jlapack-0.8~dfsg.orig/ 0000755 0001750 0001750 00000000000 11734055016 014707 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/ 0000755 0001750 0001750 00000000000 11734055016 016752 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/ 0000755 0001750 0001750 00000000000 11734055026 017542 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/ 0000755 0001750 0001750 00000000000 11734055026 020517 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/Makefile 0000644 0001750 0001750 00000000604 10616163245 022160 0 ustar osallou osallou .PHONY: util
ROOT=../..
include $(ROOT)/make.def
$(UTIL_JAR):
if test -f $(ROOT)/../util/$(UTIL_JAR); then \
cp $(ROOT)/../util/$(UTIL_JAR) .; \
else \
$(MAKE) util_deprecated;\
fi
util_deprecated: $(UTIL_CLASSES)
$(UTIL_CLASSES):
mkdir -p $(OUTDIR)
javac -d $(OUTDIR) $(UTIL_PDIR)/*.java
cd $(OUTDIR); $(JAR) cvf ../$(UTIL_JAR) .
clean:
/bin/rm -rf $(OUTDIR) $(UTIL_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/ 0000755 0001750 0001750 00000000000 11734055026 021306 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/netlib/ 0000755 0001750 0001750 00000000000 11734055026 022563 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/netlib/util/ 0000755 0001750 0001750 00000000000 11734055026 023540 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/netlib/util/EasyIn.java 0000644 0001750 0001750 00000031617 10616163246 025605 0 ustar osallou osallou package org.netlib.util;
import java.io.*;
/**
* Simple input from the keyboard for all primitive types. ver 1.0
*
* Copyright (c) Peter van der Linden, May 5 1997.
* corrected error message 11/21/97
*
* The creator of this software hereby gives you permission to:
*
* - copy the work without changing it
*
- modify the work providing you send me a copy which I can
* use in any way I want, including incorporating into this work.
*
- distribute copies of the work to the public by sale, lease,
* rental, or lending
*
- perform the work
*
- display the work
*
- fold the work into a funny hat and wear it on your head.
*
*
* This is not thread safe, not high performance, and doesn't tell EOF.
* It's intended for low-volume easy keyboard input.
* An example of use is:
*
*
* EasyIn easy = new EasyIn();
* int i = easy.readInt(); // reads an int from System.in
* float f = easy.readFloat(); // reads a float from System.in
*
*
* 2/25/98 - modified by Keith Seymour to be useful with the f2j
* translator.
*
* @author Peter van der Linden
*/
public class EasyIn {
static String line = null;
static int idx, len;
static String blank_string = " ";
/* not oringinally part of EasyIn.. I added this to make it possible
* to interleave calls to EasyIn with another input method, which
* didn't work with the previous static buffered reader.
*/
public static String myCrappyReadLine() throws java.io.IOException
{
StringBuffer sb = new StringBuffer();
int c = 0;
while(c >= 0) {
c = System.in.read();
if(c < 0)
return null;
if((char)c == '\n')
break;
sb.append((char) c);
}
return sb.toString();
}
/**
* Reset the tokenizer.
*
* @throws IOException if an input or output exception occurred.
*/
private void initTokenizer() throws IOException {
do {
line = EasyIn.myCrappyReadLine();
if(line == null)
throw new IOException("EOF");
idx = 0;
len = line.length();
} while(!hasTokens(line));
}
/**
* Checks if the string contains any tokens.
*
* @param str string to check
*
* @return true if there are tokens, false otherwise.
*/
private boolean hasTokens(String str)
{
int i, str_len;
str_len = str.length();
for(i=0;i < str_len;i++)
if(! isDelim(str.charAt(i)))
return true;
return false;
}
/**
* Checks if this character is a delimiter.
*
* @param c character to check
*
* @return true if this character is a delimiter, false otherwise.
*/
private boolean isDelim(char c)
{
return ( (c == ' ') || (c == '\t') || (c == '\r') || (c == '\n'));
}
/**
* Checks if there are more tokens.
*
* @return true if there are more tokens, false otherwise.
*/
private boolean moreTokens()
{
return ( idx < len );
}
/**
* Gets the next token.
*
* @throws IOException if an input or output exception occurred.
*
* @return the token
*/
private String getToken() throws IOException {
int begin,end;
if( (line == null) || !moreTokens() )
initTokenizer();
while( (idx < len) && isDelim(line.charAt(idx)) )
idx++;
if(idx == len) {
initTokenizer();
while( (idx < len) && isDelim(line.charAt(idx)) )
idx++;
}
begin = idx;
while( (idx < len) && !isDelim(line.charAt(idx)) )
idx++;
end = idx;
return line.substring(begin,end);
}
/**
* Reads the specified number of characters and returns a new String
* containing them.
*
* @param num_chars the number of characters to read
*
* @throws IOException if an input or output exception occurred.
*
* @return the String containing the characters read.
*/
public String readchars(int num_chars) throws IOException {
int cp_idx;
if( (line == null) || !moreTokens() )
initTokenizer();
cp_idx = idx;
if(cp_idx + num_chars < len)
{
idx += num_chars;
return( line.substring(cp_idx,cp_idx+num_chars) );
}
else
{
idx = len;
return(line.substring(cp_idx,len) + blank_string.substring(0,num_chars-(len-cp_idx)));
}
}
/**
* Reads the specified number of characters and returns a new String
* containing them. Unlike readchars(), does not throw IOException.
*
* @param num_chars the number of characters to read
*
* @return the String containing the characters read.
*/
public String readChars(int num_chars) {
try{
return readchars(num_chars);
}catch (IOException e) {
System.err.println("IO Exception in EasyIn.readChars");
return null;
}
}
/**
* Skips any tokens remaining on this line.
*/
public void skipRemaining() {
line = null; //may not be needed
idx = len;
}
/**
* Gets a boolean value from the next token.
*
* @return the boolean value
*
* @throws IOException if an input or output exception occurred.
*/
public boolean readboolean() throws IOException {
char ch = getToken().charAt(0);
if((ch == 't') || (ch == 'T'))
return true;
else
return false;
}
/**
* Gets a boolean value from the next token.
* Same as readboolean() except it does not throw IOException.
*
* @return the boolean value
*/
public boolean readBoolean() {
try {
char ch = getToken().charAt(0);
if((ch == 't') || (ch == 'T'))
return true;
else
return false;
} catch (IOException ioe) {
System.err.println("IO Exception in EasyIn.readBoolean");
return false;
}
}
/**
* Gets a byte value from the next token.
*
* @return the byte value
*
* @throws IOException if an input or output exception occurred.
*/
public byte readbyte() throws IOException {
return Byte.parseByte(getToken());
}
/**
* Gets a byte value from the next token.
* Same as readbyte() except it does not throw IOException.
*
* @return the byte value
*/
public byte readByte() {
try {
return Byte.parseByte(getToken());
} catch (IOException ioe) {
System.err.println("IO Exception in EasyIn.readByte");
return 0;
}
}
/**
* Gets a short value from the next token.
*
* @return the short value
*
* @throws IOException if an input or output exception occurred.
*/
public short readshort() throws IOException {
return Short.parseShort(getToken());
}
/**
* Gets a short value from the next token.
* Same as readshort() except it does not throw IOException.
*
* @return the short value
*/
public short readShort() {
try {
return Short.parseShort(getToken());
} catch (IOException ioe) {
System.err.println("IO Exception in EasyIn.readShort");
return 0;
}
}
/**
* Gets an integer value from the next token.
*
* @return the integer value
*
* @throws IOException if an input or output exception occurred.
*/
public int readint() throws IOException {
return Integer.parseInt(getToken());
}
/**
* Gets an integer value from the next token.
* Same as readint() except it does not throw IOException.
*
* @return the integer value
*/
public int readInt() {
try {
return Integer.parseInt(getToken());
} catch (IOException ioe) {
System.err.println("IO Exception in EasyIn.readInt");
return 0;
}
}
/**
* Gets a long integer value from the next token.
*
* @return the long integer value
*
* @throws IOException if an input or output exception occurred.
*/
public long readlong() throws IOException {
return Long.parseLong(getToken());
}
/**
* Gets a long integer value from the next token.
* Same as readlong() except it does not throw IOException.
*
* @return the long integer value
*/
public long readLong() {
try {
return Long.parseLong(getToken());
} catch (IOException ioe) {
System.err.println("IO Exception in EasyIn.readLong");
return 0L;
}
}
/**
* Gets a float value from the next token.
*
* @return the float value
*
* @throws IOException if an input or output exception occurred.
*/
public float readfloat() throws IOException {
return new Float(getToken()).floatValue();
}
/**
* Gets a float value from the next token.
* Same as readfloat() except it does not throw IOException.
*
* @return the float value
*/
public float readFloat() {
try {
return new Float(getToken()).floatValue();
} catch (IOException ioe) {
System.err.println("IO Exception in EasyIn.readFloat");
return 0.0F;
}
}
/**
* Gets a double value from the next token.
*
* @return the double value
*
* @throws IOException if an input or output exception occurred.
*/
public double readdouble() throws IOException {
String tok = getToken();
tok = tok.replace('D', 'E');
tok = tok.replace('d', 'e');
return new Double(tok).doubleValue();
}
/**
* Gets a double value from the next token.
* Same as readdouble() except it does not throw IOException.
*
* @return the double value
*/
public double readDouble() {
try {
String tok = getToken();
tok = tok.replace('D', 'E');
tok = tok.replace('d', 'e');
return new Double(tok).doubleValue();
} catch (IOException ioe) {
System.err.println("IO Exception in EasyIn.readDouble");
return 0.0;
}
}
/**
* Gets a character value from the next token.
*
* @return the character value
*
* @throws IOException if an input or output exception occurred.
*/
public char readchar() throws IOException {
return getToken().charAt(0);
}
/**
* Gets a character value from the next token.
* Same as readchar() except it does not throw IOException.
*
* @return the character value
*/
public char readChar() {
try {
return getToken().charAt(0);
} catch (IOException ioe) {
System.err.println("IO Exception in EasyIn.readChar");
return 0;
}
}
/**
* Gets a string value from the next token.
*
* @return the string value
*
* @throws IOException if an input or output exception occurred.
*/
public String readstring() throws IOException {
return EasyIn.myCrappyReadLine();
}
/**
* Gets a string value from the next token.
* Same as readstring() except it does not throw IOException.
*
* @return the string value
*/
public String readString() {
try {
return EasyIn.myCrappyReadLine();
} catch (IOException ioe) {
System.err.println("IO Exception in EasyIn.readString");
return "";
}
}
/**
* This method is just here to test the class
*/
public static void main (String args[]){
EasyIn easy = new EasyIn();
System.out.print("enter char: "); System.out.flush();
System.out.println("You entered: " + easy.readChar() );
System.out.print("enter String: "); System.out.flush();
System.out.println("You entered: " + easy.readString() );
System.out.print("enter boolean: "); System.out.flush();
System.out.println("You entered: " + easy.readBoolean() );
System.out.print("enter byte: "); System.out.flush();
System.out.println("You entered: " + easy.readByte() );
System.out.print("enter short: "); System.out.flush();
System.out.println("You entered: " + easy.readShort() );
System.out.print("enter int: "); System.out.flush();
System.out.println("You entered: " + easy.readInt() );
System.out.print("enter long: "); System.out.flush();
System.out.println("You entered: " + easy.readLong() );
System.out.print("enter float: "); System.out.flush();
System.out.println("You entered: " + easy.readFloat() );
System.out.print("enter double: "); System.out.flush();
System.out.println("You entered: " + easy.readDouble() );
}
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/netlib/util/ArraySpec.java 0000644 0001750 0001750 00000002012 10616163246 026271 0 ustar osallou osallou package org.netlib.util;
import java.util.Vector;
public class ArraySpec {
private Vector vec;
public ArraySpec(int [] arr, int offset, int len) {
vec = new Vector();
for(int i=offset; i< offset+len; i++)
vec.addElement(new Integer(arr[i]));
}
public ArraySpec(double [] arr, int offset, int len) {
vec = new Vector();
for(int i=offset; i< offset+len; i++)
vec.addElement(new Double(arr[i]));
}
public ArraySpec(float [] arr, int offset, int len) {
vec = new Vector();
for(int i=offset; i< offset+len; i++)
vec.addElement(new Float(arr[i]));
}
public ArraySpec(String [] arr, int offset, int len) {
vec = new Vector();
for(int i=offset; i< offset+len; i++)
vec.addElement(new String(arr[i]));
}
public ArraySpec(String str) {
char [] chars = str.toCharArray();
vec = new Vector();
for(int i = 0; i < chars.length; i++)
vec.addElement(new String(String.valueOf(chars[i])));
}
public Vector get_vec() {
return vec;
}
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/netlib/util/StringW.java 0000644 0001750 0001750 00000001012 10616163246 025774 0 ustar osallou osallou package org.netlib.util;
/**
* f2j object wrapper for strings.
*
* This file is part of the Fortran-to-Java (f2j) system,
* developed at the University of Tennessee.
*
* This class acts as an object wrapper for passing string
* values by reference in f2j translated files.
*
* @author Keith Seymour (seymour@cs.utk.edu)
*
*/
public class StringW {
public String val;
/**
* Create a new string wrapper.
*
* @param x the initial value
*/
public StringW(String x) {
val = x;
}
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/netlib/util/floatW.java 0000644 0001750 0001750 00000001046 10616163246 025642 0 ustar osallou osallou package org.netlib.util;
/**
* f2j object wrapper for floats.
*
* This file is part of the Fortran-to-Java (f2j) system,
* developed at the University of Tennessee.
*
* This class acts as an object wrapper for passing single
* precision floating point values by reference in f2j
* translated files.
*
* @author Keith Seymour (seymour@cs.utk.edu)
*
*/
public class floatW {
public float val;
/**
* Create a new float wrapper.
*
* @param x the initial value
*/
public floatW(float x) {
val = x;
}
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/netlib/util/intW.java 0000644 0001750 0001750 00000001002 10616163246 025317 0 ustar osallou osallou package org.netlib.util;
/**
* f2j object wrapper for integers.
*
* This file is part of the Fortran-to-Java (f2j) system,
* developed at the University of Tennessee.
*
* This class acts as an object wrapper for passing integer
* values by reference in f2j translated files.
*
* @author Keith Seymour (seymour@cs.utk.edu)
*
*/
public class intW {
public int val;
/**
* Create a new int wrapper.
*
* @param x the initial value
*/
public intW(int x) {
val = x;
}
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/netlib/util/Dummy.java 0000644 0001750 0001750 00000002707 10616163246 025506 0 ustar osallou osallou package org.netlib.util;
/**
* Placeholders for Fortran GOTO statements and labels.
*
* This file is part of the Fortran-to-Java (f2j) system,
* developed at the University of Tennessee.
*
* This class aids in the translation of goto statements.
* The code generator translates gotos and labels into calls
* to Dummy.go_to() or Dummy.label(). These calls act as
* 'placeholders' so that the gotos and labels can be found
* in the class file and converted to real branch
* instructions in the bytecode. Thus the resulting class
* file should contain no calls to Dummy.go_to() or Dummy.label().
* If so, the print statements should warn the user that the
* goto translation was not successful.
*
* @author Keith Seymour (seymour@cs.utk.edu)
*
*/
public class Dummy {
/**
* Placeholder for a Fortran GOTO statement.
*
* @param clname name of the program unit where this GOTO exists
* @param lbl the label number (target) of the GOTO
*/
public static void go_to(String clname, int lbl) {
System.err.println("Warning: Untransformed goto remaining in program! ("
+clname+", " + lbl + ")");
}
/**
* Placeholder for a Fortran label.
*
* @param clname name of the program unit where this label exists
* @param lbl the label number
*/
public static void label(String clname, int lbl) {
System.err.println("Warning: Untransformed label remaining in program! ("
+clname+", " + lbl + ")");
}
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/netlib/util/StrictUtil.java 0000644 0001750 0001750 00000017620 10616163246 026521 0 ustar osallou osallou package org.netlib.util;
import java.io.*;
/**
* StrictMath versions of various math related Fortran intrinsic functions.
*
* This file is part of the Fortran-to-Java (f2j) system,
* developed at the University of Tennessee.
*
* This class contains Strict versions of the math related utilities
* in {@link Util}.
*
* @author Keith Seymour (seymour@cs.utk.edu)
*
*/
public strictfp class StrictUtil extends Util {
/**
* Three argument integer max function.
*
* This function uses Java's StrictMath package.
*
* @param x value 1
* @param y value 2
* @param z value 3
*
* @return the largest of x, y, or z
*/
public static int max(int x, int y, int z) {
return StrictMath.max( x > y ? x : y, StrictMath.max(y,z));
}
/**
* Three argument single precision max function.
*
* This function uses Java's StrictMath package.
*
* @param x value 1
* @param y value 2
* @param z value 3
*
* @return the largest of x, y, or z
*/
public static float max(float x, float y, float z) {
return StrictMath.max( x > y ? x : y, StrictMath.max(y,z));
}
/**
* Three argument double precision max function.
*
* This function uses Java's StrictMath package.
*
* @param x value 1
* @param y value 2
* @param z value 3
*
* @return the largest of x, y, or z
*/
public static double max(double x, double y, double z) {
return StrictMath.max( x > y ? x : y, StrictMath.max(y,z));
}
/**
* Three argument integer min function.
*
* This function uses Java's StrictMath package.
*
* @param x value 1
* @param y value 2
* @param z value 3
*
* @return the smallest of x, y, or z
*/
public static int min(int x, int y, int z) {
return StrictMath.min( x < y ? x : y, StrictMath.min(y,z));
}
/**
* Three argument single precision min function.
*
* This function uses Java's StrictMath package.
*
* @param x value 1
* @param y value 2
* @param z value 3
*
* @return the smallest of x, y, or z
*/
public static float min(float x, float y, float z) {
return StrictMath.min( x < y ? x : y, StrictMath.min(y,z));
}
/**
* Three argument double precision min function.
*
* This function uses Java's StrictMath package.
*
* @param x value 1
* @param y value 2
* @param z value 3
*
* @return the smallest of x, y, or z
*/
public static double min(double x, double y, double z) {
return StrictMath.min( x < y ? x : y, StrictMath.min(y,z));
}
/**
* Base-10 logarithm function.
*
* This function uses Java's StrictMath package.
*
* @param x the value
*
* @return base-10 log of x
*/
public static double log10(double x) {
return StrictMath.log(x) / 2.30258509;
}
/**
* Base-10 logarithm function.
*
* This function uses Java's StrictMath package.
*
* @param x the value
*
* @return base-10 log of x
*/
public static float log10(float x) {
return (float) (StrictMath.log(x) / 2.30258509);
}
/**
* Fortran nearest integer (NINT) intrinsic function.
*
* Returns:
*
* - (int)(x+0.5), if x >= 0
*
- (int)(x-0.5), if x < 0
*
*
* This function uses Java's StrictMath package.
*
* @param x the floating point value
*
* @return the nearest integer to x
*/
public static int nint(float x) {
return (int) (( x >= 0 ) ? (x + 0.5) : (x - 0.5));
}
/**
* Fortran nearest integer (IDNINT) intrinsic function.
*
* Returns:
*
* - (int)(x+0.5), if x >= 0
*
- (int)(x-0.5), if x < 0
*
*
* This function uses Java's StrictMath package.
*
* @param x the double precision floating point value
*
* @return the nearest integer to x
*/
public static int idnint(double x) {
return (int) (( x >= 0 ) ? (x + 0.5) : (x - 0.5));
}
/**
* Fortran floating point transfer of sign (SIGN) intrinsic function.
*
* Returns:
*
* - abs(a1), if a2 >= 0
*
- -abs(a1), if a2 < 0
*
*
* This function uses Java's StrictMath package.
*
* @param a1 floating point value
* @param a2 sign transfer indicator
*
* @return equivalent of Fortran SIGN(a1,a2) as described above.
*/
public static float sign(float a1, float a2) {
return (a2 >= 0) ? StrictMath.abs(a1) : -StrictMath.abs(a1);
}
/**
* Fortran integer transfer of sign (ISIGN) intrinsic function.
*
* Returns:
*
* - abs(a1), if a2 >= 0
*
- -abs(a1), if a2 < 0
*
*
* This function uses Java's StrictMath package.
*
* @param a1 integer value
* @param a2 sign transfer indicator
*
* @return equivalent of Fortran ISIGN(a1,a2) as described above.
*/
public static int isign(int a1, int a2) {
return (a2 >= 0) ? StrictMath.abs(a1) : -StrictMath.abs(a1);
}
/**
* Fortran double precision transfer of sign (DSIGN) intrinsic function.
*
* Returns:
*
* - abs(a1), if a2 >= 0
*
- -abs(a1), if a2 < 0
*
*
* This function uses Java's StrictMath package.
*
* @param a1 double precision floating point value
* @param a2 sign transfer indicator
*
* @return equivalent of Fortran DSIGN(a1,a2) as described above.
*/
public static double dsign(double a1, double a2) {
return (a2 >= 0) ? StrictMath.abs(a1) : -StrictMath.abs(a1);
}
/**
* Fortran floating point positive difference (DIM) intrinsic function.
*
* Returns:
*
* - a1 - a2, if a1 > a2
*
- 0, if a1 <= a2
*
*
* This function uses Java's StrictMath package.
*
* @param a1 floating point value
* @param a2 floating point value
*
* @return equivalent of Fortran DIM(a1,a2) as described above.
*/
public static float dim(float a1, float a2) {
return (a1 > a2) ? (a1 - a2) : 0;
}
/**
* Fortran integer positive difference (IDIM) intrinsic function.
*
* Returns:
*
* - a1 - a2, if a1 > a2
*
- 0, if a1 <= a2
*
*
* This function uses Java's StrictMath package.
*
* @param a1 integer value
* @param a2 integer value
*
* @return equivalent of Fortran IDIM(a1,a2) as described above.
*/
public static int idim(int a1, int a2) {
return (a1 > a2) ? (a1 - a2) : 0;
}
/**
* Fortran double precision positive difference (DDIM) intrinsic function.
*
* Returns:
*
* - a1 - a2, if a1 > a2
*
- 0, if a1 <= a2
*
*
* This function uses Java's StrictMath package.
*
* @param a1 double precision floating point value
* @param a2 double precision floating point value
*
* @return equivalent of Fortran DDIM(a1,a2) as described above.
*/
public static double ddim(double a1, double a2) {
return (a1 > a2) ? (a1 - a2) : 0;
}
/**
* Fortran hyperbolic sine (SINH) intrinsic function.
*
* This function uses Java's StrictMath package.
*
* @param a the value to get the sine of
*
* @return the hyperbolic sine of a
*/
public static double sinh(double a) {
return ( StrictMath.exp(a) - StrictMath.exp(-a) ) * 0.5;
}
/**
* Fortran hyperbolic cosine (COSH) intrinsic function.
*
* This function uses Java's StrictMath package.
*
* @param a the value to get the cosine of
*
* @return the hyperbolic cosine of a
*/
public static double cosh(double a) {
return ( StrictMath.exp(a) + StrictMath.exp(-a) ) * 0.5;
}
/**
* Fortran hyperbolic tangent (TANH) intrinsic function.
*
* This function uses Java's StrictMath package.
*
* @param a the value to get the tangent of
*
* @return the hyperbolic tangent of a
*/
public static double tanh(double a) {
return sinh(a) / cosh(a);
}
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/netlib/util/MatConv.java 0000644 0001750 0001750 00000012763 10616163246 025765 0 ustar osallou osallou package org.netlib.util;
/**
* Conversions between one-dimensional linearized arrays and two-dimensional arays.
*
* This file is part of the Fortran-to-Java (f2j) system,
* developed at the University of Tennessee.
*
* This class contains methods for converting between the linearized
* arrays used by f2j-generated code and the more natural Java-style
* two-dimensional arrays.
*
* @author Keith Seymour (seymour@cs.utk.edu)
*
*/
public class MatConv
{
/**
* Convert a double precision two-dimensional array to
* a linearized one-dimensional array.
*
* @param m the matrix to be converted
*
* @return the linearized array
*/
public static double[] doubleTwoDtoOneD (double[][]m)
{
/* We make the assumption here that the matrices are
* square (or rectangular), to get the value of
* the second index.
*/
int ld = m.length;
double[] apimatrix = new double[ld * m[0].length];
for (int i = 0; i < ld; i++)
for (int j = 0; j < m[0].length; j++)
apimatrix[i + j * ld] = m[i][j];
return apimatrix;
}
/**
* Convert a double precision linearized one-dimensional array
* to a two-dimensional array.
*
* @param vec the linearized array to be converted
* @param ld leading dimension of the array
*
* @return the two-dimensional array
*/
public static double[][] doubleOneDtoTwoD(double [] vec, int ld)
{
int i,j;
double [][] mat = new double [ld][vec.length / ld];
for (i = 0; i < ld; i++)
for (j = 0; j < mat[0].length; j++)
mat[i][j] = vec[i + j * ld];
return mat;
}
/**
* Convert a single precision two-dimensional array to
* a linearized one-dimensional array.
*
* @param m the matrix to be converted
*
* @return the linearized array
*/
public static float[] floatTwoDtoOneD (float[][]m)
{
/* We make the assumption here that the matrices are
* square (or rectangular), to get the value of
* the second index.
*/
int ld = m.length;
float[] apimatrix = new float[ld * m[0].length];
for (int i = 0; i < ld; i++)
for (int j = 0; j < m[0].length; j++)
apimatrix[i + j * ld] = m[i][j];
return apimatrix;
}
/**
* Convert a single precision linearized one-dimensional array
* to a two-dimensional array.
*
* @param vec the linearized array to be converted
* @param ld leading dimension of the array
*
* @return the two-dimensional array
*/
public static float[][] floatOneDtoTwoD(float [] vec, int ld)
{
int i,j;
float [][] mat = new float [ld][vec.length / ld];
for (i = 0; i < ld; i++)
for (j = 0; j < mat[0].length; j++)
mat[i][j] = vec[i + j * ld];
return mat;
}
/**
* Convert an integer two-dimensional array to
* a linearized one-dimensional array.
*
* @param m the matrix to be converted
*
* @return the linearized array
*/
public static int[] intTwoDtoOneD (int[][]m)
{
/* We make the assumption here that the matrices are
* square (or rectangular), to get the value of
* the second index.
*/
int ld = m.length;
int[] apimatrix = new int[ld * m[0].length];
for (int i = 0; i < ld; i++)
for (int j = 0; j < m[0].length; j++)
apimatrix[i + j * ld] = m[i][j];
return apimatrix;
}
/**
* Convert an integer linearized one-dimensional array
* to a two-dimensional array.
*
* @param vec the linearized array to be converted
* @param ld leading dimension of the array
*
* @return the two-dimensional array
*/
public static int[][] intOneDtoTwoD(int [] vec, int ld)
{
int i,j;
int [][] mat = new int [ld][vec.length / ld];
for (i = 0; i < ld; i++)
for (j = 0; j < mat[0].length; j++)
mat[i][j] = vec[i + j * ld];
return mat;
}
/**
* Copies a linearized array into an already allocated two-dimensional
* matrix. This is typically called from the simplified wrappers
* after the raw routine has been called and the results need to be
* copied back into the Java-style two-dimensional matrix.
*
* @param mat destination matrix
* @param vec source array
*/
public static void copyOneDintoTwoD(double [][]mat, double[]vec)
{
int i,j;
int ld = mat.length;
for (i = 0; i < ld; i++)
for (j = 0; j < mat[0].length; j++)
mat[i][j] = vec[i + j * ld];
}
/**
* Copies a linearized array into an already allocated two-dimensional
* matrix. This is typically called from the simplified wrappers
* after the raw routine has been called and the results need to be
* copied back into the Java-style two-dimensional matrix.
*
* @param mat destination matrix
* @param vec source array
*/
public static void copyOneDintoTwoD(float [][]mat, float[]vec)
{
int i,j;
int ld = mat.length;
for (i = 0; i < ld; i++)
for (j = 0; j < mat[0].length; j++)
mat[i][j] = vec[i + j * ld];
}
/**
* Copies a linearized array into an already allocated two-dimensional
* matrix. This is typically called from the simplified wrappers
* after the raw routine has been called and the results need to be
* copied back into the Java-style two-dimensional matrix.
*
* @param mat destination matrix
* @param vec source array
*/
public static void copyOneDintoTwoD(int [][]mat, int[]vec)
{
int i,j;
int ld = mat.length;
for (i = 0; i < ld; i++)
for (j = 0; j < mat[0].length; j++)
mat[i][j] = vec[i + j * ld];
}
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/netlib/util/Util.java 0000644 0001750 0001750 00000031005 10616163246 025321 0 ustar osallou osallou package org.netlib.util;
import java.io.*;
import java.util.Vector;
import org.j_paine.formatter.*;
/**
* Implementations of various Fortran intrinsic functions.
*
* This file is part of the Fortran-to-Java (f2j) system,
* developed at the University of Tennessee.
*
* This class contains various helper routines for f2j-generated code.
* These routines are primarily implemented for handling Fortran intrinsic
* functions.
*
* @author Keith Seymour (seymour@cs.utk.edu)
*
*/
public class Util {
/**
* Inserts a string into a substring of another string.
*
* This method handles situations in which the lhs of an
* assignment statement is a substring operation. For example:
*
*
* a(3:4) = 'hi'
*
*
* We haven't figured out an elegant way to do this with Java Strings,
* but we do handle it, as follows:
*
*
*
* a = new StringW(
* a.val.substring(0,E1-1) +
* "hi".substring(0,E2-E1+1) +
* a.val.substring(E2,a.val.length())
* );
*
*
* Where E1 is the expression representing the starting index of the substring
* and E2 is the expression representing the ending index of the substring
*
* The resulting code looks pretty bad because we have to be
* prepared to handle rhs strings that are too big to fit in
* the lhs substring.
*
* @param x dest (string to be inserted into)
* @param y source (substring to insert into 'x')
* @param E1 expression representing the start of the substring
* @param E2 expression representing the end of the substring
*
* @return the string containing the complete string after inserting the
* substring
*/
public static String stringInsert(String x, String y, int E1, int E2) {
String tmp;
tmp = new String(
x.substring(0,E1-1) +
y.substring(0,E2-E1+1) +
x.substring(E2,x.length()));
return tmp;
}
/**
* Inserts a string into a single character substring of another string.
*
* @param x dest (string to be inserted into)
* @param y source (substring to insert into 'x')
* @param E1 expression representing the index of the character
*
* @return the string containing the complete string after inserting the
* substring
*/
public static String stringInsert(String x, String y, int E1) {
return stringInsert(x, y, E1, E1);
}
/**
* Returns a string representation of the character at the given index.
* Note: this is based on the Fortran index (1..N).
*
* @param s the string
* @param idx the index
*
* @return new string containing a single character (from s[idx])
*/
public static String strCharAt(String s, int idx) {
return String.valueOf(s.charAt(idx-1));
}
/**
* Three argument integer max function.
*
* @param x value 1
* @param y value 2
* @param z value 3
*
* @return the largest of x, y, or z
*/
public static int max(int x, int y, int z) {
return Math.max( x > y ? x : y, Math.max(y,z));
}
/**
* Three argument single precision max function.
*
* @param x value 1
* @param y value 2
* @param z value 3
*
* @return the largest of x, y, or z
*/
public static float max(float x, float y, float z) {
return Math.max( x > y ? x : y, Math.max(y,z));
}
/**
* Three argument double precision max function.
*
* @param x value 1
* @param y value 2
* @param z value 3
*
* @return the largest of x, y, or z
*/
public static double max(double x, double y, double z) {
return Math.max( x > y ? x : y, Math.max(y,z));
}
/**
* Three argument integer min function.
*
* @param x value 1
* @param y value 2
* @param z value 3
*
* @return the smallest of x, y, or z
*/
public static int min(int x, int y, int z) {
return Math.min( x < y ? x : y, Math.min(y,z));
}
/**
* Three argument single precision min function.
*
* @param x value 1
* @param y value 2
* @param z value 3
*
* @return the smallest of x, y, or z
*/
public static float min(float x, float y, float z) {
return Math.min( x < y ? x : y, Math.min(y,z));
}
/**
* Three argument double precision min function.
*
* @param x value 1
* @param y value 2
* @param z value 3
*
* @return the smallest of x, y, or z
*/
public static double min(double x, double y, double z) {
return Math.min( x < y ? x : y, Math.min(y,z));
}
/**
* Base-10 logarithm function.
*
* @param x the value
*
* @return base-10 log of x
*/
public static double log10(double x) {
return Math.log(x) / 2.30258509;
}
/**
* Base-10 logarithm function.
*
* @param x the value
*
* @return base-10 log of x
*/
public static float log10(float x) {
return (float) (Math.log(x) / 2.30258509);
}
/**
* Fortran nearest integer (NINT) intrinsic function.
*
* Returns:
*
* - (int)(x+0.5), if x >= 0
*
- (int)(x-0.5), if x < 0
*
*
* @param x the floating point value
*
* @return the nearest integer to x
*/
public static int nint(float x) {
return (int) (( x >= 0 ) ? (x + 0.5) : (x - 0.5));
}
/**
* Fortran nearest integer (IDNINT) intrinsic function.
*
* Returns:
*
* - (int)(x+0.5), if x >= 0
*
- (int)(x-0.5), if x < 0
*
*
* @param x the double precision floating point value
*
* @return the nearest integer to x
*/
public static int idnint(double x) {
return (int) (( x >= 0 ) ? (x + 0.5) : (x - 0.5));
}
/**
* Fortran floating point transfer of sign (SIGN) intrinsic function.
*
* Returns:
*
* - abs(a1), if a2 >= 0
*
- -abs(a1), if a2 < 0
*
*
* @param a1 floating point value
* @param a2 sign transfer indicator
*
* @return equivalent of Fortran SIGN(a1,a2) as described above.
*/
public static float sign(float a1, float a2) {
return (a2 >= 0) ? Math.abs(a1) : -Math.abs(a1);
}
/**
* Fortran integer transfer of sign (ISIGN) intrinsic function.
*
* Returns:
*
* - abs(a1), if a2 >= 0
*
- -abs(a1), if a2 < 0
*
*
* @param a1 integer value
* @param a2 sign transfer indicator
*
* @return equivalent of Fortran ISIGN(a1,a2) as described above.
*/
public static int isign(int a1, int a2) {
return (a2 >= 0) ? Math.abs(a1) : -Math.abs(a1);
}
/**
* Fortran double precision transfer of sign (DSIGN) intrinsic function.
*
* Returns:
*
* - abs(a1), if a2 >= 0
*
- -abs(a1), if a2 < 0
*
*
* @param a1 double precision floating point value
* @param a2 sign transfer indicator
*
* @return equivalent of Fortran DSIGN(a1,a2) as described above.
*/
public static double dsign(double a1, double a2) {
return (a2 >= 0) ? Math.abs(a1) : -Math.abs(a1);
}
/**
* Fortran floating point positive difference (DIM) intrinsic function.
*
* Returns:
*
* - a1 - a2, if a1 > a2
*
- 0, if a1 <= a2
*
*
* @param a1 floating point value
* @param a2 floating point value
*
* @return equivalent of Fortran DIM(a1,a2) as described above.
*/
public static float dim(float a1, float a2) {
return (a1 > a2) ? (a1 - a2) : 0;
}
/**
* Fortran integer positive difference (IDIM) intrinsic function.
*
* Returns:
*
* - a1 - a2, if a1 > a2
*
- 0, if a1 <= a2
*
*
* @param a1 integer value
* @param a2 integer value
*
* @return equivalent of Fortran IDIM(a1,a2) as described above.
*/
public static int idim(int a1, int a2) {
return (a1 > a2) ? (a1 - a2) : 0;
}
/**
* Fortran double precision positive difference (DDIM) intrinsic function.
*
* Returns:
*
* - a1 - a2, if a1 > a2
*
- 0, if a1 <= a2
*
*
* @param a1 double precision floating point value
* @param a2 double precision floating point value
*
* @return equivalent of Fortran DDIM(a1,a2) as described above.
*/
public static double ddim(double a1, double a2) {
return (a1 > a2) ? (a1 - a2) : 0;
}
/**
* Fortran hyperbolic sine (SINH) intrinsic function.
*
* @param a the value to get the sine of
*
* @return the hyperbolic sine of a
*/
public static double sinh(double a) {
return ( Math.exp(a) - Math.exp(-a) ) * 0.5;
}
/**
* Fortran hyperbolic cosine (COSH) intrinsic function.
*
* @param a the value to get the cosine of
*
* @return the hyperbolic cosine of a
*/
public static double cosh(double a) {
return ( Math.exp(a) + Math.exp(-a) ) * 0.5;
}
/**
* Fortran hyperbolic tangent (TANH) intrinsic function.
*
* @param a the value to get the tangent of
*
* @return the hyperbolic tangent of a
*/
public static double tanh(double a) {
return sinh(a) / cosh(a);
}
/**
* Pauses execution temporarily.
*
* I think this was an implementation dependent feature of Fortran 77.
*/
public static void pause() {
pause(null);
}
/**
* Pauses execution temporarily.
*
* I think this was an implementation dependent feature of Fortran 77.
*
* @param msg the message to be printed before pausing. if null, no
* message will be printed.
*/
public static void pause(String msg) {
if(msg != null)
System.err.println("PAUSE: " + msg);
else
System.err.print("PAUSE: ");
System.err.println("To resume execution, type: go");
System.err.println("Any other input will terminate the program.");
BufferedReader in = new BufferedReader(new InputStreamReader(System.in));
String response = null;
try {
response = in.readLine();
} catch (IOException e) {
response = null;
}
if( (response == null) || !response.equals("go")) {
System.err.println("STOP");
System.exit(0);
}
}
/**
* Formatted write.
*/
public static void f77write(String fmt, Vector v)
{
if(fmt == null) {
f77write(v);
return;
}
try {
Formatter f = new Formatter(fmt);
Vector newvec = processVector(v);
f.write( newvec, System.out );
System.out.println();
}
catch ( Exception e ) {
String m = e.getMessage();
if(m != null)
System.out.println(m);
else
System.out.println();
}
}
/**
* Unformatted write.
*/
public static void f77write(Vector v)
{
java.util.Enumeration e;
Object o;
Vector newvec = processVector(v);
e = newvec.elements();
/* fortran seems to prepend a space before the first
* unformatted element. since non-string types get
* a string prepended in the loop below, we only
* do it for strings here.
*/
if(e.hasMoreElements()) {
o = e.nextElement();
if(o instanceof String)
System.out.print(" ");
output_unformatted_element(o);
}
while(e.hasMoreElements())
output_unformatted_element(e.nextElement());
System.out.println();
}
private static void output_unformatted_element(Object o) {
if(o instanceof Boolean) {
/* print true/false as T/F like fortran does */
if(((Boolean) o).booleanValue())
System.out.print(" T");
else
System.out.print(" F");
}
else if((o instanceof Float) || (o instanceof Double))
System.out.print(" " + o); // two spaces
else if(o instanceof String)
System.out.print(o);
else
System.out.print(" " + o); // one space
}
public static int f77read(String fmt, Vector v)
{
try {
Formatter f = new Formatter(fmt);
f.read( v, new DataInputStream(System.in) );
}
catch ( EndOfFileWhenStartingReadException eof_exc) {
return 0;
}
catch ( Exception e ) {
String m = e.getMessage();
if(m != null)
System.out.println(m);
else
System.out.println("Warning: READ exception.");
return -1;
}
return v.size();
}
/**
* Expands array elements into separate entries in the Vector.
*
*/
static Vector processVector(Vector v)
{
java.util.Enumeration e;
Vector newvec = new Vector();
for(e = v.elements(); e.hasMoreElements() ;) {
Object el = e.nextElement();
if(el instanceof ArraySpec)
newvec.addAll(((ArraySpec)el).get_vec());
else
newvec.addElement(el);
}
return newvec;
}
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/netlib/util/booleanW.java 0000644 0001750 0001750 00000001026 10616163246 026152 0 ustar osallou osallou package org.netlib.util;
/**
* f2j object wrapper for booleans.
*
* This file is part of the Fortran-to-Java (f2j) system,
* developed at the University of Tennessee.
*
* This class acts as an object wrapper for passing boolean
* values by reference in f2j translated files.
*
* @author Keith Seymour (seymour@cs.utk.edu)
*
*/
public class booleanW {
public boolean val;
/**
* Create a new boolean wrapper.
*
* @param x the initial value
*/
public booleanW(boolean x) {
val = x;
}
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/netlib/util/Etime.java 0000644 0001750 0001750 00000003624 10616163246 025455 0 ustar osallou osallou package org.netlib.util;
/**
* Implementation of Fortran ETIME intrinsic.
*
* This file is part of the Fortran-to-Java (f2j) system,
* developed at the University of Tennessee.
*
* This class implements the Fortran 77 ETIME intrinsic.
* ETIME is supposed to provide the CPU time for the
* process since the start of execution. Currently,
* Java doesn't have a similar method, so we use this
* cheesy simulation:
*
* - f2j inserts a call to Etime.etime() at the beginning
* of the program.
*
- on the first call, record the current time
*
- on subsequent calls, return the difference
* between the time of the current call and the starting
* time.
*
* Essentially, this version of etime returns the
* wall-clock time elapsed since the beginning of
* execution.
*
* @author Keith Seymour (seymour@cs.utk.edu)
*
*/
public class Etime {
private static int call_num = 0;
private static long start_time = 0;
/**
* Initializes the timer.
*/
public static void etime()
{
float [] dummy = new float[2];
etime(dummy,0);
}
/**
* Get the elapsed time. Sets the first element of the
* array 't' to the elapsed time. This is also the
* return value.
*
* @param t Two-element array of times. The first
* element should be user time. The second element
* should be system time. Currently these are set
* the same, though.
* @param t_offset Offset from t. Normally zero.
*
* @return first element of t.
*/
public static float etime(float [] t, int t_offset)
{
if(call_num++ == 0)
{
start_time = System.currentTimeMillis();
t[0 + t_offset] = 0.0f;
t[1 + t_offset] = 0.0f;
return 0.0f;
}
t[0 + t_offset]=(float)(System.currentTimeMillis() - start_time) / 1000.0f;
t[1 + t_offset] = t[0 + t_offset];
return t[0 + t_offset];
}
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/netlib/util/Second.java 0000644 0001750 0001750 00000002375 10616163246 025627 0 ustar osallou osallou package org.netlib.util;
/**
* Implementation of Fortran SECOND intrinsic function.
*
* This file is part of the Fortran-to-Java (f2j) system,
* developed at the University of Tennessee.
*
* This class implements the Fortran 77 SECOND intrinsic.
* SECOND is supposed to provide the CPU time for the
* process since the start of execution. Currently,
* Java doesn't have a similar method, so we use this
* cheesy simulation:
*
* - f2j inserts a call at the beginning of the program
* to record the start time.
*
- on the first call, record the current time.
*
- on subsequent calls, return the difference
* between the current call time and the starting
* time.
*
* Essentially, this version of etime returns the
* wall-clock time elapsed since the beginning of
* execution.
*
* @author Keith Seymour (seymour@cs.utk.edu)
*
*/
public class Second {
/**
* Supposed to return the elapsed CPU time since the beginning of
* program execution. Currently implemented as wall clock time.
*
* @return the elapsed time.
*/
public static float second()
{
float [] tarray= new float[2];
Etime.etime();
Etime.etime(tarray,0);
return tarray[0];
}
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/netlib/util/doubleW.java 0000644 0001750 0001750 00000001054 10616163246 026006 0 ustar osallou osallou package org.netlib.util;
/**
* f2j object wrapper for doubles.
*
* This file is part of the Fortran-to-Java (f2j) system,
* developed at the University of Tennessee.
*
* This class acts as an object wrapper for passing double
* precision floating point values by reference in f2j
* translated files.
*
* @author Keith Seymour (seymour@cs.utk.edu)
*
*/
public class doubleW {
public double val;
/**
* Create a new double wrapper.
*
* @param x the initial value
*/
public doubleW(double x) {
val = x;
}
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/j_paine/ 0000755 0001750 0001750 00000000000 11734055026 022713 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/j_paine/formatter/ 0000755 0001750 0001750 00000000000 11734055026 024716 5 ustar osallou osallou ././@LongLink 0000000 0000000 0000000 00000000153 00000000000 011564 L ustar root root jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/j_paine/formatter/EndOfFileWhenStartingReadException.java jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/j_paine/formatter/EndOfFileWhenStartingReadExceptio0000644 0001750 0001750 00000001423 10616163245 033270 0 ustar osallou osallou package org.j_paine.formatter;
public class EndOfFileWhenStartingReadException extends InputFormatException
{
public EndOfFileWhenStartingReadException( int vecptr,
String format,
String line,
int line_number
)
{
this( "End of file when starting read of formatted data:\n" +
" Index = " + vecptr + "\n" +
" Format = " + format + "\n" +
"Last line was number " + line_number + ":\n" +
line
);
}
public EndOfFileWhenStartingReadException( String s )
{
super( s );
}
public EndOfFileWhenStartingReadException( )
{
super( );
}
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/j_paine/formatter/Formatter.java 0000644 0001750 0001750 00000131003 10616163245 027523 0 ustar osallou osallou /* Formatter.java */
package org.j_paine.formatter;
import java.io.DataInputStream;
import java.io.IOException;
import java.io.PrintStream;
import java.io.StringBufferInputStream;
import java.util.Hashtable;
import java.util.Vector;
/* This class holds a Format, and has methods for reading and
writing data against it.
*/
public class Formatter
{
private Format format = null;
private FormatMap format_map = null;
public Formatter( String format ) throws InvalidFormatException
{
this( new Format(format) );
}
public Formatter( Format format )
{
this.format = format;
}
public void setFormatMap( FormatMap format_map )
{
this.format_map = format_map;
}
public void write( Vector v, PrintStream out )
throws OutputFormatException
{
FormatX dummy_el = new FormatX();
FormatOutputList vp = new VectorAndPointer( v );
while(true) {
try {
this.format.write( vp, out );
vp.checkCurrentElementForWrite(dummy_el);
out.println();
}catch(EndOfVectorOnWriteException e) {
break;
}
}
}
public void write( int i, PrintStream out )
throws OutputFormatException
{
write( new Integer(i), out );
}
public void write( long l, PrintStream out )
throws OutputFormatException
{
write( new Long(l), out );
}
public void write( float f, PrintStream out )
throws OutputFormatException
{
write( new Float(f), out );
}
public void write( double d, PrintStream out )
throws OutputFormatException
{
write( new Double(d), out );
}
public void write( Object o, PrintStream out )
throws OutputFormatException
{
Vector v = new Vector();
v.addElement( o );
write( v, out );
}
public void read( Vector v, DataInputStream in )
throws InputFormatException
{
FormatInputList vp = new VectorAndPointer( v );
InputStreamAndBuffer inb = new InputStreamAndBuffer(in);
this.format.read( vp, inb, this.format_map );
}
public void read( Vector v, Hashtable ht, DataInputStream in )
throws InputFormatException
{
FormatInputList vp = new StringsHashtableAndPointer( v, ht );
InputStreamAndBuffer inb = new InputStreamAndBuffer(in);
this.format.read( vp, inb, this.format_map );
}
public void read( String[] s, Hashtable ht, DataInputStream in )
throws InputFormatException
{
Vector v = new Vector();
for ( int i = 0; i getWidth()) )
return s.substring(0, getWidth());
else {
if(getWidth() > s.length()) {
char [] pad = new char[getWidth() - s.length()];
for(int i=0;i 0) {
char [] pad = new char[len];
for(int i=0;i getWidth() )
throw new NumberTooWideOnWriteException( (Number)o,
vecptr,
this.toString()
);
else
return s;
}
else if(o instanceof String) {
return convertToString(new Integer((int) (((String)o).charAt(0))), vecptr);
}
else
throw new IllegalObjectOnWriteException( o,
vecptr,
this.toString()
);
}
/* vp and in are used only in generating error messages.
*/
Object convertFromString( String s,
FormatInputList vp,
InputStreamAndBuffer in
)
throws InvalidNumberOnReadException
{
/* Parse the string to check it's a valid number,
and convert if so.
*/
NumberParser np =
Parsers.theParsers().number_parser;
np.ReInit( new StringBufferInputStream(s) );
try {
int start = np.Integer();
Long l = new Long( s.substring(start) );
return l;
}
catch ( ParseException e ) {
throw new InvalidNumberOnReadException( s,
vp.getPtr(),
this.toString(),
in.getLineErrorReport(),
e.getMessage()
);
}
catch ( TokenMgrError e ) {
throw new InvalidNumberOnReadException( s,
vp.getPtr(),
this.toString(),
in.getLineErrorReport(),
e.getMessage()
);
}
}
public String toString()
{
return "I"+getWidth();
}
}
class FormatL extends FormatIOElement
{
public FormatL( int w )
{
setWidth( w );
}
String convertToString( Object o, int vecptr )
throws IllegalObjectOnWriteException,
NumberTooWideOnWriteException
{
String s;
/* Convert the number to a string. */
if ( o instanceof Boolean ) {
char [] b = new char[getWidth()];
int i;
for(i=0;i getWidth() )
throw new NumberTooWideOnWriteException( (Number)o,
vecptr,
this.toString()
);
else
return s;
}
else
throw new IllegalObjectOnWriteException( o,
vecptr,
this.toString()
);
}
/* vp and in are used only in generating error messages.
*/
Object convertFromString( String s,
FormatInputList vp,
InputStreamAndBuffer in
)
throws InvalidNumberOnReadException
{
/* Parse the string to check it's a valid number,
and convert if so.
*/
NumberParser np =
Parsers.theParsers().number_parser;
np.ReInit( new StringBufferInputStream(s) );
try {
int start = np.Boolean();
char brep = s.substring(start).charAt(0);
Boolean b;
if(brep == 't' || brep == 'T')
b = new Boolean(true);
else if(brep == 'f' || brep == 'F')
b = new Boolean(false);
else
throw new ParseException("bad logical value");
return b;
}
catch ( ParseException e ) {
throw new InvalidNumberOnReadException( s,
vp.getPtr(),
this.toString(),
in.getLineErrorReport(),
e.getMessage()
);
}
catch ( TokenMgrError e ) {
throw new InvalidNumberOnReadException( s,
vp.getPtr(),
this.toString(),
in.getLineErrorReport(),
e.getMessage()
);
}
}
public String toString()
{
return "L"+getWidth();
}
}
/* This class represents an Fw.d format element.
Numbers should be output with d decimal places.
*/
class FormatF extends FormatIOElement
{
private int d;
public FormatF( int w, int d )
{
setWidth( w );
this.d = d;
}
String convertToString( Object o, int vecptr )
throws IllegalObjectOnWriteException,
NumberTooWideOnWriteException
{
String s;
/* Convert the number to a string. */
if ( o instanceof Integer || o instanceof Long ||
o instanceof Float || o instanceof Double ) {
CJFormat cjf = new CJFormat();
cjf.setWidth( getWidth() );
cjf.setPrecision( this.d );
cjf.setPre( "" );
cjf.setPost( "" );
cjf.setLeadingZeroes( false );
cjf.setShowPlus( false );
cjf.setAlternate( false );
cjf.setShowSpace( false );
cjf.setLeftAlign( false );
cjf.setFmt( 'f' );
s = cjf.form( ((Number)o).doubleValue() );
/* Throw an exception if the string won't fit. */
if ( s.length() > getWidth() )
throw new NumberTooWideOnWriteException( (Number)o,
vecptr,
this.toString()
);
else
return s;
}
else
throw new IllegalObjectOnWriteException( o,
vecptr,
this.toString()
);
}
/* vp and in are used only in generating error messages.
*/
Object convertFromString( String s,
FormatInputList vp,
InputStreamAndBuffer in
)
throws InvalidNumberOnReadException
{
/* Parse the string to check it's a valid number,
and convert if so.
*/
NumberParser np =
Parsers.theParsers().number_parser;
np.ReInit( new StringBufferInputStream(s) );
try {
int start = np.Float();
Double d = new Double( s.substring(start) );
return d;
}
catch ( ParseException e ) {
throw new InvalidNumberOnReadException( s,
vp.getPtr(),
this.toString(),
in.getLineErrorReport(),
e.getMessage()
);
}
catch ( TokenMgrError e ) {
throw new InvalidNumberOnReadException( s,
vp.getPtr(),
this.toString(),
in.getLineErrorReport(),
e.getMessage()
);
}
}
public String toString()
{
return "F"+getWidth()+"."+this.d;
}
}
/* This class represents an Ew.d format element.
Numbers should be output as
s0.dd...ddEsdd
where s is a sign.
*/
class FormatE extends FormatIOElement
{ int d;
public FormatE( int w, int d )
{
setWidth( w );
this.d = d;
}
String convertToString( Object o, int vecptr )
throws IllegalObjectOnWriteException,
NumberTooWideOnWriteException
{
String s;
/* Convert the number to a string. */
if ( o instanceof Integer || o instanceof Long ||
o instanceof Float || o instanceof Double ) {
CJFormat cjf = new CJFormat();
cjf.setWidth( getWidth() );
cjf.setPrecision( this.d );
cjf.setPre( "" );
cjf.setPost( "" );
cjf.setLeadingZeroes( false );
cjf.setShowPlus( false );
cjf.setAlternate( false );
cjf.setShowSpace( false );
cjf.setLeftAlign( false );
cjf.setFmt( 'E' );
s = cjf.form( ((Number)o).doubleValue() );
/* Throw an exception if the string won't fit. */
if ( s.length() > getWidth() )
throw new NumberTooWideOnWriteException( (Number)o,
vecptr,
this.toString()
);
else
return s;
}
else
throw new IllegalObjectOnWriteException( o,
vecptr,
this.toString()
);
}
/* vp and in are used only in generating error messages.
*/
Object convertFromString( String s,
FormatInputList vp,
InputStreamAndBuffer in
)
throws InvalidNumberOnReadException
{
/* Parse the string to check it's a valid number,
and convert if so.
*/
NumberParser np =
Parsers.theParsers().number_parser;
np.ReInit( new StringBufferInputStream(s) );
try {
int start = np.Float();
Double d = new Double( s.substring(start) );
return d;
}
catch ( ParseException e ) {
throw new InvalidNumberOnReadException( s,
vp.getPtr(),
this.toString(),
in.getLineErrorReport(),
e.getMessage()
);
}
catch ( TokenMgrError e ) {
throw new InvalidNumberOnReadException( s,
vp.getPtr(),
this.toString(),
in.getLineErrorReport(),
e.getMessage()
);
}
}
public String toString()
{
return "E"+getWidth()+"."+this.d;
}
}
/* This class represents an / item.
*/
class FormatSlash extends FormatElement
{
public void write( FormatOutputList vp, PrintStream out )
{
out.println();
}
public void read( FormatInputList vp,
InputStreamAndBuffer in,
FormatMap format_map
)
throws InputFormatException
{
in.readLine( vp.getPtr(), this );
}
public String toString()
{
return "/";
}
}
/* This class represents an embedded literal, e.g. 'Title'.
toString() does not yet handle embedded quotes.
*/
class FormatString extends FormatElement
{
private String s;
public FormatString( String s )
{
this.s = s;
}
public void write( FormatOutputList vp, PrintStream out )
{
out.print(this.s);
}
public void read( FormatInputList vp,
InputStreamAndBuffer in,
FormatMap format_map
)
throws InputFormatException
{
String s = in.getSlice( this.s.length(), vp.getPtr(), this );
if ( !( this.s.equals(s) ) )
throw new UnmatchedStringOnReadException( s,
vp.getPtr(),
this.toString(),
in.getLineErrorReport()
);
in.advance( this.s.length() );
}
public String toString()
{
return "'" + this.s + "'";
}
}
/* This class represents a mapping from input data. We use it to specify,
for example, that on input, an "X" should be replaced by a "0" before
being interpreted by the formatted input routines.
The user must provide an instance of this class, with getMapping
defined. getMapping should return either null, if the input string
is to be left as it is, or a replacement string.
*/
abstract class FormatMap
{
public abstract String getMapping( String in );
}
interface FormatOutputList
{
boolean hasCurrentElement();
void checkCurrentElementForWrite( FormatElement format_element )
throws EndOfVectorOnWriteException;
Object getCurrentElement();
Object getCurrentElementAndAdvance();
/* Returns the current pointer.
Used only in generating error messages.
*/
int getPtr();
}
interface FormatInputList
{
/* format_element and in are only for generating error messages.
*/
void checkCurrentElementForRead( FormatElement format_element,
InputStreamAndBuffer in
)
throws InputFormatException;
// If the list is a VectorAndPointer, it won't throw an exception.
// If it is a StringsHashtableAndPointer, it will throw a
// EndOfKeyVectorOnReadException.
/* Puts o into the input list and advances its pointer.
Must be defined for each subclass.
format_element and in are only for generating error messages.
*/
void putElementAndAdvance( Object o,
FormatElement format_element,
InputStreamAndBuffer in
)
throws InputFormatException;
/* Returns the current pointer.
Used only in generating error messages.
*/
int getPtr();
}
/* This class represents a Vector and a current-element pointer.
We use it when outputting or inputting a Vector against a format:
the pointer keeps track of the current element being output, and
can be incremented by the format write and read methods.
*/
class VectorAndPointer implements FormatInputList, FormatOutputList
{
private Vector v = null;
private int vecptr = 0;
// On output, vecptr points at the next element to be used.
// On input, it points at the next free slot to be filled.
public VectorAndPointer( Vector v )
{
this.v = v;
}
public VectorAndPointer()
{
this.v = new Vector();
}
public boolean hasCurrentElement()
{
return ( this.vecptr < this.v.size() );
}
public void checkCurrentElementForWrite( FormatElement format_element )
throws EndOfVectorOnWriteException
{
if ( !hasCurrentElement() )
throw new EndOfVectorOnWriteException( this.vecptr,
format_element.toString()
);
}
/* Checks that the current element in the input list is OK and
throws an exception if not. For this implementation of
FormatInputList, there are no error conditions - we
introduced the method for the StringHashtableAndPointer class,
and need it here for compatibility.
format_element and in are only for generating error messages.
*/
public void checkCurrentElementForRead( FormatElement format_element,
InputStreamAndBuffer in
)
{
}
public Object getCurrentElement()
{
return this.v.elementAt( this.vecptr );
}
public Object getCurrentElementAndAdvance()
{
this.vecptr = this.vecptr+1;
return this.v.elementAt( this.vecptr-1 );
}
/* Puts o into the input list and advances its pointer.
format_element and in are only for generating error messages,
and not used in this implementation, since no error conditions
can arise.
*/
public void putElementAndAdvance( Object o,
FormatElement format_element,
InputStreamAndBuffer in
)
{
this.v.addElement(o);
this.vecptr = this.vecptr + 1;
}
public void advance()
{
this.vecptr = this.vecptr + 1;
}
/* Returns the current pointer.
Used only in generating error messages.
*/
public int getPtr()
{
return this.vecptr;
}
}
/* This class represents a Vector of Strings and a current-element pointer.
We use it when inputting data against a format.
*/
class StringsHashtableAndPointer implements FormatInputList
{
private VectorAndPointer vp;
private Hashtable ht;
public StringsHashtableAndPointer( Vector strings, Hashtable ht )
{
this.vp = new VectorAndPointer( strings );
this.ht = ht;
}
/* Checks that there is a current element in the key vector, and
throws an exception if not.
format_element and in are only for generating error messages.
*/
public void checkCurrentElementForRead( FormatElement format_element,
InputStreamAndBuffer in
)
throws EndOfKeyVectorOnReadException
{
if ( !(this.vp.hasCurrentElement() ) )
throw new EndOfKeyVectorOnReadException( this.vp.getPtr(),
format_element.toString(),
in.getLineErrorReport()
);
}
/* Puts o into the input list and advances its pointer.
In this implementation, that means getting the current key,
putting o into an appropriate hashtable slot, and advancing
the pointer in the vector of keys.
format_element and in are only for generating error messages.
*/
public void putElementAndAdvance( Object o,
FormatElement format_element,
InputStreamAndBuffer in
)
throws KeyNotStringOnReadException
{
Object current_key = this.vp.getCurrentElement();
if ( current_key instanceof String ) {
this.ht.put( (String)current_key, o );
this.vp.advance();
}
else
throw new KeyNotStringOnReadException( current_key,
this.vp.getPtr(),
format_element.toString(),
in.getLineErrorReport()
);
}
/* Returns the current pointer.
Used only in generating error messages.
*/
public int getPtr()
{
return this.vp.getPtr();
}
}
/* This class holds an input stream and a line buffer.
*/
class InputStreamAndBuffer
{
private DataInputStream in;
// The stream we read from.
private String line;
// The line just read.
private int ptr;
// Initialised to 0 after reading a line. Index of the next
// character to use in line.
private int line_number;
// Initially 0. Is incremented each time a line is read, so
// the first line read is number 1.
private boolean nothing_read;
// Initially true. Is set false after reading a line. We
// use this so that the first call of getSlice
// knows to read a line.
public InputStreamAndBuffer( DataInputStream in )
{
this.in = in;
this.ptr = 0;
this.line = "";
this.line_number = 0;
this.nothing_read = true;
}
/* Reads the next line into the line buffer.
vecptr and format are used only in generating error messages.
*/
public void readLine( int vecptr, FormatElement format )
throws EndOfFileWhenStartingReadException,
LineMissingOnReadException,
IOExceptionOnReadException
{
try {
String line = this.in.readLine();
if ( line == null ) {
if ( this.nothing_read )
throw new EndOfFileWhenStartingReadException( vecptr,
format.toString(),
this.line,
this.line_number
);
else
throw new LineMissingOnReadException( vecptr,
format.toString(),
this.line,
this.line_number
);
}
else {
this.ptr = 0;
this.nothing_read = false;
this.line_number = this.line_number + 1;
this.line = line;
// Don't do the assignment until we've checked for a null
// line, because then we can then use this.line as the
// previous value for error messages.
}
}
catch ( IOException e ) {
throw new IOExceptionOnReadException( this.line, this.line_number,
e.getMessage()
);
}
}
/* Returns a string consisting of the next width characters,
and throws an exception if the line is not long enough.
The 'vecptr' and 'format' parameters are used only in generating error
messages.
*/
public String getSlice( int width, int vecptr, FormatElement format )
throws DataMissingOnReadException,
LineMissingOnReadException,
EndOfFileWhenStartingReadException,
IOExceptionOnReadException
{
if ( this.nothing_read )
readLine( vecptr, format );
if ( this.ptr+width > this.line.length() ) {
/**
throw new DataMissingOnReadException( vecptr,
format.toString(),
getLineErrorReport()
);
**/
return this.line.substring( this.ptr );
}
else {
return this.line.substring( this.ptr, this.ptr+width );
}
}
/* Advances the pointer by width.
*/
public void advance( int width )
{
this.ptr = this.ptr + width;
}
/* Generates an error report showing the line, character pointer
ptr and line number.
*/
public String getLineErrorReport()
{
StringBuffer s = new StringBuffer();
/* Report the line number. */
s.append( " Line number = " + this.line_number + ":\n" );
/* Show the line. */
s.append( this.line + "\n" );
/* Show an arrow under ptr. */
for ( int i=0; i",
"",
"",
"",
"",
"",
"",
"",
"",
"",
"",
"",
"",
"\".\"",
"\"/\"",
"\"(\"",
"\")\"",
"\",\"",
};
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/j_paine/formatter/TokenMgrError.java 0000644 0001750 0001750 00000010164 10616163246 030325 0 ustar osallou osallou /* Generated By:JavaCC: Do not edit this line. TokenMgrError.java Version 3.0 */
package org.j_paine.formatter;
public class TokenMgrError extends Error
{
/*
* Ordinals for various reasons why an Error of this type can be thrown.
*/
/**
* Lexical error occured.
*/
static final int LEXICAL_ERROR = 0;
/**
* An attempt wass made to create a second instance of a static token manager.
*/
static final int STATIC_LEXER_ERROR = 1;
/**
* Tried to change to an invalid lexical state.
*/
static final int INVALID_LEXICAL_STATE = 2;
/**
* Detected (and bailed out of) an infinite loop in the token manager.
*/
static final int LOOP_DETECTED = 3;
/**
* Indicates the reason why the exception is thrown. It will have
* one of the above 4 values.
*/
int errorCode;
/**
* Replaces unprintable characters by their espaced (or unicode escaped)
* equivalents in the given string
*/
protected static final String addEscapes(String str) {
StringBuffer retval = new StringBuffer();
char ch;
for (int i = 0; i < str.length(); i++) {
switch (str.charAt(i))
{
case 0 :
continue;
case '\b':
retval.append("\\b");
continue;
case '\t':
retval.append("\\t");
continue;
case '\n':
retval.append("\\n");
continue;
case '\f':
retval.append("\\f");
continue;
case '\r':
retval.append("\\r");
continue;
case '\"':
retval.append("\\\"");
continue;
case '\'':
retval.append("\\\'");
continue;
case '\\':
retval.append("\\\\");
continue;
default:
if ((ch = str.charAt(i)) < 0x20 || ch > 0x7e) {
String s = "0000" + Integer.toString(ch, 16);
retval.append("\\u" + s.substring(s.length() - 4, s.length()));
} else {
retval.append(ch);
}
continue;
}
}
return retval.toString();
}
/**
* Returns a detailed message for the Error when it is thrown by the
* token manager to indicate a lexical error.
* Parameters :
* EOFSeen : indicates if EOF caused the lexicl error
* curLexState : lexical state in which this error occured
* errorLine : line number when the error occured
* errorColumn : column number when the error occured
* errorAfter : prefix that was seen before this error occured
* curchar : the offending character
* Note: You can customize the lexical error message by modifying this method.
*/
protected static String LexicalError(boolean EOFSeen, int lexState, int errorLine, int errorColumn, String errorAfter, char curChar) {
return("Lexical error at line " +
errorLine + ", column " +
errorColumn + ". Encountered: " +
(EOFSeen ? " " : ("\"" + addEscapes(String.valueOf(curChar)) + "\"") + " (" + (int)curChar + "), ") +
"after : \"" + addEscapes(errorAfter) + "\"");
}
/**
* You can also modify the body of this method to customize your error messages.
* For example, cases like LOOP_DETECTED and INVALID_LEXICAL_STATE are not
* of end-users concern, so you can return something like :
*
* "Internal Error : Please file a bug report .... "
*
* from this method for such cases in the release version of your parser.
*/
public String getMessage() {
return super.getMessage();
}
/*
* Constructors of various flavors follow.
*/
public TokenMgrError() {
}
public TokenMgrError(String message, int reason) {
super(message);
errorCode = reason;
}
public TokenMgrError(boolean EOFSeen, int lexState, int errorLine, int errorColumn, String errorAfter, char curChar, int reason) {
this(LexicalError(EOFSeen, lexState, errorLine, errorColumn, errorAfter, curChar), reason);
}
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/j_paine/formatter/README 0000644 0001750 0001750 00000000476 10616163246 025607 0 ustar osallou osallou This directory contains the Formatter package written by Jocelyn Paine.
http://www.j-paine.org/Formatter
This is actually a modified version of the Formatter, hacked up to work
with f2j. Among other things, I removed some exception handling, so the
modified version may not be ideal for using in other Java code.
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/j_paine/formatter/ParseException.java 0000644 0001750 0001750 00000014432 10616163246 030520 0 ustar osallou osallou /* Generated By:JavaCC: Do not edit this line. ParseException.java Version 3.0 */
package org.j_paine.formatter;
/**
* This exception is thrown when parse errors are encountered.
* You can explicitly create objects of this exception type by
* calling the method generateParseException in the generated
* parser.
*
* You can modify this class to customize your error reporting
* mechanisms so long as you retain the public fields.
*/
public class ParseException extends Exception {
/**
* This constructor is used by the method "generateParseException"
* in the generated parser. Calling this constructor generates
* a new object of this type with the fields "currentToken",
* "expectedTokenSequences", and "tokenImage" set. The boolean
* flag "specialConstructor" is also set to true to indicate that
* this constructor was used to create this object.
* This constructor calls its super class with the empty string
* to force the "toString" method of parent class "Throwable" to
* print the error message in the form:
* ParseException:
*/
public ParseException(Token currentTokenVal,
int[][] expectedTokenSequencesVal,
String[] tokenImageVal
)
{
super("");
specialConstructor = true;
currentToken = currentTokenVal;
expectedTokenSequences = expectedTokenSequencesVal;
tokenImage = tokenImageVal;
}
/**
* The following constructors are for use by you for whatever
* purpose you can think of. Constructing the exception in this
* manner makes the exception behave in the normal way - i.e., as
* documented in the class "Throwable". The fields "errorToken",
* "expectedTokenSequences", and "tokenImage" do not contain
* relevant information. The JavaCC generated code does not use
* these constructors.
*/
public ParseException() {
super();
specialConstructor = false;
}
public ParseException(String message) {
super(message);
specialConstructor = false;
}
/**
* This variable determines which constructor was used to create
* this object and thereby affects the semantics of the
* "getMessage" method (see below).
*/
protected boolean specialConstructor;
/**
* This is the last token that has been consumed successfully. If
* this object has been created due to a parse error, the token
* followng this token will (therefore) be the first error token.
*/
public Token currentToken;
/**
* Each entry in this array is an array of integers. Each array
* of integers represents a sequence of tokens (by their ordinal
* values) that is expected at this point of the parse.
*/
public int[][] expectedTokenSequences;
/**
* This is a reference to the "tokenImage" array of the generated
* parser within which the parse error occurred. This array is
* defined in the generated ...Constants interface.
*/
public String[] tokenImage;
/**
* This method has the standard behavior when this object has been
* created using the standard constructors. Otherwise, it uses
* "currentToken" and "expectedTokenSequences" to generate a parse
* error message and returns it. If this object has been created
* due to a parse error, and you do not catch it (it gets thrown
* from the parser), then this method is called during the printing
* of the final stack trace, and hence the correct error message
* gets displayed.
*/
public String getMessage() {
if (!specialConstructor) {
return super.getMessage();
}
StringBuffer expected = new StringBuffer();
int maxSize = 0;
for (int i = 0; i < expectedTokenSequences.length; i++) {
if (maxSize < expectedTokenSequences[i].length) {
maxSize = expectedTokenSequences[i].length;
}
for (int j = 0; j < expectedTokenSequences[i].length; j++) {
expected.append(tokenImage[expectedTokenSequences[i][j]]).append(" ");
}
if (expectedTokenSequences[i][expectedTokenSequences[i].length - 1] != 0) {
expected.append("...");
}
expected.append(eol).append(" ");
}
String retval = "Encountered \"";
Token tok = currentToken.next;
for (int i = 0; i < maxSize; i++) {
if (i != 0) retval += " ";
if (tok.kind == 0) {
retval += tokenImage[0];
break;
}
retval += add_escapes(tok.image);
tok = tok.next;
}
retval += "\" at line " + currentToken.next.beginLine + ", column " + currentToken.next.beginColumn;
retval += "." + eol;
if (expectedTokenSequences.length == 1) {
retval += "Was expecting:" + eol + " ";
} else {
retval += "Was expecting one of:" + eol + " ";
}
retval += expected.toString();
return retval;
}
/**
* The end of line string for this machine.
*/
protected String eol = System.getProperty("line.separator", "\n");
/**
* Used to convert raw characters to their escaped version
* when these raw version cannot be used as part of an ASCII
* string literal.
*/
protected String add_escapes(String str) {
StringBuffer retval = new StringBuffer();
char ch;
for (int i = 0; i < str.length(); i++) {
switch (str.charAt(i))
{
case 0 :
continue;
case '\b':
retval.append("\\b");
continue;
case '\t':
retval.append("\\t");
continue;
case '\n':
retval.append("\\n");
continue;
case '\f':
retval.append("\\f");
continue;
case '\r':
retval.append("\\r");
continue;
case '\"':
retval.append("\\\"");
continue;
case '\'':
retval.append("\\\'");
continue;
case '\\':
retval.append("\\\\");
continue;
default:
if ((ch = str.charAt(i)) < 0x20 || ch > 0x7e) {
String s = "0000" + Integer.toString(ch, 16);
retval.append("\\u" + s.substring(s.length() - 4, s.length()));
} else {
retval.append(ch);
}
continue;
}
}
return retval.toString();
}
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/j_paine/formatter/NumberParserTokenManager.java 0000644 0001750 0001750 00000026507 10616163246 032476 0 ustar osallou osallou /* Generated By:JavaCC: Do not edit this line. NumberParserTokenManager.java */
package org.j_paine.formatter;
public class NumberParserTokenManager implements NumberParserConstants
{
public java.io.PrintStream debugStream = System.out;
public void setDebugStream(java.io.PrintStream ds) { debugStream = ds; }
private final int jjStopStringLiteralDfa_0(int pos, long active0)
{
switch (pos)
{
default :
return -1;
}
}
private final int jjStartNfa_0(int pos, long active0)
{
return jjMoveNfa_0(jjStopStringLiteralDfa_0(pos, active0), pos + 1);
}
private final int jjStopAtPos(int pos, int kind)
{
jjmatchedKind = kind;
jjmatchedPos = pos;
return pos + 1;
}
private final int jjStartNfaWithStates_0(int pos, int kind, int state)
{
jjmatchedKind = kind;
jjmatchedPos = pos;
try { curChar = input_stream.readChar(); }
catch(java.io.IOException e) { return pos + 1; }
return jjMoveNfa_0(state, pos + 1);
}
private final int jjMoveStringLiteralDfa0_0()
{
switch(curChar)
{
case 32:
return jjStopAtPos(0, 6);
case 43:
return jjStopAtPos(0, 8);
case 45:
return jjStopAtPos(0, 7);
default :
return jjMoveNfa_0(0, 0);
}
}
private final void jjCheckNAdd(int state)
{
if (jjrounds[state] != jjround)
{
jjstateSet[jjnewStateCnt++] = state;
jjrounds[state] = jjround;
}
}
private final void jjAddStates(int start, int end)
{
do {
jjstateSet[jjnewStateCnt++] = jjnextStates[start];
} while (start++ != end);
}
private final void jjCheckNAddTwoStates(int state1, int state2)
{
jjCheckNAdd(state1);
jjCheckNAdd(state2);
}
private final void jjCheckNAddStates(int start, int end)
{
do {
jjCheckNAdd(jjnextStates[start]);
} while (start++ != end);
}
private final void jjCheckNAddStates(int start)
{
jjCheckNAdd(jjnextStates[start]);
jjCheckNAdd(jjnextStates[start + 1]);
}
private final int jjMoveNfa_0(int startState, int curPos)
{
int[] nextStates;
int startsAt = 0;
jjnewStateCnt = 24;
int i = 1;
jjstateSet[0] = startState;
int j, kind = 0x7fffffff;
for (;;)
{
if (++jjround == 0x7fffffff)
ReInitRounds();
if (curChar < 64)
{
long l = 1L << curChar;
MatchLoop: do
{
switch(jjstateSet[--i])
{
case 0:
if ((0x3ff000000000000L & l) != 0L)
{
if (kind > 4)
kind = 4;
jjCheckNAddStates(0, 5);
}
else if (curChar == 46)
jjCheckNAdd(5);
if ((0x3fe000000000000L & l) != 0L)
{
if (kind > 1)
kind = 1;
jjCheckNAdd(2);
}
else if (curChar == 48)
{
if (kind > 1)
kind = 1;
}
break;
case 1:
if ((0x3fe000000000000L & l) == 0L)
break;
if (kind > 1)
kind = 1;
jjCheckNAdd(2);
break;
case 2:
if ((0x3ff000000000000L & l) == 0L)
break;
if (kind > 1)
kind = 1;
jjCheckNAdd(2);
break;
case 4:
if (curChar == 46)
jjCheckNAdd(5);
break;
case 5:
if ((0x3ff000000000000L & l) == 0L)
break;
if (kind > 4)
kind = 4;
jjCheckNAddTwoStates(5, 6);
break;
case 7:
if ((0x280000000000L & l) != 0L)
jjCheckNAdd(8);
break;
case 8:
if ((0x3ff000000000000L & l) == 0L)
break;
if (kind > 4)
kind = 4;
jjCheckNAdd(8);
break;
case 9:
if ((0x3ff000000000000L & l) == 0L)
break;
if (kind > 4)
kind = 4;
jjCheckNAddStates(0, 5);
break;
case 10:
if ((0x3ff000000000000L & l) != 0L)
jjCheckNAddTwoStates(10, 11);
break;
case 11:
if (curChar != 46)
break;
if (kind > 4)
kind = 4;
jjCheckNAddTwoStates(12, 13);
break;
case 12:
if ((0x3ff000000000000L & l) == 0L)
break;
if (kind > 4)
kind = 4;
jjCheckNAddTwoStates(12, 13);
break;
case 14:
if ((0x280000000000L & l) != 0L)
jjCheckNAdd(15);
break;
case 15:
if ((0x3ff000000000000L & l) == 0L)
break;
if (kind > 4)
kind = 4;
jjCheckNAdd(15);
break;
case 16:
if ((0x3ff000000000000L & l) != 0L)
jjCheckNAddTwoStates(16, 17);
break;
case 18:
if ((0x280000000000L & l) != 0L)
jjCheckNAdd(19);
break;
case 19:
if ((0x3ff000000000000L & l) == 0L)
break;
if (kind > 4)
kind = 4;
jjCheckNAdd(19);
break;
case 20:
if ((0x3ff000000000000L & l) == 0L)
break;
if (kind > 4)
kind = 4;
jjCheckNAddTwoStates(20, 21);
break;
case 22:
if ((0x280000000000L & l) != 0L)
jjCheckNAdd(23);
break;
case 23:
if ((0x3ff000000000000L & l) == 0L)
break;
if (kind > 4)
kind = 4;
jjCheckNAdd(23);
break;
default : break;
}
} while(i != startsAt);
}
else if (curChar < 128)
{
long l = 1L << (curChar & 077);
MatchLoop: do
{
switch(jjstateSet[--i])
{
case 0:
if ((0x100040L & l) != 0L)
kind = 3;
break;
case 6:
if ((0x2000000020L & l) != 0L)
jjAddStates(6, 7);
break;
case 13:
if ((0x2000000020L & l) != 0L)
jjAddStates(8, 9);
break;
case 17:
if ((0x2000000020L & l) != 0L)
jjAddStates(10, 11);
break;
case 21:
if ((0x2000000020L & l) != 0L)
jjAddStates(12, 13);
break;
default : break;
}
} while(i != startsAt);
}
else
{
int i2 = (curChar & 0xff) >> 6;
long l2 = 1L << (curChar & 077);
MatchLoop: do
{
switch(jjstateSet[--i])
{
default : break;
}
} while(i != startsAt);
}
if (kind != 0x7fffffff)
{
jjmatchedKind = kind;
jjmatchedPos = curPos;
kind = 0x7fffffff;
}
++curPos;
if ((i = jjnewStateCnt) == (startsAt = 24 - (jjnewStateCnt = startsAt)))
return curPos;
try { curChar = input_stream.readChar(); }
catch(java.io.IOException e) { return curPos; }
}
}
static final int[] jjnextStates = {
10, 11, 16, 17, 20, 21, 7, 8, 14, 15, 18, 19, 22, 23,
};
public static final String[] jjstrLiteralImages = {
"", null, null, null, null, null, "\40", "\55", "\53", };
public static final String[] lexStateNames = {
"DEFAULT",
};
protected SimpleCharStream input_stream;
private final int[] jjrounds = new int[24];
private final int[] jjstateSet = new int[48];
protected char curChar;
public NumberParserTokenManager(SimpleCharStream stream){
if (SimpleCharStream.staticFlag)
throw new Error("ERROR: Cannot use a static CharStream class with a non-static lexical analyzer.");
input_stream = stream;
}
public NumberParserTokenManager(SimpleCharStream stream, int lexState){
this(stream);
SwitchTo(lexState);
}
public void ReInit(SimpleCharStream stream)
{
jjmatchedPos = jjnewStateCnt = 0;
curLexState = defaultLexState;
input_stream = stream;
ReInitRounds();
}
private final void ReInitRounds()
{
int i;
jjround = 0x80000001;
for (i = 24; i-- > 0;)
jjrounds[i] = 0x80000000;
}
public void ReInit(SimpleCharStream stream, int lexState)
{
ReInit(stream);
SwitchTo(lexState);
}
public void SwitchTo(int lexState)
{
if (lexState >= 1 || lexState < 0)
throw new TokenMgrError("Error: Ignoring invalid lexical state : " + lexState + ". State unchanged.", TokenMgrError.INVALID_LEXICAL_STATE);
else
curLexState = lexState;
}
protected Token jjFillToken()
{
Token t = Token.newToken(jjmatchedKind);
t.kind = jjmatchedKind;
String im = jjstrLiteralImages[jjmatchedKind];
t.image = (im == null) ? input_stream.GetImage() : im;
t.beginLine = input_stream.getBeginLine();
t.beginColumn = input_stream.getBeginColumn();
t.endLine = input_stream.getEndLine();
t.endColumn = input_stream.getEndColumn();
return t;
}
int curLexState = 0;
int defaultLexState = 0;
int jjnewStateCnt;
int jjround;
int jjmatchedPos;
int jjmatchedKind;
public Token getNextToken()
{
int kind;
Token specialToken = null;
Token matchedToken;
int curPos = 0;
EOFLoop :
for (;;)
{
try
{
curChar = input_stream.BeginToken();
}
catch(java.io.IOException e)
{
jjmatchedKind = 0;
matchedToken = jjFillToken();
return matchedToken;
}
jjmatchedKind = 0x7fffffff;
jjmatchedPos = 0;
curPos = jjMoveStringLiteralDfa0_0();
if (jjmatchedKind != 0x7fffffff)
{
if (jjmatchedPos + 1 < curPos)
input_stream.backup(curPos - jjmatchedPos - 1);
matchedToken = jjFillToken();
return matchedToken;
}
int error_line = input_stream.getEndLine();
int error_column = input_stream.getEndColumn();
String error_after = null;
boolean EOFSeen = false;
try { input_stream.readChar(); input_stream.backup(1); }
catch (java.io.IOException e1) {
EOFSeen = true;
error_after = curPos <= 1 ? "" : input_stream.GetImage();
if (curChar == '\n' || curChar == '\r') {
error_line++;
error_column = 0;
}
else
error_column++;
}
if (!EOFSeen) {
input_stream.backup(1);
error_after = curPos <= 1 ? "" : input_stream.GetImage();
}
throw new TokenMgrError(EOFSeen, curLexState, error_line, error_column, error_after, curChar, TokenMgrError.LEXICAL_ERROR);
}
}
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/j_paine/formatter/FormatParser.jj 0000644 0001750 0001750 00000010567 10616163245 027662 0 ustar osallou osallou /* FormatParser.java */
/*
This parser parses Fortran format strings.
*/
options {
STATIC = true;
DEBUG_PARSER = false;
DEBUG_TOKEN_MANAGER = false;
DEBUG_LOOKAHEAD = false;
}
PARSER_BEGIN(FormatParser)
package org.j_paine.formatter;
class FormatParser
{
}
PARSER_END(FormatParser)
SKIP :
{
<(" ")+>
}
TOKEN :
{
}
// An unsigned integer, for repetition factors, field widths, etc.
// previously:
TOKEN :
{
}
// A string literal inside a format. We haven't implemented
// embedded quotes yet.
TOKEN : { < A_DESC : "A" | "a" > }
TOKEN : { < P_DESC : "P" | "p" > }
TOKEN : { < X_DESC : "X" | "x" > }
TOKEN : { < I_DESC : "I" | "i" > }
TOKEN : { < F_DESC : "F" | "f" > }
TOKEN : { < D_DESC : "D" | "d" > }
TOKEN : { < E_DESC : "E" | "e" > }
TOKEN : { < G_DESC : "G" | "g" > }
TOKEN : { < L_DESC : "L" | "l" > }
int Integer():
{ Token t;
}
{
t=
{ return (Integer.valueOf(t.image)).intValue(); }
}
FormatElement FormatIOElementFloat():
{ FormatElement fe;
int w, d, m;
w = d = m = -1;
}
{
// for Iw.m, ignore the .m value
(
w=Integer() "." d=Integer() { fe=new FormatF(w,d); }
| w=Integer() "." d=Integer() { fe=new FormatE(w,d); }
| w=Integer() "." d=Integer() { fe=new FormatE(w,d); }
| w=Integer() "." d=Integer() { fe=new FormatE(w,d); }
)
{ return fe; }
}
FormatElement FormatIOElementNonFloat():
{ FormatElement fe;
int w, d, m;
w = d = m = -1;
}
{
// for Iw.m, ignore the .m value
(
[w=Integer()] { fe=new FormatA(w); }
| w=Integer() ["." m=Integer()] { fe=new FormatI(w); }
| w=Integer() { fe=new FormatL(w); }
)
{ return fe; }
}
// This represents a format element that transfers one
// data item.
FormatElement FormatNonIOElement(): {}
{
{ return new FormatX(); }
}
// This represents a format element that doesn't transfer
// any data items.
FormatElement FormatElement():
{ FormatElement fe;
}
{
( fe=FormatIOElementFloat()
| fe=FormatIOElementNonFloat()
| fe=FormatNonIOElement()
| fe=FormatScale()
)
{ return fe; }
}
FormatElement FormatScale():
{ FormatElement fe = null;
int r=1;
}
{
/* Commas may be omitted between a P edit descriptor and an
* immediately following F, E, D, or G edit descriptor (13.5.9).
*/
[ [r=Integer()] (fe=FormatIOElementFloat()) ]
{
return new FormatP(r, fe);
}
}
FormatSlash FormatSlash(): {}
{
"/" { return new FormatSlash(); }
}
// These are a special case. Unlike other format elements,
// Fortran permits several slashes to be concatenated without
// commas to separate them, and you can't use a repetition
// factor on them.
FormatString FormatString():
{ Token t;
String s;
}
{
( t= )
{ s = t.image;
s = s.substring(1,s.length()-1); // Remove the quotes.
return new FormatString(s);
}
}
// Another special case that can't be repeated, and can be
// concatenated to other elements without commas.
void OptionalFormatSlashesOrStrings( Format f ):
{ FormatUniv fs;
}
{
( (fs=FormatSlash() | fs=FormatString()) { f.addElement(fs); } )*
}
FormatRepeatedItem FormatRepeatedItem():
{ int r=1;
FormatUniv fu;
}
{
[ r=Integer() ]
( "(" fu=Format() ")"
| fu=FormatElement()
)
{
if(fu instanceof FormatP) {
FormatRepeatedItem ritem;
ritem = ((FormatP)fu).getRepeatedItem();
if(ritem != null)
return ritem;
else
return new FormatRepeatedItem( r, fu );
}
else
return new FormatRepeatedItem( r, fu );
}
}
void FormatGroup( Format f ):
{ FormatRepeatedItem fri;
}
{
( OptionalFormatSlashesOrStrings( f )
[ fri = FormatRepeatedItem() { if(fri != null) f.addElement(fri); }
OptionalFormatSlashesOrStrings( f )
]
)
}
// This rather messy syntax allows us to have slashes and/or
// strings either side of a format element or repeated group
// without needing to separate them from each other or the element
// with commas.
// It also means that we can have empty format groups and format
// groups that don't transfer any data elements. So for example,
// the format ,/, is valid under this grammar.
Format Format():
{ FormatRepeatedItem fri;
Format f = new Format();
}
{
( FormatGroup(f) )
( "," ( FormatGroup(f) ) )*
{ return f; }
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/j_paine/formatter/NumberParser.java 0000644 0001750 0001750 00000016420 10616163245 030172 0 ustar osallou osallou /* Generated By:JavaCC: Do not edit this line. NumberParser.java */
package org.j_paine.formatter;
class NumberParser implements NumberParserConstants {
final public int Float() throws ParseException {
int start = 0;
label_1:
while (true) {
switch ((jj_ntk==-1)?jj_ntk():jj_ntk) {
case 6:
;
break;
default:
jj_la1[0] = jj_gen;
break label_1;
}
jj_consume_token(6);
start++;
}
switch ((jj_ntk==-1)?jj_ntk():jj_ntk) {
case 7:
case 8:
switch ((jj_ntk==-1)?jj_ntk():jj_ntk) {
case 7:
jj_consume_token(7);
break;
case 8:
jj_consume_token(8);
break;
default:
jj_la1[1] = jj_gen;
jj_consume_token(-1);
throw new ParseException();
}
break;
default:
jj_la1[2] = jj_gen;
;
}
switch ((jj_ntk==-1)?jj_ntk():jj_ntk) {
case INTEGER_LITERAL:
jj_consume_token(INTEGER_LITERAL);
break;
case FLOATING_POINT_LITERAL:
jj_consume_token(FLOATING_POINT_LITERAL);
break;
default:
jj_la1[3] = jj_gen;
jj_consume_token(-1);
throw new ParseException();
}
jj_consume_token(0);
{if (true) return start;}
throw new Error("Missing return statement in function");
}
// This is the syntax of numbers we want a real format to accept.
// The makes sure that trailing non-numeric characters
// (even spaces) are reported as an error.
// Returns an integer which is the number of spaces to skip before
// the number starts.
final public int Integer() throws ParseException {
int start = 0;
label_2:
while (true) {
switch ((jj_ntk==-1)?jj_ntk():jj_ntk) {
case 6:
;
break;
default:
jj_la1[4] = jj_gen;
break label_2;
}
jj_consume_token(6);
start++;
}
switch ((jj_ntk==-1)?jj_ntk():jj_ntk) {
case 7:
case 8:
switch ((jj_ntk==-1)?jj_ntk():jj_ntk) {
case 7:
jj_consume_token(7);
break;
case 8:
jj_consume_token(8);
break;
default:
jj_la1[5] = jj_gen;
jj_consume_token(-1);
throw new ParseException();
}
break;
default:
jj_la1[6] = jj_gen;
;
}
jj_consume_token(INTEGER_LITERAL);
jj_consume_token(0);
{if (true) return start;}
throw new Error("Missing return statement in function");
}
// This is the syntax of numbers we want an integer format to
// accept.
// Returns an integer which is the number of spaces to skip before
// the number starts.
final public int Boolean() throws ParseException {
int start = 0;
label_3:
while (true) {
switch ((jj_ntk==-1)?jj_ntk():jj_ntk) {
case 6:
;
break;
default:
jj_la1[7] = jj_gen;
break label_3;
}
jj_consume_token(6);
start++;
}
jj_consume_token(LOGICAL_LITERAL);
jj_consume_token(0);
{if (true) return start;}
throw new Error("Missing return statement in function");
}
public NumberParserTokenManager token_source;
SimpleCharStream jj_input_stream;
public Token token, jj_nt;
private int jj_ntk;
private int jj_gen;
final private int[] jj_la1 = new int[8];
static private int[] jj_la1_0;
static {
jj_la1_0();
}
private static void jj_la1_0() {
jj_la1_0 = new int[] {0x40,0x180,0x180,0x12,0x40,0x180,0x180,0x40,};
}
public NumberParser(java.io.InputStream stream) {
this(stream, null);
}
public NumberParser(java.io.InputStream stream, String encoding) {
try { jj_input_stream = new SimpleCharStream(stream, encoding, 1, 1); } catch(java.io.UnsupportedEncodingException e) { throw new RuntimeException(e); }
token_source = new NumberParserTokenManager(jj_input_stream);
token = new Token();
jj_ntk = -1;
jj_gen = 0;
for (int i = 0; i < 8; i++) jj_la1[i] = -1;
}
public void ReInit(java.io.InputStream stream) {
ReInit(stream, null);
}
public void ReInit(java.io.InputStream stream, String encoding) {
try { jj_input_stream.ReInit(stream, encoding, 1, 1); } catch(java.io.UnsupportedEncodingException e) { throw new RuntimeException(e); }
token_source.ReInit(jj_input_stream);
token = new Token();
jj_ntk = -1;
jj_gen = 0;
for (int i = 0; i < 8; i++) jj_la1[i] = -1;
}
public NumberParser(java.io.Reader stream) {
jj_input_stream = new SimpleCharStream(stream, 1, 1);
token_source = new NumberParserTokenManager(jj_input_stream);
token = new Token();
jj_ntk = -1;
jj_gen = 0;
for (int i = 0; i < 8; i++) jj_la1[i] = -1;
}
public void ReInit(java.io.Reader stream) {
jj_input_stream.ReInit(stream, 1, 1);
token_source.ReInit(jj_input_stream);
token = new Token();
jj_ntk = -1;
jj_gen = 0;
for (int i = 0; i < 8; i++) jj_la1[i] = -1;
}
public NumberParser(NumberParserTokenManager tm) {
token_source = tm;
token = new Token();
jj_ntk = -1;
jj_gen = 0;
for (int i = 0; i < 8; i++) jj_la1[i] = -1;
}
public void ReInit(NumberParserTokenManager tm) {
token_source = tm;
token = new Token();
jj_ntk = -1;
jj_gen = 0;
for (int i = 0; i < 8; i++) jj_la1[i] = -1;
}
final private Token jj_consume_token(int kind) throws ParseException {
Token oldToken;
if ((oldToken = token).next != null) token = token.next;
else token = token.next = token_source.getNextToken();
jj_ntk = -1;
if (token.kind == kind) {
jj_gen++;
return token;
}
token = oldToken;
jj_kind = kind;
throw generateParseException();
}
final public Token getNextToken() {
if (token.next != null) token = token.next;
else token = token.next = token_source.getNextToken();
jj_ntk = -1;
jj_gen++;
return token;
}
final public Token getToken(int index) {
Token t = token;
for (int i = 0; i < index; i++) {
if (t.next != null) t = t.next;
else t = t.next = token_source.getNextToken();
}
return t;
}
final private int jj_ntk() {
if ((jj_nt=token.next) == null)
return (jj_ntk = (token.next=token_source.getNextToken()).kind);
else
return (jj_ntk = jj_nt.kind);
}
private java.util.Vector jj_expentries = new java.util.Vector();
private int[] jj_expentry;
private int jj_kind = -1;
public ParseException generateParseException() {
jj_expentries.removeAllElements();
boolean[] la1tokens = new boolean[9];
for (int i = 0; i < 9; i++) {
la1tokens[i] = false;
}
if (jj_kind >= 0) {
la1tokens[jj_kind] = true;
jj_kind = -1;
}
for (int i = 0; i < 8; i++) {
if (jj_la1[i] == jj_gen) {
for (int j = 0; j < 32; j++) {
if ((jj_la1_0[i] & (1< 2)
kind = 2;
jjCheckNAdd(1);
}
else if (curChar == 39)
jjCheckNAddTwoStates(3, 4);
else if (curChar == 32)
{
if (kind > 1)
kind = 1;
jjCheckNAdd(0);
}
break;
case 0:
if (curChar != 32)
break;
if (kind > 1)
kind = 1;
jjCheckNAdd(0);
break;
case 1:
if ((0x3ff000000000000L & l) == 0L)
break;
if (kind > 2)
kind = 2;
jjCheckNAdd(1);
break;
case 3:
if ((0xffffff7fffffffffL & l) != 0L)
jjCheckNAddTwoStates(3, 4);
break;
case 4:
if (curChar == 39 && kind > 3)
kind = 3;
break;
default : break;
}
} while(i != startsAt);
}
else if (curChar < 128)
{
long l = 1L << (curChar & 077);
MatchLoop: do
{
switch(jjstateSet[--i])
{
case 2:
if ((0x100000001000L & l) != 0L)
{
if (kind > 12)
kind = 12;
}
else if ((0x8000000080L & l) != 0L)
{
if (kind > 11)
kind = 11;
}
else if ((0x2000000020L & l) != 0L)
{
if (kind > 10)
kind = 10;
}
else if ((0x1000000010L & l) != 0L)
{
if (kind > 9)
kind = 9;
}
else if ((0x4000000040L & l) != 0L)
{
if (kind > 8)
kind = 8;
}
else if ((0x20000000200L & l) != 0L)
{
if (kind > 7)
kind = 7;
}
else if ((0x100000001000000L & l) != 0L)
{
if (kind > 6)
kind = 6;
}
else if ((0x1000000010000L & l) != 0L)
{
if (kind > 5)
kind = 5;
}
else if ((0x200000002L & l) != 0L)
{
if (kind > 4)
kind = 4;
}
break;
case 3:
jjAddStates(0, 1);
break;
case 5:
if ((0x200000002L & l) != 0L && kind > 4)
kind = 4;
break;
case 6:
if ((0x1000000010000L & l) != 0L && kind > 5)
kind = 5;
break;
case 7:
if ((0x100000001000000L & l) != 0L && kind > 6)
kind = 6;
break;
case 8:
if ((0x20000000200L & l) != 0L && kind > 7)
kind = 7;
break;
case 9:
if ((0x4000000040L & l) != 0L && kind > 8)
kind = 8;
break;
case 10:
if ((0x1000000010L & l) != 0L && kind > 9)
kind = 9;
break;
case 11:
if ((0x2000000020L & l) != 0L && kind > 10)
kind = 10;
break;
case 12:
if ((0x8000000080L & l) != 0L && kind > 11)
kind = 11;
break;
case 13:
if ((0x100000001000L & l) != 0L && kind > 12)
kind = 12;
break;
default : break;
}
} while(i != startsAt);
}
else
{
int i2 = (curChar & 0xff) >> 6;
long l2 = 1L << (curChar & 077);
MatchLoop: do
{
switch(jjstateSet[--i])
{
case 3:
if ((jjbitVec0[i2] & l2) != 0L)
jjAddStates(0, 1);
break;
default : break;
}
} while(i != startsAt);
}
if (kind != 0x7fffffff)
{
jjmatchedKind = kind;
jjmatchedPos = curPos;
kind = 0x7fffffff;
}
++curPos;
if ((i = jjnewStateCnt) == (startsAt = 14 - (jjnewStateCnt = startsAt)))
return curPos;
try { curChar = input_stream.readChar(); }
catch(java.io.IOException e) { return curPos; }
}
}
static final int[] jjnextStates = {
3, 4,
};
public static final String[] jjstrLiteralImages = {
"", null, null, null, null, null, null, null, null, null, null, null, null,
"\56", "\57", "\50", "\51", "\54", };
public static final String[] lexStateNames = {
"DEFAULT",
};
static final long[] jjtoToken = {
0x3fffdL,
};
static final long[] jjtoSkip = {
0x2L,
};
static protected SimpleCharStream input_stream;
static private final int[] jjrounds = new int[14];
static private final int[] jjstateSet = new int[28];
static protected char curChar;
public FormatParserTokenManager(SimpleCharStream stream){
if (input_stream != null)
throw new TokenMgrError("ERROR: Second call to constructor of static lexer. You must use ReInit() to initialize the static variables.", TokenMgrError.STATIC_LEXER_ERROR);
input_stream = stream;
}
public FormatParserTokenManager(SimpleCharStream stream, int lexState){
this(stream);
SwitchTo(lexState);
}
static public void ReInit(SimpleCharStream stream)
{
jjmatchedPos = jjnewStateCnt = 0;
curLexState = defaultLexState;
input_stream = stream;
ReInitRounds();
}
static private final void ReInitRounds()
{
int i;
jjround = 0x80000001;
for (i = 14; i-- > 0;)
jjrounds[i] = 0x80000000;
}
static public void ReInit(SimpleCharStream stream, int lexState)
{
ReInit(stream);
SwitchTo(lexState);
}
static public void SwitchTo(int lexState)
{
if (lexState >= 1 || lexState < 0)
throw new TokenMgrError("Error: Ignoring invalid lexical state : " + lexState + ". State unchanged.", TokenMgrError.INVALID_LEXICAL_STATE);
else
curLexState = lexState;
}
static protected Token jjFillToken()
{
Token t = Token.newToken(jjmatchedKind);
t.kind = jjmatchedKind;
String im = jjstrLiteralImages[jjmatchedKind];
t.image = (im == null) ? input_stream.GetImage() : im;
t.beginLine = input_stream.getBeginLine();
t.beginColumn = input_stream.getBeginColumn();
t.endLine = input_stream.getEndLine();
t.endColumn = input_stream.getEndColumn();
return t;
}
static int curLexState = 0;
static int defaultLexState = 0;
static int jjnewStateCnt;
static int jjround;
static int jjmatchedPos;
static int jjmatchedKind;
public static Token getNextToken()
{
int kind;
Token specialToken = null;
Token matchedToken;
int curPos = 0;
EOFLoop :
for (;;)
{
try
{
curChar = input_stream.BeginToken();
}
catch(java.io.IOException e)
{
jjmatchedKind = 0;
matchedToken = jjFillToken();
return matchedToken;
}
jjmatchedKind = 0x7fffffff;
jjmatchedPos = 0;
curPos = jjMoveStringLiteralDfa0_0();
if (jjmatchedKind != 0x7fffffff)
{
if (jjmatchedPos + 1 < curPos)
input_stream.backup(curPos - jjmatchedPos - 1);
if ((jjtoToken[jjmatchedKind >> 6] & (1L << (jjmatchedKind & 077))) != 0L)
{
matchedToken = jjFillToken();
return matchedToken;
}
else
{
continue EOFLoop;
}
}
int error_line = input_stream.getEndLine();
int error_column = input_stream.getEndColumn();
String error_after = null;
boolean EOFSeen = false;
try { input_stream.readChar(); input_stream.backup(1); }
catch (java.io.IOException e1) {
EOFSeen = true;
error_after = curPos <= 1 ? "" : input_stream.GetImage();
if (curChar == '\n' || curChar == '\r') {
error_line++;
error_column = 0;
}
else
error_column++;
}
if (!EOFSeen) {
input_stream.backup(1);
error_after = curPos <= 1 ? "" : input_stream.GetImage();
}
throw new TokenMgrError(EOFSeen, curLexState, error_line, error_column, error_after, curChar, TokenMgrError.LEXICAL_ERROR);
}
}
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/j_paine/formatter/NumberParserConstants.java 0000644 0001750 0001750 00000001025 10616163245 032062 0 ustar osallou osallou /* Generated By:JavaCC: Do not edit this line. NumberParserConstants.java */
package org.j_paine.formatter;
public interface NumberParserConstants {
int EOF = 0;
int INTEGER_LITERAL = 1;
int DECIMAL_LITERAL = 2;
int LOGICAL_LITERAL = 3;
int FLOATING_POINT_LITERAL = 4;
int EXPONENT = 5;
int DEFAULT = 0;
String[] tokenImage = {
"",
"",
"",
"",
"",
"",
"\" \"",
"\"-\"",
"\"+\"",
};
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/j_paine/formatter/Token.java 0000644 0001750 0001750 00000005154 10616163246 026650 0 ustar osallou osallou /* Generated By:JavaCC: Do not edit this line. Token.java Version 3.0 */
package org.j_paine.formatter;
/**
* Describes the input token stream.
*/
public class Token {
/**
* An integer that describes the kind of this token. This numbering
* system is determined by JavaCCParser, and a table of these numbers is
* stored in the file ...Constants.java.
*/
public int kind;
/**
* beginLine and beginColumn describe the position of the first character
* of this token; endLine and endColumn describe the position of the
* last character of this token.
*/
public int beginLine, beginColumn, endLine, endColumn;
/**
* The string image of the token.
*/
public String image;
/**
* A reference to the next regular (non-special) token from the input
* stream. If this is the last token from the input stream, or if the
* token manager has not read tokens beyond this one, this field is
* set to null. This is true only if this token is also a regular
* token. Otherwise, see below for a description of the contents of
* this field.
*/
public Token next;
/**
* This field is used to access special tokens that occur prior to this
* token, but after the immediately preceding regular (non-special) token.
* If there are no such special tokens, this field is set to null.
* When there are more than one such special token, this field refers
* to the last of these special tokens, which in turn refers to the next
* previous special token through its specialToken field, and so on
* until the first special token (whose specialToken field is null).
* The next fields of special tokens refer to other special tokens that
* immediately follow it (without an intervening regular token). If there
* is no such token, this field is null.
*/
public Token specialToken;
/**
* Returns the image.
*/
public String toString()
{
return image;
}
/**
* Returns a new Token object, by default. However, if you want, you
* can create and return subclass objects based on the value of ofKind.
* Simply add the cases to the switch for all those special cases.
* For example, if you have a subclass of Token called IDToken that
* you want to create if ofKind is ID, simlpy add something like :
*
* case MyParserConstants.ID : return new IDToken();
*
* to the following switch statement. Then you can cast matchedToken
* variable to the appropriate type and use it in your lexical actions.
*/
public static final Token newToken(int ofKind)
{
switch(ofKind)
{
default : return new Token();
}
}
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/j_paine/formatter/SimpleCharStream.java 0000644 0001750 0001750 00000025642 10616163246 030777 0 ustar osallou osallou /* Generated By:JavaCC: Do not edit this line. SimpleCharStream.java Version 4.0 */
package org.j_paine.formatter;
/**
* An implementation of interface CharStream, where the stream is assumed to
* contain only ASCII characters (without unicode processing).
*/
public class SimpleCharStream
{
public static final boolean staticFlag = false;
int bufsize;
int available;
int tokenBegin;
public int bufpos = -1;
protected int bufline[];
protected int bufcolumn[];
protected int column = 0;
protected int line = 1;
protected boolean prevCharIsCR = false;
protected boolean prevCharIsLF = false;
protected java.io.Reader inputStream;
protected char[] buffer;
protected int maxNextCharInd = 0;
protected int inBuf = 0;
protected int tabSize = 8;
protected void setTabSize(int i) { tabSize = i; }
protected int getTabSize(int i) { return tabSize; }
protected void ExpandBuff(boolean wrapAround)
{
char[] newbuffer = new char[bufsize + 2048];
int newbufline[] = new int[bufsize + 2048];
int newbufcolumn[] = new int[bufsize + 2048];
try
{
if (wrapAround)
{
System.arraycopy(buffer, tokenBegin, newbuffer, 0, bufsize - tokenBegin);
System.arraycopy(buffer, 0, newbuffer,
bufsize - tokenBegin, bufpos);
buffer = newbuffer;
System.arraycopy(bufline, tokenBegin, newbufline, 0, bufsize - tokenBegin);
System.arraycopy(bufline, 0, newbufline, bufsize - tokenBegin, bufpos);
bufline = newbufline;
System.arraycopy(bufcolumn, tokenBegin, newbufcolumn, 0, bufsize - tokenBegin);
System.arraycopy(bufcolumn, 0, newbufcolumn, bufsize - tokenBegin, bufpos);
bufcolumn = newbufcolumn;
maxNextCharInd = (bufpos += (bufsize - tokenBegin));
}
else
{
System.arraycopy(buffer, tokenBegin, newbuffer, 0, bufsize - tokenBegin);
buffer = newbuffer;
System.arraycopy(bufline, tokenBegin, newbufline, 0, bufsize - tokenBegin);
bufline = newbufline;
System.arraycopy(bufcolumn, tokenBegin, newbufcolumn, 0, bufsize - tokenBegin);
bufcolumn = newbufcolumn;
maxNextCharInd = (bufpos -= tokenBegin);
}
}
catch (Throwable t)
{
throw new Error(t.getMessage());
}
bufsize += 2048;
available = bufsize;
tokenBegin = 0;
}
protected void FillBuff() throws java.io.IOException
{
if (maxNextCharInd == available)
{
if (available == bufsize)
{
if (tokenBegin > 2048)
{
bufpos = maxNextCharInd = 0;
available = tokenBegin;
}
else if (tokenBegin < 0)
bufpos = maxNextCharInd = 0;
else
ExpandBuff(false);
}
else if (available > tokenBegin)
available = bufsize;
else if ((tokenBegin - available) < 2048)
ExpandBuff(true);
else
available = tokenBegin;
}
int i;
try {
if ((i = inputStream.read(buffer, maxNextCharInd,
available - maxNextCharInd)) == -1)
{
inputStream.close();
throw new java.io.IOException();
}
else
maxNextCharInd += i;
return;
}
catch(java.io.IOException e) {
--bufpos;
backup(0);
if (tokenBegin == -1)
tokenBegin = bufpos;
throw e;
}
}
public char BeginToken() throws java.io.IOException
{
tokenBegin = -1;
char c = readChar();
tokenBegin = bufpos;
return c;
}
protected void UpdateLineColumn(char c)
{
column++;
if (prevCharIsLF)
{
prevCharIsLF = false;
line += (column = 1);
}
else if (prevCharIsCR)
{
prevCharIsCR = false;
if (c == '\n')
{
prevCharIsLF = true;
}
else
line += (column = 1);
}
switch (c)
{
case '\r' :
prevCharIsCR = true;
break;
case '\n' :
prevCharIsLF = true;
break;
case '\t' :
column--;
column += (tabSize - (column % tabSize));
break;
default :
break;
}
bufline[bufpos] = line;
bufcolumn[bufpos] = column;
}
public char readChar() throws java.io.IOException
{
if (inBuf > 0)
{
--inBuf;
if (++bufpos == bufsize)
bufpos = 0;
return buffer[bufpos];
}
if (++bufpos >= maxNextCharInd)
FillBuff();
char c = buffer[bufpos];
UpdateLineColumn(c);
return (c);
}
/**
* @deprecated
* @see #getEndColumn
*/
public int getColumn() {
return bufcolumn[bufpos];
}
/**
* @deprecated
* @see #getEndLine
*/
public int getLine() {
return bufline[bufpos];
}
public int getEndColumn() {
return bufcolumn[bufpos];
}
public int getEndLine() {
return bufline[bufpos];
}
public int getBeginColumn() {
return bufcolumn[tokenBegin];
}
public int getBeginLine() {
return bufline[tokenBegin];
}
public void backup(int amount) {
inBuf += amount;
if ((bufpos -= amount) < 0)
bufpos += bufsize;
}
public SimpleCharStream(java.io.Reader dstream, int startline,
int startcolumn, int buffersize)
{
inputStream = dstream;
line = startline;
column = startcolumn - 1;
available = bufsize = buffersize;
buffer = new char[buffersize];
bufline = new int[buffersize];
bufcolumn = new int[buffersize];
}
public SimpleCharStream(java.io.Reader dstream, int startline,
int startcolumn)
{
this(dstream, startline, startcolumn, 4096);
}
public SimpleCharStream(java.io.Reader dstream)
{
this(dstream, 1, 1, 4096);
}
public void ReInit(java.io.Reader dstream, int startline,
int startcolumn, int buffersize)
{
inputStream = dstream;
line = startline;
column = startcolumn - 1;
if (buffer == null || buffersize != buffer.length)
{
available = bufsize = buffersize;
buffer = new char[buffersize];
bufline = new int[buffersize];
bufcolumn = new int[buffersize];
}
prevCharIsLF = prevCharIsCR = false;
tokenBegin = inBuf = maxNextCharInd = 0;
bufpos = -1;
}
public void ReInit(java.io.Reader dstream, int startline,
int startcolumn)
{
ReInit(dstream, startline, startcolumn, 4096);
}
public void ReInit(java.io.Reader dstream)
{
ReInit(dstream, 1, 1, 4096);
}
public SimpleCharStream(java.io.InputStream dstream, String encoding, int startline,
int startcolumn, int buffersize) throws java.io.UnsupportedEncodingException
{
this(encoding == null ? new java.io.InputStreamReader(dstream) : new java.io.InputStreamReader(dstream, encoding), startline, startcolumn, buffersize);
}
public SimpleCharStream(java.io.InputStream dstream, int startline,
int startcolumn, int buffersize)
{
this(new java.io.InputStreamReader(dstream), startline, startcolumn, buffersize);
}
public SimpleCharStream(java.io.InputStream dstream, String encoding, int startline,
int startcolumn) throws java.io.UnsupportedEncodingException
{
this(dstream, encoding, startline, startcolumn, 4096);
}
public SimpleCharStream(java.io.InputStream dstream, int startline,
int startcolumn)
{
this(dstream, startline, startcolumn, 4096);
}
public SimpleCharStream(java.io.InputStream dstream, String encoding) throws java.io.UnsupportedEncodingException
{
this(dstream, encoding, 1, 1, 4096);
}
public SimpleCharStream(java.io.InputStream dstream)
{
this(dstream, 1, 1, 4096);
}
public void ReInit(java.io.InputStream dstream, String encoding, int startline,
int startcolumn, int buffersize) throws java.io.UnsupportedEncodingException
{
ReInit(encoding == null ? new java.io.InputStreamReader(dstream) : new java.io.InputStreamReader(dstream, encoding), startline, startcolumn, buffersize);
}
public void ReInit(java.io.InputStream dstream, int startline,
int startcolumn, int buffersize)
{
ReInit(new java.io.InputStreamReader(dstream), startline, startcolumn, buffersize);
}
public void ReInit(java.io.InputStream dstream, String encoding) throws java.io.UnsupportedEncodingException
{
ReInit(dstream, encoding, 1, 1, 4096);
}
public void ReInit(java.io.InputStream dstream)
{
ReInit(dstream, 1, 1, 4096);
}
public void ReInit(java.io.InputStream dstream, String encoding, int startline,
int startcolumn) throws java.io.UnsupportedEncodingException
{
ReInit(dstream, encoding, startline, startcolumn, 4096);
}
public void ReInit(java.io.InputStream dstream, int startline,
int startcolumn)
{
ReInit(dstream, startline, startcolumn, 4096);
}
public String GetImage()
{
if (bufpos >= tokenBegin)
return new String(buffer, tokenBegin, bufpos - tokenBegin + 1);
else
return new String(buffer, tokenBegin, bufsize - tokenBegin) +
new String(buffer, 0, bufpos + 1);
}
public char[] GetSuffix(int len)
{
char[] ret = new char[len];
if ((bufpos + 1) >= len)
System.arraycopy(buffer, bufpos - len + 1, ret, 0, len);
else
{
System.arraycopy(buffer, bufsize - (len - bufpos - 1), ret, 0,
len - bufpos - 1);
System.arraycopy(buffer, 0, ret, len - bufpos - 1, bufpos + 1);
}
return ret;
}
public void Done()
{
buffer = null;
bufline = null;
bufcolumn = null;
}
/**
* Method to adjust line and column numbers for the start of a token.
*/
public void adjustBeginLineColumn(int newLine, int newCol)
{
int start = tokenBegin;
int len;
if (bufpos >= tokenBegin)
{
len = bufpos - tokenBegin + inBuf + 1;
}
else
{
len = bufsize - tokenBegin + bufpos + 1 + inBuf;
}
int i = 0, j = 0, k = 0;
int nextColDiff = 0, columnDiff = 0;
while (i < len &&
bufline[j = start % bufsize] == bufline[k = ++start % bufsize])
{
bufline[j] = newLine;
nextColDiff = columnDiff + bufcolumn[k] - bufcolumn[j];
bufcolumn[j] = newCol + columnDiff;
columnDiff = nextColDiff;
i++;
}
if (i < len)
{
bufline[j] = newLine++;
bufcolumn[j] = newCol + columnDiff;
while (i++ < len)
{
if (bufline[j = start % bufsize] != bufline[++start % bufsize])
bufline[j] = newLine++;
else
bufline[j] = newLine;
}
}
line = bufline[j];
column = bufcolumn[j];
}
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/j_paine/formatter/NumberParser.jj 0000644 0001750 0001750 00000003227 10616163245 027655 0 ustar osallou osallou /* NumberParser.java */
/*
This parser is used to check the syntax of numbers read by our
formatted read routines.
*/
options {
STATIC = false;
DEBUG_PARSER = false;
DEBUG_TOKEN_MANAGER = false;
DEBUG_LOOKAHEAD = false;
}
PARSER_BEGIN(NumberParser)
package org.j_paine.formatter;
class NumberParser
{
}
PARSER_END(NumberParser)
TOKEN :
{
< INTEGER_LITERAL:
>
|
< #DECIMAL_LITERAL:
"0"
| ["1"-"9"] (["0"-"9"])*
>
|
< LOGICAL_LITERAL:
"T" | "F"
>
// We don't allow leading zeroes in integers, as these
// might indicate typing errors in the data.
|
< FLOATING_POINT_LITERAL:
(["0"-"9"])+ "." (["0"-"9"])* ()?
| "." (["0"-"9"])+ ()?
| (["0"-"9"])+
| (["0"-"9"])+ ()?
>
|
< #EXPONENT: ["e","E"] (["+","-"])? (["0"-"9"])+ >
}
int Float():
{ int start = 0;
}
{
( " " {start++;} )*
[ "-" | "+" ]
( | )
{ return start; }
}
// This is the syntax of numbers we want a real format to accept.
// The makes sure that trailing non-numeric characters
// (even spaces) are reported as an error.
// Returns an integer which is the number of spaces to skip before
// the number starts.
int Integer():
{ int start = 0;
}
{
( " " {start++;} )*
[ "-" | "+" ]
{ return start; }
}
// This is the syntax of numbers we want an integer format to
// accept.
// Returns an integer which is the number of spaces to skip before
// the number starts.
int Boolean():
{ int start = 0;
}
{
( " " {start++;} )*
{ return start; }
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/util/org/j_paine/formatter/FormatParser.java 0000644 0001750 0001750 00000033374 10616163245 030201 0 ustar osallou osallou /* Generated By:JavaCC: Do not edit this line. FormatParser.java */
package org.j_paine.formatter;
class FormatParser implements FormatParserConstants {
static final public int Integer() throws ParseException {
Token t;
t = jj_consume_token(INTEGER);
{if (true) return (Integer.valueOf(t.image)).intValue();}
throw new Error("Missing return statement in function");
}
static final public FormatElement FormatIOElementFloat() throws ParseException {
FormatElement fe;
int w, d, m;
w = d = m = -1;
switch ((jj_ntk==-1)?jj_ntk():jj_ntk) {
case F_DESC:
jj_consume_token(F_DESC);
w = Integer();
jj_consume_token(13);
d = Integer();
fe=new FormatF(w,d);
break;
case D_DESC:
jj_consume_token(D_DESC);
w = Integer();
jj_consume_token(13);
d = Integer();
fe=new FormatE(w,d);
break;
case E_DESC:
jj_consume_token(E_DESC);
w = Integer();
jj_consume_token(13);
d = Integer();
fe=new FormatE(w,d);
break;
case G_DESC:
jj_consume_token(G_DESC);
w = Integer();
jj_consume_token(13);
d = Integer();
fe=new FormatE(w,d);
break;
default:
jj_la1[0] = jj_gen;
jj_consume_token(-1);
throw new ParseException();
}
{if (true) return fe;}
throw new Error("Missing return statement in function");
}
static final public FormatElement FormatIOElementNonFloat() throws ParseException {
FormatElement fe;
int w, d, m;
w = d = m = -1;
switch ((jj_ntk==-1)?jj_ntk():jj_ntk) {
case A_DESC:
jj_consume_token(A_DESC);
switch ((jj_ntk==-1)?jj_ntk():jj_ntk) {
case INTEGER:
w = Integer();
break;
default:
jj_la1[1] = jj_gen;
;
}
fe=new FormatA(w);
break;
case I_DESC:
jj_consume_token(I_DESC);
w = Integer();
switch ((jj_ntk==-1)?jj_ntk():jj_ntk) {
case 13:
jj_consume_token(13);
m = Integer();
break;
default:
jj_la1[2] = jj_gen;
;
}
fe=new FormatI(w);
break;
case L_DESC:
jj_consume_token(L_DESC);
w = Integer();
fe=new FormatL(w);
break;
default:
jj_la1[3] = jj_gen;
jj_consume_token(-1);
throw new ParseException();
}
{if (true) return fe;}
throw new Error("Missing return statement in function");
}
// This represents a format element that transfers one
// data item.
static final public FormatElement FormatNonIOElement() throws ParseException {
jj_consume_token(X_DESC);
{if (true) return new FormatX();}
throw new Error("Missing return statement in function");
}
// This represents a format element that doesn't transfer
// any data items.
static final public FormatElement FormatElement() throws ParseException {
FormatElement fe;
switch ((jj_ntk==-1)?jj_ntk():jj_ntk) {
case F_DESC:
case D_DESC:
case E_DESC:
case G_DESC:
fe = FormatIOElementFloat();
break;
case A_DESC:
case I_DESC:
case L_DESC:
fe = FormatIOElementNonFloat();
break;
case X_DESC:
fe = FormatNonIOElement();
break;
case P_DESC:
fe = FormatScale();
break;
default:
jj_la1[4] = jj_gen;
jj_consume_token(-1);
throw new ParseException();
}
{if (true) return fe;}
throw new Error("Missing return statement in function");
}
static final public FormatElement FormatScale() throws ParseException {
FormatElement fe = null;
int r=1;
jj_consume_token(P_DESC);
switch ((jj_ntk==-1)?jj_ntk():jj_ntk) {
case INTEGER:
case F_DESC:
case D_DESC:
case E_DESC:
case G_DESC:
switch ((jj_ntk==-1)?jj_ntk():jj_ntk) {
case INTEGER:
r = Integer();
break;
default:
jj_la1[5] = jj_gen;
;
}
fe = FormatIOElementFloat();
break;
default:
jj_la1[6] = jj_gen;
;
}
{if (true) return new FormatP(r, fe);}
throw new Error("Missing return statement in function");
}
static final public FormatSlash FormatSlash() throws ParseException {
jj_consume_token(14);
{if (true) return new FormatSlash();}
throw new Error("Missing return statement in function");
}
// These are a special case. Unlike other format elements,
// Fortran permits several slashes to be concatenated without
// commas to separate them, and you can't use a repetition
// factor on them.
static final public FormatString FormatString() throws ParseException {
Token t;
String s;
t = jj_consume_token(STRING);
s = t.image;
s = s.substring(1,s.length()-1); // Remove the quotes.
{if (true) return new FormatString(s);}
throw new Error("Missing return statement in function");
}
// Another special case that can't be repeated, and can be
// concatenated to other elements without commas.
static final public void OptionalFormatSlashesOrStrings(Format f) throws ParseException {
FormatUniv fs;
label_1:
while (true) {
switch ((jj_ntk==-1)?jj_ntk():jj_ntk) {
case STRING:
case 14:
;
break;
default:
jj_la1[7] = jj_gen;
break label_1;
}
switch ((jj_ntk==-1)?jj_ntk():jj_ntk) {
case 14:
fs = FormatSlash();
break;
case STRING:
fs = FormatString();
break;
default:
jj_la1[8] = jj_gen;
jj_consume_token(-1);
throw new ParseException();
}
f.addElement(fs);
}
}
static final public FormatRepeatedItem FormatRepeatedItem() throws ParseException {
int r=1;
FormatUniv fu;
switch ((jj_ntk==-1)?jj_ntk():jj_ntk) {
case INTEGER:
r = Integer();
break;
default:
jj_la1[9] = jj_gen;
;
}
switch ((jj_ntk==-1)?jj_ntk():jj_ntk) {
case 15:
jj_consume_token(15);
fu = Format();
jj_consume_token(16);
break;
case A_DESC:
case P_DESC:
case X_DESC:
case I_DESC:
case F_DESC:
case D_DESC:
case E_DESC:
case G_DESC:
case L_DESC:
fu = FormatElement();
break;
default:
jj_la1[10] = jj_gen;
jj_consume_token(-1);
throw new ParseException();
}
if(fu instanceof FormatP) {
FormatRepeatedItem ritem;
ritem = ((FormatP)fu).getRepeatedItem();
if(ritem != null)
{if (true) return ritem;}
else
{if (true) return new FormatRepeatedItem( r, fu );}
}
else
{if (true) return new FormatRepeatedItem( r, fu );}
throw new Error("Missing return statement in function");
}
static final public void FormatGroup(Format f) throws ParseException {
FormatRepeatedItem fri;
OptionalFormatSlashesOrStrings(f);
switch ((jj_ntk==-1)?jj_ntk():jj_ntk) {
case INTEGER:
case A_DESC:
case P_DESC:
case X_DESC:
case I_DESC:
case F_DESC:
case D_DESC:
case E_DESC:
case G_DESC:
case L_DESC:
case 15:
fri = FormatRepeatedItem();
if(fri != null) f.addElement(fri);
OptionalFormatSlashesOrStrings(f);
break;
default:
jj_la1[11] = jj_gen;
;
}
}
// This rather messy syntax allows us to have slashes and/or
// strings either side of a format element or repeated group
// without needing to separate them from each other or the element
// with commas.
// It also means that we can have empty format groups and format
// groups that don't transfer any data elements. So for example,
// the format ,/, is valid under this grammar.
static final public Format Format() throws ParseException {
FormatRepeatedItem fri;
Format f = new Format();
FormatGroup(f);
label_2:
while (true) {
switch ((jj_ntk==-1)?jj_ntk():jj_ntk) {
case 17:
;
break;
default:
jj_la1[12] = jj_gen;
break label_2;
}
jj_consume_token(17);
FormatGroup(f);
}
{if (true) return f;}
throw new Error("Missing return statement in function");
}
static private boolean jj_initialized_once = false;
static public FormatParserTokenManager token_source;
static SimpleCharStream jj_input_stream;
static public Token token, jj_nt;
static private int jj_ntk;
static private int jj_gen;
static final private int[] jj_la1 = new int[13];
static private int[] jj_la1_0;
static {
jj_la1_0();
}
private static void jj_la1_0() {
jj_la1_0 = new int[] {0xf00,0x4,0x2000,0x1090,0x1ff0,0x4,0xf04,0x4008,0x4008,0x4,0x9ff0,0x9ff4,0x20000,};
}
public FormatParser(java.io.InputStream stream) {
this(stream, null);
}
public FormatParser(java.io.InputStream stream, String encoding) {
if (jj_initialized_once) {
System.out.println("ERROR: Second call to constructor of static parser. You must");
System.out.println(" either use ReInit() or set the JavaCC option STATIC to false");
System.out.println(" during parser generation.");
throw new Error();
}
jj_initialized_once = true;
try { jj_input_stream = new SimpleCharStream(stream, encoding, 1, 1); } catch(java.io.UnsupportedEncodingException e) { throw new RuntimeException(e); }
token_source = new FormatParserTokenManager(jj_input_stream);
token = new Token();
jj_ntk = -1;
jj_gen = 0;
for (int i = 0; i < 13; i++) jj_la1[i] = -1;
}
static public void ReInit(java.io.InputStream stream) {
ReInit(stream, null);
}
static public void ReInit(java.io.InputStream stream, String encoding) {
try { jj_input_stream.ReInit(stream, encoding, 1, 1); } catch(java.io.UnsupportedEncodingException e) { throw new RuntimeException(e); }
token_source.ReInit(jj_input_stream);
token = new Token();
jj_ntk = -1;
jj_gen = 0;
for (int i = 0; i < 13; i++) jj_la1[i] = -1;
}
public FormatParser(java.io.Reader stream) {
if (jj_initialized_once) {
System.out.println("ERROR: Second call to constructor of static parser. You must");
System.out.println(" either use ReInit() or set the JavaCC option STATIC to false");
System.out.println(" during parser generation.");
throw new Error();
}
jj_initialized_once = true;
jj_input_stream = new SimpleCharStream(stream, 1, 1);
token_source = new FormatParserTokenManager(jj_input_stream);
token = new Token();
jj_ntk = -1;
jj_gen = 0;
for (int i = 0; i < 13; i++) jj_la1[i] = -1;
}
static public void ReInit(java.io.Reader stream) {
jj_input_stream.ReInit(stream, 1, 1);
token_source.ReInit(jj_input_stream);
token = new Token();
jj_ntk = -1;
jj_gen = 0;
for (int i = 0; i < 13; i++) jj_la1[i] = -1;
}
public FormatParser(FormatParserTokenManager tm) {
if (jj_initialized_once) {
System.out.println("ERROR: Second call to constructor of static parser. You must");
System.out.println(" either use ReInit() or set the JavaCC option STATIC to false");
System.out.println(" during parser generation.");
throw new Error();
}
jj_initialized_once = true;
token_source = tm;
token = new Token();
jj_ntk = -1;
jj_gen = 0;
for (int i = 0; i < 13; i++) jj_la1[i] = -1;
}
public void ReInit(FormatParserTokenManager tm) {
token_source = tm;
token = new Token();
jj_ntk = -1;
jj_gen = 0;
for (int i = 0; i < 13; i++) jj_la1[i] = -1;
}
static final private Token jj_consume_token(int kind) throws ParseException {
Token oldToken;
if ((oldToken = token).next != null) token = token.next;
else token = token.next = token_source.getNextToken();
jj_ntk = -1;
if (token.kind == kind) {
jj_gen++;
return token;
}
token = oldToken;
jj_kind = kind;
throw generateParseException();
}
static final public Token getNextToken() {
if (token.next != null) token = token.next;
else token = token.next = token_source.getNextToken();
jj_ntk = -1;
jj_gen++;
return token;
}
static final public Token getToken(int index) {
Token t = token;
for (int i = 0; i < index; i++) {
if (t.next != null) t = t.next;
else t = t.next = token_source.getNextToken();
}
return t;
}
static final private int jj_ntk() {
if ((jj_nt=token.next) == null)
return (jj_ntk = (token.next=token_source.getNextToken()).kind);
else
return (jj_ntk = jj_nt.kind);
}
static private java.util.Vector jj_expentries = new java.util.Vector();
static private int[] jj_expentry;
static private int jj_kind = -1;
static public ParseException generateParseException() {
jj_expentries.removeAllElements();
boolean[] la1tokens = new boolean[18];
for (int i = 0; i < 18; i++) {
la1tokens[i] = false;
}
if (jj_kind >= 0) {
la1tokens[jj_kind] = true;
jj_kind = -1;
}
for (int i = 0; i < 13; i++) {
if (jj_la1[i] == jj_gen) {
for (int j = 0; j < 32; j++) {
if ((jj_la1_0[i] & (1< /dev/null
cd $(OUTDIR); $(JAR) cvf ../$(LAPACK_JAR) `find . -name "*.class"`
mkdir -p $(SIMPLE_DIR)/$(LAPACK_PDIR)
-cp `find $(OUTDIR)/$(LAPACK_PDIR) -name "[A-Z][A-Z]*.java"` $(SIMPLE_DIR)/$(LAPACK_PDIR)
-$(JAVAC) -classpath .:$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):$(LAPACK_JAR):$(SIMPLE_DIR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR) $(SIMPLE_DIR)/$(LAPACK_PDIR)/*.java
cd $(SIMPLE_DIR); $(JAR) cvf ../$(SIMPLE_LAPACK_JAR) `find . -name "*.class"`
nojar: $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(ERR_DIR)/$(ERR_JAR) lapack.f
$(F2J) $(F2JFLAGS) lapack.f > /dev/null
$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):
cd $(ROOT)/$(BLAS_DIR);$(MAKE)
$(ROOT)/$(ERR_DIR)/$(ERR_JAR):
cd $(ROOT)/$(ERR_DIR);$(MAKE)
javasrc:
$(MAKE) -f Makefile_javasrc
verify: $(LAPACK_JAR)
cd $(OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR) $(VERIFY) $(LAPACK_PDIR)/*.class
clean:
/bin/rm -rf *.java *.class *.f2j $(SIMPLE_LAPACK_JAR) $(LAPACK_JAR) $(OUTDIR) $(JAVASRC_OUTDIR) $(SIMPLE_DIR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/lapack/verify_all.csh 0000755 0001750 0001750 00000000317 10616163232 023631 0 ustar osallou osallou #!/bin/csh
setenv CPTMP $CLASSPATH":../../blas/blas.jar:../../error_reporting/xerbla.jar"
cd obj
foreach file(org/netlib/lapack/*.class)
java -classpath $CPTMP de.fub.bytecode.verifier.Verifier $file
end
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/lapack/lapack.f 0000644 0001750 0001750 00033452413 10616442117 022415 0 ustar osallou osallou SUBROUTINE DBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ,
$ WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER COMPQ, UPLO
INTEGER INFO, LDU, LDVT, N
* ..
* .. Array Arguments ..
INTEGER IQ( * ), IWORK( * )
DOUBLE PRECISION D( * ), E( * ), Q( * ), U( LDU, * ),
$ VT( LDVT, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DBDSDC computes the singular value decomposition (SVD) of a real
* N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT,
* using a divide and conquer method, where S is a diagonal matrix
* with non-negative diagonal elements (the singular values of B), and
* U and VT are orthogonal matrices of left and right singular vectors,
* respectively. DBDSDC can be used to compute all singular values,
* and optionally, singular vectors or singular vectors in compact form.
*
* This code makes very mild assumptions about floating point
* arithmetic. It will work on machines with a guard digit in
* add/subtract, or on those binary machines without guard digits
* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
* It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none. See DLASD3 for details.
*
* The code currently calls DLASDQ if singular values only are desired.
* However, it can be slightly modified to compute singular values
* using the divide and conquer method.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': B is upper bidiagonal.
* = 'L': B is lower bidiagonal.
*
* COMPQ (input) CHARACTER*1
* Specifies whether singular vectors are to be computed
* as follows:
* = 'N': Compute singular values only;
* = 'P': Compute singular values and compute singular
* vectors in compact form;
* = 'I': Compute singular values and singular vectors.
*
* N (input) INTEGER
* The order of the matrix B. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the n diagonal elements of the bidiagonal matrix B.
* On exit, if INFO=0, the singular values of B.
*
* E (input/output) DOUBLE PRECISION array, dimension (N-1)
* On entry, the elements of E contain the offdiagonal
* elements of the bidiagonal matrix whose SVD is desired.
* On exit, E has been destroyed.
*
* U (output) DOUBLE PRECISION array, dimension (LDU,N)
* If COMPQ = 'I', then:
* On exit, if INFO = 0, U contains the left singular vectors
* of the bidiagonal matrix.
* For other values of COMPQ, U is not referenced.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= 1.
* If singular vectors are desired, then LDU >= max( 1, N ).
*
* VT (output) DOUBLE PRECISION array, dimension (LDVT,N)
* If COMPQ = 'I', then:
* On exit, if INFO = 0, VT' contains the right singular
* vectors of the bidiagonal matrix.
* For other values of COMPQ, VT is not referenced.
*
* LDVT (input) INTEGER
* The leading dimension of the array VT. LDVT >= 1.
* If singular vectors are desired, then LDVT >= max( 1, N ).
*
* Q (output) DOUBLE PRECISION array, dimension (LDQ)
* If COMPQ = 'P', then:
* On exit, if INFO = 0, Q and IQ contain the left
* and right singular vectors in a compact form,
* requiring O(N log N) space instead of 2*N**2.
* In particular, Q contains all the DOUBLE PRECISION data in
* LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))
* words of memory, where SMLSIZ is returned by ILAENV and
* is equal to the maximum size of the subproblems at the
* bottom of the computation tree (usually about 25).
* For other values of COMPQ, Q is not referenced.
*
* IQ (output) INTEGER array, dimension (LDIQ)
* If COMPQ = 'P', then:
* On exit, if INFO = 0, Q and IQ contain the left
* and right singular vectors in a compact form,
* requiring O(N log N) space instead of 2*N**2.
* In particular, IQ contains all INTEGER data in
* LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))
* words of memory, where SMLSIZ is returned by ILAENV and
* is equal to the maximum size of the subproblems at the
* bottom of the computation tree (usually about 25).
* For other values of COMPQ, IQ is not referenced.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
* If COMPQ = 'N' then LWORK >= (4 * N).
* If COMPQ = 'P' then LWORK >= (6 * N).
* If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N).
*
* IWORK (workspace) INTEGER array, dimension (8*N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: The algorithm failed to compute an singular value.
* The update process of divide and conquer failed.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
* Changed dimension statement in comment describing E from (N) to
* (N-1). Sven, 17 Feb 05.
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
* ..
* .. Local Scalars ..
INTEGER DIFL, DIFR, GIVCOL, GIVNUM, GIVPTR, I, IC,
$ ICOMPQ, IERR, II, IS, IU, IUPLO, IVT, J, K, KK,
$ MLVL, NM1, NSIZE, PERM, POLES, QSTART, SMLSIZ,
$ SMLSZP, SQRE, START, WSTART, Z
DOUBLE PRECISION CS, EPS, ORGNRM, P, R, SN
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANST
EXTERNAL LSAME, ILAENV, DLAMCH, DLANST
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLARTG, DLASCL, DLASD0, DLASDA, DLASDQ,
$ DLASET, DLASR, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, INT, LOG, SIGN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IUPLO = 0
IF( LSAME( UPLO, 'U' ) )
$ IUPLO = 1
IF( LSAME( UPLO, 'L' ) )
$ IUPLO = 2
IF( LSAME( COMPQ, 'N' ) ) THEN
ICOMPQ = 0
ELSE IF( LSAME( COMPQ, 'P' ) ) THEN
ICOMPQ = 1
ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
ICOMPQ = 2
ELSE
ICOMPQ = -1
END IF
IF( IUPLO.EQ.0 ) THEN
INFO = -1
ELSE IF( ICOMPQ.LT.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ( LDU.LT.1 ) .OR. ( ( ICOMPQ.EQ.2 ) .AND. ( LDU.LT.
$ N ) ) ) THEN
INFO = -7
ELSE IF( ( LDVT.LT.1 ) .OR. ( ( ICOMPQ.EQ.2 ) .AND. ( LDVT.LT.
$ N ) ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DBDSDC', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
SMLSIZ = ILAENV( 9, 'DBDSDC', ' ', 0, 0, 0, 0 )
IF( N.EQ.1 ) THEN
IF( ICOMPQ.EQ.1 ) THEN
Q( 1 ) = SIGN( ONE, D( 1 ) )
Q( 1+SMLSIZ*N ) = ONE
ELSE IF( ICOMPQ.EQ.2 ) THEN
U( 1, 1 ) = SIGN( ONE, D( 1 ) )
VT( 1, 1 ) = ONE
END IF
D( 1 ) = ABS( D( 1 ) )
RETURN
END IF
NM1 = N - 1
*
* If matrix lower bidiagonal, rotate to be upper bidiagonal
* by applying Givens rotations on the left
*
WSTART = 1
QSTART = 3
IF( ICOMPQ.EQ.1 ) THEN
CALL DCOPY( N, D, 1, Q( 1 ), 1 )
CALL DCOPY( N-1, E, 1, Q( N+1 ), 1 )
END IF
IF( IUPLO.EQ.2 ) THEN
QSTART = 5
WSTART = 2*N - 1
DO 10 I = 1, N - 1
CALL DLARTG( D( I ), E( I ), CS, SN, R )
D( I ) = R
E( I ) = SN*D( I+1 )
D( I+1 ) = CS*D( I+1 )
IF( ICOMPQ.EQ.1 ) THEN
Q( I+2*N ) = CS
Q( I+3*N ) = SN
ELSE IF( ICOMPQ.EQ.2 ) THEN
WORK( I ) = CS
WORK( NM1+I ) = -SN
END IF
10 CONTINUE
END IF
*
* If ICOMPQ = 0, use DLASDQ to compute the singular values.
*
IF( ICOMPQ.EQ.0 ) THEN
CALL DLASDQ( 'U', 0, N, 0, 0, 0, D, E, VT, LDVT, U, LDU, U,
$ LDU, WORK( WSTART ), INFO )
GO TO 40
END IF
*
* If N is smaller than the minimum divide size SMLSIZ, then solve
* the problem with another solver.
*
IF( N.LE.SMLSIZ ) THEN
IF( ICOMPQ.EQ.2 ) THEN
CALL DLASET( 'A', N, N, ZERO, ONE, U, LDU )
CALL DLASET( 'A', N, N, ZERO, ONE, VT, LDVT )
CALL DLASDQ( 'U', 0, N, N, N, 0, D, E, VT, LDVT, U, LDU, U,
$ LDU, WORK( WSTART ), INFO )
ELSE IF( ICOMPQ.EQ.1 ) THEN
IU = 1
IVT = IU + N
CALL DLASET( 'A', N, N, ZERO, ONE, Q( IU+( QSTART-1 )*N ),
$ N )
CALL DLASET( 'A', N, N, ZERO, ONE, Q( IVT+( QSTART-1 )*N ),
$ N )
CALL DLASDQ( 'U', 0, N, N, N, 0, D, E,
$ Q( IVT+( QSTART-1 )*N ), N,
$ Q( IU+( QSTART-1 )*N ), N,
$ Q( IU+( QSTART-1 )*N ), N, WORK( WSTART ),
$ INFO )
END IF
GO TO 40
END IF
*
IF( ICOMPQ.EQ.2 ) THEN
CALL DLASET( 'A', N, N, ZERO, ONE, U, LDU )
CALL DLASET( 'A', N, N, ZERO, ONE, VT, LDVT )
END IF
*
* Scale.
*
ORGNRM = DLANST( 'M', N, D, E )
IF( ORGNRM.EQ.ZERO )
$ RETURN
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, IERR )
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, IERR )
*
EPS = DLAMCH( 'Epsilon' )
*
MLVL = INT( LOG( DBLE( N ) / DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1
SMLSZP = SMLSIZ + 1
*
IF( ICOMPQ.EQ.1 ) THEN
IU = 1
IVT = 1 + SMLSIZ
DIFL = IVT + SMLSZP
DIFR = DIFL + MLVL
Z = DIFR + MLVL*2
IC = Z + MLVL
IS = IC + 1
POLES = IS + 1
GIVNUM = POLES + 2*MLVL
*
K = 1
GIVPTR = 2
PERM = 3
GIVCOL = PERM + MLVL
END IF
*
DO 20 I = 1, N
IF( ABS( D( I ) ).LT.EPS ) THEN
D( I ) = SIGN( EPS, D( I ) )
END IF
20 CONTINUE
*
START = 1
SQRE = 0
*
DO 30 I = 1, NM1
IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN
*
* Subproblem found. First determine its size and then
* apply divide and conquer on it.
*
IF( I.LT.NM1 ) THEN
*
* A subproblem with E(I) small for I < NM1.
*
NSIZE = I - START + 1
ELSE IF( ABS( E( I ) ).GE.EPS ) THEN
*
* A subproblem with E(NM1) not too small but I = NM1.
*
NSIZE = N - START + 1
ELSE
*
* A subproblem with E(NM1) small. This implies an
* 1-by-1 subproblem at D(N). Solve this 1-by-1 problem
* first.
*
NSIZE = I - START + 1
IF( ICOMPQ.EQ.2 ) THEN
U( N, N ) = SIGN( ONE, D( N ) )
VT( N, N ) = ONE
ELSE IF( ICOMPQ.EQ.1 ) THEN
Q( N+( QSTART-1 )*N ) = SIGN( ONE, D( N ) )
Q( N+( SMLSIZ+QSTART-1 )*N ) = ONE
END IF
D( N ) = ABS( D( N ) )
END IF
IF( ICOMPQ.EQ.2 ) THEN
CALL DLASD0( NSIZE, SQRE, D( START ), E( START ),
$ U( START, START ), LDU, VT( START, START ),
$ LDVT, SMLSIZ, IWORK, WORK( WSTART ), INFO )
ELSE
CALL DLASDA( ICOMPQ, SMLSIZ, NSIZE, SQRE, D( START ),
$ E( START ), Q( START+( IU+QSTART-2 )*N ), N,
$ Q( START+( IVT+QSTART-2 )*N ),
$ IQ( START+K*N ), Q( START+( DIFL+QSTART-2 )*
$ N ), Q( START+( DIFR+QSTART-2 )*N ),
$ Q( START+( Z+QSTART-2 )*N ),
$ Q( START+( POLES+QSTART-2 )*N ),
$ IQ( START+GIVPTR*N ), IQ( START+GIVCOL*N ),
$ N, IQ( START+PERM*N ),
$ Q( START+( GIVNUM+QSTART-2 )*N ),
$ Q( START+( IC+QSTART-2 )*N ),
$ Q( START+( IS+QSTART-2 )*N ),
$ WORK( WSTART ), IWORK, INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
END IF
START = I + 1
END IF
30 CONTINUE
*
* Unscale
*
CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, IERR )
40 CONTINUE
*
* Use Selection Sort to minimize swaps of singular vectors
*
DO 60 II = 2, N
I = II - 1
KK = I
P = D( I )
DO 50 J = II, N
IF( D( J ).GT.P ) THEN
KK = J
P = D( J )
END IF
50 CONTINUE
IF( KK.NE.I ) THEN
D( KK ) = D( I )
D( I ) = P
IF( ICOMPQ.EQ.1 ) THEN
IQ( I ) = KK
ELSE IF( ICOMPQ.EQ.2 ) THEN
CALL DSWAP( N, U( 1, I ), 1, U( 1, KK ), 1 )
CALL DSWAP( N, VT( I, 1 ), LDVT, VT( KK, 1 ), LDVT )
END IF
ELSE IF( ICOMPQ.EQ.1 ) THEN
IQ( I ) = I
END IF
60 CONTINUE
*
* If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO
*
IF( ICOMPQ.EQ.1 ) THEN
IF( IUPLO.EQ.1 ) THEN
IQ( N ) = 1
ELSE
IQ( N ) = 0
END IF
END IF
*
* If B is lower bidiagonal, update U by those Givens rotations
* which rotated B to be upper bidiagonal
*
IF( ( IUPLO.EQ.2 ) .AND. ( ICOMPQ.EQ.2 ) )
$ CALL DLASR( 'L', 'V', 'B', N, N, WORK( 1 ), WORK( N ), U, LDU )
*
RETURN
*
* End of DBDSDC
*
END
SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U,
$ LDU, C, LDC, WORK, INFO )
*
* -- LAPACK routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* January 2007
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU
* ..
* .. Array Arguments ..
DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ),
$ VT( LDVT, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DBDSQR computes the singular values and, optionally, the right and/or
* left singular vectors from the singular value decomposition (SVD) of
* a real N-by-N (upper or lower) bidiagonal matrix B using the implicit
* zero-shift QR algorithm. The SVD of B has the form
*
* B = Q * S * P**T
*
* where S is the diagonal matrix of singular values, Q is an orthogonal
* matrix of left singular vectors, and P is an orthogonal matrix of
* right singular vectors. If left singular vectors are requested, this
* subroutine actually returns U*Q instead of Q, and, if right singular
* vectors are requested, this subroutine returns P**T*VT instead of
* P**T, for given real input matrices U and VT. When U and VT are the
* orthogonal matrices that reduce a general matrix A to bidiagonal
* form: A = U*B*VT, as computed by DGEBRD, then
*
* A = (U*Q) * S * (P**T*VT)
*
* is the SVD of A. Optionally, the subroutine may also compute Q**T*C
* for a given real input matrix C.
*
* See "Computing Small Singular Values of Bidiagonal Matrices With
* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,
* no. 5, pp. 873-912, Sept 1990) and
* "Accurate singular values and differential qd algorithms," by
* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics
* Department, University of California at Berkeley, July 1992
* for a detailed description of the algorithm.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': B is upper bidiagonal;
* = 'L': B is lower bidiagonal.
*
* N (input) INTEGER
* The order of the matrix B. N >= 0.
*
* NCVT (input) INTEGER
* The number of columns of the matrix VT. NCVT >= 0.
*
* NRU (input) INTEGER
* The number of rows of the matrix U. NRU >= 0.
*
* NCC (input) INTEGER
* The number of columns of the matrix C. NCC >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the n diagonal elements of the bidiagonal matrix B.
* On exit, if INFO=0, the singular values of B in decreasing
* order.
*
* E (input/output) DOUBLE PRECISION array, dimension (N-1)
* On entry, the N-1 offdiagonal elements of the bidiagonal
* matrix B.
* On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E
* will contain the diagonal and superdiagonal elements of a
* bidiagonal matrix orthogonally equivalent to the one given
* as input.
*
* VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT)
* On entry, an N-by-NCVT matrix VT.
* On exit, VT is overwritten by P**T * VT.
* Not referenced if NCVT = 0.
*
* LDVT (input) INTEGER
* The leading dimension of the array VT.
* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.
*
* U (input/output) DOUBLE PRECISION array, dimension (LDU, N)
* On entry, an NRU-by-N matrix U.
* On exit, U is overwritten by U * Q.
* Not referenced if NRU = 0.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= max(1,NRU).
*
* C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC)
* On entry, an N-by-NCC matrix C.
* On exit, C is overwritten by Q**T * C.
* Not referenced if NCC = 0.
*
* LDC (input) INTEGER
* The leading dimension of the array C.
* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
* if NCVT = NRU = NCC = 0, (max(1, 4*N)) otherwise
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: If INFO = -i, the i-th argument had an illegal value
* > 0: the algorithm did not converge; D and E contain the
* elements of a bidiagonal matrix which is orthogonally
* similar to the input matrix B; if INFO = i, i
* elements of E have not converged to zero.
*
* Internal Parameters
* ===================
*
* TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8)))
* TOLMUL controls the convergence criterion of the QR loop.
* If it is positive, TOLMUL*EPS is the desired relative
* precision in the computed singular values.
* If it is negative, abs(TOLMUL*EPS*sigma_max) is the
* desired absolute accuracy in the computed singular
* values (corresponds to relative accuracy
* abs(TOLMUL*EPS) in the largest singular value.
* abs(TOLMUL) should be between 1 and 1/EPS, and preferably
* between 10 (for fast convergence) and .1/EPS
* (for there to be some accuracy in the results).
* Default is to lose at either one eighth or 2 of the
* available decimal digits in each computed singular value
* (whichever is smaller).
*
* MAXITR INTEGER, default = 6
* MAXITR controls the maximum number of passes of the
* algorithm through its inner loop. The algorithms stops
* (and so fails to converge) if the number of passes
* through the inner loop exceeds MAXITR*N**2.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION NEGONE
PARAMETER ( NEGONE = -1.0D0 )
DOUBLE PRECISION HNDRTH
PARAMETER ( HNDRTH = 0.01D0 )
DOUBLE PRECISION TEN
PARAMETER ( TEN = 10.0D0 )
DOUBLE PRECISION HNDRD
PARAMETER ( HNDRD = 100.0D0 )
DOUBLE PRECISION MEIGTH
PARAMETER ( MEIGTH = -0.125D0 )
INTEGER MAXITR
PARAMETER ( MAXITR = 6 )
* ..
* .. Local Scalars ..
LOGICAL LOWER, ROTATE
INTEGER I, IDIR, ISUB, ITER, J, LL, LLL, M, MAXIT, NM1,
$ NM12, NM13, OLDLL, OLDM
DOUBLE PRECISION ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU,
$ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL,
$ SINR, SLL, SMAX, SMIN, SMINL, SMINOA,
$ SN, THRESH, TOL, TOLMUL, UNFL
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DLARTG, DLAS2, DLASQ1, DLASR, DLASV2, DROT,
$ DSCAL, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
LOWER = LSAME( UPLO, 'L' )
IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LOWER ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NCVT.LT.0 ) THEN
INFO = -3
ELSE IF( NRU.LT.0 ) THEN
INFO = -4
ELSE IF( NCC.LT.0 ) THEN
INFO = -5
ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR.
$ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN
INFO = -9
ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN
INFO = -11
ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR.
$ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN
INFO = -13
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DBDSQR', -INFO )
RETURN
END IF
IF( N.EQ.0 )
$ RETURN
IF( N.EQ.1 )
$ GO TO 160
*
* ROTATE is true if any singular vectors desired, false otherwise
*
ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 )
*
* If no singular vectors desired, use qd algorithm
*
IF( .NOT.ROTATE ) THEN
CALL DLASQ1( N, D, E, WORK, INFO )
RETURN
END IF
*
NM1 = N - 1
NM12 = NM1 + NM1
NM13 = NM12 + NM1
IDIR = 0
*
* Get machine constants
*
EPS = DLAMCH( 'Epsilon' )
UNFL = DLAMCH( 'Safe minimum' )
*
* If matrix lower bidiagonal, rotate to be upper bidiagonal
* by applying Givens rotations on the left
*
IF( LOWER ) THEN
DO 10 I = 1, N - 1
CALL DLARTG( D( I ), E( I ), CS, SN, R )
D( I ) = R
E( I ) = SN*D( I+1 )
D( I+1 ) = CS*D( I+1 )
WORK( I ) = CS
WORK( NM1+I ) = SN
10 CONTINUE
*
* Update singular vectors if desired
*
IF( NRU.GT.0 )
$ CALL DLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ), WORK( N ), U,
$ LDU )
IF( NCC.GT.0 )
$ CALL DLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ), WORK( N ), C,
$ LDC )
END IF
*
* Compute singular values to relative accuracy TOL
* (By setting TOL to be negative, algorithm will compute
* singular values to absolute accuracy ABS(TOL)*norm(input matrix))
*
TOLMUL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) )
TOL = TOLMUL*EPS
*
* Compute approximate maximum, minimum singular values
*
SMAX = ZERO
DO 20 I = 1, N
SMAX = MAX( SMAX, ABS( D( I ) ) )
20 CONTINUE
DO 30 I = 1, N - 1
SMAX = MAX( SMAX, ABS( E( I ) ) )
30 CONTINUE
SMINL = ZERO
IF( TOL.GE.ZERO ) THEN
*
* Relative accuracy desired
*
SMINOA = ABS( D( 1 ) )
IF( SMINOA.EQ.ZERO )
$ GO TO 50
MU = SMINOA
DO 40 I = 2, N
MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) )
SMINOA = MIN( SMINOA, MU )
IF( SMINOA.EQ.ZERO )
$ GO TO 50
40 CONTINUE
50 CONTINUE
SMINOA = SMINOA / SQRT( DBLE( N ) )
THRESH = MAX( TOL*SMINOA, MAXITR*N*N*UNFL )
ELSE
*
* Absolute accuracy desired
*
THRESH = MAX( ABS( TOL )*SMAX, MAXITR*N*N*UNFL )
END IF
*
* Prepare for main iteration loop for the singular values
* (MAXIT is the maximum number of passes through the inner
* loop permitted before nonconvergence signalled.)
*
MAXIT = MAXITR*N*N
ITER = 0
OLDLL = -1
OLDM = -1
*
* M points to last element of unconverged part of matrix
*
M = N
*
* Begin main iteration loop
*
60 CONTINUE
*
* Check for convergence or exceeding iteration count
*
IF( M.LE.1 )
$ GO TO 160
IF( ITER.GT.MAXIT )
$ GO TO 200
*
* Find diagonal block of matrix to work on
*
IF( TOL.LT.ZERO .AND. ABS( D( M ) ).LE.THRESH )
$ D( M ) = ZERO
SMAX = ABS( D( M ) )
SMIN = SMAX
DO 70 LLL = 1, M - 1
LL = M - LLL
ABSS = ABS( D( LL ) )
ABSE = ABS( E( LL ) )
IF( TOL.LT.ZERO .AND. ABSS.LE.THRESH )
$ D( LL ) = ZERO
IF( ABSE.LE.THRESH )
$ GO TO 80
SMIN = MIN( SMIN, ABSS )
SMAX = MAX( SMAX, ABSS, ABSE )
70 CONTINUE
LL = 0
GO TO 90
80 CONTINUE
E( LL ) = ZERO
*
* Matrix splits since E(LL) = 0
*
IF( LL.EQ.M-1 ) THEN
*
* Convergence of bottom singular value, return to top of loop
*
M = M - 1
GO TO 60
END IF
90 CONTINUE
LL = LL + 1
*
* E(LL) through E(M-1) are nonzero, E(LL-1) is zero
*
IF( LL.EQ.M-1 ) THEN
*
* 2 by 2 block, handle separately
*
CALL DLASV2( D( M-1 ), E( M-1 ), D( M ), SIGMN, SIGMX, SINR,
$ COSR, SINL, COSL )
D( M-1 ) = SIGMX
E( M-1 ) = ZERO
D( M ) = SIGMN
*
* Compute singular vectors, if desired
*
IF( NCVT.GT.0 )
$ CALL DROT( NCVT, VT( M-1, 1 ), LDVT, VT( M, 1 ), LDVT, COSR,
$ SINR )
IF( NRU.GT.0 )
$ CALL DROT( NRU, U( 1, M-1 ), 1, U( 1, M ), 1, COSL, SINL )
IF( NCC.GT.0 )
$ CALL DROT( NCC, C( M-1, 1 ), LDC, C( M, 1 ), LDC, COSL,
$ SINL )
M = M - 2
GO TO 60
END IF
*
* If working on new submatrix, choose shift direction
* (from larger end diagonal element towards smaller)
*
IF( LL.GT.OLDM .OR. M.LT.OLDLL ) THEN
IF( ABS( D( LL ) ).GE.ABS( D( M ) ) ) THEN
*
* Chase bulge from top (big end) to bottom (small end)
*
IDIR = 1
ELSE
*
* Chase bulge from bottom (big end) to top (small end)
*
IDIR = 2
END IF
END IF
*
* Apply convergence tests
*
IF( IDIR.EQ.1 ) THEN
*
* Run convergence test in forward direction
* First apply standard test to bottom of matrix
*
IF( ABS( E( M-1 ) ).LE.ABS( TOL )*ABS( D( M ) ) .OR.
$ ( TOL.LT.ZERO .AND. ABS( E( M-1 ) ).LE.THRESH ) ) THEN
E( M-1 ) = ZERO
GO TO 60
END IF
*
IF( TOL.GE.ZERO ) THEN
*
* If relative accuracy desired,
* apply convergence criterion forward
*
MU = ABS( D( LL ) )
SMINL = MU
DO 100 LLL = LL, M - 1
IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
E( LLL ) = ZERO
GO TO 60
END IF
MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
SMINL = MIN( SMINL, MU )
100 CONTINUE
END IF
*
ELSE
*
* Run convergence test in backward direction
* First apply standard test to top of matrix
*
IF( ABS( E( LL ) ).LE.ABS( TOL )*ABS( D( LL ) ) .OR.
$ ( TOL.LT.ZERO .AND. ABS( E( LL ) ).LE.THRESH ) ) THEN
E( LL ) = ZERO
GO TO 60
END IF
*
IF( TOL.GE.ZERO ) THEN
*
* If relative accuracy desired,
* apply convergence criterion backward
*
MU = ABS( D( M ) )
SMINL = MU
DO 110 LLL = M - 1, LL, -1
IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
E( LLL ) = ZERO
GO TO 60
END IF
MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
SMINL = MIN( SMINL, MU )
110 CONTINUE
END IF
END IF
OLDLL = LL
OLDM = M
*
* Compute shift. First, test if shifting would ruin relative
* accuracy, and if so set the shift to zero.
*
IF( TOL.GE.ZERO .AND. N*TOL*( SMINL / SMAX ).LE.
$ MAX( EPS, HNDRTH*TOL ) ) THEN
*
* Use a zero shift to avoid loss of relative accuracy
*
SHIFT = ZERO
ELSE
*
* Compute the shift from 2-by-2 block at end of matrix
*
IF( IDIR.EQ.1 ) THEN
SLL = ABS( D( LL ) )
CALL DLAS2( D( M-1 ), E( M-1 ), D( M ), SHIFT, R )
ELSE
SLL = ABS( D( M ) )
CALL DLAS2( D( LL ), E( LL ), D( LL+1 ), SHIFT, R )
END IF
*
* Test if shift negligible, and if so set to zero
*
IF( SLL.GT.ZERO ) THEN
IF( ( SHIFT / SLL )**2.LT.EPS )
$ SHIFT = ZERO
END IF
END IF
*
* Increment iteration count
*
ITER = ITER + M - LL
*
* If SHIFT = 0, do simplified QR iteration
*
IF( SHIFT.EQ.ZERO ) THEN
IF( IDIR.EQ.1 ) THEN
*
* Chase bulge from top to bottom
* Save cosines and sines for later singular vector updates
*
CS = ONE
OLDCS = ONE
DO 120 I = LL, M - 1
CALL DLARTG( D( I )*CS, E( I ), CS, SN, R )
IF( I.GT.LL )
$ E( I-1 ) = OLDSN*R
CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) )
WORK( I-LL+1 ) = CS
WORK( I-LL+1+NM1 ) = SN
WORK( I-LL+1+NM12 ) = OLDCS
WORK( I-LL+1+NM13 ) = OLDSN
120 CONTINUE
H = D( M )*CS
D( M ) = H*OLDCS
E( M-1 ) = H*OLDSN
*
* Update singular vectors
*
IF( NCVT.GT.0 )
$ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ),
$ WORK( N ), VT( LL, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL DLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ),
$ WORK( NM13+1 ), U( 1, LL ), LDU )
IF( NCC.GT.0 )
$ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ),
$ WORK( NM13+1 ), C( LL, 1 ), LDC )
*
* Test convergence
*
IF( ABS( E( M-1 ) ).LE.THRESH )
$ E( M-1 ) = ZERO
*
ELSE
*
* Chase bulge from bottom to top
* Save cosines and sines for later singular vector updates
*
CS = ONE
OLDCS = ONE
DO 130 I = M, LL + 1, -1
CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R )
IF( I.LT.M )
$ E( I ) = OLDSN*R
CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) )
WORK( I-LL ) = CS
WORK( I-LL+NM1 ) = -SN
WORK( I-LL+NM12 ) = OLDCS
WORK( I-LL+NM13 ) = -OLDSN
130 CONTINUE
H = D( LL )*CS
D( LL ) = H*OLDCS
E( LL ) = H*OLDSN
*
* Update singular vectors
*
IF( NCVT.GT.0 )
$ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ),
$ WORK( NM13+1 ), VT( LL, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL DLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ),
$ WORK( N ), U( 1, LL ), LDU )
IF( NCC.GT.0 )
$ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ),
$ WORK( N ), C( LL, 1 ), LDC )
*
* Test convergence
*
IF( ABS( E( LL ) ).LE.THRESH )
$ E( LL ) = ZERO
END IF
ELSE
*
* Use nonzero shift
*
IF( IDIR.EQ.1 ) THEN
*
* Chase bulge from top to bottom
* Save cosines and sines for later singular vector updates
*
F = ( ABS( D( LL ) )-SHIFT )*
$ ( SIGN( ONE, D( LL ) )+SHIFT / D( LL ) )
G = E( LL )
DO 140 I = LL, M - 1
CALL DLARTG( F, G, COSR, SINR, R )
IF( I.GT.LL )
$ E( I-1 ) = R
F = COSR*D( I ) + SINR*E( I )
E( I ) = COSR*E( I ) - SINR*D( I )
G = SINR*D( I+1 )
D( I+1 ) = COSR*D( I+1 )
CALL DLARTG( F, G, COSL, SINL, R )
D( I ) = R
F = COSL*E( I ) + SINL*D( I+1 )
D( I+1 ) = COSL*D( I+1 ) - SINL*E( I )
IF( I.LT.M-1 ) THEN
G = SINL*E( I+1 )
E( I+1 ) = COSL*E( I+1 )
END IF
WORK( I-LL+1 ) = COSR
WORK( I-LL+1+NM1 ) = SINR
WORK( I-LL+1+NM12 ) = COSL
WORK( I-LL+1+NM13 ) = SINL
140 CONTINUE
E( M-1 ) = F
*
* Update singular vectors
*
IF( NCVT.GT.0 )
$ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ),
$ WORK( N ), VT( LL, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL DLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ),
$ WORK( NM13+1 ), U( 1, LL ), LDU )
IF( NCC.GT.0 )
$ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ),
$ WORK( NM13+1 ), C( LL, 1 ), LDC )
*
* Test convergence
*
IF( ABS( E( M-1 ) ).LE.THRESH )
$ E( M-1 ) = ZERO
*
ELSE
*
* Chase bulge from bottom to top
* Save cosines and sines for later singular vector updates
*
F = ( ABS( D( M ) )-SHIFT )*( SIGN( ONE, D( M ) )+SHIFT /
$ D( M ) )
G = E( M-1 )
DO 150 I = M, LL + 1, -1
CALL DLARTG( F, G, COSR, SINR, R )
IF( I.LT.M )
$ E( I ) = R
F = COSR*D( I ) + SINR*E( I-1 )
E( I-1 ) = COSR*E( I-1 ) - SINR*D( I )
G = SINR*D( I-1 )
D( I-1 ) = COSR*D( I-1 )
CALL DLARTG( F, G, COSL, SINL, R )
D( I ) = R
F = COSL*E( I-1 ) + SINL*D( I-1 )
D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 )
IF( I.GT.LL+1 ) THEN
G = SINL*E( I-2 )
E( I-2 ) = COSL*E( I-2 )
END IF
WORK( I-LL ) = COSR
WORK( I-LL+NM1 ) = -SINR
WORK( I-LL+NM12 ) = COSL
WORK( I-LL+NM13 ) = -SINL
150 CONTINUE
E( LL ) = F
*
* Test convergence
*
IF( ABS( E( LL ) ).LE.THRESH )
$ E( LL ) = ZERO
*
* Update singular vectors if desired
*
IF( NCVT.GT.0 )
$ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ),
$ WORK( NM13+1 ), VT( LL, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL DLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ),
$ WORK( N ), U( 1, LL ), LDU )
IF( NCC.GT.0 )
$ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ),
$ WORK( N ), C( LL, 1 ), LDC )
END IF
END IF
*
* QR iteration finished, go back and check convergence
*
GO TO 60
*
* All singular values converged, so make them positive
*
160 CONTINUE
DO 170 I = 1, N
IF( D( I ).LT.ZERO ) THEN
D( I ) = -D( I )
*
* Change sign of singular vectors, if desired
*
IF( NCVT.GT.0 )
$ CALL DSCAL( NCVT, NEGONE, VT( I, 1 ), LDVT )
END IF
170 CONTINUE
*
* Sort the singular values into decreasing order (insertion sort on
* singular values, but only one transposition per singular vector)
*
DO 190 I = 1, N - 1
*
* Scan for smallest D(I)
*
ISUB = 1
SMIN = D( 1 )
DO 180 J = 2, N + 1 - I
IF( D( J ).LE.SMIN ) THEN
ISUB = J
SMIN = D( J )
END IF
180 CONTINUE
IF( ISUB.NE.N+1-I ) THEN
*
* Swap singular values and vectors
*
D( ISUB ) = D( N+1-I )
D( N+1-I ) = SMIN
IF( NCVT.GT.0 )
$ CALL DSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ),
$ LDVT )
IF( NRU.GT.0 )
$ CALL DSWAP( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 )
IF( NCC.GT.0 )
$ CALL DSWAP( NCC, C( ISUB, 1 ), LDC, C( N+1-I, 1 ), LDC )
END IF
190 CONTINUE
GO TO 220
*
* Maximum number of iterations exceeded, failure to converge
*
200 CONTINUE
INFO = 0
DO 210 I = 1, N - 1
IF( E( I ).NE.ZERO )
$ INFO = INFO + 1
210 CONTINUE
220 CONTINUE
RETURN
*
* End of DBDSQR
*
END
SUBROUTINE DDISNA( JOB, M, N, D, SEP, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOB
INTEGER INFO, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), SEP( * )
* ..
*
* Purpose
* =======
*
* DDISNA computes the reciprocal condition numbers for the eigenvectors
* of a real symmetric or complex Hermitian matrix or for the left or
* right singular vectors of a general m-by-n matrix. The reciprocal
* condition number is the 'gap' between the corresponding eigenvalue or
* singular value and the nearest other one.
*
* The bound on the error, measured by angle in radians, in the I-th
* computed vector is given by
*
* DLAMCH( 'E' ) * ( ANORM / SEP( I ) )
*
* where ANORM = 2-norm(A) = max( abs( D(j) ) ). SEP(I) is not allowed
* to be smaller than DLAMCH( 'E' )*ANORM in order to limit the size of
* the error bound.
*
* DDISNA may also be used to compute error bounds for eigenvectors of
* the generalized symmetric definite eigenproblem.
*
* Arguments
* =========
*
* JOB (input) CHARACTER*1
* Specifies for which problem the reciprocal condition numbers
* should be computed:
* = 'E': the eigenvectors of a symmetric/Hermitian matrix;
* = 'L': the left singular vectors of a general matrix;
* = 'R': the right singular vectors of a general matrix.
*
* M (input) INTEGER
* The number of rows of the matrix. M >= 0.
*
* N (input) INTEGER
* If JOB = 'L' or 'R', the number of columns of the matrix,
* in which case N >= 0. Ignored if JOB = 'E'.
*
* D (input) DOUBLE PRECISION array, dimension (M) if JOB = 'E'
* dimension (min(M,N)) if JOB = 'L' or 'R'
* The eigenvalues (if JOB = 'E') or singular values (if JOB =
* 'L' or 'R') of the matrix, in either increasing or decreasing
* order. If singular values, they must be non-negative.
*
* SEP (output) DOUBLE PRECISION array, dimension (M) if JOB = 'E'
* dimension (min(M,N)) if JOB = 'L' or 'R'
* The reciprocal condition numbers of the vectors.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL DECR, EIGEN, INCR, LEFT, RIGHT, SING
INTEGER I, K
DOUBLE PRECISION ANORM, EPS, NEWGAP, OLDGAP, SAFMIN, THRESH
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
EIGEN = LSAME( JOB, 'E' )
LEFT = LSAME( JOB, 'L' )
RIGHT = LSAME( JOB, 'R' )
SING = LEFT .OR. RIGHT
IF( EIGEN ) THEN
K = M
ELSE IF( SING ) THEN
K = MIN( M, N )
END IF
IF( .NOT.EIGEN .AND. .NOT.SING ) THEN
INFO = -1
ELSE IF( M.LT.0 ) THEN
INFO = -2
ELSE IF( K.LT.0 ) THEN
INFO = -3
ELSE
INCR = .TRUE.
DECR = .TRUE.
DO 10 I = 1, K - 1
IF( INCR )
$ INCR = INCR .AND. D( I ).LE.D( I+1 )
IF( DECR )
$ DECR = DECR .AND. D( I ).GE.D( I+1 )
10 CONTINUE
IF( SING .AND. K.GT.0 ) THEN
IF( INCR )
$ INCR = INCR .AND. ZERO.LE.D( 1 )
IF( DECR )
$ DECR = DECR .AND. D( K ).GE.ZERO
END IF
IF( .NOT.( INCR .OR. DECR ) )
$ INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DDISNA', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( K.EQ.0 )
$ RETURN
*
* Compute reciprocal condition numbers
*
IF( K.EQ.1 ) THEN
SEP( 1 ) = DLAMCH( 'O' )
ELSE
OLDGAP = ABS( D( 2 )-D( 1 ) )
SEP( 1 ) = OLDGAP
DO 20 I = 2, K - 1
NEWGAP = ABS( D( I+1 )-D( I ) )
SEP( I ) = MIN( OLDGAP, NEWGAP )
OLDGAP = NEWGAP
20 CONTINUE
SEP( K ) = OLDGAP
END IF
IF( SING ) THEN
IF( ( LEFT .AND. M.GT.N ) .OR. ( RIGHT .AND. M.LT.N ) ) THEN
IF( INCR )
$ SEP( 1 ) = MIN( SEP( 1 ), D( 1 ) )
IF( DECR )
$ SEP( K ) = MIN( SEP( K ), D( K ) )
END IF
END IF
*
* Ensure that reciprocal condition numbers are not less than
* threshold, in order to limit the size of the error bound
*
EPS = DLAMCH( 'E' )
SAFMIN = DLAMCH( 'S' )
ANORM = MAX( ABS( D( 1 ) ), ABS( D( K ) ) )
IF( ANORM.EQ.ZERO ) THEN
THRESH = EPS
ELSE
THRESH = MAX( EPS*ANORM, SAFMIN )
END IF
DO 30 I = 1, K
SEP( I ) = MAX( SEP( I ), THRESH )
30 CONTINUE
*
RETURN
*
* End of DDISNA
*
END
SUBROUTINE DGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q,
$ LDQ, PT, LDPT, C, LDC, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER VECT
INTEGER INFO, KL, KU, LDAB, LDC, LDPT, LDQ, M, N, NCC
* ..
* .. Array Arguments ..
DOUBLE PRECISION AB( LDAB, * ), C( LDC, * ), D( * ), E( * ),
$ PT( LDPT, * ), Q( LDQ, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGBBRD reduces a real general m-by-n band matrix A to upper
* bidiagonal form B by an orthogonal transformation: Q' * A * P = B.
*
* The routine computes B, and optionally forms Q or P', or computes
* Q'*C for a given matrix C.
*
* Arguments
* =========
*
* VECT (input) CHARACTER*1
* Specifies whether or not the matrices Q and P' are to be
* formed.
* = 'N': do not form Q or P';
* = 'Q': form Q only;
* = 'P': form P' only;
* = 'B': form both.
*
* 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.
*
* NCC (input) INTEGER
* The number of columns of the matrix C. NCC >= 0.
*
* KL (input) INTEGER
* The number of subdiagonals of the matrix A. KL >= 0.
*
* KU (input) INTEGER
* The number of superdiagonals of the matrix A. KU >= 0.
*
* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
* On entry, the m-by-n band matrix A, stored in rows 1 to
* KL+KU+1. The j-th column of A is stored in the j-th column of
* the array AB as follows:
* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
* On exit, A is overwritten by values generated during the
* reduction.
*
* LDAB (input) INTEGER
* The leading dimension of the array A. LDAB >= KL+KU+1.
*
* D (output) DOUBLE PRECISION array, dimension (min(M,N))
* The diagonal elements of the bidiagonal matrix B.
*
* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)
* The superdiagonal elements of the bidiagonal matrix B.
*
* Q (output) DOUBLE PRECISION array, dimension (LDQ,M)
* If VECT = 'Q' or 'B', the m-by-m orthogonal matrix Q.
* If VECT = 'N' or 'P', the array Q is not referenced.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q.
* LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.
*
* PT (output) DOUBLE PRECISION array, dimension (LDPT,N)
* If VECT = 'P' or 'B', the n-by-n orthogonal matrix P'.
* If VECT = 'N' or 'Q', the array PT is not referenced.
*
* LDPT (input) INTEGER
* The leading dimension of the array PT.
* LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.
*
* C (input/output) DOUBLE PRECISION array, dimension (LDC,NCC)
* On entry, an m-by-ncc matrix C.
* On exit, C is overwritten by Q'*C.
* C is not referenced if NCC = 0.
*
* LDC (input) INTEGER
* The leading dimension of the array C.
* LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (2*max(M,N))
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL WANTB, WANTC, WANTPT, WANTQ
INTEGER I, INCA, J, J1, J2, KB, KB1, KK, KLM, KLU1,
$ KUN, L, MINMN, ML, ML0, MN, MU, MU0, NR, NRT
DOUBLE PRECISION RA, RB, RC, RS
* ..
* .. External Subroutines ..
EXTERNAL DLARGV, DLARTG, DLARTV, DLASET, DROT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
WANTB = LSAME( VECT, 'B' )
WANTQ = LSAME( VECT, 'Q' ) .OR. WANTB
WANTPT = LSAME( VECT, 'P' ) .OR. WANTB
WANTC = NCC.GT.0
KLU1 = KL + KU + 1
INFO = 0
IF( .NOT.WANTQ .AND. .NOT.WANTPT .AND. .NOT.LSAME( VECT, 'N' ) )
$ THEN
INFO = -1
ELSE IF( M.LT.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NCC.LT.0 ) THEN
INFO = -4
ELSE IF( KL.LT.0 ) THEN
INFO = -5
ELSE IF( KU.LT.0 ) THEN
INFO = -6
ELSE IF( LDAB.LT.KLU1 ) THEN
INFO = -8
ELSE IF( LDQ.LT.1 .OR. WANTQ .AND. LDQ.LT.MAX( 1, M ) ) THEN
INFO = -12
ELSE IF( LDPT.LT.1 .OR. WANTPT .AND. LDPT.LT.MAX( 1, N ) ) THEN
INFO = -14
ELSE IF( LDC.LT.1 .OR. WANTC .AND. LDC.LT.MAX( 1, M ) ) THEN
INFO = -16
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGBBRD', -INFO )
RETURN
END IF
*
* Initialize Q and P' to the unit matrix, if needed
*
IF( WANTQ )
$ CALL DLASET( 'Full', M, M, ZERO, ONE, Q, LDQ )
IF( WANTPT )
$ CALL DLASET( 'Full', N, N, ZERO, ONE, PT, LDPT )
*
* Quick return if possible.
*
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
MINMN = MIN( M, N )
*
IF( KL+KU.GT.1 ) THEN
*
* Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce
* first to lower bidiagonal form and then transform to upper
* bidiagonal
*
IF( KU.GT.0 ) THEN
ML0 = 1
MU0 = 2
ELSE
ML0 = 2
MU0 = 1
END IF
*
* Wherever possible, plane rotations are generated and applied in
* vector operations of length NR over the index set J1:J2:KLU1.
*
* The sines of the plane rotations are stored in WORK(1:max(m,n))
* and the cosines in WORK(max(m,n)+1:2*max(m,n)).
*
MN = MAX( M, N )
KLM = MIN( M-1, KL )
KUN = MIN( N-1, KU )
KB = KLM + KUN
KB1 = KB + 1
INCA = KB1*LDAB
NR = 0
J1 = KLM + 2
J2 = 1 - KUN
*
DO 90 I = 1, MINMN
*
* Reduce i-th column and i-th row of matrix to bidiagonal form
*
ML = KLM + 1
MU = KUN + 1
DO 80 KK = 1, KB
J1 = J1 + KB
J2 = J2 + KB
*
* generate plane rotations to annihilate nonzero elements
* which have been created below the band
*
IF( NR.GT.0 )
$ CALL DLARGV( NR, AB( KLU1, J1-KLM-1 ), INCA,
$ WORK( J1 ), KB1, WORK( MN+J1 ), KB1 )
*
* apply plane rotations from the left
*
DO 10 L = 1, KB
IF( J2-KLM+L-1.GT.N ) THEN
NRT = NR - 1
ELSE
NRT = NR
END IF
IF( NRT.GT.0 )
$ CALL DLARTV( NRT, AB( KLU1-L, J1-KLM+L-1 ), INCA,
$ AB( KLU1-L+1, J1-KLM+L-1 ), INCA,
$ WORK( MN+J1 ), WORK( J1 ), KB1 )
10 CONTINUE
*
IF( ML.GT.ML0 ) THEN
IF( ML.LE.M-I+1 ) THEN
*
* generate plane rotation to annihilate a(i+ml-1,i)
* within the band, and apply rotation from the left
*
CALL DLARTG( AB( KU+ML-1, I ), AB( KU+ML, I ),
$ WORK( MN+I+ML-1 ), WORK( I+ML-1 ),
$ RA )
AB( KU+ML-1, I ) = RA
IF( I.LT.N )
$ CALL DROT( MIN( KU+ML-2, N-I ),
$ AB( KU+ML-2, I+1 ), LDAB-1,
$ AB( KU+ML-1, I+1 ), LDAB-1,
$ WORK( MN+I+ML-1 ), WORK( I+ML-1 ) )
END IF
NR = NR + 1
J1 = J1 - KB1
END IF
*
IF( WANTQ ) THEN
*
* accumulate product of plane rotations in Q
*
DO 20 J = J1, J2, KB1
CALL DROT( M, Q( 1, J-1 ), 1, Q( 1, J ), 1,
$ WORK( MN+J ), WORK( J ) )
20 CONTINUE
END IF
*
IF( WANTC ) THEN
*
* apply plane rotations to C
*
DO 30 J = J1, J2, KB1
CALL DROT( NCC, C( J-1, 1 ), LDC, C( J, 1 ), LDC,
$ WORK( MN+J ), WORK( J ) )
30 CONTINUE
END IF
*
IF( J2+KUN.GT.N ) THEN
*
* adjust J2 to keep within the bounds of the matrix
*
NR = NR - 1
J2 = J2 - KB1
END IF
*
DO 40 J = J1, J2, KB1
*
* create nonzero element a(j-1,j+ku) above the band
* and store it in WORK(n+1:2*n)
*
WORK( J+KUN ) = WORK( J )*AB( 1, J+KUN )
AB( 1, J+KUN ) = WORK( MN+J )*AB( 1, J+KUN )
40 CONTINUE
*
* generate plane rotations to annihilate nonzero elements
* which have been generated above the band
*
IF( NR.GT.0 )
$ CALL DLARGV( NR, AB( 1, J1+KUN-1 ), INCA,
$ WORK( J1+KUN ), KB1, WORK( MN+J1+KUN ),
$ KB1 )
*
* apply plane rotations from the right
*
DO 50 L = 1, KB
IF( J2+L-1.GT.M ) THEN
NRT = NR - 1
ELSE
NRT = NR
END IF
IF( NRT.GT.0 )
$ CALL DLARTV( NRT, AB( L+1, J1+KUN-1 ), INCA,
$ AB( L, J1+KUN ), INCA,
$ WORK( MN+J1+KUN ), WORK( J1+KUN ),
$ KB1 )
50 CONTINUE
*
IF( ML.EQ.ML0 .AND. MU.GT.MU0 ) THEN
IF( MU.LE.N-I+1 ) THEN
*
* generate plane rotation to annihilate a(i,i+mu-1)
* within the band, and apply rotation from the right
*
CALL DLARTG( AB( KU-MU+3, I+MU-2 ),
$ AB( KU-MU+2, I+MU-1 ),
$ WORK( MN+I+MU-1 ), WORK( I+MU-1 ),
$ RA )
AB( KU-MU+3, I+MU-2 ) = RA
CALL DROT( MIN( KL+MU-2, M-I ),
$ AB( KU-MU+4, I+MU-2 ), 1,
$ AB( KU-MU+3, I+MU-1 ), 1,
$ WORK( MN+I+MU-1 ), WORK( I+MU-1 ) )
END IF
NR = NR + 1
J1 = J1 - KB1
END IF
*
IF( WANTPT ) THEN
*
* accumulate product of plane rotations in P'
*
DO 60 J = J1, J2, KB1
CALL DROT( N, PT( J+KUN-1, 1 ), LDPT,
$ PT( J+KUN, 1 ), LDPT, WORK( MN+J+KUN ),
$ WORK( J+KUN ) )
60 CONTINUE
END IF
*
IF( J2+KB.GT.M ) THEN
*
* adjust J2 to keep within the bounds of the matrix
*
NR = NR - 1
J2 = J2 - KB1
END IF
*
DO 70 J = J1, J2, KB1
*
* create nonzero element a(j+kl+ku,j+ku-1) below the
* band and store it in WORK(1:n)
*
WORK( J+KB ) = WORK( J+KUN )*AB( KLU1, J+KUN )
AB( KLU1, J+KUN ) = WORK( MN+J+KUN )*AB( KLU1, J+KUN )
70 CONTINUE
*
IF( ML.GT.ML0 ) THEN
ML = ML - 1
ELSE
MU = MU - 1
END IF
80 CONTINUE
90 CONTINUE
END IF
*
IF( KU.EQ.0 .AND. KL.GT.0 ) THEN
*
* A has been reduced to lower bidiagonal form
*
* Transform lower bidiagonal form to upper bidiagonal by applying
* plane rotations from the left, storing diagonal elements in D
* and off-diagonal elements in E
*
DO 100 I = 1, MIN( M-1, N )
CALL DLARTG( AB( 1, I ), AB( 2, I ), RC, RS, RA )
D( I ) = RA
IF( I.LT.N ) THEN
E( I ) = RS*AB( 1, I+1 )
AB( 1, I+1 ) = RC*AB( 1, I+1 )
END IF
IF( WANTQ )
$ CALL DROT( M, Q( 1, I ), 1, Q( 1, I+1 ), 1, RC, RS )
IF( WANTC )
$ CALL DROT( NCC, C( I, 1 ), LDC, C( I+1, 1 ), LDC, RC,
$ RS )
100 CONTINUE
IF( M.LE.N )
$ D( M ) = AB( 1, M )
ELSE IF( KU.GT.0 ) THEN
*
* A has been reduced to upper bidiagonal form
*
IF( M.LT.N ) THEN
*
* Annihilate a(m,m+1) by applying plane rotations from the
* right, storing diagonal elements in D and off-diagonal
* elements in E
*
RB = AB( KU, M+1 )
DO 110 I = M, 1, -1
CALL DLARTG( AB( KU+1, I ), RB, RC, RS, RA )
D( I ) = RA
IF( I.GT.1 ) THEN
RB = -RS*AB( KU, I )
E( I-1 ) = RC*AB( KU, I )
END IF
IF( WANTPT )
$ CALL DROT( N, PT( I, 1 ), LDPT, PT( M+1, 1 ), LDPT,
$ RC, RS )
110 CONTINUE
ELSE
*
* Copy off-diagonal elements to E and diagonal elements to D
*
DO 120 I = 1, MINMN - 1
E( I ) = AB( KU, I+1 )
120 CONTINUE
DO 130 I = 1, MINMN
D( I ) = AB( KU+1, I )
130 CONTINUE
END IF
ELSE
*
* A is diagonal. Set elements of E to zero and copy diagonal
* elements to D.
*
DO 140 I = 1, MINMN - 1
E( I ) = ZERO
140 CONTINUE
DO 150 I = 1, MINMN
D( I ) = AB( 1, I )
150 CONTINUE
END IF
RETURN
*
* End of DGBBRD
*
END
SUBROUTINE DGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND,
$ WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER INFO, KL, KU, LDAB, N
DOUBLE PRECISION ANORM, RCOND
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), IWORK( * )
DOUBLE PRECISION AB( LDAB, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGBCON estimates the reciprocal of the condition number of a real
* general band matrix A, in either the 1-norm or the infinity-norm,
* using the LU factorization computed by DGBTRF.
*
* An estimate is obtained for norm(inv(A)), and the reciprocal of the
* condition number is computed as
* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies whether the 1-norm condition number or the
* infinity-norm condition number is required:
* = '1' or 'O': 1-norm;
* = 'I': Infinity-norm.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KL (input) INTEGER
* The number of subdiagonals within the band of A. KL >= 0.
*
* KU (input) INTEGER
* The number of superdiagonals within the band of A. KU >= 0.
*
* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
* Details of the LU factorization of the band matrix A, as
* computed by DGBTRF. U is stored as an upper triangular band
* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
* the multipliers used during the factorization are stored in
* rows KL+KU+2 to 2*KL+KU+1.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices; for 1 <= i <= N, row i of the matrix was
* interchanged with row IPIV(i).
*
* ANORM (input) DOUBLE PRECISION
* If NORM = '1' or 'O', the 1-norm of the original matrix A.
* If NORM = 'I', the infinity-norm of the original matrix A.
*
* RCOND (output) DOUBLE PRECISION
* The reciprocal of the condition number of the matrix A,
* computed as RCOND = 1/(norm(A) * norm(inv(A))).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LNOTI, ONENRM
CHARACTER NORMIN
INTEGER IX, J, JP, KASE, KASE1, KD, LM
DOUBLE PRECISION AINVNM, SCALE, SMLNUM, T
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DDOT, DLAMCH
EXTERNAL LSAME, IDAMAX, DDOT, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DLACN2, DLATBS, DRSCL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( KL.LT.0 ) THEN
INFO = -3
ELSE IF( KU.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN
INFO = -6
ELSE IF( ANORM.LT.ZERO ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGBCON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
RCOND = ZERO
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
ELSE IF( ANORM.EQ.ZERO ) THEN
RETURN
END IF
*
SMLNUM = DLAMCH( 'Safe minimum' )
*
* Estimate the norm of inv(A).
*
AINVNM = ZERO
NORMIN = 'N'
IF( ONENRM ) THEN
KASE1 = 1
ELSE
KASE1 = 2
END IF
KD = KL + KU + 1
LNOTI = KL.GT.0
KASE = 0
10 CONTINUE
CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.KASE1 ) THEN
*
* Multiply by inv(L).
*
IF( LNOTI ) THEN
DO 20 J = 1, N - 1
LM = MIN( KL, N-J )
JP = IPIV( J )
T = WORK( JP )
IF( JP.NE.J ) THEN
WORK( JP ) = WORK( J )
WORK( J ) = T
END IF
CALL DAXPY( LM, -T, AB( KD+1, J ), 1, WORK( J+1 ), 1 )
20 CONTINUE
END IF
*
* Multiply by inv(U).
*
CALL DLATBS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
$ KL+KU, AB, LDAB, WORK, SCALE, WORK( 2*N+1 ),
$ INFO )
ELSE
*
* Multiply by inv(U').
*
CALL DLATBS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N,
$ KL+KU, AB, LDAB, WORK, SCALE, WORK( 2*N+1 ),
$ INFO )
*
* Multiply by inv(L').
*
IF( LNOTI ) THEN
DO 30 J = N - 1, 1, -1
LM = MIN( KL, N-J )
WORK( J ) = WORK( J ) - DDOT( LM, AB( KD+1, J ), 1,
$ WORK( J+1 ), 1 )
JP = IPIV( J )
IF( JP.NE.J ) THEN
T = WORK( JP )
WORK( JP ) = WORK( J )
WORK( J ) = T
END IF
30 CONTINUE
END IF
END IF
*
* Divide X by 1/SCALE if doing so will not cause overflow.
*
NORMIN = 'Y'
IF( SCALE.NE.ONE ) THEN
IX = IDAMAX( N, WORK, 1 )
IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
$ GO TO 40
CALL DRSCL( N, SCALE, WORK, 1 )
END IF
GO TO 10
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / AINVNM ) / ANORM
*
40 CONTINUE
RETURN
*
* End of DGBCON
*
END
SUBROUTINE DGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND,
$ AMAX, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, KL, KU, LDAB, M, N
DOUBLE PRECISION AMAX, COLCND, ROWCND
* ..
* .. Array Arguments ..
DOUBLE PRECISION AB( LDAB, * ), C( * ), R( * )
* ..
*
* Purpose
* =======
*
* DGBEQU computes row and column scalings intended to equilibrate an
* M-by-N band matrix A and reduce its condition number. R returns the
* row scale factors and C the column scale factors, chosen to try to
* make the largest element in each row and column of the matrix B with
* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
*
* R(i) and C(j) are restricted to be between SMLNUM = smallest safe
* number and BIGNUM = largest safe number. Use of these scaling
* factors is not guaranteed to reduce the condition number of A but
* works well in practice.
*
* 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.
*
* KL (input) INTEGER
* The number of subdiagonals within the band of A. KL >= 0.
*
* KU (input) INTEGER
* The number of superdiagonals within the band of A. KU >= 0.
*
* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
* The band matrix A, stored in rows 1 to KL+KU+1. The j-th
* column of A is stored in the j-th column of the array AB as
* follows:
* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KL+KU+1.
*
* R (output) DOUBLE PRECISION array, dimension (M)
* If INFO = 0, or INFO > M, R contains the row scale factors
* for A.
*
* C (output) DOUBLE PRECISION array, dimension (N)
* If INFO = 0, C contains the column scale factors for A.
*
* ROWCND (output) DOUBLE PRECISION
* If INFO = 0 or INFO > M, ROWCND contains the ratio of the
* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and
* AMAX is neither too large nor too small, it is not worth
* scaling by R.
*
* COLCND (output) DOUBLE PRECISION
* If INFO = 0, COLCND contains the ratio of the smallest
* C(i) to the largest C(i). If COLCND >= 0.1, it is not
* worth scaling by C.
*
* AMAX (output) DOUBLE PRECISION
* Absolute value of largest matrix element. If AMAX is very
* close to overflow or very close to underflow, the matrix
* should be scaled.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, and i is
* <= M: the i-th row of A is exactly zero
* > M: the (i-M)-th column of A is exactly zero
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, KD
DOUBLE PRECISION BIGNUM, RCMAX, RCMIN, SMLNUM
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, 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( KL.LT.0 ) THEN
INFO = -3
ELSE IF( KU.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.KL+KU+1 ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGBEQU', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
ROWCND = ONE
COLCND = ONE
AMAX = ZERO
RETURN
END IF
*
* Get machine constants.
*
SMLNUM = DLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
*
* Compute row scale factors.
*
DO 10 I = 1, M
R( I ) = ZERO
10 CONTINUE
*
* Find the maximum element in each row.
*
KD = KU + 1
DO 30 J = 1, N
DO 20 I = MAX( J-KU, 1 ), MIN( J+KL, M )
R( I ) = MAX( R( I ), ABS( AB( KD+I-J, J ) ) )
20 CONTINUE
30 CONTINUE
*
* Find the maximum and minimum scale factors.
*
RCMIN = BIGNUM
RCMAX = ZERO
DO 40 I = 1, M
RCMAX = MAX( RCMAX, R( I ) )
RCMIN = MIN( RCMIN, R( I ) )
40 CONTINUE
AMAX = RCMAX
*
IF( RCMIN.EQ.ZERO ) THEN
*
* Find the first zero scale factor and return an error code.
*
DO 50 I = 1, M
IF( R( I ).EQ.ZERO ) THEN
INFO = I
RETURN
END IF
50 CONTINUE
ELSE
*
* Invert the scale factors.
*
DO 60 I = 1, M
R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM )
60 CONTINUE
*
* Compute ROWCND = min(R(I)) / max(R(I))
*
ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
END IF
*
* Compute column scale factors
*
DO 70 J = 1, N
C( J ) = ZERO
70 CONTINUE
*
* Find the maximum element in each column,
* assuming the row scaling computed above.
*
KD = KU + 1
DO 90 J = 1, N
DO 80 I = MAX( J-KU, 1 ), MIN( J+KL, M )
C( J ) = MAX( C( J ), ABS( AB( KD+I-J, J ) )*R( I ) )
80 CONTINUE
90 CONTINUE
*
* Find the maximum and minimum scale factors.
*
RCMIN = BIGNUM
RCMAX = ZERO
DO 100 J = 1, N
RCMIN = MIN( RCMIN, C( J ) )
RCMAX = MAX( RCMAX, C( J ) )
100 CONTINUE
*
IF( RCMIN.EQ.ZERO ) THEN
*
* Find the first zero scale factor and return an error code.
*
DO 110 J = 1, N
IF( C( J ).EQ.ZERO ) THEN
INFO = M + J
RETURN
END IF
110 CONTINUE
ELSE
*
* Invert the scale factors.
*
DO 120 J = 1, N
C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM )
120 CONTINUE
*
* Compute COLCND = min(C(J)) / max(C(J))
*
COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
END IF
*
RETURN
*
* End of DGBEQU
*
END
SUBROUTINE DGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB,
$ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), IWORK( * )
DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
$ BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* DGBRFS improves the computed solution to a system of linear
* equations when the coefficient matrix is banded, and provides
* error bounds and backward error estimates for the solution.
*
* 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**H * X = B (Conjugate transpose = Transpose)
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KL (input) INTEGER
* The number of subdiagonals within the band of A. KL >= 0.
*
* KU (input) INTEGER
* The number of superdiagonals within the band of A. KU >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrices B and X. NRHS >= 0.
*
* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
* The original band matrix A, stored in rows 1 to KL+KU+1.
* The j-th column of A is stored in the j-th column of the
* array AB as follows:
* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KL+KU+1.
*
* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)
* Details of the LU factorization of the band matrix A, as
* computed by DGBTRF. U is stored as an upper triangular band
* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
* the multipliers used during the factorization are stored in
* rows KL+KU+2 to 2*KL+KU+1.
*
* LDAFB (input) INTEGER
* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices from DGBTRF; for 1<=i<=N, row i of the
* matrix was interchanged with row IPIV(i).
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
* On entry, the solution matrix X, as computed by DGBTRS.
* On exit, the improved solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Internal Parameters
* ===================
*
* ITMAX is the maximum number of steps of iterative refinement.
*
* =====================================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 5 )
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D+0 )
DOUBLE PRECISION THREE
PARAMETER ( THREE = 3.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN
CHARACTER TRANST
INTEGER COUNT, I, J, K, KASE, KK, NZ
DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DGBMV, DGBTRS, DLACN2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH
* ..
* .. 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( KL.LT.0 ) THEN
INFO = -3
ELSE IF( KU.LT.0 ) THEN
INFO = -4
ELSE IF( NRHS.LT.0 ) THEN
INFO = -5
ELSE IF( LDAB.LT.KL+KU+1 ) THEN
INFO = -7
ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN
INFO = -9
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -12
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -14
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGBRFS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
DO 10 J = 1, NRHS
FERR( J ) = ZERO
BERR( J ) = ZERO
10 CONTINUE
RETURN
END IF
*
IF( NOTRAN ) THEN
TRANST = 'T'
ELSE
TRANST = 'N'
END IF
*
* NZ = maximum number of nonzero elements in each row of A, plus 1
*
NZ = MIN( KL+KU+2, N+1 )
EPS = DLAMCH( 'Epsilon' )
SAFMIN = DLAMCH( 'Safe minimum' )
SAFE1 = NZ*SAFMIN
SAFE2 = SAFE1 / EPS
*
* Do for each right hand side
*
DO 140 J = 1, NRHS
*
COUNT = 1
LSTRES = THREE
20 CONTINUE
*
* Loop until stopping criterion is satisfied.
*
* Compute residual R = B - op(A) * X,
* where op(A) = A, A**T, or A**H, depending on TRANS.
*
CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
CALL DGBMV( TRANS, N, N, KL, KU, -ONE, AB, LDAB, X( 1, J ), 1,
$ ONE, WORK( N+1 ), 1 )
*
* Compute componentwise relative backward error from formula
*
* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
*
* where abs(Z) is the componentwise absolute value of the matrix
* or vector Z. If the i-th component of the denominator is less
* than SAFE2, then SAFE1 is added to the i-th components of the
* numerator and denominator before dividing.
*
DO 30 I = 1, N
WORK( I ) = ABS( B( I, J ) )
30 CONTINUE
*
* Compute abs(op(A))*abs(X) + abs(B).
*
IF( NOTRAN ) THEN
DO 50 K = 1, N
KK = KU + 1 - K
XK = ABS( X( K, J ) )
DO 40 I = MAX( 1, K-KU ), MIN( N, K+KL )
WORK( I ) = WORK( I ) + ABS( AB( KK+I, K ) )*XK
40 CONTINUE
50 CONTINUE
ELSE
DO 70 K = 1, N
S = ZERO
KK = KU + 1 - K
DO 60 I = MAX( 1, K-KU ), MIN( N, K+KL )
S = S + ABS( AB( KK+I, K ) )*ABS( X( I, J ) )
60 CONTINUE
WORK( K ) = WORK( K ) + S
70 CONTINUE
END IF
S = ZERO
DO 80 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
ELSE
S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
$ ( WORK( I )+SAFE1 ) )
END IF
80 CONTINUE
BERR( J ) = S
*
* Test stopping criterion. Continue iterating if
* 1) The residual BERR(J) is larger than machine epsilon, and
* 2) BERR(J) decreased by at least a factor of 2 during the
* last iteration, and
* 3) At most ITMAX iterations tried.
*
IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
$ COUNT.LE.ITMAX ) THEN
*
* Update solution and try again.
*
CALL DGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, IPIV,
$ WORK( N+1 ), N, INFO )
CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
LSTRES = BERR( J )
COUNT = COUNT + 1
GO TO 20
END IF
*
* Bound error from formula
*
* norm(X - XTRUE) / norm(X) .le. FERR =
* norm( abs(inv(op(A)))*
* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
*
* where
* norm(Z) is the magnitude of the largest component of Z
* inv(op(A)) is the inverse of op(A)
* abs(Z) is the componentwise absolute value of the matrix or
* vector Z
* NZ is the maximum number of nonzeros in any row of A, plus 1
* EPS is machine epsilon
*
* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
* is incremented by SAFE1 if the i-th component of
* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
*
* Use DLACN2 to estimate the infinity-norm of the matrix
* inv(op(A)) * diag(W),
* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
*
DO 90 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
ELSE
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
END IF
90 CONTINUE
*
KASE = 0
100 CONTINUE
CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
$ KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Multiply by diag(W)*inv(op(A)**T).
*
CALL DGBTRS( TRANST, N, KL, KU, 1, AFB, LDAFB, IPIV,
$ WORK( N+1 ), N, INFO )
DO 110 I = 1, N
WORK( N+I ) = WORK( N+I )*WORK( I )
110 CONTINUE
ELSE
*
* Multiply by inv(op(A))*diag(W).
*
DO 120 I = 1, N
WORK( N+I ) = WORK( N+I )*WORK( I )
120 CONTINUE
CALL DGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, IPIV,
$ WORK( N+1 ), N, INFO )
END IF
GO TO 100
END IF
*
* Normalize error.
*
LSTRES = ZERO
DO 130 I = 1, N
LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
130 CONTINUE
IF( LSTRES.NE.ZERO )
$ FERR( J ) = FERR( J ) / LSTRES
*
140 CONTINUE
*
RETURN
*
* End of DGBRFS
*
END
SUBROUTINE DGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION AB( LDAB, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* DGBSV computes the solution to a real system of linear equations
* A * X = B, where A is a band matrix of order N with KL subdiagonals
* and KU superdiagonals, and X and B are N-by-NRHS matrices.
*
* The LU decomposition with partial pivoting and row interchanges is
* used to factor A as A = L * U, where L is a product of permutation
* and unit lower triangular matrices with KL subdiagonals, and U is
* upper triangular with KL+KU superdiagonals. The factored form of A
* is then used to solve the system of equations A * X = B.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of linear equations, i.e., the order of the
* matrix A. N >= 0.
*
* KL (input) INTEGER
* The number of subdiagonals within the band of A. KL >= 0.
*
* KU (input) INTEGER
* The number of superdiagonals within the band of A. KU >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrix B. NRHS >= 0.
*
* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
* On entry, the matrix A in band storage, in rows KL+1 to
* 2*KL+KU+1; rows 1 to KL of the array need not be set.
* The j-th column of A is stored in the j-th column of the
* array AB as follows:
* AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)
* On exit, details of the factorization: U is stored as an
* upper triangular band matrix with KL+KU superdiagonals in
* rows 1 to KL+KU+1, and the multipliers used during the
* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
* See below for further details.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
*
* IPIV (output) INTEGER array, dimension (N)
* The pivot indices that define the permutation matrix P;
* row i of the matrix was interchanged with row IPIV(i).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the N-by-NRHS right hand side matrix B.
* On exit, if INFO = 0, the N-by-NRHS 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
* > 0: if INFO = i, U(i,i) is exactly zero. The factorization
* has been completed, but the factor U is exactly
* singular, and the solution has not been computed.
*
* Further Details
* ===============
*
* The band storage scheme is illustrated by the following example, when
* M = N = 6, KL = 2, KU = 1:
*
* On entry: On exit:
*
* * * * + + + * * * u14 u25 u36
* * * + + + + * * u13 u24 u35 u46
* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
* a31 a42 a53 a64 * * m31 m42 m53 m64 * *
*
* Array elements marked * are not used by the routine; elements marked
* + need not be set on entry, but are required by the routine to store
* elements of U because of fill-in resulting from the row interchanges.
*
* =====================================================================
*
* .. External Subroutines ..
EXTERNAL DGBTRF, DGBTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( KL.LT.0 ) THEN
INFO = -2
ELSE IF( KU.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN
INFO = -6
ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGBSV ', -INFO )
RETURN
END IF
*
* Compute the LU factorization of the band matrix A.
*
CALL DGBTRF( N, N, KL, KU, AB, LDAB, IPIV, INFO )
IF( INFO.EQ.0 ) THEN
*
* Solve the system A*X = B, overwriting B with X.
*
CALL DGBTRS( 'No transpose', N, KL, KU, NRHS, AB, LDAB, IPIV,
$ B, LDB, INFO )
END IF
RETURN
*
* End of DGBSV
*
END
SUBROUTINE DGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB,
$ LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX,
$ RCOND, FERR, BERR, WORK, IWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER EQUED, FACT, TRANS
INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS
DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), IWORK( * )
DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
$ BERR( * ), C( * ), FERR( * ), R( * ),
$ WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* DGBSVX uses the LU factorization to compute the solution to a real
* system of linear equations A * X = B, A**T * X = B, or A**H * X = B,
* where A is a band matrix of order N with KL subdiagonals and KU
* superdiagonals, and X and B are N-by-NRHS matrices.
*
* Error bounds on the solution and a condition estimate are also
* provided.
*
* Description
* ===========
*
* The following steps are performed by this subroutine:
*
* 1. If FACT = 'E', real scaling factors are computed to equilibrate
* the system:
* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B
* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
* Whether or not the system will be equilibrated depends on the
* scaling of the matrix A, but if equilibration is used, A is
* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
* or diag(C)*B (if TRANS = 'T' or 'C').
*
* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the
* matrix A (after equilibration if FACT = 'E') as
* A = L * U,
* where L is a product of permutation and unit lower triangular
* matrices with KL subdiagonals, and U is upper triangular with
* KL+KU superdiagonals.
*
* 3. If some U(i,i)=0, so that U is exactly singular, then the routine
* returns with INFO = i. Otherwise, the factored form of A is used
* to estimate the condition number of the matrix A. If the
* reciprocal of the condition number is less than machine precision,
* INFO = N+1 is returned as a warning, but the routine still goes on
* to solve for X and compute error bounds as described below.
*
* 4. The system of equations is solved for X using the factored form
* of A.
*
* 5. Iterative refinement is applied to improve the computed solution
* matrix and calculate error bounds and backward error estimates
* for it.
*
* 6. If equilibration was used, the matrix X is premultiplied by
* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
* that it solves the original system before equilibration.
*
* Arguments
* =========
*
* FACT (input) CHARACTER*1
* Specifies whether or not the factored form of the matrix A is
* supplied on entry, and if not, whether the matrix A should be
* equilibrated before it is factored.
* = 'F': On entry, AFB and IPIV contain the factored form of
* A. If EQUED is not 'N', the matrix A has been
* equilibrated with scaling factors given by R and C.
* AB, AFB, and IPIV are not modified.
* = 'N': The matrix A will be copied to AFB and factored.
* = 'E': The matrix A will be equilibrated if necessary, then
* copied to AFB and factored.
*
* 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**H * X = B (Transpose)
*
* N (input) INTEGER
* The number of linear equations, i.e., the order of the
* matrix A. N >= 0.
*
* KL (input) INTEGER
* The number of subdiagonals within the band of A. KL >= 0.
*
* KU (input) INTEGER
* The number of superdiagonals within the band of A. KU >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrices B and X. NRHS >= 0.
*
* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
* The j-th column of A is stored in the j-th column of the
* array AB as follows:
* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)
*
* If FACT = 'F' and EQUED is not 'N', then A must have been
* equilibrated by the scaling factors in R and/or C. AB is not
* modified if FACT = 'F' or 'N', or if FACT = 'E' and
* EQUED = 'N' on exit.
*
* On exit, if EQUED .ne. 'N', A is scaled as follows:
* EQUED = 'R': A := diag(R) * A
* EQUED = 'C': A := A * diag(C)
* EQUED = 'B': A := diag(R) * A * diag(C).
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KL+KU+1.
*
* AFB (input or output) DOUBLE PRECISION array, dimension (LDAFB,N)
* If FACT = 'F', then AFB is an input argument and on entry
* contains details of the LU factorization of the band matrix
* A, as computed by DGBTRF. U is stored as an upper triangular
* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,
* and the multipliers used during the factorization are stored
* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is
* the factored form of the equilibrated matrix A.
*
* If FACT = 'N', then AFB is an output argument and on exit
* returns details of the LU factorization of A.
*
* If FACT = 'E', then AFB is an output argument and on exit
* returns details of the LU factorization of the equilibrated
* matrix A (see the description of AB for the form of the
* equilibrated matrix).
*
* LDAFB (input) INTEGER
* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.
*
* IPIV (input or output) INTEGER array, dimension (N)
* If FACT = 'F', then IPIV is an input argument and on entry
* contains the pivot indices from the factorization A = L*U
* as computed by DGBTRF; row i of the matrix was interchanged
* with row IPIV(i).
*
* If FACT = 'N', then IPIV is an output argument and on exit
* contains the pivot indices from the factorization A = L*U
* of the original matrix A.
*
* If FACT = 'E', then IPIV is an output argument and on exit
* contains the pivot indices from the factorization A = L*U
* of the equilibrated matrix A.
*
* EQUED (input or output) CHARACTER*1
* Specifies the form of equilibration that was done.
* = 'N': No equilibration (always true if FACT = 'N').
* = 'R': Row equilibration, i.e., A has been premultiplied by
* diag(R).
* = 'C': Column equilibration, i.e., A has been postmultiplied
* by diag(C).
* = 'B': Both row and column equilibration, i.e., A has been
* replaced by diag(R) * A * diag(C).
* EQUED is an input argument if FACT = 'F'; otherwise, it is an
* output argument.
*
* R (input or output) DOUBLE PRECISION array, dimension (N)
* The row scale factors for A. If EQUED = 'R' or 'B', A is
* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
* is not accessed. R is an input argument if FACT = 'F';
* otherwise, R is an output argument. If FACT = 'F' and
* EQUED = 'R' or 'B', each element of R must be positive.
*
* C (input or output) DOUBLE PRECISION array, dimension (N)
* The column scale factors for A. If EQUED = 'C' or 'B', A is
* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
* is not accessed. C is an input argument if FACT = 'F';
* otherwise, C is an output argument. If FACT = 'F' and
* EQUED = 'C' or 'B', each element of C must be positive.
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the right hand side matrix B.
* On exit,
* if EQUED = 'N', B is not modified;
* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
* diag(R)*B;
* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
* overwritten by diag(C)*B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X
* to the original system of equations. Note that A and B are
* modified on exit if EQUED .ne. 'N', and the solution to the
* equilibrated system is inv(diag(C))*X if TRANS = 'N' and
* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'
* and EQUED = 'R' or 'B'.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* RCOND (output) DOUBLE PRECISION
* The estimate of the reciprocal condition number of the matrix
* A after equilibration (if done). If RCOND is less than the
* machine precision (in particular, if RCOND = 0), the matrix
* is singular to working precision. This condition is
* indicated by a return code of INFO > 0.
*
* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace/output) DOUBLE PRECISION array, dimension (3*N)
* On exit, WORK(1) contains the reciprocal pivot growth
* factor norm(A)/norm(U). The "max absolute element" norm is
* used. If WORK(1) is much less than 1, then the stability
* of the LU factorization of the (equilibrated) matrix A
* could be poor. This also means that the solution X, condition
* estimator RCOND, and forward error bound FERR could be
* unreliable. If factorization fails with 0 0: if INFO = i, and i is
* <= N: U(i,i) is exactly zero. The factorization
* has been completed, but the factor U is exactly
* singular, so the solution and error bounds
* could not be computed. RCOND = 0 is returned.
* = N+1: U is nonsingular, but RCOND is less than machine
* precision, meaning that the matrix is singular
* to working precision. Nevertheless, the
* solution and error bounds are computed because
* there are a number of situations where the
* computed solution can be more accurate than the
* value of RCOND would suggest.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU
CHARACTER NORM
INTEGER I, INFEQU, J, J1, J2
DOUBLE PRECISION AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN,
$ ROWCND, RPVGRW, SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANGB, DLANTB
EXTERNAL LSAME, DLAMCH, DLANGB, DLANTB
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGBCON, DGBEQU, DGBRFS, DGBTRF, DGBTRS,
$ DLACPY, DLAQGB, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
NOFACT = LSAME( FACT, 'N' )
EQUIL = LSAME( FACT, 'E' )
NOTRAN = LSAME( TRANS, 'N' )
IF( NOFACT .OR. EQUIL ) THEN
EQUED = 'N'
ROWEQU = .FALSE.
COLEQU = .FALSE.
ELSE
ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
SMLNUM = DLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
END IF
*
* Test the input parameters.
*
IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
$ THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
$ LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( KL.LT.0 ) THEN
INFO = -4
ELSE IF( KU.LT.0 ) THEN
INFO = -5
ELSE IF( NRHS.LT.0 ) THEN
INFO = -6
ELSE IF( LDAB.LT.KL+KU+1 ) THEN
INFO = -8
ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN
INFO = -10
ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
$ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
INFO = -12
ELSE
IF( ROWEQU ) THEN
RCMIN = BIGNUM
RCMAX = ZERO
DO 10 J = 1, N
RCMIN = MIN( RCMIN, R( J ) )
RCMAX = MAX( RCMAX, R( J ) )
10 CONTINUE
IF( RCMIN.LE.ZERO ) THEN
INFO = -13
ELSE IF( N.GT.0 ) THEN
ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
ELSE
ROWCND = ONE
END IF
END IF
IF( COLEQU .AND. INFO.EQ.0 ) THEN
RCMIN = BIGNUM
RCMAX = ZERO
DO 20 J = 1, N
RCMIN = MIN( RCMIN, C( J ) )
RCMAX = MAX( RCMAX, C( J ) )
20 CONTINUE
IF( RCMIN.LE.ZERO ) THEN
INFO = -14
ELSE IF( N.GT.0 ) THEN
COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
ELSE
COLCND = ONE
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -16
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -18
END IF
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGBSVX', -INFO )
RETURN
END IF
*
IF( EQUIL ) THEN
*
* Compute row and column scalings to equilibrate the matrix A.
*
CALL DGBEQU( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND,
$ AMAX, INFEQU )
IF( INFEQU.EQ.0 ) THEN
*
* Equilibrate the matrix.
*
CALL DLAQGB( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND,
$ AMAX, EQUED )
ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
END IF
END IF
*
* Scale the right hand side.
*
IF( NOTRAN ) THEN
IF( ROWEQU ) THEN
DO 40 J = 1, NRHS
DO 30 I = 1, N
B( I, J ) = R( I )*B( I, J )
30 CONTINUE
40 CONTINUE
END IF
ELSE IF( COLEQU ) THEN
DO 60 J = 1, NRHS
DO 50 I = 1, N
B( I, J ) = C( I )*B( I, J )
50 CONTINUE
60 CONTINUE
END IF
*
IF( NOFACT .OR. EQUIL ) THEN
*
* Compute the LU factorization of the band matrix A.
*
DO 70 J = 1, N
J1 = MAX( J-KU, 1 )
J2 = MIN( J+KL, N )
CALL DCOPY( J2-J1+1, AB( KU+1-J+J1, J ), 1,
$ AFB( KL+KU+1-J+J1, J ), 1 )
70 CONTINUE
*
CALL DGBTRF( N, N, KL, KU, AFB, LDAFB, IPIV, INFO )
*
* Return if INFO is non-zero.
*
IF( INFO.GT.0 ) THEN
*
* Compute the reciprocal pivot growth factor of the
* leading rank-deficient INFO columns of A.
*
ANORM = ZERO
DO 90 J = 1, INFO
DO 80 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
ANORM = MAX( ANORM, ABS( AB( I, J ) ) )
80 CONTINUE
90 CONTINUE
RPVGRW = DLANTB( 'M', 'U', 'N', INFO, MIN( INFO-1, KL+KU ),
$ AFB( MAX( 1, KL+KU+2-INFO ), 1 ), LDAFB,
$ WORK )
IF( RPVGRW.EQ.ZERO ) THEN
RPVGRW = ONE
ELSE
RPVGRW = ANORM / RPVGRW
END IF
WORK( 1 ) = RPVGRW
RCOND = ZERO
RETURN
END IF
END IF
*
* Compute the norm of the matrix A and the
* reciprocal pivot growth factor RPVGRW.
*
IF( NOTRAN ) THEN
NORM = '1'
ELSE
NORM = 'I'
END IF
ANORM = DLANGB( NORM, N, KL, KU, AB, LDAB, WORK )
RPVGRW = DLANTB( 'M', 'U', 'N', N, KL+KU, AFB, LDAFB, WORK )
IF( RPVGRW.EQ.ZERO ) THEN
RPVGRW = ONE
ELSE
RPVGRW = DLANGB( 'M', N, KL, KU, AB, LDAB, WORK ) / RPVGRW
END IF
*
* Compute the reciprocal of the condition number of A.
*
CALL DGBCON( NORM, N, KL, KU, AFB, LDAFB, IPIV, ANORM, RCOND,
$ WORK, IWORK, INFO )
*
* Compute the solution matrix X.
*
CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
CALL DGBTRS( TRANS, N, KL, KU, NRHS, AFB, LDAFB, IPIV, X, LDX,
$ INFO )
*
* Use iterative refinement to improve the computed solution and
* compute error bounds and backward error estimates for it.
*
CALL DGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV,
$ B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
*
* Transform the solution matrix X to a solution of the original
* system.
*
IF( NOTRAN ) THEN
IF( COLEQU ) THEN
DO 110 J = 1, NRHS
DO 100 I = 1, N
X( I, J ) = C( I )*X( I, J )
100 CONTINUE
110 CONTINUE
DO 120 J = 1, NRHS
FERR( J ) = FERR( J ) / COLCND
120 CONTINUE
END IF
ELSE IF( ROWEQU ) THEN
DO 140 J = 1, NRHS
DO 130 I = 1, N
X( I, J ) = R( I )*X( I, J )
130 CONTINUE
140 CONTINUE
DO 150 J = 1, NRHS
FERR( J ) = FERR( J ) / ROWCND
150 CONTINUE
END IF
*
* Set INFO = N+1 if the matrix is singular to working precision.
*
IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
$ INFO = N + 1
*
WORK( 1 ) = RPVGRW
RETURN
*
* End of DGBSVX
*
END
SUBROUTINE DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, KL, KU, LDAB, M, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION AB( LDAB, * )
* ..
*
* Purpose
* =======
*
* DGBTF2 computes an LU factorization of a real m-by-n band matrix A
* using partial pivoting with row interchanges.
*
* This is the unblocked version of the algorithm, calling Level 2 BLAS.
*
* 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.
*
* KL (input) INTEGER
* The number of subdiagonals within the band of A. KL >= 0.
*
* KU (input) INTEGER
* The number of superdiagonals within the band of A. KU >= 0.
*
* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
* On entry, the matrix A in band storage, in rows KL+1 to
* 2*KL+KU+1; rows 1 to KL of the array need not be set.
* The j-th column of A is stored in the j-th column of the
* array AB as follows:
* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
*
* On exit, details of the factorization: U is stored as an
* upper triangular band matrix with KL+KU superdiagonals in
* rows 1 to KL+KU+1, and the multipliers used during the
* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
* See below for further details.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
*
* 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.
*
* Further Details
* ===============
*
* The band storage scheme is illustrated by the following example, when
* M = N = 6, KL = 2, KU = 1:
*
* On entry: On exit:
*
* * * * + + + * * * u14 u25 u36
* * * + + + + * * u13 u24 u35 u46
* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
* a31 a42 a53 a64 * * m31 m42 m53 m64 * *
*
* Array elements marked * are not used by the routine; elements marked
* + need not be set on entry, but are required by the routine to store
* elements of U, because of fill-in resulting from the row
* interchanges.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, JP, JU, KM, KV
* ..
* .. External Functions ..
INTEGER IDAMAX
EXTERNAL IDAMAX
* ..
* .. External Subroutines ..
EXTERNAL DGER, DSCAL, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* KV is the number of superdiagonals in the factor U, allowing for
* fill-in.
*
KV = KU + KL
*
* Test the input parameters.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( KL.LT.0 ) THEN
INFO = -3
ELSE IF( KU.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.KL+KV+1 ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGBTF2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
* Gaussian elimination with partial pivoting
*
* Set fill-in elements in columns KU+2 to KV to zero.
*
DO 20 J = KU + 2, MIN( KV, N )
DO 10 I = KV - J + 2, KL
AB( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
*
* JU is the index of the last column affected by the current stage
* of the factorization.
*
JU = 1
*
DO 40 J = 1, MIN( M, N )
*
* Set fill-in elements in column J+KV to zero.
*
IF( J+KV.LE.N ) THEN
DO 30 I = 1, KL
AB( I, J+KV ) = ZERO
30 CONTINUE
END IF
*
* Find pivot and test for singularity. KM is the number of
* subdiagonal elements in the current column.
*
KM = MIN( KL, M-J )
JP = IDAMAX( KM+1, AB( KV+1, J ), 1 )
IPIV( J ) = JP + J - 1
IF( AB( KV+JP, J ).NE.ZERO ) THEN
JU = MAX( JU, MIN( J+KU+JP-1, N ) )
*
* Apply interchange to columns J to JU.
*
IF( JP.NE.1 )
$ CALL DSWAP( JU-J+1, AB( KV+JP, J ), LDAB-1,
$ AB( KV+1, J ), LDAB-1 )
*
IF( KM.GT.0 ) THEN
*
* Compute multipliers.
*
CALL DSCAL( KM, ONE / AB( KV+1, J ), AB( KV+2, J ), 1 )
*
* Update trailing submatrix within the band.
*
IF( JU.GT.J )
$ CALL DGER( KM, JU-J, -ONE, AB( KV+2, J ), 1,
$ AB( KV, J+1 ), LDAB-1, AB( KV+1, J+1 ),
$ LDAB-1 )
END IF
ELSE
*
* If pivot is zero, set INFO to the index of the pivot
* unless a zero pivot has already been found.
*
IF( INFO.EQ.0 )
$ INFO = J
END IF
40 CONTINUE
RETURN
*
* End of DGBTF2
*
END
SUBROUTINE DGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, KL, KU, LDAB, M, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION AB( LDAB, * )
* ..
*
* Purpose
* =======
*
* DGBTRF computes an LU factorization of a real m-by-n band matrix A
* using partial pivoting with row interchanges.
*
* This is the blocked version of the algorithm, calling Level 3 BLAS.
*
* 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.
*
* KL (input) INTEGER
* The number of subdiagonals within the band of A. KL >= 0.
*
* KU (input) INTEGER
* The number of superdiagonals within the band of A. KU >= 0.
*
* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
* On entry, the matrix A in band storage, in rows KL+1 to
* 2*KL+KU+1; rows 1 to KL of the array need not be set.
* The j-th column of A is stored in the j-th column of the
* array AB as follows:
* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
*
* On exit, details of the factorization: U is stored as an
* upper triangular band matrix with KL+KU superdiagonals in
* rows 1 to KL+KU+1, and the multipliers used during the
* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
* See below for further details.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
*
* 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.
*
* Further Details
* ===============
*
* The band storage scheme is illustrated by the following example, when
* M = N = 6, KL = 2, KU = 1:
*
* On entry: On exit:
*
* * * * + + + * * * u14 u25 u36
* * * + + + + * * u13 u24 u35 u46
* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
* a31 a42 a53 a64 * * m31 m42 m53 m64 * *
*
* Array elements marked * are not used by the routine; elements marked
* + need not be set on entry, but are required by the routine to store
* elements of U because of fill-in resulting from the row interchanges.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
INTEGER NBMAX, LDWORK
PARAMETER ( NBMAX = 64, LDWORK = NBMAX+1 )
* ..
* .. Local Scalars ..
INTEGER I, I2, I3, II, IP, J, J2, J3, JB, JJ, JM, JP,
$ JU, K2, KM, KV, NB, NW
DOUBLE PRECISION TEMP
* ..
* .. Local Arrays ..
DOUBLE PRECISION WORK13( LDWORK, NBMAX ),
$ WORK31( LDWORK, NBMAX )
* ..
* .. External Functions ..
INTEGER IDAMAX, ILAENV
EXTERNAL IDAMAX, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGBTF2, DGEMM, DGER, DLASWP, DSCAL,
$ DSWAP, DTRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* KV is the number of superdiagonals in the factor U, allowing for
* fill-in
*
KV = KU + KL
*
* Test the input parameters.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( KL.LT.0 ) THEN
INFO = -3
ELSE IF( KU.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.KL+KV+1 ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGBTRF', -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, 'DGBTRF', ' ', M, N, KL, KU )
*
* The block size must not exceed the limit set by the size of the
* local arrays WORK13 and WORK31.
*
NB = MIN( NB, NBMAX )
*
IF( NB.LE.1 .OR. NB.GT.KL ) THEN
*
* Use unblocked code
*
CALL DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
ELSE
*
* Use blocked code
*
* Zero the superdiagonal elements of the work array WORK13
*
DO 20 J = 1, NB
DO 10 I = 1, J - 1
WORK13( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
*
* Zero the subdiagonal elements of the work array WORK31
*
DO 40 J = 1, NB
DO 30 I = J + 1, NB
WORK31( I, J ) = ZERO
30 CONTINUE
40 CONTINUE
*
* Gaussian elimination with partial pivoting
*
* Set fill-in elements in columns KU+2 to KV to zero
*
DO 60 J = KU + 2, MIN( KV, N )
DO 50 I = KV - J + 2, KL
AB( I, J ) = ZERO
50 CONTINUE
60 CONTINUE
*
* JU is the index of the last column affected by the current
* stage of the factorization
*
JU = 1
*
DO 180 J = 1, MIN( M, N ), NB
JB = MIN( NB, MIN( M, N )-J+1 )
*
* The active part of the matrix is partitioned
*
* A11 A12 A13
* A21 A22 A23
* A31 A32 A33
*
* Here A11, A21 and A31 denote the current block of JB columns
* which is about to be factorized. The number of rows in the
* partitioning are JB, I2, I3 respectively, and the numbers
* of columns are JB, J2, J3. The superdiagonal elements of A13
* and the subdiagonal elements of A31 lie outside the band.
*
I2 = MIN( KL-JB, M-J-JB+1 )
I3 = MIN( JB, M-J-KL+1 )
*
* J2 and J3 are computed after JU has been updated.
*
* Factorize the current block of JB columns
*
DO 80 JJ = J, J + JB - 1
*
* Set fill-in elements in column JJ+KV to zero
*
IF( JJ+KV.LE.N ) THEN
DO 70 I = 1, KL
AB( I, JJ+KV ) = ZERO
70 CONTINUE
END IF
*
* Find pivot and test for singularity. KM is the number of
* subdiagonal elements in the current column.
*
KM = MIN( KL, M-JJ )
JP = IDAMAX( KM+1, AB( KV+1, JJ ), 1 )
IPIV( JJ ) = JP + JJ - J
IF( AB( KV+JP, JJ ).NE.ZERO ) THEN
JU = MAX( JU, MIN( JJ+KU+JP-1, N ) )
IF( JP.NE.1 ) THEN
*
* Apply interchange to columns J to J+JB-1
*
IF( JP+JJ-1.LT.J+KL ) THEN
*
CALL DSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1,
$ AB( KV+JP+JJ-J, J ), LDAB-1 )
ELSE
*
* The interchange affects columns J to JJ-1 of A31
* which are stored in the work array WORK31
*
CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
$ WORK31( JP+JJ-J-KL, 1 ), LDWORK )
CALL DSWAP( J+JB-JJ, AB( KV+1, JJ ), LDAB-1,
$ AB( KV+JP, JJ ), LDAB-1 )
END IF
END IF
*
* Compute multipliers
*
CALL DSCAL( KM, ONE / AB( KV+1, JJ ), AB( KV+2, JJ ),
$ 1 )
*
* Update trailing submatrix within the band and within
* the current block. JM is the index of the last column
* which needs to be updated.
*
JM = MIN( JU, J+JB-1 )
IF( JM.GT.JJ )
$ CALL DGER( KM, JM-JJ, -ONE, AB( KV+2, JJ ), 1,
$ AB( KV, JJ+1 ), LDAB-1,
$ AB( KV+1, JJ+1 ), LDAB-1 )
ELSE
*
* If pivot is zero, set INFO to the index of the pivot
* unless a zero pivot has already been found.
*
IF( INFO.EQ.0 )
$ INFO = JJ
END IF
*
* Copy current column of A31 into the work array WORK31
*
NW = MIN( JJ-J+1, I3 )
IF( NW.GT.0 )
$ CALL DCOPY( NW, AB( KV+KL+1-JJ+J, JJ ), 1,
$ WORK31( 1, JJ-J+1 ), 1 )
80 CONTINUE
IF( J+JB.LE.N ) THEN
*
* Apply the row interchanges to the other blocks.
*
J2 = MIN( JU-J+1, KV ) - JB
J3 = MAX( 0, JU-J-KV+1 )
*
* Use DLASWP to apply the row interchanges to A12, A22, and
* A32.
*
CALL DLASWP( J2, AB( KV+1-JB, J+JB ), LDAB-1, 1, JB,
$ IPIV( J ), 1 )
*
* Adjust the pivot indices.
*
DO 90 I = J, J + JB - 1
IPIV( I ) = IPIV( I ) + J - 1
90 CONTINUE
*
* Apply the row interchanges to A13, A23, and A33
* columnwise.
*
K2 = J - 1 + JB + J2
DO 110 I = 1, J3
JJ = K2 + I
DO 100 II = J + I - 1, J + JB - 1
IP = IPIV( II )
IF( IP.NE.II ) THEN
TEMP = AB( KV+1+II-JJ, JJ )
AB( KV+1+II-JJ, JJ ) = AB( KV+1+IP-JJ, JJ )
AB( KV+1+IP-JJ, JJ ) = TEMP
END IF
100 CONTINUE
110 CONTINUE
*
* Update the relevant part of the trailing submatrix
*
IF( J2.GT.0 ) THEN
*
* Update A12
*
CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit',
$ JB, J2, ONE, AB( KV+1, J ), LDAB-1,
$ AB( KV+1-JB, J+JB ), LDAB-1 )
*
IF( I2.GT.0 ) THEN
*
* Update A22
*
CALL DGEMM( 'No transpose', 'No transpose', I2, J2,
$ JB, -ONE, AB( KV+1+JB, J ), LDAB-1,
$ AB( KV+1-JB, J+JB ), LDAB-1, ONE,
$ AB( KV+1, J+JB ), LDAB-1 )
END IF
*
IF( I3.GT.0 ) THEN
*
* Update A32
*
CALL DGEMM( 'No transpose', 'No transpose', I3, J2,
$ JB, -ONE, WORK31, LDWORK,
$ AB( KV+1-JB, J+JB ), LDAB-1, ONE,
$ AB( KV+KL+1-JB, J+JB ), LDAB-1 )
END IF
END IF
*
IF( J3.GT.0 ) THEN
*
* Copy the lower triangle of A13 into the work array
* WORK13
*
DO 130 JJ = 1, J3
DO 120 II = JJ, JB
WORK13( II, JJ ) = AB( II-JJ+1, JJ+J+KV-1 )
120 CONTINUE
130 CONTINUE
*
* Update A13 in the work array
*
CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit',
$ JB, J3, ONE, AB( KV+1, J ), LDAB-1,
$ WORK13, LDWORK )
*
IF( I2.GT.0 ) THEN
*
* Update A23
*
CALL DGEMM( 'No transpose', 'No transpose', I2, J3,
$ JB, -ONE, AB( KV+1+JB, J ), LDAB-1,
$ WORK13, LDWORK, ONE, AB( 1+JB, J+KV ),
$ LDAB-1 )
END IF
*
IF( I3.GT.0 ) THEN
*
* Update A33
*
CALL DGEMM( 'No transpose', 'No transpose', I3, J3,
$ JB, -ONE, WORK31, LDWORK, WORK13,
$ LDWORK, ONE, AB( 1+KL, J+KV ), LDAB-1 )
END IF
*
* Copy the lower triangle of A13 back into place
*
DO 150 JJ = 1, J3
DO 140 II = JJ, JB
AB( II-JJ+1, JJ+J+KV-1 ) = WORK13( II, JJ )
140 CONTINUE
150 CONTINUE
END IF
ELSE
*
* Adjust the pivot indices.
*
DO 160 I = J, J + JB - 1
IPIV( I ) = IPIV( I ) + J - 1
160 CONTINUE
END IF
*
* Partially undo the interchanges in the current block to
* restore the upper triangular form of A31 and copy the upper
* triangle of A31 back into place
*
DO 170 JJ = J + JB - 1, J, -1
JP = IPIV( JJ ) - JJ + 1
IF( JP.NE.1 ) THEN
*
* Apply interchange to columns J to JJ-1
*
IF( JP+JJ-1.LT.J+KL ) THEN
*
* The interchange does not affect A31
*
CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
$ AB( KV+JP+JJ-J, J ), LDAB-1 )
ELSE
*
* The interchange does affect A31
*
CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
$ WORK31( JP+JJ-J-KL, 1 ), LDWORK )
END IF
END IF
*
* Copy the current column of A31 back into place
*
NW = MIN( I3, JJ-J+1 )
IF( NW.GT.0 )
$ CALL DCOPY( NW, WORK31( 1, JJ-J+1 ), 1,
$ AB( KV+KL+1-JJ+J, JJ ), 1 )
170 CONTINUE
180 CONTINUE
END IF
*
RETURN
*
* End of DGBTRF
*
END
SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION AB( LDAB, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* DGBTRS solves a system of linear equations
* A * X = B or A' * X = B
* with a general band matrix A using the LU factorization computed
* by DGBTRF.
*
* Arguments
* =========
*
* TRANS (input) CHARACTER*1
* Specifies the form of the system of equations.
* = 'N': A * X = B (No transpose)
* = 'T': A'* X = B (Transpose)
* = 'C': A'* X = B (Conjugate transpose = Transpose)
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KL (input) INTEGER
* The number of subdiagonals within the band of A. KL >= 0.
*
* KU (input) INTEGER
* The number of superdiagonals within the band of A. KU >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrix B. NRHS >= 0.
*
* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
* Details of the LU factorization of the band matrix A, as
* computed by DGBTRF. U is stored as an upper triangular band
* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
* the multipliers used during the factorization are stored in
* rows KL+KU+2 to 2*KL+KU+1.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices; 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 LNOTI, NOTRAN
INTEGER I, J, KD, L, LM
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DGEMV, DGER, DSWAP, DTBSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. 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( KL.LT.0 ) THEN
INFO = -3
ELSE IF( KU.LT.0 ) THEN
INFO = -4
ELSE IF( NRHS.LT.0 ) THEN
INFO = -5
ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGBTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
KD = KU + KL + 1
LNOTI = KL.GT.0
*
IF( NOTRAN ) THEN
*
* Solve A*X = B.
*
* Solve L*X = B, overwriting B with X.
*
* L is represented as a product of permutations and unit lower
* triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1),
* where each transformation L(i) is a rank-one modification of
* the identity matrix.
*
IF( LNOTI ) THEN
DO 10 J = 1, N - 1
LM = MIN( KL, N-J )
L = IPIV( J )
IF( L.NE.J )
$ CALL DSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
CALL DGER( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ),
$ LDB, B( J+1, 1 ), LDB )
10 CONTINUE
END IF
*
DO 20 I = 1, NRHS
*
* Solve U*X = B, overwriting B with X.
*
CALL DTBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU,
$ AB, LDAB, B( 1, I ), 1 )
20 CONTINUE
*
ELSE
*
* Solve A'*X = B.
*
DO 30 I = 1, NRHS
*
* Solve U'*X = B, overwriting B with X.
*
CALL DTBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB,
$ LDAB, B( 1, I ), 1 )
30 CONTINUE
*
* Solve L'*X = B, overwriting B with X.
*
IF( LNOTI ) THEN
DO 40 J = N - 1, 1, -1
LM = MIN( KL, N-J )
CALL DGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ),
$ LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB )
L = IPIV( J )
IF( L.NE.J )
$ CALL DSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
40 CONTINUE
END IF
END IF
RETURN
*
* End of DGBTRS
*
END
SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOB, SIDE
INTEGER IHI, ILO, INFO, LDV, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION SCALE( * ), V( LDV, * )
* ..
*
* Purpose
* =======
*
* DGEBAK forms the right or left eigenvectors of a real general matrix
* by backward transformation on the computed eigenvectors of the
* balanced matrix output by DGEBAL.
*
* Arguments
* =========
*
* JOB (input) CHARACTER*1
* Specifies the type of backward transformation required:
* = 'N', do nothing, return immediately;
* = 'P', do backward transformation for permutation only;
* = 'S', do backward transformation for scaling only;
* = 'B', do backward transformations for both permutation and
* scaling.
* JOB must be the same as the argument JOB supplied to DGEBAL.
*
* SIDE (input) CHARACTER*1
* = 'R': V contains right eigenvectors;
* = 'L': V contains left eigenvectors.
*
* N (input) INTEGER
* The number of rows of the matrix V. N >= 0.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* The integers ILO and IHI determined by DGEBAL.
* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
*
* SCALE (input) DOUBLE PRECISION array, dimension (N)
* Details of the permutation and scaling factors, as returned
* by DGEBAL.
*
* M (input) INTEGER
* The number of columns of the matrix V. M >= 0.
*
* V (input/output) DOUBLE PRECISION array, dimension (LDV,M)
* On entry, the matrix of right or left eigenvectors to be
* transformed, as returned by DHSEIN or DTREVC.
* On exit, V is overwritten by the transformed eigenvectors.
*
* LDV (input) INTEGER
* The leading dimension of the array V. LDV >= 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 LEFTV, RIGHTV
INTEGER I, II, K
DOUBLE PRECISION S
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Decode and Test the input parameters
*
RIGHTV = LSAME( SIDE, 'R' )
LEFTV = LSAME( SIDE, 'L' )
*
INFO = 0
IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
$ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
INFO = -1
ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
INFO = -5
ELSE IF( M.LT.0 ) THEN
INFO = -7
ELSE IF( LDV.LT.MAX( 1, N ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGEBAK', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
IF( M.EQ.0 )
$ RETURN
IF( LSAME( JOB, 'N' ) )
$ RETURN
*
IF( ILO.EQ.IHI )
$ GO TO 30
*
* Backward balance
*
IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN
*
IF( RIGHTV ) THEN
DO 10 I = ILO, IHI
S = SCALE( I )
CALL DSCAL( M, S, V( I, 1 ), LDV )
10 CONTINUE
END IF
*
IF( LEFTV ) THEN
DO 20 I = ILO, IHI
S = ONE / SCALE( I )
CALL DSCAL( M, S, V( I, 1 ), LDV )
20 CONTINUE
END IF
*
END IF
*
* Backward permutation
*
* For I = ILO-1 step -1 until 1,
* IHI+1 step 1 until N do --
*
30 CONTINUE
IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN
IF( RIGHTV ) THEN
DO 40 II = 1, N
I = II
IF( I.GE.ILO .AND. I.LE.IHI )
$ GO TO 40
IF( I.LT.ILO )
$ I = ILO - II
K = SCALE( I )
IF( K.EQ.I )
$ GO TO 40
CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
40 CONTINUE
END IF
*
IF( LEFTV ) THEN
DO 50 II = 1, N
I = II
IF( I.GE.ILO .AND. I.LE.IHI )
$ GO TO 50
IF( I.LT.ILO )
$ I = ILO - II
K = SCALE( I )
IF( K.EQ.I )
$ GO TO 50
CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
50 CONTINUE
END IF
END IF
*
RETURN
*
* End of DGEBAK
*
END
SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOB
INTEGER IHI, ILO, INFO, LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), SCALE( * )
* ..
*
* Purpose
* =======
*
* DGEBAL balances a general real matrix A. This involves, first,
* permuting A by a similarity transformation to isolate eigenvalues
* in the first 1 to ILO-1 and last IHI+1 to N elements on the
* diagonal; and second, applying a diagonal similarity transformation
* to rows and columns ILO to IHI to make the rows and columns as
* close in norm as possible. Both steps are optional.
*
* Balancing may reduce the 1-norm of the matrix, and improve the
* accuracy of the computed eigenvalues and/or eigenvectors.
*
* Arguments
* =========
*
* JOB (input) CHARACTER*1
* Specifies the operations to be performed on A:
* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0
* for i = 1,...,N;
* = 'P': permute only;
* = 'S': scale only;
* = 'B': both permute and scale.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the input matrix A.
* On exit, A is overwritten by the balanced matrix.
* If JOB = 'N', A is not referenced.
* See Further Details.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* ILO (output) INTEGER
* IHI (output) INTEGER
* ILO and IHI are set to integers such that on exit
* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.
* If JOB = 'N' or 'S', ILO = 1 and IHI = N.
*
* SCALE (output) DOUBLE PRECISION array, dimension (N)
* Details of the permutations and scaling factors applied to
* A. If P(j) is the index of the row and column interchanged
* with row and column j and D(j) is the scaling factor
* applied to row and column j, then
* SCALE(j) = P(j) for j = 1,...,ILO-1
* = D(j) for j = ILO,...,IHI
* = P(j) for j = IHI+1,...,N.
* The order in which the interchanges are made is N to IHI+1,
* then 1 to ILO-1.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* The permutations consist of row and column interchanges which put
* the matrix in the form
*
* ( T1 X Y )
* P A P = ( 0 B Z )
* ( 0 0 T2 )
*
* where T1 and T2 are upper triangular matrices whose eigenvalues lie
* along the diagonal. The column indices ILO and IHI mark the starting
* and ending columns of the submatrix B. Balancing consists of applying
* a diagonal similarity transformation inv(D) * B * D to make the
* 1-norms of each row of B and its corresponding column nearly equal.
* The output matrix is
*
* ( T1 X*D Y )
* ( 0 inv(D)*B*D inv(D)*Z ).
* ( 0 0 T2 )
*
* Information about the permutations P and the diagonal matrix D is
* returned in the vector SCALE.
*
* This subroutine is based on the EISPACK routine BALANC.
*
* Modified by Tzu-Yi Chen, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION SCLFAC
PARAMETER ( SCLFAC = 2.0D+0 )
DOUBLE PRECISION FACTOR
PARAMETER ( FACTOR = 0.95D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOCONV
INTEGER I, ICA, IEXC, IRA, J, K, L, M
DOUBLE PRECISION C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1,
$ SFMIN2
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, IDAMAX, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
$ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGEBAL', -INFO )
RETURN
END IF
*
K = 1
L = N
*
IF( N.EQ.0 )
$ GO TO 210
*
IF( LSAME( JOB, 'N' ) ) THEN
DO 10 I = 1, N
SCALE( I ) = ONE
10 CONTINUE
GO TO 210
END IF
*
IF( LSAME( JOB, 'S' ) )
$ GO TO 120
*
* Permutation to isolate eigenvalues if possible
*
GO TO 50
*
* Row and column exchange.
*
20 CONTINUE
SCALE( M ) = J
IF( J.EQ.M )
$ GO TO 30
*
CALL DSWAP( L, A( 1, J ), 1, A( 1, M ), 1 )
CALL DSWAP( N-K+1, A( J, K ), LDA, A( M, K ), LDA )
*
30 CONTINUE
GO TO ( 40, 80 )IEXC
*
* Search for rows isolating an eigenvalue and push them down.
*
40 CONTINUE
IF( L.EQ.1 )
$ GO TO 210
L = L - 1
*
50 CONTINUE
DO 70 J = L, 1, -1
*
DO 60 I = 1, L
IF( I.EQ.J )
$ GO TO 60
IF( A( J, I ).NE.ZERO )
$ GO TO 70
60 CONTINUE
*
M = L
IEXC = 1
GO TO 20
70 CONTINUE
*
GO TO 90
*
* Search for columns isolating an eigenvalue and push them left.
*
80 CONTINUE
K = K + 1
*
90 CONTINUE
DO 110 J = K, L
*
DO 100 I = K, L
IF( I.EQ.J )
$ GO TO 100
IF( A( I, J ).NE.ZERO )
$ GO TO 110
100 CONTINUE
*
M = K
IEXC = 2
GO TO 20
110 CONTINUE
*
120 CONTINUE
DO 130 I = K, L
SCALE( I ) = ONE
130 CONTINUE
*
IF( LSAME( JOB, 'P' ) )
$ GO TO 210
*
* Balance the submatrix in rows K to L.
*
* Iterative loop for norm reduction
*
SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' )
SFMAX1 = ONE / SFMIN1
SFMIN2 = SFMIN1*SCLFAC
SFMAX2 = ONE / SFMIN2
140 CONTINUE
NOCONV = .FALSE.
*
DO 200 I = K, L
C = ZERO
R = ZERO
*
DO 150 J = K, L
IF( J.EQ.I )
$ GO TO 150
C = C + ABS( A( J, I ) )
R = R + ABS( A( I, J ) )
150 CONTINUE
ICA = IDAMAX( L, A( 1, I ), 1 )
CA = ABS( A( ICA, I ) )
IRA = IDAMAX( N-K+1, A( I, K ), LDA )
RA = ABS( A( I, IRA+K-1 ) )
*
* Guard against zero C or R due to underflow.
*
IF( C.EQ.ZERO .OR. R.EQ.ZERO )
$ GO TO 200
G = R / SCLFAC
F = ONE
S = C + R
160 CONTINUE
IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR.
$ MIN( R, G, RA ).LE.SFMIN2 )GO TO 170
F = F*SCLFAC
C = C*SCLFAC
CA = CA*SCLFAC
R = R / SCLFAC
G = G / SCLFAC
RA = RA / SCLFAC
GO TO 160
*
170 CONTINUE
G = C / SCLFAC
180 CONTINUE
IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR.
$ MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 190
F = F / SCLFAC
C = C / SCLFAC
G = G / SCLFAC
CA = CA / SCLFAC
R = R*SCLFAC
RA = RA*SCLFAC
GO TO 180
*
* Now balance.
*
190 CONTINUE
IF( ( C+R ).GE.FACTOR*S )
$ GO TO 200
IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN
IF( F*SCALE( I ).LE.SFMIN1 )
$ GO TO 200
END IF
IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN
IF( SCALE( I ).GE.SFMAX1 / F )
$ GO TO 200
END IF
G = ONE / F
SCALE( I ) = SCALE( I )*F
NOCONV = .TRUE.
*
CALL DSCAL( N-K+1, G, A( I, K ), LDA )
CALL DSCAL( L, F, A( 1, I ), 1 )
*
200 CONTINUE
*
IF( NOCONV )
$ GO TO 140
*
210 CONTINUE
ILO = K
IHI = L
*
RETURN
*
* End of DGEBAL
*
END
SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ),
$ TAUQ( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGEBD2 reduces a real general m by n matrix A to upper or lower
* bidiagonal form B by an orthogonal transformation: Q' * A * P = B.
*
* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows in the matrix A. M >= 0.
*
* N (input) INTEGER
* The number of columns in the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the m by n general matrix to be reduced.
* On exit,
* if m >= n, the diagonal and the first superdiagonal are
* overwritten with the upper bidiagonal matrix B; the
* elements below the diagonal, with the array TAUQ, represent
* the orthogonal matrix Q as a product of elementary
* reflectors, and the elements above the first superdiagonal,
* with the array TAUP, represent the orthogonal matrix P as
* a product of elementary reflectors;
* if m < n, the diagonal and the first subdiagonal are
* overwritten with the lower bidiagonal matrix B; the
* elements below the first subdiagonal, with the array TAUQ,
* represent the orthogonal matrix Q as a product of
* elementary reflectors, and the elements above the diagonal,
* with the array TAUP, represent the orthogonal matrix P as
* a product of elementary reflectors.
* See Further Details.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* D (output) DOUBLE PRECISION array, dimension (min(M,N))
* The diagonal elements of the bidiagonal matrix B:
* D(i) = A(i,i).
*
* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)
* The off-diagonal elements of the bidiagonal matrix B:
* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
*
* TAUQ (output) DOUBLE PRECISION array dimension (min(M,N))
* The scalar factors of the elementary reflectors which
* represent the orthogonal matrix Q. See Further Details.
*
* TAUP (output) DOUBLE PRECISION array, dimension (min(M,N))
* The scalar factors of the elementary reflectors which
* represent the orthogonal matrix P. See Further Details.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (max(M,N))
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* The matrices Q and P are represented as products of elementary
* reflectors:
*
* If m >= n,
*
* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)
*
* Each H(i) and G(i) has the form:
*
* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
*
* where tauq and taup are real scalars, and v and u are real vectors;
* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);
* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);
* tauq is stored in TAUQ(i) and taup in TAUP(i).
*
* If m < n,
*
* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)
*
* Each H(i) and G(i) has the form:
*
* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
*
* where tauq and taup are real scalars, and v and u are real vectors;
* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
* tauq is stored in TAUQ(i) and taup in TAUP(i).
*
* The contents of A on exit are illustrated by the following examples:
*
* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
*
* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )
* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )
* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )
* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )
* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )
* ( v1 v2 v3 v4 v5 )
*
* where d and e denote diagonal and off-diagonal elements of B, vi
* denotes an element of the vector defining H(i), and ui an element of
* the vector defining G(i).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I
* ..
* .. External Subroutines ..
EXTERNAL DLARF, DLARFG, 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.LT.0 ) THEN
CALL XERBLA( 'DGEBD2', -INFO )
RETURN
END IF
*
IF( M.GE.N ) THEN
*
* Reduce to upper bidiagonal form
*
DO 10 I = 1, N
*
* 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,
$ TAUQ( I ) )
D( I ) = A( I, I )
A( I, I ) = ONE
*
* Apply H(i) to A(i:m,i+1:n) from the left
*
IF( I.LT.N )
$ CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAUQ( I ),
$ A( I, I+1 ), LDA, WORK )
A( I, I ) = D( I )
*
IF( I.LT.N ) THEN
*
* Generate elementary reflector G(i) to annihilate
* A(i,i+2:n)
*
CALL DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ),
$ LDA, TAUP( I ) )
E( I ) = A( I, I+1 )
A( I, I+1 ) = ONE
*
* Apply G(i) to A(i+1:m,i+1:n) from the right
*
CALL DLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA,
$ TAUP( I ), A( I+1, I+1 ), LDA, WORK )
A( I, I+1 ) = E( I )
ELSE
TAUP( I ) = ZERO
END IF
10 CONTINUE
ELSE
*
* Reduce to lower bidiagonal form
*
DO 20 I = 1, M
*
* Generate elementary reflector G(i) to annihilate A(i,i+1:n)
*
CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA,
$ TAUP( I ) )
D( I ) = A( I, I )
A( I, I ) = ONE
*
* Apply G(i) to A(i+1:m,i:n) from the right
*
IF( I.LT.M )
$ CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
$ TAUP( I ), A( I+1, I ), LDA, WORK )
A( I, I ) = D( I )
*
IF( I.LT.M ) THEN
*
* Generate elementary reflector H(i) to annihilate
* A(i+2:m,i)
*
CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1,
$ TAUQ( I ) )
E( I ) = A( I+1, I )
A( I+1, I ) = ONE
*
* Apply H(i) to A(i+1:m,i+1:n) from the left
*
CALL DLARF( 'Left', M-I, N-I, A( I+1, I ), 1, TAUQ( I ),
$ A( I+1, I+1 ), LDA, WORK )
A( I+1, I ) = E( I )
ELSE
TAUQ( I ) = ZERO
END IF
20 CONTINUE
END IF
RETURN
*
* End of DGEBD2
*
END
SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ),
$ TAUQ( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGEBRD reduces a general real M-by-N matrix A to upper or lower
* bidiagonal form B by an orthogonal transformation: Q**T * A * P = B.
*
* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows in the matrix A. M >= 0.
*
* N (input) INTEGER
* The number of columns in the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the M-by-N general matrix to be reduced.
* On exit,
* if m >= n, the diagonal and the first superdiagonal are
* overwritten with the upper bidiagonal matrix B; the
* elements below the diagonal, with the array TAUQ, represent
* the orthogonal matrix Q as a product of elementary
* reflectors, and the elements above the first superdiagonal,
* with the array TAUP, represent the orthogonal matrix P as
* a product of elementary reflectors;
* if m < n, the diagonal and the first subdiagonal are
* overwritten with the lower bidiagonal matrix B; the
* elements below the first subdiagonal, with the array TAUQ,
* represent the orthogonal matrix Q as a product of
* elementary reflectors, and the elements above the diagonal,
* with the array TAUP, represent the orthogonal matrix P as
* a product of elementary reflectors.
* See Further Details.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* D (output) DOUBLE PRECISION array, dimension (min(M,N))
* The diagonal elements of the bidiagonal matrix B:
* D(i) = A(i,i).
*
* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)
* The off-diagonal elements of the bidiagonal matrix B:
* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
*
* TAUQ (output) DOUBLE PRECISION array dimension (min(M,N))
* The scalar factors of the elementary reflectors which
* represent the orthogonal matrix Q. See Further Details.
*
* TAUP (output) DOUBLE PRECISION array, dimension (min(M,N))
* The scalar factors of the elementary reflectors which
* represent the orthogonal matrix P. 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 length of the array WORK. LWORK >= max(1,M,N).
* For optimum performance LWORK >= (M+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 matrices Q and P are represented as products of elementary
* reflectors:
*
* If m >= n,
*
* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)
*
* Each H(i) and G(i) has the form:
*
* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
*
* where tauq and taup are real scalars, and v and u are real vectors;
* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);
* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);
* tauq is stored in TAUQ(i) and taup in TAUP(i).
*
* If m < n,
*
* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)
*
* Each H(i) and G(i) has the form:
*
* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
*
* where tauq and taup are real scalars, and v and u are real vectors;
* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
* tauq is stored in TAUQ(i) and taup in TAUP(i).
*
* The contents of A on exit are illustrated by the following examples:
*
* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
*
* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )
* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )
* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )
* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )
* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )
* ( v1 v2 v3 v4 v5 )
*
* where d and e denote diagonal and off-diagonal elements of B, vi
* denotes an element of the vector defining H(i), and ui an element of
* the vector defining G(i).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB,
$ NBMIN, NX
DOUBLE PRECISION WS
* ..
* .. External Subroutines ..
EXTERNAL DGEBD2, DGEMM, DLABRD, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
NB = MAX( 1, ILAENV( 1, 'DGEBRD', ' ', M, N, -1, -1 ) )
LWKOPT = ( M+N )*NB
WORK( 1 ) = DBLE( 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, M, N ) .AND. .NOT.LQUERY ) THEN
INFO = -10
END IF
IF( INFO.LT.0 ) THEN
CALL XERBLA( 'DGEBRD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
MINMN = MIN( M, N )
IF( MINMN.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
WS = MAX( M, N )
LDWRKX = M
LDWRKY = N
*
IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN
*
* Set the crossover point NX.
*
NX = MAX( NB, ILAENV( 3, 'DGEBRD', ' ', M, N, -1, -1 ) )
*
* Determine when to switch from blocked to unblocked code.
*
IF( NX.LT.MINMN ) THEN
WS = ( M+N )*NB
IF( LWORK.LT.WS ) THEN
*
* Not enough work space for the optimal NB, consider using
* a smaller block size.
*
NBMIN = ILAENV( 2, 'DGEBRD', ' ', M, N, -1, -1 )
IF( LWORK.GE.( M+N )*NBMIN ) THEN
NB = LWORK / ( M+N )
ELSE
NB = 1
NX = MINMN
END IF
END IF
END IF
ELSE
NX = MINMN
END IF
*
DO 30 I = 1, MINMN - NX, NB
*
* Reduce rows and columns i:i+nb-1 to bidiagonal form and return
* the matrices X and Y which are needed to update the unreduced
* part of the matrix
*
CALL DLABRD( M-I+1, N-I+1, NB, A( I, I ), LDA, D( I ), E( I ),
$ TAUQ( I ), TAUP( I ), WORK, LDWRKX,
$ WORK( LDWRKX*NB+1 ), LDWRKY )
*
* Update the trailing submatrix A(i+nb:m,i+nb:n), using an update
* of the form A := A - V*Y' - X*U'
*
CALL DGEMM( 'No transpose', 'Transpose', M-I-NB+1, N-I-NB+1,
$ NB, -ONE, A( I+NB, I ), LDA,
$ WORK( LDWRKX*NB+NB+1 ), LDWRKY, ONE,
$ A( I+NB, I+NB ), LDA )
CALL DGEMM( 'No transpose', 'No transpose', M-I-NB+1, N-I-NB+1,
$ NB, -ONE, WORK( NB+1 ), LDWRKX, A( I, I+NB ), LDA,
$ ONE, A( I+NB, I+NB ), LDA )
*
* Copy diagonal and off-diagonal elements of B back into A
*
IF( M.GE.N ) THEN
DO 10 J = I, I + NB - 1
A( J, J ) = D( J )
A( J, J+1 ) = E( J )
10 CONTINUE
ELSE
DO 20 J = I, I + NB - 1
A( J, J ) = D( J )
A( J+1, J ) = E( J )
20 CONTINUE
END IF
30 CONTINUE
*
* Use unblocked code to reduce the remainder of the matrix
*
CALL DGEBD2( M-I+1, N-I+1, A( I, I ), LDA, D( I ), E( I ),
$ TAUQ( I ), TAUP( I ), WORK, IINFO )
WORK( 1 ) = WS
RETURN
*
* End of DGEBRD
*
END
SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER INFO, LDA, N
DOUBLE PRECISION ANORM, RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGECON estimates the reciprocal of the condition number of a general
* real matrix A, in either the 1-norm or the infinity-norm, using
* the LU factorization computed by DGETRF.
*
* An estimate is obtained for norm(inv(A)), and the reciprocal of the
* condition number is computed as
* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies whether the 1-norm condition number or the
* infinity-norm condition number is required:
* = '1' or 'O': 1-norm;
* = 'I': Infinity-norm.
*
* N (input) INTEGER
* The order of the matrix A. N >= 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).
*
* ANORM (input) DOUBLE PRECISION
* If NORM = '1' or 'O', the 1-norm of the original matrix A.
* If NORM = 'I', the infinity-norm of the original matrix A.
*
* RCOND (output) DOUBLE PRECISION
* The reciprocal of the condition number of the matrix A,
* computed as RCOND = 1/(norm(A) * norm(inv(A))).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL ONENRM
CHARACTER NORMIN
INTEGER IX, KASE, KASE1
DOUBLE PRECISION AINVNM, SCALE, SL, SMLNUM, SU
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, IDAMAX, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DLACN2, DLATRS, DRSCL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( ANORM.LT.ZERO ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGECON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
RCOND = ZERO
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
ELSE IF( ANORM.EQ.ZERO ) THEN
RETURN
END IF
*
SMLNUM = DLAMCH( 'Safe minimum' )
*
* Estimate the norm of inv(A).
*
AINVNM = ZERO
NORMIN = 'N'
IF( ONENRM ) THEN
KASE1 = 1
ELSE
KASE1 = 2
END IF
KASE = 0
10 CONTINUE
CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.KASE1 ) THEN
*
* Multiply by inv(L).
*
CALL DLATRS( 'Lower', 'No transpose', 'Unit', NORMIN, N, A,
$ LDA, WORK, SL, WORK( 2*N+1 ), INFO )
*
* Multiply by inv(U).
*
CALL DLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
$ A, LDA, WORK, SU, WORK( 3*N+1 ), INFO )
ELSE
*
* Multiply by inv(U').
*
CALL DLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, A,
$ LDA, WORK, SU, WORK( 3*N+1 ), INFO )
*
* Multiply by inv(L').
*
CALL DLATRS( 'Lower', 'Transpose', 'Unit', NORMIN, N, A,
$ LDA, WORK, SL, WORK( 2*N+1 ), INFO )
END IF
*
* Divide X by 1/(SL*SU) if doing so will not cause overflow.
*
SCALE = SL*SU
NORMIN = 'Y'
IF( SCALE.NE.ONE ) THEN
IX = IDAMAX( N, WORK, 1 )
IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
$ GO TO 20
CALL DRSCL( N, SCALE, WORK, 1 )
END IF
GO TO 10
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / AINVNM ) / ANORM
*
20 CONTINUE
RETURN
*
* End of DGECON
*
END
SUBROUTINE DGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, M, N
DOUBLE PRECISION AMAX, COLCND, ROWCND
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), C( * ), R( * )
* ..
*
* Purpose
* =======
*
* DGEEQU computes row and column scalings intended to equilibrate an
* M-by-N matrix A and reduce its condition number. R returns the row
* scale factors and C the column scale factors, chosen to try to make
* the largest element in each row and column of the matrix B with
* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
*
* R(i) and C(j) are restricted to be between SMLNUM = smallest safe
* number and BIGNUM = largest safe number. Use of these scaling
* factors is not guaranteed to reduce the condition number of A but
* works well in practice.
*
* 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) DOUBLE PRECISION array, dimension (LDA,N)
* The M-by-N matrix whose equilibration factors are
* to be computed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* R (output) DOUBLE PRECISION array, dimension (M)
* If INFO = 0 or INFO > M, R contains the row scale factors
* for A.
*
* C (output) DOUBLE PRECISION array, dimension (N)
* If INFO = 0, C contains the column scale factors for A.
*
* ROWCND (output) DOUBLE PRECISION
* If INFO = 0 or INFO > M, ROWCND contains the ratio of the
* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and
* AMAX is neither too large nor too small, it is not worth
* scaling by R.
*
* COLCND (output) DOUBLE PRECISION
* If INFO = 0, COLCND contains the ratio of the smallest
* C(i) to the largest C(i). If COLCND >= 0.1, it is not
* worth scaling by C.
*
* AMAX (output) DOUBLE PRECISION
* Absolute value of largest matrix element. If AMAX is very
* close to overflow or very close to underflow, the matrix
* should be scaled.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, and i is
* <= M: the i-th row of A is exactly zero
* > M: the (i-M)-th column of A is exactly zero
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION BIGNUM, RCMAX, RCMIN, SMLNUM
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, 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( 'DGEEQU', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
ROWCND = ONE
COLCND = ONE
AMAX = ZERO
RETURN
END IF
*
* Get machine constants.
*
SMLNUM = DLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
*
* Compute row scale factors.
*
DO 10 I = 1, M
R( I ) = ZERO
10 CONTINUE
*
* Find the maximum element in each row.
*
DO 30 J = 1, N
DO 20 I = 1, M
R( I ) = MAX( R( I ), ABS( A( I, J ) ) )
20 CONTINUE
30 CONTINUE
*
* Find the maximum and minimum scale factors.
*
RCMIN = BIGNUM
RCMAX = ZERO
DO 40 I = 1, M
RCMAX = MAX( RCMAX, R( I ) )
RCMIN = MIN( RCMIN, R( I ) )
40 CONTINUE
AMAX = RCMAX
*
IF( RCMIN.EQ.ZERO ) THEN
*
* Find the first zero scale factor and return an error code.
*
DO 50 I = 1, M
IF( R( I ).EQ.ZERO ) THEN
INFO = I
RETURN
END IF
50 CONTINUE
ELSE
*
* Invert the scale factors.
*
DO 60 I = 1, M
R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM )
60 CONTINUE
*
* Compute ROWCND = min(R(I)) / max(R(I))
*
ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
END IF
*
* Compute column scale factors
*
DO 70 J = 1, N
C( J ) = ZERO
70 CONTINUE
*
* Find the maximum element in each column,
* assuming the row scaling computed above.
*
DO 90 J = 1, N
DO 80 I = 1, M
C( J ) = MAX( C( J ), ABS( A( I, J ) )*R( I ) )
80 CONTINUE
90 CONTINUE
*
* Find the maximum and minimum scale factors.
*
RCMIN = BIGNUM
RCMAX = ZERO
DO 100 J = 1, N
RCMIN = MIN( RCMIN, C( J ) )
RCMAX = MAX( RCMAX, C( J ) )
100 CONTINUE
*
IF( RCMIN.EQ.ZERO ) THEN
*
* Find the first zero scale factor and return an error code.
*
DO 110 J = 1, N
IF( C( J ).EQ.ZERO ) THEN
INFO = M + J
RETURN
END IF
110 CONTINUE
ELSE
*
* Invert the scale factors.
*
DO 120 J = 1, N
C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM )
120 CONTINUE
*
* Compute COLCND = min(C(J)) / max(C(J))
*
COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
END IF
*
RETURN
*
* End of DGEEQU
*
END
SUBROUTINE DGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI,
$ VS, LDVS, WORK, LWORK, BWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBVS, SORT
INTEGER INFO, LDA, LDVS, LWORK, N, SDIM
* ..
* .. Array Arguments ..
LOGICAL BWORK( * )
DOUBLE PRECISION A( LDA, * ), VS( LDVS, * ), WI( * ), WORK( * ),
$ WR( * )
* ..
* .. Function Arguments ..
LOGICAL SELECT
EXTERNAL SELECT
* ..
*
* Purpose
* =======
*
* DGEES computes for an N-by-N real nonsymmetric matrix A, the
* eigenvalues, the real Schur form T, and, optionally, the matrix of
* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).
*
* Optionally, it also orders the eigenvalues on the diagonal of the
* real Schur form so that selected eigenvalues are at the top left.
* The leading columns of Z then form an orthonormal basis for the
* invariant subspace corresponding to the selected eigenvalues.
*
* A matrix is in real Schur form if it is upper quasi-triangular with
* 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the
* form
* [ a b ]
* [ c a ]
*
* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
*
* Arguments
* =========
*
* JOBVS (input) CHARACTER*1
* = 'N': Schur vectors are not computed;
* = 'V': Schur vectors are computed.
*
* SORT (input) CHARACTER*1
* Specifies whether or not to order the eigenvalues on the
* diagonal of the Schur form.
* = 'N': Eigenvalues are not ordered;
* = 'S': Eigenvalues are ordered (see SELECT).
*
* SELECT (external procedure) LOGICAL FUNCTION of two DOUBLE PRECISION arguments
* SELECT must be declared EXTERNAL in the calling subroutine.
* If SORT = 'S', SELECT is used to select eigenvalues to sort
* to the top left of the Schur form.
* If SORT = 'N', SELECT is not referenced.
* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if
* SELECT(WR(j),WI(j)) is true; i.e., if either one of a complex
* conjugate pair of eigenvalues is selected, then both complex
* eigenvalues are selected.
* Note that a selected complex eigenvalue may no longer
* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since
* ordering may change the value of complex eigenvalues
* (especially if the eigenvalue is ill-conditioned); in this
* case INFO is set to N+2 (see INFO below).
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the N-by-N matrix A.
* On exit, A has been overwritten by its real Schur form T.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* SDIM (output) INTEGER
* If SORT = 'N', SDIM = 0.
* If SORT = 'S', SDIM = number of eigenvalues (after sorting)
* for which SELECT is true. (Complex conjugate
* pairs for which SELECT is true for either
* eigenvalue count as 2.)
*
* WR (output) DOUBLE PRECISION array, dimension (N)
* WI (output) DOUBLE PRECISION array, dimension (N)
* WR and WI contain the real and imaginary parts,
* respectively, of the computed eigenvalues in the same order
* that they appear on the diagonal of the output Schur form T.
* Complex conjugate pairs of eigenvalues will appear
* consecutively with the eigenvalue having the positive
* imaginary part first.
*
* VS (output) DOUBLE PRECISION array, dimension (LDVS,N)
* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur
* vectors.
* If JOBVS = 'N', VS is not referenced.
*
* LDVS (input) INTEGER
* The leading dimension of the array VS. LDVS >= 1; if
* JOBVS = 'V', LDVS >= N.
*
* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
* On exit, if INFO = 0, WORK(1) contains the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK. LWORK >= max(1,3*N).
* For good performance, LWORK must generally be larger.
*
* 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.
*
* BWORK (workspace) LOGICAL array, dimension (N)
* Not referenced if SORT = 'N'.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = i, and i is
* <= N: the QR algorithm failed to compute all the
* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI
* contain those eigenvalues which have converged; if
* JOBVS = 'V', VS contains the matrix which reduces A
* to its partially converged Schur form.
* = N+1: the eigenvalues could not be reordered because some
* eigenvalues were too close to separate (the problem
* is very ill-conditioned);
* = N+2: after reordering, roundoff changed values of some
* complex eigenvalues so that leading eigenvalues in
* the Schur form no longer satisfy SELECT=.TRUE. This
* could also be caused by underflow due to scaling.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL CURSL, LASTSL, LQUERY, LST2SL, SCALEA, WANTST,
$ WANTVS
INTEGER HSWORK, I, I1, I2, IBAL, ICOND, IERR, IEVAL,
$ IHI, ILO, INXT, IP, ITAU, IWRK, MAXWRK, MINWRK
DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, S, SEP, SMLNUM
* ..
* .. Local Arrays ..
INTEGER IDUM( 1 )
DOUBLE PRECISION DUM( 1 )
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLACPY,
$ DLABAD, DLASCL, DORGHR, DSWAP, DTRSEN, XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
WANTVS = LSAME( JOBVS, 'V' )
WANTST = LSAME( SORT, 'S' )
IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN
INFO = -1
ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDVS.LT.1 .OR. ( WANTVS .AND. LDVS.LT.N ) ) THEN
INFO = -11
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.
* HSWORK refers to the workspace preferred by DHSEQR, as
* calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
* the worst case.)
*
IF( INFO.EQ.0 ) THEN
IF( N.EQ.0 ) THEN
MINWRK = 1
MAXWRK = 1
ELSE
MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 )
MINWRK = 3*N
*
CALL DHSEQR( 'S', JOBVS, N, 1, N, A, LDA, WR, WI, VS, LDVS,
$ WORK, -1, IEVAL )
HSWORK = WORK( 1 )
*
IF( .NOT.WANTVS ) THEN
MAXWRK = MAX( MAXWRK, N + HSWORK )
ELSE
MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1,
$ 'DORGHR', ' ', N, 1, N, -1 ) )
MAXWRK = MAX( MAXWRK, N + HSWORK )
END IF
END IF
WORK( 1 ) = MAXWRK
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGEES ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
SDIM = 0
RETURN
END IF
*
* Get machine constants
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
SMLNUM = SQRT( SMLNUM ) / EPS
BIGNUM = ONE / SMLNUM
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = DLANGE( 'M', N, N, A, LDA, DUM )
SCALEA = .FALSE.
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
SCALEA = .TRUE.
CSCALE = SMLNUM
ELSE IF( ANRM.GT.BIGNUM ) THEN
SCALEA = .TRUE.
CSCALE = BIGNUM
END IF
IF( SCALEA )
$ CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
*
* Permute the matrix to make it more nearly triangular
* (Workspace: need N)
*
IBAL = 1
CALL DGEBAL( 'P', N, A, LDA, ILO, IHI, WORK( IBAL ), IERR )
*
* Reduce to upper Hessenberg form
* (Workspace: need 3*N, prefer 2*N+N*NB)
*
ITAU = N + IBAL
IWRK = N + ITAU
CALL DGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
$ LWORK-IWRK+1, IERR )
*
IF( WANTVS ) THEN
*
* Copy Householder vectors to VS
*
CALL DLACPY( 'L', N, N, A, LDA, VS, LDVS )
*
* Generate orthogonal matrix in VS
* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB)
*
CALL DORGHR( N, ILO, IHI, VS, LDVS, WORK( ITAU ), WORK( IWRK ),
$ LWORK-IWRK+1, IERR )
END IF
*
SDIM = 0
*
* Perform QR iteration, accumulating Schur vectors in VS if desired
* (Workspace: need N+1, prefer N+HSWORK (see comments) )
*
IWRK = ITAU
CALL DHSEQR( 'S', JOBVS, N, ILO, IHI, A, LDA, WR, WI, VS, LDVS,
$ WORK( IWRK ), LWORK-IWRK+1, IEVAL )
IF( IEVAL.GT.0 )
$ INFO = IEVAL
*
* Sort eigenvalues if desired
*
IF( WANTST .AND. INFO.EQ.0 ) THEN
IF( SCALEA ) THEN
CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WR, N, IERR )
CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WI, N, IERR )
END IF
DO 10 I = 1, N
BWORK( I ) = SELECT( WR( I ), WI( I ) )
10 CONTINUE
*
* Reorder eigenvalues and transform Schur vectors
* (Workspace: none needed)
*
CALL DTRSEN( 'N', JOBVS, BWORK, N, A, LDA, VS, LDVS, WR, WI,
$ SDIM, S, SEP, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1,
$ ICOND )
IF( ICOND.GT.0 )
$ INFO = N + ICOND
END IF
*
IF( WANTVS ) THEN
*
* Undo balancing
* (Workspace: need N)
*
CALL DGEBAK( 'P', 'R', N, ILO, IHI, WORK( IBAL ), N, VS, LDVS,
$ IERR )
END IF
*
IF( SCALEA ) THEN
*
* Undo scaling for the Schur form of A
*
CALL DLASCL( 'H', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR )
CALL DCOPY( N, A, LDA+1, WR, 1 )
IF( CSCALE.EQ.SMLNUM ) THEN
*
* If scaling back towards underflow, adjust WI if an
* offdiagonal element of a 2-by-2 block in the Schur form
* underflows.
*
IF( IEVAL.GT.0 ) THEN
I1 = IEVAL + 1
I2 = IHI - 1
CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI,
$ MAX( ILO-1, 1 ), IERR )
ELSE IF( WANTST ) THEN
I1 = 1
I2 = N - 1
ELSE
I1 = ILO
I2 = IHI - 1
END IF
INXT = I1 - 1
DO 20 I = I1, I2
IF( I.LT.INXT )
$ GO TO 20
IF( WI( I ).EQ.ZERO ) THEN
INXT = I + 1
ELSE
IF( A( I+1, I ).EQ.ZERO ) THEN
WI( I ) = ZERO
WI( I+1 ) = ZERO
ELSE IF( A( I+1, I ).NE.ZERO .AND. A( I, I+1 ).EQ.
$ ZERO ) THEN
WI( I ) = ZERO
WI( I+1 ) = ZERO
IF( I.GT.1 )
$ CALL DSWAP( I-1, A( 1, I ), 1, A( 1, I+1 ), 1 )
IF( N.GT.I+1 )
$ CALL DSWAP( N-I-1, A( I, I+2 ), LDA,
$ A( I+1, I+2 ), LDA )
IF( WANTVS ) THEN
CALL DSWAP( N, VS( 1, I ), 1, VS( 1, I+1 ), 1 )
END IF
A( I, I+1 ) = A( I+1, I )
A( I+1, I ) = ZERO
END IF
INXT = I + 2
END IF
20 CONTINUE
END IF
*
* Undo scaling for the imaginary part of the eigenvalues
*
CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-IEVAL, 1,
$ WI( IEVAL+1 ), MAX( N-IEVAL, 1 ), IERR )
END IF
*
IF( WANTST .AND. INFO.EQ.0 ) THEN
*
* Check if reordering successful
*
LASTSL = .TRUE.
LST2SL = .TRUE.
SDIM = 0
IP = 0
DO 30 I = 1, N
CURSL = SELECT( WR( I ), WI( I ) )
IF( WI( I ).EQ.ZERO ) THEN
IF( CURSL )
$ SDIM = SDIM + 1
IP = 0
IF( CURSL .AND. .NOT.LASTSL )
$ INFO = N + 2
ELSE
IF( IP.EQ.1 ) THEN
*
* Last eigenvalue of conjugate pair
*
CURSL = CURSL .OR. LASTSL
LASTSL = CURSL
IF( CURSL )
$ SDIM = SDIM + 2
IP = -1
IF( CURSL .AND. .NOT.LST2SL )
$ INFO = N + 2
ELSE
*
* First eigenvalue of conjugate pair
*
IP = 1
END IF
END IF
LST2SL = LASTSL
LASTSL = CURSL
30 CONTINUE
END IF
*
WORK( 1 ) = MAXWRK
RETURN
*
* End of DGEES
*
END
SUBROUTINE DGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM,
$ WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK,
$ IWORK, LIWORK, BWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBVS, SENSE, SORT
INTEGER INFO, LDA, LDVS, LIWORK, LWORK, N, SDIM
DOUBLE PRECISION RCONDE, RCONDV
* ..
* .. Array Arguments ..
LOGICAL BWORK( * )
INTEGER IWORK( * )
DOUBLE PRECISION A( LDA, * ), VS( LDVS, * ), WI( * ), WORK( * ),
$ WR( * )
* ..
* .. Function Arguments ..
LOGICAL SELECT
EXTERNAL SELECT
* ..
*
* Purpose
* =======
*
* DGEESX computes for an N-by-N real nonsymmetric matrix A, the
* eigenvalues, the real Schur form T, and, optionally, the matrix of
* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).
*
* Optionally, it also orders the eigenvalues on the diagonal of the
* real Schur form so that selected eigenvalues are at the top left;
* computes a reciprocal condition number for the average of the
* selected eigenvalues (RCONDE); and computes a reciprocal condition
* number for the right invariant subspace corresponding to the
* selected eigenvalues (RCONDV). The leading columns of Z form an
* orthonormal basis for this invariant subspace.
*
* For further explanation of the reciprocal condition numbers RCONDE
* and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where
* these quantities are called s and sep respectively).
*
* A real matrix is in real Schur form if it is upper quasi-triangular
* with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in
* the form
* [ a b ]
* [ c a ]
*
* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
*
* Arguments
* =========
*
* JOBVS (input) CHARACTER*1
* = 'N': Schur vectors are not computed;
* = 'V': Schur vectors are computed.
*
* SORT (input) CHARACTER*1
* Specifies whether or not to order the eigenvalues on the
* diagonal of the Schur form.
* = 'N': Eigenvalues are not ordered;
* = 'S': Eigenvalues are ordered (see SELECT).
*
* SELECT (external procedure) LOGICAL FUNCTION of two DOUBLE PRECISION arguments
* SELECT must be declared EXTERNAL in the calling subroutine.
* If SORT = 'S', SELECT is used to select eigenvalues to sort
* to the top left of the Schur form.
* If SORT = 'N', SELECT is not referenced.
* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if
* SELECT(WR(j),WI(j)) is true; i.e., if either one of a
* complex conjugate pair of eigenvalues is selected, then both
* are. Note that a selected complex eigenvalue may no longer
* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since
* ordering may change the value of complex eigenvalues
* (especially if the eigenvalue is ill-conditioned); in this
* case INFO may be set to N+3 (see INFO below).
*
* SENSE (input) CHARACTER*1
* Determines which reciprocal condition numbers are computed.
* = 'N': None are computed;
* = 'E': Computed for average of selected eigenvalues only;
* = 'V': Computed for selected right invariant subspace only;
* = 'B': Computed for both.
* If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
* On entry, the N-by-N matrix A.
* On exit, A is overwritten by its real Schur form T.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* SDIM (output) INTEGER
* If SORT = 'N', SDIM = 0.
* If SORT = 'S', SDIM = number of eigenvalues (after sorting)
* for which SELECT is true. (Complex conjugate
* pairs for which SELECT is true for either
* eigenvalue count as 2.)
*
* WR (output) DOUBLE PRECISION array, dimension (N)
* WI (output) DOUBLE PRECISION array, dimension (N)
* WR and WI contain the real and imaginary parts, respectively,
* of the computed eigenvalues, in the same order that they
* appear on the diagonal of the output Schur form T. Complex
* conjugate pairs of eigenvalues appear consecutively with the
* eigenvalue having the positive imaginary part first.
*
* VS (output) DOUBLE PRECISION array, dimension (LDVS,N)
* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur
* vectors.
* If JOBVS = 'N', VS is not referenced.
*
* LDVS (input) INTEGER
* The leading dimension of the array VS. LDVS >= 1, and if
* JOBVS = 'V', LDVS >= N.
*
* RCONDE (output) DOUBLE PRECISION
* If SENSE = 'E' or 'B', RCONDE contains the reciprocal
* condition number for the average of the selected eigenvalues.
* Not referenced if SENSE = 'N' or 'V'.
*
* RCONDV (output) DOUBLE PRECISION
* If SENSE = 'V' or 'B', RCONDV contains the reciprocal
* condition number for the selected right invariant subspace.
* Not referenced if SENSE = 'N' or 'E'.
*
* 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,3*N).
* Also, if SENSE = 'E' or 'V' or 'B',
* LWORK >= N+2*SDIM*(N-SDIM), where SDIM is the number of
* selected eigenvalues computed by this routine. Note that
* N+2*SDIM*(N-SDIM) <= N+N*N/2. Note also that an error is only
* returned if LWORK < max(1,3*N), but if SENSE = 'E' or 'V' or
* 'B' this may not be large enough.
* For good performance, LWORK must generally be larger.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates upper bounds on the optimal sizes of the
* arrays WORK and IWORK, returns these values as the first
* entries of the WORK and IWORK arrays, and no error messages
* related to LWORK or LIWORK are issued by XERBLA.
*
* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK.
* LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM).
* Note that SDIM*(N-SDIM) <= N*N/4. Note also that an error is
* only returned if LIWORK < 1, but if SENSE = 'V' or 'B' this
* may not be large enough.
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates upper bounds on the optimal sizes of
* the arrays WORK and IWORK, returns these values as the first
* entries of the WORK and IWORK arrays, and no error messages
* related to LWORK or LIWORK are issued by XERBLA.
*
* BWORK (workspace) LOGICAL array, dimension (N)
* Not referenced if SORT = 'N'.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = i, and i is
* <= N: the QR algorithm failed to compute all the
* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI
* contain those eigenvalues which have converged; if
* JOBVS = 'V', VS contains the transformation which
* reduces A to its partially converged Schur form.
* = N+1: the eigenvalues could not be reordered because some
* eigenvalues were too close to separate (the problem
* is very ill-conditioned);
* = N+2: after reordering, roundoff changed values of some
* complex eigenvalues so that leading eigenvalues in
* the Schur form no longer satisfy SELECT=.TRUE. This
* could also be caused by underflow due to scaling.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL CURSL, LASTSL, LQUERY, LST2SL, SCALEA, WANTSB,
$ WANTSE, WANTSN, WANTST, WANTSV, WANTVS
INTEGER HSWORK, I, I1, I2, IBAL, ICOND, IERR, IEVAL,
$ IHI, ILO, INXT, IP, ITAU, IWRK, LIWRK, LWRK,
$ MAXWRK, MINWRK
DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SMLNUM
* ..
* .. Local Arrays ..
DOUBLE PRECISION DUM( 1 )
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLACPY,
$ DLASCL, DORGHR, DSWAP, DTRSEN, XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL LSAME, ILAENV, DLABAD, DLAMCH, DLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
WANTVS = LSAME( JOBVS, 'V' )
WANTST = LSAME( SORT, 'S' )
WANTSN = LSAME( SENSE, 'N' )
WANTSE = LSAME( SENSE, 'E' )
WANTSV = LSAME( SENSE, 'V' )
WANTSB = LSAME( SENSE, 'B' )
LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN
INFO = -1
ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
INFO = -2
ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSV .OR. WANTSB ) .OR.
$ ( .NOT.WANTST .AND. .NOT.WANTSN ) ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDVS.LT.1 .OR. ( WANTVS .AND. LDVS.LT.N ) ) THEN
INFO = -12
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "RWorkspace:" describe the
* minimal amount of real workspace needed at that point in the
* code, as well as the preferred amount for good performance.
* IWorkspace refers to integer workspace.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.
* HSWORK refers to the workspace preferred by DHSEQR, as
* calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
* the worst case.
* If SENSE = 'E', 'V' or 'B', then the amount of workspace needed
* depends on SDIM, which is computed by the routine DTRSEN later
* in the code.)
*
IF( INFO.EQ.0 ) THEN
LIWRK = 1
IF( N.EQ.0 ) THEN
MINWRK = 1
LWRK = 1
ELSE
MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 )
MINWRK = 3*N
*
CALL DHSEQR( 'S', JOBVS, N, 1, N, A, LDA, WR, WI, VS, LDVS,
$ WORK, -1, IEVAL )
HSWORK = WORK( 1 )
*
IF( .NOT.WANTVS ) THEN
MAXWRK = MAX( MAXWRK, N + HSWORK )
ELSE
MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1,
$ 'DORGHR', ' ', N, 1, N, -1 ) )
MAXWRK = MAX( MAXWRK, N + HSWORK )
END IF
LWRK = MAXWRK
IF( .NOT.WANTSN )
$ LWRK = MAX( LWRK, N + ( N*N )/2 )
IF( WANTSV .OR. WANTSB )
$ LIWRK = ( N*N )/4
END IF
IWORK( 1 ) = LIWRK
WORK( 1 ) = LWRK
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
INFO = -16
ELSE IF( LIWORK.LT.1 .AND. .NOT.LQUERY ) THEN
INFO = -18
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGEESX', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
SDIM = 0
RETURN
END IF
*
* Get machine constants
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
SMLNUM = SQRT( SMLNUM ) / EPS
BIGNUM = ONE / SMLNUM
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = DLANGE( 'M', N, N, A, LDA, DUM )
SCALEA = .FALSE.
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
SCALEA = .TRUE.
CSCALE = SMLNUM
ELSE IF( ANRM.GT.BIGNUM ) THEN
SCALEA = .TRUE.
CSCALE = BIGNUM
END IF
IF( SCALEA )
$ CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
*
* Permute the matrix to make it more nearly triangular
* (RWorkspace: need N)
*
IBAL = 1
CALL DGEBAL( 'P', N, A, LDA, ILO, IHI, WORK( IBAL ), IERR )
*
* Reduce to upper Hessenberg form
* (RWorkspace: need 3*N, prefer 2*N+N*NB)
*
ITAU = N + IBAL
IWRK = N + ITAU
CALL DGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
$ LWORK-IWRK+1, IERR )
*
IF( WANTVS ) THEN
*
* Copy Householder vectors to VS
*
CALL DLACPY( 'L', N, N, A, LDA, VS, LDVS )
*
* Generate orthogonal matrix in VS
* (RWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
*
CALL DORGHR( N, ILO, IHI, VS, LDVS, WORK( ITAU ), WORK( IWRK ),
$ LWORK-IWRK+1, IERR )
END IF
*
SDIM = 0
*
* Perform QR iteration, accumulating Schur vectors in VS if desired
* (RWorkspace: need N+1, prefer N+HSWORK (see comments) )
*
IWRK = ITAU
CALL DHSEQR( 'S', JOBVS, N, ILO, IHI, A, LDA, WR, WI, VS, LDVS,
$ WORK( IWRK ), LWORK-IWRK+1, IEVAL )
IF( IEVAL.GT.0 )
$ INFO = IEVAL
*
* Sort eigenvalues if desired
*
IF( WANTST .AND. INFO.EQ.0 ) THEN
IF( SCALEA ) THEN
CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WR, N, IERR )
CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WI, N, IERR )
END IF
DO 10 I = 1, N
BWORK( I ) = SELECT( WR( I ), WI( I ) )
10 CONTINUE
*
* Reorder eigenvalues, transform Schur vectors, and compute
* reciprocal condition numbers
* (RWorkspace: if SENSE is not 'N', need N+2*SDIM*(N-SDIM)
* otherwise, need N )
* (IWorkspace: if SENSE is 'V' or 'B', need SDIM*(N-SDIM)
* otherwise, need 0 )
*
CALL DTRSEN( SENSE, JOBVS, BWORK, N, A, LDA, VS, LDVS, WR, WI,
$ SDIM, RCONDE, RCONDV, WORK( IWRK ), LWORK-IWRK+1,
$ IWORK, LIWORK, ICOND )
IF( .NOT.WANTSN )
$ MAXWRK = MAX( MAXWRK, N+2*SDIM*( N-SDIM ) )
IF( ICOND.EQ.-15 ) THEN
*
* Not enough real workspace
*
INFO = -16
ELSE IF( ICOND.EQ.-17 ) THEN
*
* Not enough integer workspace
*
INFO = -18
ELSE IF( ICOND.GT.0 ) THEN
*
* DTRSEN failed to reorder or to restore standard Schur form
*
INFO = ICOND + N
END IF
END IF
*
IF( WANTVS ) THEN
*
* Undo balancing
* (RWorkspace: need N)
*
CALL DGEBAK( 'P', 'R', N, ILO, IHI, WORK( IBAL ), N, VS, LDVS,
$ IERR )
END IF
*
IF( SCALEA ) THEN
*
* Undo scaling for the Schur form of A
*
CALL DLASCL( 'H', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR )
CALL DCOPY( N, A, LDA+1, WR, 1 )
IF( ( WANTSV .OR. WANTSB ) .AND. INFO.EQ.0 ) THEN
DUM( 1 ) = RCONDV
CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, 1, 1, DUM, 1, IERR )
RCONDV = DUM( 1 )
END IF
IF( CSCALE.EQ.SMLNUM ) THEN
*
* If scaling back towards underflow, adjust WI if an
* offdiagonal element of a 2-by-2 block in the Schur form
* underflows.
*
IF( IEVAL.GT.0 ) THEN
I1 = IEVAL + 1
I2 = IHI - 1
CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N,
$ IERR )
ELSE IF( WANTST ) THEN
I1 = 1
I2 = N - 1
ELSE
I1 = ILO
I2 = IHI - 1
END IF
INXT = I1 - 1
DO 20 I = I1, I2
IF( I.LT.INXT )
$ GO TO 20
IF( WI( I ).EQ.ZERO ) THEN
INXT = I + 1
ELSE
IF( A( I+1, I ).EQ.ZERO ) THEN
WI( I ) = ZERO
WI( I+1 ) = ZERO
ELSE IF( A( I+1, I ).NE.ZERO .AND. A( I, I+1 ).EQ.
$ ZERO ) THEN
WI( I ) = ZERO
WI( I+1 ) = ZERO
IF( I.GT.1 )
$ CALL DSWAP( I-1, A( 1, I ), 1, A( 1, I+1 ), 1 )
IF( N.GT.I+1 )
$ CALL DSWAP( N-I-1, A( I, I+2 ), LDA,
$ A( I+1, I+2 ), LDA )
CALL DSWAP( N, VS( 1, I ), 1, VS( 1, I+1 ), 1 )
A( I, I+1 ) = A( I+1, I )
A( I+1, I ) = ZERO
END IF
INXT = I + 2
END IF
20 CONTINUE
END IF
CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-IEVAL, 1,
$ WI( IEVAL+1 ), MAX( N-IEVAL, 1 ), IERR )
END IF
*
IF( WANTST .AND. INFO.EQ.0 ) THEN
*
* Check if reordering successful
*
LASTSL = .TRUE.
LST2SL = .TRUE.
SDIM = 0
IP = 0
DO 30 I = 1, N
CURSL = SELECT( WR( I ), WI( I ) )
IF( WI( I ).EQ.ZERO ) THEN
IF( CURSL )
$ SDIM = SDIM + 1
IP = 0
IF( CURSL .AND. .NOT.LASTSL )
$ INFO = N + 2
ELSE
IF( IP.EQ.1 ) THEN
*
* Last eigenvalue of conjugate pair
*
CURSL = CURSL .OR. LASTSL
LASTSL = CURSL
IF( CURSL )
$ SDIM = SDIM + 2
IP = -1
IF( CURSL .AND. .NOT.LST2SL )
$ INFO = N + 2
ELSE
*
* First eigenvalue of conjugate pair
*
IP = 1
END IF
END IF
LST2SL = LASTSL
LASTSL = CURSL
30 CONTINUE
END IF
*
WORK( 1 ) = MAXWRK
IF( WANTSV .OR. WANTSB ) THEN
IWORK( 1 ) = MAX( 1, SDIM*( N-SDIM ) )
ELSE
IWORK( 1 ) = 1
END IF
*
RETURN
*
* End of DGEESX
*
END
SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR,
$ LDVR, WORK, LWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBVL, JOBVR
INTEGER INFO, LDA, LDVL, LDVR, LWORK, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ),
$ WI( * ), WORK( * ), WR( * )
* ..
*
* Purpose
* =======
*
* DGEEV computes for an N-by-N real nonsymmetric matrix A, the
* eigenvalues and, optionally, the left and/or right eigenvectors.
*
* The right eigenvector v(j) of A satisfies
* A * v(j) = lambda(j) * v(j)
* where lambda(j) is its eigenvalue.
* The left eigenvector u(j) of A satisfies
* u(j)**H * A = lambda(j) * u(j)**H
* where u(j)**H denotes the conjugate transpose of u(j).
*
* The computed eigenvectors are normalized to have Euclidean norm
* equal to 1 and largest component real.
*
* Arguments
* =========
*
* JOBVL (input) CHARACTER*1
* = 'N': left eigenvectors of A are not computed;
* = 'V': left eigenvectors of A are computed.
*
* JOBVR (input) CHARACTER*1
* = 'N': right eigenvectors of A are not computed;
* = 'V': right eigenvectors of A are computed.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the N-by-N matrix A.
* On exit, A has been overwritten.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* WR (output) DOUBLE PRECISION array, dimension (N)
* WI (output) DOUBLE PRECISION array, dimension (N)
* WR and WI contain the real and imaginary parts,
* respectively, of the computed eigenvalues. Complex
* conjugate pairs of eigenvalues appear consecutively
* with the eigenvalue having the positive imaginary part
* first.
*
* VL (output) DOUBLE PRECISION array, dimension (LDVL,N)
* If JOBVL = 'V', the left eigenvectors u(j) are stored one
* after another in the columns of VL, in the same order
* as their eigenvalues.
* If JOBVL = 'N', VL is not referenced.
* If the j-th eigenvalue is real, then u(j) = VL(:,j),
* the j-th column of VL.
* If the j-th and (j+1)-st eigenvalues form a complex
* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and
* u(j+1) = VL(:,j) - i*VL(:,j+1).
*
* LDVL (input) INTEGER
* The leading dimension of the array VL. LDVL >= 1; if
* JOBVL = 'V', LDVL >= N.
*
* VR (output) DOUBLE PRECISION array, dimension (LDVR,N)
* If JOBVR = 'V', the right eigenvectors v(j) are stored one
* after another in the columns of VR, in the same order
* as their eigenvalues.
* If JOBVR = 'N', VR is not referenced.
* If the j-th eigenvalue is real, then v(j) = VR(:,j),
* the j-th column of VR.
* If the j-th and (j+1)-st eigenvalues form a complex
* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and
* v(j+1) = VR(:,j) - i*VR(:,j+1).
*
* LDVR (input) INTEGER
* The leading dimension of the array VR. LDVR >= 1; if
* JOBVR = 'V', LDVR >= N.
*
* 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,3*N), and
* if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good
* performance, LWORK must generally be larger.
*
* 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.
* > 0: if INFO = i, the QR algorithm failed to compute all the
* eigenvalues, and no eigenvectors have been computed;
* elements i+1:N of WR and WI contain eigenvalues which
* have converged.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, SCALEA, WANTVL, WANTVR
CHARACTER SIDE
INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, ITAU, IWRK, K,
$ MAXWRK, MINWRK, NOUT
DOUBLE PRECISION ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM,
$ SN
* ..
* .. Local Arrays ..
LOGICAL SELECT( 1 )
DOUBLE PRECISION DUM( 1 )
* ..
* .. External Subroutines ..
EXTERNAL DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLABAD, DLACPY,
$ DLARTG, DLASCL, DORGHR, DROT, DSCAL, DTREVC,
$ XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX, ILAENV
DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2, DNRM2
EXTERNAL LSAME, IDAMAX, ILAENV, DLAMCH, DLANGE, DLAPY2,
$ DNRM2
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
WANTVL = LSAME( JOBVL, 'V' )
WANTVR = LSAME( JOBVR, 'V' )
IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN
INFO = -1
ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN
INFO = -9
ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN
INFO = -11
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.
* HSWORK refers to the workspace preferred by DHSEQR, as
* calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
* the worst case.)
*
IF( INFO.EQ.0 ) THEN
IF( N.EQ.0 ) THEN
MINWRK = 1
MAXWRK = 1
ELSE
MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 )
IF( WANTVL ) THEN
MINWRK = 4*N
MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1,
$ 'DORGHR', ' ', N, 1, N, -1 ) )
CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VL, LDVL,
$ WORK, -1, INFO )
HSWORK = WORK( 1 )
MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK )
MAXWRK = MAX( MAXWRK, 4*N )
ELSE IF( WANTVR ) THEN
MINWRK = 4*N
MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1,
$ 'DORGHR', ' ', N, 1, N, -1 ) )
CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VR, LDVR,
$ WORK, -1, INFO )
HSWORK = WORK( 1 )
MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK )
MAXWRK = MAX( MAXWRK, 4*N )
ELSE
MINWRK = 3*N
CALL DHSEQR( 'E', 'N', N, 1, N, A, LDA, WR, WI, VR, LDVR,
$ WORK, -1, INFO )
HSWORK = WORK( 1 )
MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK )
END IF
MAXWRK = MAX( MAXWRK, MINWRK )
END IF
WORK( 1 ) = MAXWRK
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGEEV ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Get machine constants
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
SMLNUM = SQRT( SMLNUM ) / EPS
BIGNUM = ONE / SMLNUM
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = DLANGE( 'M', N, N, A, LDA, DUM )
SCALEA = .FALSE.
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
SCALEA = .TRUE.
CSCALE = SMLNUM
ELSE IF( ANRM.GT.BIGNUM ) THEN
SCALEA = .TRUE.
CSCALE = BIGNUM
END IF
IF( SCALEA )
$ CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
*
* Balance the matrix
* (Workspace: need N)
*
IBAL = 1
CALL DGEBAL( 'B', N, A, LDA, ILO, IHI, WORK( IBAL ), IERR )
*
* Reduce to upper Hessenberg form
* (Workspace: need 3*N, prefer 2*N+N*NB)
*
ITAU = IBAL + N
IWRK = ITAU + N
CALL DGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
$ LWORK-IWRK+1, IERR )
*
IF( WANTVL ) THEN
*
* Want left eigenvectors
* Copy Householder vectors to VL
*
SIDE = 'L'
CALL DLACPY( 'L', N, N, A, LDA, VL, LDVL )
*
* Generate orthogonal matrix in VL
* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB)
*
CALL DORGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ),
$ LWORK-IWRK+1, IERR )
*
* Perform QR iteration, accumulating Schur vectors in VL
* (Workspace: need N+1, prefer N+HSWORK (see comments) )
*
IWRK = ITAU
CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VL, LDVL,
$ WORK( IWRK ), LWORK-IWRK+1, INFO )
*
IF( WANTVR ) THEN
*
* Want left and right eigenvectors
* Copy Schur vectors to VR
*
SIDE = 'B'
CALL DLACPY( 'F', N, N, VL, LDVL, VR, LDVR )
END IF
*
ELSE IF( WANTVR ) THEN
*
* Want right eigenvectors
* Copy Householder vectors to VR
*
SIDE = 'R'
CALL DLACPY( 'L', N, N, A, LDA, VR, LDVR )
*
* Generate orthogonal matrix in VR
* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB)
*
CALL DORGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ),
$ LWORK-IWRK+1, IERR )
*
* Perform QR iteration, accumulating Schur vectors in VR
* (Workspace: need N+1, prefer N+HSWORK (see comments) )
*
IWRK = ITAU
CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR,
$ WORK( IWRK ), LWORK-IWRK+1, INFO )
*
ELSE
*
* Compute eigenvalues only
* (Workspace: need N+1, prefer N+HSWORK (see comments) )
*
IWRK = ITAU
CALL DHSEQR( 'E', 'N', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR,
$ WORK( IWRK ), LWORK-IWRK+1, INFO )
END IF
*
* If INFO > 0 from DHSEQR, then quit
*
IF( INFO.GT.0 )
$ GO TO 50
*
IF( WANTVL .OR. WANTVR ) THEN
*
* Compute left and/or right eigenvectors
* (Workspace: need 4*N)
*
CALL DTREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
$ N, NOUT, WORK( IWRK ), IERR )
END IF
*
IF( WANTVL ) THEN
*
* Undo balancing of left eigenvectors
* (Workspace: need N)
*
CALL DGEBAK( 'B', 'L', N, ILO, IHI, WORK( IBAL ), N, VL, LDVL,
$ IERR )
*
* Normalize left eigenvectors and make largest component real
*
DO 20 I = 1, N
IF( WI( I ).EQ.ZERO ) THEN
SCL = ONE / DNRM2( N, VL( 1, I ), 1 )
CALL DSCAL( N, SCL, VL( 1, I ), 1 )
ELSE IF( WI( I ).GT.ZERO ) THEN
SCL = ONE / DLAPY2( DNRM2( N, VL( 1, I ), 1 ),
$ DNRM2( N, VL( 1, I+1 ), 1 ) )
CALL DSCAL( N, SCL, VL( 1, I ), 1 )
CALL DSCAL( N, SCL, VL( 1, I+1 ), 1 )
DO 10 K = 1, N
WORK( IWRK+K-1 ) = VL( K, I )**2 + VL( K, I+1 )**2
10 CONTINUE
K = IDAMAX( N, WORK( IWRK ), 1 )
CALL DLARTG( VL( K, I ), VL( K, I+1 ), CS, SN, R )
CALL DROT( N, VL( 1, I ), 1, VL( 1, I+1 ), 1, CS, SN )
VL( K, I+1 ) = ZERO
END IF
20 CONTINUE
END IF
*
IF( WANTVR ) THEN
*
* Undo balancing of right eigenvectors
* (Workspace: need N)
*
CALL DGEBAK( 'B', 'R', N, ILO, IHI, WORK( IBAL ), N, VR, LDVR,
$ IERR )
*
* Normalize right eigenvectors and make largest component real
*
DO 40 I = 1, N
IF( WI( I ).EQ.ZERO ) THEN
SCL = ONE / DNRM2( N, VR( 1, I ), 1 )
CALL DSCAL( N, SCL, VR( 1, I ), 1 )
ELSE IF( WI( I ).GT.ZERO ) THEN
SCL = ONE / DLAPY2( DNRM2( N, VR( 1, I ), 1 ),
$ DNRM2( N, VR( 1, I+1 ), 1 ) )
CALL DSCAL( N, SCL, VR( 1, I ), 1 )
CALL DSCAL( N, SCL, VR( 1, I+1 ), 1 )
DO 30 K = 1, N
WORK( IWRK+K-1 ) = VR( K, I )**2 + VR( K, I+1 )**2
30 CONTINUE
K = IDAMAX( N, WORK( IWRK ), 1 )
CALL DLARTG( VR( K, I ), VR( K, I+1 ), CS, SN, R )
CALL DROT( N, VR( 1, I ), 1, VR( 1, I+1 ), 1, CS, SN )
VR( K, I+1 ) = ZERO
END IF
40 CONTINUE
END IF
*
* Undo scaling if necessary
*
50 CONTINUE
IF( SCALEA ) THEN
CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WR( INFO+1 ),
$ MAX( N-INFO, 1 ), IERR )
CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WI( INFO+1 ),
$ MAX( N-INFO, 1 ), IERR )
IF( INFO.GT.0 ) THEN
CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WR, N,
$ IERR )
CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N,
$ IERR )
END IF
END IF
*
WORK( 1 ) = MAXWRK
RETURN
*
* End of DGEEV
*
END
SUBROUTINE DGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI,
$ VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM,
$ RCONDE, RCONDV, WORK, LWORK, IWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER BALANC, JOBVL, JOBVR, SENSE
INTEGER IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N
DOUBLE PRECISION ABNRM
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION A( LDA, * ), RCONDE( * ), RCONDV( * ),
$ SCALE( * ), VL( LDVL, * ), VR( LDVR, * ),
$ WI( * ), WORK( * ), WR( * )
* ..
*
* Purpose
* =======
*
* DGEEVX computes for an N-by-N real nonsymmetric matrix A, the
* eigenvalues and, optionally, the left and/or right eigenvectors.
*
* Optionally also, it computes a balancing transformation to improve
* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
* (RCONDE), and reciprocal condition numbers for the right
* eigenvectors (RCONDV).
*
* The right eigenvector v(j) of A satisfies
* A * v(j) = lambda(j) * v(j)
* where lambda(j) is its eigenvalue.
* The left eigenvector u(j) of A satisfies
* u(j)**H * A = lambda(j) * u(j)**H
* where u(j)**H denotes the conjugate transpose of u(j).
*
* The computed eigenvectors are normalized to have Euclidean norm
* equal to 1 and largest component real.
*
* Balancing a matrix means permuting the rows and columns to make it
* more nearly upper triangular, and applying a diagonal similarity
* transformation D * A * D**(-1), where D is a diagonal matrix, to
* make its rows and columns closer in norm and the condition numbers
* of its eigenvalues and eigenvectors smaller. The computed
* reciprocal condition numbers correspond to the balanced matrix.
* Permuting rows and columns will not change the condition numbers
* (in exact arithmetic) but diagonal scaling will. For further
* explanation of balancing, see section 4.10.2 of the LAPACK
* Users' Guide.
*
* Arguments
* =========
*
* BALANC (input) CHARACTER*1
* Indicates how the input matrix should be diagonally scaled
* and/or permuted to improve the conditioning of its
* eigenvalues.
* = 'N': Do not diagonally scale or permute;
* = 'P': Perform permutations to make the matrix more nearly
* upper triangular. Do not diagonally scale;
* = 'S': Diagonally scale the matrix, i.e. replace A by
* D*A*D**(-1), where D is a diagonal matrix chosen
* to make the rows and columns of A more equal in
* norm. Do not permute;
* = 'B': Both diagonally scale and permute A.
*
* Computed reciprocal condition numbers will be for the matrix
* after balancing and/or permuting. Permuting does not change
* condition numbers (in exact arithmetic), but balancing does.
*
* JOBVL (input) CHARACTER*1
* = 'N': left eigenvectors of A are not computed;
* = 'V': left eigenvectors of A are computed.
* If SENSE = 'E' or 'B', JOBVL must = 'V'.
*
* JOBVR (input) CHARACTER*1
* = 'N': right eigenvectors of A are not computed;
* = 'V': right eigenvectors of A are computed.
* If SENSE = 'E' or 'B', JOBVR must = 'V'.
*
* SENSE (input) CHARACTER*1
* Determines which reciprocal condition numbers are computed.
* = 'N': None are computed;
* = 'E': Computed for eigenvalues only;
* = 'V': Computed for right eigenvectors only;
* = 'B': Computed for eigenvalues and right eigenvectors.
*
* If SENSE = 'E' or 'B', both left and right eigenvectors
* must also be computed (JOBVL = 'V' and JOBVR = 'V').
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the N-by-N matrix A.
* On exit, A has been overwritten. If JOBVL = 'V' or
* JOBVR = 'V', A contains the real Schur form of the balanced
* version of the input matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* WR (output) DOUBLE PRECISION array, dimension (N)
* WI (output) DOUBLE PRECISION array, dimension (N)
* WR and WI contain the real and imaginary parts,
* respectively, of the computed eigenvalues. Complex
* conjugate pairs of eigenvalues will appear consecutively
* with the eigenvalue having the positive imaginary part
* first.
*
* VL (output) DOUBLE PRECISION array, dimension (LDVL,N)
* If JOBVL = 'V', the left eigenvectors u(j) are stored one
* after another in the columns of VL, in the same order
* as their eigenvalues.
* If JOBVL = 'N', VL is not referenced.
* If the j-th eigenvalue is real, then u(j) = VL(:,j),
* the j-th column of VL.
* If the j-th and (j+1)-st eigenvalues form a complex
* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and
* u(j+1) = VL(:,j) - i*VL(:,j+1).
*
* LDVL (input) INTEGER
* The leading dimension of the array VL. LDVL >= 1; if
* JOBVL = 'V', LDVL >= N.
*
* VR (output) DOUBLE PRECISION array, dimension (LDVR,N)
* If JOBVR = 'V', the right eigenvectors v(j) are stored one
* after another in the columns of VR, in the same order
* as their eigenvalues.
* If JOBVR = 'N', VR is not referenced.
* If the j-th eigenvalue is real, then v(j) = VR(:,j),
* the j-th column of VR.
* If the j-th and (j+1)-st eigenvalues form a complex
* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and
* v(j+1) = VR(:,j) - i*VR(:,j+1).
*
* LDVR (input) INTEGER
* The leading dimension of the array VR. LDVR >= 1, and if
* JOBVR = 'V', LDVR >= N.
*
* ILO (output) INTEGER
* IHI (output) INTEGER
* ILO and IHI are integer values determined when A was
* balanced. The balanced A(i,j) = 0 if I > J and
* J = 1,...,ILO-1 or I = IHI+1,...,N.
*
* SCALE (output) DOUBLE PRECISION array, dimension (N)
* Details of the permutations and scaling factors applied
* when balancing A. If P(j) is the index of the row and column
* interchanged with row and column j, and D(j) is the scaling
* factor applied to row and column j, then
* SCALE(J) = P(J), for J = 1,...,ILO-1
* = D(J), for J = ILO,...,IHI
* = P(J) for J = IHI+1,...,N.
* The order in which the interchanges are made is N to IHI+1,
* then 1 to ILO-1.
*
* ABNRM (output) DOUBLE PRECISION
* The one-norm of the balanced matrix (the maximum
* of the sum of absolute values of elements of any column).
*
* RCONDE (output) DOUBLE PRECISION array, dimension (N)
* RCONDE(j) is the reciprocal condition number of the j-th
* eigenvalue.
*
* RCONDV (output) DOUBLE PRECISION array, dimension (N)
* RCONDV(j) is the reciprocal condition number of the j-th
* right eigenvector.
*
* 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 SENSE = 'N' or 'E',
* LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V',
* LWORK >= 3*N. If SENSE = 'V' or 'B', LWORK >= N*(N+6).
* For good performance, LWORK must generally be larger.
*
* 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.
*
* IWORK (workspace) INTEGER array, dimension (2*N-2)
* If SENSE = 'N' or 'E', not referenced.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = i, the QR algorithm failed to compute all the
* eigenvalues, and no eigenvectors or condition numbers
* have been computed; elements 1:ILO-1 and i+1:N of WR
* and WI contain eigenvalues which have converged.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, SCALEA, WANTVL, WANTVR, WNTSNB, WNTSNE,
$ WNTSNN, WNTSNV
CHARACTER JOB, SIDE
INTEGER HSWORK, I, ICOND, IERR, ITAU, IWRK, K, MAXWRK,
$ MINWRK, NOUT
DOUBLE PRECISION ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM,
$ SN
* ..
* .. Local Arrays ..
LOGICAL SELECT( 1 )
DOUBLE PRECISION DUM( 1 )
* ..
* .. External Subroutines ..
EXTERNAL DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLABAD, DLACPY,
$ DLARTG, DLASCL, DORGHR, DROT, DSCAL, DTREVC,
$ DTRSNA, XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX, ILAENV
DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2, DNRM2
EXTERNAL LSAME, IDAMAX, ILAENV, DLAMCH, DLANGE, DLAPY2,
$ DNRM2
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
WANTVL = LSAME( JOBVL, 'V' )
WANTVR = LSAME( JOBVR, 'V' )
WNTSNN = LSAME( SENSE, 'N' )
WNTSNE = LSAME( SENSE, 'E' )
WNTSNV = LSAME( SENSE, 'V' )
WNTSNB = LSAME( SENSE, 'B' )
IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LSAME( BALANC,
$ 'S' ) .OR. LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) ) )
$ THEN
INFO = -1
ELSE IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN
INFO = -2
ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN
INFO = -3
ELSE IF( .NOT.( WNTSNN .OR. WNTSNE .OR. WNTSNB .OR. WNTSNV ) .OR.
$ ( ( WNTSNE .OR. WNTSNB ) .AND. .NOT.( WANTVL .AND.
$ WANTVR ) ) ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN
INFO = -11
ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN
INFO = -13
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.
* HSWORK refers to the workspace preferred by DHSEQR, as
* calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
* the worst case.)
*
IF( INFO.EQ.0 ) THEN
IF( N.EQ.0 ) THEN
MINWRK = 1
MAXWRK = 1
ELSE
MAXWRK = N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 )
*
IF( WANTVL ) THEN
CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VL, LDVL,
$ WORK, -1, INFO )
ELSE IF( WANTVR ) THEN
CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VR, LDVR,
$ WORK, -1, INFO )
ELSE
IF( WNTSNN ) THEN
CALL DHSEQR( 'E', 'N', N, 1, N, A, LDA, WR, WI, VR,
$ LDVR, WORK, -1, INFO )
ELSE
CALL DHSEQR( 'S', 'N', N, 1, N, A, LDA, WR, WI, VR,
$ LDVR, WORK, -1, INFO )
END IF
END IF
HSWORK = WORK( 1 )
*
IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN
MINWRK = 2*N
IF( .NOT.WNTSNN )
$ MINWRK = MAX( MINWRK, N*N+6*N )
MAXWRK = MAX( MAXWRK, HSWORK )
IF( .NOT.WNTSNN )
$ MAXWRK = MAX( MAXWRK, N*N + 6*N )
ELSE
MINWRK = 3*N
IF( ( .NOT.WNTSNN ) .AND. ( .NOT.WNTSNE ) )
$ MINWRK = MAX( MINWRK, N*N + 6*N )
MAXWRK = MAX( MAXWRK, HSWORK )
MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'DORGHR',
$ ' ', N, 1, N, -1 ) )
IF( ( .NOT.WNTSNN ) .AND. ( .NOT.WNTSNE ) )
$ MAXWRK = MAX( MAXWRK, N*N + 6*N )
MAXWRK = MAX( MAXWRK, 3*N )
END IF
MAXWRK = MAX( MAXWRK, MINWRK )
END IF
WORK( 1 ) = MAXWRK
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
INFO = -21
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGEEVX', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Get machine constants
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
SMLNUM = SQRT( SMLNUM ) / EPS
BIGNUM = ONE / SMLNUM
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ICOND = 0
ANRM = DLANGE( 'M', N, N, A, LDA, DUM )
SCALEA = .FALSE.
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
SCALEA = .TRUE.
CSCALE = SMLNUM
ELSE IF( ANRM.GT.BIGNUM ) THEN
SCALEA = .TRUE.
CSCALE = BIGNUM
END IF
IF( SCALEA )
$ CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
*
* Balance the matrix and compute ABNRM
*
CALL DGEBAL( BALANC, N, A, LDA, ILO, IHI, SCALE, IERR )
ABNRM = DLANGE( '1', N, N, A, LDA, DUM )
IF( SCALEA ) THEN
DUM( 1 ) = ABNRM
CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, 1, 1, DUM, 1, IERR )
ABNRM = DUM( 1 )
END IF
*
* Reduce to upper Hessenberg form
* (Workspace: need 2*N, prefer N+N*NB)
*
ITAU = 1
IWRK = ITAU + N
CALL DGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
$ LWORK-IWRK+1, IERR )
*
IF( WANTVL ) THEN
*
* Want left eigenvectors
* Copy Householder vectors to VL
*
SIDE = 'L'
CALL DLACPY( 'L', N, N, A, LDA, VL, LDVL )
*
* Generate orthogonal matrix in VL
* (Workspace: need 2*N-1, prefer N+(N-1)*NB)
*
CALL DORGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ),
$ LWORK-IWRK+1, IERR )
*
* Perform QR iteration, accumulating Schur vectors in VL
* (Workspace: need 1, prefer HSWORK (see comments) )
*
IWRK = ITAU
CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VL, LDVL,
$ WORK( IWRK ), LWORK-IWRK+1, INFO )
*
IF( WANTVR ) THEN
*
* Want left and right eigenvectors
* Copy Schur vectors to VR
*
SIDE = 'B'
CALL DLACPY( 'F', N, N, VL, LDVL, VR, LDVR )
END IF
*
ELSE IF( WANTVR ) THEN
*
* Want right eigenvectors
* Copy Householder vectors to VR
*
SIDE = 'R'
CALL DLACPY( 'L', N, N, A, LDA, VR, LDVR )
*
* Generate orthogonal matrix in VR
* (Workspace: need 2*N-1, prefer N+(N-1)*NB)
*
CALL DORGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ),
$ LWORK-IWRK+1, IERR )
*
* Perform QR iteration, accumulating Schur vectors in VR
* (Workspace: need 1, prefer HSWORK (see comments) )
*
IWRK = ITAU
CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR,
$ WORK( IWRK ), LWORK-IWRK+1, INFO )
*
ELSE
*
* Compute eigenvalues only
* If condition numbers desired, compute Schur form
*
IF( WNTSNN ) THEN
JOB = 'E'
ELSE
JOB = 'S'
END IF
*
* (Workspace: need 1, prefer HSWORK (see comments) )
*
IWRK = ITAU
CALL DHSEQR( JOB, 'N', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR,
$ WORK( IWRK ), LWORK-IWRK+1, INFO )
END IF
*
* If INFO > 0 from DHSEQR, then quit
*
IF( INFO.GT.0 )
$ GO TO 50
*
IF( WANTVL .OR. WANTVR ) THEN
*
* Compute left and/or right eigenvectors
* (Workspace: need 3*N)
*
CALL DTREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
$ N, NOUT, WORK( IWRK ), IERR )
END IF
*
* Compute condition numbers if desired
* (Workspace: need N*N+6*N unless SENSE = 'E')
*
IF( .NOT.WNTSNN ) THEN
CALL DTRSNA( SENSE, 'A', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
$ RCONDE, RCONDV, N, NOUT, WORK( IWRK ), N, IWORK,
$ ICOND )
END IF
*
IF( WANTVL ) THEN
*
* Undo balancing of left eigenvectors
*
CALL DGEBAK( BALANC, 'L', N, ILO, IHI, SCALE, N, VL, LDVL,
$ IERR )
*
* Normalize left eigenvectors and make largest component real
*
DO 20 I = 1, N
IF( WI( I ).EQ.ZERO ) THEN
SCL = ONE / DNRM2( N, VL( 1, I ), 1 )
CALL DSCAL( N, SCL, VL( 1, I ), 1 )
ELSE IF( WI( I ).GT.ZERO ) THEN
SCL = ONE / DLAPY2( DNRM2( N, VL( 1, I ), 1 ),
$ DNRM2( N, VL( 1, I+1 ), 1 ) )
CALL DSCAL( N, SCL, VL( 1, I ), 1 )
CALL DSCAL( N, SCL, VL( 1, I+1 ), 1 )
DO 10 K = 1, N
WORK( K ) = VL( K, I )**2 + VL( K, I+1 )**2
10 CONTINUE
K = IDAMAX( N, WORK, 1 )
CALL DLARTG( VL( K, I ), VL( K, I+1 ), CS, SN, R )
CALL DROT( N, VL( 1, I ), 1, VL( 1, I+1 ), 1, CS, SN )
VL( K, I+1 ) = ZERO
END IF
20 CONTINUE
END IF
*
IF( WANTVR ) THEN
*
* Undo balancing of right eigenvectors
*
CALL DGEBAK( BALANC, 'R', N, ILO, IHI, SCALE, N, VR, LDVR,
$ IERR )
*
* Normalize right eigenvectors and make largest component real
*
DO 40 I = 1, N
IF( WI( I ).EQ.ZERO ) THEN
SCL = ONE / DNRM2( N, VR( 1, I ), 1 )
CALL DSCAL( N, SCL, VR( 1, I ), 1 )
ELSE IF( WI( I ).GT.ZERO ) THEN
SCL = ONE / DLAPY2( DNRM2( N, VR( 1, I ), 1 ),
$ DNRM2( N, VR( 1, I+1 ), 1 ) )
CALL DSCAL( N, SCL, VR( 1, I ), 1 )
CALL DSCAL( N, SCL, VR( 1, I+1 ), 1 )
DO 30 K = 1, N
WORK( K ) = VR( K, I )**2 + VR( K, I+1 )**2
30 CONTINUE
K = IDAMAX( N, WORK, 1 )
CALL DLARTG( VR( K, I ), VR( K, I+1 ), CS, SN, R )
CALL DROT( N, VR( 1, I ), 1, VR( 1, I+1 ), 1, CS, SN )
VR( K, I+1 ) = ZERO
END IF
40 CONTINUE
END IF
*
* Undo scaling if necessary
*
50 CONTINUE
IF( SCALEA ) THEN
CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WR( INFO+1 ),
$ MAX( N-INFO, 1 ), IERR )
CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WI( INFO+1 ),
$ MAX( N-INFO, 1 ), IERR )
IF( INFO.EQ.0 ) THEN
IF( ( WNTSNV .OR. WNTSNB ) .AND. ICOND.EQ.0 )
$ CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, RCONDV, N,
$ IERR )
ELSE
CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WR, N,
$ IERR )
CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N,
$ IERR )
END IF
END IF
*
WORK( 1 ) = MAXWRK
RETURN
*
* End of DGEEVX
*
END
SUBROUTINE DGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR,
$ ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK,
$ LWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBVSL, JOBVSR
INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
$ B( LDB, * ), BETA( * ), VSL( LDVSL, * ),
$ VSR( LDVSR, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* This routine is deprecated and has been replaced by routine DGGES.
*
* DGEGS computes the eigenvalues, real Schur form, and, optionally,
* left and or/right Schur vectors of a real matrix pair (A,B).
* Given two square matrices A and B, the generalized real Schur
* factorization has the form
*
* A = Q*S*Z**T, B = Q*T*Z**T
*
* where Q and Z are orthogonal matrices, T is upper triangular, and S
* is an upper quasi-triangular matrix with 1-by-1 and 2-by-2 diagonal
* blocks, the 2-by-2 blocks corresponding to complex conjugate pairs
* of eigenvalues of (A,B). The columns of Q are the left Schur vectors
* and the columns of Z are the right Schur vectors.
*
* If only the eigenvalues of (A,B) are needed, the driver routine
* DGEGV should be used instead. See DGEGV for a description of the
* eigenvalues of the generalized nonsymmetric eigenvalue problem
* (GNEP).
*
* Arguments
* =========
*
* JOBVSL (input) CHARACTER*1
* = 'N': do not compute the left Schur vectors;
* = 'V': compute the left Schur vectors (returned in VSL).
*
* JOBVSR (input) CHARACTER*1
* = 'N': do not compute the right Schur vectors;
* = 'V': compute the right Schur vectors (returned in VSR).
*
* N (input) INTEGER
* The order of the matrices A, B, VSL, and VSR. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
* On entry, the matrix A.
* On exit, the upper quasi-triangular matrix S from the
* generalized real Schur factorization.
*
* LDA (input) INTEGER
* The leading dimension of A. LDA >= max(1,N).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
* On entry, the matrix B.
* On exit, the upper triangular matrix T from the generalized
* real Schur factorization.
*
* LDB (input) INTEGER
* The leading dimension of B. LDB >= max(1,N).
*
* ALPHAR (output) DOUBLE PRECISION array, dimension (N)
* The real parts of each scalar alpha defining an eigenvalue
* of GNEP.
*
* ALPHAI (output) DOUBLE PRECISION array, dimension (N)
* The imaginary parts of each scalar alpha defining an
* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th
* eigenvalue is real; if positive, then the j-th and (j+1)-st
* eigenvalues are a complex conjugate pair, with
* ALPHAI(j+1) = -ALPHAI(j).
*
* BETA (output) DOUBLE PRECISION array, dimension (N)
* The scalars beta that define the eigenvalues of GNEP.
* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
* beta = BETA(j) represent the j-th eigenvalue of the matrix
* pair (A,B), in one of the forms lambda = alpha/beta or
* mu = beta/alpha. Since either lambda or mu may overflow,
* they should not, in general, be computed.
*
* VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N)
* If JOBVSL = 'V', the matrix of left Schur vectors Q.
* Not referenced if JOBVSL = 'N'.
*
* LDVSL (input) INTEGER
* The leading dimension of the matrix VSL. LDVSL >=1, and
* if JOBVSL = 'V', LDVSL >= N.
*
* VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N)
* If JOBVSR = 'V', the matrix of right Schur vectors Z.
* Not referenced if JOBVSR = 'N'.
*
* LDVSR (input) INTEGER
* The leading dimension of the matrix VSR. LDVSR >= 1, and
* if JOBVSR = 'V', LDVSR >= N.
*
* 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,4*N).
* For good performance, LWORK must generally be larger.
* To compute the optimal value of LWORK, call ILAENV to get
* blocksizes (for DGEQRF, DORMQR, and DORGQR.) Then compute:
* NB -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR
* The optimal LWORK is 2*N + N*(NB+1).
*
* 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.
* = 1,...,N:
* The QZ iteration failed. (A,B) are not in Schur
* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should
* be correct for j=INFO+1,...,N.
* > N: errors that usually indicate LAPACK problems:
* =N+1: error return from DGGBAL
* =N+2: error return from DGEQRF
* =N+3: error return from DORMQR
* =N+4: error return from DORGQR
* =N+5: error return from DGGHRD
* =N+6: error return from DHGEQZ (other than failed
* iteration)
* =N+7: error return from DGGBAK (computing VSL)
* =N+8: error return from DGGBAK (computing VSR)
* =N+9: error return from DLASCL (various places)
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL ILASCL, ILBSCL, ILVSL, ILVSR, LQUERY
INTEGER ICOLS, IHI, IINFO, IJOBVL, IJOBVR, ILEFT, ILO,
$ IRIGHT, IROWS, ITAU, IWORK, LOPT, LWKMIN,
$ LWKOPT, NB, NB1, NB2, NB3
DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
$ SAFMIN, SMLNUM
* ..
* .. External Subroutines ..
EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLACPY,
$ DLASCL, DLASET, DORGQR, DORMQR, XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC INT, MAX
* ..
* .. Executable Statements ..
*
* Decode the input arguments
*
IF( LSAME( JOBVSL, 'N' ) ) THEN
IJOBVL = 1
ILVSL = .FALSE.
ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN
IJOBVL = 2
ILVSL = .TRUE.
ELSE
IJOBVL = -1
ILVSL = .FALSE.
END IF
*
IF( LSAME( JOBVSR, 'N' ) ) THEN
IJOBVR = 1
ILVSR = .FALSE.
ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN
IJOBVR = 2
ILVSR = .TRUE.
ELSE
IJOBVR = -1
ILVSR = .FALSE.
END IF
*
* Test the input arguments
*
LWKMIN = MAX( 4*N, 1 )
LWKOPT = LWKMIN
WORK( 1 ) = LWKOPT
LQUERY = ( LWORK.EQ.-1 )
INFO = 0
IF( IJOBVL.LE.0 ) THEN
INFO = -1
ELSE IF( IJOBVR.LE.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN
INFO = -12
ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN
INFO = -14
ELSE IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
INFO = -16
END IF
*
IF( INFO.EQ.0 ) THEN
NB1 = ILAENV( 1, 'DGEQRF', ' ', N, N, -1, -1 )
NB2 = ILAENV( 1, 'DORMQR', ' ', N, N, N, -1 )
NB3 = ILAENV( 1, 'DORGQR', ' ', N, N, N, -1 )
NB = MAX( NB1, NB2, NB3 )
LOPT = 2*N + N*( NB+1 )
WORK( 1 ) = LOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGEGS ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Get machine constants
*
EPS = DLAMCH( 'E' )*DLAMCH( 'B' )
SAFMIN = DLAMCH( 'S' )
SMLNUM = N*SAFMIN / EPS
BIGNUM = ONE / SMLNUM
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = DLANGE( 'M', N, N, A, LDA, WORK )
ILASCL = .FALSE.
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
ANRMTO = SMLNUM
ILASCL = .TRUE.
ELSE IF( ANRM.GT.BIGNUM ) THEN
ANRMTO = BIGNUM
ILASCL = .TRUE.
END IF
*
IF( ILASCL ) THEN
CALL DLASCL( 'G', -1, -1, ANRM, ANRMTO, N, N, A, LDA, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 9
RETURN
END IF
END IF
*
* Scale B if max element outside range [SMLNUM,BIGNUM]
*
BNRM = DLANGE( 'M', N, N, B, LDB, WORK )
ILBSCL = .FALSE.
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
BNRMTO = SMLNUM
ILBSCL = .TRUE.
ELSE IF( BNRM.GT.BIGNUM ) THEN
BNRMTO = BIGNUM
ILBSCL = .TRUE.
END IF
*
IF( ILBSCL ) THEN
CALL DLASCL( 'G', -1, -1, BNRM, BNRMTO, N, N, B, LDB, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 9
RETURN
END IF
END IF
*
* Permute the matrix to make it more nearly triangular
* Workspace layout: (2*N words -- "work..." not actually used)
* left_permutation, right_permutation, work...
*
ILEFT = 1
IRIGHT = N + 1
IWORK = IRIGHT + N
CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ),
$ WORK( IRIGHT ), WORK( IWORK ), IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 1
GO TO 10
END IF
*
* Reduce B to triangular form, and initialize VSL and/or VSR
* Workspace layout: ("work..." must have at least N words)
* left_permutation, right_permutation, tau, work...
*
IROWS = IHI + 1 - ILO
ICOLS = N + 1 - ILO
ITAU = IWORK
IWORK = ITAU + IROWS
CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
$ WORK( IWORK ), LWORK+1-IWORK, IINFO )
IF( IINFO.GE.0 )
$ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
IF( IINFO.NE.0 ) THEN
INFO = N + 2
GO TO 10
END IF
*
CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
$ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWORK ),
$ LWORK+1-IWORK, IINFO )
IF( IINFO.GE.0 )
$ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
IF( IINFO.NE.0 ) THEN
INFO = N + 3
GO TO 10
END IF
*
IF( ILVSL ) THEN
CALL DLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL )
CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
$ VSL( ILO+1, ILO ), LDVSL )
CALL DORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL,
$ WORK( ITAU ), WORK( IWORK ), LWORK+1-IWORK,
$ IINFO )
IF( IINFO.GE.0 )
$ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
IF( IINFO.NE.0 ) THEN
INFO = N + 4
GO TO 10
END IF
END IF
*
IF( ILVSR )
$ CALL DLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR )
*
* Reduce to generalized Hessenberg form
*
CALL DGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL,
$ LDVSL, VSR, LDVSR, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 5
GO TO 10
END IF
*
* Perform QZ algorithm, computing Schur vectors if desired
* Workspace layout: ("work..." must have at least 1 word)
* left_permutation, right_permutation, work...
*
IWORK = ITAU
CALL DHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB,
$ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR,
$ WORK( IWORK ), LWORK+1-IWORK, IINFO )
IF( IINFO.GE.0 )
$ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
IF( IINFO.NE.0 ) THEN
IF( IINFO.GT.0 .AND. IINFO.LE.N ) THEN
INFO = IINFO
ELSE IF( IINFO.GT.N .AND. IINFO.LE.2*N ) THEN
INFO = IINFO - N
ELSE
INFO = N + 6
END IF
GO TO 10
END IF
*
* Apply permutation to VSL and VSR
*
IF( ILVSL ) THEN
CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
$ WORK( IRIGHT ), N, VSL, LDVSL, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 7
GO TO 10
END IF
END IF
IF( ILVSR ) THEN
CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ),
$ WORK( IRIGHT ), N, VSR, LDVSR, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 8
GO TO 10
END IF
END IF
*
* Undo scaling
*
IF( ILASCL ) THEN
CALL DLASCL( 'H', -1, -1, ANRMTO, ANRM, N, N, A, LDA, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 9
RETURN
END IF
CALL DLASCL( 'G', -1, -1, ANRMTO, ANRM, N, 1, ALPHAR, N,
$ IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 9
RETURN
END IF
CALL DLASCL( 'G', -1, -1, ANRMTO, ANRM, N, 1, ALPHAI, N,
$ IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 9
RETURN
END IF
END IF
*
IF( ILBSCL ) THEN
CALL DLASCL( 'U', -1, -1, BNRMTO, BNRM, N, N, B, LDB, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 9
RETURN
END IF
CALL DLASCL( 'G', -1, -1, BNRMTO, BNRM, N, 1, BETA, N, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 9
RETURN
END IF
END IF
*
10 CONTINUE
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of DGEGS
*
END
SUBROUTINE DGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI,
$ BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBVL, JOBVR
INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
$ B( LDB, * ), BETA( * ), VL( LDVL, * ),
$ VR( LDVR, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* This routine is deprecated and has been replaced by routine DGGEV.
*
* DGEGV computes the eigenvalues and, optionally, the left and/or right
* eigenvectors of a real matrix pair (A,B).
* Given two square matrices A and B,
* the generalized nonsymmetric eigenvalue problem (GNEP) is to find the
* eigenvalues lambda and corresponding (non-zero) eigenvectors x such
* that
*
* A*x = lambda*B*x.
*
* An alternate form is to find the eigenvalues mu and corresponding
* eigenvectors y such that
*
* mu*A*y = B*y.
*
* These two forms are equivalent with mu = 1/lambda and x = y if
* neither lambda nor mu is zero. In order to deal with the case that
* lambda or mu is zero or small, two values alpha and beta are returned
* for each eigenvalue, such that lambda = alpha/beta and
* mu = beta/alpha.
*
* The vectors x and y in the above equations are right eigenvectors of
* the matrix pair (A,B). Vectors u and v satisfying
*
* u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B
*
* are left eigenvectors of (A,B).
*
* Note: this routine performs "full balancing" on A and B -- see
* "Further Details", below.
*
* Arguments
* =========
*
* JOBVL (input) CHARACTER*1
* = 'N': do not compute the left generalized eigenvectors;
* = 'V': compute the left generalized eigenvectors (returned
* in VL).
*
* JOBVR (input) CHARACTER*1
* = 'N': do not compute the right generalized eigenvectors;
* = 'V': compute the right generalized eigenvectors (returned
* in VR).
*
* N (input) INTEGER
* The order of the matrices A, B, VL, and VR. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
* On entry, the matrix A.
* If JOBVL = 'V' or JOBVR = 'V', then on exit A
* contains the real Schur form of A from the generalized Schur
* factorization of the pair (A,B) after balancing.
* If no eigenvectors were computed, then only the diagonal
* blocks from the Schur form will be correct. See DGGHRD and
* DHGEQZ for details.
*
* LDA (input) INTEGER
* The leading dimension of A. LDA >= max(1,N).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
* On entry, the matrix B.
* If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the
* upper triangular matrix obtained from B in the generalized
* Schur factorization of the pair (A,B) after balancing.
* If no eigenvectors were computed, then only those elements of
* B corresponding to the diagonal blocks from the Schur form of
* A will be correct. See DGGHRD and DHGEQZ for details.
*
* LDB (input) INTEGER
* The leading dimension of B. LDB >= max(1,N).
*
* ALPHAR (output) DOUBLE PRECISION array, dimension (N)
* The real parts of each scalar alpha defining an eigenvalue of
* GNEP.
*
* ALPHAI (output) DOUBLE PRECISION array, dimension (N)
* The imaginary parts of each scalar alpha defining an
* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th
* eigenvalue is real; if positive, then the j-th and
* (j+1)-st eigenvalues are a complex conjugate pair, with
* ALPHAI(j+1) = -ALPHAI(j).
*
* BETA (output) DOUBLE PRECISION array, dimension (N)
* The scalars beta that define the eigenvalues of GNEP.
*
* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
* beta = BETA(j) represent the j-th eigenvalue of the matrix
* pair (A,B), in one of the forms lambda = alpha/beta or
* mu = beta/alpha. Since either lambda or mu may overflow,
* they should not, in general, be computed.
*
* VL (output) DOUBLE PRECISION array, dimension (LDVL,N)
* If JOBVL = 'V', the left eigenvectors u(j) are stored
* in the columns of VL, in the same order as their eigenvalues.
* If the j-th eigenvalue is real, then u(j) = VL(:,j).
* If the j-th and (j+1)-st eigenvalues form a complex conjugate
* pair, then
* u(j) = VL(:,j) + i*VL(:,j+1)
* and
* u(j+1) = VL(:,j) - i*VL(:,j+1).
*
* Each eigenvector is scaled so that its largest component has
* abs(real part) + abs(imag. part) = 1, except for eigenvectors
* corresponding to an eigenvalue with alpha = beta = 0, which
* are set to zero.
* Not referenced if JOBVL = 'N'.
*
* LDVL (input) INTEGER
* The leading dimension of the matrix VL. LDVL >= 1, and
* if JOBVL = 'V', LDVL >= N.
*
* VR (output) DOUBLE PRECISION array, dimension (LDVR,N)
* If JOBVR = 'V', the right eigenvectors x(j) are stored
* in the columns of VR, in the same order as their eigenvalues.
* If the j-th eigenvalue is real, then x(j) = VR(:,j).
* If the j-th and (j+1)-st eigenvalues form a complex conjugate
* pair, then
* x(j) = VR(:,j) + i*VR(:,j+1)
* and
* x(j+1) = VR(:,j) - i*VR(:,j+1).
*
* Each eigenvector is scaled so that its largest component has
* abs(real part) + abs(imag. part) = 1, except for eigenvalues
* corresponding to an eigenvalue with alpha = beta = 0, which
* are set to zero.
* Not referenced if JOBVR = 'N'.
*
* LDVR (input) INTEGER
* The leading dimension of the matrix VR. LDVR >= 1, and
* if JOBVR = 'V', LDVR >= N.
*
* 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,8*N).
* For good performance, LWORK must generally be larger.
* To compute the optimal value of LWORK, call ILAENV to get
* blocksizes (for DGEQRF, DORMQR, and DORGQR.) Then compute:
* NB -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR;
* The optimal LWORK is:
* 2*N + MAX( 6*N, N*(NB+1) ).
*
* 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.
* = 1,...,N:
* The QZ iteration failed. No eigenvectors have been
* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
* should be correct for j=INFO+1,...,N.
* > N: errors that usually indicate LAPACK problems:
* =N+1: error return from DGGBAL
* =N+2: error return from DGEQRF
* =N+3: error return from DORMQR
* =N+4: error return from DORGQR
* =N+5: error return from DGGHRD
* =N+6: error return from DHGEQZ (other than failed
* iteration)
* =N+7: error return from DTGEVC
* =N+8: error return from DGGBAK (computing VL)
* =N+9: error return from DGGBAK (computing VR)
* =N+10: error return from DLASCL (various calls)
*
* Further Details
* ===============
*
* Balancing
* ---------
*
* This driver calls DGGBAL to both permute and scale rows and columns
* of A and B. The permutations PL and PR are chosen so that PL*A*PR
* and PL*B*R will be upper triangular except for the diagonal blocks
* A(i:j,i:j) and B(i:j,i:j), with i and j as close together as
* possible. The diagonal scaling matrices DL and DR are chosen so
* that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to
* one (except for the elements that start out zero.)
*
* After the eigenvalues and eigenvectors of the balanced matrices
* have been computed, DGGBAK transforms the eigenvectors back to what
* they would have been (in perfect arithmetic) if they had not been
* balanced.
*
* Contents of A and B on Exit
* -------- -- - --- - -- ----
*
* If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or
* both), then on exit the arrays A and B will contain the real Schur
* form[*] of the "balanced" versions of A and B. If no eigenvectors
* are computed, then only the diagonal blocks will be correct.
*
* [*] See DHGEQZ, DGEGS, or read the book "Matrix Computations",
* by Golub & van Loan, pub. by Johns Hopkins U. Press.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL ILIMIT, ILV, ILVL, ILVR, LQUERY
CHARACTER CHTEMP
INTEGER ICOLS, IHI, IINFO, IJOBVL, IJOBVR, ILEFT, ILO,
$ IN, IRIGHT, IROWS, ITAU, IWORK, JC, JR, LOPT,
$ LWKMIN, LWKOPT, NB, NB1, NB2, NB3
DOUBLE PRECISION ABSAI, ABSAR, ABSB, ANRM, ANRM1, ANRM2, BNRM,
$ BNRM1, BNRM2, EPS, ONEPLS, SAFMAX, SAFMIN,
$ SALFAI, SALFAR, SBETA, SCALE, TEMP
* ..
* .. Local Arrays ..
LOGICAL LDUMMA( 1 )
* ..
* .. External Subroutines ..
EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLACPY,
$ DLASCL, DLASET, DORGQR, DORMQR, DTGEVC, XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, MAX
* ..
* .. Executable Statements ..
*
* Decode the input arguments
*
IF( LSAME( JOBVL, 'N' ) ) THEN
IJOBVL = 1
ILVL = .FALSE.
ELSE IF( LSAME( JOBVL, 'V' ) ) THEN
IJOBVL = 2
ILVL = .TRUE.
ELSE
IJOBVL = -1
ILVL = .FALSE.
END IF
*
IF( LSAME( JOBVR, 'N' ) ) THEN
IJOBVR = 1
ILVR = .FALSE.
ELSE IF( LSAME( JOBVR, 'V' ) ) THEN
IJOBVR = 2
ILVR = .TRUE.
ELSE
IJOBVR = -1
ILVR = .FALSE.
END IF
ILV = ILVL .OR. ILVR
*
* Test the input arguments
*
LWKMIN = MAX( 8*N, 1 )
LWKOPT = LWKMIN
WORK( 1 ) = LWKOPT
LQUERY = ( LWORK.EQ.-1 )
INFO = 0
IF( IJOBVL.LE.0 ) THEN
INFO = -1
ELSE IF( IJOBVR.LE.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
INFO = -12
ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
INFO = -14
ELSE IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
INFO = -16
END IF
*
IF( INFO.EQ.0 ) THEN
NB1 = ILAENV( 1, 'DGEQRF', ' ', N, N, -1, -1 )
NB2 = ILAENV( 1, 'DORMQR', ' ', N, N, N, -1 )
NB3 = ILAENV( 1, 'DORGQR', ' ', N, N, N, -1 )
NB = MAX( NB1, NB2, NB3 )
LOPT = 2*N + MAX( 6*N, N*( NB+1 ) )
WORK( 1 ) = LOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGEGV ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Get machine constants
*
EPS = DLAMCH( 'E' )*DLAMCH( 'B' )
SAFMIN = DLAMCH( 'S' )
SAFMIN = SAFMIN + SAFMIN
SAFMAX = ONE / SAFMIN
ONEPLS = ONE + ( 4*EPS )
*
* Scale A
*
ANRM = DLANGE( 'M', N, N, A, LDA, WORK )
ANRM1 = ANRM
ANRM2 = ONE
IF( ANRM.LT.ONE ) THEN
IF( SAFMAX*ANRM.LT.ONE ) THEN
ANRM1 = SAFMIN
ANRM2 = SAFMAX*ANRM
END IF
END IF
*
IF( ANRM.GT.ZERO ) THEN
CALL DLASCL( 'G', -1, -1, ANRM, ONE, N, N, A, LDA, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 10
RETURN
END IF
END IF
*
* Scale B
*
BNRM = DLANGE( 'M', N, N, B, LDB, WORK )
BNRM1 = BNRM
BNRM2 = ONE
IF( BNRM.LT.ONE ) THEN
IF( SAFMAX*BNRM.LT.ONE ) THEN
BNRM1 = SAFMIN
BNRM2 = SAFMAX*BNRM
END IF
END IF
*
IF( BNRM.GT.ZERO ) THEN
CALL DLASCL( 'G', -1, -1, BNRM, ONE, N, N, B, LDB, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 10
RETURN
END IF
END IF
*
* Permute the matrix to make it more nearly triangular
* Workspace layout: (8*N words -- "work" requires 6*N words)
* left_permutation, right_permutation, work...
*
ILEFT = 1
IRIGHT = N + 1
IWORK = IRIGHT + N
CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ),
$ WORK( IRIGHT ), WORK( IWORK ), IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 1
GO TO 120
END IF
*
* Reduce B to triangular form, and initialize VL and/or VR
* Workspace layout: ("work..." must have at least N words)
* left_permutation, right_permutation, tau, work...
*
IROWS = IHI + 1 - ILO
IF( ILV ) THEN
ICOLS = N + 1 - ILO
ELSE
ICOLS = IROWS
END IF
ITAU = IWORK
IWORK = ITAU + IROWS
CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
$ WORK( IWORK ), LWORK+1-IWORK, IINFO )
IF( IINFO.GE.0 )
$ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
IF( IINFO.NE.0 ) THEN
INFO = N + 2
GO TO 120
END IF
*
CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
$ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWORK ),
$ LWORK+1-IWORK, IINFO )
IF( IINFO.GE.0 )
$ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
IF( IINFO.NE.0 ) THEN
INFO = N + 3
GO TO 120
END IF
*
IF( ILVL ) THEN
CALL DLASET( 'Full', N, N, ZERO, ONE, VL, LDVL )
CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
$ VL( ILO+1, ILO ), LDVL )
CALL DORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
$ WORK( ITAU ), WORK( IWORK ), LWORK+1-IWORK,
$ IINFO )
IF( IINFO.GE.0 )
$ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
IF( IINFO.NE.0 ) THEN
INFO = N + 4
GO TO 120
END IF
END IF
*
IF( ILVR )
$ CALL DLASET( 'Full', N, N, ZERO, ONE, VR, LDVR )
*
* Reduce to generalized Hessenberg form
*
IF( ILV ) THEN
*
* Eigenvectors requested -- work on whole matrix.
*
CALL DGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL,
$ LDVL, VR, LDVR, IINFO )
ELSE
CALL DGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA,
$ B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IINFO )
END IF
IF( IINFO.NE.0 ) THEN
INFO = N + 5
GO TO 120
END IF
*
* Perform QZ algorithm
* Workspace layout: ("work..." must have at least 1 word)
* left_permutation, right_permutation, work...
*
IWORK = ITAU
IF( ILV ) THEN
CHTEMP = 'S'
ELSE
CHTEMP = 'E'
END IF
CALL DHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB,
$ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR,
$ WORK( IWORK ), LWORK+1-IWORK, IINFO )
IF( IINFO.GE.0 )
$ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
IF( IINFO.NE.0 ) THEN
IF( IINFO.GT.0 .AND. IINFO.LE.N ) THEN
INFO = IINFO
ELSE IF( IINFO.GT.N .AND. IINFO.LE.2*N ) THEN
INFO = IINFO - N
ELSE
INFO = N + 6
END IF
GO TO 120
END IF
*
IF( ILV ) THEN
*
* Compute Eigenvectors (DTGEVC requires 6*N words of workspace)
*
IF( ILVL ) THEN
IF( ILVR ) THEN
CHTEMP = 'B'
ELSE
CHTEMP = 'L'
END IF
ELSE
CHTEMP = 'R'
END IF
*
CALL DTGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, LDVL,
$ VR, LDVR, N, IN, WORK( IWORK ), IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 7
GO TO 120
END IF
*
* Undo balancing on VL and VR, rescale
*
IF( ILVL ) THEN
CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
$ WORK( IRIGHT ), N, VL, LDVL, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 8
GO TO 120
END IF
DO 50 JC = 1, N
IF( ALPHAI( JC ).LT.ZERO )
$ GO TO 50
TEMP = ZERO
IF( ALPHAI( JC ).EQ.ZERO ) THEN
DO 10 JR = 1, N
TEMP = MAX( TEMP, ABS( VL( JR, JC ) ) )
10 CONTINUE
ELSE
DO 20 JR = 1, N
TEMP = MAX( TEMP, ABS( VL( JR, JC ) )+
$ ABS( VL( JR, JC+1 ) ) )
20 CONTINUE
END IF
IF( TEMP.LT.SAFMIN )
$ GO TO 50
TEMP = ONE / TEMP
IF( ALPHAI( JC ).EQ.ZERO ) THEN
DO 30 JR = 1, N
VL( JR, JC ) = VL( JR, JC )*TEMP
30 CONTINUE
ELSE
DO 40 JR = 1, N
VL( JR, JC ) = VL( JR, JC )*TEMP
VL( JR, JC+1 ) = VL( JR, JC+1 )*TEMP
40 CONTINUE
END IF
50 CONTINUE
END IF
IF( ILVR ) THEN
CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ),
$ WORK( IRIGHT ), N, VR, LDVR, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 9
GO TO 120
END IF
DO 100 JC = 1, N
IF( ALPHAI( JC ).LT.ZERO )
$ GO TO 100
TEMP = ZERO
IF( ALPHAI( JC ).EQ.ZERO ) THEN
DO 60 JR = 1, N
TEMP = MAX( TEMP, ABS( VR( JR, JC ) ) )
60 CONTINUE
ELSE
DO 70 JR = 1, N
TEMP = MAX( TEMP, ABS( VR( JR, JC ) )+
$ ABS( VR( JR, JC+1 ) ) )
70 CONTINUE
END IF
IF( TEMP.LT.SAFMIN )
$ GO TO 100
TEMP = ONE / TEMP
IF( ALPHAI( JC ).EQ.ZERO ) THEN
DO 80 JR = 1, N
VR( JR, JC ) = VR( JR, JC )*TEMP
80 CONTINUE
ELSE
DO 90 JR = 1, N
VR( JR, JC ) = VR( JR, JC )*TEMP
VR( JR, JC+1 ) = VR( JR, JC+1 )*TEMP
90 CONTINUE
END IF
100 CONTINUE
END IF
*
* End of eigenvector calculation
*
END IF
*
* Undo scaling in alpha, beta
*
* Note: this does not give the alpha and beta for the unscaled
* problem.
*
* Un-scaling is limited to avoid underflow in alpha and beta
* if they are significant.
*
DO 110 JC = 1, N
ABSAR = ABS( ALPHAR( JC ) )
ABSAI = ABS( ALPHAI( JC ) )
ABSB = ABS( BETA( JC ) )
SALFAR = ANRM*ALPHAR( JC )
SALFAI = ANRM*ALPHAI( JC )
SBETA = BNRM*BETA( JC )
ILIMIT = .FALSE.
SCALE = ONE
*
* Check for significant underflow in ALPHAI
*
IF( ABS( SALFAI ).LT.SAFMIN .AND. ABSAI.GE.
$ MAX( SAFMIN, EPS*ABSAR, EPS*ABSB ) ) THEN
ILIMIT = .TRUE.
SCALE = ( ONEPLS*SAFMIN / ANRM1 ) /
$ MAX( ONEPLS*SAFMIN, ANRM2*ABSAI )
*
ELSE IF( SALFAI.EQ.ZERO ) THEN
*
* If insignificant underflow in ALPHAI, then make the
* conjugate eigenvalue real.
*
IF( ALPHAI( JC ).LT.ZERO .AND. JC.GT.1 ) THEN
ALPHAI( JC-1 ) = ZERO
ELSE IF( ALPHAI( JC ).GT.ZERO .AND. JC.LT.N ) THEN
ALPHAI( JC+1 ) = ZERO
END IF
END IF
*
* Check for significant underflow in ALPHAR
*
IF( ABS( SALFAR ).LT.SAFMIN .AND. ABSAR.GE.
$ MAX( SAFMIN, EPS*ABSAI, EPS*ABSB ) ) THEN
ILIMIT = .TRUE.
SCALE = MAX( SCALE, ( ONEPLS*SAFMIN / ANRM1 ) /
$ MAX( ONEPLS*SAFMIN, ANRM2*ABSAR ) )
END IF
*
* Check for significant underflow in BETA
*
IF( ABS( SBETA ).LT.SAFMIN .AND. ABSB.GE.
$ MAX( SAFMIN, EPS*ABSAR, EPS*ABSAI ) ) THEN
ILIMIT = .TRUE.
SCALE = MAX( SCALE, ( ONEPLS*SAFMIN / BNRM1 ) /
$ MAX( ONEPLS*SAFMIN, BNRM2*ABSB ) )
END IF
*
* Check for possible overflow when limiting scaling
*
IF( ILIMIT ) THEN
TEMP = ( SCALE*SAFMIN )*MAX( ABS( SALFAR ), ABS( SALFAI ),
$ ABS( SBETA ) )
IF( TEMP.GT.ONE )
$ SCALE = SCALE / TEMP
IF( SCALE.LT.ONE )
$ ILIMIT = .FALSE.
END IF
*
* Recompute un-scaled ALPHAR, ALPHAI, BETA if necessary.
*
IF( ILIMIT ) THEN
SALFAR = ( SCALE*ALPHAR( JC ) )*ANRM
SALFAI = ( SCALE*ALPHAI( JC ) )*ANRM
SBETA = ( SCALE*BETA( JC ) )*BNRM
END IF
ALPHAR( JC ) = SALFAR
ALPHAI( JC ) = SALFAI
BETA( JC ) = SBETA
110 CONTINUE
*
120 CONTINUE
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of DGEGV
*
END
SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IHI, ILO, INFO, LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGEHD2 reduces a real general matrix A to upper Hessenberg form H by
* an orthogonal similarity transformation: Q' * A * Q = H .
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* It is assumed that A is already upper triangular in rows
* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
* set by a previous call to DGEBAL; otherwise they should be
* set to 1 and N respectively. See Further Details.
* 1 <= ILO <= IHI <= max(1,N).
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the n by n general matrix to be reduced.
* On exit, the upper triangle and the first subdiagonal of A
* are overwritten with the upper Hessenberg matrix H, and the
* elements below the first subdiagonal, 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,N).
*
* TAU (output) DOUBLE PRECISION array, dimension (N-1)
* 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 (ihi-ilo) elementary
* reflectors
*
* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a real scalar, and v is a real vector with
* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
* exit in A(i+2:ihi,i), and tau in TAU(i).
*
* The contents of A are illustrated by the following example, with
* n = 7, ilo = 2 and ihi = 6:
*
* on entry, on exit,
*
* ( a a a a a a a ) ( a a h h h h a )
* ( a a a a a a ) ( a h h h h a )
* ( a a a a a a ) ( h h h h h h )
* ( a a a a a a ) ( v2 h h h h h )
* ( a a a a a a ) ( v2 v3 h h h h )
* ( a a a a a a ) ( v2 v3 v4 h h h )
* ( a ) ( a )
*
* where a denotes an element of the original matrix A, h denotes a
* modified element of the upper Hessenberg matrix H, and vi denotes an
* element of the vector defining H(i).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I
DOUBLE PRECISION AII
* ..
* .. External Subroutines ..
EXTERNAL DLARF, DLARFG, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
INFO = -2
ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGEHD2', -INFO )
RETURN
END IF
*
DO 10 I = ILO, IHI - 1
*
* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i)
*
CALL DLARFG( IHI-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1,
$ TAU( I ) )
AII = A( I+1, I )
A( I+1, I ) = ONE
*
* Apply H(i) to A(1:ihi,i+1:ihi) from the right
*
CALL DLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ),
$ A( 1, I+1 ), LDA, WORK )
*
* Apply H(i) to A(i+1:ihi,i+1:n) from the left
*
CALL DLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, TAU( I ),
$ A( I+1, I+1 ), LDA, WORK )
*
A( I+1, I ) = AII
10 CONTINUE
*
RETURN
*
* End of DGEHD2
*
END
SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IHI, ILO, INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGEHRD reduces a real general matrix A to upper Hessenberg form H by
* an orthogonal similarity transformation: Q' * A * Q = H .
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* It is assumed that A is already upper triangular in rows
* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
* set by a previous call to DGEBAL; otherwise they should be
* set to 1 and N respectively. See Further Details.
* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the N-by-N general matrix to be reduced.
* On exit, the upper triangle and the first subdiagonal of A
* are overwritten with the upper Hessenberg matrix H, and the
* elements below the first subdiagonal, 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,N).
*
* TAU (output) DOUBLE PRECISION array, dimension (N-1)
* The scalar factors of the elementary reflectors (see Further
* Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to
* zero.
*
* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The length 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 (ihi-ilo) elementary
* reflectors
*
* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a real scalar, and v is a real vector with
* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
* exit in A(i+2:ihi,i), and tau in TAU(i).
*
* The contents of A are illustrated by the following example, with
* n = 7, ilo = 2 and ihi = 6:
*
* on entry, on exit,
*
* ( a a a a a a a ) ( a a h h h h a )
* ( a a a a a a ) ( a h h h h a )
* ( a a a a a a ) ( h h h h h h )
* ( a a a a a a ) ( v2 h h h h h )
* ( a a a a a a ) ( v2 v3 h h h h )
* ( a a a a a a ) ( v2 v3 v4 h h h )
* ( a ) ( a )
*
* where a denotes an element of the original matrix A, h denotes a
* modified element of the upper Hessenberg matrix H, and vi denotes an
* element of the vector defining H(i).
*
* This file is a slight modification of LAPACK-3.0's DGEHRD
* subroutine incorporating improvements proposed by Quintana-Orti and
* Van de Geijn (2005).
*
* =====================================================================
*
* .. Parameters ..
INTEGER NBMAX, LDT
PARAMETER ( NBMAX = 64, LDT = NBMAX+1 )
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0,
$ ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IINFO, IWS, J, LDWORK, LWKOPT, NB,
$ NBMIN, NH, NX
DOUBLE PRECISION EI
* ..
* .. Local Arrays ..
DOUBLE PRECISION T( LDT, NBMAX )
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DGEHD2, DGEMM, DLAHR2, DLARFB, DTRMM,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
NB = MIN( NBMAX, ILAENV( 1, 'DGEHRD', ' ', N, ILO, IHI, -1 ) )
LWKOPT = N*NB
WORK( 1 ) = LWKOPT
LQUERY = ( LWORK.EQ.-1 )
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
INFO = -2
ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGEHRD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero
*
DO 10 I = 1, ILO - 1
TAU( I ) = ZERO
10 CONTINUE
DO 20 I = MAX( 1, IHI ), N - 1
TAU( I ) = ZERO
20 CONTINUE
*
* Quick return if possible
*
NH = IHI - ILO + 1
IF( NH.LE.1 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
* Determine the block size
*
NB = MIN( NBMAX, ILAENV( 1, 'DGEHRD', ' ', N, ILO, IHI, -1 ) )
NBMIN = 2
IWS = 1
IF( NB.GT.1 .AND. NB.LT.NH ) THEN
*
* Determine when to cross over from blocked to unblocked code
* (last block is always handled by unblocked code)
*
NX = MAX( NB, ILAENV( 3, 'DGEHRD', ' ', N, ILO, IHI, -1 ) )
IF( NX.LT.NH ) THEN
*
* Determine if workspace is large enough for blocked code
*
IWS = N*NB
IF( LWORK.LT.IWS ) THEN
*
* Not enough workspace to use optimal NB: determine the
* minimum value of NB, and reduce NB or force use of
* unblocked code
*
NBMIN = MAX( 2, ILAENV( 2, 'DGEHRD', ' ', N, ILO, IHI,
$ -1 ) )
IF( LWORK.GE.N*NBMIN ) THEN
NB = LWORK / N
ELSE
NB = 1
END IF
END IF
END IF
END IF
LDWORK = N
*
IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN
*
* Use unblocked code below
*
I = ILO
*
ELSE
*
* Use blocked code
*
DO 40 I = ILO, IHI - 1 - NX, NB
IB = MIN( NB, IHI-I )
*
* Reduce columns i:i+ib-1 to Hessenberg form, returning the
* matrices V and T of the block reflector H = I - V*T*V'
* which performs the reduction, and also the matrix Y = A*V*T
*
CALL DLAHR2( IHI, I, IB, A( 1, I ), LDA, TAU( I ), T, LDT,
$ WORK, LDWORK )
*
* Apply the block reflector H to A(1:ihi,i+ib:ihi) from the
* right, computing A := A - Y * V'. V(i+ib,ib-1) must be set
* to 1
*
EI = A( I+IB, I+IB-1 )
A( I+IB, I+IB-1 ) = ONE
CALL DGEMM( 'No transpose', 'Transpose',
$ IHI, IHI-I-IB+1,
$ IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE,
$ A( 1, I+IB ), LDA )
A( I+IB, I+IB-1 ) = EI
*
* Apply the block reflector H to A(1:i,i+1:i+ib-1) from the
* right
*
CALL DTRMM( 'Right', 'Lower', 'Transpose',
$ 'Unit', I, IB-1,
$ ONE, A( I+1, I ), LDA, WORK, LDWORK )
DO 30 J = 0, IB-2
CALL DAXPY( I, -ONE, WORK( LDWORK*J+1 ), 1,
$ A( 1, I+J+1 ), 1 )
30 CONTINUE
*
* Apply the block reflector H to A(i+1:ihi,i+ib:n) from the
* left
*
CALL DLARFB( 'Left', 'Transpose', 'Forward',
$ 'Columnwise',
$ IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA, T, LDT,
$ A( I+1, I+IB ), LDA, WORK, LDWORK )
40 CONTINUE
END IF
*
* Use unblocked code to reduce the rest of the matrix
*
CALL DGEHD2( N, I, IHI, A, LDA, TAU, WORK, IINFO )
WORK( 1 ) = IWS
*
RETURN
*
* End of DGEHRD
*
END
SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGELQ2 computes an LQ factorization of a real m by n matrix A:
* A = L * Q.
*
* 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 below the diagonal of the array
* contain the m by min(m,n) lower trapezoidal matrix L (L is
* lower triangular if m <= n); the elements above 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 (M)
*
* 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(k) . . . H(2) H(1), where k = min(m,n).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* 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:n) is stored on exit in A(i,i+1:n),
* 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( 'DGELQ2', -INFO )
RETURN
END IF
*
K = MIN( M, N )
*
DO 10 I = 1, K
*
* Generate elementary reflector H(i) to annihilate A(i,i+1:n)
*
CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA,
$ TAU( I ) )
IF( I.LT.M ) THEN
*
* Apply H(i) to A(i+1:m,i:n) from the right
*
AII = A( I, I )
A( I, I ) = ONE
CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ),
$ A( I+1, I ), LDA, WORK )
A( I, I ) = AII
END IF
10 CONTINUE
RETURN
*
* End of DGELQ2
*
END
SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGELQF computes an LQ factorization of a real M-by-N matrix A:
* A = L * Q.
*
* 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 below the diagonal of the array
* contain the m-by-min(m,n) lower trapezoidal matrix L (L is
* lower triangular if m <= n); the elements above 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/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,M).
* For optimum performance LWORK >= M*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(k) . . . H(2) H(1), where k = min(m,n).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* 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:n) is stored on exit in A(i,i+1:n),
* and tau in TAU(i).
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
$ NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL DGELQ2, 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, 'DGELQF', ' ', M, N, -1, -1 )
LWKOPT = M*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, M ) .AND. .NOT.LQUERY ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGELQF', -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 = M
IF( NB.GT.1 .AND. NB.LT.K ) THEN
*
* Determine when to cross over from blocked to unblocked code.
*
NX = MAX( 0, ILAENV( 3, 'DGELQF', ' ', M, N, -1, -1 ) )
IF( NX.LT.K ) THEN
*
* Determine if workspace is large enough for blocked code.
*
LDWORK = M
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, 'DGELQF', ' ', 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 LQ factorization of the current block
* A(i:i+ib-1,i:n)
*
CALL DGELQ2( IB, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
$ IINFO )
IF( I+IB.LE.M ) THEN
*
* Form the triangular factor of the block reflector
* H = H(i) H(i+1) . . . H(i+ib-1)
*
CALL DLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ),
$ LDA, TAU( I ), WORK, LDWORK )
*
* Apply H to A(i+ib:m,i:n) from the right
*
CALL DLARFB( 'Right', 'No transpose', 'Forward',
$ 'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ),
$ LDA, WORK, LDWORK, A( I+IB, I ), 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 DGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
$ IINFO )
*
WORK( 1 ) = IWS
RETURN
*
* End of DGELQF
*
END
SUBROUTINE DGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK,
$ INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGELS solves overdetermined or underdetermined real linear systems
* involving an M-by-N matrix A, or its transpose, using a QR or LQ
* factorization of A. It is assumed that A has full rank.
*
* The following options are provided:
*
* 1. If TRANS = 'N' and m >= n: find the least squares solution of
* an overdetermined system, i.e., solve the least squares problem
* minimize || B - A*X ||.
*
* 2. If TRANS = 'N' and m < n: find the minimum norm solution of
* an underdetermined system A * X = B.
*
* 3. If TRANS = 'T' and m >= n: find the minimum norm solution of
* an undetermined system A**T * X = B.
*
* 4. If TRANS = 'T' and m < n: find the least squares solution of
* an overdetermined system, i.e., solve the least squares problem
* minimize || B - A**T * X ||.
*
* Several right hand side vectors b and solution vectors x can be
* handled in a single call; they are stored as the columns of the
* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
* matrix X.
*
* Arguments
* =========
*
* TRANS (input) CHARACTER*1
* = 'N': the linear system involves A;
* = 'T': the linear system involves A**T.
*
* 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.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of
* columns of the matrices B and X. NRHS >=0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit,
* if M >= N, A is overwritten by details of its QR
* factorization as returned by DGEQRF;
* if M < N, A is overwritten by details of its LQ
* factorization as returned by DGELQF.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the matrix B of right hand side vectors, stored
* columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS
* if TRANS = 'T'.
* On exit, if INFO = 0, B is overwritten by the solution
* vectors, stored columnwise:
* if TRANS = 'N' and m >= n, rows 1 to n of B contain the least
* squares solution vectors; the residual sum of squares for the
* solution in each column is given by the sum of squares of
* elements N+1 to M in that column;
* if TRANS = 'N' and m < n, rows 1 to N of B contain the
* minimum norm solution vectors;
* if TRANS = 'T' and m >= n, rows 1 to M of B contain the
* minimum norm solution vectors;
* if TRANS = 'T' and m < n, rows 1 to M of B contain the
* least squares solution vectors; the residual sum of squares
* for the solution in each column is given by the sum of
* squares of elements M+1 to N in that column.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= MAX(1,M,N).
*
* 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, MN + max( MN, NRHS ) ).
* For optimal performance,
* LWORK >= max( 1, MN + max( MN, NRHS )*NB ).
* where MN = min(M,N) and NB is the optimum block size.
*
* 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
* > 0: if INFO = i, the i-th diagonal element of the
* triangular factor of A is zero, so that A does not have
* full rank; the least squares solution could not be
* computed.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, TPSD
INTEGER BROW, I, IASCL, IBSCL, J, MN, NB, SCLLEN, WSIZE
DOUBLE PRECISION ANRM, BIGNUM, BNRM, SMLNUM
* ..
* .. Local Arrays ..
DOUBLE PRECISION RWORK( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL LSAME, ILAENV, DLABAD, DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DGELQF, DGEQRF, DLASCL, DLASET, DORMLQ, DORMQR,
$ DTRTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments.
*
INFO = 0
MN = MIN( M, N )
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.( LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'T' ) ) ) THEN
INFO = -1
ELSE IF( M.LT.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -6
ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
INFO = -8
ELSE IF( LWORK.LT.MAX( 1, MN+MAX( MN, NRHS ) ) .AND. .NOT.LQUERY )
$ THEN
INFO = -10
END IF
*
* Figure out optimal block size
*
IF( INFO.EQ.0 .OR. INFO.EQ.-10 ) THEN
*
TPSD = .TRUE.
IF( LSAME( TRANS, 'N' ) )
$ TPSD = .FALSE.
*
IF( M.GE.N ) THEN
NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
IF( TPSD ) THEN
NB = MAX( NB, ILAENV( 1, 'DORMQR', 'LN', M, NRHS, N,
$ -1 ) )
ELSE
NB = MAX( NB, ILAENV( 1, 'DORMQR', 'LT', M, NRHS, N,
$ -1 ) )
END IF
ELSE
NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
IF( TPSD ) THEN
NB = MAX( NB, ILAENV( 1, 'DORMLQ', 'LT', N, NRHS, M,
$ -1 ) )
ELSE
NB = MAX( NB, ILAENV( 1, 'DORMLQ', 'LN', N, NRHS, M,
$ -1 ) )
END IF
END IF
*
WSIZE = MAX( 1, MN+MAX( MN, NRHS )*NB )
WORK( 1 ) = DBLE( WSIZE )
*
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGELS ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( MIN( M, N, NRHS ).EQ.0 ) THEN
CALL DLASET( 'Full', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
RETURN
END IF
*
* Get machine parameters
*
SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' )
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
*
* Scale A, B if max element outside range [SMLNUM,BIGNUM]
*
ANRM = DLANGE( 'M', M, N, A, LDA, RWORK )
IASCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
IASCL = 1
ELSE IF( ANRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
IASCL = 2
ELSE IF( ANRM.EQ.ZERO ) THEN
*
* Matrix all zero. Return zero solution.
*
CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
GO TO 50
END IF
*
BROW = M
IF( TPSD )
$ BROW = N
BNRM = DLANGE( 'M', BROW, NRHS, B, LDB, RWORK )
IBSCL = 0
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, BROW, NRHS, B, LDB,
$ INFO )
IBSCL = 1
ELSE IF( BNRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, BROW, NRHS, B, LDB,
$ INFO )
IBSCL = 2
END IF
*
IF( M.GE.N ) THEN
*
* compute QR factorization of A
*
CALL DGEQRF( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ), LWORK-MN,
$ INFO )
*
* workspace at least N, optimally N*NB
*
IF( .NOT.TPSD ) THEN
*
* Least-Squares Problem min || A * X - B ||
*
* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS)
*
CALL DORMQR( 'Left', 'Transpose', M, NRHS, N, A, LDA,
$ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
$ INFO )
*
* workspace at least NRHS, optimally NRHS*NB
*
* B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS)
*
CALL DTRTRS( 'Upper', 'No transpose', 'Non-unit', N, NRHS,
$ A, LDA, B, LDB, INFO )
*
IF( INFO.GT.0 ) THEN
RETURN
END IF
*
SCLLEN = N
*
ELSE
*
* Overdetermined system of equations A' * X = B
*
* B(1:N,1:NRHS) := inv(R') * B(1:N,1:NRHS)
*
CALL DTRTRS( 'Upper', 'Transpose', 'Non-unit', N, NRHS,
$ A, LDA, B, LDB, INFO )
*
IF( INFO.GT.0 ) THEN
RETURN
END IF
*
* B(N+1:M,1:NRHS) = ZERO
*
DO 20 J = 1, NRHS
DO 10 I = N + 1, M
B( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
*
* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS)
*
CALL DORMQR( 'Left', 'No transpose', M, NRHS, N, A, LDA,
$ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
$ INFO )
*
* workspace at least NRHS, optimally NRHS*NB
*
SCLLEN = M
*
END IF
*
ELSE
*
* Compute LQ factorization of A
*
CALL DGELQF( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ), LWORK-MN,
$ INFO )
*
* workspace at least M, optimally M*NB.
*
IF( .NOT.TPSD ) THEN
*
* underdetermined system of equations A * X = B
*
* B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS)
*
CALL DTRTRS( 'Lower', 'No transpose', 'Non-unit', M, NRHS,
$ A, LDA, B, LDB, INFO )
*
IF( INFO.GT.0 ) THEN
RETURN
END IF
*
* B(M+1:N,1:NRHS) = 0
*
DO 40 J = 1, NRHS
DO 30 I = M + 1, N
B( I, J ) = ZERO
30 CONTINUE
40 CONTINUE
*
* B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS)
*
CALL DORMLQ( 'Left', 'Transpose', N, NRHS, M, A, LDA,
$ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
$ INFO )
*
* workspace at least NRHS, optimally NRHS*NB
*
SCLLEN = N
*
ELSE
*
* overdetermined system min || A' * X - B ||
*
* B(1:N,1:NRHS) := Q * B(1:N,1:NRHS)
*
CALL DORMLQ( 'Left', 'No transpose', N, NRHS, M, A, LDA,
$ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
$ INFO )
*
* workspace at least NRHS, optimally NRHS*NB
*
* B(1:M,1:NRHS) := inv(L') * B(1:M,1:NRHS)
*
CALL DTRTRS( 'Lower', 'Transpose', 'Non-unit', M, NRHS,
$ A, LDA, B, LDB, INFO )
*
IF( INFO.GT.0 ) THEN
RETURN
END IF
*
SCLLEN = M
*
END IF
*
END IF
*
* Undo scaling
*
IF( IASCL.EQ.1 ) THEN
CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, SCLLEN, NRHS, B, LDB,
$ INFO )
ELSE IF( IASCL.EQ.2 ) THEN
CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, SCLLEN, NRHS, B, LDB,
$ INFO )
END IF
IF( IBSCL.EQ.1 ) THEN
CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, SCLLEN, NRHS, B, LDB,
$ INFO )
ELSE IF( IBSCL.EQ.2 ) THEN
CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, SCLLEN, NRHS, B, LDB,
$ INFO )
END IF
*
50 CONTINUE
WORK( 1 ) = DBLE( WSIZE )
*
RETURN
*
* End of DGELS
*
END
SUBROUTINE DGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK,
$ WORK, LWORK, IWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGELSD computes the minimum-norm solution to a real linear least
* squares problem:
* minimize 2-norm(| b - A*x |)
* using the singular value decomposition (SVD) of A. A is an M-by-N
* matrix which may be rank-deficient.
*
* Several right hand side vectors b and solution vectors x can be
* handled in a single call; they are stored as the columns of the
* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
* matrix X.
*
* The problem is solved in three steps:
* (1) Reduce the coefficient matrix A to bidiagonal form with
* Householder transformations, reducing the original problem
* into a "bidiagonal least squares problem" (BLS)
* (2) Solve the BLS using a divide and conquer approach.
* (3) Apply back all the Householder tranformations to solve
* the original least squares problem.
*
* The effective rank of A is determined by treating as zero those
* singular values which are less than RCOND times the largest singular
* value.
*
* The divide and conquer algorithm makes very mild assumptions about
* floating point arithmetic. It will work on machines with a guard
* digit in add/subtract, or on those binary machines without guard
* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
* Cray-2. It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of A. M >= 0.
*
* N (input) INTEGER
* The number of columns of A. N >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrices B and X. NRHS >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, A has been destroyed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the M-by-NRHS right hand side matrix B.
* On exit, B is overwritten by the N-by-NRHS solution
* matrix X. If m >= n and RANK = n, the residual
* sum-of-squares for the solution in the i-th column is given
* by the sum of squares of elements n+1:m in that column.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,max(M,N)).
*
* S (output) DOUBLE PRECISION array, dimension (min(M,N))
* The singular values of A in decreasing order.
* The condition number of A in the 2-norm = S(1)/S(min(m,n)).
*
* RCOND (input) DOUBLE PRECISION
* RCOND is used to determine the effective rank of A.
* Singular values S(i) <= RCOND*S(1) are treated as zero.
* If RCOND < 0, machine precision is used instead.
*
* RANK (output) INTEGER
* The effective rank of A, i.e., the number of singular values
* which are greater than RCOND*S(1).
*
* 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 must be at least 1.
* The exact minimum amount of workspace needed depends on M,
* N and NRHS. As long as LWORK is at least
* 12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2,
* if M is greater than or equal to N or
* 12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2,
* if M is less than N, the code will execute correctly.
* SMLSIZ is returned by ILAENV and is equal to the maximum
* size of the subproblems at the bottom of the computation
* tree (usually about 25), and
* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )
* For good performance, LWORK should generally be larger.
*
* 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.
*
* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))
* LIWORK >= 3 * MINMN * NLVL + 11 * MINMN,
* where MINMN = MIN( M,N ).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: the algorithm for computing the SVD failed to converge;
* if INFO = i, i off-diagonal elements of an intermediate
* bidiagonal form did not converge to zero.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Ren-Cang Li, Computer Science Division, University of
* California at Berkeley, USA
* Osni Marques, LBNL/NERSC, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER IASCL, IBSCL, IE, IL, ITAU, ITAUP, ITAUQ,
$ LDWORK, MAXMN, MAXWRK, MINMN, MINWRK, MM,
$ MNTHR, NLVL, NWORK, SMLSIZ, WLALSD
DOUBLE PRECISION ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM
* ..
* .. External Subroutines ..
EXTERNAL DGEBRD, DGELQF, DGEQRF, DLABAD, DLACPY, DLALSD,
$ DLASCL, DLASET, DORMBR, DORMLQ, DORMQR, XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL ILAENV, DLAMCH, DLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, INT, LOG, MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments.
*
INFO = 0
MINMN = MIN( M, N )
MAXMN = MAX( M, N )
MNTHR = ILAENV( 6, 'DGELSD', ' ', M, N, NRHS, -1 )
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) 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, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN
INFO = -7
END IF
*
SMLSIZ = ILAENV( 9, 'DGELSD', ' ', 0, 0, 0, 0 )
*
* Compute workspace.
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.)
*
MINWRK = 1
MINMN = MAX( 1, MINMN )
NLVL = MAX( INT( LOG( DBLE( MINMN ) / DBLE( SMLSIZ+1 ) ) /
$ LOG( TWO ) ) + 1, 0 )
*
IF( INFO.EQ.0 ) THEN
MAXWRK = 0
MM = M
IF( M.GE.N .AND. M.GE.MNTHR ) THEN
*
* Path 1a - overdetermined, with many more rows than columns.
*
MM = N
MAXWRK = MAX( MAXWRK, N+N*ILAENV( 1, 'DGEQRF', ' ', M, N,
$ -1, -1 ) )
MAXWRK = MAX( MAXWRK, N+NRHS*
$ ILAENV( 1, 'DORMQR', 'LT', M, NRHS, N, -1 ) )
END IF
IF( M.GE.N ) THEN
*
* Path 1 - overdetermined or exactly determined.
*
MAXWRK = MAX( MAXWRK, 3*N+( MM+N )*
$ ILAENV( 1, 'DGEBRD', ' ', MM, N, -1, -1 ) )
MAXWRK = MAX( MAXWRK, 3*N+NRHS*
$ ILAENV( 1, 'DORMBR', 'QLT', MM, NRHS, N, -1 ) )
MAXWRK = MAX( MAXWRK, 3*N+( N-1 )*
$ ILAENV( 1, 'DORMBR', 'PLN', N, NRHS, N, -1 ) )
WLALSD = 9*N+2*N*SMLSIZ+8*N*NLVL+N*NRHS+(SMLSIZ+1)**2
MAXWRK = MAX( MAXWRK, 3*N+WLALSD )
MINWRK = MAX( 3*N+MM, 3*N+NRHS, 3*N+WLALSD )
END IF
IF( N.GT.M ) THEN
WLALSD = 9*M+2*M*SMLSIZ+8*M*NLVL+M*NRHS+(SMLSIZ+1)**2
IF( N.GE.MNTHR ) THEN
*
* Path 2a - underdetermined, with many more columns
* than rows.
*
MAXWRK = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
MAXWRK = MAX( MAXWRK, M*M+4*M+2*M*
$ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
MAXWRK = MAX( MAXWRK, M*M+4*M+NRHS*
$ ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, M, -1 ) )
MAXWRK = MAX( MAXWRK, M*M+4*M+( M-1 )*
$ ILAENV( 1, 'DORMBR', 'PLN', M, NRHS, M, -1 ) )
IF( NRHS.GT.1 ) THEN
MAXWRK = MAX( MAXWRK, M*M+M+M*NRHS )
ELSE
MAXWRK = MAX( MAXWRK, M*M+2*M )
END IF
MAXWRK = MAX( MAXWRK, M+NRHS*
$ ILAENV( 1, 'DORMLQ', 'LT', N, NRHS, M, -1 ) )
MAXWRK = MAX( MAXWRK, M*M+4*M+WLALSD )
ELSE
*
* Path 2 - remaining underdetermined cases.
*
MAXWRK = 3*M + ( N+M )*ILAENV( 1, 'DGEBRD', ' ', M, N,
$ -1, -1 )
MAXWRK = MAX( MAXWRK, 3*M+NRHS*
$ ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, N, -1 ) )
MAXWRK = MAX( MAXWRK, 3*M+M*
$ ILAENV( 1, 'DORMBR', 'PLN', N, NRHS, M, -1 ) )
MAXWRK = MAX( MAXWRK, 3*M+WLALSD )
END IF
MINWRK = MAX( 3*M+NRHS, 3*M+M, 3*M+WLALSD )
END IF
MINWRK = MIN( MINWRK, MAXWRK )
WORK( 1 ) = MAXWRK
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGELSD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
GO TO 10
END IF
*
* Quick return if possible.
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
RANK = 0
RETURN
END IF
*
* Get machine parameters.
*
EPS = DLAMCH( 'P' )
SFMIN = DLAMCH( 'S' )
SMLNUM = SFMIN / EPS
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
*
* Scale A if max entry outside range [SMLNUM,BIGNUM].
*
ANRM = DLANGE( 'M', M, N, A, LDA, WORK )
IASCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM.
*
CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
IASCL = 1
ELSE IF( ANRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM.
*
CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
IASCL = 2
ELSE IF( ANRM.EQ.ZERO ) THEN
*
* Matrix all zero. Return zero solution.
*
CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
CALL DLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 )
RANK = 0
GO TO 10
END IF
*
* Scale B if max entry outside range [SMLNUM,BIGNUM].
*
BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK )
IBSCL = 0
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM.
*
CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
IBSCL = 1
ELSE IF( BNRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM.
*
CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
IBSCL = 2
END IF
*
* If M < N make sure certain entries of B are zero.
*
IF( M.LT.N )
$ CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB )
*
* Overdetermined case.
*
IF( M.GE.N ) THEN
*
* Path 1 - overdetermined or exactly determined.
*
MM = M
IF( M.GE.MNTHR ) THEN
*
* Path 1a - overdetermined, with many more rows than columns.
*
MM = N
ITAU = 1
NWORK = ITAU + N
*
* Compute A=Q*R.
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, INFO )
*
* Multiply B by transpose(Q).
* (Workspace: need N+NRHS, prefer N+NRHS*NB)
*
CALL DORMQR( 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAU ), B,
$ LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
* Zero out below R.
*
IF( N.GT.1 ) THEN
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
END IF
END IF
*
IE = 1
ITAUQ = IE + N
ITAUP = ITAUQ + N
NWORK = ITAUP + N
*
* Bidiagonalize R in A.
* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB)
*
CALL DGEBRD( MM, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ INFO )
*
* Multiply B by transpose of left bidiagonalizing vectors of R.
* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB)
*
CALL DORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, WORK( ITAUQ ),
$ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
* Solve the bidiagonal least squares problem.
*
CALL DLALSD( 'U', SMLSIZ, N, NRHS, S, WORK( IE ), B, LDB,
$ RCOND, RANK, WORK( NWORK ), IWORK, INFO )
IF( INFO.NE.0 ) THEN
GO TO 10
END IF
*
* Multiply B by right bidiagonalizing vectors of R.
*
CALL DORMBR( 'P', 'L', 'N', N, NRHS, N, A, LDA, WORK( ITAUP ),
$ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+
$ MAX( M, 2*M-4, NRHS, N-3*M, WLALSD ) ) THEN
*
* Path 2a - underdetermined, with many more columns than rows
* and sufficient workspace for an efficient algorithm.
*
LDWORK = M
IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ),
$ M*LDA+M+M*NRHS, 4*M+M*LDA+WLALSD ) )LDWORK = LDA
ITAU = 1
NWORK = M + 1
*
* Compute A=L*Q.
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, INFO )
IL = NWORK
*
* Copy L to WORK(IL), zeroing out above its diagonal.
*
CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK )
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( IL+LDWORK ),
$ LDWORK )
IE = IL + LDWORK*M
ITAUQ = IE + M
ITAUP = ITAUQ + M
NWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IL).
* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB)
*
CALL DGEBRD( M, M, WORK( IL ), LDWORK, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
$ LWORK-NWORK+1, INFO )
*
* Multiply B by transpose of left bidiagonalizing vectors of L.
* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB)
*
CALL DORMBR( 'Q', 'L', 'T', M, NRHS, M, WORK( IL ), LDWORK,
$ WORK( ITAUQ ), B, LDB, WORK( NWORK ),
$ LWORK-NWORK+1, INFO )
*
* Solve the bidiagonal least squares problem.
*
CALL DLALSD( 'U', SMLSIZ, M, NRHS, S, WORK( IE ), B, LDB,
$ RCOND, RANK, WORK( NWORK ), IWORK, INFO )
IF( INFO.NE.0 ) THEN
GO TO 10
END IF
*
* Multiply B by right bidiagonalizing vectors of L.
*
CALL DORMBR( 'P', 'L', 'N', M, NRHS, M, WORK( IL ), LDWORK,
$ WORK( ITAUP ), B, LDB, WORK( NWORK ),
$ LWORK-NWORK+1, INFO )
*
* Zero out below first M rows of B.
*
CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB )
NWORK = ITAU + M
*
* Multiply transpose(Q) by B.
* (Workspace: need M+NRHS, prefer M+NRHS*NB)
*
CALL DORMLQ( 'L', 'T', N, NRHS, M, A, LDA, WORK( ITAU ), B,
$ LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
ELSE
*
* Path 2 - remaining underdetermined cases.
*
IE = 1
ITAUQ = IE + M
ITAUP = ITAUQ + M
NWORK = ITAUP + M
*
* Bidiagonalize A.
* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
*
CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ INFO )
*
* Multiply B by transpose of left bidiagonalizing vectors.
* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB)
*
CALL DORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAUQ ),
$ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
* Solve the bidiagonal least squares problem.
*
CALL DLALSD( 'L', SMLSIZ, M, NRHS, S, WORK( IE ), B, LDB,
$ RCOND, RANK, WORK( NWORK ), IWORK, INFO )
IF( INFO.NE.0 ) THEN
GO TO 10
END IF
*
* Multiply B by right bidiagonalizing vectors of A.
*
CALL DORMBR( 'P', 'L', 'N', N, NRHS, M, A, LDA, WORK( ITAUP ),
$ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
END IF
*
* Undo scaling.
*
IF( IASCL.EQ.1 ) THEN
CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
$ INFO )
ELSE IF( IASCL.EQ.2 ) THEN
CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
$ INFO )
END IF
IF( IBSCL.EQ.1 ) THEN
CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
ELSE IF( IBSCL.EQ.2 ) THEN
CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
END IF
*
10 CONTINUE
WORK( 1 ) = MAXWRK
RETURN
*
* End of DGELSD
*
END
SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK,
$ WORK, LWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGELSS computes the minimum norm solution to a real linear least
* squares problem:
*
* Minimize 2-norm(| b - A*x |).
*
* using the singular value decomposition (SVD) of A. A is an M-by-N
* matrix which may be rank-deficient.
*
* Several right hand side vectors b and solution vectors x can be
* handled in a single call; they are stored as the columns of the
* M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix
* X.
*
* The effective rank of A is determined by treating as zero those
* singular values which are less than RCOND times the largest singular
* value.
*
* 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.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrices B and X. NRHS >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, the first min(m,n) rows of A are overwritten with
* its right singular vectors, stored rowwise.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the M-by-NRHS right hand side matrix B.
* On exit, B is overwritten by the N-by-NRHS solution
* matrix X. If m >= n and RANK = n, the residual
* sum-of-squares for the solution in the i-th column is given
* by the sum of squares of elements n+1:m in that column.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,max(M,N)).
*
* S (output) DOUBLE PRECISION array, dimension (min(M,N))
* The singular values of A in decreasing order.
* The condition number of A in the 2-norm = S(1)/S(min(m,n)).
*
* RCOND (input) DOUBLE PRECISION
* RCOND is used to determine the effective rank of A.
* Singular values S(i) <= RCOND*S(1) are treated as zero.
* If RCOND < 0, machine precision is used instead.
*
* RANK (output) INTEGER
* The effective rank of A, i.e., the number of singular values
* which are greater than RCOND*S(1).
*
* 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 >= 1, and also:
* LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS )
* For good performance, LWORK should generally be larger.
*
* 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.
* > 0: the algorithm for computing the SVD failed to converge;
* if INFO = i, i off-diagonal elements of an intermediate
* bidiagonal form did not converge to zero.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER BDSPAC, BL, CHUNK, I, IASCL, IBSCL, IE, IL,
$ ITAU, ITAUP, ITAUQ, IWORK, LDWORK, MAXMN,
$ MAXWRK, MINMN, MINWRK, MM, MNTHR
DOUBLE PRECISION ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM, THR
* ..
* .. Local Arrays ..
DOUBLE PRECISION VDUM( 1 )
* ..
* .. External Subroutines ..
EXTERNAL DBDSQR, DCOPY, DGEBRD, DGELQF, DGEMM, DGEMV,
$ DGEQRF, DLABAD, DLACPY, DLASCL, DLASET, DORGBR,
$ DORMBR, DORMLQ, DORMQR, DRSCL, XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL ILAENV, DLAMCH, DLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
MINMN = MIN( M, N )
MAXMN = MAX( M, N )
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) 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, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN
INFO = -7
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.)
*
IF( INFO.EQ.0 ) THEN
MINWRK = 1
MAXWRK = 1
IF( MINMN.GT.0 ) THEN
MM = M
MNTHR = ILAENV( 6, 'DGELSS', ' ', M, N, NRHS, -1 )
IF( M.GE.N .AND. M.GE.MNTHR ) THEN
*
* Path 1a - overdetermined, with many more rows than
* columns
*
MM = N
MAXWRK = MAX( MAXWRK, N + N*ILAENV( 1, 'DGEQRF', ' ', M,
$ N, -1, -1 ) )
MAXWRK = MAX( MAXWRK, N + NRHS*ILAENV( 1, 'DORMQR', 'LT',
$ M, NRHS, N, -1 ) )
END IF
IF( M.GE.N ) THEN
*
* Path 1 - overdetermined or exactly determined
*
* Compute workspace needed for DBDSQR
*
BDSPAC = MAX( 1, 5*N )
MAXWRK = MAX( MAXWRK, 3*N + ( MM + N )*ILAENV( 1,
$ 'DGEBRD', ' ', MM, N, -1, -1 ) )
MAXWRK = MAX( MAXWRK, 3*N + NRHS*ILAENV( 1, 'DORMBR',
$ 'QLT', MM, NRHS, N, -1 ) )
MAXWRK = MAX( MAXWRK, 3*N + ( N - 1 )*ILAENV( 1,
$ 'DORGBR', 'P', N, N, N, -1 ) )
MAXWRK = MAX( MAXWRK, BDSPAC )
MAXWRK = MAX( MAXWRK, N*NRHS )
MINWRK = MAX( 3*N + MM, 3*N + NRHS, BDSPAC )
MAXWRK = MAX( MINWRK, MAXWRK )
END IF
IF( N.GT.M ) THEN
*
* Compute workspace needed for DBDSQR
*
BDSPAC = MAX( 1, 5*M )
MINWRK = MAX( 3*M+NRHS, 3*M+N, BDSPAC )
IF( N.GE.MNTHR ) THEN
*
* Path 2a - underdetermined, with many more columns
* than rows
*
MAXWRK = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1,
$ -1 )
MAXWRK = MAX( MAXWRK, M*M + 4*M + 2*M*ILAENV( 1,
$ 'DGEBRD', ' ', M, M, -1, -1 ) )
MAXWRK = MAX( MAXWRK, M*M + 4*M + NRHS*ILAENV( 1,
$ 'DORMBR', 'QLT', M, NRHS, M, -1 ) )
MAXWRK = MAX( MAXWRK, M*M + 4*M +
$ ( M - 1 )*ILAENV( 1, 'DORGBR', 'P', M,
$ M, M, -1 ) )
MAXWRK = MAX( MAXWRK, M*M + M + BDSPAC )
IF( NRHS.GT.1 ) THEN
MAXWRK = MAX( MAXWRK, M*M + M + M*NRHS )
ELSE
MAXWRK = MAX( MAXWRK, M*M + 2*M )
END IF
MAXWRK = MAX( MAXWRK, M + NRHS*ILAENV( 1, 'DORMLQ',
$ 'LT', N, NRHS, M, -1 ) )
ELSE
*
* Path 2 - underdetermined
*
MAXWRK = 3*M + ( N + M )*ILAENV( 1, 'DGEBRD', ' ', M,
$ N, -1, -1 )
MAXWRK = MAX( MAXWRK, 3*M + NRHS*ILAENV( 1, 'DORMBR',
$ 'QLT', M, NRHS, M, -1 ) )
MAXWRK = MAX( MAXWRK, 3*M + M*ILAENV( 1, 'DORGBR',
$ 'P', M, N, M, -1 ) )
MAXWRK = MAX( MAXWRK, BDSPAC )
MAXWRK = MAX( MAXWRK, N*NRHS )
END IF
END IF
MAXWRK = MAX( MINWRK, MAXWRK )
END IF
WORK( 1 ) = MAXWRK
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY )
$ INFO = -12
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGELSS', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
RANK = 0
RETURN
END IF
*
* Get machine parameters
*
EPS = DLAMCH( 'P' )
SFMIN = DLAMCH( 'S' )
SMLNUM = SFMIN / EPS
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = DLANGE( 'M', M, N, A, LDA, WORK )
IASCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
IASCL = 1
ELSE IF( ANRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
IASCL = 2
ELSE IF( ANRM.EQ.ZERO ) THEN
*
* Matrix all zero. Return zero solution.
*
CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
CALL DLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 )
RANK = 0
GO TO 70
END IF
*
* Scale B if max element outside range [SMLNUM,BIGNUM]
*
BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK )
IBSCL = 0
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
IBSCL = 1
ELSE IF( BNRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
IBSCL = 2
END IF
*
* Overdetermined case
*
IF( M.GE.N ) THEN
*
* Path 1 - overdetermined or exactly determined
*
MM = M
IF( M.GE.MNTHR ) THEN
*
* Path 1a - overdetermined, with many more rows than columns
*
MM = N
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
$ LWORK-IWORK+1, INFO )
*
* Multiply B by transpose(Q)
* (Workspace: need N+NRHS, prefer N+NRHS*NB)
*
CALL DORMQR( 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAU ), B,
$ LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
*
* Zero out below R
*
IF( N.GT.1 )
$ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
END IF
*
IE = 1
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in A
* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB)
*
CALL DGEBRD( MM, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
$ INFO )
*
* Multiply B by transpose of left bidiagonalizing vectors of R
* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB)
*
CALL DORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, WORK( ITAUQ ),
$ B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
*
* Generate right bidiagonalizing vectors of R in A
* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
*
CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, INFO )
IWORK = IE + N
*
* Perform bidiagonal QR iteration
* multiply B by transpose of left singular vectors
* compute right singular vectors in A
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', N, N, 0, NRHS, S, WORK( IE ), A, LDA, VDUM,
$ 1, B, LDB, WORK( IWORK ), INFO )
IF( INFO.NE.0 )
$ GO TO 70
*
* Multiply B by reciprocals of singular values
*
THR = MAX( RCOND*S( 1 ), SFMIN )
IF( RCOND.LT.ZERO )
$ THR = MAX( EPS*S( 1 ), SFMIN )
RANK = 0
DO 10 I = 1, N
IF( S( I ).GT.THR ) THEN
CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB )
RANK = RANK + 1
ELSE
CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
END IF
10 CONTINUE
*
* Multiply B by right singular vectors
* (Workspace: need N, prefer N*NRHS)
*
IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN
CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, A, LDA, B, LDB, ZERO,
$ WORK, LDB )
CALL DLACPY( 'G', N, NRHS, WORK, LDB, B, LDB )
ELSE IF( NRHS.GT.1 ) THEN
CHUNK = LWORK / N
DO 20 I = 1, NRHS, CHUNK
BL = MIN( NRHS-I+1, CHUNK )
CALL DGEMM( 'T', 'N', N, BL, N, ONE, A, LDA, B( 1, I ),
$ LDB, ZERO, WORK, N )
CALL DLACPY( 'G', N, BL, WORK, N, B( 1, I ), LDB )
20 CONTINUE
ELSE
CALL DGEMV( 'T', N, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 )
CALL DCOPY( N, WORK, 1, B, 1 )
END IF
*
ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+
$ MAX( M, 2*M-4, NRHS, N-3*M ) ) THEN
*
* Path 2a - underdetermined, with many more columns than rows
* and sufficient workspace for an efficient algorithm
*
LDWORK = M
IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ),
$ M*LDA+M+M*NRHS ) )LDWORK = LDA
ITAU = 1
IWORK = M + 1
*
* Compute A=L*Q
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
$ LWORK-IWORK+1, INFO )
IL = IWORK
*
* Copy L to WORK(IL), zeroing out above it
*
CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK )
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( IL+LDWORK ),
$ LDWORK )
IE = IL + LDWORK*M
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IL)
* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB)
*
CALL DGEBRD( M, M, WORK( IL ), LDWORK, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, INFO )
*
* Multiply B by transpose of left bidiagonalizing vectors of L
* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB)
*
CALL DORMBR( 'Q', 'L', 'T', M, NRHS, M, WORK( IL ), LDWORK,
$ WORK( ITAUQ ), B, LDB, WORK( IWORK ),
$ LWORK-IWORK+1, INFO )
*
* Generate right bidiagonalizing vectors of R in WORK(IL)
* (Workspace: need M*M+5*M-1, prefer M*M+4*M+(M-1)*NB)
*
CALL DORGBR( 'P', M, M, M, WORK( IL ), LDWORK, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, INFO )
IWORK = IE + M
*
* Perform bidiagonal QR iteration,
* computing right singular vectors of L in WORK(IL) and
* multiplying B by transpose of left singular vectors
* (Workspace: need M*M+M+BDSPAC)
*
CALL DBDSQR( 'U', M, M, 0, NRHS, S, WORK( IE ), WORK( IL ),
$ LDWORK, A, LDA, B, LDB, WORK( IWORK ), INFO )
IF( INFO.NE.0 )
$ GO TO 70
*
* Multiply B by reciprocals of singular values
*
THR = MAX( RCOND*S( 1 ), SFMIN )
IF( RCOND.LT.ZERO )
$ THR = MAX( EPS*S( 1 ), SFMIN )
RANK = 0
DO 30 I = 1, M
IF( S( I ).GT.THR ) THEN
CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB )
RANK = RANK + 1
ELSE
CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
END IF
30 CONTINUE
IWORK = IE
*
* Multiply B by right singular vectors of L in WORK(IL)
* (Workspace: need M*M+2*M, prefer M*M+M+M*NRHS)
*
IF( LWORK.GE.LDB*NRHS+IWORK-1 .AND. NRHS.GT.1 ) THEN
CALL DGEMM( 'T', 'N', M, NRHS, M, ONE, WORK( IL ), LDWORK,
$ B, LDB, ZERO, WORK( IWORK ), LDB )
CALL DLACPY( 'G', M, NRHS, WORK( IWORK ), LDB, B, LDB )
ELSE IF( NRHS.GT.1 ) THEN
CHUNK = ( LWORK-IWORK+1 ) / M
DO 40 I = 1, NRHS, CHUNK
BL = MIN( NRHS-I+1, CHUNK )
CALL DGEMM( 'T', 'N', M, BL, M, ONE, WORK( IL ), LDWORK,
$ B( 1, I ), LDB, ZERO, WORK( IWORK ), M )
CALL DLACPY( 'G', M, BL, WORK( IWORK ), M, B( 1, I ),
$ LDB )
40 CONTINUE
ELSE
CALL DGEMV( 'T', M, M, ONE, WORK( IL ), LDWORK, B( 1, 1 ),
$ 1, ZERO, WORK( IWORK ), 1 )
CALL DCOPY( M, WORK( IWORK ), 1, B( 1, 1 ), 1 )
END IF
*
* Zero out below first M rows of B
*
CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB )
IWORK = ITAU + M
*
* Multiply transpose(Q) by B
* (Workspace: need M+NRHS, prefer M+NRHS*NB)
*
CALL DORMLQ( 'L', 'T', N, NRHS, M, A, LDA, WORK( ITAU ), B,
$ LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
*
ELSE
*
* Path 2 - remaining underdetermined cases
*
IE = 1
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize A
* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
*
CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
$ INFO )
*
* Multiply B by transpose of left bidiagonalizing vectors
* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB)
*
CALL DORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAUQ ),
$ B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
*
* Generate right bidiagonalizing vectors in A
* (Workspace: need 4*M, prefer 3*M+M*NB)
*
CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, INFO )
IWORK = IE + M
*
* Perform bidiagonal QR iteration,
* computing right singular vectors of A in A and
* multiplying B by transpose of left singular vectors
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'L', M, N, 0, NRHS, S, WORK( IE ), A, LDA, VDUM,
$ 1, B, LDB, WORK( IWORK ), INFO )
IF( INFO.NE.0 )
$ GO TO 70
*
* Multiply B by reciprocals of singular values
*
THR = MAX( RCOND*S( 1 ), SFMIN )
IF( RCOND.LT.ZERO )
$ THR = MAX( EPS*S( 1 ), SFMIN )
RANK = 0
DO 50 I = 1, M
IF( S( I ).GT.THR ) THEN
CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB )
RANK = RANK + 1
ELSE
CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
END IF
50 CONTINUE
*
* Multiply B by right singular vectors of A
* (Workspace: need N, prefer N*NRHS)
*
IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN
CALL DGEMM( 'T', 'N', N, NRHS, M, ONE, A, LDA, B, LDB, ZERO,
$ WORK, LDB )
CALL DLACPY( 'F', N, NRHS, WORK, LDB, B, LDB )
ELSE IF( NRHS.GT.1 ) THEN
CHUNK = LWORK / N
DO 60 I = 1, NRHS, CHUNK
BL = MIN( NRHS-I+1, CHUNK )
CALL DGEMM( 'T', 'N', N, BL, M, ONE, A, LDA, B( 1, I ),
$ LDB, ZERO, WORK, N )
CALL DLACPY( 'F', N, BL, WORK, N, B( 1, I ), LDB )
60 CONTINUE
ELSE
CALL DGEMV( 'T', M, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 )
CALL DCOPY( N, WORK, 1, B, 1 )
END IF
END IF
*
* Undo scaling
*
IF( IASCL.EQ.1 ) THEN
CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
$ INFO )
ELSE IF( IASCL.EQ.2 ) THEN
CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
$ INFO )
END IF
IF( IBSCL.EQ.1 ) THEN
CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
ELSE IF( IBSCL.EQ.2 ) THEN
CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
END IF
*
70 CONTINUE
WORK( 1 ) = MAXWRK
RETURN
*
* End of DGELSS
*
END
SUBROUTINE DGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK,
$ WORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, M, N, NRHS, RANK
DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
INTEGER JPVT( * )
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* This routine is deprecated and has been replaced by routine DGELSY.
*
* DGELSX computes the minimum-norm solution to a real linear least
* squares problem:
* minimize || A * X - B ||
* using a complete orthogonal factorization of A. A is an M-by-N
* matrix which may be rank-deficient.
*
* Several right hand side vectors b and solution vectors x can be
* handled in a single call; they are stored as the columns of the
* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
* matrix X.
*
* The routine first computes a QR factorization with column pivoting:
* A * P = Q * [ R11 R12 ]
* [ 0 R22 ]
* with R11 defined as the largest leading submatrix whose estimated
* condition number is less than 1/RCOND. The order of R11, RANK,
* is the effective rank of A.
*
* Then, R22 is considered to be negligible, and R12 is annihilated
* by orthogonal transformations from the right, arriving at the
* complete orthogonal factorization:
* A * P = Q * [ T11 0 ] * Z
* [ 0 0 ]
* The minimum-norm solution is then
* X = P * Z' [ inv(T11)*Q1'*B ]
* [ 0 ]
* where Q1 consists of the first RANK columns of Q.
*
* 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.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of
* columns of matrices B and X. NRHS >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, A has been overwritten by details of its
* complete orthogonal factorization.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the M-by-NRHS right hand side matrix B.
* On exit, the N-by-NRHS solution matrix X.
* If m >= n and RANK = n, the residual sum-of-squares for
* the solution in the i-th column is given by the sum of
* squares of elements N+1:M in that column.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,M,N).
*
* JPVT (input/output) INTEGER array, dimension (N)
* On entry, if JPVT(i) .ne. 0, the i-th column of A is an
* initial column, otherwise it is a free column. Before
* the QR factorization of A, all initial columns are
* permuted to the leading positions; only the remaining
* free columns are moved as a result of column pivoting
* during the factorization.
* On exit, if JPVT(i) = k, then the i-th column of A*P
* was the k-th column of A.
*
* RCOND (input) DOUBLE PRECISION
* RCOND is used to determine the effective rank of A, which
* is defined as the order of the largest leading triangular
* submatrix R11 in the QR factorization with pivoting of A,
* whose estimated condition number < 1/RCOND.
*
* RANK (output) INTEGER
* The effective rank of A, i.e., the order of the submatrix
* R11. This is the same as the order of the submatrix T11
* in the complete orthogonal factorization of A.
*
* WORK (workspace) DOUBLE PRECISION array, dimension
* (max( min(M,N)+3*N, 2*min(M,N)+NRHS )),
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
INTEGER IMAX, IMIN
PARAMETER ( IMAX = 1, IMIN = 2 )
DOUBLE PRECISION ZERO, ONE, DONE, NTDONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, DONE = ZERO,
$ NTDONE = ONE )
* ..
* .. Local Scalars ..
INTEGER I, IASCL, IBSCL, ISMAX, ISMIN, J, K, MN
DOUBLE PRECISION ANRM, BIGNUM, BNRM, C1, C2, S1, S2, SMAX,
$ SMAXPR, SMIN, SMINPR, SMLNUM, T1, T2
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DGEQPF, DLAIC1, DLASCL, DLASET, DLATZM, DORM2R,
$ DTRSM, DTZRQF, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
MN = MIN( M, N )
ISMIN = MN + 1
ISMAX = 2*MN + 1
*
* Test the input arguments.
*
INFO = 0
IF( M.LT.0 ) 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, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
INFO = -7
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGELSX', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( MIN( M, N, NRHS ).EQ.0 ) THEN
RANK = 0
RETURN
END IF
*
* Get machine parameters
*
SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' )
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
*
* Scale A, B if max elements outside range [SMLNUM,BIGNUM]
*
ANRM = DLANGE( 'M', M, N, A, LDA, WORK )
IASCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
IASCL = 1
ELSE IF( ANRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
IASCL = 2
ELSE IF( ANRM.EQ.ZERO ) THEN
*
* Matrix all zero. Return zero solution.
*
CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
RANK = 0
GO TO 100
END IF
*
BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK )
IBSCL = 0
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
IBSCL = 1
ELSE IF( BNRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
IBSCL = 2
END IF
*
* Compute QR factorization with column pivoting of A:
* A * P = Q * R
*
CALL DGEQPF( M, N, A, LDA, JPVT, WORK( 1 ), WORK( MN+1 ), INFO )
*
* workspace 3*N. Details of Householder rotations stored
* in WORK(1:MN).
*
* Determine RANK using incremental condition estimation
*
WORK( ISMIN ) = ONE
WORK( ISMAX ) = ONE
SMAX = ABS( A( 1, 1 ) )
SMIN = SMAX
IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN
RANK = 0
CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
GO TO 100
ELSE
RANK = 1
END IF
*
10 CONTINUE
IF( RANK.LT.MN ) THEN
I = RANK + 1
CALL DLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ),
$ A( I, I ), SMINPR, S1, C1 )
CALL DLAIC1( IMAX, RANK, WORK( ISMAX ), SMAX, A( 1, I ),
$ A( I, I ), SMAXPR, S2, C2 )
*
IF( SMAXPR*RCOND.LE.SMINPR ) THEN
DO 20 I = 1, RANK
WORK( ISMIN+I-1 ) = S1*WORK( ISMIN+I-1 )
WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 )
20 CONTINUE
WORK( ISMIN+RANK ) = C1
WORK( ISMAX+RANK ) = C2
SMIN = SMINPR
SMAX = SMAXPR
RANK = RANK + 1
GO TO 10
END IF
END IF
*
* Logically partition R = [ R11 R12 ]
* [ 0 R22 ]
* where R11 = R(1:RANK,1:RANK)
*
* [R11,R12] = [ T11, 0 ] * Y
*
IF( RANK.LT.N )
$ CALL DTZRQF( RANK, N, A, LDA, WORK( MN+1 ), INFO )
*
* Details of Householder rotations stored in WORK(MN+1:2*MN)
*
* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS)
*
CALL DORM2R( 'Left', 'Transpose', M, NRHS, MN, A, LDA, WORK( 1 ),
$ B, LDB, WORK( 2*MN+1 ), INFO )
*
* workspace NRHS
*
* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS)
*
CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK,
$ NRHS, ONE, A, LDA, B, LDB )
*
DO 40 I = RANK + 1, N
DO 30 J = 1, NRHS
B( I, J ) = ZERO
30 CONTINUE
40 CONTINUE
*
* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS)
*
IF( RANK.LT.N ) THEN
DO 50 I = 1, RANK
CALL DLATZM( 'Left', N-RANK+1, NRHS, A( I, RANK+1 ), LDA,
$ WORK( MN+I ), B( I, 1 ), B( RANK+1, 1 ), LDB,
$ WORK( 2*MN+1 ) )
50 CONTINUE
END IF
*
* workspace NRHS
*
* B(1:N,1:NRHS) := P * B(1:N,1:NRHS)
*
DO 90 J = 1, NRHS
DO 60 I = 1, N
WORK( 2*MN+I ) = NTDONE
60 CONTINUE
DO 80 I = 1, N
IF( WORK( 2*MN+I ).EQ.NTDONE ) THEN
IF( JPVT( I ).NE.I ) THEN
K = I
T1 = B( K, J )
T2 = B( JPVT( K ), J )
70 CONTINUE
B( JPVT( K ), J ) = T1
WORK( 2*MN+K ) = DONE
T1 = T2
K = JPVT( K )
T2 = B( JPVT( K ), J )
IF( JPVT( K ).NE.I )
$ GO TO 70
B( I, J ) = T1
WORK( 2*MN+K ) = DONE
END IF
END IF
80 CONTINUE
90 CONTINUE
*
* Undo scaling
*
IF( IASCL.EQ.1 ) THEN
CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
CALL DLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA,
$ INFO )
ELSE IF( IASCL.EQ.2 ) THEN
CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
CALL DLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA,
$ INFO )
END IF
IF( IBSCL.EQ.1 ) THEN
CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
ELSE IF( IBSCL.EQ.2 ) THEN
CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
END IF
*
100 CONTINUE
*
RETURN
*
* End of DGELSX
*
END
SUBROUTINE DGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK,
$ WORK, LWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
INTEGER JPVT( * )
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGELSY computes the minimum-norm solution to a real linear least
* squares problem:
* minimize || A * X - B ||
* using a complete orthogonal factorization of A. A is an M-by-N
* matrix which may be rank-deficient.
*
* Several right hand side vectors b and solution vectors x can be
* handled in a single call; they are stored as the columns of the
* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
* matrix X.
*
* The routine first computes a QR factorization with column pivoting:
* A * P = Q * [ R11 R12 ]
* [ 0 R22 ]
* with R11 defined as the largest leading submatrix whose estimated
* condition number is less than 1/RCOND. The order of R11, RANK,
* is the effective rank of A.
*
* Then, R22 is considered to be negligible, and R12 is annihilated
* by orthogonal transformations from the right, arriving at the
* complete orthogonal factorization:
* A * P = Q * [ T11 0 ] * Z
* [ 0 0 ]
* The minimum-norm solution is then
* X = P * Z' [ inv(T11)*Q1'*B ]
* [ 0 ]
* where Q1 consists of the first RANK columns of Q.
*
* This routine is basically identical to the original xGELSX except
* three differences:
* o The call to the subroutine xGEQPF has been substituted by the
* the call to the subroutine xGEQP3. This subroutine is a Blas-3
* version of the QR factorization with column pivoting.
* o Matrix B (the right hand side) is updated with Blas-3.
* o The permutation of matrix B (the right hand side) is faster and
* more simple.
*
* 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.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of
* columns of matrices B and X. NRHS >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, A has been overwritten by details of its
* complete orthogonal factorization.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the M-by-NRHS right hand side matrix B.
* On exit, the N-by-NRHS solution matrix X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,M,N).
*
* JPVT (input/output) INTEGER array, dimension (N)
* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
* to the front of AP, otherwise column i is a free column.
* On exit, if JPVT(i) = k, then the i-th column of AP
* was the k-th column of A.
*
* RCOND (input) DOUBLE PRECISION
* RCOND is used to determine the effective rank of A, which
* is defined as the order of the largest leading triangular
* submatrix R11 in the QR factorization with pivoting of A,
* whose estimated condition number < 1/RCOND.
*
* RANK (output) INTEGER
* The effective rank of A, i.e., the order of the submatrix
* R11. This is the same as the order of the submatrix T11
* in the complete orthogonal factorization of A.
*
* 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.
* The unblocked strategy requires that:
* LWORK >= MAX( MN+3*N+1, 2*MN+NRHS ),
* where MN = min( M, N ).
* The block algorithm requires that:
* LWORK >= MAX( MN+2*N+NB*(N+1), 2*MN+NB*NRHS ),
* where NB is an upper bound on the blocksize returned
* by ILAENV for the routines DGEQP3, DTZRZF, STZRQF, DORMQR,
* and DORMRZ.
*
* 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
* ===============
*
* Based on contributions by
* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
* E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
*
* =====================================================================
*
* .. Parameters ..
INTEGER IMAX, IMIN
PARAMETER ( IMAX = 1, IMIN = 2 )
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IASCL, IBSCL, ISMAX, ISMIN, J, LWKMIN,
$ LWKOPT, MN, NB, NB1, NB2, NB3, NB4
DOUBLE PRECISION ANRM, BIGNUM, BNRM, C1, C2, S1, S2, SMAX,
$ SMAXPR, SMIN, SMINPR, SMLNUM, WSIZE
* ..
* .. External Functions ..
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL ILAENV, DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEQP3, DLABAD, DLAIC1, DLASCL, DLASET,
$ DORMQR, DORMRZ, DTRSM, DTZRZF, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
MN = MIN( M, N )
ISMIN = MN + 1
ISMAX = 2*MN + 1
*
* Test the 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( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
INFO = -7
END IF
*
* Figure out optimal block size
*
IF( INFO.EQ.0 ) THEN
IF( MN.EQ.0 .OR. NRHS.EQ.0 ) THEN
LWKMIN = 1
LWKOPT = 1
ELSE
NB1 = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
NB2 = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 )
NB3 = ILAENV( 1, 'DORMQR', ' ', M, N, NRHS, -1 )
NB4 = ILAENV( 1, 'DORMRQ', ' ', M, N, NRHS, -1 )
NB = MAX( NB1, NB2, NB3, NB4 )
LWKMIN = MN + MAX( 2*MN, N + 1, MN + NRHS )
LWKOPT = MAX( LWKMIN,
$ MN + 2*N + NB*( N + 1 ), 2*MN + NB*NRHS )
END IF
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGELSY', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( MN.EQ.0 .OR. NRHS.EQ.0 ) THEN
RANK = 0
RETURN
END IF
*
* Get machine parameters
*
SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' )
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
*
* Scale A, B if max entries outside range [SMLNUM,BIGNUM]
*
ANRM = DLANGE( 'M', M, N, A, LDA, WORK )
IASCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
IASCL = 1
ELSE IF( ANRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
IASCL = 2
ELSE IF( ANRM.EQ.ZERO ) THEN
*
* Matrix all zero. Return zero solution.
*
CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
RANK = 0
GO TO 70
END IF
*
BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK )
IBSCL = 0
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
IBSCL = 1
ELSE IF( BNRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
IBSCL = 2
END IF
*
* Compute QR factorization with column pivoting of A:
* A * P = Q * R
*
CALL DGEQP3( M, N, A, LDA, JPVT, WORK( 1 ), WORK( MN+1 ),
$ LWORK-MN, INFO )
WSIZE = MN + WORK( MN+1 )
*
* workspace: MN+2*N+NB*(N+1).
* Details of Householder rotations stored in WORK(1:MN).
*
* Determine RANK using incremental condition estimation
*
WORK( ISMIN ) = ONE
WORK( ISMAX ) = ONE
SMAX = ABS( A( 1, 1 ) )
SMIN = SMAX
IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN
RANK = 0
CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
GO TO 70
ELSE
RANK = 1
END IF
*
10 CONTINUE
IF( RANK.LT.MN ) THEN
I = RANK + 1
CALL DLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ),
$ A( I, I ), SMINPR, S1, C1 )
CALL DLAIC1( IMAX, RANK, WORK( ISMAX ), SMAX, A( 1, I ),
$ A( I, I ), SMAXPR, S2, C2 )
*
IF( SMAXPR*RCOND.LE.SMINPR ) THEN
DO 20 I = 1, RANK
WORK( ISMIN+I-1 ) = S1*WORK( ISMIN+I-1 )
WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 )
20 CONTINUE
WORK( ISMIN+RANK ) = C1
WORK( ISMAX+RANK ) = C2
SMIN = SMINPR
SMAX = SMAXPR
RANK = RANK + 1
GO TO 10
END IF
END IF
*
* workspace: 3*MN.
*
* Logically partition R = [ R11 R12 ]
* [ 0 R22 ]
* where R11 = R(1:RANK,1:RANK)
*
* [R11,R12] = [ T11, 0 ] * Y
*
IF( RANK.LT.N )
$ CALL DTZRZF( RANK, N, A, LDA, WORK( MN+1 ), WORK( 2*MN+1 ),
$ LWORK-2*MN, INFO )
*
* workspace: 2*MN.
* Details of Householder rotations stored in WORK(MN+1:2*MN)
*
* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS)
*
CALL DORMQR( 'Left', 'Transpose', M, NRHS, MN, A, LDA, WORK( 1 ),
$ B, LDB, WORK( 2*MN+1 ), LWORK-2*MN, INFO )
WSIZE = MAX( WSIZE, 2*MN+WORK( 2*MN+1 ) )
*
* workspace: 2*MN+NB*NRHS.
*
* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS)
*
CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK,
$ NRHS, ONE, A, LDA, B, LDB )
*
DO 40 J = 1, NRHS
DO 30 I = RANK + 1, N
B( I, J ) = ZERO
30 CONTINUE
40 CONTINUE
*
* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS)
*
IF( RANK.LT.N ) THEN
CALL DORMRZ( 'Left', 'Transpose', N, NRHS, RANK, N-RANK, A,
$ LDA, WORK( MN+1 ), B, LDB, WORK( 2*MN+1 ),
$ LWORK-2*MN, INFO )
END IF
*
* workspace: 2*MN+NRHS.
*
* B(1:N,1:NRHS) := P * B(1:N,1:NRHS)
*
DO 60 J = 1, NRHS
DO 50 I = 1, N
WORK( JPVT( I ) ) = B( I, J )
50 CONTINUE
CALL DCOPY( N, WORK( 1 ), 1, B( 1, J ), 1 )
60 CONTINUE
*
* workspace: N.
*
* Undo scaling
*
IF( IASCL.EQ.1 ) THEN
CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
CALL DLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA,
$ INFO )
ELSE IF( IASCL.EQ.2 ) THEN
CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
CALL DLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA,
$ INFO )
END IF
IF( IBSCL.EQ.1 ) THEN
CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
ELSE IF( IBSCL.EQ.2 ) THEN
CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
END IF
*
70 CONTINUE
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of DGELSY
*
END
SUBROUTINE DGEQL2( M, N, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGEQL2 computes a QL factorization of a real m by n matrix A:
* A = Q * L.
*
* 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, if m >= n, the lower triangle of the subarray
* A(m-n+1:m,1:n) contains the n by n lower triangular matrix L;
* if m <= n, the elements on and below the (n-m)-th
* superdiagonal contain the m by n lower trapezoidal matrix L;
* the remaining elements, 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(k) . . . H(2) H(1), where k = min(m,n).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a real scalar, and v is a real vector with
* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in
* A(1:m-k+i-1,n-k+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( 'DGEQL2', -INFO )
RETURN
END IF
*
K = MIN( M, N )
*
DO 10 I = K, 1, -1
*
* Generate elementary reflector H(i) to annihilate
* A(1:m-k+i-1,n-k+i)
*
CALL DLARFG( M-K+I, A( M-K+I, N-K+I ), A( 1, N-K+I ), 1,
$ TAU( I ) )
*
* Apply H(i) to A(1:m-k+i,1:n-k+i-1) from the left
*
AII = A( M-K+I, N-K+I )
A( M-K+I, N-K+I ) = ONE
CALL DLARF( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1, TAU( I ),
$ A, LDA, WORK )
A( M-K+I, N-K+I ) = AII
10 CONTINUE
RETURN
*
* End of DGEQL2
*
END
SUBROUTINE DGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGEQLF computes a QL factorization of a real M-by-N matrix A:
* A = Q * L.
*
* 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,
* if m >= n, the lower triangle of the subarray
* A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L;
* if m <= n, the elements on and below the (n-m)-th
* superdiagonal contain the M-by-N lower trapezoidal matrix L;
* the remaining elements, 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/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(k) . . . H(2) H(1), where k = min(m,n).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a real scalar, and v is a real vector with
* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in
* A(1:m-k+i-1,n-k+i), and tau in TAU(i).
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,
$ MU, NB, NBMIN, NU, NX
* ..
* .. External Subroutines ..
EXTERNAL DGEQL2, DLARFB, DLARFT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the 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
K = MIN( M, N )
IF( K.EQ.0 ) THEN
LWKOPT = 1
ELSE
NB = ILAENV( 1, 'DGEQLF', ' ', M, N, -1, -1 )
LWKOPT = N*NB
END IF
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -7
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGEQLF', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( K.EQ.0 ) THEN
RETURN
END IF
*
NBMIN = 2
NX = 1
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, 'DGEQLF', ' ', 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, 'DGEQLF', ' ', 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.
* The last kk columns are handled by the block method.
*
KI = ( ( K-NX-1 ) / NB )*NB
KK = MIN( K, KI+NB )
*
DO 10 I = K - KK + KI + 1, K - KK + 1, -NB
IB = MIN( K-I+1, NB )
*
* Compute the QL factorization of the current block
* A(1:m-k+i+ib-1,n-k+i:n-k+i+ib-1)
*
CALL DGEQL2( M-K+I+IB-1, IB, A( 1, N-K+I ), LDA, TAU( I ),
$ WORK, IINFO )
IF( N-K+I.GT.1 ) THEN
*
* Form the triangular factor of the block reflector
* H = H(i+ib-1) . . . H(i+1) H(i)
*
CALL DLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB,
$ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK )
*
* Apply H' to A(1:m-k+i+ib-1,1:n-k+i-1) from the left
*
CALL DLARFB( 'Left', 'Transpose', 'Backward',
$ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB,
$ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA,
$ WORK( IB+1 ), LDWORK )
END IF
10 CONTINUE
MU = M - K + I + NB - 1
NU = N - K + I + NB - 1
ELSE
MU = M
NU = N
END IF
*
* Use unblocked code to factor the last or only block
*
IF( MU.GT.0 .AND. NU.GT.0 )
$ CALL DGEQL2( MU, NU, A, LDA, TAU, WORK, IINFO )
*
WORK( 1 ) = IWS
RETURN
*
* End of DGEQLF
*
END
SUBROUTINE DGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
INTEGER JPVT( * )
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGEQP3 computes a QR factorization with column pivoting of a
* matrix A: A*P = Q*R using Level 3 BLAS.
*
* 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 upper triangle of the array contains the
* min(M,N)-by-N upper trapezoidal matrix R; the elements below
* the diagonal, together with the array TAU, represent the
* orthogonal matrix Q as a product of min(M,N) elementary
* reflectors.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* JPVT (input/output) INTEGER array, dimension (N)
* On entry, if JPVT(J).ne.0, the J-th column of A is permuted
* to the front of A*P (a leading column); if JPVT(J)=0,
* the J-th column of A is a free column.
* On exit, if JPVT(J)=K, then the J-th column of A*P was the
* the K-th column of A.
*
* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
* The scalar factors of the elementary reflectors.
*
* 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 >= 3*N+1.
* For optimal performance LWORK >= 2*N+( N+1 )*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'
*
* where tau is a real/complex scalar, and v is a real/complex 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).
*
* Based on contributions by
* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
* X. Sun, Computer Science Dept., Duke University, USA
*
* =====================================================================
*
* .. 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
*
* Quick return if possible.
*
IF( MINMN.EQ.0 ) 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, SN,
$ -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 DGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO )
*
* -- LAPACK deprecated driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
INTEGER JPVT( * )
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* This routine is deprecated and has been replaced by routine DGEQP3.
*
* DGEQPF computes a QR factorization with column pivoting of a
* real M-by-N matrix A: A*P = 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 upper triangle of the array contains the
* min(M,N)-by-N upper triangular matrix R; the elements
* below the diagonal, together with the array TAU,
* represent the orthogonal matrix Q as a product of
* min(m,n) elementary reflectors.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* JPVT (input/output) INTEGER array, dimension (N)
* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
* to the front of A*P (a leading column); if JPVT(i) = 0,
* the i-th column of A is a free column.
* On exit, if JPVT(i) = k, then the i-th column of A*P
* was the k-th column of A.
*
* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
* The scalar factors of the elementary reflectors.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*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(n)
*
* Each H(i) has the form
*
* H = I - tau * v * v'
*
* 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).
*
* The matrix P is represented in jpvt as follows: If
* jpvt(j) = i
* then the jth column of P is the ith canonical unit vector.
*
* Partial column norm updating strategy modified by
* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,
* University of Zagreb, Croatia.
* June 2006.
* For more details see LAPACK Working Note 176.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, ITEMP, J, MA, MN, PVT
DOUBLE PRECISION AII, TEMP, TEMP2, TOL3Z
* ..
* .. External Subroutines ..
EXTERNAL DGEQR2, DLARF, DLARFG, DORM2R, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH, DNRM2
EXTERNAL IDAMAX, DLAMCH, DNRM2
* ..
* .. 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( 'DGEQPF', -INFO )
RETURN
END IF
*
MN = MIN( M, N )
TOL3Z = SQRT(DLAMCH('Epsilon'))
*
* Move initial columns up front
*
ITEMP = 1
DO 10 I = 1, N
IF( JPVT( I ).NE.0 ) THEN
IF( I.NE.ITEMP ) THEN
CALL DSWAP( M, A( 1, I ), 1, A( 1, ITEMP ), 1 )
JPVT( I ) = JPVT( ITEMP )
JPVT( ITEMP ) = I
ELSE
JPVT( I ) = I
END IF
ITEMP = ITEMP + 1
ELSE
JPVT( I ) = I
END IF
10 CONTINUE
ITEMP = ITEMP - 1
*
* Compute the QR factorization and update remaining columns
*
IF( ITEMP.GT.0 ) THEN
MA = MIN( ITEMP, M )
CALL DGEQR2( M, MA, A, LDA, TAU, WORK, INFO )
IF( MA.LT.N ) THEN
CALL DORM2R( 'Left', 'Transpose', M, N-MA, MA, A, LDA, TAU,
$ A( 1, MA+1 ), LDA, WORK, INFO )
END IF
END IF
*
IF( ITEMP.LT.MN ) THEN
*
* Initialize partial column norms. The first n elements of
* work store the exact column norms.
*
DO 20 I = ITEMP + 1, N
WORK( I ) = DNRM2( M-ITEMP, A( ITEMP+1, I ), 1 )
WORK( N+I ) = WORK( I )
20 CONTINUE
*
* Compute factorization
*
DO 40 I = ITEMP + 1, MN
*
* Determine ith pivot column and swap if necessary
*
PVT = ( I-1 ) + IDAMAX( N-I+1, WORK( 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
WORK( PVT ) = WORK( I )
WORK( N+PVT ) = WORK( N+I )
END IF
*
* Generate elementary reflector H(i)
*
IF( I.LT.M ) THEN
CALL DLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, TAU( I ) )
ELSE
CALL DLARFG( 1, A( M, M ), A( M, M ), 1, TAU( M ) )
END IF
*
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( 2*N+1 ) )
A( I, I ) = AII
END IF
*
* Update partial column norms
*
DO 30 J = I + 1, N
IF( WORK( J ).NE.ZERO ) THEN
*
* NOTE: The following 4 lines follow from the analysis in
* Lapack Working Note 176.
*
TEMP = ABS( A( I, J ) ) / WORK( J )
TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) )
TEMP2 = TEMP*( WORK( J ) / WORK( N+J ) )**2
IF( TEMP2 .LE. TOL3Z ) THEN
IF( M-I.GT.0 ) THEN
WORK( J ) = DNRM2( M-I, A( I+1, J ), 1 )
WORK( N+J ) = WORK( J )
ELSE
WORK( J ) = ZERO
WORK( N+J ) = ZERO
END IF
ELSE
WORK( J ) = WORK( J )*SQRT( TEMP )
END IF
END IF
30 CONTINUE
*
40 CONTINUE
END IF
RETURN
*
* End of DGEQPF
*
END
SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. 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'
*
* 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.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. 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'
*
* 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' 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 DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB,
$ X, LDX, FERR, BERR, WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), IWORK( * )
DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
$ BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* DGERFS improves the computed solution to a system of linear
* equations and provides error bounds and backward error estimates for
* the solution.
*
* 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**H * 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 matrices B and X. NRHS >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The original N-by-N matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)
* The factors L and U from the factorization A = P*L*U
* as computed by DGETRF.
*
* LDAF (input) INTEGER
* The leading dimension of the array AF. LDAF >= 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) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
* On entry, the solution matrix X, as computed by DGETRS.
* On exit, the improved solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Internal Parameters
* ===================
*
* ITMAX is the maximum number of steps of iterative refinement.
*
* =====================================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 5 )
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D+0 )
DOUBLE PRECISION THREE
PARAMETER ( THREE = 3.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN
CHARACTER TRANST
INTEGER COUNT, I, J, K, KASE, NZ
DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DGEMV, DGETRS, DLACN2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH
* ..
* .. 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( LDAF.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -10
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGERFS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
DO 10 J = 1, NRHS
FERR( J ) = ZERO
BERR( J ) = ZERO
10 CONTINUE
RETURN
END IF
*
IF( NOTRAN ) THEN
TRANST = 'T'
ELSE
TRANST = 'N'
END IF
*
* NZ = maximum number of nonzero elements in each row of A, plus 1
*
NZ = N + 1
EPS = DLAMCH( 'Epsilon' )
SAFMIN = DLAMCH( 'Safe minimum' )
SAFE1 = NZ*SAFMIN
SAFE2 = SAFE1 / EPS
*
* Do for each right hand side
*
DO 140 J = 1, NRHS
*
COUNT = 1
LSTRES = THREE
20 CONTINUE
*
* Loop until stopping criterion is satisfied.
*
* Compute residual R = B - op(A) * X,
* where op(A) = A, A**T, or A**H, depending on TRANS.
*
CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
CALL DGEMV( TRANS, N, N, -ONE, A, LDA, X( 1, J ), 1, ONE,
$ WORK( N+1 ), 1 )
*
* Compute componentwise relative backward error from formula
*
* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
*
* where abs(Z) is the componentwise absolute value of the matrix
* or vector Z. If the i-th component of the denominator is less
* than SAFE2, then SAFE1 is added to the i-th components of the
* numerator and denominator before dividing.
*
DO 30 I = 1, N
WORK( I ) = ABS( B( I, J ) )
30 CONTINUE
*
* Compute abs(op(A))*abs(X) + abs(B).
*
IF( NOTRAN ) THEN
DO 50 K = 1, N
XK = ABS( X( K, J ) )
DO 40 I = 1, N
WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
40 CONTINUE
50 CONTINUE
ELSE
DO 70 K = 1, N
S = ZERO
DO 60 I = 1, N
S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
60 CONTINUE
WORK( K ) = WORK( K ) + S
70 CONTINUE
END IF
S = ZERO
DO 80 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
ELSE
S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
$ ( WORK( I )+SAFE1 ) )
END IF
80 CONTINUE
BERR( J ) = S
*
* Test stopping criterion. Continue iterating if
* 1) The residual BERR(J) is larger than machine epsilon, and
* 2) BERR(J) decreased by at least a factor of 2 during the
* last iteration, and
* 3) At most ITMAX iterations tried.
*
IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
$ COUNT.LE.ITMAX ) THEN
*
* Update solution and try again.
*
CALL DGETRS( TRANS, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
$ INFO )
CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
LSTRES = BERR( J )
COUNT = COUNT + 1
GO TO 20
END IF
*
* Bound error from formula
*
* norm(X - XTRUE) / norm(X) .le. FERR =
* norm( abs(inv(op(A)))*
* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
*
* where
* norm(Z) is the magnitude of the largest component of Z
* inv(op(A)) is the inverse of op(A)
* abs(Z) is the componentwise absolute value of the matrix or
* vector Z
* NZ is the maximum number of nonzeros in any row of A, plus 1
* EPS is machine epsilon
*
* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
* is incremented by SAFE1 if the i-th component of
* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
*
* Use DLACN2 to estimate the infinity-norm of the matrix
* inv(op(A)) * diag(W),
* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
*
DO 90 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
ELSE
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
END IF
90 CONTINUE
*
KASE = 0
100 CONTINUE
CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
$ KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Multiply by diag(W)*inv(op(A)**T).
*
CALL DGETRS( TRANST, N, 1, AF, LDAF, IPIV, WORK( N+1 ),
$ N, INFO )
DO 110 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
110 CONTINUE
ELSE
*
* Multiply by inv(op(A))*diag(W).
*
DO 120 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
120 CONTINUE
CALL DGETRS( TRANS, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
$ INFO )
END IF
GO TO 100
END IF
*
* Normalize error.
*
LSTRES = ZERO
DO 130 I = 1, N
LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
130 CONTINUE
IF( LSTRES.NE.ZERO )
$ FERR( J ) = FERR( J ) / LSTRES
*
140 CONTINUE
*
RETURN
*
* End of DGERFS
*
END
SUBROUTINE DGERQ2( M, N, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGERQ2 computes an RQ factorization of a real m by n matrix A:
* A = R * Q.
*
* 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, if m <= n, the upper triangle of the subarray
* A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;
* if m >= n, the elements on and above the (m-n)-th subdiagonal
* contain the m by n upper trapezoidal matrix R; the remaining
* elements, 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 (M)
*
* 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'
*
* where tau is a real scalar, and v is a real vector with
* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
* A(m-k+i,1:n-k+i-1), 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( 'DGERQ2', -INFO )
RETURN
END IF
*
K = MIN( M, N )
*
DO 10 I = K, 1, -1
*
* Generate elementary reflector H(i) to annihilate
* A(m-k+i,1:n-k+i-1)
*
CALL DLARFG( N-K+I, A( M-K+I, N-K+I ), A( M-K+I, 1 ), LDA,
$ TAU( I ) )
*
* Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right
*
AII = A( M-K+I, N-K+I )
A( M-K+I, N-K+I ) = ONE
CALL DLARF( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA,
$ TAU( I ), A, LDA, WORK )
A( M-K+I, N-K+I ) = AII
10 CONTINUE
RETURN
*
* End of DGERQ2
*
END
SUBROUTINE DGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGERQF computes an RQ factorization of a real M-by-N matrix A:
* A = R * Q.
*
* 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,
* if m <= n, the upper triangle of the subarray
* A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R;
* if m >= n, the elements on and above the (m-n)-th subdiagonal
* contain the M-by-N upper trapezoidal matrix R;
* the remaining elements, 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,M).
* For optimum performance LWORK >= M*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'
*
* where tau is a real scalar, and v is a real vector with
* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
* A(m-k+i,1:n-k+i-1), and tau in TAU(i).
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,
$ MU, NB, NBMIN, NU, NX
* ..
* .. External Subroutines ..
EXTERNAL DGERQ2, DLARFB, DLARFT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the 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
K = MIN( M, N )
IF( K.EQ.0 ) THEN
LWKOPT = 1
ELSE
NB = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 )
LWKOPT = M*NB
END IF
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
INFO = -7
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGERQF', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( K.EQ.0 ) THEN
RETURN
END IF
*
NBMIN = 2
NX = 1
IWS = M
IF( NB.GT.1 .AND. NB.LT.K ) THEN
*
* Determine when to cross over from blocked to unblocked code.
*
NX = MAX( 0, ILAENV( 3, 'DGERQF', ' ', M, N, -1, -1 ) )
IF( NX.LT.K ) THEN
*
* Determine if workspace is large enough for blocked code.
*
LDWORK = M
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, 'DGERQF', ' ', 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.
* The last kk rows are handled by the block method.
*
KI = ( ( K-NX-1 ) / NB )*NB
KK = MIN( K, KI+NB )
*
DO 10 I = K - KK + KI + 1, K - KK + 1, -NB
IB = MIN( K-I+1, NB )
*
* Compute the RQ factorization of the current block
* A(m-k+i:m-k+i+ib-1,1:n-k+i+ib-1)
*
CALL DGERQ2( IB, N-K+I+IB-1, A( M-K+I, 1 ), LDA, TAU( I ),
$ WORK, IINFO )
IF( M-K+I.GT.1 ) THEN
*
* Form the triangular factor of the block reflector
* H = H(i+ib-1) . . . H(i+1) H(i)
*
CALL DLARFT( 'Backward', 'Rowwise', N-K+I+IB-1, IB,
$ A( M-K+I, 1 ), LDA, TAU( I ), WORK, LDWORK )
*
* Apply H to A(1:m-k+i-1,1:n-k+i+ib-1) from the right
*
CALL DLARFB( 'Right', 'No transpose', 'Backward',
$ 'Rowwise', M-K+I-1, N-K+I+IB-1, IB,
$ A( M-K+I, 1 ), LDA, WORK, LDWORK, A, LDA,
$ WORK( IB+1 ), LDWORK )
END IF
10 CONTINUE
MU = M - K + I + NB - 1
NU = N - K + I + NB - 1
ELSE
MU = M
NU = N
END IF
*
* Use unblocked code to factor the last or only block
*
IF( MU.GT.0 .AND. NU.GT.0 )
$ CALL DGERQ2( MU, NU, A, LDA, TAU, WORK, IINFO )
*
WORK( 1 ) = IWS
RETURN
*
* End of DGERQF
*
END
SUBROUTINE DGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, N
DOUBLE PRECISION SCALE
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), JPIV( * )
DOUBLE PRECISION A( LDA, * ), RHS( * )
* ..
*
* Purpose
* =======
*
* DGESC2 solves a system of linear equations
*
* A * X = scale* RHS
*
* with a general N-by-N matrix A using the LU factorization with
* complete pivoting computed by DGETC2.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix A.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the LU part of the factorization of the n-by-n
* matrix A computed by DGETC2: A = P * L * U * Q
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1, N).
*
* RHS (input/output) DOUBLE PRECISION array, dimension (N).
* On entry, the right hand side vector b.
* On exit, the solution vector X.
*
* IPIV (input) INTEGER array, dimension (N).
* The pivot indices; for 1 <= i <= N, row i of the
* matrix has been interchanged with row IPIV(i).
*
* JPIV (input) INTEGER array, dimension (N).
* The pivot indices; for 1 <= j <= N, column j of the
* matrix has been interchanged with column JPIV(j).
*
* SCALE (output) DOUBLE PRECISION
* On exit, SCALE contains the scale factor. SCALE is chosen
* 0 <= SCALE <= 1 to prevent owerflow in the solution.
*
* Further Details
* ===============
*
* Based on contributions by
* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
* Umea University, S-901 87 Umea, Sweden.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, TWO
PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION BIGNUM, EPS, SMLNUM, TEMP
* ..
* .. External Subroutines ..
EXTERNAL DLASWP, DSCAL
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL IDAMAX, DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
* Set constant to control owerflow
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' ) / EPS
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
*
* Apply permutations IPIV to RHS
*
CALL DLASWP( 1, RHS, LDA, 1, N-1, IPIV, 1 )
*
* Solve for L part
*
DO 20 I = 1, N - 1
DO 10 J = I + 1, N
RHS( J ) = RHS( J ) - A( J, I )*RHS( I )
10 CONTINUE
20 CONTINUE
*
* Solve for U part
*
SCALE = ONE
*
* Check for scaling
*
I = IDAMAX( N, RHS, 1 )
IF( TWO*SMLNUM*ABS( RHS( I ) ).GT.ABS( A( N, N ) ) ) THEN
TEMP = ( ONE / TWO ) / ABS( RHS( I ) )
CALL DSCAL( N, TEMP, RHS( 1 ), 1 )
SCALE = SCALE*TEMP
END IF
*
DO 40 I = N, 1, -1
TEMP = ONE / A( I, I )
RHS( I ) = RHS( I )*TEMP
DO 30 J = I + 1, N
RHS( I ) = RHS( I ) - RHS( J )*( A( I, J )*TEMP )
30 CONTINUE
40 CONTINUE
*
* Apply permutations JPIV to the solution (RHS)
*
CALL DLASWP( 1, RHS, LDA, 1, N-1, JPIV, -1 )
RETURN
*
* End of DGESC2
*
END
SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK,
$ LWORK, IWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ
INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ),
$ VT( LDVT, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGESDD computes the singular value decomposition (SVD) of a real
* M-by-N matrix A, optionally computing the left and right singular
* vectors. If singular vectors are desired, it uses a
* divide-and-conquer algorithm.
*
* The SVD is written
*
* A = U * SIGMA * transpose(V)
*
* where SIGMA is an M-by-N matrix which is zero except for its
* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and
* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA
* are the singular values of A; they are real and non-negative, and
* are returned in descending order. The first min(m,n) columns of
* U and V are the left and right singular vectors of A.
*
* Note that the routine returns VT = V**T, not V.
*
* The divide and conquer algorithm makes very mild assumptions about
* floating point arithmetic. It will work on machines with a guard
* digit in add/subtract, or on those binary machines without guard
* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
* Cray-2. It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* Specifies options for computing all or part of the matrix U:
* = 'A': all M columns of U and all N rows of V**T are
* returned in the arrays U and VT;
* = 'S': the first min(M,N) columns of U and the first
* min(M,N) rows of V**T are returned in the arrays U
* and VT;
* = 'O': If M >= N, the first N columns of U are overwritten
* on the array A and all rows of V**T are returned in
* the array VT;
* otherwise, all columns of U are returned in the
* array U and the first M rows of V**T are overwritten
* in the array A;
* = 'N': no columns of U or rows of V**T are computed.
*
* M (input) INTEGER
* The number of rows of the input matrix A. M >= 0.
*
* N (input) INTEGER
* The number of columns of the input matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit,
* if JOBZ = 'O', A is overwritten with the first N columns
* of U (the left singular vectors, stored
* columnwise) if M >= N;
* A is overwritten with the first M rows
* of V**T (the right singular vectors, stored
* rowwise) otherwise.
* if JOBZ .ne. 'O', the contents of A are destroyed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* S (output) DOUBLE PRECISION array, dimension (min(M,N))
* The singular values of A, sorted so that S(i) >= S(i+1).
*
* U (output) DOUBLE PRECISION array, dimension (LDU,UCOL)
* UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;
* UCOL = min(M,N) if JOBZ = 'S'.
* If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M
* orthogonal matrix U;
* if JOBZ = 'S', U contains the first min(M,N) columns of U
* (the left singular vectors, stored columnwise);
* if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= 1; if
* JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.
*
* VT (output) DOUBLE PRECISION array, dimension (LDVT,N)
* If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the
* N-by-N orthogonal matrix V**T;
* if JOBZ = 'S', VT contains the first min(M,N) rows of
* V**T (the right singular vectors, stored rowwise);
* if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.
*
* LDVT (input) INTEGER
* The leading dimension of the array VT. LDVT >= 1; if
* JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;
* if JOBZ = 'S', LDVT >= min(M,N).
*
* 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 >= 1.
* If JOBZ = 'N',
* LWORK >= 3*min(M,N) + max(max(M,N),7*min(M,N)).
* If JOBZ = 'O',
* LWORK >= 3*min(M,N)*min(M,N) +
* max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)).
* If JOBZ = 'S' or 'A'
* LWORK >= 3*min(M,N)*min(M,N) +
* max(max(M,N),4*min(M,N)*min(M,N)+4*min(M,N)).
* For good performance, LWORK should generally be larger.
* If LWORK = -1 but other input arguments are legal, WORK(1)
* returns the optimal LWORK.
*
* IWORK (workspace) INTEGER array, dimension (8*min(M,N))
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: DBDSDC did not converge, updating process failed.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, WNTQA, WNTQAS, WNTQN, WNTQO, WNTQS
INTEGER BDSPAC, BLK, CHUNK, I, IE, IERR, IL,
$ IR, ISCL, ITAU, ITAUP, ITAUQ, IU, IVT, LDWKVT,
$ LDWRKL, LDWRKR, LDWRKU, MAXWRK, MINMN, MINWRK,
$ MNTHR, NWORK, WRKBL
DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM
* ..
* .. Local Arrays ..
INTEGER IDUM( 1 )
DOUBLE PRECISION DUM( 1 )
* ..
* .. External Subroutines ..
EXTERNAL DBDSDC, DGEBRD, DGELQF, DGEMM, DGEQRF, DLACPY,
$ DLASCL, DLASET, DORGBR, DORGLQ, DORGQR, DORMBR,
$ XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC INT, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
MINMN = MIN( M, N )
WNTQA = LSAME( JOBZ, 'A' )
WNTQS = LSAME( JOBZ, 'S' )
WNTQAS = WNTQA .OR. WNTQS
WNTQO = LSAME( JOBZ, 'O' )
WNTQN = LSAME( JOBZ, 'N' )
LQUERY = ( LWORK.EQ.-1 )
*
IF( .NOT.( WNTQA .OR. WNTQS .OR. WNTQO .OR. WNTQN ) ) 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 = -5
ELSE IF( LDU.LT.1 .OR. ( WNTQAS .AND. LDU.LT.M ) .OR.
$ ( WNTQO .AND. M.LT.N .AND. LDU.LT.M ) ) THEN
INFO = -8
ELSE IF( LDVT.LT.1 .OR. ( WNTQA .AND. LDVT.LT.N ) .OR.
$ ( WNTQS .AND. LDVT.LT.MINMN ) .OR.
$ ( WNTQO .AND. M.GE.N .AND. LDVT.LT.N ) ) THEN
INFO = -10
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.)
*
IF( INFO.EQ.0 ) THEN
MINWRK = 1
MAXWRK = 1
IF( M.GE.N .AND. MINMN.GT.0 ) THEN
*
* Compute space needed for DBDSDC
*
MNTHR = INT( MINMN*11.0D0 / 6.0D0 )
IF( WNTQN ) THEN
BDSPAC = 7*N
ELSE
BDSPAC = 3*N*N + 4*N
END IF
IF( M.GE.MNTHR ) THEN
IF( WNTQN ) THEN
*
* Path 1 (M much larger than N, JOBZ='N')
*
WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1,
$ -1 )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
MAXWRK = MAX( WRKBL, BDSPAC+N )
MINWRK = BDSPAC + N
ELSE IF( WNTQO ) THEN
*
* Path 2 (M much larger than N, JOBZ='O')
*
WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
$ N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'DORMBR', 'QLN', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*N )
MAXWRK = WRKBL + 2*N*N
MINWRK = BDSPAC + 2*N*N + 3*N
ELSE IF( WNTQS ) THEN
*
* Path 3 (M much larger than N, JOBZ='S')
*
WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
$ N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'DORMBR', 'QLN', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*N )
MAXWRK = WRKBL + N*N
MINWRK = BDSPAC + N*N + 3*N
ELSE IF( WNTQA ) THEN
*
* Path 4 (M much larger than N, JOBZ='A')
*
WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M,
$ M, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'DORMBR', 'QLN', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*N )
MAXWRK = WRKBL + N*N
MINWRK = BDSPAC + N*N + 3*N
END IF
ELSE
*
* Path 5 (M at least N, but not much larger)
*
WRKBL = 3*N + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N, -1,
$ -1 )
IF( WNTQN ) THEN
MAXWRK = MAX( WRKBL, BDSPAC+3*N )
MINWRK = 3*N + MAX( M, BDSPAC )
ELSE IF( WNTQO ) THEN
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'DORMBR', 'QLN', M, N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*N )
MAXWRK = WRKBL + M*N
MINWRK = 3*N + MAX( M, N*N+BDSPAC )
ELSE IF( WNTQS ) THEN
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'DORMBR', 'QLN', M, N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
MAXWRK = MAX( WRKBL, BDSPAC+3*N )
MINWRK = 3*N + MAX( M, BDSPAC )
ELSE IF( WNTQA ) THEN
WRKBL = MAX( WRKBL, 3*N+M*
$ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
MAXWRK = MAX( MAXWRK, BDSPAC+3*N )
MINWRK = 3*N + MAX( M, BDSPAC )
END IF
END IF
ELSE IF( MINMN.GT.0 ) THEN
*
* Compute space needed for DBDSDC
*
MNTHR = INT( MINMN*11.0D0 / 6.0D0 )
IF( WNTQN ) THEN
BDSPAC = 7*M
ELSE
BDSPAC = 3*M*M + 4*M
END IF
IF( N.GE.MNTHR ) THEN
IF( WNTQN ) THEN
*
* Path 1t (N much larger than M, JOBZ='N')
*
WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1,
$ -1 )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
MAXWRK = MAX( WRKBL, BDSPAC+M )
MINWRK = BDSPAC + M
ELSE IF( WNTQO ) THEN
*
* Path 2t (N much larger than M, JOBZ='O')
*
WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
$ N, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*M )
MAXWRK = WRKBL + 2*M*M
MINWRK = BDSPAC + 2*M*M + 3*M
ELSE IF( WNTQS ) THEN
*
* Path 3t (N much larger than M, JOBZ='S')
*
WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
$ N, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*M )
MAXWRK = WRKBL + M*M
MINWRK = BDSPAC + M*M + 3*M
ELSE IF( WNTQA ) THEN
*
* Path 4t (N much larger than M, JOBZ='A')
*
WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N,
$ N, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*M )
MAXWRK = WRKBL + M*M
MINWRK = BDSPAC + M*M + 3*M
END IF
ELSE
*
* Path 5t (N greater than M, but not much larger)
*
WRKBL = 3*M + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N, -1,
$ -1 )
IF( WNTQN ) THEN
MAXWRK = MAX( WRKBL, BDSPAC+3*M )
MINWRK = 3*M + MAX( N, BDSPAC )
ELSE IF( WNTQO ) THEN
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'DORMBR', 'PRT', M, N, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*M )
MAXWRK = WRKBL + M*N
MINWRK = 3*M + MAX( N, M*M+BDSPAC )
ELSE IF( WNTQS ) THEN
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'DORMBR', 'PRT', M, N, M, -1 ) )
MAXWRK = MAX( WRKBL, BDSPAC+3*M )
MINWRK = 3*M + MAX( N, BDSPAC )
ELSE IF( WNTQA ) THEN
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'DORMBR', 'PRT', N, N, M, -1 ) )
MAXWRK = MAX( WRKBL, BDSPAC+3*M )
MINWRK = 3*M + MAX( N, BDSPAC )
END IF
END IF
END IF
MAXWRK = MAX( MAXWRK, MINWRK )
WORK( 1 ) = MAXWRK
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGESDD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
RETURN
END IF
*
* Get machine constants
*
EPS = DLAMCH( 'P' )
SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS
BIGNUM = ONE / SMLNUM
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = DLANGE( 'M', M, N, A, LDA, DUM )
ISCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
ISCL = 1
CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR )
ELSE IF( ANRM.GT.BIGNUM ) THEN
ISCL = 1
CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR )
END IF
*
IF( M.GE.N ) THEN
*
* A has at least as many rows as columns. If A has sufficiently
* more rows than columns, first reduce using the QR
* decomposition (if sufficient workspace available)
*
IF( M.GE.MNTHR ) THEN
*
IF( WNTQN ) THEN
*
* Path 1 (M much larger than N, JOBZ='N')
* No singular vectors to be computed
*
ITAU = 1
NWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Zero out below R
*
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
IE = 1
ITAUQ = IE + N
ITAUP = ITAUQ + N
NWORK = ITAUP + N
*
* Bidiagonalize R in A
* (Workspace: need 4*N, prefer 3*N+2*N*NB)
*
CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
NWORK = IE + N
*
* Perform bidiagonal SVD, computing singular values only
* (Workspace: need N+BDSPAC)
*
CALL DBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1,
$ DUM, IDUM, WORK( NWORK ), IWORK, INFO )
*
ELSE IF( WNTQO ) THEN
*
* Path 2 (M much larger than N, JOBZ = 'O')
* N left singular vectors to be overwritten on A and
* N right singular vectors to be computed in VT
*
IR = 1
*
* WORK(IR) is LDWRKR by N
*
IF( LWORK.GE.LDA*N+N*N+3*N+BDSPAC ) THEN
LDWRKR = LDA
ELSE
LDWRKR = ( LWORK-N*N-3*N-BDSPAC ) / N
END IF
ITAU = IR + LDWRKR*N
NWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Copy R to WORK(IR), zeroing out below it
*
CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ),
$ LDWRKR )
*
* Generate Q in A
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
NWORK = ITAUP + N
*
* Bidiagonalize R in VT, copying result to WORK(IR)
* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
*
CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* WORK(IU) is N by N
*
IU = NWORK
NWORK = IU + N*N
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in WORK(IU) and computing right
* singular vectors of bidiagonal matrix in VT
* (Workspace: need N+N*N+BDSPAC)
*
CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N,
$ VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Overwrite WORK(IU) by left singular vectors of R
* and VT by right singular vectors of R
* (Workspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB)
*
CALL DORMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IU ), N, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
CALL DORMBR( 'P', 'R', 'T', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Multiply Q in A by left singular vectors of R in
* WORK(IU), storing result in WORK(IR) and copying to A
* (Workspace: need 2*N*N, prefer N*N+M*N)
*
DO 10 I = 1, M, LDWRKR
CHUNK = MIN( M-I+1, LDWRKR )
CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
$ LDA, WORK( IU ), N, ZERO, WORK( IR ),
$ LDWRKR )
CALL DLACPY( 'F', CHUNK, N, WORK( IR ), LDWRKR,
$ A( I, 1 ), LDA )
10 CONTINUE
*
ELSE IF( WNTQS ) THEN
*
* Path 3 (M much larger than N, JOBZ='S')
* N left singular vectors to be computed in U and
* N right singular vectors to be computed in VT
*
IR = 1
*
* WORK(IR) is N by N
*
LDWRKR = N
ITAU = IR + LDWRKR*N
NWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Copy R to WORK(IR), zeroing out below it
*
CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ),
$ LDWRKR )
*
* Generate Q in A
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
NWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IR)
* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
*
CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagoal matrix in U and computing right singular
* vectors of bidiagonal matrix in VT
* (Workspace: need N+BDSPAC)
*
CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT,
$ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Overwrite U by left singular vectors of R and VT
* by right singular vectors of R
* (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB)
*
CALL DORMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
CALL DORMBR( 'P', 'R', 'T', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Multiply Q in A by left singular vectors of R in
* WORK(IR), storing result in U
* (Workspace: need N*N)
*
CALL DLACPY( 'F', N, N, U, LDU, WORK( IR ), LDWRKR )
CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA, WORK( IR ),
$ LDWRKR, ZERO, U, LDU )
*
ELSE IF( WNTQA ) THEN
*
* Path 4 (M much larger than N, JOBZ='A')
* M left singular vectors to be computed in U and
* N right singular vectors to be computed in VT
*
IU = 1
*
* WORK(IU) is N by N
*
LDWRKU = N
ITAU = IU + LDWRKU*N
NWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Produce R in A, zeroing out other entries
*
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
NWORK = ITAUP + N
*
* Bidiagonalize R in A
* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
*
CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in WORK(IU) and computing right
* singular vectors of bidiagonal matrix in VT
* (Workspace: need N+N*N+BDSPAC)
*
CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N,
$ VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Overwrite WORK(IU) by left singular vectors of R and VT
* by right singular vectors of R
* (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB)
*
CALL DORMBR( 'Q', 'L', 'N', N, N, N, A, LDA,
$ WORK( ITAUQ ), WORK( IU ), LDWRKU,
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
CALL DORMBR( 'P', 'R', 'T', N, N, N, A, LDA,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Multiply Q in U by left singular vectors of R in
* WORK(IU), storing result in A
* (Workspace: need N*N)
*
CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU, WORK( IU ),
$ LDWRKU, ZERO, A, LDA )
*
* Copy left singular vectors of A from A to U
*
CALL DLACPY( 'F', M, N, A, LDA, U, LDU )
*
END IF
*
ELSE
*
* M .LT. MNTHR
*
* Path 5 (M at least N, but not much larger)
* Reduce to bidiagonal form without QR decomposition
*
IE = 1
ITAUQ = IE + N
ITAUP = ITAUQ + N
NWORK = ITAUP + N
*
* Bidiagonalize A
* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB)
*
CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
IF( WNTQN ) THEN
*
* Perform bidiagonal SVD, only computing singular values
* (Workspace: need N+BDSPAC)
*
CALL DBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1,
$ DUM, IDUM, WORK( NWORK ), IWORK, INFO )
ELSE IF( WNTQO ) THEN
IU = NWORK
IF( LWORK.GE.M*N+3*N+BDSPAC ) THEN
*
* WORK( IU ) is M by N
*
LDWRKU = M
NWORK = IU + LDWRKU*N
CALL DLASET( 'F', M, N, ZERO, ZERO, WORK( IU ),
$ LDWRKU )
ELSE
*
* WORK( IU ) is N by N
*
LDWRKU = N
NWORK = IU + LDWRKU*N
*
* WORK(IR) is LDWRKR by N
*
IR = NWORK
LDWRKR = ( LWORK-N*N-3*N ) / N
END IF
NWORK = IU + LDWRKU*N
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in WORK(IU) and computing right
* singular vectors of bidiagonal matrix in VT
* (Workspace: need N+N*N+BDSPAC)
*
CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ),
$ LDWRKU, VT, LDVT, DUM, IDUM, WORK( NWORK ),
$ IWORK, INFO )
*
* Overwrite VT by right singular vectors of A
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL DORMBR( 'P', 'R', 'T', N, N, N, A, LDA,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
IF( LWORK.GE.M*N+3*N+BDSPAC ) THEN
*
* Overwrite WORK(IU) by left singular vectors of A
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL DORMBR( 'Q', 'L', 'N', M, N, N, A, LDA,
$ WORK( ITAUQ ), WORK( IU ), LDWRKU,
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Copy left singular vectors of A from WORK(IU) to A
*
CALL DLACPY( 'F', M, N, WORK( IU ), LDWRKU, A, LDA )
ELSE
*
* Generate Q in A
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Multiply Q in A by left singular vectors of
* bidiagonal matrix in WORK(IU), storing result in
* WORK(IR) and copying to A
* (Workspace: need 2*N*N, prefer N*N+M*N)
*
DO 20 I = 1, M, LDWRKR
CHUNK = MIN( M-I+1, LDWRKR )
CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
$ LDA, WORK( IU ), LDWRKU, ZERO,
$ WORK( IR ), LDWRKR )
CALL DLACPY( 'F', CHUNK, N, WORK( IR ), LDWRKR,
$ A( I, 1 ), LDA )
20 CONTINUE
END IF
*
ELSE IF( WNTQS ) THEN
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U and computing right singular
* vectors of bidiagonal matrix in VT
* (Workspace: need N+BDSPAC)
*
CALL DLASET( 'F', M, N, ZERO, ZERO, U, LDU )
CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT,
$ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Overwrite U by left singular vectors of A and VT
* by right singular vectors of A
* (Workspace: need 3*N, prefer 2*N+N*NB)
*
CALL DORMBR( 'Q', 'L', 'N', M, N, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
CALL DORMBR( 'P', 'R', 'T', N, N, N, A, LDA,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
ELSE IF( WNTQA ) THEN
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U and computing right singular
* vectors of bidiagonal matrix in VT
* (Workspace: need N+BDSPAC)
*
CALL DLASET( 'F', M, M, ZERO, ZERO, U, LDU )
CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT,
$ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Set the right corner of U to identity matrix
*
IF( M.GT.N ) THEN
CALL DLASET( 'F', M-N, M-N, ZERO, ONE, U( N+1, N+1 ),
$ LDU )
END IF
*
* Overwrite U by left singular vectors of A and VT
* by right singular vectors of A
* (Workspace: need N*N+2*N+M, prefer N*N+2*N+M*NB)
*
CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
CALL DORMBR( 'P', 'R', 'T', N, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
END IF
*
END IF
*
ELSE
*
* A has more columns than rows. If A has sufficiently more
* columns than rows, first reduce using the LQ decomposition (if
* sufficient workspace available)
*
IF( N.GE.MNTHR ) THEN
*
IF( WNTQN ) THEN
*
* Path 1t (N much larger than M, JOBZ='N')
* No singular vectors to be computed
*
ITAU = 1
NWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Zero out above L
*
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA )
IE = 1
ITAUQ = IE + M
ITAUP = ITAUQ + M
NWORK = ITAUP + M
*
* Bidiagonalize L in A
* (Workspace: need 4*M, prefer 3*M+2*M*NB)
*
CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
NWORK = IE + M
*
* Perform bidiagonal SVD, computing singular values only
* (Workspace: need M+BDSPAC)
*
CALL DBDSDC( 'U', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1,
$ DUM, IDUM, WORK( NWORK ), IWORK, INFO )
*
ELSE IF( WNTQO ) THEN
*
* Path 2t (N much larger than M, JOBZ='O')
* M right singular vectors to be overwritten on A and
* M left singular vectors to be computed in U
*
IVT = 1
*
* IVT is M by M
*
IL = IVT + M*M
IF( LWORK.GE.M*N+M*M+3*M+BDSPAC ) THEN
*
* WORK(IL) is M by N
*
LDWRKL = M
CHUNK = N
ELSE
LDWRKL = M
CHUNK = ( LWORK-M*M ) / M
END IF
ITAU = IL + LDWRKL*M
NWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Copy L to WORK(IL), zeroing about above it
*
CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL )
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
$ WORK( IL+LDWRKL ), LDWRKL )
*
* Generate Q in A
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
NWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IL)
* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
*
CALL DGEBRD( M, M, WORK( IL ), LDWRKL, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U, and computing right singular
* vectors of bidiagonal matrix in WORK(IVT)
* (Workspace: need M+M*M+BDSPAC)
*
CALL DBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU,
$ WORK( IVT ), M, DUM, IDUM, WORK( NWORK ),
$ IWORK, INFO )
*
* Overwrite U by left singular vectors of L and WORK(IVT)
* by right singular vectors of L
* (Workspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB)
*
CALL DORMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
CALL DORMBR( 'P', 'R', 'T', M, M, M, WORK( IL ), LDWRKL,
$ WORK( ITAUP ), WORK( IVT ), M,
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Multiply right singular vectors of L in WORK(IVT) by Q
* in A, storing result in WORK(IL) and copying to A
* (Workspace: need 2*M*M, prefer M*M+M*N)
*
DO 30 I = 1, N, CHUNK
BLK = MIN( N-I+1, CHUNK )
CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IVT ), M,
$ A( 1, I ), LDA, ZERO, WORK( IL ), LDWRKL )
CALL DLACPY( 'F', M, BLK, WORK( IL ), LDWRKL,
$ A( 1, I ), LDA )
30 CONTINUE
*
ELSE IF( WNTQS ) THEN
*
* Path 3t (N much larger than M, JOBZ='S')
* M right singular vectors to be computed in VT and
* M left singular vectors to be computed in U
*
IL = 1
*
* WORK(IL) is M by M
*
LDWRKL = M
ITAU = IL + LDWRKL*M
NWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Copy L to WORK(IL), zeroing out above it
*
CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL )
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
$ WORK( IL+LDWRKL ), LDWRKL )
*
* Generate Q in A
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
NWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IU), copying result to U
* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
*
CALL DGEBRD( M, M, WORK( IL ), LDWRKL, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U and computing right singular
* vectors of bidiagonal matrix in VT
* (Workspace: need M+BDSPAC)
*
CALL DBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, VT,
$ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Overwrite U by left singular vectors of L and VT
* by right singular vectors of L
* (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB)
*
CALL DORMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
CALL DORMBR( 'P', 'R', 'T', M, M, M, WORK( IL ), LDWRKL,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Multiply right singular vectors of L in WORK(IL) by
* Q in A, storing result in VT
* (Workspace: need M*M)
*
CALL DLACPY( 'F', M, M, VT, LDVT, WORK( IL ), LDWRKL )
CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IL ), LDWRKL,
$ A, LDA, ZERO, VT, LDVT )
*
ELSE IF( WNTQA ) THEN
*
* Path 4t (N much larger than M, JOBZ='A')
* N right singular vectors to be computed in VT and
* M left singular vectors to be computed in U
*
IVT = 1
*
* WORK(IVT) is M by M
*
LDWKVT = M
ITAU = IVT + LDWKVT*M
NWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Produce L in A, zeroing out other entries
*
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
NWORK = ITAUP + M
*
* Bidiagonalize L in A
* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
*
CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U and computing right singular
* vectors of bidiagonal matrix in WORK(IVT)
* (Workspace: need M+M*M+BDSPAC)
*
CALL DBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU,
$ WORK( IVT ), LDWKVT, DUM, IDUM,
$ WORK( NWORK ), IWORK, INFO )
*
* Overwrite U by left singular vectors of L and WORK(IVT)
* by right singular vectors of L
* (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB)
*
CALL DORMBR( 'Q', 'L', 'N', M, M, M, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
CALL DORMBR( 'P', 'R', 'T', M, M, M, A, LDA,
$ WORK( ITAUP ), WORK( IVT ), LDWKVT,
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Multiply right singular vectors of L in WORK(IVT) by
* Q in VT, storing result in A
* (Workspace: need M*M)
*
CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IVT ), LDWKVT,
$ VT, LDVT, ZERO, A, LDA )
*
* Copy right singular vectors of A from A to VT
*
CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT )
*
END IF
*
ELSE
*
* N .LT. MNTHR
*
* Path 5t (N greater than M, but not much larger)
* Reduce to bidiagonal form without LQ decomposition
*
IE = 1
ITAUQ = IE + M
ITAUP = ITAUQ + M
NWORK = ITAUP + M
*
* Bidiagonalize A
* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
*
CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
IF( WNTQN ) THEN
*
* Perform bidiagonal SVD, only computing singular values
* (Workspace: need M+BDSPAC)
*
CALL DBDSDC( 'L', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1,
$ DUM, IDUM, WORK( NWORK ), IWORK, INFO )
ELSE IF( WNTQO ) THEN
LDWKVT = M
IVT = NWORK
IF( LWORK.GE.M*N+3*M+BDSPAC ) THEN
*
* WORK( IVT ) is M by N
*
CALL DLASET( 'F', M, N, ZERO, ZERO, WORK( IVT ),
$ LDWKVT )
NWORK = IVT + LDWKVT*N
ELSE
*
* WORK( IVT ) is M by M
*
NWORK = IVT + LDWKVT*M
IL = NWORK
*
* WORK(IL) is M by CHUNK
*
CHUNK = ( LWORK-M*M-3*M ) / M
END IF
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U and computing right singular
* vectors of bidiagonal matrix in WORK(IVT)
* (Workspace: need M*M+BDSPAC)
*
CALL DBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU,
$ WORK( IVT ), LDWKVT, DUM, IDUM,
$ WORK( NWORK ), IWORK, INFO )
*
* Overwrite U by left singular vectors of A
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
IF( LWORK.GE.M*N+3*M+BDSPAC ) THEN
*
* Overwrite WORK(IVT) by left singular vectors of A
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL DORMBR( 'P', 'R', 'T', M, N, M, A, LDA,
$ WORK( ITAUP ), WORK( IVT ), LDWKVT,
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Copy right singular vectors of A from WORK(IVT) to A
*
CALL DLACPY( 'F', M, N, WORK( IVT ), LDWKVT, A, LDA )
ELSE
*
* Generate P**T in A
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Multiply Q in A by right singular vectors of
* bidiagonal matrix in WORK(IVT), storing result in
* WORK(IL) and copying to A
* (Workspace: need 2*M*M, prefer M*M+M*N)
*
DO 40 I = 1, N, CHUNK
BLK = MIN( N-I+1, CHUNK )
CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IVT ),
$ LDWKVT, A( 1, I ), LDA, ZERO,
$ WORK( IL ), M )
CALL DLACPY( 'F', M, BLK, WORK( IL ), M, A( 1, I ),
$ LDA )
40 CONTINUE
END IF
ELSE IF( WNTQS ) THEN
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U and computing right singular
* vectors of bidiagonal matrix in VT
* (Workspace: need M+BDSPAC)
*
CALL DLASET( 'F', M, N, ZERO, ZERO, VT, LDVT )
CALL DBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT,
$ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Overwrite U by left singular vectors of A and VT
* by right singular vectors of A
* (Workspace: need 3*M, prefer 2*M+M*NB)
*
CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
CALL DORMBR( 'P', 'R', 'T', M, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
ELSE IF( WNTQA ) THEN
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U and computing right singular
* vectors of bidiagonal matrix in VT
* (Workspace: need M+BDSPAC)
*
CALL DLASET( 'F', N, N, ZERO, ZERO, VT, LDVT )
CALL DBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT,
$ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Set the right corner of VT to identity matrix
*
IF( N.GT.M ) THEN
CALL DLASET( 'F', N-M, N-M, ZERO, ONE, VT( M+1, M+1 ),
$ LDVT )
END IF
*
* Overwrite U by left singular vectors of A and VT
* by right singular vectors of A
* (Workspace: need 2*M+N, prefer 2*M+N*NB)
*
CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
CALL DORMBR( 'P', 'R', 'T', N, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
END IF
*
END IF
*
END IF
*
* Undo scaling if necessary
*
IF( ISCL.EQ.1 ) THEN
IF( ANRM.GT.BIGNUM )
$ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
$ IERR )
IF( ANRM.LT.SMLNUM )
$ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
$ IERR )
END IF
*
* Return optimal workspace in WORK(1)
*
WORK( 1 ) = MAXWRK
*
RETURN
*
* End of DGESDD
*
END
SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* DGESV computes the solution to a real system of linear equations
* A * X = B,
* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
*
* The LU decomposition with partial pivoting and row interchanges is
* used to factor A as
* A = P * L * U,
* where P is a permutation matrix, L is unit lower triangular, and U is
* upper triangular. The factored form of A is then used to solve the
* system of equations A * X = B.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of linear equations, i.e., 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/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the N-by-N coefficient matrix A.
* 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,N).
*
* IPIV (output) INTEGER array, dimension (N)
* The pivot indices that define the permutation matrix P;
* row i of the matrix was interchanged with row IPIV(i).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the N-by-NRHS matrix of right hand side matrix B.
* On exit, if INFO = 0, the N-by-NRHS 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
* > 0: if INFO = i, U(i,i) is exactly zero. The factorization
* has been completed, but the factor U is exactly
* singular, so the solution could not be computed.
*
* =====================================================================
*
* .. External Subroutines ..
EXTERNAL DGETRF, DGETRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( NRHS.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGESV ', -INFO )
RETURN
END IF
*
* Compute the LU factorization of A.
*
CALL DGETRF( N, N, A, LDA, IPIV, INFO )
IF( INFO.EQ.0 ) THEN
*
* Solve the system A*X = B, overwriting B with X.
*
CALL DGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB,
$ INFO )
END IF
RETURN
*
* End of DGESV
*
END
SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT,
$ WORK, LWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBU, JOBVT
INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ),
$ VT( LDVT, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGESVD computes the singular value decomposition (SVD) of a real
* M-by-N matrix A, optionally computing the left and/or right singular
* vectors. The SVD is written
*
* A = U * SIGMA * transpose(V)
*
* where SIGMA is an M-by-N matrix which is zero except for its
* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and
* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA
* are the singular values of A; they are real and non-negative, and
* are returned in descending order. The first min(m,n) columns of
* U and V are the left and right singular vectors of A.
*
* Note that the routine returns V**T, not V.
*
* Arguments
* =========
*
* JOBU (input) CHARACTER*1
* Specifies options for computing all or part of the matrix U:
* = 'A': all M columns of U are returned in array U:
* = 'S': the first min(m,n) columns of U (the left singular
* vectors) are returned in the array U;
* = 'O': the first min(m,n) columns of U (the left singular
* vectors) are overwritten on the array A;
* = 'N': no columns of U (no left singular vectors) are
* computed.
*
* JOBVT (input) CHARACTER*1
* Specifies options for computing all or part of the matrix
* V**T:
* = 'A': all N rows of V**T are returned in the array VT;
* = 'S': the first min(m,n) rows of V**T (the right singular
* vectors) are returned in the array VT;
* = 'O': the first min(m,n) rows of V**T (the right singular
* vectors) are overwritten on the array A;
* = 'N': no rows of V**T (no right singular vectors) are
* computed.
*
* JOBVT and JOBU cannot both be 'O'.
*
* M (input) INTEGER
* The number of rows of the input matrix A. M >= 0.
*
* N (input) INTEGER
* The number of columns of the input matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit,
* if JOBU = 'O', A is overwritten with the first min(m,n)
* columns of U (the left singular vectors,
* stored columnwise);
* if JOBVT = 'O', A is overwritten with the first min(m,n)
* rows of V**T (the right singular vectors,
* stored rowwise);
* if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A
* are destroyed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* S (output) DOUBLE PRECISION array, dimension (min(M,N))
* The singular values of A, sorted so that S(i) >= S(i+1).
*
* U (output) DOUBLE PRECISION array, dimension (LDU,UCOL)
* (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.
* If JOBU = 'A', U contains the M-by-M orthogonal matrix U;
* if JOBU = 'S', U contains the first min(m,n) columns of U
* (the left singular vectors, stored columnwise);
* if JOBU = 'N' or 'O', U is not referenced.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= 1; if
* JOBU = 'S' or 'A', LDU >= M.
*
* VT (output) DOUBLE PRECISION array, dimension (LDVT,N)
* If JOBVT = 'A', VT contains the N-by-N orthogonal matrix
* V**T;
* if JOBVT = 'S', VT contains the first min(m,n) rows of
* V**T (the right singular vectors, stored rowwise);
* if JOBVT = 'N' or 'O', VT is not referenced.
*
* LDVT (input) INTEGER
* The leading dimension of the array VT. LDVT >= 1; if
* JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).
*
* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK;
* if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged
* superdiagonal elements of an upper bidiagonal matrix B
* whose diagonal is in S (not necessarily sorted). B
* satisfies A = U * B * VT, so it has the same singular values
* as A, and singular vectors related by U and VT.
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* LWORK >= MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)).
* For good performance, LWORK should generally be larger.
*
* 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.
* > 0: if DBDSQR did not converge, INFO specifies how many
* superdiagonals of an intermediate bidiagonal form B
* did not converge to zero. See the description of WORK
* above for details.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS,
$ WNTVA, WNTVAS, WNTVN, WNTVO, WNTVS
INTEGER BDSPAC, BLK, CHUNK, I, IE, IERR, IR, ISCL,
$ ITAU, ITAUP, ITAUQ, IU, IWORK, LDWRKR, LDWRKU,
$ MAXWRK, MINMN, MINWRK, MNTHR, NCU, NCVT, NRU,
$ NRVT, WRKBL
DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM
* ..
* .. Local Arrays ..
DOUBLE PRECISION DUM( 1 )
* ..
* .. External Subroutines ..
EXTERNAL DBDSQR, DGEBRD, DGELQF, DGEMM, DGEQRF, DLACPY,
$ DLASCL, DLASET, DORGBR, DORGLQ, DORGQR, DORMBR,
$ XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
MINMN = MIN( M, N )
WNTUA = LSAME( JOBU, 'A' )
WNTUS = LSAME( JOBU, 'S' )
WNTUAS = WNTUA .OR. WNTUS
WNTUO = LSAME( JOBU, 'O' )
WNTUN = LSAME( JOBU, 'N' )
WNTVA = LSAME( JOBVT, 'A' )
WNTVS = LSAME( JOBVT, 'S' )
WNTVAS = WNTVA .OR. WNTVS
WNTVO = LSAME( JOBVT, 'O' )
WNTVN = LSAME( JOBVT, 'N' )
LQUERY = ( LWORK.EQ.-1 )
*
IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN
INFO = -1
ELSE IF( .NOT.( WNTVA .OR. WNTVS .OR. WNTVO .OR. WNTVN ) .OR.
$ ( WNTVO .AND. WNTUO ) ) THEN
INFO = -2
ELSE IF( M.LT.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -6
ELSE IF( LDU.LT.1 .OR. ( WNTUAS .AND. LDU.LT.M ) ) THEN
INFO = -9
ELSE IF( LDVT.LT.1 .OR. ( WNTVA .AND. LDVT.LT.N ) .OR.
$ ( WNTVS .AND. LDVT.LT.MINMN ) ) THEN
INFO = -11
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.)
*
IF( INFO.EQ.0 ) THEN
MINWRK = 1
MAXWRK = 1
IF( M.GE.N .AND. MINMN.GT.0 ) THEN
*
* Compute space needed for DBDSQR
*
MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 )
BDSPAC = 5*N
IF( M.GE.MNTHR ) THEN
IF( WNTUN ) THEN
*
* Path 1 (M much larger than N, JOBU='N')
*
MAXWRK = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1,
$ -1 )
MAXWRK = MAX( MAXWRK, 3*N+2*N*
$ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
IF( WNTVO .OR. WNTVAS )
$ MAXWRK = MAX( MAXWRK, 3*N+( N-1 )*
$ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
MAXWRK = MAX( MAXWRK, BDSPAC )
MINWRK = MAX( 4*N, BDSPAC )
ELSE IF( WNTUO .AND. WNTVN ) THEN
*
* Path 2 (M much larger than N, JOBU='O', JOBVT='N')
*
WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
$ N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = MAX( N*N+WRKBL, N*N+M*N+N )
MINWRK = MAX( 3*N+M, BDSPAC )
ELSE IF( WNTUO .AND. WNTVAS ) THEN
*
* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or
* 'A')
*
WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
$ N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+( N-1 )*
$ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = MAX( N*N+WRKBL, N*N+M*N+N )
MINWRK = MAX( 3*N+M, BDSPAC )
ELSE IF( WNTUS .AND. WNTVN ) THEN
*
* Path 4 (M much larger than N, JOBU='S', JOBVT='N')
*
WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
$ N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = N*N + WRKBL
MINWRK = MAX( 3*N+M, BDSPAC )
ELSE IF( WNTUS .AND. WNTVO ) THEN
*
* Path 5 (M much larger than N, JOBU='S', JOBVT='O')
*
WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
$ N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+( N-1 )*
$ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = 2*N*N + WRKBL
MINWRK = MAX( 3*N+M, BDSPAC )
ELSE IF( WNTUS .AND. WNTVAS ) THEN
*
* Path 6 (M much larger than N, JOBU='S', JOBVT='S' or
* 'A')
*
WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
$ N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+( N-1 )*
$ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = N*N + WRKBL
MINWRK = MAX( 3*N+M, BDSPAC )
ELSE IF( WNTUA .AND. WNTVN ) THEN
*
* Path 7 (M much larger than N, JOBU='A', JOBVT='N')
*
WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M,
$ M, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = N*N + WRKBL
MINWRK = MAX( 3*N+M, BDSPAC )
ELSE IF( WNTUA .AND. WNTVO ) THEN
*
* Path 8 (M much larger than N, JOBU='A', JOBVT='O')
*
WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M,
$ M, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+( N-1 )*
$ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = 2*N*N + WRKBL
MINWRK = MAX( 3*N+M, BDSPAC )
ELSE IF( WNTUA .AND. WNTVAS ) THEN
*
* Path 9 (M much larger than N, JOBU='A', JOBVT='S' or
* 'A')
*
WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M,
$ M, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+( N-1 )*
$ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = N*N + WRKBL
MINWRK = MAX( 3*N+M, BDSPAC )
END IF
ELSE
*
* Path 10 (M at least N, but not much larger)
*
MAXWRK = 3*N + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N,
$ -1, -1 )
IF( WNTUS .OR. WNTUO )
$ MAXWRK = MAX( MAXWRK, 3*N+N*
$ ILAENV( 1, 'DORGBR', 'Q', M, N, N, -1 ) )
IF( WNTUA )
$ MAXWRK = MAX( MAXWRK, 3*N+M*
$ ILAENV( 1, 'DORGBR', 'Q', M, M, N, -1 ) )
IF( .NOT.WNTVN )
$ MAXWRK = MAX( MAXWRK, 3*N+( N-1 )*
$ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
MAXWRK = MAX( MAXWRK, BDSPAC )
MINWRK = MAX( 3*N+M, BDSPAC )
END IF
ELSE IF( MINMN.GT.0 ) THEN
*
* Compute space needed for DBDSQR
*
MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 )
BDSPAC = 5*M
IF( N.GE.MNTHR ) THEN
IF( WNTVN ) THEN
*
* Path 1t(N much larger than M, JOBVT='N')
*
MAXWRK = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1,
$ -1 )
MAXWRK = MAX( MAXWRK, 3*M+2*M*
$ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
IF( WNTUO .OR. WNTUAS )
$ MAXWRK = MAX( MAXWRK, 3*M+M*
$ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
MAXWRK = MAX( MAXWRK, BDSPAC )
MINWRK = MAX( 4*M, BDSPAC )
ELSE IF( WNTVO .AND. WNTUN ) THEN
*
* Path 2t(N much larger than M, JOBU='N', JOBVT='O')
*
WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
$ N, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*M+( M-1 )*
$ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = MAX( M*M+WRKBL, M*M+M*N+M )
MINWRK = MAX( 3*M+N, BDSPAC )
ELSE IF( WNTVO .AND. WNTUAS ) THEN
*
* Path 3t(N much larger than M, JOBU='S' or 'A',
* JOBVT='O')
*
WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
$ N, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*M+( M-1 )*
$ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = MAX( M*M+WRKBL, M*M+M*N+M )
MINWRK = MAX( 3*M+N, BDSPAC )
ELSE IF( WNTVS .AND. WNTUN ) THEN
*
* Path 4t(N much larger than M, JOBU='N', JOBVT='S')
*
WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
$ N, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*M+( M-1 )*
$ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = M*M + WRKBL
MINWRK = MAX( 3*M+N, BDSPAC )
ELSE IF( WNTVS .AND. WNTUO ) THEN
*
* Path 5t(N much larger than M, JOBU='O', JOBVT='S')
*
WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
$ N, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*M+( M-1 )*
$ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = 2*M*M + WRKBL
MINWRK = MAX( 3*M+N, BDSPAC )
ELSE IF( WNTVS .AND. WNTUAS ) THEN
*
* Path 6t(N much larger than M, JOBU='S' or 'A',
* JOBVT='S')
*
WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
$ N, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*M+( M-1 )*
$ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = M*M + WRKBL
MINWRK = MAX( 3*M+N, BDSPAC )
ELSE IF( WNTVA .AND. WNTUN ) THEN
*
* Path 7t(N much larger than M, JOBU='N', JOBVT='A')
*
WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N,
$ N, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*M+( M-1 )*
$ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = M*M + WRKBL
MINWRK = MAX( 3*M+N, BDSPAC )
ELSE IF( WNTVA .AND. WNTUO ) THEN
*
* Path 8t(N much larger than M, JOBU='O', JOBVT='A')
*
WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N,
$ N, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*M+( M-1 )*
$ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = 2*M*M + WRKBL
MINWRK = MAX( 3*M+N, BDSPAC )
ELSE IF( WNTVA .AND. WNTUAS ) THEN
*
* Path 9t(N much larger than M, JOBU='S' or 'A',
* JOBVT='A')
*
WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N,
$ N, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*M+( M-1 )*
$ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = M*M + WRKBL
MINWRK = MAX( 3*M+N, BDSPAC )
END IF
ELSE
*
* Path 10t(N greater than M, but not much larger)
*
MAXWRK = 3*M + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N,
$ -1, -1 )
IF( WNTVS .OR. WNTVO )
$ MAXWRK = MAX( MAXWRK, 3*M+M*
$ ILAENV( 1, 'DORGBR', 'P', M, N, M, -1 ) )
IF( WNTVA )
$ MAXWRK = MAX( MAXWRK, 3*M+N*
$ ILAENV( 1, 'DORGBR', 'P', N, N, M, -1 ) )
IF( .NOT.WNTUN )
$ MAXWRK = MAX( MAXWRK, 3*M+( M-1 )*
$ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
MAXWRK = MAX( MAXWRK, BDSPAC )
MINWRK = MAX( 3*M+N, BDSPAC )
END IF
END IF
MAXWRK = MAX( MAXWRK, MINWRK )
WORK( 1 ) = MAXWRK
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGESVD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
RETURN
END IF
*
* Get machine constants
*
EPS = DLAMCH( 'P' )
SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS
BIGNUM = ONE / SMLNUM
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = DLANGE( 'M', M, N, A, LDA, DUM )
ISCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
ISCL = 1
CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR )
ELSE IF( ANRM.GT.BIGNUM ) THEN
ISCL = 1
CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR )
END IF
*
IF( M.GE.N ) THEN
*
* A has at least as many rows as columns. If A has sufficiently
* more rows than columns, first reduce using the QR
* decomposition (if sufficient workspace available)
*
IF( M.GE.MNTHR ) THEN
*
IF( WNTUN ) THEN
*
* Path 1 (M much larger than N, JOBU='N')
* No left singular vectors to be computed
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Zero out below R
*
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
IE = 1
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in A
* (Workspace: need 4*N, prefer 3*N+2*N*NB)
*
CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
$ IERR )
NCVT = 0
IF( WNTVO .OR. WNTVAS ) THEN
*
* If right singular vectors desired, generate P'.
* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
*
CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
NCVT = N
END IF
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of A in A if desired
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', N, NCVT, 0, 0, S, WORK( IE ), A, LDA,
$ DUM, 1, DUM, 1, WORK( IWORK ), INFO )
*
* If right singular vectors desired in VT, copy them there
*
IF( WNTVAS )
$ CALL DLACPY( 'F', N, N, A, LDA, VT, LDVT )
*
ELSE IF( WNTUO .AND. WNTVN ) THEN
*
* Path 2 (M much larger than N, JOBU='O', JOBVT='N')
* N left singular vectors to be overwritten on A and
* no right singular vectors to be computed
*
IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+LDA*N ) THEN
*
* WORK(IU) is LDA by N, WORK(IR) is LDA by N
*
LDWRKU = LDA
LDWRKR = LDA
ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+N*N ) THEN
*
* WORK(IU) is LDA by N, WORK(IR) is N by N
*
LDWRKU = LDA
LDWRKR = N
ELSE
*
* WORK(IU) is LDWRKU by N, WORK(IR) is N by N
*
LDWRKU = ( LWORK-N*N-N ) / N
LDWRKR = N
END IF
ITAU = IR + LDWRKR*N
IWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to WORK(IR) and zero out below it
*
CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ),
$ LDWRKR )
*
* Generate Q in A
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IR)
* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
*
CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate left vectors bidiagonalizing R
* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
*
CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IR)
* (Workspace: need N*N+BDSPAC)
*
CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, 1,
$ WORK( IR ), LDWRKR, DUM, 1,
$ WORK( IWORK ), INFO )
IU = IE + N
*
* Multiply Q in A by left singular vectors of R in
* WORK(IR), storing result in WORK(IU) and copying to A
* (Workspace: need N*N+2*N, prefer N*N+M*N+N)
*
DO 10 I = 1, M, LDWRKU
CHUNK = MIN( M-I+1, LDWRKU )
CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
$ LDA, WORK( IR ), LDWRKR, ZERO,
$ WORK( IU ), LDWRKU )
CALL DLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
$ A( I, 1 ), LDA )
10 CONTINUE
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
IE = 1
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize A
* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB)
*
CALL DGEBRD( M, N, A, LDA, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate left vectors bidiagonalizing A
* (Workspace: need 4*N, prefer 3*N+N*NB)
*
CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in A
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM, 1,
$ A, LDA, DUM, 1, WORK( IWORK ), INFO )
*
END IF
*
ELSE IF( WNTUO .AND. WNTVAS ) THEN
*
* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or 'A')
* N left singular vectors to be overwritten on A and
* N right singular vectors to be computed in VT
*
IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+LDA*N ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is LDA by N
*
LDWRKU = LDA
LDWRKR = LDA
ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+N*N ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is N by N
*
LDWRKU = LDA
LDWRKR = N
ELSE
*
* WORK(IU) is LDWRKU by N and WORK(IR) is N by N
*
LDWRKU = ( LWORK-N*N-N ) / N
LDWRKR = N
END IF
ITAU = IR + LDWRKR*N
IWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to VT, zeroing out below it
*
CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
IF( N.GT.1 )
$ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
$ VT( 2, 1 ), LDVT )
*
* Generate Q in A
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in VT, copying result to WORK(IR)
* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
*
CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'L', N, N, VT, LDVT, WORK( IR ), LDWRKR )
*
* Generate left vectors bidiagonalizing R in WORK(IR)
* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
*
CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right vectors bidiagonalizing R in VT
* (Workspace: need N*N+4*N-1, prefer N*N+3*N+(N-1)*NB)
*
CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IR) and computing right
* singular vectors of R in VT
* (Workspace: need N*N+BDSPAC)
*
CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, LDVT,
$ WORK( IR ), LDWRKR, DUM, 1,
$ WORK( IWORK ), INFO )
IU = IE + N
*
* Multiply Q in A by left singular vectors of R in
* WORK(IR), storing result in WORK(IU) and copying to A
* (Workspace: need N*N+2*N, prefer N*N+M*N+N)
*
DO 20 I = 1, M, LDWRKU
CHUNK = MIN( M-I+1, LDWRKU )
CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
$ LDA, WORK( IR ), LDWRKR, ZERO,
$ WORK( IU ), LDWRKU )
CALL DLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
$ A( I, 1 ), LDA )
20 CONTINUE
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to VT, zeroing out below it
*
CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
IF( N.GT.1 )
$ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
$ VT( 2, 1 ), LDVT )
*
* Generate Q in A
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in VT
* (Workspace: need 4*N, prefer 3*N+2*N*NB)
*
CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in A by left vectors bidiagonalizing R
* (Workspace: need 3*N+M, prefer 3*N+M*NB)
*
CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
$ WORK( ITAUQ ), A, LDA, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right vectors bidiagonalizing R in VT
* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
*
CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in A and computing right
* singular vectors of A in VT
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT, LDVT,
$ A, LDA, DUM, 1, WORK( IWORK ), INFO )
*
END IF
*
ELSE IF( WNTUS ) THEN
*
IF( WNTVN ) THEN
*
* Path 4 (M much larger than N, JOBU='S', JOBVT='N')
* N left singular vectors to be computed in U and
* no right singular vectors to be computed
*
IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.WRKBL+LDA*N ) THEN
*
* WORK(IR) is LDA by N
*
LDWRKR = LDA
ELSE
*
* WORK(IR) is N by N
*
LDWRKR = N
END IF
ITAU = IR + LDWRKR*N
IWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to WORK(IR), zeroing out below it
*
CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ),
$ LDWRKR )
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
$ WORK( IR+1 ), LDWRKR )
*
* Generate Q in A
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IR)
* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
*
CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left vectors bidiagonalizing R in WORK(IR)
* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
*
CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IR)
* (Workspace: need N*N+BDSPAC)
*
CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM,
$ 1, WORK( IR ), LDWRKR, DUM, 1,
$ WORK( IWORK ), INFO )
*
* Multiply Q in A by left singular vectors of R in
* WORK(IR), storing result in U
* (Workspace: need N*N)
*
CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA,
$ WORK( IR ), LDWRKR, ZERO, U, LDU )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Zero out below R in A
*
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
$ LDA )
*
* Bidiagonalize R in A
* (Workspace: need 4*N, prefer 3*N+2*N*NB)
*
CALL DGEBRD( N, N, A, LDA, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in U by left vectors bidiagonalizing R
* (Workspace: need 3*N+M, prefer 3*N+M*NB)
*
CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM,
$ 1, U, LDU, DUM, 1, WORK( IWORK ),
$ INFO )
*
END IF
*
ELSE IF( WNTVO ) THEN
*
* Path 5 (M much larger than N, JOBU='S', JOBVT='O')
* N left singular vectors to be computed in U and
* N right singular vectors to be overwritten on A
*
IF( LWORK.GE.2*N*N+MAX( 4*N, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+2*LDA*N ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is LDA by N
*
LDWRKU = LDA
IR = IU + LDWRKU*N
LDWRKR = LDA
ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is N by N
*
LDWRKU = LDA
IR = IU + LDWRKU*N
LDWRKR = N
ELSE
*
* WORK(IU) is N by N and WORK(IR) is N by N
*
LDWRKU = N
IR = IU + LDWRKU*N
LDWRKR = N
END IF
ITAU = IR + LDWRKR*N
IWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to WORK(IU), zeroing out below it
*
CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ),
$ LDWRKU )
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
$ WORK( IU+1 ), LDWRKU )
*
* Generate Q in A
* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
*
CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IU), copying result to
* WORK(IR)
* (Workspace: need 2*N*N+4*N,
* prefer 2*N*N+3*N+2*N*NB)
*
CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU,
$ WORK( IR ), LDWRKR )
*
* Generate left bidiagonalizing vectors in WORK(IU)
* (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB)
*
CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in WORK(IR)
* (Workspace: need 2*N*N+4*N-1,
* prefer 2*N*N+3*N+(N-1)*NB)
*
CALL DORGBR( 'P', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IU) and computing
* right singular vectors of R in WORK(IR)
* (Workspace: need 2*N*N+BDSPAC)
*
CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ),
$ WORK( IR ), LDWRKR, WORK( IU ),
$ LDWRKU, DUM, 1, WORK( IWORK ), INFO )
*
* Multiply Q in A by left singular vectors of R in
* WORK(IU), storing result in U
* (Workspace: need N*N)
*
CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA,
$ WORK( IU ), LDWRKU, ZERO, U, LDU )
*
* Copy right singular vectors of R to A
* (Workspace: need N*N)
*
CALL DLACPY( 'F', N, N, WORK( IR ), LDWRKR, A,
$ LDA )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Zero out below R in A
*
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
$ LDA )
*
* Bidiagonalize R in A
* (Workspace: need 4*N, prefer 3*N+2*N*NB)
*
CALL DGEBRD( N, N, A, LDA, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in U by left vectors bidiagonalizing R
* (Workspace: need 3*N+M, prefer 3*N+M*NB)
*
CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right vectors bidiagonalizing R in A
* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
*
CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in A
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), A,
$ LDA, U, LDU, DUM, 1, WORK( IWORK ),
$ INFO )
*
END IF
*
ELSE IF( WNTVAS ) THEN
*
* Path 6 (M much larger than N, JOBU='S', JOBVT='S'
* or 'A')
* N left singular vectors to be computed in U and
* N right singular vectors to be computed in VT
*
IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+LDA*N ) THEN
*
* WORK(IU) is LDA by N
*
LDWRKU = LDA
ELSE
*
* WORK(IU) is N by N
*
LDWRKU = N
END IF
ITAU = IU + LDWRKU*N
IWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to WORK(IU), zeroing out below it
*
CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ),
$ LDWRKU )
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
$ WORK( IU+1 ), LDWRKU )
*
* Generate Q in A
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IU), copying result to VT
* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
*
CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT,
$ LDVT )
*
* Generate left bidiagonalizing vectors in WORK(IU)
* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
*
CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in VT
* (Workspace: need N*N+4*N-1,
* prefer N*N+3*N+(N-1)*NB)
*
CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IU) and computing
* right singular vectors of R in VT
* (Workspace: need N*N+BDSPAC)
*
CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT,
$ LDVT, WORK( IU ), LDWRKU, DUM, 1,
$ WORK( IWORK ), INFO )
*
* Multiply Q in A by left singular vectors of R in
* WORK(IU), storing result in U
* (Workspace: need N*N)
*
CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA,
$ WORK( IU ), LDWRKU, ZERO, U, LDU )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to VT, zeroing out below it
*
CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
IF( N.GT.1 )
$ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
$ VT( 2, 1 ), LDVT )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in VT
* (Workspace: need 4*N, prefer 3*N+2*N*NB)
*
CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in U by left bidiagonalizing vectors
* in VT
* (Workspace: need 3*N+M, prefer 3*N+M*NB)
*
CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
$ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in VT
* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
*
CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in VT
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT,
$ LDVT, U, LDU, DUM, 1, WORK( IWORK ),
$ INFO )
*
END IF
*
END IF
*
ELSE IF( WNTUA ) THEN
*
IF( WNTVN ) THEN
*
* Path 7 (M much larger than N, JOBU='A', JOBVT='N')
* M left singular vectors to be computed in U and
* no right singular vectors to be computed
*
IF( LWORK.GE.N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.WRKBL+LDA*N ) THEN
*
* WORK(IR) is LDA by N
*
LDWRKR = LDA
ELSE
*
* WORK(IR) is N by N
*
LDWRKR = N
END IF
ITAU = IR + LDWRKR*N
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Copy R to WORK(IR), zeroing out below it
*
CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ),
$ LDWRKR )
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
$ WORK( IR+1 ), LDWRKR )
*
* Generate Q in U
* (Workspace: need N*N+N+M, prefer N*N+N+M*NB)
*
CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IR)
* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
*
CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in WORK(IR)
* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
*
CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IR)
* (Workspace: need N*N+BDSPAC)
*
CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM,
$ 1, WORK( IR ), LDWRKR, DUM, 1,
$ WORK( IWORK ), INFO )
*
* Multiply Q in U by left singular vectors of R in
* WORK(IR), storing result in A
* (Workspace: need N*N)
*
CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU,
$ WORK( IR ), LDWRKR, ZERO, A, LDA )
*
* Copy left singular vectors of A from A to U
*
CALL DLACPY( 'F', M, N, A, LDA, U, LDU )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (Workspace: need N+M, prefer N+M*NB)
*
CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Zero out below R in A
*
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
$ LDA )
*
* Bidiagonalize R in A
* (Workspace: need 4*N, prefer 3*N+2*N*NB)
*
CALL DGEBRD( N, N, A, LDA, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in U by left bidiagonalizing vectors
* in A
* (Workspace: need 3*N+M, prefer 3*N+M*NB)
*
CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM,
$ 1, U, LDU, DUM, 1, WORK( IWORK ),
$ INFO )
*
END IF
*
ELSE IF( WNTVO ) THEN
*
* Path 8 (M much larger than N, JOBU='A', JOBVT='O')
* M left singular vectors to be computed in U and
* N right singular vectors to be overwritten on A
*
IF( LWORK.GE.2*N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+2*LDA*N ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is LDA by N
*
LDWRKU = LDA
IR = IU + LDWRKU*N
LDWRKR = LDA
ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is N by N
*
LDWRKU = LDA
IR = IU + LDWRKU*N
LDWRKR = N
ELSE
*
* WORK(IU) is N by N and WORK(IR) is N by N
*
LDWRKU = N
IR = IU + LDWRKU*N
LDWRKR = N
END IF
ITAU = IR + LDWRKR*N
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (Workspace: need 2*N*N+N+M, prefer 2*N*N+N+M*NB)
*
CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to WORK(IU), zeroing out below it
*
CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ),
$ LDWRKU )
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
$ WORK( IU+1 ), LDWRKU )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IU), copying result to
* WORK(IR)
* (Workspace: need 2*N*N+4*N,
* prefer 2*N*N+3*N+2*N*NB)
*
CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU,
$ WORK( IR ), LDWRKR )
*
* Generate left bidiagonalizing vectors in WORK(IU)
* (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB)
*
CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in WORK(IR)
* (Workspace: need 2*N*N+4*N-1,
* prefer 2*N*N+3*N+(N-1)*NB)
*
CALL DORGBR( 'P', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IU) and computing
* right singular vectors of R in WORK(IR)
* (Workspace: need 2*N*N+BDSPAC)
*
CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ),
$ WORK( IR ), LDWRKR, WORK( IU ),
$ LDWRKU, DUM, 1, WORK( IWORK ), INFO )
*
* Multiply Q in U by left singular vectors of R in
* WORK(IU), storing result in A
* (Workspace: need N*N)
*
CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU,
$ WORK( IU ), LDWRKU, ZERO, A, LDA )
*
* Copy left singular vectors of A from A to U
*
CALL DLACPY( 'F', M, N, A, LDA, U, LDU )
*
* Copy right singular vectors of R from WORK(IR) to A
*
CALL DLACPY( 'F', N, N, WORK( IR ), LDWRKR, A,
$ LDA )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (Workspace: need N+M, prefer N+M*NB)
*
CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Zero out below R in A
*
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
$ LDA )
*
* Bidiagonalize R in A
* (Workspace: need 4*N, prefer 3*N+2*N*NB)
*
CALL DGEBRD( N, N, A, LDA, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in U by left bidiagonalizing vectors
* in A
* (Workspace: need 3*N+M, prefer 3*N+M*NB)
*
CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in A
* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
*
CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in A
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), A,
$ LDA, U, LDU, DUM, 1, WORK( IWORK ),
$ INFO )
*
END IF
*
ELSE IF( WNTVAS ) THEN
*
* Path 9 (M much larger than N, JOBU='A', JOBVT='S'
* or 'A')
* M left singular vectors to be computed in U and
* N right singular vectors to be computed in VT
*
IF( LWORK.GE.N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+LDA*N ) THEN
*
* WORK(IU) is LDA by N
*
LDWRKU = LDA
ELSE
*
* WORK(IU) is N by N
*
LDWRKU = N
END IF
ITAU = IU + LDWRKU*N
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (Workspace: need N*N+N+M, prefer N*N+N+M*NB)
*
CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to WORK(IU), zeroing out below it
*
CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ),
$ LDWRKU )
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
$ WORK( IU+1 ), LDWRKU )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IU), copying result to VT
* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
*
CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT,
$ LDVT )
*
* Generate left bidiagonalizing vectors in WORK(IU)
* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
*
CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in VT
* (Workspace: need N*N+4*N-1,
* prefer N*N+3*N+(N-1)*NB)
*
CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IU) and computing
* right singular vectors of R in VT
* (Workspace: need N*N+BDSPAC)
*
CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT,
$ LDVT, WORK( IU ), LDWRKU, DUM, 1,
$ WORK( IWORK ), INFO )
*
* Multiply Q in U by left singular vectors of R in
* WORK(IU), storing result in A
* (Workspace: need N*N)
*
CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU,
$ WORK( IU ), LDWRKU, ZERO, A, LDA )
*
* Copy left singular vectors of A from A to U
*
CALL DLACPY( 'F', M, N, A, LDA, U, LDU )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (Workspace: need N+M, prefer N+M*NB)
*
CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R from A to VT, zeroing out below it
*
CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
IF( N.GT.1 )
$ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
$ VT( 2, 1 ), LDVT )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in VT
* (Workspace: need 4*N, prefer 3*N+2*N*NB)
*
CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in U by left bidiagonalizing vectors
* in VT
* (Workspace: need 3*N+M, prefer 3*N+M*NB)
*
CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
$ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in VT
* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
*
CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in VT
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT,
$ LDVT, U, LDU, DUM, 1, WORK( IWORK ),
$ INFO )
*
END IF
*
END IF
*
END IF
*
ELSE
*
* M .LT. MNTHR
*
* Path 10 (M at least N, but not much larger)
* Reduce to bidiagonal form without QR decomposition
*
IE = 1
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize A
* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB)
*
CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
$ IERR )
IF( WNTUAS ) THEN
*
* If left singular vectors desired in U, copy result to U
* and generate left bidiagonalizing vectors in U
* (Workspace: need 3*N+NCU, prefer 3*N+NCU*NB)
*
CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
IF( WNTUS )
$ NCU = N
IF( WNTUA )
$ NCU = M
CALL DORGBR( 'Q', M, NCU, N, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IF( WNTVAS ) THEN
*
* If right singular vectors desired in VT, copy result to
* VT and generate right bidiagonalizing vectors in VT
* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
*
CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IF( WNTUO ) THEN
*
* If left singular vectors desired in A, generate left
* bidiagonalizing vectors in A
* (Workspace: need 4*N, prefer 3*N+N*NB)
*
CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IF( WNTVO ) THEN
*
* If right singular vectors desired in A, generate right
* bidiagonalizing vectors in A
* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
*
CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IWORK = IE + N
IF( WNTUAS .OR. WNTUO )
$ NRU = M
IF( WNTUN )
$ NRU = 0
IF( WNTVAS .OR. WNTVO )
$ NCVT = N
IF( WNTVN )
$ NCVT = 0
IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN
*
* Perform bidiagonal QR iteration, if desired, computing
* left singular vectors in U and computing right singular
* vectors in VT
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), VT,
$ LDVT, U, LDU, DUM, 1, WORK( IWORK ), INFO )
ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN
*
* Perform bidiagonal QR iteration, if desired, computing
* left singular vectors in U and computing right singular
* vectors in A
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), A, LDA,
$ U, LDU, DUM, 1, WORK( IWORK ), INFO )
ELSE
*
* Perform bidiagonal QR iteration, if desired, computing
* left singular vectors in A and computing right singular
* vectors in VT
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), VT,
$ LDVT, A, LDA, DUM, 1, WORK( IWORK ), INFO )
END IF
*
END IF
*
ELSE
*
* A has more columns than rows. If A has sufficiently more
* columns than rows, first reduce using the LQ decomposition (if
* sufficient workspace available)
*
IF( N.GE.MNTHR ) THEN
*
IF( WNTVN ) THEN
*
* Path 1t(N much larger than M, JOBVT='N')
* No right singular vectors to be computed
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Zero out above L
*
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA )
IE = 1
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in A
* (Workspace: need 4*M, prefer 3*M+2*M*NB)
*
CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
$ IERR )
IF( WNTUO .OR. WNTUAS ) THEN
*
* If left singular vectors desired, generate Q
* (Workspace: need 4*M, prefer 3*M+M*NB)
*
CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IWORK = IE + M
NRU = 0
IF( WNTUO .OR. WNTUAS )
$ NRU = M
*
* Perform bidiagonal QR iteration, computing left singular
* vectors of A in A if desired
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', M, 0, NRU, 0, S, WORK( IE ), DUM, 1, A,
$ LDA, DUM, 1, WORK( IWORK ), INFO )
*
* If left singular vectors desired in U, copy them there
*
IF( WNTUAS )
$ CALL DLACPY( 'F', M, M, A, LDA, U, LDU )
*
ELSE IF( WNTVO .AND. WNTUN ) THEN
*
* Path 2t(N much larger than M, JOBU='N', JOBVT='O')
* M right singular vectors to be overwritten on A and
* no left singular vectors to be computed
*
IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+LDA*M ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is LDA by M
*
LDWRKU = LDA
CHUNK = N
LDWRKR = LDA
ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+M*M ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is M by M
*
LDWRKU = LDA
CHUNK = N
LDWRKR = M
ELSE
*
* WORK(IU) is M by CHUNK and WORK(IR) is M by M
*
LDWRKU = M
CHUNK = ( LWORK-M*M-M ) / M
LDWRKR = M
END IF
ITAU = IR + LDWRKR*M
IWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to WORK(IR) and zero out above it
*
CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ), LDWRKR )
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
$ WORK( IR+LDWRKR ), LDWRKR )
*
* Generate Q in A
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IR)
* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
*
CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate right vectors bidiagonalizing L
* (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB)
*
CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of L in WORK(IR)
* (Workspace: need M*M+BDSPAC)
*
CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ),
$ WORK( IR ), LDWRKR, DUM, 1, DUM, 1,
$ WORK( IWORK ), INFO )
IU = IE + M
*
* Multiply right singular vectors of L in WORK(IR) by Q
* in A, storing result in WORK(IU) and copying to A
* (Workspace: need M*M+2*M, prefer M*M+M*N+M)
*
DO 30 I = 1, N, CHUNK
BLK = MIN( N-I+1, CHUNK )
CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IR ),
$ LDWRKR, A( 1, I ), LDA, ZERO,
$ WORK( IU ), LDWRKU )
CALL DLACPY( 'F', M, BLK, WORK( IU ), LDWRKU,
$ A( 1, I ), LDA )
30 CONTINUE
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
IE = 1
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize A
* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
*
CALL DGEBRD( M, N, A, LDA, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate right vectors bidiagonalizing A
* (Workspace: need 4*M, prefer 3*M+M*NB)
*
CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of A in A
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'L', M, N, 0, 0, S, WORK( IE ), A, LDA,
$ DUM, 1, DUM, 1, WORK( IWORK ), INFO )
*
END IF
*
ELSE IF( WNTVO .AND. WNTUAS ) THEN
*
* Path 3t(N much larger than M, JOBU='S' or 'A', JOBVT='O')
* M right singular vectors to be overwritten on A and
* M left singular vectors to be computed in U
*
IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+LDA*M ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is LDA by M
*
LDWRKU = LDA
CHUNK = N
LDWRKR = LDA
ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+M*M ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is M by M
*
LDWRKU = LDA
CHUNK = N
LDWRKR = M
ELSE
*
* WORK(IU) is M by CHUNK and WORK(IR) is M by M
*
LDWRKU = M
CHUNK = ( LWORK-M*M-M ) / M
LDWRKR = M
END IF
ITAU = IR + LDWRKR*M
IWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to U, zeroing about above it
*
CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
$ LDU )
*
* Generate Q in A
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in U, copying result to WORK(IR)
* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
*
CALL DGEBRD( M, M, U, LDU, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'U', M, M, U, LDU, WORK( IR ), LDWRKR )
*
* Generate right vectors bidiagonalizing L in WORK(IR)
* (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB)
*
CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left vectors bidiagonalizing L in U
* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB)
*
CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of L in U, and computing right
* singular vectors of L in WORK(IR)
* (Workspace: need M*M+BDSPAC)
*
CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
$ WORK( IR ), LDWRKR, U, LDU, DUM, 1,
$ WORK( IWORK ), INFO )
IU = IE + M
*
* Multiply right singular vectors of L in WORK(IR) by Q
* in A, storing result in WORK(IU) and copying to A
* (Workspace: need M*M+2*M, prefer M*M+M*N+M))
*
DO 40 I = 1, N, CHUNK
BLK = MIN( N-I+1, CHUNK )
CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IR ),
$ LDWRKR, A( 1, I ), LDA, ZERO,
$ WORK( IU ), LDWRKU )
CALL DLACPY( 'F', M, BLK, WORK( IU ), LDWRKU,
$ A( 1, I ), LDA )
40 CONTINUE
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to U, zeroing out above it
*
CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
$ LDU )
*
* Generate Q in A
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in U
* (Workspace: need 4*M, prefer 3*M+2*M*NB)
*
CALL DGEBRD( M, M, U, LDU, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right vectors bidiagonalizing L by Q in A
* (Workspace: need 3*M+N, prefer 3*M+N*NB)
*
CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU,
$ WORK( ITAUP ), A, LDA, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left vectors bidiagonalizing L in U
* (Workspace: need 4*M, prefer 3*M+M*NB)
*
CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in A
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), A, LDA,
$ U, LDU, DUM, 1, WORK( IWORK ), INFO )
*
END IF
*
ELSE IF( WNTVS ) THEN
*
IF( WNTUN ) THEN
*
* Path 4t(N much larger than M, JOBU='N', JOBVT='S')
* M right singular vectors to be computed in VT and
* no left singular vectors to be computed
*
IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.WRKBL+LDA*M ) THEN
*
* WORK(IR) is LDA by M
*
LDWRKR = LDA
ELSE
*
* WORK(IR) is M by M
*
LDWRKR = M
END IF
ITAU = IR + LDWRKR*M
IWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to WORK(IR), zeroing out above it
*
CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ),
$ LDWRKR )
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
$ WORK( IR+LDWRKR ), LDWRKR )
*
* Generate Q in A
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IR)
* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
*
CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right vectors bidiagonalizing L in
* WORK(IR)
* (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB)
*
CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of L in WORK(IR)
* (Workspace: need M*M+BDSPAC)
*
CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ),
$ WORK( IR ), LDWRKR, DUM, 1, DUM, 1,
$ WORK( IWORK ), INFO )
*
* Multiply right singular vectors of L in WORK(IR) by
* Q in A, storing result in VT
* (Workspace: need M*M)
*
CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IR ),
$ LDWRKR, A, LDA, ZERO, VT, LDVT )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy result to VT
*
CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Zero out above L in A
*
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
$ LDA )
*
* Bidiagonalize L in A
* (Workspace: need 4*M, prefer 3*M+2*M*NB)
*
CALL DGEBRD( M, M, A, LDA, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right vectors bidiagonalizing L by Q in VT
* (Workspace: need 3*M+N, prefer 3*M+N*NB)
*
CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT,
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of A in VT
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', M, N, 0, 0, S, WORK( IE ), VT,
$ LDVT, DUM, 1, DUM, 1, WORK( IWORK ),
$ INFO )
*
END IF
*
ELSE IF( WNTUO ) THEN
*
* Path 5t(N much larger than M, JOBU='O', JOBVT='S')
* M right singular vectors to be computed in VT and
* M left singular vectors to be overwritten on A
*
IF( LWORK.GE.2*M*M+MAX( 4*M, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+2*LDA*M ) THEN
*
* WORK(IU) is LDA by M and WORK(IR) is LDA by M
*
LDWRKU = LDA
IR = IU + LDWRKU*M
LDWRKR = LDA
ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN
*
* WORK(IU) is LDA by M and WORK(IR) is M by M
*
LDWRKU = LDA
IR = IU + LDWRKU*M
LDWRKR = M
ELSE
*
* WORK(IU) is M by M and WORK(IR) is M by M
*
LDWRKU = M
IR = IU + LDWRKU*M
LDWRKR = M
END IF
ITAU = IR + LDWRKR*M
IWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to WORK(IU), zeroing out below it
*
CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ),
$ LDWRKU )
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
$ WORK( IU+LDWRKU ), LDWRKU )
*
* Generate Q in A
* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
*
CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IU), copying result to
* WORK(IR)
* (Workspace: need 2*M*M+4*M,
* prefer 2*M*M+3*M+2*M*NB)
*
CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU,
$ WORK( IR ), LDWRKR )
*
* Generate right bidiagonalizing vectors in WORK(IU)
* (Workspace: need 2*M*M+4*M-1,
* prefer 2*M*M+3*M+(M-1)*NB)
*
CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in WORK(IR)
* (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB)
*
CALL DORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of L in WORK(IR) and computing
* right singular vectors of L in WORK(IU)
* (Workspace: need 2*M*M+BDSPAC)
*
CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
$ WORK( IU ), LDWRKU, WORK( IR ),
$ LDWRKR, DUM, 1, WORK( IWORK ), INFO )
*
* Multiply right singular vectors of L in WORK(IU) by
* Q in A, storing result in VT
* (Workspace: need M*M)
*
CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
$ LDWRKU, A, LDA, ZERO, VT, LDVT )
*
* Copy left singular vectors of L to A
* (Workspace: need M*M)
*
CALL DLACPY( 'F', M, M, WORK( IR ), LDWRKR, A,
$ LDA )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Zero out above L in A
*
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
$ LDA )
*
* Bidiagonalize L in A
* (Workspace: need 4*M, prefer 3*M+2*M*NB)
*
CALL DGEBRD( M, M, A, LDA, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right vectors bidiagonalizing L by Q in VT
* (Workspace: need 3*M+N, prefer 3*M+N*NB)
*
CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT,
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors of L in A
* (Workspace: need 4*M, prefer 3*M+M*NB)
*
CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, compute left
* singular vectors of A in A and compute right
* singular vectors of A in VT
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
$ LDVT, A, LDA, DUM, 1, WORK( IWORK ),
$ INFO )
*
END IF
*
ELSE IF( WNTUAS ) THEN
*
* Path 6t(N much larger than M, JOBU='S' or 'A',
* JOBVT='S')
* M right singular vectors to be computed in VT and
* M left singular vectors to be computed in U
*
IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+LDA*M ) THEN
*
* WORK(IU) is LDA by N
*
LDWRKU = LDA
ELSE
*
* WORK(IU) is LDA by M
*
LDWRKU = M
END IF
ITAU = IU + LDWRKU*M
IWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to WORK(IU), zeroing out above it
*
CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ),
$ LDWRKU )
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
$ WORK( IU+LDWRKU ), LDWRKU )
*
* Generate Q in A
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IU), copying result to U
* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
*
CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, U,
$ LDU )
*
* Generate right bidiagonalizing vectors in WORK(IU)
* (Workspace: need M*M+4*M-1,
* prefer M*M+3*M+(M-1)*NB)
*
CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in U
* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB)
*
CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of L in U and computing right
* singular vectors of L in WORK(IU)
* (Workspace: need M*M+BDSPAC)
*
CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
$ WORK( IU ), LDWRKU, U, LDU, DUM, 1,
$ WORK( IWORK ), INFO )
*
* Multiply right singular vectors of L in WORK(IU) by
* Q in A, storing result in VT
* (Workspace: need M*M)
*
CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
$ LDWRKU, A, LDA, ZERO, VT, LDVT )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to U, zeroing out above it
*
CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
$ LDU )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in U
* (Workspace: need 4*M, prefer 3*M+2*M*NB)
*
CALL DGEBRD( M, M, U, LDU, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right bidiagonalizing vectors in U by Q
* in VT
* (Workspace: need 3*M+N, prefer 3*M+N*NB)
*
CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU,
$ WORK( ITAUP ), VT, LDVT,
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in U
* (Workspace: need 4*M, prefer 3*M+M*NB)
*
CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in VT
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
$ LDVT, U, LDU, DUM, 1, WORK( IWORK ),
$ INFO )
*
END IF
*
END IF
*
ELSE IF( WNTVA ) THEN
*
IF( WNTUN ) THEN
*
* Path 7t(N much larger than M, JOBU='N', JOBVT='A')
* N right singular vectors to be computed in VT and
* no left singular vectors to be computed
*
IF( LWORK.GE.M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.WRKBL+LDA*M ) THEN
*
* WORK(IR) is LDA by M
*
LDWRKR = LDA
ELSE
*
* WORK(IR) is M by M
*
LDWRKR = M
END IF
ITAU = IR + LDWRKR*M
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Copy L to WORK(IR), zeroing out above it
*
CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ),
$ LDWRKR )
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
$ WORK( IR+LDWRKR ), LDWRKR )
*
* Generate Q in VT
* (Workspace: need M*M+M+N, prefer M*M+M+N*NB)
*
CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IR)
* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
*
CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in WORK(IR)
* (Workspace: need M*M+4*M-1,
* prefer M*M+3*M+(M-1)*NB)
*
CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of L in WORK(IR)
* (Workspace: need M*M+BDSPAC)
*
CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ),
$ WORK( IR ), LDWRKR, DUM, 1, DUM, 1,
$ WORK( IWORK ), INFO )
*
* Multiply right singular vectors of L in WORK(IR) by
* Q in VT, storing result in A
* (Workspace: need M*M)
*
CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IR ),
$ LDWRKR, VT, LDVT, ZERO, A, LDA )
*
* Copy right singular vectors of A from A to VT
*
CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (Workspace: need M+N, prefer M+N*NB)
*
CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Zero out above L in A
*
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
$ LDA )
*
* Bidiagonalize L in A
* (Workspace: need 4*M, prefer 3*M+2*M*NB)
*
CALL DGEBRD( M, M, A, LDA, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right bidiagonalizing vectors in A by Q
* in VT
* (Workspace: need 3*M+N, prefer 3*M+N*NB)
*
CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT,
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of A in VT
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', M, N, 0, 0, S, WORK( IE ), VT,
$ LDVT, DUM, 1, DUM, 1, WORK( IWORK ),
$ INFO )
*
END IF
*
ELSE IF( WNTUO ) THEN
*
* Path 8t(N much larger than M, JOBU='O', JOBVT='A')
* N right singular vectors to be computed in VT and
* M left singular vectors to be overwritten on A
*
IF( LWORK.GE.2*M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+2*LDA*M ) THEN
*
* WORK(IU) is LDA by M and WORK(IR) is LDA by M
*
LDWRKU = LDA
IR = IU + LDWRKU*M
LDWRKR = LDA
ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN
*
* WORK(IU) is LDA by M and WORK(IR) is M by M
*
LDWRKU = LDA
IR = IU + LDWRKU*M
LDWRKR = M
ELSE
*
* WORK(IU) is M by M and WORK(IR) is M by M
*
LDWRKU = M
IR = IU + LDWRKU*M
LDWRKR = M
END IF
ITAU = IR + LDWRKR*M
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (Workspace: need 2*M*M+M+N, prefer 2*M*M+M+N*NB)
*
CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to WORK(IU), zeroing out above it
*
CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ),
$ LDWRKU )
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
$ WORK( IU+LDWRKU ), LDWRKU )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IU), copying result to
* WORK(IR)
* (Workspace: need 2*M*M+4*M,
* prefer 2*M*M+3*M+2*M*NB)
*
CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU,
$ WORK( IR ), LDWRKR )
*
* Generate right bidiagonalizing vectors in WORK(IU)
* (Workspace: need 2*M*M+4*M-1,
* prefer 2*M*M+3*M+(M-1)*NB)
*
CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in WORK(IR)
* (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB)
*
CALL DORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of L in WORK(IR) and computing
* right singular vectors of L in WORK(IU)
* (Workspace: need 2*M*M+BDSPAC)
*
CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
$ WORK( IU ), LDWRKU, WORK( IR ),
$ LDWRKR, DUM, 1, WORK( IWORK ), INFO )
*
* Multiply right singular vectors of L in WORK(IU) by
* Q in VT, storing result in A
* (Workspace: need M*M)
*
CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
$ LDWRKU, VT, LDVT, ZERO, A, LDA )
*
* Copy right singular vectors of A from A to VT
*
CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT )
*
* Copy left singular vectors of A from WORK(IR) to A
*
CALL DLACPY( 'F', M, M, WORK( IR ), LDWRKR, A,
$ LDA )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (Workspace: need M+N, prefer M+N*NB)
*
CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Zero out above L in A
*
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
$ LDA )
*
* Bidiagonalize L in A
* (Workspace: need 4*M, prefer 3*M+2*M*NB)
*
CALL DGEBRD( M, M, A, LDA, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right bidiagonalizing vectors in A by Q
* in VT
* (Workspace: need 3*M+N, prefer 3*M+N*NB)
*
CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT,
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in A
* (Workspace: need 4*M, prefer 3*M+M*NB)
*
CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in A and computing right
* singular vectors of A in VT
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
$ LDVT, A, LDA, DUM, 1, WORK( IWORK ),
$ INFO )
*
END IF
*
ELSE IF( WNTUAS ) THEN
*
* Path 9t(N much larger than M, JOBU='S' or 'A',
* JOBVT='A')
* N right singular vectors to be computed in VT and
* M left singular vectors to be computed in U
*
IF( LWORK.GE.M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+LDA*M ) THEN
*
* WORK(IU) is LDA by M
*
LDWRKU = LDA
ELSE
*
* WORK(IU) is M by M
*
LDWRKU = M
END IF
ITAU = IU + LDWRKU*M
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (Workspace: need M*M+M+N, prefer M*M+M+N*NB)
*
CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to WORK(IU), zeroing out above it
*
CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ),
$ LDWRKU )
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
$ WORK( IU+LDWRKU ), LDWRKU )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IU), copying result to U
* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
*
CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, U,
$ LDU )
*
* Generate right bidiagonalizing vectors in WORK(IU)
* (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB)
*
CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in U
* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB)
*
CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of L in U and computing right
* singular vectors of L in WORK(IU)
* (Workspace: need M*M+BDSPAC)
*
CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
$ WORK( IU ), LDWRKU, U, LDU, DUM, 1,
$ WORK( IWORK ), INFO )
*
* Multiply right singular vectors of L in WORK(IU) by
* Q in VT, storing result in A
* (Workspace: need M*M)
*
CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
$ LDWRKU, VT, LDVT, ZERO, A, LDA )
*
* Copy right singular vectors of A from A to VT
*
CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (Workspace: need M+N, prefer M+N*NB)
*
CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to U, zeroing out above it
*
CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
$ LDU )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in U
* (Workspace: need 4*M, prefer 3*M+2*M*NB)
*
CALL DGEBRD( M, M, U, LDU, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right bidiagonalizing vectors in U by Q
* in VT
* (Workspace: need 3*M+N, prefer 3*M+N*NB)
*
CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU,
$ WORK( ITAUP ), VT, LDVT,
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in U
* (Workspace: need 4*M, prefer 3*M+M*NB)
*
CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in VT
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
$ LDVT, U, LDU, DUM, 1, WORK( IWORK ),
$ INFO )
*
END IF
*
END IF
*
END IF
*
ELSE
*
* N .LT. MNTHR
*
* Path 10t(N greater than M, but not much larger)
* Reduce to bidiagonal form without LQ decomposition
*
IE = 1
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize A
* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
*
CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
$ IERR )
IF( WNTUAS ) THEN
*
* If left singular vectors desired in U, copy result to U
* and generate left bidiagonalizing vectors in U
* (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB)
*
CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
CALL DORGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IF( WNTVAS ) THEN
*
* If right singular vectors desired in VT, copy result to
* VT and generate right bidiagonalizing vectors in VT
* (Workspace: need 3*M+NRVT, prefer 3*M+NRVT*NB)
*
CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
IF( WNTVA )
$ NRVT = N
IF( WNTVS )
$ NRVT = M
CALL DORGBR( 'P', NRVT, N, M, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IF( WNTUO ) THEN
*
* If left singular vectors desired in A, generate left
* bidiagonalizing vectors in A
* (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB)
*
CALL DORGBR( 'Q', M, M, N, A, LDA, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IF( WNTVO ) THEN
*
* If right singular vectors desired in A, generate right
* bidiagonalizing vectors in A
* (Workspace: need 4*M, prefer 3*M+M*NB)
*
CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IWORK = IE + M
IF( WNTUAS .OR. WNTUO )
$ NRU = M
IF( WNTUN )
$ NRU = 0
IF( WNTVAS .OR. WNTVO )
$ NCVT = N
IF( WNTVN )
$ NCVT = 0
IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN
*
* Perform bidiagonal QR iteration, if desired, computing
* left singular vectors in U and computing right singular
* vectors in VT
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), VT,
$ LDVT, U, LDU, DUM, 1, WORK( IWORK ), INFO )
ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN
*
* Perform bidiagonal QR iteration, if desired, computing
* left singular vectors in U and computing right singular
* vectors in A
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), A, LDA,
$ U, LDU, DUM, 1, WORK( IWORK ), INFO )
ELSE
*
* Perform bidiagonal QR iteration, if desired, computing
* left singular vectors in A and computing right singular
* vectors in VT
* (Workspace: need BDSPAC)
*
CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), VT,
$ LDVT, A, LDA, DUM, 1, WORK( IWORK ), INFO )
END IF
*
END IF
*
END IF
*
* If DBDSQR failed to converge, copy unconverged superdiagonals
* to WORK( 2:MINMN )
*
IF( INFO.NE.0 ) THEN
IF( IE.GT.2 ) THEN
DO 50 I = 1, MINMN - 1
WORK( I+1 ) = WORK( I+IE-1 )
50 CONTINUE
END IF
IF( IE.LT.2 ) THEN
DO 60 I = MINMN - 1, 1, -1
WORK( I+1 ) = WORK( I+IE-1 )
60 CONTINUE
END IF
END IF
*
* Undo scaling if necessary
*
IF( ISCL.EQ.1 ) THEN
IF( ANRM.GT.BIGNUM )
$ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
$ IERR )
IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM )
$ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN-1, 1, WORK( 2 ),
$ MINMN, IERR )
IF( ANRM.LT.SMLNUM )
$ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
$ IERR )
IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM )
$ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN-1, 1, WORK( 2 ),
$ MINMN, IERR )
END IF
*
* Return optimal workspace in WORK(1)
*
WORK( 1 ) = MAXWRK
*
RETURN
*
* End of DGESVD
*
END
SUBROUTINE DGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV,
$ EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR,
$ WORK, IWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER EQUED, FACT, TRANS
INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), IWORK( * )
DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
$ BERR( * ), C( * ), FERR( * ), R( * ),
$ WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* DGESVX uses the LU factorization to compute the solution to a real
* system of linear equations
* A * X = B,
* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
*
* Error bounds on the solution and a condition estimate are also
* provided.
*
* Description
* ===========
*
* The following steps are performed:
*
* 1. If FACT = 'E', real scaling factors are computed to equilibrate
* the system:
* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B
* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
* Whether or not the system will be equilibrated depends on the
* scaling of the matrix A, but if equilibration is used, A is
* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
* or diag(C)*B (if TRANS = 'T' or 'C').
*
* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the
* matrix A (after equilibration if FACT = 'E') as
* A = P * L * U,
* where P is a permutation matrix, L is a unit lower triangular
* matrix, and U is upper triangular.
*
* 3. If some U(i,i)=0, so that U is exactly singular, then the routine
* returns with INFO = i. Otherwise, the factored form of A is used
* to estimate the condition number of the matrix A. If the
* reciprocal of the condition number is less than machine precision,
* INFO = N+1 is returned as a warning, but the routine still goes on
* to solve for X and compute error bounds as described below.
*
* 4. The system of equations is solved for X using the factored form
* of A.
*
* 5. Iterative refinement is applied to improve the computed solution
* matrix and calculate error bounds and backward error estimates
* for it.
*
* 6. If equilibration was used, the matrix X is premultiplied by
* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
* that it solves the original system before equilibration.
*
* Arguments
* =========
*
* FACT (input) CHARACTER*1
* Specifies whether or not the factored form of the matrix A is
* supplied on entry, and if not, whether the matrix A should be
* equilibrated before it is factored.
* = 'F': On entry, AF and IPIV contain the factored form of A.
* If EQUED is not 'N', the matrix A has been
* equilibrated with scaling factors given by R and C.
* A, AF, and IPIV are not modified.
* = 'N': The matrix A will be copied to AF and factored.
* = 'E': The matrix A will be equilibrated if necessary, then
* copied to AF and factored.
*
* 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**H * X = B (Transpose)
*
* N (input) INTEGER
* The number of linear equations, i.e., 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 matrices B and X. NRHS >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is
* not 'N', then A must have been equilibrated by the scaling
* factors in R and/or C. A is not modified if FACT = 'F' or
* 'N', or if FACT = 'E' and EQUED = 'N' on exit.
*
* On exit, if EQUED .ne. 'N', A is scaled as follows:
* EQUED = 'R': A := diag(R) * A
* EQUED = 'C': A := A * diag(C)
* EQUED = 'B': A := diag(R) * A * diag(C).
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N)
* If FACT = 'F', then AF is an input argument and on entry
* contains the factors L and U from the factorization
* A = P*L*U as computed by DGETRF. If EQUED .ne. 'N', then
* AF is the factored form of the equilibrated matrix A.
*
* If FACT = 'N', then AF is an output argument and on exit
* returns the factors L and U from the factorization A = P*L*U
* of the original matrix A.
*
* If FACT = 'E', then AF is an output argument and on exit
* returns the factors L and U from the factorization A = P*L*U
* of the equilibrated matrix A (see the description of A for
* the form of the equilibrated matrix).
*
* LDAF (input) INTEGER
* The leading dimension of the array AF. LDAF >= max(1,N).
*
* IPIV (input or output) INTEGER array, dimension (N)
* If FACT = 'F', then IPIV is an input argument and on entry
* contains the pivot indices from the factorization A = P*L*U
* as computed by DGETRF; row i of the matrix was interchanged
* with row IPIV(i).
*
* If FACT = 'N', then IPIV is an output argument and on exit
* contains the pivot indices from the factorization A = P*L*U
* of the original matrix A.
*
* If FACT = 'E', then IPIV is an output argument and on exit
* contains the pivot indices from the factorization A = P*L*U
* of the equilibrated matrix A.
*
* EQUED (input or output) CHARACTER*1
* Specifies the form of equilibration that was done.
* = 'N': No equilibration (always true if FACT = 'N').
* = 'R': Row equilibration, i.e., A has been premultiplied by
* diag(R).
* = 'C': Column equilibration, i.e., A has been postmultiplied
* by diag(C).
* = 'B': Both row and column equilibration, i.e., A has been
* replaced by diag(R) * A * diag(C).
* EQUED is an input argument if FACT = 'F'; otherwise, it is an
* output argument.
*
* R (input or output) DOUBLE PRECISION array, dimension (N)
* The row scale factors for A. If EQUED = 'R' or 'B', A is
* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
* is not accessed. R is an input argument if FACT = 'F';
* otherwise, R is an output argument. If FACT = 'F' and
* EQUED = 'R' or 'B', each element of R must be positive.
*
* C (input or output) DOUBLE PRECISION array, dimension (N)
* The column scale factors for A. If EQUED = 'C' or 'B', A is
* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
* is not accessed. C is an input argument if FACT = 'F';
* otherwise, C is an output argument. If FACT = 'F' and
* EQUED = 'C' or 'B', each element of C must be positive.
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the N-by-NRHS right hand side matrix B.
* On exit,
* if EQUED = 'N', B is not modified;
* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
* diag(R)*B;
* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
* overwritten by diag(C)*B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X
* to the original system of equations. Note that A and B are
* modified on exit if EQUED .ne. 'N', and the solution to the
* equilibrated system is inv(diag(C))*X if TRANS = 'N' and
* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'
* and EQUED = 'R' or 'B'.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* RCOND (output) DOUBLE PRECISION
* The estimate of the reciprocal condition number of the matrix
* A after equilibration (if done). If RCOND is less than the
* machine precision (in particular, if RCOND = 0), the matrix
* is singular to working precision. This condition is
* indicated by a return code of INFO > 0.
*
* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace/output) DOUBLE PRECISION array, dimension (4*N)
* On exit, WORK(1) contains the reciprocal pivot growth
* factor norm(A)/norm(U). The "max absolute element" norm is
* used. If WORK(1) is much less than 1, then the stability
* of the LU factorization of the (equilibrated) matrix A
* could be poor. This also means that the solution X, condition
* estimator RCOND, and forward error bound FERR could be
* unreliable. If factorization fails with 0 0: if INFO = i, and i is
* <= N: U(i,i) is exactly zero. The factorization has
* been completed, but the factor U is exactly
* singular, so the solution and error bounds
* could not be computed. RCOND = 0 is returned.
* = N+1: U is nonsingular, but RCOND is less than machine
* precision, meaning that the matrix is singular
* to working precision. Nevertheless, the
* solution and error bounds are computed because
* there are a number of situations where the
* computed solution can be more accurate than the
* value of RCOND would suggest.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU
CHARACTER NORM
INTEGER I, INFEQU, J
DOUBLE PRECISION AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN,
$ ROWCND, RPVGRW, SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANGE, DLANTR
EXTERNAL LSAME, DLAMCH, DLANGE, DLANTR
* ..
* .. External Subroutines ..
EXTERNAL DGECON, DGEEQU, DGERFS, DGETRF, DGETRS, DLACPY,
$ DLAQGE, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
NOFACT = LSAME( FACT, 'N' )
EQUIL = LSAME( FACT, 'E' )
NOTRAN = LSAME( TRANS, 'N' )
IF( NOFACT .OR. EQUIL ) THEN
EQUED = 'N'
ROWEQU = .FALSE.
COLEQU = .FALSE.
ELSE
ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
SMLNUM = DLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
END IF
*
* Test the input parameters.
*
IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
$ THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
$ LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
$ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
INFO = -10
ELSE
IF( ROWEQU ) THEN
RCMIN = BIGNUM
RCMAX = ZERO
DO 10 J = 1, N
RCMIN = MIN( RCMIN, R( J ) )
RCMAX = MAX( RCMAX, R( J ) )
10 CONTINUE
IF( RCMIN.LE.ZERO ) THEN
INFO = -11
ELSE IF( N.GT.0 ) THEN
ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
ELSE
ROWCND = ONE
END IF
END IF
IF( COLEQU .AND. INFO.EQ.0 ) THEN
RCMIN = BIGNUM
RCMAX = ZERO
DO 20 J = 1, N
RCMIN = MIN( RCMIN, C( J ) )
RCMAX = MAX( RCMAX, C( J ) )
20 CONTINUE
IF( RCMIN.LE.ZERO ) THEN
INFO = -12
ELSE IF( N.GT.0 ) THEN
COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
ELSE
COLCND = ONE
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -14
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -16
END IF
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGESVX', -INFO )
RETURN
END IF
*
IF( EQUIL ) THEN
*
* Compute row and column scalings to equilibrate the matrix A.
*
CALL DGEEQU( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFEQU )
IF( INFEQU.EQ.0 ) THEN
*
* Equilibrate the matrix.
*
CALL DLAQGE( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
$ EQUED )
ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
END IF
END IF
*
* Scale the right hand side.
*
IF( NOTRAN ) THEN
IF( ROWEQU ) THEN
DO 40 J = 1, NRHS
DO 30 I = 1, N
B( I, J ) = R( I )*B( I, J )
30 CONTINUE
40 CONTINUE
END IF
ELSE IF( COLEQU ) THEN
DO 60 J = 1, NRHS
DO 50 I = 1, N
B( I, J ) = C( I )*B( I, J )
50 CONTINUE
60 CONTINUE
END IF
*
IF( NOFACT .OR. EQUIL ) THEN
*
* Compute the LU factorization of A.
*
CALL DLACPY( 'Full', N, N, A, LDA, AF, LDAF )
CALL DGETRF( N, N, AF, LDAF, IPIV, INFO )
*
* Return if INFO is non-zero.
*
IF( INFO.GT.0 ) THEN
*
* Compute the reciprocal pivot growth factor of the
* leading rank-deficient INFO columns of A.
*
RPVGRW = DLANTR( 'M', 'U', 'N', INFO, INFO, AF, LDAF,
$ WORK )
IF( RPVGRW.EQ.ZERO ) THEN
RPVGRW = ONE
ELSE
RPVGRW = DLANGE( 'M', N, INFO, A, LDA, WORK ) / RPVGRW
END IF
WORK( 1 ) = RPVGRW
RCOND = ZERO
RETURN
END IF
END IF
*
* Compute the norm of the matrix A and the
* reciprocal pivot growth factor RPVGRW.
*
IF( NOTRAN ) THEN
NORM = '1'
ELSE
NORM = 'I'
END IF
ANORM = DLANGE( NORM, N, N, A, LDA, WORK )
RPVGRW = DLANTR( 'M', 'U', 'N', N, N, AF, LDAF, WORK )
IF( RPVGRW.EQ.ZERO ) THEN
RPVGRW = ONE
ELSE
RPVGRW = DLANGE( 'M', N, N, A, LDA, WORK ) / RPVGRW
END IF
*
* Compute the reciprocal of the condition number of A.
*
CALL DGECON( NORM, N, AF, LDAF, ANORM, RCOND, WORK, IWORK, INFO )
*
* Compute the solution matrix X.
*
CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
CALL DGETRS( TRANS, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO )
*
* Use iterative refinement to improve the computed solution and
* compute error bounds and backward error estimates for it.
*
CALL DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X,
$ LDX, FERR, BERR, WORK, IWORK, INFO )
*
* Transform the solution matrix X to a solution of the original
* system.
*
IF( NOTRAN ) THEN
IF( COLEQU ) THEN
DO 80 J = 1, NRHS
DO 70 I = 1, N
X( I, J ) = C( I )*X( I, J )
70 CONTINUE
80 CONTINUE
DO 90 J = 1, NRHS
FERR( J ) = FERR( J ) / COLCND
90 CONTINUE
END IF
ELSE IF( ROWEQU ) THEN
DO 110 J = 1, NRHS
DO 100 I = 1, N
X( I, J ) = R( I )*X( I, J )
100 CONTINUE
110 CONTINUE
DO 120 J = 1, NRHS
FERR( J ) = FERR( J ) / ROWCND
120 CONTINUE
END IF
*
WORK( 1 ) = RPVGRW
*
* Set INFO = N+1 if the matrix is singular to working precision.
*
IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
$ INFO = N + 1
RETURN
*
* End of DGESVX
*
END
SUBROUTINE DGETC2( N, A, LDA, IPIV, JPIV, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), JPIV( * )
DOUBLE PRECISION A( LDA, * )
* ..
*
* Purpose
* =======
*
* DGETC2 computes an LU factorization with complete pivoting of the
* n-by-n matrix A. The factorization has the form A = P * L * U * Q,
* where P and Q are permutation matrices, L is lower triangular with
* unit diagonal elements and U is upper triangular.
*
* This is the Level 2 BLAS algorithm.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
* On entry, the n-by-n matrix A to be factored.
* On exit, the factors L and U from the factorization
* A = P*L*U*Q; the unit diagonal elements of L are not stored.
* If U(k, k) appears to be less than SMIN, U(k, k) is given the
* value of SMIN, i.e., giving a nonsingular perturbed system.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* IPIV (output) INTEGER array, dimension(N).
* The pivot indices; for 1 <= i <= N, row i of the
* matrix has been interchanged with row IPIV(i).
*
* JPIV (output) INTEGER array, dimension(N).
* The pivot indices; for 1 <= j <= N, column j of the
* matrix has been interchanged with column JPIV(j).
*
* INFO (output) INTEGER
* = 0: successful exit
* > 0: if INFO = k, U(k, k) is likely to produce owerflow if
* we try to solve for x in Ax = b. So U is perturbed to
* avoid the overflow.
*
* Further Details
* ===============
*
* Based on contributions by
* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
* Umea University, S-901 87 Umea, Sweden.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, IP, IPV, J, JP, JPV
DOUBLE PRECISION BIGNUM, EPS, SMIN, SMLNUM, XMAX
* ..
* .. External Subroutines ..
EXTERNAL DGER, DSWAP
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Set constants to control overflow
*
INFO = 0
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' ) / EPS
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
*
* Factorize A using complete pivoting.
* Set pivots less than SMIN to SMIN.
*
DO 40 I = 1, N - 1
*
* Find max element in matrix A
*
XMAX = ZERO
DO 20 IP = I, N
DO 10 JP = I, N
IF( ABS( A( IP, JP ) ).GE.XMAX ) THEN
XMAX = ABS( A( IP, JP ) )
IPV = IP
JPV = JP
END IF
10 CONTINUE
20 CONTINUE
IF( I.EQ.1 )
$ SMIN = MAX( EPS*XMAX, SMLNUM )
*
* Swap rows
*
IF( IPV.NE.I )
$ CALL DSWAP( N, A( IPV, 1 ), LDA, A( I, 1 ), LDA )
IPIV( I ) = IPV
*
* Swap columns
*
IF( JPV.NE.I )
$ CALL DSWAP( N, A( 1, JPV ), 1, A( 1, I ), 1 )
JPIV( I ) = JPV
*
* Check for singularity
*
IF( ABS( A( I, I ) ).LT.SMIN ) THEN
INFO = I
A( I, I ) = SMIN
END IF
DO 30 J = I + 1, N
A( J, I ) = A( J, I ) / A( I, I )
30 CONTINUE
CALL DGER( N-I, N-I, -ONE, A( I+1, I ), 1, A( I, I+1 ), LDA,
$ A( I+1, I+1 ), LDA )
40 CONTINUE
*
IF( ABS( A( N, N ) ).LT.SMIN ) THEN
INFO = N
A( N, N ) = SMIN
END IF
*
RETURN
*
* End of DGETC2
*
END
SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley 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.1) --
* Univ. of Tennessee, Univ. of California Berkeley 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 DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGETRI computes the inverse of a matrix using the LU factorization
* computed by DGETRF.
*
* This method inverts U and then computes inv(A) by solving the system
* inv(A)*L = inv(U) for inv(A).
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the factors L and U from the factorization
* A = P*L*U as computed by DGETRF.
* On exit, if INFO = 0, the inverse of the original matrix A.
*
* 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).
*
* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
* On exit, if INFO=0, then WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK. LWORK >= max(1,N).
* For optimal performance LWORK >= N*NB, where NB is
* the optimal blocksize returned by ILAENV.
*
* 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
* > 0: if INFO = i, U(i,i) is exactly zero; the matrix is
* singular and its inverse could not be computed.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB,
$ NBMIN, NN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DGEMV, DSWAP, DTRSM, DTRTRI, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
NB = ILAENV( 1, 'DGETRI', ' ', N, -1, -1, -1 )
LWKOPT = N*NB
WORK( 1 ) = LWKOPT
LQUERY = ( LWORK.EQ.-1 )
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -3
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGETRI', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Form inv(U). If INFO > 0 from DTRTRI, then U is singular,
* and the inverse is not computed.
*
CALL DTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO )
IF( INFO.GT.0 )
$ RETURN
*
NBMIN = 2
LDWORK = N
IF( NB.GT.1 .AND. NB.LT.N ) THEN
IWS = MAX( LDWORK*NB, 1 )
IF( LWORK.LT.IWS ) THEN
NB = LWORK / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'DGETRI', ' ', N, -1, -1, -1 ) )
END IF
ELSE
IWS = N
END IF
*
* Solve the equation inv(A)*L = inv(U) for inv(A).
*
IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN
*
* Use unblocked code.
*
DO 20 J = N, 1, -1
*
* Copy current column of L to WORK and replace with zeros.
*
DO 10 I = J + 1, N
WORK( I ) = A( I, J )
A( I, J ) = ZERO
10 CONTINUE
*
* Compute current column of inv(A).
*
IF( J.LT.N )
$ CALL DGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ),
$ LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 )
20 CONTINUE
ELSE
*
* Use blocked code.
*
NN = ( ( N-1 ) / NB )*NB + 1
DO 50 J = NN, 1, -NB
JB = MIN( NB, N-J+1 )
*
* Copy current block column of L to WORK and replace with
* zeros.
*
DO 40 JJ = J, J + JB - 1
DO 30 I = JJ + 1, N
WORK( I+( JJ-J )*LDWORK ) = A( I, JJ )
A( I, JJ ) = ZERO
30 CONTINUE
40 CONTINUE
*
* Compute current block column of inv(A).
*
IF( J+JB.LE.N )
$ CALL DGEMM( 'No transpose', 'No transpose', N, JB,
$ N-J-JB+1, -ONE, A( 1, J+JB ), LDA,
$ WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA )
CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB,
$ ONE, WORK( J ), LDWORK, A( 1, J ), LDA )
50 CONTINUE
END IF
*
* Apply column interchanges.
*
DO 60 J = N - 1, 1, -1
JP = IPIV( J )
IF( JP.NE.J )
$ CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 )
60 CONTINUE
*
WORK( 1 ) = IWS
RETURN
*
* End of DGETRI
*
END
SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. 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' * 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'* X = B (Transpose)
* = 'C': A'* 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' * X = B.
*
* Solve U'*X = B, overwriting B with X.
*
CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS,
$ ONE, A, LDA, B, LDB )
*
* Solve L'*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
SUBROUTINE DGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V,
$ LDV, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOB, SIDE
INTEGER IHI, ILO, INFO, LDV, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION LSCALE( * ), RSCALE( * ), V( LDV, * )
* ..
*
* Purpose
* =======
*
* DGGBAK forms the right or left eigenvectors of a real generalized
* eigenvalue problem A*x = lambda*B*x, by backward transformation on
* the computed eigenvectors of the balanced pair of matrices output by
* DGGBAL.
*
* Arguments
* =========
*
* JOB (input) CHARACTER*1
* Specifies the type of backward transformation required:
* = 'N': do nothing, return immediately;
* = 'P': do backward transformation for permutation only;
* = 'S': do backward transformation for scaling only;
* = 'B': do backward transformations for both permutation and
* scaling.
* JOB must be the same as the argument JOB supplied to DGGBAL.
*
* SIDE (input) CHARACTER*1
* = 'R': V contains right eigenvectors;
* = 'L': V contains left eigenvectors.
*
* N (input) INTEGER
* The number of rows of the matrix V. N >= 0.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* The integers ILO and IHI determined by DGGBAL.
* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
*
* LSCALE (input) DOUBLE PRECISION array, dimension (N)
* Details of the permutations and/or scaling factors applied
* to the left side of A and B, as returned by DGGBAL.
*
* RSCALE (input) DOUBLE PRECISION array, dimension (N)
* Details of the permutations and/or scaling factors applied
* to the right side of A and B, as returned by DGGBAL.
*
* M (input) INTEGER
* The number of columns of the matrix V. M >= 0.
*
* V (input/output) DOUBLE PRECISION array, dimension (LDV,M)
* On entry, the matrix of right or left eigenvectors to be
* transformed, as returned by DTGEVC.
* On exit, V is overwritten by the transformed eigenvectors.
*
* LDV (input) INTEGER
* The leading dimension of the matrix V. LDV >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* See R.C. Ward, Balancing the generalized eigenvalue problem,
* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LEFTV, RIGHTV
INTEGER I, K
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
RIGHTV = LSAME( SIDE, 'R' )
LEFTV = LSAME( SIDE, 'L' )
*
INFO = 0
IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
$ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
INFO = -1
ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ILO.LT.1 ) THEN
INFO = -4
ELSE IF( N.EQ.0 .AND. IHI.EQ.0 .AND. ILO.NE.1 ) THEN
INFO = -4
ELSE IF( N.GT.0 .AND. ( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) )
$ THEN
INFO = -5
ELSE IF( N.EQ.0 .AND. ILO.EQ.1 .AND. IHI.NE.0 ) THEN
INFO = -5
ELSE IF( M.LT.0 ) THEN
INFO = -8
ELSE IF( LDV.LT.MAX( 1, N ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGGBAK', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
IF( M.EQ.0 )
$ RETURN
IF( LSAME( JOB, 'N' ) )
$ RETURN
*
IF( ILO.EQ.IHI )
$ GO TO 30
*
* Backward balance
*
IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN
*
* Backward transformation on right eigenvectors
*
IF( RIGHTV ) THEN
DO 10 I = ILO, IHI
CALL DSCAL( M, RSCALE( I ), V( I, 1 ), LDV )
10 CONTINUE
END IF
*
* Backward transformation on left eigenvectors
*
IF( LEFTV ) THEN
DO 20 I = ILO, IHI
CALL DSCAL( M, LSCALE( I ), V( I, 1 ), LDV )
20 CONTINUE
END IF
END IF
*
* Backward permutation
*
30 CONTINUE
IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN
*
* Backward permutation on right eigenvectors
*
IF( RIGHTV ) THEN
IF( ILO.EQ.1 )
$ GO TO 50
*
DO 40 I = ILO - 1, 1, -1
K = RSCALE( I )
IF( K.EQ.I )
$ GO TO 40
CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
40 CONTINUE
*
50 CONTINUE
IF( IHI.EQ.N )
$ GO TO 70
DO 60 I = IHI + 1, N
K = RSCALE( I )
IF( K.EQ.I )
$ GO TO 60
CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
60 CONTINUE
END IF
*
* Backward permutation on left eigenvectors
*
70 CONTINUE
IF( LEFTV ) THEN
IF( ILO.EQ.1 )
$ GO TO 90
DO 80 I = ILO - 1, 1, -1
K = LSCALE( I )
IF( K.EQ.I )
$ GO TO 80
CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
80 CONTINUE
*
90 CONTINUE
IF( IHI.EQ.N )
$ GO TO 110
DO 100 I = IHI + 1, N
K = LSCALE( I )
IF( K.EQ.I )
$ GO TO 100
CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
100 CONTINUE
END IF
END IF
*
110 CONTINUE
*
RETURN
*
* End of DGGBAK
*
END
SUBROUTINE DGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE,
$ RSCALE, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOB
INTEGER IHI, ILO, INFO, LDA, LDB, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), LSCALE( * ),
$ RSCALE( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGGBAL balances a pair of general real matrices (A,B). This
* involves, first, permuting A and B by similarity transformations to
* isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N
* elements on the diagonal; and second, applying a diagonal similarity
* transformation to rows and columns ILO to IHI to make the rows
* and columns as close in norm as possible. Both steps are optional.
*
* Balancing may reduce the 1-norm of the matrices, and improve the
* accuracy of the computed eigenvalues and/or eigenvectors in the
* generalized eigenvalue problem A*x = lambda*B*x.
*
* Arguments
* =========
*
* JOB (input) CHARACTER*1
* Specifies the operations to be performed on A and B:
* = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0
* and RSCALE(I) = 1.0 for i = 1,...,N.
* = 'P': permute only;
* = 'S': scale only;
* = 'B': both permute and scale.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the input matrix A.
* On exit, A is overwritten by the balanced matrix.
* If JOB = 'N', A is not referenced.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)
* On entry, the input matrix B.
* On exit, B is overwritten by the balanced matrix.
* If JOB = 'N', B is not referenced.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* ILO (output) INTEGER
* IHI (output) INTEGER
* ILO and IHI are set to integers such that on exit
* A(i,j) = 0 and B(i,j) = 0 if i > j and
* j = 1,...,ILO-1 or i = IHI+1,...,N.
* If JOB = 'N' or 'S', ILO = 1 and IHI = N.
*
* LSCALE (output) DOUBLE PRECISION array, dimension (N)
* Details of the permutations and scaling factors applied
* to the left side of A and B. If P(j) is the index of the
* row interchanged with row j, and D(j)
* is the scaling factor applied to row j, then
* LSCALE(j) = P(j) for J = 1,...,ILO-1
* = D(j) for J = ILO,...,IHI
* = P(j) for J = IHI+1,...,N.
* The order in which the interchanges are made is N to IHI+1,
* then 1 to ILO-1.
*
* RSCALE (output) DOUBLE PRECISION array, dimension (N)
* Details of the permutations and scaling factors applied
* to the right side of A and B. If P(j) is the index of the
* column interchanged with column j, and D(j)
* is the scaling factor applied to column j, then
* LSCALE(j) = P(j) for J = 1,...,ILO-1
* = D(j) for J = ILO,...,IHI
* = P(j) for J = IHI+1,...,N.
* The order in which the interchanges are made is N to IHI+1,
* then 1 to ILO-1.
*
* WORK (workspace) REAL array, dimension (lwork)
* lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and
* at least 1 when JOB = 'N' or 'P'.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* See R.C. WARD, Balancing the generalized eigenvalue problem,
* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
DOUBLE PRECISION THREE, SCLFAC
PARAMETER ( THREE = 3.0D+0, SCLFAC = 1.0D+1 )
* ..
* .. Local Scalars ..
INTEGER I, ICAB, IFLOW, IP1, IR, IRAB, IT, J, JC, JP1,
$ K, KOUNT, L, LCAB, LM1, LRAB, LSFMAX, LSFMIN,
$ M, NR, NRP2
DOUBLE PRECISION ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2,
$ COEF5, COR, EW, EWC, GAMMA, PGAMMA, RAB, SFMAX,
$ SFMIN, SUM, T, TA, TB, TC
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DDOT, DLAMCH
EXTERNAL LSAME, IDAMAX, DDOT, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DSCAL, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, INT, LOG10, MAX, MIN, SIGN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
$ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGGBAL', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
ILO = 1
IHI = N
RETURN
END IF
*
IF( N.EQ.1 ) THEN
ILO = 1
IHI = N
LSCALE( 1 ) = ONE
RSCALE( 1 ) = ONE
RETURN
END IF
*
IF( LSAME( JOB, 'N' ) ) THEN
ILO = 1
IHI = N
DO 10 I = 1, N
LSCALE( I ) = ONE
RSCALE( I ) = ONE
10 CONTINUE
RETURN
END IF
*
K = 1
L = N
IF( LSAME( JOB, 'S' ) )
$ GO TO 190
*
GO TO 30
*
* Permute the matrices A and B to isolate the eigenvalues.
*
* Find row with one nonzero in columns 1 through L
*
20 CONTINUE
L = LM1
IF( L.NE.1 )
$ GO TO 30
*
RSCALE( 1 ) = ONE
LSCALE( 1 ) = ONE
GO TO 190
*
30 CONTINUE
LM1 = L - 1
DO 80 I = L, 1, -1
DO 40 J = 1, LM1
JP1 = J + 1
IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO )
$ GO TO 50
40 CONTINUE
J = L
GO TO 70
*
50 CONTINUE
DO 60 J = JP1, L
IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO )
$ GO TO 80
60 CONTINUE
J = JP1 - 1
*
70 CONTINUE
M = L
IFLOW = 1
GO TO 160
80 CONTINUE
GO TO 100
*
* Find column with one nonzero in rows K through N
*
90 CONTINUE
K = K + 1
*
100 CONTINUE
DO 150 J = K, L
DO 110 I = K, LM1
IP1 = I + 1
IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO )
$ GO TO 120
110 CONTINUE
I = L
GO TO 140
120 CONTINUE
DO 130 I = IP1, L
IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO )
$ GO TO 150
130 CONTINUE
I = IP1 - 1
140 CONTINUE
M = K
IFLOW = 2
GO TO 160
150 CONTINUE
GO TO 190
*
* Permute rows M and I
*
160 CONTINUE
LSCALE( M ) = I
IF( I.EQ.M )
$ GO TO 170
CALL DSWAP( N-K+1, A( I, K ), LDA, A( M, K ), LDA )
CALL DSWAP( N-K+1, B( I, K ), LDB, B( M, K ), LDB )
*
* Permute columns M and J
*
170 CONTINUE
RSCALE( M ) = J
IF( J.EQ.M )
$ GO TO 180
CALL DSWAP( L, A( 1, J ), 1, A( 1, M ), 1 )
CALL DSWAP( L, B( 1, J ), 1, B( 1, M ), 1 )
*
180 CONTINUE
GO TO ( 20, 90 )IFLOW
*
190 CONTINUE
ILO = K
IHI = L
*
IF( LSAME( JOB, 'P' ) ) THEN
DO 195 I = ILO, IHI
LSCALE( I ) = ONE
RSCALE( I ) = ONE
195 CONTINUE
RETURN
END IF
*
IF( ILO.EQ.IHI )
$ RETURN
*
* Balance the submatrix in rows ILO to IHI.
*
NR = IHI - ILO + 1
DO 200 I = ILO, IHI
RSCALE( I ) = ZERO
LSCALE( I ) = ZERO
*
WORK( I ) = ZERO
WORK( I+N ) = ZERO
WORK( I+2*N ) = ZERO
WORK( I+3*N ) = ZERO
WORK( I+4*N ) = ZERO
WORK( I+5*N ) = ZERO
200 CONTINUE
*
* Compute right side vector in resulting linear equations
*
BASL = LOG10( SCLFAC )
DO 240 I = ILO, IHI
DO 230 J = ILO, IHI
TB = B( I, J )
TA = A( I, J )
IF( TA.EQ.ZERO )
$ GO TO 210
TA = LOG10( ABS( TA ) ) / BASL
210 CONTINUE
IF( TB.EQ.ZERO )
$ GO TO 220
TB = LOG10( ABS( TB ) ) / BASL
220 CONTINUE
WORK( I+4*N ) = WORK( I+4*N ) - TA - TB
WORK( J+5*N ) = WORK( J+5*N ) - TA - TB
230 CONTINUE
240 CONTINUE
*
COEF = ONE / DBLE( 2*NR )
COEF2 = COEF*COEF
COEF5 = HALF*COEF2
NRP2 = NR + 2
BETA = ZERO
IT = 1
*
* Start generalized conjugate gradient iteration
*
250 CONTINUE
*
GAMMA = DDOT( NR, WORK( ILO+4*N ), 1, WORK( ILO+4*N ), 1 ) +
$ DDOT( NR, WORK( ILO+5*N ), 1, WORK( ILO+5*N ), 1 )
*
EW = ZERO
EWC = ZERO
DO 260 I = ILO, IHI
EW = EW + WORK( I+4*N )
EWC = EWC + WORK( I+5*N )
260 CONTINUE
*
GAMMA = COEF*GAMMA - COEF2*( EW**2+EWC**2 ) - COEF5*( EW-EWC )**2
IF( GAMMA.EQ.ZERO )
$ GO TO 350
IF( IT.NE.1 )
$ BETA = GAMMA / PGAMMA
T = COEF5*( EWC-THREE*EW )
TC = COEF5*( EW-THREE*EWC )
*
CALL DSCAL( NR, BETA, WORK( ILO ), 1 )
CALL DSCAL( NR, BETA, WORK( ILO+N ), 1 )
*
CALL DAXPY( NR, COEF, WORK( ILO+4*N ), 1, WORK( ILO+N ), 1 )
CALL DAXPY( NR, COEF, WORK( ILO+5*N ), 1, WORK( ILO ), 1 )
*
DO 270 I = ILO, IHI
WORK( I ) = WORK( I ) + TC
WORK( I+N ) = WORK( I+N ) + T
270 CONTINUE
*
* Apply matrix to vector
*
DO 300 I = ILO, IHI
KOUNT = 0
SUM = ZERO
DO 290 J = ILO, IHI
IF( A( I, J ).EQ.ZERO )
$ GO TO 280
KOUNT = KOUNT + 1
SUM = SUM + WORK( J )
280 CONTINUE
IF( B( I, J ).EQ.ZERO )
$ GO TO 290
KOUNT = KOUNT + 1
SUM = SUM + WORK( J )
290 CONTINUE
WORK( I+2*N ) = DBLE( KOUNT )*WORK( I+N ) + SUM
300 CONTINUE
*
DO 330 J = ILO, IHI
KOUNT = 0
SUM = ZERO
DO 320 I = ILO, IHI
IF( A( I, J ).EQ.ZERO )
$ GO TO 310
KOUNT = KOUNT + 1
SUM = SUM + WORK( I+N )
310 CONTINUE
IF( B( I, J ).EQ.ZERO )
$ GO TO 320
KOUNT = KOUNT + 1
SUM = SUM + WORK( I+N )
320 CONTINUE
WORK( J+3*N ) = DBLE( KOUNT )*WORK( J ) + SUM
330 CONTINUE
*
SUM = DDOT( NR, WORK( ILO+N ), 1, WORK( ILO+2*N ), 1 ) +
$ DDOT( NR, WORK( ILO ), 1, WORK( ILO+3*N ), 1 )
ALPHA = GAMMA / SUM
*
* Determine correction to current iteration
*
CMAX = ZERO
DO 340 I = ILO, IHI
COR = ALPHA*WORK( I+N )
IF( ABS( COR ).GT.CMAX )
$ CMAX = ABS( COR )
LSCALE( I ) = LSCALE( I ) + COR
COR = ALPHA*WORK( I )
IF( ABS( COR ).GT.CMAX )
$ CMAX = ABS( COR )
RSCALE( I ) = RSCALE( I ) + COR
340 CONTINUE
IF( CMAX.LT.HALF )
$ GO TO 350
*
CALL DAXPY( NR, -ALPHA, WORK( ILO+2*N ), 1, WORK( ILO+4*N ), 1 )
CALL DAXPY( NR, -ALPHA, WORK( ILO+3*N ), 1, WORK( ILO+5*N ), 1 )
*
PGAMMA = GAMMA
IT = IT + 1
IF( IT.LE.NRP2 )
$ GO TO 250
*
* End generalized conjugate gradient iteration
*
350 CONTINUE
SFMIN = DLAMCH( 'S' )
SFMAX = ONE / SFMIN
LSFMIN = INT( LOG10( SFMIN ) / BASL+ONE )
LSFMAX = INT( LOG10( SFMAX ) / BASL )
DO 360 I = ILO, IHI
IRAB = IDAMAX( N-ILO+1, A( I, ILO ), LDA )
RAB = ABS( A( I, IRAB+ILO-1 ) )
IRAB = IDAMAX( N-ILO+1, B( I, ILO ), LDB )
RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) )
LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE )
IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) )
IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB )
LSCALE( I ) = SCLFAC**IR
ICAB = IDAMAX( IHI, A( 1, I ), 1 )
CAB = ABS( A( ICAB, I ) )
ICAB = IDAMAX( IHI, B( 1, I ), 1 )
CAB = MAX( CAB, ABS( B( ICAB, I ) ) )
LCAB = INT( LOG10( CAB+SFMIN ) / BASL+ONE )
JC = RSCALE( I ) + SIGN( HALF, RSCALE( I ) )
JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB )
RSCALE( I ) = SCLFAC**JC
360 CONTINUE
*
* Row scaling of matrices A and B
*
DO 370 I = ILO, IHI
CALL DSCAL( N-ILO+1, LSCALE( I ), A( I, ILO ), LDA )
CALL DSCAL( N-ILO+1, LSCALE( I ), B( I, ILO ), LDB )
370 CONTINUE
*
* Column scaling of matrices A and B
*
DO 380 J = ILO, IHI
CALL DSCAL( IHI, RSCALE( J ), A( 1, J ), 1 )
CALL DSCAL( IHI, RSCALE( J ), B( 1, J ), 1 )
380 CONTINUE
*
RETURN
*
* End of DGGBAL
*
END
SUBROUTINE DGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB,
$ SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR,
$ LDVSR, WORK, LWORK, BWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBVSL, JOBVSR, SORT
INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM
* ..
* .. Array Arguments ..
LOGICAL BWORK( * )
DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
$ B( LDB, * ), BETA( * ), VSL( LDVSL, * ),
$ VSR( LDVSR, * ), WORK( * )
* ..
* .. Function Arguments ..
LOGICAL SELCTG
EXTERNAL SELCTG
* ..
*
* Purpose
* =======
*
* DGGES computes for a pair of N-by-N real nonsymmetric matrices (A,B),
* the generalized eigenvalues, the generalized real Schur form (S,T),
* optionally, the left and/or right matrices of Schur vectors (VSL and
* VSR). This gives the generalized Schur factorization
*
* (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T )
*
* Optionally, it also orders the eigenvalues so that a selected cluster
* of eigenvalues appears in the leading diagonal blocks of the upper
* quasi-triangular matrix S and the upper triangular matrix T.The
* leading columns of VSL and VSR then form an orthonormal basis for the
* corresponding left and right eigenspaces (deflating subspaces).
*
* (If only the generalized eigenvalues are needed, use the driver
* DGGEV instead, which is faster.)
*
* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
* or a ratio alpha/beta = w, such that A - w*B is singular. It is
* usually represented as the pair (alpha,beta), as there is a
* reasonable interpretation for beta=0 or both being zero.
*
* A pair of matrices (S,T) is in generalized real Schur form if T is
* upper triangular with non-negative diagonal and S is block upper
* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond
* to real generalized eigenvalues, while 2-by-2 blocks of S will be
* "standardized" by making the corresponding elements of T have the
* form:
* [ a 0 ]
* [ 0 b ]
*
* and the pair of corresponding 2-by-2 blocks in S and T will have a
* complex conjugate pair of generalized eigenvalues.
*
*
* Arguments
* =========
*
* JOBVSL (input) CHARACTER*1
* = 'N': do not compute the left Schur vectors;
* = 'V': compute the left Schur vectors.
*
* JOBVSR (input) CHARACTER*1
* = 'N': do not compute the right Schur vectors;
* = 'V': compute the right Schur vectors.
*
* SORT (input) CHARACTER*1
* Specifies whether or not to order the eigenvalues on the
* diagonal of the generalized Schur form.
* = 'N': Eigenvalues are not ordered;
* = 'S': Eigenvalues are ordered (see SELCTG);
*
* SELCTG (external procedure) LOGICAL FUNCTION of three DOUBLE PRECISION arguments
* SELCTG must be declared EXTERNAL in the calling subroutine.
* If SORT = 'N', SELCTG is not referenced.
* If SORT = 'S', SELCTG is used to select eigenvalues to sort
* to the top left of the Schur form.
* An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if
* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either
* one of a complex conjugate pair of eigenvalues is selected,
* then both complex eigenvalues are selected.
*
* Note that in the ill-conditioned case, a selected complex
* eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j),
* BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2
* in this case.
*
* N (input) INTEGER
* The order of the matrices A, B, VSL, and VSR. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
* On entry, the first of the pair of matrices.
* On exit, A has been overwritten by its generalized Schur
* form S.
*
* LDA (input) INTEGER
* The leading dimension of A. LDA >= max(1,N).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
* On entry, the second of the pair of matrices.
* On exit, B has been overwritten by its generalized Schur
* form T.
*
* LDB (input) INTEGER
* The leading dimension of B. LDB >= max(1,N).
*
* SDIM (output) INTEGER
* If SORT = 'N', SDIM = 0.
* If SORT = 'S', SDIM = number of eigenvalues (after sorting)
* for which SELCTG is true. (Complex conjugate pairs for which
* SELCTG is true for either eigenvalue count as 2.)
*
* ALPHAR (output) DOUBLE PRECISION array, dimension (N)
* ALPHAI (output) DOUBLE PRECISION array, dimension (N)
* BETA (output) DOUBLE PRECISION array, dimension (N)
* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i,
* and BETA(j),j=1,...,N are the diagonals of the complex Schur
* form (S,T) that would result if the 2-by-2 diagonal blocks of
* the real Schur form of (A,B) were further reduced to
* triangular form using 2-by-2 complex unitary transformations.
* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
* positive, then the j-th and (j+1)-st eigenvalues are a
* complex conjugate pair, with ALPHAI(j+1) negative.
*
* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
* may easily over- or underflow, and BETA(j) may even be zero.
* Thus, the user should avoid naively computing the ratio.
* However, ALPHAR and ALPHAI will be always less than and
* usually comparable with norm(A) in magnitude, and BETA always
* less than and usually comparable with norm(B).
*
* VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N)
* If JOBVSL = 'V', VSL will contain the left Schur vectors.
* Not referenced if JOBVSL = 'N'.
*
* LDVSL (input) INTEGER
* The leading dimension of the matrix VSL. LDVSL >=1, and
* if JOBVSL = 'V', LDVSL >= N.
*
* VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N)
* If JOBVSR = 'V', VSR will contain the right Schur vectors.
* Not referenced if JOBVSR = 'N'.
*
* LDVSR (input) INTEGER
* The leading dimension of the matrix VSR. LDVSR >= 1, and
* if JOBVSR = 'V', LDVSR >= N.
*
* 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 N = 0, LWORK >= 1, else LWORK >= 8*N+16.
* For good performance , LWORK must generally be larger.
*
* 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.
*
* BWORK (workspace) LOGICAL array, dimension (N)
* Not referenced if SORT = 'N'.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* = 1,...,N:
* The QZ iteration failed. (A,B) are not in Schur
* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should
* be correct for j=INFO+1,...,N.
* > N: =N+1: other than QZ iteration failed in DHGEQZ.
* =N+2: after reordering, roundoff changed values of
* some complex eigenvalues so that leading
* eigenvalues in the Generalized Schur form no
* longer satisfy SELCTG=.TRUE. This could also
* be caused due to scaling.
* =N+3: reordering failed in DTGSEN.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL,
$ LQUERY, LST2SL, WANTST
INTEGER I, ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT,
$ ILO, IP, IRIGHT, IROWS, ITAU, IWRK, MAXWRK,
$ MINWRK
DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PVSL,
$ PVSR, SAFMAX, SAFMIN, SMLNUM
* ..
* .. Local Arrays ..
INTEGER IDUM( 1 )
DOUBLE PRECISION DIF( 2 )
* ..
* .. External Subroutines ..
EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLABAD,
$ DLACPY, DLASCL, DLASET, DORGQR, DORMQR, DTGSEN,
$ XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Decode the input arguments
*
IF( LSAME( JOBVSL, 'N' ) ) THEN
IJOBVL = 1
ILVSL = .FALSE.
ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN
IJOBVL = 2
ILVSL = .TRUE.
ELSE
IJOBVL = -1
ILVSL = .FALSE.
END IF
*
IF( LSAME( JOBVSR, 'N' ) ) THEN
IJOBVR = 1
ILVSR = .FALSE.
ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN
IJOBVR = 2
ILVSR = .TRUE.
ELSE
IJOBVR = -1
ILVSR = .FALSE.
END IF
*
WANTST = LSAME( SORT, 'S' )
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
IF( IJOBVL.LE.0 ) THEN
INFO = -1
ELSE IF( IJOBVR.LE.0 ) THEN
INFO = -2
ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN
INFO = -15
ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN
INFO = -17
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.)
*
IF( INFO.EQ.0 ) THEN
IF( N.GT.0 )THEN
MINWRK = MAX( 8*N, 6*N + 16 )
MAXWRK = MINWRK - N +
$ N*ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 )
MAXWRK = MAX( MAXWRK, MINWRK - N +
$ N*ILAENV( 1, 'DORMQR', ' ', N, 1, N, -1 ) )
IF( ILVSL ) THEN
MAXWRK = MAX( MAXWRK, MINWRK - N +
$ N*ILAENV( 1, 'DORGQR', ' ', N, 1, N, -1 ) )
END IF
ELSE
MINWRK = 1
MAXWRK = 1
END IF
WORK( 1 ) = MAXWRK
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY )
$ INFO = -19
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGGES ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
SDIM = 0
RETURN
END IF
*
* Get machine constants
*
EPS = DLAMCH( 'P' )
SAFMIN = DLAMCH( 'S' )
SAFMAX = ONE / SAFMIN
CALL DLABAD( SAFMIN, SAFMAX )
SMLNUM = SQRT( SAFMIN ) / EPS
BIGNUM = ONE / SMLNUM
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = DLANGE( 'M', N, N, A, LDA, WORK )
ILASCL = .FALSE.
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
ANRMTO = SMLNUM
ILASCL = .TRUE.
ELSE IF( ANRM.GT.BIGNUM ) THEN
ANRMTO = BIGNUM
ILASCL = .TRUE.
END IF
IF( ILASCL )
$ CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
*
* Scale B if max element outside range [SMLNUM,BIGNUM]
*
BNRM = DLANGE( 'M', N, N, B, LDB, WORK )
ILBSCL = .FALSE.
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
BNRMTO = SMLNUM
ILBSCL = .TRUE.
ELSE IF( BNRM.GT.BIGNUM ) THEN
BNRMTO = BIGNUM
ILBSCL = .TRUE.
END IF
IF( ILBSCL )
$ CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
*
* Permute the matrix to make it more nearly triangular
* (Workspace: need 6*N + 2*N space for storing balancing factors)
*
ILEFT = 1
IRIGHT = N + 1
IWRK = IRIGHT + N
CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ),
$ WORK( IRIGHT ), WORK( IWRK ), IERR )
*
* Reduce B to triangular form (QR decomposition of B)
* (Workspace: need N, prefer N*NB)
*
IROWS = IHI + 1 - ILO
ICOLS = N + 1 - ILO
ITAU = IWRK
IWRK = ITAU + IROWS
CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
$ WORK( IWRK ), LWORK+1-IWRK, IERR )
*
* Apply the orthogonal transformation to matrix A
* (Workspace: need N, prefer N*NB)
*
CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
$ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
$ LWORK+1-IWRK, IERR )
*
* Initialize VSL
* (Workspace: need N, prefer N*NB)
*
IF( ILVSL ) THEN
CALL DLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL )
IF( IROWS.GT.1 ) THEN
CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
$ VSL( ILO+1, ILO ), LDVSL )
END IF
CALL DORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL,
$ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
END IF
*
* Initialize VSR
*
IF( ILVSR )
$ CALL DLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR )
*
* Reduce to generalized Hessenberg form
* (Workspace: none needed)
*
CALL DGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL,
$ LDVSL, VSR, LDVSR, IERR )
*
* Perform QZ algorithm, computing Schur vectors if desired
* (Workspace: need N)
*
IWRK = ITAU
CALL DHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB,
$ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR,
$ WORK( IWRK ), LWORK+1-IWRK, IERR )
IF( IERR.NE.0 ) THEN
IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
INFO = IERR
ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
INFO = IERR - N
ELSE
INFO = N + 1
END IF
GO TO 50
END IF
*
* Sort eigenvalues ALPHA/BETA if desired
* (Workspace: need 4*N+16 )
*
SDIM = 0
IF( WANTST ) THEN
*
* Undo scaling on eigenvalues before SELCTGing
*
IF( ILASCL ) THEN
CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N,
$ IERR )
CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N,
$ IERR )
END IF
IF( ILBSCL )
$ CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
*
* Select eigenvalues
*
DO 10 I = 1, N
BWORK( I ) = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) )
10 CONTINUE
*
CALL DTGSEN( 0, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, ALPHAR,
$ ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, SDIM, PVSL,
$ PVSR, DIF, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1,
$ IERR )
IF( IERR.EQ.1 )
$ INFO = N + 3
*
END IF
*
* Apply back-permutation to VSL and VSR
* (Workspace: none needed)
*
IF( ILVSL )
$ CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
$ WORK( IRIGHT ), N, VSL, LDVSL, IERR )
*
IF( ILVSR )
$ CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ),
$ WORK( IRIGHT ), N, VSR, LDVSR, IERR )
*
* Check if unscaling would cause over/underflow, if so, rescale
* (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of
* B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I)
*
IF( ILASCL ) THEN
DO 20 I = 1, N
IF( ALPHAI( I ).NE.ZERO ) THEN
IF( ( ALPHAR( I ) / SAFMAX ).GT.( ANRMTO / ANRM ) .OR.
$ ( SAFMIN / ALPHAR( I ) ).GT.( ANRM / ANRMTO ) ) THEN
WORK( 1 ) = ABS( A( I, I ) / ALPHAR( I ) )
BETA( I ) = BETA( I )*WORK( 1 )
ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
ELSE IF( ( ALPHAI( I ) / SAFMAX ).GT.
$ ( ANRMTO / ANRM ) .OR.
$ ( SAFMIN / ALPHAI( I ) ).GT.( ANRM / ANRMTO ) )
$ THEN
WORK( 1 ) = ABS( A( I, I+1 ) / ALPHAI( I ) )
BETA( I ) = BETA( I )*WORK( 1 )
ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
END IF
END IF
20 CONTINUE
END IF
*
IF( ILBSCL ) THEN
DO 30 I = 1, N
IF( ALPHAI( I ).NE.ZERO ) THEN
IF( ( BETA( I ) / SAFMAX ).GT.( BNRMTO / BNRM ) .OR.
$ ( SAFMIN / BETA( I ) ).GT.( BNRM / BNRMTO ) ) THEN
WORK( 1 ) = ABS( B( I, I ) / BETA( I ) )
BETA( I ) = BETA( I )*WORK( 1 )
ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
END IF
END IF
30 CONTINUE
END IF
*
* Undo scaling
*
IF( ILASCL ) THEN
CALL DLASCL( 'H', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR )
CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
END IF
*
IF( ILBSCL ) THEN
CALL DLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR )
CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
END IF
*
IF( WANTST ) THEN
*
* Check if reordering is correct
*
LASTSL = .TRUE.
LST2SL = .TRUE.
SDIM = 0
IP = 0
DO 40 I = 1, N
CURSL = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) )
IF( ALPHAI( I ).EQ.ZERO ) THEN
IF( CURSL )
$ SDIM = SDIM + 1
IP = 0
IF( CURSL .AND. .NOT.LASTSL )
$ INFO = N + 2
ELSE
IF( IP.EQ.1 ) THEN
*
* Last eigenvalue of conjugate pair
*
CURSL = CURSL .OR. LASTSL
LASTSL = CURSL
IF( CURSL )
$ SDIM = SDIM + 2
IP = -1
IF( CURSL .AND. .NOT.LST2SL )
$ INFO = N + 2
ELSE
*
* First eigenvalue of conjugate pair
*
IP = 1
END IF
END IF
LST2SL = LASTSL
LASTSL = CURSL
40 CONTINUE
*
END IF
*
50 CONTINUE
*
WORK( 1 ) = MAXWRK
*
RETURN
*
* End of DGGES
*
END
SUBROUTINE DGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA,
$ B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL,
$ VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, IWORK,
$ LIWORK, BWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBVSL, JOBVSR, SENSE, SORT
INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LIWORK, LWORK, N,
$ SDIM
* ..
* .. Array Arguments ..
LOGICAL BWORK( * )
INTEGER IWORK( * )
DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
$ B( LDB, * ), BETA( * ), RCONDE( 2 ),
$ RCONDV( 2 ), VSL( LDVSL, * ), VSR( LDVSR, * ),
$ WORK( * )
* ..
* .. Function Arguments ..
LOGICAL SELCTG
EXTERNAL SELCTG
* ..
*
* Purpose
* =======
*
* DGGESX computes for a pair of N-by-N real nonsymmetric matrices
* (A,B), the generalized eigenvalues, the real Schur form (S,T), and,
* optionally, the left and/or right matrices of Schur vectors (VSL and
* VSR). This gives the generalized Schur factorization
*
* (A,B) = ( (VSL) S (VSR)**T, (VSL) T (VSR)**T )
*
* Optionally, it also orders the eigenvalues so that a selected cluster
* of eigenvalues appears in the leading diagonal blocks of the upper
* quasi-triangular matrix S and the upper triangular matrix T; computes
* a reciprocal condition number for the average of the selected
* eigenvalues (RCONDE); and computes a reciprocal condition number for
* the right and left deflating subspaces corresponding to the selected
* eigenvalues (RCONDV). The leading columns of VSL and VSR then form
* an orthonormal basis for the corresponding left and right eigenspaces
* (deflating subspaces).
*
* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
* or a ratio alpha/beta = w, such that A - w*B is singular. It is
* usually represented as the pair (alpha,beta), as there is a
* reasonable interpretation for beta=0 or for both being zero.
*
* A pair of matrices (S,T) is in generalized real Schur form if T is
* upper triangular with non-negative diagonal and S is block upper
* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond
* to real generalized eigenvalues, while 2-by-2 blocks of S will be
* "standardized" by making the corresponding elements of T have the
* form:
* [ a 0 ]
* [ 0 b ]
*
* and the pair of corresponding 2-by-2 blocks in S and T will have a
* complex conjugate pair of generalized eigenvalues.
*
*
* Arguments
* =========
*
* JOBVSL (input) CHARACTER*1
* = 'N': do not compute the left Schur vectors;
* = 'V': compute the left Schur vectors.
*
* JOBVSR (input) CHARACTER*1
* = 'N': do not compute the right Schur vectors;
* = 'V': compute the right Schur vectors.
*
* SORT (input) CHARACTER*1
* Specifies whether or not to order the eigenvalues on the
* diagonal of the generalized Schur form.
* = 'N': Eigenvalues are not ordered;
* = 'S': Eigenvalues are ordered (see SELCTG).
*
* SELCTG (external procedure) LOGICAL FUNCTION of three DOUBLE PRECISION arguments
* SELCTG must be declared EXTERNAL in the calling subroutine.
* If SORT = 'N', SELCTG is not referenced.
* If SORT = 'S', SELCTG is used to select eigenvalues to sort
* to the top left of the Schur form.
* An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if
* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either
* one of a complex conjugate pair of eigenvalues is selected,
* then both complex eigenvalues are selected.
* Note that a selected complex eigenvalue may no longer satisfy
* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) = .TRUE. after ordering,
* since ordering may change the value of complex eigenvalues
* (especially if the eigenvalue is ill-conditioned), in this
* case INFO is set to N+3.
*
* SENSE (input) CHARACTER*1
* Determines which reciprocal condition numbers are computed.
* = 'N' : None are computed;
* = 'E' : Computed for average of selected eigenvalues only;
* = 'V' : Computed for selected deflating subspaces only;
* = 'B' : Computed for both.
* If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.
*
* N (input) INTEGER
* The order of the matrices A, B, VSL, and VSR. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
* On entry, the first of the pair of matrices.
* On exit, A has been overwritten by its generalized Schur
* form S.
*
* LDA (input) INTEGER
* The leading dimension of A. LDA >= max(1,N).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
* On entry, the second of the pair of matrices.
* On exit, B has been overwritten by its generalized Schur
* form T.
*
* LDB (input) INTEGER
* The leading dimension of B. LDB >= max(1,N).
*
* SDIM (output) INTEGER
* If SORT = 'N', SDIM = 0.
* If SORT = 'S', SDIM = number of eigenvalues (after sorting)
* for which SELCTG is true. (Complex conjugate pairs for which
* SELCTG is true for either eigenvalue count as 2.)
*
* ALPHAR (output) DOUBLE PRECISION array, dimension (N)
* ALPHAI (output) DOUBLE PRECISION array, dimension (N)
* BETA (output) DOUBLE PRECISION array, dimension (N)
* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i
* and BETA(j),j=1,...,N are the diagonals of the complex Schur
* form (S,T) that would result if the 2-by-2 diagonal blocks of
* the real Schur form of (A,B) were further reduced to
* triangular form using 2-by-2 complex unitary transformations.
* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
* positive, then the j-th and (j+1)-st eigenvalues are a
* complex conjugate pair, with ALPHAI(j+1) negative.
*
* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
* may easily over- or underflow, and BETA(j) may even be zero.
* Thus, the user should avoid naively computing the ratio.
* However, ALPHAR and ALPHAI will be always less than and
* usually comparable with norm(A) in magnitude, and BETA always
* less than and usually comparable with norm(B).
*
* VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N)
* If JOBVSL = 'V', VSL will contain the left Schur vectors.
* Not referenced if JOBVSL = 'N'.
*
* LDVSL (input) INTEGER
* The leading dimension of the matrix VSL. LDVSL >=1, and
* if JOBVSL = 'V', LDVSL >= N.
*
* VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N)
* If JOBVSR = 'V', VSR will contain the right Schur vectors.
* Not referenced if JOBVSR = 'N'.
*
* LDVSR (input) INTEGER
* The leading dimension of the matrix VSR. LDVSR >= 1, and
* if JOBVSR = 'V', LDVSR >= N.
*
* RCONDE (output) DOUBLE PRECISION array, dimension ( 2 )
* If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the
* reciprocal condition numbers for the average of the selected
* eigenvalues.
* Not referenced if SENSE = 'N' or 'V'.
*
* RCONDV (output) DOUBLE PRECISION array, dimension ( 2 )
* If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the
* reciprocal condition numbers for the selected deflating
* subspaces.
* Not referenced if SENSE = 'N' or 'E'.
*
* 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 N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B',
* LWORK >= max( 8*N, 6*N+16, 2*SDIM*(N-SDIM) ), else
* LWORK >= max( 8*N, 6*N+16 ).
* Note that 2*SDIM*(N-SDIM) <= N*N/2.
* Note also that an error is only returned if
* LWORK < max( 8*N, 6*N+16), but if SENSE = 'E' or 'V' or 'B'
* this may not be large enough.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the bound on the optimal size of the WORK
* array and the minimum size of the IWORK array, returns these
* values as the first entries of the WORK and IWORK arrays, and
* no error message related to LWORK or LIWORK is issued by
* XERBLA.
*
* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK.
* If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise
* LIWORK >= N+6.
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the bound on the optimal size of the
* WORK array and the minimum size of the IWORK array, returns
* these values as the first entries of the WORK and IWORK
* arrays, and no error message related to LWORK or LIWORK is
* issued by XERBLA.
*
* BWORK (workspace) LOGICAL array, dimension (N)
* Not referenced if SORT = 'N'.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* = 1,...,N:
* The QZ iteration failed. (A,B) are not in Schur
* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should
* be correct for j=INFO+1,...,N.
* > N: =N+1: other than QZ iteration failed in DHGEQZ
* =N+2: after reordering, roundoff changed values of
* some complex eigenvalues so that leading
* eigenvalues in the Generalized Schur form no
* longer satisfy SELCTG=.TRUE. This could also
* be caused due to scaling.
* =N+3: reordering failed in DTGSEN.
*
* Further details
* ===============
*
* An approximate (asymptotic) bound on the average absolute error of
* the selected eigenvalues is
*
* EPS * norm((A, B)) / RCONDE( 1 ).
*
* An approximate (asymptotic) bound on the maximum angular error in
* the computed deflating subspaces is
*
* EPS * norm((A, B)) / RCONDV( 2 ).
*
* See LAPACK User's Guide, section 4.11 for more information.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL,
$ LQUERY, LST2SL, WANTSB, WANTSE, WANTSN, WANTST,
$ WANTSV
INTEGER I, ICOLS, IERR, IHI, IJOB, IJOBVL, IJOBVR,
$ ILEFT, ILO, IP, IRIGHT, IROWS, ITAU, IWRK,
$ LIWMIN, LWRK, MAXWRK, MINWRK
DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PL,
$ PR, SAFMAX, SAFMIN, SMLNUM
* ..
* .. Local Arrays ..
DOUBLE PRECISION DIF( 2 )
* ..
* .. External Subroutines ..
EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLABAD,
$ DLACPY, DLASCL, DLASET, DORGQR, DORMQR, DTGSEN,
$ XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Decode the input arguments
*
IF( LSAME( JOBVSL, 'N' ) ) THEN
IJOBVL = 1
ILVSL = .FALSE.
ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN
IJOBVL = 2
ILVSL = .TRUE.
ELSE
IJOBVL = -1
ILVSL = .FALSE.
END IF
*
IF( LSAME( JOBVSR, 'N' ) ) THEN
IJOBVR = 1
ILVSR = .FALSE.
ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN
IJOBVR = 2
ILVSR = .TRUE.
ELSE
IJOBVR = -1
ILVSR = .FALSE.
END IF
*
WANTST = LSAME( SORT, 'S' )
WANTSN = LSAME( SENSE, 'N' )
WANTSE = LSAME( SENSE, 'E' )
WANTSV = LSAME( SENSE, 'V' )
WANTSB = LSAME( SENSE, 'B' )
LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
IF( WANTSN ) THEN
IJOB = 0
ELSE IF( WANTSE ) THEN
IJOB = 1
ELSE IF( WANTSV ) THEN
IJOB = 2
ELSE IF( WANTSB ) THEN
IJOB = 4
END IF
*
* Test the input arguments
*
INFO = 0
IF( IJOBVL.LE.0 ) THEN
INFO = -1
ELSE IF( IJOBVR.LE.0 ) THEN
INFO = -2
ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
INFO = -3
ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSV .OR. WANTSB ) .OR.
$ ( .NOT.WANTST .AND. .NOT.WANTSN ) ) THEN
INFO = -5
ELSE IF( N.LT.0 ) THEN
INFO = -6
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -10
ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN
INFO = -16
ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN
INFO = -18
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.)
*
IF( INFO.EQ.0 ) THEN
IF( N.GT.0) THEN
MINWRK = MAX( 8*N, 6*N + 16 )
MAXWRK = MINWRK - N +
$ N*ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 )
MAXWRK = MAX( MAXWRK, MINWRK - N +
$ N*ILAENV( 1, 'DORMQR', ' ', N, 1, N, -1 ) )
IF( ILVSL ) THEN
MAXWRK = MAX( MAXWRK, MINWRK - N +
$ N*ILAENV( 1, 'DORGQR', ' ', N, 1, N, -1 ) )
END IF
LWRK = MAXWRK
IF( IJOB.GE.1 )
$ LWRK = MAX( LWRK, N*N/2 )
ELSE
MINWRK = 1
MAXWRK = 1
LWRK = 1
END IF
WORK( 1 ) = LWRK
IF( WANTSN .OR. N.EQ.0 ) THEN
LIWMIN = 1
ELSE
LIWMIN = N + 6
END IF
IWORK( 1 ) = LIWMIN
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
INFO = -22
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -24
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGGESX', -INFO )
RETURN
ELSE IF (LQUERY) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
SDIM = 0
RETURN
END IF
*
* Get machine constants
*
EPS = DLAMCH( 'P' )
SAFMIN = DLAMCH( 'S' )
SAFMAX = ONE / SAFMIN
CALL DLABAD( SAFMIN, SAFMAX )
SMLNUM = SQRT( SAFMIN ) / EPS
BIGNUM = ONE / SMLNUM
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = DLANGE( 'M', N, N, A, LDA, WORK )
ILASCL = .FALSE.
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
ANRMTO = SMLNUM
ILASCL = .TRUE.
ELSE IF( ANRM.GT.BIGNUM ) THEN
ANRMTO = BIGNUM
ILASCL = .TRUE.
END IF
IF( ILASCL )
$ CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
*
* Scale B if max element outside range [SMLNUM,BIGNUM]
*
BNRM = DLANGE( 'M', N, N, B, LDB, WORK )
ILBSCL = .FALSE.
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
BNRMTO = SMLNUM
ILBSCL = .TRUE.
ELSE IF( BNRM.GT.BIGNUM ) THEN
BNRMTO = BIGNUM
ILBSCL = .TRUE.
END IF
IF( ILBSCL )
$ CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
*
* Permute the matrix to make it more nearly triangular
* (Workspace: need 6*N + 2*N for permutation parameters)
*
ILEFT = 1
IRIGHT = N + 1
IWRK = IRIGHT + N
CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ),
$ WORK( IRIGHT ), WORK( IWRK ), IERR )
*
* Reduce B to triangular form (QR decomposition of B)
* (Workspace: need N, prefer N*NB)
*
IROWS = IHI + 1 - ILO
ICOLS = N + 1 - ILO
ITAU = IWRK
IWRK = ITAU + IROWS
CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
$ WORK( IWRK ), LWORK+1-IWRK, IERR )
*
* Apply the orthogonal transformation to matrix A
* (Workspace: need N, prefer N*NB)
*
CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
$ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
$ LWORK+1-IWRK, IERR )
*
* Initialize VSL
* (Workspace: need N, prefer N*NB)
*
IF( ILVSL ) THEN
CALL DLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL )
IF( IROWS.GT.1 ) THEN
CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
$ VSL( ILO+1, ILO ), LDVSL )
END IF
CALL DORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL,
$ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
END IF
*
* Initialize VSR
*
IF( ILVSR )
$ CALL DLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR )
*
* Reduce to generalized Hessenberg form
* (Workspace: none needed)
*
CALL DGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL,
$ LDVSL, VSR, LDVSR, IERR )
*
SDIM = 0
*
* Perform QZ algorithm, computing Schur vectors if desired
* (Workspace: need N)
*
IWRK = ITAU
CALL DHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB,
$ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR,
$ WORK( IWRK ), LWORK+1-IWRK, IERR )
IF( IERR.NE.0 ) THEN
IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
INFO = IERR
ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
INFO = IERR - N
ELSE
INFO = N + 1
END IF
GO TO 60
END IF
*
* Sort eigenvalues ALPHA/BETA and compute the reciprocal of
* condition number(s)
* (Workspace: If IJOB >= 1, need MAX( 8*(N+1), 2*SDIM*(N-SDIM) )
* otherwise, need 8*(N+1) )
*
IF( WANTST ) THEN
*
* Undo scaling on eigenvalues before SELCTGing
*
IF( ILASCL ) THEN
CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N,
$ IERR )
CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N,
$ IERR )
END IF
IF( ILBSCL )
$ CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
*
* Select eigenvalues
*
DO 10 I = 1, N
BWORK( I ) = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) )
10 CONTINUE
*
* Reorder eigenvalues, transform Generalized Schur vectors, and
* compute reciprocal condition numbers
*
CALL DTGSEN( IJOB, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB,
$ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR,
$ SDIM, PL, PR, DIF, WORK( IWRK ), LWORK-IWRK+1,
$ IWORK, LIWORK, IERR )
*
IF( IJOB.GE.1 )
$ MAXWRK = MAX( MAXWRK, 2*SDIM*( N-SDIM ) )
IF( IERR.EQ.-22 ) THEN
*
* not enough real workspace
*
INFO = -22
ELSE
IF( IJOB.EQ.1 .OR. IJOB.EQ.4 ) THEN
RCONDE( 1 ) = PL
RCONDE( 2 ) = PR
END IF
IF( IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN
RCONDV( 1 ) = DIF( 1 )
RCONDV( 2 ) = DIF( 2 )
END IF
IF( IERR.EQ.1 )
$ INFO = N + 3
END IF
*
END IF
*
* Apply permutation to VSL and VSR
* (Workspace: none needed)
*
IF( ILVSL )
$ CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
$ WORK( IRIGHT ), N, VSL, LDVSL, IERR )
*
IF( ILVSR )
$ CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ),
$ WORK( IRIGHT ), N, VSR, LDVSR, IERR )
*
* Check if unscaling would cause over/underflow, if so, rescale
* (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of
* B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I)
*
IF( ILASCL ) THEN
DO 20 I = 1, N
IF( ALPHAI( I ).NE.ZERO ) THEN
IF( ( ALPHAR( I ) / SAFMAX ).GT.( ANRMTO / ANRM ) .OR.
$ ( SAFMIN / ALPHAR( I ) ).GT.( ANRM / ANRMTO ) ) THEN
WORK( 1 ) = ABS( A( I, I ) / ALPHAR( I ) )
BETA( I ) = BETA( I )*WORK( 1 )
ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
ELSE IF( ( ALPHAI( I ) / SAFMAX ).GT.
$ ( ANRMTO / ANRM ) .OR.
$ ( SAFMIN / ALPHAI( I ) ).GT.( ANRM / ANRMTO ) )
$ THEN
WORK( 1 ) = ABS( A( I, I+1 ) / ALPHAI( I ) )
BETA( I ) = BETA( I )*WORK( 1 )
ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
END IF
END IF
20 CONTINUE
END IF
*
IF( ILBSCL ) THEN
DO 30 I = 1, N
IF( ALPHAI( I ).NE.ZERO ) THEN
IF( ( BETA( I ) / SAFMAX ).GT.( BNRMTO / BNRM ) .OR.
$ ( SAFMIN / BETA( I ) ).GT.( BNRM / BNRMTO ) ) THEN
WORK( 1 ) = ABS( B( I, I ) / BETA( I ) )
BETA( I ) = BETA( I )*WORK( 1 )
ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
END IF
END IF
30 CONTINUE
END IF
*
* Undo scaling
*
IF( ILASCL ) THEN
CALL DLASCL( 'H', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR )
CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
END IF
*
IF( ILBSCL ) THEN
CALL DLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR )
CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
END IF
*
IF( WANTST ) THEN
*
* Check if reordering is correct
*
LASTSL = .TRUE.
LST2SL = .TRUE.
SDIM = 0
IP = 0
DO 50 I = 1, N
CURSL = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) )
IF( ALPHAI( I ).EQ.ZERO ) THEN
IF( CURSL )
$ SDIM = SDIM + 1
IP = 0
IF( CURSL .AND. .NOT.LASTSL )
$ INFO = N + 2
ELSE
IF( IP.EQ.1 ) THEN
*
* Last eigenvalue of conjugate pair
*
CURSL = CURSL .OR. LASTSL
LASTSL = CURSL
IF( CURSL )
$ SDIM = SDIM + 2
IP = -1
IF( CURSL .AND. .NOT.LST2SL )
$ INFO = N + 2
ELSE
*
* First eigenvalue of conjugate pair
*
IP = 1
END IF
END IF
LST2SL = LASTSL
LASTSL = CURSL
50 CONTINUE
*
END IF
*
60 CONTINUE
*
WORK( 1 ) = MAXWRK
IWORK( 1 ) = LIWMIN
*
RETURN
*
* End of DGGESX
*
END
SUBROUTINE DGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI,
$ BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBVL, JOBVR
INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
$ B( LDB, * ), BETA( * ), VL( LDVL, * ),
$ VR( LDVR, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B)
* the generalized eigenvalues, and optionally, the left and/or right
* generalized eigenvectors.
*
* A generalized eigenvalue for a pair of matrices (A,B) is a scalar
* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
* singular. It is usually represented as the pair (alpha,beta), as
* there is a reasonable interpretation for beta=0, and even for both
* being zero.
*
* The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
* of (A,B) satisfies
*
* A * v(j) = lambda(j) * B * v(j).
*
* The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
* of (A,B) satisfies
*
* u(j)**H * A = lambda(j) * u(j)**H * B .
*
* where u(j)**H is the conjugate-transpose of u(j).
*
*
* Arguments
* =========
*
* JOBVL (input) CHARACTER*1
* = 'N': do not compute the left generalized eigenvectors;
* = 'V': compute the left generalized eigenvectors.
*
* JOBVR (input) CHARACTER*1
* = 'N': do not compute the right generalized eigenvectors;
* = 'V': compute the right generalized eigenvectors.
*
* N (input) INTEGER
* The order of the matrices A, B, VL, and VR. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
* On entry, the matrix A in the pair (A,B).
* On exit, A has been overwritten.
*
* LDA (input) INTEGER
* The leading dimension of A. LDA >= max(1,N).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
* On entry, the matrix B in the pair (A,B).
* On exit, B has been overwritten.
*
* LDB (input) INTEGER
* The leading dimension of B. LDB >= max(1,N).
*
* ALPHAR (output) DOUBLE PRECISION array, dimension (N)
* ALPHAI (output) DOUBLE PRECISION array, dimension (N)
* BETA (output) DOUBLE PRECISION array, dimension (N)
* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
* be the generalized eigenvalues. If ALPHAI(j) is zero, then
* the j-th eigenvalue is real; if positive, then the j-th and
* (j+1)-st eigenvalues are a complex conjugate pair, with
* ALPHAI(j+1) negative.
*
* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
* may easily over- or underflow, and BETA(j) may even be zero.
* Thus, the user should avoid naively computing the ratio
* alpha/beta. However, ALPHAR and ALPHAI will be always less
* than and usually comparable with norm(A) in magnitude, and
* BETA always less than and usually comparable with norm(B).
*
* VL (output) DOUBLE PRECISION array, dimension (LDVL,N)
* If JOBVL = 'V', the left eigenvectors u(j) are stored one
* after another in the columns of VL, in the same order as
* their eigenvalues. If the j-th eigenvalue is real, then
* u(j) = VL(:,j), the j-th column of VL. If the j-th and
* (j+1)-th eigenvalues form a complex conjugate pair, then
* u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).
* Each eigenvector is scaled so the largest component has
* abs(real part)+abs(imag. part)=1.
* Not referenced if JOBVL = 'N'.
*
* LDVL (input) INTEGER
* The leading dimension of the matrix VL. LDVL >= 1, and
* if JOBVL = 'V', LDVL >= N.
*
* VR (output) DOUBLE PRECISION array, dimension (LDVR,N)
* If JOBVR = 'V', the right eigenvectors v(j) are stored one
* after another in the columns of VR, in the same order as
* their eigenvalues. If the j-th eigenvalue is real, then
* v(j) = VR(:,j), the j-th column of VR. If the j-th and
* (j+1)-th eigenvalues form a complex conjugate pair, then
* v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).
* Each eigenvector is scaled so the largest component has
* abs(real part)+abs(imag. part)=1.
* Not referenced if JOBVR = 'N'.
*
* LDVR (input) INTEGER
* The leading dimension of the matrix VR. LDVR >= 1, and
* if JOBVR = 'V', LDVR >= N.
*
* 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,8*N).
* For good performance, LWORK must generally be larger.
*
* 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.
* = 1,...,N:
* The QZ iteration failed. No eigenvectors have been
* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
* should be correct for j=INFO+1,...,N.
* > N: =N+1: other than QZ iteration failed in DHGEQZ.
* =N+2: error return from DTGEVC.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY
CHARACTER CHTEMP
INTEGER ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, ILO,
$ IN, IRIGHT, IROWS, ITAU, IWRK, JC, JR, MAXWRK,
$ MINWRK
DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
$ SMLNUM, TEMP
* ..
* .. Local Arrays ..
LOGICAL LDUMMA( 1 )
* ..
* .. External Subroutines ..
EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLABAD,
$ DLACPY,DLASCL, DLASET, DORGQR, DORMQR, DTGEVC,
$ XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Decode the input arguments
*
IF( LSAME( JOBVL, 'N' ) ) THEN
IJOBVL = 1
ILVL = .FALSE.
ELSE IF( LSAME( JOBVL, 'V' ) ) THEN
IJOBVL = 2
ILVL = .TRUE.
ELSE
IJOBVL = -1
ILVL = .FALSE.
END IF
*
IF( LSAME( JOBVR, 'N' ) ) THEN
IJOBVR = 1
ILVR = .FALSE.
ELSE IF( LSAME( JOBVR, 'V' ) ) THEN
IJOBVR = 2
ILVR = .TRUE.
ELSE
IJOBVR = -1
ILVR = .FALSE.
END IF
ILV = ILVL .OR. ILVR
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
IF( IJOBVL.LE.0 ) THEN
INFO = -1
ELSE IF( IJOBVR.LE.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
INFO = -12
ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
INFO = -14
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV. The workspace is
* computed assuming ILO = 1 and IHI = N, the worst case.)
*
IF( INFO.EQ.0 ) THEN
MINWRK = MAX( 1, 8*N )
MAXWRK = MAX( 1, N*( 7 +
$ ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 ) ) )
MAXWRK = MAX( MAXWRK, N*( 7 +
$ ILAENV( 1, 'DORMQR', ' ', N, 1, N, 0 ) ) )
IF( ILVL ) THEN
MAXWRK = MAX( MAXWRK, N*( 7 +
$ ILAENV( 1, 'DORGQR', ' ', N, 1, N, -1 ) ) )
END IF
WORK( 1 ) = MAXWRK
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY )
$ INFO = -16
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGGEV ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Get machine constants
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
SMLNUM = SQRT( SMLNUM ) / EPS
BIGNUM = ONE / SMLNUM
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = DLANGE( 'M', N, N, A, LDA, WORK )
ILASCL = .FALSE.
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
ANRMTO = SMLNUM
ILASCL = .TRUE.
ELSE IF( ANRM.GT.BIGNUM ) THEN
ANRMTO = BIGNUM
ILASCL = .TRUE.
END IF
IF( ILASCL )
$ CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
*
* Scale B if max element outside range [SMLNUM,BIGNUM]
*
BNRM = DLANGE( 'M', N, N, B, LDB, WORK )
ILBSCL = .FALSE.
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
BNRMTO = SMLNUM
ILBSCL = .TRUE.
ELSE IF( BNRM.GT.BIGNUM ) THEN
BNRMTO = BIGNUM
ILBSCL = .TRUE.
END IF
IF( ILBSCL )
$ CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
*
* Permute the matrices A, B to isolate eigenvalues if possible
* (Workspace: need 6*N)
*
ILEFT = 1
IRIGHT = N + 1
IWRK = IRIGHT + N
CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ),
$ WORK( IRIGHT ), WORK( IWRK ), IERR )
*
* Reduce B to triangular form (QR decomposition of B)
* (Workspace: need N, prefer N*NB)
*
IROWS = IHI + 1 - ILO
IF( ILV ) THEN
ICOLS = N + 1 - ILO
ELSE
ICOLS = IROWS
END IF
ITAU = IWRK
IWRK = ITAU + IROWS
CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
$ WORK( IWRK ), LWORK+1-IWRK, IERR )
*
* Apply the orthogonal transformation to matrix A
* (Workspace: need N, prefer N*NB)
*
CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
$ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
$ LWORK+1-IWRK, IERR )
*
* Initialize VL
* (Workspace: need N, prefer N*NB)
*
IF( ILVL ) THEN
CALL DLASET( 'Full', N, N, ZERO, ONE, VL, LDVL )
IF( IROWS.GT.1 ) THEN
CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
$ VL( ILO+1, ILO ), LDVL )
END IF
CALL DORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
$ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
END IF
*
* Initialize VR
*
IF( ILVR )
$ CALL DLASET( 'Full', N, N, ZERO, ONE, VR, LDVR )
*
* Reduce to generalized Hessenberg form
* (Workspace: none needed)
*
IF( ILV ) THEN
*
* Eigenvectors requested -- work on whole matrix.
*
CALL DGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL,
$ LDVL, VR, LDVR, IERR )
ELSE
CALL DGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA,
$ B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IERR )
END IF
*
* Perform QZ algorithm (Compute eigenvalues, and optionally, the
* Schur forms and Schur vectors)
* (Workspace: need N)
*
IWRK = ITAU
IF( ILV ) THEN
CHTEMP = 'S'
ELSE
CHTEMP = 'E'
END IF
CALL DHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB,
$ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR,
$ WORK( IWRK ), LWORK+1-IWRK, IERR )
IF( IERR.NE.0 ) THEN
IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
INFO = IERR
ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
INFO = IERR - N
ELSE
INFO = N + 1
END IF
GO TO 110
END IF
*
* Compute Eigenvectors
* (Workspace: need 6*N)
*
IF( ILV ) THEN
IF( ILVL ) THEN
IF( ILVR ) THEN
CHTEMP = 'B'
ELSE
CHTEMP = 'L'
END IF
ELSE
CHTEMP = 'R'
END IF
CALL DTGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, LDVL,
$ VR, LDVR, N, IN, WORK( IWRK ), IERR )
IF( IERR.NE.0 ) THEN
INFO = N + 2
GO TO 110
END IF
*
* Undo balancing on VL and VR and normalization
* (Workspace: none needed)
*
IF( ILVL ) THEN
CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
$ WORK( IRIGHT ), N, VL, LDVL, IERR )
DO 50 JC = 1, N
IF( ALPHAI( JC ).LT.ZERO )
$ GO TO 50
TEMP = ZERO
IF( ALPHAI( JC ).EQ.ZERO ) THEN
DO 10 JR = 1, N
TEMP = MAX( TEMP, ABS( VL( JR, JC ) ) )
10 CONTINUE
ELSE
DO 20 JR = 1, N
TEMP = MAX( TEMP, ABS( VL( JR, JC ) )+
$ ABS( VL( JR, JC+1 ) ) )
20 CONTINUE
END IF
IF( TEMP.LT.SMLNUM )
$ GO TO 50
TEMP = ONE / TEMP
IF( ALPHAI( JC ).EQ.ZERO ) THEN
DO 30 JR = 1, N
VL( JR, JC ) = VL( JR, JC )*TEMP
30 CONTINUE
ELSE
DO 40 JR = 1, N
VL( JR, JC ) = VL( JR, JC )*TEMP
VL( JR, JC+1 ) = VL( JR, JC+1 )*TEMP
40 CONTINUE
END IF
50 CONTINUE
END IF
IF( ILVR ) THEN
CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ),
$ WORK( IRIGHT ), N, VR, LDVR, IERR )
DO 100 JC = 1, N
IF( ALPHAI( JC ).LT.ZERO )
$ GO TO 100
TEMP = ZERO
IF( ALPHAI( JC ).EQ.ZERO ) THEN
DO 60 JR = 1, N
TEMP = MAX( TEMP, ABS( VR( JR, JC ) ) )
60 CONTINUE
ELSE
DO 70 JR = 1, N
TEMP = MAX( TEMP, ABS( VR( JR, JC ) )+
$ ABS( VR( JR, JC+1 ) ) )
70 CONTINUE
END IF
IF( TEMP.LT.SMLNUM )
$ GO TO 100
TEMP = ONE / TEMP
IF( ALPHAI( JC ).EQ.ZERO ) THEN
DO 80 JR = 1, N
VR( JR, JC ) = VR( JR, JC )*TEMP
80 CONTINUE
ELSE
DO 90 JR = 1, N
VR( JR, JC ) = VR( JR, JC )*TEMP
VR( JR, JC+1 ) = VR( JR, JC+1 )*TEMP
90 CONTINUE
END IF
100 CONTINUE
END IF
*
* End of eigenvector calculation
*
END IF
*
* Undo scaling if necessary
*
IF( ILASCL ) THEN
CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
END IF
*
IF( ILBSCL ) THEN
CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
END IF
*
110 CONTINUE
*
WORK( 1 ) = MAXWRK
*
RETURN
*
* End of DGGEV
*
END
SUBROUTINE DGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB,
$ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, ILO,
$ IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE,
$ RCONDV, WORK, LWORK, IWORK, BWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER BALANC, JOBVL, JOBVR, SENSE
INTEGER IHI, ILO, INFO, LDA, LDB, LDVL, LDVR, LWORK, N
DOUBLE PRECISION ABNRM, BBNRM
* ..
* .. Array Arguments ..
LOGICAL BWORK( * )
INTEGER IWORK( * )
DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
$ B( LDB, * ), BETA( * ), LSCALE( * ),
$ RCONDE( * ), RCONDV( * ), RSCALE( * ),
$ VL( LDVL, * ), VR( LDVR, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B)
* the generalized eigenvalues, and optionally, the left and/or right
* generalized eigenvectors.
*
* Optionally also, it computes a balancing transformation to improve
* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
* LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for
* the eigenvalues (RCONDE), and reciprocal condition numbers for the
* right eigenvectors (RCONDV).
*
* A generalized eigenvalue for a pair of matrices (A,B) is a scalar
* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
* singular. It is usually represented as the pair (alpha,beta), as
* there is a reasonable interpretation for beta=0, and even for both
* being zero.
*
* The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
* of (A,B) satisfies
*
* A * v(j) = lambda(j) * B * v(j) .
*
* The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
* of (A,B) satisfies
*
* u(j)**H * A = lambda(j) * u(j)**H * B.
*
* where u(j)**H is the conjugate-transpose of u(j).
*
*
* Arguments
* =========
*
* BALANC (input) CHARACTER*1
* Specifies the balance option to be performed.
* = 'N': do not diagonally scale or permute;
* = 'P': permute only;
* = 'S': scale only;
* = 'B': both permute and scale.
* Computed reciprocal condition numbers will be for the
* matrices after permuting and/or balancing. Permuting does
* not change condition numbers (in exact arithmetic), but
* balancing does.
*
* JOBVL (input) CHARACTER*1
* = 'N': do not compute the left generalized eigenvectors;
* = 'V': compute the left generalized eigenvectors.
*
* JOBVR (input) CHARACTER*1
* = 'N': do not compute the right generalized eigenvectors;
* = 'V': compute the right generalized eigenvectors.
*
* SENSE (input) CHARACTER*1
* Determines which reciprocal condition numbers are computed.
* = 'N': none are computed;
* = 'E': computed for eigenvalues only;
* = 'V': computed for eigenvectors only;
* = 'B': computed for eigenvalues and eigenvectors.
*
* N (input) INTEGER
* The order of the matrices A, B, VL, and VR. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
* On entry, the matrix A in the pair (A,B).
* On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'
* or both, then A contains the first part of the real Schur
* form of the "balanced" versions of the input A and B.
*
* LDA (input) INTEGER
* The leading dimension of A. LDA >= max(1,N).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
* On entry, the matrix B in the pair (A,B).
* On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'
* or both, then B contains the second part of the real Schur
* form of the "balanced" versions of the input A and B.
*
* LDB (input) INTEGER
* The leading dimension of B. LDB >= max(1,N).
*
* ALPHAR (output) DOUBLE PRECISION array, dimension (N)
* ALPHAI (output) DOUBLE PRECISION array, dimension (N)
* BETA (output) DOUBLE PRECISION array, dimension (N)
* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
* be the generalized eigenvalues. If ALPHAI(j) is zero, then
* the j-th eigenvalue is real; if positive, then the j-th and
* (j+1)-st eigenvalues are a complex conjugate pair, with
* ALPHAI(j+1) negative.
*
* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
* may easily over- or underflow, and BETA(j) may even be zero.
* Thus, the user should avoid naively computing the ratio
* ALPHA/BETA. However, ALPHAR and ALPHAI will be always less
* than and usually comparable with norm(A) in magnitude, and
* BETA always less than and usually comparable with norm(B).
*
* VL (output) DOUBLE PRECISION array, dimension (LDVL,N)
* If JOBVL = 'V', the left eigenvectors u(j) are stored one
* after another in the columns of VL, in the same order as
* their eigenvalues. If the j-th eigenvalue is real, then
* u(j) = VL(:,j), the j-th column of VL. If the j-th and
* (j+1)-th eigenvalues form a complex conjugate pair, then
* u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).
* Each eigenvector will be scaled so the largest component have
* abs(real part) + abs(imag. part) = 1.
* Not referenced if JOBVL = 'N'.
*
* LDVL (input) INTEGER
* The leading dimension of the matrix VL. LDVL >= 1, and
* if JOBVL = 'V', LDVL >= N.
*
* VR (output) DOUBLE PRECISION array, dimension (LDVR,N)
* If JOBVR = 'V', the right eigenvectors v(j) are stored one
* after another in the columns of VR, in the same order as
* their eigenvalues. If the j-th eigenvalue is real, then
* v(j) = VR(:,j), the j-th column of VR. If the j-th and
* (j+1)-th eigenvalues form a complex conjugate pair, then
* v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).
* Each eigenvector will be scaled so the largest component have
* abs(real part) + abs(imag. part) = 1.
* Not referenced if JOBVR = 'N'.
*
* LDVR (input) INTEGER
* The leading dimension of the matrix VR. LDVR >= 1, and
* if JOBVR = 'V', LDVR >= N.
*
* ILO (output) INTEGER
* IHI (output) INTEGER
* ILO and IHI are integer values such that on exit
* A(i,j) = 0 and B(i,j) = 0 if i > j and
* j = 1,...,ILO-1 or i = IHI+1,...,N.
* If BALANC = 'N' or 'S', ILO = 1 and IHI = N.
*
* LSCALE (output) DOUBLE PRECISION array, dimension (N)
* Details of the permutations and scaling factors applied
* to the left side of A and B. If PL(j) is the index of the
* row interchanged with row j, and DL(j) is the scaling
* factor applied to row j, then
* LSCALE(j) = PL(j) for j = 1,...,ILO-1
* = DL(j) for j = ILO,...,IHI
* = PL(j) for j = IHI+1,...,N.
* The order in which the interchanges are made is N to IHI+1,
* then 1 to ILO-1.
*
* RSCALE (output) DOUBLE PRECISION array, dimension (N)
* Details of the permutations and scaling factors applied
* to the right side of A and B. If PR(j) is the index of the
* column interchanged with column j, and DR(j) is the scaling
* factor applied to column j, then
* RSCALE(j) = PR(j) for j = 1,...,ILO-1
* = DR(j) for j = ILO,...,IHI
* = PR(j) for j = IHI+1,...,N
* The order in which the interchanges are made is N to IHI+1,
* then 1 to ILO-1.
*
* ABNRM (output) DOUBLE PRECISION
* The one-norm of the balanced matrix A.
*
* BBNRM (output) DOUBLE PRECISION
* The one-norm of the balanced matrix B.
*
* RCONDE (output) DOUBLE PRECISION array, dimension (N)
* If SENSE = 'E' or 'B', the reciprocal condition numbers of
* the eigenvalues, stored in consecutive elements of the array.
* For a complex conjugate pair of eigenvalues two consecutive
* elements of RCONDE are set to the same value. Thus RCONDE(j),
* RCONDV(j), and the j-th columns of VL and VR all correspond
* to the j-th eigenpair.
* If SENSE = 'N or 'V', RCONDE is not referenced.
*
* RCONDV (output) DOUBLE PRECISION array, dimension (N)
* If SENSE = 'V' or 'B', the estimated reciprocal condition
* numbers of the eigenvectors, stored in consecutive elements
* of the array. For a complex eigenvector two consecutive
* elements of RCONDV are set to the same value. If the
* eigenvalues cannot be reordered to compute RCONDV(j),
* RCONDV(j) is set to 0; this can only occur when the true
* value would be very small anyway.
* If SENSE = 'N' or 'E', RCONDV is not referenced.
*
* 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,2*N).
* If BALANC = 'S' or 'B', or JOBVL = 'V', or JOBVR = 'V',
* LWORK >= max(1,6*N).
* If SENSE = 'E' or 'B', LWORK >= max(1,10*N).
* If SENSE = 'V' or 'B', LWORK >= 2*N*N+8*N+16.
*
* 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.
*
* IWORK (workspace) INTEGER array, dimension (N+6)
* If SENSE = 'E', IWORK is not referenced.
*
* BWORK (workspace) LOGICAL array, dimension (N)
* If SENSE = 'N', BWORK is not referenced.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* = 1,...,N:
* The QZ iteration failed. No eigenvectors have been
* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
* should be correct for j=INFO+1,...,N.
* > N: =N+1: other than QZ iteration failed in DHGEQZ.
* =N+2: error return from DTGEVC.
*
* Further Details
* ===============
*
* Balancing a matrix pair (A,B) includes, first, permuting rows and
* columns to isolate eigenvalues, second, applying diagonal similarity
* transformation to the rows and columns to make the rows and columns
* as close in norm as possible. The computed reciprocal condition
* numbers correspond to the balanced matrix. Permuting rows and columns
* will not change the condition numbers (in exact arithmetic) but
* diagonal scaling will. For further explanation of balancing, see
* section 4.11.1.2 of LAPACK Users' Guide.
*
* An approximate error bound on the chordal distance between the i-th
* computed generalized eigenvalue w and the corresponding exact
* eigenvalue lambda is
*
* chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)
*
* An approximate error bound for the angle between the i-th computed
* eigenvector VL(i) or VR(i) is given by
*
* EPS * norm(ABNRM, BBNRM) / DIF(i).
*
* For further explanation of the reciprocal condition numbers RCONDE
* and RCONDV, see section 4.11 of LAPACK User's Guide.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY, NOSCL,
$ PAIR, WANTSB, WANTSE, WANTSN, WANTSV
CHARACTER CHTEMP
INTEGER I, ICOLS, IERR, IJOBVL, IJOBVR, IN, IROWS,
$ ITAU, IWRK, IWRK1, J, JC, JR, M, MAXWRK,
$ MINWRK, MM
DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
$ SMLNUM, TEMP
* ..
* .. Local Arrays ..
LOGICAL LDUMMA( 1 )
* ..
* .. External Subroutines ..
EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLABAD,
$ DLACPY, DLASCL, DLASET, DORGQR, DORMQR, DTGEVC,
$ DTGSNA, XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Decode the input arguments
*
IF( LSAME( JOBVL, 'N' ) ) THEN
IJOBVL = 1
ILVL = .FALSE.
ELSE IF( LSAME( JOBVL, 'V' ) ) THEN
IJOBVL = 2
ILVL = .TRUE.
ELSE
IJOBVL = -1
ILVL = .FALSE.
END IF
*
IF( LSAME( JOBVR, 'N' ) ) THEN
IJOBVR = 1
ILVR = .FALSE.
ELSE IF( LSAME( JOBVR, 'V' ) ) THEN
IJOBVR = 2
ILVR = .TRUE.
ELSE
IJOBVR = -1
ILVR = .FALSE.
END IF
ILV = ILVL .OR. ILVR
*
NOSCL = LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, 'P' )
WANTSN = LSAME( SENSE, 'N' )
WANTSE = LSAME( SENSE, 'E' )
WANTSV = LSAME( SENSE, 'V' )
WANTSB = LSAME( SENSE, 'B' )
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LSAME( BALANC,
$ 'S' ) .OR. LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) ) )
$ THEN
INFO = -1
ELSE IF( IJOBVL.LE.0 ) THEN
INFO = -2
ELSE IF( IJOBVR.LE.0 ) THEN
INFO = -3
ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSB .OR. WANTSV ) )
$ THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
INFO = -14
ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
INFO = -16
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV. The workspace is
* computed assuming ILO = 1 and IHI = N, the worst case.)
*
IF( INFO.EQ.0 ) THEN
IF( N.EQ.0 ) THEN
MINWRK = 1
MAXWRK = 1
ELSE
IF( NOSCL .AND. .NOT.ILV ) THEN
MINWRK = 2*N
ELSE
MINWRK = 6*N
END IF
IF( WANTSE .OR. WANTSB ) THEN
MINWRK = 10*N
END IF
IF( WANTSV .OR. WANTSB ) THEN
MINWRK = MAX( MINWRK, 2*N*( N + 4 ) + 16 )
END IF
MAXWRK = MINWRK
MAXWRK = MAX( MAXWRK,
$ N + N*ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 ) )
MAXWRK = MAX( MAXWRK,
$ N + N*ILAENV( 1, 'DORMQR', ' ', N, 1, N, 0 ) )
IF( ILVL ) THEN
MAXWRK = MAX( MAXWRK, N +
$ N*ILAENV( 1, 'DORGQR', ' ', N, 1, N, 0 ) )
END IF
END IF
WORK( 1 ) = MAXWRK
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
INFO = -26
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGGEVX', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
*
* Get machine constants
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
SMLNUM = SQRT( SMLNUM ) / EPS
BIGNUM = ONE / SMLNUM
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = DLANGE( 'M', N, N, A, LDA, WORK )
ILASCL = .FALSE.
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
ANRMTO = SMLNUM
ILASCL = .TRUE.
ELSE IF( ANRM.GT.BIGNUM ) THEN
ANRMTO = BIGNUM
ILASCL = .TRUE.
END IF
IF( ILASCL )
$ CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
*
* Scale B if max element outside range [SMLNUM,BIGNUM]
*
BNRM = DLANGE( 'M', N, N, B, LDB, WORK )
ILBSCL = .FALSE.
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
BNRMTO = SMLNUM
ILBSCL = .TRUE.
ELSE IF( BNRM.GT.BIGNUM ) THEN
BNRMTO = BIGNUM
ILBSCL = .TRUE.
END IF
IF( ILBSCL )
$ CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
*
* Permute and/or balance the matrix pair (A,B)
* (Workspace: need 6*N if BALANC = 'S' or 'B', 1 otherwise)
*
CALL DGGBAL( BALANC, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE,
$ WORK, IERR )
*
* Compute ABNRM and BBNRM
*
ABNRM = DLANGE( '1', N, N, A, LDA, WORK( 1 ) )
IF( ILASCL ) THEN
WORK( 1 ) = ABNRM
CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, 1, 1, WORK( 1 ), 1,
$ IERR )
ABNRM = WORK( 1 )
END IF
*
BBNRM = DLANGE( '1', N, N, B, LDB, WORK( 1 ) )
IF( ILBSCL ) THEN
WORK( 1 ) = BBNRM
CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, 1, 1, WORK( 1 ), 1,
$ IERR )
BBNRM = WORK( 1 )
END IF
*
* Reduce B to triangular form (QR decomposition of B)
* (Workspace: need N, prefer N*NB )
*
IROWS = IHI + 1 - ILO
IF( ILV .OR. .NOT.WANTSN ) THEN
ICOLS = N + 1 - ILO
ELSE
ICOLS = IROWS
END IF
ITAU = 1
IWRK = ITAU + IROWS
CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
$ WORK( IWRK ), LWORK+1-IWRK, IERR )
*
* Apply the orthogonal transformation to A
* (Workspace: need N, prefer N*NB)
*
CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
$ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
$ LWORK+1-IWRK, IERR )
*
* Initialize VL and/or VR
* (Workspace: need N, prefer N*NB)
*
IF( ILVL ) THEN
CALL DLASET( 'Full', N, N, ZERO, ONE, VL, LDVL )
IF( IROWS.GT.1 ) THEN
CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
$ VL( ILO+1, ILO ), LDVL )
END IF
CALL DORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
$ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
END IF
*
IF( ILVR )
$ CALL DLASET( 'Full', N, N, ZERO, ONE, VR, LDVR )
*
* Reduce to generalized Hessenberg form
* (Workspace: none needed)
*
IF( ILV .OR. .NOT.WANTSN ) THEN
*
* Eigenvectors requested -- work on whole matrix.
*
CALL DGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL,
$ LDVL, VR, LDVR, IERR )
ELSE
CALL DGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA,
$ B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IERR )
END IF
*
* Perform QZ algorithm (Compute eigenvalues, and optionally, the
* Schur forms and Schur vectors)
* (Workspace: need N)
*
IF( ILV .OR. .NOT.WANTSN ) THEN
CHTEMP = 'S'
ELSE
CHTEMP = 'E'
END IF
*
CALL DHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB,
$ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK,
$ LWORK, IERR )
IF( IERR.NE.0 ) THEN
IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
INFO = IERR
ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
INFO = IERR - N
ELSE
INFO = N + 1
END IF
GO TO 130
END IF
*
* Compute Eigenvectors and estimate condition numbers if desired
* (Workspace: DTGEVC: need 6*N
* DTGSNA: need 2*N*(N+2)+16 if SENSE = 'V' or 'B',
* need N otherwise )
*
IF( ILV .OR. .NOT.WANTSN ) THEN
IF( ILV ) THEN
IF( ILVL ) THEN
IF( ILVR ) THEN
CHTEMP = 'B'
ELSE
CHTEMP = 'L'
END IF
ELSE
CHTEMP = 'R'
END IF
*
CALL DTGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL,
$ LDVL, VR, LDVR, N, IN, WORK, IERR )
IF( IERR.NE.0 ) THEN
INFO = N + 2
GO TO 130
END IF
END IF
*
IF( .NOT.WANTSN ) THEN
*
* compute eigenvectors (DTGEVC) and estimate condition
* numbers (DTGSNA). Note that the definition of the condition
* number is not invariant under transformation (u,v) to
* (Q*u, Z*v), where (u,v) are eigenvectors of the generalized
* Schur form (S,T), Q and Z are orthogonal matrices. In order
* to avoid using extra 2*N*N workspace, we have to recalculate
* eigenvectors and estimate one condition numbers at a time.
*
PAIR = .FALSE.
DO 20 I = 1, N
*
IF( PAIR ) THEN
PAIR = .FALSE.
GO TO 20
END IF
MM = 1
IF( I.LT.N ) THEN
IF( A( I+1, I ).NE.ZERO ) THEN
PAIR = .TRUE.
MM = 2
END IF
END IF
*
DO 10 J = 1, N
BWORK( J ) = .FALSE.
10 CONTINUE
IF( MM.EQ.1 ) THEN
BWORK( I ) = .TRUE.
ELSE IF( MM.EQ.2 ) THEN
BWORK( I ) = .TRUE.
BWORK( I+1 ) = .TRUE.
END IF
*
IWRK = MM*N + 1
IWRK1 = IWRK + MM*N
*
* Compute a pair of left and right eigenvectors.
* (compute workspace: need up to 4*N + 6*N)
*
IF( WANTSE .OR. WANTSB ) THEN
CALL DTGEVC( 'B', 'S', BWORK, N, A, LDA, B, LDB,
$ WORK( 1 ), N, WORK( IWRK ), N, MM, M,
$ WORK( IWRK1 ), IERR )
IF( IERR.NE.0 ) THEN
INFO = N + 2
GO TO 130
END IF
END IF
*
CALL DTGSNA( SENSE, 'S', BWORK, N, A, LDA, B, LDB,
$ WORK( 1 ), N, WORK( IWRK ), N, RCONDE( I ),
$ RCONDV( I ), MM, M, WORK( IWRK1 ),
$ LWORK-IWRK1+1, IWORK, IERR )
*
20 CONTINUE
END IF
END IF
*
* Undo balancing on VL and VR and normalization
* (Workspace: none needed)
*
IF( ILVL ) THEN
CALL DGGBAK( BALANC, 'L', N, ILO, IHI, LSCALE, RSCALE, N, VL,
$ LDVL, IERR )
*
DO 70 JC = 1, N
IF( ALPHAI( JC ).LT.ZERO )
$ GO TO 70
TEMP = ZERO
IF( ALPHAI( JC ).EQ.ZERO ) THEN
DO 30 JR = 1, N
TEMP = MAX( TEMP, ABS( VL( JR, JC ) ) )
30 CONTINUE
ELSE
DO 40 JR = 1, N
TEMP = MAX( TEMP, ABS( VL( JR, JC ) )+
$ ABS( VL( JR, JC+1 ) ) )
40 CONTINUE
END IF
IF( TEMP.LT.SMLNUM )
$ GO TO 70
TEMP = ONE / TEMP
IF( ALPHAI( JC ).EQ.ZERO ) THEN
DO 50 JR = 1, N
VL( JR, JC ) = VL( JR, JC )*TEMP
50 CONTINUE
ELSE
DO 60 JR = 1, N
VL( JR, JC ) = VL( JR, JC )*TEMP
VL( JR, JC+1 ) = VL( JR, JC+1 )*TEMP
60 CONTINUE
END IF
70 CONTINUE
END IF
IF( ILVR ) THEN
CALL DGGBAK( BALANC, 'R', N, ILO, IHI, LSCALE, RSCALE, N, VR,
$ LDVR, IERR )
DO 120 JC = 1, N
IF( ALPHAI( JC ).LT.ZERO )
$ GO TO 120
TEMP = ZERO
IF( ALPHAI( JC ).EQ.ZERO ) THEN
DO 80 JR = 1, N
TEMP = MAX( TEMP, ABS( VR( JR, JC ) ) )
80 CONTINUE
ELSE
DO 90 JR = 1, N
TEMP = MAX( TEMP, ABS( VR( JR, JC ) )+
$ ABS( VR( JR, JC+1 ) ) )
90 CONTINUE
END IF
IF( TEMP.LT.SMLNUM )
$ GO TO 120
TEMP = ONE / TEMP
IF( ALPHAI( JC ).EQ.ZERO ) THEN
DO 100 JR = 1, N
VR( JR, JC ) = VR( JR, JC )*TEMP
100 CONTINUE
ELSE
DO 110 JR = 1, N
VR( JR, JC ) = VR( JR, JC )*TEMP
VR( JR, JC+1 ) = VR( JR, JC+1 )*TEMP
110 CONTINUE
END IF
120 CONTINUE
END IF
*
* Undo scaling if necessary
*
IF( ILASCL ) THEN
CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
END IF
*
IF( ILBSCL ) THEN
CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
END IF
*
130 CONTINUE
WORK( 1 ) = MAXWRK
*
RETURN
*
* End of DGGEVX
*
END
SUBROUTINE DGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK,
$ INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, P
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), D( * ), WORK( * ),
$ X( * ), Y( * )
* ..
*
* Purpose
* =======
*
* DGGGLM solves a general Gauss-Markov linear model (GLM) problem:
*
* minimize || y ||_2 subject to d = A*x + B*y
* x
*
* where A is an N-by-M matrix, B is an N-by-P matrix, and d is a
* given N-vector. It is assumed that M <= N <= M+P, and
*
* rank(A) = M and rank( A B ) = N.
*
* Under these assumptions, the constrained equation is always
* consistent, and there is a unique solution x and a minimal 2-norm
* solution y, which is obtained using a generalized QR factorization
* of the matrices (A, B) given by
*
* A = Q*(R), B = Q*T*Z.
* (0)
*
* In particular, if matrix B is square nonsingular, then the problem
* GLM is equivalent to the following weighted linear least squares
* problem
*
* minimize || inv(B)*(d-A*x) ||_2
* x
*
* where inv(B) denotes the inverse of B.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of rows of the matrices A and B. N >= 0.
*
* M (input) INTEGER
* The number of columns of the matrix A. 0 <= M <= N.
*
* P (input) INTEGER
* The number of columns of the matrix B. P >= N-M.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,M)
* On entry, the N-by-M matrix A.
* On exit, the upper triangular part of the array A contains
* the M-by-M upper triangular matrix R.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,P)
* On entry, the N-by-P matrix B.
* On exit, if N <= P, the upper triangle of the subarray
* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;
* if N > P, the elements on and above the (N-P)th subdiagonal
* contain the N-by-P upper trapezoidal matrix T.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, D is the left hand side of the GLM equation.
* On exit, D is destroyed.
*
* X (output) DOUBLE PRECISION array, dimension (M)
* Y (output) DOUBLE PRECISION array, dimension (P)
* On exit, X and Y are the solutions of the GLM problem.
*
* 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+M+P).
* For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,
* where NB is an upper bound for the optimal blocksizes for
* DGEQRF, SGERQF, DORMQR and SORMRQ.
*
* 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.
* = 1: the upper triangular factor R associated with A in the
* generalized QR factorization of the pair (A, B) is
* singular, so that rank(A) < M; the least squares
* solution could not be computed.
* = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal
* factor T associated with B in the generalized QR
* factorization of the pair (A, B) is singular, so that
* rank( A B ) < N; the least squares solution could not
* be computed.
*
* ===================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, LOPT, LWKMIN, LWKOPT, NB, NB1, NB2, NB3,
$ NB4, NP
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMV, DGGQRF, DORMQR, DORMRQ, DTRTRS,
$ XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC INT, MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
NP = MIN( N, P )
LQUERY = ( LWORK.EQ.-1 )
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( M.LT.0 .OR. M.GT.N ) THEN
INFO = -2
ELSE IF( P.LT.0 .OR. P.LT.N-M ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
END IF
*
* Calculate workspace
*
IF( INFO.EQ.0) THEN
IF( N.EQ.0 ) THEN
LWKMIN = 1
LWKOPT = 1
ELSE
NB1 = ILAENV( 1, 'DGEQRF', ' ', N, M, -1, -1 )
NB2 = ILAENV( 1, 'DGERQF', ' ', N, M, -1, -1 )
NB3 = ILAENV( 1, 'DORMQR', ' ', N, M, P, -1 )
NB4 = ILAENV( 1, 'DORMRQ', ' ', N, M, P, -1 )
NB = MAX( NB1, NB2, NB3, NB4 )
LWKMIN = M + N + P
LWKOPT = M + NP + MAX( N, P )*NB
END IF
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGGGLM', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Compute the GQR factorization of matrices A and B:
*
* Q'*A = ( R11 ) M, Q'*B*Z' = ( T11 T12 ) M
* ( 0 ) N-M ( 0 T22 ) N-M
* M M+P-N N-M
*
* where R11 and T22 are upper triangular, and Q and Z are
* orthogonal.
*
CALL DGGQRF( N, M, P, A, LDA, WORK, B, LDB, WORK( M+1 ),
$ WORK( M+NP+1 ), LWORK-M-NP, INFO )
LOPT = WORK( M+NP+1 )
*
* Update left-hand-side vector d = Q'*d = ( d1 ) M
* ( d2 ) N-M
*
CALL DORMQR( 'Left', 'Transpose', N, 1, M, A, LDA, WORK, D,
$ MAX( 1, N ), WORK( M+NP+1 ), LWORK-M-NP, INFO )
LOPT = MAX( LOPT, INT( WORK( M+NP+1 ) ) )
*
* Solve T22*y2 = d2 for y2
*
IF( N.GT.M ) THEN
CALL DTRTRS( 'Upper', 'No transpose', 'Non unit', N-M, 1,
$ B( M+1, M+P-N+1 ), LDB, D( M+1 ), N-M, INFO )
*
IF( INFO.GT.0 ) THEN
INFO = 1
RETURN
END IF
*
CALL DCOPY( N-M, D( M+1 ), 1, Y( M+P-N+1 ), 1 )
END IF
*
* Set y1 = 0
*
DO 10 I = 1, M + P - N
Y( I ) = ZERO
10 CONTINUE
*
* Update d1 = d1 - T12*y2
*
CALL DGEMV( 'No transpose', M, N-M, -ONE, B( 1, M+P-N+1 ), LDB,
$ Y( M+P-N+1 ), 1, ONE, D, 1 )
*
* Solve triangular system: R11*x = d1
*
IF( M.GT.0 ) THEN
CALL DTRTRS( 'Upper', 'No Transpose', 'Non unit', M, 1, A, LDA,
$ D, M, INFO )
*
IF( INFO.GT.0 ) THEN
INFO = 2
RETURN
END IF
*
* Copy D to X
*
CALL DCOPY( M, D, 1, X, 1 )
END IF
*
* Backward transformation y = Z'*y
*
CALL DORMRQ( 'Left', 'Transpose', P, 1, NP,
$ B( MAX( 1, N-P+1 ), 1 ), LDB, WORK( M+1 ), Y,
$ MAX( 1, P ), WORK( M+NP+1 ), LWORK-M-NP, INFO )
WORK( 1 ) = M + NP + MAX( LOPT, INT( WORK( M+NP+1 ) ) )
*
RETURN
*
* End of DGGGLM
*
END
SUBROUTINE DGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q,
$ LDQ, Z, LDZ, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER COMPQ, COMPZ
INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
$ Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DGGHRD reduces a pair of real matrices (A,B) to generalized upper
* Hessenberg form using orthogonal transformations, where A is a
* general matrix and B is upper triangular. The form of the
* generalized eigenvalue problem is
* A*x = lambda*B*x,
* and B is typically made upper triangular by computing its QR
* factorization and moving the orthogonal matrix Q to the left side
* of the equation.
*
* This subroutine simultaneously reduces A to a Hessenberg matrix H:
* Q**T*A*Z = H
* and transforms B to another upper triangular matrix T:
* Q**T*B*Z = T
* in order to reduce the problem to its standard form
* H*y = lambda*T*y
* where y = Z**T*x.
*
* The orthogonal matrices Q and Z are determined as products of Givens
* rotations. They may either be formed explicitly, or they may be
* postmultiplied into input matrices Q1 and Z1, so that
*
* Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T
*
* Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T
*
* If Q1 is the orthogonal matrix from the QR factorization of B in the
* original equation A*x = lambda*B*x, then DGGHRD reduces the original
* problem to generalized Hessenberg form.
*
* Arguments
* =========
*
* COMPQ (input) CHARACTER*1
* = 'N': do not compute Q;
* = 'I': Q is initialized to the unit matrix, and the
* orthogonal matrix Q is returned;
* = 'V': Q must contain an orthogonal matrix Q1 on entry,
* and the product Q1*Q is returned.
*
* COMPZ (input) CHARACTER*1
* = 'N': do not compute Z;
* = 'I': Z is initialized to the unit matrix, and the
* orthogonal matrix Z is returned;
* = 'V': Z must contain an orthogonal matrix Z1 on entry,
* and the product Z1*Z is returned.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* ILO and IHI mark the rows and columns of A which are to be
* reduced. It is assumed that A is already upper triangular
* in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are
* normally set by a previous call to SGGBAL; otherwise they
* should be set to 1 and N respectively.
* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
* On entry, the N-by-N general matrix to be reduced.
* On exit, the upper triangle and the first subdiagonal of A
* are overwritten with the upper Hessenberg matrix H, and the
* rest is set to zero.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
* On entry, the N-by-N upper triangular matrix B.
* On exit, the upper triangular matrix T = Q**T B Z. The
* elements below the diagonal are set to zero.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
* On entry, if COMPQ = 'V', the orthogonal matrix Q1,
* typically from the QR factorization of B.
* On exit, if COMPQ='I', the orthogonal matrix Q, and if
* COMPQ = 'V', the product Q1*Q.
* Not referenced if COMPQ='N'.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q.
* LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.
*
* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
* On entry, if COMPZ = 'V', the orthogonal matrix Z1.
* On exit, if COMPZ='I', the orthogonal matrix Z, and if
* COMPZ = 'V', the product Z1*Z.
* Not referenced if COMPZ='N'.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z.
* LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* This routine reduces A to Hessenberg and B to triangular form by
* an unblocked reduction, as described in _Matrix_Computations_,
* by Golub and Van Loan (Johns Hopkins Press.)
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL ILQ, ILZ
INTEGER ICOMPQ, ICOMPZ, JCOL, JROW
DOUBLE PRECISION C, S, TEMP
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DLARTG, DLASET, DROT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Decode COMPQ
*
IF( LSAME( COMPQ, 'N' ) ) THEN
ILQ = .FALSE.
ICOMPQ = 1
ELSE IF( LSAME( COMPQ, 'V' ) ) THEN
ILQ = .TRUE.
ICOMPQ = 2
ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
ILQ = .TRUE.
ICOMPQ = 3
ELSE
ICOMPQ = 0
END IF
*
* Decode COMPZ
*
IF( LSAME( COMPZ, 'N' ) ) THEN
ILZ = .FALSE.
ICOMPZ = 1
ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
ILZ = .TRUE.
ICOMPZ = 2
ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
ILZ = .TRUE.
ICOMPZ = 3
ELSE
ICOMPZ = 0
END IF
*
* Test the input parameters.
*
INFO = 0
IF( ICOMPQ.LE.0 ) THEN
INFO = -1
ELSE IF( ICOMPZ.LE.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ILO.LT.1 ) THEN
INFO = -4
ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN
INFO = -11
ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN
INFO = -13
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGGHRD', -INFO )
RETURN
END IF
*
* Initialize Q and Z if desired.
*
IF( ICOMPQ.EQ.3 )
$ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
IF( ICOMPZ.EQ.3 )
$ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
*
* Quick return if possible
*
IF( N.LE.1 )
$ RETURN
*
* Zero out lower triangle of B
*
DO 20 JCOL = 1, N - 1
DO 10 JROW = JCOL + 1, N
B( JROW, JCOL ) = ZERO
10 CONTINUE
20 CONTINUE
*
* Reduce A and B
*
DO 40 JCOL = ILO, IHI - 2
*
DO 30 JROW = IHI, JCOL + 2, -1
*
* Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL)
*
TEMP = A( JROW-1, JCOL )
CALL DLARTG( TEMP, A( JROW, JCOL ), C, S,
$ A( JROW-1, JCOL ) )
A( JROW, JCOL ) = ZERO
CALL DROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA,
$ A( JROW, JCOL+1 ), LDA, C, S )
CALL DROT( N+2-JROW, B( JROW-1, JROW-1 ), LDB,
$ B( JROW, JROW-1 ), LDB, C, S )
IF( ILQ )
$ CALL DROT( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, C, S )
*
* Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1)
*
TEMP = B( JROW, JROW )
CALL DLARTG( TEMP, B( JROW, JROW-1 ), C, S,
$ B( JROW, JROW ) )
B( JROW, JROW-1 ) = ZERO
CALL DROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, C, S )
CALL DROT( JROW-1, B( 1, JROW ), 1, B( 1, JROW-1 ), 1, C,
$ S )
IF( ILZ )
$ CALL DROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, C, S )
30 CONTINUE
40 CONTINUE
*
RETURN
*
* End of DGGHRD
*
END
SUBROUTINE DGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK,
$ INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, P
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( * ), D( * ),
$ WORK( * ), X( * )
* ..
*
* Purpose
* =======
*
* DGGLSE solves the linear equality-constrained least squares (LSE)
* problem:
*
* minimize || c - A*x ||_2 subject to B*x = d
*
* where A is an M-by-N matrix, B is a P-by-N matrix, c is a given
* M-vector, and d is a given P-vector. It is assumed that
* P <= N <= M+P, and
*
* rank(B) = P and rank( (A) ) = N.
* ( (B) )
*
* These conditions ensure that the LSE problem has a unique solution,
* which is obtained using a generalized RQ factorization of the
* matrices (B, A) given by
*
* B = (0 R)*Q, A = Z*T*Q.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix A. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrices A and B. N >= 0.
*
* P (input) INTEGER
* The number of rows of the matrix B. 0 <= P <= N <= M+P.
*
* 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 T.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)
* On entry, the P-by-N matrix B.
* On exit, the upper triangle of the subarray B(1:P,N-P+1:N)
* contains the P-by-P upper triangular matrix R.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,P).
*
* C (input/output) DOUBLE PRECISION array, dimension (M)
* On entry, C contains the right hand side vector for the
* least squares part of the LSE problem.
* On exit, the residual sum of squares for the solution
* is given by the sum of squares of elements N-P+1 to M of
* vector C.
*
* D (input/output) DOUBLE PRECISION array, dimension (P)
* On entry, D contains the right hand side vector for the
* constrained equation.
* On exit, D is destroyed.
*
* X (output) DOUBLE PRECISION array, dimension (N)
* On exit, X is the solution of the LSE problem.
*
* 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,M+N+P).
* For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,
* where NB is an upper bound for the optimal blocksizes for
* DGEQRF, SGERQF, DORMQR and SORMRQ.
*
* 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.
* = 1: the upper triangular factor R associated with B in the
* generalized RQ factorization of the pair (B, A) is
* singular, so that rank(B) < P; the least squares
* solution could not be computed.
* = 2: the (N-P) by (N-P) part of the upper trapezoidal factor
* T associated with A in the generalized RQ factorization
* of the pair (B, A) is singular, so that
* rank( (A) ) < N; the least squares solution could not
* ( (B) )
* be computed.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER LOPT, LWKMIN, LWKOPT, MN, NB, NB1, NB2, NB3,
$ NB4, NR
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DGEMV, DGGRQF, DORMQR, DORMRQ,
$ DTRMV, DTRTRS, XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC INT, MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
MN = MIN( M, N )
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( P.LT.0 .OR. P.GT.N .OR. P.LT.N-M ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
INFO = -7
END IF
*
* Calculate workspace
*
IF( INFO.EQ.0) THEN
IF( N.EQ.0 ) THEN
LWKMIN = 1
LWKOPT = 1
ELSE
NB1 = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
NB2 = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 )
NB3 = ILAENV( 1, 'DORMQR', ' ', M, N, P, -1 )
NB4 = ILAENV( 1, 'DORMRQ', ' ', M, N, P, -1 )
NB = MAX( NB1, NB2, NB3, NB4 )
LWKMIN = M + N + P
LWKOPT = P + MN + MAX( M, N )*NB
END IF
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGGLSE', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Compute the GRQ factorization of matrices B and A:
*
* B*Q' = ( 0 T12 ) P Z'*A*Q' = ( R11 R12 ) N-P
* N-P P ( 0 R22 ) M+P-N
* N-P P
*
* where T12 and R11 are upper triangular, and Q and Z are
* orthogonal.
*
CALL DGGRQF( P, M, N, B, LDB, WORK, A, LDA, WORK( P+1 ),
$ WORK( P+MN+1 ), LWORK-P-MN, INFO )
LOPT = WORK( P+MN+1 )
*
* Update c = Z'*c = ( c1 ) N-P
* ( c2 ) M+P-N
*
CALL DORMQR( 'Left', 'Transpose', M, 1, MN, A, LDA, WORK( P+1 ),
$ C, MAX( 1, M ), WORK( P+MN+1 ), LWORK-P-MN, INFO )
LOPT = MAX( LOPT, INT( WORK( P+MN+1 ) ) )
*
* Solve T12*x2 = d for x2
*
IF( P.GT.0 ) THEN
CALL DTRTRS( 'Upper', 'No transpose', 'Non-unit', P, 1,
$ B( 1, N-P+1 ), LDB, D, P, INFO )
*
IF( INFO.GT.0 ) THEN
INFO = 1
RETURN
END IF
*
* Put the solution in X
*
CALL DCOPY( P, D, 1, X( N-P+1 ), 1 )
*
* Update c1
*
CALL DGEMV( 'No transpose', N-P, P, -ONE, A( 1, N-P+1 ), LDA,
$ D, 1, ONE, C, 1 )
END IF
*
* Solve R11*x1 = c1 for x1
*
IF( N.GT.P ) THEN
CALL DTRTRS( 'Upper', 'No transpose', 'Non-unit', N-P, 1,
$ A, LDA, C, N-P, INFO )
*
IF( INFO.GT.0 ) THEN
INFO = 2
RETURN
END IF
*
* Put the solutions in X
*
CALL DCOPY( N-P, C, 1, X, 1 )
END IF
*
* Compute the residual vector:
*
IF( M.LT.N ) THEN
NR = M + P - N
IF( NR.GT.0 )
$ CALL DGEMV( 'No transpose', NR, N-M, -ONE, A( N-P+1, M+1 ),
$ LDA, D( NR+1 ), 1, ONE, C( N-P+1 ), 1 )
ELSE
NR = P
END IF
IF( NR.GT.0 ) THEN
CALL DTRMV( 'Upper', 'No transpose', 'Non unit', NR,
$ A( N-P+1, N-P+1 ), LDA, D, 1 )
CALL DAXPY( NR, -ONE, D, 1, C( N-P+1 ), 1 )
END IF
*
* Backward transformation x = Q'*x
*
CALL DORMRQ( 'Left', 'Transpose', N, 1, P, B, LDB, WORK( 1 ), X,
$ N, WORK( P+MN+1 ), LWORK-P-MN, INFO )
WORK( 1 ) = P + MN + MAX( LOPT, INT( WORK( P+MN+1 ) ) )
*
RETURN
*
* End of DGGLSE
*
END
SUBROUTINE DGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK,
$ LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, P
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* DGGQRF computes a generalized QR factorization of an N-by-M matrix A
* and an N-by-P matrix B:
*
* A = Q*R, B = Q*T*Z,
*
* where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal
* matrix, and R and T assume one of the forms:
*
* if N >= M, R = ( R11 ) M , or if N < M, R = ( R11 R12 ) N,
* ( 0 ) N-M N M-N
* M
*
* where R11 is upper triangular, and
*
* if N <= P, T = ( 0 T12 ) N, or if N > P, T = ( T11 ) N-P,
* P-N N ( T21 ) P
* P
*
* where T12 or T21 is upper triangular.
*
* In particular, if B is square and nonsingular, the GQR factorization
* of A and B implicitly gives the QR factorization of inv(B)*A:
*
* inv(B)*A = Z'*(inv(T)*R)
*
* where inv(B) denotes the inverse of the matrix B, and Z' denotes the
* transpose of the matrix Z.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of rows of the matrices A and B. N >= 0.
*
* M (input) INTEGER
* The number of columns of the matrix A. M >= 0.
*
* P (input) INTEGER
* The number of columns of the matrix B. P >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,M)
* On entry, the N-by-M matrix A.
* On exit, the elements on and above the diagonal of the array
* contain the min(N,M)-by-M upper trapezoidal matrix R (R is
* upper triangular if N >= M); the elements below the diagonal,
* with the array TAUA, represent the orthogonal matrix Q as a
* product of min(N,M) elementary reflectors (see Further
* Details).
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* TAUA (output) DOUBLE PRECISION array, dimension (min(N,M))
* The scalar factors of the elementary reflectors which
* represent the orthogonal matrix Q (see Further Details).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,P)
* On entry, the N-by-P matrix B.
* On exit, if N <= P, the upper triangle of the subarray
* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;
* if N > P, the elements on and above the (N-P)-th subdiagonal
* contain the N-by-P upper trapezoidal matrix T; the remaining
* elements, with the array TAUB, represent the orthogonal
* matrix Z as a product of elementary reflectors (see Further
* Details).
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* TAUB (output) DOUBLE PRECISION array, dimension (min(N,P))
* The scalar factors of the elementary reflectors which
* represent the orthogonal matrix Z (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,M,P).
* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
* where NB1 is the optimal blocksize for the QR factorization
* of an N-by-M matrix, NB2 is the optimal blocksize for the
* RQ factorization of an N-by-P matrix, and NB3 is the optimal
* blocksize for a call of DORMQR.
*
* 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(n,m).
*
* Each H(i) has the form
*
* H(i) = I - taua * v * v'
*
* where taua is a real scalar, and v is a real vector with
* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
* and taua in TAUA(i).
* To form Q explicitly, use LAPACK subroutine DORGQR.
* To use Q to update another matrix, use LAPACK subroutine DORMQR.
*
* The matrix Z is represented as a product of elementary reflectors
*
* Z = H(1) H(2) . . . H(k), where k = min(n,p).
*
* Each H(i) has the form
*
* H(i) = I - taub * v * v'
*
* where taub is a real scalar, and v is a real vector with
* v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in
* B(n-k+i,1:p-k+i-1), and taub in TAUB(i).
* To form Z explicitly, use LAPACK subroutine DORGRQ.
* To use Z to update another matrix, use LAPACK subroutine DORMRQ.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3
* ..
* .. External Subroutines ..
EXTERNAL DGEQRF, DGERQF, DORMQR, XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC INT, MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
NB1 = ILAENV( 1, 'DGEQRF', ' ', N, M, -1, -1 )
NB2 = ILAENV( 1, 'DGERQF', ' ', N, P, -1, -1 )
NB3 = ILAENV( 1, 'DORMQR', ' ', N, M, P, -1 )
NB = MAX( NB1, NB2, NB3 )
LWKOPT = MAX( N, M, P )*NB
WORK( 1 ) = LWKOPT
LQUERY = ( LWORK.EQ.-1 )
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( M.LT.0 ) THEN
INFO = -2
ELSE IF( P.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
ELSE IF( LWORK.LT.MAX( 1, N, M, P ) .AND. .NOT.LQUERY ) THEN
INFO = -11
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGGQRF', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* QR factorization of N-by-M matrix A: A = Q*R
*
CALL DGEQRF( N, M, A, LDA, TAUA, WORK, LWORK, INFO )
LOPT = WORK( 1 )
*
* Update B := Q'*B.
*
CALL DORMQR( 'Left', 'Transpose', N, P, MIN( N, M ), A, LDA, TAUA,
$ B, LDB, WORK, LWORK, INFO )
LOPT = MAX( LOPT, INT( WORK( 1 ) ) )
*
* RQ factorization of N-by-P matrix B: B = T*Z.
*
CALL DGERQF( N, P, B, LDB, TAUB, WORK, LWORK, INFO )
WORK( 1 ) = MAX( LOPT, INT( WORK( 1 ) ) )
*
RETURN
*
* End of DGGQRF
*
END
SUBROUTINE DGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK,
$ LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, P
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* DGGRQF computes a generalized RQ factorization of an M-by-N matrix A
* and a P-by-N matrix B:
*
* A = R*Q, B = Z*T*Q,
*
* where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal
* matrix, and R and T assume one of the forms:
*
* if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N,
* N-M M ( R21 ) N
* N
*
* where R12 or R21 is upper triangular, and
*
* if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P,
* ( 0 ) P-N P N-P
* N
*
* where T11 is upper triangular.
*
* In particular, if B is square and nonsingular, the GRQ factorization
* of A and B implicitly gives the RQ factorization of A*inv(B):
*
* A*inv(B) = (R*inv(T))*Z'
*
* where inv(B) denotes the inverse of the matrix B, and Z' denotes the
* transpose of the matrix Z.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix A. M >= 0.
*
* P (input) INTEGER
* The number of rows of the matrix B. P >= 0.
*
* N (input) INTEGER
* The number of columns of the matrices A and B. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, if M <= N, the upper triangle of the subarray
* A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;
* if M > N, the elements on and above the (M-N)-th subdiagonal
* contain the M-by-N upper trapezoidal matrix R; the remaining
* elements, with the array TAUA, 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).
*
* TAUA (output) DOUBLE PRECISION array, dimension (min(M,N))
* The scalar factors of the elementary reflectors which
* represent the orthogonal matrix Q (see Further Details).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)
* On entry, the P-by-N matrix B.
* On exit, the elements on and above the diagonal of the array
* contain the min(P,N)-by-N upper trapezoidal matrix T (T is
* upper triangular if P >= N); the elements below the diagonal,
* with the array TAUB, represent the orthogonal matrix Z as a
* product of elementary reflectors (see Further Details).
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,P).
*
* TAUB (output) DOUBLE PRECISION array, dimension (min(P,N))
* The scalar factors of the elementary reflectors which
* represent the orthogonal matrix Z (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,M,P).
* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
* where NB1 is the optimal blocksize for the RQ factorization
* of an M-by-N matrix, NB2 is the optimal blocksize for the
* QR factorization of a P-by-N matrix, and NB3 is the optimal
* blocksize for a call of DORMRQ.
*
* 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 INF0= -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 - taua * v * v'
*
* where taua is a real scalar, and v is a real vector with
* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
* A(m-k+i,1:n-k+i-1), and taua in TAUA(i).
* To form Q explicitly, use LAPACK subroutine DORGRQ.
* To use Q to update another matrix, use LAPACK subroutine DORMRQ.
*
* The matrix Z is represented as a product of elementary reflectors
*
* Z = H(1) H(2) . . . H(k), where k = min(p,n).
*
* Each H(i) has the form
*
* H(i) = I - taub * v * v'
*
* where taub is a real scalar, and v is a real vector with
* v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),
* and taub in TAUB(i).
* To form Z explicitly, use LAPACK subroutine DORGQR.
* To use Z to update another matrix, use LAPACK subroutine DORMQR.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3
* ..
* .. External Subroutines ..
EXTERNAL DGEQRF, DGERQF, DORMRQ, XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC INT, MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
NB1 = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 )
NB2 = ILAENV( 1, 'DGEQRF', ' ', P, N, -1, -1 )
NB3 = ILAENV( 1, 'DORMRQ', ' ', M, N, P, -1 )
NB = MAX( NB1, NB2, NB3 )
LWKOPT = MAX( N, M, P )*NB
WORK( 1 ) = LWKOPT
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( P.LT.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
INFO = -8
ELSE IF( LWORK.LT.MAX( 1, M, P, N ) .AND. .NOT.LQUERY ) THEN
INFO = -11
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGGRQF', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* RQ factorization of M-by-N matrix A: A = R*Q
*
CALL DGERQF( M, N, A, LDA, TAUA, WORK, LWORK, INFO )
LOPT = WORK( 1 )
*
* Update B := B*Q'
*
CALL DORMRQ( 'Right', 'Transpose', P, N, MIN( M, N ),
$ A( MAX( 1, M-N+1 ), 1 ), LDA, TAUA, B, LDB, WORK,
$ LWORK, INFO )
LOPT = MAX( LOPT, INT( WORK( 1 ) ) )
*
* QR factorization of P-by-N matrix B: B = Z*T
*
CALL DGEQRF( P, N, B, LDB, TAUB, WORK, LWORK, INFO )
WORK( 1 ) = MAX( LOPT, INT( WORK( 1 ) ) )
*
RETURN
*
* End of DGGRQF
*
END
SUBROUTINE DGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B,
$ LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK,
$ IWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBQ, JOBU, JOBV
INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION A( LDA, * ), ALPHA( * ), B( LDB, * ),
$ BETA( * ), Q( LDQ, * ), U( LDU, * ),
$ V( LDV, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGGSVD computes the generalized singular value decomposition (GSVD)
* of an M-by-N real matrix A and P-by-N real matrix B:
*
* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R )
*
* where U, V and Q are orthogonal matrices, and Z' is the transpose
* of Z. Let K+L = the effective numerical rank of the matrix (A',B')',
* then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and
* D2 are M-by-(K+L) and P-by-(K+L) "diagonal" matrices and of the
* following structures, respectively:
*
* If M-K-L >= 0,
*
* K L
* D1 = K ( I 0 )
* L ( 0 C )
* M-K-L ( 0 0 )
*
* K L
* D2 = L ( 0 S )
* P-L ( 0 0 )
*
* N-K-L K L
* ( 0 R ) = K ( 0 R11 R12 )
* L ( 0 0 R22 )
*
* where
*
* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),
* S = diag( BETA(K+1), ... , BETA(K+L) ),
* C**2 + S**2 = I.
*
* R is stored in A(1:K+L,N-K-L+1:N) on exit.
*
* If M-K-L < 0,
*
* K M-K K+L-M
* D1 = K ( I 0 0 )
* M-K ( 0 C 0 )
*
* K M-K K+L-M
* D2 = M-K ( 0 S 0 )
* K+L-M ( 0 0 I )
* P-L ( 0 0 0 )
*
* N-K-L K M-K K+L-M
* ( 0 R ) = K ( 0 R11 R12 R13 )
* M-K ( 0 0 R22 R23 )
* K+L-M ( 0 0 0 R33 )
*
* where
*
* C = diag( ALPHA(K+1), ... , ALPHA(M) ),
* S = diag( BETA(K+1), ... , BETA(M) ),
* C**2 + S**2 = I.
*
* (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored
* ( 0 R22 R23 )
* in B(M-K+1:L,N+M-K-L+1:N) on exit.
*
* The routine computes C, S, R, and optionally the orthogonal
* transformation matrices U, V and Q.
*
* In particular, if B is an N-by-N nonsingular matrix, then the GSVD of
* A and B implicitly gives the SVD of A*inv(B):
* A*inv(B) = U*(D1*inv(D2))*V'.
* If ( A',B')' has orthonormal columns, then the GSVD of A and B is
* also equal to the CS decomposition of A and B. Furthermore, the GSVD
* can be used to derive the solution of the eigenvalue problem:
* A'*A x = lambda* B'*B x.
* In some literature, the GSVD of A and B is presented in the form
* U'*A*X = ( 0 D1 ), V'*B*X = ( 0 D2 )
* where U and V are orthogonal and X is nonsingular, D1 and D2 are
* ``diagonal''. The former GSVD form can be converted to the latter
* form by taking the nonsingular matrix X as
*
* X = Q*( I 0 )
* ( 0 inv(R) ).
*
* Arguments
* =========
*
* JOBU (input) CHARACTER*1
* = 'U': Orthogonal matrix U is computed;
* = 'N': U is not computed.
*
* JOBV (input) CHARACTER*1
* = 'V': Orthogonal matrix V is computed;
* = 'N': V is not computed.
*
* JOBQ (input) CHARACTER*1
* = 'Q': Orthogonal matrix Q is computed;
* = 'N': Q is not computed.
*
* M (input) INTEGER
* The number of rows of the matrix A. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrices A and B. N >= 0.
*
* P (input) INTEGER
* The number of rows of the matrix B. P >= 0.
*
* K (output) INTEGER
* L (output) INTEGER
* On exit, K and L specify the dimension of the subblocks
* described in the Purpose section.
* K + L = effective numerical rank of (A',B')'.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, A contains the triangular matrix R, or part of R.
* See Purpose for details.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)
* On entry, the P-by-N matrix B.
* On exit, B contains the triangular matrix R if M-K-L < 0.
* See Purpose for details.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,P).
*
* ALPHA (output) DOUBLE PRECISION array, dimension (N)
* BETA (output) DOUBLE PRECISION array, dimension (N)
* On exit, ALPHA and BETA contain the generalized singular
* value pairs of A and B;
* ALPHA(1:K) = 1,
* BETA(1:K) = 0,
* and if M-K-L >= 0,
* ALPHA(K+1:K+L) = C,
* BETA(K+1:K+L) = S,
* or if M-K-L < 0,
* ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0
* BETA(K+1:M) =S, BETA(M+1:K+L) =1
* and
* ALPHA(K+L+1:N) = 0
* BETA(K+L+1:N) = 0
*
* U (output) DOUBLE PRECISION array, dimension (LDU,M)
* If JOBU = 'U', U contains the M-by-M orthogonal matrix U.
* If JOBU = 'N', U is not referenced.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= max(1,M) if
* JOBU = 'U'; LDU >= 1 otherwise.
*
* V (output) DOUBLE PRECISION array, dimension (LDV,P)
* If JOBV = 'V', V contains the P-by-P orthogonal matrix V.
* If JOBV = 'N', V is not referenced.
*
* LDV (input) INTEGER
* The leading dimension of the array V. LDV >= max(1,P) if
* JOBV = 'V'; LDV >= 1 otherwise.
*
* Q (output) DOUBLE PRECISION array, dimension (LDQ,N)
* If JOBQ = 'Q', Q contains the N-by-N orthogonal matrix Q.
* If JOBQ = 'N', Q is not referenced.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N) if
* JOBQ = 'Q'; LDQ >= 1 otherwise.
*
* WORK (workspace) DOUBLE PRECISION array,
* dimension (max(3*N,M,P)+N)
*
* IWORK (workspace/output) INTEGER array, dimension (N)
* On exit, IWORK stores the sorting information. More
* precisely, the following loop will sort ALPHA
* for I = K+1, min(M,K+L)
* swap ALPHA(I) and ALPHA(IWORK(I))
* endfor
* such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, the Jacobi-type procedure failed to
* converge. For further details, see subroutine DTGSJA.
*
* Internal Parameters
* ===================
*
* TOLA DOUBLE PRECISION
* TOLB DOUBLE PRECISION
* TOLA and TOLB are the thresholds to determine the effective
* rank of (A',B')'. Generally, they are set to
* TOLA = MAX(M,N)*norm(A)*MAZHEPS,
* TOLB = MAX(P,N)*norm(B)*MAZHEPS.
* The size of TOLA and TOLB may affect the size of backward
* errors of the decomposition.
*
* Further Details
* ===============
*
* 2-96 Based on modifications by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL WANTQ, WANTU, WANTV
INTEGER I, IBND, ISUB, J, NCYCLE
DOUBLE PRECISION ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL LSAME, DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGGSVP, DTGSJA, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
WANTU = LSAME( JOBU, 'U' )
WANTV = LSAME( JOBV, 'V' )
WANTQ = LSAME( JOBQ, 'Q' )
*
INFO = 0
IF( .NOT.( WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN
INFO = -2
ELSE IF( .NOT.( WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN
INFO = -3
ELSE IF( M.LT.0 ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( P.LT.0 ) THEN
INFO = -6
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -10
ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
INFO = -12
ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN
INFO = -16
ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN
INFO = -18
ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
INFO = -20
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGGSVD', -INFO )
RETURN
END IF
*
* Compute the Frobenius norm of matrices A and B
*
ANORM = DLANGE( '1', M, N, A, LDA, WORK )
BNORM = DLANGE( '1', P, N, B, LDB, WORK )
*
* Get machine precision and set up threshold for determining
* the effective numerical rank of the matrices A and B.
*
ULP = DLAMCH( 'Precision' )
UNFL = DLAMCH( 'Safe Minimum' )
TOLA = MAX( M, N )*MAX( ANORM, UNFL )*ULP
TOLB = MAX( P, N )*MAX( BNORM, UNFL )*ULP
*
* Preprocessing
*
CALL DGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA,
$ TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, WORK,
$ WORK( N+1 ), INFO )
*
* Compute the GSVD of two upper "triangular" matrices
*
CALL DTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, LDB,
$ TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ,
$ WORK, NCYCLE, INFO )
*
* Sort the singular values and store the pivot indices in IWORK
* Copy ALPHA to WORK, then sort ALPHA in WORK
*
CALL DCOPY( N, ALPHA, 1, WORK, 1 )
IBND = MIN( L, M-K )
DO 20 I = 1, IBND
*
* Scan for largest ALPHA(K+I)
*
ISUB = I
SMAX = WORK( K+I )
DO 10 J = I + 1, IBND
TEMP = WORK( K+J )
IF( TEMP.GT.SMAX ) THEN
ISUB = J
SMAX = TEMP
END IF
10 CONTINUE
IF( ISUB.NE.I ) THEN
WORK( K+ISUB ) = WORK( K+I )
WORK( K+I ) = SMAX
IWORK( K+I ) = K + ISUB
ELSE
IWORK( K+I ) = K + I
END IF
20 CONTINUE
*
RETURN
*
* End of DGGSVD
*
END
SUBROUTINE DGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB,
$ TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ,
$ IWORK, TAU, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBQ, JOBU, JOBV
INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P
DOUBLE PRECISION TOLA, TOLB
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
$ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGGSVP computes orthogonal matrices U, V and Q such that
*
* N-K-L K L
* U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0;
* L ( 0 0 A23 )
* M-K-L ( 0 0 0 )
*
* N-K-L K L
* = K ( 0 A12 A13 ) if M-K-L < 0;
* M-K ( 0 0 A23 )
*
* N-K-L K L
* V'*B*Q = L ( 0 0 B13 )
* P-L ( 0 0 0 )
*
* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
* otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective
* numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the
* transpose of Z.
*
* This decomposition is the preprocessing step for computing the
* Generalized Singular Value Decomposition (GSVD), see subroutine
* DGGSVD.
*
* Arguments
* =========
*
* JOBU (input) CHARACTER*1
* = 'U': Orthogonal matrix U is computed;
* = 'N': U is not computed.
*
* JOBV (input) CHARACTER*1
* = 'V': Orthogonal matrix V is computed;
* = 'N': V is not computed.
*
* JOBQ (input) CHARACTER*1
* = 'Q': Orthogonal matrix Q is computed;
* = 'N': Q is not computed.
*
* M (input) INTEGER
* The number of rows of the matrix A. M >= 0.
*
* P (input) INTEGER
* The number of rows of the matrix B. P >= 0.
*
* N (input) INTEGER
* The number of columns of the matrices A and B. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, A contains the triangular (or trapezoidal) matrix
* described in the Purpose section.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)
* On entry, the P-by-N matrix B.
* On exit, B contains the triangular matrix described in
* the Purpose section.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,P).
*
* TOLA (input) DOUBLE PRECISION
* TOLB (input) DOUBLE PRECISION
* TOLA and TOLB are the thresholds to determine the effective
* numerical rank of matrix B and a subblock of A. Generally,
* they are set to
* TOLA = MAX(M,N)*norm(A)*MAZHEPS,
* TOLB = MAX(P,N)*norm(B)*MAZHEPS.
* The size of TOLA and TOLB may affect the size of backward
* errors of the decomposition.
*
* K (output) INTEGER
* L (output) INTEGER
* On exit, K and L specify the dimension of the subblocks
* described in Purpose.
* K + L = effective numerical rank of (A',B')'.
*
* U (output) DOUBLE PRECISION array, dimension (LDU,M)
* If JOBU = 'U', U contains the orthogonal matrix U.
* If JOBU = 'N', U is not referenced.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= max(1,M) if
* JOBU = 'U'; LDU >= 1 otherwise.
*
* V (output) DOUBLE PRECISION array, dimension (LDV,M)
* If JOBV = 'V', V contains the orthogonal matrix V.
* If JOBV = 'N', V is not referenced.
*
* LDV (input) INTEGER
* The leading dimension of the array V. LDV >= max(1,P) if
* JOBV = 'V'; LDV >= 1 otherwise.
*
* Q (output) DOUBLE PRECISION array, dimension (LDQ,N)
* If JOBQ = 'Q', Q contains the orthogonal matrix Q.
* If JOBQ = 'N', Q is not referenced.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N) if
* JOBQ = 'Q'; LDQ >= 1 otherwise.
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* TAU (workspace) DOUBLE PRECISION array, dimension (N)
*
* WORK (workspace) DOUBLE PRECISION array, dimension (max(3*N,M,P))
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
*
* Further Details
* ===============
*
* The subroutine uses LAPACK subroutine DGEQPF for the QR factorization
* with column pivoting to detect the effective numerical rank of the
* a matrix. It may be replaced by a better rank determination strategy.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL FORWRD, WANTQ, WANTU, WANTV
INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DGEQPF, DGEQR2, DGERQ2, DLACPY, DLAPMT, DLASET,
$ DORG2R, DORM2R, DORMR2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
WANTU = LSAME( JOBU, 'U' )
WANTV = LSAME( JOBV, 'V' )
WANTQ = LSAME( JOBQ, 'Q' )
FORWRD = .TRUE.
*
INFO = 0
IF( .NOT.( WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN
INFO = -2
ELSE IF( .NOT.( WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN
INFO = -3
ELSE IF( M.LT.0 ) THEN
INFO = -4
ELSE IF( P.LT.0 ) THEN
INFO = -5
ELSE IF( N.LT.0 ) THEN
INFO = -6
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -8
ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
INFO = -10
ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN
INFO = -16
ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN
INFO = -18
ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
INFO = -20
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGGSVP', -INFO )
RETURN
END IF
*
* QR with column pivoting of B: B*P = V*( S11 S12 )
* ( 0 0 )
*
DO 10 I = 1, N
IWORK( I ) = 0
10 CONTINUE
CALL DGEQPF( P, N, B, LDB, IWORK, TAU, WORK, INFO )
*
* Update A := A*P
*
CALL DLAPMT( FORWRD, M, N, A, LDA, IWORK )
*
* Determine the effective rank of matrix B.
*
L = 0
DO 20 I = 1, MIN( P, N )
IF( ABS( B( I, I ) ).GT.TOLB )
$ L = L + 1
20 CONTINUE
*
IF( WANTV ) THEN
*
* Copy the details of V, and form V.
*
CALL DLASET( 'Full', P, P, ZERO, ZERO, V, LDV )
IF( P.GT.1 )
$ CALL DLACPY( 'Lower', P-1, N, B( 2, 1 ), LDB, V( 2, 1 ),
$ LDV )
CALL DORG2R( P, P, MIN( P, N ), V, LDV, TAU, WORK, INFO )
END IF
*
* Clean up B
*
DO 40 J = 1, L - 1
DO 30 I = J + 1, L
B( I, J ) = ZERO
30 CONTINUE
40 CONTINUE
IF( P.GT.L )
$ CALL DLASET( 'Full', P-L, N, ZERO, ZERO, B( L+1, 1 ), LDB )
*
IF( WANTQ ) THEN
*
* Set Q = I and Update Q := Q*P
*
CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
CALL DLAPMT( FORWRD, N, N, Q, LDQ, IWORK )
END IF
*
IF( P.GE.L .AND. N.NE.L ) THEN
*
* RQ factorization of (S11 S12): ( S11 S12 ) = ( 0 S12 )*Z
*
CALL DGERQ2( L, N, B, LDB, TAU, WORK, INFO )
*
* Update A := A*Z'
*
CALL DORMR2( 'Right', 'Transpose', M, N, L, B, LDB, TAU, A,
$ LDA, WORK, INFO )
*
IF( WANTQ ) THEN
*
* Update Q := Q*Z'
*
CALL DORMR2( 'Right', 'Transpose', N, N, L, B, LDB, TAU, Q,
$ LDQ, WORK, INFO )
END IF
*
* Clean up B
*
CALL DLASET( 'Full', L, N-L, ZERO, ZERO, B, LDB )
DO 60 J = N - L + 1, N
DO 50 I = J - N + L + 1, L
B( I, J ) = ZERO
50 CONTINUE
60 CONTINUE
*
END IF
*
* Let N-L L
* A = ( A11 A12 ) M,
*
* then the following does the complete QR decomposition of A11:
*
* A11 = U*( 0 T12 )*P1'
* ( 0 0 )
*
DO 70 I = 1, N - L
IWORK( I ) = 0
70 CONTINUE
CALL DGEQPF( M, N-L, A, LDA, IWORK, TAU, WORK, INFO )
*
* Determine the effective rank of A11
*
K = 0
DO 80 I = 1, MIN( M, N-L )
IF( ABS( A( I, I ) ).GT.TOLA )
$ K = K + 1
80 CONTINUE
*
* Update A12 := U'*A12, where A12 = A( 1:M, N-L+1:N )
*
CALL DORM2R( 'Left', 'Transpose', M, L, MIN( M, N-L ), A, LDA,
$ TAU, A( 1, N-L+1 ), LDA, WORK, INFO )
*
IF( WANTU ) THEN
*
* Copy the details of U, and form U
*
CALL DLASET( 'Full', M, M, ZERO, ZERO, U, LDU )
IF( M.GT.1 )
$ CALL DLACPY( 'Lower', M-1, N-L, A( 2, 1 ), LDA, U( 2, 1 ),
$ LDU )
CALL DORG2R( M, M, MIN( M, N-L ), U, LDU, TAU, WORK, INFO )
END IF
*
IF( WANTQ ) THEN
*
* Update Q( 1:N, 1:N-L ) = Q( 1:N, 1:N-L )*P1
*
CALL DLAPMT( FORWRD, N, N-L, Q, LDQ, IWORK )
END IF
*
* Clean up A: set the strictly lower triangular part of
* A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0.
*
DO 100 J = 1, K - 1
DO 90 I = J + 1, K
A( I, J ) = ZERO
90 CONTINUE
100 CONTINUE
IF( M.GT.K )
$ CALL DLASET( 'Full', M-K, N-L, ZERO, ZERO, A( K+1, 1 ), LDA )
*
IF( N-L.GT.K ) THEN
*
* RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1
*
CALL DGERQ2( K, N-L, A, LDA, TAU, WORK, INFO )
*
IF( WANTQ ) THEN
*
* Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1'
*
CALL DORMR2( 'Right', 'Transpose', N, N-L, K, A, LDA, TAU,
$ Q, LDQ, WORK, INFO )
END IF
*
* Clean up A
*
CALL DLASET( 'Full', K, N-L-K, ZERO, ZERO, A, LDA )
DO 120 J = N - L - K + 1, N - L
DO 110 I = J - N + L + K + 1, K
A( I, J ) = ZERO
110 CONTINUE
120 CONTINUE
*
END IF
*
IF( M.GT.K ) THEN
*
* QR factorization of A( K+1:M,N-L+1:N )
*
CALL DGEQR2( M-K, L, A( K+1, N-L+1 ), LDA, TAU, WORK, INFO )
*
IF( WANTU ) THEN
*
* Update U(:,K+1:M) := U(:,K+1:M)*U1
*
CALL DORM2R( 'Right', 'No transpose', M, M-K, MIN( M-K, L ),
$ A( K+1, N-L+1 ), LDA, TAU, U( 1, K+1 ), LDU,
$ WORK, INFO )
END IF
*
* Clean up
*
DO 140 J = N - L + 1, N
DO 130 I = J - N + K + L + 1, M
A( I, J ) = ZERO
130 CONTINUE
140 CONTINUE
*
END IF
*
RETURN
*
* End of DGGSVP
*
END
SUBROUTINE DGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND,
$ WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER INFO, N
DOUBLE PRECISION ANORM, RCOND
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), IWORK( * )
DOUBLE PRECISION D( * ), DL( * ), DU( * ), DU2( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGTCON estimates the reciprocal of the condition number of a real
* tridiagonal matrix A using the LU factorization as computed by
* DGTTRF.
*
* An estimate is obtained for norm(inv(A)), and the reciprocal of the
* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies whether the 1-norm condition number or the
* infinity-norm condition number is required:
* = '1' or 'O': 1-norm;
* = 'I': Infinity-norm.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* DL (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) multipliers that define the matrix L from the
* LU factorization of A as computed by DGTTRF.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the upper triangular matrix U from
* the LU factorization of A.
*
* DU (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) elements of the first superdiagonal of U.
*
* DU2 (input) DOUBLE PRECISION array, dimension (N-2)
* The (n-2) elements of the second superdiagonal of U.
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices; for 1 <= i <= n, row i of the matrix was
* interchanged with row IPIV(i). IPIV(i) will always be either
* i or i+1; IPIV(i) = i indicates a row interchange was not
* required.
*
* ANORM (input) DOUBLE PRECISION
* If NORM = '1' or 'O', the 1-norm of the original matrix A.
* If NORM = 'I', the infinity-norm of the original matrix A.
*
* RCOND (output) DOUBLE PRECISION
* The reciprocal of the condition number of the matrix A,
* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
* estimate of the 1-norm of inv(A) computed in this routine.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL ONENRM
INTEGER I, KASE, KASE1
DOUBLE PRECISION AINVNM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DGTTRS, DLACN2, XERBLA
* ..
* .. Executable Statements ..
*
* Test the input arguments.
*
INFO = 0
ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ANORM.LT.ZERO ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGTCON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
RCOND = ZERO
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
ELSE IF( ANORM.EQ.ZERO ) THEN
RETURN
END IF
*
* Check that D(1:N) is non-zero.
*
DO 10 I = 1, N
IF( D( I ).EQ.ZERO )
$ RETURN
10 CONTINUE
*
AINVNM = ZERO
IF( ONENRM ) THEN
KASE1 = 1
ELSE
KASE1 = 2
END IF
KASE = 0
20 CONTINUE
CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.KASE1 ) THEN
*
* Multiply by inv(U)*inv(L).
*
CALL DGTTRS( 'No transpose', N, 1, DL, D, DU, DU2, IPIV,
$ WORK, N, INFO )
ELSE
*
* Multiply by inv(L')*inv(U').
*
CALL DGTTRS( 'Transpose', N, 1, DL, D, DU, DU2, IPIV, WORK,
$ N, INFO )
END IF
GO TO 20
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / AINVNM ) / ANORM
*
RETURN
*
* End of DGTCON
*
END
SUBROUTINE DGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2,
$ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER INFO, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), IWORK( * )
DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DF( * ),
$ DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ),
$ FERR( * ), WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* DGTRFS improves the computed solution to a system of linear
* equations when the coefficient matrix is tridiagonal, and provides
* error bounds and backward error estimates for the solution.
*
* 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**H * 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.
*
* DL (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) subdiagonal elements of A.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The diagonal elements of A.
*
* DU (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) superdiagonal elements of A.
*
* DLF (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) multipliers that define the matrix L from the
* LU factorization of A as computed by DGTTRF.
*
* DF (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the upper triangular matrix U from
* the LU factorization of A.
*
* DUF (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) elements of the first superdiagonal of U.
*
* DU2 (input) DOUBLE PRECISION array, dimension (N-2)
* The (n-2) elements of the second superdiagonal of U.
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices; for 1 <= i <= n, row i of the matrix was
* interchanged with row IPIV(i). IPIV(i) will always be either
* i or i+1; IPIV(i) = i indicates a row interchange was not
* required.
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
* On entry, the solution matrix X, as computed by DGTTRS.
* On exit, the improved solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Internal Parameters
* ===================
*
* ITMAX is the maximum number of steps of iterative refinement.
*
* =====================================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 5 )
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D+0 )
DOUBLE PRECISION THREE
PARAMETER ( THREE = 3.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN
CHARACTER TRANSN, TRANST
INTEGER COUNT, I, J, KASE, NZ
DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DGTTRS, DLACN2, DLAGTM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH
* ..
* .. 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( LDB.LT.MAX( 1, N ) ) THEN
INFO = -13
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -15
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGTRFS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
DO 10 J = 1, NRHS
FERR( J ) = ZERO
BERR( J ) = ZERO
10 CONTINUE
RETURN
END IF
*
IF( NOTRAN ) THEN
TRANSN = 'N'
TRANST = 'T'
ELSE
TRANSN = 'T'
TRANST = 'N'
END IF
*
* NZ = maximum number of nonzero elements in each row of A, plus 1
*
NZ = 4
EPS = DLAMCH( 'Epsilon' )
SAFMIN = DLAMCH( 'Safe minimum' )
SAFE1 = NZ*SAFMIN
SAFE2 = SAFE1 / EPS
*
* Do for each right hand side
*
DO 110 J = 1, NRHS
*
COUNT = 1
LSTRES = THREE
20 CONTINUE
*
* Loop until stopping criterion is satisfied.
*
* Compute residual R = B - op(A) * X,
* where op(A) = A, A**T, or A**H, depending on TRANS.
*
CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
CALL DLAGTM( TRANS, N, 1, -ONE, DL, D, DU, X( 1, J ), LDX, ONE,
$ WORK( N+1 ), N )
*
* Compute abs(op(A))*abs(x) + abs(b) for use in the backward
* error bound.
*
IF( NOTRAN ) THEN
IF( N.EQ.1 ) THEN
WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) )
ELSE
WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) ) +
$ ABS( DU( 1 )*X( 2, J ) )
DO 30 I = 2, N - 1
WORK( I ) = ABS( B( I, J ) ) +
$ ABS( DL( I-1 )*X( I-1, J ) ) +
$ ABS( D( I )*X( I, J ) ) +
$ ABS( DU( I )*X( I+1, J ) )
30 CONTINUE
WORK( N ) = ABS( B( N, J ) ) +
$ ABS( DL( N-1 )*X( N-1, J ) ) +
$ ABS( D( N )*X( N, J ) )
END IF
ELSE
IF( N.EQ.1 ) THEN
WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) )
ELSE
WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) ) +
$ ABS( DL( 1 )*X( 2, J ) )
DO 40 I = 2, N - 1
WORK( I ) = ABS( B( I, J ) ) +
$ ABS( DU( I-1 )*X( I-1, J ) ) +
$ ABS( D( I )*X( I, J ) ) +
$ ABS( DL( I )*X( I+1, J ) )
40 CONTINUE
WORK( N ) = ABS( B( N, J ) ) +
$ ABS( DU( N-1 )*X( N-1, J ) ) +
$ ABS( D( N )*X( N, J ) )
END IF
END IF
*
* Compute componentwise relative backward error from formula
*
* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
*
* where abs(Z) is the componentwise absolute value of the matrix
* or vector Z. If the i-th component of the denominator is less
* than SAFE2, then SAFE1 is added to the i-th components of the
* numerator and denominator before dividing.
*
S = ZERO
DO 50 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
ELSE
S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
$ ( WORK( I )+SAFE1 ) )
END IF
50 CONTINUE
BERR( J ) = S
*
* Test stopping criterion. Continue iterating if
* 1) The residual BERR(J) is larger than machine epsilon, and
* 2) BERR(J) decreased by at least a factor of 2 during the
* last iteration, and
* 3) At most ITMAX iterations tried.
*
IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
$ COUNT.LE.ITMAX ) THEN
*
* Update solution and try again.
*
CALL DGTTRS( TRANS, N, 1, DLF, DF, DUF, DU2, IPIV,
$ WORK( N+1 ), N, INFO )
CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
LSTRES = BERR( J )
COUNT = COUNT + 1
GO TO 20
END IF
*
* Bound error from formula
*
* norm(X - XTRUE) / norm(X) .le. FERR =
* norm( abs(inv(op(A)))*
* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
*
* where
* norm(Z) is the magnitude of the largest component of Z
* inv(op(A)) is the inverse of op(A)
* abs(Z) is the componentwise absolute value of the matrix or
* vector Z
* NZ is the maximum number of nonzeros in any row of A, plus 1
* EPS is machine epsilon
*
* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
* is incremented by SAFE1 if the i-th component of
* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
*
* Use DLACN2 to estimate the infinity-norm of the matrix
* inv(op(A)) * diag(W),
* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
*
DO 60 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
ELSE
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
END IF
60 CONTINUE
*
KASE = 0
70 CONTINUE
CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
$ KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Multiply by diag(W)*inv(op(A)**T).
*
CALL DGTTRS( TRANST, N, 1, DLF, DF, DUF, DU2, IPIV,
$ WORK( N+1 ), N, INFO )
DO 80 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
80 CONTINUE
ELSE
*
* Multiply by inv(op(A))*diag(W).
*
DO 90 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
90 CONTINUE
CALL DGTTRS( TRANSN, N, 1, DLF, DF, DUF, DU2, IPIV,
$ WORK( N+1 ), N, INFO )
END IF
GO TO 70
END IF
*
* Normalize error.
*
LSTRES = ZERO
DO 100 I = 1, N
LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
100 CONTINUE
IF( LSTRES.NE.ZERO )
$ FERR( J ) = FERR( J ) / LSTRES
*
110 CONTINUE
*
RETURN
*
* End of DGTRFS
*
END
SUBROUTINE DGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * )
* ..
*
* Purpose
* =======
*
* DGTSV solves the equation
*
* A*X = B,
*
* where A is an n by n tridiagonal matrix, by Gaussian elimination with
* partial pivoting.
*
* Note that the equation A'*X = B may be solved by interchanging the
* order of the arguments DU and DL.
*
* Arguments
* =========
*
* 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.
*
* DL (input/output) DOUBLE PRECISION array, dimension (N-1)
* On entry, DL must contain the (n-1) sub-diagonal elements of
* A.
*
* On exit, DL is overwritten by the (n-2) elements of the
* second super-diagonal of the upper triangular matrix U from
* the LU factorization of A, in DL(1), ..., DL(n-2).
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, D must contain the diagonal elements of A.
*
* On exit, D is overwritten by the n diagonal elements of U.
*
* DU (input/output) DOUBLE PRECISION array, dimension (N-1)
* On entry, DU must contain the (n-1) super-diagonal elements
* of A.
*
* On exit, DU is overwritten by the (n-1) elements of the first
* super-diagonal of U.
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the N by NRHS matrix of right hand side matrix B.
* On exit, if INFO = 0, the N by NRHS 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
* > 0: if INFO = i, U(i,i) is exactly zero, and the solution
* has not been computed. The factorization has not been
* completed unless i = N.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION FACT, TEMP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( NRHS.LT.0 ) THEN
INFO = -2
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGTSV ', -INFO )
RETURN
END IF
*
IF( N.EQ.0 )
$ RETURN
*
IF( NRHS.EQ.1 ) THEN
DO 10 I = 1, N - 2
IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
*
* No row interchange required
*
IF( D( I ).NE.ZERO ) THEN
FACT = DL( I ) / D( I )
D( I+1 ) = D( I+1 ) - FACT*DU( I )
B( I+1, 1 ) = B( I+1, 1 ) - FACT*B( I, 1 )
ELSE
INFO = I
RETURN
END IF
DL( I ) = ZERO
ELSE
*
* Interchange rows I and I+1
*
FACT = D( I ) / DL( I )
D( I ) = DL( I )
TEMP = D( I+1 )
D( I+1 ) = DU( I ) - FACT*TEMP
DL( I ) = DU( I+1 )
DU( I+1 ) = -FACT*DL( I )
DU( I ) = TEMP
TEMP = B( I, 1 )
B( I, 1 ) = B( I+1, 1 )
B( I+1, 1 ) = TEMP - FACT*B( I+1, 1 )
END IF
10 CONTINUE
IF( N.GT.1 ) THEN
I = N - 1
IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
IF( D( I ).NE.ZERO ) THEN
FACT = DL( I ) / D( I )
D( I+1 ) = D( I+1 ) - FACT*DU( I )
B( I+1, 1 ) = B( I+1, 1 ) - FACT*B( I, 1 )
ELSE
INFO = I
RETURN
END IF
ELSE
FACT = D( I ) / DL( I )
D( I ) = DL( I )
TEMP = D( I+1 )
D( I+1 ) = DU( I ) - FACT*TEMP
DU( I ) = TEMP
TEMP = B( I, 1 )
B( I, 1 ) = B( I+1, 1 )
B( I+1, 1 ) = TEMP - FACT*B( I+1, 1 )
END IF
END IF
IF( D( N ).EQ.ZERO ) THEN
INFO = N
RETURN
END IF
ELSE
DO 40 I = 1, N - 2
IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
*
* No row interchange required
*
IF( D( I ).NE.ZERO ) THEN
FACT = DL( I ) / D( I )
D( I+1 ) = D( I+1 ) - FACT*DU( I )
DO 20 J = 1, NRHS
B( I+1, J ) = B( I+1, J ) - FACT*B( I, J )
20 CONTINUE
ELSE
INFO = I
RETURN
END IF
DL( I ) = ZERO
ELSE
*
* Interchange rows I and I+1
*
FACT = D( I ) / DL( I )
D( I ) = DL( I )
TEMP = D( I+1 )
D( I+1 ) = DU( I ) - FACT*TEMP
DL( I ) = DU( I+1 )
DU( I+1 ) = -FACT*DL( I )
DU( I ) = TEMP
DO 30 J = 1, NRHS
TEMP = B( I, J )
B( I, J ) = B( I+1, J )
B( I+1, J ) = TEMP - FACT*B( I+1, J )
30 CONTINUE
END IF
40 CONTINUE
IF( N.GT.1 ) THEN
I = N - 1
IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
IF( D( I ).NE.ZERO ) THEN
FACT = DL( I ) / D( I )
D( I+1 ) = D( I+1 ) - FACT*DU( I )
DO 50 J = 1, NRHS
B( I+1, J ) = B( I+1, J ) - FACT*B( I, J )
50 CONTINUE
ELSE
INFO = I
RETURN
END IF
ELSE
FACT = D( I ) / DL( I )
D( I ) = DL( I )
TEMP = D( I+1 )
D( I+1 ) = DU( I ) - FACT*TEMP
DU( I ) = TEMP
DO 60 J = 1, NRHS
TEMP = B( I, J )
B( I, J ) = B( I+1, J )
B( I+1, J ) = TEMP - FACT*B( I+1, J )
60 CONTINUE
END IF
END IF
IF( D( N ).EQ.ZERO ) THEN
INFO = N
RETURN
END IF
END IF
*
* Back solve with the matrix U from the factorization.
*
IF( NRHS.LE.2 ) THEN
J = 1
70 CONTINUE
B( N, J ) = B( N, J ) / D( N )
IF( N.GT.1 )
$ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / D( N-1 )
DO 80 I = N - 2, 1, -1
B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DL( I )*
$ B( I+2, J ) ) / D( I )
80 CONTINUE
IF( J.LT.NRHS ) THEN
J = J + 1
GO TO 70
END IF
ELSE
DO 100 J = 1, NRHS
B( N, J ) = B( N, J ) / D( N )
IF( N.GT.1 )
$ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) /
$ D( N-1 )
DO 90 I = N - 2, 1, -1
B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DL( I )*
$ B( I+2, J ) ) / D( I )
90 CONTINUE
100 CONTINUE
END IF
*
RETURN
*
* End of DGTSV
*
END
SUBROUTINE DGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF,
$ DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR,
$ WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER FACT, TRANS
INTEGER INFO, LDB, LDX, N, NRHS
DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), IWORK( * )
DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DF( * ),
$ DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ),
$ FERR( * ), WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* DGTSVX uses the LU factorization to compute the solution to a real
* system of linear equations A * X = B or A**T * X = B,
* where A is a tridiagonal matrix of order N and X and B are N-by-NRHS
* matrices.
*
* Error bounds on the solution and a condition estimate are also
* provided.
*
* Description
* ===========
*
* The following steps are performed:
*
* 1. If FACT = 'N', the LU decomposition is used to factor the matrix A
* as A = L * U, where L is a product of permutation and unit lower
* bidiagonal matrices and U is upper triangular with nonzeros in
* only the main diagonal and first two superdiagonals.
*
* 2. If some U(i,i)=0, so that U is exactly singular, then the routine
* returns with INFO = i. Otherwise, the factored form of A is used
* to estimate the condition number of the matrix A. If the
* reciprocal of the condition number is less than machine precision,
* INFO = N+1 is returned as a warning, but the routine still goes on
* to solve for X and compute error bounds as described below.
*
* 3. The system of equations is solved for X using the factored form
* of A.
*
* 4. Iterative refinement is applied to improve the computed solution
* matrix and calculate error bounds and backward error estimates
* for it.
*
* Arguments
* =========
*
* FACT (input) CHARACTER*1
* Specifies whether or not the factored form of A has been
* supplied on entry.
* = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored
* form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV
* will not be modified.
* = 'N': The matrix will be copied to DLF, DF, and DUF
* and factored.
*
* 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**H * 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.
*
* DL (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) subdiagonal elements of A.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of A.
*
* DU (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) superdiagonal elements of A.
*
* DLF (input or output) DOUBLE PRECISION array, dimension (N-1)
* If FACT = 'F', then DLF is an input argument and on entry
* contains the (n-1) multipliers that define the matrix L from
* the LU factorization of A as computed by DGTTRF.
*
* If FACT = 'N', then DLF is an output argument and on exit
* contains the (n-1) multipliers that define the matrix L from
* the LU factorization of A.
*
* DF (input or output) DOUBLE PRECISION array, dimension (N)
* If FACT = 'F', then DF is an input argument and on entry
* contains the n diagonal elements of the upper triangular
* matrix U from the LU factorization of A.
*
* If FACT = 'N', then DF is an output argument and on exit
* contains the n diagonal elements of the upper triangular
* matrix U from the LU factorization of A.
*
* DUF (input or output) DOUBLE PRECISION array, dimension (N-1)
* If FACT = 'F', then DUF is an input argument and on entry
* contains the (n-1) elements of the first superdiagonal of U.
*
* If FACT = 'N', then DUF is an output argument and on exit
* contains the (n-1) elements of the first superdiagonal of U.
*
* DU2 (input or output) DOUBLE PRECISION array, dimension (N-2)
* If FACT = 'F', then DU2 is an input argument and on entry
* contains the (n-2) elements of the second superdiagonal of
* U.
*
* If FACT = 'N', then DU2 is an output argument and on exit
* contains the (n-2) elements of the second superdiagonal of
* U.
*
* IPIV (input or output) INTEGER array, dimension (N)
* If FACT = 'F', then IPIV is an input argument and on entry
* contains the pivot indices from the LU factorization of A as
* computed by DGTTRF.
*
* If FACT = 'N', then IPIV is an output argument and on exit
* contains the pivot indices from the LU factorization of A;
* row i of the matrix was interchanged with row IPIV(i).
* IPIV(i) will always be either i or i+1; IPIV(i) = i indicates
* a row interchange was not required.
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The N-by-NRHS right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* RCOND (output) DOUBLE PRECISION
* The estimate of the reciprocal condition number of the matrix
* A. If RCOND is less than the machine precision (in
* particular, if RCOND = 0), the matrix is singular to working
* precision. This condition is indicated by a return code of
* INFO > 0.
*
* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, and i is
* <= N: U(i,i) is exactly zero. The factorization
* has not been completed unless i = N, but the
* factor U is exactly singular, so the solution
* and error bounds could not be computed.
* RCOND = 0 is returned.
* = N+1: U is nonsingular, but RCOND is less than machine
* precision, meaning that the matrix is singular
* to working precision. Nevertheless, the
* solution and error bounds are computed because
* there are a number of situations where the
* computed solution can be more accurate than the
* value of RCOND would suggest.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOFACT, NOTRAN
CHARACTER NORM
DOUBLE PRECISION ANORM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANGT
EXTERNAL LSAME, DLAMCH, DLANGT
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGTCON, DGTRFS, DGTTRF, DGTTRS, DLACPY,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
INFO = 0
NOFACT = LSAME( FACT, 'N' )
NOTRAN = LSAME( TRANS, 'N' )
IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
$ LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.0 ) THEN
INFO = -4
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -14
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -16
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGTSVX', -INFO )
RETURN
END IF
*
IF( NOFACT ) THEN
*
* Compute the LU factorization of A.
*
CALL DCOPY( N, D, 1, DF, 1 )
IF( N.GT.1 ) THEN
CALL DCOPY( N-1, DL, 1, DLF, 1 )
CALL DCOPY( N-1, DU, 1, DUF, 1 )
END IF
CALL DGTTRF( N, DLF, DF, DUF, DU2, IPIV, INFO )
*
* Return if INFO is non-zero.
*
IF( INFO.GT.0 )THEN
RCOND = ZERO
RETURN
END IF
END IF
*
* Compute the norm of the matrix A.
*
IF( NOTRAN ) THEN
NORM = '1'
ELSE
NORM = 'I'
END IF
ANORM = DLANGT( NORM, N, DL, D, DU )
*
* Compute the reciprocal of the condition number of A.
*
CALL DGTCON( NORM, N, DLF, DF, DUF, DU2, IPIV, ANORM, RCOND, WORK,
$ IWORK, INFO )
*
* Compute the solution vectors X.
*
CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
CALL DGTTRS( TRANS, N, NRHS, DLF, DF, DUF, DU2, IPIV, X, LDX,
$ INFO )
*
* Use iterative refinement to improve the computed solutions and
* compute error bounds and backward error estimates for them.
*
CALL DGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV,
$ B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
*
* Set INFO = N+1 if the matrix is singular to working precision.
*
IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
$ INFO = N + 1
*
RETURN
*
* End of DGTSVX
*
END
SUBROUTINE DGTTRF( N, DL, D, DU, DU2, IPIV, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION D( * ), DL( * ), DU( * ), DU2( * )
* ..
*
* Purpose
* =======
*
* DGTTRF computes an LU factorization of a real tridiagonal matrix A
* using elimination with partial pivoting and row interchanges.
*
* The factorization has the form
* A = L * U
* where L is a product of permutation and unit lower bidiagonal
* matrices and U is upper triangular with nonzeros in only the main
* diagonal and first two superdiagonals.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix A.
*
* DL (input/output) DOUBLE PRECISION array, dimension (N-1)
* On entry, DL must contain the (n-1) sub-diagonal elements of
* A.
*
* On exit, DL is overwritten by the (n-1) multipliers that
* define the matrix L from the LU factorization of A.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, D must contain the diagonal elements of A.
*
* On exit, D is overwritten by the n diagonal elements of the
* upper triangular matrix U from the LU factorization of A.
*
* DU (input/output) DOUBLE PRECISION array, dimension (N-1)
* On entry, DU must contain the (n-1) super-diagonal elements
* of A.
*
* On exit, DU is overwritten by the (n-1) elements of the first
* super-diagonal of U.
*
* DU2 (output) DOUBLE PRECISION array, dimension (N-2)
* On exit, DU2 is overwritten by the (n-2) elements of the
* second super-diagonal of U.
*
* IPIV (output) INTEGER array, dimension (N)
* The pivot indices; for 1 <= i <= n, row i of the matrix was
* interchanged with row IPIV(i). IPIV(i) will always be either
* i or i+1; IPIV(i) = i indicates a row interchange was not
* required.
*
* 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 ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I
DOUBLE PRECISION FACT, TEMP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
CALL XERBLA( 'DGTTRF', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Initialize IPIV(i) = i and DU2(I) = 0
*
DO 10 I = 1, N
IPIV( I ) = I
10 CONTINUE
DO 20 I = 1, N - 2
DU2( I ) = ZERO
20 CONTINUE
*
DO 30 I = 1, N - 2
IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
*
* No row interchange required, eliminate DL(I)
*
IF( D( I ).NE.ZERO ) THEN
FACT = DL( I ) / D( I )
DL( I ) = FACT
D( I+1 ) = D( I+1 ) - FACT*DU( I )
END IF
ELSE
*
* Interchange rows I and I+1, eliminate DL(I)
*
FACT = D( I ) / DL( I )
D( I ) = DL( I )
DL( I ) = FACT
TEMP = DU( I )
DU( I ) = D( I+1 )
D( I+1 ) = TEMP - FACT*D( I+1 )
DU2( I ) = DU( I+1 )
DU( I+1 ) = -FACT*DU( I+1 )
IPIV( I ) = I + 1
END IF
30 CONTINUE
IF( N.GT.1 ) THEN
I = N - 1
IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
IF( D( I ).NE.ZERO ) THEN
FACT = DL( I ) / D( I )
DL( I ) = FACT
D( I+1 ) = D( I+1 ) - FACT*DU( I )
END IF
ELSE
FACT = D( I ) / DL( I )
D( I ) = DL( I )
DL( I ) = FACT
TEMP = DU( I )
DU( I ) = D( I+1 )
D( I+1 ) = TEMP - FACT*D( I+1 )
IPIV( I ) = I + 1
END IF
END IF
*
* Check for a zero on the diagonal of U.
*
DO 40 I = 1, N
IF( D( I ).EQ.ZERO ) THEN
INFO = I
GO TO 50
END IF
40 CONTINUE
50 CONTINUE
*
RETURN
*
* End of DGTTRF
*
END
SUBROUTINE DGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * )
* ..
*
* Purpose
* =======
*
* DGTTRS solves one of the systems of equations
* A*X = B or A'*X = B,
* with a tridiagonal matrix A using the LU factorization computed
* by DGTTRF.
*
* Arguments
* =========
*
* TRANS (input) CHARACTER*1
* Specifies the form of the system of equations.
* = 'N': A * X = B (No transpose)
* = 'T': A'* X = B (Transpose)
* = 'C': A'* X = B (Conjugate transpose = Transpose)
*
* N (input) INTEGER
* The order of the matrix A.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrix B. NRHS >= 0.
*
* DL (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) multipliers that define the matrix L from the
* LU factorization of A.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the upper triangular matrix U from
* the LU factorization of A.
*
* DU (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) elements of the first super-diagonal of U.
*
* DU2 (input) DOUBLE PRECISION array, dimension (N-2)
* The (n-2) elements of the second super-diagonal of U.
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices; for 1 <= i <= n, row i of the matrix was
* interchanged with row IPIV(i). IPIV(i) will always be either
* i or i+1; IPIV(i) = i indicates a row interchange was not
* required.
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the matrix of right hand side vectors B.
* On exit, B is overwritten by the solution vectors 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
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL NOTRAN
INTEGER ITRANS, J, JB, NB
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DGTTS2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
NOTRAN = ( TRANS.EQ.'N' .OR. TRANS.EQ.'n' )
IF( .NOT.NOTRAN .AND. .NOT.( TRANS.EQ.'T' .OR. TRANS.EQ.
$ 't' ) .AND. .NOT.( TRANS.EQ.'C' .OR. TRANS.EQ.'c' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGTTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
* Decode TRANS
*
IF( NOTRAN ) THEN
ITRANS = 0
ELSE
ITRANS = 1
END IF
*
* Determine the number of right-hand sides to solve at a time.
*
IF( NRHS.EQ.1 ) THEN
NB = 1
ELSE
NB = MAX( 1, ILAENV( 1, 'DGTTRS', TRANS, N, NRHS, -1, -1 ) )
END IF
*
IF( NB.GE.NRHS ) THEN
CALL DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )
ELSE
DO 10 J = 1, NRHS, NB
JB = MIN( NRHS-J+1, NB )
CALL DGTTS2( ITRANS, N, JB, DL, D, DU, DU2, IPIV, B( 1, J ),
$ LDB )
10 CONTINUE
END IF
*
* End of DGTTRS
*
END
SUBROUTINE DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER ITRANS, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * )
* ..
*
* Purpose
* =======
*
* DGTTS2 solves one of the systems of equations
* A*X = B or A'*X = B,
* with a tridiagonal matrix A using the LU factorization computed
* by DGTTRF.
*
* Arguments
* =========
*
* ITRANS (input) INTEGER
* Specifies the form of the system of equations.
* = 0: A * X = B (No transpose)
* = 1: A'* X = B (Transpose)
* = 2: A'* X = B (Conjugate transpose = Transpose)
*
* N (input) INTEGER
* The order of the matrix A.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrix B. NRHS >= 0.
*
* DL (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) multipliers that define the matrix L from the
* LU factorization of A.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the upper triangular matrix U from
* the LU factorization of A.
*
* DU (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) elements of the first super-diagonal of U.
*
* DU2 (input) DOUBLE PRECISION array, dimension (N-2)
* The (n-2) elements of the second super-diagonal of U.
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices; for 1 <= i <= n, row i of the matrix was
* interchanged with row IPIV(i). IPIV(i) will always be either
* i or i+1; IPIV(i) = i indicates a row interchange was not
* required.
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the matrix of right hand side vectors B.
* On exit, B is overwritten by the solution vectors X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, IP, J
DOUBLE PRECISION TEMP
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
IF( ITRANS.EQ.0 ) THEN
*
* Solve A*X = B using the LU factorization of A,
* overwriting each right hand side vector with its solution.
*
IF( NRHS.LE.1 ) THEN
J = 1
10 CONTINUE
*
* Solve L*x = b.
*
DO 20 I = 1, N - 1
IP = IPIV( I )
TEMP = B( I+1-IP+I, J ) - DL( I )*B( IP, J )
B( I, J ) = B( IP, J )
B( I+1, J ) = TEMP
20 CONTINUE
*
* Solve U*x = b.
*
B( N, J ) = B( N, J ) / D( N )
IF( N.GT.1 )
$ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) /
$ D( N-1 )
DO 30 I = N - 2, 1, -1
B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )*
$ B( I+2, J ) ) / D( I )
30 CONTINUE
IF( J.LT.NRHS ) THEN
J = J + 1
GO TO 10
END IF
ELSE
DO 60 J = 1, NRHS
*
* Solve L*x = b.
*
DO 40 I = 1, N - 1
IF( IPIV( I ).EQ.I ) THEN
B( I+1, J ) = B( I+1, J ) - DL( I )*B( I, J )
ELSE
TEMP = B( I, J )
B( I, J ) = B( I+1, J )
B( I+1, J ) = TEMP - DL( I )*B( I, J )
END IF
40 CONTINUE
*
* Solve U*x = b.
*
B( N, J ) = B( N, J ) / D( N )
IF( N.GT.1 )
$ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) /
$ D( N-1 )
DO 50 I = N - 2, 1, -1
B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )*
$ B( I+2, J ) ) / D( I )
50 CONTINUE
60 CONTINUE
END IF
ELSE
*
* Solve A' * X = B.
*
IF( NRHS.LE.1 ) THEN
*
* Solve U'*x = b.
*
J = 1
70 CONTINUE
B( 1, J ) = B( 1, J ) / D( 1 )
IF( N.GT.1 )
$ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 )
DO 80 I = 3, N
B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-DU2( I-2 )*
$ B( I-2, J ) ) / D( I )
80 CONTINUE
*
* Solve L'*x = b.
*
DO 90 I = N - 1, 1, -1
IP = IPIV( I )
TEMP = B( I, J ) - DL( I )*B( I+1, J )
B( I, J ) = B( IP, J )
B( IP, J ) = TEMP
90 CONTINUE
IF( J.LT.NRHS ) THEN
J = J + 1
GO TO 70
END IF
*
ELSE
DO 120 J = 1, NRHS
*
* Solve U'*x = b.
*
B( 1, J ) = B( 1, J ) / D( 1 )
IF( N.GT.1 )
$ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 )
DO 100 I = 3, N
B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-
$ DU2( I-2 )*B( I-2, J ) ) / D( I )
100 CONTINUE
DO 110 I = N - 1, 1, -1
IF( IPIV( I ).EQ.I ) THEN
B( I, J ) = B( I, J ) - DL( I )*B( I+1, J )
ELSE
TEMP = B( I+1, J )
B( I+1, J ) = B( I, J ) - DL( I )*TEMP
B( I, J ) = TEMP
END IF
110 CONTINUE
120 CONTINUE
END IF
END IF
*
* End of DGTTS2
*
END
SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT,
$ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK,
$ LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER COMPQ, COMPZ, JOB
INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION ALPHAI( * ), ALPHAR( * ), BETA( * ),
$ H( LDH, * ), Q( LDQ, * ), T( LDT, * ),
$ WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DHGEQZ computes the eigenvalues of a real matrix pair (H,T),
* where H is an upper Hessenberg matrix and T is upper triangular,
* using the double-shift QZ method.
* Matrix pairs of this type are produced by the reduction to
* generalized upper Hessenberg form of a real matrix pair (A,B):
*
* A = Q1*H*Z1**T, B = Q1*T*Z1**T,
*
* as computed by DGGHRD.
*
* If JOB='S', then the Hessenberg-triangular pair (H,T) is
* also reduced to generalized Schur form,
*
* H = Q*S*Z**T, T = Q*P*Z**T,
*
* where Q and Z are orthogonal matrices, P is an upper triangular
* matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2
* diagonal blocks.
*
* The 1-by-1 blocks correspond to real eigenvalues of the matrix pair
* (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of
* eigenvalues.
*
* Additionally, the 2-by-2 upper triangular diagonal blocks of P
* corresponding to 2-by-2 blocks of S are reduced to positive diagonal
* form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0,
* P(j,j) > 0, and P(j+1,j+1) > 0.
*
* Optionally, the orthogonal matrix Q from the generalized Schur
* factorization may be postmultiplied into an input matrix Q1, and the
* orthogonal matrix Z may be postmultiplied into an input matrix Z1.
* If Q1 and Z1 are the orthogonal matrices from DGGHRD that reduced
* the matrix pair (A,B) to generalized upper Hessenberg form, then the
* output matrices Q1*Q and Z1*Z are the orthogonal factors from the
* generalized Schur factorization of (A,B):
*
* A = (Q1*Q)*S*(Z1*Z)**T, B = (Q1*Q)*P*(Z1*Z)**T.
*
* To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently,
* of (A,B)) are computed as a pair of values (alpha,beta), where alpha is
* complex and beta real.
* If beta is nonzero, lambda = alpha / beta is an eigenvalue of the
* generalized nonsymmetric eigenvalue problem (GNEP)
* A*x = lambda*B*x
* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the
* alternate form of the GNEP
* mu*A*y = B*y.
* Real eigenvalues can be read directly from the generalized Schur
* form:
* alpha = S(i,i), beta = P(i,i).
*
* Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix
* Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973),
* pp. 241--256.
*
* Arguments
* =========
*
* JOB (input) CHARACTER*1
* = 'E': Compute eigenvalues only;
* = 'S': Compute eigenvalues and the Schur form.
*
* COMPQ (input) CHARACTER*1
* = 'N': Left Schur vectors (Q) are not computed;
* = 'I': Q is initialized to the unit matrix and the matrix Q
* of left Schur vectors of (H,T) is returned;
* = 'V': Q must contain an orthogonal matrix Q1 on entry and
* the product Q1*Q is returned.
*
* COMPZ (input) CHARACTER*1
* = 'N': Right Schur vectors (Z) are not computed;
* = 'I': Z is initialized to the unit matrix and the matrix Z
* of right Schur vectors of (H,T) is returned;
* = 'V': Z must contain an orthogonal matrix Z1 on entry and
* the product Z1*Z is returned.
*
* N (input) INTEGER
* The order of the matrices H, T, Q, and Z. N >= 0.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* ILO and IHI mark the rows and columns of H which are in
* Hessenberg form. It is assumed that A is already upper
* triangular in rows and columns 1:ILO-1 and IHI+1:N.
* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.
*
* H (input/output) DOUBLE PRECISION array, dimension (LDH, N)
* On entry, the N-by-N upper Hessenberg matrix H.
* On exit, if JOB = 'S', H contains the upper quasi-triangular
* matrix S from the generalized Schur factorization;
* 2-by-2 diagonal blocks (corresponding to complex conjugate
* pairs of eigenvalues) are returned in standard form, with
* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0.
* If JOB = 'E', the diagonal blocks of H match those of S, but
* the rest of H is unspecified.
*
* LDH (input) INTEGER
* The leading dimension of the array H. LDH >= max( 1, N ).
*
* T (input/output) DOUBLE PRECISION array, dimension (LDT, N)
* On entry, the N-by-N upper triangular matrix T.
* On exit, if JOB = 'S', T contains the upper triangular
* matrix P from the generalized Schur factorization;
* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S
* are reduced to positive diagonal form, i.e., if H(j+1,j) is
* non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and
* T(j+1,j+1) > 0.
* If JOB = 'E', the diagonal blocks of T match those of P, but
* the rest of T is unspecified.
*
* LDT (input) INTEGER
* The leading dimension of the array T. LDT >= max( 1, N ).
*
* ALPHAR (output) DOUBLE PRECISION array, dimension (N)
* The real parts of each scalar alpha defining an eigenvalue
* of GNEP.
*
* ALPHAI (output) DOUBLE PRECISION array, dimension (N)
* The imaginary parts of each scalar alpha defining an
* eigenvalue of GNEP.
* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
* positive, then the j-th and (j+1)-st eigenvalues are a
* complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j).
*
* BETA (output) DOUBLE PRECISION array, dimension (N)
* The scalars beta that define the eigenvalues of GNEP.
* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
* beta = BETA(j) represent the j-th eigenvalue of the matrix
* pair (A,B), in one of the forms lambda = alpha/beta or
* mu = beta/alpha. Since either lambda or mu may overflow,
* they should not, in general, be computed.
*
* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
* On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in
* the reduction of (A,B) to generalized Hessenberg form.
* On exit, if COMPZ = 'I', the orthogonal matrix of left Schur
* vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix
* of left Schur vectors of (A,B).
* Not referenced if COMPZ = 'N'.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= 1.
* If COMPQ='V' or 'I', then LDQ >= N.
*
* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
* On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in
* the reduction of (A,B) to generalized Hessenberg form.
* On exit, if COMPZ = 'I', the orthogonal matrix of
* right Schur vectors of (H,T), and if COMPZ = 'V', the
* orthogonal matrix of right Schur vectors of (A,B).
* Not referenced if COMPZ = 'N'.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1.
* If COMPZ='V' or 'I', then LDZ >= N.
*
* 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).
*
* 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
* = 1,...,N: the QZ iteration did not converge. (H,T) is not
* in Schur form, but ALPHAR(i), ALPHAI(i), and
* BETA(i), i=INFO+1,...,N should be correct.
* = N+1,...,2*N: the shift calculation failed. (H,T) is not
* in Schur form, but ALPHAR(i), ALPHAI(i), and
* BETA(i), i=INFO-N+1,...,N should be correct.
*
* Further Details
* ===============
*
* Iteration counters:
*
* JITER -- counts iterations.
* IITER -- counts iterations run since ILAST was last
* changed. This is therefore reset only when a 1-by-1 or
* 2-by-2 block deflates off the bottom.
*
* =====================================================================
*
* .. Parameters ..
* $ SAFETY = 1.0E+0 )
DOUBLE PRECISION HALF, ZERO, ONE, SAFETY
PARAMETER ( HALF = 0.5D+0, ZERO = 0.0D+0, ONE = 1.0D+0,
$ SAFETY = 1.0D+2 )
* ..
* .. Local Scalars ..
LOGICAL ILAZR2, ILAZRO, ILPIVT, ILQ, ILSCHR, ILZ,
$ LQUERY
INTEGER ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST,
$ ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER,
$ JR, MAXIT
DOUBLE PRECISION A11, A12, A1I, A1R, A21, A22, A2I, A2R, AD11,
$ AD11L, AD12, AD12L, AD21, AD21L, AD22, AD22L,
$ AD32L, AN, ANORM, ASCALE, ATOL, B11, B1A, B1I,
$ B1R, B22, B2A, B2I, B2R, BN, BNORM, BSCALE,
$ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL,
$ CQ, CR, CZ, ESHIFT, S, S1, S1INV, S2, SAFMAX,
$ SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T1,
$ TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, U12, U12L,
$ U2, ULP, VS, W11, W12, W21, W22, WABS, WI, WR,
$ WR2
* ..
* .. Local Arrays ..
DOUBLE PRECISION V( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANHS, DLAPY2, DLAPY3
EXTERNAL LSAME, DLAMCH, DLANHS, DLAPY2, DLAPY3
* ..
* .. External Subroutines ..
EXTERNAL DLAG2, DLARFG, DLARTG, DLASET, DLASV2, DROT,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Decode JOB, COMPQ, COMPZ
*
IF( LSAME( JOB, 'E' ) ) THEN
ILSCHR = .FALSE.
ISCHUR = 1
ELSE IF( LSAME( JOB, 'S' ) ) THEN
ILSCHR = .TRUE.
ISCHUR = 2
ELSE
ISCHUR = 0
END IF
*
IF( LSAME( COMPQ, 'N' ) ) THEN
ILQ = .FALSE.
ICOMPQ = 1
ELSE IF( LSAME( COMPQ, 'V' ) ) THEN
ILQ = .TRUE.
ICOMPQ = 2
ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
ILQ = .TRUE.
ICOMPQ = 3
ELSE
ICOMPQ = 0
END IF
*
IF( LSAME( COMPZ, 'N' ) ) THEN
ILZ = .FALSE.
ICOMPZ = 1
ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
ILZ = .TRUE.
ICOMPZ = 2
ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
ILZ = .TRUE.
ICOMPZ = 3
ELSE
ICOMPZ = 0
END IF
*
* Check Argument Values
*
INFO = 0
WORK( 1 ) = MAX( 1, N )
LQUERY = ( LWORK.EQ.-1 )
IF( ISCHUR.EQ.0 ) THEN
INFO = -1
ELSE IF( ICOMPQ.EQ.0 ) THEN
INFO = -2
ELSE IF( ICOMPZ.EQ.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( ILO.LT.1 ) THEN
INFO = -5
ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
INFO = -6
ELSE IF( LDH.LT.N ) THEN
INFO = -8
ELSE IF( LDT.LT.N ) THEN
INFO = -10
ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN
INFO = -15
ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN
INFO = -17
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -19
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DHGEQZ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 ) THEN
WORK( 1 ) = DBLE( 1 )
RETURN
END IF
*
* Initialize Q and Z
*
IF( ICOMPQ.EQ.3 )
$ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
IF( ICOMPZ.EQ.3 )
$ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
*
* Machine Constants
*
IN = IHI + 1 - ILO
SAFMIN = DLAMCH( 'S' )
SAFMAX = ONE / SAFMIN
ULP = DLAMCH( 'E' )*DLAMCH( 'B' )
ANORM = DLANHS( 'F', IN, H( ILO, ILO ), LDH, WORK )
BNORM = DLANHS( 'F', IN, T( ILO, ILO ), LDT, WORK )
ATOL = MAX( SAFMIN, ULP*ANORM )
BTOL = MAX( SAFMIN, ULP*BNORM )
ASCALE = ONE / MAX( SAFMIN, ANORM )
BSCALE = ONE / MAX( SAFMIN, BNORM )
*
* Set Eigenvalues IHI+1:N
*
DO 30 J = IHI + 1, N
IF( T( J, J ).LT.ZERO ) THEN
IF( ILSCHR ) THEN
DO 10 JR = 1, J
H( JR, J ) = -H( JR, J )
T( JR, J ) = -T( JR, J )
10 CONTINUE
ELSE
H( J, J ) = -H( J, J )
T( J, J ) = -T( J, J )
END IF
IF( ILZ ) THEN
DO 20 JR = 1, N
Z( JR, J ) = -Z( JR, J )
20 CONTINUE
END IF
END IF
ALPHAR( J ) = H( J, J )
ALPHAI( J ) = ZERO
BETA( J ) = T( J, J )
30 CONTINUE
*
* If IHI < ILO, skip QZ steps
*
IF( IHI.LT.ILO )
$ GO TO 380
*
* MAIN QZ ITERATION LOOP
*
* Initialize dynamic indices
*
* Eigenvalues ILAST+1:N have been found.
* Column operations modify rows IFRSTM:whatever.
* Row operations modify columns whatever:ILASTM.
*
* If only eigenvalues are being computed, then
* IFRSTM is the row of the last splitting row above row ILAST;
* this is always at least ILO.
* IITER counts iterations since the last eigenvalue was found,
* to tell when to use an extraordinary shift.
* MAXIT is the maximum number of QZ sweeps allowed.
*
ILAST = IHI
IF( ILSCHR ) THEN
IFRSTM = 1
ILASTM = N
ELSE
IFRSTM = ILO
ILASTM = IHI
END IF
IITER = 0
ESHIFT = ZERO
MAXIT = 30*( IHI-ILO+1 )
*
DO 360 JITER = 1, MAXIT
*
* Split the matrix if possible.
*
* Two tests:
* 1: H(j,j-1)=0 or j=ILO
* 2: T(j,j)=0
*
IF( ILAST.EQ.ILO ) THEN
*
* Special case: j=ILAST
*
GO TO 80
ELSE
IF( ABS( H( ILAST, ILAST-1 ) ).LE.ATOL ) THEN
H( ILAST, ILAST-1 ) = ZERO
GO TO 80
END IF
END IF
*
IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN
T( ILAST, ILAST ) = ZERO
GO TO 70
END IF
*
* General case: j unfl )
* __
* (sA - wB) ( CZ -SZ )
* ( SZ CZ )
*
C11R = S1*A11 - WR*B11
C11I = -WI*B11
C12 = S1*A12
C21 = S1*A21
C22R = S1*A22 - WR*B22
C22I = -WI*B22
*
IF( ABS( C11R )+ABS( C11I )+ABS( C12 ).GT.ABS( C21 )+
$ ABS( C22R )+ABS( C22I ) ) THEN
T1 = DLAPY3( C12, C11R, C11I )
CZ = C12 / T1
SZR = -C11R / T1
SZI = -C11I / T1
ELSE
CZ = DLAPY2( C22R, C22I )
IF( CZ.LE.SAFMIN ) THEN
CZ = ZERO
SZR = ONE
SZI = ZERO
ELSE
TEMPR = C22R / CZ
TEMPI = C22I / CZ
T1 = DLAPY2( CZ, C21 )
CZ = CZ / T1
SZR = -C21*TEMPR / T1
SZI = C21*TEMPI / T1
END IF
END IF
*
* Compute Givens rotation on left
*
* ( CQ SQ )
* ( __ ) A or B
* ( -SQ CQ )
*
AN = ABS( A11 ) + ABS( A12 ) + ABS( A21 ) + ABS( A22 )
BN = ABS( B11 ) + ABS( B22 )
WABS = ABS( WR ) + ABS( WI )
IF( S1*AN.GT.WABS*BN ) THEN
CQ = CZ*B11
SQR = SZR*B22
SQI = -SZI*B22
ELSE
A1R = CZ*A11 + SZR*A12
A1I = SZI*A12
A2R = CZ*A21 + SZR*A22
A2I = SZI*A22
CQ = DLAPY2( A1R, A1I )
IF( CQ.LE.SAFMIN ) THEN
CQ = ZERO
SQR = ONE
SQI = ZERO
ELSE
TEMPR = A1R / CQ
TEMPI = A1I / CQ
SQR = TEMPR*A2R + TEMPI*A2I
SQI = TEMPI*A2R - TEMPR*A2I
END IF
END IF
T1 = DLAPY3( CQ, SQR, SQI )
CQ = CQ / T1
SQR = SQR / T1
SQI = SQI / T1
*
* Compute diagonal elements of QBZ
*
TEMPR = SQR*SZR - SQI*SZI
TEMPI = SQR*SZI + SQI*SZR
B1R = CQ*CZ*B11 + TEMPR*B22
B1I = TEMPI*B22
B1A = DLAPY2( B1R, B1I )
B2R = CQ*CZ*B22 + TEMPR*B11
B2I = -TEMPI*B11
B2A = DLAPY2( B2R, B2I )
*
* Normalize so beta > 0, and Im( alpha1 ) > 0
*
BETA( ILAST-1 ) = B1A
BETA( ILAST ) = B2A
ALPHAR( ILAST-1 ) = ( WR*B1A )*S1INV
ALPHAI( ILAST-1 ) = ( WI*B1A )*S1INV
ALPHAR( ILAST ) = ( WR*B2A )*S1INV
ALPHAI( ILAST ) = -( WI*B2A )*S1INV
*
* Step 3: Go to next block -- exit if finished.
*
ILAST = IFIRST - 1
IF( ILAST.LT.ILO )
$ GO TO 380
*
* Reset counters
*
IITER = 0
ESHIFT = ZERO
IF( .NOT.ILSCHR ) THEN
ILASTM = ILAST
IF( IFRSTM.GT.ILAST )
$ IFRSTM = ILO
END IF
GO TO 350
ELSE
*
* Usual case: 3x3 or larger block, using Francis implicit
* double-shift
*
* 2
* Eigenvalue equation is w - c w + d = 0,
*
* -1 2 -1
* so compute 1st column of (A B ) - c A B + d
* using the formula in QZIT (from EISPACK)
*
* We assume that the block is at least 3x3
*
AD11 = ( ASCALE*H( ILAST-1, ILAST-1 ) ) /
$ ( BSCALE*T( ILAST-1, ILAST-1 ) )
AD21 = ( ASCALE*H( ILAST, ILAST-1 ) ) /
$ ( BSCALE*T( ILAST-1, ILAST-1 ) )
AD12 = ( ASCALE*H( ILAST-1, ILAST ) ) /
$ ( BSCALE*T( ILAST, ILAST ) )
AD22 = ( ASCALE*H( ILAST, ILAST ) ) /
$ ( BSCALE*T( ILAST, ILAST ) )
U12 = T( ILAST-1, ILAST ) / T( ILAST, ILAST )
AD11L = ( ASCALE*H( IFIRST, IFIRST ) ) /
$ ( BSCALE*T( IFIRST, IFIRST ) )
AD21L = ( ASCALE*H( IFIRST+1, IFIRST ) ) /
$ ( BSCALE*T( IFIRST, IFIRST ) )
AD12L = ( ASCALE*H( IFIRST, IFIRST+1 ) ) /
$ ( BSCALE*T( IFIRST+1, IFIRST+1 ) )
AD22L = ( ASCALE*H( IFIRST+1, IFIRST+1 ) ) /
$ ( BSCALE*T( IFIRST+1, IFIRST+1 ) )
AD32L = ( ASCALE*H( IFIRST+2, IFIRST+1 ) ) /
$ ( BSCALE*T( IFIRST+1, IFIRST+1 ) )
U12L = T( IFIRST, IFIRST+1 ) / T( IFIRST+1, IFIRST+1 )
*
V( 1 ) = ( AD11-AD11L )*( AD22-AD11L ) - AD12*AD21 +
$ AD21*U12*AD11L + ( AD12L-AD11L*U12L )*AD21L
V( 2 ) = ( ( AD22L-AD11L )-AD21L*U12L-( AD11-AD11L )-
$ ( AD22-AD11L )+AD21*U12 )*AD21L
V( 3 ) = AD32L*AD21L
*
ISTART = IFIRST
*
CALL DLARFG( 3, V( 1 ), V( 2 ), 1, TAU )
V( 1 ) = ONE
*
* Sweep
*
DO 290 J = ISTART, ILAST - 2
*
* All but last elements: use 3x3 Householder transforms.
*
* Zero (j-1)st column of A
*
IF( J.GT.ISTART ) THEN
V( 1 ) = H( J, J-1 )
V( 2 ) = H( J+1, J-1 )
V( 3 ) = H( J+2, J-1 )
*
CALL DLARFG( 3, H( J, J-1 ), V( 2 ), 1, TAU )
V( 1 ) = ONE
H( J+1, J-1 ) = ZERO
H( J+2, J-1 ) = ZERO
END IF
*
DO 230 JC = J, ILASTM
TEMP = TAU*( H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )*
$ H( J+2, JC ) )
H( J, JC ) = H( J, JC ) - TEMP
H( J+1, JC ) = H( J+1, JC ) - TEMP*V( 2 )
H( J+2, JC ) = H( J+2, JC ) - TEMP*V( 3 )
TEMP2 = TAU*( T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )*
$ T( J+2, JC ) )
T( J, JC ) = T( J, JC ) - TEMP2
T( J+1, JC ) = T( J+1, JC ) - TEMP2*V( 2 )
T( J+2, JC ) = T( J+2, JC ) - TEMP2*V( 3 )
230 CONTINUE
IF( ILQ ) THEN
DO 240 JR = 1, N
TEMP = TAU*( Q( JR, J )+V( 2 )*Q( JR, J+1 )+V( 3 )*
$ Q( JR, J+2 ) )
Q( JR, J ) = Q( JR, J ) - TEMP
Q( JR, J+1 ) = Q( JR, J+1 ) - TEMP*V( 2 )
Q( JR, J+2 ) = Q( JR, J+2 ) - TEMP*V( 3 )
240 CONTINUE
END IF
*
* Zero j-th column of B (see DLAGBC for details)
*
* Swap rows to pivot
*
ILPIVT = .FALSE.
TEMP = MAX( ABS( T( J+1, J+1 ) ), ABS( T( J+1, J+2 ) ) )
TEMP2 = MAX( ABS( T( J+2, J+1 ) ), ABS( T( J+2, J+2 ) ) )
IF( MAX( TEMP, TEMP2 ).LT.SAFMIN ) THEN
SCALE = ZERO
U1 = ONE
U2 = ZERO
GO TO 250
ELSE IF( TEMP.GE.TEMP2 ) THEN
W11 = T( J+1, J+1 )
W21 = T( J+2, J+1 )
W12 = T( J+1, J+2 )
W22 = T( J+2, J+2 )
U1 = T( J+1, J )
U2 = T( J+2, J )
ELSE
W21 = T( J+1, J+1 )
W11 = T( J+2, J+1 )
W22 = T( J+1, J+2 )
W12 = T( J+2, J+2 )
U2 = T( J+1, J )
U1 = T( J+2, J )
END IF
*
* Swap columns if nec.
*
IF( ABS( W12 ).GT.ABS( W11 ) ) THEN
ILPIVT = .TRUE.
TEMP = W12
TEMP2 = W22
W12 = W11
W22 = W21
W11 = TEMP
W21 = TEMP2
END IF
*
* LU-factor
*
TEMP = W21 / W11
U2 = U2 - TEMP*U1
W22 = W22 - TEMP*W12
W21 = ZERO
*
* Compute SCALE
*
SCALE = ONE
IF( ABS( W22 ).LT.SAFMIN ) THEN
SCALE = ZERO
U2 = ONE
U1 = -W12 / W11
GO TO 250
END IF
IF( ABS( W22 ).LT.ABS( U2 ) )
$ SCALE = ABS( W22 / U2 )
IF( ABS( W11 ).LT.ABS( U1 ) )
$ SCALE = MIN( SCALE, ABS( W11 / U1 ) )
*
* Solve
*
U2 = ( SCALE*U2 ) / W22
U1 = ( SCALE*U1-W12*U2 ) / W11
*
250 CONTINUE
IF( ILPIVT ) THEN
TEMP = U2
U2 = U1
U1 = TEMP
END IF
*
* Compute Householder Vector
*
T1 = SQRT( SCALE**2+U1**2+U2**2 )
TAU = ONE + SCALE / T1
VS = -ONE / ( SCALE+T1 )
V( 1 ) = ONE
V( 2 ) = VS*U1
V( 3 ) = VS*U2
*
* Apply transformations from the right.
*
DO 260 JR = IFRSTM, MIN( J+3, ILAST )
TEMP = TAU*( H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )*
$ H( JR, J+2 ) )
H( JR, J ) = H( JR, J ) - TEMP
H( JR, J+1 ) = H( JR, J+1 ) - TEMP*V( 2 )
H( JR, J+2 ) = H( JR, J+2 ) - TEMP*V( 3 )
260 CONTINUE
DO 270 JR = IFRSTM, J + 2
TEMP = TAU*( T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )*
$ T( JR, J+2 ) )
T( JR, J ) = T( JR, J ) - TEMP
T( JR, J+1 ) = T( JR, J+1 ) - TEMP*V( 2 )
T( JR, J+2 ) = T( JR, J+2 ) - TEMP*V( 3 )
270 CONTINUE
IF( ILZ ) THEN
DO 280 JR = 1, N
TEMP = TAU*( Z( JR, J )+V( 2 )*Z( JR, J+1 )+V( 3 )*
$ Z( JR, J+2 ) )
Z( JR, J ) = Z( JR, J ) - TEMP
Z( JR, J+1 ) = Z( JR, J+1 ) - TEMP*V( 2 )
Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 )
280 CONTINUE
END IF
T( J+1, J ) = ZERO
T( J+2, J ) = ZERO
290 CONTINUE
*
* Last elements: Use Givens rotations
*
* Rotations from the left
*
J = ILAST - 1
TEMP = H( J, J-1 )
CALL DLARTG( TEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) )
H( J+1, J-1 ) = ZERO
*
DO 300 JC = J, ILASTM
TEMP = C*H( J, JC ) + S*H( J+1, JC )
H( J+1, JC ) = -S*H( J, JC ) + C*H( J+1, JC )
H( J, JC ) = TEMP
TEMP2 = C*T( J, JC ) + S*T( J+1, JC )
T( J+1, JC ) = -S*T( J, JC ) + C*T( J+1, JC )
T( J, JC ) = TEMP2
300 CONTINUE
IF( ILQ ) THEN
DO 310 JR = 1, N
TEMP = C*Q( JR, J ) + S*Q( JR, J+1 )
Q( JR, J+1 ) = -S*Q( JR, J ) + C*Q( JR, J+1 )
Q( JR, J ) = TEMP
310 CONTINUE
END IF
*
* Rotations from the right.
*
TEMP = T( J+1, J+1 )
CALL DLARTG( TEMP, T( J+1, J ), C, S, T( J+1, J+1 ) )
T( J+1, J ) = ZERO
*
DO 320 JR = IFRSTM, ILAST
TEMP = C*H( JR, J+1 ) + S*H( JR, J )
H( JR, J ) = -S*H( JR, J+1 ) + C*H( JR, J )
H( JR, J+1 ) = TEMP
320 CONTINUE
DO 330 JR = IFRSTM, ILAST - 1
TEMP = C*T( JR, J+1 ) + S*T( JR, J )
T( JR, J ) = -S*T( JR, J+1 ) + C*T( JR, J )
T( JR, J+1 ) = TEMP
330 CONTINUE
IF( ILZ ) THEN
DO 340 JR = 1, N
TEMP = C*Z( JR, J+1 ) + S*Z( JR, J )
Z( JR, J ) = -S*Z( JR, J+1 ) + C*Z( JR, J )
Z( JR, J+1 ) = TEMP
340 CONTINUE
END IF
*
* End of Double-Shift code
*
END IF
*
GO TO 350
*
* End of iteration loop
*
350 CONTINUE
360 CONTINUE
*
* Drop-through = non-convergence
*
INFO = ILAST
GO TO 420
*
* Successful completion of all QZ steps
*
380 CONTINUE
*
* Set Eigenvalues 1:ILO-1
*
DO 410 J = 1, ILO - 1
IF( T( J, J ).LT.ZERO ) THEN
IF( ILSCHR ) THEN
DO 390 JR = 1, J
H( JR, J ) = -H( JR, J )
T( JR, J ) = -T( JR, J )
390 CONTINUE
ELSE
H( J, J ) = -H( J, J )
T( J, J ) = -T( J, J )
END IF
IF( ILZ ) THEN
DO 400 JR = 1, N
Z( JR, J ) = -Z( JR, J )
400 CONTINUE
END IF
END IF
ALPHAR( J ) = H( J, J )
ALPHAI( J ) = ZERO
BETA( J ) = T( J, J )
410 CONTINUE
*
* Normal Termination
*
INFO = 0
*
* Exit (other than argument error) -- return optimal workspace size
*
420 CONTINUE
WORK( 1 ) = DBLE( N )
RETURN
*
* End of DHGEQZ
*
END
SUBROUTINE DHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI,
$ VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL,
$ IFAILR, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER EIGSRC, INITV, SIDE
INTEGER INFO, LDH, LDVL, LDVR, M, MM, N
* ..
* .. Array Arguments ..
LOGICAL SELECT( * )
INTEGER IFAILL( * ), IFAILR( * )
DOUBLE PRECISION H( LDH, * ), VL( LDVL, * ), VR( LDVR, * ),
$ WI( * ), WORK( * ), WR( * )
* ..
*
* Purpose
* =======
*
* DHSEIN uses inverse iteration to find specified right and/or left
* eigenvectors of a real upper Hessenberg matrix H.
*
* The right eigenvector x and the left eigenvector y of the matrix H
* corresponding to an eigenvalue w are defined by:
*
* H * x = w * x, y**h * H = w * y**h
*
* where y**h denotes the conjugate transpose of the vector y.
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* = 'R': compute right eigenvectors only;
* = 'L': compute left eigenvectors only;
* = 'B': compute both right and left eigenvectors.
*
* EIGSRC (input) CHARACTER*1
* Specifies the source of eigenvalues supplied in (WR,WI):
* = 'Q': the eigenvalues were found using DHSEQR; thus, if
* H has zero subdiagonal elements, and so is
* block-triangular, then the j-th eigenvalue can be
* assumed to be an eigenvalue of the block containing
* the j-th row/column. This property allows DHSEIN to
* perform inverse iteration on just one diagonal block.
* = 'N': no assumptions are made on the correspondence
* between eigenvalues and diagonal blocks. In this
* case, DHSEIN must always perform inverse iteration
* using the whole matrix H.
*
* INITV (input) CHARACTER*1
* = 'N': no initial vectors are supplied;
* = 'U': user-supplied initial vectors are stored in the arrays
* VL and/or VR.
*
* SELECT (input/output) LOGICAL array, dimension (N)
* Specifies the eigenvectors to be computed. To select the
* real eigenvector corresponding to a real eigenvalue WR(j),
* SELECT(j) must be set to .TRUE.. To select the complex
* eigenvector corresponding to a complex eigenvalue
* (WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)),
* either SELECT(j) or SELECT(j+1) or both must be set to
* .TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is
* .FALSE..
*
* N (input) INTEGER
* The order of the matrix H. N >= 0.
*
* H (input) DOUBLE PRECISION array, dimension (LDH,N)
* The upper Hessenberg matrix H.
*
* LDH (input) INTEGER
* The leading dimension of the array H. LDH >= max(1,N).
*
* WR (input/output) DOUBLE PRECISION array, dimension (N)
* WI (input) DOUBLE PRECISION array, dimension (N)
* On entry, the real and imaginary parts of the eigenvalues of
* H; a complex conjugate pair of eigenvalues must be stored in
* consecutive elements of WR and WI.
* On exit, WR may have been altered since close eigenvalues
* are perturbed slightly in searching for independent
* eigenvectors.
*
* VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)
* On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must
* contain starting vectors for the inverse iteration for the
* left eigenvectors; the starting vector for each eigenvector
* must be in the same column(s) in which the eigenvector will
* be stored.
* On exit, if SIDE = 'L' or 'B', the left eigenvectors
* specified by SELECT will be stored consecutively in the
* columns of VL, in the same order as their eigenvalues. A
* complex eigenvector corresponding to a complex eigenvalue is
* stored in two consecutive columns, the first holding the real
* part and the second the imaginary part.
* If SIDE = 'R', VL is not referenced.
*
* LDVL (input) INTEGER
* The leading dimension of the array VL.
* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
*
* VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)
* On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must
* contain starting vectors for the inverse iteration for the
* right eigenvectors; the starting vector for each eigenvector
* must be in the same column(s) in which the eigenvector will
* be stored.
* On exit, if SIDE = 'R' or 'B', the right eigenvectors
* specified by SELECT will be stored consecutively in the
* columns of VR, in the same order as their eigenvalues. A
* complex eigenvector corresponding to a complex eigenvalue is
* stored in two consecutive columns, the first holding the real
* part and the second the imaginary part.
* If SIDE = 'L', VR is not referenced.
*
* LDVR (input) INTEGER
* The leading dimension of the array VR.
* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
*
* MM (input) INTEGER
* The number of columns in the arrays VL and/or VR. MM >= M.
*
* M (output) INTEGER
* The number of columns in the arrays VL and/or VR required to
* store the eigenvectors; each selected real eigenvector
* occupies one column and each selected complex eigenvector
* occupies two columns.
*
* WORK (workspace) DOUBLE PRECISION array, dimension ((N+2)*N)
*
* IFAILL (output) INTEGER array, dimension (MM)
* If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left
* eigenvector in the i-th column of VL (corresponding to the
* eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the
* eigenvector converged satisfactorily. If the i-th and (i+1)th
* columns of VL hold a complex eigenvector, then IFAILL(i) and
* IFAILL(i+1) are set to the same value.
* If SIDE = 'R', IFAILL is not referenced.
*
* IFAILR (output) INTEGER array, dimension (MM)
* If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right
* eigenvector in the i-th column of VR (corresponding to the
* eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the
* eigenvector converged satisfactorily. If the i-th and (i+1)th
* columns of VR hold a complex eigenvector, then IFAILR(i) and
* IFAILR(i+1) are set to the same value.
* If SIDE = 'L', IFAILR is not referenced.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, i is the number of eigenvectors which
* failed to converge; see IFAILL and IFAILR for further
* details.
*
* Further Details
* ===============
*
* Each eigenvector is normalized so that the element of largest
* magnitude has magnitude 1; here the magnitude of a complex number
* (x,y) is taken to be |x|+|y|.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL BOTHV, FROMQR, LEFTV, NOINIT, PAIR, RIGHTV
INTEGER I, IINFO, K, KL, KLN, KR, KSI, KSR, LDWORK
DOUBLE PRECISION BIGNUM, EPS3, HNORM, SMLNUM, ULP, UNFL, WKI,
$ WKR
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANHS
EXTERNAL LSAME, DLAMCH, DLANHS
* ..
* .. External Subroutines ..
EXTERNAL DLAEIN, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Decode and test the input parameters.
*
BOTHV = LSAME( SIDE, 'B' )
RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV
LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV
*
FROMQR = LSAME( EIGSRC, 'Q' )
*
NOINIT = LSAME( INITV, 'N' )
*
* Set M to the number of columns required to store the selected
* eigenvectors, and standardize the array SELECT.
*
M = 0
PAIR = .FALSE.
DO 10 K = 1, N
IF( PAIR ) THEN
PAIR = .FALSE.
SELECT( K ) = .FALSE.
ELSE
IF( WI( K ).EQ.ZERO ) THEN
IF( SELECT( K ) )
$ M = M + 1
ELSE
PAIR = .TRUE.
IF( SELECT( K ) .OR. SELECT( K+1 ) ) THEN
SELECT( K ) = .TRUE.
M = M + 2
END IF
END IF
END IF
10 CONTINUE
*
INFO = 0
IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
INFO = -1
ELSE IF( .NOT.FROMQR .AND. .NOT.LSAME( EIGSRC, 'N' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOINIT .AND. .NOT.LSAME( INITV, 'U' ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN
INFO = -11
ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN
INFO = -13
ELSE IF( MM.LT.M ) THEN
INFO = -14
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DHSEIN', -INFO )
RETURN
END IF
*
* Quick return if possible.
*
IF( N.EQ.0 )
$ RETURN
*
* Set machine-dependent constants.
*
UNFL = DLAMCH( 'Safe minimum' )
ULP = DLAMCH( 'Precision' )
SMLNUM = UNFL*( N / ULP )
BIGNUM = ( ONE-ULP ) / SMLNUM
*
LDWORK = N + 1
*
KL = 1
KLN = 0
IF( FROMQR ) THEN
KR = 0
ELSE
KR = N
END IF
KSR = 1
*
DO 120 K = 1, N
IF( SELECT( K ) ) THEN
*
* Compute eigenvector(s) corresponding to W(K).
*
IF( FROMQR ) THEN
*
* If affiliation of eigenvalues is known, check whether
* the matrix splits.
*
* Determine KL and KR such that 1 <= KL <= K <= KR <= N
* and H(KL,KL-1) and H(KR+1,KR) are zero (or KL = 1 or
* KR = N).
*
* Then inverse iteration can be performed with the
* submatrix H(KL:N,KL:N) for a left eigenvector, and with
* the submatrix H(1:KR,1:KR) for a right eigenvector.
*
DO 20 I = K, KL + 1, -1
IF( H( I, I-1 ).EQ.ZERO )
$ GO TO 30
20 CONTINUE
30 CONTINUE
KL = I
IF( K.GT.KR ) THEN
DO 40 I = K, N - 1
IF( H( I+1, I ).EQ.ZERO )
$ GO TO 50
40 CONTINUE
50 CONTINUE
KR = I
END IF
END IF
*
IF( KL.NE.KLN ) THEN
KLN = KL
*
* Compute infinity-norm of submatrix H(KL:KR,KL:KR) if it
* has not ben computed before.
*
HNORM = DLANHS( 'I', KR-KL+1, H( KL, KL ), LDH, WORK )
IF( HNORM.GT.ZERO ) THEN
EPS3 = HNORM*ULP
ELSE
EPS3 = SMLNUM
END IF
END IF
*
* Perturb eigenvalue if it is close to any previous
* selected eigenvalues affiliated to the submatrix
* H(KL:KR,KL:KR). Close roots are modified by EPS3.
*
WKR = WR( K )
WKI = WI( K )
60 CONTINUE
DO 70 I = K - 1, KL, -1
IF( SELECT( I ) .AND. ABS( WR( I )-WKR )+
$ ABS( WI( I )-WKI ).LT.EPS3 ) THEN
WKR = WKR + EPS3
GO TO 60
END IF
70 CONTINUE
WR( K ) = WKR
*
PAIR = WKI.NE.ZERO
IF( PAIR ) THEN
KSI = KSR + 1
ELSE
KSI = KSR
END IF
IF( LEFTV ) THEN
*
* Compute left eigenvector.
*
CALL DLAEIN( .FALSE., NOINIT, N-KL+1, H( KL, KL ), LDH,
$ WKR, WKI, VL( KL, KSR ), VL( KL, KSI ),
$ WORK, LDWORK, WORK( N*N+N+1 ), EPS3, SMLNUM,
$ BIGNUM, IINFO )
IF( IINFO.GT.0 ) THEN
IF( PAIR ) THEN
INFO = INFO + 2
ELSE
INFO = INFO + 1
END IF
IFAILL( KSR ) = K
IFAILL( KSI ) = K
ELSE
IFAILL( KSR ) = 0
IFAILL( KSI ) = 0
END IF
DO 80 I = 1, KL - 1
VL( I, KSR ) = ZERO
80 CONTINUE
IF( PAIR ) THEN
DO 90 I = 1, KL - 1
VL( I, KSI ) = ZERO
90 CONTINUE
END IF
END IF
IF( RIGHTV ) THEN
*
* Compute right eigenvector.
*
CALL DLAEIN( .TRUE., NOINIT, KR, H, LDH, WKR, WKI,
$ VR( 1, KSR ), VR( 1, KSI ), WORK, LDWORK,
$ WORK( N*N+N+1 ), EPS3, SMLNUM, BIGNUM,
$ IINFO )
IF( IINFO.GT.0 ) THEN
IF( PAIR ) THEN
INFO = INFO + 2
ELSE
INFO = INFO + 1
END IF
IFAILR( KSR ) = K
IFAILR( KSI ) = K
ELSE
IFAILR( KSR ) = 0
IFAILR( KSI ) = 0
END IF
DO 100 I = KR + 1, N
VR( I, KSR ) = ZERO
100 CONTINUE
IF( PAIR ) THEN
DO 110 I = KR + 1, N
VR( I, KSI ) = ZERO
110 CONTINUE
END IF
END IF
*
IF( PAIR ) THEN
KSR = KSR + 2
ELSE
KSR = KSR + 1
END IF
END IF
120 CONTINUE
*
RETURN
*
* End of DHSEIN
*
END
SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z,
$ LDZ, WORK, LWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N
CHARACTER COMPZ, JOB
* ..
* .. Array Arguments ..
DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ),
$ Z( LDZ, * )
* ..
* Purpose
* =======
*
* DHSEQR computes the eigenvalues of a Hessenberg matrix H
* and, optionally, the matrices T and Z from the Schur decomposition
* H = Z T Z**T, where T is an upper quasi-triangular matrix (the
* Schur form), and Z is the orthogonal matrix of Schur vectors.
*
* Optionally Z may be postmultiplied into an input orthogonal
* matrix Q so that this routine can give the Schur factorization
* of a matrix A which has been reduced to the Hessenberg form H
* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.
*
* Arguments
* =========
*
* JOB (input) CHARACTER*1
* = 'E': compute eigenvalues only;
* = 'S': compute eigenvalues and the Schur form T.
*
* COMPZ (input) CHARACTER*1
* = 'N': no Schur vectors are computed;
* = 'I': Z is initialized to the unit matrix and the matrix Z
* of Schur vectors of H is returned;
* = 'V': Z must contain an orthogonal matrix Q on entry, and
* the product Q*Z is returned.
*
* N (input) INTEGER
* The order of the matrix H. N .GE. 0.
*
* 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. ILO and IHI are normally
* set by a previous call to DGEBAL, and then passed to DGEHRD
* when the matrix output by DGEBAL is reduced to Hessenberg
* form. Otherwise ILO and IHI should be set to 1 and N
* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
* If N = 0, then ILO = 1 and IHI = 0.
*
* H (input/output) DOUBLE PRECISION array, dimension (LDH,N)
* On entry, the upper Hessenberg matrix H.
* On exit, if INFO = 0 and JOB = 'S', then H contains the
* upper quasi-triangular matrix T from the Schur decomposition
* (the Schur form); 2-by-2 diagonal blocks (corresponding to
* complex conjugate pairs of eigenvalues) are returned in
* standard form, with H(i,i) = H(i+1,i+1) and
* H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and JOB = 'E', the
* contents of H are unspecified on exit. (The output value of
* H when INFO.GT.0 is given under the description of INFO
* below.)
*
* Unlike earlier versions of DHSEQR, this subroutine may
* explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1
* or j = IHI+1, IHI+2, ... N.
*
* LDH (input) INTEGER
* The leading dimension of the array H. LDH .GE. max(1,N).
*
* WR (output) DOUBLE PRECISION array, dimension (N)
* WI (output) DOUBLE PRECISION array, dimension (N)
* The real and imaginary parts, respectively, of the computed
* eigenvalues. If two eigenvalues are computed as a complex
* conjugate pair, they are stored in consecutive elements of
* WR and WI, say the i-th and (i+1)th, with WI(i) .GT. 0 and
* WI(i+1) .LT. 0. If JOB = 'S', the eigenvalues are stored in
* the same order as on the diagonal of the Schur form returned
* in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2
* diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and
* WI(i+1) = -WI(i).
*
* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
* If COMPZ = 'N', Z is not referenced.
* If COMPZ = 'I', on entry Z need not be set and on exit,
* if INFO = 0, Z contains the orthogonal matrix Z of the Schur
* vectors of H. If COMPZ = 'V', on entry Z must contain an
* N-by-N matrix Q, which is assumed to be equal to the unit
* matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,
* if INFO = 0, Z contains Q*Z.
* Normally Q is the orthogonal matrix generated by DORGHR
* after the call to DGEHRD which formed the Hessenberg matrix
* H. (The output value of Z when INFO.GT.0 is given under
* the description of INFO below.)
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. if COMPZ = 'I' or
* COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1.
*
* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns an estimate of
* the optimal value for LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK. LWORK .GE. max(1,N)
* is sufficient, but LWORK typically as large as 6*N may
* be required for optimal performance. A workspace query
* to determine the optimal workspace size is recommended.
*
* If LWORK = -1, then DHSEQR does a workspace query.
* In this case, DHSEQR checks the input parameters and
* estimates the optimal workspace size for the given
* values of N, ILO and IHI. The estimate is returned
* in WORK(1). No error message related to LWORK is
* issued by XERBLA. Neither H nor Z are accessed.
*
*
* INFO (output) INTEGER
* = 0: successful exit
* .LT. 0: if INFO = -i, the i-th argument had an illegal
* value
* .GT. 0: if INFO = i, DHSEQR failed to compute all of
* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
* and WI contain those eigenvalues which have been
* successfully computed. (Failures are rare.)
*
* If INFO .GT. 0 and JOB = 'E', then on exit, the
* remaining unconverged eigenvalues are the eigen-
* values of the upper Hessenberg matrix rows and
* columns ILO through INFO of the final, output
* value of H.
*
* If INFO .GT. 0 and JOB = 'S', then on exit
*
* (*) (initial value of H)*U = U*(final value of H)
*
* where U is an orthogonal matrix. The final
* value of H is upper Hessenberg and quasi-triangular
* in rows and columns INFO+1 through IHI.
*
* If INFO .GT. 0 and COMPZ = 'V', then on exit
*
* (final value of Z) = (initial value of Z)*U
*
* where U is the orthogonal matrix in (*) (regard-
* less of the value of JOB.)
*
* If INFO .GT. 0 and COMPZ = 'I', then on exit
* (final value of Z) = U
* where U is the orthogonal matrix in (*) (regard-
* less of the value of JOB.)
*
* If INFO .GT. 0 and COMPZ = 'N', then Z is not
* accessed.
*
* ================================================================
* Default values supplied by
* ILAENV(ISPEC,'DHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).
* It is suggested that these defaults be adjusted in order
* to attain best performance in each particular
* computational environment.
*
* ISPEC=1: The DLAHQR vs DLAQR0 crossover point.
* Default: 75. (Must be at least 11.)
*
* ISPEC=2: Recommended deflation window size.
* This depends on ILO, IHI and NS. NS is the
* number of simultaneous shifts returned
* by ILAENV(ISPEC=4). (See ISPEC=4 below.)
* The default for (IHI-ILO+1).LE.500 is NS.
* The default for (IHI-ILO+1).GT.500 is 3*NS/2.
*
* ISPEC=3: Nibble crossover point. (See ILAENV for
* details.) Default: 14% of deflation window
* size.
*
* ISPEC=4: Number of simultaneous shifts, NS, in
* a multi-shift QR iteration.
*
* If IHI-ILO+1 is ...
*
* greater than ...but less ... the
* or equal to ... than default is
*
* 1 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 some or all matrices of this order
* are passed to the implicit double shift routine
* DLAHQR and NS is ignored. See ISPEC=1 above
* and comments in IPARM for details.
*
* The asterisks (**) indicate an ad-hoc
* function of N increasing from 10 to 64.
*
* ISPEC=5: Select structured matrix multiply.
* (See ILAENV for details.) Default: 3.
*
* ================================================================
* Based on contributions by
* Karen Braman and Ralph Byers, Department of Mathematics,
* University of Kansas, USA
*
* ================================================================
* References:
* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
* Performance, SIAM Journal of Matrix Analysis, volume 23, pages
* 929--947, 2002.
*
* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
* Algorithm Part II: Aggressive Early Deflation, SIAM Journal
* of Matrix Analysis, volume 23, pages 948--973, 2002.
*
* ================================================================
* .. Parameters ..
*
* ==== Matrices of order NTINY or smaller must be processed by
* . DLAHQR because of insufficient subdiagonal scratch space.
* . (This is a hard limit.) ====
*
* ==== NL allocates some local workspace to help small matrices
* . through a rare DLAHQR failure. NL .GT. NTINY = 11 is
* . required and NL .LE. NMIN = ILAENV(ISPEC=1,...) is recom-
* . mended. (The default value of NMIN is 75.) Using NL = 49
* . allows up to six simultaneous shifts and a 16-by-16
* . deflation window. ====
*
INTEGER NTINY
PARAMETER ( NTINY = 11 )
INTEGER NL
PARAMETER ( NL = 49 )
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 )
* ..
* .. Local Arrays ..
DOUBLE PRECISION HL( NL, NL ), WORKL( NL )
* ..
* .. Local Scalars ..
INTEGER I, KBOT, NMIN
LOGICAL INITZ, LQUERY, WANTT, WANTZ
* ..
* .. External Functions ..
INTEGER ILAENV
LOGICAL LSAME
EXTERNAL ILAENV, LSAME
* ..
* .. External Subroutines ..
EXTERNAL DLACPY, DLAHQR, DLAQR0, DLASET, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
* ==== Decode and check the input parameters. ====
*
WANTT = LSAME( JOB, 'S' )
INITZ = LSAME( COMPZ, 'I' )
WANTZ = INITZ .OR. LSAME( COMPZ, 'V' )
WORK( 1 ) = DBLE( MAX( 1, N ) )
LQUERY = LWORK.EQ.-1
*
INFO = 0
IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN
INFO = -1
ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
INFO = -5
ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN
INFO = -11
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
*
IF( INFO.NE.0 ) THEN
*
* ==== Quick return in case of invalid argument. ====
*
CALL XERBLA( 'DHSEQR', -INFO )
RETURN
*
ELSE IF( N.EQ.0 ) THEN
*
* ==== Quick return in case N = 0; nothing to do. ====
*
RETURN
*
ELSE IF( LQUERY ) THEN
*
* ==== Quick return in case of a workspace query ====
*
CALL DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO,
$ IHI, Z, LDZ, WORK, LWORK, INFO )
* ==== Ensure reported workspace size is backward-compatible with
* . previous LAPACK versions. ====
WORK( 1 ) = MAX( DBLE( MAX( 1, N ) ), WORK( 1 ) )
RETURN
*
ELSE
*
* ==== copy eigenvalues isolated by DGEBAL ====
*
DO 10 I = 1, ILO - 1
WR( I ) = H( I, I )
WI( I ) = ZERO
10 CONTINUE
DO 20 I = IHI + 1, N
WR( I ) = H( I, I )
WI( I ) = ZERO
20 CONTINUE
*
* ==== Initialize Z, if requested ====
*
IF( INITZ )
$ CALL DLASET( 'A', N, N, ZERO, ONE, Z, LDZ )
*
* ==== Quick return if possible ====
*
IF( ILO.EQ.IHI ) THEN
WR( ILO ) = H( ILO, ILO )
WI( ILO ) = ZERO
RETURN
END IF
*
* ==== DLAHQR/DLAQR0 crossover point ====
*
NMIN = ILAENV( 12, 'DHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N,
$ ILO, IHI, LWORK )
NMIN = MAX( NTINY, NMIN )
*
* ==== DLAQR0 for big matrices; DLAHQR for small ones ====
*
IF( N.GT.NMIN ) THEN
CALL DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO,
$ IHI, Z, LDZ, WORK, LWORK, INFO )
ELSE
*
* ==== Small matrix ====
*
CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO,
$ IHI, Z, LDZ, INFO )
*
IF( INFO.GT.0 ) THEN
*
* ==== A rare DLAHQR failure! DLAQR0 sometimes succeeds
* . when DLAHQR fails. ====
*
KBOT = INFO
*
IF( N.GE.NL ) THEN
*
* ==== Larger matrices have enough subdiagonal scratch
* . space to call DLAQR0 directly. ====
*
CALL DLAQR0( WANTT, WANTZ, N, ILO, KBOT, H, LDH, WR,
$ WI, ILO, IHI, Z, LDZ, WORK, LWORK, INFO )
*
ELSE
*
* ==== Tiny matrices don't have enough subdiagonal
* . scratch space to benefit from DLAQR0. Hence,
* . tiny matrices must be copied into a larger
* . array before calling DLAQR0. ====
*
CALL DLACPY( 'A', N, N, H, LDH, HL, NL )
HL( N+1, N ) = ZERO
CALL DLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ),
$ NL )
CALL DLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, WR,
$ WI, ILO, IHI, Z, LDZ, WORKL, NL, INFO )
IF( WANTT .OR. INFO.NE.0 )
$ CALL DLACPY( 'A', N, N, HL, NL, H, LDH )
END IF
END IF
END IF
*
* ==== Clear out the trash, if necessary. ====
*
IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 )
$ CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH )
*
* ==== Ensure reported workspace size is backward-compatible with
* . previous LAPACK versions. ====
*
WORK( 1 ) = MAX( DBLE( MAX( 1, N ) ), WORK( 1 ) )
END IF
*
* ==== End of DHSEQR ====
*
END
LOGICAL FUNCTION DISNAN(DIN)
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
DOUBLE PRECISION DIN
* ..
*
* Purpose
* =======
*
* DISNAN returns .TRUE. if its argument is NaN, and .FALSE.
* otherwise. To be replaced by the Fortran 2003 intrinsic in the
* future.
*
* Arguments
* =========
*
* DIN (input) DOUBLE PRECISION
* Input to test for NaN.
*
* =====================================================================
*
* .. External Functions ..
LOGICAL DLAISNAN
EXTERNAL DLAISNAN
* ..
* .. Executable Statements ..
DISNAN = DLAISNAN(DIN,DIN)
RETURN
END
SUBROUTINE DLABAD( SMALL, LARGE )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
DOUBLE PRECISION LARGE, SMALL
* ..
*
* Purpose
* =======
*
* DLABAD takes as input the values computed by DLAMCH for underflow and
* overflow, and returns the square root of each of these values if the
* log of LARGE is sufficiently large. This subroutine is intended to
* identify machines with a large exponent range, such as the Crays, and
* redefine the underflow and overflow limits to be the square roots of
* the values computed by DLAMCH. This subroutine is needed because
* DLAMCH does not compensate for poor arithmetic in the upper half of
* the exponent range, as is found on a Cray.
*
* Arguments
* =========
*
* SMALL (input/output) DOUBLE PRECISION
* On entry, the underflow threshold as computed by DLAMCH.
* On exit, if LOG10(LARGE) is sufficiently large, the square
* root of SMALL, otherwise unchanged.
*
* LARGE (input/output) DOUBLE PRECISION
* On entry, the overflow threshold as computed by DLAMCH.
* On exit, if LOG10(LARGE) is sufficiently large, the square
* root of LARGE, otherwise unchanged.
*
* =====================================================================
*
* .. Intrinsic Functions ..
INTRINSIC LOG10, SQRT
* ..
* .. Executable Statements ..
*
* If it looks like we're on a Cray, take the square root of
* SMALL and LARGE to avoid overflow and underflow problems.
*
IF( LOG10( LARGE ).GT.2000.D0 ) THEN
SMALL = SQRT( SMALL )
LARGE = SQRT( LARGE )
END IF
*
RETURN
*
* End of DLABAD
*
END
SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y,
$ LDY )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDX, LDY, M, N, NB
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ),
$ TAUQ( * ), X( LDX, * ), Y( LDY, * )
* ..
*
* Purpose
* =======
*
* DLABRD reduces the first NB rows and columns of a real general
* m by n matrix A to upper or lower bidiagonal form by an orthogonal
* transformation Q' * A * P, and returns the matrices X and Y which
* are needed to apply the transformation to the unreduced part of A.
*
* If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower
* bidiagonal form.
*
* This is an auxiliary routine called by DGEBRD
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows in the matrix A.
*
* N (input) INTEGER
* The number of columns in the matrix A.
*
* NB (input) INTEGER
* The number of leading rows and columns of A to be reduced.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the m by n general matrix to be reduced.
* On exit, the first NB rows and columns of the matrix are
* overwritten; the rest of the array is unchanged.
* If m >= n, elements on and below the diagonal in the first NB
* columns, with the array TAUQ, represent the orthogonal
* matrix Q as a product of elementary reflectors; and
* elements above the diagonal in the first NB rows, with the
* array TAUP, represent the orthogonal matrix P as a product
* of elementary reflectors.
* If m < n, elements below the diagonal in the first NB
* columns, with the array TAUQ, represent the orthogonal
* matrix Q as a product of elementary reflectors, and
* elements on and above the diagonal in the first NB rows,
* with the array TAUP, represent the orthogonal matrix P as
* a product of elementary reflectors.
* See Further Details.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* D (output) DOUBLE PRECISION array, dimension (NB)
* The diagonal elements of the first NB rows and columns of
* the reduced matrix. D(i) = A(i,i).
*
* E (output) DOUBLE PRECISION array, dimension (NB)
* The off-diagonal elements of the first NB rows and columns of
* the reduced matrix.
*
* TAUQ (output) DOUBLE PRECISION array dimension (NB)
* The scalar factors of the elementary reflectors which
* represent the orthogonal matrix Q. See Further Details.
*
* TAUP (output) DOUBLE PRECISION array, dimension (NB)
* The scalar factors of the elementary reflectors which
* represent the orthogonal matrix P. See Further Details.
*
* X (output) DOUBLE PRECISION array, dimension (LDX,NB)
* The m-by-nb matrix X required to update the unreduced part
* of A.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= M.
*
* Y (output) DOUBLE PRECISION array, dimension (LDY,NB)
* The n-by-nb matrix Y required to update the unreduced part
* of A.
*
* LDY (input) INTEGER
* The leading dimension of the array Y. LDY >= N.
*
* Further Details
* ===============
*
* The matrices Q and P are represented as products of elementary
* reflectors:
*
* Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb)
*
* Each H(i) and G(i) has the form:
*
* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
*
* where tauq and taup are real scalars, and v and u are real vectors.
*
* If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in
* A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in
* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
*
* If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in
* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in
* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
*
* The elements of the vectors v and u together form the m-by-nb matrix
* V and the nb-by-n matrix U' which are needed, with X and Y, to apply
* the transformation to the unreduced part of the matrix, using a block
* update of the form: A := A - V*Y' - X*U'.
*
* The contents of A on exit are illustrated by the following examples
* with nb = 2:
*
* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
*
* ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 )
* ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 )
* ( v1 v2 a a a ) ( v1 1 a a a a )
* ( v1 v2 a a a ) ( v1 v2 a a a a )
* ( v1 v2 a a a ) ( v1 v2 a a a a )
* ( v1 v2 a a a )
*
* where a denotes an element of the original matrix which is unchanged,
* vi denotes an element of the vector defining H(i), and ui an element
* of the vector defining G(i).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
INTEGER I
* ..
* .. External Subroutines ..
EXTERNAL DGEMV, DLARFG, DSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
IF( M.GE.N ) THEN
*
* Reduce to upper bidiagonal form
*
DO 10 I = 1, NB
*
* Update A(i:m,i)
*
CALL DGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ),
$ LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 )
CALL DGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ),
$ LDX, A( 1, I ), 1, ONE, A( I, I ), 1 )
*
* Generate reflection Q(i) to annihilate A(i+1:m,i)
*
CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
$ TAUQ( I ) )
D( I ) = A( I, I )
IF( I.LT.N ) THEN
A( I, I ) = ONE
*
* Compute Y(i+1:n,i)
*
CALL DGEMV( 'Transpose', M-I+1, N-I, ONE, A( I, I+1 ),
$ LDA, A( I, I ), 1, ZERO, Y( I+1, I ), 1 )
CALL DGEMV( 'Transpose', M-I+1, I-1, ONE, A( I, 1 ), LDA,
$ A( I, I ), 1, ZERO, Y( 1, I ), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
$ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
CALL DGEMV( 'Transpose', M-I+1, I-1, ONE, X( I, 1 ), LDX,
$ A( I, I ), 1, ZERO, Y( 1, I ), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ),
$ LDA, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
CALL DSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
*
* Update A(i,i+1:n)
*
CALL DGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ),
$ LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA )
CALL DGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ),
$ LDA, X( I, 1 ), LDX, ONE, A( I, I+1 ), LDA )
*
* Generate reflection P(i) to annihilate A(i,i+2:n)
*
CALL DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ),
$ LDA, TAUP( I ) )
E( I ) = A( I, I+1 )
A( I, I+1 ) = ONE
*
* Compute X(i+1:m,i)
*
CALL DGEMV( 'No transpose', M-I, N-I, ONE, A( I+1, I+1 ),
$ LDA, A( I, I+1 ), LDA, ZERO, X( I+1, I ), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, Y( I+1, 1 ), LDY,
$ A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 )
CALL DGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ),
$ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
CALL DGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ),
$ LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 )
CALL DGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
$ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
CALL DSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
END IF
10 CONTINUE
ELSE
*
* Reduce to lower bidiagonal form
*
DO 20 I = 1, NB
*
* Update A(i,i:n)
*
CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ),
$ LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA )
CALL DGEMV( 'Transpose', I-1, N-I+1, -ONE, A( 1, I ), LDA,
$ X( I, 1 ), LDX, ONE, A( I, I ), LDA )
*
* Generate reflection P(i) to annihilate A(i,i+1:n)
*
CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA,
$ TAUP( I ) )
D( I ) = A( I, I )
IF( I.LT.M ) THEN
A( I, I ) = ONE
*
* Compute X(i+1:m,i)
*
CALL DGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ),
$ LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Y( I, 1 ), LDY,
$ A( I, I ), LDA, ZERO, X( 1, I ), 1 )
CALL DGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
$ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
CALL DGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ),
$ LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 )
CALL DGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
$ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
CALL DSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
*
* Update A(i+1:m,i)
*
CALL DGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
$ LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 )
CALL DGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ),
$ LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 )
*
* Generate reflection Q(i) to annihilate A(i+2:m,i)
*
CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1,
$ TAUQ( I ) )
E( I ) = A( I+1, I )
A( I+1, I ) = ONE
*
* Compute Y(i+1:n,i)
*
CALL DGEMV( 'Transpose', M-I, N-I, ONE, A( I+1, I+1 ),
$ LDA, A( I+1, I ), 1, ZERO, Y( I+1, I ), 1 )
CALL DGEMV( 'Transpose', M-I, I-1, ONE, A( I+1, 1 ), LDA,
$ A( I+1, I ), 1, ZERO, Y( 1, I ), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
$ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
CALL DGEMV( 'Transpose', M-I, I, ONE, X( I+1, 1 ), LDX,
$ A( I+1, I ), 1, ZERO, Y( 1, I ), 1 )
CALL DGEMV( 'Transpose', I, N-I, -ONE, A( 1, I+1 ), LDA,
$ Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
CALL DSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
END IF
20 CONTINUE
END IF
RETURN
*
* End of DLABRD
*
END
SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KASE, N
DOUBLE PRECISION EST
* ..
* .. Array Arguments ..
INTEGER ISGN( * ), ISAVE( 3 )
DOUBLE PRECISION V( * ), X( * )
* ..
*
* Purpose
* =======
*
* DLACN2 estimates the 1-norm of a square, real matrix A.
* Reverse communication is used for evaluating matrix-vector products.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix. N >= 1.
*
* V (workspace) DOUBLE PRECISION array, dimension (N)
* On the final return, V = A*W, where EST = norm(V)/norm(W)
* (W is not returned).
*
* X (input/output) DOUBLE PRECISION array, dimension (N)
* On an intermediate return, X should be overwritten by
* A * X, if KASE=1,
* A' * X, if KASE=2,
* and DLACN2 must be re-called with all the other parameters
* unchanged.
*
* ISGN (workspace) INTEGER array, dimension (N)
*
* EST (input/output) DOUBLE PRECISION
* On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be
* unchanged from the previous call to DLACN2.
* On exit, EST is an estimate (a lower bound) for norm(A).
*
* KASE (input/output) INTEGER
* On the initial call to DLACN2, KASE should be 0.
* On an intermediate return, KASE will be 1 or 2, indicating
* whether X should be overwritten by A * X or A' * X.
* On the final return from DLACN2, KASE will again be 0.
*
* ISAVE (input/output) INTEGER array, dimension (3)
* ISAVE is used to save variables between calls to DLACN2
*
* Further Details
* ======= =======
*
* Contributed by Nick Higham, University of Manchester.
* Originally named SONEST, dated March 16, 1988.
*
* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of
* a real or complex matrix, with applications to condition estimation",
* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.
*
* This is a thread safe version of DLACON, which uses the array ISAVE
* in place of a SAVE statement, as follows:
*
* DLACON DLACN2
* JUMP ISAVE(1)
* J ISAVE(2)
* ITER ISAVE(3)
*
* =====================================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 5 )
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, JLAST
DOUBLE PRECISION ALTSGN, ESTOLD, TEMP
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DASUM
EXTERNAL IDAMAX, DASUM
* ..
* .. External Subroutines ..
EXTERNAL DCOPY
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, NINT, SIGN
* ..
* .. Executable Statements ..
*
IF( KASE.EQ.0 ) THEN
DO 10 I = 1, N
X( I ) = ONE / DBLE( N )
10 CONTINUE
KASE = 1
ISAVE( 1 ) = 1
RETURN
END IF
*
GO TO ( 20, 40, 70, 110, 140 )ISAVE( 1 )
*
* ................ ENTRY (ISAVE( 1 ) = 1)
* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X.
*
20 CONTINUE
IF( N.EQ.1 ) THEN
V( 1 ) = X( 1 )
EST = ABS( V( 1 ) )
* ... QUIT
GO TO 150
END IF
EST = DASUM( N, X, 1 )
*
DO 30 I = 1, N
X( I ) = SIGN( ONE, X( I ) )
ISGN( I ) = NINT( X( I ) )
30 CONTINUE
KASE = 2
ISAVE( 1 ) = 2
RETURN
*
* ................ ENTRY (ISAVE( 1 ) = 2)
* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
*
40 CONTINUE
ISAVE( 2 ) = IDAMAX( N, X, 1 )
ISAVE( 3 ) = 2
*
* MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
*
50 CONTINUE
DO 60 I = 1, N
X( I ) = ZERO
60 CONTINUE
X( ISAVE( 2 ) ) = ONE
KASE = 1
ISAVE( 1 ) = 3
RETURN
*
* ................ ENTRY (ISAVE( 1 ) = 3)
* X HAS BEEN OVERWRITTEN BY A*X.
*
70 CONTINUE
CALL DCOPY( N, X, 1, V, 1 )
ESTOLD = EST
EST = DASUM( N, V, 1 )
DO 80 I = 1, N
IF( NINT( SIGN( ONE, X( I ) ) ).NE.ISGN( I ) )
$ GO TO 90
80 CONTINUE
* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED.
GO TO 120
*
90 CONTINUE
* TEST FOR CYCLING.
IF( EST.LE.ESTOLD )
$ GO TO 120
*
DO 100 I = 1, N
X( I ) = SIGN( ONE, X( I ) )
ISGN( I ) = NINT( X( I ) )
100 CONTINUE
KASE = 2
ISAVE( 1 ) = 4
RETURN
*
* ................ ENTRY (ISAVE( 1 ) = 4)
* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
*
110 CONTINUE
JLAST = ISAVE( 2 )
ISAVE( 2 ) = IDAMAX( N, X, 1 )
IF( ( X( JLAST ).NE.ABS( X( ISAVE( 2 ) ) ) ) .AND.
$ ( ISAVE( 3 ).LT.ITMAX ) ) THEN
ISAVE( 3 ) = ISAVE( 3 ) + 1
GO TO 50
END IF
*
* ITERATION COMPLETE. FINAL STAGE.
*
120 CONTINUE
ALTSGN = ONE
DO 130 I = 1, N
X( I ) = ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) )
ALTSGN = -ALTSGN
130 CONTINUE
KASE = 1
ISAVE( 1 ) = 5
RETURN
*
* ................ ENTRY (ISAVE( 1 ) = 5)
* X HAS BEEN OVERWRITTEN BY A*X.
*
140 CONTINUE
TEMP = TWO*( DASUM( N, X, 1 ) / DBLE( 3*N ) )
IF( TEMP.GT.EST ) THEN
CALL DCOPY( N, X, 1, V, 1 )
EST = TEMP
END IF
*
150 CONTINUE
KASE = 0
RETURN
*
* End of DLACN2
*
END
SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KASE, N
DOUBLE PRECISION EST
* ..
* .. Array Arguments ..
INTEGER ISGN( * )
DOUBLE PRECISION V( * ), X( * )
* ..
*
* Purpose
* =======
*
* DLACON estimates the 1-norm of a square, real matrix A.
* Reverse communication is used for evaluating matrix-vector products.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix. N >= 1.
*
* V (workspace) DOUBLE PRECISION array, dimension (N)
* On the final return, V = A*W, where EST = norm(V)/norm(W)
* (W is not returned).
*
* X (input/output) DOUBLE PRECISION array, dimension (N)
* On an intermediate return, X should be overwritten by
* A * X, if KASE=1,
* A' * X, if KASE=2,
* and DLACON must be re-called with all the other parameters
* unchanged.
*
* ISGN (workspace) INTEGER array, dimension (N)
*
* EST (input/output) DOUBLE PRECISION
* On entry with KASE = 1 or 2 and JUMP = 3, EST should be
* unchanged from the previous call to DLACON.
* On exit, EST is an estimate (a lower bound) for norm(A).
*
* KASE (input/output) INTEGER
* On the initial call to DLACON, KASE should be 0.
* On an intermediate return, KASE will be 1 or 2, indicating
* whether X should be overwritten by A * X or A' * X.
* On the final return from DLACON, KASE will again be 0.
*
* Further Details
* ======= =======
*
* Contributed by Nick Higham, University of Manchester.
* Originally named SONEST, dated March 16, 1988.
*
* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of
* a real or complex matrix, with applications to condition estimation",
* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.
*
* =====================================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 5 )
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, ITER, J, JLAST, JUMP
DOUBLE PRECISION ALTSGN, ESTOLD, TEMP
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DASUM
EXTERNAL IDAMAX, DASUM
* ..
* .. External Subroutines ..
EXTERNAL DCOPY
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, NINT, SIGN
* ..
* .. Save statement ..
SAVE
* ..
* .. Executable Statements ..
*
IF( KASE.EQ.0 ) THEN
DO 10 I = 1, N
X( I ) = ONE / DBLE( N )
10 CONTINUE
KASE = 1
JUMP = 1
RETURN
END IF
*
GO TO ( 20, 40, 70, 110, 140 )JUMP
*
* ................ ENTRY (JUMP = 1)
* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X.
*
20 CONTINUE
IF( N.EQ.1 ) THEN
V( 1 ) = X( 1 )
EST = ABS( V( 1 ) )
* ... QUIT
GO TO 150
END IF
EST = DASUM( N, X, 1 )
*
DO 30 I = 1, N
X( I ) = SIGN( ONE, X( I ) )
ISGN( I ) = NINT( X( I ) )
30 CONTINUE
KASE = 2
JUMP = 2
RETURN
*
* ................ ENTRY (JUMP = 2)
* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
*
40 CONTINUE
J = IDAMAX( N, X, 1 )
ITER = 2
*
* MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
*
50 CONTINUE
DO 60 I = 1, N
X( I ) = ZERO
60 CONTINUE
X( J ) = ONE
KASE = 1
JUMP = 3
RETURN
*
* ................ ENTRY (JUMP = 3)
* X HAS BEEN OVERWRITTEN BY A*X.
*
70 CONTINUE
CALL DCOPY( N, X, 1, V, 1 )
ESTOLD = EST
EST = DASUM( N, V, 1 )
DO 80 I = 1, N
IF( NINT( SIGN( ONE, X( I ) ) ).NE.ISGN( I ) )
$ GO TO 90
80 CONTINUE
* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED.
GO TO 120
*
90 CONTINUE
* TEST FOR CYCLING.
IF( EST.LE.ESTOLD )
$ GO TO 120
*
DO 100 I = 1, N
X( I ) = SIGN( ONE, X( I ) )
ISGN( I ) = NINT( X( I ) )
100 CONTINUE
KASE = 2
JUMP = 4
RETURN
*
* ................ ENTRY (JUMP = 4)
* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
*
110 CONTINUE
JLAST = J
J = IDAMAX( N, X, 1 )
IF( ( X( JLAST ).NE.ABS( X( J ) ) ) .AND. ( ITER.LT.ITMAX ) ) THEN
ITER = ITER + 1
GO TO 50
END IF
*
* ITERATION COMPLETE. FINAL STAGE.
*
120 CONTINUE
ALTSGN = ONE
DO 130 I = 1, N
X( I ) = ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) )
ALTSGN = -ALTSGN
130 CONTINUE
KASE = 1
JUMP = 5
RETURN
*
* ................ ENTRY (JUMP = 5)
* X HAS BEEN OVERWRITTEN BY A*X.
*
140 CONTINUE
TEMP = TWO*( DASUM( N, X, 1 ) / DBLE( 3*N ) )
IF( TEMP.GT.EST ) THEN
CALL DCOPY( N, X, 1, V, 1 )
EST = TEMP
END IF
*
150 CONTINUE
KASE = 0
RETURN
*
* End of DLACON
*
END
SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDA, LDB, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* DLACPY copies all or part of a two-dimensional matrix A to another
* matrix B.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies the part of the matrix A to be copied to B.
* = 'U': Upper triangular part
* = 'L': Lower triangular part
* Otherwise: All of the matrix A
*
* 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) DOUBLE PRECISION array, dimension (LDA,N)
* The m by n matrix A. If UPLO = 'U', only the upper triangle
* or trapezoid is accessed; if UPLO = 'L', only the lower
* triangle or trapezoid is accessed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (output) DOUBLE PRECISION array, dimension (LDB,N)
* On exit, B = A in the locations specified by UPLO.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,M).
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = 1, MIN( J, M )
B( I, J ) = A( I, J )
10 CONTINUE
20 CONTINUE
ELSE IF( LSAME( UPLO, 'L' ) ) THEN
DO 40 J = 1, N
DO 30 I = J, M
B( I, J ) = A( I, J )
30 CONTINUE
40 CONTINUE
ELSE
DO 60 J = 1, N
DO 50 I = 1, M
B( I, J ) = A( I, J )
50 CONTINUE
60 CONTINUE
END IF
RETURN
*
* End of DLACPY
*
END
SUBROUTINE DLADIV( A, B, C, D, P, Q )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
DOUBLE PRECISION A, B, C, D, P, Q
* ..
*
* Purpose
* =======
*
* DLADIV performs complex division in real arithmetic
*
* a + i*b
* p + i*q = ---------
* c + i*d
*
* The algorithm is due to Robert L. Smith and can be found
* in D. Knuth, The art of Computer Programming, Vol.2, p.195
*
* Arguments
* =========
*
* A (input) DOUBLE PRECISION
* B (input) DOUBLE PRECISION
* C (input) DOUBLE PRECISION
* D (input) DOUBLE PRECISION
* The scalars a, b, c, and d in the above expression.
*
* P (output) DOUBLE PRECISION
* Q (output) DOUBLE PRECISION
* The scalars p and q in the above expression.
*
* =====================================================================
*
* .. Local Scalars ..
DOUBLE PRECISION E, F
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
IF( ABS( D ).LT.ABS( C ) ) THEN
E = D / C
F = C + D*E
P = ( A+B*E ) / F
Q = ( B-A*E ) / F
ELSE
E = C / D
F = D + C*E
P = ( B+A*E ) / F
Q = ( -A+B*E ) / F
END IF
*
RETURN
*
* End of DLADIV
*
END
SUBROUTINE DLAE2( A, B, C, RT1, RT2 )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
DOUBLE PRECISION A, B, C, RT1, RT2
* ..
*
* Purpose
* =======
*
* DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix
* [ A B ]
* [ B C ].
* On return, RT1 is the eigenvalue of larger absolute value, and RT2
* is the eigenvalue of smaller absolute value.
*
* Arguments
* =========
*
* A (input) DOUBLE PRECISION
* The (1,1) element of the 2-by-2 matrix.
*
* B (input) DOUBLE PRECISION
* The (1,2) and (2,1) elements of the 2-by-2 matrix.
*
* C (input) DOUBLE PRECISION
* The (2,2) element of the 2-by-2 matrix.
*
* RT1 (output) DOUBLE PRECISION
* The eigenvalue of larger absolute value.
*
* RT2 (output) DOUBLE PRECISION
* The eigenvalue of smaller absolute value.
*
* Further Details
* ===============
*
* RT1 is accurate to a few ulps barring over/underflow.
*
* RT2 may be inaccurate if there is massive cancellation in the
* determinant A*C-B*B; higher precision or correctly rounded or
* correctly truncated arithmetic would be needed to compute RT2
* accurately in all cases.
*
* Overflow is possible only if RT1 is within a factor of 5 of overflow.
* Underflow is harmless if the input data is 0 or exceeds
* underflow_threshold / macheps.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D0 )
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION HALF
PARAMETER ( HALF = 0.5D0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION AB, ACMN, ACMX, ADF, DF, RT, SM, TB
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SQRT
* ..
* .. Executable Statements ..
*
* Compute the eigenvalues
*
SM = A + C
DF = A - C
ADF = ABS( DF )
TB = B + B
AB = ABS( TB )
IF( ABS( A ).GT.ABS( C ) ) THEN
ACMX = A
ACMN = C
ELSE
ACMX = C
ACMN = A
END IF
IF( ADF.GT.AB ) THEN
RT = ADF*SQRT( ONE+( AB / ADF )**2 )
ELSE IF( ADF.LT.AB ) THEN
RT = AB*SQRT( ONE+( ADF / AB )**2 )
ELSE
*
* Includes case AB=ADF=0
*
RT = AB*SQRT( TWO )
END IF
IF( SM.LT.ZERO ) THEN
RT1 = HALF*( SM-RT )
*
* Order of execution important.
* To get fully accurate smaller eigenvalue,
* next line needs to be executed in higher precision.
*
RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
ELSE IF( SM.GT.ZERO ) THEN
RT1 = HALF*( SM+RT )
*
* Order of execution important.
* To get fully accurate smaller eigenvalue,
* next line needs to be executed in higher precision.
*
RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
ELSE
*
* Includes case RT1 = RT2 = 0
*
RT1 = HALF*RT
RT2 = -HALF*RT
END IF
RETURN
*
* End of DLAE2
*
END
SUBROUTINE DLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL,
$ RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT,
$ NAB, WORK, IWORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IJOB, INFO, MINP, MMAX, MOUT, N, NBMIN, NITMAX
DOUBLE PRECISION ABSTOL, PIVMIN, RELTOL
* ..
* .. Array Arguments ..
INTEGER IWORK( * ), NAB( MMAX, * ), NVAL( * )
DOUBLE PRECISION AB( MMAX, * ), C( * ), D( * ), E( * ), E2( * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* DLAEBZ contains the iteration loops which compute and use the
* function N(w), which is the count of eigenvalues of a symmetric
* tridiagonal matrix T less than or equal to its argument w. It
* performs a choice of two types of loops:
*
* IJOB=1, followed by
* IJOB=2: It takes as input a list of intervals and returns a list of
* sufficiently small intervals whose union contains the same
* eigenvalues as the union of the original intervals.
* The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP.
* The output interval (AB(j,1),AB(j,2)] will contain
* eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT.
*
* IJOB=3: It performs a binary search in each input interval
* (AB(j,1),AB(j,2)] for a point w(j) such that
* N(w(j))=NVAL(j), and uses C(j) as the starting point of
* the search. If such a w(j) is found, then on output
* AB(j,1)=AB(j,2)=w. If no such w(j) is found, then on output
* (AB(j,1),AB(j,2)] will be a small interval containing the
* point where N(w) jumps through NVAL(j), unless that point
* lies outside the initial interval.
*
* Note that the intervals are in all cases half-open intervals,
* i.e., of the form (a,b] , which includes b but not a .
*
* To avoid underflow, the matrix should be scaled so that its largest
* element is no greater than overflow**(1/2) * underflow**(1/4)
* in absolute value. To assure the most accurate computation
* of small eigenvalues, the matrix should be scaled to be
* not much smaller than that, either.
*
* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
* Matrix", Report CS41, Computer Science Dept., Stanford
* University, July 21, 1966
*
* Note: the arguments are, in general, *not* checked for unreasonable
* values.
*
* Arguments
* =========
*
* IJOB (input) INTEGER
* Specifies what is to be done:
* = 1: Compute NAB for the initial intervals.
* = 2: Perform bisection iteration to find eigenvalues of T.
* = 3: Perform bisection iteration to invert N(w), i.e.,
* to find a point which has a specified number of
* eigenvalues of T to its left.
* Other values will cause DLAEBZ to return with INFO=-1.
*
* NITMAX (input) INTEGER
* The maximum number of "levels" of bisection to be
* performed, i.e., an interval of width W will not be made
* smaller than 2^(-NITMAX) * W. If not all intervals
* have converged after NITMAX iterations, then INFO is set
* to the number of non-converged intervals.
*
* N (input) INTEGER
* The dimension n of the tridiagonal matrix T. It must be at
* least 1.
*
* MMAX (input) INTEGER
* The maximum number of intervals. If more than MMAX intervals
* are generated, then DLAEBZ will quit with INFO=MMAX+1.
*
* MINP (input) INTEGER
* The initial number of intervals. It may not be greater than
* MMAX.
*
* NBMIN (input) INTEGER
* The smallest number of intervals that should be processed
* using a vector loop. If zero, then only the scalar loop
* will be used.
*
* ABSTOL (input) DOUBLE PRECISION
* The minimum (absolute) width of an interval. When an
* interval is narrower than ABSTOL, or than RELTOL times the
* larger (in magnitude) endpoint, then it is considered to be
* sufficiently small, i.e., converged. This must be at least
* zero.
*
* RELTOL (input) DOUBLE PRECISION
* The minimum relative width of an interval. When an interval
* is narrower than ABSTOL, or than RELTOL times the larger (in
* magnitude) endpoint, then it is considered to be
* sufficiently small, i.e., converged. Note: this should
* always be at least radix*machine epsilon.
*
* PIVMIN (input) DOUBLE PRECISION
* The minimum absolute value of a "pivot" in the Sturm
* sequence loop. This *must* be at least max |e(j)**2| *
* safe_min and at least safe_min, where safe_min is at least
* the smallest number that can divide one without overflow.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The diagonal elements of the tridiagonal matrix T.
*
* E (input) DOUBLE PRECISION array, dimension (N)
* The offdiagonal elements of the tridiagonal matrix T in
* positions 1 through N-1. E(N) is arbitrary.
*
* E2 (input) DOUBLE PRECISION array, dimension (N)
* The squares of the offdiagonal elements of the tridiagonal
* matrix T. E2(N) is ignored.
*
* NVAL (input/output) INTEGER array, dimension (MINP)
* If IJOB=1 or 2, not referenced.
* If IJOB=3, the desired values of N(w). The elements of NVAL
* will be reordered to correspond with the intervals in AB.
* Thus, NVAL(j) on output will not, in general be the same as
* NVAL(j) on input, but it will correspond with the interval
* (AB(j,1),AB(j,2)] on output.
*
* AB (input/output) DOUBLE PRECISION array, dimension (MMAX,2)
* The endpoints of the intervals. AB(j,1) is a(j), the left
* endpoint of the j-th interval, and AB(j,2) is b(j), the
* right endpoint of the j-th interval. The input intervals
* will, in general, be modified, split, and reordered by the
* calculation.
*
* C (input/output) DOUBLE PRECISION array, dimension (MMAX)
* If IJOB=1, ignored.
* If IJOB=2, workspace.
* If IJOB=3, then on input C(j) should be initialized to the
* first search point in the binary search.
*
* MOUT (output) INTEGER
* If IJOB=1, the number of eigenvalues in the intervals.
* If IJOB=2 or 3, the number of intervals output.
* If IJOB=3, MOUT will equal MINP.
*
* NAB (input/output) INTEGER array, dimension (MMAX,2)
* If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)).
* If IJOB=2, then on input, NAB(i,j) should be set. It must
* satisfy the condition:
* N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)),
* which means that in interval i only eigenvalues
* NAB(i,1)+1,...,NAB(i,2) will be considered. Usually,
* NAB(i,j)=N(AB(i,j)), from a previous call to DLAEBZ with
* IJOB=1.
* On output, NAB(i,j) will contain
* max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of
* the input interval that the output interval
* (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the
* the input values of NAB(k,1) and NAB(k,2).
* If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)),
* unless N(w) > NVAL(i) for all search points w , in which
* case NAB(i,1) will not be modified, i.e., the output
* value will be the same as the input value (modulo
* reorderings -- see NVAL and AB), or unless N(w) < NVAL(i)
* for all search points w , in which case NAB(i,2) will
* not be modified. Normally, NAB should be set to some
* distinctive value(s) before DLAEBZ is called.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (MMAX)
* Workspace.
*
* IWORK (workspace) INTEGER array, dimension (MMAX)
* Workspace.
*
* INFO (output) INTEGER
* = 0: All intervals converged.
* = 1--MMAX: The last INFO intervals did not converge.
* = MMAX+1: More than MMAX intervals were generated.
*
* Further Details
* ===============
*
* This routine is intended to be called only by other LAPACK
* routines, thus the interface is less user-friendly. It is intended
* for two purposes:
*
* (a) finding eigenvalues. In this case, DLAEBZ should have one or
* more initial intervals set up in AB, and DLAEBZ should be called
* with IJOB=1. This sets up NAB, and also counts the eigenvalues.
* Intervals with no eigenvalues would usually be thrown out at
* this point. Also, if not all the eigenvalues in an interval i
* are desired, NAB(i,1) can be increased or NAB(i,2) decreased.
* For example, set NAB(i,1)=NAB(i,2)-1 to get the largest
* eigenvalue. DLAEBZ is then called with IJOB=2 and MMAX
* no smaller than the value of MOUT returned by the call with
* IJOB=1. After this (IJOB=2) call, eigenvalues NAB(i,1)+1
* through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the
* tolerance specified by ABSTOL and RELTOL.
*
* (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l).
* In this case, start with a Gershgorin interval (a,b). Set up
* AB to contain 2 search intervals, both initially (a,b). One
* NVAL element should contain f-1 and the other should contain l
* , while C should contain a and b, resp. NAB(i,1) should be -1
* and NAB(i,2) should be N+1, to flag an error if the desired
* interval does not lie in (a,b). DLAEBZ is then called with
* IJOB=3. On exit, if w(f-1) < w(f), then one of the intervals --
* j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while
* if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r
* >= 0, then the interval will have N(AB(j,1))=NAB(j,1)=f-k and
* N(AB(j,2))=NAB(j,2)=f+r. The cases w(l) < w(l+1) and
* w(l-r)=...=w(l+k) are handled similarly.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, TWO, HALF
PARAMETER ( ZERO = 0.0D0, TWO = 2.0D0,
$ HALF = 1.0D0 / TWO )
* ..
* .. Local Scalars ..
INTEGER ITMP1, ITMP2, J, JI, JIT, JP, KF, KFNEW, KL,
$ KLNEW
DOUBLE PRECISION TMP1, TMP2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Check for Errors
*
INFO = 0
IF( IJOB.LT.1 .OR. IJOB.GT.3 ) THEN
INFO = -1
RETURN
END IF
*
* Initialize NAB
*
IF( IJOB.EQ.1 ) THEN
*
* Compute the number of eigenvalues in the initial intervals.
*
MOUT = 0
*DIR$ NOVECTOR
DO 30 JI = 1, MINP
DO 20 JP = 1, 2
TMP1 = D( 1 ) - AB( JI, JP )
IF( ABS( TMP1 ).LT.PIVMIN )
$ TMP1 = -PIVMIN
NAB( JI, JP ) = 0
IF( TMP1.LE.ZERO )
$ NAB( JI, JP ) = 1
*
DO 10 J = 2, N
TMP1 = D( J ) - E2( J-1 ) / TMP1 - AB( JI, JP )
IF( ABS( TMP1 ).LT.PIVMIN )
$ TMP1 = -PIVMIN
IF( TMP1.LE.ZERO )
$ NAB( JI, JP ) = NAB( JI, JP ) + 1
10 CONTINUE
20 CONTINUE
MOUT = MOUT + NAB( JI, 2 ) - NAB( JI, 1 )
30 CONTINUE
RETURN
END IF
*
* Initialize for loop
*
* KF and KL have the following meaning:
* Intervals 1,...,KF-1 have converged.
* Intervals KF,...,KL still need to be refined.
*
KF = 1
KL = MINP
*
* If IJOB=2, initialize C.
* If IJOB=3, use the user-supplied starting point.
*
IF( IJOB.EQ.2 ) THEN
DO 40 JI = 1, MINP
C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) )
40 CONTINUE
END IF
*
* Iteration loop
*
DO 130 JIT = 1, NITMAX
*
* Loop over intervals
*
IF( KL-KF+1.GE.NBMIN .AND. NBMIN.GT.0 ) THEN
*
* Begin of Parallel Version of the loop
*
DO 60 JI = KF, KL
*
* Compute N(c), the number of eigenvalues less than c
*
WORK( JI ) = D( 1 ) - C( JI )
IWORK( JI ) = 0
IF( WORK( JI ).LE.PIVMIN ) THEN
IWORK( JI ) = 1
WORK( JI ) = MIN( WORK( JI ), -PIVMIN )
END IF
*
DO 50 J = 2, N
WORK( JI ) = D( J ) - E2( J-1 ) / WORK( JI ) - C( JI )
IF( WORK( JI ).LE.PIVMIN ) THEN
IWORK( JI ) = IWORK( JI ) + 1
WORK( JI ) = MIN( WORK( JI ), -PIVMIN )
END IF
50 CONTINUE
60 CONTINUE
*
IF( IJOB.LE.2 ) THEN
*
* IJOB=2: Choose all intervals containing eigenvalues.
*
KLNEW = KL
DO 70 JI = KF, KL
*
* Insure that N(w) is monotone
*
IWORK( JI ) = MIN( NAB( JI, 2 ),
$ MAX( NAB( JI, 1 ), IWORK( JI ) ) )
*
* Update the Queue -- add intervals if both halves
* contain eigenvalues.
*
IF( IWORK( JI ).EQ.NAB( JI, 2 ) ) THEN
*
* No eigenvalue in the upper interval:
* just use the lower interval.
*
AB( JI, 2 ) = C( JI )
*
ELSE IF( IWORK( JI ).EQ.NAB( JI, 1 ) ) THEN
*
* No eigenvalue in the lower interval:
* just use the upper interval.
*
AB( JI, 1 ) = C( JI )
ELSE
KLNEW = KLNEW + 1
IF( KLNEW.LE.MMAX ) THEN
*
* Eigenvalue in both intervals -- add upper to
* queue.
*
AB( KLNEW, 2 ) = AB( JI, 2 )
NAB( KLNEW, 2 ) = NAB( JI, 2 )
AB( KLNEW, 1 ) = C( JI )
NAB( KLNEW, 1 ) = IWORK( JI )
AB( JI, 2 ) = C( JI )
NAB( JI, 2 ) = IWORK( JI )
ELSE
INFO = MMAX + 1
END IF
END IF
70 CONTINUE
IF( INFO.NE.0 )
$ RETURN
KL = KLNEW
ELSE
*
* IJOB=3: Binary search. Keep only the interval containing
* w s.t. N(w) = NVAL
*
DO 80 JI = KF, KL
IF( IWORK( JI ).LE.NVAL( JI ) ) THEN
AB( JI, 1 ) = C( JI )
NAB( JI, 1 ) = IWORK( JI )
END IF
IF( IWORK( JI ).GE.NVAL( JI ) ) THEN
AB( JI, 2 ) = C( JI )
NAB( JI, 2 ) = IWORK( JI )
END IF
80 CONTINUE
END IF
*
ELSE
*
* End of Parallel Version of the loop
*
* Begin of Serial Version of the loop
*
KLNEW = KL
DO 100 JI = KF, KL
*
* Compute N(w), the number of eigenvalues less than w
*
TMP1 = C( JI )
TMP2 = D( 1 ) - TMP1
ITMP1 = 0
IF( TMP2.LE.PIVMIN ) THEN
ITMP1 = 1
TMP2 = MIN( TMP2, -PIVMIN )
END IF
*
* A series of compiler directives to defeat vectorization
* for the next loop
*
*$PL$ CMCHAR=' '
CDIR$ NEXTSCALAR
C$DIR SCALAR
CDIR$ NEXT SCALAR
CVD$L NOVECTOR
CDEC$ NOVECTOR
CVD$ NOVECTOR
*VDIR NOVECTOR
*VOCL LOOP,SCALAR
CIBM PREFER SCALAR
*$PL$ CMCHAR='*'
*
DO 90 J = 2, N
TMP2 = D( J ) - E2( J-1 ) / TMP2 - TMP1
IF( TMP2.LE.PIVMIN ) THEN
ITMP1 = ITMP1 + 1
TMP2 = MIN( TMP2, -PIVMIN )
END IF
90 CONTINUE
*
IF( IJOB.LE.2 ) THEN
*
* IJOB=2: Choose all intervals containing eigenvalues.
*
* Insure that N(w) is monotone
*
ITMP1 = MIN( NAB( JI, 2 ),
$ MAX( NAB( JI, 1 ), ITMP1 ) )
*
* Update the Queue -- add intervals if both halves
* contain eigenvalues.
*
IF( ITMP1.EQ.NAB( JI, 2 ) ) THEN
*
* No eigenvalue in the upper interval:
* just use the lower interval.
*
AB( JI, 2 ) = TMP1
*
ELSE IF( ITMP1.EQ.NAB( JI, 1 ) ) THEN
*
* No eigenvalue in the lower interval:
* just use the upper interval.
*
AB( JI, 1 ) = TMP1
ELSE IF( KLNEW.LT.MMAX ) THEN
*
* Eigenvalue in both intervals -- add upper to queue.
*
KLNEW = KLNEW + 1
AB( KLNEW, 2 ) = AB( JI, 2 )
NAB( KLNEW, 2 ) = NAB( JI, 2 )
AB( KLNEW, 1 ) = TMP1
NAB( KLNEW, 1 ) = ITMP1
AB( JI, 2 ) = TMP1
NAB( JI, 2 ) = ITMP1
ELSE
INFO = MMAX + 1
RETURN
END IF
ELSE
*
* IJOB=3: Binary search. Keep only the interval
* containing w s.t. N(w) = NVAL
*
IF( ITMP1.LE.NVAL( JI ) ) THEN
AB( JI, 1 ) = TMP1
NAB( JI, 1 ) = ITMP1
END IF
IF( ITMP1.GE.NVAL( JI ) ) THEN
AB( JI, 2 ) = TMP1
NAB( JI, 2 ) = ITMP1
END IF
END IF
100 CONTINUE
KL = KLNEW
*
* End of Serial Version of the loop
*
END IF
*
* Check for convergence
*
KFNEW = KF
DO 110 JI = KF, KL
TMP1 = ABS( AB( JI, 2 )-AB( JI, 1 ) )
TMP2 = MAX( ABS( AB( JI, 2 ) ), ABS( AB( JI, 1 ) ) )
IF( TMP1.LT.MAX( ABSTOL, PIVMIN, RELTOL*TMP2 ) .OR.
$ NAB( JI, 1 ).GE.NAB( JI, 2 ) ) THEN
*
* Converged -- Swap with position KFNEW,
* then increment KFNEW
*
IF( JI.GT.KFNEW ) THEN
TMP1 = AB( JI, 1 )
TMP2 = AB( JI, 2 )
ITMP1 = NAB( JI, 1 )
ITMP2 = NAB( JI, 2 )
AB( JI, 1 ) = AB( KFNEW, 1 )
AB( JI, 2 ) = AB( KFNEW, 2 )
NAB( JI, 1 ) = NAB( KFNEW, 1 )
NAB( JI, 2 ) = NAB( KFNEW, 2 )
AB( KFNEW, 1 ) = TMP1
AB( KFNEW, 2 ) = TMP2
NAB( KFNEW, 1 ) = ITMP1
NAB( KFNEW, 2 ) = ITMP2
IF( IJOB.EQ.3 ) THEN
ITMP1 = NVAL( JI )
NVAL( JI ) = NVAL( KFNEW )
NVAL( KFNEW ) = ITMP1
END IF
END IF
KFNEW = KFNEW + 1
END IF
110 CONTINUE
KF = KFNEW
*
* Choose Midpoints
*
DO 120 JI = KF, KL
C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) )
120 CONTINUE
*
* If no more intervals to refine, quit.
*
IF( KF.GT.KL )
$ GO TO 140
130 CONTINUE
*
* Converged
*
140 CONTINUE
INFO = MAX( KL+1-KF, 0 )
MOUT = KL
*
RETURN
*
* End of DLAEBZ
*
END
SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS,
$ WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* DLAED0 computes all eigenvalues and corresponding eigenvectors of a
* symmetric tridiagonal matrix using the divide and conquer method.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* = 0: Compute eigenvalues only.
* = 1: Compute eigenvectors of original dense symmetric matrix
* also. On entry, Q contains the orthogonal matrix used
* to reduce the original matrix to tridiagonal form.
* = 2: Compute eigenvalues and eigenvectors of tridiagonal
* matrix.
*
* QSIZ (input) INTEGER
* The dimension of the orthogonal matrix used to reduce
* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the main diagonal of the tridiagonal matrix.
* On exit, its eigenvalues.
*
* E (input) DOUBLE PRECISION array, dimension (N-1)
* The off-diagonal elements of the tridiagonal matrix.
* On exit, E has been destroyed.
*
* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
* On entry, Q must contain an N-by-N orthogonal matrix.
* If ICOMPQ = 0 Q is not referenced.
* If ICOMPQ = 1 On entry, Q is a subset of the columns of the
* orthogonal matrix used to reduce the full
* matrix to tridiagonal form corresponding to
* the subset of the full matrix which is being
* decomposed at this time.
* If ICOMPQ = 2 On entry, Q will be the identity matrix.
* On exit, Q contains the eigenvectors of the
* tridiagonal matrix.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. If eigenvectors are
* desired, then LDQ >= max(1,N). In any case, LDQ >= 1.
*
* QSTORE (workspace) DOUBLE PRECISION array, dimension (LDQS, N)
* Referenced only when ICOMPQ = 1. Used to store parts of
* the eigenvector matrix when the updating matrix multiplies
* take place.
*
* LDQS (input) INTEGER
* The leading dimension of the array QSTORE. If ICOMPQ = 1,
* then LDQS >= max(1,N). In any case, LDQS >= 1.
*
* WORK (workspace) DOUBLE PRECISION array,
* If ICOMPQ = 0 or 1, the dimension of WORK must be at least
* 1 + 3*N + 2*N*lg N + 2*N**2
* ( lg( N ) = smallest integer k
* such that 2^k >= N )
* If ICOMPQ = 2, the dimension of WORK must be at least
* 4*N + N**2.
*
* IWORK (workspace) INTEGER array,
* If ICOMPQ = 0 or 1, the dimension of IWORK must be at least
* 6 + 6*N + 5*N*lg N.
* ( lg( N ) = smallest integer k
* such that 2^k >= N )
* If ICOMPQ = 2, the dimension of IWORK must be at least
* 3 + 5*N.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: The algorithm failed to compute an eigenvalue while
* working on the submatrix lying in rows and columns
* INFO/(N+1) through mod(INFO,N+1).
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.D0, ONE = 1.D0, TWO = 2.D0 )
* ..
* .. Local Scalars ..
INTEGER CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM,
$ IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM,
$ J, K, LGN, MATSIZ, MSD2, SMLSIZ, SMM1, SPM1,
$ SPM2, SUBMAT, SUBPBS, TLVLS
DOUBLE PRECISION TEMP
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMM, DLACPY, DLAED1, DLAED7, DSTEQR,
$ XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, INT, LOG, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.2 ) THEN
INFO = -1
ELSE IF( ( ICOMPQ.EQ.1 ) .AND. ( QSIZ.LT.MAX( 0, N ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDQS.LT.MAX( 1, N ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAED0', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
SMLSIZ = ILAENV( 9, 'DLAED0', ' ', 0, 0, 0, 0 )
*
* Determine the size and placement of the submatrices, and save in
* the leading elements of IWORK.
*
IWORK( 1 ) = N
SUBPBS = 1
TLVLS = 0
10 CONTINUE
IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN
DO 20 J = SUBPBS, 1, -1
IWORK( 2*J ) = ( IWORK( J )+1 ) / 2
IWORK( 2*J-1 ) = IWORK( J ) / 2
20 CONTINUE
TLVLS = TLVLS + 1
SUBPBS = 2*SUBPBS
GO TO 10
END IF
DO 30 J = 2, SUBPBS
IWORK( J ) = IWORK( J ) + IWORK( J-1 )
30 CONTINUE
*
* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1
* using rank-1 modifications (cuts).
*
SPM1 = SUBPBS - 1
DO 40 I = 1, SPM1
SUBMAT = IWORK( I ) + 1
SMM1 = SUBMAT - 1
D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) )
D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) )
40 CONTINUE
*
INDXQ = 4*N + 3
IF( ICOMPQ.NE.2 ) THEN
*
* Set up workspaces for eigenvalues only/accumulate new vectors
* routine
*
TEMP = LOG( DBLE( N ) ) / LOG( TWO )
LGN = INT( TEMP )
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IPRMPT = INDXQ + N + 1
IPERM = IPRMPT + N*LGN
IQPTR = IPERM + N*LGN
IGIVPT = IQPTR + N + 2
IGIVCL = IGIVPT + N*LGN
*
IGIVNM = 1
IQ = IGIVNM + 2*N*LGN
IWREM = IQ + N**2 + 1
*
* Initialize pointers
*
DO 50 I = 0, SUBPBS
IWORK( IPRMPT+I ) = 1
IWORK( IGIVPT+I ) = 1
50 CONTINUE
IWORK( IQPTR ) = 1
END IF
*
* Solve each submatrix eigenproblem at the bottom of the divide and
* conquer tree.
*
CURR = 0
DO 70 I = 0, SPM1
IF( I.EQ.0 ) THEN
SUBMAT = 1
MATSIZ = IWORK( 1 )
ELSE
SUBMAT = IWORK( I ) + 1
MATSIZ = IWORK( I+1 ) - IWORK( I )
END IF
IF( ICOMPQ.EQ.2 ) THEN
CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
$ Q( SUBMAT, SUBMAT ), LDQ, WORK, INFO )
IF( INFO.NE.0 )
$ GO TO 130
ELSE
CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
$ WORK( IQ-1+IWORK( IQPTR+CURR ) ), MATSIZ, WORK,
$ INFO )
IF( INFO.NE.0 )
$ GO TO 130
IF( ICOMPQ.EQ.1 ) THEN
CALL DGEMM( 'N', 'N', QSIZ, MATSIZ, MATSIZ, ONE,
$ Q( 1, SUBMAT ), LDQ, WORK( IQ-1+IWORK( IQPTR+
$ CURR ) ), MATSIZ, ZERO, QSTORE( 1, SUBMAT ),
$ LDQS )
END IF
IWORK( IQPTR+CURR+1 ) = IWORK( IQPTR+CURR ) + MATSIZ**2
CURR = CURR + 1
END IF
K = 1
DO 60 J = SUBMAT, IWORK( I+1 )
IWORK( INDXQ+J ) = K
K = K + 1
60 CONTINUE
70 CONTINUE
*
* Successively merge eigensystems of adjacent submatrices
* into eigensystem for the corresponding larger matrix.
*
* while ( SUBPBS > 1 )
*
CURLVL = 1
80 CONTINUE
IF( SUBPBS.GT.1 ) THEN
SPM2 = SUBPBS - 2
DO 90 I = 0, SPM2, 2
IF( I.EQ.0 ) THEN
SUBMAT = 1
MATSIZ = IWORK( 2 )
MSD2 = IWORK( 1 )
CURPRB = 0
ELSE
SUBMAT = IWORK( I ) + 1
MATSIZ = IWORK( I+2 ) - IWORK( I )
MSD2 = MATSIZ / 2
CURPRB = CURPRB + 1
END IF
*
* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2)
* into an eigensystem of size MATSIZ.
* DLAED1 is used only for the full eigensystem of a tridiagonal
* matrix.
* DLAED7 handles the cases in which eigenvalues only or eigenvalues
* and eigenvectors of a full symmetric matrix (which was reduced to
* tridiagonal form) are desired.
*
IF( ICOMPQ.EQ.2 ) THEN
CALL DLAED1( MATSIZ, D( SUBMAT ), Q( SUBMAT, SUBMAT ),
$ LDQ, IWORK( INDXQ+SUBMAT ),
$ E( SUBMAT+MSD2-1 ), MSD2, WORK,
$ IWORK( SUBPBS+1 ), INFO )
ELSE
CALL DLAED7( ICOMPQ, MATSIZ, QSIZ, TLVLS, CURLVL, CURPRB,
$ D( SUBMAT ), QSTORE( 1, SUBMAT ), LDQS,
$ IWORK( INDXQ+SUBMAT ), E( SUBMAT+MSD2-1 ),
$ MSD2, WORK( IQ ), IWORK( IQPTR ),
$ IWORK( IPRMPT ), IWORK( IPERM ),
$ IWORK( IGIVPT ), IWORK( IGIVCL ),
$ WORK( IGIVNM ), WORK( IWREM ),
$ IWORK( SUBPBS+1 ), INFO )
END IF
IF( INFO.NE.0 )
$ GO TO 130
IWORK( I / 2+1 ) = IWORK( I+2 )
90 CONTINUE
SUBPBS = SUBPBS / 2
CURLVL = CURLVL + 1
GO TO 80
END IF
*
* end while
*
* Re-merge the eigenvalues/vectors which were deflated at the final
* merge step.
*
IF( ICOMPQ.EQ.1 ) THEN
DO 100 I = 1, N
J = IWORK( INDXQ+I )
WORK( I ) = D( J )
CALL DCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 )
100 CONTINUE
CALL DCOPY( N, WORK, 1, D, 1 )
ELSE IF( ICOMPQ.EQ.2 ) THEN
DO 110 I = 1, N
J = IWORK( INDXQ+I )
WORK( I ) = D( J )
CALL DCOPY( N, Q( 1, J ), 1, WORK( N*I+1 ), 1 )
110 CONTINUE
CALL DCOPY( N, WORK, 1, D, 1 )
CALL DLACPY( 'A', N, N, WORK( N+1 ), N, Q, LDQ )
ELSE
DO 120 I = 1, N
J = IWORK( INDXQ+I )
WORK( I ) = D( J )
120 CONTINUE
CALL DCOPY( N, WORK, 1, D, 1 )
END IF
GO TO 140
*
130 CONTINUE
INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1
*
140 CONTINUE
RETURN
*
* End of DLAED0
*
END
SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER CUTPNT, INFO, LDQ, N
DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
INTEGER INDXQ( * ), IWORK( * )
DOUBLE PRECISION D( * ), Q( LDQ, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLAED1 computes the updated eigensystem of a diagonal
* matrix after modification by a rank-one symmetric matrix. This
* routine is used only for the eigenproblem which requires all
* eigenvalues and eigenvectors of a tridiagonal matrix. DLAED7 handles
* the case in which eigenvalues only or eigenvalues and eigenvectors
* of a full symmetric matrix (which was reduced to tridiagonal form)
* are desired.
*
* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)
*
* where Z = Q'u, u is a vector of length N with ones in the
* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
*
* The eigenvectors of the original matrix are stored in Q, and the
* eigenvalues are in D. The algorithm consists of three stages:
*
* The first stage consists of deflating the size of the problem
* when there are multiple eigenvalues or if there is a zero in
* the Z vector. For each such occurence the dimension of the
* secular equation problem is reduced by one. This stage is
* performed by the routine DLAED2.
*
* The second stage consists of calculating the updated
* eigenvalues. This is done by finding the roots of the secular
* equation via the routine DLAED4 (as called by DLAED3).
* This routine also calculates the eigenvectors of the current
* problem.
*
* The final stage consists of computing the updated eigenvectors
* directly using the updated eigenvalues. The eigenvectors for
* the current problem are multiplied with the eigenvectors from
* the overall problem.
*
* Arguments
* =========
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the eigenvalues of the rank-1-perturbed matrix.
* On exit, the eigenvalues of the repaired matrix.
*
* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
* On entry, the eigenvectors of the rank-1-perturbed matrix.
* On exit, the eigenvectors of the repaired tridiagonal matrix.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* INDXQ (input/output) INTEGER array, dimension (N)
* On entry, the permutation which separately sorts the two
* subproblems in D into ascending order.
* On exit, the permutation which will reintegrate the
* subproblems back into sorted order,
* i.e. D( INDXQ( I = 1, N ) ) will be in ascending order.
*
* RHO (input) DOUBLE PRECISION
* The subdiagonal entry used to create the rank-1 modification.
*
* CUTPNT (input) INTEGER
* The location of the last eigenvalue in the leading sub-matrix.
* min(1,N) <= CUTPNT <= N/2.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (4*N + N**2)
*
* IWORK (workspace) INTEGER array, dimension (4*N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an eigenvalue did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
* Modified by Francoise Tisseur, University of Tennessee.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER COLTYP, I, IDLMDA, INDX, INDXC, INDXP, IQ2, IS,
$ IW, IZ, K, N1, N2, ZPP1
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLAED2, DLAED3, DLAMRG, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( MIN( 1, N / 2 ).GT.CUTPNT .OR. ( N / 2 ).LT.CUTPNT ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAED1', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* The following values are integer pointers which indicate
* the portion of the workspace
* used by a particular array in DLAED2 and DLAED3.
*
IZ = 1
IDLMDA = IZ + N
IW = IDLMDA + N
IQ2 = IW + N
*
INDX = 1
INDXC = INDX + N
COLTYP = INDXC + N
INDXP = COLTYP + N
*
*
* Form the z-vector which consists of the last row of Q_1 and the
* first row of Q_2.
*
CALL DCOPY( CUTPNT, Q( CUTPNT, 1 ), LDQ, WORK( IZ ), 1 )
ZPP1 = CUTPNT + 1
CALL DCOPY( N-CUTPNT, Q( ZPP1, ZPP1 ), LDQ, WORK( IZ+CUTPNT ), 1 )
*
* Deflate eigenvalues.
*
CALL DLAED2( K, N, CUTPNT, D, Q, LDQ, INDXQ, RHO, WORK( IZ ),
$ WORK( IDLMDA ), WORK( IW ), WORK( IQ2 ),
$ IWORK( INDX ), IWORK( INDXC ), IWORK( INDXP ),
$ IWORK( COLTYP ), INFO )
*
IF( INFO.NE.0 )
$ GO TO 20
*
* Solve Secular Equation.
*
IF( K.NE.0 ) THEN
IS = ( IWORK( COLTYP )+IWORK( COLTYP+1 ) )*CUTPNT +
$ ( IWORK( COLTYP+1 )+IWORK( COLTYP+2 ) )*( N-CUTPNT ) + IQ2
CALL DLAED3( K, N, CUTPNT, D, Q, LDQ, RHO, WORK( IDLMDA ),
$ WORK( IQ2 ), IWORK( INDXC ), IWORK( COLTYP ),
$ WORK( IW ), WORK( IS ), INFO )
IF( INFO.NE.0 )
$ GO TO 20
*
* Prepare the INDXQ sorting permutation.
*
N1 = K
N2 = N - K
CALL DLAMRG( N1, N2, D, 1, -1, INDXQ )
ELSE
DO 10 I = 1, N
INDXQ( I ) = I
10 CONTINUE
END IF
*
20 CONTINUE
RETURN
*
* End of DLAED1
*
END
SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W,
$ Q2, INDX, INDXC, INDXP, COLTYP, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDQ, N, N1
DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
INTEGER COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ),
$ INDXQ( * )
DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
$ W( * ), Z( * )
* ..
*
* Purpose
* =======
*
* DLAED2 merges the two sets of eigenvalues together into a single
* sorted set. Then it tries to deflate the size of the problem.
* There are two ways in which deflation can occur: when two or more
* eigenvalues are close together or if there is a tiny entry in the
* Z vector. For each such occurrence the order of the related secular
* equation problem is reduced by one.
*
* Arguments
* =========
*
* K (output) INTEGER
* The number of non-deflated eigenvalues, and the order of the
* related secular equation. 0 <= K <=N.
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* N1 (input) INTEGER
* The location of the last eigenvalue in the leading sub-matrix.
* min(1,N) <= N1 <= N/2.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, D contains the eigenvalues of the two submatrices to
* be combined.
* On exit, D contains the trailing (N-K) updated eigenvalues
* (those which were deflated) sorted into increasing order.
*
* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
* On entry, Q contains the eigenvectors of two submatrices in
* the two square blocks with corners at (1,1), (N1,N1)
* and (N1+1, N1+1), (N,N).
* On exit, Q contains the trailing (N-K) updated eigenvectors
* (those which were deflated) in its last N-K columns.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* INDXQ (input/output) INTEGER array, dimension (N)
* The permutation which separately sorts the two sub-problems
* in D into ascending order. Note that elements in the second
* half of this permutation must first have N1 added to their
* values. Destroyed on exit.
*
* RHO (input/output) DOUBLE PRECISION
* On entry, the off-diagonal element associated with the rank-1
* cut which originally split the two submatrices which are now
* being recombined.
* On exit, RHO has been modified to the value required by
* DLAED3.
*
* Z (input) DOUBLE PRECISION array, dimension (N)
* On entry, Z contains the updating vector (the last
* row of the first sub-eigenvector matrix and the first row of
* the second sub-eigenvector matrix).
* On exit, the contents of Z have been destroyed by the updating
* process.
*
* DLAMDA (output) DOUBLE PRECISION array, dimension (N)
* A copy of the first K eigenvalues which will be used by
* DLAED3 to form the secular equation.
*
* W (output) DOUBLE PRECISION array, dimension (N)
* The first k values of the final deflation-altered z-vector
* which will be passed to DLAED3.
*
* Q2 (output) DOUBLE PRECISION array, dimension (N1**2+(N-N1)**2)
* A copy of the first K eigenvectors which will be used by
* DLAED3 in a matrix multiply (DGEMM) to solve for the new
* eigenvectors.
*
* INDX (workspace) INTEGER array, dimension (N)
* The permutation used to sort the contents of DLAMDA into
* ascending order.
*
* INDXC (output) INTEGER array, dimension (N)
* The permutation used to arrange the columns of the deflated
* Q matrix into three groups: the first group contains non-zero
* elements only at and above N1, the second contains
* non-zero elements only below N1, and the third is dense.
*
* INDXP (workspace) INTEGER array, dimension (N)
* The permutation used to place deflated values of D at the end
* of the array. INDXP(1:K) points to the nondeflated D-values
* and INDXP(K+1:N) points to the deflated eigenvalues.
*
* COLTYP (workspace/output) INTEGER array, dimension (N)
* During execution, a label which will indicate which of the
* following types a column in the Q2 matrix is:
* 1 : non-zero in the upper half only;
* 2 : dense;
* 3 : non-zero in the lower half only;
* 4 : deflated.
* On exit, COLTYP(i) is the number of columns of type i,
* for i=1 to 4 only.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
* Modified by Francoise Tisseur, University of Tennessee.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT
PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0,
$ TWO = 2.0D0, EIGHT = 8.0D0 )
* ..
* .. Local Arrays ..
INTEGER CTOT( 4 ), PSM( 4 )
* ..
* .. Local Scalars ..
INTEGER CT, I, IMAX, IQ1, IQ2, J, JMAX, JS, K2, N1P1,
$ N2, NJ, PJ
DOUBLE PRECISION C, EPS, S, T, TAU, TOL
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH, DLAPY2
EXTERNAL IDAMAX, DLAMCH, DLAPY2
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLACPY, DLAMRG, DROT, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( MIN( 1, ( N / 2 ) ).GT.N1 .OR. ( N / 2 ).LT.N1 ) THEN
INFO = -3
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAED2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
N2 = N - N1
N1P1 = N1 + 1
*
IF( RHO.LT.ZERO ) THEN
CALL DSCAL( N2, MONE, Z( N1P1 ), 1 )
END IF
*
* Normalize z so that norm(z) = 1. Since z is the concatenation of
* two normalized vectors, norm2(z) = sqrt(2).
*
T = ONE / SQRT( TWO )
CALL DSCAL( N, T, Z, 1 )
*
* RHO = ABS( norm(z)**2 * RHO )
*
RHO = ABS( TWO*RHO )
*
* Sort the eigenvalues into increasing order
*
DO 10 I = N1P1, N
INDXQ( I ) = INDXQ( I ) + N1
10 CONTINUE
*
* re-integrate the deflated parts from the last pass
*
DO 20 I = 1, N
DLAMDA( I ) = D( INDXQ( I ) )
20 CONTINUE
CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDXC )
DO 30 I = 1, N
INDX( I ) = INDXQ( INDXC( I ) )
30 CONTINUE
*
* Calculate the allowable deflation tolerance
*
IMAX = IDAMAX( N, Z, 1 )
JMAX = IDAMAX( N, D, 1 )
EPS = DLAMCH( 'Epsilon' )
TOL = EIGHT*EPS*MAX( ABS( D( JMAX ) ), ABS( Z( IMAX ) ) )
*
* If the rank-1 modifier is small enough, no more needs to be done
* except to reorganize Q so that its columns correspond with the
* elements in D.
*
IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN
K = 0
IQ2 = 1
DO 40 J = 1, N
I = INDX( J )
CALL DCOPY( N, Q( 1, I ), 1, Q2( IQ2 ), 1 )
DLAMDA( J ) = D( I )
IQ2 = IQ2 + N
40 CONTINUE
CALL DLACPY( 'A', N, N, Q2, N, Q, LDQ )
CALL DCOPY( N, DLAMDA, 1, D, 1 )
GO TO 190
END IF
*
* If there are multiple eigenvalues then the problem deflates. Here
* the number of equal eigenvalues are found. As each equal
* eigenvalue is found, an elementary reflector is computed to rotate
* the corresponding eigensubspace so that the corresponding
* components of Z are zero in this new basis.
*
DO 50 I = 1, N1
COLTYP( I ) = 1
50 CONTINUE
DO 60 I = N1P1, N
COLTYP( I ) = 3
60 CONTINUE
*
*
K = 0
K2 = N + 1
DO 70 J = 1, N
NJ = INDX( J )
IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
COLTYP( NJ ) = 4
INDXP( K2 ) = NJ
IF( J.EQ.N )
$ GO TO 100
ELSE
PJ = NJ
GO TO 80
END IF
70 CONTINUE
80 CONTINUE
J = J + 1
NJ = INDX( J )
IF( J.GT.N )
$ GO TO 100
IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
COLTYP( NJ ) = 4
INDXP( K2 ) = NJ
ELSE
*
* Check if eigenvalues are close enough to allow deflation.
*
S = Z( PJ )
C = Z( NJ )
*
* Find sqrt(a**2+b**2) without overflow or
* destructive underflow.
*
TAU = DLAPY2( C, S )
T = D( NJ ) - D( PJ )
C = C / TAU
S = -S / TAU
IF( ABS( T*C*S ).LE.TOL ) THEN
*
* Deflation is possible.
*
Z( NJ ) = TAU
Z( PJ ) = ZERO
IF( COLTYP( NJ ).NE.COLTYP( PJ ) )
$ COLTYP( NJ ) = 2
COLTYP( PJ ) = 4
CALL DROT( N, Q( 1, PJ ), 1, Q( 1, NJ ), 1, C, S )
T = D( PJ )*C**2 + D( NJ )*S**2
D( NJ ) = D( PJ )*S**2 + D( NJ )*C**2
D( PJ ) = T
K2 = K2 - 1
I = 1
90 CONTINUE
IF( K2+I.LE.N ) THEN
IF( D( PJ ).LT.D( INDXP( K2+I ) ) ) THEN
INDXP( K2+I-1 ) = INDXP( K2+I )
INDXP( K2+I ) = PJ
I = I + 1
GO TO 90
ELSE
INDXP( K2+I-1 ) = PJ
END IF
ELSE
INDXP( K2+I-1 ) = PJ
END IF
PJ = NJ
ELSE
K = K + 1
DLAMDA( K ) = D( PJ )
W( K ) = Z( PJ )
INDXP( K ) = PJ
PJ = NJ
END IF
END IF
GO TO 80
100 CONTINUE
*
* Record the last eigenvalue.
*
K = K + 1
DLAMDA( K ) = D( PJ )
W( K ) = Z( PJ )
INDXP( K ) = PJ
*
* Count up the total number of the various types of columns, then
* form a permutation which positions the four column types into
* four uniform groups (although one or more of these groups may be
* empty).
*
DO 110 J = 1, 4
CTOT( J ) = 0
110 CONTINUE
DO 120 J = 1, N
CT = COLTYP( J )
CTOT( CT ) = CTOT( CT ) + 1
120 CONTINUE
*
* PSM(*) = Position in SubMatrix (of types 1 through 4)
*
PSM( 1 ) = 1
PSM( 2 ) = 1 + CTOT( 1 )
PSM( 3 ) = PSM( 2 ) + CTOT( 2 )
PSM( 4 ) = PSM( 3 ) + CTOT( 3 )
K = N - CTOT( 4 )
*
* Fill out the INDXC array so that the permutation which it induces
* will place all type-1 columns first, all type-2 columns next,
* then all type-3's, and finally all type-4's.
*
DO 130 J = 1, N
JS = INDXP( J )
CT = COLTYP( JS )
INDX( PSM( CT ) ) = JS
INDXC( PSM( CT ) ) = J
PSM( CT ) = PSM( CT ) + 1
130 CONTINUE
*
* Sort the eigenvalues and corresponding eigenvectors into DLAMDA
* and Q2 respectively. The eigenvalues/vectors which were not
* deflated go into the first K slots of DLAMDA and Q2 respectively,
* while those which were deflated go into the last N - K slots.
*
I = 1
IQ1 = 1
IQ2 = 1 + ( CTOT( 1 )+CTOT( 2 ) )*N1
DO 140 J = 1, CTOT( 1 )
JS = INDX( I )
CALL DCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 )
Z( I ) = D( JS )
I = I + 1
IQ1 = IQ1 + N1
140 CONTINUE
*
DO 150 J = 1, CTOT( 2 )
JS = INDX( I )
CALL DCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 )
CALL DCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 )
Z( I ) = D( JS )
I = I + 1
IQ1 = IQ1 + N1
IQ2 = IQ2 + N2
150 CONTINUE
*
DO 160 J = 1, CTOT( 3 )
JS = INDX( I )
CALL DCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 )
Z( I ) = D( JS )
I = I + 1
IQ2 = IQ2 + N2
160 CONTINUE
*
IQ1 = IQ2
DO 170 J = 1, CTOT( 4 )
JS = INDX( I )
CALL DCOPY( N, Q( 1, JS ), 1, Q2( IQ2 ), 1 )
IQ2 = IQ2 + N
Z( I ) = D( JS )
I = I + 1
170 CONTINUE
*
* The deflated eigenvalues and their corresponding vectors go back
* into the last N - K slots of D and Q respectively.
*
CALL DLACPY( 'A', N, CTOT( 4 ), Q2( IQ1 ), N, Q( 1, K+1 ), LDQ )
CALL DCOPY( N-K, Z( K+1 ), 1, D( K+1 ), 1 )
*
* Copy CTOT into COLTYP for referencing in DLAED3.
*
DO 180 J = 1, 4
COLTYP( J ) = CTOT( J )
180 CONTINUE
*
190 CONTINUE
RETURN
*
* End of DLAED2
*
END
SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX,
$ CTOT, W, S, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDQ, N, N1
DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
INTEGER CTOT( * ), INDX( * )
DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
$ S( * ), W( * )
* ..
*
* Purpose
* =======
*
* DLAED3 finds the roots of the secular equation, as defined by the
* values in D, W, and RHO, between 1 and K. It makes the
* appropriate calls to DLAED4 and then updates the eigenvectors by
* multiplying the matrix of eigenvectors of the pair of eigensystems
* being combined by the matrix of eigenvectors of the K-by-K system
* which is solved here.
*
* This code makes very mild assumptions about floating point
* arithmetic. It will work on machines with a guard digit in
* add/subtract, or on those binary machines without guard digits
* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
* It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Arguments
* =========
*
* K (input) INTEGER
* The number of terms in the rational function to be solved by
* DLAED4. K >= 0.
*
* N (input) INTEGER
* The number of rows and columns in the Q matrix.
* N >= K (deflation may result in N>K).
*
* N1 (input) INTEGER
* The location of the last eigenvalue in the leading submatrix.
* min(1,N) <= N1 <= N/2.
*
* D (output) DOUBLE PRECISION array, dimension (N)
* D(I) contains the updated eigenvalues for
* 1 <= I <= K.
*
* Q (output) DOUBLE PRECISION array, dimension (LDQ,N)
* Initially the first K columns are used as workspace.
* On output the columns 1 to K contain
* the updated eigenvectors.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* RHO (input) DOUBLE PRECISION
* The value of the parameter in the rank one update equation.
* RHO >= 0 required.
*
* DLAMDA (input/output) DOUBLE PRECISION array, dimension (K)
* The first K elements of this array contain the old roots
* of the deflated updating problem. These are the poles
* of the secular equation. May be changed on output by
* having lowest order bit set to zero on Cray X-MP, Cray Y-MP,
* Cray-2, or Cray C-90, as described above.
*
* Q2 (input) DOUBLE PRECISION array, dimension (LDQ2, N)
* The first K columns of this matrix contain the non-deflated
* eigenvectors for the split problem.
*
* INDX (input) INTEGER array, dimension (N)
* The permutation used to arrange the columns of the deflated
* Q matrix into three groups (see DLAED2).
* The rows of the eigenvectors found by DLAED4 must be likewise
* permuted before the matrix multiply can take place.
*
* CTOT (input) INTEGER array, dimension (4)
* A count of the total number of the various types of columns
* in Q, as described in INDX. The fourth column type is any
* column which has been deflated.
*
* W (input/output) DOUBLE PRECISION array, dimension (K)
* The first K elements of this array contain the components
* of the deflation-adjusted updating vector. Destroyed on
* output.
*
* S (workspace) DOUBLE PRECISION array, dimension (N1 + 1)*K
* Will contain the eigenvectors of the repaired matrix which
* will be multiplied by the previously accumulated eigenvectors
* to update the system.
*
* LDS (input) INTEGER
* The leading dimension of S. LDS >= max(1,K).
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an eigenvalue did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
* Modified by Francoise Tisseur, University of Tennessee.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, II, IQ2, J, N12, N2, N23
DOUBLE PRECISION TEMP
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMC3, DNRM2
EXTERNAL DLAMC3, DNRM2
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMM, DLACPY, DLAED4, DLASET, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( K.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.K ) THEN
INFO = -2
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAED3', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( K.EQ.0 )
$ RETURN
*
* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
* be computed with high relative accuracy (barring over/underflow).
* This is a problem on machines without a guard digit in
* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
* which on any of these machines zeros out the bottommost
* bit of DLAMDA(I) if it is 1; this makes the subsequent
* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
* occurs. On binary machines with a guard digit (almost all
* machines) it does not change DLAMDA(I) at all. On hexadecimal
* and decimal machines with a guard digit, it slightly
* changes the bottommost bits of DLAMDA(I). It does not account
* for hexadecimal or decimal machines without guard digits
* (we know of none). We use a subroutine call to compute
* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating
* this code.
*
DO 10 I = 1, K
DLAMDA( I ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I )
10 CONTINUE
*
DO 20 J = 1, K
CALL DLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO )
*
* If the zero finder fails, the computation is terminated.
*
IF( INFO.NE.0 )
$ GO TO 120
20 CONTINUE
*
IF( K.EQ.1 )
$ GO TO 110
IF( K.EQ.2 ) THEN
DO 30 J = 1, K
W( 1 ) = Q( 1, J )
W( 2 ) = Q( 2, J )
II = INDX( 1 )
Q( 1, J ) = W( II )
II = INDX( 2 )
Q( 2, J ) = W( II )
30 CONTINUE
GO TO 110
END IF
*
* Compute updated W.
*
CALL DCOPY( K, W, 1, S, 1 )
*
* Initialize W(I) = Q(I,I)
*
CALL DCOPY( K, Q, LDQ+1, W, 1 )
DO 60 J = 1, K
DO 40 I = 1, J - 1
W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
40 CONTINUE
DO 50 I = J + 1, K
W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
50 CONTINUE
60 CONTINUE
DO 70 I = 1, K
W( I ) = SIGN( SQRT( -W( I ) ), S( I ) )
70 CONTINUE
*
* Compute eigenvectors of the modified rank-1 modification.
*
DO 100 J = 1, K
DO 80 I = 1, K
S( I ) = W( I ) / Q( I, J )
80 CONTINUE
TEMP = DNRM2( K, S, 1 )
DO 90 I = 1, K
II = INDX( I )
Q( I, J ) = S( II ) / TEMP
90 CONTINUE
100 CONTINUE
*
* Compute the updated eigenvectors.
*
110 CONTINUE
*
N2 = N - N1
N12 = CTOT( 1 ) + CTOT( 2 )
N23 = CTOT( 2 ) + CTOT( 3 )
*
CALL DLACPY( 'A', N23, K, Q( CTOT( 1 )+1, 1 ), LDQ, S, N23 )
IQ2 = N1*N12 + 1
IF( N23.NE.0 ) THEN
CALL DGEMM( 'N', 'N', N2, K, N23, ONE, Q2( IQ2 ), N2, S, N23,
$ ZERO, Q( N1+1, 1 ), LDQ )
ELSE
CALL DLASET( 'A', N2, K, ZERO, ZERO, Q( N1+1, 1 ), LDQ )
END IF
*
CALL DLACPY( 'A', N12, K, Q, LDQ, S, N12 )
IF( N12.NE.0 ) THEN
CALL DGEMM( 'N', 'N', N1, K, N12, ONE, Q2, N1, S, N12, ZERO, Q,
$ LDQ )
ELSE
CALL DLASET( 'A', N1, K, ZERO, ZERO, Q( 1, 1 ), LDQ )
END IF
*
*
120 CONTINUE
RETURN
*
* End of DLAED3
*
END
SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER I, INFO, N
DOUBLE PRECISION DLAM, RHO
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), DELTA( * ), Z( * )
* ..
*
* Purpose
* =======
*
* This subroutine computes the I-th updated eigenvalue of a symmetric
* rank-one modification to a diagonal matrix whose elements are
* given in the array d, and that
*
* D(i) < D(j) for i < j
*
* and that RHO > 0. This is arranged by the calling routine, and is
* no loss in generality. The rank-one modified system is thus
*
* diag( D ) + RHO * Z * Z_transpose.
*
* where we assume the Euclidean norm of Z is 1.
*
* The method consists of approximating the rational functions in the
* secular equation by simpler interpolating rational functions.
*
* Arguments
* =========
*
* N (input) INTEGER
* The length of all arrays.
*
* I (input) INTEGER
* The index of the eigenvalue to be computed. 1 <= I <= N.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The original eigenvalues. It is assumed that they are in
* order, D(I) < D(J) for I < J.
*
* Z (input) DOUBLE PRECISION array, dimension (N)
* The components of the updating vector.
*
* DELTA (output) DOUBLE PRECISION array, dimension (N)
* If N .GT. 2, DELTA contains (D(j) - lambda_I) in its j-th
* component. If N = 1, then DELTA(1) = 1. If N = 2, see DLAED5
* for detail. The vector DELTA contains the information necessary
* to construct the eigenvectors by DLAED3 and DLAED9.
*
* RHO (input) DOUBLE PRECISION
* The scalar in the symmetric updating formula.
*
* DLAM (output) DOUBLE PRECISION
* The computed lambda_I, the I-th updated eigenvalue.
*
* INFO (output) INTEGER
* = 0: successful exit
* > 0: if INFO = 1, the updating process failed.
*
* Internal Parameters
* ===================
*
* Logical variable ORGATI (origin-at-i?) is used for distinguishing
* whether D(i) or D(i+1) is treated as the origin.
*
* ORGATI = .true. origin at i
* ORGATI = .false. origin at i+1
*
* Logical variable SWTCH3 (switch-for-3-poles?) is for noting
* if we are working with THREE poles!
*
* MAXIT is the maximum number of iterations allowed for each
* eigenvalue.
*
* Further Details
* ===============
*
* Based on contributions by
* Ren-Cang Li, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXIT
PARAMETER ( MAXIT = 30 )
DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0,
$ TEN = 10.0D0 )
* ..
* .. Local Scalars ..
LOGICAL ORGATI, SWTCH, SWTCH3
INTEGER II, IIM1, IIP1, IP1, ITER, J, NITER
DOUBLE PRECISION A, B, C, DEL, DLTLB, DLTUB, DPHI, DPSI, DW,
$ EPS, ERRETM, ETA, MIDPT, PHI, PREW, PSI,
$ RHOINV, TAU, TEMP, TEMP1, W
* ..
* .. Local Arrays ..
DOUBLE PRECISION ZZ( 3 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DLAED5, DLAED6
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Since this routine is called in an inner loop, we do no argument
* checking.
*
* Quick return for N=1 and 2.
*
INFO = 0
IF( N.EQ.1 ) THEN
*
* Presumably, I=1 upon entry
*
DLAM = D( 1 ) + RHO*Z( 1 )*Z( 1 )
DELTA( 1 ) = ONE
RETURN
END IF
IF( N.EQ.2 ) THEN
CALL DLAED5( I, D, Z, DELTA, RHO, DLAM )
RETURN
END IF
*
* Compute machine epsilon
*
EPS = DLAMCH( 'Epsilon' )
RHOINV = ONE / RHO
*
* The case I = N
*
IF( I.EQ.N ) THEN
*
* Initialize some basic variables
*
II = N - 1
NITER = 1
*
* Calculate initial guess
*
MIDPT = RHO / TWO
*
* If ||Z||_2 is not one, then TEMP should be set to
* RHO * ||Z||_2^2 / TWO
*
DO 10 J = 1, N
DELTA( J ) = ( D( J )-D( I ) ) - MIDPT
10 CONTINUE
*
PSI = ZERO
DO 20 J = 1, N - 2
PSI = PSI + Z( J )*Z( J ) / DELTA( J )
20 CONTINUE
*
C = RHOINV + PSI
W = C + Z( II )*Z( II ) / DELTA( II ) +
$ Z( N )*Z( N ) / DELTA( N )
*
IF( W.LE.ZERO ) THEN
TEMP = Z( N-1 )*Z( N-1 ) / ( D( N )-D( N-1 )+RHO ) +
$ Z( N )*Z( N ) / RHO
IF( C.LE.TEMP ) THEN
TAU = RHO
ELSE
DEL = D( N ) - D( N-1 )
A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
B = Z( N )*Z( N )*DEL
IF( A.LT.ZERO ) THEN
TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
ELSE
TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
END IF
END IF
*
* It can be proved that
* D(N)+RHO/2 <= LAMBDA(N) < D(N)+TAU <= D(N)+RHO
*
DLTLB = MIDPT
DLTUB = RHO
ELSE
DEL = D( N ) - D( N-1 )
A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
B = Z( N )*Z( N )*DEL
IF( A.LT.ZERO ) THEN
TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
ELSE
TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
END IF
*
* It can be proved that
* D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2
*
DLTLB = ZERO
DLTUB = MIDPT
END IF
*
DO 30 J = 1, N
DELTA( J ) = ( D( J )-D( I ) ) - TAU
30 CONTINUE
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 40 J = 1, II
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
40 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
TEMP = Z( N ) / DELTA( N )
PHI = Z( N )*TEMP
DPHI = TEMP*TEMP
ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
$ ABS( TAU )*( DPSI+DPHI )
*
W = RHOINV + PHI + PSI
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
DLAM = D( I ) + TAU
GO TO 250
END IF
*
IF( W.LE.ZERO ) THEN
DLTLB = MAX( DLTLB, TAU )
ELSE
DLTUB = MIN( DLTUB, TAU )
END IF
*
* Calculate the new step
*
NITER = NITER + 1
C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI
A = ( DELTA( N-1 )+DELTA( N ) )*W -
$ DELTA( N-1 )*DELTA( N )*( DPSI+DPHI )
B = DELTA( N-1 )*DELTA( N )*W
IF( C.LT.ZERO )
$ C = ABS( C )
IF( C.EQ.ZERO ) THEN
* ETA = B/A
* ETA = RHO - TAU
ETA = DLTUB - TAU
ELSE IF( A.GE.ZERO ) THEN
ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
IF( W*ETA.GT.ZERO )
$ ETA = -W / ( DPSI+DPHI )
TEMP = TAU + ETA
IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
IF( W.LT.ZERO ) THEN
ETA = ( DLTUB-TAU ) / TWO
ELSE
ETA = ( DLTLB-TAU ) / TWO
END IF
END IF
DO 50 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
50 CONTINUE
*
TAU = TAU + ETA
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 60 J = 1, II
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
60 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
TEMP = Z( N ) / DELTA( N )
PHI = Z( N )*TEMP
DPHI = TEMP*TEMP
ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
$ ABS( TAU )*( DPSI+DPHI )
*
W = RHOINV + PHI + PSI
*
* Main loop to update the values of the array DELTA
*
ITER = NITER + 1
*
DO 90 NITER = ITER, MAXIT
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
DLAM = D( I ) + TAU
GO TO 250
END IF
*
IF( W.LE.ZERO ) THEN
DLTLB = MAX( DLTLB, TAU )
ELSE
DLTUB = MIN( DLTUB, TAU )
END IF
*
* Calculate the new step
*
C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI
A = ( DELTA( N-1 )+DELTA( N ) )*W -
$ DELTA( N-1 )*DELTA( N )*( DPSI+DPHI )
B = DELTA( N-1 )*DELTA( N )*W
IF( A.GE.ZERO ) THEN
ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
IF( W*ETA.GT.ZERO )
$ ETA = -W / ( DPSI+DPHI )
TEMP = TAU + ETA
IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
IF( W.LT.ZERO ) THEN
ETA = ( DLTUB-TAU ) / TWO
ELSE
ETA = ( DLTLB-TAU ) / TWO
END IF
END IF
DO 70 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
70 CONTINUE
*
TAU = TAU + ETA
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 80 J = 1, II
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
80 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
TEMP = Z( N ) / DELTA( N )
PHI = Z( N )*TEMP
DPHI = TEMP*TEMP
ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
$ ABS( TAU )*( DPSI+DPHI )
*
W = RHOINV + PHI + PSI
90 CONTINUE
*
* Return with INFO = 1, NITER = MAXIT and not converged
*
INFO = 1
DLAM = D( I ) + TAU
GO TO 250
*
* End for the case I = N
*
ELSE
*
* The case for I < N
*
NITER = 1
IP1 = I + 1
*
* Calculate initial guess
*
DEL = D( IP1 ) - D( I )
MIDPT = DEL / TWO
DO 100 J = 1, N
DELTA( J ) = ( D( J )-D( I ) ) - MIDPT
100 CONTINUE
*
PSI = ZERO
DO 110 J = 1, I - 1
PSI = PSI + Z( J )*Z( J ) / DELTA( J )
110 CONTINUE
*
PHI = ZERO
DO 120 J = N, I + 2, -1
PHI = PHI + Z( J )*Z( J ) / DELTA( J )
120 CONTINUE
C = RHOINV + PSI + PHI
W = C + Z( I )*Z( I ) / DELTA( I ) +
$ Z( IP1 )*Z( IP1 ) / DELTA( IP1 )
*
IF( W.GT.ZERO ) THEN
*
* d(i)< the ith eigenvalue < (d(i)+d(i+1))/2
*
* We choose d(i) as origin.
*
ORGATI = .TRUE.
A = C*DEL + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 )
B = Z( I )*Z( I )*DEL
IF( A.GT.ZERO ) THEN
TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
ELSE
TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
END IF
DLTLB = ZERO
DLTUB = MIDPT
ELSE
*
* (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1)
*
* We choose d(i+1) as origin.
*
ORGATI = .FALSE.
A = C*DEL - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 )
B = Z( IP1 )*Z( IP1 )*DEL
IF( A.LT.ZERO ) THEN
TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) )
ELSE
TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C )
END IF
DLTLB = -MIDPT
DLTUB = ZERO
END IF
*
IF( ORGATI ) THEN
DO 130 J = 1, N
DELTA( J ) = ( D( J )-D( I ) ) - TAU
130 CONTINUE
ELSE
DO 140 J = 1, N
DELTA( J ) = ( D( J )-D( IP1 ) ) - TAU
140 CONTINUE
END IF
IF( ORGATI ) THEN
II = I
ELSE
II = I + 1
END IF
IIM1 = II - 1
IIP1 = II + 1
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 150 J = 1, IIM1
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
150 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
DPHI = ZERO
PHI = ZERO
DO 160 J = N, IIP1, -1
TEMP = Z( J ) / DELTA( J )
PHI = PHI + Z( J )*TEMP
DPHI = DPHI + TEMP*TEMP
ERRETM = ERRETM + PHI
160 CONTINUE
*
W = RHOINV + PHI + PSI
*
* W is the value of the secular function with
* its ii-th element removed.
*
SWTCH3 = .FALSE.
IF( ORGATI ) THEN
IF( W.LT.ZERO )
$ SWTCH3 = .TRUE.
ELSE
IF( W.GT.ZERO )
$ SWTCH3 = .TRUE.
END IF
IF( II.EQ.1 .OR. II.EQ.N )
$ SWTCH3 = .FALSE.
*
TEMP = Z( II ) / DELTA( II )
DW = DPSI + DPHI + TEMP*TEMP
TEMP = Z( II )*TEMP
W = W + TEMP
ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
$ THREE*ABS( TEMP ) + ABS( TAU )*DW
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
IF( ORGATI ) THEN
DLAM = D( I ) + TAU
ELSE
DLAM = D( IP1 ) + TAU
END IF
GO TO 250
END IF
*
IF( W.LE.ZERO ) THEN
DLTLB = MAX( DLTLB, TAU )
ELSE
DLTUB = MIN( DLTUB, TAU )
END IF
*
* Calculate the new step
*
NITER = NITER + 1
IF( .NOT.SWTCH3 ) THEN
IF( ORGATI ) THEN
C = W - DELTA( IP1 )*DW - ( D( I )-D( IP1 ) )*
$ ( Z( I ) / DELTA( I ) )**2
ELSE
C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )*
$ ( Z( IP1 ) / DELTA( IP1 ) )**2
END IF
A = ( DELTA( I )+DELTA( IP1 ) )*W -
$ DELTA( I )*DELTA( IP1 )*DW
B = DELTA( I )*DELTA( IP1 )*W
IF( C.EQ.ZERO ) THEN
IF( A.EQ.ZERO ) THEN
IF( ORGATI ) THEN
A = Z( I )*Z( I ) + DELTA( IP1 )*DELTA( IP1 )*
$ ( DPSI+DPHI )
ELSE
A = Z( IP1 )*Z( IP1 ) + DELTA( I )*DELTA( I )*
$ ( DPSI+DPHI )
END IF
END IF
ETA = B / A
ELSE IF( A.LE.ZERO ) THEN
ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
ELSE
*
* Interpolation using THREE most relevant poles
*
TEMP = RHOINV + PSI + PHI
IF( ORGATI ) THEN
TEMP1 = Z( IIM1 ) / DELTA( IIM1 )
TEMP1 = TEMP1*TEMP1
C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) -
$ ( D( IIM1 )-D( IIP1 ) )*TEMP1
ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*
$ ( ( DPSI-TEMP1 )+DPHI )
ELSE
TEMP1 = Z( IIP1 ) / DELTA( IIP1 )
TEMP1 = TEMP1*TEMP1
C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) -
$ ( D( IIP1 )-D( IIM1 ) )*TEMP1
ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*
$ ( DPSI+( DPHI-TEMP1 ) )
ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
END IF
ZZ( 2 ) = Z( II )*Z( II )
CALL DLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA,
$ INFO )
IF( INFO.NE.0 )
$ GO TO 250
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
IF( W*ETA.GE.ZERO )
$ ETA = -W / DW
TEMP = TAU + ETA
IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
IF( W.LT.ZERO ) THEN
ETA = ( DLTUB-TAU ) / TWO
ELSE
ETA = ( DLTLB-TAU ) / TWO
END IF
END IF
*
PREW = W
*
DO 180 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
180 CONTINUE
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 190 J = 1, IIM1
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
190 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
DPHI = ZERO
PHI = ZERO
DO 200 J = N, IIP1, -1
TEMP = Z( J ) / DELTA( J )
PHI = PHI + Z( J )*TEMP
DPHI = DPHI + TEMP*TEMP
ERRETM = ERRETM + PHI
200 CONTINUE
*
TEMP = Z( II ) / DELTA( II )
DW = DPSI + DPHI + TEMP*TEMP
TEMP = Z( II )*TEMP
W = RHOINV + PHI + PSI + TEMP
ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
$ THREE*ABS( TEMP ) + ABS( TAU+ETA )*DW
*
SWTCH = .FALSE.
IF( ORGATI ) THEN
IF( -W.GT.ABS( PREW ) / TEN )
$ SWTCH = .TRUE.
ELSE
IF( W.GT.ABS( PREW ) / TEN )
$ SWTCH = .TRUE.
END IF
*
TAU = TAU + ETA
*
* Main loop to update the values of the array DELTA
*
ITER = NITER + 1
*
DO 240 NITER = ITER, MAXIT
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
IF( ORGATI ) THEN
DLAM = D( I ) + TAU
ELSE
DLAM = D( IP1 ) + TAU
END IF
GO TO 250
END IF
*
IF( W.LE.ZERO ) THEN
DLTLB = MAX( DLTLB, TAU )
ELSE
DLTUB = MIN( DLTUB, TAU )
END IF
*
* Calculate the new step
*
IF( .NOT.SWTCH3 ) THEN
IF( .NOT.SWTCH ) THEN
IF( ORGATI ) THEN
C = W - DELTA( IP1 )*DW -
$ ( D( I )-D( IP1 ) )*( Z( I ) / DELTA( I ) )**2
ELSE
C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )*
$ ( Z( IP1 ) / DELTA( IP1 ) )**2
END IF
ELSE
TEMP = Z( II ) / DELTA( II )
IF( ORGATI ) THEN
DPSI = DPSI + TEMP*TEMP
ELSE
DPHI = DPHI + TEMP*TEMP
END IF
C = W - DELTA( I )*DPSI - DELTA( IP1 )*DPHI
END IF
A = ( DELTA( I )+DELTA( IP1 ) )*W -
$ DELTA( I )*DELTA( IP1 )*DW
B = DELTA( I )*DELTA( IP1 )*W
IF( C.EQ.ZERO ) THEN
IF( A.EQ.ZERO ) THEN
IF( .NOT.SWTCH ) THEN
IF( ORGATI ) THEN
A = Z( I )*Z( I ) + DELTA( IP1 )*
$ DELTA( IP1 )*( DPSI+DPHI )
ELSE
A = Z( IP1 )*Z( IP1 ) +
$ DELTA( I )*DELTA( I )*( DPSI+DPHI )
END IF
ELSE
A = DELTA( I )*DELTA( I )*DPSI +
$ DELTA( IP1 )*DELTA( IP1 )*DPHI
END IF
END IF
ETA = B / A
ELSE IF( A.LE.ZERO ) THEN
ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
ELSE
*
* Interpolation using THREE most relevant poles
*
TEMP = RHOINV + PSI + PHI
IF( SWTCH ) THEN
C = TEMP - DELTA( IIM1 )*DPSI - DELTA( IIP1 )*DPHI
ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*DPSI
ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*DPHI
ELSE
IF( ORGATI ) THEN
TEMP1 = Z( IIM1 ) / DELTA( IIM1 )
TEMP1 = TEMP1*TEMP1
C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) -
$ ( D( IIM1 )-D( IIP1 ) )*TEMP1
ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*
$ ( ( DPSI-TEMP1 )+DPHI )
ELSE
TEMP1 = Z( IIP1 ) / DELTA( IIP1 )
TEMP1 = TEMP1*TEMP1
C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) -
$ ( D( IIP1 )-D( IIM1 ) )*TEMP1
ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*
$ ( DPSI+( DPHI-TEMP1 ) )
ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
END IF
END IF
CALL DLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA,
$ INFO )
IF( INFO.NE.0 )
$ GO TO 250
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
IF( W*ETA.GE.ZERO )
$ ETA = -W / DW
TEMP = TAU + ETA
IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
IF( W.LT.ZERO ) THEN
ETA = ( DLTUB-TAU ) / TWO
ELSE
ETA = ( DLTLB-TAU ) / TWO
END IF
END IF
*
DO 210 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
210 CONTINUE
*
TAU = TAU + ETA
PREW = W
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 220 J = 1, IIM1
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
220 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
DPHI = ZERO
PHI = ZERO
DO 230 J = N, IIP1, -1
TEMP = Z( J ) / DELTA( J )
PHI = PHI + Z( J )*TEMP
DPHI = DPHI + TEMP*TEMP
ERRETM = ERRETM + PHI
230 CONTINUE
*
TEMP = Z( II ) / DELTA( II )
DW = DPSI + DPHI + TEMP*TEMP
TEMP = Z( II )*TEMP
W = RHOINV + PHI + PSI + TEMP
ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
$ THREE*ABS( TEMP ) + ABS( TAU )*DW
IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN )
$ SWTCH = .NOT.SWTCH
*
240 CONTINUE
*
* Return with INFO = 1, NITER = MAXIT and not converged
*
INFO = 1
IF( ORGATI ) THEN
DLAM = D( I ) + TAU
ELSE
DLAM = D( IP1 ) + TAU
END IF
*
END IF
*
250 CONTINUE
*
RETURN
*
* End of DLAED4
*
END
SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER I
DOUBLE PRECISION DLAM, RHO
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( 2 ), DELTA( 2 ), Z( 2 )
* ..
*
* Purpose
* =======
*
* This subroutine computes the I-th eigenvalue of a symmetric rank-one
* modification of a 2-by-2 diagonal matrix
*
* diag( D ) + RHO * Z * transpose(Z) .
*
* The diagonal elements in the array D are assumed to satisfy
*
* D(i) < D(j) for i < j .
*
* We also assume RHO > 0 and that the Euclidean norm of the vector
* Z is one.
*
* Arguments
* =========
*
* I (input) INTEGER
* The index of the eigenvalue to be computed. I = 1 or I = 2.
*
* D (input) DOUBLE PRECISION array, dimension (2)
* The original eigenvalues. We assume D(1) < D(2).
*
* Z (input) DOUBLE PRECISION array, dimension (2)
* The components of the updating vector.
*
* DELTA (output) DOUBLE PRECISION array, dimension (2)
* The vector DELTA contains the information necessary
* to construct the eigenvectors.
*
* RHO (input) DOUBLE PRECISION
* The scalar in the symmetric updating formula.
*
* DLAM (output) DOUBLE PRECISION
* The computed lambda_I, the I-th updated eigenvalue.
*
* Further Details
* ===============
*
* Based on contributions by
* Ren-Cang Li, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, FOUR
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ FOUR = 4.0D0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION B, C, DEL, TAU, TEMP, W
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SQRT
* ..
* .. Executable Statements ..
*
DEL = D( 2 ) - D( 1 )
IF( I.EQ.1 ) THEN
W = ONE + TWO*RHO*( Z( 2 )*Z( 2 )-Z( 1 )*Z( 1 ) ) / DEL
IF( W.GT.ZERO ) THEN
B = DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
C = RHO*Z( 1 )*Z( 1 )*DEL
*
* B > ZERO, always
*
TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) )
DLAM = D( 1 ) + TAU
DELTA( 1 ) = -Z( 1 ) / TAU
DELTA( 2 ) = Z( 2 ) / ( DEL-TAU )
ELSE
B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
C = RHO*Z( 2 )*Z( 2 )*DEL
IF( B.GT.ZERO ) THEN
TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) )
ELSE
TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO
END IF
DLAM = D( 2 ) + TAU
DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
DELTA( 2 ) = -Z( 2 ) / TAU
END IF
TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
DELTA( 1 ) = DELTA( 1 ) / TEMP
DELTA( 2 ) = DELTA( 2 ) / TEMP
ELSE
*
* Now I=2
*
B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
C = RHO*Z( 2 )*Z( 2 )*DEL
IF( B.GT.ZERO ) THEN
TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO
ELSE
TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) )
END IF
DLAM = D( 2 ) + TAU
DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
DELTA( 2 ) = -Z( 2 ) / TAU
TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
DELTA( 1 ) = DELTA( 1 ) / TEMP
DELTA( 2 ) = DELTA( 2 ) / TEMP
END IF
RETURN
*
* End OF DLAED5
*
END
SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO )
*
* -- LAPACK routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* February 2007
*
* .. Scalar Arguments ..
LOGICAL ORGATI
INTEGER INFO, KNITER
DOUBLE PRECISION FINIT, RHO, TAU
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( 3 ), Z( 3 )
* ..
*
* Purpose
* =======
*
* DLAED6 computes the positive or negative root (closest to the origin)
* of
* z(1) z(2) z(3)
* f(x) = rho + --------- + ---------- + ---------
* d(1)-x d(2)-x d(3)-x
*
* It is assumed that
*
* if ORGATI = .true. the root is between d(2) and d(3);
* otherwise it is between d(1) and d(2)
*
* This routine will be called by DLAED4 when necessary. In most cases,
* the root sought is the smallest in magnitude, though it might not be
* in some extremely rare situations.
*
* Arguments
* =========
*
* KNITER (input) INTEGER
* Refer to DLAED4 for its significance.
*
* ORGATI (input) LOGICAL
* If ORGATI is true, the needed root is between d(2) and
* d(3); otherwise it is between d(1) and d(2). See
* DLAED4 for further details.
*
* RHO (input) DOUBLE PRECISION
* Refer to the equation f(x) above.
*
* D (input) DOUBLE PRECISION array, dimension (3)
* D satisfies d(1) < d(2) < d(3).
*
* Z (input) DOUBLE PRECISION array, dimension (3)
* Each of the elements in z must be positive.
*
* FINIT (input) DOUBLE PRECISION
* The value of f at 0. It is more accurate than the one
* evaluated inside this routine (if someone wants to do
* so).
*
* TAU (output) DOUBLE PRECISION
* The root of the equation f(x).
*
* INFO (output) INTEGER
* = 0: successful exit
* > 0: if INFO = 1, failure to converge
*
* Further Details
* ===============
*
* 30/06/99: Based on contributions by
* Ren-Cang Li, Computer Science Division, University of California
* at Berkeley, USA
*
* 10/02/03: This version has a few statements commented out for thread
* safety (machine parameters are computed on each entry). SJH.
*
* 05/10/06: Modified from a new version of Ren-Cang Li, use
* Gragg-Thornton-Warner cubic convergent scheme for better stability.
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXIT
PARAMETER ( MAXIT = 40 )
DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Local Arrays ..
DOUBLE PRECISION DSCALE( 3 ), ZSCALE( 3 )
* ..
* .. Local Scalars ..
LOGICAL SCALE
INTEGER I, ITER, NITER
DOUBLE PRECISION A, B, BASE, C, DDF, DF, EPS, ERRETM, ETA, F,
$ FC, SCLFAC, SCLINV, SMALL1, SMALL2, SMINV1,
$ SMINV2, TEMP, TEMP1, TEMP2, TEMP3, TEMP4,
$ LBD, UBD
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
*
IF( ORGATI ) THEN
LBD = D(2)
UBD = D(3)
ELSE
LBD = D(1)
UBD = D(2)
END IF
IF( FINIT .LT. ZERO )THEN
LBD = ZERO
ELSE
UBD = ZERO
END IF
*
NITER = 1
TAU = ZERO
IF( KNITER.EQ.2 ) THEN
IF( ORGATI ) THEN
TEMP = ( D( 3 )-D( 2 ) ) / TWO
C = RHO + Z( 1 ) / ( ( D( 1 )-D( 2 ) )-TEMP )
A = C*( D( 2 )+D( 3 ) ) + Z( 2 ) + Z( 3 )
B = C*D( 2 )*D( 3 ) + Z( 2 )*D( 3 ) + Z( 3 )*D( 2 )
ELSE
TEMP = ( D( 1 )-D( 2 ) ) / TWO
C = RHO + Z( 3 ) / ( ( D( 3 )-D( 2 ) )-TEMP )
A = C*( D( 1 )+D( 2 ) ) + Z( 1 ) + Z( 2 )
B = C*D( 1 )*D( 2 ) + Z( 1 )*D( 2 ) + Z( 2 )*D( 1 )
END IF
TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) )
A = A / TEMP
B = B / TEMP
C = C / TEMP
IF( C.EQ.ZERO ) THEN
TAU = B / A
ELSE IF( A.LE.ZERO ) THEN
TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
IF( TAU .LT. LBD .OR. TAU .GT. UBD )
$ TAU = ( LBD+UBD )/TWO
IF( D(1).EQ.TAU .OR. D(2).EQ.TAU .OR. D(3).EQ.TAU ) THEN
TAU = ZERO
ELSE
TEMP = FINIT + TAU*Z(1)/( D(1)*( D( 1 )-TAU ) ) +
$ TAU*Z(2)/( D(2)*( D( 2 )-TAU ) ) +
$ TAU*Z(3)/( D(3)*( D( 3 )-TAU ) )
IF( TEMP .LE. ZERO )THEN
LBD = TAU
ELSE
UBD = TAU
END IF
IF( ABS( FINIT ).LE.ABS( TEMP ) )
$ TAU = ZERO
END IF
END IF
*
* get machine parameters for possible scaling to avoid overflow
*
* modified by Sven: parameters SMALL1, SMINV1, SMALL2,
* SMINV2, EPS are not SAVEd anymore between one call to the
* others but recomputed at each call
*
EPS = DLAMCH( 'Epsilon' )
BASE = DLAMCH( 'Base' )
SMALL1 = BASE**( INT( LOG( DLAMCH( 'SafMin' ) ) / LOG( BASE ) /
$ THREE ) )
SMINV1 = ONE / SMALL1
SMALL2 = SMALL1*SMALL1
SMINV2 = SMINV1*SMINV1
*
* Determine if scaling of inputs necessary to avoid overflow
* when computing 1/TEMP**3
*
IF( ORGATI ) THEN
TEMP = MIN( ABS( D( 2 )-TAU ), ABS( D( 3 )-TAU ) )
ELSE
TEMP = MIN( ABS( D( 1 )-TAU ), ABS( D( 2 )-TAU ) )
END IF
SCALE = .FALSE.
IF( TEMP.LE.SMALL1 ) THEN
SCALE = .TRUE.
IF( TEMP.LE.SMALL2 ) THEN
*
* Scale up by power of radix nearest 1/SAFMIN**(2/3)
*
SCLFAC = SMINV2
SCLINV = SMALL2
ELSE
*
* Scale up by power of radix nearest 1/SAFMIN**(1/3)
*
SCLFAC = SMINV1
SCLINV = SMALL1
END IF
*
* Scaling up safe because D, Z, TAU scaled elsewhere to be O(1)
*
DO 10 I = 1, 3
DSCALE( I ) = D( I )*SCLFAC
ZSCALE( I ) = Z( I )*SCLFAC
10 CONTINUE
TAU = TAU*SCLFAC
LBD = LBD*SCLFAC
UBD = UBD*SCLFAC
ELSE
*
* Copy D and Z to DSCALE and ZSCALE
*
DO 20 I = 1, 3
DSCALE( I ) = D( I )
ZSCALE( I ) = Z( I )
20 CONTINUE
END IF
*
FC = ZERO
DF = ZERO
DDF = ZERO
DO 30 I = 1, 3
TEMP = ONE / ( DSCALE( I )-TAU )
TEMP1 = ZSCALE( I )*TEMP
TEMP2 = TEMP1*TEMP
TEMP3 = TEMP2*TEMP
FC = FC + TEMP1 / DSCALE( I )
DF = DF + TEMP2
DDF = DDF + TEMP3
30 CONTINUE
F = FINIT + TAU*FC
*
IF( ABS( F ).LE.ZERO )
$ GO TO 60
IF( F .LE. ZERO )THEN
LBD = TAU
ELSE
UBD = TAU
END IF
*
* Iteration begins -- Use Gragg-Thornton-Warner cubic convergent
* scheme
*
* It is not hard to see that
*
* 1) Iterations will go up monotonically
* if FINIT < 0;
*
* 2) Iterations will go down monotonically
* if FINIT > 0.
*
ITER = NITER + 1
*
DO 50 NITER = ITER, MAXIT
*
IF( ORGATI ) THEN
TEMP1 = DSCALE( 2 ) - TAU
TEMP2 = DSCALE( 3 ) - TAU
ELSE
TEMP1 = DSCALE( 1 ) - TAU
TEMP2 = DSCALE( 2 ) - TAU
END IF
A = ( TEMP1+TEMP2 )*F - TEMP1*TEMP2*DF
B = TEMP1*TEMP2*F
C = F - ( TEMP1+TEMP2 )*DF + TEMP1*TEMP2*DDF
TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) )
A = A / TEMP
B = B / TEMP
C = C / TEMP
IF( C.EQ.ZERO ) THEN
ETA = B / A
ELSE IF( A.LE.ZERO ) THEN
ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
IF( F*ETA.GE.ZERO ) THEN
ETA = -F / DF
END IF
*
TAU = TAU + ETA
IF( TAU .LT. LBD .OR. TAU .GT. UBD )
$ TAU = ( LBD + UBD )/TWO
*
FC = ZERO
ERRETM = ZERO
DF = ZERO
DDF = ZERO
DO 40 I = 1, 3
TEMP = ONE / ( DSCALE( I )-TAU )
TEMP1 = ZSCALE( I )*TEMP
TEMP2 = TEMP1*TEMP
TEMP3 = TEMP2*TEMP
TEMP4 = TEMP1 / DSCALE( I )
FC = FC + TEMP4
ERRETM = ERRETM + ABS( TEMP4 )
DF = DF + TEMP2
DDF = DDF + TEMP3
40 CONTINUE
F = FINIT + TAU*FC
ERRETM = EIGHT*( ABS( FINIT )+ABS( TAU )*ERRETM ) +
$ ABS( TAU )*DF
IF( ABS( F ).LE.EPS*ERRETM )
$ GO TO 60
IF( F .LE. ZERO )THEN
LBD = TAU
ELSE
UBD = TAU
END IF
50 CONTINUE
INFO = 1
60 CONTINUE
*
* Undo scaling
*
IF( SCALE )
$ TAU = TAU*SCLINV
RETURN
*
* End of DLAED6
*
END
SUBROUTINE DLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q,
$ LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR,
$ PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N,
$ QSIZ, TLVLS
DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),
$ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )
DOUBLE PRECISION D( * ), GIVNUM( 2, * ), Q( LDQ, * ),
$ QSTORE( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLAED7 computes the updated eigensystem of a diagonal
* matrix after modification by a rank-one symmetric matrix. This
* routine is used only for the eigenproblem which requires all
* eigenvalues and optionally eigenvectors of a dense symmetric matrix
* that has been reduced to tridiagonal form. DLAED1 handles
* the case in which all eigenvalues and eigenvectors of a symmetric
* tridiagonal matrix are desired.
*
* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)
*
* where Z = Q'u, u is a vector of length N with ones in the
* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
*
* The eigenvectors of the original matrix are stored in Q, and the
* eigenvalues are in D. The algorithm consists of three stages:
*
* The first stage consists of deflating the size of the problem
* when there are multiple eigenvalues or if there is a zero in
* the Z vector. For each such occurence the dimension of the
* secular equation problem is reduced by one. This stage is
* performed by the routine DLAED8.
*
* The second stage consists of calculating the updated
* eigenvalues. This is done by finding the roots of the secular
* equation via the routine DLAED4 (as called by DLAED9).
* This routine also calculates the eigenvectors of the current
* problem.
*
* The final stage consists of computing the updated eigenvectors
* directly using the updated eigenvalues. The eigenvectors for
* the current problem are multiplied with the eigenvectors from
* the overall problem.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* = 0: Compute eigenvalues only.
* = 1: Compute eigenvectors of original dense symmetric matrix
* also. On entry, Q contains the orthogonal matrix used
* to reduce the original matrix to tridiagonal form.
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* QSIZ (input) INTEGER
* The dimension of the orthogonal matrix used to reduce
* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.
*
* TLVLS (input) INTEGER
* The total number of merging levels in the overall divide and
* conquer tree.
*
* CURLVL (input) INTEGER
* The current level in the overall merge routine,
* 0 <= CURLVL <= TLVLS.
*
* CURPBM (input) INTEGER
* The current problem in the current level in the overall
* merge routine (counting from upper left to lower right).
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the eigenvalues of the rank-1-perturbed matrix.
* On exit, the eigenvalues of the repaired matrix.
*
* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
* On entry, the eigenvectors of the rank-1-perturbed matrix.
* On exit, the eigenvectors of the repaired tridiagonal matrix.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* INDXQ (output) INTEGER array, dimension (N)
* The permutation which will reintegrate the subproblem just
* solved back into sorted order, i.e., D( INDXQ( I = 1, N ) )
* will be in ascending order.
*
* RHO (input) DOUBLE PRECISION
* The subdiagonal element used to create the rank-1
* modification.
*
* CUTPNT (input) INTEGER
* Contains the location of the last eigenvalue in the leading
* sub-matrix. min(1,N) <= CUTPNT <= N.
*
* QSTORE (input/output) DOUBLE PRECISION array, dimension (N**2+1)
* Stores eigenvectors of submatrices encountered during
* divide and conquer, packed together. QPTR points to
* beginning of the submatrices.
*
* QPTR (input/output) INTEGER array, dimension (N+2)
* List of indices pointing to beginning of submatrices stored
* in QSTORE. The submatrices are numbered starting at the
* bottom left of the divide and conquer tree, from left to
* right and bottom to top.
*
* PRMPTR (input) INTEGER array, dimension (N lg N)
* Contains a list of pointers which indicate where in PERM a
* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)
* indicates the size of the permutation and also the size of
* the full, non-deflated problem.
*
* PERM (input) INTEGER array, dimension (N lg N)
* Contains the permutations (from deflation and sorting) to be
* applied to each eigenblock.
*
* GIVPTR (input) INTEGER array, dimension (N lg N)
* Contains a list of pointers which indicate where in GIVCOL a
* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)
* indicates the number of Givens rotations.
*
* GIVCOL (input) INTEGER array, dimension (2, N lg N)
* Each pair of numbers indicates a pair of columns to take place
* in a Givens rotation.
*
* GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N)
* Each number indicates the S value to be used in the
* corresponding Givens rotation.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N+QSIZ*N)
*
* IWORK (workspace) INTEGER array, dimension (4*N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an eigenvalue did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER COLTYP, CURR, I, IDLMDA, INDX, INDXC, INDXP,
$ IQ2, IS, IW, IZ, K, LDQ2, N1, N2, PTR
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLAED8, DLAED9, DLAEDA, DLAMRG, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN
INFO = -4
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( MIN( 1, N ).GT.CUTPNT .OR. N.LT.CUTPNT ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAED7', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* The following values are for bookkeeping purposes only. They are
* integer pointers which indicate the portion of the workspace
* used by a particular array in DLAED8 and DLAED9.
*
IF( ICOMPQ.EQ.1 ) THEN
LDQ2 = QSIZ
ELSE
LDQ2 = N
END IF
*
IZ = 1
IDLMDA = IZ + N
IW = IDLMDA + N
IQ2 = IW + N
IS = IQ2 + N*LDQ2
*
INDX = 1
INDXC = INDX + N
COLTYP = INDXC + N
INDXP = COLTYP + N
*
* Form the z-vector which consists of the last row of Q_1 and the
* first row of Q_2.
*
PTR = 1 + 2**TLVLS
DO 10 I = 1, CURLVL - 1
PTR = PTR + 2**( TLVLS-I )
10 CONTINUE
CURR = PTR + CURPBM
CALL DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,
$ GIVCOL, GIVNUM, QSTORE, QPTR, WORK( IZ ),
$ WORK( IZ+N ), INFO )
*
* When solving the final problem, we no longer need the stored data,
* so we will overwrite the data from this level onto the previously
* used storage space.
*
IF( CURLVL.EQ.TLVLS ) THEN
QPTR( CURR ) = 1
PRMPTR( CURR ) = 1
GIVPTR( CURR ) = 1
END IF
*
* Sort and Deflate eigenvalues.
*
CALL DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, CUTPNT,
$ WORK( IZ ), WORK( IDLMDA ), WORK( IQ2 ), LDQ2,
$ WORK( IW ), PERM( PRMPTR( CURR ) ), GIVPTR( CURR+1 ),
$ GIVCOL( 1, GIVPTR( CURR ) ),
$ GIVNUM( 1, GIVPTR( CURR ) ), IWORK( INDXP ),
$ IWORK( INDX ), INFO )
PRMPTR( CURR+1 ) = PRMPTR( CURR ) + N
GIVPTR( CURR+1 ) = GIVPTR( CURR+1 ) + GIVPTR( CURR )
*
* Solve Secular Equation.
*
IF( K.NE.0 ) THEN
CALL DLAED9( K, 1, K, N, D, WORK( IS ), K, RHO, WORK( IDLMDA ),
$ WORK( IW ), QSTORE( QPTR( CURR ) ), K, INFO )
IF( INFO.NE.0 )
$ GO TO 30
IF( ICOMPQ.EQ.1 ) THEN
CALL DGEMM( 'N', 'N', QSIZ, K, K, ONE, WORK( IQ2 ), LDQ2,
$ QSTORE( QPTR( CURR ) ), K, ZERO, Q, LDQ )
END IF
QPTR( CURR+1 ) = QPTR( CURR ) + K**2
*
* Prepare the INDXQ sorting permutation.
*
N1 = K
N2 = N - K
CALL DLAMRG( N1, N2, D, 1, -1, INDXQ )
ELSE
QPTR( CURR+1 ) = QPTR( CURR )
DO 20 I = 1, N
INDXQ( I ) = I
20 CONTINUE
END IF
*
30 CONTINUE
RETURN
*
* End of DLAED7
*
END
SUBROUTINE DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO,
$ CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR,
$ GIVCOL, GIVNUM, INDXP, INDX, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N,
$ QSIZ
DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ),
$ INDXQ( * ), PERM( * )
DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ),
$ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * )
* ..
*
* Purpose
* =======
*
* DLAED8 merges the two sets of eigenvalues together into a single
* sorted set. Then it tries to deflate the size of the problem.
* There are two ways in which deflation can occur: when two or more
* eigenvalues are close together or if there is a tiny element in the
* Z vector. For each such occurrence the order of the related secular
* equation problem is reduced by one.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* = 0: Compute eigenvalues only.
* = 1: Compute eigenvectors of original dense symmetric matrix
* also. On entry, Q contains the orthogonal matrix used
* to reduce the original matrix to tridiagonal form.
*
* K (output) INTEGER
* The number of non-deflated eigenvalues, and the order of the
* related secular equation.
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* QSIZ (input) INTEGER
* The dimension of the orthogonal matrix used to reduce
* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the eigenvalues of the two submatrices to be
* combined. On exit, the trailing (N-K) updated eigenvalues
* (those which were deflated) sorted into increasing order.
*
* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
* If ICOMPQ = 0, Q is not referenced. Otherwise,
* on entry, Q contains the eigenvectors of the partially solved
* system which has been previously updated in matrix
* multiplies with other partially solved eigensystems.
* On exit, Q contains the trailing (N-K) updated eigenvectors
* (those which were deflated) in its last N-K columns.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* INDXQ (input) INTEGER array, dimension (N)
* The permutation which separately sorts the two sub-problems
* in D into ascending order. Note that elements in the second
* half of this permutation must first have CUTPNT added to
* their values in order to be accurate.
*
* RHO (input/output) DOUBLE PRECISION
* On entry, the off-diagonal element associated with the rank-1
* cut which originally split the two submatrices which are now
* being recombined.
* On exit, RHO has been modified to the value required by
* DLAED3.
*
* CUTPNT (input) INTEGER
* The location of the last eigenvalue in the leading
* sub-matrix. min(1,N) <= CUTPNT <= N.
*
* Z (input) DOUBLE PRECISION array, dimension (N)
* On entry, Z contains the updating vector (the last row of
* the first sub-eigenvector matrix and the first row of the
* second sub-eigenvector matrix).
* On exit, the contents of Z are destroyed by the updating
* process.
*
* DLAMDA (output) DOUBLE PRECISION array, dimension (N)
* A copy of the first K eigenvalues which will be used by
* DLAED3 to form the secular equation.
*
* Q2 (output) DOUBLE PRECISION array, dimension (LDQ2,N)
* If ICOMPQ = 0, Q2 is not referenced. Otherwise,
* a copy of the first K eigenvectors which will be used by
* DLAED7 in a matrix multiply (DGEMM) to update the new
* eigenvectors.
*
* LDQ2 (input) INTEGER
* The leading dimension of the array Q2. LDQ2 >= max(1,N).
*
* W (output) DOUBLE PRECISION array, dimension (N)
* The first k values of the final deflation-altered z-vector and
* will be passed to DLAED3.
*
* PERM (output) INTEGER array, dimension (N)
* The permutations (from deflation and sorting) to be applied
* to each eigenblock.
*
* GIVPTR (output) INTEGER
* The number of Givens rotations which took place in this
* subproblem.
*
* GIVCOL (output) INTEGER array, dimension (2, N)
* Each pair of numbers indicates a pair of columns to take place
* in a Givens rotation.
*
* GIVNUM (output) DOUBLE PRECISION array, dimension (2, N)
* Each number indicates the S value to be used in the
* corresponding Givens rotation.
*
* INDXP (workspace) INTEGER array, dimension (N)
* The permutation used to place deflated values of D at the end
* of the array. INDXP(1:K) points to the nondeflated D-values
* and INDXP(K+1:N) points to the deflated eigenvalues.
*
* INDX (workspace) INTEGER array, dimension (N)
* The permutation used to sort the contents of D into ascending
* order.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT
PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0,
$ TWO = 2.0D0, EIGHT = 8.0D0 )
* ..
* .. Local Scalars ..
*
INTEGER I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2
DOUBLE PRECISION C, EPS, S, T, TAU, TOL
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH, DLAPY2
EXTERNAL IDAMAX, DLAMCH, DLAPY2
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLACPY, DLAMRG, DROT, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN
INFO = -4
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN
INFO = -10
ELSE IF( LDQ2.LT.MAX( 1, N ) ) THEN
INFO = -14
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAED8', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
N1 = CUTPNT
N2 = N - N1
N1P1 = N1 + 1
*
IF( RHO.LT.ZERO ) THEN
CALL DSCAL( N2, MONE, Z( N1P1 ), 1 )
END IF
*
* Normalize z so that norm(z) = 1
*
T = ONE / SQRT( TWO )
DO 10 J = 1, N
INDX( J ) = J
10 CONTINUE
CALL DSCAL( N, T, Z, 1 )
RHO = ABS( TWO*RHO )
*
* Sort the eigenvalues into increasing order
*
DO 20 I = CUTPNT + 1, N
INDXQ( I ) = INDXQ( I ) + CUTPNT
20 CONTINUE
DO 30 I = 1, N
DLAMDA( I ) = D( INDXQ( I ) )
W( I ) = Z( INDXQ( I ) )
30 CONTINUE
I = 1
J = CUTPNT + 1
CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDX )
DO 40 I = 1, N
D( I ) = DLAMDA( INDX( I ) )
Z( I ) = W( INDX( I ) )
40 CONTINUE
*
* Calculate the allowable deflation tolerence
*
IMAX = IDAMAX( N, Z, 1 )
JMAX = IDAMAX( N, D, 1 )
EPS = DLAMCH( 'Epsilon' )
TOL = EIGHT*EPS*ABS( D( JMAX ) )
*
* If the rank-1 modifier is small enough, no more needs to be done
* except to reorganize Q so that its columns correspond with the
* elements in D.
*
IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN
K = 0
IF( ICOMPQ.EQ.0 ) THEN
DO 50 J = 1, N
PERM( J ) = INDXQ( INDX( J ) )
50 CONTINUE
ELSE
DO 60 J = 1, N
PERM( J ) = INDXQ( INDX( J ) )
CALL DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
60 CONTINUE
CALL DLACPY( 'A', QSIZ, N, Q2( 1, 1 ), LDQ2, Q( 1, 1 ),
$ LDQ )
END IF
RETURN
END IF
*
* If there are multiple eigenvalues then the problem deflates. Here
* the number of equal eigenvalues are found. As each equal
* eigenvalue is found, an elementary reflector is computed to rotate
* the corresponding eigensubspace so that the corresponding
* components of Z are zero in this new basis.
*
K = 0
GIVPTR = 0
K2 = N + 1
DO 70 J = 1, N
IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
INDXP( K2 ) = J
IF( J.EQ.N )
$ GO TO 110
ELSE
JLAM = J
GO TO 80
END IF
70 CONTINUE
80 CONTINUE
J = J + 1
IF( J.GT.N )
$ GO TO 100
IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
INDXP( K2 ) = J
ELSE
*
* Check if eigenvalues are close enough to allow deflation.
*
S = Z( JLAM )
C = Z( J )
*
* Find sqrt(a**2+b**2) without overflow or
* destructive underflow.
*
TAU = DLAPY2( C, S )
T = D( J ) - D( JLAM )
C = C / TAU
S = -S / TAU
IF( ABS( T*C*S ).LE.TOL ) THEN
*
* Deflation is possible.
*
Z( J ) = TAU
Z( JLAM ) = ZERO
*
* Record the appropriate Givens rotation
*
GIVPTR = GIVPTR + 1
GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) )
GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) )
GIVNUM( 1, GIVPTR ) = C
GIVNUM( 2, GIVPTR ) = S
IF( ICOMPQ.EQ.1 ) THEN
CALL DROT( QSIZ, Q( 1, INDXQ( INDX( JLAM ) ) ), 1,
$ Q( 1, INDXQ( INDX( J ) ) ), 1, C, S )
END IF
T = D( JLAM )*C*C + D( J )*S*S
D( J ) = D( JLAM )*S*S + D( J )*C*C
D( JLAM ) = T
K2 = K2 - 1
I = 1
90 CONTINUE
IF( K2+I.LE.N ) THEN
IF( D( JLAM ).LT.D( INDXP( K2+I ) ) ) THEN
INDXP( K2+I-1 ) = INDXP( K2+I )
INDXP( K2+I ) = JLAM
I = I + 1
GO TO 90
ELSE
INDXP( K2+I-1 ) = JLAM
END IF
ELSE
INDXP( K2+I-1 ) = JLAM
END IF
JLAM = J
ELSE
K = K + 1
W( K ) = Z( JLAM )
DLAMDA( K ) = D( JLAM )
INDXP( K ) = JLAM
JLAM = J
END IF
END IF
GO TO 80
100 CONTINUE
*
* Record the last eigenvalue.
*
K = K + 1
W( K ) = Z( JLAM )
DLAMDA( K ) = D( JLAM )
INDXP( K ) = JLAM
*
110 CONTINUE
*
* Sort the eigenvalues and corresponding eigenvectors into DLAMDA
* and Q2 respectively. The eigenvalues/vectors which were not
* deflated go into the first K slots of DLAMDA and Q2 respectively,
* while those which were deflated go into the last N - K slots.
*
IF( ICOMPQ.EQ.0 ) THEN
DO 120 J = 1, N
JP = INDXP( J )
DLAMDA( J ) = D( JP )
PERM( J ) = INDXQ( INDX( JP ) )
120 CONTINUE
ELSE
DO 130 J = 1, N
JP = INDXP( J )
DLAMDA( J ) = D( JP )
PERM( J ) = INDXQ( INDX( JP ) )
CALL DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
130 CONTINUE
END IF
*
* The deflated eigenvalues and their corresponding vectors go back
* into the last N - K slots of D and Q respectively.
*
IF( K.LT.N ) THEN
IF( ICOMPQ.EQ.0 ) THEN
CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )
ELSE
CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )
CALL DLACPY( 'A', QSIZ, N-K, Q2( 1, K+1 ), LDQ2,
$ Q( 1, K+1 ), LDQ )
END IF
END IF
*
RETURN
*
* End of DLAED8
*
END
SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W,
$ S, LDS, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N
DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ),
$ W( * )
* ..
*
* Purpose
* =======
*
* DLAED9 finds the roots of the secular equation, as defined by the
* values in D, Z, and RHO, between KSTART and KSTOP. It makes the
* appropriate calls to DLAED4 and then stores the new matrix of
* eigenvectors for use in calculating the next level of Z vectors.
*
* Arguments
* =========
*
* K (input) INTEGER
* The number of terms in the rational function to be solved by
* DLAED4. K >= 0.
*
* KSTART (input) INTEGER
* KSTOP (input) INTEGER
* The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP
* are to be computed. 1 <= KSTART <= KSTOP <= K.
*
* N (input) INTEGER
* The number of rows and columns in the Q matrix.
* N >= K (delation may result in N > K).
*
* D (output) DOUBLE PRECISION array, dimension (N)
* D(I) contains the updated eigenvalues
* for KSTART <= I <= KSTOP.
*
* Q (workspace) DOUBLE PRECISION array, dimension (LDQ,N)
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max( 1, N ).
*
* RHO (input) DOUBLE PRECISION
* The value of the parameter in the rank one update equation.
* RHO >= 0 required.
*
* DLAMDA (input) DOUBLE PRECISION array, dimension (K)
* The first K elements of this array contain the old roots
* of the deflated updating problem. These are the poles
* of the secular equation.
*
* W (input) DOUBLE PRECISION array, dimension (K)
* The first K elements of this array contain the components
* of the deflation-adjusted updating vector.
*
* S (output) DOUBLE PRECISION array, dimension (LDS, K)
* Will contain the eigenvectors of the repaired matrix which
* will be stored for subsequent Z vector calculation and
* multiplied by the previously accumulated eigenvectors
* to update the system.
*
* LDS (input) INTEGER
* The leading dimension of S. LDS >= max( 1, K ).
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an eigenvalue did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION TEMP
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMC3, DNRM2
EXTERNAL DLAMC3, DNRM2
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLAED4, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( K.LT.0 ) THEN
INFO = -1
ELSE IF( KSTART.LT.1 .OR. KSTART.GT.MAX( 1, K ) ) THEN
INFO = -2
ELSE IF( MAX( 1, KSTOP ).LT.KSTART .OR. KSTOP.GT.MAX( 1, K ) )
$ THEN
INFO = -3
ELSE IF( N.LT.K ) THEN
INFO = -4
ELSE IF( LDQ.LT.MAX( 1, K ) ) THEN
INFO = -7
ELSE IF( LDS.LT.MAX( 1, K ) ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAED9', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( K.EQ.0 )
$ RETURN
*
* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
* be computed with high relative accuracy (barring over/underflow).
* This is a problem on machines without a guard digit in
* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
* which on any of these machines zeros out the bottommost
* bit of DLAMDA(I) if it is 1; this makes the subsequent
* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
* occurs. On binary machines with a guard digit (almost all
* machines) it does not change DLAMDA(I) at all. On hexadecimal
* and decimal machines with a guard digit, it slightly
* changes the bottommost bits of DLAMDA(I). It does not account
* for hexadecimal or decimal machines without guard digits
* (we know of none). We use a subroutine call to compute
* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating
* this code.
*
DO 10 I = 1, N
DLAMDA( I ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I )
10 CONTINUE
*
DO 20 J = KSTART, KSTOP
CALL DLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO )
*
* If the zero finder fails, the computation is terminated.
*
IF( INFO.NE.0 )
$ GO TO 120
20 CONTINUE
*
IF( K.EQ.1 .OR. K.EQ.2 ) THEN
DO 40 I = 1, K
DO 30 J = 1, K
S( J, I ) = Q( J, I )
30 CONTINUE
40 CONTINUE
GO TO 120
END IF
*
* Compute updated W.
*
CALL DCOPY( K, W, 1, S, 1 )
*
* Initialize W(I) = Q(I,I)
*
CALL DCOPY( K, Q, LDQ+1, W, 1 )
DO 70 J = 1, K
DO 50 I = 1, J - 1
W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
50 CONTINUE
DO 60 I = J + 1, K
W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
60 CONTINUE
70 CONTINUE
DO 80 I = 1, K
W( I ) = SIGN( SQRT( -W( I ) ), S( I, 1 ) )
80 CONTINUE
*
* Compute eigenvectors of the modified rank-1 modification.
*
DO 110 J = 1, K
DO 90 I = 1, K
Q( I, J ) = W( I ) / Q( I, J )
90 CONTINUE
TEMP = DNRM2( K, Q( 1, J ), 1 )
DO 100 I = 1, K
S( I, J ) = Q( I, J ) / TEMP
100 CONTINUE
110 CONTINUE
*
120 CONTINUE
RETURN
*
* End of DLAED9
*
END
SUBROUTINE DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,
$ GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER CURLVL, CURPBM, INFO, N, TLVLS
* ..
* .. Array Arguments ..
INTEGER GIVCOL( 2, * ), GIVPTR( * ), PERM( * ),
$ PRMPTR( * ), QPTR( * )
DOUBLE PRECISION GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * )
* ..
*
* Purpose
* =======
*
* DLAEDA computes the Z vector corresponding to the merge step in the
* CURLVLth step of the merge process with TLVLS steps for the CURPBMth
* problem.
*
* Arguments
* =========
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* TLVLS (input) INTEGER
* The total number of merging levels in the overall divide and
* conquer tree.
*
* CURLVL (input) INTEGER
* The current level in the overall merge routine,
* 0 <= curlvl <= tlvls.
*
* CURPBM (input) INTEGER
* The current problem in the current level in the overall
* merge routine (counting from upper left to lower right).
*
* PRMPTR (input) INTEGER array, dimension (N lg N)
* Contains a list of pointers which indicate where in PERM a
* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)
* indicates the size of the permutation and incidentally the
* size of the full, non-deflated problem.
*
* PERM (input) INTEGER array, dimension (N lg N)
* Contains the permutations (from deflation and sorting) to be
* applied to each eigenblock.
*
* GIVPTR (input) INTEGER array, dimension (N lg N)
* Contains a list of pointers which indicate where in GIVCOL a
* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)
* indicates the number of Givens rotations.
*
* GIVCOL (input) INTEGER array, dimension (2, N lg N)
* Each pair of numbers indicates a pair of columns to take place
* in a Givens rotation.
*
* GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N)
* Each number indicates the S value to be used in the
* corresponding Givens rotation.
*
* Q (input) DOUBLE PRECISION array, dimension (N**2)
* Contains the square eigenblocks from previous levels, the
* starting positions for blocks are given by QPTR.
*
* QPTR (input) INTEGER array, dimension (N+2)
* Contains a list of pointers which indicate where in Q an
* eigenblock is stored. SQRT( QPTR(i+1) - QPTR(i) ) indicates
* the size of the block.
*
* Z (output) DOUBLE PRECISION array, dimension (N)
* On output this vector contains the updating vector (the last
* row of the first sub-eigenvector matrix and the first row of
* the second sub-eigenvector matrix).
*
* ZTEMP (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
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
INTEGER BSIZ1, BSIZ2, CURR, I, K, MID, PSIZ1, PSIZ2,
$ PTR, ZPTR1
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMV, DROT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, INT, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( N.LT.0 ) THEN
INFO = -1
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAEDA', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Determine location of first number in second half.
*
MID = N / 2 + 1
*
* Gather last/first rows of appropriate eigenblocks into center of Z
*
PTR = 1
*
* Determine location of lowest level subproblem in the full storage
* scheme
*
CURR = PTR + CURPBM*2**CURLVL + 2**( CURLVL-1 ) - 1
*
* Determine size of these matrices. We add HALF to the value of
* the SQRT in case the machine underestimates one of these square
* roots.
*
BSIZ1 = INT( HALF+SQRT( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) )
BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+1 ) ) ) )
DO 10 K = 1, MID - BSIZ1 - 1
Z( K ) = ZERO
10 CONTINUE
CALL DCOPY( BSIZ1, Q( QPTR( CURR )+BSIZ1-1 ), BSIZ1,
$ Z( MID-BSIZ1 ), 1 )
CALL DCOPY( BSIZ2, Q( QPTR( CURR+1 ) ), BSIZ2, Z( MID ), 1 )
DO 20 K = MID + BSIZ2, N
Z( K ) = ZERO
20 CONTINUE
*
* Loop thru remaining levels 1 -> CURLVL applying the Givens
* rotations and permutation and then multiplying the center matrices
* against the current Z.
*
PTR = 2**TLVLS + 1
DO 70 K = 1, CURLVL - 1
CURR = PTR + CURPBM*2**( CURLVL-K ) + 2**( CURLVL-K-1 ) - 1
PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR )
PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 )
ZPTR1 = MID - PSIZ1
*
* Apply Givens at CURR and CURR+1
*
DO 30 I = GIVPTR( CURR ), GIVPTR( CURR+1 ) - 1
CALL DROT( 1, Z( ZPTR1+GIVCOL( 1, I )-1 ), 1,
$ Z( ZPTR1+GIVCOL( 2, I )-1 ), 1, GIVNUM( 1, I ),
$ GIVNUM( 2, I ) )
30 CONTINUE
DO 40 I = GIVPTR( CURR+1 ), GIVPTR( CURR+2 ) - 1
CALL DROT( 1, Z( MID-1+GIVCOL( 1, I ) ), 1,
$ Z( MID-1+GIVCOL( 2, I ) ), 1, GIVNUM( 1, I ),
$ GIVNUM( 2, I ) )
40 CONTINUE
PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR )
PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 )
DO 50 I = 0, PSIZ1 - 1
ZTEMP( I+1 ) = Z( ZPTR1+PERM( PRMPTR( CURR )+I )-1 )
50 CONTINUE
DO 60 I = 0, PSIZ2 - 1
ZTEMP( PSIZ1+I+1 ) = Z( MID+PERM( PRMPTR( CURR+1 )+I )-1 )
60 CONTINUE
*
* Multiply Blocks at CURR and CURR+1
*
* Determine size of these matrices. We add HALF to the value of
* the SQRT in case the machine underestimates one of these
* square roots.
*
BSIZ1 = INT( HALF+SQRT( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) )
BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+
$ 1 ) ) ) )
IF( BSIZ1.GT.0 ) THEN
CALL DGEMV( 'T', BSIZ1, BSIZ1, ONE, Q( QPTR( CURR ) ),
$ BSIZ1, ZTEMP( 1 ), 1, ZERO, Z( ZPTR1 ), 1 )
END IF
CALL DCOPY( PSIZ1-BSIZ1, ZTEMP( BSIZ1+1 ), 1, Z( ZPTR1+BSIZ1 ),
$ 1 )
IF( BSIZ2.GT.0 ) THEN
CALL DGEMV( 'T', BSIZ2, BSIZ2, ONE, Q( QPTR( CURR+1 ) ),
$ BSIZ2, ZTEMP( PSIZ1+1 ), 1, ZERO, Z( MID ), 1 )
END IF
CALL DCOPY( PSIZ2-BSIZ2, ZTEMP( PSIZ1+BSIZ2+1 ), 1,
$ Z( MID+BSIZ2 ), 1 )
*
PTR = PTR + 2**( TLVLS-K )
70 CONTINUE
*
RETURN
*
* End of DLAEDA
*
END
SUBROUTINE DLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B,
$ LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL NOINIT, RIGHTV
INTEGER INFO, LDB, LDH, N
DOUBLE PRECISION BIGNUM, EPS3, SMLNUM, WI, WR
* ..
* .. Array Arguments ..
DOUBLE PRECISION B( LDB, * ), H( LDH, * ), VI( * ), VR( * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* DLAEIN uses inverse iteration to find a right or left eigenvector
* corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg
* matrix H.
*
* Arguments
* =========
*
* RIGHTV (input) LOGICAL
* = .TRUE. : compute right eigenvector;
* = .FALSE.: compute left eigenvector.
*
* NOINIT (input) LOGICAL
* = .TRUE. : no initial vector supplied in (VR,VI).
* = .FALSE.: initial vector supplied in (VR,VI).
*
* N (input) INTEGER
* The order of the matrix H. N >= 0.
*
* H (input) DOUBLE PRECISION array, dimension (LDH,N)
* The upper Hessenberg matrix H.
*
* LDH (input) INTEGER
* The leading dimension of the array H. LDH >= max(1,N).
*
* WR (input) DOUBLE PRECISION
* WI (input) DOUBLE PRECISION
* The real and imaginary parts of the eigenvalue of H whose
* corresponding right or left eigenvector is to be computed.
*
* VR (input/output) DOUBLE PRECISION array, dimension (N)
* VI (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain
* a real starting vector for inverse iteration using the real
* eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI
* must contain the real and imaginary parts of a complex
* starting vector for inverse iteration using the complex
* eigenvalue (WR,WI); otherwise VR and VI need not be set.
* On exit, if WI = 0.0 (real eigenvalue), VR contains the
* computed real eigenvector; if WI.ne.0.0 (complex eigenvalue),
* VR and VI contain the real and imaginary parts of the
* computed complex eigenvector. The eigenvector is normalized
* so that the component of largest magnitude has magnitude 1;
* here the magnitude of a complex number (x,y) is taken to be
* |x| + |y|.
* VI is not referenced if WI = 0.0.
*
* B (workspace) DOUBLE PRECISION array, dimension (LDB,N)
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= N+1.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* EPS3 (input) DOUBLE PRECISION
* A small machine-dependent value which is used to perturb
* close eigenvalues, and to replace zero pivots.
*
* SMLNUM (input) DOUBLE PRECISION
* A machine-dependent value close to the underflow threshold.
*
* BIGNUM (input) DOUBLE PRECISION
* A machine-dependent value close to the overflow threshold.
*
* INFO (output) INTEGER
* = 0: successful exit
* = 1: inverse iteration did not converge; VR is set to the
* last iterate, and so is VI if WI.ne.0.0.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TENTH
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TENTH = 1.0D-1 )
* ..
* .. Local Scalars ..
CHARACTER NORMIN, TRANS
INTEGER I, I1, I2, I3, IERR, ITS, J
DOUBLE PRECISION ABSBII, ABSBJJ, EI, EJ, GROWTO, NORM, NRMSML,
$ REC, ROOTN, SCALE, TEMP, VCRIT, VMAX, VNORM, W,
$ W1, X, XI, XR, Y
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DASUM, DLAPY2, DNRM2
EXTERNAL IDAMAX, DASUM, DLAPY2, DNRM2
* ..
* .. External Subroutines ..
EXTERNAL DLADIV, DLATRS, DSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
*
* GROWTO is the threshold used in the acceptance test for an
* eigenvector.
*
ROOTN = SQRT( DBLE( N ) )
GROWTO = TENTH / ROOTN
NRMSML = MAX( ONE, EPS3*ROOTN )*SMLNUM
*
* Form B = H - (WR,WI)*I (except that the subdiagonal elements and
* the imaginary parts of the diagonal elements are not stored).
*
DO 20 J = 1, N
DO 10 I = 1, J - 1
B( I, J ) = H( I, J )
10 CONTINUE
B( J, J ) = H( J, J ) - WR
20 CONTINUE
*
IF( WI.EQ.ZERO ) THEN
*
* Real eigenvalue.
*
IF( NOINIT ) THEN
*
* Set initial vector.
*
DO 30 I = 1, N
VR( I ) = EPS3
30 CONTINUE
ELSE
*
* Scale supplied initial vector.
*
VNORM = DNRM2( N, VR, 1 )
CALL DSCAL( N, ( EPS3*ROOTN ) / MAX( VNORM, NRMSML ), VR,
$ 1 )
END IF
*
IF( RIGHTV ) THEN
*
* LU decomposition with partial pivoting of B, replacing zero
* pivots by EPS3.
*
DO 60 I = 1, N - 1
EI = H( I+1, I )
IF( ABS( B( I, I ) ).LT.ABS( EI ) ) THEN
*
* Interchange rows and eliminate.
*
X = B( I, I ) / EI
B( I, I ) = EI
DO 40 J = I + 1, N
TEMP = B( I+1, J )
B( I+1, J ) = B( I, J ) - X*TEMP
B( I, J ) = TEMP
40 CONTINUE
ELSE
*
* Eliminate without interchange.
*
IF( B( I, I ).EQ.ZERO )
$ B( I, I ) = EPS3
X = EI / B( I, I )
IF( X.NE.ZERO ) THEN
DO 50 J = I + 1, N
B( I+1, J ) = B( I+1, J ) - X*B( I, J )
50 CONTINUE
END IF
END IF
60 CONTINUE
IF( B( N, N ).EQ.ZERO )
$ B( N, N ) = EPS3
*
TRANS = 'N'
*
ELSE
*
* UL decomposition with partial pivoting of B, replacing zero
* pivots by EPS3.
*
DO 90 J = N, 2, -1
EJ = H( J, J-1 )
IF( ABS( B( J, J ) ).LT.ABS( EJ ) ) THEN
*
* Interchange columns and eliminate.
*
X = B( J, J ) / EJ
B( J, J ) = EJ
DO 70 I = 1, J - 1
TEMP = B( I, J-1 )
B( I, J-1 ) = B( I, J ) - X*TEMP
B( I, J ) = TEMP
70 CONTINUE
ELSE
*
* Eliminate without interchange.
*
IF( B( J, J ).EQ.ZERO )
$ B( J, J ) = EPS3
X = EJ / B( J, J )
IF( X.NE.ZERO ) THEN
DO 80 I = 1, J - 1
B( I, J-1 ) = B( I, J-1 ) - X*B( I, J )
80 CONTINUE
END IF
END IF
90 CONTINUE
IF( B( 1, 1 ).EQ.ZERO )
$ B( 1, 1 ) = EPS3
*
TRANS = 'T'
*
END IF
*
NORMIN = 'N'
DO 110 ITS = 1, N
*
* Solve U*x = scale*v for a right eigenvector
* or U'*x = scale*v for a left eigenvector,
* overwriting x on v.
*
CALL DLATRS( 'Upper', TRANS, 'Nonunit', NORMIN, N, B, LDB,
$ VR, SCALE, WORK, IERR )
NORMIN = 'Y'
*
* Test for sufficient growth in the norm of v.
*
VNORM = DASUM( N, VR, 1 )
IF( VNORM.GE.GROWTO*SCALE )
$ GO TO 120
*
* Choose new orthogonal starting vector and try again.
*
TEMP = EPS3 / ( ROOTN+ONE )
VR( 1 ) = EPS3
DO 100 I = 2, N
VR( I ) = TEMP
100 CONTINUE
VR( N-ITS+1 ) = VR( N-ITS+1 ) - EPS3*ROOTN
110 CONTINUE
*
* Failure to find eigenvector in N iterations.
*
INFO = 1
*
120 CONTINUE
*
* Normalize eigenvector.
*
I = IDAMAX( N, VR, 1 )
CALL DSCAL( N, ONE / ABS( VR( I ) ), VR, 1 )
ELSE
*
* Complex eigenvalue.
*
IF( NOINIT ) THEN
*
* Set initial vector.
*
DO 130 I = 1, N
VR( I ) = EPS3
VI( I ) = ZERO
130 CONTINUE
ELSE
*
* Scale supplied initial vector.
*
NORM = DLAPY2( DNRM2( N, VR, 1 ), DNRM2( N, VI, 1 ) )
REC = ( EPS3*ROOTN ) / MAX( NORM, NRMSML )
CALL DSCAL( N, REC, VR, 1 )
CALL DSCAL( N, REC, VI, 1 )
END IF
*
IF( RIGHTV ) THEN
*
* LU decomposition with partial pivoting of B, replacing zero
* pivots by EPS3.
*
* The imaginary part of the (i,j)-th element of U is stored in
* B(j+1,i).
*
B( 2, 1 ) = -WI
DO 140 I = 2, N
B( I+1, 1 ) = ZERO
140 CONTINUE
*
DO 170 I = 1, N - 1
ABSBII = DLAPY2( B( I, I ), B( I+1, I ) )
EI = H( I+1, I )
IF( ABSBII.LT.ABS( EI ) ) THEN
*
* Interchange rows and eliminate.
*
XR = B( I, I ) / EI
XI = B( I+1, I ) / EI
B( I, I ) = EI
B( I+1, I ) = ZERO
DO 150 J = I + 1, N
TEMP = B( I+1, J )
B( I+1, J ) = B( I, J ) - XR*TEMP
B( J+1, I+1 ) = B( J+1, I ) - XI*TEMP
B( I, J ) = TEMP
B( J+1, I ) = ZERO
150 CONTINUE
B( I+2, I ) = -WI
B( I+1, I+1 ) = B( I+1, I+1 ) - XI*WI
B( I+2, I+1 ) = B( I+2, I+1 ) + XR*WI
ELSE
*
* Eliminate without interchanging rows.
*
IF( ABSBII.EQ.ZERO ) THEN
B( I, I ) = EPS3
B( I+1, I ) = ZERO
ABSBII = EPS3
END IF
EI = ( EI / ABSBII ) / ABSBII
XR = B( I, I )*EI
XI = -B( I+1, I )*EI
DO 160 J = I + 1, N
B( I+1, J ) = B( I+1, J ) - XR*B( I, J ) +
$ XI*B( J+1, I )
B( J+1, I+1 ) = -XR*B( J+1, I ) - XI*B( I, J )
160 CONTINUE
B( I+2, I+1 ) = B( I+2, I+1 ) - WI
END IF
*
* Compute 1-norm of offdiagonal elements of i-th row.
*
WORK( I ) = DASUM( N-I, B( I, I+1 ), LDB ) +
$ DASUM( N-I, B( I+2, I ), 1 )
170 CONTINUE
IF( B( N, N ).EQ.ZERO .AND. B( N+1, N ).EQ.ZERO )
$ B( N, N ) = EPS3
WORK( N ) = ZERO
*
I1 = N
I2 = 1
I3 = -1
ELSE
*
* UL decomposition with partial pivoting of conjg(B),
* replacing zero pivots by EPS3.
*
* The imaginary part of the (i,j)-th element of U is stored in
* B(j+1,i).
*
B( N+1, N ) = WI
DO 180 J = 1, N - 1
B( N+1, J ) = ZERO
180 CONTINUE
*
DO 210 J = N, 2, -1
EJ = H( J, J-1 )
ABSBJJ = DLAPY2( B( J, J ), B( J+1, J ) )
IF( ABSBJJ.LT.ABS( EJ ) ) THEN
*
* Interchange columns and eliminate
*
XR = B( J, J ) / EJ
XI = B( J+1, J ) / EJ
B( J, J ) = EJ
B( J+1, J ) = ZERO
DO 190 I = 1, J - 1
TEMP = B( I, J-1 )
B( I, J-1 ) = B( I, J ) - XR*TEMP
B( J, I ) = B( J+1, I ) - XI*TEMP
B( I, J ) = TEMP
B( J+1, I ) = ZERO
190 CONTINUE
B( J+1, J-1 ) = WI
B( J-1, J-1 ) = B( J-1, J-1 ) + XI*WI
B( J, J-1 ) = B( J, J-1 ) - XR*WI
ELSE
*
* Eliminate without interchange.
*
IF( ABSBJJ.EQ.ZERO ) THEN
B( J, J ) = EPS3
B( J+1, J ) = ZERO
ABSBJJ = EPS3
END IF
EJ = ( EJ / ABSBJJ ) / ABSBJJ
XR = B( J, J )*EJ
XI = -B( J+1, J )*EJ
DO 200 I = 1, J - 1
B( I, J-1 ) = B( I, J-1 ) - XR*B( I, J ) +
$ XI*B( J+1, I )
B( J, I ) = -XR*B( J+1, I ) - XI*B( I, J )
200 CONTINUE
B( J, J-1 ) = B( J, J-1 ) + WI
END IF
*
* Compute 1-norm of offdiagonal elements of j-th column.
*
WORK( J ) = DASUM( J-1, B( 1, J ), 1 ) +
$ DASUM( J-1, B( J+1, 1 ), LDB )
210 CONTINUE
IF( B( 1, 1 ).EQ.ZERO .AND. B( 2, 1 ).EQ.ZERO )
$ B( 1, 1 ) = EPS3
WORK( 1 ) = ZERO
*
I1 = 1
I2 = N
I3 = 1
END IF
*
DO 270 ITS = 1, N
SCALE = ONE
VMAX = ONE
VCRIT = BIGNUM
*
* Solve U*(xr,xi) = scale*(vr,vi) for a right eigenvector,
* or U'*(xr,xi) = scale*(vr,vi) for a left eigenvector,
* overwriting (xr,xi) on (vr,vi).
*
DO 250 I = I1, I2, I3
*
IF( WORK( I ).GT.VCRIT ) THEN
REC = ONE / VMAX
CALL DSCAL( N, REC, VR, 1 )
CALL DSCAL( N, REC, VI, 1 )
SCALE = SCALE*REC
VMAX = ONE
VCRIT = BIGNUM
END IF
*
XR = VR( I )
XI = VI( I )
IF( RIGHTV ) THEN
DO 220 J = I + 1, N
XR = XR - B( I, J )*VR( J ) + B( J+1, I )*VI( J )
XI = XI - B( I, J )*VI( J ) - B( J+1, I )*VR( J )
220 CONTINUE
ELSE
DO 230 J = 1, I - 1
XR = XR - B( J, I )*VR( J ) + B( I+1, J )*VI( J )
XI = XI - B( J, I )*VI( J ) - B( I+1, J )*VR( J )
230 CONTINUE
END IF
*
W = ABS( B( I, I ) ) + ABS( B( I+1, I ) )
IF( W.GT.SMLNUM ) THEN
IF( W.LT.ONE ) THEN
W1 = ABS( XR ) + ABS( XI )
IF( W1.GT.W*BIGNUM ) THEN
REC = ONE / W1
CALL DSCAL( N, REC, VR, 1 )
CALL DSCAL( N, REC, VI, 1 )
XR = VR( I )
XI = VI( I )
SCALE = SCALE*REC
VMAX = VMAX*REC
END IF
END IF
*
* Divide by diagonal element of B.
*
CALL DLADIV( XR, XI, B( I, I ), B( I+1, I ), VR( I ),
$ VI( I ) )
VMAX = MAX( ABS( VR( I ) )+ABS( VI( I ) ), VMAX )
VCRIT = BIGNUM / VMAX
ELSE
DO 240 J = 1, N
VR( J ) = ZERO
VI( J ) = ZERO
240 CONTINUE
VR( I ) = ONE
VI( I ) = ONE
SCALE = ZERO
VMAX = ONE
VCRIT = BIGNUM
END IF
250 CONTINUE
*
* Test for sufficient growth in the norm of (VR,VI).
*
VNORM = DASUM( N, VR, 1 ) + DASUM( N, VI, 1 )
IF( VNORM.GE.GROWTO*SCALE )
$ GO TO 280
*
* Choose a new orthogonal starting vector and try again.
*
Y = EPS3 / ( ROOTN+ONE )
VR( 1 ) = EPS3
VI( 1 ) = ZERO
*
DO 260 I = 2, N
VR( I ) = Y
VI( I ) = ZERO
260 CONTINUE
VR( N-ITS+1 ) = VR( N-ITS+1 ) - EPS3*ROOTN
270 CONTINUE
*
* Failure to find eigenvector in N iterations
*
INFO = 1
*
280 CONTINUE
*
* Normalize eigenvector.
*
VNORM = ZERO
DO 290 I = 1, N
VNORM = MAX( VNORM, ABS( VR( I ) )+ABS( VI( I ) ) )
290 CONTINUE
CALL DSCAL( N, ONE / VNORM, VR, 1 )
CALL DSCAL( N, ONE / VNORM, VI, 1 )
*
END IF
*
RETURN
*
* End of DLAEIN
*
END
SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1
* ..
*
* Purpose
* =======
*
* DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix
* [ A B ]
* [ B C ].
* On return, RT1 is the eigenvalue of larger absolute value, RT2 is the
* eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right
* eigenvector for RT1, giving the decomposition
*
* [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ]
* [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ].
*
* Arguments
* =========
*
* A (input) DOUBLE PRECISION
* The (1,1) element of the 2-by-2 matrix.
*
* B (input) DOUBLE PRECISION
* The (1,2) element and the conjugate of the (2,1) element of
* the 2-by-2 matrix.
*
* C (input) DOUBLE PRECISION
* The (2,2) element of the 2-by-2 matrix.
*
* RT1 (output) DOUBLE PRECISION
* The eigenvalue of larger absolute value.
*
* RT2 (output) DOUBLE PRECISION
* The eigenvalue of smaller absolute value.
*
* CS1 (output) DOUBLE PRECISION
* SN1 (output) DOUBLE PRECISION
* The vector (CS1, SN1) is a unit right eigenvector for RT1.
*
* Further Details
* ===============
*
* RT1 is accurate to a few ulps barring over/underflow.
*
* RT2 may be inaccurate if there is massive cancellation in the
* determinant A*C-B*B; higher precision or correctly rounded or
* correctly truncated arithmetic would be needed to compute RT2
* accurately in all cases.
*
* CS1 and SN1 are accurate to a few ulps barring over/underflow.
*
* Overflow is possible only if RT1 is within a factor of 5 of overflow.
* Underflow is harmless if the input data is 0 or exceeds
* underflow_threshold / macheps.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D0 )
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION HALF
PARAMETER ( HALF = 0.5D0 )
* ..
* .. Local Scalars ..
INTEGER SGN1, SGN2
DOUBLE PRECISION AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM,
$ TB, TN
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SQRT
* ..
* .. Executable Statements ..
*
* Compute the eigenvalues
*
SM = A + C
DF = A - C
ADF = ABS( DF )
TB = B + B
AB = ABS( TB )
IF( ABS( A ).GT.ABS( C ) ) THEN
ACMX = A
ACMN = C
ELSE
ACMX = C
ACMN = A
END IF
IF( ADF.GT.AB ) THEN
RT = ADF*SQRT( ONE+( AB / ADF )**2 )
ELSE IF( ADF.LT.AB ) THEN
RT = AB*SQRT( ONE+( ADF / AB )**2 )
ELSE
*
* Includes case AB=ADF=0
*
RT = AB*SQRT( TWO )
END IF
IF( SM.LT.ZERO ) THEN
RT1 = HALF*( SM-RT )
SGN1 = -1
*
* Order of execution important.
* To get fully accurate smaller eigenvalue,
* next line needs to be executed in higher precision.
*
RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
ELSE IF( SM.GT.ZERO ) THEN
RT1 = HALF*( SM+RT )
SGN1 = 1
*
* Order of execution important.
* To get fully accurate smaller eigenvalue,
* next line needs to be executed in higher precision.
*
RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
ELSE
*
* Includes case RT1 = RT2 = 0
*
RT1 = HALF*RT
RT2 = -HALF*RT
SGN1 = 1
END IF
*
* Compute the eigenvector
*
IF( DF.GE.ZERO ) THEN
CS = DF + RT
SGN2 = 1
ELSE
CS = DF - RT
SGN2 = -1
END IF
ACS = ABS( CS )
IF( ACS.GT.AB ) THEN
CT = -TB / CS
SN1 = ONE / SQRT( ONE+CT*CT )
CS1 = CT*SN1
ELSE
IF( AB.EQ.ZERO ) THEN
CS1 = ONE
SN1 = ZERO
ELSE
TN = -CS / TB
CS1 = ONE / SQRT( ONE+TN*TN )
SN1 = TN*CS1
END IF
END IF
IF( SGN1.EQ.SGN2 ) THEN
TN = CS1
CS1 = -SN1
SN1 = TN
END IF
RETURN
*
* End of DLAEV2
*
END
SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK,
$ INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL WANTQ
INTEGER INFO, J1, LDQ, LDT, N, N1, N2
* ..
* .. Array Arguments ..
DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in
* an upper quasi-triangular matrix T by an orthogonal similarity
* transformation.
*
* T must be in Schur canonical form, that is, block upper triangular
* with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block
* has its diagonal elemnts equal and its off-diagonal elements of
* opposite sign.
*
* Arguments
* =========
*
* WANTQ (input) LOGICAL
* = .TRUE. : accumulate the transformation in the matrix Q;
* = .FALSE.: do not accumulate the transformation.
*
* N (input) INTEGER
* The order of the matrix T. N >= 0.
*
* T (input/output) DOUBLE PRECISION array, dimension (LDT,N)
* On entry, the upper quasi-triangular matrix T, in Schur
* canonical form.
* On exit, the updated matrix T, again in Schur canonical form.
*
* LDT (input) INTEGER
* The leading dimension of the array T. LDT >= max(1,N).
*
* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
* On entry, if WANTQ is .TRUE., the orthogonal matrix Q.
* On exit, if WANTQ is .TRUE., the updated matrix Q.
* If WANTQ is .FALSE., Q is not referenced.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q.
* LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N.
*
* J1 (input) INTEGER
* The index of the first row of the first block T11.
*
* N1 (input) INTEGER
* The order of the first block T11. N1 = 0, 1 or 2.
*
* N2 (input) INTEGER
* The order of the second block T22. N2 = 0, 1 or 2.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* = 1: the transformed matrix T would be too far from Schur
* form; the blocks are not swapped and T and Q are
* unchanged.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION TEN
PARAMETER ( TEN = 1.0D+1 )
INTEGER LDD, LDX
PARAMETER ( LDD = 4, LDX = 2 )
* ..
* .. Local Scalars ..
INTEGER IERR, J2, J3, J4, K, ND
DOUBLE PRECISION CS, DNORM, EPS, SCALE, SMLNUM, SN, T11, T22,
$ T33, TAU, TAU1, TAU2, TEMP, THRESH, WI1, WI2,
$ WR1, WR2, XNORM
* ..
* .. Local Arrays ..
DOUBLE PRECISION D( LDD, 4 ), U( 3 ), U1( 3 ), U2( 3 ),
$ X( LDX, 2 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DLACPY, DLANV2, DLARFG, DLARFX, DLARTG, DLASY2,
$ DROT
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Quick return if possible
*
IF( N.EQ.0 .OR. N1.EQ.0 .OR. N2.EQ.0 )
$ RETURN
IF( J1+N1.GT.N )
$ RETURN
*
J2 = J1 + 1
J3 = J1 + 2
J4 = J1 + 3
*
IF( N1.EQ.1 .AND. N2.EQ.1 ) THEN
*
* Swap two 1-by-1 blocks.
*
T11 = T( J1, J1 )
T22 = T( J2, J2 )
*
* Determine the transformation to perform the interchange.
*
CALL DLARTG( T( J1, J2 ), T22-T11, CS, SN, TEMP )
*
* Apply transformation to the matrix T.
*
IF( J3.LE.N )
$ CALL DROT( N-J1-1, T( J1, J3 ), LDT, T( J2, J3 ), LDT, CS,
$ SN )
CALL DROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN )
*
T( J1, J1 ) = T22
T( J2, J2 ) = T11
*
IF( WANTQ ) THEN
*
* Accumulate transformation in the matrix Q.
*
CALL DROT( N, Q( 1, J1 ), 1, Q( 1, J2 ), 1, CS, SN )
END IF
*
ELSE
*
* Swapping involves at least one 2-by-2 block.
*
* Copy the diagonal block of order N1+N2 to the local array D
* and compute its norm.
*
ND = N1 + N2
CALL DLACPY( 'Full', ND, ND, T( J1, J1 ), LDT, D, LDD )
DNORM = DLANGE( 'Max', ND, ND, D, LDD, WORK )
*
* Compute machine-dependent threshold for test for accepting
* swap.
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' ) / EPS
THRESH = MAX( TEN*EPS*DNORM, SMLNUM )
*
* Solve T11*X - X*T22 = scale*T12 for X.
*
CALL DLASY2( .FALSE., .FALSE., -1, N1, N2, D, LDD,
$ D( N1+1, N1+1 ), LDD, D( 1, N1+1 ), LDD, SCALE, X,
$ LDX, XNORM, IERR )
*
* Swap the adjacent diagonal blocks.
*
K = N1 + N1 + N2 - 3
GO TO ( 10, 20, 30 )K
*
10 CONTINUE
*
* N1 = 1, N2 = 2: generate elementary reflector H so that:
*
* ( scale, X11, X12 ) H = ( 0, 0, * )
*
U( 1 ) = SCALE
U( 2 ) = X( 1, 1 )
U( 3 ) = X( 1, 2 )
CALL DLARFG( 3, U( 3 ), U, 1, TAU )
U( 3 ) = ONE
T11 = T( J1, J1 )
*
* Perform swap provisionally on diagonal block in D.
*
CALL DLARFX( 'L', 3, 3, U, TAU, D, LDD, WORK )
CALL DLARFX( 'R', 3, 3, U, TAU, D, LDD, WORK )
*
* Test whether to reject swap.
*
IF( MAX( ABS( D( 3, 1 ) ), ABS( D( 3, 2 ) ), ABS( D( 3,
$ 3 )-T11 ) ).GT.THRESH )GO TO 50
*
* Accept swap: apply transformation to the entire matrix T.
*
CALL DLARFX( 'L', 3, N-J1+1, U, TAU, T( J1, J1 ), LDT, WORK )
CALL DLARFX( 'R', J2, 3, U, TAU, T( 1, J1 ), LDT, WORK )
*
T( J3, J1 ) = ZERO
T( J3, J2 ) = ZERO
T( J3, J3 ) = T11
*
IF( WANTQ ) THEN
*
* Accumulate transformation in the matrix Q.
*
CALL DLARFX( 'R', N, 3, U, TAU, Q( 1, J1 ), LDQ, WORK )
END IF
GO TO 40
*
20 CONTINUE
*
* N1 = 2, N2 = 1: generate elementary reflector H so that:
*
* H ( -X11 ) = ( * )
* ( -X21 ) = ( 0 )
* ( scale ) = ( 0 )
*
U( 1 ) = -X( 1, 1 )
U( 2 ) = -X( 2, 1 )
U( 3 ) = SCALE
CALL DLARFG( 3, U( 1 ), U( 2 ), 1, TAU )
U( 1 ) = ONE
T33 = T( J3, J3 )
*
* Perform swap provisionally on diagonal block in D.
*
CALL DLARFX( 'L', 3, 3, U, TAU, D, LDD, WORK )
CALL DLARFX( 'R', 3, 3, U, TAU, D, LDD, WORK )
*
* Test whether to reject swap.
*
IF( MAX( ABS( D( 2, 1 ) ), ABS( D( 3, 1 ) ), ABS( D( 1,
$ 1 )-T33 ) ).GT.THRESH )GO TO 50
*
* Accept swap: apply transformation to the entire matrix T.
*
CALL DLARFX( 'R', J3, 3, U, TAU, T( 1, J1 ), LDT, WORK )
CALL DLARFX( 'L', 3, N-J1, U, TAU, T( J1, J2 ), LDT, WORK )
*
T( J1, J1 ) = T33
T( J2, J1 ) = ZERO
T( J3, J1 ) = ZERO
*
IF( WANTQ ) THEN
*
* Accumulate transformation in the matrix Q.
*
CALL DLARFX( 'R', N, 3, U, TAU, Q( 1, J1 ), LDQ, WORK )
END IF
GO TO 40
*
30 CONTINUE
*
* N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so
* that:
*
* H(2) H(1) ( -X11 -X12 ) = ( * * )
* ( -X21 -X22 ) ( 0 * )
* ( scale 0 ) ( 0 0 )
* ( 0 scale ) ( 0 0 )
*
U1( 1 ) = -X( 1, 1 )
U1( 2 ) = -X( 2, 1 )
U1( 3 ) = SCALE
CALL DLARFG( 3, U1( 1 ), U1( 2 ), 1, TAU1 )
U1( 1 ) = ONE
*
TEMP = -TAU1*( X( 1, 2 )+U1( 2 )*X( 2, 2 ) )
U2( 1 ) = -TEMP*U1( 2 ) - X( 2, 2 )
U2( 2 ) = -TEMP*U1( 3 )
U2( 3 ) = SCALE
CALL DLARFG( 3, U2( 1 ), U2( 2 ), 1, TAU2 )
U2( 1 ) = ONE
*
* Perform swap provisionally on diagonal block in D.
*
CALL DLARFX( 'L', 3, 4, U1, TAU1, D, LDD, WORK )
CALL DLARFX( 'R', 4, 3, U1, TAU1, D, LDD, WORK )
CALL DLARFX( 'L', 3, 4, U2, TAU2, D( 2, 1 ), LDD, WORK )
CALL DLARFX( 'R', 4, 3, U2, TAU2, D( 1, 2 ), LDD, WORK )
*
* Test whether to reject swap.
*
IF( MAX( ABS( D( 3, 1 ) ), ABS( D( 3, 2 ) ), ABS( D( 4, 1 ) ),
$ ABS( D( 4, 2 ) ) ).GT.THRESH )GO TO 50
*
* Accept swap: apply transformation to the entire matrix T.
*
CALL DLARFX( 'L', 3, N-J1+1, U1, TAU1, T( J1, J1 ), LDT, WORK )
CALL DLARFX( 'R', J4, 3, U1, TAU1, T( 1, J1 ), LDT, WORK )
CALL DLARFX( 'L', 3, N-J1+1, U2, TAU2, T( J2, J1 ), LDT, WORK )
CALL DLARFX( 'R', J4, 3, U2, TAU2, T( 1, J2 ), LDT, WORK )
*
T( J3, J1 ) = ZERO
T( J3, J2 ) = ZERO
T( J4, J1 ) = ZERO
T( J4, J2 ) = ZERO
*
IF( WANTQ ) THEN
*
* Accumulate transformation in the matrix Q.
*
CALL DLARFX( 'R', N, 3, U1, TAU1, Q( 1, J1 ), LDQ, WORK )
CALL DLARFX( 'R', N, 3, U2, TAU2, Q( 1, J2 ), LDQ, WORK )
END IF
*
40 CONTINUE
*
IF( N2.EQ.2 ) THEN
*
* Standardize new 2-by-2 block T11
*
CALL DLANV2( T( J1, J1 ), T( J1, J2 ), T( J2, J1 ),
$ T( J2, J2 ), WR1, WI1, WR2, WI2, CS, SN )
CALL DROT( N-J1-1, T( J1, J1+2 ), LDT, T( J2, J1+2 ), LDT,
$ CS, SN )
CALL DROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN )
IF( WANTQ )
$ CALL DROT( N, Q( 1, J1 ), 1, Q( 1, J2 ), 1, CS, SN )
END IF
*
IF( N1.EQ.2 ) THEN
*
* Standardize new 2-by-2 block T22
*
J3 = J1 + N2
J4 = J3 + 1
CALL DLANV2( T( J3, J3 ), T( J3, J4 ), T( J4, J3 ),
$ T( J4, J4 ), WR1, WI1, WR2, WI2, CS, SN )
IF( J3+2.LE.N )
$ CALL DROT( N-J3-1, T( J3, J3+2 ), LDT, T( J4, J3+2 ),
$ LDT, CS, SN )
CALL DROT( J3-1, T( 1, J3 ), 1, T( 1, J4 ), 1, CS, SN )
IF( WANTQ )
$ CALL DROT( N, Q( 1, J3 ), 1, Q( 1, J4 ), 1, CS, SN )
END IF
*
END IF
RETURN
*
* Exit with INFO = 1 if swap was rejected.
*
50 CONTINUE
INFO = 1
RETURN
*
* End of DLAEXC
*
END
SUBROUTINE DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1,
$ WR2, WI )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDB
DOUBLE PRECISION SAFMIN, SCALE1, SCALE2, WI, WR1, WR2
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* DLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue
* problem A - w B, with scaling as necessary to avoid over-/underflow.
*
* The scaling factor "s" results in a modified eigenvalue equation
*
* s A - w B
*
* where s is a non-negative scaling factor chosen so that w, w B,
* and s A do not overflow and, if possible, do not underflow, either.
*
* Arguments
* =========
*
* A (input) DOUBLE PRECISION array, dimension (LDA, 2)
* On entry, the 2 x 2 matrix A. It is assumed that its 1-norm
* is less than 1/SAFMIN. Entries less than
* sqrt(SAFMIN)*norm(A) are subject to being treated as zero.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= 2.
*
* B (input) DOUBLE PRECISION array, dimension (LDB, 2)
* On entry, the 2 x 2 upper triangular matrix B. It is
* assumed that the one-norm of B is less than 1/SAFMIN. The
* diagonals should be at least sqrt(SAFMIN) times the largest
* element of B (in absolute value); if a diagonal is smaller
* than that, then +/- sqrt(SAFMIN) will be used instead of
* that diagonal.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= 2.
*
* SAFMIN (input) DOUBLE PRECISION
* The smallest positive number s.t. 1/SAFMIN does not
* overflow. (This should always be DLAMCH('S') -- it is an
* argument in order to avoid having to call DLAMCH frequently.)
*
* SCALE1 (output) DOUBLE PRECISION
* A scaling factor used to avoid over-/underflow in the
* eigenvalue equation which defines the first eigenvalue. If
* the eigenvalues are complex, then the eigenvalues are
* ( WR1 +/- WI i ) / SCALE1 (which may lie outside the
* exponent range of the machine), SCALE1=SCALE2, and SCALE1
* will always be positive. If the eigenvalues are real, then
* the first (real) eigenvalue is WR1 / SCALE1 , but this may
* overflow or underflow, and in fact, SCALE1 may be zero or
* less than the underflow threshhold if the exact eigenvalue
* is sufficiently large.
*
* SCALE2 (output) DOUBLE PRECISION
* A scaling factor used to avoid over-/underflow in the
* eigenvalue equation which defines the second eigenvalue. If
* the eigenvalues are complex, then SCALE2=SCALE1. If the
* eigenvalues are real, then the second (real) eigenvalue is
* WR2 / SCALE2 , but this may overflow or underflow, and in
* fact, SCALE2 may be zero or less than the underflow
* threshhold if the exact eigenvalue is sufficiently large.
*
* WR1 (output) DOUBLE PRECISION
* If the eigenvalue is real, then WR1 is SCALE1 times the
* eigenvalue closest to the (2,2) element of A B**(-1). If the
* eigenvalue is complex, then WR1=WR2 is SCALE1 times the real
* part of the eigenvalues.
*
* WR2 (output) DOUBLE PRECISION
* If the eigenvalue is real, then WR2 is SCALE2 times the
* other eigenvalue. If the eigenvalue is complex, then
* WR1=WR2 is SCALE1 times the real part of the eigenvalues.
*
* WI (output) DOUBLE PRECISION
* If the eigenvalue is real, then WI is zero. If the
* eigenvalue is complex, then WI is SCALE1 times the imaginary
* part of the eigenvalues. WI will always be non-negative.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
DOUBLE PRECISION HALF
PARAMETER ( HALF = ONE / TWO )
DOUBLE PRECISION FUZZY1
PARAMETER ( FUZZY1 = ONE+1.0D-5 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION A11, A12, A21, A22, ABI22, ANORM, AS11, AS12,
$ AS22, ASCALE, B11, B12, B22, BINV11, BINV22,
$ BMIN, BNORM, BSCALE, BSIZE, C1, C2, C3, C4, C5,
$ DIFF, DISCR, PP, QQ, R, RTMAX, RTMIN, S1, S2,
$ SAFMAX, SHIFT, SS, SUM, WABS, WBIG, WDET,
$ WSCALE, WSIZE, WSMALL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SIGN, SQRT
* ..
* .. Executable Statements ..
*
RTMIN = SQRT( SAFMIN )
RTMAX = ONE / RTMIN
SAFMAX = ONE / SAFMIN
*
* Scale A
*
ANORM = MAX( ABS( A( 1, 1 ) )+ABS( A( 2, 1 ) ),
$ ABS( A( 1, 2 ) )+ABS( A( 2, 2 ) ), SAFMIN )
ASCALE = ONE / ANORM
A11 = ASCALE*A( 1, 1 )
A21 = ASCALE*A( 2, 1 )
A12 = ASCALE*A( 1, 2 )
A22 = ASCALE*A( 2, 2 )
*
* Perturb B if necessary to insure non-singularity
*
B11 = B( 1, 1 )
B12 = B( 1, 2 )
B22 = B( 2, 2 )
BMIN = RTMIN*MAX( ABS( B11 ), ABS( B12 ), ABS( B22 ), RTMIN )
IF( ABS( B11 ).LT.BMIN )
$ B11 = SIGN( BMIN, B11 )
IF( ABS( B22 ).LT.BMIN )
$ B22 = SIGN( BMIN, B22 )
*
* Scale B
*
BNORM = MAX( ABS( B11 ), ABS( B12 )+ABS( B22 ), SAFMIN )
BSIZE = MAX( ABS( B11 ), ABS( B22 ) )
BSCALE = ONE / BSIZE
B11 = B11*BSCALE
B12 = B12*BSCALE
B22 = B22*BSCALE
*
* Compute larger eigenvalue by method described by C. van Loan
*
* ( AS is A shifted by -SHIFT*B )
*
BINV11 = ONE / B11
BINV22 = ONE / B22
S1 = A11*BINV11
S2 = A22*BINV22
IF( ABS( S1 ).LE.ABS( S2 ) ) THEN
AS12 = A12 - S1*B12
AS22 = A22 - S1*B22
SS = A21*( BINV11*BINV22 )
ABI22 = AS22*BINV22 - SS*B12
PP = HALF*ABI22
SHIFT = S1
ELSE
AS12 = A12 - S2*B12
AS11 = A11 - S2*B11
SS = A21*( BINV11*BINV22 )
ABI22 = -SS*B12
PP = HALF*( AS11*BINV11+ABI22 )
SHIFT = S2
END IF
QQ = SS*AS12
IF( ABS( PP*RTMIN ).GE.ONE ) THEN
DISCR = ( RTMIN*PP )**2 + QQ*SAFMIN
R = SQRT( ABS( DISCR ) )*RTMAX
ELSE
IF( PP**2+ABS( QQ ).LE.SAFMIN ) THEN
DISCR = ( RTMAX*PP )**2 + QQ*SAFMAX
R = SQRT( ABS( DISCR ) )*RTMIN
ELSE
DISCR = PP**2 + QQ
R = SQRT( ABS( DISCR ) )
END IF
END IF
*
* Note: the test of R in the following IF is to cover the case when
* DISCR is small and negative and is flushed to zero during
* the calculation of R. On machines which have a consistent
* flush-to-zero threshhold and handle numbers above that
* threshhold correctly, it would not be necessary.
*
IF( DISCR.GE.ZERO .OR. R.EQ.ZERO ) THEN
SUM = PP + SIGN( R, PP )
DIFF = PP - SIGN( R, PP )
WBIG = SHIFT + SUM
*
* Compute smaller eigenvalue
*
WSMALL = SHIFT + DIFF
IF( HALF*ABS( WBIG ).GT.MAX( ABS( WSMALL ), SAFMIN ) ) THEN
WDET = ( A11*A22-A12*A21 )*( BINV11*BINV22 )
WSMALL = WDET / WBIG
END IF
*
* Choose (real) eigenvalue closest to 2,2 element of A*B**(-1)
* for WR1.
*
IF( PP.GT.ABI22 ) THEN
WR1 = MIN( WBIG, WSMALL )
WR2 = MAX( WBIG, WSMALL )
ELSE
WR1 = MAX( WBIG, WSMALL )
WR2 = MIN( WBIG, WSMALL )
END IF
WI = ZERO
ELSE
*
* Complex eigenvalues
*
WR1 = SHIFT + PP
WR2 = WR1
WI = R
END IF
*
* Further scaling to avoid underflow and overflow in computing
* SCALE1 and overflow in computing w*B.
*
* This scale factor (WSCALE) is bounded from above using C1 and C2,
* and from below using C3 and C4.
* C1 implements the condition s A must never overflow.
* C2 implements the condition w B must never overflow.
* C3, with C2,
* implement the condition that s A - w B must never overflow.
* C4 implements the condition s should not underflow.
* C5 implements the condition max(s,|w|) should be at least 2.
*
C1 = BSIZE*( SAFMIN*MAX( ONE, ASCALE ) )
C2 = SAFMIN*MAX( ONE, BNORM )
C3 = BSIZE*SAFMIN
IF( ASCALE.LE.ONE .AND. BSIZE.LE.ONE ) THEN
C4 = MIN( ONE, ( ASCALE / SAFMIN )*BSIZE )
ELSE
C4 = ONE
END IF
IF( ASCALE.LE.ONE .OR. BSIZE.LE.ONE ) THEN
C5 = MIN( ONE, ASCALE*BSIZE )
ELSE
C5 = ONE
END IF
*
* Scale first eigenvalue
*
WABS = ABS( WR1 ) + ABS( WI )
WSIZE = MAX( SAFMIN, C1, FUZZY1*( WABS*C2+C3 ),
$ MIN( C4, HALF*MAX( WABS, C5 ) ) )
IF( WSIZE.NE.ONE ) THEN
WSCALE = ONE / WSIZE
IF( WSIZE.GT.ONE ) THEN
SCALE1 = ( MAX( ASCALE, BSIZE )*WSCALE )*
$ MIN( ASCALE, BSIZE )
ELSE
SCALE1 = ( MIN( ASCALE, BSIZE )*WSCALE )*
$ MAX( ASCALE, BSIZE )
END IF
WR1 = WR1*WSCALE
IF( WI.NE.ZERO ) THEN
WI = WI*WSCALE
WR2 = WR1
SCALE2 = SCALE1
END IF
ELSE
SCALE1 = ASCALE*BSIZE
SCALE2 = SCALE1
END IF
*
* Scale second eigenvalue (if real)
*
IF( WI.EQ.ZERO ) THEN
WSIZE = MAX( SAFMIN, C1, FUZZY1*( ABS( WR2 )*C2+C3 ),
$ MIN( C4, HALF*MAX( ABS( WR2 ), C5 ) ) )
IF( WSIZE.NE.ONE ) THEN
WSCALE = ONE / WSIZE
IF( WSIZE.GT.ONE ) THEN
SCALE2 = ( MAX( ASCALE, BSIZE )*WSCALE )*
$ MIN( ASCALE, BSIZE )
ELSE
SCALE2 = ( MIN( ASCALE, BSIZE )*WSCALE )*
$ MAX( ASCALE, BSIZE )
END IF
WR2 = WR2*WSCALE
ELSE
SCALE2 = ASCALE*BSIZE
END IF
END IF
*
* End of DLAG2
*
RETURN
END
SUBROUTINE DLAG2S( M, N, A, LDA, SA, LDSA, INFO)
*
* -- LAPACK PROTOTYPE auxiliary routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* January 2007
*
* ..
* .. WARNING: PROTOTYPE ..
* This is an LAPACK PROTOTYPE routine which means that the
* interface of this routine is likely to be changed in the future
* based on community feedback.
*
* .. Scalar Arguments ..
INTEGER INFO,LDA,LDSA,M,N
* ..
* .. Array Arguments ..
REAL SA(LDSA,*)
DOUBLE PRECISION A(LDA,*)
* ..
*
* Purpose
* =======
*
* DLAG2S converts a DOUBLE PRECISION matrix, SA, to a SINGLE
* PRECISION matrix, A.
*
* RMAX is the overflow for the SINGLE PRECISION arithmetic
* DLAG2S checks that all the entries of A are between -RMAX and
* RMAX. If not the convertion is aborted and a flag is raised.
*
* This is a helper routine so there is no argument checking.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of lines of the matrix A. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix A. N >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the M-by-N coefficient matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* SA (output) REAL array, dimension (LDSA,N)
* On exit, if INFO=0, the M-by-N coefficient matrix SA.
*
* LDSA (input) INTEGER
* The leading dimension of the array SA. LDSA >= max(1,M).
*
* INFO (output) INTEGER
* = 0: successful exit
* > 0: if INFO = k, the (i,j) entry of the matrix A has
* overflowed when moving from DOUBLE PRECISION to SINGLE
* k is given by k = (i-1)*LDA+j
*
* =========
*
* .. Local Scalars ..
INTEGER I,J
DOUBLE PRECISION RMAX
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Executable Statements ..
*
RMAX = SLAMCH('O')
DO 20 J = 1,N
DO 30 I = 1,M
IF ((A(I,J).LT.-RMAX) .OR. (A(I,J).GT.RMAX)) THEN
INFO = (I-1)*LDA + J
GO TO 10
END IF
SA(I,J) = A(I,J)
30 CONTINUE
20 CONTINUE
10 CONTINUE
RETURN
*
* End of DLAG2S
*
END
SUBROUTINE DLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV,
$ SNV, CSQ, SNQ )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL UPPER
DOUBLE PRECISION A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, SNQ,
$ SNU, SNV
* ..
*
* Purpose
* =======
*
* DLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such
* that if ( UPPER ) then
*
* U'*A*Q = U'*( A1 A2 )*Q = ( x 0 )
* ( 0 A3 ) ( x x )
* and
* V'*B*Q = V'*( B1 B2 )*Q = ( x 0 )
* ( 0 B3 ) ( x x )
*
* or if ( .NOT.UPPER ) then
*
* U'*A*Q = U'*( A1 0 )*Q = ( x x )
* ( A2 A3 ) ( 0 x )
* and
* V'*B*Q = V'*( B1 0 )*Q = ( x x )
* ( B2 B3 ) ( 0 x )
*
* The rows of the transformed A and B are parallel, where
*
* U = ( CSU SNU ), V = ( CSV SNV ), Q = ( CSQ SNQ )
* ( -SNU CSU ) ( -SNV CSV ) ( -SNQ CSQ )
*
* Z' denotes the transpose of Z.
*
*
* Arguments
* =========
*
* UPPER (input) LOGICAL
* = .TRUE.: the input matrices A and B are upper triangular.
* = .FALSE.: the input matrices A and B are lower triangular.
*
* A1 (input) DOUBLE PRECISION
* A2 (input) DOUBLE PRECISION
* A3 (input) DOUBLE PRECISION
* On entry, A1, A2 and A3 are elements of the input 2-by-2
* upper (lower) triangular matrix A.
*
* B1 (input) DOUBLE PRECISION
* B2 (input) DOUBLE PRECISION
* B3 (input) DOUBLE PRECISION
* On entry, B1, B2 and B3 are elements of the input 2-by-2
* upper (lower) triangular matrix B.
*
* CSU (output) DOUBLE PRECISION
* SNU (output) DOUBLE PRECISION
* The desired orthogonal matrix U.
*
* CSV (output) DOUBLE PRECISION
* SNV (output) DOUBLE PRECISION
* The desired orthogonal matrix V.
*
* CSQ (output) DOUBLE PRECISION
* SNQ (output) DOUBLE PRECISION
* The desired orthogonal matrix Q.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION A, AUA11, AUA12, AUA21, AUA22, AVB11, AVB12,
$ AVB21, AVB22, B, C, CSL, CSR, D, R, S1, S2,
$ SNL, SNR, UA11, UA11R, UA12, UA21, UA22, UA22R,
$ VB11, VB11R, VB12, VB21, VB22, VB22R
* ..
* .. External Subroutines ..
EXTERNAL DLARTG, DLASV2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
IF( UPPER ) THEN
*
* Input matrices A and B are upper triangular matrices
*
* Form matrix C = A*adj(B) = ( a b )
* ( 0 d )
*
A = A1*B3
D = A3*B1
B = A2*B1 - A1*B2
*
* The SVD of real 2-by-2 triangular C
*
* ( CSL -SNL )*( A B )*( CSR SNR ) = ( R 0 )
* ( SNL CSL ) ( 0 D ) ( -SNR CSR ) ( 0 T )
*
CALL DLASV2( A, B, D, S1, S2, SNR, CSR, SNL, CSL )
*
IF( ABS( CSL ).GE.ABS( SNL ) .OR. ABS( CSR ).GE.ABS( SNR ) )
$ THEN
*
* Compute the (1,1) and (1,2) elements of U'*A and V'*B,
* and (1,2) element of |U|'*|A| and |V|'*|B|.
*
UA11R = CSL*A1
UA12 = CSL*A2 + SNL*A3
*
VB11R = CSR*B1
VB12 = CSR*B2 + SNR*B3
*
AUA12 = ABS( CSL )*ABS( A2 ) + ABS( SNL )*ABS( A3 )
AVB12 = ABS( CSR )*ABS( B2 ) + ABS( SNR )*ABS( B3 )
*
* zero (1,2) elements of U'*A and V'*B
*
IF( ( ABS( UA11R )+ABS( UA12 ) ).NE.ZERO ) THEN
IF( AUA12 / ( ABS( UA11R )+ABS( UA12 ) ).LE.AVB12 /
$ ( ABS( VB11R )+ABS( VB12 ) ) ) THEN
CALL DLARTG( -UA11R, UA12, CSQ, SNQ, R )
ELSE
CALL DLARTG( -VB11R, VB12, CSQ, SNQ, R )
END IF
ELSE
CALL DLARTG( -VB11R, VB12, CSQ, SNQ, R )
END IF
*
CSU = CSL
SNU = -SNL
CSV = CSR
SNV = -SNR
*
ELSE
*
* Compute the (2,1) and (2,2) elements of U'*A and V'*B,
* and (2,2) element of |U|'*|A| and |V|'*|B|.
*
UA21 = -SNL*A1
UA22 = -SNL*A2 + CSL*A3
*
VB21 = -SNR*B1
VB22 = -SNR*B2 + CSR*B3
*
AUA22 = ABS( SNL )*ABS( A2 ) + ABS( CSL )*ABS( A3 )
AVB22 = ABS( SNR )*ABS( B2 ) + ABS( CSR )*ABS( B3 )
*
* zero (2,2) elements of U'*A and V'*B, and then swap.
*
IF( ( ABS( UA21 )+ABS( UA22 ) ).NE.ZERO ) THEN
IF( AUA22 / ( ABS( UA21 )+ABS( UA22 ) ).LE.AVB22 /
$ ( ABS( VB21 )+ABS( VB22 ) ) ) THEN
CALL DLARTG( -UA21, UA22, CSQ, SNQ, R )
ELSE
CALL DLARTG( -VB21, VB22, CSQ, SNQ, R )
END IF
ELSE
CALL DLARTG( -VB21, VB22, CSQ, SNQ, R )
END IF
*
CSU = SNL
SNU = CSL
CSV = SNR
SNV = CSR
*
END IF
*
ELSE
*
* Input matrices A and B are lower triangular matrices
*
* Form matrix C = A*adj(B) = ( a 0 )
* ( c d )
*
A = A1*B3
D = A3*B1
C = A2*B3 - A3*B2
*
* The SVD of real 2-by-2 triangular C
*
* ( CSL -SNL )*( A 0 )*( CSR SNR ) = ( R 0 )
* ( SNL CSL ) ( C D ) ( -SNR CSR ) ( 0 T )
*
CALL DLASV2( A, C, D, S1, S2, SNR, CSR, SNL, CSL )
*
IF( ABS( CSR ).GE.ABS( SNR ) .OR. ABS( CSL ).GE.ABS( SNL ) )
$ THEN
*
* Compute the (2,1) and (2,2) elements of U'*A and V'*B,
* and (2,1) element of |U|'*|A| and |V|'*|B|.
*
UA21 = -SNR*A1 + CSR*A2
UA22R = CSR*A3
*
VB21 = -SNL*B1 + CSL*B2
VB22R = CSL*B3
*
AUA21 = ABS( SNR )*ABS( A1 ) + ABS( CSR )*ABS( A2 )
AVB21 = ABS( SNL )*ABS( B1 ) + ABS( CSL )*ABS( B2 )
*
* zero (2,1) elements of U'*A and V'*B.
*
IF( ( ABS( UA21 )+ABS( UA22R ) ).NE.ZERO ) THEN
IF( AUA21 / ( ABS( UA21 )+ABS( UA22R ) ).LE.AVB21 /
$ ( ABS( VB21 )+ABS( VB22R ) ) ) THEN
CALL DLARTG( UA22R, UA21, CSQ, SNQ, R )
ELSE
CALL DLARTG( VB22R, VB21, CSQ, SNQ, R )
END IF
ELSE
CALL DLARTG( VB22R, VB21, CSQ, SNQ, R )
END IF
*
CSU = CSR
SNU = -SNR
CSV = CSL
SNV = -SNL
*
ELSE
*
* Compute the (1,1) and (1,2) elements of U'*A and V'*B,
* and (1,1) element of |U|'*|A| and |V|'*|B|.
*
UA11 = CSR*A1 + SNR*A2
UA12 = SNR*A3
*
VB11 = CSL*B1 + SNL*B2
VB12 = SNL*B3
*
AUA11 = ABS( CSR )*ABS( A1 ) + ABS( SNR )*ABS( A2 )
AVB11 = ABS( CSL )*ABS( B1 ) + ABS( SNL )*ABS( B2 )
*
* zero (1,1) elements of U'*A and V'*B, and then swap.
*
IF( ( ABS( UA11 )+ABS( UA12 ) ).NE.ZERO ) THEN
IF( AUA11 / ( ABS( UA11 )+ABS( UA12 ) ).LE.AVB11 /
$ ( ABS( VB11 )+ABS( VB12 ) ) ) THEN
CALL DLARTG( UA12, UA11, CSQ, SNQ, R )
ELSE
CALL DLARTG( VB12, VB11, CSQ, SNQ, R )
END IF
ELSE
CALL DLARTG( VB12, VB11, CSQ, SNQ, R )
END IF
*
CSU = SNR
SNU = CSR
CSV = SNL
SNV = CSL
*
END IF
*
END IF
*
RETURN
*
* End of DLAGS2
*
END
SUBROUTINE DLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, N
DOUBLE PRECISION LAMBDA, TOL
* ..
* .. Array Arguments ..
INTEGER IN( * )
DOUBLE PRECISION A( * ), B( * ), C( * ), D( * )
* ..
*
* Purpose
* =======
*
* DLAGTF factorizes the matrix (T - lambda*I), where T is an n by n
* tridiagonal matrix and lambda is a scalar, as
*
* T - lambda*I = PLU,
*
* where P is a permutation matrix, L is a unit lower tridiagonal matrix
* with at most one non-zero sub-diagonal elements per column and U is
* an upper triangular matrix with at most two non-zero super-diagonal
* elements per column.
*
* The factorization is obtained by Gaussian elimination with partial
* pivoting and implicit row scaling.
*
* The parameter LAMBDA is included in the routine so that DLAGTF may
* be used, in conjunction with DLAGTS, to obtain eigenvectors of T by
* inverse iteration.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix T.
*
* A (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, A must contain the diagonal elements of T.
*
* On exit, A is overwritten by the n diagonal elements of the
* upper triangular matrix U of the factorization of T.
*
* LAMBDA (input) DOUBLE PRECISION
* On entry, the scalar lambda.
*
* B (input/output) DOUBLE PRECISION array, dimension (N-1)
* On entry, B must contain the (n-1) super-diagonal elements of
* T.
*
* On exit, B is overwritten by the (n-1) super-diagonal
* elements of the matrix U of the factorization of T.
*
* C (input/output) DOUBLE PRECISION array, dimension (N-1)
* On entry, C must contain the (n-1) sub-diagonal elements of
* T.
*
* On exit, C is overwritten by the (n-1) sub-diagonal elements
* of the matrix L of the factorization of T.
*
* TOL (input) DOUBLE PRECISION
* On entry, a relative tolerance used to indicate whether or
* not the matrix (T - lambda*I) is nearly singular. TOL should
* normally be chose as approximately the largest relative error
* in the elements of T. For example, if the elements of T are
* correct to about 4 significant figures, then TOL should be
* set to about 5*10**(-4). If TOL is supplied as less than eps,
* where eps is the relative machine precision, then the value
* eps is used in place of TOL.
*
* D (output) DOUBLE PRECISION array, dimension (N-2)
* On exit, D is overwritten by the (n-2) second super-diagonal
* elements of the matrix U of the factorization of T.
*
* IN (output) INTEGER array, dimension (N)
* On exit, IN contains details of the permutation matrix P. If
* an interchange occurred at the kth step of the elimination,
* then IN(k) = 1, otherwise IN(k) = 0. The element IN(n)
* returns the smallest positive integer j such that
*
* abs( u(j,j) ).le. norm( (T - lambda*I)(j) )*TOL,
*
* where norm( A(j) ) denotes the sum of the absolute values of
* the jth row of the matrix A. If no such j exists then IN(n)
* is returned as zero. If IN(n) is returned as positive, then a
* diagonal element of U is small, indicating that
* (T - lambda*I) is singular or nearly singular,
*
* INFO (output) INTEGER
* = 0 : successful exit
* .lt. 0: if INFO = -k, the kth argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER K
DOUBLE PRECISION EPS, MULT, PIV1, PIV2, SCALE1, SCALE2, TEMP, TL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
CALL XERBLA( 'DLAGTF', -INFO )
RETURN
END IF
*
IF( N.EQ.0 )
$ RETURN
*
A( 1 ) = A( 1 ) - LAMBDA
IN( N ) = 0
IF( N.EQ.1 ) THEN
IF( A( 1 ).EQ.ZERO )
$ IN( 1 ) = 1
RETURN
END IF
*
EPS = DLAMCH( 'Epsilon' )
*
TL = MAX( TOL, EPS )
SCALE1 = ABS( A( 1 ) ) + ABS( B( 1 ) )
DO 10 K = 1, N - 1
A( K+1 ) = A( K+1 ) - LAMBDA
SCALE2 = ABS( C( K ) ) + ABS( A( K+1 ) )
IF( K.LT.( N-1 ) )
$ SCALE2 = SCALE2 + ABS( B( K+1 ) )
IF( A( K ).EQ.ZERO ) THEN
PIV1 = ZERO
ELSE
PIV1 = ABS( A( K ) ) / SCALE1
END IF
IF( C( K ).EQ.ZERO ) THEN
IN( K ) = 0
PIV2 = ZERO
SCALE1 = SCALE2
IF( K.LT.( N-1 ) )
$ D( K ) = ZERO
ELSE
PIV2 = ABS( C( K ) ) / SCALE2
IF( PIV2.LE.PIV1 ) THEN
IN( K ) = 0
SCALE1 = SCALE2
C( K ) = C( K ) / A( K )
A( K+1 ) = A( K+1 ) - C( K )*B( K )
IF( K.LT.( N-1 ) )
$ D( K ) = ZERO
ELSE
IN( K ) = 1
MULT = A( K ) / C( K )
A( K ) = C( K )
TEMP = A( K+1 )
A( K+1 ) = B( K ) - MULT*TEMP
IF( K.LT.( N-1 ) ) THEN
D( K ) = B( K+1 )
B( K+1 ) = -MULT*D( K )
END IF
B( K ) = TEMP
C( K ) = MULT
END IF
END IF
IF( ( MAX( PIV1, PIV2 ).LE.TL ) .AND. ( IN( N ).EQ.0 ) )
$ IN( N ) = K
10 CONTINUE
IF( ( ABS( A( N ) ).LE.SCALE1*TL ) .AND. ( IN( N ).EQ.0 ) )
$ IN( N ) = N
*
RETURN
*
* End of DLAGTF
*
END
SUBROUTINE DLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA,
$ B, LDB )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER LDB, LDX, N, NRHS
DOUBLE PRECISION ALPHA, BETA
* ..
* .. Array Arguments ..
DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ),
$ X( LDX, * )
* ..
*
* Purpose
* =======
*
* DLAGTM performs a matrix-vector product of the form
*
* B := alpha * A * X + beta * B
*
* where A is a tridiagonal matrix of order N, B and X are N by NRHS
* matrices, and alpha and beta are real scalars, each of which may be
* 0., 1., or -1.
*
* Arguments
* =========
*
* TRANS (input) CHARACTER*1
* Specifies the operation applied to A.
* = 'N': No transpose, B := alpha * A * X + beta * B
* = 'T': Transpose, B := alpha * A'* X + beta * B
* = 'C': 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 matrices X and B.
*
* ALPHA (input) DOUBLE PRECISION
* The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise,
* it is assumed to be 0.
*
* DL (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) sub-diagonal elements of T.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The diagonal elements of T.
*
* DU (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) super-diagonal elements of T.
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The N by NRHS matrix X.
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(N,1).
*
* BETA (input) DOUBLE PRECISION
* The scalar beta. BETA must be 0., 1., or -1.; otherwise,
* it is assumed to be 1.
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the N by NRHS matrix B.
* On exit, B is overwritten by the matrix expression
* B := alpha * A * X + beta * B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(N,1).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 )
$ RETURN
*
* Multiply B by BETA if BETA.NE.1.
*
IF( BETA.EQ.ZERO ) THEN
DO 20 J = 1, NRHS
DO 10 I = 1, N
B( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
ELSE IF( BETA.EQ.-ONE ) THEN
DO 40 J = 1, NRHS
DO 30 I = 1, N
B( I, J ) = -B( I, J )
30 CONTINUE
40 CONTINUE
END IF
*
IF( ALPHA.EQ.ONE ) THEN
IF( LSAME( TRANS, 'N' ) ) THEN
*
* Compute B := B + A*X
*
DO 60 J = 1, NRHS
IF( N.EQ.1 ) THEN
B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J )
ELSE
B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) +
$ DU( 1 )*X( 2, J )
B( N, J ) = B( N, J ) + DL( N-1 )*X( N-1, J ) +
$ D( N )*X( N, J )
DO 50 I = 2, N - 1
B( I, J ) = B( I, J ) + DL( I-1 )*X( I-1, J ) +
$ D( I )*X( I, J ) + DU( I )*X( I+1, J )
50 CONTINUE
END IF
60 CONTINUE
ELSE
*
* Compute B := B + A'*X
*
DO 80 J = 1, NRHS
IF( N.EQ.1 ) THEN
B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J )
ELSE
B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) +
$ DL( 1 )*X( 2, J )
B( N, J ) = B( N, J ) + DU( N-1 )*X( N-1, J ) +
$ D( N )*X( N, J )
DO 70 I = 2, N - 1
B( I, J ) = B( I, J ) + DU( I-1 )*X( I-1, J ) +
$ D( I )*X( I, J ) + DL( I )*X( I+1, J )
70 CONTINUE
END IF
80 CONTINUE
END IF
ELSE IF( ALPHA.EQ.-ONE ) THEN
IF( LSAME( TRANS, 'N' ) ) THEN
*
* Compute B := B - A*X
*
DO 100 J = 1, NRHS
IF( N.EQ.1 ) THEN
B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J )
ELSE
B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) -
$ DU( 1 )*X( 2, J )
B( N, J ) = B( N, J ) - DL( N-1 )*X( N-1, J ) -
$ D( N )*X( N, J )
DO 90 I = 2, N - 1
B( I, J ) = B( I, J ) - DL( I-1 )*X( I-1, J ) -
$ D( I )*X( I, J ) - DU( I )*X( I+1, J )
90 CONTINUE
END IF
100 CONTINUE
ELSE
*
* Compute B := B - A'*X
*
DO 120 J = 1, NRHS
IF( N.EQ.1 ) THEN
B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J )
ELSE
B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) -
$ DL( 1 )*X( 2, J )
B( N, J ) = B( N, J ) - DU( N-1 )*X( N-1, J ) -
$ D( N )*X( N, J )
DO 110 I = 2, N - 1
B( I, J ) = B( I, J ) - DU( I-1 )*X( I-1, J ) -
$ D( I )*X( I, J ) - DL( I )*X( I+1, J )
110 CONTINUE
END IF
120 CONTINUE
END IF
END IF
RETURN
*
* End of DLAGTM
*
END
SUBROUTINE DLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, JOB, N
DOUBLE PRECISION TOL
* ..
* .. Array Arguments ..
INTEGER IN( * )
DOUBLE PRECISION A( * ), B( * ), C( * ), D( * ), Y( * )
* ..
*
* Purpose
* =======
*
* DLAGTS may be used to solve one of the systems of equations
*
* (T - lambda*I)*x = y or (T - lambda*I)'*x = y,
*
* where T is an n by n tridiagonal matrix, for x, following the
* factorization of (T - lambda*I) as
*
* (T - lambda*I) = P*L*U ,
*
* by routine DLAGTF. The choice of equation to be solved is
* controlled by the argument JOB, and in each case there is an option
* to perturb zero or very small diagonal elements of U, this option
* being intended for use in applications such as inverse iteration.
*
* Arguments
* =========
*
* JOB (input) INTEGER
* Specifies the job to be performed by DLAGTS as follows:
* = 1: The equations (T - lambda*I)x = y are to be solved,
* but diagonal elements of U are not to be perturbed.
* = -1: The equations (T - lambda*I)x = y are to be solved
* and, if overflow would otherwise occur, the diagonal
* elements of U are to be perturbed. See argument TOL
* below.
* = 2: The equations (T - lambda*I)'x = y are to be solved,
* but diagonal elements of U are not to be perturbed.
* = -2: The equations (T - lambda*I)'x = y are to be solved
* and, if overflow would otherwise occur, the diagonal
* elements of U are to be perturbed. See argument TOL
* below.
*
* N (input) INTEGER
* The order of the matrix T.
*
* A (input) DOUBLE PRECISION array, dimension (N)
* On entry, A must contain the diagonal elements of U as
* returned from DLAGTF.
*
* B (input) DOUBLE PRECISION array, dimension (N-1)
* On entry, B must contain the first super-diagonal elements of
* U as returned from DLAGTF.
*
* C (input) DOUBLE PRECISION array, dimension (N-1)
* On entry, C must contain the sub-diagonal elements of L as
* returned from DLAGTF.
*
* D (input) DOUBLE PRECISION array, dimension (N-2)
* On entry, D must contain the second super-diagonal elements
* of U as returned from DLAGTF.
*
* IN (input) INTEGER array, dimension (N)
* On entry, IN must contain details of the matrix P as returned
* from DLAGTF.
*
* Y (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the right hand side vector y.
* On exit, Y is overwritten by the solution vector x.
*
* TOL (input/output) DOUBLE PRECISION
* On entry, with JOB .lt. 0, TOL should be the minimum
* perturbation to be made to very small diagonal elements of U.
* TOL should normally be chosen as about eps*norm(U), where eps
* is the relative machine precision, but if TOL is supplied as
* non-positive, then it is reset to eps*max( abs( u(i,j) ) ).
* If JOB .gt. 0 then TOL is not referenced.
*
* On exit, TOL is changed as described above, only if TOL is
* non-positive on entry. Otherwise TOL is unchanged.
*
* INFO (output) INTEGER
* = 0 : successful exit
* .lt. 0: if INFO = -i, the i-th argument had an illegal value
* .gt. 0: overflow would occur when computing the INFO(th)
* element of the solution vector x. This can only occur
* when JOB is supplied as positive and either means
* that a diagonal element of U is very small, or that
* the elements of the right-hand side vector y are very
* large.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER K
DOUBLE PRECISION ABSAK, AK, BIGNUM, EPS, PERT, SFMIN, TEMP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SIGN
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
INFO = 0
IF( ( ABS( JOB ).GT.2 ) .OR. ( JOB.EQ.0 ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAGTS', -INFO )
RETURN
END IF
*
IF( N.EQ.0 )
$ RETURN
*
EPS = DLAMCH( 'Epsilon' )
SFMIN = DLAMCH( 'Safe minimum' )
BIGNUM = ONE / SFMIN
*
IF( JOB.LT.0 ) THEN
IF( TOL.LE.ZERO ) THEN
TOL = ABS( A( 1 ) )
IF( N.GT.1 )
$ TOL = MAX( TOL, ABS( A( 2 ) ), ABS( B( 1 ) ) )
DO 10 K = 3, N
TOL = MAX( TOL, ABS( A( K ) ), ABS( B( K-1 ) ),
$ ABS( D( K-2 ) ) )
10 CONTINUE
TOL = TOL*EPS
IF( TOL.EQ.ZERO )
$ TOL = EPS
END IF
END IF
*
IF( ABS( JOB ).EQ.1 ) THEN
DO 20 K = 2, N
IF( IN( K-1 ).EQ.0 ) THEN
Y( K ) = Y( K ) - C( K-1 )*Y( K-1 )
ELSE
TEMP = Y( K-1 )
Y( K-1 ) = Y( K )
Y( K ) = TEMP - C( K-1 )*Y( K )
END IF
20 CONTINUE
IF( JOB.EQ.1 ) THEN
DO 30 K = N, 1, -1
IF( K.LE.N-2 ) THEN
TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 )
ELSE IF( K.EQ.N-1 ) THEN
TEMP = Y( K ) - B( K )*Y( K+1 )
ELSE
TEMP = Y( K )
END IF
AK = A( K )
ABSAK = ABS( AK )
IF( ABSAK.LT.ONE ) THEN
IF( ABSAK.LT.SFMIN ) THEN
IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
$ THEN
INFO = K
RETURN
ELSE
TEMP = TEMP*BIGNUM
AK = AK*BIGNUM
END IF
ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
INFO = K
RETURN
END IF
END IF
Y( K ) = TEMP / AK
30 CONTINUE
ELSE
DO 50 K = N, 1, -1
IF( K.LE.N-2 ) THEN
TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 )
ELSE IF( K.EQ.N-1 ) THEN
TEMP = Y( K ) - B( K )*Y( K+1 )
ELSE
TEMP = Y( K )
END IF
AK = A( K )
PERT = SIGN( TOL, AK )
40 CONTINUE
ABSAK = ABS( AK )
IF( ABSAK.LT.ONE ) THEN
IF( ABSAK.LT.SFMIN ) THEN
IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
$ THEN
AK = AK + PERT
PERT = 2*PERT
GO TO 40
ELSE
TEMP = TEMP*BIGNUM
AK = AK*BIGNUM
END IF
ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
AK = AK + PERT
PERT = 2*PERT
GO TO 40
END IF
END IF
Y( K ) = TEMP / AK
50 CONTINUE
END IF
ELSE
*
* Come to here if JOB = 2 or -2
*
IF( JOB.EQ.2 ) THEN
DO 60 K = 1, N
IF( K.GE.3 ) THEN
TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 )
ELSE IF( K.EQ.2 ) THEN
TEMP = Y( K ) - B( K-1 )*Y( K-1 )
ELSE
TEMP = Y( K )
END IF
AK = A( K )
ABSAK = ABS( AK )
IF( ABSAK.LT.ONE ) THEN
IF( ABSAK.LT.SFMIN ) THEN
IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
$ THEN
INFO = K
RETURN
ELSE
TEMP = TEMP*BIGNUM
AK = AK*BIGNUM
END IF
ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
INFO = K
RETURN
END IF
END IF
Y( K ) = TEMP / AK
60 CONTINUE
ELSE
DO 80 K = 1, N
IF( K.GE.3 ) THEN
TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 )
ELSE IF( K.EQ.2 ) THEN
TEMP = Y( K ) - B( K-1 )*Y( K-1 )
ELSE
TEMP = Y( K )
END IF
AK = A( K )
PERT = SIGN( TOL, AK )
70 CONTINUE
ABSAK = ABS( AK )
IF( ABSAK.LT.ONE ) THEN
IF( ABSAK.LT.SFMIN ) THEN
IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
$ THEN
AK = AK + PERT
PERT = 2*PERT
GO TO 70
ELSE
TEMP = TEMP*BIGNUM
AK = AK*BIGNUM
END IF
ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
AK = AK + PERT
PERT = 2*PERT
GO TO 70
END IF
END IF
Y( K ) = TEMP / AK
80 CONTINUE
END IF
*
DO 90 K = N, 2, -1
IF( IN( K-1 ).EQ.0 ) THEN
Y( K-1 ) = Y( K-1 ) - C( K-1 )*Y( K )
ELSE
TEMP = Y( K-1 )
Y( K-1 ) = Y( K )
Y( K ) = TEMP - C( K-1 )*Y( K )
END IF
90 CONTINUE
END IF
*
* End of DLAGTS
*
END
SUBROUTINE DLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL,
$ CSR, SNR )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDB
DOUBLE PRECISION CSL, CSR, SNL, SNR
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), ALPHAI( 2 ), ALPHAR( 2 ),
$ B( LDB, * ), BETA( 2 )
* ..
*
* Purpose
* =======
*
* DLAGV2 computes the Generalized Schur factorization of a real 2-by-2
* matrix pencil (A,B) where B is upper triangular. This routine
* computes orthogonal (rotation) matrices given by CSL, SNL and CSR,
* SNR such that
*
* 1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0
* types), then
*
* [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ]
* [ 0 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ]
*
* [ b11 b12 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ]
* [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ],
*
* 2) if the pencil (A,B) has a pair of complex conjugate eigenvalues,
* then
*
* [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ]
* [ a21 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ]
*
* [ b11 0 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ]
* [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ]
*
* where b11 >= b22 > 0.
*
*
* Arguments
* =========
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA, 2)
* On entry, the 2 x 2 matrix A.
* On exit, A is overwritten by the ``A-part'' of the
* generalized Schur form.
*
* LDA (input) INTEGER
* THe leading dimension of the array A. LDA >= 2.
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB, 2)
* On entry, the upper triangular 2 x 2 matrix B.
* On exit, B is overwritten by the ``B-part'' of the
* generalized Schur form.
*
* LDB (input) INTEGER
* THe leading dimension of the array B. LDB >= 2.
*
* ALPHAR (output) DOUBLE PRECISION array, dimension (2)
* ALPHAI (output) DOUBLE PRECISION array, dimension (2)
* BETA (output) DOUBLE PRECISION array, dimension (2)
* (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the
* pencil (A,B), k=1,2, i = sqrt(-1). Note that BETA(k) may
* be zero.
*
* CSL (output) DOUBLE PRECISION
* The cosine of the left rotation matrix.
*
* SNL (output) DOUBLE PRECISION
* The sine of the left rotation matrix.
*
* CSR (output) DOUBLE PRECISION
* The cosine of the right rotation matrix.
*
* SNR (output) DOUBLE PRECISION
* The sine of the right rotation matrix.
*
* Further Details
* ===============
*
* Based on contributions by
* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION ANORM, ASCALE, BNORM, BSCALE, H1, H2, H3, QQ,
$ R, RR, SAFMIN, SCALE1, SCALE2, T, ULP, WI, WR1,
$ WR2
* ..
* .. External Subroutines ..
EXTERNAL DLAG2, DLARTG, DLASV2, DROT
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLAPY2
EXTERNAL DLAMCH, DLAPY2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
SAFMIN = DLAMCH( 'S' )
ULP = DLAMCH( 'P' )
*
* Scale A
*
ANORM = MAX( ABS( A( 1, 1 ) )+ABS( A( 2, 1 ) ),
$ ABS( A( 1, 2 ) )+ABS( A( 2, 2 ) ), SAFMIN )
ASCALE = ONE / ANORM
A( 1, 1 ) = ASCALE*A( 1, 1 )
A( 1, 2 ) = ASCALE*A( 1, 2 )
A( 2, 1 ) = ASCALE*A( 2, 1 )
A( 2, 2 ) = ASCALE*A( 2, 2 )
*
* Scale B
*
BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 1, 2 ) )+ABS( B( 2, 2 ) ),
$ SAFMIN )
BSCALE = ONE / BNORM
B( 1, 1 ) = BSCALE*B( 1, 1 )
B( 1, 2 ) = BSCALE*B( 1, 2 )
B( 2, 2 ) = BSCALE*B( 2, 2 )
*
* Check if A can be deflated
*
IF( ABS( A( 2, 1 ) ).LE.ULP ) THEN
CSL = ONE
SNL = ZERO
CSR = ONE
SNR = ZERO
A( 2, 1 ) = ZERO
B( 2, 1 ) = ZERO
*
* Check if B is singular
*
ELSE IF( ABS( B( 1, 1 ) ).LE.ULP ) THEN
CALL DLARTG( A( 1, 1 ), A( 2, 1 ), CSL, SNL, R )
CSR = ONE
SNR = ZERO
CALL DROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL )
CALL DROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL )
A( 2, 1 ) = ZERO
B( 1, 1 ) = ZERO
B( 2, 1 ) = ZERO
*
ELSE IF( ABS( B( 2, 2 ) ).LE.ULP ) THEN
CALL DLARTG( A( 2, 2 ), A( 2, 1 ), CSR, SNR, T )
SNR = -SNR
CALL DROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR )
CALL DROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR )
CSL = ONE
SNL = ZERO
A( 2, 1 ) = ZERO
B( 2, 1 ) = ZERO
B( 2, 2 ) = ZERO
*
ELSE
*
* B is nonsingular, first compute the eigenvalues of (A,B)
*
CALL DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, WR2,
$ WI )
*
IF( WI.EQ.ZERO ) THEN
*
* two real eigenvalues, compute s*A-w*B
*
H1 = SCALE1*A( 1, 1 ) - WR1*B( 1, 1 )
H2 = SCALE1*A( 1, 2 ) - WR1*B( 1, 2 )
H3 = SCALE1*A( 2, 2 ) - WR1*B( 2, 2 )
*
RR = DLAPY2( H1, H2 )
QQ = DLAPY2( SCALE1*A( 2, 1 ), H3 )
*
IF( RR.GT.QQ ) THEN
*
* find right rotation matrix to zero 1,1 element of
* (sA - wB)
*
CALL DLARTG( H2, H1, CSR, SNR, T )
*
ELSE
*
* find right rotation matrix to zero 2,1 element of
* (sA - wB)
*
CALL DLARTG( H3, SCALE1*A( 2, 1 ), CSR, SNR, T )
*
END IF
*
SNR = -SNR
CALL DROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR )
CALL DROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR )
*
* compute inf norms of A and B
*
H1 = MAX( ABS( A( 1, 1 ) )+ABS( A( 1, 2 ) ),
$ ABS( A( 2, 1 ) )+ABS( A( 2, 2 ) ) )
H2 = MAX( ABS( B( 1, 1 ) )+ABS( B( 1, 2 ) ),
$ ABS( B( 2, 1 ) )+ABS( B( 2, 2 ) ) )
*
IF( ( SCALE1*H1 ).GE.ABS( WR1 )*H2 ) THEN
*
* find left rotation matrix Q to zero out B(2,1)
*
CALL DLARTG( B( 1, 1 ), B( 2, 1 ), CSL, SNL, R )
*
ELSE
*
* find left rotation matrix Q to zero out A(2,1)
*
CALL DLARTG( A( 1, 1 ), A( 2, 1 ), CSL, SNL, R )
*
END IF
*
CALL DROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL )
CALL DROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL )
*
A( 2, 1 ) = ZERO
B( 2, 1 ) = ZERO
*
ELSE
*
* a pair of complex conjugate eigenvalues
* first compute the SVD of the matrix B
*
CALL DLASV2( B( 1, 1 ), B( 1, 2 ), B( 2, 2 ), R, T, SNR,
$ CSR, SNL, CSL )
*
* Form (A,B) := Q(A,B)Z' where Q is left rotation matrix and
* Z is right rotation matrix computed from DLASV2
*
CALL DROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL )
CALL DROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL )
CALL DROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR )
CALL DROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR )
*
B( 2, 1 ) = ZERO
B( 1, 2 ) = ZERO
*
END IF
*
END IF
*
* Unscaling
*
A( 1, 1 ) = ANORM*A( 1, 1 )
A( 2, 1 ) = ANORM*A( 2, 1 )
A( 1, 2 ) = ANORM*A( 1, 2 )
A( 2, 2 ) = ANORM*A( 2, 2 )
B( 1, 1 ) = BNORM*B( 1, 1 )
B( 2, 1 ) = BNORM*B( 2, 1 )
B( 1, 2 ) = BNORM*B( 1, 2 )
B( 2, 2 ) = BNORM*B( 2, 2 )
*
IF( WI.EQ.ZERO ) THEN
ALPHAR( 1 ) = A( 1, 1 )
ALPHAR( 2 ) = A( 2, 2 )
ALPHAI( 1 ) = ZERO
ALPHAI( 2 ) = ZERO
BETA( 1 ) = B( 1, 1 )
BETA( 2 ) = B( 2, 2 )
ELSE
ALPHAR( 1 ) = ANORM*WR1 / SCALE1 / BNORM
ALPHAI( 1 ) = ANORM*WI / SCALE1 / BNORM
ALPHAR( 2 ) = ALPHAR( 1 )
ALPHAI( 2 ) = -ALPHAI( 1 )
BETA( 1 ) = ONE
BETA( 2 ) = ONE
END IF
*
RETURN
*
* End of DLAGV2
*
END
SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
$ ILOZ, IHIZ, Z, LDZ, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
DOUBLE PRECISION H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DLAHQR is an auxiliary routine called by DHSEQR to update the
* eigenvalues and Schur decomposition already computed by DHSEQR, by
* dealing with the Hessenberg submatrix in rows and columns ILO to
* IHI.
*
* Arguments
* =========
*
* WANTT (input) LOGICAL
* = .TRUE. : the full Schur form T is required;
* = .FALSE.: only eigenvalues are required.
*
* WANTZ (input) LOGICAL
* = .TRUE. : the matrix of Schur vectors Z is required;
* = .FALSE.: Schur vectors are not required.
*
* N (input) INTEGER
* The order of the matrix H. N >= 0.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* It is assumed that H is already upper quasi-triangular in
* rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless
* ILO = 1). DLAHQR works primarily with the Hessenberg
* submatrix in rows and columns ILO to IHI, but applies
* transformations to all of H if WANTT is .TRUE..
* 1 <= ILO <= max(1,IHI); IHI <= N.
*
* H (input/output) DOUBLE PRECISION array, dimension (LDH,N)
* On entry, the upper Hessenberg matrix H.
* On exit, if INFO is zero and if WANTT is .TRUE., H is upper
* quasi-triangular in rows and columns ILO:IHI, with any
* 2-by-2 diagonal blocks in standard form. If INFO is zero
* and WANTT is .FALSE., the contents of H are unspecified on
* exit. The output state of H if INFO is nonzero is given
* below under the description of INFO.
*
* LDH (input) INTEGER
* The leading dimension of the array H. LDH >= max(1,N).
*
* WR (output) DOUBLE PRECISION array, dimension (N)
* WI (output) DOUBLE PRECISION array, dimension (N)
* The real and imaginary parts, respectively, of the computed
* eigenvalues ILO to IHI are stored in the corresponding
* elements of WR and WI. If two eigenvalues are computed as a
* complex conjugate pair, they are stored in consecutive
* elements of WR and WI, say the i-th and (i+1)th, with
* WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the
* eigenvalues are stored in the same order as on the diagonal
* of the Schur form returned in H, with WR(i) = H(i,i), and, if
* H(i:i+1,i:i+1) is a 2-by-2 diagonal block,
* WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i).
*
* ILOZ (input) INTEGER
* IHIZ (input) INTEGER
* Specify the rows of Z to which transformations must be
* applied if WANTZ is .TRUE..
* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
*
* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
* If WANTZ is .TRUE., on entry Z must contain the current
* matrix Z of transformations accumulated by DHSEQR, and on
* exit Z has been updated; transformations are applied only to
* the submatrix Z(ILOZ:IHIZ,ILO:IHI).
* If WANTZ is .FALSE., Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* .GT. 0: If INFO = i, DLAHQR failed to compute all the
* eigenvalues ILO to IHI in a total of 30 iterations
* per eigenvalue; elements i+1:ihi of WR and WI
* contain those eigenvalues which have been
* successfully computed.
*
* If INFO .GT. 0 and WANTT is .FALSE., then on exit,
* the remaining unconverged eigenvalues are the
* eigenvalues of the upper Hessenberg matrix rows
* and columns ILO thorugh INFO of the final, output
* value of H.
*
* If INFO .GT. 0 and WANTT is .TRUE., then on exit
* (*) (initial value of H)*U = U*(final value of H)
* where U is an orthognal matrix. The final
* value of H is upper Hessenberg and triangular in
* rows and columns INFO+1 through IHI.
*
* If INFO .GT. 0 and WANTZ is .TRUE., then on exit
* (final value of Z) = (initial value of Z)*U
* where U is the orthogonal matrix in (*)
* (regardless of the value of WANTT.)
*
* Further Details
* ===============
*
* 02-96 Based on modifications by
* David Day, Sandia National Laboratory, USA
*
* 12-04 Further modifications by
* Ralph Byers, University of Kansas, USA
*
* This is a modified version of DLAHQR from LAPACK version 3.0.
* It is (1) more robust against overflow and underflow and
* (2) adopts the more conservative Ahues & Tisseur stopping
* criterion (LAWN 122, 1997).
*
* =========================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 30 )
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0, TWO = 2.0d0 )
DOUBLE PRECISION DAT1, DAT2
PARAMETER ( DAT1 = 3.0d0 / 4.0d0, DAT2 = -0.4375d0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION AA, AB, BA, BB, CS, DET, H11, H12, H21, H21S,
$ H22, RT1I, RT1R, RT2I, RT2R, RTDISC, S, SAFMAX,
$ SAFMIN, SMLNUM, SN, SUM, T1, T2, T3, TR, TST,
$ ULP, V2, V3
INTEGER I, I1, I2, ITS, J, K, L, M, NH, NR, NZ
* ..
* .. Local Arrays ..
DOUBLE PRECISION V( 3 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLABAD, DLANV2, DLARFG, DROT
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
IF( ILO.EQ.IHI ) THEN
WR( ILO ) = H( ILO, ILO )
WI( ILO ) = ZERO
RETURN
END IF
*
* ==== clear out the trash ====
DO 10 J = ILO, IHI - 3
H( J+2, J ) = ZERO
H( J+3, J ) = ZERO
10 CONTINUE
IF( ILO.LE.IHI-2 )
$ H( IHI, IHI-2 ) = ZERO
*
NH = IHI - ILO + 1
NZ = IHIZ - ILOZ + 1
*
* Set machine-dependent constants for the stopping criterion.
*
SAFMIN = DLAMCH( 'SAFE MINIMUM' )
SAFMAX = ONE / SAFMIN
CALL DLABAD( SAFMIN, SAFMAX )
ULP = DLAMCH( 'PRECISION' )
SMLNUM = SAFMIN*( DBLE( NH ) / ULP )
*
* I1 and I2 are the indices of the first row and last column of H
* to which transformations must be applied. If eigenvalues only are
* being computed, I1 and I2 are set inside the main loop.
*
IF( WANTT ) THEN
I1 = 1
I2 = N
END IF
*
* The main loop begins here. I is the loop index and decreases from
* IHI to ILO in steps of 1 or 2. Each iteration of the loop works
* with the active submatrix in rows and columns L to I.
* Eigenvalues I+1 to IHI have already converged. Either L = ILO or
* H(L,L-1) is negligible so that the matrix splits.
*
I = IHI
20 CONTINUE
L = ILO
IF( I.LT.ILO )
$ GO TO 160
*
* Perform QR iterations on rows and columns ILO to I until a
* submatrix of order 1 or 2 splits off at the bottom because a
* subdiagonal element has become negligible.
*
DO 140 ITS = 0, ITMAX
*
* Look for a single small subdiagonal element.
*
DO 30 K = I, L + 1, -1
IF( ABS( H( K, K-1 ) ).LE.SMLNUM )
$ GO TO 40
TST = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) )
IF( TST.EQ.ZERO ) THEN
IF( K-2.GE.ILO )
$ TST = TST + ABS( H( K-1, K-2 ) )
IF( K+1.LE.IHI )
$ TST = TST + ABS( H( K+1, K ) )
END IF
* ==== The following is a conservative small subdiagonal
* . deflation criterion due to Ahues & Tisseur (LAWN 122,
* . 1997). It has better mathematical foundation and
* . improves accuracy in some cases. ====
IF( ABS( H( K, K-1 ) ).LE.ULP*TST ) THEN
AB = MAX( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) )
BA = MIN( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) )
AA = MAX( ABS( H( K, K ) ),
$ ABS( H( K-1, K-1 )-H( K, K ) ) )
BB = MIN( ABS( H( K, K ) ),
$ ABS( H( K-1, K-1 )-H( K, K ) ) )
S = AA + AB
IF( BA*( AB / S ).LE.MAX( SMLNUM,
$ ULP*( BB*( AA / S ) ) ) )GO TO 40
END IF
30 CONTINUE
40 CONTINUE
L = K
IF( L.GT.ILO ) THEN
*
* H(L,L-1) is negligible
*
H( L, L-1 ) = ZERO
END IF
*
* Exit from loop if a submatrix of order 1 or 2 has split off.
*
IF( L.GE.I-1 )
$ GO TO 150
*
* Now the active submatrix is in rows and columns L to I. If
* eigenvalues only are being computed, only the active submatrix
* need be transformed.
*
IF( .NOT.WANTT ) THEN
I1 = L
I2 = I
END IF
*
IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN
*
* Exceptional shift.
*
H11 = DAT1*S + H( I, I )
H12 = DAT2*S
H21 = S
H22 = H11
ELSE
*
* Prepare to use Francis' double shift
* (i.e. 2nd degree generalized Rayleigh quotient)
*
H11 = H( I-1, I-1 )
H21 = H( I, I-1 )
H12 = H( I-1, I )
H22 = H( I, I )
END IF
S = ABS( H11 ) + ABS( H12 ) + ABS( H21 ) + ABS( H22 )
IF( S.EQ.ZERO ) THEN
RT1R = ZERO
RT1I = ZERO
RT2R = ZERO
RT2I = ZERO
ELSE
H11 = H11 / S
H21 = H21 / S
H12 = H12 / S
H22 = H22 / S
TR = ( H11+H22 ) / TWO
DET = ( H11-TR )*( H22-TR ) - H12*H21
RTDISC = SQRT( ABS( DET ) )
IF( DET.GE.ZERO ) THEN
*
* ==== complex conjugate shifts ====
*
RT1R = TR*S
RT2R = RT1R
RT1I = RTDISC*S
RT2I = -RT1I
ELSE
*
* ==== real shifts (use only one of them) ====
*
RT1R = TR + RTDISC
RT2R = TR - RTDISC
IF( ABS( RT1R-H22 ).LE.ABS( RT2R-H22 ) ) THEN
RT1R = RT1R*S
RT2R = RT1R
ELSE
RT2R = RT2R*S
RT1R = RT2R
END IF
RT1I = ZERO
RT2I = ZERO
END IF
END IF
*
* Look for two consecutive small subdiagonal elements.
*
DO 50 M = I - 2, L, -1
* Determine the effect of starting the double-shift QR
* iteration at row M, and see if this would make H(M,M-1)
* negligible. (The following uses scaling to avoid
* overflows and most underflows.)
*
H21S = H( M+1, M )
S = ABS( H( M, M )-RT2R ) + ABS( RT2I ) + ABS( H21S )
H21S = H( M+1, M ) / S
V( 1 ) = H21S*H( M, M+1 ) + ( H( M, M )-RT1R )*
$ ( ( H( M, M )-RT2R ) / S ) - RT1I*( RT2I / S )
V( 2 ) = H21S*( H( M, M )+H( M+1, M+1 )-RT1R-RT2R )
V( 3 ) = H21S*H( M+2, M+1 )
S = ABS( V( 1 ) ) + ABS( V( 2 ) ) + ABS( V( 3 ) )
V( 1 ) = V( 1 ) / S
V( 2 ) = V( 2 ) / S
V( 3 ) = V( 3 ) / S
IF( M.EQ.L )
$ GO TO 60
IF( ABS( H( M, M-1 ) )*( ABS( V( 2 ) )+ABS( V( 3 ) ) ).LE.
$ ULP*ABS( V( 1 ) )*( ABS( H( M-1, M-1 ) )+ABS( H( M,
$ M ) )+ABS( H( M+1, M+1 ) ) ) )GO TO 60
50 CONTINUE
60 CONTINUE
*
* Double-shift QR step
*
DO 130 K = M, I - 1
*
* The first iteration of this loop determines a reflection G
* from the vector V and applies it from left and right to H,
* thus creating a nonzero bulge below the subdiagonal.
*
* Each subsequent iteration determines a reflection G to
* restore the Hessenberg form in the (K-1)th column, and thus
* chases the bulge one step toward the bottom of the active
* submatrix. NR is the order of G.
*
NR = MIN( 3, I-K+1 )
IF( K.GT.M )
$ CALL DCOPY( NR, H( K, K-1 ), 1, V, 1 )
CALL DLARFG( NR, V( 1 ), V( 2 ), 1, T1 )
IF( K.GT.M ) THEN
H( K, K-1 ) = V( 1 )
H( K+1, K-1 ) = ZERO
IF( K.LT.I-1 )
$ H( K+2, K-1 ) = ZERO
ELSE IF( M.GT.L ) THEN
H( K, K-1 ) = -H( K, K-1 )
END IF
V2 = V( 2 )
T2 = T1*V2
IF( NR.EQ.3 ) THEN
V3 = V( 3 )
T3 = T1*V3
*
* Apply G from the left to transform the rows of the matrix
* in columns K to I2.
*
DO 70 J = K, I2
SUM = H( K, J ) + V2*H( K+1, J ) + V3*H( K+2, J )
H( K, J ) = H( K, J ) - SUM*T1
H( K+1, J ) = H( K+1, J ) - SUM*T2
H( K+2, J ) = H( K+2, J ) - SUM*T3
70 CONTINUE
*
* Apply G from the right to transform the columns of the
* matrix in rows I1 to min(K+3,I).
*
DO 80 J = I1, MIN( K+3, I )
SUM = H( J, K ) + V2*H( J, K+1 ) + V3*H( J, K+2 )
H( J, K ) = H( J, K ) - SUM*T1
H( J, K+1 ) = H( J, K+1 ) - SUM*T2
H( J, K+2 ) = H( J, K+2 ) - SUM*T3
80 CONTINUE
*
IF( WANTZ ) THEN
*
* Accumulate transformations in the matrix Z
*
DO 90 J = ILOZ, IHIZ
SUM = Z( J, K ) + V2*Z( J, K+1 ) + V3*Z( J, K+2 )
Z( J, K ) = Z( J, K ) - SUM*T1
Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2
Z( J, K+2 ) = Z( J, K+2 ) - SUM*T3
90 CONTINUE
END IF
ELSE IF( NR.EQ.2 ) THEN
*
* Apply G from the left to transform the rows of the matrix
* in columns K to I2.
*
DO 100 J = K, I2
SUM = H( K, J ) + V2*H( K+1, J )
H( K, J ) = H( K, J ) - SUM*T1
H( K+1, J ) = H( K+1, J ) - SUM*T2
100 CONTINUE
*
* Apply G from the right to transform the columns of the
* matrix in rows I1 to min(K+3,I).
*
DO 110 J = I1, I
SUM = H( J, K ) + V2*H( J, K+1 )
H( J, K ) = H( J, K ) - SUM*T1
H( J, K+1 ) = H( J, K+1 ) - SUM*T2
110 CONTINUE
*
IF( WANTZ ) THEN
*
* Accumulate transformations in the matrix Z
*
DO 120 J = ILOZ, IHIZ
SUM = Z( J, K ) + V2*Z( J, K+1 )
Z( J, K ) = Z( J, K ) - SUM*T1
Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2
120 CONTINUE
END IF
END IF
130 CONTINUE
*
140 CONTINUE
*
* Failure to converge in remaining number of iterations
*
INFO = I
RETURN
*
150 CONTINUE
*
IF( L.EQ.I ) THEN
*
* H(I,I-1) is negligible: one eigenvalue has converged.
*
WR( I ) = H( I, I )
WI( I ) = ZERO
ELSE IF( L.EQ.I-1 ) THEN
*
* H(I-1,I-2) is negligible: a pair of eigenvalues have converged.
*
* Transform the 2-by-2 submatrix to standard Schur form,
* and compute and store the eigenvalues.
*
CALL DLANV2( H( I-1, I-1 ), H( I-1, I ), H( I, I-1 ),
$ H( I, I ), WR( I-1 ), WI( I-1 ), WR( I ), WI( I ),
$ CS, SN )
*
IF( WANTT ) THEN
*
* Apply the transformation to the rest of H.
*
IF( I2.GT.I )
$ CALL DROT( I2-I, H( I-1, I+1 ), LDH, H( I, I+1 ), LDH,
$ CS, SN )
CALL DROT( I-I1-1, H( I1, I-1 ), 1, H( I1, I ), 1, CS, SN )
END IF
IF( WANTZ ) THEN
*
* Apply the transformation to Z.
*
CALL DROT( NZ, Z( ILOZ, I-1 ), 1, Z( ILOZ, I ), 1, CS, SN )
END IF
END IF
*
* return to start of the main loop with new value of I.
*
I = L - 1
GO TO 20
*
160 CONTINUE
RETURN
*
* End of DLAHQR
*
END
SUBROUTINE DLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER K, LDA, LDT, LDY, N, NB
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), T( LDT, NB ), TAU( NB ),
$ Y( LDY, NB )
* ..
*
* Purpose
* =======
*
* DLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1)
* matrix A so that elements below the k-th subdiagonal are zero. The
* reduction is performed by an orthogonal similarity transformation
* Q' * A * Q. The routine returns the matrices V and T which determine
* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.
*
* This is an auxiliary routine called by DGEHRD.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix A.
*
* K (input) INTEGER
* The offset for the reduction. Elements below the k-th
* subdiagonal in the first NB columns are reduced to zero.
* K < N.
*
* NB (input) INTEGER
* The number of columns to be reduced.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N-K+1)
* On entry, the n-by-(n-k+1) general matrix A.
* On exit, the elements on and above the k-th subdiagonal in
* the first NB columns are overwritten with the corresponding
* elements of the reduced matrix; the elements below the k-th
* subdiagonal, with the array TAU, represent the matrix Q as a
* product of elementary reflectors. The other columns of A are
* unchanged. See Further Details.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* TAU (output) DOUBLE PRECISION array, dimension (NB)
* The scalar factors of the elementary reflectors. See Further
* Details.
*
* T (output) DOUBLE PRECISION array, dimension (LDT,NB)
* The upper triangular matrix T.
*
* LDT (input) INTEGER
* The leading dimension of the array T. LDT >= NB.
*
* Y (output) DOUBLE PRECISION array, dimension (LDY,NB)
* The n-by-nb matrix Y.
*
* LDY (input) INTEGER
* The leading dimension of the array Y. LDY >= N.
*
* Further Details
* ===============
*
* The matrix Q is represented as a product of nb elementary reflectors
*
* Q = H(1) H(2) . . . H(nb).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a real scalar, and v is a real vector with
* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in
* A(i+k+1:n,i), and tau in TAU(i).
*
* The elements of the vectors v together form the (n-k+1)-by-nb matrix
* V which is needed, with T and Y, to apply the transformation to the
* unreduced part of the matrix, using an update of the form:
* A := (I - V*T*V') * (A - Y*V').
*
* The contents of A on exit are illustrated by the following example
* with n = 7, k = 3 and nb = 2:
*
* ( a a a a a )
* ( a a a a a )
* ( a a a a a )
* ( h h a a a )
* ( v1 h a a a )
* ( v1 v2 a a a )
* ( v1 v2 a a a )
*
* where a denotes an element of the original matrix A, h denotes a
* modified element of the upper Hessenberg matrix H, and vi denotes an
* element of the vector defining H(i).
*
* This file is a slight modification of LAPACK-3.0's DLAHRD
* incorporating improvements proposed by Quintana-Orti and Van de
* Gejin. Note that the entries of A(1:K,2:NB) differ from those
* returned by the original LAPACK routine. This function is
* not backward compatible with LAPACK3.0.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0,
$ ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I
DOUBLE PRECISION EI
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DLACPY,
$ DLARFG, DSCAL, DTRMM, DTRMV
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.1 )
$ RETURN
*
DO 10 I = 1, NB
IF( I.GT.1 ) THEN
*
* Update A(K+1:N,I)
*
* Update I-th column of A - Y * V'
*
CALL DGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, Y(K+1,1), LDY,
$ A( K+I-1, 1 ), LDA, ONE, A( K+1, I ), 1 )
*
* Apply I - V * T' * V' to this column (call it b) from the
* left, using the last column of T as workspace
*
* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows)
* ( V2 ) ( b2 )
*
* where V1 is unit lower triangular
*
* w := V1' * b1
*
CALL DCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 )
CALL DTRMV( 'Lower', 'Transpose', 'UNIT',
$ I-1, A( K+1, 1 ),
$ LDA, T( 1, NB ), 1 )
*
* w := w + V2'*b2
*
CALL DGEMV( 'Transpose', N-K-I+1, I-1,
$ ONE, A( K+I, 1 ),
$ LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 )
*
* w := T'*w
*
CALL DTRMV( 'Upper', 'Transpose', 'NON-UNIT',
$ I-1, T, LDT,
$ T( 1, NB ), 1 )
*
* b2 := b2 - V2*w
*
CALL DGEMV( 'NO TRANSPOSE', N-K-I+1, I-1, -ONE,
$ A( K+I, 1 ),
$ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 )
*
* b1 := b1 - V1*w
*
CALL DTRMV( 'Lower', 'NO TRANSPOSE',
$ 'UNIT', I-1,
$ A( K+1, 1 ), LDA, T( 1, NB ), 1 )
CALL DAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 )
*
A( K+I-1, I-1 ) = EI
END IF
*
* Generate the elementary reflector H(I) to annihilate
* A(K+I+1:N,I)
*
CALL DLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1,
$ TAU( I ) )
EI = A( K+I, I )
A( K+I, I ) = ONE
*
* Compute Y(K+1:N,I)
*
CALL DGEMV( 'NO TRANSPOSE', N-K, N-K-I+1,
$ ONE, A( K+1, I+1 ),
$ LDA, A( K+I, I ), 1, ZERO, Y( K+1, I ), 1 )
CALL DGEMV( 'Transpose', N-K-I+1, I-1,
$ ONE, A( K+I, 1 ), LDA,
$ A( K+I, I ), 1, ZERO, T( 1, I ), 1 )
CALL DGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE,
$ Y( K+1, 1 ), LDY,
$ T( 1, I ), 1, ONE, Y( K+1, I ), 1 )
CALL DSCAL( N-K, TAU( I ), Y( K+1, I ), 1 )
*
* Compute T(1:I,I)
*
CALL DSCAL( I-1, -TAU( I ), T( 1, I ), 1 )
CALL DTRMV( 'Upper', 'No Transpose', 'NON-UNIT',
$ I-1, T, LDT,
$ T( 1, I ), 1 )
T( I, I ) = TAU( I )
*
10 CONTINUE
A( K+NB, NB ) = EI
*
* Compute Y(1:K,1:NB)
*
CALL DLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY )
CALL DTRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE',
$ 'UNIT', K, NB,
$ ONE, A( K+1, 1 ), LDA, Y, LDY )
IF( N.GT.K+NB )
$ CALL DGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K,
$ NB, N-K-NB, ONE,
$ A( 1, 2+NB ), LDA, A( K+1+NB, 1 ), LDA, ONE, Y,
$ LDY )
CALL DTRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE',
$ 'NON-UNIT', K, NB,
$ ONE, T, LDT, Y, LDY )
*
RETURN
*
* End of DLAHR2
*
END
SUBROUTINE DLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER K, LDA, LDT, LDY, N, NB
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), T( LDT, NB ), TAU( NB ),
$ Y( LDY, NB )
* ..
*
* Purpose
* =======
*
* DLAHRD reduces the first NB columns of a real general n-by-(n-k+1)
* matrix A so that elements below the k-th subdiagonal are zero. The
* reduction is performed by an orthogonal similarity transformation
* Q' * A * Q. The routine returns the matrices V and T which determine
* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.
*
* This is an OBSOLETE auxiliary routine.
* This routine will be 'deprecated' in a future release.
* Please use the new routine DLAHR2 instead.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix A.
*
* K (input) INTEGER
* The offset for the reduction. Elements below the k-th
* subdiagonal in the first NB columns are reduced to zero.
*
* NB (input) INTEGER
* The number of columns to be reduced.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N-K+1)
* On entry, the n-by-(n-k+1) general matrix A.
* On exit, the elements on and above the k-th subdiagonal in
* the first NB columns are overwritten with the corresponding
* elements of the reduced matrix; the elements below the k-th
* subdiagonal, with the array TAU, represent the matrix Q as a
* product of elementary reflectors. The other columns of A are
* unchanged. See Further Details.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* TAU (output) DOUBLE PRECISION array, dimension (NB)
* The scalar factors of the elementary reflectors. See Further
* Details.
*
* T (output) DOUBLE PRECISION array, dimension (LDT,NB)
* The upper triangular matrix T.
*
* LDT (input) INTEGER
* The leading dimension of the array T. LDT >= NB.
*
* Y (output) DOUBLE PRECISION array, dimension (LDY,NB)
* The n-by-nb matrix Y.
*
* LDY (input) INTEGER
* The leading dimension of the array Y. LDY >= N.
*
* Further Details
* ===============
*
* The matrix Q is represented as a product of nb elementary reflectors
*
* Q = H(1) H(2) . . . H(nb).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a real scalar, and v is a real vector with
* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in
* A(i+k+1:n,i), and tau in TAU(i).
*
* The elements of the vectors v together form the (n-k+1)-by-nb matrix
* V which is needed, with T and Y, to apply the transformation to the
* unreduced part of the matrix, using an update of the form:
* A := (I - V*T*V') * (A - Y*V').
*
* The contents of A on exit are illustrated by the following example
* with n = 7, k = 3 and nb = 2:
*
* ( a h a a a )
* ( a h a a a )
* ( a h a a a )
* ( h h a a a )
* ( v1 h a a a )
* ( v1 v2 a a a )
* ( v1 v2 a a a )
*
* where a denotes an element of the original matrix A, h denotes a
* modified element of the upper Hessenberg matrix H, and vi denotes an
* element of the vector defining H(i).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I
DOUBLE PRECISION EI
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DGEMV, DLARFG, DSCAL, DTRMV
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.1 )
$ RETURN
*
DO 10 I = 1, NB
IF( I.GT.1 ) THEN
*
* Update A(1:n,i)
*
* Compute i-th column of A - Y * V'
*
CALL DGEMV( 'No transpose', N, I-1, -ONE, Y, LDY,
$ A( K+I-1, 1 ), LDA, ONE, A( 1, I ), 1 )
*
* Apply I - V * T' * V' to this column (call it b) from the
* left, using the last column of T as workspace
*
* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows)
* ( V2 ) ( b2 )
*
* where V1 is unit lower triangular
*
* w := V1' * b1
*
CALL DCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 )
CALL DTRMV( 'Lower', 'Transpose', 'Unit', I-1, A( K+1, 1 ),
$ LDA, T( 1, NB ), 1 )
*
* w := w + V2'*b2
*
CALL DGEMV( 'Transpose', N-K-I+1, I-1, ONE, A( K+I, 1 ),
$ LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 )
*
* w := T'*w
*
CALL DTRMV( 'Upper', 'Transpose', 'Non-unit', I-1, T, LDT,
$ T( 1, NB ), 1 )
*
* b2 := b2 - V2*w
*
CALL DGEMV( 'No transpose', N-K-I+1, I-1, -ONE, A( K+I, 1 ),
$ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 )
*
* b1 := b1 - V1*w
*
CALL DTRMV( 'Lower', 'No transpose', 'Unit', I-1,
$ A( K+1, 1 ), LDA, T( 1, NB ), 1 )
CALL DAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 )
*
A( K+I-1, I-1 ) = EI
END IF
*
* Generate the elementary reflector H(i) to annihilate
* A(k+i+1:n,i)
*
CALL DLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1,
$ TAU( I ) )
EI = A( K+I, I )
A( K+I, I ) = ONE
*
* Compute Y(1:n,i)
*
CALL DGEMV( 'No transpose', N, N-K-I+1, ONE, A( 1, I+1 ), LDA,
$ A( K+I, I ), 1, ZERO, Y( 1, I ), 1 )
CALL DGEMV( 'Transpose', N-K-I+1, I-1, ONE, A( K+I, 1 ), LDA,
$ A( K+I, I ), 1, ZERO, T( 1, I ), 1 )
CALL DGEMV( 'No transpose', N, I-1, -ONE, Y, LDY, T( 1, I ), 1,
$ ONE, Y( 1, I ), 1 )
CALL DSCAL( N, TAU( I ), Y( 1, I ), 1 )
*
* Compute T(1:i,i)
*
CALL DSCAL( I-1, -TAU( I ), T( 1, I ), 1 )
CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, LDT,
$ T( 1, I ), 1 )
T( I, I ) = TAU( I )
*
10 CONTINUE
A( K+NB, NB ) = EI
*
RETURN
*
* End of DLAHRD
*
END
SUBROUTINE DLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER J, JOB
DOUBLE PRECISION C, GAMMA, S, SEST, SESTPR
* ..
* .. Array Arguments ..
DOUBLE PRECISION W( J ), X( J )
* ..
*
* Purpose
* =======
*
* DLAIC1 applies one step of incremental condition estimation in
* its simplest version:
*
* Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j
* lower triangular matrix L, such that
* twonorm(L*x) = sest
* Then DLAIC1 computes sestpr, s, c such that
* the vector
* [ s*x ]
* xhat = [ c ]
* is an approximate singular vector of
* [ L 0 ]
* Lhat = [ w' gamma ]
* in the sense that
* twonorm(Lhat*xhat) = sestpr.
*
* Depending on JOB, an estimate for the largest or smallest singular
* value is computed.
*
* Note that [s c]' and sestpr**2 is an eigenpair of the system
*
* diag(sest*sest, 0) + [alpha gamma] * [ alpha ]
* [ gamma ]
*
* where alpha = x'*w.
*
* Arguments
* =========
*
* JOB (input) INTEGER
* = 1: an estimate for the largest singular value is computed.
* = 2: an estimate for the smallest singular value is computed.
*
* J (input) INTEGER
* Length of X and W
*
* X (input) DOUBLE PRECISION array, dimension (J)
* The j-vector x.
*
* SEST (input) DOUBLE PRECISION
* Estimated singular value of j by j matrix L
*
* W (input) DOUBLE PRECISION array, dimension (J)
* The j-vector w.
*
* GAMMA (input) DOUBLE PRECISION
* The diagonal element gamma.
*
* SESTPR (output) DOUBLE PRECISION
* Estimated singular value of (j+1) by (j+1) matrix Lhat.
*
* S (output) DOUBLE PRECISION
* Sine needed in forming xhat.
*
* C (output) DOUBLE PRECISION
* Cosine needed in forming xhat.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
DOUBLE PRECISION HALF, FOUR
PARAMETER ( HALF = 0.5D0, FOUR = 4.0D0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION ABSALP, ABSEST, ABSGAM, ALPHA, B, COSINE, EPS,
$ NORMA, S1, S2, SINE, T, TEST, TMP, ZETA1, ZETA2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SIGN, SQRT
* ..
* .. External Functions ..
DOUBLE PRECISION DDOT, DLAMCH
EXTERNAL DDOT, DLAMCH
* ..
* .. Executable Statements ..
*
EPS = DLAMCH( 'Epsilon' )
ALPHA = DDOT( J, X, 1, W, 1 )
*
ABSALP = ABS( ALPHA )
ABSGAM = ABS( GAMMA )
ABSEST = ABS( SEST )
*
IF( JOB.EQ.1 ) THEN
*
* Estimating largest singular value
*
* special cases
*
IF( SEST.EQ.ZERO ) THEN
S1 = MAX( ABSGAM, ABSALP )
IF( S1.EQ.ZERO ) THEN
S = ZERO
C = ONE
SESTPR = ZERO
ELSE
S = ALPHA / S1
C = GAMMA / S1
TMP = SQRT( S*S+C*C )
S = S / TMP
C = C / TMP
SESTPR = S1*TMP
END IF
RETURN
ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN
S = ONE
C = ZERO
TMP = MAX( ABSEST, ABSALP )
S1 = ABSEST / TMP
S2 = ABSALP / TMP
SESTPR = TMP*SQRT( S1*S1+S2*S2 )
RETURN
ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN
S1 = ABSGAM
S2 = ABSEST
IF( S1.LE.S2 ) THEN
S = ONE
C = ZERO
SESTPR = S2
ELSE
S = ZERO
C = ONE
SESTPR = S1
END IF
RETURN
ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN
S1 = ABSGAM
S2 = ABSALP
IF( S1.LE.S2 ) THEN
TMP = S1 / S2
S = SQRT( ONE+TMP*TMP )
SESTPR = S2*S
C = ( GAMMA / S2 ) / S
S = SIGN( ONE, ALPHA ) / S
ELSE
TMP = S2 / S1
C = SQRT( ONE+TMP*TMP )
SESTPR = S1*C
S = ( ALPHA / S1 ) / C
C = SIGN( ONE, GAMMA ) / C
END IF
RETURN
ELSE
*
* normal case
*
ZETA1 = ALPHA / ABSEST
ZETA2 = GAMMA / ABSEST
*
B = ( ONE-ZETA1*ZETA1-ZETA2*ZETA2 )*HALF
C = ZETA1*ZETA1
IF( B.GT.ZERO ) THEN
T = C / ( B+SQRT( B*B+C ) )
ELSE
T = SQRT( B*B+C ) - B
END IF
*
SINE = -ZETA1 / T
COSINE = -ZETA2 / ( ONE+T )
TMP = SQRT( SINE*SINE+COSINE*COSINE )
S = SINE / TMP
C = COSINE / TMP
SESTPR = SQRT( T+ONE )*ABSEST
RETURN
END IF
*
ELSE IF( JOB.EQ.2 ) THEN
*
* Estimating smallest singular value
*
* special cases
*
IF( SEST.EQ.ZERO ) THEN
SESTPR = ZERO
IF( MAX( ABSGAM, ABSALP ).EQ.ZERO ) THEN
SINE = ONE
COSINE = ZERO
ELSE
SINE = -GAMMA
COSINE = ALPHA
END IF
S1 = MAX( ABS( SINE ), ABS( COSINE ) )
S = SINE / S1
C = COSINE / S1
TMP = SQRT( S*S+C*C )
S = S / TMP
C = C / TMP
RETURN
ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN
S = ZERO
C = ONE
SESTPR = ABSGAM
RETURN
ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN
S1 = ABSGAM
S2 = ABSEST
IF( S1.LE.S2 ) THEN
S = ZERO
C = ONE
SESTPR = S1
ELSE
S = ONE
C = ZERO
SESTPR = S2
END IF
RETURN
ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN
S1 = ABSGAM
S2 = ABSALP
IF( S1.LE.S2 ) THEN
TMP = S1 / S2
C = SQRT( ONE+TMP*TMP )
SESTPR = ABSEST*( TMP / C )
S = -( GAMMA / S2 ) / C
C = SIGN( ONE, ALPHA ) / C
ELSE
TMP = S2 / S1
S = SQRT( ONE+TMP*TMP )
SESTPR = ABSEST / S
C = ( ALPHA / S1 ) / S
S = -SIGN( ONE, GAMMA ) / S
END IF
RETURN
ELSE
*
* normal case
*
ZETA1 = ALPHA / ABSEST
ZETA2 = GAMMA / ABSEST
*
NORMA = MAX( ONE+ZETA1*ZETA1+ABS( ZETA1*ZETA2 ),
$ ABS( ZETA1*ZETA2 )+ZETA2*ZETA2 )
*
* See if root is closer to zero or to ONE
*
TEST = ONE + TWO*( ZETA1-ZETA2 )*( ZETA1+ZETA2 )
IF( TEST.GE.ZERO ) THEN
*
* root is close to zero, compute directly
*
B = ( ZETA1*ZETA1+ZETA2*ZETA2+ONE )*HALF
C = ZETA2*ZETA2
T = C / ( B+SQRT( ABS( B*B-C ) ) )
SINE = ZETA1 / ( ONE-T )
COSINE = -ZETA2 / T
SESTPR = SQRT( T+FOUR*EPS*EPS*NORMA )*ABSEST
ELSE
*
* root is closer to ONE, shift by that amount
*
B = ( ZETA2*ZETA2+ZETA1*ZETA1-ONE )*HALF
C = ZETA1*ZETA1
IF( B.GE.ZERO ) THEN
T = -C / ( B+SQRT( B*B+C ) )
ELSE
T = B - SQRT( B*B+C )
END IF
SINE = -ZETA1 / T
COSINE = -ZETA2 / ( ONE+T )
SESTPR = SQRT( ONE+T+FOUR*EPS*EPS*NORMA )*ABSEST
END IF
TMP = SQRT( SINE*SINE+COSINE*COSINE )
S = SINE / TMP
C = COSINE / TMP
RETURN
*
END IF
END IF
RETURN
*
* End of DLAIC1
*
END
LOGICAL FUNCTION DLAISNAN(DIN1,DIN2)
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
DOUBLE PRECISION DIN1,DIN2
* ..
*
* Purpose
* =======
*
* This routine is not for general use. It exists solely to avoid
* over-optimization in DISNAN.
*
* DLAISNAN checks for NaNs by comparing its two arguments for
* inequality. NaN is the only floating-point value where NaN != NaN
* returns .TRUE. To check for NaNs, pass the same variable as both
* arguments.
*
* Strictly speaking, Fortran does not allow aliasing of function
* arguments. So a compiler must assume that the two arguments are
* not the same variable, and the test will not be optimized away.
* Interprocedural or whole-program optimization may delete this
* test. The ISNAN functions will be replaced by the correct
* Fortran 03 intrinsic once the intrinsic is widely available.
*
* Arguments
* =========
*
* DIN1 (input) DOUBLE PRECISION
* DIN2 (input) DOUBLE PRECISION
* Two numbers to compare for inequality.
*
* =====================================================================
*
* .. Executable Statements ..
DLAISNAN = (DIN1.NE.DIN2)
RETURN
END
SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B,
$ LDB, WR, WI, X, LDX, SCALE, XNORM, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL LTRANS
INTEGER INFO, LDA, LDB, LDX, NA, NW
DOUBLE PRECISION CA, D1, D2, SCALE, SMIN, WI, WR, XNORM
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* DLALN2 solves a system of the form (ca A - w D ) X = s B
* or (ca A' - w D) X = s B with possible scaling ("s") and
* perturbation of A. (A' means A-transpose.)
*
* A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA
* real diagonal matrix, w is a real or complex value, and X and B are
* NA x 1 matrices -- real if w is real, complex if w is complex. NA
* may be 1 or 2.
*
* If w is complex, X and B are represented as NA x 2 matrices,
* the first column of each being the real part and the second
* being the imaginary part.
*
* "s" is a scaling factor (.LE. 1), computed by DLALN2, which is
* so chosen that X can be computed without overflow. X is further
* scaled if necessary to assure that norm(ca A - w D)*norm(X) is less
* than overflow.
*
* If both singular values of (ca A - w D) are less than SMIN,
* SMIN*identity will be used instead of (ca A - w D). If only one
* singular value is less than SMIN, one element of (ca A - w D) will be
* perturbed enough to make the smallest singular value roughly SMIN.
* If both singular values are at least SMIN, (ca A - w D) will not be
* perturbed. In any case, the perturbation will be at most some small
* multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values
* are computed by infinity-norm approximations, and thus will only be
* correct to a factor of 2 or so.
*
* Note: all input quantities are assumed to be smaller than overflow
* by a reasonable factor. (See BIGNUM.)
*
* Arguments
* ==========
*
* LTRANS (input) LOGICAL
* =.TRUE.: A-transpose will be used.
* =.FALSE.: A will be used (not transposed.)
*
* NA (input) INTEGER
* The size of the matrix A. It may (only) be 1 or 2.
*
* NW (input) INTEGER
* 1 if "w" is real, 2 if "w" is complex. It may only be 1
* or 2.
*
* SMIN (input) DOUBLE PRECISION
* The desired lower bound on the singular values of A. This
* should be a safe distance away from underflow or overflow,
* say, between (underflow/machine precision) and (machine
* precision * overflow ). (See BIGNUM and ULP.)
*
* CA (input) DOUBLE PRECISION
* The coefficient c, which A is multiplied by.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,NA)
* The NA x NA matrix A.
*
* LDA (input) INTEGER
* The leading dimension of A. It must be at least NA.
*
* D1 (input) DOUBLE PRECISION
* The 1,1 element in the diagonal matrix D.
*
* D2 (input) DOUBLE PRECISION
* The 2,2 element in the diagonal matrix D. Not used if NW=1.
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NW)
* The NA x NW matrix B (right-hand side). If NW=2 ("w" is
* complex), column 1 contains the real part of B and column 2
* contains the imaginary part.
*
* LDB (input) INTEGER
* The leading dimension of B. It must be at least NA.
*
* WR (input) DOUBLE PRECISION
* The real part of the scalar "w".
*
* WI (input) DOUBLE PRECISION
* The imaginary part of the scalar "w". Not used if NW=1.
*
* X (output) DOUBLE PRECISION array, dimension (LDX,NW)
* The NA x NW matrix X (unknowns), as computed by DLALN2.
* If NW=2 ("w" is complex), on exit, column 1 will contain
* the real part of X and column 2 will contain the imaginary
* part.
*
* LDX (input) INTEGER
* The leading dimension of X. It must be at least NA.
*
* SCALE (output) DOUBLE PRECISION
* The scale factor that B must be multiplied by to insure
* that overflow does not occur when computing X. Thus,
* (ca A - w D) X will be SCALE*B, not B (ignoring
* perturbations of A.) It will be at most 1.
*
* XNORM (output) DOUBLE PRECISION
* The infinity-norm of X, when X is regarded as an NA x NW
* real matrix.
*
* INFO (output) INTEGER
* An error flag. It will be set to zero if no error occurs,
* a negative number if an argument is in error, or a positive
* number if ca A - w D had to be perturbed.
* The possible values are:
* = 0: No error occurred, and (ca A - w D) did not have to be
* perturbed.
* = 1: (ca A - w D) had to be perturbed to make its smallest
* (or only) singular value greater than SMIN.
* NOTE: In the interests of speed, this routine does not
* check the inputs for errors.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D0 )
* ..
* .. Local Scalars ..
INTEGER ICMAX, J
DOUBLE PRECISION BBND, BI1, BI2, BIGNUM, BNORM, BR1, BR2, CI21,
$ CI22, CMAX, CNORM, CR21, CR22, CSI, CSR, LI21,
$ LR21, SMINI, SMLNUM, TEMP, U22ABS, UI11, UI11R,
$ UI12, UI12S, UI22, UR11, UR11R, UR12, UR12S,
$ UR22, XI1, XI2, XR1, XR2
* ..
* .. Local Arrays ..
LOGICAL RSWAP( 4 ), ZSWAP( 4 )
INTEGER IPIVOT( 4, 4 )
DOUBLE PRECISION CI( 2, 2 ), CIV( 4 ), CR( 2, 2 ), CRV( 4 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DLADIV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Equivalences ..
EQUIVALENCE ( CI( 1, 1 ), CIV( 1 ) ),
$ ( CR( 1, 1 ), CRV( 1 ) )
* ..
* .. Data statements ..
DATA ZSWAP / .FALSE., .FALSE., .TRUE., .TRUE. /
DATA RSWAP / .FALSE., .TRUE., .FALSE., .TRUE. /
DATA IPIVOT / 1, 2, 3, 4, 2, 1, 4, 3, 3, 4, 1, 2, 4,
$ 3, 2, 1 /
* ..
* .. Executable Statements ..
*
* Compute BIGNUM
*
SMLNUM = TWO*DLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
SMINI = MAX( SMIN, SMLNUM )
*
* Don't check for input errors
*
INFO = 0
*
* Standard Initializations
*
SCALE = ONE
*
IF( NA.EQ.1 ) THEN
*
* 1 x 1 (i.e., scalar) system C X = B
*
IF( NW.EQ.1 ) THEN
*
* Real 1x1 system.
*
* C = ca A - w D
*
CSR = CA*A( 1, 1 ) - WR*D1
CNORM = ABS( CSR )
*
* If | C | < SMINI, use C = SMINI
*
IF( CNORM.LT.SMINI ) THEN
CSR = SMINI
CNORM = SMINI
INFO = 1
END IF
*
* Check scaling for X = B / C
*
BNORM = ABS( B( 1, 1 ) )
IF( CNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN
IF( BNORM.GT.BIGNUM*CNORM )
$ SCALE = ONE / BNORM
END IF
*
* Compute X
*
X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / CSR
XNORM = ABS( X( 1, 1 ) )
ELSE
*
* Complex 1x1 system (w is complex)
*
* C = ca A - w D
*
CSR = CA*A( 1, 1 ) - WR*D1
CSI = -WI*D1
CNORM = ABS( CSR ) + ABS( CSI )
*
* If | C | < SMINI, use C = SMINI
*
IF( CNORM.LT.SMINI ) THEN
CSR = SMINI
CSI = ZERO
CNORM = SMINI
INFO = 1
END IF
*
* Check scaling for X = B / C
*
BNORM = ABS( B( 1, 1 ) ) + ABS( B( 1, 2 ) )
IF( CNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN
IF( BNORM.GT.BIGNUM*CNORM )
$ SCALE = ONE / BNORM
END IF
*
* Compute X
*
CALL DLADIV( SCALE*B( 1, 1 ), SCALE*B( 1, 2 ), CSR, CSI,
$ X( 1, 1 ), X( 1, 2 ) )
XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) )
END IF
*
ELSE
*
* 2x2 System
*
* Compute the real part of C = ca A - w D (or ca A' - w D )
*
CR( 1, 1 ) = CA*A( 1, 1 ) - WR*D1
CR( 2, 2 ) = CA*A( 2, 2 ) - WR*D2
IF( LTRANS ) THEN
CR( 1, 2 ) = CA*A( 2, 1 )
CR( 2, 1 ) = CA*A( 1, 2 )
ELSE
CR( 2, 1 ) = CA*A( 2, 1 )
CR( 1, 2 ) = CA*A( 1, 2 )
END IF
*
IF( NW.EQ.1 ) THEN
*
* Real 2x2 system (w is real)
*
* Find the largest element in C
*
CMAX = ZERO
ICMAX = 0
*
DO 10 J = 1, 4
IF( ABS( CRV( J ) ).GT.CMAX ) THEN
CMAX = ABS( CRV( J ) )
ICMAX = J
END IF
10 CONTINUE
*
* If norm(C) < SMINI, use SMINI*identity.
*
IF( CMAX.LT.SMINI ) THEN
BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 2, 1 ) ) )
IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN
IF( BNORM.GT.BIGNUM*SMINI )
$ SCALE = ONE / BNORM
END IF
TEMP = SCALE / SMINI
X( 1, 1 ) = TEMP*B( 1, 1 )
X( 2, 1 ) = TEMP*B( 2, 1 )
XNORM = TEMP*BNORM
INFO = 1
RETURN
END IF
*
* Gaussian elimination with complete pivoting.
*
UR11 = CRV( ICMAX )
CR21 = CRV( IPIVOT( 2, ICMAX ) )
UR12 = CRV( IPIVOT( 3, ICMAX ) )
CR22 = CRV( IPIVOT( 4, ICMAX ) )
UR11R = ONE / UR11
LR21 = UR11R*CR21
UR22 = CR22 - UR12*LR21
*
* If smaller pivot < SMINI, use SMINI
*
IF( ABS( UR22 ).LT.SMINI ) THEN
UR22 = SMINI
INFO = 1
END IF
IF( RSWAP( ICMAX ) ) THEN
BR1 = B( 2, 1 )
BR2 = B( 1, 1 )
ELSE
BR1 = B( 1, 1 )
BR2 = B( 2, 1 )
END IF
BR2 = BR2 - LR21*BR1
BBND = MAX( ABS( BR1*( UR22*UR11R ) ), ABS( BR2 ) )
IF( BBND.GT.ONE .AND. ABS( UR22 ).LT.ONE ) THEN
IF( BBND.GE.BIGNUM*ABS( UR22 ) )
$ SCALE = ONE / BBND
END IF
*
XR2 = ( BR2*SCALE ) / UR22
XR1 = ( SCALE*BR1 )*UR11R - XR2*( UR11R*UR12 )
IF( ZSWAP( ICMAX ) ) THEN
X( 1, 1 ) = XR2
X( 2, 1 ) = XR1
ELSE
X( 1, 1 ) = XR1
X( 2, 1 ) = XR2
END IF
XNORM = MAX( ABS( XR1 ), ABS( XR2 ) )
*
* Further scaling if norm(A) norm(X) > overflow
*
IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN
IF( XNORM.GT.BIGNUM / CMAX ) THEN
TEMP = CMAX / BIGNUM
X( 1, 1 ) = TEMP*X( 1, 1 )
X( 2, 1 ) = TEMP*X( 2, 1 )
XNORM = TEMP*XNORM
SCALE = TEMP*SCALE
END IF
END IF
ELSE
*
* Complex 2x2 system (w is complex)
*
* Find the largest element in C
*
CI( 1, 1 ) = -WI*D1
CI( 2, 1 ) = ZERO
CI( 1, 2 ) = ZERO
CI( 2, 2 ) = -WI*D2
CMAX = ZERO
ICMAX = 0
*
DO 20 J = 1, 4
IF( ABS( CRV( J ) )+ABS( CIV( J ) ).GT.CMAX ) THEN
CMAX = ABS( CRV( J ) ) + ABS( CIV( J ) )
ICMAX = J
END IF
20 CONTINUE
*
* If norm(C) < SMINI, use SMINI*identity.
*
IF( CMAX.LT.SMINI ) THEN
BNORM = MAX( ABS( B( 1, 1 ) )+ABS( B( 1, 2 ) ),
$ ABS( B( 2, 1 ) )+ABS( B( 2, 2 ) ) )
IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN
IF( BNORM.GT.BIGNUM*SMINI )
$ SCALE = ONE / BNORM
END IF
TEMP = SCALE / SMINI
X( 1, 1 ) = TEMP*B( 1, 1 )
X( 2, 1 ) = TEMP*B( 2, 1 )
X( 1, 2 ) = TEMP*B( 1, 2 )
X( 2, 2 ) = TEMP*B( 2, 2 )
XNORM = TEMP*BNORM
INFO = 1
RETURN
END IF
*
* Gaussian elimination with complete pivoting.
*
UR11 = CRV( ICMAX )
UI11 = CIV( ICMAX )
CR21 = CRV( IPIVOT( 2, ICMAX ) )
CI21 = CIV( IPIVOT( 2, ICMAX ) )
UR12 = CRV( IPIVOT( 3, ICMAX ) )
UI12 = CIV( IPIVOT( 3, ICMAX ) )
CR22 = CRV( IPIVOT( 4, ICMAX ) )
CI22 = CIV( IPIVOT( 4, ICMAX ) )
IF( ICMAX.EQ.1 .OR. ICMAX.EQ.4 ) THEN
*
* Code when off-diagonals of pivoted C are real
*
IF( ABS( UR11 ).GT.ABS( UI11 ) ) THEN
TEMP = UI11 / UR11
UR11R = ONE / ( UR11*( ONE+TEMP**2 ) )
UI11R = -TEMP*UR11R
ELSE
TEMP = UR11 / UI11
UI11R = -ONE / ( UI11*( ONE+TEMP**2 ) )
UR11R = -TEMP*UI11R
END IF
LR21 = CR21*UR11R
LI21 = CR21*UI11R
UR12S = UR12*UR11R
UI12S = UR12*UI11R
UR22 = CR22 - UR12*LR21
UI22 = CI22 - UR12*LI21
ELSE
*
* Code when diagonals of pivoted C are real
*
UR11R = ONE / UR11
UI11R = ZERO
LR21 = CR21*UR11R
LI21 = CI21*UR11R
UR12S = UR12*UR11R
UI12S = UI12*UR11R
UR22 = CR22 - UR12*LR21 + UI12*LI21
UI22 = -UR12*LI21 - UI12*LR21
END IF
U22ABS = ABS( UR22 ) + ABS( UI22 )
*
* If smaller pivot < SMINI, use SMINI
*
IF( U22ABS.LT.SMINI ) THEN
UR22 = SMINI
UI22 = ZERO
INFO = 1
END IF
IF( RSWAP( ICMAX ) ) THEN
BR2 = B( 1, 1 )
BR1 = B( 2, 1 )
BI2 = B( 1, 2 )
BI1 = B( 2, 2 )
ELSE
BR1 = B( 1, 1 )
BR2 = B( 2, 1 )
BI1 = B( 1, 2 )
BI2 = B( 2, 2 )
END IF
BR2 = BR2 - LR21*BR1 + LI21*BI1
BI2 = BI2 - LI21*BR1 - LR21*BI1
BBND = MAX( ( ABS( BR1 )+ABS( BI1 ) )*
$ ( U22ABS*( ABS( UR11R )+ABS( UI11R ) ) ),
$ ABS( BR2 )+ABS( BI2 ) )
IF( BBND.GT.ONE .AND. U22ABS.LT.ONE ) THEN
IF( BBND.GE.BIGNUM*U22ABS ) THEN
SCALE = ONE / BBND
BR1 = SCALE*BR1
BI1 = SCALE*BI1
BR2 = SCALE*BR2
BI2 = SCALE*BI2
END IF
END IF
*
CALL DLADIV( BR2, BI2, UR22, UI22, XR2, XI2 )
XR1 = UR11R*BR1 - UI11R*BI1 - UR12S*XR2 + UI12S*XI2
XI1 = UI11R*BR1 + UR11R*BI1 - UI12S*XR2 - UR12S*XI2
IF( ZSWAP( ICMAX ) ) THEN
X( 1, 1 ) = XR2
X( 2, 1 ) = XR1
X( 1, 2 ) = XI2
X( 2, 2 ) = XI1
ELSE
X( 1, 1 ) = XR1
X( 2, 1 ) = XR2
X( 1, 2 ) = XI1
X( 2, 2 ) = XI2
END IF
XNORM = MAX( ABS( XR1 )+ABS( XI1 ), ABS( XR2 )+ABS( XI2 ) )
*
* Further scaling if norm(A) norm(X) > overflow
*
IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN
IF( XNORM.GT.BIGNUM / CMAX ) THEN
TEMP = CMAX / BIGNUM
X( 1, 1 ) = TEMP*X( 1, 1 )
X( 2, 1 ) = TEMP*X( 2, 1 )
X( 1, 2 ) = TEMP*X( 1, 2 )
X( 2, 2 ) = TEMP*X( 2, 2 )
XNORM = TEMP*XNORM
SCALE = TEMP*SCALE
END IF
END IF
END IF
END IF
*
RETURN
*
* End of DLALN2
*
END
SUBROUTINE DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX,
$ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM,
$ POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL,
$ LDGNUM, NL, NR, NRHS, SQRE
DOUBLE PRECISION C, S
* ..
* .. Array Arguments ..
INTEGER GIVCOL( LDGCOL, * ), PERM( * )
DOUBLE PRECISION B( LDB, * ), BX( LDBX, * ), DIFL( * ),
$ DIFR( LDGNUM, * ), GIVNUM( LDGNUM, * ),
$ POLES( LDGNUM, * ), WORK( * ), Z( * )
* ..
*
* Purpose
* =======
*
* DLALS0 applies back the multiplying factors of either the left or the
* right singular vector matrix of a diagonal matrix appended by a row
* to the right hand side matrix B in solving the least squares problem
* using the divide-and-conquer SVD approach.
*
* For the left singular vector matrix, three types of orthogonal
* matrices are involved:
*
* (1L) Givens rotations: the number of such rotations is GIVPTR; the
* pairs of columns/rows they were applied to are stored in GIVCOL;
* and the C- and S-values of these rotations are stored in GIVNUM.
*
* (2L) Permutation. The (NL+1)-st row of B is to be moved to the first
* row, and for J=2:N, PERM(J)-th row of B is to be moved to the
* J-th row.
*
* (3L) The left singular vector matrix of the remaining matrix.
*
* For the right singular vector matrix, four types of orthogonal
* matrices are involved:
*
* (1R) The right singular vector matrix of the remaining matrix.
*
* (2R) If SQRE = 1, one extra Givens rotation to generate the right
* null space.
*
* (3R) The inverse transformation of (2L).
*
* (4R) The inverse transformation of (1L).
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* Specifies whether singular vectors are to be computed in
* factored form:
* = 0: Left singular vector matrix.
* = 1: Right singular vector matrix.
*
* NL (input) INTEGER
* The row dimension of the upper block. NL >= 1.
*
* NR (input) INTEGER
* The row dimension of the lower block. NR >= 1.
*
* SQRE (input) INTEGER
* = 0: the lower block is an NR-by-NR square matrix.
* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
*
* The bidiagonal matrix has row dimension N = NL + NR + 1,
* and column dimension M = N + SQRE.
*
* NRHS (input) INTEGER
* The number of columns of B and BX. NRHS must be at least 1.
*
* B (input/output) DOUBLE PRECISION array, dimension ( LDB, NRHS )
* On input, B contains the right hand sides of the least
* squares problem in rows 1 through M. On output, B contains
* the solution X in rows 1 through N.
*
* LDB (input) INTEGER
* The leading dimension of B. LDB must be at least
* max(1,MAX( M, N ) ).
*
* BX (workspace) DOUBLE PRECISION array, dimension ( LDBX, NRHS )
*
* LDBX (input) INTEGER
* The leading dimension of BX.
*
* PERM (input) INTEGER array, dimension ( N )
* The permutations (from deflation and sorting) applied
* to the two blocks.
*
* GIVPTR (input) INTEGER
* The number of Givens rotations which took place in this
* subproblem.
*
* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )
* Each pair of numbers indicates a pair of rows/columns
* involved in a Givens rotation.
*
* LDGCOL (input) INTEGER
* The leading dimension of GIVCOL, must be at least N.
*
* GIVNUM (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
* Each number indicates the C or S value used in the
* corresponding Givens rotation.
*
* LDGNUM (input) INTEGER
* The leading dimension of arrays DIFR, POLES and
* GIVNUM, must be at least K.
*
* POLES (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
* On entry, POLES(1:K, 1) contains the new singular
* values obtained from solving the secular equation, and
* POLES(1:K, 2) is an array containing the poles in the secular
* equation.
*
* DIFL (input) DOUBLE PRECISION array, dimension ( K ).
* On entry, DIFL(I) is the distance between I-th updated
* (undeflated) singular value and the I-th (undeflated) old
* singular value.
*
* DIFR (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ).
* On entry, DIFR(I, 1) contains the distances between I-th
* updated (undeflated) singular value and the I+1-th
* (undeflated) old singular value. And DIFR(I, 2) is the
* normalizing factor for the I-th right singular vector.
*
* Z (input) DOUBLE PRECISION array, dimension ( K )
* Contain the components of the deflation-adjusted updating row
* vector.
*
* K (input) INTEGER
* Contains the dimension of the non-deflated matrix,
* This is the order of the related secular equation. 1 <= K <=N.
*
* C (input) DOUBLE PRECISION
* C contains garbage if SQRE =0 and the C-value of a Givens
* rotation related to the right null space if SQRE = 1.
*
* S (input) DOUBLE PRECISION
* S contains garbage if SQRE =0 and the S-value of a Givens
* rotation related to the right null space if SQRE = 1.
*
* WORK (workspace) DOUBLE PRECISION array, dimension ( K )
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Ren-Cang Li, Computer Science Division, University of
* California at Berkeley, USA
* Osni Marques, LBNL/NERSC, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO, NEGONE
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, NEGONE = -1.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, J, M, N, NLP1
DOUBLE PRECISION DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, TEMP
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMV, DLACPY, DLASCL, DROT, DSCAL,
$ XERBLA
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMC3, DNRM2
EXTERNAL DLAMC3, DNRM2
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
INFO = -1
ELSE IF( NL.LT.1 ) THEN
INFO = -2
ELSE IF( NR.LT.1 ) THEN
INFO = -3
ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
INFO = -4
END IF
*
N = NL + NR + 1
*
IF( NRHS.LT.1 ) THEN
INFO = -5
ELSE IF( LDB.LT.N ) THEN
INFO = -7
ELSE IF( LDBX.LT.N ) THEN
INFO = -9
ELSE IF( GIVPTR.LT.0 ) THEN
INFO = -11
ELSE IF( LDGCOL.LT.N ) THEN
INFO = -13
ELSE IF( LDGNUM.LT.N ) THEN
INFO = -15
ELSE IF( K.LT.1 ) THEN
INFO = -20
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLALS0', -INFO )
RETURN
END IF
*
M = N + SQRE
NLP1 = NL + 1
*
IF( ICOMPQ.EQ.0 ) THEN
*
* Apply back orthogonal transformations from the left.
*
* Step (1L): apply back the Givens rotations performed.
*
DO 10 I = 1, GIVPTR
CALL DROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB,
$ B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ),
$ GIVNUM( I, 1 ) )
10 CONTINUE
*
* Step (2L): permute rows of B.
*
CALL DCOPY( NRHS, B( NLP1, 1 ), LDB, BX( 1, 1 ), LDBX )
DO 20 I = 2, N
CALL DCOPY( NRHS, B( PERM( I ), 1 ), LDB, BX( I, 1 ), LDBX )
20 CONTINUE
*
* Step (3L): apply the inverse of the left singular vector
* matrix to BX.
*
IF( K.EQ.1 ) THEN
CALL DCOPY( NRHS, BX, LDBX, B, LDB )
IF( Z( 1 ).LT.ZERO ) THEN
CALL DSCAL( NRHS, NEGONE, B, LDB )
END IF
ELSE
DO 50 J = 1, K
DIFLJ = DIFL( J )
DJ = POLES( J, 1 )
DSIGJ = -POLES( J, 2 )
IF( J.LT.K ) THEN
DIFRJ = -DIFR( J, 1 )
DSIGJP = -POLES( J+1, 2 )
END IF
IF( ( Z( J ).EQ.ZERO ) .OR. ( POLES( J, 2 ).EQ.ZERO ) )
$ THEN
WORK( J ) = ZERO
ELSE
WORK( J ) = -POLES( J, 2 )*Z( J ) / DIFLJ /
$ ( POLES( J, 2 )+DJ )
END IF
DO 30 I = 1, J - 1
IF( ( Z( I ).EQ.ZERO ) .OR.
$ ( POLES( I, 2 ).EQ.ZERO ) ) THEN
WORK( I ) = ZERO
ELSE
WORK( I ) = POLES( I, 2 )*Z( I ) /
$ ( DLAMC3( POLES( I, 2 ), DSIGJ )-
$ DIFLJ ) / ( POLES( I, 2 )+DJ )
END IF
30 CONTINUE
DO 40 I = J + 1, K
IF( ( Z( I ).EQ.ZERO ) .OR.
$ ( POLES( I, 2 ).EQ.ZERO ) ) THEN
WORK( I ) = ZERO
ELSE
WORK( I ) = POLES( I, 2 )*Z( I ) /
$ ( DLAMC3( POLES( I, 2 ), DSIGJP )+
$ DIFRJ ) / ( POLES( I, 2 )+DJ )
END IF
40 CONTINUE
WORK( 1 ) = NEGONE
TEMP = DNRM2( K, WORK, 1 )
CALL DGEMV( 'T', K, NRHS, ONE, BX, LDBX, WORK, 1, ZERO,
$ B( J, 1 ), LDB )
CALL DLASCL( 'G', 0, 0, TEMP, ONE, 1, NRHS, B( J, 1 ),
$ LDB, INFO )
50 CONTINUE
END IF
*
* Move the deflated rows of BX to B also.
*
IF( K.LT.MAX( M, N ) )
$ CALL DLACPY( 'A', N-K, NRHS, BX( K+1, 1 ), LDBX,
$ B( K+1, 1 ), LDB )
ELSE
*
* Apply back the right orthogonal transformations.
*
* Step (1R): apply back the new right singular vector matrix
* to B.
*
IF( K.EQ.1 ) THEN
CALL DCOPY( NRHS, B, LDB, BX, LDBX )
ELSE
DO 80 J = 1, K
DSIGJ = POLES( J, 2 )
IF( Z( J ).EQ.ZERO ) THEN
WORK( J ) = ZERO
ELSE
WORK( J ) = -Z( J ) / DIFL( J ) /
$ ( DSIGJ+POLES( J, 1 ) ) / DIFR( J, 2 )
END IF
DO 60 I = 1, J - 1
IF( Z( J ).EQ.ZERO ) THEN
WORK( I ) = ZERO
ELSE
WORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I+1,
$ 2 ) )-DIFR( I, 1 ) ) /
$ ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )
END IF
60 CONTINUE
DO 70 I = J + 1, K
IF( Z( J ).EQ.ZERO ) THEN
WORK( I ) = ZERO
ELSE
WORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I,
$ 2 ) )-DIFL( I ) ) /
$ ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )
END IF
70 CONTINUE
CALL DGEMV( 'T', K, NRHS, ONE, B, LDB, WORK, 1, ZERO,
$ BX( J, 1 ), LDBX )
80 CONTINUE
END IF
*
* Step (2R): if SQRE = 1, apply back the rotation that is
* related to the right null space of the subproblem.
*
IF( SQRE.EQ.1 ) THEN
CALL DCOPY( NRHS, B( M, 1 ), LDB, BX( M, 1 ), LDBX )
CALL DROT( NRHS, BX( 1, 1 ), LDBX, BX( M, 1 ), LDBX, C, S )
END IF
IF( K.LT.MAX( M, N ) )
$ CALL DLACPY( 'A', N-K, NRHS, B( K+1, 1 ), LDB, BX( K+1, 1 ),
$ LDBX )
*
* Step (3R): permute rows of B.
*
CALL DCOPY( NRHS, BX( 1, 1 ), LDBX, B( NLP1, 1 ), LDB )
IF( SQRE.EQ.1 ) THEN
CALL DCOPY( NRHS, BX( M, 1 ), LDBX, B( M, 1 ), LDB )
END IF
DO 90 I = 2, N
CALL DCOPY( NRHS, BX( I, 1 ), LDBX, B( PERM( I ), 1 ), LDB )
90 CONTINUE
*
* Step (4R): apply back the Givens rotations performed.
*
DO 100 I = GIVPTR, 1, -1
CALL DROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB,
$ B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ),
$ -GIVNUM( I, 1 ) )
100 CONTINUE
END IF
*
RETURN
*
* End of DLALS0
*
END
SUBROUTINE DLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U,
$ LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR,
$ GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK,
$ IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS,
$ SMLSIZ
* ..
* .. Array Arguments ..
INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ),
$ K( * ), PERM( LDGCOL, * )
DOUBLE PRECISION B( LDB, * ), BX( LDBX, * ), C( * ),
$ DIFL( LDU, * ), DIFR( LDU, * ),
$ GIVNUM( LDU, * ), POLES( LDU, * ), S( * ),
$ U( LDU, * ), VT( LDU, * ), WORK( * ),
$ Z( LDU, * )
* ..
*
* Purpose
* =======
*
* DLALSA is an itermediate step in solving the least squares problem
* by computing the SVD of the coefficient matrix in compact form (The
* singular vectors are computed as products of simple orthorgonal
* matrices.).
*
* If ICOMPQ = 0, DLALSA applies the inverse of the left singular vector
* matrix of an upper bidiagonal matrix to the right hand side; and if
* ICOMPQ = 1, DLALSA applies the right singular vector matrix to the
* right hand side. The singular vector matrices were generated in
* compact form by DLALSA.
*
* Arguments
* =========
*
*
* ICOMPQ (input) INTEGER
* Specifies whether the left or the right singular vector
* matrix is involved.
* = 0: Left singular vector matrix
* = 1: Right singular vector matrix
*
* SMLSIZ (input) INTEGER
* The maximum size of the subproblems at the bottom of the
* computation tree.
*
* N (input) INTEGER
* The row and column dimensions of the upper bidiagonal matrix.
*
* NRHS (input) INTEGER
* The number of columns of B and BX. NRHS must be at least 1.
*
* B (input/output) DOUBLE PRECISION array, dimension ( LDB, NRHS )
* On input, B contains the right hand sides of the least
* squares problem in rows 1 through M.
* On output, B contains the solution X in rows 1 through N.
*
* LDB (input) INTEGER
* The leading dimension of B in the calling subprogram.
* LDB must be at least max(1,MAX( M, N ) ).
*
* BX (output) DOUBLE PRECISION array, dimension ( LDBX, NRHS )
* On exit, the result of applying the left or right singular
* vector matrix to B.
*
* LDBX (input) INTEGER
* The leading dimension of BX.
*
* U (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ).
* On entry, U contains the left singular vector matrices of all
* subproblems at the bottom level.
*
* LDU (input) INTEGER, LDU = > N.
* The leading dimension of arrays U, VT, DIFL, DIFR,
* POLES, GIVNUM, and Z.
*
* VT (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ).
* On entry, VT' contains the right singular vector matrices of
* all subproblems at the bottom level.
*
* K (input) INTEGER array, dimension ( N ).
*
* DIFL (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).
* where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.
*
* DIFR (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
* On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record
* distances between singular values on the I-th level and
* singular values on the (I -1)-th level, and DIFR(*, 2 * I)
* record the normalizing factors of the right singular vectors
* matrices of subproblems on I-th level.
*
* Z (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).
* On entry, Z(1, I) contains the components of the deflation-
* adjusted updating row vector for subproblems on the I-th
* level.
*
* POLES (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
* On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old
* singular values involved in the secular equations on the I-th
* level.
*
* GIVPTR (input) INTEGER array, dimension ( N ).
* On entry, GIVPTR( I ) records the number of Givens
* rotations performed on the I-th problem on the computation
* tree.
*
* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ).
* On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the
* locations of Givens rotations performed on the I-th level on
* the computation tree.
*
* LDGCOL (input) INTEGER, LDGCOL = > N.
* The leading dimension of arrays GIVCOL and PERM.
*
* PERM (input) INTEGER array, dimension ( LDGCOL, NLVL ).
* On entry, PERM(*, I) records permutations done on the I-th
* level of the computation tree.
*
* GIVNUM (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
* On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-
* values of Givens rotations performed on the I-th level on the
* computation tree.
*
* C (input) DOUBLE PRECISION array, dimension ( N ).
* On entry, if the I-th subproblem is not square,
* C( I ) contains the C-value of a Givens rotation related to
* the right null space of the I-th subproblem.
*
* S (input) DOUBLE PRECISION array, dimension ( N ).
* On entry, if the I-th subproblem is not square,
* S( I ) contains the S-value of a Givens rotation related to
* the right null space of the I-th subproblem.
*
* WORK (workspace) DOUBLE PRECISION array.
* The dimension must be at least N.
*
* IWORK (workspace) INTEGER array.
* The dimension must be at least 3 * N
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Ren-Cang Li, Computer Science Division, University of
* California at Berkeley, USA
* Osni Marques, LBNL/NERSC, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, I1, IC, IM1, INODE, J, LF, LL, LVL, LVL2,
$ ND, NDB1, NDIML, NDIMR, NL, NLF, NLP1, NLVL,
$ NR, NRF, NRP1, SQRE
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMM, DLALS0, DLASDT, XERBLA
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
INFO = -1
ELSE IF( SMLSIZ.LT.3 ) THEN
INFO = -2
ELSE IF( N.LT.SMLSIZ ) THEN
INFO = -3
ELSE IF( NRHS.LT.1 ) THEN
INFO = -4
ELSE IF( LDB.LT.N ) THEN
INFO = -6
ELSE IF( LDBX.LT.N ) THEN
INFO = -8
ELSE IF( LDU.LT.N ) THEN
INFO = -10
ELSE IF( LDGCOL.LT.N ) THEN
INFO = -19
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLALSA', -INFO )
RETURN
END IF
*
* Book-keeping and setting up the computation tree.
*
INODE = 1
NDIML = INODE + N
NDIMR = NDIML + N
*
CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ),
$ IWORK( NDIMR ), SMLSIZ )
*
* The following code applies back the left singular vector factors.
* For applying back the right singular vector factors, go to 50.
*
IF( ICOMPQ.EQ.1 ) THEN
GO TO 50
END IF
*
* The nodes on the bottom level of the tree were solved
* by DLASDQ. The corresponding left and right singular vector
* matrices are in explicit form. First apply back the left
* singular vector matrices.
*
NDB1 = ( ND+1 ) / 2
DO 10 I = NDB1, ND
*
* IC : center row of each node
* NL : number of rows of left subproblem
* NR : number of rows of right subproblem
* NLF: starting row of the left subproblem
* NRF: starting row of the right subproblem
*
I1 = I - 1
IC = IWORK( INODE+I1 )
NL = IWORK( NDIML+I1 )
NR = IWORK( NDIMR+I1 )
NLF = IC - NL
NRF = IC + 1
CALL DGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU,
$ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX )
CALL DGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU,
$ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX )
10 CONTINUE
*
* Next copy the rows of B that correspond to unchanged rows
* in the bidiagonal matrix to BX.
*
DO 20 I = 1, ND
IC = IWORK( INODE+I-1 )
CALL DCOPY( NRHS, B( IC, 1 ), LDB, BX( IC, 1 ), LDBX )
20 CONTINUE
*
* Finally go through the left singular vector matrices of all
* the other subproblems bottom-up on the tree.
*
J = 2**NLVL
SQRE = 0
*
DO 40 LVL = NLVL, 1, -1
LVL2 = 2*LVL - 1
*
* find the first node LF and last node LL on
* the current level LVL
*
IF( LVL.EQ.1 ) THEN
LF = 1
LL = 1
ELSE
LF = 2**( LVL-1 )
LL = 2*LF - 1
END IF
DO 30 I = LF, LL
IM1 = I - 1
IC = IWORK( INODE+IM1 )
NL = IWORK( NDIML+IM1 )
NR = IWORK( NDIMR+IM1 )
NLF = IC - NL
NRF = IC + 1
J = J - 1
CALL DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, BX( NLF, 1 ), LDBX,
$ B( NLF, 1 ), LDB, PERM( NLF, LVL ),
$ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
$ GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ),
$ DIFL( NLF, LVL ), DIFR( NLF, LVL2 ),
$ Z( NLF, LVL ), K( J ), C( J ), S( J ), WORK,
$ INFO )
30 CONTINUE
40 CONTINUE
GO TO 90
*
* ICOMPQ = 1: applying back the right singular vector factors.
*
50 CONTINUE
*
* First now go through the right singular vector matrices of all
* the tree nodes top-down.
*
J = 0
DO 70 LVL = 1, NLVL
LVL2 = 2*LVL - 1
*
* Find the first node LF and last node LL on
* the current level LVL.
*
IF( LVL.EQ.1 ) THEN
LF = 1
LL = 1
ELSE
LF = 2**( LVL-1 )
LL = 2*LF - 1
END IF
DO 60 I = LL, LF, -1
IM1 = I - 1
IC = IWORK( INODE+IM1 )
NL = IWORK( NDIML+IM1 )
NR = IWORK( NDIMR+IM1 )
NLF = IC - NL
NRF = IC + 1
IF( I.EQ.LL ) THEN
SQRE = 0
ELSE
SQRE = 1
END IF
J = J + 1
CALL DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B( NLF, 1 ), LDB,
$ BX( NLF, 1 ), LDBX, PERM( NLF, LVL ),
$ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
$ GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ),
$ DIFL( NLF, LVL ), DIFR( NLF, LVL2 ),
$ Z( NLF, LVL ), K( J ), C( J ), S( J ), WORK,
$ INFO )
60 CONTINUE
70 CONTINUE
*
* The nodes on the bottom level of the tree were solved
* by DLASDQ. The corresponding right singular vector
* matrices are in explicit form. Apply them back.
*
NDB1 = ( ND+1 ) / 2
DO 80 I = NDB1, ND
I1 = I - 1
IC = IWORK( INODE+I1 )
NL = IWORK( NDIML+I1 )
NR = IWORK( NDIMR+I1 )
NLP1 = NL + 1
IF( I.EQ.ND ) THEN
NRP1 = NR
ELSE
NRP1 = NR + 1
END IF
NLF = IC - NL
NRF = IC + 1
CALL DGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU,
$ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX )
CALL DGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU,
$ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX )
80 CONTINUE
*
90 CONTINUE
*
RETURN
*
* End of DLALSA
*
END
SUBROUTINE DLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND,
$ RANK, WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDB, N, NRHS, RANK, SMLSIZ
DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION B( LDB, * ), D( * ), E( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLALSD uses the singular value decomposition of A to solve the least
* squares problem of finding X to minimize the Euclidean norm of each
* column of A*X-B, where A is N-by-N upper bidiagonal, and X and B
* are N-by-NRHS. The solution X overwrites B.
*
* The singular values of A smaller than RCOND times the largest
* singular value are treated as zero in solving the least squares
* problem; in this case a minimum norm solution is returned.
* The actual singular values are returned in D in ascending order.
*
* This code makes very mild assumptions about floating point
* arithmetic. It will work on machines with a guard digit in
* add/subtract, or on those binary machines without guard digits
* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
* It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': D and E define an upper bidiagonal matrix.
* = 'L': D and E define a lower bidiagonal matrix.
*
* SMLSIZ (input) INTEGER
* The maximum size of the subproblems at the bottom of the
* computation tree.
*
* N (input) INTEGER
* The dimension of the bidiagonal matrix. N >= 0.
*
* NRHS (input) INTEGER
* The number of columns of B. NRHS must be at least 1.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry D contains the main diagonal of the bidiagonal
* matrix. On exit, if INFO = 0, D contains its singular values.
*
* E (input/output) DOUBLE PRECISION array, dimension (N-1)
* Contains the super-diagonal entries of the bidiagonal matrix.
* On exit, E has been destroyed.
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On input, B contains the right hand sides of the least
* squares problem. On output, B contains the solution X.
*
* LDB (input) INTEGER
* The leading dimension of B in the calling subprogram.
* LDB must be at least max(1,N).
*
* RCOND (input) DOUBLE PRECISION
* The singular values of A less than or equal to RCOND times
* the largest singular value are treated as zero in solving
* the least squares problem. If RCOND is negative,
* machine precision is used instead.
* For example, if diag(S)*X=B were the least squares problem,
* where diag(S) is a diagonal matrix of singular values, the
* solution would be X(i) = B(i) / S(i) if S(i) is greater than
* RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to
* RCOND*max(S).
*
* RANK (output) INTEGER
* The number of singular values of A greater than RCOND times
* the largest singular value.
*
* WORK (workspace) DOUBLE PRECISION array, dimension at least
* (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2),
* where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1).
*
* IWORK (workspace) INTEGER array, dimension at least
* (3*N*NLVL + 11*N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: The algorithm failed to compute an singular value while
* working on the submatrix lying in rows and columns
* INFO/(N+1) through MOD(INFO,N+1).
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Ren-Cang Li, Computer Science Division, University of
* California at Berkeley, USA
* Osni Marques, LBNL/NERSC, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
* ..
* .. Local Scalars ..
INTEGER BX, BXST, C, DIFL, DIFR, GIVCOL, GIVNUM,
$ GIVPTR, I, ICMPQ1, ICMPQ2, IWK, J, K, NLVL,
$ NM1, NSIZE, NSUB, NWORK, PERM, POLES, S, SIZEI,
$ SMLSZP, SQRE, ST, ST1, U, VT, Z
DOUBLE PRECISION CS, EPS, ORGNRM, R, RCND, SN, TOL
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH, DLANST
EXTERNAL IDAMAX, DLAMCH, DLANST
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMM, DLACPY, DLALSA, DLARTG, DLASCL,
$ DLASDA, DLASDQ, DLASET, DLASRT, DROT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, INT, LOG, SIGN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.1 ) THEN
INFO = -4
ELSE IF( ( LDB.LT.1 ) .OR. ( LDB.LT.N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLALSD', -INFO )
RETURN
END IF
*
EPS = DLAMCH( 'Epsilon' )
*
* Set up the tolerance.
*
IF( ( RCOND.LE.ZERO ) .OR. ( RCOND.GE.ONE ) ) THEN
RCND = EPS
ELSE
RCND = RCOND
END IF
*
RANK = 0
*
* Quick return if possible.
*
IF( N.EQ.0 ) THEN
RETURN
ELSE IF( N.EQ.1 ) THEN
IF( D( 1 ).EQ.ZERO ) THEN
CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, B, LDB )
ELSE
RANK = 1
CALL DLASCL( 'G', 0, 0, D( 1 ), ONE, 1, NRHS, B, LDB, INFO )
D( 1 ) = ABS( D( 1 ) )
END IF
RETURN
END IF
*
* Rotate the matrix if it is lower bidiagonal.
*
IF( UPLO.EQ.'L' ) THEN
DO 10 I = 1, N - 1
CALL DLARTG( D( I ), E( I ), CS, SN, R )
D( I ) = R
E( I ) = SN*D( I+1 )
D( I+1 ) = CS*D( I+1 )
IF( NRHS.EQ.1 ) THEN
CALL DROT( 1, B( I, 1 ), 1, B( I+1, 1 ), 1, CS, SN )
ELSE
WORK( I*2-1 ) = CS
WORK( I*2 ) = SN
END IF
10 CONTINUE
IF( NRHS.GT.1 ) THEN
DO 30 I = 1, NRHS
DO 20 J = 1, N - 1
CS = WORK( J*2-1 )
SN = WORK( J*2 )
CALL DROT( 1, B( J, I ), 1, B( J+1, I ), 1, CS, SN )
20 CONTINUE
30 CONTINUE
END IF
END IF
*
* Scale.
*
NM1 = N - 1
ORGNRM = DLANST( 'M', N, D, E )
IF( ORGNRM.EQ.ZERO ) THEN
CALL DLASET( 'A', N, NRHS, ZERO, ZERO, B, LDB )
RETURN
END IF
*
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, INFO )
*
* If N is smaller than the minimum divide size SMLSIZ, then solve
* the problem with another solver.
*
IF( N.LE.SMLSIZ ) THEN
NWORK = 1 + N*N
CALL DLASET( 'A', N, N, ZERO, ONE, WORK, N )
CALL DLASDQ( 'U', 0, N, N, 0, NRHS, D, E, WORK, N, WORK, N, B,
$ LDB, WORK( NWORK ), INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
TOL = RCND*ABS( D( IDAMAX( N, D, 1 ) ) )
DO 40 I = 1, N
IF( D( I ).LE.TOL ) THEN
CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
ELSE
CALL DLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS, B( I, 1 ),
$ LDB, INFO )
RANK = RANK + 1
END IF
40 CONTINUE
CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, WORK, N, B, LDB, ZERO,
$ WORK( NWORK ), N )
CALL DLACPY( 'A', N, NRHS, WORK( NWORK ), N, B, LDB )
*
* Unscale.
*
CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
CALL DLASRT( 'D', N, D, INFO )
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO )
*
RETURN
END IF
*
* Book-keeping and setting up some constants.
*
NLVL = INT( LOG( DBLE( N ) / DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1
*
SMLSZP = SMLSIZ + 1
*
U = 1
VT = 1 + SMLSIZ*N
DIFL = VT + SMLSZP*N
DIFR = DIFL + NLVL*N
Z = DIFR + NLVL*N*2
C = Z + NLVL*N
S = C + N
POLES = S + N
GIVNUM = POLES + 2*NLVL*N
BX = GIVNUM + 2*NLVL*N
NWORK = BX + N*NRHS
*
SIZEI = 1 + N
K = SIZEI + N
GIVPTR = K + N
PERM = GIVPTR + N
GIVCOL = PERM + NLVL*N
IWK = GIVCOL + NLVL*N*2
*
ST = 1
SQRE = 0
ICMPQ1 = 1
ICMPQ2 = 0
NSUB = 0
*
DO 50 I = 1, N
IF( ABS( D( I ) ).LT.EPS ) THEN
D( I ) = SIGN( EPS, D( I ) )
END IF
50 CONTINUE
*
DO 60 I = 1, NM1
IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN
NSUB = NSUB + 1
IWORK( NSUB ) = ST
*
* Subproblem found. First determine its size and then
* apply divide and conquer on it.
*
IF( I.LT.NM1 ) THEN
*
* A subproblem with E(I) small for I < NM1.
*
NSIZE = I - ST + 1
IWORK( SIZEI+NSUB-1 ) = NSIZE
ELSE IF( ABS( E( I ) ).GE.EPS ) THEN
*
* A subproblem with E(NM1) not too small but I = NM1.
*
NSIZE = N - ST + 1
IWORK( SIZEI+NSUB-1 ) = NSIZE
ELSE
*
* A subproblem with E(NM1) small. This implies an
* 1-by-1 subproblem at D(N), which is not solved
* explicitly.
*
NSIZE = I - ST + 1
IWORK( SIZEI+NSUB-1 ) = NSIZE
NSUB = NSUB + 1
IWORK( NSUB ) = N
IWORK( SIZEI+NSUB-1 ) = 1
CALL DCOPY( NRHS, B( N, 1 ), LDB, WORK( BX+NM1 ), N )
END IF
ST1 = ST - 1
IF( NSIZE.EQ.1 ) THEN
*
* This is a 1-by-1 subproblem and is not solved
* explicitly.
*
CALL DCOPY( NRHS, B( ST, 1 ), LDB, WORK( BX+ST1 ), N )
ELSE IF( NSIZE.LE.SMLSIZ ) THEN
*
* This is a small subproblem and is solved by DLASDQ.
*
CALL DLASET( 'A', NSIZE, NSIZE, ZERO, ONE,
$ WORK( VT+ST1 ), N )
CALL DLASDQ( 'U', 0, NSIZE, NSIZE, 0, NRHS, D( ST ),
$ E( ST ), WORK( VT+ST1 ), N, WORK( NWORK ),
$ N, B( ST, 1 ), LDB, WORK( NWORK ), INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
CALL DLACPY( 'A', NSIZE, NRHS, B( ST, 1 ), LDB,
$ WORK( BX+ST1 ), N )
ELSE
*
* A large problem. Solve it using divide and conquer.
*
CALL DLASDA( ICMPQ1, SMLSIZ, NSIZE, SQRE, D( ST ),
$ E( ST ), WORK( U+ST1 ), N, WORK( VT+ST1 ),
$ IWORK( K+ST1 ), WORK( DIFL+ST1 ),
$ WORK( DIFR+ST1 ), WORK( Z+ST1 ),
$ WORK( POLES+ST1 ), IWORK( GIVPTR+ST1 ),
$ IWORK( GIVCOL+ST1 ), N, IWORK( PERM+ST1 ),
$ WORK( GIVNUM+ST1 ), WORK( C+ST1 ),
$ WORK( S+ST1 ), WORK( NWORK ), IWORK( IWK ),
$ INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
BXST = BX + ST1
CALL DLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, B( ST, 1 ),
$ LDB, WORK( BXST ), N, WORK( U+ST1 ), N,
$ WORK( VT+ST1 ), IWORK( K+ST1 ),
$ WORK( DIFL+ST1 ), WORK( DIFR+ST1 ),
$ WORK( Z+ST1 ), WORK( POLES+ST1 ),
$ IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N,
$ IWORK( PERM+ST1 ), WORK( GIVNUM+ST1 ),
$ WORK( C+ST1 ), WORK( S+ST1 ), WORK( NWORK ),
$ IWORK( IWK ), INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
END IF
ST = I + 1
END IF
60 CONTINUE
*
* Apply the singular values and treat the tiny ones as zero.
*
TOL = RCND*ABS( D( IDAMAX( N, D, 1 ) ) )
*
DO 70 I = 1, N
*
* Some of the elements in D can be negative because 1-by-1
* subproblems were not solved explicitly.
*
IF( ABS( D( I ) ).LE.TOL ) THEN
CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, WORK( BX+I-1 ), N )
ELSE
RANK = RANK + 1
CALL DLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS,
$ WORK( BX+I-1 ), N, INFO )
END IF
D( I ) = ABS( D( I ) )
70 CONTINUE
*
* Now apply back the right singular vectors.
*
ICMPQ2 = 1
DO 80 I = 1, NSUB
ST = IWORK( I )
ST1 = ST - 1
NSIZE = IWORK( SIZEI+I-1 )
BXST = BX + ST1
IF( NSIZE.EQ.1 ) THEN
CALL DCOPY( NRHS, WORK( BXST ), N, B( ST, 1 ), LDB )
ELSE IF( NSIZE.LE.SMLSIZ ) THEN
CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
$ WORK( VT+ST1 ), N, WORK( BXST ), N, ZERO,
$ B( ST, 1 ), LDB )
ELSE
CALL DLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, WORK( BXST ), N,
$ B( ST, 1 ), LDB, WORK( U+ST1 ), N,
$ WORK( VT+ST1 ), IWORK( K+ST1 ),
$ WORK( DIFL+ST1 ), WORK( DIFR+ST1 ),
$ WORK( Z+ST1 ), WORK( POLES+ST1 ),
$ IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N,
$ IWORK( PERM+ST1 ), WORK( GIVNUM+ST1 ),
$ WORK( C+ST1 ), WORK( S+ST1 ), WORK( NWORK ),
$ IWORK( IWK ), INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
END IF
80 CONTINUE
*
* Unscale and sort the singular values.
*
CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
CALL DLASRT( 'D', N, D, INFO )
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO )
*
RETURN
*
* End of DLALSD
*
END
SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER DTRD1, DTRD2, N1, N2
* ..
* .. Array Arguments ..
INTEGER INDEX( * )
DOUBLE PRECISION A( * )
* ..
*
* Purpose
* =======
*
* DLAMRG will create a permutation list which will merge the elements
* of A (which is composed of two independently sorted sets) into a
* single set which is sorted in ascending order.
*
* Arguments
* =========
*
* N1 (input) INTEGER
* N2 (input) INTEGER
* These arguements contain the respective lengths of the two
* sorted lists to be merged.
*
* A (input) DOUBLE PRECISION array, dimension (N1+N2)
* The first N1 elements of A contain a list of numbers which
* are sorted in either ascending or descending order. Likewise
* for the final N2 elements.
*
* DTRD1 (input) INTEGER
* DTRD2 (input) INTEGER
* These are the strides to be taken through the array A.
* Allowable strides are 1 and -1. They indicate whether a
* subset of A is sorted in ascending (DTRDx = 1) or descending
* (DTRDx = -1) order.
*
* INDEX (output) INTEGER array, dimension (N1+N2)
* On exit this array will contain a permutation such that
* if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be
* sorted in ascending order.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, IND1, IND2, N1SV, N2SV
* ..
* .. Executable Statements ..
*
N1SV = N1
N2SV = N2
IF( DTRD1.GT.0 ) THEN
IND1 = 1
ELSE
IND1 = N1
END IF
IF( DTRD2.GT.0 ) THEN
IND2 = 1 + N1
ELSE
IND2 = N1 + N2
END IF
I = 1
* while ( (N1SV > 0) & (N2SV > 0) )
10 CONTINUE
IF( N1SV.GT.0 .AND. N2SV.GT.0 ) THEN
IF( A( IND1 ).LE.A( IND2 ) ) THEN
INDEX( I ) = IND1
I = I + 1
IND1 = IND1 + DTRD1
N1SV = N1SV - 1
ELSE
INDEX( I ) = IND2
I = I + 1
IND2 = IND2 + DTRD2
N2SV = N2SV - 1
END IF
GO TO 10
END IF
* end while
IF( N1SV.EQ.0 ) THEN
DO 20 N1SV = 1, N2SV
INDEX( I ) = IND2
I = I + 1
IND2 = IND2 + DTRD2
20 CONTINUE
ELSE
* N2SV .EQ. 0
DO 30 N2SV = 1, N1SV
INDEX( I ) = IND1
I = I + 1
IND1 = IND1 + DTRD1
30 CONTINUE
END IF
*
RETURN
*
* End of DLAMRG
*
END
FUNCTION DLANEG( N, D, LLD, SIGMA, PIVMIN, R )
IMPLICIT NONE
INTEGER DLANEG
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER N, R
DOUBLE PRECISION PIVMIN, SIGMA
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), LLD( * )
* ..
*
* Purpose
* =======
*
* DLANEG computes the Sturm count, the number of negative pivots
* encountered while factoring tridiagonal T - sigma I = L D L^T.
* This implementation works directly on the factors without forming
* the tridiagonal matrix T. The Sturm count is also the number of
* eigenvalues of T less than sigma.
*
* This routine is called from DLARRB.
*
* The current routine does not use the PIVMIN parameter but rather
* requires IEEE-754 propagation of Infinities and NaNs. This
* routine also has no input range restrictions but does require
* default exception handling such that x/0 produces Inf when x is
* non-zero, and Inf/Inf produces NaN. For more information, see:
*
* Marques, Riedy, and Voemel, "Benefits of IEEE-754 Features in
* Modern Symmetric Tridiagonal Eigensolvers," SIAM Journal on
* Scientific Computing, v28, n5, 2006. DOI 10.1137/050641624
* (Tech report version in LAWN 172 with the same title.)
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The N diagonal elements of the diagonal matrix D.
*
* LLD (input) DOUBLE PRECISION array, dimension (N-1)
* The (N-1) elements L(i)*L(i)*D(i).
*
* SIGMA (input) DOUBLE PRECISION
* Shift amount in T - sigma I = L D L^T.
*
* PIVMIN (input) DOUBLE PRECISION
* The minimum pivot in the Sturm sequence. May be used
* when zero pivots are encountered on non-IEEE-754
* architectures.
*
* R (input) INTEGER
* The twist index for the twisted factorization that is used
* for the negcount.
*
* Further Details
* ===============
*
* Based on contributions by
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
* Jason Riedy, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* Some architectures propagate Infinities and NaNs very slowly, so
* the code computes counts in BLKLEN chunks. Then a NaN can
* propagate at most BLKLEN columns before being detected. This is
* not a general tuning parameter; it needs only to be just large
* enough that the overhead is tiny in common cases.
INTEGER BLKLEN
PARAMETER ( BLKLEN = 128 )
* ..
* .. Local Scalars ..
INTEGER BJ, J, NEG1, NEG2, NEGCNT
DOUBLE PRECISION BSAV, DMINUS, DPLUS, GAMMA, P, T, TMP
LOGICAL SAWNAN
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN, MAX
* ..
* .. External Functions ..
LOGICAL DISNAN
EXTERNAL DISNAN
* ..
* .. Executable Statements ..
NEGCNT = 0
* I) upper part: L D L^T - SIGMA I = L+ D+ L+^T
T = -SIGMA
DO 210 BJ = 1, R-1, BLKLEN
NEG1 = 0
BSAV = T
DO 21 J = BJ, MIN(BJ+BLKLEN-1, R-1)
DPLUS = D( J ) + T
IF( DPLUS.LT.ZERO ) NEG1 = NEG1 + 1
TMP = T / DPLUS
T = TMP * LLD( J ) - SIGMA
21 CONTINUE
SAWNAN = DISNAN( T )
* Run a slower version of the above loop if a NaN is detected.
* A NaN should occur only with a zero pivot after an infinite
* pivot. In that case, substituting 1 for T/DPLUS is the
* correct limit.
IF( SAWNAN ) THEN
NEG1 = 0
T = BSAV
DO 22 J = BJ, MIN(BJ+BLKLEN-1, R-1)
DPLUS = D( J ) + T
IF( DPLUS.LT.ZERO ) NEG1 = NEG1 + 1
TMP = T / DPLUS
IF (DISNAN(TMP)) TMP = ONE
T = TMP * LLD(J) - SIGMA
22 CONTINUE
END IF
NEGCNT = NEGCNT + NEG1
210 CONTINUE
*
* II) lower part: L D L^T - SIGMA I = U- D- U-^T
P = D( N ) - SIGMA
DO 230 BJ = N-1, R, -BLKLEN
NEG2 = 0
BSAV = P
DO 23 J = BJ, MAX(BJ-BLKLEN+1, R), -1
DMINUS = LLD( J ) + P
IF( DMINUS.LT.ZERO ) NEG2 = NEG2 + 1
TMP = P / DMINUS
P = TMP * D( J ) - SIGMA
23 CONTINUE
SAWNAN = DISNAN( P )
* As above, run a slower version that substitutes 1 for Inf/Inf.
*
IF( SAWNAN ) THEN
NEG2 = 0
P = BSAV
DO 24 J = BJ, MAX(BJ-BLKLEN+1, R), -1
DMINUS = LLD( J ) + P
IF( DMINUS.LT.ZERO ) NEG2 = NEG2 + 1
TMP = P / DMINUS
IF (DISNAN(TMP)) TMP = ONE
P = TMP * D(J) - SIGMA
24 CONTINUE
END IF
NEGCNT = NEGCNT + NEG2
230 CONTINUE
*
* III) Twist index
* T was shifted by SIGMA initially.
GAMMA = (T + SIGMA) + P
IF( GAMMA.LT.ZERO ) NEGCNT = NEGCNT+1
DLANEG = NEGCNT
END
DOUBLE PRECISION FUNCTION DLANGB( NORM, N, KL, KU, AB, LDAB,
$ WORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER KL, KU, LDAB, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AB( LDAB, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLANGB returns the value of the one norm, or the Frobenius norm, or
* the infinity norm, or the element of largest absolute value of an
* n by n band matrix A, with kl sub-diagonals and ku super-diagonals.
*
* Description
* ===========
*
* DLANGB returns the value
*
* DLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm'
* (
* ( norm1(A), NORM = '1', 'O' or 'o'
* (
* ( normI(A), NORM = 'I' or 'i'
* (
* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*
* where norm1 denotes the one norm of a matrix (maximum column sum),
* normI denotes the infinity norm of a matrix (maximum row sum) and
* normF denotes the Frobenius norm of a matrix (square root of sum of
* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies the value to be returned in DLANGB as described
* above.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0. When N = 0, DLANGB is
* set to zero.
*
* KL (input) INTEGER
* The number of sub-diagonals of the matrix A. KL >= 0.
*
* KU (input) INTEGER
* The number of super-diagonals of the matrix A. KU >= 0.
*
* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
* The band matrix A, stored in rows 1 to KL+KU+1. The j-th
* column of A is stored in the j-th column of the array AB as
* follows:
* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KL+KU+1.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
* where LWORK >= N when NORM = 'I'; otherwise, WORK is not
* referenced.
*
* =====================================================================
*
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, K, L
DOUBLE PRECISION SCALE, SUM, VALUE
* ..
* .. External Subroutines ..
EXTERNAL DLASSQ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
VALUE = ZERO
DO 20 J = 1, N
DO 10 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
10 CONTINUE
20 CONTINUE
ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
*
* Find norm1(A).
*
VALUE = ZERO
DO 40 J = 1, N
SUM = ZERO
DO 30 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
SUM = SUM + ABS( AB( I, J ) )
30 CONTINUE
VALUE = MAX( VALUE, SUM )
40 CONTINUE
ELSE IF( LSAME( NORM, 'I' ) ) THEN
*
* Find normI(A).
*
DO 50 I = 1, N
WORK( I ) = ZERO
50 CONTINUE
DO 70 J = 1, N
K = KU + 1 - J
DO 60 I = MAX( 1, J-KU ), MIN( N, J+KL )
WORK( I ) = WORK( I ) + ABS( AB( K+I, J ) )
60 CONTINUE
70 CONTINUE
VALUE = ZERO
DO 80 I = 1, N
VALUE = MAX( VALUE, WORK( I ) )
80 CONTINUE
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
DO 90 J = 1, N
L = MAX( 1, J-KU )
K = KU + 1 - J + L
CALL DLASSQ( MIN( N, J+KL )-L+1, AB( K, J ), 1, SCALE, SUM )
90 CONTINUE
VALUE = SCALE*SQRT( SUM )
END IF
*
DLANGB = VALUE
RETURN
*
* End of DLANGB
*
END
DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLANGE returns the value of the one norm, or the Frobenius norm, or
* the infinity norm, or the element of largest absolute value of a
* real matrix A.
*
* Description
* ===========
*
* DLANGE returns the value
*
* DLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'
* (
* ( norm1(A), NORM = '1', 'O' or 'o'
* (
* ( normI(A), NORM = 'I' or 'i'
* (
* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*
* where norm1 denotes the one norm of a matrix (maximum column sum),
* normI denotes the infinity norm of a matrix (maximum row sum) and
* normF denotes the Frobenius norm of a matrix (square root of sum of
* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies the value to be returned in DLANGE as described
* above.
*
* M (input) INTEGER
* The number of rows of the matrix A. M >= 0. When M = 0,
* DLANGE is set to zero.
*
* N (input) INTEGER
* The number of columns of the matrix A. N >= 0. When N = 0,
* DLANGE is set to zero.
*
* 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(M,1).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
* where LWORK >= M when NORM = 'I'; otherwise, WORK is not
* referenced.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION SCALE, SUM, VALUE
* ..
* .. External Subroutines ..
EXTERNAL DLASSQ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
IF( MIN( M, N ).EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
VALUE = ZERO
DO 20 J = 1, N
DO 10 I = 1, M
VALUE = MAX( VALUE, ABS( A( I, J ) ) )
10 CONTINUE
20 CONTINUE
ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
*
* Find norm1(A).
*
VALUE = ZERO
DO 40 J = 1, N
SUM = ZERO
DO 30 I = 1, M
SUM = SUM + ABS( A( I, J ) )
30 CONTINUE
VALUE = MAX( VALUE, SUM )
40 CONTINUE
ELSE IF( LSAME( NORM, 'I' ) ) THEN
*
* Find normI(A).
*
DO 50 I = 1, M
WORK( I ) = ZERO
50 CONTINUE
DO 70 J = 1, N
DO 60 I = 1, M
WORK( I ) = WORK( I ) + ABS( A( I, J ) )
60 CONTINUE
70 CONTINUE
VALUE = ZERO
DO 80 I = 1, M
VALUE = MAX( VALUE, WORK( I ) )
80 CONTINUE
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
DO 90 J = 1, N
CALL DLASSQ( M, A( 1, J ), 1, SCALE, SUM )
90 CONTINUE
VALUE = SCALE*SQRT( SUM )
END IF
*
DLANGE = VALUE
RETURN
*
* End of DLANGE
*
END
DOUBLE PRECISION FUNCTION DLANGT( NORM, N, DL, D, DU )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), DL( * ), DU( * )
* ..
*
* Purpose
* =======
*
* DLANGT returns the value of the one norm, or the Frobenius norm, or
* the infinity norm, or the element of largest absolute value of a
* real tridiagonal matrix A.
*
* Description
* ===========
*
* DLANGT returns the value
*
* DLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm'
* (
* ( norm1(A), NORM = '1', 'O' or 'o'
* (
* ( normI(A), NORM = 'I' or 'i'
* (
* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*
* where norm1 denotes the one norm of a matrix (maximum column sum),
* normI denotes the infinity norm of a matrix (maximum row sum) and
* normF denotes the Frobenius norm of a matrix (square root of sum of
* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies the value to be returned in DLANGT as described
* above.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0. When N = 0, DLANGT is
* set to zero.
*
* DL (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) sub-diagonal elements of A.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The diagonal elements of A.
*
* DU (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) super-diagonal elements of A.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I
DOUBLE PRECISION ANORM, SCALE, SUM
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DLASSQ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
IF( N.LE.0 ) THEN
ANORM = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
ANORM = ABS( D( N ) )
DO 10 I = 1, N - 1
ANORM = MAX( ANORM, ABS( DL( I ) ) )
ANORM = MAX( ANORM, ABS( D( I ) ) )
ANORM = MAX( ANORM, ABS( DU( I ) ) )
10 CONTINUE
ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' ) THEN
*
* Find norm1(A).
*
IF( N.EQ.1 ) THEN
ANORM = ABS( D( 1 ) )
ELSE
ANORM = MAX( ABS( D( 1 ) )+ABS( DL( 1 ) ),
$ ABS( D( N ) )+ABS( DU( N-1 ) ) )
DO 20 I = 2, N - 1
ANORM = MAX( ANORM, ABS( D( I ) )+ABS( DL( I ) )+
$ ABS( DU( I-1 ) ) )
20 CONTINUE
END IF
ELSE IF( LSAME( NORM, 'I' ) ) THEN
*
* Find normI(A).
*
IF( N.EQ.1 ) THEN
ANORM = ABS( D( 1 ) )
ELSE
ANORM = MAX( ABS( D( 1 ) )+ABS( DU( 1 ) ),
$ ABS( D( N ) )+ABS( DL( N-1 ) ) )
DO 30 I = 2, N - 1
ANORM = MAX( ANORM, ABS( D( I ) )+ABS( DU( I ) )+
$ ABS( DL( I-1 ) ) )
30 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
CALL DLASSQ( N, D, 1, SCALE, SUM )
IF( N.GT.1 ) THEN
CALL DLASSQ( N-1, DL, 1, SCALE, SUM )
CALL DLASSQ( N-1, DU, 1, SCALE, SUM )
END IF
ANORM = SCALE*SQRT( SUM )
END IF
*
DLANGT = ANORM
RETURN
*
* End of DLANGT
*
END
DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLANHS returns the value of the one norm, or the Frobenius norm, or
* the infinity norm, or the element of largest absolute value of a
* Hessenberg matrix A.
*
* Description
* ===========
*
* DLANHS returns the value
*
* DLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm'
* (
* ( norm1(A), NORM = '1', 'O' or 'o'
* (
* ( normI(A), NORM = 'I' or 'i'
* (
* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*
* where norm1 denotes the one norm of a matrix (maximum column sum),
* normI denotes the infinity norm of a matrix (maximum row sum) and
* normF denotes the Frobenius norm of a matrix (square root of sum of
* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies the value to be returned in DLANHS as described
* above.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0. When N = 0, DLANHS is
* set to zero.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The n by n upper Hessenberg matrix A; the part of A below the
* first sub-diagonal is not referenced.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(N,1).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
* where LWORK >= N when NORM = 'I'; otherwise, WORK is not
* referenced.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION SCALE, SUM, VALUE
* ..
* .. External Subroutines ..
EXTERNAL DLASSQ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
VALUE = ZERO
DO 20 J = 1, N
DO 10 I = 1, MIN( N, J+1 )
VALUE = MAX( VALUE, ABS( A( I, J ) ) )
10 CONTINUE
20 CONTINUE
ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
*
* Find norm1(A).
*
VALUE = ZERO
DO 40 J = 1, N
SUM = ZERO
DO 30 I = 1, MIN( N, J+1 )
SUM = SUM + ABS( A( I, J ) )
30 CONTINUE
VALUE = MAX( VALUE, SUM )
40 CONTINUE
ELSE IF( LSAME( NORM, 'I' ) ) THEN
*
* Find normI(A).
*
DO 50 I = 1, N
WORK( I ) = ZERO
50 CONTINUE
DO 70 J = 1, N
DO 60 I = 1, MIN( N, J+1 )
WORK( I ) = WORK( I ) + ABS( A( I, J ) )
60 CONTINUE
70 CONTINUE
VALUE = ZERO
DO 80 I = 1, N
VALUE = MAX( VALUE, WORK( I ) )
80 CONTINUE
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
DO 90 J = 1, N
CALL DLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM )
90 CONTINUE
VALUE = SCALE*SQRT( SUM )
END IF
*
DLANHS = VALUE
RETURN
*
* End of DLANHS
*
END
DOUBLE PRECISION FUNCTION DLANSB( NORM, UPLO, N, K, AB, LDAB,
$ WORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER NORM, UPLO
INTEGER K, LDAB, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AB( LDAB, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLANSB returns the value of the one norm, or the Frobenius norm, or
* the infinity norm, or the element of largest absolute value of an
* n by n symmetric band matrix A, with k super-diagonals.
*
* Description
* ===========
*
* DLANSB returns the value
*
* DLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm'
* (
* ( norm1(A), NORM = '1', 'O' or 'o'
* (
* ( normI(A), NORM = 'I' or 'i'
* (
* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*
* where norm1 denotes the one norm of a matrix (maximum column sum),
* normI denotes the infinity norm of a matrix (maximum row sum) and
* normF denotes the Frobenius norm of a matrix (square root of sum of
* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies the value to be returned in DLANSB as described
* above.
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* band matrix A is supplied.
* = 'U': Upper triangular part is supplied
* = 'L': Lower triangular part is supplied
*
* N (input) INTEGER
* The order of the matrix A. N >= 0. When N = 0, DLANSB is
* set to zero.
*
* K (input) INTEGER
* The number of super-diagonals or sub-diagonals of the
* band matrix A. K >= 0.
*
* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
* The upper or lower triangle of the symmetric band matrix A,
* stored in the first K+1 rows of AB. The j-th column of A is
* stored in the j-th column of the array AB as follows:
* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= K+1.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
* WORK is not referenced.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, L
DOUBLE PRECISION ABSA, SCALE, SUM, VALUE
* ..
* .. External Subroutines ..
EXTERNAL DLASSQ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = MAX( K+2-J, 1 ), K + 1
VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1, N
DO 30 I = 1, MIN( N+1-J, K+1 )
VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
30 CONTINUE
40 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
$ ( NORM.EQ.'1' ) ) THEN
*
* Find normI(A) ( = norm1(A), since A is symmetric).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 60 J = 1, N
SUM = ZERO
L = K + 1 - J
DO 50 I = MAX( 1, J-K ), J - 1
ABSA = ABS( AB( L+I, J ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
50 CONTINUE
WORK( J ) = SUM + ABS( AB( K+1, J ) )
60 CONTINUE
DO 70 I = 1, N
VALUE = MAX( VALUE, WORK( I ) )
70 CONTINUE
ELSE
DO 80 I = 1, N
WORK( I ) = ZERO
80 CONTINUE
DO 100 J = 1, N
SUM = WORK( J ) + ABS( AB( 1, J ) )
L = 1 - J
DO 90 I = J + 1, MIN( N, J+K )
ABSA = ABS( AB( L+I, J ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
90 CONTINUE
VALUE = MAX( VALUE, SUM )
100 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
IF( K.GT.0 ) THEN
IF( LSAME( UPLO, 'U' ) ) THEN
DO 110 J = 2, N
CALL DLASSQ( MIN( J-1, K ), AB( MAX( K+2-J, 1 ), J ),
$ 1, SCALE, SUM )
110 CONTINUE
L = K + 1
ELSE
DO 120 J = 1, N - 1
CALL DLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE,
$ SUM )
120 CONTINUE
L = 1
END IF
SUM = 2*SUM
ELSE
L = 1
END IF
CALL DLASSQ( N, AB( L, 1 ), LDAB, SCALE, SUM )
VALUE = SCALE*SQRT( SUM )
END IF
*
DLANSB = VALUE
RETURN
*
* End of DLANSB
*
END
DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER NORM, UPLO
INTEGER N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLANSP returns the value of the one norm, or the Frobenius norm, or
* the infinity norm, or the element of largest absolute value of a
* real symmetric matrix A, supplied in packed form.
*
* Description
* ===========
*
* DLANSP returns the value
*
* DLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm'
* (
* ( norm1(A), NORM = '1', 'O' or 'o'
* (
* ( normI(A), NORM = 'I' or 'i'
* (
* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*
* where norm1 denotes the one norm of a matrix (maximum column sum),
* normI denotes the infinity norm of a matrix (maximum row sum) and
* normF denotes the Frobenius norm of a matrix (square root of sum of
* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies the value to be returned in DLANSP as described
* above.
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is supplied.
* = 'U': Upper triangular part of A is supplied
* = 'L': Lower triangular part of A is supplied
*
* N (input) INTEGER
* The order of the matrix A. N >= 0. When N = 0, DLANSP is
* set to zero.
*
* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The upper or lower triangle of the symmetric matrix A, packed
* columnwise in a linear array. The j-th column of A is stored
* in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
* WORK is not referenced.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, K
DOUBLE PRECISION ABSA, SCALE, SUM, VALUE
* ..
* .. External Subroutines ..
EXTERNAL DLASSQ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
K = 1
DO 20 J = 1, N
DO 10 I = K, K + J - 1
VALUE = MAX( VALUE, ABS( AP( I ) ) )
10 CONTINUE
K = K + J
20 CONTINUE
ELSE
K = 1
DO 40 J = 1, N
DO 30 I = K, K + N - J
VALUE = MAX( VALUE, ABS( AP( I ) ) )
30 CONTINUE
K = K + N - J + 1
40 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
$ ( NORM.EQ.'1' ) ) THEN
*
* Find normI(A) ( = norm1(A), since A is symmetric).
*
VALUE = ZERO
K = 1
IF( LSAME( UPLO, 'U' ) ) THEN
DO 60 J = 1, N
SUM = ZERO
DO 50 I = 1, J - 1
ABSA = ABS( AP( K ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
K = K + 1
50 CONTINUE
WORK( J ) = SUM + ABS( AP( K ) )
K = K + 1
60 CONTINUE
DO 70 I = 1, N
VALUE = MAX( VALUE, WORK( I ) )
70 CONTINUE
ELSE
DO 80 I = 1, N
WORK( I ) = ZERO
80 CONTINUE
DO 100 J = 1, N
SUM = WORK( J ) + ABS( AP( K ) )
K = K + 1
DO 90 I = J + 1, N
ABSA = ABS( AP( K ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
K = K + 1
90 CONTINUE
VALUE = MAX( VALUE, SUM )
100 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
K = 2
IF( LSAME( UPLO, 'U' ) ) THEN
DO 110 J = 2, N
CALL DLASSQ( J-1, AP( K ), 1, SCALE, SUM )
K = K + J
110 CONTINUE
ELSE
DO 120 J = 1, N - 1
CALL DLASSQ( N-J, AP( K ), 1, SCALE, SUM )
K = K + N - J + 1
120 CONTINUE
END IF
SUM = 2*SUM
K = 1
DO 130 I = 1, N
IF( AP( K ).NE.ZERO ) THEN
ABSA = ABS( AP( K ) )
IF( SCALE.LT.ABSA ) THEN
SUM = ONE + SUM*( SCALE / ABSA )**2
SCALE = ABSA
ELSE
SUM = SUM + ( ABSA / SCALE )**2
END IF
END IF
IF( LSAME( UPLO, 'U' ) ) THEN
K = K + I + 1
ELSE
K = K + N - I + 1
END IF
130 CONTINUE
VALUE = SCALE*SQRT( SUM )
END IF
*
DLANSP = VALUE
RETURN
*
* End of DLANSP
*
END
DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * )
* ..
*
* Purpose
* =======
*
* DLANST returns the value of the one norm, or the Frobenius norm, or
* the infinity norm, or the element of largest absolute value of a
* real symmetric tridiagonal matrix A.
*
* Description
* ===========
*
* DLANST returns the value
*
* DLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm'
* (
* ( norm1(A), NORM = '1', 'O' or 'o'
* (
* ( normI(A), NORM = 'I' or 'i'
* (
* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*
* where norm1 denotes the one norm of a matrix (maximum column sum),
* normI denotes the infinity norm of a matrix (maximum row sum) and
* normF denotes the Frobenius norm of a matrix (square root of sum of
* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies the value to be returned in DLANST as described
* above.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0. When N = 0, DLANST is
* set to zero.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The diagonal elements of A.
*
* E (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) sub-diagonal or super-diagonal elements of A.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I
DOUBLE PRECISION ANORM, SCALE, SUM
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DLASSQ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
IF( N.LE.0 ) THEN
ANORM = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
ANORM = ABS( D( N ) )
DO 10 I = 1, N - 1
ANORM = MAX( ANORM, ABS( D( I ) ) )
ANORM = MAX( ANORM, ABS( E( I ) ) )
10 CONTINUE
ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR.
$ LSAME( NORM, 'I' ) ) THEN
*
* Find norm1(A).
*
IF( N.EQ.1 ) THEN
ANORM = ABS( D( 1 ) )
ELSE
ANORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ),
$ ABS( E( N-1 ) )+ABS( D( N ) ) )
DO 20 I = 2, N - 1
ANORM = MAX( ANORM, ABS( D( I ) )+ABS( E( I ) )+
$ ABS( E( I-1 ) ) )
20 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
IF( N.GT.1 ) THEN
CALL DLASSQ( N-1, E, 1, SCALE, SUM )
SUM = 2*SUM
END IF
CALL DLASSQ( N, D, 1, SCALE, SUM )
ANORM = SCALE*SQRT( SUM )
END IF
*
DLANST = ANORM
RETURN
*
* End of DLANST
*
END
DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER NORM, UPLO
INTEGER LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLANSY returns the value of the one norm, or the Frobenius norm, or
* the infinity norm, or the element of largest absolute value of a
* real symmetric matrix A.
*
* Description
* ===========
*
* DLANSY returns the value
*
* DLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm'
* (
* ( norm1(A), NORM = '1', 'O' or 'o'
* (
* ( normI(A), NORM = 'I' or 'i'
* (
* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*
* where norm1 denotes the one norm of a matrix (maximum column sum),
* normI denotes the infinity norm of a matrix (maximum row sum) and
* normF denotes the Frobenius norm of a matrix (square root of sum of
* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies the value to be returned in DLANSY as described
* above.
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is to be referenced.
* = 'U': Upper triangular part of A is referenced
* = 'L': Lower triangular part of A is referenced
*
* N (input) INTEGER
* The order of the matrix A. N >= 0. When N = 0, DLANSY is
* set to zero.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The symmetric matrix A. If UPLO = 'U', the leading n by n
* upper triangular part of A contains the upper triangular part
* of the matrix A, and the strictly lower triangular part of A
* is not referenced. If UPLO = 'L', the leading n by n lower
* triangular part of A contains the lower triangular part of
* the matrix A, and the strictly upper triangular part of A is
* not referenced.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(N,1).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
* WORK is not referenced.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION ABSA, SCALE, SUM, VALUE
* ..
* .. External Subroutines ..
EXTERNAL DLASSQ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = 1, J
VALUE = MAX( VALUE, ABS( A( I, J ) ) )
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1, N
DO 30 I = J, N
VALUE = MAX( VALUE, ABS( A( I, J ) ) )
30 CONTINUE
40 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
$ ( NORM.EQ.'1' ) ) THEN
*
* Find normI(A) ( = norm1(A), since A is symmetric).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 60 J = 1, N
SUM = ZERO
DO 50 I = 1, J - 1
ABSA = ABS( A( I, J ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
50 CONTINUE
WORK( J ) = SUM + ABS( A( J, J ) )
60 CONTINUE
DO 70 I = 1, N
VALUE = MAX( VALUE, WORK( I ) )
70 CONTINUE
ELSE
DO 80 I = 1, N
WORK( I ) = ZERO
80 CONTINUE
DO 100 J = 1, N
SUM = WORK( J ) + ABS( A( J, J ) )
DO 90 I = J + 1, N
ABSA = ABS( A( I, J ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
90 CONTINUE
VALUE = MAX( VALUE, SUM )
100 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
IF( LSAME( UPLO, 'U' ) ) THEN
DO 110 J = 2, N
CALL DLASSQ( J-1, A( 1, J ), 1, SCALE, SUM )
110 CONTINUE
ELSE
DO 120 J = 1, N - 1
CALL DLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM )
120 CONTINUE
END IF
SUM = 2*SUM
CALL DLASSQ( N, A, LDA+1, SCALE, SUM )
VALUE = SCALE*SQRT( SUM )
END IF
*
DLANSY = VALUE
RETURN
*
* End of DLANSY
*
END
DOUBLE PRECISION FUNCTION DLANTB( NORM, UPLO, DIAG, N, K, AB,
$ LDAB, WORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, NORM, UPLO
INTEGER K, LDAB, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AB( LDAB, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLANTB returns the value of the one norm, or the Frobenius norm, or
* the infinity norm, or the element of largest absolute value of an
* n by n triangular band matrix A, with ( k + 1 ) diagonals.
*
* Description
* ===========
*
* DLANTB returns the value
*
* DLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm'
* (
* ( norm1(A), NORM = '1', 'O' or 'o'
* (
* ( normI(A), NORM = 'I' or 'i'
* (
* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*
* where norm1 denotes the one norm of a matrix (maximum column sum),
* normI denotes the infinity norm of a matrix (maximum row sum) and
* normF denotes the Frobenius norm of a matrix (square root of sum of
* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies the value to be returned in DLANTB as described
* above.
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0. When N = 0, DLANTB is
* set to zero.
*
* K (input) INTEGER
* The number of super-diagonals of the matrix A if UPLO = 'U',
* or the number of sub-diagonals of the matrix A if UPLO = 'L'.
* K >= 0.
*
* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
* The upper or lower triangular band matrix A, stored in the
* first k+1 rows of AB. The j-th column of A is stored
* in the j-th column of the array AB as follows:
* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).
* Note that when DIAG = 'U', the elements of the array AB
* corresponding to the diagonal elements of the matrix A are
* not referenced, but are assumed to be one.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= K+1.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
* where LWORK >= N when NORM = 'I'; otherwise, WORK is not
* referenced.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UDIAG
INTEGER I, J, L
DOUBLE PRECISION SCALE, SUM, VALUE
* ..
* .. External Subroutines ..
EXTERNAL DLASSQ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
IF( LSAME( DIAG, 'U' ) ) THEN
VALUE = ONE
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = MAX( K+2-J, 1 ), K
VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1, N
DO 30 I = 2, MIN( N+1-J, K+1 )
VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
30 CONTINUE
40 CONTINUE
END IF
ELSE
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 60 J = 1, N
DO 50 I = MAX( K+2-J, 1 ), K + 1
VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
50 CONTINUE
60 CONTINUE
ELSE
DO 80 J = 1, N
DO 70 I = 1, MIN( N+1-J, K+1 )
VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
70 CONTINUE
80 CONTINUE
END IF
END IF
ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
*
* Find norm1(A).
*
VALUE = ZERO
UDIAG = LSAME( DIAG, 'U' )
IF( LSAME( UPLO, 'U' ) ) THEN
DO 110 J = 1, N
IF( UDIAG ) THEN
SUM = ONE
DO 90 I = MAX( K+2-J, 1 ), K
SUM = SUM + ABS( AB( I, J ) )
90 CONTINUE
ELSE
SUM = ZERO
DO 100 I = MAX( K+2-J, 1 ), K + 1
SUM = SUM + ABS( AB( I, J ) )
100 CONTINUE
END IF
VALUE = MAX( VALUE, SUM )
110 CONTINUE
ELSE
DO 140 J = 1, N
IF( UDIAG ) THEN
SUM = ONE
DO 120 I = 2, MIN( N+1-J, K+1 )
SUM = SUM + ABS( AB( I, J ) )
120 CONTINUE
ELSE
SUM = ZERO
DO 130 I = 1, MIN( N+1-J, K+1 )
SUM = SUM + ABS( AB( I, J ) )
130 CONTINUE
END IF
VALUE = MAX( VALUE, SUM )
140 CONTINUE
END IF
ELSE IF( LSAME( NORM, 'I' ) ) THEN
*
* Find normI(A).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
IF( LSAME( DIAG, 'U' ) ) THEN
DO 150 I = 1, N
WORK( I ) = ONE
150 CONTINUE
DO 170 J = 1, N
L = K + 1 - J
DO 160 I = MAX( 1, J-K ), J - 1
WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
160 CONTINUE
170 CONTINUE
ELSE
DO 180 I = 1, N
WORK( I ) = ZERO
180 CONTINUE
DO 200 J = 1, N
L = K + 1 - J
DO 190 I = MAX( 1, J-K ), J
WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
190 CONTINUE
200 CONTINUE
END IF
ELSE
IF( LSAME( DIAG, 'U' ) ) THEN
DO 210 I = 1, N
WORK( I ) = ONE
210 CONTINUE
DO 230 J = 1, N
L = 1 - J
DO 220 I = J + 1, MIN( N, J+K )
WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
220 CONTINUE
230 CONTINUE
ELSE
DO 240 I = 1, N
WORK( I ) = ZERO
240 CONTINUE
DO 260 J = 1, N
L = 1 - J
DO 250 I = J, MIN( N, J+K )
WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
250 CONTINUE
260 CONTINUE
END IF
END IF
DO 270 I = 1, N
VALUE = MAX( VALUE, WORK( I ) )
270 CONTINUE
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
IF( LSAME( UPLO, 'U' ) ) THEN
IF( LSAME( DIAG, 'U' ) ) THEN
SCALE = ONE
SUM = N
IF( K.GT.0 ) THEN
DO 280 J = 2, N
CALL DLASSQ( MIN( J-1, K ),
$ AB( MAX( K+2-J, 1 ), J ), 1, SCALE,
$ SUM )
280 CONTINUE
END IF
ELSE
SCALE = ZERO
SUM = ONE
DO 290 J = 1, N
CALL DLASSQ( MIN( J, K+1 ), AB( MAX( K+2-J, 1 ), J ),
$ 1, SCALE, SUM )
290 CONTINUE
END IF
ELSE
IF( LSAME( DIAG, 'U' ) ) THEN
SCALE = ONE
SUM = N
IF( K.GT.0 ) THEN
DO 300 J = 1, N - 1
CALL DLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE,
$ SUM )
300 CONTINUE
END IF
ELSE
SCALE = ZERO
SUM = ONE
DO 310 J = 1, N
CALL DLASSQ( MIN( N-J+1, K+1 ), AB( 1, J ), 1, SCALE,
$ SUM )
310 CONTINUE
END IF
END IF
VALUE = SCALE*SQRT( SUM )
END IF
*
DLANTB = VALUE
RETURN
*
* End of DLANTB
*
END
DOUBLE PRECISION FUNCTION DLANTP( NORM, UPLO, DIAG, N, AP, WORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, NORM, UPLO
INTEGER N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLANTP returns the value of the one norm, or the Frobenius norm, or
* the infinity norm, or the element of largest absolute value of a
* triangular matrix A, supplied in packed form.
*
* Description
* ===========
*
* DLANTP returns the value
*
* DLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm'
* (
* ( norm1(A), NORM = '1', 'O' or 'o'
* (
* ( normI(A), NORM = 'I' or 'i'
* (
* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*
* where norm1 denotes the one norm of a matrix (maximum column sum),
* normI denotes the infinity norm of a matrix (maximum row sum) and
* normF denotes the Frobenius norm of a matrix (square root of sum of
* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies the value to be returned in DLANTP as described
* above.
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0. When N = 0, DLANTP is
* set to zero.
*
* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The upper or lower triangular matrix A, packed columnwise in
* a linear array. The j-th column of A is stored in the array
* AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
* Note that when DIAG = 'U', the elements of the array AP
* corresponding to the diagonal elements of the matrix A are
* not referenced, but are assumed to be one.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
* where LWORK >= N when NORM = 'I'; otherwise, WORK is not
* referenced.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UDIAG
INTEGER I, J, K
DOUBLE PRECISION SCALE, SUM, VALUE
* ..
* .. External Subroutines ..
EXTERNAL DLASSQ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
K = 1
IF( LSAME( DIAG, 'U' ) ) THEN
VALUE = ONE
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = K, K + J - 2
VALUE = MAX( VALUE, ABS( AP( I ) ) )
10 CONTINUE
K = K + J
20 CONTINUE
ELSE
DO 40 J = 1, N
DO 30 I = K + 1, K + N - J
VALUE = MAX( VALUE, ABS( AP( I ) ) )
30 CONTINUE
K = K + N - J + 1
40 CONTINUE
END IF
ELSE
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 60 J = 1, N
DO 50 I = K, K + J - 1
VALUE = MAX( VALUE, ABS( AP( I ) ) )
50 CONTINUE
K = K + J
60 CONTINUE
ELSE
DO 80 J = 1, N
DO 70 I = K, K + N - J
VALUE = MAX( VALUE, ABS( AP( I ) ) )
70 CONTINUE
K = K + N - J + 1
80 CONTINUE
END IF
END IF
ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
*
* Find norm1(A).
*
VALUE = ZERO
K = 1
UDIAG = LSAME( DIAG, 'U' )
IF( LSAME( UPLO, 'U' ) ) THEN
DO 110 J = 1, N
IF( UDIAG ) THEN
SUM = ONE
DO 90 I = K, K + J - 2
SUM = SUM + ABS( AP( I ) )
90 CONTINUE
ELSE
SUM = ZERO
DO 100 I = K, K + J - 1
SUM = SUM + ABS( AP( I ) )
100 CONTINUE
END IF
K = K + J
VALUE = MAX( VALUE, SUM )
110 CONTINUE
ELSE
DO 140 J = 1, N
IF( UDIAG ) THEN
SUM = ONE
DO 120 I = K + 1, K + N - J
SUM = SUM + ABS( AP( I ) )
120 CONTINUE
ELSE
SUM = ZERO
DO 130 I = K, K + N - J
SUM = SUM + ABS( AP( I ) )
130 CONTINUE
END IF
K = K + N - J + 1
VALUE = MAX( VALUE, SUM )
140 CONTINUE
END IF
ELSE IF( LSAME( NORM, 'I' ) ) THEN
*
* Find normI(A).
*
K = 1
IF( LSAME( UPLO, 'U' ) ) THEN
IF( LSAME( DIAG, 'U' ) ) THEN
DO 150 I = 1, N
WORK( I ) = ONE
150 CONTINUE
DO 170 J = 1, N
DO 160 I = 1, J - 1
WORK( I ) = WORK( I ) + ABS( AP( K ) )
K = K + 1
160 CONTINUE
K = K + 1
170 CONTINUE
ELSE
DO 180 I = 1, N
WORK( I ) = ZERO
180 CONTINUE
DO 200 J = 1, N
DO 190 I = 1, J
WORK( I ) = WORK( I ) + ABS( AP( K ) )
K = K + 1
190 CONTINUE
200 CONTINUE
END IF
ELSE
IF( LSAME( DIAG, 'U' ) ) THEN
DO 210 I = 1, N
WORK( I ) = ONE
210 CONTINUE
DO 230 J = 1, N
K = K + 1
DO 220 I = J + 1, N
WORK( I ) = WORK( I ) + ABS( AP( K ) )
K = K + 1
220 CONTINUE
230 CONTINUE
ELSE
DO 240 I = 1, N
WORK( I ) = ZERO
240 CONTINUE
DO 260 J = 1, N
DO 250 I = J, N
WORK( I ) = WORK( I ) + ABS( AP( K ) )
K = K + 1
250 CONTINUE
260 CONTINUE
END IF
END IF
VALUE = ZERO
DO 270 I = 1, N
VALUE = MAX( VALUE, WORK( I ) )
270 CONTINUE
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
IF( LSAME( UPLO, 'U' ) ) THEN
IF( LSAME( DIAG, 'U' ) ) THEN
SCALE = ONE
SUM = N
K = 2
DO 280 J = 2, N
CALL DLASSQ( J-1, AP( K ), 1, SCALE, SUM )
K = K + J
280 CONTINUE
ELSE
SCALE = ZERO
SUM = ONE
K = 1
DO 290 J = 1, N
CALL DLASSQ( J, AP( K ), 1, SCALE, SUM )
K = K + J
290 CONTINUE
END IF
ELSE
IF( LSAME( DIAG, 'U' ) ) THEN
SCALE = ONE
SUM = N
K = 2
DO 300 J = 1, N - 1
CALL DLASSQ( N-J, AP( K ), 1, SCALE, SUM )
K = K + N - J + 1
300 CONTINUE
ELSE
SCALE = ZERO
SUM = ONE
K = 1
DO 310 J = 1, N
CALL DLASSQ( N-J+1, AP( K ), 1, SCALE, SUM )
K = K + N - J + 1
310 CONTINUE
END IF
END IF
VALUE = SCALE*SQRT( SUM )
END IF
*
DLANTP = VALUE
RETURN
*
* End of DLANTP
*
END
DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, LDA,
$ WORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, NORM, UPLO
INTEGER LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLANTR returns the value of the one norm, or the Frobenius norm, or
* the infinity norm, or the element of largest absolute value of a
* trapezoidal or triangular matrix A.
*
* Description
* ===========
*
* DLANTR returns the value
*
* DLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm'
* (
* ( norm1(A), NORM = '1', 'O' or 'o'
* (
* ( normI(A), NORM = 'I' or 'i'
* (
* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*
* where norm1 denotes the one norm of a matrix (maximum column sum),
* normI denotes the infinity norm of a matrix (maximum row sum) and
* normF denotes the Frobenius norm of a matrix (square root of sum of
* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies the value to be returned in DLANTR as described
* above.
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower trapezoidal.
* = 'U': Upper trapezoidal
* = 'L': Lower trapezoidal
* Note that A is triangular instead of trapezoidal if M = N.
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A has unit diagonal.
* = 'N': Non-unit diagonal
* = 'U': Unit diagonal
*
* M (input) INTEGER
* The number of rows of the matrix A. M >= 0, and if
* UPLO = 'U', M <= N. When M = 0, DLANTR is set to zero.
*
* N (input) INTEGER
* The number of columns of the matrix A. N >= 0, and if
* UPLO = 'L', N <= M. When N = 0, DLANTR is set to zero.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The trapezoidal matrix A (A is triangular if M = N).
* If UPLO = 'U', the leading m by n upper trapezoidal part of
* the array A contains the upper trapezoidal matrix, and the
* strictly lower triangular part of A is not referenced.
* If UPLO = 'L', the leading m by n lower trapezoidal part of
* the array A contains the lower trapezoidal matrix, and the
* strictly upper triangular part of A is not referenced. Note
* that when DIAG = 'U', the diagonal elements of A are not
* referenced and are assumed to be one.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(M,1).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
* where LWORK >= M when NORM = 'I'; otherwise, WORK is not
* referenced.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UDIAG
INTEGER I, J
DOUBLE PRECISION SCALE, SUM, VALUE
* ..
* .. External Subroutines ..
EXTERNAL DLASSQ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
IF( MIN( M, N ).EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
IF( LSAME( DIAG, 'U' ) ) THEN
VALUE = ONE
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = 1, MIN( M, J-1 )
VALUE = MAX( VALUE, ABS( A( I, J ) ) )
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1, N
DO 30 I = J + 1, M
VALUE = MAX( VALUE, ABS( A( I, J ) ) )
30 CONTINUE
40 CONTINUE
END IF
ELSE
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 60 J = 1, N
DO 50 I = 1, MIN( M, J )
VALUE = MAX( VALUE, ABS( A( I, J ) ) )
50 CONTINUE
60 CONTINUE
ELSE
DO 80 J = 1, N
DO 70 I = J, M
VALUE = MAX( VALUE, ABS( A( I, J ) ) )
70 CONTINUE
80 CONTINUE
END IF
END IF
ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
*
* Find norm1(A).
*
VALUE = ZERO
UDIAG = LSAME( DIAG, 'U' )
IF( LSAME( UPLO, 'U' ) ) THEN
DO 110 J = 1, N
IF( ( UDIAG ) .AND. ( J.LE.M ) ) THEN
SUM = ONE
DO 90 I = 1, J - 1
SUM = SUM + ABS( A( I, J ) )
90 CONTINUE
ELSE
SUM = ZERO
DO 100 I = 1, MIN( M, J )
SUM = SUM + ABS( A( I, J ) )
100 CONTINUE
END IF
VALUE = MAX( VALUE, SUM )
110 CONTINUE
ELSE
DO 140 J = 1, N
IF( UDIAG ) THEN
SUM = ONE
DO 120 I = J + 1, M
SUM = SUM + ABS( A( I, J ) )
120 CONTINUE
ELSE
SUM = ZERO
DO 130 I = J, M
SUM = SUM + ABS( A( I, J ) )
130 CONTINUE
END IF
VALUE = MAX( VALUE, SUM )
140 CONTINUE
END IF
ELSE IF( LSAME( NORM, 'I' ) ) THEN
*
* Find normI(A).
*
IF( LSAME( UPLO, 'U' ) ) THEN
IF( LSAME( DIAG, 'U' ) ) THEN
DO 150 I = 1, M
WORK( I ) = ONE
150 CONTINUE
DO 170 J = 1, N
DO 160 I = 1, MIN( M, J-1 )
WORK( I ) = WORK( I ) + ABS( A( I, J ) )
160 CONTINUE
170 CONTINUE
ELSE
DO 180 I = 1, M
WORK( I ) = ZERO
180 CONTINUE
DO 200 J = 1, N
DO 190 I = 1, MIN( M, J )
WORK( I ) = WORK( I ) + ABS( A( I, J ) )
190 CONTINUE
200 CONTINUE
END IF
ELSE
IF( LSAME( DIAG, 'U' ) ) THEN
DO 210 I = 1, N
WORK( I ) = ONE
210 CONTINUE
DO 220 I = N + 1, M
WORK( I ) = ZERO
220 CONTINUE
DO 240 J = 1, N
DO 230 I = J + 1, M
WORK( I ) = WORK( I ) + ABS( A( I, J ) )
230 CONTINUE
240 CONTINUE
ELSE
DO 250 I = 1, M
WORK( I ) = ZERO
250 CONTINUE
DO 270 J = 1, N
DO 260 I = J, M
WORK( I ) = WORK( I ) + ABS( A( I, J ) )
260 CONTINUE
270 CONTINUE
END IF
END IF
VALUE = ZERO
DO 280 I = 1, M
VALUE = MAX( VALUE, WORK( I ) )
280 CONTINUE
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
IF( LSAME( UPLO, 'U' ) ) THEN
IF( LSAME( DIAG, 'U' ) ) THEN
SCALE = ONE
SUM = MIN( M, N )
DO 290 J = 2, N
CALL DLASSQ( MIN( M, J-1 ), A( 1, J ), 1, SCALE, SUM )
290 CONTINUE
ELSE
SCALE = ZERO
SUM = ONE
DO 300 J = 1, N
CALL DLASSQ( MIN( M, J ), A( 1, J ), 1, SCALE, SUM )
300 CONTINUE
END IF
ELSE
IF( LSAME( DIAG, 'U' ) ) THEN
SCALE = ONE
SUM = MIN( M, N )
DO 310 J = 1, N
CALL DLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, SCALE,
$ SUM )
310 CONTINUE
ELSE
SCALE = ZERO
SUM = ONE
DO 320 J = 1, N
CALL DLASSQ( M-J+1, A( J, J ), 1, SCALE, SUM )
320 CONTINUE
END IF
END IF
VALUE = SCALE*SQRT( SUM )
END IF
*
DLANTR = VALUE
RETURN
*
* End of DLANTR
*
END
SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
DOUBLE PRECISION A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN
* ..
*
* Purpose
* =======
*
* DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric
* matrix in standard form:
*
* [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ]
* [ C D ] [ SN CS ] [ CC DD ] [-SN CS ]
*
* where either
* 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or
* 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex
* conjugate eigenvalues.
*
* Arguments
* =========
*
* A (input/output) DOUBLE PRECISION
* B (input/output) DOUBLE PRECISION
* C (input/output) DOUBLE PRECISION
* D (input/output) DOUBLE PRECISION
* On entry, the elements of the input matrix.
* On exit, they are overwritten by the elements of the
* standardised Schur form.
*
* RT1R (output) DOUBLE PRECISION
* RT1I (output) DOUBLE PRECISION
* RT2R (output) DOUBLE PRECISION
* RT2I (output) DOUBLE PRECISION
* The real and imaginary parts of the eigenvalues. If the
* eigenvalues are a complex conjugate pair, RT1I > 0.
*
* CS (output) DOUBLE PRECISION
* SN (output) DOUBLE PRECISION
* Parameters of the rotation matrix.
*
* Further Details
* ===============
*
* Modified by V. Sima, Research Institute for Informatics, Bucharest,
* Romania, to reduce the risk of cancellation errors,
* when computing real eigenvalues, and to ensure, if possible, that
* abs(RT1R) >= abs(RT2R).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
DOUBLE PRECISION MULTPL
PARAMETER ( MULTPL = 4.0D+0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION AA, BB, BCMAX, BCMIS, CC, CS1, DD, EPS, P, SAB,
$ SAC, SCALE, SIGMA, SN1, TAU, TEMP, Z
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLAPY2
EXTERNAL DLAMCH, DLAPY2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SIGN, SQRT
* ..
* .. Executable Statements ..
*
EPS = DLAMCH( 'P' )
IF( C.EQ.ZERO ) THEN
CS = ONE
SN = ZERO
GO TO 10
*
ELSE IF( B.EQ.ZERO ) THEN
*
* Swap rows and columns
*
CS = ZERO
SN = ONE
TEMP = D
D = A
A = TEMP
B = -C
C = ZERO
GO TO 10
ELSE IF( ( A-D ).EQ.ZERO .AND. SIGN( ONE, B ).NE.SIGN( ONE, C ) )
$ THEN
CS = ONE
SN = ZERO
GO TO 10
ELSE
*
TEMP = A - D
P = HALF*TEMP
BCMAX = MAX( ABS( B ), ABS( C ) )
BCMIS = MIN( ABS( B ), ABS( C ) )*SIGN( ONE, B )*SIGN( ONE, C )
SCALE = MAX( ABS( P ), BCMAX )
Z = ( P / SCALE )*P + ( BCMAX / SCALE )*BCMIS
*
* If Z is of the order of the machine accuracy, postpone the
* decision on the nature of eigenvalues
*
IF( Z.GE.MULTPL*EPS ) THEN
*
* Real eigenvalues. Compute A and D.
*
Z = P + SIGN( SQRT( SCALE )*SQRT( Z ), P )
A = D + Z
D = D - ( BCMAX / Z )*BCMIS
*
* Compute B and the rotation matrix
*
TAU = DLAPY2( C, Z )
CS = Z / TAU
SN = C / TAU
B = B - C
C = ZERO
ELSE
*
* Complex eigenvalues, or real (almost) equal eigenvalues.
* Make diagonal elements equal.
*
SIGMA = B + C
TAU = DLAPY2( SIGMA, TEMP )
CS = SQRT( HALF*( ONE+ABS( SIGMA ) / TAU ) )
SN = -( P / ( TAU*CS ) )*SIGN( ONE, SIGMA )
*
* Compute [ AA BB ] = [ A B ] [ CS -SN ]
* [ CC DD ] [ C D ] [ SN CS ]
*
AA = A*CS + B*SN
BB = -A*SN + B*CS
CC = C*CS + D*SN
DD = -C*SN + D*CS
*
* Compute [ A B ] = [ CS SN ] [ AA BB ]
* [ C D ] [-SN CS ] [ CC DD ]
*
A = AA*CS + CC*SN
B = BB*CS + DD*SN
C = -AA*SN + CC*CS
D = -BB*SN + DD*CS
*
TEMP = HALF*( A+D )
A = TEMP
D = TEMP
*
IF( C.NE.ZERO ) THEN
IF( B.NE.ZERO ) THEN
IF( SIGN( ONE, B ).EQ.SIGN( ONE, C ) ) THEN
*
* Real eigenvalues: reduce to upper triangular form
*
SAB = SQRT( ABS( B ) )
SAC = SQRT( ABS( C ) )
P = SIGN( SAB*SAC, C )
TAU = ONE / SQRT( ABS( B+C ) )
A = TEMP + P
D = TEMP - P
B = B - C
C = ZERO
CS1 = SAB*TAU
SN1 = SAC*TAU
TEMP = CS*CS1 - SN*SN1
SN = CS*SN1 + SN*CS1
CS = TEMP
END IF
ELSE
B = -C
C = ZERO
TEMP = CS
CS = -SN
SN = TEMP
END IF
END IF
END IF
*
END IF
*
10 CONTINUE
*
* Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I).
*
RT1R = A
RT2R = D
IF( C.EQ.ZERO ) THEN
RT1I = ZERO
RT2I = ZERO
ELSE
RT1I = SQRT( ABS( B ) )*SQRT( ABS( C ) )
RT2I = -RT1I
END IF
RETURN
*
* End of DLANV2
*
END
SUBROUTINE DLAPLL( N, X, INCX, Y, INCY, SSMIN )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INCX, INCY, N
DOUBLE PRECISION SSMIN
* ..
* .. Array Arguments ..
DOUBLE PRECISION X( * ), Y( * )
* ..
*
* Purpose
* =======
*
* Given two column vectors X and Y, let
*
* A = ( X Y ).
*
* The subroutine first computes the QR factorization of A = Q*R,
* and then computes the SVD of the 2-by-2 upper triangular matrix R.
* The smaller singular value of R is returned in SSMIN, which is used
* as the measurement of the linear dependency of the vectors X and Y.
*
* Arguments
* =========
*
* N (input) INTEGER
* The length of the vectors X and Y.
*
* X (input/output) DOUBLE PRECISION array,
* dimension (1+(N-1)*INCX)
* On entry, X contains the N-vector X.
* On exit, X is overwritten.
*
* INCX (input) INTEGER
* The increment between successive elements of X. INCX > 0.
*
* Y (input/output) DOUBLE PRECISION array,
* dimension (1+(N-1)*INCY)
* On entry, Y contains the N-vector Y.
* On exit, Y is overwritten.
*
* INCY (input) INTEGER
* The increment between successive elements of Y. INCY > 0.
*
* SSMIN (output) DOUBLE PRECISION
* The smallest singular value of the N-by-2 matrix A = ( X Y ).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION A11, A12, A22, C, SSMAX, TAU
* ..
* .. External Functions ..
DOUBLE PRECISION DDOT
EXTERNAL DDOT
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DLARFG, DLAS2
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.1 ) THEN
SSMIN = ZERO
RETURN
END IF
*
* Compute the QR factorization of the N-by-2 matrix ( X Y )
*
CALL DLARFG( N, X( 1 ), X( 1+INCX ), INCX, TAU )
A11 = X( 1 )
X( 1 ) = ONE
*
C = -TAU*DDOT( N, X, INCX, Y, INCY )
CALL DAXPY( N, C, X, INCX, Y, INCY )
*
CALL DLARFG( N-1, Y( 1+INCY ), Y( 1+2*INCY ), INCY, TAU )
*
A12 = Y( 1 )
A22 = Y( 1+INCY )
*
* Compute the SVD of 2-by-2 Upper triangular matrix.
*
CALL DLAS2( A11, A12, A22, SSMIN, SSMAX )
*
RETURN
*
* End of DLAPLL
*
END
SUBROUTINE DLAPMT( FORWRD, M, N, X, LDX, K )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL FORWRD
INTEGER LDX, M, N
* ..
* .. Array Arguments ..
INTEGER K( * )
DOUBLE PRECISION X( LDX, * )
* ..
*
* Purpose
* =======
*
* DLAPMT rearranges the columns of the M by N matrix X as specified
* by the permutation K(1),K(2),...,K(N) of the integers 1,...,N.
* If FORWRD = .TRUE., forward permutation:
*
* X(*,K(J)) is moved X(*,J) for J = 1,2,...,N.
*
* If FORWRD = .FALSE., backward permutation:
*
* X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N.
*
* Arguments
* =========
*
* FORWRD (input) LOGICAL
* = .TRUE., forward permutation
* = .FALSE., backward permutation
*
* M (input) INTEGER
* The number of rows of the matrix X. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix X. N >= 0.
*
* X (input/output) DOUBLE PRECISION array, dimension (LDX,N)
* On entry, the M by N matrix X.
* On exit, X contains the permuted matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X, LDX >= MAX(1,M).
*
* K (input/output) INTEGER array, dimension (N)
* On entry, K contains the permutation vector. K is used as
* internal workspace, but reset to its original value on
* output.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, II, IN, J
DOUBLE PRECISION TEMP
* ..
* .. Executable Statements ..
*
IF( N.LE.1 )
$ RETURN
*
DO 10 I = 1, N
K( I ) = -K( I )
10 CONTINUE
*
IF( FORWRD ) THEN
*
* Forward permutation
*
DO 50 I = 1, N
*
IF( K( I ).GT.0 )
$ GO TO 40
*
J = I
K( J ) = -K( J )
IN = K( J )
*
20 CONTINUE
IF( K( IN ).GT.0 )
$ GO TO 40
*
DO 30 II = 1, M
TEMP = X( II, J )
X( II, J ) = X( II, IN )
X( II, IN ) = TEMP
30 CONTINUE
*
K( IN ) = -K( IN )
J = IN
IN = K( IN )
GO TO 20
*
40 CONTINUE
*
50 CONTINUE
*
ELSE
*
* Backward permutation
*
DO 90 I = 1, N
*
IF( K( I ).GT.0 )
$ GO TO 80
*
K( I ) = -K( I )
J = K( I )
60 CONTINUE
IF( J.EQ.I )
$ GO TO 80
*
DO 70 II = 1, M
TEMP = X( II, I )
X( II, I ) = X( II, J )
X( II, J ) = TEMP
70 CONTINUE
*
K( J ) = -K( J )
J = K( J )
GO TO 60
*
80 CONTINUE
*
90 CONTINUE
*
END IF
*
RETURN
*
* End of DLAPMT
*
END
DOUBLE PRECISION FUNCTION DLAPY2( X, Y )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley 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
DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
DOUBLE PRECISION X, Y, Z
* ..
*
* Purpose
* =======
*
* DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause
* unnecessary overflow.
*
* Arguments
* =========
*
* X (input) DOUBLE PRECISION
* Y (input) DOUBLE PRECISION
* Z (input) DOUBLE PRECISION
* X, Y and Z specify the values x, y and z.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION W, XABS, YABS, ZABS
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
XABS = ABS( X )
YABS = ABS( Y )
ZABS = ABS( Z )
W = MAX( XABS, YABS, ZABS )
IF( W.EQ.ZERO ) THEN
* W can be zero for max(0,nan,0)
* adding all three entries together will make sure
* NaN will not disappear.
DLAPY3 = XABS + YABS + ZABS
ELSE
DLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+
$ ( ZABS / W )**2 )
END IF
RETURN
*
* End of DLAPY3
*
END
SUBROUTINE DLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND,
$ AMAX, EQUED )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER EQUED
INTEGER KL, KU, LDAB, M, N
DOUBLE PRECISION AMAX, COLCND, ROWCND
* ..
* .. Array Arguments ..
DOUBLE PRECISION AB( LDAB, * ), C( * ), R( * )
* ..
*
* Purpose
* =======
*
* DLAQGB equilibrates a general M by N band matrix A with KL
* subdiagonals and KU superdiagonals using the row and scaling factors
* in the vectors R and C.
*
* 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.
*
* KL (input) INTEGER
* The number of subdiagonals within the band of A. KL >= 0.
*
* KU (input) INTEGER
* The number of superdiagonals within the band of A. KU >= 0.
*
* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
* The j-th column of A is stored in the j-th column of the
* array AB as follows:
* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
*
* On exit, the equilibrated matrix, in the same storage format
* as A. See EQUED for the form of the equilibrated matrix.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDA >= KL+KU+1.
*
* R (input) DOUBLE PRECISION array, dimension (M)
* The row scale factors for A.
*
* C (input) DOUBLE PRECISION array, dimension (N)
* The column scale factors for A.
*
* ROWCND (input) DOUBLE PRECISION
* Ratio of the smallest R(i) to the largest R(i).
*
* COLCND (input) DOUBLE PRECISION
* Ratio of the smallest C(i) to the largest C(i).
*
* AMAX (input) DOUBLE PRECISION
* Absolute value of largest matrix entry.
*
* EQUED (output) CHARACTER*1
* Specifies the form of equilibration that was done.
* = 'N': No equilibration
* = 'R': Row equilibration, i.e., A has been premultiplied by
* diag(R).
* = 'C': Column equilibration, i.e., A has been postmultiplied
* by diag(C).
* = 'B': Both row and column equilibration, i.e., A has been
* replaced by diag(R) * A * diag(C).
*
* Internal Parameters
* ===================
*
* THRESH is a threshold value used to decide if row or column scaling
* should be done based on the ratio of the row or column scaling
* factors. If ROWCND < THRESH, row scaling is done, and if
* COLCND < THRESH, column scaling is done.
*
* LARGE and SMALL are threshold values used to decide if row scaling
* should be done based on the absolute size of the largest matrix
* element. If AMAX > LARGE or AMAX < SMALL, row scaling is done.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, THRESH
PARAMETER ( ONE = 1.0D+0, THRESH = 0.1D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION CJ, LARGE, SMALL
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 ) THEN
EQUED = 'N'
RETURN
END IF
*
* Initialize LARGE and SMALL.
*
SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
LARGE = ONE / SMALL
*
IF( ROWCND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE )
$ THEN
*
* No row scaling
*
IF( COLCND.GE.THRESH ) THEN
*
* No column scaling
*
EQUED = 'N'
ELSE
*
* Column scaling
*
DO 20 J = 1, N
CJ = C( J )
DO 10 I = MAX( 1, J-KU ), MIN( M, J+KL )
AB( KU+1+I-J, J ) = CJ*AB( KU+1+I-J, J )
10 CONTINUE
20 CONTINUE
EQUED = 'C'
END IF
ELSE IF( COLCND.GE.THRESH ) THEN
*
* Row scaling, no column scaling
*
DO 40 J = 1, N
DO 30 I = MAX( 1, J-KU ), MIN( M, J+KL )
AB( KU+1+I-J, J ) = R( I )*AB( KU+1+I-J, J )
30 CONTINUE
40 CONTINUE
EQUED = 'R'
ELSE
*
* Row and column scaling
*
DO 60 J = 1, N
CJ = C( J )
DO 50 I = MAX( 1, J-KU ), MIN( M, J+KL )
AB( KU+1+I-J, J ) = CJ*R( I )*AB( KU+1+I-J, J )
50 CONTINUE
60 CONTINUE
EQUED = 'B'
END IF
*
RETURN
*
* End of DLAQGB
*
END
SUBROUTINE DLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
$ EQUED )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER EQUED
INTEGER LDA, M, N
DOUBLE PRECISION AMAX, COLCND, ROWCND
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), C( * ), R( * )
* ..
*
* Purpose
* =======
*
* DLAQGE equilibrates a general M by N matrix A using the row and
* column scaling factors in the vectors R and C.
*
* 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 equilibrated matrix. See EQUED for the form of
* the equilibrated matrix.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(M,1).
*
* R (input) DOUBLE PRECISION array, dimension (M)
* The row scale factors for A.
*
* C (input) DOUBLE PRECISION array, dimension (N)
* The column scale factors for A.
*
* ROWCND (input) DOUBLE PRECISION
* Ratio of the smallest R(i) to the largest R(i).
*
* COLCND (input) DOUBLE PRECISION
* Ratio of the smallest C(i) to the largest C(i).
*
* AMAX (input) DOUBLE PRECISION
* Absolute value of largest matrix entry.
*
* EQUED (output) CHARACTER*1
* Specifies the form of equilibration that was done.
* = 'N': No equilibration
* = 'R': Row equilibration, i.e., A has been premultiplied by
* diag(R).
* = 'C': Column equilibration, i.e., A has been postmultiplied
* by diag(C).
* = 'B': Both row and column equilibration, i.e., A has been
* replaced by diag(R) * A * diag(C).
*
* Internal Parameters
* ===================
*
* THRESH is a threshold value used to decide if row or column scaling
* should be done based on the ratio of the row or column scaling
* factors. If ROWCND < THRESH, row scaling is done, and if
* COLCND < THRESH, column scaling is done.
*
* LARGE and SMALL are threshold values used to decide if row scaling
* should be done based on the absolute size of the largest matrix
* element. If AMAX > LARGE or AMAX < SMALL, row scaling is done.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, THRESH
PARAMETER ( ONE = 1.0D+0, THRESH = 0.1D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION CJ, LARGE, SMALL
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 ) THEN
EQUED = 'N'
RETURN
END IF
*
* Initialize LARGE and SMALL.
*
SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
LARGE = ONE / SMALL
*
IF( ROWCND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE )
$ THEN
*
* No row scaling
*
IF( COLCND.GE.THRESH ) THEN
*
* No column scaling
*
EQUED = 'N'
ELSE
*
* Column scaling
*
DO 20 J = 1, N
CJ = C( J )
DO 10 I = 1, M
A( I, J ) = CJ*A( I, J )
10 CONTINUE
20 CONTINUE
EQUED = 'C'
END IF
ELSE IF( COLCND.GE.THRESH ) THEN
*
* Row scaling, no column scaling
*
DO 40 J = 1, N
DO 30 I = 1, M
A( I, J ) = R( I )*A( I, J )
30 CONTINUE
40 CONTINUE
EQUED = 'R'
ELSE
*
* Row and column scaling
*
DO 60 J = 1, N
CJ = C( J )
DO 50 I = 1, M
A( I, J ) = CJ*R( I )*A( I, J )
50 CONTINUE
60 CONTINUE
EQUED = 'B'
END IF
*
RETURN
*
* End of DLAQGE
*
END
SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
$ WORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, M, N, OFFSET
* ..
* .. Array Arguments ..
INTEGER JPVT( * )
DOUBLE PRECISION A( LDA, * ), TAU( * ), VN1( * ), VN2( * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* DLAQP2 computes a QR factorization with column pivoting of
* the block A(OFFSET+1:M,1:N).
* The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.
*
* 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.
*
* OFFSET (input) INTEGER
* The number of rows of the matrix A that must be pivoted
* but no factorized. OFFSET >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, the upper triangle of block A(OFFSET+1:M,1:N) is
* the triangular factor obtained; the elements in block
* A(OFFSET+1:M,1:N) below the diagonal, together with the
* array TAU, represent the orthogonal matrix Q as a product of
* elementary reflectors. Block A(1:OFFSET,1:N) has been
* accordingly pivoted, but no factorized.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* JPVT (input/output) INTEGER array, dimension (N)
* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
* to the front of A*P (a leading column); if JPVT(i) = 0,
* the i-th column of A is a free column.
* On exit, if JPVT(i) = k, then the i-th column of A*P
* was the k-th column of A.
*
* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
* The scalar factors of the elementary reflectors.
*
* VN1 (input/output) DOUBLE PRECISION array, dimension (N)
* The vector with the partial column norms.
*
* VN2 (input/output) DOUBLE PRECISION array, dimension (N)
* The vector with the exact column norms.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* Further Details
* ===============
*
* Based on contributions by
* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
* X. Sun, Computer Science Dept., Duke University, USA
*
* Partial column norm updating strategy modified by
* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,
* University of Zagreb, Croatia.
* June 2006.
* For more details see LAPACK Working Note 176.
* =====================================================================
*
* .. 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)' 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.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KB, LDA, LDF, M, N, NB, OFFSET
* ..
* .. Array Arguments ..
INTEGER JPVT( * )
DOUBLE PRECISION A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ),
$ VN1( * ), VN2( * )
* ..
*
* Purpose
* =======
*
* DLAQPS computes a step of QR factorization with column pivoting
* of a real M-by-N matrix A by using Blas-3. It tries to factorize
* NB columns from A starting from the row OFFSET+1, and updates all
* of the matrix with Blas-3 xGEMM.
*
* In some cases, due to catastrophic cancellations, it cannot
* factorize NB columns. Hence, the actual number of factorized
* columns is returned in KB.
*
* Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.
*
* 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
*
* OFFSET (input) INTEGER
* The number of rows of A that have been factorized in
* previous steps.
*
* NB (input) INTEGER
* The number of columns to factorize.
*
* KB (output) INTEGER
* The number of columns actually factorized.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, block A(OFFSET+1:M,1:KB) is the triangular
* factor obtained and block A(1:OFFSET,1:N) has been
* accordingly pivoted, but no factorized.
* The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has
* been updated.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* JPVT (input/output) INTEGER array, dimension (N)
* JPVT(I) = K <==> Column K of the full matrix A has been
* permuted into position I in AP.
*
* TAU (output) DOUBLE PRECISION array, dimension (KB)
* The scalar factors of the elementary reflectors.
*
* VN1 (input/output) DOUBLE PRECISION array, dimension (N)
* The vector with the partial column norms.
*
* VN2 (input/output) DOUBLE PRECISION array, dimension (N)
* The vector with the exact column norms.
*
* AUXV (input/output) DOUBLE PRECISION array, dimension (NB)
* Auxiliar vector.
*
* F (input/output) DOUBLE PRECISION array, dimension (LDF,NB)
* Matrix F' = L*Y'*A.
*
* LDF (input) INTEGER
* The leading dimension of the array F. LDF >= max(1,N).
*
* Further Details
* ===============
*
* Based on contributions by
* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
* X. Sun, Computer Science Dept., Duke University, USA
*
* Partial column norm updating strategy modified by
* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,
* University of Zagreb, Croatia.
* June 2006.
* For more details see LAPACK Working Note 176.
* =====================================================================
*
* .. 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)'.
*
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)'*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)'
* *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)'.
*
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)'.
*
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 DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
$ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ),
$ Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DLAQR0 computes the eigenvalues of a Hessenberg matrix H
* and, optionally, the matrices T and Z from the Schur decomposition
* H = Z T Z**T, where T is an upper quasi-triangular matrix (the
* Schur form), and Z is the orthogonal matrix of Schur vectors.
*
* Optionally Z may be postmultiplied into an input orthogonal
* matrix Q so that this routine can give the Schur factorization
* of a matrix A which has been reduced to the Hessenberg form H
* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.
*
* Arguments
* =========
*
* WANTT (input) LOGICAL
* = .TRUE. : the full Schur form T is required;
* = .FALSE.: only eigenvalues are required.
*
* WANTZ (input) LOGICAL
* = .TRUE. : the matrix of Schur vectors Z is required;
* = .FALSE.: Schur vectors are not required.
*
* N (input) INTEGER
* The order of the matrix H. N .GE. 0.
*
* 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 and, if ILO.GT.1,
* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a
* previous call to DGEBAL, and then passed to DGEHRD when the
* matrix output by DGEBAL is reduced to Hessenberg form.
* Otherwise, ILO and IHI should be set to 1 and N,
* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
* If N = 0, then ILO = 1 and IHI = 0.
*
* H (input/output) DOUBLE PRECISION array, dimension (LDH,N)
* On entry, the upper Hessenberg matrix H.
* On exit, if INFO = 0 and WANTT is .TRUE., then H contains
* the upper quasi-triangular matrix T from the Schur
* decomposition (the Schur form); 2-by-2 diagonal blocks
* (corresponding to complex conjugate pairs of eigenvalues)
* are returned in standard form, with H(i,i) = H(i+1,i+1)
* and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is
* .FALSE., then the contents of H are unspecified on exit.
* (The output value of H when INFO.GT.0 is given under the
* description of INFO below.)
*
* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and
* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.
*
* LDH (input) INTEGER
* The leading dimension of the array H. LDH .GE. max(1,N).
*
* WR (output) DOUBLE PRECISION array, dimension (IHI)
* WI (output) DOUBLE PRECISION array, dimension (IHI)
* The real and imaginary parts, respectively, of the computed
* eigenvalues of H(ILO:IHI,ILO:IHI) are stored WR(ILO:IHI)
* and WI(ILO:IHI). If two eigenvalues are computed as a
* complex conjugate pair, they are stored in consecutive
* elements of WR and WI, say the i-th and (i+1)th, with
* WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then
* the eigenvalues are stored in the same order as on the
* diagonal of the Schur form returned in H, with
* WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal
* block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and
* WI(i+1) = -WI(i).
*
* ILOZ (input) INTEGER
* IHIZ (input) INTEGER
* Specify the rows of Z to which transformations must be
* applied if WANTZ is .TRUE..
* 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.
*
* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI)
* If WANTZ is .FALSE., then Z is not referenced.
* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is
* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the
* orthogonal Schur factor of H(ILO:IHI,ILO:IHI).
* (The output value of Z when INFO.GT.0 is given under
* the description of INFO below.)
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. if WANTZ is .TRUE.
* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.
*
* WORK (workspace/output) DOUBLE PRECISION array, dimension LWORK
* On exit, if LWORK = -1, WORK(1) returns an estimate of
* the optimal value for LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK. LWORK .GE. max(1,N)
* is sufficient, but LWORK typically as large as 6*N may
* be required for optimal performance. A workspace query
* to determine the optimal workspace size is recommended.
*
* If LWORK = -1, then DLAQR0 does a workspace query.
* In this case, DLAQR0 checks the input parameters and
* estimates the optimal workspace size for the given
* values of N, ILO and IHI. The estimate is returned
* in WORK(1). No error message related to LWORK is
* issued by XERBLA. Neither H nor Z are accessed.
*
*
* INFO (output) INTEGER
* = 0: successful exit
* .GT. 0: if INFO = i, DLAQR0 failed to compute all of
* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
* and WI contain those eigenvalues which have been
* successfully computed. (Failures are rare.)
*
* If INFO .GT. 0 and WANT is .FALSE., then on exit,
* the remaining unconverged eigenvalues are the eigen-
* values of the upper Hessenberg matrix rows and
* columns ILO through INFO of the final, output
* value of H.
*
* If INFO .GT. 0 and WANTT is .TRUE., then on exit
*
* (*) (initial value of H)*U = U*(final value of H)
*
* where U is an orthogonal matrix. The final
* value of H is upper Hessenberg and quasi-triangular
* in rows and columns INFO+1 through IHI.
*
* If INFO .GT. 0 and WANTZ is .TRUE., then on exit
*
* (final value of Z(ILO:IHI,ILOZ:IHIZ)
* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U
*
* where U is the orthogonal matrix in (*) (regard-
* less of the value of WANTT.)
*
* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not
* accessed.
*
*
* ================================================================
* Based on contributions by
* Karen Braman and Ralph Byers, Department of Mathematics,
* University of Kansas, USA
*
* ================================================================
*
* References:
* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
* Performance, SIAM Journal of Matrix Analysis, volume 23, pages
* 929--947, 2002.
*
* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
* Algorithm Part II: Aggressive Early Deflation, SIAM Journal
* of Matrix Analysis, volume 23, pages 948--973, 2002.
*
* ================================================================
* .. Parameters ..
*
* ==== Matrices of order NTINY or smaller must be processed by
* . DLAHQR because of insufficient subdiagonal scratch space.
* . (This is a hard limit.) ====
*
* ==== Exceptional deflation windows: try to cure rare
* . slow convergence by increasing the size of the
* . deflation window after KEXNW iterations. =====
*
* ==== Exceptional shifts: try to cure rare slow convergence
* . with ad-hoc exceptional shifts every KEXSH iterations.
* . The constants WILK1 and WILK2 are used to form the
* . exceptional shifts. ====
*
INTEGER NTINY
PARAMETER ( NTINY = 11 )
INTEGER KEXNW, KEXSH
PARAMETER ( KEXNW = 5, KEXSH = 6 )
DOUBLE PRECISION WILK1, WILK2
PARAMETER ( WILK1 = 0.75d0, WILK2 = -0.4375d0 )
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION AA, BB, CC, CS, DD, SN, SS, SWAP
INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS,
$ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS,
$ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX,
$ NSR, NVE, NW, NWMAX, NWR
LOGICAL NWINC, SORTED
CHARACTER JBCMPZ*2
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Local Arrays ..
DOUBLE PRECISION ZDUM( 1, 1 )
* ..
* .. External Subroutines ..
EXTERNAL DLACPY, DLAHQR, DLANV2, DLAQR3, DLAQR4, DLAQR5
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD
* ..
* .. Executable Statements ..
INFO = 0
*
* ==== Quick return for N = 0: nothing to do. ====
*
IF( N.EQ.0 ) THEN
WORK( 1 ) = ONE
RETURN
END IF
*
* ==== Set up job flags for ILAENV. ====
*
IF( WANTT ) THEN
JBCMPZ( 1: 1 ) = 'S'
ELSE
JBCMPZ( 1: 1 ) = 'E'
END IF
IF( WANTZ ) THEN
JBCMPZ( 2: 2 ) = 'V'
ELSE
JBCMPZ( 2: 2 ) = 'N'
END IF
*
* ==== Tiny matrices must use DLAHQR. ====
*
IF( N.LE.NTINY ) THEN
*
* ==== Estimate optimal workspace. ====
*
LWKOPT = 1
IF( LWORK.NE.-1 )
$ CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
$ ILOZ, IHIZ, Z, LDZ, INFO )
ELSE
*
* ==== Use small bulge multi-shift QR with aggressive early
* . deflation on larger-than-tiny matrices. ====
*
* ==== Hope for the best. ====
*
INFO = 0
*
* ==== NWR = recommended deflation window size. At this
* . point, N .GT. NTINY = 11, so there is enough
* . subdiagonal workspace for NWR.GE.2 as required.
* . (In fact, there is enough subdiagonal space for
* . NWR.GE.3.) ====
*
NWR = ILAENV( 13, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
NWR = MAX( 2, NWR )
NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR )
NW = NWR
*
* ==== NSR = recommended number of simultaneous shifts.
* . At this point N .GT. NTINY = 11, so there is at
* . enough subdiagonal workspace for NSR to be even
* . and greater than or equal to two as required. ====
*
NSR = ILAENV( 15, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO )
NSR = MAX( 2, NSR-MOD( NSR, 2 ) )
*
* ==== Estimate optimal workspace ====
*
* ==== Workspace query call to DLAQR3 ====
*
CALL DLAQR3( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ,
$ IHIZ, Z, LDZ, LS, LD, WR, WI, H, LDH, N, H, LDH,
$ N, H, LDH, WORK, -1 )
*
* ==== Optimal workspace = MAX(DLAQR5, DLAQR3) ====
*
LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) )
*
* ==== Quick return in case of workspace query. ====
*
IF( LWORK.EQ.-1 ) THEN
WORK( 1 ) = DBLE( LWKOPT )
RETURN
END IF
*
* ==== DLAHQR/DLAQR0 crossover point ====
*
NMIN = ILAENV( 12, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
NMIN = MAX( NTINY, NMIN )
*
* ==== Nibble crossover point ====
*
NIBBLE = ILAENV( 14, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
NIBBLE = MAX( 0, NIBBLE )
*
* ==== Accumulate reflections during ttswp? Use block
* . 2-by-2 structure during matrix-matrix multiply? ====
*
KACC22 = ILAENV( 16, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
KACC22 = MAX( 0, KACC22 )
KACC22 = MIN( 2, KACC22 )
*
* ==== NWMAX = the largest possible deflation window for
* . which there is sufficient workspace. ====
*
NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 )
*
* ==== NSMAX = the Largest number of simultaneous shifts
* . for which there is sufficient workspace. ====
*
NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 )
NSMAX = NSMAX - MOD( NSMAX, 2 )
*
* ==== NDFL: an iteration count restarted at deflation. ====
*
NDFL = 1
*
* ==== ITMAX = iteration limit ====
*
ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) )
*
* ==== Last row and column in the active block ====
*
KBOT = IHI
*
* ==== Main Loop ====
*
DO 80 IT = 1, ITMAX
*
* ==== Done when KBOT falls below ILO ====
*
IF( KBOT.LT.ILO )
$ GO TO 90
*
* ==== Locate active block ====
*
DO 10 K = KBOT, ILO + 1, -1
IF( H( K, K-1 ).EQ.ZERO )
$ GO TO 20
10 CONTINUE
K = ILO
20 CONTINUE
KTOP = K
*
* ==== Select deflation window size ====
*
NH = KBOT - KTOP + 1
IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN
*
* ==== Typical deflation window. If possible and
* . advisable, nibble the entire active block.
* . If not, use size NWR or NWR+1 depending upon
* . which has the smaller corresponding subdiagonal
* . entry (a heuristic). ====
*
NWINC = .TRUE.
IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN
NW = NH
ELSE
NW = MIN( NWR, NH, NWMAX )
IF( NW.LT.NWMAX ) THEN
IF( NW.GE.NH-1 ) THEN
NW = NH
ELSE
KWTOP = KBOT - NW + 1
IF( ABS( H( KWTOP, KWTOP-1 ) ).GT.
$ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1
END IF
END IF
END IF
ELSE
*
* ==== Exceptional deflation window. If there have
* . been no deflations in KEXNW or more iterations,
* . then vary the deflation window size. At first,
* . because, larger windows are, in general, more
* . powerful than smaller ones, rapidly increase the
* . window up to the maximum reasonable and possible.
* . Then maybe try a slightly smaller window. ====
*
IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN
NW = MIN( NWMAX, NH, 2*NW )
ELSE
NWINC = .FALSE.
IF( NW.EQ.NH .AND. NH.GT.2 )
$ NW = NH - 1
END IF
END IF
*
* ==== Aggressive early deflation:
* . split workspace under the subdiagonal into
* . - an nw-by-nw work array V in the lower
* . left-hand-corner,
* . - an NW-by-at-least-NW-but-more-is-better
* . (NW-by-NHO) horizontal work array along
* . the bottom edge,
* . - an at-least-NW-but-more-is-better (NHV-by-NW)
* . vertical work array along the left-hand-edge.
* . ====
*
KV = N - NW + 1
KT = NW + 1
NHO = ( N-NW-1 ) - KT + 1
KWV = NW + 2
NVE = ( N-NW ) - KWV + 1
*
* ==== Aggressive early deflation ====
*
CALL DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
$ IHIZ, Z, LDZ, LS, LD, WR, WI, H( KV, 1 ), LDH,
$ NHO, H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH,
$ WORK, LWORK )
*
* ==== Adjust KBOT accounting for new deflations. ====
*
KBOT = KBOT - LD
*
* ==== KS points to the shifts. ====
*
KS = KBOT - LS + 1
*
* ==== Skip an expensive QR sweep if there is a (partly
* . heuristic) reason to expect that many eigenvalues
* . will deflate without it. Here, the QR sweep is
* . skipped if many eigenvalues have just been deflated
* . or if the remaining active block is small.
*
IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT-
$ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN
*
* ==== NS = nominal number of simultaneous shifts.
* . This may be lowered (slightly) if DLAQR3
* . did not provide that many shifts. ====
*
NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) )
NS = NS - MOD( NS, 2 )
*
* ==== If there have been no deflations
* . in a multiple of KEXSH iterations,
* . then try exceptional shifts.
* . Otherwise use shifts provided by
* . DLAQR3 above or from the eigenvalues
* . of a trailing principal submatrix. ====
*
IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN
KS = KBOT - NS + 1
DO 30 I = KBOT, MAX( KS+1, KTOP+2 ), -2
SS = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) )
AA = WILK1*SS + H( I, I )
BB = SS
CC = WILK2*SS
DD = AA
CALL DLANV2( AA, BB, CC, DD, WR( I-1 ), WI( I-1 ),
$ WR( I ), WI( I ), CS, SN )
30 CONTINUE
IF( KS.EQ.KTOP ) THEN
WR( KS+1 ) = H( KS+1, KS+1 )
WI( KS+1 ) = ZERO
WR( KS ) = WR( KS+1 )
WI( KS ) = WI( KS+1 )
END IF
ELSE
*
* ==== Got NS/2 or fewer shifts? Use DLAQR4 or
* . DLAHQR on a trailing principal submatrix to
* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9,
* . there is enough space below the subdiagonal
* . to fit an NS-by-NS scratch array.) ====
*
IF( KBOT-KS+1.LE.NS / 2 ) THEN
KS = KBOT - NS + 1
KT = N - NS + 1
CALL DLACPY( 'A', NS, NS, H( KS, KS ), LDH,
$ H( KT, 1 ), LDH )
IF( NS.GT.NMIN ) THEN
CALL DLAQR4( .false., .false., NS, 1, NS,
$ H( KT, 1 ), LDH, WR( KS ),
$ WI( KS ), 1, 1, ZDUM, 1, WORK,
$ LWORK, INF )
ELSE
CALL DLAHQR( .false., .false., NS, 1, NS,
$ H( KT, 1 ), LDH, WR( KS ),
$ WI( KS ), 1, 1, ZDUM, 1, INF )
END IF
KS = KS + INF
*
* ==== In case of a rare QR failure use
* . eigenvalues of the trailing 2-by-2
* . principal submatrix. ====
*
IF( KS.GE.KBOT ) THEN
AA = H( KBOT-1, KBOT-1 )
CC = H( KBOT, KBOT-1 )
BB = H( KBOT-1, KBOT )
DD = H( KBOT, KBOT )
CALL DLANV2( AA, BB, CC, DD, WR( KBOT-1 ),
$ WI( KBOT-1 ), WR( KBOT ),
$ WI( KBOT ), CS, SN )
KS = KBOT - 1
END IF
END IF
*
IF( KBOT-KS+1.GT.NS ) THEN
*
* ==== Sort the shifts (Helps a little)
* . Bubble sort keeps complex conjugate
* . pairs together. ====
*
SORTED = .false.
DO 50 K = KBOT, KS + 1, -1
IF( SORTED )
$ GO TO 60
SORTED = .true.
DO 40 I = KS, K - 1
IF( ABS( WR( I ) )+ABS( WI( I ) ).LT.
$ ABS( WR( I+1 ) )+ABS( WI( I+1 ) ) ) THEN
SORTED = .false.
*
SWAP = WR( I )
WR( I ) = WR( I+1 )
WR( I+1 ) = SWAP
*
SWAP = WI( I )
WI( I ) = WI( I+1 )
WI( I+1 ) = SWAP
END IF
40 CONTINUE
50 CONTINUE
60 CONTINUE
END IF
*
* ==== Shuffle shifts into pairs of real shifts
* . and pairs of complex conjugate shifts
* . assuming complex conjugate shifts are
* . already adjacent to one another. (Yes,
* . they are.) ====
*
DO 70 I = KBOT, KS + 2, -2
IF( WI( I ).NE.-WI( I-1 ) ) THEN
*
SWAP = WR( I )
WR( I ) = WR( I-1 )
WR( I-1 ) = WR( I-2 )
WR( I-2 ) = SWAP
*
SWAP = WI( I )
WI( I ) = WI( I-1 )
WI( I-1 ) = WI( I-2 )
WI( I-2 ) = SWAP
END IF
70 CONTINUE
END IF
*
* ==== If there are only two shifts and both are
* . real, then use only one. ====
*
IF( KBOT-KS+1.EQ.2 ) THEN
IF( WI( KBOT ).EQ.ZERO ) THEN
IF( ABS( WR( KBOT )-H( KBOT, KBOT ) ).LT.
$ ABS( WR( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN
WR( KBOT-1 ) = WR( KBOT )
ELSE
WR( KBOT ) = WR( KBOT-1 )
END IF
END IF
END IF
*
* ==== Use up to NS of the the smallest magnatiude
* . shifts. If there aren't NS shifts available,
* . then use them all, possibly dropping one to
* . make the number of shifts even. ====
*
NS = MIN( NS, KBOT-KS+1 )
NS = NS - MOD( NS, 2 )
KS = KBOT - NS + 1
*
* ==== Small-bulge multi-shift QR sweep:
* . split workspace under the subdiagonal into
* . - a KDU-by-KDU work array U in the lower
* . left-hand-corner,
* . - a KDU-by-at-least-KDU-but-more-is-better
* . (KDU-by-NHo) horizontal work array WH along
* . the bottom edge,
* . - and an at-least-KDU-but-more-is-better-by-KDU
* . (NVE-by-KDU) vertical work WV arrow along
* . the left-hand-edge. ====
*
KDU = 3*NS - 3
KU = N - KDU + 1
KWH = KDU + 1
NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1
KWV = KDU + 4
NVE = N - KDU - KWV + 1
*
* ==== Small-bulge multi-shift QR sweep ====
*
CALL DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS,
$ WR( KS ), WI( KS ), H, LDH, ILOZ, IHIZ, Z,
$ LDZ, WORK, 3, H( KU, 1 ), LDH, NVE,
$ H( KWV, 1 ), LDH, NHO, H( KU, KWH ), LDH )
END IF
*
* ==== Note progress (or the lack of it). ====
*
IF( LD.GT.0 ) THEN
NDFL = 1
ELSE
NDFL = NDFL + 1
END IF
*
* ==== End of main loop ====
80 CONTINUE
*
* ==== Iteration limit exceeded. Set INFO to show where
* . the problem occurred and exit. ====
*
INFO = KBOT
90 CONTINUE
END IF
*
* ==== Return the optimal value of LWORK. ====
*
WORK( 1 ) = DBLE( LWKOPT )
*
* ==== End of DLAQR0 ====
*
END
SUBROUTINE DLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
DOUBLE PRECISION SI1, SI2, SR1, SR2
INTEGER LDH, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION H( LDH, * ), V( * )
* ..
*
* Given a 2-by-2 or 3-by-3 matrix H, DLAQR1 sets v to a
* scalar multiple of the first column of the product
*
* (*) K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I)
*
* scaling to avoid overflows and most underflows. It
* is assumed that either
*
* 1) sr1 = sr2 and si1 = -si2
* or
* 2) si1 = si2 = 0.
*
* This is useful for starting double implicit shift bulges
* in the QR algorithm.
*
*
* N (input) integer
* Order of the matrix H. N must be either 2 or 3.
*
* H (input) DOUBLE PRECISION array of dimension (LDH,N)
* The 2-by-2 or 3-by-3 matrix H in (*).
*
* LDH (input) integer
* The leading dimension of H as declared in
* the calling procedure. LDH.GE.N
*
* SR1 (input) DOUBLE PRECISION
* SI1 The shifts in (*).
* SR2
* SI2
*
* V (output) DOUBLE PRECISION array of dimension N
* A scalar multiple of the first column of the
* matrix K in (*).
*
* ================================================================
* Based on contributions by
* Karen Braman and Ralph Byers, Department of Mathematics,
* University of Kansas, USA
*
* ================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0d0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION H21S, H31S, S
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
IF( N.EQ.2 ) THEN
S = ABS( H( 1, 1 )-SR2 ) + ABS( SI2 ) + ABS( H( 2, 1 ) )
IF( S.EQ.ZERO ) THEN
V( 1 ) = ZERO
V( 2 ) = ZERO
ELSE
H21S = H( 2, 1 ) / S
V( 1 ) = H21S*H( 1, 2 ) + ( H( 1, 1 )-SR1 )*
$ ( ( H( 1, 1 )-SR2 ) / S ) - SI1*( SI2 / S )
V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-SR1-SR2 )
END IF
ELSE
S = ABS( H( 1, 1 )-SR2 ) + ABS( SI2 ) + ABS( H( 2, 1 ) ) +
$ ABS( H( 3, 1 ) )
IF( S.EQ.ZERO ) THEN
V( 1 ) = ZERO
V( 2 ) = ZERO
V( 3 ) = ZERO
ELSE
H21S = H( 2, 1 ) / S
H31S = H( 3, 1 ) / S
V( 1 ) = ( H( 1, 1 )-SR1 )*( ( H( 1, 1 )-SR2 ) / S ) -
$ SI1*( SI2 / S ) + H( 1, 2 )*H21S + H( 1, 3 )*H31S
V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-SR1-SR2 ) +
$ H( 2, 3 )*H31S
V( 3 ) = H31S*( H( 1, 1 )+H( 3, 3 )-SR1-SR2 ) +
$ H21S*H( 3, 2 )
END IF
END IF
END
SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
$ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T,
$ LDT, NV, WV, LDWV, WORK, LWORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
$ LDZ, LWORK, N, ND, NH, NS, NV, NW
LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ),
$ V( LDV, * ), WORK( * ), WV( LDWV, * ),
$ Z( LDZ, * )
* ..
*
* This subroutine is identical to DLAQR3 except that it avoids
* recursion by calling DLAHQR instead of DLAQR4.
*
*
* ******************************************************************
* Aggressive early deflation:
*
* This subroutine accepts as input an upper Hessenberg matrix
* H and performs an orthogonal similarity transformation
* designed to detect and deflate fully converged eigenvalues from
* a trailing principal submatrix. On output H has been over-
* written by a new Hessenberg matrix that is a perturbation of
* an orthogonal similarity transformation of H. It is to be
* hoped that the final version of H has many zero subdiagonal
* entries.
*
* ******************************************************************
* WANTT (input) LOGICAL
* If .TRUE., then the Hessenberg matrix H is fully updated
* so that the quasi-triangular Schur factor may be
* computed (in cooperation with the calling subroutine).
* If .FALSE., then only enough of H is updated to preserve
* the eigenvalues.
*
* WANTZ (input) LOGICAL
* If .TRUE., then the orthogonal matrix Z is updated so
* so that the orthogonal Schur factor may be computed
* (in cooperation with the calling subroutine).
* If .FALSE., then Z is not referenced.
*
* N (input) INTEGER
* The order of the matrix H and (if WANTZ is .TRUE.) the
* order of the orthogonal matrix Z.
*
* KTOP (input) INTEGER
* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.
* KBOT and KTOP together determine an isolated block
* along the diagonal of the Hessenberg matrix.
*
* KBOT (input) INTEGER
* It is assumed without a check that either
* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together
* determine an isolated block along the diagonal of the
* Hessenberg matrix.
*
* NW (input) INTEGER
* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).
*
* H (input/output) DOUBLE PRECISION array, dimension (LDH,N)
* On input the initial N-by-N section of H stores the
* Hessenberg matrix undergoing aggressive early deflation.
* On output H has been transformed by an orthogonal
* similarity transformation, perturbed, and the returned
* to Hessenberg form that (it is to be hoped) has some
* zero subdiagonal entries.
*
* LDH (input) integer
* Leading dimension of H just as declared in the calling
* subroutine. N .LE. LDH
*
* ILOZ (input) INTEGER
* IHIZ (input) INTEGER
* Specify the rows of Z to which transformations must be
* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.
*
* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI)
* IF WANTZ is .TRUE., then on output, the orthogonal
* similarity transformation mentioned above has been
* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.
* If WANTZ is .FALSE., then Z is unreferenced.
*
* LDZ (input) integer
* The leading dimension of Z just as declared in the
* calling subroutine. 1 .LE. LDZ.
*
* NS (output) integer
* The number of unconverged (ie approximate) eigenvalues
* returned in SR and SI that may be used as shifts by the
* calling subroutine.
*
* ND (output) integer
* The number of converged eigenvalues uncovered by this
* subroutine.
*
* SR (output) DOUBLE PRECISION array, dimension KBOT
* SI (output) DOUBLE PRECISION array, dimension KBOT
* On output, the real and imaginary parts of approximate
* eigenvalues that may be used for shifts are stored in
* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and
* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.
* The real and imaginary parts of converged eigenvalues
* are stored in SR(KBOT-ND+1) through SR(KBOT) and
* SI(KBOT-ND+1) through SI(KBOT), respectively.
*
* V (workspace) DOUBLE PRECISION array, dimension (LDV,NW)
* An NW-by-NW work array.
*
* LDV (input) integer scalar
* The leading dimension of V just as declared in the
* calling subroutine. NW .LE. LDV
*
* NH (input) integer scalar
* The number of columns of T. NH.GE.NW.
*
* T (workspace) DOUBLE PRECISION array, dimension (LDT,NW)
*
* LDT (input) integer
* The leading dimension of T just as declared in the
* calling subroutine. NW .LE. LDT
*
* NV (input) integer
* The number of rows of work array WV available for
* workspace. NV.GE.NW.
*
* WV (workspace) DOUBLE PRECISION array, dimension (LDWV,NW)
*
* LDWV (input) integer
* The leading dimension of W just as declared in the
* calling subroutine. NW .LE. LDV
*
* WORK (workspace) DOUBLE PRECISION array, dimension LWORK.
* On exit, WORK(1) is set to an estimate of the optimal value
* of LWORK for the given values of N, NW, KTOP and KBOT.
*
* LWORK (input) integer
* The dimension of the work array WORK. LWORK = 2*NW
* suffices, but greater efficiency may result from larger
* values of LWORK.
*
* If LWORK = -1, then a workspace query is assumed; DLAQR2
* only estimates the optimal workspace size for the given
* values of N, NW, KTOP and KBOT. The estimate is returned
* in WORK(1). No error message related to LWORK is issued
* by XERBLA. Neither H nor Z are accessed.
*
* ================================================================
* Based on contributions by
* Karen Braman and Ralph Byers, Department of Mathematics,
* University of Kansas, USA
*
* ================================================================
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S,
$ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP
INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL,
$ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2,
$ LWKOPT
LOGICAL BULGE, SORTED
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEHRD, DGEMM, DLABAD, DLACPY, DLAHQR,
$ DLANV2, DLARF, DLARFG, DLASET, DORGHR, DTREXC
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* ==== Estimate optimal workspace. ====
*
JW = MIN( NW, KBOT-KTOP+1 )
IF( JW.LE.2 ) THEN
LWKOPT = 1
ELSE
*
* ==== Workspace query call to DGEHRD ====
*
CALL DGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
LWK1 = INT( WORK( 1 ) )
*
* ==== Workspace query call to DORGHR ====
*
CALL DORGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
LWK2 = INT( WORK( 1 ) )
*
* ==== Optimal workspace ====
*
LWKOPT = JW + MAX( LWK1, LWK2 )
END IF
*
* ==== Quick return in case of workspace query. ====
*
IF( LWORK.EQ.-1 ) THEN
WORK( 1 ) = DBLE( LWKOPT )
RETURN
END IF
*
* ==== Nothing to do ...
* ... for an empty active block ... ====
NS = 0
ND = 0
IF( KTOP.GT.KBOT )
$ RETURN
* ... nor for an empty deflation window. ====
IF( NW.LT.1 )
$ RETURN
*
* ==== Machine constants ====
*
SAFMIN = DLAMCH( 'SAFE MINIMUM' )
SAFMAX = ONE / SAFMIN
CALL DLABAD( SAFMIN, SAFMAX )
ULP = DLAMCH( 'PRECISION' )
SMLNUM = SAFMIN*( DBLE( N ) / ULP )
*
* ==== Setup deflation window ====
*
JW = MIN( NW, KBOT-KTOP+1 )
KWTOP = KBOT - JW + 1
IF( KWTOP.EQ.KTOP ) THEN
S = ZERO
ELSE
S = H( KWTOP, KWTOP-1 )
END IF
*
IF( KBOT.EQ.KWTOP ) THEN
*
* ==== 1-by-1 deflation window: not much to do ====
*
SR( KWTOP ) = H( KWTOP, KWTOP )
SI( KWTOP ) = ZERO
NS = 1
ND = 0
IF( ABS( S ).LE.MAX( SMLNUM, ULP*ABS( H( KWTOP, KWTOP ) ) ) )
$ THEN
NS = 0
ND = 1
IF( KWTOP.GT.KTOP )
$ H( KWTOP, KWTOP-1 ) = ZERO
END IF
RETURN
END IF
*
* ==== Convert to spike-triangular form. (In case of a
* . rare QR failure, this routine continues to do
* . aggressive early deflation using that part of
* . the deflation window that converged using INFQR
* . here and there to keep track.) ====
*
CALL DLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
CALL DCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
*
CALL DLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
CALL DLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ),
$ SI( KWTOP ), 1, JW, V, LDV, INFQR )
*
* ==== DTREXC needs a clean margin near the diagonal ====
*
DO 10 J = 1, JW - 3
T( J+2, J ) = ZERO
T( J+3, J ) = ZERO
10 CONTINUE
IF( JW.GT.2 )
$ T( JW, JW-2 ) = ZERO
*
* ==== Deflation detection loop ====
*
NS = JW
ILST = INFQR + 1
20 CONTINUE
IF( ILST.LE.NS ) THEN
IF( NS.EQ.1 ) THEN
BULGE = .FALSE.
ELSE
BULGE = T( NS, NS-1 ).NE.ZERO
END IF
*
* ==== Small spike tip test for deflation ====
*
IF( .NOT.BULGE ) THEN
*
* ==== Real eigenvalue ====
*
FOO = ABS( T( NS, NS ) )
IF( FOO.EQ.ZERO )
$ FOO = ABS( S )
IF( ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN
*
* ==== Deflatable ====
*
NS = NS - 1
ELSE
*
* ==== Undeflatable. Move it up out of the way.
* . (DTREXC can not fail in this case.) ====
*
IFST = NS
CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
$ INFO )
ILST = ILST + 1
END IF
ELSE
*
* ==== Complex conjugate pair ====
*
FOO = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )*
$ SQRT( ABS( T( NS-1, NS ) ) )
IF( FOO.EQ.ZERO )
$ FOO = ABS( S )
IF( MAX( ABS( S*V( 1, NS ) ), ABS( S*V( 1, NS-1 ) ) ).LE.
$ MAX( SMLNUM, ULP*FOO ) ) THEN
*
* ==== Deflatable ====
*
NS = NS - 2
ELSE
*
* ==== Undflatable. Move them up out of the way.
* . Fortunately, DTREXC does the right thing with
* . ILST in case of a rare exchange failure. ====
*
IFST = NS
CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
$ INFO )
ILST = ILST + 2
END IF
END IF
*
* ==== End deflation detection loop ====
*
GO TO 20
END IF
*
* ==== Return to Hessenberg form ====
*
IF( NS.EQ.0 )
$ S = ZERO
*
IF( NS.LT.JW ) THEN
*
* ==== sorting diagonal blocks of T improves accuracy for
* . graded matrices. Bubble sort deals well with
* . exchange failures. ====
*
SORTED = .false.
I = NS + 1
30 CONTINUE
IF( SORTED )
$ GO TO 50
SORTED = .true.
*
KEND = I - 1
I = INFQR + 1
IF( I.EQ.NS ) THEN
K = I + 1
ELSE IF( T( I+1, I ).EQ.ZERO ) THEN
K = I + 1
ELSE
K = I + 2
END IF
40 CONTINUE
IF( K.LE.KEND ) THEN
IF( K.EQ.I+1 ) THEN
EVI = ABS( T( I, I ) )
ELSE
EVI = ABS( T( I, I ) ) + SQRT( ABS( T( I+1, I ) ) )*
$ SQRT( ABS( T( I, I+1 ) ) )
END IF
*
IF( K.EQ.KEND ) THEN
EVK = ABS( T( K, K ) )
ELSE IF( T( K+1, K ).EQ.ZERO ) THEN
EVK = ABS( T( K, K ) )
ELSE
EVK = ABS( T( K, K ) ) + SQRT( ABS( T( K+1, K ) ) )*
$ SQRT( ABS( T( K, K+1 ) ) )
END IF
*
IF( EVI.GE.EVK ) THEN
I = K
ELSE
SORTED = .false.
IFST = I
ILST = K
CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
$ INFO )
IF( INFO.EQ.0 ) THEN
I = ILST
ELSE
I = K
END IF
END IF
IF( I.EQ.KEND ) THEN
K = I + 1
ELSE IF( T( I+1, I ).EQ.ZERO ) THEN
K = I + 1
ELSE
K = I + 2
END IF
GO TO 40
END IF
GO TO 30
50 CONTINUE
END IF
*
* ==== Restore shift/eigenvalue array from T ====
*
I = JW
60 CONTINUE
IF( I.GE.INFQR+1 ) THEN
IF( I.EQ.INFQR+1 ) THEN
SR( KWTOP+I-1 ) = T( I, I )
SI( KWTOP+I-1 ) = ZERO
I = I - 1
ELSE IF( T( I, I-1 ).EQ.ZERO ) THEN
SR( KWTOP+I-1 ) = T( I, I )
SI( KWTOP+I-1 ) = ZERO
I = I - 1
ELSE
AA = T( I-1, I-1 )
CC = T( I, I-1 )
BB = T( I-1, I )
DD = T( I, I )
CALL DLANV2( AA, BB, CC, DD, SR( KWTOP+I-2 ),
$ SI( KWTOP+I-2 ), SR( KWTOP+I-1 ),
$ SI( KWTOP+I-1 ), CS, SN )
I = I - 2
END IF
GO TO 60
END IF
*
IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN
IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
*
* ==== Reflect spike back into lower triangle ====
*
CALL DCOPY( NS, V, LDV, WORK, 1 )
BETA = WORK( 1 )
CALL DLARFG( NS, BETA, WORK( 2 ), 1, TAU )
WORK( 1 ) = ONE
*
CALL DLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )
*
CALL DLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT,
$ WORK( JW+1 ) )
CALL DLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT,
$ WORK( JW+1 ) )
CALL DLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV,
$ WORK( JW+1 ) )
*
CALL DGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
$ LWORK-JW, INFO )
END IF
*
* ==== Copy updated reduced window into place ====
*
IF( KWTOP.GT.1 )
$ H( KWTOP, KWTOP-1 ) = S*V( 1, 1 )
CALL DLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH )
CALL DCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ),
$ LDH+1 )
*
* ==== Accumulate orthogonal matrix in order update
* . H and Z, if requested. (A modified version
* . of DORGHR that accumulates block Householder
* . transformations into V directly might be
* . marginally more efficient than the following.) ====
*
IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
CALL DORGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
$ LWORK-JW, INFO )
CALL DGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO,
$ WV, LDWV )
CALL DLACPY( 'A', JW, NS, WV, LDWV, V, LDV )
END IF
*
* ==== Update vertical slab in H ====
*
IF( WANTT ) THEN
LTOP = 1
ELSE
LTOP = KTOP
END IF
DO 70 KROW = LTOP, KWTOP - 1, NV
KLN = MIN( NV, KWTOP-KROW )
CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
$ LDH, V, LDV, ZERO, WV, LDWV )
CALL DLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH )
70 CONTINUE
*
* ==== Update horizontal slab in H ====
*
IF( WANTT ) THEN
DO 80 KCOL = KBOT + 1, N, NH
KLN = MIN( NH, N-KCOL+1 )
CALL DGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV,
$ H( KWTOP, KCOL ), LDH, ZERO, T, LDT )
CALL DLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ),
$ LDH )
80 CONTINUE
END IF
*
* ==== Update vertical slab in Z ====
*
IF( WANTZ ) THEN
DO 90 KROW = ILOZ, IHIZ, NV
KLN = MIN( NV, IHIZ-KROW+1 )
CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
$ LDZ, V, LDV, ZERO, WV, LDWV )
CALL DLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ),
$ LDZ )
90 CONTINUE
END IF
END IF
*
* ==== Return the number of deflations ... ====
*
ND = JW - NS
*
* ==== ... and the number of shifts. (Subtracting
* . INFQR from the spike length takes care
* . of the case of a rare QR failure while
* . calculating eigenvalues of the deflation
* . window.) ====
*
NS = NS - INFQR
*
* ==== Return optimal workspace. ====
*
WORK( 1 ) = DBLE( LWKOPT )
*
* ==== End of DLAQR2 ====
*
END
SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
$ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T,
$ LDT, NV, WV, LDWV, WORK, LWORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
$ LDZ, LWORK, N, ND, NH, NS, NV, NW
LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ),
$ V( LDV, * ), WORK( * ), WV( LDWV, * ),
$ Z( LDZ, * )
* ..
*
* ******************************************************************
* Aggressive early deflation:
*
* This subroutine accepts as input an upper Hessenberg matrix
* H and performs an orthogonal similarity transformation
* designed to detect and deflate fully converged eigenvalues from
* a trailing principal submatrix. On output H has been over-
* written by a new Hessenberg matrix that is a perturbation of
* an orthogonal similarity transformation of H. It is to be
* hoped that the final version of H has many zero subdiagonal
* entries.
*
* ******************************************************************
* WANTT (input) LOGICAL
* If .TRUE., then the Hessenberg matrix H is fully updated
* so that the quasi-triangular Schur factor may be
* computed (in cooperation with the calling subroutine).
* If .FALSE., then only enough of H is updated to preserve
* the eigenvalues.
*
* WANTZ (input) LOGICAL
* If .TRUE., then the orthogonal matrix Z is updated so
* so that the orthogonal Schur factor may be computed
* (in cooperation with the calling subroutine).
* If .FALSE., then Z is not referenced.
*
* N (input) INTEGER
* The order of the matrix H and (if WANTZ is .TRUE.) the
* order of the orthogonal matrix Z.
*
* KTOP (input) INTEGER
* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.
* KBOT and KTOP together determine an isolated block
* along the diagonal of the Hessenberg matrix.
*
* KBOT (input) INTEGER
* It is assumed without a check that either
* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together
* determine an isolated block along the diagonal of the
* Hessenberg matrix.
*
* NW (input) INTEGER
* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).
*
* H (input/output) DOUBLE PRECISION array, dimension (LDH,N)
* On input the initial N-by-N section of H stores the
* Hessenberg matrix undergoing aggressive early deflation.
* On output H has been transformed by an orthogonal
* similarity transformation, perturbed, and the returned
* to Hessenberg form that (it is to be hoped) has some
* zero subdiagonal entries.
*
* LDH (input) integer
* Leading dimension of H just as declared in the calling
* subroutine. N .LE. LDH
*
* ILOZ (input) INTEGER
* IHIZ (input) INTEGER
* Specify the rows of Z to which transformations must be
* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.
*
* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI)
* IF WANTZ is .TRUE., then on output, the orthogonal
* similarity transformation mentioned above has been
* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.
* If WANTZ is .FALSE., then Z is unreferenced.
*
* LDZ (input) integer
* The leading dimension of Z just as declared in the
* calling subroutine. 1 .LE. LDZ.
*
* NS (output) integer
* The number of unconverged (ie approximate) eigenvalues
* returned in SR and SI that may be used as shifts by the
* calling subroutine.
*
* ND (output) integer
* The number of converged eigenvalues uncovered by this
* subroutine.
*
* SR (output) DOUBLE PRECISION array, dimension KBOT
* SI (output) DOUBLE PRECISION array, dimension KBOT
* On output, the real and imaginary parts of approximate
* eigenvalues that may be used for shifts are stored in
* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and
* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.
* The real and imaginary parts of converged eigenvalues
* are stored in SR(KBOT-ND+1) through SR(KBOT) and
* SI(KBOT-ND+1) through SI(KBOT), respectively.
*
* V (workspace) DOUBLE PRECISION array, dimension (LDV,NW)
* An NW-by-NW work array.
*
* LDV (input) integer scalar
* The leading dimension of V just as declared in the
* calling subroutine. NW .LE. LDV
*
* NH (input) integer scalar
* The number of columns of T. NH.GE.NW.
*
* T (workspace) DOUBLE PRECISION array, dimension (LDT,NW)
*
* LDT (input) integer
* The leading dimension of T just as declared in the
* calling subroutine. NW .LE. LDT
*
* NV (input) integer
* The number of rows of work array WV available for
* workspace. NV.GE.NW.
*
* WV (workspace) DOUBLE PRECISION array, dimension (LDWV,NW)
*
* LDWV (input) integer
* The leading dimension of W just as declared in the
* calling subroutine. NW .LE. LDV
*
* WORK (workspace) DOUBLE PRECISION array, dimension LWORK.
* On exit, WORK(1) is set to an estimate of the optimal value
* of LWORK for the given values of N, NW, KTOP and KBOT.
*
* LWORK (input) integer
* The dimension of the work array WORK. LWORK = 2*NW
* suffices, but greater efficiency may result from larger
* values of LWORK.
*
* If LWORK = -1, then a workspace query is assumed; DLAQR3
* only estimates the optimal workspace size for the given
* values of N, NW, KTOP and KBOT. The estimate is returned
* in WORK(1). No error message related to LWORK is issued
* by XERBLA. Neither H nor Z are accessed.
*
* ================================================================
* Based on contributions by
* Karen Braman and Ralph Byers, Department of Mathematics,
* University of Kansas, USA
*
* ==================================================================
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S,
$ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP
INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL,
$ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3,
$ LWKOPT, NMIN
LOGICAL BULGE, SORTED
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
INTEGER ILAENV
EXTERNAL DLAMCH, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEHRD, DGEMM, DLABAD, DLACPY, DLAHQR,
$ DLANV2, DLAQR4, DLARF, DLARFG, DLASET, DORGHR,
$ DTREXC
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* ==== Estimate optimal workspace. ====
*
JW = MIN( NW, KBOT-KTOP+1 )
IF( JW.LE.2 ) THEN
LWKOPT = 1
ELSE
*
* ==== Workspace query call to DGEHRD ====
*
CALL DGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
LWK1 = INT( WORK( 1 ) )
*
* ==== Workspace query call to DORGHR ====
*
CALL DORGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
LWK2 = INT( WORK( 1 ) )
*
* ==== Workspace query call to DLAQR4 ====
*
CALL DLAQR4( .true., .true., JW, 1, JW, T, LDT, SR, SI, 1, JW,
$ V, LDV, WORK, -1, INFQR )
LWK3 = INT( WORK( 1 ) )
*
* ==== Optimal workspace ====
*
LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 )
END IF
*
* ==== Quick return in case of workspace query. ====
*
IF( LWORK.EQ.-1 ) THEN
WORK( 1 ) = DBLE( LWKOPT )
RETURN
END IF
*
* ==== Nothing to do ...
* ... for an empty active block ... ====
NS = 0
ND = 0
IF( KTOP.GT.KBOT )
$ RETURN
* ... nor for an empty deflation window. ====
IF( NW.LT.1 )
$ RETURN
*
* ==== Machine constants ====
*
SAFMIN = DLAMCH( 'SAFE MINIMUM' )
SAFMAX = ONE / SAFMIN
CALL DLABAD( SAFMIN, SAFMAX )
ULP = DLAMCH( 'PRECISION' )
SMLNUM = SAFMIN*( DBLE( N ) / ULP )
*
* ==== Setup deflation window ====
*
JW = MIN( NW, KBOT-KTOP+1 )
KWTOP = KBOT - JW + 1
IF( KWTOP.EQ.KTOP ) THEN
S = ZERO
ELSE
S = H( KWTOP, KWTOP-1 )
END IF
*
IF( KBOT.EQ.KWTOP ) THEN
*
* ==== 1-by-1 deflation window: not much to do ====
*
SR( KWTOP ) = H( KWTOP, KWTOP )
SI( KWTOP ) = ZERO
NS = 1
ND = 0
IF( ABS( S ).LE.MAX( SMLNUM, ULP*ABS( H( KWTOP, KWTOP ) ) ) )
$ THEN
NS = 0
ND = 1
IF( KWTOP.GT.KTOP )
$ H( KWTOP, KWTOP-1 ) = ZERO
END IF
RETURN
END IF
*
* ==== Convert to spike-triangular form. (In case of a
* . rare QR failure, this routine continues to do
* . aggressive early deflation using that part of
* . the deflation window that converged using INFQR
* . here and there to keep track.) ====
*
CALL DLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
CALL DCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
*
CALL DLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
NMIN = ILAENV( 12, 'DLAQR3', 'SV', JW, 1, JW, LWORK )
IF( JW.GT.NMIN ) THEN
CALL DLAQR4( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ),
$ SI( KWTOP ), 1, JW, V, LDV, WORK, LWORK, INFQR )
ELSE
CALL DLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ),
$ SI( KWTOP ), 1, JW, V, LDV, INFQR )
END IF
*
* ==== DTREXC needs a clean margin near the diagonal ====
*
DO 10 J = 1, JW - 3
T( J+2, J ) = ZERO
T( J+3, J ) = ZERO
10 CONTINUE
IF( JW.GT.2 )
$ T( JW, JW-2 ) = ZERO
*
* ==== Deflation detection loop ====
*
NS = JW
ILST = INFQR + 1
20 CONTINUE
IF( ILST.LE.NS ) THEN
IF( NS.EQ.1 ) THEN
BULGE = .FALSE.
ELSE
BULGE = T( NS, NS-1 ).NE.ZERO
END IF
*
* ==== Small spike tip test for deflation ====
*
IF( .NOT.BULGE ) THEN
*
* ==== Real eigenvalue ====
*
FOO = ABS( T( NS, NS ) )
IF( FOO.EQ.ZERO )
$ FOO = ABS( S )
IF( ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN
*
* ==== Deflatable ====
*
NS = NS - 1
ELSE
*
* ==== Undeflatable. Move it up out of the way.
* . (DTREXC can not fail in this case.) ====
*
IFST = NS
CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
$ INFO )
ILST = ILST + 1
END IF
ELSE
*
* ==== Complex conjugate pair ====
*
FOO = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )*
$ SQRT( ABS( T( NS-1, NS ) ) )
IF( FOO.EQ.ZERO )
$ FOO = ABS( S )
IF( MAX( ABS( S*V( 1, NS ) ), ABS( S*V( 1, NS-1 ) ) ).LE.
$ MAX( SMLNUM, ULP*FOO ) ) THEN
*
* ==== Deflatable ====
*
NS = NS - 2
ELSE
*
* ==== Undflatable. Move them up out of the way.
* . Fortunately, DTREXC does the right thing with
* . ILST in case of a rare exchange failure. ====
*
IFST = NS
CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
$ INFO )
ILST = ILST + 2
END IF
END IF
*
* ==== End deflation detection loop ====
*
GO TO 20
END IF
*
* ==== Return to Hessenberg form ====
*
IF( NS.EQ.0 )
$ S = ZERO
*
IF( NS.LT.JW ) THEN
*
* ==== sorting diagonal blocks of T improves accuracy for
* . graded matrices. Bubble sort deals well with
* . exchange failures. ====
*
SORTED = .false.
I = NS + 1
30 CONTINUE
IF( SORTED )
$ GO TO 50
SORTED = .true.
*
KEND = I - 1
I = INFQR + 1
IF( I.EQ.NS ) THEN
K = I + 1
ELSE IF( T( I+1, I ).EQ.ZERO ) THEN
K = I + 1
ELSE
K = I + 2
END IF
40 CONTINUE
IF( K.LE.KEND ) THEN
IF( K.EQ.I+1 ) THEN
EVI = ABS( T( I, I ) )
ELSE
EVI = ABS( T( I, I ) ) + SQRT( ABS( T( I+1, I ) ) )*
$ SQRT( ABS( T( I, I+1 ) ) )
END IF
*
IF( K.EQ.KEND ) THEN
EVK = ABS( T( K, K ) )
ELSE IF( T( K+1, K ).EQ.ZERO ) THEN
EVK = ABS( T( K, K ) )
ELSE
EVK = ABS( T( K, K ) ) + SQRT( ABS( T( K+1, K ) ) )*
$ SQRT( ABS( T( K, K+1 ) ) )
END IF
*
IF( EVI.GE.EVK ) THEN
I = K
ELSE
SORTED = .false.
IFST = I
ILST = K
CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
$ INFO )
IF( INFO.EQ.0 ) THEN
I = ILST
ELSE
I = K
END IF
END IF
IF( I.EQ.KEND ) THEN
K = I + 1
ELSE IF( T( I+1, I ).EQ.ZERO ) THEN
K = I + 1
ELSE
K = I + 2
END IF
GO TO 40
END IF
GO TO 30
50 CONTINUE
END IF
*
* ==== Restore shift/eigenvalue array from T ====
*
I = JW
60 CONTINUE
IF( I.GE.INFQR+1 ) THEN
IF( I.EQ.INFQR+1 ) THEN
SR( KWTOP+I-1 ) = T( I, I )
SI( KWTOP+I-1 ) = ZERO
I = I - 1
ELSE IF( T( I, I-1 ).EQ.ZERO ) THEN
SR( KWTOP+I-1 ) = T( I, I )
SI( KWTOP+I-1 ) = ZERO
I = I - 1
ELSE
AA = T( I-1, I-1 )
CC = T( I, I-1 )
BB = T( I-1, I )
DD = T( I, I )
CALL DLANV2( AA, BB, CC, DD, SR( KWTOP+I-2 ),
$ SI( KWTOP+I-2 ), SR( KWTOP+I-1 ),
$ SI( KWTOP+I-1 ), CS, SN )
I = I - 2
END IF
GO TO 60
END IF
*
IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN
IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
*
* ==== Reflect spike back into lower triangle ====
*
CALL DCOPY( NS, V, LDV, WORK, 1 )
BETA = WORK( 1 )
CALL DLARFG( NS, BETA, WORK( 2 ), 1, TAU )
WORK( 1 ) = ONE
*
CALL DLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )
*
CALL DLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT,
$ WORK( JW+1 ) )
CALL DLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT,
$ WORK( JW+1 ) )
CALL DLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV,
$ WORK( JW+1 ) )
*
CALL DGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
$ LWORK-JW, INFO )
END IF
*
* ==== Copy updated reduced window into place ====
*
IF( KWTOP.GT.1 )
$ H( KWTOP, KWTOP-1 ) = S*V( 1, 1 )
CALL DLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH )
CALL DCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ),
$ LDH+1 )
*
* ==== Accumulate orthogonal matrix in order update
* . H and Z, if requested. (A modified version
* . of DORGHR that accumulates block Householder
* . transformations into V directly might be
* . marginally more efficient than the following.) ====
*
IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
CALL DORGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
$ LWORK-JW, INFO )
CALL DGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO,
$ WV, LDWV )
CALL DLACPY( 'A', JW, NS, WV, LDWV, V, LDV )
END IF
*
* ==== Update vertical slab in H ====
*
IF( WANTT ) THEN
LTOP = 1
ELSE
LTOP = KTOP
END IF
DO 70 KROW = LTOP, KWTOP - 1, NV
KLN = MIN( NV, KWTOP-KROW )
CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
$ LDH, V, LDV, ZERO, WV, LDWV )
CALL DLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH )
70 CONTINUE
*
* ==== Update horizontal slab in H ====
*
IF( WANTT ) THEN
DO 80 KCOL = KBOT + 1, N, NH
KLN = MIN( NH, N-KCOL+1 )
CALL DGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV,
$ H( KWTOP, KCOL ), LDH, ZERO, T, LDT )
CALL DLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ),
$ LDH )
80 CONTINUE
END IF
*
* ==== Update vertical slab in Z ====
*
IF( WANTZ ) THEN
DO 90 KROW = ILOZ, IHIZ, NV
KLN = MIN( NV, IHIZ-KROW+1 )
CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
$ LDZ, V, LDV, ZERO, WV, LDWV )
CALL DLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ),
$ LDZ )
90 CONTINUE
END IF
END IF
*
* ==== Return the number of deflations ... ====
*
ND = JW - NS
*
* ==== ... and the number of shifts. (Subtracting
* . INFQR from the spike length takes care
* . of the case of a rare QR failure while
* . calculating eigenvalues of the deflation
* . window.) ====
*
NS = NS - INFQR
*
* ==== Return optimal workspace. ====
*
WORK( 1 ) = DBLE( LWKOPT )
*
* ==== End of DLAQR3 ====
*
END
SUBROUTINE DLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
$ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ),
$ Z( LDZ, * )
* ..
*
* This subroutine implements one level of recursion for DLAQR0.
* It is a complete implementation of the small bulge multi-shift
* QR algorithm. It may be called by DLAQR0 and, for large enough
* deflation window size, it may be called by DLAQR3. This
* subroutine is identical to DLAQR0 except that it calls DLAQR2
* instead of DLAQR3.
*
* Purpose
* =======
*
* DLAQR4 computes the eigenvalues of a Hessenberg matrix H
* and, optionally, the matrices T and Z from the Schur decomposition
* H = Z T Z**T, where T is an upper quasi-triangular matrix (the
* Schur form), and Z is the orthogonal matrix of Schur vectors.
*
* Optionally Z may be postmultiplied into an input orthogonal
* matrix Q so that this routine can give the Schur factorization
* of a matrix A which has been reduced to the Hessenberg form H
* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.
*
* Arguments
* =========
*
* WANTT (input) LOGICAL
* = .TRUE. : the full Schur form T is required;
* = .FALSE.: only eigenvalues are required.
*
* WANTZ (input) LOGICAL
* = .TRUE. : the matrix of Schur vectors Z is required;
* = .FALSE.: Schur vectors are not required.
*
* N (input) INTEGER
* The order of the matrix H. N .GE. 0.
*
* 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 and, if ILO.GT.1,
* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a
* previous call to DGEBAL, and then passed to DGEHRD when the
* matrix output by DGEBAL is reduced to Hessenberg form.
* Otherwise, ILO and IHI should be set to 1 and N,
* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
* If N = 0, then ILO = 1 and IHI = 0.
*
* H (input/output) DOUBLE PRECISION array, dimension (LDH,N)
* On entry, the upper Hessenberg matrix H.
* On exit, if INFO = 0 and WANTT is .TRUE., then H contains
* the upper quasi-triangular matrix T from the Schur
* decomposition (the Schur form); 2-by-2 diagonal blocks
* (corresponding to complex conjugate pairs of eigenvalues)
* are returned in standard form, with H(i,i) = H(i+1,i+1)
* and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is
* .FALSE., then the contents of H are unspecified on exit.
* (The output value of H when INFO.GT.0 is given under the
* description of INFO below.)
*
* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and
* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.
*
* LDH (input) INTEGER
* The leading dimension of the array H. LDH .GE. max(1,N).
*
* WR (output) DOUBLE PRECISION array, dimension (IHI)
* WI (output) DOUBLE PRECISION array, dimension (IHI)
* The real and imaginary parts, respectively, of the computed
* eigenvalues of H(ILO:IHI,ILO:IHI) are stored WR(ILO:IHI)
* and WI(ILO:IHI). If two eigenvalues are computed as a
* complex conjugate pair, they are stored in consecutive
* elements of WR and WI, say the i-th and (i+1)th, with
* WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then
* the eigenvalues are stored in the same order as on the
* diagonal of the Schur form returned in H, with
* WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal
* block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and
* WI(i+1) = -WI(i).
*
* ILOZ (input) INTEGER
* IHIZ (input) INTEGER
* Specify the rows of Z to which transformations must be
* applied if WANTZ is .TRUE..
* 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.
*
* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI)
* If WANTZ is .FALSE., then Z is not referenced.
* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is
* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the
* orthogonal Schur factor of H(ILO:IHI,ILO:IHI).
* (The output value of Z when INFO.GT.0 is given under
* the description of INFO below.)
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. if WANTZ is .TRUE.
* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.
*
* WORK (workspace/output) DOUBLE PRECISION array, dimension LWORK
* On exit, if LWORK = -1, WORK(1) returns an estimate of
* the optimal value for LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK. LWORK .GE. max(1,N)
* is sufficient, but LWORK typically as large as 6*N may
* be required for optimal performance. A workspace query
* to determine the optimal workspace size is recommended.
*
* If LWORK = -1, then DLAQR4 does a workspace query.
* In this case, DLAQR4 checks the input parameters and
* estimates the optimal workspace size for the given
* values of N, ILO and IHI. The estimate is returned
* in WORK(1). No error message related to LWORK is
* issued by XERBLA. Neither H nor Z are accessed.
*
*
* INFO (output) INTEGER
* = 0: successful exit
* .GT. 0: if INFO = i, DLAQR4 failed to compute all of
* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
* and WI contain those eigenvalues which have been
* successfully computed. (Failures are rare.)
*
* If INFO .GT. 0 and WANT is .FALSE., then on exit,
* the remaining unconverged eigenvalues are the eigen-
* values of the upper Hessenberg matrix rows and
* columns ILO through INFO of the final, output
* value of H.
*
* If INFO .GT. 0 and WANTT is .TRUE., then on exit
*
* (*) (initial value of H)*U = U*(final value of H)
*
* where U is an orthogonal matrix. The final
* value of H is upper Hessenberg and quasi-triangular
* in rows and columns INFO+1 through IHI.
*
* If INFO .GT. 0 and WANTZ is .TRUE., then on exit
*
* (final value of Z(ILO:IHI,ILOZ:IHIZ)
* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U
*
* where U is the orthogonal matrix in (*) (regard-
* less of the value of WANTT.)
*
* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not
* accessed.
*
* ================================================================
* Based on contributions by
* Karen Braman and Ralph Byers, Department of Mathematics,
* University of Kansas, USA
*
* ================================================================
* References:
* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
* Performance, SIAM Journal of Matrix Analysis, volume 23, pages
* 929--947, 2002.
*
* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
* Algorithm Part II: Aggressive Early Deflation, SIAM Journal
* of Matrix Analysis, volume 23, pages 948--973, 2002.
*
* ================================================================
* .. Parameters ..
*
* ==== Matrices of order NTINY or smaller must be processed by
* . DLAHQR because of insufficient subdiagonal scratch space.
* . (This is a hard limit.) ====
*
* ==== Exceptional deflation windows: try to cure rare
* . slow convergence by increasing the size of the
* . deflation window after KEXNW iterations. =====
*
* ==== Exceptional shifts: try to cure rare slow convergence
* . with ad-hoc exceptional shifts every KEXSH iterations.
* . The constants WILK1 and WILK2 are used to form the
* . exceptional shifts. ====
*
INTEGER NTINY
PARAMETER ( NTINY = 11 )
INTEGER KEXNW, KEXSH
PARAMETER ( KEXNW = 5, KEXSH = 6 )
DOUBLE PRECISION WILK1, WILK2
PARAMETER ( WILK1 = 0.75d0, WILK2 = -0.4375d0 )
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION AA, BB, CC, CS, DD, SN, SS, SWAP
INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS,
$ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS,
$ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX,
$ NSR, NVE, NW, NWMAX, NWR
LOGICAL NWINC, SORTED
CHARACTER JBCMPZ*2
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Local Arrays ..
DOUBLE PRECISION ZDUM( 1, 1 )
* ..
* .. External Subroutines ..
EXTERNAL DLACPY, DLAHQR, DLANV2, DLAQR2, DLAQR5
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD
* ..
* .. Executable Statements ..
INFO = 0
*
* ==== Quick return for N = 0: nothing to do. ====
*
IF( N.EQ.0 ) THEN
WORK( 1 ) = ONE
RETURN
END IF
*
* ==== Set up job flags for ILAENV. ====
*
IF( WANTT ) THEN
JBCMPZ( 1: 1 ) = 'S'
ELSE
JBCMPZ( 1: 1 ) = 'E'
END IF
IF( WANTZ ) THEN
JBCMPZ( 2: 2 ) = 'V'
ELSE
JBCMPZ( 2: 2 ) = 'N'
END IF
*
* ==== Tiny matrices must use DLAHQR. ====
*
IF( N.LE.NTINY ) THEN
*
* ==== Estimate optimal workspace. ====
*
LWKOPT = 1
IF( LWORK.NE.-1 )
$ CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
$ ILOZ, IHIZ, Z, LDZ, INFO )
ELSE
*
* ==== Use small bulge multi-shift QR with aggressive early
* . deflation on larger-than-tiny matrices. ====
*
* ==== Hope for the best. ====
*
INFO = 0
*
* ==== NWR = recommended deflation window size. At this
* . point, N .GT. NTINY = 11, so there is enough
* . subdiagonal workspace for NWR.GE.2 as required.
* . (In fact, there is enough subdiagonal space for
* . NWR.GE.3.) ====
*
NWR = ILAENV( 13, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
NWR = MAX( 2, NWR )
NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR )
NW = NWR
*
* ==== NSR = recommended number of simultaneous shifts.
* . At this point N .GT. NTINY = 11, so there is at
* . enough subdiagonal workspace for NSR to be even
* . and greater than or equal to two as required. ====
*
NSR = ILAENV( 15, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO )
NSR = MAX( 2, NSR-MOD( NSR, 2 ) )
*
* ==== Estimate optimal workspace ====
*
* ==== Workspace query call to DLAQR2 ====
*
CALL DLAQR2( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ,
$ IHIZ, Z, LDZ, LS, LD, WR, WI, H, LDH, N, H, LDH,
$ N, H, LDH, WORK, -1 )
*
* ==== Optimal workspace = MAX(DLAQR5, DLAQR2) ====
*
LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) )
*
* ==== Quick return in case of workspace query. ====
*
IF( LWORK.EQ.-1 ) THEN
WORK( 1 ) = DBLE( LWKOPT )
RETURN
END IF
*
* ==== DLAHQR/DLAQR0 crossover point ====
*
NMIN = ILAENV( 12, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
NMIN = MAX( NTINY, NMIN )
*
* ==== Nibble crossover point ====
*
NIBBLE = ILAENV( 14, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
NIBBLE = MAX( 0, NIBBLE )
*
* ==== Accumulate reflections during ttswp? Use block
* . 2-by-2 structure during matrix-matrix multiply? ====
*
KACC22 = ILAENV( 16, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
KACC22 = MAX( 0, KACC22 )
KACC22 = MIN( 2, KACC22 )
*
* ==== NWMAX = the largest possible deflation window for
* . which there is sufficient workspace. ====
*
NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 )
*
* ==== NSMAX = the Largest number of simultaneous shifts
* . for which there is sufficient workspace. ====
*
NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 )
NSMAX = NSMAX - MOD( NSMAX, 2 )
*
* ==== NDFL: an iteration count restarted at deflation. ====
*
NDFL = 1
*
* ==== ITMAX = iteration limit ====
*
ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) )
*
* ==== Last row and column in the active block ====
*
KBOT = IHI
*
* ==== Main Loop ====
*
DO 80 IT = 1, ITMAX
*
* ==== Done when KBOT falls below ILO ====
*
IF( KBOT.LT.ILO )
$ GO TO 90
*
* ==== Locate active block ====
*
DO 10 K = KBOT, ILO + 1, -1
IF( H( K, K-1 ).EQ.ZERO )
$ GO TO 20
10 CONTINUE
K = ILO
20 CONTINUE
KTOP = K
*
* ==== Select deflation window size ====
*
NH = KBOT - KTOP + 1
IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN
*
* ==== Typical deflation window. If possible and
* . advisable, nibble the entire active block.
* . If not, use size NWR or NWR+1 depending upon
* . which has the smaller corresponding subdiagonal
* . entry (a heuristic). ====
*
NWINC = .TRUE.
IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN
NW = NH
ELSE
NW = MIN( NWR, NH, NWMAX )
IF( NW.LT.NWMAX ) THEN
IF( NW.GE.NH-1 ) THEN
NW = NH
ELSE
KWTOP = KBOT - NW + 1
IF( ABS( H( KWTOP, KWTOP-1 ) ).GT.
$ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1
END IF
END IF
END IF
ELSE
*
* ==== Exceptional deflation window. If there have
* . been no deflations in KEXNW or more iterations,
* . then vary the deflation window size. At first,
* . because, larger windows are, in general, more
* . powerful than smaller ones, rapidly increase the
* . window up to the maximum reasonable and possible.
* . Then maybe try a slightly smaller window. ====
*
IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN
NW = MIN( NWMAX, NH, 2*NW )
ELSE
NWINC = .FALSE.
IF( NW.EQ.NH .AND. NH.GT.2 )
$ NW = NH - 1
END IF
END IF
*
* ==== Aggressive early deflation:
* . split workspace under the subdiagonal into
* . - an nw-by-nw work array V in the lower
* . left-hand-corner,
* . - an NW-by-at-least-NW-but-more-is-better
* . (NW-by-NHO) horizontal work array along
* . the bottom edge,
* . - an at-least-NW-but-more-is-better (NHV-by-NW)
* . vertical work array along the left-hand-edge.
* . ====
*
KV = N - NW + 1
KT = NW + 1
NHO = ( N-NW-1 ) - KT + 1
KWV = NW + 2
NVE = ( N-NW ) - KWV + 1
*
* ==== Aggressive early deflation ====
*
CALL DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
$ IHIZ, Z, LDZ, LS, LD, WR, WI, H( KV, 1 ), LDH,
$ NHO, H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH,
$ WORK, LWORK )
*
* ==== Adjust KBOT accounting for new deflations. ====
*
KBOT = KBOT - LD
*
* ==== KS points to the shifts. ====
*
KS = KBOT - LS + 1
*
* ==== Skip an expensive QR sweep if there is a (partly
* . heuristic) reason to expect that many eigenvalues
* . will deflate without it. Here, the QR sweep is
* . skipped if many eigenvalues have just been deflated
* . or if the remaining active block is small.
*
IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT-
$ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN
*
* ==== NS = nominal number of simultaneous shifts.
* . This may be lowered (slightly) if DLAQR2
* . did not provide that many shifts. ====
*
NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) )
NS = NS - MOD( NS, 2 )
*
* ==== If there have been no deflations
* . in a multiple of KEXSH iterations,
* . then try exceptional shifts.
* . Otherwise use shifts provided by
* . DLAQR2 above or from the eigenvalues
* . of a trailing principal submatrix. ====
*
IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN
KS = KBOT - NS + 1
DO 30 I = KBOT, MAX( KS+1, KTOP+2 ), -2
SS = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) )
AA = WILK1*SS + H( I, I )
BB = SS
CC = WILK2*SS
DD = AA
CALL DLANV2( AA, BB, CC, DD, WR( I-1 ), WI( I-1 ),
$ WR( I ), WI( I ), CS, SN )
30 CONTINUE
IF( KS.EQ.KTOP ) THEN
WR( KS+1 ) = H( KS+1, KS+1 )
WI( KS+1 ) = ZERO
WR( KS ) = WR( KS+1 )
WI( KS ) = WI( KS+1 )
END IF
ELSE
*
* ==== Got NS/2 or fewer shifts? Use DLAHQR
* . on a trailing principal submatrix to
* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9,
* . there is enough space below the subdiagonal
* . to fit an NS-by-NS scratch array.) ====
*
IF( KBOT-KS+1.LE.NS / 2 ) THEN
KS = KBOT - NS + 1
KT = N - NS + 1
CALL DLACPY( 'A', NS, NS, H( KS, KS ), LDH,
$ H( KT, 1 ), LDH )
CALL DLAHQR( .false., .false., NS, 1, NS,
$ H( KT, 1 ), LDH, WR( KS ), WI( KS ),
$ 1, 1, ZDUM, 1, INF )
KS = KS + INF
*
* ==== In case of a rare QR failure use
* . eigenvalues of the trailing 2-by-2
* . principal submatrix. ====
*
IF( KS.GE.KBOT ) THEN
AA = H( KBOT-1, KBOT-1 )
CC = H( KBOT, KBOT-1 )
BB = H( KBOT-1, KBOT )
DD = H( KBOT, KBOT )
CALL DLANV2( AA, BB, CC, DD, WR( KBOT-1 ),
$ WI( KBOT-1 ), WR( KBOT ),
$ WI( KBOT ), CS, SN )
KS = KBOT - 1
END IF
END IF
*
IF( KBOT-KS+1.GT.NS ) THEN
*
* ==== Sort the shifts (Helps a little)
* . Bubble sort keeps complex conjugate
* . pairs together. ====
*
SORTED = .false.
DO 50 K = KBOT, KS + 1, -1
IF( SORTED )
$ GO TO 60
SORTED = .true.
DO 40 I = KS, K - 1
IF( ABS( WR( I ) )+ABS( WI( I ) ).LT.
$ ABS( WR( I+1 ) )+ABS( WI( I+1 ) ) ) THEN
SORTED = .false.
*
SWAP = WR( I )
WR( I ) = WR( I+1 )
WR( I+1 ) = SWAP
*
SWAP = WI( I )
WI( I ) = WI( I+1 )
WI( I+1 ) = SWAP
END IF
40 CONTINUE
50 CONTINUE
60 CONTINUE
END IF
*
* ==== Shuffle shifts into pairs of real shifts
* . and pairs of complex conjugate shifts
* . assuming complex conjugate shifts are
* . already adjacent to one another. (Yes,
* . they are.) ====
*
DO 70 I = KBOT, KS + 2, -2
IF( WI( I ).NE.-WI( I-1 ) ) THEN
*
SWAP = WR( I )
WR( I ) = WR( I-1 )
WR( I-1 ) = WR( I-2 )
WR( I-2 ) = SWAP
*
SWAP = WI( I )
WI( I ) = WI( I-1 )
WI( I-1 ) = WI( I-2 )
WI( I-2 ) = SWAP
END IF
70 CONTINUE
END IF
*
* ==== If there are only two shifts and both are
* . real, then use only one. ====
*
IF( KBOT-KS+1.EQ.2 ) THEN
IF( WI( KBOT ).EQ.ZERO ) THEN
IF( ABS( WR( KBOT )-H( KBOT, KBOT ) ).LT.
$ ABS( WR( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN
WR( KBOT-1 ) = WR( KBOT )
ELSE
WR( KBOT ) = WR( KBOT-1 )
END IF
END IF
END IF
*
* ==== Use up to NS of the the smallest magnatiude
* . shifts. If there aren't NS shifts available,
* . then use them all, possibly dropping one to
* . make the number of shifts even. ====
*
NS = MIN( NS, KBOT-KS+1 )
NS = NS - MOD( NS, 2 )
KS = KBOT - NS + 1
*
* ==== Small-bulge multi-shift QR sweep:
* . split workspace under the subdiagonal into
* . - a KDU-by-KDU work array U in the lower
* . left-hand-corner,
* . - a KDU-by-at-least-KDU-but-more-is-better
* . (KDU-by-NHo) horizontal work array WH along
* . the bottom edge,
* . - and an at-least-KDU-but-more-is-better-by-KDU
* . (NVE-by-KDU) vertical work WV arrow along
* . the left-hand-edge. ====
*
KDU = 3*NS - 3
KU = N - KDU + 1
KWH = KDU + 1
NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1
KWV = KDU + 4
NVE = N - KDU - KWV + 1
*
* ==== Small-bulge multi-shift QR sweep ====
*
CALL DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS,
$ WR( KS ), WI( KS ), H, LDH, ILOZ, IHIZ, Z,
$ LDZ, WORK, 3, H( KU, 1 ), LDH, NVE,
$ H( KWV, 1 ), LDH, NHO, H( KU, KWH ), LDH )
END IF
*
* ==== Note progress (or the lack of it). ====
*
IF( LD.GT.0 ) THEN
NDFL = 1
ELSE
NDFL = NDFL + 1
END IF
*
* ==== End of main loop ====
80 CONTINUE
*
* ==== Iteration limit exceeded. Set INFO to show where
* . the problem occurred and exit. ====
*
INFO = KBOT
90 CONTINUE
END IF
*
* ==== Return the optimal value of LWORK. ====
*
WORK( 1 ) = DBLE( LWKOPT )
*
* ==== End of DLAQR4 ====
*
END
SUBROUTINE DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS,
$ SR, SI, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U,
$ LDU, NV, WV, LDWV, NH, WH, LDWH )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV,
$ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV
LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), U( LDU, * ),
$ V( LDV, * ), WH( LDWH, * ), WV( LDWV, * ),
$ Z( LDZ, * )
* ..
*
* This auxiliary subroutine called by DLAQR0 performs a
* single small-bulge multi-shift QR sweep.
*
* WANTT (input) logical scalar
* WANTT = .true. if the quasi-triangular Schur factor
* is being computed. WANTT is set to .false. otherwise.
*
* WANTZ (input) logical scalar
* WANTZ = .true. if the orthogonal Schur factor is being
* computed. WANTZ is set to .false. otherwise.
*
* KACC22 (input) integer with value 0, 1, or 2.
* Specifies the computation mode of far-from-diagonal
* orthogonal updates.
* = 0: DLAQR5 does not accumulate reflections and does not
* use matrix-matrix multiply to update far-from-diagonal
* matrix entries.
* = 1: DLAQR5 accumulates reflections and uses matrix-matrix
* multiply to update the far-from-diagonal matrix entries.
* = 2: DLAQR5 accumulates reflections, uses matrix-matrix
* multiply to update the far-from-diagonal matrix entries,
* and takes advantage of 2-by-2 block structure during
* matrix multiplies.
*
* N (input) integer scalar
* N is the order of the Hessenberg matrix H upon which this
* subroutine operates.
*
* KTOP (input) integer scalar
* KBOT (input) integer scalar
* These are the first and last rows and columns of an
* isolated diagonal block upon which the QR sweep is to be
* applied. It is assumed without a check that
* either KTOP = 1 or H(KTOP,KTOP-1) = 0
* and
* either KBOT = N or H(KBOT+1,KBOT) = 0.
*
* NSHFTS (input) integer scalar
* NSHFTS gives the number of simultaneous shifts. NSHFTS
* must be positive and even.
*
* SR (input) DOUBLE PRECISION array of size (NSHFTS)
* SI (input) DOUBLE PRECISION array of size (NSHFTS)
* SR contains the real parts and SI contains the imaginary
* parts of the NSHFTS shifts of origin that define the
* multi-shift QR sweep.
*
* H (input/output) DOUBLE PRECISION array of size (LDH,N)
* On input H contains a Hessenberg matrix. On output a
* multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied
* to the isolated diagonal block in rows and columns KTOP
* through KBOT.
*
* LDH (input) integer scalar
* LDH is the leading dimension of H just as declared in the
* calling procedure. LDH.GE.MAX(1,N).
*
* ILOZ (input) INTEGER
* IHIZ (input) INTEGER
* Specify the rows of Z to which transformations must be
* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N
*
* Z (input/output) DOUBLE PRECISION array of size (LDZ,IHI)
* If WANTZ = .TRUE., then the QR Sweep orthogonal
* similarity transformation is accumulated into
* Z(ILOZ:IHIZ,ILO:IHI) from the right.
* If WANTZ = .FALSE., then Z is unreferenced.
*
* LDZ (input) integer scalar
* LDA is the leading dimension of Z just as declared in
* the calling procedure. LDZ.GE.N.
*
* V (workspace) DOUBLE PRECISION array of size (LDV,NSHFTS/2)
*
* LDV (input) integer scalar
* LDV is the leading dimension of V as declared in the
* calling procedure. LDV.GE.3.
*
* U (workspace) DOUBLE PRECISION array of size
* (LDU,3*NSHFTS-3)
*
* LDU (input) integer scalar
* LDU is the leading dimension of U just as declared in the
* in the calling subroutine. LDU.GE.3*NSHFTS-3.
*
* NH (input) integer scalar
* NH is the number of columns in array WH available for
* workspace. NH.GE.1.
*
* WH (workspace) DOUBLE PRECISION array of size (LDWH,NH)
*
* LDWH (input) integer scalar
* Leading dimension of WH just as declared in the
* calling procedure. LDWH.GE.3*NSHFTS-3.
*
* NV (input) integer scalar
* NV is the number of rows in WV agailable for workspace.
* NV.GE.1.
*
* WV (workspace) DOUBLE PRECISION array of size
* (LDWV,3*NSHFTS-3)
*
* LDWV (input) integer scalar
* LDWV is the leading dimension of WV as declared in the
* in the calling subroutine. LDWV.GE.NV.
*
*
* ================================================================
* Based on contributions by
* Karen Braman and Ralph Byers, Department of Mathematics,
* University of Kansas, USA
*
* ============================================================
* Reference:
*
* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
* Algorithm Part I: Maintaining Well Focused Shifts, and
* Level 3 Performance, SIAM Journal of Matrix Analysis,
* volume 23, pages 929--947, 2002.
*
* ============================================================
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION ALPHA, BETA, H11, H12, H21, H22, REFSUM,
$ SAFMAX, SAFMIN, SCL, SMLNUM, SWAP, TST1, TST2,
$ ULP
INTEGER I, I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN,
$ JROW, JTOP, K, K1, KDU, KMS, KNZ, KRCOL, KZS,
$ M, M22, MBOT, MEND, MSTART, MTOP, NBMPS, NDCOL,
$ NS, NU
LOGICAL ACCUM, BLK22, BMP22
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
*
INTRINSIC ABS, DBLE, MAX, MIN, MOD
* ..
* .. Local Arrays ..
DOUBLE PRECISION VT( 3 )
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLABAD, DLACPY, DLAQR1, DLARFG, DLASET,
$ DTRMM
* ..
* .. Executable Statements ..
*
* ==== If there are no shifts, then there is nothing to do. ====
*
IF( NSHFTS.LT.2 )
$ RETURN
*
* ==== If the active block is empty or 1-by-1, then there
* . is nothing to do. ====
*
IF( KTOP.GE.KBOT )
$ RETURN
*
* ==== Shuffle shifts into pairs of real shifts and pairs
* . of complex conjugate shifts assuming complex
* . conjugate shifts are already adjacent to one
* . another. ====
*
DO 10 I = 1, NSHFTS - 2, 2
IF( SI( I ).NE.-SI( I+1 ) ) THEN
*
SWAP = SR( I )
SR( I ) = SR( I+1 )
SR( I+1 ) = SR( I+2 )
SR( I+2 ) = SWAP
*
SWAP = SI( I )
SI( I ) = SI( I+1 )
SI( I+1 ) = SI( I+2 )
SI( I+2 ) = SWAP
END IF
10 CONTINUE
*
* ==== NSHFTS is supposed to be even, but if is odd,
* . then simply reduce it by one. The shuffle above
* . ensures that the dropped shift is real and that
* . the remaining shifts are paired. ====
*
NS = NSHFTS - MOD( NSHFTS, 2 )
*
* ==== Machine constants for deflation ====
*
SAFMIN = DLAMCH( 'SAFE MINIMUM' )
SAFMAX = ONE / SAFMIN
CALL DLABAD( SAFMIN, SAFMAX )
ULP = DLAMCH( 'PRECISION' )
SMLNUM = SAFMIN*( DBLE( N ) / ULP )
*
* ==== Use accumulated reflections to update far-from-diagonal
* . entries ? ====
*
ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 )
*
* ==== If so, exploit the 2-by-2 block structure? ====
*
BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 )
*
* ==== clear trash ====
*
IF( KTOP+2.LE.KBOT )
$ H( KTOP+2, KTOP ) = ZERO
*
* ==== NBMPS = number of 2-shift bulges in the chain ====
*
NBMPS = NS / 2
*
* ==== KDU = width of slab ====
*
KDU = 6*NBMPS - 3
*
* ==== Create and chase chains of NBMPS bulges ====
*
DO 220 INCOL = 3*( 1-NBMPS ) + KTOP - 1, KBOT - 2, 3*NBMPS - 2
NDCOL = INCOL + KDU
IF( ACCUM )
$ CALL DLASET( 'ALL', KDU, KDU, ZERO, ONE, U, LDU )
*
* ==== Near-the-diagonal bulge chase. The following loop
* . performs the near-the-diagonal part of a small bulge
* . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal
* . chunk extends from column INCOL to column NDCOL
* . (including both column INCOL and column NDCOL). The
* . following loop chases a 3*NBMPS column long chain of
* . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL
* . may be less than KTOP and and NDCOL may be greater than
* . KBOT indicating phantom columns from which to chase
* . bulges before they are actually introduced or to which
* . to chase bulges beyond column KBOT.) ====
*
DO 150 KRCOL = INCOL, MIN( INCOL+3*NBMPS-3, KBOT-2 )
*
* ==== Bulges number MTOP to MBOT are active double implicit
* . shift bulges. There may or may not also be small
* . 2-by-2 bulge, if there is room. The inactive bulges
* . (if any) must wait until the active bulges have moved
* . down the diagonal to make room. The phantom matrix
* . paradigm described above helps keep track. ====
*
MTOP = MAX( 1, ( ( KTOP-1 )-KRCOL+2 ) / 3+1 )
MBOT = MIN( NBMPS, ( KBOT-KRCOL ) / 3 )
M22 = MBOT + 1
BMP22 = ( MBOT.LT.NBMPS ) .AND. ( KRCOL+3*( M22-1 ) ).EQ.
$ ( KBOT-2 )
*
* ==== Generate reflections to chase the chain right
* . one column. (The minimum value of K is KTOP-1.) ====
*
DO 20 M = MTOP, MBOT
K = KRCOL + 3*( M-1 )
IF( K.EQ.KTOP-1 ) THEN
CALL DLAQR1( 3, H( KTOP, KTOP ), LDH, SR( 2*M-1 ),
$ SI( 2*M-1 ), SR( 2*M ), SI( 2*M ),
$ V( 1, M ) )
ALPHA = V( 1, M )
CALL DLARFG( 3, ALPHA, V( 2, M ), 1, V( 1, M ) )
ELSE
BETA = H( K+1, K )
V( 2, M ) = H( K+2, K )
V( 3, M ) = H( K+3, K )
CALL DLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) )
*
* ==== A Bulge may collapse because of vigilant
* . deflation or destructive underflow. (The
* . initial bulge is always collapsed.) Use
* . the two-small-subdiagonals trick to try
* . to get it started again. If V(2,M).NE.0 and
* . V(3,M) = H(K+3,K+1) = H(K+3,K+2) = 0, then
* . this bulge is collapsing into a zero
* . subdiagonal. It will be restarted next
* . trip through the loop.)
*
IF( V( 1, M ).NE.ZERO .AND.
$ ( V( 3, M ).NE.ZERO .OR. ( H( K+3,
$ K+1 ).EQ.ZERO .AND. H( K+3, K+2 ).EQ.ZERO ) ) )
$ THEN
*
* ==== Typical case: not collapsed (yet). ====
*
H( K+1, K ) = BETA
H( K+2, K ) = ZERO
H( K+3, K ) = ZERO
ELSE
*
* ==== Atypical case: collapsed. Attempt to
* . reintroduce ignoring H(K+1,K). If the
* . fill resulting from the new reflector
* . is too large, then abandon it.
* . Otherwise, use the new one. ====
*
CALL DLAQR1( 3, H( K+1, K+1 ), LDH, SR( 2*M-1 ),
$ SI( 2*M-1 ), SR( 2*M ), SI( 2*M ),
$ VT )
SCL = ABS( VT( 1 ) ) + ABS( VT( 2 ) ) +
$ ABS( VT( 3 ) )
IF( SCL.NE.ZERO ) THEN
VT( 1 ) = VT( 1 ) / SCL
VT( 2 ) = VT( 2 ) / SCL
VT( 3 ) = VT( 3 ) / SCL
END IF
*
* ==== The following is the traditional and
* . conservative two-small-subdiagonals
* . test. ====
* .
IF( ABS( H( K+1, K ) )*( ABS( VT( 2 ) )+
$ ABS( VT( 3 ) ) ).GT.ULP*ABS( VT( 1 ) )*
$ ( ABS( H( K, K ) )+ABS( H( K+1,
$ K+1 ) )+ABS( H( K+2, K+2 ) ) ) ) THEN
*
* ==== Starting a new bulge here would
* . create non-negligible fill. If
* . the old reflector is diagonal (only
* . possible with underflows), then
* . change it to I. Otherwise, use
* . it with trepidation. ====
*
IF( V( 2, M ).EQ.ZERO .AND. V( 3, M ).EQ.ZERO )
$ THEN
V( 1, M ) = ZERO
ELSE
H( K+1, K ) = BETA
H( K+2, K ) = ZERO
H( K+3, K ) = ZERO
END IF
ELSE
*
* ==== Stating a new bulge here would
* . create only negligible fill.
* . Replace the old reflector with
* . the new one. ====
*
ALPHA = VT( 1 )
CALL DLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) )
REFSUM = H( K+1, K ) + H( K+2, K )*VT( 2 ) +
$ H( K+3, K )*VT( 3 )
H( K+1, K ) = H( K+1, K ) - VT( 1 )*REFSUM
H( K+2, K ) = ZERO
H( K+3, K ) = ZERO
V( 1, M ) = VT( 1 )
V( 2, M ) = VT( 2 )
V( 3, M ) = VT( 3 )
END IF
END IF
END IF
20 CONTINUE
*
* ==== Generate a 2-by-2 reflection, if needed. ====
*
K = KRCOL + 3*( M22-1 )
IF( BMP22 ) THEN
IF( K.EQ.KTOP-1 ) THEN
CALL DLAQR1( 2, H( K+1, K+1 ), LDH, SR( 2*M22-1 ),
$ SI( 2*M22-1 ), SR( 2*M22 ), SI( 2*M22 ),
$ V( 1, M22 ) )
BETA = V( 1, M22 )
CALL DLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) )
ELSE
BETA = H( K+1, K )
V( 2, M22 ) = H( K+2, K )
CALL DLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) )
H( K+1, K ) = BETA
H( K+2, K ) = ZERO
END IF
ELSE
*
* ==== Initialize V(1,M22) here to avoid possible undefined
* . variable problems later. ====
*
V( 1, M22 ) = ZERO
END IF
*
* ==== Multiply H by reflections from the left ====
*
IF( ACCUM ) THEN
JBOT = MIN( NDCOL, KBOT )
ELSE IF( WANTT ) THEN
JBOT = N
ELSE
JBOT = KBOT
END IF
DO 40 J = MAX( KTOP, KRCOL ), JBOT
MEND = MIN( MBOT, ( J-KRCOL+2 ) / 3 )
DO 30 M = MTOP, MEND
K = KRCOL + 3*( M-1 )
REFSUM = V( 1, M )*( H( K+1, J )+V( 2, M )*
$ H( K+2, J )+V( 3, M )*H( K+3, J ) )
H( K+1, J ) = H( K+1, J ) - REFSUM
H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M )
H( K+3, J ) = H( K+3, J ) - REFSUM*V( 3, M )
30 CONTINUE
40 CONTINUE
IF( BMP22 ) THEN
K = KRCOL + 3*( M22-1 )
DO 50 J = MAX( K+1, KTOP ), JBOT
REFSUM = V( 1, M22 )*( H( K+1, J )+V( 2, M22 )*
$ H( K+2, J ) )
H( K+1, J ) = H( K+1, J ) - REFSUM
H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M22 )
50 CONTINUE
END IF
*
* ==== Multiply H by reflections from the right.
* . Delay filling in the last row until the
* . vigilant deflation check is complete. ====
*
IF( ACCUM ) THEN
JTOP = MAX( KTOP, INCOL )
ELSE IF( WANTT ) THEN
JTOP = 1
ELSE
JTOP = KTOP
END IF
DO 90 M = MTOP, MBOT
IF( V( 1, M ).NE.ZERO ) THEN
K = KRCOL + 3*( M-1 )
DO 60 J = JTOP, MIN( KBOT, K+3 )
REFSUM = V( 1, M )*( H( J, K+1 )+V( 2, M )*
$ H( J, K+2 )+V( 3, M )*H( J, K+3 ) )
H( J, K+1 ) = H( J, K+1 ) - REFSUM
H( J, K+2 ) = H( J, K+2 ) - REFSUM*V( 2, M )
H( J, K+3 ) = H( J, K+3 ) - REFSUM*V( 3, M )
60 CONTINUE
*
IF( ACCUM ) THEN
*
* ==== Accumulate U. (If necessary, update Z later
* . with with an efficient matrix-matrix
* . multiply.) ====
*
KMS = K - INCOL
DO 70 J = MAX( 1, KTOP-INCOL ), KDU
REFSUM = V( 1, M )*( U( J, KMS+1 )+V( 2, M )*
$ U( J, KMS+2 )+V( 3, M )*U( J, KMS+3 ) )
U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM
U( J, KMS+2 ) = U( J, KMS+2 ) - REFSUM*V( 2, M )
U( J, KMS+3 ) = U( J, KMS+3 ) - REFSUM*V( 3, M )
70 CONTINUE
ELSE IF( WANTZ ) THEN
*
* ==== U is not accumulated, so update Z
* . now by multiplying by reflections
* . from the right. ====
*
DO 80 J = ILOZ, IHIZ
REFSUM = V( 1, M )*( Z( J, K+1 )+V( 2, M )*
$ Z( J, K+2 )+V( 3, M )*Z( J, K+3 ) )
Z( J, K+1 ) = Z( J, K+1 ) - REFSUM
Z( J, K+2 ) = Z( J, K+2 ) - REFSUM*V( 2, M )
Z( J, K+3 ) = Z( J, K+3 ) - REFSUM*V( 3, M )
80 CONTINUE
END IF
END IF
90 CONTINUE
*
* ==== Special case: 2-by-2 reflection (if needed) ====
*
K = KRCOL + 3*( M22-1 )
IF( BMP22 .AND. ( V( 1, M22 ).NE.ZERO ) ) THEN
DO 100 J = JTOP, MIN( KBOT, K+3 )
REFSUM = V( 1, M22 )*( H( J, K+1 )+V( 2, M22 )*
$ H( J, K+2 ) )
H( J, K+1 ) = H( J, K+1 ) - REFSUM
H( J, K+2 ) = H( J, K+2 ) - REFSUM*V( 2, M22 )
100 CONTINUE
*
IF( ACCUM ) THEN
KMS = K - INCOL
DO 110 J = MAX( 1, KTOP-INCOL ), KDU
REFSUM = V( 1, M22 )*( U( J, KMS+1 )+V( 2, M22 )*
$ U( J, KMS+2 ) )
U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM
U( J, KMS+2 ) = U( J, KMS+2 ) - REFSUM*V( 2, M22 )
110 CONTINUE
ELSE IF( WANTZ ) THEN
DO 120 J = ILOZ, IHIZ
REFSUM = V( 1, M22 )*( Z( J, K+1 )+V( 2, M22 )*
$ Z( J, K+2 ) )
Z( J, K+1 ) = Z( J, K+1 ) - REFSUM
Z( J, K+2 ) = Z( J, K+2 ) - REFSUM*V( 2, M22 )
120 CONTINUE
END IF
END IF
*
* ==== Vigilant deflation check ====
*
MSTART = MTOP
IF( KRCOL+3*( MSTART-1 ).LT.KTOP )
$ MSTART = MSTART + 1
MEND = MBOT
IF( BMP22 )
$ MEND = MEND + 1
IF( KRCOL.EQ.KBOT-2 )
$ MEND = MEND + 1
DO 130 M = MSTART, MEND
K = MIN( KBOT-1, KRCOL+3*( M-1 ) )
*
* ==== The following convergence test requires that
* . the tradition small-compared-to-nearby-diagonals
* . criterion and the Ahues & Tisseur (LAWN 122, 1997)
* . criteria both be satisfied. The latter improves
* . accuracy in some examples. Falling back on an
* . alternate convergence criterion when TST1 or TST2
* . is zero (as done here) is traditional but probably
* . unnecessary. ====
*
IF( H( K+1, K ).NE.ZERO ) THEN
TST1 = ABS( H( K, K ) ) + ABS( H( K+1, K+1 ) )
IF( TST1.EQ.ZERO ) THEN
IF( K.GE.KTOP+1 )
$ TST1 = TST1 + ABS( H( K, K-1 ) )
IF( K.GE.KTOP+2 )
$ TST1 = TST1 + ABS( H( K, K-2 ) )
IF( K.GE.KTOP+3 )
$ TST1 = TST1 + ABS( H( K, K-3 ) )
IF( K.LE.KBOT-2 )
$ TST1 = TST1 + ABS( H( K+2, K+1 ) )
IF( K.LE.KBOT-3 )
$ TST1 = TST1 + ABS( H( K+3, K+1 ) )
IF( K.LE.KBOT-4 )
$ TST1 = TST1 + ABS( H( K+4, K+1 ) )
END IF
IF( ABS( H( K+1, K ) ).LE.MAX( SMLNUM, ULP*TST1 ) )
$ THEN
H12 = MAX( ABS( H( K+1, K ) ), ABS( H( K, K+1 ) ) )
H21 = MIN( ABS( H( K+1, K ) ), ABS( H( K, K+1 ) ) )
H11 = MAX( ABS( H( K+1, K+1 ) ),
$ ABS( H( K, K )-H( K+1, K+1 ) ) )
H22 = MIN( ABS( H( K+1, K+1 ) ),
$ ABS( H( K, K )-H( K+1, K+1 ) ) )
SCL = H11 + H12
TST2 = H22*( H11 / SCL )
*
IF( TST2.EQ.ZERO .OR. H21*( H12 / SCL ).LE.
$ MAX( SMLNUM, ULP*TST2 ) )H( K+1, K ) = ZERO
END IF
END IF
130 CONTINUE
*
* ==== Fill in the last row of each bulge. ====
*
MEND = MIN( NBMPS, ( KBOT-KRCOL-1 ) / 3 )
DO 140 M = MTOP, MEND
K = KRCOL + 3*( M-1 )
REFSUM = V( 1, M )*V( 3, M )*H( K+4, K+3 )
H( K+4, K+1 ) = -REFSUM
H( K+4, K+2 ) = -REFSUM*V( 2, M )
H( K+4, K+3 ) = H( K+4, K+3 ) - REFSUM*V( 3, M )
140 CONTINUE
*
* ==== End of near-the-diagonal bulge chase. ====
*
150 CONTINUE
*
* ==== Use U (if accumulated) to update far-from-diagonal
* . entries in H. If required, use U to update Z as
* . well. ====
*
IF( ACCUM ) THEN
IF( WANTT ) THEN
JTOP = 1
JBOT = N
ELSE
JTOP = KTOP
JBOT = KBOT
END IF
IF( ( .NOT.BLK22 ) .OR. ( INCOL.LT.KTOP ) .OR.
$ ( NDCOL.GT.KBOT ) .OR. ( NS.LE.2 ) ) THEN
*
* ==== Updates not exploiting the 2-by-2 block
* . structure of U. K1 and NU keep track of
* . the location and size of U in the special
* . cases of introducing bulges and chasing
* . bulges off the bottom. In these special
* . cases and in case the number of shifts
* . is NS = 2, there is no 2-by-2 block
* . structure to exploit. ====
*
K1 = MAX( 1, KTOP-INCOL )
NU = ( KDU-MAX( 0, NDCOL-KBOT ) ) - K1 + 1
*
* ==== Horizontal Multiply ====
*
DO 160 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH
JLEN = MIN( NH, JBOT-JCOL+1 )
CALL DGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ),
$ LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH,
$ LDWH )
CALL DLACPY( 'ALL', NU, JLEN, WH, LDWH,
$ H( INCOL+K1, JCOL ), LDH )
160 CONTINUE
*
* ==== Vertical multiply ====
*
DO 170 JROW = JTOP, MAX( KTOP, INCOL ) - 1, NV
JLEN = MIN( NV, MAX( KTOP, INCOL )-JROW )
CALL DGEMM( 'N', 'N', JLEN, NU, NU, ONE,
$ H( JROW, INCOL+K1 ), LDH, U( K1, K1 ),
$ LDU, ZERO, WV, LDWV )
CALL DLACPY( 'ALL', JLEN, NU, WV, LDWV,
$ H( JROW, INCOL+K1 ), LDH )
170 CONTINUE
*
* ==== Z multiply (also vertical) ====
*
IF( WANTZ ) THEN
DO 180 JROW = ILOZ, IHIZ, NV
JLEN = MIN( NV, IHIZ-JROW+1 )
CALL DGEMM( 'N', 'N', JLEN, NU, NU, ONE,
$ Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ),
$ LDU, ZERO, WV, LDWV )
CALL DLACPY( 'ALL', JLEN, NU, WV, LDWV,
$ Z( JROW, INCOL+K1 ), LDZ )
180 CONTINUE
END IF
ELSE
*
* ==== Updates exploiting U's 2-by-2 block structure.
* . (I2, I4, J2, J4 are the last rows and columns
* . of the blocks.) ====
*
I2 = ( KDU+1 ) / 2
I4 = KDU
J2 = I4 - I2
J4 = KDU
*
* ==== KZS and KNZ deal with the band of zeros
* . along the diagonal of one of the triangular
* . blocks. ====
*
KZS = ( J4-J2 ) - ( NS+1 )
KNZ = NS + 1
*
* ==== Horizontal multiply ====
*
DO 190 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH
JLEN = MIN( NH, JBOT-JCOL+1 )
*
* ==== Copy bottom of H to top+KZS of scratch ====
* (The first KZS rows get multiplied by zero.) ====
*
CALL DLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ),
$ LDH, WH( KZS+1, 1 ), LDWH )
*
* ==== Multiply by U21' ====
*
CALL DLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH )
CALL DTRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE,
$ U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ),
$ LDWH )
*
* ==== Multiply top of H by U11' ====
*
CALL DGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU,
$ H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH )
*
* ==== Copy top of H bottom of WH ====
*
CALL DLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH,
$ WH( I2+1, 1 ), LDWH )
*
* ==== Multiply by U21' ====
*
CALL DTRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE,
$ U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH )
*
* ==== Multiply by U22 ====
*
CALL DGEMM( 'C', 'N', I4-I2, JLEN, J4-J2, ONE,
$ U( J2+1, I2+1 ), LDU,
$ H( INCOL+1+J2, JCOL ), LDH, ONE,
$ WH( I2+1, 1 ), LDWH )
*
* ==== Copy it back ====
*
CALL DLACPY( 'ALL', KDU, JLEN, WH, LDWH,
$ H( INCOL+1, JCOL ), LDH )
190 CONTINUE
*
* ==== Vertical multiply ====
*
DO 200 JROW = JTOP, MAX( INCOL, KTOP ) - 1, NV
JLEN = MIN( NV, MAX( INCOL, KTOP )-JROW )
*
* ==== Copy right of H to scratch (the first KZS
* . columns get multiplied by zero) ====
*
CALL DLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ),
$ LDH, WV( 1, 1+KZS ), LDWV )
*
* ==== Multiply by U21 ====
*
CALL DLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV )
CALL DTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE,
$ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ),
$ LDWV )
*
* ==== Multiply by U11 ====
*
CALL DGEMM( 'N', 'N', JLEN, I2, J2, ONE,
$ H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV,
$ LDWV )
*
* ==== Copy left of H to right of scratch ====
*
CALL DLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH,
$ WV( 1, 1+I2 ), LDWV )
*
* ==== Multiply by U21 ====
*
CALL DTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE,
$ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV )
*
* ==== Multiply by U22 ====
*
CALL DGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE,
$ H( JROW, INCOL+1+J2 ), LDH,
$ U( J2+1, I2+1 ), LDU, ONE, WV( 1, 1+I2 ),
$ LDWV )
*
* ==== Copy it back ====
*
CALL DLACPY( 'ALL', JLEN, KDU, WV, LDWV,
$ H( JROW, INCOL+1 ), LDH )
200 CONTINUE
*
* ==== Multiply Z (also vertical) ====
*
IF( WANTZ ) THEN
DO 210 JROW = ILOZ, IHIZ, NV
JLEN = MIN( NV, IHIZ-JROW+1 )
*
* ==== Copy right of Z to left of scratch (first
* . KZS columns get multiplied by zero) ====
*
CALL DLACPY( 'ALL', JLEN, KNZ,
$ Z( JROW, INCOL+1+J2 ), LDZ,
$ WV( 1, 1+KZS ), LDWV )
*
* ==== Multiply by U12 ====
*
CALL DLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV,
$ LDWV )
CALL DTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE,
$ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ),
$ LDWV )
*
* ==== Multiply by U11 ====
*
CALL DGEMM( 'N', 'N', JLEN, I2, J2, ONE,
$ Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE,
$ WV, LDWV )
*
* ==== Copy left of Z to right of scratch ====
*
CALL DLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ),
$ LDZ, WV( 1, 1+I2 ), LDWV )
*
* ==== Multiply by U21 ====
*
CALL DTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE,
$ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ),
$ LDWV )
*
* ==== Multiply by U22 ====
*
CALL DGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE,
$ Z( JROW, INCOL+1+J2 ), LDZ,
$ U( J2+1, I2+1 ), LDU, ONE,
$ WV( 1, 1+I2 ), LDWV )
*
* ==== Copy the result back to Z ====
*
CALL DLACPY( 'ALL', JLEN, KDU, WV, LDWV,
$ Z( JROW, INCOL+1 ), LDZ )
210 CONTINUE
END IF
END IF
END IF
220 CONTINUE
*
* ==== End of DLAQR5 ====
*
END
SUBROUTINE DLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER EQUED, UPLO
INTEGER KD, LDAB, N
DOUBLE PRECISION AMAX, SCOND
* ..
* .. Array Arguments ..
DOUBLE PRECISION AB( LDAB, * ), S( * )
* ..
*
* Purpose
* =======
*
* DLAQSB equilibrates a symmetric band matrix A using the scaling
* factors in the vector S.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of super-diagonals of the matrix A if UPLO = 'U',
* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
*
* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
* On entry, the upper or lower triangle of the symmetric band
* matrix A, stored in the first KD+1 rows of the array. The
* j-th column of A is stored in the j-th column of the array AB
* as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*
* On exit, if INFO = 0, the triangular factor U or L from the
* Cholesky factorization A = U'*U or A = L*L' of the band
* matrix A, in the same storage format as A.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* S (input) DOUBLE PRECISION array, dimension (N)
* The scale factors for A.
*
* SCOND (input) DOUBLE PRECISION
* Ratio of the smallest S(i) to the largest S(i).
*
* AMAX (input) DOUBLE PRECISION
* Absolute value of largest matrix entry.
*
* EQUED (output) CHARACTER*1
* Specifies whether or not equilibration was done.
* = 'N': No equilibration.
* = 'Y': Equilibration was done, i.e., A has been replaced by
* diag(S) * A * diag(S).
*
* Internal Parameters
* ===================
*
* THRESH is a threshold value used to decide if scaling should be done
* based on the ratio of the scaling factors. If SCOND < THRESH,
* scaling is done.
*
* LARGE and SMALL are threshold values used to decide if scaling should
* be done based on the absolute size of the largest matrix element.
* If AMAX > LARGE or AMAX < SMALL, scaling is done.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, THRESH
PARAMETER ( ONE = 1.0D+0, THRESH = 0.1D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION CJ, LARGE, SMALL
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.0 ) THEN
EQUED = 'N'
RETURN
END IF
*
* Initialize LARGE and SMALL.
*
SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
LARGE = ONE / SMALL
*
IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
*
* No equilibration
*
EQUED = 'N'
ELSE
*
* Replace A by diag(S) * A * diag(S).
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Upper triangle of A is stored in band format.
*
DO 20 J = 1, N
CJ = S( J )
DO 10 I = MAX( 1, J-KD ), J
AB( KD+1+I-J, J ) = CJ*S( I )*AB( KD+1+I-J, J )
10 CONTINUE
20 CONTINUE
ELSE
*
* Lower triangle of A is stored.
*
DO 40 J = 1, N
CJ = S( J )
DO 30 I = J, MIN( N, J+KD )
AB( 1+I-J, J ) = CJ*S( I )*AB( 1+I-J, J )
30 CONTINUE
40 CONTINUE
END IF
EQUED = 'Y'
END IF
*
RETURN
*
* End of DLAQSB
*
END
SUBROUTINE DLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER EQUED, UPLO
INTEGER N
DOUBLE PRECISION AMAX, SCOND
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP( * ), S( * )
* ..
*
* Purpose
* =======
*
* DLAQSP equilibrates a symmetric matrix A using the scaling factors
* in the vector S.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* A, packed columnwise in a linear array. The j-th column of A
* is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
*
* On exit, the equilibrated matrix: diag(S) * A * diag(S), in
* the same storage format as A.
*
* S (input) DOUBLE PRECISION array, dimension (N)
* The scale factors for A.
*
* SCOND (input) DOUBLE PRECISION
* Ratio of the smallest S(i) to the largest S(i).
*
* AMAX (input) DOUBLE PRECISION
* Absolute value of largest matrix entry.
*
* EQUED (output) CHARACTER*1
* Specifies whether or not equilibration was done.
* = 'N': No equilibration.
* = 'Y': Equilibration was done, i.e., A has been replaced by
* diag(S) * A * diag(S).
*
* Internal Parameters
* ===================
*
* THRESH is a threshold value used to decide if scaling should be done
* based on the ratio of the scaling factors. If SCOND < THRESH,
* scaling is done.
*
* LARGE and SMALL are threshold values used to decide if scaling should
* be done based on the absolute size of the largest matrix element.
* If AMAX > LARGE or AMAX < SMALL, scaling is done.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, THRESH
PARAMETER ( ONE = 1.0D+0, THRESH = 0.1D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, JC
DOUBLE PRECISION CJ, LARGE, SMALL
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.0 ) THEN
EQUED = 'N'
RETURN
END IF
*
* Initialize LARGE and SMALL.
*
SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
LARGE = ONE / SMALL
*
IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
*
* No equilibration
*
EQUED = 'N'
ELSE
*
* Replace A by diag(S) * A * diag(S).
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Upper triangle of A is stored.
*
JC = 1
DO 20 J = 1, N
CJ = S( J )
DO 10 I = 1, J
AP( JC+I-1 ) = CJ*S( I )*AP( JC+I-1 )
10 CONTINUE
JC = JC + J
20 CONTINUE
ELSE
*
* Lower triangle of A is stored.
*
JC = 1
DO 40 J = 1, N
CJ = S( J )
DO 30 I = J, N
AP( JC+I-J ) = CJ*S( I )*AP( JC+I-J )
30 CONTINUE
JC = JC + N - J + 1
40 CONTINUE
END IF
EQUED = 'Y'
END IF
*
RETURN
*
* End of DLAQSP
*
END
SUBROUTINE DLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER EQUED, UPLO
INTEGER LDA, N
DOUBLE PRECISION AMAX, SCOND
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), S( * )
* ..
*
* Purpose
* =======
*
* DLAQSY equilibrates a symmetric matrix A using the scaling factors
* in the vector S.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the symmetric matrix A. If UPLO = 'U', the leading
* n by n upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading n by n lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced.
*
* On exit, if EQUED = 'Y', the equilibrated matrix:
* diag(S) * A * diag(S).
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(N,1).
*
* S (input) DOUBLE PRECISION array, dimension (N)
* The scale factors for A.
*
* SCOND (input) DOUBLE PRECISION
* Ratio of the smallest S(i) to the largest S(i).
*
* AMAX (input) DOUBLE PRECISION
* Absolute value of largest matrix entry.
*
* EQUED (output) CHARACTER*1
* Specifies whether or not equilibration was done.
* = 'N': No equilibration.
* = 'Y': Equilibration was done, i.e., A has been replaced by
* diag(S) * A * diag(S).
*
* Internal Parameters
* ===================
*
* THRESH is a threshold value used to decide if scaling should be done
* based on the ratio of the scaling factors. If SCOND < THRESH,
* scaling is done.
*
* LARGE and SMALL are threshold values used to decide if scaling should
* be done based on the absolute size of the largest matrix element.
* If AMAX > LARGE or AMAX < SMALL, scaling is done.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, THRESH
PARAMETER ( ONE = 1.0D+0, THRESH = 0.1D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION CJ, LARGE, SMALL
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.0 ) THEN
EQUED = 'N'
RETURN
END IF
*
* Initialize LARGE and SMALL.
*
SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
LARGE = ONE / SMALL
*
IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
*
* No equilibration
*
EQUED = 'N'
ELSE
*
* Replace A by diag(S) * A * diag(S).
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Upper triangle of A is stored.
*
DO 20 J = 1, N
CJ = S( J )
DO 10 I = 1, J
A( I, J ) = CJ*S( I )*A( I, J )
10 CONTINUE
20 CONTINUE
ELSE
*
* Lower triangle of A is stored.
*
DO 40 J = 1, N
CJ = S( J )
DO 30 I = J, N
A( I, J ) = CJ*S( I )*A( I, J )
30 CONTINUE
40 CONTINUE
END IF
EQUED = 'Y'
END IF
*
RETURN
*
* End of DLAQSY
*
END
SUBROUTINE DLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK,
$ INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL LREAL, LTRAN
INTEGER INFO, LDT, N
DOUBLE PRECISION SCALE, W
* ..
* .. Array Arguments ..
DOUBLE PRECISION B( * ), T( LDT, * ), WORK( * ), X( * )
* ..
*
* Purpose
* =======
*
* DLAQTR solves the real quasi-triangular system
*
* op(T)*p = scale*c, if LREAL = .TRUE.
*
* or the complex quasi-triangular systems
*
* op(T + iB)*(p+iq) = scale*(c+id), if LREAL = .FALSE.
*
* in real arithmetic, where T is upper quasi-triangular.
* If LREAL = .FALSE., then the first diagonal block of T must be
* 1 by 1, B is the specially structured matrix
*
* B = [ b(1) b(2) ... b(n) ]
* [ w ]
* [ w ]
* [ . ]
* [ w ]
*
* op(A) = A or A', A' denotes the conjugate transpose of
* matrix A.
*
* On input, X = [ c ]. On output, X = [ p ].
* [ d ] [ q ]
*
* This subroutine is designed for the condition number estimation
* in routine DTRSNA.
*
* Arguments
* =========
*
* LTRAN (input) LOGICAL
* On entry, LTRAN specifies the option of conjugate transpose:
* = .FALSE., op(T+i*B) = T+i*B,
* = .TRUE., op(T+i*B) = (T+i*B)'.
*
* LREAL (input) LOGICAL
* On entry, LREAL specifies the input matrix structure:
* = .FALSE., the input is complex
* = .TRUE., the input is real
*
* N (input) INTEGER
* On entry, N specifies the order of T+i*B. N >= 0.
*
* T (input) DOUBLE PRECISION array, dimension (LDT,N)
* On entry, T contains a matrix in Schur canonical form.
* If LREAL = .FALSE., then the first diagonal block of T mu
* be 1 by 1.
*
* LDT (input) INTEGER
* The leading dimension of the matrix T. LDT >= max(1,N).
*
* B (input) DOUBLE PRECISION array, dimension (N)
* On entry, B contains the elements to form the matrix
* B as described above.
* If LREAL = .TRUE., B is not referenced.
*
* W (input) DOUBLE PRECISION
* On entry, W is the diagonal element of the matrix B.
* If LREAL = .TRUE., W is not referenced.
*
* SCALE (output) DOUBLE PRECISION
* On exit, SCALE is the scale factor.
*
* X (input/output) DOUBLE PRECISION array, dimension (2*N)
* On entry, X contains the right hand side of the system.
* On exit, X is overwritten by the solution.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* INFO (output) INTEGER
* On exit, INFO is set to
* 0: successful exit.
* 1: the some diagonal 1 by 1 block has been perturbed by
* a small number SMIN to keep nonsingularity.
* 2: the some diagonal 2 by 2 block has been perturbed by
* a small number in DLALN2 to keep nonsingularity.
* NOTE: In the interests of speed, this routine does not
* check the inputs for errors.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN
INTEGER I, IERR, J, J1, J2, JNEXT, K, N1, N2
DOUBLE PRECISION BIGNUM, EPS, REC, SCALOC, SI, SMIN, SMINW,
$ SMLNUM, SR, TJJ, TMP, XJ, XMAX, XNORM, Z
* ..
* .. Local Arrays ..
DOUBLE PRECISION D( 2, 2 ), V( 2, 2 )
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DASUM, DDOT, DLAMCH, DLANGE
EXTERNAL IDAMAX, DASUM, DDOT, DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DLADIV, DLALN2, DSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Do not test the input parameters for errors
*
NOTRAN = .NOT.LTRAN
INFO = 0
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Set constants to control overflow
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' ) / EPS
BIGNUM = ONE / SMLNUM
*
XNORM = DLANGE( 'M', N, N, T, LDT, D )
IF( .NOT.LREAL )
$ XNORM = MAX( XNORM, ABS( W ), DLANGE( 'M', N, 1, B, N, D ) )
SMIN = MAX( SMLNUM, EPS*XNORM )
*
* Compute 1-norm of each column of strictly upper triangular
* part of T to control overflow in triangular solver.
*
WORK( 1 ) = ZERO
DO 10 J = 2, N
WORK( J ) = DASUM( J-1, T( 1, J ), 1 )
10 CONTINUE
*
IF( .NOT.LREAL ) THEN
DO 20 I = 2, N
WORK( I ) = WORK( I ) + ABS( B( I ) )
20 CONTINUE
END IF
*
N2 = 2*N
N1 = N
IF( .NOT.LREAL )
$ N1 = N2
K = IDAMAX( N1, X, 1 )
XMAX = ABS( X( K ) )
SCALE = ONE
*
IF( XMAX.GT.BIGNUM ) THEN
SCALE = BIGNUM / XMAX
CALL DSCAL( N1, SCALE, X, 1 )
XMAX = BIGNUM
END IF
*
IF( LREAL ) THEN
*
IF( NOTRAN ) THEN
*
* Solve T*p = scale*c
*
JNEXT = N
DO 30 J = N, 1, -1
IF( J.GT.JNEXT )
$ GO TO 30
J1 = J
J2 = J
JNEXT = J - 1
IF( J.GT.1 ) THEN
IF( T( J, J-1 ).NE.ZERO ) THEN
J1 = J - 1
JNEXT = J - 2
END IF
END IF
*
IF( J1.EQ.J2 ) THEN
*
* Meet 1 by 1 diagonal block
*
* Scale to avoid overflow when computing
* x(j) = b(j)/T(j,j)
*
XJ = ABS( X( J1 ) )
TJJ = ABS( T( J1, J1 ) )
TMP = T( J1, J1 )
IF( TJJ.LT.SMIN ) THEN
TMP = SMIN
TJJ = SMIN
INFO = 1
END IF
*
IF( XJ.EQ.ZERO )
$ GO TO 30
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.BIGNUM*TJJ ) THEN
REC = ONE / XJ
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
X( J1 ) = X( J1 ) / TMP
XJ = ABS( X( J1 ) )
*
* Scale x if necessary to avoid overflow when adding a
* multiple of column j1 of T.
*
IF( XJ.GT.ONE ) THEN
REC = ONE / XJ
IF( WORK( J1 ).GT.( BIGNUM-XMAX )*REC ) THEN
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
END IF
END IF
IF( J1.GT.1 ) THEN
CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
K = IDAMAX( J1-1, X, 1 )
XMAX = ABS( X( K ) )
END IF
*
ELSE
*
* Meet 2 by 2 diagonal block
*
* Call 2 by 2 linear system solve, to take
* care of possible overflow by scaling factor.
*
D( 1, 1 ) = X( J1 )
D( 2, 1 ) = X( J2 )
CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, T( J1, J1 ),
$ LDT, ONE, ONE, D, 2, ZERO, ZERO, V, 2,
$ SCALOC, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 2
*
IF( SCALOC.NE.ONE ) THEN
CALL DSCAL( N, SCALOC, X, 1 )
SCALE = SCALE*SCALOC
END IF
X( J1 ) = V( 1, 1 )
X( J2 ) = V( 2, 1 )
*
* Scale V(1,1) (= X(J1)) and/or V(2,1) (=X(J2))
* to avoid overflow in updating right-hand side.
*
XJ = MAX( ABS( V( 1, 1 ) ), ABS( V( 2, 1 ) ) )
IF( XJ.GT.ONE ) THEN
REC = ONE / XJ
IF( MAX( WORK( J1 ), WORK( J2 ) ).GT.
$ ( BIGNUM-XMAX )*REC ) THEN
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
END IF
END IF
*
* Update right-hand side
*
IF( J1.GT.1 ) THEN
CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
CALL DAXPY( J1-1, -X( J2 ), T( 1, J2 ), 1, X, 1 )
K = IDAMAX( J1-1, X, 1 )
XMAX = ABS( X( K ) )
END IF
*
END IF
*
30 CONTINUE
*
ELSE
*
* Solve T'*p = scale*c
*
JNEXT = 1
DO 40 J = 1, N
IF( J.LT.JNEXT )
$ GO TO 40
J1 = J
J2 = J
JNEXT = J + 1
IF( J.LT.N ) THEN
IF( T( J+1, J ).NE.ZERO ) THEN
J2 = J + 1
JNEXT = J + 2
END IF
END IF
*
IF( J1.EQ.J2 ) THEN
*
* 1 by 1 diagonal block
*
* Scale if necessary to avoid overflow in forming the
* right-hand side element by inner product.
*
XJ = ABS( X( J1 ) )
IF( XMAX.GT.ONE ) THEN
REC = ONE / XMAX
IF( WORK( J1 ).GT.( BIGNUM-XJ )*REC ) THEN
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
*
X( J1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X, 1 )
*
XJ = ABS( X( J1 ) )
TJJ = ABS( T( J1, J1 ) )
TMP = T( J1, J1 )
IF( TJJ.LT.SMIN ) THEN
TMP = SMIN
TJJ = SMIN
INFO = 1
END IF
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.BIGNUM*TJJ ) THEN
REC = ONE / XJ
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
X( J1 ) = X( J1 ) / TMP
XMAX = MAX( XMAX, ABS( X( J1 ) ) )
*
ELSE
*
* 2 by 2 diagonal block
*
* Scale if necessary to avoid overflow in forming the
* right-hand side elements by inner product.
*
XJ = MAX( ABS( X( J1 ) ), ABS( X( J2 ) ) )
IF( XMAX.GT.ONE ) THEN
REC = ONE / XMAX
IF( MAX( WORK( J2 ), WORK( J1 ) ).GT.( BIGNUM-XJ )*
$ REC ) THEN
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
*
D( 1, 1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X,
$ 1 )
D( 2, 1 ) = X( J2 ) - DDOT( J1-1, T( 1, J2 ), 1, X,
$ 1 )
*
CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, T( J1, J1 ),
$ LDT, ONE, ONE, D, 2, ZERO, ZERO, V, 2,
$ SCALOC, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 2
*
IF( SCALOC.NE.ONE ) THEN
CALL DSCAL( N, SCALOC, X, 1 )
SCALE = SCALE*SCALOC
END IF
X( J1 ) = V( 1, 1 )
X( J2 ) = V( 2, 1 )
XMAX = MAX( ABS( X( J1 ) ), ABS( X( J2 ) ), XMAX )
*
END IF
40 CONTINUE
END IF
*
ELSE
*
SMINW = MAX( EPS*ABS( W ), SMIN )
IF( NOTRAN ) THEN
*
* Solve (T + iB)*(p+iq) = c+id
*
JNEXT = N
DO 70 J = N, 1, -1
IF( J.GT.JNEXT )
$ GO TO 70
J1 = J
J2 = J
JNEXT = J - 1
IF( J.GT.1 ) THEN
IF( T( J, J-1 ).NE.ZERO ) THEN
J1 = J - 1
JNEXT = J - 2
END IF
END IF
*
IF( J1.EQ.J2 ) THEN
*
* 1 by 1 diagonal block
*
* Scale if necessary to avoid overflow in division
*
Z = W
IF( J1.EQ.1 )
$ Z = B( 1 )
XJ = ABS( X( J1 ) ) + ABS( X( N+J1 ) )
TJJ = ABS( T( J1, J1 ) ) + ABS( Z )
TMP = T( J1, J1 )
IF( TJJ.LT.SMINW ) THEN
TMP = SMINW
TJJ = SMINW
INFO = 1
END IF
*
IF( XJ.EQ.ZERO )
$ GO TO 70
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.BIGNUM*TJJ ) THEN
REC = ONE / XJ
CALL DSCAL( N2, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
CALL DLADIV( X( J1 ), X( N+J1 ), TMP, Z, SR, SI )
X( J1 ) = SR
X( N+J1 ) = SI
XJ = ABS( X( J1 ) ) + ABS( X( N+J1 ) )
*
* Scale x if necessary to avoid overflow when adding a
* multiple of column j1 of T.
*
IF( XJ.GT.ONE ) THEN
REC = ONE / XJ
IF( WORK( J1 ).GT.( BIGNUM-XMAX )*REC ) THEN
CALL DSCAL( N2, REC, X, 1 )
SCALE = SCALE*REC
END IF
END IF
*
IF( J1.GT.1 ) THEN
CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
CALL DAXPY( J1-1, -X( N+J1 ), T( 1, J1 ), 1,
$ X( N+1 ), 1 )
*
X( 1 ) = X( 1 ) + B( J1 )*X( N+J1 )
X( N+1 ) = X( N+1 ) - B( J1 )*X( J1 )
*
XMAX = ZERO
DO 50 K = 1, J1 - 1
XMAX = MAX( XMAX, ABS( X( K ) )+
$ ABS( X( K+N ) ) )
50 CONTINUE
END IF
*
ELSE
*
* Meet 2 by 2 diagonal block
*
D( 1, 1 ) = X( J1 )
D( 2, 1 ) = X( J2 )
D( 1, 2 ) = X( N+J1 )
D( 2, 2 ) = X( N+J2 )
CALL DLALN2( .FALSE., 2, 2, SMINW, ONE, T( J1, J1 ),
$ LDT, ONE, ONE, D, 2, ZERO, -W, V, 2,
$ SCALOC, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 2
*
IF( SCALOC.NE.ONE ) THEN
CALL DSCAL( 2*N, SCALOC, X, 1 )
SCALE = SCALOC*SCALE
END IF
X( J1 ) = V( 1, 1 )
X( J2 ) = V( 2, 1 )
X( N+J1 ) = V( 1, 2 )
X( N+J2 ) = V( 2, 2 )
*
* Scale X(J1), .... to avoid overflow in
* updating right hand side.
*
XJ = MAX( ABS( V( 1, 1 ) )+ABS( V( 1, 2 ) ),
$ ABS( V( 2, 1 ) )+ABS( V( 2, 2 ) ) )
IF( XJ.GT.ONE ) THEN
REC = ONE / XJ
IF( MAX( WORK( J1 ), WORK( J2 ) ).GT.
$ ( BIGNUM-XMAX )*REC ) THEN
CALL DSCAL( N2, REC, X, 1 )
SCALE = SCALE*REC
END IF
END IF
*
* Update the right-hand side.
*
IF( J1.GT.1 ) THEN
CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
CALL DAXPY( J1-1, -X( J2 ), T( 1, J2 ), 1, X, 1 )
*
CALL DAXPY( J1-1, -X( N+J1 ), T( 1, J1 ), 1,
$ X( N+1 ), 1 )
CALL DAXPY( J1-1, -X( N+J2 ), T( 1, J2 ), 1,
$ X( N+1 ), 1 )
*
X( 1 ) = X( 1 ) + B( J1 )*X( N+J1 ) +
$ B( J2 )*X( N+J2 )
X( N+1 ) = X( N+1 ) - B( J1 )*X( J1 ) -
$ B( J2 )*X( J2 )
*
XMAX = ZERO
DO 60 K = 1, J1 - 1
XMAX = MAX( ABS( X( K ) )+ABS( X( K+N ) ),
$ XMAX )
60 CONTINUE
END IF
*
END IF
70 CONTINUE
*
ELSE
*
* Solve (T + iB)'*(p+iq) = c+id
*
JNEXT = 1
DO 80 J = 1, N
IF( J.LT.JNEXT )
$ GO TO 80
J1 = J
J2 = J
JNEXT = J + 1
IF( J.LT.N ) THEN
IF( T( J+1, J ).NE.ZERO ) THEN
J2 = J + 1
JNEXT = J + 2
END IF
END IF
*
IF( J1.EQ.J2 ) THEN
*
* 1 by 1 diagonal block
*
* Scale if necessary to avoid overflow in forming the
* right-hand side element by inner product.
*
XJ = ABS( X( J1 ) ) + ABS( X( J1+N ) )
IF( XMAX.GT.ONE ) THEN
REC = ONE / XMAX
IF( WORK( J1 ).GT.( BIGNUM-XJ )*REC ) THEN
CALL DSCAL( N2, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
*
X( J1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X, 1 )
X( N+J1 ) = X( N+J1 ) - DDOT( J1-1, T( 1, J1 ), 1,
$ X( N+1 ), 1 )
IF( J1.GT.1 ) THEN
X( J1 ) = X( J1 ) - B( J1 )*X( N+1 )
X( N+J1 ) = X( N+J1 ) + B( J1 )*X( 1 )
END IF
XJ = ABS( X( J1 ) ) + ABS( X( J1+N ) )
*
Z = W
IF( J1.EQ.1 )
$ Z = B( 1 )
*
* Scale if necessary to avoid overflow in
* complex division
*
TJJ = ABS( T( J1, J1 ) ) + ABS( Z )
TMP = T( J1, J1 )
IF( TJJ.LT.SMINW ) THEN
TMP = SMINW
TJJ = SMINW
INFO = 1
END IF
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.BIGNUM*TJJ ) THEN
REC = ONE / XJ
CALL DSCAL( N2, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
CALL DLADIV( X( J1 ), X( N+J1 ), TMP, -Z, SR, SI )
X( J1 ) = SR
X( J1+N ) = SI
XMAX = MAX( ABS( X( J1 ) )+ABS( X( J1+N ) ), XMAX )
*
ELSE
*
* 2 by 2 diagonal block
*
* Scale if necessary to avoid overflow in forming the
* right-hand side element by inner product.
*
XJ = MAX( ABS( X( J1 ) )+ABS( X( N+J1 ) ),
$ ABS( X( J2 ) )+ABS( X( N+J2 ) ) )
IF( XMAX.GT.ONE ) THEN
REC = ONE / XMAX
IF( MAX( WORK( J1 ), WORK( J2 ) ).GT.
$ ( BIGNUM-XJ ) / XMAX ) THEN
CALL DSCAL( N2, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
*
D( 1, 1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X,
$ 1 )
D( 2, 1 ) = X( J2 ) - DDOT( J1-1, T( 1, J2 ), 1, X,
$ 1 )
D( 1, 2 ) = X( N+J1 ) - DDOT( J1-1, T( 1, J1 ), 1,
$ X( N+1 ), 1 )
D( 2, 2 ) = X( N+J2 ) - DDOT( J1-1, T( 1, J2 ), 1,
$ X( N+1 ), 1 )
D( 1, 1 ) = D( 1, 1 ) - B( J1 )*X( N+1 )
D( 2, 1 ) = D( 2, 1 ) - B( J2 )*X( N+1 )
D( 1, 2 ) = D( 1, 2 ) + B( J1 )*X( 1 )
D( 2, 2 ) = D( 2, 2 ) + B( J2 )*X( 1 )
*
CALL DLALN2( .TRUE., 2, 2, SMINW, ONE, T( J1, J1 ),
$ LDT, ONE, ONE, D, 2, ZERO, W, V, 2,
$ SCALOC, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 2
*
IF( SCALOC.NE.ONE ) THEN
CALL DSCAL( N2, SCALOC, X, 1 )
SCALE = SCALOC*SCALE
END IF
X( J1 ) = V( 1, 1 )
X( J2 ) = V( 2, 1 )
X( N+J1 ) = V( 1, 2 )
X( N+J2 ) = V( 2, 2 )
XMAX = MAX( ABS( X( J1 ) )+ABS( X( N+J1 ) ),
$ ABS( X( J2 ) )+ABS( X( N+J2 ) ), XMAX )
*
END IF
*
80 CONTINUE
*
END IF
*
END IF
*
RETURN
*
* End of DLAQTR
*
END
SUBROUTINE DLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD,
$ PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA,
$ R, ISUPPZ, NRMINV, RESID, RQCORR, WORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL WANTNC
INTEGER B1, BN, N, NEGCNT, R
DOUBLE PRECISION GAPTOL, LAMBDA, MINGMA, NRMINV, PIVMIN, RESID,
$ RQCORR, ZTZ
* ..
* .. Array Arguments ..
INTEGER ISUPPZ( * )
DOUBLE PRECISION D( * ), L( * ), LD( * ), LLD( * ),
$ WORK( * )
DOUBLE PRECISION Z( * )
* ..
*
* Purpose
* =======
*
* DLAR1V computes the (scaled) r-th column of the inverse of
* the sumbmatrix in rows B1 through BN of the tridiagonal matrix
* L D L^T - sigma I. When sigma is close to an eigenvalue, the
* computed vector is an accurate eigenvector. Usually, r corresponds
* to the index where the eigenvector is largest in magnitude.
* The following steps accomplish this computation :
* (a) Stationary qd transform, L D L^T - sigma I = L(+) D(+) L(+)^T,
* (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T,
* (c) Computation of the diagonal elements of the inverse of
* L D L^T - sigma I by combining the above transforms, and choosing
* r as the index where the diagonal of the inverse is (one of the)
* largest in magnitude.
* (d) Computation of the (scaled) r-th column of the inverse using the
* twisted factorization obtained by combining the top part of the
* the stationary and the bottom part of the progressive transform.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix L D L^T.
*
* B1 (input) INTEGER
* First index of the submatrix of L D L^T.
*
* BN (input) INTEGER
* Last index of the submatrix of L D L^T.
*
* LAMBDA (input) DOUBLE PRECISION
* The shift. In order to compute an accurate eigenvector,
* LAMBDA should be a good approximation to an eigenvalue
* of L D L^T.
*
* L (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) subdiagonal elements of the unit bidiagonal matrix
* L, in elements 1 to N-1.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the diagonal matrix D.
*
* LD (input) DOUBLE PRECISION array, dimension (N-1)
* The n-1 elements L(i)*D(i).
*
* LLD (input) DOUBLE PRECISION array, dimension (N-1)
* The n-1 elements L(i)*L(i)*D(i).
*
* PIVMIN (input) DOUBLE PRECISION
* The minimum pivot in the Sturm sequence.
*
* GAPTOL (input) DOUBLE PRECISION
* Tolerance that indicates when eigenvector entries are negligible
* w.r.t. their contribution to the residual.
*
* Z (input/output) DOUBLE PRECISION array, dimension (N)
* On input, all entries of Z must be set to 0.
* On output, Z contains the (scaled) r-th column of the
* inverse. The scaling is such that Z(R) equals 1.
*
* WANTNC (input) LOGICAL
* Specifies whether NEGCNT has to be computed.
*
* NEGCNT (output) INTEGER
* If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin
* in the matrix factorization L D L^T, and NEGCNT = -1 otherwise.
*
* ZTZ (output) DOUBLE PRECISION
* The square of the 2-norm of Z.
*
* MINGMA (output) DOUBLE PRECISION
* The reciprocal of the largest (in magnitude) diagonal
* element of the inverse of L D L^T - sigma I.
*
* R (input/output) INTEGER
* The twist index for the twisted factorization used to
* compute Z.
* On input, 0 <= R <= N. If R is input as 0, R is set to
* the index where (L D L^T - sigma I)^{-1} is largest
* in magnitude. If 1 <= R <= N, R is unchanged.
* On output, R contains the twist index used to compute Z.
* Ideally, R designates the position of the maximum entry in the
* eigenvector.
*
* ISUPPZ (output) INTEGER array, dimension (2)
* The support of the vector in Z, i.e., the vector Z is
* nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ).
*
* NRMINV (output) DOUBLE PRECISION
* NRMINV = 1/SQRT( ZTZ )
*
* RESID (output) DOUBLE PRECISION
* The residual of the FP vector.
* RESID = ABS( MINGMA )/SQRT( ZTZ )
*
* RQCORR (output) DOUBLE PRECISION
* The Rayleigh Quotient correction to LAMBDA.
* RQCORR = MINGMA*TMP
*
* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL SAWNAN1, SAWNAN2
INTEGER I, INDLPL, INDP, INDS, INDUMN, NEG1, NEG2, R1,
$ R2
DOUBLE PRECISION DMINUS, DPLUS, EPS, S, TMP
* ..
* .. External Functions ..
LOGICAL DISNAN
DOUBLE PRECISION DLAMCH
EXTERNAL DISNAN, DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
EPS = DLAMCH( 'Precision' )
IF( R.EQ.0 ) THEN
R1 = B1
R2 = BN
ELSE
R1 = R
R2 = R
END IF
* Storage for LPLUS
INDLPL = 0
* Storage for UMINUS
INDUMN = N
INDS = 2*N + 1
INDP = 3*N + 1
IF( B1.EQ.1 ) THEN
WORK( INDS ) = ZERO
ELSE
WORK( INDS+B1-1 ) = LLD( B1-1 )
END IF
*
* Compute the stationary transform (using the differential form)
* until the index R2.
*
SAWNAN1 = .FALSE.
NEG1 = 0
S = WORK( INDS+B1-1 ) - LAMBDA
DO 50 I = B1, R1 - 1
DPLUS = D( I ) + S
WORK( INDLPL+I ) = LD( I ) / DPLUS
IF(DPLUS.LT.ZERO) NEG1 = NEG1 + 1
WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
S = WORK( INDS+I ) - LAMBDA
50 CONTINUE
SAWNAN1 = DISNAN( S )
IF( SAWNAN1 ) GOTO 60
DO 51 I = R1, R2 - 1
DPLUS = D( I ) + S
WORK( INDLPL+I ) = LD( I ) / DPLUS
WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
S = WORK( INDS+I ) - LAMBDA
51 CONTINUE
SAWNAN1 = DISNAN( S )
*
60 CONTINUE
IF( SAWNAN1 ) THEN
* Runs a slower version of the above loop if a NaN is detected
NEG1 = 0
S = WORK( INDS+B1-1 ) - LAMBDA
DO 70 I = B1, R1 - 1
DPLUS = D( I ) + S
IF(ABS(DPLUS).LT.PIVMIN) DPLUS = -PIVMIN
WORK( INDLPL+I ) = LD( I ) / DPLUS
IF(DPLUS.LT.ZERO) NEG1 = NEG1 + 1
WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
IF( WORK( INDLPL+I ).EQ.ZERO )
$ WORK( INDS+I ) = LLD( I )
S = WORK( INDS+I ) - LAMBDA
70 CONTINUE
DO 71 I = R1, R2 - 1
DPLUS = D( I ) + S
IF(ABS(DPLUS).LT.PIVMIN) DPLUS = -PIVMIN
WORK( INDLPL+I ) = LD( I ) / DPLUS
WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
IF( WORK( INDLPL+I ).EQ.ZERO )
$ WORK( INDS+I ) = LLD( I )
S = WORK( INDS+I ) - LAMBDA
71 CONTINUE
END IF
*
* Compute the progressive transform (using the differential form)
* until the index R1
*
SAWNAN2 = .FALSE.
NEG2 = 0
WORK( INDP+BN-1 ) = D( BN ) - LAMBDA
DO 80 I = BN - 1, R1, -1
DMINUS = LLD( I ) + WORK( INDP+I )
TMP = D( I ) / DMINUS
IF(DMINUS.LT.ZERO) NEG2 = NEG2 + 1
WORK( INDUMN+I ) = L( I )*TMP
WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - LAMBDA
80 CONTINUE
TMP = WORK( INDP+R1-1 )
SAWNAN2 = DISNAN( TMP )
IF( SAWNAN2 ) THEN
* Runs a slower version of the above loop if a NaN is detected
NEG2 = 0
DO 100 I = BN-1, R1, -1
DMINUS = LLD( I ) + WORK( INDP+I )
IF(ABS(DMINUS).LT.PIVMIN) DMINUS = -PIVMIN
TMP = D( I ) / DMINUS
IF(DMINUS.LT.ZERO) NEG2 = NEG2 + 1
WORK( INDUMN+I ) = L( I )*TMP
WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - LAMBDA
IF( TMP.EQ.ZERO )
$ WORK( INDP+I-1 ) = D( I ) - LAMBDA
100 CONTINUE
END IF
*
* Find the index (from R1 to R2) of the largest (in magnitude)
* diagonal element of the inverse
*
MINGMA = WORK( INDS+R1-1 ) + WORK( INDP+R1-1 )
IF( MINGMA.LT.ZERO ) NEG1 = NEG1 + 1
IF( WANTNC ) THEN
NEGCNT = NEG1 + NEG2
ELSE
NEGCNT = -1
ENDIF
IF( ABS(MINGMA).EQ.ZERO )
$ MINGMA = EPS*WORK( INDS+R1-1 )
R = R1
DO 110 I = R1, R2 - 1
TMP = WORK( INDS+I ) + WORK( INDP+I )
IF( TMP.EQ.ZERO )
$ TMP = EPS*WORK( INDS+I )
IF( ABS( TMP ).LE.ABS( MINGMA ) ) THEN
MINGMA = TMP
R = I + 1
END IF
110 CONTINUE
*
* Compute the FP vector: solve N^T v = e_r
*
ISUPPZ( 1 ) = B1
ISUPPZ( 2 ) = BN
Z( R ) = ONE
ZTZ = ONE
*
* Compute the FP vector upwards from R
*
IF( .NOT.SAWNAN1 .AND. .NOT.SAWNAN2 ) THEN
DO 210 I = R-1, B1, -1
Z( I ) = -( WORK( INDLPL+I )*Z( I+1 ) )
IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
$ THEN
Z( I ) = ZERO
ISUPPZ( 1 ) = I + 1
GOTO 220
ENDIF
ZTZ = ZTZ + Z( I )*Z( I )
210 CONTINUE
220 CONTINUE
ELSE
* Run slower loop if NaN occurred.
DO 230 I = R - 1, B1, -1
IF( Z( I+1 ).EQ.ZERO ) THEN
Z( I ) = -( LD( I+1 ) / LD( I ) )*Z( I+2 )
ELSE
Z( I ) = -( WORK( INDLPL+I )*Z( I+1 ) )
END IF
IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
$ THEN
Z( I ) = ZERO
ISUPPZ( 1 ) = I + 1
GO TO 240
END IF
ZTZ = ZTZ + Z( I )*Z( I )
230 CONTINUE
240 CONTINUE
ENDIF
* Compute the FP vector downwards from R in blocks of size BLKSIZ
IF( .NOT.SAWNAN1 .AND. .NOT.SAWNAN2 ) THEN
DO 250 I = R, BN-1
Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) )
IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
$ THEN
Z( I+1 ) = ZERO
ISUPPZ( 2 ) = I
GO TO 260
END IF
ZTZ = ZTZ + Z( I+1 )*Z( I+1 )
250 CONTINUE
260 CONTINUE
ELSE
* Run slower loop if NaN occurred.
DO 270 I = R, BN - 1
IF( Z( I ).EQ.ZERO ) THEN
Z( I+1 ) = -( LD( I-1 ) / LD( I ) )*Z( I-1 )
ELSE
Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) )
END IF
IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
$ THEN
Z( I+1 ) = ZERO
ISUPPZ( 2 ) = I
GO TO 280
END IF
ZTZ = ZTZ + Z( I+1 )*Z( I+1 )
270 CONTINUE
280 CONTINUE
END IF
*
* Compute quantities for convergence test
*
TMP = ONE / ZTZ
NRMINV = SQRT( TMP )
RESID = ABS( MINGMA )*NRMINV
RQCORR = MINGMA*TMP
*
*
RETURN
*
* End of DLAR1V
*
END
SUBROUTINE DLAR2V( N, X, Y, Z, INCX, C, S, INCC )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INCC, INCX, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION C( * ), S( * ), X( * ), Y( * ), Z( * )
* ..
*
* Purpose
* =======
*
* DLAR2V applies a vector of real plane rotations from both sides to
* a sequence of 2-by-2 real symmetric matrices, defined by the elements
* of the vectors x, y and z. For i = 1,2,...,n
*
* ( x(i) z(i) ) := ( c(i) s(i) ) ( x(i) z(i) ) ( c(i) -s(i) )
* ( z(i) y(i) ) ( -s(i) c(i) ) ( z(i) y(i) ) ( s(i) c(i) )
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of plane rotations to be applied.
*
* X (input/output) DOUBLE PRECISION array,
* dimension (1+(N-1)*INCX)
* The vector x.
*
* Y (input/output) DOUBLE PRECISION array,
* dimension (1+(N-1)*INCX)
* The vector y.
*
* Z (input/output) DOUBLE PRECISION array,
* dimension (1+(N-1)*INCX)
* The vector z.
*
* INCX (input) INTEGER
* The increment between elements of X, Y and Z. INCX > 0.
*
* C (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
* The cosines of the plane rotations.
*
* S (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
* The sines of the plane rotations.
*
* INCC (input) INTEGER
* The increment between elements of C and S. INCC > 0.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, IC, IX
DOUBLE PRECISION CI, SI, T1, T2, T3, T4, T5, T6, XI, YI, ZI
* ..
* .. Executable Statements ..
*
IX = 1
IC = 1
DO 10 I = 1, N
XI = X( IX )
YI = Y( IX )
ZI = Z( IX )
CI = C( IC )
SI = S( IC )
T1 = SI*ZI
T2 = CI*ZI
T3 = T2 - SI*XI
T4 = T2 + SI*YI
T5 = CI*XI + T1
T6 = CI*YI - T1
X( IX ) = CI*T5 + SI*T4
Y( IX ) = CI*T6 - SI*T3
Z( IX ) = CI*T4 - SI*T5
IX = IX + INCX
IC = IC + INCC
10 CONTINUE
*
* End of DLAR2V
*
RETURN
END
SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. 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'
*
* 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 )
* ..
* .. External Subroutines ..
EXTERNAL DGEMV, DGER
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Executable Statements ..
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form H * C
*
IF( TAU.NE.ZERO ) THEN
*
* w := C' * v
*
CALL DGEMV( 'Transpose', M, N, ONE, C, LDC, V, INCV, ZERO,
$ WORK, 1 )
*
* C := C - v * w'
*
CALL DGER( M, N, -TAU, V, INCV, WORK, 1, C, LDC )
END IF
ELSE
*
* Form C * H
*
IF( TAU.NE.ZERO ) THEN
*
* w := C * v
*
CALL DGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV,
$ ZERO, WORK, 1 )
*
* C := C - w * v'
*
CALL DGER( M, N, -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 )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. 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' 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' from the Left
* = 'R': apply H or H' from the Right
*
* TRANS (input) CHARACTER*1
* = 'N': apply H (No transpose)
* = 'T': apply H' (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'*C or C*H or C*H'.
*
* LDC (input) INTEGER
* The leading dimension of the array C. LDA >= 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).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
CHARACTER TRANST
INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. 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' * C where C = ( C1 )
* ( C2 )
*
* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK)
*
* W := C1'
*
DO 10 J = 1, K
CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
10 CONTINUE
*
* W := W * V1
*
CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
$ K, ONE, V, LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C2'*V2
*
CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K,
$ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV,
$ ONE, WORK, LDWORK )
END IF
*
* W := W * T' or W * T
*
CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W'
*
IF( M.GT.K ) THEN
*
* C2 := C2 - V2 * W'
*
CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K,
$ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE,
$ C( K+1, 1 ), LDC )
END IF
*
* W := W * V1'
*
CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
$ ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W'
*
DO 30 J = 1, K
DO 20 I = 1, N
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' where C = ( C1 C2 )
*
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
*
* W := C1
*
DO 40 J = 1, K
CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
40 CONTINUE
*
* W := W * V1
*
CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
$ K, ONE, V, LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C2 * V2
*
CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K,
$ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
$ ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T'
*
CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V'
*
IF( N.GT.K ) THEN
*
* C2 := C2 - W * V2'
*
CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K,
$ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE,
$ C( 1, K+1 ), LDC )
END IF
*
* W := W * V1'
*
CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
$ ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 60 J = 1, K
DO 50 I = 1, M
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' * C where C = ( C1 )
* ( C2 )
*
* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK)
*
* W := C2'
*
DO 70 J = 1, K
CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
70 CONTINUE
*
* W := W * V2
*
CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
$ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C1'*V1
*
CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K,
$ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T' or W * T
*
CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W'
*
IF( M.GT.K ) THEN
*
* C1 := C1 - V1 * W'
*
CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K,
$ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
END IF
*
* W := W * V2'
*
CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
$ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
*
* C2 := C2 - W'
*
DO 90 J = 1, K
DO 80 I = 1, N
C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
80 CONTINUE
90 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H' where C = ( C1 C2 )
*
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
*
* W := C2
*
DO 100 J = 1, K
CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
100 CONTINUE
*
* W := W * V2
*
CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
$ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C1 * V1
*
CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K,
$ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T'
*
CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V'
*
IF( N.GT.K ) THEN
*
* C1 := C1 - W * V1'
*
CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K,
$ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
END IF
*
* W := W * V2'
*
CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
$ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
*
* C2 := C2 - W
*
DO 120 J = 1, K
DO 110 I = 1, M
C( I, N-K+J ) = C( I, N-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' * C where C = ( C1 )
* ( C2 )
*
* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK)
*
* W := C1'
*
DO 130 J = 1, K
CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
130 CONTINUE
*
* W := W * V1'
*
CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
$ ONE, V, LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C2'*V2'
*
CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
$ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE,
$ WORK, LDWORK )
END IF
*
* W := W * T' or W * T
*
CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V' * W'
*
IF( M.GT.K ) THEN
*
* C2 := C2 - V2' * W'
*
CALL DGEMM( 'Transpose', 'Transpose', M-K, N, 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', N,
$ K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W'
*
DO 150 J = 1, K
DO 140 I = 1, N
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' where C = ( C1 C2 )
*
* W := C * V' = (C1*V1' + C2*V2') (stored in WORK)
*
* W := C1
*
DO 160 J = 1, K
CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
160 CONTINUE
*
* W := W * V1'
*
CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
$ ONE, V, LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C2 * V2'
*
CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K,
$ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV,
$ ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T'
*
CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V
*
IF( N.GT.K ) THEN
*
* C2 := C2 - W * V2
*
CALL DGEMM( 'No transpose', 'No transpose', M, N-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', M,
$ K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 180 J = 1, K
DO 170 I = 1, M
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' * C where C = ( C1 )
* ( C2 )
*
* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK)
*
* W := C2'
*
DO 190 J = 1, K
CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
190 CONTINUE
*
* W := W * V2'
*
CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
$ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C1'*V1'
*
CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
$ C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T' or W * T
*
CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V' * W'
*
IF( M.GT.K ) THEN
*
* C1 := C1 - V1' * W'
*
CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
$ V, LDV, WORK, LDWORK, ONE, C, LDC )
END IF
*
* W := W * V2
*
CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
$ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
*
* C2 := C2 - W'
*
DO 210 J = 1, K
DO 200 I = 1, N
C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
200 CONTINUE
210 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H' where C = ( C1 C2 )
*
* W := C * V' = (C1*V1' + C2*V2') (stored in WORK)
*
* W := C2
*
DO 220 J = 1, K
CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
220 CONTINUE
*
* W := W * V2'
*
CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
$ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C1 * V1'
*
CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K,
$ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T'
*
CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V
*
IF( N.GT.K ) THEN
*
* C1 := C1 - W * V1
*
CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K,
$ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
END IF
*
* W := W * V2
*
CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
$ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 240 J = 1, K
DO 230 I = 1, M
C( I, N-K+J ) = C( I, N-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.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. 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' * 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' ) ,
* ( 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' )
IF( ABS( BETA ).LT.SAFMIN ) THEN
*
* XNORM, BETA may be inaccurate; scale X and recompute them
*
RSAFMN = ONE / SAFMIN
KNT = 0
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 )
TAU = ( BETA-ALPHA ) / BETA
CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
*
* If ALPHA is subnormal, it may lose relative accuracy
*
ALPHA = BETA
DO 20 J = 1, KNT
ALPHA = ALPHA*SAFMIN
20 CONTINUE
ELSE
TAU = ( BETA-ALPHA ) / BETA
CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
ALPHA = BETA
END IF
END IF
*
RETURN
*
* End of DLARFG
*
END
SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. 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'
*
* 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 * 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
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
DO 20 I = 1, K
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
*
* T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i)
*
CALL DGEMV( 'Transpose', N-I+1, I-1, -TAU( I ),
$ V( I, 1 ), LDV, V( I, I ), 1, ZERO,
$ T( 1, I ), 1 )
ELSE
*
* T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)'
*
CALL DGEMV( 'No transpose', I-1, N-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 )
END IF
20 CONTINUE
ELSE
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
*
* T(i+1:k,i) :=
* - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i)
*
CALL DGEMV( 'Transpose', N-K+I, K-I, -TAU( I ),
$ V( 1, I+1 ), LDV, V( 1, 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
*
* T(i+1:k,i) :=
* - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)'
*
CALL DGEMV( 'No transpose', K-I, N-K+I, -TAU( I ),
$ V( I+1, 1 ), LDV, V( I, 1 ), 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 )
END IF
T( I, I ) = TAU( I )
END IF
40 CONTINUE
END IF
RETURN
*
* End of DLARFT
*
END
SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE
INTEGER LDC, M, N
DOUBLE PRECISION TAU
* ..
* .. Array Arguments ..
DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLARFX 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'
*
* where tau is a real scalar and v is a real vector.
*
* If tau = 0, then H is taken to be the unit matrix
*
* This version uses inline code if H has order < 11.
*
* 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 (M) if SIDE = 'L'
* or (N) if SIDE = 'R'
* The vector v in the representation of H.
*
* 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. LDA >= (1,M).
*
* WORK (workspace) DOUBLE PRECISION array, dimension
* (N) if SIDE = 'L'
* or (M) if SIDE = 'R'
* WORK is not referenced if H has order < 11.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER J
DOUBLE PRECISION SUM, T1, T10, T2, T3, T4, T5, T6, T7, T8, T9,
$ V1, V10, V2, V3, V4, V5, V6, V7, V8, V9
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DGEMV, DGER
* ..
* .. Executable Statements ..
*
IF( TAU.EQ.ZERO )
$ RETURN
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form H * C, where H has order m.
*
GO TO ( 10, 30, 50, 70, 90, 110, 130, 150,
$ 170, 190 )M
*
* Code for general M
*
* w := C'*v
*
CALL DGEMV( 'Transpose', M, N, ONE, C, LDC, V, 1, ZERO, WORK,
$ 1 )
*
* C := C - tau * v * w'
*
CALL DGER( M, N, -TAU, V, 1, WORK, 1, C, LDC )
GO TO 410
10 CONTINUE
*
* Special code for 1 x 1 Householder
*
T1 = ONE - TAU*V( 1 )*V( 1 )
DO 20 J = 1, N
C( 1, J ) = T1*C( 1, J )
20 CONTINUE
GO TO 410
30 CONTINUE
*
* Special code for 2 x 2 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
DO 40 J = 1, N
SUM = V1*C( 1, J ) + V2*C( 2, J )
C( 1, J ) = C( 1, J ) - SUM*T1
C( 2, J ) = C( 2, J ) - SUM*T2
40 CONTINUE
GO TO 410
50 CONTINUE
*
* Special code for 3 x 3 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
DO 60 J = 1, N
SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J )
C( 1, J ) = C( 1, J ) - SUM*T1
C( 2, J ) = C( 2, J ) - SUM*T2
C( 3, J ) = C( 3, J ) - SUM*T3
60 CONTINUE
GO TO 410
70 CONTINUE
*
* Special code for 4 x 4 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
V4 = V( 4 )
T4 = TAU*V4
DO 80 J = 1, N
SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
$ V4*C( 4, J )
C( 1, J ) = C( 1, J ) - SUM*T1
C( 2, J ) = C( 2, J ) - SUM*T2
C( 3, J ) = C( 3, J ) - SUM*T3
C( 4, J ) = C( 4, J ) - SUM*T4
80 CONTINUE
GO TO 410
90 CONTINUE
*
* Special code for 5 x 5 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
V4 = V( 4 )
T4 = TAU*V4
V5 = V( 5 )
T5 = TAU*V5
DO 100 J = 1, N
SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
$ V4*C( 4, J ) + V5*C( 5, J )
C( 1, J ) = C( 1, J ) - SUM*T1
C( 2, J ) = C( 2, J ) - SUM*T2
C( 3, J ) = C( 3, J ) - SUM*T3
C( 4, J ) = C( 4, J ) - SUM*T4
C( 5, J ) = C( 5, J ) - SUM*T5
100 CONTINUE
GO TO 410
110 CONTINUE
*
* Special code for 6 x 6 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
V4 = V( 4 )
T4 = TAU*V4
V5 = V( 5 )
T5 = TAU*V5
V6 = V( 6 )
T6 = TAU*V6
DO 120 J = 1, N
SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
$ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J )
C( 1, J ) = C( 1, J ) - SUM*T1
C( 2, J ) = C( 2, J ) - SUM*T2
C( 3, J ) = C( 3, J ) - SUM*T3
C( 4, J ) = C( 4, J ) - SUM*T4
C( 5, J ) = C( 5, J ) - SUM*T5
C( 6, J ) = C( 6, J ) - SUM*T6
120 CONTINUE
GO TO 410
130 CONTINUE
*
* Special code for 7 x 7 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
V4 = V( 4 )
T4 = TAU*V4
V5 = V( 5 )
T5 = TAU*V5
V6 = V( 6 )
T6 = TAU*V6
V7 = V( 7 )
T7 = TAU*V7
DO 140 J = 1, N
SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
$ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
$ V7*C( 7, J )
C( 1, J ) = C( 1, J ) - SUM*T1
C( 2, J ) = C( 2, J ) - SUM*T2
C( 3, J ) = C( 3, J ) - SUM*T3
C( 4, J ) = C( 4, J ) - SUM*T4
C( 5, J ) = C( 5, J ) - SUM*T5
C( 6, J ) = C( 6, J ) - SUM*T6
C( 7, J ) = C( 7, J ) - SUM*T7
140 CONTINUE
GO TO 410
150 CONTINUE
*
* Special code for 8 x 8 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
V4 = V( 4 )
T4 = TAU*V4
V5 = V( 5 )
T5 = TAU*V5
V6 = V( 6 )
T6 = TAU*V6
V7 = V( 7 )
T7 = TAU*V7
V8 = V( 8 )
T8 = TAU*V8
DO 160 J = 1, N
SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
$ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
$ V7*C( 7, J ) + V8*C( 8, J )
C( 1, J ) = C( 1, J ) - SUM*T1
C( 2, J ) = C( 2, J ) - SUM*T2
C( 3, J ) = C( 3, J ) - SUM*T3
C( 4, J ) = C( 4, J ) - SUM*T4
C( 5, J ) = C( 5, J ) - SUM*T5
C( 6, J ) = C( 6, J ) - SUM*T6
C( 7, J ) = C( 7, J ) - SUM*T7
C( 8, J ) = C( 8, J ) - SUM*T8
160 CONTINUE
GO TO 410
170 CONTINUE
*
* Special code for 9 x 9 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
V4 = V( 4 )
T4 = TAU*V4
V5 = V( 5 )
T5 = TAU*V5
V6 = V( 6 )
T6 = TAU*V6
V7 = V( 7 )
T7 = TAU*V7
V8 = V( 8 )
T8 = TAU*V8
V9 = V( 9 )
T9 = TAU*V9
DO 180 J = 1, N
SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
$ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
$ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J )
C( 1, J ) = C( 1, J ) - SUM*T1
C( 2, J ) = C( 2, J ) - SUM*T2
C( 3, J ) = C( 3, J ) - SUM*T3
C( 4, J ) = C( 4, J ) - SUM*T4
C( 5, J ) = C( 5, J ) - SUM*T5
C( 6, J ) = C( 6, J ) - SUM*T6
C( 7, J ) = C( 7, J ) - SUM*T7
C( 8, J ) = C( 8, J ) - SUM*T8
C( 9, J ) = C( 9, J ) - SUM*T9
180 CONTINUE
GO TO 410
190 CONTINUE
*
* Special code for 10 x 10 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
V4 = V( 4 )
T4 = TAU*V4
V5 = V( 5 )
T5 = TAU*V5
V6 = V( 6 )
T6 = TAU*V6
V7 = V( 7 )
T7 = TAU*V7
V8 = V( 8 )
T8 = TAU*V8
V9 = V( 9 )
T9 = TAU*V9
V10 = V( 10 )
T10 = TAU*V10
DO 200 J = 1, N
SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
$ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
$ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) +
$ V10*C( 10, J )
C( 1, J ) = C( 1, J ) - SUM*T1
C( 2, J ) = C( 2, J ) - SUM*T2
C( 3, J ) = C( 3, J ) - SUM*T3
C( 4, J ) = C( 4, J ) - SUM*T4
C( 5, J ) = C( 5, J ) - SUM*T5
C( 6, J ) = C( 6, J ) - SUM*T6
C( 7, J ) = C( 7, J ) - SUM*T7
C( 8, J ) = C( 8, J ) - SUM*T8
C( 9, J ) = C( 9, J ) - SUM*T9
C( 10, J ) = C( 10, J ) - SUM*T10
200 CONTINUE
GO TO 410
ELSE
*
* Form C * H, where H has order n.
*
GO TO ( 210, 230, 250, 270, 290, 310, 330, 350,
$ 370, 390 )N
*
* Code for general N
*
* w := C * v
*
CALL DGEMV( 'No transpose', M, N, ONE, C, LDC, V, 1, ZERO,
$ WORK, 1 )
*
* C := C - tau * w * v'
*
CALL DGER( M, N, -TAU, WORK, 1, V, 1, C, LDC )
GO TO 410
210 CONTINUE
*
* Special code for 1 x 1 Householder
*
T1 = ONE - TAU*V( 1 )*V( 1 )
DO 220 J = 1, M
C( J, 1 ) = T1*C( J, 1 )
220 CONTINUE
GO TO 410
230 CONTINUE
*
* Special code for 2 x 2 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
DO 240 J = 1, M
SUM = V1*C( J, 1 ) + V2*C( J, 2 )
C( J, 1 ) = C( J, 1 ) - SUM*T1
C( J, 2 ) = C( J, 2 ) - SUM*T2
240 CONTINUE
GO TO 410
250 CONTINUE
*
* Special code for 3 x 3 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
DO 260 J = 1, M
SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 )
C( J, 1 ) = C( J, 1 ) - SUM*T1
C( J, 2 ) = C( J, 2 ) - SUM*T2
C( J, 3 ) = C( J, 3 ) - SUM*T3
260 CONTINUE
GO TO 410
270 CONTINUE
*
* Special code for 4 x 4 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
V4 = V( 4 )
T4 = TAU*V4
DO 280 J = 1, M
SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
$ V4*C( J, 4 )
C( J, 1 ) = C( J, 1 ) - SUM*T1
C( J, 2 ) = C( J, 2 ) - SUM*T2
C( J, 3 ) = C( J, 3 ) - SUM*T3
C( J, 4 ) = C( J, 4 ) - SUM*T4
280 CONTINUE
GO TO 410
290 CONTINUE
*
* Special code for 5 x 5 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
V4 = V( 4 )
T4 = TAU*V4
V5 = V( 5 )
T5 = TAU*V5
DO 300 J = 1, M
SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
$ V4*C( J, 4 ) + V5*C( J, 5 )
C( J, 1 ) = C( J, 1 ) - SUM*T1
C( J, 2 ) = C( J, 2 ) - SUM*T2
C( J, 3 ) = C( J, 3 ) - SUM*T3
C( J, 4 ) = C( J, 4 ) - SUM*T4
C( J, 5 ) = C( J, 5 ) - SUM*T5
300 CONTINUE
GO TO 410
310 CONTINUE
*
* Special code for 6 x 6 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
V4 = V( 4 )
T4 = TAU*V4
V5 = V( 5 )
T5 = TAU*V5
V6 = V( 6 )
T6 = TAU*V6
DO 320 J = 1, M
SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
$ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 )
C( J, 1 ) = C( J, 1 ) - SUM*T1
C( J, 2 ) = C( J, 2 ) - SUM*T2
C( J, 3 ) = C( J, 3 ) - SUM*T3
C( J, 4 ) = C( J, 4 ) - SUM*T4
C( J, 5 ) = C( J, 5 ) - SUM*T5
C( J, 6 ) = C( J, 6 ) - SUM*T6
320 CONTINUE
GO TO 410
330 CONTINUE
*
* Special code for 7 x 7 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
V4 = V( 4 )
T4 = TAU*V4
V5 = V( 5 )
T5 = TAU*V5
V6 = V( 6 )
T6 = TAU*V6
V7 = V( 7 )
T7 = TAU*V7
DO 340 J = 1, M
SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
$ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
$ V7*C( J, 7 )
C( J, 1 ) = C( J, 1 ) - SUM*T1
C( J, 2 ) = C( J, 2 ) - SUM*T2
C( J, 3 ) = C( J, 3 ) - SUM*T3
C( J, 4 ) = C( J, 4 ) - SUM*T4
C( J, 5 ) = C( J, 5 ) - SUM*T5
C( J, 6 ) = C( J, 6 ) - SUM*T6
C( J, 7 ) = C( J, 7 ) - SUM*T7
340 CONTINUE
GO TO 410
350 CONTINUE
*
* Special code for 8 x 8 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
V4 = V( 4 )
T4 = TAU*V4
V5 = V( 5 )
T5 = TAU*V5
V6 = V( 6 )
T6 = TAU*V6
V7 = V( 7 )
T7 = TAU*V7
V8 = V( 8 )
T8 = TAU*V8
DO 360 J = 1, M
SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
$ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
$ V7*C( J, 7 ) + V8*C( J, 8 )
C( J, 1 ) = C( J, 1 ) - SUM*T1
C( J, 2 ) = C( J, 2 ) - SUM*T2
C( J, 3 ) = C( J, 3 ) - SUM*T3
C( J, 4 ) = C( J, 4 ) - SUM*T4
C( J, 5 ) = C( J, 5 ) - SUM*T5
C( J, 6 ) = C( J, 6 ) - SUM*T6
C( J, 7 ) = C( J, 7 ) - SUM*T7
C( J, 8 ) = C( J, 8 ) - SUM*T8
360 CONTINUE
GO TO 410
370 CONTINUE
*
* Special code for 9 x 9 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
V4 = V( 4 )
T4 = TAU*V4
V5 = V( 5 )
T5 = TAU*V5
V6 = V( 6 )
T6 = TAU*V6
V7 = V( 7 )
T7 = TAU*V7
V8 = V( 8 )
T8 = TAU*V8
V9 = V( 9 )
T9 = TAU*V9
DO 380 J = 1, M
SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
$ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
$ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 )
C( J, 1 ) = C( J, 1 ) - SUM*T1
C( J, 2 ) = C( J, 2 ) - SUM*T2
C( J, 3 ) = C( J, 3 ) - SUM*T3
C( J, 4 ) = C( J, 4 ) - SUM*T4
C( J, 5 ) = C( J, 5 ) - SUM*T5
C( J, 6 ) = C( J, 6 ) - SUM*T6
C( J, 7 ) = C( J, 7 ) - SUM*T7
C( J, 8 ) = C( J, 8 ) - SUM*T8
C( J, 9 ) = C( J, 9 ) - SUM*T9
380 CONTINUE
GO TO 410
390 CONTINUE
*
* Special code for 10 x 10 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
V4 = V( 4 )
T4 = TAU*V4
V5 = V( 5 )
T5 = TAU*V5
V6 = V( 6 )
T6 = TAU*V6
V7 = V( 7 )
T7 = TAU*V7
V8 = V( 8 )
T8 = TAU*V8
V9 = V( 9 )
T9 = TAU*V9
V10 = V( 10 )
T10 = TAU*V10
DO 400 J = 1, M
SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
$ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
$ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) +
$ V10*C( J, 10 )
C( J, 1 ) = C( J, 1 ) - SUM*T1
C( J, 2 ) = C( J, 2 ) - SUM*T2
C( J, 3 ) = C( J, 3 ) - SUM*T3
C( J, 4 ) = C( J, 4 ) - SUM*T4
C( J, 5 ) = C( J, 5 ) - SUM*T5
C( J, 6 ) = C( J, 6 ) - SUM*T6
C( J, 7 ) = C( J, 7 ) - SUM*T7
C( J, 8 ) = C( J, 8 ) - SUM*T8
C( J, 9 ) = C( J, 9 ) - SUM*T9
C( J, 10 ) = C( J, 10 ) - SUM*T10
400 CONTINUE
GO TO 410
END IF
410 CONTINUE
RETURN
*
* End of DLARFX
*
END
SUBROUTINE DLARGV( N, X, INCX, Y, INCY, C, INCC )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INCC, INCX, INCY, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION C( * ), X( * ), Y( * )
* ..
*
* Purpose
* =======
*
* DLARGV generates a vector of real plane rotations, determined by
* elements of the real vectors x and y. For i = 1,2,...,n
*
* ( c(i) s(i) ) ( x(i) ) = ( a(i) )
* ( -s(i) c(i) ) ( y(i) ) = ( 0 )
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of plane rotations to be generated.
*
* X (input/output) DOUBLE PRECISION array,
* dimension (1+(N-1)*INCX)
* On entry, the vector x.
* On exit, x(i) is overwritten by a(i), for i = 1,...,n.
*
* INCX (input) INTEGER
* The increment between elements of X. INCX > 0.
*
* Y (input/output) DOUBLE PRECISION array,
* dimension (1+(N-1)*INCY)
* On entry, the vector y.
* On exit, the sines of the plane rotations.
*
* INCY (input) INTEGER
* The increment between elements of Y. INCY > 0.
*
* C (output) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
* The cosines of the plane rotations.
*
* INCC (input) INTEGER
* The increment between elements of C. INCC > 0.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, IC, IX, IY
DOUBLE PRECISION F, G, T, TT
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SQRT
* ..
* .. Executable Statements ..
*
IX = 1
IY = 1
IC = 1
DO 10 I = 1, N
F = X( IX )
G = Y( IY )
IF( G.EQ.ZERO ) THEN
C( IC ) = ONE
ELSE IF( F.EQ.ZERO ) THEN
C( IC ) = ZERO
Y( IY ) = ONE
X( IX ) = G
ELSE IF( ABS( F ).GT.ABS( G ) ) THEN
T = G / F
TT = SQRT( ONE+T*T )
C( IC ) = ONE / TT
Y( IY ) = T*C( IC )
X( IX ) = F*TT
ELSE
T = F / G
TT = SQRT( ONE+T*T )
Y( IY ) = ONE / TT
C( IC ) = T*Y( IY )
X( IX ) = G*TT
END IF
IC = IC + INCC
IY = IY + INCY
IX = IX + INCX
10 CONTINUE
RETURN
*
* End of DLARGV
*
END
SUBROUTINE DLARNV( IDIST, ISEED, N, X )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IDIST, N
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
DOUBLE PRECISION X( * )
* ..
*
* Purpose
* =======
*
* DLARNV returns a vector of n random real numbers from a uniform or
* normal distribution.
*
* Arguments
* =========
*
* IDIST (input) INTEGER
* Specifies the distribution of the random numbers:
* = 1: uniform (0,1)
* = 2: uniform (-1,1)
* = 3: normal (0,1)
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry, the seed of the random number generator; the array
* elements must be between 0 and 4095, and ISEED(4) must be
* odd.
* On exit, the seed is updated.
*
* N (input) INTEGER
* The number of random numbers to be generated.
*
* X (output) DOUBLE PRECISION array, dimension (N)
* The generated random numbers.
*
* Further Details
* ===============
*
* This routine calls the auxiliary routine DLARUV to generate random
* real numbers from a uniform (0,1) distribution, in batches of up to
* 128 using vectorisable code. The Box-Muller method is used to
* transform numbers from a uniform to a normal distribution.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, TWO
PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 )
INTEGER LV
PARAMETER ( LV = 128 )
DOUBLE PRECISION TWOPI
PARAMETER ( TWOPI = 6.2831853071795864769252867663D+0 )
* ..
* .. Local Scalars ..
INTEGER I, IL, IL2, IV
* ..
* .. Local Arrays ..
DOUBLE PRECISION U( LV )
* ..
* .. Intrinsic Functions ..
INTRINSIC COS, LOG, MIN, SQRT
* ..
* .. External Subroutines ..
EXTERNAL DLARUV
* ..
* .. Executable Statements ..
*
DO 40 IV = 1, N, LV / 2
IL = MIN( LV / 2, N-IV+1 )
IF( IDIST.EQ.3 ) THEN
IL2 = 2*IL
ELSE
IL2 = IL
END IF
*
* Call DLARUV to generate IL2 numbers from a uniform (0,1)
* distribution (IL2 <= LV)
*
CALL DLARUV( ISEED, IL2, U )
*
IF( IDIST.EQ.1 ) THEN
*
* Copy generated numbers
*
DO 10 I = 1, IL
X( IV+I-1 ) = U( I )
10 CONTINUE
ELSE IF( IDIST.EQ.2 ) THEN
*
* Convert generated numbers to uniform (-1,1) distribution
*
DO 20 I = 1, IL
X( IV+I-1 ) = TWO*U( I ) - ONE
20 CONTINUE
ELSE IF( IDIST.EQ.3 ) THEN
*
* Convert generated numbers to normal (0,1) distribution
*
DO 30 I = 1, IL
X( IV+I-1 ) = SQRT( -TWO*LOG( U( 2*I-1 ) ) )*
$ COS( TWOPI*U( 2*I ) )
30 CONTINUE
END IF
40 CONTINUE
RETURN
*
* End of DLARNV
*
END
SUBROUTINE DLARRA( N, D, E, E2, SPLTOL, TNRM,
$ NSPLIT, ISPLIT, INFO )
IMPLICIT NONE
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, N, NSPLIT
DOUBLE PRECISION SPLTOL, TNRM
* ..
* .. Array Arguments ..
INTEGER ISPLIT( * )
DOUBLE PRECISION D( * ), E( * ), E2( * )
* ..
*
* Purpose
* =======
*
* Compute the splitting points with threshold SPLTOL.
* DLARRA sets any "small" off-diagonal elements to zero.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix. N > 0.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* On entry, the N diagonal elements of the tridiagonal
* matrix T.
*
* E (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the first (N-1) entries contain the subdiagonal
* elements of the tridiagonal matrix T; E(N) need not be set.
* On exit, the entries E( ISPLIT( I ) ), 1 <= I <= NSPLIT,
* are set to zero, the other entries of E are untouched.
*
* E2 (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the first (N-1) entries contain the SQUARES of the
* subdiagonal elements of the tridiagonal matrix T;
* E2(N) need not be set.
* On exit, the entries E2( ISPLIT( I ) ),
* 1 <= I <= NSPLIT, have been set to zero
*
* SPLTOL (input) DOUBLE PRECISION
* The threshold for splitting. Two criteria can be used:
* SPLTOL<0 : criterion based on absolute off-diagonal value
* SPLTOL>0 : criterion that preserves relative accuracy
*
* TNRM (input) DOUBLE PRECISION
* The norm of the matrix.
*
* NSPLIT (output) INTEGER
* The number of blocks T splits into. 1 <= NSPLIT <= N.
*
* ISPLIT (output) INTEGER array, dimension (N)
* The splitting points, at which T breaks up into blocks.
* The first block consists of rows/columns 1 to ISPLIT(1),
* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
* etc., and the NSPLIT-th consists of rows/columns
* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
*
*
* INFO (output) INTEGER
* = 0: successful exit
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER I
DOUBLE PRECISION EABS, TMP1
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
INFO = 0
* Compute splitting points
NSPLIT = 1
IF(SPLTOL.LT.ZERO) THEN
* Criterion based on absolute off-diagonal value
TMP1 = ABS(SPLTOL)* TNRM
DO 9 I = 1, N-1
EABS = ABS( E(I) )
IF( EABS .LE. TMP1) THEN
E(I) = ZERO
E2(I) = ZERO
ISPLIT( NSPLIT ) = I
NSPLIT = NSPLIT + 1
END IF
9 CONTINUE
ELSE
* Criterion that guarantees relative accuracy
DO 10 I = 1, N-1
EABS = ABS( E(I) )
IF( EABS .LE. SPLTOL * SQRT(ABS(D(I)))*SQRT(ABS(D(I+1))) )
$ THEN
E(I) = ZERO
E2(I) = ZERO
ISPLIT( NSPLIT ) = I
NSPLIT = NSPLIT + 1
END IF
10 CONTINUE
ENDIF
ISPLIT( NSPLIT ) = N
RETURN
*
* End of DLARRA
*
END
SUBROUTINE DLARRB( N, D, LLD, IFIRST, ILAST, RTOL1,
$ RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK,
$ PIVMIN, SPDIAM, TWIST, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IFIRST, ILAST, INFO, N, OFFSET, TWIST
DOUBLE PRECISION PIVMIN, RTOL1, RTOL2, SPDIAM
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION D( * ), LLD( * ), W( * ),
$ WERR( * ), WGAP( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* Given the relatively robust representation(RRR) L D L^T, DLARRB
* does "limited" bisection to refine the eigenvalues of L D L^T,
* W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial
* guesses for these eigenvalues are input in W, the corresponding estimate
* of the error in these guesses and their gaps are input in WERR
* and WGAP, respectively. During bisection, intervals
* [left, right] are maintained by storing their mid-points and
* semi-widths in the arrays W and WERR respectively.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The N diagonal elements of the diagonal matrix D.
*
* LLD (input) DOUBLE PRECISION array, dimension (N-1)
* The (N-1) elements L(i)*L(i)*D(i).
*
* IFIRST (input) INTEGER
* The index of the first eigenvalue to be computed.
*
* ILAST (input) INTEGER
* The index of the last eigenvalue to be computed.
*
* RTOL1 (input) DOUBLE PRECISION
* RTOL2 (input) DOUBLE PRECISION
* Tolerance for the convergence of the bisection intervals.
* An interval [LEFT,RIGHT] has converged if
* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
* where GAP is the (estimated) distance to the nearest
* eigenvalue.
*
* OFFSET (input) INTEGER
* Offset for the arrays W, WGAP and WERR, i.e., the IFIRST-OFFSET
* through ILAST-OFFSET elements of these arrays are to be used.
*
* W (input/output) DOUBLE PRECISION array, dimension (N)
* On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are
* estimates of the eigenvalues of L D L^T indexed IFIRST throug
* ILAST.
* On output, these estimates are refined.
*
* WGAP (input/output) DOUBLE PRECISION array, dimension (N-1)
* On input, the (estimated) gaps between consecutive
* eigenvalues of L D L^T, i.e., WGAP(I-OFFSET) is the gap between
* eigenvalues I and I+1. Note that if IFIRST.EQ.ILAST
* then WGAP(IFIRST-OFFSET) must be set to ZERO.
* On output, these gaps are refined.
*
* WERR (input/output) DOUBLE PRECISION array, dimension (N)
* On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are
* the errors in the estimates of the corresponding elements in W.
* On output, these errors are refined.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
* Workspace.
*
* IWORK (workspace) INTEGER array, dimension (2*N)
* Workspace.
*
* PIVMIN (input) DOUBLE PRECISION
* The minimum pivot in the Sturm sequence.
*
* SPDIAM (input) DOUBLE PRECISION
* The spectral diameter of the matrix.
*
* TWIST (input) INTEGER
* The twist index for the twisted factorization that is used
* for the negcount.
* TWIST = N: Compute negcount from L D L^T - LAMBDA I = L+ D+ L+^T
* TWIST = 1: Compute negcount from L D L^T - LAMBDA I = U- D- U-^T
* TWIST = R: Compute negcount from L D L^T - LAMBDA I = N(r) D(r) N(r)
*
* INFO (output) INTEGER
* Error flag.
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, TWO, HALF
PARAMETER ( ZERO = 0.0D0, TWO = 2.0D0,
$ HALF = 0.5D0 )
INTEGER MAXITR
* ..
* .. Local Scalars ..
INTEGER I, I1, II, IP, ITER, K, NEGCNT, NEXT, NINT,
$ OLNINT, PREV, R
DOUBLE PRECISION BACK, CVRGD, GAP, LEFT, LGAP, MID, MNWDTH,
$ RGAP, RIGHT, TMP, WIDTH
* ..
* .. External Functions ..
INTEGER DLANEG
EXTERNAL DLANEG
*
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
*
MAXITR = INT( ( LOG( SPDIAM+PIVMIN )-LOG( PIVMIN ) ) /
$ LOG( TWO ) ) + 2
MNWDTH = TWO * PIVMIN
*
R = TWIST
IF((R.LT.1).OR.(R.GT.N)) R = N
*
* Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ].
* The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while
* Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 )
* for an unconverged interval is set to the index of the next unconverged
* interval, and is -1 or 0 for a converged interval. Thus a linked
* list of unconverged intervals is set up.
*
I1 = IFIRST
* The number of unconverged intervals
NINT = 0
* The last unconverged interval found
PREV = 0
RGAP = WGAP( I1-OFFSET )
DO 75 I = I1, ILAST
K = 2*I
II = I - OFFSET
LEFT = W( II ) - WERR( II )
RIGHT = W( II ) + WERR( II )
LGAP = RGAP
RGAP = WGAP( II )
GAP = MIN( LGAP, RGAP )
* Make sure that [LEFT,RIGHT] contains the desired eigenvalue
* Compute negcount from dstqds facto L+D+L+^T = L D L^T - LEFT
*
* Do while( NEGCNT(LEFT).GT.I-1 )
*
BACK = WERR( II )
20 CONTINUE
NEGCNT = DLANEG( N, D, LLD, LEFT, PIVMIN, R )
IF( NEGCNT.GT.I-1 ) THEN
LEFT = LEFT - BACK
BACK = TWO*BACK
GO TO 20
END IF
*
* Do while( NEGCNT(RIGHT).LT.I )
* Compute negcount from dstqds facto L+D+L+^T = L D L^T - RIGHT
*
BACK = WERR( II )
50 CONTINUE
NEGCNT = DLANEG( N, D, LLD, RIGHT, PIVMIN, R )
IF( NEGCNT.LT.I ) THEN
RIGHT = RIGHT + BACK
BACK = TWO*BACK
GO TO 50
END IF
WIDTH = HALF*ABS( LEFT - RIGHT )
TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
CVRGD = MAX(RTOL1*GAP,RTOL2*TMP)
IF( WIDTH.LE.CVRGD .OR. WIDTH.LE.MNWDTH ) THEN
* This interval has already converged and does not need refinement.
* (Note that the gaps might change through refining the
* eigenvalues, however, they can only get bigger.)
* Remove it from the list.
IWORK( K-1 ) = -1
* Make sure that I1 always points to the first unconverged interval
IF((I.EQ.I1).AND.(I.LT.ILAST)) I1 = I + 1
IF((PREV.GE.I1).AND.(I.LE.ILAST)) IWORK( 2*PREV-1 ) = I + 1
ELSE
* unconverged interval found
PREV = I
NINT = NINT + 1
IWORK( K-1 ) = I + 1
IWORK( K ) = NEGCNT
END IF
WORK( K-1 ) = LEFT
WORK( K ) = RIGHT
75 CONTINUE
*
* Do while( NINT.GT.0 ), i.e. there are still unconverged intervals
* and while (ITER.LT.MAXITR)
*
ITER = 0
80 CONTINUE
PREV = I1 - 1
I = I1
OLNINT = NINT
DO 100 IP = 1, OLNINT
K = 2*I
II = I - OFFSET
RGAP = WGAP( II )
LGAP = RGAP
IF(II.GT.1) LGAP = WGAP( II-1 )
GAP = MIN( LGAP, RGAP )
NEXT = IWORK( K-1 )
LEFT = WORK( K-1 )
RIGHT = WORK( K )
MID = HALF*( LEFT + RIGHT )
* semiwidth of interval
WIDTH = RIGHT - MID
TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
CVRGD = MAX(RTOL1*GAP,RTOL2*TMP)
IF( ( WIDTH.LE.CVRGD ) .OR. ( WIDTH.LE.MNWDTH ).OR.
$ ( ITER.EQ.MAXITR ) )THEN
* reduce number of unconverged intervals
NINT = NINT - 1
* Mark interval as converged.
IWORK( K-1 ) = 0
IF( I1.EQ.I ) THEN
I1 = NEXT
ELSE
* Prev holds the last unconverged interval previously examined
IF(PREV.GE.I1) IWORK( 2*PREV-1 ) = NEXT
END IF
I = NEXT
GO TO 100
END IF
PREV = I
*
* Perform one bisection step
*
NEGCNT = DLANEG( N, D, LLD, MID, PIVMIN, R )
IF( NEGCNT.LE.I-1 ) THEN
WORK( K-1 ) = MID
ELSE
WORK( K ) = MID
END IF
I = NEXT
100 CONTINUE
ITER = ITER + 1
* do another loop if there are still unconverged intervals
* However, in the last iteration, all intervals are accepted
* since this is the best we can do.
IF( ( NINT.GT.0 ).AND.(ITER.LE.MAXITR) ) GO TO 80
*
*
* At this point, all the intervals have converged
DO 110 I = IFIRST, ILAST
K = 2*I
II = I - OFFSET
* All intervals marked by '0' have been refined.
IF( IWORK( K-1 ).EQ.0 ) THEN
W( II ) = HALF*( WORK( K-1 )+WORK( K ) )
WERR( II ) = WORK( K ) - W( II )
END IF
110 CONTINUE
*
DO 111 I = IFIRST+1, ILAST
K = 2*I
II = I - OFFSET
WGAP( II-1 ) = MAX( ZERO,
$ W(II) - WERR (II) - W( II-1 ) - WERR( II-1 ))
111 CONTINUE
RETURN
*
* End of DLARRB
*
END
SUBROUTINE DLARRC( JOBT, N, VL, VU, D, E, PIVMIN,
$ EIGCNT, LCNT, RCNT, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBT
INTEGER EIGCNT, INFO, LCNT, N, RCNT
DOUBLE PRECISION PIVMIN, VL, VU
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * )
* ..
*
* Purpose
* =======
*
* Find the number of eigenvalues of the symmetric tridiagonal matrix T
* that are in the interval (VL,VU] if JOBT = 'T', and of L D L^T
* if JOBT = 'L'.
*
* Arguments
* =========
*
* JOBT (input) CHARACTER*1
* = 'T': Compute Sturm count for matrix T.
* = 'L': Compute Sturm count for matrix L D L^T.
*
* N (input) INTEGER
* The order of the matrix. N > 0.
*
* VL (input) DOUBLE PRECISION
* VU (input) DOUBLE PRECISION
* The lower and upper bounds for the eigenvalues.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* JOBT = 'T': The N diagonal elements of the tridiagonal matrix T.
* JOBT = 'L': The N diagonal elements of the diagonal matrix D.
*
* E (input) DOUBLE PRECISION array, dimension (N)
* JOBT = 'T': The N-1 offdiagonal elements of the matrix T.
* JOBT = 'L': The N-1 offdiagonal elements of the matrix L.
*
* PIVMIN (input) DOUBLE PRECISION
* The minimum pivot in the Sturm sequence for T.
*
* EIGCNT (output) INTEGER
* The number of eigenvalues of the symmetric tridiagonal matrix T
* that are in the interval (VL,VU]
*
* LCNT (output) INTEGER
* RCNT (output) INTEGER
* The left and right negcounts of the interval.
*
* INFO (output) INTEGER
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER I
LOGICAL MATT
DOUBLE PRECISION LPIVOT, RPIVOT, SL, SU, TMP, TMP2
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Executable Statements ..
*
INFO = 0
LCNT = 0
RCNT = 0
EIGCNT = 0
MATT = LSAME( JOBT, 'T' )
IF (MATT) THEN
* Sturm sequence count on T
LPIVOT = D( 1 ) - VL
RPIVOT = D( 1 ) - VU
IF( LPIVOT.LE.ZERO ) THEN
LCNT = LCNT + 1
ENDIF
IF( RPIVOT.LE.ZERO ) THEN
RCNT = RCNT + 1
ENDIF
DO 10 I = 1, N-1
TMP = E(I)**2
LPIVOT = ( D( I+1 )-VL ) - TMP/LPIVOT
RPIVOT = ( D( I+1 )-VU ) - TMP/RPIVOT
IF( LPIVOT.LE.ZERO ) THEN
LCNT = LCNT + 1
ENDIF
IF( RPIVOT.LE.ZERO ) THEN
RCNT = RCNT + 1
ENDIF
10 CONTINUE
ELSE
* Sturm sequence count on L D L^T
SL = -VL
SU = -VU
DO 20 I = 1, N - 1
LPIVOT = D( I ) + SL
RPIVOT = D( I ) + SU
IF( LPIVOT.LE.ZERO ) THEN
LCNT = LCNT + 1
ENDIF
IF( RPIVOT.LE.ZERO ) THEN
RCNT = RCNT + 1
ENDIF
TMP = E(I) * D(I) * E(I)
*
TMP2 = TMP / LPIVOT
IF( TMP2.EQ.ZERO ) THEN
SL = TMP - VL
ELSE
SL = SL*TMP2 - VL
END IF
*
TMP2 = TMP / RPIVOT
IF( TMP2.EQ.ZERO ) THEN
SU = TMP - VU
ELSE
SU = SU*TMP2 - VU
END IF
20 CONTINUE
LPIVOT = D( N ) + SL
RPIVOT = D( N ) + SU
IF( LPIVOT.LE.ZERO ) THEN
LCNT = LCNT + 1
ENDIF
IF( RPIVOT.LE.ZERO ) THEN
RCNT = RCNT + 1
ENDIF
ENDIF
EIGCNT = RCNT - LCNT
RETURN
*
* end of DLARRC
*
END
SUBROUTINE DLARRD( RANGE, ORDER, N, VL, VU, IL, IU, GERS,
$ RELTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT,
$ M, W, WERR, WL, WU, IBLOCK, INDEXW,
$ WORK, IWORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER ORDER, RANGE
INTEGER IL, INFO, IU, M, N, NSPLIT
DOUBLE PRECISION PIVMIN, RELTOL, VL, VU, WL, WU
* ..
* .. Array Arguments ..
INTEGER IBLOCK( * ), INDEXW( * ),
$ ISPLIT( * ), IWORK( * )
DOUBLE PRECISION D( * ), E( * ), E2( * ),
$ GERS( * ), W( * ), WERR( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLARRD computes the eigenvalues of a symmetric tridiagonal
* matrix T to suitable accuracy. This is an auxiliary code to be
* called from DSTEMR.
* The user may ask for all eigenvalues, all eigenvalues
* in the half-open interval (VL, VU], or the IL-th through IU-th
* eigenvalues.
*
* To avoid overflow, the matrix must be scaled so that its
* largest element is no greater than overflow**(1/2) *
* underflow**(1/4) in absolute value, and for greatest
* accuracy, it should not be much smaller than that.
*
* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
* Matrix", Report CS41, Computer Science Dept., Stanford
* University, July 21, 1966.
*
* Arguments
* =========
*
* RANGE (input) CHARACTER
* = 'A': ("All") all eigenvalues will be found.
* = 'V': ("Value") all eigenvalues in the half-open interval
* (VL, VU] will be found.
* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
* entire matrix) will be found.
*
* ORDER (input) CHARACTER
* = 'B': ("By Block") the eigenvalues will be grouped by
* split-off block (see IBLOCK, ISPLIT) and
* ordered from smallest to largest within
* the block.
* = 'E': ("Entire matrix")
* the eigenvalues for the entire matrix
* will be ordered from smallest to
* largest.
*
* N (input) INTEGER
* The order of the tridiagonal matrix T. N >= 0.
*
* VL (input) DOUBLE PRECISION
* VU (input) DOUBLE PRECISION
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. Eigenvalues less than or equal
* to VL, or greater than VU, will not be returned. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* GERS (input) DOUBLE PRECISION array, dimension (2*N)
* The N Gerschgorin intervals (the i-th Gerschgorin interval
* is (GERS(2*i-1), GERS(2*i)).
*
* RELTOL (input) DOUBLE PRECISION
* The minimum relative width of an interval. When an interval
* is narrower than RELTOL times the larger (in
* magnitude) endpoint, then it is considered to be
* sufficiently small, i.e., converged. Note: this should
* always be at least radix*machine epsilon.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the tridiagonal matrix T.
*
* E (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) off-diagonal elements of the tridiagonal matrix T.
*
* E2 (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) squared off-diagonal elements of the tridiagonal matrix T.
*
* PIVMIN (input) DOUBLE PRECISION
* The minimum pivot allowed in the Sturm sequence for T.
*
* NSPLIT (input) INTEGER
* The number of diagonal blocks in the matrix T.
* 1 <= NSPLIT <= N.
*
* ISPLIT (input) INTEGER array, dimension (N)
* The splitting points, at which T breaks up into submatrices.
* The first submatrix consists of rows/columns 1 to ISPLIT(1),
* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
* etc., and the NSPLIT-th consists of rows/columns
* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
* (Only the first NSPLIT elements will actually be used, but
* since the user cannot know a priori what value NSPLIT will
* have, N words must be reserved for ISPLIT.)
*
* M (output) INTEGER
* The actual number of eigenvalues found. 0 <= M <= N.
* (See also the description of INFO=2,3.)
*
* W (output) DOUBLE PRECISION array, dimension (N)
* On exit, the first M elements of W will contain the
* eigenvalue approximations. DLARRD computes an interval
* I_j = (a_j, b_j] that includes eigenvalue j. The eigenvalue
* approximation is given as the interval midpoint
* W(j)= ( a_j + b_j)/2. The corresponding error is bounded by
* WERR(j) = abs( a_j - b_j)/2
*
* WERR (output) DOUBLE PRECISION array, dimension (N)
* The error bound on the corresponding eigenvalue approximation
* in W.
*
* WL (output) DOUBLE PRECISION
* WU (output) DOUBLE PRECISION
* The interval (WL, WU] contains all the wanted eigenvalues.
* If RANGE='V', then WL=VL and WU=VU.
* If RANGE='A', then WL and WU are the global Gerschgorin bounds
* on the spectrum.
* If RANGE='I', then WL and WU are computed by DLAEBZ from the
* index range specified.
*
* IBLOCK (output) INTEGER array, dimension (N)
* At each row/column j where E(j) is zero or small, the
* matrix T is considered to split into a block diagonal
* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which
* block (from 1 to the number of blocks) the eigenvalue W(i)
* belongs. (DLARRD may use the remaining N-M elements as
* workspace.)
*
* INDEXW (output) INTEGER array, dimension (N)
* The indices of the eigenvalues within each block (submatrix);
* for example, INDEXW(i)= j and IBLOCK(i)=k imply that the
* i-th eigenvalue W(i) is the j-th eigenvalue in block k.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
*
* IWORK (workspace) INTEGER array, dimension (3*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: some or all of the eigenvalues failed to converge or
* were not computed:
* =1 or 3: Bisection failed to converge for some
* eigenvalues; these eigenvalues are flagged by a
* negative block number. The effect is that the
* eigenvalues may not be as accurate as the
* absolute and relative tolerances. This is
* generally caused by unexpectedly inaccurate
* arithmetic.
* =2 or 3: RANGE='I' only: Not all of the eigenvalues
* IL:IU were found.
* Effect: M < IU+1-IL
* Cause: non-monotonic arithmetic, causing the
* Sturm sequence to be non-monotonic.
* Cure: recalculate, using RANGE='A', and pick
* out eigenvalues IL:IU. In some cases,
* increasing the PARAMETER "FUDGE" may
* make things work.
* = 4: RANGE='I', and the Gershgorin interval
* initially used was too small. No eigenvalues
* were computed.
* Probable cause: your machine has sloppy
* floating-point arithmetic.
* Cure: Increase the PARAMETER "FUDGE",
* recompile, and try again.
*
* Internal Parameters
* ===================
*
* FUDGE DOUBLE PRECISION, default = 2
* A "fudge factor" to widen the Gershgorin intervals. Ideally,
* a value of 1 should work, but on machines with sloppy
* arithmetic, this needs to be larger. The default for
* publicly released versions should be large enough to handle
* the worst machine around. Note that this has no effect
* on accuracy of the solution.
*
* Based on contributions by
* W. Kahan, University of California, Berkeley, USA
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, HALF, FUDGE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0,
$ TWO = 2.0D0, HALF = ONE/TWO,
$ FUDGE = TWO )
INTEGER ALLRNG, VALRNG, INDRNG
PARAMETER ( ALLRNG = 1, VALRNG = 2, INDRNG = 3 )
* ..
* .. Local Scalars ..
LOGICAL NCNVRG, TOOFEW
INTEGER I, IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO,
$ IM, IN, IOFF, IOUT, IRANGE, ITMAX, ITMP1,
$ ITMP2, IW, IWOFF, J, JBLK, JDISC, JE, JEE, NB,
$ NWL, NWU
DOUBLE PRECISION ATOLI, EPS, GL, GU, RTOLI, SPDIAM, TMP1, TMP2,
$ TNORM, UFLOW, WKILL, WLU, WUL
* ..
* .. Local Arrays ..
INTEGER IDUMMA( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, ILAENV, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DLAEBZ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Decode RANGE
*
IF( LSAME( RANGE, 'A' ) ) THEN
IRANGE = ALLRNG
ELSE IF( LSAME( RANGE, 'V' ) ) THEN
IRANGE = VALRNG
ELSE IF( LSAME( RANGE, 'I' ) ) THEN
IRANGE = INDRNG
ELSE
IRANGE = 0
END IF
*
* Check for Errors
*
IF( IRANGE.LE.0 ) THEN
INFO = -1
ELSE IF( .NOT.(LSAME(ORDER,'B').OR.LSAME(ORDER,'E')) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( IRANGE.EQ.VALRNG ) THEN
IF( VL.GE.VU )
$ INFO = -5
ELSE IF( IRANGE.EQ.INDRNG .AND.
$ ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) ) THEN
INFO = -6
ELSE IF( IRANGE.EQ.INDRNG .AND.
$ ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) THEN
INFO = -7
END IF
*
IF( INFO.NE.0 ) THEN
RETURN
END IF
* Initialize error flags
INFO = 0
NCNVRG = .FALSE.
TOOFEW = .FALSE.
* Quick return if possible
M = 0
IF( N.EQ.0 ) RETURN
* Simplification:
IF( IRANGE.EQ.INDRNG .AND. IL.EQ.1 .AND. IU.EQ.N ) IRANGE = 1
* Get machine constants
EPS = DLAMCH( 'P' )
UFLOW = DLAMCH( 'U' )
* Special Case when N=1
* Treat case of 1x1 matrix for quick return
IF( N.EQ.1 ) THEN
IF( (IRANGE.EQ.ALLRNG).OR.
$ ((IRANGE.EQ.VALRNG).AND.(D(1).GT.VL).AND.(D(1).LE.VU)).OR.
$ ((IRANGE.EQ.INDRNG).AND.(IL.EQ.1).AND.(IU.EQ.1)) ) THEN
M = 1
W(1) = D(1)
* The computation error of the eigenvalue is zero
WERR(1) = ZERO
IBLOCK( 1 ) = 1
INDEXW( 1 ) = 1
ENDIF
RETURN
END IF
* NB is the minimum vector length for vector bisection, or 0
* if only scalar is to be done.
NB = ILAENV( 1, 'DSTEBZ', ' ', N, -1, -1, -1 )
IF( NB.LE.1 ) NB = 0
* Find global spectral radius
GL = D(1)
GU = D(1)
DO 5 I = 1,N
GL = MIN( GL, GERS( 2*I - 1))
GU = MAX( GU, GERS(2*I) )
5 CONTINUE
* Compute global Gerschgorin bounds and spectral diameter
TNORM = MAX( ABS( GL ), ABS( GU ) )
GL = GL - FUDGE*TNORM*EPS*N - FUDGE*TWO*PIVMIN
GU = GU + FUDGE*TNORM*EPS*N + FUDGE*TWO*PIVMIN
SPDIAM = GU - GL
* Input arguments for DLAEBZ:
* The relative tolerance. An interval (a,b] lies within
* "relative tolerance" if b-a < RELTOL*max(|a|,|b|),
RTOLI = RELTOL
* Set the absolute tolerance for interval convergence to zero to force
* interval convergence based on relative size of the interval.
* This is dangerous because intervals might not converge when RELTOL is
* small. But at least a very small number should be selected so that for
* strongly graded matrices, the code can get relatively accurate
* eigenvalues.
ATOLI = FUDGE*TWO*UFLOW + FUDGE*TWO*PIVMIN
IF( IRANGE.EQ.INDRNG ) THEN
* RANGE='I': Compute an interval containing eigenvalues
* IL through IU. The initial interval [GL,GU] from the global
* Gerschgorin bounds GL and GU is refined by DLAEBZ.
ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) /
$ LOG( TWO ) ) + 2
WORK( N+1 ) = GL
WORK( N+2 ) = GL
WORK( N+3 ) = GU
WORK( N+4 ) = GU
WORK( N+5 ) = GL
WORK( N+6 ) = GU
IWORK( 1 ) = -1
IWORK( 2 ) = -1
IWORK( 3 ) = N + 1
IWORK( 4 ) = N + 1
IWORK( 5 ) = IL - 1
IWORK( 6 ) = IU
*
CALL DLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN,
$ D, E, E2, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT,
$ IWORK, W, IBLOCK, IINFO )
IF( IINFO .NE. 0 ) THEN
INFO = IINFO
RETURN
END IF
* On exit, output intervals may not be ordered by ascending negcount
IF( IWORK( 6 ).EQ.IU ) THEN
WL = WORK( N+1 )
WLU = WORK( N+3 )
NWL = IWORK( 1 )
WU = WORK( N+4 )
WUL = WORK( N+2 )
NWU = IWORK( 4 )
ELSE
WL = WORK( N+2 )
WLU = WORK( N+4 )
NWL = IWORK( 2 )
WU = WORK( N+3 )
WUL = WORK( N+1 )
NWU = IWORK( 3 )
END IF
* On exit, the interval [WL, WLU] contains a value with negcount NWL,
* and [WUL, WU] contains a value with negcount NWU.
IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN
INFO = 4
RETURN
END IF
ELSEIF( IRANGE.EQ.VALRNG ) THEN
WL = VL
WU = VU
ELSEIF( IRANGE.EQ.ALLRNG ) THEN
WL = GL
WU = GU
ENDIF
* Find Eigenvalues -- Loop Over blocks and recompute NWL and NWU.
* NWL accumulates the number of eigenvalues .le. WL,
* NWU accumulates the number of eigenvalues .le. WU
M = 0
IEND = 0
INFO = 0
NWL = 0
NWU = 0
*
DO 70 JBLK = 1, NSPLIT
IOFF = IEND
IBEGIN = IOFF + 1
IEND = ISPLIT( JBLK )
IN = IEND - IOFF
*
IF( IN.EQ.1 ) THEN
* 1x1 block
IF( WL.GE.D( IBEGIN )-PIVMIN )
$ NWL = NWL + 1
IF( WU.GE.D( IBEGIN )-PIVMIN )
$ NWU = NWU + 1
IF( IRANGE.EQ.ALLRNG .OR.
$ ( WL.LT.D( IBEGIN )-PIVMIN
$ .AND. WU.GE. D( IBEGIN )-PIVMIN ) ) THEN
M = M + 1
W( M ) = D( IBEGIN )
WERR(M) = ZERO
* The gap for a single block doesn't matter for the later
* algorithm and is assigned an arbitrary large value
IBLOCK( M ) = JBLK
INDEXW( M ) = 1
END IF
* Disabled 2x2 case because of a failure on the following matrix
* RANGE = 'I', IL = IU = 4
* Original Tridiagonal, d = [
* -0.150102010615740E+00
* -0.849897989384260E+00
* -0.128208148052635E-15
* 0.128257718286320E-15
* ];
* e = [
* -0.357171383266986E+00
* -0.180411241501588E-15
* -0.175152352710251E-15
* ];
*
* ELSE IF( IN.EQ.2 ) THEN
** 2x2 block
* DISC = SQRT( (HALF*(D(IBEGIN)-D(IEND)))**2 + E(IBEGIN)**2 )
* TMP1 = HALF*(D(IBEGIN)+D(IEND))
* L1 = TMP1 - DISC
* IF( WL.GE. L1-PIVMIN )
* $ NWL = NWL + 1
* IF( WU.GE. L1-PIVMIN )
* $ NWU = NWU + 1
* IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L1-PIVMIN .AND. WU.GE.
* $ L1-PIVMIN ) ) THEN
* M = M + 1
* W( M ) = L1
** The uncertainty of eigenvalues of a 2x2 matrix is very small
* WERR( M ) = EPS * ABS( W( M ) ) * TWO
* IBLOCK( M ) = JBLK
* INDEXW( M ) = 1
* ENDIF
* L2 = TMP1 + DISC
* IF( WL.GE. L2-PIVMIN )
* $ NWL = NWL + 1
* IF( WU.GE. L2-PIVMIN )
* $ NWU = NWU + 1
* IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L2-PIVMIN .AND. WU.GE.
* $ L2-PIVMIN ) ) THEN
* M = M + 1
* W( M ) = L2
** The uncertainty of eigenvalues of a 2x2 matrix is very small
* WERR( M ) = EPS * ABS( W( M ) ) * TWO
* IBLOCK( M ) = JBLK
* INDEXW( M ) = 2
* ENDIF
ELSE
* General Case - block of size IN >= 2
* Compute local Gerschgorin interval and use it as the initial
* interval for DLAEBZ
GU = D( IBEGIN )
GL = D( IBEGIN )
TMP1 = ZERO
DO 40 J = IBEGIN, IEND
GL = MIN( GL, GERS( 2*J - 1))
GU = MAX( GU, GERS(2*J) )
40 CONTINUE
SPDIAM = GU - GL
GL = GL - FUDGE*SPDIAM*EPS*IN - FUDGE*PIVMIN
GU = GU + FUDGE*SPDIAM*EPS*IN + FUDGE*PIVMIN
*
IF( IRANGE.GT.1 ) THEN
IF( GU.LT.WL ) THEN
* the local block contains none of the wanted eigenvalues
NWL = NWL + IN
NWU = NWU + IN
GO TO 70
END IF
* refine search interval if possible, only range (WL,WU] matters
GL = MAX( GL, WL )
GU = MIN( GU, WU )
IF( GL.GE.GU )
$ GO TO 70
END IF
* Find negcount of initial interval boundaries GL and GU
WORK( N+1 ) = GL
WORK( N+IN+1 ) = GU
CALL DLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
$ D( IBEGIN ), E( IBEGIN ), E2( IBEGIN ),
$ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM,
$ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
IF( IINFO .NE. 0 ) THEN
INFO = IINFO
RETURN
END IF
*
NWL = NWL + IWORK( 1 )
NWU = NWU + IWORK( IN+1 )
IWOFF = M - IWORK( 1 )
* Compute Eigenvalues
ITMAX = INT( ( LOG( GU-GL+PIVMIN )-LOG( PIVMIN ) ) /
$ LOG( TWO ) ) + 2
CALL DLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
$ D( IBEGIN ), E( IBEGIN ), E2( IBEGIN ),
$ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT,
$ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
IF( IINFO .NE. 0 ) THEN
INFO = IINFO
RETURN
END IF
*
* Copy eigenvalues into W and IBLOCK
* Use -JBLK for block number for unconverged eigenvalues.
* Loop over the number of output intervals from DLAEBZ
DO 60 J = 1, IOUT
* eigenvalue approximation is middle point of interval
TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) )
* semi length of error interval
TMP2 = HALF*ABS( WORK( J+N )-WORK( J+IN+N ) )
IF( J.GT.IOUT-IINFO ) THEN
* Flag non-convergence.
NCNVRG = .TRUE.
IB = -JBLK
ELSE
IB = JBLK
END IF
DO 50 JE = IWORK( J ) + 1 + IWOFF,
$ IWORK( J+IN ) + IWOFF
W( JE ) = TMP1
WERR( JE ) = TMP2
INDEXW( JE ) = JE - IWOFF
IBLOCK( JE ) = IB
50 CONTINUE
60 CONTINUE
*
M = M + IM
END IF
70 CONTINUE
* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU
* If NWL+1 < IL or NWU > IU, discard extra eigenvalues.
IF( IRANGE.EQ.INDRNG ) THEN
IDISCL = IL - 1 - NWL
IDISCU = NWU - IU
*
IF( IDISCL.GT.0 ) THEN
IM = 0
DO 80 JE = 1, M
* Remove some of the smallest eigenvalues from the left so that
* at the end IDISCL =0. Move all eigenvalues up to the left.
IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN
IDISCL = IDISCL - 1
ELSE
IM = IM + 1
W( IM ) = W( JE )
WERR( IM ) = WERR( JE )
INDEXW( IM ) = INDEXW( JE )
IBLOCK( IM ) = IBLOCK( JE )
END IF
80 CONTINUE
M = IM
END IF
IF( IDISCU.GT.0 ) THEN
* Remove some of the largest eigenvalues from the right so that
* at the end IDISCU =0. Move all eigenvalues up to the left.
IM=M+1
DO 81 JE = M, 1, -1
IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN
IDISCU = IDISCU - 1
ELSE
IM = IM - 1
W( IM ) = W( JE )
WERR( IM ) = WERR( JE )
INDEXW( IM ) = INDEXW( JE )
IBLOCK( IM ) = IBLOCK( JE )
END IF
81 CONTINUE
JEE = 0
DO 82 JE = IM, M
JEE = JEE + 1
W( JEE ) = W( JE )
WERR( JEE ) = WERR( JE )
INDEXW( JEE ) = INDEXW( JE )
IBLOCK( JEE ) = IBLOCK( JE )
82 CONTINUE
M = M-IM+1
END IF
IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
* Code to deal with effects of bad arithmetic. (If N(w) is
* monotone non-decreasing, this should never happen.)
* Some low eigenvalues to be discarded are not in (WL,WLU],
* or high eigenvalues to be discarded are not in (WUL,WU]
* so just kill off the smallest IDISCL/largest IDISCU
* eigenvalues, by marking the corresponding IBLOCK = 0
IF( IDISCL.GT.0 ) THEN
WKILL = WU
DO 100 JDISC = 1, IDISCL
IW = 0
DO 90 JE = 1, M
IF( IBLOCK( JE ).NE.0 .AND.
$ ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN
IW = JE
WKILL = W( JE )
END IF
90 CONTINUE
IBLOCK( IW ) = 0
100 CONTINUE
END IF
IF( IDISCU.GT.0 ) THEN
WKILL = WL
DO 120 JDISC = 1, IDISCU
IW = 0
DO 110 JE = 1, M
IF( IBLOCK( JE ).NE.0 .AND.
$ ( W( JE ).GE.WKILL .OR. IW.EQ.0 ) ) THEN
IW = JE
WKILL = W( JE )
END IF
110 CONTINUE
IBLOCK( IW ) = 0
120 CONTINUE
END IF
* Now erase all eigenvalues with IBLOCK set to zero
IM = 0
DO 130 JE = 1, M
IF( IBLOCK( JE ).NE.0 ) THEN
IM = IM + 1
W( IM ) = W( JE )
WERR( IM ) = WERR( JE )
INDEXW( IM ) = INDEXW( JE )
IBLOCK( IM ) = IBLOCK( JE )
END IF
130 CONTINUE
M = IM
END IF
IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN
TOOFEW = .TRUE.
END IF
END IF
*
IF(( IRANGE.EQ.ALLRNG .AND. M.NE.N ).OR.
$ ( IRANGE.EQ.INDRNG .AND. M.NE.IU-IL+1 ) ) THEN
TOOFEW = .TRUE.
END IF
* If ORDER='B', do nothing the eigenvalues are already sorted by
* block.
* If ORDER='E', sort the eigenvalues from smallest to largest
IF( LSAME(ORDER,'E') .AND. NSPLIT.GT.1 ) THEN
DO 150 JE = 1, M - 1
IE = 0
TMP1 = W( JE )
DO 140 J = JE + 1, M
IF( W( J ).LT.TMP1 ) THEN
IE = J
TMP1 = W( J )
END IF
140 CONTINUE
IF( IE.NE.0 ) THEN
TMP2 = WERR( IE )
ITMP1 = IBLOCK( IE )
ITMP2 = INDEXW( IE )
W( IE ) = W( JE )
WERR( IE ) = WERR( JE )
IBLOCK( IE ) = IBLOCK( JE )
INDEXW( IE ) = INDEXW( JE )
W( JE ) = TMP1
WERR( JE ) = TMP2
IBLOCK( JE ) = ITMP1
INDEXW( JE ) = ITMP2
END IF
150 CONTINUE
END IF
*
INFO = 0
IF( NCNVRG )
$ INFO = INFO + 1
IF( TOOFEW )
$ INFO = INFO + 2
RETURN
*
* End of DLARRD
*
END
SUBROUTINE DLARRE( RANGE, N, VL, VU, IL, IU, D, E, E2,
$ RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT, M,
$ W, WERR, WGAP, IBLOCK, INDEXW, GERS, PIVMIN,
$ WORK, IWORK, INFO )
IMPLICIT NONE
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER RANGE
INTEGER IL, INFO, IU, M, N, NSPLIT
DOUBLE PRECISION PIVMIN, RTOL1, RTOL2, SPLTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * ),
$ INDEXW( * )
DOUBLE PRECISION D( * ), E( * ), E2( * ), GERS( * ),
$ W( * ),WERR( * ), WGAP( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* To find the desired eigenvalues of a given real symmetric
* tridiagonal matrix T, DLARRE sets any "small" off-diagonal
* elements to zero, and for each unreduced block T_i, it finds
* (a) a suitable shift at one end of the block's spectrum,
* (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and
* (c) eigenvalues of each L_i D_i L_i^T.
* The representations and eigenvalues found are then used by
* DSTEMR to compute the eigenvectors of T.
* The accuracy varies depending on whether bisection is used to
* find a few eigenvalues or the dqds algorithm (subroutine DLASQ2) to
* conpute all and then discard any unwanted one.
* As an added benefit, DLARRE also outputs the n
* Gerschgorin intervals for the matrices L_i D_i L_i^T.
*
* Arguments
* =========
*
* RANGE (input) CHARACTER
* = 'A': ("All") all eigenvalues will be found.
* = 'V': ("Value") all eigenvalues in the half-open interval
* (VL, VU] will be found.
* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
* entire matrix) will be found.
*
* N (input) INTEGER
* The order of the matrix. N > 0.
*
* VL (input/output) DOUBLE PRECISION
* VU (input/output) DOUBLE PRECISION
* If RANGE='V', the lower and upper bounds for the eigenvalues.
* Eigenvalues less than or equal to VL, or greater than VU,
* will not be returned. VL < VU.
* If RANGE='I' or ='A', DLARRE computes bounds on the desired
* part of the spectrum.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the N diagonal elements of the tridiagonal
* matrix T.
* On exit, the N diagonal elements of the diagonal
* matrices D_i.
*
* E (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the first (N-1) entries contain the subdiagonal
* elements of the tridiagonal matrix T; E(N) need not be set.
* On exit, E contains the subdiagonal elements of the unit
* bidiagonal matrices L_i. The entries E( ISPLIT( I ) ),
* 1 <= I <= NSPLIT, contain the base points sigma_i on output.
*
* E2 (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the first (N-1) entries contain the SQUARES of the
* subdiagonal elements of the tridiagonal matrix T;
* E2(N) need not be set.
* On exit, the entries E2( ISPLIT( I ) ),
* 1 <= I <= NSPLIT, have been set to zero
*
* RTOL1 (input) DOUBLE PRECISION
* RTOL2 (input) DOUBLE PRECISION
* Parameters for bisection.
* An interval [LEFT,RIGHT] has converged if
* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
*
* SPLTOL (input) DOUBLE PRECISION
* The threshold for splitting.
*
* NSPLIT (output) INTEGER
* The number of blocks T splits into. 1 <= NSPLIT <= N.
*
* ISPLIT (output) INTEGER array, dimension (N)
* The splitting points, at which T breaks up into blocks.
* The first block consists of rows/columns 1 to ISPLIT(1),
* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
* etc., and the NSPLIT-th consists of rows/columns
* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
*
* M (output) INTEGER
* The total number of eigenvalues (of all L_i D_i L_i^T)
* found.
*
* W (output) DOUBLE PRECISION array, dimension (N)
* The first M elements contain the eigenvalues. The
* eigenvalues of each of the blocks, L_i D_i L_i^T, are
* sorted in ascending order ( DLARRE may use the
* remaining N-M elements as workspace).
*
* WERR (output) DOUBLE PRECISION array, dimension (N)
* The error bound on the corresponding eigenvalue in W.
*
* WGAP (output) DOUBLE PRECISION array, dimension (N)
* The separation from the right neighbor eigenvalue in W.
* The gap is only with respect to the eigenvalues of the same block
* as each block has its own representation tree.
* Exception: at the right end of a block we store the left gap
*
* IBLOCK (output) INTEGER array, dimension (N)
* The indices of the blocks (submatrices) associated with the
* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue
* W(i) belongs to the first block from the top, =2 if W(i)
* belongs to the second block, etc.
*
* INDEXW (output) INTEGER array, dimension (N)
* The indices of the eigenvalues within each block (submatrix);
* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the
* i-th eigenvalue W(i) is the 10-th eigenvalue in block 2
*
* GERS (output) DOUBLE PRECISION array, dimension (2*N)
* The N Gerschgorin intervals (the i-th Gerschgorin interval
* is (GERS(2*i-1), GERS(2*i)).
*
* PIVMIN (output) DOUBLE PRECISION
* The minimum pivot in the Sturm sequence for T.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (6*N)
* Workspace.
*
* IWORK (workspace) INTEGER array, dimension (5*N)
* Workspace.
*
* INFO (output) INTEGER
* = 0: successful exit
* > 0: A problem occured in DLARRE.
* < 0: One of the called subroutines signaled an internal problem.
* Needs inspection of the corresponding parameter IINFO
* for further information.
*
* =-1: Problem in DLARRD.
* = 2: No base representation could be found in MAXTRY iterations.
* Increasing MAXTRY and recompilation might be a remedy.
* =-3: Problem in DLARRB when computing the refined root
* representation for DLASQ2.
* =-4: Problem in DLARRB when preforming bisection on the
* desired part of the spectrum.
* =-5: Problem in DLASQ2.
* =-6: Problem in DLASQ2.
*
* Further Details
* The base representations are required to suffer very little
* element growth and consequently define all their eigenvalues to
* high relative accuracy.
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION FAC, FOUR, FOURTH, FUDGE, HALF, HNDRD,
$ MAXGROWTH, ONE, PERT, TWO, ZERO
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0,
$ TWO = 2.0D0, FOUR=4.0D0,
$ HNDRD = 100.0D0,
$ PERT = 8.0D0,
$ HALF = ONE/TWO, FOURTH = ONE/FOUR, FAC= HALF,
$ MAXGROWTH = 64.0D0, FUDGE = 2.0D0 )
INTEGER MAXTRY, ALLRNG, INDRNG, VALRNG
PARAMETER ( MAXTRY = 6, ALLRNG = 1, INDRNG = 2,
$ VALRNG = 3 )
* ..
* .. Local Scalars ..
LOGICAL FORCEB, NOREP, USEDQD
INTEGER CNT, CNT1, CNT2, I, IBEGIN, IDUM, IEND, IINFO,
$ IN, INDL, INDU, IRANGE, J, JBLK, MB, MM,
$ WBEGIN, WEND
DOUBLE PRECISION AVGAP, BSRTOL, CLWDTH, DMAX, DPIVOT, EABS,
$ EMAX, EOLD, EPS, GL, GU, ISLEFT, ISRGHT, RTL,
$ RTOL, S1, S2, SAFMIN, SGNDEF, SIGMA, SPDIAM,
$ TAU, TMP, TMP1
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH, LSAME
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLARNV, DLARRA, DLARRB, DLARRC, DLARRD,
$ DLASQ2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Decode RANGE
*
IF( LSAME( RANGE, 'A' ) ) THEN
IRANGE = ALLRNG
ELSE IF( LSAME( RANGE, 'V' ) ) THEN
IRANGE = VALRNG
ELSE IF( LSAME( RANGE, 'I' ) ) THEN
IRANGE = INDRNG
END IF
M = 0
* Get machine constants
SAFMIN = DLAMCH( 'S' )
EPS = DLAMCH( 'P' )
* Set parameters
RTL = SQRT(EPS)
BSRTOL = SQRT(EPS)
* Treat case of 1x1 matrix for quick return
IF( N.EQ.1 ) THEN
IF( (IRANGE.EQ.ALLRNG).OR.
$ ((IRANGE.EQ.VALRNG).AND.(D(1).GT.VL).AND.(D(1).LE.VU)).OR.
$ ((IRANGE.EQ.INDRNG).AND.(IL.EQ.1).AND.(IU.EQ.1)) ) THEN
M = 1
W(1) = D(1)
* The computation error of the eigenvalue is zero
WERR(1) = ZERO
WGAP(1) = ZERO
IBLOCK( 1 ) = 1
INDEXW( 1 ) = 1
GERS(1) = D( 1 )
GERS(2) = D( 1 )
ENDIF
* store the shift for the initial RRR, which is zero in this case
E(1) = ZERO
RETURN
END IF
* General case: tridiagonal matrix of order > 1
*
* Init WERR, WGAP. Compute Gerschgorin intervals and spectral diameter.
* Compute maximum off-diagonal entry and pivmin.
GL = D(1)
GU = D(1)
EOLD = ZERO
EMAX = ZERO
E(N) = ZERO
DO 5 I = 1,N
WERR(I) = ZERO
WGAP(I) = ZERO
EABS = ABS( E(I) )
IF( EABS .GE. EMAX ) THEN
EMAX = EABS
END IF
TMP1 = EABS + EOLD
GERS( 2*I-1) = D(I) - TMP1
GL = MIN( GL, GERS( 2*I - 1))
GERS( 2*I ) = D(I) + TMP1
GU = MAX( GU, GERS(2*I) )
EOLD = EABS
5 CONTINUE
* The minimum pivot allowed in the Sturm sequence for T
PIVMIN = SAFMIN * MAX( ONE, EMAX**2 )
* Compute spectral diameter. The Gerschgorin bounds give an
* estimate that is wrong by at most a factor of SQRT(2)
SPDIAM = GU - GL
* Compute splitting points
CALL DLARRA( N, D, E, E2, SPLTOL, SPDIAM,
$ NSPLIT, ISPLIT, IINFO )
* Can force use of bisection instead of faster DQDS.
* Option left in the code for future multisection work.
FORCEB = .FALSE.
IF( (IRANGE.EQ.ALLRNG) .AND. (.NOT. FORCEB) ) THEN
* Set interval [VL,VU] that contains all eigenvalues
VL = GL
VU = GU
ELSE
* We call DLARRD to find crude approximations to the eigenvalues
* in the desired range. In case IRANGE = INDRNG, we also obtain the
* interval (VL,VU] that contains all the wanted eigenvalues.
* An interval [LEFT,RIGHT] has converged if
* RIGHT-LEFT.LT.RTOL*MAX(ABS(LEFT),ABS(RIGHT))
* DLARRD needs a WORK of size 4*N, IWORK of size 3*N
CALL DLARRD( RANGE, 'B', N, VL, VU, IL, IU, GERS,
$ BSRTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT,
$ MM, W, WERR, VL, VU, IBLOCK, INDEXW,
$ WORK, IWORK, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = -1
RETURN
ENDIF
* Make sure that the entries M+1 to N in W, WERR, IBLOCK, INDEXW are 0
DO 14 I = MM+1,N
W( I ) = ZERO
WERR( I ) = ZERO
IBLOCK( I ) = 0
INDEXW( I ) = 0
14 CONTINUE
END IF
***
* Loop over unreduced blocks
IBEGIN = 1
WBEGIN = 1
DO 170 JBLK = 1, NSPLIT
IEND = ISPLIT( JBLK )
IN = IEND - IBEGIN + 1
* 1 X 1 block
IF( IN.EQ.1 ) THEN
IF( (IRANGE.EQ.ALLRNG).OR.( (IRANGE.EQ.VALRNG).AND.
$ ( D( IBEGIN ).GT.VL ).AND.( D( IBEGIN ).LE.VU ) )
$ .OR. ( (IRANGE.EQ.INDRNG).AND.(IBLOCK(WBEGIN).EQ.JBLK))
$ ) THEN
M = M + 1
W( M ) = D( IBEGIN )
WERR(M) = ZERO
* The gap for a single block doesn't matter for the later
* algorithm and is assigned an arbitrary large value
WGAP(M) = ZERO
IBLOCK( M ) = JBLK
INDEXW( M ) = 1
WBEGIN = WBEGIN + 1
ENDIF
* E( IEND ) holds the shift for the initial RRR
E( IEND ) = ZERO
IBEGIN = IEND + 1
GO TO 170
END IF
*
* Blocks of size larger than 1x1
*
* E( IEND ) will hold the shift for the initial RRR, for now set it =0
E( IEND ) = ZERO
*
* Find local outer bounds GL,GU for the block
GL = D(IBEGIN)
GU = D(IBEGIN)
DO 15 I = IBEGIN , IEND
GL = MIN( GERS( 2*I-1 ), GL )
GU = MAX( GERS( 2*I ), GU )
15 CONTINUE
SPDIAM = GU - GL
IF(.NOT. ((IRANGE.EQ.ALLRNG).AND.(.NOT.FORCEB)) ) THEN
* Count the number of eigenvalues in the current block.
MB = 0
DO 20 I = WBEGIN,MM
IF( IBLOCK(I).EQ.JBLK ) THEN
MB = MB+1
ELSE
GOTO 21
ENDIF
20 CONTINUE
21 CONTINUE
IF( MB.EQ.0) THEN
* No eigenvalue in the current block lies in the desired range
* E( IEND ) holds the shift for the initial RRR
E( IEND ) = ZERO
IBEGIN = IEND + 1
GO TO 170
ELSE
* Decide whether dqds or bisection is more efficient
USEDQD = ( (MB .GT. FAC*IN) .AND. (.NOT.FORCEB) )
WEND = WBEGIN + MB - 1
* Calculate gaps for the current block
* In later stages, when representations for individual
* eigenvalues are different, we use SIGMA = E( IEND ).
SIGMA = ZERO
DO 30 I = WBEGIN, WEND - 1
WGAP( I ) = MAX( ZERO,
$ W(I+1)-WERR(I+1) - (W(I)+WERR(I)) )
30 CONTINUE
WGAP( WEND ) = MAX( ZERO,
$ VU - SIGMA - (W( WEND )+WERR( WEND )))
* Find local index of the first and last desired evalue.
INDL = INDEXW(WBEGIN)
INDU = INDEXW( WEND )
ENDIF
ENDIF
IF(( (IRANGE.EQ.ALLRNG) .AND. (.NOT. FORCEB) ).OR.USEDQD) THEN
* Case of DQDS
* Find approximations to the extremal eigenvalues of the block
CALL DLARRK( IN, 1, GL, GU, D(IBEGIN),
$ E2(IBEGIN), PIVMIN, RTL, TMP, TMP1, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = -1
RETURN
ENDIF
ISLEFT = MAX(GL, TMP - TMP1
$ - HNDRD * EPS* ABS(TMP - TMP1))
CALL DLARRK( IN, IN, GL, GU, D(IBEGIN),
$ E2(IBEGIN), PIVMIN, RTL, TMP, TMP1, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = -1
RETURN
ENDIF
ISRGHT = MIN(GU, TMP + TMP1
$ + HNDRD * EPS * ABS(TMP + TMP1))
* Improve the estimate of the spectral diameter
SPDIAM = ISRGHT - ISLEFT
ELSE
* Case of bisection
* Find approximations to the wanted extremal eigenvalues
ISLEFT = MAX(GL, W(WBEGIN) - WERR(WBEGIN)
$ - HNDRD * EPS*ABS(W(WBEGIN)- WERR(WBEGIN) ))
ISRGHT = MIN(GU,W(WEND) + WERR(WEND)
$ + HNDRD * EPS * ABS(W(WEND)+ WERR(WEND)))
ENDIF
* Decide whether the base representation for the current block
* L_JBLK D_JBLK L_JBLK^T = T_JBLK - sigma_JBLK I
* should be on the left or the right end of the current block.
* The strategy is to shift to the end which is "more populated"
* Furthermore, decide whether to use DQDS for the computation of
* the eigenvalue approximations at the end of DLARRE or bisection.
* dqds is chosen if all eigenvalues are desired or the number of
* eigenvalues to be computed is large compared to the blocksize.
IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN
* If all the eigenvalues have to be computed, we use dqd
USEDQD = .TRUE.
* INDL is the local index of the first eigenvalue to compute
INDL = 1
INDU = IN
* MB = number of eigenvalues to compute
MB = IN
WEND = WBEGIN + MB - 1
* Define 1/4 and 3/4 points of the spectrum
S1 = ISLEFT + FOURTH * SPDIAM
S2 = ISRGHT - FOURTH * SPDIAM
ELSE
* DLARRD has computed IBLOCK and INDEXW for each eigenvalue
* approximation.
* choose sigma
IF( USEDQD ) THEN
S1 = ISLEFT + FOURTH * SPDIAM
S2 = ISRGHT - FOURTH * SPDIAM
ELSE
TMP = MIN(ISRGHT,VU) - MAX(ISLEFT,VL)
S1 = MAX(ISLEFT,VL) + FOURTH * TMP
S2 = MIN(ISRGHT,VU) - FOURTH * TMP
ENDIF
ENDIF
* Compute the negcount at the 1/4 and 3/4 points
IF(MB.GT.1) THEN
CALL DLARRC( 'T', IN, S1, S2, D(IBEGIN),
$ E(IBEGIN), PIVMIN, CNT, CNT1, CNT2, IINFO)
ENDIF
IF(MB.EQ.1) THEN
SIGMA = GL
SGNDEF = ONE
ELSEIF( CNT1 - INDL .GE. INDU - CNT2 ) THEN
IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN
SIGMA = MAX(ISLEFT,GL)
ELSEIF( USEDQD ) THEN
* use Gerschgorin bound as shift to get pos def matrix
* for dqds
SIGMA = ISLEFT
ELSE
* use approximation of the first desired eigenvalue of the
* block as shift
SIGMA = MAX(ISLEFT,VL)
ENDIF
SGNDEF = ONE
ELSE
IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN
SIGMA = MIN(ISRGHT,GU)
ELSEIF( USEDQD ) THEN
* use Gerschgorin bound as shift to get neg def matrix
* for dqds
SIGMA = ISRGHT
ELSE
* use approximation of the first desired eigenvalue of the
* block as shift
SIGMA = MIN(ISRGHT,VU)
ENDIF
SGNDEF = -ONE
ENDIF
* An initial SIGMA has been chosen that will be used for computing
* T - SIGMA I = L D L^T
* Define the increment TAU of the shift in case the initial shift
* needs to be refined to obtain a factorization with not too much
* element growth.
IF( USEDQD ) THEN
* The initial SIGMA was to the outer end of the spectrum
* the matrix is definite and we need not retreat.
TAU = SPDIAM*EPS*N + TWO*PIVMIN
ELSE
IF(MB.GT.1) THEN
CLWDTH = W(WEND) + WERR(WEND) - W(WBEGIN) - WERR(WBEGIN)
AVGAP = ABS(CLWDTH / DBLE(WEND-WBEGIN))
IF( SGNDEF.EQ.ONE ) THEN
TAU = HALF*MAX(WGAP(WBEGIN),AVGAP)
TAU = MAX(TAU,WERR(WBEGIN))
ELSE
TAU = HALF*MAX(WGAP(WEND-1),AVGAP)
TAU = MAX(TAU,WERR(WEND))
ENDIF
ELSE
TAU = WERR(WBEGIN)
ENDIF
ENDIF
*
DO 80 IDUM = 1, MAXTRY
* Compute L D L^T factorization of tridiagonal matrix T - sigma I.
* Store D in WORK(1:IN), L in WORK(IN+1:2*IN), and reciprocals of
* pivots in WORK(2*IN+1:3*IN)
DPIVOT = D( IBEGIN ) - SIGMA
WORK( 1 ) = DPIVOT
DMAX = ABS( WORK(1) )
J = IBEGIN
DO 70 I = 1, IN - 1
WORK( 2*IN+I ) = ONE / WORK( I )
TMP = E( J )*WORK( 2*IN+I )
WORK( IN+I ) = TMP
DPIVOT = ( D( J+1 )-SIGMA ) - TMP*E( J )
WORK( I+1 ) = DPIVOT
DMAX = MAX( DMAX, ABS(DPIVOT) )
J = J + 1
70 CONTINUE
* check for element growth
IF( DMAX .GT. MAXGROWTH*SPDIAM ) THEN
NOREP = .TRUE.
ELSE
NOREP = .FALSE.
ENDIF
IF( USEDQD .AND. .NOT.NOREP ) THEN
* Ensure the definiteness of the representation
* All entries of D (of L D L^T) must have the same sign
DO 71 I = 1, IN
TMP = SGNDEF*WORK( I )
IF( TMP.LT.ZERO ) NOREP = .TRUE.
71 CONTINUE
ENDIF
IF(NOREP) THEN
* Note that in the case of IRANGE=ALLRNG, we use the Gerschgorin
* shift which makes the matrix definite. So we should end up
* here really only in the case of IRANGE = VALRNG or INDRNG.
IF( IDUM.EQ.MAXTRY-1 ) THEN
IF( SGNDEF.EQ.ONE ) THEN
* The fudged Gerschgorin shift should succeed
SIGMA =
$ GL - FUDGE*SPDIAM*EPS*N - FUDGE*TWO*PIVMIN
ELSE
SIGMA =
$ GU + FUDGE*SPDIAM*EPS*N + FUDGE*TWO*PIVMIN
END IF
ELSE
SIGMA = SIGMA - SGNDEF * TAU
TAU = TWO * TAU
END IF
ELSE
* an initial RRR is found
GO TO 83
END IF
80 CONTINUE
* if the program reaches this point, no base representation could be
* found in MAXTRY iterations.
INFO = 2
RETURN
83 CONTINUE
* At this point, we have found an initial base representation
* T - SIGMA I = L D L^T with not too much element growth.
* Store the shift.
E( IEND ) = SIGMA
* Store D and L.
CALL DCOPY( IN, WORK, 1, D( IBEGIN ), 1 )
CALL DCOPY( IN-1, WORK( IN+1 ), 1, E( IBEGIN ), 1 )
IF(MB.GT.1 ) THEN
*
* Perturb each entry of the base representation by a small
* (but random) relative amount to overcome difficulties with
* glued matrices.
*
DO 122 I = 1, 4
ISEED( I ) = 1
122 CONTINUE
CALL DLARNV(2, ISEED, 2*IN-1, WORK(1))
DO 125 I = 1,IN-1
D(IBEGIN+I-1) = D(IBEGIN+I-1)*(ONE+EPS*PERT*WORK(I))
E(IBEGIN+I-1) = E(IBEGIN+I-1)*(ONE+EPS*PERT*WORK(IN+I))
125 CONTINUE
D(IEND) = D(IEND)*(ONE+EPS*FOUR*WORK(IN))
*
ENDIF
*
* Don't update the Gerschgorin intervals because keeping track
* of the updates would be too much work in DLARRV.
* We update W instead and use it to locate the proper Gerschgorin
* intervals.
* Compute the required eigenvalues of L D L' by bisection or dqds
IF ( .NOT.USEDQD ) THEN
* If DLARRD has been used, shift the eigenvalue approximations
* according to their representation. This is necessary for
* a uniform DLARRV since dqds computes eigenvalues of the
* shifted representation. In DLARRV, W will always hold the
* UNshifted eigenvalue approximation.
DO 134 J=WBEGIN,WEND
W(J) = W(J) - SIGMA
WERR(J) = WERR(J) + ABS(W(J)) * EPS
134 CONTINUE
* call DLARRB to reduce eigenvalue error of the approximations
* from DLARRD
DO 135 I = IBEGIN, IEND-1
WORK( I ) = D( I ) * E( I )**2
135 CONTINUE
* use bisection to find EV from INDL to INDU
CALL DLARRB(IN, D(IBEGIN), WORK(IBEGIN),
$ INDL, INDU, RTOL1, RTOL2, INDL-1,
$ W(WBEGIN), WGAP(WBEGIN), WERR(WBEGIN),
$ WORK( 2*N+1 ), IWORK, PIVMIN, SPDIAM,
$ IN, IINFO )
IF( IINFO .NE. 0 ) THEN
INFO = -4
RETURN
END IF
* DLARRB computes all gaps correctly except for the last one
* Record distance to VU/GU
WGAP( WEND ) = MAX( ZERO,
$ ( VU-SIGMA ) - ( W( WEND ) + WERR( WEND ) ) )
DO 138 I = INDL, INDU
M = M + 1
IBLOCK(M) = JBLK
INDEXW(M) = I
138 CONTINUE
ELSE
* Call dqds to get all eigs (and then possibly delete unwanted
* eigenvalues).
* Note that dqds finds the eigenvalues of the L D L^T representation
* of T to high relative accuracy. High relative accuracy
* might be lost when the shift of the RRR is subtracted to obtain
* the eigenvalues of T. However, T is not guaranteed to define its
* eigenvalues to high relative accuracy anyway.
* Set RTOL to the order of the tolerance used in DLASQ2
* This is an ESTIMATED error, the worst case bound is 4*N*EPS
* which is usually too large and requires unnecessary work to be
* done by bisection when computing the eigenvectors
RTOL = LOG(DBLE(IN)) * FOUR * EPS
J = IBEGIN
DO 140 I = 1, IN - 1
WORK( 2*I-1 ) = ABS( D( J ) )
WORK( 2*I ) = E( J )*E( J )*WORK( 2*I-1 )
J = J + 1
140 CONTINUE
WORK( 2*IN-1 ) = ABS( D( IEND ) )
WORK( 2*IN ) = ZERO
CALL DLASQ2( IN, WORK, IINFO )
IF( IINFO .NE. 0 ) THEN
* If IINFO = -5 then an index is part of a tight cluster
* and should be changed. The index is in IWORK(1) and the
* gap is in WORK(N+1)
INFO = -5
RETURN
ELSE
* Test that all eigenvalues are positive as expected
DO 149 I = 1, IN
IF( WORK( I ).LT.ZERO ) THEN
INFO = -6
RETURN
ENDIF
149 CONTINUE
END IF
IF( SGNDEF.GT.ZERO ) THEN
DO 150 I = INDL, INDU
M = M + 1
W( M ) = WORK( IN-I+1 )
IBLOCK( M ) = JBLK
INDEXW( M ) = I
150 CONTINUE
ELSE
DO 160 I = INDL, INDU
M = M + 1
W( M ) = -WORK( I )
IBLOCK( M ) = JBLK
INDEXW( M ) = I
160 CONTINUE
END IF
DO 165 I = M - MB + 1, M
* the value of RTOL below should be the tolerance in DLASQ2
WERR( I ) = RTOL * ABS( W(I) )
165 CONTINUE
DO 166 I = M - MB + 1, M - 1
* compute the right gap between the intervals
WGAP( I ) = MAX( ZERO,
$ W(I+1)-WERR(I+1) - (W(I)+WERR(I)) )
166 CONTINUE
WGAP( M ) = MAX( ZERO,
$ ( VU-SIGMA ) - ( W( M ) + WERR( M ) ) )
END IF
* proceed with next block
IBEGIN = IEND + 1
WBEGIN = WEND + 1
170 CONTINUE
*
RETURN
*
* end of DLARRE
*
END
SUBROUTINE DLARRF( N, D, L, LD, CLSTRT, CLEND,
$ W, WGAP, WERR,
$ SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA,
$ DPLUS, LPLUS, WORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
**
* .. Scalar Arguments ..
INTEGER CLSTRT, CLEND, INFO, N
DOUBLE PRECISION CLGAPL, CLGAPR, PIVMIN, SIGMA, SPDIAM
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), DPLUS( * ), L( * ), LD( * ),
$ LPLUS( * ), W( * ), WGAP( * ), WERR( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* Given the initial representation L D L^T and its cluster of close
* eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ...
* W( CLEND ), DLARRF finds a new relatively robust representation
* L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the
* eigenvalues of L(+) D(+) L(+)^T is relatively isolated.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix (subblock, if the matrix splitted).
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The N diagonal elements of the diagonal matrix D.
*
* L (input) DOUBLE PRECISION array, dimension (N-1)
* The (N-1) subdiagonal elements of the unit bidiagonal
* matrix L.
*
* LD (input) DOUBLE PRECISION array, dimension (N-1)
* The (N-1) elements L(i)*D(i).
*
* CLSTRT (input) INTEGER
* The index of the first eigenvalue in the cluster.
*
* CLEND (input) INTEGER
* The index of the last eigenvalue in the cluster.
*
* W (input) DOUBLE PRECISION array, dimension >= (CLEND-CLSTRT+1)
* The eigenvalue APPROXIMATIONS of L D L^T in ascending order.
* W( CLSTRT ) through W( CLEND ) form the cluster of relatively
* close eigenalues.
*
* WGAP (input/output) DOUBLE PRECISION array, dimension >= (CLEND-CLSTRT+1)
* The separation from the right neighbor eigenvalue in W.
*
* WERR (input) DOUBLE PRECISION array, dimension >= (CLEND-CLSTRT+1)
* WERR contain the semiwidth of the uncertainty
* interval of the corresponding eigenvalue APPROXIMATION in W
*
* SPDIAM (input) estimate of the spectral diameter obtained from the
* Gerschgorin intervals
*
* CLGAPL, CLGAPR (input) absolute gap on each end of the cluster.
* Set by the calling routine to protect against shifts too close
* to eigenvalues outside the cluster.
*
* PIVMIN (input) DOUBLE PRECISION
* The minimum pivot allowed in the Sturm sequence.
*
* SIGMA (output) DOUBLE PRECISION
* The shift used to form L(+) D(+) L(+)^T.
*
* DPLUS (output) DOUBLE PRECISION array, dimension (N)
* The N diagonal elements of the diagonal matrix D(+).
*
* LPLUS (output) DOUBLE PRECISION array, dimension (N-1)
* The first (N-1) elements of LPLUS contain the subdiagonal
* elements of the unit bidiagonal matrix L(+).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
* Workspace.
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION FOUR, MAXGROWTH1, MAXGROWTH2, ONE, QUART, TWO,
$ ZERO
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ FOUR = 4.0D0, QUART = 0.25D0,
$ MAXGROWTH1 = 8.D0,
$ MAXGROWTH2 = 8.D0 )
* ..
* .. Local Scalars ..
LOGICAL DORRR1, FORCER, NOFAIL, SAWNAN1, SAWNAN2, TRYRRR1
INTEGER I, INDX, KTRY, KTRYMAX, SLEFT, SRIGHT, SHIFT
PARAMETER ( KTRYMAX = 1, SLEFT = 1, SRIGHT = 2 )
DOUBLE PRECISION AVGAP, BESTSHIFT, CLWDTH, EPS, FACT, FAIL,
$ FAIL2, GROWTHBOUND, LDELTA, LDMAX, LSIGMA,
$ MAX1, MAX2, MINGAP, OLDP, PROD, RDELTA, RDMAX,
$ RRR1, RRR2, RSIGMA, S, SMLGROWTH, TMP, ZNM2
* ..
* .. External Functions ..
LOGICAL DISNAN
DOUBLE PRECISION DLAMCH
EXTERNAL DISNAN, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DCOPY
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
INFO = 0
FACT = DBLE(2**KTRYMAX)
EPS = DLAMCH( 'Precision' )
SHIFT = 0
FORCER = .FALSE.
* Note that we cannot guarantee that for any of the shifts tried,
* the factorization has a small or even moderate element growth.
* There could be Ritz values at both ends of the cluster and despite
* backing off, there are examples where all factorizations tried
* (in IEEE mode, allowing zero pivots & infinities) have INFINITE
* element growth.
* For this reason, we should use PIVMIN in this subroutine so that at
* least the L D L^T factorization exists. It can be checked afterwards
* whether the element growth caused bad residuals/orthogonality.
* Decide whether the code should accept the best among all
* representations despite large element growth or signal INFO=1
NOFAIL = .TRUE.
*
* Compute the average gap length of the cluster
CLWDTH = ABS(W(CLEND)-W(CLSTRT)) + WERR(CLEND) + WERR(CLSTRT)
AVGAP = CLWDTH / DBLE(CLEND-CLSTRT)
MINGAP = MIN(CLGAPL, CLGAPR)
* Initial values for shifts to both ends of cluster
LSIGMA = MIN(W( CLSTRT ),W( CLEND )) - WERR( CLSTRT )
RSIGMA = MAX(W( CLSTRT ),W( CLEND )) + WERR( CLEND )
* Use a small fudge to make sure that we really shift to the outside
LSIGMA = LSIGMA - ABS(LSIGMA)* FOUR * EPS
RSIGMA = RSIGMA + ABS(RSIGMA)* FOUR * EPS
* Compute upper bounds for how much to back off the initial shifts
LDMAX = QUART * MINGAP + TWO * PIVMIN
RDMAX = QUART * MINGAP + TWO * PIVMIN
LDELTA = MAX(AVGAP,WGAP( CLSTRT ))/FACT
RDELTA = MAX(AVGAP,WGAP( CLEND-1 ))/FACT
*
* Initialize the record of the best representation found
*
S = DLAMCH( 'S' )
SMLGROWTH = ONE / S
FAIL = DBLE(N-1)*MINGAP/(SPDIAM*EPS)
FAIL2 = DBLE(N-1)*MINGAP/(SPDIAM*SQRT(EPS))
BESTSHIFT = LSIGMA
*
* while (KTRY <= KTRYMAX)
KTRY = 0
GROWTHBOUND = MAXGROWTH1*SPDIAM
5 CONTINUE
SAWNAN1 = .FALSE.
SAWNAN2 = .FALSE.
* Ensure that we do not back off too much of the initial shifts
LDELTA = MIN(LDMAX,LDELTA)
RDELTA = MIN(RDMAX,RDELTA)
* Compute the element growth when shifting to both ends of the cluster
* accept the shift if there is no element growth at one of the two ends
* Left end
S = -LSIGMA
DPLUS( 1 ) = D( 1 ) + S
IF(ABS(DPLUS(1)).LT.PIVMIN) THEN
DPLUS(1) = -PIVMIN
* Need to set SAWNAN1 because refined RRR test should not be used
* in this case
SAWNAN1 = .TRUE.
ENDIF
MAX1 = ABS( DPLUS( 1 ) )
DO 6 I = 1, N - 1
LPLUS( I ) = LD( I ) / DPLUS( I )
S = S*LPLUS( I )*L( I ) - LSIGMA
DPLUS( I+1 ) = D( I+1 ) + S
IF(ABS(DPLUS(I+1)).LT.PIVMIN) THEN
DPLUS(I+1) = -PIVMIN
* Need to set SAWNAN1 because refined RRR test should not be used
* in this case
SAWNAN1 = .TRUE.
ENDIF
MAX1 = MAX( MAX1,ABS(DPLUS(I+1)) )
6 CONTINUE
SAWNAN1 = SAWNAN1 .OR. DISNAN( MAX1 )
IF( FORCER .OR.
$ (MAX1.LE.GROWTHBOUND .AND. .NOT.SAWNAN1 ) ) THEN
SIGMA = LSIGMA
SHIFT = SLEFT
GOTO 100
ENDIF
* Right end
S = -RSIGMA
WORK( 1 ) = D( 1 ) + S
IF(ABS(WORK(1)).LT.PIVMIN) THEN
WORK(1) = -PIVMIN
* Need to set SAWNAN2 because refined RRR test should not be used
* in this case
SAWNAN2 = .TRUE.
ENDIF
MAX2 = ABS( WORK( 1 ) )
DO 7 I = 1, N - 1
WORK( N+I ) = LD( I ) / WORK( I )
S = S*WORK( N+I )*L( I ) - RSIGMA
WORK( I+1 ) = D( I+1 ) + S
IF(ABS(WORK(I+1)).LT.PIVMIN) THEN
WORK(I+1) = -PIVMIN
* Need to set SAWNAN2 because refined RRR test should not be used
* in this case
SAWNAN2 = .TRUE.
ENDIF
MAX2 = MAX( MAX2,ABS(WORK(I+1)) )
7 CONTINUE
SAWNAN2 = SAWNAN2 .OR. DISNAN( MAX2 )
IF( FORCER .OR.
$ (MAX2.LE.GROWTHBOUND .AND. .NOT.SAWNAN2 ) ) THEN
SIGMA = RSIGMA
SHIFT = SRIGHT
GOTO 100
ENDIF
* If we are at this point, both shifts led to too much element growth
* Record the better of the two shifts (provided it didn't lead to NaN)
IF(SAWNAN1.AND.SAWNAN2) THEN
* both MAX1 and MAX2 are NaN
GOTO 50
ELSE
IF( .NOT.SAWNAN1 ) THEN
INDX = 1
IF(MAX1.LE.SMLGROWTH) THEN
SMLGROWTH = MAX1
BESTSHIFT = LSIGMA
ENDIF
ENDIF
IF( .NOT.SAWNAN2 ) THEN
IF(SAWNAN1 .OR. MAX2.LE.MAX1) INDX = 2
IF(MAX2.LE.SMLGROWTH) THEN
SMLGROWTH = MAX2
BESTSHIFT = RSIGMA
ENDIF
ENDIF
ENDIF
* If we are here, both the left and the right shift led to
* element growth. If the element growth is moderate, then
* we may still accept the representation, if it passes a
* refined test for RRR. This test supposes that no NaN occurred.
* Moreover, we use the refined RRR test only for isolated clusters.
IF((CLWDTH.LT.MINGAP/DBLE(128)) .AND.
$ (MIN(MAX1,MAX2).LT.FAIL2)
$ .AND.(.NOT.SAWNAN1).AND.(.NOT.SAWNAN2)) THEN
DORRR1 = .TRUE.
ELSE
DORRR1 = .FALSE.
ENDIF
TRYRRR1 = .TRUE.
IF( TRYRRR1 .AND. DORRR1 ) THEN
IF(INDX.EQ.1) THEN
TMP = ABS( DPLUS( N ) )
ZNM2 = ONE
PROD = ONE
OLDP = ONE
DO 15 I = N-1, 1, -1
IF( PROD .LE. EPS ) THEN
PROD =
$ ((DPLUS(I+1)*WORK(N+I+1))/(DPLUS(I)*WORK(N+I)))*OLDP
ELSE
PROD = PROD*ABS(WORK(N+I))
END IF
OLDP = PROD
ZNM2 = ZNM2 + PROD**2
TMP = MAX( TMP, ABS( DPLUS( I ) * PROD ))
15 CONTINUE
RRR1 = TMP/( SPDIAM * SQRT( ZNM2 ) )
IF (RRR1.LE.MAXGROWTH2) THEN
SIGMA = LSIGMA
SHIFT = SLEFT
GOTO 100
ENDIF
ELSE IF(INDX.EQ.2) THEN
TMP = ABS( WORK( N ) )
ZNM2 = ONE
PROD = ONE
OLDP = ONE
DO 16 I = N-1, 1, -1
IF( PROD .LE. EPS ) THEN
PROD = ((WORK(I+1)*LPLUS(I+1))/(WORK(I)*LPLUS(I)))*OLDP
ELSE
PROD = PROD*ABS(LPLUS(I))
END IF
OLDP = PROD
ZNM2 = ZNM2 + PROD**2
TMP = MAX( TMP, ABS( WORK( I ) * PROD ))
16 CONTINUE
RRR2 = TMP/( SPDIAM * SQRT( ZNM2 ) )
IF (RRR2.LE.MAXGROWTH2) THEN
SIGMA = RSIGMA
SHIFT = SRIGHT
GOTO 100
ENDIF
END IF
ENDIF
50 CONTINUE
IF (KTRY.LT.KTRYMAX) THEN
* If we are here, both shifts failed also the RRR test.
* Back off to the outside
LSIGMA = MAX( LSIGMA - LDELTA,
$ LSIGMA - LDMAX)
RSIGMA = MIN( RSIGMA + RDELTA,
$ RSIGMA + RDMAX )
LDELTA = TWO * LDELTA
RDELTA = TWO * RDELTA
KTRY = KTRY + 1
GOTO 5
ELSE
* None of the representations investigated satisfied our
* criteria. Take the best one we found.
IF((SMLGROWTH.LT.FAIL).OR.NOFAIL) THEN
LSIGMA = BESTSHIFT
RSIGMA = BESTSHIFT
FORCER = .TRUE.
GOTO 5
ELSE
INFO = 1
RETURN
ENDIF
END IF
100 CONTINUE
IF (SHIFT.EQ.SLEFT) THEN
ELSEIF (SHIFT.EQ.SRIGHT) THEN
* store new L and D back into DPLUS, LPLUS
CALL DCOPY( N, WORK, 1, DPLUS, 1 )
CALL DCOPY( N-1, WORK(N+1), 1, LPLUS, 1 )
ENDIF
RETURN
*
* End of DLARRF
*
END
SUBROUTINE DLARRJ( N, D, E2, IFIRST, ILAST,
$ RTOL, OFFSET, W, WERR, WORK, IWORK,
$ PIVMIN, SPDIAM, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IFIRST, ILAST, INFO, N, OFFSET
DOUBLE PRECISION PIVMIN, RTOL, SPDIAM
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION D( * ), E2( * ), W( * ),
$ WERR( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* Given the initial eigenvalue approximations of T, DLARRJ
* does bisection to refine the eigenvalues of T,
* W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial
* guesses for these eigenvalues are input in W, the corresponding estimate
* of the error in these guesses in WERR. During bisection, intervals
* [left, right] are maintained by storing their mid-points and
* semi-widths in the arrays W and WERR respectively.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The N diagonal elements of T.
*
* E2 (input) DOUBLE PRECISION array, dimension (N-1)
* The Squares of the (N-1) subdiagonal elements of T.
*
* IFIRST (input) INTEGER
* The index of the first eigenvalue to be computed.
*
* ILAST (input) INTEGER
* The index of the last eigenvalue to be computed.
*
* RTOL (input) DOUBLE PRECISION
* Tolerance for the convergence of the bisection intervals.
* An interval [LEFT,RIGHT] has converged if
* RIGHT-LEFT.LT.RTOL*MAX(|LEFT|,|RIGHT|).
*
* OFFSET (input) INTEGER
* Offset for the arrays W and WERR, i.e., the IFIRST-OFFSET
* through ILAST-OFFSET elements of these arrays are to be used.
*
* W (input/output) DOUBLE PRECISION array, dimension (N)
* On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are
* estimates of the eigenvalues of L D L^T indexed IFIRST through
* ILAST.
* On output, these estimates are refined.
*
* WERR (input/output) DOUBLE PRECISION array, dimension (N)
* On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are
* the errors in the estimates of the corresponding elements in W.
* On output, these errors are refined.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
* Workspace.
*
* IWORK (workspace) INTEGER array, dimension (2*N)
* Workspace.
*
* PIVMIN (input) DOUBLE PRECISION
* The minimum pivot in the Sturm sequence for T.
*
* SPDIAM (input) DOUBLE PRECISION
* The spectral diameter of T.
*
* INFO (output) INTEGER
* Error flag.
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, HALF
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ HALF = 0.5D0 )
INTEGER MAXITR
* ..
* .. Local Scalars ..
INTEGER CNT, I, I1, I2, II, ITER, J, K, NEXT, NINT,
$ OLNINT, P, PREV, SAVI1
DOUBLE PRECISION DPLUS, FAC, LEFT, MID, RIGHT, S, TMP, WIDTH
*
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
INFO = 0
*
MAXITR = INT( ( LOG( SPDIAM+PIVMIN )-LOG( PIVMIN ) ) /
$ LOG( TWO ) ) + 2
*
* Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ].
* The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while
* Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 )
* for an unconverged interval is set to the index of the next unconverged
* interval, and is -1 or 0 for a converged interval. Thus a linked
* list of unconverged intervals is set up.
*
I1 = IFIRST
I2 = ILAST
* The number of unconverged intervals
NINT = 0
* The last unconverged interval found
PREV = 0
DO 75 I = I1, I2
K = 2*I
II = I - OFFSET
LEFT = W( II ) - WERR( II )
MID = W(II)
RIGHT = W( II ) + WERR( II )
WIDTH = RIGHT - MID
TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
* The following test prevents the test of converged intervals
IF( WIDTH.LT.RTOL*TMP ) THEN
* This interval has already converged and does not need refinement.
* (Note that the gaps might change through refining the
* eigenvalues, however, they can only get bigger.)
* Remove it from the list.
IWORK( K-1 ) = -1
* Make sure that I1 always points to the first unconverged interval
IF((I.EQ.I1).AND.(I.LT.I2)) I1 = I + 1
IF((PREV.GE.I1).AND.(I.LE.I2)) IWORK( 2*PREV-1 ) = I + 1
ELSE
* unconverged interval found
PREV = I
* Make sure that [LEFT,RIGHT] contains the desired eigenvalue
*
* Do while( CNT(LEFT).GT.I-1 )
*
FAC = ONE
20 CONTINUE
CNT = 0
S = LEFT
DPLUS = D( 1 ) - S
IF( DPLUS.LT.ZERO ) CNT = CNT + 1
DO 30 J = 2, N
DPLUS = D( J ) - S - E2( J-1 )/DPLUS
IF( DPLUS.LT.ZERO ) CNT = CNT + 1
30 CONTINUE
IF( CNT.GT.I-1 ) THEN
LEFT = LEFT - WERR( II )*FAC
FAC = TWO*FAC
GO TO 20
END IF
*
* Do while( CNT(RIGHT).LT.I )
*
FAC = ONE
50 CONTINUE
CNT = 0
S = RIGHT
DPLUS = D( 1 ) - S
IF( DPLUS.LT.ZERO ) CNT = CNT + 1
DO 60 J = 2, N
DPLUS = D( J ) - S - E2( J-1 )/DPLUS
IF( DPLUS.LT.ZERO ) CNT = CNT + 1
60 CONTINUE
IF( CNT.LT.I ) THEN
RIGHT = RIGHT + WERR( II )*FAC
FAC = TWO*FAC
GO TO 50
END IF
NINT = NINT + 1
IWORK( K-1 ) = I + 1
IWORK( K ) = CNT
END IF
WORK( K-1 ) = LEFT
WORK( K ) = RIGHT
75 CONTINUE
SAVI1 = I1
*
* Do while( NINT.GT.0 ), i.e. there are still unconverged intervals
* and while (ITER.LT.MAXITR)
*
ITER = 0
80 CONTINUE
PREV = I1 - 1
I = I1
OLNINT = NINT
DO 100 P = 1, OLNINT
K = 2*I
II = I - OFFSET
NEXT = IWORK( K-1 )
LEFT = WORK( K-1 )
RIGHT = WORK( K )
MID = HALF*( LEFT + RIGHT )
* semiwidth of interval
WIDTH = RIGHT - MID
TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
IF( ( WIDTH.LT.RTOL*TMP ) .OR.
$ (ITER.EQ.MAXITR) )THEN
* reduce number of unconverged intervals
NINT = NINT - 1
* Mark interval as converged.
IWORK( K-1 ) = 0
IF( I1.EQ.I ) THEN
I1 = NEXT
ELSE
* Prev holds the last unconverged interval previously examined
IF(PREV.GE.I1) IWORK( 2*PREV-1 ) = NEXT
END IF
I = NEXT
GO TO 100
END IF
PREV = I
*
* Perform one bisection step
*
CNT = 0
S = MID
DPLUS = D( 1 ) - S
IF( DPLUS.LT.ZERO ) CNT = CNT + 1
DO 90 J = 2, N
DPLUS = D( J ) - S - E2( J-1 )/DPLUS
IF( DPLUS.LT.ZERO ) CNT = CNT + 1
90 CONTINUE
IF( CNT.LE.I-1 ) THEN
WORK( K-1 ) = MID
ELSE
WORK( K ) = MID
END IF
I = NEXT
100 CONTINUE
ITER = ITER + 1
* do another loop if there are still unconverged intervals
* However, in the last iteration, all intervals are accepted
* since this is the best we can do.
IF( ( NINT.GT.0 ).AND.(ITER.LE.MAXITR) ) GO TO 80
*
*
* At this point, all the intervals have converged
DO 110 I = SAVI1, ILAST
K = 2*I
II = I - OFFSET
* All intervals marked by '0' have been refined.
IF( IWORK( K-1 ).EQ.0 ) THEN
W( II ) = HALF*( WORK( K-1 )+WORK( K ) )
WERR( II ) = WORK( K ) - W( II )
END IF
110 CONTINUE
*
RETURN
*
* End of DLARRJ
*
END
SUBROUTINE DLARRK( N, IW, GL, GU,
$ D, E2, PIVMIN, RELTOL, W, WERR, INFO)
IMPLICIT NONE
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, IW, N
DOUBLE PRECISION PIVMIN, RELTOL, GL, GU, W, WERR
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E2( * )
* ..
*
* Purpose
* =======
*
* DLARRK computes one eigenvalue of a symmetric tridiagonal
* matrix T to suitable accuracy. This is an auxiliary code to be
* called from DSTEMR.
*
* To avoid overflow, the matrix must be scaled so that its
* largest element is no greater than overflow**(1/2) *
* underflow**(1/4) in absolute value, and for greatest
* accuracy, it should not be much smaller than that.
*
* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
* Matrix", Report CS41, Computer Science Dept., Stanford
* University, July 21, 1966.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the tridiagonal matrix T. N >= 0.
*
* IW (input) INTEGER
* The index of the eigenvalues to be returned.
*
* GL (input) DOUBLE PRECISION
* GU (input) DOUBLE PRECISION
* An upper and a lower bound on the eigenvalue.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the tridiagonal matrix T.
*
* E2 (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) squared off-diagonal elements of the tridiagonal matrix T.
*
* PIVMIN (input) DOUBLE PRECISION
* The minimum pivot allowed in the Sturm sequence for T.
*
* RELTOL (input) DOUBLE PRECISION
* The minimum relative width of an interval. When an interval
* is narrower than RELTOL times the larger (in
* magnitude) endpoint, then it is considered to be
* sufficiently small, i.e., converged. Note: this should
* always be at least radix*machine epsilon.
*
* W (output) DOUBLE PRECISION
*
* WERR (output) DOUBLE PRECISION
* The error bound on the corresponding eigenvalue approximation
* in W.
*
* INFO (output) INTEGER
* = 0: Eigenvalue converged
* = -1: Eigenvalue did NOT converge
*
* Internal Parameters
* ===================
*
* FUDGE DOUBLE PRECISION, default = 2
* A "fudge factor" to widen the Gershgorin intervals.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION FUDGE, HALF, TWO, ZERO
PARAMETER ( HALF = 0.5D0, TWO = 2.0D0,
$ FUDGE = TWO, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, IT, ITMAX, NEGCNT
DOUBLE PRECISION ATOLI, EPS, LEFT, MID, RIGHT, RTOLI, TMP1,
$ TMP2, TNORM
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX
* ..
* .. Executable Statements ..
*
* Get machine constants
EPS = DLAMCH( 'P' )
TNORM = MAX( ABS( GL ), ABS( GU ) )
RTOLI = RELTOL
ATOLI = FUDGE*TWO*PIVMIN
ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) /
$ LOG( TWO ) ) + 2
INFO = -1
LEFT = GL - FUDGE*TNORM*EPS*N - FUDGE*TWO*PIVMIN
RIGHT = GU + FUDGE*TNORM*EPS*N + FUDGE*TWO*PIVMIN
IT = 0
10 CONTINUE
*
* Check if interval converged or maximum number of iterations reached
*
TMP1 = ABS( RIGHT - LEFT )
TMP2 = MAX( ABS(RIGHT), ABS(LEFT) )
IF( TMP1.LT.MAX( ATOLI, PIVMIN, RTOLI*TMP2 ) ) THEN
INFO = 0
GOTO 30
ENDIF
IF(IT.GT.ITMAX)
$ GOTO 30
*
* Count number of negative pivots for mid-point
*
IT = IT + 1
MID = HALF * (LEFT + RIGHT)
NEGCNT = 0
TMP1 = D( 1 ) - MID
IF( ABS( TMP1 ).LT.PIVMIN )
$ TMP1 = -PIVMIN
IF( TMP1.LE.ZERO )
$ NEGCNT = NEGCNT + 1
*
DO 20 I = 2, N
TMP1 = D( I ) - E2( I-1 ) / TMP1 - MID
IF( ABS( TMP1 ).LT.PIVMIN )
$ TMP1 = -PIVMIN
IF( TMP1.LE.ZERO )
$ NEGCNT = NEGCNT + 1
20 CONTINUE
IF(NEGCNT.GE.IW) THEN
RIGHT = MID
ELSE
LEFT = MID
ENDIF
GOTO 10
30 CONTINUE
*
* Converged or maximum number of iterations reached
*
W = HALF * (LEFT + RIGHT)
WERR = HALF * ABS( RIGHT - LEFT )
RETURN
*
* End of DLARRK
*
END
SUBROUTINE DLARRR( N, D, E, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER N, INFO
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * )
* ..
*
*
* Purpose
* =======
*
* Perform tests to decide whether the symmetric tridiagonal matrix T
* warrants expensive computations which guarantee high relative accuracy
* in the eigenvalues.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix. N > 0.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The N diagonal elements of the tridiagonal matrix T.
*
* E (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the first (N-1) entries contain the subdiagonal
* elements of the tridiagonal matrix T; E(N) is set to ZERO.
*
* INFO (output) INTEGER
* INFO = 0(default) : the matrix warrants computations preserving
* relative accuracy.
* INFO = 1 : the matrix warrants computations guaranteeing
* only absolute accuracy.
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, RELCOND
PARAMETER ( ZERO = 0.0D0,
$ RELCOND = 0.999D0 )
* ..
* .. Local Scalars ..
INTEGER I
LOGICAL YESREL
DOUBLE PRECISION EPS, SAFMIN, SMLNUM, RMIN, TMP, TMP2,
$ OFFDIG, OFFDIG2
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
* As a default, do NOT go for relative-accuracy preserving computations.
INFO = 1
SAFMIN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
RMIN = SQRT( SMLNUM )
* Tests for relative accuracy
*
* Test for scaled diagonal dominance
* Scale the diagonal entries to one and check whether the sum of the
* off-diagonals is less than one
*
* The sdd relative error bounds have a 1/(1- 2*x) factor in them,
* x = max(OFFDIG + OFFDIG2), so when x is close to 1/2, no relative
* accuracy is promised. In the notation of the code fragment below,
* 1/(1 - (OFFDIG + OFFDIG2)) is the condition number.
* We don't think it is worth going into "sdd mode" unless the relative
* condition number is reasonable, not 1/macheps.
* The threshold should be compatible with other thresholds used in the
* code. We set OFFDIG + OFFDIG2 <= .999 =: RELCOND, it corresponds
* to losing at most 3 decimal digits: 1 / (1 - (OFFDIG + OFFDIG2)) <= 1000
* instead of the current OFFDIG + OFFDIG2 < 1
*
YESREL = .TRUE.
OFFDIG = ZERO
TMP = SQRT(ABS(D(1)))
IF (TMP.LT.RMIN) YESREL = .FALSE.
IF(.NOT.YESREL) GOTO 11
DO 10 I = 2, N
TMP2 = SQRT(ABS(D(I)))
IF (TMP2.LT.RMIN) YESREL = .FALSE.
IF(.NOT.YESREL) GOTO 11
OFFDIG2 = ABS(E(I-1))/(TMP*TMP2)
IF(OFFDIG+OFFDIG2.GE.RELCOND) YESREL = .FALSE.
IF(.NOT.YESREL) GOTO 11
TMP = TMP2
OFFDIG = OFFDIG2
10 CONTINUE
11 CONTINUE
IF( YESREL ) THEN
INFO = 0
RETURN
ELSE
ENDIF
*
*
* *** MORE TO BE IMPLEMENTED ***
*
*
* Test if the lower bidiagonal matrix L from T = L D L^T
* (zero shift facto) is well conditioned
*
*
* Test if the upper bidiagonal matrix U from T = U D U^T
* (zero shift facto) is well conditioned.
* In this case, the matrix needs to be flipped and, at the end
* of the eigenvector computation, the flip needs to be applied
* to the computed eigenvectors (and the support)
*
*
RETURN
*
* END OF DLARRR
*
END
SUBROUTINE DLARRV( N, VL, VU, D, L, PIVMIN,
$ ISPLIT, M, DOL, DOU, MINRGP,
$ RTOL1, RTOL2, W, WERR, WGAP,
$ IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ,
$ WORK, IWORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER DOL, DOU, INFO, LDZ, M, N
DOUBLE PRECISION MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU
* ..
* .. Array Arguments ..
INTEGER IBLOCK( * ), INDEXW( * ), ISPLIT( * ),
$ ISUPPZ( * ), IWORK( * )
DOUBLE PRECISION D( * ), GERS( * ), L( * ), W( * ), WERR( * ),
$ WGAP( * ), WORK( * )
DOUBLE PRECISION Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DLARRV computes the eigenvectors of the tridiagonal matrix
* T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T.
* The input eigenvalues should have been computed by DLARRE.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* VL (input) DOUBLE PRECISION
* VU (input) DOUBLE PRECISION
* Lower and upper bounds of the interval that contains the desired
* eigenvalues. VL < VU. Needed to compute gaps on the left or right
* end of the extremal eigenvalues in the desired RANGE.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the N diagonal elements of the diagonal matrix D.
* On exit, D may be overwritten.
*
* L (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the (N-1) subdiagonal elements of the unit
* bidiagonal matrix L are in elements 1 to N-1 of L
* (if the matrix is not splitted.) At the end of each block
* is stored the corresponding shift as given by DLARRE.
* On exit, L is overwritten.
*
* PIVMIN (in) DOUBLE PRECISION
* The minimum pivot allowed in the Sturm sequence.
*
* ISPLIT (input) INTEGER array, dimension (N)
* The splitting points, at which T breaks up into blocks.
* The first block consists of rows/columns 1 to
* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
* through ISPLIT( 2 ), etc.
*
* M (input) INTEGER
* The total number of input eigenvalues. 0 <= M <= N.
*
* DOL (input) INTEGER
* DOU (input) INTEGER
* If the user wants to compute only selected eigenvectors from all
* the eigenvalues supplied, he can specify an index range DOL:DOU.
* Or else the setting DOL=1, DOU=M should be applied.
* Note that DOL and DOU refer to the order in which the eigenvalues
* are stored in W.
* If the user wants to compute only selected eigenpairs, then
* the columns DOL-1 to DOU+1 of the eigenvector space Z contain the
* computed eigenvectors. All other columns of Z are set to zero.
*
* MINRGP (input) DOUBLE PRECISION
*
* RTOL1 (input) DOUBLE PRECISION
* RTOL2 (input) DOUBLE PRECISION
* Parameters for bisection.
* An interval [LEFT,RIGHT] has converged if
* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
*
* W (input/output) DOUBLE PRECISION array, dimension (N)
* The first M elements of W contain the APPROXIMATE eigenvalues for
* which eigenvectors are to be computed. The eigenvalues
* should be grouped by split-off block and ordered from
* smallest to largest within the block ( The output array
* W from DLARRE is expected here ). Furthermore, they are with
* respect to the shift of the corresponding root representation
* for their block. On exit, W holds the eigenvalues of the
* UNshifted matrix.
*
* WERR (input/output) DOUBLE PRECISION array, dimension (N)
* The first M elements contain the semiwidth of the uncertainty
* interval of the corresponding eigenvalue in W
*
* WGAP (input/output) DOUBLE PRECISION array, dimension (N)
* The separation from the right neighbor eigenvalue in W.
*
* IBLOCK (input) INTEGER array, dimension (N)
* The indices of the blocks (submatrices) associated with the
* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue
* W(i) belongs to the first block from the top, =2 if W(i)
* belongs to the second block, etc.
*
* INDEXW (input) INTEGER array, dimension (N)
* The indices of the eigenvalues within each block (submatrix);
* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the
* i-th eigenvalue W(i) is the 10-th eigenvalue in the second block.
*
* GERS (input) DOUBLE PRECISION array, dimension (2*N)
* The N Gerschgorin intervals (the i-th Gerschgorin interval
* is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should
* be computed from the original UNshifted matrix.
*
* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
* If INFO = 0, the first M columns of Z contain the
* orthonormal eigenvectors of the matrix T
* corresponding to the input eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* Note: the user must ensure that at least max(1,M) columns are
* supplied in the array Z.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )
* The support of the eigenvectors in Z, i.e., the indices
* indicating the nonzero elements in Z. The I-th eigenvector
* is nonzero only in elements ISUPPZ( 2*I-1 ) through
* ISUPPZ( 2*I ).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (12*N)
*
* IWORK (workspace) INTEGER array, dimension (7*N)
*
* INFO (output) INTEGER
* = 0: successful exit
*
* > 0: A problem occured in DLARRV.
* < 0: One of the called subroutines signaled an internal problem.
* Needs inspection of the corresponding parameter IINFO
* for further information.
*
* =-1: Problem in DLARRB when refining a child's eigenvalues.
* =-2: Problem in DLARRF when computing the RRR of a child.
* When a child is inside a tight cluster, it can be difficult
* to find an RRR. A partial remedy from the user's point of
* view is to make the parameter MINRGP smaller and recompile.
* However, as the orthogonality of the computed vectors is
* proportional to 1/MINRGP, the user should be aware that
* he might be trading in precision when he decreases MINRGP.
* =-3: Problem in DLARRB when refining a single eigenvalue
* after the Rayleigh correction was rejected.
* = 5: The Rayleigh Quotient Iteration failed to converge to
* full accuracy in MAXITR steps.
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXITR
PARAMETER ( MAXITR = 10 )
DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, HALF
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0,
$ TWO = 2.0D0, THREE = 3.0D0,
$ FOUR = 4.0D0, HALF = 0.5D0)
* ..
* .. Local Scalars ..
LOGICAL ESKIP, NEEDBS, STP2II, TRYRQC, USEDBS, USEDRQ
INTEGER DONE, I, IBEGIN, IDONE, IEND, II, IINDC1,
$ IINDC2, IINDR, IINDWK, IINFO, IM, IN, INDEIG,
$ INDLD, INDLLD, INDWRK, ISUPMN, ISUPMX, ITER,
$ ITMP1, J, JBLK, K, MINIWSIZE, MINWSIZE, NCLUS,
$ NDEPTH, NEGCNT, NEWCLS, NEWFST, NEWFTT, NEWLST,
$ NEWSIZ, OFFSET, OLDCLS, OLDFST, OLDIEN, OLDLST,
$ OLDNCL, P, PARITY, Q, WBEGIN, WEND, WINDEX,
$ WINDMN, WINDPL, ZFROM, ZTO, ZUSEDL, ZUSEDU,
$ ZUSEDW
DOUBLE PRECISION BSTRES, BSTW, EPS, FUDGE, GAP, GAPTOL, GL, GU,
$ LAMBDA, LEFT, LGAP, MINGMA, NRMINV, RESID,
$ RGAP, RIGHT, RQCORR, RQTOL, SAVGAP, SGNDEF,
$ SIGMA, SPDIAM, SSIGMA, TAU, TMP, TOL, ZTZ
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLAR1V, DLARRB, DLARRF, DLASET,
$ DSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN
* ..
* .. Executable Statements ..
* ..
* The first N entries of WORK are reserved for the eigenvalues
INDLD = N+1
INDLLD= 2*N+1
INDWRK= 3*N+1
MINWSIZE = 12 * N
DO 5 I= 1,MINWSIZE
WORK( I ) = ZERO
5 CONTINUE
* IWORK(IINDR+1:IINDR+N) hold the twist indices R for the
* factorization used to compute the FP vector
IINDR = 0
* IWORK(IINDC1+1:IINC2+N) are used to store the clusters of the current
* layer and the one above.
IINDC1 = N
IINDC2 = 2*N
IINDWK = 3*N + 1
MINIWSIZE = 7 * N
DO 10 I= 1,MINIWSIZE
IWORK( I ) = 0
10 CONTINUE
ZUSEDL = 1
IF(DOL.GT.1) THEN
* Set lower bound for use of Z
ZUSEDL = DOL-1
ENDIF
ZUSEDU = M
IF(DOU.LT.M) THEN
* Set lower bound for use of Z
ZUSEDU = DOU+1
ENDIF
* The width of the part of Z that is used
ZUSEDW = ZUSEDU - ZUSEDL + 1
CALL DLASET( 'Full', N, ZUSEDW, ZERO, ZERO,
$ Z(1,ZUSEDL), LDZ )
EPS = DLAMCH( 'Precision' )
RQTOL = TWO * EPS
*
* Set expert flags for standard code.
TRYRQC = .TRUE.
IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN
ELSE
* Only selected eigenpairs are computed. Since the other evalues
* are not refined by RQ iteration, bisection has to compute to full
* accuracy.
RTOL1 = FOUR * EPS
RTOL2 = FOUR * EPS
ENDIF
* The entries WBEGIN:WEND in W, WERR, WGAP correspond to the
* desired eigenvalues. The support of the nonzero eigenvector
* entries is contained in the interval IBEGIN:IEND.
* Remark that if k eigenpairs are desired, then the eigenvectors
* are stored in k contiguous columns of Z.
* DONE is the number of eigenvectors already computed
DONE = 0
IBEGIN = 1
WBEGIN = 1
DO 170 JBLK = 1, IBLOCK( M )
IEND = ISPLIT( JBLK )
SIGMA = L( IEND )
* Find the eigenvectors of the submatrix indexed IBEGIN
* through IEND.
WEND = WBEGIN - 1
15 CONTINUE
IF( WEND.LT.M ) THEN
IF( IBLOCK( WEND+1 ).EQ.JBLK ) THEN
WEND = WEND + 1
GO TO 15
END IF
END IF
IF( WEND.LT.WBEGIN ) THEN
IBEGIN = IEND + 1
GO TO 170
ELSEIF( (WEND.LT.DOL).OR.(WBEGIN.GT.DOU) ) THEN
IBEGIN = IEND + 1
WBEGIN = WEND + 1
GO TO 170
END IF
* Find local spectral diameter of the block
GL = GERS( 2*IBEGIN-1 )
GU = GERS( 2*IBEGIN )
DO 20 I = IBEGIN+1 , IEND
GL = MIN( GERS( 2*I-1 ), GL )
GU = MAX( GERS( 2*I ), GU )
20 CONTINUE
SPDIAM = GU - GL
* OLDIEN is the last index of the previous block
OLDIEN = IBEGIN - 1
* Calculate the size of the current block
IN = IEND - IBEGIN + 1
* The number of eigenvalues in the current block
IM = WEND - WBEGIN + 1
* This is for a 1x1 block
IF( IBEGIN.EQ.IEND ) THEN
DONE = DONE+1
Z( IBEGIN, WBEGIN ) = ONE
ISUPPZ( 2*WBEGIN-1 ) = IBEGIN
ISUPPZ( 2*WBEGIN ) = IBEGIN
W( WBEGIN ) = W( WBEGIN ) + SIGMA
WORK( WBEGIN ) = W( WBEGIN )
IBEGIN = IEND + 1
WBEGIN = WBEGIN + 1
GO TO 170
END IF
* The desired (shifted) eigenvalues are stored in W(WBEGIN:WEND)
* Note that these can be approximations, in this case, the corresp.
* entries of WERR give the size of the uncertainty interval.
* The eigenvalue approximations will be refined when necessary as
* high relative accuracy is required for the computation of the
* corresponding eigenvectors.
CALL DCOPY( IM, W( WBEGIN ), 1,
& WORK( WBEGIN ), 1 )
* We store in W the eigenvalue approximations w.r.t. the original
* matrix T.
DO 30 I=1,IM
W(WBEGIN+I-1) = W(WBEGIN+I-1)+SIGMA
30 CONTINUE
* NDEPTH is the current depth of the representation tree
NDEPTH = 0
* PARITY is either 1 or 0
PARITY = 1
* NCLUS is the number of clusters for the next level of the
* representation tree, we start with NCLUS = 1 for the root
NCLUS = 1
IWORK( IINDC1+1 ) = 1
IWORK( IINDC1+2 ) = IM
* IDONE is the number of eigenvectors already computed in the current
* block
IDONE = 0
* loop while( IDONE.LT.IM )
* generate the representation tree for the current block and
* compute the eigenvectors
40 CONTINUE
IF( IDONE.LT.IM ) THEN
* This is a crude protection against infinitely deep trees
IF( NDEPTH.GT.M ) THEN
INFO = -2
RETURN
ENDIF
* breadth first processing of the current level of the representation
* tree: OLDNCL = number of clusters on current level
OLDNCL = NCLUS
* reset NCLUS to count the number of child clusters
NCLUS = 0
*
PARITY = 1 - PARITY
IF( PARITY.EQ.0 ) THEN
OLDCLS = IINDC1
NEWCLS = IINDC2
ELSE
OLDCLS = IINDC2
NEWCLS = IINDC1
END IF
* Process the clusters on the current level
DO 150 I = 1, OLDNCL
J = OLDCLS + 2*I
* OLDFST, OLDLST = first, last index of current cluster.
* cluster indices start with 1 and are relative
* to WBEGIN when accessing W, WGAP, WERR, Z
OLDFST = IWORK( J-1 )
OLDLST = IWORK( J )
IF( NDEPTH.GT.0 ) THEN
* Retrieve relatively robust representation (RRR) of cluster
* that has been computed at the previous level
* The RRR is stored in Z and overwritten once the eigenvectors
* have been computed or when the cluster is refined
IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN
* Get representation from location of the leftmost evalue
* of the cluster
J = WBEGIN + OLDFST - 1
ELSE
IF(WBEGIN+OLDFST-1.LT.DOL) THEN
* Get representation from the left end of Z array
J = DOL - 1
ELSEIF(WBEGIN+OLDFST-1.GT.DOU) THEN
* Get representation from the right end of Z array
J = DOU
ELSE
J = WBEGIN + OLDFST - 1
ENDIF
ENDIF
CALL DCOPY( IN, Z( IBEGIN, J ), 1, D( IBEGIN ), 1 )
CALL DCOPY( IN-1, Z( IBEGIN, J+1 ), 1, L( IBEGIN ),
$ 1 )
SIGMA = Z( IEND, J+1 )
* Set the corresponding entries in Z to zero
CALL DLASET( 'Full', IN, 2, ZERO, ZERO,
$ Z( IBEGIN, J), LDZ )
END IF
* Compute DL and DLL of current RRR
DO 50 J = IBEGIN, IEND-1
TMP = D( J )*L( J )
WORK( INDLD-1+J ) = TMP
WORK( INDLLD-1+J ) = TMP*L( J )
50 CONTINUE
IF( NDEPTH.GT.0 ) THEN
* P and Q are index of the first and last eigenvalue to compute
* within the current block
P = INDEXW( WBEGIN-1+OLDFST )
Q = INDEXW( WBEGIN-1+OLDLST )
* Offset for the arrays WORK, WGAP and WERR, i.e., th P-OFFSET
* thru' Q-OFFSET elements of these arrays are to be used.
C OFFSET = P-OLDFST
OFFSET = INDEXW( WBEGIN ) - 1
* perform limited bisection (if necessary) to get approximate
* eigenvalues to the precision needed.
CALL DLARRB( IN, D( IBEGIN ),
$ WORK(INDLLD+IBEGIN-1),
$ P, Q, RTOL1, RTOL2, OFFSET,
$ WORK(WBEGIN),WGAP(WBEGIN),WERR(WBEGIN),
$ WORK( INDWRK ), IWORK( IINDWK ),
$ PIVMIN, SPDIAM, IN, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = -1
RETURN
ENDIF
* We also recompute the extremal gaps. W holds all eigenvalues
* of the unshifted matrix and must be used for computation
* of WGAP, the entries of WORK might stem from RRRs with
* different shifts. The gaps from WBEGIN-1+OLDFST to
* WBEGIN-1+OLDLST are correctly computed in DLARRB.
* However, we only allow the gaps to become greater since
* this is what should happen when we decrease WERR
IF( OLDFST.GT.1) THEN
WGAP( WBEGIN+OLDFST-2 ) =
$ MAX(WGAP(WBEGIN+OLDFST-2),
$ W(WBEGIN+OLDFST-1)-WERR(WBEGIN+OLDFST-1)
$ - W(WBEGIN+OLDFST-2)-WERR(WBEGIN+OLDFST-2) )
ENDIF
IF( WBEGIN + OLDLST -1 .LT. WEND ) THEN
WGAP( WBEGIN+OLDLST-1 ) =
$ MAX(WGAP(WBEGIN+OLDLST-1),
$ W(WBEGIN+OLDLST)-WERR(WBEGIN+OLDLST)
$ - W(WBEGIN+OLDLST-1)-WERR(WBEGIN+OLDLST-1) )
ENDIF
* Each time the eigenvalues in WORK get refined, we store
* the newly found approximation with all shifts applied in W
DO 53 J=OLDFST,OLDLST
W(WBEGIN+J-1) = WORK(WBEGIN+J-1)+SIGMA
53 CONTINUE
END IF
* Process the current node.
NEWFST = OLDFST
DO 140 J = OLDFST, OLDLST
IF( J.EQ.OLDLST ) THEN
* we are at the right end of the cluster, this is also the
* boundary of the child cluster
NEWLST = J
ELSE IF ( WGAP( WBEGIN + J -1).GE.
$ MINRGP* ABS( WORK(WBEGIN + J -1) ) ) THEN
* the right relative gap is big enough, the child cluster
* (NEWFST,..,NEWLST) is well separated from the following
NEWLST = J
ELSE
* inside a child cluster, the relative gap is not
* big enough.
GOTO 140
END IF
* Compute size of child cluster found
NEWSIZ = NEWLST - NEWFST + 1
* NEWFTT is the place in Z where the new RRR or the computed
* eigenvector is to be stored
IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN
* Store representation at location of the leftmost evalue
* of the cluster
NEWFTT = WBEGIN + NEWFST - 1
ELSE
IF(WBEGIN+NEWFST-1.LT.DOL) THEN
* Store representation at the left end of Z array
NEWFTT = DOL - 1
ELSEIF(WBEGIN+NEWFST-1.GT.DOU) THEN
* Store representation at the right end of Z array
NEWFTT = DOU
ELSE
NEWFTT = WBEGIN + NEWFST - 1
ENDIF
ENDIF
IF( NEWSIZ.GT.1) THEN
*
* Current child is not a singleton but a cluster.
* Compute and store new representation of child.
*
*
* Compute left and right cluster gap.
*
* LGAP and RGAP are not computed from WORK because
* the eigenvalue approximations may stem from RRRs
* different shifts. However, W hold all eigenvalues
* of the unshifted matrix. Still, the entries in WGAP
* have to be computed from WORK since the entries
* in W might be of the same order so that gaps are not
* exhibited correctly for very close eigenvalues.
IF( NEWFST.EQ.1 ) THEN
LGAP = MAX( ZERO,
$ W(WBEGIN)-WERR(WBEGIN) - VL )
ELSE
LGAP = WGAP( WBEGIN+NEWFST-2 )
ENDIF
RGAP = WGAP( WBEGIN+NEWLST-1 )
*
* Compute left- and rightmost eigenvalue of child
* to high precision in order to shift as close
* as possible and obtain as large relative gaps
* as possible
*
DO 55 K =1,2
IF(K.EQ.1) THEN
P = INDEXW( WBEGIN-1+NEWFST )
ELSE
P = INDEXW( WBEGIN-1+NEWLST )
ENDIF
OFFSET = INDEXW( WBEGIN ) - 1
CALL DLARRB( IN, D(IBEGIN),
$ WORK( INDLLD+IBEGIN-1 ),P,P,
$ RQTOL, RQTOL, OFFSET,
$ WORK(WBEGIN),WGAP(WBEGIN),
$ WERR(WBEGIN),WORK( INDWRK ),
$ IWORK( IINDWK ), PIVMIN, SPDIAM,
$ IN, IINFO )
55 CONTINUE
*
IF((WBEGIN+NEWLST-1.LT.DOL).OR.
$ (WBEGIN+NEWFST-1.GT.DOU)) THEN
* if the cluster contains no desired eigenvalues
* skip the computation of that branch of the rep. tree
*
* We could skip before the refinement of the extremal
* eigenvalues of the child, but then the representation
* tree could be different from the one when nothing is
* skipped. For this reason we skip at this place.
IDONE = IDONE + NEWLST - NEWFST + 1
GOTO 139
ENDIF
*
* Compute RRR of child cluster.
* Note that the new RRR is stored in Z
*
C DLARRF needs LWORK = 2*N
CALL DLARRF( IN, D( IBEGIN ), L( IBEGIN ),
$ WORK(INDLD+IBEGIN-1),
$ NEWFST, NEWLST, WORK(WBEGIN),
$ WGAP(WBEGIN), WERR(WBEGIN),
$ SPDIAM, LGAP, RGAP, PIVMIN, TAU,
$ Z(IBEGIN, NEWFTT),Z(IBEGIN, NEWFTT+1),
$ WORK( INDWRK ), IINFO )
IF( IINFO.EQ.0 ) THEN
* a new RRR for the cluster was found by DLARRF
* update shift and store it
SSIGMA = SIGMA + TAU
Z( IEND, NEWFTT+1 ) = SSIGMA
* WORK() are the midpoints and WERR() the semi-width
* Note that the entries in W are unchanged.
DO 116 K = NEWFST, NEWLST
FUDGE =
$ THREE*EPS*ABS(WORK(WBEGIN+K-1))
WORK( WBEGIN + K - 1 ) =
$ WORK( WBEGIN + K - 1) - TAU
FUDGE = FUDGE +
$ FOUR*EPS*ABS(WORK(WBEGIN+K-1))
* Fudge errors
WERR( WBEGIN + K - 1 ) =
$ WERR( WBEGIN + K - 1 ) + FUDGE
* Gaps are not fudged. Provided that WERR is small
* when eigenvalues are close, a zero gap indicates
* that a new representation is needed for resolving
* the cluster. A fudge could lead to a wrong decision
* of judging eigenvalues 'separated' which in
* reality are not. This could have a negative impact
* on the orthogonality of the computed eigenvectors.
116 CONTINUE
NCLUS = NCLUS + 1
K = NEWCLS + 2*NCLUS
IWORK( K-1 ) = NEWFST
IWORK( K ) = NEWLST
ELSE
INFO = -2
RETURN
ENDIF
ELSE
*
* Compute eigenvector of singleton
*
ITER = 0
*
TOL = FOUR * LOG(DBLE(IN)) * EPS
*
K = NEWFST
WINDEX = WBEGIN + K - 1
WINDMN = MAX(WINDEX - 1,1)
WINDPL = MIN(WINDEX + 1,M)
LAMBDA = WORK( WINDEX )
DONE = DONE + 1
* Check if eigenvector computation is to be skipped
IF((WINDEX.LT.DOL).OR.
$ (WINDEX.GT.DOU)) THEN
ESKIP = .TRUE.
GOTO 125
ELSE
ESKIP = .FALSE.
ENDIF
LEFT = WORK( WINDEX ) - WERR( WINDEX )
RIGHT = WORK( WINDEX ) + WERR( WINDEX )
INDEIG = INDEXW( WINDEX )
* Note that since we compute the eigenpairs for a child,
* all eigenvalue approximations are w.r.t the same shift.
* In this case, the entries in WORK should be used for
* computing the gaps since they exhibit even very small
* differences in the eigenvalues, as opposed to the
* entries in W which might "look" the same.
IF( K .EQ. 1) THEN
* In the case RANGE='I' and with not much initial
* accuracy in LAMBDA and VL, the formula
* LGAP = MAX( ZERO, (SIGMA - VL) + LAMBDA )
* can lead to an overestimation of the left gap and
* thus to inadequately early RQI 'convergence'.
* Prevent this by forcing a small left gap.
LGAP = EPS*MAX(ABS(LEFT),ABS(RIGHT))
ELSE
LGAP = WGAP(WINDMN)
ENDIF
IF( K .EQ. IM) THEN
* In the case RANGE='I' and with not much initial
* accuracy in LAMBDA and VU, the formula
* can lead to an overestimation of the right gap and
* thus to inadequately early RQI 'convergence'.
* Prevent this by forcing a small right gap.
RGAP = EPS*MAX(ABS(LEFT),ABS(RIGHT))
ELSE
RGAP = WGAP(WINDEX)
ENDIF
GAP = MIN( LGAP, RGAP )
IF(( K .EQ. 1).OR.(K .EQ. IM)) THEN
* The eigenvector support can become wrong
* because significant entries could be cut off due to a
* large GAPTOL parameter in LAR1V. Prevent this.
GAPTOL = ZERO
ELSE
GAPTOL = GAP * EPS
ENDIF
ISUPMN = IN
ISUPMX = 1
* Update WGAP so that it holds the minimum gap
* to the left or the right. This is crucial in the
* case where bisection is used to ensure that the
* eigenvalue is refined up to the required precision.
* The correct value is restored afterwards.
SAVGAP = WGAP(WINDEX)
WGAP(WINDEX) = GAP
* We want to use the Rayleigh Quotient Correction
* as often as possible since it converges quadratically
* when we are close enough to the desired eigenvalue.
* However, the Rayleigh Quotient can have the wrong sign
* and lead us away from the desired eigenvalue. In this
* case, the best we can do is to use bisection.
USEDBS = .FALSE.
USEDRQ = .FALSE.
* Bisection is initially turned off unless it is forced
NEEDBS = .NOT.TRYRQC
120 CONTINUE
* Check if bisection should be used to refine eigenvalue
IF(NEEDBS) THEN
* Take the bisection as new iterate
USEDBS = .TRUE.
ITMP1 = IWORK( IINDR+WINDEX )
OFFSET = INDEXW( WBEGIN ) - 1
CALL DLARRB( IN, D(IBEGIN),
$ WORK(INDLLD+IBEGIN-1),INDEIG,INDEIG,
$ ZERO, TWO*EPS, OFFSET,
$ WORK(WBEGIN),WGAP(WBEGIN),
$ WERR(WBEGIN),WORK( INDWRK ),
$ IWORK( IINDWK ), PIVMIN, SPDIAM,
$ ITMP1, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = -3
RETURN
ENDIF
LAMBDA = WORK( WINDEX )
* Reset twist index from inaccurate LAMBDA to
* force computation of true MINGMA
IWORK( IINDR+WINDEX ) = 0
ENDIF
* Given LAMBDA, compute the eigenvector.
CALL DLAR1V( IN, 1, IN, LAMBDA, D( IBEGIN ),
$ L( IBEGIN ), WORK(INDLD+IBEGIN-1),
$ WORK(INDLLD+IBEGIN-1),
$ PIVMIN, GAPTOL, Z( IBEGIN, WINDEX ),
$ .NOT.USEDBS, NEGCNT, ZTZ, MINGMA,
$ IWORK( IINDR+WINDEX ), ISUPPZ( 2*WINDEX-1 ),
$ NRMINV, RESID, RQCORR, WORK( INDWRK ) )
IF(ITER .EQ. 0) THEN
BSTRES = RESID
BSTW = LAMBDA
ELSEIF(RESID.LT.BSTRES) THEN
BSTRES = RESID
BSTW = LAMBDA
ENDIF
ISUPMN = MIN(ISUPMN,ISUPPZ( 2*WINDEX-1 ))
ISUPMX = MAX(ISUPMX,ISUPPZ( 2*WINDEX ))
ITER = ITER + 1
* sin alpha <= |resid|/gap
* Note that both the residual and the gap are
* proportional to the matrix, so ||T|| doesn't play
* a role in the quotient
*
* Convergence test for Rayleigh-Quotient iteration
* (omitted when Bisection has been used)
*
IF( RESID.GT.TOL*GAP .AND. ABS( RQCORR ).GT.
$ RQTOL*ABS( LAMBDA ) .AND. .NOT. USEDBS)
$ THEN
* We need to check that the RQCORR update doesn't
* move the eigenvalue away from the desired one and
* towards a neighbor. -> protection with bisection
IF(INDEIG.LE.NEGCNT) THEN
* The wanted eigenvalue lies to the left
SGNDEF = -ONE
ELSE
* The wanted eigenvalue lies to the right
SGNDEF = ONE
ENDIF
* We only use the RQCORR if it improves the
* the iterate reasonably.
IF( ( RQCORR*SGNDEF.GE.ZERO )
$ .AND.( LAMBDA + RQCORR.LE. RIGHT)
$ .AND.( LAMBDA + RQCORR.GE. LEFT)
$ ) THEN
USEDRQ = .TRUE.
* Store new midpoint of bisection interval in WORK
IF(SGNDEF.EQ.ONE) THEN
* The current LAMBDA is on the left of the true
* eigenvalue
LEFT = LAMBDA
* We prefer to assume that the error estimate
* is correct. We could make the interval not
* as a bracket but to be modified if the RQCORR
* chooses to. In this case, the RIGHT side should
* be modified as follows:
* RIGHT = MAX(RIGHT, LAMBDA + RQCORR)
ELSE
* The current LAMBDA is on the right of the true
* eigenvalue
RIGHT = LAMBDA
* See comment about assuming the error estimate is
* correct above.
* LEFT = MIN(LEFT, LAMBDA + RQCORR)
ENDIF
WORK( WINDEX ) =
$ HALF * (RIGHT + LEFT)
* Take RQCORR since it has the correct sign and
* improves the iterate reasonably
LAMBDA = LAMBDA + RQCORR
* Update width of error interval
WERR( WINDEX ) =
$ HALF * (RIGHT-LEFT)
ELSE
NEEDBS = .TRUE.
ENDIF
IF(RIGHT-LEFT.LT.RQTOL*ABS(LAMBDA)) THEN
* The eigenvalue is computed to bisection accuracy
* compute eigenvector and stop
USEDBS = .TRUE.
GOTO 120
ELSEIF( ITER.LT.MAXITR ) THEN
GOTO 120
ELSEIF( ITER.EQ.MAXITR ) THEN
NEEDBS = .TRUE.
GOTO 120
ELSE
INFO = 5
RETURN
END IF
ELSE
STP2II = .FALSE.
IF(USEDRQ .AND. USEDBS .AND.
$ BSTRES.LE.RESID) THEN
LAMBDA = BSTW
STP2II = .TRUE.
ENDIF
IF (STP2II) THEN
* improve error angle by second step
CALL DLAR1V( IN, 1, IN, LAMBDA,
$ D( IBEGIN ), L( IBEGIN ),
$ WORK(INDLD+IBEGIN-1),
$ WORK(INDLLD+IBEGIN-1),
$ PIVMIN, GAPTOL, Z( IBEGIN, WINDEX ),
$ .NOT.USEDBS, NEGCNT, ZTZ, MINGMA,
$ IWORK( IINDR+WINDEX ),
$ ISUPPZ( 2*WINDEX-1 ),
$ NRMINV, RESID, RQCORR, WORK( INDWRK ) )
ENDIF
WORK( WINDEX ) = LAMBDA
END IF
*
* Compute FP-vector support w.r.t. whole matrix
*
ISUPPZ( 2*WINDEX-1 ) = ISUPPZ( 2*WINDEX-1 )+OLDIEN
ISUPPZ( 2*WINDEX ) = ISUPPZ( 2*WINDEX )+OLDIEN
ZFROM = ISUPPZ( 2*WINDEX-1 )
ZTO = ISUPPZ( 2*WINDEX )
ISUPMN = ISUPMN + OLDIEN
ISUPMX = ISUPMX + OLDIEN
* Ensure vector is ok if support in the RQI has changed
IF(ISUPMN.LT.ZFROM) THEN
DO 122 II = ISUPMN,ZFROM-1
Z( II, WINDEX ) = ZERO
122 CONTINUE
ENDIF
IF(ISUPMX.GT.ZTO) THEN
DO 123 II = ZTO+1,ISUPMX
Z( II, WINDEX ) = ZERO
123 CONTINUE
ENDIF
CALL DSCAL( ZTO-ZFROM+1, NRMINV,
$ Z( ZFROM, WINDEX ), 1 )
125 CONTINUE
* Update W
W( WINDEX ) = LAMBDA+SIGMA
* Recompute the gaps on the left and right
* But only allow them to become larger and not
* smaller (which can only happen through "bad"
* cancellation and doesn't reflect the theory
* where the initial gaps are underestimated due
* to WERR being too crude.)
IF(.NOT.ESKIP) THEN
IF( K.GT.1) THEN
WGAP( WINDMN ) = MAX( WGAP(WINDMN),
$ W(WINDEX)-WERR(WINDEX)
$ - W(WINDMN)-WERR(WINDMN) )
ENDIF
IF( WINDEX.LT.WEND ) THEN
WGAP( WINDEX ) = MAX( SAVGAP,
$ W( WINDPL )-WERR( WINDPL )
$ - W( WINDEX )-WERR( WINDEX) )
ENDIF
ENDIF
IDONE = IDONE + 1
ENDIF
* here ends the code for the current child
*
139 CONTINUE
* Proceed to any remaining child nodes
NEWFST = J + 1
140 CONTINUE
150 CONTINUE
NDEPTH = NDEPTH + 1
GO TO 40
END IF
IBEGIN = IEND + 1
WBEGIN = WEND + 1
170 CONTINUE
*
RETURN
*
* End of DLARRV
*
END
SUBROUTINE DLARTG( F, G, CS, SN, R )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
DOUBLE PRECISION CS, F, G, R, SN
* ..
*
* Purpose
* =======
*
* DLARTG generate a plane rotation so that
*
* [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1.
* [ -SN CS ] [ G ] [ 0 ]
*
* This is a slower, more accurate version of the BLAS1 routine DROTG,
* with the following other differences:
* F and G are unchanged on return.
* If G=0, then CS=1 and SN=0.
* If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any
* floating point operations (saves work in DBDSQR when
* there are zeros on the diagonal).
*
* If F exceeds G in magnitude, CS will be positive.
*
* Arguments
* =========
*
* F (input) DOUBLE PRECISION
* The first component of vector to be rotated.
*
* G (input) DOUBLE PRECISION
* The second component of vector to be rotated.
*
* CS (output) DOUBLE PRECISION
* The cosine of the rotation.
*
* SN (output) DOUBLE PRECISION
* The sine of the rotation.
*
* R (output) DOUBLE PRECISION
* The nonzero component of the rotated vector.
*
* This version has a few statements commented out for thread safety
* (machine parameters are computed on each entry). 10 feb 03, SJH.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D0 )
* ..
* .. Local Scalars ..
* LOGICAL FIRST
INTEGER COUNT, I
DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX, SQRT
* ..
* .. Save statement ..
* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2
* ..
* .. Data statements ..
* DATA FIRST / .TRUE. /
* ..
* .. Executable Statements ..
*
* IF( FIRST ) THEN
SAFMIN = DLAMCH( 'S' )
EPS = DLAMCH( 'E' )
SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
$ LOG( DLAMCH( 'B' ) ) / TWO )
SAFMX2 = ONE / SAFMN2
* FIRST = .FALSE.
* END IF
IF( G.EQ.ZERO ) THEN
CS = ONE
SN = ZERO
R = F
ELSE IF( F.EQ.ZERO ) THEN
CS = ZERO
SN = ONE
R = G
ELSE
F1 = F
G1 = G
SCALE = MAX( ABS( F1 ), ABS( G1 ) )
IF( SCALE.GE.SAFMX2 ) THEN
COUNT = 0
10 CONTINUE
COUNT = COUNT + 1
F1 = F1*SAFMN2
G1 = G1*SAFMN2
SCALE = MAX( ABS( F1 ), ABS( G1 ) )
IF( SCALE.GE.SAFMX2 )
$ GO TO 10
R = SQRT( F1**2+G1**2 )
CS = F1 / R
SN = G1 / R
DO 20 I = 1, COUNT
R = R*SAFMX2
20 CONTINUE
ELSE IF( SCALE.LE.SAFMN2 ) THEN
COUNT = 0
30 CONTINUE
COUNT = COUNT + 1
F1 = F1*SAFMX2
G1 = G1*SAFMX2
SCALE = MAX( ABS( F1 ), ABS( G1 ) )
IF( SCALE.LE.SAFMN2 )
$ GO TO 30
R = SQRT( F1**2+G1**2 )
CS = F1 / R
SN = G1 / R
DO 40 I = 1, COUNT
R = R*SAFMN2
40 CONTINUE
ELSE
R = SQRT( F1**2+G1**2 )
CS = F1 / R
SN = G1 / R
END IF
IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN
CS = -CS
SN = -SN
R = -R
END IF
END IF
RETURN
*
* End of DLARTG
*
END
SUBROUTINE DLARTV( N, X, INCX, Y, INCY, C, S, INCC )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INCC, INCX, INCY, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION C( * ), S( * ), X( * ), Y( * )
* ..
*
* Purpose
* =======
*
* DLARTV applies a vector of real plane rotations to elements of the
* real vectors x and y. For i = 1,2,...,n
*
* ( x(i) ) := ( c(i) s(i) ) ( x(i) )
* ( y(i) ) ( -s(i) c(i) ) ( y(i) )
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of plane rotations to be applied.
*
* X (input/output) DOUBLE PRECISION array,
* dimension (1+(N-1)*INCX)
* The vector x.
*
* INCX (input) INTEGER
* The increment between elements of X. INCX > 0.
*
* Y (input/output) DOUBLE PRECISION array,
* dimension (1+(N-1)*INCY)
* The vector y.
*
* INCY (input) INTEGER
* The increment between elements of Y. INCY > 0.
*
* C (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
* The cosines of the plane rotations.
*
* S (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
* The sines of the plane rotations.
*
* INCC (input) INTEGER
* The increment between elements of C and S. INCC > 0.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, IC, IX, IY
DOUBLE PRECISION XI, YI
* ..
* .. Executable Statements ..
*
IX = 1
IY = 1
IC = 1
DO 10 I = 1, N
XI = X( IX )
YI = Y( IY )
X( IX ) = C( IC )*XI + S( IC )*YI
Y( IY ) = C( IC )*YI - S( IC )*XI
IX = IX + INCX
IY = IY + INCY
IC = IC + INCC
10 CONTINUE
RETURN
*
* End of DLARTV
*
END
SUBROUTINE DLARUV( ISEED, N, X )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER N
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
DOUBLE PRECISION X( N )
* ..
*
* Purpose
* =======
*
* DLARUV returns a vector of n random real numbers from a uniform (0,1)
* distribution (n <= 128).
*
* This is an auxiliary routine called by DLARNV and ZLARNV.
*
* Arguments
* =========
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry, the seed of the random number generator; the array
* elements must be between 0 and 4095, and ISEED(4) must be
* odd.
* On exit, the seed is updated.
*
* N (input) INTEGER
* The number of random numbers to be generated. N <= 128.
*
* X (output) DOUBLE PRECISION array, dimension (N)
* The generated random numbers.
*
* Further Details
* ===============
*
* This routine uses a multiplicative congruential method with modulus
* 2**48 and multiplier 33952834046453 (see G.S.Fishman,
* 'Multiplicative congruential random number generators with modulus
* 2**b: an exhaustive analysis for b = 32 and a partial analysis for
* b = 48', Math. Comp. 189, pp 331-344, 1990).
*
* 48-bit integers are stored in 4 integer array elements with 12 bits
* per element. Hence the routine is portable across machines with
* integers of 32 bits or more.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
INTEGER LV, IPW2
DOUBLE PRECISION R
PARAMETER ( LV = 128, IPW2 = 4096, R = ONE / IPW2 )
* ..
* .. Local Scalars ..
INTEGER I, I1, I2, I3, I4, IT1, IT2, IT3, IT4, J
* ..
* .. Local Arrays ..
INTEGER MM( LV, 4 )
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MIN, MOD
* ..
* .. Data statements ..
DATA ( MM( 1, J ), J = 1, 4 ) / 494, 322, 2508,
$ 2549 /
DATA ( MM( 2, J ), J = 1, 4 ) / 2637, 789, 3754,
$ 1145 /
DATA ( MM( 3, J ), J = 1, 4 ) / 255, 1440, 1766,
$ 2253 /
DATA ( MM( 4, J ), J = 1, 4 ) / 2008, 752, 3572,
$ 305 /
DATA ( MM( 5, J ), J = 1, 4 ) / 1253, 2859, 2893,
$ 3301 /
DATA ( MM( 6, J ), J = 1, 4 ) / 3344, 123, 307,
$ 1065 /
DATA ( MM( 7, J ), J = 1, 4 ) / 4084, 1848, 1297,
$ 3133 /
DATA ( MM( 8, J ), J = 1, 4 ) / 1739, 643, 3966,
$ 2913 /
DATA ( MM( 9, J ), J = 1, 4 ) / 3143, 2405, 758,
$ 3285 /
DATA ( MM( 10, J ), J = 1, 4 ) / 3468, 2638, 2598,
$ 1241 /
DATA ( MM( 11, J ), J = 1, 4 ) / 688, 2344, 3406,
$ 1197 /
DATA ( MM( 12, J ), J = 1, 4 ) / 1657, 46, 2922,
$ 3729 /
DATA ( MM( 13, J ), J = 1, 4 ) / 1238, 3814, 1038,
$ 2501 /
DATA ( MM( 14, J ), J = 1, 4 ) / 3166, 913, 2934,
$ 1673 /
DATA ( MM( 15, J ), J = 1, 4 ) / 1292, 3649, 2091,
$ 541 /
DATA ( MM( 16, J ), J = 1, 4 ) / 3422, 339, 2451,
$ 2753 /
DATA ( MM( 17, J ), J = 1, 4 ) / 1270, 3808, 1580,
$ 949 /
DATA ( MM( 18, J ), J = 1, 4 ) / 2016, 822, 1958,
$ 2361 /
DATA ( MM( 19, J ), J = 1, 4 ) / 154, 2832, 2055,
$ 1165 /
DATA ( MM( 20, J ), J = 1, 4 ) / 2862, 3078, 1507,
$ 4081 /
DATA ( MM( 21, J ), J = 1, 4 ) / 697, 3633, 1078,
$ 2725 /
DATA ( MM( 22, J ), J = 1, 4 ) / 1706, 2970, 3273,
$ 3305 /
DATA ( MM( 23, J ), J = 1, 4 ) / 491, 637, 17,
$ 3069 /
DATA ( MM( 24, J ), J = 1, 4 ) / 931, 2249, 854,
$ 3617 /
DATA ( MM( 25, J ), J = 1, 4 ) / 1444, 2081, 2916,
$ 3733 /
DATA ( MM( 26, J ), J = 1, 4 ) / 444, 4019, 3971,
$ 409 /
DATA ( MM( 27, J ), J = 1, 4 ) / 3577, 1478, 2889,
$ 2157 /
DATA ( MM( 28, J ), J = 1, 4 ) / 3944, 242, 3831,
$ 1361 /
DATA ( MM( 29, J ), J = 1, 4 ) / 2184, 481, 2621,
$ 3973 /
DATA ( MM( 30, J ), J = 1, 4 ) / 1661, 2075, 1541,
$ 1865 /
DATA ( MM( 31, J ), J = 1, 4 ) / 3482, 4058, 893,
$ 2525 /
DATA ( MM( 32, J ), J = 1, 4 ) / 657, 622, 736,
$ 1409 /
DATA ( MM( 33, J ), J = 1, 4 ) / 3023, 3376, 3992,
$ 3445 /
DATA ( MM( 34, J ), J = 1, 4 ) / 3618, 812, 787,
$ 3577 /
DATA ( MM( 35, J ), J = 1, 4 ) / 1267, 234, 2125,
$ 77 /
DATA ( MM( 36, J ), J = 1, 4 ) / 1828, 641, 2364,
$ 3761 /
DATA ( MM( 37, J ), J = 1, 4 ) / 164, 4005, 2460,
$ 2149 /
DATA ( MM( 38, J ), J = 1, 4 ) / 3798, 1122, 257,
$ 1449 /
DATA ( MM( 39, J ), J = 1, 4 ) / 3087, 3135, 1574,
$ 3005 /
DATA ( MM( 40, J ), J = 1, 4 ) / 2400, 2640, 3912,
$ 225 /
DATA ( MM( 41, J ), J = 1, 4 ) / 2870, 2302, 1216,
$ 85 /
DATA ( MM( 42, J ), J = 1, 4 ) / 3876, 40, 3248,
$ 3673 /
DATA ( MM( 43, J ), J = 1, 4 ) / 1905, 1832, 3401,
$ 3117 /
DATA ( MM( 44, J ), J = 1, 4 ) / 1593, 2247, 2124,
$ 3089 /
DATA ( MM( 45, J ), J = 1, 4 ) / 1797, 2034, 2762,
$ 1349 /
DATA ( MM( 46, J ), J = 1, 4 ) / 1234, 2637, 149,
$ 2057 /
DATA ( MM( 47, J ), J = 1, 4 ) / 3460, 1287, 2245,
$ 413 /
DATA ( MM( 48, J ), J = 1, 4 ) / 328, 1691, 166,
$ 65 /
DATA ( MM( 49, J ), J = 1, 4 ) / 2861, 496, 466,
$ 1845 /
DATA ( MM( 50, J ), J = 1, 4 ) / 1950, 1597, 4018,
$ 697 /
DATA ( MM( 51, J ), J = 1, 4 ) / 617, 2394, 1399,
$ 3085 /
DATA ( MM( 52, J ), J = 1, 4 ) / 2070, 2584, 190,
$ 3441 /
DATA ( MM( 53, J ), J = 1, 4 ) / 3331, 1843, 2879,
$ 1573 /
DATA ( MM( 54, J ), J = 1, 4 ) / 769, 336, 153,
$ 3689 /
DATA ( MM( 55, J ), J = 1, 4 ) / 1558, 1472, 2320,
$ 2941 /
DATA ( MM( 56, J ), J = 1, 4 ) / 2412, 2407, 18,
$ 929 /
DATA ( MM( 57, J ), J = 1, 4 ) / 2800, 433, 712,
$ 533 /
DATA ( MM( 58, J ), J = 1, 4 ) / 189, 2096, 2159,
$ 2841 /
DATA ( MM( 59, J ), J = 1, 4 ) / 287, 1761, 2318,
$ 4077 /
DATA ( MM( 60, J ), J = 1, 4 ) / 2045, 2810, 2091,
$ 721 /
DATA ( MM( 61, J ), J = 1, 4 ) / 1227, 566, 3443,
$ 2821 /
DATA ( MM( 62, J ), J = 1, 4 ) / 2838, 442, 1510,
$ 2249 /
DATA ( MM( 63, J ), J = 1, 4 ) / 209, 41, 449,
$ 2397 /
DATA ( MM( 64, J ), J = 1, 4 ) / 2770, 1238, 1956,
$ 2817 /
DATA ( MM( 65, J ), J = 1, 4 ) / 3654, 1086, 2201,
$ 245 /
DATA ( MM( 66, J ), J = 1, 4 ) / 3993, 603, 3137,
$ 1913 /
DATA ( MM( 67, J ), J = 1, 4 ) / 192, 840, 3399,
$ 1997 /
DATA ( MM( 68, J ), J = 1, 4 ) / 2253, 3168, 1321,
$ 3121 /
DATA ( MM( 69, J ), J = 1, 4 ) / 3491, 1499, 2271,
$ 997 /
DATA ( MM( 70, J ), J = 1, 4 ) / 2889, 1084, 3667,
$ 1833 /
DATA ( MM( 71, J ), J = 1, 4 ) / 2857, 3438, 2703,
$ 2877 /
DATA ( MM( 72, J ), J = 1, 4 ) / 2094, 2408, 629,
$ 1633 /
DATA ( MM( 73, J ), J = 1, 4 ) / 1818, 1589, 2365,
$ 981 /
DATA ( MM( 74, J ), J = 1, 4 ) / 688, 2391, 2431,
$ 2009 /
DATA ( MM( 75, J ), J = 1, 4 ) / 1407, 288, 1113,
$ 941 /
DATA ( MM( 76, J ), J = 1, 4 ) / 634, 26, 3922,
$ 2449 /
DATA ( MM( 77, J ), J = 1, 4 ) / 3231, 512, 2554,
$ 197 /
DATA ( MM( 78, J ), J = 1, 4 ) / 815, 1456, 184,
$ 2441 /
DATA ( MM( 79, J ), J = 1, 4 ) / 3524, 171, 2099,
$ 285 /
DATA ( MM( 80, J ), J = 1, 4 ) / 1914, 1677, 3228,
$ 1473 /
DATA ( MM( 81, J ), J = 1, 4 ) / 516, 2657, 4012,
$ 2741 /
DATA ( MM( 82, J ), J = 1, 4 ) / 164, 2270, 1921,
$ 3129 /
DATA ( MM( 83, J ), J = 1, 4 ) / 303, 2587, 3452,
$ 909 /
DATA ( MM( 84, J ), J = 1, 4 ) / 2144, 2961, 3901,
$ 2801 /
DATA ( MM( 85, J ), J = 1, 4 ) / 3480, 1970, 572,
$ 421 /
DATA ( MM( 86, J ), J = 1, 4 ) / 119, 1817, 3309,
$ 4073 /
DATA ( MM( 87, J ), J = 1, 4 ) / 3357, 676, 3171,
$ 2813 /
DATA ( MM( 88, J ), J = 1, 4 ) / 837, 1410, 817,
$ 2337 /
DATA ( MM( 89, J ), J = 1, 4 ) / 2826, 3723, 3039,
$ 1429 /
DATA ( MM( 90, J ), J = 1, 4 ) / 2332, 2803, 1696,
$ 1177 /
DATA ( MM( 91, J ), J = 1, 4 ) / 2089, 3185, 1256,
$ 1901 /
DATA ( MM( 92, J ), J = 1, 4 ) / 3780, 184, 3715,
$ 81 /
DATA ( MM( 93, J ), J = 1, 4 ) / 1700, 663, 2077,
$ 1669 /
DATA ( MM( 94, J ), J = 1, 4 ) / 3712, 499, 3019,
$ 2633 /
DATA ( MM( 95, J ), J = 1, 4 ) / 150, 3784, 1497,
$ 2269 /
DATA ( MM( 96, J ), J = 1, 4 ) / 2000, 1631, 1101,
$ 129 /
DATA ( MM( 97, J ), J = 1, 4 ) / 3375, 1925, 717,
$ 1141 /
DATA ( MM( 98, J ), J = 1, 4 ) / 1621, 3912, 51,
$ 249 /
DATA ( MM( 99, J ), J = 1, 4 ) / 3090, 1398, 981,
$ 3917 /
DATA ( MM( 100, J ), J = 1, 4 ) / 3765, 1349, 1978,
$ 2481 /
DATA ( MM( 101, J ), J = 1, 4 ) / 1149, 1441, 1813,
$ 3941 /
DATA ( MM( 102, J ), J = 1, 4 ) / 3146, 2224, 3881,
$ 2217 /
DATA ( MM( 103, J ), J = 1, 4 ) / 33, 2411, 76,
$ 2749 /
DATA ( MM( 104, J ), J = 1, 4 ) / 3082, 1907, 3846,
$ 3041 /
DATA ( MM( 105, J ), J = 1, 4 ) / 2741, 3192, 3694,
$ 1877 /
DATA ( MM( 106, J ), J = 1, 4 ) / 359, 2786, 1682,
$ 345 /
DATA ( MM( 107, J ), J = 1, 4 ) / 3316, 382, 124,
$ 2861 /
DATA ( MM( 108, J ), J = 1, 4 ) / 1749, 37, 1660,
$ 1809 /
DATA ( MM( 109, J ), J = 1, 4 ) / 185, 759, 3997,
$ 3141 /
DATA ( MM( 110, J ), J = 1, 4 ) / 2784, 2948, 479,
$ 2825 /
DATA ( MM( 111, J ), J = 1, 4 ) / 2202, 1862, 1141,
$ 157 /
DATA ( MM( 112, J ), J = 1, 4 ) / 2199, 3802, 886,
$ 2881 /
DATA ( MM( 113, J ), J = 1, 4 ) / 1364, 2423, 3514,
$ 3637 /
DATA ( MM( 114, J ), J = 1, 4 ) / 1244, 2051, 1301,
$ 1465 /
DATA ( MM( 115, J ), J = 1, 4 ) / 2020, 2295, 3604,
$ 2829 /
DATA ( MM( 116, J ), J = 1, 4 ) / 3160, 1332, 1888,
$ 2161 /
DATA ( MM( 117, J ), J = 1, 4 ) / 2785, 1832, 1836,
$ 3365 /
DATA ( MM( 118, J ), J = 1, 4 ) / 2772, 2405, 1990,
$ 361 /
DATA ( MM( 119, J ), J = 1, 4 ) / 1217, 3638, 2058,
$ 2685 /
DATA ( MM( 120, J ), J = 1, 4 ) / 1822, 3661, 692,
$ 3745 /
DATA ( MM( 121, J ), J = 1, 4 ) / 1245, 327, 1194,
$ 2325 /
DATA ( MM( 122, J ), J = 1, 4 ) / 2252, 3660, 20,
$ 3609 /
DATA ( MM( 123, J ), J = 1, 4 ) / 3904, 716, 3285,
$ 3821 /
DATA ( MM( 124, J ), J = 1, 4 ) / 2774, 1842, 2046,
$ 3537 /
DATA ( MM( 125, J ), J = 1, 4 ) / 997, 3987, 2107,
$ 517 /
DATA ( MM( 126, J ), J = 1, 4 ) / 2573, 1368, 3508,
$ 3017 /
DATA ( MM( 127, J ), J = 1, 4 ) / 1148, 1848, 3525,
$ 2141 /
DATA ( MM( 128, J ), J = 1, 4 ) / 545, 2366, 3801,
$ 1537 /
* ..
* .. Executable Statements ..
*
I1 = ISEED( 1 )
I2 = ISEED( 2 )
I3 = ISEED( 3 )
I4 = ISEED( 4 )
*
DO 10 I = 1, MIN( N, LV )
*
20 CONTINUE
*
* Multiply the seed by i-th power of the multiplier modulo 2**48
*
IT4 = I4*MM( I, 4 )
IT3 = IT4 / IPW2
IT4 = IT4 - IPW2*IT3
IT3 = IT3 + I3*MM( I, 4 ) + I4*MM( I, 3 )
IT2 = IT3 / IPW2
IT3 = IT3 - IPW2*IT2
IT2 = IT2 + I2*MM( I, 4 ) + I3*MM( I, 3 ) + I4*MM( I, 2 )
IT1 = IT2 / IPW2
IT2 = IT2 - IPW2*IT1
IT1 = IT1 + I1*MM( I, 4 ) + I2*MM( I, 3 ) + I3*MM( I, 2 ) +
$ I4*MM( I, 1 )
IT1 = MOD( IT1, IPW2 )
*
* Convert 48-bit integer to a real number in the interval (0,1)
*
X( I ) = R*( DBLE( IT1 )+R*( DBLE( IT2 )+R*( DBLE( IT3 )+R*
$ DBLE( IT4 ) ) ) )
*
IF (X( I ).EQ.1.0D0) THEN
* If a real number has n bits of precision, and the first
* n bits of the 48-bit integer above happen to be all 1 (which
* will occur about once every 2**n calls), then X( I ) will
* be rounded to exactly 1.0.
* Since X( I ) is not supposed to return exactly 0.0 or 1.0,
* the statistically correct thing to do in this situation is
* simply to iterate again.
* N.B. the case X( I ) = 0.0 should not be possible.
I1 = I1 + 2
I2 = I2 + 2
I3 = I3 + 2
I4 = I4 + 2
GOTO 20
END IF
*
10 CONTINUE
*
* Return final value of seed
*
ISEED( 1 ) = IT1
ISEED( 2 ) = IT2
ISEED( 3 ) = IT3
ISEED( 4 ) = IT4
RETURN
*
* End of DLARUV
*
END
SUBROUTINE DLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE
INTEGER INCV, L, LDC, M, N
DOUBLE PRECISION TAU
* ..
* .. Array Arguments ..
DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLARZ 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'
*
* where tau is a real scalar and v is a real vector.
*
* If tau = 0, then H is taken to be the unit matrix.
*
*
* H is a product of k elementary reflectors as returned by DTZRZF.
*
* 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.
*
* L (input) INTEGER
* The number of entries of the vector V containing
* the meaningful part of the Householder vectors.
* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
*
* V (input) DOUBLE PRECISION array, dimension (1+(L-1)*abs(INCV))
* The vector v in the representation of H as returned by
* DTZRZF. 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'
*
* Further Details
* ===============
*
* Based on contributions by
* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DGEMV, DGER
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Executable Statements ..
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form H * C
*
IF( TAU.NE.ZERO ) THEN
*
* w( 1:n ) = C( 1, 1:n )
*
CALL DCOPY( N, C, LDC, WORK, 1 )
*
* w( 1:n ) = w( 1:n ) + C( m-l+1:m, 1:n )' * v( 1:l )
*
CALL DGEMV( 'Transpose', L, N, ONE, C( M-L+1, 1 ), LDC, V,
$ INCV, ONE, WORK, 1 )
*
* C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n )
*
CALL DAXPY( N, -TAU, WORK, 1, C, LDC )
*
* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ...
* tau * v( 1:l ) * w( 1:n )'
*
CALL DGER( L, N, -TAU, V, INCV, WORK, 1, C( M-L+1, 1 ),
$ LDC )
END IF
*
ELSE
*
* Form C * H
*
IF( TAU.NE.ZERO ) THEN
*
* w( 1:m ) = C( 1:m, 1 )
*
CALL DCOPY( M, C, 1, WORK, 1 )
*
* w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l )
*
CALL DGEMV( 'No transpose', M, L, ONE, C( 1, N-L+1 ), LDC,
$ V, INCV, ONE, WORK, 1 )
*
* C( 1:m, 1 ) = C( 1:m, 1 ) - tau * w( 1:m )
*
CALL DAXPY( M, -TAU, WORK, 1, C, 1 )
*
* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ...
* tau * w( 1:m ) * v( 1:l )'
*
CALL DGER( M, L, -TAU, WORK, 1, V, INCV, C( 1, N-L+1 ),
$ LDC )
*
END IF
*
END IF
*
RETURN
*
* End of DLARZ
*
END
SUBROUTINE DLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V,
$ LDV, T, LDT, C, LDC, WORK, LDWORK )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIRECT, SIDE, STOREV, TRANS
INTEGER K, L, LDC, LDT, LDV, LDWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ),
$ WORK( LDWORK, * )
* ..
*
* Purpose
* =======
*
* DLARZB applies a real block reflector H or its transpose H**T to
* a real distributed M-by-N C from the left or the right.
*
* Currently, only STOREV = 'R' and DIRECT = 'B' are supported.
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* = 'L': apply H or H' from the Left
* = 'R': apply H or H' from the Right
*
* TRANS (input) CHARACTER*1
* = 'N': apply H (No transpose)
* = 'C': apply H' (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, not supported yet)
* = '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 (not supported yet)
* = '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).
*
* L (input) INTEGER
* The number of columns of the matrix V containing the
* meaningful part of the Householder reflectors.
* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
*
* V (input) DOUBLE PRECISION array, dimension (LDV,NV).
* If STOREV = 'C', NV = K; if STOREV = 'R', NV = L.
*
* LDV (input) INTEGER
* The leading dimension of the array V.
* If STOREV = 'C', LDV >= L; 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'*C or C*H or C*H'.
*
* 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
* ===============
*
* Based on contributions by
* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
CHARACTER TRANST
INTEGER I, INFO, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMM, DTRMM, XERBLA
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
* Check for currently supported options
*
INFO = 0
IF( .NOT.LSAME( DIRECT, 'B' ) ) THEN
INFO = -3
ELSE IF( .NOT.LSAME( STOREV, 'R' ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLARZB', -INFO )
RETURN
END IF
*
IF( LSAME( TRANS, 'N' ) ) THEN
TRANST = 'T'
ELSE
TRANST = 'N'
END IF
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form H * C or H' * C
*
* W( 1:n, 1:k ) = C( 1:k, 1:n )'
*
DO 10 J = 1, K
CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
10 CONTINUE
*
* W( 1:n, 1:k ) = W( 1:n, 1:k ) + ...
* C( m-l+1:m, 1:n )' * V( 1:k, 1:l )'
*
IF( L.GT.0 )
$ CALL DGEMM( 'Transpose', 'Transpose', N, K, L, ONE,
$ C( M-L+1, 1 ), LDC, V, LDV, ONE, WORK, LDWORK )
*
* W( 1:n, 1:k ) = W( 1:n, 1:k ) * T' or W( 1:m, 1:k ) * T
*
CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, ONE, T,
$ LDT, WORK, LDWORK )
*
* C( 1:k, 1:n ) = C( 1:k, 1:n ) - W( 1:n, 1:k )'
*
DO 30 J = 1, N
DO 20 I = 1, K
C( I, J ) = C( I, J ) - WORK( J, I )
20 CONTINUE
30 CONTINUE
*
* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ...
* V( 1:k, 1:l )' * W( 1:n, 1:k )'
*
IF( L.GT.0 )
$ CALL DGEMM( 'Transpose', 'Transpose', L, N, K, -ONE, V, LDV,
$ WORK, LDWORK, ONE, C( M-L+1, 1 ), LDC )
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H'
*
* W( 1:m, 1:k ) = C( 1:m, 1:k )
*
DO 40 J = 1, K
CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
40 CONTINUE
*
* W( 1:m, 1:k ) = W( 1:m, 1:k ) + ...
* C( 1:m, n-l+1:n ) * V( 1:k, 1:l )'
*
IF( L.GT.0 )
$ CALL DGEMM( 'No transpose', 'Transpose', M, K, L, ONE,
$ C( 1, N-L+1 ), LDC, V, LDV, ONE, WORK, LDWORK )
*
* W( 1:m, 1:k ) = W( 1:m, 1:k ) * T or W( 1:m, 1:k ) * T'
*
CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, ONE, T,
$ LDT, WORK, LDWORK )
*
* C( 1:m, 1:k ) = C( 1:m, 1:k ) - W( 1:m, 1:k )
*
DO 60 J = 1, K
DO 50 I = 1, M
C( I, J ) = C( I, J ) - WORK( I, J )
50 CONTINUE
60 CONTINUE
*
* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ...
* W( 1:m, 1:k ) * V( 1:k, 1:l )
*
IF( L.GT.0 )
$ CALL DGEMM( 'No transpose', 'No transpose', M, L, K, -ONE,
$ WORK, LDWORK, V, LDV, ONE, C( 1, N-L+1 ), LDC )
*
END IF
*
RETURN
*
* End of DLARZB
*
END
SUBROUTINE DLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIRECT, STOREV
INTEGER K, LDT, LDV, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * )
* ..
*
* Purpose
* =======
*
* DLARZT 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'
*
* 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 * V
*
* Currently, only STOREV = 'R' and DIRECT = 'B' are supported.
*
* 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, not supported yet)
* = '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 (not supported yet)
* = '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
* ===============
*
* Based on contributions by
* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*
* 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_____
* ( v1 v2 v3 ) / \
* ( v1 v2 v3 ) ( v1 v1 v1 v1 v1 . . . . 1 )
* V = ( v1 v2 v3 ) ( v2 v2 v2 v2 v2 . . . 1 )
* ( v1 v2 v3 ) ( v3 v3 v3 v3 v3 . . 1 )
* ( v1 v2 v3 )
* . . .
* . . .
* 1 . .
* 1 .
* 1
*
* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
*
* ______V_____
* 1 / \
* . 1 ( 1 . . . . v1 v1 v1 v1 v1 )
* . . 1 ( . 1 . . . v2 v2 v2 v2 v2 )
* . . . ( . . 1 . . v3 v3 v3 v3 v3 )
* . . .
* ( v1 v2 v3 )
* ( v1 v2 v3 )
* V = ( v1 v2 v3 )
* ( v1 v2 v3 )
* ( v1 v2 v3 )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
* ..
* .. External Subroutines ..
EXTERNAL DGEMV, DTRMV, XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Executable Statements ..
*
* Check for currently supported options
*
INFO = 0
IF( .NOT.LSAME( DIRECT, 'B' ) ) THEN
INFO = -1
ELSE IF( .NOT.LSAME( STOREV, 'R' ) ) THEN
INFO = -2
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLARZT', -INFO )
RETURN
END IF
*
DO 20 I = K, 1, -1
IF( TAU( I ).EQ.ZERO ) THEN
*
* H(i) = I
*
DO 10 J = I, K
T( J, I ) = ZERO
10 CONTINUE
ELSE
*
* general case
*
IF( I.LT.K ) THEN
*
* T(i+1:k,i) = - tau(i) * V(i+1:k,1:n) * V(i,1:n)'
*
CALL DGEMV( 'No transpose', K-I, N, -TAU( I ),
$ V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO,
$ T( I+1, I ), 1 )
*
* 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 )
END IF
T( I, I ) = TAU( I )
END IF
20 CONTINUE
RETURN
*
* End of DLARZT
*
END
SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
DOUBLE PRECISION F, G, H, SSMAX, SSMIN
* ..
*
* Purpose
* =======
*
* DLAS2 computes the singular values of the 2-by-2 matrix
* [ F G ]
* [ 0 H ].
* On return, SSMIN is the smaller singular value and SSMAX is the
* larger singular value.
*
* Arguments
* =========
*
* F (input) DOUBLE PRECISION
* The (1,1) element of the 2-by-2 matrix.
*
* G (input) DOUBLE PRECISION
* The (1,2) element of the 2-by-2 matrix.
*
* H (input) DOUBLE PRECISION
* The (2,2) element of the 2-by-2 matrix.
*
* SSMIN (output) DOUBLE PRECISION
* The smaller singular value.
*
* SSMAX (output) DOUBLE PRECISION
* The larger singular value.
*
* Further Details
* ===============
*
* Barring over/underflow, all output quantities are correct to within
* a few units in the last place (ulps), even in the absence of a guard
* digit in addition/subtraction.
*
* In IEEE arithmetic, the code works correctly if one matrix element is
* infinite.
*
* Overflow will not occur unless the largest singular value itself
* overflows, or is within a few ulps of overflow. (On machines with
* partial overflow, like the Cray, overflow may occur if the largest
* singular value is within a factor of 2 of overflow.)
*
* Underflow is harmless if underflow is gradual. Otherwise, results
* may correspond to a matrix modified by perturbations of size near
* the underflow threshold.
*
* ====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION AS, AT, AU, C, FA, FHMN, FHMX, GA, HA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
FA = ABS( F )
GA = ABS( G )
HA = ABS( H )
FHMN = MIN( FA, HA )
FHMX = MAX( FA, HA )
IF( FHMN.EQ.ZERO ) THEN
SSMIN = ZERO
IF( FHMX.EQ.ZERO ) THEN
SSMAX = GA
ELSE
SSMAX = MAX( FHMX, GA )*SQRT( ONE+
$ ( MIN( FHMX, GA ) / MAX( FHMX, GA ) )**2 )
END IF
ELSE
IF( GA.LT.FHMX ) THEN
AS = ONE + FHMN / FHMX
AT = ( FHMX-FHMN ) / FHMX
AU = ( GA / FHMX )**2
C = TWO / ( SQRT( AS*AS+AU )+SQRT( AT*AT+AU ) )
SSMIN = FHMN*C
SSMAX = FHMX / C
ELSE
AU = FHMX / GA
IF( AU.EQ.ZERO ) THEN
*
* Avoid possible harmful underflow if exponent range
* asymmetric (true SSMIN may not underflow even if
* AU underflows)
*
SSMIN = ( FHMN*FHMX ) / GA
SSMAX = GA
ELSE
AS = ONE + FHMN / FHMX
AT = ( FHMX-FHMN ) / FHMX
C = ONE / ( SQRT( ONE+( AS*AU )**2 )+
$ SQRT( ONE+( AT*AU )**2 ) )
SSMIN = ( FHMN*C )*AU
SSMIN = SSMIN + SSMIN
SSMAX = GA / ( C+C )
END IF
END IF
END IF
RETURN
*
* End of DLAS2
*
END
SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TYPE
INTEGER INFO, KL, KU, LDA, M, N
DOUBLE PRECISION CFROM, CTO
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
* ..
*
* Purpose
* =======
*
* DLASCL multiplies the M by N real matrix A by the real scalar
* CTO/CFROM. This is done without over/underflow as long as the final
* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
* A may be full, upper triangular, lower triangular, upper Hessenberg,
* or banded.
*
* Arguments
* =========
*
* TYPE (input) CHARACTER*1
* TYPE indices the storage type of the input matrix.
* = 'G': A is a full matrix.
* = 'L': A is a lower triangular matrix.
* = 'U': A is an upper triangular matrix.
* = 'H': A is an upper Hessenberg matrix.
* = 'B': A is a symmetric band matrix with lower bandwidth KL
* and upper bandwidth KU and with the only the lower
* half stored.
* = 'Q': A is a symmetric band matrix with lower bandwidth KL
* and upper bandwidth KU and with the only the upper
* half stored.
* = 'Z': A is a band matrix with lower bandwidth KL and upper
* bandwidth KU.
*
* KL (input) INTEGER
* The lower bandwidth of A. Referenced only if TYPE = 'B',
* 'Q' or 'Z'.
*
* KU (input) INTEGER
* The upper bandwidth of A. Referenced only if TYPE = 'B',
* 'Q' or 'Z'.
*
* CFROM (input) DOUBLE PRECISION
* CTO (input) DOUBLE PRECISION
* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
* without over/underflow if the final result CTO*A(I,J)/CFROM
* can be represented without over/underflow. CFROM must be
* nonzero.
*
* 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)
* The matrix to be multiplied by CTO/CFROM. See TYPE for the
* storage type.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* INFO (output) INTEGER
* 0 - successful exit
* <0 - if INFO = -i, the i-th argument had an illegal value.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL DONE
INTEGER I, ITYPE, J, K1, K2, K3, K4
DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
*
IF( LSAME( TYPE, 'G' ) ) THEN
ITYPE = 0
ELSE IF( LSAME( TYPE, 'L' ) ) THEN
ITYPE = 1
ELSE IF( LSAME( TYPE, 'U' ) ) THEN
ITYPE = 2
ELSE IF( LSAME( TYPE, 'H' ) ) THEN
ITYPE = 3
ELSE IF( LSAME( TYPE, 'B' ) ) THEN
ITYPE = 4
ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
ITYPE = 5
ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
ITYPE = 6
ELSE
ITYPE = -1
END IF
*
IF( ITYPE.EQ.-1 ) THEN
INFO = -1
ELSE IF( CFROM.EQ.ZERO ) THEN
INFO = -4
ELSE IF( M.LT.0 ) THEN
INFO = -6
ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
$ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
INFO = -7
ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
INFO = -9
ELSE IF( ITYPE.GE.4 ) THEN
IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
INFO = -2
ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
$ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
$ THEN
INFO = -3
ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
$ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
$ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
INFO = -9
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLASCL', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. M.EQ.0 )
$ RETURN
*
* Get machine parameters
*
SMLNUM = DLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
*
CFROMC = CFROM
CTOC = CTO
*
10 CONTINUE
CFROM1 = CFROMC*SMLNUM
CTO1 = CTOC / BIGNUM
IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
MUL = SMLNUM
DONE = .FALSE.
CFROMC = CFROM1
ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
MUL = BIGNUM
DONE = .FALSE.
CTOC = CTO1
ELSE
MUL = CTOC / CFROMC
DONE = .TRUE.
END IF
*
IF( ITYPE.EQ.0 ) THEN
*
* Full matrix
*
DO 30 J = 1, N
DO 20 I = 1, M
A( I, J ) = A( I, J )*MUL
20 CONTINUE
30 CONTINUE
*
ELSE IF( ITYPE.EQ.1 ) THEN
*
* Lower triangular matrix
*
DO 50 J = 1, N
DO 40 I = J, M
A( I, J ) = A( I, J )*MUL
40 CONTINUE
50 CONTINUE
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Upper triangular matrix
*
DO 70 J = 1, N
DO 60 I = 1, MIN( J, M )
A( I, J ) = A( I, J )*MUL
60 CONTINUE
70 CONTINUE
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* Upper Hessenberg matrix
*
DO 90 J = 1, N
DO 80 I = 1, MIN( J+1, M )
A( I, J ) = A( I, J )*MUL
80 CONTINUE
90 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Lower half of a symmetric band matrix
*
K3 = KL + 1
K4 = N + 1
DO 110 J = 1, N
DO 100 I = 1, MIN( K3, K4-J )
A( I, J ) = A( I, J )*MUL
100 CONTINUE
110 CONTINUE
*
ELSE IF( ITYPE.EQ.5 ) THEN
*
* Upper half of a symmetric band matrix
*
K1 = KU + 2
K3 = KU + 1
DO 130 J = 1, N
DO 120 I = MAX( K1-J, 1 ), K3
A( I, J ) = A( I, J )*MUL
120 CONTINUE
130 CONTINUE
*
ELSE IF( ITYPE.EQ.6 ) THEN
*
* Band matrix
*
K1 = KL + KU + 2
K2 = KL + 1
K3 = 2*KL + KU + 1
K4 = KL + KU + 1 + M
DO 150 J = 1, N
DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
A( I, J ) = A( I, J )*MUL
140 CONTINUE
150 CONTINUE
*
END IF
*
IF( .NOT.DONE )
$ GO TO 10
*
RETURN
*
* End of DLASCL
*
END
SUBROUTINE DLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK,
$ WORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDU, LDVT, N, SMLSIZ, SQRE
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION D( * ), E( * ), U( LDU, * ), VT( LDVT, * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* Using a divide and conquer approach, DLASD0 computes the singular
* value decomposition (SVD) of a real upper bidiagonal N-by-M
* matrix B with diagonal D and offdiagonal E, where M = N + SQRE.
* The algorithm computes orthogonal matrices U and VT such that
* B = U * S * VT. The singular values S are overwritten on D.
*
* A related subroutine, DLASDA, computes only the singular values,
* and optionally, the singular vectors in compact form.
*
* Arguments
* =========
*
* N (input) INTEGER
* On entry, the row dimension of the upper bidiagonal matrix.
* This is also the dimension of the main diagonal array D.
*
* SQRE (input) INTEGER
* Specifies the column dimension of the bidiagonal matrix.
* = 0: The bidiagonal matrix has column dimension M = N;
* = 1: The bidiagonal matrix has column dimension M = N+1;
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry D contains the main diagonal of the bidiagonal
* matrix.
* On exit D, if INFO = 0, contains its singular values.
*
* E (input) DOUBLE PRECISION array, dimension (M-1)
* Contains the subdiagonal entries of the bidiagonal matrix.
* On exit, E has been destroyed.
*
* U (output) DOUBLE PRECISION array, dimension at least (LDQ, N)
* On exit, U contains the left singular vectors.
*
* LDU (input) INTEGER
* On entry, leading dimension of U.
*
* VT (output) DOUBLE PRECISION array, dimension at least (LDVT, M)
* On exit, VT' contains the right singular vectors.
*
* LDVT (input) INTEGER
* On entry, leading dimension of VT.
*
* SMLSIZ (input) INTEGER
* On entry, maximum size of the subproblems at the
* bottom of the computation tree.
*
* IWORK (workspace) INTEGER work array.
* Dimension must be at least (8 * N)
*
* WORK (workspace) DOUBLE PRECISION work array.
* Dimension must be at least (3 * M**2 + 2 * M)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an singular value did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, I1, IC, IDXQ, IDXQC, IM1, INODE, ITEMP, IWK,
$ J, LF, LL, LVL, M, NCC, ND, NDB1, NDIML, NDIMR,
$ NL, NLF, NLP1, NLVL, NR, NRF, NRP1, SQREI
DOUBLE PRECISION ALPHA, BETA
* ..
* .. External Subroutines ..
EXTERNAL DLASD1, DLASDQ, DLASDT, XERBLA
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
INFO = -2
END IF
*
M = N + SQRE
*
IF( LDU.LT.N ) THEN
INFO = -6
ELSE IF( LDVT.LT.M ) THEN
INFO = -8
ELSE IF( SMLSIZ.LT.3 ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLASD0', -INFO )
RETURN
END IF
*
* If the input matrix is too small, call DLASDQ to find the SVD.
*
IF( N.LE.SMLSIZ ) THEN
CALL DLASDQ( 'U', SQRE, N, M, N, 0, D, E, VT, LDVT, U, LDU, U,
$ LDU, WORK, INFO )
RETURN
END IF
*
* Set up the computation tree.
*
INODE = 1
NDIML = INODE + N
NDIMR = NDIML + N
IDXQ = NDIMR + N
IWK = IDXQ + N
CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ),
$ IWORK( NDIMR ), SMLSIZ )
*
* For the nodes on bottom level of the tree, solve
* their subproblems by DLASDQ.
*
NDB1 = ( ND+1 ) / 2
NCC = 0
DO 30 I = NDB1, ND
*
* IC : center row of each node
* NL : number of rows of left subproblem
* NR : number of rows of right subproblem
* NLF: starting row of the left subproblem
* NRF: starting row of the right subproblem
*
I1 = I - 1
IC = IWORK( INODE+I1 )
NL = IWORK( NDIML+I1 )
NLP1 = NL + 1
NR = IWORK( NDIMR+I1 )
NRP1 = NR + 1
NLF = IC - NL
NRF = IC + 1
SQREI = 1
CALL DLASDQ( 'U', SQREI, NL, NLP1, NL, NCC, D( NLF ), E( NLF ),
$ VT( NLF, NLF ), LDVT, U( NLF, NLF ), LDU,
$ U( NLF, NLF ), LDU, WORK, INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
ITEMP = IDXQ + NLF - 2
DO 10 J = 1, NL
IWORK( ITEMP+J ) = J
10 CONTINUE
IF( I.EQ.ND ) THEN
SQREI = SQRE
ELSE
SQREI = 1
END IF
NRP1 = NR + SQREI
CALL DLASDQ( 'U', SQREI, NR, NRP1, NR, NCC, D( NRF ), E( NRF ),
$ VT( NRF, NRF ), LDVT, U( NRF, NRF ), LDU,
$ U( NRF, NRF ), LDU, WORK, INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
ITEMP = IDXQ + IC
DO 20 J = 1, NR
IWORK( ITEMP+J-1 ) = J
20 CONTINUE
30 CONTINUE
*
* Now conquer each subproblem bottom-up.
*
DO 50 LVL = NLVL, 1, -1
*
* Find the first node LF and last node LL on the
* current level LVL.
*
IF( LVL.EQ.1 ) THEN
LF = 1
LL = 1
ELSE
LF = 2**( LVL-1 )
LL = 2*LF - 1
END IF
DO 40 I = LF, LL
IM1 = I - 1
IC = IWORK( INODE+IM1 )
NL = IWORK( NDIML+IM1 )
NR = IWORK( NDIMR+IM1 )
NLF = IC - NL
IF( ( SQRE.EQ.0 ) .AND. ( I.EQ.LL ) ) THEN
SQREI = SQRE
ELSE
SQREI = 1
END IF
IDXQC = IDXQ + NLF - 1
ALPHA = D( IC )
BETA = E( IC )
CALL DLASD1( NL, NR, SQREI, D( NLF ), ALPHA, BETA,
$ U( NLF, NLF ), LDU, VT( NLF, NLF ), LDVT,
$ IWORK( IDXQC ), IWORK( IWK ), WORK, INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
40 CONTINUE
50 CONTINUE
*
RETURN
*
* End of DLASD0
*
END
SUBROUTINE DLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT,
$ IDXQ, IWORK, WORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDU, LDVT, NL, NR, SQRE
DOUBLE PRECISION ALPHA, BETA
* ..
* .. Array Arguments ..
INTEGER IDXQ( * ), IWORK( * )
DOUBLE PRECISION D( * ), U( LDU, * ), VT( LDVT, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B,
* where N = NL + NR + 1 and M = N + SQRE. DLASD1 is called from DLASD0.
*
* A related subroutine DLASD7 handles the case in which the singular
* values (and the singular vectors in factored form) are desired.
*
* DLASD1 computes the SVD as follows:
*
* ( D1(in) 0 0 0 )
* B = U(in) * ( Z1' a Z2' b ) * VT(in)
* ( 0 0 D2(in) 0 )
*
* = U(out) * ( D(out) 0) * VT(out)
*
* where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M
* with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros
* elsewhere; and the entry b is empty if SQRE = 0.
*
* The left singular vectors of the original matrix are stored in U, and
* the transpose of the right singular vectors are stored in VT, and the
* singular values are in D. The algorithm consists of three stages:
*
* The first stage consists of deflating the size of the problem
* when there are multiple singular values or when there are zeros in
* the Z vector. For each such occurence the dimension of the
* secular equation problem is reduced by one. This stage is
* performed by the routine DLASD2.
*
* The second stage consists of calculating the updated
* singular values. This is done by finding the square roots of the
* roots of the secular equation via the routine DLASD4 (as called
* by DLASD3). This routine also calculates the singular vectors of
* the current problem.
*
* The final stage consists of computing the updated singular vectors
* directly using the updated singular values. The singular vectors
* for the current problem are multiplied with the singular vectors
* from the overall problem.
*
* Arguments
* =========
*
* NL (input) INTEGER
* The row dimension of the upper block. NL >= 1.
*
* NR (input) INTEGER
* The row dimension of the lower block. NR >= 1.
*
* SQRE (input) INTEGER
* = 0: the lower block is an NR-by-NR square matrix.
* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
*
* The bidiagonal matrix has row dimension N = NL + NR + 1,
* and column dimension M = N + SQRE.
*
* D (input/output) DOUBLE PRECISION array,
* dimension (N = NL+NR+1).
* On entry D(1:NL,1:NL) contains the singular values of the
* upper block; and D(NL+2:N) contains the singular values of
* the lower block. On exit D(1:N) contains the singular values
* of the modified matrix.
*
* ALPHA (input/output) DOUBLE PRECISION
* Contains the diagonal element associated with the added row.
*
* BETA (input/output) DOUBLE PRECISION
* Contains the off-diagonal element associated with the added
* row.
*
* U (input/output) DOUBLE PRECISION array, dimension(LDU,N)
* On entry U(1:NL, 1:NL) contains the left singular vectors of
* the upper block; U(NL+2:N, NL+2:N) contains the left singular
* vectors of the lower block. On exit U contains the left
* singular vectors of the bidiagonal matrix.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= max( 1, N ).
*
* VT (input/output) DOUBLE PRECISION array, dimension(LDVT,M)
* where M = N + SQRE.
* On entry VT(1:NL+1, 1:NL+1)' contains the right singular
* vectors of the upper block; VT(NL+2:M, NL+2:M)' contains
* the right singular vectors of the lower block. On exit
* VT' contains the right singular vectors of the
* bidiagonal matrix.
*
* LDVT (input) INTEGER
* The leading dimension of the array VT. LDVT >= max( 1, M ).
*
* IDXQ (output) INTEGER array, dimension(N)
* This contains the permutation which will reintegrate the
* subproblem just solved back into sorted order, i.e.
* D( IDXQ( I = 1, N ) ) will be in ascending order.
*
* IWORK (workspace) INTEGER array, dimension( 4 * N )
*
* WORK (workspace) DOUBLE PRECISION array, dimension( 3*M**2 + 2*M )
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an singular value did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
*
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER COLTYP, I, IDX, IDXC, IDXP, IQ, ISIGMA, IU2,
$ IVT2, IZ, K, LDQ, LDU2, LDVT2, M, N, N1, N2
DOUBLE PRECISION ORGNRM
* ..
* .. External Subroutines ..
EXTERNAL DLAMRG, DLASCL, DLASD2, DLASD3, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( NL.LT.1 ) THEN
INFO = -1
ELSE IF( NR.LT.1 ) THEN
INFO = -2
ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
INFO = -3
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLASD1', -INFO )
RETURN
END IF
*
N = NL + NR + 1
M = N + SQRE
*
* The following values are for bookkeeping purposes only. They are
* integer pointers which indicate the portion of the workspace
* used by a particular array in DLASD2 and DLASD3.
*
LDU2 = N
LDVT2 = M
*
IZ = 1
ISIGMA = IZ + M
IU2 = ISIGMA + N
IVT2 = IU2 + LDU2*N
IQ = IVT2 + LDVT2*M
*
IDX = 1
IDXC = IDX + N
COLTYP = IDXC + N
IDXP = COLTYP + N
*
* Scale.
*
ORGNRM = MAX( ABS( ALPHA ), ABS( BETA ) )
D( NL+1 ) = ZERO
DO 10 I = 1, N
IF( ABS( D( I ) ).GT.ORGNRM ) THEN
ORGNRM = ABS( D( I ) )
END IF
10 CONTINUE
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
ALPHA = ALPHA / ORGNRM
BETA = BETA / ORGNRM
*
* Deflate singular values.
*
CALL DLASD2( NL, NR, SQRE, K, D, WORK( IZ ), ALPHA, BETA, U, LDU,
$ VT, LDVT, WORK( ISIGMA ), WORK( IU2 ), LDU2,
$ WORK( IVT2 ), LDVT2, IWORK( IDXP ), IWORK( IDX ),
$ IWORK( IDXC ), IDXQ, IWORK( COLTYP ), INFO )
*
* Solve Secular Equation and update singular vectors.
*
LDQ = K
CALL DLASD3( NL, NR, SQRE, K, D, WORK( IQ ), LDQ, WORK( ISIGMA ),
$ U, LDU, WORK( IU2 ), LDU2, VT, LDVT, WORK( IVT2 ),
$ LDVT2, IWORK( IDXC ), IWORK( COLTYP ), WORK( IZ ),
$ INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
*
* Unscale.
*
CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
*
* Prepare the IDXQ sorting permutation.
*
N1 = K
N2 = N - K
CALL DLAMRG( N1, N2, D, 1, -1, IDXQ )
*
RETURN
*
* End of DLASD1
*
END
SUBROUTINE DLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT,
$ LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX,
$ IDXC, IDXQ, COLTYP, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDU, LDU2, LDVT, LDVT2, NL, NR, SQRE
DOUBLE PRECISION ALPHA, BETA
* ..
* .. Array Arguments ..
INTEGER COLTYP( * ), IDX( * ), IDXC( * ), IDXP( * ),
$ IDXQ( * )
DOUBLE PRECISION D( * ), DSIGMA( * ), U( LDU, * ),
$ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ),
$ Z( * )
* ..
*
* Purpose
* =======
*
* DLASD2 merges the two sets of singular values together into a single
* sorted set. Then it tries to deflate the size of the problem.
* There are two ways in which deflation can occur: when two or more
* singular values are close together or if there is a tiny entry in the
* Z vector. For each such occurrence the order of the related secular
* equation problem is reduced by one.
*
* DLASD2 is called from DLASD1.
*
* Arguments
* =========
*
* NL (input) INTEGER
* The row dimension of the upper block. NL >= 1.
*
* NR (input) INTEGER
* The row dimension of the lower block. NR >= 1.
*
* SQRE (input) INTEGER
* = 0: the lower block is an NR-by-NR square matrix.
* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
*
* The bidiagonal matrix has N = NL + NR + 1 rows and
* M = N + SQRE >= N columns.
*
* K (output) INTEGER
* Contains the dimension of the non-deflated matrix,
* This is the order of the related secular equation. 1 <= K <=N.
*
* D (input/output) DOUBLE PRECISION array, dimension(N)
* On entry D contains the singular values of the two submatrices
* to be combined. On exit D contains the trailing (N-K) updated
* singular values (those which were deflated) sorted into
* increasing order.
*
* Z (output) DOUBLE PRECISION array, dimension(N)
* On exit Z contains the updating row vector in the secular
* equation.
*
* ALPHA (input) DOUBLE PRECISION
* Contains the diagonal element associated with the added row.
*
* BETA (input) DOUBLE PRECISION
* Contains the off-diagonal element associated with the added
* row.
*
* U (input/output) DOUBLE PRECISION array, dimension(LDU,N)
* On entry U contains the left singular vectors of two
* submatrices in the two square blocks with corners at (1,1),
* (NL, NL), and (NL+2, NL+2), (N,N).
* On exit U contains the trailing (N-K) updated left singular
* vectors (those which were deflated) in its last N-K columns.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= N.
*
* VT (input/output) DOUBLE PRECISION array, dimension(LDVT,M)
* On entry VT' contains the right singular vectors of two
* submatrices in the two square blocks with corners at (1,1),
* (NL+1, NL+1), and (NL+2, NL+2), (M,M).
* On exit VT' contains the trailing (N-K) updated right singular
* vectors (those which were deflated) in its last N-K columns.
* In case SQRE =1, the last row of VT spans the right null
* space.
*
* LDVT (input) INTEGER
* The leading dimension of the array VT. LDVT >= M.
*
* DSIGMA (output) DOUBLE PRECISION array, dimension (N)
* Contains a copy of the diagonal elements (K-1 singular values
* and one zero) in the secular equation.
*
* U2 (output) DOUBLE PRECISION array, dimension(LDU2,N)
* Contains a copy of the first K-1 left singular vectors which
* will be used by DLASD3 in a matrix multiply (DGEMM) to solve
* for the new left singular vectors. U2 is arranged into four
* blocks. The first block contains a column with 1 at NL+1 and
* zero everywhere else; the second block contains non-zero
* entries only at and above NL; the third contains non-zero
* entries only below NL+1; and the fourth is dense.
*
* LDU2 (input) INTEGER
* The leading dimension of the array U2. LDU2 >= N.
*
* VT2 (output) DOUBLE PRECISION array, dimension(LDVT2,N)
* VT2' contains a copy of the first K right singular vectors
* which will be used by DLASD3 in a matrix multiply (DGEMM) to
* solve for the new right singular vectors. VT2 is arranged into
* three blocks. The first block contains a row that corresponds
* to the special 0 diagonal element in SIGMA; the second block
* contains non-zeros only at and before NL +1; the third block
* contains non-zeros only at and after NL +2.
*
* LDVT2 (input) INTEGER
* The leading dimension of the array VT2. LDVT2 >= M.
*
* IDXP (workspace) INTEGER array dimension(N)
* This will contain the permutation used to place deflated
* values of D at the end of the array. On output IDXP(2:K)
* points to the nondeflated D-values and IDXP(K+1:N)
* points to the deflated singular values.
*
* IDX (workspace) INTEGER array dimension(N)
* This will contain the permutation used to sort the contents of
* D into ascending order.
*
* IDXC (output) INTEGER array dimension(N)
* This will contain the permutation used to arrange the columns
* of the deflated U matrix into three groups: the first group
* contains non-zero entries only at and above NL, the second
* contains non-zero entries only below NL+2, and the third is
* dense.
*
* IDXQ (input/output) INTEGER array dimension(N)
* This contains the permutation which separately sorts the two
* sub-problems in D into ascending order. Note that entries in
* the first hlaf of this permutation must first be moved one
* position backward; and entries in the second half
* must first have NL+1 added to their values.
*
* COLTYP (workspace/output) INTEGER array dimension(N)
* As workspace, this will contain a label which will indicate
* which of the following types a column in the U2 matrix or a
* row in the VT2 matrix is:
* 1 : non-zero in the upper half only
* 2 : non-zero in the lower half only
* 3 : dense
* 4 : deflated
*
* On exit, it is an array of dimension 4, with COLTYP(I) being
* the dimension of the I-th type columns.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, EIGHT
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0,
$ EIGHT = 8.0D+0 )
* ..
* .. Local Arrays ..
INTEGER CTOT( 4 ), PSM( 4 )
* ..
* .. Local Scalars ..
INTEGER CT, I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M,
$ N, NLP1, NLP2
DOUBLE PRECISION C, EPS, HLFTOL, S, TAU, TOL, Z1
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLAPY2
EXTERNAL DLAMCH, DLAPY2
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLACPY, DLAMRG, DLASET, DROT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( NL.LT.1 ) THEN
INFO = -1
ELSE IF( NR.LT.1 ) THEN
INFO = -2
ELSE IF( ( SQRE.NE.1 ) .AND. ( SQRE.NE.0 ) ) THEN
INFO = -3
END IF
*
N = NL + NR + 1
M = N + SQRE
*
IF( LDU.LT.N ) THEN
INFO = -10
ELSE IF( LDVT.LT.M ) THEN
INFO = -12
ELSE IF( LDU2.LT.N ) THEN
INFO = -15
ELSE IF( LDVT2.LT.M ) THEN
INFO = -17
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLASD2', -INFO )
RETURN
END IF
*
NLP1 = NL + 1
NLP2 = NL + 2
*
* Generate the first part of the vector Z; and move the singular
* values in the first part of D one position backward.
*
Z1 = ALPHA*VT( NLP1, NLP1 )
Z( 1 ) = Z1
DO 10 I = NL, 1, -1
Z( I+1 ) = ALPHA*VT( I, NLP1 )
D( I+1 ) = D( I )
IDXQ( I+1 ) = IDXQ( I ) + 1
10 CONTINUE
*
* Generate the second part of the vector Z.
*
DO 20 I = NLP2, M
Z( I ) = BETA*VT( I, NLP2 )
20 CONTINUE
*
* Initialize some reference arrays.
*
DO 30 I = 2, NLP1
COLTYP( I ) = 1
30 CONTINUE
DO 40 I = NLP2, N
COLTYP( I ) = 2
40 CONTINUE
*
* Sort the singular values into increasing order
*
DO 50 I = NLP2, N
IDXQ( I ) = IDXQ( I ) + NLP1
50 CONTINUE
*
* DSIGMA, IDXC, IDXC, and the first column of U2
* are used as storage space.
*
DO 60 I = 2, N
DSIGMA( I ) = D( IDXQ( I ) )
U2( I, 1 ) = Z( IDXQ( I ) )
IDXC( I ) = COLTYP( IDXQ( I ) )
60 CONTINUE
*
CALL DLAMRG( NL, NR, DSIGMA( 2 ), 1, 1, IDX( 2 ) )
*
DO 70 I = 2, N
IDXI = 1 + IDX( I )
D( I ) = DSIGMA( IDXI )
Z( I ) = U2( IDXI, 1 )
COLTYP( I ) = IDXC( IDXI )
70 CONTINUE
*
* Calculate the allowable deflation tolerance
*
EPS = DLAMCH( 'Epsilon' )
TOL = MAX( ABS( ALPHA ), ABS( BETA ) )
TOL = EIGHT*EPS*MAX( ABS( D( N ) ), TOL )
*
* There are 2 kinds of deflation -- first a value in the z-vector
* is small, second two (or more) singular values are very close
* together (their difference is small).
*
* If the value in the z-vector is small, we simply permute the
* array so that the corresponding singular value is moved to the
* end.
*
* If two values in the D-vector are close, we perform a two-sided
* rotation designed to make one of the corresponding z-vector
* entries zero, and then permute the array so that the deflated
* singular value is moved to the end.
*
* If there are multiple singular values then the problem deflates.
* Here the number of equal singular values are found. As each equal
* singular value is found, an elementary reflector is computed to
* rotate the corresponding singular subspace so that the
* corresponding components of Z are zero in this new basis.
*
K = 1
K2 = N + 1
DO 80 J = 2, N
IF( ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
IDXP( K2 ) = J
COLTYP( J ) = 4
IF( J.EQ.N )
$ GO TO 120
ELSE
JPREV = J
GO TO 90
END IF
80 CONTINUE
90 CONTINUE
J = JPREV
100 CONTINUE
J = J + 1
IF( J.GT.N )
$ GO TO 110
IF( ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
IDXP( K2 ) = J
COLTYP( J ) = 4
ELSE
*
* Check if singular values are close enough to allow deflation.
*
IF( ABS( D( J )-D( JPREV ) ).LE.TOL ) THEN
*
* Deflation is possible.
*
S = Z( JPREV )
C = Z( J )
*
* Find sqrt(a**2+b**2) without overflow or
* destructive underflow.
*
TAU = DLAPY2( C, S )
C = C / TAU
S = -S / TAU
Z( J ) = TAU
Z( JPREV ) = ZERO
*
* Apply back the Givens rotation to the left and right
* singular vector matrices.
*
IDXJP = IDXQ( IDX( JPREV )+1 )
IDXJ = IDXQ( IDX( J )+1 )
IF( IDXJP.LE.NLP1 ) THEN
IDXJP = IDXJP - 1
END IF
IF( IDXJ.LE.NLP1 ) THEN
IDXJ = IDXJ - 1
END IF
CALL DROT( N, U( 1, IDXJP ), 1, U( 1, IDXJ ), 1, C, S )
CALL DROT( M, VT( IDXJP, 1 ), LDVT, VT( IDXJ, 1 ), LDVT, C,
$ S )
IF( COLTYP( J ).NE.COLTYP( JPREV ) ) THEN
COLTYP( J ) = 3
END IF
COLTYP( JPREV ) = 4
K2 = K2 - 1
IDXP( K2 ) = JPREV
JPREV = J
ELSE
K = K + 1
U2( K, 1 ) = Z( JPREV )
DSIGMA( K ) = D( JPREV )
IDXP( K ) = JPREV
JPREV = J
END IF
END IF
GO TO 100
110 CONTINUE
*
* Record the last singular value.
*
K = K + 1
U2( K, 1 ) = Z( JPREV )
DSIGMA( K ) = D( JPREV )
IDXP( K ) = JPREV
*
120 CONTINUE
*
* Count up the total number of the various types of columns, then
* form a permutation which positions the four column types into
* four groups of uniform structure (although one or more of these
* groups may be empty).
*
DO 130 J = 1, 4
CTOT( J ) = 0
130 CONTINUE
DO 140 J = 2, N
CT = COLTYP( J )
CTOT( CT ) = CTOT( CT ) + 1
140 CONTINUE
*
* PSM(*) = Position in SubMatrix (of types 1 through 4)
*
PSM( 1 ) = 2
PSM( 2 ) = 2 + CTOT( 1 )
PSM( 3 ) = PSM( 2 ) + CTOT( 2 )
PSM( 4 ) = PSM( 3 ) + CTOT( 3 )
*
* Fill out the IDXC array so that the permutation which it induces
* will place all type-1 columns first, all type-2 columns next,
* then all type-3's, and finally all type-4's, starting from the
* second column. This applies similarly to the rows of VT.
*
DO 150 J = 2, N
JP = IDXP( J )
CT = COLTYP( JP )
IDXC( PSM( CT ) ) = J
PSM( CT ) = PSM( CT ) + 1
150 CONTINUE
*
* Sort the singular values and corresponding singular vectors into
* DSIGMA, U2, and VT2 respectively. The singular values/vectors
* which were not deflated go into the first K slots of DSIGMA, U2,
* and VT2 respectively, while those which were deflated go into the
* last N - K slots, except that the first column/row will be treated
* separately.
*
DO 160 J = 2, N
JP = IDXP( J )
DSIGMA( J ) = D( JP )
IDXJ = IDXQ( IDX( IDXP( IDXC( J ) ) )+1 )
IF( IDXJ.LE.NLP1 ) THEN
IDXJ = IDXJ - 1
END IF
CALL DCOPY( N, U( 1, IDXJ ), 1, U2( 1, J ), 1 )
CALL DCOPY( M, VT( IDXJ, 1 ), LDVT, VT2( J, 1 ), LDVT2 )
160 CONTINUE
*
* Determine DSIGMA(1), DSIGMA(2) and Z(1)
*
DSIGMA( 1 ) = ZERO
HLFTOL = TOL / TWO
IF( ABS( DSIGMA( 2 ) ).LE.HLFTOL )
$ DSIGMA( 2 ) = HLFTOL
IF( M.GT.N ) THEN
Z( 1 ) = DLAPY2( Z1, Z( M ) )
IF( Z( 1 ).LE.TOL ) THEN
C = ONE
S = ZERO
Z( 1 ) = TOL
ELSE
C = Z1 / Z( 1 )
S = Z( M ) / Z( 1 )
END IF
ELSE
IF( ABS( Z1 ).LE.TOL ) THEN
Z( 1 ) = TOL
ELSE
Z( 1 ) = Z1
END IF
END IF
*
* Move the rest of the updating row to Z.
*
CALL DCOPY( K-1, U2( 2, 1 ), 1, Z( 2 ), 1 )
*
* Determine the first column of U2, the first row of VT2 and the
* last row of VT.
*
CALL DLASET( 'A', N, 1, ZERO, ZERO, U2, LDU2 )
U2( NLP1, 1 ) = ONE
IF( M.GT.N ) THEN
DO 170 I = 1, NLP1
VT( M, I ) = -S*VT( NLP1, I )
VT2( 1, I ) = C*VT( NLP1, I )
170 CONTINUE
DO 180 I = NLP2, M
VT2( 1, I ) = S*VT( M, I )
VT( M, I ) = C*VT( M, I )
180 CONTINUE
ELSE
CALL DCOPY( M, VT( NLP1, 1 ), LDVT, VT2( 1, 1 ), LDVT2 )
END IF
IF( M.GT.N ) THEN
CALL DCOPY( M, VT( M, 1 ), LDVT, VT2( M, 1 ), LDVT2 )
END IF
*
* The deflated singular values and their corresponding vectors go
* into the back of D, U, and V respectively.
*
IF( N.GT.K ) THEN
CALL DCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 )
CALL DLACPY( 'A', N, N-K, U2( 1, K+1 ), LDU2, U( 1, K+1 ),
$ LDU )
CALL DLACPY( 'A', N-K, M, VT2( K+1, 1 ), LDVT2, VT( K+1, 1 ),
$ LDVT )
END IF
*
* Copy CTOT into COLTYP for referencing in DLASD3.
*
DO 190 J = 1, 4
COLTYP( J ) = CTOT( J )
190 CONTINUE
*
RETURN
*
* End of DLASD2
*
END
SUBROUTINE DLASD3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2,
$ LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z,
$ INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDQ, LDU, LDU2, LDVT, LDVT2, NL, NR,
$ SQRE
* ..
* .. Array Arguments ..
INTEGER CTOT( * ), IDXC( * )
DOUBLE PRECISION D( * ), DSIGMA( * ), Q( LDQ, * ), U( LDU, * ),
$ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ),
$ Z( * )
* ..
*
* Purpose
* =======
*
* DLASD3 finds all the square roots of the roots of the secular
* equation, as defined by the values in D and Z. It makes the
* appropriate calls to DLASD4 and then updates the singular
* vectors by matrix multiplication.
*
* This code makes very mild assumptions about floating point
* arithmetic. It will work on machines with a guard digit in
* add/subtract, or on those binary machines without guard digits
* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
* It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* DLASD3 is called from DLASD1.
*
* Arguments
* =========
*
* NL (input) INTEGER
* The row dimension of the upper block. NL >= 1.
*
* NR (input) INTEGER
* The row dimension of the lower block. NR >= 1.
*
* SQRE (input) INTEGER
* = 0: the lower block is an NR-by-NR square matrix.
* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
*
* The bidiagonal matrix has N = NL + NR + 1 rows and
* M = N + SQRE >= N columns.
*
* K (input) INTEGER
* The size of the secular equation, 1 =< K = < N.
*
* D (output) DOUBLE PRECISION array, dimension(K)
* On exit the square roots of the roots of the secular equation,
* in ascending order.
*
* Q (workspace) DOUBLE PRECISION array,
* dimension at least (LDQ,K).
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= K.
*
* DSIGMA (input) DOUBLE PRECISION array, dimension(K)
* The first K elements of this array contain the old roots
* of the deflated updating problem. These are the poles
* of the secular equation.
*
* U (output) DOUBLE PRECISION array, dimension (LDU, N)
* The last N - K columns of this matrix contain the deflated
* left singular vectors.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= N.
*
* U2 (input/output) DOUBLE PRECISION array, dimension (LDU2, N)
* The first K columns of this matrix contain the non-deflated
* left singular vectors for the split problem.
*
* LDU2 (input) INTEGER
* The leading dimension of the array U2. LDU2 >= N.
*
* VT (output) DOUBLE PRECISION array, dimension (LDVT, M)
* The last M - K columns of VT' contain the deflated
* right singular vectors.
*
* LDVT (input) INTEGER
* The leading dimension of the array VT. LDVT >= N.
*
* VT2 (input/output) DOUBLE PRECISION array, dimension (LDVT2, N)
* The first K columns of VT2' contain the non-deflated
* right singular vectors for the split problem.
*
* LDVT2 (input) INTEGER
* The leading dimension of the array VT2. LDVT2 >= N.
*
* IDXC (input) INTEGER array, dimension ( N )
* The permutation used to arrange the columns of U (and rows of
* VT) into three groups: the first group contains non-zero
* entries only at and above (or before) NL +1; the second
* contains non-zero entries only at and below (or after) NL+2;
* and the third is dense. The first column of U and the row of
* VT are treated separately, however.
*
* The rows of the singular vectors found by DLASD4
* must be likewise permuted before the matrix multiplies can
* take place.
*
* CTOT (input) INTEGER array, dimension ( 4 )
* A count of the total number of the various types of columns
* in U (or rows in VT), as described in IDXC. The fourth column
* type is any column which has been deflated.
*
* Z (input) DOUBLE PRECISION array, dimension (K)
* The first K elements of this array contain the components
* of the deflation-adjusted updating row vector.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an singular value did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO, NEGONE
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0,
$ NEGONE = -1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER CTEMP, I, J, JC, KTEMP, M, N, NLP1, NLP2, NRP1
DOUBLE PRECISION RHO, TEMP
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMC3, DNRM2
EXTERNAL DLAMC3, DNRM2
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMM, DLACPY, DLASCL, DLASD4, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( NL.LT.1 ) THEN
INFO = -1
ELSE IF( NR.LT.1 ) THEN
INFO = -2
ELSE IF( ( SQRE.NE.1 ) .AND. ( SQRE.NE.0 ) ) THEN
INFO = -3
END IF
*
N = NL + NR + 1
M = N + SQRE
NLP1 = NL + 1
NLP2 = NL + 2
*
IF( ( K.LT.1 ) .OR. ( K.GT.N ) ) THEN
INFO = -4
ELSE IF( LDQ.LT.K ) THEN
INFO = -7
ELSE IF( LDU.LT.N ) THEN
INFO = -10
ELSE IF( LDU2.LT.N ) THEN
INFO = -12
ELSE IF( LDVT.LT.M ) THEN
INFO = -14
ELSE IF( LDVT2.LT.M ) THEN
INFO = -16
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLASD3', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( K.EQ.1 ) THEN
D( 1 ) = ABS( Z( 1 ) )
CALL DCOPY( M, VT2( 1, 1 ), LDVT2, VT( 1, 1 ), LDVT )
IF( Z( 1 ).GT.ZERO ) THEN
CALL DCOPY( N, U2( 1, 1 ), 1, U( 1, 1 ), 1 )
ELSE
DO 10 I = 1, N
U( I, 1 ) = -U2( I, 1 )
10 CONTINUE
END IF
RETURN
END IF
*
* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can
* be computed with high relative accuracy (barring over/underflow).
* This is a problem on machines without a guard digit in
* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I),
* which on any of these machines zeros out the bottommost
* bit of DSIGMA(I) if it is 1; this makes the subsequent
* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation
* occurs. On binary machines with a guard digit (almost all
* machines) it does not change DSIGMA(I) at all. On hexadecimal
* and decimal machines with a guard digit, it slightly
* changes the bottommost bits of DSIGMA(I). It does not account
* for hexadecimal or decimal machines without guard digits
* (we know of none). We use a subroutine call to compute
* 2*DSIGMA(I) to prevent optimizing compilers from eliminating
* this code.
*
DO 20 I = 1, K
DSIGMA( I ) = DLAMC3( DSIGMA( I ), DSIGMA( I ) ) - DSIGMA( I )
20 CONTINUE
*
* Keep a copy of Z.
*
CALL DCOPY( K, Z, 1, Q, 1 )
*
* Normalize Z.
*
RHO = DNRM2( K, Z, 1 )
CALL DLASCL( 'G', 0, 0, RHO, ONE, K, 1, Z, K, INFO )
RHO = RHO*RHO
*
* Find the new singular values.
*
DO 30 J = 1, K
CALL DLASD4( K, J, DSIGMA, Z, U( 1, J ), RHO, D( J ),
$ VT( 1, J ), INFO )
*
* If the zero finder fails, the computation is terminated.
*
IF( INFO.NE.0 ) THEN
RETURN
END IF
30 CONTINUE
*
* Compute updated Z.
*
DO 60 I = 1, K
Z( I ) = U( I, K )*VT( I, K )
DO 40 J = 1, I - 1
Z( I ) = Z( I )*( U( I, J )*VT( I, J ) /
$ ( DSIGMA( I )-DSIGMA( J ) ) /
$ ( DSIGMA( I )+DSIGMA( J ) ) )
40 CONTINUE
DO 50 J = I, K - 1
Z( I ) = Z( I )*( U( I, J )*VT( I, J ) /
$ ( DSIGMA( I )-DSIGMA( J+1 ) ) /
$ ( DSIGMA( I )+DSIGMA( J+1 ) ) )
50 CONTINUE
Z( I ) = SIGN( SQRT( ABS( Z( I ) ) ), Q( I, 1 ) )
60 CONTINUE
*
* Compute left singular vectors of the modified diagonal matrix,
* and store related information for the right singular vectors.
*
DO 90 I = 1, K
VT( 1, I ) = Z( 1 ) / U( 1, I ) / VT( 1, I )
U( 1, I ) = NEGONE
DO 70 J = 2, K
VT( J, I ) = Z( J ) / U( J, I ) / VT( J, I )
U( J, I ) = DSIGMA( J )*VT( J, I )
70 CONTINUE
TEMP = DNRM2( K, U( 1, I ), 1 )
Q( 1, I ) = U( 1, I ) / TEMP
DO 80 J = 2, K
JC = IDXC( J )
Q( J, I ) = U( JC, I ) / TEMP
80 CONTINUE
90 CONTINUE
*
* Update the left singular vector matrix.
*
IF( K.EQ.2 ) THEN
CALL DGEMM( 'N', 'N', N, K, K, ONE, U2, LDU2, Q, LDQ, ZERO, U,
$ LDU )
GO TO 100
END IF
IF( CTOT( 1 ).GT.0 ) THEN
CALL DGEMM( 'N', 'N', NL, K, CTOT( 1 ), ONE, U2( 1, 2 ), LDU2,
$ Q( 2, 1 ), LDQ, ZERO, U( 1, 1 ), LDU )
IF( CTOT( 3 ).GT.0 ) THEN
KTEMP = 2 + CTOT( 1 ) + CTOT( 2 )
CALL DGEMM( 'N', 'N', NL, K, CTOT( 3 ), ONE, U2( 1, KTEMP ),
$ LDU2, Q( KTEMP, 1 ), LDQ, ONE, U( 1, 1 ), LDU )
END IF
ELSE IF( CTOT( 3 ).GT.0 ) THEN
KTEMP = 2 + CTOT( 1 ) + CTOT( 2 )
CALL DGEMM( 'N', 'N', NL, K, CTOT( 3 ), ONE, U2( 1, KTEMP ),
$ LDU2, Q( KTEMP, 1 ), LDQ, ZERO, U( 1, 1 ), LDU )
ELSE
CALL DLACPY( 'F', NL, K, U2, LDU2, U, LDU )
END IF
CALL DCOPY( K, Q( 1, 1 ), LDQ, U( NLP1, 1 ), LDU )
KTEMP = 2 + CTOT( 1 )
CTEMP = CTOT( 2 ) + CTOT( 3 )
CALL DGEMM( 'N', 'N', NR, K, CTEMP, ONE, U2( NLP2, KTEMP ), LDU2,
$ Q( KTEMP, 1 ), LDQ, ZERO, U( NLP2, 1 ), LDU )
*
* Generate the right singular vectors.
*
100 CONTINUE
DO 120 I = 1, K
TEMP = DNRM2( K, VT( 1, I ), 1 )
Q( I, 1 ) = VT( 1, I ) / TEMP
DO 110 J = 2, K
JC = IDXC( J )
Q( I, J ) = VT( JC, I ) / TEMP
110 CONTINUE
120 CONTINUE
*
* Update the right singular vector matrix.
*
IF( K.EQ.2 ) THEN
CALL DGEMM( 'N', 'N', K, M, K, ONE, Q, LDQ, VT2, LDVT2, ZERO,
$ VT, LDVT )
RETURN
END IF
KTEMP = 1 + CTOT( 1 )
CALL DGEMM( 'N', 'N', K, NLP1, KTEMP, ONE, Q( 1, 1 ), LDQ,
$ VT2( 1, 1 ), LDVT2, ZERO, VT( 1, 1 ), LDVT )
KTEMP = 2 + CTOT( 1 ) + CTOT( 2 )
IF( KTEMP.LE.LDVT2 )
$ CALL DGEMM( 'N', 'N', K, NLP1, CTOT( 3 ), ONE, Q( 1, KTEMP ),
$ LDQ, VT2( KTEMP, 1 ), LDVT2, ONE, VT( 1, 1 ),
$ LDVT )
*
KTEMP = CTOT( 1 ) + 1
NRP1 = NR + SQRE
IF( KTEMP.GT.1 ) THEN
DO 130 I = 1, K
Q( I, KTEMP ) = Q( I, 1 )
130 CONTINUE
DO 140 I = NLP2, M
VT2( KTEMP, I ) = VT2( 1, I )
140 CONTINUE
END IF
CTEMP = 1 + CTOT( 2 ) + CTOT( 3 )
CALL DGEMM( 'N', 'N', K, NRP1, CTEMP, ONE, Q( 1, KTEMP ), LDQ,
$ VT2( KTEMP, NLP2 ), LDVT2, ZERO, VT( 1, NLP2 ), LDVT )
*
RETURN
*
* End of DLASD3
*
END
SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER I, INFO, N
DOUBLE PRECISION RHO, SIGMA
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), DELTA( * ), WORK( * ), Z( * )
* ..
*
* Purpose
* =======
*
* This subroutine computes the square root of the I-th updated
* eigenvalue of a positive symmetric rank-one modification to
* a positive diagonal matrix whose entries are given as the squares
* of the corresponding entries in the array d, and that
*
* 0 <= D(i) < D(j) for i < j
*
* and that RHO > 0. This is arranged by the calling routine, and is
* no loss in generality. The rank-one modified system is thus
*
* diag( D ) * diag( D ) + RHO * Z * Z_transpose.
*
* where we assume the Euclidean norm of Z is 1.
*
* The method consists of approximating the rational functions in the
* secular equation by simpler interpolating rational functions.
*
* Arguments
* =========
*
* N (input) INTEGER
* The length of all arrays.
*
* I (input) INTEGER
* The index of the eigenvalue to be computed. 1 <= I <= N.
*
* D (input) DOUBLE PRECISION array, dimension ( N )
* The original eigenvalues. It is assumed that they are in
* order, 0 <= D(I) < D(J) for I < J.
*
* Z (input) DOUBLE PRECISION array, dimension ( N )
* The components of the updating vector.
*
* DELTA (output) DOUBLE PRECISION array, dimension ( N )
* If N .ne. 1, DELTA contains (D(j) - sigma_I) in its j-th
* component. If N = 1, then DELTA(1) = 1. The vector DELTA
* contains the information necessary to construct the
* (singular) eigenvectors.
*
* RHO (input) DOUBLE PRECISION
* The scalar in the symmetric updating formula.
*
* SIGMA (output) DOUBLE PRECISION
* The computed sigma_I, the I-th updated eigenvalue.
*
* WORK (workspace) DOUBLE PRECISION array, dimension ( N )
* If N .ne. 1, WORK contains (D(j) + sigma_I) in its j-th
* component. If N = 1, then WORK( 1 ) = 1.
*
* INFO (output) INTEGER
* = 0: successful exit
* > 0: if INFO = 1, the updating process failed.
*
* Internal Parameters
* ===================
*
* Logical variable ORGATI (origin-at-i?) is used for distinguishing
* whether D(i) or D(i+1) is treated as the origin.
*
* ORGATI = .true. origin at i
* ORGATI = .false. origin at i+1
*
* Logical variable SWTCH3 (switch-for-3-poles?) is for noting
* if we are working with THREE poles!
*
* MAXIT is the maximum number of iterations allowed for each
* eigenvalue.
*
* Further Details
* ===============
*
* Based on contributions by
* Ren-Cang Li, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXIT
PARAMETER ( MAXIT = 20 )
DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0,
$ THREE = 3.0D+0, FOUR = 4.0D+0, EIGHT = 8.0D+0,
$ TEN = 10.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL ORGATI, SWTCH, SWTCH3
INTEGER II, IIM1, IIP1, IP1, ITER, J, NITER
DOUBLE PRECISION A, B, C, DELSQ, DELSQ2, DPHI, DPSI, DTIIM,
$ DTIIP, DTIPSQ, DTISQ, DTNSQ, DTNSQ1, DW, EPS,
$ ERRETM, ETA, PHI, PREW, PSI, RHOINV, SG2LB,
$ SG2UB, TAU, TEMP, TEMP1, TEMP2, W
* ..
* .. Local Arrays ..
DOUBLE PRECISION DD( 3 ), ZZ( 3 )
* ..
* .. External Subroutines ..
EXTERNAL DLAED6, DLASD5
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Since this routine is called in an inner loop, we do no argument
* checking.
*
* Quick return for N=1 and 2.
*
INFO = 0
IF( N.EQ.1 ) THEN
*
* Presumably, I=1 upon entry
*
SIGMA = SQRT( D( 1 )*D( 1 )+RHO*Z( 1 )*Z( 1 ) )
DELTA( 1 ) = ONE
WORK( 1 ) = ONE
RETURN
END IF
IF( N.EQ.2 ) THEN
CALL DLASD5( I, D, Z, DELTA, RHO, SIGMA, WORK )
RETURN
END IF
*
* Compute machine epsilon
*
EPS = DLAMCH( 'Epsilon' )
RHOINV = ONE / RHO
*
* The case I = N
*
IF( I.EQ.N ) THEN
*
* Initialize some basic variables
*
II = N - 1
NITER = 1
*
* Calculate initial guess
*
TEMP = RHO / TWO
*
* If ||Z||_2 is not one, then TEMP should be set to
* RHO * ||Z||_2^2 / TWO
*
TEMP1 = TEMP / ( D( N )+SQRT( D( N )*D( N )+TEMP ) )
DO 10 J = 1, N
WORK( J ) = D( J ) + D( N ) + TEMP1
DELTA( J ) = ( D( J )-D( N ) ) - TEMP1
10 CONTINUE
*
PSI = ZERO
DO 20 J = 1, N - 2
PSI = PSI + Z( J )*Z( J ) / ( DELTA( J )*WORK( J ) )
20 CONTINUE
*
C = RHOINV + PSI
W = C + Z( II )*Z( II ) / ( DELTA( II )*WORK( II ) ) +
$ Z( N )*Z( N ) / ( DELTA( N )*WORK( N ) )
*
IF( W.LE.ZERO ) THEN
TEMP1 = SQRT( D( N )*D( N )+RHO )
TEMP = Z( N-1 )*Z( N-1 ) / ( ( D( N-1 )+TEMP1 )*
$ ( D( N )-D( N-1 )+RHO / ( D( N )+TEMP1 ) ) ) +
$ Z( N )*Z( N ) / RHO
*
* The following TAU is to approximate
* SIGMA_n^2 - D( N )*D( N )
*
IF( C.LE.TEMP ) THEN
TAU = RHO
ELSE
DELSQ = ( D( N )-D( N-1 ) )*( D( N )+D( N-1 ) )
A = -C*DELSQ + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
B = Z( N )*Z( N )*DELSQ
IF( A.LT.ZERO ) THEN
TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
ELSE
TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
END IF
END IF
*
* It can be proved that
* D(N)^2+RHO/2 <= SIGMA_n^2 < D(N)^2+TAU <= D(N)^2+RHO
*
ELSE
DELSQ = ( D( N )-D( N-1 ) )*( D( N )+D( N-1 ) )
A = -C*DELSQ + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
B = Z( N )*Z( N )*DELSQ
*
* The following TAU is to approximate
* SIGMA_n^2 - D( N )*D( N )
*
IF( A.LT.ZERO ) THEN
TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
ELSE
TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
END IF
*
* It can be proved that
* D(N)^2 < D(N)^2+TAU < SIGMA(N)^2 < D(N)^2+RHO/2
*
END IF
*
* The following ETA is to approximate SIGMA_n - D( N )
*
ETA = TAU / ( D( N )+SQRT( D( N )*D( N )+TAU ) )
*
SIGMA = D( N ) + ETA
DO 30 J = 1, N
DELTA( J ) = ( D( J )-D( I ) ) - ETA
WORK( J ) = D( J ) + D( I ) + ETA
30 CONTINUE
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 40 J = 1, II
TEMP = Z( J ) / ( DELTA( J )*WORK( J ) )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
40 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
TEMP = Z( N ) / ( DELTA( N )*WORK( N ) )
PHI = Z( N )*TEMP
DPHI = TEMP*TEMP
ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
$ ABS( TAU )*( DPSI+DPHI )
*
W = RHOINV + PHI + PSI
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
GO TO 240
END IF
*
* Calculate the new step
*
NITER = NITER + 1
DTNSQ1 = WORK( N-1 )*DELTA( N-1 )
DTNSQ = WORK( N )*DELTA( N )
C = W - DTNSQ1*DPSI - DTNSQ*DPHI
A = ( DTNSQ+DTNSQ1 )*W - DTNSQ*DTNSQ1*( DPSI+DPHI )
B = DTNSQ*DTNSQ1*W
IF( C.LT.ZERO )
$ C = ABS( C )
IF( C.EQ.ZERO ) THEN
ETA = RHO - SIGMA*SIGMA
ELSE IF( A.GE.ZERO ) THEN
ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
IF( W*ETA.GT.ZERO )
$ ETA = -W / ( DPSI+DPHI )
TEMP = ETA - DTNSQ
IF( TEMP.GT.RHO )
$ ETA = RHO + DTNSQ
*
TAU = TAU + ETA
ETA = ETA / ( SIGMA+SQRT( ETA+SIGMA*SIGMA ) )
DO 50 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
WORK( J ) = WORK( J ) + ETA
50 CONTINUE
*
SIGMA = SIGMA + ETA
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 60 J = 1, II
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
60 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
TEMP = Z( N ) / ( WORK( N )*DELTA( N ) )
PHI = Z( N )*TEMP
DPHI = TEMP*TEMP
ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
$ ABS( TAU )*( DPSI+DPHI )
*
W = RHOINV + PHI + PSI
*
* Main loop to update the values of the array DELTA
*
ITER = NITER + 1
*
DO 90 NITER = ITER, MAXIT
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
GO TO 240
END IF
*
* Calculate the new step
*
DTNSQ1 = WORK( N-1 )*DELTA( N-1 )
DTNSQ = WORK( N )*DELTA( N )
C = W - DTNSQ1*DPSI - DTNSQ*DPHI
A = ( DTNSQ+DTNSQ1 )*W - DTNSQ1*DTNSQ*( DPSI+DPHI )
B = DTNSQ1*DTNSQ*W
IF( A.GE.ZERO ) THEN
ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
IF( W*ETA.GT.ZERO )
$ ETA = -W / ( DPSI+DPHI )
TEMP = ETA - DTNSQ
IF( TEMP.LE.ZERO )
$ ETA = ETA / TWO
*
TAU = TAU + ETA
ETA = ETA / ( SIGMA+SQRT( ETA+SIGMA*SIGMA ) )
DO 70 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
WORK( J ) = WORK( J ) + ETA
70 CONTINUE
*
SIGMA = SIGMA + ETA
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 80 J = 1, II
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
80 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
TEMP = Z( N ) / ( WORK( N )*DELTA( N ) )
PHI = Z( N )*TEMP
DPHI = TEMP*TEMP
ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
$ ABS( TAU )*( DPSI+DPHI )
*
W = RHOINV + PHI + PSI
90 CONTINUE
*
* Return with INFO = 1, NITER = MAXIT and not converged
*
INFO = 1
GO TO 240
*
* End for the case I = N
*
ELSE
*
* The case for I < N
*
NITER = 1
IP1 = I + 1
*
* Calculate initial guess
*
DELSQ = ( D( IP1 )-D( I ) )*( D( IP1 )+D( I ) )
DELSQ2 = DELSQ / TWO
TEMP = DELSQ2 / ( D( I )+SQRT( D( I )*D( I )+DELSQ2 ) )
DO 100 J = 1, N
WORK( J ) = D( J ) + D( I ) + TEMP
DELTA( J ) = ( D( J )-D( I ) ) - TEMP
100 CONTINUE
*
PSI = ZERO
DO 110 J = 1, I - 1
PSI = PSI + Z( J )*Z( J ) / ( WORK( J )*DELTA( J ) )
110 CONTINUE
*
PHI = ZERO
DO 120 J = N, I + 2, -1
PHI = PHI + Z( J )*Z( J ) / ( WORK( J )*DELTA( J ) )
120 CONTINUE
C = RHOINV + PSI + PHI
W = C + Z( I )*Z( I ) / ( WORK( I )*DELTA( I ) ) +
$ Z( IP1 )*Z( IP1 ) / ( WORK( IP1 )*DELTA( IP1 ) )
*
IF( W.GT.ZERO ) THEN
*
* d(i)^2 < the ith sigma^2 < (d(i)^2+d(i+1)^2)/2
*
* We choose d(i) as origin.
*
ORGATI = .TRUE.
SG2LB = ZERO
SG2UB = DELSQ2
A = C*DELSQ + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 )
B = Z( I )*Z( I )*DELSQ
IF( A.GT.ZERO ) THEN
TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
ELSE
TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
END IF
*
* TAU now is an estimation of SIGMA^2 - D( I )^2. The
* following, however, is the corresponding estimation of
* SIGMA - D( I ).
*
ETA = TAU / ( D( I )+SQRT( D( I )*D( I )+TAU ) )
ELSE
*
* (d(i)^2+d(i+1)^2)/2 <= the ith sigma^2 < d(i+1)^2/2
*
* We choose d(i+1) as origin.
*
ORGATI = .FALSE.
SG2LB = -DELSQ2
SG2UB = ZERO
A = C*DELSQ - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 )
B = Z( IP1 )*Z( IP1 )*DELSQ
IF( A.LT.ZERO ) THEN
TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) )
ELSE
TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C )
END IF
*
* TAU now is an estimation of SIGMA^2 - D( IP1 )^2. The
* following, however, is the corresponding estimation of
* SIGMA - D( IP1 ).
*
ETA = TAU / ( D( IP1 )+SQRT( ABS( D( IP1 )*D( IP1 )+
$ TAU ) ) )
END IF
*
IF( ORGATI ) THEN
II = I
SIGMA = D( I ) + ETA
DO 130 J = 1, N
WORK( J ) = D( J ) + D( I ) + ETA
DELTA( J ) = ( D( J )-D( I ) ) - ETA
130 CONTINUE
ELSE
II = I + 1
SIGMA = D( IP1 ) + ETA
DO 140 J = 1, N
WORK( J ) = D( J ) + D( IP1 ) + ETA
DELTA( J ) = ( D( J )-D( IP1 ) ) - ETA
140 CONTINUE
END IF
IIM1 = II - 1
IIP1 = II + 1
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 150 J = 1, IIM1
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
150 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
DPHI = ZERO
PHI = ZERO
DO 160 J = N, IIP1, -1
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PHI = PHI + Z( J )*TEMP
DPHI = DPHI + TEMP*TEMP
ERRETM = ERRETM + PHI
160 CONTINUE
*
W = RHOINV + PHI + PSI
*
* W is the value of the secular function with
* its ii-th element removed.
*
SWTCH3 = .FALSE.
IF( ORGATI ) THEN
IF( W.LT.ZERO )
$ SWTCH3 = .TRUE.
ELSE
IF( W.GT.ZERO )
$ SWTCH3 = .TRUE.
END IF
IF( II.EQ.1 .OR. II.EQ.N )
$ SWTCH3 = .FALSE.
*
TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
DW = DPSI + DPHI + TEMP*TEMP
TEMP = Z( II )*TEMP
W = W + TEMP
ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
$ THREE*ABS( TEMP ) + ABS( TAU )*DW
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
GO TO 240
END IF
*
IF( W.LE.ZERO ) THEN
SG2LB = MAX( SG2LB, TAU )
ELSE
SG2UB = MIN( SG2UB, TAU )
END IF
*
* Calculate the new step
*
NITER = NITER + 1
IF( .NOT.SWTCH3 ) THEN
DTIPSQ = WORK( IP1 )*DELTA( IP1 )
DTISQ = WORK( I )*DELTA( I )
IF( ORGATI ) THEN
C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2
ELSE
C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2
END IF
A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW
B = DTIPSQ*DTISQ*W
IF( C.EQ.ZERO ) THEN
IF( A.EQ.ZERO ) THEN
IF( ORGATI ) THEN
A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ*( DPSI+DPHI )
ELSE
A = Z( IP1 )*Z( IP1 ) + DTISQ*DTISQ*( DPSI+DPHI )
END IF
END IF
ETA = B / A
ELSE IF( A.LE.ZERO ) THEN
ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
ELSE
*
* Interpolation using THREE most relevant poles
*
DTIIM = WORK( IIM1 )*DELTA( IIM1 )
DTIIP = WORK( IIP1 )*DELTA( IIP1 )
TEMP = RHOINV + PSI + PHI
IF( ORGATI ) THEN
TEMP1 = Z( IIM1 ) / DTIIM
TEMP1 = TEMP1*TEMP1
C = ( TEMP - DTIIP*( DPSI+DPHI ) ) -
$ ( D( IIM1 )-D( IIP1 ) )*( D( IIM1 )+D( IIP1 ) )*TEMP1
ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
IF( DPSI.LT.TEMP1 ) THEN
ZZ( 3 ) = DTIIP*DTIIP*DPHI
ELSE
ZZ( 3 ) = DTIIP*DTIIP*( ( DPSI-TEMP1 )+DPHI )
END IF
ELSE
TEMP1 = Z( IIP1 ) / DTIIP
TEMP1 = TEMP1*TEMP1
C = ( TEMP - DTIIM*( DPSI+DPHI ) ) -
$ ( D( IIP1 )-D( IIM1 ) )*( D( IIM1 )+D( IIP1 ) )*TEMP1
IF( DPHI.LT.TEMP1 ) THEN
ZZ( 1 ) = DTIIM*DTIIM*DPSI
ELSE
ZZ( 1 ) = DTIIM*DTIIM*( DPSI+( DPHI-TEMP1 ) )
END IF
ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
END IF
ZZ( 2 ) = Z( II )*Z( II )
DD( 1 ) = DTIIM
DD( 2 ) = DELTA( II )*WORK( II )
DD( 3 ) = DTIIP
CALL DLAED6( NITER, ORGATI, C, DD, ZZ, W, ETA, INFO )
IF( INFO.NE.0 )
$ GO TO 240
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
IF( W*ETA.GE.ZERO )
$ ETA = -W / DW
IF( ORGATI ) THEN
TEMP1 = WORK( I )*DELTA( I )
TEMP = ETA - TEMP1
ELSE
TEMP1 = WORK( IP1 )*DELTA( IP1 )
TEMP = ETA - TEMP1
END IF
IF( TEMP.GT.SG2UB .OR. TEMP.LT.SG2LB ) THEN
IF( W.LT.ZERO ) THEN
ETA = ( SG2UB-TAU ) / TWO
ELSE
ETA = ( SG2LB-TAU ) / TWO
END IF
END IF
*
TAU = TAU + ETA
ETA = ETA / ( SIGMA+SQRT( SIGMA*SIGMA+ETA ) )
*
PREW = W
*
SIGMA = SIGMA + ETA
DO 170 J = 1, N
WORK( J ) = WORK( J ) + ETA
DELTA( J ) = DELTA( J ) - ETA
170 CONTINUE
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 180 J = 1, IIM1
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
180 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
DPHI = ZERO
PHI = ZERO
DO 190 J = N, IIP1, -1
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PHI = PHI + Z( J )*TEMP
DPHI = DPHI + TEMP*TEMP
ERRETM = ERRETM + PHI
190 CONTINUE
*
TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
DW = DPSI + DPHI + TEMP*TEMP
TEMP = Z( II )*TEMP
W = RHOINV + PHI + PSI + TEMP
ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
$ THREE*ABS( TEMP ) + ABS( TAU )*DW
*
IF( W.LE.ZERO ) THEN
SG2LB = MAX( SG2LB, TAU )
ELSE
SG2UB = MIN( SG2UB, TAU )
END IF
*
SWTCH = .FALSE.
IF( ORGATI ) THEN
IF( -W.GT.ABS( PREW ) / TEN )
$ SWTCH = .TRUE.
ELSE
IF( W.GT.ABS( PREW ) / TEN )
$ SWTCH = .TRUE.
END IF
*
* Main loop to update the values of the array DELTA and WORK
*
ITER = NITER + 1
*
DO 230 NITER = ITER, MAXIT
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
GO TO 240
END IF
*
* Calculate the new step
*
IF( .NOT.SWTCH3 ) THEN
DTIPSQ = WORK( IP1 )*DELTA( IP1 )
DTISQ = WORK( I )*DELTA( I )
IF( .NOT.SWTCH ) THEN
IF( ORGATI ) THEN
C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2
ELSE
C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2
END IF
ELSE
TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
IF( ORGATI ) THEN
DPSI = DPSI + TEMP*TEMP
ELSE
DPHI = DPHI + TEMP*TEMP
END IF
C = W - DTISQ*DPSI - DTIPSQ*DPHI
END IF
A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW
B = DTIPSQ*DTISQ*W
IF( C.EQ.ZERO ) THEN
IF( A.EQ.ZERO ) THEN
IF( .NOT.SWTCH ) THEN
IF( ORGATI ) THEN
A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ*
$ ( DPSI+DPHI )
ELSE
A = Z( IP1 )*Z( IP1 ) +
$ DTISQ*DTISQ*( DPSI+DPHI )
END IF
ELSE
A = DTISQ*DTISQ*DPSI + DTIPSQ*DTIPSQ*DPHI
END IF
END IF
ETA = B / A
ELSE IF( A.LE.ZERO ) THEN
ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
ELSE
*
* Interpolation using THREE most relevant poles
*
DTIIM = WORK( IIM1 )*DELTA( IIM1 )
DTIIP = WORK( IIP1 )*DELTA( IIP1 )
TEMP = RHOINV + PSI + PHI
IF( SWTCH ) THEN
C = TEMP - DTIIM*DPSI - DTIIP*DPHI
ZZ( 1 ) = DTIIM*DTIIM*DPSI
ZZ( 3 ) = DTIIP*DTIIP*DPHI
ELSE
IF( ORGATI ) THEN
TEMP1 = Z( IIM1 ) / DTIIM
TEMP1 = TEMP1*TEMP1
TEMP2 = ( D( IIM1 )-D( IIP1 ) )*
$ ( D( IIM1 )+D( IIP1 ) )*TEMP1
C = TEMP - DTIIP*( DPSI+DPHI ) - TEMP2
ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
IF( DPSI.LT.TEMP1 ) THEN
ZZ( 3 ) = DTIIP*DTIIP*DPHI
ELSE
ZZ( 3 ) = DTIIP*DTIIP*( ( DPSI-TEMP1 )+DPHI )
END IF
ELSE
TEMP1 = Z( IIP1 ) / DTIIP
TEMP1 = TEMP1*TEMP1
TEMP2 = ( D( IIP1 )-D( IIM1 ) )*
$ ( D( IIM1 )+D( IIP1 ) )*TEMP1
C = TEMP - DTIIM*( DPSI+DPHI ) - TEMP2
IF( DPHI.LT.TEMP1 ) THEN
ZZ( 1 ) = DTIIM*DTIIM*DPSI
ELSE
ZZ( 1 ) = DTIIM*DTIIM*( DPSI+( DPHI-TEMP1 ) )
END IF
ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
END IF
END IF
DD( 1 ) = DTIIM
DD( 2 ) = DELTA( II )*WORK( II )
DD( 3 ) = DTIIP
CALL DLAED6( NITER, ORGATI, C, DD, ZZ, W, ETA, INFO )
IF( INFO.NE.0 )
$ GO TO 240
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
IF( W*ETA.GE.ZERO )
$ ETA = -W / DW
IF( ORGATI ) THEN
TEMP1 = WORK( I )*DELTA( I )
TEMP = ETA - TEMP1
ELSE
TEMP1 = WORK( IP1 )*DELTA( IP1 )
TEMP = ETA - TEMP1
END IF
IF( TEMP.GT.SG2UB .OR. TEMP.LT.SG2LB ) THEN
IF( W.LT.ZERO ) THEN
ETA = ( SG2UB-TAU ) / TWO
ELSE
ETA = ( SG2LB-TAU ) / TWO
END IF
END IF
*
TAU = TAU + ETA
ETA = ETA / ( SIGMA+SQRT( SIGMA*SIGMA+ETA ) )
*
SIGMA = SIGMA + ETA
DO 200 J = 1, N
WORK( J ) = WORK( J ) + ETA
DELTA( J ) = DELTA( J ) - ETA
200 CONTINUE
*
PREW = W
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 210 J = 1, IIM1
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
210 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
DPHI = ZERO
PHI = ZERO
DO 220 J = N, IIP1, -1
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PHI = PHI + Z( J )*TEMP
DPHI = DPHI + TEMP*TEMP
ERRETM = ERRETM + PHI
220 CONTINUE
*
TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
DW = DPSI + DPHI + TEMP*TEMP
TEMP = Z( II )*TEMP
W = RHOINV + PHI + PSI + TEMP
ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
$ THREE*ABS( TEMP ) + ABS( TAU )*DW
IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN )
$ SWTCH = .NOT.SWTCH
*
IF( W.LE.ZERO ) THEN
SG2LB = MAX( SG2LB, TAU )
ELSE
SG2UB = MIN( SG2UB, TAU )
END IF
*
230 CONTINUE
*
* Return with INFO = 1, NITER = MAXIT and not converged
*
INFO = 1
*
END IF
*
240 CONTINUE
RETURN
*
* End of DLASD4
*
END
SUBROUTINE DLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER I
DOUBLE PRECISION DSIGMA, RHO
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( 2 ), DELTA( 2 ), WORK( 2 ), Z( 2 )
* ..
*
* Purpose
* =======
*
* This subroutine computes the square root of the I-th eigenvalue
* of a positive symmetric rank-one modification of a 2-by-2 diagonal
* matrix
*
* diag( D ) * diag( D ) + RHO * Z * transpose(Z) .
*
* The diagonal entries in the array D are assumed to satisfy
*
* 0 <= D(i) < D(j) for i < j .
*
* We also assume RHO > 0 and that the Euclidean norm of the vector
* Z is one.
*
* Arguments
* =========
*
* I (input) INTEGER
* The index of the eigenvalue to be computed. I = 1 or I = 2.
*
* D (input) DOUBLE PRECISION array, dimension ( 2 )
* The original eigenvalues. We assume 0 <= D(1) < D(2).
*
* Z (input) DOUBLE PRECISION array, dimension ( 2 )
* The components of the updating vector.
*
* DELTA (output) DOUBLE PRECISION array, dimension ( 2 )
* Contains (D(j) - sigma_I) in its j-th component.
* The vector DELTA contains the information necessary
* to construct the eigenvectors.
*
* RHO (input) DOUBLE PRECISION
* The scalar in the symmetric updating formula.
*
* DSIGMA (output) DOUBLE PRECISION
* The computed sigma_I, the I-th updated eigenvalue.
*
* WORK (workspace) DOUBLE PRECISION array, dimension ( 2 )
* WORK contains (D(j) + sigma_I) in its j-th component.
*
* Further Details
* ===============
*
* Based on contributions by
* Ren-Cang Li, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0,
$ THREE = 3.0D+0, FOUR = 4.0D+0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION B, C, DEL, DELSQ, TAU, W
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SQRT
* ..
* .. Executable Statements ..
*
DEL = D( 2 ) - D( 1 )
DELSQ = DEL*( D( 2 )+D( 1 ) )
IF( I.EQ.1 ) THEN
W = ONE + FOUR*RHO*( Z( 2 )*Z( 2 ) / ( D( 1 )+THREE*D( 2 ) )-
$ Z( 1 )*Z( 1 ) / ( THREE*D( 1 )+D( 2 ) ) ) / DEL
IF( W.GT.ZERO ) THEN
B = DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
C = RHO*Z( 1 )*Z( 1 )*DELSQ
*
* B > ZERO, always
*
* The following TAU is DSIGMA * DSIGMA - D( 1 ) * D( 1 )
*
TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) )
*
* The following TAU is DSIGMA - D( 1 )
*
TAU = TAU / ( D( 1 )+SQRT( D( 1 )*D( 1 )+TAU ) )
DSIGMA = D( 1 ) + TAU
DELTA( 1 ) = -TAU
DELTA( 2 ) = DEL - TAU
WORK( 1 ) = TWO*D( 1 ) + TAU
WORK( 2 ) = ( D( 1 )+TAU ) + D( 2 )
* DELTA( 1 ) = -Z( 1 ) / TAU
* DELTA( 2 ) = Z( 2 ) / ( DEL-TAU )
ELSE
B = -DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
C = RHO*Z( 2 )*Z( 2 )*DELSQ
*
* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 )
*
IF( B.GT.ZERO ) THEN
TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) )
ELSE
TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO
END IF
*
* The following TAU is DSIGMA - D( 2 )
*
TAU = TAU / ( D( 2 )+SQRT( ABS( D( 2 )*D( 2 )+TAU ) ) )
DSIGMA = D( 2 ) + TAU
DELTA( 1 ) = -( DEL+TAU )
DELTA( 2 ) = -TAU
WORK( 1 ) = D( 1 ) + TAU + D( 2 )
WORK( 2 ) = TWO*D( 2 ) + TAU
* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
* DELTA( 2 ) = -Z( 2 ) / TAU
END IF
* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
* DELTA( 1 ) = DELTA( 1 ) / TEMP
* DELTA( 2 ) = DELTA( 2 ) / TEMP
ELSE
*
* Now I=2
*
B = -DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
C = RHO*Z( 2 )*Z( 2 )*DELSQ
*
* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 )
*
IF( B.GT.ZERO ) THEN
TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO
ELSE
TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) )
END IF
*
* The following TAU is DSIGMA - D( 2 )
*
TAU = TAU / ( D( 2 )+SQRT( D( 2 )*D( 2 )+TAU ) )
DSIGMA = D( 2 ) + TAU
DELTA( 1 ) = -( DEL+TAU )
DELTA( 2 ) = -TAU
WORK( 1 ) = D( 1 ) + TAU + D( 2 )
WORK( 2 ) = TWO*D( 2 ) + TAU
* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
* DELTA( 2 ) = -Z( 2 ) / TAU
* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
* DELTA( 1 ) = DELTA( 1 ) / TEMP
* DELTA( 2 ) = DELTA( 2 ) / TEMP
END IF
RETURN
*
* End of DLASD5
*
END
SUBROUTINE DLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA,
$ IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM,
$ LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK,
$ IWORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL,
$ NR, SQRE
DOUBLE PRECISION ALPHA, BETA, C, S
* ..
* .. Array Arguments ..
INTEGER GIVCOL( LDGCOL, * ), IDXQ( * ), IWORK( * ),
$ PERM( * )
DOUBLE PRECISION D( * ), DIFL( * ), DIFR( * ),
$ GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ),
$ VF( * ), VL( * ), WORK( * ), Z( * )
* ..
*
* Purpose
* =======
*
* DLASD6 computes the SVD of an updated upper bidiagonal matrix B
* obtained by merging two smaller ones by appending a row. This
* routine is used only for the problem which requires all singular
* values and optionally singular vector matrices in factored form.
* B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE.
* A related subroutine, DLASD1, handles the case in which all singular
* values and singular vectors of the bidiagonal matrix are desired.
*
* DLASD6 computes the SVD as follows:
*
* ( D1(in) 0 0 0 )
* B = U(in) * ( Z1' a Z2' b ) * VT(in)
* ( 0 0 D2(in) 0 )
*
* = U(out) * ( D(out) 0) * VT(out)
*
* where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M
* with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros
* elsewhere; and the entry b is empty if SQRE = 0.
*
* The singular values of B can be computed using D1, D2, the first
* components of all the right singular vectors of the lower block, and
* the last components of all the right singular vectors of the upper
* block. These components are stored and updated in VF and VL,
* respectively, in DLASD6. Hence U and VT are not explicitly
* referenced.
*
* The singular values are stored in D. The algorithm consists of two
* stages:
*
* The first stage consists of deflating the size of the problem
* when there are multiple singular values or if there is a zero
* in the Z vector. For each such occurence the dimension of the
* secular equation problem is reduced by one. This stage is
* performed by the routine DLASD7.
*
* The second stage consists of calculating the updated
* singular values. This is done by finding the roots of the
* secular equation via the routine DLASD4 (as called by DLASD8).
* This routine also updates VF and VL and computes the distances
* between the updated singular values and the old singular
* values.
*
* DLASD6 is called from DLASDA.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* Specifies whether singular vectors are to be computed in
* factored form:
* = 0: Compute singular values only.
* = 1: Compute singular vectors in factored form as well.
*
* NL (input) INTEGER
* The row dimension of the upper block. NL >= 1.
*
* NR (input) INTEGER
* The row dimension of the lower block. NR >= 1.
*
* SQRE (input) INTEGER
* = 0: the lower block is an NR-by-NR square matrix.
* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
*
* The bidiagonal matrix has row dimension N = NL + NR + 1,
* and column dimension M = N + SQRE.
*
* D (input/output) DOUBLE PRECISION array, dimension ( NL+NR+1 ).
* On entry D(1:NL,1:NL) contains the singular values of the
* upper block, and D(NL+2:N) contains the singular values
* of the lower block. On exit D(1:N) contains the singular
* values of the modified matrix.
*
* VF (input/output) DOUBLE PRECISION array, dimension ( M )
* On entry, VF(1:NL+1) contains the first components of all
* right singular vectors of the upper block; and VF(NL+2:M)
* contains the first components of all right singular vectors
* of the lower block. On exit, VF contains the first components
* of all right singular vectors of the bidiagonal matrix.
*
* VL (input/output) DOUBLE PRECISION array, dimension ( M )
* On entry, VL(1:NL+1) contains the last components of all
* right singular vectors of the upper block; and VL(NL+2:M)
* contains the last components of all right singular vectors of
* the lower block. On exit, VL contains the last components of
* all right singular vectors of the bidiagonal matrix.
*
* ALPHA (input/output) DOUBLE PRECISION
* Contains the diagonal element associated with the added row.
*
* BETA (input/output) DOUBLE PRECISION
* Contains the off-diagonal element associated with the added
* row.
*
* IDXQ (output) INTEGER array, dimension ( N )
* This contains the permutation which will reintegrate the
* subproblem just solved back into sorted order, i.e.
* D( IDXQ( I = 1, N ) ) will be in ascending order.
*
* PERM (output) INTEGER array, dimension ( N )
* The permutations (from deflation and sorting) to be applied
* to each block. Not referenced if ICOMPQ = 0.
*
* GIVPTR (output) INTEGER
* The number of Givens rotations which took place in this
* subproblem. Not referenced if ICOMPQ = 0.
*
* GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )
* Each pair of numbers indicates a pair of columns to take place
* in a Givens rotation. Not referenced if ICOMPQ = 0.
*
* LDGCOL (input) INTEGER
* leading dimension of GIVCOL, must be at least N.
*
* GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
* Each number indicates the C or S value to be used in the
* corresponding Givens rotation. Not referenced if ICOMPQ = 0.
*
* LDGNUM (input) INTEGER
* The leading dimension of GIVNUM and POLES, must be at least N.
*
* POLES (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
* On exit, POLES(1,*) is an array containing the new singular
* values obtained from solving the secular equation, and
* POLES(2,*) is an array containing the poles in the secular
* equation. Not referenced if ICOMPQ = 0.
*
* DIFL (output) DOUBLE PRECISION array, dimension ( N )
* On exit, DIFL(I) is the distance between I-th updated
* (undeflated) singular value and the I-th (undeflated) old
* singular value.
*
* DIFR (output) DOUBLE PRECISION array,
* dimension ( LDGNUM, 2 ) if ICOMPQ = 1 and
* dimension ( N ) if ICOMPQ = 0.
* On exit, DIFR(I, 1) is the distance between I-th updated
* (undeflated) singular value and the I+1-th (undeflated) old
* singular value.
*
* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the
* normalizing factors for the right singular vector matrix.
*
* See DLASD8 for details on DIFL and DIFR.
*
* Z (output) DOUBLE PRECISION array, dimension ( M )
* The first elements of this array contain the components
* of the deflation-adjusted updating row vector.
*
* K (output) INTEGER
* Contains the dimension of the non-deflated matrix,
* This is the order of the related secular equation. 1 <= K <=N.
*
* C (output) DOUBLE PRECISION
* C contains garbage if SQRE =0 and the C-value of a Givens
* rotation related to the right null space if SQRE = 1.
*
* S (output) DOUBLE PRECISION
* S contains garbage if SQRE =0 and the S-value of a Givens
* rotation related to the right null space if SQRE = 1.
*
* WORK (workspace) DOUBLE PRECISION array, dimension ( 4 * M )
*
* IWORK (workspace) INTEGER array, dimension ( 3 * N )
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an singular value did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, IDX, IDXC, IDXP, ISIGMA, IVFW, IVLW, IW, M,
$ N, N1, N2
DOUBLE PRECISION ORGNRM
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLAMRG, DLASCL, DLASD7, DLASD8, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
N = NL + NR + 1
M = N + SQRE
*
IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
INFO = -1
ELSE IF( NL.LT.1 ) THEN
INFO = -2
ELSE IF( NR.LT.1 ) THEN
INFO = -3
ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
INFO = -4
ELSE IF( LDGCOL.LT.N ) THEN
INFO = -14
ELSE IF( LDGNUM.LT.N ) THEN
INFO = -16
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLASD6', -INFO )
RETURN
END IF
*
* The following values are for bookkeeping purposes only. They are
* integer pointers which indicate the portion of the workspace
* used by a particular array in DLASD7 and DLASD8.
*
ISIGMA = 1
IW = ISIGMA + N
IVFW = IW + M
IVLW = IVFW + M
*
IDX = 1
IDXC = IDX + N
IDXP = IDXC + N
*
* Scale.
*
ORGNRM = MAX( ABS( ALPHA ), ABS( BETA ) )
D( NL+1 ) = ZERO
DO 10 I = 1, N
IF( ABS( D( I ) ).GT.ORGNRM ) THEN
ORGNRM = ABS( D( I ) )
END IF
10 CONTINUE
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
ALPHA = ALPHA / ORGNRM
BETA = BETA / ORGNRM
*
* Sort and Deflate singular values.
*
CALL DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, WORK( IW ), VF,
$ WORK( IVFW ), VL, WORK( IVLW ), ALPHA, BETA,
$ WORK( ISIGMA ), IWORK( IDX ), IWORK( IDXP ), IDXQ,
$ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, C, S,
$ INFO )
*
* Solve Secular Equation, compute DIFL, DIFR, and update VF, VL.
*
CALL DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDGNUM,
$ WORK( ISIGMA ), WORK( IW ), INFO )
*
* Save the poles if ICOMPQ = 1.
*
IF( ICOMPQ.EQ.1 ) THEN
CALL DCOPY( K, D, 1, POLES( 1, 1 ), 1 )
CALL DCOPY( K, WORK( ISIGMA ), 1, POLES( 1, 2 ), 1 )
END IF
*
* Unscale.
*
CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
*
* Prepare the IDXQ sorting permutation.
*
N1 = K
N2 = N - K
CALL DLAMRG( N1, N2, D, 1, -1, IDXQ )
*
RETURN
*
* End of DLASD6
*
END
SUBROUTINE DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL,
$ VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ,
$ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM,
$ C, S, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL,
$ NR, SQRE
DOUBLE PRECISION ALPHA, BETA, C, S
* ..
* .. Array Arguments ..
INTEGER GIVCOL( LDGCOL, * ), IDX( * ), IDXP( * ),
$ IDXQ( * ), PERM( * )
DOUBLE PRECISION D( * ), DSIGMA( * ), GIVNUM( LDGNUM, * ),
$ VF( * ), VFW( * ), VL( * ), VLW( * ), Z( * ),
$ ZW( * )
* ..
*
* Purpose
* =======
*
* DLASD7 merges the two sets of singular values together into a single
* sorted set. Then it tries to deflate the size of the problem. There
* are two ways in which deflation can occur: when two or more singular
* values are close together or if there is a tiny entry in the Z
* vector. For each such occurrence the order of the related
* secular equation problem is reduced by one.
*
* DLASD7 is called from DLASD6.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* Specifies whether singular vectors are to be computed
* in compact form, as follows:
* = 0: Compute singular values only.
* = 1: Compute singular vectors of upper
* bidiagonal matrix in compact form.
*
* NL (input) INTEGER
* The row dimension of the upper block. NL >= 1.
*
* NR (input) INTEGER
* The row dimension of the lower block. NR >= 1.
*
* SQRE (input) INTEGER
* = 0: the lower block is an NR-by-NR square matrix.
* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
*
* The bidiagonal matrix has
* N = NL + NR + 1 rows and
* M = N + SQRE >= N columns.
*
* K (output) INTEGER
* Contains the dimension of the non-deflated matrix, this is
* the order of the related secular equation. 1 <= K <=N.
*
* D (input/output) DOUBLE PRECISION array, dimension ( N )
* On entry D contains the singular values of the two submatrices
* to be combined. On exit D contains the trailing (N-K) updated
* singular values (those which were deflated) sorted into
* increasing order.
*
* Z (output) DOUBLE PRECISION array, dimension ( M )
* On exit Z contains the updating row vector in the secular
* equation.
*
* ZW (workspace) DOUBLE PRECISION array, dimension ( M )
* Workspace for Z.
*
* VF (input/output) DOUBLE PRECISION array, dimension ( M )
* On entry, VF(1:NL+1) contains the first components of all
* right singular vectors of the upper block; and VF(NL+2:M)
* contains the first components of all right singular vectors
* of the lower block. On exit, VF contains the first components
* of all right singular vectors of the bidiagonal matrix.
*
* VFW (workspace) DOUBLE PRECISION array, dimension ( M )
* Workspace for VF.
*
* VL (input/output) DOUBLE PRECISION array, dimension ( M )
* On entry, VL(1:NL+1) contains the last components of all
* right singular vectors of the upper block; and VL(NL+2:M)
* contains the last components of all right singular vectors
* of the lower block. On exit, VL contains the last components
* of all right singular vectors of the bidiagonal matrix.
*
* VLW (workspace) DOUBLE PRECISION array, dimension ( M )
* Workspace for VL.
*
* ALPHA (input) DOUBLE PRECISION
* Contains the diagonal element associated with the added row.
*
* BETA (input) DOUBLE PRECISION
* Contains the off-diagonal element associated with the added
* row.
*
* DSIGMA (output) DOUBLE PRECISION array, dimension ( N )
* Contains a copy of the diagonal elements (K-1 singular values
* and one zero) in the secular equation.
*
* IDX (workspace) INTEGER array, dimension ( N )
* This will contain the permutation used to sort the contents of
* D into ascending order.
*
* IDXP (workspace) INTEGER array, dimension ( N )
* This will contain the permutation used to place deflated
* values of D at the end of the array. On output IDXP(2:K)
* points to the nondeflated D-values and IDXP(K+1:N)
* points to the deflated singular values.
*
* IDXQ (input) INTEGER array, dimension ( N )
* This contains the permutation which separately sorts the two
* sub-problems in D into ascending order. Note that entries in
* the first half of this permutation must first be moved one
* position backward; and entries in the second half
* must first have NL+1 added to their values.
*
* PERM (output) INTEGER array, dimension ( N )
* The permutations (from deflation and sorting) to be applied
* to each singular block. Not referenced if ICOMPQ = 0.
*
* GIVPTR (output) INTEGER
* The number of Givens rotations which took place in this
* subproblem. Not referenced if ICOMPQ = 0.
*
* GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )
* Each pair of numbers indicates a pair of columns to take place
* in a Givens rotation. Not referenced if ICOMPQ = 0.
*
* LDGCOL (input) INTEGER
* The leading dimension of GIVCOL, must be at least N.
*
* GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
* Each number indicates the C or S value to be used in the
* corresponding Givens rotation. Not referenced if ICOMPQ = 0.
*
* LDGNUM (input) INTEGER
* The leading dimension of GIVNUM, must be at least N.
*
* C (output) DOUBLE PRECISION
* C contains garbage if SQRE =0 and the C-value of a Givens
* rotation related to the right null space if SQRE = 1.
*
* S (output) DOUBLE PRECISION
* S contains garbage if SQRE =0 and the S-value of a Givens
* rotation related to the right null space if SQRE = 1.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, EIGHT
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0,
$ EIGHT = 8.0D+0 )
* ..
* .. Local Scalars ..
*
INTEGER I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M, N,
$ NLP1, NLP2
DOUBLE PRECISION EPS, HLFTOL, TAU, TOL, Z1
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLAMRG, DROT, XERBLA
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLAPY2
EXTERNAL DLAMCH, DLAPY2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
N = NL + NR + 1
M = N + SQRE
*
IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
INFO = -1
ELSE IF( NL.LT.1 ) THEN
INFO = -2
ELSE IF( NR.LT.1 ) THEN
INFO = -3
ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
INFO = -4
ELSE IF( LDGCOL.LT.N ) THEN
INFO = -22
ELSE IF( LDGNUM.LT.N ) THEN
INFO = -24
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLASD7', -INFO )
RETURN
END IF
*
NLP1 = NL + 1
NLP2 = NL + 2
IF( ICOMPQ.EQ.1 ) THEN
GIVPTR = 0
END IF
*
* Generate the first part of the vector Z and move the singular
* values in the first part of D one position backward.
*
Z1 = ALPHA*VL( NLP1 )
VL( NLP1 ) = ZERO
TAU = VF( NLP1 )
DO 10 I = NL, 1, -1
Z( I+1 ) = ALPHA*VL( I )
VL( I ) = ZERO
VF( I+1 ) = VF( I )
D( I+1 ) = D( I )
IDXQ( I+1 ) = IDXQ( I ) + 1
10 CONTINUE
VF( 1 ) = TAU
*
* Generate the second part of the vector Z.
*
DO 20 I = NLP2, M
Z( I ) = BETA*VF( I )
VF( I ) = ZERO
20 CONTINUE
*
* Sort the singular values into increasing order
*
DO 30 I = NLP2, N
IDXQ( I ) = IDXQ( I ) + NLP1
30 CONTINUE
*
* DSIGMA, IDXC, IDXC, and ZW are used as storage space.
*
DO 40 I = 2, N
DSIGMA( I ) = D( IDXQ( I ) )
ZW( I ) = Z( IDXQ( I ) )
VFW( I ) = VF( IDXQ( I ) )
VLW( I ) = VL( IDXQ( I ) )
40 CONTINUE
*
CALL DLAMRG( NL, NR, DSIGMA( 2 ), 1, 1, IDX( 2 ) )
*
DO 50 I = 2, N
IDXI = 1 + IDX( I )
D( I ) = DSIGMA( IDXI )
Z( I ) = ZW( IDXI )
VF( I ) = VFW( IDXI )
VL( I ) = VLW( IDXI )
50 CONTINUE
*
* Calculate the allowable deflation tolerence
*
EPS = DLAMCH( 'Epsilon' )
TOL = MAX( ABS( ALPHA ), ABS( BETA ) )
TOL = EIGHT*EIGHT*EPS*MAX( ABS( D( N ) ), TOL )
*
* There are 2 kinds of deflation -- first a value in the z-vector
* is small, second two (or more) singular values are very close
* together (their difference is small).
*
* If the value in the z-vector is small, we simply permute the
* array so that the corresponding singular value is moved to the
* end.
*
* If two values in the D-vector are close, we perform a two-sided
* rotation designed to make one of the corresponding z-vector
* entries zero, and then permute the array so that the deflated
* singular value is moved to the end.
*
* If there are multiple singular values then the problem deflates.
* Here the number of equal singular values are found. As each equal
* singular value is found, an elementary reflector is computed to
* rotate the corresponding singular subspace so that the
* corresponding components of Z are zero in this new basis.
*
K = 1
K2 = N + 1
DO 60 J = 2, N
IF( ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
IDXP( K2 ) = J
IF( J.EQ.N )
$ GO TO 100
ELSE
JPREV = J
GO TO 70
END IF
60 CONTINUE
70 CONTINUE
J = JPREV
80 CONTINUE
J = J + 1
IF( J.GT.N )
$ GO TO 90
IF( ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
IDXP( K2 ) = J
ELSE
*
* Check if singular values are close enough to allow deflation.
*
IF( ABS( D( J )-D( JPREV ) ).LE.TOL ) THEN
*
* Deflation is possible.
*
S = Z( JPREV )
C = Z( J )
*
* Find sqrt(a**2+b**2) without overflow or
* destructive underflow.
*
TAU = DLAPY2( C, S )
Z( J ) = TAU
Z( JPREV ) = ZERO
C = C / TAU
S = -S / TAU
*
* Record the appropriate Givens rotation
*
IF( ICOMPQ.EQ.1 ) THEN
GIVPTR = GIVPTR + 1
IDXJP = IDXQ( IDX( JPREV )+1 )
IDXJ = IDXQ( IDX( J )+1 )
IF( IDXJP.LE.NLP1 ) THEN
IDXJP = IDXJP - 1
END IF
IF( IDXJ.LE.NLP1 ) THEN
IDXJ = IDXJ - 1
END IF
GIVCOL( GIVPTR, 2 ) = IDXJP
GIVCOL( GIVPTR, 1 ) = IDXJ
GIVNUM( GIVPTR, 2 ) = C
GIVNUM( GIVPTR, 1 ) = S
END IF
CALL DROT( 1, VF( JPREV ), 1, VF( J ), 1, C, S )
CALL DROT( 1, VL( JPREV ), 1, VL( J ), 1, C, S )
K2 = K2 - 1
IDXP( K2 ) = JPREV
JPREV = J
ELSE
K = K + 1
ZW( K ) = Z( JPREV )
DSIGMA( K ) = D( JPREV )
IDXP( K ) = JPREV
JPREV = J
END IF
END IF
GO TO 80
90 CONTINUE
*
* Record the last singular value.
*
K = K + 1
ZW( K ) = Z( JPREV )
DSIGMA( K ) = D( JPREV )
IDXP( K ) = JPREV
*
100 CONTINUE
*
* Sort the singular values into DSIGMA. The singular values which
* were not deflated go into the first K slots of DSIGMA, except
* that DSIGMA(1) is treated separately.
*
DO 110 J = 2, N
JP = IDXP( J )
DSIGMA( J ) = D( JP )
VFW( J ) = VF( JP )
VLW( J ) = VL( JP )
110 CONTINUE
IF( ICOMPQ.EQ.1 ) THEN
DO 120 J = 2, N
JP = IDXP( J )
PERM( J ) = IDXQ( IDX( JP )+1 )
IF( PERM( J ).LE.NLP1 ) THEN
PERM( J ) = PERM( J ) - 1
END IF
120 CONTINUE
END IF
*
* The deflated singular values go back into the last N - K slots of
* D.
*
CALL DCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 )
*
* Determine DSIGMA(1), DSIGMA(2), Z(1), VF(1), VL(1), VF(M), and
* VL(M).
*
DSIGMA( 1 ) = ZERO
HLFTOL = TOL / TWO
IF( ABS( DSIGMA( 2 ) ).LE.HLFTOL )
$ DSIGMA( 2 ) = HLFTOL
IF( M.GT.N ) THEN
Z( 1 ) = DLAPY2( Z1, Z( M ) )
IF( Z( 1 ).LE.TOL ) THEN
C = ONE
S = ZERO
Z( 1 ) = TOL
ELSE
C = Z1 / Z( 1 )
S = -Z( M ) / Z( 1 )
END IF
CALL DROT( 1, VF( M ), 1, VF( 1 ), 1, C, S )
CALL DROT( 1, VL( M ), 1, VL( 1 ), 1, C, S )
ELSE
IF( ABS( Z1 ).LE.TOL ) THEN
Z( 1 ) = TOL
ELSE
Z( 1 ) = Z1
END IF
END IF
*
* Restore Z, VF, and VL.
*
CALL DCOPY( K-1, ZW( 2 ), 1, Z( 2 ), 1 )
CALL DCOPY( N-1, VFW( 2 ), 1, VF( 2 ), 1 )
CALL DCOPY( N-1, VLW( 2 ), 1, VL( 2 ), 1 )
*
RETURN
*
* End of DLASD7
*
END
SUBROUTINE DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR,
$ DSIGMA, WORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER ICOMPQ, INFO, K, LDDIFR
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), DIFL( * ), DIFR( LDDIFR, * ),
$ DSIGMA( * ), VF( * ), VL( * ), WORK( * ),
$ Z( * )
* ..
*
* Purpose
* =======
*
* DLASD8 finds the square roots of the roots of the secular equation,
* as defined by the values in DSIGMA and Z. It makes the appropriate
* calls to DLASD4, and stores, for each element in D, the distance
* to its two nearest poles (elements in DSIGMA). It also updates
* the arrays VF and VL, the first and last components of all the
* right singular vectors of the original bidiagonal matrix.
*
* DLASD8 is called from DLASD6.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* Specifies whether singular vectors are to be computed in
* factored form in the calling routine:
* = 0: Compute singular values only.
* = 1: Compute singular vectors in factored form as well.
*
* K (input) INTEGER
* The number of terms in the rational function to be solved
* by DLASD4. K >= 1.
*
* D (output) DOUBLE PRECISION array, dimension ( K )
* On output, D contains the updated singular values.
*
* Z (input) DOUBLE PRECISION array, dimension ( K )
* The first K elements of this array contain the components
* of the deflation-adjusted updating row vector.
*
* VF (input/output) DOUBLE PRECISION array, dimension ( K )
* On entry, VF contains information passed through DBEDE8.
* On exit, VF contains the first K components of the first
* components of all right singular vectors of the bidiagonal
* matrix.
*
* VL (input/output) DOUBLE PRECISION array, dimension ( K )
* On entry, VL contains information passed through DBEDE8.
* On exit, VL contains the first K components of the last
* components of all right singular vectors of the bidiagonal
* matrix.
*
* DIFL (output) DOUBLE PRECISION array, dimension ( K )
* On exit, DIFL(I) = D(I) - DSIGMA(I).
*
* DIFR (output) DOUBLE PRECISION array,
* dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and
* dimension ( K ) if ICOMPQ = 0.
* On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not
* defined and will not be referenced.
*
* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the
* normalizing factors for the right singular vector matrix.
*
* LDDIFR (input) INTEGER
* The leading dimension of DIFR, must be at least K.
*
* DSIGMA (input) DOUBLE PRECISION array, dimension ( K )
* The first K elements of this array contain the old roots
* of the deflated updating problem. These are the poles
* of the secular equation.
*
* WORK (workspace) DOUBLE PRECISION array, dimension at least 3 * K
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an singular value did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, IWK1, IWK2, IWK2I, IWK3, IWK3I, J
DOUBLE PRECISION DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, RHO, TEMP
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLASCL, DLASD4, DLASET, XERBLA
* ..
* .. External Functions ..
DOUBLE PRECISION DDOT, DLAMC3, DNRM2
EXTERNAL DDOT, DLAMC3, DNRM2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
INFO = -1
ELSE IF( K.LT.1 ) THEN
INFO = -2
ELSE IF( LDDIFR.LT.K ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLASD8', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( K.EQ.1 ) THEN
D( 1 ) = ABS( Z( 1 ) )
DIFL( 1 ) = D( 1 )
IF( ICOMPQ.EQ.1 ) THEN
DIFL( 2 ) = ONE
DIFR( 1, 2 ) = ONE
END IF
RETURN
END IF
*
* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can
* be computed with high relative accuracy (barring over/underflow).
* This is a problem on machines without a guard digit in
* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I),
* which on any of these machines zeros out the bottommost
* bit of DSIGMA(I) if it is 1; this makes the subsequent
* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation
* occurs. On binary machines with a guard digit (almost all
* machines) it does not change DSIGMA(I) at all. On hexadecimal
* and decimal machines with a guard digit, it slightly
* changes the bottommost bits of DSIGMA(I). It does not account
* for hexadecimal or decimal machines without guard digits
* (we know of none). We use a subroutine call to compute
* 2*DSIGMA(I) to prevent optimizing compilers from eliminating
* this code.
*
DO 10 I = 1, K
DSIGMA( I ) = DLAMC3( DSIGMA( I ), DSIGMA( I ) ) - DSIGMA( I )
10 CONTINUE
*
* Book keeping.
*
IWK1 = 1
IWK2 = IWK1 + K
IWK3 = IWK2 + K
IWK2I = IWK2 - 1
IWK3I = IWK3 - 1
*
* Normalize Z.
*
RHO = DNRM2( K, Z, 1 )
CALL DLASCL( 'G', 0, 0, RHO, ONE, K, 1, Z, K, INFO )
RHO = RHO*RHO
*
* Initialize WORK(IWK3).
*
CALL DLASET( 'A', K, 1, ONE, ONE, WORK( IWK3 ), K )
*
* Compute the updated singular values, the arrays DIFL, DIFR,
* and the updated Z.
*
DO 40 J = 1, K
CALL DLASD4( K, J, DSIGMA, Z, WORK( IWK1 ), RHO, D( J ),
$ WORK( IWK2 ), INFO )
*
* If the root finder fails, the computation is terminated.
*
IF( INFO.NE.0 ) THEN
RETURN
END IF
WORK( IWK3I+J ) = WORK( IWK3I+J )*WORK( J )*WORK( IWK2I+J )
DIFL( J ) = -WORK( J )
DIFR( J, 1 ) = -WORK( J+1 )
DO 20 I = 1, J - 1
WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )*
$ WORK( IWK2I+I ) / ( DSIGMA( I )-
$ DSIGMA( J ) ) / ( DSIGMA( I )+
$ DSIGMA( J ) )
20 CONTINUE
DO 30 I = J + 1, K
WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )*
$ WORK( IWK2I+I ) / ( DSIGMA( I )-
$ DSIGMA( J ) ) / ( DSIGMA( I )+
$ DSIGMA( J ) )
30 CONTINUE
40 CONTINUE
*
* Compute updated Z.
*
DO 50 I = 1, K
Z( I ) = SIGN( SQRT( ABS( WORK( IWK3I+I ) ) ), Z( I ) )
50 CONTINUE
*
* Update VF and VL.
*
DO 80 J = 1, K
DIFLJ = DIFL( J )
DJ = D( J )
DSIGJ = -DSIGMA( J )
IF( J.LT.K ) THEN
DIFRJ = -DIFR( J, 1 )
DSIGJP = -DSIGMA( J+1 )
END IF
WORK( J ) = -Z( J ) / DIFLJ / ( DSIGMA( J )+DJ )
DO 60 I = 1, J - 1
WORK( I ) = Z( I ) / ( DLAMC3( DSIGMA( I ), DSIGJ )-DIFLJ )
$ / ( DSIGMA( I )+DJ )
60 CONTINUE
DO 70 I = J + 1, K
WORK( I ) = Z( I ) / ( DLAMC3( DSIGMA( I ), DSIGJP )+DIFRJ )
$ / ( DSIGMA( I )+DJ )
70 CONTINUE
TEMP = DNRM2( K, WORK, 1 )
WORK( IWK2I+J ) = DDOT( K, WORK, 1, VF, 1 ) / TEMP
WORK( IWK3I+J ) = DDOT( K, WORK, 1, VL, 1 ) / TEMP
IF( ICOMPQ.EQ.1 ) THEN
DIFR( J, 2 ) = TEMP
END IF
80 CONTINUE
*
CALL DCOPY( K, WORK( IWK2 ), 1, VF, 1 )
CALL DCOPY( K, WORK( IWK3 ), 1, VL, 1 )
*
RETURN
*
* End of DLASD8
*
END
SUBROUTINE DLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K,
$ DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL,
$ PERM, GIVNUM, C, S, WORK, IWORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER ICOMPQ, INFO, LDGCOL, LDU, N, SMLSIZ, SQRE
* ..
* .. Array Arguments ..
INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ),
$ K( * ), PERM( LDGCOL, * )
DOUBLE PRECISION C( * ), D( * ), DIFL( LDU, * ), DIFR( LDU, * ),
$ E( * ), GIVNUM( LDU, * ), POLES( LDU, * ),
$ S( * ), U( LDU, * ), VT( LDU, * ), WORK( * ),
$ Z( LDU, * )
* ..
*
* Purpose
* =======
*
* Using a divide and conquer approach, DLASDA computes the singular
* value decomposition (SVD) of a real upper bidiagonal N-by-M matrix
* B with diagonal D and offdiagonal E, where M = N + SQRE. The
* algorithm computes the singular values in the SVD B = U * S * VT.
* The orthogonal matrices U and VT are optionally computed in
* compact form.
*
* A related subroutine, DLASD0, computes the singular values and
* the singular vectors in explicit form.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* Specifies whether singular vectors are to be computed
* in compact form, as follows
* = 0: Compute singular values only.
* = 1: Compute singular vectors of upper bidiagonal
* matrix in compact form.
*
* SMLSIZ (input) INTEGER
* The maximum size of the subproblems at the bottom of the
* computation tree.
*
* N (input) INTEGER
* The row dimension of the upper bidiagonal matrix. This is
* also the dimension of the main diagonal array D.
*
* SQRE (input) INTEGER
* Specifies the column dimension of the bidiagonal matrix.
* = 0: The bidiagonal matrix has column dimension M = N;
* = 1: The bidiagonal matrix has column dimension M = N + 1.
*
* D (input/output) DOUBLE PRECISION array, dimension ( N )
* On entry D contains the main diagonal of the bidiagonal
* matrix. On exit D, if INFO = 0, contains its singular values.
*
* E (input) DOUBLE PRECISION array, dimension ( M-1 )
* Contains the subdiagonal entries of the bidiagonal matrix.
* On exit, E has been destroyed.
*
* U (output) DOUBLE PRECISION array,
* dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced
* if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left
* singular vector matrices of all subproblems at the bottom
* level.
*
* LDU (input) INTEGER, LDU = > N.
* The leading dimension of arrays U, VT, DIFL, DIFR, POLES,
* GIVNUM, and Z.
*
* VT (output) DOUBLE PRECISION array,
* dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced
* if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT' contains the right
* singular vector matrices of all subproblems at the bottom
* level.
*
* K (output) INTEGER array,
* dimension ( N ) if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0.
* If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th
* secular equation on the computation tree.
*
* DIFL (output) DOUBLE PRECISION array, dimension ( LDU, NLVL ),
* where NLVL = floor(log_2 (N/SMLSIZ))).
*
* DIFR (output) DOUBLE PRECISION array,
* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and
* dimension ( N ) if ICOMPQ = 0.
* If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1)
* record distances between singular values on the I-th
* level and singular values on the (I -1)-th level, and
* DIFR(1:N, 2 * I ) contains the normalizing factors for
* the right singular vector matrix. See DLASD8 for details.
*
* Z (output) DOUBLE PRECISION array,
* dimension ( LDU, NLVL ) if ICOMPQ = 1 and
* dimension ( N ) if ICOMPQ = 0.
* The first K elements of Z(1, I) contain the components of
* the deflation-adjusted updating row vector for subproblems
* on the I-th level.
*
* POLES (output) DOUBLE PRECISION array,
* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced
* if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and
* POLES(1, 2*I) contain the new and old singular values
* involved in the secular equations on the I-th level.
*
* GIVPTR (output) INTEGER array,
* dimension ( N ) if ICOMPQ = 1, and not referenced if
* ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records
* the number of Givens rotations performed on the I-th
* problem on the computation tree.
*
* GIVCOL (output) INTEGER array,
* dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not
* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,
* GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations
* of Givens rotations performed on the I-th level on the
* computation tree.
*
* LDGCOL (input) INTEGER, LDGCOL = > N.
* The leading dimension of arrays GIVCOL and PERM.
*
* PERM (output) INTEGER array,
* dimension ( LDGCOL, NLVL ) if ICOMPQ = 1, and not referenced
* if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records
* permutations done on the I-th level of the computation tree.
*
* GIVNUM (output) DOUBLE PRECISION array,
* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not
* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,
* GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S-
* values of Givens rotations performed on the I-th level on
* the computation tree.
*
* C (output) DOUBLE PRECISION array,
* dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0.
* If ICOMPQ = 1 and the I-th subproblem is not square, on exit,
* C( I ) contains the C-value of a Givens rotation related to
* the right null space of the I-th subproblem.
*
* S (output) DOUBLE PRECISION array, dimension ( N ) if
* ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1
* and the I-th subproblem is not square, on exit, S( I )
* contains the S-value of a Givens rotation related to
* the right null space of the I-th subproblem.
*
* WORK (workspace) DOUBLE PRECISION array, dimension
* (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)).
*
* IWORK (workspace) INTEGER array.
* Dimension must be at least (7 * N).
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an singular value did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, I1, IC, IDXQ, IDXQI, IM1, INODE, ITEMP, IWK,
$ J, LF, LL, LVL, LVL2, M, NCC, ND, NDB1, NDIML,
$ NDIMR, NL, NLF, NLP1, NLVL, NR, NRF, NRP1, NRU,
$ NWORK1, NWORK2, SMLSZP, SQREI, VF, VFI, VL, VLI
DOUBLE PRECISION ALPHA, BETA
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLASD6, DLASDQ, DLASDT, DLASET, XERBLA
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
INFO = -1
ELSE IF( SMLSIZ.LT.3 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
INFO = -4
ELSE IF( LDU.LT.( N+SQRE ) ) THEN
INFO = -8
ELSE IF( LDGCOL.LT.N ) THEN
INFO = -17
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLASDA', -INFO )
RETURN
END IF
*
M = N + SQRE
*
* If the input matrix is too small, call DLASDQ to find the SVD.
*
IF( N.LE.SMLSIZ ) THEN
IF( ICOMPQ.EQ.0 ) THEN
CALL DLASDQ( 'U', SQRE, N, 0, 0, 0, D, E, VT, LDU, U, LDU,
$ U, LDU, WORK, INFO )
ELSE
CALL DLASDQ( 'U', SQRE, N, M, N, 0, D, E, VT, LDU, U, LDU,
$ U, LDU, WORK, INFO )
END IF
RETURN
END IF
*
* Book-keeping and set up the computation tree.
*
INODE = 1
NDIML = INODE + N
NDIMR = NDIML + N
IDXQ = NDIMR + N
IWK = IDXQ + N
*
NCC = 0
NRU = 0
*
SMLSZP = SMLSIZ + 1
VF = 1
VL = VF + M
NWORK1 = VL + M
NWORK2 = NWORK1 + SMLSZP*SMLSZP
*
CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ),
$ IWORK( NDIMR ), SMLSIZ )
*
* for the nodes on bottom level of the tree, solve
* their subproblems by DLASDQ.
*
NDB1 = ( ND+1 ) / 2
DO 30 I = NDB1, ND
*
* IC : center row of each node
* NL : number of rows of left subproblem
* NR : number of rows of right subproblem
* NLF: starting row of the left subproblem
* NRF: starting row of the right subproblem
*
I1 = I - 1
IC = IWORK( INODE+I1 )
NL = IWORK( NDIML+I1 )
NLP1 = NL + 1
NR = IWORK( NDIMR+I1 )
NLF = IC - NL
NRF = IC + 1
IDXQI = IDXQ + NLF - 2
VFI = VF + NLF - 1
VLI = VL + NLF - 1
SQREI = 1
IF( ICOMPQ.EQ.0 ) THEN
CALL DLASET( 'A', NLP1, NLP1, ZERO, ONE, WORK( NWORK1 ),
$ SMLSZP )
CALL DLASDQ( 'U', SQREI, NL, NLP1, NRU, NCC, D( NLF ),
$ E( NLF ), WORK( NWORK1 ), SMLSZP,
$ WORK( NWORK2 ), NL, WORK( NWORK2 ), NL,
$ WORK( NWORK2 ), INFO )
ITEMP = NWORK1 + NL*SMLSZP
CALL DCOPY( NLP1, WORK( NWORK1 ), 1, WORK( VFI ), 1 )
CALL DCOPY( NLP1, WORK( ITEMP ), 1, WORK( VLI ), 1 )
ELSE
CALL DLASET( 'A', NL, NL, ZERO, ONE, U( NLF, 1 ), LDU )
CALL DLASET( 'A', NLP1, NLP1, ZERO, ONE, VT( NLF, 1 ), LDU )
CALL DLASDQ( 'U', SQREI, NL, NLP1, NL, NCC, D( NLF ),
$ E( NLF ), VT( NLF, 1 ), LDU, U( NLF, 1 ), LDU,
$ U( NLF, 1 ), LDU, WORK( NWORK1 ), INFO )
CALL DCOPY( NLP1, VT( NLF, 1 ), 1, WORK( VFI ), 1 )
CALL DCOPY( NLP1, VT( NLF, NLP1 ), 1, WORK( VLI ), 1 )
END IF
IF( INFO.NE.0 ) THEN
RETURN
END IF
DO 10 J = 1, NL
IWORK( IDXQI+J ) = J
10 CONTINUE
IF( ( I.EQ.ND ) .AND. ( SQRE.EQ.0 ) ) THEN
SQREI = 0
ELSE
SQREI = 1
END IF
IDXQI = IDXQI + NLP1
VFI = VFI + NLP1
VLI = VLI + NLP1
NRP1 = NR + SQREI
IF( ICOMPQ.EQ.0 ) THEN
CALL DLASET( 'A', NRP1, NRP1, ZERO, ONE, WORK( NWORK1 ),
$ SMLSZP )
CALL DLASDQ( 'U', SQREI, NR, NRP1, NRU, NCC, D( NRF ),
$ E( NRF ), WORK( NWORK1 ), SMLSZP,
$ WORK( NWORK2 ), NR, WORK( NWORK2 ), NR,
$ WORK( NWORK2 ), INFO )
ITEMP = NWORK1 + ( NRP1-1 )*SMLSZP
CALL DCOPY( NRP1, WORK( NWORK1 ), 1, WORK( VFI ), 1 )
CALL DCOPY( NRP1, WORK( ITEMP ), 1, WORK( VLI ), 1 )
ELSE
CALL DLASET( 'A', NR, NR, ZERO, ONE, U( NRF, 1 ), LDU )
CALL DLASET( 'A', NRP1, NRP1, ZERO, ONE, VT( NRF, 1 ), LDU )
CALL DLASDQ( 'U', SQREI, NR, NRP1, NR, NCC, D( NRF ),
$ E( NRF ), VT( NRF, 1 ), LDU, U( NRF, 1 ), LDU,
$ U( NRF, 1 ), LDU, WORK( NWORK1 ), INFO )
CALL DCOPY( NRP1, VT( NRF, 1 ), 1, WORK( VFI ), 1 )
CALL DCOPY( NRP1, VT( NRF, NRP1 ), 1, WORK( VLI ), 1 )
END IF
IF( INFO.NE.0 ) THEN
RETURN
END IF
DO 20 J = 1, NR
IWORK( IDXQI+J ) = J
20 CONTINUE
30 CONTINUE
*
* Now conquer each subproblem bottom-up.
*
J = 2**NLVL
DO 50 LVL = NLVL, 1, -1
LVL2 = LVL*2 - 1
*
* Find the first node LF and last node LL on
* the current level LVL.
*
IF( LVL.EQ.1 ) THEN
LF = 1
LL = 1
ELSE
LF = 2**( LVL-1 )
LL = 2*LF - 1
END IF
DO 40 I = LF, LL
IM1 = I - 1
IC = IWORK( INODE+IM1 )
NL = IWORK( NDIML+IM1 )
NR = IWORK( NDIMR+IM1 )
NLF = IC - NL
NRF = IC + 1
IF( I.EQ.LL ) THEN
SQREI = SQRE
ELSE
SQREI = 1
END IF
VFI = VF + NLF - 1
VLI = VL + NLF - 1
IDXQI = IDXQ + NLF - 1
ALPHA = D( IC )
BETA = E( IC )
IF( ICOMPQ.EQ.0 ) THEN
CALL DLASD6( ICOMPQ, NL, NR, SQREI, D( NLF ),
$ WORK( VFI ), WORK( VLI ), ALPHA, BETA,
$ IWORK( IDXQI ), PERM, GIVPTR( 1 ), GIVCOL,
$ LDGCOL, GIVNUM, LDU, POLES, DIFL, DIFR, Z,
$ K( 1 ), C( 1 ), S( 1 ), WORK( NWORK1 ),
$ IWORK( IWK ), INFO )
ELSE
J = J - 1
CALL DLASD6( ICOMPQ, NL, NR, SQREI, D( NLF ),
$ WORK( VFI ), WORK( VLI ), ALPHA, BETA,
$ IWORK( IDXQI ), PERM( NLF, LVL ),
$ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
$ GIVNUM( NLF, LVL2 ), LDU,
$ POLES( NLF, LVL2 ), DIFL( NLF, LVL ),
$ DIFR( NLF, LVL2 ), Z( NLF, LVL ), K( J ),
$ C( J ), S( J ), WORK( NWORK1 ),
$ IWORK( IWK ), INFO )
END IF
IF( INFO.NE.0 ) THEN
RETURN
END IF
40 CONTINUE
50 CONTINUE
*
RETURN
*
* End of DLASDA
*
END
SUBROUTINE DLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT,
$ U, LDU, C, LDC, WORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU, SQRE
* ..
* .. Array Arguments ..
DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ),
$ VT( LDVT, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLASDQ computes the singular value decomposition (SVD) of a real
* (upper or lower) bidiagonal matrix with diagonal D and offdiagonal
* E, accumulating the transformations if desired. Letting B denote
* the input bidiagonal matrix, the algorithm computes orthogonal
* matrices Q and P such that B = Q * S * P' (P' denotes the transpose
* of P). The singular values S are overwritten on D.
*
* The input matrix U is changed to U * Q if desired.
* The input matrix VT is changed to P' * VT if desired.
* The input matrix C is changed to Q' * C if desired.
*
* See "Computing Small Singular Values of Bidiagonal Matrices With
* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
* LAPACK Working Note #3, for a detailed description of the algorithm.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* On entry, UPLO specifies whether the input bidiagonal matrix
* is upper or lower bidiagonal, and wether it is square are
* not.
* UPLO = 'U' or 'u' B is upper bidiagonal.
* UPLO = 'L' or 'l' B is lower bidiagonal.
*
* SQRE (input) INTEGER
* = 0: then the input matrix is N-by-N.
* = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and
* (N+1)-by-N if UPLU = 'L'.
*
* The bidiagonal matrix has
* N = NL + NR + 1 rows and
* M = N + SQRE >= N columns.
*
* N (input) INTEGER
* On entry, N specifies the number of rows and columns
* in the matrix. N must be at least 0.
*
* NCVT (input) INTEGER
* On entry, NCVT specifies the number of columns of
* the matrix VT. NCVT must be at least 0.
*
* NRU (input) INTEGER
* On entry, NRU specifies the number of rows of
* the matrix U. NRU must be at least 0.
*
* NCC (input) INTEGER
* On entry, NCC specifies the number of columns of
* the matrix C. NCC must be at least 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, D contains the diagonal entries of the
* bidiagonal matrix whose SVD is desired. On normal exit,
* D contains the singular values in ascending order.
*
* E (input/output) DOUBLE PRECISION array.
* dimension is (N-1) if SQRE = 0 and N if SQRE = 1.
* On entry, the entries of E contain the offdiagonal entries
* of the bidiagonal matrix whose SVD is desired. On normal
* exit, E will contain 0. If the algorithm does not converge,
* D and E will contain the diagonal and superdiagonal entries
* of a bidiagonal matrix orthogonally equivalent to the one
* given as input.
*
* VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT)
* On entry, contains a matrix which on exit has been
* premultiplied by P', dimension N-by-NCVT if SQRE = 0
* and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0).
*
* LDVT (input) INTEGER
* On entry, LDVT specifies the leading dimension of VT as
* declared in the calling (sub) program. LDVT must be at
* least 1. If NCVT is nonzero LDVT must also be at least N.
*
* U (input/output) DOUBLE PRECISION array, dimension (LDU, N)
* On entry, contains a matrix which on exit has been
* postmultiplied by Q, dimension NRU-by-N if SQRE = 0
* and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0).
*
* LDU (input) INTEGER
* On entry, LDU specifies the leading dimension of U as
* declared in the calling (sub) program. LDU must be at
* least max( 1, NRU ) .
*
* C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC)
* On entry, contains an N-by-NCC matrix which on exit
* has been premultiplied by Q' dimension N-by-NCC if SQRE = 0
* and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0).
*
* LDC (input) INTEGER
* On entry, LDC specifies the leading dimension of C as
* declared in the calling (sub) program. LDC must be at
* least 1. If NCC is nonzero, LDC must also be at least N.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
* Workspace. Only referenced if one of NCVT, NRU, or NCC is
* nonzero, and if N is at least 2.
*
* INFO (output) INTEGER
* On exit, a value of 0 indicates a successful exit.
* If INFO < 0, argument number -INFO is illegal.
* If INFO > 0, the algorithm did not converge, and INFO
* specifies how many superdiagonals did not converge.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL ROTATE
INTEGER I, ISUB, IUPLO, J, NP1, SQRE1
DOUBLE PRECISION CS, R, SMIN, SN
* ..
* .. External Subroutines ..
EXTERNAL DBDSQR, DLARTG, DLASR, DSWAP, XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IUPLO = 0
IF( LSAME( UPLO, 'U' ) )
$ IUPLO = 1
IF( LSAME( UPLO, 'L' ) )
$ IUPLO = 2
IF( IUPLO.EQ.0 ) THEN
INFO = -1
ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NCVT.LT.0 ) THEN
INFO = -4
ELSE IF( NRU.LT.0 ) THEN
INFO = -5
ELSE IF( NCC.LT.0 ) THEN
INFO = -6
ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR.
$ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN
INFO = -10
ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN
INFO = -12
ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR.
$ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN
INFO = -14
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLASDQ', -INFO )
RETURN
END IF
IF( N.EQ.0 )
$ RETURN
*
* ROTATE is true if any singular vectors desired, false otherwise
*
ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 )
NP1 = N + 1
SQRE1 = SQRE
*
* If matrix non-square upper bidiagonal, rotate to be lower
* bidiagonal. The rotations are on the right.
*
IF( ( IUPLO.EQ.1 ) .AND. ( SQRE1.EQ.1 ) ) THEN
DO 10 I = 1, N - 1
CALL DLARTG( D( I ), E( I ), CS, SN, R )
D( I ) = R
E( I ) = SN*D( I+1 )
D( I+1 ) = CS*D( I+1 )
IF( ROTATE ) THEN
WORK( I ) = CS
WORK( N+I ) = SN
END IF
10 CONTINUE
CALL DLARTG( D( N ), E( N ), CS, SN, R )
D( N ) = R
E( N ) = ZERO
IF( ROTATE ) THEN
WORK( N ) = CS
WORK( N+N ) = SN
END IF
IUPLO = 2
SQRE1 = 0
*
* Update singular vectors if desired.
*
IF( NCVT.GT.0 )
$ CALL DLASR( 'L', 'V', 'F', NP1, NCVT, WORK( 1 ),
$ WORK( NP1 ), VT, LDVT )
END IF
*
* If matrix lower bidiagonal, rotate to be upper bidiagonal
* by applying Givens rotations on the left.
*
IF( IUPLO.EQ.2 ) THEN
DO 20 I = 1, N - 1
CALL DLARTG( D( I ), E( I ), CS, SN, R )
D( I ) = R
E( I ) = SN*D( I+1 )
D( I+1 ) = CS*D( I+1 )
IF( ROTATE ) THEN
WORK( I ) = CS
WORK( N+I ) = SN
END IF
20 CONTINUE
*
* If matrix (N+1)-by-N lower bidiagonal, one additional
* rotation is needed.
*
IF( SQRE1.EQ.1 ) THEN
CALL DLARTG( D( N ), E( N ), CS, SN, R )
D( N ) = R
IF( ROTATE ) THEN
WORK( N ) = CS
WORK( N+N ) = SN
END IF
END IF
*
* Update singular vectors if desired.
*
IF( NRU.GT.0 ) THEN
IF( SQRE1.EQ.0 ) THEN
CALL DLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ),
$ WORK( NP1 ), U, LDU )
ELSE
CALL DLASR( 'R', 'V', 'F', NRU, NP1, WORK( 1 ),
$ WORK( NP1 ), U, LDU )
END IF
END IF
IF( NCC.GT.0 ) THEN
IF( SQRE1.EQ.0 ) THEN
CALL DLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ),
$ WORK( NP1 ), C, LDC )
ELSE
CALL DLASR( 'L', 'V', 'F', NP1, NCC, WORK( 1 ),
$ WORK( NP1 ), C, LDC )
END IF
END IF
END IF
*
* Call DBDSQR to compute the SVD of the reduced real
* N-by-N upper bidiagonal matrix.
*
CALL DBDSQR( 'U', N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C,
$ LDC, WORK, INFO )
*
* Sort the singular values into ascending order (insertion sort on
* singular values, but only one transposition per singular vector)
*
DO 40 I = 1, N
*
* Scan for smallest D(I).
*
ISUB = I
SMIN = D( I )
DO 30 J = I + 1, N
IF( D( J ).LT.SMIN ) THEN
ISUB = J
SMIN = D( J )
END IF
30 CONTINUE
IF( ISUB.NE.I ) THEN
*
* Swap singular values and vectors.
*
D( ISUB ) = D( I )
D( I ) = SMIN
IF( NCVT.GT.0 )
$ CALL DSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( I, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL DSWAP( NRU, U( 1, ISUB ), 1, U( 1, I ), 1 )
IF( NCC.GT.0 )
$ CALL DSWAP( NCC, C( ISUB, 1 ), LDC, C( I, 1 ), LDC )
END IF
40 CONTINUE
*
RETURN
*
* End of DLASDQ
*
END
SUBROUTINE DLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LVL, MSUB, N, ND
* ..
* .. Array Arguments ..
INTEGER INODE( * ), NDIML( * ), NDIMR( * )
* ..
*
* Purpose
* =======
*
* DLASDT creates a tree of subproblems for bidiagonal divide and
* conquer.
*
* Arguments
* =========
*
* N (input) INTEGER
* On entry, the number of diagonal elements of the
* bidiagonal matrix.
*
* LVL (output) INTEGER
* On exit, the number of levels on the computation tree.
*
* ND (output) INTEGER
* On exit, the number of nodes on the tree.
*
* INODE (output) INTEGER array, dimension ( N )
* On exit, centers of subproblems.
*
* NDIML (output) INTEGER array, dimension ( N )
* On exit, row dimensions of left children.
*
* NDIMR (output) INTEGER array, dimension ( N )
* On exit, row dimensions of right children.
*
* MSUB (input) INTEGER.
* On entry, the maximum row dimension each subproblem at the
* bottom of the tree can be of.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, IL, IR, LLST, MAXN, NCRNT, NLVL
DOUBLE PRECISION TEMP
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, INT, LOG, MAX
* ..
* .. Executable Statements ..
*
* Find the number of levels on the tree.
*
MAXN = MAX( 1, N )
TEMP = LOG( DBLE( MAXN ) / DBLE( MSUB+1 ) ) / LOG( TWO )
LVL = INT( TEMP ) + 1
*
I = N / 2
INODE( 1 ) = I + 1
NDIML( 1 ) = I
NDIMR( 1 ) = N - I - 1
IL = 0
IR = 1
LLST = 1
DO 20 NLVL = 1, LVL - 1
*
* Constructing the tree at (NLVL+1)-st level. The number of
* nodes created on this level is LLST * 2.
*
DO 10 I = 0, LLST - 1
IL = IL + 2
IR = IR + 2
NCRNT = LLST + I
NDIML( IL ) = NDIML( NCRNT ) / 2
NDIMR( IL ) = NDIML( NCRNT ) - NDIML( IL ) - 1
INODE( IL ) = INODE( NCRNT ) - NDIMR( IL ) - 1
NDIML( IR ) = NDIMR( NCRNT ) / 2
NDIMR( IR ) = NDIMR( NCRNT ) - NDIML( IR ) - 1
INODE( IR ) = INODE( NCRNT ) + NDIML( IR ) + 1
10 CONTINUE
LLST = LLST*2
20 CONTINUE
ND = LLST*2 - 1
*
RETURN
*
* End of DLASDT
*
END
SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDA, M, N
DOUBLE PRECISION ALPHA, BETA
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
* ..
*
* Purpose
* =======
*
* DLASET initializes an m-by-n matrix A to BETA on the diagonal and
* ALPHA on the offdiagonals.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies the part of the matrix A to be set.
* = 'U': Upper triangular part is set; the strictly lower
* triangular part of A is not changed.
* = 'L': Lower triangular part is set; the strictly upper
* triangular part of A is not changed.
* Otherwise: All of the matrix A is set.
*
* 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.
*
* ALPHA (input) DOUBLE PRECISION
* The constant to which the offdiagonal elements are to be set.
*
* BETA (input) DOUBLE PRECISION
* The constant to which the diagonal elements are to be set.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On exit, the leading m-by-n submatrix of A is set as follows:
*
* if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n,
* if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n,
* otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j,
*
* and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n).
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Set the strictly upper triangular or trapezoidal part of the
* array to ALPHA.
*
DO 20 J = 2, N
DO 10 I = 1, MIN( J-1, M )
A( I, J ) = ALPHA
10 CONTINUE
20 CONTINUE
*
ELSE IF( LSAME( UPLO, 'L' ) ) THEN
*
* Set the strictly lower triangular or trapezoidal part of the
* array to ALPHA.
*
DO 40 J = 1, MIN( M, N )
DO 30 I = J + 1, M
A( I, J ) = ALPHA
30 CONTINUE
40 CONTINUE
*
ELSE
*
* Set the leading m-by-n submatrix to ALPHA.
*
DO 60 J = 1, N
DO 50 I = 1, M
A( I, J ) = ALPHA
50 CONTINUE
60 CONTINUE
END IF
*
* Set the first min(M,N) diagonal elements to BETA.
*
DO 70 I = 1, MIN( M, N )
A( I, I ) = BETA
70 CONTINUE
*
RETURN
*
* End of DLASET
*
END
SUBROUTINE DLASQ1( N, D, E, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLASQ1 computes the singular values of a real N-by-N bidiagonal
* matrix with diagonal D and off-diagonal E. The singular values
* are computed to high relative accuracy, in the absence of
* denormalization, underflow and overflow. The algorithm was first
* presented in
*
* "Accurate singular values and differential qd algorithms" by K. V.
* Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230,
* 1994,
*
* and the present implementation is described in "An implementation of
* the dqds Algorithm (Positive Case)", LAPACK Working Note.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of rows and columns in the matrix. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, D contains the diagonal elements of the
* bidiagonal matrix whose SVD is desired. On normal exit,
* D contains the singular values in decreasing order.
*
* E (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, elements E(1:N-1) contain the off-diagonal elements
* of the bidiagonal matrix whose SVD is desired.
* On exit, E is overwritten.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: the algorithm failed
* = 1, a split was marked by a positive value in E
* = 2, current block of Z not diagonalized after 30*N
* iterations (in inner while loop)
* = 3, termination criterion of outer while loop not met
* (program created more than N unreduced blocks)
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, IINFO
DOUBLE PRECISION EPS, SCALE, SAFMIN, SIGMN, SIGMX
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLAS2, DLASCL, DLASQ2, DLASRT, XERBLA
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -2
CALL XERBLA( 'DLASQ1', -INFO )
RETURN
ELSE IF( N.EQ.0 ) THEN
RETURN
ELSE IF( N.EQ.1 ) THEN
D( 1 ) = ABS( D( 1 ) )
RETURN
ELSE IF( N.EQ.2 ) THEN
CALL DLAS2( D( 1 ), E( 1 ), D( 2 ), SIGMN, SIGMX )
D( 1 ) = SIGMX
D( 2 ) = SIGMN
RETURN
END IF
*
* Estimate the largest singular value.
*
SIGMX = ZERO
DO 10 I = 1, N - 1
D( I ) = ABS( D( I ) )
SIGMX = MAX( SIGMX, ABS( E( I ) ) )
10 CONTINUE
D( N ) = ABS( D( N ) )
*
* Early return if SIGMX is zero (matrix is already diagonal).
*
IF( SIGMX.EQ.ZERO ) THEN
CALL DLASRT( 'D', N, D, IINFO )
RETURN
END IF
*
DO 20 I = 1, N
SIGMX = MAX( SIGMX, D( I ) )
20 CONTINUE
*
* Copy D and E into WORK (in the Z format) and scale (squaring the
* input data makes scaling by a power of the radix pointless).
*
EPS = DLAMCH( 'Precision' )
SAFMIN = DLAMCH( 'Safe minimum' )
SCALE = SQRT( EPS / SAFMIN )
CALL DCOPY( N, D, 1, WORK( 1 ), 2 )
CALL DCOPY( N-1, E, 1, WORK( 2 ), 2 )
CALL DLASCL( 'G', 0, 0, SIGMX, SCALE, 2*N-1, 1, WORK, 2*N-1,
$ IINFO )
*
* Compute the q's and e's.
*
DO 30 I = 1, 2*N - 1
WORK( I ) = WORK( I )**2
30 CONTINUE
WORK( 2*N ) = ZERO
*
CALL DLASQ2( N, WORK, INFO )
*
IF( INFO.EQ.0 ) THEN
DO 40 I = 1, N
D( I ) = SQRT( WORK( I ) )
40 CONTINUE
CALL DLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, D, N, IINFO )
END IF
*
RETURN
*
* End of DLASQ1
*
END
SUBROUTINE DLASQ2( N, Z, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call DLAZQ3 in place of DLASQ3, 13 Feb 03, SJH.
*
* .. Scalar Arguments ..
INTEGER INFO, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION Z( * )
* ..
*
* Purpose
* =======
*
* DLASQ2 computes all the eigenvalues of the symmetric positive
* definite tridiagonal matrix associated with the qd array Z to high
* relative accuracy are computed to high relative accuracy, in the
* absence of denormalization, underflow and overflow.
*
* To see the relation of Z to the tridiagonal matrix, let L be a
* unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and
* let U be an upper bidiagonal matrix with 1's above and diagonal
* Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the
* symmetric tridiagonal to which it is similar.
*
* Note : DLASQ2 defines a logical variable, IEEE, which is true
* on machines which follow ieee-754 floating-point standard in their
* handling of infinities and NaNs, and false otherwise. This variable
* is passed to DLAZQ3.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of rows and columns in the matrix. N >= 0.
*
* Z (workspace) DOUBLE PRECISION array, dimension ( 4*N )
* On entry Z holds the qd array. On exit, entries 1 to N hold
* the eigenvalues in decreasing order, Z( 2*N+1 ) holds the
* trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If
* N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 )
* holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of
* shifts that failed.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if the i-th argument is a scalar and had an illegal
* value, then INFO = -i, if the i-th argument is an
* array and the j-entry had an illegal value, then
* INFO = -(i*100+j)
* > 0: the algorithm failed
* = 1, a split was marked by a positive value in E
* = 2, current block of Z not diagonalized after 30*N
* iterations (in inner while loop)
* = 3, termination criterion of outer while loop not met
* (program created more than N unreduced blocks)
*
* Further Details
* ===============
* Local Variables: I0:N0 defines a current unreduced segment of Z.
* The shifts are accumulated in SIGMA. Iteration count is in ITER.
* Ping-pong is controlled by PP (alternates between 0 and 1).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION CBIAS
PARAMETER ( CBIAS = 1.50D0 )
DOUBLE PRECISION ZERO, HALF, ONE, TWO, FOUR, HUNDRD
PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0,
$ TWO = 2.0D0, FOUR = 4.0D0, HUNDRD = 100.0D0 )
* ..
* .. Local Scalars ..
LOGICAL IEEE
INTEGER I0, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, K,
$ N0, NBIG, NDIV, NFAIL, PP, SPLT, TTYPE
DOUBLE PRECISION D, DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, E,
$ EMAX, EMIN, EPS, OLDEMN, QMAX, QMIN, S, SAFMIN,
$ SIGMA, T, TAU, TEMP, TOL, TOL2, TRACE, ZMAX
* ..
* .. External Subroutines ..
EXTERNAL DLAZQ3, DLASRT, XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH, ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input arguments.
* (in case DLASQ2 is not called by DLASQ1)
*
INFO = 0
EPS = DLAMCH( 'Precision' )
SAFMIN = DLAMCH( 'Safe minimum' )
TOL = EPS*HUNDRD
TOL2 = TOL**2
*
IF( N.LT.0 ) THEN
INFO = -1
CALL XERBLA( 'DLASQ2', 1 )
RETURN
ELSE IF( N.EQ.0 ) THEN
RETURN
ELSE IF( N.EQ.1 ) THEN
*
* 1-by-1 case.
*
IF( Z( 1 ).LT.ZERO ) THEN
INFO = -201
CALL XERBLA( 'DLASQ2', 2 )
END IF
RETURN
ELSE IF( N.EQ.2 ) THEN
*
* 2-by-2 case.
*
IF( Z( 2 ).LT.ZERO .OR. Z( 3 ).LT.ZERO ) THEN
INFO = -2
CALL XERBLA( 'DLASQ2', 2 )
RETURN
ELSE IF( Z( 3 ).GT.Z( 1 ) ) THEN
D = Z( 3 )
Z( 3 ) = Z( 1 )
Z( 1 ) = D
END IF
Z( 5 ) = Z( 1 ) + Z( 2 ) + Z( 3 )
IF( Z( 2 ).GT.Z( 3 )*TOL2 ) THEN
T = HALF*( ( Z( 1 )-Z( 3 ) )+Z( 2 ) )
S = Z( 3 )*( Z( 2 ) / T )
IF( S.LE.T ) THEN
S = Z( 3 )*( Z( 2 ) / ( T*( ONE+SQRT( ONE+S / T ) ) ) )
ELSE
S = Z( 3 )*( Z( 2 ) / ( T+SQRT( T )*SQRT( T+S ) ) )
END IF
T = Z( 1 ) + ( S+Z( 2 ) )
Z( 3 ) = Z( 3 )*( Z( 1 ) / T )
Z( 1 ) = T
END IF
Z( 2 ) = Z( 3 )
Z( 6 ) = Z( 2 ) + Z( 1 )
RETURN
END IF
*
* Check for negative data and compute sums of q's and e's.
*
Z( 2*N ) = ZERO
EMIN = Z( 2 )
QMAX = ZERO
ZMAX = ZERO
D = ZERO
E = ZERO
*
DO 10 K = 1, 2*( N-1 ), 2
IF( Z( K ).LT.ZERO ) THEN
INFO = -( 200+K )
CALL XERBLA( 'DLASQ2', 2 )
RETURN
ELSE IF( Z( K+1 ).LT.ZERO ) THEN
INFO = -( 200+K+1 )
CALL XERBLA( 'DLASQ2', 2 )
RETURN
END IF
D = D + Z( K )
E = E + Z( K+1 )
QMAX = MAX( QMAX, Z( K ) )
EMIN = MIN( EMIN, Z( K+1 ) )
ZMAX = MAX( QMAX, ZMAX, Z( K+1 ) )
10 CONTINUE
IF( Z( 2*N-1 ).LT.ZERO ) THEN
INFO = -( 200+2*N-1 )
CALL XERBLA( 'DLASQ2', 2 )
RETURN
END IF
D = D + Z( 2*N-1 )
QMAX = MAX( QMAX, Z( 2*N-1 ) )
ZMAX = MAX( QMAX, ZMAX )
*
* Check for diagonality.
*
IF( E.EQ.ZERO ) THEN
DO 20 K = 2, N
Z( K ) = Z( 2*K-1 )
20 CONTINUE
CALL DLASRT( 'D', N, Z, IINFO )
Z( 2*N-1 ) = D
RETURN
END IF
*
TRACE = D + E
*
* Check for zero data.
*
IF( TRACE.EQ.ZERO ) THEN
Z( 2*N-1 ) = ZERO
RETURN
END IF
*
* Check whether the machine is IEEE conformable.
*
IEEE = ILAENV( 10, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 .AND.
$ ILAENV( 11, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1
*
* Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...).
*
DO 30 K = 2*N, 2, -2
Z( 2*K ) = ZERO
Z( 2*K-1 ) = Z( K )
Z( 2*K-2 ) = ZERO
Z( 2*K-3 ) = Z( K-1 )
30 CONTINUE
*
I0 = 1
N0 = N
*
* Reverse the qd-array, if warranted.
*
IF( CBIAS*Z( 4*I0-3 ).LT.Z( 4*N0-3 ) ) THEN
IPN4 = 4*( I0+N0 )
DO 40 I4 = 4*I0, 2*( I0+N0-1 ), 4
TEMP = Z( I4-3 )
Z( I4-3 ) = Z( IPN4-I4-3 )
Z( IPN4-I4-3 ) = TEMP
TEMP = Z( I4-1 )
Z( I4-1 ) = Z( IPN4-I4-5 )
Z( IPN4-I4-5 ) = TEMP
40 CONTINUE
END IF
*
* Initial split checking via dqd and Li's test.
*
PP = 0
*
DO 80 K = 1, 2
*
D = Z( 4*N0+PP-3 )
DO 50 I4 = 4*( N0-1 ) + PP, 4*I0 + PP, -4
IF( Z( I4-1 ).LE.TOL2*D ) THEN
Z( I4-1 ) = -ZERO
D = Z( I4-3 )
ELSE
D = Z( I4-3 )*( D / ( D+Z( I4-1 ) ) )
END IF
50 CONTINUE
*
* dqd maps Z to ZZ plus Li's test.
*
EMIN = Z( 4*I0+PP+1 )
D = Z( 4*I0+PP-3 )
DO 60 I4 = 4*I0 + PP, 4*( N0-1 ) + PP, 4
Z( I4-2*PP-2 ) = D + Z( I4-1 )
IF( Z( I4-1 ).LE.TOL2*D ) THEN
Z( I4-1 ) = -ZERO
Z( I4-2*PP-2 ) = D
Z( I4-2*PP ) = ZERO
D = Z( I4+1 )
ELSE IF( SAFMIN*Z( I4+1 ).LT.Z( I4-2*PP-2 ) .AND.
$ SAFMIN*Z( I4-2*PP-2 ).LT.Z( I4+1 ) ) THEN
TEMP = Z( I4+1 ) / Z( I4-2*PP-2 )
Z( I4-2*PP ) = Z( I4-1 )*TEMP
D = D*TEMP
ELSE
Z( I4-2*PP ) = Z( I4+1 )*( Z( I4-1 ) / Z( I4-2*PP-2 ) )
D = Z( I4+1 )*( D / Z( I4-2*PP-2 ) )
END IF
EMIN = MIN( EMIN, Z( I4-2*PP ) )
60 CONTINUE
Z( 4*N0-PP-2 ) = D
*
* Now find qmax.
*
QMAX = Z( 4*I0-PP-2 )
DO 70 I4 = 4*I0 - PP + 2, 4*N0 - PP - 2, 4
QMAX = MAX( QMAX, Z( I4 ) )
70 CONTINUE
*
* Prepare for the next iteration on K.
*
PP = 1 - PP
80 CONTINUE
*
* Initialise variables to pass to DLAZQ3
*
TTYPE = 0
DMIN1 = ZERO
DMIN2 = ZERO
DN = ZERO
DN1 = ZERO
DN2 = ZERO
TAU = ZERO
*
ITER = 2
NFAIL = 0
NDIV = 2*( N0-I0 )
*
DO 140 IWHILA = 1, N + 1
IF( N0.LT.1 )
$ GO TO 150
*
* While array unfinished do
*
* E(N0) holds the value of SIGMA when submatrix in I0:N0
* splits from the rest of the array, but is negated.
*
DESIG = ZERO
IF( N0.EQ.N ) THEN
SIGMA = ZERO
ELSE
SIGMA = -Z( 4*N0-1 )
END IF
IF( SIGMA.LT.ZERO ) THEN
INFO = 1
RETURN
END IF
*
* Find last unreduced submatrix's top index I0, find QMAX and
* EMIN. Find Gershgorin-type bound if Q's much greater than E's.
*
EMAX = ZERO
IF( N0.GT.I0 ) THEN
EMIN = ABS( Z( 4*N0-5 ) )
ELSE
EMIN = ZERO
END IF
QMIN = Z( 4*N0-3 )
QMAX = QMIN
DO 90 I4 = 4*N0, 8, -4
IF( Z( I4-5 ).LE.ZERO )
$ GO TO 100
IF( QMIN.GE.FOUR*EMAX ) THEN
QMIN = MIN( QMIN, Z( I4-3 ) )
EMAX = MAX( EMAX, Z( I4-5 ) )
END IF
QMAX = MAX( QMAX, Z( I4-7 )+Z( I4-5 ) )
EMIN = MIN( EMIN, Z( I4-5 ) )
90 CONTINUE
I4 = 4
*
100 CONTINUE
I0 = I4 / 4
*
* Store EMIN for passing to DLAZQ3.
*
Z( 4*N0-1 ) = EMIN
*
* Put -(initial shift) into DMIN.
*
DMIN = -MAX( ZERO, QMIN-TWO*SQRT( QMIN )*SQRT( EMAX ) )
*
* Now I0:N0 is unreduced. PP = 0 for ping, PP = 1 for pong.
*
PP = 0
*
NBIG = 30*( N0-I0+1 )
DO 120 IWHILB = 1, NBIG
IF( I0.GT.N0 )
$ GO TO 130
*
* While submatrix unfinished take a good dqds step.
*
CALL DLAZQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL,
$ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1,
$ DN2, TAU )
*
PP = 1 - PP
*
* When EMIN is very small check for splits.
*
IF( PP.EQ.0 .AND. N0-I0.GE.3 ) THEN
IF( Z( 4*N0 ).LE.TOL2*QMAX .OR.
$ Z( 4*N0-1 ).LE.TOL2*SIGMA ) THEN
SPLT = I0 - 1
QMAX = Z( 4*I0-3 )
EMIN = Z( 4*I0-1 )
OLDEMN = Z( 4*I0 )
DO 110 I4 = 4*I0, 4*( N0-3 ), 4
IF( Z( I4 ).LE.TOL2*Z( I4-3 ) .OR.
$ Z( I4-1 ).LE.TOL2*SIGMA ) THEN
Z( I4-1 ) = -SIGMA
SPLT = I4 / 4
QMAX = ZERO
EMIN = Z( I4+3 )
OLDEMN = Z( I4+4 )
ELSE
QMAX = MAX( QMAX, Z( I4+1 ) )
EMIN = MIN( EMIN, Z( I4-1 ) )
OLDEMN = MIN( OLDEMN, Z( I4 ) )
END IF
110 CONTINUE
Z( 4*N0-1 ) = EMIN
Z( 4*N0 ) = OLDEMN
I0 = SPLT + 1
END IF
END IF
*
120 CONTINUE
*
INFO = 2
RETURN
*
* end IWHILB
*
130 CONTINUE
*
140 CONTINUE
*
INFO = 3
RETURN
*
* end IWHILA
*
150 CONTINUE
*
* Move q's to the front.
*
DO 160 K = 2, N
Z( K ) = Z( 4*K-3 )
160 CONTINUE
*
* Sort and compute sum of eigenvalues.
*
CALL DLASRT( 'D', N, Z, IINFO )
*
E = ZERO
DO 170 K = N, 1, -1
E = E + Z( K )
170 CONTINUE
*
* Store trace, sum(eigenvalues) and information on performance.
*
Z( 2*N+1 ) = TRACE
Z( 2*N+2 ) = E
Z( 2*N+3 ) = DBLE( ITER )
Z( 2*N+4 ) = DBLE( NDIV ) / DBLE( N**2 )
Z( 2*N+5 ) = HUNDRD*NFAIL / DBLE( ITER )
RETURN
*
* End of DLASQ2
*
END
SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL,
$ ITER, NDIV, IEEE )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL IEEE
INTEGER I0, ITER, N0, NDIV, NFAIL, PP
DOUBLE PRECISION DESIG, DMIN, QMAX, SIGMA
* ..
* .. Array Arguments ..
DOUBLE PRECISION Z( * )
* ..
*
* Purpose
* =======
*
* DLASQ3 checks for deflation, computes a shift (TAU) and calls dqds.
* In case of failure it changes shifts, and tries again until output
* is positive.
*
* Arguments
* =========
*
* I0 (input) INTEGER
* First index.
*
* N0 (input) INTEGER
* Last index.
*
* Z (input) DOUBLE PRECISION array, dimension ( 4*N )
* Z holds the qd array.
*
* PP (input) INTEGER
* PP=0 for ping, PP=1 for pong.
*
* DMIN (output) DOUBLE PRECISION
* Minimum value of d.
*
* SIGMA (output) DOUBLE PRECISION
* Sum of shifts used in current segment.
*
* DESIG (input/output) DOUBLE PRECISION
* Lower order part of SIGMA
*
* QMAX (input) DOUBLE PRECISION
* Maximum value of q.
*
* NFAIL (output) INTEGER
* Number of times shift was too big.
*
* ITER (output) INTEGER
* Number of iterations.
*
* NDIV (output) INTEGER
* Number of divisions.
*
* TTYPE (output) INTEGER
* Shift type.
*
* IEEE (input) LOGICAL
* Flag for IEEE or non IEEE arithmetic (passed to DLASQ5).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION CBIAS
PARAMETER ( CBIAS = 1.50D0 )
DOUBLE PRECISION ZERO, QURTR, HALF, ONE, TWO, HUNDRD
PARAMETER ( ZERO = 0.0D0, QURTR = 0.250D0, HALF = 0.5D0,
$ ONE = 1.0D0, TWO = 2.0D0, HUNDRD = 100.0D0 )
* ..
* .. Local Scalars ..
INTEGER IPN4, J4, N0IN, NN, TTYPE
DOUBLE PRECISION DMIN1, DMIN2, DN, DN1, DN2, EPS, S, SAFMIN, T,
$ TAU, TEMP, TOL, TOL2
* ..
* .. External Subroutines ..
EXTERNAL DLASQ4, DLASQ5, DLASQ6
* ..
* .. External Function ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Save statement ..
SAVE TTYPE
SAVE DMIN1, DMIN2, DN, DN1, DN2, TAU
* ..
* .. Data statement ..
DATA TTYPE / 0 /
DATA DMIN1 / ZERO /, DMIN2 / ZERO /, DN / ZERO /,
$ DN1 / ZERO /, DN2 / ZERO /, TAU / ZERO /
* ..
* .. Executable Statements ..
*
N0IN = N0
EPS = DLAMCH( 'Precision' )
SAFMIN = DLAMCH( 'Safe minimum' )
TOL = EPS*HUNDRD
TOL2 = TOL**2
*
* Check for deflation.
*
10 CONTINUE
*
IF( N0.LT.I0 )
$ RETURN
IF( N0.EQ.I0 )
$ GO TO 20
NN = 4*N0 + PP
IF( N0.EQ.( I0+1 ) )
$ GO TO 40
*
* Check whether E(N0-1) is negligible, 1 eigenvalue.
*
IF( Z( NN-5 ).GT.TOL2*( SIGMA+Z( NN-3 ) ) .AND.
$ Z( NN-2*PP-4 ).GT.TOL2*Z( NN-7 ) )
$ GO TO 30
*
20 CONTINUE
*
Z( 4*N0-3 ) = Z( 4*N0+PP-3 ) + SIGMA
N0 = N0 - 1
GO TO 10
*
* Check whether E(N0-2) is negligible, 2 eigenvalues.
*
30 CONTINUE
*
IF( Z( NN-9 ).GT.TOL2*SIGMA .AND.
$ Z( NN-2*PP-8 ).GT.TOL2*Z( NN-11 ) )
$ GO TO 50
*
40 CONTINUE
*
IF( Z( NN-3 ).GT.Z( NN-7 ) ) THEN
S = Z( NN-3 )
Z( NN-3 ) = Z( NN-7 )
Z( NN-7 ) = S
END IF
IF( Z( NN-5 ).GT.Z( NN-3 )*TOL2 ) THEN
T = HALF*( ( Z( NN-7 )-Z( NN-3 ) )+Z( NN-5 ) )
S = Z( NN-3 )*( Z( NN-5 ) / T )
IF( S.LE.T ) THEN
S = Z( NN-3 )*( Z( NN-5 ) /
$ ( T*( ONE+SQRT( ONE+S / T ) ) ) )
ELSE
S = Z( NN-3 )*( Z( NN-5 ) / ( T+SQRT( T )*SQRT( T+S ) ) )
END IF
T = Z( NN-7 ) + ( S+Z( NN-5 ) )
Z( NN-3 ) = Z( NN-3 )*( Z( NN-7 ) / T )
Z( NN-7 ) = T
END IF
Z( 4*N0-7 ) = Z( NN-7 ) + SIGMA
Z( 4*N0-3 ) = Z( NN-3 ) + SIGMA
N0 = N0 - 2
GO TO 10
*
50 CONTINUE
*
* Reverse the qd-array, if warranted.
*
IF( DMIN.LE.ZERO .OR. N0.LT.N0IN ) THEN
IF( CBIAS*Z( 4*I0+PP-3 ).LT.Z( 4*N0+PP-3 ) ) THEN
IPN4 = 4*( I0+N0 )
DO 60 J4 = 4*I0, 2*( I0+N0-1 ), 4
TEMP = Z( J4-3 )
Z( J4-3 ) = Z( IPN4-J4-3 )
Z( IPN4-J4-3 ) = TEMP
TEMP = Z( J4-2 )
Z( J4-2 ) = Z( IPN4-J4-2 )
Z( IPN4-J4-2 ) = TEMP
TEMP = Z( J4-1 )
Z( J4-1 ) = Z( IPN4-J4-5 )
Z( IPN4-J4-5 ) = TEMP
TEMP = Z( J4 )
Z( J4 ) = Z( IPN4-J4-4 )
Z( IPN4-J4-4 ) = TEMP
60 CONTINUE
IF( N0-I0.LE.4 ) THEN
Z( 4*N0+PP-1 ) = Z( 4*I0+PP-1 )
Z( 4*N0-PP ) = Z( 4*I0-PP )
END IF
DMIN2 = MIN( DMIN2, Z( 4*N0+PP-1 ) )
Z( 4*N0+PP-1 ) = MIN( Z( 4*N0+PP-1 ), Z( 4*I0+PP-1 ),
$ Z( 4*I0+PP+3 ) )
Z( 4*N0-PP ) = MIN( Z( 4*N0-PP ), Z( 4*I0-PP ),
$ Z( 4*I0-PP+4 ) )
QMAX = MAX( QMAX, Z( 4*I0+PP-3 ), Z( 4*I0+PP+1 ) )
DMIN = -ZERO
END IF
END IF
*
IF( DMIN.LT.ZERO .OR. SAFMIN*QMAX.LT.MIN( Z( 4*N0+PP-1 ),
$ Z( 4*N0+PP-9 ), DMIN2+Z( 4*N0-PP ) ) ) THEN
*
* Choose a shift.
*
CALL DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1,
$ DN2, TAU, TTYPE )
*
* Call dqds until DMIN > 0.
*
80 CONTINUE
*
CALL DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN,
$ DN1, DN2, IEEE )
*
NDIV = NDIV + ( N0-I0+2 )
ITER = ITER + 1
*
* Check status.
*
IF( DMIN.GE.ZERO .AND. DMIN1.GT.ZERO ) THEN
*
* Success.
*
GO TO 100
*
ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND.
$ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND.
$ ABS( DN ).LT.TOL*SIGMA ) THEN
*
* Convergence hidden by negative DN.
*
Z( 4*( N0-1 )-PP+2 ) = ZERO
DMIN = ZERO
GO TO 100
ELSE IF( DMIN.LT.ZERO ) THEN
*
* TAU too big. Select new TAU and try again.
*
NFAIL = NFAIL + 1
IF( TTYPE.LT.-22 ) THEN
*
* Failed twice. Play it safe.
*
TAU = ZERO
ELSE IF( DMIN1.GT.ZERO ) THEN
*
* Late failure. Gives excellent shift.
*
TAU = ( TAU+DMIN )*( ONE-TWO*EPS )
TTYPE = TTYPE - 11
ELSE
*
* Early failure. Divide by 4.
*
TAU = QURTR*TAU
TTYPE = TTYPE - 12
END IF
GO TO 80
ELSE IF( DMIN.NE.DMIN ) THEN
*
* NaN.
*
TAU = ZERO
GO TO 80
ELSE
*
* Possible underflow. Play it safe.
*
GO TO 90
END IF
END IF
*
* Risk of underflow.
*
90 CONTINUE
CALL DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 )
NDIV = NDIV + ( N0-I0+2 )
ITER = ITER + 1
TAU = ZERO
*
100 CONTINUE
IF( TAU.LT.SIGMA ) THEN
DESIG = DESIG + TAU
T = SIGMA + DESIG
DESIG = DESIG - ( T-SIGMA )
ELSE
T = SIGMA + TAU
DESIG = SIGMA - ( T-TAU ) + DESIG
END IF
SIGMA = T
*
RETURN
*
* End of DLASQ3
*
END
SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN,
$ DN1, DN2, TAU, TTYPE )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER I0, N0, N0IN, PP, TTYPE
DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, TAU
* ..
* .. Array Arguments ..
DOUBLE PRECISION Z( * )
* ..
*
* Purpose
* =======
*
* DLASQ4 computes an approximation TAU to the smallest eigenvalue
* using values of d from the previous transform.
*
* I0 (input) INTEGER
* First index.
*
* N0 (input) INTEGER
* Last index.
*
* Z (input) DOUBLE PRECISION array, dimension ( 4*N )
* Z holds the qd array.
*
* PP (input) INTEGER
* PP=0 for ping, PP=1 for pong.
*
* N0IN (input) INTEGER
* The value of N0 at start of EIGTEST.
*
* DMIN (input) DOUBLE PRECISION
* Minimum value of d.
*
* DMIN1 (input) DOUBLE PRECISION
* Minimum value of d, excluding D( N0 ).
*
* DMIN2 (input) DOUBLE PRECISION
* Minimum value of d, excluding D( N0 ) and D( N0-1 ).
*
* DN (input) DOUBLE PRECISION
* d(N)
*
* DN1 (input) DOUBLE PRECISION
* d(N-1)
*
* DN2 (input) DOUBLE PRECISION
* d(N-2)
*
* TAU (output) DOUBLE PRECISION
* This is the shift.
*
* TTYPE (output) INTEGER
* Shift type.
*
* Further Details
* ===============
* CNST1 = 9/16
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION CNST1, CNST2, CNST3
PARAMETER ( CNST1 = 0.5630D0, CNST2 = 1.010D0,
$ CNST3 = 1.050D0 )
DOUBLE PRECISION QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD
PARAMETER ( QURTR = 0.250D0, THIRD = 0.3330D0,
$ HALF = 0.50D0, ZERO = 0.0D0, ONE = 1.0D0,
$ TWO = 2.0D0, HUNDRD = 100.0D0 )
* ..
* .. Local Scalars ..
INTEGER I4, NN, NP
DOUBLE PRECISION A2, B1, B2, G, GAM, GAP1, GAP2, S
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Save statement ..
SAVE G
* ..
* .. Data statement ..
DATA G / ZERO /
* ..
* .. Executable Statements ..
*
* A negative DMIN forces the shift to take that absolute value
* TTYPE records the type of shift.
*
IF( DMIN.LE.ZERO ) THEN
TAU = -DMIN
TTYPE = -1
RETURN
END IF
*
NN = 4*N0 + PP
IF( N0IN.EQ.N0 ) THEN
*
* No eigenvalues deflated.
*
IF( DMIN.EQ.DN .OR. DMIN.EQ.DN1 ) THEN
*
B1 = SQRT( Z( NN-3 ) )*SQRT( Z( NN-5 ) )
B2 = SQRT( Z( NN-7 ) )*SQRT( Z( NN-9 ) )
A2 = Z( NN-7 ) + Z( NN-5 )
*
* Cases 2 and 3.
*
IF( DMIN.EQ.DN .AND. DMIN1.EQ.DN1 ) THEN
GAP2 = DMIN2 - A2 - DMIN2*QURTR
IF( GAP2.GT.ZERO .AND. GAP2.GT.B2 ) THEN
GAP1 = A2 - DN - ( B2 / GAP2 )*B2
ELSE
GAP1 = A2 - DN - ( B1+B2 )
END IF
IF( GAP1.GT.ZERO .AND. GAP1.GT.B1 ) THEN
S = MAX( DN-( B1 / GAP1 )*B1, HALF*DMIN )
TTYPE = -2
ELSE
S = ZERO
IF( DN.GT.B1 )
$ S = DN - B1
IF( A2.GT.( B1+B2 ) )
$ S = MIN( S, A2-( B1+B2 ) )
S = MAX( S, THIRD*DMIN )
TTYPE = -3
END IF
ELSE
*
* Case 4.
*
TTYPE = -4
S = QURTR*DMIN
IF( DMIN.EQ.DN ) THEN
GAM = DN
A2 = ZERO
IF( Z( NN-5 ) .GT. Z( NN-7 ) )
$ RETURN
B2 = Z( NN-5 ) / Z( NN-7 )
NP = NN - 9
ELSE
NP = NN - 2*PP
B2 = Z( NP-2 )
GAM = DN1
IF( Z( NP-4 ) .GT. Z( NP-2 ) )
$ RETURN
A2 = Z( NP-4 ) / Z( NP-2 )
IF( Z( NN-9 ) .GT. Z( NN-11 ) )
$ RETURN
B2 = Z( NN-9 ) / Z( NN-11 )
NP = NN - 13
END IF
*
* Approximate contribution to norm squared from I < NN-1.
*
A2 = A2 + B2
DO 10 I4 = NP, 4*I0 - 1 + PP, -4
IF( B2.EQ.ZERO )
$ GO TO 20
B1 = B2
IF( Z( I4 ) .GT. Z( I4-2 ) )
$ RETURN
B2 = B2*( Z( I4 ) / Z( I4-2 ) )
A2 = A2 + B2
IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 )
$ GO TO 20
10 CONTINUE
20 CONTINUE
A2 = CNST3*A2
*
* Rayleigh quotient residual bound.
*
IF( A2.LT.CNST1 )
$ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 )
END IF
ELSE IF( DMIN.EQ.DN2 ) THEN
*
* Case 5.
*
TTYPE = -5
S = QURTR*DMIN
*
* Compute contribution to norm squared from I > NN-2.
*
NP = NN - 2*PP
B1 = Z( NP-2 )
B2 = Z( NP-6 )
GAM = DN2
IF( Z( NP-8 ).GT.B2 .OR. Z( NP-4 ).GT.B1 )
$ RETURN
A2 = ( Z( NP-8 ) / B2 )*( ONE+Z( NP-4 ) / B1 )
*
* Approximate contribution to norm squared from I < NN-2.
*
IF( N0-I0.GT.2 ) THEN
B2 = Z( NN-13 ) / Z( NN-15 )
A2 = A2 + B2
DO 30 I4 = NN - 17, 4*I0 - 1 + PP, -4
IF( B2.EQ.ZERO )
$ GO TO 40
B1 = B2
IF( Z( I4 ) .GT. Z( I4-2 ) )
$ RETURN
B2 = B2*( Z( I4 ) / Z( I4-2 ) )
A2 = A2 + B2
IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 )
$ GO TO 40
30 CONTINUE
40 CONTINUE
A2 = CNST3*A2
END IF
*
IF( A2.LT.CNST1 )
$ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 )
ELSE
*
* Case 6, no information to guide us.
*
IF( TTYPE.EQ.-6 ) THEN
G = G + THIRD*( ONE-G )
ELSE IF( TTYPE.EQ.-18 ) THEN
G = QURTR*THIRD
ELSE
G = QURTR
END IF
S = G*DMIN
TTYPE = -6
END IF
*
ELSE IF( N0IN.EQ.( N0+1 ) ) THEN
*
* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN.
*
IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN
*
* Cases 7 and 8.
*
TTYPE = -7
S = THIRD*DMIN1
IF( Z( NN-5 ).GT.Z( NN-7 ) )
$ RETURN
B1 = Z( NN-5 ) / Z( NN-7 )
B2 = B1
IF( B2.EQ.ZERO )
$ GO TO 60
DO 50 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4
A2 = B1
IF( Z( I4 ).GT.Z( I4-2 ) )
$ RETURN
B1 = B1*( Z( I4 ) / Z( I4-2 ) )
B2 = B2 + B1
IF( HUNDRD*MAX( B1, A2 ).LT.B2 )
$ GO TO 60
50 CONTINUE
60 CONTINUE
B2 = SQRT( CNST3*B2 )
A2 = DMIN1 / ( ONE+B2**2 )
GAP2 = HALF*DMIN2 - A2
IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN
S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) )
ELSE
S = MAX( S, A2*( ONE-CNST2*B2 ) )
TTYPE = -8
END IF
ELSE
*
* Case 9.
*
S = QURTR*DMIN1
IF( DMIN1.EQ.DN1 )
$ S = HALF*DMIN1
TTYPE = -9
END IF
*
ELSE IF( N0IN.EQ.( N0+2 ) ) THEN
*
* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN.
*
* Cases 10 and 11.
*
IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN
TTYPE = -10
S = THIRD*DMIN2
IF( Z( NN-5 ).GT.Z( NN-7 ) )
$ RETURN
B1 = Z( NN-5 ) / Z( NN-7 )
B2 = B1
IF( B2.EQ.ZERO )
$ GO TO 80
DO 70 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4
IF( Z( I4 ).GT.Z( I4-2 ) )
$ RETURN
B1 = B1*( Z( I4 ) / Z( I4-2 ) )
B2 = B2 + B1
IF( HUNDRD*B1.LT.B2 )
$ GO TO 80
70 CONTINUE
80 CONTINUE
B2 = SQRT( CNST3*B2 )
A2 = DMIN2 / ( ONE+B2**2 )
GAP2 = Z( NN-7 ) + Z( NN-9 ) -
$ SQRT( Z( NN-11 ) )*SQRT( Z( NN-9 ) ) - A2
IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN
S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) )
ELSE
S = MAX( S, A2*( ONE-CNST2*B2 ) )
END IF
ELSE
S = QURTR*DMIN2
TTYPE = -11
END IF
ELSE IF( N0IN.GT.( N0+2 ) ) THEN
*
* Case 12, more than two eigenvalues deflated. No information.
*
S = ZERO
TTYPE = -12
END IF
*
TAU = S
RETURN
*
* End of DLASQ4
*
END
SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN,
$ DNM1, DNM2, IEEE )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL IEEE
INTEGER I0, N0, PP
DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU
* ..
* .. Array Arguments ..
DOUBLE PRECISION Z( * )
* ..
*
* Purpose
* =======
*
* DLASQ5 computes one dqds transform in ping-pong form, one
* version for IEEE machines another for non IEEE machines.
*
* Arguments
* =========
*
* I0 (input) INTEGER
* First index.
*
* N0 (input) INTEGER
* Last index.
*
* Z (input) DOUBLE PRECISION array, dimension ( 4*N )
* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid
* an extra argument.
*
* PP (input) INTEGER
* PP=0 for ping, PP=1 for pong.
*
* TAU (input) DOUBLE PRECISION
* This is the shift.
*
* DMIN (output) DOUBLE PRECISION
* Minimum value of d.
*
* DMIN1 (output) DOUBLE PRECISION
* Minimum value of d, excluding D( N0 ).
*
* DMIN2 (output) DOUBLE PRECISION
* Minimum value of d, excluding D( N0 ) and D( N0-1 ).
*
* DN (output) DOUBLE PRECISION
* d(N0), the last value of d.
*
* DNM1 (output) DOUBLE PRECISION
* d(N0-1).
*
* DNM2 (output) DOUBLE PRECISION
* d(N0-2).
*
* IEEE (input) LOGICAL
* Flag for IEEE or non IEEE arithmetic.
*
* =====================================================================
*
* .. Parameter ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER J4, J4P2
DOUBLE PRECISION D, EMIN, TEMP
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
IF( ( N0-I0-1 ).LE.0 )
$ RETURN
*
J4 = 4*I0 + PP - 3
EMIN = Z( J4+4 )
D = Z( J4 ) - TAU
DMIN = D
DMIN1 = -Z( J4 )
*
IF( IEEE ) THEN
*
* Code for IEEE arithmetic.
*
IF( PP.EQ.0 ) THEN
DO 10 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-2 ) = D + Z( J4-1 )
TEMP = Z( J4+1 ) / Z( J4-2 )
D = D*TEMP - TAU
DMIN = MIN( DMIN, D )
Z( J4 ) = Z( J4-1 )*TEMP
EMIN = MIN( Z( J4 ), EMIN )
10 CONTINUE
ELSE
DO 20 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-3 ) = D + Z( J4 )
TEMP = Z( J4+2 ) / Z( J4-3 )
D = D*TEMP - TAU
DMIN = MIN( DMIN, D )
Z( J4-1 ) = Z( J4 )*TEMP
EMIN = MIN( Z( J4-1 ), EMIN )
20 CONTINUE
END IF
*
* Unroll last two steps.
*
DNM2 = D
DMIN2 = DMIN
J4 = 4*( N0-2 ) - PP
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM2 + Z( J4P2 )
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU
DMIN = MIN( DMIN, DNM1 )
*
DMIN1 = DMIN
J4 = J4 + 4
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM1 + Z( J4P2 )
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU
DMIN = MIN( DMIN, DN )
*
ELSE
*
* Code for non IEEE arithmetic.
*
IF( PP.EQ.0 ) THEN
DO 30 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-2 ) = D + Z( J4-1 )
IF( D.LT.ZERO ) THEN
RETURN
ELSE
Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) )
D = Z( J4+1 )*( D / Z( J4-2 ) ) - TAU
END IF
DMIN = MIN( DMIN, D )
EMIN = MIN( EMIN, Z( J4 ) )
30 CONTINUE
ELSE
DO 40 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-3 ) = D + Z( J4 )
IF( D.LT.ZERO ) THEN
RETURN
ELSE
Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) )
D = Z( J4+2 )*( D / Z( J4-3 ) ) - TAU
END IF
DMIN = MIN( DMIN, D )
EMIN = MIN( EMIN, Z( J4-1 ) )
40 CONTINUE
END IF
*
* Unroll last two steps.
*
DNM2 = D
DMIN2 = DMIN
J4 = 4*( N0-2 ) - PP
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM2 + Z( J4P2 )
IF( DNM2.LT.ZERO ) THEN
RETURN
ELSE
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU
END IF
DMIN = MIN( DMIN, DNM1 )
*
DMIN1 = DMIN
J4 = J4 + 4
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM1 + Z( J4P2 )
IF( DNM1.LT.ZERO ) THEN
RETURN
ELSE
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU
END IF
DMIN = MIN( DMIN, DN )
*
END IF
*
Z( J4+2 ) = DN
Z( 4*N0-PP ) = EMIN
RETURN
*
* End of DLASQ5
*
END
SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN,
$ DNM1, DNM2 )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER I0, N0, PP
DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2
* ..
* .. Array Arguments ..
DOUBLE PRECISION Z( * )
* ..
*
* Purpose
* =======
*
* DLASQ6 computes one dqd (shift equal to zero) transform in
* ping-pong form, with protection against underflow and overflow.
*
* Arguments
* =========
*
* I0 (input) INTEGER
* First index.
*
* N0 (input) INTEGER
* Last index.
*
* Z (input) DOUBLE PRECISION array, dimension ( 4*N )
* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid
* an extra argument.
*
* PP (input) INTEGER
* PP=0 for ping, PP=1 for pong.
*
* DMIN (output) DOUBLE PRECISION
* Minimum value of d.
*
* DMIN1 (output) DOUBLE PRECISION
* Minimum value of d, excluding D( N0 ).
*
* DMIN2 (output) DOUBLE PRECISION
* Minimum value of d, excluding D( N0 ) and D( N0-1 ).
*
* DN (output) DOUBLE PRECISION
* d(N0), the last value of d.
*
* DNM1 (output) DOUBLE PRECISION
* d(N0-1).
*
* DNM2 (output) DOUBLE PRECISION
* d(N0-2).
*
* =====================================================================
*
* .. Parameter ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER J4, J4P2
DOUBLE PRECISION D, EMIN, SAFMIN, TEMP
* ..
* .. External Function ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
IF( ( N0-I0-1 ).LE.0 )
$ RETURN
*
SAFMIN = DLAMCH( 'Safe minimum' )
J4 = 4*I0 + PP - 3
EMIN = Z( J4+4 )
D = Z( J4 )
DMIN = D
*
IF( PP.EQ.0 ) THEN
DO 10 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-2 ) = D + Z( J4-1 )
IF( Z( J4-2 ).EQ.ZERO ) THEN
Z( J4 ) = ZERO
D = Z( J4+1 )
DMIN = D
EMIN = ZERO
ELSE IF( SAFMIN*Z( J4+1 ).LT.Z( J4-2 ) .AND.
$ SAFMIN*Z( J4-2 ).LT.Z( J4+1 ) ) THEN
TEMP = Z( J4+1 ) / Z( J4-2 )
Z( J4 ) = Z( J4-1 )*TEMP
D = D*TEMP
ELSE
Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) )
D = Z( J4+1 )*( D / Z( J4-2 ) )
END IF
DMIN = MIN( DMIN, D )
EMIN = MIN( EMIN, Z( J4 ) )
10 CONTINUE
ELSE
DO 20 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-3 ) = D + Z( J4 )
IF( Z( J4-3 ).EQ.ZERO ) THEN
Z( J4-1 ) = ZERO
D = Z( J4+2 )
DMIN = D
EMIN = ZERO
ELSE IF( SAFMIN*Z( J4+2 ).LT.Z( J4-3 ) .AND.
$ SAFMIN*Z( J4-3 ).LT.Z( J4+2 ) ) THEN
TEMP = Z( J4+2 ) / Z( J4-3 )
Z( J4-1 ) = Z( J4 )*TEMP
D = D*TEMP
ELSE
Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) )
D = Z( J4+2 )*( D / Z( J4-3 ) )
END IF
DMIN = MIN( DMIN, D )
EMIN = MIN( EMIN, Z( J4-1 ) )
20 CONTINUE
END IF
*
* Unroll last two steps.
*
DNM2 = D
DMIN2 = DMIN
J4 = 4*( N0-2 ) - PP
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM2 + Z( J4P2 )
IF( Z( J4-2 ).EQ.ZERO ) THEN
Z( J4 ) = ZERO
DNM1 = Z( J4P2+2 )
DMIN = DNM1
EMIN = ZERO
ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND.
$ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN
TEMP = Z( J4P2+2 ) / Z( J4-2 )
Z( J4 ) = Z( J4P2 )*TEMP
DNM1 = DNM2*TEMP
ELSE
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) )
END IF
DMIN = MIN( DMIN, DNM1 )
*
DMIN1 = DMIN
J4 = J4 + 4
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM1 + Z( J4P2 )
IF( Z( J4-2 ).EQ.ZERO ) THEN
Z( J4 ) = ZERO
DN = Z( J4P2+2 )
DMIN = DN
EMIN = ZERO
ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND.
$ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN
TEMP = Z( J4P2+2 ) / Z( J4-2 )
Z( J4 ) = Z( J4P2 )*TEMP
DN = DNM1*TEMP
ELSE
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) )
END IF
DMIN = MIN( DMIN, DN )
*
Z( J4+2 ) = DN
Z( 4*N0-PP ) = EMIN
RETURN
*
* End of DLASQ6
*
END
SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIRECT, PIVOT, SIDE
INTEGER LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), C( * ), S( * )
* ..
*
* Purpose
* =======
*
* DLASR applies a sequence of plane rotations to a real matrix A,
* from either the left or the right.
*
* When SIDE = 'L', the transformation takes the form
*
* A := P*A
*
* and when SIDE = 'R', the transformation takes the form
*
* A := A*P**T
*
* where P is an orthogonal matrix consisting of a sequence of z plane
* rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',
* and P**T is the transpose of P.
*
* When DIRECT = 'F' (Forward sequence), then
*
* P = P(z-1) * ... * P(2) * P(1)
*
* and when DIRECT = 'B' (Backward sequence), then
*
* P = P(1) * P(2) * ... * P(z-1)
*
* where P(k) is a plane rotation matrix defined by the 2-by-2 rotation
*
* R(k) = ( c(k) s(k) )
* = ( -s(k) c(k) ).
*
* When PIVOT = 'V' (Variable pivot), the rotation is performed
* for the plane (k,k+1), i.e., P(k) has the form
*
* P(k) = ( 1 )
* ( ... )
* ( 1 )
* ( c(k) s(k) )
* ( -s(k) c(k) )
* ( 1 )
* ( ... )
* ( 1 )
*
* where R(k) appears as a rank-2 modification to the identity matrix in
* rows and columns k and k+1.
*
* When PIVOT = 'T' (Top pivot), the rotation is performed for the
* plane (1,k+1), so P(k) has the form
*
* P(k) = ( c(k) s(k) )
* ( 1 )
* ( ... )
* ( 1 )
* ( -s(k) c(k) )
* ( 1 )
* ( ... )
* ( 1 )
*
* where R(k) appears in rows and columns 1 and k+1.
*
* Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is
* performed for the plane (k,z), giving P(k) the form
*
* P(k) = ( 1 )
* ( ... )
* ( 1 )
* ( c(k) s(k) )
* ( 1 )
* ( ... )
* ( 1 )
* ( -s(k) c(k) )
*
* where R(k) appears in rows and columns k and z. The rotations are
* performed without ever forming P(k) explicitly.
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* Specifies whether the plane rotation matrix P is applied to
* A on the left or the right.
* = 'L': Left, compute A := P*A
* = 'R': Right, compute A:= A*P**T
*
* PIVOT (input) CHARACTER*1
* Specifies the plane for which P(k) is a plane rotation
* matrix.
* = 'V': Variable pivot, the plane (k,k+1)
* = 'T': Top pivot, the plane (1,k+1)
* = 'B': Bottom pivot, the plane (k,z)
*
* DIRECT (input) CHARACTER*1
* Specifies whether P is a forward or backward sequence of
* plane rotations.
* = 'F': Forward, P = P(z-1)*...*P(2)*P(1)
* = 'B': Backward, P = P(1)*P(2)*...*P(z-1)
*
* M (input) INTEGER
* The number of rows of the matrix A. If m <= 1, an immediate
* return is effected.
*
* N (input) INTEGER
* The number of columns of the matrix A. If n <= 1, an
* immediate return is effected.
*
* C (input) DOUBLE PRECISION array, dimension
* (M-1) if SIDE = 'L'
* (N-1) if SIDE = 'R'
* The cosines c(k) of the plane rotations.
*
* S (input) DOUBLE PRECISION array, dimension
* (M-1) if SIDE = 'L'
* (N-1) if SIDE = 'R'
* The sines s(k) of the plane rotations. The 2-by-2 plane
* rotation part of the matrix P(k), R(k), has the form
* R(k) = ( c(k) s(k) )
* ( -s(k) c(k) ).
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* The M-by-N matrix A. On exit, A is overwritten by P*A if
* SIDE = 'R' or by A*P**T if SIDE = 'L'.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
DOUBLE PRECISION CTEMP, STEMP, TEMP
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN
INFO = 1
ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT,
$ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN
INFO = 2
ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) )
$ THEN
INFO = 3
ELSE IF( M.LT.0 ) THEN
INFO = 4
ELSE IF( N.LT.0 ) THEN
INFO = 5
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = 9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLASR ', INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) )
$ RETURN
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form P * A
*
IF( LSAME( PIVOT, 'V' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 20 J = 1, M - 1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 10 I = 1, N
TEMP = A( J+1, I )
A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
10 CONTINUE
END IF
20 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 40 J = M - 1, 1, -1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 30 I = 1, N
TEMP = A( J+1, I )
A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
30 CONTINUE
END IF
40 CONTINUE
END IF
ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 60 J = 2, M
CTEMP = C( J-1 )
STEMP = S( J-1 )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 50 I = 1, N
TEMP = A( J, I )
A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
50 CONTINUE
END IF
60 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 80 J = M, 2, -1
CTEMP = C( J-1 )
STEMP = S( J-1 )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 70 I = 1, N
TEMP = A( J, I )
A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
70 CONTINUE
END IF
80 CONTINUE
END IF
ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 100 J = 1, M - 1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 90 I = 1, N
TEMP = A( J, I )
A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
90 CONTINUE
END IF
100 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 120 J = M - 1, 1, -1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 110 I = 1, N
TEMP = A( J, I )
A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
110 CONTINUE
END IF
120 CONTINUE
END IF
END IF
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form A * P'
*
IF( LSAME( PIVOT, 'V' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 140 J = 1, N - 1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 130 I = 1, M
TEMP = A( I, J+1 )
A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
130 CONTINUE
END IF
140 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 160 J = N - 1, 1, -1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 150 I = 1, M
TEMP = A( I, J+1 )
A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
150 CONTINUE
END IF
160 CONTINUE
END IF
ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 180 J = 2, N
CTEMP = C( J-1 )
STEMP = S( J-1 )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 170 I = 1, M
TEMP = A( I, J )
A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
170 CONTINUE
END IF
180 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 200 J = N, 2, -1
CTEMP = C( J-1 )
STEMP = S( J-1 )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 190 I = 1, M
TEMP = A( I, J )
A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
190 CONTINUE
END IF
200 CONTINUE
END IF
ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 220 J = 1, N - 1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 210 I = 1, M
TEMP = A( I, J )
A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
210 CONTINUE
END IF
220 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 240 J = N - 1, 1, -1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 230 I = 1, M
TEMP = A( I, J )
A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
230 CONTINUE
END IF
240 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of DLASR
*
END
SUBROUTINE DLASRT( ID, N, D, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER ID
INTEGER INFO, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * )
* ..
*
* Purpose
* =======
*
* Sort the numbers in D in increasing order (if ID = 'I') or
* in decreasing order (if ID = 'D' ).
*
* Use Quick Sort, reverting to Insertion sort on arrays of
* size <= 20. Dimension of STACK limits N to about 2**32.
*
* Arguments
* =========
*
* ID (input) CHARACTER*1
* = 'I': sort D in increasing order;
* = 'D': sort D in decreasing order.
*
* N (input) INTEGER
* The length of the array D.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the array to be sorted.
* On exit, D has been sorted into increasing order
* (D(1) <= ... <= D(N) ) or into decreasing order
* (D(1) >= ... >= D(N) ), depending on ID.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
INTEGER SELECT
PARAMETER ( SELECT = 20 )
* ..
* .. Local Scalars ..
INTEGER DIR, ENDD, I, J, START, STKPNT
DOUBLE PRECISION D1, D2, D3, DMNMX, TMP
* ..
* .. Local Arrays ..
INTEGER STACK( 2, 32 )
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
* Test the input paramters.
*
INFO = 0
DIR = -1
IF( LSAME( ID, 'D' ) ) THEN
DIR = 0
ELSE IF( LSAME( ID, 'I' ) ) THEN
DIR = 1
END IF
IF( DIR.EQ.-1 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLASRT', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.1 )
$ RETURN
*
STKPNT = 1
STACK( 1, 1 ) = 1
STACK( 2, 1 ) = N
10 CONTINUE
START = STACK( 1, STKPNT )
ENDD = STACK( 2, STKPNT )
STKPNT = STKPNT - 1
IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN
*
* Do Insertion sort on D( START:ENDD )
*
IF( DIR.EQ.0 ) THEN
*
* Sort into decreasing order
*
DO 30 I = START + 1, ENDD
DO 20 J = I, START + 1, -1
IF( D( J ).GT.D( J-1 ) ) THEN
DMNMX = D( J )
D( J ) = D( J-1 )
D( J-1 ) = DMNMX
ELSE
GO TO 30
END IF
20 CONTINUE
30 CONTINUE
*
ELSE
*
* Sort into increasing order
*
DO 50 I = START + 1, ENDD
DO 40 J = I, START + 1, -1
IF( D( J ).LT.D( J-1 ) ) THEN
DMNMX = D( J )
D( J ) = D( J-1 )
D( J-1 ) = DMNMX
ELSE
GO TO 50
END IF
40 CONTINUE
50 CONTINUE
*
END IF
*
ELSE IF( ENDD-START.GT.SELECT ) THEN
*
* Partition D( START:ENDD ) and stack parts, largest one first
*
* Choose partition entry as median of 3
*
D1 = D( START )
D2 = D( ENDD )
I = ( START+ENDD ) / 2
D3 = D( I )
IF( D1.LT.D2 ) THEN
IF( D3.LT.D1 ) THEN
DMNMX = D1
ELSE IF( D3.LT.D2 ) THEN
DMNMX = D3
ELSE
DMNMX = D2
END IF
ELSE
IF( D3.LT.D2 ) THEN
DMNMX = D2
ELSE IF( D3.LT.D1 ) THEN
DMNMX = D3
ELSE
DMNMX = D1
END IF
END IF
*
IF( DIR.EQ.0 ) THEN
*
* Sort into decreasing order
*
I = START - 1
J = ENDD + 1
60 CONTINUE
70 CONTINUE
J = J - 1
IF( D( J ).LT.DMNMX )
$ GO TO 70
80 CONTINUE
I = I + 1
IF( D( I ).GT.DMNMX )
$ GO TO 80
IF( I.LT.J ) THEN
TMP = D( I )
D( I ) = D( J )
D( J ) = TMP
GO TO 60
END IF
IF( J-START.GT.ENDD-J-1 ) THEN
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = START
STACK( 2, STKPNT ) = J
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = J + 1
STACK( 2, STKPNT ) = ENDD
ELSE
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = J + 1
STACK( 2, STKPNT ) = ENDD
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = START
STACK( 2, STKPNT ) = J
END IF
ELSE
*
* Sort into increasing order
*
I = START - 1
J = ENDD + 1
90 CONTINUE
100 CONTINUE
J = J - 1
IF( D( J ).GT.DMNMX )
$ GO TO 100
110 CONTINUE
I = I + 1
IF( D( I ).LT.DMNMX )
$ GO TO 110
IF( I.LT.J ) THEN
TMP = D( I )
D( I ) = D( J )
D( J ) = TMP
GO TO 90
END IF
IF( J-START.GT.ENDD-J-1 ) THEN
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = START
STACK( 2, STKPNT ) = J
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = J + 1
STACK( 2, STKPNT ) = ENDD
ELSE
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = J + 1
STACK( 2, STKPNT ) = ENDD
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = START
STACK( 2, STKPNT ) = J
END IF
END IF
END IF
IF( STKPNT.GT.0 )
$ GO TO 10
RETURN
*
* End of DLASRT
*
END
SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INCX, N
DOUBLE PRECISION SCALE, SUMSQ
* ..
* .. Array Arguments ..
DOUBLE PRECISION X( * )
* ..
*
* Purpose
* =======
*
* DLASSQ returns the values scl and smsq such that
*
* ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
*
* where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is
* assumed to be non-negative and scl returns the value
*
* scl = max( scale, abs( x( i ) ) ).
*
* scale and sumsq must be supplied in SCALE and SUMSQ and
* scl and smsq are overwritten on SCALE and SUMSQ respectively.
*
* The routine makes only one pass through the vector x.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of elements to be used from the vector X.
*
* X (input) DOUBLE PRECISION array, dimension (N)
* The vector for which a scaled sum of squares is computed.
* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
*
* INCX (input) INTEGER
* The increment between successive values of the vector X.
* INCX > 0.
*
* SCALE (input/output) DOUBLE PRECISION
* On entry, the value scale in the equation above.
* On exit, SCALE is overwritten with scl , the scaling factor
* for the sum of squares.
*
* SUMSQ (input/output) DOUBLE PRECISION
* On entry, the value sumsq in the equation above.
* On exit, SUMSQ is overwritten with smsq , the basic sum of
* squares from which scl has been factored out.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER IX
DOUBLE PRECISION ABSXI
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
IF( N.GT.0 ) THEN
DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX
IF( X( IX ).NE.ZERO ) THEN
ABSXI = ABS( X( IX ) )
IF( SCALE.LT.ABSXI ) THEN
SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2
SCALE = ABSXI
ELSE
SUMSQ = SUMSQ + ( ABSXI / SCALE )**2
END IF
END IF
10 CONTINUE
END IF
RETURN
*
* End of DLASSQ
*
END
SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
DOUBLE PRECISION CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN
* ..
*
* Purpose
* =======
*
* DLASV2 computes the singular value decomposition of a 2-by-2
* triangular matrix
* [ F G ]
* [ 0 H ].
* On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the
* smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and
* right singular vectors for abs(SSMAX), giving the decomposition
*
* [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ]
* [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ].
*
* Arguments
* =========
*
* F (input) DOUBLE PRECISION
* The (1,1) element of the 2-by-2 matrix.
*
* G (input) DOUBLE PRECISION
* The (1,2) element of the 2-by-2 matrix.
*
* H (input) DOUBLE PRECISION
* The (2,2) element of the 2-by-2 matrix.
*
* SSMIN (output) DOUBLE PRECISION
* abs(SSMIN) is the smaller singular value.
*
* SSMAX (output) DOUBLE PRECISION
* abs(SSMAX) is the larger singular value.
*
* SNL (output) DOUBLE PRECISION
* CSL (output) DOUBLE PRECISION
* The vector (CSL, SNL) is a unit left singular vector for the
* singular value abs(SSMAX).
*
* SNR (output) DOUBLE PRECISION
* CSR (output) DOUBLE PRECISION
* The vector (CSR, SNR) is a unit right singular vector for the
* singular value abs(SSMAX).
*
* Further Details
* ===============
*
* Any input parameter may be aliased with any output parameter.
*
* Barring over/underflow and assuming a guard digit in subtraction, all
* output quantities are correct to within a few units in the last
* place (ulps).
*
* In IEEE arithmetic, the code works correctly if one matrix element is
* infinite.
*
* Overflow will not occur unless the largest singular value itself
* overflows or is within a few ulps of overflow. (On machines with
* partial overflow, like the Cray, overflow may occur if the largest
* singular value is within a factor of 2 of overflow.)
*
* Underflow is harmless if underflow is gradual. Otherwise, results
* may correspond to a matrix modified by perturbations of size near
* the underflow threshold.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION HALF
PARAMETER ( HALF = 0.5D0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D0 )
DOUBLE PRECISION FOUR
PARAMETER ( FOUR = 4.0D0 )
* ..
* .. Local Scalars ..
LOGICAL GASMAL, SWAP
INTEGER PMAX
DOUBLE PRECISION A, CLT, CRT, D, FA, FT, GA, GT, HA, HT, L, M,
$ MM, R, S, SLT, SRT, T, TEMP, TSIGN, TT
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SIGN, SQRT
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Executable Statements ..
*
FT = F
FA = ABS( FT )
HT = H
HA = ABS( H )
*
* PMAX points to the maximum absolute element of matrix
* PMAX = 1 if F largest in absolute values
* PMAX = 2 if G largest in absolute values
* PMAX = 3 if H largest in absolute values
*
PMAX = 1
SWAP = ( HA.GT.FA )
IF( SWAP ) THEN
PMAX = 3
TEMP = FT
FT = HT
HT = TEMP
TEMP = FA
FA = HA
HA = TEMP
*
* Now FA .ge. HA
*
END IF
GT = G
GA = ABS( GT )
IF( GA.EQ.ZERO ) THEN
*
* Diagonal matrix
*
SSMIN = HA
SSMAX = FA
CLT = ONE
CRT = ONE
SLT = ZERO
SRT = ZERO
ELSE
GASMAL = .TRUE.
IF( GA.GT.FA ) THEN
PMAX = 2
IF( ( FA / GA ).LT.DLAMCH( 'EPS' ) ) THEN
*
* Case of very large GA
*
GASMAL = .FALSE.
SSMAX = GA
IF( HA.GT.ONE ) THEN
SSMIN = FA / ( GA / HA )
ELSE
SSMIN = ( FA / GA )*HA
END IF
CLT = ONE
SLT = HT / GT
SRT = ONE
CRT = FT / GT
END IF
END IF
IF( GASMAL ) THEN
*
* Normal case
*
D = FA - HA
IF( D.EQ.FA ) THEN
*
* Copes with infinite F or H
*
L = ONE
ELSE
L = D / FA
END IF
*
* Note that 0 .le. L .le. 1
*
M = GT / FT
*
* Note that abs(M) .le. 1/macheps
*
T = TWO - L
*
* Note that T .ge. 1
*
MM = M*M
TT = T*T
S = SQRT( TT+MM )
*
* Note that 1 .le. S .le. 1 + 1/macheps
*
IF( L.EQ.ZERO ) THEN
R = ABS( M )
ELSE
R = SQRT( L*L+MM )
END IF
*
* Note that 0 .le. R .le. 1 + 1/macheps
*
A = HALF*( S+R )
*
* Note that 1 .le. A .le. 1 + abs(M)
*
SSMIN = HA / A
SSMAX = FA*A
IF( MM.EQ.ZERO ) THEN
*
* Note that M is very tiny
*
IF( L.EQ.ZERO ) THEN
T = SIGN( TWO, FT )*SIGN( ONE, GT )
ELSE
T = GT / SIGN( D, FT ) + M / T
END IF
ELSE
T = ( M / ( S+T )+M / ( R+L ) )*( ONE+A )
END IF
L = SQRT( T*T+FOUR )
CRT = TWO / L
SRT = T / L
CLT = ( CRT+SRT*M ) / A
SLT = ( HT / FT )*SRT / A
END IF
END IF
IF( SWAP ) THEN
CSL = SRT
SNL = CRT
CSR = SLT
SNR = CLT
ELSE
CSL = CLT
SNL = SLT
CSR = CRT
SNR = SRT
END IF
*
* Correct signs of SSMAX and SSMIN
*
IF( PMAX.EQ.1 )
$ TSIGN = SIGN( ONE, CSR )*SIGN( ONE, CSL )*SIGN( ONE, F )
IF( PMAX.EQ.2 )
$ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, CSL )*SIGN( ONE, G )
IF( PMAX.EQ.3 )
$ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, SNL )*SIGN( ONE, H )
SSMAX = SIGN( SSMAX, TSIGN )
SSMIN = SIGN( SSMIN, TSIGN*SIGN( ONE, F )*SIGN( ONE, H ) )
RETURN
*
* End of DLASV2
*
END
SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley 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 DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR,
$ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL LTRANL, LTRANR
INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2
DOUBLE PRECISION SCALE, XNORM
* ..
* .. Array Arguments ..
DOUBLE PRECISION B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ),
$ X( LDX, * )
* ..
*
* Purpose
* =======
*
* DLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in
*
* op(TL)*X + ISGN*X*op(TR) = SCALE*B,
*
* where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or
* -1. op(T) = T or T', where T' denotes the transpose of T.
*
* Arguments
* =========
*
* LTRANL (input) LOGICAL
* On entry, LTRANL specifies the op(TL):
* = .FALSE., op(TL) = TL,
* = .TRUE., op(TL) = TL'.
*
* LTRANR (input) LOGICAL
* On entry, LTRANR specifies the op(TR):
* = .FALSE., op(TR) = TR,
* = .TRUE., op(TR) = TR'.
*
* ISGN (input) INTEGER
* On entry, ISGN specifies the sign of the equation
* as described before. ISGN may only be 1 or -1.
*
* N1 (input) INTEGER
* On entry, N1 specifies the order of matrix TL.
* N1 may only be 0, 1 or 2.
*
* N2 (input) INTEGER
* On entry, N2 specifies the order of matrix TR.
* N2 may only be 0, 1 or 2.
*
* TL (input) DOUBLE PRECISION array, dimension (LDTL,2)
* On entry, TL contains an N1 by N1 matrix.
*
* LDTL (input) INTEGER
* The leading dimension of the matrix TL. LDTL >= max(1,N1).
*
* TR (input) DOUBLE PRECISION array, dimension (LDTR,2)
* On entry, TR contains an N2 by N2 matrix.
*
* LDTR (input) INTEGER
* The leading dimension of the matrix TR. LDTR >= max(1,N2).
*
* B (input) DOUBLE PRECISION array, dimension (LDB,2)
* On entry, the N1 by N2 matrix B contains the right-hand
* side of the equation.
*
* LDB (input) INTEGER
* The leading dimension of the matrix B. LDB >= max(1,N1).
*
* SCALE (output) DOUBLE PRECISION
* On exit, SCALE contains the scale factor. SCALE is chosen
* less than or equal to 1 to prevent the solution overflowing.
*
* X (output) DOUBLE PRECISION array, dimension (LDX,2)
* On exit, X contains the N1 by N2 solution.
*
* LDX (input) INTEGER
* The leading dimension of the matrix X. LDX >= max(1,N1).
*
* XNORM (output) DOUBLE PRECISION
* On exit, XNORM is the infinity-norm of the solution.
*
* INFO (output) INTEGER
* On exit, INFO is set to
* 0: successful exit.
* 1: TL and TR have too close eigenvalues, so TL or
* TR is perturbed to get a nonsingular equation.
* NOTE: In the interests of speed, this routine does not
* check the inputs for errors.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION TWO, HALF, EIGHT
PARAMETER ( TWO = 2.0D+0, HALF = 0.5D+0, EIGHT = 8.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL BSWAP, XSWAP
INTEGER I, IP, IPIV, IPSV, J, JP, JPSV, K
DOUBLE PRECISION BET, EPS, GAM, L21, SGN, SMIN, SMLNUM, TAU1,
$ TEMP, U11, U12, U22, XMAX
* ..
* .. Local Arrays ..
LOGICAL BSWPIV( 4 ), XSWPIV( 4 )
INTEGER JPIV( 4 ), LOCL21( 4 ), LOCU12( 4 ),
$ LOCU22( 4 )
DOUBLE PRECISION BTMP( 4 ), T16( 4, 4 ), TMP( 4 ), X2( 2 )
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL IDAMAX, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Data statements ..
DATA LOCU12 / 3, 4, 1, 2 / , LOCL21 / 2, 1, 4, 3 / ,
$ LOCU22 / 4, 3, 2, 1 /
DATA XSWPIV / .FALSE., .FALSE., .TRUE., .TRUE. /
DATA BSWPIV / .FALSE., .TRUE., .FALSE., .TRUE. /
* ..
* .. Executable Statements ..
*
* Do not check the input parameters for errors
*
INFO = 0
*
* Quick return if possible
*
IF( N1.EQ.0 .OR. N2.EQ.0 )
$ RETURN
*
* Set constants to control overflow
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' ) / EPS
SGN = ISGN
*
K = N1 + N1 + N2 - 2
GO TO ( 10, 20, 30, 50 )K
*
* 1 by 1: TL11*X + SGN*X*TR11 = B11
*
10 CONTINUE
TAU1 = TL( 1, 1 ) + SGN*TR( 1, 1 )
BET = ABS( TAU1 )
IF( BET.LE.SMLNUM ) THEN
TAU1 = SMLNUM
BET = SMLNUM
INFO = 1
END IF
*
SCALE = ONE
GAM = ABS( B( 1, 1 ) )
IF( SMLNUM*GAM.GT.BET )
$ SCALE = ONE / GAM
*
X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / TAU1
XNORM = ABS( X( 1, 1 ) )
RETURN
*
* 1 by 2:
* TL11*[X11 X12] + ISGN*[X11 X12]*op[TR11 TR12] = [B11 B12]
* [TR21 TR22]
*
20 CONTINUE
*
SMIN = MAX( EPS*MAX( ABS( TL( 1, 1 ) ), ABS( TR( 1, 1 ) ),
$ ABS( TR( 1, 2 ) ), ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ),
$ SMLNUM )
TMP( 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 )
TMP( 4 ) = TL( 1, 1 ) + SGN*TR( 2, 2 )
IF( LTRANR ) THEN
TMP( 2 ) = SGN*TR( 2, 1 )
TMP( 3 ) = SGN*TR( 1, 2 )
ELSE
TMP( 2 ) = SGN*TR( 1, 2 )
TMP( 3 ) = SGN*TR( 2, 1 )
END IF
BTMP( 1 ) = B( 1, 1 )
BTMP( 2 ) = B( 1, 2 )
GO TO 40
*
* 2 by 1:
* op[TL11 TL12]*[X11] + ISGN* [X11]*TR11 = [B11]
* [TL21 TL22] [X21] [X21] [B21]
*
30 CONTINUE
SMIN = MAX( EPS*MAX( ABS( TR( 1, 1 ) ), ABS( TL( 1, 1 ) ),
$ ABS( TL( 1, 2 ) ), ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ),
$ SMLNUM )
TMP( 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 )
TMP( 4 ) = TL( 2, 2 ) + SGN*TR( 1, 1 )
IF( LTRANL ) THEN
TMP( 2 ) = TL( 1, 2 )
TMP( 3 ) = TL( 2, 1 )
ELSE
TMP( 2 ) = TL( 2, 1 )
TMP( 3 ) = TL( 1, 2 )
END IF
BTMP( 1 ) = B( 1, 1 )
BTMP( 2 ) = B( 2, 1 )
40 CONTINUE
*
* Solve 2 by 2 system using complete pivoting.
* Set pivots less than SMIN to SMIN.
*
IPIV = IDAMAX( 4, TMP, 1 )
U11 = TMP( IPIV )
IF( ABS( U11 ).LE.SMIN ) THEN
INFO = 1
U11 = SMIN
END IF
U12 = TMP( LOCU12( IPIV ) )
L21 = TMP( LOCL21( IPIV ) ) / U11
U22 = TMP( LOCU22( IPIV ) ) - U12*L21
XSWAP = XSWPIV( IPIV )
BSWAP = BSWPIV( IPIV )
IF( ABS( U22 ).LE.SMIN ) THEN
INFO = 1
U22 = SMIN
END IF
IF( BSWAP ) THEN
TEMP = BTMP( 2 )
BTMP( 2 ) = BTMP( 1 ) - L21*TEMP
BTMP( 1 ) = TEMP
ELSE
BTMP( 2 ) = BTMP( 2 ) - L21*BTMP( 1 )
END IF
SCALE = ONE
IF( ( TWO*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( U22 ) .OR.
$ ( TWO*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( U11 ) ) THEN
SCALE = HALF / MAX( ABS( BTMP( 1 ) ), ABS( BTMP( 2 ) ) )
BTMP( 1 ) = BTMP( 1 )*SCALE
BTMP( 2 ) = BTMP( 2 )*SCALE
END IF
X2( 2 ) = BTMP( 2 ) / U22
X2( 1 ) = BTMP( 1 ) / U11 - ( U12 / U11 )*X2( 2 )
IF( XSWAP ) THEN
TEMP = X2( 2 )
X2( 2 ) = X2( 1 )
X2( 1 ) = TEMP
END IF
X( 1, 1 ) = X2( 1 )
IF( N1.EQ.1 ) THEN
X( 1, 2 ) = X2( 2 )
XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) )
ELSE
X( 2, 1 ) = X2( 2 )
XNORM = MAX( ABS( X( 1, 1 ) ), ABS( X( 2, 1 ) ) )
END IF
RETURN
*
* 2 by 2:
* op[TL11 TL12]*[X11 X12] +ISGN* [X11 X12]*op[TR11 TR12] = [B11 B12]
* [TL21 TL22] [X21 X22] [X21 X22] [TR21 TR22] [B21 B22]
*
* Solve equivalent 4 by 4 system using complete pivoting.
* Set pivots less than SMIN to SMIN.
*
50 CONTINUE
SMIN = MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ),
$ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) )
SMIN = MAX( SMIN, ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ),
$ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) )
SMIN = MAX( EPS*SMIN, SMLNUM )
BTMP( 1 ) = ZERO
CALL DCOPY( 16, BTMP, 0, T16, 1 )
T16( 1, 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 )
T16( 2, 2 ) = TL( 2, 2 ) + SGN*TR( 1, 1 )
T16( 3, 3 ) = TL( 1, 1 ) + SGN*TR( 2, 2 )
T16( 4, 4 ) = TL( 2, 2 ) + SGN*TR( 2, 2 )
IF( LTRANL ) THEN
T16( 1, 2 ) = TL( 2, 1 )
T16( 2, 1 ) = TL( 1, 2 )
T16( 3, 4 ) = TL( 2, 1 )
T16( 4, 3 ) = TL( 1, 2 )
ELSE
T16( 1, 2 ) = TL( 1, 2 )
T16( 2, 1 ) = TL( 2, 1 )
T16( 3, 4 ) = TL( 1, 2 )
T16( 4, 3 ) = TL( 2, 1 )
END IF
IF( LTRANR ) THEN
T16( 1, 3 ) = SGN*TR( 1, 2 )
T16( 2, 4 ) = SGN*TR( 1, 2 )
T16( 3, 1 ) = SGN*TR( 2, 1 )
T16( 4, 2 ) = SGN*TR( 2, 1 )
ELSE
T16( 1, 3 ) = SGN*TR( 2, 1 )
T16( 2, 4 ) = SGN*TR( 2, 1 )
T16( 3, 1 ) = SGN*TR( 1, 2 )
T16( 4, 2 ) = SGN*TR( 1, 2 )
END IF
BTMP( 1 ) = B( 1, 1 )
BTMP( 2 ) = B( 2, 1 )
BTMP( 3 ) = B( 1, 2 )
BTMP( 4 ) = B( 2, 2 )
*
* Perform elimination
*
DO 100 I = 1, 3
XMAX = ZERO
DO 70 IP = I, 4
DO 60 JP = I, 4
IF( ABS( T16( IP, JP ) ).GE.XMAX ) THEN
XMAX = ABS( T16( IP, JP ) )
IPSV = IP
JPSV = JP
END IF
60 CONTINUE
70 CONTINUE
IF( IPSV.NE.I ) THEN
CALL DSWAP( 4, T16( IPSV, 1 ), 4, T16( I, 1 ), 4 )
TEMP = BTMP( I )
BTMP( I ) = BTMP( IPSV )
BTMP( IPSV ) = TEMP
END IF
IF( JPSV.NE.I )
$ CALL DSWAP( 4, T16( 1, JPSV ), 1, T16( 1, I ), 1 )
JPIV( I ) = JPSV
IF( ABS( T16( I, I ) ).LT.SMIN ) THEN
INFO = 1
T16( I, I ) = SMIN
END IF
DO 90 J = I + 1, 4
T16( J, I ) = T16( J, I ) / T16( I, I )
BTMP( J ) = BTMP( J ) - T16( J, I )*BTMP( I )
DO 80 K = I + 1, 4
T16( J, K ) = T16( J, K ) - T16( J, I )*T16( I, K )
80 CONTINUE
90 CONTINUE
100 CONTINUE
IF( ABS( T16( 4, 4 ) ).LT.SMIN )
$ T16( 4, 4 ) = SMIN
SCALE = ONE
IF( ( EIGHT*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T16( 1, 1 ) ) .OR.
$ ( EIGHT*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T16( 2, 2 ) ) .OR.
$ ( EIGHT*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T16( 3, 3 ) ) .OR.
$ ( EIGHT*SMLNUM )*ABS( BTMP( 4 ) ).GT.ABS( T16( 4, 4 ) ) ) THEN
SCALE = ( ONE / EIGHT ) / MAX( ABS( BTMP( 1 ) ),
$ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ), ABS( BTMP( 4 ) ) )
BTMP( 1 ) = BTMP( 1 )*SCALE
BTMP( 2 ) = BTMP( 2 )*SCALE
BTMP( 3 ) = BTMP( 3 )*SCALE
BTMP( 4 ) = BTMP( 4 )*SCALE
END IF
DO 120 I = 1, 4
K = 5 - I
TEMP = ONE / T16( K, K )
TMP( K ) = BTMP( K )*TEMP
DO 110 J = K + 1, 4
TMP( K ) = TMP( K ) - ( TEMP*T16( K, J ) )*TMP( J )
110 CONTINUE
120 CONTINUE
DO 130 I = 1, 3
IF( JPIV( 4-I ).NE.4-I ) THEN
TEMP = TMP( 4-I )
TMP( 4-I ) = TMP( JPIV( 4-I ) )
TMP( JPIV( 4-I ) ) = TEMP
END IF
130 CONTINUE
X( 1, 1 ) = TMP( 1 )
X( 2, 1 ) = TMP( 2 )
X( 1, 2 ) = TMP( 3 )
X( 2, 2 ) = TMP( 4 )
XNORM = MAX( ABS( TMP( 1 ) )+ABS( TMP( 3 ) ),
$ ABS( TMP( 2 ) )+ABS( TMP( 4 ) ) )
RETURN
*
* End of DLASY2
*
END
SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, KB, LDA, LDW, N, NB
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * ), W( LDW, * )
* ..
*
* Purpose
* =======
*
* DLASYF computes a partial factorization of a real symmetric matrix A
* using the Bunch-Kaufman diagonal pivoting method. The partial
* factorization has the form:
*
* A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
* ( 0 U22 ) ( 0 D ) ( U12' U22' )
*
* A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L'
* ( L21 I ) ( 0 A22 ) ( 0 I )
*
* where the order of D is at most NB. The actual order is returned in
* the argument KB, and is either NB or NB-1, or N if N <= NB.
*
* DLASYF is an auxiliary routine called by DSYTRF. It uses blocked code
* (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or
* A22 (if UPLO = 'L').
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* NB (input) INTEGER
* The maximum number of columns of the matrix A that should be
* factored. NB should be at least 2 to allow for 2-by-2 pivot
* blocks.
*
* KB (output) INTEGER
* The number of columns of A that were actually factored.
* KB is either NB-1 or NB, or N if N <= NB.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the symmetric matrix A. If UPLO = 'U', the leading
* n-by-n upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading n-by-n lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced.
* On exit, A contains details of the partial factorization.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* IPIV (output) INTEGER array, dimension (N)
* Details of the interchanges and the block structure of D.
* If UPLO = 'U', only the last KB elements of IPIV are set;
* if UPLO = 'L', only the first KB elements are set.
*
* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
* interchanged and D(k,k) is a 1-by-1 diagonal block.
* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*
* W (workspace) DOUBLE PRECISION array, dimension (LDW,NB)
*
* LDW (input) INTEGER
* The leading dimension of the array W. LDW >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* > 0: if INFO = k, D(k,k) is exactly zero. The factorization
* has been completed, but the block diagonal matrix D is
* exactly singular.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION EIGHT, SEVTEN
PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
* ..
* .. Local Scalars ..
INTEGER IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP,
$ KSTEP, KW
DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D21, D22, R1,
$ ROWMAX, T
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
EXTERNAL LSAME, IDAMAX
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMM, DGEMV, DSCAL, DSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Initialize ALPHA for use in choosing pivot block size.
*
ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Factorize the trailing columns of A using the upper triangle
* of A and working backwards, and compute the matrix W = U12*D
* for use in updating A11
*
* K is the main loop index, decreasing from N in steps of 1 or 2
*
* KW is the column of W which corresponds to column K of A
*
K = N
10 CONTINUE
KW = NB + K - N
*
* Exit from loop
*
IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 )
$ GO TO 30
*
* Copy column K of A to column KW of W and update it
*
CALL DCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 )
IF( K.LT.N )
$ CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), LDA,
$ W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 )
*
KSTEP = 1
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = ABS( W( K, KW ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value
*
IF( K.GT.1 ) THEN
IMAX = IDAMAX( K-1, W( 1, KW ), 1 )
COLMAX = ABS( W( IMAX, KW ) )
ELSE
COLMAX = ZERO
END IF
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* Column K is zero: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
ELSE
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE
*
* Copy column IMAX to column KW-1 of W and update it
*
CALL DCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )
CALL DCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA,
$ W( IMAX+1, KW-1 ), 1 )
IF( K.LT.N )
$ CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ),
$ LDA, W( IMAX, KW+1 ), LDW, ONE,
$ W( 1, KW-1 ), 1 )
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value
*
JMAX = IMAX + IDAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 )
ROWMAX = ABS( W( JMAX, KW-1 ) )
IF( IMAX.GT.1 ) THEN
JMAX = IDAMAX( IMAX-1, W( 1, KW-1 ), 1 )
ROWMAX = MAX( ROWMAX, ABS( W( JMAX, KW-1 ) ) )
END IF
*
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE IF( ABS( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX ) THEN
*
* interchange rows and columns K and IMAX, use 1-by-1
* pivot block
*
KP = IMAX
*
* copy column KW-1 of W to column KW
*
CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
ELSE
*
* interchange rows and columns K-1 and IMAX, use 2-by-2
* pivot block
*
KP = IMAX
KSTEP = 2
END IF
END IF
*
KK = K - KSTEP + 1
KKW = NB + KK - N
*
* Updated column KP is already stored in column KKW of W
*
IF( KP.NE.KK ) THEN
*
* Copy non-updated column KK to column KP
*
A( KP, K ) = A( KK, K )
CALL DCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
$ LDA )
CALL DCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 )
*
* Interchange rows KK and KP in last KK columns of A and W
*
CALL DSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA )
CALL DSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
$ LDW )
END IF
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column KW of W now holds
*
* W(k) = U(k)*D(k)
*
* where U(k) is the k-th column of U
*
* Store U(k) in column k of A
*
CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
R1 = ONE / A( K, K )
CALL DSCAL( K-1, R1, A( 1, K ), 1 )
ELSE
*
* 2-by-2 pivot block D(k): columns KW and KW-1 of W now
* hold
*
* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
*
* where U(k) and U(k-1) are the k-th and (k-1)-th columns
* of U
*
IF( K.GT.2 ) THEN
*
* Store U(k) and U(k-1) in columns k and k-1 of A
*
D21 = W( K-1, KW )
D11 = W( K, KW ) / D21
D22 = W( K-1, KW-1 ) / D21
T = ONE / ( D11*D22-ONE )
D21 = T / D21
DO 20 J = 1, K - 2
A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) )
A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) )
20 CONTINUE
END IF
*
* Copy D(k) to A
*
A( K-1, K-1 ) = W( K-1, KW-1 )
A( K-1, K ) = W( K-1, KW )
A( K, K ) = W( K, KW )
END IF
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -KP
IPIV( K-1 ) = -KP
END IF
*
* Decrease K and return to the start of the main loop
*
K = K - KSTEP
GO TO 10
*
30 CONTINUE
*
* Update the upper triangle of A11 (= A(1:k,1:k)) as
*
* A11 := A11 - U12*D*U12' = A11 - U12*W'
*
* computing blocks of NB columns at a time
*
DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB
JB = MIN( NB, K-J+1 )
*
* Update the upper triangle of the diagonal block
*
DO 40 JJ = J, J + JB - 1
CALL DGEMV( 'No transpose', JJ-J+1, N-K, -ONE,
$ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, ONE,
$ A( J, JJ ), 1 )
40 CONTINUE
*
* Update the rectangular superdiagonal block
*
CALL DGEMM( 'No transpose', 'Transpose', J-1, JB, N-K, -ONE,
$ A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, ONE,
$ A( 1, J ), LDA )
50 CONTINUE
*
* Put U12 in standard form by partially undoing the interchanges
* in columns k+1:n
*
J = K + 1
60 CONTINUE
JJ = J
JP = IPIV( J )
IF( JP.LT.0 ) THEN
JP = -JP
J = J + 1
END IF
J = J + 1
IF( JP.NE.JJ .AND. J.LE.N )
$ CALL DSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA )
IF( J.LE.N )
$ GO TO 60
*
* Set KB to the number of columns factorized
*
KB = N - K
*
ELSE
*
* Factorize the leading columns of A using the lower triangle
* of A and working forwards, and compute the matrix W = L21*D
* for use in updating A22
*
* K is the main loop index, increasing from 1 in steps of 1 or 2
*
K = 1
70 CONTINUE
*
* Exit from loop
*
IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N )
$ GO TO 90
*
* Copy column K of A to column K of W and update it
*
CALL DCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 )
CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), LDA,
$ W( K, 1 ), LDW, ONE, W( K, K ), 1 )
*
KSTEP = 1
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = ABS( W( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value
*
IF( K.LT.N ) THEN
IMAX = K + IDAMAX( N-K, W( K+1, K ), 1 )
COLMAX = ABS( W( IMAX, K ) )
ELSE
COLMAX = ZERO
END IF
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* Column K is zero: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
ELSE
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE
*
* Copy column IMAX to column K+1 of W and update it
*
CALL DCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 )
CALL DCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, W( IMAX, K+1 ),
$ 1 )
CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ),
$ LDA, W( IMAX, 1 ), LDW, ONE, W( K, K+1 ), 1 )
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value
*
JMAX = K - 1 + IDAMAX( IMAX-K, W( K, K+1 ), 1 )
ROWMAX = ABS( W( JMAX, K+1 ) )
IF( IMAX.LT.N ) THEN
JMAX = IMAX + IDAMAX( N-IMAX, W( IMAX+1, K+1 ), 1 )
ROWMAX = MAX( ROWMAX, ABS( W( JMAX, K+1 ) ) )
END IF
*
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE IF( ABS( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX ) THEN
*
* interchange rows and columns K and IMAX, use 1-by-1
* pivot block
*
KP = IMAX
*
* copy column K+1 of W to column K
*
CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
ELSE
*
* interchange rows and columns K+1 and IMAX, use 2-by-2
* pivot block
*
KP = IMAX
KSTEP = 2
END IF
END IF
*
KK = K + KSTEP - 1
*
* Updated column KP is already stored in column KK of W
*
IF( KP.NE.KK ) THEN
*
* Copy non-updated column KK to column KP
*
A( KP, K ) = A( KK, K )
CALL DCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA )
CALL DCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 )
*
* Interchange rows KK and KP in first KK columns of A and W
*
CALL DSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
CALL DSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
END IF
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column k of W now holds
*
* W(k) = L(k)*D(k)
*
* where L(k) is the k-th column of L
*
* Store L(k) in column k of A
*
CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
IF( K.LT.N ) THEN
R1 = ONE / A( K, K )
CALL DSCAL( N-K, R1, A( K+1, K ), 1 )
END IF
ELSE
*
* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
*
* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
*
* where L(k) and L(k+1) are the k-th and (k+1)-th columns
* of L
*
IF( K.LT.N-1 ) THEN
*
* Store L(k) and L(k+1) in columns k and k+1 of A
*
D21 = W( K+1, K )
D11 = W( K+1, K+1 ) / D21
D22 = W( K, K ) / D21
T = ONE / ( D11*D22-ONE )
D21 = T / D21
DO 80 J = K + 2, N
A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) )
A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) )
80 CONTINUE
END IF
*
* Copy D(k) to A
*
A( K, K ) = W( K, K )
A( K+1, K ) = W( K+1, K )
A( K+1, K+1 ) = W( K+1, K+1 )
END IF
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -KP
IPIV( K+1 ) = -KP
END IF
*
* Increase K and return to the start of the main loop
*
K = K + KSTEP
GO TO 70
*
90 CONTINUE
*
* Update the lower triangle of A22 (= A(k:n,k:n)) as
*
* A22 := A22 - L21*D*L21' = A22 - L21*W'
*
* computing blocks of NB columns at a time
*
DO 110 J = K, N, NB
JB = MIN( NB, N-J+1 )
*
* Update the lower triangle of the diagonal block
*
DO 100 JJ = J, J + JB - 1
CALL DGEMV( 'No transpose', J+JB-JJ, K-1, -ONE,
$ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, ONE,
$ A( JJ, JJ ), 1 )
100 CONTINUE
*
* Update the rectangular subdiagonal block
*
IF( J+JB.LE.N )
$ CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
$ K-1, -ONE, A( J+JB, 1 ), LDA, W( J, 1 ), LDW,
$ ONE, A( J+JB, J ), LDA )
110 CONTINUE
*
* Put L21 in standard form by partially undoing the interchanges
* in columns 1:k-1
*
J = K - 1
120 CONTINUE
JJ = J
JP = IPIV( J )
IF( JP.LT.0 ) THEN
JP = -JP
J = J - 1
END IF
J = J - 1
IF( JP.NE.JJ .AND. J.GE.1 )
$ CALL DSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA )
IF( J.GE.1 )
$ GO TO 120
*
* Set KB to the number of columns factorized
*
KB = K - 1
*
END IF
RETURN
*
* End of DLASYF
*
END
SUBROUTINE DLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X,
$ SCALE, CNORM, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, NORMIN, TRANS, UPLO
INTEGER INFO, KD, LDAB, N
DOUBLE PRECISION SCALE
* ..
* .. Array Arguments ..
DOUBLE PRECISION AB( LDAB, * ), CNORM( * ), X( * )
* ..
*
* Purpose
* =======
*
* DLATBS solves one of the triangular systems
*
* A *x = s*b or A'*x = s*b
*
* with scaling to prevent overflow, where A is an upper or lower
* triangular band matrix. Here A' denotes the transpose of A, x and b
* are n-element vectors, and s is a scaling factor, usually less than
* or equal to 1, chosen so that the components of x will be less than
* the overflow threshold. If the unscaled problem will not cause
* overflow, the Level 2 BLAS routine DTBSV is called. If the matrix A
* is singular (A(j,j) = 0 for some j), then s is set to 0 and a
* non-trivial solution to A*x = 0 is returned.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the operation applied to A.
* = 'N': Solve A * x = s*b (No transpose)
* = 'T': Solve A'* x = s*b (Transpose)
* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* NORMIN (input) CHARACTER*1
* Specifies whether CNORM has been set or not.
* = 'Y': CNORM contains the column norms on entry
* = 'N': CNORM is not set on entry. On exit, the norms will
* be computed and stored in CNORM.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of subdiagonals or superdiagonals in the
* triangular matrix A. KD >= 0.
*
* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
* The upper or lower triangular band matrix A, stored in the
* first KD+1 rows of the array. The j-th column of A is stored
* in the j-th column of the array AB as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* X (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the right hand side b of the triangular system.
* On exit, X is overwritten by the solution vector x.
*
* SCALE (output) DOUBLE PRECISION
* The scaling factor s for the triangular system
* A * x = s*b or A'* x = s*b.
* If SCALE = 0, the matrix A is singular or badly scaled, and
* the vector x is an exact or approximate solution to A*x = 0.
*
* CNORM (input or output) DOUBLE PRECISION array, dimension (N)
*
* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
* contains the norm of the off-diagonal part of the j-th column
* of A. If TRANS = 'N', CNORM(j) must be greater than or equal
* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
* must be greater than or equal to the 1-norm.
*
* If NORMIN = 'N', CNORM is an output argument and CNORM(j)
* returns the 1-norm of the offdiagonal part of the j-th column
* of A.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
*
* Further Details
* ======= =======
*
* A rough bound on x is computed; if that is less than overflow, DTBSV
* is called, otherwise, specific code is used which checks for possible
* overflow or divide-by-zero at every operation.
*
* A columnwise scheme is used for solving A*x = b. The basic algorithm
* if A is lower triangular is
*
* x[1:n] := b[1:n]
* for j = 1, ..., n
* x(j) := x(j) / A(j,j)
* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
* end
*
* Define bounds on the components of x after j iterations of the loop:
* M(j) = bound on x[1:j]
* G(j) = bound on x[j+1:n]
* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
*
* Then for iteration j+1 we have
* M(j+1) <= G(j) / | A(j+1,j+1) |
* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
*
* where CNORM(j+1) is greater than or equal to the infinity-norm of
* column j+1 of A, not counting the diagonal. Hence
*
* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
* 1<=i<=j
* and
*
* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
* 1<=i< j
*
* Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTBSV if the
* reciprocal of the largest M(j), j=1,..,n, is larger than
* max(underflow, 1/overflow).
*
* The bound on x(j) is also used to determine when a step in the
* columnwise method can be performed without fear of overflow. If
* the computed bound is greater than a large constant, x is scaled to
* prevent overflow, but if the bound overflows, x is set to 0, x(j) to
* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
*
* Similarly, a row-wise scheme is used to solve A'*x = b. The basic
* algorithm for A upper triangular is
*
* for j = 1, ..., n
* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)
* end
*
* We simultaneously compute two bounds
* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j
* M(j) = bound on x(i), 1<=i<=j
*
* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
* Then the bound on x(j) is
*
* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
*
* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
* 1<=i<=j
*
* and we can safely call DTBSV if 1/M(n) and 1/G(n) are both greater
* than max(underflow, 1/overflow).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN, NOUNIT, UPPER
INTEGER I, IMAX, J, JFIRST, JINC, JLAST, JLEN, MAIND
DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS,
$ TMAX, TSCAL, USCAL, XBND, XJ, XMAX
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DASUM, DDOT, DLAMCH
EXTERNAL LSAME, IDAMAX, DASUM, DDOT, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DSCAL, DTBSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOTRAN = LSAME( TRANS, 'N' )
NOUNIT = LSAME( DIAG, 'N' )
*
* Test the input parameters.
*
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
$ LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -3
ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT.
$ LSAME( NORMIN, 'N' ) ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( KD.LT.0 ) THEN
INFO = -6
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLATBS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Determine machine dependent parameters to control overflow.
*
SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
BIGNUM = ONE / SMLNUM
SCALE = ONE
*
IF( LSAME( NORMIN, 'N' ) ) THEN
*
* Compute the 1-norm of each column, not including the diagonal.
*
IF( UPPER ) THEN
*
* A is upper triangular.
*
DO 10 J = 1, N
JLEN = MIN( KD, J-1 )
CNORM( J ) = DASUM( JLEN, AB( KD+1-JLEN, J ), 1 )
10 CONTINUE
ELSE
*
* A is lower triangular.
*
DO 20 J = 1, N
JLEN = MIN( KD, N-J )
IF( JLEN.GT.0 ) THEN
CNORM( J ) = DASUM( JLEN, AB( 2, J ), 1 )
ELSE
CNORM( J ) = ZERO
END IF
20 CONTINUE
END IF
END IF
*
* Scale the column norms by TSCAL if the maximum element in CNORM is
* greater than BIGNUM.
*
IMAX = IDAMAX( N, CNORM, 1 )
TMAX = CNORM( IMAX )
IF( TMAX.LE.BIGNUM ) THEN
TSCAL = ONE
ELSE
TSCAL = ONE / ( SMLNUM*TMAX )
CALL DSCAL( N, TSCAL, CNORM, 1 )
END IF
*
* Compute a bound on the computed solution vector to see if the
* Level 2 BLAS routine DTBSV can be used.
*
J = IDAMAX( N, X, 1 )
XMAX = ABS( X( J ) )
XBND = XMAX
IF( NOTRAN ) THEN
*
* Compute the growth in A * x = b.
*
IF( UPPER ) THEN
JFIRST = N
JLAST = 1
JINC = -1
MAIND = KD + 1
ELSE
JFIRST = 1
JLAST = N
JINC = 1
MAIND = 1
END IF
*
IF( TSCAL.NE.ONE ) THEN
GROW = ZERO
GO TO 50
END IF
*
IF( NOUNIT ) THEN
*
* A is non-unit triangular.
*
* Compute GROW = 1/G(j) and XBND = 1/M(j).
* Initially, G(0) = max{x(i), i=1,...,n}.
*
GROW = ONE / MAX( XBND, SMLNUM )
XBND = GROW
DO 30 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 50
*
* M(j) = G(j-1) / abs(A(j,j))
*
TJJ = ABS( AB( MAIND, J ) )
XBND = MIN( XBND, MIN( ONE, TJJ )*GROW )
IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN
*
* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
*
GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) )
ELSE
*
* G(j) could overflow, set GROW to 0.
*
GROW = ZERO
END IF
30 CONTINUE
GROW = XBND
ELSE
*
* A is unit triangular.
*
* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
*
GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
DO 40 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 50
*
* G(j) = G(j-1)*( 1 + CNORM(j) )
*
GROW = GROW*( ONE / ( ONE+CNORM( J ) ) )
40 CONTINUE
END IF
50 CONTINUE
*
ELSE
*
* Compute the growth in A' * x = b.
*
IF( UPPER ) THEN
JFIRST = 1
JLAST = N
JINC = 1
MAIND = KD + 1
ELSE
JFIRST = N
JLAST = 1
JINC = -1
MAIND = 1
END IF
*
IF( TSCAL.NE.ONE ) THEN
GROW = ZERO
GO TO 80
END IF
*
IF( NOUNIT ) THEN
*
* A is non-unit triangular.
*
* Compute GROW = 1/G(j) and XBND = 1/M(j).
* Initially, M(0) = max{x(i), i=1,...,n}.
*
GROW = ONE / MAX( XBND, SMLNUM )
XBND = GROW
DO 60 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 80
*
* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
*
XJ = ONE + CNORM( J )
GROW = MIN( GROW, XBND / XJ )
*
* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
*
TJJ = ABS( AB( MAIND, J ) )
IF( XJ.GT.TJJ )
$ XBND = XBND*( TJJ / XJ )
60 CONTINUE
GROW = MIN( GROW, XBND )
ELSE
*
* A is unit triangular.
*
* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
*
GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
DO 70 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 80
*
* G(j) = ( 1 + CNORM(j) )*G(j-1)
*
XJ = ONE + CNORM( J )
GROW = GROW / XJ
70 CONTINUE
END IF
80 CONTINUE
END IF
*
IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN
*
* Use the Level 2 BLAS solve if the reciprocal of the bound on
* elements of X is not too small.
*
CALL DTBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, X, 1 )
ELSE
*
* Use a Level 1 BLAS solve, scaling intermediate results.
*
IF( XMAX.GT.BIGNUM ) THEN
*
* Scale X so that its components are less than or equal to
* BIGNUM in absolute value.
*
SCALE = BIGNUM / XMAX
CALL DSCAL( N, SCALE, X, 1 )
XMAX = BIGNUM
END IF
*
IF( NOTRAN ) THEN
*
* Solve A * x = b
*
DO 110 J = JFIRST, JLAST, JINC
*
* Compute x(j) = b(j) / A(j,j), scaling x if necessary.
*
XJ = ABS( X( J ) )
IF( NOUNIT ) THEN
TJJS = AB( MAIND, J )*TSCAL
ELSE
TJJS = TSCAL
IF( TSCAL.EQ.ONE )
$ GO TO 100
END IF
TJJ = ABS( TJJS )
IF( TJJ.GT.SMLNUM ) THEN
*
* abs(A(j,j)) > SMLNUM:
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale x by 1/b(j).
*
REC = ONE / XJ
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
X( J ) = X( J ) / TJJS
XJ = ABS( X( J ) )
ELSE IF( TJJ.GT.ZERO ) THEN
*
* 0 < abs(A(j,j)) <= SMLNUM:
*
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
* to avoid overflow when dividing by A(j,j).
*
REC = ( TJJ*BIGNUM ) / XJ
IF( CNORM( J ).GT.ONE ) THEN
*
* Scale by 1/CNORM(j) to avoid overflow when
* multiplying x(j) times column j.
*
REC = REC / CNORM( J )
END IF
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
X( J ) = X( J ) / TJJS
XJ = ABS( X( J ) )
ELSE
*
* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
* scale = 0, and compute a solution to A*x = 0.
*
DO 90 I = 1, N
X( I ) = ZERO
90 CONTINUE
X( J ) = ONE
XJ = ONE
SCALE = ZERO
XMAX = ZERO
END IF
100 CONTINUE
*
* Scale x if necessary to avoid overflow when adding a
* multiple of column j of A.
*
IF( XJ.GT.ONE ) THEN
REC = ONE / XJ
IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN
*
* Scale x by 1/(2*abs(x(j))).
*
REC = REC*HALF
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
END IF
ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
*
* Scale x by 1/2.
*
CALL DSCAL( N, HALF, X, 1 )
SCALE = SCALE*HALF
END IF
*
IF( UPPER ) THEN
IF( J.GT.1 ) THEN
*
* Compute the update
* x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) -
* x(j)* A(max(1,j-kd):j-1,j)
*
JLEN = MIN( KD, J-1 )
CALL DAXPY( JLEN, -X( J )*TSCAL,
$ AB( KD+1-JLEN, J ), 1, X( J-JLEN ), 1 )
I = IDAMAX( J-1, X, 1 )
XMAX = ABS( X( I ) )
END IF
ELSE IF( J.LT.N ) THEN
*
* Compute the update
* x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) -
* x(j) * A(j+1:min(j+kd,n),j)
*
JLEN = MIN( KD, N-J )
IF( JLEN.GT.0 )
$ CALL DAXPY( JLEN, -X( J )*TSCAL, AB( 2, J ), 1,
$ X( J+1 ), 1 )
I = J + IDAMAX( N-J, X( J+1 ), 1 )
XMAX = ABS( X( I ) )
END IF
110 CONTINUE
*
ELSE
*
* Solve A' * x = b
*
DO 160 J = JFIRST, JLAST, JINC
*
* Compute x(j) = b(j) - sum A(k,j)*x(k).
* k<>j
*
XJ = ABS( X( J ) )
USCAL = TSCAL
REC = ONE / MAX( XMAX, ONE )
IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
*
* If x(j) could overflow, scale x by 1/(2*XMAX).
*
REC = REC*HALF
IF( NOUNIT ) THEN
TJJS = AB( MAIND, J )*TSCAL
ELSE
TJJS = TSCAL
END IF
TJJ = ABS( TJJS )
IF( TJJ.GT.ONE ) THEN
*
* Divide by A(j,j) when scaling x if A(j,j) > 1.
*
REC = MIN( ONE, REC*TJJ )
USCAL = USCAL / TJJS
END IF
IF( REC.LT.ONE ) THEN
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
*
SUMJ = ZERO
IF( USCAL.EQ.ONE ) THEN
*
* If the scaling needed for A in the dot product is 1,
* call DDOT to perform the dot product.
*
IF( UPPER ) THEN
JLEN = MIN( KD, J-1 )
SUMJ = DDOT( JLEN, AB( KD+1-JLEN, J ), 1,
$ X( J-JLEN ), 1 )
ELSE
JLEN = MIN( KD, N-J )
IF( JLEN.GT.0 )
$ SUMJ = DDOT( JLEN, AB( 2, J ), 1, X( J+1 ), 1 )
END IF
ELSE
*
* Otherwise, use in-line code for the dot product.
*
IF( UPPER ) THEN
JLEN = MIN( KD, J-1 )
DO 120 I = 1, JLEN
SUMJ = SUMJ + ( AB( KD+I-JLEN, J )*USCAL )*
$ X( J-JLEN-1+I )
120 CONTINUE
ELSE
JLEN = MIN( KD, N-J )
DO 130 I = 1, JLEN
SUMJ = SUMJ + ( AB( I+1, J )*USCAL )*X( J+I )
130 CONTINUE
END IF
END IF
*
IF( USCAL.EQ.TSCAL ) THEN
*
* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j)
* was not used to scale the dotproduct.
*
X( J ) = X( J ) - SUMJ
XJ = ABS( X( J ) )
IF( NOUNIT ) THEN
*
* Compute x(j) = x(j) / A(j,j), scaling if necessary.
*
TJJS = AB( MAIND, J )*TSCAL
ELSE
TJJS = TSCAL
IF( TSCAL.EQ.ONE )
$ GO TO 150
END IF
TJJ = ABS( TJJS )
IF( TJJ.GT.SMLNUM ) THEN
*
* abs(A(j,j)) > SMLNUM:
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale X by 1/abs(x(j)).
*
REC = ONE / XJ
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
X( J ) = X( J ) / TJJS
ELSE IF( TJJ.GT.ZERO ) THEN
*
* 0 < abs(A(j,j)) <= SMLNUM:
*
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
*
REC = ( TJJ*BIGNUM ) / XJ
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
X( J ) = X( J ) / TJJS
ELSE
*
* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
* scale = 0, and compute a solution to A'*x = 0.
*
DO 140 I = 1, N
X( I ) = ZERO
140 CONTINUE
X( J ) = ONE
SCALE = ZERO
XMAX = ZERO
END IF
150 CONTINUE
ELSE
*
* Compute x(j) := x(j) / A(j,j) - sumj if the dot
* product has already been divided by 1/A(j,j).
*
X( J ) = X( J ) / TJJS - SUMJ
END IF
XMAX = MAX( XMAX, ABS( X( J ) ) )
160 CONTINUE
END IF
SCALE = SCALE / TSCAL
END IF
*
* Scale the column norms by 1/TSCAL for return.
*
IF( TSCAL.NE.ONE ) THEN
CALL DSCAL( N, ONE / TSCAL, CNORM, 1 )
END IF
*
RETURN
*
* End of DLATBS
*
END
SUBROUTINE DLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV,
$ JPIV )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IJOB, LDZ, N
DOUBLE PRECISION RDSCAL, RDSUM
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), JPIV( * )
DOUBLE PRECISION RHS( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DLATDF uses the LU factorization of the n-by-n matrix Z computed by
* DGETC2 and computes a contribution to the reciprocal Dif-estimate
* by solving Z * x = b for x, and choosing the r.h.s. b such that
* the norm of x is as large as possible. On entry RHS = b holds the
* contribution from earlier solved sub-systems, and on return RHS = x.
*
* The factorization of Z returned by DGETC2 has the form Z = P*L*U*Q,
* where P and Q are permutation matrices. L is lower triangular with
* unit diagonal elements and U is upper triangular.
*
* Arguments
* =========
*
* IJOB (input) INTEGER
* IJOB = 2: First compute an approximative null-vector e
* of Z using DGECON, e is normalized and solve for
* Zx = +-e - f with the sign giving the greater value
* of 2-norm(x). About 5 times as expensive as Default.
* IJOB .ne. 2: Local look ahead strategy where all entries of
* the r.h.s. b is choosen as either +1 or -1 (Default).
*
* N (input) INTEGER
* The number of columns of the matrix Z.
*
* Z (input) DOUBLE PRECISION array, dimension (LDZ, N)
* On entry, the LU part of the factorization of the n-by-n
* matrix Z computed by DGETC2: Z = P * L * U * Q
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDA >= max(1, N).
*
* RHS (input/output) DOUBLE PRECISION array, dimension N.
* On entry, RHS contains contributions from other subsystems.
* On exit, RHS contains the solution of the subsystem with
* entries acoording to the value of IJOB (see above).
*
* RDSUM (input/output) DOUBLE PRECISION
* On entry, the sum of squares of computed contributions to
* the Dif-estimate under computation by DTGSYL, where the
* scaling factor RDSCAL (see below) has been factored out.
* On exit, the corresponding sum of squares updated with the
* contributions from the current sub-system.
* If TRANS = 'T' RDSUM is not touched.
* NOTE: RDSUM only makes sense when DTGSY2 is called by STGSYL.
*
* RDSCAL (input/output) DOUBLE PRECISION
* On entry, scaling factor used to prevent overflow in RDSUM.
* On exit, RDSCAL is updated w.r.t. the current contributions
* in RDSUM.
* If TRANS = 'T', RDSCAL is not touched.
* NOTE: RDSCAL only makes sense when DTGSY2 is called by
* DTGSYL.
*
* IPIV (input) INTEGER array, dimension (N).
* The pivot indices; for 1 <= i <= N, row i of the
* matrix has been interchanged with row IPIV(i).
*
* JPIV (input) INTEGER array, dimension (N).
* The pivot indices; for 1 <= j <= N, column j of the
* matrix has been interchanged with column JPIV(j).
*
* Further Details
* ===============
*
* Based on contributions by
* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
* Umea University, S-901 87 Umea, Sweden.
*
* This routine is a further developed implementation of algorithm
* BSOLVE in [1] using complete pivoting in the LU factorization.
*
* [1] Bo Kagstrom and Lars Westin,
* Generalized Schur Methods with Condition Estimators for
* Solving the Generalized Sylvester Equation, IEEE Transactions
* on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.
*
* [2] Peter Poromaa,
* On Efficient and Robust Estimators for the Separation
* between two Regular Matrix Pairs with Applications in
* Condition Estimation. Report IMINF-95.05, Departement of
* Computing Science, Umea University, S-901 87 Umea, Sweden, 1995.
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXDIM
PARAMETER ( MAXDIM = 8 )
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J, K
DOUBLE PRECISION BM, BP, PMONE, SMINU, SPLUS, TEMP
* ..
* .. Local Arrays ..
INTEGER IWORK( MAXDIM )
DOUBLE PRECISION WORK( 4*MAXDIM ), XM( MAXDIM ), XP( MAXDIM )
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DGECON, DGESC2, DLASSQ, DLASWP,
$ DSCAL
* ..
* .. External Functions ..
DOUBLE PRECISION DASUM, DDOT
EXTERNAL DASUM, DDOT
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SQRT
* ..
* .. Executable Statements ..
*
IF( IJOB.NE.2 ) THEN
*
* Apply permutations IPIV to RHS
*
CALL DLASWP( 1, RHS, LDZ, 1, N-1, IPIV, 1 )
*
* Solve for L-part choosing RHS either to +1 or -1.
*
PMONE = -ONE
*
DO 10 J = 1, N - 1
BP = RHS( J ) + ONE
BM = RHS( J ) - ONE
SPLUS = ONE
*
* Look-ahead for L-part RHS(1:N-1) = + or -1, SPLUS and
* SMIN computed more efficiently than in BSOLVE [1].
*
SPLUS = SPLUS + DDOT( N-J, Z( J+1, J ), 1, Z( J+1, J ), 1 )
SMINU = DDOT( N-J, Z( J+1, J ), 1, RHS( J+1 ), 1 )
SPLUS = SPLUS*RHS( J )
IF( SPLUS.GT.SMINU ) THEN
RHS( J ) = BP
ELSE IF( SMINU.GT.SPLUS ) THEN
RHS( J ) = BM
ELSE
*
* In this case the updating sums are equal and we can
* choose RHS(J) +1 or -1. The first time this happens
* we choose -1, thereafter +1. This is a simple way to
* get good estimates of matrices like Byers well-known
* example (see [1]). (Not done in BSOLVE.)
*
RHS( J ) = RHS( J ) + PMONE
PMONE = ONE
END IF
*
* Compute the remaining r.h.s.
*
TEMP = -RHS( J )
CALL DAXPY( N-J, TEMP, Z( J+1, J ), 1, RHS( J+1 ), 1 )
*
10 CONTINUE
*
* Solve for U-part, look-ahead for RHS(N) = +-1. This is not done
* in BSOLVE and will hopefully give us a better estimate because
* any ill-conditioning of the original matrix is transfered to U
* and not to L. U(N, N) is an approximation to sigma_min(LU).
*
CALL DCOPY( N-1, RHS, 1, XP, 1 )
XP( N ) = RHS( N ) + ONE
RHS( N ) = RHS( N ) - ONE
SPLUS = ZERO
SMINU = ZERO
DO 30 I = N, 1, -1
TEMP = ONE / Z( I, I )
XP( I ) = XP( I )*TEMP
RHS( I ) = RHS( I )*TEMP
DO 20 K = I + 1, N
XP( I ) = XP( I ) - XP( K )*( Z( I, K )*TEMP )
RHS( I ) = RHS( I ) - RHS( K )*( Z( I, K )*TEMP )
20 CONTINUE
SPLUS = SPLUS + ABS( XP( I ) )
SMINU = SMINU + ABS( RHS( I ) )
30 CONTINUE
IF( SPLUS.GT.SMINU )
$ CALL DCOPY( N, XP, 1, RHS, 1 )
*
* Apply the permutations JPIV to the computed solution (RHS)
*
CALL DLASWP( 1, RHS, LDZ, 1, N-1, JPIV, -1 )
*
* Compute the sum of squares
*
CALL DLASSQ( N, RHS, 1, RDSCAL, RDSUM )
*
ELSE
*
* IJOB = 2, Compute approximate nullvector XM of Z
*
CALL DGECON( 'I', N, Z, LDZ, ONE, TEMP, WORK, IWORK, INFO )
CALL DCOPY( N, WORK( N+1 ), 1, XM, 1 )
*
* Compute RHS
*
CALL DLASWP( 1, XM, LDZ, 1, N-1, IPIV, -1 )
TEMP = ONE / SQRT( DDOT( N, XM, 1, XM, 1 ) )
CALL DSCAL( N, TEMP, XM, 1 )
CALL DCOPY( N, XM, 1, XP, 1 )
CALL DAXPY( N, ONE, RHS, 1, XP, 1 )
CALL DAXPY( N, -ONE, XM, 1, RHS, 1 )
CALL DGESC2( N, Z, LDZ, RHS, IPIV, JPIV, TEMP )
CALL DGESC2( N, Z, LDZ, XP, IPIV, JPIV, TEMP )
IF( DASUM( N, XP, 1 ).GT.DASUM( N, RHS, 1 ) )
$ CALL DCOPY( N, XP, 1, RHS, 1 )
*
* Compute the sum of squares
*
CALL DLASSQ( N, RHS, 1, RDSCAL, RDSUM )
*
END IF
*
RETURN
*
* End of DLATDF
*
END
SUBROUTINE DLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE,
$ CNORM, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, NORMIN, TRANS, UPLO
INTEGER INFO, N
DOUBLE PRECISION SCALE
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP( * ), CNORM( * ), X( * )
* ..
*
* Purpose
* =======
*
* DLATPS solves one of the triangular systems
*
* A *x = s*b or A'*x = s*b
*
* with scaling to prevent overflow, where A is an upper or lower
* triangular matrix stored in packed form. Here A' denotes the
* transpose of A, x and b are n-element vectors, and s is a scaling
* factor, usually less than or equal to 1, chosen so that the
* components of x will be less than the overflow threshold. If the
* unscaled problem will not cause overflow, the Level 2 BLAS routine
* DTPSV is called. If the matrix A is singular (A(j,j) = 0 for some j),
* then s is set to 0 and a non-trivial solution to A*x = 0 is returned.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the operation applied to A.
* = 'N': Solve A * x = s*b (No transpose)
* = 'T': Solve A'* x = s*b (Transpose)
* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* NORMIN (input) CHARACTER*1
* Specifies whether CNORM has been set or not.
* = 'Y': CNORM contains the column norms on entry
* = 'N': CNORM is not set on entry. On exit, the norms will
* be computed and stored in CNORM.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The upper or lower triangular matrix A, packed columnwise in
* a linear array. The j-th column of A is stored in the array
* AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
*
* X (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the right hand side b of the triangular system.
* On exit, X is overwritten by the solution vector x.
*
* SCALE (output) DOUBLE PRECISION
* The scaling factor s for the triangular system
* A * x = s*b or A'* x = s*b.
* If SCALE = 0, the matrix A is singular or badly scaled, and
* the vector x is an exact or approximate solution to A*x = 0.
*
* CNORM (input or output) DOUBLE PRECISION array, dimension (N)
*
* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
* contains the norm of the off-diagonal part of the j-th column
* of A. If TRANS = 'N', CNORM(j) must be greater than or equal
* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
* must be greater than or equal to the 1-norm.
*
* If NORMIN = 'N', CNORM is an output argument and CNORM(j)
* returns the 1-norm of the offdiagonal part of the j-th column
* of A.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
*
* Further Details
* ======= =======
*
* A rough bound on x is computed; if that is less than overflow, DTPSV
* is called, otherwise, specific code is used which checks for possible
* overflow or divide-by-zero at every operation.
*
* A columnwise scheme is used for solving A*x = b. The basic algorithm
* if A is lower triangular is
*
* x[1:n] := b[1:n]
* for j = 1, ..., n
* x(j) := x(j) / A(j,j)
* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
* end
*
* Define bounds on the components of x after j iterations of the loop:
* M(j) = bound on x[1:j]
* G(j) = bound on x[j+1:n]
* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
*
* Then for iteration j+1 we have
* M(j+1) <= G(j) / | A(j+1,j+1) |
* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
*
* where CNORM(j+1) is greater than or equal to the infinity-norm of
* column j+1 of A, not counting the diagonal. Hence
*
* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
* 1<=i<=j
* and
*
* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
* 1<=i< j
*
* Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTPSV if the
* reciprocal of the largest M(j), j=1,..,n, is larger than
* max(underflow, 1/overflow).
*
* The bound on x(j) is also used to determine when a step in the
* columnwise method can be performed without fear of overflow. If
* the computed bound is greater than a large constant, x is scaled to
* prevent overflow, but if the bound overflows, x is set to 0, x(j) to
* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
*
* Similarly, a row-wise scheme is used to solve A'*x = b. The basic
* algorithm for A upper triangular is
*
* for j = 1, ..., n
* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)
* end
*
* We simultaneously compute two bounds
* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j
* M(j) = bound on x(i), 1<=i<=j
*
* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
* Then the bound on x(j) is
*
* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
*
* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
* 1<=i<=j
*
* and we can safely call DTPSV if 1/M(n) and 1/G(n) are both greater
* than max(underflow, 1/overflow).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN, NOUNIT, UPPER
INTEGER I, IMAX, IP, J, JFIRST, JINC, JLAST, JLEN
DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS,
$ TMAX, TSCAL, USCAL, XBND, XJ, XMAX
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DASUM, DDOT, DLAMCH
EXTERNAL LSAME, IDAMAX, DASUM, DDOT, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DSCAL, DTPSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOTRAN = LSAME( TRANS, 'N' )
NOUNIT = LSAME( DIAG, 'N' )
*
* Test the input parameters.
*
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
$ LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -3
ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT.
$ LSAME( NORMIN, 'N' ) ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLATPS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Determine machine dependent parameters to control overflow.
*
SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
BIGNUM = ONE / SMLNUM
SCALE = ONE
*
IF( LSAME( NORMIN, 'N' ) ) THEN
*
* Compute the 1-norm of each column, not including the diagonal.
*
IF( UPPER ) THEN
*
* A is upper triangular.
*
IP = 1
DO 10 J = 1, N
CNORM( J ) = DASUM( J-1, AP( IP ), 1 )
IP = IP + J
10 CONTINUE
ELSE
*
* A is lower triangular.
*
IP = 1
DO 20 J = 1, N - 1
CNORM( J ) = DASUM( N-J, AP( IP+1 ), 1 )
IP = IP + N - J + 1
20 CONTINUE
CNORM( N ) = ZERO
END IF
END IF
*
* Scale the column norms by TSCAL if the maximum element in CNORM is
* greater than BIGNUM.
*
IMAX = IDAMAX( N, CNORM, 1 )
TMAX = CNORM( IMAX )
IF( TMAX.LE.BIGNUM ) THEN
TSCAL = ONE
ELSE
TSCAL = ONE / ( SMLNUM*TMAX )
CALL DSCAL( N, TSCAL, CNORM, 1 )
END IF
*
* Compute a bound on the computed solution vector to see if the
* Level 2 BLAS routine DTPSV can be used.
*
J = IDAMAX( N, X, 1 )
XMAX = ABS( X( J ) )
XBND = XMAX
IF( NOTRAN ) THEN
*
* Compute the growth in A * x = b.
*
IF( UPPER ) THEN
JFIRST = N
JLAST = 1
JINC = -1
ELSE
JFIRST = 1
JLAST = N
JINC = 1
END IF
*
IF( TSCAL.NE.ONE ) THEN
GROW = ZERO
GO TO 50
END IF
*
IF( NOUNIT ) THEN
*
* A is non-unit triangular.
*
* Compute GROW = 1/G(j) and XBND = 1/M(j).
* Initially, G(0) = max{x(i), i=1,...,n}.
*
GROW = ONE / MAX( XBND, SMLNUM )
XBND = GROW
IP = JFIRST*( JFIRST+1 ) / 2
JLEN = N
DO 30 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 50
*
* M(j) = G(j-1) / abs(A(j,j))
*
TJJ = ABS( AP( IP ) )
XBND = MIN( XBND, MIN( ONE, TJJ )*GROW )
IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN
*
* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
*
GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) )
ELSE
*
* G(j) could overflow, set GROW to 0.
*
GROW = ZERO
END IF
IP = IP + JINC*JLEN
JLEN = JLEN - 1
30 CONTINUE
GROW = XBND
ELSE
*
* A is unit triangular.
*
* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
*
GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
DO 40 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 50
*
* G(j) = G(j-1)*( 1 + CNORM(j) )
*
GROW = GROW*( ONE / ( ONE+CNORM( J ) ) )
40 CONTINUE
END IF
50 CONTINUE
*
ELSE
*
* Compute the growth in A' * x = b.
*
IF( UPPER ) THEN
JFIRST = 1
JLAST = N
JINC = 1
ELSE
JFIRST = N
JLAST = 1
JINC = -1
END IF
*
IF( TSCAL.NE.ONE ) THEN
GROW = ZERO
GO TO 80
END IF
*
IF( NOUNIT ) THEN
*
* A is non-unit triangular.
*
* Compute GROW = 1/G(j) and XBND = 1/M(j).
* Initially, M(0) = max{x(i), i=1,...,n}.
*
GROW = ONE / MAX( XBND, SMLNUM )
XBND = GROW
IP = JFIRST*( JFIRST+1 ) / 2
JLEN = 1
DO 60 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 80
*
* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
*
XJ = ONE + CNORM( J )
GROW = MIN( GROW, XBND / XJ )
*
* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
*
TJJ = ABS( AP( IP ) )
IF( XJ.GT.TJJ )
$ XBND = XBND*( TJJ / XJ )
JLEN = JLEN + 1
IP = IP + JINC*JLEN
60 CONTINUE
GROW = MIN( GROW, XBND )
ELSE
*
* A is unit triangular.
*
* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
*
GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
DO 70 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 80
*
* G(j) = ( 1 + CNORM(j) )*G(j-1)
*
XJ = ONE + CNORM( J )
GROW = GROW / XJ
70 CONTINUE
END IF
80 CONTINUE
END IF
*
IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN
*
* Use the Level 2 BLAS solve if the reciprocal of the bound on
* elements of X is not too small.
*
CALL DTPSV( UPLO, TRANS, DIAG, N, AP, X, 1 )
ELSE
*
* Use a Level 1 BLAS solve, scaling intermediate results.
*
IF( XMAX.GT.BIGNUM ) THEN
*
* Scale X so that its components are less than or equal to
* BIGNUM in absolute value.
*
SCALE = BIGNUM / XMAX
CALL DSCAL( N, SCALE, X, 1 )
XMAX = BIGNUM
END IF
*
IF( NOTRAN ) THEN
*
* Solve A * x = b
*
IP = JFIRST*( JFIRST+1 ) / 2
DO 110 J = JFIRST, JLAST, JINC
*
* Compute x(j) = b(j) / A(j,j), scaling x if necessary.
*
XJ = ABS( X( J ) )
IF( NOUNIT ) THEN
TJJS = AP( IP )*TSCAL
ELSE
TJJS = TSCAL
IF( TSCAL.EQ.ONE )
$ GO TO 100
END IF
TJJ = ABS( TJJS )
IF( TJJ.GT.SMLNUM ) THEN
*
* abs(A(j,j)) > SMLNUM:
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale x by 1/b(j).
*
REC = ONE / XJ
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
X( J ) = X( J ) / TJJS
XJ = ABS( X( J ) )
ELSE IF( TJJ.GT.ZERO ) THEN
*
* 0 < abs(A(j,j)) <= SMLNUM:
*
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
* to avoid overflow when dividing by A(j,j).
*
REC = ( TJJ*BIGNUM ) / XJ
IF( CNORM( J ).GT.ONE ) THEN
*
* Scale by 1/CNORM(j) to avoid overflow when
* multiplying x(j) times column j.
*
REC = REC / CNORM( J )
END IF
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
X( J ) = X( J ) / TJJS
XJ = ABS( X( J ) )
ELSE
*
* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
* scale = 0, and compute a solution to A*x = 0.
*
DO 90 I = 1, N
X( I ) = ZERO
90 CONTINUE
X( J ) = ONE
XJ = ONE
SCALE = ZERO
XMAX = ZERO
END IF
100 CONTINUE
*
* Scale x if necessary to avoid overflow when adding a
* multiple of column j of A.
*
IF( XJ.GT.ONE ) THEN
REC = ONE / XJ
IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN
*
* Scale x by 1/(2*abs(x(j))).
*
REC = REC*HALF
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
END IF
ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
*
* Scale x by 1/2.
*
CALL DSCAL( N, HALF, X, 1 )
SCALE = SCALE*HALF
END IF
*
IF( UPPER ) THEN
IF( J.GT.1 ) THEN
*
* Compute the update
* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j)
*
CALL DAXPY( J-1, -X( J )*TSCAL, AP( IP-J+1 ), 1, X,
$ 1 )
I = IDAMAX( J-1, X, 1 )
XMAX = ABS( X( I ) )
END IF
IP = IP - J
ELSE
IF( J.LT.N ) THEN
*
* Compute the update
* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j)
*
CALL DAXPY( N-J, -X( J )*TSCAL, AP( IP+1 ), 1,
$ X( J+1 ), 1 )
I = J + IDAMAX( N-J, X( J+1 ), 1 )
XMAX = ABS( X( I ) )
END IF
IP = IP + N - J + 1
END IF
110 CONTINUE
*
ELSE
*
* Solve A' * x = b
*
IP = JFIRST*( JFIRST+1 ) / 2
JLEN = 1
DO 160 J = JFIRST, JLAST, JINC
*
* Compute x(j) = b(j) - sum A(k,j)*x(k).
* k<>j
*
XJ = ABS( X( J ) )
USCAL = TSCAL
REC = ONE / MAX( XMAX, ONE )
IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
*
* If x(j) could overflow, scale x by 1/(2*XMAX).
*
REC = REC*HALF
IF( NOUNIT ) THEN
TJJS = AP( IP )*TSCAL
ELSE
TJJS = TSCAL
END IF
TJJ = ABS( TJJS )
IF( TJJ.GT.ONE ) THEN
*
* Divide by A(j,j) when scaling x if A(j,j) > 1.
*
REC = MIN( ONE, REC*TJJ )
USCAL = USCAL / TJJS
END IF
IF( REC.LT.ONE ) THEN
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
*
SUMJ = ZERO
IF( USCAL.EQ.ONE ) THEN
*
* If the scaling needed for A in the dot product is 1,
* call DDOT to perform the dot product.
*
IF( UPPER ) THEN
SUMJ = DDOT( J-1, AP( IP-J+1 ), 1, X, 1 )
ELSE IF( J.LT.N ) THEN
SUMJ = DDOT( N-J, AP( IP+1 ), 1, X( J+1 ), 1 )
END IF
ELSE
*
* Otherwise, use in-line code for the dot product.
*
IF( UPPER ) THEN
DO 120 I = 1, J - 1
SUMJ = SUMJ + ( AP( IP-J+I )*USCAL )*X( I )
120 CONTINUE
ELSE IF( J.LT.N ) THEN
DO 130 I = 1, N - J
SUMJ = SUMJ + ( AP( IP+I )*USCAL )*X( J+I )
130 CONTINUE
END IF
END IF
*
IF( USCAL.EQ.TSCAL ) THEN
*
* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j)
* was not used to scale the dotproduct.
*
X( J ) = X( J ) - SUMJ
XJ = ABS( X( J ) )
IF( NOUNIT ) THEN
*
* Compute x(j) = x(j) / A(j,j), scaling if necessary.
*
TJJS = AP( IP )*TSCAL
ELSE
TJJS = TSCAL
IF( TSCAL.EQ.ONE )
$ GO TO 150
END IF
TJJ = ABS( TJJS )
IF( TJJ.GT.SMLNUM ) THEN
*
* abs(A(j,j)) > SMLNUM:
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale X by 1/abs(x(j)).
*
REC = ONE / XJ
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
X( J ) = X( J ) / TJJS
ELSE IF( TJJ.GT.ZERO ) THEN
*
* 0 < abs(A(j,j)) <= SMLNUM:
*
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
*
REC = ( TJJ*BIGNUM ) / XJ
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
X( J ) = X( J ) / TJJS
ELSE
*
* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
* scale = 0, and compute a solution to A'*x = 0.
*
DO 140 I = 1, N
X( I ) = ZERO
140 CONTINUE
X( J ) = ONE
SCALE = ZERO
XMAX = ZERO
END IF
150 CONTINUE
ELSE
*
* Compute x(j) := x(j) / A(j,j) - sumj if the dot
* product has already been divided by 1/A(j,j).
*
X( J ) = X( J ) / TJJS - SUMJ
END IF
XMAX = MAX( XMAX, ABS( X( J ) ) )
JLEN = JLEN + 1
IP = IP + JINC*JLEN
160 CONTINUE
END IF
SCALE = SCALE / TSCAL
END IF
*
* Scale the column norms by 1/TSCAL for return.
*
IF( TSCAL.NE.ONE ) THEN
CALL DSCAL( N, ONE / TSCAL, CNORM, 1 )
END IF
*
RETURN
*
* End of DLATPS
*
END
SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDA, LDW, N, NB
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ), W( LDW, * )
* ..
*
* Purpose
* =======
*
* DLATRD reduces NB rows and columns of a real symmetric matrix A to
* symmetric tridiagonal form by an orthogonal similarity
* transformation Q' * A * Q, and returns the matrices V and W which are
* needed to apply the transformation to the unreduced part of A.
*
* If UPLO = 'U', DLATRD reduces the last NB rows and columns of a
* matrix, of which the upper triangle is supplied;
* if UPLO = 'L', DLATRD reduces the first NB rows and columns of a
* matrix, of which the lower triangle is supplied.
*
* This is an auxiliary routine called by DSYTRD.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The order of the matrix A.
*
* NB (input) INTEGER
* The number of rows and columns to be reduced.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the symmetric matrix A. If UPLO = 'U', the leading
* n-by-n upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading n-by-n lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced.
* On exit:
* if UPLO = 'U', the last NB columns have been reduced to
* tridiagonal form, with the diagonal elements overwriting
* the diagonal elements of A; the elements above the diagonal
* with the array TAU, represent the orthogonal matrix Q as a
* product of elementary reflectors;
* if UPLO = 'L', the first NB columns have been reduced to
* tridiagonal form, with the diagonal elements overwriting
* the diagonal elements of A; 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 >= (1,N).
*
* E (output) DOUBLE PRECISION array, dimension (N-1)
* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal
* elements of the last NB columns of the reduced matrix;
* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of
* the first NB columns of the reduced matrix.
*
* TAU (output) DOUBLE PRECISION array, dimension (N-1)
* The scalar factors of the elementary reflectors, stored in
* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.
* See Further Details.
*
* W (output) DOUBLE PRECISION array, dimension (LDW,NB)
* The n-by-nb matrix W required to update the unreduced part
* of A.
*
* LDW (input) INTEGER
* The leading dimension of the array W. LDW >= max(1,N).
*
* Further Details
* ===============
*
* If UPLO = 'U', the matrix Q is represented as a product of elementary
* reflectors
*
* Q = H(n) H(n-1) . . . H(n-nb+1).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a real scalar, and v is a real vector with
* v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),
* and tau in TAU(i-1).
*
* If UPLO = 'L', the matrix Q is represented as a product of elementary
* reflectors
*
* Q = H(1) H(2) . . . H(nb).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a real scalar, and v is a real vector with
* v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
* and tau in TAU(i).
*
* The elements of the vectors v together form the n-by-nb matrix V
* which is needed, with W, to apply the transformation to the unreduced
* part of the matrix, using a symmetric rank-2k update of the form:
* A := A - V*W' - W*V'.
*
* The contents of A on exit are illustrated by the following examples
* with n = 5 and nb = 2:
*
* if UPLO = 'U': if UPLO = 'L':
*
* ( a a a v4 v5 ) ( d )
* ( a a v4 v5 ) ( 1 d )
* ( a 1 v5 ) ( v1 1 a )
* ( d 1 ) ( v1 v2 a a )
* ( d ) ( v1 v2 a a a )
*
* where d denotes a diagonal element of the reduced matrix, a denotes
* an element of the original matrix that is unchanged, and vi denotes
* an element of the vector defining H(i).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, HALF
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 )
* ..
* .. Local Scalars ..
INTEGER I, IW
DOUBLE PRECISION ALPHA
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DGEMV, DLARFG, DSCAL, DSYMV
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DDOT
EXTERNAL LSAME, DDOT
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Reduce last NB columns of upper triangle
*
DO 10 I = N, N - NB + 1, -1
IW = I - N + NB
IF( I.LT.N ) THEN
*
* Update A(1:i,i)
*
CALL DGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ),
$ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 )
CALL DGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ),
$ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 )
END IF
IF( I.GT.1 ) THEN
*
* Generate elementary reflector H(i) to annihilate
* A(1:i-2,i)
*
CALL DLARFG( I-1, A( I-1, I ), A( 1, I ), 1, TAU( I-1 ) )
E( I-1 ) = A( I-1, I )
A( I-1, I ) = ONE
*
* Compute W(1:i-1,i)
*
CALL DSYMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1,
$ ZERO, W( 1, IW ), 1 )
IF( I.LT.N ) THEN
CALL DGEMV( 'Transpose', I-1, N-I, ONE, W( 1, IW+1 ),
$ LDW, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 )
CALL DGEMV( 'No transpose', I-1, N-I, -ONE,
$ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE,
$ W( 1, IW ), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, A( 1, I+1 ),
$ LDA, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 )
CALL DGEMV( 'No transpose', I-1, N-I, -ONE,
$ W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE,
$ W( 1, IW ), 1 )
END IF
CALL DSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 )
ALPHA = -HALF*TAU( I-1 )*DDOT( I-1, W( 1, IW ), 1,
$ A( 1, I ), 1 )
CALL DAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 )
END IF
*
10 CONTINUE
ELSE
*
* Reduce first NB columns of lower triangle
*
DO 20 I = 1, NB
*
* Update A(i:n,i)
*
CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ),
$ LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 )
CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ),
$ LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 )
IF( I.LT.N ) THEN
*
* Generate elementary reflector H(i) to annihilate
* A(i+2:n,i)
*
CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1,
$ TAU( I ) )
E( I ) = A( I+1, I )
A( I+1, I ) = ONE
*
* Compute W(i+1:n,i)
*
CALL DSYMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA,
$ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, W( I+1, 1 ), LDW,
$ A( I+1, I ), 1, ZERO, W( 1, I ), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ),
$ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA,
$ A( I+1, I ), 1, ZERO, W( 1, I ), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ),
$ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
CALL DSCAL( N-I, TAU( I ), W( I+1, I ), 1 )
ALPHA = -HALF*TAU( I )*DDOT( N-I, W( I+1, I ), 1,
$ A( I+1, I ), 1 )
CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 )
END IF
*
20 CONTINUE
END IF
*
RETURN
*
* End of DLATRD
*
END
SUBROUTINE DLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE,
$ CNORM, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, NORMIN, TRANS, UPLO
INTEGER INFO, LDA, N
DOUBLE PRECISION SCALE
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), CNORM( * ), X( * )
* ..
*
* Purpose
* =======
*
* DLATRS solves one of the triangular systems
*
* A *x = s*b or A'*x = s*b
*
* with scaling to prevent overflow. Here A is an upper or lower
* triangular matrix, A' denotes the transpose of A, x and b are
* n-element vectors, and s is a scaling factor, usually less than
* or equal to 1, chosen so that the components of x will be less than
* the overflow threshold. If the unscaled problem will not cause
* overflow, the Level 2 BLAS routine DTRSV is called. If the matrix A
* is singular (A(j,j) = 0 for some j), then s is set to 0 and a
* non-trivial solution to A*x = 0 is returned.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the operation applied to A.
* = 'N': Solve A * x = s*b (No transpose)
* = 'T': Solve A'* x = s*b (Transpose)
* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* NORMIN (input) CHARACTER*1
* Specifies whether CNORM has been set or not.
* = 'Y': CNORM contains the column norms on entry
* = 'N': CNORM is not set on entry. On exit, the norms will
* be computed and stored in CNORM.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The triangular matrix A. If UPLO = 'U', the leading n by n
* upper triangular part of the array A contains the upper
* triangular matrix, and the strictly lower triangular part of
* A is not referenced. If UPLO = 'L', the leading n by n lower
* triangular part of the array A contains the lower triangular
* matrix, and the strictly upper triangular part of A is not
* referenced. If DIAG = 'U', the diagonal elements of A are
* also not referenced and are assumed to be 1.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max (1,N).
*
* X (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the right hand side b of the triangular system.
* On exit, X is overwritten by the solution vector x.
*
* SCALE (output) DOUBLE PRECISION
* The scaling factor s for the triangular system
* A * x = s*b or A'* x = s*b.
* If SCALE = 0, the matrix A is singular or badly scaled, and
* the vector x is an exact or approximate solution to A*x = 0.
*
* CNORM (input or output) DOUBLE PRECISION array, dimension (N)
*
* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
* contains the norm of the off-diagonal part of the j-th column
* of A. If TRANS = 'N', CNORM(j) must be greater than or equal
* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
* must be greater than or equal to the 1-norm.
*
* If NORMIN = 'N', CNORM is an output argument and CNORM(j)
* returns the 1-norm of the offdiagonal part of the j-th column
* of A.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
*
* Further Details
* ======= =======
*
* A rough bound on x is computed; if that is less than overflow, DTRSV
* is called, otherwise, specific code is used which checks for possible
* overflow or divide-by-zero at every operation.
*
* A columnwise scheme is used for solving A*x = b. The basic algorithm
* if A is lower triangular is
*
* x[1:n] := b[1:n]
* for j = 1, ..., n
* x(j) := x(j) / A(j,j)
* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
* end
*
* Define bounds on the components of x after j iterations of the loop:
* M(j) = bound on x[1:j]
* G(j) = bound on x[j+1:n]
* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
*
* Then for iteration j+1 we have
* M(j+1) <= G(j) / | A(j+1,j+1) |
* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
*
* where CNORM(j+1) is greater than or equal to the infinity-norm of
* column j+1 of A, not counting the diagonal. Hence
*
* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
* 1<=i<=j
* and
*
* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
* 1<=i< j
*
* Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTRSV if the
* reciprocal of the largest M(j), j=1,..,n, is larger than
* max(underflow, 1/overflow).
*
* The bound on x(j) is also used to determine when a step in the
* columnwise method can be performed without fear of overflow. If
* the computed bound is greater than a large constant, x is scaled to
* prevent overflow, but if the bound overflows, x is set to 0, x(j) to
* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
*
* Similarly, a row-wise scheme is used to solve A'*x = b. The basic
* algorithm for A upper triangular is
*
* for j = 1, ..., n
* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)
* end
*
* We simultaneously compute two bounds
* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j
* M(j) = bound on x(i), 1<=i<=j
*
* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
* Then the bound on x(j) is
*
* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
*
* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
* 1<=i<=j
*
* and we can safely call DTRSV if 1/M(n) and 1/G(n) are both greater
* than max(underflow, 1/overflow).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN, NOUNIT, UPPER
INTEGER I, IMAX, J, JFIRST, JINC, JLAST
DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS,
$ TMAX, TSCAL, USCAL, XBND, XJ, XMAX
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DASUM, DDOT, DLAMCH
EXTERNAL LSAME, IDAMAX, DASUM, DDOT, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DSCAL, DTRSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOTRAN = LSAME( TRANS, 'N' )
NOUNIT = LSAME( DIAG, 'N' )
*
* Test the input parameters.
*
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
$ LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -3
ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT.
$ LSAME( NORMIN, 'N' ) ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLATRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Determine machine dependent parameters to control overflow.
*
SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
BIGNUM = ONE / SMLNUM
SCALE = ONE
*
IF( LSAME( NORMIN, 'N' ) ) THEN
*
* Compute the 1-norm of each column, not including the diagonal.
*
IF( UPPER ) THEN
*
* A is upper triangular.
*
DO 10 J = 1, N
CNORM( J ) = DASUM( J-1, A( 1, J ), 1 )
10 CONTINUE
ELSE
*
* A is lower triangular.
*
DO 20 J = 1, N - 1
CNORM( J ) = DASUM( N-J, A( J+1, J ), 1 )
20 CONTINUE
CNORM( N ) = ZERO
END IF
END IF
*
* Scale the column norms by TSCAL if the maximum element in CNORM is
* greater than BIGNUM.
*
IMAX = IDAMAX( N, CNORM, 1 )
TMAX = CNORM( IMAX )
IF( TMAX.LE.BIGNUM ) THEN
TSCAL = ONE
ELSE
TSCAL = ONE / ( SMLNUM*TMAX )
CALL DSCAL( N, TSCAL, CNORM, 1 )
END IF
*
* Compute a bound on the computed solution vector to see if the
* Level 2 BLAS routine DTRSV can be used.
*
J = IDAMAX( N, X, 1 )
XMAX = ABS( X( J ) )
XBND = XMAX
IF( NOTRAN ) THEN
*
* Compute the growth in A * x = b.
*
IF( UPPER ) THEN
JFIRST = N
JLAST = 1
JINC = -1
ELSE
JFIRST = 1
JLAST = N
JINC = 1
END IF
*
IF( TSCAL.NE.ONE ) THEN
GROW = ZERO
GO TO 50
END IF
*
IF( NOUNIT ) THEN
*
* A is non-unit triangular.
*
* Compute GROW = 1/G(j) and XBND = 1/M(j).
* Initially, G(0) = max{x(i), i=1,...,n}.
*
GROW = ONE / MAX( XBND, SMLNUM )
XBND = GROW
DO 30 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 50
*
* M(j) = G(j-1) / abs(A(j,j))
*
TJJ = ABS( A( J, J ) )
XBND = MIN( XBND, MIN( ONE, TJJ )*GROW )
IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN
*
* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
*
GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) )
ELSE
*
* G(j) could overflow, set GROW to 0.
*
GROW = ZERO
END IF
30 CONTINUE
GROW = XBND
ELSE
*
* A is unit triangular.
*
* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
*
GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
DO 40 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 50
*
* G(j) = G(j-1)*( 1 + CNORM(j) )
*
GROW = GROW*( ONE / ( ONE+CNORM( J ) ) )
40 CONTINUE
END IF
50 CONTINUE
*
ELSE
*
* Compute the growth in A' * x = b.
*
IF( UPPER ) THEN
JFIRST = 1
JLAST = N
JINC = 1
ELSE
JFIRST = N
JLAST = 1
JINC = -1
END IF
*
IF( TSCAL.NE.ONE ) THEN
GROW = ZERO
GO TO 80
END IF
*
IF( NOUNIT ) THEN
*
* A is non-unit triangular.
*
* Compute GROW = 1/G(j) and XBND = 1/M(j).
* Initially, M(0) = max{x(i), i=1,...,n}.
*
GROW = ONE / MAX( XBND, SMLNUM )
XBND = GROW
DO 60 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 80
*
* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
*
XJ = ONE + CNORM( J )
GROW = MIN( GROW, XBND / XJ )
*
* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
*
TJJ = ABS( A( J, J ) )
IF( XJ.GT.TJJ )
$ XBND = XBND*( TJJ / XJ )
60 CONTINUE
GROW = MIN( GROW, XBND )
ELSE
*
* A is unit triangular.
*
* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
*
GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
DO 70 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 80
*
* G(j) = ( 1 + CNORM(j) )*G(j-1)
*
XJ = ONE + CNORM( J )
GROW = GROW / XJ
70 CONTINUE
END IF
80 CONTINUE
END IF
*
IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN
*
* Use the Level 2 BLAS solve if the reciprocal of the bound on
* elements of X is not too small.
*
CALL DTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 )
ELSE
*
* Use a Level 1 BLAS solve, scaling intermediate results.
*
IF( XMAX.GT.BIGNUM ) THEN
*
* Scale X so that its components are less than or equal to
* BIGNUM in absolute value.
*
SCALE = BIGNUM / XMAX
CALL DSCAL( N, SCALE, X, 1 )
XMAX = BIGNUM
END IF
*
IF( NOTRAN ) THEN
*
* Solve A * x = b
*
DO 110 J = JFIRST, JLAST, JINC
*
* Compute x(j) = b(j) / A(j,j), scaling x if necessary.
*
XJ = ABS( X( J ) )
IF( NOUNIT ) THEN
TJJS = A( J, J )*TSCAL
ELSE
TJJS = TSCAL
IF( TSCAL.EQ.ONE )
$ GO TO 100
END IF
TJJ = ABS( TJJS )
IF( TJJ.GT.SMLNUM ) THEN
*
* abs(A(j,j)) > SMLNUM:
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale x by 1/b(j).
*
REC = ONE / XJ
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
X( J ) = X( J ) / TJJS
XJ = ABS( X( J ) )
ELSE IF( TJJ.GT.ZERO ) THEN
*
* 0 < abs(A(j,j)) <= SMLNUM:
*
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
* to avoid overflow when dividing by A(j,j).
*
REC = ( TJJ*BIGNUM ) / XJ
IF( CNORM( J ).GT.ONE ) THEN
*
* Scale by 1/CNORM(j) to avoid overflow when
* multiplying x(j) times column j.
*
REC = REC / CNORM( J )
END IF
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
X( J ) = X( J ) / TJJS
XJ = ABS( X( J ) )
ELSE
*
* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
* scale = 0, and compute a solution to A*x = 0.
*
DO 90 I = 1, N
X( I ) = ZERO
90 CONTINUE
X( J ) = ONE
XJ = ONE
SCALE = ZERO
XMAX = ZERO
END IF
100 CONTINUE
*
* Scale x if necessary to avoid overflow when adding a
* multiple of column j of A.
*
IF( XJ.GT.ONE ) THEN
REC = ONE / XJ
IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN
*
* Scale x by 1/(2*abs(x(j))).
*
REC = REC*HALF
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
END IF
ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
*
* Scale x by 1/2.
*
CALL DSCAL( N, HALF, X, 1 )
SCALE = SCALE*HALF
END IF
*
IF( UPPER ) THEN
IF( J.GT.1 ) THEN
*
* Compute the update
* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j)
*
CALL DAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X,
$ 1 )
I = IDAMAX( J-1, X, 1 )
XMAX = ABS( X( I ) )
END IF
ELSE
IF( J.LT.N ) THEN
*
* Compute the update
* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j)
*
CALL DAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1,
$ X( J+1 ), 1 )
I = J + IDAMAX( N-J, X( J+1 ), 1 )
XMAX = ABS( X( I ) )
END IF
END IF
110 CONTINUE
*
ELSE
*
* Solve A' * x = b
*
DO 160 J = JFIRST, JLAST, JINC
*
* Compute x(j) = b(j) - sum A(k,j)*x(k).
* k<>j
*
XJ = ABS( X( J ) )
USCAL = TSCAL
REC = ONE / MAX( XMAX, ONE )
IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
*
* If x(j) could overflow, scale x by 1/(2*XMAX).
*
REC = REC*HALF
IF( NOUNIT ) THEN
TJJS = A( J, J )*TSCAL
ELSE
TJJS = TSCAL
END IF
TJJ = ABS( TJJS )
IF( TJJ.GT.ONE ) THEN
*
* Divide by A(j,j) when scaling x if A(j,j) > 1.
*
REC = MIN( ONE, REC*TJJ )
USCAL = USCAL / TJJS
END IF
IF( REC.LT.ONE ) THEN
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
*
SUMJ = ZERO
IF( USCAL.EQ.ONE ) THEN
*
* If the scaling needed for A in the dot product is 1,
* call DDOT to perform the dot product.
*
IF( UPPER ) THEN
SUMJ = DDOT( J-1, A( 1, J ), 1, X, 1 )
ELSE IF( J.LT.N ) THEN
SUMJ = DDOT( N-J, A( J+1, J ), 1, X( J+1 ), 1 )
END IF
ELSE
*
* Otherwise, use in-line code for the dot product.
*
IF( UPPER ) THEN
DO 120 I = 1, J - 1
SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I )
120 CONTINUE
ELSE IF( J.LT.N ) THEN
DO 130 I = J + 1, N
SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I )
130 CONTINUE
END IF
END IF
*
IF( USCAL.EQ.TSCAL ) THEN
*
* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j)
* was not used to scale the dotproduct.
*
X( J ) = X( J ) - SUMJ
XJ = ABS( X( J ) )
IF( NOUNIT ) THEN
TJJS = A( J, J )*TSCAL
ELSE
TJJS = TSCAL
IF( TSCAL.EQ.ONE )
$ GO TO 150
END IF
*
* Compute x(j) = x(j) / A(j,j), scaling if necessary.
*
TJJ = ABS( TJJS )
IF( TJJ.GT.SMLNUM ) THEN
*
* abs(A(j,j)) > SMLNUM:
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale X by 1/abs(x(j)).
*
REC = ONE / XJ
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
X( J ) = X( J ) / TJJS
ELSE IF( TJJ.GT.ZERO ) THEN
*
* 0 < abs(A(j,j)) <= SMLNUM:
*
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
*
REC = ( TJJ*BIGNUM ) / XJ
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
X( J ) = X( J ) / TJJS
ELSE
*
* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
* scale = 0, and compute a solution to A'*x = 0.
*
DO 140 I = 1, N
X( I ) = ZERO
140 CONTINUE
X( J ) = ONE
SCALE = ZERO
XMAX = ZERO
END IF
150 CONTINUE
ELSE
*
* Compute x(j) := x(j) / A(j,j) - sumj if the dot
* product has already been divided by 1/A(j,j).
*
X( J ) = X( J ) / TJJS - SUMJ
END IF
XMAX = MAX( XMAX, ABS( X( J ) ) )
160 CONTINUE
END IF
SCALE = SCALE / TSCAL
END IF
*
* Scale the column norms by 1/TSCAL for return.
*
IF( TSCAL.NE.ONE ) THEN
CALL DSCAL( N, ONE / TSCAL, CNORM, 1 )
END IF
*
RETURN
*
* End of DLATRS
*
END
SUBROUTINE DLATRZ( M, N, L, A, LDA, TAU, WORK )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER L, LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLATRZ factors the M-by-(M+L) real upper trapezoidal matrix
* [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z, by means
* of orthogonal transformations. Z is an (M+L)-by-(M+L) orthogonal
* matrix and, R and A1 are M-by-M upper triangular matrices.
*
* 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.
*
* L (input) INTEGER
* The number of columns of the matrix A containing the
* meaningful part of the Householder vectors. N-M >= L >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the leading M-by-N upper trapezoidal part of the
* array A must contain the matrix to be factorized.
* On exit, the leading M-by-M upper triangular part of A
* contains the upper triangular matrix R, and elements N-L+1 to
* N of the first M rows of A, with the array TAU, represent the
* orthogonal matrix Z as a product of M elementary reflectors.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* TAU (output) DOUBLE PRECISION array, dimension (M)
* The scalar factors of the elementary reflectors.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (M)
*
* Further Details
* ===============
*
* Based on contributions by
* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*
* The factorization is obtained by Householder's method. The kth
* transformation matrix, Z( k ), which is used to introduce zeros into
* the ( m - k + 1 )th row of A, is given in the form
*
* Z( k ) = ( I 0 ),
* ( 0 T( k ) )
*
* where
*
* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),
* ( 0 )
* ( z( k ) )
*
* tau is a scalar and z( k ) is an l element vector. tau and z( k )
* are chosen to annihilate the elements of the kth row of A2.
*
* The scalar tau is returned in the kth element of TAU and the vector
* u( k ) in the kth row of A2, such that the elements of z( k ) are
* in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in
* the upper triangular part of A1.
*
* Z is given by
*
* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I
* ..
* .. External Subroutines ..
EXTERNAL DLARFG, DLARZ
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
* Quick return if possible
*
IF( M.EQ.0 ) THEN
RETURN
ELSE IF( M.EQ.N ) THEN
DO 10 I = 1, N
TAU( I ) = ZERO
10 CONTINUE
RETURN
END IF
*
DO 20 I = M, 1, -1
*
* Generate elementary reflector H(i) to annihilate
* [ A(i,i) A(i,n-l+1:n) ]
*
CALL DLARFG( L+1, A( I, I ), A( I, N-L+1 ), LDA, TAU( I ) )
*
* Apply H(i) to A(1:i-1,i:n) from the right
*
CALL DLARZ( 'Right', I-1, N-I+1, L, A( I, N-L+1 ), LDA,
$ TAU( I ), A( 1, I ), LDA, WORK )
*
20 CONTINUE
*
RETURN
*
* End of DLATRZ
*
END
SUBROUTINE DLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE
INTEGER INCV, LDC, M, N
DOUBLE PRECISION TAU
* ..
* .. Array Arguments ..
DOUBLE PRECISION C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* This routine is deprecated and has been replaced by routine DORMRZ.
*
* DLATZM applies a Householder matrix generated by DTZRQF to a matrix.
*
* Let P = I - tau*u*u', u = ( 1 ),
* ( v )
* where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if
* SIDE = 'R'.
*
* If SIDE equals 'L', let
* C = [ C1 ] 1
* [ C2 ] m-1
* n
* Then C is overwritten by P*C.
*
* If SIDE equals 'R', let
* C = [ C1, C2 ] m
* 1 n-1
* Then C is overwritten by C*P.
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* = 'L': form P * C
* = 'R': form C * P
*
* 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'
* (1 + (N-1)*abs(INCV)) if SIDE = 'R'
* The vector v in the representation of P. 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 P.
*
* C1 (input/output) DOUBLE PRECISION array, dimension
* (LDC,N) if SIDE = 'L'
* (M,1) if SIDE = 'R'
* On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1
* if SIDE = 'R'.
*
* On exit, the first row of P*C if SIDE = 'L', or the first
* column of C*P if SIDE = 'R'.
*
* C2 (input/output) DOUBLE PRECISION array, dimension
* (LDC, N) if SIDE = 'L'
* (LDC, N-1) if SIDE = 'R'
* On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the
* m x (n - 1) matrix C2 if SIDE = 'R'.
*
* On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P
* if SIDE = 'R'.
*
* LDC (input) INTEGER
* The leading dimension of the arrays C1 and C2. LDC >= (1,M).
*
* WORK (workspace) DOUBLE PRECISION array, dimension
* (N) if SIDE = 'L'
* (M) if SIDE = 'R'
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DGEMV, DGER
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
IF( ( MIN( M, N ).EQ.0 ) .OR. ( TAU.EQ.ZERO ) )
$ RETURN
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* w := C1 + v' * C2
*
CALL DCOPY( N, C1, LDC, WORK, 1 )
CALL DGEMV( 'Transpose', M-1, N, ONE, C2, LDC, V, INCV, ONE,
$ WORK, 1 )
*
* [ C1 ] := [ C1 ] - tau* [ 1 ] * w'
* [ C2 ] [ C2 ] [ v ]
*
CALL DAXPY( N, -TAU, WORK, 1, C1, LDC )
CALL DGER( M-1, N, -TAU, V, INCV, WORK, 1, C2, LDC )
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* w := C1 + C2 * v
*
CALL DCOPY( M, C1, 1, WORK, 1 )
CALL DGEMV( 'No transpose', M, N-1, ONE, C2, LDC, V, INCV, ONE,
$ WORK, 1 )
*
* [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v']
*
CALL DAXPY( M, -TAU, WORK, 1, C1, 1 )
CALL DGER( M, N-1, -TAU, WORK, 1, V, INCV, C2, LDC )
END IF
*
RETURN
*
* End of DLATZM
*
END
SUBROUTINE DLAUU2( UPLO, N, A, LDA, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
* ..
*
* Purpose
* =======
*
* DLAUU2 computes the product U * U' or L' * L, where the triangular
* factor U or L is stored in the upper or lower triangular part of
* the array A.
*
* If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
* overwriting the factor U in A.
* If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
* overwriting the factor L in A.
*
* This is the unblocked form of the algorithm, calling Level 2 BLAS.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the triangular factor stored in the array A
* is upper or lower triangular:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The order of the triangular factor U or L. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the triangular factor U or L.
* On exit, if UPLO = 'U', the upper triangle of A is
* overwritten with the upper triangle of the product U * U';
* if UPLO = 'L', the lower triangle of A is overwritten with
* the lower triangle of the product L' * L.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I
DOUBLE PRECISION AII
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DDOT
EXTERNAL LSAME, DDOT
* ..
* .. External Subroutines ..
EXTERNAL DGEMV, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAUU2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Compute the product U * U'.
*
DO 10 I = 1, N
AII = A( I, I )
IF( I.LT.N ) THEN
A( I, I ) = DDOT( N-I+1, A( I, I ), LDA, A( I, I ), LDA )
CALL DGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ),
$ LDA, A( I, I+1 ), LDA, AII, A( 1, I ), 1 )
ELSE
CALL DSCAL( I, AII, A( 1, I ), 1 )
END IF
10 CONTINUE
*
ELSE
*
* Compute the product L' * L.
*
DO 20 I = 1, N
AII = A( I, I )
IF( I.LT.N ) THEN
A( I, I ) = DDOT( N-I+1, A( I, I ), 1, A( I, I ), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA,
$ A( I+1, I ), 1, AII, A( I, 1 ), LDA )
ELSE
CALL DSCAL( I, AII, A( I, 1 ), LDA )
END IF
20 CONTINUE
END IF
*
RETURN
*
* End of DLAUU2
*
END
SUBROUTINE DLAUUM( UPLO, N, A, LDA, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
* ..
*
* Purpose
* =======
*
* DLAUUM computes the product U * U' or L' * L, where the triangular
* factor U or L is stored in the upper or lower triangular part of
* the array A.
*
* If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
* overwriting the factor U in A.
* If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
* overwriting the factor L in A.
*
* This is the blocked form of the algorithm, calling Level 3 BLAS.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the triangular factor stored in the array A
* is upper or lower triangular:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The order of the triangular factor U or L. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the triangular factor U or L.
* On exit, if UPLO = 'U', the upper triangle of A is
* overwritten with the upper triangle of the product U * U';
* if UPLO = 'L', the lower triangle of A is overwritten with
* the lower triangle of the product L' * L.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, IB, NB
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLAUU2, DSYRK, DTRMM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAUUM', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Determine the block size for this environment.
*
NB = ILAENV( 1, 'DLAUUM', UPLO, N, -1, -1, -1 )
*
IF( NB.LE.1 .OR. NB.GE.N ) THEN
*
* Use unblocked code
*
CALL DLAUU2( UPLO, N, A, LDA, INFO )
ELSE
*
* Use blocked code
*
IF( UPPER ) THEN
*
* Compute the product U * U'.
*
DO 10 I = 1, N, NB
IB = MIN( NB, N-I+1 )
CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-unit',
$ I-1, IB, ONE, A( I, I ), LDA, A( 1, I ),
$ LDA )
CALL DLAUU2( 'Upper', IB, A( I, I ), LDA, INFO )
IF( I+IB.LE.N ) THEN
CALL DGEMM( 'No transpose', 'Transpose', I-1, IB,
$ N-I-IB+1, ONE, A( 1, I+IB ), LDA,
$ A( I, I+IB ), LDA, ONE, A( 1, I ), LDA )
CALL DSYRK( 'Upper', 'No transpose', IB, N-I-IB+1,
$ ONE, A( I, I+IB ), LDA, ONE, A( I, I ),
$ LDA )
END IF
10 CONTINUE
ELSE
*
* Compute the product L' * L.
*
DO 20 I = 1, N, NB
IB = MIN( NB, N-I+1 )
CALL DTRMM( 'Left', 'Lower', 'Transpose', 'Non-unit', IB,
$ I-1, ONE, A( I, I ), LDA, A( I, 1 ), LDA )
CALL DLAUU2( 'Lower', IB, A( I, I ), LDA, INFO )
IF( I+IB.LE.N ) THEN
CALL DGEMM( 'Transpose', 'No transpose', IB, I-1,
$ N-I-IB+1, ONE, A( I+IB, I ), LDA,
$ A( I+IB, 1 ), LDA, ONE, A( I, 1 ), LDA )
CALL DSYRK( 'Lower', 'Transpose', IB, N-I-IB+1, ONE,
$ A( I+IB, I ), LDA, ONE, A( I, I ), LDA )
END IF
20 CONTINUE
END IF
END IF
*
RETURN
*
* End of DLAUUM
*
END
SUBROUTINE DLAZQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL,
$ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1,
$ DN2, TAU )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL IEEE
INTEGER I0, ITER, N0, NDIV, NFAIL, PP, TTYPE
DOUBLE PRECISION DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, QMAX,
$ SIGMA, TAU
* ..
* .. Array Arguments ..
DOUBLE PRECISION Z( * )
* ..
*
* Purpose
* =======
*
* DLAZQ3 checks for deflation, computes a shift (TAU) and calls dqds.
* In case of failure it changes shifts, and tries again until output
* is positive.
*
* Arguments
* =========
*
* I0 (input) INTEGER
* First index.
*
* N0 (input) INTEGER
* Last index.
*
* Z (input) DOUBLE PRECISION array, dimension ( 4*N )
* Z holds the qd array.
*
* PP (input) INTEGER
* PP=0 for ping, PP=1 for pong.
*
* DMIN (output) DOUBLE PRECISION
* Minimum value of d.
*
* SIGMA (output) DOUBLE PRECISION
* Sum of shifts used in current segment.
*
* DESIG (input/output) DOUBLE PRECISION
* Lower order part of SIGMA
*
* QMAX (input) DOUBLE PRECISION
* Maximum value of q.
*
* NFAIL (output) INTEGER
* Number of times shift was too big.
*
* ITER (output) INTEGER
* Number of iterations.
*
* NDIV (output) INTEGER
* Number of divisions.
*
* IEEE (input) LOGICAL
* Flag for IEEE or non IEEE arithmetic (passed to DLASQ5).
*
* TTYPE (input/output) INTEGER
* Shift type. TTYPE is passed as an argument in order to save
* its value between calls to DLAZQ3
*
* DMIN1 (input/output) REAL
* DMIN2 (input/output) REAL
* DN (input/output) REAL
* DN1 (input/output) REAL
* DN2 (input/output) REAL
* TAU (input/output) REAL
* These are passed as arguments in order to save their values
* between calls to DLAZQ3
*
* This is a thread safe version of DLASQ3, which passes TTYPE, DMIN1,
* DMIN2, DN, DN1. DN2 and TAU through the argument list in place of
* declaring them in a SAVE statment.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION CBIAS
PARAMETER ( CBIAS = 1.50D0 )
DOUBLE PRECISION ZERO, QURTR, HALF, ONE, TWO, HUNDRD
PARAMETER ( ZERO = 0.0D0, QURTR = 0.250D0, HALF = 0.5D0,
$ ONE = 1.0D0, TWO = 2.0D0, HUNDRD = 100.0D0 )
* ..
* .. Local Scalars ..
INTEGER IPN4, J4, N0IN, NN
DOUBLE PRECISION EPS, G, S, SAFMIN, T, TEMP, TOL, TOL2
* ..
* .. External Subroutines ..
EXTERNAL DLASQ5, DLASQ6, DLAZQ4
* ..
* .. External Function ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MIN, SQRT
* ..
* .. Executable Statements ..
*
N0IN = N0
EPS = DLAMCH( 'Precision' )
SAFMIN = DLAMCH( 'Safe minimum' )
TOL = EPS*HUNDRD
TOL2 = TOL**2
G = ZERO
*
* Check for deflation.
*
10 CONTINUE
*
IF( N0.LT.I0 )
$ RETURN
IF( N0.EQ.I0 )
$ GO TO 20
NN = 4*N0 + PP
IF( N0.EQ.( I0+1 ) )
$ GO TO 40
*
* Check whether E(N0-1) is negligible, 1 eigenvalue.
*
IF( Z( NN-5 ).GT.TOL2*( SIGMA+Z( NN-3 ) ) .AND.
$ Z( NN-2*PP-4 ).GT.TOL2*Z( NN-7 ) )
$ GO TO 30
*
20 CONTINUE
*
Z( 4*N0-3 ) = Z( 4*N0+PP-3 ) + SIGMA
N0 = N0 - 1
GO TO 10
*
* Check whether E(N0-2) is negligible, 2 eigenvalues.
*
30 CONTINUE
*
IF( Z( NN-9 ).GT.TOL2*SIGMA .AND.
$ Z( NN-2*PP-8 ).GT.TOL2*Z( NN-11 ) )
$ GO TO 50
*
40 CONTINUE
*
IF( Z( NN-3 ).GT.Z( NN-7 ) ) THEN
S = Z( NN-3 )
Z( NN-3 ) = Z( NN-7 )
Z( NN-7 ) = S
END IF
IF( Z( NN-5 ).GT.Z( NN-3 )*TOL2 ) THEN
T = HALF*( ( Z( NN-7 )-Z( NN-3 ) )+Z( NN-5 ) )
S = Z( NN-3 )*( Z( NN-5 ) / T )
IF( S.LE.T ) THEN
S = Z( NN-3 )*( Z( NN-5 ) /
$ ( T*( ONE+SQRT( ONE+S / T ) ) ) )
ELSE
S = Z( NN-3 )*( Z( NN-5 ) / ( T+SQRT( T )*SQRT( T+S ) ) )
END IF
T = Z( NN-7 ) + ( S+Z( NN-5 ) )
Z( NN-3 ) = Z( NN-3 )*( Z( NN-7 ) / T )
Z( NN-7 ) = T
END IF
Z( 4*N0-7 ) = Z( NN-7 ) + SIGMA
Z( 4*N0-3 ) = Z( NN-3 ) + SIGMA
N0 = N0 - 2
GO TO 10
*
50 CONTINUE
*
* Reverse the qd-array, if warranted.
*
IF( DMIN.LE.ZERO .OR. N0.LT.N0IN ) THEN
IF( CBIAS*Z( 4*I0+PP-3 ).LT.Z( 4*N0+PP-3 ) ) THEN
IPN4 = 4*( I0+N0 )
DO 60 J4 = 4*I0, 2*( I0+N0-1 ), 4
TEMP = Z( J4-3 )
Z( J4-3 ) = Z( IPN4-J4-3 )
Z( IPN4-J4-3 ) = TEMP
TEMP = Z( J4-2 )
Z( J4-2 ) = Z( IPN4-J4-2 )
Z( IPN4-J4-2 ) = TEMP
TEMP = Z( J4-1 )
Z( J4-1 ) = Z( IPN4-J4-5 )
Z( IPN4-J4-5 ) = TEMP
TEMP = Z( J4 )
Z( J4 ) = Z( IPN4-J4-4 )
Z( IPN4-J4-4 ) = TEMP
60 CONTINUE
IF( N0-I0.LE.4 ) THEN
Z( 4*N0+PP-1 ) = Z( 4*I0+PP-1 )
Z( 4*N0-PP ) = Z( 4*I0-PP )
END IF
DMIN2 = MIN( DMIN2, Z( 4*N0+PP-1 ) )
Z( 4*N0+PP-1 ) = MIN( Z( 4*N0+PP-1 ), Z( 4*I0+PP-1 ),
$ Z( 4*I0+PP+3 ) )
Z( 4*N0-PP ) = MIN( Z( 4*N0-PP ), Z( 4*I0-PP ),
$ Z( 4*I0-PP+4 ) )
QMAX = MAX( QMAX, Z( 4*I0+PP-3 ), Z( 4*I0+PP+1 ) )
DMIN = -ZERO
END IF
END IF
*
IF( DMIN.LT.ZERO .OR. SAFMIN*QMAX.LT.MIN( Z( 4*N0+PP-1 ),
$ Z( 4*N0+PP-9 ), DMIN2+Z( 4*N0-PP ) ) ) THEN
*
* Choose a shift.
*
CALL DLAZQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1,
$ DN2, TAU, TTYPE, G )
*
* Call dqds until DMIN > 0.
*
80 CONTINUE
*
CALL DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN,
$ DN1, DN2, IEEE )
*
NDIV = NDIV + ( N0-I0+2 )
ITER = ITER + 1
*
* Check status.
*
IF( DMIN.GE.ZERO .AND. DMIN1.GT.ZERO ) THEN
*
* Success.
*
GO TO 100
*
ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND.
$ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND.
$ ABS( DN ).LT.TOL*SIGMA ) THEN
*
* Convergence hidden by negative DN.
*
Z( 4*( N0-1 )-PP+2 ) = ZERO
DMIN = ZERO
GO TO 100
ELSE IF( DMIN.LT.ZERO ) THEN
*
* TAU too big. Select new TAU and try again.
*
NFAIL = NFAIL + 1
IF( TTYPE.LT.-22 ) THEN
*
* Failed twice. Play it safe.
*
TAU = ZERO
ELSE IF( DMIN1.GT.ZERO ) THEN
*
* Late failure. Gives excellent shift.
*
TAU = ( TAU+DMIN )*( ONE-TWO*EPS )
TTYPE = TTYPE - 11
ELSE
*
* Early failure. Divide by 4.
*
TAU = QURTR*TAU
TTYPE = TTYPE - 12
END IF
GO TO 80
ELSE IF( DMIN.NE.DMIN ) THEN
*
* NaN.
*
TAU = ZERO
GO TO 80
ELSE
*
* Possible underflow. Play it safe.
*
GO TO 90
END IF
END IF
*
* Risk of underflow.
*
90 CONTINUE
CALL DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 )
NDIV = NDIV + ( N0-I0+2 )
ITER = ITER + 1
TAU = ZERO
*
100 CONTINUE
IF( TAU.LT.SIGMA ) THEN
DESIG = DESIG + TAU
T = SIGMA + DESIG
DESIG = DESIG - ( T-SIGMA )
ELSE
T = SIGMA + TAU
DESIG = SIGMA - ( T-TAU ) + DESIG
END IF
SIGMA = T
*
RETURN
*
* End of DLAZQ3
*
END
SUBROUTINE DLAZQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN,
$ DN1, DN2, TAU, TTYPE, G )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER I0, N0, N0IN, PP, TTYPE
DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU
* ..
* .. Array Arguments ..
DOUBLE PRECISION Z( * )
* ..
*
* Purpose
* =======
*
* DLAZQ4 computes an approximation TAU to the smallest eigenvalue
* using values of d from the previous transform.
*
* I0 (input) INTEGER
* First index.
*
* N0 (input) INTEGER
* Last index.
*
* Z (input) DOUBLE PRECISION array, dimension ( 4*N )
* Z holds the qd array.
*
* PP (input) INTEGER
* PP=0 for ping, PP=1 for pong.
*
* N0IN (input) INTEGER
* The value of N0 at start of EIGTEST.
*
* DMIN (input) DOUBLE PRECISION
* Minimum value of d.
*
* DMIN1 (input) DOUBLE PRECISION
* Minimum value of d, excluding D( N0 ).
*
* DMIN2 (input) DOUBLE PRECISION
* Minimum value of d, excluding D( N0 ) and D( N0-1 ).
*
* DN (input) DOUBLE PRECISION
* d(N)
*
* DN1 (input) DOUBLE PRECISION
* d(N-1)
*
* DN2 (input) DOUBLE PRECISION
* d(N-2)
*
* TAU (output) DOUBLE PRECISION
* This is the shift.
*
* TTYPE (output) INTEGER
* Shift type.
*
* G (input/output) DOUBLE PRECISION
* G is passed as an argument in order to save its value between
* calls to DLAZQ4
*
* Further Details
* ===============
* CNST1 = 9/16
*
* This is a thread safe version of DLASQ4, which passes G through the
* argument list in place of declaring G in a SAVE statment.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION CNST1, CNST2, CNST3
PARAMETER ( CNST1 = 0.5630D0, CNST2 = 1.010D0,
$ CNST3 = 1.050D0 )
DOUBLE PRECISION QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD
PARAMETER ( QURTR = 0.250D0, THIRD = 0.3330D0,
$ HALF = 0.50D0, ZERO = 0.0D0, ONE = 1.0D0,
$ TWO = 2.0D0, HUNDRD = 100.0D0 )
* ..
* .. Local Scalars ..
INTEGER I4, NN, NP
DOUBLE PRECISION A2, B1, B2, GAM, GAP1, GAP2, S
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* A negative DMIN forces the shift to take that absolute value
* TTYPE records the type of shift.
*
IF( DMIN.LE.ZERO ) THEN
TAU = -DMIN
TTYPE = -1
RETURN
END IF
*
NN = 4*N0 + PP
IF( N0IN.EQ.N0 ) THEN
*
* No eigenvalues deflated.
*
IF( DMIN.EQ.DN .OR. DMIN.EQ.DN1 ) THEN
*
B1 = SQRT( Z( NN-3 ) )*SQRT( Z( NN-5 ) )
B2 = SQRT( Z( NN-7 ) )*SQRT( Z( NN-9 ) )
A2 = Z( NN-7 ) + Z( NN-5 )
*
* Cases 2 and 3.
*
IF( DMIN.EQ.DN .AND. DMIN1.EQ.DN1 ) THEN
GAP2 = DMIN2 - A2 - DMIN2*QURTR
IF( GAP2.GT.ZERO .AND. GAP2.GT.B2 ) THEN
GAP1 = A2 - DN - ( B2 / GAP2 )*B2
ELSE
GAP1 = A2 - DN - ( B1+B2 )
END IF
IF( GAP1.GT.ZERO .AND. GAP1.GT.B1 ) THEN
S = MAX( DN-( B1 / GAP1 )*B1, HALF*DMIN )
TTYPE = -2
ELSE
S = ZERO
IF( DN.GT.B1 )
$ S = DN - B1
IF( A2.GT.( B1+B2 ) )
$ S = MIN( S, A2-( B1+B2 ) )
S = MAX( S, THIRD*DMIN )
TTYPE = -3
END IF
ELSE
*
* Case 4.
*
TTYPE = -4
S = QURTR*DMIN
IF( DMIN.EQ.DN ) THEN
GAM = DN
A2 = ZERO
IF( Z( NN-5 ) .GT. Z( NN-7 ) )
$ RETURN
B2 = Z( NN-5 ) / Z( NN-7 )
NP = NN - 9
ELSE
NP = NN - 2*PP
B2 = Z( NP-2 )
GAM = DN1
IF( Z( NP-4 ) .GT. Z( NP-2 ) )
$ RETURN
A2 = Z( NP-4 ) / Z( NP-2 )
IF( Z( NN-9 ) .GT. Z( NN-11 ) )
$ RETURN
B2 = Z( NN-9 ) / Z( NN-11 )
NP = NN - 13
END IF
*
* Approximate contribution to norm squared from I < NN-1.
*
A2 = A2 + B2
DO 10 I4 = NP, 4*I0 - 1 + PP, -4
IF( B2.EQ.ZERO )
$ GO TO 20
B1 = B2
IF( Z( I4 ) .GT. Z( I4-2 ) )
$ RETURN
B2 = B2*( Z( I4 ) / Z( I4-2 ) )
A2 = A2 + B2
IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 )
$ GO TO 20
10 CONTINUE
20 CONTINUE
A2 = CNST3*A2
*
* Rayleigh quotient residual bound.
*
IF( A2.LT.CNST1 )
$ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 )
END IF
ELSE IF( DMIN.EQ.DN2 ) THEN
*
* Case 5.
*
TTYPE = -5
S = QURTR*DMIN
*
* Compute contribution to norm squared from I > NN-2.
*
NP = NN - 2*PP
B1 = Z( NP-2 )
B2 = Z( NP-6 )
GAM = DN2
IF( Z( NP-8 ).GT.B2 .OR. Z( NP-4 ).GT.B1 )
$ RETURN
A2 = ( Z( NP-8 ) / B2 )*( ONE+Z( NP-4 ) / B1 )
*
* Approximate contribution to norm squared from I < NN-2.
*
IF( N0-I0.GT.2 ) THEN
B2 = Z( NN-13 ) / Z( NN-15 )
A2 = A2 + B2
DO 30 I4 = NN - 17, 4*I0 - 1 + PP, -4
IF( B2.EQ.ZERO )
$ GO TO 40
B1 = B2
IF( Z( I4 ) .GT. Z( I4-2 ) )
$ RETURN
B2 = B2*( Z( I4 ) / Z( I4-2 ) )
A2 = A2 + B2
IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 )
$ GO TO 40
30 CONTINUE
40 CONTINUE
A2 = CNST3*A2
END IF
*
IF( A2.LT.CNST1 )
$ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 )
ELSE
*
* Case 6, no information to guide us.
*
IF( TTYPE.EQ.-6 ) THEN
G = G + THIRD*( ONE-G )
ELSE IF( TTYPE.EQ.-18 ) THEN
G = QURTR*THIRD
ELSE
G = QURTR
END IF
S = G*DMIN
TTYPE = -6
END IF
*
ELSE IF( N0IN.EQ.( N0+1 ) ) THEN
*
* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN.
*
IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN
*
* Cases 7 and 8.
*
TTYPE = -7
S = THIRD*DMIN1
IF( Z( NN-5 ).GT.Z( NN-7 ) )
$ RETURN
B1 = Z( NN-5 ) / Z( NN-7 )
B2 = B1
IF( B2.EQ.ZERO )
$ GO TO 60
DO 50 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4
A2 = B1
IF( Z( I4 ).GT.Z( I4-2 ) )
$ RETURN
B1 = B1*( Z( I4 ) / Z( I4-2 ) )
B2 = B2 + B1
IF( HUNDRD*MAX( B1, A2 ).LT.B2 )
$ GO TO 60
50 CONTINUE
60 CONTINUE
B2 = SQRT( CNST3*B2 )
A2 = DMIN1 / ( ONE+B2**2 )
GAP2 = HALF*DMIN2 - A2
IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN
S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) )
ELSE
S = MAX( S, A2*( ONE-CNST2*B2 ) )
TTYPE = -8
END IF
ELSE
*
* Case 9.
*
S = QURTR*DMIN1
IF( DMIN1.EQ.DN1 )
$ S = HALF*DMIN1
TTYPE = -9
END IF
*
ELSE IF( N0IN.EQ.( N0+2 ) ) THEN
*
* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN.
*
* Cases 10 and 11.
*
IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN
TTYPE = -10
S = THIRD*DMIN2
IF( Z( NN-5 ).GT.Z( NN-7 ) )
$ RETURN
B1 = Z( NN-5 ) / Z( NN-7 )
B2 = B1
IF( B2.EQ.ZERO )
$ GO TO 80
DO 70 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4
IF( Z( I4 ).GT.Z( I4-2 ) )
$ RETURN
B1 = B1*( Z( I4 ) / Z( I4-2 ) )
B2 = B2 + B1
IF( HUNDRD*B1.LT.B2 )
$ GO TO 80
70 CONTINUE
80 CONTINUE
B2 = SQRT( CNST3*B2 )
A2 = DMIN2 / ( ONE+B2**2 )
GAP2 = Z( NN-7 ) + Z( NN-9 ) -
$ SQRT( Z( NN-11 ) )*SQRT( Z( NN-9 ) ) - A2
IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN
S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) )
ELSE
S = MAX( S, A2*( ONE-CNST2*B2 ) )
END IF
ELSE
S = QURTR*DMIN2
TTYPE = -11
END IF
ELSE IF( N0IN.GT.( N0+2 ) ) THEN
*
* Case 12, more than two eigenvalues deflated. No information.
*
S = ZERO
TTYPE = -12
END IF
*
TAU = S
RETURN
*
* End of DLAZQ4
*
END
SUBROUTINE DOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDQ, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DOPGTR generates a real orthogonal matrix Q which is defined as the
* product of n-1 elementary reflectors H(i) of order n, as returned by
* DSPTRD using packed storage:
*
* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
*
* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangular packed storage used in previous
* call to DSPTRD;
* = 'L': Lower triangular packed storage used in previous
* call to DSPTRD.
*
* N (input) INTEGER
* The order of the matrix Q. N >= 0.
*
* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The vectors which define the elementary reflectors, as
* returned by DSPTRD.
*
* TAU (input) DOUBLE PRECISION array, dimension (N-1)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by DSPTRD.
*
* Q (output) DOUBLE PRECISION array, dimension (LDQ,N)
* The N-by-N orthogonal matrix Q.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (N-1)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, IINFO, IJ, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DORG2L, DORG2R, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DOPGTR', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Q was determined by a call to DSPTRD with UPLO = 'U'
*
* Unpack the vectors which define the elementary reflectors and
* set the last row and column of Q equal to those of the unit
* matrix
*
IJ = 2
DO 20 J = 1, N - 1
DO 10 I = 1, J - 1
Q( I, J ) = AP( IJ )
IJ = IJ + 1
10 CONTINUE
IJ = IJ + 2
Q( N, J ) = ZERO
20 CONTINUE
DO 30 I = 1, N - 1
Q( I, N ) = ZERO
30 CONTINUE
Q( N, N ) = ONE
*
* Generate Q(1:n-1,1:n-1)
*
CALL DORG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO )
*
ELSE
*
* Q was determined by a call to DSPTRD with UPLO = 'L'.
*
* Unpack the vectors which define the elementary reflectors and
* set the first row and column of Q equal to those of the unit
* matrix
*
Q( 1, 1 ) = ONE
DO 40 I = 2, N
Q( I, 1 ) = ZERO
40 CONTINUE
IJ = 3
DO 60 J = 2, N
Q( 1, J ) = ZERO
DO 50 I = J + 1, N
Q( I, J ) = AP( IJ )
IJ = IJ + 1
50 CONTINUE
IJ = IJ + 2
60 CONTINUE
IF( N.GT.1 ) THEN
*
* Generate Q(2:n,2:n)
*
CALL DORG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK,
$ IINFO )
END IF
END IF
RETURN
*
* End of DOPGTR
*
END
SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS, UPLO
INTEGER INFO, LDC, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP( * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DOPMTR 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 of order nq, with nq = m if
* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
* nq-1 elementary reflectors, as returned by DSPTRD using packed
* storage:
*
* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
*
* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* = 'L': apply Q or Q**T from the Left;
* = 'R': apply Q or Q**T from the Right.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangular packed storage used in previous
* call to DSPTRD;
* = 'L': Lower triangular packed storage used in previous
* call to DSPTRD.
*
* 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.
*
* AP (input) DOUBLE PRECISION array, dimension
* (M*(M+1)/2) if SIDE = 'L'
* (N*(N+1)/2) if SIDE = 'R'
* The vectors which define the elementary reflectors, as
* returned by DSPTRD. AP is modified by the routine but
* restored on exit.
*
* TAU (input) DOUBLE PRECISION array, dimension (M-1) if SIDE = 'L'
* or (N-1) if SIDE = 'R'
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by DSPTRD.
*
* 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 FORWRD, LEFT, NOTRAN, UPPER
INTEGER I, I1, I2, I3, IC, II, 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' )
UPPER = LSAME( UPLO, 'U' )
*
* 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.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
INFO = -3
ELSE IF( M.LT.0 ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DOPMTR', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Q was determined by a call to DSPTRD with UPLO = 'U'
*
FORWRD = ( LEFT .AND. NOTRAN ) .OR.
$ ( .NOT.LEFT .AND. .NOT.NOTRAN )
*
IF( FORWRD ) THEN
I1 = 1
I2 = NQ - 1
I3 = 1
II = 2
ELSE
I1 = NQ - 1
I2 = 1
I3 = -1
II = NQ*( NQ+1 ) / 2 - 1
END IF
*
IF( LEFT ) THEN
NI = N
ELSE
MI = M
END IF
*
DO 10 I = I1, I2, I3
IF( LEFT ) THEN
*
* H(i) is applied to C(1:i,1:n)
*
MI = I
ELSE
*
* H(i) is applied to C(1:m,1:i)
*
NI = I
END IF
*
* Apply H(i)
*
AII = AP( II )
AP( II ) = ONE
CALL DLARF( SIDE, MI, NI, AP( II-I+1 ), 1, TAU( I ), C, LDC,
$ WORK )
AP( II ) = AII
*
IF( FORWRD ) THEN
II = II + I + 2
ELSE
II = II - I - 1
END IF
10 CONTINUE
ELSE
*
* Q was determined by a call to DSPTRD with UPLO = 'L'.
*
FORWRD = ( LEFT .AND. .NOT.NOTRAN ) .OR.
$ ( .NOT.LEFT .AND. NOTRAN )
*
IF( FORWRD ) THEN
I1 = 1
I2 = NQ - 1
I3 = 1
II = 2
ELSE
I1 = NQ - 1
I2 = 1
I3 = -1
II = NQ*( NQ+1 ) / 2 - 1
END IF
*
IF( LEFT ) THEN
NI = N
JC = 1
ELSE
MI = M
IC = 1
END IF
*
DO 20 I = I1, I2, I3
AII = AP( II )
AP( II ) = ONE
IF( LEFT ) THEN
*
* H(i) is applied to C(i+1:m,1:n)
*
MI = M - I
IC = I + 1
ELSE
*
* H(i) is applied to C(1:m,i+1:n)
*
NI = N - I
JC = I + 1
END IF
*
* Apply H(i)
*
CALL DLARF( SIDE, MI, NI, AP( II ), 1, TAU( I ),
$ C( IC, JC ), LDC, WORK )
AP( II ) = AII
*
IF( FORWRD ) THEN
II = II + NQ - I + 1
ELSE
II = II - NQ + I - 2
END IF
20 CONTINUE
END IF
RETURN
*
* End of DOPMTR
*
END
SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DORG2L generates an m by n real matrix Q with orthonormal columns,
* which is defined as the last n columns of a product of k elementary
* reflectors of order m
*
* Q = H(k) . . . H(2) H(1)
*
* as returned by DGEQLF.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix Q. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix Q. M >= N >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* matrix Q. N >= K >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the (n-k+i)-th column must contain the vector which
* defines the elementary reflector H(i), for i = 1,2,...,k, as
* returned by DGEQLF in the last k columns of its array
* argument A.
* On exit, the m by n matrix Q.
*
* LDA (input) INTEGER
* The first dimension of the array A. LDA >= max(1,M).
*
* TAU (input) DOUBLE PRECISION array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by DGEQLF.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument has an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, II, J, L
* ..
* .. External Subroutines ..
EXTERNAL DLARF, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORG2L', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
* Initialise columns 1:n-k to columns of the unit matrix
*
DO 20 J = 1, N - K
DO 10 L = 1, M
A( L, J ) = ZERO
10 CONTINUE
A( M-N+J, J ) = ONE
20 CONTINUE
*
DO 40 I = 1, K
II = N - K + I
*
* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left
*
A( M-N+II, II ) = ONE
CALL DLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A,
$ LDA, WORK )
CALL DSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 )
A( M-N+II, II ) = ONE - TAU( I )
*
* Set A(m-k+i+1:m,n-k+i) to zero
*
DO 30 L = M - N + II + 1, M
A( L, II ) = ZERO
30 CONTINUE
40 CONTINUE
RETURN
*
* End of DORG2L
*
END
SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DORG2R generates an m by n real matrix Q with orthonormal columns,
* which is defined as the first n columns of a product of k elementary
* reflectors of order m
*
* Q = H(1) H(2) . . . H(k)
*
* as returned by DGEQRF.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix Q. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix Q. M >= N >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* matrix Q. N >= K >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, 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.
* On exit, the m-by-n matrix Q.
*
* LDA (input) INTEGER
* The first dimension of the array A. LDA >= max(1,M).
*
* TAU (input) DOUBLE PRECISION array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by DGEQRF.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument has an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, L
* ..
* .. External Subroutines ..
EXTERNAL DLARF, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORG2R', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
* Initialise columns k+1:n to columns of the unit matrix
*
DO 20 J = K + 1, N
DO 10 L = 1, M
A( L, J ) = ZERO
10 CONTINUE
A( J, J ) = ONE
20 CONTINUE
*
DO 40 I = K, 1, -1
*
* Apply H(i) to A(i:m,i:n) from the left
*
IF( I.LT.N ) THEN
A( I, I ) = ONE
CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
$ A( I, I+1 ), LDA, WORK )
END IF
IF( I.LT.M )
$ CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 )
A( I, I ) = ONE - TAU( I )
*
* Set A(1:i-1,i) to zero
*
DO 30 L = 1, I - 1
A( L, I ) = ZERO
30 CONTINUE
40 CONTINUE
RETURN
*
* End of DORG2R
*
END
SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER VECT
INTEGER INFO, K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DORGBR generates one of the real orthogonal matrices Q or P**T
* determined by DGEBRD when reducing a real matrix A to bidiagonal
* form: A = Q * B * P**T. Q and P**T are defined as products of
* elementary reflectors H(i) or G(i) respectively.
*
* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q
* is of order M:
* if m >= k, Q = H(1) H(2) . . . H(k) and DORGBR returns the first n
* columns of Q, where m >= n >= k;
* if m < k, Q = H(1) H(2) . . . H(m-1) and DORGBR returns Q as an
* M-by-M matrix.
*
* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T
* is of order N:
* if k < n, P**T = G(k) . . . G(2) G(1) and DORGBR returns the first m
* rows of P**T, where n >= m >= k;
* if k >= n, P**T = G(n-1) . . . G(2) G(1) and DORGBR returns P**T as
* an N-by-N matrix.
*
* Arguments
* =========
*
* VECT (input) CHARACTER*1
* Specifies whether the matrix Q or the matrix P**T is
* required, as defined in the transformation applied by DGEBRD:
* = 'Q': generate Q;
* = 'P': generate P**T.
*
* M (input) INTEGER
* The number of rows of the matrix Q or P**T to be returned.
* M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix Q or P**T to be returned.
* N >= 0.
* If VECT = 'Q', M >= N >= min(M,K);
* if VECT = 'P', N >= M >= min(N,K).
*
* K (input) INTEGER
* If VECT = 'Q', the number of columns in the original M-by-K
* matrix reduced by DGEBRD.
* If VECT = 'P', the number of rows in the original K-by-N
* matrix reduced by DGEBRD.
* K >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the vectors which define the elementary reflectors,
* as returned by DGEBRD.
* On exit, the M-by-N matrix Q or P**T.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* TAU (input) DOUBLE PRECISION array, dimension
* (min(M,K)) if VECT = 'Q'
* (min(N,K)) if VECT = 'P'
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i) or G(i), which determines Q or P**T, as
* returned by DGEBRD in its array argument TAUQ or TAUP.
*
* 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,min(M,N)).
* For optimum performance LWORK >= min(M,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
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, WANTQ
INTEGER I, IINFO, J, LWKOPT, MN, NB
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DORGLQ, DORGQR, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
WANTQ = LSAME( VECT, 'Q' )
MN = MIN( M, N )
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN
INFO = -1
ELSE IF( M.LT.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 .OR. ( WANTQ .AND. ( N.GT.M .OR. N.LT.MIN( M,
$ K ) ) ) .OR. ( .NOT.WANTQ .AND. ( M.GT.N .OR. M.LT.
$ MIN( N, K ) ) ) ) THEN
INFO = -3
ELSE IF( K.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -6
ELSE IF( LWORK.LT.MAX( 1, MN ) .AND. .NOT.LQUERY ) THEN
INFO = -9
END IF
*
IF( INFO.EQ.0 ) THEN
IF( WANTQ ) THEN
NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 )
ELSE
NB = ILAENV( 1, 'DORGLQ', ' ', M, N, K, -1 )
END IF
LWKOPT = MAX( 1, MN )*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORGBR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
IF( WANTQ ) THEN
*
* Form Q, determined by a call to DGEBRD to reduce an m-by-k
* matrix
*
IF( M.GE.K ) THEN
*
* If m >= k, assume m >= n >= k
*
CALL DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO )
*
ELSE
*
* If m < k, assume m = n
*
* Shift the vectors which define the elementary reflectors one
* column to the right, and set the first row and column of Q
* to those of the unit matrix
*
DO 20 J = M, 2, -1
A( 1, J ) = ZERO
DO 10 I = J + 1, M
A( I, J ) = A( I, J-1 )
10 CONTINUE
20 CONTINUE
A( 1, 1 ) = ONE
DO 30 I = 2, M
A( I, 1 ) = ZERO
30 CONTINUE
IF( M.GT.1 ) THEN
*
* Form Q(2:m,2:m)
*
CALL DORGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK,
$ LWORK, IINFO )
END IF
END IF
ELSE
*
* Form P', determined by a call to DGEBRD to reduce a k-by-n
* matrix
*
IF( K.LT.N ) THEN
*
* If k < n, assume k <= m <= n
*
CALL DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO )
*
ELSE
*
* If k >= n, assume m = n
*
* Shift the vectors which define the elementary reflectors one
* row downward, and set the first row and column of P' to
* those of the unit matrix
*
A( 1, 1 ) = ONE
DO 40 I = 2, N
A( I, 1 ) = ZERO
40 CONTINUE
DO 60 J = 2, N
DO 50 I = J - 1, 2, -1
A( I, J ) = A( I-1, J )
50 CONTINUE
A( 1, J ) = ZERO
60 CONTINUE
IF( N.GT.1 ) THEN
*
* Form P'(2:n,2:n)
*
CALL DORGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
$ LWORK, IINFO )
END IF
END IF
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of DORGBR
*
END
SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IHI, ILO, INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DORGHR generates a real orthogonal matrix Q which is defined as the
* product of IHI-ILO elementary reflectors of order N, as returned by
* DGEHRD:
*
* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix Q. N >= 0.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* ILO and IHI must have the same values as in the previous call
* of DGEHRD. Q is equal to the unit matrix except in the
* submatrix Q(ilo+1:ihi,ilo+1:ihi).
* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the vectors which define the elementary reflectors,
* as returned by DGEHRD.
* On exit, the N-by-N orthogonal matrix Q.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* TAU (input) DOUBLE PRECISION array, dimension (N-1)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by DGEHRD.
*
* 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 >= IHI-ILO.
* For optimum performance LWORK >= (IHI-ILO)*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
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IINFO, J, LWKOPT, NB, NH
* ..
* .. External Subroutines ..
EXTERNAL DORGQR, XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
NH = IHI - ILO
LQUERY = ( LWORK.EQ.-1 )
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
INFO = -2
ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LWORK.LT.MAX( 1, NH ) .AND. .NOT.LQUERY ) THEN
INFO = -8
END IF
*
IF( INFO.EQ.0 ) THEN
NB = ILAENV( 1, 'DORGQR', ' ', NH, NH, NH, -1 )
LWKOPT = MAX( 1, NH )*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORGHR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
* Shift the vectors which define the elementary reflectors one
* column to the right, and set the first ilo and the last n-ihi
* rows and columns to those of the unit matrix
*
DO 40 J = IHI, ILO + 1, -1
DO 10 I = 1, J - 1
A( I, J ) = ZERO
10 CONTINUE
DO 20 I = J + 1, IHI
A( I, J ) = A( I, J-1 )
20 CONTINUE
DO 30 I = IHI + 1, N
A( I, J ) = ZERO
30 CONTINUE
40 CONTINUE
DO 60 J = 1, ILO
DO 50 I = 1, N
A( I, J ) = ZERO
50 CONTINUE
A( J, J ) = ONE
60 CONTINUE
DO 80 J = IHI + 1, N
DO 70 I = 1, N
A( I, J ) = ZERO
70 CONTINUE
A( J, J ) = ONE
80 CONTINUE
*
IF( NH.GT.0 ) THEN
*
* Generate Q(ilo+1:ihi,ilo+1:ihi)
*
CALL DORGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ),
$ WORK, LWORK, IINFO )
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of DORGHR
*
END
SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DORGL2 generates an m by n real matrix Q with orthonormal rows,
* which is defined as the first m rows of a product of k elementary
* reflectors of order n
*
* Q = H(k) . . . H(2) H(1)
*
* as returned by DGELQF.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix Q. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix Q. N >= M.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* matrix Q. M >= K >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the i-th row must contain the vector which defines
* the elementary reflector H(i), for i = 1,2,...,k, as returned
* by DGELQF in the first k rows of its array argument A.
* On exit, the m-by-n matrix Q.
*
* LDA (input) INTEGER
* The first dimension of the array A. LDA >= max(1,M).
*
* TAU (input) DOUBLE PRECISION array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by DGELQF.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (M)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument has an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, L
* ..
* .. External Subroutines ..
EXTERNAL DLARF, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORGL2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.LE.0 )
$ RETURN
*
IF( K.LT.M ) THEN
*
* Initialise rows k+1:m to rows of the unit matrix
*
DO 20 J = 1, N
DO 10 L = K + 1, M
A( L, J ) = ZERO
10 CONTINUE
IF( J.GT.K .AND. J.LE.M )
$ A( J, J ) = ONE
20 CONTINUE
END IF
*
DO 40 I = K, 1, -1
*
* Apply H(i) to A(i:m,i:n) from the right
*
IF( I.LT.N ) THEN
IF( I.LT.M ) THEN
A( I, I ) = ONE
CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
$ TAU( I ), A( I+1, I ), LDA, WORK )
END IF
CALL DSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA )
END IF
A( I, I ) = ONE - TAU( I )
*
* Set A(i,1:i-1) to zero
*
DO 30 L = 1, I - 1
A( I, L ) = ZERO
30 CONTINUE
40 CONTINUE
RETURN
*
* End of DORGL2
*
END
SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DORGLQ generates an M-by-N real matrix Q with orthonormal rows,
* which is defined as the first M rows of a product of K elementary
* reflectors of order N
*
* Q = H(k) . . . H(2) H(1)
*
* as returned by DGELQF.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix Q. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix Q. N >= M.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* matrix Q. M >= K >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the i-th row must contain the vector which defines
* the elementary reflector H(i), for i = 1,2,...,k, as returned
* by DGELQF in the first k rows of its array argument A.
* On exit, the M-by-N matrix Q.
*
* LDA (input) INTEGER
* The first dimension of the array A. LDA >= max(1,M).
*
* TAU (input) DOUBLE PRECISION array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by DGELQF.
*
* 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,M).
* For optimum performance LWORK >= M*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 has an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
$ LWKOPT, NB, NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL DLARFB, DLARFT, DORGL2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
NB = ILAENV( 1, 'DORGLQ', ' ', M, N, K, -1 )
LWKOPT = MAX( 1, M )*NB
WORK( 1 ) = LWKOPT
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORGLQ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.LE.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
NBMIN = 2
NX = 0
IWS = M
IF( NB.GT.1 .AND. NB.LT.K ) THEN
*
* Determine when to cross over from blocked to unblocked code.
*
NX = MAX( 0, ILAENV( 3, 'DORGLQ', ' ', M, N, K, -1 ) )
IF( NX.LT.K ) THEN
*
* Determine if workspace is large enough for blocked code.
*
LDWORK = M
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, 'DORGLQ', ' ', M, N, K, -1 ) )
END IF
END IF
END IF
*
IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
*
* Use blocked code after the last block.
* The first kk rows are handled by the block method.
*
KI = ( ( K-NX-1 ) / NB )*NB
KK = MIN( K, KI+NB )
*
* Set A(kk+1:m,1:kk) to zero.
*
DO 20 J = 1, KK
DO 10 I = KK + 1, M
A( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
KK = 0
END IF
*
* Use unblocked code for the last or only block.
*
IF( KK.LT.M )
$ CALL DORGL2( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA,
$ TAU( KK+1 ), WORK, IINFO )
*
IF( KK.GT.0 ) THEN
*
* Use blocked code
*
DO 50 I = KI + 1, 1, -NB
IB = MIN( NB, K-I+1 )
IF( I+IB.LE.M ) THEN
*
* Form the triangular factor of the block reflector
* H = H(i) H(i+1) . . . H(i+ib-1)
*
CALL DLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ),
$ LDA, TAU( I ), WORK, LDWORK )
*
* Apply H' to A(i+ib:m,i:n) from the right
*
CALL DLARFB( 'Right', 'Transpose', 'Forward', 'Rowwise',
$ M-I-IB+1, N-I+1, IB, A( I, I ), LDA, WORK,
$ LDWORK, A( I+IB, I ), LDA, WORK( IB+1 ),
$ LDWORK )
END IF
*
* Apply H' to columns i:n of current block
*
CALL DORGL2( IB, N-I+1, IB, A( I, I ), LDA, TAU( I ), WORK,
$ IINFO )
*
* Set columns 1:i-1 of current block to zero
*
DO 40 J = 1, I - 1
DO 30 L = I, I + IB - 1
A( L, J ) = ZERO
30 CONTINUE
40 CONTINUE
50 CONTINUE
END IF
*
WORK( 1 ) = IWS
RETURN
*
* End of DORGLQ
*
END
SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DORGQL generates an M-by-N real matrix Q with orthonormal columns,
* which is defined as the last N columns of a product of K elementary
* reflectors of order M
*
* Q = H(k) . . . H(2) H(1)
*
* as returned by DGEQLF.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix Q. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix Q. M >= N >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* matrix Q. N >= K >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the (n-k+i)-th column must contain the vector which
* defines the elementary reflector H(i), for i = 1,2,...,k, as
* returned by DGEQLF in the last k columns of its array
* argument A.
* On exit, the M-by-N matrix Q.
*
* LDA (input) INTEGER
* The first dimension of the array A. LDA >= max(1,M).
*
* TAU (input) DOUBLE PRECISION array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by DGEQLF.
*
* 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 has an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT,
$ NB, NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL DLARFB, DLARFT, DORG2L, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
*
IF( INFO.EQ.0 ) THEN
IF( N.EQ.0 ) THEN
LWKOPT = 1
ELSE
NB = ILAENV( 1, 'DORGQL', ' ', M, N, K, -1 )
LWKOPT = N*NB
END IF
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -8
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORGQL', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 ) THEN
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, 'DORGQL', ' ', M, N, K, -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, 'DORGQL', ' ', M, N, K, -1 ) )
END IF
END IF
END IF
*
IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
*
* Use blocked code after the first block.
* The last kk columns are handled by the block method.
*
KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB )
*
* Set A(m-kk+1:m,1:n-kk) to zero.
*
DO 20 J = 1, N - KK
DO 10 I = M - KK + 1, M
A( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
KK = 0
END IF
*
* Use unblocked code for the first or only block.
*
CALL DORG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO )
*
IF( KK.GT.0 ) THEN
*
* Use blocked code
*
DO 50 I = K - KK + 1, K, NB
IB = MIN( NB, K-I+1 )
IF( N-K+I.GT.1 ) THEN
*
* Form the triangular factor of the block reflector
* H = H(i+ib-1) . . . H(i+1) H(i)
*
CALL DLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB,
$ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK )
*
* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left
*
CALL DLARFB( 'Left', 'No transpose', 'Backward',
$ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB,
$ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA,
$ WORK( IB+1 ), LDWORK )
END IF
*
* Apply H to rows 1:m-k+i+ib-1 of current block
*
CALL DORG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA,
$ TAU( I ), WORK, IINFO )
*
* Set rows m-k+i+ib:m of current block to zero
*
DO 40 J = N - K + I, N - K + I + IB - 1
DO 30 L = M - K + I + IB, M
A( L, J ) = ZERO
30 CONTINUE
40 CONTINUE
50 CONTINUE
END IF
*
WORK( 1 ) = IWS
RETURN
*
* End of DORGQL
*
END
SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DORGQR generates an M-by-N real matrix Q with orthonormal columns,
* which is defined as the first N columns of a product of K elementary
* reflectors of order M
*
* Q = H(1) H(2) . . . H(k)
*
* as returned by DGEQRF.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix Q. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix Q. M >= N >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* matrix Q. N >= K >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, 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.
* On exit, the M-by-N matrix Q.
*
* LDA (input) INTEGER
* The first dimension of the array A. LDA >= max(1,M).
*
* TAU (input) DOUBLE PRECISION array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by DGEQRF.
*
* 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 has an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
$ LWKOPT, NB, NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL DLARFB, DLARFT, DORG2R, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 )
LWKOPT = MAX( 1, N )*NB
WORK( 1 ) = LWKOPT
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORGQR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.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, 'DORGQR', ' ', M, N, K, -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, 'DORGQR', ' ', M, N, K, -1 ) )
END IF
END IF
END IF
*
IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
*
* Use blocked code after the last block.
* The first kk columns are handled by the block method.
*
KI = ( ( K-NX-1 ) / NB )*NB
KK = MIN( K, KI+NB )
*
* Set A(1:kk,kk+1:n) to zero.
*
DO 20 J = KK + 1, N
DO 10 I = 1, KK
A( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
KK = 0
END IF
*
* Use unblocked code for the last or only block.
*
IF( KK.LT.N )
$ CALL DORG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA,
$ TAU( KK+1 ), WORK, IINFO )
*
IF( KK.GT.0 ) THEN
*
* Use blocked code
*
DO 50 I = KI + 1, 1, -NB
IB = MIN( NB, K-I+1 )
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 to A(i:m,i+ib:n) from the left
*
CALL DLARFB( 'Left', 'No 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
*
* Apply H to rows i:m of current block
*
CALL DORG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK,
$ IINFO )
*
* Set rows 1:i-1 of current block to zero
*
DO 40 J = I, I + IB - 1
DO 30 L = 1, I - 1
A( L, J ) = ZERO
30 CONTINUE
40 CONTINUE
50 CONTINUE
END IF
*
WORK( 1 ) = IWS
RETURN
*
* End of DORGQR
*
END
SUBROUTINE DORGR2( M, N, K, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DORGR2 generates an m by n real matrix Q with orthonormal rows,
* which is defined as the last m rows of a product of k elementary
* reflectors of order n
*
* Q = H(1) H(2) . . . H(k)
*
* as returned by DGERQF.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix Q. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix Q. N >= M.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* matrix Q. M >= K >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the (m-k+i)-th row must contain the vector which
* defines the elementary reflector H(i), for i = 1,2,...,k, as
* returned by DGERQF in the last k rows of its array argument
* A.
* On exit, the m by n matrix Q.
*
* LDA (input) INTEGER
* The first dimension of the array A. LDA >= max(1,M).
*
* TAU (input) DOUBLE PRECISION array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by DGERQF.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (M)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument has an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, II, J, L
* ..
* .. External Subroutines ..
EXTERNAL DLARF, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORGR2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.LE.0 )
$ RETURN
*
IF( K.LT.M ) THEN
*
* Initialise rows 1:m-k to rows of the unit matrix
*
DO 20 J = 1, N
DO 10 L = 1, M - K
A( L, J ) = ZERO
10 CONTINUE
IF( J.GT.N-M .AND. J.LE.N-K )
$ A( M-N+J, J ) = ONE
20 CONTINUE
END IF
*
DO 40 I = 1, K
II = M - K + I
*
* Apply H(i) to A(1:m-k+i,1:n-k+i) from the right
*
A( II, N-M+II ) = ONE
CALL DLARF( 'Right', II-1, N-M+II, A( II, 1 ), LDA, TAU( I ),
$ A, LDA, WORK )
CALL DSCAL( N-M+II-1, -TAU( I ), A( II, 1 ), LDA )
A( II, N-M+II ) = ONE - TAU( I )
*
* Set A(m-k+i,n-k+i+1:n) to zero
*
DO 30 L = N - M + II + 1, N
A( II, L ) = ZERO
30 CONTINUE
40 CONTINUE
RETURN
*
* End of DORGR2
*
END
SUBROUTINE DORGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DORGRQ generates an M-by-N real matrix Q with orthonormal rows,
* which is defined as the last M rows of a product of K elementary
* reflectors of order N
*
* Q = H(1) H(2) . . . H(k)
*
* as returned by DGERQF.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix Q. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix Q. N >= M.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* matrix Q. M >= K >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the (m-k+i)-th row must contain the vector which
* defines the elementary reflector H(i), for i = 1,2,...,k, as
* returned by DGERQF in the last k rows of its array argument
* A.
* On exit, the M-by-N matrix Q.
*
* LDA (input) INTEGER
* The first dimension of the array A. LDA >= max(1,M).
*
* TAU (input) DOUBLE PRECISION array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by DGERQF.
*
* 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,M).
* For optimum performance LWORK >= M*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 has an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, II, IINFO, IWS, J, KK, L, LDWORK,
$ LWKOPT, NB, NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL DLARFB, DLARFT, DORGR2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
*
IF( INFO.EQ.0 ) THEN
IF( M.LE.0 ) THEN
LWKOPT = 1
ELSE
NB = ILAENV( 1, 'DORGRQ', ' ', M, N, K, -1 )
LWKOPT = M*NB
END IF
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
INFO = -8
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORGRQ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.LE.0 ) THEN
RETURN
END IF
*
NBMIN = 2
NX = 0
IWS = M
IF( NB.GT.1 .AND. NB.LT.K ) THEN
*
* Determine when to cross over from blocked to unblocked code.
*
NX = MAX( 0, ILAENV( 3, 'DORGRQ', ' ', M, N, K, -1 ) )
IF( NX.LT.K ) THEN
*
* Determine if workspace is large enough for blocked code.
*
LDWORK = M
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, 'DORGRQ', ' ', M, N, K, -1 ) )
END IF
END IF
END IF
*
IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
*
* Use blocked code after the first block.
* The last kk rows are handled by the block method.
*
KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB )
*
* Set A(1:m-kk,n-kk+1:n) to zero.
*
DO 20 J = N - KK + 1, N
DO 10 I = 1, M - KK
A( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
KK = 0
END IF
*
* Use unblocked code for the first or only block.
*
CALL DORGR2( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO )
*
IF( KK.GT.0 ) THEN
*
* Use blocked code
*
DO 50 I = K - KK + 1, K, NB
IB = MIN( NB, K-I+1 )
II = M - K + I
IF( II.GT.1 ) THEN
*
* Form the triangular factor of the block reflector
* H = H(i+ib-1) . . . H(i+1) H(i)
*
CALL DLARFT( 'Backward', 'Rowwise', N-K+I+IB-1, IB,
$ A( II, 1 ), LDA, TAU( I ), WORK, LDWORK )
*
* Apply H' to A(1:m-k+i-1,1:n-k+i+ib-1) from the right
*
CALL DLARFB( 'Right', 'Transpose', 'Backward', 'Rowwise',
$ II-1, N-K+I+IB-1, IB, A( II, 1 ), LDA, WORK,
$ LDWORK, A, LDA, WORK( IB+1 ), LDWORK )
END IF
*
* Apply H' to columns 1:n-k+i+ib-1 of current block
*
CALL DORGR2( IB, N-K+I+IB-1, IB, A( II, 1 ), LDA, TAU( I ),
$ WORK, IINFO )
*
* Set columns n-k+i+ib:n of current block to zero
*
DO 40 L = N - K + I + IB, N
DO 30 J = II, II + IB - 1
A( J, L ) = ZERO
30 CONTINUE
40 CONTINUE
50 CONTINUE
END IF
*
WORK( 1 ) = IWS
RETURN
*
* End of DORGRQ
*
END
SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DORGTR generates a real orthogonal matrix Q which is defined as the
* product of n-1 elementary reflectors of order N, as returned by
* DSYTRD:
*
* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
*
* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A contains elementary reflectors
* from DSYTRD;
* = 'L': Lower triangle of A contains elementary reflectors
* from DSYTRD.
*
* N (input) INTEGER
* The order of the matrix Q. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the vectors which define the elementary reflectors,
* as returned by DSYTRD.
* On exit, the N-by-N orthogonal matrix Q.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* TAU (input) DOUBLE PRECISION array, dimension (N-1)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by DSYTRD.
*
* 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-1).
* For optimum performance LWORK >= (N-1)*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
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, UPPER
INTEGER I, IINFO, J, LWKOPT, NB
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DORGQL, DORGQR, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN
INFO = -7
END IF
*
IF( INFO.EQ.0 ) THEN
IF( UPPER ) THEN
NB = ILAENV( 1, 'DORGQL', ' ', N-1, N-1, N-1, -1 )
ELSE
NB = ILAENV( 1, 'DORGQR', ' ', N-1, N-1, N-1, -1 )
END IF
LWKOPT = MAX( 1, N-1 )*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORGTR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
IF( UPPER ) THEN
*
* Q was determined by a call to DSYTRD with UPLO = 'U'
*
* Shift the vectors which define the elementary reflectors one
* column to the left, and set the last row and column of Q to
* those of the unit matrix
*
DO 20 J = 1, N - 1
DO 10 I = 1, J - 1
A( I, J ) = A( I, J+1 )
10 CONTINUE
A( N, J ) = ZERO
20 CONTINUE
DO 30 I = 1, N - 1
A( I, N ) = ZERO
30 CONTINUE
A( N, N ) = ONE
*
* Generate Q(1:n-1,1:n-1)
*
CALL DORGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO )
*
ELSE
*
* Q was determined by a call to DSYTRD with UPLO = 'L'.
*
* Shift the vectors which define the elementary reflectors one
* column to the right, and set the first row and column of Q to
* those of the unit matrix
*
DO 50 J = N, 2, -1
A( 1, J ) = ZERO
DO 40 I = J + 1, N
A( I, J ) = A( I, J-1 )
40 CONTINUE
50 CONTINUE
A( 1, 1 ) = ONE
DO 60 I = 2, N
A( I, 1 ) = ZERO
60 CONTINUE
IF( N.GT.1 ) THEN
*
* Generate Q(2:n,2:n)
*
CALL DORGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
$ LWORK, IINFO )
END IF
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of DORGTR
*
END
SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DORM2L overwrites the general real m by n matrix C with
*
* Q * C if SIDE = 'L' and TRANS = 'N', or
*
* Q'* C if SIDE = 'L' and TRANS = 'T', or
*
* C * Q if SIDE = 'R' and TRANS = 'N', or
*
* C * Q' if SIDE = 'R' and TRANS = 'T',
*
* where Q is a real orthogonal matrix defined as the product of k
* elementary reflectors
*
* Q = H(k) . . . H(2) H(1)
*
* as returned by DGEQLF. 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' from the Left
* = 'R': apply Q or Q' from the Right
*
* TRANS (input) CHARACTER*1
* = 'N': apply Q (No transpose)
* = 'T': apply Q' (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
* DGEQLF in the last 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 DGEQLF.
*
* 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'*C or C*Q' 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, 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( 'DORM2L', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
$ RETURN
*
IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) )
$ THEN
I1 = 1
I2 = K
I3 = 1
ELSE
I1 = K
I2 = 1
I3 = -1
END IF
*
IF( LEFT ) THEN
NI = N
ELSE
MI = M
END IF
*
DO 10 I = I1, I2, I3
IF( LEFT ) THEN
*
* H(i) is applied to C(1:m-k+i,1:n)
*
MI = M - K + I
ELSE
*
* H(i) is applied to C(1:m,1:n-k+i)
*
NI = N - K + I
END IF
*
* Apply H(i)
*
AII = A( NQ-K+I, I )
A( NQ-K+I, I ) = ONE
CALL DLARF( SIDE, MI, NI, A( 1, I ), 1, TAU( I ), C, LDC,
$ WORK )
A( NQ-K+I, I ) = AII
10 CONTINUE
RETURN
*
* End of DORM2L
*
END
SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. 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'* C if SIDE = 'L' and TRANS = 'T', or
*
* C * Q if SIDE = 'R' and TRANS = 'N', or
*
* C * Q' 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' from the Left
* = 'R': apply Q or Q' from the Right
*
* TRANS (input) CHARACTER*1
* = 'N': apply Q (No transpose)
* = 'T': apply Q' (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'*C or C*Q' 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 DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C,
$ LDC, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS, VECT
INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* If VECT = 'Q', DORMBR 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
*
* If VECT = 'P', DORMBR overwrites the general real M-by-N matrix C
* with
* SIDE = 'L' SIDE = 'R'
* TRANS = 'N': P * C C * P
* TRANS = 'T': P**T * C C * P**T
*
* Here Q and P**T are the orthogonal matrices determined by DGEBRD when
* reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and
* P**T are defined as products of elementary reflectors H(i) and G(i)
* respectively.
*
* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the
* order of the orthogonal matrix Q or P**T that is applied.
*
* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:
* if nq >= k, Q = H(1) H(2) . . . H(k);
* if nq < k, Q = H(1) H(2) . . . H(nq-1).
*
* If VECT = 'P', A is assumed to have been a K-by-NQ matrix:
* if k < nq, P = G(1) G(2) . . . G(k);
* if k >= nq, P = G(1) G(2) . . . G(nq-1).
*
* Arguments
* =========
*
* VECT (input) CHARACTER*1
* = 'Q': apply Q or Q**T;
* = 'P': apply P or P**T.
*
* SIDE (input) CHARACTER*1
* = 'L': apply Q, Q**T, P or P**T from the Left;
* = 'R': apply Q, Q**T, P or P**T from the Right.
*
* TRANS (input) CHARACTER*1
* = 'N': No transpose, apply Q or P;
* = 'T': Transpose, apply Q**T or P**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
* If VECT = 'Q', the number of columns in the original
* matrix reduced by DGEBRD.
* If VECT = 'P', the number of rows in the original
* matrix reduced by DGEBRD.
* K >= 0.
*
* A (input) DOUBLE PRECISION array, dimension
* (LDA,min(nq,K)) if VECT = 'Q'
* (LDA,nq) if VECT = 'P'
* The vectors which define the elementary reflectors H(i) and
* G(i), whose products determine the matrices Q and P, as
* returned by DGEBRD.
*
* LDA (input) INTEGER
* The leading dimension of the array A.
* If VECT = 'Q', LDA >= max(1,nq);
* if VECT = 'P', LDA >= max(1,min(nq,K)).
*
* TAU (input) DOUBLE PRECISION array, dimension (min(nq,K))
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i) or G(i) which determines Q or P, as returned
* by DGEBRD in the array argument TAUQ or TAUP.
*
* 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
* or P*C or P**T*C or C*P or C*P**T.
*
* 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
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN
CHARACTER TRANST
INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DORMLQ, DORMQR, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
APPLYQ = LSAME( VECT, 'Q' )
LEFT = LSAME( SIDE, 'L' )
NOTRAN = LSAME( TRANS, 'N' )
LQUERY = ( LWORK.EQ.-1 )
*
* NQ is the order of Q or P and NW is the minimum dimension of WORK
*
IF( LEFT ) THEN
NQ = M
NW = N
ELSE
NQ = N
NW = M
END IF
IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN
INFO = -1
ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
INFO = -3
ELSE IF( M.LT.0 ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( K.LT.0 ) THEN
INFO = -6
ELSE IF( ( APPLYQ .AND. LDA.LT.MAX( 1, NQ ) ) .OR.
$ ( .NOT.APPLYQ .AND. LDA.LT.MAX( 1, MIN( NQ, K ) ) ) )
$ THEN
INFO = -8
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -11
ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
*
IF( INFO.EQ.0 ) THEN
IF( APPLYQ ) THEN
IF( LEFT ) THEN
NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M-1, N, M-1,
$ -1 )
ELSE
NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N-1, N-1,
$ -1 )
END IF
ELSE
IF( LEFT ) THEN
NB = ILAENV( 1, 'DORMLQ', SIDE // TRANS, M-1, N, M-1,
$ -1 )
ELSE
NB = ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N-1, N-1,
$ -1 )
END IF
END IF
LWKOPT = MAX( 1, NW )*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORMBR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
WORK( 1 ) = 1
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
IF( APPLYQ ) THEN
*
* Apply Q
*
IF( NQ.GE.K ) THEN
*
* Q was determined by a call to DGEBRD with nq >= k
*
CALL DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, IINFO )
ELSE IF( NQ.GT.1 ) THEN
*
* Q was determined by a call to DGEBRD with nq < k
*
IF( LEFT ) THEN
MI = M - 1
NI = N
I1 = 2
I2 = 1
ELSE
MI = M
NI = N - 1
I1 = 1
I2 = 2
END IF
CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU,
$ C( I1, I2 ), LDC, WORK, LWORK, IINFO )
END IF
ELSE
*
* Apply P
*
IF( NOTRAN ) THEN
TRANST = 'T'
ELSE
TRANST = 'N'
END IF
IF( NQ.GT.K ) THEN
*
* P was determined by a call to DGEBRD with nq > k
*
CALL DORMLQ( SIDE, TRANST, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, IINFO )
ELSE IF( NQ.GT.1 ) THEN
*
* P was determined by a call to DGEBRD with nq <= k
*
IF( LEFT ) THEN
MI = M - 1
NI = N
I1 = 2
I2 = 1
ELSE
MI = M
NI = N - 1
I1 = 1
I2 = 2
END IF
CALL DORMLQ( SIDE, TRANST, MI, NI, NQ-1, A( 1, 2 ), LDA,
$ TAU, C( I1, I2 ), LDC, WORK, LWORK, IINFO )
END IF
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of DORMBR
*
END
SUBROUTINE DORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C,
$ LDC, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DORMHR 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 of order nq, with nq = m if
* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
* IHI-ILO elementary reflectors, as returned by DGEHRD:
*
* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
*
* 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.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* ILO and IHI must have the same values as in the previous call
* of DGEHRD. Q is equal to the unit matrix except in the
* submatrix Q(ilo+1:ihi,ilo+1:ihi).
* If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and
* ILO = 1 and IHI = 0, if M = 0;
* if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and
* ILO = 1 and IHI = 0, if N = 0.
*
* A (input) DOUBLE PRECISION array, dimension
* (LDA,M) if SIDE = 'L'
* (LDA,N) if SIDE = 'R'
* The vectors which define the elementary reflectors, as
* returned by DGEHRD.
*
* LDA (input) INTEGER
* The leading dimension of the array A.
* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
*
* TAU (input) DOUBLE PRECISION array, dimension
* (M-1) if SIDE = 'L'
* (N-1) if SIDE = 'R'
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by DGEHRD.
*
* 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
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LEFT, LQUERY
INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DORMQR, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
NH = IHI - ILO
LEFT = LSAME( SIDE, 'L' )
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.LSAME( TRANS, 'N' ) .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( ILO.LT.1 .OR. ILO.GT.MAX( 1, NQ ) ) THEN
INFO = -5
ELSE IF( IHI.LT.MIN( ILO, NQ ) .OR. IHI.GT.NQ ) THEN
INFO = -6
ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
INFO = -8
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -11
ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
*
IF( INFO.EQ.0 ) THEN
IF( LEFT ) THEN
NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, NH, N, NH, -1 )
ELSE
NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, NH, NH, -1 )
END IF
LWKOPT = MAX( 1, NW )*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORMHR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. NH.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
IF( LEFT ) THEN
MI = NH
NI = N
I1 = ILO + 1
I2 = 1
ELSE
MI = M
NI = NH
I1 = 1
I2 = ILO + 1
END IF
*
CALL DORMQR( SIDE, TRANS, MI, NI, NH, A( ILO+1, ILO ), LDA,
$ TAU( ILO ), C( I1, I2 ), LDC, WORK, LWORK, IINFO )
*
WORK( 1 ) = LWKOPT
RETURN
*
* End of DORMHR
*
END
SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DORML2 overwrites the general real m by n matrix C with
*
* Q * C if SIDE = 'L' and TRANS = 'N', or
*
* Q'* C if SIDE = 'L' and TRANS = 'T', or
*
* C * Q if SIDE = 'R' and TRANS = 'N', or
*
* C * Q' if SIDE = 'R' and TRANS = 'T',
*
* where Q is a real orthogonal matrix defined as the product of k
* elementary reflectors
*
* Q = H(k) . . . H(2) H(1)
*
* as returned by DGELQF. 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' from the Left
* = 'R': apply Q or Q' from the Right
*
* TRANS (input) CHARACTER*1
* = 'N': apply Q (No transpose)
* = 'T': apply Q' (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,M) if SIDE = 'L',
* (LDA,N) if SIDE = 'R'
* The i-th row must contain the vector which defines the
* elementary reflector H(i), for i = 1,2,...,k, as returned by
* DGELQF in the first k rows 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. LDA >= max(1,K).
*
* TAU (input) DOUBLE PRECISION array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by DGELQF.
*
* 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'*C or C*Q' 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, K ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORML2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
$ RETURN
*
IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.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 ), LDA, TAU( I ),
$ C( IC, JC ), LDC, WORK )
A( I, I ) = AII
10 CONTINUE
RETURN
*
* End of DORML2
*
END
SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DORMLQ 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(k) . . . H(2) H(1)
*
* as returned by DGELQF. 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,M) if SIDE = 'L',
* (LDA,N) if SIDE = 'R'
* The i-th row must contain the vector which defines the
* elementary reflector H(i), for i = 1,2,...,k, as returned by
* DGELQF in the first k rows 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. LDA >= max(1,K).
*
* TAU (input) DOUBLE PRECISION array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by DGELQF.
*
* 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
CHARACTER TRANST
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, DORML2, 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, K ) ) 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, 'DORMLQ', SIDE // TRANS, M, N, K,
$ -1 ) )
LWKOPT = MAX( 1, NW )*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORMLQ', -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, 'DORMLQ', 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 DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
$ IINFO )
ELSE
*
* Use blocked code
*
IF( ( LEFT .AND. NOTRAN ) .OR.
$ ( .NOT.LEFT .AND. .NOT.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
*
IF( NOTRAN ) THEN
TRANST = 'T'
ELSE
TRANST = 'N'
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', 'Rowwise', NQ-I+1, IB, A( I, I ),
$ LDA, TAU( I ), T, LDT )
IF( LEFT ) THEN
*
* H or H' is applied to C(i:m,1:n)
*
MI = M - I + 1
IC = I
ELSE
*
* H or H' is applied to C(1:m,i:n)
*
NI = N - I + 1
JC = I
END IF
*
* Apply H or H'
*
CALL DLARFB( SIDE, TRANST, 'Forward', 'Rowwise', 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 DORMLQ
*
END
SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DORMQL 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(k) . . . H(2) H(1)
*
* as returned by DGEQLF. 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
* DGEQLF in the last 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 DGEQLF.
*
* 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, IINFO, IWS, 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, DORM2L, 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 = MAX( 1, N )
ELSE
NQ = N
NW = MAX( 1, 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
END IF
*
IF( INFO.EQ.0 ) THEN
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
LWKOPT = 1
ELSE
*
* 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, 'DORMQL', SIDE // TRANS, M, N,
$ K, -1 ) )
LWKOPT = NW*NB
END IF
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORMQL', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
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, 'DORMQL', 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 DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
$ IINFO )
ELSE
*
* Use blocked code
*
IF( ( LEFT .AND. NOTRAN ) .OR.
$ ( .NOT.LEFT .AND. .NOT.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
ELSE
MI = M
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+ib-1) . . . H(i+1) H(i)
*
CALL DLARFT( 'Backward', 'Columnwise', NQ-K+I+IB-1, IB,
$ A( 1, I ), LDA, TAU( I ), T, LDT )
IF( LEFT ) THEN
*
* H or H' is applied to C(1:m-k+i+ib-1,1:n)
*
MI = M - K + I + IB - 1
ELSE
*
* H or H' is applied to C(1:m,1:n-k+i+ib-1)
*
NI = N - K + I + IB - 1
END IF
*
* Apply H or H'
*
CALL DLARFB( SIDE, TRANS, 'Backward', 'Columnwise', MI, NI,
$ IB, A( 1, I ), LDA, T, LDT, C, LDC, WORK,
$ LDWORK )
10 CONTINUE
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of DORMQL
*
END
SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. 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' is applied to C(i:m,1:n)
*
MI = M - I + 1
IC = I
ELSE
*
* H or H' is applied to C(1:m,i:n)
*
NI = N - I + 1
JC = I
END IF
*
* Apply H or H'
*
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
SUBROUTINE DORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DORMR2 overwrites the general real m by n matrix C with
*
* Q * C if SIDE = 'L' and TRANS = 'N', or
*
* Q'* C if SIDE = 'L' and TRANS = 'T', or
*
* C * Q if SIDE = 'R' and TRANS = 'N', or
*
* C * Q' 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 DGERQF. 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' from the Left
* = 'R': apply Q or Q' from the Right
*
* TRANS (input) CHARACTER*1
* = 'N': apply Q (No transpose)
* = 'T': apply Q' (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,M) if SIDE = 'L',
* (LDA,N) if SIDE = 'R'
* The i-th row must contain the vector which defines the
* elementary reflector H(i), for i = 1,2,...,k, as returned by
* DGERQF in the last k rows 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. LDA >= max(1,K).
*
* TAU (input) DOUBLE PRECISION array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by DGERQF.
*
* 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'*C or C*Q' 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, 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, K ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORMR2', -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
ELSE
MI = M
END IF
*
DO 10 I = I1, I2, I3
IF( LEFT ) THEN
*
* H(i) is applied to C(1:m-k+i,1:n)
*
MI = M - K + I
ELSE
*
* H(i) is applied to C(1:m,1:n-k+i)
*
NI = N - K + I
END IF
*
* Apply H(i)
*
AII = A( I, NQ-K+I )
A( I, NQ-K+I ) = ONE
CALL DLARF( SIDE, MI, NI, A( I, 1 ), LDA, TAU( I ), C, LDC,
$ WORK )
A( I, NQ-K+I ) = AII
10 CONTINUE
RETURN
*
* End of DORMR2
*
END
SUBROUTINE DORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC,
$ WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, L, LDA, LDC, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DORMR3 overwrites the general real m by n matrix C with
*
* Q * C if SIDE = 'L' and TRANS = 'N', or
*
* Q'* C if SIDE = 'L' and TRANS = 'T', or
*
* C * Q if SIDE = 'R' and TRANS = 'N', or
*
* C * Q' 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 DTZRZF. 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' from the Left
* = 'R': apply Q or Q' from the Right
*
* TRANS (input) CHARACTER*1
* = 'N': apply Q (No transpose)
* = 'T': apply Q' (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.
*
* L (input) INTEGER
* The number of columns of the matrix A containing
* the meaningful part of the Householder reflectors.
* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
*
* A (input) DOUBLE PRECISION array, dimension
* (LDA,M) if SIDE = 'L',
* (LDA,N) if SIDE = 'R'
* The i-th row must contain the vector which defines the
* elementary reflector H(i), for i = 1,2,...,k, as returned by
* DTZRZF in the last k rows 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. LDA >= max(1,K).
*
* TAU (input) DOUBLE PRECISION array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by DTZRZF.
*
* 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'*C or C*Q' 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
*
* Further Details
* ===============
*
* Based on contributions by
* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, IC, JA, JC, MI, NI, NQ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DLARZ, 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( L.LT.0 .OR. ( LEFT .AND. ( L.GT.M ) ) .OR.
$ ( .NOT.LEFT .AND. ( L.GT.N ) ) ) THEN
INFO = -6
ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
INFO = -8
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -11
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORMR3', -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
JA = M - L + 1
JC = 1
ELSE
MI = M
JA = N - L + 1
IC = 1
END IF
*
DO 10 I = I1, I2, I3
IF( LEFT ) THEN
*
* H(i) or H(i)' is applied to C(i:m,1:n)
*
MI = M - I + 1
IC = I
ELSE
*
* H(i) or H(i)' is applied to C(1:m,i:n)
*
NI = N - I + 1
JC = I
END IF
*
* Apply H(i) or H(i)'
*
CALL DLARZ( SIDE, MI, NI, L, A( I, JA ), LDA, TAU( I ),
$ C( IC, JC ), LDC, WORK )
*
10 CONTINUE
*
RETURN
*
* End of DORMR3
*
END
SUBROUTINE DORMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DORMRQ 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 DGERQF. 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,M) if SIDE = 'L',
* (LDA,N) if SIDE = 'R'
* The i-th row must contain the vector which defines the
* elementary reflector H(i), for i = 1,2,...,k, as returned by
* DGERQF in the last k rows 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. LDA >= max(1,K).
*
* TAU (input) DOUBLE PRECISION array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by DGERQF.
*
* 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
CHARACTER TRANST
INTEGER I, I1, I2, I3, IB, IINFO, IWS, 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, DORMR2, 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 = MAX( 1, N )
ELSE
NQ = N
NW = MAX( 1, 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, K ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
END IF
*
IF( INFO.EQ.0 ) THEN
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
LWKOPT = 1
ELSE
*
* 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, 'DORMRQ', SIDE // TRANS, M, N,
$ K, -1 ) )
LWKOPT = NW*NB
END IF
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORMRQ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
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, 'DORMRQ', 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 DORMR2( 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
ELSE
MI = M
END IF
*
IF( NOTRAN ) THEN
TRANST = 'T'
ELSE
TRANST = 'N'
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+ib-1) . . . H(i+1) H(i)
*
CALL DLARFT( 'Backward', 'Rowwise', NQ-K+I+IB-1, IB,
$ A( I, 1 ), LDA, TAU( I ), T, LDT )
IF( LEFT ) THEN
*
* H or H' is applied to C(1:m-k+i+ib-1,1:n)
*
MI = M - K + I + IB - 1
ELSE
*
* H or H' is applied to C(1:m,1:n-k+i+ib-1)
*
NI = N - K + I + IB - 1
END IF
*
* Apply H or H'
*
CALL DLARFB( SIDE, TRANST, 'Backward', 'Rowwise', MI, NI,
$ IB, A( I, 1 ), LDA, T, LDT, C, LDC, WORK,
$ LDWORK )
10 CONTINUE
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of DORMRQ
*
END
SUBROUTINE DORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC,
$ WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* January 2007
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, L, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DORMRZ 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 DTZRZF. 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.
*
* L (input) INTEGER
* The number of columns of the matrix A containing
* the meaningful part of the Householder reflectors.
* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
*
* A (input) DOUBLE PRECISION array, dimension
* (LDA,M) if SIDE = 'L',
* (LDA,N) if SIDE = 'R'
* The i-th row must contain the vector which defines the
* elementary reflector H(i), for i = 1,2,...,k, as returned by
* DTZRZF in the last k rows 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. LDA >= max(1,K).
*
* TAU (input) DOUBLE PRECISION array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by DTZRZF.
*
* 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**H*C or C*Q**H 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
*
* Further Details
* ===============
*
* Based on contributions by
* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*
* =====================================================================
*
* .. Parameters ..
INTEGER NBMAX, LDT
PARAMETER ( NBMAX = 64, LDT = NBMAX+1 )
* ..
* .. Local Scalars ..
LOGICAL LEFT, LQUERY, NOTRAN
CHARACTER TRANST
INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JA, 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 DLARZB, DLARZT, DORMR3, 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 = MAX( 1, N )
ELSE
NQ = N
NW = MAX( 1, 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( L.LT.0 .OR. ( LEFT .AND. ( L.GT.M ) ) .OR.
$ ( .NOT.LEFT .AND. ( L.GT.N ) ) ) THEN
INFO = -6
ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
INFO = -8
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -11
END IF
*
IF( INFO.EQ.0 ) THEN
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
LWKOPT = 1
ELSE
*
* 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, 'DORMRQ', SIDE // TRANS, M, N,
$ K, -1 ) )
LWKOPT = NW*NB
END IF
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORMRZ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.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, 'DORMRQ', 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 DORMR3( SIDE, TRANS, M, N, K, L, 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
JA = M - L + 1
ELSE
MI = M
IC = 1
JA = N - L + 1
END IF
*
IF( NOTRAN ) THEN
TRANST = 'T'
ELSE
TRANST = 'N'
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+ib-1) . . . H(i+1) H(i)
*
CALL DLARZT( 'Backward', 'Rowwise', L, IB, A( I, JA ), LDA,
$ TAU( I ), T, LDT )
*
IF( LEFT ) THEN
*
* H or H' is applied to C(i:m,1:n)
*
MI = M - I + 1
IC = I
ELSE
*
* H or H' is applied to C(1:m,i:n)
*
NI = N - I + 1
JC = I
END IF
*
* Apply H or H'
*
CALL DLARZB( SIDE, TRANST, 'Backward', 'Rowwise', MI, NI,
$ IB, L, A( I, JA ), LDA, T, LDT, C( IC, JC ),
$ LDC, WORK, LDWORK )
10 CONTINUE
*
END IF
*
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of DORMRZ
*
END
SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC,
$ WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS, UPLO
INTEGER INFO, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DORMTR 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 of order nq, with nq = m if
* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
* nq-1 elementary reflectors, as returned by DSYTRD:
*
* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
*
* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* = 'L': apply Q or Q**T from the Left;
* = 'R': apply Q or Q**T from the Right.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A contains elementary reflectors
* from DSYTRD;
* = 'L': Lower triangle of A contains elementary reflectors
* from DSYTRD.
*
* 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.
*
* A (input) DOUBLE PRECISION array, dimension
* (LDA,M) if SIDE = 'L'
* (LDA,N) if SIDE = 'R'
* The vectors which define the elementary reflectors, as
* returned by DSYTRD.
*
* LDA (input) INTEGER
* The leading dimension of the array A.
* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
*
* TAU (input) DOUBLE PRECISION array, dimension
* (M-1) if SIDE = 'L'
* (N-1) if SIDE = 'R'
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by DSYTRD.
*
* 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
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LEFT, LQUERY, UPPER
INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DORMQL, DORMQR, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LEFT = LSAME( SIDE, 'L' )
UPPER = LSAME( UPLO, 'U' )
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.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) )
$ THEN
INFO = -3
ELSE IF( M.LT.0 ) THEN
INFO = -4
ELSE IF( N.LT.0 ) 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
IF( UPPER ) THEN
IF( LEFT ) THEN
NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M-1, N, M-1,
$ -1 )
ELSE
NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N-1, N-1,
$ -1 )
END IF
ELSE
IF( LEFT ) THEN
NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M-1, N, M-1,
$ -1 )
ELSE
NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N-1, N-1,
$ -1 )
END IF
END IF
LWKOPT = MAX( 1, NW )*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORMTR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
IF( LEFT ) THEN
MI = M - 1
NI = N
ELSE
MI = M
NI = N - 1
END IF
*
IF( UPPER ) THEN
*
* Q was determined by a call to DSYTRD with UPLO = 'U'
*
CALL DORMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C,
$ LDC, WORK, LWORK, IINFO )
ELSE
*
* Q was determined by a call to DSYTRD with UPLO = 'L'
*
IF( LEFT ) THEN
I1 = 2
I2 = 1
ELSE
I1 = 1
I2 = 2
END IF
CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU,
$ C( I1, I2 ), LDC, WORK, LWORK, IINFO )
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of DORMTR
*
END
SUBROUTINE DPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK,
$ IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, KD, LDAB, N
DOUBLE PRECISION ANORM, RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION AB( LDAB, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DPBCON estimates the reciprocal of the condition number (in the
* 1-norm) of a real symmetric positive definite band matrix using the
* Cholesky factorization A = U**T*U or A = L*L**T computed by DPBTRF.
*
* An estimate is obtained for norm(inv(A)), and the reciprocal of the
* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangular factor stored in AB;
* = 'L': Lower triangular factor stored in AB.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
*
* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
* The triangular factor U or L from the Cholesky factorization
* A = U**T*U or A = L*L**T of the band matrix A, stored in the
* first KD+1 rows of the array. The j-th column of U or L is
* stored in the j-th column of the array AB as follows:
* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* ANORM (input) DOUBLE PRECISION
* The 1-norm (or infinity-norm) of the symmetric band matrix A.
*
* RCOND (output) DOUBLE PRECISION
* The reciprocal of the condition number of the matrix A,
* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
* estimate of the 1-norm of inv(A) computed in this routine.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
CHARACTER NORMIN
INTEGER IX, KASE
DOUBLE PRECISION AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, IDAMAX, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DLACN2, DLATBS, DRSCL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( KD.LT.0 ) THEN
INFO = -3
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -5
ELSE IF( ANORM.LT.ZERO ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPBCON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
RCOND = ZERO
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
ELSE IF( ANORM.EQ.ZERO ) THEN
RETURN
END IF
*
SMLNUM = DLAMCH( 'Safe minimum' )
*
* Estimate the 1-norm of the inverse.
*
KASE = 0
NORMIN = 'N'
10 CONTINUE
CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( UPPER ) THEN
*
* Multiply by inv(U').
*
CALL DLATBS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N,
$ KD, AB, LDAB, WORK, SCALEL, WORK( 2*N+1 ),
$ INFO )
NORMIN = 'Y'
*
* Multiply by inv(U).
*
CALL DLATBS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
$ KD, AB, LDAB, WORK, SCALEU, WORK( 2*N+1 ),
$ INFO )
ELSE
*
* Multiply by inv(L).
*
CALL DLATBS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N,
$ KD, AB, LDAB, WORK, SCALEL, WORK( 2*N+1 ),
$ INFO )
NORMIN = 'Y'
*
* Multiply by inv(L').
*
CALL DLATBS( 'Lower', 'Transpose', 'Non-unit', NORMIN, N,
$ KD, AB, LDAB, WORK, SCALEU, WORK( 2*N+1 ),
$ INFO )
END IF
*
* Multiply by 1/SCALE if doing so will not cause overflow.
*
SCALE = SCALEL*SCALEU
IF( SCALE.NE.ONE ) THEN
IX = IDAMAX( N, WORK, 1 )
IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
$ GO TO 20
CALL DRSCL( N, SCALE, WORK, 1 )
END IF
GO TO 10
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / AINVNM ) / ANORM
*
20 CONTINUE
*
RETURN
*
* End of DPBCON
*
END
SUBROUTINE DPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, KD, LDAB, N
DOUBLE PRECISION AMAX, SCOND
* ..
* .. Array Arguments ..
DOUBLE PRECISION AB( LDAB, * ), S( * )
* ..
*
* Purpose
* =======
*
* DPBEQU computes row and column scalings intended to equilibrate a
* symmetric positive definite band matrix A and reduce its condition
* number (with respect to the two-norm). S contains the scale factors,
* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
* choice of S puts the condition number of B within a factor N of the
* smallest possible condition number over all possible diagonal
* scalings.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangular of A is stored;
* = 'L': Lower triangular of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
*
* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
* The upper or lower triangle of the symmetric band matrix A,
* stored in the first KD+1 rows of the array. The j-th column
* of A is stored in the j-th column of the array AB as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*
* LDAB (input) INTEGER
* The leading dimension of the array A. LDAB >= KD+1.
*
* S (output) DOUBLE PRECISION array, dimension (N)
* If INFO = 0, S contains the scale factors for A.
*
* SCOND (output) DOUBLE PRECISION
* If INFO = 0, S contains the ratio of the smallest S(i) to
* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
* large nor too small, it is not worth scaling by S.
*
* AMAX (output) DOUBLE PRECISION
* Absolute value of largest matrix element. If AMAX is very
* close to overflow or very close to underflow, the matrix
* should be scaled.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = i, the i-th diagonal element is nonpositive.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, J
DOUBLE PRECISION SMIN
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( KD.LT.0 ) THEN
INFO = -3
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPBEQU', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
SCOND = ONE
AMAX = ZERO
RETURN
END IF
*
IF( UPPER ) THEN
J = KD + 1
ELSE
J = 1
END IF
*
* Initialize SMIN and AMAX.
*
S( 1 ) = AB( J, 1 )
SMIN = S( 1 )
AMAX = S( 1 )
*
* Find the minimum and maximum diagonal elements.
*
DO 10 I = 2, N
S( I ) = AB( J, I )
SMIN = MIN( SMIN, S( I ) )
AMAX = MAX( AMAX, S( I ) )
10 CONTINUE
*
IF( SMIN.LE.ZERO ) THEN
*
* Find the first non-positive diagonal element and return.
*
DO 20 I = 1, N
IF( S( I ).LE.ZERO ) THEN
INFO = I
RETURN
END IF
20 CONTINUE
ELSE
*
* Set the scale factors to the reciprocals
* of the diagonal elements.
*
DO 30 I = 1, N
S( I ) = ONE / SQRT( S( I ) )
30 CONTINUE
*
* Compute SCOND = min(S(I)) / max(S(I))
*
SCOND = SQRT( SMIN ) / SQRT( AMAX )
END IF
RETURN
*
* End of DPBEQU
*
END
SUBROUTINE DPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B,
$ LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
$ BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* DPBRFS improves the computed solution to a system of linear
* equations when the coefficient matrix is symmetric positive definite
* and banded, and provides error bounds and backward error estimates
* for the solution.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrices B and X. NRHS >= 0.
*
* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
* The upper or lower triangle of the symmetric band matrix A,
* stored in the first KD+1 rows of the array. The j-th column
* of A is stored in the j-th column of the array AB as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)
* The triangular factor U or L from the Cholesky factorization
* A = U**T*U or A = L*L**T of the band matrix A as computed by
* DPBTRF, in the same storage format as A (see AB).
*
* LDAFB (input) INTEGER
* The leading dimension of the array AFB. LDAFB >= KD+1.
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
* On entry, the solution matrix X, as computed by DPBTRS.
* On exit, the improved solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Internal Parameters
* ===================
*
* ITMAX is the maximum number of steps of iterative refinement.
*
* =====================================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 5 )
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D+0 )
DOUBLE PRECISION THREE
PARAMETER ( THREE = 3.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER COUNT, I, J, K, KASE, L, NZ
DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DLACN2, DPBTRS, DSBMV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( KD.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -6
ELSE IF( LDAFB.LT.KD+1 ) THEN
INFO = -8
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -10
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPBRFS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
DO 10 J = 1, NRHS
FERR( J ) = ZERO
BERR( J ) = ZERO
10 CONTINUE
RETURN
END IF
*
* NZ = maximum number of nonzero elements in each row of A, plus 1
*
NZ = MIN( N+1, 2*KD+2 )
EPS = DLAMCH( 'Epsilon' )
SAFMIN = DLAMCH( 'Safe minimum' )
SAFE1 = NZ*SAFMIN
SAFE2 = SAFE1 / EPS
*
* Do for each right hand side
*
DO 140 J = 1, NRHS
*
COUNT = 1
LSTRES = THREE
20 CONTINUE
*
* Loop until stopping criterion is satisfied.
*
* Compute residual R = B - A * X
*
CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
CALL DSBMV( UPLO, N, KD, -ONE, AB, LDAB, X( 1, J ), 1, ONE,
$ WORK( N+1 ), 1 )
*
* Compute componentwise relative backward error from formula
*
* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
*
* where abs(Z) is the componentwise absolute value of the matrix
* or vector Z. If the i-th component of the denominator is less
* than SAFE2, then SAFE1 is added to the i-th components of the
* numerator and denominator before dividing.
*
DO 30 I = 1, N
WORK( I ) = ABS( B( I, J ) )
30 CONTINUE
*
* Compute abs(A)*abs(X) + abs(B).
*
IF( UPPER ) THEN
DO 50 K = 1, N
S = ZERO
XK = ABS( X( K, J ) )
L = KD + 1 - K
DO 40 I = MAX( 1, K-KD ), K - 1
WORK( I ) = WORK( I ) + ABS( AB( L+I, K ) )*XK
S = S + ABS( AB( L+I, K ) )*ABS( X( I, J ) )
40 CONTINUE
WORK( K ) = WORK( K ) + ABS( AB( KD+1, K ) )*XK + S
50 CONTINUE
ELSE
DO 70 K = 1, N
S = ZERO
XK = ABS( X( K, J ) )
WORK( K ) = WORK( K ) + ABS( AB( 1, K ) )*XK
L = 1 - K
DO 60 I = K + 1, MIN( N, K+KD )
WORK( I ) = WORK( I ) + ABS( AB( L+I, K ) )*XK
S = S + ABS( AB( L+I, K ) )*ABS( X( I, J ) )
60 CONTINUE
WORK( K ) = WORK( K ) + S
70 CONTINUE
END IF
S = ZERO
DO 80 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
ELSE
S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
$ ( WORK( I )+SAFE1 ) )
END IF
80 CONTINUE
BERR( J ) = S
*
* Test stopping criterion. Continue iterating if
* 1) The residual BERR(J) is larger than machine epsilon, and
* 2) BERR(J) decreased by at least a factor of 2 during the
* last iteration, and
* 3) At most ITMAX iterations tried.
*
IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
$ COUNT.LE.ITMAX ) THEN
*
* Update solution and try again.
*
CALL DPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK( N+1 ), N,
$ INFO )
CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
LSTRES = BERR( J )
COUNT = COUNT + 1
GO TO 20
END IF
*
* Bound error from formula
*
* norm(X - XTRUE) / norm(X) .le. FERR =
* norm( abs(inv(A))*
* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
*
* where
* norm(Z) is the magnitude of the largest component of Z
* inv(A) is the inverse of A
* abs(Z) is the componentwise absolute value of the matrix or
* vector Z
* NZ is the maximum number of nonzeros in any row of A, plus 1
* EPS is machine epsilon
*
* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
* is incremented by SAFE1 if the i-th component of
* abs(A)*abs(X) + abs(B) is less than SAFE2.
*
* Use DLACN2 to estimate the infinity-norm of the matrix
* inv(A) * diag(W),
* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
*
DO 90 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
ELSE
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
END IF
90 CONTINUE
*
KASE = 0
100 CONTINUE
CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
$ KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Multiply by diag(W)*inv(A').
*
CALL DPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK( N+1 ), N,
$ INFO )
DO 110 I = 1, N
WORK( N+I ) = WORK( N+I )*WORK( I )
110 CONTINUE
ELSE IF( KASE.EQ.2 ) THEN
*
* Multiply by inv(A)*diag(W).
*
DO 120 I = 1, N
WORK( N+I ) = WORK( N+I )*WORK( I )
120 CONTINUE
CALL DPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK( N+1 ), N,
$ INFO )
END IF
GO TO 100
END IF
*
* Normalize error.
*
LSTRES = ZERO
DO 130 I = 1, N
LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
130 CONTINUE
IF( LSTRES.NE.ZERO )
$ FERR( J ) = FERR( J ) / LSTRES
*
140 CONTINUE
*
RETURN
*
* End of DPBRFS
*
END
SUBROUTINE DPBSTF( UPLO, N, KD, AB, LDAB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, KD, LDAB, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AB( LDAB, * )
* ..
*
* Purpose
* =======
*
* DPBSTF computes a split Cholesky factorization of a real
* symmetric positive definite band matrix A.
*
* This routine is designed to be used in conjunction with DSBGST.
*
* The factorization has the form A = S**T*S where S is a band matrix
* of the same bandwidth as A and the following structure:
*
* S = ( U )
* ( M L )
*
* where U is upper triangular of order m = (n+kd)/2, and L is lower
* triangular of order n-m.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
*
* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
* On entry, the upper or lower triangle of the symmetric band
* matrix A, stored in the first kd+1 rows of the array. The
* j-th column of A is stored in the j-th column of the array AB
* as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*
* On exit, if INFO = 0, the factor S from the split Cholesky
* factorization A = S**T*S. See Further Details.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, the factorization could not be completed,
* because the updated element a(i,i) was negative; the
* matrix A is not positive definite.
*
* Further Details
* ===============
*
* The band storage scheme is illustrated by the following example, when
* N = 7, KD = 2:
*
* S = ( s11 s12 s13 )
* ( s22 s23 s24 )
* ( s33 s34 )
* ( s44 )
* ( s53 s54 s55 )
* ( s64 s65 s66 )
* ( s75 s76 s77 )
*
* If UPLO = 'U', the array AB holds:
*
* on entry: on exit:
*
* * * a13 a24 a35 a46 a57 * * s13 s24 s53 s64 s75
* * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54 s65 s76
* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77
*
* If UPLO = 'L', the array AB holds:
*
* on entry: on exit:
*
* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77
* a21 a32 a43 a54 a65 a76 * s12 s23 s34 s54 s65 s76 *
* a31 a42 a53 a64 a64 * * s13 s24 s53 s64 s75 * *
*
* Array elements marked * are not used by the routine.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, KLD, KM, M
DOUBLE PRECISION AJJ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, DSYR, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( KD.LT.0 ) THEN
INFO = -3
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPBSTF', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
KLD = MAX( 1, LDAB-1 )
*
* Set the splitting point m.
*
M = ( N+KD ) / 2
*
IF( UPPER ) THEN
*
* Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m).
*
DO 10 J = N, M + 1, -1
*
* Compute s(j,j) and test for non-positive-definiteness.
*
AJJ = AB( KD+1, J )
IF( AJJ.LE.ZERO )
$ GO TO 50
AJJ = SQRT( AJJ )
AB( KD+1, J ) = AJJ
KM = MIN( J-1, KD )
*
* Compute elements j-km:j-1 of the j-th column and update the
* the leading submatrix within the band.
*
CALL DSCAL( KM, ONE / AJJ, AB( KD+1-KM, J ), 1 )
CALL DSYR( 'Upper', KM, -ONE, AB( KD+1-KM, J ), 1,
$ AB( KD+1, J-KM ), KLD )
10 CONTINUE
*
* Factorize the updated submatrix A(1:m,1:m) as U**T*U.
*
DO 20 J = 1, M
*
* Compute s(j,j) and test for non-positive-definiteness.
*
AJJ = AB( KD+1, J )
IF( AJJ.LE.ZERO )
$ GO TO 50
AJJ = SQRT( AJJ )
AB( KD+1, J ) = AJJ
KM = MIN( KD, M-J )
*
* Compute elements j+1:j+km of the j-th row and update the
* trailing submatrix within the band.
*
IF( KM.GT.0 ) THEN
CALL DSCAL( KM, ONE / AJJ, AB( KD, J+1 ), KLD )
CALL DSYR( 'Upper', KM, -ONE, AB( KD, J+1 ), KLD,
$ AB( KD+1, J+1 ), KLD )
END IF
20 CONTINUE
ELSE
*
* Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m).
*
DO 30 J = N, M + 1, -1
*
* Compute s(j,j) and test for non-positive-definiteness.
*
AJJ = AB( 1, J )
IF( AJJ.LE.ZERO )
$ GO TO 50
AJJ = SQRT( AJJ )
AB( 1, J ) = AJJ
KM = MIN( J-1, KD )
*
* Compute elements j-km:j-1 of the j-th row and update the
* trailing submatrix within the band.
*
CALL DSCAL( KM, ONE / AJJ, AB( KM+1, J-KM ), KLD )
CALL DSYR( 'Lower', KM, -ONE, AB( KM+1, J-KM ), KLD,
$ AB( 1, J-KM ), KLD )
30 CONTINUE
*
* Factorize the updated submatrix A(1:m,1:m) as U**T*U.
*
DO 40 J = 1, M
*
* Compute s(j,j) and test for non-positive-definiteness.
*
AJJ = AB( 1, J )
IF( AJJ.LE.ZERO )
$ GO TO 50
AJJ = SQRT( AJJ )
AB( 1, J ) = AJJ
KM = MIN( KD, M-J )
*
* Compute elements j+1:j+km of the j-th column and update the
* trailing submatrix within the band.
*
IF( KM.GT.0 ) THEN
CALL DSCAL( KM, ONE / AJJ, AB( 2, J ), 1 )
CALL DSYR( 'Lower', KM, -ONE, AB( 2, J ), 1,
$ AB( 1, J+1 ), KLD )
END IF
40 CONTINUE
END IF
RETURN
*
50 CONTINUE
INFO = J
RETURN
*
* End of DPBSTF
*
END
SUBROUTINE DPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, KD, LDAB, LDB, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION AB( LDAB, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* DPBSV computes the solution to a real system of linear equations
* A * X = B,
* where A is an N-by-N symmetric positive definite band matrix and X
* and B are N-by-NRHS matrices.
*
* The Cholesky decomposition is used to factor A as
* A = U**T * U, if UPLO = 'U', or
* A = L * L**T, if UPLO = 'L',
* where U is an upper triangular band matrix, and L is a lower
* triangular band matrix, with the same number of superdiagonals or
* subdiagonals as A. The factored form of A is then used to solve the
* system of equations A * X = B.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The number of linear equations, i.e., the order of the
* matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrix B. NRHS >= 0.
*
* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
* On entry, the upper or lower triangle of the symmetric band
* matrix A, stored in the first KD+1 rows of the array. The
* j-th column of A is stored in the j-th column of the array AB
* as follows:
* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).
* See below for further details.
*
* On exit, if INFO = 0, the triangular factor U or L from the
* Cholesky factorization A = U**T*U or A = L*L**T of the band
* matrix A, in the same storage format as A.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the N-by-NRHS right hand side matrix B.
* On exit, if INFO = 0, the N-by-NRHS 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
* > 0: if INFO = i, the leading minor of order i of A is not
* positive definite, so the factorization could not be
* completed, and the solution has not been computed.
*
* Further Details
* ===============
*
* The band storage scheme is illustrated by the following example, when
* N = 6, KD = 2, and UPLO = 'U':
*
* On entry: On exit:
*
* * * a13 a24 a35 a46 * * u13 u24 u35 u46
* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
*
* Similarly, if UPLO = 'L' the format of A is as follows:
*
* On entry: On exit:
*
* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
* a31 a42 a53 a64 * * l31 l42 l53 l64 * *
*
* Array elements marked * are not used by the routine.
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DPBTRF, DPBTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( KD.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -6
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPBSV ', -INFO )
RETURN
END IF
*
* Compute the Cholesky factorization A = U'*U or A = L*L'.
*
CALL DPBTRF( UPLO, N, KD, AB, LDAB, INFO )
IF( INFO.EQ.0 ) THEN
*
* Solve the system A*X = B, overwriting B with X.
*
CALL DPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
*
END IF
RETURN
*
* End of DPBSV
*
END
SUBROUTINE DPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB,
$ EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR,
$ WORK, IWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER EQUED, FACT, UPLO
INTEGER INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS
DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
$ BERR( * ), FERR( * ), S( * ), WORK( * ),
$ X( LDX, * )
* ..
*
* Purpose
* =======
*
* DPBSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to
* compute the solution to a real system of linear equations
* A * X = B,
* where A is an N-by-N symmetric positive definite band matrix and X
* and B are N-by-NRHS matrices.
*
* Error bounds on the solution and a condition estimate are also
* provided.
*
* Description
* ===========
*
* The following steps are performed:
*
* 1. If FACT = 'E', real scaling factors are computed to equilibrate
* the system:
* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
* Whether or not the system will be equilibrated depends on the
* scaling of the matrix A, but if equilibration is used, A is
* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
*
* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
* factor the matrix A (after equilibration if FACT = 'E') as
* A = U**T * U, if UPLO = 'U', or
* A = L * L**T, if UPLO = 'L',
* where U is an upper triangular band matrix, and L is a lower
* triangular band matrix.
*
* 3. If the leading i-by-i principal minor is not positive definite,
* then the routine returns with INFO = i. Otherwise, the factored
* form of A is used to estimate the condition number of the matrix
* A. If the reciprocal of the condition number is less than machine
* precision, INFO = N+1 is returned as a warning, but the routine
* still goes on to solve for X and compute error bounds as
* described below.
*
* 4. The system of equations is solved for X using the factored form
* of A.
*
* 5. Iterative refinement is applied to improve the computed solution
* matrix and calculate error bounds and backward error estimates
* for it.
*
* 6. If equilibration was used, the matrix X is premultiplied by
* diag(S) so that it solves the original system before
* equilibration.
*
* Arguments
* =========
*
* FACT (input) CHARACTER*1
* Specifies whether or not the factored form of the matrix A is
* supplied on entry, and if not, whether the matrix A should be
* equilibrated before it is factored.
* = 'F': On entry, AFB contains the factored form of A.
* If EQUED = 'Y', the matrix A has been equilibrated
* with scaling factors given by S. AB and AFB will not
* be modified.
* = 'N': The matrix A will be copied to AFB and factored.
* = 'E': The matrix A will be equilibrated if necessary, then
* copied to AFB and factored.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The number of linear equations, i.e., the order of the
* matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
*
* NRHS (input) INTEGER
* The number of right-hand sides, i.e., the number of columns
* of the matrices B and X. NRHS >= 0.
*
* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
* On entry, the upper or lower triangle of the symmetric band
* matrix A, stored in the first KD+1 rows of the array, except
* if FACT = 'F' and EQUED = 'Y', then A must contain the
* equilibrated matrix diag(S)*A*diag(S). The j-th column of A
* is stored in the j-th column of the array AB as follows:
* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).
* See below for further details.
*
* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
* diag(S)*A*diag(S).
*
* LDAB (input) INTEGER
* The leading dimension of the array A. LDAB >= KD+1.
*
* AFB (input or output) DOUBLE PRECISION array, dimension (LDAFB,N)
* If FACT = 'F', then AFB is an input argument and on entry
* contains the triangular factor U or L from the Cholesky
* factorization A = U**T*U or A = L*L**T of the band matrix
* A, in the same storage format as A (see AB). If EQUED = 'Y',
* then AFB is the factored form of the equilibrated matrix A.
*
* If FACT = 'N', then AFB is an output argument and on exit
* returns the triangular factor U or L from the Cholesky
* factorization A = U**T*U or A = L*L**T.
*
* If FACT = 'E', then AFB is an output argument and on exit
* returns the triangular factor U or L from the Cholesky
* factorization A = U**T*U or A = L*L**T of the equilibrated
* matrix A (see the description of A for the form of the
* equilibrated matrix).
*
* LDAFB (input) INTEGER
* The leading dimension of the array AFB. LDAFB >= KD+1.
*
* EQUED (input or output) CHARACTER*1
* Specifies the form of equilibration that was done.
* = 'N': No equilibration (always true if FACT = 'N').
* = 'Y': Equilibration was done, i.e., A has been replaced by
* diag(S) * A * diag(S).
* EQUED is an input argument if FACT = 'F'; otherwise, it is an
* output argument.
*
* S (input or output) DOUBLE PRECISION array, dimension (N)
* The scale factors for A; not accessed if EQUED = 'N'. S is
* an input argument if FACT = 'F'; otherwise, S is an output
* argument. If FACT = 'F' and EQUED = 'Y', each element of S
* must be positive.
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the N-by-NRHS right hand side matrix B.
* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
* B is overwritten by diag(S) * B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
* the original system of equations. Note that if EQUED = 'Y',
* A and B are modified on exit, and the solution to the
* equilibrated system is inv(diag(S))*X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* RCOND (output) DOUBLE PRECISION
* The estimate of the reciprocal condition number of the matrix
* A after equilibration (if done). If RCOND is less than the
* machine precision (in particular, if RCOND = 0), the matrix
* is singular to working precision. This condition is
* indicated by a return code of INFO > 0.
*
* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, and i is
* <= N: the leading minor of order i of A is
* not positive definite, so the factorization
* could not be completed, and the solution has not
* been computed. RCOND = 0 is returned.
* = N+1: U is nonsingular, but RCOND is less than machine
* precision, meaning that the matrix is singular
* to working precision. Nevertheless, the
* solution and error bounds are computed because
* there are a number of situations where the
* computed solution can be more accurate than the
* value of RCOND would suggest.
*
* Further Details
* ===============
*
* The band storage scheme is illustrated by the following example, when
* N = 6, KD = 2, and UPLO = 'U':
*
* Two-dimensional storage of the symmetric matrix A:
*
* a11 a12 a13
* a22 a23 a24
* a33 a34 a35
* a44 a45 a46
* a55 a56
* (aij=conjg(aji)) a66
*
* Band storage of the upper triangle of A:
*
* * * a13 a24 a35 a46
* * a12 a23 a34 a45 a56
* a11 a22 a33 a44 a55 a66
*
* Similarly, if UPLO = 'L' the format of A is as follows:
*
* a11 a22 a33 a44 a55 a66
* a21 a32 a43 a54 a65 *
* a31 a42 a53 a64 * *
*
* Array elements marked * are not used by the routine.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL EQUIL, NOFACT, RCEQU, UPPER
INTEGER I, INFEQU, J, J1, J2
DOUBLE PRECISION AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANSB
EXTERNAL LSAME, DLAMCH, DLANSB
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLACPY, DLAQSB, DPBCON, DPBEQU, DPBRFS,
$ DPBTRF, DPBTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
NOFACT = LSAME( FACT, 'N' )
EQUIL = LSAME( FACT, 'E' )
UPPER = LSAME( UPLO, 'U' )
IF( NOFACT .OR. EQUIL ) THEN
EQUED = 'N'
RCEQU = .FALSE.
ELSE
RCEQU = LSAME( EQUED, 'Y' )
SMLNUM = DLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
END IF
*
* Test the input parameters.
*
IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
$ THEN
INFO = -1
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( KD.LT.0 ) THEN
INFO = -4
ELSE IF( NRHS.LT.0 ) THEN
INFO = -5
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -7
ELSE IF( LDAFB.LT.KD+1 ) THEN
INFO = -9
ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
$ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
INFO = -10
ELSE
IF( RCEQU ) THEN
SMIN = BIGNUM
SMAX = ZERO
DO 10 J = 1, N
SMIN = MIN( SMIN, S( J ) )
SMAX = MAX( SMAX, S( J ) )
10 CONTINUE
IF( SMIN.LE.ZERO ) THEN
INFO = -11
ELSE IF( N.GT.0 ) THEN
SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
ELSE
SCOND = ONE
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -13
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -15
END IF
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPBSVX', -INFO )
RETURN
END IF
*
IF( EQUIL ) THEN
*
* Compute row and column scalings to equilibrate the matrix A.
*
CALL DPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFEQU )
IF( INFEQU.EQ.0 ) THEN
*
* Equilibrate the matrix.
*
CALL DLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )
RCEQU = LSAME( EQUED, 'Y' )
END IF
END IF
*
* Scale the right-hand side.
*
IF( RCEQU ) THEN
DO 30 J = 1, NRHS
DO 20 I = 1, N
B( I, J ) = S( I )*B( I, J )
20 CONTINUE
30 CONTINUE
END IF
*
IF( NOFACT .OR. EQUIL ) THEN
*
* Compute the Cholesky factorization A = U'*U or A = L*L'.
*
IF( UPPER ) THEN
DO 40 J = 1, N
J1 = MAX( J-KD, 1 )
CALL DCOPY( J-J1+1, AB( KD+1-J+J1, J ), 1,
$ AFB( KD+1-J+J1, J ), 1 )
40 CONTINUE
ELSE
DO 50 J = 1, N
J2 = MIN( J+KD, N )
CALL DCOPY( J2-J+1, AB( 1, J ), 1, AFB( 1, J ), 1 )
50 CONTINUE
END IF
*
CALL DPBTRF( UPLO, N, KD, AFB, LDAFB, INFO )
*
* Return if INFO is non-zero.
*
IF( INFO.GT.0 )THEN
RCOND = ZERO
RETURN
END IF
END IF
*
* Compute the norm of the matrix A.
*
ANORM = DLANSB( '1', UPLO, N, KD, AB, LDAB, WORK )
*
* Compute the reciprocal of the condition number of A.
*
CALL DPBCON( UPLO, N, KD, AFB, LDAFB, ANORM, RCOND, WORK, IWORK,
$ INFO )
*
* Compute the solution matrix X.
*
CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
CALL DPBTRS( UPLO, N, KD, NRHS, AFB, LDAFB, X, LDX, INFO )
*
* Use iterative refinement to improve the computed solution and
* compute error bounds and backward error estimates for it.
*
CALL DPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X,
$ LDX, FERR, BERR, WORK, IWORK, INFO )
*
* Transform the solution matrix X to a solution of the original
* system.
*
IF( RCEQU ) THEN
DO 70 J = 1, NRHS
DO 60 I = 1, N
X( I, J ) = S( I )*X( I, J )
60 CONTINUE
70 CONTINUE
DO 80 J = 1, NRHS
FERR( J ) = FERR( J ) / SCOND
80 CONTINUE
END IF
*
* Set INFO = N+1 if the matrix is singular to working precision.
*
IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
$ INFO = N + 1
*
RETURN
*
* End of DPBSVX
*
END
SUBROUTINE DPBTF2( UPLO, N, KD, AB, LDAB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, KD, LDAB, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AB( LDAB, * )
* ..
*
* Purpose
* =======
*
* DPBTF2 computes the Cholesky factorization of a real symmetric
* positive definite band matrix A.
*
* The factorization has the form
* A = U' * U , if UPLO = 'U', or
* A = L * L', if UPLO = 'L',
* where U is an upper triangular matrix, U' is the transpose of U, and
* L is lower triangular.
*
* This is the unblocked version of the algorithm, calling Level 2 BLAS.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of super-diagonals of the matrix A if UPLO = 'U',
* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
*
* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
* On entry, the upper or lower triangle of the symmetric band
* matrix A, stored in the first KD+1 rows of the array. The
* j-th column of A is stored in the j-th column of the array AB
* as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*
* On exit, if INFO = 0, the triangular factor U or L from the
* Cholesky factorization A = U'*U or A = L*L' of the band
* matrix A, in the same storage format as A.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
* > 0: if INFO = k, the leading minor of order k is not
* positive definite, and the factorization could not be
* completed.
*
* Further Details
* ===============
*
* The band storage scheme is illustrated by the following example, when
* N = 6, KD = 2, and UPLO = 'U':
*
* On entry: On exit:
*
* * * a13 a24 a35 a46 * * u13 u24 u35 u46
* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
*
* Similarly, if UPLO = 'L' the format of A is as follows:
*
* On entry: On exit:
*
* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
* a31 a42 a53 a64 * * l31 l42 l53 l64 * *
*
* Array elements marked * are not used by the routine.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, KLD, KN
DOUBLE PRECISION AJJ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, DSYR, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( KD.LT.0 ) THEN
INFO = -3
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPBTF2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
KLD = MAX( 1, LDAB-1 )
*
IF( UPPER ) THEN
*
* Compute the Cholesky factorization A = U'*U.
*
DO 10 J = 1, N
*
* Compute U(J,J) and test for non-positive-definiteness.
*
AJJ = AB( KD+1, J )
IF( AJJ.LE.ZERO )
$ GO TO 30
AJJ = SQRT( AJJ )
AB( KD+1, J ) = AJJ
*
* Compute elements J+1:J+KN of row J and update the
* trailing submatrix within the band.
*
KN = MIN( KD, N-J )
IF( KN.GT.0 ) THEN
CALL DSCAL( KN, ONE / AJJ, AB( KD, J+1 ), KLD )
CALL DSYR( 'Upper', KN, -ONE, AB( KD, J+1 ), KLD,
$ AB( KD+1, J+1 ), KLD )
END IF
10 CONTINUE
ELSE
*
* Compute the Cholesky factorization A = L*L'.
*
DO 20 J = 1, N
*
* Compute L(J,J) and test for non-positive-definiteness.
*
AJJ = AB( 1, J )
IF( AJJ.LE.ZERO )
$ GO TO 30
AJJ = SQRT( AJJ )
AB( 1, J ) = AJJ
*
* Compute elements J+1:J+KN of column J and update the
* trailing submatrix within the band.
*
KN = MIN( KD, N-J )
IF( KN.GT.0 ) THEN
CALL DSCAL( KN, ONE / AJJ, AB( 2, J ), 1 )
CALL DSYR( 'Lower', KN, -ONE, AB( 2, J ), 1,
$ AB( 1, J+1 ), KLD )
END IF
20 CONTINUE
END IF
RETURN
*
30 CONTINUE
INFO = J
RETURN
*
* End of DPBTF2
*
END
SUBROUTINE DPBTRF( UPLO, N, KD, AB, LDAB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, KD, LDAB, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AB( LDAB, * )
* ..
*
* Purpose
* =======
*
* DPBTRF computes the Cholesky factorization of a real symmetric
* positive definite band matrix A.
*
* The factorization has the form
* A = U**T * U, if UPLO = 'U', or
* A = L * L**T, if UPLO = 'L',
* where U is an upper triangular matrix and L is lower triangular.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
*
* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
* On entry, the upper or lower triangle of the symmetric band
* matrix A, stored in the first KD+1 rows of the array. The
* j-th column of A is stored in the j-th column of the array AB
* as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*
* On exit, if INFO = 0, the triangular factor U or L from the
* Cholesky factorization A = U**T*U or A = L*L**T of the band
* matrix A, in the same storage format as A.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, the leading minor of order i is not
* positive definite, and the factorization could not be
* completed.
*
* Further Details
* ===============
*
* The band storage scheme is illustrated by the following example, when
* N = 6, KD = 2, and UPLO = 'U':
*
* On entry: On exit:
*
* * * a13 a24 a35 a46 * * u13 u24 u35 u46
* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
*
* Similarly, if UPLO = 'L' the format of A is as follows:
*
* On entry: On exit:
*
* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
* a31 a42 a53 a64 * * l31 l42 l53 l64 * *
*
* Array elements marked * are not used by the routine.
*
* Contributed by
* Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
INTEGER NBMAX, LDWORK
PARAMETER ( NBMAX = 32, LDWORK = NBMAX+1 )
* ..
* .. Local Scalars ..
INTEGER I, I2, I3, IB, II, J, JJ, NB
* ..
* .. Local Arrays ..
DOUBLE PRECISION WORK( LDWORK, NBMAX )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DPBTF2, DPOTF2, DSYRK, DTRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( ( .NOT.LSAME( UPLO, 'U' ) ) .AND.
$ ( .NOT.LSAME( UPLO, 'L' ) ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( KD.LT.0 ) THEN
INFO = -3
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPBTRF', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Determine the block size for this environment
*
NB = ILAENV( 1, 'DPBTRF', UPLO, N, KD, -1, -1 )
*
* The block size must not exceed the semi-bandwidth KD, and must not
* exceed the limit set by the size of the local array WORK.
*
NB = MIN( NB, NBMAX )
*
IF( NB.LE.1 .OR. NB.GT.KD ) THEN
*
* Use unblocked code
*
CALL DPBTF2( UPLO, N, KD, AB, LDAB, INFO )
ELSE
*
* Use blocked code
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Compute the Cholesky factorization of a symmetric band
* matrix, given the upper triangle of the matrix in band
* storage.
*
* Zero the upper triangle of the work array.
*
DO 20 J = 1, NB
DO 10 I = 1, J - 1
WORK( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
*
* Process the band matrix one diagonal block at a time.
*
DO 70 I = 1, N, NB
IB = MIN( NB, N-I+1 )
*
* Factorize the diagonal block
*
CALL DPOTF2( UPLO, IB, AB( KD+1, I ), LDAB-1, II )
IF( II.NE.0 ) THEN
INFO = I + II - 1
GO TO 150
END IF
IF( I+IB.LE.N ) THEN
*
* Update the relevant part of the trailing submatrix.
* If A11 denotes the diagonal block which has just been
* factorized, then we need to update the remaining
* blocks in the diagram:
*
* A11 A12 A13
* A22 A23
* A33
*
* The numbers of rows and columns in the partitioning
* are IB, I2, I3 respectively. The blocks A12, A22 and
* A23 are empty if IB = KD. The upper triangle of A13
* lies outside the band.
*
I2 = MIN( KD-IB, N-I-IB+1 )
I3 = MIN( IB, N-I-KD+1 )
*
IF( I2.GT.0 ) THEN
*
* Update A12
*
CALL DTRSM( 'Left', 'Upper', 'Transpose',
$ 'Non-unit', IB, I2, ONE, AB( KD+1, I ),
$ LDAB-1, AB( KD+1-IB, I+IB ), LDAB-1 )
*
* Update A22
*
CALL DSYRK( 'Upper', 'Transpose', I2, IB, -ONE,
$ AB( KD+1-IB, I+IB ), LDAB-1, ONE,
$ AB( KD+1, I+IB ), LDAB-1 )
END IF
*
IF( I3.GT.0 ) THEN
*
* Copy the lower triangle of A13 into the work array.
*
DO 40 JJ = 1, I3
DO 30 II = JJ, IB
WORK( II, JJ ) = AB( II-JJ+1, JJ+I+KD-1 )
30 CONTINUE
40 CONTINUE
*
* Update A13 (in the work array).
*
CALL DTRSM( 'Left', 'Upper', 'Transpose',
$ 'Non-unit', IB, I3, ONE, AB( KD+1, I ),
$ LDAB-1, WORK, LDWORK )
*
* Update A23
*
IF( I2.GT.0 )
$ CALL DGEMM( 'Transpose', 'No Transpose', I2, I3,
$ IB, -ONE, AB( KD+1-IB, I+IB ),
$ LDAB-1, WORK, LDWORK, ONE,
$ AB( 1+IB, I+KD ), LDAB-1 )
*
* Update A33
*
CALL DSYRK( 'Upper', 'Transpose', I3, IB, -ONE,
$ WORK, LDWORK, ONE, AB( KD+1, I+KD ),
$ LDAB-1 )
*
* Copy the lower triangle of A13 back into place.
*
DO 60 JJ = 1, I3
DO 50 II = JJ, IB
AB( II-JJ+1, JJ+I+KD-1 ) = WORK( II, JJ )
50 CONTINUE
60 CONTINUE
END IF
END IF
70 CONTINUE
ELSE
*
* Compute the Cholesky factorization of a symmetric band
* matrix, given the lower triangle of the matrix in band
* storage.
*
* Zero the lower triangle of the work array.
*
DO 90 J = 1, NB
DO 80 I = J + 1, NB
WORK( I, J ) = ZERO
80 CONTINUE
90 CONTINUE
*
* Process the band matrix one diagonal block at a time.
*
DO 140 I = 1, N, NB
IB = MIN( NB, N-I+1 )
*
* Factorize the diagonal block
*
CALL DPOTF2( UPLO, IB, AB( 1, I ), LDAB-1, II )
IF( II.NE.0 ) THEN
INFO = I + II - 1
GO TO 150
END IF
IF( I+IB.LE.N ) THEN
*
* Update the relevant part of the trailing submatrix.
* If A11 denotes the diagonal block which has just been
* factorized, then we need to update the remaining
* blocks in the diagram:
*
* A11
* A21 A22
* A31 A32 A33
*
* The numbers of rows and columns in the partitioning
* are IB, I2, I3 respectively. The blocks A21, A22 and
* A32 are empty if IB = KD. The lower triangle of A31
* lies outside the band.
*
I2 = MIN( KD-IB, N-I-IB+1 )
I3 = MIN( IB, N-I-KD+1 )
*
IF( I2.GT.0 ) THEN
*
* Update A21
*
CALL DTRSM( 'Right', 'Lower', 'Transpose',
$ 'Non-unit', I2, IB, ONE, AB( 1, I ),
$ LDAB-1, AB( 1+IB, I ), LDAB-1 )
*
* Update A22
*
CALL DSYRK( 'Lower', 'No Transpose', I2, IB, -ONE,
$ AB( 1+IB, I ), LDAB-1, ONE,
$ AB( 1, I+IB ), LDAB-1 )
END IF
*
IF( I3.GT.0 ) THEN
*
* Copy the upper triangle of A31 into the work array.
*
DO 110 JJ = 1, IB
DO 100 II = 1, MIN( JJ, I3 )
WORK( II, JJ ) = AB( KD+1-JJ+II, JJ+I-1 )
100 CONTINUE
110 CONTINUE
*
* Update A31 (in the work array).
*
CALL DTRSM( 'Right', 'Lower', 'Transpose',
$ 'Non-unit', I3, IB, ONE, AB( 1, I ),
$ LDAB-1, WORK, LDWORK )
*
* Update A32
*
IF( I2.GT.0 )
$ CALL DGEMM( 'No transpose', 'Transpose', I3, I2,
$ IB, -ONE, WORK, LDWORK,
$ AB( 1+IB, I ), LDAB-1, ONE,
$ AB( 1+KD-IB, I+IB ), LDAB-1 )
*
* Update A33
*
CALL DSYRK( 'Lower', 'No Transpose', I3, IB, -ONE,
$ WORK, LDWORK, ONE, AB( 1, I+KD ),
$ LDAB-1 )
*
* Copy the upper triangle of A31 back into place.
*
DO 130 JJ = 1, IB
DO 120 II = 1, MIN( JJ, I3 )
AB( KD+1-JJ+II, JJ+I-1 ) = WORK( II, JJ )
120 CONTINUE
130 CONTINUE
END IF
END IF
140 CONTINUE
END IF
END IF
RETURN
*
150 CONTINUE
RETURN
*
* End of DPBTRF
*
END
SUBROUTINE DPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, KD, LDAB, LDB, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION AB( LDAB, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* DPBTRS solves a system of linear equations A*X = B with a symmetric
* positive definite band matrix A using the Cholesky factorization
* A = U**T*U or A = L*L**T computed by DPBTRF.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangular factor stored in AB;
* = 'L': Lower triangular factor stored in AB.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrix B. NRHS >= 0.
*
* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
* The triangular factor U or L from the Cholesky factorization
* A = U**T*U or A = L*L**T of the band matrix A, stored in the
* first KD+1 rows of the array. The j-th column of U or L is
* stored in the j-th column of the array AB as follows:
* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* 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
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DTBSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( KD.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -6
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPBTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Solve A*X = B where A = U'*U.
*
DO 10 J = 1, NRHS
*
* Solve U'*X = B, overwriting B with X.
*
CALL DTBSV( 'Upper', 'Transpose', 'Non-unit', N, KD, AB,
$ LDAB, B( 1, J ), 1 )
*
* Solve U*X = B, overwriting B with X.
*
CALL DTBSV( 'Upper', 'No transpose', 'Non-unit', N, KD, AB,
$ LDAB, B( 1, J ), 1 )
10 CONTINUE
ELSE
*
* Solve A*X = B where A = L*L'.
*
DO 20 J = 1, NRHS
*
* Solve L*X = B, overwriting B with X.
*
CALL DTBSV( 'Lower', 'No transpose', 'Non-unit', N, KD, AB,
$ LDAB, B( 1, J ), 1 )
*
* Solve L'*X = B, overwriting B with X.
*
CALL DTBSV( 'Lower', 'Transpose', 'Non-unit', N, KD, AB,
$ LDAB, B( 1, J ), 1 )
20 CONTINUE
END IF
*
RETURN
*
* End of DPBTRS
*
END
SUBROUTINE DPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
DOUBLE PRECISION ANORM, RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DPOCON estimates the reciprocal of the condition number (in the
* 1-norm) of a real symmetric positive definite matrix using the
* Cholesky factorization A = U**T*U or A = L*L**T computed by DPOTRF.
*
* An estimate is obtained for norm(inv(A)), and the reciprocal of the
* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The triangular factor U or L from the Cholesky factorization
* A = U**T*U or A = L*L**T, as computed by DPOTRF.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* ANORM (input) DOUBLE PRECISION
* The 1-norm (or infinity-norm) of the symmetric matrix A.
*
* RCOND (output) DOUBLE PRECISION
* The reciprocal of the condition number of the matrix A,
* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
* estimate of the 1-norm of inv(A) computed in this routine.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
CHARACTER NORMIN
INTEGER IX, KASE
DOUBLE PRECISION AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, IDAMAX, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DLACN2, DLATRS, DRSCL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( ANORM.LT.ZERO ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPOCON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
RCOND = ZERO
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
ELSE IF( ANORM.EQ.ZERO ) THEN
RETURN
END IF
*
SMLNUM = DLAMCH( 'Safe minimum' )
*
* Estimate the 1-norm of inv(A).
*
KASE = 0
NORMIN = 'N'
10 CONTINUE
CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( UPPER ) THEN
*
* Multiply by inv(U').
*
CALL DLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, A,
$ LDA, WORK, SCALEL, WORK( 2*N+1 ), INFO )
NORMIN = 'Y'
*
* Multiply by inv(U).
*
CALL DLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
$ A, LDA, WORK, SCALEU, WORK( 2*N+1 ), INFO )
ELSE
*
* Multiply by inv(L).
*
CALL DLATRS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N,
$ A, LDA, WORK, SCALEL, WORK( 2*N+1 ), INFO )
NORMIN = 'Y'
*
* Multiply by inv(L').
*
CALL DLATRS( 'Lower', 'Transpose', 'Non-unit', NORMIN, N, A,
$ LDA, WORK, SCALEU, WORK( 2*N+1 ), INFO )
END IF
*
* Multiply by 1/SCALE if doing so will not cause overflow.
*
SCALE = SCALEL*SCALEU
IF( SCALE.NE.ONE ) THEN
IX = IDAMAX( N, WORK, 1 )
IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
$ GO TO 20
CALL DRSCL( N, SCALE, WORK, 1 )
END IF
GO TO 10
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / AINVNM ) / ANORM
*
20 CONTINUE
RETURN
*
* End of DPOCON
*
END
SUBROUTINE DPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, N
DOUBLE PRECISION AMAX, SCOND
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), S( * )
* ..
*
* Purpose
* =======
*
* DPOEQU computes row and column scalings intended to equilibrate a
* symmetric positive definite matrix A and reduce its condition number
* (with respect to the two-norm). S contains the scale factors,
* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
* choice of S puts the condition number of B within a factor N of the
* smallest possible condition number over all possible diagonal
* scalings.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The N-by-N symmetric positive definite matrix whose scaling
* factors are to be computed. Only the diagonal elements of A
* are referenced.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* S (output) DOUBLE PRECISION array, dimension (N)
* If INFO = 0, S contains the scale factors for A.
*
* SCOND (output) DOUBLE PRECISION
* If INFO = 0, S contains the ratio of the smallest S(i) to
* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
* large nor too small, it is not worth scaling by S.
*
* AMAX (output) DOUBLE PRECISION
* Absolute value of largest matrix element. If AMAX is very
* close to overflow or very close to underflow, the matrix
* should be scaled.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, the i-th diagonal element is nonpositive.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I
DOUBLE PRECISION SMIN
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -3
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPOEQU', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
SCOND = ONE
AMAX = ZERO
RETURN
END IF
*
* Find the minimum and maximum diagonal elements.
*
S( 1 ) = A( 1, 1 )
SMIN = S( 1 )
AMAX = S( 1 )
DO 10 I = 2, N
S( I ) = A( I, I )
SMIN = MIN( SMIN, S( I ) )
AMAX = MAX( AMAX, S( I ) )
10 CONTINUE
*
IF( SMIN.LE.ZERO ) THEN
*
* Find the first non-positive diagonal element and return.
*
DO 20 I = 1, N
IF( S( I ).LE.ZERO ) THEN
INFO = I
RETURN
END IF
20 CONTINUE
ELSE
*
* Set the scale factors to the reciprocals
* of the diagonal elements.
*
DO 30 I = 1, N
S( I ) = ONE / SQRT( S( I ) )
30 CONTINUE
*
* Compute SCOND = min(S(I)) / max(S(I))
*
SCOND = SQRT( SMIN ) / SQRT( AMAX )
END IF
RETURN
*
* End of DPOEQU
*
END
SUBROUTINE DPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X,
$ LDX, FERR, BERR, WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
$ BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* DPORFS improves the computed solution to a system of linear
* equations when the coefficient matrix is symmetric positive definite,
* and provides error bounds and backward error estimates for the
* solution.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* 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 matrices B and X. NRHS >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
* upper triangular part of A contains the upper triangular part
* of the matrix A, and the strictly lower triangular part of A
* is not referenced. If UPLO = 'L', the leading N-by-N lower
* triangular part of A contains the lower triangular part of
* the matrix A, and the strictly upper triangular part of A is
* not referenced.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)
* The triangular factor U or L from the Cholesky factorization
* A = U**T*U or A = L*L**T, as computed by DPOTRF.
*
* LDAF (input) INTEGER
* The leading dimension of the array AF. LDAF >= max(1,N).
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
* On entry, the solution matrix X, as computed by DPOTRS.
* On exit, the improved solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Internal Parameters
* ===================
*
* ITMAX is the maximum number of steps of iterative refinement.
*
* =====================================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 5 )
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D+0 )
DOUBLE PRECISION THREE
PARAMETER ( THREE = 3.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER COUNT, I, J, K, KASE, NZ
DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DLACN2, DPOTRS, DSYMV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) 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( LDAF.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -11
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPORFS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
DO 10 J = 1, NRHS
FERR( J ) = ZERO
BERR( J ) = ZERO
10 CONTINUE
RETURN
END IF
*
* NZ = maximum number of nonzero elements in each row of A, plus 1
*
NZ = N + 1
EPS = DLAMCH( 'Epsilon' )
SAFMIN = DLAMCH( 'Safe minimum' )
SAFE1 = NZ*SAFMIN
SAFE2 = SAFE1 / EPS
*
* Do for each right hand side
*
DO 140 J = 1, NRHS
*
COUNT = 1
LSTRES = THREE
20 CONTINUE
*
* Loop until stopping criterion is satisfied.
*
* Compute residual R = B - A * X
*
CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
CALL DSYMV( UPLO, N, -ONE, A, LDA, X( 1, J ), 1, ONE,
$ WORK( N+1 ), 1 )
*
* Compute componentwise relative backward error from formula
*
* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
*
* where abs(Z) is the componentwise absolute value of the matrix
* or vector Z. If the i-th component of the denominator is less
* than SAFE2, then SAFE1 is added to the i-th components of the
* numerator and denominator before dividing.
*
DO 30 I = 1, N
WORK( I ) = ABS( B( I, J ) )
30 CONTINUE
*
* Compute abs(A)*abs(X) + abs(B).
*
IF( UPPER ) THEN
DO 50 K = 1, N
S = ZERO
XK = ABS( X( K, J ) )
DO 40 I = 1, K - 1
WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
40 CONTINUE
WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK + S
50 CONTINUE
ELSE
DO 70 K = 1, N
S = ZERO
XK = ABS( X( K, J ) )
WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK
DO 60 I = K + 1, N
WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
60 CONTINUE
WORK( K ) = WORK( K ) + S
70 CONTINUE
END IF
S = ZERO
DO 80 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
ELSE
S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
$ ( WORK( I )+SAFE1 ) )
END IF
80 CONTINUE
BERR( J ) = S
*
* Test stopping criterion. Continue iterating if
* 1) The residual BERR(J) is larger than machine epsilon, and
* 2) BERR(J) decreased by at least a factor of 2 during the
* last iteration, and
* 3) At most ITMAX iterations tried.
*
IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
$ COUNT.LE.ITMAX ) THEN
*
* Update solution and try again.
*
CALL DPOTRS( UPLO, N, 1, AF, LDAF, WORK( N+1 ), N, INFO )
CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
LSTRES = BERR( J )
COUNT = COUNT + 1
GO TO 20
END IF
*
* Bound error from formula
*
* norm(X - XTRUE) / norm(X) .le. FERR =
* norm( abs(inv(A))*
* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
*
* where
* norm(Z) is the magnitude of the largest component of Z
* inv(A) is the inverse of A
* abs(Z) is the componentwise absolute value of the matrix or
* vector Z
* NZ is the maximum number of nonzeros in any row of A, plus 1
* EPS is machine epsilon
*
* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
* is incremented by SAFE1 if the i-th component of
* abs(A)*abs(X) + abs(B) is less than SAFE2.
*
* Use DLACN2 to estimate the infinity-norm of the matrix
* inv(A) * diag(W),
* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
*
DO 90 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
ELSE
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
END IF
90 CONTINUE
*
KASE = 0
100 CONTINUE
CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
$ KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Multiply by diag(W)*inv(A').
*
CALL DPOTRS( UPLO, N, 1, AF, LDAF, WORK( N+1 ), N, INFO )
DO 110 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
110 CONTINUE
ELSE IF( KASE.EQ.2 ) THEN
*
* Multiply by inv(A)*diag(W).
*
DO 120 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
120 CONTINUE
CALL DPOTRS( UPLO, N, 1, AF, LDAF, WORK( N+1 ), N, INFO )
END IF
GO TO 100
END IF
*
* Normalize error.
*
LSTRES = ZERO
DO 130 I = 1, N
LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
130 CONTINUE
IF( LSTRES.NE.ZERO )
$ FERR( J ) = FERR( J ) / LSTRES
*
140 CONTINUE
*
RETURN
*
* End of DPORFS
*
END
SUBROUTINE DPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* DPOSV computes the solution to a real system of linear equations
* A * X = B,
* where A is an N-by-N symmetric positive definite matrix and X and B
* are N-by-NRHS matrices.
*
* The Cholesky decomposition is used to factor A as
* A = U**T* U, if UPLO = 'U', or
* A = L * L**T, if UPLO = 'L',
* where U is an upper triangular matrix and L is a lower triangular
* matrix. The factored form of A is then used to solve the system of
* equations A * X = B.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The number of linear equations, i.e., 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/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the symmetric matrix A. If UPLO = 'U', the leading
* N-by-N upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading N-by-N lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced.
*
* On exit, if INFO = 0, the factor U or L from the Cholesky
* factorization A = U**T*U or A = L*L**T.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the N-by-NRHS right hand side matrix B.
* On exit, if INFO = 0, the N-by-NRHS 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
* > 0: if INFO = i, the leading minor of order i of A is not
* positive definite, so the factorization could not be
* completed, and the solution has not been computed.
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DPOTRF, DPOTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) 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 = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPOSV ', -INFO )
RETURN
END IF
*
* Compute the Cholesky factorization A = U'*U or A = L*L'.
*
CALL DPOTRF( UPLO, N, A, LDA, INFO )
IF( INFO.EQ.0 ) THEN
*
* Solve the system A*X = B, overwriting B with X.
*
CALL DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
*
END IF
RETURN
*
* End of DPOSV
*
END
SUBROUTINE DPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED,
$ S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK,
$ IWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER EQUED, FACT, UPLO
INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
$ BERR( * ), FERR( * ), S( * ), WORK( * ),
$ X( LDX, * )
* ..
*
* Purpose
* =======
*
* DPOSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to
* compute the solution to a real system of linear equations
* A * X = B,
* where A is an N-by-N symmetric positive definite matrix and X and B
* are N-by-NRHS matrices.
*
* Error bounds on the solution and a condition estimate are also
* provided.
*
* Description
* ===========
*
* The following steps are performed:
*
* 1. If FACT = 'E', real scaling factors are computed to equilibrate
* the system:
* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
* Whether or not the system will be equilibrated depends on the
* scaling of the matrix A, but if equilibration is used, A is
* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
*
* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
* factor the matrix A (after equilibration if FACT = 'E') as
* A = U**T* U, if UPLO = 'U', or
* A = L * L**T, if UPLO = 'L',
* where U is an upper triangular matrix and L is a lower triangular
* matrix.
*
* 3. If the leading i-by-i principal minor is not positive definite,
* then the routine returns with INFO = i. Otherwise, the factored
* form of A is used to estimate the condition number of the matrix
* A. If the reciprocal of the condition number is less than machine
* precision, INFO = N+1 is returned as a warning, but the routine
* still goes on to solve for X and compute error bounds as
* described below.
*
* 4. The system of equations is solved for X using the factored form
* of A.
*
* 5. Iterative refinement is applied to improve the computed solution
* matrix and calculate error bounds and backward error estimates
* for it.
*
* 6. If equilibration was used, the matrix X is premultiplied by
* diag(S) so that it solves the original system before
* equilibration.
*
* Arguments
* =========
*
* FACT (input) CHARACTER*1
* Specifies whether or not the factored form of the matrix A is
* supplied on entry, and if not, whether the matrix A should be
* equilibrated before it is factored.
* = 'F': On entry, AF contains the factored form of A.
* If EQUED = 'Y', the matrix A has been equilibrated
* with scaling factors given by S. A and AF will not
* be modified.
* = 'N': The matrix A will be copied to AF and factored.
* = 'E': The matrix A will be equilibrated if necessary, then
* copied to AF and factored.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The number of linear equations, i.e., 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 matrices B and X. NRHS >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the symmetric matrix A, except if FACT = 'F' and
* EQUED = 'Y', then A must contain the equilibrated matrix
* diag(S)*A*diag(S). If UPLO = 'U', the leading
* N-by-N upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading N-by-N lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced. A is not modified if
* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
*
* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
* diag(S)*A*diag(S).
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N)
* If FACT = 'F', then AF is an input argument and on entry
* contains the triangular factor U or L from the Cholesky
* factorization A = U**T*U or A = L*L**T, in the same storage
* format as A. If EQUED .ne. 'N', then AF is the factored form
* of the equilibrated matrix diag(S)*A*diag(S).
*
* If FACT = 'N', then AF is an output argument and on exit
* returns the triangular factor U or L from the Cholesky
* factorization A = U**T*U or A = L*L**T of the original
* matrix A.
*
* If FACT = 'E', then AF is an output argument and on exit
* returns the triangular factor U or L from the Cholesky
* factorization A = U**T*U or A = L*L**T of the equilibrated
* matrix A (see the description of A for the form of the
* equilibrated matrix).
*
* LDAF (input) INTEGER
* The leading dimension of the array AF. LDAF >= max(1,N).
*
* EQUED (input or output) CHARACTER*1
* Specifies the form of equilibration that was done.
* = 'N': No equilibration (always true if FACT = 'N').
* = 'Y': Equilibration was done, i.e., A has been replaced by
* diag(S) * A * diag(S).
* EQUED is an input argument if FACT = 'F'; otherwise, it is an
* output argument.
*
* S (input or output) DOUBLE PRECISION array, dimension (N)
* The scale factors for A; not accessed if EQUED = 'N'. S is
* an input argument if FACT = 'F'; otherwise, S is an output
* argument. If FACT = 'F' and EQUED = 'Y', each element of S
* must be positive.
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the N-by-NRHS right hand side matrix B.
* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
* B is overwritten by diag(S) * B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
* the original system of equations. Note that if EQUED = 'Y',
* A and B are modified on exit, and the solution to the
* equilibrated system is inv(diag(S))*X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* RCOND (output) DOUBLE PRECISION
* The estimate of the reciprocal condition number of the matrix
* A after equilibration (if done). If RCOND is less than the
* machine precision (in particular, if RCOND = 0), the matrix
* is singular to working precision. This condition is
* indicated by a return code of INFO > 0.
*
* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, and i is
* <= N: the leading minor of order i of A is
* not positive definite, so the factorization
* could not be completed, and the solution has not
* been computed. RCOND = 0 is returned.
* = N+1: U is nonsingular, but RCOND is less than machine
* precision, meaning that the matrix is singular
* to working precision. Nevertheless, the
* solution and error bounds are computed because
* there are a number of situations where the
* computed solution can be more accurate than the
* value of RCOND would suggest.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL EQUIL, NOFACT, RCEQU
INTEGER I, INFEQU, J
DOUBLE PRECISION AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANSY
EXTERNAL LSAME, DLAMCH, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DLACPY, DLAQSY, DPOCON, DPOEQU, DPORFS, DPOTRF,
$ DPOTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
NOFACT = LSAME( FACT, 'N' )
EQUIL = LSAME( FACT, 'E' )
IF( NOFACT .OR. EQUIL ) THEN
EQUED = 'N'
RCEQU = .FALSE.
ELSE
RCEQU = LSAME( EQUED, 'Y' )
SMLNUM = DLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
END IF
*
* Test the input parameters.
*
IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
$ THEN
INFO = -1
ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
$ THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
$ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
INFO = -9
ELSE
IF( RCEQU ) THEN
SMIN = BIGNUM
SMAX = ZERO
DO 10 J = 1, N
SMIN = MIN( SMIN, S( J ) )
SMAX = MAX( SMAX, S( J ) )
10 CONTINUE
IF( SMIN.LE.ZERO ) THEN
INFO = -10
ELSE IF( N.GT.0 ) THEN
SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
ELSE
SCOND = ONE
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -12
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -14
END IF
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPOSVX', -INFO )
RETURN
END IF
*
IF( EQUIL ) THEN
*
* Compute row and column scalings to equilibrate the matrix A.
*
CALL DPOEQU( N, A, LDA, S, SCOND, AMAX, INFEQU )
IF( INFEQU.EQ.0 ) THEN
*
* Equilibrate the matrix.
*
CALL DLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )
RCEQU = LSAME( EQUED, 'Y' )
END IF
END IF
*
* Scale the right hand side.
*
IF( RCEQU ) THEN
DO 30 J = 1, NRHS
DO 20 I = 1, N
B( I, J ) = S( I )*B( I, J )
20 CONTINUE
30 CONTINUE
END IF
*
IF( NOFACT .OR. EQUIL ) THEN
*
* Compute the Cholesky factorization A = U'*U or A = L*L'.
*
CALL DLACPY( UPLO, N, N, A, LDA, AF, LDAF )
CALL DPOTRF( UPLO, N, AF, LDAF, INFO )
*
* Return if INFO is non-zero.
*
IF( INFO.GT.0 )THEN
RCOND = ZERO
RETURN
END IF
END IF
*
* Compute the norm of the matrix A.
*
ANORM = DLANSY( '1', UPLO, N, A, LDA, WORK )
*
* Compute the reciprocal of the condition number of A.
*
CALL DPOCON( UPLO, N, AF, LDAF, ANORM, RCOND, WORK, IWORK, INFO )
*
* Compute the solution matrix X.
*
CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
CALL DPOTRS( UPLO, N, NRHS, AF, LDAF, X, LDX, INFO )
*
* Use iterative refinement to improve the computed solution and
* compute error bounds and backward error estimates for it.
*
CALL DPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX,
$ FERR, BERR, WORK, IWORK, INFO )
*
* Transform the solution matrix X to a solution of the original
* system.
*
IF( RCEQU ) THEN
DO 50 J = 1, NRHS
DO 40 I = 1, N
X( I, J ) = S( I )*X( I, J )
40 CONTINUE
50 CONTINUE
DO 60 J = 1, NRHS
FERR( J ) = FERR( J ) / SCOND
60 CONTINUE
END IF
*
* Set INFO = N+1 if the matrix is singular to working precision.
*
IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
$ INFO = N + 1
*
RETURN
*
* End of DPOSVX
*
END
SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
* ..
*
* Purpose
* =======
*
* DPOTF2 computes the Cholesky factorization of a real symmetric
* positive definite matrix A.
*
* The factorization has the form
* A = U' * U , if UPLO = 'U', or
* A = L * L', if UPLO = 'L',
* where U is an upper triangular matrix and L is lower triangular.
*
* This is the unblocked version of the algorithm, calling Level 2 BLAS.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the symmetric matrix A. If UPLO = 'U', the leading
* n by n upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading n by n lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced.
*
* On exit, if INFO = 0, the factor U or L from the Cholesky
* factorization A = U'*U or A = L*L'.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
* > 0: if INFO = k, the leading minor of order k is not
* positive definite, and the factorization could not be
* completed.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J
DOUBLE PRECISION AJJ
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DDOT
EXTERNAL LSAME, DDOT
* ..
* .. External Subroutines ..
EXTERNAL DGEMV, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPOTF2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Compute the Cholesky factorization A = U'*U.
*
DO 10 J = 1, N
*
* Compute U(J,J) and test for non-positive-definiteness.
*
AJJ = A( J, J ) - DDOT( J-1, A( 1, J ), 1, A( 1, J ), 1 )
IF( AJJ.LE.ZERO ) THEN
A( J, J ) = AJJ
GO TO 30
END IF
AJJ = SQRT( AJJ )
A( J, J ) = AJJ
*
* Compute elements J+1:N of row J.
*
IF( J.LT.N ) THEN
CALL DGEMV( 'Transpose', J-1, N-J, -ONE, A( 1, J+1 ),
$ LDA, A( 1, J ), 1, ONE, A( J, J+1 ), LDA )
CALL DSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA )
END IF
10 CONTINUE
ELSE
*
* Compute the Cholesky factorization A = L*L'.
*
DO 20 J = 1, N
*
* Compute L(J,J) and test for non-positive-definiteness.
*
AJJ = A( J, J ) - DDOT( J-1, A( J, 1 ), LDA, A( J, 1 ),
$ LDA )
IF( AJJ.LE.ZERO ) THEN
A( J, J ) = AJJ
GO TO 30
END IF
AJJ = SQRT( AJJ )
A( J, J ) = AJJ
*
* Compute elements J+1:N of column J.
*
IF( J.LT.N ) THEN
CALL DGEMV( 'No transpose', N-J, J-1, -ONE, A( J+1, 1 ),
$ LDA, A( J, 1 ), LDA, ONE, A( J+1, J ), 1 )
CALL DSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 )
END IF
20 CONTINUE
END IF
GO TO 40
*
30 CONTINUE
INFO = J
*
40 CONTINUE
RETURN
*
* End of DPOTF2
*
END
SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
* ..
*
* Purpose
* =======
*
* DPOTRF computes the Cholesky factorization of a real symmetric
* positive definite matrix A.
*
* The factorization has the form
* A = U**T * U, if UPLO = 'U', or
* A = L * L**T, if UPLO = 'L',
* where U is an upper triangular matrix and L is lower triangular.
*
* This is the block version of the algorithm, calling Level 3 BLAS.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the symmetric matrix A. If UPLO = 'U', the leading
* N-by-N upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading N-by-N lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced.
*
* On exit, if INFO = 0, the factor U or L from the Cholesky
* factorization A = U**T*U or A = L*L**T.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, the leading minor of order i is not
* positive definite, and the factorization could not be
* completed.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, JB, NB
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DPOTF2, DSYRK, DTRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPOTRF', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Determine the block size for this environment.
*
NB = ILAENV( 1, 'DPOTRF', UPLO, N, -1, -1, -1 )
IF( NB.LE.1 .OR. NB.GE.N ) THEN
*
* Use unblocked code.
*
CALL DPOTF2( UPLO, N, A, LDA, INFO )
ELSE
*
* Use blocked code.
*
IF( UPPER ) THEN
*
* Compute the Cholesky factorization A = U'*U.
*
DO 10 J = 1, N, NB
*
* Update and factorize the current diagonal block and test
* for non-positive-definiteness.
*
JB = MIN( NB, N-J+1 )
CALL DSYRK( 'Upper', 'Transpose', JB, J-1, -ONE,
$ A( 1, J ), LDA, ONE, A( J, J ), LDA )
CALL DPOTF2( 'Upper', JB, A( J, J ), LDA, INFO )
IF( INFO.NE.0 )
$ GO TO 30
IF( J+JB.LE.N ) THEN
*
* Compute the current block row.
*
CALL DGEMM( 'Transpose', 'No transpose', JB, N-J-JB+1,
$ J-1, -ONE, A( 1, J ), LDA, A( 1, J+JB ),
$ LDA, ONE, A( J, J+JB ), LDA )
CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit',
$ JB, N-J-JB+1, ONE, A( J, J ), LDA,
$ A( J, J+JB ), LDA )
END IF
10 CONTINUE
*
ELSE
*
* Compute the Cholesky factorization A = L*L'.
*
DO 20 J = 1, N, NB
*
* Update and factorize the current diagonal block and test
* for non-positive-definiteness.
*
JB = MIN( NB, N-J+1 )
CALL DSYRK( 'Lower', 'No transpose', JB, J-1, -ONE,
$ A( J, 1 ), LDA, ONE, A( J, J ), LDA )
CALL DPOTF2( 'Lower', JB, A( J, J ), LDA, INFO )
IF( INFO.NE.0 )
$ GO TO 30
IF( J+JB.LE.N ) THEN
*
* Compute the current block column.
*
CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
$ J-1, -ONE, A( J+JB, 1 ), LDA, A( J, 1 ),
$ LDA, ONE, A( J+JB, J ), LDA )
CALL DTRSM( 'Right', 'Lower', 'Transpose', 'Non-unit',
$ N-J-JB+1, JB, ONE, A( J, J ), LDA,
$ A( J+JB, J ), LDA )
END IF
20 CONTINUE
END IF
END IF
GO TO 40
*
30 CONTINUE
INFO = INFO + J - 1
*
40 CONTINUE
RETURN
*
* End of DPOTRF
*
END
SUBROUTINE DPOTRI( UPLO, N, A, LDA, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
* ..
*
* Purpose
* =======
*
* DPOTRI computes the inverse of a real symmetric positive definite
* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
* computed by DPOTRF.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the triangular factor U or L from the Cholesky
* factorization A = U**T*U or A = L*L**T, as computed by
* DPOTRF.
* On exit, the upper or lower triangle of the (symmetric)
* inverse of A, overwriting the input factor U or L.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, the (i,i) element of the factor U or L is
* zero, and the inverse could not be computed.
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DLAUUM, DTRTRI, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPOTRI', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Invert the triangular Cholesky factor U or L.
*
CALL DTRTRI( UPLO, 'Non-unit', N, A, LDA, INFO )
IF( INFO.GT.0 )
$ RETURN
*
* Form inv(U)*inv(U)' or inv(L)'*inv(L).
*
CALL DLAUUM( UPLO, N, A, LDA, INFO )
*
RETURN
*
* End of DPOTRI
*
END
SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* DPOTRS solves a system of linear equations A*X = B with a symmetric
* positive definite matrix A using the Cholesky factorization
* A = U**T*U or A = L*L**T computed by DPOTRF.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* 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 triangular factor U or L from the Cholesky factorization
* A = U**T*U or A = L*L**T, as computed by DPOTRF.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* 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 UPPER
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DTRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) 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 = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPOTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Solve A*X = B where A = U'*U.
*
* Solve U'*X = B, overwriting B with X.
*
CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-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*X = B where A = L*L'.
*
* Solve L*X = B, overwriting B with X.
*
CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', N,
$ NRHS, ONE, A, LDA, B, LDB )
*
* Solve L'*X = B, overwriting B with X.
*
CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Non-unit', N, NRHS,
$ ONE, A, LDA, B, LDB )
END IF
*
RETURN
*
* End of DPOTRS
*
END
SUBROUTINE DPPCON( UPLO, N, AP, ANORM, RCOND, WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, N
DOUBLE PRECISION ANORM, RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION AP( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DPPCON estimates the reciprocal of the condition number (in the
* 1-norm) of a real symmetric positive definite packed matrix using
* the Cholesky factorization A = U**T*U or A = L*L**T computed by
* DPPTRF.
*
* An estimate is obtained for norm(inv(A)), and the reciprocal of the
* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The triangular factor U or L from the Cholesky factorization
* A = U**T*U or A = L*L**T, packed columnwise in a linear
* array. The j-th column of U or L is stored in the array AP
* as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
*
* ANORM (input) DOUBLE PRECISION
* The 1-norm (or infinity-norm) of the symmetric matrix A.
*
* RCOND (output) DOUBLE PRECISION
* The reciprocal of the condition number of the matrix A,
* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
* estimate of the 1-norm of inv(A) computed in this routine.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
CHARACTER NORMIN
INTEGER IX, KASE
DOUBLE PRECISION AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, IDAMAX, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DLACN2, DLATPS, DRSCL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ANORM.LT.ZERO ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPPCON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
RCOND = ZERO
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
ELSE IF( ANORM.EQ.ZERO ) THEN
RETURN
END IF
*
SMLNUM = DLAMCH( 'Safe minimum' )
*
* Estimate the 1-norm of the inverse.
*
KASE = 0
NORMIN = 'N'
10 CONTINUE
CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( UPPER ) THEN
*
* Multiply by inv(U').
*
CALL DLATPS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N,
$ AP, WORK, SCALEL, WORK( 2*N+1 ), INFO )
NORMIN = 'Y'
*
* Multiply by inv(U).
*
CALL DLATPS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
$ AP, WORK, SCALEU, WORK( 2*N+1 ), INFO )
ELSE
*
* Multiply by inv(L).
*
CALL DLATPS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N,
$ AP, WORK, SCALEL, WORK( 2*N+1 ), INFO )
NORMIN = 'Y'
*
* Multiply by inv(L').
*
CALL DLATPS( 'Lower', 'Transpose', 'Non-unit', NORMIN, N,
$ AP, WORK, SCALEU, WORK( 2*N+1 ), INFO )
END IF
*
* Multiply by 1/SCALE if doing so will not cause overflow.
*
SCALE = SCALEL*SCALEU
IF( SCALE.NE.ONE ) THEN
IX = IDAMAX( N, WORK, 1 )
IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
$ GO TO 20
CALL DRSCL( N, SCALE, WORK, 1 )
END IF
GO TO 10
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / AINVNM ) / ANORM
*
20 CONTINUE
RETURN
*
* End of DPPCON
*
END
SUBROUTINE DPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, N
DOUBLE PRECISION AMAX, SCOND
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP( * ), S( * )
* ..
*
* Purpose
* =======
*
* DPPEQU computes row and column scalings intended to equilibrate a
* symmetric positive definite matrix A in packed storage and reduce
* its condition number (with respect to the two-norm). S contains the
* scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix
* B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.
* This choice of S puts the condition number of B within a factor N of
* the smallest possible condition number over all possible diagonal
* scalings.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The upper or lower triangle of the symmetric matrix A, packed
* columnwise in a linear array. The j-th column of A is stored
* in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
*
* S (output) DOUBLE PRECISION array, dimension (N)
* If INFO = 0, S contains the scale factors for A.
*
* SCOND (output) DOUBLE PRECISION
* If INFO = 0, S contains the ratio of the smallest S(i) to
* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
* large nor too small, it is not worth scaling by S.
*
* AMAX (output) DOUBLE PRECISION
* Absolute value of largest matrix element. If AMAX is very
* close to overflow or very close to underflow, the matrix
* should be scaled.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, the i-th diagonal element is nonpositive.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, JJ
DOUBLE PRECISION SMIN
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPPEQU', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
SCOND = ONE
AMAX = ZERO
RETURN
END IF
*
* Initialize SMIN and AMAX.
*
S( 1 ) = AP( 1 )
SMIN = S( 1 )
AMAX = S( 1 )
*
IF( UPPER ) THEN
*
* UPLO = 'U': Upper triangle of A is stored.
* Find the minimum and maximum diagonal elements.
*
JJ = 1
DO 10 I = 2, N
JJ = JJ + I
S( I ) = AP( JJ )
SMIN = MIN( SMIN, S( I ) )
AMAX = MAX( AMAX, S( I ) )
10 CONTINUE
*
ELSE
*
* UPLO = 'L': Lower triangle of A is stored.
* Find the minimum and maximum diagonal elements.
*
JJ = 1
DO 20 I = 2, N
JJ = JJ + N - I + 2
S( I ) = AP( JJ )
SMIN = MIN( SMIN, S( I ) )
AMAX = MAX( AMAX, S( I ) )
20 CONTINUE
END IF
*
IF( SMIN.LE.ZERO ) THEN
*
* Find the first non-positive diagonal element and return.
*
DO 30 I = 1, N
IF( S( I ).LE.ZERO ) THEN
INFO = I
RETURN
END IF
30 CONTINUE
ELSE
*
* Set the scale factors to the reciprocals
* of the diagonal elements.
*
DO 40 I = 1, N
S( I ) = ONE / SQRT( S( I ) )
40 CONTINUE
*
* Compute SCOND = min(S(I)) / max(S(I))
*
SCOND = SQRT( SMIN ) / SQRT( AMAX )
END IF
RETURN
*
* End of DPPEQU
*
END
SUBROUTINE DPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR,
$ BERR, WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ),
$ FERR( * ), WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* DPPRFS improves the computed solution to a system of linear
* equations when the coefficient matrix is symmetric positive definite
* and packed, and provides error bounds and backward error estimates
* for the solution.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* 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 matrices B and X. NRHS >= 0.
*
* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The upper or lower triangle of the symmetric matrix A, packed
* columnwise in a linear array. The j-th column of A is stored
* in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
*
* AFP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The triangular factor U or L from the Cholesky factorization
* A = U**T*U or A = L*L**T, as computed by DPPTRF/ZPPTRF,
* packed columnwise in a linear array in the same format as A
* (see AP).
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
* On entry, the solution matrix X, as computed by DPPTRS.
* On exit, the improved solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Internal Parameters
* ===================
*
* ITMAX is the maximum number of steps of iterative refinement.
*
* =====================================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 5 )
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D+0 )
DOUBLE PRECISION THREE
PARAMETER ( THREE = 3.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER COUNT, I, IK, J, K, KASE, KK, NZ
DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DLACN2, DPPTRS, DSPMV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPPRFS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
DO 10 J = 1, NRHS
FERR( J ) = ZERO
BERR( J ) = ZERO
10 CONTINUE
RETURN
END IF
*
* NZ = maximum number of nonzero elements in each row of A, plus 1
*
NZ = N + 1
EPS = DLAMCH( 'Epsilon' )
SAFMIN = DLAMCH( 'Safe minimum' )
SAFE1 = NZ*SAFMIN
SAFE2 = SAFE1 / EPS
*
* Do for each right hand side
*
DO 140 J = 1, NRHS
*
COUNT = 1
LSTRES = THREE
20 CONTINUE
*
* Loop until stopping criterion is satisfied.
*
* Compute residual R = B - A * X
*
CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
CALL DSPMV( UPLO, N, -ONE, AP, X( 1, J ), 1, ONE, WORK( N+1 ),
$ 1 )
*
* Compute componentwise relative backward error from formula
*
* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
*
* where abs(Z) is the componentwise absolute value of the matrix
* or vector Z. If the i-th component of the denominator is less
* than SAFE2, then SAFE1 is added to the i-th components of the
* numerator and denominator before dividing.
*
DO 30 I = 1, N
WORK( I ) = ABS( B( I, J ) )
30 CONTINUE
*
* Compute abs(A)*abs(X) + abs(B).
*
KK = 1
IF( UPPER ) THEN
DO 50 K = 1, N
S = ZERO
XK = ABS( X( K, J ) )
IK = KK
DO 40 I = 1, K - 1
WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK
S = S + ABS( AP( IK ) )*ABS( X( I, J ) )
IK = IK + 1
40 CONTINUE
WORK( K ) = WORK( K ) + ABS( AP( KK+K-1 ) )*XK + S
KK = KK + K
50 CONTINUE
ELSE
DO 70 K = 1, N
S = ZERO
XK = ABS( X( K, J ) )
WORK( K ) = WORK( K ) + ABS( AP( KK ) )*XK
IK = KK + 1
DO 60 I = K + 1, N
WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK
S = S + ABS( AP( IK ) )*ABS( X( I, J ) )
IK = IK + 1
60 CONTINUE
WORK( K ) = WORK( K ) + S
KK = KK + ( N-K+1 )
70 CONTINUE
END IF
S = ZERO
DO 80 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
ELSE
S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
$ ( WORK( I )+SAFE1 ) )
END IF
80 CONTINUE
BERR( J ) = S
*
* Test stopping criterion. Continue iterating if
* 1) The residual BERR(J) is larger than machine epsilon, and
* 2) BERR(J) decreased by at least a factor of 2 during the
* last iteration, and
* 3) At most ITMAX iterations tried.
*
IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
$ COUNT.LE.ITMAX ) THEN
*
* Update solution and try again.
*
CALL DPPTRS( UPLO, N, 1, AFP, WORK( N+1 ), N, INFO )
CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
LSTRES = BERR( J )
COUNT = COUNT + 1
GO TO 20
END IF
*
* Bound error from formula
*
* norm(X - XTRUE) / norm(X) .le. FERR =
* norm( abs(inv(A))*
* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
*
* where
* norm(Z) is the magnitude of the largest component of Z
* inv(A) is the inverse of A
* abs(Z) is the componentwise absolute value of the matrix or
* vector Z
* NZ is the maximum number of nonzeros in any row of A, plus 1
* EPS is machine epsilon
*
* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
* is incremented by SAFE1 if the i-th component of
* abs(A)*abs(X) + abs(B) is less than SAFE2.
*
* Use DLACN2 to estimate the infinity-norm of the matrix
* inv(A) * diag(W),
* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
*
DO 90 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
ELSE
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
END IF
90 CONTINUE
*
KASE = 0
100 CONTINUE
CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
$ KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Multiply by diag(W)*inv(A').
*
CALL DPPTRS( UPLO, N, 1, AFP, WORK( N+1 ), N, INFO )
DO 110 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
110 CONTINUE
ELSE IF( KASE.EQ.2 ) THEN
*
* Multiply by inv(A)*diag(W).
*
DO 120 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
120 CONTINUE
CALL DPPTRS( UPLO, N, 1, AFP, WORK( N+1 ), N, INFO )
END IF
GO TO 100
END IF
*
* Normalize error.
*
LSTRES = ZERO
DO 130 I = 1, N
LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
130 CONTINUE
IF( LSTRES.NE.ZERO )
$ FERR( J ) = FERR( J ) / LSTRES
*
140 CONTINUE
*
RETURN
*
* End of DPPRFS
*
END
SUBROUTINE DPPSV( UPLO, N, NRHS, AP, B, LDB, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP( * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* DPPSV computes the solution to a real system of linear equations
* A * X = B,
* where A is an N-by-N symmetric positive definite matrix stored in
* packed format and X and B are N-by-NRHS matrices.
*
* The Cholesky decomposition is used to factor A as
* A = U**T* U, if UPLO = 'U', or
* A = L * L**T, if UPLO = 'L',
* where U is an upper triangular matrix and L is a lower triangular
* matrix. The factored form of A is then used to solve the system of
* equations A * X = B.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The number of linear equations, i.e., 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.
*
* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* A, packed columnwise in a linear array. The j-th column of A
* is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
* See below for further details.
*
* On exit, if INFO = 0, the factor U or L from the Cholesky
* factorization A = U**T*U or A = L*L**T, in the same storage
* format as A.
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the N-by-NRHS right hand side matrix B.
* On exit, if INFO = 0, the N-by-NRHS 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
* > 0: if INFO = i, the leading minor of order i of A is not
* positive definite, so the factorization could not be
* completed, and the solution has not been computed.
*
* Further Details
* ===============
*
* The packed storage scheme is illustrated by the following example
* when N = 4, UPLO = 'U':
*
* Two-dimensional storage of the symmetric matrix A:
*
* a11 a12 a13 a14
* a22 a23 a24
* a33 a34 (aij = conjg(aji))
* a44
*
* Packed storage of the upper triangle of A:
*
* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DPPTRF, DPPTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPPSV ', -INFO )
RETURN
END IF
*
* Compute the Cholesky factorization A = U'*U or A = L*L'.
*
CALL DPPTRF( UPLO, N, AP, INFO )
IF( INFO.EQ.0 ) THEN
*
* Solve the system A*X = B, overwriting B with X.
*
CALL DPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )
*
END IF
RETURN
*
* End of DPPSV
*
END
SUBROUTINE DPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB,
$ X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER EQUED, FACT, UPLO
INTEGER INFO, LDB, LDX, N, NRHS
DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ),
$ FERR( * ), S( * ), WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* DPPSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to
* compute the solution to a real system of linear equations
* A * X = B,
* where A is an N-by-N symmetric positive definite matrix stored in
* packed format and X and B are N-by-NRHS matrices.
*
* Error bounds on the solution and a condition estimate are also
* provided.
*
* Description
* ===========
*
* The following steps are performed:
*
* 1. If FACT = 'E', real scaling factors are computed to equilibrate
* the system:
* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
* Whether or not the system will be equilibrated depends on the
* scaling of the matrix A, but if equilibration is used, A is
* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
*
* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
* factor the matrix A (after equilibration if FACT = 'E') as
* A = U**T* U, if UPLO = 'U', or
* A = L * L**T, if UPLO = 'L',
* where U is an upper triangular matrix and L is a lower triangular
* matrix.
*
* 3. If the leading i-by-i principal minor is not positive definite,
* then the routine returns with INFO = i. Otherwise, the factored
* form of A is used to estimate the condition number of the matrix
* A. If the reciprocal of the condition number is less than machine
* precision, INFO = N+1 is returned as a warning, but the routine
* still goes on to solve for X and compute error bounds as
* described below.
*
* 4. The system of equations is solved for X using the factored form
* of A.
*
* 5. Iterative refinement is applied to improve the computed solution
* matrix and calculate error bounds and backward error estimates
* for it.
*
* 6. If equilibration was used, the matrix X is premultiplied by
* diag(S) so that it solves the original system before
* equilibration.
*
* Arguments
* =========
*
* FACT (input) CHARACTER*1
* Specifies whether or not the factored form of the matrix A is
* supplied on entry, and if not, whether the matrix A should be
* equilibrated before it is factored.
* = 'F': On entry, AFP contains the factored form of A.
* If EQUED = 'Y', the matrix A has been equilibrated
* with scaling factors given by S. AP and AFP will not
* be modified.
* = 'N': The matrix A will be copied to AFP and factored.
* = 'E': The matrix A will be equilibrated if necessary, then
* copied to AFP and factored.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The number of linear equations, i.e., 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 matrices B and X. NRHS >= 0.
*
* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* A, packed columnwise in a linear array, except if FACT = 'F'
* and EQUED = 'Y', then A must contain the equilibrated matrix
* diag(S)*A*diag(S). The j-th column of A is stored in the
* array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
* See below for further details. A is not modified if
* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
*
* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
* diag(S)*A*diag(S).
*
* AFP (input or output) DOUBLE PRECISION array, dimension
* (N*(N+1)/2)
* If FACT = 'F', then AFP is an input argument and on entry
* contains the triangular factor U or L from the Cholesky
* factorization A = U'*U or A = L*L', in the same storage
* format as A. If EQUED .ne. 'N', then AFP is the factored
* form of the equilibrated matrix A.
*
* If FACT = 'N', then AFP is an output argument and on exit
* returns the triangular factor U or L from the Cholesky
* factorization A = U'*U or A = L*L' of the original matrix A.
*
* If FACT = 'E', then AFP is an output argument and on exit
* returns the triangular factor U or L from the Cholesky
* factorization A = U'*U or A = L*L' of the equilibrated
* matrix A (see the description of AP for the form of the
* equilibrated matrix).
*
* EQUED (input or output) CHARACTER*1
* Specifies the form of equilibration that was done.
* = 'N': No equilibration (always true if FACT = 'N').
* = 'Y': Equilibration was done, i.e., A has been replaced by
* diag(S) * A * diag(S).
* EQUED is an input argument if FACT = 'F'; otherwise, it is an
* output argument.
*
* S (input or output) DOUBLE PRECISION array, dimension (N)
* The scale factors for A; not accessed if EQUED = 'N'. S is
* an input argument if FACT = 'F'; otherwise, S is an output
* argument. If FACT = 'F' and EQUED = 'Y', each element of S
* must be positive.
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the N-by-NRHS right hand side matrix B.
* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
* B is overwritten by diag(S) * B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
* the original system of equations. Note that if EQUED = 'Y',
* A and B are modified on exit, and the solution to the
* equilibrated system is inv(diag(S))*X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* RCOND (output) DOUBLE PRECISION
* The estimate of the reciprocal condition number of the matrix
* A after equilibration (if done). If RCOND is less than the
* machine precision (in particular, if RCOND = 0), the matrix
* is singular to working precision. This condition is
* indicated by a return code of INFO > 0.
*
* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, and i is
* <= N: the leading minor of order i of A is
* not positive definite, so the factorization
* could not be completed, and the solution has not
* been computed. RCOND = 0 is returned.
* = N+1: U is nonsingular, but RCOND is less than machine
* precision, meaning that the matrix is singular
* to working precision. Nevertheless, the
* solution and error bounds are computed because
* there are a number of situations where the
* computed solution can be more accurate than the
* value of RCOND would suggest.
*
* Further Details
* ===============
*
* The packed storage scheme is illustrated by the following example
* when N = 4, UPLO = 'U':
*
* Two-dimensional storage of the symmetric matrix A:
*
* a11 a12 a13 a14
* a22 a23 a24
* a33 a34 (aij = conjg(aji))
* a44
*
* Packed storage of the upper triangle of A:
*
* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL EQUIL, NOFACT, RCEQU
INTEGER I, INFEQU, J
DOUBLE PRECISION AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANSP
EXTERNAL LSAME, DLAMCH, DLANSP
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLACPY, DLAQSP, DPPCON, DPPEQU, DPPRFS,
$ DPPTRF, DPPTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
NOFACT = LSAME( FACT, 'N' )
EQUIL = LSAME( FACT, 'E' )
IF( NOFACT .OR. EQUIL ) THEN
EQUED = 'N'
RCEQU = .FALSE.
ELSE
RCEQU = LSAME( EQUED, 'Y' )
SMLNUM = DLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
END IF
*
* Test the input parameters.
*
IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
$ THEN
INFO = -1
ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
$ THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.0 ) THEN
INFO = -4
ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
$ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
INFO = -7
ELSE
IF( RCEQU ) THEN
SMIN = BIGNUM
SMAX = ZERO
DO 10 J = 1, N
SMIN = MIN( SMIN, S( J ) )
SMAX = MAX( SMAX, S( J ) )
10 CONTINUE
IF( SMIN.LE.ZERO ) THEN
INFO = -8
ELSE IF( N.GT.0 ) THEN
SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
ELSE
SCOND = ONE
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -10
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -12
END IF
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPPSVX', -INFO )
RETURN
END IF
*
IF( EQUIL ) THEN
*
* Compute row and column scalings to equilibrate the matrix A.
*
CALL DPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFEQU )
IF( INFEQU.EQ.0 ) THEN
*
* Equilibrate the matrix.
*
CALL DLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )
RCEQU = LSAME( EQUED, 'Y' )
END IF
END IF
*
* Scale the right-hand side.
*
IF( RCEQU ) THEN
DO 30 J = 1, NRHS
DO 20 I = 1, N
B( I, J ) = S( I )*B( I, J )
20 CONTINUE
30 CONTINUE
END IF
*
IF( NOFACT .OR. EQUIL ) THEN
*
* Compute the Cholesky factorization A = U'*U or A = L*L'.
*
CALL DCOPY( N*( N+1 ) / 2, AP, 1, AFP, 1 )
CALL DPPTRF( UPLO, N, AFP, INFO )
*
* Return if INFO is non-zero.
*
IF( INFO.GT.0 )THEN
RCOND = ZERO
RETURN
END IF
END IF
*
* Compute the norm of the matrix A.
*
ANORM = DLANSP( 'I', UPLO, N, AP, WORK )
*
* Compute the reciprocal of the condition number of A.
*
CALL DPPCON( UPLO, N, AFP, ANORM, RCOND, WORK, IWORK, INFO )
*
* Compute the solution matrix X.
*
CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
CALL DPPTRS( UPLO, N, NRHS, AFP, X, LDX, INFO )
*
* Use iterative refinement to improve the computed solution and
* compute error bounds and backward error estimates for it.
*
CALL DPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR,
$ WORK, IWORK, INFO )
*
* Transform the solution matrix X to a solution of the original
* system.
*
IF( RCEQU ) THEN
DO 50 J = 1, NRHS
DO 40 I = 1, N
X( I, J ) = S( I )*X( I, J )
40 CONTINUE
50 CONTINUE
DO 60 J = 1, NRHS
FERR( J ) = FERR( J ) / SCOND
60 CONTINUE
END IF
*
* Set INFO = N+1 if the matrix is singular to working precision.
*
IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
$ INFO = N + 1
*
RETURN
*
* End of DPPSVX
*
END
SUBROUTINE DPPTRF( UPLO, N, AP, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP( * )
* ..
*
* Purpose
* =======
*
* DPPTRF computes the Cholesky factorization of a real symmetric
* positive definite matrix A stored in packed format.
*
* The factorization has the form
* A = U**T * U, if UPLO = 'U', or
* A = L * L**T, if UPLO = 'L',
* where U is an upper triangular matrix and L is lower triangular.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* A, packed columnwise in a linear array. The j-th column of A
* is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
* See below for further details.
*
* On exit, if INFO = 0, the triangular factor U or L from the
* Cholesky factorization A = U**T*U or A = L*L**T, in the same
* storage format as A.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, the leading minor of order i is not
* positive definite, and the factorization could not be
* completed.
*
* Further Details
* ======= =======
*
* The packed storage scheme is illustrated by the following example
* when N = 4, UPLO = 'U':
*
* Two-dimensional storage of the symmetric matrix A:
*
* a11 a12 a13 a14
* a22 a23 a24
* a33 a34 (aij = aji)
* a44
*
* Packed storage of the upper triangle of A:
*
* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, JC, JJ
DOUBLE PRECISION AJJ
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DDOT
EXTERNAL LSAME, DDOT
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, DSPR, DTPSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPPTRF', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Compute the Cholesky factorization A = U'*U.
*
JJ = 0
DO 10 J = 1, N
JC = JJ + 1
JJ = JJ + J
*
* Compute elements 1:J-1 of column J.
*
IF( J.GT.1 )
$ CALL DTPSV( 'Upper', 'Transpose', 'Non-unit', J-1, AP,
$ AP( JC ), 1 )
*
* Compute U(J,J) and test for non-positive-definiteness.
*
AJJ = AP( JJ ) - DDOT( J-1, AP( JC ), 1, AP( JC ), 1 )
IF( AJJ.LE.ZERO ) THEN
AP( JJ ) = AJJ
GO TO 30
END IF
AP( JJ ) = SQRT( AJJ )
10 CONTINUE
ELSE
*
* Compute the Cholesky factorization A = L*L'.
*
JJ = 1
DO 20 J = 1, N
*
* Compute L(J,J) and test for non-positive-definiteness.
*
AJJ = AP( JJ )
IF( AJJ.LE.ZERO ) THEN
AP( JJ ) = AJJ
GO TO 30
END IF
AJJ = SQRT( AJJ )
AP( JJ ) = AJJ
*
* Compute elements J+1:N of column J and update the trailing
* submatrix.
*
IF( J.LT.N ) THEN
CALL DSCAL( N-J, ONE / AJJ, AP( JJ+1 ), 1 )
CALL DSPR( 'Lower', N-J, -ONE, AP( JJ+1 ), 1,
$ AP( JJ+N-J+1 ) )
JJ = JJ + N - J + 1
END IF
20 CONTINUE
END IF
GO TO 40
*
30 CONTINUE
INFO = J
*
40 CONTINUE
RETURN
*
* End of DPPTRF
*
END
SUBROUTINE DPPTRI( UPLO, N, AP, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP( * )
* ..
*
* Purpose
* =======
*
* DPPTRI computes the inverse of a real symmetric positive definite
* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
* computed by DPPTRF.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangular factor is stored in AP;
* = 'L': Lower triangular factor is stored in AP.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* On entry, the triangular factor U or L from the Cholesky
* factorization A = U**T*U or A = L*L**T, packed columnwise as
* a linear array. The j-th column of U or L is stored in the
* array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
*
* On exit, the upper or lower triangle of the (symmetric)
* inverse of A, overwriting the input factor U or L.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, the (i,i) element of the factor U or L is
* zero, and the inverse could not be computed.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, JC, JJ, JJN
DOUBLE PRECISION AJJ
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DDOT
EXTERNAL LSAME, DDOT
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, DSPR, DTPMV, DTPTRI, XERBLA
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPPTRI', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Invert the triangular Cholesky factor U or L.
*
CALL DTPTRI( UPLO, 'Non-unit', N, AP, INFO )
IF( INFO.GT.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Compute the product inv(U) * inv(U)'.
*
JJ = 0
DO 10 J = 1, N
JC = JJ + 1
JJ = JJ + J
IF( J.GT.1 )
$ CALL DSPR( 'Upper', J-1, ONE, AP( JC ), 1, AP )
AJJ = AP( JJ )
CALL DSCAL( J, AJJ, AP( JC ), 1 )
10 CONTINUE
*
ELSE
*
* Compute the product inv(L)' * inv(L).
*
JJ = 1
DO 20 J = 1, N
JJN = JJ + N - J + 1
AP( JJ ) = DDOT( N-J+1, AP( JJ ), 1, AP( JJ ), 1 )
IF( J.LT.N )
$ CALL DTPMV( 'Lower', 'Transpose', 'Non-unit', N-J,
$ AP( JJN ), AP( JJ+1 ), 1 )
JJ = JJN
20 CONTINUE
END IF
*
RETURN
*
* End of DPPTRI
*
END
SUBROUTINE DPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP( * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* DPPTRS solves a system of linear equations A*X = B with a symmetric
* positive definite matrix A in packed storage using the Cholesky
* factorization A = U**T*U or A = L*L**T computed by DPPTRF.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* 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.
*
* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The triangular factor U or L from the Cholesky factorization
* A = U**T*U or A = L*L**T, packed columnwise in a linear
* array. The j-th column of U or L is stored in the array AP
* as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
*
* 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
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DTPSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPPTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Solve A*X = B where A = U'*U.
*
DO 10 I = 1, NRHS
*
* Solve U'*X = B, overwriting B with X.
*
CALL DTPSV( 'Upper', 'Transpose', 'Non-unit', N, AP,
$ B( 1, I ), 1 )
*
* Solve U*X = B, overwriting B with X.
*
CALL DTPSV( 'Upper', 'No transpose', 'Non-unit', N, AP,
$ B( 1, I ), 1 )
10 CONTINUE
ELSE
*
* Solve A*X = B where A = L*L'.
*
DO 20 I = 1, NRHS
*
* Solve L*Y = B, overwriting B with X.
*
CALL DTPSV( 'Lower', 'No transpose', 'Non-unit', N, AP,
$ B( 1, I ), 1 )
*
* Solve L'*X = Y, overwriting B with X.
*
CALL DTPSV( 'Lower', 'Transpose', 'Non-unit', N, AP,
$ B( 1, I ), 1 )
20 CONTINUE
END IF
*
RETURN
*
* End of DPPTRS
*
END
SUBROUTINE DPTCON( N, D, E, ANORM, RCOND, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, N
DOUBLE PRECISION ANORM, RCOND
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DPTCON computes the reciprocal of the condition number (in the
* 1-norm) of a real symmetric positive definite tridiagonal matrix
* using the factorization A = L*D*L**T or A = U**T*D*U computed by
* DPTTRF.
*
* Norm(inv(A)) is computed by a direct method, and the reciprocal of
* the condition number is computed as
* RCOND = 1 / (ANORM * norm(inv(A))).
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the diagonal matrix D from the
* factorization of A, as computed by DPTTRF.
*
* E (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) off-diagonal elements of the unit bidiagonal factor
* U or L from the factorization of A, as computed by DPTTRF.
*
* ANORM (input) DOUBLE PRECISION
* The 1-norm of the original matrix A.
*
* RCOND (output) DOUBLE PRECISION
* The reciprocal of the condition number of the matrix A,
* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the
* 1-norm of inv(A) computed in this routine.
*
* 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 method used is described in Nicholas J. Higham, "Efficient
* Algorithms for Computing the Condition Number of a Tridiagonal
* Matrix", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, IX
DOUBLE PRECISION AINVNM
* ..
* .. External Functions ..
INTEGER IDAMAX
EXTERNAL IDAMAX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
* Test the input arguments.
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( ANORM.LT.ZERO ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPTCON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
RCOND = ZERO
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
ELSE IF( ANORM.EQ.ZERO ) THEN
RETURN
END IF
*
* Check that D(1:N) is positive.
*
DO 10 I = 1, N
IF( D( I ).LE.ZERO )
$ RETURN
10 CONTINUE
*
* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by
*
* m(i,j) = abs(A(i,j)), i = j,
* m(i,j) = -abs(A(i,j)), i .ne. j,
*
* and e = [ 1, 1, ..., 1 ]'. Note M(A) = M(L)*D*M(L)'.
*
* Solve M(L) * x = e.
*
WORK( 1 ) = ONE
DO 20 I = 2, N
WORK( I ) = ONE + WORK( I-1 )*ABS( E( I-1 ) )
20 CONTINUE
*
* Solve D * M(L)' * x = b.
*
WORK( N ) = WORK( N ) / D( N )
DO 30 I = N - 1, 1, -1
WORK( I ) = WORK( I ) / D( I ) + WORK( I+1 )*ABS( E( I ) )
30 CONTINUE
*
* Compute AINVNM = max(x(i)), 1<=i<=n.
*
IX = IDAMAX( N, WORK, 1 )
AINVNM = ABS( WORK( IX ) )
*
* Compute the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / AINVNM ) / ANORM
*
RETURN
*
* End of DPTCON
*
END
SUBROUTINE DPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER COMPZ
INTEGER INFO, LDZ, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DPTEQR computes all eigenvalues and, optionally, eigenvectors of a
* symmetric positive definite tridiagonal matrix by first factoring the
* matrix using DPTTRF, and then calling DBDSQR to compute the singular
* values of the bidiagonal factor.
*
* This routine computes the eigenvalues of the positive definite
* tridiagonal matrix to high relative accuracy. This means that if the
* eigenvalues range over many orders of magnitude in size, then the
* small eigenvalues and corresponding eigenvectors will be computed
* more accurately than, for example, with the standard QR method.
*
* The eigenvectors of a full or band symmetric positive definite matrix
* can also be found if DSYTRD, DSPTRD, or DSBTRD has been used to
* reduce this matrix to tridiagonal form. (The reduction to tridiagonal
* form, however, may preclude the possibility of obtaining high
* relative accuracy in the small eigenvalues of the original matrix, if
* these eigenvalues range over many orders of magnitude.)
*
* Arguments
* =========
*
* COMPZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only.
* = 'V': Compute eigenvectors of original symmetric
* matrix also. Array Z contains the orthogonal
* matrix used to reduce the original matrix to
* tridiagonal form.
* = 'I': Compute eigenvectors of tridiagonal matrix also.
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the n diagonal elements of the tridiagonal
* matrix.
* On normal exit, D contains the eigenvalues, in descending
* order.
*
* E (input/output) DOUBLE PRECISION array, dimension (N-1)
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix.
* On exit, E has been destroyed.
*
* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
* On entry, if COMPZ = 'V', the orthogonal matrix used in the
* reduction to tridiagonal form.
* On exit, if COMPZ = 'V', the orthonormal eigenvectors of the
* original symmetric matrix;
* if COMPZ = 'I', the orthonormal eigenvectors of the
* tridiagonal matrix.
* If INFO > 0 on exit, Z contains the eigenvectors associated
* with only the stored eigenvalues.
* If COMPZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* COMPZ = 'V' or 'I', LDZ >= max(1,N).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = i, and i is:
* <= N the Cholesky factorization of the matrix could
* not be performed because the i-th principal minor
* was not positive definite.
* > N the SVD algorithm failed to converge;
* if INFO = N+i, i off-diagonal elements of the
* bidiagonal factor did not converge to zero.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DBDSQR, DLASET, DPTTRF, XERBLA
* ..
* .. Local Arrays ..
DOUBLE PRECISION C( 1, 1 ), VT( 1, 1 )
* ..
* .. Local Scalars ..
INTEGER I, ICOMPZ, NRU
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( LSAME( COMPZ, 'N' ) ) THEN
ICOMPZ = 0
ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
ICOMPZ = 1
ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
ICOMPZ = 2
ELSE
ICOMPZ = -1
END IF
IF( ICOMPZ.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
$ N ) ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPTEQR', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( ICOMPZ.GT.0 )
$ Z( 1, 1 ) = ONE
RETURN
END IF
IF( ICOMPZ.EQ.2 )
$ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
*
* Call DPTTRF to factor the matrix.
*
CALL DPTTRF( N, D, E, INFO )
IF( INFO.NE.0 )
$ RETURN
DO 10 I = 1, N
D( I ) = SQRT( D( I ) )
10 CONTINUE
DO 20 I = 1, N - 1
E( I ) = E( I )*D( I )
20 CONTINUE
*
* Call DBDSQR to compute the singular values/vectors of the
* bidiagonal factor.
*
IF( ICOMPZ.GT.0 ) THEN
NRU = N
ELSE
NRU = 0
END IF
CALL DBDSQR( 'Lower', N, 0, NRU, 0, D, E, VT, 1, Z, LDZ, C, 1,
$ WORK, INFO )
*
* Square the singular values.
*
IF( INFO.EQ.0 ) THEN
DO 30 I = 1, N
D( I ) = D( I )*D( I )
30 CONTINUE
ELSE
INFO = N + INFO
END IF
*
RETURN
*
* End of DPTEQR
*
END
SUBROUTINE DPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR,
$ BERR, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DF( * ),
$ E( * ), EF( * ), FERR( * ), WORK( * ),
$ X( LDX, * )
* ..
*
* Purpose
* =======
*
* DPTRFS improves the computed solution to a system of linear
* equations when the coefficient matrix is symmetric positive definite
* and tridiagonal, and provides error bounds and backward error
* estimates for the solution.
*
* Arguments
* =========
*
* 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.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the tridiagonal matrix A.
*
* E (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) subdiagonal elements of the tridiagonal matrix A.
*
* DF (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the diagonal matrix D from the
* factorization computed by DPTTRF.
*
* EF (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) subdiagonal elements of the unit bidiagonal factor
* L from the factorization computed by DPTTRF.
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
* On entry, the solution matrix X, as computed by DPTTRS.
* On exit, the improved solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j).
*
* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Internal Parameters
* ===================
*
* ITMAX is the maximum number of steps of iterative refinement.
*
* =====================================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 5 )
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D+0 )
DOUBLE PRECISION THREE
PARAMETER ( THREE = 3.0D+0 )
* ..
* .. Local Scalars ..
INTEGER COUNT, I, IX, J, NZ
DOUBLE PRECISION BI, CX, DX, EPS, EX, LSTRES, S, SAFE1, SAFE2,
$ SAFMIN
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DPTTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL IDAMAX, DLAMCH
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( NRHS.LT.0 ) THEN
INFO = -2
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPTRFS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
DO 10 J = 1, NRHS
FERR( J ) = ZERO
BERR( J ) = ZERO
10 CONTINUE
RETURN
END IF
*
* NZ = maximum number of nonzero elements in each row of A, plus 1
*
NZ = 4
EPS = DLAMCH( 'Epsilon' )
SAFMIN = DLAMCH( 'Safe minimum' )
SAFE1 = NZ*SAFMIN
SAFE2 = SAFE1 / EPS
*
* Do for each right hand side
*
DO 90 J = 1, NRHS
*
COUNT = 1
LSTRES = THREE
20 CONTINUE
*
* Loop until stopping criterion is satisfied.
*
* Compute residual R = B - A * X. Also compute
* abs(A)*abs(x) + abs(b) for use in the backward error bound.
*
IF( N.EQ.1 ) THEN
BI = B( 1, J )
DX = D( 1 )*X( 1, J )
WORK( N+1 ) = BI - DX
WORK( 1 ) = ABS( BI ) + ABS( DX )
ELSE
BI = B( 1, J )
DX = D( 1 )*X( 1, J )
EX = E( 1 )*X( 2, J )
WORK( N+1 ) = BI - DX - EX
WORK( 1 ) = ABS( BI ) + ABS( DX ) + ABS( EX )
DO 30 I = 2, N - 1
BI = B( I, J )
CX = E( I-1 )*X( I-1, J )
DX = D( I )*X( I, J )
EX = E( I )*X( I+1, J )
WORK( N+I ) = BI - CX - DX - EX
WORK( I ) = ABS( BI ) + ABS( CX ) + ABS( DX ) + ABS( EX )
30 CONTINUE
BI = B( N, J )
CX = E( N-1 )*X( N-1, J )
DX = D( N )*X( N, J )
WORK( N+N ) = BI - CX - DX
WORK( N ) = ABS( BI ) + ABS( CX ) + ABS( DX )
END IF
*
* Compute componentwise relative backward error from formula
*
* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
*
* where abs(Z) is the componentwise absolute value of the matrix
* or vector Z. If the i-th component of the denominator is less
* than SAFE2, then SAFE1 is added to the i-th components of the
* numerator and denominator before dividing.
*
S = ZERO
DO 40 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
ELSE
S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
$ ( WORK( I )+SAFE1 ) )
END IF
40 CONTINUE
BERR( J ) = S
*
* Test stopping criterion. Continue iterating if
* 1) The residual BERR(J) is larger than machine epsilon, and
* 2) BERR(J) decreased by at least a factor of 2 during the
* last iteration, and
* 3) At most ITMAX iterations tried.
*
IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
$ COUNT.LE.ITMAX ) THEN
*
* Update solution and try again.
*
CALL DPTTRS( N, 1, DF, EF, WORK( N+1 ), N, INFO )
CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
LSTRES = BERR( J )
COUNT = COUNT + 1
GO TO 20
END IF
*
* Bound error from formula
*
* norm(X - XTRUE) / norm(X) .le. FERR =
* norm( abs(inv(A))*
* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
*
* where
* norm(Z) is the magnitude of the largest component of Z
* inv(A) is the inverse of A
* abs(Z) is the componentwise absolute value of the matrix or
* vector Z
* NZ is the maximum number of nonzeros in any row of A, plus 1
* EPS is machine epsilon
*
* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
* is incremented by SAFE1 if the i-th component of
* abs(A)*abs(X) + abs(B) is less than SAFE2.
*
DO 50 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
ELSE
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
END IF
50 CONTINUE
IX = IDAMAX( N, WORK, 1 )
FERR( J ) = WORK( IX )
*
* Estimate the norm of inv(A).
*
* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by
*
* m(i,j) = abs(A(i,j)), i = j,
* m(i,j) = -abs(A(i,j)), i .ne. j,
*
* and e = [ 1, 1, ..., 1 ]'. Note M(A) = M(L)*D*M(L)'.
*
* Solve M(L) * x = e.
*
WORK( 1 ) = ONE
DO 60 I = 2, N
WORK( I ) = ONE + WORK( I-1 )*ABS( EF( I-1 ) )
60 CONTINUE
*
* Solve D * M(L)' * x = b.
*
WORK( N ) = WORK( N ) / DF( N )
DO 70 I = N - 1, 1, -1
WORK( I ) = WORK( I ) / DF( I ) + WORK( I+1 )*ABS( EF( I ) )
70 CONTINUE
*
* Compute norm(inv(A)) = max(x(i)), 1<=i<=n.
*
IX = IDAMAX( N, WORK, 1 )
FERR( J ) = FERR( J )*ABS( WORK( IX ) )
*
* Normalize error.
*
LSTRES = ZERO
DO 80 I = 1, N
LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
80 CONTINUE
IF( LSTRES.NE.ZERO )
$ FERR( J ) = FERR( J ) / LSTRES
*
90 CONTINUE
*
RETURN
*
* End of DPTRFS
*
END
SUBROUTINE DPTSV( N, NRHS, D, E, B, LDB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION B( LDB, * ), D( * ), E( * )
* ..
*
* Purpose
* =======
*
* DPTSV computes the solution to a real system of linear equations
* A*X = B, where A is an N-by-N symmetric positive definite tridiagonal
* matrix, and X and B are N-by-NRHS matrices.
*
* A is factored as A = L*D*L**T, and the factored form of A is then
* used to solve the system of equations.
*
* Arguments
* =========
*
* 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.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the n diagonal elements of the tridiagonal matrix
* A. On exit, the n diagonal elements of the diagonal matrix
* D from the factorization A = L*D*L**T.
*
* E (input/output) DOUBLE PRECISION array, dimension (N-1)
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix A. On exit, the (n-1) subdiagonal elements of the
* unit bidiagonal factor L from the L*D*L**T factorization of
* A. (E can also be regarded as the superdiagonal of the unit
* bidiagonal factor U from the U**T*D*U factorization of A.)
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the N-by-NRHS right hand side matrix B.
* On exit, if INFO = 0, the N-by-NRHS 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
* > 0: if INFO = i, the leading minor of order i is not
* positive definite, and the solution has not been
* computed. The factorization has not been completed
* unless i = N.
*
* =====================================================================
*
* .. External Subroutines ..
EXTERNAL DPTTRF, DPTTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( NRHS.LT.0 ) THEN
INFO = -2
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPTSV ', -INFO )
RETURN
END IF
*
* Compute the L*D*L' (or U'*D*U) factorization of A.
*
CALL DPTTRF( N, D, E, INFO )
IF( INFO.EQ.0 ) THEN
*
* Solve the system A*X = B, overwriting B with X.
*
CALL DPTTRS( N, NRHS, D, E, B, LDB, INFO )
END IF
RETURN
*
* End of DPTSV
*
END
SUBROUTINE DPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX,
$ RCOND, FERR, BERR, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER FACT
INTEGER INFO, LDB, LDX, N, NRHS
DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DF( * ),
$ E( * ), EF( * ), FERR( * ), WORK( * ),
$ X( LDX, * )
* ..
*
* Purpose
* =======
*
* DPTSVX uses the factorization A = L*D*L**T to compute the solution
* to a real system of linear equations A*X = B, where A is an N-by-N
* symmetric positive definite tridiagonal matrix and X and B are
* N-by-NRHS matrices.
*
* Error bounds on the solution and a condition estimate are also
* provided.
*
* Description
* ===========
*
* The following steps are performed:
*
* 1. If FACT = 'N', the matrix A is factored as A = L*D*L**T, where L
* is a unit lower bidiagonal matrix and D is diagonal. The
* factorization can also be regarded as having the form
* A = U**T*D*U.
*
* 2. If the leading i-by-i principal minor is not positive definite,
* then the routine returns with INFO = i. Otherwise, the factored
* form of A is used to estimate the condition number of the matrix
* A. If the reciprocal of the condition number is less than machine
* precision, INFO = N+1 is returned as a warning, but the routine
* still goes on to solve for X and compute error bounds as
* described below.
*
* 3. The system of equations is solved for X using the factored form
* of A.
*
* 4. Iterative refinement is applied to improve the computed solution
* matrix and calculate error bounds and backward error estimates
* for it.
*
* Arguments
* =========
*
* FACT (input) CHARACTER*1
* Specifies whether or not the factored form of A has been
* supplied on entry.
* = 'F': On entry, DF and EF contain the factored form of A.
* D, E, DF, and EF will not be modified.
* = 'N': The matrix A will be copied to DF and EF and
* factored.
*
* 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 matrices B and X. NRHS >= 0.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the tridiagonal matrix A.
*
* E (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) subdiagonal elements of the tridiagonal matrix A.
*
* DF (input or output) DOUBLE PRECISION array, dimension (N)
* If FACT = 'F', then DF is an input argument and on entry
* contains the n diagonal elements of the diagonal matrix D
* from the L*D*L**T factorization of A.
* If FACT = 'N', then DF is an output argument and on exit
* contains the n diagonal elements of the diagonal matrix D
* from the L*D*L**T factorization of A.
*
* EF (input or output) DOUBLE PRECISION array, dimension (N-1)
* If FACT = 'F', then EF is an input argument and on entry
* contains the (n-1) subdiagonal elements of the unit
* bidiagonal factor L from the L*D*L**T factorization of A.
* If FACT = 'N', then EF is an output argument and on exit
* contains the (n-1) subdiagonal elements of the unit
* bidiagonal factor L from the L*D*L**T factorization of A.
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The N-by-NRHS right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
* If INFO = 0 of INFO = N+1, the N-by-NRHS solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* RCOND (output) DOUBLE PRECISION
* The reciprocal condition number of the matrix A. If RCOND
* is less than the machine precision (in particular, if
* RCOND = 0), the matrix is singular to working precision.
* This condition is indicated by a return code of INFO > 0.
*
* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j).
*
* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in any
* element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, and i is
* <= N: the leading minor of order i of A is
* not positive definite, so the factorization
* could not be completed, and the solution has not
* been computed. RCOND = 0 is returned.
* = N+1: U is nonsingular, but RCOND is less than machine
* precision, meaning that the matrix is singular
* to working precision. Nevertheless, the
* solution and error bounds are computed because
* there are a number of situations where the
* computed solution can be more accurate than the
* value of RCOND would suggest.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOFACT
DOUBLE PRECISION ANORM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANST
EXTERNAL LSAME, DLAMCH, DLANST
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLACPY, DPTCON, DPTRFS, DPTTRF, DPTTRS,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
NOFACT = LSAME( FACT, 'N' )
IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -11
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPTSVX', -INFO )
RETURN
END IF
*
IF( NOFACT ) THEN
*
* Compute the L*D*L' (or U'*D*U) factorization of A.
*
CALL DCOPY( N, D, 1, DF, 1 )
IF( N.GT.1 )
$ CALL DCOPY( N-1, E, 1, EF, 1 )
CALL DPTTRF( N, DF, EF, INFO )
*
* Return if INFO is non-zero.
*
IF( INFO.GT.0 )THEN
RCOND = ZERO
RETURN
END IF
END IF
*
* Compute the norm of the matrix A.
*
ANORM = DLANST( '1', N, D, E )
*
* Compute the reciprocal of the condition number of A.
*
CALL DPTCON( N, DF, EF, ANORM, RCOND, WORK, INFO )
*
* Compute the solution vectors X.
*
CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
CALL DPTTRS( N, NRHS, DF, EF, X, LDX, INFO )
*
* Use iterative refinement to improve the computed solutions and
* compute error bounds and backward error estimates for them.
*
CALL DPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR,
$ WORK, INFO )
*
* Set INFO = N+1 if the matrix is singular to working precision.
*
IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
$ INFO = N + 1
*
RETURN
*
* End of DPTSVX
*
END
SUBROUTINE DPTTRF( N, D, E, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * )
* ..
*
* Purpose
* =======
*
* DPTTRF computes the L*D*L' factorization of a real symmetric
* positive definite tridiagonal matrix A. The factorization may also
* be regarded as having the form A = U'*D*U.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the n diagonal elements of the tridiagonal matrix
* A. On exit, the n diagonal elements of the diagonal matrix
* D from the L*D*L' factorization of A.
*
* E (input/output) DOUBLE PRECISION array, dimension (N-1)
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix A. On exit, the (n-1) subdiagonal elements of the
* unit bidiagonal factor L from the L*D*L' factorization of A.
* E can also be regarded as the superdiagonal of the unit
* bidiagonal factor U from the U'*D*U factorization of A.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
* > 0: if INFO = k, the leading minor of order k is not
* positive definite; if k < N, the factorization could not
* be completed, while if k = N, the factorization was
* completed, but D(N) <= 0.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, I4
DOUBLE PRECISION EI
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MOD
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
CALL XERBLA( 'DPTTRF', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Compute the L*D*L' (or U'*D*U) factorization of A.
*
I4 = MOD( N-1, 4 )
DO 10 I = 1, I4
IF( D( I ).LE.ZERO ) THEN
INFO = I
GO TO 30
END IF
EI = E( I )
E( I ) = EI / D( I )
D( I+1 ) = D( I+1 ) - E( I )*EI
10 CONTINUE
*
DO 20 I = I4 + 1, N - 4, 4
*
* Drop out of the loop if d(i) <= 0: the matrix is not positive
* definite.
*
IF( D( I ).LE.ZERO ) THEN
INFO = I
GO TO 30
END IF
*
* Solve for e(i) and d(i+1).
*
EI = E( I )
E( I ) = EI / D( I )
D( I+1 ) = D( I+1 ) - E( I )*EI
*
IF( D( I+1 ).LE.ZERO ) THEN
INFO = I + 1
GO TO 30
END IF
*
* Solve for e(i+1) and d(i+2).
*
EI = E( I+1 )
E( I+1 ) = EI / D( I+1 )
D( I+2 ) = D( I+2 ) - E( I+1 )*EI
*
IF( D( I+2 ).LE.ZERO ) THEN
INFO = I + 2
GO TO 30
END IF
*
* Solve for e(i+2) and d(i+3).
*
EI = E( I+2 )
E( I+2 ) = EI / D( I+2 )
D( I+3 ) = D( I+3 ) - E( I+2 )*EI
*
IF( D( I+3 ).LE.ZERO ) THEN
INFO = I + 3
GO TO 30
END IF
*
* Solve for e(i+3) and d(i+4).
*
EI = E( I+3 )
E( I+3 ) = EI / D( I+3 )
D( I+4 ) = D( I+4 ) - E( I+3 )*EI
20 CONTINUE
*
* Check d(n) for positive definiteness.
*
IF( D( N ).LE.ZERO )
$ INFO = N
*
30 CONTINUE
RETURN
*
* End of DPTTRF
*
END
SUBROUTINE DPTTRS( N, NRHS, D, E, B, LDB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION B( LDB, * ), D( * ), E( * )
* ..
*
* Purpose
* =======
*
* DPTTRS solves a tridiagonal system of the form
* A * X = B
* using the L*D*L' factorization of A computed by DPTTRF. D is a
* diagonal matrix specified in the vector D, L is a unit bidiagonal
* matrix whose subdiagonal is specified in the vector E, and X and B
* are N by NRHS matrices.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the tridiagonal 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.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the diagonal matrix D from the
* L*D*L' factorization of A.
*
* E (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) subdiagonal elements of the unit bidiagonal factor
* L from the L*D*L' factorization of A. E can also be regarded
* as the superdiagonal of the unit bidiagonal factor U from the
* factorization A = U'*D*U.
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the right hand side vectors B for the system of
* linear equations.
* On exit, the solution vectors, X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER J, JB, NB
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DPTTS2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments.
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( NRHS.LT.0 ) THEN
INFO = -2
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPTTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
* Determine the number of right-hand sides to solve at a time.
*
IF( NRHS.EQ.1 ) THEN
NB = 1
ELSE
NB = MAX( 1, ILAENV( 1, 'DPTTRS', ' ', N, NRHS, -1, -1 ) )
END IF
*
IF( NB.GE.NRHS ) THEN
CALL DPTTS2( N, NRHS, D, E, B, LDB )
ELSE
DO 10 J = 1, NRHS, NB
JB = MIN( NRHS-J+1, NB )
CALL DPTTS2( N, JB, D, E, B( 1, J ), LDB )
10 CONTINUE
END IF
*
RETURN
*
* End of DPTTRS
*
END
SUBROUTINE DPTTS2( N, NRHS, D, E, B, LDB )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDB, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION B( LDB, * ), D( * ), E( * )
* ..
*
* Purpose
* =======
*
* DPTTS2 solves a tridiagonal system of the form
* A * X = B
* using the L*D*L' factorization of A computed by DPTTRF. D is a
* diagonal matrix specified in the vector D, L is a unit bidiagonal
* matrix whose subdiagonal is specified in the vector E, and X and B
* are N by NRHS matrices.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the tridiagonal 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.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the diagonal matrix D from the
* L*D*L' factorization of A.
*
* E (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) subdiagonal elements of the unit bidiagonal factor
* L from the L*D*L' factorization of A. E can also be regarded
* as the superdiagonal of the unit bidiagonal factor U from the
* factorization A = U'*D*U.
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the right hand side vectors B for the system of
* linear equations.
* On exit, the solution vectors, X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J
* ..
* .. External Subroutines ..
EXTERNAL DSCAL
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.1 ) THEN
IF( N.EQ.1 )
$ CALL DSCAL( NRHS, 1.D0 / D( 1 ), B, LDB )
RETURN
END IF
*
* Solve A * X = B using the factorization A = L*D*L',
* overwriting each right hand side vector with its solution.
*
DO 30 J = 1, NRHS
*
* Solve L * x = b.
*
DO 10 I = 2, N
B( I, J ) = B( I, J ) - B( I-1, J )*E( I-1 )
10 CONTINUE
*
* Solve D * L' * x = b.
*
B( N, J ) = B( N, J ) / D( N )
DO 20 I = N - 1, 1, -1
B( I, J ) = B( I, J ) / D( I ) - B( I+1, J )*E( I )
20 CONTINUE
30 CONTINUE
*
RETURN
*
* End of DPTTS2
*
END
SUBROUTINE DRSCL( N, SA, SX, INCX )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INCX, N
DOUBLE PRECISION SA
* ..
* .. Array Arguments ..
DOUBLE PRECISION SX( * )
* ..
*
* Purpose
* =======
*
* DRSCL multiplies an n-element real vector x by the real scalar 1/a.
* This is done without overflow or underflow as long as
* the final result x/a does not overflow or underflow.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of components of the vector x.
*
* SA (input) DOUBLE PRECISION
* The scalar a which is used to divide each component of x.
* SA must be >= 0, or the subroutine will divide by zero.
*
* SX (input/output) DOUBLE PRECISION array, dimension
* (1+(N-1)*abs(INCX))
* The n-element vector x.
*
* INCX (input) INTEGER
* The increment between successive values of the vector SX.
* > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL DONE
DOUBLE PRECISION BIGNUM, CDEN, CDEN1, CNUM, CNUM1, MUL, SMLNUM
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
* Get machine parameters
*
SMLNUM = DLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
*
* Initialize the denominator to SA and the numerator to 1.
*
CDEN = SA
CNUM = ONE
*
10 CONTINUE
CDEN1 = CDEN*SMLNUM
CNUM1 = CNUM / BIGNUM
IF( ABS( CDEN1 ).GT.ABS( CNUM ) .AND. CNUM.NE.ZERO ) THEN
*
* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM.
*
MUL = SMLNUM
DONE = .FALSE.
CDEN = CDEN1
ELSE IF( ABS( CNUM1 ).GT.ABS( CDEN ) ) THEN
*
* Pre-multiply X by BIGNUM if CDEN is small compared to CNUM.
*
MUL = BIGNUM
DONE = .FALSE.
CNUM = CNUM1
ELSE
*
* Multiply X by CNUM / CDEN and return.
*
MUL = CNUM / CDEN
DONE = .TRUE.
END IF
*
* Scale the vector X by MUL
*
CALL DSCAL( N, MUL, SX, INCX )
*
IF( .NOT.DONE )
$ GO TO 10
*
RETURN
*
* End of DRSCL
*
END
SUBROUTINE DSBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK,
$ INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, KD, LDAB, LDZ, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DSBEV computes all the eigenvalues and, optionally, eigenvectors of
* a real symmetric band matrix A.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
*
* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)
* On entry, the upper or lower triangle of the symmetric band
* matrix A, stored in the first KD+1 rows of the array. The
* j-th column of A is stored in the j-th column of the array AB
* as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*
* On exit, AB is overwritten by values generated during the
* reduction to tridiagonal form. If UPLO = 'U', the first
* superdiagonal and the diagonal of the tridiagonal matrix T
* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
* the diagonal and first subdiagonal of T are returned in the
* first two rows of AB.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD + 1.
*
* W (output) DOUBLE PRECISION array, dimension (N)
* If INFO = 0, the eigenvalues in ascending order.
*
* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
* eigenvectors of the matrix A, with the i-th column of Z
* holding the eigenvector associated with W(i).
* If JOBZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,3*N-2))
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, the algorithm failed to converge; i
* off-diagonal elements of an intermediate tridiagonal
* form did not converge to zero.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LOWER, WANTZ
INTEGER IINFO, IMAX, INDE, INDWRK, ISCALE
DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
$ SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANSB
EXTERNAL LSAME, DLAMCH, DLANSB
* ..
* .. External Subroutines ..
EXTERNAL DLASCL, DSBTRD, DSCAL, DSTEQR, DSTERF, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
LOWER = LSAME( UPLO, 'L' )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( KD.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -6
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -9
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSBEV ', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( LOWER ) THEN
W( 1 ) = AB( 1, 1 )
ELSE
W( 1 ) = AB( KD+1, 1 )
END IF
IF( WANTZ )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = SQRT( BIGNUM )
*
* Scale matrix to allowable range, if necessary.
*
ANRM = DLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK )
ISCALE = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 ) THEN
IF( LOWER ) THEN
CALL DLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
ELSE
CALL DLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
END IF
END IF
*
* Call DSBTRD to reduce symmetric band matrix to tridiagonal form.
*
INDE = 1
INDWRK = INDE + N
CALL DSBTRD( JOBZ, UPLO, N, KD, AB, LDAB, W, WORK( INDE ), Z, LDZ,
$ WORK( INDWRK ), IINFO )
*
* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEQR.
*
IF( .NOT.WANTZ ) THEN
CALL DSTERF( N, W, WORK( INDE ), INFO )
ELSE
CALL DSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ),
$ INFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = N
ELSE
IMAX = INFO - 1
END IF
CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
RETURN
*
* End of DSBEV
*
END
SUBROUTINE DSBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK,
$ LWORK, IWORK, LIWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, KD, LDAB, LDZ, LIWORK, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DSBEVD computes all the eigenvalues and, optionally, eigenvectors of
* a real symmetric band matrix A. If eigenvectors are desired, it uses
* a divide and conquer algorithm.
*
* The divide and conquer algorithm makes very mild assumptions about
* floating point arithmetic. It will work on machines with a guard
* digit in add/subtract, or on those binary machines without guard
* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
* Cray-2. It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
*
* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)
* On entry, the upper or lower triangle of the symmetric band
* matrix A, stored in the first KD+1 rows of the array. The
* j-th column of A is stored in the j-th column of the array AB
* as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*
* On exit, AB is overwritten by values generated during the
* reduction to tridiagonal form. If UPLO = 'U', the first
* superdiagonal and the diagonal of the tridiagonal matrix T
* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
* the diagonal and first subdiagonal of T are returned in the
* first two rows of AB.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD + 1.
*
* W (output) DOUBLE PRECISION array, dimension (N)
* If INFO = 0, the eigenvalues in ascending order.
*
* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
* eigenvectors of the matrix A, with the i-th column of Z
* holding the eigenvector associated with W(i).
* If JOBZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace/output) DOUBLE PRECISION array,
* dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* IF N <= 1, LWORK must be at least 1.
* If JOBZ = 'N' and N > 2, LWORK must be at least 2*N.
* If JOBZ = 'V' and N > 2, LWORK must be at least
* ( 1 + 5*N + 2*N**2 ).
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal sizes of the WORK and IWORK
* arrays, returns these values as the first entries of the WORK
* and IWORK arrays, and no error message related to LWORK or
* LIWORK is issued by XERBLA.
*
* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array LIWORK.
* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.
* If JOBZ = 'V' and N > 2, LIWORK must be at least 3 + 5*N.
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal sizes of the WORK and
* IWORK arrays, returns these values as the first entries of
* the WORK and IWORK arrays, and no error message related to
* LWORK or LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, the algorithm failed to converge; i
* off-diagonal elements of an intermediate tridiagonal
* form did not converge to zero.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LOWER, LQUERY, WANTZ
INTEGER IINFO, INDE, INDWK2, INDWRK, ISCALE, LIWMIN,
$ LLWRK2, LWMIN
DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
$ SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANSB
EXTERNAL LSAME, DLAMCH, DLANSB
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLACPY, DLASCL, DSBTRD, DSCAL, DSTEDC,
$ DSTERF, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
LOWER = LSAME( UPLO, 'L' )
LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
INFO = 0
IF( N.LE.1 ) THEN
LIWMIN = 1
LWMIN = 1
ELSE
IF( WANTZ ) THEN
LIWMIN = 3 + 5*N
LWMIN = 1 + 5*N + 2*N**2
ELSE
LIWMIN = 1
LWMIN = 2*N
END IF
END IF
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( KD.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -6
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -9
END IF
*
IF( INFO.EQ.0 ) THEN
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -11
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSBEVD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
W( 1 ) = AB( 1, 1 )
IF( WANTZ )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = SQRT( BIGNUM )
*
* Scale matrix to allowable range, if necessary.
*
ANRM = DLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK )
ISCALE = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 ) THEN
IF( LOWER ) THEN
CALL DLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
ELSE
CALL DLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
END IF
END IF
*
* Call DSBTRD to reduce symmetric band matrix to tridiagonal form.
*
INDE = 1
INDWRK = INDE + N
INDWK2 = INDWRK + N*N
LLWRK2 = LWORK - INDWK2 + 1
CALL DSBTRD( JOBZ, UPLO, N, KD, AB, LDAB, W, WORK( INDE ), Z, LDZ,
$ WORK( INDWRK ), IINFO )
*
* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEDC.
*
IF( .NOT.WANTZ ) THEN
CALL DSTERF( N, W, WORK( INDE ), INFO )
ELSE
CALL DSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N,
$ WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO )
CALL DGEMM( 'N', 'N', N, N, N, ONE, Z, LDZ, WORK( INDWRK ), N,
$ ZERO, WORK( INDWK2 ), N )
CALL DLACPY( 'A', N, N, WORK( INDWK2 ), N, Z, LDZ )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( ISCALE.EQ.1 )
$ CALL DSCAL( N, ONE / SIGMA, W, 1 )
*
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
RETURN
*
* End of DSBEVD
*
END
SUBROUTINE DSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL,
$ VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK,
$ IFAIL, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE, UPLO
INTEGER IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N
DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER IFAIL( * ), IWORK( * )
DOUBLE PRECISION AB( LDAB, * ), Q( LDQ, * ), W( * ), WORK( * ),
$ Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DSBEVX computes selected eigenvalues and, optionally, eigenvectors
* of a real symmetric band matrix A. Eigenvalues and eigenvectors can
* be selected by specifying either a range of values or a range of
* indices for the desired eigenvalues.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* RANGE (input) CHARACTER*1
* = 'A': all eigenvalues will be found;
* = 'V': all eigenvalues in the half-open interval (VL,VU]
* will be found;
* = 'I': the IL-th through IU-th eigenvalues will be found.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
*
* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)
* On entry, the upper or lower triangle of the symmetric band
* matrix A, stored in the first KD+1 rows of the array. The
* j-th column of A is stored in the j-th column of the array AB
* as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*
* On exit, AB is overwritten by values generated during the
* reduction to tridiagonal form. If UPLO = 'U', the first
* superdiagonal and the diagonal of the tridiagonal matrix T
* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
* the diagonal and first subdiagonal of T are returned in the
* first two rows of AB.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD + 1.
*
* Q (output) DOUBLE PRECISION array, dimension (LDQ, N)
* If JOBZ = 'V', the N-by-N orthogonal matrix used in the
* reduction to tridiagonal form.
* If JOBZ = 'N', the array Q is not referenced.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. If JOBZ = 'V', then
* LDQ >= max(1,N).
*
* VL (input) DOUBLE PRECISION
* VU (input) DOUBLE PRECISION
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* ABSTOL (input) DOUBLE PRECISION
* The absolute error tolerance for the eigenvalues.
* An approximate eigenvalue is accepted as converged
* when it is determined to lie in an interval [a,b]
* of width less than or equal to
*
* ABSTOL + EPS * max( |a|,|b| ) ,
*
* where EPS is the machine precision. If ABSTOL is less than
* or equal to zero, then EPS*|T| will be used in its place,
* where |T| is the 1-norm of the tridiagonal matrix obtained
* by reducing AB to tridiagonal form.
*
* Eigenvalues will be computed most accurately when ABSTOL is
* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
* If this routine returns with INFO>0, indicating that some
* eigenvectors did not converge, try setting ABSTOL to
* 2*DLAMCH('S').
*
* See "Computing Small Singular Values of Bidiagonal Matrices
* with Guaranteed High Relative Accuracy," by Demmel and
* Kahan, LAPACK Working Note #3.
*
* M (output) INTEGER
* The total number of eigenvalues found. 0 <= M <= N.
* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*
* W (output) DOUBLE PRECISION array, dimension (N)
* The first M elements contain the selected eigenvalues in
* ascending order.
*
* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
* contain the orthonormal eigenvectors of the matrix A
* corresponding to the selected eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* If an eigenvector fails to converge, then that column of Z
* contains the latest approximation to the eigenvector, and the
* index of the eigenvector is returned in IFAIL.
* If JOBZ = 'N', then Z is not referenced.
* Note: the user must ensure that at least max(1,M) columns are
* supplied in the array Z; if RANGE = 'V', the exact value of M
* is not known in advance and an upper bound must be used.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (7*N)
*
* IWORK (workspace) INTEGER array, dimension (5*N)
*
* IFAIL (output) INTEGER array, dimension (N)
* If JOBZ = 'V', then if INFO = 0, the first M elements of
* IFAIL are zero. If INFO > 0, then IFAIL contains the
* indices of the eigenvectors that failed to converge.
* If JOBZ = 'N', then IFAIL is not referenced.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = i, then i eigenvectors failed to converge.
* Their indices are stored in array IFAIL.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, LOWER, TEST, VALEIG, WANTZ
CHARACTER ORDER
INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
$ INDISP, INDIWO, INDWRK, ISCALE, ITMP1, J, JJ,
$ NSPLIT
DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
$ SIGMA, SMLNUM, TMP1, VLL, VUU
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANSB
EXTERNAL LSAME, DLAMCH, DLANSB
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMV, DLACPY, DLASCL, DSBTRD, DSCAL,
$ DSTEBZ, DSTEIN, DSTEQR, DSTERF, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
LOWER = LSAME( UPLO, 'L' )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
INFO = -2
ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( KD.LT.0 ) THEN
INFO = -5
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -7
ELSE IF( WANTZ .AND. LDQ.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE
IF( VALEIG ) THEN
IF( N.GT.0 .AND. VU.LE.VL )
$ INFO = -11
ELSE IF( INDEIG ) THEN
IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
INFO = -12
ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
INFO = -13
END IF
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) )
$ INFO = -18
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSBEVX', -INFO )
RETURN
END IF
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
M = 1
IF( LOWER ) THEN
TMP1 = AB( 1, 1 )
ELSE
TMP1 = AB( KD+1, 1 )
END IF
IF( VALEIG ) THEN
IF( .NOT.( VL.LT.TMP1 .AND. VU.GE.TMP1 ) )
$ M = 0
END IF
IF( M.EQ.1 ) THEN
W( 1 ) = TMP1
IF( WANTZ )
$ Z( 1, 1 ) = ONE
END IF
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
*
* Scale matrix to allowable range, if necessary.
*
ISCALE = 0
ABSTLL = ABSTOL
IF( VALEIG ) THEN
VLL = VL
VUU = VU
ELSE
VLL = ZERO
VUU = ZERO
END IF
ANRM = DLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK )
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 ) THEN
IF( LOWER ) THEN
CALL DLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
ELSE
CALL DLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
END IF
IF( ABSTOL.GT.0 )
$ ABSTLL = ABSTOL*SIGMA
IF( VALEIG ) THEN
VLL = VL*SIGMA
VUU = VU*SIGMA
END IF
END IF
*
* Call DSBTRD to reduce symmetric band matrix to tridiagonal form.
*
INDD = 1
INDE = INDD + N
INDWRK = INDE + N
CALL DSBTRD( JOBZ, UPLO, N, KD, AB, LDAB, WORK( INDD ),
$ WORK( INDE ), Q, LDQ, WORK( INDWRK ), IINFO )
*
* If all eigenvalues are desired and ABSTOL is less than or equal
* to zero, then call DSTERF or SSTEQR. If this fails for some
* eigenvalue, then try DSTEBZ.
*
TEST = .FALSE.
IF (INDEIG) THEN
IF (IL.EQ.1 .AND. IU.EQ.N) THEN
TEST = .TRUE.
END IF
END IF
IF ((ALLEIG .OR. TEST) .AND. (ABSTOL.LE.ZERO)) THEN
CALL DCOPY( N, WORK( INDD ), 1, W, 1 )
INDEE = INDWRK + 2*N
IF( .NOT.WANTZ ) THEN
CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
CALL DSTERF( N, W, WORK( INDEE ), INFO )
ELSE
CALL DLACPY( 'A', N, N, Q, LDQ, Z, LDZ )
CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ,
$ WORK( INDWRK ), INFO )
IF( INFO.EQ.0 ) THEN
DO 10 I = 1, N
IFAIL( I ) = 0
10 CONTINUE
END IF
END IF
IF( INFO.EQ.0 ) THEN
M = N
GO TO 30
END IF
INFO = 0
END IF
*
* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN.
*
IF( WANTZ ) THEN
ORDER = 'B'
ELSE
ORDER = 'E'
END IF
INDIBL = 1
INDISP = INDIBL + N
INDIWO = INDISP + N
CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
$ WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
$ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ),
$ IWORK( INDIWO ), INFO )
*
IF( WANTZ ) THEN
CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
$ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
$ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO )
*
* Apply orthogonal matrix used in reduction to tridiagonal
* form to eigenvectors returned by DSTEIN.
*
DO 20 J = 1, M
CALL DCOPY( N, Z( 1, J ), 1, WORK( 1 ), 1 )
CALL DGEMV( 'N', N, N, ONE, Q, LDQ, WORK, 1, ZERO,
$ Z( 1, J ), 1 )
20 CONTINUE
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
30 CONTINUE
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = M
ELSE
IMAX = INFO - 1
END IF
CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
* If eigenvalues are not in order, then sort them, along with
* eigenvectors.
*
IF( WANTZ ) THEN
DO 50 J = 1, M - 1
I = 0
TMP1 = W( J )
DO 40 JJ = J + 1, M
IF( W( JJ ).LT.TMP1 ) THEN
I = JJ
TMP1 = W( JJ )
END IF
40 CONTINUE
*
IF( I.NE.0 ) THEN
ITMP1 = IWORK( INDIBL+I-1 )
W( I ) = W( J )
IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
W( J ) = TMP1
IWORK( INDIBL+J-1 ) = ITMP1
CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
IF( INFO.NE.0 ) THEN
ITMP1 = IFAIL( I )
IFAIL( I ) = IFAIL( J )
IFAIL( J ) = ITMP1
END IF
END IF
50 CONTINUE
END IF
*
RETURN
*
* End of DSBEVX
*
END
SUBROUTINE DSBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X,
$ LDX, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO, VECT
INTEGER INFO, KA, KB, LDAB, LDBB, LDX, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), WORK( * ),
$ X( LDX, * )
* ..
*
* Purpose
* =======
*
* DSBGST reduces a real symmetric-definite banded generalized
* eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y,
* such that C has the same bandwidth as A.
*
* B must have been previously factorized as S**T*S by DPBSTF, using a
* split Cholesky factorization. A is overwritten by C = X**T*A*X, where
* X = S**(-1)*Q and Q is an orthogonal matrix chosen to preserve the
* bandwidth of A.
*
* Arguments
* =========
*
* VECT (input) CHARACTER*1
* = 'N': do not form the transformation matrix X;
* = 'V': form X.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* KA (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
*
* KB (input) INTEGER
* The number of superdiagonals of the matrix B if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0.
*
* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
* On entry, the upper or lower triangle of the symmetric band
* matrix A, stored in the first ka+1 rows of the array. The
* j-th column of A is stored in the j-th column of the array AB
* as follows:
* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
*
* On exit, the transformed matrix X**T*A*X, stored in the same
* format as A.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KA+1.
*
* BB (input) DOUBLE PRECISION array, dimension (LDBB,N)
* The banded factor S from the split Cholesky factorization of
* B, as returned by DPBSTF, stored in the first KB+1 rows of
* the array.
*
* LDBB (input) INTEGER
* The leading dimension of the array BB. LDBB >= KB+1.
*
* X (output) DOUBLE PRECISION array, dimension (LDX,N)
* If VECT = 'V', the n-by-n matrix X.
* If VECT = 'N', the array X is not referenced.
*
* LDX (input) INTEGER
* The leading dimension of the array X.
* LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPDATE, UPPER, WANTX
INTEGER I, I0, I1, I2, INCA, J, J1, J1T, J2, J2T, K,
$ KA1, KB1, KBT, L, M, NR, NRT, NX
DOUBLE PRECISION BII, RA, RA1, T
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DGER, DLAR2V, DLARGV, DLARTG, DLARTV, DLASET,
$ DROT, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
WANTX = LSAME( VECT, 'V' )
UPPER = LSAME( UPLO, 'U' )
KA1 = KA + 1
KB1 = KB + 1
INFO = 0
IF( .NOT.WANTX .AND. .NOT.LSAME( VECT, 'N' ) ) THEN
INFO = -1
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( KA.LT.0 ) THEN
INFO = -4
ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
INFO = -5
ELSE IF( LDAB.LT.KA+1 ) THEN
INFO = -7
ELSE IF( LDBB.LT.KB+1 ) THEN
INFO = -9
ELSE IF( LDX.LT.1 .OR. WANTX .AND. LDX.LT.MAX( 1, N ) ) THEN
INFO = -11
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSBGST', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
INCA = LDAB*KA1
*
* Initialize X to the unit matrix, if needed
*
IF( WANTX )
$ CALL DLASET( 'Full', N, N, ZERO, ONE, X, LDX )
*
* Set M to the splitting point m. It must be the same value as is
* used in DPBSTF. The chosen value allows the arrays WORK and RWORK
* to be of dimension (N).
*
M = ( N+KB ) / 2
*
* The routine works in two phases, corresponding to the two halves
* of the split Cholesky factorization of B as S**T*S where
*
* S = ( U )
* ( M L )
*
* with U upper triangular of order m, and L lower triangular of
* order n-m. S has the same bandwidth as B.
*
* S is treated as a product of elementary matrices:
*
* S = S(m)*S(m-1)*...*S(2)*S(1)*S(m+1)*S(m+2)*...*S(n-1)*S(n)
*
* where S(i) is determined by the i-th row of S.
*
* In phase 1, the index i takes the values n, n-1, ... , m+1;
* in phase 2, it takes the values 1, 2, ... , m.
*
* For each value of i, the current matrix A is updated by forming
* inv(S(i))**T*A*inv(S(i)). This creates a triangular bulge outside
* the band of A. The bulge is then pushed down toward the bottom of
* A in phase 1, and up toward the top of A in phase 2, by applying
* plane rotations.
*
* There are kb*(kb+1)/2 elements in the bulge, but at most 2*kb-1
* of them are linearly independent, so annihilating a bulge requires
* only 2*kb-1 plane rotations. The rotations are divided into a 1st
* set of kb-1 rotations, and a 2nd set of kb rotations.
*
* Wherever possible, rotations are generated and applied in vector
* operations of length NR between the indices J1 and J2 (sometimes
* replaced by modified values NRT, J1T or J2T).
*
* The cosines and sines of the rotations are stored in the array
* WORK. The cosines of the 1st set of rotations are stored in
* elements n+2:n+m-kb-1 and the sines of the 1st set in elements
* 2:m-kb-1; the cosines of the 2nd set are stored in elements
* n+m-kb+1:2*n and the sines of the second set in elements m-kb+1:n.
*
* The bulges are not formed explicitly; nonzero elements outside the
* band are created only when they are required for generating new
* rotations; they are stored in the array WORK, in positions where
* they are later overwritten by the sines of the rotations which
* annihilate them.
*
* **************************** Phase 1 *****************************
*
* The logical structure of this phase is:
*
* UPDATE = .TRUE.
* DO I = N, M + 1, -1
* use S(i) to update A and create a new bulge
* apply rotations to push all bulges KA positions downward
* END DO
* UPDATE = .FALSE.
* DO I = M + KA + 1, N - 1
* apply rotations to push all bulges KA positions downward
* END DO
*
* To avoid duplicating code, the two loops are merged.
*
UPDATE = .TRUE.
I = N + 1
10 CONTINUE
IF( UPDATE ) THEN
I = I - 1
KBT = MIN( KB, I-1 )
I0 = I - 1
I1 = MIN( N, I+KA )
I2 = I - KBT + KA1
IF( I.LT.M+1 ) THEN
UPDATE = .FALSE.
I = I + 1
I0 = M
IF( KA.EQ.0 )
$ GO TO 480
GO TO 10
END IF
ELSE
I = I + KA
IF( I.GT.N-1 )
$ GO TO 480
END IF
*
IF( UPPER ) THEN
*
* Transform A, working with the upper triangle
*
IF( UPDATE ) THEN
*
* Form inv(S(i))**T * A * inv(S(i))
*
BII = BB( KB1, I )
DO 20 J = I, I1
AB( I-J+KA1, J ) = AB( I-J+KA1, J ) / BII
20 CONTINUE
DO 30 J = MAX( 1, I-KA ), I
AB( J-I+KA1, I ) = AB( J-I+KA1, I ) / BII
30 CONTINUE
DO 60 K = I - KBT, I - 1
DO 40 J = I - KBT, K
AB( J-K+KA1, K ) = AB( J-K+KA1, K ) -
$ BB( J-I+KB1, I )*AB( K-I+KA1, I ) -
$ BB( K-I+KB1, I )*AB( J-I+KA1, I ) +
$ AB( KA1, I )*BB( J-I+KB1, I )*
$ BB( K-I+KB1, I )
40 CONTINUE
DO 50 J = MAX( 1, I-KA ), I - KBT - 1
AB( J-K+KA1, K ) = AB( J-K+KA1, K ) -
$ BB( K-I+KB1, I )*AB( J-I+KA1, I )
50 CONTINUE
60 CONTINUE
DO 80 J = I, I1
DO 70 K = MAX( J-KA, I-KBT ), I - 1
AB( K-J+KA1, J ) = AB( K-J+KA1, J ) -
$ BB( K-I+KB1, I )*AB( I-J+KA1, J )
70 CONTINUE
80 CONTINUE
*
IF( WANTX ) THEN
*
* post-multiply X by inv(S(i))
*
CALL DSCAL( N-M, ONE / BII, X( M+1, I ), 1 )
IF( KBT.GT.0 )
$ CALL DGER( N-M, KBT, -ONE, X( M+1, I ), 1,
$ BB( KB1-KBT, I ), 1, X( M+1, I-KBT ), LDX )
END IF
*
* store a(i,i1) in RA1 for use in next loop over K
*
RA1 = AB( I-I1+KA1, I1 )
END IF
*
* Generate and apply vectors of rotations to chase all the
* existing bulges KA positions down toward the bottom of the
* band
*
DO 130 K = 1, KB - 1
IF( UPDATE ) THEN
*
* Determine the rotations which would annihilate the bulge
* which has in theory just been created
*
IF( I-K+KA.LT.N .AND. I-K.GT.1 ) THEN
*
* generate rotation to annihilate a(i,i-k+ka+1)
*
CALL DLARTG( AB( K+1, I-K+KA ), RA1,
$ WORK( N+I-K+KA-M ), WORK( I-K+KA-M ),
$ RA )
*
* create nonzero element a(i-k,i-k+ka+1) outside the
* band and store it in WORK(i-k)
*
T = -BB( KB1-K, I )*RA1
WORK( I-K ) = WORK( N+I-K+KA-M )*T -
$ WORK( I-K+KA-M )*AB( 1, I-K+KA )
AB( 1, I-K+KA ) = WORK( I-K+KA-M )*T +
$ WORK( N+I-K+KA-M )*AB( 1, I-K+KA )
RA1 = RA
END IF
END IF
J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
NR = ( N-J2+KA ) / KA1
J1 = J2 + ( NR-1 )*KA1
IF( UPDATE ) THEN
J2T = MAX( J2, I+2*KA-K+1 )
ELSE
J2T = J2
END IF
NRT = ( N-J2T+KA ) / KA1
DO 90 J = J2T, J1, KA1
*
* create nonzero element a(j-ka,j+1) outside the band
* and store it in WORK(j-m)
*
WORK( J-M ) = WORK( J-M )*AB( 1, J+1 )
AB( 1, J+1 ) = WORK( N+J-M )*AB( 1, J+1 )
90 CONTINUE
*
* generate rotations in 1st set to annihilate elements which
* have been created outside the band
*
IF( NRT.GT.0 )
$ CALL DLARGV( NRT, AB( 1, J2T ), INCA, WORK( J2T-M ), KA1,
$ WORK( N+J2T-M ), KA1 )
IF( NR.GT.0 ) THEN
*
* apply rotations in 1st set from the right
*
DO 100 L = 1, KA - 1
CALL DLARTV( NR, AB( KA1-L, J2 ), INCA,
$ AB( KA-L, J2+1 ), INCA, WORK( N+J2-M ),
$ WORK( J2-M ), KA1 )
100 CONTINUE
*
* apply rotations in 1st set from both sides to diagonal
* blocks
*
CALL DLAR2V( NR, AB( KA1, J2 ), AB( KA1, J2+1 ),
$ AB( KA, J2+1 ), INCA, WORK( N+J2-M ),
$ WORK( J2-M ), KA1 )
*
END IF
*
* start applying rotations in 1st set from the left
*
DO 110 L = KA - 1, KB - K + 1, -1
NRT = ( N-J2+L ) / KA1
IF( NRT.GT.0 )
$ CALL DLARTV( NRT, AB( L, J2+KA1-L ), INCA,
$ AB( L+1, J2+KA1-L ), INCA,
$ WORK( N+J2-M ), WORK( J2-M ), KA1 )
110 CONTINUE
*
IF( WANTX ) THEN
*
* post-multiply X by product of rotations in 1st set
*
DO 120 J = J2, J1, KA1
CALL DROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
$ WORK( N+J-M ), WORK( J-M ) )
120 CONTINUE
END IF
130 CONTINUE
*
IF( UPDATE ) THEN
IF( I2.LE.N .AND. KBT.GT.0 ) THEN
*
* create nonzero element a(i-kbt,i-kbt+ka+1) outside the
* band and store it in WORK(i-kbt)
*
WORK( I-KBT ) = -BB( KB1-KBT, I )*RA1
END IF
END IF
*
DO 170 K = KB, 1, -1
IF( UPDATE ) THEN
J2 = I - K - 1 + MAX( 2, K-I0+1 )*KA1
ELSE
J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
END IF
*
* finish applying rotations in 2nd set from the left
*
DO 140 L = KB - K, 1, -1
NRT = ( N-J2+KA+L ) / KA1
IF( NRT.GT.0 )
$ CALL DLARTV( NRT, AB( L, J2-L+1 ), INCA,
$ AB( L+1, J2-L+1 ), INCA, WORK( N+J2-KA ),
$ WORK( J2-KA ), KA1 )
140 CONTINUE
NR = ( N-J2+KA ) / KA1
J1 = J2 + ( NR-1 )*KA1
DO 150 J = J1, J2, -KA1
WORK( J ) = WORK( J-KA )
WORK( N+J ) = WORK( N+J-KA )
150 CONTINUE
DO 160 J = J2, J1, KA1
*
* create nonzero element a(j-ka,j+1) outside the band
* and store it in WORK(j)
*
WORK( J ) = WORK( J )*AB( 1, J+1 )
AB( 1, J+1 ) = WORK( N+J )*AB( 1, J+1 )
160 CONTINUE
IF( UPDATE ) THEN
IF( I-K.LT.N-KA .AND. K.LE.KBT )
$ WORK( I-K+KA ) = WORK( I-K )
END IF
170 CONTINUE
*
DO 210 K = KB, 1, -1
J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
NR = ( N-J2+KA ) / KA1
J1 = J2 + ( NR-1 )*KA1
IF( NR.GT.0 ) THEN
*
* generate rotations in 2nd set to annihilate elements
* which have been created outside the band
*
CALL DLARGV( NR, AB( 1, J2 ), INCA, WORK( J2 ), KA1,
$ WORK( N+J2 ), KA1 )
*
* apply rotations in 2nd set from the right
*
DO 180 L = 1, KA - 1
CALL DLARTV( NR, AB( KA1-L, J2 ), INCA,
$ AB( KA-L, J2+1 ), INCA, WORK( N+J2 ),
$ WORK( J2 ), KA1 )
180 CONTINUE
*
* apply rotations in 2nd set from both sides to diagonal
* blocks
*
CALL DLAR2V( NR, AB( KA1, J2 ), AB( KA1, J2+1 ),
$ AB( KA, J2+1 ), INCA, WORK( N+J2 ),
$ WORK( J2 ), KA1 )
*
END IF
*
* start applying rotations in 2nd set from the left
*
DO 190 L = KA - 1, KB - K + 1, -1
NRT = ( N-J2+L ) / KA1
IF( NRT.GT.0 )
$ CALL DLARTV( NRT, AB( L, J2+KA1-L ), INCA,
$ AB( L+1, J2+KA1-L ), INCA, WORK( N+J2 ),
$ WORK( J2 ), KA1 )
190 CONTINUE
*
IF( WANTX ) THEN
*
* post-multiply X by product of rotations in 2nd set
*
DO 200 J = J2, J1, KA1
CALL DROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
$ WORK( N+J ), WORK( J ) )
200 CONTINUE
END IF
210 CONTINUE
*
DO 230 K = 1, KB - 1
J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
*
* finish applying rotations in 1st set from the left
*
DO 220 L = KB - K, 1, -1
NRT = ( N-J2+L ) / KA1
IF( NRT.GT.0 )
$ CALL DLARTV( NRT, AB( L, J2+KA1-L ), INCA,
$ AB( L+1, J2+KA1-L ), INCA,
$ WORK( N+J2-M ), WORK( J2-M ), KA1 )
220 CONTINUE
230 CONTINUE
*
IF( KB.GT.1 ) THEN
DO 240 J = N - 1, I - KB + 2*KA + 1, -1
WORK( N+J-M ) = WORK( N+J-KA-M )
WORK( J-M ) = WORK( J-KA-M )
240 CONTINUE
END IF
*
ELSE
*
* Transform A, working with the lower triangle
*
IF( UPDATE ) THEN
*
* Form inv(S(i))**T * A * inv(S(i))
*
BII = BB( 1, I )
DO 250 J = I, I1
AB( J-I+1, I ) = AB( J-I+1, I ) / BII
250 CONTINUE
DO 260 J = MAX( 1, I-KA ), I
AB( I-J+1, J ) = AB( I-J+1, J ) / BII
260 CONTINUE
DO 290 K = I - KBT, I - 1
DO 270 J = I - KBT, K
AB( K-J+1, J ) = AB( K-J+1, J ) -
$ BB( I-J+1, J )*AB( I-K+1, K ) -
$ BB( I-K+1, K )*AB( I-J+1, J ) +
$ AB( 1, I )*BB( I-J+1, J )*
$ BB( I-K+1, K )
270 CONTINUE
DO 280 J = MAX( 1, I-KA ), I - KBT - 1
AB( K-J+1, J ) = AB( K-J+1, J ) -
$ BB( I-K+1, K )*AB( I-J+1, J )
280 CONTINUE
290 CONTINUE
DO 310 J = I, I1
DO 300 K = MAX( J-KA, I-KBT ), I - 1
AB( J-K+1, K ) = AB( J-K+1, K ) -
$ BB( I-K+1, K )*AB( J-I+1, I )
300 CONTINUE
310 CONTINUE
*
IF( WANTX ) THEN
*
* post-multiply X by inv(S(i))
*
CALL DSCAL( N-M, ONE / BII, X( M+1, I ), 1 )
IF( KBT.GT.0 )
$ CALL DGER( N-M, KBT, -ONE, X( M+1, I ), 1,
$ BB( KBT+1, I-KBT ), LDBB-1,
$ X( M+1, I-KBT ), LDX )
END IF
*
* store a(i1,i) in RA1 for use in next loop over K
*
RA1 = AB( I1-I+1, I )
END IF
*
* Generate and apply vectors of rotations to chase all the
* existing bulges KA positions down toward the bottom of the
* band
*
DO 360 K = 1, KB - 1
IF( UPDATE ) THEN
*
* Determine the rotations which would annihilate the bulge
* which has in theory just been created
*
IF( I-K+KA.LT.N .AND. I-K.GT.1 ) THEN
*
* generate rotation to annihilate a(i-k+ka+1,i)
*
CALL DLARTG( AB( KA1-K, I ), RA1, WORK( N+I-K+KA-M ),
$ WORK( I-K+KA-M ), RA )
*
* create nonzero element a(i-k+ka+1,i-k) outside the
* band and store it in WORK(i-k)
*
T = -BB( K+1, I-K )*RA1
WORK( I-K ) = WORK( N+I-K+KA-M )*T -
$ WORK( I-K+KA-M )*AB( KA1, I-K )
AB( KA1, I-K ) = WORK( I-K+KA-M )*T +
$ WORK( N+I-K+KA-M )*AB( KA1, I-K )
RA1 = RA
END IF
END IF
J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
NR = ( N-J2+KA ) / KA1
J1 = J2 + ( NR-1 )*KA1
IF( UPDATE ) THEN
J2T = MAX( J2, I+2*KA-K+1 )
ELSE
J2T = J2
END IF
NRT = ( N-J2T+KA ) / KA1
DO 320 J = J2T, J1, KA1
*
* create nonzero element a(j+1,j-ka) outside the band
* and store it in WORK(j-m)
*
WORK( J-M ) = WORK( J-M )*AB( KA1, J-KA+1 )
AB( KA1, J-KA+1 ) = WORK( N+J-M )*AB( KA1, J-KA+1 )
320 CONTINUE
*
* generate rotations in 1st set to annihilate elements which
* have been created outside the band
*
IF( NRT.GT.0 )
$ CALL DLARGV( NRT, AB( KA1, J2T-KA ), INCA, WORK( J2T-M ),
$ KA1, WORK( N+J2T-M ), KA1 )
IF( NR.GT.0 ) THEN
*
* apply rotations in 1st set from the left
*
DO 330 L = 1, KA - 1
CALL DLARTV( NR, AB( L+1, J2-L ), INCA,
$ AB( L+2, J2-L ), INCA, WORK( N+J2-M ),
$ WORK( J2-M ), KA1 )
330 CONTINUE
*
* apply rotations in 1st set from both sides to diagonal
* blocks
*
CALL DLAR2V( NR, AB( 1, J2 ), AB( 1, J2+1 ), AB( 2, J2 ),
$ INCA, WORK( N+J2-M ), WORK( J2-M ), KA1 )
*
END IF
*
* start applying rotations in 1st set from the right
*
DO 340 L = KA - 1, KB - K + 1, -1
NRT = ( N-J2+L ) / KA1
IF( NRT.GT.0 )
$ CALL DLARTV( NRT, AB( KA1-L+1, J2 ), INCA,
$ AB( KA1-L, J2+1 ), INCA, WORK( N+J2-M ),
$ WORK( J2-M ), KA1 )
340 CONTINUE
*
IF( WANTX ) THEN
*
* post-multiply X by product of rotations in 1st set
*
DO 350 J = J2, J1, KA1
CALL DROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
$ WORK( N+J-M ), WORK( J-M ) )
350 CONTINUE
END IF
360 CONTINUE
*
IF( UPDATE ) THEN
IF( I2.LE.N .AND. KBT.GT.0 ) THEN
*
* create nonzero element a(i-kbt+ka+1,i-kbt) outside the
* band and store it in WORK(i-kbt)
*
WORK( I-KBT ) = -BB( KBT+1, I-KBT )*RA1
END IF
END IF
*
DO 400 K = KB, 1, -1
IF( UPDATE ) THEN
J2 = I - K - 1 + MAX( 2, K-I0+1 )*KA1
ELSE
J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
END IF
*
* finish applying rotations in 2nd set from the right
*
DO 370 L = KB - K, 1, -1
NRT = ( N-J2+KA+L ) / KA1
IF( NRT.GT.0 )
$ CALL DLARTV( NRT, AB( KA1-L+1, J2-KA ), INCA,
$ AB( KA1-L, J2-KA+1 ), INCA,
$ WORK( N+J2-KA ), WORK( J2-KA ), KA1 )
370 CONTINUE
NR = ( N-J2+KA ) / KA1
J1 = J2 + ( NR-1 )*KA1
DO 380 J = J1, J2, -KA1
WORK( J ) = WORK( J-KA )
WORK( N+J ) = WORK( N+J-KA )
380 CONTINUE
DO 390 J = J2, J1, KA1
*
* create nonzero element a(j+1,j-ka) outside the band
* and store it in WORK(j)
*
WORK( J ) = WORK( J )*AB( KA1, J-KA+1 )
AB( KA1, J-KA+1 ) = WORK( N+J )*AB( KA1, J-KA+1 )
390 CONTINUE
IF( UPDATE ) THEN
IF( I-K.LT.N-KA .AND. K.LE.KBT )
$ WORK( I-K+KA ) = WORK( I-K )
END IF
400 CONTINUE
*
DO 440 K = KB, 1, -1
J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
NR = ( N-J2+KA ) / KA1
J1 = J2 + ( NR-1 )*KA1
IF( NR.GT.0 ) THEN
*
* generate rotations in 2nd set to annihilate elements
* which have been created outside the band
*
CALL DLARGV( NR, AB( KA1, J2-KA ), INCA, WORK( J2 ), KA1,
$ WORK( N+J2 ), KA1 )
*
* apply rotations in 2nd set from the left
*
DO 410 L = 1, KA - 1
CALL DLARTV( NR, AB( L+1, J2-L ), INCA,
$ AB( L+2, J2-L ), INCA, WORK( N+J2 ),
$ WORK( J2 ), KA1 )
410 CONTINUE
*
* apply rotations in 2nd set from both sides to diagonal
* blocks
*
CALL DLAR2V( NR, AB( 1, J2 ), AB( 1, J2+1 ), AB( 2, J2 ),
$ INCA, WORK( N+J2 ), WORK( J2 ), KA1 )
*
END IF
*
* start applying rotations in 2nd set from the right
*
DO 420 L = KA - 1, KB - K + 1, -1
NRT = ( N-J2+L ) / KA1
IF( NRT.GT.0 )
$ CALL DLARTV( NRT, AB( KA1-L+1, J2 ), INCA,
$ AB( KA1-L, J2+1 ), INCA, WORK( N+J2 ),
$ WORK( J2 ), KA1 )
420 CONTINUE
*
IF( WANTX ) THEN
*
* post-multiply X by product of rotations in 2nd set
*
DO 430 J = J2, J1, KA1
CALL DROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
$ WORK( N+J ), WORK( J ) )
430 CONTINUE
END IF
440 CONTINUE
*
DO 460 K = 1, KB - 1
J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
*
* finish applying rotations in 1st set from the right
*
DO 450 L = KB - K, 1, -1
NRT = ( N-J2+L ) / KA1
IF( NRT.GT.0 )
$ CALL DLARTV( NRT, AB( KA1-L+1, J2 ), INCA,
$ AB( KA1-L, J2+1 ), INCA, WORK( N+J2-M ),
$ WORK( J2-M ), KA1 )
450 CONTINUE
460 CONTINUE
*
IF( KB.GT.1 ) THEN
DO 470 J = N - 1, I - KB + 2*KA + 1, -1
WORK( N+J-M ) = WORK( N+J-KA-M )
WORK( J-M ) = WORK( J-KA-M )
470 CONTINUE
END IF
*
END IF
*
GO TO 10
*
480 CONTINUE
*
* **************************** Phase 2 *****************************
*
* The logical structure of this phase is:
*
* UPDATE = .TRUE.
* DO I = 1, M
* use S(i) to update A and create a new bulge
* apply rotations to push all bulges KA positions upward
* END DO
* UPDATE = .FALSE.
* DO I = M - KA - 1, 2, -1
* apply rotations to push all bulges KA positions upward
* END DO
*
* To avoid duplicating code, the two loops are merged.
*
UPDATE = .TRUE.
I = 0
490 CONTINUE
IF( UPDATE ) THEN
I = I + 1
KBT = MIN( KB, M-I )
I0 = I + 1
I1 = MAX( 1, I-KA )
I2 = I + KBT - KA1
IF( I.GT.M ) THEN
UPDATE = .FALSE.
I = I - 1
I0 = M + 1
IF( KA.EQ.0 )
$ RETURN
GO TO 490
END IF
ELSE
I = I - KA
IF( I.LT.2 )
$ RETURN
END IF
*
IF( I.LT.M-KBT ) THEN
NX = M
ELSE
NX = N
END IF
*
IF( UPPER ) THEN
*
* Transform A, working with the upper triangle
*
IF( UPDATE ) THEN
*
* Form inv(S(i))**T * A * inv(S(i))
*
BII = BB( KB1, I )
DO 500 J = I1, I
AB( J-I+KA1, I ) = AB( J-I+KA1, I ) / BII
500 CONTINUE
DO 510 J = I, MIN( N, I+KA )
AB( I-J+KA1, J ) = AB( I-J+KA1, J ) / BII
510 CONTINUE
DO 540 K = I + 1, I + KBT
DO 520 J = K, I + KBT
AB( K-J+KA1, J ) = AB( K-J+KA1, J ) -
$ BB( I-J+KB1, J )*AB( I-K+KA1, K ) -
$ BB( I-K+KB1, K )*AB( I-J+KA1, J ) +
$ AB( KA1, I )*BB( I-J+KB1, J )*
$ BB( I-K+KB1, K )
520 CONTINUE
DO 530 J = I + KBT + 1, MIN( N, I+KA )
AB( K-J+KA1, J ) = AB( K-J+KA1, J ) -
$ BB( I-K+KB1, K )*AB( I-J+KA1, J )
530 CONTINUE
540 CONTINUE
DO 560 J = I1, I
DO 550 K = I + 1, MIN( J+KA, I+KBT )
AB( J-K+KA1, K ) = AB( J-K+KA1, K ) -
$ BB( I-K+KB1, K )*AB( J-I+KA1, I )
550 CONTINUE
560 CONTINUE
*
IF( WANTX ) THEN
*
* post-multiply X by inv(S(i))
*
CALL DSCAL( NX, ONE / BII, X( 1, I ), 1 )
IF( KBT.GT.0 )
$ CALL DGER( NX, KBT, -ONE, X( 1, I ), 1, BB( KB, I+1 ),
$ LDBB-1, X( 1, I+1 ), LDX )
END IF
*
* store a(i1,i) in RA1 for use in next loop over K
*
RA1 = AB( I1-I+KA1, I )
END IF
*
* Generate and apply vectors of rotations to chase all the
* existing bulges KA positions up toward the top of the band
*
DO 610 K = 1, KB - 1
IF( UPDATE ) THEN
*
* Determine the rotations which would annihilate the bulge
* which has in theory just been created
*
IF( I+K-KA1.GT.0 .AND. I+K.LT.M ) THEN
*
* generate rotation to annihilate a(i+k-ka-1,i)
*
CALL DLARTG( AB( K+1, I ), RA1, WORK( N+I+K-KA ),
$ WORK( I+K-KA ), RA )
*
* create nonzero element a(i+k-ka-1,i+k) outside the
* band and store it in WORK(m-kb+i+k)
*
T = -BB( KB1-K, I+K )*RA1
WORK( M-KB+I+K ) = WORK( N+I+K-KA )*T -
$ WORK( I+K-KA )*AB( 1, I+K )
AB( 1, I+K ) = WORK( I+K-KA )*T +
$ WORK( N+I+K-KA )*AB( 1, I+K )
RA1 = RA
END IF
END IF
J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
NR = ( J2+KA-1 ) / KA1
J1 = J2 - ( NR-1 )*KA1
IF( UPDATE ) THEN
J2T = MIN( J2, I-2*KA+K-1 )
ELSE
J2T = J2
END IF
NRT = ( J2T+KA-1 ) / KA1
DO 570 J = J1, J2T, KA1
*
* create nonzero element a(j-1,j+ka) outside the band
* and store it in WORK(j)
*
WORK( J ) = WORK( J )*AB( 1, J+KA-1 )
AB( 1, J+KA-1 ) = WORK( N+J )*AB( 1, J+KA-1 )
570 CONTINUE
*
* generate rotations in 1st set to annihilate elements which
* have been created outside the band
*
IF( NRT.GT.0 )
$ CALL DLARGV( NRT, AB( 1, J1+KA ), INCA, WORK( J1 ), KA1,
$ WORK( N+J1 ), KA1 )
IF( NR.GT.0 ) THEN
*
* apply rotations in 1st set from the left
*
DO 580 L = 1, KA - 1
CALL DLARTV( NR, AB( KA1-L, J1+L ), INCA,
$ AB( KA-L, J1+L ), INCA, WORK( N+J1 ),
$ WORK( J1 ), KA1 )
580 CONTINUE
*
* apply rotations in 1st set from both sides to diagonal
* blocks
*
CALL DLAR2V( NR, AB( KA1, J1 ), AB( KA1, J1-1 ),
$ AB( KA, J1 ), INCA, WORK( N+J1 ),
$ WORK( J1 ), KA1 )
*
END IF
*
* start applying rotations in 1st set from the right
*
DO 590 L = KA - 1, KB - K + 1, -1
NRT = ( J2+L-1 ) / KA1
J1T = J2 - ( NRT-1 )*KA1
IF( NRT.GT.0 )
$ CALL DLARTV( NRT, AB( L, J1T ), INCA,
$ AB( L+1, J1T-1 ), INCA, WORK( N+J1T ),
$ WORK( J1T ), KA1 )
590 CONTINUE
*
IF( WANTX ) THEN
*
* post-multiply X by product of rotations in 1st set
*
DO 600 J = J1, J2, KA1
CALL DROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
$ WORK( N+J ), WORK( J ) )
600 CONTINUE
END IF
610 CONTINUE
*
IF( UPDATE ) THEN
IF( I2.GT.0 .AND. KBT.GT.0 ) THEN
*
* create nonzero element a(i+kbt-ka-1,i+kbt) outside the
* band and store it in WORK(m-kb+i+kbt)
*
WORK( M-KB+I+KBT ) = -BB( KB1-KBT, I+KBT )*RA1
END IF
END IF
*
DO 650 K = KB, 1, -1
IF( UPDATE ) THEN
J2 = I + K + 1 - MAX( 2, K+I0-M )*KA1
ELSE
J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
END IF
*
* finish applying rotations in 2nd set from the right
*
DO 620 L = KB - K, 1, -1
NRT = ( J2+KA+L-1 ) / KA1
J1T = J2 - ( NRT-1 )*KA1
IF( NRT.GT.0 )
$ CALL DLARTV( NRT, AB( L, J1T+KA ), INCA,
$ AB( L+1, J1T+KA-1 ), INCA,
$ WORK( N+M-KB+J1T+KA ),
$ WORK( M-KB+J1T+KA ), KA1 )
620 CONTINUE
NR = ( J2+KA-1 ) / KA1
J1 = J2 - ( NR-1 )*KA1
DO 630 J = J1, J2, KA1
WORK( M-KB+J ) = WORK( M-KB+J+KA )
WORK( N+M-KB+J ) = WORK( N+M-KB+J+KA )
630 CONTINUE
DO 640 J = J1, J2, KA1
*
* create nonzero element a(j-1,j+ka) outside the band
* and store it in WORK(m-kb+j)
*
WORK( M-KB+J ) = WORK( M-KB+J )*AB( 1, J+KA-1 )
AB( 1, J+KA-1 ) = WORK( N+M-KB+J )*AB( 1, J+KA-1 )
640 CONTINUE
IF( UPDATE ) THEN
IF( I+K.GT.KA1 .AND. K.LE.KBT )
$ WORK( M-KB+I+K-KA ) = WORK( M-KB+I+K )
END IF
650 CONTINUE
*
DO 690 K = KB, 1, -1
J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
NR = ( J2+KA-1 ) / KA1
J1 = J2 - ( NR-1 )*KA1
IF( NR.GT.0 ) THEN
*
* generate rotations in 2nd set to annihilate elements
* which have been created outside the band
*
CALL DLARGV( NR, AB( 1, J1+KA ), INCA, WORK( M-KB+J1 ),
$ KA1, WORK( N+M-KB+J1 ), KA1 )
*
* apply rotations in 2nd set from the left
*
DO 660 L = 1, KA - 1
CALL DLARTV( NR, AB( KA1-L, J1+L ), INCA,
$ AB( KA-L, J1+L ), INCA,
$ WORK( N+M-KB+J1 ), WORK( M-KB+J1 ), KA1 )
660 CONTINUE
*
* apply rotations in 2nd set from both sides to diagonal
* blocks
*
CALL DLAR2V( NR, AB( KA1, J1 ), AB( KA1, J1-1 ),
$ AB( KA, J1 ), INCA, WORK( N+M-KB+J1 ),
$ WORK( M-KB+J1 ), KA1 )
*
END IF
*
* start applying rotations in 2nd set from the right
*
DO 670 L = KA - 1, KB - K + 1, -1
NRT = ( J2+L-1 ) / KA1
J1T = J2 - ( NRT-1 )*KA1
IF( NRT.GT.0 )
$ CALL DLARTV( NRT, AB( L, J1T ), INCA,
$ AB( L+1, J1T-1 ), INCA,
$ WORK( N+M-KB+J1T ), WORK( M-KB+J1T ),
$ KA1 )
670 CONTINUE
*
IF( WANTX ) THEN
*
* post-multiply X by product of rotations in 2nd set
*
DO 680 J = J1, J2, KA1
CALL DROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
$ WORK( N+M-KB+J ), WORK( M-KB+J ) )
680 CONTINUE
END IF
690 CONTINUE
*
DO 710 K = 1, KB - 1
J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
*
* finish applying rotations in 1st set from the right
*
DO 700 L = KB - K, 1, -1
NRT = ( J2+L-1 ) / KA1
J1T = J2 - ( NRT-1 )*KA1
IF( NRT.GT.0 )
$ CALL DLARTV( NRT, AB( L, J1T ), INCA,
$ AB( L+1, J1T-1 ), INCA, WORK( N+J1T ),
$ WORK( J1T ), KA1 )
700 CONTINUE
710 CONTINUE
*
IF( KB.GT.1 ) THEN
DO 720 J = 2, MIN( I+KB, M ) - 2*KA - 1
WORK( N+J ) = WORK( N+J+KA )
WORK( J ) = WORK( J+KA )
720 CONTINUE
END IF
*
ELSE
*
* Transform A, working with the lower triangle
*
IF( UPDATE ) THEN
*
* Form inv(S(i))**T * A * inv(S(i))
*
BII = BB( 1, I )
DO 730 J = I1, I
AB( I-J+1, J ) = AB( I-J+1, J ) / BII
730 CONTINUE
DO 740 J = I, MIN( N, I+KA )
AB( J-I+1, I ) = AB( J-I+1, I ) / BII
740 CONTINUE
DO 770 K = I + 1, I + KBT
DO 750 J = K, I + KBT
AB( J-K+1, K ) = AB( J-K+1, K ) -
$ BB( J-I+1, I )*AB( K-I+1, I ) -
$ BB( K-I+1, I )*AB( J-I+1, I ) +
$ AB( 1, I )*BB( J-I+1, I )*
$ BB( K-I+1, I )
750 CONTINUE
DO 760 J = I + KBT + 1, MIN( N, I+KA )
AB( J-K+1, K ) = AB( J-K+1, K ) -
$ BB( K-I+1, I )*AB( J-I+1, I )
760 CONTINUE
770 CONTINUE
DO 790 J = I1, I
DO 780 K = I + 1, MIN( J+KA, I+KBT )
AB( K-J+1, J ) = AB( K-J+1, J ) -
$ BB( K-I+1, I )*AB( I-J+1, J )
780 CONTINUE
790 CONTINUE
*
IF( WANTX ) THEN
*
* post-multiply X by inv(S(i))
*
CALL DSCAL( NX, ONE / BII, X( 1, I ), 1 )
IF( KBT.GT.0 )
$ CALL DGER( NX, KBT, -ONE, X( 1, I ), 1, BB( 2, I ), 1,
$ X( 1, I+1 ), LDX )
END IF
*
* store a(i,i1) in RA1 for use in next loop over K
*
RA1 = AB( I-I1+1, I1 )
END IF
*
* Generate and apply vectors of rotations to chase all the
* existing bulges KA positions up toward the top of the band
*
DO 840 K = 1, KB - 1
IF( UPDATE ) THEN
*
* Determine the rotations which would annihilate the bulge
* which has in theory just been created
*
IF( I+K-KA1.GT.0 .AND. I+K.LT.M ) THEN
*
* generate rotation to annihilate a(i,i+k-ka-1)
*
CALL DLARTG( AB( KA1-K, I+K-KA ), RA1,
$ WORK( N+I+K-KA ), WORK( I+K-KA ), RA )
*
* create nonzero element a(i+k,i+k-ka-1) outside the
* band and store it in WORK(m-kb+i+k)
*
T = -BB( K+1, I )*RA1
WORK( M-KB+I+K ) = WORK( N+I+K-KA )*T -
$ WORK( I+K-KA )*AB( KA1, I+K-KA )
AB( KA1, I+K-KA ) = WORK( I+K-KA )*T +
$ WORK( N+I+K-KA )*AB( KA1, I+K-KA )
RA1 = RA
END IF
END IF
J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
NR = ( J2+KA-1 ) / KA1
J1 = J2 - ( NR-1 )*KA1
IF( UPDATE ) THEN
J2T = MIN( J2, I-2*KA+K-1 )
ELSE
J2T = J2
END IF
NRT = ( J2T+KA-1 ) / KA1
DO 800 J = J1, J2T, KA1
*
* create nonzero element a(j+ka,j-1) outside the band
* and store it in WORK(j)
*
WORK( J ) = WORK( J )*AB( KA1, J-1 )
AB( KA1, J-1 ) = WORK( N+J )*AB( KA1, J-1 )
800 CONTINUE
*
* generate rotations in 1st set to annihilate elements which
* have been created outside the band
*
IF( NRT.GT.0 )
$ CALL DLARGV( NRT, AB( KA1, J1 ), INCA, WORK( J1 ), KA1,
$ WORK( N+J1 ), KA1 )
IF( NR.GT.0 ) THEN
*
* apply rotations in 1st set from the right
*
DO 810 L = 1, KA - 1
CALL DLARTV( NR, AB( L+1, J1 ), INCA, AB( L+2, J1-1 ),
$ INCA, WORK( N+J1 ), WORK( J1 ), KA1 )
810 CONTINUE
*
* apply rotations in 1st set from both sides to diagonal
* blocks
*
CALL DLAR2V( NR, AB( 1, J1 ), AB( 1, J1-1 ),
$ AB( 2, J1-1 ), INCA, WORK( N+J1 ),
$ WORK( J1 ), KA1 )
*
END IF
*
* start applying rotations in 1st set from the left
*
DO 820 L = KA - 1, KB - K + 1, -1
NRT = ( J2+L-1 ) / KA1
J1T = J2 - ( NRT-1 )*KA1
IF( NRT.GT.0 )
$ CALL DLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA,
$ AB( KA1-L, J1T-KA1+L ), INCA,
$ WORK( N+J1T ), WORK( J1T ), KA1 )
820 CONTINUE
*
IF( WANTX ) THEN
*
* post-multiply X by product of rotations in 1st set
*
DO 830 J = J1, J2, KA1
CALL DROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
$ WORK( N+J ), WORK( J ) )
830 CONTINUE
END IF
840 CONTINUE
*
IF( UPDATE ) THEN
IF( I2.GT.0 .AND. KBT.GT.0 ) THEN
*
* create nonzero element a(i+kbt,i+kbt-ka-1) outside the
* band and store it in WORK(m-kb+i+kbt)
*
WORK( M-KB+I+KBT ) = -BB( KBT+1, I )*RA1
END IF
END IF
*
DO 880 K = KB, 1, -1
IF( UPDATE ) THEN
J2 = I + K + 1 - MAX( 2, K+I0-M )*KA1
ELSE
J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
END IF
*
* finish applying rotations in 2nd set from the left
*
DO 850 L = KB - K, 1, -1
NRT = ( J2+KA+L-1 ) / KA1
J1T = J2 - ( NRT-1 )*KA1
IF( NRT.GT.0 )
$ CALL DLARTV( NRT, AB( KA1-L+1, J1T+L-1 ), INCA,
$ AB( KA1-L, J1T+L-1 ), INCA,
$ WORK( N+M-KB+J1T+KA ),
$ WORK( M-KB+J1T+KA ), KA1 )
850 CONTINUE
NR = ( J2+KA-1 ) / KA1
J1 = J2 - ( NR-1 )*KA1
DO 860 J = J1, J2, KA1
WORK( M-KB+J ) = WORK( M-KB+J+KA )
WORK( N+M-KB+J ) = WORK( N+M-KB+J+KA )
860 CONTINUE
DO 870 J = J1, J2, KA1
*
* create nonzero element a(j+ka,j-1) outside the band
* and store it in WORK(m-kb+j)
*
WORK( M-KB+J ) = WORK( M-KB+J )*AB( KA1, J-1 )
AB( KA1, J-1 ) = WORK( N+M-KB+J )*AB( KA1, J-1 )
870 CONTINUE
IF( UPDATE ) THEN
IF( I+K.GT.KA1 .AND. K.LE.KBT )
$ WORK( M-KB+I+K-KA ) = WORK( M-KB+I+K )
END IF
880 CONTINUE
*
DO 920 K = KB, 1, -1
J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
NR = ( J2+KA-1 ) / KA1
J1 = J2 - ( NR-1 )*KA1
IF( NR.GT.0 ) THEN
*
* generate rotations in 2nd set to annihilate elements
* which have been created outside the band
*
CALL DLARGV( NR, AB( KA1, J1 ), INCA, WORK( M-KB+J1 ),
$ KA1, WORK( N+M-KB+J1 ), KA1 )
*
* apply rotations in 2nd set from the right
*
DO 890 L = 1, KA - 1
CALL DLARTV( NR, AB( L+1, J1 ), INCA, AB( L+2, J1-1 ),
$ INCA, WORK( N+M-KB+J1 ), WORK( M-KB+J1 ),
$ KA1 )
890 CONTINUE
*
* apply rotations in 2nd set from both sides to diagonal
* blocks
*
CALL DLAR2V( NR, AB( 1, J1 ), AB( 1, J1-1 ),
$ AB( 2, J1-1 ), INCA, WORK( N+M-KB+J1 ),
$ WORK( M-KB+J1 ), KA1 )
*
END IF
*
* start applying rotations in 2nd set from the left
*
DO 900 L = KA - 1, KB - K + 1, -1
NRT = ( J2+L-1 ) / KA1
J1T = J2 - ( NRT-1 )*KA1
IF( NRT.GT.0 )
$ CALL DLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA,
$ AB( KA1-L, J1T-KA1+L ), INCA,
$ WORK( N+M-KB+J1T ), WORK( M-KB+J1T ),
$ KA1 )
900 CONTINUE
*
IF( WANTX ) THEN
*
* post-multiply X by product of rotations in 2nd set
*
DO 910 J = J1, J2, KA1
CALL DROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
$ WORK( N+M-KB+J ), WORK( M-KB+J ) )
910 CONTINUE
END IF
920 CONTINUE
*
DO 940 K = 1, KB - 1
J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
*
* finish applying rotations in 1st set from the left
*
DO 930 L = KB - K, 1, -1
NRT = ( J2+L-1 ) / KA1
J1T = J2 - ( NRT-1 )*KA1
IF( NRT.GT.0 )
$ CALL DLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA,
$ AB( KA1-L, J1T-KA1+L ), INCA,
$ WORK( N+J1T ), WORK( J1T ), KA1 )
930 CONTINUE
940 CONTINUE
*
IF( KB.GT.1 ) THEN
DO 950 J = 2, MIN( I+KB, M ) - 2*KA - 1
WORK( N+J ) = WORK( N+J+KA )
WORK( J ) = WORK( J+KA )
950 CONTINUE
END IF
*
END IF
*
GO TO 490
*
* End of DSBGST
*
END
SUBROUTINE DSBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z,
$ LDZ, WORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, KA, KB, LDAB, LDBB, LDZ, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), W( * ),
$ WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DSBGV computes all the eigenvalues, and optionally, the eigenvectors
* of a real generalized symmetric-definite banded eigenproblem, of
* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric
* and banded, and B is also positive definite.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangles of A and B are stored;
* = 'L': Lower triangles of A and B are stored.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* KA (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
*
* KB (input) INTEGER
* The number of superdiagonals of the matrix B if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KB >= 0.
*
* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)
* On entry, the upper or lower triangle of the symmetric band
* matrix A, stored in the first ka+1 rows of the array. The
* j-th column of A is stored in the j-th column of the array AB
* as follows:
* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
*
* On exit, the contents of AB are destroyed.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KA+1.
*
* BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N)
* On entry, the upper or lower triangle of the symmetric band
* matrix B, stored in the first kb+1 rows of the array. The
* j-th column of B is stored in the j-th column of the array BB
* as follows:
* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).
*
* On exit, the factor S from the split Cholesky factorization
* B = S**T*S, as returned by DPBSTF.
*
* LDBB (input) INTEGER
* The leading dimension of the array BB. LDBB >= KB+1.
*
* W (output) DOUBLE PRECISION array, dimension (N)
* If INFO = 0, the eigenvalues in ascending order.
*
* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
* eigenvectors, with the i-th column of Z holding the
* eigenvector associated with W(i). The eigenvectors are
* normalized so that Z**T*B*Z = I.
* If JOBZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= N.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, and i is:
* <= N: the algorithm failed to converge:
* i off-diagonal elements of an intermediate
* tridiagonal form did not converge to zero;
* > N: if INFO = N + i, for 1 <= i <= N, then DPBSTF
* returned INFO = i: B is not positive definite.
* The factorization of B could not be completed and
* no eigenvalues or eigenvectors were computed.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL UPPER, WANTZ
CHARACTER VECT
INTEGER IINFO, INDE, INDWRK
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DPBSTF, DSBGST, DSBTRD, DSTEQR, DSTERF, XERBLA
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
UPPER = LSAME( UPLO, 'U' )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( KA.LT.0 ) THEN
INFO = -4
ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
INFO = -5
ELSE IF( LDAB.LT.KA+1 ) THEN
INFO = -7
ELSE IF( LDBB.LT.KB+1 ) THEN
INFO = -9
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSBGV ', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Form a split Cholesky factorization of B.
*
CALL DPBSTF( UPLO, N, KB, BB, LDBB, INFO )
IF( INFO.NE.0 ) THEN
INFO = N + INFO
RETURN
END IF
*
* Transform problem to standard eigenvalue problem.
*
INDE = 1
INDWRK = INDE + N
CALL DSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Z, LDZ,
$ WORK( INDWRK ), IINFO )
*
* Reduce to tridiagonal form.
*
IF( WANTZ ) THEN
VECT = 'U'
ELSE
VECT = 'N'
END IF
CALL DSBTRD( VECT, UPLO, N, KA, AB, LDAB, W, WORK( INDE ), Z, LDZ,
$ WORK( INDWRK ), IINFO )
*
* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEQR.
*
IF( .NOT.WANTZ ) THEN
CALL DSTERF( N, W, WORK( INDE ), INFO )
ELSE
CALL DSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ),
$ INFO )
END IF
RETURN
*
* End of DSBGV
*
END
SUBROUTINE DSBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W,
$ Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, KA, KB, LDAB, LDBB, LDZ, LIWORK, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), W( * ),
$ WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DSBGVD computes all the eigenvalues, and optionally, the eigenvectors
* of a real generalized symmetric-definite banded eigenproblem, of the
* form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric and
* banded, and B is also positive definite. If eigenvectors are
* desired, it uses a divide and conquer algorithm.
*
* The divide and conquer algorithm makes very mild assumptions about
* floating point arithmetic. It will work on machines with a guard
* digit in add/subtract, or on those binary machines without guard
* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
* Cray-2. It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangles of A and B are stored;
* = 'L': Lower triangles of A and B are stored.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* KA (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
*
* KB (input) INTEGER
* The number of superdiagonals of the matrix B if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KB >= 0.
*
* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)
* On entry, the upper or lower triangle of the symmetric band
* matrix A, stored in the first ka+1 rows of the array. The
* j-th column of A is stored in the j-th column of the array AB
* as follows:
* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
*
* On exit, the contents of AB are destroyed.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KA+1.
*
* BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N)
* On entry, the upper or lower triangle of the symmetric band
* matrix B, stored in the first kb+1 rows of the array. The
* j-th column of B is stored in the j-th column of the array BB
* as follows:
* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).
*
* On exit, the factor S from the split Cholesky factorization
* B = S**T*S, as returned by DPBSTF.
*
* LDBB (input) INTEGER
* The leading dimension of the array BB. LDBB >= KB+1.
*
* W (output) DOUBLE PRECISION array, dimension (N)
* If INFO = 0, the eigenvalues in ascending order.
*
* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
* eigenvectors, with the i-th column of Z holding the
* eigenvector associated with W(i). The eigenvectors are
* normalized so Z**T*B*Z = I.
* If JOBZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* 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 N <= 1, LWORK >= 1.
* If JOBZ = 'N' and N > 1, LWORK >= 3*N.
* If JOBZ = 'V' and N > 1, LWORK >= 1 + 5*N + 2*N**2.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal sizes of the WORK and IWORK
* arrays, returns these values as the first entries of the WORK
* and IWORK arrays, and no error message related to LWORK or
* LIWORK is issued by XERBLA.
*
* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK.
* If JOBZ = 'N' or N <= 1, LIWORK >= 1.
* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal sizes of the WORK and
* IWORK arrays, returns these values as the first entries of
* the WORK and IWORK arrays, and no error message related to
* LWORK or LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, and i is:
* <= N: the algorithm failed to converge:
* i off-diagonal elements of an intermediate
* tridiagonal form did not converge to zero;
* > N: if INFO = N + i, for 1 <= i <= N, then DPBSTF
* returned INFO = i: B is not positive definite.
* The factorization of B could not be completed and
* no eigenvalues or eigenvectors were computed.
*
* Further Details
* ===============
*
* Based on contributions by
* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, UPPER, WANTZ
CHARACTER VECT
INTEGER IINFO, INDE, INDWK2, INDWRK, LIWMIN, LLWRK2,
$ LWMIN
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLACPY, DPBSTF, DSBGST, DSBTRD, DSTEDC,
$ DSTERF, XERBLA
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
UPPER = LSAME( UPLO, 'U' )
LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
INFO = 0
IF( N.LE.1 ) THEN
LIWMIN = 1
LWMIN = 1
ELSE IF( WANTZ ) THEN
LIWMIN = 3 + 5*N
LWMIN = 1 + 5*N + 2*N**2
ELSE
LIWMIN = 1
LWMIN = 2*N
END IF
*
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( KA.LT.0 ) THEN
INFO = -4
ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
INFO = -5
ELSE IF( LDAB.LT.KA+1 ) THEN
INFO = -7
ELSE IF( LDBB.LT.KB+1 ) THEN
INFO = -9
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -12
END IF
*
IF( INFO.EQ.0 ) THEN
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -14
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -16
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSBGVD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Form a split Cholesky factorization of B.
*
CALL DPBSTF( UPLO, N, KB, BB, LDBB, INFO )
IF( INFO.NE.0 ) THEN
INFO = N + INFO
RETURN
END IF
*
* Transform problem to standard eigenvalue problem.
*
INDE = 1
INDWRK = INDE + N
INDWK2 = INDWRK + N*N
LLWRK2 = LWORK - INDWK2 + 1
CALL DSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Z, LDZ,
$ WORK( INDWRK ), IINFO )
*
* Reduce to tridiagonal form.
*
IF( WANTZ ) THEN
VECT = 'U'
ELSE
VECT = 'N'
END IF
CALL DSBTRD( VECT, UPLO, N, KA, AB, LDAB, W, WORK( INDE ), Z, LDZ,
$ WORK( INDWRK ), IINFO )
*
* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEDC.
*
IF( .NOT.WANTZ ) THEN
CALL DSTERF( N, W, WORK( INDE ), INFO )
ELSE
CALL DSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N,
$ WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO )
CALL DGEMM( 'N', 'N', N, N, N, ONE, Z, LDZ, WORK( INDWRK ), N,
$ ZERO, WORK( INDWK2 ), N )
CALL DLACPY( 'A', N, N, WORK( INDWK2 ), N, Z, LDZ )
END IF
*
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
RETURN
*
* End of DSBGVD
*
END
SUBROUTINE DSBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB,
$ LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z,
$ LDZ, WORK, IWORK, IFAIL, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE, UPLO
INTEGER IL, INFO, IU, KA, KB, LDAB, LDBB, LDQ, LDZ, M,
$ N
DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER IFAIL( * ), IWORK( * )
DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), Q( LDQ, * ),
$ W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DSBGVX computes selected eigenvalues, and optionally, eigenvectors
* of a real generalized symmetric-definite banded eigenproblem, of
* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric
* and banded, and B is also positive definite. Eigenvalues and
* eigenvectors can be selected by specifying either all eigenvalues,
* a range of values or a range of indices for the desired eigenvalues.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* RANGE (input) CHARACTER*1
* = 'A': all eigenvalues will be found.
* = 'V': all eigenvalues in the half-open interval (VL,VU]
* will be found.
* = 'I': the IL-th through IU-th eigenvalues will be found.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangles of A and B are stored;
* = 'L': Lower triangles of A and B are stored.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* KA (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
*
* KB (input) INTEGER
* The number of superdiagonals of the matrix B if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KB >= 0.
*
* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)
* On entry, the upper or lower triangle of the symmetric band
* matrix A, stored in the first ka+1 rows of the array. The
* j-th column of A is stored in the j-th column of the array AB
* as follows:
* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
*
* On exit, the contents of AB are destroyed.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KA+1.
*
* BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N)
* On entry, the upper or lower triangle of the symmetric band
* matrix B, stored in the first kb+1 rows of the array. The
* j-th column of B is stored in the j-th column of the array BB
* as follows:
* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).
*
* On exit, the factor S from the split Cholesky factorization
* B = S**T*S, as returned by DPBSTF.
*
* LDBB (input) INTEGER
* The leading dimension of the array BB. LDBB >= KB+1.
*
* Q (output) DOUBLE PRECISION array, dimension (LDQ, N)
* If JOBZ = 'V', the n-by-n matrix used in the reduction of
* A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x,
* and consequently C to tridiagonal form.
* If JOBZ = 'N', the array Q is not referenced.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. If JOBZ = 'N',
* LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N).
*
* VL (input) DOUBLE PRECISION
* VU (input) DOUBLE PRECISION
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* ABSTOL (input) DOUBLE PRECISION
* The absolute error tolerance for the eigenvalues.
* An approximate eigenvalue is accepted as converged
* when it is determined to lie in an interval [a,b]
* of width less than or equal to
*
* ABSTOL + EPS * max( |a|,|b| ) ,
*
* where EPS is the machine precision. If ABSTOL is less than
* or equal to zero, then EPS*|T| will be used in its place,
* where |T| is the 1-norm of the tridiagonal matrix obtained
* by reducing A to tridiagonal form.
*
* Eigenvalues will be computed most accurately when ABSTOL is
* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
* If this routine returns with INFO>0, indicating that some
* eigenvectors did not converge, try setting ABSTOL to
* 2*DLAMCH('S').
*
* M (output) INTEGER
* The total number of eigenvalues found. 0 <= M <= N.
* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*
* W (output) DOUBLE PRECISION array, dimension (N)
* If INFO = 0, the eigenvalues in ascending order.
*
* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
* eigenvectors, with the i-th column of Z holding the
* eigenvector associated with W(i). The eigenvectors are
* normalized so Z**T*B*Z = I.
* If JOBZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace/output) DOUBLE PRECISION array, dimension (7*N)
*
* IWORK (workspace/output) INTEGER array, dimension (5*N)
*
* IFAIL (output) INTEGER array, dimension (M)
* If JOBZ = 'V', then if INFO = 0, the first M elements of
* IFAIL are zero. If INFO > 0, then IFAIL contains the
* indices of the eigenvalues that failed to converge.
* If JOBZ = 'N', then IFAIL is not referenced.
*
* INFO (output) INTEGER
* = 0 : successful exit
* < 0 : if INFO = -i, the i-th argument had an illegal value
* <= N: if INFO = i, then i eigenvectors failed to converge.
* Their indices are stored in IFAIL.
* > N : DPBSTF returned an error code; i.e.,
* if INFO = N + i, for 1 <= i <= N, then the leading
* minor of order i of B is not positive definite.
* The factorization of B could not be completed and
* no eigenvalues or eigenvectors were computed.
*
* Further Details
* ===============
*
* Based on contributions by
* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, TEST, UPPER, VALEIG, WANTZ
CHARACTER ORDER, VECT
INTEGER I, IINFO, INDD, INDE, INDEE, INDIBL, INDISP,
$ INDIWO, INDWRK, ITMP1, J, JJ, NSPLIT
DOUBLE PRECISION TMP1
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMV, DLACPY, DPBSTF, DSBGST, DSBTRD,
$ DSTEBZ, DSTEIN, DSTEQR, DSTERF, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
UPPER = LSAME( UPLO, 'U' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
INFO = -2
ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( KA.LT.0 ) THEN
INFO = -5
ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
INFO = -6
ELSE IF( LDAB.LT.KA+1 ) THEN
INFO = -8
ELSE IF( LDBB.LT.KB+1 ) THEN
INFO = -10
ELSE IF( LDQ.LT.1 .OR. ( WANTZ .AND. LDQ.LT.N ) ) THEN
INFO = -12
ELSE
IF( VALEIG ) THEN
IF( N.GT.0 .AND. VU.LE.VL )
$ INFO = -14
ELSE IF( INDEIG ) THEN
IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
INFO = -15
ELSE IF ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
INFO = -16
END IF
END IF
END IF
IF( INFO.EQ.0) THEN
IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -21
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSBGVX', -INFO )
RETURN
END IF
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 )
$ RETURN
*
* Form a split Cholesky factorization of B.
*
CALL DPBSTF( UPLO, N, KB, BB, LDBB, INFO )
IF( INFO.NE.0 ) THEN
INFO = N + INFO
RETURN
END IF
*
* Transform problem to standard eigenvalue problem.
*
CALL DSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ,
$ WORK, IINFO )
*
* Reduce symmetric band matrix to tridiagonal form.
*
INDD = 1
INDE = INDD + N
INDWRK = INDE + N
IF( WANTZ ) THEN
VECT = 'U'
ELSE
VECT = 'N'
END IF
CALL DSBTRD( VECT, UPLO, N, KA, AB, LDAB, WORK( INDD ),
$ WORK( INDE ), Q, LDQ, WORK( INDWRK ), IINFO )
*
* If all eigenvalues are desired and ABSTOL is less than or equal
* to zero, then call DSTERF or SSTEQR. If this fails for some
* eigenvalue, then try DSTEBZ.
*
TEST = .FALSE.
IF( INDEIG ) THEN
IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
TEST = .TRUE.
END IF
END IF
IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN
CALL DCOPY( N, WORK( INDD ), 1, W, 1 )
INDEE = INDWRK + 2*N
CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
IF( .NOT.WANTZ ) THEN
CALL DSTERF( N, W, WORK( INDEE ), INFO )
ELSE
CALL DLACPY( 'A', N, N, Q, LDQ, Z, LDZ )
CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ,
$ WORK( INDWRK ), INFO )
IF( INFO.EQ.0 ) THEN
DO 10 I = 1, N
IFAIL( I ) = 0
10 CONTINUE
END IF
END IF
IF( INFO.EQ.0 ) THEN
M = N
GO TO 30
END IF
INFO = 0
END IF
*
* Otherwise, call DSTEBZ and, if eigenvectors are desired,
* call DSTEIN.
*
IF( WANTZ ) THEN
ORDER = 'B'
ELSE
ORDER = 'E'
END IF
INDIBL = 1
INDISP = INDIBL + N
INDIWO = INDISP + N
CALL DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL,
$ WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
$ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ),
$ IWORK( INDIWO ), INFO )
*
IF( WANTZ ) THEN
CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
$ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
$ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO )
*
* Apply transformation matrix used in reduction to tridiagonal
* form to eigenvectors returned by DSTEIN.
*
DO 20 J = 1, M
CALL DCOPY( N, Z( 1, J ), 1, WORK( 1 ), 1 )
CALL DGEMV( 'N', N, N, ONE, Q, LDQ, WORK, 1, ZERO,
$ Z( 1, J ), 1 )
20 CONTINUE
END IF
*
30 CONTINUE
*
* If eigenvalues are not in order, then sort them, along with
* eigenvectors.
*
IF( WANTZ ) THEN
DO 50 J = 1, M - 1
I = 0
TMP1 = W( J )
DO 40 JJ = J + 1, M
IF( W( JJ ).LT.TMP1 ) THEN
I = JJ
TMP1 = W( JJ )
END IF
40 CONTINUE
*
IF( I.NE.0 ) THEN
ITMP1 = IWORK( INDIBL+I-1 )
W( I ) = W( J )
IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
W( J ) = TMP1
IWORK( INDIBL+J-1 ) = ITMP1
CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
IF( INFO.NE.0 ) THEN
ITMP1 = IFAIL( I )
IFAIL( I ) = IFAIL( J )
IFAIL( J ) = ITMP1
END IF
END IF
50 CONTINUE
END IF
*
RETURN
*
* End of DSBGVX
*
END
SUBROUTINE DSBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ,
$ WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO, VECT
INTEGER INFO, KD, LDAB, LDQ, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AB( LDAB, * ), D( * ), E( * ), Q( LDQ, * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* DSBTRD reduces a real symmetric band matrix A to symmetric
* tridiagonal form T by an orthogonal similarity transformation:
* Q**T * A * Q = T.
*
* Arguments
* =========
*
* VECT (input) CHARACTER*1
* = 'N': do not form Q;
* = 'V': form Q;
* = 'U': update a matrix X, by forming X*Q.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
*
* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
* On entry, the upper or lower triangle of the symmetric band
* matrix A, stored in the first KD+1 rows of the array. The
* j-th column of A is stored in the j-th column of the array AB
* as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
* On exit, the diagonal elements of AB are overwritten by the
* diagonal elements of the tridiagonal matrix T; if KD > 0, the
* elements on the first superdiagonal (if UPLO = 'U') or the
* first subdiagonal (if UPLO = 'L') are overwritten by the
* off-diagonal elements of T; the rest of AB is overwritten by
* values generated during the reduction.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* D (output) DOUBLE PRECISION array, dimension (N)
* The diagonal elements of the tridiagonal matrix T.
*
* E (output) DOUBLE PRECISION array, dimension (N-1)
* The off-diagonal elements of the tridiagonal matrix T:
* E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.
*
* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
* On entry, if VECT = 'U', then Q must contain an N-by-N
* matrix X; if VECT = 'N' or 'V', then Q need not be set.
*
* On exit:
* if VECT = 'V', Q contains the N-by-N orthogonal matrix Q;
* if VECT = 'U', Q contains the product X*Q;
* if VECT = 'N', the array Q is not referenced.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q.
* LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.
*
* 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
* ===============
*
* Modified by Linda Kaufman, Bell Labs.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL INITQ, UPPER, WANTQ
INTEGER I, I2, IBL, INCA, INCX, IQAEND, IQB, IQEND, J,
$ J1, J1END, J1INC, J2, JEND, JIN, JINC, K, KD1,
$ KDM1, KDN, L, LAST, LEND, NQ, NR, NRT
DOUBLE PRECISION TEMP
* ..
* .. External Subroutines ..
EXTERNAL DLAR2V, DLARGV, DLARTG, DLARTV, DLASET, DROT,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INITQ = LSAME( VECT, 'V' )
WANTQ = INITQ .OR. LSAME( VECT, 'U' )
UPPER = LSAME( UPLO, 'U' )
KD1 = KD + 1
KDM1 = KD - 1
INCX = LDAB - 1
IQEND = 1
*
INFO = 0
IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'N' ) ) THEN
INFO = -1
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( KD.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.KD1 ) THEN
INFO = -6
ELSE IF( LDQ.LT.MAX( 1, N ) .AND. WANTQ ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSBTRD', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Initialize Q to the unit matrix, if needed
*
IF( INITQ )
$ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
*
* Wherever possible, plane rotations are generated and applied in
* vector operations of length NR over the index set J1:J2:KD1.
*
* The cosines and sines of the plane rotations are stored in the
* arrays D and WORK.
*
INCA = KD1*LDAB
KDN = MIN( N-1, KD )
IF( UPPER ) THEN
*
IF( KD.GT.1 ) THEN
*
* Reduce to tridiagonal form, working with upper triangle
*
NR = 0
J1 = KDN + 2
J2 = 1
*
DO 90 I = 1, N - 2
*
* Reduce i-th row of matrix to tridiagonal form
*
DO 80 K = KDN + 1, 2, -1
J1 = J1 + KDN
J2 = J2 + KDN
*
IF( NR.GT.0 ) THEN
*
* generate plane rotations to annihilate nonzero
* elements which have been created outside the band
*
CALL DLARGV( NR, AB( 1, J1-1 ), INCA, WORK( J1 ),
$ KD1, D( J1 ), KD1 )
*
* apply rotations from the right
*
*
* Dependent on the the number of diagonals either
* DLARTV or DROT is used
*
IF( NR.GE.2*KD-1 ) THEN
DO 10 L = 1, KD - 1
CALL DLARTV( NR, AB( L+1, J1-1 ), INCA,
$ AB( L, J1 ), INCA, D( J1 ),
$ WORK( J1 ), KD1 )
10 CONTINUE
*
ELSE
JEND = J1 + ( NR-1 )*KD1
DO 20 JINC = J1, JEND, KD1
CALL DROT( KDM1, AB( 2, JINC-1 ), 1,
$ AB( 1, JINC ), 1, D( JINC ),
$ WORK( JINC ) )
20 CONTINUE
END IF
END IF
*
*
IF( K.GT.2 ) THEN
IF( K.LE.N-I+1 ) THEN
*
* generate plane rotation to annihilate a(i,i+k-1)
* within the band
*
CALL DLARTG( AB( KD-K+3, I+K-2 ),
$ AB( KD-K+2, I+K-1 ), D( I+K-1 ),
$ WORK( I+K-1 ), TEMP )
AB( KD-K+3, I+K-2 ) = TEMP
*
* apply rotation from the right
*
CALL DROT( K-3, AB( KD-K+4, I+K-2 ), 1,
$ AB( KD-K+3, I+K-1 ), 1, D( I+K-1 ),
$ WORK( I+K-1 ) )
END IF
NR = NR + 1
J1 = J1 - KDN - 1
END IF
*
* apply plane rotations from both sides to diagonal
* blocks
*
IF( NR.GT.0 )
$ CALL DLAR2V( NR, AB( KD1, J1-1 ), AB( KD1, J1 ),
$ AB( KD, J1 ), INCA, D( J1 ),
$ WORK( J1 ), KD1 )
*
* apply plane rotations from the left
*
IF( NR.GT.0 ) THEN
IF( 2*KD-1.LT.NR ) THEN
*
* Dependent on the the number of diagonals either
* DLARTV or DROT is used
*
DO 30 L = 1, KD - 1
IF( J2+L.GT.N ) THEN
NRT = NR - 1
ELSE
NRT = NR
END IF
IF( NRT.GT.0 )
$ CALL DLARTV( NRT, AB( KD-L, J1+L ), INCA,
$ AB( KD-L+1, J1+L ), INCA,
$ D( J1 ), WORK( J1 ), KD1 )
30 CONTINUE
ELSE
J1END = J1 + KD1*( NR-2 )
IF( J1END.GE.J1 ) THEN
DO 40 JIN = J1, J1END, KD1
CALL DROT( KD-1, AB( KD-1, JIN+1 ), INCX,
$ AB( KD, JIN+1 ), INCX,
$ D( JIN ), WORK( JIN ) )
40 CONTINUE
END IF
LEND = MIN( KDM1, N-J2 )
LAST = J1END + KD1
IF( LEND.GT.0 )
$ CALL DROT( LEND, AB( KD-1, LAST+1 ), INCX,
$ AB( KD, LAST+1 ), INCX, D( LAST ),
$ WORK( LAST ) )
END IF
END IF
*
IF( WANTQ ) THEN
*
* accumulate product of plane rotations in Q
*
IF( INITQ ) THEN
*
* take advantage of the fact that Q was
* initially the Identity matrix
*
IQEND = MAX( IQEND, J2 )
I2 = MAX( 0, K-3 )
IQAEND = 1 + I*KD
IF( K.EQ.2 )
$ IQAEND = IQAEND + KD
IQAEND = MIN( IQAEND, IQEND )
DO 50 J = J1, J2, KD1
IBL = I - I2 / KDM1
I2 = I2 + 1
IQB = MAX( 1, J-IBL )
NQ = 1 + IQAEND - IQB
IQAEND = MIN( IQAEND+KD, IQEND )
CALL DROT( NQ, Q( IQB, J-1 ), 1, Q( IQB, J ),
$ 1, D( J ), WORK( J ) )
50 CONTINUE
ELSE
*
DO 60 J = J1, J2, KD1
CALL DROT( N, Q( 1, J-1 ), 1, Q( 1, J ), 1,
$ D( J ), WORK( J ) )
60 CONTINUE
END IF
*
END IF
*
IF( J2+KDN.GT.N ) THEN
*
* adjust J2 to keep within the bounds of the matrix
*
NR = NR - 1
J2 = J2 - KDN - 1
END IF
*
DO 70 J = J1, J2, KD1
*
* create nonzero element a(j-1,j+kd) outside the band
* and store it in WORK
*
WORK( J+KD ) = WORK( J )*AB( 1, J+KD )
AB( 1, J+KD ) = D( J )*AB( 1, J+KD )
70 CONTINUE
80 CONTINUE
90 CONTINUE
END IF
*
IF( KD.GT.0 ) THEN
*
* copy off-diagonal elements to E
*
DO 100 I = 1, N - 1
E( I ) = AB( KD, I+1 )
100 CONTINUE
ELSE
*
* set E to zero if original matrix was diagonal
*
DO 110 I = 1, N - 1
E( I ) = ZERO
110 CONTINUE
END IF
*
* copy diagonal elements to D
*
DO 120 I = 1, N
D( I ) = AB( KD1, I )
120 CONTINUE
*
ELSE
*
IF( KD.GT.1 ) THEN
*
* Reduce to tridiagonal form, working with lower triangle
*
NR = 0
J1 = KDN + 2
J2 = 1
*
DO 210 I = 1, N - 2
*
* Reduce i-th column of matrix to tridiagonal form
*
DO 200 K = KDN + 1, 2, -1
J1 = J1 + KDN
J2 = J2 + KDN
*
IF( NR.GT.0 ) THEN
*
* generate plane rotations to annihilate nonzero
* elements which have been created outside the band
*
CALL DLARGV( NR, AB( KD1, J1-KD1 ), INCA,
$ WORK( J1 ), KD1, D( J1 ), KD1 )
*
* apply plane rotations from one side
*
*
* Dependent on the the number of diagonals either
* DLARTV or DROT is used
*
IF( NR.GT.2*KD-1 ) THEN
DO 130 L = 1, KD - 1
CALL DLARTV( NR, AB( KD1-L, J1-KD1+L ), INCA,
$ AB( KD1-L+1, J1-KD1+L ), INCA,
$ D( J1 ), WORK( J1 ), KD1 )
130 CONTINUE
ELSE
JEND = J1 + KD1*( NR-1 )
DO 140 JINC = J1, JEND, KD1
CALL DROT( KDM1, AB( KD, JINC-KD ), INCX,
$ AB( KD1, JINC-KD ), INCX,
$ D( JINC ), WORK( JINC ) )
140 CONTINUE
END IF
*
END IF
*
IF( K.GT.2 ) THEN
IF( K.LE.N-I+1 ) THEN
*
* generate plane rotation to annihilate a(i+k-1,i)
* within the band
*
CALL DLARTG( AB( K-1, I ), AB( K, I ),
$ D( I+K-1 ), WORK( I+K-1 ), TEMP )
AB( K-1, I ) = TEMP
*
* apply rotation from the left
*
CALL DROT( K-3, AB( K-2, I+1 ), LDAB-1,
$ AB( K-1, I+1 ), LDAB-1, D( I+K-1 ),
$ WORK( I+K-1 ) )
END IF
NR = NR + 1
J1 = J1 - KDN - 1
END IF
*
* apply plane rotations from both sides to diagonal
* blocks
*
IF( NR.GT.0 )
$ CALL DLAR2V( NR, AB( 1, J1-1 ), AB( 1, J1 ),
$ AB( 2, J1-1 ), INCA, D( J1 ),
$ WORK( J1 ), KD1 )
*
* apply plane rotations from the right
*
*
* Dependent on the the number of diagonals either
* DLARTV or DROT is used
*
IF( NR.GT.0 ) THEN
IF( NR.GT.2*KD-1 ) THEN
DO 150 L = 1, KD - 1
IF( J2+L.GT.N ) THEN
NRT = NR - 1
ELSE
NRT = NR
END IF
IF( NRT.GT.0 )
$ CALL DLARTV( NRT, AB( L+2, J1-1 ), INCA,
$ AB( L+1, J1 ), INCA, D( J1 ),
$ WORK( J1 ), KD1 )
150 CONTINUE
ELSE
J1END = J1 + KD1*( NR-2 )
IF( J1END.GE.J1 ) THEN
DO 160 J1INC = J1, J1END, KD1
CALL DROT( KDM1, AB( 3, J1INC-1 ), 1,
$ AB( 2, J1INC ), 1, D( J1INC ),
$ WORK( J1INC ) )
160 CONTINUE
END IF
LEND = MIN( KDM1, N-J2 )
LAST = J1END + KD1
IF( LEND.GT.0 )
$ CALL DROT( LEND, AB( 3, LAST-1 ), 1,
$ AB( 2, LAST ), 1, D( LAST ),
$ WORK( LAST ) )
END IF
END IF
*
*
*
IF( WANTQ ) THEN
*
* accumulate product of plane rotations in Q
*
IF( INITQ ) THEN
*
* take advantage of the fact that Q was
* initially the Identity matrix
*
IQEND = MAX( IQEND, J2 )
I2 = MAX( 0, K-3 )
IQAEND = 1 + I*KD
IF( K.EQ.2 )
$ IQAEND = IQAEND + KD
IQAEND = MIN( IQAEND, IQEND )
DO 170 J = J1, J2, KD1
IBL = I - I2 / KDM1
I2 = I2 + 1
IQB = MAX( 1, J-IBL )
NQ = 1 + IQAEND - IQB
IQAEND = MIN( IQAEND+KD, IQEND )
CALL DROT( NQ, Q( IQB, J-1 ), 1, Q( IQB, J ),
$ 1, D( J ), WORK( J ) )
170 CONTINUE
ELSE
*
DO 180 J = J1, J2, KD1
CALL DROT( N, Q( 1, J-1 ), 1, Q( 1, J ), 1,
$ D( J ), WORK( J ) )
180 CONTINUE
END IF
END IF
*
IF( J2+KDN.GT.N ) THEN
*
* adjust J2 to keep within the bounds of the matrix
*
NR = NR - 1
J2 = J2 - KDN - 1
END IF
*
DO 190 J = J1, J2, KD1
*
* create nonzero element a(j+kd,j-1) outside the
* band and store it in WORK
*
WORK( J+KD ) = WORK( J )*AB( KD1, J )
AB( KD1, J ) = D( J )*AB( KD1, J )
190 CONTINUE
200 CONTINUE
210 CONTINUE
END IF
*
IF( KD.GT.0 ) THEN
*
* copy off-diagonal elements to E
*
DO 220 I = 1, N - 1
E( I ) = AB( 2, I )
220 CONTINUE
ELSE
*
* set E to zero if original matrix was diagonal
*
DO 230 I = 1, N - 1
E( I ) = ZERO
230 CONTINUE
END IF
*
* copy diagonal elements to D
*
DO 240 I = 1, N
D( I ) = AB( 1, I )
240 CONTINUE
END IF
*
RETURN
*
* End of DSBTRD
*
END
SUBROUTINE DSGESV( N, NRHS, A, LDA, IPIV, B, LDB, X, LDX, WORK,
+ SWORK, ITER, INFO)
*
* -- LAPACK PROTOTYPE driver routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* February 2007
*
* ..
* .. WARNING: PROTOTYPE ..
* This is an LAPACK PROTOTYPE routine which means that the
* interface of this routine is likely to be changed in the future
* based on community feedback.
*
* ..
* .. Scalar Arguments ..
INTEGER INFO,ITER,LDA,LDB,LDX,N,NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV(*)
REAL SWORK(*)
DOUBLE PRECISION A(LDA,*),B(LDB,*),WORK(N,*),X(LDX,*)
* ..
*
* Purpose
* =======
*
* DSGESV computes the solution to a real system of linear equations
* A * X = B,
* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
*
* DSGESV first attempts to factorize the matrix in SINGLE PRECISION
* and use this factorization within an iterative refinement procedure to
* produce a solution with DOUBLE PRECISION normwise backward error
* quality (see below). If the approach fails the method switches to a
* DOUBLE PRECISION factorization and solve.
*
* The iterative refinement is not going to be a winning strategy if
* the ratio SINGLE PRECISION performance over DOUBLE PRECISION performance
* is too small. A reasonable strategy should take the number of right-hand
* sides and the size of the matrix into account. This might be done with a
* call to ILAENV in the future. Up to now, we always try iterative refinement.
*
* The iterative refinement process is stopped if
* ITER > ITERMAX
* or for all the RHS we have:
* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX
* where
* o ITER is the number of the current iteration in the iterative
* refinement process
* o RNRM is the infinity-norm of the residual
* o XNRM is the infinity-norm of the solution
* o ANRM is the infinity-operator-norm of the matrix A
* o EPS is the machine epsilon returned by DLAMCH('Epsilon')
* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00 respectively.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of linear equations, i.e., 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 or input/ouptut) DOUBLE PRECISION array,
* dimension (LDA,N)
* On entry, the N-by-N coefficient matrix A.
* On exit, if iterative refinement has been successfully used
* (INFO.EQ.0 and ITER.GE.0, see description below), then A is
* unchanged, if double precision factorization has been used
* (INFO.EQ.0 and ITER.LT.0, see description below), then the
* array A contains 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,N).
*
* IPIV (output) INTEGER array, dimension (N)
* The pivot indices that define the permutation matrix P;
* row i of the matrix was interchanged with row IPIV(i).
* Corresponds either to the single precision factorization
* (if INFO.EQ.0 and ITER.GE.0) or the double precision
* factorization (if INFO.EQ.0 and ITER.LT.0).
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The N-by-NRHS matrix of right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
* If INFO = 0, the N-by-NRHS solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (N*NRHS)
* This array is used to hold the residual vectors.
*
* SWORK (workspace) REAL array, dimension (N*(N+NRHS))
* This array is used to use the single precision matrix and the
* right-hand sides or solutions in single precision.
*
* ITER (output) INTEGER
* < 0: iterative refinement has failed, double precision
* factorization has been performed
* -1 : taking into account machine parameters, N, NRHS, it
* is a priori not worth working in SINGLE PRECISION
* -2 : overflow of an entry when moving from double to
* SINGLE PRECISION
* -3 : failure of SGETRF
* -31: stop the iterative refinement after the 30th
* iterations
* > 0: iterative refinement has been sucessfully used.
* Returns the number of iterations
*
* 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) computed in DOUBLE PRECISION is
* exactly zero. The factorization has been completed,
* but the factor U is exactly singular, so the solution
* could not be computed.
*
* =========
*
* .. Parameters ..
DOUBLE PRECISION NEGONE,ONE
PARAMETER (NEGONE=-1.0D+0,ONE=1.0D+0)
*
* .. Local Scalars ..
LOGICAL DOITREF
INTEGER I,IITER,ITERMAX,OK,PTSA,PTSX
DOUBLE PRECISION ANRM,BWDMAX,CTE,EPS,RNRM,XNRM
*
* .. External Subroutines ..
EXTERNAL DAXPY,DGEMM,DLACPY,DLAG2S,SLAG2D,
+ SGETRF,SGETRS,XERBLA
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH,DLANGE
EXTERNAL IDAMAX,DLAMCH,DLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS,DBLE,MAX,SQRT
* ..
* .. Executable Statements ..
*
ITERMAX = 30
BWDMAX = 1.0E+00
DOITREF = .TRUE.
*
OK = 0
INFO = 0
ITER = 0
*
* Test the input parameters.
*
IF (N.LT.0) THEN
INFO = -1
ELSE IF (NRHS.LT.0) THEN
INFO = -2
ELSE IF (LDA.LT.MAX(1,N)) THEN
INFO = -4
ELSE IF (LDB.LT.MAX(1,N)) THEN
INFO = -7
ELSE IF (LDX.LT.MAX(1,N)) THEN
INFO = -9
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('DSGESV',-INFO)
RETURN
END IF
*
* Quick return if (N.EQ.0).
*
IF (N.EQ.0) RETURN
*
* Skip single precision iterative refinement if a priori slower
* than double precision factorization.
*
IF (.NOT.DOITREF) THEN
ITER = -1
GO TO 40
END IF
*
* Compute some constants.
*
ANRM = DLANGE('I',N,N,A,LDA,WORK)
EPS = DLAMCH('Epsilon')
CTE = ANRM*EPS*SQRT(DBLE(N))*BWDMAX
*
* Set the pointers PTSA, PTSX for referencing SA and SX in SWORK.
*
PTSA = 1
PTSX = PTSA + N*N
*
* Convert B from double precision to single precision and store the
* result in SX.
*
CALL DLAG2S(N,NRHS,B,LDB,SWORK(PTSX),N,INFO)
*
IF (INFO.NE.0) THEN
ITER = -2
GO TO 40
END IF
*
* Convert A from double precision to single precision and store the
* result in SA.
*
CALL DLAG2S(N,N,A,LDA,SWORK(PTSA),N,INFO)
*
IF (INFO.NE.0) THEN
ITER = -2
GO TO 40
END IF
*
* Compute the LU factorization of SA.
*
CALL SGETRF(N,N,SWORK(PTSA),N,IPIV,INFO)
*
IF (INFO.NE.0) THEN
ITER = -3
GO TO 40
END IF
*
* Solve the system SA*SX = SB.
*
CALL SGETRS('No transpose',N,NRHS,SWORK(PTSA),N,IPIV,
+ SWORK(PTSX),N,INFO)
*
* Convert SX back to double precision
*
CALL SLAG2D(N,NRHS,SWORK(PTSX),N,X,LDX,INFO)
*
* Compute R = B - AX (R is WORK).
*
CALL DLACPY('All',N,NRHS,B,LDB,WORK,N)
*
CALL DGEMM('No Transpose','No Transpose',N,NRHS,N,NEGONE,A,LDA,X,
+ LDX,ONE,WORK,N)
*
* Check whether the NRHS normwised backward errors satisfy the
* stopping criterion. If yes, set ITER=0 and return.
*
DO I = 1,NRHS
XNRM = ABS(X(IDAMAX(N,X(1,I),1),I))
RNRM = ABS(WORK(IDAMAX(N,WORK(1,I),1),I))
IF (RNRM.GT.XNRM*CTE) GOTO 10
END DO
*
* If we are here, the NRHS normwised backward errors satisfy the
* stopping criterion. We are good to exit.
*
ITER = 0
RETURN
*
10 CONTINUE
*
DO 30 IITER = 1,ITERMAX
*
* Convert R (in WORK) from double precision to single precision
* and store the result in SX.
*
CALL DLAG2S(N,NRHS,WORK,N,SWORK(PTSX),N,INFO)
*
IF (INFO.NE.0) THEN
ITER = -2
GO TO 40
END IF
*
* Solve the system SA*SX = SR.
*
CALL SGETRS('No transpose',N,NRHS,SWORK(PTSA),N,IPIV,
+ SWORK(PTSX),N,INFO)
*
* Convert SX back to double precision and update the current
* iterate.
*
CALL SLAG2D(N,NRHS,SWORK(PTSX),N,WORK,N,INFO)
*
CALL DAXPY(N*NRHS,ONE,WORK,1,X,1)
*
* Compute R = B - AX (R is WORK).
*
CALL DLACPY('All',N,NRHS,B,LDB,WORK,N)
*
CALL DGEMM('No Transpose','No Transpose',N,NRHS,N,NEGONE,A,
+ LDA,X,LDX,ONE,WORK,N)
*
* Check whether the NRHS normwised backward errors satisfy the
* stopping criterion. If yes, set ITER=IITER>0 and return.
*
DO I = 1,NRHS
XNRM = ABS(X(IDAMAX(N,X(1,I),1),I))
RNRM = ABS(WORK(IDAMAX(N,WORK(1,I),1),I))
IF (RNRM.GT.XNRM*CTE) GOTO 20
END DO
*
* If we are here, the NRHS normwised backward errors satisfy the
* stopping criterion, we are good to exit.
*
ITER = IITER
*
RETURN
*
20 CONTINUE
*
30 CONTINUE
*
* If we are at this place of the code, this is because we have
* performed ITER=ITERMAX iterations and never satisified the stopping
* criterion, set up the ITER flag accordingly and follow up on double
* precision routine.
*
ITER = -ITERMAX - 1
*
40 CONTINUE
*
* Single-precision iterative refinement failed to converge to a
* satisfactory solution, so we resort to double precision.
*
CALL DGETRF(N,N,A,LDA,IPIV,INFO)
*
CALL DLACPY('All',N,NRHS,B,LDB,X,LDX)
*
IF (INFO.EQ.0) THEN
CALL DGETRS('No transpose',N,NRHS,A,LDA,IPIV,X,LDX,INFO)
END IF
*
RETURN
*
* End of DSGESV.
*
END
SUBROUTINE DSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, IWORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, N
DOUBLE PRECISION ANORM, RCOND
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), IWORK( * )
DOUBLE PRECISION AP( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DSPCON estimates the reciprocal of the condition number (in the
* 1-norm) of a real symmetric packed matrix A using the factorization
* A = U*D*U**T or A = L*D*L**T computed by DSPTRF.
*
* An estimate is obtained for norm(inv(A)), and the reciprocal of the
* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the details of the factorization are stored
* as an upper or lower triangular matrix.
* = 'U': Upper triangular, form is A = U*D*U**T;
* = 'L': Lower triangular, form is A = L*D*L**T.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The block diagonal matrix D and the multipliers used to
* obtain the factor U or L as computed by DSPTRF, stored as a
* packed triangular matrix.
*
* IPIV (input) INTEGER array, dimension (N)
* Details of the interchanges and the block structure of D
* as determined by DSPTRF.
*
* ANORM (input) DOUBLE PRECISION
* The 1-norm of the original matrix A.
*
* RCOND (output) DOUBLE PRECISION
* The reciprocal of the condition number of the matrix A,
* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
* estimate of the 1-norm of inv(A) computed in this routine.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, IP, KASE
DOUBLE PRECISION AINVNM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DLACN2, DSPTRS, XERBLA
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ANORM.LT.ZERO ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSPCON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
RCOND = ZERO
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
ELSE IF( ANORM.LE.ZERO ) THEN
RETURN
END IF
*
* Check that the diagonal matrix D is nonsingular.
*
IF( UPPER ) THEN
*
* Upper triangular storage: examine D from bottom to top
*
IP = N*( N+1 ) / 2
DO 10 I = N, 1, -1
IF( IPIV( I ).GT.0 .AND. AP( IP ).EQ.ZERO )
$ RETURN
IP = IP - I
10 CONTINUE
ELSE
*
* Lower triangular storage: examine D from top to bottom.
*
IP = 1
DO 20 I = 1, N
IF( IPIV( I ).GT.0 .AND. AP( IP ).EQ.ZERO )
$ RETURN
IP = IP + N - I + 1
20 CONTINUE
END IF
*
* Estimate the 1-norm of the inverse.
*
KASE = 0
30 CONTINUE
CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
*
* Multiply by inv(L*D*L') or inv(U*D*U').
*
CALL DSPTRS( UPLO, N, 1, AP, IPIV, WORK, N, INFO )
GO TO 30
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / AINVNM ) / ANORM
*
RETURN
*
* End of DSPCON
*
END
SUBROUTINE DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, LDZ, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DSPEV computes all the eigenvalues and, optionally, eigenvectors of a
* real symmetric matrix A in packed storage.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* A, packed columnwise in a linear array. The j-th column of A
* is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
*
* On exit, AP is overwritten by values generated during the
* reduction to tridiagonal form. If UPLO = 'U', the diagonal
* and first superdiagonal of the tridiagonal matrix T overwrite
* the corresponding elements of A, and if UPLO = 'L', the
* diagonal and first subdiagonal of T overwrite the
* corresponding elements of A.
*
* W (output) DOUBLE PRECISION array, dimension (N)
* If INFO = 0, the eigenvalues in ascending order.
*
* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
* eigenvectors of the matrix A, with the i-th column of Z
* holding the eigenvector associated with W(i).
* If JOBZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = i, the algorithm failed to converge; i
* off-diagonal elements of an intermediate tridiagonal
* form did not converge to zero.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL WANTZ
INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE
DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
$ SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANSP
EXTERNAL LSAME, DLAMCH, DLANSP
* ..
* .. External Subroutines ..
EXTERNAL DOPGTR, DSCAL, DSPTRD, DSTEQR, DSTERF, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) )
$ THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -7
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSPEV ', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
W( 1 ) = AP( 1 )
IF( WANTZ )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = SQRT( BIGNUM )
*
* Scale matrix to allowable range, if necessary.
*
ANRM = DLANSP( 'M', UPLO, N, AP, WORK )
ISCALE = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 ) THEN
CALL DSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
END IF
*
* Call DSPTRD to reduce symmetric packed matrix to tridiagonal form.
*
INDE = 1
INDTAU = INDE + N
CALL DSPTRD( UPLO, N, AP, W, WORK( INDE ), WORK( INDTAU ), IINFO )
*
* For eigenvalues only, call DSTERF. For eigenvectors, first call
* DOPGTR to generate the orthogonal matrix, then call DSTEQR.
*
IF( .NOT.WANTZ ) THEN
CALL DSTERF( N, W, WORK( INDE ), INFO )
ELSE
INDWRK = INDTAU + N
CALL DOPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ,
$ WORK( INDWRK ), IINFO )
CALL DSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDTAU ),
$ INFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = N
ELSE
IMAX = INFO - 1
END IF
CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
RETURN
*
* End of DSPEV
*
END
SUBROUTINE DSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK,
$ IWORK, LIWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, LDZ, LIWORK, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DSPEVD computes all the eigenvalues and, optionally, eigenvectors
* of a real symmetric matrix A in packed storage. If eigenvectors are
* desired, it uses a divide and conquer algorithm.
*
* The divide and conquer algorithm makes very mild assumptions about
* floating point arithmetic. It will work on machines with a guard
* digit in add/subtract, or on those binary machines without guard
* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
* Cray-2. It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* A, packed columnwise in a linear array. The j-th column of A
* is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
*
* On exit, AP is overwritten by values generated during the
* reduction to tridiagonal form. If UPLO = 'U', the diagonal
* and first superdiagonal of the tridiagonal matrix T overwrite
* the corresponding elements of A, and if UPLO = 'L', the
* diagonal and first subdiagonal of T overwrite the
* corresponding elements of A.
*
* W (output) DOUBLE PRECISION array, dimension (N)
* If INFO = 0, the eigenvalues in ascending order.
*
* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
* eigenvectors of the matrix A, with the i-th column of Z
* holding the eigenvector associated with W(i).
* If JOBZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace/output) DOUBLE PRECISION array,
* dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns the required LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* If N <= 1, LWORK must be at least 1.
* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N.
* If JOBZ = 'V' and N > 1, LWORK must be at least
* 1 + 6*N + N**2.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the required sizes of the WORK and IWORK
* arrays, returns these values as the first entries of the WORK
* and IWORK arrays, and no error message related to LWORK or
* LIWORK is issued by XERBLA.
*
* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK.
* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.
* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the required sizes of the WORK and
* IWORK arrays, returns these values as the first entries of
* the WORK and IWORK arrays, and no error message related to
* LWORK or LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = i, the algorithm failed to converge; i
* off-diagonal elements of an intermediate tridiagonal
* form did not converge to zero.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, WANTZ
INTEGER IINFO, INDE, INDTAU, INDWRK, ISCALE, LIWMIN,
$ LLWORK, LWMIN
DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
$ SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANSP
EXTERNAL LSAME, DLAMCH, DLANSP
* ..
* .. External Subroutines ..
EXTERNAL DOPMTR, DSCAL, DSPTRD, DSTEDC, DSTERF, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) )
$ THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -7
END IF
*
IF( INFO.EQ.0 ) THEN
IF( N.LE.1 ) THEN
LIWMIN = 1
LWMIN = 1
ELSE
IF( WANTZ ) THEN
LIWMIN = 3 + 5*N
LWMIN = 1 + 6*N + N**2
ELSE
LIWMIN = 1
LWMIN = 2*N
END IF
END IF
IWORK( 1 ) = LIWMIN
WORK( 1 ) = LWMIN
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -9
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -11
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSPEVD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
W( 1 ) = AP( 1 )
IF( WANTZ )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = SQRT( BIGNUM )
*
* Scale matrix to allowable range, if necessary.
*
ANRM = DLANSP( 'M', UPLO, N, AP, WORK )
ISCALE = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 ) THEN
CALL DSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
END IF
*
* Call DSPTRD to reduce symmetric packed matrix to tridiagonal form.
*
INDE = 1
INDTAU = INDE + N
CALL DSPTRD( UPLO, N, AP, W, WORK( INDE ), WORK( INDTAU ), IINFO )
*
* For eigenvalues only, call DSTERF. For eigenvectors, first call
* DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the
* tridiagonal matrix, then call DOPMTR to multiply it by the
* Householder transformations represented in AP.
*
IF( .NOT.WANTZ ) THEN
CALL DSTERF( N, W, WORK( INDE ), INFO )
ELSE
INDWRK = INDTAU + N
LLWORK = LWORK - INDWRK + 1
CALL DSTEDC( 'I', N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ),
$ LLWORK, IWORK, LIWORK, INFO )
CALL DOPMTR( 'L', UPLO, 'N', N, N, AP, WORK( INDTAU ), Z, LDZ,
$ WORK( INDWRK ), IINFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( ISCALE.EQ.1 )
$ CALL DSCAL( N, ONE / SIGMA, W, 1 )
*
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
RETURN
*
* End of DSPEVD
*
END
SUBROUTINE DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU,
$ ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL,
$ INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE, UPLO
INTEGER IL, INFO, IU, LDZ, M, N
DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER IFAIL( * ), IWORK( * )
DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DSPEVX computes selected eigenvalues and, optionally, eigenvectors
* of a real symmetric matrix A in packed storage. Eigenvalues/vectors
* can be selected by specifying either a range of values or a range of
* indices for the desired eigenvalues.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* RANGE (input) CHARACTER*1
* = 'A': all eigenvalues will be found;
* = 'V': all eigenvalues in the half-open interval (VL,VU]
* will be found;
* = 'I': the IL-th through IU-th eigenvalues will be found.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* A, packed columnwise in a linear array. The j-th column of A
* is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
*
* On exit, AP is overwritten by values generated during the
* reduction to tridiagonal form. If UPLO = 'U', the diagonal
* and first superdiagonal of the tridiagonal matrix T overwrite
* the corresponding elements of A, and if UPLO = 'L', the
* diagonal and first subdiagonal of T overwrite the
* corresponding elements of A.
*
* VL (input) DOUBLE PRECISION
* VU (input) DOUBLE PRECISION
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* ABSTOL (input) DOUBLE PRECISION
* The absolute error tolerance for the eigenvalues.
* An approximate eigenvalue is accepted as converged
* when it is determined to lie in an interval [a,b]
* of width less than or equal to
*
* ABSTOL + EPS * max( |a|,|b| ) ,
*
* where EPS is the machine precision. If ABSTOL is less than
* or equal to zero, then EPS*|T| will be used in its place,
* where |T| is the 1-norm of the tridiagonal matrix obtained
* by reducing AP to tridiagonal form.
*
* Eigenvalues will be computed most accurately when ABSTOL is
* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
* If this routine returns with INFO>0, indicating that some
* eigenvectors did not converge, try setting ABSTOL to
* 2*DLAMCH('S').
*
* See "Computing Small Singular Values of Bidiagonal Matrices
* with Guaranteed High Relative Accuracy," by Demmel and
* Kahan, LAPACK Working Note #3.
*
* M (output) INTEGER
* The total number of eigenvalues found. 0 <= M <= N.
* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*
* W (output) DOUBLE PRECISION array, dimension (N)
* If INFO = 0, the selected eigenvalues in ascending order.
*
* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
* contain the orthonormal eigenvectors of the matrix A
* corresponding to the selected eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* If an eigenvector fails to converge, then that column of Z
* contains the latest approximation to the eigenvector, and the
* index of the eigenvector is returned in IFAIL.
* If JOBZ = 'N', then Z is not referenced.
* Note: the user must ensure that at least max(1,M) columns are
* supplied in the array Z; if RANGE = 'V', the exact value of M
* is not known in advance and an upper bound must be used.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (8*N)
*
* IWORK (workspace) INTEGER array, dimension (5*N)
*
* IFAIL (output) INTEGER array, dimension (N)
* If JOBZ = 'V', then if INFO = 0, the first M elements of
* IFAIL are zero. If INFO > 0, then IFAIL contains the
* indices of the eigenvectors that failed to converge.
* If JOBZ = 'N', then IFAIL is not referenced.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, then i eigenvectors failed to converge.
* Their indices are stored in array IFAIL.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, TEST, VALEIG, WANTZ
CHARACTER ORDER
INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
$ INDISP, INDIWO, INDTAU, INDWRK, ISCALE, ITMP1,
$ J, JJ, NSPLIT
DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
$ SIGMA, SMLNUM, TMP1, VLL, VUU
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANSP
EXTERNAL LSAME, DLAMCH, DLANSP
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DOPGTR, DOPMTR, DSCAL, DSPTRD, DSTEBZ,
$ DSTEIN, DSTEQR, DSTERF, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
INFO = -2
ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) )
$ THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE
IF( VALEIG ) THEN
IF( N.GT.0 .AND. VU.LE.VL )
$ INFO = -7
ELSE IF( INDEIG ) THEN
IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
INFO = -9
END IF
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) )
$ INFO = -14
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSPEVX', -INFO )
RETURN
END IF
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( ALLEIG .OR. INDEIG ) THEN
M = 1
W( 1 ) = AP( 1 )
ELSE
IF( VL.LT.AP( 1 ) .AND. VU.GE.AP( 1 ) ) THEN
M = 1
W( 1 ) = AP( 1 )
END IF
END IF
IF( WANTZ )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
*
* Scale matrix to allowable range, if necessary.
*
ISCALE = 0
ABSTLL = ABSTOL
IF( VALEIG ) THEN
VLL = VL
VUU = VU
ELSE
VLL = ZERO
VUU = ZERO
END IF
ANRM = DLANSP( 'M', UPLO, N, AP, WORK )
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 ) THEN
CALL DSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
IF( ABSTOL.GT.0 )
$ ABSTLL = ABSTOL*SIGMA
IF( VALEIG ) THEN
VLL = VL*SIGMA
VUU = VU*SIGMA
END IF
END IF
*
* Call DSPTRD to reduce symmetric packed matrix to tridiagonal form.
*
INDTAU = 1
INDE = INDTAU + N
INDD = INDE + N
INDWRK = INDD + N
CALL DSPTRD( UPLO, N, AP, WORK( INDD ), WORK( INDE ),
$ WORK( INDTAU ), IINFO )
*
* If all eigenvalues are desired and ABSTOL is less than or equal
* to zero, then call DSTERF or DOPGTR and SSTEQR. If this fails
* for some eigenvalue, then try DSTEBZ.
*
TEST = .FALSE.
IF (INDEIG) THEN
IF (IL.EQ.1 .AND. IU.EQ.N) THEN
TEST = .TRUE.
END IF
END IF
IF ((ALLEIG .OR. TEST) .AND. (ABSTOL.LE.ZERO)) THEN
CALL DCOPY( N, WORK( INDD ), 1, W, 1 )
INDEE = INDWRK + 2*N
IF( .NOT.WANTZ ) THEN
CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
CALL DSTERF( N, W, WORK( INDEE ), INFO )
ELSE
CALL DOPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ,
$ WORK( INDWRK ), IINFO )
CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ,
$ WORK( INDWRK ), INFO )
IF( INFO.EQ.0 ) THEN
DO 10 I = 1, N
IFAIL( I ) = 0
10 CONTINUE
END IF
END IF
IF( INFO.EQ.0 ) THEN
M = N
GO TO 20
END IF
INFO = 0
END IF
*
* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN.
*
IF( WANTZ ) THEN
ORDER = 'B'
ELSE
ORDER = 'E'
END IF
INDIBL = 1
INDISP = INDIBL + N
INDIWO = INDISP + N
CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
$ WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
$ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ),
$ IWORK( INDIWO ), INFO )
*
IF( WANTZ ) THEN
CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
$ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
$ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO )
*
* Apply orthogonal matrix used in reduction to tridiagonal
* form to eigenvectors returned by DSTEIN.
*
CALL DOPMTR( 'L', UPLO, 'N', N, M, AP, WORK( INDTAU ), Z, LDZ,
$ WORK( INDWRK ), INFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
20 CONTINUE
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = M
ELSE
IMAX = INFO - 1
END IF
CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
* If eigenvalues are not in order, then sort them, along with
* eigenvectors.
*
IF( WANTZ ) THEN
DO 40 J = 1, M - 1
I = 0
TMP1 = W( J )
DO 30 JJ = J + 1, M
IF( W( JJ ).LT.TMP1 ) THEN
I = JJ
TMP1 = W( JJ )
END IF
30 CONTINUE
*
IF( I.NE.0 ) THEN
ITMP1 = IWORK( INDIBL+I-1 )
W( I ) = W( J )
IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
W( J ) = TMP1
IWORK( INDIBL+J-1 ) = ITMP1
CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
IF( INFO.NE.0 ) THEN
ITMP1 = IFAIL( I )
IFAIL( I ) = IFAIL( J )
IFAIL( J ) = ITMP1
END IF
END IF
40 CONTINUE
END IF
*
RETURN
*
* End of DSPEVX
*
END
SUBROUTINE DSPGST( ITYPE, UPLO, N, AP, BP, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, ITYPE, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP( * ), BP( * )
* ..
*
* Purpose
* =======
*
* DSPGST reduces a real symmetric-definite generalized eigenproblem
* to standard form, using packed storage.
*
* If ITYPE = 1, the problem is A*x = lambda*B*x,
* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)
*
* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.
*
* B must have been previously factorized as U**T*U or L*L**T by DPPTRF.
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);
* = 2 or 3: compute U*A*U**T or L**T*A*L.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored and B is factored as
* U**T*U;
* = 'L': Lower triangle of A is stored and B is factored as
* L*L**T.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* A, packed columnwise in a linear array. The j-th column of A
* is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
*
* On exit, if INFO = 0, the transformed matrix, stored in the
* same format as A.
*
* BP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The triangular factor from the Cholesky factorization of B,
* stored in the same format as A, as returned by DPPTRF.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, HALF
PARAMETER ( ONE = 1.0D0, HALF = 0.5D0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, J1, J1J1, JJ, K, K1, K1K1, KK
DOUBLE PRECISION AJJ, AKK, BJJ, BKK, CT
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DSCAL, DSPMV, DSPR2, DTPMV, DTPSV,
$ XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DDOT
EXTERNAL LSAME, DDOT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
INFO = -1
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSPGST', -INFO )
RETURN
END IF
*
IF( ITYPE.EQ.1 ) THEN
IF( UPPER ) THEN
*
* Compute inv(U')*A*inv(U)
*
* J1 and JJ are the indices of A(1,j) and A(j,j)
*
JJ = 0
DO 10 J = 1, N
J1 = JJ + 1
JJ = JJ + J
*
* Compute the j-th column of the upper triangle of A
*
BJJ = BP( JJ )
CALL DTPSV( UPLO, 'Transpose', 'Nonunit', J, BP,
$ AP( J1 ), 1 )
CALL DSPMV( UPLO, J-1, -ONE, AP, BP( J1 ), 1, ONE,
$ AP( J1 ), 1 )
CALL DSCAL( J-1, ONE / BJJ, AP( J1 ), 1 )
AP( JJ ) = ( AP( JJ )-DDOT( J-1, AP( J1 ), 1, BP( J1 ),
$ 1 ) ) / BJJ
10 CONTINUE
ELSE
*
* Compute inv(L)*A*inv(L')
*
* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1)
*
KK = 1
DO 20 K = 1, N
K1K1 = KK + N - K + 1
*
* Update the lower triangle of A(k:n,k:n)
*
AKK = AP( KK )
BKK = BP( KK )
AKK = AKK / BKK**2
AP( KK ) = AKK
IF( K.LT.N ) THEN
CALL DSCAL( N-K, ONE / BKK, AP( KK+1 ), 1 )
CT = -HALF*AKK
CALL DAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 )
CALL DSPR2( UPLO, N-K, -ONE, AP( KK+1 ), 1,
$ BP( KK+1 ), 1, AP( K1K1 ) )
CALL DAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 )
CALL DTPSV( UPLO, 'No transpose', 'Non-unit', N-K,
$ BP( K1K1 ), AP( KK+1 ), 1 )
END IF
KK = K1K1
20 CONTINUE
END IF
ELSE
IF( UPPER ) THEN
*
* Compute U*A*U'
*
* K1 and KK are the indices of A(1,k) and A(k,k)
*
KK = 0
DO 30 K = 1, N
K1 = KK + 1
KK = KK + K
*
* Update the upper triangle of A(1:k,1:k)
*
AKK = AP( KK )
BKK = BP( KK )
CALL DTPMV( UPLO, 'No transpose', 'Non-unit', K-1, BP,
$ AP( K1 ), 1 )
CT = HALF*AKK
CALL DAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 )
CALL DSPR2( UPLO, K-1, ONE, AP( K1 ), 1, BP( K1 ), 1,
$ AP )
CALL DAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 )
CALL DSCAL( K-1, BKK, AP( K1 ), 1 )
AP( KK ) = AKK*BKK**2
30 CONTINUE
ELSE
*
* Compute L'*A*L
*
* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1)
*
JJ = 1
DO 40 J = 1, N
J1J1 = JJ + N - J + 1
*
* Compute the j-th column of the lower triangle of A
*
AJJ = AP( JJ )
BJJ = BP( JJ )
AP( JJ ) = AJJ*BJJ + DDOT( N-J, AP( JJ+1 ), 1,
$ BP( JJ+1 ), 1 )
CALL DSCAL( N-J, BJJ, AP( JJ+1 ), 1 )
CALL DSPMV( UPLO, N-J, ONE, AP( J1J1 ), BP( JJ+1 ), 1,
$ ONE, AP( JJ+1 ), 1 )
CALL DTPMV( UPLO, 'Transpose', 'Non-unit', N-J+1,
$ BP( JJ ), AP( JJ ), 1 )
JJ = J1J1
40 CONTINUE
END IF
END IF
RETURN
*
* End of DSPGST
*
END
SUBROUTINE DSPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK,
$ INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, ITYPE, LDZ, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP( * ), BP( * ), W( * ), WORK( * ),
$ Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DSPGV computes all the eigenvalues and, optionally, the eigenvectors
* of a real generalized symmetric-definite eigenproblem, of the form
* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
* Here A and B are assumed to be symmetric, stored in packed format,
* and B is also positive definite.
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* Specifies the problem type to be solved:
* = 1: A*x = (lambda)*B*x
* = 2: A*B*x = (lambda)*x
* = 3: B*A*x = (lambda)*x
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangles of A and B are stored;
* = 'L': Lower triangles of A and B are stored.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* AP (input/output) DOUBLE PRECISION array, dimension
* (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* A, packed columnwise in a linear array. The j-th column of A
* is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
*
* On exit, the contents of AP are destroyed.
*
* BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* B, packed columnwise in a linear array. The j-th column of B
* is stored in the array BP as follows:
* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
*
* On exit, the triangular factor U or L from the Cholesky
* factorization B = U**T*U or B = L*L**T, in the same storage
* format as B.
*
* W (output) DOUBLE PRECISION array, dimension (N)
* If INFO = 0, the eigenvalues in ascending order.
*
* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
* eigenvectors. The eigenvectors are normalized as follows:
* if ITYPE = 1 or 2, Z**T*B*Z = I;
* if ITYPE = 3, Z**T*inv(B)*Z = I.
* If JOBZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: DPPTRF or DSPEV returned an error code:
* <= N: if INFO = i, DSPEV failed to converge;
* i off-diagonal elements of an intermediate
* tridiagonal form did not converge to zero.
* > N: if INFO = n + i, for 1 <= i <= n, then the leading
* minor of order i of B is not positive definite.
* The factorization of B could not be completed and
* no eigenvalues or eigenvectors were computed.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL UPPER, WANTZ
CHARACTER TRANS
INTEGER J, NEIG
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DPPTRF, DSPEV, DSPGST, DTPMV, DTPSV, XERBLA
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
UPPER = LSAME( UPLO, 'U' )
*
INFO = 0
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
INFO = -1
ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -2
ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSPGV ', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Form a Cholesky factorization of B.
*
CALL DPPTRF( UPLO, N, BP, INFO )
IF( INFO.NE.0 ) THEN
INFO = N + INFO
RETURN
END IF
*
* Transform problem to standard eigenvalue problem and solve.
*
CALL DSPGST( ITYPE, UPLO, N, AP, BP, INFO )
CALL DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO )
*
IF( WANTZ ) THEN
*
* Backtransform eigenvectors to the original problem.
*
NEIG = N
IF( INFO.GT.0 )
$ NEIG = INFO - 1
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
*
* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
*
IF( UPPER ) THEN
TRANS = 'N'
ELSE
TRANS = 'T'
END IF
*
DO 10 J = 1, NEIG
CALL DTPSV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
$ 1 )
10 CONTINUE
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* For B*A*x=(lambda)*x;
* backtransform eigenvectors: x = L*y or U'*y
*
IF( UPPER ) THEN
TRANS = 'T'
ELSE
TRANS = 'N'
END IF
*
DO 20 J = 1, NEIG
CALL DTPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
$ 1 )
20 CONTINUE
END IF
END IF
RETURN
*
* End of DSPGV
*
END
SUBROUTINE DSPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK,
$ LWORK, IWORK, LIWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, ITYPE, LDZ, LIWORK, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION AP( * ), BP( * ), W( * ), WORK( * ),
$ Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DSPGVD computes all the eigenvalues, and optionally, the eigenvectors
* of a real generalized symmetric-definite eigenproblem, of the form
* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
* B are assumed to be symmetric, stored in packed format, and B is also
* positive definite.
* If eigenvectors are desired, it uses a divide and conquer algorithm.
*
* The divide and conquer algorithm makes very mild assumptions about
* floating point arithmetic. It will work on machines with a guard
* digit in add/subtract, or on those binary machines without guard
* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
* Cray-2. It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* Specifies the problem type to be solved:
* = 1: A*x = (lambda)*B*x
* = 2: A*B*x = (lambda)*x
* = 3: B*A*x = (lambda)*x
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangles of A and B are stored;
* = 'L': Lower triangles of A and B are stored.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* A, packed columnwise in a linear array. The j-th column of A
* is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
*
* On exit, the contents of AP are destroyed.
*
* BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* B, packed columnwise in a linear array. The j-th column of B
* is stored in the array BP as follows:
* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
*
* On exit, the triangular factor U or L from the Cholesky
* factorization B = U**T*U or B = L*L**T, in the same storage
* format as B.
*
* W (output) DOUBLE PRECISION array, dimension (N)
* If INFO = 0, the eigenvalues in ascending order.
*
* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
* eigenvectors. The eigenvectors are normalized as follows:
* if ITYPE = 1 or 2, Z**T*B*Z = I;
* if ITYPE = 3, Z**T*inv(B)*Z = I.
* If JOBZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
* On exit, if INFO = 0, WORK(1) returns the required LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* If N <= 1, LWORK >= 1.
* If JOBZ = 'N' and N > 1, LWORK >= 2*N.
* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the required sizes of the WORK and IWORK
* arrays, returns these values as the first entries of the WORK
* and IWORK arrays, and no error message related to LWORK or
* LIWORK is issued by XERBLA.
*
* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK.
* If JOBZ = 'N' or N <= 1, LIWORK >= 1.
* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the required sizes of the WORK and
* IWORK arrays, returns these values as the first entries of
* the WORK and IWORK arrays, and no error message related to
* LWORK or LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: DPPTRF or DSPEVD returned an error code:
* <= N: if INFO = i, DSPEVD failed to converge;
* i off-diagonal elements of an intermediate
* tridiagonal form did not converge to zero;
* > N: if INFO = N + i, for 1 <= i <= N, then the leading
* minor of order i of B is not positive definite.
* The factorization of B could not be completed and
* no eigenvalues or eigenvectors were computed.
*
* Further Details
* ===============
*
* Based on contributions by
* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, UPPER, WANTZ
CHARACTER TRANS
INTEGER J, LIWMIN, LWMIN, NEIG
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DPPTRF, DSPEVD, DSPGST, DTPMV, DTPSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
UPPER = LSAME( UPLO, 'U' )
LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
INFO = 0
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
INFO = -1
ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -2
ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -9
END IF
*
IF( INFO.EQ.0 ) THEN
IF( N.LE.1 ) THEN
LIWMIN = 1
LWMIN = 1
ELSE
IF( WANTZ ) THEN
LIWMIN = 3 + 5*N
LWMIN = 1 + 6*N + 2*N**2
ELSE
LIWMIN = 1
LWMIN = 2*N
END IF
END IF
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -11
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSPGVD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Form a Cholesky factorization of BP.
*
CALL DPPTRF( UPLO, N, BP, INFO )
IF( INFO.NE.0 ) THEN
INFO = N + INFO
RETURN
END IF
*
* Transform problem to standard eigenvalue problem and solve.
*
CALL DSPGST( ITYPE, UPLO, N, AP, BP, INFO )
CALL DSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, IWORK,
$ LIWORK, INFO )
LWMIN = MAX( DBLE( LWMIN ), DBLE( WORK( 1 ) ) )
LIWMIN = MAX( DBLE( LIWMIN ), DBLE( IWORK( 1 ) ) )
*
IF( WANTZ ) THEN
*
* Backtransform eigenvectors to the original problem.
*
NEIG = N
IF( INFO.GT.0 )
$ NEIG = INFO - 1
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
*
* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
*
IF( UPPER ) THEN
TRANS = 'N'
ELSE
TRANS = 'T'
END IF
*
DO 10 J = 1, NEIG
CALL DTPSV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
$ 1 )
10 CONTINUE
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* For B*A*x=(lambda)*x;
* backtransform eigenvectors: x = L*y or U'*y
*
IF( UPPER ) THEN
TRANS = 'T'
ELSE
TRANS = 'N'
END IF
*
DO 20 J = 1, NEIG
CALL DTPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
$ 1 )
20 CONTINUE
END IF
END IF
*
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
RETURN
*
* End of DSPGVD
*
END
SUBROUTINE DSPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU,
$ IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK,
$ IFAIL, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE, UPLO
INTEGER IL, INFO, ITYPE, IU, LDZ, M, N
DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER IFAIL( * ), IWORK( * )
DOUBLE PRECISION AP( * ), BP( * ), W( * ), WORK( * ),
$ Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DSPGVX computes selected eigenvalues, and optionally, eigenvectors
* of a real generalized symmetric-definite eigenproblem, of the form
* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A
* and B are assumed to be symmetric, stored in packed storage, and B
* is also positive definite. Eigenvalues and eigenvectors can be
* selected by specifying either a range of values or a range of indices
* for the desired eigenvalues.
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* Specifies the problem type to be solved:
* = 1: A*x = (lambda)*B*x
* = 2: A*B*x = (lambda)*x
* = 3: B*A*x = (lambda)*x
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* RANGE (input) CHARACTER*1
* = 'A': all eigenvalues will be found.
* = 'V': all eigenvalues in the half-open interval (VL,VU]
* will be found.
* = 'I': the IL-th through IU-th eigenvalues will be found.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A and B are stored;
* = 'L': Lower triangle of A and B are stored.
*
* N (input) INTEGER
* The order of the matrix pencil (A,B). N >= 0.
*
* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* A, packed columnwise in a linear array. The j-th column of A
* is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
*
* On exit, the contents of AP are destroyed.
*
* BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* B, packed columnwise in a linear array. The j-th column of B
* is stored in the array BP as follows:
* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
*
* On exit, the triangular factor U or L from the Cholesky
* factorization B = U**T*U or B = L*L**T, in the same storage
* format as B.
*
* VL (input) DOUBLE PRECISION
* VU (input) DOUBLE PRECISION
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* ABSTOL (input) DOUBLE PRECISION
* The absolute error tolerance for the eigenvalues.
* An approximate eigenvalue is accepted as converged
* when it is determined to lie in an interval [a,b]
* of width less than or equal to
*
* ABSTOL + EPS * max( |a|,|b| ) ,
*
* where EPS is the machine precision. If ABSTOL is less than
* or equal to zero, then EPS*|T| will be used in its place,
* where |T| is the 1-norm of the tridiagonal matrix obtained
* by reducing A to tridiagonal form.
*
* Eigenvalues will be computed most accurately when ABSTOL is
* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
* If this routine returns with INFO>0, indicating that some
* eigenvectors did not converge, try setting ABSTOL to
* 2*DLAMCH('S').
*
* M (output) INTEGER
* The total number of eigenvalues found. 0 <= M <= N.
* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*
* W (output) DOUBLE PRECISION array, dimension (N)
* On normal exit, the first M elements contain the selected
* eigenvalues in ascending order.
*
* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
* If JOBZ = 'N', then Z is not referenced.
* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
* contain the orthonormal eigenvectors of the matrix A
* corresponding to the selected eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* The eigenvectors are normalized as follows:
* if ITYPE = 1 or 2, Z**T*B*Z = I;
* if ITYPE = 3, Z**T*inv(B)*Z = I.
*
* If an eigenvector fails to converge, then that column of Z
* contains the latest approximation to the eigenvector, and the
* index of the eigenvector is returned in IFAIL.
* Note: the user must ensure that at least max(1,M) columns are
* supplied in the array Z; if RANGE = 'V', the exact value of M
* is not known in advance and an upper bound must be used.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (8*N)
*
* IWORK (workspace) INTEGER array, dimension (5*N)
*
* IFAIL (output) INTEGER array, dimension (N)
* If JOBZ = 'V', then if INFO = 0, the first M elements of
* IFAIL are zero. If INFO > 0, then IFAIL contains the
* indices of the eigenvectors that failed to converge.
* If JOBZ = 'N', then IFAIL is not referenced.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: DPPTRF or DSPEVX returned an error code:
* <= N: if INFO = i, DSPEVX failed to converge;
* i eigenvectors failed to converge. Their indices
* are stored in array IFAIL.
* > N: if INFO = N + i, for 1 <= i <= N, then the leading
* minor of order i of B is not positive definite.
* The factorization of B could not be completed and
* no eigenvalues or eigenvectors were computed.
*
* Further Details
* ===============
*
* Based on contributions by
* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, UPPER, VALEIG, WANTZ
CHARACTER TRANS
INTEGER J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DPPTRF, DSPEVX, DSPGST, DTPMV, DTPSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
UPPER = LSAME( UPLO, 'U' )
WANTZ = LSAME( JOBZ, 'V' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
*
INFO = 0
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
INFO = -1
ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -2
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
INFO = -3
ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE
IF( VALEIG ) THEN
IF( N.GT.0 .AND. VU.LE.VL ) THEN
INFO = -9
END IF
ELSE IF( INDEIG ) THEN
IF( IL.LT.1 ) THEN
INFO = -10
ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
INFO = -11
END IF
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -16
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSPGVX', -INFO )
RETURN
END IF
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 )
$ RETURN
*
* Form a Cholesky factorization of B.
*
CALL DPPTRF( UPLO, N, BP, INFO )
IF( INFO.NE.0 ) THEN
INFO = N + INFO
RETURN
END IF
*
* Transform problem to standard eigenvalue problem and solve.
*
CALL DSPGST( ITYPE, UPLO, N, AP, BP, INFO )
CALL DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M,
$ W, Z, LDZ, WORK, IWORK, IFAIL, INFO )
*
IF( WANTZ ) THEN
*
* Backtransform eigenvectors to the original problem.
*
IF( INFO.GT.0 )
$ M = INFO - 1
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
*
* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
*
IF( UPPER ) THEN
TRANS = 'N'
ELSE
TRANS = 'T'
END IF
*
DO 10 J = 1, M
CALL DTPSV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
$ 1 )
10 CONTINUE
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* For B*A*x=(lambda)*x;
* backtransform eigenvectors: x = L*y or U'*y
*
IF( UPPER ) THEN
TRANS = 'T'
ELSE
TRANS = 'N'
END IF
*
DO 20 J = 1, M
CALL DTPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
$ 1 )
20 CONTINUE
END IF
END IF
*
RETURN
*
* End of DSPGVX
*
END
SUBROUTINE DSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX,
$ FERR, BERR, WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), IWORK( * )
DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ),
$ FERR( * ), WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* DSPRFS improves the computed solution to a system of linear
* equations when the coefficient matrix is symmetric indefinite
* and packed, and provides error bounds and backward error estimates
* for the solution.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* 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 matrices B and X. NRHS >= 0.
*
* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The upper or lower triangle of the symmetric matrix A, packed
* columnwise in a linear array. The j-th column of A is stored
* in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
*
* AFP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The factored form of the matrix A. AFP contains the block
* diagonal matrix D and the multipliers used to obtain the
* factor U or L from the factorization A = U*D*U**T or
* A = L*D*L**T as computed by DSPTRF, stored as a packed
* triangular matrix.
*
* IPIV (input) INTEGER array, dimension (N)
* Details of the interchanges and the block structure of D
* as determined by DSPTRF.
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
* On entry, the solution matrix X, as computed by DSPTRS.
* On exit, the improved solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Internal Parameters
* ===================
*
* ITMAX is the maximum number of steps of iterative refinement.
*
* =====================================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 5 )
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D+0 )
DOUBLE PRECISION THREE
PARAMETER ( THREE = 3.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER COUNT, I, IK, J, K, KASE, KK, NZ
DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DLACN2, DSPMV, DSPTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSPRFS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
DO 10 J = 1, NRHS
FERR( J ) = ZERO
BERR( J ) = ZERO
10 CONTINUE
RETURN
END IF
*
* NZ = maximum number of nonzero elements in each row of A, plus 1
*
NZ = N + 1
EPS = DLAMCH( 'Epsilon' )
SAFMIN = DLAMCH( 'Safe minimum' )
SAFE1 = NZ*SAFMIN
SAFE2 = SAFE1 / EPS
*
* Do for each right hand side
*
DO 140 J = 1, NRHS
*
COUNT = 1
LSTRES = THREE
20 CONTINUE
*
* Loop until stopping criterion is satisfied.
*
* Compute residual R = B - A * X
*
CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
CALL DSPMV( UPLO, N, -ONE, AP, X( 1, J ), 1, ONE, WORK( N+1 ),
$ 1 )
*
* Compute componentwise relative backward error from formula
*
* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
*
* where abs(Z) is the componentwise absolute value of the matrix
* or vector Z. If the i-th component of the denominator is less
* than SAFE2, then SAFE1 is added to the i-th components of the
* numerator and denominator before dividing.
*
DO 30 I = 1, N
WORK( I ) = ABS( B( I, J ) )
30 CONTINUE
*
* Compute abs(A)*abs(X) + abs(B).
*
KK = 1
IF( UPPER ) THEN
DO 50 K = 1, N
S = ZERO
XK = ABS( X( K, J ) )
IK = KK
DO 40 I = 1, K - 1
WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK
S = S + ABS( AP( IK ) )*ABS( X( I, J ) )
IK = IK + 1
40 CONTINUE
WORK( K ) = WORK( K ) + ABS( AP( KK+K-1 ) )*XK + S
KK = KK + K
50 CONTINUE
ELSE
DO 70 K = 1, N
S = ZERO
XK = ABS( X( K, J ) )
WORK( K ) = WORK( K ) + ABS( AP( KK ) )*XK
IK = KK + 1
DO 60 I = K + 1, N
WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK
S = S + ABS( AP( IK ) )*ABS( X( I, J ) )
IK = IK + 1
60 CONTINUE
WORK( K ) = WORK( K ) + S
KK = KK + ( N-K+1 )
70 CONTINUE
END IF
S = ZERO
DO 80 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
ELSE
S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
$ ( WORK( I )+SAFE1 ) )
END IF
80 CONTINUE
BERR( J ) = S
*
* Test stopping criterion. Continue iterating if
* 1) The residual BERR(J) is larger than machine epsilon, and
* 2) BERR(J) decreased by at least a factor of 2 during the
* last iteration, and
* 3) At most ITMAX iterations tried.
*
IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
$ COUNT.LE.ITMAX ) THEN
*
* Update solution and try again.
*
CALL DSPTRS( UPLO, N, 1, AFP, IPIV, WORK( N+1 ), N, INFO )
CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
LSTRES = BERR( J )
COUNT = COUNT + 1
GO TO 20
END IF
*
* Bound error from formula
*
* norm(X - XTRUE) / norm(X) .le. FERR =
* norm( abs(inv(A))*
* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
*
* where
* norm(Z) is the magnitude of the largest component of Z
* inv(A) is the inverse of A
* abs(Z) is the componentwise absolute value of the matrix or
* vector Z
* NZ is the maximum number of nonzeros in any row of A, plus 1
* EPS is machine epsilon
*
* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
* is incremented by SAFE1 if the i-th component of
* abs(A)*abs(X) + abs(B) is less than SAFE2.
*
* Use DLACN2 to estimate the infinity-norm of the matrix
* inv(A) * diag(W),
* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
*
DO 90 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
ELSE
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
END IF
90 CONTINUE
*
KASE = 0
100 CONTINUE
CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
$ KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Multiply by diag(W)*inv(A').
*
CALL DSPTRS( UPLO, N, 1, AFP, IPIV, WORK( N+1 ), N,
$ INFO )
DO 110 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
110 CONTINUE
ELSE IF( KASE.EQ.2 ) THEN
*
* Multiply by inv(A)*diag(W).
*
DO 120 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
120 CONTINUE
CALL DSPTRS( UPLO, N, 1, AFP, IPIV, WORK( N+1 ), N,
$ INFO )
END IF
GO TO 100
END IF
*
* Normalize error.
*
LSTRES = ZERO
DO 130 I = 1, N
LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
130 CONTINUE
IF( LSTRES.NE.ZERO )
$ FERR( J ) = FERR( J ) / LSTRES
*
140 CONTINUE
*
RETURN
*
* End of DSPRFS
*
END
SUBROUTINE DSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION AP( * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* DSPSV computes the solution to a real system of linear equations
* A * X = B,
* where A is an N-by-N symmetric matrix stored in packed format and X
* and B are N-by-NRHS matrices.
*
* The diagonal pivoting method is used to factor A as
* A = U * D * U**T, if UPLO = 'U', or
* A = L * D * L**T, if UPLO = 'L',
* where U (or L) is a product of permutation and unit upper (lower)
* triangular matrices, D is symmetric and block diagonal with 1-by-1
* and 2-by-2 diagonal blocks. The factored form of A is then used to
* solve the system of equations A * X = B.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The number of linear equations, i.e., 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.
*
* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* A, packed columnwise in a linear array. The j-th column of A
* is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
* See below for further details.
*
* On exit, the block diagonal matrix D and the multipliers used
* to obtain the factor U or L from the factorization
* A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as
* a packed triangular matrix in the same storage format as A.
*
* IPIV (output) INTEGER array, dimension (N)
* Details of the interchanges and the block structure of D, as
* determined by DSPTRF. If IPIV(k) > 0, then rows and columns
* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1
* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,
* then rows and columns k-1 and -IPIV(k) were interchanged and
* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and
* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and
* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2
* diagonal block.
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the N-by-NRHS right hand side matrix B.
* On exit, if INFO = 0, the N-by-NRHS 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
* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
* has been completed, but the block diagonal matrix D is
* exactly singular, so the solution could not be
* computed.
*
* Further Details
* ===============
*
* The packed storage scheme is illustrated by the following example
* when N = 4, UPLO = 'U':
*
* Two-dimensional storage of the symmetric matrix A:
*
* a11 a12 a13 a14
* a22 a23 a24
* a33 a34 (aij = aji)
* a44
*
* Packed storage of the upper triangle of A:
*
* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DSPTRF, DSPTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSPSV ', -INFO )
RETURN
END IF
*
* Compute the factorization A = U*D*U' or A = L*D*L'.
*
CALL DSPTRF( UPLO, N, AP, IPIV, INFO )
IF( INFO.EQ.0 ) THEN
*
* Solve the system A*X = B, overwriting B with X.
*
CALL DSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
*
END IF
RETURN
*
* End of DSPSV
*
END
SUBROUTINE DSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X,
$ LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER FACT, UPLO
INTEGER INFO, LDB, LDX, N, NRHS
DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), IWORK( * )
DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ),
$ FERR( * ), WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* DSPSVX uses the diagonal pivoting factorization A = U*D*U**T or
* A = L*D*L**T to compute the solution to a real system of linear
* equations A * X = B, where A is an N-by-N symmetric matrix stored
* in packed format and X and B are N-by-NRHS matrices.
*
* Error bounds on the solution and a condition estimate are also
* provided.
*
* Description
* ===========
*
* The following steps are performed:
*
* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as
* A = U * D * U**T, if UPLO = 'U', or
* A = L * D * L**T, if UPLO = 'L',
* where U (or L) is a product of permutation and unit upper (lower)
* triangular matrices and D is symmetric and block diagonal with
* 1-by-1 and 2-by-2 diagonal blocks.
*
* 2. If some D(i,i)=0, so that D is exactly singular, then the routine
* returns with INFO = i. Otherwise, the factored form of A is used
* to estimate the condition number of the matrix A. If the
* reciprocal of the condition number is less than machine precision,
* INFO = N+1 is returned as a warning, but the routine still goes on
* to solve for X and compute error bounds as described below.
*
* 3. The system of equations is solved for X using the factored form
* of A.
*
* 4. Iterative refinement is applied to improve the computed solution
* matrix and calculate error bounds and backward error estimates
* for it.
*
* Arguments
* =========
*
* FACT (input) CHARACTER*1
* Specifies whether or not the factored form of A has been
* supplied on entry.
* = 'F': On entry, AFP and IPIV contain the factored form of
* A. AP, AFP and IPIV will not be modified.
* = 'N': The matrix A will be copied to AFP and factored.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The number of linear equations, i.e., 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 matrices B and X. NRHS >= 0.
*
* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The upper or lower triangle of the symmetric matrix A, packed
* columnwise in a linear array. The j-th column of A is stored
* in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
* See below for further details.
*
* AFP (input or output) DOUBLE PRECISION array, dimension
* (N*(N+1)/2)
* If FACT = 'F', then AFP is an input argument and on entry
* contains the block diagonal matrix D and the multipliers used
* to obtain the factor U or L from the factorization
* A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as
* a packed triangular matrix in the same storage format as A.
*
* If FACT = 'N', then AFP is an output argument and on exit
* contains the block diagonal matrix D and the multipliers used
* to obtain the factor U or L from the factorization
* A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as
* a packed triangular matrix in the same storage format as A.
*
* IPIV (input or output) INTEGER array, dimension (N)
* If FACT = 'F', then IPIV is an input argument and on entry
* contains details of the interchanges and the block structure
* of D, as determined by DSPTRF.
* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
* interchanged and D(k,k) is a 1-by-1 diagonal block.
* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*
* If FACT = 'N', then IPIV is an output argument and on exit
* contains details of the interchanges and the block structure
* of D, as determined by DSPTRF.
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The N-by-NRHS right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* RCOND (output) DOUBLE PRECISION
* The estimate of the reciprocal condition number of the matrix
* A. If RCOND is less than the machine precision (in
* particular, if RCOND = 0), the matrix is singular to working
* precision. This condition is indicated by a return code of
* INFO > 0.
*
* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, and i is
* <= N: D(i,i) is exactly zero. The factorization
* has been completed but the factor D is exactly
* singular, so the solution and error bounds could
* not be computed. RCOND = 0 is returned.
* = N+1: D is nonsingular, but RCOND is less than machine
* precision, meaning that the matrix is singular
* to working precision. Nevertheless, the
* solution and error bounds are computed because
* there are a number of situations where the
* computed solution can be more accurate than the
* value of RCOND would suggest.
*
* Further Details
* ===============
*
* The packed storage scheme is illustrated by the following example
* when N = 4, UPLO = 'U':
*
* Two-dimensional storage of the symmetric matrix A:
*
* a11 a12 a13 a14
* a22 a23 a24
* a33 a34 (aij = aji)
* a44
*
* Packed storage of the upper triangle of A:
*
* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOFACT
DOUBLE PRECISION ANORM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANSP
EXTERNAL LSAME, DLAMCH, DLANSP
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLACPY, DSPCON, DSPRFS, DSPTRF, DSPTRS,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
NOFACT = LSAME( FACT, 'N' )
IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
INFO = -1
ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
$ THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.0 ) THEN
INFO = -4
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -11
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSPSVX', -INFO )
RETURN
END IF
*
IF( NOFACT ) THEN
*
* Compute the factorization A = U*D*U' or A = L*D*L'.
*
CALL DCOPY( N*( N+1 ) / 2, AP, 1, AFP, 1 )
CALL DSPTRF( UPLO, N, AFP, IPIV, INFO )
*
* Return if INFO is non-zero.
*
IF( INFO.GT.0 )THEN
RCOND = ZERO
RETURN
END IF
END IF
*
* Compute the norm of the matrix A.
*
ANORM = DLANSP( 'I', UPLO, N, AP, WORK )
*
* Compute the reciprocal of the condition number of A.
*
CALL DSPCON( UPLO, N, AFP, IPIV, ANORM, RCOND, WORK, IWORK, INFO )
*
* Compute the solution vectors X.
*
CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
CALL DSPTRS( UPLO, N, NRHS, AFP, IPIV, X, LDX, INFO )
*
* Use iterative refinement to improve the computed solutions and
* compute error bounds and backward error estimates for them.
*
CALL DSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR,
$ BERR, WORK, IWORK, INFO )
*
* Set INFO = N+1 if the matrix is singular to working precision.
*
IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
$ INFO = N + 1
*
RETURN
*
* End of DSPSVX
*
END
SUBROUTINE DSPTRD( UPLO, N, AP, D, E, TAU, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP( * ), D( * ), E( * ), TAU( * )
* ..
*
* Purpose
* =======
*
* DSPTRD reduces a real symmetric matrix A stored in packed form to
* symmetric tridiagonal form T by an orthogonal similarity
* transformation: Q**T * A * Q = T.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* A, packed columnwise in a linear array. The j-th column of A
* is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
* On exit, if UPLO = 'U', the diagonal and first superdiagonal
* of A are overwritten by the corresponding elements of the
* tridiagonal matrix T, and the elements above the first
* superdiagonal, with the array TAU, represent the orthogonal
* matrix Q as a product of elementary reflectors; if UPLO
* = 'L', the diagonal and first subdiagonal of A are over-
* written by the corresponding elements of the tridiagonal
* matrix T, and the elements below the first subdiagonal, with
* the array TAU, represent the orthogonal matrix Q as a product
* of elementary reflectors. See Further Details.
*
* D (output) DOUBLE PRECISION array, dimension (N)
* The diagonal elements of the tridiagonal matrix T:
* D(i) = A(i,i).
*
* E (output) DOUBLE PRECISION array, dimension (N-1)
* The off-diagonal elements of the tridiagonal matrix T:
* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
*
* TAU (output) DOUBLE PRECISION array, dimension (N-1)
* The scalar factors of the elementary reflectors (see Further
* Details).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Further Details
* ===============
*
* If UPLO = 'U', the matrix Q is represented as a product of elementary
* reflectors
*
* Q = H(n-1) . . . H(2) H(1).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a real scalar, and v is a real vector with
* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,
* overwriting A(1:i-1,i+1), and tau is stored in TAU(i).
*
* If UPLO = 'L', the matrix Q is represented as a product of elementary
* reflectors
*
* Q = H(1) H(2) . . . H(n-1).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a real scalar, and v is a real vector with
* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,
* overwriting A(i+2:n,i), and tau is stored in TAU(i).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO, HALF
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0,
$ HALF = 1.0D0 / 2.0D0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, I1, I1I1, II
DOUBLE PRECISION ALPHA, TAUI
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DLARFG, DSPMV, DSPR2, XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DDOT
EXTERNAL LSAME, DDOT
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSPTRD', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Reduce the upper triangle of A.
* I1 is the index in AP of A(1,I+1).
*
I1 = N*( N-1 ) / 2 + 1
DO 10 I = N - 1, 1, -1
*
* Generate elementary reflector H(i) = I - tau * v * v'
* to annihilate A(1:i-1,i+1)
*
CALL DLARFG( I, AP( I1+I-1 ), AP( I1 ), 1, TAUI )
E( I ) = AP( I1+I-1 )
*
IF( TAUI.NE.ZERO ) THEN
*
* Apply H(i) from both sides to A(1:i,1:i)
*
AP( I1+I-1 ) = ONE
*
* Compute y := tau * A * v storing y in TAU(1:i)
*
CALL DSPMV( UPLO, I, TAUI, AP, AP( I1 ), 1, ZERO, TAU,
$ 1 )
*
* Compute w := y - 1/2 * tau * (y'*v) * v
*
ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, AP( I1 ), 1 )
CALL DAXPY( I, ALPHA, AP( I1 ), 1, TAU, 1 )
*
* Apply the transformation as a rank-2 update:
* A := A - v * w' - w * v'
*
CALL DSPR2( UPLO, I, -ONE, AP( I1 ), 1, TAU, 1, AP )
*
AP( I1+I-1 ) = E( I )
END IF
D( I+1 ) = AP( I1+I )
TAU( I ) = TAUI
I1 = I1 - I
10 CONTINUE
D( 1 ) = AP( 1 )
ELSE
*
* Reduce the lower triangle of A. II is the index in AP of
* A(i,i) and I1I1 is the index of A(i+1,i+1).
*
II = 1
DO 20 I = 1, N - 1
I1I1 = II + N - I + 1
*
* Generate elementary reflector H(i) = I - tau * v * v'
* to annihilate A(i+2:n,i)
*
CALL DLARFG( N-I, AP( II+1 ), AP( II+2 ), 1, TAUI )
E( I ) = AP( II+1 )
*
IF( TAUI.NE.ZERO ) THEN
*
* Apply H(i) from both sides to A(i+1:n,i+1:n)
*
AP( II+1 ) = ONE
*
* Compute y := tau * A * v storing y in TAU(i:n-1)
*
CALL DSPMV( UPLO, N-I, TAUI, AP( I1I1 ), AP( II+1 ), 1,
$ ZERO, TAU( I ), 1 )
*
* Compute w := y - 1/2 * tau * (y'*v) * v
*
ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I ), 1, AP( II+1 ),
$ 1 )
CALL DAXPY( N-I, ALPHA, AP( II+1 ), 1, TAU( I ), 1 )
*
* Apply the transformation as a rank-2 update:
* A := A - v * w' - w * v'
*
CALL DSPR2( UPLO, N-I, -ONE, AP( II+1 ), 1, TAU( I ), 1,
$ AP( I1I1 ) )
*
AP( II+1 ) = E( I )
END IF
D( I ) = AP( II )
TAU( I ) = TAUI
II = I1I1
20 CONTINUE
D( N ) = AP( II )
END IF
*
RETURN
*
* End of DSPTRD
*
END
SUBROUTINE DSPTRF( UPLO, N, AP, IPIV, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION AP( * )
* ..
*
* Purpose
* =======
*
* DSPTRF computes the factorization of a real symmetric matrix A stored
* in packed format using the Bunch-Kaufman diagonal pivoting method:
*
* A = U*D*U**T or A = L*D*L**T
*
* where U (or L) is a product of permutation and unit upper (lower)
* triangular matrices, and D is symmetric and block diagonal with
* 1-by-1 and 2-by-2 diagonal blocks.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* A, packed columnwise in a linear array. The j-th column of A
* is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
*
* On exit, the block diagonal matrix D and the multipliers used
* to obtain the factor U or L, stored as a packed triangular
* matrix overwriting A (see below for further details).
*
* IPIV (output) INTEGER array, dimension (N)
* Details of the interchanges and the block structure of D.
* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
* interchanged and D(k,k) is a 1-by-1 diagonal block.
* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
* has been completed, but the block diagonal matrix D is
* exactly singular, and division by zero will occur if it
* is used to solve a system of equations.
*
* Further Details
* ===============
*
* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services
* Company
*
* If UPLO = 'U', then A = U*D*U', where
* U = P(n)*U(n)* ... *P(k)U(k)* ...,
* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
* that if the diagonal block D(k) is of order s (s = 1 or 2), then
*
* ( I v 0 ) k-s
* U(k) = ( 0 I 0 ) s
* ( 0 0 I ) n-k
* k-s s n-k
*
* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
* and A(k,k), and v overwrites A(1:k-2,k-1:k).
*
* If UPLO = 'L', then A = L*D*L', where
* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
* that if the diagonal block D(k) is of order s (s = 1 or 2), then
*
* ( I 0 0 ) k-1
* L(k) = ( 0 I 0 ) s
* ( 0 v I ) n-k-s+1
* k-1 s n-k-s+1
*
* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION EIGHT, SEVTEN
PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, IMAX, J, JMAX, K, KC, KK, KNC, KP, KPC,
$ KSTEP, KX, NPP
DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, R1,
$ ROWMAX, T, WK, WKM1, WKP1
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
EXTERNAL LSAME, IDAMAX
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, DSPR, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSPTRF', -INFO )
RETURN
END IF
*
* Initialize ALPHA for use in choosing pivot block size.
*
ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
*
IF( UPPER ) THEN
*
* Factorize A as U*D*U' using the upper triangle of A
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2
*
K = N
KC = ( N-1 )*N / 2 + 1
10 CONTINUE
KNC = KC
*
* If K < 1, exit from loop
*
IF( K.LT.1 )
$ GO TO 110
KSTEP = 1
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = ABS( AP( KC+K-1 ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value
*
IF( K.GT.1 ) THEN
IMAX = IDAMAX( K-1, AP( KC ), 1 )
COLMAX = ABS( AP( KC+IMAX-1 ) )
ELSE
COLMAX = ZERO
END IF
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* Column K is zero: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
ELSE
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value
*
ROWMAX = ZERO
JMAX = IMAX
KX = IMAX*( IMAX+1 ) / 2 + IMAX
DO 20 J = IMAX + 1, K
IF( ABS( AP( KX ) ).GT.ROWMAX ) THEN
ROWMAX = ABS( AP( KX ) )
JMAX = J
END IF
KX = KX + J
20 CONTINUE
KPC = ( IMAX-1 )*IMAX / 2 + 1
IF( IMAX.GT.1 ) THEN
JMAX = IDAMAX( IMAX-1, AP( KPC ), 1 )
ROWMAX = MAX( ROWMAX, ABS( AP( KPC+JMAX-1 ) ) )
END IF
*
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE IF( ABS( AP( KPC+IMAX-1 ) ).GE.ALPHA*ROWMAX ) THEN
*
* interchange rows and columns K and IMAX, use 1-by-1
* pivot block
*
KP = IMAX
ELSE
*
* interchange rows and columns K-1 and IMAX, use 2-by-2
* pivot block
*
KP = IMAX
KSTEP = 2
END IF
END IF
*
KK = K - KSTEP + 1
IF( KSTEP.EQ.2 )
$ KNC = KNC - K + 1
IF( KP.NE.KK ) THEN
*
* Interchange rows and columns KK and KP in the leading
* submatrix A(1:k,1:k)
*
CALL DSWAP( KP-1, AP( KNC ), 1, AP( KPC ), 1 )
KX = KPC + KP - 1
DO 30 J = KP + 1, KK - 1
KX = KX + J - 1
T = AP( KNC+J-1 )
AP( KNC+J-1 ) = AP( KX )
AP( KX ) = T
30 CONTINUE
T = AP( KNC+KK-1 )
AP( KNC+KK-1 ) = AP( KPC+KP-1 )
AP( KPC+KP-1 ) = T
IF( KSTEP.EQ.2 ) THEN
T = AP( KC+K-2 )
AP( KC+K-2 ) = AP( KC+KP-1 )
AP( KC+KP-1 ) = T
END IF
END IF
*
* Update the leading submatrix
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column k now holds
*
* W(k) = U(k)*D(k)
*
* where U(k) is the k-th column of U
*
* Perform a rank-1 update of A(1:k-1,1:k-1) as
*
* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)'
*
R1 = ONE / AP( KC+K-1 )
CALL DSPR( UPLO, K-1, -R1, AP( KC ), 1, AP )
*
* Store U(k) in column k
*
CALL DSCAL( K-1, R1, AP( KC ), 1 )
ELSE
*
* 2-by-2 pivot block D(k): columns k and k-1 now hold
*
* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
*
* where U(k) and U(k-1) are the k-th and (k-1)-th columns
* of U
*
* Perform a rank-2 update of A(1:k-2,1:k-2) as
*
* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )'
* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )'
*
IF( K.GT.2 ) THEN
*
D12 = AP( K-1+( K-1 )*K / 2 )
D22 = AP( K-1+( K-2 )*( K-1 ) / 2 ) / D12
D11 = AP( K+( K-1 )*K / 2 ) / D12
T = ONE / ( D11*D22-ONE )
D12 = T / D12
*
DO 50 J = K - 2, 1, -1
WKM1 = D12*( D11*AP( J+( K-2 )*( K-1 ) / 2 )-
$ AP( J+( K-1 )*K / 2 ) )
WK = D12*( D22*AP( J+( K-1 )*K / 2 )-
$ AP( J+( K-2 )*( K-1 ) / 2 ) )
DO 40 I = J, 1, -1
AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) -
$ AP( I+( K-1 )*K / 2 )*WK -
$ AP( I+( K-2 )*( K-1 ) / 2 )*WKM1
40 CONTINUE
AP( J+( K-1 )*K / 2 ) = WK
AP( J+( K-2 )*( K-1 ) / 2 ) = WKM1
50 CONTINUE
*
END IF
*
END IF
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -KP
IPIV( K-1 ) = -KP
END IF
*
* Decrease K and return to the start of the main loop
*
K = K - KSTEP
KC = KNC - K
GO TO 10
*
ELSE
*
* Factorize A as L*D*L' using the lower triangle of A
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2
*
K = 1
KC = 1
NPP = N*( N+1 ) / 2
60 CONTINUE
KNC = KC
*
* If K > N, exit from loop
*
IF( K.GT.N )
$ GO TO 110
KSTEP = 1
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = ABS( AP( KC ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value
*
IF( K.LT.N ) THEN
IMAX = K + IDAMAX( N-K, AP( KC+1 ), 1 )
COLMAX = ABS( AP( KC+IMAX-K ) )
ELSE
COLMAX = ZERO
END IF
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* Column K is zero: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
ELSE
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value
*
ROWMAX = ZERO
KX = KC + IMAX - K
DO 70 J = K, IMAX - 1
IF( ABS( AP( KX ) ).GT.ROWMAX ) THEN
ROWMAX = ABS( AP( KX ) )
JMAX = J
END IF
KX = KX + N - J
70 CONTINUE
KPC = NPP - ( N-IMAX+1 )*( N-IMAX+2 ) / 2 + 1
IF( IMAX.LT.N ) THEN
JMAX = IMAX + IDAMAX( N-IMAX, AP( KPC+1 ), 1 )
ROWMAX = MAX( ROWMAX, ABS( AP( KPC+JMAX-IMAX ) ) )
END IF
*
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE IF( ABS( AP( KPC ) ).GE.ALPHA*ROWMAX ) THEN
*
* interchange rows and columns K and IMAX, use 1-by-1
* pivot block
*
KP = IMAX
ELSE
*
* interchange rows and columns K+1 and IMAX, use 2-by-2
* pivot block
*
KP = IMAX
KSTEP = 2
END IF
END IF
*
KK = K + KSTEP - 1
IF( KSTEP.EQ.2 )
$ KNC = KNC + N - K + 1
IF( KP.NE.KK ) THEN
*
* Interchange rows and columns KK and KP in the trailing
* submatrix A(k:n,k:n)
*
IF( KP.LT.N )
$ CALL DSWAP( N-KP, AP( KNC+KP-KK+1 ), 1, AP( KPC+1 ),
$ 1 )
KX = KNC + KP - KK
DO 80 J = KK + 1, KP - 1
KX = KX + N - J + 1
T = AP( KNC+J-KK )
AP( KNC+J-KK ) = AP( KX )
AP( KX ) = T
80 CONTINUE
T = AP( KNC )
AP( KNC ) = AP( KPC )
AP( KPC ) = T
IF( KSTEP.EQ.2 ) THEN
T = AP( KC+1 )
AP( KC+1 ) = AP( KC+KP-K )
AP( KC+KP-K ) = T
END IF
END IF
*
* Update the trailing submatrix
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column k now holds
*
* W(k) = L(k)*D(k)
*
* where L(k) is the k-th column of L
*
IF( K.LT.N ) THEN
*
* Perform a rank-1 update of A(k+1:n,k+1:n) as
*
* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)'
*
R1 = ONE / AP( KC )
CALL DSPR( UPLO, N-K, -R1, AP( KC+1 ), 1,
$ AP( KC+N-K+1 ) )
*
* Store L(k) in column K
*
CALL DSCAL( N-K, R1, AP( KC+1 ), 1 )
END IF
ELSE
*
* 2-by-2 pivot block D(k): columns K and K+1 now hold
*
* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
*
* where L(k) and L(k+1) are the k-th and (k+1)-th columns
* of L
*
IF( K.LT.N-1 ) THEN
*
* Perform a rank-2 update of A(k+2:n,k+2:n) as
*
* A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )'
* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )'
*
D21 = AP( K+1+( K-1 )*( 2*N-K ) / 2 )
D11 = AP( K+1+K*( 2*N-K-1 ) / 2 ) / D21
D22 = AP( K+( K-1 )*( 2*N-K ) / 2 ) / D21
T = ONE / ( D11*D22-ONE )
D21 = T / D21
*
DO 100 J = K + 2, N
WK = D21*( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )-
$ AP( J+K*( 2*N-K-1 ) / 2 ) )
WKP1 = D21*( D22*AP( J+K*( 2*N-K-1 ) / 2 )-
$ AP( J+( K-1 )*( 2*N-K ) / 2 ) )
*
DO 90 I = J, N
AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )*
$ ( 2*N-J ) / 2 ) - AP( I+( K-1 )*( 2*N-K ) /
$ 2 )*WK - AP( I+K*( 2*N-K-1 ) / 2 )*WKP1
90 CONTINUE
*
AP( J+( K-1 )*( 2*N-K ) / 2 ) = WK
AP( J+K*( 2*N-K-1 ) / 2 ) = WKP1
*
100 CONTINUE
END IF
END IF
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -KP
IPIV( K+1 ) = -KP
END IF
*
* Increase K and return to the start of the main loop
*
K = K + KSTEP
KC = KNC + N - K + 2
GO TO 60
*
END IF
*
110 CONTINUE
RETURN
*
* End of DSPTRF
*
END
SUBROUTINE DSPTRI( UPLO, N, AP, IPIV, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION AP( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DSPTRI computes the inverse of a real symmetric indefinite matrix
* A in packed storage using the factorization A = U*D*U**T or
* A = L*D*L**T computed by DSPTRF.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the details of the factorization are stored
* as an upper or lower triangular matrix.
* = 'U': Upper triangular, form is A = U*D*U**T;
* = 'L': Lower triangular, form is A = L*D*L**T.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* On entry, the block diagonal matrix D and the multipliers
* used to obtain the factor U or L as computed by DSPTRF,
* stored as a packed triangular matrix.
*
* On exit, if INFO = 0, the (symmetric) inverse of the original
* matrix, stored as a packed triangular matrix. The j-th column
* of inv(A) is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;
* if UPLO = 'L',
* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.
*
* IPIV (input) INTEGER array, dimension (N)
* Details of the interchanges and the block structure of D
* as determined by DSPTRF.
*
* 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
* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
* inverse could not be computed.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, K, KC, KCNEXT, KP, KPC, KSTEP, KX, NPP
DOUBLE PRECISION AK, AKKP1, AKP1, D, T, TEMP
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DDOT
EXTERNAL LSAME, DDOT
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DSPMV, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSPTRI', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Check that the diagonal matrix D is nonsingular.
*
IF( UPPER ) THEN
*
* Upper triangular storage: examine D from bottom to top
*
KP = N*( N+1 ) / 2
DO 10 INFO = N, 1, -1
IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO )
$ RETURN
KP = KP - INFO
10 CONTINUE
ELSE
*
* Lower triangular storage: examine D from top to bottom.
*
KP = 1
DO 20 INFO = 1, N
IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO )
$ RETURN
KP = KP + N - INFO + 1
20 CONTINUE
END IF
INFO = 0
*
IF( UPPER ) THEN
*
* Compute inv(A) from the factorization A = U*D*U'.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
KC = 1
30 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 50
*
KCNEXT = KC + K
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Invert the diagonal block.
*
AP( KC+K-1 ) = ONE / AP( KC+K-1 )
*
* Compute column K of the inverse.
*
IF( K.GT.1 ) THEN
CALL DCOPY( K-1, AP( KC ), 1, WORK, 1 )
CALL DSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, AP( KC ),
$ 1 )
AP( KC+K-1 ) = AP( KC+K-1 ) -
$ DDOT( K-1, WORK, 1, AP( KC ), 1 )
END IF
KSTEP = 1
ELSE
*
* 2 x 2 diagonal block
*
* Invert the diagonal block.
*
T = ABS( AP( KCNEXT+K-1 ) )
AK = AP( KC+K-1 ) / T
AKP1 = AP( KCNEXT+K ) / T
AKKP1 = AP( KCNEXT+K-1 ) / T
D = T*( AK*AKP1-ONE )
AP( KC+K-1 ) = AKP1 / D
AP( KCNEXT+K ) = AK / D
AP( KCNEXT+K-1 ) = -AKKP1 / D
*
* Compute columns K and K+1 of the inverse.
*
IF( K.GT.1 ) THEN
CALL DCOPY( K-1, AP( KC ), 1, WORK, 1 )
CALL DSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, AP( KC ),
$ 1 )
AP( KC+K-1 ) = AP( KC+K-1 ) -
$ DDOT( K-1, WORK, 1, AP( KC ), 1 )
AP( KCNEXT+K-1 ) = AP( KCNEXT+K-1 ) -
$ DDOT( K-1, AP( KC ), 1, AP( KCNEXT ),
$ 1 )
CALL DCOPY( K-1, AP( KCNEXT ), 1, WORK, 1 )
CALL DSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO,
$ AP( KCNEXT ), 1 )
AP( KCNEXT+K ) = AP( KCNEXT+K ) -
$ DDOT( K-1, WORK, 1, AP( KCNEXT ), 1 )
END IF
KSTEP = 2
KCNEXT = KCNEXT + K + 1
END IF
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K ) THEN
*
* Interchange rows and columns K and KP in the leading
* submatrix A(1:k+1,1:k+1)
*
KPC = ( KP-1 )*KP / 2 + 1
CALL DSWAP( KP-1, AP( KC ), 1, AP( KPC ), 1 )
KX = KPC + KP - 1
DO 40 J = KP + 1, K - 1
KX = KX + J - 1
TEMP = AP( KC+J-1 )
AP( KC+J-1 ) = AP( KX )
AP( KX ) = TEMP
40 CONTINUE
TEMP = AP( KC+K-1 )
AP( KC+K-1 ) = AP( KPC+KP-1 )
AP( KPC+KP-1 ) = TEMP
IF( KSTEP.EQ.2 ) THEN
TEMP = AP( KC+K+K-1 )
AP( KC+K+K-1 ) = AP( KC+K+KP-1 )
AP( KC+K+KP-1 ) = TEMP
END IF
END IF
*
K = K + KSTEP
KC = KCNEXT
GO TO 30
50 CONTINUE
*
ELSE
*
* Compute inv(A) from the factorization A = L*D*L'.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
NPP = N*( N+1 ) / 2
K = N
KC = NPP
60 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 80
*
KCNEXT = KC - ( N-K+2 )
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Invert the diagonal block.
*
AP( KC ) = ONE / AP( KC )
*
* Compute column K of the inverse.
*
IF( K.LT.N ) THEN
CALL DCOPY( N-K, AP( KC+1 ), 1, WORK, 1 )
CALL DSPMV( UPLO, N-K, -ONE, AP( KC+N-K+1 ), WORK, 1,
$ ZERO, AP( KC+1 ), 1 )
AP( KC ) = AP( KC ) - DDOT( N-K, WORK, 1, AP( KC+1 ), 1 )
END IF
KSTEP = 1
ELSE
*
* 2 x 2 diagonal block
*
* Invert the diagonal block.
*
T = ABS( AP( KCNEXT+1 ) )
AK = AP( KCNEXT ) / T
AKP1 = AP( KC ) / T
AKKP1 = AP( KCNEXT+1 ) / T
D = T*( AK*AKP1-ONE )
AP( KCNEXT ) = AKP1 / D
AP( KC ) = AK / D
AP( KCNEXT+1 ) = -AKKP1 / D
*
* Compute columns K-1 and K of the inverse.
*
IF( K.LT.N ) THEN
CALL DCOPY( N-K, AP( KC+1 ), 1, WORK, 1 )
CALL DSPMV( UPLO, N-K, -ONE, AP( KC+( N-K+1 ) ), WORK, 1,
$ ZERO, AP( KC+1 ), 1 )
AP( KC ) = AP( KC ) - DDOT( N-K, WORK, 1, AP( KC+1 ), 1 )
AP( KCNEXT+1 ) = AP( KCNEXT+1 ) -
$ DDOT( N-K, AP( KC+1 ), 1,
$ AP( KCNEXT+2 ), 1 )
CALL DCOPY( N-K, AP( KCNEXT+2 ), 1, WORK, 1 )
CALL DSPMV( UPLO, N-K, -ONE, AP( KC+( N-K+1 ) ), WORK, 1,
$ ZERO, AP( KCNEXT+2 ), 1 )
AP( KCNEXT ) = AP( KCNEXT ) -
$ DDOT( N-K, WORK, 1, AP( KCNEXT+2 ), 1 )
END IF
KSTEP = 2
KCNEXT = KCNEXT - ( N-K+3 )
END IF
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K ) THEN
*
* Interchange rows and columns K and KP in the trailing
* submatrix A(k-1:n,k-1:n)
*
KPC = NPP - ( N-KP+1 )*( N-KP+2 ) / 2 + 1
IF( KP.LT.N )
$ CALL DSWAP( N-KP, AP( KC+KP-K+1 ), 1, AP( KPC+1 ), 1 )
KX = KC + KP - K
DO 70 J = K + 1, KP - 1
KX = KX + N - J + 1
TEMP = AP( KC+J-K )
AP( KC+J-K ) = AP( KX )
AP( KX ) = TEMP
70 CONTINUE
TEMP = AP( KC )
AP( KC ) = AP( KPC )
AP( KPC ) = TEMP
IF( KSTEP.EQ.2 ) THEN
TEMP = AP( KC-N+K-1 )
AP( KC-N+K-1 ) = AP( KC-N+KP-1 )
AP( KC-N+KP-1 ) = TEMP
END IF
END IF
*
K = K - KSTEP
KC = KCNEXT
GO TO 60
80 CONTINUE
END IF
*
RETURN
*
* End of DSPTRI
*
END
SUBROUTINE DSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION AP( * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* DSPTRS solves a system of linear equations A*X = B with a real
* symmetric matrix A stored in packed format using the factorization
* A = U*D*U**T or A = L*D*L**T computed by DSPTRF.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the details of the factorization are stored
* as an upper or lower triangular matrix.
* = 'U': Upper triangular, form is A = U*D*U**T;
* = 'L': Lower triangular, form is A = L*D*L**T.
*
* 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.
*
* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The block diagonal matrix D and the multipliers used to
* obtain the factor U or L as computed by DSPTRF, stored as a
* packed triangular matrix.
*
* IPIV (input) INTEGER array, dimension (N)
* Details of the interchanges and the block structure of D
* as determined by DSPTRF.
*
* 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 UPPER
INTEGER J, K, KC, KP
DOUBLE PRECISION AK, AKM1, AKM1K, BK, BKM1, DENOM
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DGEMV, DGER, DSCAL, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSPTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Solve A*X = B, where A = U*D*U'.
*
* First solve U*D*X = B, overwriting B with X.
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = N
KC = N*( N+1 ) / 2 + 1
10 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 30
*
KC = KC - K
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(U(K)), where U(K) is the transformation
* stored in column K of A.
*
CALL DGER( K-1, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB,
$ B( 1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
CALL DSCAL( NRHS, ONE / AP( KC+K-1 ), B( K, 1 ), LDB )
K = K - 1
ELSE
*
* 2 x 2 diagonal block
*
* Interchange rows K-1 and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K-1 )
$ CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(U(K)), where U(K) is the transformation
* stored in columns K-1 and K of A.
*
CALL DGER( K-2, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB,
$ B( 1, 1 ), LDB )
CALL DGER( K-2, NRHS, -ONE, AP( KC-( K-1 ) ), 1,
$ B( K-1, 1 ), LDB, B( 1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
AKM1K = AP( KC+K-2 )
AKM1 = AP( KC-1 ) / AKM1K
AK = AP( KC+K-1 ) / AKM1K
DENOM = AKM1*AK - ONE
DO 20 J = 1, NRHS
BKM1 = B( K-1, J ) / AKM1K
BK = B( K, J ) / AKM1K
B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
20 CONTINUE
KC = KC - K + 1
K = K - 2
END IF
*
GO TO 10
30 CONTINUE
*
* Next solve U'*X = B, overwriting B with X.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
KC = 1
40 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 50
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Multiply by inv(U'(K)), where U(K) is the transformation
* stored in column K of A.
*
CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, AP( KC ),
$ 1, ONE, B( K, 1 ), LDB )
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
KC = KC + K
K = K + 1
ELSE
*
* 2 x 2 diagonal block
*
* Multiply by inv(U'(K+1)), where U(K+1) is the transformation
* stored in columns K and K+1 of A.
*
CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, AP( KC ),
$ 1, ONE, B( K, 1 ), LDB )
CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB,
$ AP( KC+K ), 1, ONE, B( K+1, 1 ), LDB )
*
* Interchange rows K and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
KC = KC + 2*K + 1
K = K + 2
END IF
*
GO TO 40
50 CONTINUE
*
ELSE
*
* Solve A*X = B, where A = L*D*L'.
*
* First solve L*D*X = B, overwriting B with X.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
KC = 1
60 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 80
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(L(K)), where L(K) is the transformation
* stored in column K of A.
*
IF( K.LT.N )
$ CALL DGER( N-K, NRHS, -ONE, AP( KC+1 ), 1, B( K, 1 ),
$ LDB, B( K+1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
CALL DSCAL( NRHS, ONE / AP( KC ), B( K, 1 ), LDB )
KC = KC + N - K + 1
K = K + 1
ELSE
*
* 2 x 2 diagonal block
*
* Interchange rows K+1 and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K+1 )
$ CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(L(K)), where L(K) is the transformation
* stored in columns K and K+1 of A.
*
IF( K.LT.N-1 ) THEN
CALL DGER( N-K-1, NRHS, -ONE, AP( KC+2 ), 1, B( K, 1 ),
$ LDB, B( K+2, 1 ), LDB )
CALL DGER( N-K-1, NRHS, -ONE, AP( KC+N-K+2 ), 1,
$ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
END IF
*
* Multiply by the inverse of the diagonal block.
*
AKM1K = AP( KC+1 )
AKM1 = AP( KC ) / AKM1K
AK = AP( KC+N-K+1 ) / AKM1K
DENOM = AKM1*AK - ONE
DO 70 J = 1, NRHS
BKM1 = B( K, J ) / AKM1K
BK = B( K+1, J ) / AKM1K
B( K, J ) = ( AK*BKM1-BK ) / DENOM
B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
70 CONTINUE
KC = KC + 2*( N-K ) + 1
K = K + 2
END IF
*
GO TO 60
80 CONTINUE
*
* Next solve L'*X = B, overwriting B with X.
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = N
KC = N*( N+1 ) / 2 + 1
90 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 100
*
KC = KC - ( N-K+1 )
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Multiply by inv(L'(K)), where L(K) is the transformation
* stored in column K of A.
*
IF( K.LT.N )
$ CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
$ LDB, AP( KC+1 ), 1, ONE, B( K, 1 ), LDB )
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
K = K - 1
ELSE
*
* 2 x 2 diagonal block
*
* Multiply by inv(L'(K-1)), where L(K-1) is the transformation
* stored in columns K-1 and K of A.
*
IF( K.LT.N ) THEN
CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
$ LDB, AP( KC+1 ), 1, ONE, B( K, 1 ), LDB )
CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
$ LDB, AP( KC-( N-K ) ), 1, ONE, B( K-1, 1 ),
$ LDB )
END IF
*
* Interchange rows K and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
KC = KC - ( N-K+2 )
K = K - 2
END IF
*
GO TO 90
100 CONTINUE
END IF
*
RETURN
*
* End of DSPTRS
*
END
SUBROUTINE DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E,
$ M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
* 8-18-00: Increase FUDGE factor for T3E (eca)
*
* .. Scalar Arguments ..
CHARACTER ORDER, RANGE
INTEGER IL, INFO, IU, M, N, NSPLIT
DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * )
DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DSTEBZ computes the eigenvalues of a symmetric tridiagonal
* matrix T. The user may ask for all eigenvalues, all eigenvalues
* in the half-open interval (VL, VU], or the IL-th through IU-th
* eigenvalues.
*
* To avoid overflow, the matrix must be scaled so that its
* largest element is no greater than overflow**(1/2) *
* underflow**(1/4) in absolute value, and for greatest
* accuracy, it should not be much smaller than that.
*
* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
* Matrix", Report CS41, Computer Science Dept., Stanford
* University, July 21, 1966.
*
* Arguments
* =========
*
* RANGE (input) CHARACTER*1
* = 'A': ("All") all eigenvalues will be found.
* = 'V': ("Value") all eigenvalues in the half-open interval
* (VL, VU] will be found.
* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
* entire matrix) will be found.
*
* ORDER (input) CHARACTER*1
* = 'B': ("By Block") the eigenvalues will be grouped by
* split-off block (see IBLOCK, ISPLIT) and
* ordered from smallest to largest within
* the block.
* = 'E': ("Entire matrix")
* the eigenvalues for the entire matrix
* will be ordered from smallest to
* largest.
*
* N (input) INTEGER
* The order of the tridiagonal matrix T. N >= 0.
*
* VL (input) DOUBLE PRECISION
* VU (input) DOUBLE PRECISION
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. Eigenvalues less than or equal
* to VL, or greater than VU, will not be returned. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* ABSTOL (input) DOUBLE PRECISION
* The absolute tolerance for the eigenvalues. An eigenvalue
* (or cluster) is considered to be located if it has been
* determined to lie in an interval whose width is ABSTOL or
* less. If ABSTOL is less than or equal to zero, then ULP*|T|
* will be used, where |T| means the 1-norm of T.
*
* Eigenvalues will be computed most accurately when ABSTOL is
* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the tridiagonal matrix T.
*
* E (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) off-diagonal elements of the tridiagonal matrix T.
*
* M (output) INTEGER
* The actual number of eigenvalues found. 0 <= M <= N.
* (See also the description of INFO=2,3.)
*
* NSPLIT (output) INTEGER
* The number of diagonal blocks in the matrix T.
* 1 <= NSPLIT <= N.
*
* W (output) DOUBLE PRECISION array, dimension (N)
* On exit, the first M elements of W will contain the
* eigenvalues. (DSTEBZ may use the remaining N-M elements as
* workspace.)
*
* IBLOCK (output) INTEGER array, dimension (N)
* At each row/column j where E(j) is zero or small, the
* matrix T is considered to split into a block diagonal
* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which
* block (from 1 to the number of blocks) the eigenvalue W(i)
* belongs. (DSTEBZ may use the remaining N-M elements as
* workspace.)
*
* ISPLIT (output) INTEGER array, dimension (N)
* The splitting points, at which T breaks up into submatrices.
* The first submatrix consists of rows/columns 1 to ISPLIT(1),
* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
* etc., and the NSPLIT-th consists of rows/columns
* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
* (Only the first NSPLIT elements will actually be used, but
* since the user cannot know a priori what value NSPLIT will
* have, N words must be reserved for ISPLIT.)
*
* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
*
* IWORK (workspace) INTEGER array, dimension (3*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: some or all of the eigenvalues failed to converge or
* were not computed:
* =1 or 3: Bisection failed to converge for some
* eigenvalues; these eigenvalues are flagged by a
* negative block number. The effect is that the
* eigenvalues may not be as accurate as the
* absolute and relative tolerances. This is
* generally caused by unexpectedly inaccurate
* arithmetic.
* =2 or 3: RANGE='I' only: Not all of the eigenvalues
* IL:IU were found.
* Effect: M < IU+1-IL
* Cause: non-monotonic arithmetic, causing the
* Sturm sequence to be non-monotonic.
* Cure: recalculate, using RANGE='A', and pick
* out eigenvalues IL:IU. In some cases,
* increasing the PARAMETER "FUDGE" may
* make things work.
* = 4: RANGE='I', and the Gershgorin interval
* initially used was too small. No eigenvalues
* were computed.
* Probable cause: your machine has sloppy
* floating-point arithmetic.
* Cure: Increase the PARAMETER "FUDGE",
* recompile, and try again.
*
* Internal Parameters
* ===================
*
* RELFAC DOUBLE PRECISION, default = 2.0e0
* The relative tolerance. An interval (a,b] lies within
* "relative tolerance" if b-a < RELFAC*ulp*max(|a|,|b|),
* where "ulp" is the machine precision (distance from 1 to
* the next larger floating point number.)
*
* FUDGE DOUBLE PRECISION, default = 2
* A "fudge factor" to widen the Gershgorin intervals. Ideally,
* a value of 1 should work, but on machines with sloppy
* arithmetic, this needs to be larger. The default for
* publicly released versions should be large enough to handle
* the worst machine around. Note that this has no effect
* on accuracy of the solution.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, HALF
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ HALF = 1.0D0 / TWO )
DOUBLE PRECISION FUDGE, RELFAC
PARAMETER ( FUDGE = 2.1D0, RELFAC = 2.0D0 )
* ..
* .. Local Scalars ..
LOGICAL NCNVRG, TOOFEW
INTEGER IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO,
$ IM, IN, IOFF, IORDER, IOUT, IRANGE, ITMAX,
$ ITMP1, IW, IWOFF, J, JB, JDISC, JE, NB, NWL,
$ NWU
DOUBLE PRECISION ATOLI, BNORM, GL, GU, PIVMIN, RTOLI, SAFEMN,
$ TMP1, TMP2, TNORM, ULP, WKILL, WL, WLU, WU, WUL
* ..
* .. Local Arrays ..
INTEGER IDUMMA( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, ILAENV, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DLAEBZ, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Decode RANGE
*
IF( LSAME( RANGE, 'A' ) ) THEN
IRANGE = 1
ELSE IF( LSAME( RANGE, 'V' ) ) THEN
IRANGE = 2
ELSE IF( LSAME( RANGE, 'I' ) ) THEN
IRANGE = 3
ELSE
IRANGE = 0
END IF
*
* Decode ORDER
*
IF( LSAME( ORDER, 'B' ) ) THEN
IORDER = 2
ELSE IF( LSAME( ORDER, 'E' ) ) THEN
IORDER = 1
ELSE
IORDER = 0
END IF
*
* Check for Errors
*
IF( IRANGE.LE.0 ) THEN
INFO = -1
ELSE IF( IORDER.LE.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( IRANGE.EQ.2 ) THEN
IF( VL.GE.VU )
$ INFO = -5
ELSE IF( IRANGE.EQ.3 .AND. ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) )
$ THEN
INFO = -6
ELSE IF( IRANGE.EQ.3 .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) )
$ THEN
INFO = -7
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSTEBZ', -INFO )
RETURN
END IF
*
* Initialize error flags
*
INFO = 0
NCNVRG = .FALSE.
TOOFEW = .FALSE.
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 )
$ RETURN
*
* Simplifications:
*
IF( IRANGE.EQ.3 .AND. IL.EQ.1 .AND. IU.EQ.N )
$ IRANGE = 1
*
* Get machine constants
* NB is the minimum vector length for vector bisection, or 0
* if only scalar is to be done.
*
SAFEMN = DLAMCH( 'S' )
ULP = DLAMCH( 'P' )
RTOLI = ULP*RELFAC
NB = ILAENV( 1, 'DSTEBZ', ' ', N, -1, -1, -1 )
IF( NB.LE.1 )
$ NB = 0
*
* Special Case when N=1
*
IF( N.EQ.1 ) THEN
NSPLIT = 1
ISPLIT( 1 ) = 1
IF( IRANGE.EQ.2 .AND. ( VL.GE.D( 1 ) .OR. VU.LT.D( 1 ) ) ) THEN
M = 0
ELSE
W( 1 ) = D( 1 )
IBLOCK( 1 ) = 1
M = 1
END IF
RETURN
END IF
*
* Compute Splitting Points
*
NSPLIT = 1
WORK( N ) = ZERO
PIVMIN = ONE
*
*DIR$ NOVECTOR
DO 10 J = 2, N
TMP1 = E( J-1 )**2
IF( ABS( D( J )*D( J-1 ) )*ULP**2+SAFEMN.GT.TMP1 ) THEN
ISPLIT( NSPLIT ) = J - 1
NSPLIT = NSPLIT + 1
WORK( J-1 ) = ZERO
ELSE
WORK( J-1 ) = TMP1
PIVMIN = MAX( PIVMIN, TMP1 )
END IF
10 CONTINUE
ISPLIT( NSPLIT ) = N
PIVMIN = PIVMIN*SAFEMN
*
* Compute Interval and ATOLI
*
IF( IRANGE.EQ.3 ) THEN
*
* RANGE='I': Compute the interval containing eigenvalues
* IL through IU.
*
* Compute Gershgorin interval for entire (split) matrix
* and use it as the initial interval
*
GU = D( 1 )
GL = D( 1 )
TMP1 = ZERO
*
DO 20 J = 1, N - 1
TMP2 = SQRT( WORK( J ) )
GU = MAX( GU, D( J )+TMP1+TMP2 )
GL = MIN( GL, D( J )-TMP1-TMP2 )
TMP1 = TMP2
20 CONTINUE
*
GU = MAX( GU, D( N )+TMP1 )
GL = MIN( GL, D( N )-TMP1 )
TNORM = MAX( ABS( GL ), ABS( GU ) )
GL = GL - FUDGE*TNORM*ULP*N - FUDGE*TWO*PIVMIN
GU = GU + FUDGE*TNORM*ULP*N + FUDGE*PIVMIN
*
* Compute Iteration parameters
*
ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) /
$ LOG( TWO ) ) + 2
IF( ABSTOL.LE.ZERO ) THEN
ATOLI = ULP*TNORM
ELSE
ATOLI = ABSTOL
END IF
*
WORK( N+1 ) = GL
WORK( N+2 ) = GL
WORK( N+3 ) = GU
WORK( N+4 ) = GU
WORK( N+5 ) = GL
WORK( N+6 ) = GU
IWORK( 1 ) = -1
IWORK( 2 ) = -1
IWORK( 3 ) = N + 1
IWORK( 4 ) = N + 1
IWORK( 5 ) = IL - 1
IWORK( 6 ) = IU
*
CALL DLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN, D, E,
$ WORK, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT,
$ IWORK, W, IBLOCK, IINFO )
*
IF( IWORK( 6 ).EQ.IU ) THEN
WL = WORK( N+1 )
WLU = WORK( N+3 )
NWL = IWORK( 1 )
WU = WORK( N+4 )
WUL = WORK( N+2 )
NWU = IWORK( 4 )
ELSE
WL = WORK( N+2 )
WLU = WORK( N+4 )
NWL = IWORK( 2 )
WU = WORK( N+3 )
WUL = WORK( N+1 )
NWU = IWORK( 3 )
END IF
*
IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN
INFO = 4
RETURN
END IF
ELSE
*
* RANGE='A' or 'V' -- Set ATOLI
*
TNORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ),
$ ABS( D( N ) )+ABS( E( N-1 ) ) )
*
DO 30 J = 2, N - 1
TNORM = MAX( TNORM, ABS( D( J ) )+ABS( E( J-1 ) )+
$ ABS( E( J ) ) )
30 CONTINUE
*
IF( ABSTOL.LE.ZERO ) THEN
ATOLI = ULP*TNORM
ELSE
ATOLI = ABSTOL
END IF
*
IF( IRANGE.EQ.2 ) THEN
WL = VL
WU = VU
ELSE
WL = ZERO
WU = ZERO
END IF
END IF
*
* Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU.
* NWL accumulates the number of eigenvalues .le. WL,
* NWU accumulates the number of eigenvalues .le. WU
*
M = 0
IEND = 0
INFO = 0
NWL = 0
NWU = 0
*
DO 70 JB = 1, NSPLIT
IOFF = IEND
IBEGIN = IOFF + 1
IEND = ISPLIT( JB )
IN = IEND - IOFF
*
IF( IN.EQ.1 ) THEN
*
* Special Case -- IN=1
*
IF( IRANGE.EQ.1 .OR. WL.GE.D( IBEGIN )-PIVMIN )
$ NWL = NWL + 1
IF( IRANGE.EQ.1 .OR. WU.GE.D( IBEGIN )-PIVMIN )
$ NWU = NWU + 1
IF( IRANGE.EQ.1 .OR. ( WL.LT.D( IBEGIN )-PIVMIN .AND. WU.GE.
$ D( IBEGIN )-PIVMIN ) ) THEN
M = M + 1
W( M ) = D( IBEGIN )
IBLOCK( M ) = JB
END IF
ELSE
*
* General Case -- IN > 1
*
* Compute Gershgorin Interval
* and use it as the initial interval
*
GU = D( IBEGIN )
GL = D( IBEGIN )
TMP1 = ZERO
*
DO 40 J = IBEGIN, IEND - 1
TMP2 = ABS( E( J ) )
GU = MAX( GU, D( J )+TMP1+TMP2 )
GL = MIN( GL, D( J )-TMP1-TMP2 )
TMP1 = TMP2
40 CONTINUE
*
GU = MAX( GU, D( IEND )+TMP1 )
GL = MIN( GL, D( IEND )-TMP1 )
BNORM = MAX( ABS( GL ), ABS( GU ) )
GL = GL - FUDGE*BNORM*ULP*IN - FUDGE*PIVMIN
GU = GU + FUDGE*BNORM*ULP*IN + FUDGE*PIVMIN
*
* Compute ATOLI for the current submatrix
*
IF( ABSTOL.LE.ZERO ) THEN
ATOLI = ULP*MAX( ABS( GL ), ABS( GU ) )
ELSE
ATOLI = ABSTOL
END IF
*
IF( IRANGE.GT.1 ) THEN
IF( GU.LT.WL ) THEN
NWL = NWL + IN
NWU = NWU + IN
GO TO 70
END IF
GL = MAX( GL, WL )
GU = MIN( GU, WU )
IF( GL.GE.GU )
$ GO TO 70
END IF
*
* Set Up Initial Interval
*
WORK( N+1 ) = GL
WORK( N+IN+1 ) = GU
CALL DLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
$ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ),
$ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM,
$ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
*
NWL = NWL + IWORK( 1 )
NWU = NWU + IWORK( IN+1 )
IWOFF = M - IWORK( 1 )
*
* Compute Eigenvalues
*
ITMAX = INT( ( LOG( GU-GL+PIVMIN )-LOG( PIVMIN ) ) /
$ LOG( TWO ) ) + 2
CALL DLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
$ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ),
$ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT,
$ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
*
* Copy Eigenvalues Into W and IBLOCK
* Use -JB for block number for unconverged eigenvalues.
*
DO 60 J = 1, IOUT
TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) )
*
* Flag non-convergence.
*
IF( J.GT.IOUT-IINFO ) THEN
NCNVRG = .TRUE.
IB = -JB
ELSE
IB = JB
END IF
DO 50 JE = IWORK( J ) + 1 + IWOFF,
$ IWORK( J+IN ) + IWOFF
W( JE ) = TMP1
IBLOCK( JE ) = IB
50 CONTINUE
60 CONTINUE
*
M = M + IM
END IF
70 CONTINUE
*
* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU
* If NWL+1 < IL or NWU > IU, discard extra eigenvalues.
*
IF( IRANGE.EQ.3 ) THEN
IM = 0
IDISCL = IL - 1 - NWL
IDISCU = NWU - IU
*
IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
DO 80 JE = 1, M
IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN
IDISCL = IDISCL - 1
ELSE IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN
IDISCU = IDISCU - 1
ELSE
IM = IM + 1
W( IM ) = W( JE )
IBLOCK( IM ) = IBLOCK( JE )
END IF
80 CONTINUE
M = IM
END IF
IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
*
* Code to deal with effects of bad arithmetic:
* Some low eigenvalues to be discarded are not in (WL,WLU],
* or high eigenvalues to be discarded are not in (WUL,WU]
* so just kill off the smallest IDISCL/largest IDISCU
* eigenvalues, by simply finding the smallest/largest
* eigenvalue(s).
*
* (If N(w) is monotone non-decreasing, this should never
* happen.)
*
IF( IDISCL.GT.0 ) THEN
WKILL = WU
DO 100 JDISC = 1, IDISCL
IW = 0
DO 90 JE = 1, M
IF( IBLOCK( JE ).NE.0 .AND.
$ ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN
IW = JE
WKILL = W( JE )
END IF
90 CONTINUE
IBLOCK( IW ) = 0
100 CONTINUE
END IF
IF( IDISCU.GT.0 ) THEN
*
WKILL = WL
DO 120 JDISC = 1, IDISCU
IW = 0
DO 110 JE = 1, M
IF( IBLOCK( JE ).NE.0 .AND.
$ ( W( JE ).GT.WKILL .OR. IW.EQ.0 ) ) THEN
IW = JE
WKILL = W( JE )
END IF
110 CONTINUE
IBLOCK( IW ) = 0
120 CONTINUE
END IF
IM = 0
DO 130 JE = 1, M
IF( IBLOCK( JE ).NE.0 ) THEN
IM = IM + 1
W( IM ) = W( JE )
IBLOCK( IM ) = IBLOCK( JE )
END IF
130 CONTINUE
M = IM
END IF
IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN
TOOFEW = .TRUE.
END IF
END IF
*
* If ORDER='B', do nothing -- the eigenvalues are already sorted
* by block.
* If ORDER='E', sort the eigenvalues from smallest to largest
*
IF( IORDER.EQ.1 .AND. NSPLIT.GT.1 ) THEN
DO 150 JE = 1, M - 1
IE = 0
TMP1 = W( JE )
DO 140 J = JE + 1, M
IF( W( J ).LT.TMP1 ) THEN
IE = J
TMP1 = W( J )
END IF
140 CONTINUE
*
IF( IE.NE.0 ) THEN
ITMP1 = IBLOCK( IE )
W( IE ) = W( JE )
IBLOCK( IE ) = IBLOCK( JE )
W( JE ) = TMP1
IBLOCK( JE ) = ITMP1
END IF
150 CONTINUE
END IF
*
INFO = 0
IF( NCNVRG )
$ INFO = INFO + 1
IF( TOOFEW )
$ INFO = INFO + 2
RETURN
*
* End of DSTEBZ
*
END
SUBROUTINE DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK,
$ LIWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER COMPZ
INTEGER INFO, LDZ, LIWORK, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DSTEDC computes all eigenvalues and, optionally, eigenvectors of a
* symmetric tridiagonal matrix using the divide and conquer method.
* The eigenvectors of a full or band real symmetric matrix can also be
* found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this
* matrix to tridiagonal form.
*
* This code makes very mild assumptions about floating point
* arithmetic. It will work on machines with a guard digit in
* add/subtract, or on those binary machines without guard digits
* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
* It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none. See DLAED3 for details.
*
* Arguments
* =========
*
* COMPZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only.
* = 'I': Compute eigenvectors of tridiagonal matrix also.
* = 'V': Compute eigenvectors of original dense symmetric
* matrix also. On entry, Z contains the orthogonal
* matrix used to reduce the original matrix to
* tridiagonal form.
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the diagonal elements of the tridiagonal matrix.
* On exit, if INFO = 0, the eigenvalues in ascending order.
*
* E (input/output) DOUBLE PRECISION array, dimension (N-1)
* On entry, the subdiagonal elements of the tridiagonal matrix.
* On exit, E has been destroyed.
*
* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
* On entry, if COMPZ = 'V', then Z contains the orthogonal
* matrix used in the reduction to tridiagonal form.
* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
* orthonormal eigenvectors of the original symmetric matrix,
* and if COMPZ = 'I', Z contains the orthonormal eigenvectors
* of the symmetric tridiagonal matrix.
* If COMPZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1.
* If eigenvectors are desired, then LDZ >= max(1,N).
*
* WORK (workspace/output) DOUBLE PRECISION array,
* dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* If COMPZ = 'N' or N <= 1 then LWORK must be at least 1.
* If COMPZ = 'V' and N > 1 then LWORK must be at least
* ( 1 + 3*N + 2*N*lg N + 3*N**2 ),
* where lg( N ) = smallest integer k such
* that 2**k >= N.
* If COMPZ = 'I' and N > 1 then LWORK must be at least
* ( 1 + 4*N + N**2 ).
* Note that for COMPZ = 'I' or 'V', then if N is less than or
* equal to the minimum divide size, usually 25, then LWORK need
* only be max(1,2*(N-1)).
*
* 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.
*
* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK.
* If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1.
* If COMPZ = 'V' and N > 1 then LIWORK must be at least
* ( 6 + 6*N + 5*N*lg N ).
* If COMPZ = 'I' and N > 1 then LIWORK must be at least
* ( 3 + 5*N ).
* Note that for COMPZ = 'I' or 'V', then if N is less than or
* equal to the minimum divide size, usually 25, then LIWORK
* need only be 1.
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal size of the IWORK array,
* returns this value as the first entry of the IWORK array, and
* no error message related to LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: The algorithm failed to compute an eigenvalue while
* working on the submatrix lying in rows and columns
* INFO/(N+1) through mod(INFO,N+1).
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
* Modified by Francoise Tisseur, University of Tennessee.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER FINISH, I, ICOMPZ, II, J, K, LGN, LIWMIN,
$ LWMIN, M, SMLSIZ, START, STOREZ, STRTRW
DOUBLE PRECISION EPS, ORGNRM, P, TINY
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANST
EXTERNAL LSAME, ILAENV, DLAMCH, DLANST
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLACPY, DLAED0, DLASCL, DLASET, DLASRT,
$ DSTEQR, DSTERF, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, INT, LOG, MAX, MOD, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
IF( LSAME( COMPZ, 'N' ) ) THEN
ICOMPZ = 0
ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
ICOMPZ = 1
ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
ICOMPZ = 2
ELSE
ICOMPZ = -1
END IF
IF( ICOMPZ.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ( LDZ.LT.1 ) .OR.
$ ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, N ) ) ) THEN
INFO = -6
END IF
*
IF( INFO.EQ.0 ) THEN
*
* Compute the workspace requirements
*
SMLSIZ = ILAENV( 9, 'DSTEDC', ' ', 0, 0, 0, 0 )
IF( N.LE.1 .OR. ICOMPZ.EQ.0 ) THEN
LIWMIN = 1
LWMIN = 1
ELSE IF( N.LE.SMLSIZ ) THEN
LIWMIN = 1
LWMIN = 2*( N - 1 )
ELSE
LGN = INT( LOG( DBLE( N ) )/LOG( TWO ) )
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IF( ICOMPZ.EQ.1 ) THEN
LWMIN = 1 + 3*N + 2*N*LGN + 3*N**2
LIWMIN = 6 + 6*N + 5*N*LGN
ELSE IF( ICOMPZ.EQ.2 ) THEN
LWMIN = 1 + 4*N + N**2
LIWMIN = 3 + 5*N
END IF
END IF
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
IF( LWORK.LT.LWMIN .AND. .NOT. LQUERY ) THEN
INFO = -8
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT. LQUERY ) THEN
INFO = -10
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSTEDC', -INFO )
RETURN
ELSE IF (LQUERY) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
IF( N.EQ.1 ) THEN
IF( ICOMPZ.NE.0 )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* If the following conditional clause is removed, then the routine
* will use the Divide and Conquer routine to compute only the
* eigenvalues, which requires (3N + 3N**2) real workspace and
* (2 + 5N + 2N lg(N)) integer workspace.
* Since on many architectures DSTERF is much faster than any other
* algorithm for finding eigenvalues only, it is used here
* as the default. If the conditional clause is removed, then
* information on the size of workspace needs to be changed.
*
* If COMPZ = 'N', use DSTERF to compute the eigenvalues.
*
IF( ICOMPZ.EQ.0 ) THEN
CALL DSTERF( N, D, E, INFO )
GO TO 50
END IF
*
* If N is smaller than the minimum divide size (SMLSIZ+1), then
* solve the problem with another solver.
*
IF( N.LE.SMLSIZ ) THEN
*
CALL DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
*
ELSE
*
* If COMPZ = 'V', the Z matrix must be stored elsewhere for later
* use.
*
IF( ICOMPZ.EQ.1 ) THEN
STOREZ = 1 + N*N
ELSE
STOREZ = 1
END IF
*
IF( ICOMPZ.EQ.2 ) THEN
CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
END IF
*
* Scale.
*
ORGNRM = DLANST( 'M', N, D, E )
IF( ORGNRM.EQ.ZERO )
$ GO TO 50
*
EPS = DLAMCH( 'Epsilon' )
*
START = 1
*
* while ( START <= N )
*
10 CONTINUE
IF( START.LE.N ) THEN
*
* Let FINISH be the position of the next subdiagonal entry
* such that E( FINISH ) <= TINY or FINISH = N if no such
* subdiagonal exists. The matrix identified by the elements
* between START and FINISH constitutes an independent
* sub-problem.
*
FINISH = START
20 CONTINUE
IF( FINISH.LT.N ) THEN
TINY = EPS*SQRT( ABS( D( FINISH ) ) )*
$ SQRT( ABS( D( FINISH+1 ) ) )
IF( ABS( E( FINISH ) ).GT.TINY ) THEN
FINISH = FINISH + 1
GO TO 20
END IF
END IF
*
* (Sub) Problem determined. Compute its size and solve it.
*
M = FINISH - START + 1
IF( M.EQ.1 ) THEN
START = FINISH + 1
GO TO 10
END IF
IF( M.GT.SMLSIZ ) THEN
*
* Scale.
*
ORGNRM = DLANST( 'M', M, D( START ), E( START ) )
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ), M,
$ INFO )
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1, E( START ),
$ M-1, INFO )
*
IF( ICOMPZ.EQ.1 ) THEN
STRTRW = 1
ELSE
STRTRW = START
END IF
CALL DLAED0( ICOMPZ, N, M, D( START ), E( START ),
$ Z( STRTRW, START ), LDZ, WORK( 1 ), N,
$ WORK( STOREZ ), IWORK, INFO )
IF( INFO.NE.0 ) THEN
INFO = ( INFO / ( M+1 )+START-1 )*( N+1 ) +
$ MOD( INFO, ( M+1 ) ) + START - 1
GO TO 50
END IF
*
* Scale back.
*
CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ), M,
$ INFO )
*
ELSE
IF( ICOMPZ.EQ.1 ) THEN
*
* Since QR won't update a Z matrix which is larger than
* the length of D, we must solve the sub-problem in a
* workspace and then multiply back into Z.
*
CALL DSTEQR( 'I', M, D( START ), E( START ), WORK, M,
$ WORK( M*M+1 ), INFO )
CALL DLACPY( 'A', N, M, Z( 1, START ), LDZ,
$ WORK( STOREZ ), N )
CALL DGEMM( 'N', 'N', N, M, M, ONE,
$ WORK( STOREZ ), N, WORK, M, ZERO,
$ Z( 1, START ), LDZ )
ELSE IF( ICOMPZ.EQ.2 ) THEN
CALL DSTEQR( 'I', M, D( START ), E( START ),
$ Z( START, START ), LDZ, WORK, INFO )
ELSE
CALL DSTERF( M, D( START ), E( START ), INFO )
END IF
IF( INFO.NE.0 ) THEN
INFO = START*( N+1 ) + FINISH
GO TO 50
END IF
END IF
*
START = FINISH + 1
GO TO 10
END IF
*
* endwhile
*
* If the problem split any number of times, then the eigenvalues
* will not be properly ordered. Here we permute the eigenvalues
* (and the associated eigenvectors) into ascending order.
*
IF( M.NE.N ) THEN
IF( ICOMPZ.EQ.0 ) THEN
*
* Use Quick Sort
*
CALL DLASRT( 'I', N, D, INFO )
*
ELSE
*
* Use Selection Sort to minimize swaps of eigenvectors
*
DO 40 II = 2, N
I = II - 1
K = I
P = D( I )
DO 30 J = II, N
IF( D( J ).LT.P ) THEN
K = J
P = D( J )
END IF
30 CONTINUE
IF( K.NE.I ) THEN
D( K ) = D( I )
D( I ) = P
CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
END IF
40 CONTINUE
END IF
END IF
END IF
*
50 CONTINUE
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
RETURN
*
* End of DSTEDC
*
END
SUBROUTINE DSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
$ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK,
$ LIWORK, INFO )
IMPLICIT NONE
*
*
* -- LAPACK computational routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE
INTEGER IL, INFO, IU, LDZ, LIWORK, LWORK, M, N
DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER ISUPPZ( * ), IWORK( * )
DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * )
DOUBLE PRECISION Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DSTEGR computes selected eigenvalues and, optionally, eigenvectors
* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
* a well defined set of pairwise different real eigenvalues, the corresponding
* real eigenvectors are pairwise orthogonal.
*
* The spectrum may be computed either completely or partially by specifying
* either an interval (VL,VU] or a range of indices IL:IU for the desired
* eigenvalues.
*
* DSTEGR is a compatability wrapper around the improved DSTEMR routine.
* See DSTEMR for further details.
*
* One important change is that the ABSTOL parameter no longer provides any
* benefit and hence is no longer used.
*
* Note : DSTEGR and DSTEMR work only on machines which follow
* IEEE-754 floating-point standard in their handling of infinities and
* NaNs. Normal execution may create these exceptiona values and hence
* may abort due to a floating point exception in environments which
* do not conform to the IEEE-754 standard.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* RANGE (input) CHARACTER*1
* = 'A': all eigenvalues will be found.
* = 'V': all eigenvalues in the half-open interval (VL,VU]
* will be found.
* = 'I': the IL-th through IU-th eigenvalues will be found.
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the N diagonal elements of the tridiagonal matrix
* T. On exit, D is overwritten.
*
* E (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the (N-1) subdiagonal elements of the tridiagonal
* matrix T in elements 1 to N-1 of E. E(N) need not be set on
* input, but is used internally as workspace.
* On exit, E is overwritten.
*
* VL (input) DOUBLE PRECISION
* VU (input) DOUBLE PRECISION
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* ABSTOL (input) DOUBLE PRECISION
* Unused. Was the absolute error tolerance for the
* eigenvalues/eigenvectors in previous versions.
*
* M (output) INTEGER
* The total number of eigenvalues found. 0 <= M <= N.
* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*
* W (output) DOUBLE PRECISION array, dimension (N)
* The first M elements contain the selected eigenvalues in
* ascending order.
*
* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
* contain the orthonormal eigenvectors of the matrix T
* corresponding to the selected eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* If JOBZ = 'N', then Z is not referenced.
* Note: the user must ensure that at least max(1,M) columns are
* supplied in the array Z; if RANGE = 'V', the exact value of M
* is not known in advance and an upper bound must be used.
* Supplying N columns is always safe.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', then LDZ >= max(1,N).
*
* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
* The support of the eigenvectors in Z, i.e., the indices
* indicating the nonzero elements in Z. The i-th computed eigenvector
* is nonzero only in elements ISUPPZ( 2*i-1 ) through
* ISUPPZ( 2*i ). This is relevant in the case when the matrix
* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
*
* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns the optimal
* (and minimal) LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK. LWORK >= max(1,18*N)
* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
* 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.
*
* IWORK (workspace/output) INTEGER array, dimension (LIWORK)
* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK. LIWORK >= max(1,10*N)
* if the eigenvectors are desired, and LIWORK >= max(1,8*N)
* if only the eigenvalues are to be computed.
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal size of the IWORK array,
* returns this value as the first entry of the IWORK array, and
* no error message related to LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* On exit, INFO
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = 1X, internal error in DLARRE,
* if INFO = 2X, internal error in DLARRV.
* Here, the digit X = ABS( IINFO ) < 10, where IINFO is
* the nonzero error code returned by DLARRE or
* DLARRV, respectively.
*
* Further Details
* ===============
*
* Based on contributions by
* Inderjit Dhillon, IBM Almaden, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, LBNL/NERSC, USA
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL TRYRAC
* ..
* .. External Subroutines ..
EXTERNAL DSTEMR
* ..
* .. Executable Statements ..
INFO = 0
TRYRAC = .FALSE.
CALL DSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
$ M, W, Z, LDZ, N, ISUPPZ, TRYRAC, WORK, LWORK,
$ IWORK, LIWORK, INFO )
*
* End of DSTEGR
*
END
SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK,
$ IWORK, IFAIL, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDZ, M, N
* ..
* .. Array Arguments ..
INTEGER IBLOCK( * ), IFAIL( * ), ISPLIT( * ),
$ IWORK( * )
DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DSTEIN computes the eigenvectors of a real symmetric tridiagonal
* matrix T corresponding to specified eigenvalues, using inverse
* iteration.
*
* The maximum number of iterations allowed for each eigenvector is
* specified by an internal parameter MAXITS (currently set to 5).
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the tridiagonal matrix T.
*
* E (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) subdiagonal elements of the tridiagonal matrix
* T, in elements 1 to N-1.
*
* M (input) INTEGER
* The number of eigenvectors to be found. 0 <= M <= N.
*
* W (input) DOUBLE PRECISION array, dimension (N)
* The first M elements of W contain the eigenvalues for
* which eigenvectors are to be computed. The eigenvalues
* should be grouped by split-off block and ordered from
* smallest to largest within the block. ( The output array
* W from DSTEBZ with ORDER = 'B' is expected here. )
*
* IBLOCK (input) INTEGER array, dimension (N)
* The submatrix indices associated with the corresponding
* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to
* the first submatrix from the top, =2 if W(i) belongs to
* the second submatrix, etc. ( The output array IBLOCK
* from DSTEBZ is expected here. )
*
* ISPLIT (input) INTEGER array, dimension (N)
* The splitting points, at which T breaks up into submatrices.
* The first submatrix consists of rows/columns 1 to
* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
* through ISPLIT( 2 ), etc.
* ( The output array ISPLIT from DSTEBZ is expected here. )
*
* Z (output) DOUBLE PRECISION array, dimension (LDZ, M)
* The computed eigenvectors. The eigenvector associated
* with the eigenvalue W(i) is stored in the i-th column of
* Z. Any vector which fails to converge is set to its current
* iterate after MAXITS iterations.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= max(1,N).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (5*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* IFAIL (output) INTEGER array, dimension (M)
* On normal exit, all elements of IFAIL are zero.
* If one or more eigenvectors fail to converge after
* MAXITS iterations, then their indices are stored in
* array IFAIL.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, then i eigenvectors failed to converge
* in MAXITS iterations. Their indices are stored in
* array IFAIL.
*
* Internal Parameters
* ===================
*
* MAXITS INTEGER, default = 5
* The maximum number of iterations performed.
*
* EXTRA INTEGER, default = 2
* The number of iterations performed after norm growth
* criterion is satisfied, should be at least 1.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TEN, ODM3, ODM1
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1,
$ ODM3 = 1.0D-3, ODM1 = 1.0D-1 )
INTEGER MAXITS, EXTRA
PARAMETER ( MAXITS = 5, EXTRA = 2 )
* ..
* .. Local Scalars ..
INTEGER B1, BLKSIZ, BN, GPIND, I, IINFO, INDRV1,
$ INDRV2, INDRV3, INDRV4, INDRV5, ITS, J, J1,
$ JBLK, JMAX, NBLK, NRMCHK
DOUBLE PRECISION DTPCRT, EPS, EPS1, NRM, ONENRM, ORTOL, PERTOL,
$ SCL, SEP, TOL, XJ, XJM, ZTR
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 )
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DASUM, DDOT, DLAMCH, DNRM2
EXTERNAL IDAMAX, DASUM, DDOT, DLAMCH, DNRM2
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DLAGTF, DLAGTS, DLARNV, DSCAL,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
DO 10 I = 1, M
IFAIL( I ) = 0
10 CONTINUE
*
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( M.LT.0 .OR. M.GT.N ) THEN
INFO = -4
ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE
DO 20 J = 2, M
IF( IBLOCK( J ).LT.IBLOCK( J-1 ) ) THEN
INFO = -6
GO TO 30
END IF
IF( IBLOCK( J ).EQ.IBLOCK( J-1 ) .AND. W( J ).LT.W( J-1 ) )
$ THEN
INFO = -5
GO TO 30
END IF
20 CONTINUE
30 CONTINUE
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSTEIN', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. M.EQ.0 ) THEN
RETURN
ELSE IF( N.EQ.1 ) THEN
Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
EPS = DLAMCH( 'Precision' )
*
* Initialize seed for random number generator DLARNV.
*
DO 40 I = 1, 4
ISEED( I ) = 1
40 CONTINUE
*
* Initialize pointers.
*
INDRV1 = 0
INDRV2 = INDRV1 + N
INDRV3 = INDRV2 + N
INDRV4 = INDRV3 + N
INDRV5 = INDRV4 + N
*
* Compute eigenvectors of matrix blocks.
*
J1 = 1
DO 160 NBLK = 1, IBLOCK( M )
*
* Find starting and ending indices of block nblk.
*
IF( NBLK.EQ.1 ) THEN
B1 = 1
ELSE
B1 = ISPLIT( NBLK-1 ) + 1
END IF
BN = ISPLIT( NBLK )
BLKSIZ = BN - B1 + 1
IF( BLKSIZ.EQ.1 )
$ GO TO 60
GPIND = B1
*
* Compute reorthogonalization criterion and stopping criterion.
*
ONENRM = ABS( D( B1 ) ) + ABS( E( B1 ) )
ONENRM = MAX( ONENRM, ABS( D( BN ) )+ABS( E( BN-1 ) ) )
DO 50 I = B1 + 1, BN - 1
ONENRM = MAX( ONENRM, ABS( D( I ) )+ABS( E( I-1 ) )+
$ ABS( E( I ) ) )
50 CONTINUE
ORTOL = ODM3*ONENRM
*
DTPCRT = SQRT( ODM1 / BLKSIZ )
*
* Loop through eigenvalues of block nblk.
*
60 CONTINUE
JBLK = 0
DO 150 J = J1, M
IF( IBLOCK( J ).NE.NBLK ) THEN
J1 = J
GO TO 160
END IF
JBLK = JBLK + 1
XJ = W( J )
*
* Skip all the work if the block size is one.
*
IF( BLKSIZ.EQ.1 ) THEN
WORK( INDRV1+1 ) = ONE
GO TO 120
END IF
*
* If eigenvalues j and j-1 are too close, add a relatively
* small perturbation.
*
IF( JBLK.GT.1 ) THEN
EPS1 = ABS( EPS*XJ )
PERTOL = TEN*EPS1
SEP = XJ - XJM
IF( SEP.LT.PERTOL )
$ XJ = XJM + PERTOL
END IF
*
ITS = 0
NRMCHK = 0
*
* Get random starting vector.
*
CALL DLARNV( 2, ISEED, BLKSIZ, WORK( INDRV1+1 ) )
*
* Copy the matrix T so it won't be destroyed in factorization.
*
CALL DCOPY( BLKSIZ, D( B1 ), 1, WORK( INDRV4+1 ), 1 )
CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV2+2 ), 1 )
CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV3+1 ), 1 )
*
* Compute LU factors with partial pivoting ( PT = LU )
*
TOL = ZERO
CALL DLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, WORK( INDRV2+2 ),
$ WORK( INDRV3+1 ), TOL, WORK( INDRV5+1 ), IWORK,
$ IINFO )
*
* Update iteration count.
*
70 CONTINUE
ITS = ITS + 1
IF( ITS.GT.MAXITS )
$ GO TO 100
*
* Normalize and scale the righthand side vector Pb.
*
SCL = BLKSIZ*ONENRM*MAX( EPS,
$ ABS( WORK( INDRV4+BLKSIZ ) ) ) /
$ DASUM( BLKSIZ, WORK( INDRV1+1 ), 1 )
CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 )
*
* Solve the system LU = Pb.
*
CALL DLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), WORK( INDRV2+2 ),
$ WORK( INDRV3+1 ), WORK( INDRV5+1 ), IWORK,
$ WORK( INDRV1+1 ), TOL, IINFO )
*
* Reorthogonalize by modified Gram-Schmidt if eigenvalues are
* close enough.
*
IF( JBLK.EQ.1 )
$ GO TO 90
IF( ABS( XJ-XJM ).GT.ORTOL )
$ GPIND = J
IF( GPIND.NE.J ) THEN
DO 80 I = GPIND, J - 1
ZTR = -DDOT( BLKSIZ, WORK( INDRV1+1 ), 1, Z( B1, I ),
$ 1 )
CALL DAXPY( BLKSIZ, ZTR, Z( B1, I ), 1,
$ WORK( INDRV1+1 ), 1 )
80 CONTINUE
END IF
*
* Check the infinity norm of the iterate.
*
90 CONTINUE
JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 )
NRM = ABS( WORK( INDRV1+JMAX ) )
*
* Continue for additional iterations after norm reaches
* stopping criterion.
*
IF( NRM.LT.DTPCRT )
$ GO TO 70
NRMCHK = NRMCHK + 1
IF( NRMCHK.LT.EXTRA+1 )
$ GO TO 70
*
GO TO 110
*
* If stopping criterion was not satisfied, update info and
* store eigenvector number in array ifail.
*
100 CONTINUE
INFO = INFO + 1
IFAIL( INFO ) = J
*
* Accept iterate as jth eigenvector.
*
110 CONTINUE
SCL = ONE / DNRM2( BLKSIZ, WORK( INDRV1+1 ), 1 )
JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 )
IF( WORK( INDRV1+JMAX ).LT.ZERO )
$ SCL = -SCL
CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 )
120 CONTINUE
DO 130 I = 1, N
Z( I, J ) = ZERO
130 CONTINUE
DO 140 I = 1, BLKSIZ
Z( B1+I-1, J ) = WORK( INDRV1+I )
140 CONTINUE
*
* Save the shift to check eigenvalue spacing at next
* iteration.
*
XJM = XJ
*
150 CONTINUE
160 CONTINUE
*
RETURN
*
* End of DSTEIN
*
END
SUBROUTINE DSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
$ M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK,
$ IWORK, LIWORK, INFO )
IMPLICIT NONE
*
* -- LAPACK computational routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE
LOGICAL TRYRAC
INTEGER IL, INFO, IU, LDZ, NZC, LIWORK, LWORK, M, N
DOUBLE PRECISION VL, VU
* ..
* .. Array Arguments ..
INTEGER ISUPPZ( * ), IWORK( * )
DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * )
DOUBLE PRECISION Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DSTEMR computes selected eigenvalues and, optionally, eigenvectors
* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
* a well defined set of pairwise different real eigenvalues, the corresponding
* real eigenvectors are pairwise orthogonal.
*
* The spectrum may be computed either completely or partially by specifying
* either an interval (VL,VU] or a range of indices IL:IU for the desired
* eigenvalues.
*
* Depending on the number of desired eigenvalues, these are computed either
* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are
* computed by the use of various suitable L D L^T factorizations near clusters
* of close eigenvalues (referred to as RRRs, Relatively Robust
* Representations). An informal sketch of the algorithm follows.
*
* For each unreduced block (submatrix) of T,
* (a) Compute T - sigma I = L D L^T, so that L and D
* define all the wanted eigenvalues to high relative accuracy.
* This means that small relative changes in the entries of D and L
* cause only small relative changes in the eigenvalues and
* eigenvectors. The standard (unfactored) representation of the
* tridiagonal matrix T does not have this property in general.
* (b) Compute the eigenvalues to suitable accuracy.
* If the eigenvectors are desired, the algorithm attains full
* accuracy of the computed eigenvalues only right before
* the corresponding vectors have to be computed, see steps c) and d).
* (c) For each cluster of close eigenvalues, select a new
* shift close to the cluster, find a new factorization, and refine
* the shifted eigenvalues to suitable accuracy.
* (d) For each eigenvalue with a large enough relative separation compute
* the corresponding eigenvector by forming a rank revealing twisted
* factorization. Go back to (c) for any clusters that remain.
*
* For more details, see:
* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
* 2004. Also LAPACK Working Note 154.
* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
* tridiagonal eigenvalue/eigenvector problem",
* Computer Science Division Technical Report No. UCB/CSD-97-971,
* UC Berkeley, May 1997.
*
* Notes:
* 1.DSTEMR works only on machines which follow IEEE-754
* floating-point standard in their handling of infinities and NaNs.
* This permits the use of efficient inner loops avoiding a check for
* zero divisors.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* RANGE (input) CHARACTER*1
* = 'A': all eigenvalues will be found.
* = 'V': all eigenvalues in the half-open interval (VL,VU]
* will be found.
* = 'I': the IL-th through IU-th eigenvalues will be found.
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the N diagonal elements of the tridiagonal matrix
* T. On exit, D is overwritten.
*
* E (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the (N-1) subdiagonal elements of the tridiagonal
* matrix T in elements 1 to N-1 of E. E(N) need not be set on
* input, but is used internally as workspace.
* On exit, E is overwritten.
*
* VL (input) DOUBLE PRECISION
* VU (input) DOUBLE PRECISION
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* M (output) INTEGER
* The total number of eigenvalues found. 0 <= M <= N.
* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*
* W (output) DOUBLE PRECISION array, dimension (N)
* The first M elements contain the selected eigenvalues in
* ascending order.
*
* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
* contain the orthonormal eigenvectors of the matrix T
* corresponding to the selected eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* If JOBZ = 'N', then Z is not referenced.
* Note: the user must ensure that at least max(1,M) columns are
* supplied in the array Z; if RANGE = 'V', the exact value of M
* is not known in advance and can be computed with a workspace
* query by setting NZC = -1, see below.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', then LDZ >= max(1,N).
*
* NZC (input) INTEGER
* The number of eigenvectors to be held in the array Z.
* If RANGE = 'A', then NZC >= max(1,N).
* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].
* If RANGE = 'I', then NZC >= IU-IL+1.
* If NZC = -1, then a workspace query is assumed; the
* routine calculates the number of columns of the array Z that
* are needed to hold the eigenvectors.
* This value is returned as the first entry of the Z array, and
* no error message related to NZC is issued by XERBLA.
*
* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
* The support of the eigenvectors in Z, i.e., the indices
* indicating the nonzero elements in Z. The i-th computed eigenvector
* is nonzero only in elements ISUPPZ( 2*i-1 ) through
* ISUPPZ( 2*i ). This is relevant in the case when the matrix
* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
*
* TRYRAC (input/output) LOGICAL
* If TRYRAC.EQ..TRUE., indicates that the code should check whether
* the tridiagonal matrix defines its eigenvalues to high relative
* accuracy. If so, the code uses relative-accuracy preserving
* algorithms that might be (a bit) slower depending on the matrix.
* If the matrix does not define its eigenvalues to high relative
* accuracy, the code can uses possibly faster algorithms.
* If TRYRAC.EQ..FALSE., the code is not required to guarantee
* relatively accurate eigenvalues and can use the fastest possible
* techniques.
* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix
* does not define its eigenvalues to high relative accuracy.
*
* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns the optimal
* (and minimal) LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK. LWORK >= max(1,18*N)
* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
* 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.
*
* IWORK (workspace/output) INTEGER array, dimension (LIWORK)
* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK. LIWORK >= max(1,10*N)
* if the eigenvectors are desired, and LIWORK >= max(1,8*N)
* if only the eigenvalues are to be computed.
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal size of the IWORK array,
* returns this value as the first entry of the IWORK array, and
* no error message related to LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* On exit, INFO
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = 1X, internal error in DLARRE,
* if INFO = 2X, internal error in DLARRV.
* Here, the digit X = ABS( IINFO ) < 10, where IINFO is
* the nonzero error code returned by DLARRE or
* DLARRV, respectively.
*
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, FOUR, MINRGP
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0,
$ FOUR = 4.0D0,
$ MINRGP = 1.0D-3 )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, LQUERY, VALEIG, WANTZ, ZQUERY
INTEGER I, IBEGIN, IEND, IFIRST, IIL, IINDBL, IINDW,
$ IINDWK, IINFO, IINSPL, IIU, ILAST, IN, INDD,
$ INDE2, INDERR, INDGP, INDGRS, INDWRK, ITMP,
$ ITMP2, J, JBLK, JJ, LIWMIN, LWMIN, NSPLIT,
$ NZCMIN, OFFSET, WBEGIN, WEND
DOUBLE PRECISION BIGNUM, CS, EPS, PIVMIN, R1, R2, RMAX, RMIN,
$ RTOL1, RTOL2, SAFMIN, SCALE, SMLNUM, SN,
$ THRESH, TMP, TNRM, WL, WU
* ..
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANST
EXTERNAL LSAME, DLAMCH, DLANST
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLAE2, DLAEV2, DLARRC, DLARRE, DLARRJ,
$ DLARRR, DLARRV, DLASRT, DSCAL, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
*
LQUERY = ( ( LWORK.EQ.-1 ).OR.( LIWORK.EQ.-1 ) )
ZQUERY = ( NZC.EQ.-1 )
TRYRAC = ( INFO.NE.0 )
* DSTEMR needs WORK of size 6*N, IWORK of size 3*N.
* In addition, DLARRE needs WORK of size 6*N, IWORK of size 5*N.
* Furthermore, DLARRV needs WORK of size 12*N, IWORK of size 7*N.
IF( WANTZ ) THEN
LWMIN = 18*N
LIWMIN = 10*N
ELSE
* need less workspace if only the eigenvalues are wanted
LWMIN = 12*N
LIWMIN = 8*N
ENDIF
WL = ZERO
WU = ZERO
IIL = 0
IIU = 0
IF( VALEIG ) THEN
* We do not reference VL, VU in the cases RANGE = 'I','A'
* The interval (WL, WU] contains all the wanted eigenvalues.
* It is either given by the user or computed in DLARRE.
WL = VL
WU = VU
ELSEIF( INDEIG ) THEN
* We do not reference IL, IU in the cases RANGE = 'V','A'
IIL = IL
IIU = IU
ENDIF
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( VALEIG .AND. N.GT.0 .AND. WU.LE.WL ) THEN
INFO = -7
ELSE IF( INDEIG .AND. ( IIL.LT.1 .OR. IIL.GT.N ) ) THEN
INFO = -8
ELSE IF( INDEIG .AND. ( IIU.LT.IIL .OR. IIU.GT.N ) ) THEN
INFO = -9
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -13
ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -17
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -19
END IF
*
* Get machine constants.
*
SAFMIN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
*
IF( INFO.EQ.0 ) THEN
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
IF( WANTZ .AND. ALLEIG ) THEN
NZCMIN = N
ELSE IF( WANTZ .AND. VALEIG ) THEN
CALL DLARRC( 'T', N, VL, VU, D, E, SAFMIN,
$ NZCMIN, ITMP, ITMP2, INFO )
ELSE IF( WANTZ .AND. INDEIG ) THEN
NZCMIN = IIU-IIL+1
ELSE
* WANTZ .EQ. FALSE.
NZCMIN = 0
ENDIF
IF( ZQUERY .AND. INFO.EQ.0 ) THEN
Z( 1,1 ) = NZCMIN
ELSE IF( NZC.LT.NZCMIN .AND. .NOT.ZQUERY ) THEN
INFO = -14
END IF
END IF
IF( INFO.NE.0 ) THEN
*
CALL XERBLA( 'DSTEMR', -INFO )
*
RETURN
ELSE IF( LQUERY .OR. ZQUERY ) THEN
RETURN
END IF
*
* Handle N = 0, 1, and 2 cases immediately
*
M = 0
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( ALLEIG .OR. INDEIG ) THEN
M = 1
W( 1 ) = D( 1 )
ELSE
IF( WL.LT.D( 1 ) .AND. WU.GE.D( 1 ) ) THEN
M = 1
W( 1 ) = D( 1 )
END IF
END IF
IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
Z( 1, 1 ) = ONE
ISUPPZ(1) = 1
ISUPPZ(2) = 1
END IF
RETURN
END IF
*
IF( N.EQ.2 ) THEN
IF( .NOT.WANTZ ) THEN
CALL DLAE2( D(1), E(1), D(2), R1, R2 )
ELSE IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
CALL DLAEV2( D(1), E(1), D(2), R1, R2, CS, SN )
END IF
IF( ALLEIG.OR.
$ (VALEIG.AND.(R2.GT.WL).AND.
$ (R2.LE.WU)).OR.
$ (INDEIG.AND.(IIL.EQ.1)) ) THEN
M = M+1
W( M ) = R2
IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
Z( 1, M ) = -SN
Z( 2, M ) = CS
* Note: At most one of SN and CS can be zero.
IF (SN.NE.ZERO) THEN
IF (CS.NE.ZERO) THEN
ISUPPZ(2*M-1) = 1
ISUPPZ(2*M-1) = 2
ELSE
ISUPPZ(2*M-1) = 1
ISUPPZ(2*M-1) = 1
END IF
ELSE
ISUPPZ(2*M-1) = 2
ISUPPZ(2*M) = 2
END IF
ENDIF
ENDIF
IF( ALLEIG.OR.
$ (VALEIG.AND.(R1.GT.WL).AND.
$ (R1.LE.WU)).OR.
$ (INDEIG.AND.(IIU.EQ.2)) ) THEN
M = M+1
W( M ) = R1
IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
Z( 1, M ) = CS
Z( 2, M ) = SN
* Note: At most one of SN and CS can be zero.
IF (SN.NE.ZERO) THEN
IF (CS.NE.ZERO) THEN
ISUPPZ(2*M-1) = 1
ISUPPZ(2*M-1) = 2
ELSE
ISUPPZ(2*M-1) = 1
ISUPPZ(2*M-1) = 1
END IF
ELSE
ISUPPZ(2*M-1) = 2
ISUPPZ(2*M) = 2
END IF
ENDIF
ENDIF
RETURN
END IF
* Continue with general N
INDGRS = 1
INDERR = 2*N + 1
INDGP = 3*N + 1
INDD = 4*N + 1
INDE2 = 5*N + 1
INDWRK = 6*N + 1
*
IINSPL = 1
IINDBL = N + 1
IINDW = 2*N + 1
IINDWK = 3*N + 1
*
* Scale matrix to allowable range, if necessary.
* The allowable range is related to the PIVMIN parameter; see the
* comments in DLARRD. The preference for scaling small values
* up is heuristic; we expect users' matrices not to be close to the
* RMAX threshold.
*
SCALE = ONE
TNRM = DLANST( 'M', N, D, E )
IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
SCALE = RMIN / TNRM
ELSE IF( TNRM.GT.RMAX ) THEN
SCALE = RMAX / TNRM
END IF
IF( SCALE.NE.ONE ) THEN
CALL DSCAL( N, SCALE, D, 1 )
CALL DSCAL( N-1, SCALE, E, 1 )
TNRM = TNRM*SCALE
IF( VALEIG ) THEN
* If eigenvalues in interval have to be found,
* scale (WL, WU] accordingly
WL = WL*SCALE
WU = WU*SCALE
ENDIF
END IF
*
* Compute the desired eigenvalues of the tridiagonal after splitting
* into smaller subblocks if the corresponding off-diagonal elements
* are small
* THRESH is the splitting parameter for DLARRE
* A negative THRESH forces the old splitting criterion based on the
* size of the off-diagonal. A positive THRESH switches to splitting
* which preserves relative accuracy.
*
IF( TRYRAC ) THEN
* Test whether the matrix warrants the more expensive relative approach.
CALL DLARRR( N, D, E, IINFO )
ELSE
* The user does not care about relative accurately eigenvalues
IINFO = -1
ENDIF
* Set the splitting criterion
IF (IINFO.EQ.0) THEN
THRESH = EPS
ELSE
THRESH = -EPS
* relative accuracy is desired but T does not guarantee it
TRYRAC = .FALSE.
ENDIF
*
IF( TRYRAC ) THEN
* Copy original diagonal, needed to guarantee relative accuracy
CALL DCOPY(N,D,1,WORK(INDD),1)
ENDIF
* Store the squares of the offdiagonal values of T
DO 5 J = 1, N-1
WORK( INDE2+J-1 ) = E(J)**2
5 CONTINUE
* Set the tolerance parameters for bisection
IF( .NOT.WANTZ ) THEN
* DLARRE computes the eigenvalues to full precision.
RTOL1 = FOUR * EPS
RTOL2 = FOUR * EPS
ELSE
* DLARRE computes the eigenvalues to less than full precision.
* DLARRV will refine the eigenvalue approximations, and we can
* need less accurate initial bisection in DLARRE.
* Note: these settings do only affect the subset case and DLARRE
RTOL1 = SQRT(EPS)
RTOL2 = MAX( SQRT(EPS)*5.0D-3, FOUR * EPS )
ENDIF
CALL DLARRE( RANGE, N, WL, WU, IIL, IIU, D, E,
$ WORK(INDE2), RTOL1, RTOL2, THRESH, NSPLIT,
$ IWORK( IINSPL ), M, W, WORK( INDERR ),
$ WORK( INDGP ), IWORK( IINDBL ),
$ IWORK( IINDW ), WORK( INDGRS ), PIVMIN,
$ WORK( INDWRK ), IWORK( IINDWK ), IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 10 + ABS( IINFO )
RETURN
END IF
* Note that if RANGE .NE. 'V', DLARRE computes bounds on the desired
* part of the spectrum. All desired eigenvalues are contained in
* (WL,WU]
IF( WANTZ ) THEN
*
* Compute the desired eigenvectors corresponding to the computed
* eigenvalues
*
CALL DLARRV( N, WL, WU, D, E,
$ PIVMIN, IWORK( IINSPL ), M,
$ 1, M, MINRGP, RTOL1, RTOL2,
$ W, WORK( INDERR ), WORK( INDGP ), IWORK( IINDBL ),
$ IWORK( IINDW ), WORK( INDGRS ), Z, LDZ,
$ ISUPPZ, WORK( INDWRK ), IWORK( IINDWK ), IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 20 + ABS( IINFO )
RETURN
END IF
ELSE
* DLARRE computes eigenvalues of the (shifted) root representation
* DLARRV returns the eigenvalues of the unshifted matrix.
* However, if the eigenvectors are not desired by the user, we need
* to apply the corresponding shifts from DLARRE to obtain the
* eigenvalues of the original matrix.
DO 20 J = 1, M
ITMP = IWORK( IINDBL+J-1 )
W( J ) = W( J ) + E( IWORK( IINSPL+ITMP-1 ) )
20 CONTINUE
END IF
*
IF ( TRYRAC ) THEN
* Refine computed eigenvalues so that they are relatively accurate
* with respect to the original matrix T.
IBEGIN = 1
WBEGIN = 1
DO 39 JBLK = 1, IWORK( IINDBL+M-1 )
IEND = IWORK( IINSPL+JBLK-1 )
IN = IEND - IBEGIN + 1
WEND = WBEGIN - 1
* check if any eigenvalues have to be refined in this block
36 CONTINUE
IF( WEND.LT.M ) THEN
IF( IWORK( IINDBL+WEND ).EQ.JBLK ) THEN
WEND = WEND + 1
GO TO 36
END IF
END IF
IF( WEND.LT.WBEGIN ) THEN
IBEGIN = IEND + 1
GO TO 39
END IF
OFFSET = IWORK(IINDW+WBEGIN-1)-1
IFIRST = IWORK(IINDW+WBEGIN-1)
ILAST = IWORK(IINDW+WEND-1)
RTOL2 = FOUR * EPS
CALL DLARRJ( IN,
$ WORK(INDD+IBEGIN-1), WORK(INDE2+IBEGIN-1),
$ IFIRST, ILAST, RTOL2, OFFSET, W(WBEGIN),
$ WORK( INDERR+WBEGIN-1 ),
$ WORK( INDWRK ), IWORK( IINDWK ), PIVMIN,
$ TNRM, IINFO )
IBEGIN = IEND + 1
WBEGIN = WEND + 1
39 CONTINUE
ENDIF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( SCALE.NE.ONE ) THEN
CALL DSCAL( M, ONE / SCALE, W, 1 )
END IF
*
* If eigenvalues are not in increasing order, then sort them,
* possibly along with eigenvectors.
*
IF( NSPLIT.GT.1 ) THEN
IF( .NOT. WANTZ ) THEN
CALL DLASRT( 'I', M, W, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 3
RETURN
END IF
ELSE
DO 60 J = 1, M - 1
I = 0
TMP = W( J )
DO 50 JJ = J + 1, M
IF( W( JJ ).LT.TMP ) THEN
I = JJ
TMP = W( JJ )
END IF
50 CONTINUE
IF( I.NE.0 ) THEN
W( I ) = W( J )
W( J ) = TMP
IF( WANTZ ) THEN
CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
ITMP = ISUPPZ( 2*I-1 )
ISUPPZ( 2*I-1 ) = ISUPPZ( 2*J-1 )
ISUPPZ( 2*J-1 ) = ITMP
ITMP = ISUPPZ( 2*I )
ISUPPZ( 2*I ) = ISUPPZ( 2*J )
ISUPPZ( 2*J ) = ITMP
END IF
END IF
60 CONTINUE
END IF
ENDIF
*
*
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
RETURN
*
* End of DSTEMR
*
END
SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER COMPZ
INTEGER INFO, LDZ, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DSTEQR computes all eigenvalues and, optionally, eigenvectors of a
* symmetric tridiagonal matrix using the implicit QL or QR method.
* The eigenvectors of a full or band symmetric matrix can also be found
* if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to
* tridiagonal form.
*
* Arguments
* =========
*
* COMPZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only.
* = 'V': Compute eigenvalues and eigenvectors of the original
* symmetric matrix. On entry, Z must contain the
* orthogonal matrix used to reduce the original matrix
* to tridiagonal form.
* = 'I': Compute eigenvalues and eigenvectors of the
* tridiagonal matrix. Z is initialized to the identity
* matrix.
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the diagonal elements of the tridiagonal matrix.
* On exit, if INFO = 0, the eigenvalues in ascending order.
*
* E (input/output) DOUBLE PRECISION array, dimension (N-1)
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix.
* On exit, E has been destroyed.
*
* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
* On entry, if COMPZ = 'V', then Z contains the orthogonal
* matrix used in the reduction to tridiagonal form.
* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
* orthonormal eigenvectors of the original symmetric matrix,
* and if COMPZ = 'I', Z contains the orthonormal eigenvectors
* of the symmetric tridiagonal matrix.
* If COMPZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* eigenvectors are desired, then LDZ >= max(1,N).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))
* If COMPZ = 'N', then WORK is not referenced.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: the algorithm has failed to find all the eigenvalues in
* a total of 30*N iterations; if INFO = i, then i
* elements of E have not converged to zero; on exit, D
* and E contain the elements of a symmetric tridiagonal
* matrix which is orthogonally similar to the original
* matrix.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, THREE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ THREE = 3.0D0 )
INTEGER MAXIT
PARAMETER ( MAXIT = 30 )
* ..
* .. Local Scalars ..
INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND,
$ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1,
$ NM1, NMAXIT
DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2,
$ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANST, DLAPY2
EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2
* ..
* .. External Subroutines ..
EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASET, DLASR,
$ DLASRT, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( LSAME( COMPZ, 'N' ) ) THEN
ICOMPZ = 0
ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
ICOMPZ = 1
ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
ICOMPZ = 2
ELSE
ICOMPZ = -1
END IF
IF( ICOMPZ.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
$ N ) ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSTEQR', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( ICOMPZ.EQ.2 )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Determine the unit roundoff and over/underflow thresholds.
*
EPS = DLAMCH( 'E' )
EPS2 = EPS**2
SAFMIN = DLAMCH( 'S' )
SAFMAX = ONE / SAFMIN
SSFMAX = SQRT( SAFMAX ) / THREE
SSFMIN = SQRT( SAFMIN ) / EPS2
*
* Compute the eigenvalues and eigenvectors of the tridiagonal
* matrix.
*
IF( ICOMPZ.EQ.2 )
$ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
*
NMAXIT = N*MAXIT
JTOT = 0
*
* Determine where the matrix splits and choose QL or QR iteration
* for each block, according to whether top or bottom diagonal
* element is smaller.
*
L1 = 1
NM1 = N - 1
*
10 CONTINUE
IF( L1.GT.N )
$ GO TO 160
IF( L1.GT.1 )
$ E( L1-1 ) = ZERO
IF( L1.LE.NM1 ) THEN
DO 20 M = L1, NM1
TST = ABS( E( M ) )
IF( TST.EQ.ZERO )
$ GO TO 30
IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+
$ 1 ) ) ) )*EPS ) THEN
E( M ) = ZERO
GO TO 30
END IF
20 CONTINUE
END IF
M = N
*
30 CONTINUE
L = L1
LSV = L
LEND = M
LENDSV = LEND
L1 = M + 1
IF( LEND.EQ.L )
$ GO TO 10
*
* Scale submatrix in rows and columns L to LEND
*
ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) )
ISCALE = 0
IF( ANORM.EQ.ZERO )
$ GO TO 10
IF( ANORM.GT.SSFMAX ) THEN
ISCALE = 1
CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
$ INFO )
ELSE IF( ANORM.LT.SSFMIN ) THEN
ISCALE = 2
CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N,
$ INFO )
END IF
*
* Choose between QL and QR iteration
*
IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
LEND = LSV
L = LENDSV
END IF
*
IF( LEND.GT.L ) THEN
*
* QL Iteration
*
* Look for small subdiagonal element.
*
40 CONTINUE
IF( L.NE.LEND ) THEN
LENDM1 = LEND - 1
DO 50 M = L, LENDM1
TST = ABS( E( M ) )**2
IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+
$ SAFMIN )GO TO 60
50 CONTINUE
END IF
*
M = LEND
*
60 CONTINUE
IF( M.LT.LEND )
$ E( M ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 80
*
* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
* to compute its eigensystem.
*
IF( M.EQ.L+1 ) THEN
IF( ICOMPZ.GT.0 ) THEN
CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S )
WORK( L ) = C
WORK( N-1+L ) = S
CALL DLASR( 'R', 'V', 'B', N, 2, WORK( L ),
$ WORK( N-1+L ), Z( 1, L ), LDZ )
ELSE
CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 )
END IF
D( L ) = RT1
D( L+1 ) = RT2
E( L ) = ZERO
L = L + 2
IF( L.LE.LEND )
$ GO TO 40
GO TO 140
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 140
JTOT = JTOT + 1
*
* Form shift.
*
G = ( D( L+1 )-P ) / ( TWO*E( L ) )
R = DLAPY2( G, ONE )
G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) )
*
S = ONE
C = ONE
P = ZERO
*
* Inner loop
*
MM1 = M - 1
DO 70 I = MM1, L, -1
F = S*E( I )
B = C*E( I )
CALL DLARTG( G, F, C, S, R )
IF( I.NE.M-1 )
$ E( I+1 ) = R
G = D( I+1 ) - P
R = ( D( I )-G )*S + TWO*C*B
P = S*R
D( I+1 ) = G + P
G = C*R - B
*
* If eigenvectors are desired, then save rotations.
*
IF( ICOMPZ.GT.0 ) THEN
WORK( I ) = C
WORK( N-1+I ) = -S
END IF
*
70 CONTINUE
*
* If eigenvectors are desired, then apply saved rotations.
*
IF( ICOMPZ.GT.0 ) THEN
MM = M - L + 1
CALL DLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ),
$ Z( 1, L ), LDZ )
END IF
*
D( L ) = D( L ) - P
E( L ) = G
GO TO 40
*
* Eigenvalue found.
*
80 CONTINUE
D( L ) = P
*
L = L + 1
IF( L.LE.LEND )
$ GO TO 40
GO TO 140
*
ELSE
*
* QR Iteration
*
* Look for small superdiagonal element.
*
90 CONTINUE
IF( L.NE.LEND ) THEN
LENDP1 = LEND + 1
DO 100 M = L, LENDP1, -1
TST = ABS( E( M-1 ) )**2
IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+
$ SAFMIN )GO TO 110
100 CONTINUE
END IF
*
M = LEND
*
110 CONTINUE
IF( M.GT.LEND )
$ E( M-1 ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 130
*
* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
* to compute its eigensystem.
*
IF( M.EQ.L-1 ) THEN
IF( ICOMPZ.GT.0 ) THEN
CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S )
WORK( M ) = C
WORK( N-1+M ) = S
CALL DLASR( 'R', 'V', 'F', N, 2, WORK( M ),
$ WORK( N-1+M ), Z( 1, L-1 ), LDZ )
ELSE
CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 )
END IF
D( L-1 ) = RT1
D( L ) = RT2
E( L-1 ) = ZERO
L = L - 2
IF( L.GE.LEND )
$ GO TO 90
GO TO 140
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 140
JTOT = JTOT + 1
*
* Form shift.
*
G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) )
R = DLAPY2( G, ONE )
G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) )
*
S = ONE
C = ONE
P = ZERO
*
* Inner loop
*
LM1 = L - 1
DO 120 I = M, LM1
F = S*E( I )
B = C*E( I )
CALL DLARTG( G, F, C, S, R )
IF( I.NE.M )
$ E( I-1 ) = R
G = D( I ) - P
R = ( D( I+1 )-G )*S + TWO*C*B
P = S*R
D( I ) = G + P
G = C*R - B
*
* If eigenvectors are desired, then save rotations.
*
IF( ICOMPZ.GT.0 ) THEN
WORK( I ) = C
WORK( N-1+I ) = S
END IF
*
120 CONTINUE
*
* If eigenvectors are desired, then apply saved rotations.
*
IF( ICOMPZ.GT.0 ) THEN
MM = L - M + 1
CALL DLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ),
$ Z( 1, M ), LDZ )
END IF
*
D( L ) = D( L ) - P
E( LM1 ) = G
GO TO 90
*
* Eigenvalue found.
*
130 CONTINUE
D( L ) = P
*
L = L - 1
IF( L.GE.LEND )
$ GO TO 90
GO TO 140
*
END IF
*
* Undo scaling if necessary
*
140 CONTINUE
IF( ISCALE.EQ.1 ) THEN
CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ),
$ N, INFO )
ELSE IF( ISCALE.EQ.2 ) THEN
CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ),
$ N, INFO )
END IF
*
* Check for no convergence to an eigenvalue after a total
* of N*MAXIT iterations.
*
IF( JTOT.LT.NMAXIT )
$ GO TO 10
DO 150 I = 1, N - 1
IF( E( I ).NE.ZERO )
$ INFO = INFO + 1
150 CONTINUE
GO TO 190
*
* Order eigenvalues and eigenvectors.
*
160 CONTINUE
IF( ICOMPZ.EQ.0 ) THEN
*
* Use Quick Sort
*
CALL DLASRT( 'I', N, D, INFO )
*
ELSE
*
* Use Selection Sort to minimize swaps of eigenvectors
*
DO 180 II = 2, N
I = II - 1
K = I
P = D( I )
DO 170 J = II, N
IF( D( J ).LT.P ) THEN
K = J
P = D( J )
END IF
170 CONTINUE
IF( K.NE.I ) THEN
D( K ) = D( I )
D( I ) = P
CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
END IF
180 CONTINUE
END IF
*
190 CONTINUE
RETURN
*
* End of DSTEQR
*
END
SUBROUTINE DSTERF( N, D, E, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * )
* ..
*
* Purpose
* =======
*
* DSTERF computes all eigenvalues of a symmetric tridiagonal matrix
* using the Pal-Walker-Kahan variant of the QL or QR algorithm.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the n diagonal elements of the tridiagonal matrix.
* On exit, if INFO = 0, the eigenvalues in ascending order.
*
* E (input/output) DOUBLE PRECISION array, dimension (N-1)
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix.
* On exit, E has been destroyed.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: the algorithm failed to find all of the eigenvalues in
* a total of 30*N iterations; if INFO = i, then i
* elements of E have not converged to zero.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, THREE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ THREE = 3.0D0 )
INTEGER MAXIT
PARAMETER ( MAXIT = 30 )
* ..
* .. Local Scalars ..
INTEGER I, ISCALE, JTOT, L, L1, LEND, LENDSV, LSV, M,
$ NMAXIT
DOUBLE PRECISION ALPHA, ANORM, BB, C, EPS, EPS2, GAMMA, OLDC,
$ OLDGAM, P, R, RT1, RT2, RTE, S, SAFMAX, SAFMIN,
$ SIGMA, SSFMAX, SSFMIN
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANST, DLAPY2
EXTERNAL DLAMCH, DLANST, DLAPY2
* ..
* .. External Subroutines ..
EXTERNAL DLAE2, DLASCL, DLASRT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
* Quick return if possible
*
IF( N.LT.0 ) THEN
INFO = -1
CALL XERBLA( 'DSTERF', -INFO )
RETURN
END IF
IF( N.LE.1 )
$ RETURN
*
* Determine the unit roundoff for this environment.
*
EPS = DLAMCH( 'E' )
EPS2 = EPS**2
SAFMIN = DLAMCH( 'S' )
SAFMAX = ONE / SAFMIN
SSFMAX = SQRT( SAFMAX ) / THREE
SSFMIN = SQRT( SAFMIN ) / EPS2
*
* Compute the eigenvalues of the tridiagonal matrix.
*
NMAXIT = N*MAXIT
SIGMA = ZERO
JTOT = 0
*
* Determine where the matrix splits and choose QL or QR iteration
* for each block, according to whether top or bottom diagonal
* element is smaller.
*
L1 = 1
*
10 CONTINUE
IF( L1.GT.N )
$ GO TO 170
IF( L1.GT.1 )
$ E( L1-1 ) = ZERO
DO 20 M = L1, N - 1
IF( ABS( E( M ) ).LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+
$ 1 ) ) ) )*EPS ) THEN
E( M ) = ZERO
GO TO 30
END IF
20 CONTINUE
M = N
*
30 CONTINUE
L = L1
LSV = L
LEND = M
LENDSV = LEND
L1 = M + 1
IF( LEND.EQ.L )
$ GO TO 10
*
* Scale submatrix in rows and columns L to LEND
*
ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) )
ISCALE = 0
IF( ANORM.GT.SSFMAX ) THEN
ISCALE = 1
CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
$ INFO )
ELSE IF( ANORM.LT.SSFMIN ) THEN
ISCALE = 2
CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N,
$ INFO )
END IF
*
DO 40 I = L, LEND - 1
E( I ) = E( I )**2
40 CONTINUE
*
* Choose between QL and QR iteration
*
IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
LEND = LSV
L = LENDSV
END IF
*
IF( LEND.GE.L ) THEN
*
* QL Iteration
*
* Look for small subdiagonal element.
*
50 CONTINUE
IF( L.NE.LEND ) THEN
DO 60 M = L, LEND - 1
IF( ABS( E( M ) ).LE.EPS2*ABS( D( M )*D( M+1 ) ) )
$ GO TO 70
60 CONTINUE
END IF
M = LEND
*
70 CONTINUE
IF( M.LT.LEND )
$ E( M ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 90
*
* If remaining matrix is 2 by 2, use DLAE2 to compute its
* eigenvalues.
*
IF( M.EQ.L+1 ) THEN
RTE = SQRT( E( L ) )
CALL DLAE2( D( L ), RTE, D( L+1 ), RT1, RT2 )
D( L ) = RT1
D( L+1 ) = RT2
E( L ) = ZERO
L = L + 2
IF( L.LE.LEND )
$ GO TO 50
GO TO 150
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 150
JTOT = JTOT + 1
*
* Form shift.
*
RTE = SQRT( E( L ) )
SIGMA = ( D( L+1 )-P ) / ( TWO*RTE )
R = DLAPY2( SIGMA, ONE )
SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) )
*
C = ONE
S = ZERO
GAMMA = D( M ) - SIGMA
P = GAMMA*GAMMA
*
* Inner loop
*
DO 80 I = M - 1, L, -1
BB = E( I )
R = P + BB
IF( I.NE.M-1 )
$ E( I+1 ) = S*R
OLDC = C
C = P / R
S = BB / R
OLDGAM = GAMMA
ALPHA = D( I )
GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM
D( I+1 ) = OLDGAM + ( ALPHA-GAMMA )
IF( C.NE.ZERO ) THEN
P = ( GAMMA*GAMMA ) / C
ELSE
P = OLDC*BB
END IF
80 CONTINUE
*
E( L ) = S*P
D( L ) = SIGMA + GAMMA
GO TO 50
*
* Eigenvalue found.
*
90 CONTINUE
D( L ) = P
*
L = L + 1
IF( L.LE.LEND )
$ GO TO 50
GO TO 150
*
ELSE
*
* QR Iteration
*
* Look for small superdiagonal element.
*
100 CONTINUE
DO 110 M = L, LEND + 1, -1
IF( ABS( E( M-1 ) ).LE.EPS2*ABS( D( M )*D( M-1 ) ) )
$ GO TO 120
110 CONTINUE
M = LEND
*
120 CONTINUE
IF( M.GT.LEND )
$ E( M-1 ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 140
*
* If remaining matrix is 2 by 2, use DLAE2 to compute its
* eigenvalues.
*
IF( M.EQ.L-1 ) THEN
RTE = SQRT( E( L-1 ) )
CALL DLAE2( D( L ), RTE, D( L-1 ), RT1, RT2 )
D( L ) = RT1
D( L-1 ) = RT2
E( L-1 ) = ZERO
L = L - 2
IF( L.GE.LEND )
$ GO TO 100
GO TO 150
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 150
JTOT = JTOT + 1
*
* Form shift.
*
RTE = SQRT( E( L-1 ) )
SIGMA = ( D( L-1 )-P ) / ( TWO*RTE )
R = DLAPY2( SIGMA, ONE )
SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) )
*
C = ONE
S = ZERO
GAMMA = D( M ) - SIGMA
P = GAMMA*GAMMA
*
* Inner loop
*
DO 130 I = M, L - 1
BB = E( I )
R = P + BB
IF( I.NE.M )
$ E( I-1 ) = S*R
OLDC = C
C = P / R
S = BB / R
OLDGAM = GAMMA
ALPHA = D( I+1 )
GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM
D( I ) = OLDGAM + ( ALPHA-GAMMA )
IF( C.NE.ZERO ) THEN
P = ( GAMMA*GAMMA ) / C
ELSE
P = OLDC*BB
END IF
130 CONTINUE
*
E( L-1 ) = S*P
D( L ) = SIGMA + GAMMA
GO TO 100
*
* Eigenvalue found.
*
140 CONTINUE
D( L ) = P
*
L = L - 1
IF( L.GE.LEND )
$ GO TO 100
GO TO 150
*
END IF
*
* Undo scaling if necessary
*
150 CONTINUE
IF( ISCALE.EQ.1 )
$ CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
IF( ISCALE.EQ.2 )
$ CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
*
* Check for no convergence to an eigenvalue after a total
* of N*MAXIT iterations.
*
IF( JTOT.LT.NMAXIT )
$ GO TO 10
DO 160 I = 1, N - 1
IF( E( I ).NE.ZERO )
$ INFO = INFO + 1
160 CONTINUE
GO TO 180
*
* Sort eigenvalues in increasing order.
*
170 CONTINUE
CALL DLASRT( 'I', N, D, INFO )
*
180 CONTINUE
RETURN
*
* End of DSTERF
*
END
SUBROUTINE DSTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ
INTEGER INFO, LDZ, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DSTEV computes all eigenvalues and, optionally, eigenvectors of a
* real symmetric tridiagonal matrix A.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the n diagonal elements of the tridiagonal matrix
* A.
* On exit, if INFO = 0, the eigenvalues in ascending order.
*
* E (input/output) DOUBLE PRECISION array, dimension (N-1)
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix A, stored in elements 1 to N-1 of E.
* On exit, the contents of E are destroyed.
*
* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
* eigenvectors of the matrix A, with the i-th column of Z
* holding the eigenvector associated with D(i).
* If JOBZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))
* If JOBZ = 'N', WORK is not referenced.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, the algorithm failed to converge; i
* off-diagonal elements of E did not converge to zero.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL WANTZ
INTEGER IMAX, ISCALE
DOUBLE PRECISION BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM,
$ TNRM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANST
EXTERNAL LSAME, DLAMCH, DLANST
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, DSTEQR, DSTERF, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -6
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSTEV ', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( WANTZ )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = SQRT( BIGNUM )
*
* Scale matrix to allowable range, if necessary.
*
ISCALE = 0
TNRM = DLANST( 'M', N, D, E )
IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / TNRM
ELSE IF( TNRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / TNRM
END IF
IF( ISCALE.EQ.1 ) THEN
CALL DSCAL( N, SIGMA, D, 1 )
CALL DSCAL( N-1, SIGMA, E( 1 ), 1 )
END IF
*
* For eigenvalues only, call DSTERF. For eigenvalues and
* eigenvectors, call DSTEQR.
*
IF( .NOT.WANTZ ) THEN
CALL DSTERF( N, D, E, INFO )
ELSE
CALL DSTEQR( 'I', N, D, E, Z, LDZ, WORK, INFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = N
ELSE
IMAX = INFO - 1
END IF
CALL DSCAL( IMAX, ONE / SIGMA, D, 1 )
END IF
*
RETURN
*
* End of DSTEV
*
END
SUBROUTINE DSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK,
$ LIWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ
INTEGER INFO, LDZ, LIWORK, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DSTEVD computes all eigenvalues and, optionally, eigenvectors of a
* real symmetric tridiagonal matrix. If eigenvectors are desired, it
* uses a divide and conquer algorithm.
*
* The divide and conquer algorithm makes very mild assumptions about
* floating point arithmetic. It will work on machines with a guard
* digit in add/subtract, or on those binary machines without guard
* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
* Cray-2. It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the n diagonal elements of the tridiagonal matrix
* A.
* On exit, if INFO = 0, the eigenvalues in ascending order.
*
* E (input/output) DOUBLE PRECISION array, dimension (N-1)
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix A, stored in elements 1 to N-1 of E.
* On exit, the contents of E are destroyed.
*
* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
* eigenvectors of the matrix A, with the i-th column of Z
* holding the eigenvector associated with D(i).
* If JOBZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace/output) DOUBLE PRECISION array,
* dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* If JOBZ = 'N' or N <= 1 then LWORK must be at least 1.
* If JOBZ = 'V' and N > 1 then LWORK must be at least
* ( 1 + 4*N + N**2 ).
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal sizes of the WORK and IWORK
* arrays, returns these values as the first entries of the WORK
* and IWORK arrays, and no error message related to LWORK or
* LIWORK is issued by XERBLA.
*
* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK.
* If JOBZ = 'N' or N <= 1 then LIWORK must be at least 1.
* If JOBZ = 'V' and N > 1 then LIWORK must be at least 3+5*N.
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal sizes of the WORK and
* IWORK arrays, returns these values as the first entries of
* the WORK and IWORK arrays, and no error message related to
* LWORK or LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, the algorithm failed to converge; i
* off-diagonal elements of E did not converge to zero.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, WANTZ
INTEGER ISCALE, LIWMIN, LWMIN
DOUBLE PRECISION BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM,
$ TNRM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANST
EXTERNAL LSAME, DLAMCH, DLANST
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, DSTEDC, DSTERF, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
INFO = 0
LIWMIN = 1
LWMIN = 1
IF( N.GT.1 .AND. WANTZ ) THEN
LWMIN = 1 + 4*N + N**2
LIWMIN = 3 + 5*N
END IF
*
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -6
END IF
*
IF( INFO.EQ.0 ) THEN
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -8
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -10
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSTEVD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( WANTZ )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = SQRT( BIGNUM )
*
* Scale matrix to allowable range, if necessary.
*
ISCALE = 0
TNRM = DLANST( 'M', N, D, E )
IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / TNRM
ELSE IF( TNRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / TNRM
END IF
IF( ISCALE.EQ.1 ) THEN
CALL DSCAL( N, SIGMA, D, 1 )
CALL DSCAL( N-1, SIGMA, E( 1 ), 1 )
END IF
*
* For eigenvalues only, call DSTERF. For eigenvalues and
* eigenvectors, call DSTEDC.
*
IF( .NOT.WANTZ ) THEN
CALL DSTERF( N, D, E, INFO )
ELSE
CALL DSTEDC( 'I', N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK,
$ INFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( ISCALE.EQ.1 )
$ CALL DSCAL( N, ONE / SIGMA, D, 1 )
*
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
RETURN
*
* End of DSTEVD
*
END
SUBROUTINE DSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL,
$ M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK,
$ LIWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE
INTEGER IL, INFO, IU, LDZ, LIWORK, LWORK, M, N
DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER ISUPPZ( * ), IWORK( * )
DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DSTEVR computes selected eigenvalues and, optionally, eigenvectors
* of a real symmetric tridiagonal matrix T. Eigenvalues and
* eigenvectors can be selected by specifying either a range of values
* or a range of indices for the desired eigenvalues.
*
* Whenever possible, DSTEVR calls DSTEMR to compute the
* eigenspectrum using Relatively Robust Representations. DSTEMR
* computes eigenvalues by the dqds algorithm, while orthogonal
* eigenvectors are computed from various "good" L D L^T representations
* (also known as Relatively Robust Representations). Gram-Schmidt
* orthogonalization is avoided as far as possible. More specifically,
* the various steps of the algorithm are as follows. For the i-th
* unreduced block of T,
* (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T
* is a relatively robust representation,
* (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high
* relative accuracy by the dqds algorithm,
* (c) If there is a cluster of close eigenvalues, "choose" sigma_i
* close to the cluster, and go to step (a),
* (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T,
* compute the corresponding eigenvector by forming a
* rank-revealing twisted factorization.
* The desired accuracy of the output can be specified by the input
* parameter ABSTOL.
*
* For more details, see "A new O(n^2) algorithm for the symmetric
* tridiagonal eigenvalue/eigenvector problem", by Inderjit Dhillon,
* Computer Science Division Technical Report No. UCB//CSD-97-971,
* UC Berkeley, May 1997.
*
*
* Note 1 : DSTEVR calls DSTEMR when the full spectrum is requested
* on machines which conform to the ieee-754 floating point standard.
* DSTEVR calls DSTEBZ and DSTEIN on non-ieee machines and
* when partial spectrum requests are made.
*
* Normal execution of DSTEMR may create NaNs and infinities and
* hence may abort due to a floating point exception in environments
* which do not handle NaNs and infinities in the ieee standard default
* manner.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* RANGE (input) CHARACTER*1
* = 'A': all eigenvalues will be found.
* = 'V': all eigenvalues in the half-open interval (VL,VU]
* will be found.
* = 'I': the IL-th through IU-th eigenvalues will be found.
********** For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and
********** DSTEIN are called
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the n diagonal elements of the tridiagonal matrix
* A.
* On exit, D may be multiplied by a constant factor chosen
* to avoid over/underflow in computing the eigenvalues.
*
* E (input/output) DOUBLE PRECISION array, dimension (max(1,N-1))
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix A in elements 1 to N-1 of E.
* On exit, E may be multiplied by a constant factor chosen
* to avoid over/underflow in computing the eigenvalues.
*
* VL (input) DOUBLE PRECISION
* VU (input) DOUBLE PRECISION
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* ABSTOL (input) DOUBLE PRECISION
* The absolute error tolerance for the eigenvalues.
* An approximate eigenvalue is accepted as converged
* when it is determined to lie in an interval [a,b]
* of width less than or equal to
*
* ABSTOL + EPS * max( |a|,|b| ) ,
*
* where EPS is the machine precision. If ABSTOL is less than
* or equal to zero, then EPS*|T| will be used in its place,
* where |T| is the 1-norm of the tridiagonal matrix obtained
* by reducing A to tridiagonal form.
*
* See "Computing Small Singular Values of Bidiagonal Matrices
* with Guaranteed High Relative Accuracy," by Demmel and
* Kahan, LAPACK Working Note #3.
*
* If high relative accuracy is important, set ABSTOL to
* DLAMCH( 'Safe minimum' ). Doing so will guarantee that
* eigenvalues are computed to high relative accuracy when
* possible in future releases. The current code does not
* make any guarantees about high relative accuracy, but
* future releases will. See J. Barlow and J. Demmel,
* "Computing Accurate Eigensystems of Scaled Diagonally
* Dominant Matrices", LAPACK Working Note #7, for a discussion
* of which matrices define their eigenvalues to high relative
* accuracy.
*
* M (output) INTEGER
* The total number of eigenvalues found. 0 <= M <= N.
* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*
* W (output) DOUBLE PRECISION array, dimension (N)
* The first M elements contain the selected eigenvalues in
* ascending order.
*
* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
* contain the orthonormal eigenvectors of the matrix A
* corresponding to the selected eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* Note: the user must ensure that at least max(1,M) columns are
* supplied in the array Z; if RANGE = 'V', the exact value of M
* is not known in advance and an upper bound must be used.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )
* The support of the eigenvectors in Z, i.e., the indices
* indicating the nonzero elements in Z. The i-th eigenvector
* is nonzero only in elements ISUPPZ( 2*i-1 ) through
* ISUPPZ( 2*i ).
********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1
*
* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
* On exit, if INFO = 0, WORK(1) returns the optimal (and
* minimal) LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK. LWORK >= max(1,20*N).
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal sizes of the WORK and IWORK
* arrays, returns these values as the first entries of the WORK
* and IWORK arrays, and no error message related to LWORK or
* LIWORK is issued by XERBLA.
*
* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if INFO = 0, IWORK(1) returns the optimal (and
* minimal) LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK. LIWORK >= max(1,10*N).
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal sizes of the WORK and
* IWORK arrays, returns these values as the first entries of
* the WORK and IWORK arrays, and no error message related to
* LWORK or LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: Internal error
*
* Further Details
* ===============
*
* Based on contributions by
* Inderjit Dhillon, IBM Almaden, USA
* Osni Marques, LBNL/NERSC, USA
* Ken Stanley, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, TEST, LQUERY, VALEIG, WANTZ,
$ TRYRAC
CHARACTER ORDER
INTEGER I, IEEEOK, IMAX, INDIBL, INDIFL, INDISP,
$ INDIWO, ISCALE, ITMP1, J, JJ, LIWMIN, LWMIN,
$ NSPLIT
DOUBLE PRECISION BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM,
$ TMP1, TNRM, VLL, VUU
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANST
EXTERNAL LSAME, ILAENV, DLAMCH, DLANST
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTEMR, DSTEIN, DSTERF,
$ DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
*
* Test the input parameters.
*
IEEEOK = ILAENV( 10, 'DSTEVR', 'N', 1, 2, 3, 4 )
*
WANTZ = LSAME( JOBZ, 'V' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
*
LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LIWORK.EQ.-1 ) )
LWMIN = MAX( 1, 20*N )
LIWMIN = MAX( 1, 10*N )
*
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE
IF( VALEIG ) THEN
IF( N.GT.0 .AND. VU.LE.VL )
$ INFO = -7
ELSE IF( INDEIG ) THEN
IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
INFO = -9
END IF
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -14
END IF
END IF
*
IF( INFO.EQ.0 ) THEN
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -17
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -19
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSTEVR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( ALLEIG .OR. INDEIG ) THEN
M = 1
W( 1 ) = D( 1 )
ELSE
IF( VL.LT.D( 1 ) .AND. VU.GE.D( 1 ) ) THEN
M = 1
W( 1 ) = D( 1 )
END IF
END IF
IF( WANTZ )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
*
*
* Scale matrix to allowable range, if necessary.
*
ISCALE = 0
VLL = VL
VUU = VU
*
TNRM = DLANST( 'M', N, D, E )
IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / TNRM
ELSE IF( TNRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / TNRM
END IF
IF( ISCALE.EQ.1 ) THEN
CALL DSCAL( N, SIGMA, D, 1 )
CALL DSCAL( N-1, SIGMA, E( 1 ), 1 )
IF( VALEIG ) THEN
VLL = VL*SIGMA
VUU = VU*SIGMA
END IF
END IF
* Initialize indices into workspaces. Note: These indices are used only
* if DSTERF or DSTEMR fail.
* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in DSTEBZ and
* stores the block indices of each of the M<=N eigenvalues.
INDIBL = 1
* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in DSTEBZ and
* stores the starting and finishing indices of each block.
INDISP = INDIBL + N
* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors
* that corresponding to eigenvectors that fail to converge in
* DSTEIN. This information is discarded; if any fail, the driver
* returns INFO > 0.
INDIFL = INDISP + N
* INDIWO is the offset of the remaining integer workspace.
INDIWO = INDISP + N
*
* If all eigenvalues are desired, then
* call DSTERF or DSTEMR. If this fails for some eigenvalue, then
* try DSTEBZ.
*
*
TEST = .FALSE.
IF( INDEIG ) THEN
IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
TEST = .TRUE.
END IF
END IF
IF( ( ALLEIG .OR. TEST ) .AND. IEEEOK.EQ.1 ) THEN
CALL DCOPY( N-1, E( 1 ), 1, WORK( 1 ), 1 )
IF( .NOT.WANTZ ) THEN
CALL DCOPY( N, D, 1, W, 1 )
CALL DSTERF( N, W, WORK, INFO )
ELSE
CALL DCOPY( N, D, 1, WORK( N+1 ), 1 )
IF (ABSTOL .LE. TWO*N*EPS) THEN
TRYRAC = .TRUE.
ELSE
TRYRAC = .FALSE.
END IF
CALL DSTEMR( JOBZ, 'A', N, WORK( N+1 ), WORK, VL, VU, IL,
$ IU, M, W, Z, LDZ, N, ISUPPZ, TRYRAC,
$ WORK( 2*N+1 ), LWORK-2*N, IWORK, LIWORK, INFO )
*
END IF
IF( INFO.EQ.0 ) THEN
M = N
GO TO 10
END IF
INFO = 0
END IF
*
* Otherwise, call DSTEBZ and, if eigenvectors are desired, DSTEIN.
*
IF( WANTZ ) THEN
ORDER = 'B'
ELSE
ORDER = 'E'
END IF
CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTOL, D, E, M,
$ NSPLIT, W, IWORK( INDIBL ), IWORK( INDISP ), WORK,
$ IWORK( INDIWO ), INFO )
*
IF( WANTZ ) THEN
CALL DSTEIN( N, D, E, M, W, IWORK( INDIBL ), IWORK( INDISP ),
$ Z, LDZ, WORK, IWORK( INDIWO ), IWORK( INDIFL ),
$ INFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
10 CONTINUE
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = M
ELSE
IMAX = INFO - 1
END IF
CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
* If eigenvalues are not in order, then sort them, along with
* eigenvectors.
*
IF( WANTZ ) THEN
DO 30 J = 1, M - 1
I = 0
TMP1 = W( J )
DO 20 JJ = J + 1, M
IF( W( JJ ).LT.TMP1 ) THEN
I = JJ
TMP1 = W( JJ )
END IF
20 CONTINUE
*
IF( I.NE.0 ) THEN
ITMP1 = IWORK( I )
W( I ) = W( J )
IWORK( I ) = IWORK( J )
W( J ) = TMP1
IWORK( J ) = ITMP1
CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
END IF
30 CONTINUE
END IF
*
* Causes problems with tests 19 & 20:
* IF (wantz .and. INDEIG ) Z( 1,1) = Z(1,1) / 1.002 + .002
*
*
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
RETURN
*
* End of DSTEVR
*
END
SUBROUTINE DSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL,
$ M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE
INTEGER IL, INFO, IU, LDZ, M, N
DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER IFAIL( * ), IWORK( * )
DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DSTEVX computes selected eigenvalues and, optionally, eigenvectors
* of a real symmetric tridiagonal matrix A. Eigenvalues and
* eigenvectors can be selected by specifying either a range of values
* or a range of indices for the desired eigenvalues.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* RANGE (input) CHARACTER*1
* = 'A': all eigenvalues will be found.
* = 'V': all eigenvalues in the half-open interval (VL,VU]
* will be found.
* = 'I': the IL-th through IU-th eigenvalues will be found.
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the n diagonal elements of the tridiagonal matrix
* A.
* On exit, D may be multiplied by a constant factor chosen
* to avoid over/underflow in computing the eigenvalues.
*
* E (input/output) DOUBLE PRECISION array, dimension (max(1,N-1))
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix A in elements 1 to N-1 of E.
* On exit, E may be multiplied by a constant factor chosen
* to avoid over/underflow in computing the eigenvalues.
*
* VL (input) DOUBLE PRECISION
* VU (input) DOUBLE PRECISION
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* ABSTOL (input) DOUBLE PRECISION
* The absolute error tolerance for the eigenvalues.
* An approximate eigenvalue is accepted as converged
* when it is determined to lie in an interval [a,b]
* of width less than or equal to
*
* ABSTOL + EPS * max( |a|,|b| ) ,
*
* where EPS is the machine precision. If ABSTOL is less
* than or equal to zero, then EPS*|T| will be used in
* its place, where |T| is the 1-norm of the tridiagonal
* matrix.
*
* Eigenvalues will be computed most accurately when ABSTOL is
* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
* If this routine returns with INFO>0, indicating that some
* eigenvectors did not converge, try setting ABSTOL to
* 2*DLAMCH('S').
*
* See "Computing Small Singular Values of Bidiagonal Matrices
* with Guaranteed High Relative Accuracy," by Demmel and
* Kahan, LAPACK Working Note #3.
*
* M (output) INTEGER
* The total number of eigenvalues found. 0 <= M <= N.
* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*
* W (output) DOUBLE PRECISION array, dimension (N)
* The first M elements contain the selected eigenvalues in
* ascending order.
*
* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
* contain the orthonormal eigenvectors of the matrix A
* corresponding to the selected eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* If an eigenvector fails to converge (INFO > 0), then that
* column of Z contains the latest approximation to the
* eigenvector, and the index of the eigenvector is returned
* in IFAIL. If JOBZ = 'N', then Z is not referenced.
* Note: the user must ensure that at least max(1,M) columns are
* supplied in the array Z; if RANGE = 'V', the exact value of M
* is not known in advance and an upper bound must be used.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (5*N)
*
* IWORK (workspace) INTEGER array, dimension (5*N)
*
* IFAIL (output) INTEGER array, dimension (N)
* If JOBZ = 'V', then if INFO = 0, the first M elements of
* IFAIL are zero. If INFO > 0, then IFAIL contains the
* indices of the eigenvectors that failed to converge.
* If JOBZ = 'N', then IFAIL is not referenced.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, then i eigenvectors failed to converge.
* Their indices are stored in array IFAIL.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, TEST, VALEIG, WANTZ
CHARACTER ORDER
INTEGER I, IMAX, INDIBL, INDISP, INDIWO, INDWRK,
$ ISCALE, ITMP1, J, JJ, NSPLIT
DOUBLE PRECISION BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM,
$ TMP1, TNRM, VLL, VUU
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANST
EXTERNAL LSAME, DLAMCH, DLANST
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTEIN, DSTEQR, DSTERF,
$ DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE
IF( VALEIG ) THEN
IF( N.GT.0 .AND. VU.LE.VL )
$ INFO = -7
ELSE IF( INDEIG ) THEN
IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
INFO = -9
END IF
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) )
$ INFO = -14
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSTEVX', -INFO )
RETURN
END IF
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( ALLEIG .OR. INDEIG ) THEN
M = 1
W( 1 ) = D( 1 )
ELSE
IF( VL.LT.D( 1 ) .AND. VU.GE.D( 1 ) ) THEN
M = 1
W( 1 ) = D( 1 )
END IF
END IF
IF( WANTZ )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
*
* Scale matrix to allowable range, if necessary.
*
ISCALE = 0
IF( VALEIG ) THEN
VLL = VL
VUU = VU
ELSE
VLL = ZERO
VUU = ZERO
END IF
TNRM = DLANST( 'M', N, D, E )
IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / TNRM
ELSE IF( TNRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / TNRM
END IF
IF( ISCALE.EQ.1 ) THEN
CALL DSCAL( N, SIGMA, D, 1 )
CALL DSCAL( N-1, SIGMA, E( 1 ), 1 )
IF( VALEIG ) THEN
VLL = VL*SIGMA
VUU = VU*SIGMA
END IF
END IF
*
* If all eigenvalues are desired and ABSTOL is less than zero, then
* call DSTERF or SSTEQR. If this fails for some eigenvalue, then
* try DSTEBZ.
*
TEST = .FALSE.
IF( INDEIG ) THEN
IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
TEST = .TRUE.
END IF
END IF
IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN
CALL DCOPY( N, D, 1, W, 1 )
CALL DCOPY( N-1, E( 1 ), 1, WORK( 1 ), 1 )
INDWRK = N + 1
IF( .NOT.WANTZ ) THEN
CALL DSTERF( N, W, WORK, INFO )
ELSE
CALL DSTEQR( 'I', N, W, WORK, Z, LDZ, WORK( INDWRK ), INFO )
IF( INFO.EQ.0 ) THEN
DO 10 I = 1, N
IFAIL( I ) = 0
10 CONTINUE
END IF
END IF
IF( INFO.EQ.0 ) THEN
M = N
GO TO 20
END IF
INFO = 0
END IF
*
* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN.
*
IF( WANTZ ) THEN
ORDER = 'B'
ELSE
ORDER = 'E'
END IF
INDWRK = 1
INDIBL = 1
INDISP = INDIBL + N
INDIWO = INDISP + N
CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTOL, D, E, M,
$ NSPLIT, W, IWORK( INDIBL ), IWORK( INDISP ),
$ WORK( INDWRK ), IWORK( INDIWO ), INFO )
*
IF( WANTZ ) THEN
CALL DSTEIN( N, D, E, M, W, IWORK( INDIBL ), IWORK( INDISP ),
$ Z, LDZ, WORK( INDWRK ), IWORK( INDIWO ), IFAIL,
$ INFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
20 CONTINUE
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = M
ELSE
IMAX = INFO - 1
END IF
CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
* If eigenvalues are not in order, then sort them, along with
* eigenvectors.
*
IF( WANTZ ) THEN
DO 40 J = 1, M - 1
I = 0
TMP1 = W( J )
DO 30 JJ = J + 1, M
IF( W( JJ ).LT.TMP1 ) THEN
I = JJ
TMP1 = W( JJ )
END IF
30 CONTINUE
*
IF( I.NE.0 ) THEN
ITMP1 = IWORK( INDIBL+I-1 )
W( I ) = W( J )
IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
W( J ) = TMP1
IWORK( INDIBL+J-1 ) = ITMP1
CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
IF( INFO.NE.0 ) THEN
ITMP1 = IFAIL( I )
IFAIL( I ) = IFAIL( J )
IFAIL( J ) = ITMP1
END IF
END IF
40 CONTINUE
END IF
*
RETURN
*
* End of DSTEVX
*
END
SUBROUTINE DSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK,
$ IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
DOUBLE PRECISION ANORM, RCOND
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), IWORK( * )
DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DSYCON estimates the reciprocal of the condition number (in the
* 1-norm) of a real symmetric matrix A using the factorization
* A = U*D*U**T or A = L*D*L**T computed by DSYTRF.
*
* An estimate is obtained for norm(inv(A)), and the reciprocal of the
* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the details of the factorization are stored
* as an upper or lower triangular matrix.
* = 'U': Upper triangular, form is A = U*D*U**T;
* = 'L': Lower triangular, form is A = L*D*L**T.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The block diagonal matrix D and the multipliers used to
* obtain the factor U or L as computed by DSYTRF.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* IPIV (input) INTEGER array, dimension (N)
* Details of the interchanges and the block structure of D
* as determined by DSYTRF.
*
* ANORM (input) DOUBLE PRECISION
* The 1-norm of the original matrix A.
*
* RCOND (output) DOUBLE PRECISION
* The reciprocal of the condition number of the matrix A,
* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
* estimate of the 1-norm of inv(A) computed in this routine.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, KASE
DOUBLE PRECISION AINVNM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DLACN2, DSYTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( ANORM.LT.ZERO ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYCON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
RCOND = ZERO
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
ELSE IF( ANORM.LE.ZERO ) THEN
RETURN
END IF
*
* Check that the diagonal matrix D is nonsingular.
*
IF( UPPER ) THEN
*
* Upper triangular storage: examine D from bottom to top
*
DO 10 I = N, 1, -1
IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
$ RETURN
10 CONTINUE
ELSE
*
* Lower triangular storage: examine D from top to bottom.
*
DO 20 I = 1, N
IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
$ RETURN
20 CONTINUE
END IF
*
* Estimate the 1-norm of the inverse.
*
KASE = 0
30 CONTINUE
CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
*
* Multiply by inv(L*D*L') or inv(U*D*U').
*
CALL DSYTRS( UPLO, N, 1, A, LDA, IPIV, WORK, N, INFO )
GO TO 30
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / AINVNM ) / ANORM
*
RETURN
*
* End of DSYCON
*
END
SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DSYEV computes all eigenvalues and, optionally, eigenvectors of a
* real symmetric matrix A.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
* On entry, the symmetric matrix A. If UPLO = 'U', the
* leading N-by-N upper triangular part of A contains the
* upper triangular part of the matrix A. If UPLO = 'L',
* the leading N-by-N lower triangular part of A contains
* the lower triangular part of the matrix A.
* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
* orthonormal eigenvectors of the matrix A.
* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
* or the upper triangle (if UPLO='U') of A, including the
* diagonal, is destroyed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* W (output) DOUBLE PRECISION array, dimension (N)
* If INFO = 0, the eigenvalues in ascending order.
*
* 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 length of the array WORK. LWORK >= max(1,3*N-1).
* For optimal efficiency, LWORK >= (NB+2)*N,
* where NB is the blocksize for DSYTRD returned by ILAENV.
*
* 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
* > 0: if INFO = i, the algorithm failed to converge; i
* off-diagonal elements of an intermediate tridiagonal
* form did not converge to zero.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LOWER, LQUERY, WANTZ
INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE,
$ LLWORK, LWKOPT, NB
DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
$ SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANSY
EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DLASCL, DORGTR, DSCAL, DSTEQR, DSTERF, DSYTRD,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
LOWER = LSAME( UPLO, 'L' )
LQUERY = ( LWORK.EQ.-1 )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
END IF
*
IF( INFO.EQ.0 ) THEN
NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
LWKOPT = MAX( 1, ( NB+2 )*N )
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.MAX( 1, 3*N-1 ) .AND. .NOT.LQUERY )
$ INFO = -8
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYEV ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
RETURN
END IF
*
IF( N.EQ.1 ) THEN
W( 1 ) = A( 1, 1 )
WORK( 1 ) = 2
IF( WANTZ )
$ A( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = SQRT( BIGNUM )
*
* Scale matrix to allowable range, if necessary.
*
ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK )
ISCALE = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 )
$ CALL DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO )
*
* Call DSYTRD to reduce symmetric matrix to tridiagonal form.
*
INDE = 1
INDTAU = INDE + N
INDWRK = INDTAU + N
LLWORK = LWORK - INDWRK + 1
CALL DSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ),
$ WORK( INDWRK ), LLWORK, IINFO )
*
* For eigenvalues only, call DSTERF. For eigenvectors, first call
* DORGTR to generate the orthogonal matrix, then call DSTEQR.
*
IF( .NOT.WANTZ ) THEN
CALL DSTERF( N, W, WORK( INDE ), INFO )
ELSE
CALL DORGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ),
$ LLWORK, IINFO )
CALL DSTEQR( JOBZ, N, W, WORK( INDE ), A, LDA, WORK( INDTAU ),
$ INFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = N
ELSE
IMAX = INFO - 1
END IF
CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
* Set WORK(1) to optimal workspace size.
*
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of DSYEV
*
END
SUBROUTINE DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK,
$ LIWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, LDA, LIWORK, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DSYEVD computes all eigenvalues and, optionally, eigenvectors of a
* real symmetric matrix A. If eigenvectors are desired, it uses a
* divide and conquer algorithm.
*
* The divide and conquer algorithm makes very mild assumptions about
* floating point arithmetic. It will work on machines with a guard
* digit in add/subtract, or on those binary machines without guard
* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
* Cray-2. It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Because of large use of BLAS of level 3, DSYEVD needs N**2 more
* workspace than DSYEVX.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
* On entry, the symmetric matrix A. If UPLO = 'U', the
* leading N-by-N upper triangular part of A contains the
* upper triangular part of the matrix A. If UPLO = 'L',
* the leading N-by-N lower triangular part of A contains
* the lower triangular part of the matrix A.
* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
* orthonormal eigenvectors of the matrix A.
* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
* or the upper triangle (if UPLO='U') of A, including the
* diagonal, is destroyed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* W (output) DOUBLE PRECISION array, dimension (N)
* If INFO = 0, the eigenvalues in ascending order.
*
* WORK (workspace/output) DOUBLE PRECISION array,
* dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* If N <= 1, LWORK must be at least 1.
* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1.
* If JOBZ = 'V' and N > 1, LWORK must be at least
* 1 + 6*N + 2*N**2.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal sizes of the WORK and IWORK
* arrays, returns these values as the first entries of the WORK
* and IWORK arrays, and no error message related to LWORK or
* LIWORK is issued by XERBLA.
*
* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK.
* If N <= 1, LIWORK must be at least 1.
* If JOBZ = 'N' and N > 1, LIWORK must be at least 1.
* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal sizes of the WORK and
* IWORK arrays, returns these values as the first entries of
* the WORK and IWORK arrays, and no error message related to
* LWORK or LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i and JOBZ = 'N', then the algorithm failed
* to converge; i off-diagonal elements of an intermediate
* tridiagonal form did not converge to zero;
* if INFO = i and JOBZ = 'V', then the algorithm failed
* to compute an eigenvalue while working on the submatrix
* lying in rows and columns INFO/(N+1) through
* mod(INFO,N+1).
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
* Modified by Francoise Tisseur, University of Tennessee.
*
* Modified description of INFO. Sven, 16 Feb 05.
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
*
LOGICAL LOWER, LQUERY, WANTZ
INTEGER IINFO, INDE, INDTAU, INDWK2, INDWRK, ISCALE,
$ LIOPT, LIWMIN, LLWORK, LLWRK2, LOPT, LWMIN
DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
$ SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANSY
EXTERNAL LSAME, DLAMCH, DLANSY, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DLACPY, DLASCL, DORMTR, DSCAL, DSTEDC, DSTERF,
$ DSYTRD, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
LOWER = LSAME( UPLO, 'L' )
LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
END IF
*
IF( INFO.EQ.0 ) THEN
IF( N.LE.1 ) THEN
LIWMIN = 1
LWMIN = 1
LOPT = LWMIN
LIOPT = LIWMIN
ELSE
IF( WANTZ ) THEN
LIWMIN = 3 + 5*N
LWMIN = 1 + 6*N + 2*N**2
ELSE
LIWMIN = 1
LWMIN = 2*N + 1
END IF
LOPT = MAX( LWMIN, 2*N +
$ ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) )
LIOPT = LIWMIN
END IF
WORK( 1 ) = LOPT
IWORK( 1 ) = LIOPT
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -8
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -10
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYEVD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
W( 1 ) = A( 1, 1 )
IF( WANTZ )
$ A( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = SQRT( BIGNUM )
*
* Scale matrix to allowable range, if necessary.
*
ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK )
ISCALE = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 )
$ CALL DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO )
*
* Call DSYTRD to reduce symmetric matrix to tridiagonal form.
*
INDE = 1
INDTAU = INDE + N
INDWRK = INDTAU + N
LLWORK = LWORK - INDWRK + 1
INDWK2 = INDWRK + N*N
LLWRK2 = LWORK - INDWK2 + 1
*
CALL DSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ),
$ WORK( INDWRK ), LLWORK, IINFO )
LOPT = 2*N + WORK( INDWRK )
*
* For eigenvalues only, call DSTERF. For eigenvectors, first call
* DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the
* tridiagonal matrix, then call DORMTR to multiply it by the
* Householder transformations stored in A.
*
IF( .NOT.WANTZ ) THEN
CALL DSTERF( N, W, WORK( INDE ), INFO )
ELSE
CALL DSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N,
$ WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO )
CALL DORMTR( 'L', UPLO, 'N', N, N, A, LDA, WORK( INDTAU ),
$ WORK( INDWRK ), N, WORK( INDWK2 ), LLWRK2, IINFO )
CALL DLACPY( 'A', N, N, WORK( INDWRK ), N, A, LDA )
LOPT = MAX( LOPT, 1+6*N+2*N**2 )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( ISCALE.EQ.1 )
$ CALL DSCAL( N, ONE / SIGMA, W, 1 )
*
WORK( 1 ) = LOPT
IWORK( 1 ) = LIOPT
*
RETURN
*
* End of DSYEVD
*
END
SUBROUTINE DSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU,
$ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK,
$ IWORK, LIWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE, UPLO
INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LWORK, M, N
DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER ISUPPZ( * ), IWORK( * )
DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DSYEVR computes selected eigenvalues and, optionally, eigenvectors
* of a real symmetric matrix A. Eigenvalues and eigenvectors can be
* selected by specifying either a range of values or a range of
* indices for the desired eigenvalues.
*
* DSYEVR first reduces the matrix A to tridiagonal form T with a call
* to DSYTRD. Then, whenever possible, DSYEVR calls DSTEMR to compute
* the eigenspectrum using Relatively Robust Representations. DSTEMR
* computes eigenvalues by the dqds algorithm, while orthogonal
* eigenvectors are computed from various "good" L D L^T representations
* (also known as Relatively Robust Representations). Gram-Schmidt
* orthogonalization is avoided as far as possible. More specifically,
* the various steps of the algorithm are as follows.
*
* For each unreduced block (submatrix) of T,
* (a) Compute T - sigma I = L D L^T, so that L and D
* define all the wanted eigenvalues to high relative accuracy.
* This means that small relative changes in the entries of D and L
* cause only small relative changes in the eigenvalues and
* eigenvectors. The standard (unfactored) representation of the
* tridiagonal matrix T does not have this property in general.
* (b) Compute the eigenvalues to suitable accuracy.
* If the eigenvectors are desired, the algorithm attains full
* accuracy of the computed eigenvalues only right before
* the corresponding vectors have to be computed, see steps c) and d).
* (c) For each cluster of close eigenvalues, select a new
* shift close to the cluster, find a new factorization, and refine
* the shifted eigenvalues to suitable accuracy.
* (d) For each eigenvalue with a large enough relative separation compute
* the corresponding eigenvector by forming a rank revealing twisted
* factorization. Go back to (c) for any clusters that remain.
*
* The desired accuracy of the output can be specified by the input
* parameter ABSTOL.
*
* For more details, see DSTEMR's documentation and:
* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
* 2004. Also LAPACK Working Note 154.
* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
* tridiagonal eigenvalue/eigenvector problem",
* Computer Science Division Technical Report No. UCB/CSD-97-971,
* UC Berkeley, May 1997.
*
*
* Note 1 : DSYEVR calls DSTEMR when the full spectrum is requested
* on machines which conform to the ieee-754 floating point standard.
* DSYEVR calls DSTEBZ and SSTEIN on non-ieee machines and
* when partial spectrum requests are made.
*
* Normal execution of DSTEMR may create NaNs and infinities and
* hence may abort due to a floating point exception in environments
* which do not handle NaNs and infinities in the ieee standard default
* manner.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* RANGE (input) CHARACTER*1
* = 'A': all eigenvalues will be found.
* = 'V': all eigenvalues in the half-open interval (VL,VU]
* will be found.
* = 'I': the IL-th through IU-th eigenvalues will be found.
********** For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and
********** DSTEIN are called
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
* On entry, the symmetric matrix A. If UPLO = 'U', the
* leading N-by-N upper triangular part of A contains the
* upper triangular part of the matrix A. If UPLO = 'L',
* the leading N-by-N lower triangular part of A contains
* the lower triangular part of the matrix A.
* On exit, the lower triangle (if UPLO='L') or the upper
* triangle (if UPLO='U') of A, including the diagonal, is
* destroyed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* VL (input) DOUBLE PRECISION
* VU (input) DOUBLE PRECISION
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* ABSTOL (input) DOUBLE PRECISION
* The absolute error tolerance for the eigenvalues.
* An approximate eigenvalue is accepted as converged
* when it is determined to lie in an interval [a,b]
* of width less than or equal to
*
* ABSTOL + EPS * max( |a|,|b| ) ,
*
* where EPS is the machine precision. If ABSTOL is less than
* or equal to zero, then EPS*|T| will be used in its place,
* where |T| is the 1-norm of the tridiagonal matrix obtained
* by reducing A to tridiagonal form.
*
* See "Computing Small Singular Values of Bidiagonal Matrices
* with Guaranteed High Relative Accuracy," by Demmel and
* Kahan, LAPACK Working Note #3.
*
* If high relative accuracy is important, set ABSTOL to
* DLAMCH( 'Safe minimum' ). Doing so will guarantee that
* eigenvalues are computed to high relative accuracy when
* possible in future releases. The current code does not
* make any guarantees about high relative accuracy, but
* future releases will. See J. Barlow and J. Demmel,
* "Computing Accurate Eigensystems of Scaled Diagonally
* Dominant Matrices", LAPACK Working Note #7, for a discussion
* of which matrices define their eigenvalues to high relative
* accuracy.
*
* M (output) INTEGER
* The total number of eigenvalues found. 0 <= M <= N.
* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*
* W (output) DOUBLE PRECISION array, dimension (N)
* The first M elements contain the selected eigenvalues in
* ascending order.
*
* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
* contain the orthonormal eigenvectors of the matrix A
* corresponding to the selected eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* If JOBZ = 'N', then Z is not referenced.
* Note: the user must ensure that at least max(1,M) columns are
* supplied in the array Z; if RANGE = 'V', the exact value of M
* is not known in advance and an upper bound must be used.
* Supplying N columns is always safe.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )
* The support of the eigenvectors in Z, i.e., the indices
* indicating the nonzero elements in Z. The i-th eigenvector
* is nonzero only in elements ISUPPZ( 2*i-1 ) through
* ISUPPZ( 2*i ).
********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1
*
* 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,26*N).
* For optimal efficiency, LWORK >= (NB+6)*N,
* where NB is the max of the blocksize for DSYTRD and DORMTR
* returned by ILAENV.
*
* 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.
*
* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if INFO = 0, IWORK(1) returns the optimal LWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK. LIWORK >= max(1,10*N).
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal size of the IWORK array,
* returns this value as the first entry of the IWORK array, and
* no error message related to LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: Internal error
*
* Further Details
* ===============
*
* Based on contributions by
* Inderjit Dhillon, IBM Almaden, USA
* Osni Marques, LBNL/NERSC, USA
* Ken Stanley, Computer Science Division, University of
* California at Berkeley, USA
* Jason Riedy, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, VALEIG, WANTZ,
$ TRYRAC
CHARACTER ORDER
INTEGER I, IEEEOK, IINFO, IMAX, INDD, INDDD, INDE,
$ INDEE, INDIBL, INDIFL, INDISP, INDIWO, INDTAU,
$ INDWK, INDWKN, ISCALE, J, JJ, LIWMIN,
$ LLWORK, LLWRKN, LWKOPT, LWMIN, NB, NSPLIT
DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
$ SIGMA, SMLNUM, TMP1, VLL, VUU
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANSY
EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DORMTR, DSCAL, DSTEBZ, DSTEMR, DSTEIN,
$ DSTERF, DSWAP, DSYTRD, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
IEEEOK = ILAENV( 10, 'DSYEVR', 'N', 1, 2, 3, 4 )
*
LOWER = LSAME( UPLO, 'L' )
WANTZ = LSAME( JOBZ, 'V' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
*
LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LIWORK.EQ.-1 ) )
*
LWMIN = MAX( 1, 26*N )
LIWMIN = MAX( 1, 10*N )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
INFO = -2
ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE
IF( VALEIG ) THEN
IF( N.GT.0 .AND. VU.LE.VL )
$ INFO = -8
ELSE IF( INDEIG ) THEN
IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
INFO = -10
END IF
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -15
ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -18
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -20
END IF
END IF
*
IF( INFO.EQ.0 ) THEN
NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
NB = MAX( NB, ILAENV( 1, 'DORMTR', UPLO, N, -1, -1, -1 ) )
LWKOPT = MAX( ( NB+1 )*N, LWMIN )
WORK( 1 ) = LWKOPT
IWORK( 1 ) = LIWMIN
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYEVR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
IF( N.EQ.1 ) THEN
WORK( 1 ) = 7
IF( ALLEIG .OR. INDEIG ) THEN
M = 1
W( 1 ) = A( 1, 1 )
ELSE
IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN
M = 1
W( 1 ) = A( 1, 1 )
END IF
END IF
IF( WANTZ )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
*
* Scale matrix to allowable range, if necessary.
*
ISCALE = 0
ABSTLL = ABSTOL
VLL = VL
VUU = VU
ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK )
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 ) THEN
IF( LOWER ) THEN
DO 10 J = 1, N
CALL DSCAL( N-J+1, SIGMA, A( J, J ), 1 )
10 CONTINUE
ELSE
DO 20 J = 1, N
CALL DSCAL( J, SIGMA, A( 1, J ), 1 )
20 CONTINUE
END IF
IF( ABSTOL.GT.0 )
$ ABSTLL = ABSTOL*SIGMA
IF( VALEIG ) THEN
VLL = VL*SIGMA
VUU = VU*SIGMA
END IF
END IF
* Initialize indices into workspaces. Note: The IWORK indices are
* used only if DSTERF or DSTEMR fail.
* WORK(INDTAU:INDTAU+N-1) stores the scalar factors of the
* elementary reflectors used in DSYTRD.
INDTAU = 1
* WORK(INDD:INDD+N-1) stores the tridiagonal's diagonal entries.
INDD = INDTAU + N
* WORK(INDE:INDE+N-1) stores the off-diagonal entries of the
* tridiagonal matrix from DSYTRD.
INDE = INDD + N
* WORK(INDDD:INDDD+N-1) is a copy of the diagonal entries over
* -written by DSTEMR (the DSTERF path copies the diagonal to W).
INDDD = INDE + N
* WORK(INDEE:INDEE+N-1) is a copy of the off-diagonal entries over
* -written while computing the eigenvalues in DSTERF and DSTEMR.
INDEE = INDDD + N
* INDWK is the starting offset of the left-over workspace, and
* LLWORK is the remaining workspace size.
INDWK = INDEE + N
LLWORK = LWORK - INDWK + 1
* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in DSTEBZ and
* stores the block indices of each of the M<=N eigenvalues.
INDIBL = 1
* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in DSTEBZ and
* stores the starting and finishing indices of each block.
INDISP = INDIBL + N
* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors
* that corresponding to eigenvectors that fail to converge in
* DSTEIN. This information is discarded; if any fail, the driver
* returns INFO > 0.
INDIFL = INDISP + N
* INDIWO is the offset of the remaining integer workspace.
INDIWO = INDISP + N
*
* Call DSYTRD to reduce symmetric matrix to tridiagonal form.
*
CALL DSYTRD( UPLO, N, A, LDA, WORK( INDD ), WORK( INDE ),
$ WORK( INDTAU ), WORK( INDWK ), LLWORK, IINFO )
*
* If all eigenvalues are desired
* then call DSTERF or DSTEMR and DORMTR.
*
IF( ( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) .AND.
$ IEEEOK.EQ.1 ) THEN
IF( .NOT.WANTZ ) THEN
CALL DCOPY( N, WORK( INDD ), 1, W, 1 )
CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
CALL DSTERF( N, W, WORK( INDEE ), INFO )
ELSE
CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
CALL DCOPY( N, WORK( INDD ), 1, WORK( INDDD ), 1 )
*
IF (ABSTOL .LE. TWO*N*EPS) THEN
TRYRAC = .TRUE.
ELSE
TRYRAC = .FALSE.
END IF
CALL DSTEMR( JOBZ, 'A', N, WORK( INDDD ), WORK( INDEE ),
$ VL, VU, IL, IU, M, W, Z, LDZ, N, ISUPPZ,
$ TRYRAC, WORK( INDWK ), LWORK, IWORK, LIWORK,
$ INFO )
*
*
*
* Apply orthogonal matrix used in reduction to tridiagonal
* form to eigenvectors returned by DSTEIN.
*
IF( WANTZ .AND. INFO.EQ.0 ) THEN
INDWKN = INDE
LLWRKN = LWORK - INDWKN + 1
CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA,
$ WORK( INDTAU ), Z, LDZ, WORK( INDWKN ),
$ LLWRKN, IINFO )
END IF
END IF
*
*
IF( INFO.EQ.0 ) THEN
* Everything worked. Skip DSTEBZ/DSTEIN. IWORK(:) are
* undefined.
M = N
GO TO 30
END IF
INFO = 0
END IF
*
* Otherwise, call DSTEBZ and, if eigenvectors are desired, DSTEIN.
* Also call DSTEBZ and DSTEIN if DSTEMR fails.
*
IF( WANTZ ) THEN
ORDER = 'B'
ELSE
ORDER = 'E'
END IF
CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
$ WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
$ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWK ),
$ IWORK( INDIWO ), INFO )
*
IF( WANTZ ) THEN
CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
$ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
$ WORK( INDWK ), IWORK( INDIWO ), IWORK( INDIFL ),
$ INFO )
*
* Apply orthogonal matrix used in reduction to tridiagonal
* form to eigenvectors returned by DSTEIN.
*
INDWKN = INDE
LLWRKN = LWORK - INDWKN + 1
CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z,
$ LDZ, WORK( INDWKN ), LLWRKN, IINFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
* Jump here if DSTEMR/DSTEIN succeeded.
30 CONTINUE
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = M
ELSE
IMAX = INFO - 1
END IF
CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
* If eigenvalues are not in order, then sort them, along with
* eigenvectors. Note: We do not sort the IFAIL portion of IWORK.
* It may not be initialized (if DSTEMR/DSTEIN succeeded), and we do
* not return this detailed information to the user.
*
IF( WANTZ ) THEN
DO 50 J = 1, M - 1
I = 0
TMP1 = W( J )
DO 40 JJ = J + 1, M
IF( W( JJ ).LT.TMP1 ) THEN
I = JJ
TMP1 = W( JJ )
END IF
40 CONTINUE
*
IF( I.NE.0 ) THEN
W( I ) = W( J )
W( J ) = TMP1
CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
END IF
50 CONTINUE
END IF
*
* Set WORK(1) to optimal workspace size.
*
WORK( 1 ) = LWKOPT
IWORK( 1 ) = LIWMIN
*
RETURN
*
* End of DSYEVR
*
END
SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU,
$ ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK,
$ IFAIL, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE, UPLO
INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N
DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER IFAIL( * ), IWORK( * )
DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DSYEVX computes selected eigenvalues and, optionally, eigenvectors
* of a real symmetric matrix A. Eigenvalues and eigenvectors can be
* selected by specifying either a range of values or a range of indices
* for the desired eigenvalues.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* RANGE (input) CHARACTER*1
* = 'A': all eigenvalues will be found.
* = 'V': all eigenvalues in the half-open interval (VL,VU]
* will be found.
* = 'I': the IL-th through IU-th eigenvalues will be found.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
* On entry, the symmetric matrix A. If UPLO = 'U', the
* leading N-by-N upper triangular part of A contains the
* upper triangular part of the matrix A. If UPLO = 'L',
* the leading N-by-N lower triangular part of A contains
* the lower triangular part of the matrix A.
* On exit, the lower triangle (if UPLO='L') or the upper
* triangle (if UPLO='U') of A, including the diagonal, is
* destroyed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* VL (input) DOUBLE PRECISION
* VU (input) DOUBLE PRECISION
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* ABSTOL (input) DOUBLE PRECISION
* The absolute error tolerance for the eigenvalues.
* An approximate eigenvalue is accepted as converged
* when it is determined to lie in an interval [a,b]
* of width less than or equal to
*
* ABSTOL + EPS * max( |a|,|b| ) ,
*
* where EPS is the machine precision. If ABSTOL is less than
* or equal to zero, then EPS*|T| will be used in its place,
* where |T| is the 1-norm of the tridiagonal matrix obtained
* by reducing A to tridiagonal form.
*
* Eigenvalues will be computed most accurately when ABSTOL is
* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
* If this routine returns with INFO>0, indicating that some
* eigenvectors did not converge, try setting ABSTOL to
* 2*DLAMCH('S').
*
* See "Computing Small Singular Values of Bidiagonal Matrices
* with Guaranteed High Relative Accuracy," by Demmel and
* Kahan, LAPACK Working Note #3.
*
* M (output) INTEGER
* The total number of eigenvalues found. 0 <= M <= N.
* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*
* W (output) DOUBLE PRECISION array, dimension (N)
* On normal exit, the first M elements contain the selected
* eigenvalues in ascending order.
*
* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
* contain the orthonormal eigenvectors of the matrix A
* corresponding to the selected eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* If an eigenvector fails to converge, then that column of Z
* contains the latest approximation to the eigenvector, and the
* index of the eigenvector is returned in IFAIL.
* If JOBZ = 'N', then Z is not referenced.
* Note: the user must ensure that at least max(1,M) columns are
* supplied in the array Z; if RANGE = 'V', the exact value of M
* is not known in advance and an upper bound must be used.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* 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 length of the array WORK. LWORK >= 1, when N <= 1;
* otherwise 8*N.
* For optimal efficiency, LWORK >= (NB+3)*N,
* where NB is the max of the blocksize for DSYTRD and DORMTR
* returned by ILAENV.
*
* 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.
*
* IWORK (workspace) INTEGER array, dimension (5*N)
*
* IFAIL (output) INTEGER array, dimension (N)
* If JOBZ = 'V', then if INFO = 0, the first M elements of
* IFAIL are zero. If INFO > 0, then IFAIL contains the
* indices of the eigenvectors that failed to converge.
* If JOBZ = 'N', then IFAIL is not referenced.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, then i eigenvectors failed to converge.
* Their indices are stored in array IFAIL.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG,
$ WANTZ
CHARACTER ORDER
INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
$ INDISP, INDIWO, INDTAU, INDWKN, INDWRK, ISCALE,
$ ITMP1, J, JJ, LLWORK, LLWRKN, LWKMIN,
$ LWKOPT, NB, NSPLIT
DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
$ SIGMA, SMLNUM, TMP1, VLL, VUU
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANSY
EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLACPY, DORGTR, DORMTR, DSCAL, DSTEBZ,
$ DSTEIN, DSTEQR, DSTERF, DSWAP, DSYTRD, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
LOWER = LSAME( UPLO, 'L' )
WANTZ = LSAME( JOBZ, 'V' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
LQUERY = ( LWORK.EQ.-1 )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
INFO = -2
ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE
IF( VALEIG ) THEN
IF( N.GT.0 .AND. VU.LE.VL )
$ INFO = -8
ELSE IF( INDEIG ) THEN
IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
INFO = -10
END IF
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -15
END IF
END IF
*
IF( INFO.EQ.0 ) THEN
IF( N.LE.1 ) THEN
LWKMIN = 1
WORK( 1 ) = LWKMIN
ELSE
LWKMIN = 8*N
NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
NB = MAX( NB, ILAENV( 1, 'DORMTR', UPLO, N, -1, -1, -1 ) )
LWKOPT = MAX( LWKMIN, ( NB + 3 )*N )
WORK( 1 ) = LWKOPT
END IF
*
IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY )
$ INFO = -17
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYEVX', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 ) THEN
RETURN
END IF
*
IF( N.EQ.1 ) THEN
IF( ALLEIG .OR. INDEIG ) THEN
M = 1
W( 1 ) = A( 1, 1 )
ELSE
IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN
M = 1
W( 1 ) = A( 1, 1 )
END IF
END IF
IF( WANTZ )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
*
* Scale matrix to allowable range, if necessary.
*
ISCALE = 0
ABSTLL = ABSTOL
IF( VALEIG ) THEN
VLL = VL
VUU = VU
END IF
ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK )
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 ) THEN
IF( LOWER ) THEN
DO 10 J = 1, N
CALL DSCAL( N-J+1, SIGMA, A( J, J ), 1 )
10 CONTINUE
ELSE
DO 20 J = 1, N
CALL DSCAL( J, SIGMA, A( 1, J ), 1 )
20 CONTINUE
END IF
IF( ABSTOL.GT.0 )
$ ABSTLL = ABSTOL*SIGMA
IF( VALEIG ) THEN
VLL = VL*SIGMA
VUU = VU*SIGMA
END IF
END IF
*
* Call DSYTRD to reduce symmetric matrix to tridiagonal form.
*
INDTAU = 1
INDE = INDTAU + N
INDD = INDE + N
INDWRK = INDD + N
LLWORK = LWORK - INDWRK + 1
CALL DSYTRD( UPLO, N, A, LDA, WORK( INDD ), WORK( INDE ),
$ WORK( INDTAU ), WORK( INDWRK ), LLWORK, IINFO )
*
* If all eigenvalues are desired and ABSTOL is less than or equal to
* zero, then call DSTERF or DORGTR and SSTEQR. If this fails for
* some eigenvalue, then try DSTEBZ.
*
TEST = .FALSE.
IF( INDEIG ) THEN
IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
TEST = .TRUE.
END IF
END IF
IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN
CALL DCOPY( N, WORK( INDD ), 1, W, 1 )
INDEE = INDWRK + 2*N
IF( .NOT.WANTZ ) THEN
CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
CALL DSTERF( N, W, WORK( INDEE ), INFO )
ELSE
CALL DLACPY( 'A', N, N, A, LDA, Z, LDZ )
CALL DORGTR( UPLO, N, Z, LDZ, WORK( INDTAU ),
$ WORK( INDWRK ), LLWORK, IINFO )
CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ,
$ WORK( INDWRK ), INFO )
IF( INFO.EQ.0 ) THEN
DO 30 I = 1, N
IFAIL( I ) = 0
30 CONTINUE
END IF
END IF
IF( INFO.EQ.0 ) THEN
M = N
GO TO 40
END IF
INFO = 0
END IF
*
* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN.
*
IF( WANTZ ) THEN
ORDER = 'B'
ELSE
ORDER = 'E'
END IF
INDIBL = 1
INDISP = INDIBL + N
INDIWO = INDISP + N
CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
$ WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
$ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ),
$ IWORK( INDIWO ), INFO )
*
IF( WANTZ ) THEN
CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
$ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
$ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO )
*
* Apply orthogonal matrix used in reduction to tridiagonal
* form to eigenvectors returned by DSTEIN.
*
INDWKN = INDE
LLWRKN = LWORK - INDWKN + 1
CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z,
$ LDZ, WORK( INDWKN ), LLWRKN, IINFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
40 CONTINUE
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = M
ELSE
IMAX = INFO - 1
END IF
CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
* If eigenvalues are not in order, then sort them, along with
* eigenvectors.
*
IF( WANTZ ) THEN
DO 60 J = 1, M - 1
I = 0
TMP1 = W( J )
DO 50 JJ = J + 1, M
IF( W( JJ ).LT.TMP1 ) THEN
I = JJ
TMP1 = W( JJ )
END IF
50 CONTINUE
*
IF( I.NE.0 ) THEN
ITMP1 = IWORK( INDIBL+I-1 )
W( I ) = W( J )
IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
W( J ) = TMP1
IWORK( INDIBL+J-1 ) = ITMP1
CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
IF( INFO.NE.0 ) THEN
ITMP1 = IFAIL( I )
IFAIL( I ) = IFAIL( J )
IFAIL( J ) = ITMP1
END IF
END IF
60 CONTINUE
END IF
*
* Set WORK(1) to optimal workspace size.
*
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of DSYEVX
*
END
SUBROUTINE DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, ITYPE, LDA, LDB, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* DSYGS2 reduces a real symmetric-definite generalized eigenproblem
* to standard form.
*
* If ITYPE = 1, the problem is A*x = lambda*B*x,
* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')
*
* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.
*
* B must have been previously factorized as U'*U or L*L' by DPOTRF.
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');
* = 2 or 3: compute U*A*U' or L'*A*L.
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored, and how B has been factorized.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the symmetric matrix A. If UPLO = 'U', the leading
* n by n upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading n by n lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced.
*
* On exit, if INFO = 0, the transformed matrix, stored in the
* same format as A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input) DOUBLE PRECISION array, dimension (LDB,N)
* The triangular factor from the Cholesky factorization of B,
* as returned by DPOTRF.
*
* 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, HALF
PARAMETER ( ONE = 1.0D0, HALF = 0.5D0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER K
DOUBLE PRECISION AKK, BKK, CT
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DSCAL, DSYR2, DTRMV, DTRSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
INFO = -1
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYGS2', -INFO )
RETURN
END IF
*
IF( ITYPE.EQ.1 ) THEN
IF( UPPER ) THEN
*
* Compute inv(U')*A*inv(U)
*
DO 10 K = 1, N
*
* Update the upper triangle of A(k:n,k:n)
*
AKK = A( K, K )
BKK = B( K, K )
AKK = AKK / BKK**2
A( K, K ) = AKK
IF( K.LT.N ) THEN
CALL DSCAL( N-K, ONE / BKK, A( K, K+1 ), LDA )
CT = -HALF*AKK
CALL DAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ),
$ LDA )
CALL DSYR2( UPLO, N-K, -ONE, A( K, K+1 ), LDA,
$ B( K, K+1 ), LDB, A( K+1, K+1 ), LDA )
CALL DAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ),
$ LDA )
CALL DTRSV( UPLO, 'Transpose', 'Non-unit', N-K,
$ B( K+1, K+1 ), LDB, A( K, K+1 ), LDA )
END IF
10 CONTINUE
ELSE
*
* Compute inv(L)*A*inv(L')
*
DO 20 K = 1, N
*
* Update the lower triangle of A(k:n,k:n)
*
AKK = A( K, K )
BKK = B( K, K )
AKK = AKK / BKK**2
A( K, K ) = AKK
IF( K.LT.N ) THEN
CALL DSCAL( N-K, ONE / BKK, A( K+1, K ), 1 )
CT = -HALF*AKK
CALL DAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 )
CALL DSYR2( UPLO, N-K, -ONE, A( K+1, K ), 1,
$ B( K+1, K ), 1, A( K+1, K+1 ), LDA )
CALL DAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 )
CALL DTRSV( UPLO, 'No transpose', 'Non-unit', N-K,
$ B( K+1, K+1 ), LDB, A( K+1, K ), 1 )
END IF
20 CONTINUE
END IF
ELSE
IF( UPPER ) THEN
*
* Compute U*A*U'
*
DO 30 K = 1, N
*
* Update the upper triangle of A(1:k,1:k)
*
AKK = A( K, K )
BKK = B( K, K )
CALL DTRMV( UPLO, 'No transpose', 'Non-unit', K-1, B,
$ LDB, A( 1, K ), 1 )
CT = HALF*AKK
CALL DAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 )
CALL DSYR2( UPLO, K-1, ONE, A( 1, K ), 1, B( 1, K ), 1,
$ A, LDA )
CALL DAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 )
CALL DSCAL( K-1, BKK, A( 1, K ), 1 )
A( K, K ) = AKK*BKK**2
30 CONTINUE
ELSE
*
* Compute L'*A*L
*
DO 40 K = 1, N
*
* Update the lower triangle of A(1:k,1:k)
*
AKK = A( K, K )
BKK = B( K, K )
CALL DTRMV( UPLO, 'Transpose', 'Non-unit', K-1, B, LDB,
$ A( K, 1 ), LDA )
CT = HALF*AKK
CALL DAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA )
CALL DSYR2( UPLO, K-1, ONE, A( K, 1 ), LDA, B( K, 1 ),
$ LDB, A, LDA )
CALL DAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA )
CALL DSCAL( K-1, BKK, A( K, 1 ), LDA )
A( K, K ) = AKK*BKK**2
40 CONTINUE
END IF
END IF
RETURN
*
* End of DSYGS2
*
END
SUBROUTINE DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, ITYPE, LDA, LDB, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* DSYGST reduces a real symmetric-definite generalized eigenproblem
* to standard form.
*
* If ITYPE = 1, the problem is A*x = lambda*B*x,
* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)
*
* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.
*
* B must have been previously factorized as U**T*U or L*L**T by DPOTRF.
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);
* = 2 or 3: compute U*A*U**T or L**T*A*L.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored and B is factored as
* U**T*U;
* = 'L': Lower triangle of A is stored and B is factored as
* L*L**T.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the symmetric matrix A. If UPLO = 'U', the leading
* N-by-N upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading N-by-N lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced.
*
* On exit, if INFO = 0, the transformed matrix, stored in the
* same format as A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input) DOUBLE PRECISION array, dimension (LDB,N)
* The triangular factor from the Cholesky factorization of B,
* as returned by DPOTRF.
*
* 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, HALF
PARAMETER ( ONE = 1.0D0, HALF = 0.5D0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER K, KB, NB
* ..
* .. External Subroutines ..
EXTERNAL DSYGS2, DSYMM, DSYR2K, DTRMM, DTRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
INFO = -1
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYGST', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Determine the block size for this environment.
*
NB = ILAENV( 1, 'DSYGST', UPLO, N, -1, -1, -1 )
*
IF( NB.LE.1 .OR. NB.GE.N ) THEN
*
* Use unblocked code
*
CALL DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
ELSE
*
* Use blocked code
*
IF( ITYPE.EQ.1 ) THEN
IF( UPPER ) THEN
*
* Compute inv(U')*A*inv(U)
*
DO 10 K = 1, N, NB
KB = MIN( N-K+1, NB )
*
* Update the upper triangle of A(k:n,k:n)
*
CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
$ B( K, K ), LDB, INFO )
IF( K+KB.LE.N ) THEN
CALL DTRSM( 'Left', UPLO, 'Transpose', 'Non-unit',
$ KB, N-K-KB+1, ONE, B( K, K ), LDB,
$ A( K, K+KB ), LDA )
CALL DSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF,
$ A( K, K ), LDA, B( K, K+KB ), LDB, ONE,
$ A( K, K+KB ), LDA )
CALL DSYR2K( UPLO, 'Transpose', N-K-KB+1, KB, -ONE,
$ A( K, K+KB ), LDA, B( K, K+KB ), LDB,
$ ONE, A( K+KB, K+KB ), LDA )
CALL DSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF,
$ A( K, K ), LDA, B( K, K+KB ), LDB, ONE,
$ A( K, K+KB ), LDA )
CALL DTRSM( 'Right', UPLO, 'No transpose',
$ 'Non-unit', KB, N-K-KB+1, ONE,
$ B( K+KB, K+KB ), LDB, A( K, K+KB ),
$ LDA )
END IF
10 CONTINUE
ELSE
*
* Compute inv(L)*A*inv(L')
*
DO 20 K = 1, N, NB
KB = MIN( N-K+1, NB )
*
* Update the lower triangle of A(k:n,k:n)
*
CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
$ B( K, K ), LDB, INFO )
IF( K+KB.LE.N ) THEN
CALL DTRSM( 'Right', UPLO, 'Transpose', 'Non-unit',
$ N-K-KB+1, KB, ONE, B( K, K ), LDB,
$ A( K+KB, K ), LDA )
CALL DSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF,
$ A( K, K ), LDA, B( K+KB, K ), LDB, ONE,
$ A( K+KB, K ), LDA )
CALL DSYR2K( UPLO, 'No transpose', N-K-KB+1, KB,
$ -ONE, A( K+KB, K ), LDA, B( K+KB, K ),
$ LDB, ONE, A( K+KB, K+KB ), LDA )
CALL DSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF,
$ A( K, K ), LDA, B( K+KB, K ), LDB, ONE,
$ A( K+KB, K ), LDA )
CALL DTRSM( 'Left', UPLO, 'No transpose',
$ 'Non-unit', N-K-KB+1, KB, ONE,
$ B( K+KB, K+KB ), LDB, A( K+KB, K ),
$ LDA )
END IF
20 CONTINUE
END IF
ELSE
IF( UPPER ) THEN
*
* Compute U*A*U'
*
DO 30 K = 1, N, NB
KB = MIN( N-K+1, NB )
*
* Update the upper triangle of A(1:k+kb-1,1:k+kb-1)
*
CALL DTRMM( 'Left', UPLO, 'No transpose', 'Non-unit',
$ K-1, KB, ONE, B, LDB, A( 1, K ), LDA )
CALL DSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ),
$ LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA )
CALL DSYR2K( UPLO, 'No transpose', K-1, KB, ONE,
$ A( 1, K ), LDA, B( 1, K ), LDB, ONE, A,
$ LDA )
CALL DSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ),
$ LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA )
CALL DTRMM( 'Right', UPLO, 'Transpose', 'Non-unit',
$ K-1, KB, ONE, B( K, K ), LDB, A( 1, K ),
$ LDA )
CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
$ B( K, K ), LDB, INFO )
30 CONTINUE
ELSE
*
* Compute L'*A*L
*
DO 40 K = 1, N, NB
KB = MIN( N-K+1, NB )
*
* Update the lower triangle of A(1:k+kb-1,1:k+kb-1)
*
CALL DTRMM( 'Right', UPLO, 'No transpose', 'Non-unit',
$ KB, K-1, ONE, B, LDB, A( K, 1 ), LDA )
CALL DSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ),
$ LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA )
CALL DSYR2K( UPLO, 'Transpose', K-1, KB, ONE,
$ A( K, 1 ), LDA, B( K, 1 ), LDB, ONE, A,
$ LDA )
CALL DSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ),
$ LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA )
CALL DTRMM( 'Left', UPLO, 'Transpose', 'Non-unit', KB,
$ K-1, ONE, B( K, K ), LDB, A( K, 1 ), LDA )
CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
$ B( K, K ), LDB, INFO )
40 CONTINUE
END IF
END IF
END IF
RETURN
*
* End of DSYGST
*
END
SUBROUTINE DSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK,
$ LWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, ITYPE, LDA, LDB, LWORK, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DSYGV computes all the eigenvalues, and optionally, the eigenvectors
* of a real generalized symmetric-definite eigenproblem, of the form
* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
* Here A and B are assumed to be symmetric and B is also
* positive definite.
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* Specifies the problem type to be solved:
* = 1: A*x = (lambda)*B*x
* = 2: A*B*x = (lambda)*x
* = 3: B*A*x = (lambda)*x
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangles of A and B are stored;
* = 'L': Lower triangles of A and B are stored.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
* On entry, the symmetric matrix A. If UPLO = 'U', the
* leading N-by-N upper triangular part of A contains the
* upper triangular part of the matrix A. If UPLO = 'L',
* the leading N-by-N lower triangular part of A contains
* the lower triangular part of the matrix A.
*
* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
* matrix Z of eigenvectors. The eigenvectors are normalized
* as follows:
* if ITYPE = 1 or 2, Z**T*B*Z = I;
* if ITYPE = 3, Z**T*inv(B)*Z = I.
* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
* or the lower triangle (if UPLO='L') of A, including the
* diagonal, is destroyed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
* On entry, the symmetric positive definite matrix B.
* If UPLO = 'U', the leading N-by-N upper triangular part of B
* contains the upper triangular part of the matrix B.
* If UPLO = 'L', the leading N-by-N lower triangular part of B
* contains the lower triangular part of the matrix B.
*
* On exit, if INFO <= N, the part of B containing the matrix is
* overwritten by the triangular factor U or L from the Cholesky
* factorization B = U**T*U or B = L*L**T.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* W (output) DOUBLE PRECISION array, dimension (N)
* If INFO = 0, the eigenvalues in ascending order.
*
* 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 length of the array WORK. LWORK >= max(1,3*N-1).
* For optimal efficiency, LWORK >= (NB+2)*N,
* where NB is the blocksize for DSYTRD returned by ILAENV.
*
* 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
* > 0: DPOTRF or DSYEV returned an error code:
* <= N: if INFO = i, DSYEV failed to converge;
* i off-diagonal elements of an intermediate
* tridiagonal form did not converge to zero;
* > N: if INFO = N + i, for 1 <= i <= N, then the leading
* minor of order i of B is not positive definite.
* The factorization of B could not be completed and
* no eigenvalues or eigenvectors were computed.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, UPPER, WANTZ
CHARACTER TRANS
INTEGER LWKMIN, LWKOPT, NB, NEIG
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DPOTRF, DSYEV, DSYGST, DTRMM, DTRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
UPPER = LSAME( UPLO, 'U' )
LQUERY = ( LWORK.EQ.-1 )
*
INFO = 0
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
INFO = -1
ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -2
ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
*
IF( INFO.EQ.0 ) THEN
LWKMIN = MAX( 1, 3*N - 1 )
NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
LWKOPT = MAX( LWKMIN, ( NB + 2 )*N )
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
INFO = -11
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYGV ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Form a Cholesky factorization of B.
*
CALL DPOTRF( UPLO, N, B, LDB, INFO )
IF( INFO.NE.0 ) THEN
INFO = N + INFO
RETURN
END IF
*
* Transform problem to standard eigenvalue problem and solve.
*
CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
CALL DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )
*
IF( WANTZ ) THEN
*
* Backtransform eigenvectors to the original problem.
*
NEIG = N
IF( INFO.GT.0 )
$ NEIG = INFO - 1
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
*
* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
*
IF( UPPER ) THEN
TRANS = 'N'
ELSE
TRANS = 'T'
END IF
*
CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE,
$ B, LDB, A, LDA )
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* For B*A*x=(lambda)*x;
* backtransform eigenvectors: x = L*y or U'*y
*
IF( UPPER ) THEN
TRANS = 'T'
ELSE
TRANS = 'N'
END IF
*
CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE,
$ B, LDB, A, LDA )
END IF
END IF
*
WORK( 1 ) = LWKOPT
RETURN
*
* End of DSYGV
*
END
SUBROUTINE DSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK,
$ LWORK, IWORK, LIWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, ITYPE, LDA, LDB, LIWORK, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DSYGVD computes all the eigenvalues, and optionally, the eigenvectors
* of a real generalized symmetric-definite eigenproblem, of the form
* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
* B are assumed to be symmetric and B is also positive definite.
* If eigenvectors are desired, it uses a divide and conquer algorithm.
*
* The divide and conquer algorithm makes very mild assumptions about
* floating point arithmetic. It will work on machines with a guard
* digit in add/subtract, or on those binary machines without guard
* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
* Cray-2. It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* Specifies the problem type to be solved:
* = 1: A*x = (lambda)*B*x
* = 2: A*B*x = (lambda)*x
* = 3: B*A*x = (lambda)*x
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangles of A and B are stored;
* = 'L': Lower triangles of A and B are stored.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
* On entry, the symmetric matrix A. If UPLO = 'U', the
* leading N-by-N upper triangular part of A contains the
* upper triangular part of the matrix A. If UPLO = 'L',
* the leading N-by-N lower triangular part of A contains
* the lower triangular part of the matrix A.
*
* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
* matrix Z of eigenvectors. The eigenvectors are normalized
* as follows:
* if ITYPE = 1 or 2, Z**T*B*Z = I;
* if ITYPE = 3, Z**T*inv(B)*Z = I.
* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
* or the lower triangle (if UPLO='L') of A, including the
* diagonal, is destroyed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
* On entry, the symmetric matrix B. If UPLO = 'U', the
* leading N-by-N upper triangular part of B contains the
* upper triangular part of the matrix B. If UPLO = 'L',
* the leading N-by-N lower triangular part of B contains
* the lower triangular part of the matrix B.
*
* On exit, if INFO <= N, the part of B containing the matrix is
* overwritten by the triangular factor U or L from the Cholesky
* factorization B = U**T*U or B = L*L**T.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* W (output) DOUBLE PRECISION array, dimension (N)
* If INFO = 0, the eigenvalues in ascending order.
*
* 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 N <= 1, LWORK >= 1.
* If JOBZ = 'N' and N > 1, LWORK >= 2*N+1.
* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal sizes of the WORK and IWORK
* arrays, returns these values as the first entries of the WORK
* and IWORK arrays, and no error message related to LWORK or
* LIWORK is issued by XERBLA.
*
* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK.
* If N <= 1, LIWORK >= 1.
* If JOBZ = 'N' and N > 1, LIWORK >= 1.
* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal sizes of the WORK and
* IWORK arrays, returns these values as the first entries of
* the WORK and IWORK arrays, and no error message related to
* LWORK or LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: DPOTRF or DSYEVD returned an error code:
* <= N: if INFO = i and JOBZ = 'N', then the algorithm
* failed to converge; i off-diagonal elements of an
* intermediate tridiagonal form did not converge to
* zero;
* if INFO = i and JOBZ = 'V', then the algorithm
* failed to compute an eigenvalue while working on
* the submatrix lying in rows and columns INFO/(N+1)
* through mod(INFO,N+1);
* > N: if INFO = N + i, for 1 <= i <= N, then the leading
* minor of order i of B is not positive definite.
* The factorization of B could not be completed and
* no eigenvalues or eigenvectors were computed.
*
* Further Details
* ===============
*
* Based on contributions by
* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
*
* Modified so that no backsubstitution is performed if DSYEVD fails to
* converge (NEIG in old code could be greater than N causing out of
* bounds reference to A - reported by Ralf Meyer). Also corrected the
* description of INFO and the test on ITYPE. Sven, 16 Feb 05.
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, UPPER, WANTZ
CHARACTER TRANS
INTEGER LIOPT, LIWMIN, LOPT, LWMIN
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DPOTRF, DSYEVD, DSYGST, DTRMM, DTRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
UPPER = LSAME( UPLO, 'U' )
LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
INFO = 0
IF( N.LE.1 ) THEN
LIWMIN = 1
LWMIN = 1
ELSE IF( WANTZ ) THEN
LIWMIN = 3 + 5*N
LWMIN = 1 + 6*N + 2*N**2
ELSE
LIWMIN = 1
LWMIN = 2*N + 1
END IF
LOPT = LWMIN
LIOPT = LIWMIN
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
INFO = -1
ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -2
ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
*
IF( INFO.EQ.0 ) THEN
WORK( 1 ) = LOPT
IWORK( 1 ) = LIOPT
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -11
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYGVD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Form a Cholesky factorization of B.
*
CALL DPOTRF( UPLO, N, B, LDB, INFO )
IF( INFO.NE.0 ) THEN
INFO = N + INFO
RETURN
END IF
*
* Transform problem to standard eigenvalue problem and solve.
*
CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
CALL DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, LIWORK,
$ INFO )
LOPT = MAX( DBLE( LOPT ), DBLE( WORK( 1 ) ) )
LIOPT = MAX( DBLE( LIOPT ), DBLE( IWORK( 1 ) ) )
*
IF( WANTZ .AND. INFO.EQ.0 ) THEN
*
* Backtransform eigenvectors to the original problem.
*
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
*
* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
*
IF( UPPER ) THEN
TRANS = 'N'
ELSE
TRANS = 'T'
END IF
*
CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, N, ONE,
$ B, LDB, A, LDA )
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* For B*A*x=(lambda)*x;
* backtransform eigenvectors: x = L*y or U'*y
*
IF( UPPER ) THEN
TRANS = 'T'
ELSE
TRANS = 'N'
END IF
*
CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, N, ONE,
$ B, LDB, A, LDA )
END IF
END IF
*
WORK( 1 ) = LOPT
IWORK( 1 ) = LIOPT
*
RETURN
*
* End of DSYGVD
*
END
SUBROUTINE DSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB,
$ VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK,
$ LWORK, IWORK, IFAIL, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE, UPLO
INTEGER IL, INFO, ITYPE, IU, LDA, LDB, LDZ, LWORK, M, N
DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER IFAIL( * ), IWORK( * )
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ),
$ Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DSYGVX computes selected eigenvalues, and optionally, eigenvectors
* of a real generalized symmetric-definite eigenproblem, of the form
* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A
* and B are assumed to be symmetric and B is also positive definite.
* Eigenvalues and eigenvectors can be selected by specifying either a
* range of values or a range of indices for the desired eigenvalues.
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* Specifies the problem type to be solved:
* = 1: A*x = (lambda)*B*x
* = 2: A*B*x = (lambda)*x
* = 3: B*A*x = (lambda)*x
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* RANGE (input) CHARACTER*1
* = 'A': all eigenvalues will be found.
* = 'V': all eigenvalues in the half-open interval (VL,VU]
* will be found.
* = 'I': the IL-th through IU-th eigenvalues will be found.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A and B are stored;
* = 'L': Lower triangle of A and B are stored.
*
* N (input) INTEGER
* The order of the matrix pencil (A,B). N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
* On entry, the symmetric matrix A. If UPLO = 'U', the
* leading N-by-N upper triangular part of A contains the
* upper triangular part of the matrix A. If UPLO = 'L',
* the leading N-by-N lower triangular part of A contains
* the lower triangular part of the matrix A.
*
* On exit, the lower triangle (if UPLO='L') or the upper
* triangle (if UPLO='U') of A, including the diagonal, is
* destroyed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDA, N)
* On entry, the symmetric matrix B. If UPLO = 'U', the
* leading N-by-N upper triangular part of B contains the
* upper triangular part of the matrix B. If UPLO = 'L',
* the leading N-by-N lower triangular part of B contains
* the lower triangular part of the matrix B.
*
* On exit, if INFO <= N, the part of B containing the matrix is
* overwritten by the triangular factor U or L from the Cholesky
* factorization B = U**T*U or B = L*L**T.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* VL (input) DOUBLE PRECISION
* VU (input) DOUBLE PRECISION
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* ABSTOL (input) DOUBLE PRECISION
* The absolute error tolerance for the eigenvalues.
* An approximate eigenvalue is accepted as converged
* when it is determined to lie in an interval [a,b]
* of width less than or equal to
*
* ABSTOL + EPS * max( |a|,|b| ) ,
*
* where EPS is the machine precision. If ABSTOL is less than
* or equal to zero, then EPS*|T| will be used in its place,
* where |T| is the 1-norm of the tridiagonal matrix obtained
* by reducing A to tridiagonal form.
*
* Eigenvalues will be computed most accurately when ABSTOL is
* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
* If this routine returns with INFO>0, indicating that some
* eigenvectors did not converge, try setting ABSTOL to
* 2*DLAMCH('S').
*
* M (output) INTEGER
* The total number of eigenvalues found. 0 <= M <= N.
* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*
* W (output) DOUBLE PRECISION array, dimension (N)
* On normal exit, the first M elements contain the selected
* eigenvalues in ascending order.
*
* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
* If JOBZ = 'N', then Z is not referenced.
* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
* contain the orthonormal eigenvectors of the matrix A
* corresponding to the selected eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* The eigenvectors are normalized as follows:
* if ITYPE = 1 or 2, Z**T*B*Z = I;
* if ITYPE = 3, Z**T*inv(B)*Z = I.
*
* If an eigenvector fails to converge, then that column of Z
* contains the latest approximation to the eigenvector, and the
* index of the eigenvector is returned in IFAIL.
* Note: the user must ensure that at least max(1,M) columns are
* supplied in the array Z; if RANGE = 'V', the exact value of M
* is not known in advance and an upper bound must be used.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* 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 length of the array WORK. LWORK >= max(1,8*N).
* For optimal efficiency, LWORK >= (NB+3)*N,
* where NB is the blocksize for DSYTRD returned by ILAENV.
*
* 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.
*
* IWORK (workspace) INTEGER array, dimension (5*N)
*
* IFAIL (output) INTEGER array, dimension (N)
* If JOBZ = 'V', then if INFO = 0, the first M elements of
* IFAIL are zero. If INFO > 0, then IFAIL contains the
* indices of the eigenvectors that failed to converge.
* If JOBZ = 'N', then IFAIL is not referenced.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: DPOTRF or DSYEVX returned an error code:
* <= N: if INFO = i, DSYEVX failed to converge;
* i eigenvectors failed to converge. Their indices
* are stored in array IFAIL.
* > N: if INFO = N + i, for 1 <= i <= N, then the leading
* minor of order i of B is not positive definite.
* The factorization of B could not be completed and
* no eigenvalues or eigenvectors were computed.
*
* Further Details
* ===============
*
* Based on contributions by
* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, LQUERY, UPPER, VALEIG, WANTZ
CHARACTER TRANS
INTEGER LWKMIN, LWKOPT, NB
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DPOTRF, DSYEVX, DSYGST, DTRMM, DTRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
UPPER = LSAME( UPLO, 'U' )
WANTZ = LSAME( JOBZ, 'V' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
LQUERY = ( LWORK.EQ.-1 )
*
INFO = 0
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
INFO = -1
ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -2
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
INFO = -3
ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE
IF( VALEIG ) THEN
IF( N.GT.0 .AND. VU.LE.VL )
$ INFO = -11
ELSE IF( INDEIG ) THEN
IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
INFO = -12
ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
INFO = -13
END IF
END IF
END IF
IF (INFO.EQ.0) THEN
IF (LDZ.LT.1 .OR. (WANTZ .AND. LDZ.LT.N)) THEN
INFO = -18
END IF
END IF
*
IF( INFO.EQ.0 ) THEN
LWKMIN = MAX( 1, 8*N )
NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
LWKOPT = MAX( LWKMIN, ( NB + 3 )*N )
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
INFO = -20
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYGVX', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 ) THEN
RETURN
END IF
*
* Form a Cholesky factorization of B.
*
CALL DPOTRF( UPLO, N, B, LDB, INFO )
IF( INFO.NE.0 ) THEN
INFO = N + INFO
RETURN
END IF
*
* Transform problem to standard eigenvalue problem and solve.
*
CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
CALL DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL,
$ M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO )
*
IF( WANTZ ) THEN
*
* Backtransform eigenvectors to the original problem.
*
IF( INFO.GT.0 )
$ M = INFO - 1
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
*
* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
*
IF( UPPER ) THEN
TRANS = 'N'
ELSE
TRANS = 'T'
END IF
*
CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, M, ONE, B,
$ LDB, Z, LDZ )
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* For B*A*x=(lambda)*x;
* backtransform eigenvectors: x = L*y or U'*y
*
IF( UPPER ) THEN
TRANS = 'T'
ELSE
TRANS = 'N'
END IF
*
CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, M, ONE, B,
$ LDB, Z, LDZ )
END IF
END IF
*
* Set WORK(1) to optimal workspace size.
*
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of DSYGVX
*
END
SUBROUTINE DSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB,
$ X, LDX, FERR, BERR, WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), IWORK( * )
DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
$ BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* DSYRFS improves the computed solution to a system of linear
* equations when the coefficient matrix is symmetric indefinite, and
* provides error bounds and backward error estimates for the solution.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* 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 matrices B and X. NRHS >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
* upper triangular part of A contains the upper triangular part
* of the matrix A, and the strictly lower triangular part of A
* is not referenced. If UPLO = 'L', the leading N-by-N lower
* triangular part of A contains the lower triangular part of
* the matrix A, and the strictly upper triangular part of A is
* not referenced.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)
* The factored form of the matrix A. AF contains the block
* diagonal matrix D and the multipliers used to obtain the
* factor U or L from the factorization A = U*D*U**T or
* A = L*D*L**T as computed by DSYTRF.
*
* LDAF (input) INTEGER
* The leading dimension of the array AF. LDAF >= max(1,N).
*
* IPIV (input) INTEGER array, dimension (N)
* Details of the interchanges and the block structure of D
* as determined by DSYTRF.
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
* On entry, the solution matrix X, as computed by DSYTRS.
* On exit, the improved solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Internal Parameters
* ===================
*
* ITMAX is the maximum number of steps of iterative refinement.
*
* =====================================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 5 )
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D+0 )
DOUBLE PRECISION THREE
PARAMETER ( THREE = 3.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER COUNT, I, J, K, KASE, NZ
DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DLACN2, DSYMV, DSYTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) 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( LDAF.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -10
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYRFS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
DO 10 J = 1, NRHS
FERR( J ) = ZERO
BERR( J ) = ZERO
10 CONTINUE
RETURN
END IF
*
* NZ = maximum number of nonzero elements in each row of A, plus 1
*
NZ = N + 1
EPS = DLAMCH( 'Epsilon' )
SAFMIN = DLAMCH( 'Safe minimum' )
SAFE1 = NZ*SAFMIN
SAFE2 = SAFE1 / EPS
*
* Do for each right hand side
*
DO 140 J = 1, NRHS
*
COUNT = 1
LSTRES = THREE
20 CONTINUE
*
* Loop until stopping criterion is satisfied.
*
* Compute residual R = B - A * X
*
CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
CALL DSYMV( UPLO, N, -ONE, A, LDA, X( 1, J ), 1, ONE,
$ WORK( N+1 ), 1 )
*
* Compute componentwise relative backward error from formula
*
* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
*
* where abs(Z) is the componentwise absolute value of the matrix
* or vector Z. If the i-th component of the denominator is less
* than SAFE2, then SAFE1 is added to the i-th components of the
* numerator and denominator before dividing.
*
DO 30 I = 1, N
WORK( I ) = ABS( B( I, J ) )
30 CONTINUE
*
* Compute abs(A)*abs(X) + abs(B).
*
IF( UPPER ) THEN
DO 50 K = 1, N
S = ZERO
XK = ABS( X( K, J ) )
DO 40 I = 1, K - 1
WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
40 CONTINUE
WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK + S
50 CONTINUE
ELSE
DO 70 K = 1, N
S = ZERO
XK = ABS( X( K, J ) )
WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK
DO 60 I = K + 1, N
WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
60 CONTINUE
WORK( K ) = WORK( K ) + S
70 CONTINUE
END IF
S = ZERO
DO 80 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
ELSE
S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
$ ( WORK( I )+SAFE1 ) )
END IF
80 CONTINUE
BERR( J ) = S
*
* Test stopping criterion. Continue iterating if
* 1) The residual BERR(J) is larger than machine epsilon, and
* 2) BERR(J) decreased by at least a factor of 2 during the
* last iteration, and
* 3) At most ITMAX iterations tried.
*
IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
$ COUNT.LE.ITMAX ) THEN
*
* Update solution and try again.
*
CALL DSYTRS( UPLO, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
$ INFO )
CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
LSTRES = BERR( J )
COUNT = COUNT + 1
GO TO 20
END IF
*
* Bound error from formula
*
* norm(X - XTRUE) / norm(X) .le. FERR =
* norm( abs(inv(A))*
* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
*
* where
* norm(Z) is the magnitude of the largest component of Z
* inv(A) is the inverse of A
* abs(Z) is the componentwise absolute value of the matrix or
* vector Z
* NZ is the maximum number of nonzeros in any row of A, plus 1
* EPS is machine epsilon
*
* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
* is incremented by SAFE1 if the i-th component of
* abs(A)*abs(X) + abs(B) is less than SAFE2.
*
* Use DLACN2 to estimate the infinity-norm of the matrix
* inv(A) * diag(W),
* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
*
DO 90 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
ELSE
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
END IF
90 CONTINUE
*
KASE = 0
100 CONTINUE
CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
$ KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Multiply by diag(W)*inv(A').
*
CALL DSYTRS( UPLO, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
$ INFO )
DO 110 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
110 CONTINUE
ELSE IF( KASE.EQ.2 ) THEN
*
* Multiply by inv(A)*diag(W).
*
DO 120 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
120 CONTINUE
CALL DSYTRS( UPLO, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
$ INFO )
END IF
GO TO 100
END IF
*
* Normalize error.
*
LSTRES = ZERO
DO 130 I = 1, N
LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
130 CONTINUE
IF( LSTRES.NE.ZERO )
$ FERR( J ) = FERR( J ) / LSTRES
*
140 CONTINUE
*
RETURN
*
* End of DSYRFS
*
END
SUBROUTINE DSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK,
$ LWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LDB, LWORK, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DSYSV computes the solution to a real system of linear equations
* A * X = B,
* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
* matrices.
*
* The diagonal pivoting method is used to factor A as
* A = U * D * U**T, if UPLO = 'U', or
* A = L * D * L**T, if UPLO = 'L',
* where U (or L) is a product of permutation and unit upper (lower)
* triangular matrices, and D is symmetric and block diagonal with
* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then
* used to solve the system of equations A * X = B.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The number of linear equations, i.e., 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/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the symmetric matrix A. If UPLO = 'U', the leading
* N-by-N upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading N-by-N lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced.
*
* On exit, if INFO = 0, the block diagonal matrix D and the
* multipliers used to obtain the factor U or L from the
* factorization A = U*D*U**T or A = L*D*L**T as computed by
* DSYTRF.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* IPIV (output) INTEGER array, dimension (N)
* Details of the interchanges and the block structure of D, as
* determined by DSYTRF. If IPIV(k) > 0, then rows and columns
* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1
* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,
* then rows and columns k-1 and -IPIV(k) were interchanged and
* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and
* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and
* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2
* diagonal block.
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the N-by-NRHS right hand side matrix B.
* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* 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 length of WORK. LWORK >= 1, and for best performance
* LWORK >= max(1,N*NB), where NB is the optimal blocksize for
* DSYTRF.
*
* 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
* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
* has been completed, but the block diagonal matrix D is
* exactly singular, so the solution could not be computed.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER LWKOPT, NB
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DSYTRF, DSYTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) 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
ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
INFO = -10
END IF
*
IF( INFO.EQ.0 ) THEN
IF( N.EQ.0 ) THEN
LWKOPT = 1
ELSE
NB = ILAENV( 1, 'DSYTRF', UPLO, N, -1, -1, -1 )
LWKOPT = N*NB
END IF
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYSV ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Compute the factorization A = U*D*U' or A = L*D*L'.
*
CALL DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
IF( INFO.EQ.0 ) THEN
*
* Solve the system A*X = B, overwriting B with X.
*
CALL DSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
END IF
*
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of DSYSV
*
END
SUBROUTINE DSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B,
$ LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK,
$ IWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER FACT, UPLO
INTEGER INFO, LDA, LDAF, LDB, LDX, LWORK, N, NRHS
DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), IWORK( * )
DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
$ BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* DSYSVX uses the diagonal pivoting factorization to compute the
* solution to a real system of linear equations A * X = B,
* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
* matrices.
*
* Error bounds on the solution and a condition estimate are also
* provided.
*
* Description
* ===========
*
* The following steps are performed:
*
* 1. If FACT = 'N', the diagonal pivoting method is used to factor A.
* The form of the factorization is
* A = U * D * U**T, if UPLO = 'U', or
* A = L * D * L**T, if UPLO = 'L',
* where U (or L) is a product of permutation and unit upper (lower)
* triangular matrices, and D is symmetric and block diagonal with
* 1-by-1 and 2-by-2 diagonal blocks.
*
* 2. If some D(i,i)=0, so that D is exactly singular, then the routine
* returns with INFO = i. Otherwise, the factored form of A is used
* to estimate the condition number of the matrix A. If the
* reciprocal of the condition number is less than machine precision,
* INFO = N+1 is returned as a warning, but the routine still goes on
* to solve for X and compute error bounds as described below.
*
* 3. The system of equations is solved for X using the factored form
* of A.
*
* 4. Iterative refinement is applied to improve the computed solution
* matrix and calculate error bounds and backward error estimates
* for it.
*
* Arguments
* =========
*
* FACT (input) CHARACTER*1
* Specifies whether or not the factored form of A has been
* supplied on entry.
* = 'F': On entry, AF and IPIV contain the factored form of
* A. AF and IPIV will not be modified.
* = 'N': The matrix A will be copied to AF and factored.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The number of linear equations, i.e., 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 matrices B and X. NRHS >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
* upper triangular part of A contains the upper triangular part
* of the matrix A, and the strictly lower triangular part of A
* is not referenced. If UPLO = 'L', the leading N-by-N lower
* triangular part of A contains the lower triangular part of
* the matrix A, and the strictly upper triangular part of A is
* not referenced.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N)
* If FACT = 'F', then AF is an input argument and on entry
* contains the block diagonal matrix D and the multipliers used
* to obtain the factor U or L from the factorization
* A = U*D*U**T or A = L*D*L**T as computed by DSYTRF.
*
* If FACT = 'N', then AF is an output argument and on exit
* returns the block diagonal matrix D and the multipliers used
* to obtain the factor U or L from the factorization
* A = U*D*U**T or A = L*D*L**T.
*
* LDAF (input) INTEGER
* The leading dimension of the array AF. LDAF >= max(1,N).
*
* IPIV (input or output) INTEGER array, dimension (N)
* If FACT = 'F', then IPIV is an input argument and on entry
* contains details of the interchanges and the block structure
* of D, as determined by DSYTRF.
* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
* interchanged and D(k,k) is a 1-by-1 diagonal block.
* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*
* If FACT = 'N', then IPIV is an output argument and on exit
* contains details of the interchanges and the block structure
* of D, as determined by DSYTRF.
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The N-by-NRHS right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* RCOND (output) DOUBLE PRECISION
* The estimate of the reciprocal condition number of the matrix
* A. If RCOND is less than the machine precision (in
* particular, if RCOND = 0), the matrix is singular to working
* precision. This condition is indicated by a return code of
* INFO > 0.
*
* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* 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 length of WORK. LWORK >= max(1,3*N), and for best
* performance, when FACT = 'N', LWORK >= max(1,3*N,N*NB), where
* NB is the optimal blocksize for DSYTRF.
*
* 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.
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, and i is
* <= N: D(i,i) is exactly zero. The factorization
* has been completed but the factor D is exactly
* singular, so the solution and error bounds could
* not be computed. RCOND = 0 is returned.
* = N+1: D is nonsingular, but RCOND is less than machine
* precision, meaning that the matrix is singular
* to working precision. Nevertheless, the
* solution and error bounds are computed because
* there are a number of situations where the
* computed solution can be more accurate than the
* value of RCOND would suggest.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, NOFACT
INTEGER LWKOPT, NB
DOUBLE PRECISION ANORM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANSY
EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DLACPY, DSYCON, DSYRFS, DSYTRF, DSYTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
NOFACT = LSAME( FACT, 'N' )
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
INFO = -1
ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
$ THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -11
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -13
ELSE IF( LWORK.LT.MAX( 1, 3*N ) .AND. .NOT.LQUERY ) THEN
INFO = -18
END IF
*
IF( INFO.EQ.0 ) THEN
LWKOPT = MAX( 1, 3*N )
IF( NOFACT ) THEN
NB = ILAENV( 1, 'DSYTRF', UPLO, N, -1, -1, -1 )
LWKOPT = MAX( LWKOPT, N*NB )
END IF
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYSVX', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
IF( NOFACT ) THEN
*
* Compute the factorization A = U*D*U' or A = L*D*L'.
*
CALL DLACPY( UPLO, N, N, A, LDA, AF, LDAF )
CALL DSYTRF( UPLO, N, AF, LDAF, IPIV, WORK, LWORK, INFO )
*
* Return if INFO is non-zero.
*
IF( INFO.GT.0 )THEN
RCOND = ZERO
RETURN
END IF
END IF
*
* Compute the norm of the matrix A.
*
ANORM = DLANSY( 'I', UPLO, N, A, LDA, WORK )
*
* Compute the reciprocal of the condition number of A.
*
CALL DSYCON( UPLO, N, AF, LDAF, IPIV, ANORM, RCOND, WORK, IWORK,
$ INFO )
*
* Compute the solution vectors X.
*
CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
CALL DSYTRS( UPLO, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO )
*
* Use iterative refinement to improve the computed solutions and
* compute error bounds and backward error estimates for them.
*
CALL DSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X,
$ LDX, FERR, BERR, WORK, IWORK, INFO )
*
* Set INFO = N+1 if the matrix is singular to working precision.
*
IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
$ INFO = N + 1
*
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of DSYSVX
*
END
SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * )
* ..
*
* Purpose
* =======
*
* DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal
* form T by an orthogonal similarity transformation: Q' * A * Q = T.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the symmetric matrix A. If UPLO = 'U', the leading
* n-by-n upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading n-by-n lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced.
* On exit, if UPLO = 'U', the diagonal and first superdiagonal
* of A are overwritten by the corresponding elements of the
* tridiagonal matrix T, and the elements above the first
* superdiagonal, with the array TAU, represent the orthogonal
* matrix Q as a product of elementary reflectors; if UPLO
* = 'L', the diagonal and first subdiagonal of A are over-
* written by the corresponding elements of the tridiagonal
* matrix T, and the elements below the first subdiagonal, 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,N).
*
* D (output) DOUBLE PRECISION array, dimension (N)
* The diagonal elements of the tridiagonal matrix T:
* D(i) = A(i,i).
*
* E (output) DOUBLE PRECISION array, dimension (N-1)
* The off-diagonal elements of the tridiagonal matrix T:
* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
*
* TAU (output) DOUBLE PRECISION array, dimension (N-1)
* The scalar factors of the elementary reflectors (see Further
* Details).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* If UPLO = 'U', the matrix Q is represented as a product of elementary
* reflectors
*
* Q = H(n-1) . . . H(2) H(1).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a real scalar, and v is a real vector with
* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
* A(1:i-1,i+1), and tau in TAU(i).
*
* If UPLO = 'L', the matrix Q is represented as a product of elementary
* reflectors
*
* Q = H(1) H(2) . . . H(n-1).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a real scalar, and v is a real vector with
* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
* and tau in TAU(i).
*
* The contents of A on exit are illustrated by the following examples
* with n = 5:
*
* if UPLO = 'U': if UPLO = 'L':
*
* ( d e v2 v3 v4 ) ( d )
* ( d e v3 v4 ) ( e d )
* ( d e v4 ) ( v1 e d )
* ( d e ) ( v1 v2 e d )
* ( d ) ( v1 v2 v3 e d )
*
* where d and e denote diagonal and off-diagonal elements of T, and vi
* denotes an element of the vector defining H(i).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO, HALF
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0,
$ HALF = 1.0D0 / 2.0D0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I
DOUBLE PRECISION ALPHA, TAUI
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DLARFG, DSYMV, DSYR2, XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DDOT
EXTERNAL LSAME, DDOT
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYTD2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Reduce the upper triangle of A
*
DO 10 I = N - 1, 1, -1
*
* Generate elementary reflector H(i) = I - tau * v * v'
* to annihilate A(1:i-1,i+1)
*
CALL DLARFG( I, A( I, I+1 ), A( 1, I+1 ), 1, TAUI )
E( I ) = A( I, I+1 )
*
IF( TAUI.NE.ZERO ) THEN
*
* Apply H(i) from both sides to A(1:i,1:i)
*
A( I, I+1 ) = ONE
*
* Compute x := tau * A * v storing x in TAU(1:i)
*
CALL DSYMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO,
$ TAU, 1 )
*
* Compute w := x - 1/2 * tau * (x'*v) * v
*
ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, A( 1, I+1 ), 1 )
CALL DAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 )
*
* Apply the transformation as a rank-2 update:
* A := A - v * w' - w * v'
*
CALL DSYR2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A,
$ LDA )
*
A( I, I+1 ) = E( I )
END IF
D( I+1 ) = A( I+1, I+1 )
TAU( I ) = TAUI
10 CONTINUE
D( 1 ) = A( 1, 1 )
ELSE
*
* Reduce the lower triangle of A
*
DO 20 I = 1, N - 1
*
* Generate elementary reflector H(i) = I - tau * v * v'
* to annihilate A(i+2:n,i)
*
CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1,
$ TAUI )
E( I ) = A( I+1, I )
*
IF( TAUI.NE.ZERO ) THEN
*
* Apply H(i) from both sides to A(i+1:n,i+1:n)
*
A( I+1, I ) = ONE
*
* Compute x := tau * A * v storing y in TAU(i:n-1)
*
CALL DSYMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA,
$ A( I+1, I ), 1, ZERO, TAU( I ), 1 )
*
* Compute w := x - 1/2 * tau * (x'*v) * v
*
ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I ), 1, A( I+1, I ),
$ 1 )
CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 )
*
* Apply the transformation as a rank-2 update:
* A := A - v * w' - w * v'
*
CALL DSYR2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1,
$ A( I+1, I+1 ), LDA )
*
A( I+1, I ) = E( I )
END IF
D( I ) = A( I, I )
TAU( I ) = TAUI
20 CONTINUE
D( N ) = A( N, N )
END IF
*
RETURN
*
* End of DSYTD2
*
END
SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * )
* ..
*
* Purpose
* =======
*
* DSYTF2 computes the factorization of a real symmetric matrix A using
* the Bunch-Kaufman diagonal pivoting method:
*
* A = U*D*U' or A = L*D*L'
*
* where U (or L) is a product of permutation and unit upper (lower)
* triangular matrices, U' is the transpose of U, and D is symmetric and
* block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
*
* This is the unblocked version of the algorithm, calling Level 2 BLAS.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the symmetric matrix A. If UPLO = 'U', the leading
* n-by-n upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading n-by-n lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced.
*
* On exit, the block diagonal matrix D and the multipliers used
* to obtain the factor U or L (see below for further details).
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* IPIV (output) INTEGER array, dimension (N)
* Details of the interchanges and the block structure of D.
* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
* interchanged and D(k,k) is a 1-by-1 diagonal block.
* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
* > 0: if INFO = k, D(k,k) is exactly zero. The factorization
* has been completed, but the block diagonal matrix D is
* exactly singular, and division by zero will occur if it
* is used to solve a system of equations.
*
* Further Details
* ===============
*
* 09-29-06 - patch from
* Bobby Cheng, MathWorks
*
* Replace l.204 and l.372
* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
* by
* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN
*
* 01-01-96 - Based on modifications by
* J. Lewis, Boeing Computer Services Company
* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
* 1-96 - Based on modifications by J. Lewis, Boeing Computer Services
* Company
*
* If UPLO = 'U', then A = U*D*U', where
* U = P(n)*U(n)* ... *P(k)U(k)* ...,
* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
* that if the diagonal block D(k) is of order s (s = 1 or 2), then
*
* ( I v 0 ) k-s
* U(k) = ( 0 I 0 ) s
* ( 0 0 I ) n-k
* k-s s n-k
*
* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
* and A(k,k), and v overwrites A(1:k-2,k-1:k).
*
* If UPLO = 'L', then A = L*D*L', where
* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
* that if the diagonal block D(k) is of order s (s = 1 or 2), then
*
* ( I 0 0 ) k-1
* L(k) = ( 0 I 0 ) s
* ( 0 v I ) n-k-s+1
* k-1 s n-k-s+1
*
* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION EIGHT, SEVTEN
PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, IMAX, J, JMAX, K, KK, KP, KSTEP
DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, R1,
$ ROWMAX, T, WK, WKM1, WKP1
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
INTEGER IDAMAX
EXTERNAL LSAME, IDAMAX, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, DSWAP, DSYR, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYTF2', -INFO )
RETURN
END IF
*
* Initialize ALPHA for use in choosing pivot block size.
*
ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
*
IF( UPPER ) THEN
*
* Factorize A as U*D*U' using the upper triangle of A
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2
*
K = N
10 CONTINUE
*
* If K < 1, exit from loop
*
IF( K.LT.1 )
$ GO TO 70
KSTEP = 1
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = ABS( A( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value
*
IF( K.GT.1 ) THEN
IMAX = IDAMAX( K-1, A( 1, K ), 1 )
COLMAX = ABS( A( IMAX, K ) )
ELSE
COLMAX = ZERO
END IF
*
IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN
*
* Column K is zero or contains a NaN: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
ELSE
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value
*
JMAX = IMAX + IDAMAX( K-IMAX, A( IMAX, IMAX+1 ), LDA )
ROWMAX = ABS( A( IMAX, JMAX ) )
IF( IMAX.GT.1 ) THEN
JMAX = IDAMAX( IMAX-1, A( 1, IMAX ), 1 )
ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) )
END IF
*
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN
*
* interchange rows and columns K and IMAX, use 1-by-1
* pivot block
*
KP = IMAX
ELSE
*
* interchange rows and columns K-1 and IMAX, use 2-by-2
* pivot block
*
KP = IMAX
KSTEP = 2
END IF
END IF
*
KK = K - KSTEP + 1
IF( KP.NE.KK ) THEN
*
* Interchange rows and columns KK and KP in the leading
* submatrix A(1:k,1:k)
*
CALL DSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
CALL DSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ),
$ LDA )
T = A( KK, KK )
A( KK, KK ) = A( KP, KP )
A( KP, KP ) = T
IF( KSTEP.EQ.2 ) THEN
T = A( K-1, K )
A( K-1, K ) = A( KP, K )
A( KP, K ) = T
END IF
END IF
*
* Update the leading submatrix
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column k now holds
*
* W(k) = U(k)*D(k)
*
* where U(k) is the k-th column of U
*
* Perform a rank-1 update of A(1:k-1,1:k-1) as
*
* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)'
*
R1 = ONE / A( K, K )
CALL DSYR( UPLO, K-1, -R1, A( 1, K ), 1, A, LDA )
*
* Store U(k) in column k
*
CALL DSCAL( K-1, R1, A( 1, K ), 1 )
ELSE
*
* 2-by-2 pivot block D(k): columns k and k-1 now hold
*
* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
*
* where U(k) and U(k-1) are the k-th and (k-1)-th columns
* of U
*
* Perform a rank-2 update of A(1:k-2,1:k-2) as
*
* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )'
* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )'
*
IF( K.GT.2 ) THEN
*
D12 = A( K-1, K )
D22 = A( K-1, K-1 ) / D12
D11 = A( K, K ) / D12
T = ONE / ( D11*D22-ONE )
D12 = T / D12
*
DO 30 J = K - 2, 1, -1
WKM1 = D12*( D11*A( J, K-1 )-A( J, K ) )
WK = D12*( D22*A( J, K )-A( J, K-1 ) )
DO 20 I = J, 1, -1
A( I, J ) = A( I, J ) - A( I, K )*WK -
$ A( I, K-1 )*WKM1
20 CONTINUE
A( J, K ) = WK
A( J, K-1 ) = WKM1
30 CONTINUE
*
END IF
*
END IF
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -KP
IPIV( K-1 ) = -KP
END IF
*
* Decrease K and return to the start of the main loop
*
K = K - KSTEP
GO TO 10
*
ELSE
*
* Factorize A as L*D*L' using the lower triangle of A
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2
*
K = 1
40 CONTINUE
*
* If K > N, exit from loop
*
IF( K.GT.N )
$ GO TO 70
KSTEP = 1
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = ABS( A( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value
*
IF( K.LT.N ) THEN
IMAX = K + IDAMAX( N-K, A( K+1, K ), 1 )
COLMAX = ABS( A( IMAX, K ) )
ELSE
COLMAX = ZERO
END IF
*
IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN
*
* Column K is zero or contains a NaN: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
ELSE
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value
*
JMAX = K - 1 + IDAMAX( IMAX-K, A( IMAX, K ), LDA )
ROWMAX = ABS( A( IMAX, JMAX ) )
IF( IMAX.LT.N ) THEN
JMAX = IMAX + IDAMAX( N-IMAX, A( IMAX+1, IMAX ), 1 )
ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) )
END IF
*
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN
*
* interchange rows and columns K and IMAX, use 1-by-1
* pivot block
*
KP = IMAX
ELSE
*
* interchange rows and columns K+1 and IMAX, use 2-by-2
* pivot block
*
KP = IMAX
KSTEP = 2
END IF
END IF
*
KK = K + KSTEP - 1
IF( KP.NE.KK ) THEN
*
* Interchange rows and columns KK and KP in the trailing
* submatrix A(k:n,k:n)
*
IF( KP.LT.N )
$ CALL DSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
CALL DSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
$ LDA )
T = A( KK, KK )
A( KK, KK ) = A( KP, KP )
A( KP, KP ) = T
IF( KSTEP.EQ.2 ) THEN
T = A( K+1, K )
A( K+1, K ) = A( KP, K )
A( KP, K ) = T
END IF
END IF
*
* Update the trailing submatrix
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column k now holds
*
* W(k) = L(k)*D(k)
*
* where L(k) is the k-th column of L
*
IF( K.LT.N ) THEN
*
* Perform a rank-1 update of A(k+1:n,k+1:n) as
*
* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)'
*
D11 = ONE / A( K, K )
CALL DSYR( UPLO, N-K, -D11, A( K+1, K ), 1,
$ A( K+1, K+1 ), LDA )
*
* Store L(k) in column K
*
CALL DSCAL( N-K, D11, A( K+1, K ), 1 )
END IF
ELSE
*
* 2-by-2 pivot block D(k)
*
IF( K.LT.N-1 ) THEN
*
* Perform a rank-2 update of A(k+2:n,k+2:n) as
*
* A := A - ( (A(k) A(k+1))*D(k)**(-1) ) * (A(k) A(k+1))'
*
* where L(k) and L(k+1) are the k-th and (k+1)-th
* columns of L
*
D21 = A( K+1, K )
D11 = A( K+1, K+1 ) / D21
D22 = A( K, K ) / D21
T = ONE / ( D11*D22-ONE )
D21 = T / D21
*
DO 60 J = K + 2, N
*
WK = D21*( D11*A( J, K )-A( J, K+1 ) )
WKP1 = D21*( D22*A( J, K+1 )-A( J, K ) )
*
DO 50 I = J, N
A( I, J ) = A( I, J ) - A( I, K )*WK -
$ A( I, K+1 )*WKP1
50 CONTINUE
*
A( J, K ) = WK
A( J, K+1 ) = WKP1
*
60 CONTINUE
END IF
END IF
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -KP
IPIV( K+1 ) = -KP
END IF
*
* Increase K and return to the start of the main loop
*
K = K + KSTEP
GO TO 40
*
END IF
*
70 CONTINUE
*
RETURN
*
* End of DSYTF2
*
END
SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* DSYTRD reduces a real symmetric matrix A to real symmetric
* tridiagonal form T by an orthogonal similarity transformation:
* Q**T * A * Q = T.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the symmetric matrix A. If UPLO = 'U', the leading
* N-by-N upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading N-by-N lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced.
* On exit, if UPLO = 'U', the diagonal and first superdiagonal
* of A are overwritten by the corresponding elements of the
* tridiagonal matrix T, and the elements above the first
* superdiagonal, with the array TAU, represent the orthogonal
* matrix Q as a product of elementary reflectors; if UPLO
* = 'L', the diagonal and first subdiagonal of A are over-
* written by the corresponding elements of the tridiagonal
* matrix T, and the elements below the first subdiagonal, 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,N).
*
* D (output) DOUBLE PRECISION array, dimension (N)
* The diagonal elements of the tridiagonal matrix T:
* D(i) = A(i,i).
*
* E (output) DOUBLE PRECISION array, dimension (N-1)
* The off-diagonal elements of the tridiagonal matrix T:
* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
*
* TAU (output) DOUBLE PRECISION array, dimension (N-1)
* 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 >= 1.
* 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
* ===============
*
* If UPLO = 'U', the matrix Q is represented as a product of elementary
* reflectors
*
* Q = H(n-1) . . . H(2) H(1).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a real scalar, and v is a real vector with
* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
* A(1:i-1,i+1), and tau in TAU(i).
*
* If UPLO = 'L', the matrix Q is represented as a product of elementary
* reflectors
*
* Q = H(1) H(2) . . . H(n-1).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a real scalar, and v is a real vector with
* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
* and tau in TAU(i).
*
* The contents of A on exit are illustrated by the following examples
* with n = 5:
*
* if UPLO = 'U': if UPLO = 'L':
*
* ( d e v2 v3 v4 ) ( d )
* ( d e v3 v4 ) ( e d )
* ( d e v4 ) ( v1 e d )
* ( d e ) ( v1 v2 e d )
* ( d ) ( v1 v2 v3 e d )
*
* where d and e denote diagonal and off-diagonal elements of T, and vi
* denotes an element of the vector defining H(i).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, UPPER
INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB,
$ NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL DLATRD, DSYR2K, DSYTD2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
INFO = -9
END IF
*
IF( INFO.EQ.0 ) THEN
*
* Determine the block size.
*
NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
LWKOPT = N*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYTRD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
NX = N
IWS = 1
IF( NB.GT.1 .AND. NB.LT.N ) THEN
*
* Determine when to cross over from blocked to unblocked code
* (last block is always handled by unblocked code).
*
NX = MAX( NB, ILAENV( 3, 'DSYTRD', UPLO, N, -1, -1, -1 ) )
IF( NX.LT.N ) 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: determine the
* minimum value of NB, and reduce NB or force use of
* unblocked code by setting NX = N.
*
NB = MAX( LWORK / LDWORK, 1 )
NBMIN = ILAENV( 2, 'DSYTRD', UPLO, N, -1, -1, -1 )
IF( NB.LT.NBMIN )
$ NX = N
END IF
ELSE
NX = N
END IF
ELSE
NB = 1
END IF
*
IF( UPPER ) THEN
*
* Reduce the upper triangle of A.
* Columns 1:kk are handled by the unblocked method.
*
KK = N - ( ( N-NX+NB-1 ) / NB )*NB
DO 20 I = N - NB + 1, KK + 1, -NB
*
* Reduce columns i:i+nb-1 to tridiagonal form and form the
* matrix W which is needed to update the unreduced part of
* the matrix
*
CALL DLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK,
$ LDWORK )
*
* Update the unreduced submatrix A(1:i-1,1:i-1), using an
* update of the form: A := A - V*W' - W*V'
*
CALL DSYR2K( UPLO, 'No transpose', I-1, NB, -ONE, A( 1, I ),
$ LDA, WORK, LDWORK, ONE, A, LDA )
*
* Copy superdiagonal elements back into A, and diagonal
* elements into D
*
DO 10 J = I, I + NB - 1
A( J-1, J ) = E( J-1 )
D( J ) = A( J, J )
10 CONTINUE
20 CONTINUE
*
* Use unblocked code to reduce the last or only block
*
CALL DSYTD2( UPLO, KK, A, LDA, D, E, TAU, IINFO )
ELSE
*
* Reduce the lower triangle of A
*
DO 40 I = 1, N - NX, NB
*
* Reduce columns i:i+nb-1 to tridiagonal form and form the
* matrix W which is needed to update the unreduced part of
* the matrix
*
CALL DLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ),
$ TAU( I ), WORK, LDWORK )
*
* Update the unreduced submatrix A(i+ib:n,i+ib:n), using
* an update of the form: A := A - V*W' - W*V'
*
CALL DSYR2K( UPLO, 'No transpose', N-I-NB+1, NB, -ONE,
$ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE,
$ A( I+NB, I+NB ), LDA )
*
* Copy subdiagonal elements back into A, and diagonal
* elements into D
*
DO 30 J = I, I + NB - 1
A( J+1, J ) = E( J )
D( J ) = A( J, J )
30 CONTINUE
40 CONTINUE
*
* Use unblocked code to reduce the last or only block
*
CALL DSYTD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ),
$ TAU( I ), IINFO )
END IF
*
WORK( 1 ) = LWKOPT
RETURN
*
* End of DSYTRD
*
END
SUBROUTINE DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DSYTRF computes the factorization of a real symmetric matrix A using
* the Bunch-Kaufman diagonal pivoting method. The form of the
* factorization is
*
* A = U*D*U**T or A = L*D*L**T
*
* where U (or L) is a product of permutation and unit upper (lower)
* triangular matrices, and D is symmetric and block diagonal with
* 1-by-1 and 2-by-2 diagonal blocks.
*
* This is the blocked version of the algorithm, calling Level 3 BLAS.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the symmetric matrix A. If UPLO = 'U', the leading
* N-by-N upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading N-by-N lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced.
*
* On exit, the block diagonal matrix D and the multipliers used
* to obtain the factor U or L (see below for further details).
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* IPIV (output) INTEGER array, dimension (N)
* Details of the interchanges and the block structure of D.
* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
* interchanged and D(k,k) is a 1-by-1 diagonal block.
* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*
* 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 length of WORK. LWORK >=1. For best performance
* LWORK >= N*NB, where NB is the block size returned by ILAENV.
*
* 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
* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
* has been completed, but the block diagonal matrix D is
* exactly singular, and division by zero will occur if it
* is used to solve a system of equations.
*
* Further Details
* ===============
*
* If UPLO = 'U', then A = U*D*U', where
* U = P(n)*U(n)* ... *P(k)U(k)* ...,
* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
* that if the diagonal block D(k) is of order s (s = 1 or 2), then
*
* ( I v 0 ) k-s
* U(k) = ( 0 I 0 ) s
* ( 0 0 I ) n-k
* k-s s n-k
*
* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
* and A(k,k), and v overwrites A(1:k-2,k-1:k).
*
* If UPLO = 'L', then A = L*D*L', where
* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
* that if the diagonal block D(k) is of order s (s = 1 or 2), then
*
* ( I 0 0 ) k-1
* L(k) = ( 0 I 0 ) s
* ( 0 v I ) n-k-s+1
* k-1 s n-k-s+1
*
* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LQUERY, UPPER
INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DLASYF, DSYTF2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
INFO = -7
END IF
*
IF( INFO.EQ.0 ) THEN
*
* Determine the block size
*
NB = ILAENV( 1, 'DSYTRF', UPLO, N, -1, -1, -1 )
LWKOPT = N*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYTRF', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
NBMIN = 2
LDWORK = N
IF( NB.GT.1 .AND. NB.LT.N ) THEN
IWS = LDWORK*NB
IF( LWORK.LT.IWS ) THEN
NB = MAX( LWORK / LDWORK, 1 )
NBMIN = MAX( 2, ILAENV( 2, 'DSYTRF', UPLO, N, -1, -1, -1 ) )
END IF
ELSE
IWS = 1
END IF
IF( NB.LT.NBMIN )
$ NB = N
*
IF( UPPER ) THEN
*
* Factorize A as U*D*U' using the upper triangle of A
*
* K is the main loop index, decreasing from N to 1 in steps of
* KB, where KB is the number of columns factorized by DLASYF;
* KB is either NB or NB-1, or K for the last block
*
K = N
10 CONTINUE
*
* If K < 1, exit from loop
*
IF( K.LT.1 )
$ GO TO 40
*
IF( K.GT.NB ) THEN
*
* Factorize columns k-kb+1:k of A and use blocked code to
* update columns 1:k-kb
*
CALL DLASYF( UPLO, K, NB, KB, A, LDA, IPIV, WORK, LDWORK,
$ IINFO )
ELSE
*
* Use unblocked code to factorize columns 1:k of A
*
CALL DSYTF2( UPLO, K, A, LDA, IPIV, IINFO )
KB = K
END IF
*
* Set INFO on the first occurrence of a zero pivot
*
IF( INFO.EQ.0 .AND. IINFO.GT.0 )
$ INFO = IINFO
*
* Decrease K and return to the start of the main loop
*
K = K - KB
GO TO 10
*
ELSE
*
* Factorize A as L*D*L' using the lower triangle of A
*
* K is the main loop index, increasing from 1 to N in steps of
* KB, where KB is the number of columns factorized by DLASYF;
* KB is either NB or NB-1, or N-K+1 for the last block
*
K = 1
20 CONTINUE
*
* If K > N, exit from loop
*
IF( K.GT.N )
$ GO TO 40
*
IF( K.LE.N-NB ) THEN
*
* Factorize columns k:k+kb-1 of A and use blocked code to
* update columns k+kb:n
*
CALL DLASYF( UPLO, N-K+1, NB, KB, A( K, K ), LDA, IPIV( K ),
$ WORK, LDWORK, IINFO )
ELSE
*
* Use unblocked code to factorize columns k:n of A
*
CALL DSYTF2( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ), IINFO )
KB = N - K + 1
END IF
*
* Set INFO on the first occurrence of a zero pivot
*
IF( INFO.EQ.0 .AND. IINFO.GT.0 )
$ INFO = IINFO + K - 1
*
* Adjust IPIV
*
DO 30 J = K, K + KB - 1
IF( IPIV( J ).GT.0 ) THEN
IPIV( J ) = IPIV( J ) + K - 1
ELSE
IPIV( J ) = IPIV( J ) - K + 1
END IF
30 CONTINUE
*
* Increase K and return to the start of the main loop
*
K = K + KB
GO TO 20
*
END IF
*
40 CONTINUE
WORK( 1 ) = LWKOPT
RETURN
*
* End of DSYTRF
*
END
SUBROUTINE DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DSYTRI computes the inverse of a real symmetric indefinite matrix
* A using the factorization A = U*D*U**T or A = L*D*L**T computed by
* DSYTRF.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the details of the factorization are stored
* as an upper or lower triangular matrix.
* = 'U': Upper triangular, form is A = U*D*U**T;
* = 'L': Lower triangular, form is A = L*D*L**T.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the block diagonal matrix D and the multipliers
* used to obtain the factor U or L as computed by DSYTRF.
*
* On exit, if INFO = 0, the (symmetric) inverse of the original
* matrix. If UPLO = 'U', the upper triangular part of the
* inverse is formed and the part of A below the diagonal is not
* referenced; if UPLO = 'L' the lower triangular part of the
* inverse is formed and the part of A above the diagonal is
* not referenced.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* IPIV (input) INTEGER array, dimension (N)
* Details of the interchanges and the block structure of D
* as determined by DSYTRF.
*
* 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
* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
* inverse could not be computed.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER K, KP, KSTEP
DOUBLE PRECISION AK, AKKP1, AKP1, D, T, TEMP
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DDOT
EXTERNAL LSAME, DDOT
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DSWAP, DSYMV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYTRI', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Check that the diagonal matrix D is nonsingular.
*
IF( UPPER ) THEN
*
* Upper triangular storage: examine D from bottom to top
*
DO 10 INFO = N, 1, -1
IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO )
$ RETURN
10 CONTINUE
ELSE
*
* Lower triangular storage: examine D from top to bottom.
*
DO 20 INFO = 1, N
IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO )
$ RETURN
20 CONTINUE
END IF
INFO = 0
*
IF( UPPER ) THEN
*
* Compute inv(A) from the factorization A = U*D*U'.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
30 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 40
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Invert the diagonal block.
*
A( K, K ) = ONE / A( K, K )
*
* Compute column K of the inverse.
*
IF( K.GT.1 ) THEN
CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 )
CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
$ A( 1, K ), 1 )
A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ),
$ 1 )
END IF
KSTEP = 1
ELSE
*
* 2 x 2 diagonal block
*
* Invert the diagonal block.
*
T = ABS( A( K, K+1 ) )
AK = A( K, K ) / T
AKP1 = A( K+1, K+1 ) / T
AKKP1 = A( K, K+1 ) / T
D = T*( AK*AKP1-ONE )
A( K, K ) = AKP1 / D
A( K+1, K+1 ) = AK / D
A( K, K+1 ) = -AKKP1 / D
*
* Compute columns K and K+1 of the inverse.
*
IF( K.GT.1 ) THEN
CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 )
CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
$ A( 1, K ), 1 )
A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ),
$ 1 )
A( K, K+1 ) = A( K, K+1 ) -
$ DDOT( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 )
CALL DCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 )
CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
$ A( 1, K+1 ), 1 )
A( K+1, K+1 ) = A( K+1, K+1 ) -
$ DDOT( K-1, WORK, 1, A( 1, K+1 ), 1 )
END IF
KSTEP = 2
END IF
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K ) THEN
*
* Interchange rows and columns K and KP in the leading
* submatrix A(1:k+1,1:k+1)
*
CALL DSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
CALL DSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA )
TEMP = A( K, K )
A( K, K ) = A( KP, KP )
A( KP, KP ) = TEMP
IF( KSTEP.EQ.2 ) THEN
TEMP = A( K, K+1 )
A( K, K+1 ) = A( KP, K+1 )
A( KP, K+1 ) = TEMP
END IF
END IF
*
K = K + KSTEP
GO TO 30
40 CONTINUE
*
ELSE
*
* Compute inv(A) from the factorization A = L*D*L'.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = N
50 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 60
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Invert the diagonal block.
*
A( K, K ) = ONE / A( K, K )
*
* Compute column K of the inverse.
*
IF( K.LT.N ) THEN
CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
$ ZERO, A( K+1, K ), 1 )
A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ),
$ 1 )
END IF
KSTEP = 1
ELSE
*
* 2 x 2 diagonal block
*
* Invert the diagonal block.
*
T = ABS( A( K, K-1 ) )
AK = A( K-1, K-1 ) / T
AKP1 = A( K, K ) / T
AKKP1 = A( K, K-1 ) / T
D = T*( AK*AKP1-ONE )
A( K-1, K-1 ) = AKP1 / D
A( K, K ) = AK / D
A( K, K-1 ) = -AKKP1 / D
*
* Compute columns K-1 and K of the inverse.
*
IF( K.LT.N ) THEN
CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
$ ZERO, A( K+1, K ), 1 )
A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ),
$ 1 )
A( K, K-1 ) = A( K, K-1 ) -
$ DDOT( N-K, A( K+1, K ), 1, A( K+1, K-1 ),
$ 1 )
CALL DCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 )
CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
$ ZERO, A( K+1, K-1 ), 1 )
A( K-1, K-1 ) = A( K-1, K-1 ) -
$ DDOT( N-K, WORK, 1, A( K+1, K-1 ), 1 )
END IF
KSTEP = 2
END IF
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K ) THEN
*
* Interchange rows and columns K and KP in the trailing
* submatrix A(k-1:n,k-1:n)
*
IF( KP.LT.N )
$ CALL DSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
CALL DSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA )
TEMP = A( K, K )
A( K, K ) = A( KP, KP )
A( KP, KP ) = TEMP
IF( KSTEP.EQ.2 ) THEN
TEMP = A( K, K-1 )
A( K, K-1 ) = A( KP, K-1 )
A( KP, K-1 ) = TEMP
END IF
END IF
*
K = K - KSTEP
GO TO 50
60 CONTINUE
END IF
*
RETURN
*
* End of DSYTRI
*
END
SUBROUTINE DSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* DSYTRS solves a system of linear equations A*X = B with a real
* symmetric matrix A using the factorization A = U*D*U**T or
* A = L*D*L**T computed by DSYTRF.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the details of the factorization are stored
* as an upper or lower triangular matrix.
* = 'U': Upper triangular, form is A = U*D*U**T;
* = 'L': Lower triangular, form is A = L*D*L**T.
*
* 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 block diagonal matrix D and the multipliers used to
* obtain the factor U or L as computed by DSYTRF.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* IPIV (input) INTEGER array, dimension (N)
* Details of the interchanges and the block structure of D
* as determined by DSYTRF.
*
* 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 UPPER
INTEGER J, K, KP
DOUBLE PRECISION AK, AKM1, AKM1K, BK, BKM1, DENOM
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DGEMV, DGER, DSCAL, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) 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( 'DSYTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Solve A*X = B, where A = U*D*U'.
*
* First solve U*D*X = B, overwriting B with X.
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = N
10 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 30
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(U(K)), where U(K) is the transformation
* stored in column K of A.
*
CALL DGER( K-1, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB,
$ B( 1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
CALL DSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB )
K = K - 1
ELSE
*
* 2 x 2 diagonal block
*
* Interchange rows K-1 and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K-1 )
$ CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(U(K)), where U(K) is the transformation
* stored in columns K-1 and K of A.
*
CALL DGER( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB,
$ B( 1, 1 ), LDB )
CALL DGER( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ),
$ LDB, B( 1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
AKM1K = A( K-1, K )
AKM1 = A( K-1, K-1 ) / AKM1K
AK = A( K, K ) / AKM1K
DENOM = AKM1*AK - ONE
DO 20 J = 1, NRHS
BKM1 = B( K-1, J ) / AKM1K
BK = B( K, J ) / AKM1K
B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
20 CONTINUE
K = K - 2
END IF
*
GO TO 10
30 CONTINUE
*
* Next solve U'*X = B, overwriting B with X.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
40 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 50
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Multiply by inv(U'(K)), where U(K) is the transformation
* stored in column K of A.
*
CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, K ),
$ 1, ONE, B( K, 1 ), LDB )
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
K = K + 1
ELSE
*
* 2 x 2 diagonal block
*
* Multiply by inv(U'(K+1)), where U(K+1) is the transformation
* stored in columns K and K+1 of A.
*
CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, K ),
$ 1, ONE, B( K, 1 ), LDB )
CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB,
$ A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB )
*
* Interchange rows K and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
K = K + 2
END IF
*
GO TO 40
50 CONTINUE
*
ELSE
*
* Solve A*X = B, where A = L*D*L'.
*
* First solve L*D*X = B, overwriting B with X.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
60 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 80
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(L(K)), where L(K) is the transformation
* stored in column K of A.
*
IF( K.LT.N )
$ CALL DGER( N-K, NRHS, -ONE, A( K+1, K ), 1, B( K, 1 ),
$ LDB, B( K+1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
CALL DSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB )
K = K + 1
ELSE
*
* 2 x 2 diagonal block
*
* Interchange rows K+1 and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K+1 )
$ CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(L(K)), where L(K) is the transformation
* stored in columns K and K+1 of A.
*
IF( K.LT.N-1 ) THEN
CALL DGER( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K, 1 ),
$ LDB, B( K+2, 1 ), LDB )
CALL DGER( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1,
$ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
END IF
*
* Multiply by the inverse of the diagonal block.
*
AKM1K = A( K+1, K )
AKM1 = A( K, K ) / AKM1K
AK = A( K+1, K+1 ) / AKM1K
DENOM = AKM1*AK - ONE
DO 70 J = 1, NRHS
BKM1 = B( K, J ) / AKM1K
BK = B( K+1, J ) / AKM1K
B( K, J ) = ( AK*BKM1-BK ) / DENOM
B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
70 CONTINUE
K = K + 2
END IF
*
GO TO 60
80 CONTINUE
*
* Next solve L'*X = B, overwriting B with X.
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = N
90 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 100
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Multiply by inv(L'(K)), where L(K) is the transformation
* stored in column K of A.
*
IF( K.LT.N )
$ CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
$ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB )
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
K = K - 1
ELSE
*
* 2 x 2 diagonal block
*
* Multiply by inv(L'(K-1)), where L(K-1) is the transformation
* stored in columns K-1 and K of A.
*
IF( K.LT.N ) THEN
CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
$ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB )
CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
$ LDB, A( K+1, K-1 ), 1, ONE, B( K-1, 1 ),
$ LDB )
END IF
*
* Interchange rows K and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
K = K - 2
END IF
*
GO TO 90
100 CONTINUE
END IF
*
RETURN
*
* End of DSYTRS
*
END
SUBROUTINE DTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK,
$ IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER DIAG, NORM, UPLO
INTEGER INFO, KD, LDAB, N
DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION AB( LDAB, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DTBCON estimates the reciprocal of the condition number of a
* triangular band matrix A, in either the 1-norm or the infinity-norm.
*
* The norm of A is computed and an estimate is obtained for
* norm(inv(A)), then the reciprocal of the condition number is
* computed as
* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies whether the 1-norm condition number or the
* infinity-norm condition number is required:
* = '1' or 'O': 1-norm;
* = 'I': Infinity-norm.
*
* UPLO (input) CHARACTER*1
* = 'U': A is upper triangular;
* = 'L': A is lower triangular.
*
* DIAG (input) CHARACTER*1
* = 'N': A is non-unit triangular;
* = 'U': A is unit triangular.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals or subdiagonals of the
* triangular band matrix A. KD >= 0.
*
* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
* The upper or lower triangular band matrix A, stored in the
* first kd+1 rows of the array. The j-th column of A is stored
* in the j-th column of the array AB as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
* If DIAG = 'U', the diagonal elements of A are not referenced
* and are assumed to be 1.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* RCOND (output) DOUBLE PRECISION
* The reciprocal of the condition number of the matrix A,
* computed as RCOND = 1/(norm(A) * norm(inv(A))).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT, ONENRM, UPPER
CHARACTER NORMIN
INTEGER IX, KASE, KASE1
DOUBLE PRECISION AINVNM, ANORM, SCALE, SMLNUM, XNORM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH, DLANTB
EXTERNAL LSAME, IDAMAX, DLAMCH, DLANTB
* ..
* .. External Subroutines ..
EXTERNAL DLACN2, DLATBS, DRSCL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
NOUNIT = LSAME( DIAG, 'N' )
*
IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
INFO = -1
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( KD.LT.0 ) THEN
INFO = -5
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTBCON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
END IF
*
RCOND = ZERO
SMLNUM = DLAMCH( 'Safe minimum' )*DBLE( MAX( 1, N ) )
*
* Compute the norm of the triangular matrix A.
*
ANORM = DLANTB( NORM, UPLO, DIAG, N, KD, AB, LDAB, WORK )
*
* Continue only if ANORM > 0.
*
IF( ANORM.GT.ZERO ) THEN
*
* Estimate the norm of the inverse of A.
*
AINVNM = ZERO
NORMIN = 'N'
IF( ONENRM ) THEN
KASE1 = 1
ELSE
KASE1 = 2
END IF
KASE = 0
10 CONTINUE
CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.KASE1 ) THEN
*
* Multiply by inv(A).
*
CALL DLATBS( UPLO, 'No transpose', DIAG, NORMIN, N, KD,
$ AB, LDAB, WORK, SCALE, WORK( 2*N+1 ), INFO )
ELSE
*
* Multiply by inv(A').
*
CALL DLATBS( UPLO, 'Transpose', DIAG, NORMIN, N, KD, AB,
$ LDAB, WORK, SCALE, WORK( 2*N+1 ), INFO )
END IF
NORMIN = 'Y'
*
* Multiply by 1/SCALE if doing so will not cause overflow.
*
IF( SCALE.NE.ONE ) THEN
IX = IDAMAX( N, WORK, 1 )
XNORM = ABS( WORK( IX ) )
IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO )
$ GO TO 20
CALL DRSCL( N, SCALE, WORK, 1 )
END IF
GO TO 10
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / ANORM ) / AINVNM
END IF
*
20 CONTINUE
RETURN
*
* End of DTBCON
*
END
SUBROUTINE DTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B,
$ LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER INFO, KD, LDAB, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ), BERR( * ),
$ FERR( * ), WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* DTBRFS provides error bounds and backward error estimates for the
* solution to a system of linear equations with a triangular band
* coefficient matrix.
*
* The solution matrix X must be computed by DTBTRS or some other
* means before entering this routine. DTBRFS does not do iterative
* refinement because doing so cannot improve the backward error.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': A is upper triangular;
* = 'L': A is lower triangular.
*
* 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**H * X = B (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* = 'N': A is non-unit triangular;
* = 'U': A is unit triangular.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals or subdiagonals of the
* triangular band matrix A. KD >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrices B and X. NRHS >= 0.
*
* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
* The upper or lower triangular band matrix A, stored in the
* first kd+1 rows of the array. The j-th column of A is stored
* in the j-th column of the array AB as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
* If DIAG = 'U', the diagonal elements of A are not referenced
* and are assumed to be 1.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN, NOUNIT, UPPER
CHARACTER TRANST
INTEGER I, J, K, KASE, NZ
DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DLACN2, DTBMV, DTBSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOTRAN = LSAME( TRANS, 'N' )
NOUNIT = LSAME( DIAG, 'N' )
*
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
$ LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( KD.LT.0 ) THEN
INFO = -5
ELSE IF( NRHS.LT.0 ) THEN
INFO = -6
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -8
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -10
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTBRFS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
DO 10 J = 1, NRHS
FERR( J ) = ZERO
BERR( J ) = ZERO
10 CONTINUE
RETURN
END IF
*
IF( NOTRAN ) THEN
TRANST = 'T'
ELSE
TRANST = 'N'
END IF
*
* NZ = maximum number of nonzero elements in each row of A, plus 1
*
NZ = KD + 2
EPS = DLAMCH( 'Epsilon' )
SAFMIN = DLAMCH( 'Safe minimum' )
SAFE1 = NZ*SAFMIN
SAFE2 = SAFE1 / EPS
*
* Do for each right hand side
*
DO 250 J = 1, NRHS
*
* Compute residual R = B - op(A) * X,
* where op(A) = A or A', depending on TRANS.
*
CALL DCOPY( N, X( 1, J ), 1, WORK( N+1 ), 1 )
CALL DTBMV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, WORK( N+1 ),
$ 1 )
CALL DAXPY( N, -ONE, B( 1, J ), 1, WORK( N+1 ), 1 )
*
* Compute componentwise relative backward error from formula
*
* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
*
* where abs(Z) is the componentwise absolute value of the matrix
* or vector Z. If the i-th component of the denominator is less
* than SAFE2, then SAFE1 is added to the i-th components of the
* numerator and denominator before dividing.
*
DO 20 I = 1, N
WORK( I ) = ABS( B( I, J ) )
20 CONTINUE
*
IF( NOTRAN ) THEN
*
* Compute abs(A)*abs(X) + abs(B).
*
IF( UPPER ) THEN
IF( NOUNIT ) THEN
DO 40 K = 1, N
XK = ABS( X( K, J ) )
DO 30 I = MAX( 1, K-KD ), K
WORK( I ) = WORK( I ) +
$ ABS( AB( KD+1+I-K, K ) )*XK
30 CONTINUE
40 CONTINUE
ELSE
DO 60 K = 1, N
XK = ABS( X( K, J ) )
DO 50 I = MAX( 1, K-KD ), K - 1
WORK( I ) = WORK( I ) +
$ ABS( AB( KD+1+I-K, K ) )*XK
50 CONTINUE
WORK( K ) = WORK( K ) + XK
60 CONTINUE
END IF
ELSE
IF( NOUNIT ) THEN
DO 80 K = 1, N
XK = ABS( X( K, J ) )
DO 70 I = K, MIN( N, K+KD )
WORK( I ) = WORK( I ) + ABS( AB( 1+I-K, K ) )*XK
70 CONTINUE
80 CONTINUE
ELSE
DO 100 K = 1, N
XK = ABS( X( K, J ) )
DO 90 I = K + 1, MIN( N, K+KD )
WORK( I ) = WORK( I ) + ABS( AB( 1+I-K, K ) )*XK
90 CONTINUE
WORK( K ) = WORK( K ) + XK
100 CONTINUE
END IF
END IF
ELSE
*
* Compute abs(A')*abs(X) + abs(B).
*
IF( UPPER ) THEN
IF( NOUNIT ) THEN
DO 120 K = 1, N
S = ZERO
DO 110 I = MAX( 1, K-KD ), K
S = S + ABS( AB( KD+1+I-K, K ) )*
$ ABS( X( I, J ) )
110 CONTINUE
WORK( K ) = WORK( K ) + S
120 CONTINUE
ELSE
DO 140 K = 1, N
S = ABS( X( K, J ) )
DO 130 I = MAX( 1, K-KD ), K - 1
S = S + ABS( AB( KD+1+I-K, K ) )*
$ ABS( X( I, J ) )
130 CONTINUE
WORK( K ) = WORK( K ) + S
140 CONTINUE
END IF
ELSE
IF( NOUNIT ) THEN
DO 160 K = 1, N
S = ZERO
DO 150 I = K, MIN( N, K+KD )
S = S + ABS( AB( 1+I-K, K ) )*ABS( X( I, J ) )
150 CONTINUE
WORK( K ) = WORK( K ) + S
160 CONTINUE
ELSE
DO 180 K = 1, N
S = ABS( X( K, J ) )
DO 170 I = K + 1, MIN( N, K+KD )
S = S + ABS( AB( 1+I-K, K ) )*ABS( X( I, J ) )
170 CONTINUE
WORK( K ) = WORK( K ) + S
180 CONTINUE
END IF
END IF
END IF
S = ZERO
DO 190 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
ELSE
S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
$ ( WORK( I )+SAFE1 ) )
END IF
190 CONTINUE
BERR( J ) = S
*
* Bound error from formula
*
* norm(X - XTRUE) / norm(X) .le. FERR =
* norm( abs(inv(op(A)))*
* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
*
* where
* norm(Z) is the magnitude of the largest component of Z
* inv(op(A)) is the inverse of op(A)
* abs(Z) is the componentwise absolute value of the matrix or
* vector Z
* NZ is the maximum number of nonzeros in any row of A, plus 1
* EPS is machine epsilon
*
* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
* is incremented by SAFE1 if the i-th component of
* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
*
* Use DLACN2 to estimate the infinity-norm of the matrix
* inv(op(A)) * diag(W),
* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
*
DO 200 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
ELSE
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
END IF
200 CONTINUE
*
KASE = 0
210 CONTINUE
CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
$ KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Multiply by diag(W)*inv(op(A)').
*
CALL DTBSV( UPLO, TRANST, DIAG, N, KD, AB, LDAB,
$ WORK( N+1 ), 1 )
DO 220 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
220 CONTINUE
ELSE
*
* Multiply by inv(op(A))*diag(W).
*
DO 230 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
230 CONTINUE
CALL DTBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB,
$ WORK( N+1 ), 1 )
END IF
GO TO 210
END IF
*
* Normalize error.
*
LSTRES = ZERO
DO 240 I = 1, N
LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
240 CONTINUE
IF( LSTRES.NE.ZERO )
$ FERR( J ) = FERR( J ) / LSTRES
*
250 CONTINUE
*
RETURN
*
* End of DTBRFS
*
END
SUBROUTINE DTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B,
$ LDB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER INFO, KD, LDAB, LDB, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION AB( LDAB, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* DTBTRS solves a triangular system of the form
*
* A * X = B or A**T * X = B,
*
* where A is a triangular band matrix of order N, and B is an
* N-by NRHS matrix. A check is made to verify that A is nonsingular.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': A is upper triangular;
* = 'L': A is lower triangular.
*
* TRANS (input) CHARACTER*1
* Specifies the form the system of equations:
* = 'N': A * X = B (No transpose)
* = 'T': A**T * X = B (Transpose)
* = 'C': A**H * X = B (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* = 'N': A is non-unit triangular;
* = 'U': A is unit triangular.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals or subdiagonals of the
* triangular band matrix A. KD >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrix B. NRHS >= 0.
*
* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
* The upper or lower triangular band matrix A, stored in the
* first kd+1 rows of AB. The j-th column of A is stored
* in the j-th column of the array AB as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
* If DIAG = 'U', the diagonal elements of A are not referenced
* and are assumed to be 1.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the right hand side matrix B.
* On exit, if INFO = 0, 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
* > 0: if INFO = i, the i-th diagonal element of A is zero,
* indicating that the matrix is singular and the
* solutions X have not been computed.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT, UPPER
INTEGER J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DTBSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
NOUNIT = LSAME( DIAG, 'N' )
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .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.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( KD.LT.0 ) THEN
INFO = -5
ELSE IF( NRHS.LT.0 ) THEN
INFO = -6
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -8
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTBTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Check for singularity.
*
IF( NOUNIT ) THEN
IF( UPPER ) THEN
DO 10 INFO = 1, N
IF( AB( KD+1, INFO ).EQ.ZERO )
$ RETURN
10 CONTINUE
ELSE
DO 20 INFO = 1, N
IF( AB( 1, INFO ).EQ.ZERO )
$ RETURN
20 CONTINUE
END IF
END IF
INFO = 0
*
* Solve A * X = B or A' * X = B.
*
DO 30 J = 1, NRHS
CALL DTBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, B( 1, J ), 1 )
30 CONTINUE
*
RETURN
*
* End of DTBTRS
*
END
SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL,
$ LDVL, VR, LDVR, MM, M, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER HOWMNY, SIDE
INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N
* ..
* .. Array Arguments ..
LOGICAL SELECT( * )
DOUBLE PRECISION P( LDP, * ), S( LDS, * ), VL( LDVL, * ),
$ VR( LDVR, * ), WORK( * )
* ..
*
*
* Purpose
* =======
*
* DTGEVC computes some or all of the right and/or left eigenvectors of
* a pair of real matrices (S,P), where S is a quasi-triangular matrix
* and P is upper triangular. Matrix pairs of this type are produced by
* the generalized Schur factorization of a matrix pair (A,B):
*
* A = Q*S*Z**T, B = Q*P*Z**T
*
* as computed by DGGHRD + DHGEQZ.
*
* The right eigenvector x and the left eigenvector y of (S,P)
* corresponding to an eigenvalue w are defined by:
*
* S*x = w*P*x, (y**H)*S = w*(y**H)*P,
*
* where y**H denotes the conjugate tranpose of y.
* The eigenvalues are not input to this routine, but are computed
* directly from the diagonal blocks of S and P.
*
* This routine returns the matrices X and/or Y of right and left
* eigenvectors of (S,P), or the products Z*X and/or Q*Y,
* where Z and Q are input matrices.
* If Q and Z are the orthogonal factors from the generalized Schur
* factorization of a matrix pair (A,B), then Z*X and Q*Y
* are the matrices of right and left eigenvectors of (A,B).
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* = 'R': compute right eigenvectors only;
* = 'L': compute left eigenvectors only;
* = 'B': compute both right and left eigenvectors.
*
* HOWMNY (input) CHARACTER*1
* = 'A': compute all right and/or left eigenvectors;
* = 'B': compute all right and/or left eigenvectors,
* backtransformed by the matrices in VR and/or VL;
* = 'S': compute selected right and/or left eigenvectors,
* specified by the logical array SELECT.
*
* SELECT (input) LOGICAL array, dimension (N)
* If HOWMNY='S', SELECT specifies the eigenvectors to be
* computed. If w(j) is a real eigenvalue, the corresponding
* real eigenvector is computed if SELECT(j) is .TRUE..
* If w(j) and w(j+1) are the real and imaginary parts of a
* complex eigenvalue, the corresponding complex eigenvector
* is computed if either SELECT(j) or SELECT(j+1) is .TRUE.,
* and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is
* set to .FALSE..
* Not referenced if HOWMNY = 'A' or 'B'.
*
* N (input) INTEGER
* The order of the matrices S and P. N >= 0.
*
* S (input) DOUBLE PRECISION array, dimension (LDS,N)
* The upper quasi-triangular matrix S from a generalized Schur
* factorization, as computed by DHGEQZ.
*
* LDS (input) INTEGER
* The leading dimension of array S. LDS >= max(1,N).
*
* P (input) DOUBLE PRECISION array, dimension (LDP,N)
* The upper triangular matrix P from a generalized Schur
* factorization, as computed by DHGEQZ.
* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks
* of S must be in positive diagonal form.
*
* LDP (input) INTEGER
* The leading dimension of array P. LDP >= max(1,N).
*
* VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)
* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
* contain an N-by-N matrix Q (usually the orthogonal matrix Q
* of left Schur vectors returned by DHGEQZ).
* On exit, if SIDE = 'L' or 'B', VL contains:
* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);
* if HOWMNY = 'B', the matrix Q*Y;
* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by
* SELECT, stored consecutively in the columns of
* VL, in the same order as their eigenvalues.
*
* A complex eigenvector corresponding to a complex eigenvalue
* is stored in two consecutive columns, the first holding the
* real part, and the second the imaginary part.
*
* Not referenced if SIDE = 'R'.
*
* LDVL (input) INTEGER
* The leading dimension of array VL. LDVL >= 1, and if
* SIDE = 'L' or 'B', LDVL >= N.
*
* VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)
* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
* contain an N-by-N matrix Z (usually the orthogonal matrix Z
* of right Schur vectors returned by DHGEQZ).
*
* On exit, if SIDE = 'R' or 'B', VR contains:
* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);
* if HOWMNY = 'B' or 'b', the matrix Z*X;
* if HOWMNY = 'S' or 's', the right eigenvectors of (S,P)
* specified by SELECT, stored consecutively in the
* columns of VR, in the same order as their
* eigenvalues.
*
* A complex eigenvector corresponding to a complex eigenvalue
* is stored in two consecutive columns, the first holding the
* real part and the second the imaginary part.
*
* Not referenced if SIDE = 'L'.
*
* LDVR (input) INTEGER
* The leading dimension of the array VR. LDVR >= 1, and if
* SIDE = 'R' or 'B', LDVR >= N.
*
* MM (input) INTEGER
* The number of columns in the arrays VL and/or VR. MM >= M.
*
* M (output) INTEGER
* The number of columns in the arrays VL and/or VR actually
* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M
* is set to N. Each selected real eigenvector occupies one
* column and each selected complex eigenvector occupies two
* columns.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (6*N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: the 2-by-2 block (INFO:INFO+1) does not have a complex
* eigenvalue.
*
* Further Details
* ===============
*
* Allocation of workspace:
* ---------- -- ---------
*
* WORK( j ) = 1-norm of j-th column of A, above the diagonal
* WORK( N+j ) = 1-norm of j-th column of B, above the diagonal
* WORK( 2*N+1:3*N ) = real part of eigenvector
* WORK( 3*N+1:4*N ) = imaginary part of eigenvector
* WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector
* WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector
*
* Rowwise vs. columnwise solution methods:
* ------- -- ---------- -------- -------
*
* Finding a generalized eigenvector consists basically of solving the
* singular triangular system
*
* (A - w B) x = 0 (for right) or: (A - w B)**H y = 0 (for left)
*
* Consider finding the i-th right eigenvector (assume all eigenvalues
* are real). The equation to be solved is:
* n i
* 0 = sum C(j,k) v(k) = sum C(j,k) v(k) for j = i,. . .,1
* k=j k=j
*
* where C = (A - w B) (The components v(i+1:n) are 0.)
*
* The "rowwise" method is:
*
* (1) v(i) := 1
* for j = i-1,. . .,1:
* i
* (2) compute s = - sum C(j,k) v(k) and
* k=j+1
*
* (3) v(j) := s / C(j,j)
*
* Step 2 is sometimes called the "dot product" step, since it is an
* inner product between the j-th row and the portion of the eigenvector
* that has been computed so far.
*
* The "columnwise" method consists basically in doing the sums
* for all the rows in parallel. As each v(j) is computed, the
* contribution of v(j) times the j-th column of C is added to the
* partial sums. Since FORTRAN arrays are stored columnwise, this has
* the advantage that at each step, the elements of C that are accessed
* are adjacent to one another, whereas with the rowwise method, the
* elements accessed at a step are spaced LDS (and LDP) words apart.
*
* When finding left eigenvectors, the matrix in question is the
* transpose of the one in storage, so the rowwise method then
* actually accesses columns of A and B at each step, and so is the
* preferred method.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, SAFETY
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0,
$ SAFETY = 1.0D+2 )
* ..
* .. Local Scalars ..
LOGICAL COMPL, COMPR, IL2BY2, ILABAD, ILALL, ILBACK,
$ ILBBAD, ILCOMP, ILCPLX, LSA, LSB
INTEGER I, IBEG, IEIG, IEND, IHWMNY, IINFO, IM, ISIDE,
$ J, JA, JC, JE, JR, JW, NA, NW
DOUBLE PRECISION ACOEF, ACOEFA, ANORM, ASCALE, BCOEFA, BCOEFI,
$ BCOEFR, BIG, BIGNUM, BNORM, BSCALE, CIM2A,
$ CIM2B, CIMAGA, CIMAGB, CRE2A, CRE2B, CREALA,
$ CREALB, DMIN, SAFMIN, SALFAR, SBETA, SCALE,
$ SMALL, TEMP, TEMP2, TEMP2I, TEMP2R, ULP, XMAX,
$ XSCALE
* ..
* .. Local Arrays ..
DOUBLE PRECISION BDIAG( 2 ), SUM( 2, 2 ), SUMS( 2, 2 ),
$ SUMP( 2, 2 )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DGEMV, DLABAD, DLACPY, DLAG2, DLALN2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Decode and Test the input parameters
*
IF( LSAME( HOWMNY, 'A' ) ) THEN
IHWMNY = 1
ILALL = .TRUE.
ILBACK = .FALSE.
ELSE IF( LSAME( HOWMNY, 'S' ) ) THEN
IHWMNY = 2
ILALL = .FALSE.
ILBACK = .FALSE.
ELSE IF( LSAME( HOWMNY, 'B' ) ) THEN
IHWMNY = 3
ILALL = .TRUE.
ILBACK = .TRUE.
ELSE
IHWMNY = -1
ILALL = .TRUE.
END IF
*
IF( LSAME( SIDE, 'R' ) ) THEN
ISIDE = 1
COMPL = .FALSE.
COMPR = .TRUE.
ELSE IF( LSAME( SIDE, 'L' ) ) THEN
ISIDE = 2
COMPL = .TRUE.
COMPR = .FALSE.
ELSE IF( LSAME( SIDE, 'B' ) ) THEN
ISIDE = 3
COMPL = .TRUE.
COMPR = .TRUE.
ELSE
ISIDE = -1
END IF
*
INFO = 0
IF( ISIDE.LT.0 ) THEN
INFO = -1
ELSE IF( IHWMNY.LT.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDS.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDP.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTGEVC', -INFO )
RETURN
END IF
*
* Count the number of eigenvectors to be computed
*
IF( .NOT.ILALL ) THEN
IM = 0
ILCPLX = .FALSE.
DO 10 J = 1, N
IF( ILCPLX ) THEN
ILCPLX = .FALSE.
GO TO 10
END IF
IF( J.LT.N ) THEN
IF( S( J+1, J ).NE.ZERO )
$ ILCPLX = .TRUE.
END IF
IF( ILCPLX ) THEN
IF( SELECT( J ) .OR. SELECT( J+1 ) )
$ IM = IM + 2
ELSE
IF( SELECT( J ) )
$ IM = IM + 1
END IF
10 CONTINUE
ELSE
IM = N
END IF
*
* Check 2-by-2 diagonal blocks of A, B
*
ILABAD = .FALSE.
ILBBAD = .FALSE.
DO 20 J = 1, N - 1
IF( S( J+1, J ).NE.ZERO ) THEN
IF( P( J, J ).EQ.ZERO .OR. P( J+1, J+1 ).EQ.ZERO .OR.
$ P( J, J+1 ).NE.ZERO )ILBBAD = .TRUE.
IF( J.LT.N-1 ) THEN
IF( S( J+2, J+1 ).NE.ZERO )
$ ILABAD = .TRUE.
END IF
END IF
20 CONTINUE
*
IF( ILABAD ) THEN
INFO = -5
ELSE IF( ILBBAD ) THEN
INFO = -7
ELSE IF( COMPL .AND. LDVL.LT.N .OR. LDVL.LT.1 ) THEN
INFO = -10
ELSE IF( COMPR .AND. LDVR.LT.N .OR. LDVR.LT.1 ) THEN
INFO = -12
ELSE IF( MM.LT.IM ) THEN
INFO = -13
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTGEVC', -INFO )
RETURN
END IF
*
* Quick return if possible
*
M = IM
IF( N.EQ.0 )
$ RETURN
*
* Machine Constants
*
SAFMIN = DLAMCH( 'Safe minimum' )
BIG = ONE / SAFMIN
CALL DLABAD( SAFMIN, BIG )
ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
SMALL = SAFMIN*N / ULP
BIG = ONE / SMALL
BIGNUM = ONE / ( SAFMIN*N )
*
* Compute the 1-norm of each column of the strictly upper triangular
* part (i.e., excluding all elements belonging to the diagonal
* blocks) of A and B to check for possible overflow in the
* triangular solver.
*
ANORM = ABS( S( 1, 1 ) )
IF( N.GT.1 )
$ ANORM = ANORM + ABS( S( 2, 1 ) )
BNORM = ABS( P( 1, 1 ) )
WORK( 1 ) = ZERO
WORK( N+1 ) = ZERO
*
DO 50 J = 2, N
TEMP = ZERO
TEMP2 = ZERO
IF( S( J, J-1 ).EQ.ZERO ) THEN
IEND = J - 1
ELSE
IEND = J - 2
END IF
DO 30 I = 1, IEND
TEMP = TEMP + ABS( S( I, J ) )
TEMP2 = TEMP2 + ABS( P( I, J ) )
30 CONTINUE
WORK( J ) = TEMP
WORK( N+J ) = TEMP2
DO 40 I = IEND + 1, MIN( J+1, N )
TEMP = TEMP + ABS( S( I, J ) )
TEMP2 = TEMP2 + ABS( P( I, J ) )
40 CONTINUE
ANORM = MAX( ANORM, TEMP )
BNORM = MAX( BNORM, TEMP2 )
50 CONTINUE
*
ASCALE = ONE / MAX( ANORM, SAFMIN )
BSCALE = ONE / MAX( BNORM, SAFMIN )
*
* Left eigenvectors
*
IF( COMPL ) THEN
IEIG = 0
*
* Main loop over eigenvalues
*
ILCPLX = .FALSE.
DO 220 JE = 1, N
*
* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or
* (b) this would be the second of a complex pair.
* Check for complex eigenvalue, so as to be sure of which
* entry(-ies) of SELECT to look at.
*
IF( ILCPLX ) THEN
ILCPLX = .FALSE.
GO TO 220
END IF
NW = 1
IF( JE.LT.N ) THEN
IF( S( JE+1, JE ).NE.ZERO ) THEN
ILCPLX = .TRUE.
NW = 2
END IF
END IF
IF( ILALL ) THEN
ILCOMP = .TRUE.
ELSE IF( ILCPLX ) THEN
ILCOMP = SELECT( JE ) .OR. SELECT( JE+1 )
ELSE
ILCOMP = SELECT( JE )
END IF
IF( .NOT.ILCOMP )
$ GO TO 220
*
* Decide if (a) singular pencil, (b) real eigenvalue, or
* (c) complex eigenvalue.
*
IF( .NOT.ILCPLX ) THEN
IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND.
$ ABS( P( JE, JE ) ).LE.SAFMIN ) THEN
*
* Singular matrix pencil -- return unit eigenvector
*
IEIG = IEIG + 1
DO 60 JR = 1, N
VL( JR, IEIG ) = ZERO
60 CONTINUE
VL( IEIG, IEIG ) = ONE
GO TO 220
END IF
END IF
*
* Clear vector
*
DO 70 JR = 1, NW*N
WORK( 2*N+JR ) = ZERO
70 CONTINUE
* T
* Compute coefficients in ( a A - b B ) y = 0
* a is ACOEF
* b is BCOEFR + i*BCOEFI
*
IF( .NOT.ILCPLX ) THEN
*
* Real eigenvalue
*
TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE,
$ ABS( P( JE, JE ) )*BSCALE, SAFMIN )
SALFAR = ( TEMP*S( JE, JE ) )*ASCALE
SBETA = ( TEMP*P( JE, JE ) )*BSCALE
ACOEF = SBETA*ASCALE
BCOEFR = SALFAR*BSCALE
BCOEFI = ZERO
*
* Scale to avoid underflow
*
SCALE = ONE
LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEF ).LT.SMALL
LSB = ABS( SALFAR ).GE.SAFMIN .AND. ABS( BCOEFR ).LT.
$ SMALL
IF( LSA )
$ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG )
IF( LSB )
$ SCALE = MAX( SCALE, ( SMALL / ABS( SALFAR ) )*
$ MIN( BNORM, BIG ) )
IF( LSA .OR. LSB ) THEN
SCALE = MIN( SCALE, ONE /
$ ( SAFMIN*MAX( ONE, ABS( ACOEF ),
$ ABS( BCOEFR ) ) ) )
IF( LSA ) THEN
ACOEF = ASCALE*( SCALE*SBETA )
ELSE
ACOEF = SCALE*ACOEF
END IF
IF( LSB ) THEN
BCOEFR = BSCALE*( SCALE*SALFAR )
ELSE
BCOEFR = SCALE*BCOEFR
END IF
END IF
ACOEFA = ABS( ACOEF )
BCOEFA = ABS( BCOEFR )
*
* First component is 1
*
WORK( 2*N+JE ) = ONE
XMAX = ONE
ELSE
*
* Complex eigenvalue
*
CALL DLAG2( S( JE, JE ), LDS, P( JE, JE ), LDP,
$ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2,
$ BCOEFI )
BCOEFI = -BCOEFI
IF( BCOEFI.EQ.ZERO ) THEN
INFO = JE
RETURN
END IF
*
* Scale to avoid over/underflow
*
ACOEFA = ABS( ACOEF )
BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
SCALE = ONE
IF( ACOEFA*ULP.LT.SAFMIN .AND. ACOEFA.GE.SAFMIN )
$ SCALE = ( SAFMIN / ULP ) / ACOEFA
IF( BCOEFA*ULP.LT.SAFMIN .AND. BCOEFA.GE.SAFMIN )
$ SCALE = MAX( SCALE, ( SAFMIN / ULP ) / BCOEFA )
IF( SAFMIN*ACOEFA.GT.ASCALE )
$ SCALE = ASCALE / ( SAFMIN*ACOEFA )
IF( SAFMIN*BCOEFA.GT.BSCALE )
$ SCALE = MIN( SCALE, BSCALE / ( SAFMIN*BCOEFA ) )
IF( SCALE.NE.ONE ) THEN
ACOEF = SCALE*ACOEF
ACOEFA = ABS( ACOEF )
BCOEFR = SCALE*BCOEFR
BCOEFI = SCALE*BCOEFI
BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
END IF
*
* Compute first two components of eigenvector
*
TEMP = ACOEF*S( JE+1, JE )
TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE )
TEMP2I = -BCOEFI*P( JE, JE )
IF( ABS( TEMP ).GT.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN
WORK( 2*N+JE ) = ONE
WORK( 3*N+JE ) = ZERO
WORK( 2*N+JE+1 ) = -TEMP2R / TEMP
WORK( 3*N+JE+1 ) = -TEMP2I / TEMP
ELSE
WORK( 2*N+JE+1 ) = ONE
WORK( 3*N+JE+1 ) = ZERO
TEMP = ACOEF*S( JE, JE+1 )
WORK( 2*N+JE ) = ( BCOEFR*P( JE+1, JE+1 )-ACOEF*
$ S( JE+1, JE+1 ) ) / TEMP
WORK( 3*N+JE ) = BCOEFI*P( JE+1, JE+1 ) / TEMP
END IF
XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ),
$ ABS( WORK( 2*N+JE+1 ) )+ABS( WORK( 3*N+JE+1 ) ) )
END IF
*
DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN )
*
* T
* Triangular solve of (a A - b B) y = 0
*
* T
* (rowwise in (a A - b B) , or columnwise in (a A - b B) )
*
IL2BY2 = .FALSE.
*
DO 160 J = JE + NW, N
IF( IL2BY2 ) THEN
IL2BY2 = .FALSE.
GO TO 160
END IF
*
NA = 1
BDIAG( 1 ) = P( J, J )
IF( J.LT.N ) THEN
IF( S( J+1, J ).NE.ZERO ) THEN
IL2BY2 = .TRUE.
BDIAG( 2 ) = P( J+1, J+1 )
NA = 2
END IF
END IF
*
* Check whether scaling is necessary for dot products
*
XSCALE = ONE / MAX( ONE, XMAX )
TEMP = MAX( WORK( J ), WORK( N+J ),
$ ACOEFA*WORK( J )+BCOEFA*WORK( N+J ) )
IF( IL2BY2 )
$ TEMP = MAX( TEMP, WORK( J+1 ), WORK( N+J+1 ),
$ ACOEFA*WORK( J+1 )+BCOEFA*WORK( N+J+1 ) )
IF( TEMP.GT.BIGNUM*XSCALE ) THEN
DO 90 JW = 0, NW - 1
DO 80 JR = JE, J - 1
WORK( ( JW+2 )*N+JR ) = XSCALE*
$ WORK( ( JW+2 )*N+JR )
80 CONTINUE
90 CONTINUE
XMAX = XMAX*XSCALE
END IF
*
* Compute dot products
*
* j-1
* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k)
* k=je
*
* To reduce the op count, this is done as
*
* _ j-1 _ j-1
* a*conjg( sum S(k,j)*x(k) ) - b*conjg( sum P(k,j)*x(k) )
* k=je k=je
*
* which may cause underflow problems if A or B are close
* to underflow. (E.g., less than SMALL.)
*
*
* A series of compiler directives to defeat vectorization
* for the next loop
*
*$PL$ CMCHAR=' '
CDIR$ NEXTSCALAR
C$DIR SCALAR
CDIR$ NEXT SCALAR
CVD$L NOVECTOR
CDEC$ NOVECTOR
CVD$ NOVECTOR
*VDIR NOVECTOR
*VOCL LOOP,SCALAR
CIBM PREFER SCALAR
*$PL$ CMCHAR='*'
*
DO 120 JW = 1, NW
*
*$PL$ CMCHAR=' '
CDIR$ NEXTSCALAR
C$DIR SCALAR
CDIR$ NEXT SCALAR
CVD$L NOVECTOR
CDEC$ NOVECTOR
CVD$ NOVECTOR
*VDIR NOVECTOR
*VOCL LOOP,SCALAR
CIBM PREFER SCALAR
*$PL$ CMCHAR='*'
*
DO 110 JA = 1, NA
SUMS( JA, JW ) = ZERO
SUMP( JA, JW ) = ZERO
*
DO 100 JR = JE, J - 1
SUMS( JA, JW ) = SUMS( JA, JW ) +
$ S( JR, J+JA-1 )*
$ WORK( ( JW+1 )*N+JR )
SUMP( JA, JW ) = SUMP( JA, JW ) +
$ P( JR, J+JA-1 )*
$ WORK( ( JW+1 )*N+JR )
100 CONTINUE
110 CONTINUE
120 CONTINUE
*
*$PL$ CMCHAR=' '
CDIR$ NEXTSCALAR
C$DIR SCALAR
CDIR$ NEXT SCALAR
CVD$L NOVECTOR
CDEC$ NOVECTOR
CVD$ NOVECTOR
*VDIR NOVECTOR
*VOCL LOOP,SCALAR
CIBM PREFER SCALAR
*$PL$ CMCHAR='*'
*
DO 130 JA = 1, NA
IF( ILCPLX ) THEN
SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) +
$ BCOEFR*SUMP( JA, 1 ) -
$ BCOEFI*SUMP( JA, 2 )
SUM( JA, 2 ) = -ACOEF*SUMS( JA, 2 ) +
$ BCOEFR*SUMP( JA, 2 ) +
$ BCOEFI*SUMP( JA, 1 )
ELSE
SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) +
$ BCOEFR*SUMP( JA, 1 )
END IF
130 CONTINUE
*
* T
* Solve ( a A - b B ) y = SUM(,)
* with scaling and perturbation of the denominator
*
CALL DLALN2( .TRUE., NA, NW, DMIN, ACOEF, S( J, J ), LDS,
$ BDIAG( 1 ), BDIAG( 2 ), SUM, 2, BCOEFR,
$ BCOEFI, WORK( 2*N+J ), N, SCALE, TEMP,
$ IINFO )
IF( SCALE.LT.ONE ) THEN
DO 150 JW = 0, NW - 1
DO 140 JR = JE, J - 1
WORK( ( JW+2 )*N+JR ) = SCALE*
$ WORK( ( JW+2 )*N+JR )
140 CONTINUE
150 CONTINUE
XMAX = SCALE*XMAX
END IF
XMAX = MAX( XMAX, TEMP )
160 CONTINUE
*
* Copy eigenvector to VL, back transforming if
* HOWMNY='B'.
*
IEIG = IEIG + 1
IF( ILBACK ) THEN
DO 170 JW = 0, NW - 1
CALL DGEMV( 'N', N, N+1-JE, ONE, VL( 1, JE ), LDVL,
$ WORK( ( JW+2 )*N+JE ), 1, ZERO,
$ WORK( ( JW+4 )*N+1 ), 1 )
170 CONTINUE
CALL DLACPY( ' ', N, NW, WORK( 4*N+1 ), N, VL( 1, JE ),
$ LDVL )
IBEG = 1
ELSE
CALL DLACPY( ' ', N, NW, WORK( 2*N+1 ), N, VL( 1, IEIG ),
$ LDVL )
IBEG = JE
END IF
*
* Scale eigenvector
*
XMAX = ZERO
IF( ILCPLX ) THEN
DO 180 J = IBEG, N
XMAX = MAX( XMAX, ABS( VL( J, IEIG ) )+
$ ABS( VL( J, IEIG+1 ) ) )
180 CONTINUE
ELSE
DO 190 J = IBEG, N
XMAX = MAX( XMAX, ABS( VL( J, IEIG ) ) )
190 CONTINUE
END IF
*
IF( XMAX.GT.SAFMIN ) THEN
XSCALE = ONE / XMAX
*
DO 210 JW = 0, NW - 1
DO 200 JR = IBEG, N
VL( JR, IEIG+JW ) = XSCALE*VL( JR, IEIG+JW )
200 CONTINUE
210 CONTINUE
END IF
IEIG = IEIG + NW - 1
*
220 CONTINUE
END IF
*
* Right eigenvectors
*
IF( COMPR ) THEN
IEIG = IM + 1
*
* Main loop over eigenvalues
*
ILCPLX = .FALSE.
DO 500 JE = N, 1, -1
*
* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or
* (b) this would be the second of a complex pair.
* Check for complex eigenvalue, so as to be sure of which
* entry(-ies) of SELECT to look at -- if complex, SELECT(JE)
* or SELECT(JE-1).
* If this is a complex pair, the 2-by-2 diagonal block
* corresponding to the eigenvalue is in rows/columns JE-1:JE
*
IF( ILCPLX ) THEN
ILCPLX = .FALSE.
GO TO 500
END IF
NW = 1
IF( JE.GT.1 ) THEN
IF( S( JE, JE-1 ).NE.ZERO ) THEN
ILCPLX = .TRUE.
NW = 2
END IF
END IF
IF( ILALL ) THEN
ILCOMP = .TRUE.
ELSE IF( ILCPLX ) THEN
ILCOMP = SELECT( JE ) .OR. SELECT( JE-1 )
ELSE
ILCOMP = SELECT( JE )
END IF
IF( .NOT.ILCOMP )
$ GO TO 500
*
* Decide if (a) singular pencil, (b) real eigenvalue, or
* (c) complex eigenvalue.
*
IF( .NOT.ILCPLX ) THEN
IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND.
$ ABS( P( JE, JE ) ).LE.SAFMIN ) THEN
*
* Singular matrix pencil -- unit eigenvector
*
IEIG = IEIG - 1
DO 230 JR = 1, N
VR( JR, IEIG ) = ZERO
230 CONTINUE
VR( IEIG, IEIG ) = ONE
GO TO 500
END IF
END IF
*
* Clear vector
*
DO 250 JW = 0, NW - 1
DO 240 JR = 1, N
WORK( ( JW+2 )*N+JR ) = ZERO
240 CONTINUE
250 CONTINUE
*
* Compute coefficients in ( a A - b B ) x = 0
* a is ACOEF
* b is BCOEFR + i*BCOEFI
*
IF( .NOT.ILCPLX ) THEN
*
* Real eigenvalue
*
TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE,
$ ABS( P( JE, JE ) )*BSCALE, SAFMIN )
SALFAR = ( TEMP*S( JE, JE ) )*ASCALE
SBETA = ( TEMP*P( JE, JE ) )*BSCALE
ACOEF = SBETA*ASCALE
BCOEFR = SALFAR*BSCALE
BCOEFI = ZERO
*
* Scale to avoid underflow
*
SCALE = ONE
LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEF ).LT.SMALL
LSB = ABS( SALFAR ).GE.SAFMIN .AND. ABS( BCOEFR ).LT.
$ SMALL
IF( LSA )
$ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG )
IF( LSB )
$ SCALE = MAX( SCALE, ( SMALL / ABS( SALFAR ) )*
$ MIN( BNORM, BIG ) )
IF( LSA .OR. LSB ) THEN
SCALE = MIN( SCALE, ONE /
$ ( SAFMIN*MAX( ONE, ABS( ACOEF ),
$ ABS( BCOEFR ) ) ) )
IF( LSA ) THEN
ACOEF = ASCALE*( SCALE*SBETA )
ELSE
ACOEF = SCALE*ACOEF
END IF
IF( LSB ) THEN
BCOEFR = BSCALE*( SCALE*SALFAR )
ELSE
BCOEFR = SCALE*BCOEFR
END IF
END IF
ACOEFA = ABS( ACOEF )
BCOEFA = ABS( BCOEFR )
*
* First component is 1
*
WORK( 2*N+JE ) = ONE
XMAX = ONE
*
* Compute contribution from column JE of A and B to sum
* (See "Further Details", above.)
*
DO 260 JR = 1, JE - 1
WORK( 2*N+JR ) = BCOEFR*P( JR, JE ) -
$ ACOEF*S( JR, JE )
260 CONTINUE
ELSE
*
* Complex eigenvalue
*
CALL DLAG2( S( JE-1, JE-1 ), LDS, P( JE-1, JE-1 ), LDP,
$ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2,
$ BCOEFI )
IF( BCOEFI.EQ.ZERO ) THEN
INFO = JE - 1
RETURN
END IF
*
* Scale to avoid over/underflow
*
ACOEFA = ABS( ACOEF )
BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
SCALE = ONE
IF( ACOEFA*ULP.LT.SAFMIN .AND. ACOEFA.GE.SAFMIN )
$ SCALE = ( SAFMIN / ULP ) / ACOEFA
IF( BCOEFA*ULP.LT.SAFMIN .AND. BCOEFA.GE.SAFMIN )
$ SCALE = MAX( SCALE, ( SAFMIN / ULP ) / BCOEFA )
IF( SAFMIN*ACOEFA.GT.ASCALE )
$ SCALE = ASCALE / ( SAFMIN*ACOEFA )
IF( SAFMIN*BCOEFA.GT.BSCALE )
$ SCALE = MIN( SCALE, BSCALE / ( SAFMIN*BCOEFA ) )
IF( SCALE.NE.ONE ) THEN
ACOEF = SCALE*ACOEF
ACOEFA = ABS( ACOEF )
BCOEFR = SCALE*BCOEFR
BCOEFI = SCALE*BCOEFI
BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
END IF
*
* Compute first two components of eigenvector
* and contribution to sums
*
TEMP = ACOEF*S( JE, JE-1 )
TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE )
TEMP2I = -BCOEFI*P( JE, JE )
IF( ABS( TEMP ).GE.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN
WORK( 2*N+JE ) = ONE
WORK( 3*N+JE ) = ZERO
WORK( 2*N+JE-1 ) = -TEMP2R / TEMP
WORK( 3*N+JE-1 ) = -TEMP2I / TEMP
ELSE
WORK( 2*N+JE-1 ) = ONE
WORK( 3*N+JE-1 ) = ZERO
TEMP = ACOEF*S( JE-1, JE )
WORK( 2*N+JE ) = ( BCOEFR*P( JE-1, JE-1 )-ACOEF*
$ S( JE-1, JE-1 ) ) / TEMP
WORK( 3*N+JE ) = BCOEFI*P( JE-1, JE-1 ) / TEMP
END IF
*
XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ),
$ ABS( WORK( 2*N+JE-1 ) )+ABS( WORK( 3*N+JE-1 ) ) )
*
* Compute contribution from columns JE and JE-1
* of A and B to the sums.
*
CREALA = ACOEF*WORK( 2*N+JE-1 )
CIMAGA = ACOEF*WORK( 3*N+JE-1 )
CREALB = BCOEFR*WORK( 2*N+JE-1 ) -
$ BCOEFI*WORK( 3*N+JE-1 )
CIMAGB = BCOEFI*WORK( 2*N+JE-1 ) +
$ BCOEFR*WORK( 3*N+JE-1 )
CRE2A = ACOEF*WORK( 2*N+JE )
CIM2A = ACOEF*WORK( 3*N+JE )
CRE2B = BCOEFR*WORK( 2*N+JE ) - BCOEFI*WORK( 3*N+JE )
CIM2B = BCOEFI*WORK( 2*N+JE ) + BCOEFR*WORK( 3*N+JE )
DO 270 JR = 1, JE - 2
WORK( 2*N+JR ) = -CREALA*S( JR, JE-1 ) +
$ CREALB*P( JR, JE-1 ) -
$ CRE2A*S( JR, JE ) + CRE2B*P( JR, JE )
WORK( 3*N+JR ) = -CIMAGA*S( JR, JE-1 ) +
$ CIMAGB*P( JR, JE-1 ) -
$ CIM2A*S( JR, JE ) + CIM2B*P( JR, JE )
270 CONTINUE
END IF
*
DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN )
*
* Columnwise triangular solve of (a A - b B) x = 0
*
IL2BY2 = .FALSE.
DO 370 J = JE - NW, 1, -1
*
* If a 2-by-2 block, is in position j-1:j, wait until
* next iteration to process it (when it will be j:j+1)
*
IF( .NOT.IL2BY2 .AND. J.GT.1 ) THEN
IF( S( J, J-1 ).NE.ZERO ) THEN
IL2BY2 = .TRUE.
GO TO 370
END IF
END IF
BDIAG( 1 ) = P( J, J )
IF( IL2BY2 ) THEN
NA = 2
BDIAG( 2 ) = P( J+1, J+1 )
ELSE
NA = 1
END IF
*
* Compute x(j) (and x(j+1), if 2-by-2 block)
*
CALL DLALN2( .FALSE., NA, NW, DMIN, ACOEF, S( J, J ),
$ LDS, BDIAG( 1 ), BDIAG( 2 ), WORK( 2*N+J ),
$ N, BCOEFR, BCOEFI, SUM, 2, SCALE, TEMP,
$ IINFO )
IF( SCALE.LT.ONE ) THEN
*
DO 290 JW = 0, NW - 1
DO 280 JR = 1, JE
WORK( ( JW+2 )*N+JR ) = SCALE*
$ WORK( ( JW+2 )*N+JR )
280 CONTINUE
290 CONTINUE
END IF
XMAX = MAX( SCALE*XMAX, TEMP )
*
DO 310 JW = 1, NW
DO 300 JA = 1, NA
WORK( ( JW+1 )*N+J+JA-1 ) = SUM( JA, JW )
300 CONTINUE
310 CONTINUE
*
* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling
*
IF( J.GT.1 ) THEN
*
* Check whether scaling is necessary for sum.
*
XSCALE = ONE / MAX( ONE, XMAX )
TEMP = ACOEFA*WORK( J ) + BCOEFA*WORK( N+J )
IF( IL2BY2 )
$ TEMP = MAX( TEMP, ACOEFA*WORK( J+1 )+BCOEFA*
$ WORK( N+J+1 ) )
TEMP = MAX( TEMP, ACOEFA, BCOEFA )
IF( TEMP.GT.BIGNUM*XSCALE ) THEN
*
DO 330 JW = 0, NW - 1
DO 320 JR = 1, JE
WORK( ( JW+2 )*N+JR ) = XSCALE*
$ WORK( ( JW+2 )*N+JR )
320 CONTINUE
330 CONTINUE
XMAX = XMAX*XSCALE
END IF
*
* Compute the contributions of the off-diagonals of
* column j (and j+1, if 2-by-2 block) of A and B to the
* sums.
*
*
DO 360 JA = 1, NA
IF( ILCPLX ) THEN
CREALA = ACOEF*WORK( 2*N+J+JA-1 )
CIMAGA = ACOEF*WORK( 3*N+J+JA-1 )
CREALB = BCOEFR*WORK( 2*N+J+JA-1 ) -
$ BCOEFI*WORK( 3*N+J+JA-1 )
CIMAGB = BCOEFI*WORK( 2*N+J+JA-1 ) +
$ BCOEFR*WORK( 3*N+J+JA-1 )
DO 340 JR = 1, J - 1
WORK( 2*N+JR ) = WORK( 2*N+JR ) -
$ CREALA*S( JR, J+JA-1 ) +
$ CREALB*P( JR, J+JA-1 )
WORK( 3*N+JR ) = WORK( 3*N+JR ) -
$ CIMAGA*S( JR, J+JA-1 ) +
$ CIMAGB*P( JR, J+JA-1 )
340 CONTINUE
ELSE
CREALA = ACOEF*WORK( 2*N+J+JA-1 )
CREALB = BCOEFR*WORK( 2*N+J+JA-1 )
DO 350 JR = 1, J - 1
WORK( 2*N+JR ) = WORK( 2*N+JR ) -
$ CREALA*S( JR, J+JA-1 ) +
$ CREALB*P( JR, J+JA-1 )
350 CONTINUE
END IF
360 CONTINUE
END IF
*
IL2BY2 = .FALSE.
370 CONTINUE
*
* Copy eigenvector to VR, back transforming if
* HOWMNY='B'.
*
IEIG = IEIG - NW
IF( ILBACK ) THEN
*
DO 410 JW = 0, NW - 1
DO 380 JR = 1, N
WORK( ( JW+4 )*N+JR ) = WORK( ( JW+2 )*N+1 )*
$ VR( JR, 1 )
380 CONTINUE
*
* A series of compiler directives to defeat
* vectorization for the next loop
*
*
DO 400 JC = 2, JE
DO 390 JR = 1, N
WORK( ( JW+4 )*N+JR ) = WORK( ( JW+4 )*N+JR ) +
$ WORK( ( JW+2 )*N+JC )*VR( JR, JC )
390 CONTINUE
400 CONTINUE
410 CONTINUE
*
DO 430 JW = 0, NW - 1
DO 420 JR = 1, N
VR( JR, IEIG+JW ) = WORK( ( JW+4 )*N+JR )
420 CONTINUE
430 CONTINUE
*
IEND = N
ELSE
DO 450 JW = 0, NW - 1
DO 440 JR = 1, N
VR( JR, IEIG+JW ) = WORK( ( JW+2 )*N+JR )
440 CONTINUE
450 CONTINUE
*
IEND = JE
END IF
*
* Scale eigenvector
*
XMAX = ZERO
IF( ILCPLX ) THEN
DO 460 J = 1, IEND
XMAX = MAX( XMAX, ABS( VR( J, IEIG ) )+
$ ABS( VR( J, IEIG+1 ) ) )
460 CONTINUE
ELSE
DO 470 J = 1, IEND
XMAX = MAX( XMAX, ABS( VR( J, IEIG ) ) )
470 CONTINUE
END IF
*
IF( XMAX.GT.SAFMIN ) THEN
XSCALE = ONE / XMAX
DO 490 JW = 0, NW - 1
DO 480 JR = 1, IEND
VR( JR, IEIG+JW ) = XSCALE*VR( JR, IEIG+JW )
480 CONTINUE
490 CONTINUE
END IF
500 CONTINUE
END IF
*
RETURN
*
* End of DTGEVC
*
END
SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
$ LDZ, J1, N1, N2, WORK, LWORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL WANTQ, WANTZ
INTEGER INFO, J1, LDA, LDB, LDQ, LDZ, LWORK, N, N1, N2
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
$ WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DTGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22)
* of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair
* (A, B) by an orthogonal equivalence transformation.
*
* (A, B) must be in generalized real Schur canonical form (as returned
* by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2
* diagonal blocks. B is upper triangular.
*
* Optionally, the matrices Q and Z of generalized Schur vectors are
* updated.
*
* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'
* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'
*
*
* Arguments
* =========
*
* WANTQ (input) LOGICAL
* .TRUE. : update the left transformation matrix Q;
* .FALSE.: do not update Q.
*
* WANTZ (input) LOGICAL
* .TRUE. : update the right transformation matrix Z;
* .FALSE.: do not update Z.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* A (input/output) DOUBLE PRECISION arrays, dimensions (LDA,N)
* On entry, the matrix A in the pair (A, B).
* On exit, the updated matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input/output) DOUBLE PRECISION arrays, dimensions (LDB,N)
* On entry, the matrix B in the pair (A, B).
* On exit, the updated matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* Q (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
* On entry, if WANTQ = .TRUE., the orthogonal matrix Q.
* On exit, the updated matrix Q.
* Not referenced if WANTQ = .FALSE..
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= 1.
* If WANTQ = .TRUE., LDQ >= N.
*
* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
* On entry, if WANTZ =.TRUE., the orthogonal matrix Z.
* On exit, the updated matrix Z.
* Not referenced if WANTZ = .FALSE..
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1.
* If WANTZ = .TRUE., LDZ >= N.
*
* J1 (input) INTEGER
* The index to the first block (A11, B11). 1 <= J1 <= N.
*
* N1 (input) INTEGER
* The order of the first block (A11, B11). N1 = 0, 1 or 2.
*
* N2 (input) INTEGER
* The order of the second block (A22, B22). N2 = 0, 1 or 2.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)).
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* LWORK >= MAX( 1, N*(N2+N1), (N2+N1)*(N2+N1)*2 )
*
* INFO (output) INTEGER
* =0: Successful exit
* >0: If INFO = 1, the transformed matrix (A, B) would be
* too far from generalized Schur form; the blocks are
* not swapped and (A, B) and (Q, Z) are unchanged.
* The problem of swapping is too ill-conditioned.
* <0: If INFO = -16: LWORK is too small. Appropriate value
* for LWORK is returned in WORK(1).
*
* Further Details
* ===============
*
* Based on contributions by
* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
* Umea University, S-901 87 Umea, Sweden.
*
* In the current code both weak and strong stability tests are
* performed. The user can omit the strong stability test by changing
* the internal logical parameter WANDS to .FALSE.. See ref. [2] for
* details.
*
* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
*
* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
* Eigenvalues of a Regular Matrix Pair (A, B) and Condition
* Estimation: Theory, Algorithms and Software,
* Report UMINF - 94.04, Department of Computing Science, Umea
* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working
* Note 87. To appear in Numerical Algorithms, 1996.
*
* =====================================================================
* Replaced various illegal calls to DCOPY by calls to DLASET, or by DO
* loops. Sven Hammarling, 1/5/02.
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION TEN
PARAMETER ( TEN = 1.0D+01 )
INTEGER LDST
PARAMETER ( LDST = 4 )
LOGICAL WANDS
PARAMETER ( WANDS = .TRUE. )
* ..
* .. Local Scalars ..
LOGICAL DTRONG, WEAK
INTEGER I, IDUM, LINFO, M
DOUBLE PRECISION BQRA21, BRQA21, DDUM, DNORM, DSCALE, DSUM, EPS,
$ F, G, SA, SB, SCALE, SMLNUM, SS, THRESH, WS
* ..
* .. Local Arrays ..
INTEGER IWORK( LDST )
DOUBLE PRECISION AI( 2 ), AR( 2 ), BE( 2 ), IR( LDST, LDST ),
$ IRCOP( LDST, LDST ), LI( LDST, LDST ),
$ LICOP( LDST, LDST ), S( LDST, LDST ),
$ SCPY( LDST, LDST ), T( LDST, LDST ),
$ TAUL( LDST ), TAUR( LDST ), TCPY( LDST, LDST )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DGEQR2, DGERQ2, DLACPY, DLAGV2, DLARTG,
$ DLASET, DLASSQ, DORG2R, DORGR2, DORM2R, DORMR2,
$ DROT, DSCAL, DTGSY2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Quick return if possible
*
IF( N.LE.1 .OR. N1.LE.0 .OR. N2.LE.0 )
$ RETURN
IF( N1.GT.N .OR. ( J1+N1 ).GT.N )
$ RETURN
M = N1 + N2
IF( LWORK.LT.MAX( 1, N*M, M*M*2 ) ) THEN
INFO = -16
WORK( 1 ) = MAX( 1, N*M, M*M*2 )
RETURN
END IF
*
WEAK = .FALSE.
DTRONG = .FALSE.
*
* Make a local copy of selected block
*
CALL DLASET( 'Full', LDST, LDST, ZERO, ZERO, LI, LDST )
CALL DLASET( 'Full', LDST, LDST, ZERO, ZERO, IR, LDST )
CALL DLACPY( 'Full', M, M, A( J1, J1 ), LDA, S, LDST )
CALL DLACPY( 'Full', M, M, B( J1, J1 ), LDB, T, LDST )
*
* Compute threshold for testing acceptance of swapping.
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' ) / EPS
DSCALE = ZERO
DSUM = ONE
CALL DLACPY( 'Full', M, M, S, LDST, WORK, M )
CALL DLASSQ( M*M, WORK, 1, DSCALE, DSUM )
CALL DLACPY( 'Full', M, M, T, LDST, WORK, M )
CALL DLASSQ( M*M, WORK, 1, DSCALE, DSUM )
DNORM = DSCALE*SQRT( DSUM )
THRESH = MAX( TEN*EPS*DNORM, SMLNUM )
*
IF( M.EQ.2 ) THEN
*
* CASE 1: Swap 1-by-1 and 1-by-1 blocks.
*
* Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks
* using Givens rotations and perform the swap tentatively.
*
F = S( 2, 2 )*T( 1, 1 ) - T( 2, 2 )*S( 1, 1 )
G = S( 2, 2 )*T( 1, 2 ) - T( 2, 2 )*S( 1, 2 )
SB = ABS( T( 2, 2 ) )
SA = ABS( S( 2, 2 ) )
CALL DLARTG( F, G, IR( 1, 2 ), IR( 1, 1 ), DDUM )
IR( 2, 1 ) = -IR( 1, 2 )
IR( 2, 2 ) = IR( 1, 1 )
CALL DROT( 2, S( 1, 1 ), 1, S( 1, 2 ), 1, IR( 1, 1 ),
$ IR( 2, 1 ) )
CALL DROT( 2, T( 1, 1 ), 1, T( 1, 2 ), 1, IR( 1, 1 ),
$ IR( 2, 1 ) )
IF( SA.GE.SB ) THEN
CALL DLARTG( S( 1, 1 ), S( 2, 1 ), LI( 1, 1 ), LI( 2, 1 ),
$ DDUM )
ELSE
CALL DLARTG( T( 1, 1 ), T( 2, 1 ), LI( 1, 1 ), LI( 2, 1 ),
$ DDUM )
END IF
CALL DROT( 2, S( 1, 1 ), LDST, S( 2, 1 ), LDST, LI( 1, 1 ),
$ LI( 2, 1 ) )
CALL DROT( 2, T( 1, 1 ), LDST, T( 2, 1 ), LDST, LI( 1, 1 ),
$ LI( 2, 1 ) )
LI( 2, 2 ) = LI( 1, 1 )
LI( 1, 2 ) = -LI( 2, 1 )
*
* Weak stability test:
* |S21| + |T21| <= O(EPS * F-norm((S, T)))
*
WS = ABS( S( 2, 1 ) ) + ABS( T( 2, 1 ) )
WEAK = WS.LE.THRESH
IF( .NOT.WEAK )
$ GO TO 70
*
IF( WANDS ) THEN
*
* Strong stability test:
* F-norm((A-QL'*S*QR, B-QL'*T*QR)) <= O(EPS*F-norm((A,B)))
*
CALL DLACPY( 'Full', M, M, A( J1, J1 ), LDA, WORK( M*M+1 ),
$ M )
CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO,
$ WORK, M )
CALL DGEMM( 'N', 'T', M, M, M, -ONE, WORK, M, IR, LDST, ONE,
$ WORK( M*M+1 ), M )
DSCALE = ZERO
DSUM = ONE
CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
*
CALL DLACPY( 'Full', M, M, B( J1, J1 ), LDB, WORK( M*M+1 ),
$ M )
CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO,
$ WORK, M )
CALL DGEMM( 'N', 'T', M, M, M, -ONE, WORK, M, IR, LDST, ONE,
$ WORK( M*M+1 ), M )
CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
SS = DSCALE*SQRT( DSUM )
DTRONG = SS.LE.THRESH
IF( .NOT.DTRONG )
$ GO TO 70
END IF
*
* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and
* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)).
*
CALL DROT( J1+1, A( 1, J1 ), 1, A( 1, J1+1 ), 1, IR( 1, 1 ),
$ IR( 2, 1 ) )
CALL DROT( J1+1, B( 1, J1 ), 1, B( 1, J1+1 ), 1, IR( 1, 1 ),
$ IR( 2, 1 ) )
CALL DROT( N-J1+1, A( J1, J1 ), LDA, A( J1+1, J1 ), LDA,
$ LI( 1, 1 ), LI( 2, 1 ) )
CALL DROT( N-J1+1, B( J1, J1 ), LDB, B( J1+1, J1 ), LDB,
$ LI( 1, 1 ), LI( 2, 1 ) )
*
* Set N1-by-N2 (2,1) - blocks to ZERO.
*
A( J1+1, J1 ) = ZERO
B( J1+1, J1 ) = ZERO
*
* Accumulate transformations into Q and Z if requested.
*
IF( WANTZ )
$ CALL DROT( N, Z( 1, J1 ), 1, Z( 1, J1+1 ), 1, IR( 1, 1 ),
$ IR( 2, 1 ) )
IF( WANTQ )
$ CALL DROT( N, Q( 1, J1 ), 1, Q( 1, J1+1 ), 1, LI( 1, 1 ),
$ LI( 2, 1 ) )
*
* Exit with INFO = 0 if swap was successfully performed.
*
RETURN
*
ELSE
*
* CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2
* and 2-by-2 blocks.
*
* Solve the generalized Sylvester equation
* S11 * R - L * S22 = SCALE * S12
* T11 * R - L * T22 = SCALE * T12
* for R and L. Solutions in LI and IR.
*
CALL DLACPY( 'Full', N1, N2, T( 1, N1+1 ), LDST, LI, LDST )
CALL DLACPY( 'Full', N1, N2, S( 1, N1+1 ), LDST,
$ IR( N2+1, N1+1 ), LDST )
CALL DTGSY2( 'N', 0, N1, N2, S, LDST, S( N1+1, N1+1 ), LDST,
$ IR( N2+1, N1+1 ), LDST, T, LDST, T( N1+1, N1+1 ),
$ LDST, LI, LDST, SCALE, DSUM, DSCALE, IWORK, IDUM,
$ LINFO )
*
* Compute orthogonal matrix QL:
*
* QL' * LI = [ TL ]
* [ 0 ]
* where
* LI = [ -L ]
* [ SCALE * identity(N2) ]
*
DO 10 I = 1, N2
CALL DSCAL( N1, -ONE, LI( 1, I ), 1 )
LI( N1+I, I ) = SCALE
10 CONTINUE
CALL DGEQR2( M, N2, LI, LDST, TAUL, WORK, LINFO )
IF( LINFO.NE.0 )
$ GO TO 70
CALL DORG2R( M, M, N2, LI, LDST, TAUL, WORK, LINFO )
IF( LINFO.NE.0 )
$ GO TO 70
*
* Compute orthogonal matrix RQ:
*
* IR * RQ' = [ 0 TR],
*
* where IR = [ SCALE * identity(N1), R ]
*
DO 20 I = 1, N1
IR( N2+I, I ) = SCALE
20 CONTINUE
CALL DGERQ2( N1, M, IR( N2+1, 1 ), LDST, TAUR, WORK, LINFO )
IF( LINFO.NE.0 )
$ GO TO 70
CALL DORGR2( M, M, N1, IR, LDST, TAUR, WORK, LINFO )
IF( LINFO.NE.0 )
$ GO TO 70
*
* Perform the swapping tentatively:
*
CALL DGEMM( 'T', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO,
$ WORK, M )
CALL DGEMM( 'N', 'T', M, M, M, ONE, WORK, M, IR, LDST, ZERO, S,
$ LDST )
CALL DGEMM( 'T', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO,
$ WORK, M )
CALL DGEMM( 'N', 'T', M, M, M, ONE, WORK, M, IR, LDST, ZERO, T,
$ LDST )
CALL DLACPY( 'F', M, M, S, LDST, SCPY, LDST )
CALL DLACPY( 'F', M, M, T, LDST, TCPY, LDST )
CALL DLACPY( 'F', M, M, IR, LDST, IRCOP, LDST )
CALL DLACPY( 'F', M, M, LI, LDST, LICOP, LDST )
*
* Triangularize the B-part by an RQ factorization.
* Apply transformation (from left) to A-part, giving S.
*
CALL DGERQ2( M, M, T, LDST, TAUR, WORK, LINFO )
IF( LINFO.NE.0 )
$ GO TO 70
CALL DORMR2( 'R', 'T', M, M, M, T, LDST, TAUR, S, LDST, WORK,
$ LINFO )
IF( LINFO.NE.0 )
$ GO TO 70
CALL DORMR2( 'L', 'N', M, M, M, T, LDST, TAUR, IR, LDST, WORK,
$ LINFO )
IF( LINFO.NE.0 )
$ GO TO 70
*
* Compute F-norm(S21) in BRQA21. (T21 is 0.)
*
DSCALE = ZERO
DSUM = ONE
DO 30 I = 1, N2
CALL DLASSQ( N1, S( N2+1, I ), 1, DSCALE, DSUM )
30 CONTINUE
BRQA21 = DSCALE*SQRT( DSUM )
*
* Triangularize the B-part by a QR factorization.
* Apply transformation (from right) to A-part, giving S.
*
CALL DGEQR2( M, M, TCPY, LDST, TAUL, WORK, LINFO )
IF( LINFO.NE.0 )
$ GO TO 70
CALL DORM2R( 'L', 'T', M, M, M, TCPY, LDST, TAUL, SCPY, LDST,
$ WORK, INFO )
CALL DORM2R( 'R', 'N', M, M, M, TCPY, LDST, TAUL, LICOP, LDST,
$ WORK, INFO )
IF( LINFO.NE.0 )
$ GO TO 70
*
* Compute F-norm(S21) in BQRA21. (T21 is 0.)
*
DSCALE = ZERO
DSUM = ONE
DO 40 I = 1, N2
CALL DLASSQ( N1, SCPY( N2+1, I ), 1, DSCALE, DSUM )
40 CONTINUE
BQRA21 = DSCALE*SQRT( DSUM )
*
* Decide which method to use.
* Weak stability test:
* F-norm(S21) <= O(EPS * F-norm((S, T)))
*
IF( BQRA21.LE.BRQA21 .AND. BQRA21.LE.THRESH ) THEN
CALL DLACPY( 'F', M, M, SCPY, LDST, S, LDST )
CALL DLACPY( 'F', M, M, TCPY, LDST, T, LDST )
CALL DLACPY( 'F', M, M, IRCOP, LDST, IR, LDST )
CALL DLACPY( 'F', M, M, LICOP, LDST, LI, LDST )
ELSE IF( BRQA21.GE.THRESH ) THEN
GO TO 70
END IF
*
* Set lower triangle of B-part to zero
*
CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, T(2,1), LDST )
*
IF( WANDS ) THEN
*
* Strong stability test:
* F-norm((A-QL*S*QR', B-QL*T*QR')) <= O(EPS*F-norm((A,B)))
*
CALL DLACPY( 'Full', M, M, A( J1, J1 ), LDA, WORK( M*M+1 ),
$ M )
CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO,
$ WORK, M )
CALL DGEMM( 'N', 'N', M, M, M, -ONE, WORK, M, IR, LDST, ONE,
$ WORK( M*M+1 ), M )
DSCALE = ZERO
DSUM = ONE
CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
*
CALL DLACPY( 'Full', M, M, B( J1, J1 ), LDB, WORK( M*M+1 ),
$ M )
CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO,
$ WORK, M )
CALL DGEMM( 'N', 'N', M, M, M, -ONE, WORK, M, IR, LDST, ONE,
$ WORK( M*M+1 ), M )
CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
SS = DSCALE*SQRT( DSUM )
DTRONG = ( SS.LE.THRESH )
IF( .NOT.DTRONG )
$ GO TO 70
*
END IF
*
* If the swap is accepted ("weakly" and "strongly"), apply the
* transformations and set N1-by-N2 (2,1)-block to zero.
*
CALL DLASET( 'Full', N1, N2, ZERO, ZERO, S(N2+1,1), LDST )
*
* copy back M-by-M diagonal block starting at index J1 of (A, B)
*
CALL DLACPY( 'F', M, M, S, LDST, A( J1, J1 ), LDA )
CALL DLACPY( 'F', M, M, T, LDST, B( J1, J1 ), LDB )
CALL DLASET( 'Full', LDST, LDST, ZERO, ZERO, T, LDST )
*
* Standardize existing 2-by-2 blocks.
*
DO 50 I = 1, M*M
WORK(I) = ZERO
50 CONTINUE
WORK( 1 ) = ONE
T( 1, 1 ) = ONE
IDUM = LWORK - M*M - 2
IF( N2.GT.1 ) THEN
CALL DLAGV2( A( J1, J1 ), LDA, B( J1, J1 ), LDB, AR, AI, BE,
$ WORK( 1 ), WORK( 2 ), T( 1, 1 ), T( 2, 1 ) )
WORK( M+1 ) = -WORK( 2 )
WORK( M+2 ) = WORK( 1 )
T( N2, N2 ) = T( 1, 1 )
T( 1, 2 ) = -T( 2, 1 )
END IF
WORK( M*M ) = ONE
T( M, M ) = ONE
*
IF( N1.GT.1 ) THEN
CALL DLAGV2( A( J1+N2, J1+N2 ), LDA, B( J1+N2, J1+N2 ), LDB,
$ TAUR, TAUL, WORK( M*M+1 ), WORK( N2*M+N2+1 ),
$ WORK( N2*M+N2+2 ), T( N2+1, N2+1 ),
$ T( M, M-1 ) )
WORK( M*M ) = WORK( N2*M+N2+1 )
WORK( M*M-1 ) = -WORK( N2*M+N2+2 )
T( M, M ) = T( N2+1, N2+1 )
T( M-1, M ) = -T( M, M-1 )
END IF
CALL DGEMM( 'T', 'N', N2, N1, N2, ONE, WORK, M, A( J1, J1+N2 ),
$ LDA, ZERO, WORK( M*M+1 ), N2 )
CALL DLACPY( 'Full', N2, N1, WORK( M*M+1 ), N2, A( J1, J1+N2 ),
$ LDA )
CALL DGEMM( 'T', 'N', N2, N1, N2, ONE, WORK, M, B( J1, J1+N2 ),
$ LDB, ZERO, WORK( M*M+1 ), N2 )
CALL DLACPY( 'Full', N2, N1, WORK( M*M+1 ), N2, B( J1, J1+N2 ),
$ LDB )
CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, WORK, M, ZERO,
$ WORK( M*M+1 ), M )
CALL DLACPY( 'Full', M, M, WORK( M*M+1 ), M, LI, LDST )
CALL DGEMM( 'N', 'N', N2, N1, N1, ONE, A( J1, J1+N2 ), LDA,
$ T( N2+1, N2+1 ), LDST, ZERO, WORK, N2 )
CALL DLACPY( 'Full', N2, N1, WORK, N2, A( J1, J1+N2 ), LDA )
CALL DGEMM( 'N', 'N', N2, N1, N1, ONE, B( J1, J1+N2 ), LDB,
$ T( N2+1, N2+1 ), LDST, ZERO, WORK, N2 )
CALL DLACPY( 'Full', N2, N1, WORK, N2, B( J1, J1+N2 ), LDB )
CALL DGEMM( 'T', 'N', M, M, M, ONE, IR, LDST, T, LDST, ZERO,
$ WORK, M )
CALL DLACPY( 'Full', M, M, WORK, M, IR, LDST )
*
* Accumulate transformations into Q and Z if requested.
*
IF( WANTQ ) THEN
CALL DGEMM( 'N', 'N', N, M, M, ONE, Q( 1, J1 ), LDQ, LI,
$ LDST, ZERO, WORK, N )
CALL DLACPY( 'Full', N, M, WORK, N, Q( 1, J1 ), LDQ )
*
END IF
*
IF( WANTZ ) THEN
CALL DGEMM( 'N', 'N', N, M, M, ONE, Z( 1, J1 ), LDZ, IR,
$ LDST, ZERO, WORK, N )
CALL DLACPY( 'Full', N, M, WORK, N, Z( 1, J1 ), LDZ )
*
END IF
*
* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and
* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)).
*
I = J1 + M
IF( I.LE.N ) THEN
CALL DGEMM( 'T', 'N', M, N-I+1, M, ONE, LI, LDST,
$ A( J1, I ), LDA, ZERO, WORK, M )
CALL DLACPY( 'Full', M, N-I+1, WORK, M, A( J1, I ), LDA )
CALL DGEMM( 'T', 'N', M, N-I+1, M, ONE, LI, LDST,
$ B( J1, I ), LDA, ZERO, WORK, M )
CALL DLACPY( 'Full', M, N-I+1, WORK, M, B( J1, I ), LDB )
END IF
I = J1 - 1
IF( I.GT.0 ) THEN
CALL DGEMM( 'N', 'N', I, M, M, ONE, A( 1, J1 ), LDA, IR,
$ LDST, ZERO, WORK, I )
CALL DLACPY( 'Full', I, M, WORK, I, A( 1, J1 ), LDA )
CALL DGEMM( 'N', 'N', I, M, M, ONE, B( 1, J1 ), LDB, IR,
$ LDST, ZERO, WORK, I )
CALL DLACPY( 'Full', I, M, WORK, I, B( 1, J1 ), LDB )
END IF
*
* Exit with INFO = 0 if swap was successfully performed.
*
RETURN
*
END IF
*
* Exit with INFO = 1 if swap was rejected.
*
70 CONTINUE
*
INFO = 1
RETURN
*
* End of DTGEX2
*
END
SUBROUTINE DTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
$ LDZ, IFST, ILST, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL WANTQ, WANTZ
INTEGER IFST, ILST, INFO, LDA, LDB, LDQ, LDZ, LWORK, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
$ WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DTGEXC reorders the generalized real Schur decomposition of a real
* matrix pair (A,B) using an orthogonal equivalence transformation
*
* (A, B) = Q * (A, B) * Z',
*
* so that the diagonal block of (A, B) with row index IFST is moved
* to row ILST.
*
* (A, B) must be in generalized real Schur canonical form (as returned
* by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2
* diagonal blocks. B is upper triangular.
*
* Optionally, the matrices Q and Z of generalized Schur vectors are
* updated.
*
* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'
* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'
*
*
* Arguments
* =========
*
* WANTQ (input) LOGICAL
* .TRUE. : update the left transformation matrix Q;
* .FALSE.: do not update Q.
*
* WANTZ (input) LOGICAL
* .TRUE. : update the right transformation matrix Z;
* .FALSE.: do not update Z.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the matrix A in generalized real Schur canonical
* form.
* On exit, the updated matrix A, again in generalized
* real Schur canonical form.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)
* On entry, the matrix B in generalized real Schur canonical
* form (A,B).
* On exit, the updated matrix B, again in generalized
* real Schur canonical form (A,B).
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* Q (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
* On entry, if WANTQ = .TRUE., the orthogonal matrix Q.
* On exit, the updated matrix Q.
* If WANTQ = .FALSE., Q is not referenced.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= 1.
* If WANTQ = .TRUE., LDQ >= N.
*
* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
* On entry, if WANTZ = .TRUE., the orthogonal matrix Z.
* On exit, the updated matrix Z.
* If WANTZ = .FALSE., Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1.
* If WANTZ = .TRUE., LDZ >= N.
*
* IFST (input/output) INTEGER
* ILST (input/output) INTEGER
* Specify the reordering of the diagonal blocks of (A, B).
* The block with row index IFST is moved to row ILST, by a
* sequence of swapping between adjacent blocks.
* On exit, if IFST pointed on entry to the second row of
* a 2-by-2 block, it is changed to point to the first row;
* ILST always points to the first row of the block in its
* final position (which may differ from its input value by
* +1 or -1). 1 <= IFST, ILST <= N.
*
* 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 >= 1 when N <= 1, otherwise LWORK >= 4*N + 16.
*
* 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.
* =1: The transformed matrix pair (A, B) would be too far
* from generalized Schur form; the problem is ill-
* conditioned. (A, B) may have been partially reordered,
* and ILST points to the first row of the current
* position of the block being moved.
*
* Further Details
* ===============
*
* Based on contributions by
* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
* Umea University, S-901 87 Umea, Sweden.
*
* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER HERE, LWMIN, NBF, NBL, NBNEXT
* ..
* .. External Subroutines ..
EXTERNAL DTGEX2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Decode and test input arguments.
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDQ.LT.1 .OR. WANTQ .AND. ( LDQ.LT.MAX( 1, N ) ) ) THEN
INFO = -9
ELSE IF( LDZ.LT.1 .OR. WANTZ .AND. ( LDZ.LT.MAX( 1, N ) ) ) THEN
INFO = -11
ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN
INFO = -12
ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN
INFO = -13
END IF
*
IF( INFO.EQ.0 ) THEN
IF( N.LE.1 ) THEN
LWMIN = 1
ELSE
LWMIN = 4*N + 16
END IF
WORK(1) = LWMIN
*
IF (LWORK.LT.LWMIN .AND. .NOT.LQUERY) THEN
INFO = -15
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTGEXC', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.1 )
$ RETURN
*
* Determine the first row of the specified block and find out
* if it is 1-by-1 or 2-by-2.
*
IF( IFST.GT.1 ) THEN
IF( A( IFST, IFST-1 ).NE.ZERO )
$ IFST = IFST - 1
END IF
NBF = 1
IF( IFST.LT.N ) THEN
IF( A( IFST+1, IFST ).NE.ZERO )
$ NBF = 2
END IF
*
* Determine the first row of the final block
* and find out if it is 1-by-1 or 2-by-2.
*
IF( ILST.GT.1 ) THEN
IF( A( ILST, ILST-1 ).NE.ZERO )
$ ILST = ILST - 1
END IF
NBL = 1
IF( ILST.LT.N ) THEN
IF( A( ILST+1, ILST ).NE.ZERO )
$ NBL = 2
END IF
IF( IFST.EQ.ILST )
$ RETURN
*
IF( IFST.LT.ILST ) THEN
*
* Update ILST.
*
IF( NBF.EQ.2 .AND. NBL.EQ.1 )
$ ILST = ILST - 1
IF( NBF.EQ.1 .AND. NBL.EQ.2 )
$ ILST = ILST + 1
*
HERE = IFST
*
10 CONTINUE
*
* Swap with next one below.
*
IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
*
* Current block either 1-by-1 or 2-by-2.
*
NBNEXT = 1
IF( HERE+NBF+1.LE.N ) THEN
IF( A( HERE+NBF+1, HERE+NBF ).NE.ZERO )
$ NBNEXT = 2
END IF
CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
$ LDZ, HERE, NBF, NBNEXT, WORK, LWORK, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
HERE = HERE + NBNEXT
*
* Test if 2-by-2 block breaks into two 1-by-1 blocks.
*
IF( NBF.EQ.2 ) THEN
IF( A( HERE+1, HERE ).EQ.ZERO )
$ NBF = 3
END IF
*
ELSE
*
* Current block consists of two 1-by-1 blocks, each of which
* must be swapped individually.
*
NBNEXT = 1
IF( HERE+3.LE.N ) THEN
IF( A( HERE+3, HERE+2 ).NE.ZERO )
$ NBNEXT = 2
END IF
CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
$ LDZ, HERE+1, 1, NBNEXT, WORK, LWORK, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
IF( NBNEXT.EQ.1 ) THEN
*
* Swap two 1-by-1 blocks.
*
CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
$ LDZ, HERE, 1, 1, WORK, LWORK, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
HERE = HERE + 1
*
ELSE
*
* Recompute NBNEXT in case of 2-by-2 split.
*
IF( A( HERE+2, HERE+1 ).EQ.ZERO )
$ NBNEXT = 1
IF( NBNEXT.EQ.2 ) THEN
*
* 2-by-2 block did not split.
*
CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
$ Z, LDZ, HERE, 1, NBNEXT, WORK, LWORK,
$ INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
HERE = HERE + 2
ELSE
*
* 2-by-2 block did split.
*
CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
$ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
HERE = HERE + 1
CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
$ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
HERE = HERE + 1
END IF
*
END IF
END IF
IF( HERE.LT.ILST )
$ GO TO 10
ELSE
HERE = IFST
*
20 CONTINUE
*
* Swap with next one below.
*
IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
*
* Current block either 1-by-1 or 2-by-2.
*
NBNEXT = 1
IF( HERE.GE.3 ) THEN
IF( A( HERE-1, HERE-2 ).NE.ZERO )
$ NBNEXT = 2
END IF
CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
$ LDZ, HERE-NBNEXT, NBNEXT, NBF, WORK, LWORK,
$ INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
HERE = HERE - NBNEXT
*
* Test if 2-by-2 block breaks into two 1-by-1 blocks.
*
IF( NBF.EQ.2 ) THEN
IF( A( HERE+1, HERE ).EQ.ZERO )
$ NBF = 3
END IF
*
ELSE
*
* Current block consists of two 1-by-1 blocks, each of which
* must be swapped individually.
*
NBNEXT = 1
IF( HERE.GE.3 ) THEN
IF( A( HERE-1, HERE-2 ).NE.ZERO )
$ NBNEXT = 2
END IF
CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
$ LDZ, HERE-NBNEXT, NBNEXT, 1, WORK, LWORK,
$ INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
IF( NBNEXT.EQ.1 ) THEN
*
* Swap two 1-by-1 blocks.
*
CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
$ LDZ, HERE, NBNEXT, 1, WORK, LWORK, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
HERE = HERE - 1
ELSE
*
* Recompute NBNEXT in case of 2-by-2 split.
*
IF( A( HERE, HERE-1 ).EQ.ZERO )
$ NBNEXT = 1
IF( NBNEXT.EQ.2 ) THEN
*
* 2-by-2 block did not split.
*
CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
$ Z, LDZ, HERE-1, 2, 1, WORK, LWORK, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
HERE = HERE - 2
ELSE
*
* 2-by-2 block did split.
*
CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
$ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
HERE = HERE - 1
CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
$ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
HERE = HERE - 1
END IF
END IF
END IF
IF( HERE.GT.ILST )
$ GO TO 20
END IF
ILST = HERE
WORK( 1 ) = LWMIN
RETURN
*
* End of DTGEXC
*
END
SUBROUTINE DTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB,
$ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, M, PL,
$ PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO )
*
* -- LAPACK routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* January 2007
*
* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
*
* .. Scalar Arguments ..
LOGICAL WANTQ, WANTZ
INTEGER IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK,
$ M, N
DOUBLE PRECISION PL, PR
* ..
* .. Array Arguments ..
LOGICAL SELECT( * )
INTEGER IWORK( * )
DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
$ B( LDB, * ), BETA( * ), DIF( * ), Q( LDQ, * ),
$ WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DTGSEN reorders the generalized real Schur decomposition of a real
* matrix pair (A, B) (in terms of an orthonormal equivalence trans-
* formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues
* appears in the leading diagonal blocks of the upper quasi-triangular
* matrix A and the upper triangular B. The leading columns of Q and
* Z form orthonormal bases of the corresponding left and right eigen-
* spaces (deflating subspaces). (A, B) must be in generalized real
* Schur canonical form (as returned by DGGES), i.e. A is block upper
* triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper
* triangular.
*
* DTGSEN also computes the generalized eigenvalues
*
* w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j)
*
* of the reordered matrix pair (A, B).
*
* Optionally, DTGSEN computes the estimates of reciprocal condition
* numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),
* (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)
* between the matrix pairs (A11, B11) and (A22,B22) that correspond to
* the selected cluster and the eigenvalues outside the cluster, resp.,
* and norms of "projections" onto left and right eigenspaces w.r.t.
* the selected cluster in the (1,1)-block.
*
* Arguments
* =========
*
* IJOB (input) INTEGER
* Specifies whether condition numbers are required for the
* cluster of eigenvalues (PL and PR) or the deflating subspaces
* (Difu and Difl):
* =0: Only reorder w.r.t. SELECT. No extras.
* =1: Reciprocal of norms of "projections" onto left and right
* eigenspaces w.r.t. the selected cluster (PL and PR).
* =2: Upper bounds on Difu and Difl. F-norm-based estimate
* (DIF(1:2)).
* =3: Estimate of Difu and Difl. 1-norm-based estimate
* (DIF(1:2)).
* About 5 times as expensive as IJOB = 2.
* =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic
* version to get it all.
* =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)
*
* WANTQ (input) LOGICAL
* .TRUE. : update the left transformation matrix Q;
* .FALSE.: do not update Q.
*
* WANTZ (input) LOGICAL
* .TRUE. : update the right transformation matrix Z;
* .FALSE.: do not update Z.
*
* SELECT (input) LOGICAL array, dimension (N)
* SELECT specifies the eigenvalues in the selected cluster.
* To select a real eigenvalue w(j), SELECT(j) must be set to
* .TRUE.. To select a complex conjugate pair of eigenvalues
* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,
* either SELECT(j) or SELECT(j+1) or both must be set to
* .TRUE.; a complex conjugate pair of eigenvalues must be
* either both included in the cluster or both excluded.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension(LDA,N)
* On entry, the upper quasi-triangular matrix A, with (A, B) in
* generalized real Schur canonical form.
* On exit, A is overwritten by the reordered matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input/output) DOUBLE PRECISION array, dimension(LDB,N)
* On entry, the upper triangular matrix B, with (A, B) in
* generalized real Schur canonical form.
* On exit, B is overwritten by the reordered matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* ALPHAR (output) DOUBLE PRECISION array, dimension (N)
* ALPHAI (output) DOUBLE PRECISION array, dimension (N)
* BETA (output) DOUBLE PRECISION array, dimension (N)
* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i
* and BETA(j),j=1,...,N are the diagonals of the complex Schur
* form (S,T) that would result if the 2-by-2 diagonal blocks of
* the real generalized Schur form of (A,B) were further reduced
* to triangular form using complex unitary transformations.
* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
* positive, then the j-th and (j+1)-st eigenvalues are a
* complex conjugate pair, with ALPHAI(j+1) negative.
*
* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
* On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.
* On exit, Q has been postmultiplied by the left orthogonal
* transformation matrix which reorder (A, B); The leading M
* columns of Q form orthonormal bases for the specified pair of
* left eigenspaces (deflating subspaces).
* If WANTQ = .FALSE., Q is not referenced.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= 1;
* and if WANTQ = .TRUE., LDQ >= N.
*
* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
* On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.
* On exit, Z has been postmultiplied by the left orthogonal
* transformation matrix which reorder (A, B); The leading M
* columns of Z form orthonormal bases for the specified pair of
* left eigenspaces (deflating subspaces).
* If WANTZ = .FALSE., Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1;
* If WANTZ = .TRUE., LDZ >= N.
*
* M (output) INTEGER
* The dimension of the specified pair of left and right eigen-
* spaces (deflating subspaces). 0 <= M <= N.
*
* PL (output) DOUBLE PRECISION
* PR (output) DOUBLE PRECISION
* If IJOB = 1, 4 or 5, PL, PR are lower bounds on the
* reciprocal of the norm of "projections" onto left and right
* eigenspaces with respect to the selected cluster.
* 0 < PL, PR <= 1.
* If M = 0 or M = N, PL = PR = 1.
* If IJOB = 0, 2 or 3, PL and PR are not referenced.
*
* DIF (output) DOUBLE PRECISION array, dimension (2).
* If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.
* If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on
* Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based
* estimates of Difu and Difl.
* If M = 0 or N, DIF(1:2) = F-norm([A, B]).
* If IJOB = 0 or 1, DIF is not referenced.
*
* 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 >= 4*N+16.
* If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)).
* If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)).
*
* 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.
*
* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
* IF IJOB = 0, IWORK is not referenced. Otherwise,
* on exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK. LIWORK >= 1.
* If IJOB = 1, 2 or 4, LIWORK >= N+6.
* If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6).
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal size of the IWORK array,
* returns this value as the first entry of the IWORK array, and
* no error message related to LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* =0: Successful exit.
* <0: If INFO = -i, the i-th argument had an illegal value.
* =1: Reordering of (A, B) failed because the transformed
* matrix pair (A, B) would be too far from generalized
* Schur form; the problem is very ill-conditioned.
* (A, B) may have been partially reordered.
* If requested, 0 is returned in DIF(*), PL and PR.
*
* Further Details
* ===============
*
* DTGSEN first collects the selected eigenvalues by computing
* orthogonal U and W that move them to the top left corner of (A, B).
* In other words, the selected eigenvalues are the eigenvalues of
* (A11, B11) in:
*
* U'*(A, B)*W = (A11 A12) (B11 B12) n1
* ( 0 A22),( 0 B22) n2
* n1 n2 n1 n2
*
* where N = n1+n2 and U' means the transpose of U. The first n1 columns
* of U and W span the specified pair of left and right eigenspaces
* (deflating subspaces) of (A, B).
*
* If (A, B) has been obtained from the generalized real Schur
* decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the
* reordered generalized real Schur form of (C, D) is given by
*
* (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',
*
* and the first n1 columns of Q*U and Z*W span the corresponding
* deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).
*
* Note that if the selected eigenvalue is sufficiently ill-conditioned,
* then its value may differ significantly from its value before
* reordering.
*
* The reciprocal condition numbers of the left and right eigenspaces
* spanned by the first n1 columns of U and W (or Q*U and Z*W) may
* be returned in DIF(1:2), corresponding to Difu and Difl, resp.
*
* The Difu and Difl are defined as:
*
* Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )
* and
* Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],
*
* where sigma-min(Zu) is the smallest singular value of the
* (2*n1*n2)-by-(2*n1*n2) matrix
*
* Zu = [ kron(In2, A11) -kron(A22', In1) ]
* [ kron(In2, B11) -kron(B22', In1) ].
*
* Here, Inx is the identity matrix of size nx and A22' is the
* transpose of A22. kron(X, Y) is the Kronecker product between
* the matrices X and Y.
*
* When DIF(2) is small, small changes in (A, B) can cause large changes
* in the deflating subspace. An approximate (asymptotic) bound on the
* maximum angular error in the computed deflating subspaces is
*
* EPS * norm((A, B)) / DIF(2),
*
* where EPS is the machine precision.
*
* The reciprocal norm of the projectors on the left and right
* eigenspaces associated with (A11, B11) may be returned in PL and PR.
* They are computed as follows. First we compute L and R so that
* P*(A, B)*Q is block diagonal, where
*
* P = ( I -L ) n1 Q = ( I R ) n1
* ( 0 I ) n2 and ( 0 I ) n2
* n1 n2 n1 n2
*
* and (L, R) is the solution to the generalized Sylvester equation
*
* A11*R - L*A22 = -A12
* B11*R - L*B22 = -B12
*
* Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).
* An approximate (asymptotic) bound on the average absolute error of
* the selected eigenvalues is
*
* EPS * norm((A, B)) / PL.
*
* There are also global error bounds which valid for perturbations up
* to a certain restriction: A lower bound (x) on the smallest
* F-norm(E,F) for which an eigenvalue of (A11, B11) may move and
* coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),
* (i.e. (A + E, B + F), is
*
* x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).
*
* An approximate bound on x can be computed from DIF(1:2), PL and PR.
*
* If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed
* (L', R') and unperturbed (L, R) left and right deflating subspaces
* associated with the selected cluster in the (1,1)-blocks can be
* bounded as
*
* max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))
* max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))
*
* See LAPACK User's Guide section 4.11 or the following references
* for more information.
*
* Note that if the default method for computing the Frobenius-norm-
* based estimate DIF is not wanted (see DLATDF), then the parameter
* IDIFJB (see below) should be changed from 3 to 4 (routine DLATDF
* (IJOB = 2 will be used)). See DTGSYL for more details.
*
* Based on contributions by
* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
* Umea University, S-901 87 Umea, Sweden.
*
* References
* ==========
*
* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
*
* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
* Eigenvalues of a Regular Matrix Pair (A, B) and Condition
* Estimation: Theory, Algorithms and Software,
* Report UMINF - 94.04, Department of Computing Science, Umea
* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working
* Note 87. To appear in Numerical Algorithms, 1996.
*
* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
* for Solving the Generalized Sylvester Equation and Estimating the
* Separation between Regular Matrix Pairs, Report UMINF - 93.23,
* Department of Computing Science, Umea University, S-901 87 Umea,
* Sweden, December 1993, Revised April 1994, Also as LAPACK Working
* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,
* 1996.
*
* =====================================================================
*
* .. Parameters ..
INTEGER IDIFJB
PARAMETER ( IDIFJB = 3 )
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, PAIR, SWAP, WANTD, WANTD1, WANTD2,
$ WANTP
INTEGER I, IERR, IJB, K, KASE, KK, KS, LIWMIN, LWMIN,
$ MN2, N1, N2
DOUBLE PRECISION DSCALE, DSUM, EPS, RDSCAL, SMLNUM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL DLACN2, DLACPY, DLAG2, DLASSQ, DTGEXC, DTGSYL,
$ XERBLA
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Decode and test the input parameters
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
IF( IJOB.LT.0 .OR. IJOB.GT.5 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
INFO = -14
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -16
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTGSEN', -INFO )
RETURN
END IF
*
* Get machine constants
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' ) / EPS
IERR = 0
*
WANTP = IJOB.EQ.1 .OR. IJOB.GE.4
WANTD1 = IJOB.EQ.2 .OR. IJOB.EQ.4
WANTD2 = IJOB.EQ.3 .OR. IJOB.EQ.5
WANTD = WANTD1 .OR. WANTD2
*
* Set M to the dimension of the specified pair of deflating
* subspaces.
*
M = 0
PAIR = .FALSE.
DO 10 K = 1, N
IF( PAIR ) THEN
PAIR = .FALSE.
ELSE
IF( K.LT.N ) THEN
IF( A( K+1, K ).EQ.ZERO ) THEN
IF( SELECT( K ) )
$ M = M + 1
ELSE
PAIR = .TRUE.
IF( SELECT( K ) .OR. SELECT( K+1 ) )
$ M = M + 2
END IF
ELSE
IF( SELECT( N ) )
$ M = M + 1
END IF
END IF
10 CONTINUE
*
IF( IJOB.EQ.1 .OR. IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN
LWMIN = MAX( 1, 4*N+16, 2*M*( N-M ) )
LIWMIN = MAX( 1, N+6 )
ELSE IF( IJOB.EQ.3 .OR. IJOB.EQ.5 ) THEN
LWMIN = MAX( 1, 4*N+16, 4*M*( N-M ) )
LIWMIN = MAX( 1, 2*M*( N-M ), N+6 )
ELSE
LWMIN = MAX( 1, 4*N+16 )
LIWMIN = 1
END IF
*
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -22
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -24
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTGSEN', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible.
*
IF( M.EQ.N .OR. M.EQ.0 ) THEN
IF( WANTP ) THEN
PL = ONE
PR = ONE
END IF
IF( WANTD ) THEN
DSCALE = ZERO
DSUM = ONE
DO 20 I = 1, N
CALL DLASSQ( N, A( 1, I ), 1, DSCALE, DSUM )
CALL DLASSQ( N, B( 1, I ), 1, DSCALE, DSUM )
20 CONTINUE
DIF( 1 ) = DSCALE*SQRT( DSUM )
DIF( 2 ) = DIF( 1 )
END IF
GO TO 60
END IF
*
* Collect the selected blocks at the top-left corner of (A, B).
*
KS = 0
PAIR = .FALSE.
DO 30 K = 1, N
IF( PAIR ) THEN
PAIR = .FALSE.
ELSE
*
SWAP = SELECT( K )
IF( K.LT.N ) THEN
IF( A( K+1, K ).NE.ZERO ) THEN
PAIR = .TRUE.
SWAP = SWAP .OR. SELECT( K+1 )
END IF
END IF
*
IF( SWAP ) THEN
KS = KS + 1
*
* Swap the K-th block to position KS.
* Perform the reordering of diagonal blocks in (A, B)
* by orthogonal transformation matrices and update
* Q and Z accordingly (if requested):
*
KK = K
IF( K.NE.KS )
$ CALL DTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
$ Z, LDZ, KK, KS, WORK, LWORK, IERR )
*
IF( IERR.GT.0 ) THEN
*
* Swap is rejected: exit.
*
INFO = 1
IF( WANTP ) THEN
PL = ZERO
PR = ZERO
END IF
IF( WANTD ) THEN
DIF( 1 ) = ZERO
DIF( 2 ) = ZERO
END IF
GO TO 60
END IF
*
IF( PAIR )
$ KS = KS + 1
END IF
END IF
30 CONTINUE
IF( WANTP ) THEN
*
* Solve generalized Sylvester equation for R and L
* and compute PL and PR.
*
N1 = M
N2 = N - M
I = N1 + 1
IJB = 0
CALL DLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 )
CALL DLACPY( 'Full', N1, N2, B( 1, I ), LDB, WORK( N1*N2+1 ),
$ N1 )
CALL DTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK,
$ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), N1,
$ DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ),
$ LWORK-2*N1*N2, IWORK, IERR )
*
* Estimate the reciprocal of norms of "projections" onto left
* and right eigenspaces.
*
RDSCAL = ZERO
DSUM = ONE
CALL DLASSQ( N1*N2, WORK, 1, RDSCAL, DSUM )
PL = RDSCAL*SQRT( DSUM )
IF( PL.EQ.ZERO ) THEN
PL = ONE
ELSE
PL = DSCALE / ( SQRT( DSCALE*DSCALE / PL+PL )*SQRT( PL ) )
END IF
RDSCAL = ZERO
DSUM = ONE
CALL DLASSQ( N1*N2, WORK( N1*N2+1 ), 1, RDSCAL, DSUM )
PR = RDSCAL*SQRT( DSUM )
IF( PR.EQ.ZERO ) THEN
PR = ONE
ELSE
PR = DSCALE / ( SQRT( DSCALE*DSCALE / PR+PR )*SQRT( PR ) )
END IF
END IF
*
IF( WANTD ) THEN
*
* Compute estimates of Difu and Difl.
*
IF( WANTD1 ) THEN
N1 = M
N2 = N - M
I = N1 + 1
IJB = IDIFJB
*
* Frobenius norm-based Difu-estimate.
*
CALL DTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK,
$ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ),
$ N1, DSCALE, DIF( 1 ), WORK( 2*N1*N2+1 ),
$ LWORK-2*N1*N2, IWORK, IERR )
*
* Frobenius norm-based Difl-estimate.
*
CALL DTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, WORK,
$ N2, B( I, I ), LDB, B, LDB, WORK( N1*N2+1 ),
$ N2, DSCALE, DIF( 2 ), WORK( 2*N1*N2+1 ),
$ LWORK-2*N1*N2, IWORK, IERR )
ELSE
*
*
* Compute 1-norm-based estimates of Difu and Difl using
* reversed communication with DLACN2. In each step a
* generalized Sylvester equation or a transposed variant
* is solved.
*
KASE = 0
N1 = M
N2 = N - M
I = N1 + 1
IJB = 0
MN2 = 2*N1*N2
*
* 1-norm-based estimate of Difu.
*
40 CONTINUE
CALL DLACN2( MN2, WORK( MN2+1 ), WORK, IWORK, DIF( 1 ),
$ KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Solve generalized Sylvester equation.
*
CALL DTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA,
$ WORK, N1, B, LDB, B( I, I ), LDB,
$ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ),
$ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
$ IERR )
ELSE
*
* Solve the transposed variant.
*
CALL DTGSYL( 'T', IJB, N1, N2, A, LDA, A( I, I ), LDA,
$ WORK, N1, B, LDB, B( I, I ), LDB,
$ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ),
$ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
$ IERR )
END IF
GO TO 40
END IF
DIF( 1 ) = DSCALE / DIF( 1 )
*
* 1-norm-based estimate of Difl.
*
50 CONTINUE
CALL DLACN2( MN2, WORK( MN2+1 ), WORK, IWORK, DIF( 2 ),
$ KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Solve generalized Sylvester equation.
*
CALL DTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA,
$ WORK, N2, B( I, I ), LDB, B, LDB,
$ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ),
$ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
$ IERR )
ELSE
*
* Solve the transposed variant.
*
CALL DTGSYL( 'T', IJB, N2, N1, A( I, I ), LDA, A, LDA,
$ WORK, N2, B( I, I ), LDB, B, LDB,
$ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ),
$ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
$ IERR )
END IF
GO TO 50
END IF
DIF( 2 ) = DSCALE / DIF( 2 )
*
END IF
END IF
*
60 CONTINUE
*
* Compute generalized eigenvalues of reordered pair (A, B) and
* normalize the generalized Schur form.
*
PAIR = .FALSE.
DO 80 K = 1, N
IF( PAIR ) THEN
PAIR = .FALSE.
ELSE
*
IF( K.LT.N ) THEN
IF( A( K+1, K ).NE.ZERO ) THEN
PAIR = .TRUE.
END IF
END IF
*
IF( PAIR ) THEN
*
* Compute the eigenvalue(s) at position K.
*
WORK( 1 ) = A( K, K )
WORK( 2 ) = A( K+1, K )
WORK( 3 ) = A( K, K+1 )
WORK( 4 ) = A( K+1, K+1 )
WORK( 5 ) = B( K, K )
WORK( 6 ) = B( K+1, K )
WORK( 7 ) = B( K, K+1 )
WORK( 8 ) = B( K+1, K+1 )
CALL DLAG2( WORK, 2, WORK( 5 ), 2, SMLNUM*EPS, BETA( K ),
$ BETA( K+1 ), ALPHAR( K ), ALPHAR( K+1 ),
$ ALPHAI( K ) )
ALPHAI( K+1 ) = -ALPHAI( K )
*
ELSE
*
IF( SIGN( ONE, B( K, K ) ).LT.ZERO ) THEN
*
* If B(K,K) is negative, make it positive
*
DO 70 I = 1, N
A( K, I ) = -A( K, I )
B( K, I ) = -B( K, I )
Q( I, K ) = -Q( I, K )
70 CONTINUE
END IF
*
ALPHAR( K ) = A( K, K )
ALPHAI( K ) = ZERO
BETA( K ) = B( K, K )
*
END IF
END IF
80 CONTINUE
*
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
RETURN
*
* End of DTGSEN
*
END
SUBROUTINE DTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B,
$ LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV,
$ Q, LDQ, WORK, NCYCLE, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBQ, JOBU, JOBV
INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N,
$ NCYCLE, P
DOUBLE PRECISION TOLA, TOLB
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), ALPHA( * ), B( LDB, * ),
$ BETA( * ), Q( LDQ, * ), U( LDU, * ),
$ V( LDV, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DTGSJA computes the generalized singular value decomposition (GSVD)
* of two real upper triangular (or trapezoidal) matrices A and B.
*
* On entry, it is assumed that matrices A and B have the following
* forms, which may be obtained by the preprocessing subroutine DGGSVP
* from a general M-by-N matrix A and P-by-N matrix B:
*
* N-K-L K L
* A = K ( 0 A12 A13 ) if M-K-L >= 0;
* L ( 0 0 A23 )
* M-K-L ( 0 0 0 )
*
* N-K-L K L
* A = K ( 0 A12 A13 ) if M-K-L < 0;
* M-K ( 0 0 A23 )
*
* N-K-L K L
* B = L ( 0 0 B13 )
* P-L ( 0 0 0 )
*
* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
* otherwise A23 is (M-K)-by-L upper trapezoidal.
*
* On exit,
*
* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ),
*
* where U, V and Q are orthogonal matrices, Z' denotes the transpose
* of Z, R is a nonsingular upper triangular matrix, and D1 and D2 are
* ``diagonal'' matrices, which are of the following structures:
*
* If M-K-L >= 0,
*
* K L
* D1 = K ( I 0 )
* L ( 0 C )
* M-K-L ( 0 0 )
*
* K L
* D2 = L ( 0 S )
* P-L ( 0 0 )
*
* N-K-L K L
* ( 0 R ) = K ( 0 R11 R12 ) K
* L ( 0 0 R22 ) L
*
* where
*
* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),
* S = diag( BETA(K+1), ... , BETA(K+L) ),
* C**2 + S**2 = I.
*
* R is stored in A(1:K+L,N-K-L+1:N) on exit.
*
* If M-K-L < 0,
*
* K M-K K+L-M
* D1 = K ( I 0 0 )
* M-K ( 0 C 0 )
*
* K M-K K+L-M
* D2 = M-K ( 0 S 0 )
* K+L-M ( 0 0 I )
* P-L ( 0 0 0 )
*
* N-K-L K M-K K+L-M
* ( 0 R ) = K ( 0 R11 R12 R13 )
* M-K ( 0 0 R22 R23 )
* K+L-M ( 0 0 0 R33 )
*
* where
* C = diag( ALPHA(K+1), ... , ALPHA(M) ),
* S = diag( BETA(K+1), ... , BETA(M) ),
* C**2 + S**2 = I.
*
* R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored
* ( 0 R22 R23 )
* in B(M-K+1:L,N+M-K-L+1:N) on exit.
*
* The computation of the orthogonal transformation matrices U, V or Q
* is optional. These matrices may either be formed explicitly, or they
* may be postmultiplied into input matrices U1, V1, or Q1.
*
* Arguments
* =========
*
* JOBU (input) CHARACTER*1
* = 'U': U must contain an orthogonal matrix U1 on entry, and
* the product U1*U is returned;
* = 'I': U is initialized to the unit matrix, and the
* orthogonal matrix U is returned;
* = 'N': U is not computed.
*
* JOBV (input) CHARACTER*1
* = 'V': V must contain an orthogonal matrix V1 on entry, and
* the product V1*V is returned;
* = 'I': V is initialized to the unit matrix, and the
* orthogonal matrix V is returned;
* = 'N': V is not computed.
*
* JOBQ (input) CHARACTER*1
* = 'Q': Q must contain an orthogonal matrix Q1 on entry, and
* the product Q1*Q is returned;
* = 'I': Q is initialized to the unit matrix, and the
* orthogonal matrix Q is returned;
* = 'N': Q is not computed.
*
* M (input) INTEGER
* The number of rows of the matrix A. M >= 0.
*
* P (input) INTEGER
* The number of rows of the matrix B. P >= 0.
*
* N (input) INTEGER
* The number of columns of the matrices A and B. N >= 0.
*
* K (input) INTEGER
* L (input) INTEGER
* K and L specify the subblocks in the input matrices A and B:
* A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,N-L+1:N)
* of A and B, whose GSVD is going to be computed by DTGSJA.
* See Further details.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular
* matrix R or part of R. See Purpose for details.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)
* On entry, the P-by-N matrix B.
* On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains
* a part of R. See Purpose for details.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,P).
*
* TOLA (input) DOUBLE PRECISION
* TOLB (input) DOUBLE PRECISION
* TOLA and TOLB are the convergence criteria for the Jacobi-
* Kogbetliantz iteration procedure. Generally, they are the
* same as used in the preprocessing step, say
* TOLA = max(M,N)*norm(A)*MAZHEPS,
* TOLB = max(P,N)*norm(B)*MAZHEPS.
*
* ALPHA (output) DOUBLE PRECISION array, dimension (N)
* BETA (output) DOUBLE PRECISION array, dimension (N)
* On exit, ALPHA and BETA contain the generalized singular
* value pairs of A and B;
* ALPHA(1:K) = 1,
* BETA(1:K) = 0,
* and if M-K-L >= 0,
* ALPHA(K+1:K+L) = diag(C),
* BETA(K+1:K+L) = diag(S),
* or if M-K-L < 0,
* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0
* BETA(K+1:M) = S, BETA(M+1:K+L) = 1.
* Furthermore, if K+L < N,
* ALPHA(K+L+1:N) = 0 and
* BETA(K+L+1:N) = 0.
*
* U (input/output) DOUBLE PRECISION array, dimension (LDU,M)
* On entry, if JOBU = 'U', U must contain a matrix U1 (usually
* the orthogonal matrix returned by DGGSVP).
* On exit,
* if JOBU = 'I', U contains the orthogonal matrix U;
* if JOBU = 'U', U contains the product U1*U.
* If JOBU = 'N', U is not referenced.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= max(1,M) if
* JOBU = 'U'; LDU >= 1 otherwise.
*
* V (input/output) DOUBLE PRECISION array, dimension (LDV,P)
* On entry, if JOBV = 'V', V must contain a matrix V1 (usually
* the orthogonal matrix returned by DGGSVP).
* On exit,
* if JOBV = 'I', V contains the orthogonal matrix V;
* if JOBV = 'V', V contains the product V1*V.
* If JOBV = 'N', V is not referenced.
*
* LDV (input) INTEGER
* The leading dimension of the array V. LDV >= max(1,P) if
* JOBV = 'V'; LDV >= 1 otherwise.
*
* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
* On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually
* the orthogonal matrix returned by DGGSVP).
* On exit,
* if JOBQ = 'I', Q contains the orthogonal matrix Q;
* if JOBQ = 'Q', Q contains the product Q1*Q.
* If JOBQ = 'N', Q is not referenced.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N) if
* JOBQ = 'Q'; LDQ >= 1 otherwise.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
*
* NCYCLE (output) INTEGER
* The number of cycles required for convergence.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* = 1: the procedure does not converge after MAXIT cycles.
*
* Internal Parameters
* ===================
*
* MAXIT INTEGER
* MAXIT specifies the total loops that the iterative procedure
* may take. If after MAXIT cycles, the routine fails to
* converge, we return INFO = 1.
*
* Further Details
* ===============
*
* DTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce
* min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L
* matrix B13 to the form:
*
* U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1,
*
* where U1, V1 and Q1 are orthogonal matrix, and Z' is the transpose
* of Z. C1 and S1 are diagonal matrices satisfying
*
* C1**2 + S1**2 = I,
*
* and R1 is an L-by-L nonsingular upper triangular matrix.
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXIT
PARAMETER ( MAXIT = 40 )
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
*
LOGICAL INITQ, INITU, INITV, UPPER, WANTQ, WANTU, WANTV
INTEGER I, J, KCYCLE
DOUBLE PRECISION A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, ERROR,
$ GAMMA, RWK, SNQ, SNU, SNV, SSMIN
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLAGS2, DLAPLL, DLARTG, DLASET, DROT,
$ DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Decode and test the input parameters
*
INITU = LSAME( JOBU, 'I' )
WANTU = INITU .OR. LSAME( JOBU, 'U' )
*
INITV = LSAME( JOBV, 'I' )
WANTV = INITV .OR. LSAME( JOBV, 'V' )
*
INITQ = LSAME( JOBQ, 'I' )
WANTQ = INITQ .OR. LSAME( JOBQ, 'Q' )
*
INFO = 0
IF( .NOT.( INITU .OR. WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( INITV .OR. WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN
INFO = -2
ELSE IF( .NOT.( INITQ .OR. WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN
INFO = -3
ELSE IF( M.LT.0 ) THEN
INFO = -4
ELSE IF( P.LT.0 ) THEN
INFO = -5
ELSE IF( N.LT.0 ) THEN
INFO = -6
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -10
ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
INFO = -12
ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN
INFO = -18
ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN
INFO = -20
ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
INFO = -22
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTGSJA', -INFO )
RETURN
END IF
*
* Initialize U, V and Q, if necessary
*
IF( INITU )
$ CALL DLASET( 'Full', M, M, ZERO, ONE, U, LDU )
IF( INITV )
$ CALL DLASET( 'Full', P, P, ZERO, ONE, V, LDV )
IF( INITQ )
$ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
*
* Loop until convergence
*
UPPER = .FALSE.
DO 40 KCYCLE = 1, MAXIT
*
UPPER = .NOT.UPPER
*
DO 20 I = 1, L - 1
DO 10 J = I + 1, L
*
A1 = ZERO
A2 = ZERO
A3 = ZERO
IF( K+I.LE.M )
$ A1 = A( K+I, N-L+I )
IF( K+J.LE.M )
$ A3 = A( K+J, N-L+J )
*
B1 = B( I, N-L+I )
B3 = B( J, N-L+J )
*
IF( UPPER ) THEN
IF( K+I.LE.M )
$ A2 = A( K+I, N-L+J )
B2 = B( I, N-L+J )
ELSE
IF( K+J.LE.M )
$ A2 = A( K+J, N-L+I )
B2 = B( J, N-L+I )
END IF
*
CALL DLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU,
$ CSV, SNV, CSQ, SNQ )
*
* Update (K+I)-th and (K+J)-th rows of matrix A: U'*A
*
IF( K+J.LE.M )
$ CALL DROT( L, A( K+J, N-L+1 ), LDA, A( K+I, N-L+1 ),
$ LDA, CSU, SNU )
*
* Update I-th and J-th rows of matrix B: V'*B
*
CALL DROT( L, B( J, N-L+1 ), LDB, B( I, N-L+1 ), LDB,
$ CSV, SNV )
*
* Update (N-L+I)-th and (N-L+J)-th columns of matrices
* A and B: A*Q and B*Q
*
CALL DROT( MIN( K+L, M ), A( 1, N-L+J ), 1,
$ A( 1, N-L+I ), 1, CSQ, SNQ )
*
CALL DROT( L, B( 1, N-L+J ), 1, B( 1, N-L+I ), 1, CSQ,
$ SNQ )
*
IF( UPPER ) THEN
IF( K+I.LE.M )
$ A( K+I, N-L+J ) = ZERO
B( I, N-L+J ) = ZERO
ELSE
IF( K+J.LE.M )
$ A( K+J, N-L+I ) = ZERO
B( J, N-L+I ) = ZERO
END IF
*
* Update orthogonal matrices U, V, Q, if desired.
*
IF( WANTU .AND. K+J.LE.M )
$ CALL DROT( M, U( 1, K+J ), 1, U( 1, K+I ), 1, CSU,
$ SNU )
*
IF( WANTV )
$ CALL DROT( P, V( 1, J ), 1, V( 1, I ), 1, CSV, SNV )
*
IF( WANTQ )
$ CALL DROT( N, Q( 1, N-L+J ), 1, Q( 1, N-L+I ), 1, CSQ,
$ SNQ )
*
10 CONTINUE
20 CONTINUE
*
IF( .NOT.UPPER ) THEN
*
* The matrices A13 and B13 were lower triangular at the start
* of the cycle, and are now upper triangular.
*
* Convergence test: test the parallelism of the corresponding
* rows of A and B.
*
ERROR = ZERO
DO 30 I = 1, MIN( L, M-K )
CALL DCOPY( L-I+1, A( K+I, N-L+I ), LDA, WORK, 1 )
CALL DCOPY( L-I+1, B( I, N-L+I ), LDB, WORK( L+1 ), 1 )
CALL DLAPLL( L-I+1, WORK, 1, WORK( L+1 ), 1, SSMIN )
ERROR = MAX( ERROR, SSMIN )
30 CONTINUE
*
IF( ABS( ERROR ).LE.MIN( TOLA, TOLB ) )
$ GO TO 50
END IF
*
* End of cycle loop
*
40 CONTINUE
*
* The algorithm has not converged after MAXIT cycles.
*
INFO = 1
GO TO 100
*
50 CONTINUE
*
* If ERROR <= MIN(TOLA,TOLB), then the algorithm has converged.
* Compute the generalized singular value pairs (ALPHA, BETA), and
* set the triangular matrix R to array A.
*
DO 60 I = 1, K
ALPHA( I ) = ONE
BETA( I ) = ZERO
60 CONTINUE
*
DO 70 I = 1, MIN( L, M-K )
*
A1 = A( K+I, N-L+I )
B1 = B( I, N-L+I )
*
IF( A1.NE.ZERO ) THEN
GAMMA = B1 / A1
*
* change sign if necessary
*
IF( GAMMA.LT.ZERO ) THEN
CALL DSCAL( L-I+1, -ONE, B( I, N-L+I ), LDB )
IF( WANTV )
$ CALL DSCAL( P, -ONE, V( 1, I ), 1 )
END IF
*
CALL DLARTG( ABS( GAMMA ), ONE, BETA( K+I ), ALPHA( K+I ),
$ RWK )
*
IF( ALPHA( K+I ).GE.BETA( K+I ) ) THEN
CALL DSCAL( L-I+1, ONE / ALPHA( K+I ), A( K+I, N-L+I ),
$ LDA )
ELSE
CALL DSCAL( L-I+1, ONE / BETA( K+I ), B( I, N-L+I ),
$ LDB )
CALL DCOPY( L-I+1, B( I, N-L+I ), LDB, A( K+I, N-L+I ),
$ LDA )
END IF
*
ELSE
*
ALPHA( K+I ) = ZERO
BETA( K+I ) = ONE
CALL DCOPY( L-I+1, B( I, N-L+I ), LDB, A( K+I, N-L+I ),
$ LDA )
*
END IF
*
70 CONTINUE
*
* Post-assignment
*
DO 80 I = M + 1, K + L
ALPHA( I ) = ZERO
BETA( I ) = ONE
80 CONTINUE
*
IF( K+L.LT.N ) THEN
DO 90 I = K + L + 1, N
ALPHA( I ) = ZERO
BETA( I ) = ZERO
90 CONTINUE
END IF
*
100 CONTINUE
NCYCLE = KCYCLE
RETURN
*
* End of DTGSJA
*
END
SUBROUTINE DTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL,
$ LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK,
$ IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER HOWMNY, JOB
INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, M, MM, N
* ..
* .. Array Arguments ..
LOGICAL SELECT( * )
INTEGER IWORK( * )
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DIF( * ), S( * ),
$ VL( LDVL, * ), VR( LDVR, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DTGSNA estimates reciprocal condition numbers for specified
* eigenvalues and/or eigenvectors of a matrix pair (A, B) in
* generalized real Schur canonical form (or of any matrix pair
* (Q*A*Z', Q*B*Z') with orthogonal matrices Q and Z, where
* Z' denotes the transpose of Z.
*
* (A, B) must be in generalized real Schur form (as returned by DGGES),
* i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal
* blocks. B is upper triangular.
*
*
* Arguments
* =========
*
* JOB (input) CHARACTER*1
* Specifies whether condition numbers are required for
* eigenvalues (S) or eigenvectors (DIF):
* = 'E': for eigenvalues only (S);
* = 'V': for eigenvectors only (DIF);
* = 'B': for both eigenvalues and eigenvectors (S and DIF).
*
* HOWMNY (input) CHARACTER*1
* = 'A': compute condition numbers for all eigenpairs;
* = 'S': compute condition numbers for selected eigenpairs
* specified by the array SELECT.
*
* SELECT (input) LOGICAL array, dimension (N)
* If HOWMNY = 'S', SELECT specifies the eigenpairs for which
* condition numbers are required. To select condition numbers
* for the eigenpair corresponding to a real eigenvalue w(j),
* SELECT(j) must be set to .TRUE.. To select condition numbers
* corresponding to a complex conjugate pair of eigenvalues w(j)
* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be
* set to .TRUE..
* If HOWMNY = 'A', SELECT is not referenced.
*
* N (input) INTEGER
* The order of the square matrix pair (A, B). N >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The upper quasi-triangular matrix A in the pair (A,B).
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input) DOUBLE PRECISION array, dimension (LDB,N)
* The upper triangular matrix B in the pair (A,B).
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* VL (input) DOUBLE PRECISION array, dimension (LDVL,M)
* If JOB = 'E' or 'B', VL must contain left eigenvectors of
* (A, B), corresponding to the eigenpairs specified by HOWMNY
* and SELECT. The eigenvectors must be stored in consecutive
* columns of VL, as returned by DTGEVC.
* If JOB = 'V', VL is not referenced.
*
* LDVL (input) INTEGER
* The leading dimension of the array VL. LDVL >= 1.
* If JOB = 'E' or 'B', LDVL >= N.
*
* VR (input) DOUBLE PRECISION array, dimension (LDVR,M)
* If JOB = 'E' or 'B', VR must contain right eigenvectors of
* (A, B), corresponding to the eigenpairs specified by HOWMNY
* and SELECT. The eigenvectors must be stored in consecutive
* columns ov VR, as returned by DTGEVC.
* If JOB = 'V', VR is not referenced.
*
* LDVR (input) INTEGER
* The leading dimension of the array VR. LDVR >= 1.
* If JOB = 'E' or 'B', LDVR >= N.
*
* S (output) DOUBLE PRECISION array, dimension (MM)
* If JOB = 'E' or 'B', the reciprocal condition numbers of the
* selected eigenvalues, stored in consecutive elements of the
* array. For a complex conjugate pair of eigenvalues two
* consecutive elements of S are set to the same value. Thus
* S(j), DIF(j), and the j-th columns of VL and VR all
* correspond to the same eigenpair (but not in general the
* j-th eigenpair, unless all eigenpairs are selected).
* If JOB = 'V', S is not referenced.
*
* DIF (output) DOUBLE PRECISION array, dimension (MM)
* If JOB = 'V' or 'B', the estimated reciprocal condition
* numbers of the selected eigenvectors, stored in consecutive
* elements of the array. For a complex eigenvector two
* consecutive elements of DIF are set to the same value. If
* the eigenvalues cannot be reordered to compute DIF(j), DIF(j)
* is set to 0; this can only occur when the true value would be
* very small anyway.
* If JOB = 'E', DIF is not referenced.
*
* MM (input) INTEGER
* The number of elements in the arrays S and DIF. MM >= M.
*
* M (output) INTEGER
* The number of elements of the arrays S and DIF used to store
* the specified condition numbers; for each selected real
* eigenvalue one element is used, and for each selected complex
* conjugate pair of eigenvalues, two elements are used.
* If HOWMNY = 'A', M is set to N.
*
* 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).
* If JOB = 'V' or 'B' LWORK >= 2*N*(N+2)+16.
*
* 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.
*
* IWORK (workspace) INTEGER array, dimension (N + 6)
* If JOB = 'E', IWORK is not referenced.
*
* INFO (output) INTEGER
* =0: Successful exit
* <0: If INFO = -i, the i-th argument had an illegal value
*
*
* Further Details
* ===============
*
* The reciprocal of the condition number of a generalized eigenvalue
* w = (a, b) is defined as
*
* S(w) = (|u'Av|**2 + |u'Bv|**2)**(1/2) / (norm(u)*norm(v))
*
* where u and v are the left and right eigenvectors of (A, B)
* corresponding to w; |z| denotes the absolute value of the complex
* number, and norm(u) denotes the 2-norm of the vector u.
* The pair (a, b) corresponds to an eigenvalue w = a/b (= u'Av/u'Bv)
* of the matrix pair (A, B). If both a and b equal zero, then (A B) is
* singular and S(I) = -1 is returned.
*
* An approximate error bound on the chordal distance between the i-th
* computed generalized eigenvalue w and the corresponding exact
* eigenvalue lambda is
*
* chord(w, lambda) <= EPS * norm(A, B) / S(I)
*
* where EPS is the machine precision.
*
* The reciprocal of the condition number DIF(i) of right eigenvector u
* and left eigenvector v corresponding to the generalized eigenvalue w
* is defined as follows:
*
* a) If the i-th eigenvalue w = (a,b) is real
*
* Suppose U and V are orthogonal transformations such that
*
* U'*(A, B)*V = (S, T) = ( a * ) ( b * ) 1
* ( 0 S22 ),( 0 T22 ) n-1
* 1 n-1 1 n-1
*
* Then the reciprocal condition number DIF(i) is
*
* Difl((a, b), (S22, T22)) = sigma-min( Zl ),
*
* where sigma-min(Zl) denotes the smallest singular value of the
* 2(n-1)-by-2(n-1) matrix
*
* Zl = [ kron(a, In-1) -kron(1, S22) ]
* [ kron(b, In-1) -kron(1, T22) ] .
*
* Here In-1 is the identity matrix of size n-1. kron(X, Y) is the
* Kronecker product between the matrices X and Y.
*
* Note that if the default method for computing DIF(i) is wanted
* (see DLATDF), then the parameter DIFDRI (see below) should be
* changed from 3 to 4 (routine DLATDF(IJOB = 2 will be used)).
* See DTGSYL for more details.
*
* b) If the i-th and (i+1)-th eigenvalues are complex conjugate pair,
*
* Suppose U and V are orthogonal transformations such that
*
* U'*(A, B)*V = (S, T) = ( S11 * ) ( T11 * ) 2
* ( 0 S22 ),( 0 T22) n-2
* 2 n-2 2 n-2
*
* and (S11, T11) corresponds to the complex conjugate eigenvalue
* pair (w, conjg(w)). There exist unitary matrices U1 and V1 such
* that
*
* U1'*S11*V1 = ( s11 s12 ) and U1'*T11*V1 = ( t11 t12 )
* ( 0 s22 ) ( 0 t22 )
*
* where the generalized eigenvalues w = s11/t11 and
* conjg(w) = s22/t22.
*
* Then the reciprocal condition number DIF(i) is bounded by
*
* min( d1, max( 1, |real(s11)/real(s22)| )*d2 )
*
* where, d1 = Difl((s11, t11), (s22, t22)) = sigma-min(Z1), where
* Z1 is the complex 2-by-2 matrix
*
* Z1 = [ s11 -s22 ]
* [ t11 -t22 ],
*
* This is done by computing (using real arithmetic) the
* roots of the characteristical polynomial det(Z1' * Z1 - lambda I),
* where Z1' denotes the conjugate transpose of Z1 and det(X) denotes
* the determinant of X.
*
* and d2 is an upper bound on Difl((S11, T11), (S22, T22)), i.e. an
* upper bound on sigma-min(Z2), where Z2 is (2n-2)-by-(2n-2)
*
* Z2 = [ kron(S11', In-2) -kron(I2, S22) ]
* [ kron(T11', In-2) -kron(I2, T22) ]
*
* Note that if the default method for computing DIF is wanted (see
* DLATDF), then the parameter DIFDRI (see below) should be changed
* from 3 to 4 (routine DLATDF(IJOB = 2 will be used)). See DTGSYL
* for more details.
*
* For each eigenvalue/vector specified by SELECT, DIF stores a
* Frobenius norm-based estimate of Difl.
*
* An approximate error bound for the i-th computed eigenvector VL(i) or
* VR(i) is given by
*
* EPS * norm(A, B) / DIF(i).
*
* See ref. [2-3] for more details and further references.
*
* Based on contributions by
* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
* Umea University, S-901 87 Umea, Sweden.
*
* References
* ==========
*
* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
*
* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
* Eigenvalues of a Regular Matrix Pair (A, B) and Condition
* Estimation: Theory, Algorithms and Software,
* Report UMINF - 94.04, Department of Computing Science, Umea
* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working
* Note 87. To appear in Numerical Algorithms, 1996.
*
* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
* for Solving the Generalized Sylvester Equation and Estimating the
* Separation between Regular Matrix Pairs, Report UMINF - 93.23,
* Department of Computing Science, Umea University, S-901 87 Umea,
* Sweden, December 1993, Revised April 1994, Also as LAPACK Working
* Note 75. To appear in ACM Trans. on Math. Software, Vol 22,
* No 1, 1996.
*
* =====================================================================
*
* .. Parameters ..
INTEGER DIFDRI
PARAMETER ( DIFDRI = 3 )
DOUBLE PRECISION ZERO, ONE, TWO, FOUR
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0,
$ FOUR = 4.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, PAIR, SOMCON, WANTBH, WANTDF, WANTS
INTEGER I, IERR, IFST, ILST, IZ, K, KS, LWMIN, N1, N2
DOUBLE PRECISION ALPHAI, ALPHAR, ALPRQT, BETA, C1, C2, COND,
$ EPS, LNRM, RNRM, ROOT1, ROOT2, SCALE, SMLNUM,
$ TMPII, TMPIR, TMPRI, TMPRR, UHAV, UHAVI, UHBV,
$ UHBVI
* ..
* .. Local Arrays ..
DOUBLE PRECISION DUMMY( 1 ), DUMMY1( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DDOT, DLAMCH, DLAPY2, DNRM2
EXTERNAL LSAME, DDOT, DLAMCH, DLAPY2, DNRM2
* ..
* .. External Subroutines ..
EXTERNAL DGEMV, DLACPY, DLAG2, DTGEXC, DTGSYL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Decode and test the input parameters
*
WANTBH = LSAME( JOB, 'B' )
WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
WANTDF = LSAME( JOB, 'V' ) .OR. WANTBH
*
SOMCON = LSAME( HOWMNY, 'S' )
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
*
IF( .NOT.WANTS .AND. .NOT.WANTDF ) THEN
INFO = -1
ELSE IF( .NOT.LSAME( HOWMNY, 'A' ) .AND. .NOT.SOMCON ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( WANTS .AND. LDVL.LT.N ) THEN
INFO = -10
ELSE IF( WANTS .AND. LDVR.LT.N ) THEN
INFO = -12
ELSE
*
* Set M to the number of eigenpairs for which condition numbers
* are required, and test MM.
*
IF( SOMCON ) THEN
M = 0
PAIR = .FALSE.
DO 10 K = 1, N
IF( PAIR ) THEN
PAIR = .FALSE.
ELSE
IF( K.LT.N ) THEN
IF( A( K+1, K ).EQ.ZERO ) THEN
IF( SELECT( K ) )
$ M = M + 1
ELSE
PAIR = .TRUE.
IF( SELECT( K ) .OR. SELECT( K+1 ) )
$ M = M + 2
END IF
ELSE
IF( SELECT( N ) )
$ M = M + 1
END IF
END IF
10 CONTINUE
ELSE
M = N
END IF
*
IF( N.EQ.0 ) THEN
LWMIN = 1
ELSE IF( LSAME( JOB, 'V' ) .OR. LSAME( JOB, 'B' ) ) THEN
LWMIN = 2*N*( N + 2 ) + 16
ELSE
LWMIN = N
END IF
WORK( 1 ) = LWMIN
*
IF( MM.LT.M ) THEN
INFO = -15
ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -18
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTGSNA', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Get machine constants
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' ) / EPS
KS = 0
PAIR = .FALSE.
*
DO 20 K = 1, N
*
* Determine whether A(k,k) begins a 1-by-1 or 2-by-2 block.
*
IF( PAIR ) THEN
PAIR = .FALSE.
GO TO 20
ELSE
IF( K.LT.N )
$ PAIR = A( K+1, K ).NE.ZERO
END IF
*
* Determine whether condition numbers are required for the k-th
* eigenpair.
*
IF( SOMCON ) THEN
IF( PAIR ) THEN
IF( .NOT.SELECT( K ) .AND. .NOT.SELECT( K+1 ) )
$ GO TO 20
ELSE
IF( .NOT.SELECT( K ) )
$ GO TO 20
END IF
END IF
*
KS = KS + 1
*
IF( WANTS ) THEN
*
* Compute the reciprocal condition number of the k-th
* eigenvalue.
*
IF( PAIR ) THEN
*
* Complex eigenvalue pair.
*
RNRM = DLAPY2( DNRM2( N, VR( 1, KS ), 1 ),
$ DNRM2( N, VR( 1, KS+1 ), 1 ) )
LNRM = DLAPY2( DNRM2( N, VL( 1, KS ), 1 ),
$ DNRM2( N, VL( 1, KS+1 ), 1 ) )
CALL DGEMV( 'N', N, N, ONE, A, LDA, VR( 1, KS ), 1, ZERO,
$ WORK, 1 )
TMPRR = DDOT( N, WORK, 1, VL( 1, KS ), 1 )
TMPRI = DDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
CALL DGEMV( 'N', N, N, ONE, A, LDA, VR( 1, KS+1 ), 1,
$ ZERO, WORK, 1 )
TMPII = DDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
TMPIR = DDOT( N, WORK, 1, VL( 1, KS ), 1 )
UHAV = TMPRR + TMPII
UHAVI = TMPIR - TMPRI
CALL DGEMV( 'N', N, N, ONE, B, LDB, VR( 1, KS ), 1, ZERO,
$ WORK, 1 )
TMPRR = DDOT( N, WORK, 1, VL( 1, KS ), 1 )
TMPRI = DDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
CALL DGEMV( 'N', N, N, ONE, B, LDB, VR( 1, KS+1 ), 1,
$ ZERO, WORK, 1 )
TMPII = DDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
TMPIR = DDOT( N, WORK, 1, VL( 1, KS ), 1 )
UHBV = TMPRR + TMPII
UHBVI = TMPIR - TMPRI
UHAV = DLAPY2( UHAV, UHAVI )
UHBV = DLAPY2( UHBV, UHBVI )
COND = DLAPY2( UHAV, UHBV )
S( KS ) = COND / ( RNRM*LNRM )
S( KS+1 ) = S( KS )
*
ELSE
*
* Real eigenvalue.
*
RNRM = DNRM2( N, VR( 1, KS ), 1 )
LNRM = DNRM2( N, VL( 1, KS ), 1 )
CALL DGEMV( 'N', N, N, ONE, A, LDA, VR( 1, KS ), 1, ZERO,
$ WORK, 1 )
UHAV = DDOT( N, WORK, 1, VL( 1, KS ), 1 )
CALL DGEMV( 'N', N, N, ONE, B, LDB, VR( 1, KS ), 1, ZERO,
$ WORK, 1 )
UHBV = DDOT( N, WORK, 1, VL( 1, KS ), 1 )
COND = DLAPY2( UHAV, UHBV )
IF( COND.EQ.ZERO ) THEN
S( KS ) = -ONE
ELSE
S( KS ) = COND / ( RNRM*LNRM )
END IF
END IF
END IF
*
IF( WANTDF ) THEN
IF( N.EQ.1 ) THEN
DIF( KS ) = DLAPY2( A( 1, 1 ), B( 1, 1 ) )
GO TO 20
END IF
*
* Estimate the reciprocal condition number of the k-th
* eigenvectors.
IF( PAIR ) THEN
*
* Copy the 2-by 2 pencil beginning at (A(k,k), B(k, k)).
* Compute the eigenvalue(s) at position K.
*
WORK( 1 ) = A( K, K )
WORK( 2 ) = A( K+1, K )
WORK( 3 ) = A( K, K+1 )
WORK( 4 ) = A( K+1, K+1 )
WORK( 5 ) = B( K, K )
WORK( 6 ) = B( K+1, K )
WORK( 7 ) = B( K, K+1 )
WORK( 8 ) = B( K+1, K+1 )
CALL DLAG2( WORK, 2, WORK( 5 ), 2, SMLNUM*EPS, BETA,
$ DUMMY1( 1 ), ALPHAR, DUMMY( 1 ), ALPHAI )
ALPRQT = ONE
C1 = TWO*( ALPHAR*ALPHAR+ALPHAI*ALPHAI+BETA*BETA )
C2 = FOUR*BETA*BETA*ALPHAI*ALPHAI
ROOT1 = C1 + SQRT( C1*C1-4.0D0*C2 )
ROOT2 = C2 / ROOT1
ROOT1 = ROOT1 / TWO
COND = MIN( SQRT( ROOT1 ), SQRT( ROOT2 ) )
END IF
*
* Copy the matrix (A, B) to the array WORK and swap the
* diagonal block beginning at A(k,k) to the (1,1) position.
*
CALL DLACPY( 'Full', N, N, A, LDA, WORK, N )
CALL DLACPY( 'Full', N, N, B, LDB, WORK( N*N+1 ), N )
IFST = K
ILST = 1
*
CALL DTGEXC( .FALSE., .FALSE., N, WORK, N, WORK( N*N+1 ), N,
$ DUMMY, 1, DUMMY1, 1, IFST, ILST,
$ WORK( N*N*2+1 ), LWORK-2*N*N, IERR )
*
IF( IERR.GT.0 ) THEN
*
* Ill-conditioned problem - swap rejected.
*
DIF( KS ) = ZERO
ELSE
*
* Reordering successful, solve generalized Sylvester
* equation for R and L,
* A22 * R - L * A11 = A12
* B22 * R - L * B11 = B12,
* and compute estimate of Difl((A11,B11), (A22, B22)).
*
N1 = 1
IF( WORK( 2 ).NE.ZERO )
$ N1 = 2
N2 = N - N1
IF( N2.EQ.0 ) THEN
DIF( KS ) = COND
ELSE
I = N*N + 1
IZ = 2*N*N + 1
CALL DTGSYL( 'N', DIFDRI, N2, N1, WORK( N*N1+N1+1 ),
$ N, WORK, N, WORK( N1+1 ), N,
$ WORK( N*N1+N1+I ), N, WORK( I ), N,
$ WORK( N1+I ), N, SCALE, DIF( KS ),
$ WORK( IZ+1 ), LWORK-2*N*N, IWORK, IERR )
*
IF( PAIR )
$ DIF( KS ) = MIN( MAX( ONE, ALPRQT )*DIF( KS ),
$ COND )
END IF
END IF
IF( PAIR )
$ DIF( KS+1 ) = DIF( KS )
END IF
IF( PAIR )
$ KS = KS + 1
*
20 CONTINUE
WORK( 1 ) = LWMIN
RETURN
*
* End of DTGSNA
*
END
SUBROUTINE DTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D,
$ LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL,
$ IWORK, PQ, INFO )
*
* -- LAPACK auxiliary routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* January 2007
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N,
$ PQ
DOUBLE PRECISION RDSCAL, RDSUM, SCALE
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ),
$ D( LDD, * ), E( LDE, * ), F( LDF, * )
* ..
*
* Purpose
* =======
*
* DTGSY2 solves the generalized Sylvester equation:
*
* A * R - L * B = scale * C (1)
* D * R - L * E = scale * F,
*
* using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices,
* (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,
* N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E)
* must be in generalized Schur canonical form, i.e. A, B are upper
* quasi triangular and D, E are upper triangular. The solution (R, L)
* overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor
* chosen to avoid overflow.
*
* In matrix notation solving equation (1) corresponds to solve
* Z*x = scale*b, where Z is defined as
*
* Z = [ kron(In, A) -kron(B', Im) ] (2)
* [ kron(In, D) -kron(E', Im) ],
*
* Ik is the identity matrix of size k and X' is the transpose of X.
* kron(X, Y) is the Kronecker product between the matrices X and Y.
* In the process of solving (1), we solve a number of such systems
* where Dim(In), Dim(In) = 1 or 2.
*
* If TRANS = 'T', solve the transposed system Z'*y = scale*b for y,
* which is equivalent to solve for R and L in
*
* A' * R + D' * L = scale * C (3)
* R * B' + L * E' = scale * -F
*
* This case is used to compute an estimate of Dif[(A, D), (B, E)] =
* sigma_min(Z) using reverse communicaton with DLACON.
*
* DTGSY2 also (IJOB >= 1) contributes to the computation in DTGSYL
* of an upper bound on the separation between to matrix pairs. Then
* the input (A, D), (B, E) are sub-pencils of the matrix pair in
* DTGSYL. See DTGSYL for details.
*
* Arguments
* =========
*
* TRANS (input) CHARACTER*1
* = 'N', solve the generalized Sylvester equation (1).
* = 'T': solve the 'transposed' system (3).
*
* IJOB (input) INTEGER
* Specifies what kind of functionality to be performed.
* = 0: solve (1) only.
* = 1: A contribution from this subsystem to a Frobenius
* norm-based estimate of the separation between two matrix
* pairs is computed. (look ahead strategy is used).
* = 2: A contribution from this subsystem to a Frobenius
* norm-based estimate of the separation between two matrix
* pairs is computed. (DGECON on sub-systems is used.)
* Not referenced if TRANS = 'T'.
*
* M (input) INTEGER
* On entry, M specifies the order of A and D, and the row
* dimension of C, F, R and L.
*
* N (input) INTEGER
* On entry, N specifies the order of B and E, and the column
* dimension of C, F, R and L.
*
* A (input) DOUBLE PRECISION array, dimension (LDA, M)
* On entry, A contains an upper quasi triangular matrix.
*
* LDA (input) INTEGER
* The leading dimension of the matrix A. LDA >= max(1, M).
*
* B (input) DOUBLE PRECISION array, dimension (LDB, N)
* On entry, B contains an upper quasi triangular matrix.
*
* LDB (input) INTEGER
* The leading dimension of the matrix B. LDB >= max(1, N).
*
* C (input/output) DOUBLE PRECISION array, dimension (LDC, N)
* On entry, C contains the right-hand-side of the first matrix
* equation in (1).
* On exit, if IJOB = 0, C has been overwritten by the
* solution R.
*
* LDC (input) INTEGER
* The leading dimension of the matrix C. LDC >= max(1, M).
*
* D (input) DOUBLE PRECISION array, dimension (LDD, M)
* On entry, D contains an upper triangular matrix.
*
* LDD (input) INTEGER
* The leading dimension of the matrix D. LDD >= max(1, M).
*
* E (input) DOUBLE PRECISION array, dimension (LDE, N)
* On entry, E contains an upper triangular matrix.
*
* LDE (input) INTEGER
* The leading dimension of the matrix E. LDE >= max(1, N).
*
* F (input/output) DOUBLE PRECISION array, dimension (LDF, N)
* On entry, F contains the right-hand-side of the second matrix
* equation in (1).
* On exit, if IJOB = 0, F has been overwritten by the
* solution L.
*
* LDF (input) INTEGER
* The leading dimension of the matrix F. LDF >= max(1, M).
*
* SCALE (output) DOUBLE PRECISION
* On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions
* R and L (C and F on entry) will hold the solutions to a
* slightly perturbed system but the input matrices A, B, D and
* E have not been changed. If SCALE = 0, R and L will hold the
* solutions to the homogeneous system with C = F = 0. Normally,
* SCALE = 1.
*
* RDSUM (input/output) DOUBLE PRECISION
* On entry, the sum of squares of computed contributions to
* the Dif-estimate under computation by DTGSYL, where the
* scaling factor RDSCAL (see below) has been factored out.
* On exit, the corresponding sum of squares updated with the
* contributions from the current sub-system.
* If TRANS = 'T' RDSUM is not touched.
* NOTE: RDSUM only makes sense when DTGSY2 is called by DTGSYL.
*
* RDSCAL (input/output) DOUBLE PRECISION
* On entry, scaling factor used to prevent overflow in RDSUM.
* On exit, RDSCAL is updated w.r.t. the current contributions
* in RDSUM.
* If TRANS = 'T', RDSCAL is not touched.
* NOTE: RDSCAL only makes sense when DTGSY2 is called by
* DTGSYL.
*
* IWORK (workspace) INTEGER array, dimension (M+N+2)
*
* PQ (output) INTEGER
* On exit, the number of subsystems (of size 2-by-2, 4-by-4 and
* 8-by-8) solved by this routine.
*
* INFO (output) INTEGER
* On exit, if INFO is set to
* =0: Successful exit
* <0: If INFO = -i, the i-th argument had an illegal value.
* >0: The matrix pairs (A, D) and (B, E) have common or very
* close eigenvalues.
*
* Further Details
* ===============
*
* Based on contributions by
* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
* Umea University, S-901 87 Umea, Sweden.
*
* =====================================================================
* Replaced various illegal calls to DCOPY by calls to DLASET.
* Sven Hammarling, 27/5/02.
*
* .. Parameters ..
INTEGER LDZ
PARAMETER ( LDZ = 8 )
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN
INTEGER I, IE, IERR, II, IS, ISP1, J, JE, JJ, JS, JSP1,
$ K, MB, NB, P, Q, ZDIM
DOUBLE PRECISION ALPHA, SCALOC
* ..
* .. Local Arrays ..
INTEGER IPIV( LDZ ), JPIV( LDZ )
DOUBLE PRECISION RHS( LDZ ), Z( LDZ, LDZ )
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DGER, DGESC2,
$ DGETC2, DLASET, DLATDF, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Decode and test input parameters
*
INFO = 0
IERR = 0
NOTRAN = LSAME( TRANS, 'N' )
IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
INFO = -1
ELSE IF( NOTRAN ) THEN
IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.2 ) ) THEN
INFO = -2
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( M.LE.0 ) THEN
INFO = -3
ELSE IF( N.LE.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
ELSE IF( LDD.LT.MAX( 1, M ) ) THEN
INFO = -12
ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
INFO = -14
ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
INFO = -16
END IF
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTGSY2', -INFO )
RETURN
END IF
*
* Determine block structure of A
*
PQ = 0
P = 0
I = 1
10 CONTINUE
IF( I.GT.M )
$ GO TO 20
P = P + 1
IWORK( P ) = I
IF( I.EQ.M )
$ GO TO 20
IF( A( I+1, I ).NE.ZERO ) THEN
I = I + 2
ELSE
I = I + 1
END IF
GO TO 10
20 CONTINUE
IWORK( P+1 ) = M + 1
*
* Determine block structure of B
*
Q = P + 1
J = 1
30 CONTINUE
IF( J.GT.N )
$ GO TO 40
Q = Q + 1
IWORK( Q ) = J
IF( J.EQ.N )
$ GO TO 40
IF( B( J+1, J ).NE.ZERO ) THEN
J = J + 2
ELSE
J = J + 1
END IF
GO TO 30
40 CONTINUE
IWORK( Q+1 ) = N + 1
PQ = P*( Q-P-1 )
*
IF( NOTRAN ) THEN
*
* Solve (I, J) - subsystem
* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J)
* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J)
* for I = P, P - 1, ..., 1; J = 1, 2, ..., Q
*
SCALE = ONE
SCALOC = ONE
DO 120 J = P + 2, Q
JS = IWORK( J )
JSP1 = JS + 1
JE = IWORK( J+1 ) - 1
NB = JE - JS + 1
DO 110 I = P, 1, -1
*
IS = IWORK( I )
ISP1 = IS + 1
IE = IWORK( I+1 ) - 1
MB = IE - IS + 1
ZDIM = MB*NB*2
*
IF( ( MB.EQ.1 ) .AND. ( NB.EQ.1 ) ) THEN
*
* Build a 2-by-2 system Z * x = RHS
*
Z( 1, 1 ) = A( IS, IS )
Z( 2, 1 ) = D( IS, IS )
Z( 1, 2 ) = -B( JS, JS )
Z( 2, 2 ) = -E( JS, JS )
*
* Set up right hand side(s)
*
RHS( 1 ) = C( IS, JS )
RHS( 2 ) = F( IS, JS )
*
* Solve Z * x = RHS
*
CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
IF( IERR.GT.0 )
$ INFO = IERR
*
IF( IJOB.EQ.0 ) THEN
CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
$ SCALOC )
IF( SCALOC.NE.ONE ) THEN
DO 50 K = 1, N
CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
50 CONTINUE
SCALE = SCALE*SCALOC
END IF
ELSE
CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM,
$ RDSCAL, IPIV, JPIV )
END IF
*
* Unpack solution vector(s)
*
C( IS, JS ) = RHS( 1 )
F( IS, JS ) = RHS( 2 )
*
* Substitute R(I, J) and L(I, J) into remaining
* equation.
*
IF( I.GT.1 ) THEN
ALPHA = -RHS( 1 )
CALL DAXPY( IS-1, ALPHA, A( 1, IS ), 1, C( 1, JS ),
$ 1 )
CALL DAXPY( IS-1, ALPHA, D( 1, IS ), 1, F( 1, JS ),
$ 1 )
END IF
IF( J.LT.Q ) THEN
CALL DAXPY( N-JE, RHS( 2 ), B( JS, JE+1 ), LDB,
$ C( IS, JE+1 ), LDC )
CALL DAXPY( N-JE, RHS( 2 ), E( JS, JE+1 ), LDE,
$ F( IS, JE+1 ), LDF )
END IF
*
ELSE IF( ( MB.EQ.1 ) .AND. ( NB.EQ.2 ) ) THEN
*
* Build a 4-by-4 system Z * x = RHS
*
Z( 1, 1 ) = A( IS, IS )
Z( 2, 1 ) = ZERO
Z( 3, 1 ) = D( IS, IS )
Z( 4, 1 ) = ZERO
*
Z( 1, 2 ) = ZERO
Z( 2, 2 ) = A( IS, IS )
Z( 3, 2 ) = ZERO
Z( 4, 2 ) = D( IS, IS )
*
Z( 1, 3 ) = -B( JS, JS )
Z( 2, 3 ) = -B( JS, JSP1 )
Z( 3, 3 ) = -E( JS, JS )
Z( 4, 3 ) = -E( JS, JSP1 )
*
Z( 1, 4 ) = -B( JSP1, JS )
Z( 2, 4 ) = -B( JSP1, JSP1 )
Z( 3, 4 ) = ZERO
Z( 4, 4 ) = -E( JSP1, JSP1 )
*
* Set up right hand side(s)
*
RHS( 1 ) = C( IS, JS )
RHS( 2 ) = C( IS, JSP1 )
RHS( 3 ) = F( IS, JS )
RHS( 4 ) = F( IS, JSP1 )
*
* Solve Z * x = RHS
*
CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
IF( IERR.GT.0 )
$ INFO = IERR
*
IF( IJOB.EQ.0 ) THEN
CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
$ SCALOC )
IF( SCALOC.NE.ONE ) THEN
DO 60 K = 1, N
CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
60 CONTINUE
SCALE = SCALE*SCALOC
END IF
ELSE
CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM,
$ RDSCAL, IPIV, JPIV )
END IF
*
* Unpack solution vector(s)
*
C( IS, JS ) = RHS( 1 )
C( IS, JSP1 ) = RHS( 2 )
F( IS, JS ) = RHS( 3 )
F( IS, JSP1 ) = RHS( 4 )
*
* Substitute R(I, J) and L(I, J) into remaining
* equation.
*
IF( I.GT.1 ) THEN
CALL DGER( IS-1, NB, -ONE, A( 1, IS ), 1, RHS( 1 ),
$ 1, C( 1, JS ), LDC )
CALL DGER( IS-1, NB, -ONE, D( 1, IS ), 1, RHS( 1 ),
$ 1, F( 1, JS ), LDF )
END IF
IF( J.LT.Q ) THEN
CALL DAXPY( N-JE, RHS( 3 ), B( JS, JE+1 ), LDB,
$ C( IS, JE+1 ), LDC )
CALL DAXPY( N-JE, RHS( 3 ), E( JS, JE+1 ), LDE,
$ F( IS, JE+1 ), LDF )
CALL DAXPY( N-JE, RHS( 4 ), B( JSP1, JE+1 ), LDB,
$ C( IS, JE+1 ), LDC )
CALL DAXPY( N-JE, RHS( 4 ), E( JSP1, JE+1 ), LDE,
$ F( IS, JE+1 ), LDF )
END IF
*
ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN
*
* Build a 4-by-4 system Z * x = RHS
*
Z( 1, 1 ) = A( IS, IS )
Z( 2, 1 ) = A( ISP1, IS )
Z( 3, 1 ) = D( IS, IS )
Z( 4, 1 ) = ZERO
*
Z( 1, 2 ) = A( IS, ISP1 )
Z( 2, 2 ) = A( ISP1, ISP1 )
Z( 3, 2 ) = D( IS, ISP1 )
Z( 4, 2 ) = D( ISP1, ISP1 )
*
Z( 1, 3 ) = -B( JS, JS )
Z( 2, 3 ) = ZERO
Z( 3, 3 ) = -E( JS, JS )
Z( 4, 3 ) = ZERO
*
Z( 1, 4 ) = ZERO
Z( 2, 4 ) = -B( JS, JS )
Z( 3, 4 ) = ZERO
Z( 4, 4 ) = -E( JS, JS )
*
* Set up right hand side(s)
*
RHS( 1 ) = C( IS, JS )
RHS( 2 ) = C( ISP1, JS )
RHS( 3 ) = F( IS, JS )
RHS( 4 ) = F( ISP1, JS )
*
* Solve Z * x = RHS
*
CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
IF( IERR.GT.0 )
$ INFO = IERR
IF( IJOB.EQ.0 ) THEN
CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
$ SCALOC )
IF( SCALOC.NE.ONE ) THEN
DO 70 K = 1, N
CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
70 CONTINUE
SCALE = SCALE*SCALOC
END IF
ELSE
CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM,
$ RDSCAL, IPIV, JPIV )
END IF
*
* Unpack solution vector(s)
*
C( IS, JS ) = RHS( 1 )
C( ISP1, JS ) = RHS( 2 )
F( IS, JS ) = RHS( 3 )
F( ISP1, JS ) = RHS( 4 )
*
* Substitute R(I, J) and L(I, J) into remaining
* equation.
*
IF( I.GT.1 ) THEN
CALL DGEMV( 'N', IS-1, MB, -ONE, A( 1, IS ), LDA,
$ RHS( 1 ), 1, ONE, C( 1, JS ), 1 )
CALL DGEMV( 'N', IS-1, MB, -ONE, D( 1, IS ), LDD,
$ RHS( 1 ), 1, ONE, F( 1, JS ), 1 )
END IF
IF( J.LT.Q ) THEN
CALL DGER( MB, N-JE, ONE, RHS( 3 ), 1,
$ B( JS, JE+1 ), LDB, C( IS, JE+1 ), LDC )
CALL DGER( MB, N-JE, ONE, RHS( 3 ), 1,
$ E( JS, JE+1 ), LDE, F( IS, JE+1 ), LDF )
END IF
*
ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN
*
* Build an 8-by-8 system Z * x = RHS
*
CALL DLASET( 'F', LDZ, LDZ, ZERO, ZERO, Z, LDZ )
*
Z( 1, 1 ) = A( IS, IS )
Z( 2, 1 ) = A( ISP1, IS )
Z( 5, 1 ) = D( IS, IS )
*
Z( 1, 2 ) = A( IS, ISP1 )
Z( 2, 2 ) = A( ISP1, ISP1 )
Z( 5, 2 ) = D( IS, ISP1 )
Z( 6, 2 ) = D( ISP1, ISP1 )
*
Z( 3, 3 ) = A( IS, IS )
Z( 4, 3 ) = A( ISP1, IS )
Z( 7, 3 ) = D( IS, IS )
*
Z( 3, 4 ) = A( IS, ISP1 )
Z( 4, 4 ) = A( ISP1, ISP1 )
Z( 7, 4 ) = D( IS, ISP1 )
Z( 8, 4 ) = D( ISP1, ISP1 )
*
Z( 1, 5 ) = -B( JS, JS )
Z( 3, 5 ) = -B( JS, JSP1 )
Z( 5, 5 ) = -E( JS, JS )
Z( 7, 5 ) = -E( JS, JSP1 )
*
Z( 2, 6 ) = -B( JS, JS )
Z( 4, 6 ) = -B( JS, JSP1 )
Z( 6, 6 ) = -E( JS, JS )
Z( 8, 6 ) = -E( JS, JSP1 )
*
Z( 1, 7 ) = -B( JSP1, JS )
Z( 3, 7 ) = -B( JSP1, JSP1 )
Z( 7, 7 ) = -E( JSP1, JSP1 )
*
Z( 2, 8 ) = -B( JSP1, JS )
Z( 4, 8 ) = -B( JSP1, JSP1 )
Z( 8, 8 ) = -E( JSP1, JSP1 )
*
* Set up right hand side(s)
*
K = 1
II = MB*NB + 1
DO 80 JJ = 0, NB - 1
CALL DCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 )
CALL DCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ), 1 )
K = K + MB
II = II + MB
80 CONTINUE
*
* Solve Z * x = RHS
*
CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
IF( IERR.GT.0 )
$ INFO = IERR
IF( IJOB.EQ.0 ) THEN
CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
$ SCALOC )
IF( SCALOC.NE.ONE ) THEN
DO 90 K = 1, N
CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
90 CONTINUE
SCALE = SCALE*SCALOC
END IF
ELSE
CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM,
$ RDSCAL, IPIV, JPIV )
END IF
*
* Unpack solution vector(s)
*
K = 1
II = MB*NB + 1
DO 100 JJ = 0, NB - 1
CALL DCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 )
CALL DCOPY( MB, RHS( II ), 1, F( IS, JS+JJ ), 1 )
K = K + MB
II = II + MB
100 CONTINUE
*
* Substitute R(I, J) and L(I, J) into remaining
* equation.
*
IF( I.GT.1 ) THEN
CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE,
$ A( 1, IS ), LDA, RHS( 1 ), MB, ONE,
$ C( 1, JS ), LDC )
CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE,
$ D( 1, IS ), LDD, RHS( 1 ), MB, ONE,
$ F( 1, JS ), LDF )
END IF
IF( J.LT.Q ) THEN
K = MB*NB + 1
CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ),
$ MB, B( JS, JE+1 ), LDB, ONE,
$ C( IS, JE+1 ), LDC )
CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ),
$ MB, E( JS, JE+1 ), LDE, ONE,
$ F( IS, JE+1 ), LDF )
END IF
*
END IF
*
110 CONTINUE
120 CONTINUE
ELSE
*
* Solve (I, J) - subsystem
* A(I, I)' * R(I, J) + D(I, I)' * L(J, J) = C(I, J)
* R(I, I) * B(J, J) + L(I, J) * E(J, J) = -F(I, J)
* for I = 1, 2, ..., P, J = Q, Q - 1, ..., 1
*
SCALE = ONE
SCALOC = ONE
DO 200 I = 1, P
*
IS = IWORK( I )
ISP1 = IS + 1
IE = ( I+1 ) - 1
MB = IE - IS + 1
DO 190 J = Q, P + 2, -1
*
JS = IWORK( J )
JSP1 = JS + 1
JE = IWORK( J+1 ) - 1
NB = JE - JS + 1
ZDIM = MB*NB*2
IF( ( MB.EQ.1 ) .AND. ( NB.EQ.1 ) ) THEN
*
* Build a 2-by-2 system Z' * x = RHS
*
Z( 1, 1 ) = A( IS, IS )
Z( 2, 1 ) = -B( JS, JS )
Z( 1, 2 ) = D( IS, IS )
Z( 2, 2 ) = -E( JS, JS )
*
* Set up right hand side(s)
*
RHS( 1 ) = C( IS, JS )
RHS( 2 ) = F( IS, JS )
*
* Solve Z' * x = RHS
*
CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
IF( IERR.GT.0 )
$ INFO = IERR
*
CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
IF( SCALOC.NE.ONE ) THEN
DO 130 K = 1, N
CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
130 CONTINUE
SCALE = SCALE*SCALOC
END IF
*
* Unpack solution vector(s)
*
C( IS, JS ) = RHS( 1 )
F( IS, JS ) = RHS( 2 )
*
* Substitute R(I, J) and L(I, J) into remaining
* equation.
*
IF( J.GT.P+2 ) THEN
ALPHA = RHS( 1 )
CALL DAXPY( JS-1, ALPHA, B( 1, JS ), 1, F( IS, 1 ),
$ LDF )
ALPHA = RHS( 2 )
CALL DAXPY( JS-1, ALPHA, E( 1, JS ), 1, F( IS, 1 ),
$ LDF )
END IF
IF( I.LT.P ) THEN
ALPHA = -RHS( 1 )
CALL DAXPY( M-IE, ALPHA, A( IS, IE+1 ), LDA,
$ C( IE+1, JS ), 1 )
ALPHA = -RHS( 2 )
CALL DAXPY( M-IE, ALPHA, D( IS, IE+1 ), LDD,
$ C( IE+1, JS ), 1 )
END IF
*
ELSE IF( ( MB.EQ.1 ) .AND. ( NB.EQ.2 ) ) THEN
*
* Build a 4-by-4 system Z' * x = RHS
*
Z( 1, 1 ) = A( IS, IS )
Z( 2, 1 ) = ZERO
Z( 3, 1 ) = -B( JS, JS )
Z( 4, 1 ) = -B( JSP1, JS )
*
Z( 1, 2 ) = ZERO
Z( 2, 2 ) = A( IS, IS )
Z( 3, 2 ) = -B( JS, JSP1 )
Z( 4, 2 ) = -B( JSP1, JSP1 )
*
Z( 1, 3 ) = D( IS, IS )
Z( 2, 3 ) = ZERO
Z( 3, 3 ) = -E( JS, JS )
Z( 4, 3 ) = ZERO
*
Z( 1, 4 ) = ZERO
Z( 2, 4 ) = D( IS, IS )
Z( 3, 4 ) = -E( JS, JSP1 )
Z( 4, 4 ) = -E( JSP1, JSP1 )
*
* Set up right hand side(s)
*
RHS( 1 ) = C( IS, JS )
RHS( 2 ) = C( IS, JSP1 )
RHS( 3 ) = F( IS, JS )
RHS( 4 ) = F( IS, JSP1 )
*
* Solve Z' * x = RHS
*
CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
IF( IERR.GT.0 )
$ INFO = IERR
CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
IF( SCALOC.NE.ONE ) THEN
DO 140 K = 1, N
CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
140 CONTINUE
SCALE = SCALE*SCALOC
END IF
*
* Unpack solution vector(s)
*
C( IS, JS ) = RHS( 1 )
C( IS, JSP1 ) = RHS( 2 )
F( IS, JS ) = RHS( 3 )
F( IS, JSP1 ) = RHS( 4 )
*
* Substitute R(I, J) and L(I, J) into remaining
* equation.
*
IF( J.GT.P+2 ) THEN
CALL DAXPY( JS-1, RHS( 1 ), B( 1, JS ), 1,
$ F( IS, 1 ), LDF )
CALL DAXPY( JS-1, RHS( 2 ), B( 1, JSP1 ), 1,
$ F( IS, 1 ), LDF )
CALL DAXPY( JS-1, RHS( 3 ), E( 1, JS ), 1,
$ F( IS, 1 ), LDF )
CALL DAXPY( JS-1, RHS( 4 ), E( 1, JSP1 ), 1,
$ F( IS, 1 ), LDF )
END IF
IF( I.LT.P ) THEN
CALL DGER( M-IE, NB, -ONE, A( IS, IE+1 ), LDA,
$ RHS( 1 ), 1, C( IE+1, JS ), LDC )
CALL DGER( M-IE, NB, -ONE, D( IS, IE+1 ), LDD,
$ RHS( 3 ), 1, C( IE+1, JS ), LDC )
END IF
*
ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN
*
* Build a 4-by-4 system Z' * x = RHS
*
Z( 1, 1 ) = A( IS, IS )
Z( 2, 1 ) = A( IS, ISP1 )
Z( 3, 1 ) = -B( JS, JS )
Z( 4, 1 ) = ZERO
*
Z( 1, 2 ) = A( ISP1, IS )
Z( 2, 2 ) = A( ISP1, ISP1 )
Z( 3, 2 ) = ZERO
Z( 4, 2 ) = -B( JS, JS )
*
Z( 1, 3 ) = D( IS, IS )
Z( 2, 3 ) = D( IS, ISP1 )
Z( 3, 3 ) = -E( JS, JS )
Z( 4, 3 ) = ZERO
*
Z( 1, 4 ) = ZERO
Z( 2, 4 ) = D( ISP1, ISP1 )
Z( 3, 4 ) = ZERO
Z( 4, 4 ) = -E( JS, JS )
*
* Set up right hand side(s)
*
RHS( 1 ) = C( IS, JS )
RHS( 2 ) = C( ISP1, JS )
RHS( 3 ) = F( IS, JS )
RHS( 4 ) = F( ISP1, JS )
*
* Solve Z' * x = RHS
*
CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
IF( IERR.GT.0 )
$ INFO = IERR
*
CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
IF( SCALOC.NE.ONE ) THEN
DO 150 K = 1, N
CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
150 CONTINUE
SCALE = SCALE*SCALOC
END IF
*
* Unpack solution vector(s)
*
C( IS, JS ) = RHS( 1 )
C( ISP1, JS ) = RHS( 2 )
F( IS, JS ) = RHS( 3 )
F( ISP1, JS ) = RHS( 4 )
*
* Substitute R(I, J) and L(I, J) into remaining
* equation.
*
IF( J.GT.P+2 ) THEN
CALL DGER( MB, JS-1, ONE, RHS( 1 ), 1, B( 1, JS ),
$ 1, F( IS, 1 ), LDF )
CALL DGER( MB, JS-1, ONE, RHS( 3 ), 1, E( 1, JS ),
$ 1, F( IS, 1 ), LDF )
END IF
IF( I.LT.P ) THEN
CALL DGEMV( 'T', MB, M-IE, -ONE, A( IS, IE+1 ),
$ LDA, RHS( 1 ), 1, ONE, C( IE+1, JS ),
$ 1 )
CALL DGEMV( 'T', MB, M-IE, -ONE, D( IS, IE+1 ),
$ LDD, RHS( 3 ), 1, ONE, C( IE+1, JS ),
$ 1 )
END IF
*
ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN
*
* Build an 8-by-8 system Z' * x = RHS
*
CALL DLASET( 'F', LDZ, LDZ, ZERO, ZERO, Z, LDZ )
*
Z( 1, 1 ) = A( IS, IS )
Z( 2, 1 ) = A( IS, ISP1 )
Z( 5, 1 ) = -B( JS, JS )
Z( 7, 1 ) = -B( JSP1, JS )
*
Z( 1, 2 ) = A( ISP1, IS )
Z( 2, 2 ) = A( ISP1, ISP1 )
Z( 6, 2 ) = -B( JS, JS )
Z( 8, 2 ) = -B( JSP1, JS )
*
Z( 3, 3 ) = A( IS, IS )
Z( 4, 3 ) = A( IS, ISP1 )
Z( 5, 3 ) = -B( JS, JSP1 )
Z( 7, 3 ) = -B( JSP1, JSP1 )
*
Z( 3, 4 ) = A( ISP1, IS )
Z( 4, 4 ) = A( ISP1, ISP1 )
Z( 6, 4 ) = -B( JS, JSP1 )
Z( 8, 4 ) = -B( JSP1, JSP1 )
*
Z( 1, 5 ) = D( IS, IS )
Z( 2, 5 ) = D( IS, ISP1 )
Z( 5, 5 ) = -E( JS, JS )
*
Z( 2, 6 ) = D( ISP1, ISP1 )
Z( 6, 6 ) = -E( JS, JS )
*
Z( 3, 7 ) = D( IS, IS )
Z( 4, 7 ) = D( IS, ISP1 )
Z( 5, 7 ) = -E( JS, JSP1 )
Z( 7, 7 ) = -E( JSP1, JSP1 )
*
Z( 4, 8 ) = D( ISP1, ISP1 )
Z( 6, 8 ) = -E( JS, JSP1 )
Z( 8, 8 ) = -E( JSP1, JSP1 )
*
* Set up right hand side(s)
*
K = 1
II = MB*NB + 1
DO 160 JJ = 0, NB - 1
CALL DCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 )
CALL DCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ), 1 )
K = K + MB
II = II + MB
160 CONTINUE
*
*
* Solve Z' * x = RHS
*
CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
IF( IERR.GT.0 )
$ INFO = IERR
*
CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
IF( SCALOC.NE.ONE ) THEN
DO 170 K = 1, N
CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
170 CONTINUE
SCALE = SCALE*SCALOC
END IF
*
* Unpack solution vector(s)
*
K = 1
II = MB*NB + 1
DO 180 JJ = 0, NB - 1
CALL DCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 )
CALL DCOPY( MB, RHS( II ), 1, F( IS, JS+JJ ), 1 )
K = K + MB
II = II + MB
180 CONTINUE
*
* Substitute R(I, J) and L(I, J) into remaining
* equation.
*
IF( J.GT.P+2 ) THEN
CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE,
$ C( IS, JS ), LDC, B( 1, JS ), LDB, ONE,
$ F( IS, 1 ), LDF )
CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE,
$ F( IS, JS ), LDF, E( 1, JS ), LDE, ONE,
$ F( IS, 1 ), LDF )
END IF
IF( I.LT.P ) THEN
CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE,
$ A( IS, IE+1 ), LDA, C( IS, JS ), LDC,
$ ONE, C( IE+1, JS ), LDC )
CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE,
$ D( IS, IE+1 ), LDD, F( IS, JS ), LDF,
$ ONE, C( IE+1, JS ), LDC )
END IF
*
END IF
*
190 CONTINUE
200 CONTINUE
*
END IF
RETURN
*
* End of DTGSY2
*
END
SUBROUTINE DTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D,
$ LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK,
$ IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF,
$ LWORK, M, N
DOUBLE PRECISION DIF, SCALE
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ),
$ D( LDD, * ), E( LDE, * ), F( LDF, * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* DTGSYL solves the generalized Sylvester equation:
*
* A * R - L * B = scale * C (1)
* D * R - L * E = scale * F
*
* where R and L are unknown m-by-n matrices, (A, D), (B, E) and
* (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n,
* respectively, with real entries. (A, D) and (B, E) must be in
* generalized (real) Schur canonical form, i.e. A, B are upper quasi
* triangular and D, E are upper triangular.
*
* The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output
* scaling factor chosen to avoid overflow.
*
* In matrix notation (1) is equivalent to solve Zx = scale b, where
* Z is defined as
*
* Z = [ kron(In, A) -kron(B', Im) ] (2)
* [ kron(In, D) -kron(E', Im) ].
*
* Here Ik is the identity matrix of size k and X' is the transpose of
* X. kron(X, Y) is the Kronecker product between the matrices X and Y.
*
* If TRANS = 'T', DTGSYL solves the transposed system Z'*y = scale*b,
* which is equivalent to solve for R and L in
*
* A' * R + D' * L = scale * C (3)
* R * B' + L * E' = scale * (-F)
*
* This case (TRANS = 'T') is used to compute an one-norm-based estimate
* of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D)
* and (B,E), using DLACON.
*
* If IJOB >= 1, DTGSYL computes a Frobenius norm-based estimate
* of Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the
* reciprocal of the smallest singular value of Z. See [1-2] for more
* information.
*
* This is a level 3 BLAS algorithm.
*
* Arguments
* =========
*
* TRANS (input) CHARACTER*1
* = 'N', solve the generalized Sylvester equation (1).
* = 'T', solve the 'transposed' system (3).
*
* IJOB (input) INTEGER
* Specifies what kind of functionality to be performed.
* =0: solve (1) only.
* =1: The functionality of 0 and 3.
* =2: The functionality of 0 and 4.
* =3: Only an estimate of Dif[(A,D), (B,E)] is computed.
* (look ahead strategy IJOB = 1 is used).
* =4: Only an estimate of Dif[(A,D), (B,E)] is computed.
* ( DGECON on sub-systems is used ).
* Not referenced if TRANS = 'T'.
*
* M (input) INTEGER
* The order of the matrices A and D, and the row dimension of
* the matrices C, F, R and L.
*
* N (input) INTEGER
* The order of the matrices B and E, and the column dimension
* of the matrices C, F, R and L.
*
* A (input) DOUBLE PRECISION array, dimension (LDA, M)
* The upper quasi triangular matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1, M).
*
* B (input) DOUBLE PRECISION array, dimension (LDB, N)
* The upper quasi triangular matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1, N).
*
* C (input/output) DOUBLE PRECISION array, dimension (LDC, N)
* On entry, C contains the right-hand-side of the first matrix
* equation in (1) or (3).
* On exit, if IJOB = 0, 1 or 2, C has been overwritten by
* the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R,
* the solution achieved during the computation of the
* Dif-estimate.
*
* LDC (input) INTEGER
* The leading dimension of the array C. LDC >= max(1, M).
*
* D (input) DOUBLE PRECISION array, dimension (LDD, M)
* The upper triangular matrix D.
*
* LDD (input) INTEGER
* The leading dimension of the array D. LDD >= max(1, M).
*
* E (input) DOUBLE PRECISION array, dimension (LDE, N)
* The upper triangular matrix E.
*
* LDE (input) INTEGER
* The leading dimension of the array E. LDE >= max(1, N).
*
* F (input/output) DOUBLE PRECISION array, dimension (LDF, N)
* On entry, F contains the right-hand-side of the second matrix
* equation in (1) or (3).
* On exit, if IJOB = 0, 1 or 2, F has been overwritten by
* the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L,
* the solution achieved during the computation of the
* Dif-estimate.
*
* LDF (input) INTEGER
* The leading dimension of the array F. LDF >= max(1, M).
*
* DIF (output) DOUBLE PRECISION
* On exit DIF is the reciprocal of a lower bound of the
* reciprocal of the Dif-function, i.e. DIF is an upper bound of
* Dif[(A,D), (B,E)] = sigma_min(Z), where Z as in (2).
* IF IJOB = 0 or TRANS = 'T', DIF is not touched.
*
* SCALE (output) DOUBLE PRECISION
* On exit SCALE is the scaling factor in (1) or (3).
* If 0 < SCALE < 1, C and F hold the solutions R and L, resp.,
* to a slightly perturbed system but the input matrices A, B, D
* and E have not been changed. If SCALE = 0, C and F hold the
* solutions R and L, respectively, to the homogeneous system
* with C = F = 0. Normally, SCALE = 1.
*
* 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 > = 1.
* If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N).
*
* 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.
*
* IWORK (workspace) INTEGER array, dimension (M+N+6)
*
* INFO (output) INTEGER
* =0: successful exit
* <0: If INFO = -i, the i-th argument had an illegal value.
* >0: (A, D) and (B, E) have common or close eigenvalues.
*
* Further Details
* ===============
*
* Based on contributions by
* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
* Umea University, S-901 87 Umea, Sweden.
*
* [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
* for Solving the Generalized Sylvester Equation and Estimating the
* Separation between Regular Matrix Pairs, Report UMINF - 93.23,
* Department of Computing Science, Umea University, S-901 87 Umea,
* Sweden, December 1993, Revised April 1994, Also as LAPACK Working
* Note 75. To appear in ACM Trans. on Math. Software, Vol 22,
* No 1, 1996.
*
* [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester
* Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal.
* Appl., 15(4):1045-1060, 1994
*
* [3] B. Kagstrom and L. Westin, Generalized Schur Methods with
* Condition Estimators for Solving the Generalized Sylvester
* Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7,
* July 1989, pp 745-751.
*
* =====================================================================
* Replaced various illegal calls to DCOPY by calls to DLASET.
* Sven Hammarling, 1/5/02.
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, NOTRAN
INTEGER I, IE, IFUNC, IROUND, IS, ISOLVE, J, JE, JS, K,
$ LINFO, LWMIN, MB, NB, P, PPQQ, PQ, Q
DOUBLE PRECISION DSCALE, DSUM, SCALE2, SCALOC
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLACPY, DLASET, DSCAL, DTGSY2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Decode and test input parameters
*
INFO = 0
NOTRAN = LSAME( TRANS, 'N' )
LQUERY = ( LWORK.EQ.-1 )
*
IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
INFO = -1
ELSE IF( NOTRAN ) THEN
IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.4 ) ) THEN
INFO = -2
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( M.LE.0 ) THEN
INFO = -3
ELSE IF( N.LE.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -6
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
ELSE IF( LDD.LT.MAX( 1, M ) ) THEN
INFO = -12
ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
INFO = -14
ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
INFO = -16
END IF
END IF
*
IF( INFO.EQ.0 ) THEN
IF( NOTRAN ) THEN
IF( IJOB.EQ.1 .OR. IJOB.EQ.2 ) THEN
LWMIN = MAX( 1, 2*M*N )
ELSE
LWMIN = 1
END IF
ELSE
LWMIN = 1
END IF
WORK( 1 ) = LWMIN
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -20
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTGSYL', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
SCALE = 1
IF( NOTRAN ) THEN
IF( IJOB.NE.0 ) THEN
DIF = 0
END IF
END IF
RETURN
END IF
*
* Determine optimal block sizes MB and NB
*
MB = ILAENV( 2, 'DTGSYL', TRANS, M, N, -1, -1 )
NB = ILAENV( 5, 'DTGSYL', TRANS, M, N, -1, -1 )
*
ISOLVE = 1
IFUNC = 0
IF( NOTRAN ) THEN
IF( IJOB.GE.3 ) THEN
IFUNC = IJOB - 2
CALL DLASET( 'F', M, N, ZERO, ZERO, C, LDC )
CALL DLASET( 'F', M, N, ZERO, ZERO, F, LDF )
ELSE IF( IJOB.GE.1 ) THEN
ISOLVE = 2
END IF
END IF
*
IF( ( MB.LE.1 .AND. NB.LE.1 ) .OR. ( MB.GE.M .AND. NB.GE.N ) )
$ THEN
*
DO 30 IROUND = 1, ISOLVE
*
* Use unblocked Level 2 solver
*
DSCALE = ZERO
DSUM = ONE
PQ = 0
CALL DTGSY2( TRANS, IFUNC, M, N, A, LDA, B, LDB, C, LDC, D,
$ LDD, E, LDE, F, LDF, SCALE, DSUM, DSCALE,
$ IWORK, PQ, INFO )
IF( DSCALE.NE.ZERO ) THEN
IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN
DIF = SQRT( DBLE( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) )
ELSE
DIF = SQRT( DBLE( PQ ) ) / ( DSCALE*SQRT( DSUM ) )
END IF
END IF
*
IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN
IF( NOTRAN ) THEN
IFUNC = IJOB
END IF
SCALE2 = SCALE
CALL DLACPY( 'F', M, N, C, LDC, WORK, M )
CALL DLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M )
CALL DLASET( 'F', M, N, ZERO, ZERO, C, LDC )
CALL DLASET( 'F', M, N, ZERO, ZERO, F, LDF )
ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN
CALL DLACPY( 'F', M, N, WORK, M, C, LDC )
CALL DLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF )
SCALE = SCALE2
END IF
30 CONTINUE
*
RETURN
END IF
*
* Determine block structure of A
*
P = 0
I = 1
40 CONTINUE
IF( I.GT.M )
$ GO TO 50
P = P + 1
IWORK( P ) = I
I = I + MB
IF( I.GE.M )
$ GO TO 50
IF( A( I, I-1 ).NE.ZERO )
$ I = I + 1
GO TO 40
50 CONTINUE
*
IWORK( P+1 ) = M + 1
IF( IWORK( P ).EQ.IWORK( P+1 ) )
$ P = P - 1
*
* Determine block structure of B
*
Q = P + 1
J = 1
60 CONTINUE
IF( J.GT.N )
$ GO TO 70
Q = Q + 1
IWORK( Q ) = J
J = J + NB
IF( J.GE.N )
$ GO TO 70
IF( B( J, J-1 ).NE.ZERO )
$ J = J + 1
GO TO 60
70 CONTINUE
*
IWORK( Q+1 ) = N + 1
IF( IWORK( Q ).EQ.IWORK( Q+1 ) )
$ Q = Q - 1
*
IF( NOTRAN ) THEN
*
DO 150 IROUND = 1, ISOLVE
*
* Solve (I, J)-subsystem
* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J)
* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J)
* for I = P, P - 1,..., 1; J = 1, 2,..., Q
*
DSCALE = ZERO
DSUM = ONE
PQ = 0
SCALE = ONE
DO 130 J = P + 2, Q
JS = IWORK( J )
JE = IWORK( J+1 ) - 1
NB = JE - JS + 1
DO 120 I = P, 1, -1
IS = IWORK( I )
IE = IWORK( I+1 ) - 1
MB = IE - IS + 1
PPQQ = 0
CALL DTGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA,
$ B( JS, JS ), LDB, C( IS, JS ), LDC,
$ D( IS, IS ), LDD, E( JS, JS ), LDE,
$ F( IS, JS ), LDF, SCALOC, DSUM, DSCALE,
$ IWORK( Q+2 ), PPQQ, LINFO )
IF( LINFO.GT.0 )
$ INFO = LINFO
*
PQ = PQ + PPQQ
IF( SCALOC.NE.ONE ) THEN
DO 80 K = 1, JS - 1
CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
80 CONTINUE
DO 90 K = JS, JE
CALL DSCAL( IS-1, SCALOC, C( 1, K ), 1 )
CALL DSCAL( IS-1, SCALOC, F( 1, K ), 1 )
90 CONTINUE
DO 100 K = JS, JE
CALL DSCAL( M-IE, SCALOC, C( IE+1, K ), 1 )
CALL DSCAL( M-IE, SCALOC, F( IE+1, K ), 1 )
100 CONTINUE
DO 110 K = JE + 1, N
CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
110 CONTINUE
SCALE = SCALE*SCALOC
END IF
*
* Substitute R(I, J) and L(I, J) into remaining
* equation.
*
IF( I.GT.1 ) THEN
CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE,
$ A( 1, IS ), LDA, C( IS, JS ), LDC, ONE,
$ C( 1, JS ), LDC )
CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE,
$ D( 1, IS ), LDD, C( IS, JS ), LDC, ONE,
$ F( 1, JS ), LDF )
END IF
IF( J.LT.Q ) THEN
CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE,
$ F( IS, JS ), LDF, B( JS, JE+1 ), LDB,
$ ONE, C( IS, JE+1 ), LDC )
CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE,
$ F( IS, JS ), LDF, E( JS, JE+1 ), LDE,
$ ONE, F( IS, JE+1 ), LDF )
END IF
120 CONTINUE
130 CONTINUE
IF( DSCALE.NE.ZERO ) THEN
IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN
DIF = SQRT( DBLE( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) )
ELSE
DIF = SQRT( DBLE( PQ ) ) / ( DSCALE*SQRT( DSUM ) )
END IF
END IF
IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN
IF( NOTRAN ) THEN
IFUNC = IJOB
END IF
SCALE2 = SCALE
CALL DLACPY( 'F', M, N, C, LDC, WORK, M )
CALL DLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M )
CALL DLASET( 'F', M, N, ZERO, ZERO, C, LDC )
CALL DLASET( 'F', M, N, ZERO, ZERO, F, LDF )
ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN
CALL DLACPY( 'F', M, N, WORK, M, C, LDC )
CALL DLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF )
SCALE = SCALE2
END IF
150 CONTINUE
*
ELSE
*
* Solve transposed (I, J)-subsystem
* A(I, I)' * R(I, J) + D(I, I)' * L(I, J) = C(I, J)
* R(I, J) * B(J, J)' + L(I, J) * E(J, J)' = -F(I, J)
* for I = 1,2,..., P; J = Q, Q-1,..., 1
*
SCALE = ONE
DO 210 I = 1, P
IS = IWORK( I )
IE = IWORK( I+1 ) - 1
MB = IE - IS + 1
DO 200 J = Q, P + 2, -1
JS = IWORK( J )
JE = IWORK( J+1 ) - 1
NB = JE - JS + 1
CALL DTGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA,
$ B( JS, JS ), LDB, C( IS, JS ), LDC,
$ D( IS, IS ), LDD, E( JS, JS ), LDE,
$ F( IS, JS ), LDF, SCALOC, DSUM, DSCALE,
$ IWORK( Q+2 ), PPQQ, LINFO )
IF( LINFO.GT.0 )
$ INFO = LINFO
IF( SCALOC.NE.ONE ) THEN
DO 160 K = 1, JS - 1
CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
160 CONTINUE
DO 170 K = JS, JE
CALL DSCAL( IS-1, SCALOC, C( 1, K ), 1 )
CALL DSCAL( IS-1, SCALOC, F( 1, K ), 1 )
170 CONTINUE
DO 180 K = JS, JE
CALL DSCAL( M-IE, SCALOC, C( IE+1, K ), 1 )
CALL DSCAL( M-IE, SCALOC, F( IE+1, K ), 1 )
180 CONTINUE
DO 190 K = JE + 1, N
CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
190 CONTINUE
SCALE = SCALE*SCALOC
END IF
*
* Substitute R(I, J) and L(I, J) into remaining equation.
*
IF( J.GT.P+2 ) THEN
CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE, C( IS, JS ),
$ LDC, B( 1, JS ), LDB, ONE, F( IS, 1 ),
$ LDF )
CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE, F( IS, JS ),
$ LDF, E( 1, JS ), LDE, ONE, F( IS, 1 ),
$ LDF )
END IF
IF( I.LT.P ) THEN
CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE,
$ A( IS, IE+1 ), LDA, C( IS, JS ), LDC, ONE,
$ C( IE+1, JS ), LDC )
CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE,
$ D( IS, IE+1 ), LDD, F( IS, JS ), LDF, ONE,
$ C( IE+1, JS ), LDC )
END IF
200 CONTINUE
210 CONTINUE
*
END IF
*
WORK( 1 ) = LWMIN
*
RETURN
*
* End of DTGSYL
*
END
SUBROUTINE DTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER DIAG, NORM, UPLO
INTEGER INFO, N
DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION AP( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DTPCON estimates the reciprocal of the condition number of a packed
* triangular matrix A, in either the 1-norm or the infinity-norm.
*
* The norm of A is computed and an estimate is obtained for
* norm(inv(A)), then the reciprocal of the condition number is
* computed as
* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies whether the 1-norm condition number or the
* infinity-norm condition number is required:
* = '1' or 'O': 1-norm;
* = 'I': Infinity-norm.
*
* UPLO (input) CHARACTER*1
* = 'U': A is upper triangular;
* = 'L': A is lower triangular.
*
* DIAG (input) CHARACTER*1
* = 'N': A is non-unit triangular;
* = 'U': A is unit triangular.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The upper or lower triangular matrix A, packed columnwise in
* a linear array. The j-th column of A is stored in the array
* AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
* If DIAG = 'U', the diagonal elements of A are not referenced
* and are assumed to be 1.
*
* RCOND (output) DOUBLE PRECISION
* The reciprocal of the condition number of the matrix A,
* computed as RCOND = 1/(norm(A) * norm(inv(A))).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT, ONENRM, UPPER
CHARACTER NORMIN
INTEGER IX, KASE, KASE1
DOUBLE PRECISION AINVNM, ANORM, SCALE, SMLNUM, XNORM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH, DLANTP
EXTERNAL LSAME, IDAMAX, DLAMCH, DLANTP
* ..
* .. External Subroutines ..
EXTERNAL DLACN2, DLATPS, DRSCL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
NOUNIT = LSAME( DIAG, 'N' )
*
IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
INFO = -1
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTPCON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
END IF
*
RCOND = ZERO
SMLNUM = DLAMCH( 'Safe minimum' )*DBLE( MAX( 1, N ) )
*
* Compute the norm of the triangular matrix A.
*
ANORM = DLANTP( NORM, UPLO, DIAG, N, AP, WORK )
*
* Continue only if ANORM > 0.
*
IF( ANORM.GT.ZERO ) THEN
*
* Estimate the norm of the inverse of A.
*
AINVNM = ZERO
NORMIN = 'N'
IF( ONENRM ) THEN
KASE1 = 1
ELSE
KASE1 = 2
END IF
KASE = 0
10 CONTINUE
CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.KASE1 ) THEN
*
* Multiply by inv(A).
*
CALL DLATPS( UPLO, 'No transpose', DIAG, NORMIN, N, AP,
$ WORK, SCALE, WORK( 2*N+1 ), INFO )
ELSE
*
* Multiply by inv(A').
*
CALL DLATPS( UPLO, 'Transpose', DIAG, NORMIN, N, AP,
$ WORK, SCALE, WORK( 2*N+1 ), INFO )
END IF
NORMIN = 'Y'
*
* Multiply by 1/SCALE if doing so will not cause overflow.
*
IF( SCALE.NE.ONE ) THEN
IX = IDAMAX( N, WORK, 1 )
XNORM = ABS( WORK( IX ) )
IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO )
$ GO TO 20
CALL DRSCL( N, SCALE, WORK, 1 )
END IF
GO TO 10
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / ANORM ) / AINVNM
END IF
*
20 CONTINUE
RETURN
*
* End of DTPCON
*
END
SUBROUTINE DTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX,
$ FERR, BERR, WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER INFO, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION AP( * ), B( LDB, * ), BERR( * ), FERR( * ),
$ WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* DTPRFS provides error bounds and backward error estimates for the
* solution to a system of linear equations with a triangular packed
* coefficient matrix.
*
* The solution matrix X must be computed by DTPTRS or some other
* means before entering this routine. DTPRFS does not do iterative
* refinement because doing so cannot improve the backward error.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': A is upper triangular;
* = 'L': A is lower triangular.
*
* 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**H * X = B (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* = 'N': A is non-unit triangular;
* = 'U': A is unit triangular.
*
* 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 matrices B and X. NRHS >= 0.
*
* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The upper or lower triangular matrix A, packed columnwise in
* a linear array. The j-th column of A is stored in the array
* AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
* If DIAG = 'U', the diagonal elements of A are not referenced
* and are assumed to be 1.
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN, NOUNIT, UPPER
CHARACTER TRANST
INTEGER I, J, K, KASE, KC, NZ
DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DLACN2, DTPMV, DTPSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOTRAN = LSAME( TRANS, 'N' )
NOUNIT = LSAME( DIAG, 'N' )
*
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
$ LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( NRHS.LT.0 ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTPRFS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
DO 10 J = 1, NRHS
FERR( J ) = ZERO
BERR( J ) = ZERO
10 CONTINUE
RETURN
END IF
*
IF( NOTRAN ) THEN
TRANST = 'T'
ELSE
TRANST = 'N'
END IF
*
* NZ = maximum number of nonzero elements in each row of A, plus 1
*
NZ = N + 1
EPS = DLAMCH( 'Epsilon' )
SAFMIN = DLAMCH( 'Safe minimum' )
SAFE1 = NZ*SAFMIN
SAFE2 = SAFE1 / EPS
*
* Do for each right hand side
*
DO 250 J = 1, NRHS
*
* Compute residual R = B - op(A) * X,
* where op(A) = A or A', depending on TRANS.
*
CALL DCOPY( N, X( 1, J ), 1, WORK( N+1 ), 1 )
CALL DTPMV( UPLO, TRANS, DIAG, N, AP, WORK( N+1 ), 1 )
CALL DAXPY( N, -ONE, B( 1, J ), 1, WORK( N+1 ), 1 )
*
* Compute componentwise relative backward error from formula
*
* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
*
* where abs(Z) is the componentwise absolute value of the matrix
* or vector Z. If the i-th component of the denominator is less
* than SAFE2, then SAFE1 is added to the i-th components of the
* numerator and denominator before dividing.
*
DO 20 I = 1, N
WORK( I ) = ABS( B( I, J ) )
20 CONTINUE
*
IF( NOTRAN ) THEN
*
* Compute abs(A)*abs(X) + abs(B).
*
IF( UPPER ) THEN
KC = 1
IF( NOUNIT ) THEN
DO 40 K = 1, N
XK = ABS( X( K, J ) )
DO 30 I = 1, K
WORK( I ) = WORK( I ) + ABS( AP( KC+I-1 ) )*XK
30 CONTINUE
KC = KC + K
40 CONTINUE
ELSE
DO 60 K = 1, N
XK = ABS( X( K, J ) )
DO 50 I = 1, K - 1
WORK( I ) = WORK( I ) + ABS( AP( KC+I-1 ) )*XK
50 CONTINUE
WORK( K ) = WORK( K ) + XK
KC = KC + K
60 CONTINUE
END IF
ELSE
KC = 1
IF( NOUNIT ) THEN
DO 80 K = 1, N
XK = ABS( X( K, J ) )
DO 70 I = K, N
WORK( I ) = WORK( I ) + ABS( AP( KC+I-K ) )*XK
70 CONTINUE
KC = KC + N - K + 1
80 CONTINUE
ELSE
DO 100 K = 1, N
XK = ABS( X( K, J ) )
DO 90 I = K + 1, N
WORK( I ) = WORK( I ) + ABS( AP( KC+I-K ) )*XK
90 CONTINUE
WORK( K ) = WORK( K ) + XK
KC = KC + N - K + 1
100 CONTINUE
END IF
END IF
ELSE
*
* Compute abs(A')*abs(X) + abs(B).
*
IF( UPPER ) THEN
KC = 1
IF( NOUNIT ) THEN
DO 120 K = 1, N
S = ZERO
DO 110 I = 1, K
S = S + ABS( AP( KC+I-1 ) )*ABS( X( I, J ) )
110 CONTINUE
WORK( K ) = WORK( K ) + S
KC = KC + K
120 CONTINUE
ELSE
DO 140 K = 1, N
S = ABS( X( K, J ) )
DO 130 I = 1, K - 1
S = S + ABS( AP( KC+I-1 ) )*ABS( X( I, J ) )
130 CONTINUE
WORK( K ) = WORK( K ) + S
KC = KC + K
140 CONTINUE
END IF
ELSE
KC = 1
IF( NOUNIT ) THEN
DO 160 K = 1, N
S = ZERO
DO 150 I = K, N
S = S + ABS( AP( KC+I-K ) )*ABS( X( I, J ) )
150 CONTINUE
WORK( K ) = WORK( K ) + S
KC = KC + N - K + 1
160 CONTINUE
ELSE
DO 180 K = 1, N
S = ABS( X( K, J ) )
DO 170 I = K + 1, N
S = S + ABS( AP( KC+I-K ) )*ABS( X( I, J ) )
170 CONTINUE
WORK( K ) = WORK( K ) + S
KC = KC + N - K + 1
180 CONTINUE
END IF
END IF
END IF
S = ZERO
DO 190 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
ELSE
S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
$ ( WORK( I )+SAFE1 ) )
END IF
190 CONTINUE
BERR( J ) = S
*
* Bound error from formula
*
* norm(X - XTRUE) / norm(X) .le. FERR =
* norm( abs(inv(op(A)))*
* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
*
* where
* norm(Z) is the magnitude of the largest component of Z
* inv(op(A)) is the inverse of op(A)
* abs(Z) is the componentwise absolute value of the matrix or
* vector Z
* NZ is the maximum number of nonzeros in any row of A, plus 1
* EPS is machine epsilon
*
* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
* is incremented by SAFE1 if the i-th component of
* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
*
* Use DLACN2 to estimate the infinity-norm of the matrix
* inv(op(A)) * diag(W),
* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
*
DO 200 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
ELSE
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
END IF
200 CONTINUE
*
KASE = 0
210 CONTINUE
CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
$ KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Multiply by diag(W)*inv(op(A)').
*
CALL DTPSV( UPLO, TRANST, DIAG, N, AP, WORK( N+1 ), 1 )
DO 220 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
220 CONTINUE
ELSE
*
* Multiply by inv(op(A))*diag(W).
*
DO 230 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
230 CONTINUE
CALL DTPSV( UPLO, TRANS, DIAG, N, AP, WORK( N+1 ), 1 )
END IF
GO TO 210
END IF
*
* Normalize error.
*
LSTRES = ZERO
DO 240 I = 1, N
LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
240 CONTINUE
IF( LSTRES.NE.ZERO )
$ FERR( J ) = FERR( J ) / LSTRES
*
250 CONTINUE
*
RETURN
*
* End of DTPRFS
*
END
SUBROUTINE DTPTRI( UPLO, DIAG, N, AP, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, UPLO
INTEGER INFO, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP( * )
* ..
*
* Purpose
* =======
*
* DTPTRI computes the inverse of a real upper or lower triangular
* matrix A stored in packed format.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': A is upper triangular;
* = 'L': A is lower triangular.
*
* DIAG (input) CHARACTER*1
* = 'N': A is non-unit triangular;
* = 'U': A is unit triangular.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangular matrix A, stored
* columnwise in a linear array. The j-th column of A is stored
* in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n.
* See below for further details.
* On exit, the (triangular) inverse of the original matrix, in
* the same packed storage format.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, A(i,i) is exactly zero. The triangular
* matrix is singular and its inverse can not be computed.
*
* Further Details
* ===============
*
* A triangular matrix A can be transferred to packed storage using one
* of the following program segments:
*
* UPLO = 'U': UPLO = 'L':
*
* JC = 1 JC = 1
* DO 2 J = 1, N DO 2 J = 1, N
* DO 1 I = 1, J DO 1 I = J, N
* AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J)
* 1 CONTINUE 1 CONTINUE
* JC = JC + J JC = JC + N - J + 1
* 2 CONTINUE 2 CONTINUE
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT, UPPER
INTEGER J, JC, JCLAST, JJ
DOUBLE PRECISION AJJ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, DTPMV, XERBLA
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOUNIT = LSAME( DIAG, 'N' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTPTRI', -INFO )
RETURN
END IF
*
* Check for singularity if non-unit.
*
IF( NOUNIT ) THEN
IF( UPPER ) THEN
JJ = 0
DO 10 INFO = 1, N
JJ = JJ + INFO
IF( AP( JJ ).EQ.ZERO )
$ RETURN
10 CONTINUE
ELSE
JJ = 1
DO 20 INFO = 1, N
IF( AP( JJ ).EQ.ZERO )
$ RETURN
JJ = JJ + N - INFO + 1
20 CONTINUE
END IF
INFO = 0
END IF
*
IF( UPPER ) THEN
*
* Compute inverse of upper triangular matrix.
*
JC = 1
DO 30 J = 1, N
IF( NOUNIT ) THEN
AP( JC+J-1 ) = ONE / AP( JC+J-1 )
AJJ = -AP( JC+J-1 )
ELSE
AJJ = -ONE
END IF
*
* Compute elements 1:j-1 of j-th column.
*
CALL DTPMV( 'Upper', 'No transpose', DIAG, J-1, AP,
$ AP( JC ), 1 )
CALL DSCAL( J-1, AJJ, AP( JC ), 1 )
JC = JC + J
30 CONTINUE
*
ELSE
*
* Compute inverse of lower triangular matrix.
*
JC = N*( N+1 ) / 2
DO 40 J = N, 1, -1
IF( NOUNIT ) THEN
AP( JC ) = ONE / AP( JC )
AJJ = -AP( JC )
ELSE
AJJ = -ONE
END IF
IF( J.LT.N ) THEN
*
* Compute elements j+1:n of j-th column.
*
CALL DTPMV( 'Lower', 'No transpose', DIAG, N-J,
$ AP( JCLAST ), AP( JC+1 ), 1 )
CALL DSCAL( N-J, AJJ, AP( JC+1 ), 1 )
END IF
JCLAST = JC
JC = JC - N + J - 2
40 CONTINUE
END IF
*
RETURN
*
* End of DTPTRI
*
END
SUBROUTINE DTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP( * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* DTPTRS solves a triangular system of the form
*
* A * X = B or A**T * X = B,
*
* where A is a triangular matrix of order N stored in packed format,
* and B is an N-by-NRHS matrix. A check is made to verify that A is
* nonsingular.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': A is upper triangular;
* = 'L': A is lower triangular.
*
* 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**H * X = B (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* = 'N': A is non-unit triangular;
* = 'U': A is unit triangular.
*
* 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.
*
* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The upper or lower triangular matrix A, packed columnwise in
* a linear array. The j-th column of A is stored in the array
* AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the right hand side matrix B.
* On exit, if INFO = 0, 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
* > 0: if INFO = i, the i-th diagonal element of A is zero,
* indicating that the matrix is singular and the
* solutions X have not been computed.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT, UPPER
INTEGER J, JC
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DTPSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOUNIT = LSAME( DIAG, 'N' )
IF( .NOT.UPPER .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.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( NRHS.LT.0 ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTPTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Check for singularity.
*
IF( NOUNIT ) THEN
IF( UPPER ) THEN
JC = 1
DO 10 INFO = 1, N
IF( AP( JC+INFO-1 ).EQ.ZERO )
$ RETURN
JC = JC + INFO
10 CONTINUE
ELSE
JC = 1
DO 20 INFO = 1, N
IF( AP( JC ).EQ.ZERO )
$ RETURN
JC = JC + N - INFO + 1
20 CONTINUE
END IF
END IF
INFO = 0
*
* Solve A * x = b or A' * x = b.
*
DO 30 J = 1, NRHS
CALL DTPSV( UPLO, TRANS, DIAG, N, AP, B( 1, J ), 1 )
30 CONTINUE
*
RETURN
*
* End of DTPTRS
*
END
SUBROUTINE DTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK,
$ IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER DIAG, NORM, UPLO
INTEGER INFO, LDA, N
DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DTRCON estimates the reciprocal of the condition number of a
* triangular matrix A, in either the 1-norm or the infinity-norm.
*
* The norm of A is computed and an estimate is obtained for
* norm(inv(A)), then the reciprocal of the condition number is
* computed as
* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies whether the 1-norm condition number or the
* infinity-norm condition number is required:
* = '1' or 'O': 1-norm;
* = 'I': Infinity-norm.
*
* UPLO (input) CHARACTER*1
* = 'U': A is upper triangular;
* = 'L': A is lower triangular.
*
* DIAG (input) CHARACTER*1
* = 'N': A is non-unit triangular;
* = 'U': A is unit triangular.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The triangular matrix A. If UPLO = 'U', the leading N-by-N
* upper triangular part of the array A contains the upper
* triangular matrix, and the strictly lower triangular part of
* A is not referenced. If UPLO = 'L', the leading N-by-N lower
* triangular part of the array A contains the lower triangular
* matrix, and the strictly upper triangular part of A is not
* referenced. If DIAG = 'U', the diagonal elements of A are
* also not referenced and are assumed to be 1.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* RCOND (output) DOUBLE PRECISION
* The reciprocal of the condition number of the matrix A,
* computed as RCOND = 1/(norm(A) * norm(inv(A))).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT, ONENRM, UPPER
CHARACTER NORMIN
INTEGER IX, KASE, KASE1
DOUBLE PRECISION AINVNM, ANORM, SCALE, SMLNUM, XNORM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH, DLANTR
EXTERNAL LSAME, IDAMAX, DLAMCH, DLANTR
* ..
* .. External Subroutines ..
EXTERNAL DLACN2, DLATRS, DRSCL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
NOUNIT = LSAME( DIAG, 'N' )
*
IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
INFO = -1
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTRCON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
END IF
*
RCOND = ZERO
SMLNUM = DLAMCH( 'Safe minimum' )*DBLE( MAX( 1, N ) )
*
* Compute the norm of the triangular matrix A.
*
ANORM = DLANTR( NORM, UPLO, DIAG, N, N, A, LDA, WORK )
*
* Continue only if ANORM > 0.
*
IF( ANORM.GT.ZERO ) THEN
*
* Estimate the norm of the inverse of A.
*
AINVNM = ZERO
NORMIN = 'N'
IF( ONENRM ) THEN
KASE1 = 1
ELSE
KASE1 = 2
END IF
KASE = 0
10 CONTINUE
CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.KASE1 ) THEN
*
* Multiply by inv(A).
*
CALL DLATRS( UPLO, 'No transpose', DIAG, NORMIN, N, A,
$ LDA, WORK, SCALE, WORK( 2*N+1 ), INFO )
ELSE
*
* Multiply by inv(A').
*
CALL DLATRS( UPLO, 'Transpose', DIAG, NORMIN, N, A, LDA,
$ WORK, SCALE, WORK( 2*N+1 ), INFO )
END IF
NORMIN = 'Y'
*
* Multiply by 1/SCALE if doing so will not cause overflow.
*
IF( SCALE.NE.ONE ) THEN
IX = IDAMAX( N, WORK, 1 )
XNORM = ABS( WORK( IX ) )
IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO )
$ GO TO 20
CALL DRSCL( N, SCALE, WORK, 1 )
END IF
GO TO 10
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / ANORM ) / AINVNM
END IF
*
20 CONTINUE
RETURN
*
* End of DTRCON
*
END
SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
$ LDVR, MM, M, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER HOWMNY, SIDE
INTEGER INFO, LDT, LDVL, LDVR, M, MM, N
* ..
* .. Array Arguments ..
LOGICAL SELECT( * )
DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* DTREVC computes some or all of the right and/or left eigenvectors of
* a real upper quasi-triangular matrix T.
* Matrices of this type are produced by the Schur factorization of
* a real general matrix: A = Q*T*Q**T, as computed by DHSEQR.
*
* The right eigenvector x and the left eigenvector y of T corresponding
* to an eigenvalue w are defined by:
*
* T*x = w*x, (y**H)*T = w*(y**H)
*
* where y**H denotes the conjugate transpose of y.
* The eigenvalues are not input to this routine, but are read directly
* from the diagonal blocks of T.
*
* This routine returns the matrices X and/or Y of right and left
* eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
* input matrix. If Q is the orthogonal factor that reduces a matrix
* A to Schur form T, then Q*X and Q*Y are the matrices of right and
* left eigenvectors of A.
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* = 'R': compute right eigenvectors only;
* = 'L': compute left eigenvectors only;
* = 'B': compute both right and left eigenvectors.
*
* HOWMNY (input) CHARACTER*1
* = 'A': compute all right and/or left eigenvectors;
* = 'B': compute all right and/or left eigenvectors,
* backtransformed by the matrices in VR and/or VL;
* = 'S': compute selected right and/or left eigenvectors,
* as indicated by the logical array SELECT.
*
* SELECT (input/output) LOGICAL array, dimension (N)
* If HOWMNY = 'S', SELECT specifies the eigenvectors to be
* computed.
* If w(j) is a real eigenvalue, the corresponding real
* eigenvector is computed if SELECT(j) is .TRUE..
* If w(j) and w(j+1) are the real and imaginary parts of a
* complex eigenvalue, the corresponding complex eigenvector is
* computed if either SELECT(j) or SELECT(j+1) is .TRUE., and
* on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to
* .FALSE..
* Not referenced if HOWMNY = 'A' or 'B'.
*
* N (input) INTEGER
* The order of the matrix T. N >= 0.
*
* T (input) DOUBLE PRECISION array, dimension (LDT,N)
* The upper quasi-triangular matrix T in Schur canonical form.
*
* LDT (input) INTEGER
* The leading dimension of the array T. LDT >= max(1,N).
*
* VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)
* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
* contain an N-by-N matrix Q (usually the orthogonal matrix Q
* of Schur vectors returned by DHSEQR).
* On exit, if SIDE = 'L' or 'B', VL contains:
* if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
* if HOWMNY = 'B', the matrix Q*Y;
* if HOWMNY = 'S', the left eigenvectors of T specified by
* SELECT, stored consecutively in the columns
* of VL, in the same order as their
* eigenvalues.
* A complex eigenvector corresponding to a complex eigenvalue
* is stored in two consecutive columns, the first holding the
* real part, and the second the imaginary part.
* Not referenced if SIDE = 'R'.
*
* LDVL (input) INTEGER
* The leading dimension of the array VL. LDVL >= 1, and if
* SIDE = 'L' or 'B', LDVL >= N.
*
* VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)
* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
* contain an N-by-N matrix Q (usually the orthogonal matrix Q
* of Schur vectors returned by DHSEQR).
* On exit, if SIDE = 'R' or 'B', VR contains:
* if HOWMNY = 'A', the matrix X of right eigenvectors of T;
* if HOWMNY = 'B', the matrix Q*X;
* if HOWMNY = 'S', the right eigenvectors of T specified by
* SELECT, stored consecutively in the columns
* of VR, in the same order as their
* eigenvalues.
* A complex eigenvector corresponding to a complex eigenvalue
* is stored in two consecutive columns, the first holding the
* real part and the second the imaginary part.
* Not referenced if SIDE = 'L'.
*
* LDVR (input) INTEGER
* The leading dimension of the array VR. LDVR >= 1, and if
* SIDE = 'R' or 'B', LDVR >= N.
*
* MM (input) INTEGER
* The number of columns in the arrays VL and/or VR. MM >= M.
*
* M (output) INTEGER
* The number of columns in the arrays VL and/or VR actually
* used to store the eigenvectors.
* If HOWMNY = 'A' or 'B', M is set to N.
* Each selected real eigenvector occupies one column and each
* selected complex eigenvector occupies two columns.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Further Details
* ===============
*
* The algorithm used in this program is basically backward (forward)
* substitution, with scaling to make the the code robust against
* possible overflow.
*
* Each eigenvector is normalized so that the element of largest
* magnitude has magnitude 1; here the magnitude of a complex number
* (x,y) is taken to be |x| + |y|.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL ALLV, BOTHV, LEFTV, OVER, PAIR, RIGHTV, SOMEV
INTEGER I, IERR, II, IP, IS, J, J1, J2, JNXT, K, KI, N2
DOUBLE PRECISION BETA, BIGNUM, EMAX, OVFL, REC, REMAX, SCALE,
$ SMIN, SMLNUM, ULP, UNFL, VCRIT, VMAX, WI, WR,
$ XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DDOT, DLAMCH
EXTERNAL LSAME, IDAMAX, DDOT, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DGEMV, DLALN2, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Local Arrays ..
DOUBLE PRECISION X( 2, 2 )
* ..
* .. Executable Statements ..
*
* Decode and test the input parameters
*
BOTHV = LSAME( SIDE, 'B' )
RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV
LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV
*
ALLV = LSAME( HOWMNY, 'A' )
OVER = LSAME( HOWMNY, 'B' )
SOMEV = LSAME( HOWMNY, 'S' )
*
INFO = 0
IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
INFO = -1
ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN
INFO = -8
ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN
INFO = -10
ELSE
*
* Set M to the number of columns required to store the selected
* eigenvectors, standardize the array SELECT if necessary, and
* test MM.
*
IF( SOMEV ) THEN
M = 0
PAIR = .FALSE.
DO 10 J = 1, N
IF( PAIR ) THEN
PAIR = .FALSE.
SELECT( J ) = .FALSE.
ELSE
IF( J.LT.N ) THEN
IF( T( J+1, J ).EQ.ZERO ) THEN
IF( SELECT( J ) )
$ M = M + 1
ELSE
PAIR = .TRUE.
IF( SELECT( J ) .OR. SELECT( J+1 ) ) THEN
SELECT( J ) = .TRUE.
M = M + 2
END IF
END IF
ELSE
IF( SELECT( N ) )
$ M = M + 1
END IF
END IF
10 CONTINUE
ELSE
M = N
END IF
*
IF( MM.LT.M ) THEN
INFO = -11
END IF
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTREVC', -INFO )
RETURN
END IF
*
* Quick return if possible.
*
IF( N.EQ.0 )
$ RETURN
*
* Set the constants to control overflow.
*
UNFL = DLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
CALL DLABAD( UNFL, OVFL )
ULP = DLAMCH( 'Precision' )
SMLNUM = UNFL*( N / ULP )
BIGNUM = ( ONE-ULP ) / SMLNUM
*
* Compute 1-norm of each column of strictly upper triangular
* part of T to control overflow in triangular solver.
*
WORK( 1 ) = ZERO
DO 30 J = 2, N
WORK( J ) = ZERO
DO 20 I = 1, J - 1
WORK( J ) = WORK( J ) + ABS( T( I, J ) )
20 CONTINUE
30 CONTINUE
*
* Index IP is used to specify the real or complex eigenvalue:
* IP = 0, real eigenvalue,
* 1, first of conjugate complex pair: (wr,wi)
* -1, second of conjugate complex pair: (wr,wi)
*
N2 = 2*N
*
IF( RIGHTV ) THEN
*
* Compute right eigenvectors.
*
IP = 0
IS = M
DO 140 KI = N, 1, -1
*
IF( IP.EQ.1 )
$ GO TO 130
IF( KI.EQ.1 )
$ GO TO 40
IF( T( KI, KI-1 ).EQ.ZERO )
$ GO TO 40
IP = -1
*
40 CONTINUE
IF( SOMEV ) THEN
IF( IP.EQ.0 ) THEN
IF( .NOT.SELECT( KI ) )
$ GO TO 130
ELSE
IF( .NOT.SELECT( KI-1 ) )
$ GO TO 130
END IF
END IF
*
* Compute the KI-th eigenvalue (WR,WI).
*
WR = T( KI, KI )
WI = ZERO
IF( IP.NE.0 )
$ WI = SQRT( ABS( T( KI, KI-1 ) ) )*
$ SQRT( ABS( T( KI-1, KI ) ) )
SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM )
*
IF( IP.EQ.0 ) THEN
*
* Real right eigenvector
*
WORK( KI+N ) = ONE
*
* Form right-hand side
*
DO 50 K = 1, KI - 1
WORK( K+N ) = -T( K, KI )
50 CONTINUE
*
* Solve the upper quasi-triangular system:
* (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK.
*
JNXT = KI - 1
DO 60 J = KI - 1, 1, -1
IF( J.GT.JNXT )
$ GO TO 60
J1 = J
J2 = J
JNXT = J - 1
IF( J.GT.1 ) THEN
IF( T( J, J-1 ).NE.ZERO ) THEN
J1 = J - 1
JNXT = J - 2
END IF
END IF
*
IF( J1.EQ.J2 ) THEN
*
* 1-by-1 diagonal block
*
CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ),
$ LDT, ONE, ONE, WORK( J+N ), N, WR,
$ ZERO, X, 2, SCALE, XNORM, IERR )
*
* Scale X(1,1) to avoid overflow when updating
* the right-hand side.
*
IF( XNORM.GT.ONE ) THEN
IF( WORK( J ).GT.BIGNUM / XNORM ) THEN
X( 1, 1 ) = X( 1, 1 ) / XNORM
SCALE = SCALE / XNORM
END IF
END IF
*
* Scale if necessary
*
IF( SCALE.NE.ONE )
$ CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 )
WORK( J+N ) = X( 1, 1 )
*
* Update right-hand side
*
CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1,
$ WORK( 1+N ), 1 )
*
ELSE
*
* 2-by-2 diagonal block
*
CALL DLALN2( .FALSE., 2, 1, SMIN, ONE,
$ T( J-1, J-1 ), LDT, ONE, ONE,
$ WORK( J-1+N ), N, WR, ZERO, X, 2,
$ SCALE, XNORM, IERR )
*
* Scale X(1,1) and X(2,1) to avoid overflow when
* updating the right-hand side.
*
IF( XNORM.GT.ONE ) THEN
BETA = MAX( WORK( J-1 ), WORK( J ) )
IF( BETA.GT.BIGNUM / XNORM ) THEN
X( 1, 1 ) = X( 1, 1 ) / XNORM
X( 2, 1 ) = X( 2, 1 ) / XNORM
SCALE = SCALE / XNORM
END IF
END IF
*
* Scale if necessary
*
IF( SCALE.NE.ONE )
$ CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 )
WORK( J-1+N ) = X( 1, 1 )
WORK( J+N ) = X( 2, 1 )
*
* Update right-hand side
*
CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1,
$ WORK( 1+N ), 1 )
CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1,
$ WORK( 1+N ), 1 )
END IF
60 CONTINUE
*
* Copy the vector x or Q*x to VR and normalize.
*
IF( .NOT.OVER ) THEN
CALL DCOPY( KI, WORK( 1+N ), 1, VR( 1, IS ), 1 )
*
II = IDAMAX( KI, VR( 1, IS ), 1 )
REMAX = ONE / ABS( VR( II, IS ) )
CALL DSCAL( KI, REMAX, VR( 1, IS ), 1 )
*
DO 70 K = KI + 1, N
VR( K, IS ) = ZERO
70 CONTINUE
ELSE
IF( KI.GT.1 )
$ CALL DGEMV( 'N', N, KI-1, ONE, VR, LDVR,
$ WORK( 1+N ), 1, WORK( KI+N ),
$ VR( 1, KI ), 1 )
*
II = IDAMAX( N, VR( 1, KI ), 1 )
REMAX = ONE / ABS( VR( II, KI ) )
CALL DSCAL( N, REMAX, VR( 1, KI ), 1 )
END IF
*
ELSE
*
* Complex right eigenvector.
*
* Initial solve
* [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]*X = 0.
* [ (T(KI,KI-1) T(KI,KI) ) ]
*
IF( ABS( T( KI-1, KI ) ).GE.ABS( T( KI, KI-1 ) ) ) THEN
WORK( KI-1+N ) = ONE
WORK( KI+N2 ) = WI / T( KI-1, KI )
ELSE
WORK( KI-1+N ) = -WI / T( KI, KI-1 )
WORK( KI+N2 ) = ONE
END IF
WORK( KI+N ) = ZERO
WORK( KI-1+N2 ) = ZERO
*
* Form right-hand side
*
DO 80 K = 1, KI - 2
WORK( K+N ) = -WORK( KI-1+N )*T( K, KI-1 )
WORK( K+N2 ) = -WORK( KI+N2 )*T( K, KI )
80 CONTINUE
*
* Solve upper quasi-triangular system:
* (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2)
*
JNXT = KI - 2
DO 90 J = KI - 2, 1, -1
IF( J.GT.JNXT )
$ GO TO 90
J1 = J
J2 = J
JNXT = J - 1
IF( J.GT.1 ) THEN
IF( T( J, J-1 ).NE.ZERO ) THEN
J1 = J - 1
JNXT = J - 2
END IF
END IF
*
IF( J1.EQ.J2 ) THEN
*
* 1-by-1 diagonal block
*
CALL DLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ),
$ LDT, ONE, ONE, WORK( J+N ), N, WR, WI,
$ X, 2, SCALE, XNORM, IERR )
*
* Scale X(1,1) and X(1,2) to avoid overflow when
* updating the right-hand side.
*
IF( XNORM.GT.ONE ) THEN
IF( WORK( J ).GT.BIGNUM / XNORM ) THEN
X( 1, 1 ) = X( 1, 1 ) / XNORM
X( 1, 2 ) = X( 1, 2 ) / XNORM
SCALE = SCALE / XNORM
END IF
END IF
*
* Scale if necessary
*
IF( SCALE.NE.ONE ) THEN
CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 )
CALL DSCAL( KI, SCALE, WORK( 1+N2 ), 1 )
END IF
WORK( J+N ) = X( 1, 1 )
WORK( J+N2 ) = X( 1, 2 )
*
* Update the right-hand side
*
CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1,
$ WORK( 1+N ), 1 )
CALL DAXPY( J-1, -X( 1, 2 ), T( 1, J ), 1,
$ WORK( 1+N2 ), 1 )
*
ELSE
*
* 2-by-2 diagonal block
*
CALL DLALN2( .FALSE., 2, 2, SMIN, ONE,
$ T( J-1, J-1 ), LDT, ONE, ONE,
$ WORK( J-1+N ), N, WR, WI, X, 2, SCALE,
$ XNORM, IERR )
*
* Scale X to avoid overflow when updating
* the right-hand side.
*
IF( XNORM.GT.ONE ) THEN
BETA = MAX( WORK( J-1 ), WORK( J ) )
IF( BETA.GT.BIGNUM / XNORM ) THEN
REC = ONE / XNORM
X( 1, 1 ) = X( 1, 1 )*REC
X( 1, 2 ) = X( 1, 2 )*REC
X( 2, 1 ) = X( 2, 1 )*REC
X( 2, 2 ) = X( 2, 2 )*REC
SCALE = SCALE*REC
END IF
END IF
*
* Scale if necessary
*
IF( SCALE.NE.ONE ) THEN
CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 )
CALL DSCAL( KI, SCALE, WORK( 1+N2 ), 1 )
END IF
WORK( J-1+N ) = X( 1, 1 )
WORK( J+N ) = X( 2, 1 )
WORK( J-1+N2 ) = X( 1, 2 )
WORK( J+N2 ) = X( 2, 2 )
*
* Update the right-hand side
*
CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1,
$ WORK( 1+N ), 1 )
CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1,
$ WORK( 1+N ), 1 )
CALL DAXPY( J-2, -X( 1, 2 ), T( 1, J-1 ), 1,
$ WORK( 1+N2 ), 1 )
CALL DAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1,
$ WORK( 1+N2 ), 1 )
END IF
90 CONTINUE
*
* Copy the vector x or Q*x to VR and normalize.
*
IF( .NOT.OVER ) THEN
CALL DCOPY( KI, WORK( 1+N ), 1, VR( 1, IS-1 ), 1 )
CALL DCOPY( KI, WORK( 1+N2 ), 1, VR( 1, IS ), 1 )
*
EMAX = ZERO
DO 100 K = 1, KI
EMAX = MAX( EMAX, ABS( VR( K, IS-1 ) )+
$ ABS( VR( K, IS ) ) )
100 CONTINUE
*
REMAX = ONE / EMAX
CALL DSCAL( KI, REMAX, VR( 1, IS-1 ), 1 )
CALL DSCAL( KI, REMAX, VR( 1, IS ), 1 )
*
DO 110 K = KI + 1, N
VR( K, IS-1 ) = ZERO
VR( K, IS ) = ZERO
110 CONTINUE
*
ELSE
*
IF( KI.GT.2 ) THEN
CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR,
$ WORK( 1+N ), 1, WORK( KI-1+N ),
$ VR( 1, KI-1 ), 1 )
CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR,
$ WORK( 1+N2 ), 1, WORK( KI+N2 ),
$ VR( 1, KI ), 1 )
ELSE
CALL DSCAL( N, WORK( KI-1+N ), VR( 1, KI-1 ), 1 )
CALL DSCAL( N, WORK( KI+N2 ), VR( 1, KI ), 1 )
END IF
*
EMAX = ZERO
DO 120 K = 1, N
EMAX = MAX( EMAX, ABS( VR( K, KI-1 ) )+
$ ABS( VR( K, KI ) ) )
120 CONTINUE
REMAX = ONE / EMAX
CALL DSCAL( N, REMAX, VR( 1, KI-1 ), 1 )
CALL DSCAL( N, REMAX, VR( 1, KI ), 1 )
END IF
END IF
*
IS = IS - 1
IF( IP.NE.0 )
$ IS = IS - 1
130 CONTINUE
IF( IP.EQ.1 )
$ IP = 0
IF( IP.EQ.-1 )
$ IP = 1
140 CONTINUE
END IF
*
IF( LEFTV ) THEN
*
* Compute left eigenvectors.
*
IP = 0
IS = 1
DO 260 KI = 1, N
*
IF( IP.EQ.-1 )
$ GO TO 250
IF( KI.EQ.N )
$ GO TO 150
IF( T( KI+1, KI ).EQ.ZERO )
$ GO TO 150
IP = 1
*
150 CONTINUE
IF( SOMEV ) THEN
IF( .NOT.SELECT( KI ) )
$ GO TO 250
END IF
*
* Compute the KI-th eigenvalue (WR,WI).
*
WR = T( KI, KI )
WI = ZERO
IF( IP.NE.0 )
$ WI = SQRT( ABS( T( KI, KI+1 ) ) )*
$ SQRT( ABS( T( KI+1, KI ) ) )
SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM )
*
IF( IP.EQ.0 ) THEN
*
* Real left eigenvector.
*
WORK( KI+N ) = ONE
*
* Form right-hand side
*
DO 160 K = KI + 1, N
WORK( K+N ) = -T( KI, K )
160 CONTINUE
*
* Solve the quasi-triangular system:
* (T(KI+1:N,KI+1:N) - WR)'*X = SCALE*WORK
*
VMAX = ONE
VCRIT = BIGNUM
*
JNXT = KI + 1
DO 170 J = KI + 1, N
IF( J.LT.JNXT )
$ GO TO 170
J1 = J
J2 = J
JNXT = J + 1
IF( J.LT.N ) THEN
IF( T( J+1, J ).NE.ZERO ) THEN
J2 = J + 1
JNXT = J + 2
END IF
END IF
*
IF( J1.EQ.J2 ) THEN
*
* 1-by-1 diagonal block
*
* Scale if necessary to avoid overflow when forming
* the right-hand side.
*
IF( WORK( J ).GT.VCRIT ) THEN
REC = ONE / VMAX
CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
VMAX = ONE
VCRIT = BIGNUM
END IF
*
WORK( J+N ) = WORK( J+N ) -
$ DDOT( J-KI-1, T( KI+1, J ), 1,
$ WORK( KI+1+N ), 1 )
*
* Solve (T(J,J)-WR)'*X = WORK
*
CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ),
$ LDT, ONE, ONE, WORK( J+N ), N, WR,
$ ZERO, X, 2, SCALE, XNORM, IERR )
*
* Scale if necessary
*
IF( SCALE.NE.ONE )
$ CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
WORK( J+N ) = X( 1, 1 )
VMAX = MAX( ABS( WORK( J+N ) ), VMAX )
VCRIT = BIGNUM / VMAX
*
ELSE
*
* 2-by-2 diagonal block
*
* Scale if necessary to avoid overflow when forming
* the right-hand side.
*
BETA = MAX( WORK( J ), WORK( J+1 ) )
IF( BETA.GT.VCRIT ) THEN
REC = ONE / VMAX
CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
VMAX = ONE
VCRIT = BIGNUM
END IF
*
WORK( J+N ) = WORK( J+N ) -
$ DDOT( J-KI-1, T( KI+1, J ), 1,
$ WORK( KI+1+N ), 1 )
*
WORK( J+1+N ) = WORK( J+1+N ) -
$ DDOT( J-KI-1, T( KI+1, J+1 ), 1,
$ WORK( KI+1+N ), 1 )
*
* Solve
* [T(J,J)-WR T(J,J+1) ]'* X = SCALE*( WORK1 )
* [T(J+1,J) T(J+1,J+1)-WR] ( WORK2 )
*
CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, T( J, J ),
$ LDT, ONE, ONE, WORK( J+N ), N, WR,
$ ZERO, X, 2, SCALE, XNORM, IERR )
*
* Scale if necessary
*
IF( SCALE.NE.ONE )
$ CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
WORK( J+N ) = X( 1, 1 )
WORK( J+1+N ) = X( 2, 1 )
*
VMAX = MAX( ABS( WORK( J+N ) ),
$ ABS( WORK( J+1+N ) ), VMAX )
VCRIT = BIGNUM / VMAX
*
END IF
170 CONTINUE
*
* Copy the vector x or Q*x to VL and normalize.
*
IF( .NOT.OVER ) THEN
CALL DCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 )
*
II = IDAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1
REMAX = ONE / ABS( VL( II, IS ) )
CALL DSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 )
*
DO 180 K = 1, KI - 1
VL( K, IS ) = ZERO
180 CONTINUE
*
ELSE
*
IF( KI.LT.N )
$ CALL DGEMV( 'N', N, N-KI, ONE, VL( 1, KI+1 ), LDVL,
$ WORK( KI+1+N ), 1, WORK( KI+N ),
$ VL( 1, KI ), 1 )
*
II = IDAMAX( N, VL( 1, KI ), 1 )
REMAX = ONE / ABS( VL( II, KI ) )
CALL DSCAL( N, REMAX, VL( 1, KI ), 1 )
*
END IF
*
ELSE
*
* Complex left eigenvector.
*
* Initial solve:
* ((T(KI,KI) T(KI,KI+1) )' - (WR - I* WI))*X = 0.
* ((T(KI+1,KI) T(KI+1,KI+1)) )
*
IF( ABS( T( KI, KI+1 ) ).GE.ABS( T( KI+1, KI ) ) ) THEN
WORK( KI+N ) = WI / T( KI, KI+1 )
WORK( KI+1+N2 ) = ONE
ELSE
WORK( KI+N ) = ONE
WORK( KI+1+N2 ) = -WI / T( KI+1, KI )
END IF
WORK( KI+1+N ) = ZERO
WORK( KI+N2 ) = ZERO
*
* Form right-hand side
*
DO 190 K = KI + 2, N
WORK( K+N ) = -WORK( KI+N )*T( KI, K )
WORK( K+N2 ) = -WORK( KI+1+N2 )*T( KI+1, K )
190 CONTINUE
*
* Solve complex quasi-triangular system:
* ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2
*
VMAX = ONE
VCRIT = BIGNUM
*
JNXT = KI + 2
DO 200 J = KI + 2, N
IF( J.LT.JNXT )
$ GO TO 200
J1 = J
J2 = J
JNXT = J + 1
IF( J.LT.N ) THEN
IF( T( J+1, J ).NE.ZERO ) THEN
J2 = J + 1
JNXT = J + 2
END IF
END IF
*
IF( J1.EQ.J2 ) THEN
*
* 1-by-1 diagonal block
*
* Scale if necessary to avoid overflow when
* forming the right-hand side elements.
*
IF( WORK( J ).GT.VCRIT ) THEN
REC = ONE / VMAX
CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
CALL DSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 )
VMAX = ONE
VCRIT = BIGNUM
END IF
*
WORK( J+N ) = WORK( J+N ) -
$ DDOT( J-KI-2, T( KI+2, J ), 1,
$ WORK( KI+2+N ), 1 )
WORK( J+N2 ) = WORK( J+N2 ) -
$ DDOT( J-KI-2, T( KI+2, J ), 1,
$ WORK( KI+2+N2 ), 1 )
*
* Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2
*
CALL DLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ),
$ LDT, ONE, ONE, WORK( J+N ), N, WR,
$ -WI, X, 2, SCALE, XNORM, IERR )
*
* Scale if necessary
*
IF( SCALE.NE.ONE ) THEN
CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
CALL DSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 )
END IF
WORK( J+N ) = X( 1, 1 )
WORK( J+N2 ) = X( 1, 2 )
VMAX = MAX( ABS( WORK( J+N ) ),
$ ABS( WORK( J+N2 ) ), VMAX )
VCRIT = BIGNUM / VMAX
*
ELSE
*
* 2-by-2 diagonal block
*
* Scale if necessary to avoid overflow when forming
* the right-hand side elements.
*
BETA = MAX( WORK( J ), WORK( J+1 ) )
IF( BETA.GT.VCRIT ) THEN
REC = ONE / VMAX
CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
CALL DSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 )
VMAX = ONE
VCRIT = BIGNUM
END IF
*
WORK( J+N ) = WORK( J+N ) -
$ DDOT( J-KI-2, T( KI+2, J ), 1,
$ WORK( KI+2+N ), 1 )
*
WORK( J+N2 ) = WORK( J+N2 ) -
$ DDOT( J-KI-2, T( KI+2, J ), 1,
$ WORK( KI+2+N2 ), 1 )
*
WORK( J+1+N ) = WORK( J+1+N ) -
$ DDOT( J-KI-2, T( KI+2, J+1 ), 1,
$ WORK( KI+2+N ), 1 )
*
WORK( J+1+N2 ) = WORK( J+1+N2 ) -
$ DDOT( J-KI-2, T( KI+2, J+1 ), 1,
$ WORK( KI+2+N2 ), 1 )
*
* Solve 2-by-2 complex linear equation
* ([T(j,j) T(j,j+1) ]'-(wr-i*wi)*I)*X = SCALE*B
* ([T(j+1,j) T(j+1,j+1)] )
*
CALL DLALN2( .TRUE., 2, 2, SMIN, ONE, T( J, J ),
$ LDT, ONE, ONE, WORK( J+N ), N, WR,
$ -WI, X, 2, SCALE, XNORM, IERR )
*
* Scale if necessary
*
IF( SCALE.NE.ONE ) THEN
CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
CALL DSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 )
END IF
WORK( J+N ) = X( 1, 1 )
WORK( J+N2 ) = X( 1, 2 )
WORK( J+1+N ) = X( 2, 1 )
WORK( J+1+N2 ) = X( 2, 2 )
VMAX = MAX( ABS( X( 1, 1 ) ), ABS( X( 1, 2 ) ),
$ ABS( X( 2, 1 ) ), ABS( X( 2, 2 ) ), VMAX )
VCRIT = BIGNUM / VMAX
*
END IF
200 CONTINUE
*
* Copy the vector x or Q*x to VL and normalize.
*
IF( .NOT.OVER ) THEN
CALL DCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 )
CALL DCOPY( N-KI+1, WORK( KI+N2 ), 1, VL( KI, IS+1 ),
$ 1 )
*
EMAX = ZERO
DO 220 K = KI, N
EMAX = MAX( EMAX, ABS( VL( K, IS ) )+
$ ABS( VL( K, IS+1 ) ) )
220 CONTINUE
REMAX = ONE / EMAX
CALL DSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 )
CALL DSCAL( N-KI+1, REMAX, VL( KI, IS+1 ), 1 )
*
DO 230 K = 1, KI - 1
VL( K, IS ) = ZERO
VL( K, IS+1 ) = ZERO
230 CONTINUE
ELSE
IF( KI.LT.N-1 ) THEN
CALL DGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ),
$ LDVL, WORK( KI+2+N ), 1, WORK( KI+N ),
$ VL( 1, KI ), 1 )
CALL DGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ),
$ LDVL, WORK( KI+2+N2 ), 1,
$ WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 )
ELSE
CALL DSCAL( N, WORK( KI+N ), VL( 1, KI ), 1 )
CALL DSCAL( N, WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 )
END IF
*
EMAX = ZERO
DO 240 K = 1, N
EMAX = MAX( EMAX, ABS( VL( K, KI ) )+
$ ABS( VL( K, KI+1 ) ) )
240 CONTINUE
REMAX = ONE / EMAX
CALL DSCAL( N, REMAX, VL( 1, KI ), 1 )
CALL DSCAL( N, REMAX, VL( 1, KI+1 ), 1 )
*
END IF
*
END IF
*
IS = IS + 1
IF( IP.NE.0 )
$ IS = IS + 1
250 CONTINUE
IF( IP.EQ.-1 )
$ IP = 0
IF( IP.EQ.1 )
$ IP = -1
*
260 CONTINUE
*
END IF
*
RETURN
*
* End of DTREVC
*
END
SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER COMPQ
INTEGER IFST, ILST, INFO, LDQ, LDT, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DTREXC reorders the real Schur factorization of a real matrix
* A = Q*T*Q**T, so that the diagonal block of T with row index IFST is
* moved to row ILST.
*
* The real Schur form T is reordered by an orthogonal similarity
* transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors
* is updated by postmultiplying it with Z.
*
* T must be in Schur canonical form (as returned by DHSEQR), that is,
* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
* 2-by-2 diagonal block has its diagonal elements equal and its
* off-diagonal elements of opposite sign.
*
* Arguments
* =========
*
* COMPQ (input) CHARACTER*1
* = 'V': update the matrix Q of Schur vectors;
* = 'N': do not update Q.
*
* N (input) INTEGER
* The order of the matrix T. N >= 0.
*
* T (input/output) DOUBLE PRECISION array, dimension (LDT,N)
* On entry, the upper quasi-triangular matrix T, in Schur
* Schur canonical form.
* On exit, the reordered upper quasi-triangular matrix, again
* in Schur canonical form.
*
* LDT (input) INTEGER
* The leading dimension of the array T. LDT >= max(1,N).
*
* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
* On exit, if COMPQ = 'V', Q has been postmultiplied by the
* orthogonal transformation matrix Z which reorders T.
* If COMPQ = 'N', Q is not referenced.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* IFST (input/output) INTEGER
* ILST (input/output) INTEGER
* Specify the reordering of the diagonal blocks of T.
* The block with row index IFST is moved to row ILST, by a
* sequence of transpositions between adjacent blocks.
* On exit, if IFST pointed on entry to the second row of a
* 2-by-2 block, it is changed to point to the first row; ILST
* always points to the first row of the block in its final
* position (which may differ from its input value by +1 or -1).
* 1 <= IFST <= N; 1 <= ILST <= N.
*
* 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
* = 1: two adjacent blocks were too close to swap (the problem
* is very ill-conditioned); T may have been partially
* reordered, and ILST points to the first row of the
* current position of the block being moved.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL WANTQ
INTEGER HERE, NBF, NBL, NBNEXT
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DLAEXC, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Decode and test the input arguments.
*
INFO = 0
WANTQ = LSAME( COMPQ, 'V' )
IF( .NOT.WANTQ .AND. .NOT.LSAME( COMPQ, 'N' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN
INFO = -6
ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN
INFO = -7
ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTREXC', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.1 )
$ RETURN
*
* Determine the first row of specified block
* and find out it is 1 by 1 or 2 by 2.
*
IF( IFST.GT.1 ) THEN
IF( T( IFST, IFST-1 ).NE.ZERO )
$ IFST = IFST - 1
END IF
NBF = 1
IF( IFST.LT.N ) THEN
IF( T( IFST+1, IFST ).NE.ZERO )
$ NBF = 2
END IF
*
* Determine the first row of the final block
* and find out it is 1 by 1 or 2 by 2.
*
IF( ILST.GT.1 ) THEN
IF( T( ILST, ILST-1 ).NE.ZERO )
$ ILST = ILST - 1
END IF
NBL = 1
IF( ILST.LT.N ) THEN
IF( T( ILST+1, ILST ).NE.ZERO )
$ NBL = 2
END IF
*
IF( IFST.EQ.ILST )
$ RETURN
*
IF( IFST.LT.ILST ) THEN
*
* Update ILST
*
IF( NBF.EQ.2 .AND. NBL.EQ.1 )
$ ILST = ILST - 1
IF( NBF.EQ.1 .AND. NBL.EQ.2 )
$ ILST = ILST + 1
*
HERE = IFST
*
10 CONTINUE
*
* Swap block with next one below
*
IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
*
* Current block either 1 by 1 or 2 by 2
*
NBNEXT = 1
IF( HERE+NBF+1.LE.N ) THEN
IF( T( HERE+NBF+1, HERE+NBF ).NE.ZERO )
$ NBNEXT = 2
END IF
CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, NBF, NBNEXT,
$ WORK, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
HERE = HERE + NBNEXT
*
* Test if 2 by 2 block breaks into two 1 by 1 blocks
*
IF( NBF.EQ.2 ) THEN
IF( T( HERE+1, HERE ).EQ.ZERO )
$ NBF = 3
END IF
*
ELSE
*
* Current block consists of two 1 by 1 blocks each of which
* must be swapped individually
*
NBNEXT = 1
IF( HERE+3.LE.N ) THEN
IF( T( HERE+3, HERE+2 ).NE.ZERO )
$ NBNEXT = 2
END IF
CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE+1, 1, NBNEXT,
$ WORK, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
IF( NBNEXT.EQ.1 ) THEN
*
* Swap two 1 by 1 blocks, no problems possible
*
CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, NBNEXT,
$ WORK, INFO )
HERE = HERE + 1
ELSE
*
* Recompute NBNEXT in case 2 by 2 split
*
IF( T( HERE+2, HERE+1 ).EQ.ZERO )
$ NBNEXT = 1
IF( NBNEXT.EQ.2 ) THEN
*
* 2 by 2 Block did not split
*
CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1,
$ NBNEXT, WORK, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
HERE = HERE + 2
ELSE
*
* 2 by 2 Block did split
*
CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1,
$ WORK, INFO )
CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE+1, 1, 1,
$ WORK, INFO )
HERE = HERE + 2
END IF
END IF
END IF
IF( HERE.LT.ILST )
$ GO TO 10
*
ELSE
*
HERE = IFST
20 CONTINUE
*
* Swap block with next one above
*
IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
*
* Current block either 1 by 1 or 2 by 2
*
NBNEXT = 1
IF( HERE.GE.3 ) THEN
IF( T( HERE-1, HERE-2 ).NE.ZERO )
$ NBNEXT = 2
END IF
CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-NBNEXT, NBNEXT,
$ NBF, WORK, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
HERE = HERE - NBNEXT
*
* Test if 2 by 2 block breaks into two 1 by 1 blocks
*
IF( NBF.EQ.2 ) THEN
IF( T( HERE+1, HERE ).EQ.ZERO )
$ NBF = 3
END IF
*
ELSE
*
* Current block consists of two 1 by 1 blocks each of which
* must be swapped individually
*
NBNEXT = 1
IF( HERE.GE.3 ) THEN
IF( T( HERE-1, HERE-2 ).NE.ZERO )
$ NBNEXT = 2
END IF
CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-NBNEXT, NBNEXT,
$ 1, WORK, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
IF( NBNEXT.EQ.1 ) THEN
*
* Swap two 1 by 1 blocks, no problems possible
*
CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, NBNEXT, 1,
$ WORK, INFO )
HERE = HERE - 1
ELSE
*
* Recompute NBNEXT in case 2 by 2 split
*
IF( T( HERE, HERE-1 ).EQ.ZERO )
$ NBNEXT = 1
IF( NBNEXT.EQ.2 ) THEN
*
* 2 by 2 Block did not split
*
CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-1, 2, 1,
$ WORK, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
HERE = HERE - 2
ELSE
*
* 2 by 2 Block did split
*
CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1,
$ WORK, INFO )
CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-1, 1, 1,
$ WORK, INFO )
HERE = HERE - 2
END IF
END IF
END IF
IF( HERE.GT.ILST )
$ GO TO 20
END IF
ILST = HERE
*
RETURN
*
* End of DTREXC
*
END
SUBROUTINE DTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X,
$ LDX, FERR, BERR, WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER INFO, LDA, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ),
$ WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* DTRRFS provides error bounds and backward error estimates for the
* solution to a system of linear equations with a triangular
* coefficient matrix.
*
* The solution matrix X must be computed by DTRTRS or some other
* means before entering this routine. DTRRFS does not do iterative
* refinement because doing so cannot improve the backward error.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': A is upper triangular;
* = 'L': A is lower triangular.
*
* 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**H * X = B (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* = 'N': A is non-unit triangular;
* = 'U': A is unit triangular.
*
* 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 matrices B and X. NRHS >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The triangular matrix A. If UPLO = 'U', the leading N-by-N
* upper triangular part of the array A contains the upper
* triangular matrix, and the strictly lower triangular part of
* A is not referenced. If UPLO = 'L', the leading N-by-N lower
* triangular part of the array A contains the lower triangular
* matrix, and the strictly upper triangular part of A is not
* referenced. If DIAG = 'U', the diagonal elements of A are
* also not referenced and are assumed to be 1.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN, NOUNIT, UPPER
CHARACTER TRANST
INTEGER I, J, K, KASE, NZ
DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DLACN2, DTRMV, DTRSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOTRAN = LSAME( TRANS, 'N' )
NOUNIT = LSAME( DIAG, 'N' )
*
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
$ LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( NRHS.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -11
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTRRFS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
DO 10 J = 1, NRHS
FERR( J ) = ZERO
BERR( J ) = ZERO
10 CONTINUE
RETURN
END IF
*
IF( NOTRAN ) THEN
TRANST = 'T'
ELSE
TRANST = 'N'
END IF
*
* NZ = maximum number of nonzero elements in each row of A, plus 1
*
NZ = N + 1
EPS = DLAMCH( 'Epsilon' )
SAFMIN = DLAMCH( 'Safe minimum' )
SAFE1 = NZ*SAFMIN
SAFE2 = SAFE1 / EPS
*
* Do for each right hand side
*
DO 250 J = 1, NRHS
*
* Compute residual R = B - op(A) * X,
* where op(A) = A or A', depending on TRANS.
*
CALL DCOPY( N, X( 1, J ), 1, WORK( N+1 ), 1 )
CALL DTRMV( UPLO, TRANS, DIAG, N, A, LDA, WORK( N+1 ), 1 )
CALL DAXPY( N, -ONE, B( 1, J ), 1, WORK( N+1 ), 1 )
*
* Compute componentwise relative backward error from formula
*
* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
*
* where abs(Z) is the componentwise absolute value of the matrix
* or vector Z. If the i-th component of the denominator is less
* than SAFE2, then SAFE1 is added to the i-th components of the
* numerator and denominator before dividing.
*
DO 20 I = 1, N
WORK( I ) = ABS( B( I, J ) )
20 CONTINUE
*
IF( NOTRAN ) THEN
*
* Compute abs(A)*abs(X) + abs(B).
*
IF( UPPER ) THEN
IF( NOUNIT ) THEN
DO 40 K = 1, N
XK = ABS( X( K, J ) )
DO 30 I = 1, K
WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
30 CONTINUE
40 CONTINUE
ELSE
DO 60 K = 1, N
XK = ABS( X( K, J ) )
DO 50 I = 1, K - 1
WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
50 CONTINUE
WORK( K ) = WORK( K ) + XK
60 CONTINUE
END IF
ELSE
IF( NOUNIT ) THEN
DO 80 K = 1, N
XK = ABS( X( K, J ) )
DO 70 I = K, N
WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
70 CONTINUE
80 CONTINUE
ELSE
DO 100 K = 1, N
XK = ABS( X( K, J ) )
DO 90 I = K + 1, N
WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
90 CONTINUE
WORK( K ) = WORK( K ) + XK
100 CONTINUE
END IF
END IF
ELSE
*
* Compute abs(A')*abs(X) + abs(B).
*
IF( UPPER ) THEN
IF( NOUNIT ) THEN
DO 120 K = 1, N
S = ZERO
DO 110 I = 1, K
S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
110 CONTINUE
WORK( K ) = WORK( K ) + S
120 CONTINUE
ELSE
DO 140 K = 1, N
S = ABS( X( K, J ) )
DO 130 I = 1, K - 1
S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
130 CONTINUE
WORK( K ) = WORK( K ) + S
140 CONTINUE
END IF
ELSE
IF( NOUNIT ) THEN
DO 160 K = 1, N
S = ZERO
DO 150 I = K, N
S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
150 CONTINUE
WORK( K ) = WORK( K ) + S
160 CONTINUE
ELSE
DO 180 K = 1, N
S = ABS( X( K, J ) )
DO 170 I = K + 1, N
S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
170 CONTINUE
WORK( K ) = WORK( K ) + S
180 CONTINUE
END IF
END IF
END IF
S = ZERO
DO 190 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
ELSE
S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
$ ( WORK( I )+SAFE1 ) )
END IF
190 CONTINUE
BERR( J ) = S
*
* Bound error from formula
*
* norm(X - XTRUE) / norm(X) .le. FERR =
* norm( abs(inv(op(A)))*
* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
*
* where
* norm(Z) is the magnitude of the largest component of Z
* inv(op(A)) is the inverse of op(A)
* abs(Z) is the componentwise absolute value of the matrix or
* vector Z
* NZ is the maximum number of nonzeros in any row of A, plus 1
* EPS is machine epsilon
*
* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
* is incremented by SAFE1 if the i-th component of
* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
*
* Use DLACN2 to estimate the infinity-norm of the matrix
* inv(op(A)) * diag(W),
* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
*
DO 200 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
ELSE
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
END IF
200 CONTINUE
*
KASE = 0
210 CONTINUE
CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
$ KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Multiply by diag(W)*inv(op(A)').
*
CALL DTRSV( UPLO, TRANST, DIAG, N, A, LDA, WORK( N+1 ),
$ 1 )
DO 220 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
220 CONTINUE
ELSE
*
* Multiply by inv(op(A))*diag(W).
*
DO 230 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
230 CONTINUE
CALL DTRSV( UPLO, TRANS, DIAG, N, A, LDA, WORK( N+1 ),
$ 1 )
END IF
GO TO 210
END IF
*
* Normalize error.
*
LSTRES = ZERO
DO 240 I = 1, N
LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
240 CONTINUE
IF( LSTRES.NE.ZERO )
$ FERR( J ) = FERR( J ) / LSTRES
*
250 CONTINUE
*
RETURN
*
* End of DTRRFS
*
END
SUBROUTINE DTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI,
$ M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER COMPQ, JOB
INTEGER INFO, LDQ, LDT, LIWORK, LWORK, M, N
DOUBLE PRECISION S, SEP
* ..
* .. Array Arguments ..
LOGICAL SELECT( * )
INTEGER IWORK( * )
DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WI( * ), WORK( * ),
$ WR( * )
* ..
*
* Purpose
* =======
*
* DTRSEN reorders the real Schur factorization of a real matrix
* A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in
* the leading diagonal blocks of the upper quasi-triangular matrix T,
* and the leading columns of Q form an orthonormal basis of the
* corresponding right invariant subspace.
*
* Optionally the routine computes the reciprocal condition numbers of
* the cluster of eigenvalues and/or the invariant subspace.
*
* T must be in Schur canonical form (as returned by DHSEQR), that is,
* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
* 2-by-2 diagonal block has its diagonal elemnts equal and its
* off-diagonal elements of opposite sign.
*
* Arguments
* =========
*
* JOB (input) CHARACTER*1
* Specifies whether condition numbers are required for the
* cluster of eigenvalues (S) or the invariant subspace (SEP):
* = 'N': none;
* = 'E': for eigenvalues only (S);
* = 'V': for invariant subspace only (SEP);
* = 'B': for both eigenvalues and invariant subspace (S and
* SEP).
*
* COMPQ (input) CHARACTER*1
* = 'V': update the matrix Q of Schur vectors;
* = 'N': do not update Q.
*
* SELECT (input) LOGICAL array, dimension (N)
* SELECT specifies the eigenvalues in the selected cluster. To
* select a real eigenvalue w(j), SELECT(j) must be set to
* .TRUE.. To select a complex conjugate pair of eigenvalues
* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,
* either SELECT(j) or SELECT(j+1) or both must be set to
* .TRUE.; a complex conjugate pair of eigenvalues must be
* either both included in the cluster or both excluded.
*
* N (input) INTEGER
* The order of the matrix T. N >= 0.
*
* T (input/output) DOUBLE PRECISION array, dimension (LDT,N)
* On entry, the upper quasi-triangular matrix T, in Schur
* canonical form.
* On exit, T is overwritten by the reordered matrix T, again in
* Schur canonical form, with the selected eigenvalues in the
* leading diagonal blocks.
*
* LDT (input) INTEGER
* The leading dimension of the array T. LDT >= max(1,N).
*
* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
* On exit, if COMPQ = 'V', Q has been postmultiplied by the
* orthogonal transformation matrix which reorders T; the
* leading M columns of Q form an orthonormal basis for the
* specified invariant subspace.
* If COMPQ = 'N', Q is not referenced.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q.
* LDQ >= 1; and if COMPQ = 'V', LDQ >= N.
*
* WR (output) DOUBLE PRECISION array, dimension (N)
* WI (output) DOUBLE PRECISION array, dimension (N)
* The real and imaginary parts, respectively, of the reordered
* eigenvalues of T. The eigenvalues are stored in the same
* order as on the diagonal of T, with WR(i) = T(i,i) and, if
* T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and
* WI(i+1) = -WI(i). Note that if a complex eigenvalue is
* sufficiently ill-conditioned, then its value may differ
* significantly from its value before reordering.
*
* M (output) INTEGER
* The dimension of the specified invariant subspace.
* 0 < = M <= N.
*
* S (output) DOUBLE PRECISION
* If JOB = 'E' or 'B', S is a lower bound on the reciprocal
* condition number for the selected cluster of eigenvalues.
* S cannot underestimate the true reciprocal condition number
* by more than a factor of sqrt(N). If M = 0 or N, S = 1.
* If JOB = 'N' or 'V', S is not referenced.
*
* SEP (output) DOUBLE PRECISION
* If JOB = 'V' or 'B', SEP is the estimated reciprocal
* condition number of the specified invariant subspace. If
* M = 0 or N, SEP = norm(T).
* If JOB = 'N' or 'E', SEP is not referenced.
*
* 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 JOB = 'N', LWORK >= max(1,N);
* if JOB = 'E', LWORK >= max(1,M*(N-M));
* if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).
*
* 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.
*
* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK.
* If JOB = 'N' or 'E', LIWORK >= 1;
* if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)).
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal size of the IWORK array,
* returns this value as the first entry of the IWORK array, and
* no error message related to LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* = 1: reordering of T failed because some eigenvalues are too
* close to separate (the problem is very ill-conditioned);
* T may have been partially reordered, and WR and WI
* contain the eigenvalues in the same order as in T; S and
* SEP (if requested) are set to zero.
*
* Further Details
* ===============
*
* DTRSEN first collects the selected eigenvalues by computing an
* orthogonal transformation Z to move them to the top left corner of T.
* In other words, the selected eigenvalues are the eigenvalues of T11
* in:
*
* Z'*T*Z = ( T11 T12 ) n1
* ( 0 T22 ) n2
* n1 n2
*
* where N = n1+n2 and Z' means the transpose of Z. The first n1 columns
* of Z span the specified invariant subspace of T.
*
* If T has been obtained from the real Schur factorization of a matrix
* A = Q*T*Q', then the reordered real Schur factorization of A is given
* by A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span
* the corresponding invariant subspace of A.
*
* The reciprocal condition number of the average of the eigenvalues of
* T11 may be returned in S. S lies between 0 (very badly conditioned)
* and 1 (very well conditioned). It is computed as follows. First we
* compute R so that
*
* P = ( I R ) n1
* ( 0 0 ) n2
* n1 n2
*
* is the projector on the invariant subspace associated with T11.
* R is the solution of the Sylvester equation:
*
* T11*R - R*T22 = T12.
*
* Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote
* the two-norm of M. Then S is computed as the lower bound
*
* (1 + F-norm(R)**2)**(-1/2)
*
* on the reciprocal of 2-norm(P), the true reciprocal condition number.
* S cannot underestimate 1 / 2-norm(P) by more than a factor of
* sqrt(N).
*
* An approximate error bound for the computed average of the
* eigenvalues of T11 is
*
* EPS * norm(T) / S
*
* where EPS is the machine precision.
*
* The reciprocal condition number of the right invariant subspace
* spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.
* SEP is defined as the separation of T11 and T22:
*
* sep( T11, T22 ) = sigma-min( C )
*
* where sigma-min(C) is the smallest singular value of the
* n1*n2-by-n1*n2 matrix
*
* C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )
*
* I(m) is an m by m identity matrix, and kprod denotes the Kronecker
* product. We estimate sigma-min(C) by the reciprocal of an estimate of
* the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)
* cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).
*
* When SEP is small, small changes in T can cause large changes in
* the invariant subspace. An approximate bound on the maximum angular
* error in the computed right invariant subspace is
*
* EPS * norm(T) / SEP
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, PAIR, SWAP, WANTBH, WANTQ, WANTS,
$ WANTSP
INTEGER IERR, K, KASE, KK, KS, LIWMIN, LWMIN, N1, N2,
$ NN
DOUBLE PRECISION EST, RNORM, SCALE
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLANGE
EXTERNAL LSAME, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DLACN2, DLACPY, DTREXC, DTRSYL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Decode and test the input parameters
*
WANTBH = LSAME( JOB, 'B' )
WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH
WANTQ = LSAME( COMPQ, 'V' )
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.WANTS .AND. .NOT.WANTSP )
$ THEN
INFO = -1
ELSE IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
INFO = -8
ELSE
*
* Set M to the dimension of the specified invariant subspace,
* and test LWORK and LIWORK.
*
M = 0
PAIR = .FALSE.
DO 10 K = 1, N
IF( PAIR ) THEN
PAIR = .FALSE.
ELSE
IF( K.LT.N ) THEN
IF( T( K+1, K ).EQ.ZERO ) THEN
IF( SELECT( K ) )
$ M = M + 1
ELSE
PAIR = .TRUE.
IF( SELECT( K ) .OR. SELECT( K+1 ) )
$ M = M + 2
END IF
ELSE
IF( SELECT( N ) )
$ M = M + 1
END IF
END IF
10 CONTINUE
*
N1 = M
N2 = N - M
NN = N1*N2
*
IF( WANTSP ) THEN
LWMIN = MAX( 1, 2*NN )
LIWMIN = MAX( 1, NN )
ELSE IF( LSAME( JOB, 'N' ) ) THEN
LWMIN = MAX( 1, N )
LIWMIN = 1
ELSE IF( LSAME( JOB, 'E' ) ) THEN
LWMIN = MAX( 1, NN )
LIWMIN = 1
END IF
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -15
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -17
END IF
END IF
*
IF( INFO.EQ.0 ) THEN
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTRSEN', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible.
*
IF( M.EQ.N .OR. M.EQ.0 ) THEN
IF( WANTS )
$ S = ONE
IF( WANTSP )
$ SEP = DLANGE( '1', N, N, T, LDT, WORK )
GO TO 40
END IF
*
* Collect the selected blocks at the top-left corner of T.
*
KS = 0
PAIR = .FALSE.
DO 20 K = 1, N
IF( PAIR ) THEN
PAIR = .FALSE.
ELSE
SWAP = SELECT( K )
IF( K.LT.N ) THEN
IF( T( K+1, K ).NE.ZERO ) THEN
PAIR = .TRUE.
SWAP = SWAP .OR. SELECT( K+1 )
END IF
END IF
IF( SWAP ) THEN
KS = KS + 1
*
* Swap the K-th block to position KS.
*
IERR = 0
KK = K
IF( K.NE.KS )
$ CALL DTREXC( COMPQ, N, T, LDT, Q, LDQ, KK, KS, WORK,
$ IERR )
IF( IERR.EQ.1 .OR. IERR.EQ.2 ) THEN
*
* Blocks too close to swap: exit.
*
INFO = 1
IF( WANTS )
$ S = ZERO
IF( WANTSP )
$ SEP = ZERO
GO TO 40
END IF
IF( PAIR )
$ KS = KS + 1
END IF
END IF
20 CONTINUE
*
IF( WANTS ) THEN
*
* Solve Sylvester equation for R:
*
* T11*R - R*T22 = scale*T12
*
CALL DLACPY( 'F', N1, N2, T( 1, N1+1 ), LDT, WORK, N1 )
CALL DTRSYL( 'N', 'N', -1, N1, N2, T, LDT, T( N1+1, N1+1 ),
$ LDT, WORK, N1, SCALE, IERR )
*
* Estimate the reciprocal of the condition number of the cluster
* of eigenvalues.
*
RNORM = DLANGE( 'F', N1, N2, WORK, N1, WORK )
IF( RNORM.EQ.ZERO ) THEN
S = ONE
ELSE
S = SCALE / ( SQRT( SCALE*SCALE / RNORM+RNORM )*
$ SQRT( RNORM ) )
END IF
END IF
*
IF( WANTSP ) THEN
*
* Estimate sep(T11,T22).
*
EST = ZERO
KASE = 0
30 CONTINUE
CALL DLACN2( NN, WORK( NN+1 ), WORK, IWORK, EST, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Solve T11*R - R*T22 = scale*X.
*
CALL DTRSYL( 'N', 'N', -1, N1, N2, T, LDT,
$ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE,
$ IERR )
ELSE
*
* Solve T11'*R - R*T22' = scale*X.
*
CALL DTRSYL( 'T', 'T', -1, N1, N2, T, LDT,
$ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE,
$ IERR )
END IF
GO TO 30
END IF
*
SEP = SCALE / EST
END IF
*
40 CONTINUE
*
* Store the output eigenvalues in WR and WI.
*
DO 50 K = 1, N
WR( K ) = T( K, K )
WI( K ) = ZERO
50 CONTINUE
DO 60 K = 1, N - 1
IF( T( K+1, K ).NE.ZERO ) THEN
WI( K ) = SQRT( ABS( T( K, K+1 ) ) )*
$ SQRT( ABS( T( K+1, K ) ) )
WI( K+1 ) = -WI( K )
END IF
60 CONTINUE
*
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
RETURN
*
* End of DTRSEN
*
END
SUBROUTINE DTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
$ LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER HOWMNY, JOB
INTEGER INFO, LDT, LDVL, LDVR, LDWORK, M, MM, N
* ..
* .. Array Arguments ..
LOGICAL SELECT( * )
INTEGER IWORK( * )
DOUBLE PRECISION S( * ), SEP( * ), T( LDT, * ), VL( LDVL, * ),
$ VR( LDVR, * ), WORK( LDWORK, * )
* ..
*
* Purpose
* =======
*
* DTRSNA estimates reciprocal condition numbers for specified
* eigenvalues and/or right eigenvectors of a real upper
* quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q
* orthogonal).
*
* T must be in Schur canonical form (as returned by DHSEQR), that is,
* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
* 2-by-2 diagonal block has its diagonal elements equal and its
* off-diagonal elements of opposite sign.
*
* Arguments
* =========
*
* JOB (input) CHARACTER*1
* Specifies whether condition numbers are required for
* eigenvalues (S) or eigenvectors (SEP):
* = 'E': for eigenvalues only (S);
* = 'V': for eigenvectors only (SEP);
* = 'B': for both eigenvalues and eigenvectors (S and SEP).
*
* HOWMNY (input) CHARACTER*1
* = 'A': compute condition numbers for all eigenpairs;
* = 'S': compute condition numbers for selected eigenpairs
* specified by the array SELECT.
*
* SELECT (input) LOGICAL array, dimension (N)
* If HOWMNY = 'S', SELECT specifies the eigenpairs for which
* condition numbers are required. To select condition numbers
* for the eigenpair corresponding to a real eigenvalue w(j),
* SELECT(j) must be set to .TRUE.. To select condition numbers
* corresponding to a complex conjugate pair of eigenvalues w(j)
* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be
* set to .TRUE..
* If HOWMNY = 'A', SELECT is not referenced.
*
* N (input) INTEGER
* The order of the matrix T. N >= 0.
*
* T (input) DOUBLE PRECISION array, dimension (LDT,N)
* The upper quasi-triangular matrix T, in Schur canonical form.
*
* LDT (input) INTEGER
* The leading dimension of the array T. LDT >= max(1,N).
*
* VL (input) DOUBLE PRECISION array, dimension (LDVL,M)
* If JOB = 'E' or 'B', VL must contain left eigenvectors of T
* (or of any Q*T*Q**T with Q orthogonal), corresponding to the
* eigenpairs specified by HOWMNY and SELECT. The eigenvectors
* must be stored in consecutive columns of VL, as returned by
* DHSEIN or DTREVC.
* If JOB = 'V', VL is not referenced.
*
* LDVL (input) INTEGER
* The leading dimension of the array VL.
* LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.
*
* VR (input) DOUBLE PRECISION array, dimension (LDVR,M)
* If JOB = 'E' or 'B', VR must contain right eigenvectors of T
* (or of any Q*T*Q**T with Q orthogonal), corresponding to the
* eigenpairs specified by HOWMNY and SELECT. The eigenvectors
* must be stored in consecutive columns of VR, as returned by
* DHSEIN or DTREVC.
* If JOB = 'V', VR is not referenced.
*
* LDVR (input) INTEGER
* The leading dimension of the array VR.
* LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.
*
* S (output) DOUBLE PRECISION array, dimension (MM)
* If JOB = 'E' or 'B', the reciprocal condition numbers of the
* selected eigenvalues, stored in consecutive elements of the
* array. For a complex conjugate pair of eigenvalues two
* consecutive elements of S are set to the same value. Thus
* S(j), SEP(j), and the j-th columns of VL and VR all
* correspond to the same eigenpair (but not in general the
* j-th eigenpair, unless all eigenpairs are selected).
* If JOB = 'V', S is not referenced.
*
* SEP (output) DOUBLE PRECISION array, dimension (MM)
* If JOB = 'V' or 'B', the estimated reciprocal condition
* numbers of the selected eigenvectors, stored in consecutive
* elements of the array. For a complex eigenvector two
* consecutive elements of SEP are set to the same value. If
* the eigenvalues cannot be reordered to compute SEP(j), SEP(j)
* is set to 0; this can only occur when the true value would be
* very small anyway.
* If JOB = 'E', SEP is not referenced.
*
* MM (input) INTEGER
* The number of elements in the arrays S (if JOB = 'E' or 'B')
* and/or SEP (if JOB = 'V' or 'B'). MM >= M.
*
* M (output) INTEGER
* The number of elements of the arrays S and/or SEP actually
* used to store the estimated condition numbers.
* If HOWMNY = 'A', M is set to N.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,N+6)
* If JOB = 'E', WORK is not referenced.
*
* LDWORK (input) INTEGER
* The leading dimension of the array WORK.
* LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.
*
* IWORK (workspace) INTEGER array, dimension (2*(N-1))
* If JOB = 'E', IWORK is not referenced.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Further Details
* ===============
*
* The reciprocal of the condition number of an eigenvalue lambda is
* defined as
*
* S(lambda) = |v'*u| / (norm(u)*norm(v))
*
* where u and v are the right and left eigenvectors of T corresponding
* to lambda; v' denotes the conjugate-transpose of v, and norm(u)
* denotes the Euclidean norm. These reciprocal condition numbers always
* lie between zero (very badly conditioned) and one (very well
* conditioned). If n = 1, S(lambda) is defined to be 1.
*
* An approximate error bound for a computed eigenvalue W(i) is given by
*
* EPS * norm(T) / S(i)
*
* where EPS is the machine precision.
*
* The reciprocal of the condition number of the right eigenvector u
* corresponding to lambda is defined as follows. Suppose
*
* T = ( lambda c )
* ( 0 T22 )
*
* Then the reciprocal condition number is
*
* SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )
*
* where sigma-min denotes the smallest singular value. We approximate
* the smallest singular value by the reciprocal of an estimate of the
* one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is
* defined to be abs(T(1,1)).
*
* An approximate error bound for a computed right eigenvector VR(i)
* is given by
*
* EPS * norm(T) / SEP(i)
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL PAIR, SOMCON, WANTBH, WANTS, WANTSP
INTEGER I, IERR, IFST, ILST, J, K, KASE, KS, N2, NN
DOUBLE PRECISION BIGNUM, COND, CS, DELTA, DUMM, EPS, EST, LNRM,
$ MU, PROD, PROD1, PROD2, RNRM, SCALE, SMLNUM, SN
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
DOUBLE PRECISION DUMMY( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DDOT, DLAMCH, DLAPY2, DNRM2
EXTERNAL LSAME, DDOT, DLAMCH, DLAPY2, DNRM2
* ..
* .. External Subroutines ..
EXTERNAL DLACN2, DLACPY, DLAQTR, DTREXC, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Decode and test the input parameters
*
WANTBH = LSAME( JOB, 'B' )
WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH
*
SOMCON = LSAME( HOWMNY, 'S' )
*
INFO = 0
IF( .NOT.WANTS .AND. .NOT.WANTSP ) THEN
INFO = -1
ELSE IF( .NOT.LSAME( HOWMNY, 'A' ) .AND. .NOT.SOMCON ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDVL.LT.1 .OR. ( WANTS .AND. LDVL.LT.N ) ) THEN
INFO = -8
ELSE IF( LDVR.LT.1 .OR. ( WANTS .AND. LDVR.LT.N ) ) THEN
INFO = -10
ELSE
*
* Set M to the number of eigenpairs for which condition numbers
* are required, and test MM.
*
IF( SOMCON ) THEN
M = 0
PAIR = .FALSE.
DO 10 K = 1, N
IF( PAIR ) THEN
PAIR = .FALSE.
ELSE
IF( K.LT.N ) THEN
IF( T( K+1, K ).EQ.ZERO ) THEN
IF( SELECT( K ) )
$ M = M + 1
ELSE
PAIR = .TRUE.
IF( SELECT( K ) .OR. SELECT( K+1 ) )
$ M = M + 2
END IF
ELSE
IF( SELECT( N ) )
$ M = M + 1
END IF
END IF
10 CONTINUE
ELSE
M = N
END IF
*
IF( MM.LT.M ) THEN
INFO = -13
ELSE IF( LDWORK.LT.1 .OR. ( WANTSP .AND. LDWORK.LT.N ) ) THEN
INFO = -16
END IF
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTRSNA', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( SOMCON ) THEN
IF( .NOT.SELECT( 1 ) )
$ RETURN
END IF
IF( WANTS )
$ S( 1 ) = ONE
IF( WANTSP )
$ SEP( 1 ) = ABS( T( 1, 1 ) )
RETURN
END IF
*
* Get machine constants
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' ) / EPS
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
*
KS = 0
PAIR = .FALSE.
DO 60 K = 1, N
*
* Determine whether T(k,k) begins a 1-by-1 or 2-by-2 block.
*
IF( PAIR ) THEN
PAIR = .FALSE.
GO TO 60
ELSE
IF( K.LT.N )
$ PAIR = T( K+1, K ).NE.ZERO
END IF
*
* Determine whether condition numbers are required for the k-th
* eigenpair.
*
IF( SOMCON ) THEN
IF( PAIR ) THEN
IF( .NOT.SELECT( K ) .AND. .NOT.SELECT( K+1 ) )
$ GO TO 60
ELSE
IF( .NOT.SELECT( K ) )
$ GO TO 60
END IF
END IF
*
KS = KS + 1
*
IF( WANTS ) THEN
*
* Compute the reciprocal condition number of the k-th
* eigenvalue.
*
IF( .NOT.PAIR ) THEN
*
* Real eigenvalue.
*
PROD = DDOT( N, VR( 1, KS ), 1, VL( 1, KS ), 1 )
RNRM = DNRM2( N, VR( 1, KS ), 1 )
LNRM = DNRM2( N, VL( 1, KS ), 1 )
S( KS ) = ABS( PROD ) / ( RNRM*LNRM )
ELSE
*
* Complex eigenvalue.
*
PROD1 = DDOT( N, VR( 1, KS ), 1, VL( 1, KS ), 1 )
PROD1 = PROD1 + DDOT( N, VR( 1, KS+1 ), 1, VL( 1, KS+1 ),
$ 1 )
PROD2 = DDOT( N, VL( 1, KS ), 1, VR( 1, KS+1 ), 1 )
PROD2 = PROD2 - DDOT( N, VL( 1, KS+1 ), 1, VR( 1, KS ),
$ 1 )
RNRM = DLAPY2( DNRM2( N, VR( 1, KS ), 1 ),
$ DNRM2( N, VR( 1, KS+1 ), 1 ) )
LNRM = DLAPY2( DNRM2( N, VL( 1, KS ), 1 ),
$ DNRM2( N, VL( 1, KS+1 ), 1 ) )
COND = DLAPY2( PROD1, PROD2 ) / ( RNRM*LNRM )
S( KS ) = COND
S( KS+1 ) = COND
END IF
END IF
*
IF( WANTSP ) THEN
*
* Estimate the reciprocal condition number of the k-th
* eigenvector.
*
* Copy the matrix T to the array WORK and swap the diagonal
* block beginning at T(k,k) to the (1,1) position.
*
CALL DLACPY( 'Full', N, N, T, LDT, WORK, LDWORK )
IFST = K
ILST = 1
CALL DTREXC( 'No Q', N, WORK, LDWORK, DUMMY, 1, IFST, ILST,
$ WORK( 1, N+1 ), IERR )
*
IF( IERR.EQ.1 .OR. IERR.EQ.2 ) THEN
*
* Could not swap because blocks not well separated
*
SCALE = ONE
EST = BIGNUM
ELSE
*
* Reordering successful
*
IF( WORK( 2, 1 ).EQ.ZERO ) THEN
*
* Form C = T22 - lambda*I in WORK(2:N,2:N).
*
DO 20 I = 2, N
WORK( I, I ) = WORK( I, I ) - WORK( 1, 1 )
20 CONTINUE
N2 = 1
NN = N - 1
ELSE
*
* Triangularize the 2 by 2 block by unitary
* transformation U = [ cs i*ss ]
* [ i*ss cs ].
* such that the (1,1) position of WORK is complex
* eigenvalue lambda with positive imaginary part. (2,2)
* position of WORK is the complex eigenvalue lambda
* with negative imaginary part.
*
MU = SQRT( ABS( WORK( 1, 2 ) ) )*
$ SQRT( ABS( WORK( 2, 1 ) ) )
DELTA = DLAPY2( MU, WORK( 2, 1 ) )
CS = MU / DELTA
SN = -WORK( 2, 1 ) / DELTA
*
* Form
*
* C' = WORK(2:N,2:N) + i*[rwork(1) ..... rwork(n-1) ]
* [ mu ]
* [ .. ]
* [ .. ]
* [ mu ]
* where C' is conjugate transpose of complex matrix C,
* and RWORK is stored starting in the N+1-st column of
* WORK.
*
DO 30 J = 3, N
WORK( 2, J ) = CS*WORK( 2, J )
WORK( J, J ) = WORK( J, J ) - WORK( 1, 1 )
30 CONTINUE
WORK( 2, 2 ) = ZERO
*
WORK( 1, N+1 ) = TWO*MU
DO 40 I = 2, N - 1
WORK( I, N+1 ) = SN*WORK( 1, I+1 )
40 CONTINUE
N2 = 2
NN = 2*( N-1 )
END IF
*
* Estimate norm(inv(C'))
*
EST = ZERO
KASE = 0
50 CONTINUE
CALL DLACN2( NN, WORK( 1, N+2 ), WORK( 1, N+4 ), IWORK,
$ EST, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
IF( N2.EQ.1 ) THEN
*
* Real eigenvalue: solve C'*x = scale*c.
*
CALL DLAQTR( .TRUE., .TRUE., N-1, WORK( 2, 2 ),
$ LDWORK, DUMMY, DUMM, SCALE,
$ WORK( 1, N+4 ), WORK( 1, N+6 ),
$ IERR )
ELSE
*
* Complex eigenvalue: solve
* C'*(p+iq) = scale*(c+id) in real arithmetic.
*
CALL DLAQTR( .TRUE., .FALSE., N-1, WORK( 2, 2 ),
$ LDWORK, WORK( 1, N+1 ), MU, SCALE,
$ WORK( 1, N+4 ), WORK( 1, N+6 ),
$ IERR )
END IF
ELSE
IF( N2.EQ.1 ) THEN
*
* Real eigenvalue: solve C*x = scale*c.
*
CALL DLAQTR( .FALSE., .TRUE., N-1, WORK( 2, 2 ),
$ LDWORK, DUMMY, DUMM, SCALE,
$ WORK( 1, N+4 ), WORK( 1, N+6 ),
$ IERR )
ELSE
*
* Complex eigenvalue: solve
* C*(p+iq) = scale*(c+id) in real arithmetic.
*
CALL DLAQTR( .FALSE., .FALSE., N-1,
$ WORK( 2, 2 ), LDWORK,
$ WORK( 1, N+1 ), MU, SCALE,
$ WORK( 1, N+4 ), WORK( 1, N+6 ),
$ IERR )
*
END IF
END IF
*
GO TO 50
END IF
END IF
*
SEP( KS ) = SCALE / MAX( EST, SMLNUM )
IF( PAIR )
$ SEP( KS+1 ) = SEP( KS )
END IF
*
IF( PAIR )
$ KS = KS + 1
*
60 CONTINUE
RETURN
*
* End of DTRSNA
*
END
SUBROUTINE DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C,
$ LDC, SCALE, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANA, TRANB
INTEGER INFO, ISGN, LDA, LDB, LDC, M, N
DOUBLE PRECISION SCALE
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * )
* ..
*
* Purpose
* =======
*
* DTRSYL solves the real Sylvester matrix equation:
*
* op(A)*X + X*op(B) = scale*C or
* op(A)*X - X*op(B) = scale*C,
*
* where op(A) = A or A**T, and A and B are both upper quasi-
* triangular. A is M-by-M and B is N-by-N; the right hand side C and
* the solution X are M-by-N; and scale is an output scale factor, set
* <= 1 to avoid overflow in X.
*
* A and B must be in Schur canonical form (as returned by DHSEQR), that
* is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks;
* each 2-by-2 diagonal block has its diagonal elements equal and its
* off-diagonal elements of opposite sign.
*
* Arguments
* =========
*
* TRANA (input) CHARACTER*1
* Specifies the option op(A):
* = 'N': op(A) = A (No transpose)
* = 'T': op(A) = A**T (Transpose)
* = 'C': op(A) = A**H (Conjugate transpose = Transpose)
*
* TRANB (input) CHARACTER*1
* Specifies the option op(B):
* = 'N': op(B) = B (No transpose)
* = 'T': op(B) = B**T (Transpose)
* = 'C': op(B) = B**H (Conjugate transpose = Transpose)
*
* ISGN (input) INTEGER
* Specifies the sign in the equation:
* = +1: solve op(A)*X + X*op(B) = scale*C
* = -1: solve op(A)*X - X*op(B) = scale*C
*
* M (input) INTEGER
* The order of the matrix A, and the number of rows in the
* matrices X and C. M >= 0.
*
* N (input) INTEGER
* The order of the matrix B, and the number of columns in the
* matrices X and C. N >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,M)
* The upper quasi-triangular matrix A, in Schur canonical form.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input) DOUBLE PRECISION array, dimension (LDB,N)
* The upper quasi-triangular matrix B, in Schur canonical form.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
* On entry, the M-by-N right hand side matrix C.
* On exit, C is overwritten by the solution matrix X.
*
* LDC (input) INTEGER
* The leading dimension of the array C. LDC >= max(1,M)
*
* SCALE (output) DOUBLE PRECISION
* The scale factor, scale, set <= 1 to avoid overflow in X.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* = 1: A and B have common or very close eigenvalues; perturbed
* values were used to solve the equation (but the matrices
* A and B are unchanged).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRNA, NOTRNB
INTEGER IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT
DOUBLE PRECISION A11, BIGNUM, DA11, DB, EPS, SCALOC, SGN, SMIN,
$ SMLNUM, SUML, SUMR, XNORM
* ..
* .. Local Arrays ..
DOUBLE PRECISION DUM( 1 ), VEC( 2, 2 ), X( 2, 2 )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DDOT, DLAMCH, DLANGE
EXTERNAL LSAME, DDOT, DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DLABAD, DLALN2, DLASY2, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
* Decode and Test input parameters
*
NOTRNA = LSAME( TRANA, 'N' )
NOTRNB = LSAME( TRANB, 'N' )
*
INFO = 0
IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. .NOT.
$ LSAME( TRANA, 'C' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'T' ) .AND. .NOT.
$ LSAME( TRANB, 'C' ) ) THEN
INFO = -2
ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN
INFO = -3
ELSE IF( M.LT.0 ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -11
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTRSYL', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
* Set constants to control overflow
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
SMLNUM = SMLNUM*DBLE( M*N ) / EPS
BIGNUM = ONE / SMLNUM
*
SMIN = MAX( SMLNUM, EPS*DLANGE( 'M', M, M, A, LDA, DUM ),
$ EPS*DLANGE( 'M', N, N, B, LDB, DUM ) )
*
SCALE = ONE
SGN = ISGN
*
IF( NOTRNA .AND. NOTRNB ) THEN
*
* Solve A*X + ISGN*X*B = scale*C.
*
* The (K,L)th block of X is determined starting from
* bottom-left corner column by column by
*
* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
*
* Where
* M L-1
* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)].
* I=K+1 J=1
*
* Start column loop (index = L)
* L1 (L2) : column index of the first (first) row of X(K,L).
*
LNEXT = 1
DO 60 L = 1, N
IF( L.LT.LNEXT )
$ GO TO 60
IF( L.EQ.N ) THEN
L1 = L
L2 = L
ELSE
IF( B( L+1, L ).NE.ZERO ) THEN
L1 = L
L2 = L + 1
LNEXT = L + 2
ELSE
L1 = L
L2 = L
LNEXT = L + 1
END IF
END IF
*
* Start row loop (index = K)
* K1 (K2): row index of the first (last) row of X(K,L).
*
KNEXT = M
DO 50 K = M, 1, -1
IF( K.GT.KNEXT )
$ GO TO 50
IF( K.EQ.1 ) THEN
K1 = K
K2 = K
ELSE
IF( A( K, K-1 ).NE.ZERO ) THEN
K1 = K - 1
K2 = K
KNEXT = K - 2
ELSE
K1 = K
K2 = K
KNEXT = K - 1
END IF
END IF
*
IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
$ C( MIN( K1+1, M ), L1 ), 1 )
SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
SCALOC = ONE
*
A11 = A( K1, K1 ) + SGN*B( L1, L1 )
DA11 = ABS( A11 )
IF( DA11.LE.SMIN ) THEN
A11 = SMIN
DA11 = SMIN
INFO = 1
END IF
DB = ABS( VEC( 1, 1 ) )
IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
IF( DB.GT.BIGNUM*DA11 )
$ SCALOC = ONE / DB
END IF
X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
*
IF( SCALOC.NE.ONE ) THEN
DO 10 J = 1, N
CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
10 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
*
ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
*
SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
$ C( MIN( K2+1, M ), L1 ), 1 )
SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
*
SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
$ C( MIN( K2+1, M ), L1 ), 1 )
SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
*
CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, A( K1, K1 ),
$ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ),
$ ZERO, X, 2, SCALOC, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 1
*
IF( SCALOC.NE.ONE ) THEN
DO 20 J = 1, N
CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
20 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
C( K2, L1 ) = X( 2, 1 )
*
ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
*
SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
$ C( MIN( K1+1, M ), L1 ), 1 )
SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) )
*
SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
$ C( MIN( K1+1, M ), L2 ), 1 )
SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) )
*
CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, B( L1, L1 ),
$ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ),
$ ZERO, X, 2, SCALOC, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 1
*
IF( SCALOC.NE.ONE ) THEN
DO 30 J = 1, N
CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
30 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
C( K1, L2 ) = X( 2, 1 )
*
ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
*
SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
$ C( MIN( K2+1, M ), L1 ), 1 )
SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
*
SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
$ C( MIN( K2+1, M ), L2 ), 1 )
SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR )
*
SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
$ C( MIN( K2+1, M ), L1 ), 1 )
SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
*
SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
$ C( MIN( K2+1, M ), L2 ), 1 )
SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L2 ), 1 )
VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR )
*
CALL DLASY2( .FALSE., .FALSE., ISGN, 2, 2,
$ A( K1, K1 ), LDA, B( L1, L1 ), LDB, VEC,
$ 2, SCALOC, X, 2, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 1
*
IF( SCALOC.NE.ONE ) THEN
DO 40 J = 1, N
CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
40 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
C( K1, L2 ) = X( 1, 2 )
C( K2, L1 ) = X( 2, 1 )
C( K2, L2 ) = X( 2, 2 )
END IF
*
50 CONTINUE
*
60 CONTINUE
*
ELSE IF( .NOT.NOTRNA .AND. NOTRNB ) THEN
*
* Solve A' *X + ISGN*X*B = scale*C.
*
* The (K,L)th block of X is determined starting from
* upper-left corner column by column by
*
* A(K,K)'*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
*
* Where
* K-1 L-1
* R(K,L) = SUM [A(I,K)'*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)]
* I=1 J=1
*
* Start column loop (index = L)
* L1 (L2): column index of the first (last) row of X(K,L)
*
LNEXT = 1
DO 120 L = 1, N
IF( L.LT.LNEXT )
$ GO TO 120
IF( L.EQ.N ) THEN
L1 = L
L2 = L
ELSE
IF( B( L+1, L ).NE.ZERO ) THEN
L1 = L
L2 = L + 1
LNEXT = L + 2
ELSE
L1 = L
L2 = L
LNEXT = L + 1
END IF
END IF
*
* Start row loop (index = K)
* K1 (K2): row index of the first (last) row of X(K,L)
*
KNEXT = 1
DO 110 K = 1, M
IF( K.LT.KNEXT )
$ GO TO 110
IF( K.EQ.M ) THEN
K1 = K
K2 = K
ELSE
IF( A( K+1, K ).NE.ZERO ) THEN
K1 = K
K2 = K + 1
KNEXT = K + 2
ELSE
K1 = K
K2 = K
KNEXT = K + 1
END IF
END IF
*
IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
SCALOC = ONE
*
A11 = A( K1, K1 ) + SGN*B( L1, L1 )
DA11 = ABS( A11 )
IF( DA11.LE.SMIN ) THEN
A11 = SMIN
DA11 = SMIN
INFO = 1
END IF
DB = ABS( VEC( 1, 1 ) )
IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
IF( DB.GT.BIGNUM*DA11 )
$ SCALOC = ONE / DB
END IF
X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
*
IF( SCALOC.NE.ONE ) THEN
DO 70 J = 1, N
CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
70 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
*
ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
*
SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
*
SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
*
CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ),
$ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ),
$ ZERO, X, 2, SCALOC, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 1
*
IF( SCALOC.NE.ONE ) THEN
DO 80 J = 1, N
CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
80 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
C( K2, L1 ) = X( 2, 1 )
*
ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
*
SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) )
*
SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) )
*
CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, B( L1, L1 ),
$ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ),
$ ZERO, X, 2, SCALOC, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 1
*
IF( SCALOC.NE.ONE ) THEN
DO 90 J = 1, N
CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
90 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
C( K1, L2 ) = X( 2, 1 )
*
ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
*
SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
*
SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR )
*
SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
*
SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 )
SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L2 ), 1 )
VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR )
*
CALL DLASY2( .TRUE., .FALSE., ISGN, 2, 2, A( K1, K1 ),
$ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X,
$ 2, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 1
*
IF( SCALOC.NE.ONE ) THEN
DO 100 J = 1, N
CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
100 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
C( K1, L2 ) = X( 1, 2 )
C( K2, L1 ) = X( 2, 1 )
C( K2, L2 ) = X( 2, 2 )
END IF
*
110 CONTINUE
120 CONTINUE
*
ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN
*
* Solve A'*X + ISGN*X*B' = scale*C.
*
* The (K,L)th block of X is determined starting from
* top-right corner column by column by
*
* A(K,K)'*X(K,L) + ISGN*X(K,L)*B(L,L)' = C(K,L) - R(K,L)
*
* Where
* K-1 N
* R(K,L) = SUM [A(I,K)'*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)'].
* I=1 J=L+1
*
* Start column loop (index = L)
* L1 (L2): column index of the first (last) row of X(K,L)
*
LNEXT = N
DO 180 L = N, 1, -1
IF( L.GT.LNEXT )
$ GO TO 180
IF( L.EQ.1 ) THEN
L1 = L
L2 = L
ELSE
IF( B( L, L-1 ).NE.ZERO ) THEN
L1 = L - 1
L2 = L
LNEXT = L - 2
ELSE
L1 = L
L2 = L
LNEXT = L - 1
END IF
END IF
*
* Start row loop (index = K)
* K1 (K2): row index of the first (last) row of X(K,L)
*
KNEXT = 1
DO 170 K = 1, M
IF( K.LT.KNEXT )
$ GO TO 170
IF( K.EQ.M ) THEN
K1 = K
K2 = K
ELSE
IF( A( K+1, K ).NE.ZERO ) THEN
K1 = K
K2 = K + 1
KNEXT = K + 2
ELSE
K1 = K
K2 = K
KNEXT = K + 1
END IF
END IF
*
IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
SUMR = DDOT( N-L1, C( K1, MIN( L1+1, N ) ), LDC,
$ B( L1, MIN( L1+1, N ) ), LDB )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
SCALOC = ONE
*
A11 = A( K1, K1 ) + SGN*B( L1, L1 )
DA11 = ABS( A11 )
IF( DA11.LE.SMIN ) THEN
A11 = SMIN
DA11 = SMIN
INFO = 1
END IF
DB = ABS( VEC( 1, 1 ) )
IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
IF( DB.GT.BIGNUM*DA11 )
$ SCALOC = ONE / DB
END IF
X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
*
IF( SCALOC.NE.ONE ) THEN
DO 130 J = 1, N
CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
130 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
*
ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
*
SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
$ B( L1, MIN( L2+1, N ) ), LDB )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
*
SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
$ B( L1, MIN( L2+1, N ) ), LDB )
VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
*
CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ),
$ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ),
$ ZERO, X, 2, SCALOC, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 1
*
IF( SCALOC.NE.ONE ) THEN
DO 140 J = 1, N
CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
140 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
C( K2, L1 ) = X( 2, 1 )
*
ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
*
SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
$ B( L1, MIN( L2+1, N ) ), LDB )
VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) )
*
SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
$ B( L2, MIN( L2+1, N ) ), LDB )
VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) )
*
CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, B( L1, L1 ),
$ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ),
$ ZERO, X, 2, SCALOC, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 1
*
IF( SCALOC.NE.ONE ) THEN
DO 150 J = 1, N
CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
150 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
C( K1, L2 ) = X( 2, 1 )
*
ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
*
SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
$ B( L1, MIN( L2+1, N ) ), LDB )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
*
SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
$ B( L2, MIN( L2+1, N ) ), LDB )
VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR )
*
SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
$ B( L1, MIN( L2+1, N ) ), LDB )
VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
*
SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 )
SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
$ B( L2, MIN( L2+1, N ) ), LDB )
VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR )
*
CALL DLASY2( .TRUE., .TRUE., ISGN, 2, 2, A( K1, K1 ),
$ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X,
$ 2, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 1
*
IF( SCALOC.NE.ONE ) THEN
DO 160 J = 1, N
CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
160 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
C( K1, L2 ) = X( 1, 2 )
C( K2, L1 ) = X( 2, 1 )
C( K2, L2 ) = X( 2, 2 )
END IF
*
170 CONTINUE
180 CONTINUE
*
ELSE IF( NOTRNA .AND. .NOT.NOTRNB ) THEN
*
* Solve A*X + ISGN*X*B' = scale*C.
*
* The (K,L)th block of X is determined starting from
* bottom-right corner column by column by
*
* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L)' = C(K,L) - R(K,L)
*
* Where
* M N
* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)'].
* I=K+1 J=L+1
*
* Start column loop (index = L)
* L1 (L2): column index of the first (last) row of X(K,L)
*
LNEXT = N
DO 240 L = N, 1, -1
IF( L.GT.LNEXT )
$ GO TO 240
IF( L.EQ.1 ) THEN
L1 = L
L2 = L
ELSE
IF( B( L, L-1 ).NE.ZERO ) THEN
L1 = L - 1
L2 = L
LNEXT = L - 2
ELSE
L1 = L
L2 = L
LNEXT = L - 1
END IF
END IF
*
* Start row loop (index = K)
* K1 (K2): row index of the first (last) row of X(K,L)
*
KNEXT = M
DO 230 K = M, 1, -1
IF( K.GT.KNEXT )
$ GO TO 230
IF( K.EQ.1 ) THEN
K1 = K
K2 = K
ELSE
IF( A( K, K-1 ).NE.ZERO ) THEN
K1 = K - 1
K2 = K
KNEXT = K - 2
ELSE
K1 = K
K2 = K
KNEXT = K - 1
END IF
END IF
*
IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
$ C( MIN( K1+1, M ), L1 ), 1 )
SUMR = DDOT( N-L1, C( K1, MIN( L1+1, N ) ), LDC,
$ B( L1, MIN( L1+1, N ) ), LDB )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
SCALOC = ONE
*
A11 = A( K1, K1 ) + SGN*B( L1, L1 )
DA11 = ABS( A11 )
IF( DA11.LE.SMIN ) THEN
A11 = SMIN
DA11 = SMIN
INFO = 1
END IF
DB = ABS( VEC( 1, 1 ) )
IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
IF( DB.GT.BIGNUM*DA11 )
$ SCALOC = ONE / DB
END IF
X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
*
IF( SCALOC.NE.ONE ) THEN
DO 190 J = 1, N
CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
190 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
*
ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
*
SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
$ C( MIN( K2+1, M ), L1 ), 1 )
SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
$ B( L1, MIN( L2+1, N ) ), LDB )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
*
SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
$ C( MIN( K2+1, M ), L1 ), 1 )
SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
$ B( L1, MIN( L2+1, N ) ), LDB )
VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
*
CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, A( K1, K1 ),
$ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ),
$ ZERO, X, 2, SCALOC, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 1
*
IF( SCALOC.NE.ONE ) THEN
DO 200 J = 1, N
CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
200 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
C( K2, L1 ) = X( 2, 1 )
*
ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
*
SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
$ C( MIN( K1+1, M ), L1 ), 1 )
SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
$ B( L1, MIN( L2+1, N ) ), LDB )
VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) )
*
SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
$ C( MIN( K1+1, M ), L2 ), 1 )
SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
$ B( L2, MIN( L2+1, N ) ), LDB )
VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) )
*
CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, B( L1, L1 ),
$ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ),
$ ZERO, X, 2, SCALOC, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 1
*
IF( SCALOC.NE.ONE ) THEN
DO 210 J = 1, N
CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
210 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
C( K1, L2 ) = X( 2, 1 )
*
ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
*
SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
$ C( MIN( K2+1, M ), L1 ), 1 )
SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
$ B( L1, MIN( L2+1, N ) ), LDB )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
*
SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
$ C( MIN( K2+1, M ), L2 ), 1 )
SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
$ B( L2, MIN( L2+1, N ) ), LDB )
VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR )
*
SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
$ C( MIN( K2+1, M ), L1 ), 1 )
SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
$ B( L1, MIN( L2+1, N ) ), LDB )
VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
*
SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
$ C( MIN( K2+1, M ), L2 ), 1 )
SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
$ B( L2, MIN( L2+1, N ) ), LDB )
VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR )
*
CALL DLASY2( .FALSE., .TRUE., ISGN, 2, 2, A( K1, K1 ),
$ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X,
$ 2, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 1
*
IF( SCALOC.NE.ONE ) THEN
DO 220 J = 1, N
CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
220 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
C( K1, L2 ) = X( 1, 2 )
C( K2, L1 ) = X( 2, 1 )
C( K2, L2 ) = X( 2, 2 )
END IF
*
230 CONTINUE
240 CONTINUE
*
END IF
*
RETURN
*
* End of DTRSYL
*
END
SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
* ..
*
* Purpose
* =======
*
* DTRTI2 computes the inverse of a real upper or lower triangular
* matrix.
*
* This is the Level 2 BLAS version of the algorithm.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the triangular matrix A. If UPLO = 'U', the
* leading n by n upper triangular part of the array A contains
* the upper triangular matrix, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading n by n lower triangular part of the array A contains
* the lower triangular matrix, and the strictly upper
* triangular part of A is not referenced. If DIAG = 'U', the
* diagonal elements of A are also not referenced and are
* assumed to be 1.
*
* On exit, the (triangular) inverse of the original matrix, in
* the same storage format.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT, UPPER
INTEGER J
DOUBLE PRECISION AJJ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, DTRMV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOUNIT = LSAME( DIAG, 'N' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTRTI2', -INFO )
RETURN
END IF
*
IF( UPPER ) THEN
*
* Compute inverse of upper triangular matrix.
*
DO 10 J = 1, N
IF( NOUNIT ) THEN
A( J, J ) = ONE / A( J, J )
AJJ = -A( J, J )
ELSE
AJJ = -ONE
END IF
*
* Compute elements 1:j-1 of j-th column.
*
CALL DTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA,
$ A( 1, J ), 1 )
CALL DSCAL( J-1, AJJ, A( 1, J ), 1 )
10 CONTINUE
ELSE
*
* Compute inverse of lower triangular matrix.
*
DO 20 J = N, 1, -1
IF( NOUNIT ) THEN
A( J, J ) = ONE / A( J, J )
AJJ = -A( J, J )
ELSE
AJJ = -ONE
END IF
IF( J.LT.N ) THEN
*
* Compute elements j+1:n of j-th column.
*
CALL DTRMV( 'Lower', 'No transpose', DIAG, N-J,
$ A( J+1, J+1 ), LDA, A( J+1, J ), 1 )
CALL DSCAL( N-J, AJJ, A( J+1, J ), 1 )
END IF
20 CONTINUE
END IF
*
RETURN
*
* End of DTRTI2
*
END
SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
* ..
*
* Purpose
* =======
*
* DTRTRI computes the inverse of a real upper or lower triangular
* matrix A.
*
* This is the Level 3 BLAS version of the algorithm.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': A is upper triangular;
* = 'L': A is lower triangular.
*
* DIAG (input) CHARACTER*1
* = 'N': A is non-unit triangular;
* = 'U': A is unit triangular.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the triangular matrix A. If UPLO = 'U', the
* leading N-by-N upper triangular part of the array A contains
* the upper triangular matrix, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading N-by-N lower triangular part of the array A contains
* the lower triangular matrix, and the strictly upper
* triangular part of A is not referenced. If DIAG = 'U', the
* diagonal elements of A are also not referenced and are
* assumed to be 1.
* On exit, the (triangular) inverse of the original matrix, in
* the same storage format.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, A(i,i) is exactly zero. The triangular
* matrix is singular and its inverse can not be computed.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT, UPPER
INTEGER J, JB, NB, NN
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DTRMM, DTRSM, DTRTI2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOUNIT = LSAME( DIAG, 'N' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTRTRI', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Check for singularity if non-unit.
*
IF( NOUNIT ) THEN
DO 10 INFO = 1, N
IF( A( INFO, INFO ).EQ.ZERO )
$ RETURN
10 CONTINUE
INFO = 0
END IF
*
* Determine the block size for this environment.
*
NB = ILAENV( 1, 'DTRTRI', UPLO // DIAG, N, -1, -1, -1 )
IF( NB.LE.1 .OR. NB.GE.N ) THEN
*
* Use unblocked code
*
CALL DTRTI2( UPLO, DIAG, N, A, LDA, INFO )
ELSE
*
* Use blocked code
*
IF( UPPER ) THEN
*
* Compute inverse of upper triangular matrix
*
DO 20 J = 1, N, NB
JB = MIN( NB, N-J+1 )
*
* Compute rows 1:j-1 of current block column
*
CALL DTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1,
$ JB, ONE, A, LDA, A( 1, J ), LDA )
CALL DTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1,
$ JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA )
*
* Compute inverse of current diagonal block
*
CALL DTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO )
20 CONTINUE
ELSE
*
* Compute inverse of lower triangular matrix
*
NN = ( ( N-1 ) / NB )*NB + 1
DO 30 J = NN, 1, -NB
JB = MIN( NB, N-J+1 )
IF( J+JB.LE.N ) THEN
*
* Compute rows j+jb:n of current block column
*
CALL DTRMM( 'Left', 'Lower', 'No transpose', DIAG,
$ N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA,
$ A( J+JB, J ), LDA )
CALL DTRSM( 'Right', 'Lower', 'No transpose', DIAG,
$ N-J-JB+1, JB, -ONE, A( J, J ), LDA,
$ A( J+JB, J ), LDA )
END IF
*
* Compute inverse of current diagonal block
*
CALL DTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO )
30 CONTINUE
END IF
END IF
*
RETURN
*
* End of DTRTRI
*
END
SUBROUTINE DTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* DTRTRS solves a triangular system of the form
*
* A * X = B or A**T * X = B,
*
* where A is a triangular matrix of order N, and B is an N-by-NRHS
* matrix. A check is made to verify that A is nonsingular.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': A is upper triangular;
* = 'L': A is lower triangular.
*
* 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**H * X = B (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* = 'N': A is non-unit triangular;
* = 'U': A is unit triangular.
*
* 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 triangular matrix A. If UPLO = 'U', the leading N-by-N
* upper triangular part of the array A contains the upper
* triangular matrix, and the strictly lower triangular part of
* A is not referenced. If UPLO = 'L', the leading N-by-N lower
* triangular part of the array A contains the lower triangular
* matrix, and the strictly upper triangular part of A is not
* referenced. If DIAG = 'U', the diagonal elements of A are
* also not referenced and are assumed to be 1.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the right hand side matrix B.
* On exit, if INFO = 0, 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
* > 0: if INFO = i, the i-th diagonal element of A is zero,
* indicating that the matrix is singular and the solutions
* X have not been computed.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DTRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
NOUNIT = LSAME( DIAG, 'N' )
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.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( NRHS.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTRTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Check for singularity.
*
IF( NOUNIT ) THEN
DO 10 INFO = 1, N
IF( A( INFO, INFO ).EQ.ZERO )
$ RETURN
10 CONTINUE
END IF
INFO = 0
*
* Solve A * x = b or A' * x = b.
*
CALL DTRSM( 'Left', UPLO, TRANS, DIAG, N, NRHS, ONE, A, LDA, B,
$ LDB )
*
RETURN
*
* End of DTRTRS
*
END
SUBROUTINE DTZRQF( M, N, A, LDA, TAU, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * )
* ..
*
* Purpose
* =======
*
* This routine is deprecated and has been replaced by routine DTZRZF.
*
* DTZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A
* to upper triangular form by means of orthogonal transformations.
*
* The upper trapezoidal matrix A is factored as
*
* A = ( R 0 ) * Z,
*
* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper
* triangular matrix.
*
* 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 >= M.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the leading M-by-N upper trapezoidal part of the
* array A must contain the matrix to be factorized.
* On exit, the leading M-by-M upper triangular part of A
* contains the upper triangular matrix R, and elements M+1 to
* N of the first M rows of A, with the array TAU, represent the
* orthogonal matrix Z as a product of M elementary reflectors.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* TAU (output) DOUBLE PRECISION array, dimension (M)
* The scalar factors of the elementary reflectors.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Further Details
* ===============
*
* The factorization is obtained by Householder's method. The kth
* transformation matrix, Z( k ), which is used to introduce zeros into
* the ( m - k + 1 )th row of A, is given in the form
*
* Z( k ) = ( I 0 ),
* ( 0 T( k ) )
*
* where
*
* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),
* ( 0 )
* ( z( k ) )
*
* tau is a scalar and z( k ) is an ( n - m ) element vector.
* tau and z( k ) are chosen to annihilate the elements of the kth row
* of X.
*
* The scalar tau is returned in the kth element of TAU and the vector
* u( k ) in the kth row of A, such that the elements of z( k ) are
* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in
* the upper triangular part of A.
*
* Z is given by
*
* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, K, M1
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DGEMV, DGER, DLARFG, XERBLA
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.M ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTZRQF', -INFO )
RETURN
END IF
*
* Perform the factorization.
*
IF( M.EQ.0 )
$ RETURN
IF( M.EQ.N ) THEN
DO 10 I = 1, N
TAU( I ) = ZERO
10 CONTINUE
ELSE
M1 = MIN( M+1, N )
DO 20 K = M, 1, -1
*
* Use a Householder reflection to zero the kth row of A.
* First set up the reflection.
*
CALL DLARFG( N-M+1, A( K, K ), A( K, M1 ), LDA, TAU( K ) )
*
IF( ( TAU( K ).NE.ZERO ) .AND. ( K.GT.1 ) ) THEN
*
* We now perform the operation A := A*P( k ).
*
* Use the first ( k - 1 ) elements of TAU to store a( k ),
* where a( k ) consists of the first ( k - 1 ) elements of
* the kth column of A. Also let B denote the first
* ( k - 1 ) rows of the last ( n - m ) columns of A.
*
CALL DCOPY( K-1, A( 1, K ), 1, TAU, 1 )
*
* Form w = a( k ) + B*z( k ) in TAU.
*
CALL DGEMV( 'No transpose', K-1, N-M, ONE, A( 1, M1 ),
$ LDA, A( K, M1 ), LDA, ONE, TAU, 1 )
*
* Now form a( k ) := a( k ) - tau*w
* and B := B - tau*w*z( k )'.
*
CALL DAXPY( K-1, -TAU( K ), TAU, 1, A( 1, K ), 1 )
CALL DGER( K-1, N-M, -TAU( K ), TAU, 1, A( K, M1 ), LDA,
$ A( 1, M1 ), LDA )
END IF
20 CONTINUE
END IF
*
RETURN
*
* End of DTZRQF
*
END
SUBROUTINE DTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DTZRZF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A
* to upper triangular form by means of orthogonal transformations.
*
* The upper trapezoidal matrix A is factored as
*
* A = ( R 0 ) * Z,
*
* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper
* triangular matrix.
*
* 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 >= M.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the leading M-by-N upper trapezoidal part of the
* array A must contain the matrix to be factorized.
* On exit, the leading M-by-M upper triangular part of A
* contains the upper triangular matrix R, and elements M+1 to
* N of the first M rows of A, with the array TAU, represent the
* orthogonal matrix Z as a product of M elementary reflectors.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* TAU (output) DOUBLE PRECISION array, dimension (M)
* The scalar factors of the elementary reflectors.
*
* 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,M).
* For optimum performance LWORK >= M*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
* ===============
*
* Based on contributions by
* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*
* The factorization is obtained by Householder's method. The kth
* transformation matrix, Z( k ), which is used to introduce zeros into
* the ( m - k + 1 )th row of A, is given in the form
*
* Z( k ) = ( I 0 ),
* ( 0 T( k ) )
*
* where
*
* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),
* ( 0 )
* ( z( k ) )
*
* tau is a scalar and z( k ) is an ( n - m ) element vector.
* tau and z( k ) are chosen to annihilate the elements of the kth row
* of X.
*
* The scalar tau is returned in the kth element of TAU and the vector
* u( k ) in the kth row of A, such that the elements of z( k ) are
* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in
* the upper triangular part of A.
*
* Z is given by
*
* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IWS, KI, KK, LDWORK, LWKOPT, M1, MU, NB,
$ NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL DLARZB, DLARZT, DLATRZ, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.M ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
END IF
*
IF( INFO.EQ.0 ) THEN
IF( M.EQ.0 .OR. M.EQ.N ) THEN
LWKOPT = 1
ELSE
*
* Determine the block size.
*
NB = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 )
LWKOPT = M*NB
END IF
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
INFO = -7
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTZRZF', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 ) THEN
RETURN
ELSE IF( M.EQ.N ) THEN
DO 10 I = 1, N
TAU( I ) = ZERO
10 CONTINUE
RETURN
END IF
*
NBMIN = 2
NX = 1
IWS = M
IF( NB.GT.1 .AND. NB.LT.M ) THEN
*
* Determine when to cross over from blocked to unblocked code.
*
NX = MAX( 0, ILAENV( 3, 'DGERQF', ' ', M, N, -1, -1 ) )
IF( NX.LT.M ) THEN
*
* Determine if workspace is large enough for blocked code.
*
LDWORK = M
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, 'DGERQF', ' ', M, N, -1,
$ -1 ) )
END IF
END IF
END IF
*
IF( NB.GE.NBMIN .AND. NB.LT.M .AND. NX.LT.M ) THEN
*
* Use blocked code initially.
* The last kk rows are handled by the block method.
*
M1 = MIN( M+1, N )
KI = ( ( M-NX-1 ) / NB )*NB
KK = MIN( M, KI+NB )
*
DO 20 I = M - KK + KI + 1, M - KK + 1, -NB
IB = MIN( M-I+1, NB )
*
* Compute the TZ factorization of the current block
* A(i:i+ib-1,i:n)
*
CALL DLATRZ( IB, N-I+1, N-M, A( I, I ), LDA, TAU( I ),
$ WORK )
IF( I.GT.1 ) THEN
*
* Form the triangular factor of the block reflector
* H = H(i+ib-1) . . . H(i+1) H(i)
*
CALL DLARZT( 'Backward', 'Rowwise', N-M, IB, A( I, M1 ),
$ LDA, TAU( I ), WORK, LDWORK )
*
* Apply H to A(1:i-1,i:n) from the right
*
CALL DLARZB( 'Right', 'No transpose', 'Backward',
$ 'Rowwise', I-1, N-I+1, IB, N-M, A( I, M1 ),
$ LDA, WORK, LDWORK, A( 1, I ), LDA,
$ WORK( IB+1 ), LDWORK )
END IF
20 CONTINUE
MU = I + NB - 1
ELSE
MU = M
END IF
*
* Use unblocked code to factor the last or only block
*
IF( MU.GT.0 )
$ CALL DLATRZ( MU, N, N-M, A, LDA, TAU, WORK )
*
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of DTZRZF
*
END
INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. 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*0.0
*
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 ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 )
*
* -- LAPACK auxiliary routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* January 2007
*
* .. 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( 0, 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( 1, 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
SUBROUTINE ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH )
*
* -- LAPACK routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* January 2007
* ..
*
* Purpose
* =======
*
* This subroutine return the Lapack version
*
* Arguments
* =========
* VERS_MAJOR (output) INTEGER
* return the lapack major version
* VERS_MINOR (output) INTEGER
* return the lapack minor version from the major version
* VERS_PATCH (output) INTEGER
* return the lapack patch version from the minor version
* =====================================================================
*
INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH
* =====================================================================
VERS_MAJOR = 3
VERS_MINOR = 1
VERS_PATCH = 1
* =====================================================================
*
RETURN
END
INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley 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
LOGICAL FUNCTION LSAMEN( N, CA, CB )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*( * ) CA, CB
INTEGER N
* ..
*
* Purpose
* =======
*
* LSAMEN tests if the first N letters of CA are the same as the
* first N letters of CB, regardless of case.
* LSAMEN returns .TRUE. if CA and CB are equivalent except for case
* and .FALSE. otherwise. LSAMEN also returns .FALSE. if LEN( CA )
* or LEN( CB ) is less than N.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of characters in CA and CB to be compared.
*
* CA (input) CHARACTER*(*)
* CB (input) CHARACTER*(*)
* CA and CB specify two character strings of length at least N.
* Only the first N characters of each string will be accessed.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC LEN
* ..
* .. Executable Statements ..
*
LSAMEN = .FALSE.
IF( LEN( CA ).LT.N .OR. LEN( CB ).LT.N )
$ GO TO 20
*
* Do for each character in the two strings.
*
DO 10 I = 1, N
*
* Test if the characters are equal using LSAME.
*
IF( .NOT.LSAME( CA( I: I ), CB( I: I ) ) )
$ GO TO 20
*
10 CONTINUE
LSAMEN = .TRUE.
*
20 CONTINUE
RETURN
*
* End of LSAMEN
*
END
SUBROUTINE SBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ,
$ WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER COMPQ, UPLO
INTEGER INFO, LDU, LDVT, N
* ..
* .. Array Arguments ..
INTEGER IQ( * ), IWORK( * )
REAL D( * ), E( * ), Q( * ), U( LDU, * ),
$ VT( LDVT, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SBDSDC computes the singular value decomposition (SVD) of a real
* N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT,
* using a divide and conquer method, where S is a diagonal matrix
* with non-negative diagonal elements (the singular values of B), and
* U and VT are orthogonal matrices of left and right singular vectors,
* respectively. SBDSDC can be used to compute all singular values,
* and optionally, singular vectors or singular vectors in compact form.
*
* This code makes very mild assumptions about floating point
* arithmetic. It will work on machines with a guard digit in
* add/subtract, or on those binary machines without guard digits
* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
* It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none. See SLASD3 for details.
*
* The code currently calls SLASDQ if singular values only are desired.
* However, it can be slightly modified to compute singular values
* using the divide and conquer method.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': B is upper bidiagonal.
* = 'L': B is lower bidiagonal.
*
* COMPQ (input) CHARACTER*1
* Specifies whether singular vectors are to be computed
* as follows:
* = 'N': Compute singular values only;
* = 'P': Compute singular values and compute singular
* vectors in compact form;
* = 'I': Compute singular values and singular vectors.
*
* N (input) INTEGER
* The order of the matrix B. N >= 0.
*
* D (input/output) REAL array, dimension (N)
* On entry, the n diagonal elements of the bidiagonal matrix B.
* On exit, if INFO=0, the singular values of B.
*
* E (input/output) REAL array, dimension (N-1)
* On entry, the elements of E contain the offdiagonal
* elements of the bidiagonal matrix whose SVD is desired.
* On exit, E has been destroyed.
*
* U (output) REAL array, dimension (LDU,N)
* If COMPQ = 'I', then:
* On exit, if INFO = 0, U contains the left singular vectors
* of the bidiagonal matrix.
* For other values of COMPQ, U is not referenced.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= 1.
* If singular vectors are desired, then LDU >= max( 1, N ).
*
* VT (output) REAL array, dimension (LDVT,N)
* If COMPQ = 'I', then:
* On exit, if INFO = 0, VT' contains the right singular
* vectors of the bidiagonal matrix.
* For other values of COMPQ, VT is not referenced.
*
* LDVT (input) INTEGER
* The leading dimension of the array VT. LDVT >= 1.
* If singular vectors are desired, then LDVT >= max( 1, N ).
*
* Q (output) REAL array, dimension (LDQ)
* If COMPQ = 'P', then:
* On exit, if INFO = 0, Q and IQ contain the left
* and right singular vectors in a compact form,
* requiring O(N log N) space instead of 2*N**2.
* In particular, Q contains all the REAL data in
* LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))
* words of memory, where SMLSIZ is returned by ILAENV and
* is equal to the maximum size of the subproblems at the
* bottom of the computation tree (usually about 25).
* For other values of COMPQ, Q is not referenced.
*
* IQ (output) INTEGER array, dimension (LDIQ)
* If COMPQ = 'P', then:
* On exit, if INFO = 0, Q and IQ contain the left
* and right singular vectors in a compact form,
* requiring O(N log N) space instead of 2*N**2.
* In particular, IQ contains all INTEGER data in
* LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))
* words of memory, where SMLSIZ is returned by ILAENV and
* is equal to the maximum size of the subproblems at the
* bottom of the computation tree (usually about 25).
* For other values of COMPQ, IQ is not referenced.
*
* WORK (workspace) REAL array, dimension (MAX(1,LWORK))
* If COMPQ = 'N' then LWORK >= (4 * N).
* If COMPQ = 'P' then LWORK >= (6 * N).
* If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N).
*
* IWORK (workspace) INTEGER array, dimension (8*N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: The algorithm failed to compute an singular value.
* The update process of divide and conquer failed.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
* =====================================================================
* Changed dimension statement in comment describing E from (N) to
* (N-1). Sven, 17 Feb 05.
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
* ..
* .. Local Scalars ..
INTEGER DIFL, DIFR, GIVCOL, GIVNUM, GIVPTR, I, IC,
$ ICOMPQ, IERR, II, IS, IU, IUPLO, IVT, J, K, KK,
$ MLVL, NM1, NSIZE, PERM, POLES, QSTART, SMLSIZ,
$ SMLSZP, SQRE, START, WSTART, Z
REAL CS, EPS, ORGNRM, P, R, SN
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
REAL SLAMCH, SLANST
EXTERNAL SLAMCH, SLANST, ILAENV, LSAME
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLARTG, SLASCL, SLASD0, SLASDA, SLASDQ,
$ SLASET, SLASR, SSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL, ABS, INT, LOG, SIGN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IUPLO = 0
IF( LSAME( UPLO, 'U' ) )
$ IUPLO = 1
IF( LSAME( UPLO, 'L' ) )
$ IUPLO = 2
IF( LSAME( COMPQ, 'N' ) ) THEN
ICOMPQ = 0
ELSE IF( LSAME( COMPQ, 'P' ) ) THEN
ICOMPQ = 1
ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
ICOMPQ = 2
ELSE
ICOMPQ = -1
END IF
IF( IUPLO.EQ.0 ) THEN
INFO = -1
ELSE IF( ICOMPQ.LT.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ( LDU.LT.1 ) .OR. ( ( ICOMPQ.EQ.2 ) .AND. ( LDU.LT.
$ N ) ) ) THEN
INFO = -7
ELSE IF( ( LDVT.LT.1 ) .OR. ( ( ICOMPQ.EQ.2 ) .AND. ( LDVT.LT.
$ N ) ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SBDSDC', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
SMLSIZ = ILAENV( 9, 'SBDSDC', ' ', 0, 0, 0, 0 )
IF( N.EQ.1 ) THEN
IF( ICOMPQ.EQ.1 ) THEN
Q( 1 ) = SIGN( ONE, D( 1 ) )
Q( 1+SMLSIZ*N ) = ONE
ELSE IF( ICOMPQ.EQ.2 ) THEN
U( 1, 1 ) = SIGN( ONE, D( 1 ) )
VT( 1, 1 ) = ONE
END IF
D( 1 ) = ABS( D( 1 ) )
RETURN
END IF
NM1 = N - 1
*
* If matrix lower bidiagonal, rotate to be upper bidiagonal
* by applying Givens rotations on the left
*
WSTART = 1
QSTART = 3
IF( ICOMPQ.EQ.1 ) THEN
CALL SCOPY( N, D, 1, Q( 1 ), 1 )
CALL SCOPY( N-1, E, 1, Q( N+1 ), 1 )
END IF
IF( IUPLO.EQ.2 ) THEN
QSTART = 5
WSTART = 2*N - 1
DO 10 I = 1, N - 1
CALL SLARTG( D( I ), E( I ), CS, SN, R )
D( I ) = R
E( I ) = SN*D( I+1 )
D( I+1 ) = CS*D( I+1 )
IF( ICOMPQ.EQ.1 ) THEN
Q( I+2*N ) = CS
Q( I+3*N ) = SN
ELSE IF( ICOMPQ.EQ.2 ) THEN
WORK( I ) = CS
WORK( NM1+I ) = -SN
END IF
10 CONTINUE
END IF
*
* If ICOMPQ = 0, use SLASDQ to compute the singular values.
*
IF( ICOMPQ.EQ.0 ) THEN
CALL SLASDQ( 'U', 0, N, 0, 0, 0, D, E, VT, LDVT, U, LDU, U,
$ LDU, WORK( WSTART ), INFO )
GO TO 40
END IF
*
* If N is smaller than the minimum divide size SMLSIZ, then solve
* the problem with another solver.
*
IF( N.LE.SMLSIZ ) THEN
IF( ICOMPQ.EQ.2 ) THEN
CALL SLASET( 'A', N, N, ZERO, ONE, U, LDU )
CALL SLASET( 'A', N, N, ZERO, ONE, VT, LDVT )
CALL SLASDQ( 'U', 0, N, N, N, 0, D, E, VT, LDVT, U, LDU, U,
$ LDU, WORK( WSTART ), INFO )
ELSE IF( ICOMPQ.EQ.1 ) THEN
IU = 1
IVT = IU + N
CALL SLASET( 'A', N, N, ZERO, ONE, Q( IU+( QSTART-1 )*N ),
$ N )
CALL SLASET( 'A', N, N, ZERO, ONE, Q( IVT+( QSTART-1 )*N ),
$ N )
CALL SLASDQ( 'U', 0, N, N, N, 0, D, E,
$ Q( IVT+( QSTART-1 )*N ), N,
$ Q( IU+( QSTART-1 )*N ), N,
$ Q( IU+( QSTART-1 )*N ), N, WORK( WSTART ),
$ INFO )
END IF
GO TO 40
END IF
*
IF( ICOMPQ.EQ.2 ) THEN
CALL SLASET( 'A', N, N, ZERO, ONE, U, LDU )
CALL SLASET( 'A', N, N, ZERO, ONE, VT, LDVT )
END IF
*
* Scale.
*
ORGNRM = SLANST( 'M', N, D, E )
IF( ORGNRM.EQ.ZERO )
$ RETURN
CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, IERR )
CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, IERR )
*
EPS = SLAMCH( 'Epsilon' )
*
MLVL = INT( LOG( REAL( N ) / REAL( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1
SMLSZP = SMLSIZ + 1
*
IF( ICOMPQ.EQ.1 ) THEN
IU = 1
IVT = 1 + SMLSIZ
DIFL = IVT + SMLSZP
DIFR = DIFL + MLVL
Z = DIFR + MLVL*2
IC = Z + MLVL
IS = IC + 1
POLES = IS + 1
GIVNUM = POLES + 2*MLVL
*
K = 1
GIVPTR = 2
PERM = 3
GIVCOL = PERM + MLVL
END IF
*
DO 20 I = 1, N
IF( ABS( D( I ) ).LT.EPS ) THEN
D( I ) = SIGN( EPS, D( I ) )
END IF
20 CONTINUE
*
START = 1
SQRE = 0
*
DO 30 I = 1, NM1
IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN
*
* Subproblem found. First determine its size and then
* apply divide and conquer on it.
*
IF( I.LT.NM1 ) THEN
*
* A subproblem with E(I) small for I < NM1.
*
NSIZE = I - START + 1
ELSE IF( ABS( E( I ) ).GE.EPS ) THEN
*
* A subproblem with E(NM1) not too small but I = NM1.
*
NSIZE = N - START + 1
ELSE
*
* A subproblem with E(NM1) small. This implies an
* 1-by-1 subproblem at D(N). Solve this 1-by-1 problem
* first.
*
NSIZE = I - START + 1
IF( ICOMPQ.EQ.2 ) THEN
U( N, N ) = SIGN( ONE, D( N ) )
VT( N, N ) = ONE
ELSE IF( ICOMPQ.EQ.1 ) THEN
Q( N+( QSTART-1 )*N ) = SIGN( ONE, D( N ) )
Q( N+( SMLSIZ+QSTART-1 )*N ) = ONE
END IF
D( N ) = ABS( D( N ) )
END IF
IF( ICOMPQ.EQ.2 ) THEN
CALL SLASD0( NSIZE, SQRE, D( START ), E( START ),
$ U( START, START ), LDU, VT( START, START ),
$ LDVT, SMLSIZ, IWORK, WORK( WSTART ), INFO )
ELSE
CALL SLASDA( ICOMPQ, SMLSIZ, NSIZE, SQRE, D( START ),
$ E( START ), Q( START+( IU+QSTART-2 )*N ), N,
$ Q( START+( IVT+QSTART-2 )*N ),
$ IQ( START+K*N ), Q( START+( DIFL+QSTART-2 )*
$ N ), Q( START+( DIFR+QSTART-2 )*N ),
$ Q( START+( Z+QSTART-2 )*N ),
$ Q( START+( POLES+QSTART-2 )*N ),
$ IQ( START+GIVPTR*N ), IQ( START+GIVCOL*N ),
$ N, IQ( START+PERM*N ),
$ Q( START+( GIVNUM+QSTART-2 )*N ),
$ Q( START+( IC+QSTART-2 )*N ),
$ Q( START+( IS+QSTART-2 )*N ),
$ WORK( WSTART ), IWORK, INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
END IF
START = I + 1
END IF
30 CONTINUE
*
* Unscale
*
CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, IERR )
40 CONTINUE
*
* Use Selection Sort to minimize swaps of singular vectors
*
DO 60 II = 2, N
I = II - 1
KK = I
P = D( I )
DO 50 J = II, N
IF( D( J ).GT.P ) THEN
KK = J
P = D( J )
END IF
50 CONTINUE
IF( KK.NE.I ) THEN
D( KK ) = D( I )
D( I ) = P
IF( ICOMPQ.EQ.1 ) THEN
IQ( I ) = KK
ELSE IF( ICOMPQ.EQ.2 ) THEN
CALL SSWAP( N, U( 1, I ), 1, U( 1, KK ), 1 )
CALL SSWAP( N, VT( I, 1 ), LDVT, VT( KK, 1 ), LDVT )
END IF
ELSE IF( ICOMPQ.EQ.1 ) THEN
IQ( I ) = I
END IF
60 CONTINUE
*
* If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO
*
IF( ICOMPQ.EQ.1 ) THEN
IF( IUPLO.EQ.1 ) THEN
IQ( N ) = 1
ELSE
IQ( N ) = 0
END IF
END IF
*
* If B is lower bidiagonal, update U by those Givens rotations
* which rotated B to be upper bidiagonal
*
IF( ( IUPLO.EQ.2 ) .AND. ( ICOMPQ.EQ.2 ) )
$ CALL SLASR( 'L', 'V', 'B', N, N, WORK( 1 ), WORK( N ), U, LDU )
*
RETURN
*
* End of SBDSDC
*
END
SUBROUTINE SBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U,
$ LDU, C, LDC, WORK, INFO )
*
* -- LAPACK routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* January 2007
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU
* ..
* .. Array Arguments ..
REAL C( LDC, * ), D( * ), E( * ), U( LDU, * ),
$ VT( LDVT, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SBDSQR computes the singular values and, optionally, the right and/or
* left singular vectors from the singular value decomposition (SVD) of
* a real N-by-N (upper or lower) bidiagonal matrix B using the implicit
* zero-shift QR algorithm. The SVD of B has the form
*
* B = Q * S * P**T
*
* where S is the diagonal matrix of singular values, Q is an orthogonal
* matrix of left singular vectors, and P is an orthogonal matrix of
* right singular vectors. If left singular vectors are requested, this
* subroutine actually returns U*Q instead of Q, and, if right singular
* vectors are requested, this subroutine returns P**T*VT instead of
* P**T, for given real input matrices U and VT. When U and VT are the
* orthogonal matrices that reduce a general matrix A to bidiagonal
* form: A = U*B*VT, as computed by SGEBRD, then
*
* A = (U*Q) * S * (P**T*VT)
*
* is the SVD of A. Optionally, the subroutine may also compute Q**T*C
* for a given real input matrix C.
*
* See "Computing Small Singular Values of Bidiagonal Matrices With
* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,
* no. 5, pp. 873-912, Sept 1990) and
* "Accurate singular values and differential qd algorithms," by
* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics
* Department, University of California at Berkeley, July 1992
* for a detailed description of the algorithm.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': B is upper bidiagonal;
* = 'L': B is lower bidiagonal.
*
* N (input) INTEGER
* The order of the matrix B. N >= 0.
*
* NCVT (input) INTEGER
* The number of columns of the matrix VT. NCVT >= 0.
*
* NRU (input) INTEGER
* The number of rows of the matrix U. NRU >= 0.
*
* NCC (input) INTEGER
* The number of columns of the matrix C. NCC >= 0.
*
* D (input/output) REAL array, dimension (N)
* On entry, the n diagonal elements of the bidiagonal matrix B.
* On exit, if INFO=0, the singular values of B in decreasing
* order.
*
* E (input/output) REAL array, dimension (N-1)
* On entry, the N-1 offdiagonal elements of the bidiagonal
* matrix B.
* On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E
* will contain the diagonal and superdiagonal elements of a
* bidiagonal matrix orthogonally equivalent to the one given
* as input.
*
* VT (input/output) REAL array, dimension (LDVT, NCVT)
* On entry, an N-by-NCVT matrix VT.
* On exit, VT is overwritten by P**T * VT.
* Not referenced if NCVT = 0.
*
* LDVT (input) INTEGER
* The leading dimension of the array VT.
* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.
*
* U (input/output) REAL array, dimension (LDU, N)
* On entry, an NRU-by-N matrix U.
* On exit, U is overwritten by U * Q.
* Not referenced if NRU = 0.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= max(1,NRU).
*
* C (input/output) REAL array, dimension (LDC, NCC)
* On entry, an N-by-NCC matrix C.
* On exit, C is overwritten by Q**T * C.
* Not referenced if NCC = 0.
*
* LDC (input) INTEGER
* The leading dimension of the array C.
* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.
*
* WORK (workspace) REAL array, dimension (2*N)
* if NCVT = NRU = NCC = 0, (max(1, 4*N)) otherwise
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: If INFO = -i, the i-th argument had an illegal value
* > 0: the algorithm did not converge; D and E contain the
* elements of a bidiagonal matrix which is orthogonally
* similar to the input matrix B; if INFO = i, i
* elements of E have not converged to zero.
*
* Internal Parameters
* ===================
*
* TOLMUL REAL, default = max(10,min(100,EPS**(-1/8)))
* TOLMUL controls the convergence criterion of the QR loop.
* If it is positive, TOLMUL*EPS is the desired relative
* precision in the computed singular values.
* If it is negative, abs(TOLMUL*EPS*sigma_max) is the
* desired absolute accuracy in the computed singular
* values (corresponds to relative accuracy
* abs(TOLMUL*EPS) in the largest singular value.
* abs(TOLMUL) should be between 1 and 1/EPS, and preferably
* between 10 (for fast convergence) and .1/EPS
* (for there to be some accuracy in the results).
* Default is to lose at either one eighth or 2 of the
* available decimal digits in each computed singular value
* (whichever is smaller).
*
* MAXITR INTEGER, default = 6
* MAXITR controls the maximum number of passes of the
* algorithm through its inner loop. The algorithms stops
* (and so fails to converge) if the number of passes
* through the inner loop exceeds MAXITR*N**2.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
REAL ONE
PARAMETER ( ONE = 1.0E0 )
REAL NEGONE
PARAMETER ( NEGONE = -1.0E0 )
REAL HNDRTH
PARAMETER ( HNDRTH = 0.01E0 )
REAL TEN
PARAMETER ( TEN = 10.0E0 )
REAL HNDRD
PARAMETER ( HNDRD = 100.0E0 )
REAL MEIGTH
PARAMETER ( MEIGTH = -0.125E0 )
INTEGER MAXITR
PARAMETER ( MAXITR = 6 )
* ..
* .. Local Scalars ..
LOGICAL LOWER, ROTATE
INTEGER I, IDIR, ISUB, ITER, J, LL, LLL, M, MAXIT, NM1,
$ NM12, NM13, OLDLL, OLDM
REAL ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU,
$ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL,
$ SINR, SLL, SMAX, SMIN, SMINL, SMINOA,
$ SN, THRESH, TOL, TOLMUL, UNFL
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH
EXTERNAL LSAME, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SLARTG, SLAS2, SLASQ1, SLASR, SLASV2, SROT,
$ SSCAL, SSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
LOWER = LSAME( UPLO, 'L' )
IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LOWER ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NCVT.LT.0 ) THEN
INFO = -3
ELSE IF( NRU.LT.0 ) THEN
INFO = -4
ELSE IF( NCC.LT.0 ) THEN
INFO = -5
ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR.
$ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN
INFO = -9
ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN
INFO = -11
ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR.
$ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN
INFO = -13
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SBDSQR', -INFO )
RETURN
END IF
IF( N.EQ.0 )
$ RETURN
IF( N.EQ.1 )
$ GO TO 160
*
* ROTATE is true if any singular vectors desired, false otherwise
*
ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 )
*
* If no singular vectors desired, use qd algorithm
*
IF( .NOT.ROTATE ) THEN
CALL SLASQ1( N, D, E, WORK, INFO )
RETURN
END IF
*
NM1 = N - 1
NM12 = NM1 + NM1
NM13 = NM12 + NM1
IDIR = 0
*
* Get machine constants
*
EPS = SLAMCH( 'Epsilon' )
UNFL = SLAMCH( 'Safe minimum' )
*
* If matrix lower bidiagonal, rotate to be upper bidiagonal
* by applying Givens rotations on the left
*
IF( LOWER ) THEN
DO 10 I = 1, N - 1
CALL SLARTG( D( I ), E( I ), CS, SN, R )
D( I ) = R
E( I ) = SN*D( I+1 )
D( I+1 ) = CS*D( I+1 )
WORK( I ) = CS
WORK( NM1+I ) = SN
10 CONTINUE
*
* Update singular vectors if desired
*
IF( NRU.GT.0 )
$ CALL SLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ), WORK( N ), U,
$ LDU )
IF( NCC.GT.0 )
$ CALL SLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ), WORK( N ), C,
$ LDC )
END IF
*
* Compute singular values to relative accuracy TOL
* (By setting TOL to be negative, algorithm will compute
* singular values to absolute accuracy ABS(TOL)*norm(input matrix))
*
TOLMUL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) )
TOL = TOLMUL*EPS
*
* Compute approximate maximum, minimum singular values
*
SMAX = ZERO
DO 20 I = 1, N
SMAX = MAX( SMAX, ABS( D( I ) ) )
20 CONTINUE
DO 30 I = 1, N - 1
SMAX = MAX( SMAX, ABS( E( I ) ) )
30 CONTINUE
SMINL = ZERO
IF( TOL.GE.ZERO ) THEN
*
* Relative accuracy desired
*
SMINOA = ABS( D( 1 ) )
IF( SMINOA.EQ.ZERO )
$ GO TO 50
MU = SMINOA
DO 40 I = 2, N
MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) )
SMINOA = MIN( SMINOA, MU )
IF( SMINOA.EQ.ZERO )
$ GO TO 50
40 CONTINUE
50 CONTINUE
SMINOA = SMINOA / SQRT( REAL( N ) )
THRESH = MAX( TOL*SMINOA, MAXITR*N*N*UNFL )
ELSE
*
* Absolute accuracy desired
*
THRESH = MAX( ABS( TOL )*SMAX, MAXITR*N*N*UNFL )
END IF
*
* Prepare for main iteration loop for the singular values
* (MAXIT is the maximum number of passes through the inner
* loop permitted before nonconvergence signalled.)
*
MAXIT = MAXITR*N*N
ITER = 0
OLDLL = -1
OLDM = -1
*
* M points to last element of unconverged part of matrix
*
M = N
*
* Begin main iteration loop
*
60 CONTINUE
*
* Check for convergence or exceeding iteration count
*
IF( M.LE.1 )
$ GO TO 160
IF( ITER.GT.MAXIT )
$ GO TO 200
*
* Find diagonal block of matrix to work on
*
IF( TOL.LT.ZERO .AND. ABS( D( M ) ).LE.THRESH )
$ D( M ) = ZERO
SMAX = ABS( D( M ) )
SMIN = SMAX
DO 70 LLL = 1, M - 1
LL = M - LLL
ABSS = ABS( D( LL ) )
ABSE = ABS( E( LL ) )
IF( TOL.LT.ZERO .AND. ABSS.LE.THRESH )
$ D( LL ) = ZERO
IF( ABSE.LE.THRESH )
$ GO TO 80
SMIN = MIN( SMIN, ABSS )
SMAX = MAX( SMAX, ABSS, ABSE )
70 CONTINUE
LL = 0
GO TO 90
80 CONTINUE
E( LL ) = ZERO
*
* Matrix splits since E(LL) = 0
*
IF( LL.EQ.M-1 ) THEN
*
* Convergence of bottom singular value, return to top of loop
*
M = M - 1
GO TO 60
END IF
90 CONTINUE
LL = LL + 1
*
* E(LL) through E(M-1) are nonzero, E(LL-1) is zero
*
IF( LL.EQ.M-1 ) THEN
*
* 2 by 2 block, handle separately
*
CALL SLASV2( D( M-1 ), E( M-1 ), D( M ), SIGMN, SIGMX, SINR,
$ COSR, SINL, COSL )
D( M-1 ) = SIGMX
E( M-1 ) = ZERO
D( M ) = SIGMN
*
* Compute singular vectors, if desired
*
IF( NCVT.GT.0 )
$ CALL SROT( NCVT, VT( M-1, 1 ), LDVT, VT( M, 1 ), LDVT, COSR,
$ SINR )
IF( NRU.GT.0 )
$ CALL SROT( NRU, U( 1, M-1 ), 1, U( 1, M ), 1, COSL, SINL )
IF( NCC.GT.0 )
$ CALL SROT( NCC, C( M-1, 1 ), LDC, C( M, 1 ), LDC, COSL,
$ SINL )
M = M - 2
GO TO 60
END IF
*
* If working on new submatrix, choose shift direction
* (from larger end diagonal element towards smaller)
*
IF( LL.GT.OLDM .OR. M.LT.OLDLL ) THEN
IF( ABS( D( LL ) ).GE.ABS( D( M ) ) ) THEN
*
* Chase bulge from top (big end) to bottom (small end)
*
IDIR = 1
ELSE
*
* Chase bulge from bottom (big end) to top (small end)
*
IDIR = 2
END IF
END IF
*
* Apply convergence tests
*
IF( IDIR.EQ.1 ) THEN
*
* Run convergence test in forward direction
* First apply standard test to bottom of matrix
*
IF( ABS( E( M-1 ) ).LE.ABS( TOL )*ABS( D( M ) ) .OR.
$ ( TOL.LT.ZERO .AND. ABS( E( M-1 ) ).LE.THRESH ) ) THEN
E( M-1 ) = ZERO
GO TO 60
END IF
*
IF( TOL.GE.ZERO ) THEN
*
* If relative accuracy desired,
* apply convergence criterion forward
*
MU = ABS( D( LL ) )
SMINL = MU
DO 100 LLL = LL, M - 1
IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
E( LLL ) = ZERO
GO TO 60
END IF
MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
SMINL = MIN( SMINL, MU )
100 CONTINUE
END IF
*
ELSE
*
* Run convergence test in backward direction
* First apply standard test to top of matrix
*
IF( ABS( E( LL ) ).LE.ABS( TOL )*ABS( D( LL ) ) .OR.
$ ( TOL.LT.ZERO .AND. ABS( E( LL ) ).LE.THRESH ) ) THEN
E( LL ) = ZERO
GO TO 60
END IF
*
IF( TOL.GE.ZERO ) THEN
*
* If relative accuracy desired,
* apply convergence criterion backward
*
MU = ABS( D( M ) )
SMINL = MU
DO 110 LLL = M - 1, LL, -1
IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
E( LLL ) = ZERO
GO TO 60
END IF
MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
SMINL = MIN( SMINL, MU )
110 CONTINUE
END IF
END IF
OLDLL = LL
OLDM = M
*
* Compute shift. First, test if shifting would ruin relative
* accuracy, and if so set the shift to zero.
*
IF( TOL.GE.ZERO .AND. N*TOL*( SMINL / SMAX ).LE.
$ MAX( EPS, HNDRTH*TOL ) ) THEN
*
* Use a zero shift to avoid loss of relative accuracy
*
SHIFT = ZERO
ELSE
*
* Compute the shift from 2-by-2 block at end of matrix
*
IF( IDIR.EQ.1 ) THEN
SLL = ABS( D( LL ) )
CALL SLAS2( D( M-1 ), E( M-1 ), D( M ), SHIFT, R )
ELSE
SLL = ABS( D( M ) )
CALL SLAS2( D( LL ), E( LL ), D( LL+1 ), SHIFT, R )
END IF
*
* Test if shift negligible, and if so set to zero
*
IF( SLL.GT.ZERO ) THEN
IF( ( SHIFT / SLL )**2.LT.EPS )
$ SHIFT = ZERO
END IF
END IF
*
* Increment iteration count
*
ITER = ITER + M - LL
*
* If SHIFT = 0, do simplified QR iteration
*
IF( SHIFT.EQ.ZERO ) THEN
IF( IDIR.EQ.1 ) THEN
*
* Chase bulge from top to bottom
* Save cosines and sines for later singular vector updates
*
CS = ONE
OLDCS = ONE
DO 120 I = LL, M - 1
CALL SLARTG( D( I )*CS, E( I ), CS, SN, R )
IF( I.GT.LL )
$ E( I-1 ) = OLDSN*R
CALL SLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) )
WORK( I-LL+1 ) = CS
WORK( I-LL+1+NM1 ) = SN
WORK( I-LL+1+NM12 ) = OLDCS
WORK( I-LL+1+NM13 ) = OLDSN
120 CONTINUE
H = D( M )*CS
D( M ) = H*OLDCS
E( M-1 ) = H*OLDSN
*
* Update singular vectors
*
IF( NCVT.GT.0 )
$ CALL SLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ),
$ WORK( N ), VT( LL, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL SLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ),
$ WORK( NM13+1 ), U( 1, LL ), LDU )
IF( NCC.GT.0 )
$ CALL SLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ),
$ WORK( NM13+1 ), C( LL, 1 ), LDC )
*
* Test convergence
*
IF( ABS( E( M-1 ) ).LE.THRESH )
$ E( M-1 ) = ZERO
*
ELSE
*
* Chase bulge from bottom to top
* Save cosines and sines for later singular vector updates
*
CS = ONE
OLDCS = ONE
DO 130 I = M, LL + 1, -1
CALL SLARTG( D( I )*CS, E( I-1 ), CS, SN, R )
IF( I.LT.M )
$ E( I ) = OLDSN*R
CALL SLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) )
WORK( I-LL ) = CS
WORK( I-LL+NM1 ) = -SN
WORK( I-LL+NM12 ) = OLDCS
WORK( I-LL+NM13 ) = -OLDSN
130 CONTINUE
H = D( LL )*CS
D( LL ) = H*OLDCS
E( LL ) = H*OLDSN
*
* Update singular vectors
*
IF( NCVT.GT.0 )
$ CALL SLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ),
$ WORK( NM13+1 ), VT( LL, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL SLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ),
$ WORK( N ), U( 1, LL ), LDU )
IF( NCC.GT.0 )
$ CALL SLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ),
$ WORK( N ), C( LL, 1 ), LDC )
*
* Test convergence
*
IF( ABS( E( LL ) ).LE.THRESH )
$ E( LL ) = ZERO
END IF
ELSE
*
* Use nonzero shift
*
IF( IDIR.EQ.1 ) THEN
*
* Chase bulge from top to bottom
* Save cosines and sines for later singular vector updates
*
F = ( ABS( D( LL ) )-SHIFT )*
$ ( SIGN( ONE, D( LL ) )+SHIFT / D( LL ) )
G = E( LL )
DO 140 I = LL, M - 1
CALL SLARTG( F, G, COSR, SINR, R )
IF( I.GT.LL )
$ E( I-1 ) = R
F = COSR*D( I ) + SINR*E( I )
E( I ) = COSR*E( I ) - SINR*D( I )
G = SINR*D( I+1 )
D( I+1 ) = COSR*D( I+1 )
CALL SLARTG( F, G, COSL, SINL, R )
D( I ) = R
F = COSL*E( I ) + SINL*D( I+1 )
D( I+1 ) = COSL*D( I+1 ) - SINL*E( I )
IF( I.LT.M-1 ) THEN
G = SINL*E( I+1 )
E( I+1 ) = COSL*E( I+1 )
END IF
WORK( I-LL+1 ) = COSR
WORK( I-LL+1+NM1 ) = SINR
WORK( I-LL+1+NM12 ) = COSL
WORK( I-LL+1+NM13 ) = SINL
140 CONTINUE
E( M-1 ) = F
*
* Update singular vectors
*
IF( NCVT.GT.0 )
$ CALL SLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ),
$ WORK( N ), VT( LL, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL SLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ),
$ WORK( NM13+1 ), U( 1, LL ), LDU )
IF( NCC.GT.0 )
$ CALL SLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ),
$ WORK( NM13+1 ), C( LL, 1 ), LDC )
*
* Test convergence
*
IF( ABS( E( M-1 ) ).LE.THRESH )
$ E( M-1 ) = ZERO
*
ELSE
*
* Chase bulge from bottom to top
* Save cosines and sines for later singular vector updates
*
F = ( ABS( D( M ) )-SHIFT )*( SIGN( ONE, D( M ) )+SHIFT /
$ D( M ) )
G = E( M-1 )
DO 150 I = M, LL + 1, -1
CALL SLARTG( F, G, COSR, SINR, R )
IF( I.LT.M )
$ E( I ) = R
F = COSR*D( I ) + SINR*E( I-1 )
E( I-1 ) = COSR*E( I-1 ) - SINR*D( I )
G = SINR*D( I-1 )
D( I-1 ) = COSR*D( I-1 )
CALL SLARTG( F, G, COSL, SINL, R )
D( I ) = R
F = COSL*E( I-1 ) + SINL*D( I-1 )
D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 )
IF( I.GT.LL+1 ) THEN
G = SINL*E( I-2 )
E( I-2 ) = COSL*E( I-2 )
END IF
WORK( I-LL ) = COSR
WORK( I-LL+NM1 ) = -SINR
WORK( I-LL+NM12 ) = COSL
WORK( I-LL+NM13 ) = -SINL
150 CONTINUE
E( LL ) = F
*
* Test convergence
*
IF( ABS( E( LL ) ).LE.THRESH )
$ E( LL ) = ZERO
*
* Update singular vectors if desired
*
IF( NCVT.GT.0 )
$ CALL SLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ),
$ WORK( NM13+1 ), VT( LL, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL SLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ),
$ WORK( N ), U( 1, LL ), LDU )
IF( NCC.GT.0 )
$ CALL SLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ),
$ WORK( N ), C( LL, 1 ), LDC )
END IF
END IF
*
* QR iteration finished, go back and check convergence
*
GO TO 60
*
* All singular values converged, so make them positive
*
160 CONTINUE
DO 170 I = 1, N
IF( D( I ).LT.ZERO ) THEN
D( I ) = -D( I )
*
* Change sign of singular vectors, if desired
*
IF( NCVT.GT.0 )
$ CALL SSCAL( NCVT, NEGONE, VT( I, 1 ), LDVT )
END IF
170 CONTINUE
*
* Sort the singular values into decreasing order (insertion sort on
* singular values, but only one transposition per singular vector)
*
DO 190 I = 1, N - 1
*
* Scan for smallest D(I)
*
ISUB = 1
SMIN = D( 1 )
DO 180 J = 2, N + 1 - I
IF( D( J ).LE.SMIN ) THEN
ISUB = J
SMIN = D( J )
END IF
180 CONTINUE
IF( ISUB.NE.N+1-I ) THEN
*
* Swap singular values and vectors
*
D( ISUB ) = D( N+1-I )
D( N+1-I ) = SMIN
IF( NCVT.GT.0 )
$ CALL SSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ),
$ LDVT )
IF( NRU.GT.0 )
$ CALL SSWAP( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 )
IF( NCC.GT.0 )
$ CALL SSWAP( NCC, C( ISUB, 1 ), LDC, C( N+1-I, 1 ), LDC )
END IF
190 CONTINUE
GO TO 220
*
* Maximum number of iterations exceeded, failure to converge
*
200 CONTINUE
INFO = 0
DO 210 I = 1, N - 1
IF( E( I ).NE.ZERO )
$ INFO = INFO + 1
210 CONTINUE
220 CONTINUE
RETURN
*
* End of SBDSQR
*
END
SUBROUTINE SDISNA( JOB, M, N, D, SEP, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOB
INTEGER INFO, M, N
* ..
* .. Array Arguments ..
REAL D( * ), SEP( * )
* ..
*
* Purpose
* =======
*
* SDISNA computes the reciprocal condition numbers for the eigenvectors
* of a real symmetric or complex Hermitian matrix or for the left or
* right singular vectors of a general m-by-n matrix. The reciprocal
* condition number is the 'gap' between the corresponding eigenvalue or
* singular value and the nearest other one.
*
* The bound on the error, measured by angle in radians, in the I-th
* computed vector is given by
*
* SLAMCH( 'E' ) * ( ANORM / SEP( I ) )
*
* where ANORM = 2-norm(A) = max( abs( D(j) ) ). SEP(I) is not allowed
* to be smaller than SLAMCH( 'E' )*ANORM in order to limit the size of
* the error bound.
*
* SDISNA may also be used to compute error bounds for eigenvectors of
* the generalized symmetric definite eigenproblem.
*
* Arguments
* =========
*
* JOB (input) CHARACTER*1
* Specifies for which problem the reciprocal condition numbers
* should be computed:
* = 'E': the eigenvectors of a symmetric/Hermitian matrix;
* = 'L': the left singular vectors of a general matrix;
* = 'R': the right singular vectors of a general matrix.
*
* M (input) INTEGER
* The number of rows of the matrix. M >= 0.
*
* N (input) INTEGER
* If JOB = 'L' or 'R', the number of columns of the matrix,
* in which case N >= 0. Ignored if JOB = 'E'.
*
* D (input) REAL array, dimension (M) if JOB = 'E'
* dimension (min(M,N)) if JOB = 'L' or 'R'
* The eigenvalues (if JOB = 'E') or singular values (if JOB =
* 'L' or 'R') of the matrix, in either increasing or decreasing
* order. If singular values, they must be non-negative.
*
* SEP (output) REAL array, dimension (M) if JOB = 'E'
* dimension (min(M,N)) if JOB = 'L' or 'R'
* The reciprocal condition numbers of the vectors.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL DECR, EIGEN, INCR, LEFT, RIGHT, SING
INTEGER I, K
REAL ANORM, EPS, NEWGAP, OLDGAP, SAFMIN, THRESH
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH
EXTERNAL LSAME, SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
EIGEN = LSAME( JOB, 'E' )
LEFT = LSAME( JOB, 'L' )
RIGHT = LSAME( JOB, 'R' )
SING = LEFT .OR. RIGHT
IF( EIGEN ) THEN
K = M
ELSE IF( SING ) THEN
K = MIN( M, N )
END IF
IF( .NOT.EIGEN .AND. .NOT.SING ) THEN
INFO = -1
ELSE IF( M.LT.0 ) THEN
INFO = -2
ELSE IF( K.LT.0 ) THEN
INFO = -3
ELSE
INCR = .TRUE.
DECR = .TRUE.
DO 10 I = 1, K - 1
IF( INCR )
$ INCR = INCR .AND. D( I ).LE.D( I+1 )
IF( DECR )
$ DECR = DECR .AND. D( I ).GE.D( I+1 )
10 CONTINUE
IF( SING .AND. K.GT.0 ) THEN
IF( INCR )
$ INCR = INCR .AND. ZERO.LE.D( 1 )
IF( DECR )
$ DECR = DECR .AND. D( K ).GE.ZERO
END IF
IF( .NOT.( INCR .OR. DECR ) )
$ INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SDISNA', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( K.EQ.0 )
$ RETURN
*
* Compute reciprocal condition numbers
*
IF( K.EQ.1 ) THEN
SEP( 1 ) = SLAMCH( 'O' )
ELSE
OLDGAP = ABS( D( 2 )-D( 1 ) )
SEP( 1 ) = OLDGAP
DO 20 I = 2, K - 1
NEWGAP = ABS( D( I+1 )-D( I ) )
SEP( I ) = MIN( OLDGAP, NEWGAP )
OLDGAP = NEWGAP
20 CONTINUE
SEP( K ) = OLDGAP
END IF
IF( SING ) THEN
IF( ( LEFT .AND. M.GT.N ) .OR. ( RIGHT .AND. M.LT.N ) ) THEN
IF( INCR )
$ SEP( 1 ) = MIN( SEP( 1 ), D( 1 ) )
IF( DECR )
$ SEP( K ) = MIN( SEP( K ), D( K ) )
END IF
END IF
*
* Ensure that reciprocal condition numbers are not less than
* threshold, in order to limit the size of the error bound
*
EPS = SLAMCH( 'E' )
SAFMIN = SLAMCH( 'S' )
ANORM = MAX( ABS( D( 1 ) ), ABS( D( K ) ) )
IF( ANORM.EQ.ZERO ) THEN
THRESH = EPS
ELSE
THRESH = MAX( EPS*ANORM, SAFMIN )
END IF
DO 30 I = 1, K
SEP( I ) = MAX( SEP( I ), THRESH )
30 CONTINUE
*
RETURN
*
* End of SDISNA
*
END
SUBROUTINE SGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q,
$ LDQ, PT, LDPT, C, LDC, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER VECT
INTEGER INFO, KL, KU, LDAB, LDC, LDPT, LDQ, M, N, NCC
* ..
* .. Array Arguments ..
REAL AB( LDAB, * ), C( LDC, * ), D( * ), E( * ),
$ PT( LDPT, * ), Q( LDQ, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGBBRD reduces a real general m-by-n band matrix A to upper
* bidiagonal form B by an orthogonal transformation: Q' * A * P = B.
*
* The routine computes B, and optionally forms Q or P', or computes
* Q'*C for a given matrix C.
*
* Arguments
* =========
*
* VECT (input) CHARACTER*1
* Specifies whether or not the matrices Q and P' are to be
* formed.
* = 'N': do not form Q or P';
* = 'Q': form Q only;
* = 'P': form P' only;
* = 'B': form both.
*
* 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.
*
* NCC (input) INTEGER
* The number of columns of the matrix C. NCC >= 0.
*
* KL (input) INTEGER
* The number of subdiagonals of the matrix A. KL >= 0.
*
* KU (input) INTEGER
* The number of superdiagonals of the matrix A. KU >= 0.
*
* AB (input/output) REAL array, dimension (LDAB,N)
* On entry, the m-by-n band matrix A, stored in rows 1 to
* KL+KU+1. The j-th column of A is stored in the j-th column of
* the array AB as follows:
* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
* On exit, A is overwritten by values generated during the
* reduction.
*
* LDAB (input) INTEGER
* The leading dimension of the array A. LDAB >= KL+KU+1.
*
* D (output) REAL array, dimension (min(M,N))
* The diagonal elements of the bidiagonal matrix B.
*
* E (output) REAL array, dimension (min(M,N)-1)
* The superdiagonal elements of the bidiagonal matrix B.
*
* Q (output) REAL array, dimension (LDQ,M)
* If VECT = 'Q' or 'B', the m-by-m orthogonal matrix Q.
* If VECT = 'N' or 'P', the array Q is not referenced.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q.
* LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.
*
* PT (output) REAL array, dimension (LDPT,N)
* If VECT = 'P' or 'B', the n-by-n orthogonal matrix P'.
* If VECT = 'N' or 'Q', the array PT is not referenced.
*
* LDPT (input) INTEGER
* The leading dimension of the array PT.
* LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.
*
* C (input/output) REAL array, dimension (LDC,NCC)
* On entry, an m-by-ncc matrix C.
* On exit, C is overwritten by Q'*C.
* C is not referenced if NCC = 0.
*
* LDC (input) INTEGER
* The leading dimension of the array C.
* LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.
*
* WORK (workspace) REAL array, dimension (2*max(M,N))
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL WANTB, WANTC, WANTPT, WANTQ
INTEGER I, INCA, J, J1, J2, KB, KB1, KK, KLM, KLU1,
$ KUN, L, MINMN, ML, ML0, MN, MU, MU0, NR, NRT
REAL RA, RB, RC, RS
* ..
* .. External Subroutines ..
EXTERNAL SLARGV, SLARTG, SLARTV, SLASET, SROT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
WANTB = LSAME( VECT, 'B' )
WANTQ = LSAME( VECT, 'Q' ) .OR. WANTB
WANTPT = LSAME( VECT, 'P' ) .OR. WANTB
WANTC = NCC.GT.0
KLU1 = KL + KU + 1
INFO = 0
IF( .NOT.WANTQ .AND. .NOT.WANTPT .AND. .NOT.LSAME( VECT, 'N' ) )
$ THEN
INFO = -1
ELSE IF( M.LT.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NCC.LT.0 ) THEN
INFO = -4
ELSE IF( KL.LT.0 ) THEN
INFO = -5
ELSE IF( KU.LT.0 ) THEN
INFO = -6
ELSE IF( LDAB.LT.KLU1 ) THEN
INFO = -8
ELSE IF( LDQ.LT.1 .OR. WANTQ .AND. LDQ.LT.MAX( 1, M ) ) THEN
INFO = -12
ELSE IF( LDPT.LT.1 .OR. WANTPT .AND. LDPT.LT.MAX( 1, N ) ) THEN
INFO = -14
ELSE IF( LDC.LT.1 .OR. WANTC .AND. LDC.LT.MAX( 1, M ) ) THEN
INFO = -16
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGBBRD', -INFO )
RETURN
END IF
*
* Initialize Q and P' to the unit matrix, if needed
*
IF( WANTQ )
$ CALL SLASET( 'Full', M, M, ZERO, ONE, Q, LDQ )
IF( WANTPT )
$ CALL SLASET( 'Full', N, N, ZERO, ONE, PT, LDPT )
*
* Quick return if possible.
*
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
MINMN = MIN( M, N )
*
IF( KL+KU.GT.1 ) THEN
*
* Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce
* first to lower bidiagonal form and then transform to upper
* bidiagonal
*
IF( KU.GT.0 ) THEN
ML0 = 1
MU0 = 2
ELSE
ML0 = 2
MU0 = 1
END IF
*
* Wherever possible, plane rotations are generated and applied in
* vector operations of length NR over the index set J1:J2:KLU1.
*
* The sines of the plane rotations are stored in WORK(1:max(m,n))
* and the cosines in WORK(max(m,n)+1:2*max(m,n)).
*
MN = MAX( M, N )
KLM = MIN( M-1, KL )
KUN = MIN( N-1, KU )
KB = KLM + KUN
KB1 = KB + 1
INCA = KB1*LDAB
NR = 0
J1 = KLM + 2
J2 = 1 - KUN
*
DO 90 I = 1, MINMN
*
* Reduce i-th column and i-th row of matrix to bidiagonal form
*
ML = KLM + 1
MU = KUN + 1
DO 80 KK = 1, KB
J1 = J1 + KB
J2 = J2 + KB
*
* generate plane rotations to annihilate nonzero elements
* which have been created below the band
*
IF( NR.GT.0 )
$ CALL SLARGV( NR, AB( KLU1, J1-KLM-1 ), INCA,
$ WORK( J1 ), KB1, WORK( MN+J1 ), KB1 )
*
* apply plane rotations from the left
*
DO 10 L = 1, KB
IF( J2-KLM+L-1.GT.N ) THEN
NRT = NR - 1
ELSE
NRT = NR
END IF
IF( NRT.GT.0 )
$ CALL SLARTV( NRT, AB( KLU1-L, J1-KLM+L-1 ), INCA,
$ AB( KLU1-L+1, J1-KLM+L-1 ), INCA,
$ WORK( MN+J1 ), WORK( J1 ), KB1 )
10 CONTINUE
*
IF( ML.GT.ML0 ) THEN
IF( ML.LE.M-I+1 ) THEN
*
* generate plane rotation to annihilate a(i+ml-1,i)
* within the band, and apply rotation from the left
*
CALL SLARTG( AB( KU+ML-1, I ), AB( KU+ML, I ),
$ WORK( MN+I+ML-1 ), WORK( I+ML-1 ),
$ RA )
AB( KU+ML-1, I ) = RA
IF( I.LT.N )
$ CALL SROT( MIN( KU+ML-2, N-I ),
$ AB( KU+ML-2, I+1 ), LDAB-1,
$ AB( KU+ML-1, I+1 ), LDAB-1,
$ WORK( MN+I+ML-1 ), WORK( I+ML-1 ) )
END IF
NR = NR + 1
J1 = J1 - KB1
END IF
*
IF( WANTQ ) THEN
*
* accumulate product of plane rotations in Q
*
DO 20 J = J1, J2, KB1
CALL SROT( M, Q( 1, J-1 ), 1, Q( 1, J ), 1,
$ WORK( MN+J ), WORK( J ) )
20 CONTINUE
END IF
*
IF( WANTC ) THEN
*
* apply plane rotations to C
*
DO 30 J = J1, J2, KB1
CALL SROT( NCC, C( J-1, 1 ), LDC, C( J, 1 ), LDC,
$ WORK( MN+J ), WORK( J ) )
30 CONTINUE
END IF
*
IF( J2+KUN.GT.N ) THEN
*
* adjust J2 to keep within the bounds of the matrix
*
NR = NR - 1
J2 = J2 - KB1
END IF
*
DO 40 J = J1, J2, KB1
*
* create nonzero element a(j-1,j+ku) above the band
* and store it in WORK(n+1:2*n)
*
WORK( J+KUN ) = WORK( J )*AB( 1, J+KUN )
AB( 1, J+KUN ) = WORK( MN+J )*AB( 1, J+KUN )
40 CONTINUE
*
* generate plane rotations to annihilate nonzero elements
* which have been generated above the band
*
IF( NR.GT.0 )
$ CALL SLARGV( NR, AB( 1, J1+KUN-1 ), INCA,
$ WORK( J1+KUN ), KB1, WORK( MN+J1+KUN ),
$ KB1 )
*
* apply plane rotations from the right
*
DO 50 L = 1, KB
IF( J2+L-1.GT.M ) THEN
NRT = NR - 1
ELSE
NRT = NR
END IF
IF( NRT.GT.0 )
$ CALL SLARTV( NRT, AB( L+1, J1+KUN-1 ), INCA,
$ AB( L, J1+KUN ), INCA,
$ WORK( MN+J1+KUN ), WORK( J1+KUN ),
$ KB1 )
50 CONTINUE
*
IF( ML.EQ.ML0 .AND. MU.GT.MU0 ) THEN
IF( MU.LE.N-I+1 ) THEN
*
* generate plane rotation to annihilate a(i,i+mu-1)
* within the band, and apply rotation from the right
*
CALL SLARTG( AB( KU-MU+3, I+MU-2 ),
$ AB( KU-MU+2, I+MU-1 ),
$ WORK( MN+I+MU-1 ), WORK( I+MU-1 ),
$ RA )
AB( KU-MU+3, I+MU-2 ) = RA
CALL SROT( MIN( KL+MU-2, M-I ),
$ AB( KU-MU+4, I+MU-2 ), 1,
$ AB( KU-MU+3, I+MU-1 ), 1,
$ WORK( MN+I+MU-1 ), WORK( I+MU-1 ) )
END IF
NR = NR + 1
J1 = J1 - KB1
END IF
*
IF( WANTPT ) THEN
*
* accumulate product of plane rotations in P'
*
DO 60 J = J1, J2, KB1
CALL SROT( N, PT( J+KUN-1, 1 ), LDPT,
$ PT( J+KUN, 1 ), LDPT, WORK( MN+J+KUN ),
$ WORK( J+KUN ) )
60 CONTINUE
END IF
*
IF( J2+KB.GT.M ) THEN
*
* adjust J2 to keep within the bounds of the matrix
*
NR = NR - 1
J2 = J2 - KB1
END IF
*
DO 70 J = J1, J2, KB1
*
* create nonzero element a(j+kl+ku,j+ku-1) below the
* band and store it in WORK(1:n)
*
WORK( J+KB ) = WORK( J+KUN )*AB( KLU1, J+KUN )
AB( KLU1, J+KUN ) = WORK( MN+J+KUN )*AB( KLU1, J+KUN )
70 CONTINUE
*
IF( ML.GT.ML0 ) THEN
ML = ML - 1
ELSE
MU = MU - 1
END IF
80 CONTINUE
90 CONTINUE
END IF
*
IF( KU.EQ.0 .AND. KL.GT.0 ) THEN
*
* A has been reduced to lower bidiagonal form
*
* Transform lower bidiagonal form to upper bidiagonal by applying
* plane rotations from the left, storing diagonal elements in D
* and off-diagonal elements in E
*
DO 100 I = 1, MIN( M-1, N )
CALL SLARTG( AB( 1, I ), AB( 2, I ), RC, RS, RA )
D( I ) = RA
IF( I.LT.N ) THEN
E( I ) = RS*AB( 1, I+1 )
AB( 1, I+1 ) = RC*AB( 1, I+1 )
END IF
IF( WANTQ )
$ CALL SROT( M, Q( 1, I ), 1, Q( 1, I+1 ), 1, RC, RS )
IF( WANTC )
$ CALL SROT( NCC, C( I, 1 ), LDC, C( I+1, 1 ), LDC, RC,
$ RS )
100 CONTINUE
IF( M.LE.N )
$ D( M ) = AB( 1, M )
ELSE IF( KU.GT.0 ) THEN
*
* A has been reduced to upper bidiagonal form
*
IF( M.LT.N ) THEN
*
* Annihilate a(m,m+1) by applying plane rotations from the
* right, storing diagonal elements in D and off-diagonal
* elements in E
*
RB = AB( KU, M+1 )
DO 110 I = M, 1, -1
CALL SLARTG( AB( KU+1, I ), RB, RC, RS, RA )
D( I ) = RA
IF( I.GT.1 ) THEN
RB = -RS*AB( KU, I )
E( I-1 ) = RC*AB( KU, I )
END IF
IF( WANTPT )
$ CALL SROT( N, PT( I, 1 ), LDPT, PT( M+1, 1 ), LDPT,
$ RC, RS )
110 CONTINUE
ELSE
*
* Copy off-diagonal elements to E and diagonal elements to D
*
DO 120 I = 1, MINMN - 1
E( I ) = AB( KU, I+1 )
120 CONTINUE
DO 130 I = 1, MINMN
D( I ) = AB( KU+1, I )
130 CONTINUE
END IF
ELSE
*
* A is diagonal. Set elements of E to zero and copy diagonal
* elements to D.
*
DO 140 I = 1, MINMN - 1
E( I ) = ZERO
140 CONTINUE
DO 150 I = 1, MINMN
D( I ) = AB( 1, I )
150 CONTINUE
END IF
RETURN
*
* End of SGBBRD
*
END
SUBROUTINE SGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND,
$ WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER INFO, KL, KU, LDAB, N
REAL ANORM, RCOND
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), IWORK( * )
REAL AB( LDAB, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGBCON estimates the reciprocal of the condition number of a real
* general band matrix A, in either the 1-norm or the infinity-norm,
* using the LU factorization computed by SGBTRF.
*
* An estimate is obtained for norm(inv(A)), and the reciprocal of the
* condition number is computed as
* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies whether the 1-norm condition number or the
* infinity-norm condition number is required:
* = '1' or 'O': 1-norm;
* = 'I': Infinity-norm.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KL (input) INTEGER
* The number of subdiagonals within the band of A. KL >= 0.
*
* KU (input) INTEGER
* The number of superdiagonals within the band of A. KU >= 0.
*
* AB (input) REAL array, dimension (LDAB,N)
* Details of the LU factorization of the band matrix A, as
* computed by SGBTRF. U is stored as an upper triangular band
* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
* the multipliers used during the factorization are stored in
* rows KL+KU+2 to 2*KL+KU+1.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices; for 1 <= i <= N, row i of the matrix was
* interchanged with row IPIV(i).
*
* ANORM (input) REAL
* If NORM = '1' or 'O', the 1-norm of the original matrix A.
* If NORM = 'I', the infinity-norm of the original matrix A.
*
* RCOND (output) REAL
* The reciprocal of the condition number of the matrix A,
* computed as RCOND = 1/(norm(A) * norm(inv(A))).
*
* WORK (workspace) REAL array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LNOTI, ONENRM
CHARACTER NORMIN
INTEGER IX, J, JP, KASE, KASE1, KD, LM
REAL AINVNM, SCALE, SMLNUM, T
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SDOT, SLAMCH
EXTERNAL LSAME, ISAMAX, SDOT, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SLACN2, SLATBS, SRSCL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( KL.LT.0 ) THEN
INFO = -3
ELSE IF( KU.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN
INFO = -6
ELSE IF( ANORM.LT.ZERO ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGBCON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
RCOND = ZERO
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
ELSE IF( ANORM.EQ.ZERO ) THEN
RETURN
END IF
*
SMLNUM = SLAMCH( 'Safe minimum' )
*
* Estimate the norm of inv(A).
*
AINVNM = ZERO
NORMIN = 'N'
IF( ONENRM ) THEN
KASE1 = 1
ELSE
KASE1 = 2
END IF
KD = KL + KU + 1
LNOTI = KL.GT.0
KASE = 0
10 CONTINUE
CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.KASE1 ) THEN
*
* Multiply by inv(L).
*
IF( LNOTI ) THEN
DO 20 J = 1, N - 1
LM = MIN( KL, N-J )
JP = IPIV( J )
T = WORK( JP )
IF( JP.NE.J ) THEN
WORK( JP ) = WORK( J )
WORK( J ) = T
END IF
CALL SAXPY( LM, -T, AB( KD+1, J ), 1, WORK( J+1 ), 1 )
20 CONTINUE
END IF
*
* Multiply by inv(U).
*
CALL SLATBS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
$ KL+KU, AB, LDAB, WORK, SCALE, WORK( 2*N+1 ),
$ INFO )
ELSE
*
* Multiply by inv(U').
*
CALL SLATBS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N,
$ KL+KU, AB, LDAB, WORK, SCALE, WORK( 2*N+1 ),
$ INFO )
*
* Multiply by inv(L').
*
IF( LNOTI ) THEN
DO 30 J = N - 1, 1, -1
LM = MIN( KL, N-J )
WORK( J ) = WORK( J ) - SDOT( LM, AB( KD+1, J ), 1,
$ WORK( J+1 ), 1 )
JP = IPIV( J )
IF( JP.NE.J ) THEN
T = WORK( JP )
WORK( JP ) = WORK( J )
WORK( J ) = T
END IF
30 CONTINUE
END IF
END IF
*
* Divide X by 1/SCALE if doing so will not cause overflow.
*
NORMIN = 'Y'
IF( SCALE.NE.ONE ) THEN
IX = ISAMAX( N, WORK, 1 )
IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
$ GO TO 40
CALL SRSCL( N, SCALE, WORK, 1 )
END IF
GO TO 10
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / AINVNM ) / ANORM
*
40 CONTINUE
RETURN
*
* End of SGBCON
*
END
SUBROUTINE SGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND,
$ AMAX, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, KL, KU, LDAB, M, N
REAL AMAX, COLCND, ROWCND
* ..
* .. Array Arguments ..
REAL AB( LDAB, * ), C( * ), R( * )
* ..
*
* Purpose
* =======
*
* SGBEQU computes row and column scalings intended to equilibrate an
* M-by-N band matrix A and reduce its condition number. R returns the
* row scale factors and C the column scale factors, chosen to try to
* make the largest element in each row and column of the matrix B with
* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
*
* R(i) and C(j) are restricted to be between SMLNUM = smallest safe
* number and BIGNUM = largest safe number. Use of these scaling
* factors is not guaranteed to reduce the condition number of A but
* works well in practice.
*
* 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.
*
* KL (input) INTEGER
* The number of subdiagonals within the band of A. KL >= 0.
*
* KU (input) INTEGER
* The number of superdiagonals within the band of A. KU >= 0.
*
* AB (input) REAL array, dimension (LDAB,N)
* The band matrix A, stored in rows 1 to KL+KU+1. The j-th
* column of A is stored in the j-th column of the array AB as
* follows:
* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KL+KU+1.
*
* R (output) REAL array, dimension (M)
* If INFO = 0, or INFO > M, R contains the row scale factors
* for A.
*
* C (output) REAL array, dimension (N)
* If INFO = 0, C contains the column scale factors for A.
*
* ROWCND (output) REAL
* If INFO = 0 or INFO > M, ROWCND contains the ratio of the
* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and
* AMAX is neither too large nor too small, it is not worth
* scaling by R.
*
* COLCND (output) REAL
* If INFO = 0, COLCND contains the ratio of the smallest
* C(i) to the largest C(i). If COLCND >= 0.1, it is not
* worth scaling by C.
*
* AMAX (output) REAL
* Absolute value of largest matrix element. If AMAX is very
* close to overflow or very close to underflow, the matrix
* should be scaled.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, and i is
* <= M: the i-th row of A is exactly zero
* > M: the (i-M)-th column of A is exactly zero
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, KD
REAL BIGNUM, RCMAX, RCMIN, SMLNUM
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, 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( KL.LT.0 ) THEN
INFO = -3
ELSE IF( KU.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.KL+KU+1 ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGBEQU', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
ROWCND = ONE
COLCND = ONE
AMAX = ZERO
RETURN
END IF
*
* Get machine constants.
*
SMLNUM = SLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
*
* Compute row scale factors.
*
DO 10 I = 1, M
R( I ) = ZERO
10 CONTINUE
*
* Find the maximum element in each row.
*
KD = KU + 1
DO 30 J = 1, N
DO 20 I = MAX( J-KU, 1 ), MIN( J+KL, M )
R( I ) = MAX( R( I ), ABS( AB( KD+I-J, J ) ) )
20 CONTINUE
30 CONTINUE
*
* Find the maximum and minimum scale factors.
*
RCMIN = BIGNUM
RCMAX = ZERO
DO 40 I = 1, M
RCMAX = MAX( RCMAX, R( I ) )
RCMIN = MIN( RCMIN, R( I ) )
40 CONTINUE
AMAX = RCMAX
*
IF( RCMIN.EQ.ZERO ) THEN
*
* Find the first zero scale factor and return an error code.
*
DO 50 I = 1, M
IF( R( I ).EQ.ZERO ) THEN
INFO = I
RETURN
END IF
50 CONTINUE
ELSE
*
* Invert the scale factors.
*
DO 60 I = 1, M
R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM )
60 CONTINUE
*
* Compute ROWCND = min(R(I)) / max(R(I))
*
ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
END IF
*
* Compute column scale factors
*
DO 70 J = 1, N
C( J ) = ZERO
70 CONTINUE
*
* Find the maximum element in each column,
* assuming the row scaling computed above.
*
KD = KU + 1
DO 90 J = 1, N
DO 80 I = MAX( J-KU, 1 ), MIN( J+KL, M )
C( J ) = MAX( C( J ), ABS( AB( KD+I-J, J ) )*R( I ) )
80 CONTINUE
90 CONTINUE
*
* Find the maximum and minimum scale factors.
*
RCMIN = BIGNUM
RCMAX = ZERO
DO 100 J = 1, N
RCMIN = MIN( RCMIN, C( J ) )
RCMAX = MAX( RCMAX, C( J ) )
100 CONTINUE
*
IF( RCMIN.EQ.ZERO ) THEN
*
* Find the first zero scale factor and return an error code.
*
DO 110 J = 1, N
IF( C( J ).EQ.ZERO ) THEN
INFO = M + J
RETURN
END IF
110 CONTINUE
ELSE
*
* Invert the scale factors.
*
DO 120 J = 1, N
C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM )
120 CONTINUE
*
* Compute COLCND = min(C(J)) / max(C(J))
*
COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
END IF
*
RETURN
*
* End of SGBEQU
*
END
SUBROUTINE SGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB,
$ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), IWORK( * )
REAL AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
$ BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* SGBRFS improves the computed solution to a system of linear
* equations when the coefficient matrix is banded, and provides
* error bounds and backward error estimates for the solution.
*
* 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**H * X = B (Conjugate transpose = Transpose)
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KL (input) INTEGER
* The number of subdiagonals within the band of A. KL >= 0.
*
* KU (input) INTEGER
* The number of superdiagonals within the band of A. KU >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrices B and X. NRHS >= 0.
*
* AB (input) REAL array, dimension (LDAB,N)
* The original band matrix A, stored in rows 1 to KL+KU+1.
* The j-th column of A is stored in the j-th column of the
* array AB as follows:
* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KL+KU+1.
*
* AFB (input) REAL array, dimension (LDAFB,N)
* Details of the LU factorization of the band matrix A, as
* computed by SGBTRF. U is stored as an upper triangular band
* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
* the multipliers used during the factorization are stored in
* rows KL+KU+2 to 2*KL+KU+1.
*
* LDAFB (input) INTEGER
* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices from SGBTRF; for 1<=i<=N, row i of the
* matrix was interchanged with row IPIV(i).
*
* B (input) REAL array, dimension (LDB,NRHS)
* The right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input/output) REAL array, dimension (LDX,NRHS)
* On entry, the solution matrix X, as computed by SGBTRS.
* On exit, the improved solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* FERR (output) REAL array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) REAL array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Internal Parameters
* ===================
*
* ITMAX is the maximum number of steps of iterative refinement.
*
* =====================================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 5 )
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
REAL TWO
PARAMETER ( TWO = 2.0E+0 )
REAL THREE
PARAMETER ( THREE = 3.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN
CHARACTER TRANST
INTEGER COUNT, I, J, K, KASE, KK, NZ
REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, SGBMV, SGBTRS, SLACN2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH
EXTERNAL LSAME, SLAMCH
* ..
* .. 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( KL.LT.0 ) THEN
INFO = -3
ELSE IF( KU.LT.0 ) THEN
INFO = -4
ELSE IF( NRHS.LT.0 ) THEN
INFO = -5
ELSE IF( LDAB.LT.KL+KU+1 ) THEN
INFO = -7
ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN
INFO = -9
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -12
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -14
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGBRFS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
DO 10 J = 1, NRHS
FERR( J ) = ZERO
BERR( J ) = ZERO
10 CONTINUE
RETURN
END IF
*
IF( NOTRAN ) THEN
TRANST = 'T'
ELSE
TRANST = 'N'
END IF
*
* NZ = maximum number of nonzero elements in each row of A, plus 1
*
NZ = MIN( KL+KU+2, N+1 )
EPS = SLAMCH( 'Epsilon' )
SAFMIN = SLAMCH( 'Safe minimum' )
SAFE1 = NZ*SAFMIN
SAFE2 = SAFE1 / EPS
*
* Do for each right hand side
*
DO 140 J = 1, NRHS
*
COUNT = 1
LSTRES = THREE
20 CONTINUE
*
* Loop until stopping criterion is satisfied.
*
* Compute residual R = B - op(A) * X,
* where op(A) = A, A**T, or A**H, depending on TRANS.
*
CALL SCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
CALL SGBMV( TRANS, N, N, KL, KU, -ONE, AB, LDAB, X( 1, J ), 1,
$ ONE, WORK( N+1 ), 1 )
*
* Compute componentwise relative backward error from formula
*
* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
*
* where abs(Z) is the componentwise absolute value of the matrix
* or vector Z. If the i-th component of the denominator is less
* than SAFE2, then SAFE1 is added to the i-th components of the
* numerator and denominator before dividing.
*
DO 30 I = 1, N
WORK( I ) = ABS( B( I, J ) )
30 CONTINUE
*
* Compute abs(op(A))*abs(X) + abs(B).
*
IF( NOTRAN ) THEN
DO 50 K = 1, N
KK = KU + 1 - K
XK = ABS( X( K, J ) )
DO 40 I = MAX( 1, K-KU ), MIN( N, K+KL )
WORK( I ) = WORK( I ) + ABS( AB( KK+I, K ) )*XK
40 CONTINUE
50 CONTINUE
ELSE
DO 70 K = 1, N
S = ZERO
KK = KU + 1 - K
DO 60 I = MAX( 1, K-KU ), MIN( N, K+KL )
S = S + ABS( AB( KK+I, K ) )*ABS( X( I, J ) )
60 CONTINUE
WORK( K ) = WORK( K ) + S
70 CONTINUE
END IF
S = ZERO
DO 80 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
ELSE
S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
$ ( WORK( I )+SAFE1 ) )
END IF
80 CONTINUE
BERR( J ) = S
*
* Test stopping criterion. Continue iterating if
* 1) The residual BERR(J) is larger than machine epsilon, and
* 2) BERR(J) decreased by at least a factor of 2 during the
* last iteration, and
* 3) At most ITMAX iterations tried.
*
IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
$ COUNT.LE.ITMAX ) THEN
*
* Update solution and try again.
*
CALL SGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, IPIV,
$ WORK( N+1 ), N, INFO )
CALL SAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
LSTRES = BERR( J )
COUNT = COUNT + 1
GO TO 20
END IF
*
* Bound error from formula
*
* norm(X - XTRUE) / norm(X) .le. FERR =
* norm( abs(inv(op(A)))*
* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
*
* where
* norm(Z) is the magnitude of the largest component of Z
* inv(op(A)) is the inverse of op(A)
* abs(Z) is the componentwise absolute value of the matrix or
* vector Z
* NZ is the maximum number of nonzeros in any row of A, plus 1
* EPS is machine epsilon
*
* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
* is incremented by SAFE1 if the i-th component of
* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
*
* Use SLACN2 to estimate the infinity-norm of the matrix
* inv(op(A)) * diag(W),
* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
*
DO 90 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
ELSE
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
END IF
90 CONTINUE
*
KASE = 0
100 CONTINUE
CALL SLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
$ KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Multiply by diag(W)*inv(op(A)**T).
*
CALL SGBTRS( TRANST, N, KL, KU, 1, AFB, LDAFB, IPIV,
$ WORK( N+1 ), N, INFO )
DO 110 I = 1, N
WORK( N+I ) = WORK( N+I )*WORK( I )
110 CONTINUE
ELSE
*
* Multiply by inv(op(A))*diag(W).
*
DO 120 I = 1, N
WORK( N+I ) = WORK( N+I )*WORK( I )
120 CONTINUE
CALL SGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, IPIV,
$ WORK( N+1 ), N, INFO )
END IF
GO TO 100
END IF
*
* Normalize error.
*
LSTRES = ZERO
DO 130 I = 1, N
LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
130 CONTINUE
IF( LSTRES.NE.ZERO )
$ FERR( J ) = FERR( J ) / LSTRES
*
140 CONTINUE
*
RETURN
*
* End of SGBRFS
*
END
SUBROUTINE SGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
REAL AB( LDAB, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* SGBSV computes the solution to a real system of linear equations
* A * X = B, where A is a band matrix of order N with KL subdiagonals
* and KU superdiagonals, and X and B are N-by-NRHS matrices.
*
* The LU decomposition with partial pivoting and row interchanges is
* used to factor A as A = L * U, where L is a product of permutation
* and unit lower triangular matrices with KL subdiagonals, and U is
* upper triangular with KL+KU superdiagonals. The factored form of A
* is then used to solve the system of equations A * X = B.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of linear equations, i.e., the order of the
* matrix A. N >= 0.
*
* KL (input) INTEGER
* The number of subdiagonals within the band of A. KL >= 0.
*
* KU (input) INTEGER
* The number of superdiagonals within the band of A. KU >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrix B. NRHS >= 0.
*
* AB (input/output) REAL array, dimension (LDAB,N)
* On entry, the matrix A in band storage, in rows KL+1 to
* 2*KL+KU+1; rows 1 to KL of the array need not be set.
* The j-th column of A is stored in the j-th column of the
* array AB as follows:
* AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)
* On exit, details of the factorization: U is stored as an
* upper triangular band matrix with KL+KU superdiagonals in
* rows 1 to KL+KU+1, and the multipliers used during the
* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
* See below for further details.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
*
* IPIV (output) INTEGER array, dimension (N)
* The pivot indices that define the permutation matrix P;
* row i of the matrix was interchanged with row IPIV(i).
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the N-by-NRHS right hand side matrix B.
* On exit, if INFO = 0, the N-by-NRHS 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
* > 0: if INFO = i, U(i,i) is exactly zero. The factorization
* has been completed, but the factor U is exactly
* singular, and the solution has not been computed.
*
* Further Details
* ===============
*
* The band storage scheme is illustrated by the following example, when
* M = N = 6, KL = 2, KU = 1:
*
* On entry: On exit:
*
* * * * + + + * * * u14 u25 u36
* * * + + + + * * u13 u24 u35 u46
* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
* a31 a42 a53 a64 * * m31 m42 m53 m64 * *
*
* Array elements marked * are not used by the routine; elements marked
* + need not be set on entry, but are required by the routine to store
* elements of U because of fill-in resulting from the row interchanges.
*
* =====================================================================
*
* .. External Subroutines ..
EXTERNAL SGBTRF, SGBTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( KL.LT.0 ) THEN
INFO = -2
ELSE IF( KU.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN
INFO = -6
ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGBSV ', -INFO )
RETURN
END IF
*
* Compute the LU factorization of the band matrix A.
*
CALL SGBTRF( N, N, KL, KU, AB, LDAB, IPIV, INFO )
IF( INFO.EQ.0 ) THEN
*
* Solve the system A*X = B, overwriting B with X.
*
CALL SGBTRS( 'No transpose', N, KL, KU, NRHS, AB, LDAB, IPIV,
$ B, LDB, INFO )
END IF
RETURN
*
* End of SGBSV
*
END
SUBROUTINE SGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB,
$ LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX,
$ RCOND, FERR, BERR, WORK, IWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER EQUED, FACT, TRANS
INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS
REAL RCOND
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), IWORK( * )
REAL AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
$ BERR( * ), C( * ), FERR( * ), R( * ),
$ WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* SGBSVX uses the LU factorization to compute the solution to a real
* system of linear equations A * X = B, A**T * X = B, or A**H * X = B,
* where A is a band matrix of order N with KL subdiagonals and KU
* superdiagonals, and X and B are N-by-NRHS matrices.
*
* Error bounds on the solution and a condition estimate are also
* provided.
*
* Description
* ===========
*
* The following steps are performed by this subroutine:
*
* 1. If FACT = 'E', real scaling factors are computed to equilibrate
* the system:
* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B
* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
* Whether or not the system will be equilibrated depends on the
* scaling of the matrix A, but if equilibration is used, A is
* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
* or diag(C)*B (if TRANS = 'T' or 'C').
*
* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the
* matrix A (after equilibration if FACT = 'E') as
* A = L * U,
* where L is a product of permutation and unit lower triangular
* matrices with KL subdiagonals, and U is upper triangular with
* KL+KU superdiagonals.
*
* 3. If some U(i,i)=0, so that U is exactly singular, then the routine
* returns with INFO = i. Otherwise, the factored form of A is used
* to estimate the condition number of the matrix A. If the
* reciprocal of the condition number is less than machine precision,
* INFO = N+1 is returned as a warning, but the routine still goes on
* to solve for X and compute error bounds as described below.
*
* 4. The system of equations is solved for X using the factored form
* of A.
*
* 5. Iterative refinement is applied to improve the computed solution
* matrix and calculate error bounds and backward error estimates
* for it.
*
* 6. If equilibration was used, the matrix X is premultiplied by
* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
* that it solves the original system before equilibration.
*
* Arguments
* =========
*
* FACT (input) CHARACTER*1
* Specifies whether or not the factored form of the matrix A is
* supplied on entry, and if not, whether the matrix A should be
* equilibrated before it is factored.
* = 'F': On entry, AFB and IPIV contain the factored form of
* A. If EQUED is not 'N', the matrix A has been
* equilibrated with scaling factors given by R and C.
* AB, AFB, and IPIV are not modified.
* = 'N': The matrix A will be copied to AFB and factored.
* = 'E': The matrix A will be equilibrated if necessary, then
* copied to AFB and factored.
*
* 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**H * X = B (Transpose)
*
* N (input) INTEGER
* The number of linear equations, i.e., the order of the
* matrix A. N >= 0.
*
* KL (input) INTEGER
* The number of subdiagonals within the band of A. KL >= 0.
*
* KU (input) INTEGER
* The number of superdiagonals within the band of A. KU >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrices B and X. NRHS >= 0.
*
* AB (input/output) REAL array, dimension (LDAB,N)
* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
* The j-th column of A is stored in the j-th column of the
* array AB as follows:
* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)
*
* If FACT = 'F' and EQUED is not 'N', then A must have been
* equilibrated by the scaling factors in R and/or C. AB is not
* modified if FACT = 'F' or 'N', or if FACT = 'E' and
* EQUED = 'N' on exit.
*
* On exit, if EQUED .ne. 'N', A is scaled as follows:
* EQUED = 'R': A := diag(R) * A
* EQUED = 'C': A := A * diag(C)
* EQUED = 'B': A := diag(R) * A * diag(C).
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KL+KU+1.
*
* AFB (input or output) REAL array, dimension (LDAFB,N)
* If FACT = 'F', then AFB is an input argument and on entry
* contains details of the LU factorization of the band matrix
* A, as computed by SGBTRF. U is stored as an upper triangular
* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,
* and the multipliers used during the factorization are stored
* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is
* the factored form of the equilibrated matrix A.
*
* If FACT = 'N', then AFB is an output argument and on exit
* returns details of the LU factorization of A.
*
* If FACT = 'E', then AFB is an output argument and on exit
* returns details of the LU factorization of the equilibrated
* matrix A (see the description of AB for the form of the
* equilibrated matrix).
*
* LDAFB (input) INTEGER
* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.
*
* IPIV (input or output) INTEGER array, dimension (N)
* If FACT = 'F', then IPIV is an input argument and on entry
* contains the pivot indices from the factorization A = L*U
* as computed by SGBTRF; row i of the matrix was interchanged
* with row IPIV(i).
*
* If FACT = 'N', then IPIV is an output argument and on exit
* contains the pivot indices from the factorization A = L*U
* of the original matrix A.
*
* If FACT = 'E', then IPIV is an output argument and on exit
* contains the pivot indices from the factorization A = L*U
* of the equilibrated matrix A.
*
* EQUED (input or output) CHARACTER*1
* Specifies the form of equilibration that was done.
* = 'N': No equilibration (always true if FACT = 'N').
* = 'R': Row equilibration, i.e., A has been premultiplied by
* diag(R).
* = 'C': Column equilibration, i.e., A has been postmultiplied
* by diag(C).
* = 'B': Both row and column equilibration, i.e., A has been
* replaced by diag(R) * A * diag(C).
* EQUED is an input argument if FACT = 'F'; otherwise, it is an
* output argument.
*
* R (input or output) REAL array, dimension (N)
* The row scale factors for A. If EQUED = 'R' or 'B', A is
* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
* is not accessed. R is an input argument if FACT = 'F';
* otherwise, R is an output argument. If FACT = 'F' and
* EQUED = 'R' or 'B', each element of R must be positive.
*
* C (input or output) REAL array, dimension (N)
* The column scale factors for A. If EQUED = 'C' or 'B', A is
* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
* is not accessed. C is an input argument if FACT = 'F';
* otherwise, C is an output argument. If FACT = 'F' and
* EQUED = 'C' or 'B', each element of C must be positive.
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the right hand side matrix B.
* On exit,
* if EQUED = 'N', B is not modified;
* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
* diag(R)*B;
* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
* overwritten by diag(C)*B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (output) REAL array, dimension (LDX,NRHS)
* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X
* to the original system of equations. Note that A and B are
* modified on exit if EQUED .ne. 'N', and the solution to the
* equilibrated system is inv(diag(C))*X if TRANS = 'N' and
* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'
* and EQUED = 'R' or 'B'.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* RCOND (output) REAL
* The estimate of the reciprocal condition number of the matrix
* A after equilibration (if done). If RCOND is less than the
* machine precision (in particular, if RCOND = 0), the matrix
* is singular to working precision. This condition is
* indicated by a return code of INFO > 0.
*
* FERR (output) REAL array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace/output) REAL array, dimension (3*N)
* On exit, WORK(1) contains the reciprocal pivot growth
* factor norm(A)/norm(U). The "max absolute element" norm is
* used. If WORK(1) is much less than 1, then the stability
* of the LU factorization of the (equilibrated) matrix A
* could be poor. This also means that the solution X, condition
* estimator RCOND, and forward error bound FERR could be
* unreliable. If factorization fails with 0 0: if INFO = i, and i is
* <= N: U(i,i) is exactly zero. The factorization
* has been completed, but the factor U is exactly
* singular, so the solution and error bounds
* could not be computed. RCOND = 0 is returned.
* = N+1: U is nonsingular, but RCOND is less than machine
* precision, meaning that the matrix is singular
* to working precision. Nevertheless, the
* solution and error bounds are computed because
* there are a number of situations where the
* computed solution can be more accurate than the
*
* value of RCOND would suggest.
* =====================================================================
* Moved setting of INFO = N+1 so INFO does not subsequently get
* overwritten. Sven, 17 Mar 05.
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU
CHARACTER NORM
INTEGER I, INFEQU, J, J1, J2
REAL AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN,
$ ROWCND, RPVGRW, SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANGB, SLANTB
EXTERNAL LSAME, SLAMCH, SLANGB, SLANTB
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGBCON, SGBEQU, SGBRFS, SGBTRF, SGBTRS,
$ SLACPY, SLAQGB, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
NOFACT = LSAME( FACT, 'N' )
EQUIL = LSAME( FACT, 'E' )
NOTRAN = LSAME( TRANS, 'N' )
IF( NOFACT .OR. EQUIL ) THEN
EQUED = 'N'
ROWEQU = .FALSE.
COLEQU = .FALSE.
ELSE
ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
SMLNUM = SLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
END IF
*
* Test the input parameters.
*
IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
$ THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
$ LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( KL.LT.0 ) THEN
INFO = -4
ELSE IF( KU.LT.0 ) THEN
INFO = -5
ELSE IF( NRHS.LT.0 ) THEN
INFO = -6
ELSE IF( LDAB.LT.KL+KU+1 ) THEN
INFO = -8
ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN
INFO = -10
ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
$ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
INFO = -12
ELSE
IF( ROWEQU ) THEN
RCMIN = BIGNUM
RCMAX = ZERO
DO 10 J = 1, N
RCMIN = MIN( RCMIN, R( J ) )
RCMAX = MAX( RCMAX, R( J ) )
10 CONTINUE
IF( RCMIN.LE.ZERO ) THEN
INFO = -13
ELSE IF( N.GT.0 ) THEN
ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
ELSE
ROWCND = ONE
END IF
END IF
IF( COLEQU .AND. INFO.EQ.0 ) THEN
RCMIN = BIGNUM
RCMAX = ZERO
DO 20 J = 1, N
RCMIN = MIN( RCMIN, C( J ) )
RCMAX = MAX( RCMAX, C( J ) )
20 CONTINUE
IF( RCMIN.LE.ZERO ) THEN
INFO = -14
ELSE IF( N.GT.0 ) THEN
COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
ELSE
COLCND = ONE
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -16
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -18
END IF
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGBSVX', -INFO )
RETURN
END IF
*
IF( EQUIL ) THEN
*
* Compute row and column scalings to equilibrate the matrix A.
*
CALL SGBEQU( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND,
$ AMAX, INFEQU )
IF( INFEQU.EQ.0 ) THEN
*
* Equilibrate the matrix.
*
CALL SLAQGB( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND,
$ AMAX, EQUED )
ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
END IF
END IF
*
* Scale the right hand side.
*
IF( NOTRAN ) THEN
IF( ROWEQU ) THEN
DO 40 J = 1, NRHS
DO 30 I = 1, N
B( I, J ) = R( I )*B( I, J )
30 CONTINUE
40 CONTINUE
END IF
ELSE IF( COLEQU ) THEN
DO 60 J = 1, NRHS
DO 50 I = 1, N
B( I, J ) = C( I )*B( I, J )
50 CONTINUE
60 CONTINUE
END IF
*
IF( NOFACT .OR. EQUIL ) THEN
*
* Compute the LU factorization of the band matrix A.
*
DO 70 J = 1, N
J1 = MAX( J-KU, 1 )
J2 = MIN( J+KL, N )
CALL SCOPY( J2-J1+1, AB( KU+1-J+J1, J ), 1,
$ AFB( KL+KU+1-J+J1, J ), 1 )
70 CONTINUE
*
CALL SGBTRF( N, N, KL, KU, AFB, LDAFB, IPIV, INFO )
*
* Return if INFO is non-zero.
*
IF( INFO.GT.0 ) THEN
*
* Compute the reciprocal pivot growth factor of the
* leading rank-deficient INFO columns of A.
*
ANORM = ZERO
DO 90 J = 1, INFO
DO 80 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
ANORM = MAX( ANORM, ABS( AB( I, J ) ) )
80 CONTINUE
90 CONTINUE
RPVGRW = SLANTB( 'M', 'U', 'N', INFO, MIN( INFO-1, KL+KU ),
$ AFB( MAX( 1, KL+KU+2-INFO ), 1 ), LDAFB,
$ WORK )
IF( RPVGRW.EQ.ZERO ) THEN
RPVGRW = ONE
ELSE
RPVGRW = ANORM / RPVGRW
END IF
WORK( 1 ) = RPVGRW
RCOND = ZERO
RETURN
END IF
END IF
*
* Compute the norm of the matrix A and the
* reciprocal pivot growth factor RPVGRW.
*
IF( NOTRAN ) THEN
NORM = '1'
ELSE
NORM = 'I'
END IF
ANORM = SLANGB( NORM, N, KL, KU, AB, LDAB, WORK )
RPVGRW = SLANTB( 'M', 'U', 'N', N, KL+KU, AFB, LDAFB, WORK )
IF( RPVGRW.EQ.ZERO ) THEN
RPVGRW = ONE
ELSE
RPVGRW = SLANGB( 'M', N, KL, KU, AB, LDAB, WORK ) / RPVGRW
END IF
*
* Compute the reciprocal of the condition number of A.
*
CALL SGBCON( NORM, N, KL, KU, AFB, LDAFB, IPIV, ANORM, RCOND,
$ WORK, IWORK, INFO )
*
* Compute the solution matrix X.
*
CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
CALL SGBTRS( TRANS, N, KL, KU, NRHS, AFB, LDAFB, IPIV, X, LDX,
$ INFO )
*
* Use iterative refinement to improve the computed solution and
* compute error bounds and backward error estimates for it.
*
CALL SGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV,
$ B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
*
* Transform the solution matrix X to a solution of the original
* system.
*
IF( NOTRAN ) THEN
IF( COLEQU ) THEN
DO 110 J = 1, NRHS
DO 100 I = 1, N
X( I, J ) = C( I )*X( I, J )
100 CONTINUE
110 CONTINUE
DO 120 J = 1, NRHS
FERR( J ) = FERR( J ) / COLCND
120 CONTINUE
END IF
ELSE IF( ROWEQU ) THEN
DO 140 J = 1, NRHS
DO 130 I = 1, N
X( I, J ) = R( I )*X( I, J )
130 CONTINUE
140 CONTINUE
DO 150 J = 1, NRHS
FERR( J ) = FERR( J ) / ROWCND
150 CONTINUE
END IF
*
* Set INFO = N+1 if the matrix is singular to working precision.
*
IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
$ INFO = N + 1
*
WORK( 1 ) = RPVGRW
RETURN
*
* End of SGBSVX
*
END
SUBROUTINE SGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, KL, KU, LDAB, M, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
REAL AB( LDAB, * )
* ..
*
* Purpose
* =======
*
* SGBTF2 computes an LU factorization of a real m-by-n band matrix A
* using partial pivoting with row interchanges.
*
* This is the unblocked version of the algorithm, calling Level 2 BLAS.
*
* 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.
*
* KL (input) INTEGER
* The number of subdiagonals within the band of A. KL >= 0.
*
* KU (input) INTEGER
* The number of superdiagonals within the band of A. KU >= 0.
*
* AB (input/output) REAL array, dimension (LDAB,N)
* On entry, the matrix A in band storage, in rows KL+1 to
* 2*KL+KU+1; rows 1 to KL of the array need not be set.
* The j-th column of A is stored in the j-th column of the
* array AB as follows:
* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
*
* On exit, details of the factorization: U is stored as an
* upper triangular band matrix with KL+KU superdiagonals in
* rows 1 to KL+KU+1, and the multipliers used during the
* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
* See below for further details.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
*
* 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.
*
* Further Details
* ===============
*
* The band storage scheme is illustrated by the following example, when
* M = N = 6, KL = 2, KU = 1:
*
* On entry: On exit:
*
* * * * + + + * * * u14 u25 u36
* * * + + + + * * u13 u24 u35 u46
* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
* a31 a42 a53 a64 * * m31 m42 m53 m64 * *
*
* Array elements marked * are not used by the routine; elements marked
* + need not be set on entry, but are required by the routine to store
* elements of U, because of fill-in resulting from the row
* interchanges.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, JP, JU, KM, KV
* ..
* .. External Functions ..
INTEGER ISAMAX
EXTERNAL ISAMAX
* ..
* .. External Subroutines ..
EXTERNAL SGER, SSCAL, SSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* KV is the number of superdiagonals in the factor U, allowing for
* fill-in.
*
KV = KU + KL
*
* Test the input parameters.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( KL.LT.0 ) THEN
INFO = -3
ELSE IF( KU.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.KL+KV+1 ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGBTF2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
* Gaussian elimination with partial pivoting
*
* Set fill-in elements in columns KU+2 to KV to zero.
*
DO 20 J = KU + 2, MIN( KV, N )
DO 10 I = KV - J + 2, KL
AB( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
*
* JU is the index of the last column affected by the current stage
* of the factorization.
*
JU = 1
*
DO 40 J = 1, MIN( M, N )
*
* Set fill-in elements in column J+KV to zero.
*
IF( J+KV.LE.N ) THEN
DO 30 I = 1, KL
AB( I, J+KV ) = ZERO
30 CONTINUE
END IF
*
* Find pivot and test for singularity. KM is the number of
* subdiagonal elements in the current column.
*
KM = MIN( KL, M-J )
JP = ISAMAX( KM+1, AB( KV+1, J ), 1 )
IPIV( J ) = JP + J - 1
IF( AB( KV+JP, J ).NE.ZERO ) THEN
JU = MAX( JU, MIN( J+KU+JP-1, N ) )
*
* Apply interchange to columns J to JU.
*
IF( JP.NE.1 )
$ CALL SSWAP( JU-J+1, AB( KV+JP, J ), LDAB-1,
$ AB( KV+1, J ), LDAB-1 )
*
IF( KM.GT.0 ) THEN
*
* Compute multipliers.
*
CALL SSCAL( KM, ONE / AB( KV+1, J ), AB( KV+2, J ), 1 )
*
* Update trailing submatrix within the band.
*
IF( JU.GT.J )
$ CALL SGER( KM, JU-J, -ONE, AB( KV+2, J ), 1,
$ AB( KV, J+1 ), LDAB-1, AB( KV+1, J+1 ),
$ LDAB-1 )
END IF
ELSE
*
* If pivot is zero, set INFO to the index of the pivot
* unless a zero pivot has already been found.
*
IF( INFO.EQ.0 )
$ INFO = J
END IF
40 CONTINUE
RETURN
*
* End of SGBTF2
*
END
SUBROUTINE SGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, KL, KU, LDAB, M, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
REAL AB( LDAB, * )
* ..
*
* Purpose
* =======
*
* SGBTRF computes an LU factorization of a real m-by-n band matrix A
* using partial pivoting with row interchanges.
*
* This is the blocked version of the algorithm, calling Level 3 BLAS.
*
* 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.
*
* KL (input) INTEGER
* The number of subdiagonals within the band of A. KL >= 0.
*
* KU (input) INTEGER
* The number of superdiagonals within the band of A. KU >= 0.
*
* AB (input/output) REAL array, dimension (LDAB,N)
* On entry, the matrix A in band storage, in rows KL+1 to
* 2*KL+KU+1; rows 1 to KL of the array need not be set.
* The j-th column of A is stored in the j-th column of the
* array AB as follows:
* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
*
* On exit, details of the factorization: U is stored as an
* upper triangular band matrix with KL+KU superdiagonals in
* rows 1 to KL+KU+1, and the multipliers used during the
* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
* See below for further details.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
*
* 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.
*
* Further Details
* ===============
*
* The band storage scheme is illustrated by the following example, when
* M = N = 6, KL = 2, KU = 1:
*
* On entry: On exit:
*
* * * * + + + * * * u14 u25 u36
* * * + + + + * * u13 u24 u35 u46
* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
* a31 a42 a53 a64 * * m31 m42 m53 m64 * *
*
* Array elements marked * are not used by the routine; elements marked
* + need not be set on entry, but are required by the routine to store
* elements of U because of fill-in resulting from the row interchanges.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
INTEGER NBMAX, LDWORK
PARAMETER ( NBMAX = 64, LDWORK = NBMAX+1 )
* ..
* .. Local Scalars ..
INTEGER I, I2, I3, II, IP, J, J2, J3, JB, JJ, JM, JP,
$ JU, K2, KM, KV, NB, NW
REAL TEMP
* ..
* .. Local Arrays ..
REAL WORK13( LDWORK, NBMAX ),
$ WORK31( LDWORK, NBMAX )
* ..
* .. External Functions ..
INTEGER ILAENV, ISAMAX
EXTERNAL ILAENV, ISAMAX
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGBTF2, SGEMM, SGER, SLASWP, SSCAL,
$ SSWAP, STRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* KV is the number of superdiagonals in the factor U, allowing for
* fill-in
*
KV = KU + KL
*
* Test the input parameters.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( KL.LT.0 ) THEN
INFO = -3
ELSE IF( KU.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.KL+KV+1 ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGBTRF', -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, 'SGBTRF', ' ', M, N, KL, KU )
*
* The block size must not exceed the limit set by the size of the
* local arrays WORK13 and WORK31.
*
NB = MIN( NB, NBMAX )
*
IF( NB.LE.1 .OR. NB.GT.KL ) THEN
*
* Use unblocked code
*
CALL SGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
ELSE
*
* Use blocked code
*
* Zero the superdiagonal elements of the work array WORK13
*
DO 20 J = 1, NB
DO 10 I = 1, J - 1
WORK13( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
*
* Zero the subdiagonal elements of the work array WORK31
*
DO 40 J = 1, NB
DO 30 I = J + 1, NB
WORK31( I, J ) = ZERO
30 CONTINUE
40 CONTINUE
*
* Gaussian elimination with partial pivoting
*
* Set fill-in elements in columns KU+2 to KV to zero
*
DO 60 J = KU + 2, MIN( KV, N )
DO 50 I = KV - J + 2, KL
AB( I, J ) = ZERO
50 CONTINUE
60 CONTINUE
*
* JU is the index of the last column affected by the current
* stage of the factorization
*
JU = 1
*
DO 180 J = 1, MIN( M, N ), NB
JB = MIN( NB, MIN( M, N )-J+1 )
*
* The active part of the matrix is partitioned
*
* A11 A12 A13
* A21 A22 A23
* A31 A32 A33
*
* Here A11, A21 and A31 denote the current block of JB columns
* which is about to be factorized. The number of rows in the
* partitioning are JB, I2, I3 respectively, and the numbers
* of columns are JB, J2, J3. The superdiagonal elements of A13
* and the subdiagonal elements of A31 lie outside the band.
*
I2 = MIN( KL-JB, M-J-JB+1 )
I3 = MIN( JB, M-J-KL+1 )
*
* J2 and J3 are computed after JU has been updated.
*
* Factorize the current block of JB columns
*
DO 80 JJ = J, J + JB - 1
*
* Set fill-in elements in column JJ+KV to zero
*
IF( JJ+KV.LE.N ) THEN
DO 70 I = 1, KL
AB( I, JJ+KV ) = ZERO
70 CONTINUE
END IF
*
* Find pivot and test for singularity. KM is the number of
* subdiagonal elements in the current column.
*
KM = MIN( KL, M-JJ )
JP = ISAMAX( KM+1, AB( KV+1, JJ ), 1 )
IPIV( JJ ) = JP + JJ - J
IF( AB( KV+JP, JJ ).NE.ZERO ) THEN
JU = MAX( JU, MIN( JJ+KU+JP-1, N ) )
IF( JP.NE.1 ) THEN
*
* Apply interchange to columns J to J+JB-1
*
IF( JP+JJ-1.LT.J+KL ) THEN
*
CALL SSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1,
$ AB( KV+JP+JJ-J, J ), LDAB-1 )
ELSE
*
* The interchange affects columns J to JJ-1 of A31
* which are stored in the work array WORK31
*
CALL SSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
$ WORK31( JP+JJ-J-KL, 1 ), LDWORK )
CALL SSWAP( J+JB-JJ, AB( KV+1, JJ ), LDAB-1,
$ AB( KV+JP, JJ ), LDAB-1 )
END IF
END IF
*
* Compute multipliers
*
CALL SSCAL( KM, ONE / AB( KV+1, JJ ), AB( KV+2, JJ ),
$ 1 )
*
* Update trailing submatrix within the band and within
* the current block. JM is the index of the last column
* which needs to be updated.
*
JM = MIN( JU, J+JB-1 )
IF( JM.GT.JJ )
$ CALL SGER( KM, JM-JJ, -ONE, AB( KV+2, JJ ), 1,
$ AB( KV, JJ+1 ), LDAB-1,
$ AB( KV+1, JJ+1 ), LDAB-1 )
ELSE
*
* If pivot is zero, set INFO to the index of the pivot
* unless a zero pivot has already been found.
*
IF( INFO.EQ.0 )
$ INFO = JJ
END IF
*
* Copy current column of A31 into the work array WORK31
*
NW = MIN( JJ-J+1, I3 )
IF( NW.GT.0 )
$ CALL SCOPY( NW, AB( KV+KL+1-JJ+J, JJ ), 1,
$ WORK31( 1, JJ-J+1 ), 1 )
80 CONTINUE
IF( J+JB.LE.N ) THEN
*
* Apply the row interchanges to the other blocks.
*
J2 = MIN( JU-J+1, KV ) - JB
J3 = MAX( 0, JU-J-KV+1 )
*
* Use SLASWP to apply the row interchanges to A12, A22, and
* A32.
*
CALL SLASWP( J2, AB( KV+1-JB, J+JB ), LDAB-1, 1, JB,
$ IPIV( J ), 1 )
*
* Adjust the pivot indices.
*
DO 90 I = J, J + JB - 1
IPIV( I ) = IPIV( I ) + J - 1
90 CONTINUE
*
* Apply the row interchanges to A13, A23, and A33
* columnwise.
*
K2 = J - 1 + JB + J2
DO 110 I = 1, J3
JJ = K2 + I
DO 100 II = J + I - 1, J + JB - 1
IP = IPIV( II )
IF( IP.NE.II ) THEN
TEMP = AB( KV+1+II-JJ, JJ )
AB( KV+1+II-JJ, JJ ) = AB( KV+1+IP-JJ, JJ )
AB( KV+1+IP-JJ, JJ ) = TEMP
END IF
100 CONTINUE
110 CONTINUE
*
* Update the relevant part of the trailing submatrix
*
IF( J2.GT.0 ) THEN
*
* Update A12
*
CALL STRSM( 'Left', 'Lower', 'No transpose', 'Unit',
$ JB, J2, ONE, AB( KV+1, J ), LDAB-1,
$ AB( KV+1-JB, J+JB ), LDAB-1 )
*
IF( I2.GT.0 ) THEN
*
* Update A22
*
CALL SGEMM( 'No transpose', 'No transpose', I2, J2,
$ JB, -ONE, AB( KV+1+JB, J ), LDAB-1,
$ AB( KV+1-JB, J+JB ), LDAB-1, ONE,
$ AB( KV+1, J+JB ), LDAB-1 )
END IF
*
IF( I3.GT.0 ) THEN
*
* Update A32
*
CALL SGEMM( 'No transpose', 'No transpose', I3, J2,
$ JB, -ONE, WORK31, LDWORK,
$ AB( KV+1-JB, J+JB ), LDAB-1, ONE,
$ AB( KV+KL+1-JB, J+JB ), LDAB-1 )
END IF
END IF
*
IF( J3.GT.0 ) THEN
*
* Copy the lower triangle of A13 into the work array
* WORK13
*
DO 130 JJ = 1, J3
DO 120 II = JJ, JB
WORK13( II, JJ ) = AB( II-JJ+1, JJ+J+KV-1 )
120 CONTINUE
130 CONTINUE
*
* Update A13 in the work array
*
CALL STRSM( 'Left', 'Lower', 'No transpose', 'Unit',
$ JB, J3, ONE, AB( KV+1, J ), LDAB-1,
$ WORK13, LDWORK )
*
IF( I2.GT.0 ) THEN
*
* Update A23
*
CALL SGEMM( 'No transpose', 'No transpose', I2, J3,
$ JB, -ONE, AB( KV+1+JB, J ), LDAB-1,
$ WORK13, LDWORK, ONE, AB( 1+JB, J+KV ),
$ LDAB-1 )
END IF
*
IF( I3.GT.0 ) THEN
*
* Update A33
*
CALL SGEMM( 'No transpose', 'No transpose', I3, J3,
$ JB, -ONE, WORK31, LDWORK, WORK13,
$ LDWORK, ONE, AB( 1+KL, J+KV ), LDAB-1 )
END IF
*
* Copy the lower triangle of A13 back into place
*
DO 150 JJ = 1, J3
DO 140 II = JJ, JB
AB( II-JJ+1, JJ+J+KV-1 ) = WORK13( II, JJ )
140 CONTINUE
150 CONTINUE
END IF
ELSE
*
* Adjust the pivot indices.
*
DO 160 I = J, J + JB - 1
IPIV( I ) = IPIV( I ) + J - 1
160 CONTINUE
END IF
*
* Partially undo the interchanges in the current block to
* restore the upper triangular form of A31 and copy the upper
* triangle of A31 back into place
*
DO 170 JJ = J + JB - 1, J, -1
JP = IPIV( JJ ) - JJ + 1
IF( JP.NE.1 ) THEN
*
* Apply interchange to columns J to JJ-1
*
IF( JP+JJ-1.LT.J+KL ) THEN
*
* The interchange does not affect A31
*
CALL SSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
$ AB( KV+JP+JJ-J, J ), LDAB-1 )
ELSE
*
* The interchange does affect A31
*
CALL SSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
$ WORK31( JP+JJ-J-KL, 1 ), LDWORK )
END IF
END IF
*
* Copy the current column of A31 back into place
*
NW = MIN( I3, JJ-J+1 )
IF( NW.GT.0 )
$ CALL SCOPY( NW, WORK31( 1, JJ-J+1 ), 1,
$ AB( KV+KL+1-JJ+J, JJ ), 1 )
170 CONTINUE
180 CONTINUE
END IF
*
RETURN
*
* End of SGBTRF
*
END
SUBROUTINE SGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
REAL AB( LDAB, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* SGBTRS solves a system of linear equations
* A * X = B or A' * X = B
* with a general band matrix A using the LU factorization computed
* by SGBTRF.
*
* Arguments
* =========
*
* TRANS (input) CHARACTER*1
* Specifies the form of the system of equations.
* = 'N': A * X = B (No transpose)
* = 'T': A'* X = B (Transpose)
* = 'C': A'* X = B (Conjugate transpose = Transpose)
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KL (input) INTEGER
* The number of subdiagonals within the band of A. KL >= 0.
*
* KU (input) INTEGER
* The number of superdiagonals within the band of A. KU >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrix B. NRHS >= 0.
*
* AB (input) REAL array, dimension (LDAB,N)
* Details of the LU factorization of the band matrix A, as
* computed by SGBTRF. U is stored as an upper triangular band
* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
* the multipliers used during the factorization are stored in
* rows KL+KU+2 to 2*KL+KU+1.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices; for 1 <= i <= N, row i of the matrix was
* interchanged with row IPIV(i).
*
* B (input/output) REAL 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 ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LNOTI, NOTRAN
INTEGER I, J, KD, L, LM
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SGEMV, SGER, SSWAP, STBSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. 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( KL.LT.0 ) THEN
INFO = -3
ELSE IF( KU.LT.0 ) THEN
INFO = -4
ELSE IF( NRHS.LT.0 ) THEN
INFO = -5
ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGBTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
KD = KU + KL + 1
LNOTI = KL.GT.0
*
IF( NOTRAN ) THEN
*
* Solve A*X = B.
*
* Solve L*X = B, overwriting B with X.
*
* L is represented as a product of permutations and unit lower
* triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1),
* where each transformation L(i) is a rank-one modification of
* the identity matrix.
*
IF( LNOTI ) THEN
DO 10 J = 1, N - 1
LM = MIN( KL, N-J )
L = IPIV( J )
IF( L.NE.J )
$ CALL SSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
CALL SGER( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ),
$ LDB, B( J+1, 1 ), LDB )
10 CONTINUE
END IF
*
DO 20 I = 1, NRHS
*
* Solve U*X = B, overwriting B with X.
*
CALL STBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU,
$ AB, LDAB, B( 1, I ), 1 )
20 CONTINUE
*
ELSE
*
* Solve A'*X = B.
*
DO 30 I = 1, NRHS
*
* Solve U'*X = B, overwriting B with X.
*
CALL STBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB,
$ LDAB, B( 1, I ), 1 )
30 CONTINUE
*
* Solve L'*X = B, overwriting B with X.
*
IF( LNOTI ) THEN
DO 40 J = N - 1, 1, -1
LM = MIN( KL, N-J )
CALL SGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ),
$ LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB )
L = IPIV( J )
IF( L.NE.J )
$ CALL SSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
40 CONTINUE
END IF
END IF
RETURN
*
* End of SGBTRS
*
END
SUBROUTINE SGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOB, SIDE
INTEGER IHI, ILO, INFO, LDV, M, N
* ..
* .. Array Arguments ..
REAL V( LDV, * ), SCALE( * )
* ..
*
* Purpose
* =======
*
* SGEBAK forms the right or left eigenvectors of a real general matrix
* by backward transformation on the computed eigenvectors of the
* balanced matrix output by SGEBAL.
*
* Arguments
* =========
*
* JOB (input) CHARACTER*1
* Specifies the type of backward transformation required:
* = 'N', do nothing, return immediately;
* = 'P', do backward transformation for permutation only;
* = 'S', do backward transformation for scaling only;
* = 'B', do backward transformations for both permutation and
* scaling.
* JOB must be the same as the argument JOB supplied to SGEBAL.
*
* SIDE (input) CHARACTER*1
* = 'R': V contains right eigenvectors;
* = 'L': V contains left eigenvectors.
*
* N (input) INTEGER
* The number of rows of the matrix V. N >= 0.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* The integers ILO and IHI determined by SGEBAL.
* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
*
* SCALE (input) REAL array, dimension (N)
* Details of the permutation and scaling factors, as returned
* by SGEBAL.
*
* M (input) INTEGER
* The number of columns of the matrix V. M >= 0.
*
* V (input/output) REAL array, dimension (LDV,M)
* On entry, the matrix of right or left eigenvectors to be
* transformed, as returned by SHSEIN or STREVC.
* On exit, V is overwritten by the transformed eigenvectors.
*
* LDV (input) INTEGER
* The leading dimension of the array V. LDV >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LEFTV, RIGHTV
INTEGER I, II, K
REAL S
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SSCAL, SSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Decode and Test the input parameters
*
RIGHTV = LSAME( SIDE, 'R' )
LEFTV = LSAME( SIDE, 'L' )
*
INFO = 0
IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
$ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
INFO = -1
ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
INFO = -5
ELSE IF( M.LT.0 ) THEN
INFO = -7
ELSE IF( LDV.LT.MAX( 1, N ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGEBAK', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
IF( M.EQ.0 )
$ RETURN
IF( LSAME( JOB, 'N' ) )
$ RETURN
*
IF( ILO.EQ.IHI )
$ GO TO 30
*
* Backward balance
*
IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN
*
IF( RIGHTV ) THEN
DO 10 I = ILO, IHI
S = SCALE( I )
CALL SSCAL( M, S, V( I, 1 ), LDV )
10 CONTINUE
END IF
*
IF( LEFTV ) THEN
DO 20 I = ILO, IHI
S = ONE / SCALE( I )
CALL SSCAL( M, S, V( I, 1 ), LDV )
20 CONTINUE
END IF
*
END IF
*
* Backward permutation
*
* For I = ILO-1 step -1 until 1,
* IHI+1 step 1 until N do --
*
30 CONTINUE
IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN
IF( RIGHTV ) THEN
DO 40 II = 1, N
I = II
IF( I.GE.ILO .AND. I.LE.IHI )
$ GO TO 40
IF( I.LT.ILO )
$ I = ILO - II
K = SCALE( I )
IF( K.EQ.I )
$ GO TO 40
CALL SSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
40 CONTINUE
END IF
*
IF( LEFTV ) THEN
DO 50 II = 1, N
I = II
IF( I.GE.ILO .AND. I.LE.IHI )
$ GO TO 50
IF( I.LT.ILO )
$ I = ILO - II
K = SCALE( I )
IF( K.EQ.I )
$ GO TO 50
CALL SSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
50 CONTINUE
END IF
END IF
*
RETURN
*
* End of SGEBAK
*
END
SUBROUTINE SGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOB
INTEGER IHI, ILO, INFO, LDA, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), SCALE( * )
* ..
*
* Purpose
* =======
*
* SGEBAL balances a general real matrix A. This involves, first,
* permuting A by a similarity transformation to isolate eigenvalues
* in the first 1 to ILO-1 and last IHI+1 to N elements on the
* diagonal; and second, applying a diagonal similarity transformation
* to rows and columns ILO to IHI to make the rows and columns as
* close in norm as possible. Both steps are optional.
*
* Balancing may reduce the 1-norm of the matrix, and improve the
* accuracy of the computed eigenvalues and/or eigenvectors.
*
* Arguments
* =========
*
* JOB (input) CHARACTER*1
* Specifies the operations to be performed on A:
* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0
* for i = 1,...,N;
* = 'P': permute only;
* = 'S': scale only;
* = 'B': both permute and scale.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the input matrix A.
* On exit, A is overwritten by the balanced matrix.
* If JOB = 'N', A is not referenced.
* See Further Details.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* ILO (output) INTEGER
* IHI (output) INTEGER
* ILO and IHI are set to integers such that on exit
* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.
* If JOB = 'N' or 'S', ILO = 1 and IHI = N.
*
* SCALE (output) REAL array, dimension (N)
* Details of the permutations and scaling factors applied to
* A. If P(j) is the index of the row and column interchanged
* with row and column j and D(j) is the scaling factor
* applied to row and column j, then
* SCALE(j) = P(j) for j = 1,...,ILO-1
* = D(j) for j = ILO,...,IHI
* = P(j) for j = IHI+1,...,N.
* The order in which the interchanges are made is N to IHI+1,
* then 1 to ILO-1.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* The permutations consist of row and column interchanges which put
* the matrix in the form
*
* ( T1 X Y )
* P A P = ( 0 B Z )
* ( 0 0 T2 )
*
* where T1 and T2 are upper triangular matrices whose eigenvalues lie
* along the diagonal. The column indices ILO and IHI mark the starting
* and ending columns of the submatrix B. Balancing consists of applying
* a diagonal similarity transformation inv(D) * B * D to make the
* 1-norms of each row of B and its corresponding column nearly equal.
* The output matrix is
*
* ( T1 X*D Y )
* ( 0 inv(D)*B*D inv(D)*Z ).
* ( 0 0 T2 )
*
* Information about the permutations P and the diagonal matrix D is
* returned in the vector SCALE.
*
* This subroutine is based on the EISPACK routine BALANC.
*
* Modified by Tzu-Yi Chen, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
REAL SCLFAC
PARAMETER ( SCLFAC = 2.0E+0 )
REAL FACTOR
PARAMETER ( FACTOR = 0.95E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOCONV
INTEGER I, ICA, IEXC, IRA, J, K, L, M
REAL C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1,
$ SFMIN2
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SLAMCH
EXTERNAL LSAME, ISAMAX, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SSCAL, SSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
$ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGEBAL', -INFO )
RETURN
END IF
*
K = 1
L = N
*
IF( N.EQ.0 )
$ GO TO 210
*
IF( LSAME( JOB, 'N' ) ) THEN
DO 10 I = 1, N
SCALE( I ) = ONE
10 CONTINUE
GO TO 210
END IF
*
IF( LSAME( JOB, 'S' ) )
$ GO TO 120
*
* Permutation to isolate eigenvalues if possible
*
GO TO 50
*
* Row and column exchange.
*
20 CONTINUE
SCALE( M ) = J
IF( J.EQ.M )
$ GO TO 30
*
CALL SSWAP( L, A( 1, J ), 1, A( 1, M ), 1 )
CALL SSWAP( N-K+1, A( J, K ), LDA, A( M, K ), LDA )
*
30 CONTINUE
GO TO ( 40, 80 )IEXC
*
* Search for rows isolating an eigenvalue and push them down.
*
40 CONTINUE
IF( L.EQ.1 )
$ GO TO 210
L = L - 1
*
50 CONTINUE
DO 70 J = L, 1, -1
*
DO 60 I = 1, L
IF( I.EQ.J )
$ GO TO 60
IF( A( J, I ).NE.ZERO )
$ GO TO 70
60 CONTINUE
*
M = L
IEXC = 1
GO TO 20
70 CONTINUE
*
GO TO 90
*
* Search for columns isolating an eigenvalue and push them left.
*
80 CONTINUE
K = K + 1
*
90 CONTINUE
DO 110 J = K, L
*
DO 100 I = K, L
IF( I.EQ.J )
$ GO TO 100
IF( A( I, J ).NE.ZERO )
$ GO TO 110
100 CONTINUE
*
M = K
IEXC = 2
GO TO 20
110 CONTINUE
*
120 CONTINUE
DO 130 I = K, L
SCALE( I ) = ONE
130 CONTINUE
*
IF( LSAME( JOB, 'P' ) )
$ GO TO 210
*
* Balance the submatrix in rows K to L.
*
* Iterative loop for norm reduction
*
SFMIN1 = SLAMCH( 'S' ) / SLAMCH( 'P' )
SFMAX1 = ONE / SFMIN1
SFMIN2 = SFMIN1*SCLFAC
SFMAX2 = ONE / SFMIN2
140 CONTINUE
NOCONV = .FALSE.
*
DO 200 I = K, L
C = ZERO
R = ZERO
*
DO 150 J = K, L
IF( J.EQ.I )
$ GO TO 150
C = C + ABS( A( J, I ) )
R = R + ABS( A( I, J ) )
150 CONTINUE
ICA = ISAMAX( L, A( 1, I ), 1 )
CA = ABS( A( ICA, I ) )
IRA = ISAMAX( N-K+1, A( I, K ), LDA )
RA = ABS( A( I, IRA+K-1 ) )
*
* Guard against zero C or R due to underflow.
*
IF( C.EQ.ZERO .OR. R.EQ.ZERO )
$ GO TO 200
G = R / SCLFAC
F = ONE
S = C + R
160 CONTINUE
IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR.
$ MIN( R, G, RA ).LE.SFMIN2 )GO TO 170
F = F*SCLFAC
C = C*SCLFAC
CA = CA*SCLFAC
R = R / SCLFAC
G = G / SCLFAC
RA = RA / SCLFAC
GO TO 160
*
170 CONTINUE
G = C / SCLFAC
180 CONTINUE
IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR.
$ MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 190
F = F / SCLFAC
C = C / SCLFAC
G = G / SCLFAC
CA = CA / SCLFAC
R = R*SCLFAC
RA = RA*SCLFAC
GO TO 180
*
* Now balance.
*
190 CONTINUE
IF( ( C+R ).GE.FACTOR*S )
$ GO TO 200
IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN
IF( F*SCALE( I ).LE.SFMIN1 )
$ GO TO 200
END IF
IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN
IF( SCALE( I ).GE.SFMAX1 / F )
$ GO TO 200
END IF
G = ONE / F
SCALE( I ) = SCALE( I )*F
NOCONV = .TRUE.
*
CALL SSCAL( N-K+1, G, A( I, K ), LDA )
CALL SSCAL( L, F, A( 1, I ), 1 )
*
200 CONTINUE
*
IF( NOCONV )
$ GO TO 140
*
210 CONTINUE
ILO = K
IHI = L
*
RETURN
*
* End of SGEBAL
*
END
SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), D( * ), E( * ), TAUP( * ),
$ TAUQ( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGEBD2 reduces a real general m by n matrix A to upper or lower
* bidiagonal form B by an orthogonal transformation: Q' * A * P = B.
*
* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows in the matrix A. M >= 0.
*
* N (input) INTEGER
* The number of columns in the matrix A. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the m by n general matrix to be reduced.
* On exit,
* if m >= n, the diagonal and the first superdiagonal are
* overwritten with the upper bidiagonal matrix B; the
* elements below the diagonal, with the array TAUQ, represent
* the orthogonal matrix Q as a product of elementary
* reflectors, and the elements above the first superdiagonal,
* with the array TAUP, represent the orthogonal matrix P as
* a product of elementary reflectors;
* if m < n, the diagonal and the first subdiagonal are
* overwritten with the lower bidiagonal matrix B; the
* elements below the first subdiagonal, with the array TAUQ,
* represent the orthogonal matrix Q as a product of
* elementary reflectors, and the elements above the diagonal,
* with the array TAUP, represent the orthogonal matrix P as
* a product of elementary reflectors.
* See Further Details.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* D (output) REAL array, dimension (min(M,N))
* The diagonal elements of the bidiagonal matrix B:
* D(i) = A(i,i).
*
* E (output) REAL array, dimension (min(M,N)-1)
* The off-diagonal elements of the bidiagonal matrix B:
* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
*
* TAUQ (output) REAL array dimension (min(M,N))
* The scalar factors of the elementary reflectors which
* represent the orthogonal matrix Q. See Further Details.
*
* TAUP (output) REAL array, dimension (min(M,N))
* The scalar factors of the elementary reflectors which
* represent the orthogonal matrix P. See Further Details.
*
* WORK (workspace) REAL array, dimension (max(M,N))
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* The matrices Q and P are represented as products of elementary
* reflectors:
*
* If m >= n,
*
* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)
*
* Each H(i) and G(i) has the form:
*
* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
*
* where tauq and taup are real scalars, and v and u are real vectors;
* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);
* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);
* tauq is stored in TAUQ(i) and taup in TAUP(i).
*
* If m < n,
*
* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)
*
* Each H(i) and G(i) has the form:
*
* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
*
* where tauq and taup are real scalars, and v and u are real vectors;
* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
* tauq is stored in TAUQ(i) and taup in TAUP(i).
*
* The contents of A on exit are illustrated by the following examples:
*
* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
*
* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )
* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )
* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )
* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )
* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )
* ( v1 v2 v3 v4 v5 )
*
* where d and e denote diagonal and off-diagonal elements of B, vi
* denotes an element of the vector defining H(i), and ui an element of
* the vector defining G(i).
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I
* ..
* .. External Subroutines ..
EXTERNAL SLARF, SLARFG, 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.LT.0 ) THEN
CALL XERBLA( 'SGEBD2', -INFO )
RETURN
END IF
*
IF( M.GE.N ) THEN
*
* Reduce to upper bidiagonal form
*
DO 10 I = 1, N
*
* Generate elementary reflector H(i) to annihilate A(i+1:m,i)
*
CALL SLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
$ TAUQ( I ) )
D( I ) = A( I, I )
A( I, I ) = ONE
*
* Apply H(i) to A(i:m,i+1:n) from the left
*
IF( I.LT.N )
$ CALL SLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAUQ( I ),
$ A( I, I+1 ), LDA, WORK )
A( I, I ) = D( I )
*
IF( I.LT.N ) THEN
*
* Generate elementary reflector G(i) to annihilate
* A(i,i+2:n)
*
CALL SLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ),
$ LDA, TAUP( I ) )
E( I ) = A( I, I+1 )
A( I, I+1 ) = ONE
*
* Apply G(i) to A(i+1:m,i+1:n) from the right
*
CALL SLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA,
$ TAUP( I ), A( I+1, I+1 ), LDA, WORK )
A( I, I+1 ) = E( I )
ELSE
TAUP( I ) = ZERO
END IF
10 CONTINUE
ELSE
*
* Reduce to lower bidiagonal form
*
DO 20 I = 1, M
*
* Generate elementary reflector G(i) to annihilate A(i,i+1:n)
*
CALL SLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA,
$ TAUP( I ) )
D( I ) = A( I, I )
A( I, I ) = ONE
*
* Apply G(i) to A(i+1:m,i:n) from the right
*
IF( I.LT.M )
$ CALL SLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
$ TAUP( I ), A( I+1, I ), LDA, WORK )
A( I, I ) = D( I )
*
IF( I.LT.M ) THEN
*
* Generate elementary reflector H(i) to annihilate
* A(i+2:m,i)
*
CALL SLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1,
$ TAUQ( I ) )
E( I ) = A( I+1, I )
A( I+1, I ) = ONE
*
* Apply H(i) to A(i+1:m,i+1:n) from the left
*
CALL SLARF( 'Left', M-I, N-I, A( I+1, I ), 1, TAUQ( I ),
$ A( I+1, I+1 ), LDA, WORK )
A( I+1, I ) = E( I )
ELSE
TAUQ( I ) = ZERO
END IF
20 CONTINUE
END IF
RETURN
*
* End of SGEBD2
*
END
SUBROUTINE SGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), D( * ), E( * ), TAUP( * ),
$ TAUQ( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGEBRD reduces a general real M-by-N matrix A to upper or lower
* bidiagonal form B by an orthogonal transformation: Q**T * A * P = B.
*
* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows in the matrix A. M >= 0.
*
* N (input) INTEGER
* The number of columns in the matrix A. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the M-by-N general matrix to be reduced.
* On exit,
* if m >= n, the diagonal and the first superdiagonal are
* overwritten with the upper bidiagonal matrix B; the
* elements below the diagonal, with the array TAUQ, represent
* the orthogonal matrix Q as a product of elementary
* reflectors, and the elements above the first superdiagonal,
* with the array TAUP, represent the orthogonal matrix P as
* a product of elementary reflectors;
* if m < n, the diagonal and the first subdiagonal are
* overwritten with the lower bidiagonal matrix B; the
* elements below the first subdiagonal, with the array TAUQ,
* represent the orthogonal matrix Q as a product of
* elementary reflectors, and the elements above the diagonal,
* with the array TAUP, represent the orthogonal matrix P as
* a product of elementary reflectors.
* See Further Details.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* D (output) REAL array, dimension (min(M,N))
* The diagonal elements of the bidiagonal matrix B:
* D(i) = A(i,i).
*
* E (output) REAL array, dimension (min(M,N)-1)
* The off-diagonal elements of the bidiagonal matrix B:
* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
*
* TAUQ (output) REAL array dimension (min(M,N))
* The scalar factors of the elementary reflectors which
* represent the orthogonal matrix Q. See Further Details.
*
* TAUP (output) REAL array, dimension (min(M,N))
* The scalar factors of the elementary reflectors which
* represent the orthogonal matrix P. See Further Details.
*
* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The length of the array WORK. LWORK >= max(1,M,N).
* For optimum performance LWORK >= (M+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 matrices Q and P are represented as products of elementary
* reflectors:
*
* If m >= n,
*
* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)
*
* Each H(i) and G(i) has the form:
*
* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
*
* where tauq and taup are real scalars, and v and u are real vectors;
* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);
* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);
* tauq is stored in TAUQ(i) and taup in TAUP(i).
*
* If m < n,
*
* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)
*
* Each H(i) and G(i) has the form:
*
* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
*
* where tauq and taup are real scalars, and v and u are real vectors;
* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
* tauq is stored in TAUQ(i) and taup in TAUP(i).
*
* The contents of A on exit are illustrated by the following examples:
*
* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
*
* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )
* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )
* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )
* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )
* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )
* ( v1 v2 v3 v4 v5 )
*
* where d and e denote diagonal and off-diagonal elements of B, vi
* denotes an element of the vector defining H(i), and ui an element of
* the vector defining G(i).
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB,
$ NBMIN, NX
REAL WS
* ..
* .. External Subroutines ..
EXTERNAL SGEBD2, SGEMM, SLABRD, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
NB = MAX( 1, ILAENV( 1, 'SGEBRD', ' ', M, N, -1, -1 ) )
LWKOPT = ( M+N )*NB
WORK( 1 ) = REAL( 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, M, N ) .AND. .NOT.LQUERY ) THEN
INFO = -10
END IF
IF( INFO.LT.0 ) THEN
CALL XERBLA( 'SGEBRD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
MINMN = MIN( M, N )
IF( MINMN.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
WS = MAX( M, N )
LDWRKX = M
LDWRKY = N
*
IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN
*
* Set the crossover point NX.
*
NX = MAX( NB, ILAENV( 3, 'SGEBRD', ' ', M, N, -1, -1 ) )
*
* Determine when to switch from blocked to unblocked code.
*
IF( NX.LT.MINMN ) THEN
WS = ( M+N )*NB
IF( LWORK.LT.WS ) THEN
*
* Not enough work space for the optimal NB, consider using
* a smaller block size.
*
NBMIN = ILAENV( 2, 'SGEBRD', ' ', M, N, -1, -1 )
IF( LWORK.GE.( M+N )*NBMIN ) THEN
NB = LWORK / ( M+N )
ELSE
NB = 1
NX = MINMN
END IF
END IF
END IF
ELSE
NX = MINMN
END IF
*
DO 30 I = 1, MINMN - NX, NB
*
* Reduce rows and columns i:i+nb-1 to bidiagonal form and return
* the matrices X and Y which are needed to update the unreduced
* part of the matrix
*
CALL SLABRD( M-I+1, N-I+1, NB, A( I, I ), LDA, D( I ), E( I ),
$ TAUQ( I ), TAUP( I ), WORK, LDWRKX,
$ WORK( LDWRKX*NB+1 ), LDWRKY )
*
* Update the trailing submatrix A(i+nb:m,i+nb:n), using an update
* of the form A := A - V*Y' - X*U'
*
CALL SGEMM( 'No transpose', 'Transpose', M-I-NB+1, N-I-NB+1,
$ NB, -ONE, A( I+NB, I ), LDA,
$ WORK( LDWRKX*NB+NB+1 ), LDWRKY, ONE,
$ A( I+NB, I+NB ), LDA )
CALL SGEMM( 'No transpose', 'No transpose', M-I-NB+1, N-I-NB+1,
$ NB, -ONE, WORK( NB+1 ), LDWRKX, A( I, I+NB ), LDA,
$ ONE, A( I+NB, I+NB ), LDA )
*
* Copy diagonal and off-diagonal elements of B back into A
*
IF( M.GE.N ) THEN
DO 10 J = I, I + NB - 1
A( J, J ) = D( J )
A( J, J+1 ) = E( J )
10 CONTINUE
ELSE
DO 20 J = I, I + NB - 1
A( J, J ) = D( J )
A( J+1, J ) = E( J )
20 CONTINUE
END IF
30 CONTINUE
*
* Use unblocked code to reduce the remainder of the matrix
*
CALL SGEBD2( M-I+1, N-I+1, A( I, I ), LDA, D( I ), E( I ),
$ TAUQ( I ), TAUP( I ), WORK, IINFO )
WORK( 1 ) = WS
RETURN
*
* End of SGEBRD
*
END
SUBROUTINE SGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER INFO, LDA, N
REAL ANORM, RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL A( LDA, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGECON estimates the reciprocal of the condition number of a general
* real matrix A, in either the 1-norm or the infinity-norm, using
* the LU factorization computed by SGETRF.
*
* An estimate is obtained for norm(inv(A)), and the reciprocal of the
* condition number is computed as
* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies whether the 1-norm condition number or the
* infinity-norm condition number is required:
* = '1' or 'O': 1-norm;
* = 'I': Infinity-norm.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The factors L and U from the factorization A = P*L*U
* as computed by SGETRF.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* ANORM (input) REAL
* If NORM = '1' or 'O', the 1-norm of the original matrix A.
* If NORM = 'I', the infinity-norm of the original matrix A.
*
* RCOND (output) REAL
* The reciprocal of the condition number of the matrix A,
* computed as RCOND = 1/(norm(A) * norm(inv(A))).
*
* WORK (workspace) REAL array, dimension (4*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL ONENRM
CHARACTER NORMIN
INTEGER IX, KASE, KASE1
REAL AINVNM, SCALE, SL, SMLNUM, SU
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SLAMCH
EXTERNAL LSAME, ISAMAX, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SLACN2, SLATRS, SRSCL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( ANORM.LT.ZERO ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGECON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
RCOND = ZERO
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
ELSE IF( ANORM.EQ.ZERO ) THEN
RETURN
END IF
*
SMLNUM = SLAMCH( 'Safe minimum' )
*
* Estimate the norm of inv(A).
*
AINVNM = ZERO
NORMIN = 'N'
IF( ONENRM ) THEN
KASE1 = 1
ELSE
KASE1 = 2
END IF
KASE = 0
10 CONTINUE
CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.KASE1 ) THEN
*
* Multiply by inv(L).
*
CALL SLATRS( 'Lower', 'No transpose', 'Unit', NORMIN, N, A,
$ LDA, WORK, SL, WORK( 2*N+1 ), INFO )
*
* Multiply by inv(U).
*
CALL SLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
$ A, LDA, WORK, SU, WORK( 3*N+1 ), INFO )
ELSE
*
* Multiply by inv(U').
*
CALL SLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, A,
$ LDA, WORK, SU, WORK( 3*N+1 ), INFO )
*
* Multiply by inv(L').
*
CALL SLATRS( 'Lower', 'Transpose', 'Unit', NORMIN, N, A,
$ LDA, WORK, SL, WORK( 2*N+1 ), INFO )
END IF
*
* Divide X by 1/(SL*SU) if doing so will not cause overflow.
*
SCALE = SL*SU
NORMIN = 'Y'
IF( SCALE.NE.ONE ) THEN
IX = ISAMAX( N, WORK, 1 )
IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
$ GO TO 20
CALL SRSCL( N, SCALE, WORK, 1 )
END IF
GO TO 10
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / AINVNM ) / ANORM
*
20 CONTINUE
RETURN
*
* End of SGECON
*
END
SUBROUTINE SGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, M, N
REAL AMAX, COLCND, ROWCND
* ..
* .. Array Arguments ..
REAL A( LDA, * ), C( * ), R( * )
* ..
*
* Purpose
* =======
*
* SGEEQU computes row and column scalings intended to equilibrate an
* M-by-N matrix A and reduce its condition number. R returns the row
* scale factors and C the column scale factors, chosen to try to make
* the largest element in each row and column of the matrix B with
* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
*
* R(i) and C(j) are restricted to be between SMLNUM = smallest safe
* number and BIGNUM = largest safe number. Use of these scaling
* factors is not guaranteed to reduce the condition number of A but
* works well in practice.
*
* 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) REAL array, dimension (LDA,N)
* The M-by-N matrix whose equilibration factors are
* to be computed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* R (output) REAL array, dimension (M)
* If INFO = 0 or INFO > M, R contains the row scale factors
* for A.
*
* C (output) REAL array, dimension (N)
* If INFO = 0, C contains the column scale factors for A.
*
* ROWCND (output) REAL
* If INFO = 0 or INFO > M, ROWCND contains the ratio of the
* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and
* AMAX is neither too large nor too small, it is not worth
* scaling by R.
*
* COLCND (output) REAL
* If INFO = 0, COLCND contains the ratio of the smallest
* C(i) to the largest C(i). If COLCND >= 0.1, it is not
* worth scaling by C.
*
* AMAX (output) REAL
* Absolute value of largest matrix element. If AMAX is very
* close to overflow or very close to underflow, the matrix
* should be scaled.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, and i is
* <= M: the i-th row of A is exactly zero
* > M: the (i-M)-th column of A is exactly zero
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
REAL BIGNUM, RCMAX, RCMIN, SMLNUM
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, 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( 'SGEEQU', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
ROWCND = ONE
COLCND = ONE
AMAX = ZERO
RETURN
END IF
*
* Get machine constants.
*
SMLNUM = SLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
*
* Compute row scale factors.
*
DO 10 I = 1, M
R( I ) = ZERO
10 CONTINUE
*
* Find the maximum element in each row.
*
DO 30 J = 1, N
DO 20 I = 1, M
R( I ) = MAX( R( I ), ABS( A( I, J ) ) )
20 CONTINUE
30 CONTINUE
*
* Find the maximum and minimum scale factors.
*
RCMIN = BIGNUM
RCMAX = ZERO
DO 40 I = 1, M
RCMAX = MAX( RCMAX, R( I ) )
RCMIN = MIN( RCMIN, R( I ) )
40 CONTINUE
AMAX = RCMAX
*
IF( RCMIN.EQ.ZERO ) THEN
*
* Find the first zero scale factor and return an error code.
*
DO 50 I = 1, M
IF( R( I ).EQ.ZERO ) THEN
INFO = I
RETURN
END IF
50 CONTINUE
ELSE
*
* Invert the scale factors.
*
DO 60 I = 1, M
R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM )
60 CONTINUE
*
* Compute ROWCND = min(R(I)) / max(R(I))
*
ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
END IF
*
* Compute column scale factors
*
DO 70 J = 1, N
C( J ) = ZERO
70 CONTINUE
*
* Find the maximum element in each column,
* assuming the row scaling computed above.
*
DO 90 J = 1, N
DO 80 I = 1, M
C( J ) = MAX( C( J ), ABS( A( I, J ) )*R( I ) )
80 CONTINUE
90 CONTINUE
*
* Find the maximum and minimum scale factors.
*
RCMIN = BIGNUM
RCMAX = ZERO
DO 100 J = 1, N
RCMIN = MIN( RCMIN, C( J ) )
RCMAX = MAX( RCMAX, C( J ) )
100 CONTINUE
*
IF( RCMIN.EQ.ZERO ) THEN
*
* Find the first zero scale factor and return an error code.
*
DO 110 J = 1, N
IF( C( J ).EQ.ZERO ) THEN
INFO = M + J
RETURN
END IF
110 CONTINUE
ELSE
*
* Invert the scale factors.
*
DO 120 J = 1, N
C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM )
120 CONTINUE
*
* Compute COLCND = min(C(J)) / max(C(J))
*
COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
END IF
*
RETURN
*
* End of SGEEQU
*
END
SUBROUTINE SGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI,
$ VS, LDVS, WORK, LWORK, BWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBVS, SORT
INTEGER INFO, LDA, LDVS, LWORK, N, SDIM
* ..
* .. Array Arguments ..
LOGICAL BWORK( * )
REAL A( LDA, * ), VS( LDVS, * ), WI( * ), WORK( * ),
$ WR( * )
* ..
* .. Function Arguments ..
LOGICAL SELECT
EXTERNAL SELECT
* ..
*
* Purpose
* =======
*
* SGEES computes for an N-by-N real nonsymmetric matrix A, the
* eigenvalues, the real Schur form T, and, optionally, the matrix of
* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).
*
* Optionally, it also orders the eigenvalues on the diagonal of the
* real Schur form so that selected eigenvalues are at the top left.
* The leading columns of Z then form an orthonormal basis for the
* invariant subspace corresponding to the selected eigenvalues.
*
* A matrix is in real Schur form if it is upper quasi-triangular with
* 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the
* form
* [ a b ]
* [ c a ]
*
* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
*
* Arguments
* =========
*
* JOBVS (input) CHARACTER*1
* = 'N': Schur vectors are not computed;
* = 'V': Schur vectors are computed.
*
* SORT (input) CHARACTER*1
* Specifies whether or not to order the eigenvalues on the
* diagonal of the Schur form.
* = 'N': Eigenvalues are not ordered;
* = 'S': Eigenvalues are ordered (see SELECT).
*
* SELECT (external procedure) LOGICAL FUNCTION of two REAL arguments
* SELECT must be declared EXTERNAL in the calling subroutine.
* If SORT = 'S', SELECT is used to select eigenvalues to sort
* to the top left of the Schur form.
* If SORT = 'N', SELECT is not referenced.
* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if
* SELECT(WR(j),WI(j)) is true; i.e., if either one of a complex
* conjugate pair of eigenvalues is selected, then both complex
* eigenvalues are selected.
* Note that a selected complex eigenvalue may no longer
* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since
* ordering may change the value of complex eigenvalues
* (especially if the eigenvalue is ill-conditioned); in this
* case INFO is set to N+2 (see INFO below).
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the N-by-N matrix A.
* On exit, A has been overwritten by its real Schur form T.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* SDIM (output) INTEGER
* If SORT = 'N', SDIM = 0.
* If SORT = 'S', SDIM = number of eigenvalues (after sorting)
* for which SELECT is true. (Complex conjugate
* pairs for which SELECT is true for either
* eigenvalue count as 2.)
*
* WR (output) REAL array, dimension (N)
* WI (output) REAL array, dimension (N)
* WR and WI contain the real and imaginary parts,
* respectively, of the computed eigenvalues in the same order
* that they appear on the diagonal of the output Schur form T.
* Complex conjugate pairs of eigenvalues will appear
* consecutively with the eigenvalue having the positive
* imaginary part first.
*
* VS (output) REAL array, dimension (LDVS,N)
* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur
* vectors.
* If JOBVS = 'N', VS is not referenced.
*
* LDVS (input) INTEGER
* The leading dimension of the array VS. LDVS >= 1; if
* JOBVS = 'V', LDVS >= N.
*
* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
* On exit, if INFO = 0, WORK(1) contains the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK. LWORK >= max(1,3*N).
* For good performance, LWORK must generally be larger.
*
* 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.
*
* BWORK (workspace) LOGICAL array, dimension (N)
* Not referenced if SORT = 'N'.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = i, and i is
* <= N: the QR algorithm failed to compute all the
* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI
* contain those eigenvalues which have converged; if
* JOBVS = 'V', VS contains the matrix which reduces A
* to its partially converged Schur form.
* = N+1: the eigenvalues could not be reordered because some
* eigenvalues were too close to separate (the problem
* is very ill-conditioned);
* = N+2: after reordering, roundoff changed values of some
* complex eigenvalues so that leading eigenvalues in
* the Schur form no longer satisfy SELECT=.TRUE. This
* could also be caused by underflow due to scaling.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL CURSL, LASTSL, LQUERY, LST2SL, SCALEA, WANTST,
$ WANTVS
INTEGER HSWORK, I, I1, I2, IBAL, ICOND, IERR, IEVAL,
$ IHI, ILO, INXT, IP, ITAU, IWRK, MAXWRK, MINWRK
REAL ANRM, BIGNUM, CSCALE, EPS, S, SEP, SMLNUM
* ..
* .. Local Arrays ..
INTEGER IDUM( 1 )
REAL DUM( 1 )
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEBAK, SGEBAL, SGEHRD, SHSEQR, SLABAD,
$ SLACPY, SLASCL, SORGHR, SSWAP, STRSEN, XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
REAL SLAMCH, SLANGE
EXTERNAL LSAME, ILAENV, SLAMCH, SLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
WANTVS = LSAME( JOBVS, 'V' )
WANTST = LSAME( SORT, 'S' )
IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN
INFO = -1
ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDVS.LT.1 .OR. ( WANTVS .AND. LDVS.LT.N ) ) THEN
INFO = -11
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.
* HSWORK refers to the workspace preferred by SHSEQR, as
* calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
* the worst case.)
*
IF( INFO.EQ.0 ) THEN
IF( N.EQ.0 ) THEN
MINWRK = 1
MAXWRK = 1
ELSE
MAXWRK = 2*N + N*ILAENV( 1, 'SGEHRD', ' ', N, 1, N, 0 )
MINWRK = 3*N
*
CALL SHSEQR( 'S', JOBVS, N, 1, N, A, LDA, WR, WI, VS, LDVS,
$ WORK, -1, IEVAL )
HSWORK = WORK( 1 )
*
IF( .NOT.WANTVS ) THEN
MAXWRK = MAX( MAXWRK, N + HSWORK )
ELSE
MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1,
$ 'SORGHR', ' ', N, 1, N, -1 ) )
MAXWRK = MAX( MAXWRK, N + HSWORK )
END IF
END IF
WORK( 1 ) = MAXWRK
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGEES ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
SDIM = 0
RETURN
END IF
*
* Get machine constants
*
EPS = SLAMCH( 'P' )
SMLNUM = SLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
SMLNUM = SQRT( SMLNUM ) / EPS
BIGNUM = ONE / SMLNUM
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = SLANGE( 'M', N, N, A, LDA, DUM )
SCALEA = .FALSE.
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
SCALEA = .TRUE.
CSCALE = SMLNUM
ELSE IF( ANRM.GT.BIGNUM ) THEN
SCALEA = .TRUE.
CSCALE = BIGNUM
END IF
IF( SCALEA )
$ CALL SLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
*
* Permute the matrix to make it more nearly triangular
* (Workspace: need N)
*
IBAL = 1
CALL SGEBAL( 'P', N, A, LDA, ILO, IHI, WORK( IBAL ), IERR )
*
* Reduce to upper Hessenberg form
* (Workspace: need 3*N, prefer 2*N+N*NB)
*
ITAU = N + IBAL
IWRK = N + ITAU
CALL SGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
$ LWORK-IWRK+1, IERR )
*
IF( WANTVS ) THEN
*
* Copy Householder vectors to VS
*
CALL SLACPY( 'L', N, N, A, LDA, VS, LDVS )
*
* Generate orthogonal matrix in VS
* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB)
*
CALL SORGHR( N, ILO, IHI, VS, LDVS, WORK( ITAU ), WORK( IWRK ),
$ LWORK-IWRK+1, IERR )
END IF
*
SDIM = 0
*
* Perform QR iteration, accumulating Schur vectors in VS if desired
* (Workspace: need N+1, prefer N+HSWORK (see comments) )
*
IWRK = ITAU
CALL SHSEQR( 'S', JOBVS, N, ILO, IHI, A, LDA, WR, WI, VS, LDVS,
$ WORK( IWRK ), LWORK-IWRK+1, IEVAL )
IF( IEVAL.GT.0 )
$ INFO = IEVAL
*
* Sort eigenvalues if desired
*
IF( WANTST .AND. INFO.EQ.0 ) THEN
IF( SCALEA ) THEN
CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WR, N, IERR )
CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WI, N, IERR )
END IF
DO 10 I = 1, N
BWORK( I ) = SELECT( WR( I ), WI( I ) )
10 CONTINUE
*
* Reorder eigenvalues and transform Schur vectors
* (Workspace: none needed)
*
CALL STRSEN( 'N', JOBVS, BWORK, N, A, LDA, VS, LDVS, WR, WI,
$ SDIM, S, SEP, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1,
$ ICOND )
IF( ICOND.GT.0 )
$ INFO = N + ICOND
END IF
*
IF( WANTVS ) THEN
*
* Undo balancing
* (Workspace: need N)
*
CALL SGEBAK( 'P', 'R', N, ILO, IHI, WORK( IBAL ), N, VS, LDVS,
$ IERR )
END IF
*
IF( SCALEA ) THEN
*
* Undo scaling for the Schur form of A
*
CALL SLASCL( 'H', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR )
CALL SCOPY( N, A, LDA+1, WR, 1 )
IF( CSCALE.EQ.SMLNUM ) THEN
*
* If scaling back towards underflow, adjust WI if an
* offdiagonal element of a 2-by-2 block in the Schur form
* underflows.
*
IF( IEVAL.GT.0 ) THEN
I1 = IEVAL + 1
I2 = IHI - 1
CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI,
$ MAX( ILO-1, 1 ), IERR )
ELSE IF( WANTST ) THEN
I1 = 1
I2 = N - 1
ELSE
I1 = ILO
I2 = IHI - 1
END IF
INXT = I1 - 1
DO 20 I = I1, I2
IF( I.LT.INXT )
$ GO TO 20
IF( WI( I ).EQ.ZERO ) THEN
INXT = I + 1
ELSE
IF( A( I+1, I ).EQ.ZERO ) THEN
WI( I ) = ZERO
WI( I+1 ) = ZERO
ELSE IF( A( I+1, I ).NE.ZERO .AND. A( I, I+1 ).EQ.
$ ZERO ) THEN
WI( I ) = ZERO
WI( I+1 ) = ZERO
IF( I.GT.1 )
$ CALL SSWAP( I-1, A( 1, I ), 1, A( 1, I+1 ), 1 )
IF( N.GT.I+1 )
$ CALL SSWAP( N-I-1, A( I, I+2 ), LDA,
$ A( I+1, I+2 ), LDA )
IF( WANTVS ) THEN
CALL SSWAP( N, VS( 1, I ), 1, VS( 1, I+1 ), 1 )
END IF
A( I, I+1 ) = A( I+1, I )
A( I+1, I ) = ZERO
END IF
INXT = I + 2
END IF
20 CONTINUE
END IF
*
* Undo scaling for the imaginary part of the eigenvalues
*
CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N-IEVAL, 1,
$ WI( IEVAL+1 ), MAX( N-IEVAL, 1 ), IERR )
END IF
*
IF( WANTST .AND. INFO.EQ.0 ) THEN
*
* Check if reordering successful
*
LASTSL = .TRUE.
LST2SL = .TRUE.
SDIM = 0
IP = 0
DO 30 I = 1, N
CURSL = SELECT( WR( I ), WI( I ) )
IF( WI( I ).EQ.ZERO ) THEN
IF( CURSL )
$ SDIM = SDIM + 1
IP = 0
IF( CURSL .AND. .NOT.LASTSL )
$ INFO = N + 2
ELSE
IF( IP.EQ.1 ) THEN
*
* Last eigenvalue of conjugate pair
*
CURSL = CURSL .OR. LASTSL
LASTSL = CURSL
IF( CURSL )
$ SDIM = SDIM + 2
IP = -1
IF( CURSL .AND. .NOT.LST2SL )
$ INFO = N + 2
ELSE
*
* First eigenvalue of conjugate pair
*
IP = 1
END IF
END IF
LST2SL = LASTSL
LASTSL = CURSL
30 CONTINUE
END IF
*
WORK( 1 ) = MAXWRK
RETURN
*
* End of SGEES
*
END
SUBROUTINE SGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM,
$ WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK,
$ IWORK, LIWORK, BWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBVS, SENSE, SORT
INTEGER INFO, LDA, LDVS, LIWORK, LWORK, N, SDIM
REAL RCONDE, RCONDV
* ..
* .. Array Arguments ..
LOGICAL BWORK( * )
INTEGER IWORK( * )
REAL A( LDA, * ), VS( LDVS, * ), WI( * ), WORK( * ),
$ WR( * )
* ..
* .. Function Arguments ..
LOGICAL SELECT
EXTERNAL SELECT
* ..
*
* Purpose
* =======
*
* SGEESX computes for an N-by-N real nonsymmetric matrix A, the
* eigenvalues, the real Schur form T, and, optionally, the matrix of
* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).
*
* Optionally, it also orders the eigenvalues on the diagonal of the
* real Schur form so that selected eigenvalues are at the top left;
* computes a reciprocal condition number for the average of the
* selected eigenvalues (RCONDE); and computes a reciprocal condition
* number for the right invariant subspace corresponding to the
* selected eigenvalues (RCONDV). The leading columns of Z form an
* orthonormal basis for this invariant subspace.
*
* For further explanation of the reciprocal condition numbers RCONDE
* and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where
* these quantities are called s and sep respectively).
*
* A real matrix is in real Schur form if it is upper quasi-triangular
* with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in
* the form
* [ a b ]
* [ c a ]
*
* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
*
* Arguments
* =========
*
* JOBVS (input) CHARACTER*1
* = 'N': Schur vectors are not computed;
* = 'V': Schur vectors are computed.
*
* SORT (input) CHARACTER*1
* Specifies whether or not to order the eigenvalues on the
* diagonal of the Schur form.
* = 'N': Eigenvalues are not ordered;
* = 'S': Eigenvalues are ordered (see SELECT).
*
* SELECT (external procedure) LOGICAL FUNCTION of two REAL arguments
* SELECT must be declared EXTERNAL in the calling subroutine.
* If SORT = 'S', SELECT is used to select eigenvalues to sort
* to the top left of the Schur form.
* If SORT = 'N', SELECT is not referenced.
* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if
* SELECT(WR(j),WI(j)) is true; i.e., if either one of a
* complex conjugate pair of eigenvalues is selected, then both
* are. Note that a selected complex eigenvalue may no longer
* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since
* ordering may change the value of complex eigenvalues
* (especially if the eigenvalue is ill-conditioned); in this
* case INFO may be set to N+3 (see INFO below).
*
* SENSE (input) CHARACTER*1
* Determines which reciprocal condition numbers are computed.
* = 'N': None are computed;
* = 'E': Computed for average of selected eigenvalues only;
* = 'V': Computed for selected right invariant subspace only;
* = 'B': Computed for both.
* If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) REAL array, dimension (LDA, N)
* On entry, the N-by-N matrix A.
* On exit, A is overwritten by its real Schur form T.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* SDIM (output) INTEGER
* If SORT = 'N', SDIM = 0.
* If SORT = 'S', SDIM = number of eigenvalues (after sorting)
* for which SELECT is true. (Complex conjugate
* pairs for which SELECT is true for either
* eigenvalue count as 2.)
*
* WR (output) REAL array, dimension (N)
* WI (output) REAL array, dimension (N)
* WR and WI contain the real and imaginary parts, respectively,
* of the computed eigenvalues, in the same order that they
* appear on the diagonal of the output Schur form T. Complex
* conjugate pairs of eigenvalues appear consecutively with the
* eigenvalue having the positive imaginary part first.
*
* VS (output) REAL array, dimension (LDVS,N)
* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur
* vectors.
* If JOBVS = 'N', VS is not referenced.
*
* LDVS (input) INTEGER
* The leading dimension of the array VS. LDVS >= 1, and if
* JOBVS = 'V', LDVS >= N.
*
* RCONDE (output) REAL
* If SENSE = 'E' or 'B', RCONDE contains the reciprocal
* condition number for the average of the selected eigenvalues.
* Not referenced if SENSE = 'N' or 'V'.
*
* RCONDV (output) REAL
* If SENSE = 'V' or 'B', RCONDV contains the reciprocal
* condition number for the selected right invariant subspace.
* Not referenced if SENSE = 'N' or 'E'.
*
* WORK (workspace/output) REAL 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,3*N).
* Also, if SENSE = 'E' or 'V' or 'B',
* LWORK >= N+2*SDIM*(N-SDIM), where SDIM is the number of
* selected eigenvalues computed by this routine. Note that
* N+2*SDIM*(N-SDIM) <= N+N*N/2. Note also that an error is only
* returned if LWORK < max(1,3*N), but if SENSE = 'E' or 'V' or
* 'B' this may not be large enough.
* For good performance, LWORK must generally be larger.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates upper bounds on the optimal sizes of the
* arrays WORK and IWORK, returns these values as the first
* entries of the WORK and IWORK arrays, and no error messages
* related to LWORK or LIWORK are issued by XERBLA.
*
* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK.
* LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM).
* Note that SDIM*(N-SDIM) <= N*N/4. Note also that an error is
* only returned if LIWORK < 1, but if SENSE = 'V' or 'B' this
* may not be large enough.
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates upper bounds on the optimal sizes of
* the arrays WORK and IWORK, returns these values as the first
* entries of the WORK and IWORK arrays, and no error messages
* related to LWORK or LIWORK are issued by XERBLA.
*
* BWORK (workspace) LOGICAL array, dimension (N)
* Not referenced if SORT = 'N'.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = i, and i is
* <= N: the QR algorithm failed to compute all the
* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI
* contain those eigenvalues which have converged; if
* JOBVS = 'V', VS contains the transformation which
* reduces A to its partially converged Schur form.
* = N+1: the eigenvalues could not be reordered because some
* eigenvalues were too close to separate (the problem
* is very ill-conditioned);
* = N+2: after reordering, roundoff changed values of some
* complex eigenvalues so that leading eigenvalues in
* the Schur form no longer satisfy SELECT=.TRUE. This
* could also be caused by underflow due to scaling.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL CURSL, LASTSL, LQUERY, LST2SL, SCALEA, WANTSB,
$ WANTSE, WANTSN, WANTST, WANTSV, WANTVS
INTEGER HSWORK, I, I1, I2, IBAL, ICOND, IERR, IEVAL,
$ IHI, ILO, INXT, IP, ITAU, IWRK, LWRK, LIWRK,
$ MAXWRK, MINWRK
REAL ANRM, BIGNUM, CSCALE, EPS, SMLNUM
* ..
* .. Local Arrays ..
REAL DUM( 1 )
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEBAK, SGEBAL, SGEHRD, SHSEQR, SLABAD,
$ SLACPY, SLASCL, SORGHR, SSWAP, STRSEN, XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
REAL SLAMCH, SLANGE
EXTERNAL LSAME, ILAENV, SLAMCH, SLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
WANTVS = LSAME( JOBVS, 'V' )
WANTST = LSAME( SORT, 'S' )
WANTSN = LSAME( SENSE, 'N' )
WANTSE = LSAME( SENSE, 'E' )
WANTSV = LSAME( SENSE, 'V' )
WANTSB = LSAME( SENSE, 'B' )
LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN
INFO = -1
ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
INFO = -2
ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSV .OR. WANTSB ) .OR.
$ ( .NOT.WANTST .AND. .NOT.WANTSN ) ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDVS.LT.1 .OR. ( WANTVS .AND. LDVS.LT.N ) ) THEN
INFO = -12
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "RWorkspace:" describe the
* minimal amount of real workspace needed at that point in the
* code, as well as the preferred amount for good performance.
* IWorkspace refers to integer workspace.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.
* HSWORK refers to the workspace preferred by SHSEQR, as
* calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
* the worst case.
* If SENSE = 'E', 'V' or 'B', then the amount of workspace needed
* depends on SDIM, which is computed by the routine STRSEN later
* in the code.)
*
IF( INFO.EQ.0 ) THEN
LIWRK = 1
IF( N.EQ.0 ) THEN
MINWRK = 1
LWRK = 1
ELSE
MAXWRK = 2*N + N*ILAENV( 1, 'SGEHRD', ' ', N, 1, N, 0 )
MINWRK = 3*N
*
CALL SHSEQR( 'S', JOBVS, N, 1, N, A, LDA, WR, WI, VS, LDVS,
$ WORK, -1, IEVAL )
HSWORK = WORK( 1 )
*
IF( .NOT.WANTVS ) THEN
MAXWRK = MAX( MAXWRK, N + HSWORK )
ELSE
MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1,
$ 'SORGHR', ' ', N, 1, N, -1 ) )
MAXWRK = MAX( MAXWRK, N + HSWORK )
END IF
LWRK = MAXWRK
IF( .NOT.WANTSN )
$ LWRK = MAX( LWRK, N + ( N*N )/2 )
IF( WANTSV .OR. WANTSB )
$ LIWRK = ( N*N )/4
END IF
IWORK( 1 ) = LIWRK
WORK( 1 ) = LWRK
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
INFO = -16
ELSE IF( LIWORK.LT.1 .AND. .NOT.LQUERY ) THEN
INFO = -18
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGEESX', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
SDIM = 0
RETURN
END IF
*
* Get machine constants
*
EPS = SLAMCH( 'P' )
SMLNUM = SLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
SMLNUM = SQRT( SMLNUM ) / EPS
BIGNUM = ONE / SMLNUM
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = SLANGE( 'M', N, N, A, LDA, DUM )
SCALEA = .FALSE.
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
SCALEA = .TRUE.
CSCALE = SMLNUM
ELSE IF( ANRM.GT.BIGNUM ) THEN
SCALEA = .TRUE.
CSCALE = BIGNUM
END IF
IF( SCALEA )
$ CALL SLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
*
* Permute the matrix to make it more nearly triangular
* (RWorkspace: need N)
*
IBAL = 1
CALL SGEBAL( 'P', N, A, LDA, ILO, IHI, WORK( IBAL ), IERR )
*
* Reduce to upper Hessenberg form
* (RWorkspace: need 3*N, prefer 2*N+N*NB)
*
ITAU = N + IBAL
IWRK = N + ITAU
CALL SGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
$ LWORK-IWRK+1, IERR )
*
IF( WANTVS ) THEN
*
* Copy Householder vectors to VS
*
CALL SLACPY( 'L', N, N, A, LDA, VS, LDVS )
*
* Generate orthogonal matrix in VS
* (RWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
*
CALL SORGHR( N, ILO, IHI, VS, LDVS, WORK( ITAU ), WORK( IWRK ),
$ LWORK-IWRK+1, IERR )
END IF
*
SDIM = 0
*
* Perform QR iteration, accumulating Schur vectors in VS if desired
* (RWorkspace: need N+1, prefer N+HSWORK (see comments) )
*
IWRK = ITAU
CALL SHSEQR( 'S', JOBVS, N, ILO, IHI, A, LDA, WR, WI, VS, LDVS,
$ WORK( IWRK ), LWORK-IWRK+1, IEVAL )
IF( IEVAL.GT.0 )
$ INFO = IEVAL
*
* Sort eigenvalues if desired
*
IF( WANTST .AND. INFO.EQ.0 ) THEN
IF( SCALEA ) THEN
CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WR, N, IERR )
CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WI, N, IERR )
END IF
DO 10 I = 1, N
BWORK( I ) = SELECT( WR( I ), WI( I ) )
10 CONTINUE
*
* Reorder eigenvalues, transform Schur vectors, and compute
* reciprocal condition numbers
* (RWorkspace: if SENSE is not 'N', need N+2*SDIM*(N-SDIM)
* otherwise, need N )
* (IWorkspace: if SENSE is 'V' or 'B', need SDIM*(N-SDIM)
* otherwise, need 0 )
*
CALL STRSEN( SENSE, JOBVS, BWORK, N, A, LDA, VS, LDVS, WR, WI,
$ SDIM, RCONDE, RCONDV, WORK( IWRK ), LWORK-IWRK+1,
$ IWORK, LIWORK, ICOND )
IF( .NOT.WANTSN )
$ MAXWRK = MAX( MAXWRK, N+2*SDIM*( N-SDIM ) )
IF( ICOND.EQ.-15 ) THEN
*
* Not enough real workspace
*
INFO = -16
ELSE IF( ICOND.EQ.-17 ) THEN
*
* Not enough integer workspace
*
INFO = -18
ELSE IF( ICOND.GT.0 ) THEN
*
* STRSEN failed to reorder or to restore standard Schur form
*
INFO = ICOND + N
END IF
END IF
*
IF( WANTVS ) THEN
*
* Undo balancing
* (RWorkspace: need N)
*
CALL SGEBAK( 'P', 'R', N, ILO, IHI, WORK( IBAL ), N, VS, LDVS,
$ IERR )
END IF
*
IF( SCALEA ) THEN
*
* Undo scaling for the Schur form of A
*
CALL SLASCL( 'H', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR )
CALL SCOPY( N, A, LDA+1, WR, 1 )
IF( ( WANTSV .OR. WANTSB ) .AND. INFO.EQ.0 ) THEN
DUM( 1 ) = RCONDV
CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, 1, 1, DUM, 1, IERR )
RCONDV = DUM( 1 )
END IF
IF( CSCALE.EQ.SMLNUM ) THEN
*
* If scaling back towards underflow, adjust WI if an
* offdiagonal element of a 2-by-2 block in the Schur form
* underflows.
*
IF( IEVAL.GT.0 ) THEN
I1 = IEVAL + 1
I2 = IHI - 1
CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N,
$ IERR )
ELSE IF( WANTST ) THEN
I1 = 1
I2 = N - 1
ELSE
I1 = ILO
I2 = IHI - 1
END IF
INXT = I1 - 1
DO 20 I = I1, I2
IF( I.LT.INXT )
$ GO TO 20
IF( WI( I ).EQ.ZERO ) THEN
INXT = I + 1
ELSE
IF( A( I+1, I ).EQ.ZERO ) THEN
WI( I ) = ZERO
WI( I+1 ) = ZERO
ELSE IF( A( I+1, I ).NE.ZERO .AND. A( I, I+1 ).EQ.
$ ZERO ) THEN
WI( I ) = ZERO
WI( I+1 ) = ZERO
IF( I.GT.1 )
$ CALL SSWAP( I-1, A( 1, I ), 1, A( 1, I+1 ), 1 )
IF( N.GT.I+1 )
$ CALL SSWAP( N-I-1, A( I, I+2 ), LDA,
$ A( I+1, I+2 ), LDA )
CALL SSWAP( N, VS( 1, I ), 1, VS( 1, I+1 ), 1 )
A( I, I+1 ) = A( I+1, I )
A( I+1, I ) = ZERO
END IF
INXT = I + 2
END IF
20 CONTINUE
END IF
CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N-IEVAL, 1,
$ WI( IEVAL+1 ), MAX( N-IEVAL, 1 ), IERR )
END IF
*
IF( WANTST .AND. INFO.EQ.0 ) THEN
*
* Check if reordering successful
*
LASTSL = .TRUE.
LST2SL = .TRUE.
SDIM = 0
IP = 0
DO 30 I = 1, N
CURSL = SELECT( WR( I ), WI( I ) )
IF( WI( I ).EQ.ZERO ) THEN
IF( CURSL )
$ SDIM = SDIM + 1
IP = 0
IF( CURSL .AND. .NOT.LASTSL )
$ INFO = N + 2
ELSE
IF( IP.EQ.1 ) THEN
*
* Last eigenvalue of conjugate pair
*
CURSL = CURSL .OR. LASTSL
LASTSL = CURSL
IF( CURSL )
$ SDIM = SDIM + 2
IP = -1
IF( CURSL .AND. .NOT.LST2SL )
$ INFO = N + 2
ELSE
*
* First eigenvalue of conjugate pair
*
IP = 1
END IF
END IF
LST2SL = LASTSL
LASTSL = CURSL
30 CONTINUE
END IF
*
WORK( 1 ) = MAXWRK
IF( WANTSV .OR. WANTSB ) THEN
IWORK( 1 ) = SDIM*(N-SDIM)
ELSE
IWORK( 1 ) = 1
END IF
*
RETURN
*
* End of SGEESX
*
END
SUBROUTINE SGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR,
$ LDVR, WORK, LWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBVL, JOBVR
INTEGER INFO, LDA, LDVL, LDVR, LWORK, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ),
$ WI( * ), WORK( * ), WR( * )
* ..
*
* Purpose
* =======
*
* SGEEV computes for an N-by-N real nonsymmetric matrix A, the
* eigenvalues and, optionally, the left and/or right eigenvectors.
*
* The right eigenvector v(j) of A satisfies
* A * v(j) = lambda(j) * v(j)
* where lambda(j) is its eigenvalue.
* The left eigenvector u(j) of A satisfies
* u(j)**H * A = lambda(j) * u(j)**H
* where u(j)**H denotes the conjugate transpose of u(j).
*
* The computed eigenvectors are normalized to have Euclidean norm
* equal to 1 and largest component real.
*
* Arguments
* =========
*
* JOBVL (input) CHARACTER*1
* = 'N': left eigenvectors of A are not computed;
* = 'V': left eigenvectors of A are computed.
*
* JOBVR (input) CHARACTER*1
* = 'N': right eigenvectors of A are not computed;
* = 'V': right eigenvectors of A are computed.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the N-by-N matrix A.
* On exit, A has been overwritten.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* WR (output) REAL array, dimension (N)
* WI (output) REAL array, dimension (N)
* WR and WI contain the real and imaginary parts,
* respectively, of the computed eigenvalues. Complex
* conjugate pairs of eigenvalues appear consecutively
* with the eigenvalue having the positive imaginary part
* first.
*
* VL (output) REAL array, dimension (LDVL,N)
* If JOBVL = 'V', the left eigenvectors u(j) are stored one
* after another in the columns of VL, in the same order
* as their eigenvalues.
* If JOBVL = 'N', VL is not referenced.
* If the j-th eigenvalue is real, then u(j) = VL(:,j),
* the j-th column of VL.
* If the j-th and (j+1)-st eigenvalues form a complex
* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and
* u(j+1) = VL(:,j) - i*VL(:,j+1).
*
* LDVL (input) INTEGER
* The leading dimension of the array VL. LDVL >= 1; if
* JOBVL = 'V', LDVL >= N.
*
* VR (output) REAL array, dimension (LDVR,N)
* If JOBVR = 'V', the right eigenvectors v(j) are stored one
* after another in the columns of VR, in the same order
* as their eigenvalues.
* If JOBVR = 'N', VR is not referenced.
* If the j-th eigenvalue is real, then v(j) = VR(:,j),
* the j-th column of VR.
* If the j-th and (j+1)-st eigenvalues form a complex
* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and
* v(j+1) = VR(:,j) - i*VR(:,j+1).
*
* LDVR (input) INTEGER
* The leading dimension of the array VR. LDVR >= 1; if
* JOBVR = 'V', LDVR >= N.
*
* WORK (workspace/output) REAL 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,3*N), and
* if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good
* performance, LWORK must generally be larger.
*
* 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.
* > 0: if INFO = i, the QR algorithm failed to compute all the
* eigenvalues, and no eigenvectors have been computed;
* elements i+1:N of WR and WI contain eigenvalues which
* have converged.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, SCALEA, WANTVL, WANTVR
CHARACTER SIDE
INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, ITAU, IWRK, K,
$ MAXWRK, MINWRK, NOUT
REAL ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM,
$ SN
* ..
* .. Local Arrays ..
LOGICAL SELECT( 1 )
REAL DUM( 1 )
* ..
* .. External Subroutines ..
EXTERNAL SGEBAK, SGEBAL, SGEHRD, SHSEQR, SLABAD, SLACPY,
$ SLARTG, SLASCL, SORGHR, SROT, SSCAL, STREVC,
$ XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV, ISAMAX
REAL SLAMCH, SLANGE, SLAPY2, SNRM2
EXTERNAL LSAME, ILAENV, ISAMAX, SLAMCH, SLANGE, SLAPY2,
$ SNRM2
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
WANTVL = LSAME( JOBVL, 'V' )
WANTVR = LSAME( JOBVR, 'V' )
IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN
INFO = -1
ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN
INFO = -9
ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN
INFO = -11
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.
* HSWORK refers to the workspace preferred by SHSEQR, as
* calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
* the worst case.)
*
IF( INFO.EQ.0 ) THEN
IF( N.EQ.0 ) THEN
MINWRK = 1
MAXWRK = 1
ELSE
MAXWRK = 2*N + N*ILAENV( 1, 'SGEHRD', ' ', N, 1, N, 0 )
IF( WANTVL ) THEN
MINWRK = 4*N
MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1,
$ 'SORGHR', ' ', N, 1, N, -1 ) )
CALL SHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VL, LDVL,
$ WORK, -1, INFO )
HSWORK = WORK( 1 )
MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK )
MAXWRK = MAX( MAXWRK, 4*N )
ELSE IF( WANTVR ) THEN
MINWRK = 4*N
MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1,
$ 'SORGHR', ' ', N, 1, N, -1 ) )
CALL SHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VR, LDVR,
$ WORK, -1, INFO )
HSWORK = WORK( 1 )
MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK )
MAXWRK = MAX( MAXWRK, 4*N )
ELSE
MINWRK = 3*N
CALL SHSEQR( 'E', 'N', N, 1, N, A, LDA, WR, WI, VR, LDVR,
$ WORK, -1, INFO )
HSWORK = WORK( 1 )
MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK )
END IF
MAXWRK = MAX( MAXWRK, MINWRK )
END IF
WORK( 1 ) = MAXWRK
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGEEV ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Get machine constants
*
EPS = SLAMCH( 'P' )
SMLNUM = SLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
SMLNUM = SQRT( SMLNUM ) / EPS
BIGNUM = ONE / SMLNUM
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = SLANGE( 'M', N, N, A, LDA, DUM )
SCALEA = .FALSE.
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
SCALEA = .TRUE.
CSCALE = SMLNUM
ELSE IF( ANRM.GT.BIGNUM ) THEN
SCALEA = .TRUE.
CSCALE = BIGNUM
END IF
IF( SCALEA )
$ CALL SLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
*
* Balance the matrix
* (Workspace: need N)
*
IBAL = 1
CALL SGEBAL( 'B', N, A, LDA, ILO, IHI, WORK( IBAL ), IERR )
*
* Reduce to upper Hessenberg form
* (Workspace: need 3*N, prefer 2*N+N*NB)
*
ITAU = IBAL + N
IWRK = ITAU + N
CALL SGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
$ LWORK-IWRK+1, IERR )
*
IF( WANTVL ) THEN
*
* Want left eigenvectors
* Copy Householder vectors to VL
*
SIDE = 'L'
CALL SLACPY( 'L', N, N, A, LDA, VL, LDVL )
*
* Generate orthogonal matrix in VL
* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB)
*
CALL SORGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ),
$ LWORK-IWRK+1, IERR )
*
* Perform QR iteration, accumulating Schur vectors in VL
* (Workspace: need N+1, prefer N+HSWORK (see comments) )
*
IWRK = ITAU
CALL SHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VL, LDVL,
$ WORK( IWRK ), LWORK-IWRK+1, INFO )
*
IF( WANTVR ) THEN
*
* Want left and right eigenvectors
* Copy Schur vectors to VR
*
SIDE = 'B'
CALL SLACPY( 'F', N, N, VL, LDVL, VR, LDVR )
END IF
*
ELSE IF( WANTVR ) THEN
*
* Want right eigenvectors
* Copy Householder vectors to VR
*
SIDE = 'R'
CALL SLACPY( 'L', N, N, A, LDA, VR, LDVR )
*
* Generate orthogonal matrix in VR
* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB)
*
CALL SORGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ),
$ LWORK-IWRK+1, IERR )
*
* Perform QR iteration, accumulating Schur vectors in VR
* (Workspace: need N+1, prefer N+HSWORK (see comments) )
*
IWRK = ITAU
CALL SHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR,
$ WORK( IWRK ), LWORK-IWRK+1, INFO )
*
ELSE
*
* Compute eigenvalues only
* (Workspace: need N+1, prefer N+HSWORK (see comments) )
*
IWRK = ITAU
CALL SHSEQR( 'E', 'N', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR,
$ WORK( IWRK ), LWORK-IWRK+1, INFO )
END IF
*
* If INFO > 0 from SHSEQR, then quit
*
IF( INFO.GT.0 )
$ GO TO 50
*
IF( WANTVL .OR. WANTVR ) THEN
*
* Compute left and/or right eigenvectors
* (Workspace: need 4*N)
*
CALL STREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
$ N, NOUT, WORK( IWRK ), IERR )
END IF
*
IF( WANTVL ) THEN
*
* Undo balancing of left eigenvectors
* (Workspace: need N)
*
CALL SGEBAK( 'B', 'L', N, ILO, IHI, WORK( IBAL ), N, VL, LDVL,
$ IERR )
*
* Normalize left eigenvectors and make largest component real
*
DO 20 I = 1, N
IF( WI( I ).EQ.ZERO ) THEN
SCL = ONE / SNRM2( N, VL( 1, I ), 1 )
CALL SSCAL( N, SCL, VL( 1, I ), 1 )
ELSE IF( WI( I ).GT.ZERO ) THEN
SCL = ONE / SLAPY2( SNRM2( N, VL( 1, I ), 1 ),
$ SNRM2( N, VL( 1, I+1 ), 1 ) )
CALL SSCAL( N, SCL, VL( 1, I ), 1 )
CALL SSCAL( N, SCL, VL( 1, I+1 ), 1 )
DO 10 K = 1, N
WORK( IWRK+K-1 ) = VL( K, I )**2 + VL( K, I+1 )**2
10 CONTINUE
K = ISAMAX( N, WORK( IWRK ), 1 )
CALL SLARTG( VL( K, I ), VL( K, I+1 ), CS, SN, R )
CALL SROT( N, VL( 1, I ), 1, VL( 1, I+1 ), 1, CS, SN )
VL( K, I+1 ) = ZERO
END IF
20 CONTINUE
END IF
*
IF( WANTVR ) THEN
*
* Undo balancing of right eigenvectors
* (Workspace: need N)
*
CALL SGEBAK( 'B', 'R', N, ILO, IHI, WORK( IBAL ), N, VR, LDVR,
$ IERR )
*
* Normalize right eigenvectors and make largest component real
*
DO 40 I = 1, N
IF( WI( I ).EQ.ZERO ) THEN
SCL = ONE / SNRM2( N, VR( 1, I ), 1 )
CALL SSCAL( N, SCL, VR( 1, I ), 1 )
ELSE IF( WI( I ).GT.ZERO ) THEN
SCL = ONE / SLAPY2( SNRM2( N, VR( 1, I ), 1 ),
$ SNRM2( N, VR( 1, I+1 ), 1 ) )
CALL SSCAL( N, SCL, VR( 1, I ), 1 )
CALL SSCAL( N, SCL, VR( 1, I+1 ), 1 )
DO 30 K = 1, N
WORK( IWRK+K-1 ) = VR( K, I )**2 + VR( K, I+1 )**2
30 CONTINUE
K = ISAMAX( N, WORK( IWRK ), 1 )
CALL SLARTG( VR( K, I ), VR( K, I+1 ), CS, SN, R )
CALL SROT( N, VR( 1, I ), 1, VR( 1, I+1 ), 1, CS, SN )
VR( K, I+1 ) = ZERO
END IF
40 CONTINUE
END IF
*
* Undo scaling if necessary
*
50 CONTINUE
IF( SCALEA ) THEN
CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WR( INFO+1 ),
$ MAX( N-INFO, 1 ), IERR )
CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WI( INFO+1 ),
$ MAX( N-INFO, 1 ), IERR )
IF( INFO.GT.0 ) THEN
CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WR, N,
$ IERR )
CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N,
$ IERR )
END IF
END IF
*
WORK( 1 ) = MAXWRK
RETURN
*
* End of SGEEV
*
END
SUBROUTINE SGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI,
$ VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM,
$ RCONDE, RCONDV, WORK, LWORK, IWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER BALANC, JOBVL, JOBVR, SENSE
INTEGER IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N
REAL ABNRM
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL A( LDA, * ), RCONDE( * ), RCONDV( * ),
$ SCALE( * ), VL( LDVL, * ), VR( LDVR, * ),
$ WI( * ), WORK( * ), WR( * )
* ..
*
* Purpose
* =======
*
* SGEEVX computes for an N-by-N real nonsymmetric matrix A, the
* eigenvalues and, optionally, the left and/or right eigenvectors.
*
* Optionally also, it computes a balancing transformation to improve
* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
* (RCONDE), and reciprocal condition numbers for the right
* eigenvectors (RCONDV).
*
* The right eigenvector v(j) of A satisfies
* A * v(j) = lambda(j) * v(j)
* where lambda(j) is its eigenvalue.
* The left eigenvector u(j) of A satisfies
* u(j)**H * A = lambda(j) * u(j)**H
* where u(j)**H denotes the conjugate transpose of u(j).
*
* The computed eigenvectors are normalized to have Euclidean norm
* equal to 1 and largest component real.
*
* Balancing a matrix means permuting the rows and columns to make it
* more nearly upper triangular, and applying a diagonal similarity
* transformation D * A * D**(-1), where D is a diagonal matrix, to
* make its rows and columns closer in norm and the condition numbers
* of its eigenvalues and eigenvectors smaller. The computed
* reciprocal condition numbers correspond to the balanced matrix.
* Permuting rows and columns will not change the condition numbers
* (in exact arithmetic) but diagonal scaling will. For further
* explanation of balancing, see section 4.10.2 of the LAPACK
* Users' Guide.
*
* Arguments
* =========
*
* BALANC (input) CHARACTER*1
* Indicates how the input matrix should be diagonally scaled
* and/or permuted to improve the conditioning of its
* eigenvalues.
* = 'N': Do not diagonally scale or permute;
* = 'P': Perform permutations to make the matrix more nearly
* upper triangular. Do not diagonally scale;
* = 'S': Diagonally scale the matrix, i.e. replace A by
* D*A*D**(-1), where D is a diagonal matrix chosen
* to make the rows and columns of A more equal in
* norm. Do not permute;
* = 'B': Both diagonally scale and permute A.
*
* Computed reciprocal condition numbers will be for the matrix
* after balancing and/or permuting. Permuting does not change
* condition numbers (in exact arithmetic), but balancing does.
*
* JOBVL (input) CHARACTER*1
* = 'N': left eigenvectors of A are not computed;
* = 'V': left eigenvectors of A are computed.
* If SENSE = 'E' or 'B', JOBVL must = 'V'.
*
* JOBVR (input) CHARACTER*1
* = 'N': right eigenvectors of A are not computed;
* = 'V': right eigenvectors of A are computed.
* If SENSE = 'E' or 'B', JOBVR must = 'V'.
*
* SENSE (input) CHARACTER*1
* Determines which reciprocal condition numbers are computed.
* = 'N': None are computed;
* = 'E': Computed for eigenvalues only;
* = 'V': Computed for right eigenvectors only;
* = 'B': Computed for eigenvalues and right eigenvectors.
*
* If SENSE = 'E' or 'B', both left and right eigenvectors
* must also be computed (JOBVL = 'V' and JOBVR = 'V').
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the N-by-N matrix A.
* On exit, A has been overwritten. If JOBVL = 'V' or
* JOBVR = 'V', A contains the real Schur form of the balanced
* version of the input matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* WR (output) REAL array, dimension (N)
* WI (output) REAL array, dimension (N)
* WR and WI contain the real and imaginary parts,
* respectively, of the computed eigenvalues. Complex
* conjugate pairs of eigenvalues will appear consecutively
* with the eigenvalue having the positive imaginary part
* first.
*
* VL (output) REAL array, dimension (LDVL,N)
* If JOBVL = 'V', the left eigenvectors u(j) are stored one
* after another in the columns of VL, in the same order
* as their eigenvalues.
* If JOBVL = 'N', VL is not referenced.
* If the j-th eigenvalue is real, then u(j) = VL(:,j),
* the j-th column of VL.
* If the j-th and (j+1)-st eigenvalues form a complex
* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and
* u(j+1) = VL(:,j) - i*VL(:,j+1).
*
* LDVL (input) INTEGER
* The leading dimension of the array VL. LDVL >= 1; if
* JOBVL = 'V', LDVL >= N.
*
* VR (output) REAL array, dimension (LDVR,N)
* If JOBVR = 'V', the right eigenvectors v(j) are stored one
* after another in the columns of VR, in the same order
* as their eigenvalues.
* If JOBVR = 'N', VR is not referenced.
* If the j-th eigenvalue is real, then v(j) = VR(:,j),
* the j-th column of VR.
* If the j-th and (j+1)-st eigenvalues form a complex
* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and
* v(j+1) = VR(:,j) - i*VR(:,j+1).
*
* LDVR (input) INTEGER
* The leading dimension of the array VR. LDVR >= 1, and if
* JOBVR = 'V', LDVR >= N.
*
* ILO (output) INTEGER
* IHI (output) INTEGER
* ILO and IHI are integer values determined when A was
* balanced. The balanced A(i,j) = 0 if I > J and
* J = 1,...,ILO-1 or I = IHI+1,...,N.
*
* SCALE (output) REAL array, dimension (N)
* Details of the permutations and scaling factors applied
* when balancing A. If P(j) is the index of the row and column
* interchanged with row and column j, and D(j) is the scaling
* factor applied to row and column j, then
* SCALE(J) = P(J), for J = 1,...,ILO-1
* = D(J), for J = ILO,...,IHI
* = P(J) for J = IHI+1,...,N.
* The order in which the interchanges are made is N to IHI+1,
* then 1 to ILO-1.
*
* ABNRM (output) REAL
* The one-norm of the balanced matrix (the maximum
* of the sum of absolute values of elements of any column).
*
* RCONDE (output) REAL array, dimension (N)
* RCONDE(j) is the reciprocal condition number of the j-th
* eigenvalue.
*
* RCONDV (output) REAL array, dimension (N)
* RCONDV(j) is the reciprocal condition number of the j-th
* right eigenvector.
*
* WORK (workspace/output) REAL 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 SENSE = 'N' or 'E',
* LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V',
* LWORK >= 3*N. If SENSE = 'V' or 'B', LWORK >= N*(N+6).
* For good performance, LWORK must generally be larger.
*
* 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.
*
* IWORK (workspace) INTEGER array, dimension (2*N-2)
* If SENSE = 'N' or 'E', not referenced.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = i, the QR algorithm failed to compute all the
* eigenvalues, and no eigenvectors or condition numbers
* have been computed; elements 1:ILO-1 and i+1:N of WR
* and WI contain eigenvalues which have converged.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, SCALEA, WANTVL, WANTVR, WNTSNB, WNTSNE,
$ WNTSNN, WNTSNV
CHARACTER JOB, SIDE
INTEGER HSWORK, I, ICOND, IERR, ITAU, IWRK, K, MAXWRK,
$ MINWRK, NOUT
REAL ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM,
$ SN
* ..
* .. Local Arrays ..
LOGICAL SELECT( 1 )
REAL DUM( 1 )
* ..
* .. External Subroutines ..
EXTERNAL SGEBAK, SGEBAL, SGEHRD, SHSEQR, SLABAD, SLACPY,
$ SLARTG, SLASCL, SORGHR, SROT, SSCAL, STREVC,
$ STRSNA, XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV, ISAMAX
REAL SLAMCH, SLANGE, SLAPY2, SNRM2
EXTERNAL LSAME, ILAENV, ISAMAX, SLAMCH, SLANGE, SLAPY2,
$ SNRM2
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
WANTVL = LSAME( JOBVL, 'V' )
WANTVR = LSAME( JOBVR, 'V' )
WNTSNN = LSAME( SENSE, 'N' )
WNTSNE = LSAME( SENSE, 'E' )
WNTSNV = LSAME( SENSE, 'V' )
WNTSNB = LSAME( SENSE, 'B' )
IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, 'S' ) .OR.
$ LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) ) ) THEN
INFO = -1
ELSE IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN
INFO = -2
ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN
INFO = -3
ELSE IF( .NOT.( WNTSNN .OR. WNTSNE .OR. WNTSNB .OR. WNTSNV ) .OR.
$ ( ( WNTSNE .OR. WNTSNB ) .AND. .NOT.( WANTVL .AND.
$ WANTVR ) ) ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN
INFO = -11
ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN
INFO = -13
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.
* HSWORK refers to the workspace preferred by SHSEQR, as
* calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
* the worst case.)
*
IF( INFO.EQ.0 ) THEN
IF( N.EQ.0 ) THEN
MINWRK = 1
MAXWRK = 1
ELSE
MAXWRK = N + N*ILAENV( 1, 'SGEHRD', ' ', N, 1, N, 0 )
*
IF( WANTVL ) THEN
CALL SHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VL, LDVL,
$ WORK, -1, INFO )
ELSE IF( WANTVR ) THEN
CALL SHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VR, LDVR,
$ WORK, -1, INFO )
ELSE
IF( WNTSNN ) THEN
CALL SHSEQR( 'E', 'N', N, 1, N, A, LDA, WR, WI, VR,
$ LDVR, WORK, -1, INFO )
ELSE
CALL SHSEQR( 'S', 'N', N, 1, N, A, LDA, WR, WI, VR,
$ LDVR, WORK, -1, INFO )
END IF
END IF
HSWORK = WORK( 1 )
*
IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN
MINWRK = 2*N
IF( .NOT.WNTSNN )
$ MINWRK = MAX( MINWRK, N*N+6*N )
MAXWRK = MAX( MAXWRK, HSWORK )
IF( .NOT.WNTSNN )
$ MAXWRK = MAX( MAXWRK, N*N + 6*N )
ELSE
MINWRK = 3*N
IF( ( .NOT.WNTSNN ) .AND. ( .NOT.WNTSNE ) )
$ MINWRK = MAX( MINWRK, N*N + 6*N )
MAXWRK = MAX( MAXWRK, HSWORK )
MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'SORGHR',
$ ' ', N, 1, N, -1 ) )
IF( ( .NOT.WNTSNN ) .AND. ( .NOT.WNTSNE ) )
$ MAXWRK = MAX( MAXWRK, N*N + 6*N )
MAXWRK = MAX( MAXWRK, 3*N )
END IF
MAXWRK = MAX( MAXWRK, MINWRK )
END IF
WORK( 1 ) = MAXWRK
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
INFO = -21
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGEEVX', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Get machine constants
*
EPS = SLAMCH( 'P' )
SMLNUM = SLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
SMLNUM = SQRT( SMLNUM ) / EPS
BIGNUM = ONE / SMLNUM
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ICOND = 0
ANRM = SLANGE( 'M', N, N, A, LDA, DUM )
SCALEA = .FALSE.
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
SCALEA = .TRUE.
CSCALE = SMLNUM
ELSE IF( ANRM.GT.BIGNUM ) THEN
SCALEA = .TRUE.
CSCALE = BIGNUM
END IF
IF( SCALEA )
$ CALL SLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
*
* Balance the matrix and compute ABNRM
*
CALL SGEBAL( BALANC, N, A, LDA, ILO, IHI, SCALE, IERR )
ABNRM = SLANGE( '1', N, N, A, LDA, DUM )
IF( SCALEA ) THEN
DUM( 1 ) = ABNRM
CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, 1, 1, DUM, 1, IERR )
ABNRM = DUM( 1 )
END IF
*
* Reduce to upper Hessenberg form
* (Workspace: need 2*N, prefer N+N*NB)
*
ITAU = 1
IWRK = ITAU + N
CALL SGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
$ LWORK-IWRK+1, IERR )
*
IF( WANTVL ) THEN
*
* Want left eigenvectors
* Copy Householder vectors to VL
*
SIDE = 'L'
CALL SLACPY( 'L', N, N, A, LDA, VL, LDVL )
*
* Generate orthogonal matrix in VL
* (Workspace: need 2*N-1, prefer N+(N-1)*NB)
*
CALL SORGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ),
$ LWORK-IWRK+1, IERR )
*
* Perform QR iteration, accumulating Schur vectors in VL
* (Workspace: need 1, prefer HSWORK (see comments) )
*
IWRK = ITAU
CALL SHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VL, LDVL,
$ WORK( IWRK ), LWORK-IWRK+1, INFO )
*
IF( WANTVR ) THEN
*
* Want left and right eigenvectors
* Copy Schur vectors to VR
*
SIDE = 'B'
CALL SLACPY( 'F', N, N, VL, LDVL, VR, LDVR )
END IF
*
ELSE IF( WANTVR ) THEN
*
* Want right eigenvectors
* Copy Householder vectors to VR
*
SIDE = 'R'
CALL SLACPY( 'L', N, N, A, LDA, VR, LDVR )
*
* Generate orthogonal matrix in VR
* (Workspace: need 2*N-1, prefer N+(N-1)*NB)
*
CALL SORGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ),
$ LWORK-IWRK+1, IERR )
*
* Perform QR iteration, accumulating Schur vectors in VR
* (Workspace: need 1, prefer HSWORK (see comments) )
*
IWRK = ITAU
CALL SHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR,
$ WORK( IWRK ), LWORK-IWRK+1, INFO )
*
ELSE
*
* Compute eigenvalues only
* If condition numbers desired, compute Schur form
*
IF( WNTSNN ) THEN
JOB = 'E'
ELSE
JOB = 'S'
END IF
*
* (Workspace: need 1, prefer HSWORK (see comments) )
*
IWRK = ITAU
CALL SHSEQR( JOB, 'N', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR,
$ WORK( IWRK ), LWORK-IWRK+1, INFO )
END IF
*
* If INFO > 0 from SHSEQR, then quit
*
IF( INFO.GT.0 )
$ GO TO 50
*
IF( WANTVL .OR. WANTVR ) THEN
*
* Compute left and/or right eigenvectors
* (Workspace: need 3*N)
*
CALL STREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
$ N, NOUT, WORK( IWRK ), IERR )
END IF
*
* Compute condition numbers if desired
* (Workspace: need N*N+6*N unless SENSE = 'E')
*
IF( .NOT.WNTSNN ) THEN
CALL STRSNA( SENSE, 'A', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
$ RCONDE, RCONDV, N, NOUT, WORK( IWRK ), N, IWORK,
$ ICOND )
END IF
*
IF( WANTVL ) THEN
*
* Undo balancing of left eigenvectors
*
CALL SGEBAK( BALANC, 'L', N, ILO, IHI, SCALE, N, VL, LDVL,
$ IERR )
*
* Normalize left eigenvectors and make largest component real
*
DO 20 I = 1, N
IF( WI( I ).EQ.ZERO ) THEN
SCL = ONE / SNRM2( N, VL( 1, I ), 1 )
CALL SSCAL( N, SCL, VL( 1, I ), 1 )
ELSE IF( WI( I ).GT.ZERO ) THEN
SCL = ONE / SLAPY2( SNRM2( N, VL( 1, I ), 1 ),
$ SNRM2( N, VL( 1, I+1 ), 1 ) )
CALL SSCAL( N, SCL, VL( 1, I ), 1 )
CALL SSCAL( N, SCL, VL( 1, I+1 ), 1 )
DO 10 K = 1, N
WORK( K ) = VL( K, I )**2 + VL( K, I+1 )**2
10 CONTINUE
K = ISAMAX( N, WORK, 1 )
CALL SLARTG( VL( K, I ), VL( K, I+1 ), CS, SN, R )
CALL SROT( N, VL( 1, I ), 1, VL( 1, I+1 ), 1, CS, SN )
VL( K, I+1 ) = ZERO
END IF
20 CONTINUE
END IF
*
IF( WANTVR ) THEN
*
* Undo balancing of right eigenvectors
*
CALL SGEBAK( BALANC, 'R', N, ILO, IHI, SCALE, N, VR, LDVR,
$ IERR )
*
* Normalize right eigenvectors and make largest component real
*
DO 40 I = 1, N
IF( WI( I ).EQ.ZERO ) THEN
SCL = ONE / SNRM2( N, VR( 1, I ), 1 )
CALL SSCAL( N, SCL, VR( 1, I ), 1 )
ELSE IF( WI( I ).GT.ZERO ) THEN
SCL = ONE / SLAPY2( SNRM2( N, VR( 1, I ), 1 ),
$ SNRM2( N, VR( 1, I+1 ), 1 ) )
CALL SSCAL( N, SCL, VR( 1, I ), 1 )
CALL SSCAL( N, SCL, VR( 1, I+1 ), 1 )
DO 30 K = 1, N
WORK( K ) = VR( K, I )**2 + VR( K, I+1 )**2
30 CONTINUE
K = ISAMAX( N, WORK, 1 )
CALL SLARTG( VR( K, I ), VR( K, I+1 ), CS, SN, R )
CALL SROT( N, VR( 1, I ), 1, VR( 1, I+1 ), 1, CS, SN )
VR( K, I+1 ) = ZERO
END IF
40 CONTINUE
END IF
*
* Undo scaling if necessary
*
50 CONTINUE
IF( SCALEA ) THEN
CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WR( INFO+1 ),
$ MAX( N-INFO, 1 ), IERR )
CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WI( INFO+1 ),
$ MAX( N-INFO, 1 ), IERR )
IF( INFO.EQ.0 ) THEN
IF( ( WNTSNV .OR. WNTSNB ) .AND. ICOND.EQ.0 )
$ CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, RCONDV, N,
$ IERR )
ELSE
CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WR, N,
$ IERR )
CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N,
$ IERR )
END IF
END IF
*
WORK( 1 ) = MAXWRK
RETURN
*
* End of SGEEVX
*
END
SUBROUTINE SGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR,
$ ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK,
$ LWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBVSL, JOBVSR
INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
$ B( LDB, * ), BETA( * ), VSL( LDVSL, * ),
$ VSR( LDVSR, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* This routine is deprecated and has been replaced by routine SGGES.
*
* SGEGS computes the eigenvalues, real Schur form, and, optionally,
* left and or/right Schur vectors of a real matrix pair (A,B).
* Given two square matrices A and B, the generalized real Schur
* factorization has the form
*
* A = Q*S*Z**T, B = Q*T*Z**T
*
* where Q and Z are orthogonal matrices, T is upper triangular, and S
* is an upper quasi-triangular matrix with 1-by-1 and 2-by-2 diagonal
* blocks, the 2-by-2 blocks corresponding to complex conjugate pairs
* of eigenvalues of (A,B). The columns of Q are the left Schur vectors
* and the columns of Z are the right Schur vectors.
*
* If only the eigenvalues of (A,B) are needed, the driver routine
* SGEGV should be used instead. See SGEGV for a description of the
* eigenvalues of the generalized nonsymmetric eigenvalue problem
* (GNEP).
*
* Arguments
* =========
*
* JOBVSL (input) CHARACTER*1
* = 'N': do not compute the left Schur vectors;
* = 'V': compute the left Schur vectors (returned in VSL).
*
* JOBVSR (input) CHARACTER*1
* = 'N': do not compute the right Schur vectors;
* = 'V': compute the right Schur vectors (returned in VSR).
*
* N (input) INTEGER
* The order of the matrices A, B, VSL, and VSR. N >= 0.
*
* A (input/output) REAL array, dimension (LDA, N)
* On entry, the matrix A.
* On exit, the upper quasi-triangular matrix S from the
* generalized real Schur factorization.
*
* LDA (input) INTEGER
* The leading dimension of A. LDA >= max(1,N).
*
* B (input/output) REAL array, dimension (LDB, N)
* On entry, the matrix B.
* On exit, the upper triangular matrix T from the generalized
* real Schur factorization.
*
* LDB (input) INTEGER
* The leading dimension of B. LDB >= max(1,N).
*
* ALPHAR (output) REAL array, dimension (N)
* The real parts of each scalar alpha defining an eigenvalue
* of GNEP.
*
* ALPHAI (output) REAL array, dimension (N)
* The imaginary parts of each scalar alpha defining an
* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th
* eigenvalue is real; if positive, then the j-th and (j+1)-st
* eigenvalues are a complex conjugate pair, with
* ALPHAI(j+1) = -ALPHAI(j).
*
* BETA (output) REAL array, dimension (N)
* The scalars beta that define the eigenvalues of GNEP.
* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
* beta = BETA(j) represent the j-th eigenvalue of the matrix
* pair (A,B), in one of the forms lambda = alpha/beta or
* mu = beta/alpha. Since either lambda or mu may overflow,
* they should not, in general, be computed.
*
* VSL (output) REAL array, dimension (LDVSL,N)
* If JOBVSL = 'V', the matrix of left Schur vectors Q.
* Not referenced if JOBVSL = 'N'.
*
* LDVSL (input) INTEGER
* The leading dimension of the matrix VSL. LDVSL >=1, and
* if JOBVSL = 'V', LDVSL >= N.
*
* VSR (output) REAL array, dimension (LDVSR,N)
* If JOBVSR = 'V', the matrix of right Schur vectors Z.
* Not referenced if JOBVSR = 'N'.
*
* LDVSR (input) INTEGER
* The leading dimension of the matrix VSR. LDVSR >= 1, and
* if JOBVSR = 'V', LDVSR >= N.
*
* WORK (workspace/output) REAL 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,4*N).
* For good performance, LWORK must generally be larger.
* To compute the optimal value of LWORK, call ILAENV to get
* blocksizes (for SGEQRF, SORMQR, and SORGQR.) Then compute:
* NB -- MAX of the blocksizes for SGEQRF, SORMQR, and SORGQR
* The optimal LWORK is 2*N + N*(NB+1).
*
* 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.
* = 1,...,N:
* The QZ iteration failed. (A,B) are not in Schur
* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should
* be correct for j=INFO+1,...,N.
* > N: errors that usually indicate LAPACK problems:
* =N+1: error return from SGGBAL
* =N+2: error return from SGEQRF
* =N+3: error return from SORMQR
* =N+4: error return from SORGQR
* =N+5: error return from SGGHRD
* =N+6: error return from SHGEQZ (other than failed
* iteration)
* =N+7: error return from SGGBAK (computing VSL)
* =N+8: error return from SGGBAK (computing VSR)
* =N+9: error return from SLASCL (various places)
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL ILASCL, ILBSCL, ILVSL, ILVSR, LQUERY
INTEGER ICOLS, IHI, IINFO, IJOBVL, IJOBVR, ILEFT,
$ ILO, IRIGHT, IROWS, ITAU, IWORK, LOPT, LWKMIN,
$ LWKOPT, NB, NB1, NB2, NB3
REAL ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
$ SAFMIN, SMLNUM
* ..
* .. External Subroutines ..
EXTERNAL SGEQRF, SGGBAK, SGGBAL, SGGHRD, SHGEQZ, SLACPY,
$ SLASCL, SLASET, SORGQR, SORMQR, XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
REAL SLAMCH, SLANGE
EXTERNAL ILAENV, LSAME, SLAMCH, SLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC INT, MAX
* ..
* .. Executable Statements ..
*
* Decode the input arguments
*
IF( LSAME( JOBVSL, 'N' ) ) THEN
IJOBVL = 1
ILVSL = .FALSE.
ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN
IJOBVL = 2
ILVSL = .TRUE.
ELSE
IJOBVL = -1
ILVSL = .FALSE.
END IF
*
IF( LSAME( JOBVSR, 'N' ) ) THEN
IJOBVR = 1
ILVSR = .FALSE.
ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN
IJOBVR = 2
ILVSR = .TRUE.
ELSE
IJOBVR = -1
ILVSR = .FALSE.
END IF
*
* Test the input arguments
*
LWKMIN = MAX( 4*N, 1 )
LWKOPT = LWKMIN
WORK( 1 ) = LWKOPT
LQUERY = ( LWORK.EQ.-1 )
INFO = 0
IF( IJOBVL.LE.0 ) THEN
INFO = -1
ELSE IF( IJOBVR.LE.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN
INFO = -12
ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN
INFO = -14
ELSE IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
INFO = -16
END IF
*
IF( INFO.EQ.0 ) THEN
NB1 = ILAENV( 1, 'SGEQRF', ' ', N, N, -1, -1 )
NB2 = ILAENV( 1, 'SORMQR', ' ', N, N, N, -1 )
NB3 = ILAENV( 1, 'SORGQR', ' ', N, N, N, -1 )
NB = MAX( NB1, NB2, NB3 )
LOPT = 2*N+N*(NB+1)
WORK( 1 ) = LOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGEGS ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Get machine constants
*
EPS = SLAMCH( 'E' )*SLAMCH( 'B' )
SAFMIN = SLAMCH( 'S' )
SMLNUM = N*SAFMIN / EPS
BIGNUM = ONE / SMLNUM
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = SLANGE( 'M', N, N, A, LDA, WORK )
ILASCL = .FALSE.
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
ANRMTO = SMLNUM
ILASCL = .TRUE.
ELSE IF( ANRM.GT.BIGNUM ) THEN
ANRMTO = BIGNUM
ILASCL = .TRUE.
END IF
*
IF( ILASCL ) THEN
CALL SLASCL( 'G', -1, -1, ANRM, ANRMTO, N, N, A, LDA, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 9
RETURN
END IF
END IF
*
* Scale B if max element outside range [SMLNUM,BIGNUM]
*
BNRM = SLANGE( 'M', N, N, B, LDB, WORK )
ILBSCL = .FALSE.
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
BNRMTO = SMLNUM
ILBSCL = .TRUE.
ELSE IF( BNRM.GT.BIGNUM ) THEN
BNRMTO = BIGNUM
ILBSCL = .TRUE.
END IF
*
IF( ILBSCL ) THEN
CALL SLASCL( 'G', -1, -1, BNRM, BNRMTO, N, N, B, LDB, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 9
RETURN
END IF
END IF
*
* Permute the matrix to make it more nearly triangular
* Workspace layout: (2*N words -- "work..." not actually used)
* left_permutation, right_permutation, work...
*
ILEFT = 1
IRIGHT = N + 1
IWORK = IRIGHT + N
CALL SGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ),
$ WORK( IRIGHT ), WORK( IWORK ), IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 1
GO TO 10
END IF
*
* Reduce B to triangular form, and initialize VSL and/or VSR
* Workspace layout: ("work..." must have at least N words)
* left_permutation, right_permutation, tau, work...
*
IROWS = IHI + 1 - ILO
ICOLS = N + 1 - ILO
ITAU = IWORK
IWORK = ITAU + IROWS
CALL SGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
$ WORK( IWORK ), LWORK+1-IWORK, IINFO )
IF( IINFO.GE.0 )
$ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
IF( IINFO.NE.0 ) THEN
INFO = N + 2
GO TO 10
END IF
*
CALL SORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
$ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWORK ),
$ LWORK+1-IWORK, IINFO )
IF( IINFO.GE.0 )
$ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
IF( IINFO.NE.0 ) THEN
INFO = N + 3
GO TO 10
END IF
*
IF( ILVSL ) THEN
CALL SLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL )
CALL SLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
$ VSL( ILO+1, ILO ), LDVSL )
CALL SORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL,
$ WORK( ITAU ), WORK( IWORK ), LWORK+1-IWORK,
$ IINFO )
IF( IINFO.GE.0 )
$ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
IF( IINFO.NE.0 ) THEN
INFO = N + 4
GO TO 10
END IF
END IF
*
IF( ILVSR )
$ CALL SLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR )
*
* Reduce to generalized Hessenberg form
*
CALL SGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL,
$ LDVSL, VSR, LDVSR, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 5
GO TO 10
END IF
*
* Perform QZ algorithm, computing Schur vectors if desired
* Workspace layout: ("work..." must have at least 1 word)
* left_permutation, right_permutation, work...
*
IWORK = ITAU
CALL SHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB,
$ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR,
$ WORK( IWORK ), LWORK+1-IWORK, IINFO )
IF( IINFO.GE.0 )
$ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
IF( IINFO.NE.0 ) THEN
IF( IINFO.GT.0 .AND. IINFO.LE.N ) THEN
INFO = IINFO
ELSE IF( IINFO.GT.N .AND. IINFO.LE.2*N ) THEN
INFO = IINFO - N
ELSE
INFO = N + 6
END IF
GO TO 10
END IF
*
* Apply permutation to VSL and VSR
*
IF( ILVSL ) THEN
CALL SGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
$ WORK( IRIGHT ), N, VSL, LDVSL, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 7
GO TO 10
END IF
END IF
IF( ILVSR ) THEN
CALL SGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ),
$ WORK( IRIGHT ), N, VSR, LDVSR, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 8
GO TO 10
END IF
END IF
*
* Undo scaling
*
IF( ILASCL ) THEN
CALL SLASCL( 'H', -1, -1, ANRMTO, ANRM, N, N, A, LDA, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 9
RETURN
END IF
CALL SLASCL( 'G', -1, -1, ANRMTO, ANRM, N, 1, ALPHAR, N,
$ IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 9
RETURN
END IF
CALL SLASCL( 'G', -1, -1, ANRMTO, ANRM, N, 1, ALPHAI, N,
$ IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 9
RETURN
END IF
END IF
*
IF( ILBSCL ) THEN
CALL SLASCL( 'U', -1, -1, BNRMTO, BNRM, N, N, B, LDB, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 9
RETURN
END IF
CALL SLASCL( 'G', -1, -1, BNRMTO, BNRM, N, 1, BETA, N, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 9
RETURN
END IF
END IF
*
10 CONTINUE
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of SGEGS
*
END
SUBROUTINE SGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI,
$ BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBVL, JOBVR
INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
$ B( LDB, * ), BETA( * ), VL( LDVL, * ),
$ VR( LDVR, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* This routine is deprecated and has been replaced by routine SGGEV.
*
* SGEGV computes the eigenvalues and, optionally, the left and/or right
* eigenvectors of a real matrix pair (A,B).
* Given two square matrices A and B,
* the generalized nonsymmetric eigenvalue problem (GNEP) is to find the
* eigenvalues lambda and corresponding (non-zero) eigenvectors x such
* that
*
* A*x = lambda*B*x.
*
* An alternate form is to find the eigenvalues mu and corresponding
* eigenvectors y such that
*
* mu*A*y = B*y.
*
* These two forms are equivalent with mu = 1/lambda and x = y if
* neither lambda nor mu is zero. In order to deal with the case that
* lambda or mu is zero or small, two values alpha and beta are returned
* for each eigenvalue, such that lambda = alpha/beta and
* mu = beta/alpha.
*
* The vectors x and y in the above equations are right eigenvectors of
* the matrix pair (A,B). Vectors u and v satisfying
*
* u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B
*
* are left eigenvectors of (A,B).
*
* Note: this routine performs "full balancing" on A and B -- see
* "Further Details", below.
*
* Arguments
* =========
*
* JOBVL (input) CHARACTER*1
* = 'N': do not compute the left generalized eigenvectors;
* = 'V': compute the left generalized eigenvectors (returned
* in VL).
*
* JOBVR (input) CHARACTER*1
* = 'N': do not compute the right generalized eigenvectors;
* = 'V': compute the right generalized eigenvectors (returned
* in VR).
*
* N (input) INTEGER
* The order of the matrices A, B, VL, and VR. N >= 0.
*
* A (input/output) REAL array, dimension (LDA, N)
* On entry, the matrix A.
* If JOBVL = 'V' or JOBVR = 'V', then on exit A
* contains the real Schur form of A from the generalized Schur
* factorization of the pair (A,B) after balancing.
* If no eigenvectors were computed, then only the diagonal
* blocks from the Schur form will be correct. See SGGHRD and
* SHGEQZ for details.
*
* LDA (input) INTEGER
* The leading dimension of A. LDA >= max(1,N).
*
* B (input/output) REAL array, dimension (LDB, N)
* On entry, the matrix B.
* If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the
* upper triangular matrix obtained from B in the generalized
* Schur factorization of the pair (A,B) after balancing.
* If no eigenvectors were computed, then only those elements of
* B corresponding to the diagonal blocks from the Schur form of
* A will be correct. See SGGHRD and SHGEQZ for details.
*
* LDB (input) INTEGER
* The leading dimension of B. LDB >= max(1,N).
*
* ALPHAR (output) REAL array, dimension (N)
* The real parts of each scalar alpha defining an eigenvalue of
* GNEP.
*
* ALPHAI (output) REAL array, dimension (N)
* The imaginary parts of each scalar alpha defining an
* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th
* eigenvalue is real; if positive, then the j-th and
* (j+1)-st eigenvalues are a complex conjugate pair, with
* ALPHAI(j+1) = -ALPHAI(j).
*
* BETA (output) REAL array, dimension (N)
* The scalars beta that define the eigenvalues of GNEP.
*
* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
* beta = BETA(j) represent the j-th eigenvalue of the matrix
* pair (A,B), in one of the forms lambda = alpha/beta or
* mu = beta/alpha. Since either lambda or mu may overflow,
* they should not, in general, be computed.
*
* VL (output) REAL array, dimension (LDVL,N)
* If JOBVL = 'V', the left eigenvectors u(j) are stored
* in the columns of VL, in the same order as their eigenvalues.
* If the j-th eigenvalue is real, then u(j) = VL(:,j).
* If the j-th and (j+1)-st eigenvalues form a complex conjugate
* pair, then
* u(j) = VL(:,j) + i*VL(:,j+1)
* and
* u(j+1) = VL(:,j) - i*VL(:,j+1).
*
* Each eigenvector is scaled so that its largest component has
* abs(real part) + abs(imag. part) = 1, except for eigenvectors
* corresponding to an eigenvalue with alpha = beta = 0, which
* are set to zero.
* Not referenced if JOBVL = 'N'.
*
* LDVL (input) INTEGER
* The leading dimension of the matrix VL. LDVL >= 1, and
* if JOBVL = 'V', LDVL >= N.
*
* VR (output) REAL array, dimension (LDVR,N)
* If JOBVR = 'V', the right eigenvectors x(j) are stored
* in the columns of VR, in the same order as their eigenvalues.
* If the j-th eigenvalue is real, then x(j) = VR(:,j).
* If the j-th and (j+1)-st eigenvalues form a complex conjugate
* pair, then
* x(j) = VR(:,j) + i*VR(:,j+1)
* and
* x(j+1) = VR(:,j) - i*VR(:,j+1).
*
* Each eigenvector is scaled so that its largest component has
* abs(real part) + abs(imag. part) = 1, except for eigenvalues
* corresponding to an eigenvalue with alpha = beta = 0, which
* are set to zero.
* Not referenced if JOBVR = 'N'.
*
* LDVR (input) INTEGER
* The leading dimension of the matrix VR. LDVR >= 1, and
* if JOBVR = 'V', LDVR >= N.
*
* WORK (workspace/output) REAL 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,8*N).
* For good performance, LWORK must generally be larger.
* To compute the optimal value of LWORK, call ILAENV to get
* blocksizes (for SGEQRF, SORMQR, and SORGQR.) Then compute:
* NB -- MAX of the blocksizes for SGEQRF, SORMQR, and SORGQR;
* The optimal LWORK is:
* 2*N + MAX( 6*N, N*(NB+1) ).
*
* 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.
* = 1,...,N:
* The QZ iteration failed. No eigenvectors have been
* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
* should be correct for j=INFO+1,...,N.
* > N: errors that usually indicate LAPACK problems:
* =N+1: error return from SGGBAL
* =N+2: error return from SGEQRF
* =N+3: error return from SORMQR
* =N+4: error return from SORGQR
* =N+5: error return from SGGHRD
* =N+6: error return from SHGEQZ (other than failed
* iteration)
* =N+7: error return from STGEVC
* =N+8: error return from SGGBAK (computing VL)
* =N+9: error return from SGGBAK (computing VR)
* =N+10: error return from SLASCL (various calls)
*
* Further Details
* ===============
*
* Balancing
* ---------
*
* This driver calls SGGBAL to both permute and scale rows and columns
* of A and B. The permutations PL and PR are chosen so that PL*A*PR
* and PL*B*R will be upper triangular except for the diagonal blocks
* A(i:j,i:j) and B(i:j,i:j), with i and j as close together as
* possible. The diagonal scaling matrices DL and DR are chosen so
* that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to
* one (except for the elements that start out zero.)
*
* After the eigenvalues and eigenvectors of the balanced matrices
* have been computed, SGGBAK transforms the eigenvectors back to what
* they would have been (in perfect arithmetic) if they had not been
* balanced.
*
* Contents of A and B on Exit
* -------- -- - --- - -- ----
*
* If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or
* both), then on exit the arrays A and B will contain the real Schur
* form[*] of the "balanced" versions of A and B. If no eigenvectors
* are computed, then only the diagonal blocks will be correct.
*
* [*] See SHGEQZ, SGEGS, or read the book "Matrix Computations",
* by Golub & van Loan, pub. by Johns Hopkins U. Press.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL ILIMIT, ILV, ILVL, ILVR, LQUERY
CHARACTER CHTEMP
INTEGER ICOLS, IHI, IINFO, IJOBVL, IJOBVR, ILEFT, ILO,
$ IN, IRIGHT, IROWS, ITAU, IWORK, JC, JR, LOPT,
$ LWKMIN, LWKOPT, NB, NB1, NB2, NB3
REAL ABSAI, ABSAR, ABSB, ANRM, ANRM1, ANRM2, BNRM,
$ BNRM1, BNRM2, EPS, ONEPLS, SAFMAX, SAFMIN,
$ SALFAI, SALFAR, SBETA, SCALE, TEMP
* ..
* .. Local Arrays ..
LOGICAL LDUMMA( 1 )
* ..
* .. External Subroutines ..
EXTERNAL SGEQRF, SGGBAK, SGGBAL, SGGHRD, SHGEQZ, SLACPY,
$ SLASCL, SLASET, SORGQR, SORMQR, STGEVC, XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
REAL SLAMCH, SLANGE
EXTERNAL ILAENV, LSAME, SLAMCH, SLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, MAX
* ..
* .. Executable Statements ..
*
* Decode the input arguments
*
IF( LSAME( JOBVL, 'N' ) ) THEN
IJOBVL = 1
ILVL = .FALSE.
ELSE IF( LSAME( JOBVL, 'V' ) ) THEN
IJOBVL = 2
ILVL = .TRUE.
ELSE
IJOBVL = -1
ILVL = .FALSE.
END IF
*
IF( LSAME( JOBVR, 'N' ) ) THEN
IJOBVR = 1
ILVR = .FALSE.
ELSE IF( LSAME( JOBVR, 'V' ) ) THEN
IJOBVR = 2
ILVR = .TRUE.
ELSE
IJOBVR = -1
ILVR = .FALSE.
END IF
ILV = ILVL .OR. ILVR
*
* Test the input arguments
*
LWKMIN = MAX( 8*N, 1 )
LWKOPT = LWKMIN
WORK( 1 ) = LWKOPT
LQUERY = ( LWORK.EQ.-1 )
INFO = 0
IF( IJOBVL.LE.0 ) THEN
INFO = -1
ELSE IF( IJOBVR.LE.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
INFO = -12
ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
INFO = -14
ELSE IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
INFO = -16
END IF
*
IF( INFO.EQ.0 ) THEN
NB1 = ILAENV( 1, 'SGEQRF', ' ', N, N, -1, -1 )
NB2 = ILAENV( 1, 'SORMQR', ' ', N, N, N, -1 )
NB3 = ILAENV( 1, 'SORGQR', ' ', N, N, N, -1 )
NB = MAX( NB1, NB2, NB3 )
LOPT = 2*N + MAX( 6*N, N*(NB+1) )
WORK( 1 ) = LOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGEGV ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Get machine constants
*
EPS = SLAMCH( 'E' )*SLAMCH( 'B' )
SAFMIN = SLAMCH( 'S' )
SAFMIN = SAFMIN + SAFMIN
SAFMAX = ONE / SAFMIN
ONEPLS = ONE + ( 4*EPS )
*
* Scale A
*
ANRM = SLANGE( 'M', N, N, A, LDA, WORK )
ANRM1 = ANRM
ANRM2 = ONE
IF( ANRM.LT.ONE ) THEN
IF( SAFMAX*ANRM.LT.ONE ) THEN
ANRM1 = SAFMIN
ANRM2 = SAFMAX*ANRM
END IF
END IF
*
IF( ANRM.GT.ZERO ) THEN
CALL SLASCL( 'G', -1, -1, ANRM, ONE, N, N, A, LDA, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 10
RETURN
END IF
END IF
*
* Scale B
*
BNRM = SLANGE( 'M', N, N, B, LDB, WORK )
BNRM1 = BNRM
BNRM2 = ONE
IF( BNRM.LT.ONE ) THEN
IF( SAFMAX*BNRM.LT.ONE ) THEN
BNRM1 = SAFMIN
BNRM2 = SAFMAX*BNRM
END IF
END IF
*
IF( BNRM.GT.ZERO ) THEN
CALL SLASCL( 'G', -1, -1, BNRM, ONE, N, N, B, LDB, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 10
RETURN
END IF
END IF
*
* Permute the matrix to make it more nearly triangular
* Workspace layout: (8*N words -- "work" requires 6*N words)
* left_permutation, right_permutation, work...
*
ILEFT = 1
IRIGHT = N + 1
IWORK = IRIGHT + N
CALL SGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ),
$ WORK( IRIGHT ), WORK( IWORK ), IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 1
GO TO 120
END IF
*
* Reduce B to triangular form, and initialize VL and/or VR
* Workspace layout: ("work..." must have at least N words)
* left_permutation, right_permutation, tau, work...
*
IROWS = IHI + 1 - ILO
IF( ILV ) THEN
ICOLS = N + 1 - ILO
ELSE
ICOLS = IROWS
END IF
ITAU = IWORK
IWORK = ITAU + IROWS
CALL SGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
$ WORK( IWORK ), LWORK+1-IWORK, IINFO )
IF( IINFO.GE.0 )
$ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
IF( IINFO.NE.0 ) THEN
INFO = N + 2
GO TO 120
END IF
*
CALL SORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
$ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWORK ),
$ LWORK+1-IWORK, IINFO )
IF( IINFO.GE.0 )
$ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
IF( IINFO.NE.0 ) THEN
INFO = N + 3
GO TO 120
END IF
*
IF( ILVL ) THEN
CALL SLASET( 'Full', N, N, ZERO, ONE, VL, LDVL )
CALL SLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
$ VL( ILO+1, ILO ), LDVL )
CALL SORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
$ WORK( ITAU ), WORK( IWORK ), LWORK+1-IWORK,
$ IINFO )
IF( IINFO.GE.0 )
$ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
IF( IINFO.NE.0 ) THEN
INFO = N + 4
GO TO 120
END IF
END IF
*
IF( ILVR )
$ CALL SLASET( 'Full', N, N, ZERO, ONE, VR, LDVR )
*
* Reduce to generalized Hessenberg form
*
IF( ILV ) THEN
*
* Eigenvectors requested -- work on whole matrix.
*
CALL SGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL,
$ LDVL, VR, LDVR, IINFO )
ELSE
CALL SGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA,
$ B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IINFO )
END IF
IF( IINFO.NE.0 ) THEN
INFO = N + 5
GO TO 120
END IF
*
* Perform QZ algorithm
* Workspace layout: ("work..." must have at least 1 word)
* left_permutation, right_permutation, work...
*
IWORK = ITAU
IF( ILV ) THEN
CHTEMP = 'S'
ELSE
CHTEMP = 'E'
END IF
CALL SHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB,
$ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR,
$ WORK( IWORK ), LWORK+1-IWORK, IINFO )
IF( IINFO.GE.0 )
$ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
IF( IINFO.NE.0 ) THEN
IF( IINFO.GT.0 .AND. IINFO.LE.N ) THEN
INFO = IINFO
ELSE IF( IINFO.GT.N .AND. IINFO.LE.2*N ) THEN
INFO = IINFO - N
ELSE
INFO = N + 6
END IF
GO TO 120
END IF
*
IF( ILV ) THEN
*
* Compute Eigenvectors (STGEVC requires 6*N words of workspace)
*
IF( ILVL ) THEN
IF( ILVR ) THEN
CHTEMP = 'B'
ELSE
CHTEMP = 'L'
END IF
ELSE
CHTEMP = 'R'
END IF
*
CALL STGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, LDVL,
$ VR, LDVR, N, IN, WORK( IWORK ), IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 7
GO TO 120
END IF
*
* Undo balancing on VL and VR, rescale
*
IF( ILVL ) THEN
CALL SGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
$ WORK( IRIGHT ), N, VL, LDVL, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 8
GO TO 120
END IF
DO 50 JC = 1, N
IF( ALPHAI( JC ).LT.ZERO )
$ GO TO 50
TEMP = ZERO
IF( ALPHAI( JC ).EQ.ZERO ) THEN
DO 10 JR = 1, N
TEMP = MAX( TEMP, ABS( VL( JR, JC ) ) )
10 CONTINUE
ELSE
DO 20 JR = 1, N
TEMP = MAX( TEMP, ABS( VL( JR, JC ) )+
$ ABS( VL( JR, JC+1 ) ) )
20 CONTINUE
END IF
IF( TEMP.LT.SAFMIN )
$ GO TO 50
TEMP = ONE / TEMP
IF( ALPHAI( JC ).EQ.ZERO ) THEN
DO 30 JR = 1, N
VL( JR, JC ) = VL( JR, JC )*TEMP
30 CONTINUE
ELSE
DO 40 JR = 1, N
VL( JR, JC ) = VL( JR, JC )*TEMP
VL( JR, JC+1 ) = VL( JR, JC+1 )*TEMP
40 CONTINUE
END IF
50 CONTINUE
END IF
IF( ILVR ) THEN
CALL SGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ),
$ WORK( IRIGHT ), N, VR, LDVR, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = N + 9
GO TO 120
END IF
DO 100 JC = 1, N
IF( ALPHAI( JC ).LT.ZERO )
$ GO TO 100
TEMP = ZERO
IF( ALPHAI( JC ).EQ.ZERO ) THEN
DO 60 JR = 1, N
TEMP = MAX( TEMP, ABS( VR( JR, JC ) ) )
60 CONTINUE
ELSE
DO 70 JR = 1, N
TEMP = MAX( TEMP, ABS( VR( JR, JC ) )+
$ ABS( VR( JR, JC+1 ) ) )
70 CONTINUE
END IF
IF( TEMP.LT.SAFMIN )
$ GO TO 100
TEMP = ONE / TEMP
IF( ALPHAI( JC ).EQ.ZERO ) THEN
DO 80 JR = 1, N
VR( JR, JC ) = VR( JR, JC )*TEMP
80 CONTINUE
ELSE
DO 90 JR = 1, N
VR( JR, JC ) = VR( JR, JC )*TEMP
VR( JR, JC+1 ) = VR( JR, JC+1 )*TEMP
90 CONTINUE
END IF
100 CONTINUE
END IF
*
* End of eigenvector calculation
*
END IF
*
* Undo scaling in alpha, beta
*
* Note: this does not give the alpha and beta for the unscaled
* problem.
*
* Un-scaling is limited to avoid underflow in alpha and beta
* if they are significant.
*
DO 110 JC = 1, N
ABSAR = ABS( ALPHAR( JC ) )
ABSAI = ABS( ALPHAI( JC ) )
ABSB = ABS( BETA( JC ) )
SALFAR = ANRM*ALPHAR( JC )
SALFAI = ANRM*ALPHAI( JC )
SBETA = BNRM*BETA( JC )
ILIMIT = .FALSE.
SCALE = ONE
*
* Check for significant underflow in ALPHAI
*
IF( ABS( SALFAI ).LT.SAFMIN .AND. ABSAI.GE.
$ MAX( SAFMIN, EPS*ABSAR, EPS*ABSB ) ) THEN
ILIMIT = .TRUE.
SCALE = ( ONEPLS*SAFMIN / ANRM1 ) /
$ MAX( ONEPLS*SAFMIN, ANRM2*ABSAI )
*
ELSE IF( SALFAI.EQ.ZERO ) THEN
*
* If insignificant underflow in ALPHAI, then make the
* conjugate eigenvalue real.
*
IF( ALPHAI( JC ).LT.ZERO .AND. JC.GT.1 ) THEN
ALPHAI( JC-1 ) = ZERO
ELSE IF( ALPHAI( JC ).GT.ZERO .AND. JC.LT.N ) THEN
ALPHAI( JC+1 ) = ZERO
END IF
END IF
*
* Check for significant underflow in ALPHAR
*
IF( ABS( SALFAR ).LT.SAFMIN .AND. ABSAR.GE.
$ MAX( SAFMIN, EPS*ABSAI, EPS*ABSB ) ) THEN
ILIMIT = .TRUE.
SCALE = MAX( SCALE, ( ONEPLS*SAFMIN / ANRM1 ) /
$ MAX( ONEPLS*SAFMIN, ANRM2*ABSAR ) )
END IF
*
* Check for significant underflow in BETA
*
IF( ABS( SBETA ).LT.SAFMIN .AND. ABSB.GE.
$ MAX( SAFMIN, EPS*ABSAR, EPS*ABSAI ) ) THEN
ILIMIT = .TRUE.
SCALE = MAX( SCALE, ( ONEPLS*SAFMIN / BNRM1 ) /
$ MAX( ONEPLS*SAFMIN, BNRM2*ABSB ) )
END IF
*
* Check for possible overflow when limiting scaling
*
IF( ILIMIT ) THEN
TEMP = ( SCALE*SAFMIN )*MAX( ABS( SALFAR ), ABS( SALFAI ),
$ ABS( SBETA ) )
IF( TEMP.GT.ONE )
$ SCALE = SCALE / TEMP
IF( SCALE.LT.ONE )
$ ILIMIT = .FALSE.
END IF
*
* Recompute un-scaled ALPHAR, ALPHAI, BETA if necessary.
*
IF( ILIMIT ) THEN
SALFAR = ( SCALE*ALPHAR( JC ) )*ANRM
SALFAI = ( SCALE*ALPHAI( JC ) )*ANRM
SBETA = ( SCALE*BETA( JC ) )*BNRM
END IF
ALPHAR( JC ) = SALFAR
ALPHAI( JC ) = SALFAI
BETA( JC ) = SBETA
110 CONTINUE
*
120 CONTINUE
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of SGEGV
*
END
SUBROUTINE SGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IHI, ILO, INFO, LDA, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGEHD2 reduces a real general matrix A to upper Hessenberg form H by
* an orthogonal similarity transformation: Q' * A * Q = H .
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* It is assumed that A is already upper triangular in rows
* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
* set by a previous call to SGEBAL; otherwise they should be
* set to 1 and N respectively. See Further Details.
* 1 <= ILO <= IHI <= max(1,N).
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the n by n general matrix to be reduced.
* On exit, the upper triangle and the first subdiagonal of A
* are overwritten with the upper Hessenberg matrix H, and the
* elements below the first subdiagonal, 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,N).
*
* TAU (output) REAL array, dimension (N-1)
* The scalar factors of the elementary reflectors (see Further
* Details).
*
* WORK (workspace) REAL 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 (ihi-ilo) elementary
* reflectors
*
* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a real scalar, and v is a real vector with
* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
* exit in A(i+2:ihi,i), and tau in TAU(i).
*
* The contents of A are illustrated by the following example, with
* n = 7, ilo = 2 and ihi = 6:
*
* on entry, on exit,
*
* ( a a a a a a a ) ( a a h h h h a )
* ( a a a a a a ) ( a h h h h a )
* ( a a a a a a ) ( h h h h h h )
* ( a a a a a a ) ( v2 h h h h h )
* ( a a a a a a ) ( v2 v3 h h h h )
* ( a a a a a a ) ( v2 v3 v4 h h h )
* ( a ) ( a )
*
* where a denotes an element of the original matrix A, h denotes a
* modified element of the upper Hessenberg matrix H, and vi denotes an
* element of the vector defining H(i).
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I
REAL AII
* ..
* .. External Subroutines ..
EXTERNAL SLARF, SLARFG, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
INFO = -2
ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGEHD2', -INFO )
RETURN
END IF
*
DO 10 I = ILO, IHI - 1
*
* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i)
*
CALL SLARFG( IHI-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1,
$ TAU( I ) )
AII = A( I+1, I )
A( I+1, I ) = ONE
*
* Apply H(i) to A(1:ihi,i+1:ihi) from the right
*
CALL SLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ),
$ A( 1, I+1 ), LDA, WORK )
*
* Apply H(i) to A(i+1:ihi,i+1:n) from the left
*
CALL SLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, TAU( I ),
$ A( I+1, I+1 ), LDA, WORK )
*
A( I+1, I ) = AII
10 CONTINUE
*
RETURN
*
* End of SGEHD2
*
END
SUBROUTINE SGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IHI, ILO, INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGEHRD reduces a real general matrix A to upper Hessenberg form H by
* an orthogonal similarity transformation: Q' * A * Q = H .
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* It is assumed that A is already upper triangular in rows
* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
* set by a previous call to SGEBAL; otherwise they should be
* set to 1 and N respectively. See Further Details.
* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the N-by-N general matrix to be reduced.
* On exit, the upper triangle and the first subdiagonal of A
* are overwritten with the upper Hessenberg matrix H, and the
* elements below the first subdiagonal, 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,N).
*
* TAU (output) REAL array, dimension (N-1)
* The scalar factors of the elementary reflectors (see Further
* Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to
* zero.
*
* WORK (workspace/output) REAL array, dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The length 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 (ihi-ilo) elementary
* reflectors
*
* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a real scalar, and v is a real vector with
* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
* exit in A(i+2:ihi,i), and tau in TAU(i).
*
* The contents of A are illustrated by the following example, with
* n = 7, ilo = 2 and ihi = 6:
*
* on entry, on exit,
*
* ( a a a a a a a ) ( a a h h h h a )
* ( a a a a a a ) ( a h h h h a )
* ( a a a a a a ) ( h h h h h h )
* ( a a a a a a ) ( v2 h h h h h )
* ( a a a a a a ) ( v2 v3 h h h h )
* ( a a a a a a ) ( v2 v3 v4 h h h )
* ( a ) ( a )
*
* where a denotes an element of the original matrix A, h denotes a
* modified element of the upper Hessenberg matrix H, and vi denotes an
* element of the vector defining H(i).
*
* This file is a slight modification of LAPACK-3.0's SGEHRD
* subroutine incorporating improvements proposed by Quintana-Orti and
* Van de Geijn (2005).
*
* =====================================================================
*
* .. Parameters ..
INTEGER NBMAX, LDT
PARAMETER ( NBMAX = 64, LDT = NBMAX+1 )
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0,
$ ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IINFO, IWS, J, LDWORK, LWKOPT, NB,
$ NBMIN, NH, NX
REAL EI
* ..
* .. Local Arrays ..
REAL T( LDT, NBMAX )
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SGEHD2, SGEMM, SLAHR2, SLARFB, STRMM,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
NB = MIN( NBMAX, ILAENV( 1, 'SGEHRD', ' ', N, ILO, IHI, -1 ) )
LWKOPT = N*NB
WORK( 1 ) = LWKOPT
LQUERY = ( LWORK.EQ.-1 )
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
INFO = -2
ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGEHRD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero
*
DO 10 I = 1, ILO - 1
TAU( I ) = ZERO
10 CONTINUE
DO 20 I = MAX( 1, IHI ), N - 1
TAU( I ) = ZERO
20 CONTINUE
*
* Quick return if possible
*
NH = IHI - ILO + 1
IF( NH.LE.1 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
* Determine the block size
*
NB = MIN( NBMAX, ILAENV( 1, 'SGEHRD', ' ', N, ILO, IHI, -1 ) )
NBMIN = 2
IWS = 1
IF( NB.GT.1 .AND. NB.LT.NH ) THEN
*
* Determine when to cross over from blocked to unblocked code
* (last block is always handled by unblocked code)
*
NX = MAX( NB, ILAENV( 3, 'SGEHRD', ' ', N, ILO, IHI, -1 ) )
IF( NX.LT.NH ) THEN
*
* Determine if workspace is large enough for blocked code
*
IWS = N*NB
IF( LWORK.LT.IWS ) THEN
*
* Not enough workspace to use optimal NB: determine the
* minimum value of NB, and reduce NB or force use of
* unblocked code
*
NBMIN = MAX( 2, ILAENV( 2, 'SGEHRD', ' ', N, ILO, IHI,
$ -1 ) )
IF( LWORK.GE.N*NBMIN ) THEN
NB = LWORK / N
ELSE
NB = 1
END IF
END IF
END IF
END IF
LDWORK = N
*
IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN
*
* Use unblocked code below
*
I = ILO
*
ELSE
*
* Use blocked code
*
DO 40 I = ILO, IHI - 1 - NX, NB
IB = MIN( NB, IHI-I )
*
* Reduce columns i:i+ib-1 to Hessenberg form, returning the
* matrices V and T of the block reflector H = I - V*T*V'
* which performs the reduction, and also the matrix Y = A*V*T
*
CALL SLAHR2( IHI, I, IB, A( 1, I ), LDA, TAU( I ), T, LDT,
$ WORK, LDWORK )
*
* Apply the block reflector H to A(1:ihi,i+ib:ihi) from the
* right, computing A := A - Y * V'. V(i+ib,ib-1) must be set
* to 1
*
EI = A( I+IB, I+IB-1 )
A( I+IB, I+IB-1 ) = ONE
CALL SGEMM( 'No transpose', 'Transpose',
$ IHI, IHI-I-IB+1,
$ IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE,
$ A( 1, I+IB ), LDA )
A( I+IB, I+IB-1 ) = EI
*
* Apply the block reflector H to A(1:i,i+1:i+ib-1) from the
* right
*
CALL STRMM( 'Right', 'Lower', 'Transpose',
$ 'Unit', I, IB-1,
$ ONE, A( I+1, I ), LDA, WORK, LDWORK )
DO 30 J = 0, IB-2
CALL SAXPY( I, -ONE, WORK( LDWORK*J+1 ), 1,
$ A( 1, I+J+1 ), 1 )
30 CONTINUE
*
* Apply the block reflector H to A(i+1:ihi,i+ib:n) from the
* left
*
CALL SLARFB( 'Left', 'Transpose', 'Forward',
$ 'Columnwise',
$ IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA, T, LDT,
$ A( I+1, I+IB ), LDA, WORK, LDWORK )
40 CONTINUE
END IF
*
* Use unblocked code to reduce the rest of the matrix
*
CALL SGEHD2( N, I, IHI, A, LDA, TAU, WORK, IINFO )
WORK( 1 ) = IWS
*
RETURN
*
* End of SGEHRD
*
END
SUBROUTINE SGELQ2( M, N, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGELQ2 computes an LQ factorization of a real m by n matrix A:
* A = L * Q.
*
* 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) REAL array, dimension (LDA,N)
* On entry, the m by n matrix A.
* On exit, the elements on and below the diagonal of the array
* contain the m by min(m,n) lower trapezoidal matrix L (L is
* lower triangular if m <= n); the elements above 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) REAL array, dimension (min(M,N))
* The scalar factors of the elementary reflectors (see Further
* Details).
*
* WORK (workspace) REAL array, dimension (M)
*
* 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(k) . . . H(2) H(1), where k = min(m,n).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* 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:n) is stored on exit in A(i,i+1:n),
* and tau in TAU(i).
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, K
REAL AII
* ..
* .. External Subroutines ..
EXTERNAL SLARF, SLARFG, 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( 'SGELQ2', -INFO )
RETURN
END IF
*
K = MIN( M, N )
*
DO 10 I = 1, K
*
* Generate elementary reflector H(i) to annihilate A(i,i+1:n)
*
CALL SLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA,
$ TAU( I ) )
IF( I.LT.M ) THEN
*
* Apply H(i) to A(i+1:m,i:n) from the right
*
AII = A( I, I )
A( I, I ) = ONE
CALL SLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ),
$ A( I+1, I ), LDA, WORK )
A( I, I ) = AII
END IF
10 CONTINUE
RETURN
*
* End of SGELQ2
*
END
SUBROUTINE SGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGELQF computes an LQ factorization of a real M-by-N matrix A:
* A = L * Q.
*
* 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) REAL array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, the elements on and below the diagonal of the array
* contain the m-by-min(m,n) lower trapezoidal matrix L (L is
* lower triangular if m <= n); the elements above 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) REAL array, dimension (min(M,N))
* The scalar factors of the elementary reflectors (see Further
* Details).
*
* WORK (workspace/output) REAL 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,M).
* For optimum performance LWORK >= M*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(k) . . . H(2) H(1), where k = min(m,n).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* 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:n) is stored on exit in A(i,i+1:n),
* and tau in TAU(i).
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
$ NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL SGELQ2, SLARFB, SLARFT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
NB = ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
LWKOPT = M*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, M ) .AND. .NOT.LQUERY ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGELQF', -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 = M
IF( NB.GT.1 .AND. NB.LT.K ) THEN
*
* Determine when to cross over from blocked to unblocked code.
*
NX = MAX( 0, ILAENV( 3, 'SGELQF', ' ', M, N, -1, -1 ) )
IF( NX.LT.K ) THEN
*
* Determine if workspace is large enough for blocked code.
*
LDWORK = M
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, 'SGELQF', ' ', 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 LQ factorization of the current block
* A(i:i+ib-1,i:n)
*
CALL SGELQ2( IB, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
$ IINFO )
IF( I+IB.LE.M ) THEN
*
* Form the triangular factor of the block reflector
* H = H(i) H(i+1) . . . H(i+ib-1)
*
CALL SLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ),
$ LDA, TAU( I ), WORK, LDWORK )
*
* Apply H to A(i+ib:m,i:n) from the right
*
CALL SLARFB( 'Right', 'No transpose', 'Forward',
$ 'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ),
$ LDA, WORK, LDWORK, A( I+IB, I ), 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 SGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
$ IINFO )
*
WORK( 1 ) = IWS
RETURN
*
* End of SGELQF
*
END
SUBROUTINE SGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK,
$ INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGELS solves overdetermined or underdetermined real linear systems
* involving an M-by-N matrix A, or its transpose, using a QR or LQ
* factorization of A. It is assumed that A has full rank.
*
* The following options are provided:
*
* 1. If TRANS = 'N' and m >= n: find the least squares solution of
* an overdetermined system, i.e., solve the least squares problem
* minimize || B - A*X ||.
*
* 2. If TRANS = 'N' and m < n: find the minimum norm solution of
* an underdetermined system A * X = B.
*
* 3. If TRANS = 'T' and m >= n: find the minimum norm solution of
* an undetermined system A**T * X = B.
*
* 4. If TRANS = 'T' and m < n: find the least squares solution of
* an overdetermined system, i.e., solve the least squares problem
* minimize || B - A**T * X ||.
*
* Several right hand side vectors b and solution vectors x can be
* handled in a single call; they are stored as the columns of the
* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
* matrix X.
*
* Arguments
* =========
*
* TRANS (input) CHARACTER*1
* = 'N': the linear system involves A;
* = 'T': the linear system involves A**T.
*
* 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.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of
* columns of the matrices B and X. NRHS >=0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit,
* if M >= N, A is overwritten by details of its QR
* factorization as returned by SGEQRF;
* if M < N, A is overwritten by details of its LQ
* factorization as returned by SGELQF.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the matrix B of right hand side vectors, stored
* columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS
* if TRANS = 'T'.
* On exit, if INFO = 0, B is overwritten by the solution
* vectors, stored columnwise:
* if TRANS = 'N' and m >= n, rows 1 to n of B contain the least
* squares solution vectors; the residual sum of squares for the
* solution in each column is given by the sum of squares of
* elements N+1 to M in that column;
* if TRANS = 'N' and m < n, rows 1 to N of B contain the
* minimum norm solution vectors;
* if TRANS = 'T' and m >= n, rows 1 to M of B contain the
* minimum norm solution vectors;
* if TRANS = 'T' and m < n, rows 1 to M of B contain the
* least squares solution vectors; the residual sum of squares
* for the solution in each column is given by the sum of
* squares of elements M+1 to N in that column.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= MAX(1,M,N).
*
* WORK (workspace/output) REAL 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, MN + max( MN, NRHS ) ).
* For optimal performance,
* LWORK >= max( 1, MN + max( MN, NRHS )*NB ).
* where MN = min(M,N) and NB is the optimum block size.
*
* 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
* > 0: if INFO = i, the i-th diagonal element of the
* triangular factor of A is zero, so that A does not have
* full rank; the least squares solution could not be
* computed.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, TPSD
INTEGER BROW, I, IASCL, IBSCL, J, MN, NB, SCLLEN, WSIZE
REAL ANRM, BIGNUM, BNRM, SMLNUM
* ..
* .. Local Arrays ..
REAL RWORK( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
REAL SLAMCH, SLANGE
EXTERNAL LSAME, ILAENV, SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SGELQF, SGEQRF, SLABAD, SLASCL, SLASET, SORMLQ,
$ SORMQR, STRTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Executable Statements ..
*
* Test the input arguments.
*
INFO = 0
MN = MIN( M, N )
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.( LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'T' ) ) ) THEN
INFO = -1
ELSE IF( M.LT.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -6
ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
INFO = -8
ELSE IF( LWORK.LT.MAX( 1, MN + MAX( MN, NRHS ) ) .AND.
$ .NOT.LQUERY ) THEN
INFO = -10
END IF
*
* Figure out optimal block size
*
IF( INFO.EQ.0 .OR. INFO.EQ.-10 ) THEN
*
TPSD = .TRUE.
IF( LSAME( TRANS, 'N' ) )
$ TPSD = .FALSE.
*
IF( M.GE.N ) THEN
NB = ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
IF( TPSD ) THEN
NB = MAX( NB, ILAENV( 1, 'SORMQR', 'LN', M, NRHS, N,
$ -1 ) )
ELSE
NB = MAX( NB, ILAENV( 1, 'SORMQR', 'LT', M, NRHS, N,
$ -1 ) )
END IF
ELSE
NB = ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
IF( TPSD ) THEN
NB = MAX( NB, ILAENV( 1, 'SORMLQ', 'LT', N, NRHS, M,
$ -1 ) )
ELSE
NB = MAX( NB, ILAENV( 1, 'SORMLQ', 'LN', N, NRHS, M,
$ -1 ) )
END IF
END IF
*
WSIZE = MAX( 1, MN + MAX( MN, NRHS )*NB )
WORK( 1 ) = REAL( WSIZE )
*
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGELS ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( MIN( M, N, NRHS ).EQ.0 ) THEN
CALL SLASET( 'Full', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
RETURN
END IF
*
* Get machine parameters
*
SMLNUM = SLAMCH( 'S' ) / SLAMCH( 'P' )
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
*
* Scale A, B if max element outside range [SMLNUM,BIGNUM]
*
ANRM = SLANGE( 'M', M, N, A, LDA, RWORK )
IASCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
IASCL = 1
ELSE IF( ANRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
IASCL = 2
ELSE IF( ANRM.EQ.ZERO ) THEN
*
* Matrix all zero. Return zero solution.
*
CALL SLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
GO TO 50
END IF
*
BROW = M
IF( TPSD )
$ BROW = N
BNRM = SLANGE( 'M', BROW, NRHS, B, LDB, RWORK )
IBSCL = 0
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
CALL SLASCL( 'G', 0, 0, BNRM, SMLNUM, BROW, NRHS, B, LDB,
$ INFO )
IBSCL = 1
ELSE IF( BNRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
CALL SLASCL( 'G', 0, 0, BNRM, BIGNUM, BROW, NRHS, B, LDB,
$ INFO )
IBSCL = 2
END IF
*
IF( M.GE.N ) THEN
*
* compute QR factorization of A
*
CALL SGEQRF( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ), LWORK-MN,
$ INFO )
*
* workspace at least N, optimally N*NB
*
IF( .NOT.TPSD ) THEN
*
* Least-Squares Problem min || A * X - B ||
*
* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS)
*
CALL SORMQR( 'Left', 'Transpose', M, NRHS, N, A, LDA,
$ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
$ INFO )
*
* workspace at least NRHS, optimally NRHS*NB
*
* B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS)
*
CALL STRTRS( 'Upper', 'No transpose', 'Non-unit', N, NRHS,
$ A, LDA, B, LDB, INFO )
*
IF( INFO.GT.0 ) THEN
RETURN
END IF
*
SCLLEN = N
*
ELSE
*
* Overdetermined system of equations A' * X = B
*
* B(1:N,1:NRHS) := inv(R') * B(1:N,1:NRHS)
*
CALL STRTRS( 'Upper', 'Transpose', 'Non-unit', N, NRHS,
$ A, LDA, B, LDB, INFO )
*
IF( INFO.GT.0 ) THEN
RETURN
END IF
*
* B(N+1:M,1:NRHS) = ZERO
*
DO 20 J = 1, NRHS
DO 10 I = N + 1, M
B( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
*
* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS)
*
CALL SORMQR( 'Left', 'No transpose', M, NRHS, N, A, LDA,
$ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
$ INFO )
*
* workspace at least NRHS, optimally NRHS*NB
*
SCLLEN = M
*
END IF
*
ELSE
*
* Compute LQ factorization of A
*
CALL SGELQF( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ), LWORK-MN,
$ INFO )
*
* workspace at least M, optimally M*NB.
*
IF( .NOT.TPSD ) THEN
*
* underdetermined system of equations A * X = B
*
* B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS)
*
CALL STRTRS( 'Lower', 'No transpose', 'Non-unit', M, NRHS,
$ A, LDA, B, LDB, INFO )
*
IF( INFO.GT.0 ) THEN
RETURN
END IF
*
* B(M+1:N,1:NRHS) = 0
*
DO 40 J = 1, NRHS
DO 30 I = M + 1, N
B( I, J ) = ZERO
30 CONTINUE
40 CONTINUE
*
* B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS)
*
CALL SORMLQ( 'Left', 'Transpose', N, NRHS, M, A, LDA,
$ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
$ INFO )
*
* workspace at least NRHS, optimally NRHS*NB
*
SCLLEN = N
*
ELSE
*
* overdetermined system min || A' * X - B ||
*
* B(1:N,1:NRHS) := Q * B(1:N,1:NRHS)
*
CALL SORMLQ( 'Left', 'No transpose', N, NRHS, M, A, LDA,
$ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
$ INFO )
*
* workspace at least NRHS, optimally NRHS*NB
*
* B(1:M,1:NRHS) := inv(L') * B(1:M,1:NRHS)
*
CALL STRTRS( 'Lower', 'Transpose', 'Non-unit', M, NRHS,
$ A, LDA, B, LDB, INFO )
*
IF( INFO.GT.0 ) THEN
RETURN
END IF
*
SCLLEN = M
*
END IF
*
END IF
*
* Undo scaling
*
IF( IASCL.EQ.1 ) THEN
CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, SCLLEN, NRHS, B, LDB,
$ INFO )
ELSE IF( IASCL.EQ.2 ) THEN
CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, SCLLEN, NRHS, B, LDB,
$ INFO )
END IF
IF( IBSCL.EQ.1 ) THEN
CALL SLASCL( 'G', 0, 0, SMLNUM, BNRM, SCLLEN, NRHS, B, LDB,
$ INFO )
ELSE IF( IBSCL.EQ.2 ) THEN
CALL SLASCL( 'G', 0, 0, BIGNUM, BNRM, SCLLEN, NRHS, B, LDB,
$ INFO )
END IF
*
50 CONTINUE
WORK( 1 ) = REAL( WSIZE )
*
RETURN
*
* End of SGELS
*
END
SUBROUTINE SGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND,
$ RANK, WORK, LWORK, IWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
REAL RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL A( LDA, * ), B( LDB, * ), S( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGELSD computes the minimum-norm solution to a real linear least
* squares problem:
* minimize 2-norm(| b - A*x |)
* using the singular value decomposition (SVD) of A. A is an M-by-N
* matrix which may be rank-deficient.
*
* Several right hand side vectors b and solution vectors x can be
* handled in a single call; they are stored as the columns of the
* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
* matrix X.
*
* The problem is solved in three steps:
* (1) Reduce the coefficient matrix A to bidiagonal form with
* Householder transformations, reducing the original problem
* into a "bidiagonal least squares problem" (BLS)
* (2) Solve the BLS using a divide and conquer approach.
* (3) Apply back all the Householder tranformations to solve
* the original least squares problem.
*
* The effective rank of A is determined by treating as zero those
* singular values which are less than RCOND times the largest singular
* value.
*
* The divide and conquer algorithm makes very mild assumptions about
* floating point arithmetic. It will work on machines with a guard
* digit in add/subtract, or on those binary machines without guard
* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
* Cray-2. It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of A. M >= 0.
*
* N (input) INTEGER
* The number of columns of A. N >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrices B and X. NRHS >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, A has been destroyed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the M-by-NRHS right hand side matrix B.
* On exit, B is overwritten by the N-by-NRHS solution
* matrix X. If m >= n and RANK = n, the residual
* sum-of-squares for the solution in the i-th column is given
* by the sum of squares of elements n+1:m in that column.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,max(M,N)).
*
* S (output) REAL array, dimension (min(M,N))
* The singular values of A in decreasing order.
* The condition number of A in the 2-norm = S(1)/S(min(m,n)).
*
* RCOND (input) REAL
* RCOND is used to determine the effective rank of A.
* Singular values S(i) <= RCOND*S(1) are treated as zero.
* If RCOND < 0, machine precision is used instead.
*
* RANK (output) INTEGER
* The effective rank of A, i.e., the number of singular values
* which are greater than RCOND*S(1).
*
* WORK (workspace/output) REAL 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 must be at least 1.
* The exact minimum amount of workspace needed depends on M,
* N and NRHS. As long as LWORK is at least
* 12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2,
* if M is greater than or equal to N or
* 12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2,
* if M is less than N, the code will execute correctly.
* SMLSIZ is returned by ILAENV and is equal to the maximum
* size of the subproblems at the bottom of the computation
* tree (usually about 25), and
* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )
* For good performance, LWORK should generally be larger.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal size of the array WORK and the
* minimum size of the array IWORK, and returns these values as
* the first entries of the WORK and IWORK arrays, and no error
* message related to LWORK is issued by XERBLA.
*
* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))
* LIWORK >= max(1, 3*MINMN*NLVL + 11*MINMN),
* where MINMN = MIN( M,N ).
* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: the algorithm for computing the SVD failed to converge;
* if INFO = i, i off-diagonal elements of an intermediate
* bidiagonal form did not converge to zero.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Ren-Cang Li, Computer Science Division, University of
* California at Berkeley, USA
* Osni Marques, LBNL/NERSC, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER IASCL, IBSCL, IE, IL, ITAU, ITAUP, ITAUQ,
$ LDWORK, LIWORK, MAXMN, MAXWRK, MINMN, MINWRK,
$ MM, MNTHR, NLVL, NWORK, SMLSIZ, WLALSD
REAL ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM
* ..
* .. External Subroutines ..
EXTERNAL SGEBRD, SGELQF, SGEQRF, SLABAD, SLACPY, SLALSD,
$ SLASCL, SLASET, SORMBR, SORMLQ, SORMQR, XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
REAL SLAMCH, SLANGE
EXTERNAL SLAMCH, SLANGE, ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC INT, LOG, MAX, MIN, REAL
* ..
* .. Executable Statements ..
*
* Test the input arguments.
*
INFO = 0
MINMN = MIN( M, N )
MAXMN = MAX( M, N )
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) 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, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN
INFO = -7
END IF
*
* Compute workspace.
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.)
*
IF( INFO.EQ.0 ) THEN
MINWRK = 1
MAXWRK = 1
LIWORK = 1
IF( MINMN.GT.0 ) THEN
SMLSIZ = ILAENV( 9, 'SGELSD', ' ', 0, 0, 0, 0 )
MNTHR = ILAENV( 6, 'SGELSD', ' ', M, N, NRHS, -1 )
NLVL = MAX( INT( LOG( REAL( MINMN ) / REAL( SMLSIZ + 1 ) ) /
$ LOG( TWO ) ) + 1, 0 )
LIWORK = 3*MINMN*NLVL + 11*MINMN
MM = M
IF( M.GE.N .AND. M.GE.MNTHR ) THEN
*
* Path 1a - overdetermined, with many more rows than
* columns.
*
MM = N
MAXWRK = MAX( MAXWRK, N + N*ILAENV( 1, 'SGEQRF', ' ', M,
$ N, -1, -1 ) )
MAXWRK = MAX( MAXWRK, N + NRHS*ILAENV( 1, 'SORMQR', 'LT',
$ M, NRHS, N, -1 ) )
END IF
IF( M.GE.N ) THEN
*
* Path 1 - overdetermined or exactly determined.
*
MAXWRK = MAX( MAXWRK, 3*N + ( MM + N )*ILAENV( 1,
$ 'SGEBRD', ' ', MM, N, -1, -1 ) )
MAXWRK = MAX( MAXWRK, 3*N + NRHS*ILAENV( 1, 'SORMBR',
$ 'QLT', MM, NRHS, N, -1 ) )
MAXWRK = MAX( MAXWRK, 3*N + ( N - 1 )*ILAENV( 1,
$ 'SORMBR', 'PLN', N, NRHS, N, -1 ) )
WLALSD = 9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS +
$ ( SMLSIZ + 1 )**2
MAXWRK = MAX( MAXWRK, 3*N + WLALSD )
MINWRK = MAX( 3*N + MM, 3*N + NRHS, 3*N + WLALSD )
END IF
IF( N.GT.M ) THEN
WLALSD = 9*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS +
$ ( SMLSIZ + 1 )**2
IF( N.GE.MNTHR ) THEN
*
* Path 2a - underdetermined, with many more columns
* than rows.
*
MAXWRK = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1,
$ -1 )
MAXWRK = MAX( MAXWRK, M*M + 4*M + 2*M*ILAENV( 1,
$ 'SGEBRD', ' ', M, M, -1, -1 ) )
MAXWRK = MAX( MAXWRK, M*M + 4*M + NRHS*ILAENV( 1,
$ 'SORMBR', 'QLT', M, NRHS, M, -1 ) )
MAXWRK = MAX( MAXWRK, M*M + 4*M + ( M - 1 )*ILAENV( 1,
$ 'SORMBR', 'PLN', M, NRHS, M, -1 ) )
IF( NRHS.GT.1 ) THEN
MAXWRK = MAX( MAXWRK, M*M + M + M*NRHS )
ELSE
MAXWRK = MAX( MAXWRK, M*M + 2*M )
END IF
MAXWRK = MAX( MAXWRK, M + NRHS*ILAENV( 1, 'SORMLQ',
$ 'LT', N, NRHS, M, -1 ) )
MAXWRK = MAX( MAXWRK, M*M + 4*M + WLALSD )
ELSE
*
* Path 2 - remaining underdetermined cases.
*
MAXWRK = 3*M + ( N + M )*ILAENV( 1, 'SGEBRD', ' ', M,
$ N, -1, -1 )
MAXWRK = MAX( MAXWRK, 3*M + NRHS*ILAENV( 1, 'SORMBR',
$ 'QLT', M, NRHS, N, -1 ) )
MAXWRK = MAX( MAXWRK, 3*M + M*ILAENV( 1, 'SORMBR',
$ 'PLN', N, NRHS, M, -1 ) )
MAXWRK = MAX( MAXWRK, 3*M + WLALSD )
END IF
MINWRK = MAX( 3*M + NRHS, 3*M + M, 3*M + WLALSD )
END IF
END IF
MINWRK = MIN( MINWRK, MAXWRK )
WORK( 1 ) = MAXWRK
IWORK( 1 ) = LIWORK
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGELSD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible.
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
RANK = 0
RETURN
END IF
*
* Get machine parameters.
*
EPS = SLAMCH( 'P' )
SFMIN = SLAMCH( 'S' )
SMLNUM = SFMIN / EPS
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
*
* Scale A if max entry outside range [SMLNUM,BIGNUM].
*
ANRM = SLANGE( 'M', M, N, A, LDA, WORK )
IASCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM.
*
CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
IASCL = 1
ELSE IF( ANRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM.
*
CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
IASCL = 2
ELSE IF( ANRM.EQ.ZERO ) THEN
*
* Matrix all zero. Return zero solution.
*
CALL SLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
CALL SLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 )
RANK = 0
GO TO 10
END IF
*
* Scale B if max entry outside range [SMLNUM,BIGNUM].
*
BNRM = SLANGE( 'M', M, NRHS, B, LDB, WORK )
IBSCL = 0
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM.
*
CALL SLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
IBSCL = 1
ELSE IF( BNRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM.
*
CALL SLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
IBSCL = 2
END IF
*
* If M < N make sure certain entries of B are zero.
*
IF( M.LT.N )
$ CALL SLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB )
*
* Overdetermined case.
*
IF( M.GE.N ) THEN
*
* Path 1 - overdetermined or exactly determined.
*
MM = M
IF( M.GE.MNTHR ) THEN
*
* Path 1a - overdetermined, with many more rows than columns.
*
MM = N
ITAU = 1
NWORK = ITAU + N
*
* Compute A=Q*R.
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, INFO )
*
* Multiply B by transpose(Q).
* (Workspace: need N+NRHS, prefer N+NRHS*NB)
*
CALL SORMQR( 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAU ), B,
$ LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
* Zero out below R.
*
IF( N.GT.1 ) THEN
CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
END IF
END IF
*
IE = 1
ITAUQ = IE + N
ITAUP = ITAUQ + N
NWORK = ITAUP + N
*
* Bidiagonalize R in A.
* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB)
*
CALL SGEBRD( MM, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ INFO )
*
* Multiply B by transpose of left bidiagonalizing vectors of R.
* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB)
*
CALL SORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, WORK( ITAUQ ),
$ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
* Solve the bidiagonal least squares problem.
*
CALL SLALSD( 'U', SMLSIZ, N, NRHS, S, WORK( IE ), B, LDB,
$ RCOND, RANK, WORK( NWORK ), IWORK, INFO )
IF( INFO.NE.0 ) THEN
GO TO 10
END IF
*
* Multiply B by right bidiagonalizing vectors of R.
*
CALL SORMBR( 'P', 'L', 'N', N, NRHS, N, A, LDA, WORK( ITAUP ),
$ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+
$ MAX( M, 2*M-4, NRHS, N-3*M, WLALSD ) ) THEN
*
* Path 2a - underdetermined, with many more columns than rows
* and sufficient workspace for an efficient algorithm.
*
LDWORK = M
IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ),
$ M*LDA+M+M*NRHS, 4*M+M*LDA+WLALSD ) )LDWORK = LDA
ITAU = 1
NWORK = M + 1
*
* Compute A=L*Q.
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, INFO )
IL = NWORK
*
* Copy L to WORK(IL), zeroing out above its diagonal.
*
CALL SLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK )
CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( IL+LDWORK ),
$ LDWORK )
IE = IL + LDWORK*M
ITAUQ = IE + M
ITAUP = ITAUQ + M
NWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IL).
* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB)
*
CALL SGEBRD( M, M, WORK( IL ), LDWORK, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
$ LWORK-NWORK+1, INFO )
*
* Multiply B by transpose of left bidiagonalizing vectors of L.
* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB)
*
CALL SORMBR( 'Q', 'L', 'T', M, NRHS, M, WORK( IL ), LDWORK,
$ WORK( ITAUQ ), B, LDB, WORK( NWORK ),
$ LWORK-NWORK+1, INFO )
*
* Solve the bidiagonal least squares problem.
*
CALL SLALSD( 'U', SMLSIZ, M, NRHS, S, WORK( IE ), B, LDB,
$ RCOND, RANK, WORK( NWORK ), IWORK, INFO )
IF( INFO.NE.0 ) THEN
GO TO 10
END IF
*
* Multiply B by right bidiagonalizing vectors of L.
*
CALL SORMBR( 'P', 'L', 'N', M, NRHS, M, WORK( IL ), LDWORK,
$ WORK( ITAUP ), B, LDB, WORK( NWORK ),
$ LWORK-NWORK+1, INFO )
*
* Zero out below first M rows of B.
*
CALL SLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB )
NWORK = ITAU + M
*
* Multiply transpose(Q) by B.
* (Workspace: need M+NRHS, prefer M+NRHS*NB)
*
CALL SORMLQ( 'L', 'T', N, NRHS, M, A, LDA, WORK( ITAU ), B,
$ LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
ELSE
*
* Path 2 - remaining underdetermined cases.
*
IE = 1
ITAUQ = IE + M
ITAUP = ITAUQ + M
NWORK = ITAUP + M
*
* Bidiagonalize A.
* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
*
CALL SGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ INFO )
*
* Multiply B by transpose of left bidiagonalizing vectors.
* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB)
*
CALL SORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAUQ ),
$ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
* Solve the bidiagonal least squares problem.
*
CALL SLALSD( 'L', SMLSIZ, M, NRHS, S, WORK( IE ), B, LDB,
$ RCOND, RANK, WORK( NWORK ), IWORK, INFO )
IF( INFO.NE.0 ) THEN
GO TO 10
END IF
*
* Multiply B by right bidiagonalizing vectors of A.
*
CALL SORMBR( 'P', 'L', 'N', N, NRHS, M, A, LDA, WORK( ITAUP ),
$ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
END IF
*
* Undo scaling.
*
IF( IASCL.EQ.1 ) THEN
CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
$ INFO )
ELSE IF( IASCL.EQ.2 ) THEN
CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
$ INFO )
END IF
IF( IBSCL.EQ.1 ) THEN
CALL SLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
ELSE IF( IBSCL.EQ.2 ) THEN
CALL SLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
END IF
*
10 CONTINUE
WORK( 1 ) = MAXWRK
IWORK( 1 ) = LIWORK
RETURN
*
* End of SGELSD
*
END
SUBROUTINE SGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK,
$ WORK, LWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
REAL RCOND
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), S( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGELSS computes the minimum norm solution to a real linear least
* squares problem:
*
* Minimize 2-norm(| b - A*x |).
*
* using the singular value decomposition (SVD) of A. A is an M-by-N
* matrix which may be rank-deficient.
*
* Several right hand side vectors b and solution vectors x can be
* handled in a single call; they are stored as the columns of the
* M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix
* X.
*
* The effective rank of A is determined by treating as zero those
* singular values which are less than RCOND times the largest singular
* value.
*
* 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.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrices B and X. NRHS >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, the first min(m,n) rows of A are overwritten with
* its right singular vectors, stored rowwise.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the M-by-NRHS right hand side matrix B.
* On exit, B is overwritten by the N-by-NRHS solution
* matrix X. If m >= n and RANK = n, the residual
* sum-of-squares for the solution in the i-th column is given
* by the sum of squares of elements n+1:m in that column.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,max(M,N)).
*
* S (output) REAL array, dimension (min(M,N))
* The singular values of A in decreasing order.
* The condition number of A in the 2-norm = S(1)/S(min(m,n)).
*
* RCOND (input) REAL
* RCOND is used to determine the effective rank of A.
* Singular values S(i) <= RCOND*S(1) are treated as zero.
* If RCOND < 0, machine precision is used instead.
*
* RANK (output) INTEGER
* The effective rank of A, i.e., the number of singular values
* which are greater than RCOND*S(1).
*
* WORK (workspace/output) REAL 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 >= 1, and also:
* LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS )
* For good performance, LWORK should generally be larger.
*
* 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.
* > 0: the algorithm for computing the SVD failed to converge;
* if INFO = i, i off-diagonal elements of an intermediate
* bidiagonal form did not converge to zero.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER BDSPAC, BL, CHUNK, I, IASCL, IBSCL, IE, IL,
$ ITAU, ITAUP, ITAUQ, IWORK, LDWORK, MAXMN,
$ MAXWRK, MINMN, MINWRK, MM, MNTHR
REAL ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM, THR
* ..
* .. Local Arrays ..
REAL VDUM( 1 )
* ..
* .. External Subroutines ..
EXTERNAL SBDSQR, SCOPY, SGEBRD, SGELQF, SGEMM, SGEMV,
$ SGEQRF, SLABAD, SLACPY, SLASCL, SLASET, SORGBR,
$ SORMBR, SORMLQ, SORMQR, SRSCL, XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
REAL SLAMCH, SLANGE
EXTERNAL ILAENV, SLAMCH, SLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
MINMN = MIN( M, N )
MAXMN = MAX( M, N )
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) 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, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN
INFO = -7
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.)
*
IF( INFO.EQ.0 ) THEN
MINWRK = 1
MAXWRK = 1
IF( MINMN.GT.0 ) THEN
MM = M
MNTHR = ILAENV( 6, 'SGELSS', ' ', M, N, NRHS, -1 )
IF( M.GE.N .AND. M.GE.MNTHR ) THEN
*
* Path 1a - overdetermined, with many more rows than
* columns
*
MM = N
MAXWRK = MAX( MAXWRK, N + N*ILAENV( 1, 'SGEQRF', ' ', M,
$ N, -1, -1 ) )
MAXWRK = MAX( MAXWRK, N + NRHS*ILAENV( 1, 'SORMQR', 'LT',
$ M, NRHS, N, -1 ) )
END IF
IF( M.GE.N ) THEN
*
* Path 1 - overdetermined or exactly determined
*
* Compute workspace needed for SBDSQR
*
BDSPAC = MAX( 1, 5*N )
MAXWRK = MAX( MAXWRK, 3*N + ( MM + N )*ILAENV( 1,
$ 'SGEBRD', ' ', MM, N, -1, -1 ) )
MAXWRK = MAX( MAXWRK, 3*N + NRHS*ILAENV( 1, 'SORMBR',
$ 'QLT', MM, NRHS, N, -1 ) )
MAXWRK = MAX( MAXWRK, 3*N + ( N - 1 )*ILAENV( 1,
$ 'SORGBR', 'P', N, N, N, -1 ) )
MAXWRK = MAX( MAXWRK, BDSPAC )
MAXWRK = MAX( MAXWRK, N*NRHS )
MINWRK = MAX( 3*N + MM, 3*N + NRHS, BDSPAC )
MAXWRK = MAX( MINWRK, MAXWRK )
END IF
IF( N.GT.M ) THEN
*
* Compute workspace needed for SBDSQR
*
BDSPAC = MAX( 1, 5*M )
MINWRK = MAX( 3*M+NRHS, 3*M+N, BDSPAC )
IF( N.GE.MNTHR ) THEN
*
* Path 2a - underdetermined, with many more columns
* than rows
*
MAXWRK = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1,
$ -1 )
MAXWRK = MAX( MAXWRK, M*M + 4*M + 2*M*ILAENV( 1,
$ 'SGEBRD', ' ', M, M, -1, -1 ) )
MAXWRK = MAX( MAXWRK, M*M + 4*M + NRHS*ILAENV( 1,
$ 'SORMBR', 'QLT', M, NRHS, M, -1 ) )
MAXWRK = MAX( MAXWRK, M*M + 4*M +
$ ( M - 1 )*ILAENV( 1, 'SORGBR', 'P', M,
$ M, M, -1 ) )
MAXWRK = MAX( MAXWRK, M*M + M + BDSPAC )
IF( NRHS.GT.1 ) THEN
MAXWRK = MAX( MAXWRK, M*M + M + M*NRHS )
ELSE
MAXWRK = MAX( MAXWRK, M*M + 2*M )
END IF
MAXWRK = MAX( MAXWRK, M + NRHS*ILAENV( 1, 'SORMLQ',
$ 'LT', N, NRHS, M, -1 ) )
ELSE
*
* Path 2 - underdetermined
*
MAXWRK = 3*M + ( N + M )*ILAENV( 1, 'SGEBRD', ' ', M,
$ N, -1, -1 )
MAXWRK = MAX( MAXWRK, 3*M + NRHS*ILAENV( 1, 'SORMBR',
$ 'QLT', M, NRHS, M, -1 ) )
MAXWRK = MAX( MAXWRK, 3*M + M*ILAENV( 1, 'SORGBR',
$ 'P', M, N, M, -1 ) )
MAXWRK = MAX( MAXWRK, BDSPAC )
MAXWRK = MAX( MAXWRK, N*NRHS )
END IF
END IF
MAXWRK = MAX( MINWRK, MAXWRK )
END IF
WORK( 1 ) = MAXWRK
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY )
$ INFO = -12
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGELSS', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
RANK = 0
RETURN
END IF
*
* Get machine parameters
*
EPS = SLAMCH( 'P' )
SFMIN = SLAMCH( 'S' )
SMLNUM = SFMIN / EPS
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = SLANGE( 'M', M, N, A, LDA, WORK )
IASCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
IASCL = 1
ELSE IF( ANRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
IASCL = 2
ELSE IF( ANRM.EQ.ZERO ) THEN
*
* Matrix all zero. Return zero solution.
*
CALL SLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
CALL SLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 )
RANK = 0
GO TO 70
END IF
*
* Scale B if max element outside range [SMLNUM,BIGNUM]
*
BNRM = SLANGE( 'M', M, NRHS, B, LDB, WORK )
IBSCL = 0
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
CALL SLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
IBSCL = 1
ELSE IF( BNRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
CALL SLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
IBSCL = 2
END IF
*
* Overdetermined case
*
IF( M.GE.N ) THEN
*
* Path 1 - overdetermined or exactly determined
*
MM = M
IF( M.GE.MNTHR ) THEN
*
* Path 1a - overdetermined, with many more rows than columns
*
MM = N
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
$ LWORK-IWORK+1, INFO )
*
* Multiply B by transpose(Q)
* (Workspace: need N+NRHS, prefer N+NRHS*NB)
*
CALL SORMQR( 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAU ), B,
$ LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
*
* Zero out below R
*
IF( N.GT.1 )
$ CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
END IF
*
IE = 1
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in A
* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB)
*
CALL SGEBRD( MM, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
$ INFO )
*
* Multiply B by transpose of left bidiagonalizing vectors of R
* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB)
*
CALL SORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, WORK( ITAUQ ),
$ B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
*
* Generate right bidiagonalizing vectors of R in A
* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
*
CALL SORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, INFO )
IWORK = IE + N
*
* Perform bidiagonal QR iteration
* multiply B by transpose of left singular vectors
* compute right singular vectors in A
* (Workspace: need BDSPAC)
*
CALL SBDSQR( 'U', N, N, 0, NRHS, S, WORK( IE ), A, LDA, VDUM,
$ 1, B, LDB, WORK( IWORK ), INFO )
IF( INFO.NE.0 )
$ GO TO 70
*
* Multiply B by reciprocals of singular values
*
THR = MAX( RCOND*S( 1 ), SFMIN )
IF( RCOND.LT.ZERO )
$ THR = MAX( EPS*S( 1 ), SFMIN )
RANK = 0
DO 10 I = 1, N
IF( S( I ).GT.THR ) THEN
CALL SRSCL( NRHS, S( I ), B( I, 1 ), LDB )
RANK = RANK + 1
ELSE
CALL SLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
END IF
10 CONTINUE
*
* Multiply B by right singular vectors
* (Workspace: need N, prefer N*NRHS)
*
IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN
CALL SGEMM( 'T', 'N', N, NRHS, N, ONE, A, LDA, B, LDB, ZERO,
$ WORK, LDB )
CALL SLACPY( 'G', N, NRHS, WORK, LDB, B, LDB )
ELSE IF( NRHS.GT.1 ) THEN
CHUNK = LWORK / N
DO 20 I = 1, NRHS, CHUNK
BL = MIN( NRHS-I+1, CHUNK )
CALL SGEMM( 'T', 'N', N, BL, N, ONE, A, LDA, B( 1, I ),
$ LDB, ZERO, WORK, N )
CALL SLACPY( 'G', N, BL, WORK, N, B( 1, I ), LDB )
20 CONTINUE
ELSE
CALL SGEMV( 'T', N, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 )
CALL SCOPY( N, WORK, 1, B, 1 )
END IF
*
ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+
$ MAX( M, 2*M-4, NRHS, N-3*M ) ) THEN
*
* Path 2a - underdetermined, with many more columns than rows
* and sufficient workspace for an efficient algorithm
*
LDWORK = M
IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ),
$ M*LDA+M+M*NRHS ) )LDWORK = LDA
ITAU = 1
IWORK = M + 1
*
* Compute A=L*Q
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
$ LWORK-IWORK+1, INFO )
IL = IWORK
*
* Copy L to WORK(IL), zeroing out above it
*
CALL SLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK )
CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( IL+LDWORK ),
$ LDWORK )
IE = IL + LDWORK*M
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IL)
* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB)
*
CALL SGEBRD( M, M, WORK( IL ), LDWORK, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, INFO )
*
* Multiply B by transpose of left bidiagonalizing vectors of L
* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB)
*
CALL SORMBR( 'Q', 'L', 'T', M, NRHS, M, WORK( IL ), LDWORK,
$ WORK( ITAUQ ), B, LDB, WORK( IWORK ),
$ LWORK-IWORK+1, INFO )
*
* Generate right bidiagonalizing vectors of R in WORK(IL)
* (Workspace: need M*M+5*M-1, prefer M*M+4*M+(M-1)*NB)
*
CALL SORGBR( 'P', M, M, M, WORK( IL ), LDWORK, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, INFO )
IWORK = IE + M
*
* Perform bidiagonal QR iteration,
* computing right singular vectors of L in WORK(IL) and
* multiplying B by transpose of left singular vectors
* (Workspace: need M*M+M+BDSPAC)
*
CALL SBDSQR( 'U', M, M, 0, NRHS, S, WORK( IE ), WORK( IL ),
$ LDWORK, A, LDA, B, LDB, WORK( IWORK ), INFO )
IF( INFO.NE.0 )
$ GO TO 70
*
* Multiply B by reciprocals of singular values
*
THR = MAX( RCOND*S( 1 ), SFMIN )
IF( RCOND.LT.ZERO )
$ THR = MAX( EPS*S( 1 ), SFMIN )
RANK = 0
DO 30 I = 1, M
IF( S( I ).GT.THR ) THEN
CALL SRSCL( NRHS, S( I ), B( I, 1 ), LDB )
RANK = RANK + 1
ELSE
CALL SLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
END IF
30 CONTINUE
IWORK = IE
*
* Multiply B by right singular vectors of L in WORK(IL)
* (Workspace: need M*M+2*M, prefer M*M+M+M*NRHS)
*
IF( LWORK.GE.LDB*NRHS+IWORK-1 .AND. NRHS.GT.1 ) THEN
CALL SGEMM( 'T', 'N', M, NRHS, M, ONE, WORK( IL ), LDWORK,
$ B, LDB, ZERO, WORK( IWORK ), LDB )
CALL SLACPY( 'G', M, NRHS, WORK( IWORK ), LDB, B, LDB )
ELSE IF( NRHS.GT.1 ) THEN
CHUNK = ( LWORK-IWORK+1 ) / M
DO 40 I = 1, NRHS, CHUNK
BL = MIN( NRHS-I+1, CHUNK )
CALL SGEMM( 'T', 'N', M, BL, M, ONE, WORK( IL ), LDWORK,
$ B( 1, I ), LDB, ZERO, WORK( IWORK ), M )
CALL SLACPY( 'G', M, BL, WORK( IWORK ), M, B( 1, I ),
$ LDB )
40 CONTINUE
ELSE
CALL SGEMV( 'T', M, M, ONE, WORK( IL ), LDWORK, B( 1, 1 ),
$ 1, ZERO, WORK( IWORK ), 1 )
CALL SCOPY( M, WORK( IWORK ), 1, B( 1, 1 ), 1 )
END IF
*
* Zero out below first M rows of B
*
CALL SLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB )
IWORK = ITAU + M
*
* Multiply transpose(Q) by B
* (Workspace: need M+NRHS, prefer M+NRHS*NB)
*
CALL SORMLQ( 'L', 'T', N, NRHS, M, A, LDA, WORK( ITAU ), B,
$ LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
*
ELSE
*
* Path 2 - remaining underdetermined cases
*
IE = 1
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize A
* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
*
CALL SGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
$ INFO )
*
* Multiply B by transpose of left bidiagonalizing vectors
* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB)
*
CALL SORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAUQ ),
$ B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
*
* Generate right bidiagonalizing vectors in A
* (Workspace: need 4*M, prefer 3*M+M*NB)
*
CALL SORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, INFO )
IWORK = IE + M
*
* Perform bidiagonal QR iteration,
* computing right singular vectors of A in A and
* multiplying B by transpose of left singular vectors
* (Workspace: need BDSPAC)
*
CALL SBDSQR( 'L', M, N, 0, NRHS, S, WORK( IE ), A, LDA, VDUM,
$ 1, B, LDB, WORK( IWORK ), INFO )
IF( INFO.NE.0 )
$ GO TO 70
*
* Multiply B by reciprocals of singular values
*
THR = MAX( RCOND*S( 1 ), SFMIN )
IF( RCOND.LT.ZERO )
$ THR = MAX( EPS*S( 1 ), SFMIN )
RANK = 0
DO 50 I = 1, M
IF( S( I ).GT.THR ) THEN
CALL SRSCL( NRHS, S( I ), B( I, 1 ), LDB )
RANK = RANK + 1
ELSE
CALL SLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
END IF
50 CONTINUE
*
* Multiply B by right singular vectors of A
* (Workspace: need N, prefer N*NRHS)
*
IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN
CALL SGEMM( 'T', 'N', N, NRHS, M, ONE, A, LDA, B, LDB, ZERO,
$ WORK, LDB )
CALL SLACPY( 'F', N, NRHS, WORK, LDB, B, LDB )
ELSE IF( NRHS.GT.1 ) THEN
CHUNK = LWORK / N
DO 60 I = 1, NRHS, CHUNK
BL = MIN( NRHS-I+1, CHUNK )
CALL SGEMM( 'T', 'N', N, BL, M, ONE, A, LDA, B( 1, I ),
$ LDB, ZERO, WORK, N )
CALL SLACPY( 'F', N, BL, WORK, N, B( 1, I ), LDB )
60 CONTINUE
ELSE
CALL SGEMV( 'T', M, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 )
CALL SCOPY( N, WORK, 1, B, 1 )
END IF
END IF
*
* Undo scaling
*
IF( IASCL.EQ.1 ) THEN
CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
$ INFO )
ELSE IF( IASCL.EQ.2 ) THEN
CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
$ INFO )
END IF
IF( IBSCL.EQ.1 ) THEN
CALL SLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
ELSE IF( IBSCL.EQ.2 ) THEN
CALL SLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
END IF
*
70 CONTINUE
WORK( 1 ) = MAXWRK
RETURN
*
* End of SGELSS
*
END
SUBROUTINE SGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK,
$ WORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, M, N, NRHS, RANK
REAL RCOND
* ..
* .. Array Arguments ..
INTEGER JPVT( * )
REAL A( LDA, * ), B( LDB, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* This routine is deprecated and has been replaced by routine SGELSY.
*
* SGELSX computes the minimum-norm solution to a real linear least
* squares problem:
* minimize || A * X - B ||
* using a complete orthogonal factorization of A. A is an M-by-N
* matrix which may be rank-deficient.
*
* Several right hand side vectors b and solution vectors x can be
* handled in a single call; they are stored as the columns of the
* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
* matrix X.
*
* The routine first computes a QR factorization with column pivoting:
* A * P = Q * [ R11 R12 ]
* [ 0 R22 ]
* with R11 defined as the largest leading submatrix whose estimated
* condition number is less than 1/RCOND. The order of R11, RANK,
* is the effective rank of A.
*
* Then, R22 is considered to be negligible, and R12 is annihilated
* by orthogonal transformations from the right, arriving at the
* complete orthogonal factorization:
* A * P = Q * [ T11 0 ] * Z
* [ 0 0 ]
* The minimum-norm solution is then
* X = P * Z' [ inv(T11)*Q1'*B ]
* [ 0 ]
* where Q1 consists of the first RANK columns of Q.
*
* 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.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of
* columns of matrices B and X. NRHS >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, A has been overwritten by details of its
* complete orthogonal factorization.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the M-by-NRHS right hand side matrix B.
* On exit, the N-by-NRHS solution matrix X.
* If m >= n and RANK = n, the residual sum-of-squares for
* the solution in the i-th column is given by the sum of
* squares of elements N+1:M in that column.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,M,N).
*
* JPVT (input/output) INTEGER array, dimension (N)
* On entry, if JPVT(i) .ne. 0, the i-th column of A is an
* initial column, otherwise it is a free column. Before
* the QR factorization of A, all initial columns are
* permuted to the leading positions; only the remaining
* free columns are moved as a result of column pivoting
* during the factorization.
* On exit, if JPVT(i) = k, then the i-th column of A*P
* was the k-th column of A.
*
* RCOND (input) REAL
* RCOND is used to determine the effective rank of A, which
* is defined as the order of the largest leading triangular
* submatrix R11 in the QR factorization with pivoting of A,
* whose estimated condition number < 1/RCOND.
*
* RANK (output) INTEGER
* The effective rank of A, i.e., the order of the submatrix
* R11. This is the same as the order of the submatrix T11
* in the complete orthogonal factorization of A.
*
* WORK (workspace) REAL array, dimension
* (max( min(M,N)+3*N, 2*min(M,N)+NRHS )),
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
INTEGER IMAX, IMIN
PARAMETER ( IMAX = 1, IMIN = 2 )
REAL ZERO, ONE, DONE, NTDONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, DONE = ZERO,
$ NTDONE = ONE )
* ..
* .. Local Scalars ..
INTEGER I, IASCL, IBSCL, ISMAX, ISMIN, J, K, MN
REAL ANRM, BIGNUM, BNRM, C1, C2, S1, S2, SMAX,
$ SMAXPR, SMIN, SMINPR, SMLNUM, T1, T2
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE
EXTERNAL SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SGEQPF, SLABAD, SLAIC1, SLASCL, SLASET, SLATZM,
$ SORM2R, STRSM, STZRQF, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
MN = MIN( M, N )
ISMIN = MN + 1
ISMAX = 2*MN + 1
*
* Test the input arguments.
*
INFO = 0
IF( M.LT.0 ) 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, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
INFO = -7
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGELSX', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( MIN( M, N, NRHS ).EQ.0 ) THEN
RANK = 0
RETURN
END IF
*
* Get machine parameters
*
SMLNUM = SLAMCH( 'S' ) / SLAMCH( 'P' )
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
*
* Scale A, B if max elements outside range [SMLNUM,BIGNUM]
*
ANRM = SLANGE( 'M', M, N, A, LDA, WORK )
IASCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
IASCL = 1
ELSE IF( ANRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
IASCL = 2
ELSE IF( ANRM.EQ.ZERO ) THEN
*
* Matrix all zero. Return zero solution.
*
CALL SLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
RANK = 0
GO TO 100
END IF
*
BNRM = SLANGE( 'M', M, NRHS, B, LDB, WORK )
IBSCL = 0
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
CALL SLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
IBSCL = 1
ELSE IF( BNRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
CALL SLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
IBSCL = 2
END IF
*
* Compute QR factorization with column pivoting of A:
* A * P = Q * R
*
CALL SGEQPF( M, N, A, LDA, JPVT, WORK( 1 ), WORK( MN+1 ), INFO )
*
* workspace 3*N. Details of Householder rotations stored
* in WORK(1:MN).
*
* Determine RANK using incremental condition estimation
*
WORK( ISMIN ) = ONE
WORK( ISMAX ) = ONE
SMAX = ABS( A( 1, 1 ) )
SMIN = SMAX
IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN
RANK = 0
CALL SLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
GO TO 100
ELSE
RANK = 1
END IF
*
10 CONTINUE
IF( RANK.LT.MN ) THEN
I = RANK + 1
CALL SLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ),
$ A( I, I ), SMINPR, S1, C1 )
CALL SLAIC1( IMAX, RANK, WORK( ISMAX ), SMAX, A( 1, I ),
$ A( I, I ), SMAXPR, S2, C2 )
*
IF( SMAXPR*RCOND.LE.SMINPR ) THEN
DO 20 I = 1, RANK
WORK( ISMIN+I-1 ) = S1*WORK( ISMIN+I-1 )
WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 )
20 CONTINUE
WORK( ISMIN+RANK ) = C1
WORK( ISMAX+RANK ) = C2
SMIN = SMINPR
SMAX = SMAXPR
RANK = RANK + 1
GO TO 10
END IF
END IF
*
* Logically partition R = [ R11 R12 ]
* [ 0 R22 ]
* where R11 = R(1:RANK,1:RANK)
*
* [R11,R12] = [ T11, 0 ] * Y
*
IF( RANK.LT.N )
$ CALL STZRQF( RANK, N, A, LDA, WORK( MN+1 ), INFO )
*
* Details of Householder rotations stored in WORK(MN+1:2*MN)
*
* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS)
*
CALL SORM2R( 'Left', 'Transpose', M, NRHS, MN, A, LDA, WORK( 1 ),
$ B, LDB, WORK( 2*MN+1 ), INFO )
*
* workspace NRHS
*
* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS)
*
CALL STRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK,
$ NRHS, ONE, A, LDA, B, LDB )
*
DO 40 I = RANK + 1, N
DO 30 J = 1, NRHS
B( I, J ) = ZERO
30 CONTINUE
40 CONTINUE
*
* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS)
*
IF( RANK.LT.N ) THEN
DO 50 I = 1, RANK
CALL SLATZM( 'Left', N-RANK+1, NRHS, A( I, RANK+1 ), LDA,
$ WORK( MN+I ), B( I, 1 ), B( RANK+1, 1 ), LDB,
$ WORK( 2*MN+1 ) )
50 CONTINUE
END IF
*
* workspace NRHS
*
* B(1:N,1:NRHS) := P * B(1:N,1:NRHS)
*
DO 90 J = 1, NRHS
DO 60 I = 1, N
WORK( 2*MN+I ) = NTDONE
60 CONTINUE
DO 80 I = 1, N
IF( WORK( 2*MN+I ).EQ.NTDONE ) THEN
IF( JPVT( I ).NE.I ) THEN
K = I
T1 = B( K, J )
T2 = B( JPVT( K ), J )
70 CONTINUE
B( JPVT( K ), J ) = T1
WORK( 2*MN+K ) = DONE
T1 = T2
K = JPVT( K )
T2 = B( JPVT( K ), J )
IF( JPVT( K ).NE.I )
$ GO TO 70
B( I, J ) = T1
WORK( 2*MN+K ) = DONE
END IF
END IF
80 CONTINUE
90 CONTINUE
*
* Undo scaling
*
IF( IASCL.EQ.1 ) THEN
CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
CALL SLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA,
$ INFO )
ELSE IF( IASCL.EQ.2 ) THEN
CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
CALL SLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA,
$ INFO )
END IF
IF( IBSCL.EQ.1 ) THEN
CALL SLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
ELSE IF( IBSCL.EQ.2 ) THEN
CALL SLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
END IF
*
100 CONTINUE
*
RETURN
*
* End of SGELSX
*
END
SUBROUTINE SGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK,
$ WORK, LWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
REAL RCOND
* ..
* .. Array Arguments ..
INTEGER JPVT( * )
REAL A( LDA, * ), B( LDB, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGELSY computes the minimum-norm solution to a real linear least
* squares problem:
* minimize || A * X - B ||
* using a complete orthogonal factorization of A. A is an M-by-N
* matrix which may be rank-deficient.
*
* Several right hand side vectors b and solution vectors x can be
* handled in a single call; they are stored as the columns of the
* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
* matrix X.
*
* The routine first computes a QR factorization with column pivoting:
* A * P = Q * [ R11 R12 ]
* [ 0 R22 ]
* with R11 defined as the largest leading submatrix whose estimated
* condition number is less than 1/RCOND. The order of R11, RANK,
* is the effective rank of A.
*
* Then, R22 is considered to be negligible, and R12 is annihilated
* by orthogonal transformations from the right, arriving at the
* complete orthogonal factorization:
* A * P = Q * [ T11 0 ] * Z
* [ 0 0 ]
* The minimum-norm solution is then
* X = P * Z' [ inv(T11)*Q1'*B ]
* [ 0 ]
* where Q1 consists of the first RANK columns of Q.
*
* This routine is basically identical to the original xGELSX except
* three differences:
* o The call to the subroutine xGEQPF has been substituted by the
* the call to the subroutine xGEQP3. This subroutine is a Blas-3
* version of the QR factorization with column pivoting.
* o Matrix B (the right hand side) is updated with Blas-3.
* o The permutation of matrix B (the right hand side) is faster and
* more simple.
*
* 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.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of
* columns of matrices B and X. NRHS >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, A has been overwritten by details of its
* complete orthogonal factorization.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the M-by-NRHS right hand side matrix B.
* On exit, the N-by-NRHS solution matrix X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,M,N).
*
* JPVT (input/output) INTEGER array, dimension (N)
* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
* to the front of AP, otherwise column i is a free column.
* On exit, if JPVT(i) = k, then the i-th column of AP
* was the k-th column of A.
*
* RCOND (input) REAL
* RCOND is used to determine the effective rank of A, which
* is defined as the order of the largest leading triangular
* submatrix R11 in the QR factorization with pivoting of A,
* whose estimated condition number < 1/RCOND.
*
* RANK (output) INTEGER
* The effective rank of A, i.e., the order of the submatrix
* R11. This is the same as the order of the submatrix T11
* in the complete orthogonal factorization of A.
*
* WORK (workspace/output) REAL 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.
* The unblocked strategy requires that:
* LWORK >= MAX( MN+3*N+1, 2*MN+NRHS ),
* where MN = min( M, N ).
* The block algorithm requires that:
* LWORK >= MAX( MN+2*N+NB*(N+1), 2*MN+NB*NRHS ),
* where NB is an upper bound on the blocksize returned
* by ILAENV for the routines SGEQP3, STZRZF, STZRQF, SORMQR,
* and SORMRZ.
*
* 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
* ===============
*
* Based on contributions by
* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
* E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
*
* =====================================================================
*
* .. Parameters ..
INTEGER IMAX, IMIN
PARAMETER ( IMAX = 1, IMIN = 2 )
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IASCL, IBSCL, ISMAX, ISMIN, J, LWKMIN,
$ LWKOPT, MN, NB, NB1, NB2, NB3, NB4
REAL ANRM, BIGNUM, BNRM, C1, C2, S1, S2, SMAX,
$ SMAXPR, SMIN, SMINPR, SMLNUM, WSIZE
* ..
* .. External Functions ..
INTEGER ILAENV
REAL SLAMCH, SLANGE
EXTERNAL ILAENV, SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEQP3, SLABAD, SLAIC1, SLASCL, SLASET,
$ SORMQR, SORMRZ, STRSM, STZRZF, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
MN = MIN( M, N )
ISMIN = MN + 1
ISMAX = 2*MN + 1
*
* Test the 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( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
INFO = -7
END IF
*
* Figure out optimal block size
*
IF( INFO.EQ.0 ) THEN
IF( MN.EQ.0 .OR. NRHS.EQ.0 ) THEN
LWKMIN = 1
LWKOPT = 1
ELSE
NB1 = ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
NB2 = ILAENV( 1, 'SGERQF', ' ', M, N, -1, -1 )
NB3 = ILAENV( 1, 'SORMQR', ' ', M, N, NRHS, -1 )
NB4 = ILAENV( 1, 'SORMRQ', ' ', M, N, NRHS, -1 )
NB = MAX( NB1, NB2, NB3, NB4 )
LWKMIN = MN + MAX( 2*MN, N + 1, MN + NRHS )
LWKOPT = MAX( LWKMIN,
$ MN + 2*N + NB*( N + 1 ), 2*MN + NB*NRHS )
END IF
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGELSY', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( MN.EQ.0 .OR. NRHS.EQ.0 ) THEN
RANK = 0
RETURN
END IF
*
* Get machine parameters
*
SMLNUM = SLAMCH( 'S' ) / SLAMCH( 'P' )
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
*
* Scale A, B if max entries outside range [SMLNUM,BIGNUM]
*
ANRM = SLANGE( 'M', M, N, A, LDA, WORK )
IASCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
IASCL = 1
ELSE IF( ANRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
IASCL = 2
ELSE IF( ANRM.EQ.ZERO ) THEN
*
* Matrix all zero. Return zero solution.
*
CALL SLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
RANK = 0
GO TO 70
END IF
*
BNRM = SLANGE( 'M', M, NRHS, B, LDB, WORK )
IBSCL = 0
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
CALL SLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
IBSCL = 1
ELSE IF( BNRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
CALL SLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
IBSCL = 2
END IF
*
* Compute QR factorization with column pivoting of A:
* A * P = Q * R
*
CALL SGEQP3( M, N, A, LDA, JPVT, WORK( 1 ), WORK( MN+1 ),
$ LWORK-MN, INFO )
WSIZE = MN + WORK( MN+1 )
*
* workspace: MN+2*N+NB*(N+1).
* Details of Householder rotations stored in WORK(1:MN).
*
* Determine RANK using incremental condition estimation
*
WORK( ISMIN ) = ONE
WORK( ISMAX ) = ONE
SMAX = ABS( A( 1, 1 ) )
SMIN = SMAX
IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN
RANK = 0
CALL SLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
GO TO 70
ELSE
RANK = 1
END IF
*
10 CONTINUE
IF( RANK.LT.MN ) THEN
I = RANK + 1
CALL SLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ),
$ A( I, I ), SMINPR, S1, C1 )
CALL SLAIC1( IMAX, RANK, WORK( ISMAX ), SMAX, A( 1, I ),
$ A( I, I ), SMAXPR, S2, C2 )
*
IF( SMAXPR*RCOND.LE.SMINPR ) THEN
DO 20 I = 1, RANK
WORK( ISMIN+I-1 ) = S1*WORK( ISMIN+I-1 )
WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 )
20 CONTINUE
WORK( ISMIN+RANK ) = C1
WORK( ISMAX+RANK ) = C2
SMIN = SMINPR
SMAX = SMAXPR
RANK = RANK + 1
GO TO 10
END IF
END IF
*
* workspace: 3*MN.
*
* Logically partition R = [ R11 R12 ]
* [ 0 R22 ]
* where R11 = R(1:RANK,1:RANK)
*
* [R11,R12] = [ T11, 0 ] * Y
*
IF( RANK.LT.N )
$ CALL STZRZF( RANK, N, A, LDA, WORK( MN+1 ), WORK( 2*MN+1 ),
$ LWORK-2*MN, INFO )
*
* workspace: 2*MN.
* Details of Householder rotations stored in WORK(MN+1:2*MN)
*
* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS)
*
CALL SORMQR( 'Left', 'Transpose', M, NRHS, MN, A, LDA, WORK( 1 ),
$ B, LDB, WORK( 2*MN+1 ), LWORK-2*MN, INFO )
WSIZE = MAX( WSIZE, 2*MN+WORK( 2*MN+1 ) )
*
* workspace: 2*MN+NB*NRHS.
*
* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS)
*
CALL STRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK,
$ NRHS, ONE, A, LDA, B, LDB )
*
DO 40 J = 1, NRHS
DO 30 I = RANK + 1, N
B( I, J ) = ZERO
30 CONTINUE
40 CONTINUE
*
* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS)
*
IF( RANK.LT.N ) THEN
CALL SORMRZ( 'Left', 'Transpose', N, NRHS, RANK, N-RANK, A,
$ LDA, WORK( MN+1 ), B, LDB, WORK( 2*MN+1 ),
$ LWORK-2*MN, INFO )
END IF
*
* workspace: 2*MN+NRHS.
*
* B(1:N,1:NRHS) := P * B(1:N,1:NRHS)
*
DO 60 J = 1, NRHS
DO 50 I = 1, N
WORK( JPVT( I ) ) = B( I, J )
50 CONTINUE
CALL SCOPY( N, WORK( 1 ), 1, B( 1, J ), 1 )
60 CONTINUE
*
* workspace: N.
*
* Undo scaling
*
IF( IASCL.EQ.1 ) THEN
CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
CALL SLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA,
$ INFO )
ELSE IF( IASCL.EQ.2 ) THEN
CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
CALL SLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA,
$ INFO )
END IF
IF( IBSCL.EQ.1 ) THEN
CALL SLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
ELSE IF( IBSCL.EQ.2 ) THEN
CALL SLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
END IF
*
70 CONTINUE
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of SGELSY
*
END
SUBROUTINE SGEQL2( M, N, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGEQL2 computes a QL factorization of a real m by n matrix A:
* A = Q * L.
*
* 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) REAL array, dimension (LDA,N)
* On entry, the m by n matrix A.
* On exit, if m >= n, the lower triangle of the subarray
* A(m-n+1:m,1:n) contains the n by n lower triangular matrix L;
* if m <= n, the elements on and below the (n-m)-th
* superdiagonal contain the m by n lower trapezoidal matrix L;
* the remaining elements, 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) REAL array, dimension (min(M,N))
* The scalar factors of the elementary reflectors (see Further
* Details).
*
* WORK (workspace) REAL 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(k) . . . H(2) H(1), where k = min(m,n).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a real scalar, and v is a real vector with
* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in
* A(1:m-k+i-1,n-k+i), and tau in TAU(i).
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, K
REAL AII
* ..
* .. External Subroutines ..
EXTERNAL SLARF, SLARFG, 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( 'SGEQL2', -INFO )
RETURN
END IF
*
K = MIN( M, N )
*
DO 10 I = K, 1, -1
*
* Generate elementary reflector H(i) to annihilate
* A(1:m-k+i-1,n-k+i)
*
CALL SLARFG( M-K+I, A( M-K+I, N-K+I ), A( 1, N-K+I ), 1,
$ TAU( I ) )
*
* Apply H(i) to A(1:m-k+i,1:n-k+i-1) from the left
*
AII = A( M-K+I, N-K+I )
A( M-K+I, N-K+I ) = ONE
CALL SLARF( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1, TAU( I ),
$ A, LDA, WORK )
A( M-K+I, N-K+I ) = AII
10 CONTINUE
RETURN
*
* End of SGEQL2
*
END
SUBROUTINE SGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGEQLF computes a QL factorization of a real M-by-N matrix A:
* A = Q * L.
*
* 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) REAL array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit,
* if m >= n, the lower triangle of the subarray
* A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L;
* if m <= n, the elements on and below the (n-m)-th
* superdiagonal contain the M-by-N lower trapezoidal matrix L;
* the remaining elements, 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) REAL array, dimension (min(M,N))
* The scalar factors of the elementary reflectors (see Further
* Details).
*
* WORK (workspace/output) REAL 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(k) . . . H(2) H(1), where k = min(m,n).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a real scalar, and v is a real vector with
* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in
* A(1:m-k+i-1,n-k+i), and tau in TAU(i).
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,
$ MU, NB, NBMIN, NU, NX
* ..
* .. External Subroutines ..
EXTERNAL SGEQL2, SLARFB, SLARFT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the 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
K = MIN( M, N )
IF( K.EQ.0 ) THEN
LWKOPT = 1
ELSE
NB = ILAENV( 1, 'SGEQLF', ' ', M, N, -1, -1 )
LWKOPT = N*NB
END IF
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -7
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGEQLF', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( K.EQ.0 ) THEN
RETURN
END IF
*
NBMIN = 2
NX = 1
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, 'SGEQLF', ' ', 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, 'SGEQLF', ' ', 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.
* The last kk columns are handled by the block method.
*
KI = ( ( K-NX-1 ) / NB )*NB
KK = MIN( K, KI+NB )
*
DO 10 I = K - KK + KI + 1, K - KK + 1, -NB
IB = MIN( K-I+1, NB )
*
* Compute the QL factorization of the current block
* A(1:m-k+i+ib-1,n-k+i:n-k+i+ib-1)
*
CALL SGEQL2( M-K+I+IB-1, IB, A( 1, N-K+I ), LDA, TAU( I ),
$ WORK, IINFO )
IF( N-K+I.GT.1 ) THEN
*
* Form the triangular factor of the block reflector
* H = H(i+ib-1) . . . H(i+1) H(i)
*
CALL SLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB,
$ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK )
*
* Apply H' to A(1:m-k+i+ib-1,1:n-k+i-1) from the left
*
CALL SLARFB( 'Left', 'Transpose', 'Backward',
$ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB,
$ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA,
$ WORK( IB+1 ), LDWORK )
END IF
10 CONTINUE
MU = M - K + I + NB - 1
NU = N - K + I + NB - 1
ELSE
MU = M
NU = N
END IF
*
* Use unblocked code to factor the last or only block
*
IF( MU.GT.0 .AND. NU.GT.0 )
$ CALL SGEQL2( MU, NU, A, LDA, TAU, WORK, IINFO )
*
WORK( 1 ) = IWS
RETURN
*
* End of SGEQLF
*
END
SUBROUTINE SGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
INTEGER JPVT( * )
REAL A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGEQP3 computes a QR factorization with column pivoting of a
* matrix A: A*P = Q*R using Level 3 BLAS.
*
* 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) REAL array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, the upper triangle of the array contains the
* min(M,N)-by-N upper trapezoidal matrix R; the elements below
* the diagonal, together with the array TAU, represent the
* orthogonal matrix Q as a product of min(M,N) elementary
* reflectors.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* JPVT (input/output) INTEGER array, dimension (N)
* On entry, if JPVT(J).ne.0, the J-th column of A is permuted
* to the front of A*P (a leading column); if JPVT(J)=0,
* the J-th column of A is a free column.
* On exit, if JPVT(J)=K, then the J-th column of A*P was the
* the K-th column of A.
*
* TAU (output) REAL array, dimension (min(M,N))
* The scalar factors of the elementary reflectors.
*
* WORK (workspace/output) REAL 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 >= 3*N+1.
* For optimal performance LWORK >= 2*N+( N+1 )*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'
*
* where tau is a real/complex scalar, and v is a real/complex 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).
*
* Based on contributions by
* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
* X. Sun, Computer Science Dept., Duke University, USA
*
* =====================================================================
*
* .. 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 SGEQRF, SLAQP2, SLAQPS, SORMQR, SSWAP, XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
REAL SNRM2
EXTERNAL ILAENV, SNRM2
* ..
* .. Intrinsic Functions ..
INTRINSIC INT, MAX, MIN
* ..
* .. Executable Statements ..
*
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, 'SGEQRF', ' ', 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( 'SGEQP3', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible.
*
IF( MINMN.EQ.0 ) 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 SSWAP( 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 SGEQR2( M, NA, A, LDA, TAU, WORK, INFO )
CALL SGEQRF( M, NA, A, LDA, TAU, WORK, LWORK, INFO )
IWS = MAX( IWS, INT( WORK( 1 ) ) )
IF( NA.LT.N ) THEN
*CC CALL SORM2R( 'Left', 'Transpose', M, N-NA, NA, A, LDA,
*CC $ TAU, A( 1, NA+1 ), LDA, WORK, INFO )
CALL SORMQR( '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, 'SGEQRF', ' ', 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, 'SGEQRF', ' ', 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, 'SGEQRF', ' ', SM, SN,
$ -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 ) = SNRM2( 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 SLAQPS( 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 SLAQP2( 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 SGEQP3
*
END
SUBROUTINE SGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO )
*
* -- LAPACK deprecated driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
INTEGER JPVT( * )
REAL A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* This routine is deprecated and has been replaced by routine SGEQP3.
*
* SGEQPF computes a QR factorization with column pivoting of a
* real M-by-N matrix A: A*P = 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) REAL array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, the upper triangle of the array contains the
* min(M,N)-by-N upper triangular matrix R; the elements
* below the diagonal, together with the array TAU,
* represent the orthogonal matrix Q as a product of
* min(m,n) elementary reflectors.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* JPVT (input/output) INTEGER array, dimension (N)
* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
* to the front of A*P (a leading column); if JPVT(i) = 0,
* the i-th column of A is a free column.
* On exit, if JPVT(i) = k, then the i-th column of A*P
* was the k-th column of A.
*
* TAU (output) REAL array, dimension (min(M,N))
* The scalar factors of the elementary reflectors.
*
* WORK (workspace) REAL array, dimension (3*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(n)
*
* Each H(i) has the form
*
* H = I - tau * v * v'
*
* 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).
*
* The matrix P is represented in jpvt as follows: If
* jpvt(j) = i
* then the jth column of P is the ith canonical unit vector.
*
* Partial column norm updating strategy modified by
* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,
* University of Zagreb, Croatia.
* June 2006.
* For more details see LAPACK Working Note 176.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, ITEMP, J, MA, MN, PVT
REAL AII, TEMP, TEMP2, TOL3Z
* ..
* .. External Subroutines ..
EXTERNAL SGEQR2, SLARF, SLARFG, SORM2R, SSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. External Functions ..
INTEGER ISAMAX
REAL SLAMCH, SNRM2
EXTERNAL ISAMAX, SLAMCH, SNRM2
* ..
* .. 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( 'SGEQPF', -INFO )
RETURN
END IF
*
MN = MIN( M, N )
TOL3Z = SQRT(SLAMCH('Epsilon'))
*
* Move initial columns up front
*
ITEMP = 1
DO 10 I = 1, N
IF( JPVT( I ).NE.0 ) THEN
IF( I.NE.ITEMP ) THEN
CALL SSWAP( M, A( 1, I ), 1, A( 1, ITEMP ), 1 )
JPVT( I ) = JPVT( ITEMP )
JPVT( ITEMP ) = I
ELSE
JPVT( I ) = I
END IF
ITEMP = ITEMP + 1
ELSE
JPVT( I ) = I
END IF
10 CONTINUE
ITEMP = ITEMP - 1
*
* Compute the QR factorization and update remaining columns
*
IF( ITEMP.GT.0 ) THEN
MA = MIN( ITEMP, M )
CALL SGEQR2( M, MA, A, LDA, TAU, WORK, INFO )
IF( MA.LT.N ) THEN
CALL SORM2R( 'Left', 'Transpose', M, N-MA, MA, A, LDA, TAU,
$ A( 1, MA+1 ), LDA, WORK, INFO )
END IF
END IF
*
IF( ITEMP.LT.MN ) THEN
*
* Initialize partial column norms. The first n elements of
* work store the exact column norms.
*
DO 20 I = ITEMP + 1, N
WORK( I ) = SNRM2( M-ITEMP, A( ITEMP+1, I ), 1 )
WORK( N+I ) = WORK( I )
20 CONTINUE
*
* Compute factorization
*
DO 40 I = ITEMP + 1, MN
*
* Determine ith pivot column and swap if necessary
*
PVT = ( I-1 ) + ISAMAX( N-I+1, WORK( I ), 1 )
*
IF( PVT.NE.I ) THEN
CALL SSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 )
ITEMP = JPVT( PVT )
JPVT( PVT ) = JPVT( I )
JPVT( I ) = ITEMP
WORK( PVT ) = WORK( I )
WORK( N+PVT ) = WORK( N+I )
END IF
*
* Generate elementary reflector H(i)
*
IF( I.LT.M ) THEN
CALL SLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, TAU( I ) )
ELSE
CALL SLARFG( 1, A( M, M ), A( M, M ), 1, TAU( M ) )
END IF
*
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 SLARF( 'LEFT', M-I+1, N-I, A( I, I ), 1, TAU( I ),
$ A( I, I+1 ), LDA, WORK( 2*N+1 ) )
A( I, I ) = AII
END IF
*
* Update partial column norms
*
DO 30 J = I + 1, N
IF( WORK( J ).NE.ZERO ) THEN
*
* NOTE: The following 4 lines follow from the analysis in
* Lapack Working Note 176.
*
TEMP = ABS( A( I, J ) ) / WORK( J )
TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) )
TEMP2 = TEMP*( WORK( J ) / WORK( N+J ) )**2
IF( TEMP2 .LE. TOL3Z ) THEN
IF( M-I.GT.0 ) THEN
WORK( J ) = SNRM2( M-I, A( I+1, J ), 1 )
WORK( N+J ) = WORK( J )
ELSE
WORK( J ) = ZERO
WORK( N+J ) = ZERO
END IF
ELSE
WORK( J ) = WORK( J )*SQRT( TEMP )
END IF
END IF
30 CONTINUE
*
40 CONTINUE
END IF
RETURN
*
* End of SGEQPF
*
END
SUBROUTINE SGEQR2( M, N, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGEQR2 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) REAL 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) REAL array, dimension (min(M,N))
* The scalar factors of the elementary reflectors (see Further
* Details).
*
* WORK (workspace) REAL 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'
*
* 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 ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, K
REAL AII
* ..
* .. External Subroutines ..
EXTERNAL SLARF, SLARFG, 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( 'SGEQR2', -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 SLARFG( 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 SLARF( '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 SGEQR2
*
END
SUBROUTINE SGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGEQRF 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) REAL 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) REAL array, dimension (min(M,N))
* The scalar factors of the elementary reflectors (see Further
* Details).
*
* WORK (workspace/output) REAL 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'
*
* 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 SGEQR2, SLARFB, SLARFT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
NB = ILAENV( 1, 'SGEQRF', ' ', 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( 'SGEQRF', -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, 'SGEQRF', ' ', 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, 'SGEQRF', ' ', 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 SGEQR2( 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 SLARFT( 'Forward', 'Columnwise', M-I+1, IB,
$ A( I, I ), LDA, TAU( I ), WORK, LDWORK )
*
* Apply H' to A(i:m,i+ib:n) from the left
*
CALL SLARFB( '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 SGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
$ IINFO )
*
WORK( 1 ) = IWS
RETURN
*
* End of SGEQRF
*
END
SUBROUTINE SGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB,
$ X, LDX, FERR, BERR, WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), IWORK( * )
REAL A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
$ BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* SGERFS improves the computed solution to a system of linear
* equations and provides error bounds and backward error estimates for
* the solution.
*
* 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**H * 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 matrices B and X. NRHS >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The original N-by-N matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* AF (input) REAL array, dimension (LDAF,N)
* The factors L and U from the factorization A = P*L*U
* as computed by SGETRF.
*
* LDAF (input) INTEGER
* The leading dimension of the array AF. LDAF >= max(1,N).
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices from SGETRF; for 1<=i<=N, row i of the
* matrix was interchanged with row IPIV(i).
*
* B (input) REAL array, dimension (LDB,NRHS)
* The right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input/output) REAL array, dimension (LDX,NRHS)
* On entry, the solution matrix X, as computed by SGETRS.
* On exit, the improved solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* FERR (output) REAL array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) REAL array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Internal Parameters
* ===================
*
* ITMAX is the maximum number of steps of iterative refinement.
*
* =====================================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 5 )
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
REAL TWO
PARAMETER ( TWO = 2.0E+0 )
REAL THREE
PARAMETER ( THREE = 3.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN
CHARACTER TRANST
INTEGER COUNT, I, J, K, KASE, NZ
REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, SGEMV, SGETRS, SLACN2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH
EXTERNAL LSAME, SLAMCH
* ..
* .. 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( LDAF.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -10
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGERFS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
DO 10 J = 1, NRHS
FERR( J ) = ZERO
BERR( J ) = ZERO
10 CONTINUE
RETURN
END IF
*
IF( NOTRAN ) THEN
TRANST = 'T'
ELSE
TRANST = 'N'
END IF
*
* NZ = maximum number of nonzero elements in each row of A, plus 1
*
NZ = N + 1
EPS = SLAMCH( 'Epsilon' )
SAFMIN = SLAMCH( 'Safe minimum' )
SAFE1 = NZ*SAFMIN
SAFE2 = SAFE1 / EPS
*
* Do for each right hand side
*
DO 140 J = 1, NRHS
*
COUNT = 1
LSTRES = THREE
20 CONTINUE
*
* Loop until stopping criterion is satisfied.
*
* Compute residual R = B - op(A) * X,
* where op(A) = A, A**T, or A**H, depending on TRANS.
*
CALL SCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
CALL SGEMV( TRANS, N, N, -ONE, A, LDA, X( 1, J ), 1, ONE,
$ WORK( N+1 ), 1 )
*
* Compute componentwise relative backward error from formula
*
* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
*
* where abs(Z) is the componentwise absolute value of the matrix
* or vector Z. If the i-th component of the denominator is less
* than SAFE2, then SAFE1 is added to the i-th components of the
* numerator and denominator before dividing.
*
DO 30 I = 1, N
WORK( I ) = ABS( B( I, J ) )
30 CONTINUE
*
* Compute abs(op(A))*abs(X) + abs(B).
*
IF( NOTRAN ) THEN
DO 50 K = 1, N
XK = ABS( X( K, J ) )
DO 40 I = 1, N
WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
40 CONTINUE
50 CONTINUE
ELSE
DO 70 K = 1, N
S = ZERO
DO 60 I = 1, N
S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
60 CONTINUE
WORK( K ) = WORK( K ) + S
70 CONTINUE
END IF
S = ZERO
DO 80 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
ELSE
S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
$ ( WORK( I )+SAFE1 ) )
END IF
80 CONTINUE
BERR( J ) = S
*
* Test stopping criterion. Continue iterating if
* 1) The residual BERR(J) is larger than machine epsilon, and
* 2) BERR(J) decreased by at least a factor of 2 during the
* last iteration, and
* 3) At most ITMAX iterations tried.
*
IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
$ COUNT.LE.ITMAX ) THEN
*
* Update solution and try again.
*
CALL SGETRS( TRANS, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
$ INFO )
CALL SAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
LSTRES = BERR( J )
COUNT = COUNT + 1
GO TO 20
END IF
*
* Bound error from formula
*
* norm(X - XTRUE) / norm(X) .le. FERR =
* norm( abs(inv(op(A)))*
* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
*
* where
* norm(Z) is the magnitude of the largest component of Z
* inv(op(A)) is the inverse of op(A)
* abs(Z) is the componentwise absolute value of the matrix or
* vector Z
* NZ is the maximum number of nonzeros in any row of A, plus 1
* EPS is machine epsilon
*
* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
* is incremented by SAFE1 if the i-th component of
* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
*
* Use SLACN2 to estimate the infinity-norm of the matrix
* inv(op(A)) * diag(W),
* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
*
DO 90 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
ELSE
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
END IF
90 CONTINUE
*
KASE = 0
100 CONTINUE
CALL SLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
$ KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Multiply by diag(W)*inv(op(A)**T).
*
CALL SGETRS( TRANST, N, 1, AF, LDAF, IPIV, WORK( N+1 ),
$ N, INFO )
DO 110 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
110 CONTINUE
ELSE
*
* Multiply by inv(op(A))*diag(W).
*
DO 120 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
120 CONTINUE
CALL SGETRS( TRANS, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
$ INFO )
END IF
GO TO 100
END IF
*
* Normalize error.
*
LSTRES = ZERO
DO 130 I = 1, N
LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
130 CONTINUE
IF( LSTRES.NE.ZERO )
$ FERR( J ) = FERR( J ) / LSTRES
*
140 CONTINUE
*
RETURN
*
* End of SGERFS
*
END
SUBROUTINE SGERQ2( M, N, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGERQ2 computes an RQ factorization of a real m by n matrix A:
* A = R * Q.
*
* 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) REAL array, dimension (LDA,N)
* On entry, the m by n matrix A.
* On exit, if m <= n, the upper triangle of the subarray
* A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;
* if m >= n, the elements on and above the (m-n)-th subdiagonal
* contain the m by n upper trapezoidal matrix R; the remaining
* elements, 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) REAL array, dimension (min(M,N))
* The scalar factors of the elementary reflectors (see Further
* Details).
*
* WORK (workspace) REAL array, dimension (M)
*
* 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'
*
* where tau is a real scalar, and v is a real vector with
* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
* A(m-k+i,1:n-k+i-1), and tau in TAU(i).
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, K
REAL AII
* ..
* .. External Subroutines ..
EXTERNAL SLARF, SLARFG, 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( 'SGERQ2', -INFO )
RETURN
END IF
*
K = MIN( M, N )
*
DO 10 I = K, 1, -1
*
* Generate elementary reflector H(i) to annihilate
* A(m-k+i,1:n-k+i-1)
*
CALL SLARFG( N-K+I, A( M-K+I, N-K+I ), A( M-K+I, 1 ), LDA,
$ TAU( I ) )
*
* Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right
*
AII = A( M-K+I, N-K+I )
A( M-K+I, N-K+I ) = ONE
CALL SLARF( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA,
$ TAU( I ), A, LDA, WORK )
A( M-K+I, N-K+I ) = AII
10 CONTINUE
RETURN
*
* End of SGERQ2
*
END
SUBROUTINE SGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGERQF computes an RQ factorization of a real M-by-N matrix A:
* A = R * Q.
*
* 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) REAL array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit,
* if m <= n, the upper triangle of the subarray
* A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R;
* if m >= n, the elements on and above the (m-n)-th subdiagonal
* contain the M-by-N upper trapezoidal matrix R;
* the remaining elements, 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) REAL array, dimension (min(M,N))
* The scalar factors of the elementary reflectors (see Further
* Details).
*
* WORK (workspace/output) REAL 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,M).
* For optimum performance LWORK >= M*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'
*
* where tau is a real scalar, and v is a real vector with
* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
* A(m-k+i,1:n-k+i-1), and tau in TAU(i).
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,
$ MU, NB, NBMIN, NU, NX
* ..
* .. External Subroutines ..
EXTERNAL SGERQ2, SLARFB, SLARFT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the 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
ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
INFO = -7
END IF
*
IF( INFO.EQ.0 ) THEN
K = MIN( M, N )
IF( K.EQ.0 ) THEN
LWKOPT = 1
ELSE
NB = ILAENV( 1, 'SGERQF', ' ', M, N, -1, -1 )
LWKOPT = M*NB
WORK( 1 ) = LWKOPT
END IF
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
INFO = -7
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGERQF', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( K.EQ.0 ) THEN
RETURN
END IF
*
NBMIN = 2
NX = 1
IWS = M
IF( NB.GT.1 .AND. NB.LT.K ) THEN
*
* Determine when to cross over from blocked to unblocked code.
*
NX = MAX( 0, ILAENV( 3, 'SGERQF', ' ', M, N, -1, -1 ) )
IF( NX.LT.K ) THEN
*
* Determine if workspace is large enough for blocked code.
*
LDWORK = M
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, 'SGERQF', ' ', 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.
* The last kk rows are handled by the block method.
*
KI = ( ( K-NX-1 ) / NB )*NB
KK = MIN( K, KI+NB )
*
DO 10 I = K - KK + KI + 1, K - KK + 1, -NB
IB = MIN( K-I+1, NB )
*
* Compute the RQ factorization of the current block
* A(m-k+i:m-k+i+ib-1,1:n-k+i+ib-1)
*
CALL SGERQ2( IB, N-K+I+IB-1, A( M-K+I, 1 ), LDA, TAU( I ),
$ WORK, IINFO )
IF( M-K+I.GT.1 ) THEN
*
* Form the triangular factor of the block reflector
* H = H(i+ib-1) . . . H(i+1) H(i)
*
CALL SLARFT( 'Backward', 'Rowwise', N-K+I+IB-1, IB,
$ A( M-K+I, 1 ), LDA, TAU( I ), WORK, LDWORK )
*
* Apply H to A(1:m-k+i-1,1:n-k+i+ib-1) from the right
*
CALL SLARFB( 'Right', 'No transpose', 'Backward',
$ 'Rowwise', M-K+I-1, N-K+I+IB-1, IB,
$ A( M-K+I, 1 ), LDA, WORK, LDWORK, A, LDA,
$ WORK( IB+1 ), LDWORK )
END IF
10 CONTINUE
MU = M - K + I + NB - 1
NU = N - K + I + NB - 1
ELSE
MU = M
NU = N
END IF
*
* Use unblocked code to factor the last or only block
*
IF( MU.GT.0 .AND. NU.GT.0 )
$ CALL SGERQ2( MU, NU, A, LDA, TAU, WORK, IINFO )
*
WORK( 1 ) = IWS
RETURN
*
* End of SGERQF
*
END
SUBROUTINE SGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, N
REAL SCALE
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), JPIV( * )
REAL A( LDA, * ), RHS( * )
* ..
*
* Purpose
* =======
*
* SGESC2 solves a system of linear equations
*
* A * X = scale* RHS
*
* with a general N-by-N matrix A using the LU factorization with
* complete pivoting computed by SGETC2.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix A.
*
* A (input) REAL array, dimension (LDA,N)
* On entry, the LU part of the factorization of the n-by-n
* matrix A computed by SGETC2: A = P * L * U * Q
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1, N).
*
* RHS (input/output) REAL array, dimension (N).
* On entry, the right hand side vector b.
* On exit, the solution vector X.
*
* IPIV (input) INTEGER array, dimension (N).
* The pivot indices; for 1 <= i <= N, row i of the
* matrix has been interchanged with row IPIV(i).
*
* JPIV (input) INTEGER array, dimension (N).
* The pivot indices; for 1 <= j <= N, column j of the
* matrix has been interchanged with column JPIV(j).
*
* SCALE (output) REAL
* On exit, SCALE contains the scale factor. SCALE is chosen
* 0 <= SCALE <= 1 to prevent owerflow in the solution.
*
* Further Details
* ===============
*
* Based on contributions by
* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
* Umea University, S-901 87 Umea, Sweden.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, TWO
PARAMETER ( ONE = 1.0E+0, TWO = 2.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
REAL BIGNUM, EPS, SMLNUM, TEMP
* ..
* .. External Subroutines ..
EXTERNAL SLABAD, SLASWP, SSCAL
* ..
* .. External Functions ..
INTEGER ISAMAX
REAL SLAMCH
EXTERNAL ISAMAX, SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
* Set constant to control owerflow
*
EPS = SLAMCH( 'P' )
SMLNUM = SLAMCH( 'S' ) / EPS
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
*
* Apply permutations IPIV to RHS
*
CALL SLASWP( 1, RHS, LDA, 1, N-1, IPIV, 1 )
*
* Solve for L part
*
DO 20 I = 1, N - 1
DO 10 J = I + 1, N
RHS( J ) = RHS( J ) - A( J, I )*RHS( I )
10 CONTINUE
20 CONTINUE
*
* Solve for U part
*
SCALE = ONE
*
* Check for scaling
*
I = ISAMAX( N, RHS, 1 )
IF( TWO*SMLNUM*ABS( RHS( I ) ).GT.ABS( A( N, N ) ) ) THEN
TEMP = ( ONE / TWO ) / ABS( RHS( I ) )
CALL SSCAL( N, TEMP, RHS( 1 ), 1 )
SCALE = SCALE*TEMP
END IF
*
DO 40 I = N, 1, -1
TEMP = ONE / A( I, I )
RHS( I ) = RHS( I )*TEMP
DO 30 J = I + 1, N
RHS( I ) = RHS( I ) - RHS( J )*( A( I, J )*TEMP )
30 CONTINUE
40 CONTINUE
*
* Apply permutations JPIV to the solution (RHS)
*
CALL SLASWP( 1, RHS, LDA, 1, N-1, JPIV, -1 )
RETURN
*
* End of SGESC2
*
END
SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK,
$ LWORK, IWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ
INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL A( LDA, * ), S( * ), U( LDU, * ),
$ VT( LDVT, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGESDD computes the singular value decomposition (SVD) of a real
* M-by-N matrix A, optionally computing the left and right singular
* vectors. If singular vectors are desired, it uses a
* divide-and-conquer algorithm.
*
* The SVD is written
*
* A = U * SIGMA * transpose(V)
*
* where SIGMA is an M-by-N matrix which is zero except for its
* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and
* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA
* are the singular values of A; they are real and non-negative, and
* are returned in descending order. The first min(m,n) columns of
* U and V are the left and right singular vectors of A.
*
* Note that the routine returns VT = V**T, not V.
*
* The divide and conquer algorithm makes very mild assumptions about
* floating point arithmetic. It will work on machines with a guard
* digit in add/subtract, or on those binary machines without guard
* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
* Cray-2. It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* Specifies options for computing all or part of the matrix U:
* = 'A': all M columns of U and all N rows of V**T are
* returned in the arrays U and VT;
* = 'S': the first min(M,N) columns of U and the first
* min(M,N) rows of V**T are returned in the arrays U
* and VT;
* = 'O': If M >= N, the first N columns of U are overwritten
* on the array A and all rows of V**T are returned in
* the array VT;
* otherwise, all columns of U are returned in the
* array U and the first M rows of V**T are overwritten
* in the array A;
* = 'N': no columns of U or rows of V**T are computed.
*
* M (input) INTEGER
* The number of rows of the input matrix A. M >= 0.
*
* N (input) INTEGER
* The number of columns of the input matrix A. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit,
* if JOBZ = 'O', A is overwritten with the first N columns
* of U (the left singular vectors, stored
* columnwise) if M >= N;
* A is overwritten with the first M rows
* of V**T (the right singular vectors, stored
* rowwise) otherwise.
* if JOBZ .ne. 'O', the contents of A are destroyed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* S (output) REAL array, dimension (min(M,N))
* The singular values of A, sorted so that S(i) >= S(i+1).
*
* U (output) REAL array, dimension (LDU,UCOL)
* UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;
* UCOL = min(M,N) if JOBZ = 'S'.
* If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M
* orthogonal matrix U;
* if JOBZ = 'S', U contains the first min(M,N) columns of U
* (the left singular vectors, stored columnwise);
* if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= 1; if
* JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.
*
* VT (output) REAL array, dimension (LDVT,N)
* If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the
* N-by-N orthogonal matrix V**T;
* if JOBZ = 'S', VT contains the first min(M,N) rows of
* V**T (the right singular vectors, stored rowwise);
* if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.
*
* LDVT (input) INTEGER
* The leading dimension of the array VT. LDVT >= 1; if
* JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;
* if JOBZ = 'S', LDVT >= min(M,N).
*
* WORK (workspace/output) REAL 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 >= 1.
* If JOBZ = 'N',
* LWORK >= 3*min(M,N) + max(max(M,N),6*min(M,N)).
* If JOBZ = 'O',
* LWORK >= 3*min(M,N)*min(M,N) +
* max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)).
* If JOBZ = 'S' or 'A'
* LWORK >= 3*min(M,N)*min(M,N) +
* max(max(M,N),4*min(M,N)*min(M,N)+4*min(M,N)).
* For good performance, LWORK should generally be larger.
* If LWORK = -1 but other input arguments are legal, WORK(1)
* returns the optimal LWORK.
*
* IWORK (workspace) INTEGER array, dimension (8*min(M,N))
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: SBDSDC did not converge, updating process failed.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, WNTQA, WNTQAS, WNTQN, WNTQO, WNTQS
INTEGER BDSPAC, BLK, CHUNK, I, IE, IERR, IL,
$ IR, ISCL, ITAU, ITAUP, ITAUQ, IU, IVT, LDWKVT,
$ LDWRKL, LDWRKR, LDWRKU, MAXWRK, MINMN, MINWRK,
$ MNTHR, NWORK, WRKBL
REAL ANRM, BIGNUM, EPS, SMLNUM
* ..
* .. Local Arrays ..
INTEGER IDUM( 1 )
REAL DUM( 1 )
* ..
* .. External Subroutines ..
EXTERNAL SBDSDC, SGEBRD, SGELQF, SGEMM, SGEQRF, SLACPY,
$ SLASCL, SLASET, SORGBR, SORGLQ, SORGQR, SORMBR,
$ XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
REAL SLAMCH, SLANGE
EXTERNAL ILAENV, LSAME, SLAMCH, SLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC INT, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
MINMN = MIN( M, N )
WNTQA = LSAME( JOBZ, 'A' )
WNTQS = LSAME( JOBZ, 'S' )
WNTQAS = WNTQA .OR. WNTQS
WNTQO = LSAME( JOBZ, 'O' )
WNTQN = LSAME( JOBZ, 'N' )
LQUERY = ( LWORK.EQ.-1 )
*
IF( .NOT.( WNTQA .OR. WNTQS .OR. WNTQO .OR. WNTQN ) ) 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 = -5
ELSE IF( LDU.LT.1 .OR. ( WNTQAS .AND. LDU.LT.M ) .OR.
$ ( WNTQO .AND. M.LT.N .AND. LDU.LT.M ) ) THEN
INFO = -8
ELSE IF( LDVT.LT.1 .OR. ( WNTQA .AND. LDVT.LT.N ) .OR.
$ ( WNTQS .AND. LDVT.LT.MINMN ) .OR.
$ ( WNTQO .AND. M.GE.N .AND. LDVT.LT.N ) ) THEN
INFO = -10
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.)
*
IF( INFO.EQ.0 ) THEN
MINWRK = 1
MAXWRK = 1
IF( M.GE.N .AND. MINMN.GT.0 ) THEN
*
* Compute space needed for SBDSDC
*
MNTHR = INT( MINMN*11.0E0 / 6.0E0 )
IF( WNTQN ) THEN
BDSPAC = 7*N
ELSE
BDSPAC = 3*N*N + 4*N
END IF
IF( M.GE.MNTHR ) THEN
IF( WNTQN ) THEN
*
* Path 1 (M much larger than N, JOBZ='N')
*
WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1,
$ -1 )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
MAXWRK = MAX( WRKBL, BDSPAC+N )
MINWRK = BDSPAC + N
ELSE IF( WNTQO ) THEN
*
* Path 2 (M much larger than N, JOBZ='O')
*
WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'SORGQR', ' ', M,
$ N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'SORMBR', 'QLN', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*N )
MAXWRK = WRKBL + 2*N*N
MINWRK = BDSPAC + 2*N*N + 3*N
ELSE IF( WNTQS ) THEN
*
* Path 3 (M much larger than N, JOBZ='S')
*
WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'SORGQR', ' ', M,
$ N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'SORMBR', 'QLN', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*N )
MAXWRK = WRKBL + N*N
MINWRK = BDSPAC + N*N + 3*N
ELSE IF( WNTQA ) THEN
*
* Path 4 (M much larger than N, JOBZ='A')
*
WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'SORGQR', ' ', M,
$ M, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'SORMBR', 'QLN', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*N )
MAXWRK = WRKBL + N*N
MINWRK = BDSPAC + N*N + 3*N
END IF
ELSE
*
* Path 5 (M at least N, but not much larger)
*
WRKBL = 3*N + ( M+N )*ILAENV( 1, 'SGEBRD', ' ', M, N, -1,
$ -1 )
IF( WNTQN ) THEN
MAXWRK = MAX( WRKBL, BDSPAC+3*N )
MINWRK = 3*N + MAX( M, BDSPAC )
ELSE IF( WNTQO ) THEN
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'SORMBR', 'QLN', M, N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*N )
MAXWRK = WRKBL + M*N
MINWRK = 3*N + MAX( M, N*N+BDSPAC )
ELSE IF( WNTQS ) THEN
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'SORMBR', 'QLN', M, N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) )
MAXWRK = MAX( WRKBL, BDSPAC+3*N )
MINWRK = 3*N + MAX( M, BDSPAC )
ELSE IF( WNTQA ) THEN
WRKBL = MAX( WRKBL, 3*N+M*
$ ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) )
MAXWRK = MAX( MAXWRK, BDSPAC+3*N )
MINWRK = 3*N + MAX( M, BDSPAC )
END IF
END IF
ELSE IF ( MINMN.GT.0 ) THEN
*
* Compute space needed for SBDSDC
*
MNTHR = INT( MINMN*11.0E0 / 6.0E0 )
IF( WNTQN ) THEN
BDSPAC = 7*M
ELSE
BDSPAC = 3*M*M + 4*M
END IF
IF( N.GE.MNTHR ) THEN
IF( WNTQN ) THEN
*
* Path 1t (N much larger than M, JOBZ='N')
*
WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1,
$ -1 )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
MAXWRK = MAX( WRKBL, BDSPAC+M )
MINWRK = BDSPAC + M
ELSE IF( WNTQO ) THEN
*
* Path 2t (N much larger than M, JOBZ='O')
*
WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'SORGLQ', ' ', M,
$ N, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'SORMBR', 'QLN', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'SORMBR', 'PRT', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*M )
MAXWRK = WRKBL + 2*M*M
MINWRK = BDSPAC + 2*M*M + 3*M
ELSE IF( WNTQS ) THEN
*
* Path 3t (N much larger than M, JOBZ='S')
*
WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'SORGLQ', ' ', M,
$ N, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'SORMBR', 'QLN', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'SORMBR', 'PRT', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*M )
MAXWRK = WRKBL + M*M
MINWRK = BDSPAC + M*M + 3*M
ELSE IF( WNTQA ) THEN
*
* Path 4t (N much larger than M, JOBZ='A')
*
WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'SORGLQ', ' ', N,
$ N, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'SORMBR', 'QLN', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'SORMBR', 'PRT', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*M )
MAXWRK = WRKBL + M*M
MINWRK = BDSPAC + M*M + 3*M
END IF
ELSE
*
* Path 5t (N greater than M, but not much larger)
*
WRKBL = 3*M + ( M+N )*ILAENV( 1, 'SGEBRD', ' ', M, N, -1,
$ -1 )
IF( WNTQN ) THEN
MAXWRK = MAX( WRKBL, BDSPAC+3*M )
MINWRK = 3*M + MAX( N, BDSPAC )
ELSE IF( WNTQO ) THEN
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'SORMBR', 'PRT', M, N, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*M )
MAXWRK = WRKBL + M*N
MINWRK = 3*M + MAX( N, M*M+BDSPAC )
ELSE IF( WNTQS ) THEN
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'SORMBR', 'PRT', M, N, M, -1 ) )
MAXWRK = MAX( WRKBL, BDSPAC+3*M )
MINWRK = 3*M + MAX( N, BDSPAC )
ELSE IF( WNTQA ) THEN
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'SORMBR', 'PRT', N, N, M, -1 ) )
MAXWRK = MAX( WRKBL, BDSPAC+3*M )
MINWRK = 3*M + MAX( N, BDSPAC )
END IF
END IF
END IF
MAXWRK = MAX( MAXWRK, MINWRK )
WORK( 1 ) = MAXWRK
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGESDD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
RETURN
END IF
*
* Get machine constants
*
EPS = SLAMCH( 'P' )
SMLNUM = SQRT( SLAMCH( 'S' ) ) / EPS
BIGNUM = ONE / SMLNUM
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = SLANGE( 'M', M, N, A, LDA, DUM )
ISCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
ISCL = 1
CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR )
ELSE IF( ANRM.GT.BIGNUM ) THEN
ISCL = 1
CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR )
END IF
*
IF( M.GE.N ) THEN
*
* A has at least as many rows as columns. If A has sufficiently
* more rows than columns, first reduce using the QR
* decomposition (if sufficient workspace available)
*
IF( M.GE.MNTHR ) THEN
*
IF( WNTQN ) THEN
*
* Path 1 (M much larger than N, JOBZ='N')
* No singular vectors to be computed
*
ITAU = 1
NWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Zero out below R
*
CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
IE = 1
ITAUQ = IE + N
ITAUP = ITAUQ + N
NWORK = ITAUP + N
*
* Bidiagonalize R in A
* (Workspace: need 4*N, prefer 3*N+2*N*NB)
*
CALL SGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
NWORK = IE + N
*
* Perform bidiagonal SVD, computing singular values only
* (Workspace: need N+BDSPAC)
*
CALL SBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1,
$ DUM, IDUM, WORK( NWORK ), IWORK, INFO )
*
ELSE IF( WNTQO ) THEN
*
* Path 2 (M much larger than N, JOBZ = 'O')
* N left singular vectors to be overwritten on A and
* N right singular vectors to be computed in VT
*
IR = 1
*
* WORK(IR) is LDWRKR by N
*
IF( LWORK.GE.LDA*N+N*N+3*N+BDSPAC ) THEN
LDWRKR = LDA
ELSE
LDWRKR = ( LWORK-N*N-3*N-BDSPAC ) / N
END IF
ITAU = IR + LDWRKR*N
NWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Copy R to WORK(IR), zeroing out below it
*
CALL SLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ),
$ LDWRKR )
*
* Generate Q in A
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL SORGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
NWORK = ITAUP + N
*
* Bidiagonalize R in VT, copying result to WORK(IR)
* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
*
CALL SGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* WORK(IU) is N by N
*
IU = NWORK
NWORK = IU + N*N
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in WORK(IU) and computing right
* singular vectors of bidiagonal matrix in VT
* (Workspace: need N+N*N+BDSPAC)
*
CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N,
$ VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Overwrite WORK(IU) by left singular vectors of R
* and VT by right singular vectors of R
* (Workspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB)
*
CALL SORMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IU ), N, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
CALL SORMBR( 'P', 'R', 'T', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Multiply Q in A by left singular vectors of R in
* WORK(IU), storing result in WORK(IR) and copying to A
* (Workspace: need 2*N*N, prefer N*N+M*N)
*
DO 10 I = 1, M, LDWRKR
CHUNK = MIN( M-I+1, LDWRKR )
CALL SGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
$ LDA, WORK( IU ), N, ZERO, WORK( IR ),
$ LDWRKR )
CALL SLACPY( 'F', CHUNK, N, WORK( IR ), LDWRKR,
$ A( I, 1 ), LDA )
10 CONTINUE
*
ELSE IF( WNTQS ) THEN
*
* Path 3 (M much larger than N, JOBZ='S')
* N left singular vectors to be computed in U and
* N right singular vectors to be computed in VT
*
IR = 1
*
* WORK(IR) is N by N
*
LDWRKR = N
ITAU = IR + LDWRKR*N
NWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Copy R to WORK(IR), zeroing out below it
*
CALL SLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ),
$ LDWRKR )
*
* Generate Q in A
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL SORGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
NWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IR)
* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
*
CALL SGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagoal matrix in U and computing right singular
* vectors of bidiagonal matrix in VT
* (Workspace: need N+BDSPAC)
*
CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT,
$ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Overwrite U by left singular vectors of R and VT
* by right singular vectors of R
* (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB)
*
CALL SORMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
CALL SORMBR( 'P', 'R', 'T', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Multiply Q in A by left singular vectors of R in
* WORK(IR), storing result in U
* (Workspace: need N*N)
*
CALL SLACPY( 'F', N, N, U, LDU, WORK( IR ), LDWRKR )
CALL SGEMM( 'N', 'N', M, N, N, ONE, A, LDA, WORK( IR ),
$ LDWRKR, ZERO, U, LDU )
*
ELSE IF( WNTQA ) THEN
*
* Path 4 (M much larger than N, JOBZ='A')
* M left singular vectors to be computed in U and
* N right singular vectors to be computed in VT
*
IU = 1
*
* WORK(IU) is N by N
*
LDWRKU = N
ITAU = IU + LDWRKU*N
NWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
CALL SORGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Produce R in A, zeroing out other entries
*
CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
NWORK = ITAUP + N
*
* Bidiagonalize R in A
* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
*
CALL SGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in WORK(IU) and computing right
* singular vectors of bidiagonal matrix in VT
* (Workspace: need N+N*N+BDSPAC)
*
CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N,
$ VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Overwrite WORK(IU) by left singular vectors of R and VT
* by right singular vectors of R
* (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB)
*
CALL SORMBR( 'Q', 'L', 'N', N, N, N, A, LDA,
$ WORK( ITAUQ ), WORK( IU ), LDWRKU,
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
CALL SORMBR( 'P', 'R', 'T', N, N, N, A, LDA,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Multiply Q in U by left singular vectors of R in
* WORK(IU), storing result in A
* (Workspace: need N*N)
*
CALL SGEMM( 'N', 'N', M, N, N, ONE, U, LDU, WORK( IU ),
$ LDWRKU, ZERO, A, LDA )
*
* Copy left singular vectors of A from A to U
*
CALL SLACPY( 'F', M, N, A, LDA, U, LDU )
*
END IF
*
ELSE
*
* M .LT. MNTHR
*
* Path 5 (M at least N, but not much larger)
* Reduce to bidiagonal form without QR decomposition
*
IE = 1
ITAUQ = IE + N
ITAUP = ITAUQ + N
NWORK = ITAUP + N
*
* Bidiagonalize A
* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB)
*
CALL SGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
IF( WNTQN ) THEN
*
* Perform bidiagonal SVD, only computing singular values
* (Workspace: need N+BDSPAC)
*
CALL SBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1,
$ DUM, IDUM, WORK( NWORK ), IWORK, INFO )
ELSE IF( WNTQO ) THEN
IU = NWORK
IF( LWORK.GE.M*N+3*N+BDSPAC ) THEN
*
* WORK( IU ) is M by N
*
LDWRKU = M
NWORK = IU + LDWRKU*N
CALL SLASET( 'F', M, N, ZERO, ZERO, WORK( IU ),
$ LDWRKU )
ELSE
*
* WORK( IU ) is N by N
*
LDWRKU = N
NWORK = IU + LDWRKU*N
*
* WORK(IR) is LDWRKR by N
*
IR = NWORK
LDWRKR = ( LWORK-N*N-3*N ) / N
END IF
NWORK = IU + LDWRKU*N
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in WORK(IU) and computing right
* singular vectors of bidiagonal matrix in VT
* (Workspace: need N+N*N+BDSPAC)
*
CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ),
$ LDWRKU, VT, LDVT, DUM, IDUM, WORK( NWORK ),
$ IWORK, INFO )
*
* Overwrite VT by right singular vectors of A
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL SORMBR( 'P', 'R', 'T', N, N, N, A, LDA,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
IF( LWORK.GE.M*N+3*N+BDSPAC ) THEN
*
* Overwrite WORK(IU) by left singular vectors of A
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL SORMBR( 'Q', 'L', 'N', M, N, N, A, LDA,
$ WORK( ITAUQ ), WORK( IU ), LDWRKU,
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Copy left singular vectors of A from WORK(IU) to A
*
CALL SLACPY( 'F', M, N, WORK( IU ), LDWRKU, A, LDA )
ELSE
*
* Generate Q in A
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL SORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Multiply Q in A by left singular vectors of
* bidiagonal matrix in WORK(IU), storing result in
* WORK(IR) and copying to A
* (Workspace: need 2*N*N, prefer N*N+M*N)
*
DO 20 I = 1, M, LDWRKR
CHUNK = MIN( M-I+1, LDWRKR )
CALL SGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
$ LDA, WORK( IU ), LDWRKU, ZERO,
$ WORK( IR ), LDWRKR )
CALL SLACPY( 'F', CHUNK, N, WORK( IR ), LDWRKR,
$ A( I, 1 ), LDA )
20 CONTINUE
END IF
*
ELSE IF( WNTQS ) THEN
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U and computing right singular
* vectors of bidiagonal matrix in VT
* (Workspace: need N+BDSPAC)
*
CALL SLASET( 'F', M, N, ZERO, ZERO, U, LDU )
CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT,
$ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Overwrite U by left singular vectors of A and VT
* by right singular vectors of A
* (Workspace: need 3*N, prefer 2*N+N*NB)
*
CALL SORMBR( 'Q', 'L', 'N', M, N, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
CALL SORMBR( 'P', 'R', 'T', N, N, N, A, LDA,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
ELSE IF( WNTQA ) THEN
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U and computing right singular
* vectors of bidiagonal matrix in VT
* (Workspace: need N+BDSPAC)
*
CALL SLASET( 'F', M, M, ZERO, ZERO, U, LDU )
CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT,
$ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Set the right corner of U to identity matrix
*
IF( M.GT.N ) THEN
CALL SLASET( 'F', M-N, M-N, ZERO, ONE, U( N+1, N+1 ),
$ LDU )
END IF
*
* Overwrite U by left singular vectors of A and VT
* by right singular vectors of A
* (Workspace: need N*N+2*N+M, prefer N*N+2*N+M*NB)
*
CALL SORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
CALL SORMBR( 'P', 'R', 'T', N, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
END IF
*
END IF
*
ELSE
*
* A has more columns than rows. If A has sufficiently more
* columns than rows, first reduce using the LQ decomposition (if
* sufficient workspace available)
*
IF( N.GE.MNTHR ) THEN
*
IF( WNTQN ) THEN
*
* Path 1t (N much larger than M, JOBZ='N')
* No singular vectors to be computed
*
ITAU = 1
NWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Zero out above L
*
CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA )
IE = 1
ITAUQ = IE + M
ITAUP = ITAUQ + M
NWORK = ITAUP + M
*
* Bidiagonalize L in A
* (Workspace: need 4*M, prefer 3*M+2*M*NB)
*
CALL SGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
NWORK = IE + M
*
* Perform bidiagonal SVD, computing singular values only
* (Workspace: need M+BDSPAC)
*
CALL SBDSDC( 'U', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1,
$ DUM, IDUM, WORK( NWORK ), IWORK, INFO )
*
ELSE IF( WNTQO ) THEN
*
* Path 2t (N much larger than M, JOBZ='O')
* M right singular vectors to be overwritten on A and
* M left singular vectors to be computed in U
*
IVT = 1
*
* IVT is M by M
*
IL = IVT + M*M
IF( LWORK.GE.M*N+M*M+3*M+BDSPAC ) THEN
*
* WORK(IL) is M by N
*
LDWRKL = M
CHUNK = N
ELSE
LDWRKL = M
CHUNK = ( LWORK-M*M ) / M
END IF
ITAU = IL + LDWRKL*M
NWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Copy L to WORK(IL), zeroing about above it
*
CALL SLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL )
CALL SLASET( 'U', M-1, M-1, ZERO, ZERO,
$ WORK( IL+LDWRKL ), LDWRKL )
*
* Generate Q in A
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL SORGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
NWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IL)
* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
*
CALL SGEBRD( M, M, WORK( IL ), LDWRKL, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U, and computing right singular
* vectors of bidiagonal matrix in WORK(IVT)
* (Workspace: need M+M*M+BDSPAC)
*
CALL SBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU,
$ WORK( IVT ), M, DUM, IDUM, WORK( NWORK ),
$ IWORK, INFO )
*
* Overwrite U by left singular vectors of L and WORK(IVT)
* by right singular vectors of L
* (Workspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB)
*
CALL SORMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
CALL SORMBR( 'P', 'R', 'T', M, M, M, WORK( IL ), LDWRKL,
$ WORK( ITAUP ), WORK( IVT ), M,
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Multiply right singular vectors of L in WORK(IVT) by Q
* in A, storing result in WORK(IL) and copying to A
* (Workspace: need 2*M*M, prefer M*M+M*N)
*
DO 30 I = 1, N, CHUNK
BLK = MIN( N-I+1, CHUNK )
CALL SGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IVT ), M,
$ A( 1, I ), LDA, ZERO, WORK( IL ), LDWRKL )
CALL SLACPY( 'F', M, BLK, WORK( IL ), LDWRKL,
$ A( 1, I ), LDA )
30 CONTINUE
*
ELSE IF( WNTQS ) THEN
*
* Path 3t (N much larger than M, JOBZ='S')
* M right singular vectors to be computed in VT and
* M left singular vectors to be computed in U
*
IL = 1
*
* WORK(IL) is M by M
*
LDWRKL = M
ITAU = IL + LDWRKL*M
NWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Copy L to WORK(IL), zeroing out above it
*
CALL SLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL )
CALL SLASET( 'U', M-1, M-1, ZERO, ZERO,
$ WORK( IL+LDWRKL ), LDWRKL )
*
* Generate Q in A
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL SORGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
NWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IU), copying result to U
* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
*
CALL SGEBRD( M, M, WORK( IL ), LDWRKL, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U and computing right singular
* vectors of bidiagonal matrix in VT
* (Workspace: need M+BDSPAC)
*
CALL SBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, VT,
$ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Overwrite U by left singular vectors of L and VT
* by right singular vectors of L
* (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB)
*
CALL SORMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
CALL SORMBR( 'P', 'R', 'T', M, M, M, WORK( IL ), LDWRKL,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Multiply right singular vectors of L in WORK(IL) by
* Q in A, storing result in VT
* (Workspace: need M*M)
*
CALL SLACPY( 'F', M, M, VT, LDVT, WORK( IL ), LDWRKL )
CALL SGEMM( 'N', 'N', M, N, M, ONE, WORK( IL ), LDWRKL,
$ A, LDA, ZERO, VT, LDVT )
*
ELSE IF( WNTQA ) THEN
*
* Path 4t (N much larger than M, JOBZ='A')
* N right singular vectors to be computed in VT and
* M left singular vectors to be computed in U
*
IVT = 1
*
* WORK(IVT) is M by M
*
LDWKVT = M
ITAU = IVT + LDWKVT*M
NWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL SORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Produce L in A, zeroing out other entries
*
CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
NWORK = ITAUP + M
*
* Bidiagonalize L in A
* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
*
CALL SGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U and computing right singular
* vectors of bidiagonal matrix in WORK(IVT)
* (Workspace: need M+M*M+BDSPAC)
*
CALL SBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU,
$ WORK( IVT ), LDWKVT, DUM, IDUM,
$ WORK( NWORK ), IWORK, INFO )
*
* Overwrite U by left singular vectors of L and WORK(IVT)
* by right singular vectors of L
* (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB)
*
CALL SORMBR( 'Q', 'L', 'N', M, M, M, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
CALL SORMBR( 'P', 'R', 'T', M, M, M, A, LDA,
$ WORK( ITAUP ), WORK( IVT ), LDWKVT,
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Multiply right singular vectors of L in WORK(IVT) by
* Q in VT, storing result in A
* (Workspace: need M*M)
*
CALL SGEMM( 'N', 'N', M, N, M, ONE, WORK( IVT ), LDWKVT,
$ VT, LDVT, ZERO, A, LDA )
*
* Copy right singular vectors of A from A to VT
*
CALL SLACPY( 'F', M, N, A, LDA, VT, LDVT )
*
END IF
*
ELSE
*
* N .LT. MNTHR
*
* Path 5t (N greater than M, but not much larger)
* Reduce to bidiagonal form without LQ decomposition
*
IE = 1
ITAUQ = IE + M
ITAUP = ITAUQ + M
NWORK = ITAUP + M
*
* Bidiagonalize A
* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
*
CALL SGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
IF( WNTQN ) THEN
*
* Perform bidiagonal SVD, only computing singular values
* (Workspace: need M+BDSPAC)
*
CALL SBDSDC( 'L', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1,
$ DUM, IDUM, WORK( NWORK ), IWORK, INFO )
ELSE IF( WNTQO ) THEN
LDWKVT = M
IVT = NWORK
IF( LWORK.GE.M*N+3*M+BDSPAC ) THEN
*
* WORK( IVT ) is M by N
*
CALL SLASET( 'F', M, N, ZERO, ZERO, WORK( IVT ),
$ LDWKVT )
NWORK = IVT + LDWKVT*N
ELSE
*
* WORK( IVT ) is M by M
*
NWORK = IVT + LDWKVT*M
IL = NWORK
*
* WORK(IL) is M by CHUNK
*
CHUNK = ( LWORK-M*M-3*M ) / M
END IF
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U and computing right singular
* vectors of bidiagonal matrix in WORK(IVT)
* (Workspace: need M*M+BDSPAC)
*
CALL SBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU,
$ WORK( IVT ), LDWKVT, DUM, IDUM,
$ WORK( NWORK ), IWORK, INFO )
*
* Overwrite U by left singular vectors of A
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL SORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
IF( LWORK.GE.M*N+3*M+BDSPAC ) THEN
*
* Overwrite WORK(IVT) by left singular vectors of A
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL SORMBR( 'P', 'R', 'T', M, N, M, A, LDA,
$ WORK( ITAUP ), WORK( IVT ), LDWKVT,
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Copy right singular vectors of A from WORK(IVT) to A
*
CALL SLACPY( 'F', M, N, WORK( IVT ), LDWKVT, A, LDA )
ELSE
*
* Generate P**T in A
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL SORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Multiply Q in A by right singular vectors of
* bidiagonal matrix in WORK(IVT), storing result in
* WORK(IL) and copying to A
* (Workspace: need 2*M*M, prefer M*M+M*N)
*
DO 40 I = 1, N, CHUNK
BLK = MIN( N-I+1, CHUNK )
CALL SGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IVT ),
$ LDWKVT, A( 1, I ), LDA, ZERO,
$ WORK( IL ), M )
CALL SLACPY( 'F', M, BLK, WORK( IL ), M, A( 1, I ),
$ LDA )
40 CONTINUE
END IF
ELSE IF( WNTQS ) THEN
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U and computing right singular
* vectors of bidiagonal matrix in VT
* (Workspace: need M+BDSPAC)
*
CALL SLASET( 'F', M, N, ZERO, ZERO, VT, LDVT )
CALL SBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT,
$ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Overwrite U by left singular vectors of A and VT
* by right singular vectors of A
* (Workspace: need 3*M, prefer 2*M+M*NB)
*
CALL SORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
CALL SORMBR( 'P', 'R', 'T', M, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
ELSE IF( WNTQA ) THEN
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U and computing right singular
* vectors of bidiagonal matrix in VT
* (Workspace: need M+BDSPAC)
*
CALL SLASET( 'F', N, N, ZERO, ZERO, VT, LDVT )
CALL SBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT,
$ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Set the right corner of VT to identity matrix
*
IF( N.GT.M ) THEN
CALL SLASET( 'F', N-M, N-M, ZERO, ONE, VT( M+1, M+1 ),
$ LDVT )
END IF
*
* Overwrite U by left singular vectors of A and VT
* by right singular vectors of A
* (Workspace: need 2*M+N, prefer 2*M+N*NB)
*
CALL SORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
CALL SORMBR( 'P', 'R', 'T', N, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
END IF
*
END IF
*
END IF
*
* Undo scaling if necessary
*
IF( ISCL.EQ.1 ) THEN
IF( ANRM.GT.BIGNUM )
$ CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
$ IERR )
IF( ANRM.LT.SMLNUM )
$ CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
$ IERR )
END IF
*
* Return optimal workspace in WORK(1)
*
WORK( 1 ) = MAXWRK
*
RETURN
*
* End of SGESDD
*
END
SUBROUTINE SGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
REAL A( LDA, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* SGESV computes the solution to a real system of linear equations
* A * X = B,
* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
*
* The LU decomposition with partial pivoting and row interchanges is
* used to factor A as
* A = P * L * U,
* where P is a permutation matrix, L is unit lower triangular, and U is
* upper triangular. The factored form of A is then used to solve the
* system of equations A * X = B.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of linear equations, i.e., 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/output) REAL array, dimension (LDA,N)
* On entry, the N-by-N coefficient matrix A.
* 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,N).
*
* IPIV (output) INTEGER array, dimension (N)
* The pivot indices that define the permutation matrix P;
* row i of the matrix was interchanged with row IPIV(i).
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the N-by-NRHS matrix of right hand side matrix B.
* On exit, if INFO = 0, the N-by-NRHS 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
* > 0: if INFO = i, U(i,i) is exactly zero. The factorization
* has been completed, but the factor U is exactly
* singular, so the solution could not be computed.
*
* =====================================================================
*
* .. External Subroutines ..
EXTERNAL SGETRF, SGETRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( NRHS.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGESV ', -INFO )
RETURN
END IF
*
* Compute the LU factorization of A.
*
CALL SGETRF( N, N, A, LDA, IPIV, INFO )
IF( INFO.EQ.0 ) THEN
*
* Solve the system A*X = B, overwriting B with X.
*
CALL SGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB,
$ INFO )
END IF
RETURN
*
* End of SGESV
*
END
SUBROUTINE SGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT,
$ WORK, LWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBU, JOBVT
INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), S( * ), U( LDU, * ),
$ VT( LDVT, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGESVD computes the singular value decomposition (SVD) of a real
* M-by-N matrix A, optionally computing the left and/or right singular
* vectors. The SVD is written
*
* A = U * SIGMA * transpose(V)
*
* where SIGMA is an M-by-N matrix which is zero except for its
* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and
* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA
* are the singular values of A; they are real and non-negative, and
* are returned in descending order. The first min(m,n) columns of
* U and V are the left and right singular vectors of A.
*
* Note that the routine returns V**T, not V.
*
* Arguments
* =========
*
* JOBU (input) CHARACTER*1
* Specifies options for computing all or part of the matrix U:
* = 'A': all M columns of U are returned in array U:
* = 'S': the first min(m,n) columns of U (the left singular
* vectors) are returned in the array U;
* = 'O': the first min(m,n) columns of U (the left singular
* vectors) are overwritten on the array A;
* = 'N': no columns of U (no left singular vectors) are
* computed.
*
* JOBVT (input) CHARACTER*1
* Specifies options for computing all or part of the matrix
* V**T:
* = 'A': all N rows of V**T are returned in the array VT;
* = 'S': the first min(m,n) rows of V**T (the right singular
* vectors) are returned in the array VT;
* = 'O': the first min(m,n) rows of V**T (the right singular
* vectors) are overwritten on the array A;
* = 'N': no rows of V**T (no right singular vectors) are
* computed.
*
* JOBVT and JOBU cannot both be 'O'.
*
* M (input) INTEGER
* The number of rows of the input matrix A. M >= 0.
*
* N (input) INTEGER
* The number of columns of the input matrix A. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit,
* if JOBU = 'O', A is overwritten with the first min(m,n)
* columns of U (the left singular vectors,
* stored columnwise);
* if JOBVT = 'O', A is overwritten with the first min(m,n)
* rows of V**T (the right singular vectors,
* stored rowwise);
* if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A
* are destroyed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* S (output) REAL array, dimension (min(M,N))
* The singular values of A, sorted so that S(i) >= S(i+1).
*
* U (output) REAL array, dimension (LDU,UCOL)
* (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.
* If JOBU = 'A', U contains the M-by-M orthogonal matrix U;
* if JOBU = 'S', U contains the first min(m,n) columns of U
* (the left singular vectors, stored columnwise);
* if JOBU = 'N' or 'O', U is not referenced.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= 1; if
* JOBU = 'S' or 'A', LDU >= M.
*
* VT (output) REAL array, dimension (LDVT,N)
* If JOBVT = 'A', VT contains the N-by-N orthogonal matrix
* V**T;
* if JOBVT = 'S', VT contains the first min(m,n) rows of
* V**T (the right singular vectors, stored rowwise);
* if JOBVT = 'N' or 'O', VT is not referenced.
*
* LDVT (input) INTEGER
* The leading dimension of the array VT. LDVT >= 1; if
* JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).
*
* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK;
* if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged
* superdiagonal elements of an upper bidiagonal matrix B
* whose diagonal is in S (not necessarily sorted). B
* satisfies A = U * B * VT, so it has the same singular values
* as A, and singular vectors related by U and VT.
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* LWORK >= MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)).
* For good performance, LWORK should generally be larger.
*
* 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.
* > 0: if SBDSQR did not converge, INFO specifies how many
* superdiagonals of an intermediate bidiagonal form B
* did not converge to zero. See the description of WORK
* above for details.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS,
$ WNTVA, WNTVAS, WNTVN, WNTVO, WNTVS
INTEGER BDSPAC, BLK, CHUNK, I, IE, IERR, IR, ISCL,
$ ITAU, ITAUP, ITAUQ, IU, IWORK, LDWRKR, LDWRKU,
$ MAXWRK, MINMN, MINWRK, MNTHR, NCU, NCVT, NRU,
$ NRVT, WRKBL
REAL ANRM, BIGNUM, EPS, SMLNUM
* ..
* .. Local Arrays ..
REAL DUM( 1 )
* ..
* .. External Subroutines ..
EXTERNAL SBDSQR, SGEBRD, SGELQF, SGEMM, SGEQRF, SLACPY,
$ SLASCL, SLASET, SORGBR, SORGLQ, SORGQR, SORMBR,
$ XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
REAL SLAMCH, SLANGE
EXTERNAL LSAME, ILAENV, SLAMCH, SLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
MINMN = MIN( M, N )
WNTUA = LSAME( JOBU, 'A' )
WNTUS = LSAME( JOBU, 'S' )
WNTUAS = WNTUA .OR. WNTUS
WNTUO = LSAME( JOBU, 'O' )
WNTUN = LSAME( JOBU, 'N' )
WNTVA = LSAME( JOBVT, 'A' )
WNTVS = LSAME( JOBVT, 'S' )
WNTVAS = WNTVA .OR. WNTVS
WNTVO = LSAME( JOBVT, 'O' )
WNTVN = LSAME( JOBVT, 'N' )
LQUERY = ( LWORK.EQ.-1 )
*
IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN
INFO = -1
ELSE IF( .NOT.( WNTVA .OR. WNTVS .OR. WNTVO .OR. WNTVN ) .OR.
$ ( WNTVO .AND. WNTUO ) ) THEN
INFO = -2
ELSE IF( M.LT.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -6
ELSE IF( LDU.LT.1 .OR. ( WNTUAS .AND. LDU.LT.M ) ) THEN
INFO = -9
ELSE IF( LDVT.LT.1 .OR. ( WNTVA .AND. LDVT.LT.N ) .OR.
$ ( WNTVS .AND. LDVT.LT.MINMN ) ) THEN
INFO = -11
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.)
*
IF( INFO.EQ.0 ) THEN
MINWRK = 1
MAXWRK = 1
IF( M.GE.N .AND. MINMN.GT.0 ) THEN
*
* Compute space needed for SBDSQR
*
MNTHR = ILAENV( 6, 'SGESVD', JOBU // JOBVT, M, N, 0, 0 )
BDSPAC = 5*N
IF( M.GE.MNTHR ) THEN
IF( WNTUN ) THEN
*
* Path 1 (M much larger than N, JOBU='N')
*
MAXWRK = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1,
$ -1 )
MAXWRK = MAX( MAXWRK, 3*N+2*N*
$ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
IF( WNTVO .OR. WNTVAS )
$ MAXWRK = MAX( MAXWRK, 3*N+( N-1 )*
$ ILAENV( 1, 'SORGBR', 'P', N, N, N, -1 ) )
MAXWRK = MAX( MAXWRK, BDSPAC )
MINWRK = MAX( 4*N, BDSPAC )
ELSE IF( WNTUO .AND. WNTVN ) THEN
*
* Path 2 (M much larger than N, JOBU='O', JOBVT='N')
*
WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'SORGQR', ' ', M,
$ N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'SORGBR', 'Q', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = MAX( N*N+WRKBL, N*N+M*N+N )
MINWRK = MAX( 3*N+M, BDSPAC )
ELSE IF( WNTUO .AND. WNTVAS ) THEN
*
* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or
* 'A')
*
WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'SORGQR', ' ', M,
$ N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'SORGBR', 'Q', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+( N-1 )*
$ ILAENV( 1, 'SORGBR', 'P', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = MAX( N*N+WRKBL, N*N+M*N+N )
MINWRK = MAX( 3*N+M, BDSPAC )
ELSE IF( WNTUS .AND. WNTVN ) THEN
*
* Path 4 (M much larger than N, JOBU='S', JOBVT='N')
*
WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'SORGQR', ' ', M,
$ N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'SORGBR', 'Q', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = N*N + WRKBL
MINWRK = MAX( 3*N+M, BDSPAC )
ELSE IF( WNTUS .AND. WNTVO ) THEN
*
* Path 5 (M much larger than N, JOBU='S', JOBVT='O')
*
WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'SORGQR', ' ', M,
$ N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'SORGBR', 'Q', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+( N-1 )*
$ ILAENV( 1, 'SORGBR', 'P', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = 2*N*N + WRKBL
MINWRK = MAX( 3*N+M, BDSPAC )
ELSE IF( WNTUS .AND. WNTVAS ) THEN
*
* Path 6 (M much larger than N, JOBU='S', JOBVT='S' or
* 'A')
*
WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'SORGQR', ' ', M,
$ N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'SORGBR', 'Q', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+( N-1 )*
$ ILAENV( 1, 'SORGBR', 'P', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = N*N + WRKBL
MINWRK = MAX( 3*N+M, BDSPAC )
ELSE IF( WNTUA .AND. WNTVN ) THEN
*
* Path 7 (M much larger than N, JOBU='A', JOBVT='N')
*
WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'SORGQR', ' ', M,
$ M, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'SORGBR', 'Q', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = N*N + WRKBL
MINWRK = MAX( 3*N+M, BDSPAC )
ELSE IF( WNTUA .AND. WNTVO ) THEN
*
* Path 8 (M much larger than N, JOBU='A', JOBVT='O')
*
WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'SORGQR', ' ', M,
$ M, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'SORGBR', 'Q', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+( N-1 )*
$ ILAENV( 1, 'SORGBR', 'P', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = 2*N*N + WRKBL
MINWRK = MAX( 3*N+M, BDSPAC )
ELSE IF( WNTUA .AND. WNTVAS ) THEN
*
* Path 9 (M much larger than N, JOBU='A', JOBVT='S' or
* 'A')
*
WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'SORGQR', ' ', M,
$ M, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'SORGBR', 'Q', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+( N-1 )*
$ ILAENV( 1, 'SORGBR', 'P', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = N*N + WRKBL
MINWRK = MAX( 3*N+M, BDSPAC )
END IF
ELSE
*
* Path 10 (M at least N, but not much larger)
*
MAXWRK = 3*N + ( M+N )*ILAENV( 1, 'SGEBRD', ' ', M, N,
$ -1, -1 )
IF( WNTUS .OR. WNTUO )
$ MAXWRK = MAX( MAXWRK, 3*N+N*
$ ILAENV( 1, 'SORGBR', 'Q', M, N, N, -1 ) )
IF( WNTUA )
$ MAXWRK = MAX( MAXWRK, 3*N+M*
$ ILAENV( 1, 'SORGBR', 'Q', M, M, N, -1 ) )
IF( .NOT.WNTVN )
$ MAXWRK = MAX( MAXWRK, 3*N+( N-1 )*
$ ILAENV( 1, 'SORGBR', 'P', N, N, N, -1 ) )
MAXWRK = MAX( MAXWRK, BDSPAC )
MINWRK = MAX( 3*N+M, BDSPAC )
END IF
ELSE IF( MINMN.GT.0 ) THEN
*
* Compute space needed for SBDSQR
*
MNTHR = ILAENV( 6, 'SGESVD', JOBU // JOBVT, M, N, 0, 0 )
BDSPAC = 5*M
IF( N.GE.MNTHR ) THEN
IF( WNTVN ) THEN
*
* Path 1t(N much larger than M, JOBVT='N')
*
MAXWRK = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1,
$ -1 )
MAXWRK = MAX( MAXWRK, 3*M+2*M*
$ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
IF( WNTUO .OR. WNTUAS )
$ MAXWRK = MAX( MAXWRK, 3*M+M*
$ ILAENV( 1, 'SORGBR', 'Q', M, M, M, -1 ) )
MAXWRK = MAX( MAXWRK, BDSPAC )
MINWRK = MAX( 4*M, BDSPAC )
ELSE IF( WNTVO .AND. WNTUN ) THEN
*
* Path 2t(N much larger than M, JOBU='N', JOBVT='O')
*
WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'SORGLQ', ' ', M,
$ N, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*M+( M-1 )*
$ ILAENV( 1, 'SORGBR', 'P', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = MAX( M*M+WRKBL, M*M+M*N+M )
MINWRK = MAX( 3*M+N, BDSPAC )
ELSE IF( WNTVO .AND. WNTUAS ) THEN
*
* Path 3t(N much larger than M, JOBU='S' or 'A',
* JOBVT='O')
*
WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'SORGLQ', ' ', M,
$ N, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*M+( M-1 )*
$ ILAENV( 1, 'SORGBR', 'P', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'SORGBR', 'Q', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = MAX( M*M+WRKBL, M*M+M*N+M )
MINWRK = MAX( 3*M+N, BDSPAC )
ELSE IF( WNTVS .AND. WNTUN ) THEN
*
* Path 4t(N much larger than M, JOBU='N', JOBVT='S')
*
WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'SORGLQ', ' ', M,
$ N, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*M+( M-1 )*
$ ILAENV( 1, 'SORGBR', 'P', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = M*M + WRKBL
MINWRK = MAX( 3*M+N, BDSPAC )
ELSE IF( WNTVS .AND. WNTUO ) THEN
*
* Path 5t(N much larger than M, JOBU='O', JOBVT='S')
*
WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'SORGLQ', ' ', M,
$ N, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*M+( M-1 )*
$ ILAENV( 1, 'SORGBR', 'P', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'SORGBR', 'Q', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = 2*M*M + WRKBL
MINWRK = MAX( 3*M+N, BDSPAC )
MAXWRK = MAX( MAXWRK, MINWRK )
ELSE IF( WNTVS .AND. WNTUAS ) THEN
*
* Path 6t(N much larger than M, JOBU='S' or 'A',
* JOBVT='S')
*
WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'SORGLQ', ' ', M,
$ N, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*M+( M-1 )*
$ ILAENV( 1, 'SORGBR', 'P', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'SORGBR', 'Q', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = M*M + WRKBL
MINWRK = MAX( 3*M+N, BDSPAC )
ELSE IF( WNTVA .AND. WNTUN ) THEN
*
* Path 7t(N much larger than M, JOBU='N', JOBVT='A')
*
WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'SORGLQ', ' ', N,
$ N, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*M+( M-1 )*
$ ILAENV( 1, 'SORGBR', 'P', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = M*M + WRKBL
MINWRK = MAX( 3*M+N, BDSPAC )
ELSE IF( WNTVA .AND. WNTUO ) THEN
*
* Path 8t(N much larger than M, JOBU='O', JOBVT='A')
*
WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'SORGLQ', ' ', N,
$ N, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*M+( M-1 )*
$ ILAENV( 1, 'SORGBR', 'P', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'SORGBR', 'Q', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = 2*M*M + WRKBL
MINWRK = MAX( 3*M+N, BDSPAC )
ELSE IF( WNTVA .AND. WNTUAS ) THEN
*
* Path 9t(N much larger than M, JOBU='S' or 'A',
* JOBVT='A')
*
WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'SORGLQ', ' ', N,
$ N, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*M+( M-1 )*
$ ILAENV( 1, 'SORGBR', 'P', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'SORGBR', 'Q', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC )
MAXWRK = M*M + WRKBL
MINWRK = MAX( 3*M+N, BDSPAC )
END IF
ELSE
*
* Path 10t(N greater than M, but not much larger)
*
MAXWRK = 3*M + ( M+N )*ILAENV( 1, 'SGEBRD', ' ', M, N,
$ -1, -1 )
IF( WNTVS .OR. WNTVO )
$ MAXWRK = MAX( MAXWRK, 3*M+M*
$ ILAENV( 1, 'SORGBR', 'P', M, N, M, -1 ) )
IF( WNTVA )
$ MAXWRK = MAX( MAXWRK, 3*M+N*
$ ILAENV( 1, 'SORGBR', 'P', N, N, M, -1 ) )
IF( .NOT.WNTUN )
$ MAXWRK = MAX( MAXWRK, 3*M+( M-1 )*
$ ILAENV( 1, 'SORGBR', 'Q', M, M, M, -1 ) )
MAXWRK = MAX( MAXWRK, BDSPAC )
MINWRK = MAX( 3*M+N, BDSPAC )
END IF
END IF
MAXWRK = MAX( MAXWRK, MINWRK )
WORK( 1 ) = MAXWRK
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGESVD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
RETURN
END IF
*
* Get machine constants
*
EPS = SLAMCH( 'P' )
SMLNUM = SQRT( SLAMCH( 'S' ) ) / EPS
BIGNUM = ONE / SMLNUM
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = SLANGE( 'M', M, N, A, LDA, DUM )
ISCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
ISCL = 1
CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR )
ELSE IF( ANRM.GT.BIGNUM ) THEN
ISCL = 1
CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR )
END IF
*
IF( M.GE.N ) THEN
*
* A has at least as many rows as columns. If A has sufficiently
* more rows than columns, first reduce using the QR
* decomposition (if sufficient workspace available)
*
IF( M.GE.MNTHR ) THEN
*
IF( WNTUN ) THEN
*
* Path 1 (M much larger than N, JOBU='N')
* No left singular vectors to be computed
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Zero out below R
*
CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
IE = 1
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in A
* (Workspace: need 4*N, prefer 3*N+2*N*NB)
*
CALL SGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
$ IERR )
NCVT = 0
IF( WNTVO .OR. WNTVAS ) THEN
*
* If right singular vectors desired, generate P'.
* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
*
CALL SORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
NCVT = N
END IF
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of A in A if desired
* (Workspace: need BDSPAC)
*
CALL SBDSQR( 'U', N, NCVT, 0, 0, S, WORK( IE ), A, LDA,
$ DUM, 1, DUM, 1, WORK( IWORK ), INFO )
*
* If right singular vectors desired in VT, copy them there
*
IF( WNTVAS )
$ CALL SLACPY( 'F', N, N, A, LDA, VT, LDVT )
*
ELSE IF( WNTUO .AND. WNTVN ) THEN
*
* Path 2 (M much larger than N, JOBU='O', JOBVT='N')
* N left singular vectors to be overwritten on A and
* no right singular vectors to be computed
*
IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+LDA*N ) THEN
*
* WORK(IU) is LDA by N, WORK(IR) is LDA by N
*
LDWRKU = LDA
LDWRKR = LDA
ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+N*N ) THEN
*
* WORK(IU) is LDA by N, WORK(IR) is N by N
*
LDWRKU = LDA
LDWRKR = N
ELSE
*
* WORK(IU) is LDWRKU by N, WORK(IR) is N by N
*
LDWRKU = ( LWORK-N*N-N ) / N
LDWRKR = N
END IF
ITAU = IR + LDWRKR*N
IWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL SGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to WORK(IR) and zero out below it
*
CALL SLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ),
$ LDWRKR )
*
* Generate Q in A
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL SORGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IR)
* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
*
CALL SGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate left vectors bidiagonalizing R
* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
*
CALL SORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IR)
* (Workspace: need N*N+BDSPAC)
*
CALL SBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, 1,
$ WORK( IR ), LDWRKR, DUM, 1,
$ WORK( IWORK ), INFO )
IU = IE + N
*
* Multiply Q in A by left singular vectors of R in
* WORK(IR), storing result in WORK(IU) and copying to A
* (Workspace: need N*N+2*N, prefer N*N+M*N+N)
*
DO 10 I = 1, M, LDWRKU
CHUNK = MIN( M-I+1, LDWRKU )
CALL SGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
$ LDA, WORK( IR ), LDWRKR, ZERO,
$ WORK( IU ), LDWRKU )
CALL SLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
$ A( I, 1 ), LDA )
10 CONTINUE
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
IE = 1
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize A
* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB)
*
CALL SGEBRD( M, N, A, LDA, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate left vectors bidiagonalizing A
* (Workspace: need 4*N, prefer 3*N+N*NB)
*
CALL SORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in A
* (Workspace: need BDSPAC)
*
CALL SBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM, 1,
$ A, LDA, DUM, 1, WORK( IWORK ), INFO )
*
END IF
*
ELSE IF( WNTUO .AND. WNTVAS ) THEN
*
* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or 'A')
* N left singular vectors to be overwritten on A and
* N right singular vectors to be computed in VT
*
IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+LDA*N ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is LDA by N
*
LDWRKU = LDA
LDWRKR = LDA
ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+N*N ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is N by N
*
LDWRKU = LDA
LDWRKR = N
ELSE
*
* WORK(IU) is LDWRKU by N and WORK(IR) is N by N
*
LDWRKU = ( LWORK-N*N-N ) / N
LDWRKR = N
END IF
ITAU = IR + LDWRKR*N
IWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL SGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to VT, zeroing out below it
*
CALL SLACPY( 'U', N, N, A, LDA, VT, LDVT )
IF( N.GT.1 )
$ CALL SLASET( 'L', N-1, N-1, ZERO, ZERO,
$ VT( 2, 1 ), LDVT )
*
* Generate Q in A
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL SORGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in VT, copying result to WORK(IR)
* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
*
CALL SGEBRD( N, N, VT, LDVT, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL SLACPY( 'L', N, N, VT, LDVT, WORK( IR ), LDWRKR )
*
* Generate left vectors bidiagonalizing R in WORK(IR)
* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
*
CALL SORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right vectors bidiagonalizing R in VT
* (Workspace: need N*N+4*N-1, prefer N*N+3*N+(N-1)*NB)
*
CALL SORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IR) and computing right
* singular vectors of R in VT
* (Workspace: need N*N+BDSPAC)
*
CALL SBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, LDVT,
$ WORK( IR ), LDWRKR, DUM, 1,
$ WORK( IWORK ), INFO )
IU = IE + N
*
* Multiply Q in A by left singular vectors of R in
* WORK(IR), storing result in WORK(IU) and copying to A
* (Workspace: need N*N+2*N, prefer N*N+M*N+N)
*
DO 20 I = 1, M, LDWRKU
CHUNK = MIN( M-I+1, LDWRKU )
CALL SGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
$ LDA, WORK( IR ), LDWRKR, ZERO,
$ WORK( IU ), LDWRKU )
CALL SLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
$ A( I, 1 ), LDA )
20 CONTINUE
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL SGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to VT, zeroing out below it
*
CALL SLACPY( 'U', N, N, A, LDA, VT, LDVT )
IF( N.GT.1 )
$ CALL SLASET( 'L', N-1, N-1, ZERO, ZERO,
$ VT( 2, 1 ), LDVT )
*
* Generate Q in A
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL SORGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in VT
* (Workspace: need 4*N, prefer 3*N+2*N*NB)
*
CALL SGEBRD( N, N, VT, LDVT, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in A by left vectors bidiagonalizing R
* (Workspace: need 3*N+M, prefer 3*N+M*NB)
*
CALL SORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
$ WORK( ITAUQ ), A, LDA, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right vectors bidiagonalizing R in VT
* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
*
CALL SORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in A and computing right
* singular vectors of A in VT
* (Workspace: need BDSPAC)
*
CALL SBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT, LDVT,
$ A, LDA, DUM, 1, WORK( IWORK ), INFO )
*
END IF
*
ELSE IF( WNTUS ) THEN
*
IF( WNTVN ) THEN
*
* Path 4 (M much larger than N, JOBU='S', JOBVT='N')
* N left singular vectors to be computed in U and
* no right singular vectors to be computed
*
IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.WRKBL+LDA*N ) THEN
*
* WORK(IR) is LDA by N
*
LDWRKR = LDA
ELSE
*
* WORK(IR) is N by N
*
LDWRKR = N
END IF
ITAU = IR + LDWRKR*N
IWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL SGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to WORK(IR), zeroing out below it
*
CALL SLACPY( 'U', N, N, A, LDA, WORK( IR ),
$ LDWRKR )
CALL SLASET( 'L', N-1, N-1, ZERO, ZERO,
$ WORK( IR+1 ), LDWRKR )
*
* Generate Q in A
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL SORGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IR)
* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
*
CALL SGEBRD( N, N, WORK( IR ), LDWRKR, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left vectors bidiagonalizing R in WORK(IR)
* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
*
CALL SORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IR)
* (Workspace: need N*N+BDSPAC)
*
CALL SBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM,
$ 1, WORK( IR ), LDWRKR, DUM, 1,
$ WORK( IWORK ), INFO )
*
* Multiply Q in A by left singular vectors of R in
* WORK(IR), storing result in U
* (Workspace: need N*N)
*
CALL SGEMM( 'N', 'N', M, N, N, ONE, A, LDA,
$ WORK( IR ), LDWRKR, ZERO, U, LDU )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL SGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL SORGQR( M, N, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Zero out below R in A
*
CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
$ LDA )
*
* Bidiagonalize R in A
* (Workspace: need 4*N, prefer 3*N+2*N*NB)
*
CALL SGEBRD( N, N, A, LDA, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in U by left vectors bidiagonalizing R
* (Workspace: need 3*N+M, prefer 3*N+M*NB)
*
CALL SORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U
* (Workspace: need BDSPAC)
*
CALL SBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM,
$ 1, U, LDU, DUM, 1, WORK( IWORK ),
$ INFO )
*
END IF
*
ELSE IF( WNTVO ) THEN
*
* Path 5 (M much larger than N, JOBU='S', JOBVT='O')
* N left singular vectors to be computed in U and
* N right singular vectors to be overwritten on A
*
IF( LWORK.GE.2*N*N+MAX( 4*N, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+2*LDA*N ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is LDA by N
*
LDWRKU = LDA
IR = IU + LDWRKU*N
LDWRKR = LDA
ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is N by N
*
LDWRKU = LDA
IR = IU + LDWRKU*N
LDWRKR = N
ELSE
*
* WORK(IU) is N by N and WORK(IR) is N by N
*
LDWRKU = N
IR = IU + LDWRKU*N
LDWRKR = N
END IF
ITAU = IR + LDWRKR*N
IWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
*
CALL SGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to WORK(IU), zeroing out below it
*
CALL SLACPY( 'U', N, N, A, LDA, WORK( IU ),
$ LDWRKU )
CALL SLASET( 'L', N-1, N-1, ZERO, ZERO,
$ WORK( IU+1 ), LDWRKU )
*
* Generate Q in A
* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
*
CALL SORGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IU), copying result to
* WORK(IR)
* (Workspace: need 2*N*N+4*N,
* prefer 2*N*N+3*N+2*N*NB)
*
CALL SGEBRD( N, N, WORK( IU ), LDWRKU, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL SLACPY( 'U', N, N, WORK( IU ), LDWRKU,
$ WORK( IR ), LDWRKR )
*
* Generate left bidiagonalizing vectors in WORK(IU)
* (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB)
*
CALL SORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in WORK(IR)
* (Workspace: need 2*N*N+4*N-1,
* prefer 2*N*N+3*N+(N-1)*NB)
*
CALL SORGBR( 'P', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IU) and computing
* right singular vectors of R in WORK(IR)
* (Workspace: need 2*N*N+BDSPAC)
*
CALL SBDSQR( 'U', N, N, N, 0, S, WORK( IE ),
$ WORK( IR ), LDWRKR, WORK( IU ),
$ LDWRKU, DUM, 1, WORK( IWORK ), INFO )
*
* Multiply Q in A by left singular vectors of R in
* WORK(IU), storing result in U
* (Workspace: need N*N)
*
CALL SGEMM( 'N', 'N', M, N, N, ONE, A, LDA,
$ WORK( IU ), LDWRKU, ZERO, U, LDU )
*
* Copy right singular vectors of R to A
* (Workspace: need N*N)
*
CALL SLACPY( 'F', N, N, WORK( IR ), LDWRKR, A,
$ LDA )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL SGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL SORGQR( M, N, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Zero out below R in A
*
CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
$ LDA )
*
* Bidiagonalize R in A
* (Workspace: need 4*N, prefer 3*N+2*N*NB)
*
CALL SGEBRD( N, N, A, LDA, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in U by left vectors bidiagonalizing R
* (Workspace: need 3*N+M, prefer 3*N+M*NB)
*
CALL SORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right vectors bidiagonalizing R in A
* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
*
CALL SORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in A
* (Workspace: need BDSPAC)
*
CALL SBDSQR( 'U', N, N, M, 0, S, WORK( IE ), A,
$ LDA, U, LDU, DUM, 1, WORK( IWORK ),
$ INFO )
*
END IF
*
ELSE IF( WNTVAS ) THEN
*
* Path 6 (M much larger than N, JOBU='S', JOBVT='S'
* or 'A')
* N left singular vectors to be computed in U and
* N right singular vectors to be computed in VT
*
IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+LDA*N ) THEN
*
* WORK(IU) is LDA by N
*
LDWRKU = LDA
ELSE
*
* WORK(IU) is N by N
*
LDWRKU = N
END IF
ITAU = IU + LDWRKU*N
IWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL SGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to WORK(IU), zeroing out below it
*
CALL SLACPY( 'U', N, N, A, LDA, WORK( IU ),
$ LDWRKU )
CALL SLASET( 'L', N-1, N-1, ZERO, ZERO,
$ WORK( IU+1 ), LDWRKU )
*
* Generate Q in A
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL SORGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IU), copying result to VT
* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
*
CALL SGEBRD( N, N, WORK( IU ), LDWRKU, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL SLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT,
$ LDVT )
*
* Generate left bidiagonalizing vectors in WORK(IU)
* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
*
CALL SORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in VT
* (Workspace: need N*N+4*N-1,
* prefer N*N+3*N+(N-1)*NB)
*
CALL SORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IU) and computing
* right singular vectors of R in VT
* (Workspace: need N*N+BDSPAC)
*
CALL SBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT,
$ LDVT, WORK( IU ), LDWRKU, DUM, 1,
$ WORK( IWORK ), INFO )
*
* Multiply Q in A by left singular vectors of R in
* WORK(IU), storing result in U
* (Workspace: need N*N)
*
CALL SGEMM( 'N', 'N', M, N, N, ONE, A, LDA,
$ WORK( IU ), LDWRKU, ZERO, U, LDU )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL SGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL SORGQR( M, N, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to VT, zeroing out below it
*
CALL SLACPY( 'U', N, N, A, LDA, VT, LDVT )
IF( N.GT.1 )
$ CALL SLASET( 'L', N-1, N-1, ZERO, ZERO,
$ VT( 2, 1 ), LDVT )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in VT
* (Workspace: need 4*N, prefer 3*N+2*N*NB)
*
CALL SGEBRD( N, N, VT, LDVT, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in U by left bidiagonalizing vectors
* in VT
* (Workspace: need 3*N+M, prefer 3*N+M*NB)
*
CALL SORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
$ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in VT
* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
*
CALL SORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in VT
* (Workspace: need BDSPAC)
*
CALL SBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT,
$ LDVT, U, LDU, DUM, 1, WORK( IWORK ),
$ INFO )
*
END IF
*
END IF
*
ELSE IF( WNTUA ) THEN
*
IF( WNTVN ) THEN
*
* Path 7 (M much larger than N, JOBU='A', JOBVT='N')
* M left singular vectors to be computed in U and
* no right singular vectors to be computed
*
IF( LWORK.GE.N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.WRKBL+LDA*N ) THEN
*
* WORK(IR) is LDA by N
*
LDWRKR = LDA
ELSE
*
* WORK(IR) is N by N
*
LDWRKR = N
END IF
ITAU = IR + LDWRKR*N
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL SGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Copy R to WORK(IR), zeroing out below it
*
CALL SLACPY( 'U', N, N, A, LDA, WORK( IR ),
$ LDWRKR )
CALL SLASET( 'L', N-1, N-1, ZERO, ZERO,
$ WORK( IR+1 ), LDWRKR )
*
* Generate Q in U
* (Workspace: need N*N+N+M, prefer N*N+N+M*NB)
*
CALL SORGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IR)
* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
*
CALL SGEBRD( N, N, WORK( IR ), LDWRKR, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in WORK(IR)
* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
*
CALL SORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IR)
* (Workspace: need N*N+BDSPAC)
*
CALL SBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM,
$ 1, WORK( IR ), LDWRKR, DUM, 1,
$ WORK( IWORK ), INFO )
*
* Multiply Q in U by left singular vectors of R in
* WORK(IR), storing result in A
* (Workspace: need N*N)
*
CALL SGEMM( 'N', 'N', M, N, N, ONE, U, LDU,
$ WORK( IR ), LDWRKR, ZERO, A, LDA )
*
* Copy left singular vectors of A from A to U
*
CALL SLACPY( 'F', M, N, A, LDA, U, LDU )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL SGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (Workspace: need N+M, prefer N+M*NB)
*
CALL SORGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Zero out below R in A
*
CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
$ LDA )
*
* Bidiagonalize R in A
* (Workspace: need 4*N, prefer 3*N+2*N*NB)
*
CALL SGEBRD( N, N, A, LDA, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in U by left bidiagonalizing vectors
* in A
* (Workspace: need 3*N+M, prefer 3*N+M*NB)
*
CALL SORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U
* (Workspace: need BDSPAC)
*
CALL SBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM,
$ 1, U, LDU, DUM, 1, WORK( IWORK ),
$ INFO )
*
END IF
*
ELSE IF( WNTVO ) THEN
*
* Path 8 (M much larger than N, JOBU='A', JOBVT='O')
* M left singular vectors to be computed in U and
* N right singular vectors to be overwritten on A
*
IF( LWORK.GE.2*N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+2*LDA*N ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is LDA by N
*
LDWRKU = LDA
IR = IU + LDWRKU*N
LDWRKR = LDA
ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is N by N
*
LDWRKU = LDA
IR = IU + LDWRKU*N
LDWRKR = N
ELSE
*
* WORK(IU) is N by N and WORK(IR) is N by N
*
LDWRKU = N
IR = IU + LDWRKU*N
LDWRKR = N
END IF
ITAU = IR + LDWRKR*N
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
*
CALL SGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (Workspace: need 2*N*N+N+M, prefer 2*N*N+N+M*NB)
*
CALL SORGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to WORK(IU), zeroing out below it
*
CALL SLACPY( 'U', N, N, A, LDA, WORK( IU ),
$ LDWRKU )
CALL SLASET( 'L', N-1, N-1, ZERO, ZERO,
$ WORK( IU+1 ), LDWRKU )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IU), copying result to
* WORK(IR)
* (Workspace: need 2*N*N+4*N,
* prefer 2*N*N+3*N+2*N*NB)
*
CALL SGEBRD( N, N, WORK( IU ), LDWRKU, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL SLACPY( 'U', N, N, WORK( IU ), LDWRKU,
$ WORK( IR ), LDWRKR )
*
* Generate left bidiagonalizing vectors in WORK(IU)
* (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB)
*
CALL SORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in WORK(IR)
* (Workspace: need 2*N*N+4*N-1,
* prefer 2*N*N+3*N+(N-1)*NB)
*
CALL SORGBR( 'P', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IU) and computing
* right singular vectors of R in WORK(IR)
* (Workspace: need 2*N*N+BDSPAC)
*
CALL SBDSQR( 'U', N, N, N, 0, S, WORK( IE ),
$ WORK( IR ), LDWRKR, WORK( IU ),
$ LDWRKU, DUM, 1, WORK( IWORK ), INFO )
*
* Multiply Q in U by left singular vectors of R in
* WORK(IU), storing result in A
* (Workspace: need N*N)
*
CALL SGEMM( 'N', 'N', M, N, N, ONE, U, LDU,
$ WORK( IU ), LDWRKU, ZERO, A, LDA )
*
* Copy left singular vectors of A from A to U
*
CALL SLACPY( 'F', M, N, A, LDA, U, LDU )
*
* Copy right singular vectors of R from WORK(IR) to A
*
CALL SLACPY( 'F', N, N, WORK( IR ), LDWRKR, A,
$ LDA )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL SGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (Workspace: need N+M, prefer N+M*NB)
*
CALL SORGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Zero out below R in A
*
CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
$ LDA )
*
* Bidiagonalize R in A
* (Workspace: need 4*N, prefer 3*N+2*N*NB)
*
CALL SGEBRD( N, N, A, LDA, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in U by left bidiagonalizing vectors
* in A
* (Workspace: need 3*N+M, prefer 3*N+M*NB)
*
CALL SORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in A
* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
*
CALL SORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in A
* (Workspace: need BDSPAC)
*
CALL SBDSQR( 'U', N, N, M, 0, S, WORK( IE ), A,
$ LDA, U, LDU, DUM, 1, WORK( IWORK ),
$ INFO )
*
END IF
*
ELSE IF( WNTVAS ) THEN
*
* Path 9 (M much larger than N, JOBU='A', JOBVT='S'
* or 'A')
* M left singular vectors to be computed in U and
* N right singular vectors to be computed in VT
*
IF( LWORK.GE.N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+LDA*N ) THEN
*
* WORK(IU) is LDA by N
*
LDWRKU = LDA
ELSE
*
* WORK(IU) is N by N
*
LDWRKU = N
END IF
ITAU = IU + LDWRKU*N
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
CALL SGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (Workspace: need N*N+N+M, prefer N*N+N+M*NB)
*
CALL SORGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to WORK(IU), zeroing out below it
*
CALL SLACPY( 'U', N, N, A, LDA, WORK( IU ),
$ LDWRKU )
CALL SLASET( 'L', N-1, N-1, ZERO, ZERO,
$ WORK( IU+1 ), LDWRKU )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IU), copying result to VT
* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
*
CALL SGEBRD( N, N, WORK( IU ), LDWRKU, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL SLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT,
$ LDVT )
*
* Generate left bidiagonalizing vectors in WORK(IU)
* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
*
CALL SORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in VT
* (Workspace: need N*N+4*N-1,
* prefer N*N+3*N+(N-1)*NB)
*
CALL SORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IU) and computing
* right singular vectors of R in VT
* (Workspace: need N*N+BDSPAC)
*
CALL SBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT,
$ LDVT, WORK( IU ), LDWRKU, DUM, 1,
$ WORK( IWORK ), INFO )
*
* Multiply Q in U by left singular vectors of R in
* WORK(IU), storing result in A
* (Workspace: need N*N)
*
CALL SGEMM( 'N', 'N', M, N, N, ONE, U, LDU,
$ WORK( IU ), LDWRKU, ZERO, A, LDA )
*
* Copy left singular vectors of A from A to U
*
CALL SLACPY( 'F', M, N, A, LDA, U, LDU )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL SGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (Workspace: need N+M, prefer N+M*NB)
*
CALL SORGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R from A to VT, zeroing out below it
*
CALL SLACPY( 'U', N, N, A, LDA, VT, LDVT )
IF( N.GT.1 )
$ CALL SLASET( 'L', N-1, N-1, ZERO, ZERO,
$ VT( 2, 1 ), LDVT )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in VT
* (Workspace: need 4*N, prefer 3*N+2*N*NB)
*
CALL SGEBRD( N, N, VT, LDVT, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in U by left bidiagonalizing vectors
* in VT
* (Workspace: need 3*N+M, prefer 3*N+M*NB)
*
CALL SORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
$ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in VT
* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
*
CALL SORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in VT
* (Workspace: need BDSPAC)
*
CALL SBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT,
$ LDVT, U, LDU, DUM, 1, WORK( IWORK ),
$ INFO )
*
END IF
*
END IF
*
END IF
*
ELSE
*
* M .LT. MNTHR
*
* Path 10 (M at least N, but not much larger)
* Reduce to bidiagonal form without QR decomposition
*
IE = 1
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize A
* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB)
*
CALL SGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
$ IERR )
IF( WNTUAS ) THEN
*
* If left singular vectors desired in U, copy result to U
* and generate left bidiagonalizing vectors in U
* (Workspace: need 3*N+NCU, prefer 3*N+NCU*NB)
*
CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
IF( WNTUS )
$ NCU = N
IF( WNTUA )
$ NCU = M
CALL SORGBR( 'Q', M, NCU, N, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IF( WNTVAS ) THEN
*
* If right singular vectors desired in VT, copy result to
* VT and generate right bidiagonalizing vectors in VT
* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
*
CALL SLACPY( 'U', N, N, A, LDA, VT, LDVT )
CALL SORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IF( WNTUO ) THEN
*
* If left singular vectors desired in A, generate left
* bidiagonalizing vectors in A
* (Workspace: need 4*N, prefer 3*N+N*NB)
*
CALL SORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IF( WNTVO ) THEN
*
* If right singular vectors desired in A, generate right
* bidiagonalizing vectors in A
* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
*
CALL SORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IWORK = IE + N
IF( WNTUAS .OR. WNTUO )
$ NRU = M
IF( WNTUN )
$ NRU = 0
IF( WNTVAS .OR. WNTVO )
$ NCVT = N
IF( WNTVN )
$ NCVT = 0
IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN
*
* Perform bidiagonal QR iteration, if desired, computing
* left singular vectors in U and computing right singular
* vectors in VT
* (Workspace: need BDSPAC)
*
CALL SBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), VT,
$ LDVT, U, LDU, DUM, 1, WORK( IWORK ), INFO )
ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN
*
* Perform bidiagonal QR iteration, if desired, computing
* left singular vectors in U and computing right singular
* vectors in A
* (Workspace: need BDSPAC)
*
CALL SBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), A, LDA,
$ U, LDU, DUM, 1, WORK( IWORK ), INFO )
ELSE
*
* Perform bidiagonal QR iteration, if desired, computing
* left singular vectors in A and computing right singular
* vectors in VT
* (Workspace: need BDSPAC)
*
CALL SBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), VT,
$ LDVT, A, LDA, DUM, 1, WORK( IWORK ), INFO )
END IF
*
END IF
*
ELSE
*
* A has more columns than rows. If A has sufficiently more
* columns than rows, first reduce using the LQ decomposition (if
* sufficient workspace available)
*
IF( N.GE.MNTHR ) THEN
*
IF( WNTVN ) THEN
*
* Path 1t(N much larger than M, JOBVT='N')
* No right singular vectors to be computed
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Zero out above L
*
CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA )
IE = 1
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in A
* (Workspace: need 4*M, prefer 3*M+2*M*NB)
*
CALL SGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
$ IERR )
IF( WNTUO .OR. WNTUAS ) THEN
*
* If left singular vectors desired, generate Q
* (Workspace: need 4*M, prefer 3*M+M*NB)
*
CALL SORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IWORK = IE + M
NRU = 0
IF( WNTUO .OR. WNTUAS )
$ NRU = M
*
* Perform bidiagonal QR iteration, computing left singular
* vectors of A in A if desired
* (Workspace: need BDSPAC)
*
CALL SBDSQR( 'U', M, 0, NRU, 0, S, WORK( IE ), DUM, 1, A,
$ LDA, DUM, 1, WORK( IWORK ), INFO )
*
* If left singular vectors desired in U, copy them there
*
IF( WNTUAS )
$ CALL SLACPY( 'F', M, M, A, LDA, U, LDU )
*
ELSE IF( WNTVO .AND. WNTUN ) THEN
*
* Path 2t(N much larger than M, JOBU='N', JOBVT='O')
* M right singular vectors to be overwritten on A and
* no left singular vectors to be computed
*
IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+LDA*M ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is LDA by M
*
LDWRKU = LDA
CHUNK = N
LDWRKR = LDA
ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+M*M ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is M by M
*
LDWRKU = LDA
CHUNK = N
LDWRKR = M
ELSE
*
* WORK(IU) is M by CHUNK and WORK(IR) is M by M
*
LDWRKU = M
CHUNK = ( LWORK-M*M-M ) / M
LDWRKR = M
END IF
ITAU = IR + LDWRKR*M
IWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL SGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to WORK(IR) and zero out above it
*
CALL SLACPY( 'L', M, M, A, LDA, WORK( IR ), LDWRKR )
CALL SLASET( 'U', M-1, M-1, ZERO, ZERO,
$ WORK( IR+LDWRKR ), LDWRKR )
*
* Generate Q in A
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL SORGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IR)
* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
*
CALL SGEBRD( M, M, WORK( IR ), LDWRKR, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate right vectors bidiagonalizing L
* (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB)
*
CALL SORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of L in WORK(IR)
* (Workspace: need M*M+BDSPAC)
*
CALL SBDSQR( 'U', M, M, 0, 0, S, WORK( IE ),
$ WORK( IR ), LDWRKR, DUM, 1, DUM, 1,
$ WORK( IWORK ), INFO )
IU = IE + M
*
* Multiply right singular vectors of L in WORK(IR) by Q
* in A, storing result in WORK(IU) and copying to A
* (Workspace: need M*M+2*M, prefer M*M+M*N+M)
*
DO 30 I = 1, N, CHUNK
BLK = MIN( N-I+1, CHUNK )
CALL SGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IR ),
$ LDWRKR, A( 1, I ), LDA, ZERO,
$ WORK( IU ), LDWRKU )
CALL SLACPY( 'F', M, BLK, WORK( IU ), LDWRKU,
$ A( 1, I ), LDA )
30 CONTINUE
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
IE = 1
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize A
* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
*
CALL SGEBRD( M, N, A, LDA, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate right vectors bidiagonalizing A
* (Workspace: need 4*M, prefer 3*M+M*NB)
*
CALL SORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of A in A
* (Workspace: need BDSPAC)
*
CALL SBDSQR( 'L', M, N, 0, 0, S, WORK( IE ), A, LDA,
$ DUM, 1, DUM, 1, WORK( IWORK ), INFO )
*
END IF
*
ELSE IF( WNTVO .AND. WNTUAS ) THEN
*
* Path 3t(N much larger than M, JOBU='S' or 'A', JOBVT='O')
* M right singular vectors to be overwritten on A and
* M left singular vectors to be computed in U
*
IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+LDA*M ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is LDA by M
*
LDWRKU = LDA
CHUNK = N
LDWRKR = LDA
ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+M*M ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is M by M
*
LDWRKU = LDA
CHUNK = N
LDWRKR = M
ELSE
*
* WORK(IU) is M by CHUNK and WORK(IR) is M by M
*
LDWRKU = M
CHUNK = ( LWORK-M*M-M ) / M
LDWRKR = M
END IF
ITAU = IR + LDWRKR*M
IWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL SGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to U, zeroing about above it
*
CALL SLACPY( 'L', M, M, A, LDA, U, LDU )
CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
$ LDU )
*
* Generate Q in A
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL SORGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in U, copying result to WORK(IR)
* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
*
CALL SGEBRD( M, M, U, LDU, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL SLACPY( 'U', M, M, U, LDU, WORK( IR ), LDWRKR )
*
* Generate right vectors bidiagonalizing L in WORK(IR)
* (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB)
*
CALL SORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left vectors bidiagonalizing L in U
* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB)
*
CALL SORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of L in U, and computing right
* singular vectors of L in WORK(IR)
* (Workspace: need M*M+BDSPAC)
*
CALL SBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
$ WORK( IR ), LDWRKR, U, LDU, DUM, 1,
$ WORK( IWORK ), INFO )
IU = IE + M
*
* Multiply right singular vectors of L in WORK(IR) by Q
* in A, storing result in WORK(IU) and copying to A
* (Workspace: need M*M+2*M, prefer M*M+M*N+M))
*
DO 40 I = 1, N, CHUNK
BLK = MIN( N-I+1, CHUNK )
CALL SGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IR ),
$ LDWRKR, A( 1, I ), LDA, ZERO,
$ WORK( IU ), LDWRKU )
CALL SLACPY( 'F', M, BLK, WORK( IU ), LDWRKU,
$ A( 1, I ), LDA )
40 CONTINUE
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL SGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to U, zeroing out above it
*
CALL SLACPY( 'L', M, M, A, LDA, U, LDU )
CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
$ LDU )
*
* Generate Q in A
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL SORGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in U
* (Workspace: need 4*M, prefer 3*M+2*M*NB)
*
CALL SGEBRD( M, M, U, LDU, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right vectors bidiagonalizing L by Q in A
* (Workspace: need 3*M+N, prefer 3*M+N*NB)
*
CALL SORMBR( 'P', 'L', 'T', M, N, M, U, LDU,
$ WORK( ITAUP ), A, LDA, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left vectors bidiagonalizing L in U
* (Workspace: need 4*M, prefer 3*M+M*NB)
*
CALL SORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in A
* (Workspace: need BDSPAC)
*
CALL SBDSQR( 'U', M, N, M, 0, S, WORK( IE ), A, LDA,
$ U, LDU, DUM, 1, WORK( IWORK ), INFO )
*
END IF
*
ELSE IF( WNTVS ) THEN
*
IF( WNTUN ) THEN
*
* Path 4t(N much larger than M, JOBU='N', JOBVT='S')
* M right singular vectors to be computed in VT and
* no left singular vectors to be computed
*
IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.WRKBL+LDA*M ) THEN
*
* WORK(IR) is LDA by M
*
LDWRKR = LDA
ELSE
*
* WORK(IR) is M by M
*
LDWRKR = M
END IF
ITAU = IR + LDWRKR*M
IWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL SGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to WORK(IR), zeroing out above it
*
CALL SLACPY( 'L', M, M, A, LDA, WORK( IR ),
$ LDWRKR )
CALL SLASET( 'U', M-1, M-1, ZERO, ZERO,
$ WORK( IR+LDWRKR ), LDWRKR )
*
* Generate Q in A
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL SORGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IR)
* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
*
CALL SGEBRD( M, M, WORK( IR ), LDWRKR, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right vectors bidiagonalizing L in
* WORK(IR)
* (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB)
*
CALL SORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of L in WORK(IR)
* (Workspace: need M*M+BDSPAC)
*
CALL SBDSQR( 'U', M, M, 0, 0, S, WORK( IE ),
$ WORK( IR ), LDWRKR, DUM, 1, DUM, 1,
$ WORK( IWORK ), INFO )
*
* Multiply right singular vectors of L in WORK(IR) by
* Q in A, storing result in VT
* (Workspace: need M*M)
*
CALL SGEMM( 'N', 'N', M, N, M, ONE, WORK( IR ),
$ LDWRKR, A, LDA, ZERO, VT, LDVT )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL SGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy result to VT
*
CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL SORGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Zero out above L in A
*
CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
$ LDA )
*
* Bidiagonalize L in A
* (Workspace: need 4*M, prefer 3*M+2*M*NB)
*
CALL SGEBRD( M, M, A, LDA, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right vectors bidiagonalizing L by Q in VT
* (Workspace: need 3*M+N, prefer 3*M+N*NB)
*
CALL SORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT,
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of A in VT
* (Workspace: need BDSPAC)
*
CALL SBDSQR( 'U', M, N, 0, 0, S, WORK( IE ), VT,
$ LDVT, DUM, 1, DUM, 1, WORK( IWORK ),
$ INFO )
*
END IF
*
ELSE IF( WNTUO ) THEN
*
* Path 5t(N much larger than M, JOBU='O', JOBVT='S')
* M right singular vectors to be computed in VT and
* M left singular vectors to be overwritten on A
*
IF( LWORK.GE.2*M*M+MAX( 4*M, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+2*LDA*M ) THEN
*
* WORK(IU) is LDA by M and WORK(IR) is LDA by M
*
LDWRKU = LDA
IR = IU + LDWRKU*M
LDWRKR = LDA
ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN
*
* WORK(IU) is LDA by M and WORK(IR) is M by M
*
LDWRKU = LDA
IR = IU + LDWRKU*M
LDWRKR = M
ELSE
*
* WORK(IU) is M by M and WORK(IR) is M by M
*
LDWRKU = M
IR = IU + LDWRKU*M
LDWRKR = M
END IF
ITAU = IR + LDWRKR*M
IWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
*
CALL SGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to WORK(IU), zeroing out below it
*
CALL SLACPY( 'L', M, M, A, LDA, WORK( IU ),
$ LDWRKU )
CALL SLASET( 'U', M-1, M-1, ZERO, ZERO,
$ WORK( IU+LDWRKU ), LDWRKU )
*
* Generate Q in A
* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
*
CALL SORGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IU), copying result to
* WORK(IR)
* (Workspace: need 2*M*M+4*M,
* prefer 2*M*M+3*M+2*M*NB)
*
CALL SGEBRD( M, M, WORK( IU ), LDWRKU, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL SLACPY( 'L', M, M, WORK( IU ), LDWRKU,
$ WORK( IR ), LDWRKR )
*
* Generate right bidiagonalizing vectors in WORK(IU)
* (Workspace: need 2*M*M+4*M-1,
* prefer 2*M*M+3*M+(M-1)*NB)
*
CALL SORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in WORK(IR)
* (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB)
*
CALL SORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of L in WORK(IR) and computing
* right singular vectors of L in WORK(IU)
* (Workspace: need 2*M*M+BDSPAC)
*
CALL SBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
$ WORK( IU ), LDWRKU, WORK( IR ),
$ LDWRKR, DUM, 1, WORK( IWORK ), INFO )
*
* Multiply right singular vectors of L in WORK(IU) by
* Q in A, storing result in VT
* (Workspace: need M*M)
*
CALL SGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
$ LDWRKU, A, LDA, ZERO, VT, LDVT )
*
* Copy left singular vectors of L to A
* (Workspace: need M*M)
*
CALL SLACPY( 'F', M, M, WORK( IR ), LDWRKR, A,
$ LDA )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL SGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL SORGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Zero out above L in A
*
CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
$ LDA )
*
* Bidiagonalize L in A
* (Workspace: need 4*M, prefer 3*M+2*M*NB)
*
CALL SGEBRD( M, M, A, LDA, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right vectors bidiagonalizing L by Q in VT
* (Workspace: need 3*M+N, prefer 3*M+N*NB)
*
CALL SORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT,
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors of L in A
* (Workspace: need 4*M, prefer 3*M+M*NB)
*
CALL SORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, compute left
* singular vectors of A in A and compute right
* singular vectors of A in VT
* (Workspace: need BDSPAC)
*
CALL SBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
$ LDVT, A, LDA, DUM, 1, WORK( IWORK ),
$ INFO )
*
END IF
*
ELSE IF( WNTUAS ) THEN
*
* Path 6t(N much larger than M, JOBU='S' or 'A',
* JOBVT='S')
* M right singular vectors to be computed in VT and
* M left singular vectors to be computed in U
*
IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+LDA*M ) THEN
*
* WORK(IU) is LDA by N
*
LDWRKU = LDA
ELSE
*
* WORK(IU) is LDA by M
*
LDWRKU = M
END IF
ITAU = IU + LDWRKU*M
IWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL SGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to WORK(IU), zeroing out above it
*
CALL SLACPY( 'L', M, M, A, LDA, WORK( IU ),
$ LDWRKU )
CALL SLASET( 'U', M-1, M-1, ZERO, ZERO,
$ WORK( IU+LDWRKU ), LDWRKU )
*
* Generate Q in A
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL SORGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IU), copying result to U
* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
*
CALL SGEBRD( M, M, WORK( IU ), LDWRKU, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL SLACPY( 'L', M, M, WORK( IU ), LDWRKU, U,
$ LDU )
*
* Generate right bidiagonalizing vectors in WORK(IU)
* (Workspace: need M*M+4*M-1,
* prefer M*M+3*M+(M-1)*NB)
*
CALL SORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in U
* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB)
*
CALL SORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of L in U and computing right
* singular vectors of L in WORK(IU)
* (Workspace: need M*M+BDSPAC)
*
CALL SBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
$ WORK( IU ), LDWRKU, U, LDU, DUM, 1,
$ WORK( IWORK ), INFO )
*
* Multiply right singular vectors of L in WORK(IU) by
* Q in A, storing result in VT
* (Workspace: need M*M)
*
CALL SGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
$ LDWRKU, A, LDA, ZERO, VT, LDVT )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL SGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL SORGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to U, zeroing out above it
*
CALL SLACPY( 'L', M, M, A, LDA, U, LDU )
CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
$ LDU )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in U
* (Workspace: need 4*M, prefer 3*M+2*M*NB)
*
CALL SGEBRD( M, M, U, LDU, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right bidiagonalizing vectors in U by Q
* in VT
* (Workspace: need 3*M+N, prefer 3*M+N*NB)
*
CALL SORMBR( 'P', 'L', 'T', M, N, M, U, LDU,
$ WORK( ITAUP ), VT, LDVT,
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in U
* (Workspace: need 4*M, prefer 3*M+M*NB)
*
CALL SORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in VT
* (Workspace: need BDSPAC)
*
CALL SBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
$ LDVT, U, LDU, DUM, 1, WORK( IWORK ),
$ INFO )
*
END IF
*
END IF
*
ELSE IF( WNTVA ) THEN
*
IF( WNTUN ) THEN
*
* Path 7t(N much larger than M, JOBU='N', JOBVT='A')
* N right singular vectors to be computed in VT and
* no left singular vectors to be computed
*
IF( LWORK.GE.M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.WRKBL+LDA*M ) THEN
*
* WORK(IR) is LDA by M
*
LDWRKR = LDA
ELSE
*
* WORK(IR) is M by M
*
LDWRKR = M
END IF
ITAU = IR + LDWRKR*M
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL SGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Copy L to WORK(IR), zeroing out above it
*
CALL SLACPY( 'L', M, M, A, LDA, WORK( IR ),
$ LDWRKR )
CALL SLASET( 'U', M-1, M-1, ZERO, ZERO,
$ WORK( IR+LDWRKR ), LDWRKR )
*
* Generate Q in VT
* (Workspace: need M*M+M+N, prefer M*M+M+N*NB)
*
CALL SORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IR)
* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
*
CALL SGEBRD( M, M, WORK( IR ), LDWRKR, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in WORK(IR)
* (Workspace: need M*M+4*M-1,
* prefer M*M+3*M+(M-1)*NB)
*
CALL SORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of L in WORK(IR)
* (Workspace: need M*M+BDSPAC)
*
CALL SBDSQR( 'U', M, M, 0, 0, S, WORK( IE ),
$ WORK( IR ), LDWRKR, DUM, 1, DUM, 1,
$ WORK( IWORK ), INFO )
*
* Multiply right singular vectors of L in WORK(IR) by
* Q in VT, storing result in A
* (Workspace: need M*M)
*
CALL SGEMM( 'N', 'N', M, N, M, ONE, WORK( IR ),
$ LDWRKR, VT, LDVT, ZERO, A, LDA )
*
* Copy right singular vectors of A from A to VT
*
CALL SLACPY( 'F', M, N, A, LDA, VT, LDVT )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL SGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (Workspace: need M+N, prefer M+N*NB)
*
CALL SORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Zero out above L in A
*
CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
$ LDA )
*
* Bidiagonalize L in A
* (Workspace: need 4*M, prefer 3*M+2*M*NB)
*
CALL SGEBRD( M, M, A, LDA, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right bidiagonalizing vectors in A by Q
* in VT
* (Workspace: need 3*M+N, prefer 3*M+N*NB)
*
CALL SORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT,
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of A in VT
* (Workspace: need BDSPAC)
*
CALL SBDSQR( 'U', M, N, 0, 0, S, WORK( IE ), VT,
$ LDVT, DUM, 1, DUM, 1, WORK( IWORK ),
$ INFO )
*
END IF
*
ELSE IF( WNTUO ) THEN
*
* Path 8t(N much larger than M, JOBU='O', JOBVT='A')
* N right singular vectors to be computed in VT and
* M left singular vectors to be overwritten on A
*
IF( LWORK.GE.2*M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+2*LDA*M ) THEN
*
* WORK(IU) is LDA by M and WORK(IR) is LDA by M
*
LDWRKU = LDA
IR = IU + LDWRKU*M
LDWRKR = LDA
ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN
*
* WORK(IU) is LDA by M and WORK(IR) is M by M
*
LDWRKU = LDA
IR = IU + LDWRKU*M
LDWRKR = M
ELSE
*
* WORK(IU) is M by M and WORK(IR) is M by M
*
LDWRKU = M
IR = IU + LDWRKU*M
LDWRKR = M
END IF
ITAU = IR + LDWRKR*M
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
*
CALL SGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (Workspace: need 2*M*M+M+N, prefer 2*M*M+M+N*NB)
*
CALL SORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to WORK(IU), zeroing out above it
*
CALL SLACPY( 'L', M, M, A, LDA, WORK( IU ),
$ LDWRKU )
CALL SLASET( 'U', M-1, M-1, ZERO, ZERO,
$ WORK( IU+LDWRKU ), LDWRKU )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IU), copying result to
* WORK(IR)
* (Workspace: need 2*M*M+4*M,
* prefer 2*M*M+3*M+2*M*NB)
*
CALL SGEBRD( M, M, WORK( IU ), LDWRKU, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL SLACPY( 'L', M, M, WORK( IU ), LDWRKU,
$ WORK( IR ), LDWRKR )
*
* Generate right bidiagonalizing vectors in WORK(IU)
* (Workspace: need 2*M*M+4*M-1,
* prefer 2*M*M+3*M+(M-1)*NB)
*
CALL SORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in WORK(IR)
* (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB)
*
CALL SORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of L in WORK(IR) and computing
* right singular vectors of L in WORK(IU)
* (Workspace: need 2*M*M+BDSPAC)
*
CALL SBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
$ WORK( IU ), LDWRKU, WORK( IR ),
$ LDWRKR, DUM, 1, WORK( IWORK ), INFO )
*
* Multiply right singular vectors of L in WORK(IU) by
* Q in VT, storing result in A
* (Workspace: need M*M)
*
CALL SGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
$ LDWRKU, VT, LDVT, ZERO, A, LDA )
*
* Copy right singular vectors of A from A to VT
*
CALL SLACPY( 'F', M, N, A, LDA, VT, LDVT )
*
* Copy left singular vectors of A from WORK(IR) to A
*
CALL SLACPY( 'F', M, M, WORK( IR ), LDWRKR, A,
$ LDA )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL SGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (Workspace: need M+N, prefer M+N*NB)
*
CALL SORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Zero out above L in A
*
CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
$ LDA )
*
* Bidiagonalize L in A
* (Workspace: need 4*M, prefer 3*M+2*M*NB)
*
CALL SGEBRD( M, M, A, LDA, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right bidiagonalizing vectors in A by Q
* in VT
* (Workspace: need 3*M+N, prefer 3*M+N*NB)
*
CALL SORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT,
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in A
* (Workspace: need 4*M, prefer 3*M+M*NB)
*
CALL SORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in A and computing right
* singular vectors of A in VT
* (Workspace: need BDSPAC)
*
CALL SBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
$ LDVT, A, LDA, DUM, 1, WORK( IWORK ),
$ INFO )
*
END IF
*
ELSE IF( WNTUAS ) THEN
*
* Path 9t(N much larger than M, JOBU='S' or 'A',
* JOBVT='A')
* N right singular vectors to be computed in VT and
* M left singular vectors to be computed in U
*
IF( LWORK.GE.M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+LDA*M ) THEN
*
* WORK(IU) is LDA by M
*
LDWRKU = LDA
ELSE
*
* WORK(IU) is M by M
*
LDWRKU = M
END IF
ITAU = IU + LDWRKU*M
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
CALL SGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (Workspace: need M*M+M+N, prefer M*M+M+N*NB)
*
CALL SORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to WORK(IU), zeroing out above it
*
CALL SLACPY( 'L', M, M, A, LDA, WORK( IU ),
$ LDWRKU )
CALL SLASET( 'U', M-1, M-1, ZERO, ZERO,
$ WORK( IU+LDWRKU ), LDWRKU )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IU), copying result to U
* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
*
CALL SGEBRD( M, M, WORK( IU ), LDWRKU, S,
$ WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL SLACPY( 'L', M, M, WORK( IU ), LDWRKU, U,
$ LDU )
*
* Generate right bidiagonalizing vectors in WORK(IU)
* (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB)
*
CALL SORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in U
* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB)
*
CALL SORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of L in U and computing right
* singular vectors of L in WORK(IU)
* (Workspace: need M*M+BDSPAC)
*
CALL SBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
$ WORK( IU ), LDWRKU, U, LDU, DUM, 1,
$ WORK( IWORK ), INFO )
*
* Multiply right singular vectors of L in WORK(IU) by
* Q in VT, storing result in A
* (Workspace: need M*M)
*
CALL SGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
$ LDWRKU, VT, LDVT, ZERO, A, LDA )
*
* Copy right singular vectors of A from A to VT
*
CALL SLACPY( 'F', M, N, A, LDA, VT, LDVT )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL SGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (Workspace: need M+N, prefer M+N*NB)
*
CALL SORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to U, zeroing out above it
*
CALL SLACPY( 'L', M, M, A, LDA, U, LDU )
CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
$ LDU )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in U
* (Workspace: need 4*M, prefer 3*M+2*M*NB)
*
CALL SGEBRD( M, M, U, LDU, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right bidiagonalizing vectors in U by Q
* in VT
* (Workspace: need 3*M+N, prefer 3*M+N*NB)
*
CALL SORMBR( 'P', 'L', 'T', M, N, M, U, LDU,
$ WORK( ITAUP ), VT, LDVT,
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in U
* (Workspace: need 4*M, prefer 3*M+M*NB)
*
CALL SORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in VT
* (Workspace: need BDSPAC)
*
CALL SBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
$ LDVT, U, LDU, DUM, 1, WORK( IWORK ),
$ INFO )
*
END IF
*
END IF
*
END IF
*
ELSE
*
* N .LT. MNTHR
*
* Path 10t(N greater than M, but not much larger)
* Reduce to bidiagonal form without LQ decomposition
*
IE = 1
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize A
* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
*
CALL SGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
$ IERR )
IF( WNTUAS ) THEN
*
* If left singular vectors desired in U, copy result to U
* and generate left bidiagonalizing vectors in U
* (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB)
*
CALL SLACPY( 'L', M, M, A, LDA, U, LDU )
CALL SORGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IF( WNTVAS ) THEN
*
* If right singular vectors desired in VT, copy result to
* VT and generate right bidiagonalizing vectors in VT
* (Workspace: need 3*M+NRVT, prefer 3*M+NRVT*NB)
*
CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
IF( WNTVA )
$ NRVT = N
IF( WNTVS )
$ NRVT = M
CALL SORGBR( 'P', NRVT, N, M, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IF( WNTUO ) THEN
*
* If left singular vectors desired in A, generate left
* bidiagonalizing vectors in A
* (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB)
*
CALL SORGBR( 'Q', M, M, N, A, LDA, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IF( WNTVO ) THEN
*
* If right singular vectors desired in A, generate right
* bidiagonalizing vectors in A
* (Workspace: need 4*M, prefer 3*M+M*NB)
*
CALL SORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IWORK = IE + M
IF( WNTUAS .OR. WNTUO )
$ NRU = M
IF( WNTUN )
$ NRU = 0
IF( WNTVAS .OR. WNTVO )
$ NCVT = N
IF( WNTVN )
$ NCVT = 0
IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN
*
* Perform bidiagonal QR iteration, if desired, computing
* left singular vectors in U and computing right singular
* vectors in VT
* (Workspace: need BDSPAC)
*
CALL SBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), VT,
$ LDVT, U, LDU, DUM, 1, WORK( IWORK ), INFO )
ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN
*
* Perform bidiagonal QR iteration, if desired, computing
* left singular vectors in U and computing right singular
* vectors in A
* (Workspace: need BDSPAC)
*
CALL SBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), A, LDA,
$ U, LDU, DUM, 1, WORK( IWORK ), INFO )
ELSE
*
* Perform bidiagonal QR iteration, if desired, computing
* left singular vectors in A and computing right singular
* vectors in VT
* (Workspace: need BDSPAC)
*
CALL SBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), VT,
$ LDVT, A, LDA, DUM, 1, WORK( IWORK ), INFO )
END IF
*
END IF
*
END IF
*
* If SBDSQR failed to converge, copy unconverged superdiagonals
* to WORK( 2:MINMN )
*
IF( INFO.NE.0 ) THEN
IF( IE.GT.2 ) THEN
DO 50 I = 1, MINMN - 1
WORK( I+1 ) = WORK( I+IE-1 )
50 CONTINUE
END IF
IF( IE.LT.2 ) THEN
DO 60 I = MINMN - 1, 1, -1
WORK( I+1 ) = WORK( I+IE-1 )
60 CONTINUE
END IF
END IF
*
* Undo scaling if necessary
*
IF( ISCL.EQ.1 ) THEN
IF( ANRM.GT.BIGNUM )
$ CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
$ IERR )
IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM )
$ CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN-1, 1, WORK( 2 ),
$ MINMN, IERR )
IF( ANRM.LT.SMLNUM )
$ CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
$ IERR )
IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM )
$ CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN-1, 1, WORK( 2 ),
$ MINMN, IERR )
END IF
*
* Return optimal workspace in WORK(1)
*
WORK( 1 ) = MAXWRK
*
RETURN
*
* End of SGESVD
*
END
SUBROUTINE SGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV,
$ EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR,
$ WORK, IWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER EQUED, FACT, TRANS
INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
REAL RCOND
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), IWORK( * )
REAL A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
$ BERR( * ), C( * ), FERR( * ), R( * ),
$ WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* SGESVX uses the LU factorization to compute the solution to a real
* system of linear equations
* A * X = B,
* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
*
* Error bounds on the solution and a condition estimate are also
* provided.
*
* Description
* ===========
*
* The following steps are performed:
*
* 1. If FACT = 'E', real scaling factors are computed to equilibrate
* the system:
* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B
* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
* Whether or not the system will be equilibrated depends on the
* scaling of the matrix A, but if equilibration is used, A is
* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
* or diag(C)*B (if TRANS = 'T' or 'C').
*
* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the
* matrix A (after equilibration if FACT = 'E') as
* A = P * L * U,
* where P is a permutation matrix, L is a unit lower triangular
* matrix, and U is upper triangular.
*
* 3. If some U(i,i)=0, so that U is exactly singular, then the routine
* returns with INFO = i. Otherwise, the factored form of A is used
* to estimate the condition number of the matrix A. If the
* reciprocal of the condition number is less than machine precision,
* INFO = N+1 is returned as a warning, but the routine still goes on
* to solve for X and compute error bounds as described below.
*
* 4. The system of equations is solved for X using the factored form
* of A.
*
* 5. Iterative refinement is applied to improve the computed solution
* matrix and calculate error bounds and backward error estimates
* for it.
*
* 6. If equilibration was used, the matrix X is premultiplied by
* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
* that it solves the original system before equilibration.
*
* Arguments
* =========
*
* FACT (input) CHARACTER*1
* Specifies whether or not the factored form of the matrix A is
* supplied on entry, and if not, whether the matrix A should be
* equilibrated before it is factored.
* = 'F': On entry, AF and IPIV contain the factored form of A.
* If EQUED is not 'N', the matrix A has been
* equilibrated with scaling factors given by R and C.
* A, AF, and IPIV are not modified.
* = 'N': The matrix A will be copied to AF and factored.
* = 'E': The matrix A will be equilibrated if necessary, then
* copied to AF and factored.
*
* 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**H * X = B (Transpose)
*
* N (input) INTEGER
* The number of linear equations, i.e., 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 matrices B and X. NRHS >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is
* not 'N', then A must have been equilibrated by the scaling
* factors in R and/or C. A is not modified if FACT = 'F' or
* 'N', or if FACT = 'E' and EQUED = 'N' on exit.
*
* On exit, if EQUED .ne. 'N', A is scaled as follows:
* EQUED = 'R': A := diag(R) * A
* EQUED = 'C': A := A * diag(C)
* EQUED = 'B': A := diag(R) * A * diag(C).
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* AF (input or output) REAL array, dimension (LDAF,N)
* If FACT = 'F', then AF is an input argument and on entry
* contains the factors L and U from the factorization
* A = P*L*U as computed by SGETRF. If EQUED .ne. 'N', then
* AF is the factored form of the equilibrated matrix A.
*
* If FACT = 'N', then AF is an output argument and on exit
* returns the factors L and U from the factorization A = P*L*U
* of the original matrix A.
*
* If FACT = 'E', then AF is an output argument and on exit
* returns the factors L and U from the factorization A = P*L*U
* of the equilibrated matrix A (see the description of A for
* the form of the equilibrated matrix).
*
* LDAF (input) INTEGER
* The leading dimension of the array AF. LDAF >= max(1,N).
*
* IPIV (input or output) INTEGER array, dimension (N)
* If FACT = 'F', then IPIV is an input argument and on entry
* contains the pivot indices from the factorization A = P*L*U
* as computed by SGETRF; row i of the matrix was interchanged
* with row IPIV(i).
*
* If FACT = 'N', then IPIV is an output argument and on exit
* contains the pivot indices from the factorization A = P*L*U
* of the original matrix A.
*
* If FACT = 'E', then IPIV is an output argument and on exit
* contains the pivot indices from the factorization A = P*L*U
* of the equilibrated matrix A.
*
* EQUED (input or output) CHARACTER*1
* Specifies the form of equilibration that was done.
* = 'N': No equilibration (always true if FACT = 'N').
* = 'R': Row equilibration, i.e., A has been premultiplied by
* diag(R).
* = 'C': Column equilibration, i.e., A has been postmultiplied
* by diag(C).
* = 'B': Both row and column equilibration, i.e., A has been
* replaced by diag(R) * A * diag(C).
* EQUED is an input argument if FACT = 'F'; otherwise, it is an
* output argument.
*
* R (input or output) REAL array, dimension (N)
* The row scale factors for A. If EQUED = 'R' or 'B', A is
* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
* is not accessed. R is an input argument if FACT = 'F';
* otherwise, R is an output argument. If FACT = 'F' and
* EQUED = 'R' or 'B', each element of R must be positive.
*
* C (input or output) REAL array, dimension (N)
* The column scale factors for A. If EQUED = 'C' or 'B', A is
* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
* is not accessed. C is an input argument if FACT = 'F';
* otherwise, C is an output argument. If FACT = 'F' and
* EQUED = 'C' or 'B', each element of C must be positive.
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the N-by-NRHS right hand side matrix B.
* On exit,
* if EQUED = 'N', B is not modified;
* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
* diag(R)*B;
* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
* overwritten by diag(C)*B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (output) REAL array, dimension (LDX,NRHS)
* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X
* to the original system of equations. Note that A and B are
* modified on exit if EQUED .ne. 'N', and the solution to the
* equilibrated system is inv(diag(C))*X if TRANS = 'N' and
* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'
* and EQUED = 'R' or 'B'.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* RCOND (output) REAL
* The estimate of the reciprocal condition number of the matrix
* A after equilibration (if done). If RCOND is less than the
* machine precision (in particular, if RCOND = 0), the matrix
* is singular to working precision. This condition is
* indicated by a return code of INFO > 0.
*
* FERR (output) REAL array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace/output) REAL array, dimension (4*N)
* On exit, WORK(1) contains the reciprocal pivot growth
* factor norm(A)/norm(U). The "max absolute element" norm is
* used. If WORK(1) is much less than 1, then the stability
* of the LU factorization of the (equilibrated) matrix A
* could be poor. This also means that the solution X, condition
* estimator RCOND, and forward error bound FERR could be
* unreliable. If factorization fails with 0 0: if INFO = i, and i is
* <= N: U(i,i) is exactly zero. The factorization has
* been completed, but the factor U is exactly
* singular, so the solution and error bounds
* could not be computed. RCOND = 0 is returned.
* = N+1: U is nonsingular, but RCOND is less than machine
* precision, meaning that the matrix is singular
* to working precision. Nevertheless, the
* solution and error bounds are computed because
* there are a number of situations where the
* computed solution can be more accurate than the
* value of RCOND would suggest.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU
CHARACTER NORM
INTEGER I, INFEQU, J
REAL AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN,
$ ROWCND, RPVGRW, SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANGE, SLANTR
EXTERNAL LSAME, SLAMCH, SLANGE, SLANTR
* ..
* .. External Subroutines ..
EXTERNAL SGECON, SGEEQU, SGERFS, SGETRF, SGETRS, SLACPY,
$ SLAQGE, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
NOFACT = LSAME( FACT, 'N' )
EQUIL = LSAME( FACT, 'E' )
NOTRAN = LSAME( TRANS, 'N' )
IF( NOFACT .OR. EQUIL ) THEN
EQUED = 'N'
ROWEQU = .FALSE.
COLEQU = .FALSE.
ELSE
ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
SMLNUM = SLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
END IF
*
* Test the input parameters.
*
IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
$ THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
$ LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
$ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
INFO = -10
ELSE
IF( ROWEQU ) THEN
RCMIN = BIGNUM
RCMAX = ZERO
DO 10 J = 1, N
RCMIN = MIN( RCMIN, R( J ) )
RCMAX = MAX( RCMAX, R( J ) )
10 CONTINUE
IF( RCMIN.LE.ZERO ) THEN
INFO = -11
ELSE IF( N.GT.0 ) THEN
ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
ELSE
ROWCND = ONE
END IF
END IF
IF( COLEQU .AND. INFO.EQ.0 ) THEN
RCMIN = BIGNUM
RCMAX = ZERO
DO 20 J = 1, N
RCMIN = MIN( RCMIN, C( J ) )
RCMAX = MAX( RCMAX, C( J ) )
20 CONTINUE
IF( RCMIN.LE.ZERO ) THEN
INFO = -12
ELSE IF( N.GT.0 ) THEN
COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
ELSE
COLCND = ONE
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -14
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -16
END IF
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGESVX', -INFO )
RETURN
END IF
*
IF( EQUIL ) THEN
*
* Compute row and column scalings to equilibrate the matrix A.
*
CALL SGEEQU( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFEQU )
IF( INFEQU.EQ.0 ) THEN
*
* Equilibrate the matrix.
*
CALL SLAQGE( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
$ EQUED )
ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
END IF
END IF
*
* Scale the right hand side.
*
IF( NOTRAN ) THEN
IF( ROWEQU ) THEN
DO 40 J = 1, NRHS
DO 30 I = 1, N
B( I, J ) = R( I )*B( I, J )
30 CONTINUE
40 CONTINUE
END IF
ELSE IF( COLEQU ) THEN
DO 60 J = 1, NRHS
DO 50 I = 1, N
B( I, J ) = C( I )*B( I, J )
50 CONTINUE
60 CONTINUE
END IF
*
IF( NOFACT .OR. EQUIL ) THEN
*
* Compute the LU factorization of A.
*
CALL SLACPY( 'Full', N, N, A, LDA, AF, LDAF )
CALL SGETRF( N, N, AF, LDAF, IPIV, INFO )
*
* Return if INFO is non-zero.
*
IF( INFO.GT.0 ) THEN
*
* Compute the reciprocal pivot growth factor of the
* leading rank-deficient INFO columns of A.
*
RPVGRW = SLANTR( 'M', 'U', 'N', INFO, INFO, AF, LDAF,
$ WORK )
IF( RPVGRW.EQ.ZERO ) THEN
RPVGRW = ONE
ELSE
RPVGRW = SLANGE( 'M', N, INFO, A, LDA, WORK ) / RPVGRW
END IF
WORK( 1 ) = RPVGRW
RCOND = ZERO
RETURN
END IF
END IF
*
* Compute the norm of the matrix A and the
* reciprocal pivot growth factor RPVGRW.
*
IF( NOTRAN ) THEN
NORM = '1'
ELSE
NORM = 'I'
END IF
ANORM = SLANGE( NORM, N, N, A, LDA, WORK )
RPVGRW = SLANTR( 'M', 'U', 'N', N, N, AF, LDAF, WORK )
IF( RPVGRW.EQ.ZERO ) THEN
RPVGRW = ONE
ELSE
RPVGRW = SLANGE( 'M', N, N, A, LDA, WORK ) / RPVGRW
END IF
*
* Compute the reciprocal of the condition number of A.
*
CALL SGECON( NORM, N, AF, LDAF, ANORM, RCOND, WORK, IWORK, INFO )
*
* Compute the solution matrix X.
*
CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
CALL SGETRS( TRANS, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO )
*
* Use iterative refinement to improve the computed solution and
* compute error bounds and backward error estimates for it.
*
CALL SGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X,
$ LDX, FERR, BERR, WORK, IWORK, INFO )
*
* Transform the solution matrix X to a solution of the original
* system.
*
IF( NOTRAN ) THEN
IF( COLEQU ) THEN
DO 80 J = 1, NRHS
DO 70 I = 1, N
X( I, J ) = C( I )*X( I, J )
70 CONTINUE
80 CONTINUE
DO 90 J = 1, NRHS
FERR( J ) = FERR( J ) / COLCND
90 CONTINUE
END IF
ELSE IF( ROWEQU ) THEN
DO 110 J = 1, NRHS
DO 100 I = 1, N
X( I, J ) = R( I )*X( I, J )
100 CONTINUE
110 CONTINUE
DO 120 J = 1, NRHS
FERR( J ) = FERR( J ) / ROWCND
120 CONTINUE
END IF
*
* Set INFO = N+1 if the matrix is singular to working precision.
*
IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
$ INFO = N + 1
*
WORK( 1 ) = RPVGRW
RETURN
*
* End of SGESVX
*
END
SUBROUTINE SGETC2( N, A, LDA, IPIV, JPIV, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), JPIV( * )
REAL A( LDA, * )
* ..
*
* Purpose
* =======
*
* SGETC2 computes an LU factorization with complete pivoting of the
* n-by-n matrix A. The factorization has the form A = P * L * U * Q,
* where P and Q are permutation matrices, L is lower triangular with
* unit diagonal elements and U is upper triangular.
*
* This is the Level 2 BLAS algorithm.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) REAL array, dimension (LDA, N)
* On entry, the n-by-n matrix A to be factored.
* On exit, the factors L and U from the factorization
* A = P*L*U*Q; the unit diagonal elements of L are not stored.
* If U(k, k) appears to be less than SMIN, U(k, k) is given the
* value of SMIN, i.e., giving a nonsingular perturbed system.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* IPIV (output) INTEGER array, dimension(N).
* The pivot indices; for 1 <= i <= N, row i of the
* matrix has been interchanged with row IPIV(i).
*
* JPIV (output) INTEGER array, dimension(N).
* The pivot indices; for 1 <= j <= N, column j of the
* matrix has been interchanged with column JPIV(j).
*
* INFO (output) INTEGER
* = 0: successful exit
* > 0: if INFO = k, U(k, k) is likely to produce owerflow if
* we try to solve for x in Ax = b. So U is perturbed to
* avoid the overflow.
*
* Further Details
* ===============
*
* Based on contributions by
* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
* Umea University, S-901 87 Umea, Sweden.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, IP, IPV, J, JP, JPV
REAL BIGNUM, EPS, SMIN, SMLNUM, XMAX
* ..
* .. External Subroutines ..
EXTERNAL SGER, SLABAD, SSWAP
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Set constants to control overflow
*
INFO = 0
EPS = SLAMCH( 'P' )
SMLNUM = SLAMCH( 'S' ) / EPS
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
*
* Factorize A using complete pivoting.
* Set pivots less than SMIN to SMIN.
*
DO 40 I = 1, N - 1
*
* Find max element in matrix A
*
XMAX = ZERO
DO 20 IP = I, N
DO 10 JP = I, N
IF( ABS( A( IP, JP ) ).GE.XMAX ) THEN
XMAX = ABS( A( IP, JP ) )
IPV = IP
JPV = JP
END IF
10 CONTINUE
20 CONTINUE
IF( I.EQ.1 )
$ SMIN = MAX( EPS*XMAX, SMLNUM )
*
* Swap rows
*
IF( IPV.NE.I )
$ CALL SSWAP( N, A( IPV, 1 ), LDA, A( I, 1 ), LDA )
IPIV( I ) = IPV
*
* Swap columns
*
IF( JPV.NE.I )
$ CALL SSWAP( N, A( 1, JPV ), 1, A( 1, I ), 1 )
JPIV( I ) = JPV
*
* Check for singularity
*
IF( ABS( A( I, I ) ).LT.SMIN ) THEN
INFO = I
A( I, I ) = SMIN
END IF
DO 30 J = I + 1, N
A( J, I ) = A( J, I ) / A( I, I )
30 CONTINUE
CALL SGER( N-I, N-I, -ONE, A( I+1, I ), 1, A( I, I+1 ), LDA,
$ A( I+1, I+1 ), LDA )
40 CONTINUE
*
IF( ABS( A( N, N ) ).LT.SMIN ) THEN
INFO = N
A( N, N ) = SMIN
END IF
*
RETURN
*
* End of SGETC2
*
END
SUBROUTINE SGETF2( M, N, A, LDA, IPIV, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
REAL A( LDA, * )
* ..
*
* Purpose
* =======
*
* SGETF2 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) REAL 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 ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
REAL SFMIN
INTEGER I, J, JP
* ..
* .. External Functions ..
REAL SLAMCH
INTEGER ISAMAX
EXTERNAL SLAMCH, ISAMAX
* ..
* .. External Subroutines ..
EXTERNAL SGER, SSCAL, SSWAP, 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( 'SGETF2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
* Compute machine safe minimum
*
SFMIN = SLAMCH('S')
*
DO 10 J = 1, MIN( M, N )
*
* Find pivot and test for singularity.
*
JP = J - 1 + ISAMAX( 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 SSWAP( 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 SSCAL( 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 SGER( 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 SGETF2
*
END
SUBROUTINE SGETRF( M, N, A, LDA, IPIV, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
REAL A( LDA, * )
* ..
*
* Purpose
* =======
*
* SGETRF 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) REAL 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 ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, IINFO, J, JB, NB
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SGETF2, SLASWP, STRSM, 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( 'SGETRF', -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, 'SGETRF', ' ', M, N, -1, -1 )
IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
*
* Use unblocked code.
*
CALL SGETF2( 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 SGETF2( 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 SLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
*
IF( J+JB.LE.N ) THEN
*
* Apply interchanges to columns J+JB:N.
*
CALL SLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1,
$ IPIV, 1 )
*
* Compute block row of U.
*
CALL STRSM( '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 SGEMM( '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 SGETRF
*
END
SUBROUTINE SGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
REAL A( LDA, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGETRI computes the inverse of a matrix using the LU factorization
* computed by SGETRF.
*
* This method inverts U and then computes inv(A) by solving the system
* inv(A)*L = inv(U) for inv(A).
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the factors L and U from the factorization
* A = P*L*U as computed by SGETRF.
* On exit, if INFO = 0, the inverse of the original matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices from SGETRF; for 1<=i<=N, row i of the
* matrix was interchanged with row IPIV(i).
*
* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
* On exit, if INFO=0, then WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK. LWORK >= max(1,N).
* For optimal performance LWORK >= N*NB, where NB is
* the optimal blocksize returned by ILAENV.
*
* 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
* > 0: if INFO = i, U(i,i) is exactly zero; the matrix is
* singular and its inverse could not be computed.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB,
$ NBMIN, NN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SGEMV, SSWAP, STRSM, STRTRI, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
NB = ILAENV( 1, 'SGETRI', ' ', N, -1, -1, -1 )
LWKOPT = N*NB
WORK( 1 ) = LWKOPT
LQUERY = ( LWORK.EQ.-1 )
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -3
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGETRI', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Form inv(U). If INFO > 0 from STRTRI, then U is singular,
* and the inverse is not computed.
*
CALL STRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO )
IF( INFO.GT.0 )
$ RETURN
*
NBMIN = 2
LDWORK = N
IF( NB.GT.1 .AND. NB.LT.N ) THEN
IWS = MAX( LDWORK*NB, 1 )
IF( LWORK.LT.IWS ) THEN
NB = LWORK / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'SGETRI', ' ', N, -1, -1, -1 ) )
END IF
ELSE
IWS = N
END IF
*
* Solve the equation inv(A)*L = inv(U) for inv(A).
*
IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN
*
* Use unblocked code.
*
DO 20 J = N, 1, -1
*
* Copy current column of L to WORK and replace with zeros.
*
DO 10 I = J + 1, N
WORK( I ) = A( I, J )
A( I, J ) = ZERO
10 CONTINUE
*
* Compute current column of inv(A).
*
IF( J.LT.N )
$ CALL SGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ),
$ LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 )
20 CONTINUE
ELSE
*
* Use blocked code.
*
NN = ( ( N-1 ) / NB )*NB + 1
DO 50 J = NN, 1, -NB
JB = MIN( NB, N-J+1 )
*
* Copy current block column of L to WORK and replace with
* zeros.
*
DO 40 JJ = J, J + JB - 1
DO 30 I = JJ + 1, N
WORK( I+( JJ-J )*LDWORK ) = A( I, JJ )
A( I, JJ ) = ZERO
30 CONTINUE
40 CONTINUE
*
* Compute current block column of inv(A).
*
IF( J+JB.LE.N )
$ CALL SGEMM( 'No transpose', 'No transpose', N, JB,
$ N-J-JB+1, -ONE, A( 1, J+JB ), LDA,
$ WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA )
CALL STRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB,
$ ONE, WORK( J ), LDWORK, A( 1, J ), LDA )
50 CONTINUE
END IF
*
* Apply column interchanges.
*
DO 60 J = N - 1, 1, -1
JP = IPIV( J )
IF( JP.NE.J )
$ CALL SSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 )
60 CONTINUE
*
WORK( 1 ) = IWS
RETURN
*
* End of SGETRI
*
END
SUBROUTINE SGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
REAL A( LDA, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* SGETRS solves a system of linear equations
* A * X = B or A' * X = B
* with a general N-by-N matrix A using the LU factorization computed
* by SGETRF.
*
* Arguments
* =========
*
* TRANS (input) CHARACTER*1
* Specifies the form of the system of equations:
* = 'N': A * X = B (No transpose)
* = 'T': A'* X = B (Transpose)
* = 'C': A'* 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) REAL array, dimension (LDA,N)
* The factors L and U from the factorization A = P*L*U
* as computed by SGETRF.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices from SGETRF; for 1<=i<=N, row i of the
* matrix was interchanged with row IPIV(i).
*
* B (input/output) REAL 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 ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SLASWP, STRSM, 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( 'SGETRS', -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 SLASWP( NRHS, B, LDB, 1, N, IPIV, 1 )
*
* Solve L*X = B, overwriting B with X.
*
CALL STRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS,
$ ONE, A, LDA, B, LDB )
*
* Solve U*X = B, overwriting B with X.
*
CALL STRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N,
$ NRHS, ONE, A, LDA, B, LDB )
ELSE
*
* Solve A' * X = B.
*
* Solve U'*X = B, overwriting B with X.
*
CALL STRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS,
$ ONE, A, LDA, B, LDB )
*
* Solve L'*X = B, overwriting B with X.
*
CALL STRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE,
$ A, LDA, B, LDB )
*
* Apply row interchanges to the solution vectors.
*
CALL SLASWP( NRHS, B, LDB, 1, N, IPIV, -1 )
END IF
*
RETURN
*
* End of SGETRS
*
END
SUBROUTINE SGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V,
$ LDV, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOB, SIDE
INTEGER IHI, ILO, INFO, LDV, M, N
* ..
* .. Array Arguments ..
REAL LSCALE( * ), RSCALE( * ), V( LDV, * )
* ..
*
* Purpose
* =======
*
* SGGBAK forms the right or left eigenvectors of a real generalized
* eigenvalue problem A*x = lambda*B*x, by backward transformation on
* the computed eigenvectors of the balanced pair of matrices output by
* SGGBAL.
*
* Arguments
* =========
*
* JOB (input) CHARACTER*1
* Specifies the type of backward transformation required:
* = 'N': do nothing, return immediately;
* = 'P': do backward transformation for permutation only;
* = 'S': do backward transformation for scaling only;
* = 'B': do backward transformations for both permutation and
* scaling.
* JOB must be the same as the argument JOB supplied to SGGBAL.
*
* SIDE (input) CHARACTER*1
* = 'R': V contains right eigenvectors;
* = 'L': V contains left eigenvectors.
*
* N (input) INTEGER
* The number of rows of the matrix V. N >= 0.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* The integers ILO and IHI determined by SGGBAL.
* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
*
* LSCALE (input) REAL array, dimension (N)
* Details of the permutations and/or scaling factors applied
* to the left side of A and B, as returned by SGGBAL.
*
* RSCALE (input) REAL array, dimension (N)
* Details of the permutations and/or scaling factors applied
* to the right side of A and B, as returned by SGGBAL.
*
* M (input) INTEGER
* The number of columns of the matrix V. M >= 0.
*
* V (input/output) REAL array, dimension (LDV,M)
* On entry, the matrix of right or left eigenvectors to be
* transformed, as returned by STGEVC.
* On exit, V is overwritten by the transformed eigenvectors.
*
* LDV (input) INTEGER
* The leading dimension of the matrix V. LDV >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* See R.C. Ward, Balancing the generalized eigenvalue problem,
* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LEFTV, RIGHTV
INTEGER I, K
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SSCAL, SSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
RIGHTV = LSAME( SIDE, 'R' )
LEFTV = LSAME( SIDE, 'L' )
*
INFO = 0
IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
$ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
INFO = -1
ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ILO.LT.1 ) THEN
INFO = -4
ELSE IF( N.EQ.0 .AND. IHI.EQ.0 .AND. ILO.NE.1 ) THEN
INFO = -4
ELSE IF( N.GT.0 .AND. ( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) )
$ THEN
INFO = -5
ELSE IF( N.EQ.0 .AND. ILO.EQ.1 .AND. IHI.NE.0 ) THEN
INFO = -5
ELSE IF( M.LT.0 ) THEN
INFO = -8
ELSE IF( LDV.LT.MAX( 1, N ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGGBAK', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
IF( M.EQ.0 )
$ RETURN
IF( LSAME( JOB, 'N' ) )
$ RETURN
*
IF( ILO.EQ.IHI )
$ GO TO 30
*
* Backward balance
*
IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN
*
* Backward transformation on right eigenvectors
*
IF( RIGHTV ) THEN
DO 10 I = ILO, IHI
CALL SSCAL( M, RSCALE( I ), V( I, 1 ), LDV )
10 CONTINUE
END IF
*
* Backward transformation on left eigenvectors
*
IF( LEFTV ) THEN
DO 20 I = ILO, IHI
CALL SSCAL( M, LSCALE( I ), V( I, 1 ), LDV )
20 CONTINUE
END IF
END IF
*
* Backward permutation
*
30 CONTINUE
IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN
*
* Backward permutation on right eigenvectors
*
IF( RIGHTV ) THEN
IF( ILO.EQ.1 )
$ GO TO 50
*
DO 40 I = ILO - 1, 1, -1
K = RSCALE( I )
IF( K.EQ.I )
$ GO TO 40
CALL SSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
40 CONTINUE
*
50 CONTINUE
IF( IHI.EQ.N )
$ GO TO 70
DO 60 I = IHI + 1, N
K = RSCALE( I )
IF( K.EQ.I )
$ GO TO 60
CALL SSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
60 CONTINUE
END IF
*
* Backward permutation on left eigenvectors
*
70 CONTINUE
IF( LEFTV ) THEN
IF( ILO.EQ.1 )
$ GO TO 90
DO 80 I = ILO - 1, 1, -1
K = LSCALE( I )
IF( K.EQ.I )
$ GO TO 80
CALL SSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
80 CONTINUE
*
90 CONTINUE
IF( IHI.EQ.N )
$ GO TO 110
DO 100 I = IHI + 1, N
K = LSCALE( I )
IF( K.EQ.I )
$ GO TO 100
CALL SSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
100 CONTINUE
END IF
END IF
*
110 CONTINUE
*
RETURN
*
* End of SGGBAK
*
END
SUBROUTINE SGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE,
$ RSCALE, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOB
INTEGER IHI, ILO, INFO, LDA, LDB, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), LSCALE( * ),
$ RSCALE( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGGBAL balances a pair of general real matrices (A,B). This
* involves, first, permuting A and B by similarity transformations to
* isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N
* elements on the diagonal; and second, applying a diagonal similarity
* transformation to rows and columns ILO to IHI to make the rows
* and columns as close in norm as possible. Both steps are optional.
*
* Balancing may reduce the 1-norm of the matrices, and improve the
* accuracy of the computed eigenvalues and/or eigenvectors in the
* generalized eigenvalue problem A*x = lambda*B*x.
*
* Arguments
* =========
*
* JOB (input) CHARACTER*1
* Specifies the operations to be performed on A and B:
* = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0
* and RSCALE(I) = 1.0 for i = 1,...,N.
* = 'P': permute only;
* = 'S': scale only;
* = 'B': both permute and scale.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the input matrix A.
* On exit, A is overwritten by the balanced matrix.
* If JOB = 'N', A is not referenced.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input/output) REAL array, dimension (LDB,N)
* On entry, the input matrix B.
* On exit, B is overwritten by the balanced matrix.
* If JOB = 'N', B is not referenced.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* ILO (output) INTEGER
* IHI (output) INTEGER
* ILO and IHI are set to integers such that on exit
* A(i,j) = 0 and B(i,j) = 0 if i > j and
* j = 1,...,ILO-1 or i = IHI+1,...,N.
* If JOB = 'N' or 'S', ILO = 1 and IHI = N.
*
* LSCALE (output) REAL array, dimension (N)
* Details of the permutations and scaling factors applied
* to the left side of A and B. If P(j) is the index of the
* row interchanged with row j, and D(j)
* is the scaling factor applied to row j, then
* LSCALE(j) = P(j) for J = 1,...,ILO-1
* = D(j) for J = ILO,...,IHI
* = P(j) for J = IHI+1,...,N.
* The order in which the interchanges are made is N to IHI+1,
* then 1 to ILO-1.
*
* RSCALE (output) REAL array, dimension (N)
* Details of the permutations and scaling factors applied
* to the right side of A and B. If P(j) is the index of the
* column interchanged with column j, and D(j)
* is the scaling factor applied to column j, then
* LSCALE(j) = P(j) for J = 1,...,ILO-1
* = D(j) for J = ILO,...,IHI
* = P(j) for J = IHI+1,...,N.
* The order in which the interchanges are made is N to IHI+1,
* then 1 to ILO-1.
*
* WORK (workspace) REAL array, dimension (lwork)
* lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and
* at least 1 when JOB = 'N' or 'P'.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* See R.C. WARD, Balancing the generalized eigenvalue problem,
* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0E+0, HALF = 0.5E+0, ONE = 1.0E+0 )
REAL THREE, SCLFAC
PARAMETER ( THREE = 3.0E+0, SCLFAC = 1.0E+1 )
* ..
* .. Local Scalars ..
INTEGER I, ICAB, IFLOW, IP1, IR, IRAB, IT, J, JC, JP1,
$ K, KOUNT, L, LCAB, LM1, LRAB, LSFMAX, LSFMIN,
$ M, NR, NRP2
REAL ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2,
$ COEF5, COR, EW, EWC, GAMMA, PGAMMA, RAB, SFMAX,
$ SFMIN, SUM, T, TA, TB, TC
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SDOT, SLAMCH
EXTERNAL LSAME, ISAMAX, SDOT, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SSCAL, SSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG10, MAX, MIN, REAL, SIGN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
$ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGGBAL', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
ILO = 1
IHI = N
RETURN
END IF
*
IF( N.EQ.1 ) THEN
ILO = 1
IHI = N
LSCALE( 1 ) = ONE
RSCALE( 1 ) = ONE
RETURN
END IF
*
IF( LSAME( JOB, 'N' ) ) THEN
ILO = 1
IHI = N
DO 10 I = 1, N
LSCALE( I ) = ONE
RSCALE( I ) = ONE
10 CONTINUE
RETURN
END IF
*
K = 1
L = N
IF( LSAME( JOB, 'S' ) )
$ GO TO 190
*
GO TO 30
*
* Permute the matrices A and B to isolate the eigenvalues.
*
* Find row with one nonzero in columns 1 through L
*
20 CONTINUE
L = LM1
IF( L.NE.1 )
$ GO TO 30
*
RSCALE( 1 ) = ONE
LSCALE( 1 ) = ONE
GO TO 190
*
30 CONTINUE
LM1 = L - 1
DO 80 I = L, 1, -1
DO 40 J = 1, LM1
JP1 = J + 1
IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO )
$ GO TO 50
40 CONTINUE
J = L
GO TO 70
*
50 CONTINUE
DO 60 J = JP1, L
IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO )
$ GO TO 80
60 CONTINUE
J = JP1 - 1
*
70 CONTINUE
M = L
IFLOW = 1
GO TO 160
80 CONTINUE
GO TO 100
*
* Find column with one nonzero in rows K through N
*
90 CONTINUE
K = K + 1
*
100 CONTINUE
DO 150 J = K, L
DO 110 I = K, LM1
IP1 = I + 1
IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO )
$ GO TO 120
110 CONTINUE
I = L
GO TO 140
120 CONTINUE
DO 130 I = IP1, L
IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO )
$ GO TO 150
130 CONTINUE
I = IP1 - 1
140 CONTINUE
M = K
IFLOW = 2
GO TO 160
150 CONTINUE
GO TO 190
*
* Permute rows M and I
*
160 CONTINUE
LSCALE( M ) = I
IF( I.EQ.M )
$ GO TO 170
CALL SSWAP( N-K+1, A( I, K ), LDA, A( M, K ), LDA )
CALL SSWAP( N-K+1, B( I, K ), LDB, B( M, K ), LDB )
*
* Permute columns M and J
*
170 CONTINUE
RSCALE( M ) = J
IF( J.EQ.M )
$ GO TO 180
CALL SSWAP( L, A( 1, J ), 1, A( 1, M ), 1 )
CALL SSWAP( L, B( 1, J ), 1, B( 1, M ), 1 )
*
180 CONTINUE
GO TO ( 20, 90 )IFLOW
*
190 CONTINUE
ILO = K
IHI = L
*
IF( LSAME( JOB, 'P' ) ) THEN
DO 195 I = ILO, IHI
LSCALE( I ) = ONE
RSCALE( I ) = ONE
195 CONTINUE
RETURN
END IF
*
IF( ILO.EQ.IHI )
$ RETURN
*
* Balance the submatrix in rows ILO to IHI.
*
NR = IHI - ILO + 1
DO 200 I = ILO, IHI
RSCALE( I ) = ZERO
LSCALE( I ) = ZERO
*
WORK( I ) = ZERO
WORK( I+N ) = ZERO
WORK( I+2*N ) = ZERO
WORK( I+3*N ) = ZERO
WORK( I+4*N ) = ZERO
WORK( I+5*N ) = ZERO
200 CONTINUE
*
* Compute right side vector in resulting linear equations
*
BASL = LOG10( SCLFAC )
DO 240 I = ILO, IHI
DO 230 J = ILO, IHI
TB = B( I, J )
TA = A( I, J )
IF( TA.EQ.ZERO )
$ GO TO 210
TA = LOG10( ABS( TA ) ) / BASL
210 CONTINUE
IF( TB.EQ.ZERO )
$ GO TO 220
TB = LOG10( ABS( TB ) ) / BASL
220 CONTINUE
WORK( I+4*N ) = WORK( I+4*N ) - TA - TB
WORK( J+5*N ) = WORK( J+5*N ) - TA - TB
230 CONTINUE
240 CONTINUE
*
COEF = ONE / REAL( 2*NR )
COEF2 = COEF*COEF
COEF5 = HALF*COEF2
NRP2 = NR + 2
BETA = ZERO
IT = 1
*
* Start generalized conjugate gradient iteration
*
250 CONTINUE
*
GAMMA = SDOT( NR, WORK( ILO+4*N ), 1, WORK( ILO+4*N ), 1 ) +
$ SDOT( NR, WORK( ILO+5*N ), 1, WORK( ILO+5*N ), 1 )
*
EW = ZERO
EWC = ZERO
DO 260 I = ILO, IHI
EW = EW + WORK( I+4*N )
EWC = EWC + WORK( I+5*N )
260 CONTINUE
*
GAMMA = COEF*GAMMA - COEF2*( EW**2+EWC**2 ) - COEF5*( EW-EWC )**2
IF( GAMMA.EQ.ZERO )
$ GO TO 350
IF( IT.NE.1 )
$ BETA = GAMMA / PGAMMA
T = COEF5*( EWC-THREE*EW )
TC = COEF5*( EW-THREE*EWC )
*
CALL SSCAL( NR, BETA, WORK( ILO ), 1 )
CALL SSCAL( NR, BETA, WORK( ILO+N ), 1 )
*
CALL SAXPY( NR, COEF, WORK( ILO+4*N ), 1, WORK( ILO+N ), 1 )
CALL SAXPY( NR, COEF, WORK( ILO+5*N ), 1, WORK( ILO ), 1 )
*
DO 270 I = ILO, IHI
WORK( I ) = WORK( I ) + TC
WORK( I+N ) = WORK( I+N ) + T
270 CONTINUE
*
* Apply matrix to vector
*
DO 300 I = ILO, IHI
KOUNT = 0
SUM = ZERO
DO 290 J = ILO, IHI
IF( A( I, J ).EQ.ZERO )
$ GO TO 280
KOUNT = KOUNT + 1
SUM = SUM + WORK( J )
280 CONTINUE
IF( B( I, J ).EQ.ZERO )
$ GO TO 290
KOUNT = KOUNT + 1
SUM = SUM + WORK( J )
290 CONTINUE
WORK( I+2*N ) = REAL( KOUNT )*WORK( I+N ) + SUM
300 CONTINUE
*
DO 330 J = ILO, IHI
KOUNT = 0
SUM = ZERO
DO 320 I = ILO, IHI
IF( A( I, J ).EQ.ZERO )
$ GO TO 310
KOUNT = KOUNT + 1
SUM = SUM + WORK( I+N )
310 CONTINUE
IF( B( I, J ).EQ.ZERO )
$ GO TO 320
KOUNT = KOUNT + 1
SUM = SUM + WORK( I+N )
320 CONTINUE
WORK( J+3*N ) = REAL( KOUNT )*WORK( J ) + SUM
330 CONTINUE
*
SUM = SDOT( NR, WORK( ILO+N ), 1, WORK( ILO+2*N ), 1 ) +
$ SDOT( NR, WORK( ILO ), 1, WORK( ILO+3*N ), 1 )
ALPHA = GAMMA / SUM
*
* Determine correction to current iteration
*
CMAX = ZERO
DO 340 I = ILO, IHI
COR = ALPHA*WORK( I+N )
IF( ABS( COR ).GT.CMAX )
$ CMAX = ABS( COR )
LSCALE( I ) = LSCALE( I ) + COR
COR = ALPHA*WORK( I )
IF( ABS( COR ).GT.CMAX )
$ CMAX = ABS( COR )
RSCALE( I ) = RSCALE( I ) + COR
340 CONTINUE
IF( CMAX.LT.HALF )
$ GO TO 350
*
CALL SAXPY( NR, -ALPHA, WORK( ILO+2*N ), 1, WORK( ILO+4*N ), 1 )
CALL SAXPY( NR, -ALPHA, WORK( ILO+3*N ), 1, WORK( ILO+5*N ), 1 )
*
PGAMMA = GAMMA
IT = IT + 1
IF( IT.LE.NRP2 )
$ GO TO 250
*
* End generalized conjugate gradient iteration
*
350 CONTINUE
SFMIN = SLAMCH( 'S' )
SFMAX = ONE / SFMIN
LSFMIN = INT( LOG10( SFMIN ) / BASL+ONE )
LSFMAX = INT( LOG10( SFMAX ) / BASL )
DO 360 I = ILO, IHI
IRAB = ISAMAX( N-ILO+1, A( I, ILO ), LDA )
RAB = ABS( A( I, IRAB+ILO-1 ) )
IRAB = ISAMAX( N-ILO+1, B( I, ILO ), LDB )
RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) )
LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE )
IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) )
IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB )
LSCALE( I ) = SCLFAC**IR
ICAB = ISAMAX( IHI, A( 1, I ), 1 )
CAB = ABS( A( ICAB, I ) )
ICAB = ISAMAX( IHI, B( 1, I ), 1 )
CAB = MAX( CAB, ABS( B( ICAB, I ) ) )
LCAB = INT( LOG10( CAB+SFMIN ) / BASL+ONE )
JC = RSCALE( I ) + SIGN( HALF, RSCALE( I ) )
JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB )
RSCALE( I ) = SCLFAC**JC
360 CONTINUE
*
* Row scaling of matrices A and B
*
DO 370 I = ILO, IHI
CALL SSCAL( N-ILO+1, LSCALE( I ), A( I, ILO ), LDA )
CALL SSCAL( N-ILO+1, LSCALE( I ), B( I, ILO ), LDB )
370 CONTINUE
*
* Column scaling of matrices A and B
*
DO 380 J = ILO, IHI
CALL SSCAL( IHI, RSCALE( J ), A( 1, J ), 1 )
CALL SSCAL( IHI, RSCALE( J ), B( 1, J ), 1 )
380 CONTINUE
*
RETURN
*
* End of SGGBAL
*
END
SUBROUTINE SGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB,
$ SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR,
$ LDVSR, WORK, LWORK, BWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBVSL, JOBVSR, SORT
INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM
* ..
* .. Array Arguments ..
LOGICAL BWORK( * )
REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
$ B( LDB, * ), BETA( * ), VSL( LDVSL, * ),
$ VSR( LDVSR, * ), WORK( * )
* ..
* .. Function Arguments ..
LOGICAL SELCTG
EXTERNAL SELCTG
* ..
*
* Purpose
* =======
*
* SGGES computes for a pair of N-by-N real nonsymmetric matrices (A,B),
* the generalized eigenvalues, the generalized real Schur form (S,T),
* optionally, the left and/or right matrices of Schur vectors (VSL and
* VSR). This gives the generalized Schur factorization
*
* (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T )
*
* Optionally, it also orders the eigenvalues so that a selected cluster
* of eigenvalues appears in the leading diagonal blocks of the upper
* quasi-triangular matrix S and the upper triangular matrix T.The
* leading columns of VSL and VSR then form an orthonormal basis for the
* corresponding left and right eigenspaces (deflating subspaces).
*
* (If only the generalized eigenvalues are needed, use the driver
* SGGEV instead, which is faster.)
*
* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
* or a ratio alpha/beta = w, such that A - w*B is singular. It is
* usually represented as the pair (alpha,beta), as there is a
* reasonable interpretation for beta=0 or both being zero.
*
* A pair of matrices (S,T) is in generalized real Schur form if T is
* upper triangular with non-negative diagonal and S is block upper
* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond
* to real generalized eigenvalues, while 2-by-2 blocks of S will be
* "standardized" by making the corresponding elements of T have the
* form:
* [ a 0 ]
* [ 0 b ]
*
* and the pair of corresponding 2-by-2 blocks in S and T will have a
* complex conjugate pair of generalized eigenvalues.
*
*
* Arguments
* =========
*
* JOBVSL (input) CHARACTER*1
* = 'N': do not compute the left Schur vectors;
* = 'V': compute the left Schur vectors.
*
* JOBVSR (input) CHARACTER*1
* = 'N': do not compute the right Schur vectors;
* = 'V': compute the right Schur vectors.
*
* SORT (input) CHARACTER*1
* Specifies whether or not to order the eigenvalues on the
* diagonal of the generalized Schur form.
* = 'N': Eigenvalues are not ordered;
* = 'S': Eigenvalues are ordered (see SELCTG);
*
* SELCTG (external procedure) LOGICAL FUNCTION of three REAL arguments
* SELCTG must be declared EXTERNAL in the calling subroutine.
* If SORT = 'N', SELCTG is not referenced.
* If SORT = 'S', SELCTG is used to select eigenvalues to sort
* to the top left of the Schur form.
* An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if
* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either
* one of a complex conjugate pair of eigenvalues is selected,
* then both complex eigenvalues are selected.
*
* Note that in the ill-conditioned case, a selected complex
* eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j),
* BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2
* in this case.
*
* N (input) INTEGER
* The order of the matrices A, B, VSL, and VSR. N >= 0.
*
* A (input/output) REAL array, dimension (LDA, N)
* On entry, the first of the pair of matrices.
* On exit, A has been overwritten by its generalized Schur
* form S.
*
* LDA (input) INTEGER
* The leading dimension of A. LDA >= max(1,N).
*
* B (input/output) REAL array, dimension (LDB, N)
* On entry, the second of the pair of matrices.
* On exit, B has been overwritten by its generalized Schur
* form T.
*
* LDB (input) INTEGER
* The leading dimension of B. LDB >= max(1,N).
*
* SDIM (output) INTEGER
* If SORT = 'N', SDIM = 0.
* If SORT = 'S', SDIM = number of eigenvalues (after sorting)
* for which SELCTG is true. (Complex conjugate pairs for which
* SELCTG is true for either eigenvalue count as 2.)
*
* ALPHAR (output) REAL array, dimension (N)
* ALPHAI (output) REAL array, dimension (N)
* BETA (output) REAL array, dimension (N)
* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i,
* and BETA(j),j=1,...,N are the diagonals of the complex Schur
* form (S,T) that would result if the 2-by-2 diagonal blocks of
* the real Schur form of (A,B) were further reduced to
* triangular form using 2-by-2 complex unitary transformations.
* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
* positive, then the j-th and (j+1)-st eigenvalues are a
* complex conjugate pair, with ALPHAI(j+1) negative.
*
* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
* may easily over- or underflow, and BETA(j) may even be zero.
* Thus, the user should avoid naively computing the ratio.
* However, ALPHAR and ALPHAI will be always less than and
* usually comparable with norm(A) in magnitude, and BETA always
* less than and usually comparable with norm(B).
*
* VSL (output) REAL array, dimension (LDVSL,N)
* If JOBVSL = 'V', VSL will contain the left Schur vectors.
* Not referenced if JOBVSL = 'N'.
*
* LDVSL (input) INTEGER
* The leading dimension of the matrix VSL. LDVSL >=1, and
* if JOBVSL = 'V', LDVSL >= N.
*
* VSR (output) REAL array, dimension (LDVSR,N)
* If JOBVSR = 'V', VSR will contain the right Schur vectors.
* Not referenced if JOBVSR = 'N'.
*
* LDVSR (input) INTEGER
* The leading dimension of the matrix VSR. LDVSR >= 1, and
* if JOBVSR = 'V', LDVSR >= N.
*
* WORK (workspace/output) REAL 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 N = 0, LWORK >= 1, else LWORK >= max(8*N,6*N+16).
* For good performance , LWORK must generally be larger.
*
* 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.
*
* BWORK (workspace) LOGICAL array, dimension (N)
* Not referenced if SORT = 'N'.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* = 1,...,N:
* The QZ iteration failed. (A,B) are not in Schur
* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should
* be correct for j=INFO+1,...,N.
* > N: =N+1: other than QZ iteration failed in SHGEQZ.
* =N+2: after reordering, roundoff changed values of
* some complex eigenvalues so that leading
* eigenvalues in the Generalized Schur form no
* longer satisfy SELCTG=.TRUE. This could also
* be caused due to scaling.
* =N+3: reordering failed in STGSEN.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL,
$ LQUERY, LST2SL, WANTST
INTEGER I, ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT,
$ ILO, IP, IRIGHT, IROWS, ITAU, IWRK, MAXWRK,
$ MINWRK
REAL ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PVSL,
$ PVSR, SAFMAX, SAFMIN, SMLNUM
* ..
* .. Local Arrays ..
INTEGER IDUM( 1 )
REAL DIF( 2 )
* ..
* .. External Subroutines ..
EXTERNAL SGEQRF, SGGBAK, SGGBAL, SGGHRD, SHGEQZ, SLABAD,
$ SLACPY, SLASCL, SLASET, SORGQR, SORMQR, STGSEN,
$ XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
REAL SLAMCH, SLANGE
EXTERNAL LSAME, ILAENV, SLAMCH, SLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Decode the input arguments
*
IF( LSAME( JOBVSL, 'N' ) ) THEN
IJOBVL = 1
ILVSL = .FALSE.
ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN
IJOBVL = 2
ILVSL = .TRUE.
ELSE
IJOBVL = -1
ILVSL = .FALSE.
END IF
*
IF( LSAME( JOBVSR, 'N' ) ) THEN
IJOBVR = 1
ILVSR = .FALSE.
ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN
IJOBVR = 2
ILVSR = .TRUE.
ELSE
IJOBVR = -1
ILVSR = .FALSE.
END IF
*
WANTST = LSAME( SORT, 'S' )
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
IF( IJOBVL.LE.0 ) THEN
INFO = -1
ELSE IF( IJOBVR.LE.0 ) THEN
INFO = -2
ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN
INFO = -15
ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN
INFO = -17
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.)
*
IF( INFO.EQ.0 ) THEN
IF( N.GT.0 )THEN
MINWRK = MAX( 8*N, 6*N + 16 )
MAXWRK = MINWRK - N +
$ N*ILAENV( 1, 'SGEQRF', ' ', N, 1, N, 0 )
MAXWRK = MAX( MAXWRK, MINWRK - N +
$ N*ILAENV( 1, 'SORMQR', ' ', N, 1, N, -1 ) )
IF( ILVSL ) THEN
MAXWRK = MAX( MAXWRK, MINWRK - N +
$ N*ILAENV( 1, 'SORGQR', ' ', N, 1, N, -1 ) )
END IF
ELSE
MINWRK = 1
MAXWRK = 1
END IF
WORK( 1 ) = MAXWRK
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY )
$ INFO = -19
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGGES ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
SDIM = 0
RETURN
END IF
*
* Get machine constants
*
EPS = SLAMCH( 'P' )
SAFMIN = SLAMCH( 'S' )
SAFMAX = ONE / SAFMIN
CALL SLABAD( SAFMIN, SAFMAX )
SMLNUM = SQRT( SAFMIN ) / EPS
BIGNUM = ONE / SMLNUM
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = SLANGE( 'M', N, N, A, LDA, WORK )
ILASCL = .FALSE.
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
ANRMTO = SMLNUM
ILASCL = .TRUE.
ELSE IF( ANRM.GT.BIGNUM ) THEN
ANRMTO = BIGNUM
ILASCL = .TRUE.
END IF
IF( ILASCL )
$ CALL SLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
*
* Scale B if max element outside range [SMLNUM,BIGNUM]
*
BNRM = SLANGE( 'M', N, N, B, LDB, WORK )
ILBSCL = .FALSE.
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
BNRMTO = SMLNUM
ILBSCL = .TRUE.
ELSE IF( BNRM.GT.BIGNUM ) THEN
BNRMTO = BIGNUM
ILBSCL = .TRUE.
END IF
IF( ILBSCL )
$ CALL SLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
*
* Permute the matrix to make it more nearly triangular
* (Workspace: need 6*N + 2*N space for storing balancing factors)
*
ILEFT = 1
IRIGHT = N + 1
IWRK = IRIGHT + N
CALL SGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ),
$ WORK( IRIGHT ), WORK( IWRK ), IERR )
*
* Reduce B to triangular form (QR decomposition of B)
* (Workspace: need N, prefer N*NB)
*
IROWS = IHI + 1 - ILO
ICOLS = N + 1 - ILO
ITAU = IWRK
IWRK = ITAU + IROWS
CALL SGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
$ WORK( IWRK ), LWORK+1-IWRK, IERR )
*
* Apply the orthogonal transformation to matrix A
* (Workspace: need N, prefer N*NB)
*
CALL SORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
$ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
$ LWORK+1-IWRK, IERR )
*
* Initialize VSL
* (Workspace: need N, prefer N*NB)
*
IF( ILVSL ) THEN
CALL SLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL )
IF( IROWS.GT.1 ) THEN
CALL SLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
$ VSL( ILO+1, ILO ), LDVSL )
END IF
CALL SORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL,
$ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
END IF
*
* Initialize VSR
*
IF( ILVSR )
$ CALL SLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR )
*
* Reduce to generalized Hessenberg form
* (Workspace: none needed)
*
CALL SGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL,
$ LDVSL, VSR, LDVSR, IERR )
*
* Perform QZ algorithm, computing Schur vectors if desired
* (Workspace: need N)
*
IWRK = ITAU
CALL SHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB,
$ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR,
$ WORK( IWRK ), LWORK+1-IWRK, IERR )
IF( IERR.NE.0 ) THEN
IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
INFO = IERR
ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
INFO = IERR - N
ELSE
INFO = N + 1
END IF
GO TO 40
END IF
*
* Sort eigenvalues ALPHA/BETA if desired
* (Workspace: need 4*N+16 )
*
SDIM = 0
IF( WANTST ) THEN
*
* Undo scaling on eigenvalues before SELCTGing
*
IF( ILASCL ) THEN
CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N,
$ IERR )
CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N,
$ IERR )
END IF
IF( ILBSCL )
$ CALL SLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
*
* Select eigenvalues
*
DO 10 I = 1, N
BWORK( I ) = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) )
10 CONTINUE
*
CALL STGSEN( 0, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, ALPHAR,
$ ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, SDIM, PVSL,
$ PVSR, DIF, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1,
$ IERR )
IF( IERR.EQ.1 )
$ INFO = N + 3
*
END IF
*
* Apply back-permutation to VSL and VSR
* (Workspace: none needed)
*
IF( ILVSL )
$ CALL SGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
$ WORK( IRIGHT ), N, VSL, LDVSL, IERR )
*
IF( ILVSR )
$ CALL SGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ),
$ WORK( IRIGHT ), N, VSR, LDVSR, IERR )
*
* Check if unscaling would cause over/underflow, if so, rescale
* (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of
* B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I)
*
IF( ILASCL )THEN
DO 50 I = 1, N
IF( ALPHAI( I ).NE.ZERO ) THEN
IF( ( ALPHAR( I )/SAFMAX ).GT.( ANRMTO/ANRM ) .OR.
$ ( SAFMIN/ALPHAR( I ) ).GT.( ANRM/ANRMTO ) ) THEN
WORK( 1 ) = ABS( A( I, I )/ALPHAR( I ) )
BETA( I ) = BETA( I )*WORK( 1 )
ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
ELSE IF( ( ALPHAI( I )/SAFMAX ).GT.( ANRMTO/ANRM ) .OR.
$ ( SAFMIN/ALPHAI( I ) ).GT.( ANRM/ANRMTO ) ) THEN
WORK( 1 ) = ABS( A( I, I+1 )/ALPHAI( I ) )
BETA( I ) = BETA( I )*WORK( 1 )
ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
END IF
END IF
50 CONTINUE
END IF
*
IF( ILBSCL )THEN
DO 60 I = 1, N
IF( ALPHAI( I ).NE.ZERO ) THEN
IF( ( BETA( I )/SAFMAX ).GT.( BNRMTO/BNRM ) .OR.
$ ( SAFMIN/BETA( I ) ).GT.( BNRM/BNRMTO ) ) THEN
WORK( 1 ) = ABS(B( I, I )/BETA( I ))
BETA( I ) = BETA( I )*WORK( 1 )
ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
END IF
END IF
60 CONTINUE
END IF
*
* Undo scaling
*
IF( ILASCL ) THEN
CALL SLASCL( 'H', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR )
CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
END IF
*
IF( ILBSCL ) THEN
CALL SLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR )
CALL SLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
END IF
*
IF( WANTST ) THEN
*
* Check if reordering is correct
*
LASTSL = .TRUE.
LST2SL = .TRUE.
SDIM = 0
IP = 0
DO 30 I = 1, N
CURSL = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) )
IF( ALPHAI( I ).EQ.ZERO ) THEN
IF( CURSL )
$ SDIM = SDIM + 1
IP = 0
IF( CURSL .AND. .NOT.LASTSL )
$ INFO = N + 2
ELSE
IF( IP.EQ.1 ) THEN
*
* Last eigenvalue of conjugate pair
*
CURSL = CURSL .OR. LASTSL
LASTSL = CURSL
IF( CURSL )
$ SDIM = SDIM + 2
IP = -1
IF( CURSL .AND. .NOT.LST2SL )
$ INFO = N + 2
ELSE
*
* First eigenvalue of conjugate pair
*
IP = 1
END IF
END IF
LST2SL = LASTSL
LASTSL = CURSL
30 CONTINUE
*
END IF
*
40 CONTINUE
*
WORK( 1 ) = MAXWRK
*
RETURN
*
* End of SGGES
*
END
SUBROUTINE SGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA,
$ B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL,
$ VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, IWORK,
$ LIWORK, BWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBVSL, JOBVSR, SENSE, SORT
INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LIWORK, LWORK, N,
$ SDIM
* ..
* .. Array Arguments ..
LOGICAL BWORK( * )
INTEGER IWORK( * )
REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
$ B( LDB, * ), BETA( * ), RCONDE( 2 ),
$ RCONDV( 2 ), VSL( LDVSL, * ), VSR( LDVSR, * ),
$ WORK( * )
* ..
* .. Function Arguments ..
LOGICAL SELCTG
EXTERNAL SELCTG
* ..
*
* Purpose
* =======
*
* SGGESX computes for a pair of N-by-N real nonsymmetric matrices
* (A,B), the generalized eigenvalues, the real Schur form (S,T), and,
* optionally, the left and/or right matrices of Schur vectors (VSL and
* VSR). This gives the generalized Schur factorization
*
* (A,B) = ( (VSL) S (VSR)**T, (VSL) T (VSR)**T )
*
* Optionally, it also orders the eigenvalues so that a selected cluster
* of eigenvalues appears in the leading diagonal blocks of the upper
* quasi-triangular matrix S and the upper triangular matrix T; computes
* a reciprocal condition number for the average of the selected
* eigenvalues (RCONDE); and computes a reciprocal condition number for
* the right and left deflating subspaces corresponding to the selected
* eigenvalues (RCONDV). The leading columns of VSL and VSR then form
* an orthonormal basis for the corresponding left and right eigenspaces
* (deflating subspaces).
*
* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
* or a ratio alpha/beta = w, such that A - w*B is singular. It is
* usually represented as the pair (alpha,beta), as there is a
* reasonable interpretation for beta=0 or for both being zero.
*
* A pair of matrices (S,T) is in generalized real Schur form if T is
* upper triangular with non-negative diagonal and S is block upper
* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond
* to real generalized eigenvalues, while 2-by-2 blocks of S will be
* "standardized" by making the corresponding elements of T have the
* form:
* [ a 0 ]
* [ 0 b ]
*
* and the pair of corresponding 2-by-2 blocks in S and T will have a
* complex conjugate pair of generalized eigenvalues.
*
*
* Arguments
* =========
*
* JOBVSL (input) CHARACTER*1
* = 'N': do not compute the left Schur vectors;
* = 'V': compute the left Schur vectors.
*
* JOBVSR (input) CHARACTER*1
* = 'N': do not compute the right Schur vectors;
* = 'V': compute the right Schur vectors.
*
* SORT (input) CHARACTER*1
* Specifies whether or not to order the eigenvalues on the
* diagonal of the generalized Schur form.
* = 'N': Eigenvalues are not ordered;
* = 'S': Eigenvalues are ordered (see SELCTG).
*
* SELCTG (external procedure) LOGICAL FUNCTION of three REAL arguments
* SELCTG must be declared EXTERNAL in the calling subroutine.
* If SORT = 'N', SELCTG is not referenced.
* If SORT = 'S', SELCTG is used to select eigenvalues to sort
* to the top left of the Schur form.
* An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if
* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either
* one of a complex conjugate pair of eigenvalues is selected,
* then both complex eigenvalues are selected.
* Note that a selected complex eigenvalue may no longer satisfy
* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) = .TRUE. after ordering,
* since ordering may change the value of complex eigenvalues
* (especially if the eigenvalue is ill-conditioned), in this
* case INFO is set to N+3.
*
* SENSE (input) CHARACTER*1
* Determines which reciprocal condition numbers are computed.
* = 'N' : None are computed;
* = 'E' : Computed for average of selected eigenvalues only;
* = 'V' : Computed for selected deflating subspaces only;
* = 'B' : Computed for both.
* If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.
*
* N (input) INTEGER
* The order of the matrices A, B, VSL, and VSR. N >= 0.
*
* A (input/output) REAL array, dimension (LDA, N)
* On entry, the first of the pair of matrices.
* On exit, A has been overwritten by its generalized Schur
* form S.
*
* LDA (input) INTEGER
* The leading dimension of A. LDA >= max(1,N).
*
* B (input/output) REAL array, dimension (LDB, N)
* On entry, the second of the pair of matrices.
* On exit, B has been overwritten by its generalized Schur
* form T.
*
* LDB (input) INTEGER
* The leading dimension of B. LDB >= max(1,N).
*
* SDIM (output) INTEGER
* If SORT = 'N', SDIM = 0.
* If SORT = 'S', SDIM = number of eigenvalues (after sorting)
* for which SELCTG is true. (Complex conjugate pairs for which
* SELCTG is true for either eigenvalue count as 2.)
*
* ALPHAR (output) REAL array, dimension (N)
* ALPHAI (output) REAL array, dimension (N)
* BETA (output) REAL array, dimension (N)
* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i
* and BETA(j),j=1,...,N are the diagonals of the complex Schur
* form (S,T) that would result if the 2-by-2 diagonal blocks of
* the real Schur form of (A,B) were further reduced to
* triangular form using 2-by-2 complex unitary transformations.
* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
* positive, then the j-th and (j+1)-st eigenvalues are a
* complex conjugate pair, with ALPHAI(j+1) negative.
*
* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
* may easily over- or underflow, and BETA(j) may even be zero.
* Thus, the user should avoid naively computing the ratio.
* However, ALPHAR and ALPHAI will be always less than and
* usually comparable with norm(A) in magnitude, and BETA always
* less than and usually comparable with norm(B).
*
* VSL (output) REAL array, dimension (LDVSL,N)
* If JOBVSL = 'V', VSL will contain the left Schur vectors.
* Not referenced if JOBVSL = 'N'.
*
* LDVSL (input) INTEGER
* The leading dimension of the matrix VSL. LDVSL >=1, and
* if JOBVSL = 'V', LDVSL >= N.
*
* VSR (output) REAL array, dimension (LDVSR,N)
* If JOBVSR = 'V', VSR will contain the right Schur vectors.
* Not referenced if JOBVSR = 'N'.
*
* LDVSR (input) INTEGER
* The leading dimension of the matrix VSR. LDVSR >= 1, and
* if JOBVSR = 'V', LDVSR >= N.
*
* RCONDE (output) REAL array, dimension ( 2 )
* If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the
* reciprocal condition numbers for the average of the selected
* eigenvalues.
* Not referenced if SENSE = 'N' or 'V'.
*
* RCONDV (output) REAL array, dimension ( 2 )
* If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the
* reciprocal condition numbers for the selected deflating
* subspaces.
* Not referenced if SENSE = 'N' or 'E'.
*
* WORK (workspace/output) REAL 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 N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B',
* LWORK >= max( 8*N, 6*N+16, 2*SDIM*(N-SDIM) ), else
* LWORK >= max( 8*N, 6*N+16 ).
* Note that 2*SDIM*(N-SDIM) <= N*N/2.
* Note also that an error is only returned if
* LWORK < max( 8*N, 6*N+16), but if SENSE = 'E' or 'V' or 'B'
* this may not be large enough.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the bound on the optimal size of the WORK
* array and the minimum size of the IWORK array, returns these
* values as the first entries of the WORK and IWORK arrays, and
* no error message related to LWORK or LIWORK is issued by
* XERBLA.
*
* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK.
* If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise
* LIWORK >= N+6.
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the bound on the optimal size of the
* WORK array and the minimum size of the IWORK array, returns
* these values as the first entries of the WORK and IWORK
* arrays, and no error message related to LWORK or LIWORK is
* issued by XERBLA.
*
* BWORK (workspace) LOGICAL array, dimension (N)
* Not referenced if SORT = 'N'.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* = 1,...,N:
* The QZ iteration failed. (A,B) are not in Schur
* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should
* be correct for j=INFO+1,...,N.
* > N: =N+1: other than QZ iteration failed in SHGEQZ
* =N+2: after reordering, roundoff changed values of
* some complex eigenvalues so that leading
* eigenvalues in the Generalized Schur form no
* longer satisfy SELCTG=.TRUE. This could also
* be caused due to scaling.
* =N+3: reordering failed in STGSEN.
*
* Further details
* ===============
*
* An approximate (asymptotic) bound on the average absolute error of
* the selected eigenvalues is
*
* EPS * norm((A, B)) / RCONDE( 1 ).
*
* An approximate (asymptotic) bound on the maximum angular error in
* the computed deflating subspaces is
*
* EPS * norm((A, B)) / RCONDV( 2 ).
*
* See LAPACK User's Guide, section 4.11 for more information.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL,
$ LQUERY, LST2SL, WANTSB, WANTSE, WANTSN, WANTST,
$ WANTSV
INTEGER I, ICOLS, IERR, IHI, IJOB, IJOBVL, IJOBVR,
$ ILEFT, ILO, IP, IRIGHT, IROWS, ITAU, IWRK,
$ LIWMIN, LWRK, MAXWRK, MINWRK
REAL ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PL,
$ PR, SAFMAX, SAFMIN, SMLNUM
* ..
* .. Local Arrays ..
REAL DIF( 2 )
* ..
* .. External Subroutines ..
EXTERNAL SGEQRF, SGGBAK, SGGBAL, SGGHRD, SHGEQZ, SLABAD,
$ SLACPY, SLASCL, SLASET, SORGQR, SORMQR, STGSEN,
$ XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
REAL SLAMCH, SLANGE
EXTERNAL LSAME, ILAENV, SLAMCH, SLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Decode the input arguments
*
IF( LSAME( JOBVSL, 'N' ) ) THEN
IJOBVL = 1
ILVSL = .FALSE.
ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN
IJOBVL = 2
ILVSL = .TRUE.
ELSE
IJOBVL = -1
ILVSL = .FALSE.
END IF
*
IF( LSAME( JOBVSR, 'N' ) ) THEN
IJOBVR = 1
ILVSR = .FALSE.
ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN
IJOBVR = 2
ILVSR = .TRUE.
ELSE
IJOBVR = -1
ILVSR = .FALSE.
END IF
*
WANTST = LSAME( SORT, 'S' )
WANTSN = LSAME( SENSE, 'N' )
WANTSE = LSAME( SENSE, 'E' )
WANTSV = LSAME( SENSE, 'V' )
WANTSB = LSAME( SENSE, 'B' )
LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
IF( WANTSN ) THEN
IJOB = 0
ELSE IF( WANTSE ) THEN
IJOB = 1
ELSE IF( WANTSV ) THEN
IJOB = 2
ELSE IF( WANTSB ) THEN
IJOB = 4
END IF
*
* Test the input arguments
*
INFO = 0
IF( IJOBVL.LE.0 ) THEN
INFO = -1
ELSE IF( IJOBVR.LE.0 ) THEN
INFO = -2
ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
INFO = -3
ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSV .OR. WANTSB ) .OR.
$ ( .NOT.WANTST .AND. .NOT.WANTSN ) ) THEN
INFO = -5
ELSE IF( N.LT.0 ) THEN
INFO = -6
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -10
ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN
INFO = -16
ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN
INFO = -18
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.)
*
IF( INFO.EQ.0 ) THEN
IF( N.GT.0) THEN
MINWRK = MAX( 8*N, 6*N + 16 )
MAXWRK = MINWRK - N +
$ N*ILAENV( 1, 'SGEQRF', ' ', N, 1, N, 0 )
MAXWRK = MAX( MAXWRK, MINWRK - N +
$ N*ILAENV( 1, 'SORMQR', ' ', N, 1, N, -1 ) )
IF( ILVSL ) THEN
MAXWRK = MAX( MAXWRK, MINWRK - N +
$ N*ILAENV( 1, 'SORGQR', ' ', N, 1, N, -1 ) )
END IF
LWRK = MAXWRK
IF( IJOB.GE.1 )
$ LWRK = MAX( LWRK, N*N/2 )
ELSE
MINWRK = 1
MAXWRK = 1
LWRK = 1
END IF
WORK( 1 ) = LWRK
IF( WANTSN .OR. N.EQ.0 ) THEN
LIWMIN = 1
ELSE
LIWMIN = N + 6
END IF
IWORK( 1 ) = LIWMIN
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
INFO = -22
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -24
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGGESX', -INFO )
RETURN
ELSE IF (LQUERY) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
SDIM = 0
RETURN
END IF
*
* Get machine constants
*
EPS = SLAMCH( 'P' )
SAFMIN = SLAMCH( 'S' )
SAFMAX = ONE / SAFMIN
CALL SLABAD( SAFMIN, SAFMAX )
SMLNUM = SQRT( SAFMIN ) / EPS
BIGNUM = ONE / SMLNUM
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = SLANGE( 'M', N, N, A, LDA, WORK )
ILASCL = .FALSE.
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
ANRMTO = SMLNUM
ILASCL = .TRUE.
ELSE IF( ANRM.GT.BIGNUM ) THEN
ANRMTO = BIGNUM
ILASCL = .TRUE.
END IF
IF( ILASCL )
$ CALL SLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
*
* Scale B if max element outside range [SMLNUM,BIGNUM]
*
BNRM = SLANGE( 'M', N, N, B, LDB, WORK )
ILBSCL = .FALSE.
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
BNRMTO = SMLNUM
ILBSCL = .TRUE.
ELSE IF( BNRM.GT.BIGNUM ) THEN
BNRMTO = BIGNUM
ILBSCL = .TRUE.
END IF
IF( ILBSCL )
$ CALL SLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
*
* Permute the matrix to make it more nearly triangular
* (Workspace: need 6*N + 2*N for permutation parameters)
*
ILEFT = 1
IRIGHT = N + 1
IWRK = IRIGHT + N
CALL SGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ),
$ WORK( IRIGHT ), WORK( IWRK ), IERR )
*
* Reduce B to triangular form (QR decomposition of B)
* (Workspace: need N, prefer N*NB)
*
IROWS = IHI + 1 - ILO
ICOLS = N + 1 - ILO
ITAU = IWRK
IWRK = ITAU + IROWS
CALL SGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
$ WORK( IWRK ), LWORK+1-IWRK, IERR )
*
* Apply the orthogonal transformation to matrix A
* (Workspace: need N, prefer N*NB)
*
CALL SORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
$ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
$ LWORK+1-IWRK, IERR )
*
* Initialize VSL
* (Workspace: need N, prefer N*NB)
*
IF( ILVSL ) THEN
CALL SLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL )
IF( IROWS.GT.1 ) THEN
CALL SLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
$ VSL( ILO+1, ILO ), LDVSL )
END IF
CALL SORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL,
$ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
END IF
*
* Initialize VSR
*
IF( ILVSR )
$ CALL SLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR )
*
* Reduce to generalized Hessenberg form
* (Workspace: none needed)
*
CALL SGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL,
$ LDVSL, VSR, LDVSR, IERR )
*
SDIM = 0
*
* Perform QZ algorithm, computing Schur vectors if desired
* (Workspace: need N)
*
IWRK = ITAU
CALL SHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB,
$ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR,
$ WORK( IWRK ), LWORK+1-IWRK, IERR )
IF( IERR.NE.0 ) THEN
IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
INFO = IERR
ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
INFO = IERR - N
ELSE
INFO = N + 1
END IF
GO TO 50
END IF
*
* Sort eigenvalues ALPHA/BETA and compute the reciprocal of
* condition number(s)
* (Workspace: If IJOB >= 1, need MAX( 8*(N+1), 2*SDIM*(N-SDIM) )
* otherwise, need 8*(N+1) )
*
IF( WANTST ) THEN
*
* Undo scaling on eigenvalues before SELCTGing
*
IF( ILASCL ) THEN
CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N,
$ IERR )
CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N,
$ IERR )
END IF
IF( ILBSCL )
$ CALL SLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
*
* Select eigenvalues
*
DO 10 I = 1, N
BWORK( I ) = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) )
10 CONTINUE
*
* Reorder eigenvalues, transform Generalized Schur vectors, and
* compute reciprocal condition numbers
*
CALL STGSEN( IJOB, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB,
$ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR,
$ SDIM, PL, PR, DIF, WORK( IWRK ), LWORK-IWRK+1,
$ IWORK, LIWORK, IERR )
*
IF( IJOB.GE.1 )
$ MAXWRK = MAX( MAXWRK, 2*SDIM*( N-SDIM ) )
IF( IERR.EQ.-22 ) THEN
*
* not enough real workspace
*
INFO = -22
ELSE
IF( IJOB.EQ.1 .OR. IJOB.EQ.4 ) THEN
RCONDE( 1 ) = PL
RCONDE( 2 ) = PR
END IF
IF( IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN
RCONDV( 1 ) = DIF( 1 )
RCONDV( 2 ) = DIF( 2 )
END IF
IF( IERR.EQ.1 )
$ INFO = N + 3
END IF
*
END IF
*
* Apply permutation to VSL and VSR
* (Workspace: none needed)
*
IF( ILVSL )
$ CALL SGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
$ WORK( IRIGHT ), N, VSL, LDVSL, IERR )
*
IF( ILVSR )
$ CALL SGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ),
$ WORK( IRIGHT ), N, VSR, LDVSR, IERR )
*
* Check if unscaling would cause over/underflow, if so, rescale
* (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of
* B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I)
*
IF( ILASCL ) THEN
DO 20 I = 1, N
IF( ALPHAI( I ).NE.ZERO ) THEN
IF( ( ALPHAR( I ) / SAFMAX ).GT.( ANRMTO / ANRM ) .OR.
$ ( SAFMIN / ALPHAR( I ) ).GT.( ANRM / ANRMTO ) )
$ THEN
WORK( 1 ) = ABS( A( I, I ) / ALPHAR( I ) )
BETA( I ) = BETA( I )*WORK( 1 )
ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
ELSE IF( ( ALPHAI( I ) / SAFMAX ).GT.( ANRMTO / ANRM )
$ .OR. ( SAFMIN / ALPHAI( I ) ).GT.( ANRM / ANRMTO ) )
$ THEN
WORK( 1 ) = ABS( A( I, I+1 ) / ALPHAI( I ) )
BETA( I ) = BETA( I )*WORK( 1 )
ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
END IF
END IF
20 CONTINUE
END IF
*
IF( ILBSCL ) THEN
DO 25 I = 1, N
IF( ALPHAI( I ).NE.ZERO ) THEN
IF( ( BETA( I ) / SAFMAX ).GT.( BNRMTO / BNRM ) .OR.
$ ( SAFMIN / BETA( I ) ).GT.( BNRM / BNRMTO ) ) THEN
WORK( 1 ) = ABS( B( I, I ) / BETA( I ) )
BETA( I ) = BETA( I )*WORK( 1 )
ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
END IF
END IF
25 CONTINUE
END IF
*
* Undo scaling
*
IF( ILASCL ) THEN
CALL SLASCL( 'H', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR )
CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
END IF
*
IF( ILBSCL ) THEN
CALL SLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR )
CALL SLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
END IF
*
IF( WANTST ) THEN
*
* Check if reordering is correct
*
LASTSL = .TRUE.
LST2SL = .TRUE.
SDIM = 0
IP = 0
DO 40 I = 1, N
CURSL = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) )
IF( ALPHAI( I ).EQ.ZERO ) THEN
IF( CURSL )
$ SDIM = SDIM + 1
IP = 0
IF( CURSL .AND. .NOT.LASTSL )
$ INFO = N + 2
ELSE
IF( IP.EQ.1 ) THEN
*
* Last eigenvalue of conjugate pair
*
CURSL = CURSL .OR. LASTSL
LASTSL = CURSL
IF( CURSL )
$ SDIM = SDIM + 2
IP = -1
IF( CURSL .AND. .NOT.LST2SL )
$ INFO = N + 2
ELSE
*
* First eigenvalue of conjugate pair
*
IP = 1
END IF
END IF
LST2SL = LASTSL
LASTSL = CURSL
40 CONTINUE
*
END IF
*
50 CONTINUE
*
WORK( 1 ) = MAXWRK
IWORK( 1 ) = LIWMIN
*
RETURN
*
* End of SGGESX
*
END
SUBROUTINE SGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI,
$ BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBVL, JOBVR
INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
$ B( LDB, * ), BETA( * ), VL( LDVL, * ),
$ VR( LDVR, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B)
* the generalized eigenvalues, and optionally, the left and/or right
* generalized eigenvectors.
*
* A generalized eigenvalue for a pair of matrices (A,B) is a scalar
* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
* singular. It is usually represented as the pair (alpha,beta), as
* there is a reasonable interpretation for beta=0, and even for both
* being zero.
*
* The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
* of (A,B) satisfies
*
* A * v(j) = lambda(j) * B * v(j).
*
* The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
* of (A,B) satisfies
*
* u(j)**H * A = lambda(j) * u(j)**H * B .
*
* where u(j)**H is the conjugate-transpose of u(j).
*
*
* Arguments
* =========
*
* JOBVL (input) CHARACTER*1
* = 'N': do not compute the left generalized eigenvectors;
* = 'V': compute the left generalized eigenvectors.
*
* JOBVR (input) CHARACTER*1
* = 'N': do not compute the right generalized eigenvectors;
* = 'V': compute the right generalized eigenvectors.
*
* N (input) INTEGER
* The order of the matrices A, B, VL, and VR. N >= 0.
*
* A (input/output) REAL array, dimension (LDA, N)
* On entry, the matrix A in the pair (A,B).
* On exit, A has been overwritten.
*
* LDA (input) INTEGER
* The leading dimension of A. LDA >= max(1,N).
*
* B (input/output) REAL array, dimension (LDB, N)
* On entry, the matrix B in the pair (A,B).
* On exit, B has been overwritten.
*
* LDB (input) INTEGER
* The leading dimension of B. LDB >= max(1,N).
*
* ALPHAR (output) REAL array, dimension (N)
* ALPHAI (output) REAL array, dimension (N)
* BETA (output) REAL array, dimension (N)
* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
* be the generalized eigenvalues. If ALPHAI(j) is zero, then
* the j-th eigenvalue is real; if positive, then the j-th and
* (j+1)-st eigenvalues are a complex conjugate pair, with
* ALPHAI(j+1) negative.
*
* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
* may easily over- or underflow, and BETA(j) may even be zero.
* Thus, the user should avoid naively computing the ratio
* alpha/beta. However, ALPHAR and ALPHAI will be always less
* than and usually comparable with norm(A) in magnitude, and
* BETA always less than and usually comparable with norm(B).
*
* VL (output) REAL array, dimension (LDVL,N)
* If JOBVL = 'V', the left eigenvectors u(j) are stored one
* after another in the columns of VL, in the same order as
* their eigenvalues. If the j-th eigenvalue is real, then
* u(j) = VL(:,j), the j-th column of VL. If the j-th and
* (j+1)-th eigenvalues form a complex conjugate pair, then
* u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).
* Each eigenvector is scaled so the largest component has
* abs(real part)+abs(imag. part)=1.
* Not referenced if JOBVL = 'N'.
*
* LDVL (input) INTEGER
* The leading dimension of the matrix VL. LDVL >= 1, and
* if JOBVL = 'V', LDVL >= N.
*
* VR (output) REAL array, dimension (LDVR,N)
* If JOBVR = 'V', the right eigenvectors v(j) are stored one
* after another in the columns of VR, in the same order as
* their eigenvalues. If the j-th eigenvalue is real, then
* v(j) = VR(:,j), the j-th column of VR. If the j-th and
* (j+1)-th eigenvalues form a complex conjugate pair, then
* v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).
* Each eigenvector is scaled so the largest component has
* abs(real part)+abs(imag. part)=1.
* Not referenced if JOBVR = 'N'.
*
* LDVR (input) INTEGER
* The leading dimension of the matrix VR. LDVR >= 1, and
* if JOBVR = 'V', LDVR >= N.
*
* WORK (workspace/output) REAL 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,8*N).
* For good performance, LWORK must generally be larger.
*
* 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.
* = 1,...,N:
* The QZ iteration failed. No eigenvectors have been
* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
* should be correct for j=INFO+1,...,N.
* > N: =N+1: other than QZ iteration failed in SHGEQZ.
* =N+2: error return from STGEVC.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY
CHARACTER CHTEMP
INTEGER ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, ILO,
$ IN, IRIGHT, IROWS, ITAU, IWRK, JC, JR, MAXWRK,
$ MINWRK
REAL ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
$ SMLNUM, TEMP
* ..
* .. Local Arrays ..
LOGICAL LDUMMA( 1 )
* ..
* .. External Subroutines ..
EXTERNAL SGEQRF, SGGBAK, SGGBAL, SGGHRD, SHGEQZ, SLABAD,
$ SLACPY, SLASCL, SLASET, SORGQR, SORMQR, STGEVC,
$ XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
REAL SLAMCH, SLANGE
EXTERNAL LSAME, ILAENV, SLAMCH, SLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Decode the input arguments
*
IF( LSAME( JOBVL, 'N' ) ) THEN
IJOBVL = 1
ILVL = .FALSE.
ELSE IF( LSAME( JOBVL, 'V' ) ) THEN
IJOBVL = 2
ILVL = .TRUE.
ELSE
IJOBVL = -1
ILVL = .FALSE.
END IF
*
IF( LSAME( JOBVR, 'N' ) ) THEN
IJOBVR = 1
ILVR = .FALSE.
ELSE IF( LSAME( JOBVR, 'V' ) ) THEN
IJOBVR = 2
ILVR = .TRUE.
ELSE
IJOBVR = -1
ILVR = .FALSE.
END IF
ILV = ILVL .OR. ILVR
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
IF( IJOBVL.LE.0 ) THEN
INFO = -1
ELSE IF( IJOBVR.LE.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
INFO = -12
ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
INFO = -14
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV. The workspace is
* computed assuming ILO = 1 and IHI = N, the worst case.)
*
IF( INFO.EQ.0 ) THEN
MINWRK = MAX( 1, 8*N )
MAXWRK = MAX( 1, N*( 7 +
$ ILAENV( 1, 'SGEQRF', ' ', N, 1, N, 0 ) ) )
MAXWRK = MAX( MAXWRK, N*( 7 +
$ ILAENV( 1, 'SORMQR', ' ', N, 1, N, 0 ) ) )
IF( ILVL ) THEN
MAXWRK = MAX( MAXWRK, N*( 7 +
$ ILAENV( 1, 'SORGQR', ' ', N, 1, N, -1 ) ) )
END IF
WORK( 1 ) = MAXWRK
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY )
$ INFO = -16
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGGEV ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Get machine constants
*
EPS = SLAMCH( 'P' )
SMLNUM = SLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
SMLNUM = SQRT( SMLNUM ) / EPS
BIGNUM = ONE / SMLNUM
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = SLANGE( 'M', N, N, A, LDA, WORK )
ILASCL = .FALSE.
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
ANRMTO = SMLNUM
ILASCL = .TRUE.
ELSE IF( ANRM.GT.BIGNUM ) THEN
ANRMTO = BIGNUM
ILASCL = .TRUE.
END IF
IF( ILASCL )
$ CALL SLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
*
* Scale B if max element outside range [SMLNUM,BIGNUM]
*
BNRM = SLANGE( 'M', N, N, B, LDB, WORK )
ILBSCL = .FALSE.
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
BNRMTO = SMLNUM
ILBSCL = .TRUE.
ELSE IF( BNRM.GT.BIGNUM ) THEN
BNRMTO = BIGNUM
ILBSCL = .TRUE.
END IF
IF( ILBSCL )
$ CALL SLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
*
* Permute the matrices A, B to isolate eigenvalues if possible
* (Workspace: need 6*N)
*
ILEFT = 1
IRIGHT = N + 1
IWRK = IRIGHT + N
CALL SGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ),
$ WORK( IRIGHT ), WORK( IWRK ), IERR )
*
* Reduce B to triangular form (QR decomposition of B)
* (Workspace: need N, prefer N*NB)
*
IROWS = IHI + 1 - ILO
IF( ILV ) THEN
ICOLS = N + 1 - ILO
ELSE
ICOLS = IROWS
END IF
ITAU = IWRK
IWRK = ITAU + IROWS
CALL SGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
$ WORK( IWRK ), LWORK+1-IWRK, IERR )
*
* Apply the orthogonal transformation to matrix A
* (Workspace: need N, prefer N*NB)
*
CALL SORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
$ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
$ LWORK+1-IWRK, IERR )
*
* Initialize VL
* (Workspace: need N, prefer N*NB)
*
IF( ILVL ) THEN
CALL SLASET( 'Full', N, N, ZERO, ONE, VL, LDVL )
IF( IROWS.GT.1 ) THEN
CALL SLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
$ VL( ILO+1, ILO ), LDVL )
END IF
CALL SORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
$ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
END IF
*
* Initialize VR
*
IF( ILVR )
$ CALL SLASET( 'Full', N, N, ZERO, ONE, VR, LDVR )
*
* Reduce to generalized Hessenberg form
* (Workspace: none needed)
*
IF( ILV ) THEN
*
* Eigenvectors requested -- work on whole matrix.
*
CALL SGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL,
$ LDVL, VR, LDVR, IERR )
ELSE
CALL SGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA,
$ B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IERR )
END IF
*
* Perform QZ algorithm (Compute eigenvalues, and optionally, the
* Schur forms and Schur vectors)
* (Workspace: need N)
*
IWRK = ITAU
IF( ILV ) THEN
CHTEMP = 'S'
ELSE
CHTEMP = 'E'
END IF
CALL SHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB,
$ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR,
$ WORK( IWRK ), LWORK+1-IWRK, IERR )
IF( IERR.NE.0 ) THEN
IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
INFO = IERR
ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
INFO = IERR - N
ELSE
INFO = N + 1
END IF
GO TO 110
END IF
*
* Compute Eigenvectors
* (Workspace: need 6*N)
*
IF( ILV ) THEN
IF( ILVL ) THEN
IF( ILVR ) THEN
CHTEMP = 'B'
ELSE
CHTEMP = 'L'
END IF
ELSE
CHTEMP = 'R'
END IF
CALL STGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, LDVL,
$ VR, LDVR, N, IN, WORK( IWRK ), IERR )
IF( IERR.NE.0 ) THEN
INFO = N + 2
GO TO 110
END IF
*
* Undo balancing on VL and VR and normalization
* (Workspace: none needed)
*
IF( ILVL ) THEN
CALL SGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
$ WORK( IRIGHT ), N, VL, LDVL, IERR )
DO 50 JC = 1, N
IF( ALPHAI( JC ).LT.ZERO )
$ GO TO 50
TEMP = ZERO
IF( ALPHAI( JC ).EQ.ZERO ) THEN
DO 10 JR = 1, N
TEMP = MAX( TEMP, ABS( VL( JR, JC ) ) )
10 CONTINUE
ELSE
DO 20 JR = 1, N
TEMP = MAX( TEMP, ABS( VL( JR, JC ) )+
$ ABS( VL( JR, JC+1 ) ) )
20 CONTINUE
END IF
IF( TEMP.LT.SMLNUM )
$ GO TO 50
TEMP = ONE / TEMP
IF( ALPHAI( JC ).EQ.ZERO ) THEN
DO 30 JR = 1, N
VL( JR, JC ) = VL( JR, JC )*TEMP
30 CONTINUE
ELSE
DO 40 JR = 1, N
VL( JR, JC ) = VL( JR, JC )*TEMP
VL( JR, JC+1 ) = VL( JR, JC+1 )*TEMP
40 CONTINUE
END IF
50 CONTINUE
END IF
IF( ILVR ) THEN
CALL SGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ),
$ WORK( IRIGHT ), N, VR, LDVR, IERR )
DO 100 JC = 1, N
IF( ALPHAI( JC ).LT.ZERO )
$ GO TO 100
TEMP = ZERO
IF( ALPHAI( JC ).EQ.ZERO ) THEN
DO 60 JR = 1, N
TEMP = MAX( TEMP, ABS( VR( JR, JC ) ) )
60 CONTINUE
ELSE
DO 70 JR = 1, N
TEMP = MAX( TEMP, ABS( VR( JR, JC ) )+
$ ABS( VR( JR, JC+1 ) ) )
70 CONTINUE
END IF
IF( TEMP.LT.SMLNUM )
$ GO TO 100
TEMP = ONE / TEMP
IF( ALPHAI( JC ).EQ.ZERO ) THEN
DO 80 JR = 1, N
VR( JR, JC ) = VR( JR, JC )*TEMP
80 CONTINUE
ELSE
DO 90 JR = 1, N
VR( JR, JC ) = VR( JR, JC )*TEMP
VR( JR, JC+1 ) = VR( JR, JC+1 )*TEMP
90 CONTINUE
END IF
100 CONTINUE
END IF
*
* End of eigenvector calculation
*
END IF
*
* Undo scaling if necessary
*
IF( ILASCL ) THEN
CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
END IF
*
IF( ILBSCL ) THEN
CALL SLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
END IF
*
110 CONTINUE
*
WORK( 1 ) = MAXWRK
*
RETURN
*
* End of SGGEV
*
END
SUBROUTINE SGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB,
$ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, ILO,
$ IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE,
$ RCONDV, WORK, LWORK, IWORK, BWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER BALANC, JOBVL, JOBVR, SENSE
INTEGER IHI, ILO, INFO, LDA, LDB, LDVL, LDVR, LWORK, N
REAL ABNRM, BBNRM
* ..
* .. Array Arguments ..
LOGICAL BWORK( * )
INTEGER IWORK( * )
REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
$ B( LDB, * ), BETA( * ), LSCALE( * ),
$ RCONDE( * ), RCONDV( * ), RSCALE( * ),
$ VL( LDVL, * ), VR( LDVR, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B)
* the generalized eigenvalues, and optionally, the left and/or right
* generalized eigenvectors.
*
* Optionally also, it computes a balancing transformation to improve
* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
* LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for
* the eigenvalues (RCONDE), and reciprocal condition numbers for the
* right eigenvectors (RCONDV).
*
* A generalized eigenvalue for a pair of matrices (A,B) is a scalar
* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
* singular. It is usually represented as the pair (alpha,beta), as
* there is a reasonable interpretation for beta=0, and even for both
* being zero.
*
* The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
* of (A,B) satisfies
*
* A * v(j) = lambda(j) * B * v(j) .
*
* The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
* of (A,B) satisfies
*
* u(j)**H * A = lambda(j) * u(j)**H * B.
*
* where u(j)**H is the conjugate-transpose of u(j).
*
*
* Arguments
* =========
*
* BALANC (input) CHARACTER*1
* Specifies the balance option to be performed.
* = 'N': do not diagonally scale or permute;
* = 'P': permute only;
* = 'S': scale only;
* = 'B': both permute and scale.
* Computed reciprocal condition numbers will be for the
* matrices after permuting and/or balancing. Permuting does
* not change condition numbers (in exact arithmetic), but
* balancing does.
*
* JOBVL (input) CHARACTER*1
* = 'N': do not compute the left generalized eigenvectors;
* = 'V': compute the left generalized eigenvectors.
*
* JOBVR (input) CHARACTER*1
* = 'N': do not compute the right generalized eigenvectors;
* = 'V': compute the right generalized eigenvectors.
*
* SENSE (input) CHARACTER*1
* Determines which reciprocal condition numbers are computed.
* = 'N': none are computed;
* = 'E': computed for eigenvalues only;
* = 'V': computed for eigenvectors only;
* = 'B': computed for eigenvalues and eigenvectors.
*
* N (input) INTEGER
* The order of the matrices A, B, VL, and VR. N >= 0.
*
* A (input/output) REAL array, dimension (LDA, N)
* On entry, the matrix A in the pair (A,B).
* On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'
* or both, then A contains the first part of the real Schur
* form of the "balanced" versions of the input A and B.
*
* LDA (input) INTEGER
* The leading dimension of A. LDA >= max(1,N).
*
* B (input/output) REAL array, dimension (LDB, N)
* On entry, the matrix B in the pair (A,B).
* On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'
* or both, then B contains the second part of the real Schur
* form of the "balanced" versions of the input A and B.
*
* LDB (input) INTEGER
* The leading dimension of B. LDB >= max(1,N).
*
* ALPHAR (output) REAL array, dimension (N)
* ALPHAI (output) REAL array, dimension (N)
* BETA (output) REAL array, dimension (N)
* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
* be the generalized eigenvalues. If ALPHAI(j) is zero, then
* the j-th eigenvalue is real; if positive, then the j-th and
* (j+1)-st eigenvalues are a complex conjugate pair, with
* ALPHAI(j+1) negative.
*
* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
* may easily over- or underflow, and BETA(j) may even be zero.
* Thus, the user should avoid naively computing the ratio
* ALPHA/BETA. However, ALPHAR and ALPHAI will be always less
* than and usually comparable with norm(A) in magnitude, and
* BETA always less than and usually comparable with norm(B).
*
* VL (output) REAL array, dimension (LDVL,N)
* If JOBVL = 'V', the left eigenvectors u(j) are stored one
* after another in the columns of VL, in the same order as
* their eigenvalues. If the j-th eigenvalue is real, then
* u(j) = VL(:,j), the j-th column of VL. If the j-th and
* (j+1)-th eigenvalues form a complex conjugate pair, then
* u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).
* Each eigenvector will be scaled so the largest component have
* abs(real part) + abs(imag. part) = 1.
* Not referenced if JOBVL = 'N'.
*
* LDVL (input) INTEGER
* The leading dimension of the matrix VL. LDVL >= 1, and
* if JOBVL = 'V', LDVL >= N.
*
* VR (output) REAL array, dimension (LDVR,N)
* If JOBVR = 'V', the right eigenvectors v(j) are stored one
* after another in the columns of VR, in the same order as
* their eigenvalues. If the j-th eigenvalue is real, then
* v(j) = VR(:,j), the j-th column of VR. If the j-th and
* (j+1)-th eigenvalues form a complex conjugate pair, then
* v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).
* Each eigenvector will be scaled so the largest component have
* abs(real part) + abs(imag. part) = 1.
* Not referenced if JOBVR = 'N'.
*
* LDVR (input) INTEGER
* The leading dimension of the matrix VR. LDVR >= 1, and
* if JOBVR = 'V', LDVR >= N.
*
* ILO (output) INTEGER
* IHI (output) INTEGER
* ILO and IHI are integer values such that on exit
* A(i,j) = 0 and B(i,j) = 0 if i > j and
* j = 1,...,ILO-1 or i = IHI+1,...,N.
* If BALANC = 'N' or 'S', ILO = 1 and IHI = N.
*
* LSCALE (output) REAL array, dimension (N)
* Details of the permutations and scaling factors applied
* to the left side of A and B. If PL(j) is the index of the
* row interchanged with row j, and DL(j) is the scaling
* factor applied to row j, then
* LSCALE(j) = PL(j) for j = 1,...,ILO-1
* = DL(j) for j = ILO,...,IHI
* = PL(j) for j = IHI+1,...,N.
* The order in which the interchanges are made is N to IHI+1,
* then 1 to ILO-1.
*
* RSCALE (output) REAL array, dimension (N)
* Details of the permutations and scaling factors applied
* to the right side of A and B. If PR(j) is the index of the
* column interchanged with column j, and DR(j) is the scaling
* factor applied to column j, then
* RSCALE(j) = PR(j) for j = 1,...,ILO-1
* = DR(j) for j = ILO,...,IHI
* = PR(j) for j = IHI+1,...,N
* The order in which the interchanges are made is N to IHI+1,
* then 1 to ILO-1.
*
* ABNRM (output) REAL
* The one-norm of the balanced matrix A.
*
* BBNRM (output) REAL
* The one-norm of the balanced matrix B.
*
* RCONDE (output) REAL array, dimension (N)
* If SENSE = 'E' or 'B', the reciprocal condition numbers of
* the eigenvalues, stored in consecutive elements of the array.
* For a complex conjugate pair of eigenvalues two consecutive
* elements of RCONDE are set to the same value. Thus RCONDE(j),
* RCONDV(j), and the j-th columns of VL and VR all correspond
* to the j-th eigenpair.
* If SENSE = 'N' or 'V', RCONDE is not referenced.
*
* RCONDV (output) REAL array, dimension (N)
* If SENSE = 'V' or 'B', the estimated reciprocal condition
* numbers of the eigenvectors, stored in consecutive elements
* of the array. For a complex eigenvector two consecutive
* elements of RCONDV are set to the same value. If the
* eigenvalues cannot be reordered to compute RCONDV(j),
* RCONDV(j) is set to 0; this can only occur when the true
* value would be very small anyway.
* If SENSE = 'N' or 'E', RCONDV is not referenced.
*
* WORK (workspace/output) REAL 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,2*N).
* If BALANC = 'S' or 'B', or JOBVL = 'V', or JOBVR = 'V',
* LWORK >= max(1,6*N).
* If SENSE = 'E', LWORK >= max(1,10*N).
* If SENSE = 'V' or 'B', LWORK >= 2*N*N+8*N+16.
*
* 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.
*
* IWORK (workspace) INTEGER array, dimension (N+6)
* If SENSE = 'E', IWORK is not referenced.
*
* BWORK (workspace) LOGICAL array, dimension (N)
* If SENSE = 'N', BWORK is not referenced.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* = 1,...,N:
* The QZ iteration failed. No eigenvectors have been
* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
* should be correct for j=INFO+1,...,N.
* > N: =N+1: other than QZ iteration failed in SHGEQZ.
* =N+2: error return from STGEVC.
*
* Further Details
* ===============
*
* Balancing a matrix pair (A,B) includes, first, permuting rows and
* columns to isolate eigenvalues, second, applying diagonal similarity
* transformation to the rows and columns to make the rows and columns
* as close in norm as possible. The computed reciprocal condition
* numbers correspond to the balanced matrix. Permuting rows and columns
* will not change the condition numbers (in exact arithmetic) but
* diagonal scaling will. For further explanation of balancing, see
* section 4.11.1.2 of LAPACK Users' Guide.
*
* An approximate error bound on the chordal distance between the i-th
* computed generalized eigenvalue w and the corresponding exact
* eigenvalue lambda is
*
* chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)
*
* An approximate error bound for the angle between the i-th computed
* eigenvector VL(i) or VR(i) is given by
*
* EPS * norm(ABNRM, BBNRM) / DIF(i).
*
* For further explanation of the reciprocal condition numbers RCONDE
* and RCONDV, see section 4.11 of LAPACK User's Guide.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY, NOSCL,
$ PAIR, WANTSB, WANTSE, WANTSN, WANTSV
CHARACTER CHTEMP
INTEGER I, ICOLS, IERR, IJOBVL, IJOBVR, IN, IROWS,
$ ITAU, IWRK, IWRK1, J, JC, JR, M, MAXWRK,
$ MINWRK, MM
REAL ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
$ SMLNUM, TEMP
* ..
* .. Local Arrays ..
LOGICAL LDUMMA( 1 )
* ..
* .. External Subroutines ..
EXTERNAL SGEQRF, SGGBAK, SGGBAL, SGGHRD, SHGEQZ, SLABAD,
$ SLACPY, SLASCL, SLASET, SORGQR, SORMQR, STGEVC,
$ STGSNA, XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
REAL SLAMCH, SLANGE
EXTERNAL LSAME, ILAENV, SLAMCH, SLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Decode the input arguments
*
IF( LSAME( JOBVL, 'N' ) ) THEN
IJOBVL = 1
ILVL = .FALSE.
ELSE IF( LSAME( JOBVL, 'V' ) ) THEN
IJOBVL = 2
ILVL = .TRUE.
ELSE
IJOBVL = -1
ILVL = .FALSE.
END IF
*
IF( LSAME( JOBVR, 'N' ) ) THEN
IJOBVR = 1
ILVR = .FALSE.
ELSE IF( LSAME( JOBVR, 'V' ) ) THEN
IJOBVR = 2
ILVR = .TRUE.
ELSE
IJOBVR = -1
ILVR = .FALSE.
END IF
ILV = ILVL .OR. ILVR
*
NOSCL = LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, 'P' )
WANTSN = LSAME( SENSE, 'N' )
WANTSE = LSAME( SENSE, 'E' )
WANTSV = LSAME( SENSE, 'V' )
WANTSB = LSAME( SENSE, 'B' )
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.( NOSCL .OR. LSAME( BALANC, 'S' ) .OR.
$ LSAME( BALANC, 'B' ) ) ) THEN
INFO = -1
ELSE IF( IJOBVL.LE.0 ) THEN
INFO = -2
ELSE IF( IJOBVR.LE.0 ) THEN
INFO = -3
ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSB .OR. WANTSV ) )
$ THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
INFO = -14
ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
INFO = -16
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV. The workspace is
* computed assuming ILO = 1 and IHI = N, the worst case.)
*
IF( INFO.EQ.0 ) THEN
IF( N.EQ.0 ) THEN
MINWRK = 1
MAXWRK = 1
ELSE
IF( NOSCL .AND. .NOT.ILV ) THEN
MINWRK = 2*N
ELSE
MINWRK = 6*N
END IF
IF( WANTSE ) THEN
MINWRK = 10*N
ELSE IF( WANTSV .OR. WANTSB ) THEN
MINWRK = 2*N*( N + 4 ) + 16
END IF
MAXWRK = MINWRK
MAXWRK = MAX( MAXWRK,
$ N + N*ILAENV( 1, 'SGEQRF', ' ', N, 1, N, 0 ) )
MAXWRK = MAX( MAXWRK,
$ N + N*ILAENV( 1, 'SORMQR', ' ', N, 1, N, 0 ) )
IF( ILVL ) THEN
MAXWRK = MAX( MAXWRK, N +
$ N*ILAENV( 1, 'SORGQR', ' ', N, 1, N, 0 ) )
END IF
END IF
WORK( 1 ) = MAXWRK
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
INFO = -26
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGGEVX', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
*
* Get machine constants
*
EPS = SLAMCH( 'P' )
SMLNUM = SLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
SMLNUM = SQRT( SMLNUM ) / EPS
BIGNUM = ONE / SMLNUM
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = SLANGE( 'M', N, N, A, LDA, WORK )
ILASCL = .FALSE.
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
ANRMTO = SMLNUM
ILASCL = .TRUE.
ELSE IF( ANRM.GT.BIGNUM ) THEN
ANRMTO = BIGNUM
ILASCL = .TRUE.
END IF
IF( ILASCL )
$ CALL SLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
*
* Scale B if max element outside range [SMLNUM,BIGNUM]
*
BNRM = SLANGE( 'M', N, N, B, LDB, WORK )
ILBSCL = .FALSE.
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
BNRMTO = SMLNUM
ILBSCL = .TRUE.
ELSE IF( BNRM.GT.BIGNUM ) THEN
BNRMTO = BIGNUM
ILBSCL = .TRUE.
END IF
IF( ILBSCL )
$ CALL SLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
*
* Permute and/or balance the matrix pair (A,B)
* (Workspace: need 6*N if BALANC = 'S' or 'B', 1 otherwise)
*
CALL SGGBAL( BALANC, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE,
$ WORK, IERR )
*
* Compute ABNRM and BBNRM
*
ABNRM = SLANGE( '1', N, N, A, LDA, WORK( 1 ) )
IF( ILASCL ) THEN
WORK( 1 ) = ABNRM
CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, 1, 1, WORK( 1 ), 1,
$ IERR )
ABNRM = WORK( 1 )
END IF
*
BBNRM = SLANGE( '1', N, N, B, LDB, WORK( 1 ) )
IF( ILBSCL ) THEN
WORK( 1 ) = BBNRM
CALL SLASCL( 'G', 0, 0, BNRMTO, BNRM, 1, 1, WORK( 1 ), 1,
$ IERR )
BBNRM = WORK( 1 )
END IF
*
* Reduce B to triangular form (QR decomposition of B)
* (Workspace: need N, prefer N*NB )
*
IROWS = IHI + 1 - ILO
IF( ILV .OR. .NOT.WANTSN ) THEN
ICOLS = N + 1 - ILO
ELSE
ICOLS = IROWS
END IF
ITAU = 1
IWRK = ITAU + IROWS
CALL SGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
$ WORK( IWRK ), LWORK+1-IWRK, IERR )
*
* Apply the orthogonal transformation to A
* (Workspace: need N, prefer N*NB)
*
CALL SORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
$ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
$ LWORK+1-IWRK, IERR )
*
* Initialize VL and/or VR
* (Workspace: need N, prefer N*NB)
*
IF( ILVL ) THEN
CALL SLASET( 'Full', N, N, ZERO, ONE, VL, LDVL )
IF( IROWS.GT.1 ) THEN
CALL SLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
$ VL( ILO+1, ILO ), LDVL )
END IF
CALL SORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
$ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
END IF
*
IF( ILVR )
$ CALL SLASET( 'Full', N, N, ZERO, ONE, VR, LDVR )
*
* Reduce to generalized Hessenberg form
* (Workspace: none needed)
*
IF( ILV .OR. .NOT.WANTSN ) THEN
*
* Eigenvectors requested -- work on whole matrix.
*
CALL SGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL,
$ LDVL, VR, LDVR, IERR )
ELSE
CALL SGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA,
$ B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IERR )
END IF
*
* Perform QZ algorithm (Compute eigenvalues, and optionally, the
* Schur forms and Schur vectors)
* (Workspace: need N)
*
IF( ILV .OR. .NOT.WANTSN ) THEN
CHTEMP = 'S'
ELSE
CHTEMP = 'E'
END IF
*
CALL SHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB,
$ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK,
$ LWORK, IERR )
IF( IERR.NE.0 ) THEN
IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
INFO = IERR
ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
INFO = IERR - N
ELSE
INFO = N + 1
END IF
GO TO 130
END IF
*
* Compute Eigenvectors and estimate condition numbers if desired
* (Workspace: STGEVC: need 6*N
* STGSNA: need 2*N*(N+2)+16 if SENSE = 'V' or 'B',
* need N otherwise )
*
IF( ILV .OR. .NOT.WANTSN ) THEN
IF( ILV ) THEN
IF( ILVL ) THEN
IF( ILVR ) THEN
CHTEMP = 'B'
ELSE
CHTEMP = 'L'
END IF
ELSE
CHTEMP = 'R'
END IF
*
CALL STGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL,
$ LDVL, VR, LDVR, N, IN, WORK, IERR )
IF( IERR.NE.0 ) THEN
INFO = N + 2
GO TO 130
END IF
END IF
*
IF( .NOT.WANTSN ) THEN
*
* compute eigenvectors (STGEVC) and estimate condition
* numbers (STGSNA). Note that the definition of the condition
* number is not invariant under transformation (u,v) to
* (Q*u, Z*v), where (u,v) are eigenvectors of the generalized
* Schur form (S,T), Q and Z are orthogonal matrices. In order
* to avoid using extra 2*N*N workspace, we have to recalculate
* eigenvectors and estimate one condition numbers at a time.
*
PAIR = .FALSE.
DO 20 I = 1, N
*
IF( PAIR ) THEN
PAIR = .FALSE.
GO TO 20
END IF
MM = 1
IF( I.LT.N ) THEN
IF( A( I+1, I ).NE.ZERO ) THEN
PAIR = .TRUE.
MM = 2
END IF
END IF
*
DO 10 J = 1, N
BWORK( J ) = .FALSE.
10 CONTINUE
IF( MM.EQ.1 ) THEN
BWORK( I ) = .TRUE.
ELSE IF( MM.EQ.2 ) THEN
BWORK( I ) = .TRUE.
BWORK( I+1 ) = .TRUE.
END IF
*
IWRK = MM*N + 1
IWRK1 = IWRK + MM*N
*
* Compute a pair of left and right eigenvectors.
* (compute workspace: need up to 4*N + 6*N)
*
IF( WANTSE .OR. WANTSB ) THEN
CALL STGEVC( 'B', 'S', BWORK, N, A, LDA, B, LDB,
$ WORK( 1 ), N, WORK( IWRK ), N, MM, M,
$ WORK( IWRK1 ), IERR )
IF( IERR.NE.0 ) THEN
INFO = N + 2
GO TO 130
END IF
END IF
*
CALL STGSNA( SENSE, 'S', BWORK, N, A, LDA, B, LDB,
$ WORK( 1 ), N, WORK( IWRK ), N, RCONDE( I ),
$ RCONDV( I ), MM, M, WORK( IWRK1 ),
$ LWORK-IWRK1+1, IWORK, IERR )
*
20 CONTINUE
END IF
END IF
*
* Undo balancing on VL and VR and normalization
* (Workspace: none needed)
*
IF( ILVL ) THEN
CALL SGGBAK( BALANC, 'L', N, ILO, IHI, LSCALE, RSCALE, N, VL,
$ LDVL, IERR )
*
DO 70 JC = 1, N
IF( ALPHAI( JC ).LT.ZERO )
$ GO TO 70
TEMP = ZERO
IF( ALPHAI( JC ).EQ.ZERO ) THEN
DO 30 JR = 1, N
TEMP = MAX( TEMP, ABS( VL( JR, JC ) ) )
30 CONTINUE
ELSE
DO 40 JR = 1, N
TEMP = MAX( TEMP, ABS( VL( JR, JC ) )+
$ ABS( VL( JR, JC+1 ) ) )
40 CONTINUE
END IF
IF( TEMP.LT.SMLNUM )
$ GO TO 70
TEMP = ONE / TEMP
IF( ALPHAI( JC ).EQ.ZERO ) THEN
DO 50 JR = 1, N
VL( JR, JC ) = VL( JR, JC )*TEMP
50 CONTINUE
ELSE
DO 60 JR = 1, N
VL( JR, JC ) = VL( JR, JC )*TEMP
VL( JR, JC+1 ) = VL( JR, JC+1 )*TEMP
60 CONTINUE
END IF
70 CONTINUE
END IF
IF( ILVR ) THEN
CALL SGGBAK( BALANC, 'R', N, ILO, IHI, LSCALE, RSCALE, N, VR,
$ LDVR, IERR )
DO 120 JC = 1, N
IF( ALPHAI( JC ).LT.ZERO )
$ GO TO 120
TEMP = ZERO
IF( ALPHAI( JC ).EQ.ZERO ) THEN
DO 80 JR = 1, N
TEMP = MAX( TEMP, ABS( VR( JR, JC ) ) )
80 CONTINUE
ELSE
DO 90 JR = 1, N
TEMP = MAX( TEMP, ABS( VR( JR, JC ) )+
$ ABS( VR( JR, JC+1 ) ) )
90 CONTINUE
END IF
IF( TEMP.LT.SMLNUM )
$ GO TO 120
TEMP = ONE / TEMP
IF( ALPHAI( JC ).EQ.ZERO ) THEN
DO 100 JR = 1, N
VR( JR, JC ) = VR( JR, JC )*TEMP
100 CONTINUE
ELSE
DO 110 JR = 1, N
VR( JR, JC ) = VR( JR, JC )*TEMP
VR( JR, JC+1 ) = VR( JR, JC+1 )*TEMP
110 CONTINUE
END IF
120 CONTINUE
END IF
*
* Undo scaling if necessary
*
IF( ILASCL ) THEN
CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
END IF
*
IF( ILBSCL ) THEN
CALL SLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
END IF
*
130 CONTINUE
WORK( 1 ) = MAXWRK
*
RETURN
*
* End of SGGEVX
*
END
SUBROUTINE SGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK,
$ INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, P
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), D( * ), WORK( * ),
$ X( * ), Y( * )
* ..
*
* Purpose
* =======
*
* SGGGLM solves a general Gauss-Markov linear model (GLM) problem:
*
* minimize || y ||_2 subject to d = A*x + B*y
* x
*
* where A is an N-by-M matrix, B is an N-by-P matrix, and d is a
* given N-vector. It is assumed that M <= N <= M+P, and
*
* rank(A) = M and rank( A B ) = N.
*
* Under these assumptions, the constrained equation is always
* consistent, and there is a unique solution x and a minimal 2-norm
* solution y, which is obtained using a generalized QR factorization
* of the matrices (A, B) given by
*
* A = Q*(R), B = Q*T*Z.
* (0)
*
* In particular, if matrix B is square nonsingular, then the problem
* GLM is equivalent to the following weighted linear least squares
* problem
*
* minimize || inv(B)*(d-A*x) ||_2
* x
*
* where inv(B) denotes the inverse of B.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of rows of the matrices A and B. N >= 0.
*
* M (input) INTEGER
* The number of columns of the matrix A. 0 <= M <= N.
*
* P (input) INTEGER
* The number of columns of the matrix B. P >= N-M.
*
* A (input/output) REAL array, dimension (LDA,M)
* On entry, the N-by-M matrix A.
* On exit, the upper triangular part of the array A contains
* the M-by-M upper triangular matrix R.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input/output) REAL array, dimension (LDB,P)
* On entry, the N-by-P matrix B.
* On exit, if N <= P, the upper triangle of the subarray
* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;
* if N > P, the elements on and above the (N-P)th subdiagonal
* contain the N-by-P upper trapezoidal matrix T.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* D (input/output) REAL array, dimension (N)
* On entry, D is the left hand side of the GLM equation.
* On exit, D is destroyed.
*
* X (output) REAL array, dimension (M)
* Y (output) REAL array, dimension (P)
* On exit, X and Y are the solutions of the GLM problem.
*
* WORK (workspace/output) REAL 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+M+P).
* For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,
* where NB is an upper bound for the optimal blocksizes for
* SGEQRF, SGERQF, SORMQR and SORMRQ.
*
* 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.
* = 1: the upper triangular factor R associated with A in the
* generalized QR factorization of the pair (A, B) is
* singular, so that rank(A) < M; the least squares
* solution could not be computed.
* = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal
* factor T associated with B in the generalized QR
* factorization of the pair (A, B) is singular, so that
* rank( A B ) < N; the least squares solution could not
* be computed.
*
* ===================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, LOPT, LWKMIN, LWKOPT, NB, NB1, NB2, NB3,
$ NB4, NP
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMV, SGGQRF, SORMQR, SORMRQ, STRTRS,
$ XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC INT, MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
NP = MIN( N, P )
LQUERY = ( LWORK.EQ.-1 )
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( M.LT.0 .OR. M.GT.N ) THEN
INFO = -2
ELSE IF( P.LT.0 .OR. P.LT.N-M ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
END IF
*
* Calculate workspace
*
IF( INFO.EQ.0) THEN
IF( N.EQ.0 ) THEN
LWKMIN = 1
LWKOPT = 1
ELSE
NB1 = ILAENV( 1, 'SGEQRF', ' ', N, M, -1, -1 )
NB2 = ILAENV( 1, 'SGERQF', ' ', N, M, -1, -1 )
NB3 = ILAENV( 1, 'SORMQR', ' ', N, M, P, -1 )
NB4 = ILAENV( 1, 'SORMRQ', ' ', N, M, P, -1 )
NB = MAX( NB1, NB2, NB3, NB4 )
LWKMIN = M + N + P
LWKOPT = M + NP + MAX( N, P )*NB
END IF
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGGGLM', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Compute the GQR factorization of matrices A and B:
*
* Q'*A = ( R11 ) M, Q'*B*Z' = ( T11 T12 ) M
* ( 0 ) N-M ( 0 T22 ) N-M
* M M+P-N N-M
*
* where R11 and T22 are upper triangular, and Q and Z are
* orthogonal.
*
CALL SGGQRF( N, M, P, A, LDA, WORK, B, LDB, WORK( M+1 ),
$ WORK( M+NP+1 ), LWORK-M-NP, INFO )
LOPT = WORK( M+NP+1 )
*
* Update left-hand-side vector d = Q'*d = ( d1 ) M
* ( d2 ) N-M
*
CALL SORMQR( 'Left', 'Transpose', N, 1, M, A, LDA, WORK, D,
$ MAX( 1, N ), WORK( M+NP+1 ), LWORK-M-NP, INFO )
LOPT = MAX( LOPT, INT( WORK( M+NP+1 ) ) )
*
* Solve T22*y2 = d2 for y2
*
IF( N.GT.M ) THEN
CALL STRTRS( 'Upper', 'No transpose', 'Non unit', N-M, 1,
$ B( M+1, M+P-N+1 ), LDB, D( M+1 ), N-M, INFO )
*
IF( INFO.GT.0 ) THEN
INFO = 1
RETURN
END IF
*
CALL SCOPY( N-M, D( M+1 ), 1, Y( M+P-N+1 ), 1 )
END IF
*
* Set y1 = 0
*
DO 10 I = 1, M + P - N
Y( I ) = ZERO
10 CONTINUE
*
* Update d1 = d1 - T12*y2
*
CALL SGEMV( 'No transpose', M, N-M, -ONE, B( 1, M+P-N+1 ), LDB,
$ Y( M+P-N+1 ), 1, ONE, D, 1 )
*
* Solve triangular system: R11*x = d1
*
IF( M.GT.0 ) THEN
CALL STRTRS( 'Upper', 'No Transpose', 'Non unit', M, 1, A, LDA,
$ D, M, INFO )
*
IF( INFO.GT.0 ) THEN
INFO = 2
RETURN
END IF
*
* Copy D to X
*
CALL SCOPY( M, D, 1, X, 1 )
END IF
*
* Backward transformation y = Z'*y
*
CALL SORMRQ( 'Left', 'Transpose', P, 1, NP,
$ B( MAX( 1, N-P+1 ), 1 ), LDB, WORK( M+1 ), Y,
$ MAX( 1, P ), WORK( M+NP+1 ), LWORK-M-NP, INFO )
WORK( 1 ) = M + NP + MAX( LOPT, INT( WORK( M+NP+1 ) ) )
*
RETURN
*
* End of SGGGLM
*
END
SUBROUTINE SGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q,
$ LDQ, Z, LDZ, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER COMPQ, COMPZ
INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
$ Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SGGHRD reduces a pair of real matrices (A,B) to generalized upper
* Hessenberg form using orthogonal transformations, where A is a
* general matrix and B is upper triangular. The form of the
* generalized eigenvalue problem is
* A*x = lambda*B*x,
* and B is typically made upper triangular by computing its QR
* factorization and moving the orthogonal matrix Q to the left side
* of the equation.
*
* This subroutine simultaneously reduces A to a Hessenberg matrix H:
* Q**T*A*Z = H
* and transforms B to another upper triangular matrix T:
* Q**T*B*Z = T
* in order to reduce the problem to its standard form
* H*y = lambda*T*y
* where y = Z**T*x.
*
* The orthogonal matrices Q and Z are determined as products of Givens
* rotations. They may either be formed explicitly, or they may be
* postmultiplied into input matrices Q1 and Z1, so that
*
* Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T
*
* Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T
*
* If Q1 is the orthogonal matrix from the QR factorization of B in the
* original equation A*x = lambda*B*x, then SGGHRD reduces the original
* problem to generalized Hessenberg form.
*
* Arguments
* =========
*
* COMPQ (input) CHARACTER*1
* = 'N': do not compute Q;
* = 'I': Q is initialized to the unit matrix, and the
* orthogonal matrix Q is returned;
* = 'V': Q must contain an orthogonal matrix Q1 on entry,
* and the product Q1*Q is returned.
*
* COMPZ (input) CHARACTER*1
* = 'N': do not compute Z;
* = 'I': Z is initialized to the unit matrix, and the
* orthogonal matrix Z is returned;
* = 'V': Z must contain an orthogonal matrix Z1 on entry,
* and the product Z1*Z is returned.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* ILO and IHI mark the rows and columns of A which are to be
* reduced. It is assumed that A is already upper triangular
* in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are
* normally set by a previous call to SGGBAL; otherwise they
* should be set to 1 and N respectively.
* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
*
* A (input/output) REAL array, dimension (LDA, N)
* On entry, the N-by-N general matrix to be reduced.
* On exit, the upper triangle and the first subdiagonal of A
* are overwritten with the upper Hessenberg matrix H, and the
* rest is set to zero.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input/output) REAL array, dimension (LDB, N)
* On entry, the N-by-N upper triangular matrix B.
* On exit, the upper triangular matrix T = Q**T B Z. The
* elements below the diagonal are set to zero.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* Q (input/output) REAL array, dimension (LDQ, N)
* On entry, if COMPQ = 'V', the orthogonal matrix Q1,
* typically from the QR factorization of B.
* On exit, if COMPQ='I', the orthogonal matrix Q, and if
* COMPQ = 'V', the product Q1*Q.
* Not referenced if COMPQ='N'.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q.
* LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.
*
* Z (input/output) REAL array, dimension (LDZ, N)
* On entry, if COMPZ = 'V', the orthogonal matrix Z1.
* On exit, if COMPZ='I', the orthogonal matrix Z, and if
* COMPZ = 'V', the product Z1*Z.
* Not referenced if COMPZ='N'.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z.
* LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* This routine reduces A to Hessenberg and B to triangular form by
* an unblocked reduction, as described in _Matrix_Computations_,
* by Golub and Van Loan (Johns Hopkins Press.)
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL ILQ, ILZ
INTEGER ICOMPQ, ICOMPZ, JCOL, JROW
REAL C, S, TEMP
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SLARTG, SLASET, SROT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Decode COMPQ
*
IF( LSAME( COMPQ, 'N' ) ) THEN
ILQ = .FALSE.
ICOMPQ = 1
ELSE IF( LSAME( COMPQ, 'V' ) ) THEN
ILQ = .TRUE.
ICOMPQ = 2
ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
ILQ = .TRUE.
ICOMPQ = 3
ELSE
ICOMPQ = 0
END IF
*
* Decode COMPZ
*
IF( LSAME( COMPZ, 'N' ) ) THEN
ILZ = .FALSE.
ICOMPZ = 1
ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
ILZ = .TRUE.
ICOMPZ = 2
ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
ILZ = .TRUE.
ICOMPZ = 3
ELSE
ICOMPZ = 0
END IF
*
* Test the input parameters.
*
INFO = 0
IF( ICOMPQ.LE.0 ) THEN
INFO = -1
ELSE IF( ICOMPZ.LE.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ILO.LT.1 ) THEN
INFO = -4
ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN
INFO = -11
ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN
INFO = -13
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGGHRD', -INFO )
RETURN
END IF
*
* Initialize Q and Z if desired.
*
IF( ICOMPQ.EQ.3 )
$ CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
IF( ICOMPZ.EQ.3 )
$ CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
*
* Quick return if possible
*
IF( N.LE.1 )
$ RETURN
*
* Zero out lower triangle of B
*
DO 20 JCOL = 1, N - 1
DO 10 JROW = JCOL + 1, N
B( JROW, JCOL ) = ZERO
10 CONTINUE
20 CONTINUE
*
* Reduce A and B
*
DO 40 JCOL = ILO, IHI - 2
*
DO 30 JROW = IHI, JCOL + 2, -1
*
* Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL)
*
TEMP = A( JROW-1, JCOL )
CALL SLARTG( TEMP, A( JROW, JCOL ), C, S,
$ A( JROW-1, JCOL ) )
A( JROW, JCOL ) = ZERO
CALL SROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA,
$ A( JROW, JCOL+1 ), LDA, C, S )
CALL SROT( N+2-JROW, B( JROW-1, JROW-1 ), LDB,
$ B( JROW, JROW-1 ), LDB, C, S )
IF( ILQ )
$ CALL SROT( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, C, S )
*
* Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1)
*
TEMP = B( JROW, JROW )
CALL SLARTG( TEMP, B( JROW, JROW-1 ), C, S,
$ B( JROW, JROW ) )
B( JROW, JROW-1 ) = ZERO
CALL SROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, C, S )
CALL SROT( JROW-1, B( 1, JROW ), 1, B( 1, JROW-1 ), 1, C,
$ S )
IF( ILZ )
$ CALL SROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, C, S )
30 CONTINUE
40 CONTINUE
*
RETURN
*
* End of SGGHRD
*
END
SUBROUTINE SGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK,
$ INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, P
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), C( * ), D( * ),
$ WORK( * ), X( * )
* ..
*
* Purpose
* =======
*
* SGGLSE solves the linear equality-constrained least squares (LSE)
* problem:
*
* minimize || c - A*x ||_2 subject to B*x = d
*
* where A is an M-by-N matrix, B is a P-by-N matrix, c is a given
* M-vector, and d is a given P-vector. It is assumed that
* P <= N <= M+P, and
*
* rank(B) = P and rank( (A) ) = N.
* ( (B) )
*
* These conditions ensure that the LSE problem has a unique solution,
* which is obtained using a generalized RQ factorization of the
* matrices (B, A) given by
*
* B = (0 R)*Q, A = Z*T*Q.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix A. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrices A and B. N >= 0.
*
* P (input) INTEGER
* The number of rows of the matrix B. 0 <= P <= N <= M+P.
*
* A (input/output) REAL 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 T.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input/output) REAL array, dimension (LDB,N)
* On entry, the P-by-N matrix B.
* On exit, the upper triangle of the subarray B(1:P,N-P+1:N)
* contains the P-by-P upper triangular matrix R.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,P).
*
* C (input/output) REAL array, dimension (M)
* On entry, C contains the right hand side vector for the
* least squares part of the LSE problem.
* On exit, the residual sum of squares for the solution
* is given by the sum of squares of elements N-P+1 to M of
* vector C.
*
* D (input/output) REAL array, dimension (P)
* On entry, D contains the right hand side vector for the
* constrained equation.
* On exit, D is destroyed.
*
* X (output) REAL array, dimension (N)
* On exit, X is the solution of the LSE problem.
*
* WORK (workspace/output) REAL 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,M+N+P).
* For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,
* where NB is an upper bound for the optimal blocksizes for
* SGEQRF, SGERQF, SORMQR and SORMRQ.
*
* 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.
* = 1: the upper triangular factor R associated with B in the
* generalized RQ factorization of the pair (B, A) is
* singular, so that rank(B) < P; the least squares
* solution could not be computed.
* = 2: the (N-P) by (N-P) part of the upper trapezoidal factor
* T associated with A in the generalized RQ factorization
* of the pair (B, A) is singular, so that
* rank( (A) ) < N; the least squares solution could not
* ( (B) )
* be computed.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER LOPT, LWKMIN, LWKOPT, MN, NB, NB1, NB2, NB3,
$ NB4, NR
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, SGEMV, SGGRQF, SORMQR, SORMRQ,
$ STRMV, STRTRS, XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC INT, MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
MN = MIN( M, N )
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( P.LT.0 .OR. P.GT.N .OR. P.LT.N-M ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
INFO = -7
END IF
*
* Calculate workspace
*
IF( INFO.EQ.0) THEN
IF( N.EQ.0 ) THEN
LWKMIN = 1
LWKOPT = 1
ELSE
NB1 = ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
NB2 = ILAENV( 1, 'SGERQF', ' ', M, N, -1, -1 )
NB3 = ILAENV( 1, 'SORMQR', ' ', M, N, P, -1 )
NB4 = ILAENV( 1, 'SORMRQ', ' ', M, N, P, -1 )
NB = MAX( NB1, NB2, NB3, NB4 )
LWKMIN = M + N + P
LWKOPT = P + MN + MAX( M, N )*NB
END IF
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGGLSE', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Compute the GRQ factorization of matrices B and A:
*
* B*Q' = ( 0 T12 ) P Z'*A*Q' = ( R11 R12 ) N-P
* N-P P ( 0 R22 ) M+P-N
* N-P P
*
* where T12 and R11 are upper triangular, and Q and Z are
* orthogonal.
*
CALL SGGRQF( P, M, N, B, LDB, WORK, A, LDA, WORK( P+1 ),
$ WORK( P+MN+1 ), LWORK-P-MN, INFO )
LOPT = WORK( P+MN+1 )
*
* Update c = Z'*c = ( c1 ) N-P
* ( c2 ) M+P-N
*
CALL SORMQR( 'Left', 'Transpose', M, 1, MN, A, LDA, WORK( P+1 ),
$ C, MAX( 1, M ), WORK( P+MN+1 ), LWORK-P-MN, INFO )
LOPT = MAX( LOPT, INT( WORK( P+MN+1 ) ) )
*
* Solve T12*x2 = d for x2
*
IF( P.GT.0 ) THEN
CALL STRTRS( 'Upper', 'No transpose', 'Non-unit', P, 1,
$ B( 1, N-P+1 ), LDB, D, P, INFO )
*
IF( INFO.GT.0 ) THEN
INFO = 1
RETURN
END IF
*
* Put the solution in X
*
CALL SCOPY( P, D, 1, X( N-P+1 ), 1 )
*
* Update c1
*
CALL SGEMV( 'No transpose', N-P, P, -ONE, A( 1, N-P+1 ), LDA,
$ D, 1, ONE, C, 1 )
END IF
*
* Solve R11*x1 = c1 for x1
*
IF( N.GT.P ) THEN
CALL STRTRS( 'Upper', 'No transpose', 'Non-unit', N-P, 1,
$ A, LDA, C, N-P, INFO )
*
IF( INFO.GT.0 ) THEN
INFO = 2
RETURN
END IF
*
* Put the solution in X
*
CALL SCOPY( N-P, C, 1, X, 1 )
END IF
*
* Compute the residual vector:
*
IF( M.LT.N ) THEN
NR = M + P - N
IF( NR.GT.0 )
$ CALL SGEMV( 'No transpose', NR, N-M, -ONE, A( N-P+1, M+1 ),
$ LDA, D( NR+1 ), 1, ONE, C( N-P+1 ), 1 )
ELSE
NR = P
END IF
IF( NR.GT.0 ) THEN
CALL STRMV( 'Upper', 'No transpose', 'Non unit', NR,
$ A( N-P+1, N-P+1 ), LDA, D, 1 )
CALL SAXPY( NR, -ONE, D, 1, C( N-P+1 ), 1 )
END IF
*
* Backward transformation x = Q'*x
*
CALL SORMRQ( 'Left', 'Transpose', N, 1, P, B, LDB, WORK( 1 ), X,
$ N, WORK( P+MN+1 ), LWORK-P-MN, INFO )
WORK( 1 ) = P + MN + MAX( LOPT, INT( WORK( P+MN+1 ) ) )
*
RETURN
*
* End of SGGLSE
*
END
SUBROUTINE SGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK,
$ LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, P
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* SGGQRF computes a generalized QR factorization of an N-by-M matrix A
* and an N-by-P matrix B:
*
* A = Q*R, B = Q*T*Z,
*
* where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal
* matrix, and R and T assume one of the forms:
*
* if N >= M, R = ( R11 ) M , or if N < M, R = ( R11 R12 ) N,
* ( 0 ) N-M N M-N
* M
*
* where R11 is upper triangular, and
*
* if N <= P, T = ( 0 T12 ) N, or if N > P, T = ( T11 ) N-P,
* P-N N ( T21 ) P
* P
*
* where T12 or T21 is upper triangular.
*
* In particular, if B is square and nonsingular, the GQR factorization
* of A and B implicitly gives the QR factorization of inv(B)*A:
*
* inv(B)*A = Z'*(inv(T)*R)
*
* where inv(B) denotes the inverse of the matrix B, and Z' denotes the
* transpose of the matrix Z.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of rows of the matrices A and B. N >= 0.
*
* M (input) INTEGER
* The number of columns of the matrix A. M >= 0.
*
* P (input) INTEGER
* The number of columns of the matrix B. P >= 0.
*
* A (input/output) REAL array, dimension (LDA,M)
* On entry, the N-by-M matrix A.
* On exit, the elements on and above the diagonal of the array
* contain the min(N,M)-by-M upper trapezoidal matrix R (R is
* upper triangular if N >= M); the elements below the diagonal,
* with the array TAUA, represent the orthogonal matrix Q as a
* product of min(N,M) elementary reflectors (see Further
* Details).
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* TAUA (output) REAL array, dimension (min(N,M))
* The scalar factors of the elementary reflectors which
* represent the orthogonal matrix Q (see Further Details).
*
* B (input/output) REAL array, dimension (LDB,P)
* On entry, the N-by-P matrix B.
* On exit, if N <= P, the upper triangle of the subarray
* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;
* if N > P, the elements on and above the (N-P)-th subdiagonal
* contain the N-by-P upper trapezoidal matrix T; the remaining
* elements, with the array TAUB, represent the orthogonal
* matrix Z as a product of elementary reflectors (see Further
* Details).
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* TAUB (output) REAL array, dimension (min(N,P))
* The scalar factors of the elementary reflectors which
* represent the orthogonal matrix Z (see Further Details).
*
* WORK (workspace/output) REAL 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,M,P).
* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
* where NB1 is the optimal blocksize for the QR factorization
* of an N-by-M matrix, NB2 is the optimal blocksize for the
* RQ factorization of an N-by-P matrix, and NB3 is the optimal
* blocksize for a call of SORMQR.
*
* 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(n,m).
*
* Each H(i) has the form
*
* H(i) = I - taua * v * v'
*
* where taua is a real scalar, and v is a real vector with
* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
* and taua in TAUA(i).
* To form Q explicitly, use LAPACK subroutine SORGQR.
* To use Q to update another matrix, use LAPACK subroutine SORMQR.
*
* The matrix Z is represented as a product of elementary reflectors
*
* Z = H(1) H(2) . . . H(k), where k = min(n,p).
*
* Each H(i) has the form
*
* H(i) = I - taub * v * v'
*
* where taub is a real scalar, and v is a real vector with
* v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in
* B(n-k+i,1:p-k+i-1), and taub in TAUB(i).
* To form Z explicitly, use LAPACK subroutine SORGRQ.
* To use Z to update another matrix, use LAPACK subroutine SORMRQ.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3
* ..
* .. External Subroutines ..
EXTERNAL SGEQRF, SGERQF, SORMQR, XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC INT, MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
NB1 = ILAENV( 1, 'SGEQRF', ' ', N, M, -1, -1 )
NB2 = ILAENV( 1, 'SGERQF', ' ', N, P, -1, -1 )
NB3 = ILAENV( 1, 'SORMQR', ' ', N, M, P, -1 )
NB = MAX( NB1, NB2, NB3 )
LWKOPT = MAX( N, M, P )*NB
WORK( 1 ) = LWKOPT
LQUERY = ( LWORK.EQ.-1 )
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( M.LT.0 ) THEN
INFO = -2
ELSE IF( P.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
ELSE IF( LWORK.LT.MAX( 1, N, M, P ) .AND. .NOT.LQUERY ) THEN
INFO = -11
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGGQRF', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* QR factorization of N-by-M matrix A: A = Q*R
*
CALL SGEQRF( N, M, A, LDA, TAUA, WORK, LWORK, INFO )
LOPT = WORK( 1 )
*
* Update B := Q'*B.
*
CALL SORMQR( 'Left', 'Transpose', N, P, MIN( N, M ), A, LDA, TAUA,
$ B, LDB, WORK, LWORK, INFO )
LOPT = MAX( LOPT, INT( WORK( 1 ) ) )
*
* RQ factorization of N-by-P matrix B: B = T*Z.
*
CALL SGERQF( N, P, B, LDB, TAUB, WORK, LWORK, INFO )
WORK( 1 ) = MAX( LOPT, INT( WORK( 1 ) ) )
*
RETURN
*
* End of SGGQRF
*
END
SUBROUTINE SGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK,
$ LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, P
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* SGGRQF computes a generalized RQ factorization of an M-by-N matrix A
* and a P-by-N matrix B:
*
* A = R*Q, B = Z*T*Q,
*
* where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal
* matrix, and R and T assume one of the forms:
*
* if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N,
* N-M M ( R21 ) N
* N
*
* where R12 or R21 is upper triangular, and
*
* if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P,
* ( 0 ) P-N P N-P
* N
*
* where T11 is upper triangular.
*
* In particular, if B is square and nonsingular, the GRQ factorization
* of A and B implicitly gives the RQ factorization of A*inv(B):
*
* A*inv(B) = (R*inv(T))*Z'
*
* where inv(B) denotes the inverse of the matrix B, and Z' denotes the
* transpose of the matrix Z.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix A. M >= 0.
*
* P (input) INTEGER
* The number of rows of the matrix B. P >= 0.
*
* N (input) INTEGER
* The number of columns of the matrices A and B. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, if M <= N, the upper triangle of the subarray
* A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;
* if M > N, the elements on and above the (M-N)-th subdiagonal
* contain the M-by-N upper trapezoidal matrix R; the remaining
* elements, with the array TAUA, 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).
*
* TAUA (output) REAL array, dimension (min(M,N))
* The scalar factors of the elementary reflectors which
* represent the orthogonal matrix Q (see Further Details).
*
* B (input/output) REAL array, dimension (LDB,N)
* On entry, the P-by-N matrix B.
* On exit, the elements on and above the diagonal of the array
* contain the min(P,N)-by-N upper trapezoidal matrix T (T is
* upper triangular if P >= N); the elements below the diagonal,
* with the array TAUB, represent the orthogonal matrix Z as a
* product of elementary reflectors (see Further Details).
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,P).
*
* TAUB (output) REAL array, dimension (min(P,N))
* The scalar factors of the elementary reflectors which
* represent the orthogonal matrix Z (see Further Details).
*
* WORK (workspace/output) REAL 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,M,P).
* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
* where NB1 is the optimal blocksize for the RQ factorization
* of an M-by-N matrix, NB2 is the optimal blocksize for the
* QR factorization of a P-by-N matrix, and NB3 is the optimal
* blocksize for a call of SORMRQ.
*
* 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 INF0= -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 - taua * v * v'
*
* where taua is a real scalar, and v is a real vector with
* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
* A(m-k+i,1:n-k+i-1), and taua in TAUA(i).
* To form Q explicitly, use LAPACK subroutine SORGRQ.
* To use Q to update another matrix, use LAPACK subroutine SORMRQ.
*
* The matrix Z is represented as a product of elementary reflectors
*
* Z = H(1) H(2) . . . H(k), where k = min(p,n).
*
* Each H(i) has the form
*
* H(i) = I - taub * v * v'
*
* where taub is a real scalar, and v is a real vector with
* v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),
* and taub in TAUB(i).
* To form Z explicitly, use LAPACK subroutine SORGQR.
* To use Z to update another matrix, use LAPACK subroutine SORMQR.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3
* ..
* .. External Subroutines ..
EXTERNAL SGEQRF, SGERQF, SORMRQ, XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC INT, MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
NB1 = ILAENV( 1, 'SGERQF', ' ', M, N, -1, -1 )
NB2 = ILAENV( 1, 'SGEQRF', ' ', P, N, -1, -1 )
NB3 = ILAENV( 1, 'SORMRQ', ' ', M, N, P, -1 )
NB = MAX( NB1, NB2, NB3 )
LWKOPT = MAX( N, M, P)*NB
WORK( 1 ) = LWKOPT
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( P.LT.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
INFO = -8
ELSE IF( LWORK.LT.MAX( 1, M, P, N ) .AND. .NOT.LQUERY ) THEN
INFO = -11
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGGRQF', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* RQ factorization of M-by-N matrix A: A = R*Q
*
CALL SGERQF( M, N, A, LDA, TAUA, WORK, LWORK, INFO )
LOPT = WORK( 1 )
*
* Update B := B*Q'
*
CALL SORMRQ( 'Right', 'Transpose', P, N, MIN( M, N ),
$ A( MAX( 1, M-N+1 ), 1 ), LDA, TAUA, B, LDB, WORK,
$ LWORK, INFO )
LOPT = MAX( LOPT, INT( WORK( 1 ) ) )
*
* QR factorization of P-by-N matrix B: B = Z*T
*
CALL SGEQRF( P, N, B, LDB, TAUB, WORK, LWORK, INFO )
WORK( 1 ) = MAX( LOPT, INT( WORK( 1 ) ) )
*
RETURN
*
* End of SGGRQF
*
END
SUBROUTINE SGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B,
$ LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK,
$ IWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBQ, JOBU, JOBV
INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL A( LDA, * ), ALPHA( * ), B( LDB, * ),
$ BETA( * ), Q( LDQ, * ), U( LDU, * ),
$ V( LDV, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGGSVD computes the generalized singular value decomposition (GSVD)
* of an M-by-N real matrix A and P-by-N real matrix B:
*
* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R )
*
* where U, V and Q are orthogonal matrices, and Z' is the transpose
* of Z. Let K+L = the effective numerical rank of the matrix (A',B')',
* then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and
* D2 are M-by-(K+L) and P-by-(K+L) "diagonal" matrices and of the
* following structures, respectively:
*
* If M-K-L >= 0,
*
* K L
* D1 = K ( I 0 )
* L ( 0 C )
* M-K-L ( 0 0 )
*
* K L
* D2 = L ( 0 S )
* P-L ( 0 0 )
*
* N-K-L K L
* ( 0 R ) = K ( 0 R11 R12 )
* L ( 0 0 R22 )
*
* where
*
* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),
* S = diag( BETA(K+1), ... , BETA(K+L) ),
* C**2 + S**2 = I.
*
* R is stored in A(1:K+L,N-K-L+1:N) on exit.
*
* If M-K-L < 0,
*
* K M-K K+L-M
* D1 = K ( I 0 0 )
* M-K ( 0 C 0 )
*
* K M-K K+L-M
* D2 = M-K ( 0 S 0 )
* K+L-M ( 0 0 I )
* P-L ( 0 0 0 )
*
* N-K-L K M-K K+L-M
* ( 0 R ) = K ( 0 R11 R12 R13 )
* M-K ( 0 0 R22 R23 )
* K+L-M ( 0 0 0 R33 )
*
* where
*
* C = diag( ALPHA(K+1), ... , ALPHA(M) ),
* S = diag( BETA(K+1), ... , BETA(M) ),
* C**2 + S**2 = I.
*
* (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored
* ( 0 R22 R23 )
* in B(M-K+1:L,N+M-K-L+1:N) on exit.
*
* The routine computes C, S, R, and optionally the orthogonal
* transformation matrices U, V and Q.
*
* In particular, if B is an N-by-N nonsingular matrix, then the GSVD of
* A and B implicitly gives the SVD of A*inv(B):
* A*inv(B) = U*(D1*inv(D2))*V'.
* If ( A',B')' has orthonormal columns, then the GSVD of A and B is
* also equal to the CS decomposition of A and B. Furthermore, the GSVD
* can be used to derive the solution of the eigenvalue problem:
* A'*A x = lambda* B'*B x.
* In some literature, the GSVD of A and B is presented in the form
* U'*A*X = ( 0 D1 ), V'*B*X = ( 0 D2 )
* where U and V are orthogonal and X is nonsingular, D1 and D2 are
* ``diagonal''. The former GSVD form can be converted to the latter
* form by taking the nonsingular matrix X as
*
* X = Q*( I 0 )
* ( 0 inv(R) ).
*
* Arguments
* =========
*
* JOBU (input) CHARACTER*1
* = 'U': Orthogonal matrix U is computed;
* = 'N': U is not computed.
*
* JOBV (input) CHARACTER*1
* = 'V': Orthogonal matrix V is computed;
* = 'N': V is not computed.
*
* JOBQ (input) CHARACTER*1
* = 'Q': Orthogonal matrix Q is computed;
* = 'N': Q is not computed.
*
* M (input) INTEGER
* The number of rows of the matrix A. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrices A and B. N >= 0.
*
* P (input) INTEGER
* The number of rows of the matrix B. P >= 0.
*
* K (output) INTEGER
* L (output) INTEGER
* On exit, K and L specify the dimension of the subblocks
* described in the Purpose section.
* K + L = effective numerical rank of (A',B')'.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, A contains the triangular matrix R, or part of R.
* See Purpose for details.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input/output) REAL array, dimension (LDB,N)
* On entry, the P-by-N matrix B.
* On exit, B contains the triangular matrix R if M-K-L < 0.
* See Purpose for details.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,P).
*
* ALPHA (output) REAL array, dimension (N)
* BETA (output) REAL array, dimension (N)
* On exit, ALPHA and BETA contain the generalized singular
* value pairs of A and B;
* ALPHA(1:K) = 1,
* BETA(1:K) = 0,
* and if M-K-L >= 0,
* ALPHA(K+1:K+L) = C,
* BETA(K+1:K+L) = S,
* or if M-K-L < 0,
* ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0
* BETA(K+1:M) =S, BETA(M+1:K+L) =1
* and
* ALPHA(K+L+1:N) = 0
* BETA(K+L+1:N) = 0
*
* U (output) REAL array, dimension (LDU,M)
* If JOBU = 'U', U contains the M-by-M orthogonal matrix U.
* If JOBU = 'N', U is not referenced.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= max(1,M) if
* JOBU = 'U'; LDU >= 1 otherwise.
*
* V (output) REAL array, dimension (LDV,P)
* If JOBV = 'V', V contains the P-by-P orthogonal matrix V.
* If JOBV = 'N', V is not referenced.
*
* LDV (input) INTEGER
* The leading dimension of the array V. LDV >= max(1,P) if
* JOBV = 'V'; LDV >= 1 otherwise.
*
* Q (output) REAL array, dimension (LDQ,N)
* If JOBQ = 'Q', Q contains the N-by-N orthogonal matrix Q.
* If JOBQ = 'N', Q is not referenced.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N) if
* JOBQ = 'Q'; LDQ >= 1 otherwise.
*
* WORK (workspace) REAL array,
* dimension (max(3*N,M,P)+N)
*
* IWORK (workspace/output) INTEGER array, dimension (N)
* On exit, IWORK stores the sorting information. More
* precisely, the following loop will sort ALPHA
* for I = K+1, min(M,K+L)
* swap ALPHA(I) and ALPHA(IWORK(I))
* endfor
* such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, the Jacobi-type procedure failed to
* converge. For further details, see subroutine STGSJA.
*
* Internal Parameters
* ===================
*
* TOLA REAL
* TOLB REAL
* TOLA and TOLB are the thresholds to determine the effective
* rank of (A',B')'. Generally, they are set to
* TOLA = MAX(M,N)*norm(A)*MACHEPS,
* TOLB = MAX(P,N)*norm(B)*MACHEPS.
* The size of TOLA and TOLB may affect the size of backward
* errors of the decomposition.
*
* Further Details
* ===============
*
* 2-96 Based on modifications by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL WANTQ, WANTU, WANTV
INTEGER I, IBND, ISUB, J, NCYCLE
REAL ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANGE
EXTERNAL LSAME, SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGGSVP, STGSJA, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
WANTU = LSAME( JOBU, 'U' )
WANTV = LSAME( JOBV, 'V' )
WANTQ = LSAME( JOBQ, 'Q' )
*
INFO = 0
IF( .NOT.( WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN
INFO = -2
ELSE IF( .NOT.( WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN
INFO = -3
ELSE IF( M.LT.0 ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( P.LT.0 ) THEN
INFO = -6
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -10
ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
INFO = -12
ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN
INFO = -16
ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN
INFO = -18
ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
INFO = -20
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGGSVD', -INFO )
RETURN
END IF
*
* Compute the Frobenius norm of matrices A and B
*
ANORM = SLANGE( '1', M, N, A, LDA, WORK )
BNORM = SLANGE( '1', P, N, B, LDB, WORK )
*
* Get machine precision and set up threshold for determining
* the effective numerical rank of the matrices A and B.
*
ULP = SLAMCH( 'Precision' )
UNFL = SLAMCH( 'Safe Minimum' )
TOLA = MAX( M, N )*MAX( ANORM, UNFL )*ULP
TOLB = MAX( P, N )*MAX( BNORM, UNFL )*ULP
*
* Preprocessing
*
CALL SGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA,
$ TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, WORK,
$ WORK( N+1 ), INFO )
*
* Compute the GSVD of two upper "triangular" matrices
*
CALL STGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, LDB,
$ TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ,
$ WORK, NCYCLE, INFO )
*
* Sort the singular values and store the pivot indices in IWORK
* Copy ALPHA to WORK, then sort ALPHA in WORK
*
CALL SCOPY( N, ALPHA, 1, WORK, 1 )
IBND = MIN( L, M-K )
DO 20 I = 1, IBND
*
* Scan for largest ALPHA(K+I)
*
ISUB = I
SMAX = WORK( K+I )
DO 10 J = I + 1, IBND
TEMP = WORK( K+J )
IF( TEMP.GT.SMAX ) THEN
ISUB = J
SMAX = TEMP
END IF
10 CONTINUE
IF( ISUB.NE.I ) THEN
WORK( K+ISUB ) = WORK( K+I )
WORK( K+I ) = SMAX
IWORK( K+I ) = K + ISUB
ELSE
IWORK( K+I ) = K + I
END IF
20 CONTINUE
*
RETURN
*
* End of SGGSVD
*
END
SUBROUTINE SGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB,
$ TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ,
$ IWORK, TAU, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBQ, JOBU, JOBV
INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P
REAL TOLA, TOLB
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
$ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGGSVP computes orthogonal matrices U, V and Q such that
*
* N-K-L K L
* U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0;
* L ( 0 0 A23 )
* M-K-L ( 0 0 0 )
*
* N-K-L K L
* = K ( 0 A12 A13 ) if M-K-L < 0;
* M-K ( 0 0 A23 )
*
* N-K-L K L
* V'*B*Q = L ( 0 0 B13 )
* P-L ( 0 0 0 )
*
* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
* otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective
* numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the
* transpose of Z.
*
* This decomposition is the preprocessing step for computing the
* Generalized Singular Value Decomposition (GSVD), see subroutine
* SGGSVD.
*
* Arguments
* =========
*
* JOBU (input) CHARACTER*1
* = 'U': Orthogonal matrix U is computed;
* = 'N': U is not computed.
*
* JOBV (input) CHARACTER*1
* = 'V': Orthogonal matrix V is computed;
* = 'N': V is not computed.
*
* JOBQ (input) CHARACTER*1
* = 'Q': Orthogonal matrix Q is computed;
* = 'N': Q is not computed.
*
* M (input) INTEGER
* The number of rows of the matrix A. M >= 0.
*
* P (input) INTEGER
* The number of rows of the matrix B. P >= 0.
*
* N (input) INTEGER
* The number of columns of the matrices A and B. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, A contains the triangular (or trapezoidal) matrix
* described in the Purpose section.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input/output) REAL array, dimension (LDB,N)
* On entry, the P-by-N matrix B.
* On exit, B contains the triangular matrix described in
* the Purpose section.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,P).
*
* TOLA (input) REAL
* TOLB (input) REAL
* TOLA and TOLB are the thresholds to determine the effective
* numerical rank of matrix B and a subblock of A. Generally,
* they are set to
* TOLA = MAX(M,N)*norm(A)*MACHEPS,
* TOLB = MAX(P,N)*norm(B)*MACHEPS.
* The size of TOLA and TOLB may affect the size of backward
* errors of the decomposition.
*
* K (output) INTEGER
* L (output) INTEGER
* On exit, K and L specify the dimension of the subblocks
* described in Purpose.
* K + L = effective numerical rank of (A',B')'.
*
* U (output) REAL array, dimension (LDU,M)
* If JOBU = 'U', U contains the orthogonal matrix U.
* If JOBU = 'N', U is not referenced.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= max(1,M) if
* JOBU = 'U'; LDU >= 1 otherwise.
*
* V (output) REAL array, dimension (LDV,M)
* If JOBV = 'V', V contains the orthogonal matrix V.
* If JOBV = 'N', V is not referenced.
*
* LDV (input) INTEGER
* The leading dimension of the array V. LDV >= max(1,P) if
* JOBV = 'V'; LDV >= 1 otherwise.
*
* Q (output) REAL array, dimension (LDQ,N)
* If JOBQ = 'Q', Q contains the orthogonal matrix Q.
* If JOBQ = 'N', Q is not referenced.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N) if
* JOBQ = 'Q'; LDQ >= 1 otherwise.
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* TAU (workspace) REAL array, dimension (N)
*
* WORK (workspace) REAL array, dimension (max(3*N,M,P))
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
*
* Further Details
* ===============
*
* The subroutine uses LAPACK subroutine SGEQPF for the QR factorization
* with column pivoting to detect the effective numerical rank of the
* a matrix. It may be replaced by a better rank determination strategy.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL FORWRD, WANTQ, WANTU, WANTV
INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SGEQPF, SGEQR2, SGERQ2, SLACPY, SLAPMT, SLASET,
$ SORG2R, SORM2R, SORMR2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
WANTU = LSAME( JOBU, 'U' )
WANTV = LSAME( JOBV, 'V' )
WANTQ = LSAME( JOBQ, 'Q' )
FORWRD = .TRUE.
*
INFO = 0
IF( .NOT.( WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN
INFO = -2
ELSE IF( .NOT.( WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN
INFO = -3
ELSE IF( M.LT.0 ) THEN
INFO = -4
ELSE IF( P.LT.0 ) THEN
INFO = -5
ELSE IF( N.LT.0 ) THEN
INFO = -6
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -8
ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
INFO = -10
ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN
INFO = -16
ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN
INFO = -18
ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
INFO = -20
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGGSVP', -INFO )
RETURN
END IF
*
* QR with column pivoting of B: B*P = V*( S11 S12 )
* ( 0 0 )
*
DO 10 I = 1, N
IWORK( I ) = 0
10 CONTINUE
CALL SGEQPF( P, N, B, LDB, IWORK, TAU, WORK, INFO )
*
* Update A := A*P
*
CALL SLAPMT( FORWRD, M, N, A, LDA, IWORK )
*
* Determine the effective rank of matrix B.
*
L = 0
DO 20 I = 1, MIN( P, N )
IF( ABS( B( I, I ) ).GT.TOLB )
$ L = L + 1
20 CONTINUE
*
IF( WANTV ) THEN
*
* Copy the details of V, and form V.
*
CALL SLASET( 'Full', P, P, ZERO, ZERO, V, LDV )
IF( P.GT.1 )
$ CALL SLACPY( 'Lower', P-1, N, B( 2, 1 ), LDB, V( 2, 1 ),
$ LDV )
CALL SORG2R( P, P, MIN( P, N ), V, LDV, TAU, WORK, INFO )
END IF
*
* Clean up B
*
DO 40 J = 1, L - 1
DO 30 I = J + 1, L
B( I, J ) = ZERO
30 CONTINUE
40 CONTINUE
IF( P.GT.L )
$ CALL SLASET( 'Full', P-L, N, ZERO, ZERO, B( L+1, 1 ), LDB )
*
IF( WANTQ ) THEN
*
* Set Q = I and Update Q := Q*P
*
CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
CALL SLAPMT( FORWRD, N, N, Q, LDQ, IWORK )
END IF
*
IF( P.GE.L .AND. N.NE.L ) THEN
*
* RQ factorization of (S11 S12): ( S11 S12 ) = ( 0 S12 )*Z
*
CALL SGERQ2( L, N, B, LDB, TAU, WORK, INFO )
*
* Update A := A*Z'
*
CALL SORMR2( 'Right', 'Transpose', M, N, L, B, LDB, TAU, A,
$ LDA, WORK, INFO )
*
IF( WANTQ ) THEN
*
* Update Q := Q*Z'
*
CALL SORMR2( 'Right', 'Transpose', N, N, L, B, LDB, TAU, Q,
$ LDQ, WORK, INFO )
END IF
*
* Clean up B
*
CALL SLASET( 'Full', L, N-L, ZERO, ZERO, B, LDB )
DO 60 J = N - L + 1, N
DO 50 I = J - N + L + 1, L
B( I, J ) = ZERO
50 CONTINUE
60 CONTINUE
*
END IF
*
* Let N-L L
* A = ( A11 A12 ) M,
*
* then the following does the complete QR decomposition of A11:
*
* A11 = U*( 0 T12 )*P1'
* ( 0 0 )
*
DO 70 I = 1, N - L
IWORK( I ) = 0
70 CONTINUE
CALL SGEQPF( M, N-L, A, LDA, IWORK, TAU, WORK, INFO )
*
* Determine the effective rank of A11
*
K = 0
DO 80 I = 1, MIN( M, N-L )
IF( ABS( A( I, I ) ).GT.TOLA )
$ K = K + 1
80 CONTINUE
*
* Update A12 := U'*A12, where A12 = A( 1:M, N-L+1:N )
*
CALL SORM2R( 'Left', 'Transpose', M, L, MIN( M, N-L ), A, LDA,
$ TAU, A( 1, N-L+1 ), LDA, WORK, INFO )
*
IF( WANTU ) THEN
*
* Copy the details of U, and form U
*
CALL SLASET( 'Full', M, M, ZERO, ZERO, U, LDU )
IF( M.GT.1 )
$ CALL SLACPY( 'Lower', M-1, N-L, A( 2, 1 ), LDA, U( 2, 1 ),
$ LDU )
CALL SORG2R( M, M, MIN( M, N-L ), U, LDU, TAU, WORK, INFO )
END IF
*
IF( WANTQ ) THEN
*
* Update Q( 1:N, 1:N-L ) = Q( 1:N, 1:N-L )*P1
*
CALL SLAPMT( FORWRD, N, N-L, Q, LDQ, IWORK )
END IF
*
* Clean up A: set the strictly lower triangular part of
* A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0.
*
DO 100 J = 1, K - 1
DO 90 I = J + 1, K
A( I, J ) = ZERO
90 CONTINUE
100 CONTINUE
IF( M.GT.K )
$ CALL SLASET( 'Full', M-K, N-L, ZERO, ZERO, A( K+1, 1 ), LDA )
*
IF( N-L.GT.K ) THEN
*
* RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1
*
CALL SGERQ2( K, N-L, A, LDA, TAU, WORK, INFO )
*
IF( WANTQ ) THEN
*
* Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1'
*
CALL SORMR2( 'Right', 'Transpose', N, N-L, K, A, LDA, TAU,
$ Q, LDQ, WORK, INFO )
END IF
*
* Clean up A
*
CALL SLASET( 'Full', K, N-L-K, ZERO, ZERO, A, LDA )
DO 120 J = N - L - K + 1, N - L
DO 110 I = J - N + L + K + 1, K
A( I, J ) = ZERO
110 CONTINUE
120 CONTINUE
*
END IF
*
IF( M.GT.K ) THEN
*
* QR factorization of A( K+1:M,N-L+1:N )
*
CALL SGEQR2( M-K, L, A( K+1, N-L+1 ), LDA, TAU, WORK, INFO )
*
IF( WANTU ) THEN
*
* Update U(:,K+1:M) := U(:,K+1:M)*U1
*
CALL SORM2R( 'Right', 'No transpose', M, M-K, MIN( M-K, L ),
$ A( K+1, N-L+1 ), LDA, TAU, U( 1, K+1 ), LDU,
$ WORK, INFO )
END IF
*
* Clean up
*
DO 140 J = N - L + 1, N
DO 130 I = J - N + K + L + 1, M
A( I, J ) = ZERO
130 CONTINUE
140 CONTINUE
*
END IF
*
RETURN
*
* End of SGGSVP
*
END
SUBROUTINE SGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND,
$ WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER INFO, N
REAL ANORM, RCOND
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), IWORK( * )
REAL D( * ), DL( * ), DU( * ), DU2( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGTCON estimates the reciprocal of the condition number of a real
* tridiagonal matrix A using the LU factorization as computed by
* SGTTRF.
*
* An estimate is obtained for norm(inv(A)), and the reciprocal of the
* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies whether the 1-norm condition number or the
* infinity-norm condition number is required:
* = '1' or 'O': 1-norm;
* = 'I': Infinity-norm.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* DL (input) REAL array, dimension (N-1)
* The (n-1) multipliers that define the matrix L from the
* LU factorization of A as computed by SGTTRF.
*
* D (input) REAL array, dimension (N)
* The n diagonal elements of the upper triangular matrix U from
* the LU factorization of A.
*
* DU (input) REAL array, dimension (N-1)
* The (n-1) elements of the first superdiagonal of U.
*
* DU2 (input) REAL array, dimension (N-2)
* The (n-2) elements of the second superdiagonal of U.
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices; for 1 <= i <= n, row i of the matrix was
* interchanged with row IPIV(i). IPIV(i) will always be either
* i or i+1; IPIV(i) = i indicates a row interchange was not
* required.
*
* ANORM (input) REAL
* If NORM = '1' or 'O', the 1-norm of the original matrix A.
* If NORM = 'I', the infinity-norm of the original matrix A.
*
* RCOND (output) REAL
* The reciprocal of the condition number of the matrix A,
* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
* estimate of the 1-norm of inv(A) computed in this routine.
*
* WORK (workspace) REAL array, dimension (2*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL ONENRM
INTEGER I, KASE, KASE1
REAL AINVNM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SGTTRS, SLACN2, XERBLA
* ..
* .. Executable Statements ..
*
* Test the input arguments.
*
INFO = 0
ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ANORM.LT.ZERO ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGTCON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
RCOND = ZERO
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
ELSE IF( ANORM.EQ.ZERO ) THEN
RETURN
END IF
*
* Check that D(1:N) is non-zero.
*
DO 10 I = 1, N
IF( D( I ).EQ.ZERO )
$ RETURN
10 CONTINUE
*
AINVNM = ZERO
IF( ONENRM ) THEN
KASE1 = 1
ELSE
KASE1 = 2
END IF
KASE = 0
20 CONTINUE
CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.KASE1 ) THEN
*
* Multiply by inv(U)*inv(L).
*
CALL SGTTRS( 'No transpose', N, 1, DL, D, DU, DU2, IPIV,
$ WORK, N, INFO )
ELSE
*
* Multiply by inv(L')*inv(U').
*
CALL SGTTRS( 'Transpose', N, 1, DL, D, DU, DU2, IPIV, WORK,
$ N, INFO )
END IF
GO TO 20
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / AINVNM ) / ANORM
*
RETURN
*
* End of SGTCON
*
END
SUBROUTINE SGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2,
$ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER INFO, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), IWORK( * )
REAL B( LDB, * ), BERR( * ), D( * ), DF( * ),
$ DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ),
$ FERR( * ), WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* SGTRFS improves the computed solution to a system of linear
* equations when the coefficient matrix is tridiagonal, and provides
* error bounds and backward error estimates for the solution.
*
* 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**H * 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.
*
* DL (input) REAL array, dimension (N-1)
* The (n-1) subdiagonal elements of A.
*
* D (input) REAL array, dimension (N)
* The diagonal elements of A.
*
* DU (input) REAL array, dimension (N-1)
* The (n-1) superdiagonal elements of A.
*
* DLF (input) REAL array, dimension (N-1)
* The (n-1) multipliers that define the matrix L from the
* LU factorization of A as computed by SGTTRF.
*
* DF (input) REAL array, dimension (N)
* The n diagonal elements of the upper triangular matrix U from
* the LU factorization of A.
*
* DUF (input) REAL array, dimension (N-1)
* The (n-1) elements of the first superdiagonal of U.
*
* DU2 (input) REAL array, dimension (N-2)
* The (n-2) elements of the second superdiagonal of U.
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices; for 1 <= i <= n, row i of the matrix was
* interchanged with row IPIV(i). IPIV(i) will always be either
* i or i+1; IPIV(i) = i indicates a row interchange was not
* required.
*
* B (input) REAL array, dimension (LDB,NRHS)
* The right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input/output) REAL array, dimension (LDX,NRHS)
* On entry, the solution matrix X, as computed by SGTTRS.
* On exit, the improved solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* FERR (output) REAL array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) REAL array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Internal Parameters
* ===================
*
* ITMAX is the maximum number of steps of iterative refinement.
*
* =====================================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 5 )
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
REAL TWO
PARAMETER ( TWO = 2.0E+0 )
REAL THREE
PARAMETER ( THREE = 3.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN
CHARACTER TRANSN, TRANST
INTEGER COUNT, I, J, KASE, NZ
REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, SGTTRS, SLACN2, SLAGTM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH
EXTERNAL LSAME, SLAMCH
* ..
* .. 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( LDB.LT.MAX( 1, N ) ) THEN
INFO = -13
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -15
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGTRFS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
DO 10 J = 1, NRHS
FERR( J ) = ZERO
BERR( J ) = ZERO
10 CONTINUE
RETURN
END IF
*
IF( NOTRAN ) THEN
TRANSN = 'N'
TRANST = 'T'
ELSE
TRANSN = 'T'
TRANST = 'N'
END IF
*
* NZ = maximum number of nonzero elements in each row of A, plus 1
*
NZ = 4
EPS = SLAMCH( 'Epsilon' )
SAFMIN = SLAMCH( 'Safe minimum' )
SAFE1 = NZ*SAFMIN
SAFE2 = SAFE1 / EPS
*
* Do for each right hand side
*
DO 110 J = 1, NRHS
*
COUNT = 1
LSTRES = THREE
20 CONTINUE
*
* Loop until stopping criterion is satisfied.
*
* Compute residual R = B - op(A) * X,
* where op(A) = A, A**T, or A**H, depending on TRANS.
*
CALL SCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
CALL SLAGTM( TRANS, N, 1, -ONE, DL, D, DU, X( 1, J ), LDX, ONE,
$ WORK( N+1 ), N )
*
* Compute abs(op(A))*abs(x) + abs(b) for use in the backward
* error bound.
*
IF( NOTRAN ) THEN
IF( N.EQ.1 ) THEN
WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) )
ELSE
WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) ) +
$ ABS( DU( 1 )*X( 2, J ) )
DO 30 I = 2, N - 1
WORK( I ) = ABS( B( I, J ) ) +
$ ABS( DL( I-1 )*X( I-1, J ) ) +
$ ABS( D( I )*X( I, J ) ) +
$ ABS( DU( I )*X( I+1, J ) )
30 CONTINUE
WORK( N ) = ABS( B( N, J ) ) +
$ ABS( DL( N-1 )*X( N-1, J ) ) +
$ ABS( D( N )*X( N, J ) )
END IF
ELSE
IF( N.EQ.1 ) THEN
WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) )
ELSE
WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) ) +
$ ABS( DL( 1 )*X( 2, J ) )
DO 40 I = 2, N - 1
WORK( I ) = ABS( B( I, J ) ) +
$ ABS( DU( I-1 )*X( I-1, J ) ) +
$ ABS( D( I )*X( I, J ) ) +
$ ABS( DL( I )*X( I+1, J ) )
40 CONTINUE
WORK( N ) = ABS( B( N, J ) ) +
$ ABS( DU( N-1 )*X( N-1, J ) ) +
$ ABS( D( N )*X( N, J ) )
END IF
END IF
*
* Compute componentwise relative backward error from formula
*
* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
*
* where abs(Z) is the componentwise absolute value of the matrix
* or vector Z. If the i-th component of the denominator is less
* than SAFE2, then SAFE1 is added to the i-th components of the
* numerator and denominator before dividing.
*
S = ZERO
DO 50 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
ELSE
S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
$ ( WORK( I )+SAFE1 ) )
END IF
50 CONTINUE
BERR( J ) = S
*
* Test stopping criterion. Continue iterating if
* 1) The residual BERR(J) is larger than machine epsilon, and
* 2) BERR(J) decreased by at least a factor of 2 during the
* last iteration, and
* 3) At most ITMAX iterations tried.
*
IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
$ COUNT.LE.ITMAX ) THEN
*
* Update solution and try again.
*
CALL SGTTRS( TRANS, N, 1, DLF, DF, DUF, DU2, IPIV,
$ WORK( N+1 ), N, INFO )
CALL SAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
LSTRES = BERR( J )
COUNT = COUNT + 1
GO TO 20
END IF
*
* Bound error from formula
*
* norm(X - XTRUE) / norm(X) .le. FERR =
* norm( abs(inv(op(A)))*
* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
*
* where
* norm(Z) is the magnitude of the largest component of Z
* inv(op(A)) is the inverse of op(A)
* abs(Z) is the componentwise absolute value of the matrix or
* vector Z
* NZ is the maximum number of nonzeros in any row of A, plus 1
* EPS is machine epsilon
*
* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
* is incremented by SAFE1 if the i-th component of
* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
*
* Use SLACN2 to estimate the infinity-norm of the matrix
* inv(op(A)) * diag(W),
* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
*
DO 60 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
ELSE
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
END IF
60 CONTINUE
*
KASE = 0
70 CONTINUE
CALL SLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
$ KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Multiply by diag(W)*inv(op(A)**T).
*
CALL SGTTRS( TRANST, N, 1, DLF, DF, DUF, DU2, IPIV,
$ WORK( N+1 ), N, INFO )
DO 80 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
80 CONTINUE
ELSE
*
* Multiply by inv(op(A))*diag(W).
*
DO 90 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
90 CONTINUE
CALL SGTTRS( TRANSN, N, 1, DLF, DF, DUF, DU2, IPIV,
$ WORK( N+1 ), N, INFO )
END IF
GO TO 70
END IF
*
* Normalize error.
*
LSTRES = ZERO
DO 100 I = 1, N
LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
100 CONTINUE
IF( LSTRES.NE.ZERO )
$ FERR( J ) = FERR( J ) / LSTRES
*
110 CONTINUE
*
RETURN
*
* End of SGTRFS
*
END
SUBROUTINE SGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
REAL B( LDB, * ), D( * ), DL( * ), DU( * )
* ..
*
* Purpose
* =======
*
* SGTSV solves the equation
*
* A*X = B,
*
* where A is an n by n tridiagonal matrix, by Gaussian elimination with
* partial pivoting.
*
* Note that the equation A'*X = B may be solved by interchanging the
* order of the arguments DU and DL.
*
* Arguments
* =========
*
* 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.
*
* DL (input/output) REAL array, dimension (N-1)
* On entry, DL must contain the (n-1) sub-diagonal elements of
* A.
*
* On exit, DL is overwritten by the (n-2) elements of the
* second super-diagonal of the upper triangular matrix U from
* the LU factorization of A, in DL(1), ..., DL(n-2).
*
* D (input/output) REAL array, dimension (N)
* On entry, D must contain the diagonal elements of A.
*
* On exit, D is overwritten by the n diagonal elements of U.
*
* DU (input/output) REAL array, dimension (N-1)
* On entry, DU must contain the (n-1) super-diagonal elements
* of A.
*
* On exit, DU is overwritten by the (n-1) elements of the first
* super-diagonal of U.
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the N by NRHS matrix of right hand side matrix B.
* On exit, if INFO = 0, the N by NRHS 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
* > 0: if INFO = i, U(i,i) is exactly zero, and the solution
* has not been computed. The factorization has not been
* completed unless i = N.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
REAL FACT, TEMP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( NRHS.LT.0 ) THEN
INFO = -2
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGTSV ', -INFO )
RETURN
END IF
*
IF( N.EQ.0 )
$ RETURN
*
IF( NRHS.EQ.1 ) THEN
DO 10 I = 1, N - 2
IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
*
* No row interchange required
*
IF( D( I ).NE.ZERO ) THEN
FACT = DL( I ) / D( I )
D( I+1 ) = D( I+1 ) - FACT*DU( I )
B( I+1, 1 ) = B( I+1, 1 ) - FACT*B( I, 1 )
ELSE
INFO = I
RETURN
END IF
DL( I ) = ZERO
ELSE
*
* Interchange rows I and I+1
*
FACT = D( I ) / DL( I )
D( I ) = DL( I )
TEMP = D( I+1 )
D( I+1 ) = DU( I ) - FACT*TEMP
DL( I ) = DU( I+1 )
DU( I+1 ) = -FACT*DL( I )
DU( I ) = TEMP
TEMP = B( I, 1 )
B( I, 1 ) = B( I+1, 1 )
B( I+1, 1 ) = TEMP - FACT*B( I+1, 1 )
END IF
10 CONTINUE
IF( N.GT.1 ) THEN
I = N - 1
IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
IF( D( I ).NE.ZERO ) THEN
FACT = DL( I ) / D( I )
D( I+1 ) = D( I+1 ) - FACT*DU( I )
B( I+1, 1 ) = B( I+1, 1 ) - FACT*B( I, 1 )
ELSE
INFO = I
RETURN
END IF
ELSE
FACT = D( I ) / DL( I )
D( I ) = DL( I )
TEMP = D( I+1 )
D( I+1 ) = DU( I ) - FACT*TEMP
DU( I ) = TEMP
TEMP = B( I, 1 )
B( I, 1 ) = B( I+1, 1 )
B( I+1, 1 ) = TEMP - FACT*B( I+1, 1 )
END IF
END IF
IF( D( N ).EQ.ZERO ) THEN
INFO = N
RETURN
END IF
ELSE
DO 40 I = 1, N - 2
IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
*
* No row interchange required
*
IF( D( I ).NE.ZERO ) THEN
FACT = DL( I ) / D( I )
D( I+1 ) = D( I+1 ) - FACT*DU( I )
DO 20 J = 1, NRHS
B( I+1, J ) = B( I+1, J ) - FACT*B( I, J )
20 CONTINUE
ELSE
INFO = I
RETURN
END IF
DL( I ) = ZERO
ELSE
*
* Interchange rows I and I+1
*
FACT = D( I ) / DL( I )
D( I ) = DL( I )
TEMP = D( I+1 )
D( I+1 ) = DU( I ) - FACT*TEMP
DL( I ) = DU( I+1 )
DU( I+1 ) = -FACT*DL( I )
DU( I ) = TEMP
DO 30 J = 1, NRHS
TEMP = B( I, J )
B( I, J ) = B( I+1, J )
B( I+1, J ) = TEMP - FACT*B( I+1, J )
30 CONTINUE
END IF
40 CONTINUE
IF( N.GT.1 ) THEN
I = N - 1
IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
IF( D( I ).NE.ZERO ) THEN
FACT = DL( I ) / D( I )
D( I+1 ) = D( I+1 ) - FACT*DU( I )
DO 50 J = 1, NRHS
B( I+1, J ) = B( I+1, J ) - FACT*B( I, J )
50 CONTINUE
ELSE
INFO = I
RETURN
END IF
ELSE
FACT = D( I ) / DL( I )
D( I ) = DL( I )
TEMP = D( I+1 )
D( I+1 ) = DU( I ) - FACT*TEMP
DU( I ) = TEMP
DO 60 J = 1, NRHS
TEMP = B( I, J )
B( I, J ) = B( I+1, J )
B( I+1, J ) = TEMP - FACT*B( I+1, J )
60 CONTINUE
END IF
END IF
IF( D( N ).EQ.ZERO ) THEN
INFO = N
RETURN
END IF
END IF
*
* Back solve with the matrix U from the factorization.
*
IF( NRHS.LE.2 ) THEN
J = 1
70 CONTINUE
B( N, J ) = B( N, J ) / D( N )
IF( N.GT.1 )
$ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / D( N-1 )
DO 80 I = N - 2, 1, -1
B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DL( I )*
$ B( I+2, J ) ) / D( I )
80 CONTINUE
IF( J.LT.NRHS ) THEN
J = J + 1
GO TO 70
END IF
ELSE
DO 100 J = 1, NRHS
B( N, J ) = B( N, J ) / D( N )
IF( N.GT.1 )
$ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) /
$ D( N-1 )
DO 90 I = N - 2, 1, -1
B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DL( I )*
$ B( I+2, J ) ) / D( I )
90 CONTINUE
100 CONTINUE
END IF
*
RETURN
*
* End of SGTSV
*
END
SUBROUTINE SGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF,
$ DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR,
$ WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER FACT, TRANS
INTEGER INFO, LDB, LDX, N, NRHS
REAL RCOND
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), IWORK( * )
REAL B( LDB, * ), BERR( * ), D( * ), DF( * ),
$ DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ),
$ FERR( * ), WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* SGTSVX uses the LU factorization to compute the solution to a real
* system of linear equations A * X = B or A**T * X = B,
* where A is a tridiagonal matrix of order N and X and B are N-by-NRHS
* matrices.
*
* Error bounds on the solution and a condition estimate are also
* provided.
*
* Description
* ===========
*
* The following steps are performed:
*
* 1. If FACT = 'N', the LU decomposition is used to factor the matrix A
* as A = L * U, where L is a product of permutation and unit lower
* bidiagonal matrices and U is upper triangular with nonzeros in
* only the main diagonal and first two superdiagonals.
*
* 2. If some U(i,i)=0, so that U is exactly singular, then the routine
* returns with INFO = i. Otherwise, the factored form of A is used
* to estimate the condition number of the matrix A. If the
* reciprocal of the condition number is less than machine precision,
* INFO = N+1 is returned as a warning, but the routine still goes on
* to solve for X and compute error bounds as described below.
*
* 3. The system of equations is solved for X using the factored form
* of A.
*
* 4. Iterative refinement is applied to improve the computed solution
* matrix and calculate error bounds and backward error estimates
* for it.
*
* Arguments
* =========
*
* FACT (input) CHARACTER*1
* Specifies whether or not the factored form of A has been
* supplied on entry.
* = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored
* form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV
* will not be modified.
* = 'N': The matrix will be copied to DLF, DF, and DUF
* and factored.
*
* 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**H * 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.
*
* DL (input) REAL array, dimension (N-1)
* The (n-1) subdiagonal elements of A.
*
* D (input) REAL array, dimension (N)
* The n diagonal elements of A.
*
* DU (input) REAL array, dimension (N-1)
* The (n-1) superdiagonal elements of A.
*
* DLF (input or output) REAL array, dimension (N-1)
* If FACT = 'F', then DLF is an input argument and on entry
* contains the (n-1) multipliers that define the matrix L from
* the LU factorization of A as computed by SGTTRF.
*
* If FACT = 'N', then DLF is an output argument and on exit
* contains the (n-1) multipliers that define the matrix L from
* the LU factorization of A.
*
* DF (input or output) REAL array, dimension (N)
* If FACT = 'F', then DF is an input argument and on entry
* contains the n diagonal elements of the upper triangular
* matrix U from the LU factorization of A.
*
* If FACT = 'N', then DF is an output argument and on exit
* contains the n diagonal elements of the upper triangular
* matrix U from the LU factorization of A.
*
* DUF (input or output) REAL array, dimension (N-1)
* If FACT = 'F', then DUF is an input argument and on entry
* contains the (n-1) elements of the first superdiagonal of U.
*
* If FACT = 'N', then DUF is an output argument and on exit
* contains the (n-1) elements of the first superdiagonal of U.
*
* DU2 (input or output) REAL array, dimension (N-2)
* If FACT = 'F', then DU2 is an input argument and on entry
* contains the (n-2) elements of the second superdiagonal of
* U.
*
* If FACT = 'N', then DU2 is an output argument and on exit
* contains the (n-2) elements of the second superdiagonal of
* U.
*
* IPIV (input or output) INTEGER array, dimension (N)
* If FACT = 'F', then IPIV is an input argument and on entry
* contains the pivot indices from the LU factorization of A as
* computed by SGTTRF.
*
* If FACT = 'N', then IPIV is an output argument and on exit
* contains the pivot indices from the LU factorization of A;
* row i of the matrix was interchanged with row IPIV(i).
* IPIV(i) will always be either i or i+1; IPIV(i) = i indicates
* a row interchange was not required.
*
* B (input) REAL array, dimension (LDB,NRHS)
* The N-by-NRHS right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (output) REAL array, dimension (LDX,NRHS)
* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* RCOND (output) REAL
* The estimate of the reciprocal condition number of the matrix
* A. If RCOND is less than the machine precision (in
* particular, if RCOND = 0), the matrix is singular to working
* precision. This condition is indicated by a return code of
* INFO > 0.
*
* FERR (output) REAL array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) REAL array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, and i is
* <= N: U(i,i) is exactly zero. The factorization
* has not been completed unless i = N, but the
* factor U is exactly singular, so the solution
* and error bounds could not be computed.
* RCOND = 0 is returned.
* = N+1: U is nonsingular, but RCOND is less than machine
* precision, meaning that the matrix is singular
* to working precision. Nevertheless, the
* solution and error bounds are computed because
* there are a number of situations where the
* computed solution can be more accurate than the
* value of RCOND would suggest.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOFACT, NOTRAN
CHARACTER NORM
REAL ANORM
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANGT
EXTERNAL LSAME, SLAMCH, SLANGT
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGTCON, SGTRFS, SGTTRF, SGTTRS, SLACPY,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
INFO = 0
NOFACT = LSAME( FACT, 'N' )
NOTRAN = LSAME( TRANS, 'N' )
IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
$ LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.0 ) THEN
INFO = -4
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -14
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -16
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGTSVX', -INFO )
RETURN
END IF
*
IF( NOFACT ) THEN
*
* Compute the LU factorization of A.
*
CALL SCOPY( N, D, 1, DF, 1 )
IF( N.GT.1 ) THEN
CALL SCOPY( N-1, DL, 1, DLF, 1 )
CALL SCOPY( N-1, DU, 1, DUF, 1 )
END IF
CALL SGTTRF( N, DLF, DF, DUF, DU2, IPIV, INFO )
*
* Return if INFO is non-zero.
*
IF( INFO.GT.0 )THEN
RCOND = ZERO
RETURN
END IF
END IF
*
* Compute the norm of the matrix A.
*
IF( NOTRAN ) THEN
NORM = '1'
ELSE
NORM = 'I'
END IF
ANORM = SLANGT( NORM, N, DL, D, DU )
*
* Compute the reciprocal of the condition number of A.
*
CALL SGTCON( NORM, N, DLF, DF, DUF, DU2, IPIV, ANORM, RCOND, WORK,
$ IWORK, INFO )
*
* Compute the solution vectors X.
*
CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
CALL SGTTRS( TRANS, N, NRHS, DLF, DF, DUF, DU2, IPIV, X, LDX,
$ INFO )
*
* Use iterative refinement to improve the computed solutions and
* compute error bounds and backward error estimates for them.
*
CALL SGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV,
$ B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
*
* Set INFO = N+1 if the matrix is singular to working precision.
*
IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
$ INFO = N + 1
*
RETURN
*
* End of SGTSVX
*
END
SUBROUTINE SGTTRF( N, DL, D, DU, DU2, IPIV, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
REAL D( * ), DL( * ), DU( * ), DU2( * )
* ..
*
* Purpose
* =======
*
* SGTTRF computes an LU factorization of a real tridiagonal matrix A
* using elimination with partial pivoting and row interchanges.
*
* The factorization has the form
* A = L * U
* where L is a product of permutation and unit lower bidiagonal
* matrices and U is upper triangular with nonzeros in only the main
* diagonal and first two superdiagonals.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix A.
*
* DL (input/output) REAL array, dimension (N-1)
* On entry, DL must contain the (n-1) sub-diagonal elements of
* A.
*
* On exit, DL is overwritten by the (n-1) multipliers that
* define the matrix L from the LU factorization of A.
*
* D (input/output) REAL array, dimension (N)
* On entry, D must contain the diagonal elements of A.
*
* On exit, D is overwritten by the n diagonal elements of the
* upper triangular matrix U from the LU factorization of A.
*
* DU (input/output) REAL array, dimension (N-1)
* On entry, DU must contain the (n-1) super-diagonal elements
* of A.
*
* On exit, DU is overwritten by the (n-1) elements of the first
* super-diagonal of U.
*
* DU2 (output) REAL array, dimension (N-2)
* On exit, DU2 is overwritten by the (n-2) elements of the
* second super-diagonal of U.
*
* IPIV (output) INTEGER array, dimension (N)
* The pivot indices; for 1 <= i <= n, row i of the matrix was
* interchanged with row IPIV(i). IPIV(i) will always be either
* i or i+1; IPIV(i) = i indicates a row interchange was not
* required.
*
* 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 ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I
REAL FACT, TEMP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
CALL XERBLA( 'SGTTRF', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Initialize IPIV(i) = i and DU2(I) = 0
*
DO 10 I = 1, N
IPIV( I ) = I
10 CONTINUE
DO 20 I = 1, N - 2
DU2( I ) = ZERO
20 CONTINUE
*
DO 30 I = 1, N - 2
IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
*
* No row interchange required, eliminate DL(I)
*
IF( D( I ).NE.ZERO ) THEN
FACT = DL( I ) / D( I )
DL( I ) = FACT
D( I+1 ) = D( I+1 ) - FACT*DU( I )
END IF
ELSE
*
* Interchange rows I and I+1, eliminate DL(I)
*
FACT = D( I ) / DL( I )
D( I ) = DL( I )
DL( I ) = FACT
TEMP = DU( I )
DU( I ) = D( I+1 )
D( I+1 ) = TEMP - FACT*D( I+1 )
DU2( I ) = DU( I+1 )
DU( I+1 ) = -FACT*DU( I+1 )
IPIV( I ) = I + 1
END IF
30 CONTINUE
IF( N.GT.1 ) THEN
I = N - 1
IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
IF( D( I ).NE.ZERO ) THEN
FACT = DL( I ) / D( I )
DL( I ) = FACT
D( I+1 ) = D( I+1 ) - FACT*DU( I )
END IF
ELSE
FACT = D( I ) / DL( I )
D( I ) = DL( I )
DL( I ) = FACT
TEMP = DU( I )
DU( I ) = D( I+1 )
D( I+1 ) = TEMP - FACT*D( I+1 )
IPIV( I ) = I + 1
END IF
END IF
*
* Check for a zero on the diagonal of U.
*
DO 40 I = 1, N
IF( D( I ).EQ.ZERO ) THEN
INFO = I
GO TO 50
END IF
40 CONTINUE
50 CONTINUE
*
RETURN
*
* End of SGTTRF
*
END
SUBROUTINE SGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
REAL B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * )
* ..
*
* Purpose
* =======
*
* SGTTRS solves one of the systems of equations
* A*X = B or A'*X = B,
* with a tridiagonal matrix A using the LU factorization computed
* by SGTTRF.
*
* Arguments
* =========
*
* TRANS (input) CHARACTER*1
* Specifies the form of the system of equations.
* = 'N': A * X = B (No transpose)
* = 'T': A'* X = B (Transpose)
* = 'C': A'* X = B (Conjugate transpose = Transpose)
*
* N (input) INTEGER
* The order of the matrix A.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrix B. NRHS >= 0.
*
* DL (input) REAL array, dimension (N-1)
* The (n-1) multipliers that define the matrix L from the
* LU factorization of A.
*
* D (input) REAL array, dimension (N)
* The n diagonal elements of the upper triangular matrix U from
* the LU factorization of A.
*
* DU (input) REAL array, dimension (N-1)
* The (n-1) elements of the first super-diagonal of U.
*
* DU2 (input) REAL array, dimension (N-2)
* The (n-2) elements of the second super-diagonal of U.
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices; for 1 <= i <= n, row i of the matrix was
* interchanged with row IPIV(i). IPIV(i) will always be either
* i or i+1; IPIV(i) = i indicates a row interchange was not
* required.
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the matrix of right hand side vectors B.
* On exit, B is overwritten by the solution vectors 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
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL NOTRAN
INTEGER ITRANS, J, JB, NB
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. External Subroutines ..
EXTERNAL SGTTS2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
NOTRAN = ( TRANS.EQ.'N' .OR. TRANS.EQ.'n' )
IF( .NOT.NOTRAN .AND. .NOT.( TRANS.EQ.'T' .OR. TRANS.EQ.
$ 't' ) .AND. .NOT.( TRANS.EQ.'C' .OR. TRANS.EQ.'c' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGTTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
* Decode TRANS
*
IF( NOTRAN ) THEN
ITRANS = 0
ELSE
ITRANS = 1
END IF
*
* Determine the number of right-hand sides to solve at a time.
*
IF( NRHS.EQ.1 ) THEN
NB = 1
ELSE
NB = MAX( 1, ILAENV( 1, 'SGTTRS', TRANS, N, NRHS, -1, -1 ) )
END IF
*
IF( NB.GE.NRHS ) THEN
CALL SGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )
ELSE
DO 10 J = 1, NRHS, NB
JB = MIN( NRHS-J+1, NB )
CALL SGTTS2( ITRANS, N, JB, DL, D, DU, DU2, IPIV, B( 1, J ),
$ LDB )
10 CONTINUE
END IF
*
* End of SGTTRS
*
END
SUBROUTINE SGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER ITRANS, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
REAL B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * )
* ..
*
* Purpose
* =======
*
* SGTTS2 solves one of the systems of equations
* A*X = B or A'*X = B,
* with a tridiagonal matrix A using the LU factorization computed
* by SGTTRF.
*
* Arguments
* =========
*
* ITRANS (input) INTEGER
* Specifies the form of the system of equations.
* = 0: A * X = B (No transpose)
* = 1: A'* X = B (Transpose)
* = 2: A'* X = B (Conjugate transpose = Transpose)
*
* N (input) INTEGER
* The order of the matrix A.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrix B. NRHS >= 0.
*
* DL (input) REAL array, dimension (N-1)
* The (n-1) multipliers that define the matrix L from the
* LU factorization of A.
*
* D (input) REAL array, dimension (N)
* The n diagonal elements of the upper triangular matrix U from
* the LU factorization of A.
*
* DU (input) REAL array, dimension (N-1)
* The (n-1) elements of the first super-diagonal of U.
*
* DU2 (input) REAL array, dimension (N-2)
* The (n-2) elements of the second super-diagonal of U.
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices; for 1 <= i <= n, row i of the matrix was
* interchanged with row IPIV(i). IPIV(i) will always be either
* i or i+1; IPIV(i) = i indicates a row interchange was not
* required.
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the matrix of right hand side vectors B.
* On exit, B is overwritten by the solution vectors X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, IP, J
REAL TEMP
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
IF( ITRANS.EQ.0 ) THEN
*
* Solve A*X = B using the LU factorization of A,
* overwriting each right hand side vector with its solution.
*
IF( NRHS.LE.1 ) THEN
J = 1
10 CONTINUE
*
* Solve L*x = b.
*
DO 20 I = 1, N - 1
IP = IPIV( I )
TEMP = B( I+1-IP+I, J ) - DL( I )*B( IP, J )
B( I, J ) = B( IP, J )
B( I+1, J ) = TEMP
20 CONTINUE
*
* Solve U*x = b.
*
B( N, J ) = B( N, J ) / D( N )
IF( N.GT.1 )
$ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) /
$ D( N-1 )
DO 30 I = N - 2, 1, -1
B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )*
$ B( I+2, J ) ) / D( I )
30 CONTINUE
IF( J.LT.NRHS ) THEN
J = J + 1
GO TO 10
END IF
ELSE
DO 60 J = 1, NRHS
*
* Solve L*x = b.
*
DO 40 I = 1, N - 1
IF( IPIV( I ).EQ.I ) THEN
B( I+1, J ) = B( I+1, J ) - DL( I )*B( I, J )
ELSE
TEMP = B( I, J )
B( I, J ) = B( I+1, J )
B( I+1, J ) = TEMP - DL( I )*B( I, J )
END IF
40 CONTINUE
*
* Solve U*x = b.
*
B( N, J ) = B( N, J ) / D( N )
IF( N.GT.1 )
$ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) /
$ D( N-1 )
DO 50 I = N - 2, 1, -1
B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )*
$ B( I+2, J ) ) / D( I )
50 CONTINUE
60 CONTINUE
END IF
ELSE
*
* Solve A' * X = B.
*
IF( NRHS.LE.1 ) THEN
*
* Solve U'*x = b.
*
J = 1
70 CONTINUE
B( 1, J ) = B( 1, J ) / D( 1 )
IF( N.GT.1 )
$ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 )
DO 80 I = 3, N
B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-DU2( I-2 )*
$ B( I-2, J ) ) / D( I )
80 CONTINUE
*
* Solve L'*x = b.
*
DO 90 I = N - 1, 1, -1
IP = IPIV( I )
TEMP = B( I, J ) - DL( I )*B( I+1, J )
B( I, J ) = B( IP, J )
B( IP, J ) = TEMP
90 CONTINUE
IF( J.LT.NRHS ) THEN
J = J + 1
GO TO 70
END IF
*
ELSE
DO 120 J = 1, NRHS
*
* Solve U'*x = b.
*
B( 1, J ) = B( 1, J ) / D( 1 )
IF( N.GT.1 )
$ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 )
DO 100 I = 3, N
B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-
$ DU2( I-2 )*B( I-2, J ) ) / D( I )
100 CONTINUE
DO 110 I = N - 1, 1, -1
IF( IPIV( I ).EQ.I ) THEN
B( I, J ) = B( I, J ) - DL( I )*B( I+1, J )
ELSE
TEMP = B( I+1, J )
B( I+1, J ) = B( I, J ) - DL( I )*TEMP
B( I, J ) = TEMP
END IF
110 CONTINUE
120 CONTINUE
END IF
END IF
*
* End of SGTTS2
*
END
SUBROUTINE SHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT,
$ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK,
$ LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER COMPQ, COMPZ, JOB
INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N
* ..
* .. Array Arguments ..
REAL ALPHAI( * ), ALPHAR( * ), BETA( * ),
$ H( LDH, * ), Q( LDQ, * ), T( LDT, * ),
$ WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SHGEQZ computes the eigenvalues of a real matrix pair (H,T),
* where H is an upper Hessenberg matrix and T is upper triangular,
* using the double-shift QZ method.
* Matrix pairs of this type are produced by the reduction to
* generalized upper Hessenberg form of a real matrix pair (A,B):
*
* A = Q1*H*Z1**T, B = Q1*T*Z1**T,
*
* as computed by SGGHRD.
*
* If JOB='S', then the Hessenberg-triangular pair (H,T) is
* also reduced to generalized Schur form,
*
* H = Q*S*Z**T, T = Q*P*Z**T,
*
* where Q and Z are orthogonal matrices, P is an upper triangular
* matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2
* diagonal blocks.
*
* The 1-by-1 blocks correspond to real eigenvalues of the matrix pair
* (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of
* eigenvalues.
*
* Additionally, the 2-by-2 upper triangular diagonal blocks of P
* corresponding to 2-by-2 blocks of S are reduced to positive diagonal
* form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0,
* P(j,j) > 0, and P(j+1,j+1) > 0.
*
* Optionally, the orthogonal matrix Q from the generalized Schur
* factorization may be postmultiplied into an input matrix Q1, and the
* orthogonal matrix Z may be postmultiplied into an input matrix Z1.
* If Q1 and Z1 are the orthogonal matrices from SGGHRD that reduced
* the matrix pair (A,B) to generalized upper Hessenberg form, then the
* output matrices Q1*Q and Z1*Z are the orthogonal factors from the
* generalized Schur factorization of (A,B):
*
* A = (Q1*Q)*S*(Z1*Z)**T, B = (Q1*Q)*P*(Z1*Z)**T.
*
* To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently,
* of (A,B)) are computed as a pair of values (alpha,beta), where alpha is
* complex and beta real.
* If beta is nonzero, lambda = alpha / beta is an eigenvalue of the
* generalized nonsymmetric eigenvalue problem (GNEP)
* A*x = lambda*B*x
* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the
* alternate form of the GNEP
* mu*A*y = B*y.
* Real eigenvalues can be read directly from the generalized Schur
* form:
* alpha = S(i,i), beta = P(i,i).
*
* Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix
* Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973),
* pp. 241--256.
*
* Arguments
* =========
*
* JOB (input) CHARACTER*1
* = 'E': Compute eigenvalues only;
* = 'S': Compute eigenvalues and the Schur form.
*
* COMPQ (input) CHARACTER*1
* = 'N': Left Schur vectors (Q) are not computed;
* = 'I': Q is initialized to the unit matrix and the matrix Q
* of left Schur vectors of (H,T) is returned;
* = 'V': Q must contain an orthogonal matrix Q1 on entry and
* the product Q1*Q is returned.
*
* COMPZ (input) CHARACTER*1
* = 'N': Right Schur vectors (Z) are not computed;
* = 'I': Z is initialized to the unit matrix and the matrix Z
* of right Schur vectors of (H,T) is returned;
* = 'V': Z must contain an orthogonal matrix Z1 on entry and
* the product Z1*Z is returned.
*
* N (input) INTEGER
* The order of the matrices H, T, Q, and Z. N >= 0.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* ILO and IHI mark the rows and columns of H which are in
* Hessenberg form. It is assumed that A is already upper
* triangular in rows and columns 1:ILO-1 and IHI+1:N.
* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.
*
* H (input/output) REAL array, dimension (LDH, N)
* On entry, the N-by-N upper Hessenberg matrix H.
* On exit, if JOB = 'S', H contains the upper quasi-triangular
* matrix S from the generalized Schur factorization;
* 2-by-2 diagonal blocks (corresponding to complex conjugate
* pairs of eigenvalues) are returned in standard form, with
* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0.
* If JOB = 'E', the diagonal blocks of H match those of S, but
* the rest of H is unspecified.
*
* LDH (input) INTEGER
* The leading dimension of the array H. LDH >= max( 1, N ).
*
* T (input/output) REAL array, dimension (LDT, N)
* On entry, the N-by-N upper triangular matrix T.
* On exit, if JOB = 'S', T contains the upper triangular
* matrix P from the generalized Schur factorization;
* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S
* are reduced to positive diagonal form, i.e., if H(j+1,j) is
* non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and
* T(j+1,j+1) > 0.
* If JOB = 'E', the diagonal blocks of T match those of P, but
* the rest of T is unspecified.
*
* LDT (input) INTEGER
* The leading dimension of the array T. LDT >= max( 1, N ).
*
* ALPHAR (output) REAL array, dimension (N)
* The real parts of each scalar alpha defining an eigenvalue
* of GNEP.
*
* ALPHAI (output) REAL array, dimension (N)
* The imaginary parts of each scalar alpha defining an
* eigenvalue of GNEP.
* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
* positive, then the j-th and (j+1)-st eigenvalues are a
* complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j).
*
* BETA (output) REAL array, dimension (N)
* The scalars beta that define the eigenvalues of GNEP.
* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
* beta = BETA(j) represent the j-th eigenvalue of the matrix
* pair (A,B), in one of the forms lambda = alpha/beta or
* mu = beta/alpha. Since either lambda or mu may overflow,
* they should not, in general, be computed.
*
* Q (input/output) REAL array, dimension (LDQ, N)
* On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in
* the reduction of (A,B) to generalized Hessenberg form.
* On exit, if COMPZ = 'I', the orthogonal matrix of left Schur
* vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix
* of left Schur vectors of (A,B).
* Not referenced if COMPZ = 'N'.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= 1.
* If COMPQ='V' or 'I', then LDQ >= N.
*
* Z (input/output) REAL array, dimension (LDZ, N)
* On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in
* the reduction of (A,B) to generalized Hessenberg form.
* On exit, if COMPZ = 'I', the orthogonal matrix of
* right Schur vectors of (H,T), and if COMPZ = 'V', the
* orthogonal matrix of right Schur vectors of (A,B).
* Not referenced if COMPZ = 'N'.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1.
* If COMPZ='V' or 'I', then LDZ >= N.
*
* WORK (workspace/output) REAL 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).
*
* 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
* = 1,...,N: the QZ iteration did not converge. (H,T) is not
* in Schur form, but ALPHAR(i), ALPHAI(i), and
* BETA(i), i=INFO+1,...,N should be correct.
* = N+1,...,2*N: the shift calculation failed. (H,T) is not
* in Schur form, but ALPHAR(i), ALPHAI(i), and
* BETA(i), i=INFO-N+1,...,N should be correct.
*
* Further Details
* ===============
*
* Iteration counters:
*
* JITER -- counts iterations.
* IITER -- counts iterations run since ILAST was last
* changed. This is therefore reset only when a 1-by-1 or
* 2-by-2 block deflates off the bottom.
*
* =====================================================================
*
* .. Parameters ..
* $ SAFETY = 1.0E+0 )
REAL HALF, ZERO, ONE, SAFETY
PARAMETER ( HALF = 0.5E+0, ZERO = 0.0E+0, ONE = 1.0E+0,
$ SAFETY = 1.0E+2 )
* ..
* .. Local Scalars ..
LOGICAL ILAZR2, ILAZRO, ILPIVT, ILQ, ILSCHR, ILZ,
$ LQUERY
INTEGER ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST,
$ ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER,
$ JR, MAXIT
REAL A11, A12, A1I, A1R, A21, A22, A2I, A2R, AD11,
$ AD11L, AD12, AD12L, AD21, AD21L, AD22, AD22L,
$ AD32L, AN, ANORM, ASCALE, ATOL, B11, B1A, B1I,
$ B1R, B22, B2A, B2I, B2R, BN, BNORM, BSCALE,
$ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL,
$ CQ, CR, CZ, ESHIFT, S, S1, S1INV, S2, SAFMAX,
$ SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T1,
$ TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, U12, U12L,
$ U2, ULP, VS, W11, W12, W21, W22, WABS, WI, WR,
$ WR2
* ..
* .. Local Arrays ..
REAL V( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANHS, SLAPY2, SLAPY3
EXTERNAL LSAME, SLAMCH, SLANHS, SLAPY2, SLAPY3
* ..
* .. External Subroutines ..
EXTERNAL SLAG2, SLARFG, SLARTG, SLASET, SLASV2, SROT,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL, SQRT
* ..
* .. Executable Statements ..
*
* Decode JOB, COMPQ, COMPZ
*
IF( LSAME( JOB, 'E' ) ) THEN
ILSCHR = .FALSE.
ISCHUR = 1
ELSE IF( LSAME( JOB, 'S' ) ) THEN
ILSCHR = .TRUE.
ISCHUR = 2
ELSE
ISCHUR = 0
END IF
*
IF( LSAME( COMPQ, 'N' ) ) THEN
ILQ = .FALSE.
ICOMPQ = 1
ELSE IF( LSAME( COMPQ, 'V' ) ) THEN
ILQ = .TRUE.
ICOMPQ = 2
ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
ILQ = .TRUE.
ICOMPQ = 3
ELSE
ICOMPQ = 0
END IF
*
IF( LSAME( COMPZ, 'N' ) ) THEN
ILZ = .FALSE.
ICOMPZ = 1
ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
ILZ = .TRUE.
ICOMPZ = 2
ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
ILZ = .TRUE.
ICOMPZ = 3
ELSE
ICOMPZ = 0
END IF
*
* Check Argument Values
*
INFO = 0
WORK( 1 ) = MAX( 1, N )
LQUERY = ( LWORK.EQ.-1 )
IF( ISCHUR.EQ.0 ) THEN
INFO = -1
ELSE IF( ICOMPQ.EQ.0 ) THEN
INFO = -2
ELSE IF( ICOMPZ.EQ.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( ILO.LT.1 ) THEN
INFO = -5
ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
INFO = -6
ELSE IF( LDH.LT.N ) THEN
INFO = -8
ELSE IF( LDT.LT.N ) THEN
INFO = -10
ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN
INFO = -15
ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN
INFO = -17
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -19
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SHGEQZ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 ) THEN
WORK( 1 ) = REAL( 1 )
RETURN
END IF
*
* Initialize Q and Z
*
IF( ICOMPQ.EQ.3 )
$ CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
IF( ICOMPZ.EQ.3 )
$ CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
*
* Machine Constants
*
IN = IHI + 1 - ILO
SAFMIN = SLAMCH( 'S' )
SAFMAX = ONE / SAFMIN
ULP = SLAMCH( 'E' )*SLAMCH( 'B' )
ANORM = SLANHS( 'F', IN, H( ILO, ILO ), LDH, WORK )
BNORM = SLANHS( 'F', IN, T( ILO, ILO ), LDT, WORK )
ATOL = MAX( SAFMIN, ULP*ANORM )
BTOL = MAX( SAFMIN, ULP*BNORM )
ASCALE = ONE / MAX( SAFMIN, ANORM )
BSCALE = ONE / MAX( SAFMIN, BNORM )
*
* Set Eigenvalues IHI+1:N
*
DO 30 J = IHI + 1, N
IF( T( J, J ).LT.ZERO ) THEN
IF( ILSCHR ) THEN
DO 10 JR = 1, J
H( JR, J ) = -H( JR, J )
T( JR, J ) = -T( JR, J )
10 CONTINUE
ELSE
H( J, J ) = -H( J, J )
T( J, J ) = -T( J, J )
END IF
IF( ILZ ) THEN
DO 20 JR = 1, N
Z( JR, J ) = -Z( JR, J )
20 CONTINUE
END IF
END IF
ALPHAR( J ) = H( J, J )
ALPHAI( J ) = ZERO
BETA( J ) = T( J, J )
30 CONTINUE
*
* If IHI < ILO, skip QZ steps
*
IF( IHI.LT.ILO )
$ GO TO 380
*
* MAIN QZ ITERATION LOOP
*
* Initialize dynamic indices
*
* Eigenvalues ILAST+1:N have been found.
* Column operations modify rows IFRSTM:whatever.
* Row operations modify columns whatever:ILASTM.
*
* If only eigenvalues are being computed, then
* IFRSTM is the row of the last splitting row above row ILAST;
* this is always at least ILO.
* IITER counts iterations since the last eigenvalue was found,
* to tell when to use an extraordinary shift.
* MAXIT is the maximum number of QZ sweeps allowed.
*
ILAST = IHI
IF( ILSCHR ) THEN
IFRSTM = 1
ILASTM = N
ELSE
IFRSTM = ILO
ILASTM = IHI
END IF
IITER = 0
ESHIFT = ZERO
MAXIT = 30*( IHI-ILO+1 )
*
DO 360 JITER = 1, MAXIT
*
* Split the matrix if possible.
*
* Two tests:
* 1: H(j,j-1)=0 or j=ILO
* 2: T(j,j)=0
*
IF( ILAST.EQ.ILO ) THEN
*
* Special case: j=ILAST
*
GO TO 80
ELSE
IF( ABS( H( ILAST, ILAST-1 ) ).LE.ATOL ) THEN
H( ILAST, ILAST-1 ) = ZERO
GO TO 80
END IF
END IF
*
IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN
T( ILAST, ILAST ) = ZERO
GO TO 70
END IF
*
* General case: j unfl )
* __
* (sA - wB) ( CZ -SZ )
* ( SZ CZ )
*
C11R = S1*A11 - WR*B11
C11I = -WI*B11
C12 = S1*A12
C21 = S1*A21
C22R = S1*A22 - WR*B22
C22I = -WI*B22
*
IF( ABS( C11R )+ABS( C11I )+ABS( C12 ).GT.ABS( C21 )+
$ ABS( C22R )+ABS( C22I ) ) THEN
T1 = SLAPY3( C12, C11R, C11I )
CZ = C12 / T1
SZR = -C11R / T1
SZI = -C11I / T1
ELSE
CZ = SLAPY2( C22R, C22I )
IF( CZ.LE.SAFMIN ) THEN
CZ = ZERO
SZR = ONE
SZI = ZERO
ELSE
TEMPR = C22R / CZ
TEMPI = C22I / CZ
T1 = SLAPY2( CZ, C21 )
CZ = CZ / T1
SZR = -C21*TEMPR / T1
SZI = C21*TEMPI / T1
END IF
END IF
*
* Compute Givens rotation on left
*
* ( CQ SQ )
* ( __ ) A or B
* ( -SQ CQ )
*
AN = ABS( A11 ) + ABS( A12 ) + ABS( A21 ) + ABS( A22 )
BN = ABS( B11 ) + ABS( B22 )
WABS = ABS( WR ) + ABS( WI )
IF( S1*AN.GT.WABS*BN ) THEN
CQ = CZ*B11
SQR = SZR*B22
SQI = -SZI*B22
ELSE
A1R = CZ*A11 + SZR*A12
A1I = SZI*A12
A2R = CZ*A21 + SZR*A22
A2I = SZI*A22
CQ = SLAPY2( A1R, A1I )
IF( CQ.LE.SAFMIN ) THEN
CQ = ZERO
SQR = ONE
SQI = ZERO
ELSE
TEMPR = A1R / CQ
TEMPI = A1I / CQ
SQR = TEMPR*A2R + TEMPI*A2I
SQI = TEMPI*A2R - TEMPR*A2I
END IF
END IF
T1 = SLAPY3( CQ, SQR, SQI )
CQ = CQ / T1
SQR = SQR / T1
SQI = SQI / T1
*
* Compute diagonal elements of QBZ
*
TEMPR = SQR*SZR - SQI*SZI
TEMPI = SQR*SZI + SQI*SZR
B1R = CQ*CZ*B11 + TEMPR*B22
B1I = TEMPI*B22
B1A = SLAPY2( B1R, B1I )
B2R = CQ*CZ*B22 + TEMPR*B11
B2I = -TEMPI*B11
B2A = SLAPY2( B2R, B2I )
*
* Normalize so beta > 0, and Im( alpha1 ) > 0
*
BETA( ILAST-1 ) = B1A
BETA( ILAST ) = B2A
ALPHAR( ILAST-1 ) = ( WR*B1A )*S1INV
ALPHAI( ILAST-1 ) = ( WI*B1A )*S1INV
ALPHAR( ILAST ) = ( WR*B2A )*S1INV
ALPHAI( ILAST ) = -( WI*B2A )*S1INV
*
* Step 3: Go to next block -- exit if finished.
*
ILAST = IFIRST - 1
IF( ILAST.LT.ILO )
$ GO TO 380
*
* Reset counters
*
IITER = 0
ESHIFT = ZERO
IF( .NOT.ILSCHR ) THEN
ILASTM = ILAST
IF( IFRSTM.GT.ILAST )
$ IFRSTM = ILO
END IF
GO TO 350
ELSE
*
* Usual case: 3x3 or larger block, using Francis implicit
* double-shift
*
* 2
* Eigenvalue equation is w - c w + d = 0,
*
* -1 2 -1
* so compute 1st column of (A B ) - c A B + d
* using the formula in QZIT (from EISPACK)
*
* We assume that the block is at least 3x3
*
AD11 = ( ASCALE*H( ILAST-1, ILAST-1 ) ) /
$ ( BSCALE*T( ILAST-1, ILAST-1 ) )
AD21 = ( ASCALE*H( ILAST, ILAST-1 ) ) /
$ ( BSCALE*T( ILAST-1, ILAST-1 ) )
AD12 = ( ASCALE*H( ILAST-1, ILAST ) ) /
$ ( BSCALE*T( ILAST, ILAST ) )
AD22 = ( ASCALE*H( ILAST, ILAST ) ) /
$ ( BSCALE*T( ILAST, ILAST ) )
U12 = T( ILAST-1, ILAST ) / T( ILAST, ILAST )
AD11L = ( ASCALE*H( IFIRST, IFIRST ) ) /
$ ( BSCALE*T( IFIRST, IFIRST ) )
AD21L = ( ASCALE*H( IFIRST+1, IFIRST ) ) /
$ ( BSCALE*T( IFIRST, IFIRST ) )
AD12L = ( ASCALE*H( IFIRST, IFIRST+1 ) ) /
$ ( BSCALE*T( IFIRST+1, IFIRST+1 ) )
AD22L = ( ASCALE*H( IFIRST+1, IFIRST+1 ) ) /
$ ( BSCALE*T( IFIRST+1, IFIRST+1 ) )
AD32L = ( ASCALE*H( IFIRST+2, IFIRST+1 ) ) /
$ ( BSCALE*T( IFIRST+1, IFIRST+1 ) )
U12L = T( IFIRST, IFIRST+1 ) / T( IFIRST+1, IFIRST+1 )
*
V( 1 ) = ( AD11-AD11L )*( AD22-AD11L ) - AD12*AD21 +
$ AD21*U12*AD11L + ( AD12L-AD11L*U12L )*AD21L
V( 2 ) = ( ( AD22L-AD11L )-AD21L*U12L-( AD11-AD11L )-
$ ( AD22-AD11L )+AD21*U12 )*AD21L
V( 3 ) = AD32L*AD21L
*
ISTART = IFIRST
*
CALL SLARFG( 3, V( 1 ), V( 2 ), 1, TAU )
V( 1 ) = ONE
*
* Sweep
*
DO 290 J = ISTART, ILAST - 2
*
* All but last elements: use 3x3 Householder transforms.
*
* Zero (j-1)st column of A
*
IF( J.GT.ISTART ) THEN
V( 1 ) = H( J, J-1 )
V( 2 ) = H( J+1, J-1 )
V( 3 ) = H( J+2, J-1 )
*
CALL SLARFG( 3, H( J, J-1 ), V( 2 ), 1, TAU )
V( 1 ) = ONE
H( J+1, J-1 ) = ZERO
H( J+2, J-1 ) = ZERO
END IF
*
DO 230 JC = J, ILASTM
TEMP = TAU*( H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )*
$ H( J+2, JC ) )
H( J, JC ) = H( J, JC ) - TEMP
H( J+1, JC ) = H( J+1, JC ) - TEMP*V( 2 )
H( J+2, JC ) = H( J+2, JC ) - TEMP*V( 3 )
TEMP2 = TAU*( T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )*
$ T( J+2, JC ) )
T( J, JC ) = T( J, JC ) - TEMP2
T( J+1, JC ) = T( J+1, JC ) - TEMP2*V( 2 )
T( J+2, JC ) = T( J+2, JC ) - TEMP2*V( 3 )
230 CONTINUE
IF( ILQ ) THEN
DO 240 JR = 1, N
TEMP = TAU*( Q( JR, J )+V( 2 )*Q( JR, J+1 )+V( 3 )*
$ Q( JR, J+2 ) )
Q( JR, J ) = Q( JR, J ) - TEMP
Q( JR, J+1 ) = Q( JR, J+1 ) - TEMP*V( 2 )
Q( JR, J+2 ) = Q( JR, J+2 ) - TEMP*V( 3 )
240 CONTINUE
END IF
*
* Zero j-th column of B (see SLAGBC for details)
*
* Swap rows to pivot
*
ILPIVT = .FALSE.
TEMP = MAX( ABS( T( J+1, J+1 ) ), ABS( T( J+1, J+2 ) ) )
TEMP2 = MAX( ABS( T( J+2, J+1 ) ), ABS( T( J+2, J+2 ) ) )
IF( MAX( TEMP, TEMP2 ).LT.SAFMIN ) THEN
SCALE = ZERO
U1 = ONE
U2 = ZERO
GO TO 250
ELSE IF( TEMP.GE.TEMP2 ) THEN
W11 = T( J+1, J+1 )
W21 = T( J+2, J+1 )
W12 = T( J+1, J+2 )
W22 = T( J+2, J+2 )
U1 = T( J+1, J )
U2 = T( J+2, J )
ELSE
W21 = T( J+1, J+1 )
W11 = T( J+2, J+1 )
W22 = T( J+1, J+2 )
W12 = T( J+2, J+2 )
U2 = T( J+1, J )
U1 = T( J+2, J )
END IF
*
* Swap columns if nec.
*
IF( ABS( W12 ).GT.ABS( W11 ) ) THEN
ILPIVT = .TRUE.
TEMP = W12
TEMP2 = W22
W12 = W11
W22 = W21
W11 = TEMP
W21 = TEMP2
END IF
*
* LU-factor
*
TEMP = W21 / W11
U2 = U2 - TEMP*U1
W22 = W22 - TEMP*W12
W21 = ZERO
*
* Compute SCALE
*
SCALE = ONE
IF( ABS( W22 ).LT.SAFMIN ) THEN
SCALE = ZERO
U2 = ONE
U1 = -W12 / W11
GO TO 250
END IF
IF( ABS( W22 ).LT.ABS( U2 ) )
$ SCALE = ABS( W22 / U2 )
IF( ABS( W11 ).LT.ABS( U1 ) )
$ SCALE = MIN( SCALE, ABS( W11 / U1 ) )
*
* Solve
*
U2 = ( SCALE*U2 ) / W22
U1 = ( SCALE*U1-W12*U2 ) / W11
*
250 CONTINUE
IF( ILPIVT ) THEN
TEMP = U2
U2 = U1
U1 = TEMP
END IF
*
* Compute Householder Vector
*
T1 = SQRT( SCALE**2+U1**2+U2**2 )
TAU = ONE + SCALE / T1
VS = -ONE / ( SCALE+T1 )
V( 1 ) = ONE
V( 2 ) = VS*U1
V( 3 ) = VS*U2
*
* Apply transformations from the right.
*
DO 260 JR = IFRSTM, MIN( J+3, ILAST )
TEMP = TAU*( H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )*
$ H( JR, J+2 ) )
H( JR, J ) = H( JR, J ) - TEMP
H( JR, J+1 ) = H( JR, J+1 ) - TEMP*V( 2 )
H( JR, J+2 ) = H( JR, J+2 ) - TEMP*V( 3 )
260 CONTINUE
DO 270 JR = IFRSTM, J + 2
TEMP = TAU*( T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )*
$ T( JR, J+2 ) )
T( JR, J ) = T( JR, J ) - TEMP
T( JR, J+1 ) = T( JR, J+1 ) - TEMP*V( 2 )
T( JR, J+2 ) = T( JR, J+2 ) - TEMP*V( 3 )
270 CONTINUE
IF( ILZ ) THEN
DO 280 JR = 1, N
TEMP = TAU*( Z( JR, J )+V( 2 )*Z( JR, J+1 )+V( 3 )*
$ Z( JR, J+2 ) )
Z( JR, J ) = Z( JR, J ) - TEMP
Z( JR, J+1 ) = Z( JR, J+1 ) - TEMP*V( 2 )
Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 )
280 CONTINUE
END IF
T( J+1, J ) = ZERO
T( J+2, J ) = ZERO
290 CONTINUE
*
* Last elements: Use Givens rotations
*
* Rotations from the left
*
J = ILAST - 1
TEMP = H( J, J-1 )
CALL SLARTG( TEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) )
H( J+1, J-1 ) = ZERO
*
DO 300 JC = J, ILASTM
TEMP = C*H( J, JC ) + S*H( J+1, JC )
H( J+1, JC ) = -S*H( J, JC ) + C*H( J+1, JC )
H( J, JC ) = TEMP
TEMP2 = C*T( J, JC ) + S*T( J+1, JC )
T( J+1, JC ) = -S*T( J, JC ) + C*T( J+1, JC )
T( J, JC ) = TEMP2
300 CONTINUE
IF( ILQ ) THEN
DO 310 JR = 1, N
TEMP = C*Q( JR, J ) + S*Q( JR, J+1 )
Q( JR, J+1 ) = -S*Q( JR, J ) + C*Q( JR, J+1 )
Q( JR, J ) = TEMP
310 CONTINUE
END IF
*
* Rotations from the right.
*
TEMP = T( J+1, J+1 )
CALL SLARTG( TEMP, T( J+1, J ), C, S, T( J+1, J+1 ) )
T( J+1, J ) = ZERO
*
DO 320 JR = IFRSTM, ILAST
TEMP = C*H( JR, J+1 ) + S*H( JR, J )
H( JR, J ) = -S*H( JR, J+1 ) + C*H( JR, J )
H( JR, J+1 ) = TEMP
320 CONTINUE
DO 330 JR = IFRSTM, ILAST - 1
TEMP = C*T( JR, J+1 ) + S*T( JR, J )
T( JR, J ) = -S*T( JR, J+1 ) + C*T( JR, J )
T( JR, J+1 ) = TEMP
330 CONTINUE
IF( ILZ ) THEN
DO 340 JR = 1, N
TEMP = C*Z( JR, J+1 ) + S*Z( JR, J )
Z( JR, J ) = -S*Z( JR, J+1 ) + C*Z( JR, J )
Z( JR, J+1 ) = TEMP
340 CONTINUE
END IF
*
* End of Double-Shift code
*
END IF
*
GO TO 350
*
* End of iteration loop
*
350 CONTINUE
360 CONTINUE
*
* Drop-through = non-convergence
*
INFO = ILAST
GO TO 420
*
* Successful completion of all QZ steps
*
380 CONTINUE
*
* Set Eigenvalues 1:ILO-1
*
DO 410 J = 1, ILO - 1
IF( T( J, J ).LT.ZERO ) THEN
IF( ILSCHR ) THEN
DO 390 JR = 1, J
H( JR, J ) = -H( JR, J )
T( JR, J ) = -T( JR, J )
390 CONTINUE
ELSE
H( J, J ) = -H( J, J )
T( J, J ) = -T( J, J )
END IF
IF( ILZ ) THEN
DO 400 JR = 1, N
Z( JR, J ) = -Z( JR, J )
400 CONTINUE
END IF
END IF
ALPHAR( J ) = H( J, J )
ALPHAI( J ) = ZERO
BETA( J ) = T( J, J )
410 CONTINUE
*
* Normal Termination
*
INFO = 0
*
* Exit (other than argument error) -- return optimal workspace size
*
420 CONTINUE
WORK( 1 ) = REAL( N )
RETURN
*
* End of SHGEQZ
*
END
SUBROUTINE SHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI,
$ VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL,
$ IFAILR, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER EIGSRC, INITV, SIDE
INTEGER INFO, LDH, LDVL, LDVR, M, MM, N
* ..
* .. Array Arguments ..
LOGICAL SELECT( * )
INTEGER IFAILL( * ), IFAILR( * )
REAL H( LDH, * ), VL( LDVL, * ), VR( LDVR, * ),
$ WI( * ), WORK( * ), WR( * )
* ..
*
* Purpose
* =======
*
* SHSEIN uses inverse iteration to find specified right and/or left
* eigenvectors of a real upper Hessenberg matrix H.
*
* The right eigenvector x and the left eigenvector y of the matrix H
* corresponding to an eigenvalue w are defined by:
*
* H * x = w * x, y**h * H = w * y**h
*
* where y**h denotes the conjugate transpose of the vector y.
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* = 'R': compute right eigenvectors only;
* = 'L': compute left eigenvectors only;
* = 'B': compute both right and left eigenvectors.
*
* EIGSRC (input) CHARACTER*1
* Specifies the source of eigenvalues supplied in (WR,WI):
* = 'Q': the eigenvalues were found using SHSEQR; thus, if
* H has zero subdiagonal elements, and so is
* block-triangular, then the j-th eigenvalue can be
* assumed to be an eigenvalue of the block containing
* the j-th row/column. This property allows SHSEIN to
* perform inverse iteration on just one diagonal block.
* = 'N': no assumptions are made on the correspondence
* between eigenvalues and diagonal blocks. In this
* case, SHSEIN must always perform inverse iteration
* using the whole matrix H.
*
* INITV (input) CHARACTER*1
* = 'N': no initial vectors are supplied;
* = 'U': user-supplied initial vectors are stored in the arrays
* VL and/or VR.
*
* SELECT (input/output) LOGICAL array, dimension (N)
* Specifies the eigenvectors to be computed. To select the
* real eigenvector corresponding to a real eigenvalue WR(j),
* SELECT(j) must be set to .TRUE.. To select the complex
* eigenvector corresponding to a complex eigenvalue
* (WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)),
* either SELECT(j) or SELECT(j+1) or both must be set to
* .TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is
* .FALSE..
*
* N (input) INTEGER
* The order of the matrix H. N >= 0.
*
* H (input) REAL array, dimension (LDH,N)
* The upper Hessenberg matrix H.
*
* LDH (input) INTEGER
* The leading dimension of the array H. LDH >= max(1,N).
*
* WR (input/output) REAL array, dimension (N)
* WI (input) REAL array, dimension (N)
* On entry, the real and imaginary parts of the eigenvalues of
* H; a complex conjugate pair of eigenvalues must be stored in
* consecutive elements of WR and WI.
* On exit, WR may have been altered since close eigenvalues
* are perturbed slightly in searching for independent
* eigenvectors.
*
* VL (input/output) REAL array, dimension (LDVL,MM)
* On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must
* contain starting vectors for the inverse iteration for the
* left eigenvectors; the starting vector for each eigenvector
* must be in the same column(s) in which the eigenvector will
* be stored.
* On exit, if SIDE = 'L' or 'B', the left eigenvectors
* specified by SELECT will be stored consecutively in the
* columns of VL, in the same order as their eigenvalues. A
* complex eigenvector corresponding to a complex eigenvalue is
* stored in two consecutive columns, the first holding the real
* part and the second the imaginary part.
* If SIDE = 'R', VL is not referenced.
*
* LDVL (input) INTEGER
* The leading dimension of the array VL.
* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
*
* VR (input/output) REAL array, dimension (LDVR,MM)
* On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must
* contain starting vectors for the inverse iteration for the
* right eigenvectors; the starting vector for each eigenvector
* must be in the same column(s) in which the eigenvector will
* be stored.
* On exit, if SIDE = 'R' or 'B', the right eigenvectors
* specified by SELECT will be stored consecutively in the
* columns of VR, in the same order as their eigenvalues. A
* complex eigenvector corresponding to a complex eigenvalue is
* stored in two consecutive columns, the first holding the real
* part and the second the imaginary part.
* If SIDE = 'L', VR is not referenced.
*
* LDVR (input) INTEGER
* The leading dimension of the array VR.
* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
*
* MM (input) INTEGER
* The number of columns in the arrays VL and/or VR. MM >= M.
*
* M (output) INTEGER
* The number of columns in the arrays VL and/or VR required to
* store the eigenvectors; each selected real eigenvector
* occupies one column and each selected complex eigenvector
* occupies two columns.
*
* WORK (workspace) REAL array, dimension ((N+2)*N)
*
* IFAILL (output) INTEGER array, dimension (MM)
* If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left
* eigenvector in the i-th column of VL (corresponding to the
* eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the
* eigenvector converged satisfactorily. If the i-th and (i+1)th
* columns of VL hold a complex eigenvector, then IFAILL(i) and
* IFAILL(i+1) are set to the same value.
* If SIDE = 'R', IFAILL is not referenced.
*
* IFAILR (output) INTEGER array, dimension (MM)
* If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right
* eigenvector in the i-th column of VR (corresponding to the
* eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the
* eigenvector converged satisfactorily. If the i-th and (i+1)th
* columns of VR hold a complex eigenvector, then IFAILR(i) and
* IFAILR(i+1) are set to the same value.
* If SIDE = 'L', IFAILR is not referenced.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, i is the number of eigenvectors which
* failed to converge; see IFAILL and IFAILR for further
* details.
*
* Further Details
* ===============
*
* Each eigenvector is normalized so that the element of largest
* magnitude has magnitude 1; here the magnitude of a complex number
* (x,y) is taken to be |x|+|y|.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL BOTHV, FROMQR, LEFTV, NOINIT, PAIR, RIGHTV
INTEGER I, IINFO, K, KL, KLN, KR, KSI, KSR, LDWORK
REAL BIGNUM, EPS3, HNORM, SMLNUM, ULP, UNFL, WKI,
$ WKR
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANHS
EXTERNAL LSAME, SLAMCH, SLANHS
* ..
* .. External Subroutines ..
EXTERNAL SLAEIN, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Decode and test the input parameters.
*
BOTHV = LSAME( SIDE, 'B' )
RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV
LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV
*
FROMQR = LSAME( EIGSRC, 'Q' )
*
NOINIT = LSAME( INITV, 'N' )
*
* Set M to the number of columns required to store the selected
* eigenvectors, and standardize the array SELECT.
*
M = 0
PAIR = .FALSE.
DO 10 K = 1, N
IF( PAIR ) THEN
PAIR = .FALSE.
SELECT( K ) = .FALSE.
ELSE
IF( WI( K ).EQ.ZERO ) THEN
IF( SELECT( K ) )
$ M = M + 1
ELSE
PAIR = .TRUE.
IF( SELECT( K ) .OR. SELECT( K+1 ) ) THEN
SELECT( K ) = .TRUE.
M = M + 2
END IF
END IF
END IF
10 CONTINUE
*
INFO = 0
IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
INFO = -1
ELSE IF( .NOT.FROMQR .AND. .NOT.LSAME( EIGSRC, 'N' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOINIT .AND. .NOT.LSAME( INITV, 'U' ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN
INFO = -11
ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN
INFO = -13
ELSE IF( MM.LT.M ) THEN
INFO = -14
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SHSEIN', -INFO )
RETURN
END IF
*
* Quick return if possible.
*
IF( N.EQ.0 )
$ RETURN
*
* Set machine-dependent constants.
*
UNFL = SLAMCH( 'Safe minimum' )
ULP = SLAMCH( 'Precision' )
SMLNUM = UNFL*( N / ULP )
BIGNUM = ( ONE-ULP ) / SMLNUM
*
LDWORK = N + 1
*
KL = 1
KLN = 0
IF( FROMQR ) THEN
KR = 0
ELSE
KR = N
END IF
KSR = 1
*
DO 120 K = 1, N
IF( SELECT( K ) ) THEN
*
* Compute eigenvector(s) corresponding to W(K).
*
IF( FROMQR ) THEN
*
* If affiliation of eigenvalues is known, check whether
* the matrix splits.
*
* Determine KL and KR such that 1 <= KL <= K <= KR <= N
* and H(KL,KL-1) and H(KR+1,KR) are zero (or KL = 1 or
* KR = N).
*
* Then inverse iteration can be performed with the
* submatrix H(KL:N,KL:N) for a left eigenvector, and with
* the submatrix H(1:KR,1:KR) for a right eigenvector.
*
DO 20 I = K, KL + 1, -1
IF( H( I, I-1 ).EQ.ZERO )
$ GO TO 30
20 CONTINUE
30 CONTINUE
KL = I
IF( K.GT.KR ) THEN
DO 40 I = K, N - 1
IF( H( I+1, I ).EQ.ZERO )
$ GO TO 50
40 CONTINUE
50 CONTINUE
KR = I
END IF
END IF
*
IF( KL.NE.KLN ) THEN
KLN = KL
*
* Compute infinity-norm of submatrix H(KL:KR,KL:KR) if it
* has not ben computed before.
*
HNORM = SLANHS( 'I', KR-KL+1, H( KL, KL ), LDH, WORK )
IF( HNORM.GT.ZERO ) THEN
EPS3 = HNORM*ULP
ELSE
EPS3 = SMLNUM
END IF
END IF
*
* Perturb eigenvalue if it is close to any previous
* selected eigenvalues affiliated to the submatrix
* H(KL:KR,KL:KR). Close roots are modified by EPS3.
*
WKR = WR( K )
WKI = WI( K )
60 CONTINUE
DO 70 I = K - 1, KL, -1
IF( SELECT( I ) .AND. ABS( WR( I )-WKR )+
$ ABS( WI( I )-WKI ).LT.EPS3 ) THEN
WKR = WKR + EPS3
GO TO 60
END IF
70 CONTINUE
WR( K ) = WKR
*
PAIR = WKI.NE.ZERO
IF( PAIR ) THEN
KSI = KSR + 1
ELSE
KSI = KSR
END IF
IF( LEFTV ) THEN
*
* Compute left eigenvector.
*
CALL SLAEIN( .FALSE., NOINIT, N-KL+1, H( KL, KL ), LDH,
$ WKR, WKI, VL( KL, KSR ), VL( KL, KSI ),
$ WORK, LDWORK, WORK( N*N+N+1 ), EPS3, SMLNUM,
$ BIGNUM, IINFO )
IF( IINFO.GT.0 ) THEN
IF( PAIR ) THEN
INFO = INFO + 2
ELSE
INFO = INFO + 1
END IF
IFAILL( KSR ) = K
IFAILL( KSI ) = K
ELSE
IFAILL( KSR ) = 0
IFAILL( KSI ) = 0
END IF
DO 80 I = 1, KL - 1
VL( I, KSR ) = ZERO
80 CONTINUE
IF( PAIR ) THEN
DO 90 I = 1, KL - 1
VL( I, KSI ) = ZERO
90 CONTINUE
END IF
END IF
IF( RIGHTV ) THEN
*
* Compute right eigenvector.
*
CALL SLAEIN( .TRUE., NOINIT, KR, H, LDH, WKR, WKI,
$ VR( 1, KSR ), VR( 1, KSI ), WORK, LDWORK,
$ WORK( N*N+N+1 ), EPS3, SMLNUM, BIGNUM,
$ IINFO )
IF( IINFO.GT.0 ) THEN
IF( PAIR ) THEN
INFO = INFO + 2
ELSE
INFO = INFO + 1
END IF
IFAILR( KSR ) = K
IFAILR( KSI ) = K
ELSE
IFAILR( KSR ) = 0
IFAILR( KSI ) = 0
END IF
DO 100 I = KR + 1, N
VR( I, KSR ) = ZERO
100 CONTINUE
IF( PAIR ) THEN
DO 110 I = KR + 1, N
VR( I, KSI ) = ZERO
110 CONTINUE
END IF
END IF
*
IF( PAIR ) THEN
KSR = KSR + 2
ELSE
KSR = KSR + 1
END IF
END IF
120 CONTINUE
*
RETURN
*
* End of SHSEIN
*
END
SUBROUTINE SHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z,
$ LDZ, WORK, LWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N
CHARACTER COMPZ, JOB
* ..
* .. Array Arguments ..
REAL H( LDH, * ), WI( * ), WORK( * ), WR( * ),
$ Z( LDZ, * )
* ..
* Purpose
* =======
*
* SHSEQR computes the eigenvalues of a Hessenberg matrix H
* and, optionally, the matrices T and Z from the Schur decomposition
* H = Z T Z**T, where T is an upper quasi-triangular matrix (the
* Schur form), and Z is the orthogonal matrix of Schur vectors.
*
* Optionally Z may be postmultiplied into an input orthogonal
* matrix Q so that this routine can give the Schur factorization
* of a matrix A which has been reduced to the Hessenberg form H
* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.
*
* Arguments
* =========
*
* JOB (input) CHARACTER*1
* = 'E': compute eigenvalues only;
* = 'S': compute eigenvalues and the Schur form T.
*
* COMPZ (input) CHARACTER*1
* = 'N': no Schur vectors are computed;
* = 'I': Z is initialized to the unit matrix and the matrix Z
* of Schur vectors of H is returned;
* = 'V': Z must contain an orthogonal matrix Q on entry, and
* the product Q*Z is returned.
*
* N (input) INTEGER
* The order of the matrix H. N .GE. 0.
*
* 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. ILO and IHI are normally
* set by a previous call to SGEBAL, and then passed to SGEHRD
* when the matrix output by SGEBAL is reduced to Hessenberg
* form. Otherwise ILO and IHI should be set to 1 and N
* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
* If N = 0, then ILO = 1 and IHI = 0.
*
* H (input/output) REAL array, dimension (LDH,N)
* On entry, the upper Hessenberg matrix H.
* On exit, if INFO = 0 and JOB = 'S', then H contains the
* upper quasi-triangular matrix T from the Schur decomposition
* (the Schur form); 2-by-2 diagonal blocks (corresponding to
* complex conjugate pairs of eigenvalues) are returned in
* standard form, with H(i,i) = H(i+1,i+1) and
* H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and JOB = 'E', the
* contents of H are unspecified on exit. (The output value of
* H when INFO.GT.0 is given under the description of INFO
* below.)
*
* Unlike earlier versions of SHSEQR, this subroutine may
* explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1
* or j = IHI+1, IHI+2, ... N.
*
* LDH (input) INTEGER
* The leading dimension of the array H. LDH .GE. max(1,N).
*
* WR (output) REAL array, dimension (N)
* WI (output) REAL array, dimension (N)
* The real and imaginary parts, respectively, of the computed
* eigenvalues. If two eigenvalues are computed as a complex
* conjugate pair, they are stored in consecutive elements of
* WR and WI, say the i-th and (i+1)th, with WI(i) .GT. 0 and
* WI(i+1) .LT. 0. If JOB = 'S', the eigenvalues are stored in
* the same order as on the diagonal of the Schur form returned
* in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2
* diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and
* WI(i+1) = -WI(i).
*
* Z (input/output) REAL array, dimension (LDZ,N)
* If COMPZ = 'N', Z is not referenced.
* If COMPZ = 'I', on entry Z need not be set and on exit,
* if INFO = 0, Z contains the orthogonal matrix Z of the Schur
* vectors of H. If COMPZ = 'V', on entry Z must contain an
* N-by-N matrix Q, which is assumed to be equal to the unit
* matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,
* if INFO = 0, Z contains Q*Z.
* Normally Q is the orthogonal matrix generated by SORGHR
* after the call to SGEHRD which formed the Hessenberg matrix
* H. (The output value of Z when INFO.GT.0 is given under
* the description of INFO below.)
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. if COMPZ = 'I' or
* COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1.
*
* WORK (workspace/output) REAL array, dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns an estimate of
* the optimal value for LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK. LWORK .GE. max(1,N)
* is sufficient, but LWORK typically as large as 6*N may
* be required for optimal performance. A workspace query
* to determine the optimal workspace size is recommended.
*
* If LWORK = -1, then SHSEQR does a workspace query.
* In this case, SHSEQR checks the input parameters and
* estimates the optimal workspace size for the given
* values of N, ILO and IHI. The estimate is returned
* in WORK(1). No error message related to LWORK is
* issued by XERBLA. Neither H nor Z are accessed.
*
*
* INFO (output) INTEGER
* = 0: successful exit
* .LT. 0: if INFO = -i, the i-th argument had an illegal
* value
* .GT. 0: if INFO = i, SHSEQR failed to compute all of
* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
* and WI contain those eigenvalues which have been
* successfully computed. (Failures are rare.)
*
* If INFO .GT. 0 and JOB = 'E', then on exit, the
* remaining unconverged eigenvalues are the eigen-
* values of the upper Hessenberg matrix rows and
* columns ILO through INFO of the final, output
* value of H.
*
* If INFO .GT. 0 and JOB = 'S', then on exit
*
* (*) (initial value of H)*U = U*(final value of H)
*
* where U is an orthogonal matrix. The final
* value of H is upper Hessenberg and quasi-triangular
* in rows and columns INFO+1 through IHI.
*
* If INFO .GT. 0 and COMPZ = 'V', then on exit
*
* (final value of Z) = (initial value of Z)*U
*
* where U is the orthogonal matrix in (*) (regard-
* less of the value of JOB.)
*
* If INFO .GT. 0 and COMPZ = 'I', then on exit
* (final value of Z) = U
* where U is the orthogonal matrix in (*) (regard-
* less of the value of JOB.)
*
* If INFO .GT. 0 and COMPZ = 'N', then Z is not
* accessed.
*
* ================================================================
* Default values supplied by
* ILAENV(ISPEC,'SHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).
* It is suggested that these defaults be adjusted in order
* to attain best performance in each particular
* computational environment.
*
* ISPEC=1: The SLAHQR vs SLAQR0 crossover point.
* Default: 75. (Must be at least 11.)
*
* ISPEC=2: Recommended deflation window size.
* This depends on ILO, IHI and NS. NS is the
* number of simultaneous shifts returned
* by ILAENV(ISPEC=4). (See ISPEC=4 below.)
* The default for (IHI-ILO+1).LE.500 is NS.
* The default for (IHI-ILO+1).GT.500 is 3*NS/2.
*
* ISPEC=3: Nibble crossover point. (See ILAENV for
* details.) Default: 14% of deflation window
* size.
*
* ISPEC=4: Number of simultaneous shifts, NS, in
* a multi-shift QR iteration.
*
* If IHI-ILO+1 is ...
*
* greater than ...but less ... the
* or equal to ... than default is
*
* 1 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 some or all matrices of this order
* are passed to the implicit double shift routine
* SLAHQR and NS is ignored. See ISPEC=1 above
* and comments in IPARM for details.
*
* The asterisks (**) indicate an ad-hoc
* function of N increasing from 10 to 64.
*
* ISPEC=5: Select structured matrix multiply.
* (See ILAENV for details.) Default: 3.
*
* ================================================================
* Based on contributions by
* Karen Braman and Ralph Byers, Department of Mathematics,
* University of Kansas, USA
*
* ================================================================
* References:
* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
* Performance, SIAM Journal of Matrix Analysis, volume 23, pages
* 929--947, 2002.
*
* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
* Algorithm Part II: Aggressive Early Deflation, SIAM Journal
* of Matrix Analysis, volume 23, pages 948--973, 2002.
*
* ================================================================
* .. Parameters ..
*
* ==== Matrices of order NTINY or smaller must be processed by
* . SLAHQR because of insufficient subdiagonal scratch space.
* . (This is a hard limit.) ====
*
* ==== NL allocates some local workspace to help small matrices
* . through a rare SLAHQR failure. NL .GT. NTINY = 11 is
* . required and NL .LE. NMIN = ILAENV(ISPEC=1,...) is recom-
* . mended. (The default value of NMIN is 75.) Using NL = 49
* . allows up to six simultaneous shifts and a 16-by-16
* . deflation window. ====
*
INTEGER NTINY
PARAMETER ( NTINY = 11 )
INTEGER NL
PARAMETER ( NL = 49 )
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0 )
* ..
* .. Local Arrays ..
REAL HL( NL, NL ), WORKL( NL )
* ..
* .. Local Scalars ..
INTEGER I, KBOT, NMIN
LOGICAL INITZ, LQUERY, WANTT, WANTZ
* ..
* .. External Functions ..
INTEGER ILAENV
LOGICAL LSAME
EXTERNAL ILAENV, LSAME
* ..
* .. External Subroutines ..
EXTERNAL SLACPY, SLAHQR, SLAQR0, SLASET, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Executable Statements ..
*
* ==== Decode and check the input parameters. ====
*
WANTT = LSAME( JOB, 'S' )
INITZ = LSAME( COMPZ, 'I' )
WANTZ = INITZ .OR. LSAME( COMPZ, 'V' )
WORK( 1 ) = REAL( MAX( 1, N ) )
LQUERY = LWORK.EQ.-1
*
INFO = 0
IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN
INFO = -1
ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
INFO = -5
ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN
INFO = -11
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
*
IF( INFO.NE.0 ) THEN
*
* ==== Quick return in case of invalid argument. ====
*
CALL XERBLA( 'SHSEQR', -INFO )
RETURN
*
ELSE IF( N.EQ.0 ) THEN
*
* ==== Quick return in case N = 0; nothing to do. ====
*
RETURN
*
ELSE IF( LQUERY ) THEN
*
* ==== Quick return in case of a workspace query ====
*
CALL SLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO,
$ IHI, Z, LDZ, WORK, LWORK, INFO )
* ==== Ensure reported workspace size is backward-compatible with
* . previous LAPACK versions. ====
WORK( 1 ) = MAX( REAL( MAX( 1, N ) ), WORK( 1 ) )
RETURN
*
ELSE
*
* ==== copy eigenvalues isolated by SGEBAL ====
*
DO 10 I = 1, ILO - 1
WR( I ) = H( I, I )
WI( I ) = ZERO
10 CONTINUE
DO 20 I = IHI + 1, N
WR( I ) = H( I, I )
WI( I ) = ZERO
20 CONTINUE
*
* ==== Initialize Z, if requested ====
*
IF( INITZ )
$ CALL SLASET( 'A', N, N, ZERO, ONE, Z, LDZ )
*
* ==== Quick return if possible ====
*
IF( ILO.EQ.IHI ) THEN
WR( ILO ) = H( ILO, ILO )
WI( ILO ) = ZERO
RETURN
END IF
*
* ==== SLAHQR/SLAQR0 crossover point ====
*
NMIN = ILAENV( 1, 'SHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N, ILO,
$ IHI, LWORK )
NMIN = MAX( NTINY, NMIN )
*
* ==== SLAQR0 for big matrices; SLAHQR for small ones ====
*
IF( N.GT.NMIN ) THEN
CALL SLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO,
$ IHI, Z, LDZ, WORK, LWORK, INFO )
ELSE
*
* ==== Small matrix ====
*
CALL SLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO,
$ IHI, Z, LDZ, INFO )
*
IF( INFO.GT.0 ) THEN
*
* ==== A rare SLAHQR failure! SLAQR0 sometimes succeeds
* . when SLAHQR fails. ====
*
KBOT = INFO
*
IF( N.GE.NL ) THEN
*
* ==== Larger matrices have enough subdiagonal scratch
* . space to call SLAQR0 directly. ====
*
CALL SLAQR0( WANTT, WANTZ, N, ILO, KBOT, H, LDH, WR,
$ WI, ILO, IHI, Z, LDZ, WORK, LWORK, INFO )
*
ELSE
*
* ==== Tiny matrices don't have enough subdiagonal
* . scratch space to benefit from SLAQR0. Hence,
* . tiny matrices must be copied into a larger
* . array before calling SLAQR0. ====
*
CALL SLACPY( 'A', N, N, H, LDH, HL, NL )
HL( N+1, N ) = ZERO
CALL SLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ),
$ NL )
CALL SLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, WR,
$ WI, ILO, IHI, Z, LDZ, WORKL, NL, INFO )
IF( WANTT .OR. INFO.NE.0 )
$ CALL SLACPY( 'A', N, N, HL, NL, H, LDH )
END IF
END IF
END IF
*
* ==== Clear out the trash, if necessary. ====
*
IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 )
$ CALL SLASET( 'L', N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH )
*
* ==== Ensure reported workspace size is backward-compatible with
* . previous LAPACK versions. ====
*
WORK( 1 ) = MAX( REAL( MAX( 1, N ) ), WORK( 1 ) )
END IF
*
* ==== End of SHSEQR ====
*
END
LOGICAL FUNCTION SISNAN(SIN)
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
REAL SIN
* ..
*
* Purpose
* =======
*
* SISNAN returns .TRUE. if its argument is NaN, and .FALSE.
* otherwise. To be replaced by the Fortran 2003 intrinsic in the
* future.
*
* Arguments
* =========
*
* SIN (input) REAL
* Input to test for NaN.
*
* =====================================================================
*
* .. External Functions ..
LOGICAL SLAISNAN
EXTERNAL SLAISNAN
* ..
* .. Executable Statements ..
SISNAN = SLAISNAN(SIN,SIN)
RETURN
END
SUBROUTINE SLABAD( SMALL, LARGE )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
REAL LARGE, SMALL
* ..
*
* Purpose
* =======
*
* SLABAD takes as input the values computed by SLAMCH for underflow and
* overflow, and returns the square root of each of these values if the
* log of LARGE is sufficiently large. This subroutine is intended to
* identify machines with a large exponent range, such as the Crays, and
* redefine the underflow and overflow limits to be the square roots of
* the values computed by SLAMCH. This subroutine is needed because
* SLAMCH does not compensate for poor arithmetic in the upper half of
* the exponent range, as is found on a Cray.
*
* Arguments
* =========
*
* SMALL (input/output) REAL
* On entry, the underflow threshold as computed by SLAMCH.
* On exit, if LOG10(LARGE) is sufficiently large, the square
* root of SMALL, otherwise unchanged.
*
* LARGE (input/output) REAL
* On entry, the overflow threshold as computed by SLAMCH.
* On exit, if LOG10(LARGE) is sufficiently large, the square
* root of LARGE, otherwise unchanged.
*
* =====================================================================
*
* .. Intrinsic Functions ..
INTRINSIC LOG10, SQRT
* ..
* .. Executable Statements ..
*
* If it looks like we're on a Cray, take the square root of
* SMALL and LARGE to avoid overflow and underflow problems.
*
IF( LOG10( LARGE ).GT.2000. ) THEN
SMALL = SQRT( SMALL )
LARGE = SQRT( LARGE )
END IF
*
RETURN
*
* End of SLABAD
*
END
SUBROUTINE SLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y,
$ LDY )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDX, LDY, M, N, NB
* ..
* .. Array Arguments ..
REAL A( LDA, * ), D( * ), E( * ), TAUP( * ),
$ TAUQ( * ), X( LDX, * ), Y( LDY, * )
* ..
*
* Purpose
* =======
*
* SLABRD reduces the first NB rows and columns of a real general
* m by n matrix A to upper or lower bidiagonal form by an orthogonal
* transformation Q' * A * P, and returns the matrices X and Y which
* are needed to apply the transformation to the unreduced part of A.
*
* If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower
* bidiagonal form.
*
* This is an auxiliary routine called by SGEBRD
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows in the matrix A.
*
* N (input) INTEGER
* The number of columns in the matrix A.
*
* NB (input) INTEGER
* The number of leading rows and columns of A to be reduced.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the m by n general matrix to be reduced.
* On exit, the first NB rows and columns of the matrix are
* overwritten; the rest of the array is unchanged.
* If m >= n, elements on and below the diagonal in the first NB
* columns, with the array TAUQ, represent the orthogonal
* matrix Q as a product of elementary reflectors; and
* elements above the diagonal in the first NB rows, with the
* array TAUP, represent the orthogonal matrix P as a product
* of elementary reflectors.
* If m < n, elements below the diagonal in the first NB
* columns, with the array TAUQ, represent the orthogonal
* matrix Q as a product of elementary reflectors, and
* elements on and above the diagonal in the first NB rows,
* with the array TAUP, represent the orthogonal matrix P as
* a product of elementary reflectors.
* See Further Details.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* D (output) REAL array, dimension (NB)
* The diagonal elements of the first NB rows and columns of
* the reduced matrix. D(i) = A(i,i).
*
* E (output) REAL array, dimension (NB)
* The off-diagonal elements of the first NB rows and columns of
* the reduced matrix.
*
* TAUQ (output) REAL array dimension (NB)
* The scalar factors of the elementary reflectors which
* represent the orthogonal matrix Q. See Further Details.
*
* TAUP (output) REAL array, dimension (NB)
* The scalar factors of the elementary reflectors which
* represent the orthogonal matrix P. See Further Details.
*
* X (output) REAL array, dimension (LDX,NB)
* The m-by-nb matrix X required to update the unreduced part
* of A.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= M.
*
* Y (output) REAL array, dimension (LDY,NB)
* The n-by-nb matrix Y required to update the unreduced part
* of A.
*
* LDY (input) INTEGER
* The leading dimension of the array Y. LDY >= N.
*
* Further Details
* ===============
*
* The matrices Q and P are represented as products of elementary
* reflectors:
*
* Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb)
*
* Each H(i) and G(i) has the form:
*
* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
*
* where tauq and taup are real scalars, and v and u are real vectors.
*
* If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in
* A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in
* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
*
* If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in
* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in
* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
*
* The elements of the vectors v and u together form the m-by-nb matrix
* V and the nb-by-n matrix U' which are needed, with X and Y, to apply
* the transformation to the unreduced part of the matrix, using a block
* update of the form: A := A - V*Y' - X*U'.
*
* The contents of A on exit are illustrated by the following examples
* with nb = 2:
*
* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
*
* ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 )
* ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 )
* ( v1 v2 a a a ) ( v1 1 a a a a )
* ( v1 v2 a a a ) ( v1 v2 a a a a )
* ( v1 v2 a a a ) ( v1 v2 a a a a )
* ( v1 v2 a a a )
*
* where a denotes an element of the original matrix which is unchanged,
* vi denotes an element of the vector defining H(i), and ui an element
* of the vector defining G(i).
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
INTEGER I
* ..
* .. External Subroutines ..
EXTERNAL SGEMV, SLARFG, SSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
IF( M.GE.N ) THEN
*
* Reduce to upper bidiagonal form
*
DO 10 I = 1, NB
*
* Update A(i:m,i)
*
CALL SGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ),
$ LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 )
CALL SGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ),
$ LDX, A( 1, I ), 1, ONE, A( I, I ), 1 )
*
* Generate reflection Q(i) to annihilate A(i+1:m,i)
*
CALL SLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
$ TAUQ( I ) )
D( I ) = A( I, I )
IF( I.LT.N ) THEN
A( I, I ) = ONE
*
* Compute Y(i+1:n,i)
*
CALL SGEMV( 'Transpose', M-I+1, N-I, ONE, A( I, I+1 ),
$ LDA, A( I, I ), 1, ZERO, Y( I+1, I ), 1 )
CALL SGEMV( 'Transpose', M-I+1, I-1, ONE, A( I, 1 ), LDA,
$ A( I, I ), 1, ZERO, Y( 1, I ), 1 )
CALL SGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
$ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
CALL SGEMV( 'Transpose', M-I+1, I-1, ONE, X( I, 1 ), LDX,
$ A( I, I ), 1, ZERO, Y( 1, I ), 1 )
CALL SGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ),
$ LDA, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
CALL SSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
*
* Update A(i,i+1:n)
*
CALL SGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ),
$ LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA )
CALL SGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ),
$ LDA, X( I, 1 ), LDX, ONE, A( I, I+1 ), LDA )
*
* Generate reflection P(i) to annihilate A(i,i+2:n)
*
CALL SLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ),
$ LDA, TAUP( I ) )
E( I ) = A( I, I+1 )
A( I, I+1 ) = ONE
*
* Compute X(i+1:m,i)
*
CALL SGEMV( 'No transpose', M-I, N-I, ONE, A( I+1, I+1 ),
$ LDA, A( I, I+1 ), LDA, ZERO, X( I+1, I ), 1 )
CALL SGEMV( 'Transpose', N-I, I, ONE, Y( I+1, 1 ), LDY,
$ A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 )
CALL SGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ),
$ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
CALL SGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ),
$ LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 )
CALL SGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
$ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
CALL SSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
END IF
10 CONTINUE
ELSE
*
* Reduce to lower bidiagonal form
*
DO 20 I = 1, NB
*
* Update A(i,i:n)
*
CALL SGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ),
$ LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA )
CALL SGEMV( 'Transpose', I-1, N-I+1, -ONE, A( 1, I ), LDA,
$ X( I, 1 ), LDX, ONE, A( I, I ), LDA )
*
* Generate reflection P(i) to annihilate A(i,i+1:n)
*
CALL SLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA,
$ TAUP( I ) )
D( I ) = A( I, I )
IF( I.LT.M ) THEN
A( I, I ) = ONE
*
* Compute X(i+1:m,i)
*
CALL SGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ),
$ LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 )
CALL SGEMV( 'Transpose', N-I+1, I-1, ONE, Y( I, 1 ), LDY,
$ A( I, I ), LDA, ZERO, X( 1, I ), 1 )
CALL SGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
$ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
CALL SGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ),
$ LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 )
CALL SGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
$ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
CALL SSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
*
* Update A(i+1:m,i)
*
CALL SGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
$ LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 )
CALL SGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ),
$ LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 )
*
* Generate reflection Q(i) to annihilate A(i+2:m,i)
*
CALL SLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1,
$ TAUQ( I ) )
E( I ) = A( I+1, I )
A( I+1, I ) = ONE
*
* Compute Y(i+1:n,i)
*
CALL SGEMV( 'Transpose', M-I, N-I, ONE, A( I+1, I+1 ),
$ LDA, A( I+1, I ), 1, ZERO, Y( I+1, I ), 1 )
CALL SGEMV( 'Transpose', M-I, I-1, ONE, A( I+1, 1 ), LDA,
$ A( I+1, I ), 1, ZERO, Y( 1, I ), 1 )
CALL SGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
$ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
CALL SGEMV( 'Transpose', M-I, I, ONE, X( I+1, 1 ), LDX,
$ A( I+1, I ), 1, ZERO, Y( 1, I ), 1 )
CALL SGEMV( 'Transpose', I, N-I, -ONE, A( 1, I+1 ), LDA,
$ Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
CALL SSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
END IF
20 CONTINUE
END IF
RETURN
*
* End of SLABRD
*
END
SUBROUTINE SLACN2( N, V, X, ISGN, EST, KASE, ISAVE )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KASE, N
REAL EST
* ..
* .. Array Arguments ..
INTEGER ISGN( * ), ISAVE( 3 )
REAL V( * ), X( * )
* ..
*
* Purpose
* =======
*
* SLACN2 estimates the 1-norm of a square, real matrix A.
* Reverse communication is used for evaluating matrix-vector products.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix. N >= 1.
*
* V (workspace) REAL array, dimension (N)
* On the final return, V = A*W, where EST = norm(V)/norm(W)
* (W is not returned).
*
* X (input/output) REAL array, dimension (N)
* On an intermediate return, X should be overwritten by
* A * X, if KASE=1,
* A' * X, if KASE=2,
* and SLACN2 must be re-called with all the other parameters
* unchanged.
*
* ISGN (workspace) INTEGER array, dimension (N)
*
* EST (input/output) REAL
* On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be
* unchanged from the previous call to SLACN2.
* On exit, EST is an estimate (a lower bound) for norm(A).
*
* KASE (input/output) INTEGER
* On the initial call to SLACN2, KASE should be 0.
* On an intermediate return, KASE will be 1 or 2, indicating
* whether X should be overwritten by A * X or A' * X.
* On the final return from SLACN2, KASE will again be 0.
*
* ISAVE (input/output) INTEGER array, dimension (3)
* ISAVE is used to save variables between calls to SLACN2
*
* Further Details
* ======= =======
*
* Contributed by Nick Higham, University of Manchester.
* Originally named SONEST, dated March 16, 1988.
*
* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of
* a real or complex matrix, with applications to condition estimation",
* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.
*
* This is a thread safe version of SLACON, which uses the array ISAVE
* in place of a SAVE statement, as follows:
*
* SLACON SLACN2
* JUMP ISAVE(1)
* J ISAVE(2)
* ITER ISAVE(3)
*
* =====================================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 5 )
REAL ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, JLAST
REAL ALTSGN, ESTOLD, TEMP
* ..
* .. External Functions ..
INTEGER ISAMAX
REAL SASUM
EXTERNAL ISAMAX, SASUM
* ..
* .. External Subroutines ..
EXTERNAL SCOPY
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, NINT, REAL, SIGN
* ..
* .. Executable Statements ..
*
IF( KASE.EQ.0 ) THEN
DO 10 I = 1, N
X( I ) = ONE / REAL( N )
10 CONTINUE
KASE = 1
ISAVE( 1 ) = 1
RETURN
END IF
*
GO TO ( 20, 40, 70, 110, 140 )ISAVE( 1 )
*
* ................ ENTRY (ISAVE( 1 ) = 1)
* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X.
*
20 CONTINUE
IF( N.EQ.1 ) THEN
V( 1 ) = X( 1 )
EST = ABS( V( 1 ) )
* ... QUIT
GO TO 150
END IF
EST = SASUM( N, X, 1 )
*
DO 30 I = 1, N
X( I ) = SIGN( ONE, X( I ) )
ISGN( I ) = NINT( X( I ) )
30 CONTINUE
KASE = 2
ISAVE( 1 ) = 2
RETURN
*
* ................ ENTRY (ISAVE( 1 ) = 2)
* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
*
40 CONTINUE
ISAVE( 2 ) = ISAMAX( N, X, 1 )
ISAVE( 3 ) = 2
*
* MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
*
50 CONTINUE
DO 60 I = 1, N
X( I ) = ZERO
60 CONTINUE
X( ISAVE( 2 ) ) = ONE
KASE = 1
ISAVE( 1 ) = 3
RETURN
*
* ................ ENTRY (ISAVE( 1 ) = 3)
* X HAS BEEN OVERWRITTEN BY A*X.
*
70 CONTINUE
CALL SCOPY( N, X, 1, V, 1 )
ESTOLD = EST
EST = SASUM( N, V, 1 )
DO 80 I = 1, N
IF( NINT( SIGN( ONE, X( I ) ) ).NE.ISGN( I ) )
$ GO TO 90
80 CONTINUE
* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED.
GO TO 120
*
90 CONTINUE
* TEST FOR CYCLING.
IF( EST.LE.ESTOLD )
$ GO TO 120
*
DO 100 I = 1, N
X( I ) = SIGN( ONE, X( I ) )
ISGN( I ) = NINT( X( I ) )
100 CONTINUE
KASE = 2
ISAVE( 1 ) = 4
RETURN
*
* ................ ENTRY (ISAVE( 1 ) = 4)
* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
*
110 CONTINUE
JLAST = ISAVE( 2 )
ISAVE( 2 ) = ISAMAX( N, X, 1 )
IF( ( X( JLAST ).NE.ABS( X( ISAVE( 2 ) ) ) ) .AND.
$ ( ISAVE( 3 ).LT.ITMAX ) ) THEN
ISAVE( 3 ) = ISAVE( 3 ) + 1
GO TO 50
END IF
*
* ITERATION COMPLETE. FINAL STAGE.
*
120 CONTINUE
ALTSGN = ONE
DO 130 I = 1, N
X( I ) = ALTSGN*( ONE+REAL( I-1 ) / REAL( N-1 ) )
ALTSGN = -ALTSGN
130 CONTINUE
KASE = 1
ISAVE( 1 ) = 5
RETURN
*
* ................ ENTRY (ISAVE( 1 ) = 5)
* X HAS BEEN OVERWRITTEN BY A*X.
*
140 CONTINUE
TEMP = TWO*( SASUM( N, X, 1 ) / REAL( 3*N ) )
IF( TEMP.GT.EST ) THEN
CALL SCOPY( N, X, 1, V, 1 )
EST = TEMP
END IF
*
150 CONTINUE
KASE = 0
RETURN
*
* End of SLACN2
*
END
SUBROUTINE SLACON( N, V, X, ISGN, EST, KASE )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KASE, N
REAL EST
* ..
* .. Array Arguments ..
INTEGER ISGN( * )
REAL V( * ), X( * )
* ..
*
* Purpose
* =======
*
* SLACON estimates the 1-norm of a square, real matrix A.
* Reverse communication is used for evaluating matrix-vector products.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix. N >= 1.
*
* V (workspace) REAL array, dimension (N)
* On the final return, V = A*W, where EST = norm(V)/norm(W)
* (W is not returned).
*
* X (input/output) REAL array, dimension (N)
* On an intermediate return, X should be overwritten by
* A * X, if KASE=1,
* A' * X, if KASE=2,
* and SLACON must be re-called with all the other parameters
* unchanged.
*
* ISGN (workspace) INTEGER array, dimension (N)
*
* EST (input/output) REAL
* On entry with KASE = 1 or 2 and JUMP = 3, EST should be
* unchanged from the previous call to SLACON.
* On exit, EST is an estimate (a lower bound) for norm(A).
*
* KASE (input/output) INTEGER
* On the initial call to SLACON, KASE should be 0.
* On an intermediate return, KASE will be 1 or 2, indicating
* whether X should be overwritten by A * X or A' * X.
* On the final return from SLACON, KASE will again be 0.
*
* Further Details
* ======= =======
*
* Contributed by Nick Higham, University of Manchester.
* Originally named SONEST, dated March 16, 1988.
*
* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of
* a real or complex matrix, with applications to condition estimation",
* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.
*
* =====================================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 5 )
REAL ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, ITER, J, JLAST, JUMP
REAL ALTSGN, ESTOLD, TEMP
* ..
* .. External Functions ..
INTEGER ISAMAX
REAL SASUM
EXTERNAL ISAMAX, SASUM
* ..
* .. External Subroutines ..
EXTERNAL SCOPY
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, NINT, REAL, SIGN
* ..
* .. Save statement ..
SAVE
* ..
* .. Executable Statements ..
*
IF( KASE.EQ.0 ) THEN
DO 10 I = 1, N
X( I ) = ONE / REAL( N )
10 CONTINUE
KASE = 1
JUMP = 1
RETURN
END IF
*
GO TO ( 20, 40, 70, 110, 140 )JUMP
*
* ................ ENTRY (JUMP = 1)
* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X.
*
20 CONTINUE
IF( N.EQ.1 ) THEN
V( 1 ) = X( 1 )
EST = ABS( V( 1 ) )
* ... QUIT
GO TO 150
END IF
EST = SASUM( N, X, 1 )
*
DO 30 I = 1, N
X( I ) = SIGN( ONE, X( I ) )
ISGN( I ) = NINT( X( I ) )
30 CONTINUE
KASE = 2
JUMP = 2
RETURN
*
* ................ ENTRY (JUMP = 2)
* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
*
40 CONTINUE
J = ISAMAX( N, X, 1 )
ITER = 2
*
* MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
*
50 CONTINUE
DO 60 I = 1, N
X( I ) = ZERO
60 CONTINUE
X( J ) = ONE
KASE = 1
JUMP = 3
RETURN
*
* ................ ENTRY (JUMP = 3)
* X HAS BEEN OVERWRITTEN BY A*X.
*
70 CONTINUE
CALL SCOPY( N, X, 1, V, 1 )
ESTOLD = EST
EST = SASUM( N, V, 1 )
DO 80 I = 1, N
IF( NINT( SIGN( ONE, X( I ) ) ).NE.ISGN( I ) )
$ GO TO 90
80 CONTINUE
* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED.
GO TO 120
*
90 CONTINUE
* TEST FOR CYCLING.
IF( EST.LE.ESTOLD )
$ GO TO 120
*
DO 100 I = 1, N
X( I ) = SIGN( ONE, X( I ) )
ISGN( I ) = NINT( X( I ) )
100 CONTINUE
KASE = 2
JUMP = 4
RETURN
*
* ................ ENTRY (JUMP = 4)
* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
*
110 CONTINUE
JLAST = J
J = ISAMAX( N, X, 1 )
IF( ( X( JLAST ).NE.ABS( X( J ) ) ) .AND. ( ITER.LT.ITMAX ) ) THEN
ITER = ITER + 1
GO TO 50
END IF
*
* ITERATION COMPLETE. FINAL STAGE.
*
120 CONTINUE
ALTSGN = ONE
DO 130 I = 1, N
X( I ) = ALTSGN*( ONE+REAL( I-1 ) / REAL( N-1 ) )
ALTSGN = -ALTSGN
130 CONTINUE
KASE = 1
JUMP = 5
RETURN
*
* ................ ENTRY (JUMP = 5)
* X HAS BEEN OVERWRITTEN BY A*X.
*
140 CONTINUE
TEMP = TWO*( SASUM( N, X, 1 ) / REAL( 3*N ) )
IF( TEMP.GT.EST ) THEN
CALL SCOPY( N, X, 1, V, 1 )
EST = TEMP
END IF
*
150 CONTINUE
KASE = 0
RETURN
*
* End of SLACON
*
END
SUBROUTINE SLACPY( UPLO, M, N, A, LDA, B, LDB )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDA, LDB, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* SLACPY copies all or part of a two-dimensional matrix A to another
* matrix B.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies the part of the matrix A to be copied to B.
* = 'U': Upper triangular part
* = 'L': Lower triangular part
* Otherwise: All of the matrix A
*
* 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) REAL array, dimension (LDA,N)
* The m by n matrix A. If UPLO = 'U', only the upper triangle
* or trapezoid is accessed; if UPLO = 'L', only the lower
* triangle or trapezoid is accessed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (output) REAL array, dimension (LDB,N)
* On exit, B = A in the locations specified by UPLO.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,M).
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = 1, MIN( J, M )
B( I, J ) = A( I, J )
10 CONTINUE
20 CONTINUE
ELSE IF( LSAME( UPLO, 'L' ) ) THEN
DO 40 J = 1, N
DO 30 I = J, M
B( I, J ) = A( I, J )
30 CONTINUE
40 CONTINUE
ELSE
DO 60 J = 1, N
DO 50 I = 1, M
B( I, J ) = A( I, J )
50 CONTINUE
60 CONTINUE
END IF
RETURN
*
* End of SLACPY
*
END
SUBROUTINE SLADIV( A, B, C, D, P, Q )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
REAL A, B, C, D, P, Q
* ..
*
* Purpose
* =======
*
* SLADIV performs complex division in real arithmetic
*
* a + i*b
* p + i*q = ---------
* c + i*d
*
* The algorithm is due to Robert L. Smith and can be found
* in D. Knuth, The art of Computer Programming, Vol.2, p.195
*
* Arguments
* =========
*
* A (input) REAL
* B (input) REAL
* C (input) REAL
* D (input) REAL
* The scalars a, b, c, and d in the above expression.
*
* P (output) REAL
* Q (output) REAL
* The scalars p and q in the above expression.
*
* =====================================================================
*
* .. Local Scalars ..
REAL E, F
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
IF( ABS( D ).LT.ABS( C ) ) THEN
E = D / C
F = C + D*E
P = ( A+B*E ) / F
Q = ( B-A*E ) / F
ELSE
E = C / D
F = D + C*E
P = ( B+A*E ) / F
Q = ( -A+B*E ) / F
END IF
*
RETURN
*
* End of SLADIV
*
END
SUBROUTINE SLAE2( A, B, C, RT1, RT2 )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
REAL A, B, C, RT1, RT2
* ..
*
* Purpose
* =======
*
* SLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix
* [ A B ]
* [ B C ].
* On return, RT1 is the eigenvalue of larger absolute value, and RT2
* is the eigenvalue of smaller absolute value.
*
* Arguments
* =========
*
* A (input) REAL
* The (1,1) element of the 2-by-2 matrix.
*
* B (input) REAL
* The (1,2) and (2,1) elements of the 2-by-2 matrix.
*
* C (input) REAL
* The (2,2) element of the 2-by-2 matrix.
*
* RT1 (output) REAL
* The eigenvalue of larger absolute value.
*
* RT2 (output) REAL
* The eigenvalue of smaller absolute value.
*
* Further Details
* ===============
*
* RT1 is accurate to a few ulps barring over/underflow.
*
* RT2 may be inaccurate if there is massive cancellation in the
* determinant A*C-B*B; higher precision or correctly rounded or
* correctly truncated arithmetic would be needed to compute RT2
* accurately in all cases.
*
* Overflow is possible only if RT1 is within a factor of 5 of overflow.
* Underflow is harmless if the input data is 0 or exceeds
* underflow_threshold / macheps.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E0 )
REAL TWO
PARAMETER ( TWO = 2.0E0 )
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
REAL HALF
PARAMETER ( HALF = 0.5E0 )
* ..
* .. Local Scalars ..
REAL AB, ACMN, ACMX, ADF, DF, RT, SM, TB
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SQRT
* ..
* .. Executable Statements ..
*
* Compute the eigenvalues
*
SM = A + C
DF = A - C
ADF = ABS( DF )
TB = B + B
AB = ABS( TB )
IF( ABS( A ).GT.ABS( C ) ) THEN
ACMX = A
ACMN = C
ELSE
ACMX = C
ACMN = A
END IF
IF( ADF.GT.AB ) THEN
RT = ADF*SQRT( ONE+( AB / ADF )**2 )
ELSE IF( ADF.LT.AB ) THEN
RT = AB*SQRT( ONE+( ADF / AB )**2 )
ELSE
*
* Includes case AB=ADF=0
*
RT = AB*SQRT( TWO )
END IF
IF( SM.LT.ZERO ) THEN
RT1 = HALF*( SM-RT )
*
* Order of execution important.
* To get fully accurate smaller eigenvalue,
* next line needs to be executed in higher precision.
*
RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
ELSE IF( SM.GT.ZERO ) THEN
RT1 = HALF*( SM+RT )
*
* Order of execution important.
* To get fully accurate smaller eigenvalue,
* next line needs to be executed in higher precision.
*
RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
ELSE
*
* Includes case RT1 = RT2 = 0
*
RT1 = HALF*RT
RT2 = -HALF*RT
END IF
RETURN
*
* End of SLAE2
*
END
SUBROUTINE SLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL,
$ RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT,
$ NAB, WORK, IWORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IJOB, INFO, MINP, MMAX, MOUT, N, NBMIN, NITMAX
REAL ABSTOL, PIVMIN, RELTOL
* ..
* .. Array Arguments ..
INTEGER IWORK( * ), NAB( MMAX, * ), NVAL( * )
REAL AB( MMAX, * ), C( * ), D( * ), E( * ), E2( * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* SLAEBZ contains the iteration loops which compute and use the
* function N(w), which is the count of eigenvalues of a symmetric
* tridiagonal matrix T less than or equal to its argument w. It
* performs a choice of two types of loops:
*
* IJOB=1, followed by
* IJOB=2: It takes as input a list of intervals and returns a list of
* sufficiently small intervals whose union contains the same
* eigenvalues as the union of the original intervals.
* The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP.
* The output interval (AB(j,1),AB(j,2)] will contain
* eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT.
*
* IJOB=3: It performs a binary search in each input interval
* (AB(j,1),AB(j,2)] for a point w(j) such that
* N(w(j))=NVAL(j), and uses C(j) as the starting point of
* the search. If such a w(j) is found, then on output
* AB(j,1)=AB(j,2)=w. If no such w(j) is found, then on output
* (AB(j,1),AB(j,2)] will be a small interval containing the
* point where N(w) jumps through NVAL(j), unless that point
* lies outside the initial interval.
*
* Note that the intervals are in all cases half-open intervals,
* i.e., of the form (a,b] , which includes b but not a .
*
* To avoid underflow, the matrix should be scaled so that its largest
* element is no greater than overflow**(1/2) * underflow**(1/4)
* in absolute value. To assure the most accurate computation
* of small eigenvalues, the matrix should be scaled to be
* not much smaller than that, either.
*
* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
* Matrix", Report CS41, Computer Science Dept., Stanford
* University, July 21, 1966
*
* Note: the arguments are, in general, *not* checked for unreasonable
* values.
*
* Arguments
* =========
*
* IJOB (input) INTEGER
* Specifies what is to be done:
* = 1: Compute NAB for the initial intervals.
* = 2: Perform bisection iteration to find eigenvalues of T.
* = 3: Perform bisection iteration to invert N(w), i.e.,
* to find a point which has a specified number of
* eigenvalues of T to its left.
* Other values will cause SLAEBZ to return with INFO=-1.
*
* NITMAX (input) INTEGER
* The maximum number of "levels" of bisection to be
* performed, i.e., an interval of width W will not be made
* smaller than 2^(-NITMAX) * W. If not all intervals
* have converged after NITMAX iterations, then INFO is set
* to the number of non-converged intervals.
*
* N (input) INTEGER
* The dimension n of the tridiagonal matrix T. It must be at
* least 1.
*
* MMAX (input) INTEGER
* The maximum number of intervals. If more than MMAX intervals
* are generated, then SLAEBZ will quit with INFO=MMAX+1.
*
* MINP (input) INTEGER
* The initial number of intervals. It may not be greater than
* MMAX.
*
* NBMIN (input) INTEGER
* The smallest number of intervals that should be processed
* using a vector loop. If zero, then only the scalar loop
* will be used.
*
* ABSTOL (input) REAL
* The minimum (absolute) width of an interval. When an
* interval is narrower than ABSTOL, or than RELTOL times the
* larger (in magnitude) endpoint, then it is considered to be
* sufficiently small, i.e., converged. This must be at least
* zero.
*
* RELTOL (input) REAL
* The minimum relative width of an interval. When an interval
* is narrower than ABSTOL, or than RELTOL times the larger (in
* magnitude) endpoint, then it is considered to be
* sufficiently small, i.e., converged. Note: this should
* always be at least radix*machine epsilon.
*
* PIVMIN (input) REAL
* The minimum absolute value of a "pivot" in the Sturm
* sequence loop. This *must* be at least max |e(j)**2| *
* safe_min and at least safe_min, where safe_min is at least
* the smallest number that can divide one without overflow.
*
* D (input) REAL array, dimension (N)
* The diagonal elements of the tridiagonal matrix T.
*
* E (input) REAL array, dimension (N)
* The offdiagonal elements of the tridiagonal matrix T in
* positions 1 through N-1. E(N) is arbitrary.
*
* E2 (input) REAL array, dimension (N)
* The squares of the offdiagonal elements of the tridiagonal
* matrix T. E2(N) is ignored.
*
* NVAL (input/output) INTEGER array, dimension (MINP)
* If IJOB=1 or 2, not referenced.
* If IJOB=3, the desired values of N(w). The elements of NVAL
* will be reordered to correspond with the intervals in AB.
* Thus, NVAL(j) on output will not, in general be the same as
* NVAL(j) on input, but it will correspond with the interval
* (AB(j,1),AB(j,2)] on output.
*
* AB (input/output) REAL array, dimension (MMAX,2)
* The endpoints of the intervals. AB(j,1) is a(j), the left
* endpoint of the j-th interval, and AB(j,2) is b(j), the
* right endpoint of the j-th interval. The input intervals
* will, in general, be modified, split, and reordered by the
* calculation.
*
* C (input/output) REAL array, dimension (MMAX)
* If IJOB=1, ignored.
* If IJOB=2, workspace.
* If IJOB=3, then on input C(j) should be initialized to the
* first search point in the binary search.
*
* MOUT (output) INTEGER
* If IJOB=1, the number of eigenvalues in the intervals.
* If IJOB=2 or 3, the number of intervals output.
* If IJOB=3, MOUT will equal MINP.
*
* NAB (input/output) INTEGER array, dimension (MMAX,2)
* If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)).
* If IJOB=2, then on input, NAB(i,j) should be set. It must
* satisfy the condition:
* N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)),
* which means that in interval i only eigenvalues
* NAB(i,1)+1,...,NAB(i,2) will be considered. Usually,
* NAB(i,j)=N(AB(i,j)), from a previous call to SLAEBZ with
* IJOB=1.
* On output, NAB(i,j) will contain
* max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of
* the input interval that the output interval
* (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the
* the input values of NAB(k,1) and NAB(k,2).
* If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)),
* unless N(w) > NVAL(i) for all search points w , in which
* case NAB(i,1) will not be modified, i.e., the output
* value will be the same as the input value (modulo
* reorderings -- see NVAL and AB), or unless N(w) < NVAL(i)
* for all search points w , in which case NAB(i,2) will
* not be modified. Normally, NAB should be set to some
* distinctive value(s) before SLAEBZ is called.
*
* WORK (workspace) REAL array, dimension (MMAX)
* Workspace.
*
* IWORK (workspace) INTEGER array, dimension (MMAX)
* Workspace.
*
* INFO (output) INTEGER
* = 0: All intervals converged.
* = 1--MMAX: The last INFO intervals did not converge.
* = MMAX+1: More than MMAX intervals were generated.
*
* Further Details
* ===============
*
* This routine is intended to be called only by other LAPACK
* routines, thus the interface is less user-friendly. It is intended
* for two purposes:
*
* (a) finding eigenvalues. In this case, SLAEBZ should have one or
* more initial intervals set up in AB, and SLAEBZ should be called
* with IJOB=1. This sets up NAB, and also counts the eigenvalues.
* Intervals with no eigenvalues would usually be thrown out at
* this point. Also, if not all the eigenvalues in an interval i
* are desired, NAB(i,1) can be increased or NAB(i,2) decreased.
* For example, set NAB(i,1)=NAB(i,2)-1 to get the largest
* eigenvalue. SLAEBZ is then called with IJOB=2 and MMAX
* no smaller than the value of MOUT returned by the call with
* IJOB=1. After this (IJOB=2) call, eigenvalues NAB(i,1)+1
* through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the
* tolerance specified by ABSTOL and RELTOL.
*
* (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l).
* In this case, start with a Gershgorin interval (a,b). Set up
* AB to contain 2 search intervals, both initially (a,b). One
* NVAL element should contain f-1 and the other should contain l
* , while C should contain a and b, resp. NAB(i,1) should be -1
* and NAB(i,2) should be N+1, to flag an error if the desired
* interval does not lie in (a,b). SLAEBZ is then called with
* IJOB=3. On exit, if w(f-1) < w(f), then one of the intervals --
* j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while
* if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r
* >= 0, then the interval will have N(AB(j,1))=NAB(j,1)=f-k and
* N(AB(j,2))=NAB(j,2)=f+r. The cases w(l) < w(l+1) and
* w(l-r)=...=w(l+k) are handled similarly.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, TWO, HALF
PARAMETER ( ZERO = 0.0E0, TWO = 2.0E0,
$ HALF = 1.0E0 / TWO )
* ..
* .. Local Scalars ..
INTEGER ITMP1, ITMP2, J, JI, JIT, JP, KF, KFNEW, KL,
$ KLNEW
REAL TMP1, TMP2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Check for Errors
*
INFO = 0
IF( IJOB.LT.1 .OR. IJOB.GT.3 ) THEN
INFO = -1
RETURN
END IF
*
* Initialize NAB
*
IF( IJOB.EQ.1 ) THEN
*
* Compute the number of eigenvalues in the initial intervals.
*
MOUT = 0
CDIR$ NOVECTOR
DO 30 JI = 1, MINP
DO 20 JP = 1, 2
TMP1 = D( 1 ) - AB( JI, JP )
IF( ABS( TMP1 ).LT.PIVMIN )
$ TMP1 = -PIVMIN
NAB( JI, JP ) = 0
IF( TMP1.LE.ZERO )
$ NAB( JI, JP ) = 1
*
DO 10 J = 2, N
TMP1 = D( J ) - E2( J-1 ) / TMP1 - AB( JI, JP )
IF( ABS( TMP1 ).LT.PIVMIN )
$ TMP1 = -PIVMIN
IF( TMP1.LE.ZERO )
$ NAB( JI, JP ) = NAB( JI, JP ) + 1
10 CONTINUE
20 CONTINUE
MOUT = MOUT + NAB( JI, 2 ) - NAB( JI, 1 )
30 CONTINUE
RETURN
END IF
*
* Initialize for loop
*
* KF and KL have the following meaning:
* Intervals 1,...,KF-1 have converged.
* Intervals KF,...,KL still need to be refined.
*
KF = 1
KL = MINP
*
* If IJOB=2, initialize C.
* If IJOB=3, use the user-supplied starting point.
*
IF( IJOB.EQ.2 ) THEN
DO 40 JI = 1, MINP
C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) )
40 CONTINUE
END IF
*
* Iteration loop
*
DO 130 JIT = 1, NITMAX
*
* Loop over intervals
*
IF( KL-KF+1.GE.NBMIN .AND. NBMIN.GT.0 ) THEN
*
* Begin of Parallel Version of the loop
*
DO 60 JI = KF, KL
*
* Compute N(c), the number of eigenvalues less than c
*
WORK( JI ) = D( 1 ) - C( JI )
IWORK( JI ) = 0
IF( WORK( JI ).LE.PIVMIN ) THEN
IWORK( JI ) = 1
WORK( JI ) = MIN( WORK( JI ), -PIVMIN )
END IF
*
DO 50 J = 2, N
WORK( JI ) = D( J ) - E2( J-1 ) / WORK( JI ) - C( JI )
IF( WORK( JI ).LE.PIVMIN ) THEN
IWORK( JI ) = IWORK( JI ) + 1
WORK( JI ) = MIN( WORK( JI ), -PIVMIN )
END IF
50 CONTINUE
60 CONTINUE
*
IF( IJOB.LE.2 ) THEN
*
* IJOB=2: Choose all intervals containing eigenvalues.
*
KLNEW = KL
DO 70 JI = KF, KL
*
* Insure that N(w) is monotone
*
IWORK( JI ) = MIN( NAB( JI, 2 ),
$ MAX( NAB( JI, 1 ), IWORK( JI ) ) )
*
* Update the Queue -- add intervals if both halves
* contain eigenvalues.
*
IF( IWORK( JI ).EQ.NAB( JI, 2 ) ) THEN
*
* No eigenvalue in the upper interval:
* just use the lower interval.
*
AB( JI, 2 ) = C( JI )
*
ELSE IF( IWORK( JI ).EQ.NAB( JI, 1 ) ) THEN
*
* No eigenvalue in the lower interval:
* just use the upper interval.
*
AB( JI, 1 ) = C( JI )
ELSE
KLNEW = KLNEW + 1
IF( KLNEW.LE.MMAX ) THEN
*
* Eigenvalue in both intervals -- add upper to
* queue.
*
AB( KLNEW, 2 ) = AB( JI, 2 )
NAB( KLNEW, 2 ) = NAB( JI, 2 )
AB( KLNEW, 1 ) = C( JI )
NAB( KLNEW, 1 ) = IWORK( JI )
AB( JI, 2 ) = C( JI )
NAB( JI, 2 ) = IWORK( JI )
ELSE
INFO = MMAX + 1
END IF
END IF
70 CONTINUE
IF( INFO.NE.0 )
$ RETURN
KL = KLNEW
ELSE
*
* IJOB=3: Binary search. Keep only the interval containing
* w s.t. N(w) = NVAL
*
DO 80 JI = KF, KL
IF( IWORK( JI ).LE.NVAL( JI ) ) THEN
AB( JI, 1 ) = C( JI )
NAB( JI, 1 ) = IWORK( JI )
END IF
IF( IWORK( JI ).GE.NVAL( JI ) ) THEN
AB( JI, 2 ) = C( JI )
NAB( JI, 2 ) = IWORK( JI )
END IF
80 CONTINUE
END IF
*
ELSE
*
* End of Parallel Version of the loop
*
* Begin of Serial Version of the loop
*
KLNEW = KL
DO 100 JI = KF, KL
*
* Compute N(w), the number of eigenvalues less than w
*
TMP1 = C( JI )
TMP2 = D( 1 ) - TMP1
ITMP1 = 0
IF( TMP2.LE.PIVMIN ) THEN
ITMP1 = 1
TMP2 = MIN( TMP2, -PIVMIN )
END IF
*
* A series of compiler directives to defeat vectorization
* for the next loop
*
*$PL$ CMCHAR=' '
CDIR$ NEXTSCALAR
C$DIR SCALAR
CDIR$ NEXT SCALAR
CVD$L NOVECTOR
CDEC$ NOVECTOR
CVD$ NOVECTOR
*VDIR NOVECTOR
*VOCL LOOP,SCALAR
CIBM PREFER SCALAR
*$PL$ CMCHAR='*'
*
DO 90 J = 2, N
TMP2 = D( J ) - E2( J-1 ) / TMP2 - TMP1
IF( TMP2.LE.PIVMIN ) THEN
ITMP1 = ITMP1 + 1
TMP2 = MIN( TMP2, -PIVMIN )
END IF
90 CONTINUE
*
IF( IJOB.LE.2 ) THEN
*
* IJOB=2: Choose all intervals containing eigenvalues.
*
* Insure that N(w) is monotone
*
ITMP1 = MIN( NAB( JI, 2 ),
$ MAX( NAB( JI, 1 ), ITMP1 ) )
*
* Update the Queue -- add intervals if both halves
* contain eigenvalues.
*
IF( ITMP1.EQ.NAB( JI, 2 ) ) THEN
*
* No eigenvalue in the upper interval:
* just use the lower interval.
*
AB( JI, 2 ) = TMP1
*
ELSE IF( ITMP1.EQ.NAB( JI, 1 ) ) THEN
*
* No eigenvalue in the lower interval:
* just use the upper interval.
*
AB( JI, 1 ) = TMP1
ELSE IF( KLNEW.LT.MMAX ) THEN
*
* Eigenvalue in both intervals -- add upper to queue.
*
KLNEW = KLNEW + 1
AB( KLNEW, 2 ) = AB( JI, 2 )
NAB( KLNEW, 2 ) = NAB( JI, 2 )
AB( KLNEW, 1 ) = TMP1
NAB( KLNEW, 1 ) = ITMP1
AB( JI, 2 ) = TMP1
NAB( JI, 2 ) = ITMP1
ELSE
INFO = MMAX + 1
RETURN
END IF
ELSE
*
* IJOB=3: Binary search. Keep only the interval
* containing w s.t. N(w) = NVAL
*
IF( ITMP1.LE.NVAL( JI ) ) THEN
AB( JI, 1 ) = TMP1
NAB( JI, 1 ) = ITMP1
END IF
IF( ITMP1.GE.NVAL( JI ) ) THEN
AB( JI, 2 ) = TMP1
NAB( JI, 2 ) = ITMP1
END IF
END IF
100 CONTINUE
KL = KLNEW
*
* End of Serial Version of the loop
*
END IF
*
* Check for convergence
*
KFNEW = KF
DO 110 JI = KF, KL
TMP1 = ABS( AB( JI, 2 )-AB( JI, 1 ) )
TMP2 = MAX( ABS( AB( JI, 2 ) ), ABS( AB( JI, 1 ) ) )
IF( TMP1.LT.MAX( ABSTOL, PIVMIN, RELTOL*TMP2 ) .OR.
$ NAB( JI, 1 ).GE.NAB( JI, 2 ) ) THEN
*
* Converged -- Swap with position KFNEW,
* then increment KFNEW
*
IF( JI.GT.KFNEW ) THEN
TMP1 = AB( JI, 1 )
TMP2 = AB( JI, 2 )
ITMP1 = NAB( JI, 1 )
ITMP2 = NAB( JI, 2 )
AB( JI, 1 ) = AB( KFNEW, 1 )
AB( JI, 2 ) = AB( KFNEW, 2 )
NAB( JI, 1 ) = NAB( KFNEW, 1 )
NAB( JI, 2 ) = NAB( KFNEW, 2 )
AB( KFNEW, 1 ) = TMP1
AB( KFNEW, 2 ) = TMP2
NAB( KFNEW, 1 ) = ITMP1
NAB( KFNEW, 2 ) = ITMP2
IF( IJOB.EQ.3 ) THEN
ITMP1 = NVAL( JI )
NVAL( JI ) = NVAL( KFNEW )
NVAL( KFNEW ) = ITMP1
END IF
END IF
KFNEW = KFNEW + 1
END IF
110 CONTINUE
KF = KFNEW
*
* Choose Midpoints
*
DO 120 JI = KF, KL
C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) )
120 CONTINUE
*
* If no more intervals to refine, quit.
*
IF( KF.GT.KL )
$ GO TO 140
130 CONTINUE
*
* Converged
*
140 CONTINUE
INFO = MAX( KL+1-KF, 0 )
MOUT = KL
*
RETURN
*
* End of SLAEBZ
*
END
SUBROUTINE SLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS,
$ WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* SLAED0 computes all eigenvalues and corresponding eigenvectors of a
* symmetric tridiagonal matrix using the divide and conquer method.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* = 0: Compute eigenvalues only.
* = 1: Compute eigenvectors of original dense symmetric matrix
* also. On entry, Q contains the orthogonal matrix used
* to reduce the original matrix to tridiagonal form.
* = 2: Compute eigenvalues and eigenvectors of tridiagonal
* matrix.
*
* QSIZ (input) INTEGER
* The dimension of the orthogonal matrix used to reduce
* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* D (input/output) REAL array, dimension (N)
* On entry, the main diagonal of the tridiagonal matrix.
* On exit, its eigenvalues.
*
* E (input) REAL array, dimension (N-1)
* The off-diagonal elements of the tridiagonal matrix.
* On exit, E has been destroyed.
*
* Q (input/output) REAL array, dimension (LDQ, N)
* On entry, Q must contain an N-by-N orthogonal matrix.
* If ICOMPQ = 0 Q is not referenced.
* If ICOMPQ = 1 On entry, Q is a subset of the columns of the
* orthogonal matrix used to reduce the full
* matrix to tridiagonal form corresponding to
* the subset of the full matrix which is being
* decomposed at this time.
* If ICOMPQ = 2 On entry, Q will be the identity matrix.
* On exit, Q contains the eigenvectors of the
* tridiagonal matrix.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. If eigenvectors are
* desired, then LDQ >= max(1,N). In any case, LDQ >= 1.
*
* QSTORE (workspace) REAL array, dimension (LDQS, N)
* Referenced only when ICOMPQ = 1. Used to store parts of
* the eigenvector matrix when the updating matrix multiplies
* take place.
*
* LDQS (input) INTEGER
* The leading dimension of the array QSTORE. If ICOMPQ = 1,
* then LDQS >= max(1,N). In any case, LDQS >= 1.
*
* WORK (workspace) REAL array,
* If ICOMPQ = 0 or 1, the dimension of WORK must be at least
* 1 + 3*N + 2*N*lg N + 2*N**2
* ( lg( N ) = smallest integer k
* such that 2^k >= N )
* If ICOMPQ = 2, the dimension of WORK must be at least
* 4*N + N**2.
*
* IWORK (workspace) INTEGER array,
* If ICOMPQ = 0 or 1, the dimension of IWORK must be at least
* 6 + 6*N + 5*N*lg N.
* ( lg( N ) = smallest integer k
* such that 2^k >= N )
* If ICOMPQ = 2, the dimension of IWORK must be at least
* 3 + 5*N.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: The algorithm failed to compute an eigenvalue while
* working on the submatrix lying in rows and columns
* INFO/(N+1) through mod(INFO,N+1).
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO
PARAMETER ( ZERO = 0.E0, ONE = 1.E0, TWO = 2.E0 )
* ..
* .. Local Scalars ..
INTEGER CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM,
$ IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM,
$ J, K, LGN, MATSIZ, MSD2, SMLSIZ, SMM1, SPM1,
$ SPM2, SUBMAT, SUBPBS, TLVLS
REAL TEMP
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMM, SLACPY, SLAED1, SLAED7, SSTEQR,
$ XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX, REAL
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.2 ) THEN
INFO = -1
ELSE IF( ( ICOMPQ.EQ.1 ) .AND. ( QSIZ.LT.MAX( 0, N ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDQS.LT.MAX( 1, N ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLAED0', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
SMLSIZ = ILAENV( 9, 'SLAED0', ' ', 0, 0, 0, 0 )
*
* Determine the size and placement of the submatrices, and save in
* the leading elements of IWORK.
*
IWORK( 1 ) = N
SUBPBS = 1
TLVLS = 0
10 CONTINUE
IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN
DO 20 J = SUBPBS, 1, -1
IWORK( 2*J ) = ( IWORK( J )+1 ) / 2
IWORK( 2*J-1 ) = IWORK( J ) / 2
20 CONTINUE
TLVLS = TLVLS + 1
SUBPBS = 2*SUBPBS
GO TO 10
END IF
DO 30 J = 2, SUBPBS
IWORK( J ) = IWORK( J ) + IWORK( J-1 )
30 CONTINUE
*
* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1
* using rank-1 modifications (cuts).
*
SPM1 = SUBPBS - 1
DO 40 I = 1, SPM1
SUBMAT = IWORK( I ) + 1
SMM1 = SUBMAT - 1
D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) )
D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) )
40 CONTINUE
*
INDXQ = 4*N + 3
IF( ICOMPQ.NE.2 ) THEN
*
* Set up workspaces for eigenvalues only/accumulate new vectors
* routine
*
TEMP = LOG( REAL( N ) ) / LOG( TWO )
LGN = INT( TEMP )
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IPRMPT = INDXQ + N + 1
IPERM = IPRMPT + N*LGN
IQPTR = IPERM + N*LGN
IGIVPT = IQPTR + N + 2
IGIVCL = IGIVPT + N*LGN
*
IGIVNM = 1
IQ = IGIVNM + 2*N*LGN
IWREM = IQ + N**2 + 1
*
* Initialize pointers
*
DO 50 I = 0, SUBPBS
IWORK( IPRMPT+I ) = 1
IWORK( IGIVPT+I ) = 1
50 CONTINUE
IWORK( IQPTR ) = 1
END IF
*
* Solve each submatrix eigenproblem at the bottom of the divide and
* conquer tree.
*
CURR = 0
DO 70 I = 0, SPM1
IF( I.EQ.0 ) THEN
SUBMAT = 1
MATSIZ = IWORK( 1 )
ELSE
SUBMAT = IWORK( I ) + 1
MATSIZ = IWORK( I+1 ) - IWORK( I )
END IF
IF( ICOMPQ.EQ.2 ) THEN
CALL SSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
$ Q( SUBMAT, SUBMAT ), LDQ, WORK, INFO )
IF( INFO.NE.0 )
$ GO TO 130
ELSE
CALL SSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
$ WORK( IQ-1+IWORK( IQPTR+CURR ) ), MATSIZ, WORK,
$ INFO )
IF( INFO.NE.0 )
$ GO TO 130
IF( ICOMPQ.EQ.1 ) THEN
CALL SGEMM( 'N', 'N', QSIZ, MATSIZ, MATSIZ, ONE,
$ Q( 1, SUBMAT ), LDQ, WORK( IQ-1+IWORK( IQPTR+
$ CURR ) ), MATSIZ, ZERO, QSTORE( 1, SUBMAT ),
$ LDQS )
END IF
IWORK( IQPTR+CURR+1 ) = IWORK( IQPTR+CURR ) + MATSIZ**2
CURR = CURR + 1
END IF
K = 1
DO 60 J = SUBMAT, IWORK( I+1 )
IWORK( INDXQ+J ) = K
K = K + 1
60 CONTINUE
70 CONTINUE
*
* Successively merge eigensystems of adjacent submatrices
* into eigensystem for the corresponding larger matrix.
*
* while ( SUBPBS > 1 )
*
CURLVL = 1
80 CONTINUE
IF( SUBPBS.GT.1 ) THEN
SPM2 = SUBPBS - 2
DO 90 I = 0, SPM2, 2
IF( I.EQ.0 ) THEN
SUBMAT = 1
MATSIZ = IWORK( 2 )
MSD2 = IWORK( 1 )
CURPRB = 0
ELSE
SUBMAT = IWORK( I ) + 1
MATSIZ = IWORK( I+2 ) - IWORK( I )
MSD2 = MATSIZ / 2
CURPRB = CURPRB + 1
END IF
*
* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2)
* into an eigensystem of size MATSIZ.
* SLAED1 is used only for the full eigensystem of a tridiagonal
* matrix.
* SLAED7 handles the cases in which eigenvalues only or eigenvalues
* and eigenvectors of a full symmetric matrix (which was reduced to
* tridiagonal form) are desired.
*
IF( ICOMPQ.EQ.2 ) THEN
CALL SLAED1( MATSIZ, D( SUBMAT ), Q( SUBMAT, SUBMAT ),
$ LDQ, IWORK( INDXQ+SUBMAT ),
$ E( SUBMAT+MSD2-1 ), MSD2, WORK,
$ IWORK( SUBPBS+1 ), INFO )
ELSE
CALL SLAED7( ICOMPQ, MATSIZ, QSIZ, TLVLS, CURLVL, CURPRB,
$ D( SUBMAT ), QSTORE( 1, SUBMAT ), LDQS,
$ IWORK( INDXQ+SUBMAT ), E( SUBMAT+MSD2-1 ),
$ MSD2, WORK( IQ ), IWORK( IQPTR ),
$ IWORK( IPRMPT ), IWORK( IPERM ),
$ IWORK( IGIVPT ), IWORK( IGIVCL ),
$ WORK( IGIVNM ), WORK( IWREM ),
$ IWORK( SUBPBS+1 ), INFO )
END IF
IF( INFO.NE.0 )
$ GO TO 130
IWORK( I / 2+1 ) = IWORK( I+2 )
90 CONTINUE
SUBPBS = SUBPBS / 2
CURLVL = CURLVL + 1
GO TO 80
END IF
*
* end while
*
* Re-merge the eigenvalues/vectors which were deflated at the final
* merge step.
*
IF( ICOMPQ.EQ.1 ) THEN
DO 100 I = 1, N
J = IWORK( INDXQ+I )
WORK( I ) = D( J )
CALL SCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 )
100 CONTINUE
CALL SCOPY( N, WORK, 1, D, 1 )
ELSE IF( ICOMPQ.EQ.2 ) THEN
DO 110 I = 1, N
J = IWORK( INDXQ+I )
WORK( I ) = D( J )
CALL SCOPY( N, Q( 1, J ), 1, WORK( N*I+1 ), 1 )
110 CONTINUE
CALL SCOPY( N, WORK, 1, D, 1 )
CALL SLACPY( 'A', N, N, WORK( N+1 ), N, Q, LDQ )
ELSE
DO 120 I = 1, N
J = IWORK( INDXQ+I )
WORK( I ) = D( J )
120 CONTINUE
CALL SCOPY( N, WORK, 1, D, 1 )
END IF
GO TO 140
*
130 CONTINUE
INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1
*
140 CONTINUE
RETURN
*
* End of SLAED0
*
END
SUBROUTINE SLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER CUTPNT, INFO, LDQ, N
REAL RHO
* ..
* .. Array Arguments ..
INTEGER INDXQ( * ), IWORK( * )
REAL D( * ), Q( LDQ, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SLAED1 computes the updated eigensystem of a diagonal
* matrix after modification by a rank-one symmetric matrix. This
* routine is used only for the eigenproblem which requires all
* eigenvalues and eigenvectors of a tridiagonal matrix. SLAED7 handles
* the case in which eigenvalues only or eigenvalues and eigenvectors
* of a full symmetric matrix (which was reduced to tridiagonal form)
* are desired.
*
* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)
*
* where Z = Q'u, u is a vector of length N with ones in the
* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
*
* The eigenvectors of the original matrix are stored in Q, and the
* eigenvalues are in D. The algorithm consists of three stages:
*
* The first stage consists of deflating the size of the problem
* when there are multiple eigenvalues or if there is a zero in
* the Z vector. For each such occurence the dimension of the
* secular equation problem is reduced by one. This stage is
* performed by the routine SLAED2.
*
* The second stage consists of calculating the updated
* eigenvalues. This is done by finding the roots of the secular
* equation via the routine SLAED4 (as called by SLAED3).
* This routine also calculates the eigenvectors of the current
* problem.
*
* The final stage consists of computing the updated eigenvectors
* directly using the updated eigenvalues. The eigenvectors for
* the current problem are multiplied with the eigenvectors from
* the overall problem.
*
* Arguments
* =========
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* D (input/output) REAL array, dimension (N)
* On entry, the eigenvalues of the rank-1-perturbed matrix.
* On exit, the eigenvalues of the repaired matrix.
*
* Q (input/output) REAL array, dimension (LDQ,N)
* On entry, the eigenvectors of the rank-1-perturbed matrix.
* On exit, the eigenvectors of the repaired tridiagonal matrix.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* INDXQ (input/output) INTEGER array, dimension (N)
* On entry, the permutation which separately sorts the two
* subproblems in D into ascending order.
* On exit, the permutation which will reintegrate the
* subproblems back into sorted order,
* i.e. D( INDXQ( I = 1, N ) ) will be in ascending order.
*
* RHO (input) REAL
* The subdiagonal entry used to create the rank-1 modification.
*
* CUTPNT (input) INTEGER
* The location of the last eigenvalue in the leading sub-matrix.
* min(1,N) <= CUTPNT <= N/2.
*
* WORK (workspace) REAL array, dimension (4*N + N**2)
*
* IWORK (workspace) INTEGER array, dimension (4*N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an eigenvalue did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
* Modified by Francoise Tisseur, University of Tennessee.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER COLTYP, CPP1, I, IDLMDA, INDX, INDXC, INDXP,
$ IQ2, IS, IW, IZ, K, N1, N2
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLAED2, SLAED3, SLAMRG, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( MIN( 1, N / 2 ).GT.CUTPNT .OR. ( N / 2 ).LT.CUTPNT ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLAED1', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* The following values are integer pointers which indicate
* the portion of the workspace
* used by a particular array in SLAED2 and SLAED3.
*
IZ = 1
IDLMDA = IZ + N
IW = IDLMDA + N
IQ2 = IW + N
*
INDX = 1
INDXC = INDX + N
COLTYP = INDXC + N
INDXP = COLTYP + N
*
*
* Form the z-vector which consists of the last row of Q_1 and the
* first row of Q_2.
*
CALL SCOPY( CUTPNT, Q( CUTPNT, 1 ), LDQ, WORK( IZ ), 1 )
CPP1 = CUTPNT + 1
CALL SCOPY( N-CUTPNT, Q( CPP1, CPP1 ), LDQ, WORK( IZ+CUTPNT ), 1 )
*
* Deflate eigenvalues.
*
CALL SLAED2( K, N, CUTPNT, D, Q, LDQ, INDXQ, RHO, WORK( IZ ),
$ WORK( IDLMDA ), WORK( IW ), WORK( IQ2 ),
$ IWORK( INDX ), IWORK( INDXC ), IWORK( INDXP ),
$ IWORK( COLTYP ), INFO )
*
IF( INFO.NE.0 )
$ GO TO 20
*
* Solve Secular Equation.
*
IF( K.NE.0 ) THEN
IS = ( IWORK( COLTYP )+IWORK( COLTYP+1 ) )*CUTPNT +
$ ( IWORK( COLTYP+1 )+IWORK( COLTYP+2 ) )*( N-CUTPNT ) + IQ2
CALL SLAED3( K, N, CUTPNT, D, Q, LDQ, RHO, WORK( IDLMDA ),
$ WORK( IQ2 ), IWORK( INDXC ), IWORK( COLTYP ),
$ WORK( IW ), WORK( IS ), INFO )
IF( INFO.NE.0 )
$ GO TO 20
*
* Prepare the INDXQ sorting permutation.
*
N1 = K
N2 = N - K
CALL SLAMRG( N1, N2, D, 1, -1, INDXQ )
ELSE
DO 10 I = 1, N
INDXQ( I ) = I
10 CONTINUE
END IF
*
20 CONTINUE
RETURN
*
* End of SLAED1
*
END
SUBROUTINE SLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W,
$ Q2, INDX, INDXC, INDXP, COLTYP, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDQ, N, N1
REAL RHO
* ..
* .. Array Arguments ..
INTEGER COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ),
$ INDXQ( * )
REAL D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
$ W( * ), Z( * )
* ..
*
* Purpose
* =======
*
* SLAED2 merges the two sets of eigenvalues together into a single
* sorted set. Then it tries to deflate the size of the problem.
* There are two ways in which deflation can occur: when two or more
* eigenvalues are close together or if there is a tiny entry in the
* Z vector. For each such occurrence the order of the related secular
* equation problem is reduced by one.
*
* Arguments
* =========
*
* K (output) INTEGER
* The number of non-deflated eigenvalues, and the order of the
* related secular equation. 0 <= K <=N.
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* N1 (input) INTEGER
* The location of the last eigenvalue in the leading sub-matrix.
* min(1,N) <= N1 <= N/2.
*
* D (input/output) REAL array, dimension (N)
* On entry, D contains the eigenvalues of the two submatrices to
* be combined.
* On exit, D contains the trailing (N-K) updated eigenvalues
* (those which were deflated) sorted into increasing order.
*
* Q (input/output) REAL array, dimension (LDQ, N)
* On entry, Q contains the eigenvectors of two submatrices in
* the two square blocks with corners at (1,1), (N1,N1)
* and (N1+1, N1+1), (N,N).
* On exit, Q contains the trailing (N-K) updated eigenvectors
* (those which were deflated) in its last N-K columns.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* INDXQ (input/output) INTEGER array, dimension (N)
* The permutation which separately sorts the two sub-problems
* in D into ascending order. Note that elements in the second
* half of this permutation must first have N1 added to their
* values. Destroyed on exit.
*
* RHO (input/output) REAL
* On entry, the off-diagonal element associated with the rank-1
* cut which originally split the two submatrices which are now
* being recombined.
* On exit, RHO has been modified to the value required by
* SLAED3.
*
* Z (input) REAL array, dimension (N)
* On entry, Z contains the updating vector (the last
* row of the first sub-eigenvector matrix and the first row of
* the second sub-eigenvector matrix).
* On exit, the contents of Z have been destroyed by the updating
* process.
*
* DLAMDA (output) REAL array, dimension (N)
* A copy of the first K eigenvalues which will be used by
* SLAED3 to form the secular equation.
*
* W (output) REAL array, dimension (N)
* The first k values of the final deflation-altered z-vector
* which will be passed to SLAED3.
*
* Q2 (output) REAL array, dimension (N1**2+(N-N1)**2)
* A copy of the first K eigenvectors which will be used by
* SLAED3 in a matrix multiply (SGEMM) to solve for the new
* eigenvectors.
*
* INDX (workspace) INTEGER array, dimension (N)
* The permutation used to sort the contents of DLAMDA into
* ascending order.
*
* INDXC (output) INTEGER array, dimension (N)
* The permutation used to arrange the columns of the deflated
* Q matrix into three groups: the first group contains non-zero
* elements only at and above N1, the second contains
* non-zero elements only below N1, and the third is dense.
*
* INDXP (workspace) INTEGER array, dimension (N)
* The permutation used to place deflated values of D at the end
* of the array. INDXP(1:K) points to the nondeflated D-values
* and INDXP(K+1:N) points to the deflated eigenvalues.
*
* COLTYP (workspace/output) INTEGER array, dimension (N)
* During execution, a label which will indicate which of the
* following types a column in the Q2 matrix is:
* 1 : non-zero in the upper half only;
* 2 : dense;
* 3 : non-zero in the lower half only;
* 4 : deflated.
* On exit, COLTYP(i) is the number of columns of type i,
* for i=1 to 4 only.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
* Modified by Francoise Tisseur, University of Tennessee.
*
* =====================================================================
*
* .. Parameters ..
REAL MONE, ZERO, ONE, TWO, EIGHT
PARAMETER ( MONE = -1.0E0, ZERO = 0.0E0, ONE = 1.0E0,
$ TWO = 2.0E0, EIGHT = 8.0E0 )
* ..
* .. Local Arrays ..
INTEGER CTOT( 4 ), PSM( 4 )
* ..
* .. Local Scalars ..
INTEGER CT, I, IMAX, IQ1, IQ2, J, JMAX, JS, K2, N1P1,
$ N2, NJ, PJ
REAL C, EPS, S, T, TAU, TOL
* ..
* .. External Functions ..
INTEGER ISAMAX
REAL SLAMCH, SLAPY2
EXTERNAL ISAMAX, SLAMCH, SLAPY2
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLACPY, SLAMRG, SROT, SSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( MIN( 1, ( N / 2 ) ).GT.N1 .OR. ( N / 2 ).LT.N1 ) THEN
INFO = -3
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLAED2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
N2 = N - N1
N1P1 = N1 + 1
*
IF( RHO.LT.ZERO ) THEN
CALL SSCAL( N2, MONE, Z( N1P1 ), 1 )
END IF
*
* Normalize z so that norm(z) = 1. Since z is the concatenation of
* two normalized vectors, norm2(z) = sqrt(2).
*
T = ONE / SQRT( TWO )
CALL SSCAL( N, T, Z, 1 )
*
* RHO = ABS( norm(z)**2 * RHO )
*
RHO = ABS( TWO*RHO )
*
* Sort the eigenvalues into increasing order
*
DO 10 I = N1P1, N
INDXQ( I ) = INDXQ( I ) + N1
10 CONTINUE
*
* re-integrate the deflated parts from the last pass
*
DO 20 I = 1, N
DLAMDA( I ) = D( INDXQ( I ) )
20 CONTINUE
CALL SLAMRG( N1, N2, DLAMDA, 1, 1, INDXC )
DO 30 I = 1, N
INDX( I ) = INDXQ( INDXC( I ) )
30 CONTINUE
*
* Calculate the allowable deflation tolerance
*
IMAX = ISAMAX( N, Z, 1 )
JMAX = ISAMAX( N, D, 1 )
EPS = SLAMCH( 'Epsilon' )
TOL = EIGHT*EPS*MAX( ABS( D( JMAX ) ), ABS( Z( IMAX ) ) )
*
* If the rank-1 modifier is small enough, no more needs to be done
* except to reorganize Q so that its columns correspond with the
* elements in D.
*
IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN
K = 0
IQ2 = 1
DO 40 J = 1, N
I = INDX( J )
CALL SCOPY( N, Q( 1, I ), 1, Q2( IQ2 ), 1 )
DLAMDA( J ) = D( I )
IQ2 = IQ2 + N
40 CONTINUE
CALL SLACPY( 'A', N, N, Q2, N, Q, LDQ )
CALL SCOPY( N, DLAMDA, 1, D, 1 )
GO TO 190
END IF
*
* If there are multiple eigenvalues then the problem deflates. Here
* the number of equal eigenvalues are found. As each equal
* eigenvalue is found, an elementary reflector is computed to rotate
* the corresponding eigensubspace so that the corresponding
* components of Z are zero in this new basis.
*
DO 50 I = 1, N1
COLTYP( I ) = 1
50 CONTINUE
DO 60 I = N1P1, N
COLTYP( I ) = 3
60 CONTINUE
*
*
K = 0
K2 = N + 1
DO 70 J = 1, N
NJ = INDX( J )
IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
COLTYP( NJ ) = 4
INDXP( K2 ) = NJ
IF( J.EQ.N )
$ GO TO 100
ELSE
PJ = NJ
GO TO 80
END IF
70 CONTINUE
80 CONTINUE
J = J + 1
NJ = INDX( J )
IF( J.GT.N )
$ GO TO 100
IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
COLTYP( NJ ) = 4
INDXP( K2 ) = NJ
ELSE
*
* Check if eigenvalues are close enough to allow deflation.
*
S = Z( PJ )
C = Z( NJ )
*
* Find sqrt(a**2+b**2) without overflow or
* destructive underflow.
*
TAU = SLAPY2( C, S )
T = D( NJ ) - D( PJ )
C = C / TAU
S = -S / TAU
IF( ABS( T*C*S ).LE.TOL ) THEN
*
* Deflation is possible.
*
Z( NJ ) = TAU
Z( PJ ) = ZERO
IF( COLTYP( NJ ).NE.COLTYP( PJ ) )
$ COLTYP( NJ ) = 2
COLTYP( PJ ) = 4
CALL SROT( N, Q( 1, PJ ), 1, Q( 1, NJ ), 1, C, S )
T = D( PJ )*C**2 + D( NJ )*S**2
D( NJ ) = D( PJ )*S**2 + D( NJ )*C**2
D( PJ ) = T
K2 = K2 - 1
I = 1
90 CONTINUE
IF( K2+I.LE.N ) THEN
IF( D( PJ ).LT.D( INDXP( K2+I ) ) ) THEN
INDXP( K2+I-1 ) = INDXP( K2+I )
INDXP( K2+I ) = PJ
I = I + 1
GO TO 90
ELSE
INDXP( K2+I-1 ) = PJ
END IF
ELSE
INDXP( K2+I-1 ) = PJ
END IF
PJ = NJ
ELSE
K = K + 1
DLAMDA( K ) = D( PJ )
W( K ) = Z( PJ )
INDXP( K ) = PJ
PJ = NJ
END IF
END IF
GO TO 80
100 CONTINUE
*
* Record the last eigenvalue.
*
K = K + 1
DLAMDA( K ) = D( PJ )
W( K ) = Z( PJ )
INDXP( K ) = PJ
*
* Count up the total number of the various types of columns, then
* form a permutation which positions the four column types into
* four uniform groups (although one or more of these groups may be
* empty).
*
DO 110 J = 1, 4
CTOT( J ) = 0
110 CONTINUE
DO 120 J = 1, N
CT = COLTYP( J )
CTOT( CT ) = CTOT( CT ) + 1
120 CONTINUE
*
* PSM(*) = Position in SubMatrix (of types 1 through 4)
*
PSM( 1 ) = 1
PSM( 2 ) = 1 + CTOT( 1 )
PSM( 3 ) = PSM( 2 ) + CTOT( 2 )
PSM( 4 ) = PSM( 3 ) + CTOT( 3 )
K = N - CTOT( 4 )
*
* Fill out the INDXC array so that the permutation which it induces
* will place all type-1 columns first, all type-2 columns next,
* then all type-3's, and finally all type-4's.
*
DO 130 J = 1, N
JS = INDXP( J )
CT = COLTYP( JS )
INDX( PSM( CT ) ) = JS
INDXC( PSM( CT ) ) = J
PSM( CT ) = PSM( CT ) + 1
130 CONTINUE
*
* Sort the eigenvalues and corresponding eigenvectors into DLAMDA
* and Q2 respectively. The eigenvalues/vectors which were not
* deflated go into the first K slots of DLAMDA and Q2 respectively,
* while those which were deflated go into the last N - K slots.
*
I = 1
IQ1 = 1
IQ2 = 1 + ( CTOT( 1 )+CTOT( 2 ) )*N1
DO 140 J = 1, CTOT( 1 )
JS = INDX( I )
CALL SCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 )
Z( I ) = D( JS )
I = I + 1
IQ1 = IQ1 + N1
140 CONTINUE
*
DO 150 J = 1, CTOT( 2 )
JS = INDX( I )
CALL SCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 )
CALL SCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 )
Z( I ) = D( JS )
I = I + 1
IQ1 = IQ1 + N1
IQ2 = IQ2 + N2
150 CONTINUE
*
DO 160 J = 1, CTOT( 3 )
JS = INDX( I )
CALL SCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 )
Z( I ) = D( JS )
I = I + 1
IQ2 = IQ2 + N2
160 CONTINUE
*
IQ1 = IQ2
DO 170 J = 1, CTOT( 4 )
JS = INDX( I )
CALL SCOPY( N, Q( 1, JS ), 1, Q2( IQ2 ), 1 )
IQ2 = IQ2 + N
Z( I ) = D( JS )
I = I + 1
170 CONTINUE
*
* The deflated eigenvalues and their corresponding vectors go back
* into the last N - K slots of D and Q respectively.
*
CALL SLACPY( 'A', N, CTOT( 4 ), Q2( IQ1 ), N, Q( 1, K+1 ), LDQ )
CALL SCOPY( N-K, Z( K+1 ), 1, D( K+1 ), 1 )
*
* Copy CTOT into COLTYP for referencing in SLAED3.
*
DO 180 J = 1, 4
COLTYP( J ) = CTOT( J )
180 CONTINUE
*
190 CONTINUE
RETURN
*
* End of SLAED2
*
END
SUBROUTINE SLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX,
$ CTOT, W, S, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDQ, N, N1
REAL RHO
* ..
* .. Array Arguments ..
INTEGER CTOT( * ), INDX( * )
REAL D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
$ S( * ), W( * )
* ..
*
* Purpose
* =======
*
* SLAED3 finds the roots of the secular equation, as defined by the
* values in D, W, and RHO, between 1 and K. It makes the
* appropriate calls to SLAED4 and then updates the eigenvectors by
* multiplying the matrix of eigenvectors of the pair of eigensystems
* being combined by the matrix of eigenvectors of the K-by-K system
* which is solved here.
*
* This code makes very mild assumptions about floating point
* arithmetic. It will work on machines with a guard digit in
* add/subtract, or on those binary machines without guard digits
* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
* It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Arguments
* =========
*
* K (input) INTEGER
* The number of terms in the rational function to be solved by
* SLAED4. K >= 0.
*
* N (input) INTEGER
* The number of rows and columns in the Q matrix.
* N >= K (deflation may result in N>K).
*
* N1 (input) INTEGER
* The location of the last eigenvalue in the leading submatrix.
* min(1,N) <= N1 <= N/2.
*
* D (output) REAL array, dimension (N)
* D(I) contains the updated eigenvalues for
* 1 <= I <= K.
*
* Q (output) REAL array, dimension (LDQ,N)
* Initially the first K columns are used as workspace.
* On output the columns 1 to K contain
* the updated eigenvectors.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* RHO (input) REAL
* The value of the parameter in the rank one update equation.
* RHO >= 0 required.
*
* DLAMDA (input/output) REAL array, dimension (K)
* The first K elements of this array contain the old roots
* of the deflated updating problem. These are the poles
* of the secular equation. May be changed on output by
* having lowest order bit set to zero on Cray X-MP, Cray Y-MP,
* Cray-2, or Cray C-90, as described above.
*
* Q2 (input) REAL array, dimension (LDQ2, N)
* The first K columns of this matrix contain the non-deflated
* eigenvectors for the split problem.
*
* INDX (input) INTEGER array, dimension (N)
* The permutation used to arrange the columns of the deflated
* Q matrix into three groups (see SLAED2).
* The rows of the eigenvectors found by SLAED4 must be likewise
* permuted before the matrix multiply can take place.
*
* CTOT (input) INTEGER array, dimension (4)
* A count of the total number of the various types of columns
* in Q, as described in INDX. The fourth column type is any
* column which has been deflated.
*
* W (input/output) REAL array, dimension (K)
* The first K elements of this array contain the components
* of the deflation-adjusted updating vector. Destroyed on
* output.
*
* S (workspace) REAL array, dimension (N1 + 1)*K
* Will contain the eigenvectors of the repaired matrix which
* will be multiplied by the previously accumulated eigenvectors
* to update the system.
*
* LDS (input) INTEGER
* The leading dimension of S. LDS >= max(1,K).
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an eigenvalue did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
* Modified by Francoise Tisseur, University of Tennessee.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
INTEGER I, II, IQ2, J, N12, N2, N23
REAL TEMP
* ..
* .. External Functions ..
REAL SLAMC3, SNRM2
EXTERNAL SLAMC3, SNRM2
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMM, SLACPY, SLAED4, SLASET, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( K.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.K ) THEN
INFO = -2
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLAED3', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( K.EQ.0 )
$ RETURN
*
* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
* be computed with high relative accuracy (barring over/underflow).
* This is a problem on machines without a guard digit in
* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
* which on any of these machines zeros out the bottommost
* bit of DLAMDA(I) if it is 1; this makes the subsequent
* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
* occurs. On binary machines with a guard digit (almost all
* machines) it does not change DLAMDA(I) at all. On hexadecimal
* and decimal machines with a guard digit, it slightly
* changes the bottommost bits of DLAMDA(I). It does not account
* for hexadecimal or decimal machines without guard digits
* (we know of none). We use a subroutine call to compute
* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating
* this code.
*
DO 10 I = 1, K
DLAMDA( I ) = SLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I )
10 CONTINUE
*
DO 20 J = 1, K
CALL SLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO )
*
* If the zero finder fails, the computation is terminated.
*
IF( INFO.NE.0 )
$ GO TO 120
20 CONTINUE
*
IF( K.EQ.1 )
$ GO TO 110
IF( K.EQ.2 ) THEN
DO 30 J = 1, K
W( 1 ) = Q( 1, J )
W( 2 ) = Q( 2, J )
II = INDX( 1 )
Q( 1, J ) = W( II )
II = INDX( 2 )
Q( 2, J ) = W( II )
30 CONTINUE
GO TO 110
END IF
*
* Compute updated W.
*
CALL SCOPY( K, W, 1, S, 1 )
*
* Initialize W(I) = Q(I,I)
*
CALL SCOPY( K, Q, LDQ+1, W, 1 )
DO 60 J = 1, K
DO 40 I = 1, J - 1
W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
40 CONTINUE
DO 50 I = J + 1, K
W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
50 CONTINUE
60 CONTINUE
DO 70 I = 1, K
W( I ) = SIGN( SQRT( -W( I ) ), S( I ) )
70 CONTINUE
*
* Compute eigenvectors of the modified rank-1 modification.
*
DO 100 J = 1, K
DO 80 I = 1, K
S( I ) = W( I ) / Q( I, J )
80 CONTINUE
TEMP = SNRM2( K, S, 1 )
DO 90 I = 1, K
II = INDX( I )
Q( I, J ) = S( II ) / TEMP
90 CONTINUE
100 CONTINUE
*
* Compute the updated eigenvectors.
*
110 CONTINUE
*
N2 = N - N1
N12 = CTOT( 1 ) + CTOT( 2 )
N23 = CTOT( 2 ) + CTOT( 3 )
*
CALL SLACPY( 'A', N23, K, Q( CTOT( 1 )+1, 1 ), LDQ, S, N23 )
IQ2 = N1*N12 + 1
IF( N23.NE.0 ) THEN
CALL SGEMM( 'N', 'N', N2, K, N23, ONE, Q2( IQ2 ), N2, S, N23,
$ ZERO, Q( N1+1, 1 ), LDQ )
ELSE
CALL SLASET( 'A', N2, K, ZERO, ZERO, Q( N1+1, 1 ), LDQ )
END IF
*
CALL SLACPY( 'A', N12, K, Q, LDQ, S, N12 )
IF( N12.NE.0 ) THEN
CALL SGEMM( 'N', 'N', N1, K, N12, ONE, Q2, N1, S, N12, ZERO, Q,
$ LDQ )
ELSE
CALL SLASET( 'A', N1, K, ZERO, ZERO, Q( 1, 1 ), LDQ )
END IF
*
*
120 CONTINUE
RETURN
*
* End of SLAED3
*
END
SUBROUTINE SLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER I, INFO, N
REAL DLAM, RHO
* ..
* .. Array Arguments ..
REAL D( * ), DELTA( * ), Z( * )
* ..
*
* Purpose
* =======
*
* This subroutine computes the I-th updated eigenvalue of a symmetric
* rank-one modification to a diagonal matrix whose elements are
* given in the array d, and that
*
* D(i) < D(j) for i < j
*
* and that RHO > 0. This is arranged by the calling routine, and is
* no loss in generality. The rank-one modified system is thus
*
* diag( D ) + RHO * Z * Z_transpose.
*
* where we assume the Euclidean norm of Z is 1.
*
* The method consists of approximating the rational functions in the
* secular equation by simpler interpolating rational functions.
*
* Arguments
* =========
*
* N (input) INTEGER
* The length of all arrays.
*
* I (input) INTEGER
* The index of the eigenvalue to be computed. 1 <= I <= N.
*
* D (input) REAL array, dimension (N)
* The original eigenvalues. It is assumed that they are in
* order, D(I) < D(J) for I < J.
*
* Z (input) REAL array, dimension (N)
* The components of the updating vector.
*
* DELTA (output) REAL array, dimension (N)
* If N .GT. 2, DELTA contains (D(j) - lambda_I) in its j-th
* component. If N = 1, then DELTA(1) = 1. If N = 2, see SLAED5
* for detail. The vector DELTA contains the information necessary
* to construct the eigenvectors by SLAED3 and SLAED9.
*
* RHO (input) REAL
* The scalar in the symmetric updating formula.
*
* DLAM (output) REAL
* The computed lambda_I, the I-th updated eigenvalue.
*
* INFO (output) INTEGER
* = 0: successful exit
* > 0: if INFO = 1, the updating process failed.
*
* Internal Parameters
* ===================
*
* Logical variable ORGATI (origin-at-i?) is used for distinguishing
* whether D(i) or D(i+1) is treated as the origin.
*
* ORGATI = .true. origin at i
* ORGATI = .false. origin at i+1
*
* Logical variable SWTCH3 (switch-for-3-poles?) is for noting
* if we are working with THREE poles!
*
* MAXIT is the maximum number of iterations allowed for each
* eigenvalue.
*
* Further Details
* ===============
*
* Based on contributions by
* Ren-Cang Li, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXIT
PARAMETER ( MAXIT = 30 )
REAL ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ THREE = 3.0E0, FOUR = 4.0E0, EIGHT = 8.0E0,
$ TEN = 10.0E0 )
* ..
* .. Local Scalars ..
LOGICAL ORGATI, SWTCH, SWTCH3
INTEGER II, IIM1, IIP1, IP1, ITER, J, NITER
REAL A, B, C, DEL, DLTLB, DLTUB, DPHI, DPSI, DW,
$ EPS, ERRETM, ETA, MIDPT, PHI, PREW, PSI,
$ RHOINV, TAU, TEMP, TEMP1, W
* ..
* .. Local Arrays ..
REAL ZZ( 3 )
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SLAED5, SLAED6
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Since this routine is called in an inner loop, we do no argument
* checking.
*
* Quick return for N=1 and 2.
*
INFO = 0
IF( N.EQ.1 ) THEN
*
* Presumably, I=1 upon entry
*
DLAM = D( 1 ) + RHO*Z( 1 )*Z( 1 )
DELTA( 1 ) = ONE
RETURN
END IF
IF( N.EQ.2 ) THEN
CALL SLAED5( I, D, Z, DELTA, RHO, DLAM )
RETURN
END IF
*
* Compute machine epsilon
*
EPS = SLAMCH( 'Epsilon' )
RHOINV = ONE / RHO
*
* The case I = N
*
IF( I.EQ.N ) THEN
*
* Initialize some basic variables
*
II = N - 1
NITER = 1
*
* Calculate initial guess
*
MIDPT = RHO / TWO
*
* If ||Z||_2 is not one, then TEMP should be set to
* RHO * ||Z||_2^2 / TWO
*
DO 10 J = 1, N
DELTA( J ) = ( D( J )-D( I ) ) - MIDPT
10 CONTINUE
*
PSI = ZERO
DO 20 J = 1, N - 2
PSI = PSI + Z( J )*Z( J ) / DELTA( J )
20 CONTINUE
*
C = RHOINV + PSI
W = C + Z( II )*Z( II ) / DELTA( II ) +
$ Z( N )*Z( N ) / DELTA( N )
*
IF( W.LE.ZERO ) THEN
TEMP = Z( N-1 )*Z( N-1 ) / ( D( N )-D( N-1 )+RHO ) +
$ Z( N )*Z( N ) / RHO
IF( C.LE.TEMP ) THEN
TAU = RHO
ELSE
DEL = D( N ) - D( N-1 )
A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
B = Z( N )*Z( N )*DEL
IF( A.LT.ZERO ) THEN
TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
ELSE
TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
END IF
END IF
*
* It can be proved that
* D(N)+RHO/2 <= LAMBDA(N) < D(N)+TAU <= D(N)+RHO
*
DLTLB = MIDPT
DLTUB = RHO
ELSE
DEL = D( N ) - D( N-1 )
A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
B = Z( N )*Z( N )*DEL
IF( A.LT.ZERO ) THEN
TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
ELSE
TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
END IF
*
* It can be proved that
* D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2
*
DLTLB = ZERO
DLTUB = MIDPT
END IF
*
DO 30 J = 1, N
DELTA( J ) = ( D( J )-D( I ) ) - TAU
30 CONTINUE
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 40 J = 1, II
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
40 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
TEMP = Z( N ) / DELTA( N )
PHI = Z( N )*TEMP
DPHI = TEMP*TEMP
ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
$ ABS( TAU )*( DPSI+DPHI )
*
W = RHOINV + PHI + PSI
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
DLAM = D( I ) + TAU
GO TO 250
END IF
*
IF( W.LE.ZERO ) THEN
DLTLB = MAX( DLTLB, TAU )
ELSE
DLTUB = MIN( DLTUB, TAU )
END IF
*
* Calculate the new step
*
NITER = NITER + 1
C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI
A = ( DELTA( N-1 )+DELTA( N ) )*W -
$ DELTA( N-1 )*DELTA( N )*( DPSI+DPHI )
B = DELTA( N-1 )*DELTA( N )*W
IF( C.LT.ZERO )
$ C = ABS( C )
IF( C.EQ.ZERO ) THEN
* ETA = B/A
* ETA = RHO - TAU
ETA = DLTUB - TAU
ELSE IF( A.GE.ZERO ) THEN
ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
IF( W*ETA.GT.ZERO )
$ ETA = -W / ( DPSI+DPHI )
TEMP = TAU + ETA
IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
IF( W.LT.ZERO ) THEN
ETA = ( DLTUB-TAU ) / TWO
ELSE
ETA = ( DLTLB-TAU ) / TWO
END IF
END IF
DO 50 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
50 CONTINUE
*
TAU = TAU + ETA
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 60 J = 1, II
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
60 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
TEMP = Z( N ) / DELTA( N )
PHI = Z( N )*TEMP
DPHI = TEMP*TEMP
ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
$ ABS( TAU )*( DPSI+DPHI )
*
W = RHOINV + PHI + PSI
*
* Main loop to update the values of the array DELTA
*
ITER = NITER + 1
*
DO 90 NITER = ITER, MAXIT
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
DLAM = D( I ) + TAU
GO TO 250
END IF
*
IF( W.LE.ZERO ) THEN
DLTLB = MAX( DLTLB, TAU )
ELSE
DLTUB = MIN( DLTUB, TAU )
END IF
*
* Calculate the new step
*
C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI
A = ( DELTA( N-1 )+DELTA( N ) )*W -
$ DELTA( N-1 )*DELTA( N )*( DPSI+DPHI )
B = DELTA( N-1 )*DELTA( N )*W
IF( A.GE.ZERO ) THEN
ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
IF( W*ETA.GT.ZERO )
$ ETA = -W / ( DPSI+DPHI )
TEMP = TAU + ETA
IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
IF( W.LT.ZERO ) THEN
ETA = ( DLTUB-TAU ) / TWO
ELSE
ETA = ( DLTLB-TAU ) / TWO
END IF
END IF
DO 70 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
70 CONTINUE
*
TAU = TAU + ETA
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 80 J = 1, II
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
80 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
TEMP = Z( N ) / DELTA( N )
PHI = Z( N )*TEMP
DPHI = TEMP*TEMP
ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
$ ABS( TAU )*( DPSI+DPHI )
*
W = RHOINV + PHI + PSI
90 CONTINUE
*
* Return with INFO = 1, NITER = MAXIT and not converged
*
INFO = 1
DLAM = D( I ) + TAU
GO TO 250
*
* End for the case I = N
*
ELSE
*
* The case for I < N
*
NITER = 1
IP1 = I + 1
*
* Calculate initial guess
*
DEL = D( IP1 ) - D( I )
MIDPT = DEL / TWO
DO 100 J = 1, N
DELTA( J ) = ( D( J )-D( I ) ) - MIDPT
100 CONTINUE
*
PSI = ZERO
DO 110 J = 1, I - 1
PSI = PSI + Z( J )*Z( J ) / DELTA( J )
110 CONTINUE
*
PHI = ZERO
DO 120 J = N, I + 2, -1
PHI = PHI + Z( J )*Z( J ) / DELTA( J )
120 CONTINUE
C = RHOINV + PSI + PHI
W = C + Z( I )*Z( I ) / DELTA( I ) +
$ Z( IP1 )*Z( IP1 ) / DELTA( IP1 )
*
IF( W.GT.ZERO ) THEN
*
* d(i)< the ith eigenvalue < (d(i)+d(i+1))/2
*
* We choose d(i) as origin.
*
ORGATI = .TRUE.
A = C*DEL + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 )
B = Z( I )*Z( I )*DEL
IF( A.GT.ZERO ) THEN
TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
ELSE
TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
END IF
DLTLB = ZERO
DLTUB = MIDPT
ELSE
*
* (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1)
*
* We choose d(i+1) as origin.
*
ORGATI = .FALSE.
A = C*DEL - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 )
B = Z( IP1 )*Z( IP1 )*DEL
IF( A.LT.ZERO ) THEN
TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) )
ELSE
TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C )
END IF
DLTLB = -MIDPT
DLTUB = ZERO
END IF
*
IF( ORGATI ) THEN
DO 130 J = 1, N
DELTA( J ) = ( D( J )-D( I ) ) - TAU
130 CONTINUE
ELSE
DO 140 J = 1, N
DELTA( J ) = ( D( J )-D( IP1 ) ) - TAU
140 CONTINUE
END IF
IF( ORGATI ) THEN
II = I
ELSE
II = I + 1
END IF
IIM1 = II - 1
IIP1 = II + 1
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 150 J = 1, IIM1
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
150 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
DPHI = ZERO
PHI = ZERO
DO 160 J = N, IIP1, -1
TEMP = Z( J ) / DELTA( J )
PHI = PHI + Z( J )*TEMP
DPHI = DPHI + TEMP*TEMP
ERRETM = ERRETM + PHI
160 CONTINUE
*
W = RHOINV + PHI + PSI
*
* W is the value of the secular function with
* its ii-th element removed.
*
SWTCH3 = .FALSE.
IF( ORGATI ) THEN
IF( W.LT.ZERO )
$ SWTCH3 = .TRUE.
ELSE
IF( W.GT.ZERO )
$ SWTCH3 = .TRUE.
END IF
IF( II.EQ.1 .OR. II.EQ.N )
$ SWTCH3 = .FALSE.
*
TEMP = Z( II ) / DELTA( II )
DW = DPSI + DPHI + TEMP*TEMP
TEMP = Z( II )*TEMP
W = W + TEMP
ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
$ THREE*ABS( TEMP ) + ABS( TAU )*DW
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
IF( ORGATI ) THEN
DLAM = D( I ) + TAU
ELSE
DLAM = D( IP1 ) + TAU
END IF
GO TO 250
END IF
*
IF( W.LE.ZERO ) THEN
DLTLB = MAX( DLTLB, TAU )
ELSE
DLTUB = MIN( DLTUB, TAU )
END IF
*
* Calculate the new step
*
NITER = NITER + 1
IF( .NOT.SWTCH3 ) THEN
IF( ORGATI ) THEN
C = W - DELTA( IP1 )*DW - ( D( I )-D( IP1 ) )*
$ ( Z( I ) / DELTA( I ) )**2
ELSE
C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )*
$ ( Z( IP1 ) / DELTA( IP1 ) )**2
END IF
A = ( DELTA( I )+DELTA( IP1 ) )*W -
$ DELTA( I )*DELTA( IP1 )*DW
B = DELTA( I )*DELTA( IP1 )*W
IF( C.EQ.ZERO ) THEN
IF( A.EQ.ZERO ) THEN
IF( ORGATI ) THEN
A = Z( I )*Z( I ) + DELTA( IP1 )*DELTA( IP1 )*
$ ( DPSI+DPHI )
ELSE
A = Z( IP1 )*Z( IP1 ) + DELTA( I )*DELTA( I )*
$ ( DPSI+DPHI )
END IF
END IF
ETA = B / A
ELSE IF( A.LE.ZERO ) THEN
ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
ELSE
*
* Interpolation using THREE most relevant poles
*
TEMP = RHOINV + PSI + PHI
IF( ORGATI ) THEN
TEMP1 = Z( IIM1 ) / DELTA( IIM1 )
TEMP1 = TEMP1*TEMP1
C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) -
$ ( D( IIM1 )-D( IIP1 ) )*TEMP1
ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*
$ ( ( DPSI-TEMP1 )+DPHI )
ELSE
TEMP1 = Z( IIP1 ) / DELTA( IIP1 )
TEMP1 = TEMP1*TEMP1
C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) -
$ ( D( IIP1 )-D( IIM1 ) )*TEMP1
ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*
$ ( DPSI+( DPHI-TEMP1 ) )
ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
END IF
ZZ( 2 ) = Z( II )*Z( II )
CALL SLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA,
$ INFO )
IF( INFO.NE.0 )
$ GO TO 250
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
IF( W*ETA.GE.ZERO )
$ ETA = -W / DW
TEMP = TAU + ETA
IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
IF( W.LT.ZERO ) THEN
ETA = ( DLTUB-TAU ) / TWO
ELSE
ETA = ( DLTLB-TAU ) / TWO
END IF
END IF
*
PREW = W
*
DO 180 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
180 CONTINUE
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 190 J = 1, IIM1
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
190 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
DPHI = ZERO
PHI = ZERO
DO 200 J = N, IIP1, -1
TEMP = Z( J ) / DELTA( J )
PHI = PHI + Z( J )*TEMP
DPHI = DPHI + TEMP*TEMP
ERRETM = ERRETM + PHI
200 CONTINUE
*
TEMP = Z( II ) / DELTA( II )
DW = DPSI + DPHI + TEMP*TEMP
TEMP = Z( II )*TEMP
W = RHOINV + PHI + PSI + TEMP
ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
$ THREE*ABS( TEMP ) + ABS( TAU+ETA )*DW
*
SWTCH = .FALSE.
IF( ORGATI ) THEN
IF( -W.GT.ABS( PREW ) / TEN )
$ SWTCH = .TRUE.
ELSE
IF( W.GT.ABS( PREW ) / TEN )
$ SWTCH = .TRUE.
END IF
*
TAU = TAU + ETA
*
* Main loop to update the values of the array DELTA
*
ITER = NITER + 1
*
DO 240 NITER = ITER, MAXIT
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
IF( ORGATI ) THEN
DLAM = D( I ) + TAU
ELSE
DLAM = D( IP1 ) + TAU
END IF
GO TO 250
END IF
*
IF( W.LE.ZERO ) THEN
DLTLB = MAX( DLTLB, TAU )
ELSE
DLTUB = MIN( DLTUB, TAU )
END IF
*
* Calculate the new step
*
IF( .NOT.SWTCH3 ) THEN
IF( .NOT.SWTCH ) THEN
IF( ORGATI ) THEN
C = W - DELTA( IP1 )*DW -
$ ( D( I )-D( IP1 ) )*( Z( I ) / DELTA( I ) )**2
ELSE
C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )*
$ ( Z( IP1 ) / DELTA( IP1 ) )**2
END IF
ELSE
TEMP = Z( II ) / DELTA( II )
IF( ORGATI ) THEN
DPSI = DPSI + TEMP*TEMP
ELSE
DPHI = DPHI + TEMP*TEMP
END IF
C = W - DELTA( I )*DPSI - DELTA( IP1 )*DPHI
END IF
A = ( DELTA( I )+DELTA( IP1 ) )*W -
$ DELTA( I )*DELTA( IP1 )*DW
B = DELTA( I )*DELTA( IP1 )*W
IF( C.EQ.ZERO ) THEN
IF( A.EQ.ZERO ) THEN
IF( .NOT.SWTCH ) THEN
IF( ORGATI ) THEN
A = Z( I )*Z( I ) + DELTA( IP1 )*
$ DELTA( IP1 )*( DPSI+DPHI )
ELSE
A = Z( IP1 )*Z( IP1 ) +
$ DELTA( I )*DELTA( I )*( DPSI+DPHI )
END IF
ELSE
A = DELTA( I )*DELTA( I )*DPSI +
$ DELTA( IP1 )*DELTA( IP1 )*DPHI
END IF
END IF
ETA = B / A
ELSE IF( A.LE.ZERO ) THEN
ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
ELSE
*
* Interpolation using THREE most relevant poles
*
TEMP = RHOINV + PSI + PHI
IF( SWTCH ) THEN
C = TEMP - DELTA( IIM1 )*DPSI - DELTA( IIP1 )*DPHI
ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*DPSI
ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*DPHI
ELSE
IF( ORGATI ) THEN
TEMP1 = Z( IIM1 ) / DELTA( IIM1 )
TEMP1 = TEMP1*TEMP1
C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) -
$ ( D( IIM1 )-D( IIP1 ) )*TEMP1
ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*
$ ( ( DPSI-TEMP1 )+DPHI )
ELSE
TEMP1 = Z( IIP1 ) / DELTA( IIP1 )
TEMP1 = TEMP1*TEMP1
C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) -
$ ( D( IIP1 )-D( IIM1 ) )*TEMP1
ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*
$ ( DPSI+( DPHI-TEMP1 ) )
ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
END IF
END IF
CALL SLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA,
$ INFO )
IF( INFO.NE.0 )
$ GO TO 250
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
IF( W*ETA.GE.ZERO )
$ ETA = -W / DW
TEMP = TAU + ETA
IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
IF( W.LT.ZERO ) THEN
ETA = ( DLTUB-TAU ) / TWO
ELSE
ETA = ( DLTLB-TAU ) / TWO
END IF
END IF
*
DO 210 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
210 CONTINUE
*
TAU = TAU + ETA
PREW = W
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 220 J = 1, IIM1
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
220 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
DPHI = ZERO
PHI = ZERO
DO 230 J = N, IIP1, -1
TEMP = Z( J ) / DELTA( J )
PHI = PHI + Z( J )*TEMP
DPHI = DPHI + TEMP*TEMP
ERRETM = ERRETM + PHI
230 CONTINUE
*
TEMP = Z( II ) / DELTA( II )
DW = DPSI + DPHI + TEMP*TEMP
TEMP = Z( II )*TEMP
W = RHOINV + PHI + PSI + TEMP
ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
$ THREE*ABS( TEMP ) + ABS( TAU )*DW
IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN )
$ SWTCH = .NOT.SWTCH
*
240 CONTINUE
*
* Return with INFO = 1, NITER = MAXIT and not converged
*
INFO = 1
IF( ORGATI ) THEN
DLAM = D( I ) + TAU
ELSE
DLAM = D( IP1 ) + TAU
END IF
*
END IF
*
250 CONTINUE
*
RETURN
*
* End of SLAED4
*
END
SUBROUTINE SLAED5( I, D, Z, DELTA, RHO, DLAM )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER I
REAL DLAM, RHO
* ..
* .. Array Arguments ..
REAL D( 2 ), DELTA( 2 ), Z( 2 )
* ..
*
* Purpose
* =======
*
* This subroutine computes the I-th eigenvalue of a symmetric rank-one
* modification of a 2-by-2 diagonal matrix
*
* diag( D ) + RHO * Z * transpose(Z) .
*
* The diagonal elements in the array D are assumed to satisfy
*
* D(i) < D(j) for i < j .
*
* We also assume RHO > 0 and that the Euclidean norm of the vector
* Z is one.
*
* Arguments
* =========
*
* I (input) INTEGER
* The index of the eigenvalue to be computed. I = 1 or I = 2.
*
* D (input) REAL array, dimension (2)
* The original eigenvalues. We assume D(1) < D(2).
*
* Z (input) REAL array, dimension (2)
* The components of the updating vector.
*
* DELTA (output) REAL array, dimension (2)
* The vector DELTA contains the information necessary
* to construct the eigenvectors.
*
* RHO (input) REAL
* The scalar in the symmetric updating formula.
*
* DLAM (output) REAL
* The computed lambda_I, the I-th updated eigenvalue.
*
* Further Details
* ===============
*
* Based on contributions by
* Ren-Cang Li, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO, FOUR
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ FOUR = 4.0E0 )
* ..
* .. Local Scalars ..
REAL B, C, DEL, TAU, TEMP, W
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SQRT
* ..
* .. Executable Statements ..
*
DEL = D( 2 ) - D( 1 )
IF( I.EQ.1 ) THEN
W = ONE + TWO*RHO*( Z( 2 )*Z( 2 )-Z( 1 )*Z( 1 ) ) / DEL
IF( W.GT.ZERO ) THEN
B = DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
C = RHO*Z( 1 )*Z( 1 )*DEL
*
* B > ZERO, always
*
TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) )
DLAM = D( 1 ) + TAU
DELTA( 1 ) = -Z( 1 ) / TAU
DELTA( 2 ) = Z( 2 ) / ( DEL-TAU )
ELSE
B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
C = RHO*Z( 2 )*Z( 2 )*DEL
IF( B.GT.ZERO ) THEN
TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) )
ELSE
TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO
END IF
DLAM = D( 2 ) + TAU
DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
DELTA( 2 ) = -Z( 2 ) / TAU
END IF
TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
DELTA( 1 ) = DELTA( 1 ) / TEMP
DELTA( 2 ) = DELTA( 2 ) / TEMP
ELSE
*
* Now I=2
*
B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
C = RHO*Z( 2 )*Z( 2 )*DEL
IF( B.GT.ZERO ) THEN
TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO
ELSE
TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) )
END IF
DLAM = D( 2 ) + TAU
DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
DELTA( 2 ) = -Z( 2 ) / TAU
TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
DELTA( 1 ) = DELTA( 1 ) / TEMP
DELTA( 2 ) = DELTA( 2 ) / TEMP
END IF
RETURN
*
* End OF SLAED5
*
END
SUBROUTINE SLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO )
*
* -- LAPACK routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* February 2007
*
* .. Scalar Arguments ..
LOGICAL ORGATI
INTEGER INFO, KNITER
REAL FINIT, RHO, TAU
* ..
* .. Array Arguments ..
REAL D( 3 ), Z( 3 )
* ..
*
* Purpose
* =======
*
* SLAED6 computes the positive or negative root (closest to the origin)
* of
* z(1) z(2) z(3)
* f(x) = rho + --------- + ---------- + ---------
* d(1)-x d(2)-x d(3)-x
*
* It is assumed that
*
* if ORGATI = .true. the root is between d(2) and d(3);
* otherwise it is between d(1) and d(2)
*
* This routine will be called by SLAED4 when necessary. In most cases,
* the root sought is the smallest in magnitude, though it might not be
* in some extremely rare situations.
*
* Arguments
* =========
*
* KNITER (input) INTEGER
* Refer to SLAED4 for its significance.
*
* ORGATI (input) LOGICAL
* If ORGATI is true, the needed root is between d(2) and
* d(3); otherwise it is between d(1) and d(2). See
* SLAED4 for further details.
*
* RHO (input) REAL
* Refer to the equation f(x) above.
*
* D (input) REAL array, dimension (3)
* D satisfies d(1) < d(2) < d(3).
*
* Z (input) REAL array, dimension (3)
* Each of the elements in z must be positive.
*
* FINIT (input) REAL
* The value of f at 0. It is more accurate than the one
* evaluated inside this routine (if someone wants to do
* so).
*
* TAU (output) REAL
* The root of the equation f(x).
*
* INFO (output) INTEGER
* = 0: successful exit
* > 0: if INFO = 1, failure to converge
*
* Further Details
* ===============
*
* 30/06/99: Based on contributions by
* Ren-Cang Li, Computer Science Division, University of California
* at Berkeley, USA
*
* 10/02/03: This version has a few statements commented out for thread safety
* (machine parameters are computed on each entry). SJH.
*
* 05/10/06: Modified from a new version of Ren-Cang Li, use
* Gragg-Thornton-Warner cubic convergent scheme for better stability.
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXIT
PARAMETER ( MAXIT = 40 )
REAL ZERO, ONE, TWO, THREE, FOUR, EIGHT
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ THREE = 3.0E0, FOUR = 4.0E0, EIGHT = 8.0E0 )
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Local Arrays ..
REAL DSCALE( 3 ), ZSCALE( 3 )
* ..
* .. Local Scalars ..
LOGICAL SCALE
INTEGER I, ITER, NITER
REAL A, B, BASE, C, DDF, DF, EPS, ERRETM, ETA, F,
$ FC, SCLFAC, SCLINV, SMALL1, SMALL2, SMINV1,
$ SMINV2, TEMP, TEMP1, TEMP2, TEMP3, TEMP4,
$ LBD, UBD
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
*
IF( ORGATI ) THEN
LBD = D(2)
UBD = D(3)
ELSE
LBD = D(1)
UBD = D(2)
END IF
IF( FINIT .LT. ZERO )THEN
LBD = ZERO
ELSE
UBD = ZERO
END IF
*
NITER = 1
TAU = ZERO
IF( KNITER.EQ.2 ) THEN
IF( ORGATI ) THEN
TEMP = ( D( 3 )-D( 2 ) ) / TWO
C = RHO + Z( 1 ) / ( ( D( 1 )-D( 2 ) )-TEMP )
A = C*( D( 2 )+D( 3 ) ) + Z( 2 ) + Z( 3 )
B = C*D( 2 )*D( 3 ) + Z( 2 )*D( 3 ) + Z( 3 )*D( 2 )
ELSE
TEMP = ( D( 1 )-D( 2 ) ) / TWO
C = RHO + Z( 3 ) / ( ( D( 3 )-D( 2 ) )-TEMP )
A = C*( D( 1 )+D( 2 ) ) + Z( 1 ) + Z( 2 )
B = C*D( 1 )*D( 2 ) + Z( 1 )*D( 2 ) + Z( 2 )*D( 1 )
END IF
TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) )
A = A / TEMP
B = B / TEMP
C = C / TEMP
IF( C.EQ.ZERO ) THEN
TAU = B / A
ELSE IF( A.LE.ZERO ) THEN
TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
IF( TAU .LT. LBD .OR. TAU .GT. UBD )
$ TAU = ( LBD+UBD )/TWO
IF( D(1).EQ.TAU .OR. D(2).EQ.TAU .OR. D(3).EQ.TAU ) THEN
TAU = ZERO
ELSE
TEMP = FINIT + TAU*Z(1)/( D(1)*( D( 1 )-TAU ) ) +
$ TAU*Z(2)/( D(2)*( D( 2 )-TAU ) ) +
$ TAU*Z(3)/( D(3)*( D( 3 )-TAU ) )
IF( TEMP .LE. ZERO )THEN
LBD = TAU
ELSE
UBD = TAU
END IF
IF( ABS( FINIT ).LE.ABS( TEMP ) )
$ TAU = ZERO
END IF
END IF
*
* get machine parameters for possible scaling to avoid overflow
*
* modified by Sven: parameters SMALL1, SMINV1, SMALL2,
* SMINV2, EPS are not SAVEd anymore between one call to the
* others but recomputed at each call
*
EPS = SLAMCH( 'Epsilon' )
BASE = SLAMCH( 'Base' )
SMALL1 = BASE**( INT( LOG( SLAMCH( 'SafMin' ) ) / LOG( BASE ) /
$ THREE ) )
SMINV1 = ONE / SMALL1
SMALL2 = SMALL1*SMALL1
SMINV2 = SMINV1*SMINV1
*
* Determine if scaling of inputs necessary to avoid overflow
* when computing 1/TEMP**3
*
IF( ORGATI ) THEN
TEMP = MIN( ABS( D( 2 )-TAU ), ABS( D( 3 )-TAU ) )
ELSE
TEMP = MIN( ABS( D( 1 )-TAU ), ABS( D( 2 )-TAU ) )
END IF
SCALE = .FALSE.
IF( TEMP.LE.SMALL1 ) THEN
SCALE = .TRUE.
IF( TEMP.LE.SMALL2 ) THEN
*
* Scale up by power of radix nearest 1/SAFMIN**(2/3)
*
SCLFAC = SMINV2
SCLINV = SMALL2
ELSE
*
* Scale up by power of radix nearest 1/SAFMIN**(1/3)
*
SCLFAC = SMINV1
SCLINV = SMALL1
END IF
*
* Scaling up safe because D, Z, TAU scaled elsewhere to be O(1)
*
DO 10 I = 1, 3
DSCALE( I ) = D( I )*SCLFAC
ZSCALE( I ) = Z( I )*SCLFAC
10 CONTINUE
TAU = TAU*SCLFAC
LBD = LBD*SCLFAC
UBD = UBD*SCLFAC
ELSE
*
* Copy D and Z to DSCALE and ZSCALE
*
DO 20 I = 1, 3
DSCALE( I ) = D( I )
ZSCALE( I ) = Z( I )
20 CONTINUE
END IF
*
FC = ZERO
DF = ZERO
DDF = ZERO
DO 30 I = 1, 3
TEMP = ONE / ( DSCALE( I )-TAU )
TEMP1 = ZSCALE( I )*TEMP
TEMP2 = TEMP1*TEMP
TEMP3 = TEMP2*TEMP
FC = FC + TEMP1 / DSCALE( I )
DF = DF + TEMP2
DDF = DDF + TEMP3
30 CONTINUE
F = FINIT + TAU*FC
*
IF( ABS( F ).LE.ZERO )
$ GO TO 60
IF( F .LE. ZERO )THEN
LBD = TAU
ELSE
UBD = TAU
END IF
*
* Iteration begins -- Use Gragg-Thornton-Warner cubic convergent
* scheme
*
* It is not hard to see that
*
* 1) Iterations will go up monotonically
* if FINIT < 0;
*
* 2) Iterations will go down monotonically
* if FINIT > 0.
*
ITER = NITER + 1
*
DO 50 NITER = ITER, MAXIT
*
IF( ORGATI ) THEN
TEMP1 = DSCALE( 2 ) - TAU
TEMP2 = DSCALE( 3 ) - TAU
ELSE
TEMP1 = DSCALE( 1 ) - TAU
TEMP2 = DSCALE( 2 ) - TAU
END IF
A = ( TEMP1+TEMP2 )*F - TEMP1*TEMP2*DF
B = TEMP1*TEMP2*F
C = F - ( TEMP1+TEMP2 )*DF + TEMP1*TEMP2*DDF
TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) )
A = A / TEMP
B = B / TEMP
C = C / TEMP
IF( C.EQ.ZERO ) THEN
ETA = B / A
ELSE IF( A.LE.ZERO ) THEN
ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
IF( F*ETA.GE.ZERO ) THEN
ETA = -F / DF
END IF
*
TAU = TAU + ETA
IF( TAU .LT. LBD .OR. TAU .GT. UBD )
$ TAU = ( LBD + UBD )/TWO
*
FC = ZERO
ERRETM = ZERO
DF = ZERO
DDF = ZERO
DO 40 I = 1, 3
TEMP = ONE / ( DSCALE( I )-TAU )
TEMP1 = ZSCALE( I )*TEMP
TEMP2 = TEMP1*TEMP
TEMP3 = TEMP2*TEMP
TEMP4 = TEMP1 / DSCALE( I )
FC = FC + TEMP4
ERRETM = ERRETM + ABS( TEMP4 )
DF = DF + TEMP2
DDF = DDF + TEMP3
40 CONTINUE
F = FINIT + TAU*FC
ERRETM = EIGHT*( ABS( FINIT )+ABS( TAU )*ERRETM ) +
$ ABS( TAU )*DF
IF( ABS( F ).LE.EPS*ERRETM )
$ GO TO 60
IF( F .LE. ZERO )THEN
LBD = TAU
ELSE
UBD = TAU
END IF
50 CONTINUE
INFO = 1
60 CONTINUE
*
* Undo scaling
*
IF( SCALE )
$ TAU = TAU*SCLINV
RETURN
*
* End of SLAED6
*
END
SUBROUTINE SLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q,
$ LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR,
$ PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N,
$ QSIZ, TLVLS
REAL RHO
* ..
* .. Array Arguments ..
INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),
$ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )
REAL D( * ), GIVNUM( 2, * ), Q( LDQ, * ),
$ QSTORE( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SLAED7 computes the updated eigensystem of a diagonal
* matrix after modification by a rank-one symmetric matrix. This
* routine is used only for the eigenproblem which requires all
* eigenvalues and optionally eigenvectors of a dense symmetric matrix
* that has been reduced to tridiagonal form. SLAED1 handles
* the case in which all eigenvalues and eigenvectors of a symmetric
* tridiagonal matrix are desired.
*
* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)
*
* where Z = Q'u, u is a vector of length N with ones in the
* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
*
* The eigenvectors of the original matrix are stored in Q, and the
* eigenvalues are in D. The algorithm consists of three stages:
*
* The first stage consists of deflating the size of the problem
* when there are multiple eigenvalues or if there is a zero in
* the Z vector. For each such occurence the dimension of the
* secular equation problem is reduced by one. This stage is
* performed by the routine SLAED8.
*
* The second stage consists of calculating the updated
* eigenvalues. This is done by finding the roots of the secular
* equation via the routine SLAED4 (as called by SLAED9).
* This routine also calculates the eigenvectors of the current
* problem.
*
* The final stage consists of computing the updated eigenvectors
* directly using the updated eigenvalues. The eigenvectors for
* the current problem are multiplied with the eigenvectors from
* the overall problem.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* = 0: Compute eigenvalues only.
* = 1: Compute eigenvectors of original dense symmetric matrix
* also. On entry, Q contains the orthogonal matrix used
* to reduce the original matrix to tridiagonal form.
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* QSIZ (input) INTEGER
* The dimension of the orthogonal matrix used to reduce
* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.
*
* TLVLS (input) INTEGER
* The total number of merging levels in the overall divide and
* conquer tree.
*
* CURLVL (input) INTEGER
* The current level in the overall merge routine,
* 0 <= CURLVL <= TLVLS.
*
* CURPBM (input) INTEGER
* The current problem in the current level in the overall
* merge routine (counting from upper left to lower right).
*
* D (input/output) REAL array, dimension (N)
* On entry, the eigenvalues of the rank-1-perturbed matrix.
* On exit, the eigenvalues of the repaired matrix.
*
* Q (input/output) REAL array, dimension (LDQ, N)
* On entry, the eigenvectors of the rank-1-perturbed matrix.
* On exit, the eigenvectors of the repaired tridiagonal matrix.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* INDXQ (output) INTEGER array, dimension (N)
* The permutation which will reintegrate the subproblem just
* solved back into sorted order, i.e., D( INDXQ( I = 1, N ) )
* will be in ascending order.
*
* RHO (input) REAL
* The subdiagonal element used to create the rank-1
* modification.
*
* CUTPNT (input) INTEGER
* Contains the location of the last eigenvalue in the leading
* sub-matrix. min(1,N) <= CUTPNT <= N.
*
* QSTORE (input/output) REAL array, dimension (N**2+1)
* Stores eigenvectors of submatrices encountered during
* divide and conquer, packed together. QPTR points to
* beginning of the submatrices.
*
* QPTR (input/output) INTEGER array, dimension (N+2)
* List of indices pointing to beginning of submatrices stored
* in QSTORE. The submatrices are numbered starting at the
* bottom left of the divide and conquer tree, from left to
* right and bottom to top.
*
* PRMPTR (input) INTEGER array, dimension (N lg N)
* Contains a list of pointers which indicate where in PERM a
* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)
* indicates the size of the permutation and also the size of
* the full, non-deflated problem.
*
* PERM (input) INTEGER array, dimension (N lg N)
* Contains the permutations (from deflation and sorting) to be
* applied to each eigenblock.
*
* GIVPTR (input) INTEGER array, dimension (N lg N)
* Contains a list of pointers which indicate where in GIVCOL a
* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)
* indicates the number of Givens rotations.
*
* GIVCOL (input) INTEGER array, dimension (2, N lg N)
* Each pair of numbers indicates a pair of columns to take place
* in a Givens rotation.
*
* GIVNUM (input) REAL array, dimension (2, N lg N)
* Each number indicates the S value to be used in the
* corresponding Givens rotation.
*
* WORK (workspace) REAL array, dimension (3*N+QSIZ*N)
*
* IWORK (workspace) INTEGER array, dimension (4*N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an eigenvalue did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
INTEGER COLTYP, CURR, I, IDLMDA, INDX, INDXC, INDXP,
$ IQ2, IS, IW, IZ, K, LDQ2, N1, N2, PTR
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SLAED8, SLAED9, SLAEDA, SLAMRG, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN
INFO = -4
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( MIN( 1, N ).GT.CUTPNT .OR. N.LT.CUTPNT ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLAED7', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* The following values are for bookkeeping purposes only. They are
* integer pointers which indicate the portion of the workspace
* used by a particular array in SLAED8 and SLAED9.
*
IF( ICOMPQ.EQ.1 ) THEN
LDQ2 = QSIZ
ELSE
LDQ2 = N
END IF
*
IZ = 1
IDLMDA = IZ + N
IW = IDLMDA + N
IQ2 = IW + N
IS = IQ2 + N*LDQ2
*
INDX = 1
INDXC = INDX + N
COLTYP = INDXC + N
INDXP = COLTYP + N
*
* Form the z-vector which consists of the last row of Q_1 and the
* first row of Q_2.
*
PTR = 1 + 2**TLVLS
DO 10 I = 1, CURLVL - 1
PTR = PTR + 2**( TLVLS-I )
10 CONTINUE
CURR = PTR + CURPBM
CALL SLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,
$ GIVCOL, GIVNUM, QSTORE, QPTR, WORK( IZ ),
$ WORK( IZ+N ), INFO )
*
* When solving the final problem, we no longer need the stored data,
* so we will overwrite the data from this level onto the previously
* used storage space.
*
IF( CURLVL.EQ.TLVLS ) THEN
QPTR( CURR ) = 1
PRMPTR( CURR ) = 1
GIVPTR( CURR ) = 1
END IF
*
* Sort and Deflate eigenvalues.
*
CALL SLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, CUTPNT,
$ WORK( IZ ), WORK( IDLMDA ), WORK( IQ2 ), LDQ2,
$ WORK( IW ), PERM( PRMPTR( CURR ) ), GIVPTR( CURR+1 ),
$ GIVCOL( 1, GIVPTR( CURR ) ),
$ GIVNUM( 1, GIVPTR( CURR ) ), IWORK( INDXP ),
$ IWORK( INDX ), INFO )
PRMPTR( CURR+1 ) = PRMPTR( CURR ) + N
GIVPTR( CURR+1 ) = GIVPTR( CURR+1 ) + GIVPTR( CURR )
*
* Solve Secular Equation.
*
IF( K.NE.0 ) THEN
CALL SLAED9( K, 1, K, N, D, WORK( IS ), K, RHO, WORK( IDLMDA ),
$ WORK( IW ), QSTORE( QPTR( CURR ) ), K, INFO )
IF( INFO.NE.0 )
$ GO TO 30
IF( ICOMPQ.EQ.1 ) THEN
CALL SGEMM( 'N', 'N', QSIZ, K, K, ONE, WORK( IQ2 ), LDQ2,
$ QSTORE( QPTR( CURR ) ), K, ZERO, Q, LDQ )
END IF
QPTR( CURR+1 ) = QPTR( CURR ) + K**2
*
* Prepare the INDXQ sorting permutation.
*
N1 = K
N2 = N - K
CALL SLAMRG( N1, N2, D, 1, -1, INDXQ )
ELSE
QPTR( CURR+1 ) = QPTR( CURR )
DO 20 I = 1, N
INDXQ( I ) = I
20 CONTINUE
END IF
*
30 CONTINUE
RETURN
*
* End of SLAED7
*
END
SUBROUTINE SLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO,
$ CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR,
$ GIVCOL, GIVNUM, INDXP, INDX, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N,
$ QSIZ
REAL RHO
* ..
* .. Array Arguments ..
INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ),
$ INDXQ( * ), PERM( * )
REAL D( * ), DLAMDA( * ), GIVNUM( 2, * ),
$ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * )
* ..
*
* Purpose
* =======
*
* SLAED8 merges the two sets of eigenvalues together into a single
* sorted set. Then it tries to deflate the size of the problem.
* There are two ways in which deflation can occur: when two or more
* eigenvalues are close together or if there is a tiny element in the
* Z vector. For each such occurrence the order of the related secular
* equation problem is reduced by one.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* = 0: Compute eigenvalues only.
* = 1: Compute eigenvectors of original dense symmetric matrix
* also. On entry, Q contains the orthogonal matrix used
* to reduce the original matrix to tridiagonal form.
*
* K (output) INTEGER
* The number of non-deflated eigenvalues, and the order of the
* related secular equation.
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* QSIZ (input) INTEGER
* The dimension of the orthogonal matrix used to reduce
* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.
*
* D (input/output) REAL array, dimension (N)
* On entry, the eigenvalues of the two submatrices to be
* combined. On exit, the trailing (N-K) updated eigenvalues
* (those which were deflated) sorted into increasing order.
*
* Q (input/output) REAL array, dimension (LDQ,N)
* If ICOMPQ = 0, Q is not referenced. Otherwise,
* on entry, Q contains the eigenvectors of the partially solved
* system which has been previously updated in matrix
* multiplies with other partially solved eigensystems.
* On exit, Q contains the trailing (N-K) updated eigenvectors
* (those which were deflated) in its last N-K columns.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* INDXQ (input) INTEGER array, dimension (N)
* The permutation which separately sorts the two sub-problems
* in D into ascending order. Note that elements in the second
* half of this permutation must first have CUTPNT added to
* their values in order to be accurate.
*
* RHO (input/output) REAL
* On entry, the off-diagonal element associated with the rank-1
* cut which originally split the two submatrices which are now
* being recombined.
* On exit, RHO has been modified to the value required by
* SLAED3.
*
* CUTPNT (input) INTEGER
* The location of the last eigenvalue in the leading
* sub-matrix. min(1,N) <= CUTPNT <= N.
*
* Z (input) REAL array, dimension (N)
* On entry, Z contains the updating vector (the last row of
* the first sub-eigenvector matrix and the first row of the
* second sub-eigenvector matrix).
* On exit, the contents of Z are destroyed by the updating
* process.
*
* DLAMDA (output) REAL array, dimension (N)
* A copy of the first K eigenvalues which will be used by
* SLAED3 to form the secular equation.
*
* Q2 (output) REAL array, dimension (LDQ2,N)
* If ICOMPQ = 0, Q2 is not referenced. Otherwise,
* a copy of the first K eigenvectors which will be used by
* SLAED7 in a matrix multiply (SGEMM) to update the new
* eigenvectors.
*
* LDQ2 (input) INTEGER
* The leading dimension of the array Q2. LDQ2 >= max(1,N).
*
* W (output) REAL array, dimension (N)
* The first k values of the final deflation-altered z-vector and
* will be passed to SLAED3.
*
* PERM (output) INTEGER array, dimension (N)
* The permutations (from deflation and sorting) to be applied
* to each eigenblock.
*
* GIVPTR (output) INTEGER
* The number of Givens rotations which took place in this
* subproblem.
*
* GIVCOL (output) INTEGER array, dimension (2, N)
* Each pair of numbers indicates a pair of columns to take place
* in a Givens rotation.
*
* GIVNUM (output) REAL array, dimension (2, N)
* Each number indicates the S value to be used in the
* corresponding Givens rotation.
*
* INDXP (workspace) INTEGER array, dimension (N)
* The permutation used to place deflated values of D at the end
* of the array. INDXP(1:K) points to the nondeflated D-values
* and INDXP(K+1:N) points to the deflated eigenvalues.
*
* INDX (workspace) INTEGER array, dimension (N)
* The permutation used to sort the contents of D into ascending
* order.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL MONE, ZERO, ONE, TWO, EIGHT
PARAMETER ( MONE = -1.0E0, ZERO = 0.0E0, ONE = 1.0E0,
$ TWO = 2.0E0, EIGHT = 8.0E0 )
* ..
* .. Local Scalars ..
*
INTEGER I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2
REAL C, EPS, S, T, TAU, TOL
* ..
* .. External Functions ..
INTEGER ISAMAX
REAL SLAMCH, SLAPY2
EXTERNAL ISAMAX, SLAMCH, SLAPY2
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLACPY, SLAMRG, SROT, SSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN
INFO = -4
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN
INFO = -10
ELSE IF( LDQ2.LT.MAX( 1, N ) ) THEN
INFO = -14
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLAED8', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
N1 = CUTPNT
N2 = N - N1
N1P1 = N1 + 1
*
IF( RHO.LT.ZERO ) THEN
CALL SSCAL( N2, MONE, Z( N1P1 ), 1 )
END IF
*
* Normalize z so that norm(z) = 1
*
T = ONE / SQRT( TWO )
DO 10 J = 1, N
INDX( J ) = J
10 CONTINUE
CALL SSCAL( N, T, Z, 1 )
RHO = ABS( TWO*RHO )
*
* Sort the eigenvalues into increasing order
*
DO 20 I = CUTPNT + 1, N
INDXQ( I ) = INDXQ( I ) + CUTPNT
20 CONTINUE
DO 30 I = 1, N
DLAMDA( I ) = D( INDXQ( I ) )
W( I ) = Z( INDXQ( I ) )
30 CONTINUE
I = 1
J = CUTPNT + 1
CALL SLAMRG( N1, N2, DLAMDA, 1, 1, INDX )
DO 40 I = 1, N
D( I ) = DLAMDA( INDX( I ) )
Z( I ) = W( INDX( I ) )
40 CONTINUE
*
* Calculate the allowable deflation tolerence
*
IMAX = ISAMAX( N, Z, 1 )
JMAX = ISAMAX( N, D, 1 )
EPS = SLAMCH( 'Epsilon' )
TOL = EIGHT*EPS*ABS( D( JMAX ) )
*
* If the rank-1 modifier is small enough, no more needs to be done
* except to reorganize Q so that its columns correspond with the
* elements in D.
*
IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN
K = 0
IF( ICOMPQ.EQ.0 ) THEN
DO 50 J = 1, N
PERM( J ) = INDXQ( INDX( J ) )
50 CONTINUE
ELSE
DO 60 J = 1, N
PERM( J ) = INDXQ( INDX( J ) )
CALL SCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
60 CONTINUE
CALL SLACPY( 'A', QSIZ, N, Q2( 1, 1 ), LDQ2, Q( 1, 1 ),
$ LDQ )
END IF
RETURN
END IF
*
* If there are multiple eigenvalues then the problem deflates. Here
* the number of equal eigenvalues are found. As each equal
* eigenvalue is found, an elementary reflector is computed to rotate
* the corresponding eigensubspace so that the corresponding
* components of Z are zero in this new basis.
*
K = 0
GIVPTR = 0
K2 = N + 1
DO 70 J = 1, N
IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
INDXP( K2 ) = J
IF( J.EQ.N )
$ GO TO 110
ELSE
JLAM = J
GO TO 80
END IF
70 CONTINUE
80 CONTINUE
J = J + 1
IF( J.GT.N )
$ GO TO 100
IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
INDXP( K2 ) = J
ELSE
*
* Check if eigenvalues are close enough to allow deflation.
*
S = Z( JLAM )
C = Z( J )
*
* Find sqrt(a**2+b**2) without overflow or
* destructive underflow.
*
TAU = SLAPY2( C, S )
T = D( J ) - D( JLAM )
C = C / TAU
S = -S / TAU
IF( ABS( T*C*S ).LE.TOL ) THEN
*
* Deflation is possible.
*
Z( J ) = TAU
Z( JLAM ) = ZERO
*
* Record the appropriate Givens rotation
*
GIVPTR = GIVPTR + 1
GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) )
GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) )
GIVNUM( 1, GIVPTR ) = C
GIVNUM( 2, GIVPTR ) = S
IF( ICOMPQ.EQ.1 ) THEN
CALL SROT( QSIZ, Q( 1, INDXQ( INDX( JLAM ) ) ), 1,
$ Q( 1, INDXQ( INDX( J ) ) ), 1, C, S )
END IF
T = D( JLAM )*C*C + D( J )*S*S
D( J ) = D( JLAM )*S*S + D( J )*C*C
D( JLAM ) = T
K2 = K2 - 1
I = 1
90 CONTINUE
IF( K2+I.LE.N ) THEN
IF( D( JLAM ).LT.D( INDXP( K2+I ) ) ) THEN
INDXP( K2+I-1 ) = INDXP( K2+I )
INDXP( K2+I ) = JLAM
I = I + 1
GO TO 90
ELSE
INDXP( K2+I-1 ) = JLAM
END IF
ELSE
INDXP( K2+I-1 ) = JLAM
END IF
JLAM = J
ELSE
K = K + 1
W( K ) = Z( JLAM )
DLAMDA( K ) = D( JLAM )
INDXP( K ) = JLAM
JLAM = J
END IF
END IF
GO TO 80
100 CONTINUE
*
* Record the last eigenvalue.
*
K = K + 1
W( K ) = Z( JLAM )
DLAMDA( K ) = D( JLAM )
INDXP( K ) = JLAM
*
110 CONTINUE
*
* Sort the eigenvalues and corresponding eigenvectors into DLAMDA
* and Q2 respectively. The eigenvalues/vectors which were not
* deflated go into the first K slots of DLAMDA and Q2 respectively,
* while those which were deflated go into the last N - K slots.
*
IF( ICOMPQ.EQ.0 ) THEN
DO 120 J = 1, N
JP = INDXP( J )
DLAMDA( J ) = D( JP )
PERM( J ) = INDXQ( INDX( JP ) )
120 CONTINUE
ELSE
DO 130 J = 1, N
JP = INDXP( J )
DLAMDA( J ) = D( JP )
PERM( J ) = INDXQ( INDX( JP ) )
CALL SCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
130 CONTINUE
END IF
*
* The deflated eigenvalues and their corresponding vectors go back
* into the last N - K slots of D and Q respectively.
*
IF( K.LT.N ) THEN
IF( ICOMPQ.EQ.0 ) THEN
CALL SCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )
ELSE
CALL SCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )
CALL SLACPY( 'A', QSIZ, N-K, Q2( 1, K+1 ), LDQ2,
$ Q( 1, K+1 ), LDQ )
END IF
END IF
*
RETURN
*
* End of SLAED8
*
END
SUBROUTINE SLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W,
$ S, LDS, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N
REAL RHO
* ..
* .. Array Arguments ..
REAL D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ),
$ W( * )
* ..
*
* Purpose
* =======
*
* SLAED9 finds the roots of the secular equation, as defined by the
* values in D, Z, and RHO, between KSTART and KSTOP. It makes the
* appropriate calls to SLAED4 and then stores the new matrix of
* eigenvectors for use in calculating the next level of Z vectors.
*
* Arguments
* =========
*
* K (input) INTEGER
* The number of terms in the rational function to be solved by
* SLAED4. K >= 0.
*
* KSTART (input) INTEGER
* KSTOP (input) INTEGER
* The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP
* are to be computed. 1 <= KSTART <= KSTOP <= K.
*
* N (input) INTEGER
* The number of rows and columns in the Q matrix.
* N >= K (delation may result in N > K).
*
* D (output) REAL array, dimension (N)
* D(I) contains the updated eigenvalues
* for KSTART <= I <= KSTOP.
*
* Q (workspace) REAL array, dimension (LDQ,N)
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max( 1, N ).
*
* RHO (input) REAL
* The value of the parameter in the rank one update equation.
* RHO >= 0 required.
*
* DLAMDA (input) REAL array, dimension (K)
* The first K elements of this array contain the old roots
* of the deflated updating problem. These are the poles
* of the secular equation.
*
* W (input) REAL array, dimension (K)
* The first K elements of this array contain the components
* of the deflation-adjusted updating vector.
*
* S (output) REAL array, dimension (LDS, K)
* Will contain the eigenvectors of the repaired matrix which
* will be stored for subsequent Z vector calculation and
* multiplied by the previously accumulated eigenvectors
* to update the system.
*
* LDS (input) INTEGER
* The leading dimension of S. LDS >= max( 1, K ).
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an eigenvalue did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J
REAL TEMP
* ..
* .. External Functions ..
REAL SLAMC3, SNRM2
EXTERNAL SLAMC3, SNRM2
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLAED4, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( K.LT.0 ) THEN
INFO = -1
ELSE IF( KSTART.LT.1 .OR. KSTART.GT.MAX( 1, K ) ) THEN
INFO = -2
ELSE IF( MAX( 1, KSTOP ).LT.KSTART .OR. KSTOP.GT.MAX( 1, K ) )
$ THEN
INFO = -3
ELSE IF( N.LT.K ) THEN
INFO = -4
ELSE IF( LDQ.LT.MAX( 1, K ) ) THEN
INFO = -7
ELSE IF( LDS.LT.MAX( 1, K ) ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLAED9', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( K.EQ.0 )
$ RETURN
*
* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
* be computed with high relative accuracy (barring over/underflow).
* This is a problem on machines without a guard digit in
* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
* which on any of these machines zeros out the bottommost
* bit of DLAMDA(I) if it is 1; this makes the subsequent
* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
* occurs. On binary machines with a guard digit (almost all
* machines) it does not change DLAMDA(I) at all. On hexadecimal
* and decimal machines with a guard digit, it slightly
* changes the bottommost bits of DLAMDA(I). It does not account
* for hexadecimal or decimal machines without guard digits
* (we know of none). We use a subroutine call to compute
* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating
* this code.
*
DO 10 I = 1, N
DLAMDA( I ) = SLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I )
10 CONTINUE
*
DO 20 J = KSTART, KSTOP
CALL SLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO )
*
* If the zero finder fails, the computation is terminated.
*
IF( INFO.NE.0 )
$ GO TO 120
20 CONTINUE
*
IF( K.EQ.1 .OR. K.EQ.2 ) THEN
DO 40 I = 1, K
DO 30 J = 1, K
S( J, I ) = Q( J, I )
30 CONTINUE
40 CONTINUE
GO TO 120
END IF
*
* Compute updated W.
*
CALL SCOPY( K, W, 1, S, 1 )
*
* Initialize W(I) = Q(I,I)
*
CALL SCOPY( K, Q, LDQ+1, W, 1 )
DO 70 J = 1, K
DO 50 I = 1, J - 1
W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
50 CONTINUE
DO 60 I = J + 1, K
W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
60 CONTINUE
70 CONTINUE
DO 80 I = 1, K
W( I ) = SIGN( SQRT( -W( I ) ), S( I, 1 ) )
80 CONTINUE
*
* Compute eigenvectors of the modified rank-1 modification.
*
DO 110 J = 1, K
DO 90 I = 1, K
Q( I, J ) = W( I ) / Q( I, J )
90 CONTINUE
TEMP = SNRM2( K, Q( 1, J ), 1 )
DO 100 I = 1, K
S( I, J ) = Q( I, J ) / TEMP
100 CONTINUE
110 CONTINUE
*
120 CONTINUE
RETURN
*
* End of SLAED9
*
END
SUBROUTINE SLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,
$ GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER CURLVL, CURPBM, INFO, N, TLVLS
* ..
* .. Array Arguments ..
INTEGER GIVCOL( 2, * ), GIVPTR( * ), PERM( * ),
$ PRMPTR( * ), QPTR( * )
REAL GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * )
* ..
*
* Purpose
* =======
*
* SLAEDA computes the Z vector corresponding to the merge step in the
* CURLVLth step of the merge process with TLVLS steps for the CURPBMth
* problem.
*
* Arguments
* =========
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* TLVLS (input) INTEGER
* The total number of merging levels in the overall divide and
* conquer tree.
*
* CURLVL (input) INTEGER
* The current level in the overall merge routine,
* 0 <= curlvl <= tlvls.
*
* CURPBM (input) INTEGER
* The current problem in the current level in the overall
* merge routine (counting from upper left to lower right).
*
* PRMPTR (input) INTEGER array, dimension (N lg N)
* Contains a list of pointers which indicate where in PERM a
* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)
* indicates the size of the permutation and incidentally the
* size of the full, non-deflated problem.
*
* PERM (input) INTEGER array, dimension (N lg N)
* Contains the permutations (from deflation and sorting) to be
* applied to each eigenblock.
*
* GIVPTR (input) INTEGER array, dimension (N lg N)
* Contains a list of pointers which indicate where in GIVCOL a
* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)
* indicates the number of Givens rotations.
*
* GIVCOL (input) INTEGER array, dimension (2, N lg N)
* Each pair of numbers indicates a pair of columns to take place
* in a Givens rotation.
*
* GIVNUM (input) REAL array, dimension (2, N lg N)
* Each number indicates the S value to be used in the
* corresponding Givens rotation.
*
* Q (input) REAL array, dimension (N**2)
* Contains the square eigenblocks from previous levels, the
* starting positions for blocks are given by QPTR.
*
* QPTR (input) INTEGER array, dimension (N+2)
* Contains a list of pointers which indicate where in Q an
* eigenblock is stored. SQRT( QPTR(i+1) - QPTR(i) ) indicates
* the size of the block.
*
* Z (output) REAL array, dimension (N)
* On output this vector contains the updating vector (the last
* row of the first sub-eigenvector matrix and the first row of
* the second sub-eigenvector matrix).
*
* ZTEMP (workspace) REAL array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
INTEGER BSIZ1, BSIZ2, CURR, I, K, MID, PSIZ1, PSIZ2,
$ PTR, ZPTR1
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMV, SROT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC INT, REAL, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( N.LT.0 ) THEN
INFO = -1
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLAEDA', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Determine location of first number in second half.
*
MID = N / 2 + 1
*
* Gather last/first rows of appropriate eigenblocks into center of Z
*
PTR = 1
*
* Determine location of lowest level subproblem in the full storage
* scheme
*
CURR = PTR + CURPBM*2**CURLVL + 2**( CURLVL-1 ) - 1
*
* Determine size of these matrices. We add HALF to the value of
* the SQRT in case the machine underestimates one of these square
* roots.
*
BSIZ1 = INT( HALF+SQRT( REAL( QPTR( CURR+1 )-QPTR( CURR ) ) ) )
BSIZ2 = INT( HALF+SQRT( REAL( QPTR( CURR+2 )-QPTR( CURR+1 ) ) ) )
DO 10 K = 1, MID - BSIZ1 - 1
Z( K ) = ZERO
10 CONTINUE
CALL SCOPY( BSIZ1, Q( QPTR( CURR )+BSIZ1-1 ), BSIZ1,
$ Z( MID-BSIZ1 ), 1 )
CALL SCOPY( BSIZ2, Q( QPTR( CURR+1 ) ), BSIZ2, Z( MID ), 1 )
DO 20 K = MID + BSIZ2, N
Z( K ) = ZERO
20 CONTINUE
*
* Loop thru remaining levels 1 -> CURLVL applying the Givens
* rotations and permutation and then multiplying the center matrices
* against the current Z.
*
PTR = 2**TLVLS + 1
DO 70 K = 1, CURLVL - 1
CURR = PTR + CURPBM*2**( CURLVL-K ) + 2**( CURLVL-K-1 ) - 1
PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR )
PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 )
ZPTR1 = MID - PSIZ1
*
* Apply Givens at CURR and CURR+1
*
DO 30 I = GIVPTR( CURR ), GIVPTR( CURR+1 ) - 1
CALL SROT( 1, Z( ZPTR1+GIVCOL( 1, I )-1 ), 1,
$ Z( ZPTR1+GIVCOL( 2, I )-1 ), 1, GIVNUM( 1, I ),
$ GIVNUM( 2, I ) )
30 CONTINUE
DO 40 I = GIVPTR( CURR+1 ), GIVPTR( CURR+2 ) - 1
CALL SROT( 1, Z( MID-1+GIVCOL( 1, I ) ), 1,
$ Z( MID-1+GIVCOL( 2, I ) ), 1, GIVNUM( 1, I ),
$ GIVNUM( 2, I ) )
40 CONTINUE
PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR )
PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 )
DO 50 I = 0, PSIZ1 - 1
ZTEMP( I+1 ) = Z( ZPTR1+PERM( PRMPTR( CURR )+I )-1 )
50 CONTINUE
DO 60 I = 0, PSIZ2 - 1
ZTEMP( PSIZ1+I+1 ) = Z( MID+PERM( PRMPTR( CURR+1 )+I )-1 )
60 CONTINUE
*
* Multiply Blocks at CURR and CURR+1
*
* Determine size of these matrices. We add HALF to the value of
* the SQRT in case the machine underestimates one of these
* square roots.
*
BSIZ1 = INT( HALF+SQRT( REAL( QPTR( CURR+1 )-QPTR( CURR ) ) ) )
BSIZ2 = INT( HALF+SQRT( REAL( QPTR( CURR+2 )-QPTR( CURR+
$ 1 ) ) ) )
IF( BSIZ1.GT.0 ) THEN
CALL SGEMV( 'T', BSIZ1, BSIZ1, ONE, Q( QPTR( CURR ) ),
$ BSIZ1, ZTEMP( 1 ), 1, ZERO, Z( ZPTR1 ), 1 )
END IF
CALL SCOPY( PSIZ1-BSIZ1, ZTEMP( BSIZ1+1 ), 1, Z( ZPTR1+BSIZ1 ),
$ 1 )
IF( BSIZ2.GT.0 ) THEN
CALL SGEMV( 'T', BSIZ2, BSIZ2, ONE, Q( QPTR( CURR+1 ) ),
$ BSIZ2, ZTEMP( PSIZ1+1 ), 1, ZERO, Z( MID ), 1 )
END IF
CALL SCOPY( PSIZ2-BSIZ2, ZTEMP( PSIZ1+BSIZ2+1 ), 1,
$ Z( MID+BSIZ2 ), 1 )
*
PTR = PTR + 2**( TLVLS-K )
70 CONTINUE
*
RETURN
*
* End of SLAEDA
*
END
SUBROUTINE SLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B,
$ LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL NOINIT, RIGHTV
INTEGER INFO, LDB, LDH, N
REAL BIGNUM, EPS3, SMLNUM, WI, WR
* ..
* .. Array Arguments ..
REAL B( LDB, * ), H( LDH, * ), VI( * ), VR( * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* SLAEIN uses inverse iteration to find a right or left eigenvector
* corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg
* matrix H.
*
* Arguments
* =========
*
* RIGHTV (input) LOGICAL
* = .TRUE. : compute right eigenvector;
* = .FALSE.: compute left eigenvector.
*
* NOINIT (input) LOGICAL
* = .TRUE. : no initial vector supplied in (VR,VI).
* = .FALSE.: initial vector supplied in (VR,VI).
*
* N (input) INTEGER
* The order of the matrix H. N >= 0.
*
* H (input) REAL array, dimension (LDH,N)
* The upper Hessenberg matrix H.
*
* LDH (input) INTEGER
* The leading dimension of the array H. LDH >= max(1,N).
*
* WR (input) REAL
* WI (input) REAL
* The real and imaginary parts of the eigenvalue of H whose
* corresponding right or left eigenvector is to be computed.
*
* VR (input/output) REAL array, dimension (N)
* VI (input/output) REAL array, dimension (N)
* On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain
* a real starting vector for inverse iteration using the real
* eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI
* must contain the real and imaginary parts of a complex
* starting vector for inverse iteration using the complex
* eigenvalue (WR,WI); otherwise VR and VI need not be set.
* On exit, if WI = 0.0 (real eigenvalue), VR contains the
* computed real eigenvector; if WI.ne.0.0 (complex eigenvalue),
* VR and VI contain the real and imaginary parts of the
* computed complex eigenvector. The eigenvector is normalized
* so that the component of largest magnitude has magnitude 1;
* here the magnitude of a complex number (x,y) is taken to be
* |x| + |y|.
* VI is not referenced if WI = 0.0.
*
* B (workspace) REAL array, dimension (LDB,N)
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= N+1.
*
* WORK (workspace) REAL array, dimension (N)
*
* EPS3 (input) REAL
* A small machine-dependent value which is used to perturb
* close eigenvalues, and to replace zero pivots.
*
* SMLNUM (input) REAL
* A machine-dependent value close to the underflow threshold.
*
* BIGNUM (input) REAL
* A machine-dependent value close to the overflow threshold.
*
* INFO (output) INTEGER
* = 0: successful exit
* = 1: inverse iteration did not converge; VR is set to the
* last iterate, and so is VI if WI.ne.0.0.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TENTH
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TENTH = 1.0E-1 )
* ..
* .. Local Scalars ..
CHARACTER NORMIN, TRANS
INTEGER I, I1, I2, I3, IERR, ITS, J
REAL ABSBII, ABSBJJ, EI, EJ, GROWTO, NORM, NRMSML,
$ REC, ROOTN, SCALE, TEMP, VCRIT, VMAX, VNORM, W,
$ W1, X, XI, XR, Y
* ..
* .. External Functions ..
INTEGER ISAMAX
REAL SASUM, SLAPY2, SNRM2
EXTERNAL ISAMAX, SASUM, SLAPY2, SNRM2
* ..
* .. External Subroutines ..
EXTERNAL SLADIV, SLATRS, SSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, REAL, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
*
* GROWTO is the threshold used in the acceptance test for an
* eigenvector.
*
ROOTN = SQRT( REAL( N ) )
GROWTO = TENTH / ROOTN
NRMSML = MAX( ONE, EPS3*ROOTN )*SMLNUM
*
* Form B = H - (WR,WI)*I (except that the subdiagonal elements and
* the imaginary parts of the diagonal elements are not stored).
*
DO 20 J = 1, N
DO 10 I = 1, J - 1
B( I, J ) = H( I, J )
10 CONTINUE
B( J, J ) = H( J, J ) - WR
20 CONTINUE
*
IF( WI.EQ.ZERO ) THEN
*
* Real eigenvalue.
*
IF( NOINIT ) THEN
*
* Set initial vector.
*
DO 30 I = 1, N
VR( I ) = EPS3
30 CONTINUE
ELSE
*
* Scale supplied initial vector.
*
VNORM = SNRM2( N, VR, 1 )
CALL SSCAL( N, ( EPS3*ROOTN ) / MAX( VNORM, NRMSML ), VR,
$ 1 )
END IF
*
IF( RIGHTV ) THEN
*
* LU decomposition with partial pivoting of B, replacing zero
* pivots by EPS3.
*
DO 60 I = 1, N - 1
EI = H( I+1, I )
IF( ABS( B( I, I ) ).LT.ABS( EI ) ) THEN
*
* Interchange rows and eliminate.
*
X = B( I, I ) / EI
B( I, I ) = EI
DO 40 J = I + 1, N
TEMP = B( I+1, J )
B( I+1, J ) = B( I, J ) - X*TEMP
B( I, J ) = TEMP
40 CONTINUE
ELSE
*
* Eliminate without interchange.
*
IF( B( I, I ).EQ.ZERO )
$ B( I, I ) = EPS3
X = EI / B( I, I )
IF( X.NE.ZERO ) THEN
DO 50 J = I + 1, N
B( I+1, J ) = B( I+1, J ) - X*B( I, J )
50 CONTINUE
END IF
END IF
60 CONTINUE
IF( B( N, N ).EQ.ZERO )
$ B( N, N ) = EPS3
*
TRANS = 'N'
*
ELSE
*
* UL decomposition with partial pivoting of B, replacing zero
* pivots by EPS3.
*
DO 90 J = N, 2, -1
EJ = H( J, J-1 )
IF( ABS( B( J, J ) ).LT.ABS( EJ ) ) THEN
*
* Interchange columns and eliminate.
*
X = B( J, J ) / EJ
B( J, J ) = EJ
DO 70 I = 1, J - 1
TEMP = B( I, J-1 )
B( I, J-1 ) = B( I, J ) - X*TEMP
B( I, J ) = TEMP
70 CONTINUE
ELSE
*
* Eliminate without interchange.
*
IF( B( J, J ).EQ.ZERO )
$ B( J, J ) = EPS3
X = EJ / B( J, J )
IF( X.NE.ZERO ) THEN
DO 80 I = 1, J - 1
B( I, J-1 ) = B( I, J-1 ) - X*B( I, J )
80 CONTINUE
END IF
END IF
90 CONTINUE
IF( B( 1, 1 ).EQ.ZERO )
$ B( 1, 1 ) = EPS3
*
TRANS = 'T'
*
END IF
*
NORMIN = 'N'
DO 110 ITS = 1, N
*
* Solve U*x = scale*v for a right eigenvector
* or U'*x = scale*v for a left eigenvector,
* overwriting x on v.
*
CALL SLATRS( 'Upper', TRANS, 'Nonunit', NORMIN, N, B, LDB,
$ VR, SCALE, WORK, IERR )
NORMIN = 'Y'
*
* Test for sufficient growth in the norm of v.
*
VNORM = SASUM( N, VR, 1 )
IF( VNORM.GE.GROWTO*SCALE )
$ GO TO 120
*
* Choose new orthogonal starting vector and try again.
*
TEMP = EPS3 / ( ROOTN+ONE )
VR( 1 ) = EPS3
DO 100 I = 2, N
VR( I ) = TEMP
100 CONTINUE
VR( N-ITS+1 ) = VR( N-ITS+1 ) - EPS3*ROOTN
110 CONTINUE
*
* Failure to find eigenvector in N iterations.
*
INFO = 1
*
120 CONTINUE
*
* Normalize eigenvector.
*
I = ISAMAX( N, VR, 1 )
CALL SSCAL( N, ONE / ABS( VR( I ) ), VR, 1 )
ELSE
*
* Complex eigenvalue.
*
IF( NOINIT ) THEN
*
* Set initial vector.
*
DO 130 I = 1, N
VR( I ) = EPS3
VI( I ) = ZERO
130 CONTINUE
ELSE
*
* Scale supplied initial vector.
*
NORM = SLAPY2( SNRM2( N, VR, 1 ), SNRM2( N, VI, 1 ) )
REC = ( EPS3*ROOTN ) / MAX( NORM, NRMSML )
CALL SSCAL( N, REC, VR, 1 )
CALL SSCAL( N, REC, VI, 1 )
END IF
*
IF( RIGHTV ) THEN
*
* LU decomposition with partial pivoting of B, replacing zero
* pivots by EPS3.
*
* The imaginary part of the (i,j)-th element of U is stored in
* B(j+1,i).
*
B( 2, 1 ) = -WI
DO 140 I = 2, N
B( I+1, 1 ) = ZERO
140 CONTINUE
*
DO 170 I = 1, N - 1
ABSBII = SLAPY2( B( I, I ), B( I+1, I ) )
EI = H( I+1, I )
IF( ABSBII.LT.ABS( EI ) ) THEN
*
* Interchange rows and eliminate.
*
XR = B( I, I ) / EI
XI = B( I+1, I ) / EI
B( I, I ) = EI
B( I+1, I ) = ZERO
DO 150 J = I + 1, N
TEMP = B( I+1, J )
B( I+1, J ) = B( I, J ) - XR*TEMP
B( J+1, I+1 ) = B( J+1, I ) - XI*TEMP
B( I, J ) = TEMP
B( J+1, I ) = ZERO
150 CONTINUE
B( I+2, I ) = -WI
B( I+1, I+1 ) = B( I+1, I+1 ) - XI*WI
B( I+2, I+1 ) = B( I+2, I+1 ) + XR*WI
ELSE
*
* Eliminate without interchanging rows.
*
IF( ABSBII.EQ.ZERO ) THEN
B( I, I ) = EPS3
B( I+1, I ) = ZERO
ABSBII = EPS3
END IF
EI = ( EI / ABSBII ) / ABSBII
XR = B( I, I )*EI
XI = -B( I+1, I )*EI
DO 160 J = I + 1, N
B( I+1, J ) = B( I+1, J ) - XR*B( I, J ) +
$ XI*B( J+1, I )
B( J+1, I+1 ) = -XR*B( J+1, I ) - XI*B( I, J )
160 CONTINUE
B( I+2, I+1 ) = B( I+2, I+1 ) - WI
END IF
*
* Compute 1-norm of offdiagonal elements of i-th row.
*
WORK( I ) = SASUM( N-I, B( I, I+1 ), LDB ) +
$ SASUM( N-I, B( I+2, I ), 1 )
170 CONTINUE
IF( B( N, N ).EQ.ZERO .AND. B( N+1, N ).EQ.ZERO )
$ B( N, N ) = EPS3
WORK( N ) = ZERO
*
I1 = N
I2 = 1
I3 = -1
ELSE
*
* UL decomposition with partial pivoting of conjg(B),
* replacing zero pivots by EPS3.
*
* The imaginary part of the (i,j)-th element of U is stored in
* B(j+1,i).
*
B( N+1, N ) = WI
DO 180 J = 1, N - 1
B( N+1, J ) = ZERO
180 CONTINUE
*
DO 210 J = N, 2, -1
EJ = H( J, J-1 )
ABSBJJ = SLAPY2( B( J, J ), B( J+1, J ) )
IF( ABSBJJ.LT.ABS( EJ ) ) THEN
*
* Interchange columns and eliminate
*
XR = B( J, J ) / EJ
XI = B( J+1, J ) / EJ
B( J, J ) = EJ
B( J+1, J ) = ZERO
DO 190 I = 1, J - 1
TEMP = B( I, J-1 )
B( I, J-1 ) = B( I, J ) - XR*TEMP
B( J, I ) = B( J+1, I ) - XI*TEMP
B( I, J ) = TEMP
B( J+1, I ) = ZERO
190 CONTINUE
B( J+1, J-1 ) = WI
B( J-1, J-1 ) = B( J-1, J-1 ) + XI*WI
B( J, J-1 ) = B( J, J-1 ) - XR*WI
ELSE
*
* Eliminate without interchange.
*
IF( ABSBJJ.EQ.ZERO ) THEN
B( J, J ) = EPS3
B( J+1, J ) = ZERO
ABSBJJ = EPS3
END IF
EJ = ( EJ / ABSBJJ ) / ABSBJJ
XR = B( J, J )*EJ
XI = -B( J+1, J )*EJ
DO 200 I = 1, J - 1
B( I, J-1 ) = B( I, J-1 ) - XR*B( I, J ) +
$ XI*B( J+1, I )
B( J, I ) = -XR*B( J+1, I ) - XI*B( I, J )
200 CONTINUE
B( J, J-1 ) = B( J, J-1 ) + WI
END IF
*
* Compute 1-norm of offdiagonal elements of j-th column.
*
WORK( J ) = SASUM( J-1, B( 1, J ), 1 ) +
$ SASUM( J-1, B( J+1, 1 ), LDB )
210 CONTINUE
IF( B( 1, 1 ).EQ.ZERO .AND. B( 2, 1 ).EQ.ZERO )
$ B( 1, 1 ) = EPS3
WORK( 1 ) = ZERO
*
I1 = 1
I2 = N
I3 = 1
END IF
*
DO 270 ITS = 1, N
SCALE = ONE
VMAX = ONE
VCRIT = BIGNUM
*
* Solve U*(xr,xi) = scale*(vr,vi) for a right eigenvector,
* or U'*(xr,xi) = scale*(vr,vi) for a left eigenvector,
* overwriting (xr,xi) on (vr,vi).
*
DO 250 I = I1, I2, I3
*
IF( WORK( I ).GT.VCRIT ) THEN
REC = ONE / VMAX
CALL SSCAL( N, REC, VR, 1 )
CALL SSCAL( N, REC, VI, 1 )
SCALE = SCALE*REC
VMAX = ONE
VCRIT = BIGNUM
END IF
*
XR = VR( I )
XI = VI( I )
IF( RIGHTV ) THEN
DO 220 J = I + 1, N
XR = XR - B( I, J )*VR( J ) + B( J+1, I )*VI( J )
XI = XI - B( I, J )*VI( J ) - B( J+1, I )*VR( J )
220 CONTINUE
ELSE
DO 230 J = 1, I - 1
XR = XR - B( J, I )*VR( J ) + B( I+1, J )*VI( J )
XI = XI - B( J, I )*VI( J ) - B( I+1, J )*VR( J )
230 CONTINUE
END IF
*
W = ABS( B( I, I ) ) + ABS( B( I+1, I ) )
IF( W.GT.SMLNUM ) THEN
IF( W.LT.ONE ) THEN
W1 = ABS( XR ) + ABS( XI )
IF( W1.GT.W*BIGNUM ) THEN
REC = ONE / W1
CALL SSCAL( N, REC, VR, 1 )
CALL SSCAL( N, REC, VI, 1 )
XR = VR( I )
XI = VI( I )
SCALE = SCALE*REC
VMAX = VMAX*REC
END IF
END IF
*
* Divide by diagonal element of B.
*
CALL SLADIV( XR, XI, B( I, I ), B( I+1, I ), VR( I ),
$ VI( I ) )
VMAX = MAX( ABS( VR( I ) )+ABS( VI( I ) ), VMAX )
VCRIT = BIGNUM / VMAX
ELSE
DO 240 J = 1, N
VR( J ) = ZERO
VI( J ) = ZERO
240 CONTINUE
VR( I ) = ONE
VI( I ) = ONE
SCALE = ZERO
VMAX = ONE
VCRIT = BIGNUM
END IF
250 CONTINUE
*
* Test for sufficient growth in the norm of (VR,VI).
*
VNORM = SASUM( N, VR, 1 ) + SASUM( N, VI, 1 )
IF( VNORM.GE.GROWTO*SCALE )
$ GO TO 280
*
* Choose a new orthogonal starting vector and try again.
*
Y = EPS3 / ( ROOTN+ONE )
VR( 1 ) = EPS3
VI( 1 ) = ZERO
*
DO 260 I = 2, N
VR( I ) = Y
VI( I ) = ZERO
260 CONTINUE
VR( N-ITS+1 ) = VR( N-ITS+1 ) - EPS3*ROOTN
270 CONTINUE
*
* Failure to find eigenvector in N iterations
*
INFO = 1
*
280 CONTINUE
*
* Normalize eigenvector.
*
VNORM = ZERO
DO 290 I = 1, N
VNORM = MAX( VNORM, ABS( VR( I ) )+ABS( VI( I ) ) )
290 CONTINUE
CALL SSCAL( N, ONE / VNORM, VR, 1 )
CALL SSCAL( N, ONE / VNORM, VI, 1 )
*
END IF
*
RETURN
*
* End of SLAEIN
*
END
SUBROUTINE SLAEV2( A, B, C, RT1, RT2, CS1, SN1 )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
REAL A, B, C, CS1, RT1, RT2, SN1
* ..
*
* Purpose
* =======
*
* SLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix
* [ A B ]
* [ B C ].
* On return, RT1 is the eigenvalue of larger absolute value, RT2 is the
* eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right
* eigenvector for RT1, giving the decomposition
*
* [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ]
* [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ].
*
* Arguments
* =========
*
* A (input) REAL
* The (1,1) element of the 2-by-2 matrix.
*
* B (input) REAL
* The (1,2) element and the conjugate of the (2,1) element of
* the 2-by-2 matrix.
*
* C (input) REAL
* The (2,2) element of the 2-by-2 matrix.
*
* RT1 (output) REAL
* The eigenvalue of larger absolute value.
*
* RT2 (output) REAL
* The eigenvalue of smaller absolute value.
*
* CS1 (output) REAL
* SN1 (output) REAL
* The vector (CS1, SN1) is a unit right eigenvector for RT1.
*
* Further Details
* ===============
*
* RT1 is accurate to a few ulps barring over/underflow.
*
* RT2 may be inaccurate if there is massive cancellation in the
* determinant A*C-B*B; higher precision or correctly rounded or
* correctly truncated arithmetic would be needed to compute RT2
* accurately in all cases.
*
* CS1 and SN1 are accurate to a few ulps barring over/underflow.
*
* Overflow is possible only if RT1 is within a factor of 5 of overflow.
* Underflow is harmless if the input data is 0 or exceeds
* underflow_threshold / macheps.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E0 )
REAL TWO
PARAMETER ( TWO = 2.0E0 )
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
REAL HALF
PARAMETER ( HALF = 0.5E0 )
* ..
* .. Local Scalars ..
INTEGER SGN1, SGN2
REAL AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM,
$ TB, TN
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SQRT
* ..
* .. Executable Statements ..
*
* Compute the eigenvalues
*
SM = A + C
DF = A - C
ADF = ABS( DF )
TB = B + B
AB = ABS( TB )
IF( ABS( A ).GT.ABS( C ) ) THEN
ACMX = A
ACMN = C
ELSE
ACMX = C
ACMN = A
END IF
IF( ADF.GT.AB ) THEN
RT = ADF*SQRT( ONE+( AB / ADF )**2 )
ELSE IF( ADF.LT.AB ) THEN
RT = AB*SQRT( ONE+( ADF / AB )**2 )
ELSE
*
* Includes case AB=ADF=0
*
RT = AB*SQRT( TWO )
END IF
IF( SM.LT.ZERO ) THEN
RT1 = HALF*( SM-RT )
SGN1 = -1
*
* Order of execution important.
* To get fully accurate smaller eigenvalue,
* next line needs to be executed in higher precision.
*
RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
ELSE IF( SM.GT.ZERO ) THEN
RT1 = HALF*( SM+RT )
SGN1 = 1
*
* Order of execution important.
* To get fully accurate smaller eigenvalue,
* next line needs to be executed in higher precision.
*
RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
ELSE
*
* Includes case RT1 = RT2 = 0
*
RT1 = HALF*RT
RT2 = -HALF*RT
SGN1 = 1
END IF
*
* Compute the eigenvector
*
IF( DF.GE.ZERO ) THEN
CS = DF + RT
SGN2 = 1
ELSE
CS = DF - RT
SGN2 = -1
END IF
ACS = ABS( CS )
IF( ACS.GT.AB ) THEN
CT = -TB / CS
SN1 = ONE / SQRT( ONE+CT*CT )
CS1 = CT*SN1
ELSE
IF( AB.EQ.ZERO ) THEN
CS1 = ONE
SN1 = ZERO
ELSE
TN = -CS / TB
CS1 = ONE / SQRT( ONE+TN*TN )
SN1 = TN*CS1
END IF
END IF
IF( SGN1.EQ.SGN2 ) THEN
TN = CS1
CS1 = -SN1
SN1 = TN
END IF
RETURN
*
* End of SLAEV2
*
END
SUBROUTINE SLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK,
$ INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL WANTQ
INTEGER INFO, J1, LDQ, LDT, N, N1, N2
* ..
* .. Array Arguments ..
REAL Q( LDQ, * ), T( LDT, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in
* an upper quasi-triangular matrix T by an orthogonal similarity
* transformation.
*
* T must be in Schur canonical form, that is, block upper triangular
* with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block
* has its diagonal elemnts equal and its off-diagonal elements of
* opposite sign.
*
* Arguments
* =========
*
* WANTQ (input) LOGICAL
* = .TRUE. : accumulate the transformation in the matrix Q;
* = .FALSE.: do not accumulate the transformation.
*
* N (input) INTEGER
* The order of the matrix T. N >= 0.
*
* T (input/output) REAL array, dimension (LDT,N)
* On entry, the upper quasi-triangular matrix T, in Schur
* canonical form.
* On exit, the updated matrix T, again in Schur canonical form.
*
* LDT (input) INTEGER
* The leading dimension of the array T. LDT >= max(1,N).
*
* Q (input/output) REAL array, dimension (LDQ,N)
* On entry, if WANTQ is .TRUE., the orthogonal matrix Q.
* On exit, if WANTQ is .TRUE., the updated matrix Q.
* If WANTQ is .FALSE., Q is not referenced.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q.
* LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N.
*
* J1 (input) INTEGER
* The index of the first row of the first block T11.
*
* N1 (input) INTEGER
* The order of the first block T11. N1 = 0, 1 or 2.
*
* N2 (input) INTEGER
* The order of the second block T22. N2 = 0, 1 or 2.
*
* WORK (workspace) REAL array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* = 1: the transformed matrix T would be too far from Schur
* form; the blocks are not swapped and T and Q are
* unchanged.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
REAL TEN
PARAMETER ( TEN = 1.0E+1 )
INTEGER LDD, LDX
PARAMETER ( LDD = 4, LDX = 2 )
* ..
* .. Local Scalars ..
INTEGER IERR, J2, J3, J4, K, ND
REAL CS, DNORM, EPS, SCALE, SMLNUM, SN, T11, T22,
$ T33, TAU, TAU1, TAU2, TEMP, THRESH, WI1, WI2,
$ WR1, WR2, XNORM
* ..
* .. Local Arrays ..
REAL D( LDD, 4 ), U( 3 ), U1( 3 ), U2( 3 ),
$ X( LDX, 2 )
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE
EXTERNAL SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SLACPY, SLANV2, SLARFG, SLARFX, SLARTG, SLASY2,
$ SROT
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Quick return if possible
*
IF( N.EQ.0 .OR. N1.EQ.0 .OR. N2.EQ.0 )
$ RETURN
IF( J1+N1.GT.N )
$ RETURN
*
J2 = J1 + 1
J3 = J1 + 2
J4 = J1 + 3
*
IF( N1.EQ.1 .AND. N2.EQ.1 ) THEN
*
* Swap two 1-by-1 blocks.
*
T11 = T( J1, J1 )
T22 = T( J2, J2 )
*
* Determine the transformation to perform the interchange.
*
CALL SLARTG( T( J1, J2 ), T22-T11, CS, SN, TEMP )
*
* Apply transformation to the matrix T.
*
IF( J3.LE.N )
$ CALL SROT( N-J1-1, T( J1, J3 ), LDT, T( J2, J3 ), LDT, CS,
$ SN )
CALL SROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN )
*
T( J1, J1 ) = T22
T( J2, J2 ) = T11
*
IF( WANTQ ) THEN
*
* Accumulate transformation in the matrix Q.
*
CALL SROT( N, Q( 1, J1 ), 1, Q( 1, J2 ), 1, CS, SN )
END IF
*
ELSE
*
* Swapping involves at least one 2-by-2 block.
*
* Copy the diagonal block of order N1+N2 to the local array D
* and compute its norm.
*
ND = N1 + N2
CALL SLACPY( 'Full', ND, ND, T( J1, J1 ), LDT, D, LDD )
DNORM = SLANGE( 'Max', ND, ND, D, LDD, WORK )
*
* Compute machine-dependent threshold for test for accepting
* swap.
*
EPS = SLAMCH( 'P' )
SMLNUM = SLAMCH( 'S' ) / EPS
THRESH = MAX( TEN*EPS*DNORM, SMLNUM )
*
* Solve T11*X - X*T22 = scale*T12 for X.
*
CALL SLASY2( .FALSE., .FALSE., -1, N1, N2, D, LDD,
$ D( N1+1, N1+1 ), LDD, D( 1, N1+1 ), LDD, SCALE, X,
$ LDX, XNORM, IERR )
*
* Swap the adjacent diagonal blocks.
*
K = N1 + N1 + N2 - 3
GO TO ( 10, 20, 30 )K
*
10 CONTINUE
*
* N1 = 1, N2 = 2: generate elementary reflector H so that:
*
* ( scale, X11, X12 ) H = ( 0, 0, * )
*
U( 1 ) = SCALE
U( 2 ) = X( 1, 1 )
U( 3 ) = X( 1, 2 )
CALL SLARFG( 3, U( 3 ), U, 1, TAU )
U( 3 ) = ONE
T11 = T( J1, J1 )
*
* Perform swap provisionally on diagonal block in D.
*
CALL SLARFX( 'L', 3, 3, U, TAU, D, LDD, WORK )
CALL SLARFX( 'R', 3, 3, U, TAU, D, LDD, WORK )
*
* Test whether to reject swap.
*
IF( MAX( ABS( D( 3, 1 ) ), ABS( D( 3, 2 ) ), ABS( D( 3,
$ 3 )-T11 ) ).GT.THRESH )GO TO 50
*
* Accept swap: apply transformation to the entire matrix T.
*
CALL SLARFX( 'L', 3, N-J1+1, U, TAU, T( J1, J1 ), LDT, WORK )
CALL SLARFX( 'R', J2, 3, U, TAU, T( 1, J1 ), LDT, WORK )
*
T( J3, J1 ) = ZERO
T( J3, J2 ) = ZERO
T( J3, J3 ) = T11
*
IF( WANTQ ) THEN
*
* Accumulate transformation in the matrix Q.
*
CALL SLARFX( 'R', N, 3, U, TAU, Q( 1, J1 ), LDQ, WORK )
END IF
GO TO 40
*
20 CONTINUE
*
* N1 = 2, N2 = 1: generate elementary reflector H so that:
*
* H ( -X11 ) = ( * )
* ( -X21 ) = ( 0 )
* ( scale ) = ( 0 )
*
U( 1 ) = -X( 1, 1 )
U( 2 ) = -X( 2, 1 )
U( 3 ) = SCALE
CALL SLARFG( 3, U( 1 ), U( 2 ), 1, TAU )
U( 1 ) = ONE
T33 = T( J3, J3 )
*
* Perform swap provisionally on diagonal block in D.
*
CALL SLARFX( 'L', 3, 3, U, TAU, D, LDD, WORK )
CALL SLARFX( 'R', 3, 3, U, TAU, D, LDD, WORK )
*
* Test whether to reject swap.
*
IF( MAX( ABS( D( 2, 1 ) ), ABS( D( 3, 1 ) ), ABS( D( 1,
$ 1 )-T33 ) ).GT.THRESH )GO TO 50
*
* Accept swap: apply transformation to the entire matrix T.
*
CALL SLARFX( 'R', J3, 3, U, TAU, T( 1, J1 ), LDT, WORK )
CALL SLARFX( 'L', 3, N-J1, U, TAU, T( J1, J2 ), LDT, WORK )
*
T( J1, J1 ) = T33
T( J2, J1 ) = ZERO
T( J3, J1 ) = ZERO
*
IF( WANTQ ) THEN
*
* Accumulate transformation in the matrix Q.
*
CALL SLARFX( 'R', N, 3, U, TAU, Q( 1, J1 ), LDQ, WORK )
END IF
GO TO 40
*
30 CONTINUE
*
* N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so
* that:
*
* H(2) H(1) ( -X11 -X12 ) = ( * * )
* ( -X21 -X22 ) ( 0 * )
* ( scale 0 ) ( 0 0 )
* ( 0 scale ) ( 0 0 )
*
U1( 1 ) = -X( 1, 1 )
U1( 2 ) = -X( 2, 1 )
U1( 3 ) = SCALE
CALL SLARFG( 3, U1( 1 ), U1( 2 ), 1, TAU1 )
U1( 1 ) = ONE
*
TEMP = -TAU1*( X( 1, 2 )+U1( 2 )*X( 2, 2 ) )
U2( 1 ) = -TEMP*U1( 2 ) - X( 2, 2 )
U2( 2 ) = -TEMP*U1( 3 )
U2( 3 ) = SCALE
CALL SLARFG( 3, U2( 1 ), U2( 2 ), 1, TAU2 )
U2( 1 ) = ONE
*
* Perform swap provisionally on diagonal block in D.
*
CALL SLARFX( 'L', 3, 4, U1, TAU1, D, LDD, WORK )
CALL SLARFX( 'R', 4, 3, U1, TAU1, D, LDD, WORK )
CALL SLARFX( 'L', 3, 4, U2, TAU2, D( 2, 1 ), LDD, WORK )
CALL SLARFX( 'R', 4, 3, U2, TAU2, D( 1, 2 ), LDD, WORK )
*
* Test whether to reject swap.
*
IF( MAX( ABS( D( 3, 1 ) ), ABS( D( 3, 2 ) ), ABS( D( 4, 1 ) ),
$ ABS( D( 4, 2 ) ) ).GT.THRESH )GO TO 50
*
* Accept swap: apply transformation to the entire matrix T.
*
CALL SLARFX( 'L', 3, N-J1+1, U1, TAU1, T( J1, J1 ), LDT, WORK )
CALL SLARFX( 'R', J4, 3, U1, TAU1, T( 1, J1 ), LDT, WORK )
CALL SLARFX( 'L', 3, N-J1+1, U2, TAU2, T( J2, J1 ), LDT, WORK )
CALL SLARFX( 'R', J4, 3, U2, TAU2, T( 1, J2 ), LDT, WORK )
*
T( J3, J1 ) = ZERO
T( J3, J2 ) = ZERO
T( J4, J1 ) = ZERO
T( J4, J2 ) = ZERO
*
IF( WANTQ ) THEN
*
* Accumulate transformation in the matrix Q.
*
CALL SLARFX( 'R', N, 3, U1, TAU1, Q( 1, J1 ), LDQ, WORK )
CALL SLARFX( 'R', N, 3, U2, TAU2, Q( 1, J2 ), LDQ, WORK )
END IF
*
40 CONTINUE
*
IF( N2.EQ.2 ) THEN
*
* Standardize new 2-by-2 block T11
*
CALL SLANV2( T( J1, J1 ), T( J1, J2 ), T( J2, J1 ),
$ T( J2, J2 ), WR1, WI1, WR2, WI2, CS, SN )
CALL SROT( N-J1-1, T( J1, J1+2 ), LDT, T( J2, J1+2 ), LDT,
$ CS, SN )
CALL SROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN )
IF( WANTQ )
$ CALL SROT( N, Q( 1, J1 ), 1, Q( 1, J2 ), 1, CS, SN )
END IF
*
IF( N1.EQ.2 ) THEN
*
* Standardize new 2-by-2 block T22
*
J3 = J1 + N2
J4 = J3 + 1
CALL SLANV2( T( J3, J3 ), T( J3, J4 ), T( J4, J3 ),
$ T( J4, J4 ), WR1, WI1, WR2, WI2, CS, SN )
IF( J3+2.LE.N )
$ CALL SROT( N-J3-1, T( J3, J3+2 ), LDT, T( J4, J3+2 ),
$ LDT, CS, SN )
CALL SROT( J3-1, T( 1, J3 ), 1, T( 1, J4 ), 1, CS, SN )
IF( WANTQ )
$ CALL SROT( N, Q( 1, J3 ), 1, Q( 1, J4 ), 1, CS, SN )
END IF
*
END IF
RETURN
*
* Exit with INFO = 1 if swap was rejected.
*
50 INFO = 1
RETURN
*
* End of SLAEXC
*
END
SUBROUTINE SLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1,
$ WR2, WI )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDB
REAL SAFMIN, SCALE1, SCALE2, WI, WR1, WR2
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* SLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue
* problem A - w B, with scaling as necessary to avoid over-/underflow.
*
* The scaling factor "s" results in a modified eigenvalue equation
*
* s A - w B
*
* where s is a non-negative scaling factor chosen so that w, w B,
* and s A do not overflow and, if possible, do not underflow, either.
*
* Arguments
* =========
*
* A (input) REAL array, dimension (LDA, 2)
* On entry, the 2 x 2 matrix A. It is assumed that its 1-norm
* is less than 1/SAFMIN. Entries less than
* sqrt(SAFMIN)*norm(A) are subject to being treated as zero.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= 2.
*
* B (input) REAL array, dimension (LDB, 2)
* On entry, the 2 x 2 upper triangular matrix B. It is
* assumed that the one-norm of B is less than 1/SAFMIN. The
* diagonals should be at least sqrt(SAFMIN) times the largest
* element of B (in absolute value); if a diagonal is smaller
* than that, then +/- sqrt(SAFMIN) will be used instead of
* that diagonal.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= 2.
*
* SAFMIN (input) REAL
* The smallest positive number s.t. 1/SAFMIN does not
* overflow. (This should always be SLAMCH('S') -- it is an
* argument in order to avoid having to call SLAMCH frequently.)
*
* SCALE1 (output) REAL
* A scaling factor used to avoid over-/underflow in the
* eigenvalue equation which defines the first eigenvalue. If
* the eigenvalues are complex, then the eigenvalues are
* ( WR1 +/- WI i ) / SCALE1 (which may lie outside the
* exponent range of the machine), SCALE1=SCALE2, and SCALE1
* will always be positive. If the eigenvalues are real, then
* the first (real) eigenvalue is WR1 / SCALE1 , but this may
* overflow or underflow, and in fact, SCALE1 may be zero or
* less than the underflow threshhold if the exact eigenvalue
* is sufficiently large.
*
* SCALE2 (output) REAL
* A scaling factor used to avoid over-/underflow in the
* eigenvalue equation which defines the second eigenvalue. If
* the eigenvalues are complex, then SCALE2=SCALE1. If the
* eigenvalues are real, then the second (real) eigenvalue is
* WR2 / SCALE2 , but this may overflow or underflow, and in
* fact, SCALE2 may be zero or less than the underflow
* threshhold if the exact eigenvalue is sufficiently large.
*
* WR1 (output) REAL
* If the eigenvalue is real, then WR1 is SCALE1 times the
* eigenvalue closest to the (2,2) element of A B**(-1). If the
* eigenvalue is complex, then WR1=WR2 is SCALE1 times the real
* part of the eigenvalues.
*
* WR2 (output) REAL
* If the eigenvalue is real, then WR2 is SCALE2 times the
* other eigenvalue. If the eigenvalue is complex, then
* WR1=WR2 is SCALE1 times the real part of the eigenvalues.
*
* WI (output) REAL
* If the eigenvalue is real, then WI is zero. If the
* eigenvalue is complex, then WI is SCALE1 times the imaginary
* part of the eigenvalues. WI will always be non-negative.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
REAL HALF
PARAMETER ( HALF = ONE / TWO )
REAL FUZZY1
PARAMETER ( FUZZY1 = ONE+1.0E-5 )
* ..
* .. Local Scalars ..
REAL A11, A12, A21, A22, ABI22, ANORM, AS11, AS12,
$ AS22, ASCALE, B11, B12, B22, BINV11, BINV22,
$ BMIN, BNORM, BSCALE, BSIZE, C1, C2, C3, C4, C5,
$ DIFF, DISCR, PP, QQ, R, RTMAX, RTMIN, S1, S2,
$ SAFMAX, SHIFT, SS, SUM, WABS, WBIG, WDET,
$ WSCALE, WSIZE, WSMALL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SIGN, SQRT
* ..
* .. Executable Statements ..
*
RTMIN = SQRT( SAFMIN )
RTMAX = ONE / RTMIN
SAFMAX = ONE / SAFMIN
*
* Scale A
*
ANORM = MAX( ABS( A( 1, 1 ) )+ABS( A( 2, 1 ) ),
$ ABS( A( 1, 2 ) )+ABS( A( 2, 2 ) ), SAFMIN )
ASCALE = ONE / ANORM
A11 = ASCALE*A( 1, 1 )
A21 = ASCALE*A( 2, 1 )
A12 = ASCALE*A( 1, 2 )
A22 = ASCALE*A( 2, 2 )
*
* Perturb B if necessary to insure non-singularity
*
B11 = B( 1, 1 )
B12 = B( 1, 2 )
B22 = B( 2, 2 )
BMIN = RTMIN*MAX( ABS( B11 ), ABS( B12 ), ABS( B22 ), RTMIN )
IF( ABS( B11 ).LT.BMIN )
$ B11 = SIGN( BMIN, B11 )
IF( ABS( B22 ).LT.BMIN )
$ B22 = SIGN( BMIN, B22 )
*
* Scale B
*
BNORM = MAX( ABS( B11 ), ABS( B12 )+ABS( B22 ), SAFMIN )
BSIZE = MAX( ABS( B11 ), ABS( B22 ) )
BSCALE = ONE / BSIZE
B11 = B11*BSCALE
B12 = B12*BSCALE
B22 = B22*BSCALE
*
* Compute larger eigenvalue by method described by C. van Loan
*
* ( AS is A shifted by -SHIFT*B )
*
BINV11 = ONE / B11
BINV22 = ONE / B22
S1 = A11*BINV11
S2 = A22*BINV22
IF( ABS( S1 ).LE.ABS( S2 ) ) THEN
AS12 = A12 - S1*B12
AS22 = A22 - S1*B22
SS = A21*( BINV11*BINV22 )
ABI22 = AS22*BINV22 - SS*B12
PP = HALF*ABI22
SHIFT = S1
ELSE
AS12 = A12 - S2*B12
AS11 = A11 - S2*B11
SS = A21*( BINV11*BINV22 )
ABI22 = -SS*B12
PP = HALF*( AS11*BINV11+ABI22 )
SHIFT = S2
END IF
QQ = SS*AS12
IF( ABS( PP*RTMIN ).GE.ONE ) THEN
DISCR = ( RTMIN*PP )**2 + QQ*SAFMIN
R = SQRT( ABS( DISCR ) )*RTMAX
ELSE
IF( PP**2+ABS( QQ ).LE.SAFMIN ) THEN
DISCR = ( RTMAX*PP )**2 + QQ*SAFMAX
R = SQRT( ABS( DISCR ) )*RTMIN
ELSE
DISCR = PP**2 + QQ
R = SQRT( ABS( DISCR ) )
END IF
END IF
*
* Note: the test of R in the following IF is to cover the case when
* DISCR is small and negative and is flushed to zero during
* the calculation of R. On machines which have a consistent
* flush-to-zero threshhold and handle numbers above that
* threshhold correctly, it would not be necessary.
*
IF( DISCR.GE.ZERO .OR. R.EQ.ZERO ) THEN
SUM = PP + SIGN( R, PP )
DIFF = PP - SIGN( R, PP )
WBIG = SHIFT + SUM
*
* Compute smaller eigenvalue
*
WSMALL = SHIFT + DIFF
IF( HALF*ABS( WBIG ).GT.MAX( ABS( WSMALL ), SAFMIN ) ) THEN
WDET = ( A11*A22-A12*A21 )*( BINV11*BINV22 )
WSMALL = WDET / WBIG
END IF
*
* Choose (real) eigenvalue closest to 2,2 element of A*B**(-1)
* for WR1.
*
IF( PP.GT.ABI22 ) THEN
WR1 = MIN( WBIG, WSMALL )
WR2 = MAX( WBIG, WSMALL )
ELSE
WR1 = MAX( WBIG, WSMALL )
WR2 = MIN( WBIG, WSMALL )
END IF
WI = ZERO
ELSE
*
* Complex eigenvalues
*
WR1 = SHIFT + PP
WR2 = WR1
WI = R
END IF
*
* Further scaling to avoid underflow and overflow in computing
* SCALE1 and overflow in computing w*B.
*
* This scale factor (WSCALE) is bounded from above using C1 and C2,
* and from below using C3 and C4.
* C1 implements the condition s A must never overflow.
* C2 implements the condition w B must never overflow.
* C3, with C2,
* implement the condition that s A - w B must never overflow.
* C4 implements the condition s should not underflow.
* C5 implements the condition max(s,|w|) should be at least 2.
*
C1 = BSIZE*( SAFMIN*MAX( ONE, ASCALE ) )
C2 = SAFMIN*MAX( ONE, BNORM )
C3 = BSIZE*SAFMIN
IF( ASCALE.LE.ONE .AND. BSIZE.LE.ONE ) THEN
C4 = MIN( ONE, ( ASCALE / SAFMIN )*BSIZE )
ELSE
C4 = ONE
END IF
IF( ASCALE.LE.ONE .OR. BSIZE.LE.ONE ) THEN
C5 = MIN( ONE, ASCALE*BSIZE )
ELSE
C5 = ONE
END IF
*
* Scale first eigenvalue
*
WABS = ABS( WR1 ) + ABS( WI )
WSIZE = MAX( SAFMIN, C1, FUZZY1*( WABS*C2+C3 ),
$ MIN( C4, HALF*MAX( WABS, C5 ) ) )
IF( WSIZE.NE.ONE ) THEN
WSCALE = ONE / WSIZE
IF( WSIZE.GT.ONE ) THEN
SCALE1 = ( MAX( ASCALE, BSIZE )*WSCALE )*
$ MIN( ASCALE, BSIZE )
ELSE
SCALE1 = ( MIN( ASCALE, BSIZE )*WSCALE )*
$ MAX( ASCALE, BSIZE )
END IF
WR1 = WR1*WSCALE
IF( WI.NE.ZERO ) THEN
WI = WI*WSCALE
WR2 = WR1
SCALE2 = SCALE1
END IF
ELSE
SCALE1 = ASCALE*BSIZE
SCALE2 = SCALE1
END IF
*
* Scale second eigenvalue (if real)
*
IF( WI.EQ.ZERO ) THEN
WSIZE = MAX( SAFMIN, C1, FUZZY1*( ABS( WR2 )*C2+C3 ),
$ MIN( C4, HALF*MAX( ABS( WR2 ), C5 ) ) )
IF( WSIZE.NE.ONE ) THEN
WSCALE = ONE / WSIZE
IF( WSIZE.GT.ONE ) THEN
SCALE2 = ( MAX( ASCALE, BSIZE )*WSCALE )*
$ MIN( ASCALE, BSIZE )
ELSE
SCALE2 = ( MIN( ASCALE, BSIZE )*WSCALE )*
$ MAX( ASCALE, BSIZE )
END IF
WR2 = WR2*WSCALE
ELSE
SCALE2 = ASCALE*BSIZE
END IF
END IF
*
* End of SLAG2
*
RETURN
END
SUBROUTINE SLAG2D( M, N, SA, LDSA, A, LDA, INFO)
*
* -- LAPACK PROTOTYPE auxiliary routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* January 2007
*
* ..
* .. WARNING: PROTOTYPE ..
* This is an LAPACK PROTOTYPE routine which means that the
* interface of this routine is likely to be changed in the future
* based on community feedback.
*
* .. Scalar Arguments ..
INTEGER INFO,LDA,LDSA,M,N
* ..
* .. Array Arguments ..
REAL SA(LDSA,*)
DOUBLE PRECISION A(LDA,*)
* ..
*
* Purpose
* =======
*
* SLAG2D converts a SINGLE PRECISION matrix, SA, to a DOUBLE
* PRECISION matrix, A.
*
* Note that while it is possible to overflow while converting
* from double to single, it is not possible to overflow when
* converting from single to double.
*
* This is a helper routine so there is no argument checking.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of lines of the matrix A. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix A. N >= 0.
*
* SA (output) REAL array, dimension (LDSA,N)
* On exit, the M-by-N coefficient matrix SA.
*
* LDSA (input) INTEGER
* The leading dimension of the array SA. LDSA >= max(1,M).
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the M-by-N coefficient matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* INFO (output) INTEGER
* = 0: successful exit
* =========
*
* .. Local Scalars ..
INTEGER I,J
* ..
* .. Executable Statements ..
*
INFO = 0
DO 20 J = 1,N
DO 30 I = 1,M
A(I,J) = SA(I,J)
30 CONTINUE
20 CONTINUE
RETURN
*
* End of SLAG2D
*
END
SUBROUTINE SLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV,
$ SNV, CSQ, SNQ )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL UPPER
REAL A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, SNQ,
$ SNU, SNV
* ..
*
* Purpose
* =======
*
* SLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such
* that if ( UPPER ) then
*
* U'*A*Q = U'*( A1 A2 )*Q = ( x 0 )
* ( 0 A3 ) ( x x )
* and
* V'*B*Q = V'*( B1 B2 )*Q = ( x 0 )
* ( 0 B3 ) ( x x )
*
* or if ( .NOT.UPPER ) then
*
* U'*A*Q = U'*( A1 0 )*Q = ( x x )
* ( A2 A3 ) ( 0 x )
* and
* V'*B*Q = V'*( B1 0 )*Q = ( x x )
* ( B2 B3 ) ( 0 x )
*
* The rows of the transformed A and B are parallel, where
*
* U = ( CSU SNU ), V = ( CSV SNV ), Q = ( CSQ SNQ )
* ( -SNU CSU ) ( -SNV CSV ) ( -SNQ CSQ )
*
* Z' denotes the transpose of Z.
*
*
* Arguments
* =========
*
* UPPER (input) LOGICAL
* = .TRUE.: the input matrices A and B are upper triangular.
* = .FALSE.: the input matrices A and B are lower triangular.
*
* A1 (input) REAL
* A2 (input) REAL
* A3 (input) REAL
* On entry, A1, A2 and A3 are elements of the input 2-by-2
* upper (lower) triangular matrix A.
*
* B1 (input) REAL
* B2 (input) REAL
* B3 (input) REAL
* On entry, B1, B2 and B3 are elements of the input 2-by-2
* upper (lower) triangular matrix B.
*
* CSU (output) REAL
* SNU (output) REAL
* The desired orthogonal matrix U.
*
* CSV (output) REAL
* SNV (output) REAL
* The desired orthogonal matrix V.
*
* CSQ (output) REAL
* SNQ (output) REAL
* The desired orthogonal matrix Q.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
REAL A, AUA11, AUA12, AUA21, AUA22, AVB11, AVB12,
$ AVB21, AVB22, CSL, CSR, D, S1, S2, SNL,
$ SNR, UA11R, UA22R, VB11R, VB22R, B, C, R, UA11,
$ UA12, UA21, UA22, VB11, VB12, VB21, VB22
* ..
* .. External Subroutines ..
EXTERNAL SLARTG, SLASV2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
IF( UPPER ) THEN
*
* Input matrices A and B are upper triangular matrices
*
* Form matrix C = A*adj(B) = ( a b )
* ( 0 d )
*
A = A1*B3
D = A3*B1
B = A2*B1 - A1*B2
*
* The SVD of real 2-by-2 triangular C
*
* ( CSL -SNL )*( A B )*( CSR SNR ) = ( R 0 )
* ( SNL CSL ) ( 0 D ) ( -SNR CSR ) ( 0 T )
*
CALL SLASV2( A, B, D, S1, S2, SNR, CSR, SNL, CSL )
*
IF( ABS( CSL ).GE.ABS( SNL ) .OR. ABS( CSR ).GE.ABS( SNR ) )
$ THEN
*
* Compute the (1,1) and (1,2) elements of U'*A and V'*B,
* and (1,2) element of |U|'*|A| and |V|'*|B|.
*
UA11R = CSL*A1
UA12 = CSL*A2 + SNL*A3
*
VB11R = CSR*B1
VB12 = CSR*B2 + SNR*B3
*
AUA12 = ABS( CSL )*ABS( A2 ) + ABS( SNL )*ABS( A3 )
AVB12 = ABS( CSR )*ABS( B2 ) + ABS( SNR )*ABS( B3 )
*
* zero (1,2) elements of U'*A and V'*B
*
IF( ( ABS( UA11R )+ABS( UA12 ) ).NE.ZERO ) THEN
IF( AUA12 / ( ABS( UA11R )+ABS( UA12 ) ).LE.AVB12 /
$ ( ABS( VB11R )+ABS( VB12 ) ) ) THEN
CALL SLARTG( -UA11R, UA12, CSQ, SNQ, R )
ELSE
CALL SLARTG( -VB11R, VB12, CSQ, SNQ, R )
END IF
ELSE
CALL SLARTG( -VB11R, VB12, CSQ, SNQ, R )
END IF
*
CSU = CSL
SNU = -SNL
CSV = CSR
SNV = -SNR
*
ELSE
*
* Compute the (2,1) and (2,2) elements of U'*A and V'*B,
* and (2,2) element of |U|'*|A| and |V|'*|B|.
*
UA21 = -SNL*A1
UA22 = -SNL*A2 + CSL*A3
*
VB21 = -SNR*B1
VB22 = -SNR*B2 + CSR*B3
*
AUA22 = ABS( SNL )*ABS( A2 ) + ABS( CSL )*ABS( A3 )
AVB22 = ABS( SNR )*ABS( B2 ) + ABS( CSR )*ABS( B3 )
*
* zero (2,2) elements of U'*A and V'*B, and then swap.
*
IF( ( ABS( UA21 )+ABS( UA22 ) ).NE.ZERO ) THEN
IF( AUA22 / ( ABS( UA21 )+ABS( UA22 ) ).LE.AVB22 /
$ ( ABS( VB21 )+ABS( VB22 ) ) ) THEN
CALL SLARTG( -UA21, UA22, CSQ, SNQ, R )
ELSE
CALL SLARTG( -VB21, VB22, CSQ, SNQ, R )
END IF
ELSE
CALL SLARTG( -VB21, VB22, CSQ, SNQ, R )
END IF
*
CSU = SNL
SNU = CSL
CSV = SNR
SNV = CSR
*
END IF
*
ELSE
*
* Input matrices A and B are lower triangular matrices
*
* Form matrix C = A*adj(B) = ( a 0 )
* ( c d )
*
A = A1*B3
D = A3*B1
C = A2*B3 - A3*B2
*
* The SVD of real 2-by-2 triangular C
*
* ( CSL -SNL )*( A 0 )*( CSR SNR ) = ( R 0 )
* ( SNL CSL ) ( C D ) ( -SNR CSR ) ( 0 T )
*
CALL SLASV2( A, C, D, S1, S2, SNR, CSR, SNL, CSL )
*
IF( ABS( CSR ).GE.ABS( SNR ) .OR. ABS( CSL ).GE.ABS( SNL ) )
$ THEN
*
* Compute the (2,1) and (2,2) elements of U'*A and V'*B,
* and (2,1) element of |U|'*|A| and |V|'*|B|.
*
UA21 = -SNR*A1 + CSR*A2
UA22R = CSR*A3
*
VB21 = -SNL*B1 + CSL*B2
VB22R = CSL*B3
*
AUA21 = ABS( SNR )*ABS( A1 ) + ABS( CSR )*ABS( A2 )
AVB21 = ABS( SNL )*ABS( B1 ) + ABS( CSL )*ABS( B2 )
*
* zero (2,1) elements of U'*A and V'*B.
*
IF( ( ABS( UA21 )+ABS( UA22R ) ).NE.ZERO ) THEN
IF( AUA21 / ( ABS( UA21 )+ABS( UA22R ) ).LE.AVB21 /
$ ( ABS( VB21 )+ABS( VB22R ) ) ) THEN
CALL SLARTG( UA22R, UA21, CSQ, SNQ, R )
ELSE
CALL SLARTG( VB22R, VB21, CSQ, SNQ, R )
END IF
ELSE
CALL SLARTG( VB22R, VB21, CSQ, SNQ, R )
END IF
*
CSU = CSR
SNU = -SNR
CSV = CSL
SNV = -SNL
*
ELSE
*
* Compute the (1,1) and (1,2) elements of U'*A and V'*B,
* and (1,1) element of |U|'*|A| and |V|'*|B|.
*
UA11 = CSR*A1 + SNR*A2
UA12 = SNR*A3
*
VB11 = CSL*B1 + SNL*B2
VB12 = SNL*B3
*
AUA11 = ABS( CSR )*ABS( A1 ) + ABS( SNR )*ABS( A2 )
AVB11 = ABS( CSL )*ABS( B1 ) + ABS( SNL )*ABS( B2 )
*
* zero (1,1) elements of U'*A and V'*B, and then swap.
*
IF( ( ABS( UA11 )+ABS( UA12 ) ).NE.ZERO ) THEN
IF( AUA11 / ( ABS( UA11 )+ABS( UA12 ) ).LE.AVB11 /
$ ( ABS( VB11 )+ABS( VB12 ) ) ) THEN
CALL SLARTG( UA12, UA11, CSQ, SNQ, R )
ELSE
CALL SLARTG( VB12, VB11, CSQ, SNQ, R )
END IF
ELSE
CALL SLARTG( VB12, VB11, CSQ, SNQ, R )
END IF
*
CSU = SNR
SNU = CSR
CSV = SNL
SNV = CSL
*
END IF
*
END IF
*
RETURN
*
* End of SLAGS2
*
END
SUBROUTINE SLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, N
REAL LAMBDA, TOL
* ..
* .. Array Arguments ..
INTEGER IN( * )
REAL A( * ), B( * ), C( * ), D( * )
* ..
*
* Purpose
* =======
*
* SLAGTF factorizes the matrix (T - lambda*I), where T is an n by n
* tridiagonal matrix and lambda is a scalar, as
*
* T - lambda*I = PLU,
*
* where P is a permutation matrix, L is a unit lower tridiagonal matrix
* with at most one non-zero sub-diagonal elements per column and U is
* an upper triangular matrix with at most two non-zero super-diagonal
* elements per column.
*
* The factorization is obtained by Gaussian elimination with partial
* pivoting and implicit row scaling.
*
* The parameter LAMBDA is included in the routine so that SLAGTF may
* be used, in conjunction with SLAGTS, to obtain eigenvectors of T by
* inverse iteration.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix T.
*
* A (input/output) REAL array, dimension (N)
* On entry, A must contain the diagonal elements of T.
*
* On exit, A is overwritten by the n diagonal elements of the
* upper triangular matrix U of the factorization of T.
*
* LAMBDA (input) REAL
* On entry, the scalar lambda.
*
* B (input/output) REAL array, dimension (N-1)
* On entry, B must contain the (n-1) super-diagonal elements of
* T.
*
* On exit, B is overwritten by the (n-1) super-diagonal
* elements of the matrix U of the factorization of T.
*
* C (input/output) REAL array, dimension (N-1)
* On entry, C must contain the (n-1) sub-diagonal elements of
* T.
*
* On exit, C is overwritten by the (n-1) sub-diagonal elements
* of the matrix L of the factorization of T.
*
* TOL (input) REAL
* On entry, a relative tolerance used to indicate whether or
* not the matrix (T - lambda*I) is nearly singular. TOL should
* normally be chose as approximately the largest relative error
* in the elements of T. For example, if the elements of T are
* correct to about 4 significant figures, then TOL should be
* set to about 5*10**(-4). If TOL is supplied as less than eps,
* where eps is the relative machine precision, then the value
* eps is used in place of TOL.
*
* D (output) REAL array, dimension (N-2)
* On exit, D is overwritten by the (n-2) second super-diagonal
* elements of the matrix U of the factorization of T.
*
* IN (output) INTEGER array, dimension (N)
* On exit, IN contains details of the permutation matrix P. If
* an interchange occurred at the kth step of the elimination,
* then IN(k) = 1, otherwise IN(k) = 0. The element IN(n)
* returns the smallest positive integer j such that
*
* abs( u(j,j) ).le. norm( (T - lambda*I)(j) )*TOL,
*
* where norm( A(j) ) denotes the sum of the absolute values of
* the jth row of the matrix A. If no such j exists then IN(n)
* is returned as zero. If IN(n) is returned as positive, then a
* diagonal element of U is small, indicating that
* (T - lambda*I) is singular or nearly singular,
*
* INFO (output) INTEGER
* = 0 : successful exit
* .lt. 0: if INFO = -k, the kth argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER K
REAL EPS, MULT, PIV1, PIV2, SCALE1, SCALE2, TEMP, TL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
CALL XERBLA( 'SLAGTF', -INFO )
RETURN
END IF
*
IF( N.EQ.0 )
$ RETURN
*
A( 1 ) = A( 1 ) - LAMBDA
IN( N ) = 0
IF( N.EQ.1 ) THEN
IF( A( 1 ).EQ.ZERO )
$ IN( 1 ) = 1
RETURN
END IF
*
EPS = SLAMCH( 'Epsilon' )
*
TL = MAX( TOL, EPS )
SCALE1 = ABS( A( 1 ) ) + ABS( B( 1 ) )
DO 10 K = 1, N - 1
A( K+1 ) = A( K+1 ) - LAMBDA
SCALE2 = ABS( C( K ) ) + ABS( A( K+1 ) )
IF( K.LT.( N-1 ) )
$ SCALE2 = SCALE2 + ABS( B( K+1 ) )
IF( A( K ).EQ.ZERO ) THEN
PIV1 = ZERO
ELSE
PIV1 = ABS( A( K ) ) / SCALE1
END IF
IF( C( K ).EQ.ZERO ) THEN
IN( K ) = 0
PIV2 = ZERO
SCALE1 = SCALE2
IF( K.LT.( N-1 ) )
$ D( K ) = ZERO
ELSE
PIV2 = ABS( C( K ) ) / SCALE2
IF( PIV2.LE.PIV1 ) THEN
IN( K ) = 0
SCALE1 = SCALE2
C( K ) = C( K ) / A( K )
A( K+1 ) = A( K+1 ) - C( K )*B( K )
IF( K.LT.( N-1 ) )
$ D( K ) = ZERO
ELSE
IN( K ) = 1
MULT = A( K ) / C( K )
A( K ) = C( K )
TEMP = A( K+1 )
A( K+1 ) = B( K ) - MULT*TEMP
IF( K.LT.( N-1 ) ) THEN
D( K ) = B( K+1 )
B( K+1 ) = -MULT*D( K )
END IF
B( K ) = TEMP
C( K ) = MULT
END IF
END IF
IF( ( MAX( PIV1, PIV2 ).LE.TL ) .AND. ( IN( N ).EQ.0 ) )
$ IN( N ) = K
10 CONTINUE
IF( ( ABS( A( N ) ).LE.SCALE1*TL ) .AND. ( IN( N ).EQ.0 ) )
$ IN( N ) = N
*
RETURN
*
* End of SLAGTF
*
END
SUBROUTINE SLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA,
$ B, LDB )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER LDB, LDX, N, NRHS
REAL ALPHA, BETA
* ..
* .. Array Arguments ..
REAL B( LDB, * ), D( * ), DL( * ), DU( * ),
$ X( LDX, * )
* ..
*
* Purpose
* =======
*
* SLAGTM performs a matrix-vector product of the form
*
* B := alpha * A * X + beta * B
*
* where A is a tridiagonal matrix of order N, B and X are N by NRHS
* matrices, and alpha and beta are real scalars, each of which may be
* 0., 1., or -1.
*
* Arguments
* =========
*
* TRANS (input) CHARACTER*1
* Specifies the operation applied to A.
* = 'N': No transpose, B := alpha * A * X + beta * B
* = 'T': Transpose, B := alpha * A'* X + beta * B
* = 'C': 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 matrices X and B.
*
* ALPHA (input) REAL
* The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise,
* it is assumed to be 0.
*
* DL (input) REAL array, dimension (N-1)
* The (n-1) sub-diagonal elements of T.
*
* D (input) REAL array, dimension (N)
* The diagonal elements of T.
*
* DU (input) REAL array, dimension (N-1)
* The (n-1) super-diagonal elements of T.
*
* X (input) REAL array, dimension (LDX,NRHS)
* The N by NRHS matrix X.
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(N,1).
*
* BETA (input) REAL
* The scalar beta. BETA must be 0., 1., or -1.; otherwise,
* it is assumed to be 1.
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the N by NRHS matrix B.
* On exit, B is overwritten by the matrix expression
* B := alpha * A * X + beta * B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(N,1).
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 )
$ RETURN
*
* Multiply B by BETA if BETA.NE.1.
*
IF( BETA.EQ.ZERO ) THEN
DO 20 J = 1, NRHS
DO 10 I = 1, N
B( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
ELSE IF( BETA.EQ.-ONE ) THEN
DO 40 J = 1, NRHS
DO 30 I = 1, N
B( I, J ) = -B( I, J )
30 CONTINUE
40 CONTINUE
END IF
*
IF( ALPHA.EQ.ONE ) THEN
IF( LSAME( TRANS, 'N' ) ) THEN
*
* Compute B := B + A*X
*
DO 60 J = 1, NRHS
IF( N.EQ.1 ) THEN
B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J )
ELSE
B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) +
$ DU( 1 )*X( 2, J )
B( N, J ) = B( N, J ) + DL( N-1 )*X( N-1, J ) +
$ D( N )*X( N, J )
DO 50 I = 2, N - 1
B( I, J ) = B( I, J ) + DL( I-1 )*X( I-1, J ) +
$ D( I )*X( I, J ) + DU( I )*X( I+1, J )
50 CONTINUE
END IF
60 CONTINUE
ELSE
*
* Compute B := B + A'*X
*
DO 80 J = 1, NRHS
IF( N.EQ.1 ) THEN
B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J )
ELSE
B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) +
$ DL( 1 )*X( 2, J )
B( N, J ) = B( N, J ) + DU( N-1 )*X( N-1, J ) +
$ D( N )*X( N, J )
DO 70 I = 2, N - 1
B( I, J ) = B( I, J ) + DU( I-1 )*X( I-1, J ) +
$ D( I )*X( I, J ) + DL( I )*X( I+1, J )
70 CONTINUE
END IF
80 CONTINUE
END IF
ELSE IF( ALPHA.EQ.-ONE ) THEN
IF( LSAME( TRANS, 'N' ) ) THEN
*
* Compute B := B - A*X
*
DO 100 J = 1, NRHS
IF( N.EQ.1 ) THEN
B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J )
ELSE
B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) -
$ DU( 1 )*X( 2, J )
B( N, J ) = B( N, J ) - DL( N-1 )*X( N-1, J ) -
$ D( N )*X( N, J )
DO 90 I = 2, N - 1
B( I, J ) = B( I, J ) - DL( I-1 )*X( I-1, J ) -
$ D( I )*X( I, J ) - DU( I )*X( I+1, J )
90 CONTINUE
END IF
100 CONTINUE
ELSE
*
* Compute B := B - A'*X
*
DO 120 J = 1, NRHS
IF( N.EQ.1 ) THEN
B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J )
ELSE
B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) -
$ DL( 1 )*X( 2, J )
B( N, J ) = B( N, J ) - DU( N-1 )*X( N-1, J ) -
$ D( N )*X( N, J )
DO 110 I = 2, N - 1
B( I, J ) = B( I, J ) - DU( I-1 )*X( I-1, J ) -
$ D( I )*X( I, J ) - DL( I )*X( I+1, J )
110 CONTINUE
END IF
120 CONTINUE
END IF
END IF
RETURN
*
* End of SLAGTM
*
END
SUBROUTINE SLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, JOB, N
REAL TOL
* ..
* .. Array Arguments ..
INTEGER IN( * )
REAL A( * ), B( * ), C( * ), D( * ), Y( * )
* ..
*
* Purpose
* =======
*
* SLAGTS may be used to solve one of the systems of equations
*
* (T - lambda*I)*x = y or (T - lambda*I)'*x = y,
*
* where T is an n by n tridiagonal matrix, for x, following the
* factorization of (T - lambda*I) as
*
* (T - lambda*I) = P*L*U ,
*
* by routine SLAGTF. The choice of equation to be solved is
* controlled by the argument JOB, and in each case there is an option
* to perturb zero or very small diagonal elements of U, this option
* being intended for use in applications such as inverse iteration.
*
* Arguments
* =========
*
* JOB (input) INTEGER
* Specifies the job to be performed by SLAGTS as follows:
* = 1: The equations (T - lambda*I)x = y are to be solved,
* but diagonal elements of U are not to be perturbed.
* = -1: The equations (T - lambda*I)x = y are to be solved
* and, if overflow would otherwise occur, the diagonal
* elements of U are to be perturbed. See argument TOL
* below.
* = 2: The equations (T - lambda*I)'x = y are to be solved,
* but diagonal elements of U are not to be perturbed.
* = -2: The equations (T - lambda*I)'x = y are to be solved
* and, if overflow would otherwise occur, the diagonal
* elements of U are to be perturbed. See argument TOL
* below.
*
* N (input) INTEGER
* The order of the matrix T.
*
* A (input) REAL array, dimension (N)
* On entry, A must contain the diagonal elements of U as
* returned from SLAGTF.
*
* B (input) REAL array, dimension (N-1)
* On entry, B must contain the first super-diagonal elements of
* U as returned from SLAGTF.
*
* C (input) REAL array, dimension (N-1)
* On entry, C must contain the sub-diagonal elements of L as
* returned from SLAGTF.
*
* D (input) REAL array, dimension (N-2)
* On entry, D must contain the second super-diagonal elements
* of U as returned from SLAGTF.
*
* IN (input) INTEGER array, dimension (N)
* On entry, IN must contain details of the matrix P as returned
* from SLAGTF.
*
* Y (input/output) REAL array, dimension (N)
* On entry, the right hand side vector y.
* On exit, Y is overwritten by the solution vector x.
*
* TOL (input/output) REAL
* On entry, with JOB .lt. 0, TOL should be the minimum
* perturbation to be made to very small diagonal elements of U.
* TOL should normally be chosen as about eps*norm(U), where eps
* is the relative machine precision, but if TOL is supplied as
* non-positive, then it is reset to eps*max( abs( u(i,j) ) ).
* If JOB .gt. 0 then TOL is not referenced.
*
* On exit, TOL is changed as described above, only if TOL is
* non-positive on entry. Otherwise TOL is unchanged.
*
* INFO (output) INTEGER
* = 0 : successful exit
* .lt. 0: if INFO = -i, the i-th argument had an illegal value
* .gt. 0: overflow would occur when computing the INFO(th)
* element of the solution vector x. This can only occur
* when JOB is supplied as positive and either means
* that a diagonal element of U is very small, or that
* the elements of the right-hand side vector y are very
* large.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER K
REAL ABSAK, AK, BIGNUM, EPS, PERT, SFMIN, TEMP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SIGN
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
INFO = 0
IF( ( ABS( JOB ).GT.2 ) .OR. ( JOB.EQ.0 ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLAGTS', -INFO )
RETURN
END IF
*
IF( N.EQ.0 )
$ RETURN
*
EPS = SLAMCH( 'Epsilon' )
SFMIN = SLAMCH( 'Safe minimum' )
BIGNUM = ONE / SFMIN
*
IF( JOB.LT.0 ) THEN
IF( TOL.LE.ZERO ) THEN
TOL = ABS( A( 1 ) )
IF( N.GT.1 )
$ TOL = MAX( TOL, ABS( A( 2 ) ), ABS( B( 1 ) ) )
DO 10 K = 3, N
TOL = MAX( TOL, ABS( A( K ) ), ABS( B( K-1 ) ),
$ ABS( D( K-2 ) ) )
10 CONTINUE
TOL = TOL*EPS
IF( TOL.EQ.ZERO )
$ TOL = EPS
END IF
END IF
*
IF( ABS( JOB ).EQ.1 ) THEN
DO 20 K = 2, N
IF( IN( K-1 ).EQ.0 ) THEN
Y( K ) = Y( K ) - C( K-1 )*Y( K-1 )
ELSE
TEMP = Y( K-1 )
Y( K-1 ) = Y( K )
Y( K ) = TEMP - C( K-1 )*Y( K )
END IF
20 CONTINUE
IF( JOB.EQ.1 ) THEN
DO 30 K = N, 1, -1
IF( K.LE.N-2 ) THEN
TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 )
ELSE IF( K.EQ.N-1 ) THEN
TEMP = Y( K ) - B( K )*Y( K+1 )
ELSE
TEMP = Y( K )
END IF
AK = A( K )
ABSAK = ABS( AK )
IF( ABSAK.LT.ONE ) THEN
IF( ABSAK.LT.SFMIN ) THEN
IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
$ THEN
INFO = K
RETURN
ELSE
TEMP = TEMP*BIGNUM
AK = AK*BIGNUM
END IF
ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
INFO = K
RETURN
END IF
END IF
Y( K ) = TEMP / AK
30 CONTINUE
ELSE
DO 50 K = N, 1, -1
IF( K.LE.N-2 ) THEN
TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 )
ELSE IF( K.EQ.N-1 ) THEN
TEMP = Y( K ) - B( K )*Y( K+1 )
ELSE
TEMP = Y( K )
END IF
AK = A( K )
PERT = SIGN( TOL, AK )
40 CONTINUE
ABSAK = ABS( AK )
IF( ABSAK.LT.ONE ) THEN
IF( ABSAK.LT.SFMIN ) THEN
IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
$ THEN
AK = AK + PERT
PERT = 2*PERT
GO TO 40
ELSE
TEMP = TEMP*BIGNUM
AK = AK*BIGNUM
END IF
ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
AK = AK + PERT
PERT = 2*PERT
GO TO 40
END IF
END IF
Y( K ) = TEMP / AK
50 CONTINUE
END IF
ELSE
*
* Come to here if JOB = 2 or -2
*
IF( JOB.EQ.2 ) THEN
DO 60 K = 1, N
IF( K.GE.3 ) THEN
TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 )
ELSE IF( K.EQ.2 ) THEN
TEMP = Y( K ) - B( K-1 )*Y( K-1 )
ELSE
TEMP = Y( K )
END IF
AK = A( K )
ABSAK = ABS( AK )
IF( ABSAK.LT.ONE ) THEN
IF( ABSAK.LT.SFMIN ) THEN
IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
$ THEN
INFO = K
RETURN
ELSE
TEMP = TEMP*BIGNUM
AK = AK*BIGNUM
END IF
ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
INFO = K
RETURN
END IF
END IF
Y( K ) = TEMP / AK
60 CONTINUE
ELSE
DO 80 K = 1, N
IF( K.GE.3 ) THEN
TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 )
ELSE IF( K.EQ.2 ) THEN
TEMP = Y( K ) - B( K-1 )*Y( K-1 )
ELSE
TEMP = Y( K )
END IF
AK = A( K )
PERT = SIGN( TOL, AK )
70 CONTINUE
ABSAK = ABS( AK )
IF( ABSAK.LT.ONE ) THEN
IF( ABSAK.LT.SFMIN ) THEN
IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
$ THEN
AK = AK + PERT
PERT = 2*PERT
GO TO 70
ELSE
TEMP = TEMP*BIGNUM
AK = AK*BIGNUM
END IF
ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
AK = AK + PERT
PERT = 2*PERT
GO TO 70
END IF
END IF
Y( K ) = TEMP / AK
80 CONTINUE
END IF
*
DO 90 K = N, 2, -1
IF( IN( K-1 ).EQ.0 ) THEN
Y( K-1 ) = Y( K-1 ) - C( K-1 )*Y( K )
ELSE
TEMP = Y( K-1 )
Y( K-1 ) = Y( K )
Y( K ) = TEMP - C( K-1 )*Y( K )
END IF
90 CONTINUE
END IF
*
* End of SLAGTS
*
END
SUBROUTINE SLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL,
$ CSR, SNR )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDB
REAL CSL, CSR, SNL, SNR
* ..
* .. Array Arguments ..
REAL A( LDA, * ), ALPHAI( 2 ), ALPHAR( 2 ),
$ B( LDB, * ), BETA( 2 )
* ..
*
* Purpose
* =======
*
* SLAGV2 computes the Generalized Schur factorization of a real 2-by-2
* matrix pencil (A,B) where B is upper triangular. This routine
* computes orthogonal (rotation) matrices given by CSL, SNL and CSR,
* SNR such that
*
* 1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0
* types), then
*
* [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ]
* [ 0 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ]
*
* [ b11 b12 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ]
* [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ],
*
* 2) if the pencil (A,B) has a pair of complex conjugate eigenvalues,
* then
*
* [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ]
* [ a21 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ]
*
* [ b11 0 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ]
* [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ]
*
* where b11 >= b22 > 0.
*
*
* Arguments
* =========
*
* A (input/output) REAL array, dimension (LDA, 2)
* On entry, the 2 x 2 matrix A.
* On exit, A is overwritten by the ``A-part'' of the
* generalized Schur form.
*
* LDA (input) INTEGER
* THe leading dimension of the array A. LDA >= 2.
*
* B (input/output) REAL array, dimension (LDB, 2)
* On entry, the upper triangular 2 x 2 matrix B.
* On exit, B is overwritten by the ``B-part'' of the
* generalized Schur form.
*
* LDB (input) INTEGER
* THe leading dimension of the array B. LDB >= 2.
*
* ALPHAR (output) REAL array, dimension (2)
* ALPHAI (output) REAL array, dimension (2)
* BETA (output) REAL array, dimension (2)
* (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the
* pencil (A,B), k=1,2, i = sqrt(-1). Note that BETA(k) may
* be zero.
*
* CSL (output) REAL
* The cosine of the left rotation matrix.
*
* SNL (output) REAL
* The sine of the left rotation matrix.
*
* CSR (output) REAL
* The cosine of the right rotation matrix.
*
* SNR (output) REAL
* The sine of the right rotation matrix.
*
* Further Details
* ===============
*
* Based on contributions by
* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
REAL ANORM, ASCALE, BNORM, BSCALE, H1, H2, H3, QQ,
$ R, RR, SAFMIN, SCALE1, SCALE2, T, ULP, WI, WR1,
$ WR2
* ..
* .. External Subroutines ..
EXTERNAL SLAG2, SLARTG, SLASV2, SROT
* ..
* .. External Functions ..
REAL SLAMCH, SLAPY2
EXTERNAL SLAMCH, SLAPY2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
SAFMIN = SLAMCH( 'S' )
ULP = SLAMCH( 'P' )
*
* Scale A
*
ANORM = MAX( ABS( A( 1, 1 ) )+ABS( A( 2, 1 ) ),
$ ABS( A( 1, 2 ) )+ABS( A( 2, 2 ) ), SAFMIN )
ASCALE = ONE / ANORM
A( 1, 1 ) = ASCALE*A( 1, 1 )
A( 1, 2 ) = ASCALE*A( 1, 2 )
A( 2, 1 ) = ASCALE*A( 2, 1 )
A( 2, 2 ) = ASCALE*A( 2, 2 )
*
* Scale B
*
BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 1, 2 ) )+ABS( B( 2, 2 ) ),
$ SAFMIN )
BSCALE = ONE / BNORM
B( 1, 1 ) = BSCALE*B( 1, 1 )
B( 1, 2 ) = BSCALE*B( 1, 2 )
B( 2, 2 ) = BSCALE*B( 2, 2 )
*
* Check if A can be deflated
*
IF( ABS( A( 2, 1 ) ).LE.ULP ) THEN
CSL = ONE
SNL = ZERO
CSR = ONE
SNR = ZERO
A( 2, 1 ) = ZERO
B( 2, 1 ) = ZERO
*
* Check if B is singular
*
ELSE IF( ABS( B( 1, 1 ) ).LE.ULP ) THEN
CALL SLARTG( A( 1, 1 ), A( 2, 1 ), CSL, SNL, R )
CSR = ONE
SNR = ZERO
CALL SROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL )
CALL SROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL )
A( 2, 1 ) = ZERO
B( 1, 1 ) = ZERO
B( 2, 1 ) = ZERO
*
ELSE IF( ABS( B( 2, 2 ) ).LE.ULP ) THEN
CALL SLARTG( A( 2, 2 ), A( 2, 1 ), CSR, SNR, T )
SNR = -SNR
CALL SROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR )
CALL SROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR )
CSL = ONE
SNL = ZERO
A( 2, 1 ) = ZERO
B( 2, 1 ) = ZERO
B( 2, 2 ) = ZERO
*
ELSE
*
* B is nonsingular, first compute the eigenvalues of (A,B)
*
CALL SLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, WR2,
$ WI )
*
IF( WI.EQ.ZERO ) THEN
*
* two real eigenvalues, compute s*A-w*B
*
H1 = SCALE1*A( 1, 1 ) - WR1*B( 1, 1 )
H2 = SCALE1*A( 1, 2 ) - WR1*B( 1, 2 )
H3 = SCALE1*A( 2, 2 ) - WR1*B( 2, 2 )
*
RR = SLAPY2( H1, H2 )
QQ = SLAPY2( SCALE1*A( 2, 1 ), H3 )
*
IF( RR.GT.QQ ) THEN
*
* find right rotation matrix to zero 1,1 element of
* (sA - wB)
*
CALL SLARTG( H2, H1, CSR, SNR, T )
*
ELSE
*
* find right rotation matrix to zero 2,1 element of
* (sA - wB)
*
CALL SLARTG( H3, SCALE1*A( 2, 1 ), CSR, SNR, T )
*
END IF
*
SNR = -SNR
CALL SROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR )
CALL SROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR )
*
* compute inf norms of A and B
*
H1 = MAX( ABS( A( 1, 1 ) )+ABS( A( 1, 2 ) ),
$ ABS( A( 2, 1 ) )+ABS( A( 2, 2 ) ) )
H2 = MAX( ABS( B( 1, 1 ) )+ABS( B( 1, 2 ) ),
$ ABS( B( 2, 1 ) )+ABS( B( 2, 2 ) ) )
*
IF( ( SCALE1*H1 ).GE.ABS( WR1 )*H2 ) THEN
*
* find left rotation matrix Q to zero out B(2,1)
*
CALL SLARTG( B( 1, 1 ), B( 2, 1 ), CSL, SNL, R )
*
ELSE
*
* find left rotation matrix Q to zero out A(2,1)
*
CALL SLARTG( A( 1, 1 ), A( 2, 1 ), CSL, SNL, R )
*
END IF
*
CALL SROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL )
CALL SROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL )
*
A( 2, 1 ) = ZERO
B( 2, 1 ) = ZERO
*
ELSE
*
* a pair of complex conjugate eigenvalues
* first compute the SVD of the matrix B
*
CALL SLASV2( B( 1, 1 ), B( 1, 2 ), B( 2, 2 ), R, T, SNR,
$ CSR, SNL, CSL )
*
* Form (A,B) := Q(A,B)Z' where Q is left rotation matrix and
* Z is right rotation matrix computed from SLASV2
*
CALL SROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL )
CALL SROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL )
CALL SROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR )
CALL SROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR )
*
B( 2, 1 ) = ZERO
B( 1, 2 ) = ZERO
*
END IF
*
END IF
*
* Unscaling
*
A( 1, 1 ) = ANORM*A( 1, 1 )
A( 2, 1 ) = ANORM*A( 2, 1 )
A( 1, 2 ) = ANORM*A( 1, 2 )
A( 2, 2 ) = ANORM*A( 2, 2 )
B( 1, 1 ) = BNORM*B( 1, 1 )
B( 2, 1 ) = BNORM*B( 2, 1 )
B( 1, 2 ) = BNORM*B( 1, 2 )
B( 2, 2 ) = BNORM*B( 2, 2 )
*
IF( WI.EQ.ZERO ) THEN
ALPHAR( 1 ) = A( 1, 1 )
ALPHAR( 2 ) = A( 2, 2 )
ALPHAI( 1 ) = ZERO
ALPHAI( 2 ) = ZERO
BETA( 1 ) = B( 1, 1 )
BETA( 2 ) = B( 2, 2 )
ELSE
ALPHAR( 1 ) = ANORM*WR1 / SCALE1 / BNORM
ALPHAI( 1 ) = ANORM*WI / SCALE1 / BNORM
ALPHAR( 2 ) = ALPHAR( 1 )
ALPHAI( 2 ) = -ALPHAI( 1 )
BETA( 1 ) = ONE
BETA( 2 ) = ONE
END IF
*
RETURN
*
* End of SLAGV2
*
END
SUBROUTINE SLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
$ ILOZ, IHIZ, Z, LDZ, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
REAL H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SLAHQR is an auxiliary routine called by SHSEQR to update the
* eigenvalues and Schur decomposition already computed by SHSEQR, by
* dealing with the Hessenberg submatrix in rows and columns ILO to
* IHI.
*
* Arguments
* =========
*
* WANTT (input) LOGICAL
* = .TRUE. : the full Schur form T is required;
* = .FALSE.: only eigenvalues are required.
*
* WANTZ (input) LOGICAL
* = .TRUE. : the matrix of Schur vectors Z is required;
* = .FALSE.: Schur vectors are not required.
*
* N (input) INTEGER
* The order of the matrix H. N >= 0.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* It is assumed that H is already upper quasi-triangular in
* rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless
* ILO = 1). SLAHQR works primarily with the Hessenberg
* submatrix in rows and columns ILO to IHI, but applies
* transformations to all of H if WANTT is .TRUE..
* 1 <= ILO <= max(1,IHI); IHI <= N.
*
* H (input/output) REAL array, dimension (LDH,N)
* On entry, the upper Hessenberg matrix H.
* On exit, if INFO is zero and if WANTT is .TRUE., H is upper
* quasi-triangular in rows and columns ILO:IHI, with any
* 2-by-2 diagonal blocks in standard form. If INFO is zero
* and WANTT is .FALSE., the contents of H are unspecified on
* exit. The output state of H if INFO is nonzero is given
* below under the description of INFO.
*
* LDH (input) INTEGER
* The leading dimension of the array H. LDH >= max(1,N).
*
* WR (output) REAL array, dimension (N)
* WI (output) REAL array, dimension (N)
* The real and imaginary parts, respectively, of the computed
* eigenvalues ILO to IHI are stored in the corresponding
* elements of WR and WI. If two eigenvalues are computed as a
* complex conjugate pair, they are stored in consecutive
* elements of WR and WI, say the i-th and (i+1)th, with
* WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the
* eigenvalues are stored in the same order as on the diagonal
* of the Schur form returned in H, with WR(i) = H(i,i), and, if
* H(i:i+1,i:i+1) is a 2-by-2 diagonal block,
* WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i).
*
* ILOZ (input) INTEGER
* IHIZ (input) INTEGER
* Specify the rows of Z to which transformations must be
* applied if WANTZ is .TRUE..
* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
*
* Z (input/output) REAL array, dimension (LDZ,N)
* If WANTZ is .TRUE., on entry Z must contain the current
* matrix Z of transformations accumulated by SHSEQR, and on
* exit Z has been updated; transformations are applied only to
* the submatrix Z(ILOZ:IHIZ,ILO:IHI).
* If WANTZ is .FALSE., Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* .GT. 0: If INFO = i, SLAHQR failed to compute all the
* eigenvalues ILO to IHI in a total of 30 iterations
* per eigenvalue; elements i+1:ihi of WR and WI
* contain those eigenvalues which have been
* successfully computed.
*
* If INFO .GT. 0 and WANTT is .FALSE., then on exit,
* the remaining unconverged eigenvalues are the
* eigenvalues of the upper Hessenberg matrix rows
* and columns ILO thorugh INFO of the final, output
* value of H.
*
* If INFO .GT. 0 and WANTT is .TRUE., then on exit
* (*) (initial value of H)*U = U*(final value of H)
* where U is an orthognal matrix. The final
* value of H is upper Hessenberg and triangular in
* rows and columns INFO+1 through IHI.
*
* If INFO .GT. 0 and WANTZ is .TRUE., then on exit
* (final value of Z) = (initial value of Z)*U
* where U is the orthogonal matrix in (*)
* (regardless of the value of WANTT.)
*
* Further Details
* ===============
*
* 02-96 Based on modifications by
* David Day, Sandia National Laboratory, USA
*
* 12-04 Further modifications by
* Ralph Byers, University of Kansas, USA
*
* This is a modified version of SLAHQR from LAPACK version 3.0.
* It is (1) more robust against overflow and underflow and
* (2) adopts the more conservative Ahues & Tisseur stopping
* criterion (LAWN 122, 1997).
*
* =========================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 30 )
REAL ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0, TWO = 2.0e0 )
REAL DAT1, DAT2
PARAMETER ( DAT1 = 3.0e0 / 4.0e0, DAT2 = -0.4375e0 )
* ..
* .. Local Scalars ..
REAL AA, AB, BA, BB, CS, DET, H11, H12, H21, H21S,
$ H22, RT1I, RT1R, RT2I, RT2R, RTDISC, S, SAFMAX,
$ SAFMIN, SMLNUM, SN, SUM, T1, T2, T3, TR, TST,
$ ULP, V2, V3
INTEGER I, I1, I2, ITS, J, K, L, M, NH, NR, NZ
* ..
* .. Local Arrays ..
REAL V( 3 )
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLABAD, SLANV2, SLARFG, SROT
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
IF( ILO.EQ.IHI ) THEN
WR( ILO ) = H( ILO, ILO )
WI( ILO ) = ZERO
RETURN
END IF
*
* ==== clear out the trash ====
DO 10 J = ILO, IHI - 3
H( J+2, J ) = ZERO
H( J+3, J ) = ZERO
10 CONTINUE
IF( ILO.LE.IHI-2 )
$ H( IHI, IHI-2 ) = ZERO
*
NH = IHI - ILO + 1
NZ = IHIZ - ILOZ + 1
*
* Set machine-dependent constants for the stopping criterion.
*
SAFMIN = SLAMCH( 'SAFE MINIMUM' )
SAFMAX = ONE / SAFMIN
CALL SLABAD( SAFMIN, SAFMAX )
ULP = SLAMCH( 'PRECISION' )
SMLNUM = SAFMIN*( REAL( NH ) / ULP )
*
* I1 and I2 are the indices of the first row and last column of H
* to which transformations must be applied. If eigenvalues only are
* being computed, I1 and I2 are set inside the main loop.
*
IF( WANTT ) THEN
I1 = 1
I2 = N
END IF
*
* The main loop begins here. I is the loop index and decreases from
* IHI to ILO in steps of 1 or 2. Each iteration of the loop works
* with the active submatrix in rows and columns L to I.
* Eigenvalues I+1 to IHI have already converged. Either L = ILO or
* H(L,L-1) is negligible so that the matrix splits.
*
I = IHI
20 CONTINUE
L = ILO
IF( I.LT.ILO )
$ GO TO 160
*
* Perform QR iterations on rows and columns ILO to I until a
* submatrix of order 1 or 2 splits off at the bottom because a
* subdiagonal element has become negligible.
*
DO 140 ITS = 0, ITMAX
*
* Look for a single small subdiagonal element.
*
DO 30 K = I, L + 1, -1
IF( ABS( H( K, K-1 ) ).LE.SMLNUM )
$ GO TO 40
TST = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) )
IF( TST.EQ.ZERO ) THEN
IF( K-2.GE.ILO )
$ TST = TST + ABS( H( K-1, K-2 ) )
IF( K+1.LE.IHI )
$ TST = TST + ABS( H( K+1, K ) )
END IF
* ==== The following is a conservative small subdiagonal
* . deflation criterion due to Ahues & Tisseur (LAWN 122,
* . 1997). It has better mathematical foundation and
* . improves accuracy in some cases. ====
IF( ABS( H( K, K-1 ) ).LE.ULP*TST ) THEN
AB = MAX( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) )
BA = MIN( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) )
AA = MAX( ABS( H( K, K ) ),
$ ABS( H( K-1, K-1 )-H( K, K ) ) )
BB = MIN( ABS( H( K, K ) ),
$ ABS( H( K-1, K-1 )-H( K, K ) ) )
S = AA + AB
IF( BA*( AB / S ).LE.MAX( SMLNUM,
$ ULP*( BB*( AA / S ) ) ) )GO TO 40
END IF
30 CONTINUE
40 CONTINUE
L = K
IF( L.GT.ILO ) THEN
*
* H(L,L-1) is negligible
*
H( L, L-1 ) = ZERO
END IF
*
* Exit from loop if a submatrix of order 1 or 2 has split off.
*
IF( L.GE.I-1 )
$ GO TO 150
*
* Now the active submatrix is in rows and columns L to I. If
* eigenvalues only are being computed, only the active submatrix
* need be transformed.
*
IF( .NOT.WANTT ) THEN
I1 = L
I2 = I
END IF
*
IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN
*
* Exceptional shift.
*
H11 = DAT1*S + H( I, I )
H12 = DAT2*S
H21 = S
H22 = H11
ELSE
*
* Prepare to use Francis' double shift
* (i.e. 2nd degree generalized Rayleigh quotient)
*
H11 = H( I-1, I-1 )
H21 = H( I, I-1 )
H12 = H( I-1, I )
H22 = H( I, I )
END IF
S = ABS( H11 ) + ABS( H12 ) + ABS( H21 ) + ABS( H22 )
IF( S.EQ.ZERO ) THEN
RT1R = ZERO
RT1I = ZERO
RT2R = ZERO
RT2I = ZERO
ELSE
H11 = H11 / S
H21 = H21 / S
H12 = H12 / S
H22 = H22 / S
TR = ( H11+H22 ) / TWO
DET = ( H11-TR )*( H22-TR ) - H12*H21
RTDISC = SQRT( ABS( DET ) )
IF( DET.GE.ZERO ) THEN
*
* ==== complex conjugate shifts ====
*
RT1R = TR*S
RT2R = RT1R
RT1I = RTDISC*S
RT2I = -RT1I
ELSE
*
* ==== real shifts (use only one of them) ====
*
RT1R = TR + RTDISC
RT2R = TR - RTDISC
IF( ABS( RT1R-H22 ).LE.ABS( RT2R-H22 ) ) THEN
RT1R = RT1R*S
RT2R = RT1R
ELSE
RT2R = RT2R*S
RT1R = RT2R
END IF
RT1I = ZERO
RT2I = ZERO
END IF
END IF
*
* Look for two consecutive small subdiagonal elements.
*
DO 50 M = I - 2, L, -1
* Determine the effect of starting the double-shift QR
* iteration at row M, and see if this would make H(M,M-1)
* negligible. (The following uses scaling to avoid
* overflows and most underflows.)
*
H21S = H( M+1, M )
S = ABS( H( M, M )-RT2R ) + ABS( RT2I ) + ABS( H21S )
H21S = H( M+1, M ) / S
V( 1 ) = H21S*H( M, M+1 ) + ( H( M, M )-RT1R )*
$ ( ( H( M, M )-RT2R ) / S ) - RT1I*( RT2I / S )
V( 2 ) = H21S*( H( M, M )+H( M+1, M+1 )-RT1R-RT2R )
V( 3 ) = H21S*H( M+2, M+1 )
S = ABS( V( 1 ) ) + ABS( V( 2 ) ) + ABS( V( 3 ) )
V( 1 ) = V( 1 ) / S
V( 2 ) = V( 2 ) / S
V( 3 ) = V( 3 ) / S
IF( M.EQ.L )
$ GO TO 60
IF( ABS( H( M, M-1 ) )*( ABS( V( 2 ) )+ABS( V( 3 ) ) ).LE.
$ ULP*ABS( V( 1 ) )*( ABS( H( M-1, M-1 ) )+ABS( H( M,
$ M ) )+ABS( H( M+1, M+1 ) ) ) )GO TO 60
50 CONTINUE
60 CONTINUE
*
* Double-shift QR step
*
DO 130 K = M, I - 1
*
* The first iteration of this loop determines a reflection G
* from the vector V and applies it from left and right to H,
* thus creating a nonzero bulge below the subdiagonal.
*
* Each subsequent iteration determines a reflection G to
* restore the Hessenberg form in the (K-1)th column, and thus
* chases the bulge one step toward the bottom of the active
* submatrix. NR is the order of G.
*
NR = MIN( 3, I-K+1 )
IF( K.GT.M )
$ CALL SCOPY( NR, H( K, K-1 ), 1, V, 1 )
CALL SLARFG( NR, V( 1 ), V( 2 ), 1, T1 )
IF( K.GT.M ) THEN
H( K, K-1 ) = V( 1 )
H( K+1, K-1 ) = ZERO
IF( K.LT.I-1 )
$ H( K+2, K-1 ) = ZERO
ELSE IF( M.GT.L ) THEN
H( K, K-1 ) = -H( K, K-1 )
END IF
V2 = V( 2 )
T2 = T1*V2
IF( NR.EQ.3 ) THEN
V3 = V( 3 )
T3 = T1*V3
*
* Apply G from the left to transform the rows of the matrix
* in columns K to I2.
*
DO 70 J = K, I2
SUM = H( K, J ) + V2*H( K+1, J ) + V3*H( K+2, J )
H( K, J ) = H( K, J ) - SUM*T1
H( K+1, J ) = H( K+1, J ) - SUM*T2
H( K+2, J ) = H( K+2, J ) - SUM*T3
70 CONTINUE
*
* Apply G from the right to transform the columns of the
* matrix in rows I1 to min(K+3,I).
*
DO 80 J = I1, MIN( K+3, I )
SUM = H( J, K ) + V2*H( J, K+1 ) + V3*H( J, K+2 )
H( J, K ) = H( J, K ) - SUM*T1
H( J, K+1 ) = H( J, K+1 ) - SUM*T2
H( J, K+2 ) = H( J, K+2 ) - SUM*T3
80 CONTINUE
*
IF( WANTZ ) THEN
*
* Accumulate transformations in the matrix Z
*
DO 90 J = ILOZ, IHIZ
SUM = Z( J, K ) + V2*Z( J, K+1 ) + V3*Z( J, K+2 )
Z( J, K ) = Z( J, K ) - SUM*T1
Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2
Z( J, K+2 ) = Z( J, K+2 ) - SUM*T3
90 CONTINUE
END IF
ELSE IF( NR.EQ.2 ) THEN
*
* Apply G from the left to transform the rows of the matrix
* in columns K to I2.
*
DO 100 J = K, I2
SUM = H( K, J ) + V2*H( K+1, J )
H( K, J ) = H( K, J ) - SUM*T1
H( K+1, J ) = H( K+1, J ) - SUM*T2
100 CONTINUE
*
* Apply G from the right to transform the columns of the
* matrix in rows I1 to min(K+3,I).
*
DO 110 J = I1, I
SUM = H( J, K ) + V2*H( J, K+1 )
H( J, K ) = H( J, K ) - SUM*T1
H( J, K+1 ) = H( J, K+1 ) - SUM*T2
110 CONTINUE
*
IF( WANTZ ) THEN
*
* Accumulate transformations in the matrix Z
*
DO 120 J = ILOZ, IHIZ
SUM = Z( J, K ) + V2*Z( J, K+1 )
Z( J, K ) = Z( J, K ) - SUM*T1
Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2
120 CONTINUE
END IF
END IF
130 CONTINUE
*
140 CONTINUE
*
* Failure to converge in remaining number of iterations
*
INFO = I
RETURN
*
150 CONTINUE
*
IF( L.EQ.I ) THEN
*
* H(I,I-1) is negligible: one eigenvalue has converged.
*
WR( I ) = H( I, I )
WI( I ) = ZERO
ELSE IF( L.EQ.I-1 ) THEN
*
* H(I-1,I-2) is negligible: a pair of eigenvalues have converged.
*
* Transform the 2-by-2 submatrix to standard Schur form,
* and compute and store the eigenvalues.
*
CALL SLANV2( H( I-1, I-1 ), H( I-1, I ), H( I, I-1 ),
$ H( I, I ), WR( I-1 ), WI( I-1 ), WR( I ), WI( I ),
$ CS, SN )
*
IF( WANTT ) THEN
*
* Apply the transformation to the rest of H.
*
IF( I2.GT.I )
$ CALL SROT( I2-I, H( I-1, I+1 ), LDH, H( I, I+1 ), LDH,
$ CS, SN )
CALL SROT( I-I1-1, H( I1, I-1 ), 1, H( I1, I ), 1, CS, SN )
END IF
IF( WANTZ ) THEN
*
* Apply the transformation to Z.
*
CALL SROT( NZ, Z( ILOZ, I-1 ), 1, Z( ILOZ, I ), 1, CS, SN )
END IF
END IF
*
* return to start of the main loop with new value of I.
*
I = L - 1
GO TO 20
*
160 CONTINUE
RETURN
*
* End of SLAHQR
*
END
SUBROUTINE SLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER K, LDA, LDT, LDY, N, NB
* ..
* .. Array Arguments ..
REAL A( LDA, * ), T( LDT, NB ), TAU( NB ),
$ Y( LDY, NB )
* ..
*
* Purpose
* =======
*
* SLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1)
* matrix A so that elements below the k-th subdiagonal are zero. The
* reduction is performed by an orthogonal similarity transformation
* Q' * A * Q. The routine returns the matrices V and T which determine
* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.
*
* This is an auxiliary routine called by SGEHRD.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix A.
*
* K (input) INTEGER
* The offset for the reduction. Elements below the k-th
* subdiagonal in the first NB columns are reduced to zero.
* K < N.
*
* NB (input) INTEGER
* The number of columns to be reduced.
*
* A (input/output) REAL array, dimension (LDA,N-K+1)
* On entry, the n-by-(n-k+1) general matrix A.
* On exit, the elements on and above the k-th subdiagonal in
* the first NB columns are overwritten with the corresponding
* elements of the reduced matrix; the elements below the k-th
* subdiagonal, with the array TAU, represent the matrix Q as a
* product of elementary reflectors. The other columns of A are
* unchanged. See Further Details.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* TAU (output) REAL array, dimension (NB)
* The scalar factors of the elementary reflectors. See Further
* Details.
*
* T (output) REAL array, dimension (LDT,NB)
* The upper triangular matrix T.
*
* LDT (input) INTEGER
* The leading dimension of the array T. LDT >= NB.
*
* Y (output) REAL array, dimension (LDY,NB)
* The n-by-nb matrix Y.
*
* LDY (input) INTEGER
* The leading dimension of the array Y. LDY >= N.
*
* Further Details
* ===============
*
* The matrix Q is represented as a product of nb elementary reflectors
*
* Q = H(1) H(2) . . . H(nb).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a real scalar, and v is a real vector with
* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in
* A(i+k+1:n,i), and tau in TAU(i).
*
* The elements of the vectors v together form the (n-k+1)-by-nb matrix
* V which is needed, with T and Y, to apply the transformation to the
* unreduced part of the matrix, using an update of the form:
* A := (I - V*T*V') * (A - Y*V').
*
* The contents of A on exit are illustrated by the following example
* with n = 7, k = 3 and nb = 2:
*
* ( a a a a a )
* ( a a a a a )
* ( a a a a a )
* ( h h a a a )
* ( v1 h a a a )
* ( v1 v2 a a a )
* ( v1 v2 a a a )
*
* where a denotes an element of the original matrix A, h denotes a
* modified element of the upper Hessenberg matrix H, and vi denotes an
* element of the vector defining H(i).
*
* This file is a slight modification of LAPACK-3.0's SLAHRD
* incorporating improvements proposed by Quintana-Orti and Van de
* Gejin. Note that the entries of A(1:K,2:NB) differ from those
* returned by the original LAPACK routine. This function is
* not backward compatible with LAPACK3.0.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0,
$ ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I
REAL EI
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, SGEMM, SGEMV, SLACPY,
$ SLARFG, SSCAL, STRMM, STRMV
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.1 )
$ RETURN
*
DO 10 I = 1, NB
IF( I.GT.1 ) THEN
*
* Update A(K+1:N,I)
*
* Update I-th column of A - Y * V'
*
CALL SGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, Y(K+1,1), LDY,
$ A( K+I-1, 1 ), LDA, ONE, A( K+1, I ), 1 )
*
* Apply I - V * T' * V' to this column (call it b) from the
* left, using the last column of T as workspace
*
* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows)
* ( V2 ) ( b2 )
*
* where V1 is unit lower triangular
*
* w := V1' * b1
*
CALL SCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 )
CALL STRMV( 'Lower', 'Transpose', 'UNIT',
$ I-1, A( K+1, 1 ),
$ LDA, T( 1, NB ), 1 )
*
* w := w + V2'*b2
*
CALL SGEMV( 'Transpose', N-K-I+1, I-1,
$ ONE, A( K+I, 1 ),
$ LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 )
*
* w := T'*w
*
CALL STRMV( 'Upper', 'Transpose', 'NON-UNIT',
$ I-1, T, LDT,
$ T( 1, NB ), 1 )
*
* b2 := b2 - V2*w
*
CALL SGEMV( 'NO TRANSPOSE', N-K-I+1, I-1, -ONE,
$ A( K+I, 1 ),
$ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 )
*
* b1 := b1 - V1*w
*
CALL STRMV( 'Lower', 'NO TRANSPOSE',
$ 'UNIT', I-1,
$ A( K+1, 1 ), LDA, T( 1, NB ), 1 )
CALL SAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 )
*
A( K+I-1, I-1 ) = EI
END IF
*
* Generate the elementary reflector H(I) to annihilate
* A(K+I+1:N,I)
*
CALL SLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1,
$ TAU( I ) )
EI = A( K+I, I )
A( K+I, I ) = ONE
*
* Compute Y(K+1:N,I)
*
CALL SGEMV( 'NO TRANSPOSE', N-K, N-K-I+1,
$ ONE, A( K+1, I+1 ),
$ LDA, A( K+I, I ), 1, ZERO, Y( K+1, I ), 1 )
CALL SGEMV( 'Transpose', N-K-I+1, I-1,
$ ONE, A( K+I, 1 ), LDA,
$ A( K+I, I ), 1, ZERO, T( 1, I ), 1 )
CALL SGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE,
$ Y( K+1, 1 ), LDY,
$ T( 1, I ), 1, ONE, Y( K+1, I ), 1 )
CALL SSCAL( N-K, TAU( I ), Y( K+1, I ), 1 )
*
* Compute T(1:I,I)
*
CALL SSCAL( I-1, -TAU( I ), T( 1, I ), 1 )
CALL STRMV( 'Upper', 'No Transpose', 'NON-UNIT',
$ I-1, T, LDT,
$ T( 1, I ), 1 )
T( I, I ) = TAU( I )
*
10 CONTINUE
A( K+NB, NB ) = EI
*
* Compute Y(1:K,1:NB)
*
CALL SLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY )
CALL STRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE',
$ 'UNIT', K, NB,
$ ONE, A( K+1, 1 ), LDA, Y, LDY )
IF( N.GT.K+NB )
$ CALL SGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K,
$ NB, N-K-NB, ONE,
$ A( 1, 2+NB ), LDA, A( K+1+NB, 1 ), LDA, ONE, Y,
$ LDY )
CALL STRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE',
$ 'NON-UNIT', K, NB,
$ ONE, T, LDT, Y, LDY )
*
RETURN
*
* End of SLAHR2
*
END
SUBROUTINE SLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER K, LDA, LDT, LDY, N, NB
* ..
* .. Array Arguments ..
REAL A( LDA, * ), T( LDT, NB ), TAU( NB ),
$ Y( LDY, NB )
* ..
*
* Purpose
* =======
*
* SLAHRD reduces the first NB columns of a real general n-by-(n-k+1)
* matrix A so that elements below the k-th subdiagonal are zero. The
* reduction is performed by an orthogonal similarity transformation
* Q' * A * Q. The routine returns the matrices V and T which determine
* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.
*
* This is an OBSOLETE auxiliary routine.
* This routine will be 'deprecated' in a future release.
* Please use the new routine SLAHR2 instead.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix A.
*
* K (input) INTEGER
* The offset for the reduction. Elements below the k-th
* subdiagonal in the first NB columns are reduced to zero.
*
* NB (input) INTEGER
* The number of columns to be reduced.
*
* A (input/output) REAL array, dimension (LDA,N-K+1)
* On entry, the n-by-(n-k+1) general matrix A.
* On exit, the elements on and above the k-th subdiagonal in
* the first NB columns are overwritten with the corresponding
* elements of the reduced matrix; the elements below the k-th
* subdiagonal, with the array TAU, represent the matrix Q as a
* product of elementary reflectors. The other columns of A are
* unchanged. See Further Details.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* TAU (output) REAL array, dimension (NB)
* The scalar factors of the elementary reflectors. See Further
* Details.
*
* T (output) REAL array, dimension (LDT,NB)
* The upper triangular matrix T.
*
* LDT (input) INTEGER
* The leading dimension of the array T. LDT >= NB.
*
* Y (output) REAL array, dimension (LDY,NB)
* The n-by-nb matrix Y.
*
* LDY (input) INTEGER
* The leading dimension of the array Y. LDY >= N.
*
* Further Details
* ===============
*
* The matrix Q is represented as a product of nb elementary reflectors
*
* Q = H(1) H(2) . . . H(nb).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a real scalar, and v is a real vector with
* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in
* A(i+k+1:n,i), and tau in TAU(i).
*
* The elements of the vectors v together form the (n-k+1)-by-nb matrix
* V which is needed, with T and Y, to apply the transformation to the
* unreduced part of the matrix, using an update of the form:
* A := (I - V*T*V') * (A - Y*V').
*
* The contents of A on exit are illustrated by the following example
* with n = 7, k = 3 and nb = 2:
*
* ( a h a a a )
* ( a h a a a )
* ( a h a a a )
* ( h h a a a )
* ( v1 h a a a )
* ( v1 v2 a a a )
* ( v1 v2 a a a )
*
* where a denotes an element of the original matrix A, h denotes a
* modified element of the upper Hessenberg matrix H, and vi denotes an
* element of the vector defining H(i).
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I
REAL EI
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, SGEMV, SLARFG, SSCAL, STRMV
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.1 )
$ RETURN
*
DO 10 I = 1, NB
IF( I.GT.1 ) THEN
*
* Update A(1:n,i)
*
* Compute i-th column of A - Y * V'
*
CALL SGEMV( 'No transpose', N, I-1, -ONE, Y, LDY,
$ A( K+I-1, 1 ), LDA, ONE, A( 1, I ), 1 )
*
* Apply I - V * T' * V' to this column (call it b) from the
* left, using the last column of T as workspace
*
* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows)
* ( V2 ) ( b2 )
*
* where V1 is unit lower triangular
*
* w := V1' * b1
*
CALL SCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 )
CALL STRMV( 'Lower', 'Transpose', 'Unit', I-1, A( K+1, 1 ),
$ LDA, T( 1, NB ), 1 )
*
* w := w + V2'*b2
*
CALL SGEMV( 'Transpose', N-K-I+1, I-1, ONE, A( K+I, 1 ),
$ LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 )
*
* w := T'*w
*
CALL STRMV( 'Upper', 'Transpose', 'Non-unit', I-1, T, LDT,
$ T( 1, NB ), 1 )
*
* b2 := b2 - V2*w
*
CALL SGEMV( 'No transpose', N-K-I+1, I-1, -ONE, A( K+I, 1 ),
$ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 )
*
* b1 := b1 - V1*w
*
CALL STRMV( 'Lower', 'No transpose', 'Unit', I-1,
$ A( K+1, 1 ), LDA, T( 1, NB ), 1 )
CALL SAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 )
*
A( K+I-1, I-1 ) = EI
END IF
*
* Generate the elementary reflector H(i) to annihilate
* A(k+i+1:n,i)
*
CALL SLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1,
$ TAU( I ) )
EI = A( K+I, I )
A( K+I, I ) = ONE
*
* Compute Y(1:n,i)
*
CALL SGEMV( 'No transpose', N, N-K-I+1, ONE, A( 1, I+1 ), LDA,
$ A( K+I, I ), 1, ZERO, Y( 1, I ), 1 )
CALL SGEMV( 'Transpose', N-K-I+1, I-1, ONE, A( K+I, 1 ), LDA,
$ A( K+I, I ), 1, ZERO, T( 1, I ), 1 )
CALL SGEMV( 'No transpose', N, I-1, -ONE, Y, LDY, T( 1, I ), 1,
$ ONE, Y( 1, I ), 1 )
CALL SSCAL( N, TAU( I ), Y( 1, I ), 1 )
*
* Compute T(1:i,i)
*
CALL SSCAL( I-1, -TAU( I ), T( 1, I ), 1 )
CALL STRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, LDT,
$ T( 1, I ), 1 )
T( I, I ) = TAU( I )
*
10 CONTINUE
A( K+NB, NB ) = EI
*
RETURN
*
* End of SLAHRD
*
END
SUBROUTINE SLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER J, JOB
REAL C, GAMMA, S, SEST, SESTPR
* ..
* .. Array Arguments ..
REAL W( J ), X( J )
* ..
*
* Purpose
* =======
*
* SLAIC1 applies one step of incremental condition estimation in
* its simplest version:
*
* Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j
* lower triangular matrix L, such that
* twonorm(L*x) = sest
* Then SLAIC1 computes sestpr, s, c such that
* the vector
* [ s*x ]
* xhat = [ c ]
* is an approximate singular vector of
* [ L 0 ]
* Lhat = [ w' gamma ]
* in the sense that
* twonorm(Lhat*xhat) = sestpr.
*
* Depending on JOB, an estimate for the largest or smallest singular
* value is computed.
*
* Note that [s c]' and sestpr**2 is an eigenpair of the system
*
* diag(sest*sest, 0) + [alpha gamma] * [ alpha ]
* [ gamma ]
*
* where alpha = x'*w.
*
* Arguments
* =========
*
* JOB (input) INTEGER
* = 1: an estimate for the largest singular value is computed.
* = 2: an estimate for the smallest singular value is computed.
*
* J (input) INTEGER
* Length of X and W
*
* X (input) REAL array, dimension (J)
* The j-vector x.
*
* SEST (input) REAL
* Estimated singular value of j by j matrix L
*
* W (input) REAL array, dimension (J)
* The j-vector w.
*
* GAMMA (input) REAL
* The diagonal element gamma.
*
* SESTPR (output) REAL
* Estimated singular value of (j+1) by (j+1) matrix Lhat.
*
* S (output) REAL
* Sine needed in forming xhat.
*
* C (output) REAL
* Cosine needed in forming xhat.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 )
REAL HALF, FOUR
PARAMETER ( HALF = 0.5E0, FOUR = 4.0E0 )
* ..
* .. Local Scalars ..
REAL ABSALP, ABSEST, ABSGAM, ALPHA, B, COSINE, EPS,
$ NORMA, S1, S2, SINE, T, TEST, TMP, ZETA1, ZETA2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SIGN, SQRT
* ..
* .. External Functions ..
REAL SDOT, SLAMCH
EXTERNAL SDOT, SLAMCH
* ..
* .. Executable Statements ..
*
EPS = SLAMCH( 'Epsilon' )
ALPHA = SDOT( J, X, 1, W, 1 )
*
ABSALP = ABS( ALPHA )
ABSGAM = ABS( GAMMA )
ABSEST = ABS( SEST )
*
IF( JOB.EQ.1 ) THEN
*
* Estimating largest singular value
*
* special cases
*
IF( SEST.EQ.ZERO ) THEN
S1 = MAX( ABSGAM, ABSALP )
IF( S1.EQ.ZERO ) THEN
S = ZERO
C = ONE
SESTPR = ZERO
ELSE
S = ALPHA / S1
C = GAMMA / S1
TMP = SQRT( S*S+C*C )
S = S / TMP
C = C / TMP
SESTPR = S1*TMP
END IF
RETURN
ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN
S = ONE
C = ZERO
TMP = MAX( ABSEST, ABSALP )
S1 = ABSEST / TMP
S2 = ABSALP / TMP
SESTPR = TMP*SQRT( S1*S1+S2*S2 )
RETURN
ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN
S1 = ABSGAM
S2 = ABSEST
IF( S1.LE.S2 ) THEN
S = ONE
C = ZERO
SESTPR = S2
ELSE
S = ZERO
C = ONE
SESTPR = S1
END IF
RETURN
ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN
S1 = ABSGAM
S2 = ABSALP
IF( S1.LE.S2 ) THEN
TMP = S1 / S2
S = SQRT( ONE+TMP*TMP )
SESTPR = S2*S
C = ( GAMMA / S2 ) / S
S = SIGN( ONE, ALPHA ) / S
ELSE
TMP = S2 / S1
C = SQRT( ONE+TMP*TMP )
SESTPR = S1*C
S = ( ALPHA / S1 ) / C
C = SIGN( ONE, GAMMA ) / C
END IF
RETURN
ELSE
*
* normal case
*
ZETA1 = ALPHA / ABSEST
ZETA2 = GAMMA / ABSEST
*
B = ( ONE-ZETA1*ZETA1-ZETA2*ZETA2 )*HALF
C = ZETA1*ZETA1
IF( B.GT.ZERO ) THEN
T = C / ( B+SQRT( B*B+C ) )
ELSE
T = SQRT( B*B+C ) - B
END IF
*
SINE = -ZETA1 / T
COSINE = -ZETA2 / ( ONE+T )
TMP = SQRT( SINE*SINE+COSINE*COSINE )
S = SINE / TMP
C = COSINE / TMP
SESTPR = SQRT( T+ONE )*ABSEST
RETURN
END IF
*
ELSE IF( JOB.EQ.2 ) THEN
*
* Estimating smallest singular value
*
* special cases
*
IF( SEST.EQ.ZERO ) THEN
SESTPR = ZERO
IF( MAX( ABSGAM, ABSALP ).EQ.ZERO ) THEN
SINE = ONE
COSINE = ZERO
ELSE
SINE = -GAMMA
COSINE = ALPHA
END IF
S1 = MAX( ABS( SINE ), ABS( COSINE ) )
S = SINE / S1
C = COSINE / S1
TMP = SQRT( S*S+C*C )
S = S / TMP
C = C / TMP
RETURN
ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN
S = ZERO
C = ONE
SESTPR = ABSGAM
RETURN
ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN
S1 = ABSGAM
S2 = ABSEST
IF( S1.LE.S2 ) THEN
S = ZERO
C = ONE
SESTPR = S1
ELSE
S = ONE
C = ZERO
SESTPR = S2
END IF
RETURN
ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN
S1 = ABSGAM
S2 = ABSALP
IF( S1.LE.S2 ) THEN
TMP = S1 / S2
C = SQRT( ONE+TMP*TMP )
SESTPR = ABSEST*( TMP / C )
S = -( GAMMA / S2 ) / C
C = SIGN( ONE, ALPHA ) / C
ELSE
TMP = S2 / S1
S = SQRT( ONE+TMP*TMP )
SESTPR = ABSEST / S
C = ( ALPHA / S1 ) / S
S = -SIGN( ONE, GAMMA ) / S
END IF
RETURN
ELSE
*
* normal case
*
ZETA1 = ALPHA / ABSEST
ZETA2 = GAMMA / ABSEST
*
NORMA = MAX( ONE+ZETA1*ZETA1+ABS( ZETA1*ZETA2 ),
$ ABS( ZETA1*ZETA2 )+ZETA2*ZETA2 )
*
* See if root is closer to zero or to ONE
*
TEST = ONE + TWO*( ZETA1-ZETA2 )*( ZETA1+ZETA2 )
IF( TEST.GE.ZERO ) THEN
*
* root is close to zero, compute directly
*
B = ( ZETA1*ZETA1+ZETA2*ZETA2+ONE )*HALF
C = ZETA2*ZETA2
T = C / ( B+SQRT( ABS( B*B-C ) ) )
SINE = ZETA1 / ( ONE-T )
COSINE = -ZETA2 / T
SESTPR = SQRT( T+FOUR*EPS*EPS*NORMA )*ABSEST
ELSE
*
* root is closer to ONE, shift by that amount
*
B = ( ZETA2*ZETA2+ZETA1*ZETA1-ONE )*HALF
C = ZETA1*ZETA1
IF( B.GE.ZERO ) THEN
T = -C / ( B+SQRT( B*B+C ) )
ELSE
T = B - SQRT( B*B+C )
END IF
SINE = -ZETA1 / T
COSINE = -ZETA2 / ( ONE+T )
SESTPR = SQRT( ONE+T+FOUR*EPS*EPS*NORMA )*ABSEST
END IF
TMP = SQRT( SINE*SINE+COSINE*COSINE )
S = SINE / TMP
C = COSINE / TMP
RETURN
*
END IF
END IF
RETURN
*
* End of SLAIC1
*
END
LOGICAL FUNCTION SLAISNAN(SIN1,SIN2)
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
REAL SIN1,SIN2
* ..
*
* Purpose
* =======
*
* This routine is not for general use. It exists solely to avoid
* over-optimization in SISNAN.
*
* SLAISNAN checks for NaNs by comparing its two arguments for
* inequality. NaN is the only floating-point value where NaN != NaN
* returns .TRUE. To check for NaNs, pass the same variable as both
* arguments.
*
* Strictly speaking, Fortran does not allow aliasing of function
* arguments. So a compiler must assume that the two arguments are
* not the same variable, and the test will not be optimized away.
* Interprocedural or whole-program optimization may delete this
* test. The ISNAN functions will be replaced by the correct
* Fortran 03 intrinsic once the intrinsic is widely available.
*
* Arguments
* =========
*
* SIN1 (input) REAL
* SIN2 (input) REAL
* Two numbers to compare for inequality.
*
* =====================================================================
*
* .. Executable Statements ..
SLAISNAN = (SIN1.NE.SIN2)
RETURN
END
SUBROUTINE SLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B,
$ LDB, WR, WI, X, LDX, SCALE, XNORM, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL LTRANS
INTEGER INFO, LDA, LDB, LDX, NA, NW
REAL CA, D1, D2, SCALE, SMIN, WI, WR, XNORM
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* SLALN2 solves a system of the form (ca A - w D ) X = s B
* or (ca A' - w D) X = s B with possible scaling ("s") and
* perturbation of A. (A' means A-transpose.)
*
* A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA
* real diagonal matrix, w is a real or complex value, and X and B are
* NA x 1 matrices -- real if w is real, complex if w is complex. NA
* may be 1 or 2.
*
* If w is complex, X and B are represented as NA x 2 matrices,
* the first column of each being the real part and the second
* being the imaginary part.
*
* "s" is a scaling factor (.LE. 1), computed by SLALN2, which is
* so chosen that X can be computed without overflow. X is further
* scaled if necessary to assure that norm(ca A - w D)*norm(X) is less
* than overflow.
*
* If both singular values of (ca A - w D) are less than SMIN,
* SMIN*identity will be used instead of (ca A - w D). If only one
* singular value is less than SMIN, one element of (ca A - w D) will be
* perturbed enough to make the smallest singular value roughly SMIN.
* If both singular values are at least SMIN, (ca A - w D) will not be
* perturbed. In any case, the perturbation will be at most some small
* multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values
* are computed by infinity-norm approximations, and thus will only be
* correct to a factor of 2 or so.
*
* Note: all input quantities are assumed to be smaller than overflow
* by a reasonable factor. (See BIGNUM.)
*
* Arguments
* ==========
*
* LTRANS (input) LOGICAL
* =.TRUE.: A-transpose will be used.
* =.FALSE.: A will be used (not transposed.)
*
* NA (input) INTEGER
* The size of the matrix A. It may (only) be 1 or 2.
*
* NW (input) INTEGER
* 1 if "w" is real, 2 if "w" is complex. It may only be 1
* or 2.
*
* SMIN (input) REAL
* The desired lower bound on the singular values of A. This
* should be a safe distance away from underflow or overflow,
* say, between (underflow/machine precision) and (machine
* precision * overflow ). (See BIGNUM and ULP.)
*
* CA (input) REAL
* The coefficient c, which A is multiplied by.
*
* A (input) REAL array, dimension (LDA,NA)
* The NA x NA matrix A.
*
* LDA (input) INTEGER
* The leading dimension of A. It must be at least NA.
*
* D1 (input) REAL
* The 1,1 element in the diagonal matrix D.
*
* D2 (input) REAL
* The 2,2 element in the diagonal matrix D. Not used if NW=1.
*
* B (input) REAL array, dimension (LDB,NW)
* The NA x NW matrix B (right-hand side). If NW=2 ("w" is
* complex), column 1 contains the real part of B and column 2
* contains the imaginary part.
*
* LDB (input) INTEGER
* The leading dimension of B. It must be at least NA.
*
* WR (input) REAL
* The real part of the scalar "w".
*
* WI (input) REAL
* The imaginary part of the scalar "w". Not used if NW=1.
*
* X (output) REAL array, dimension (LDX,NW)
* The NA x NW matrix X (unknowns), as computed by SLALN2.
* If NW=2 ("w" is complex), on exit, column 1 will contain
* the real part of X and column 2 will contain the imaginary
* part.
*
* LDX (input) INTEGER
* The leading dimension of X. It must be at least NA.
*
* SCALE (output) REAL
* The scale factor that B must be multiplied by to insure
* that overflow does not occur when computing X. Thus,
* (ca A - w D) X will be SCALE*B, not B (ignoring
* perturbations of A.) It will be at most 1.
*
* XNORM (output) REAL
* The infinity-norm of X, when X is regarded as an NA x NW
* real matrix.
*
* INFO (output) INTEGER
* An error flag. It will be set to zero if no error occurs,
* a negative number if an argument is in error, or a positive
* number if ca A - w D had to be perturbed.
* The possible values are:
* = 0: No error occurred, and (ca A - w D) did not have to be
* perturbed.
* = 1: (ca A - w D) had to be perturbed to make its smallest
* (or only) singular value greater than SMIN.
* NOTE: In the interests of speed, this routine does not
* check the inputs for errors.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
REAL TWO
PARAMETER ( TWO = 2.0E0 )
* ..
* .. Local Scalars ..
INTEGER ICMAX, J
REAL BBND, BI1, BI2, BIGNUM, BNORM, BR1, BR2, CI21,
$ CI22, CMAX, CNORM, CR21, CR22, CSI, CSR, LI21,
$ LR21, SMINI, SMLNUM, TEMP, U22ABS, UI11, UI11R,
$ UI12, UI12S, UI22, UR11, UR11R, UR12, UR12S,
$ UR22, XI1, XI2, XR1, XR2
* ..
* .. Local Arrays ..
LOGICAL CSWAP( 4 ), RSWAP( 4 )
INTEGER IPIVOT( 4, 4 )
REAL CI( 2, 2 ), CIV( 4 ), CR( 2, 2 ), CRV( 4 )
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SLADIV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Equivalences ..
EQUIVALENCE ( CI( 1, 1 ), CIV( 1 ) ),
$ ( CR( 1, 1 ), CRV( 1 ) )
* ..
* .. Data statements ..
DATA CSWAP / .FALSE., .FALSE., .TRUE., .TRUE. /
DATA RSWAP / .FALSE., .TRUE., .FALSE., .TRUE. /
DATA IPIVOT / 1, 2, 3, 4, 2, 1, 4, 3, 3, 4, 1, 2, 4,
$ 3, 2, 1 /
* ..
* .. Executable Statements ..
*
* Compute BIGNUM
*
SMLNUM = TWO*SLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
SMINI = MAX( SMIN, SMLNUM )
*
* Don't check for input errors
*
INFO = 0
*
* Standard Initializations
*
SCALE = ONE
*
IF( NA.EQ.1 ) THEN
*
* 1 x 1 (i.e., scalar) system C X = B
*
IF( NW.EQ.1 ) THEN
*
* Real 1x1 system.
*
* C = ca A - w D
*
CSR = CA*A( 1, 1 ) - WR*D1
CNORM = ABS( CSR )
*
* If | C | < SMINI, use C = SMINI
*
IF( CNORM.LT.SMINI ) THEN
CSR = SMINI
CNORM = SMINI
INFO = 1
END IF
*
* Check scaling for X = B / C
*
BNORM = ABS( B( 1, 1 ) )
IF( CNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN
IF( BNORM.GT.BIGNUM*CNORM )
$ SCALE = ONE / BNORM
END IF
*
* Compute X
*
X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / CSR
XNORM = ABS( X( 1, 1 ) )
ELSE
*
* Complex 1x1 system (w is complex)
*
* C = ca A - w D
*
CSR = CA*A( 1, 1 ) - WR*D1
CSI = -WI*D1
CNORM = ABS( CSR ) + ABS( CSI )
*
* If | C | < SMINI, use C = SMINI
*
IF( CNORM.LT.SMINI ) THEN
CSR = SMINI
CSI = ZERO
CNORM = SMINI
INFO = 1
END IF
*
* Check scaling for X = B / C
*
BNORM = ABS( B( 1, 1 ) ) + ABS( B( 1, 2 ) )
IF( CNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN
IF( BNORM.GT.BIGNUM*CNORM )
$ SCALE = ONE / BNORM
END IF
*
* Compute X
*
CALL SLADIV( SCALE*B( 1, 1 ), SCALE*B( 1, 2 ), CSR, CSI,
$ X( 1, 1 ), X( 1, 2 ) )
XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) )
END IF
*
ELSE
*
* 2x2 System
*
* Compute the real part of C = ca A - w D (or ca A' - w D )
*
CR( 1, 1 ) = CA*A( 1, 1 ) - WR*D1
CR( 2, 2 ) = CA*A( 2, 2 ) - WR*D2
IF( LTRANS ) THEN
CR( 1, 2 ) = CA*A( 2, 1 )
CR( 2, 1 ) = CA*A( 1, 2 )
ELSE
CR( 2, 1 ) = CA*A( 2, 1 )
CR( 1, 2 ) = CA*A( 1, 2 )
END IF
*
IF( NW.EQ.1 ) THEN
*
* Real 2x2 system (w is real)
*
* Find the largest element in C
*
CMAX = ZERO
ICMAX = 0
*
DO 10 J = 1, 4
IF( ABS( CRV( J ) ).GT.CMAX ) THEN
CMAX = ABS( CRV( J ) )
ICMAX = J
END IF
10 CONTINUE
*
* If norm(C) < SMINI, use SMINI*identity.
*
IF( CMAX.LT.SMINI ) THEN
BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 2, 1 ) ) )
IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN
IF( BNORM.GT.BIGNUM*SMINI )
$ SCALE = ONE / BNORM
END IF
TEMP = SCALE / SMINI
X( 1, 1 ) = TEMP*B( 1, 1 )
X( 2, 1 ) = TEMP*B( 2, 1 )
XNORM = TEMP*BNORM
INFO = 1
RETURN
END IF
*
* Gaussian elimination with complete pivoting.
*
UR11 = CRV( ICMAX )
CR21 = CRV( IPIVOT( 2, ICMAX ) )
UR12 = CRV( IPIVOT( 3, ICMAX ) )
CR22 = CRV( IPIVOT( 4, ICMAX ) )
UR11R = ONE / UR11
LR21 = UR11R*CR21
UR22 = CR22 - UR12*LR21
*
* If smaller pivot < SMINI, use SMINI
*
IF( ABS( UR22 ).LT.SMINI ) THEN
UR22 = SMINI
INFO = 1
END IF
IF( RSWAP( ICMAX ) ) THEN
BR1 = B( 2, 1 )
BR2 = B( 1, 1 )
ELSE
BR1 = B( 1, 1 )
BR2 = B( 2, 1 )
END IF
BR2 = BR2 - LR21*BR1
BBND = MAX( ABS( BR1*( UR22*UR11R ) ), ABS( BR2 ) )
IF( BBND.GT.ONE .AND. ABS( UR22 ).LT.ONE ) THEN
IF( BBND.GE.BIGNUM*ABS( UR22 ) )
$ SCALE = ONE / BBND
END IF
*
XR2 = ( BR2*SCALE ) / UR22
XR1 = ( SCALE*BR1 )*UR11R - XR2*( UR11R*UR12 )
IF( CSWAP( ICMAX ) ) THEN
X( 1, 1 ) = XR2
X( 2, 1 ) = XR1
ELSE
X( 1, 1 ) = XR1
X( 2, 1 ) = XR2
END IF
XNORM = MAX( ABS( XR1 ), ABS( XR2 ) )
*
* Further scaling if norm(A) norm(X) > overflow
*
IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN
IF( XNORM.GT.BIGNUM / CMAX ) THEN
TEMP = CMAX / BIGNUM
X( 1, 1 ) = TEMP*X( 1, 1 )
X( 2, 1 ) = TEMP*X( 2, 1 )
XNORM = TEMP*XNORM
SCALE = TEMP*SCALE
END IF
END IF
ELSE
*
* Complex 2x2 system (w is complex)
*
* Find the largest element in C
*
CI( 1, 1 ) = -WI*D1
CI( 2, 1 ) = ZERO
CI( 1, 2 ) = ZERO
CI( 2, 2 ) = -WI*D2
CMAX = ZERO
ICMAX = 0
*
DO 20 J = 1, 4
IF( ABS( CRV( J ) )+ABS( CIV( J ) ).GT.CMAX ) THEN
CMAX = ABS( CRV( J ) ) + ABS( CIV( J ) )
ICMAX = J
END IF
20 CONTINUE
*
* If norm(C) < SMINI, use SMINI*identity.
*
IF( CMAX.LT.SMINI ) THEN
BNORM = MAX( ABS( B( 1, 1 ) )+ABS( B( 1, 2 ) ),
$ ABS( B( 2, 1 ) )+ABS( B( 2, 2 ) ) )
IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN
IF( BNORM.GT.BIGNUM*SMINI )
$ SCALE = ONE / BNORM
END IF
TEMP = SCALE / SMINI
X( 1, 1 ) = TEMP*B( 1, 1 )
X( 2, 1 ) = TEMP*B( 2, 1 )
X( 1, 2 ) = TEMP*B( 1, 2 )
X( 2, 2 ) = TEMP*B( 2, 2 )
XNORM = TEMP*BNORM
INFO = 1
RETURN
END IF
*
* Gaussian elimination with complete pivoting.
*
UR11 = CRV( ICMAX )
UI11 = CIV( ICMAX )
CR21 = CRV( IPIVOT( 2, ICMAX ) )
CI21 = CIV( IPIVOT( 2, ICMAX ) )
UR12 = CRV( IPIVOT( 3, ICMAX ) )
UI12 = CIV( IPIVOT( 3, ICMAX ) )
CR22 = CRV( IPIVOT( 4, ICMAX ) )
CI22 = CIV( IPIVOT( 4, ICMAX ) )
IF( ICMAX.EQ.1 .OR. ICMAX.EQ.4 ) THEN
*
* Code when off-diagonals of pivoted C are real
*
IF( ABS( UR11 ).GT.ABS( UI11 ) ) THEN
TEMP = UI11 / UR11
UR11R = ONE / ( UR11*( ONE+TEMP**2 ) )
UI11R = -TEMP*UR11R
ELSE
TEMP = UR11 / UI11
UI11R = -ONE / ( UI11*( ONE+TEMP**2 ) )
UR11R = -TEMP*UI11R
END IF
LR21 = CR21*UR11R
LI21 = CR21*UI11R
UR12S = UR12*UR11R
UI12S = UR12*UI11R
UR22 = CR22 - UR12*LR21
UI22 = CI22 - UR12*LI21
ELSE
*
* Code when diagonals of pivoted C are real
*
UR11R = ONE / UR11
UI11R = ZERO
LR21 = CR21*UR11R
LI21 = CI21*UR11R
UR12S = UR12*UR11R
UI12S = UI12*UR11R
UR22 = CR22 - UR12*LR21 + UI12*LI21
UI22 = -UR12*LI21 - UI12*LR21
END IF
U22ABS = ABS( UR22 ) + ABS( UI22 )
*
* If smaller pivot < SMINI, use SMINI
*
IF( U22ABS.LT.SMINI ) THEN
UR22 = SMINI
UI22 = ZERO
INFO = 1
END IF
IF( RSWAP( ICMAX ) ) THEN
BR2 = B( 1, 1 )
BR1 = B( 2, 1 )
BI2 = B( 1, 2 )
BI1 = B( 2, 2 )
ELSE
BR1 = B( 1, 1 )
BR2 = B( 2, 1 )
BI1 = B( 1, 2 )
BI2 = B( 2, 2 )
END IF
BR2 = BR2 - LR21*BR1 + LI21*BI1
BI2 = BI2 - LI21*BR1 - LR21*BI1
BBND = MAX( ( ABS( BR1 )+ABS( BI1 ) )*
$ ( U22ABS*( ABS( UR11R )+ABS( UI11R ) ) ),
$ ABS( BR2 )+ABS( BI2 ) )
IF( BBND.GT.ONE .AND. U22ABS.LT.ONE ) THEN
IF( BBND.GE.BIGNUM*U22ABS ) THEN
SCALE = ONE / BBND
BR1 = SCALE*BR1
BI1 = SCALE*BI1
BR2 = SCALE*BR2
BI2 = SCALE*BI2
END IF
END IF
*
CALL SLADIV( BR2, BI2, UR22, UI22, XR2, XI2 )
XR1 = UR11R*BR1 - UI11R*BI1 - UR12S*XR2 + UI12S*XI2
XI1 = UI11R*BR1 + UR11R*BI1 - UI12S*XR2 - UR12S*XI2
IF( CSWAP( ICMAX ) ) THEN
X( 1, 1 ) = XR2
X( 2, 1 ) = XR1
X( 1, 2 ) = XI2
X( 2, 2 ) = XI1
ELSE
X( 1, 1 ) = XR1
X( 2, 1 ) = XR2
X( 1, 2 ) = XI1
X( 2, 2 ) = XI2
END IF
XNORM = MAX( ABS( XR1 )+ABS( XI1 ), ABS( XR2 )+ABS( XI2 ) )
*
* Further scaling if norm(A) norm(X) > overflow
*
IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN
IF( XNORM.GT.BIGNUM / CMAX ) THEN
TEMP = CMAX / BIGNUM
X( 1, 1 ) = TEMP*X( 1, 1 )
X( 2, 1 ) = TEMP*X( 2, 1 )
X( 1, 2 ) = TEMP*X( 1, 2 )
X( 2, 2 ) = TEMP*X( 2, 2 )
XNORM = TEMP*XNORM
SCALE = TEMP*SCALE
END IF
END IF
END IF
END IF
*
RETURN
*
* End of SLALN2
*
END
SUBROUTINE SLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX,
$ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM,
$ POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL,
$ LDGNUM, NL, NR, NRHS, SQRE
REAL C, S
* ..
* .. Array Arguments ..
INTEGER GIVCOL( LDGCOL, * ), PERM( * )
REAL B( LDB, * ), BX( LDBX, * ), DIFL( * ),
$ DIFR( LDGNUM, * ), GIVNUM( LDGNUM, * ),
$ POLES( LDGNUM, * ), WORK( * ), Z( * )
* ..
*
* Purpose
* =======
*
* SLALS0 applies back the multiplying factors of either the left or the
* right singular vector matrix of a diagonal matrix appended by a row
* to the right hand side matrix B in solving the least squares problem
* using the divide-and-conquer SVD approach.
*
* For the left singular vector matrix, three types of orthogonal
* matrices are involved:
*
* (1L) Givens rotations: the number of such rotations is GIVPTR; the
* pairs of columns/rows they were applied to are stored in GIVCOL;
* and the C- and S-values of these rotations are stored in GIVNUM.
*
* (2L) Permutation. The (NL+1)-st row of B is to be moved to the first
* row, and for J=2:N, PERM(J)-th row of B is to be moved to the
* J-th row.
*
* (3L) The left singular vector matrix of the remaining matrix.
*
* For the right singular vector matrix, four types of orthogonal
* matrices are involved:
*
* (1R) The right singular vector matrix of the remaining matrix.
*
* (2R) If SQRE = 1, one extra Givens rotation to generate the right
* null space.
*
* (3R) The inverse transformation of (2L).
*
* (4R) The inverse transformation of (1L).
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* Specifies whether singular vectors are to be computed in
* factored form:
* = 0: Left singular vector matrix.
* = 1: Right singular vector matrix.
*
* NL (input) INTEGER
* The row dimension of the upper block. NL >= 1.
*
* NR (input) INTEGER
* The row dimension of the lower block. NR >= 1.
*
* SQRE (input) INTEGER
* = 0: the lower block is an NR-by-NR square matrix.
* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
*
* The bidiagonal matrix has row dimension N = NL + NR + 1,
* and column dimension M = N + SQRE.
*
* NRHS (input) INTEGER
* The number of columns of B and BX. NRHS must be at least 1.
*
* B (input/output) REAL array, dimension ( LDB, NRHS )
* On input, B contains the right hand sides of the least
* squares problem in rows 1 through M. On output, B contains
* the solution X in rows 1 through N.
*
* LDB (input) INTEGER
* The leading dimension of B. LDB must be at least
* max(1,MAX( M, N ) ).
*
* BX (workspace) REAL array, dimension ( LDBX, NRHS )
*
* LDBX (input) INTEGER
* The leading dimension of BX.
*
* PERM (input) INTEGER array, dimension ( N )
* The permutations (from deflation and sorting) applied
* to the two blocks.
*
* GIVPTR (input) INTEGER
* The number of Givens rotations which took place in this
* subproblem.
*
* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )
* Each pair of numbers indicates a pair of rows/columns
* involved in a Givens rotation.
*
* LDGCOL (input) INTEGER
* The leading dimension of GIVCOL, must be at least N.
*
* GIVNUM (input) REAL array, dimension ( LDGNUM, 2 )
* Each number indicates the C or S value used in the
* corresponding Givens rotation.
*
* LDGNUM (input) INTEGER
* The leading dimension of arrays DIFR, POLES and
* GIVNUM, must be at least K.
*
* POLES (input) REAL array, dimension ( LDGNUM, 2 )
* On entry, POLES(1:K, 1) contains the new singular
* values obtained from solving the secular equation, and
* POLES(1:K, 2) is an array containing the poles in the secular
* equation.
*
* DIFL (input) REAL array, dimension ( K ).
* On entry, DIFL(I) is the distance between I-th updated
* (undeflated) singular value and the I-th (undeflated) old
* singular value.
*
* DIFR (input) REAL array, dimension ( LDGNUM, 2 ).
* On entry, DIFR(I, 1) contains the distances between I-th
* updated (undeflated) singular value and the I+1-th
* (undeflated) old singular value. And DIFR(I, 2) is the
* normalizing factor for the I-th right singular vector.
*
* Z (input) REAL array, dimension ( K )
* Contain the components of the deflation-adjusted updating row
* vector.
*
* K (input) INTEGER
* Contains the dimension of the non-deflated matrix,
* This is the order of the related secular equation. 1 <= K <=N.
*
* C (input) REAL
* C contains garbage if SQRE =0 and the C-value of a Givens
* rotation related to the right null space if SQRE = 1.
*
* S (input) REAL
* S contains garbage if SQRE =0 and the S-value of a Givens
* rotation related to the right null space if SQRE = 1.
*
* WORK (workspace) REAL array, dimension ( K )
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Ren-Cang Li, Computer Science Division, University of
* California at Berkeley, USA
* Osni Marques, LBNL/NERSC, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO, NEGONE
PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0, NEGONE = -1.0E0 )
* ..
* .. Local Scalars ..
INTEGER I, J, M, N, NLP1
REAL DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, TEMP
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMV, SLACPY, SLASCL, SROT, SSCAL,
$ XERBLA
* ..
* .. External Functions ..
REAL SLAMC3, SNRM2
EXTERNAL SLAMC3, SNRM2
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
INFO = -1
ELSE IF( NL.LT.1 ) THEN
INFO = -2
ELSE IF( NR.LT.1 ) THEN
INFO = -3
ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
INFO = -4
END IF
*
N = NL + NR + 1
*
IF( NRHS.LT.1 ) THEN
INFO = -5
ELSE IF( LDB.LT.N ) THEN
INFO = -7
ELSE IF( LDBX.LT.N ) THEN
INFO = -9
ELSE IF( GIVPTR.LT.0 ) THEN
INFO = -11
ELSE IF( LDGCOL.LT.N ) THEN
INFO = -13
ELSE IF( LDGNUM.LT.N ) THEN
INFO = -15
ELSE IF( K.LT.1 ) THEN
INFO = -20
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLALS0', -INFO )
RETURN
END IF
*
M = N + SQRE
NLP1 = NL + 1
*
IF( ICOMPQ.EQ.0 ) THEN
*
* Apply back orthogonal transformations from the left.
*
* Step (1L): apply back the Givens rotations performed.
*
DO 10 I = 1, GIVPTR
CALL SROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB,
$ B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ),
$ GIVNUM( I, 1 ) )
10 CONTINUE
*
* Step (2L): permute rows of B.
*
CALL SCOPY( NRHS, B( NLP1, 1 ), LDB, BX( 1, 1 ), LDBX )
DO 20 I = 2, N
CALL SCOPY( NRHS, B( PERM( I ), 1 ), LDB, BX( I, 1 ), LDBX )
20 CONTINUE
*
* Step (3L): apply the inverse of the left singular vector
* matrix to BX.
*
IF( K.EQ.1 ) THEN
CALL SCOPY( NRHS, BX, LDBX, B, LDB )
IF( Z( 1 ).LT.ZERO ) THEN
CALL SSCAL( NRHS, NEGONE, B, LDB )
END IF
ELSE
DO 50 J = 1, K
DIFLJ = DIFL( J )
DJ = POLES( J, 1 )
DSIGJ = -POLES( J, 2 )
IF( J.LT.K ) THEN
DIFRJ = -DIFR( J, 1 )
DSIGJP = -POLES( J+1, 2 )
END IF
IF( ( Z( J ).EQ.ZERO ) .OR. ( POLES( J, 2 ).EQ.ZERO ) )
$ THEN
WORK( J ) = ZERO
ELSE
WORK( J ) = -POLES( J, 2 )*Z( J ) / DIFLJ /
$ ( POLES( J, 2 )+DJ )
END IF
DO 30 I = 1, J - 1
IF( ( Z( I ).EQ.ZERO ) .OR.
$ ( POLES( I, 2 ).EQ.ZERO ) ) THEN
WORK( I ) = ZERO
ELSE
WORK( I ) = POLES( I, 2 )*Z( I ) /
$ ( SLAMC3( POLES( I, 2 ), DSIGJ )-
$ DIFLJ ) / ( POLES( I, 2 )+DJ )
END IF
30 CONTINUE
DO 40 I = J + 1, K
IF( ( Z( I ).EQ.ZERO ) .OR.
$ ( POLES( I, 2 ).EQ.ZERO ) ) THEN
WORK( I ) = ZERO
ELSE
WORK( I ) = POLES( I, 2 )*Z( I ) /
$ ( SLAMC3( POLES( I, 2 ), DSIGJP )+
$ DIFRJ ) / ( POLES( I, 2 )+DJ )
END IF
40 CONTINUE
WORK( 1 ) = NEGONE
TEMP = SNRM2( K, WORK, 1 )
CALL SGEMV( 'T', K, NRHS, ONE, BX, LDBX, WORK, 1, ZERO,
$ B( J, 1 ), LDB )
CALL SLASCL( 'G', 0, 0, TEMP, ONE, 1, NRHS, B( J, 1 ),
$ LDB, INFO )
50 CONTINUE
END IF
*
* Move the deflated rows of BX to B also.
*
IF( K.LT.MAX( M, N ) )
$ CALL SLACPY( 'A', N-K, NRHS, BX( K+1, 1 ), LDBX,
$ B( K+1, 1 ), LDB )
ELSE
*
* Apply back the right orthogonal transformations.
*
* Step (1R): apply back the new right singular vector matrix
* to B.
*
IF( K.EQ.1 ) THEN
CALL SCOPY( NRHS, B, LDB, BX, LDBX )
ELSE
DO 80 J = 1, K
DSIGJ = POLES( J, 2 )
IF( Z( J ).EQ.ZERO ) THEN
WORK( J ) = ZERO
ELSE
WORK( J ) = -Z( J ) / DIFL( J ) /
$ ( DSIGJ+POLES( J, 1 ) ) / DIFR( J, 2 )
END IF
DO 60 I = 1, J - 1
IF( Z( J ).EQ.ZERO ) THEN
WORK( I ) = ZERO
ELSE
WORK( I ) = Z( J ) / ( SLAMC3( DSIGJ, -POLES( I+1,
$ 2 ) )-DIFR( I, 1 ) ) /
$ ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )
END IF
60 CONTINUE
DO 70 I = J + 1, K
IF( Z( J ).EQ.ZERO ) THEN
WORK( I ) = ZERO
ELSE
WORK( I ) = Z( J ) / ( SLAMC3( DSIGJ, -POLES( I,
$ 2 ) )-DIFL( I ) ) /
$ ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )
END IF
70 CONTINUE
CALL SGEMV( 'T', K, NRHS, ONE, B, LDB, WORK, 1, ZERO,
$ BX( J, 1 ), LDBX )
80 CONTINUE
END IF
*
* Step (2R): if SQRE = 1, apply back the rotation that is
* related to the right null space of the subproblem.
*
IF( SQRE.EQ.1 ) THEN
CALL SCOPY( NRHS, B( M, 1 ), LDB, BX( M, 1 ), LDBX )
CALL SROT( NRHS, BX( 1, 1 ), LDBX, BX( M, 1 ), LDBX, C, S )
END IF
IF( K.LT.MAX( M, N ) )
$ CALL SLACPY( 'A', N-K, NRHS, B( K+1, 1 ), LDB, BX( K+1, 1 ),
$ LDBX )
*
* Step (3R): permute rows of B.
*
CALL SCOPY( NRHS, BX( 1, 1 ), LDBX, B( NLP1, 1 ), LDB )
IF( SQRE.EQ.1 ) THEN
CALL SCOPY( NRHS, BX( M, 1 ), LDBX, B( M, 1 ), LDB )
END IF
DO 90 I = 2, N
CALL SCOPY( NRHS, BX( I, 1 ), LDBX, B( PERM( I ), 1 ), LDB )
90 CONTINUE
*
* Step (4R): apply back the Givens rotations performed.
*
DO 100 I = GIVPTR, 1, -1
CALL SROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB,
$ B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ),
$ -GIVNUM( I, 1 ) )
100 CONTINUE
END IF
*
RETURN
*
* End of SLALS0
*
END
SUBROUTINE SLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U,
$ LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR,
$ GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK,
$ IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS,
$ SMLSIZ
* ..
* .. Array Arguments ..
INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ),
$ K( * ), PERM( LDGCOL, * )
REAL B( LDB, * ), BX( LDBX, * ), C( * ),
$ DIFL( LDU, * ), DIFR( LDU, * ),
$ GIVNUM( LDU, * ), POLES( LDU, * ), S( * ),
$ U( LDU, * ), VT( LDU, * ), WORK( * ),
$ Z( LDU, * )
* ..
*
* Purpose
* =======
*
* SLALSA is an itermediate step in solving the least squares problem
* by computing the SVD of the coefficient matrix in compact form (The
* singular vectors are computed as products of simple orthorgonal
* matrices.).
*
* If ICOMPQ = 0, SLALSA applies the inverse of the left singular vector
* matrix of an upper bidiagonal matrix to the right hand side; and if
* ICOMPQ = 1, SLALSA applies the right singular vector matrix to the
* right hand side. The singular vector matrices were generated in
* compact form by SLALSA.
*
* Arguments
* =========
*
*
* ICOMPQ (input) INTEGER
* Specifies whether the left or the right singular vector
* matrix is involved.
* = 0: Left singular vector matrix
* = 1: Right singular vector matrix
*
* SMLSIZ (input) INTEGER
* The maximum size of the subproblems at the bottom of the
* computation tree.
*
* N (input) INTEGER
* The row and column dimensions of the upper bidiagonal matrix.
*
* NRHS (input) INTEGER
* The number of columns of B and BX. NRHS must be at least 1.
*
* B (input/output) REAL array, dimension ( LDB, NRHS )
* On input, B contains the right hand sides of the least
* squares problem in rows 1 through M.
* On output, B contains the solution X in rows 1 through N.
*
* LDB (input) INTEGER
* The leading dimension of B in the calling subprogram.
* LDB must be at least max(1,MAX( M, N ) ).
*
* BX (output) REAL array, dimension ( LDBX, NRHS )
* On exit, the result of applying the left or right singular
* vector matrix to B.
*
* LDBX (input) INTEGER
* The leading dimension of BX.
*
* U (input) REAL array, dimension ( LDU, SMLSIZ ).
* On entry, U contains the left singular vector matrices of all
* subproblems at the bottom level.
*
* LDU (input) INTEGER, LDU = > N.
* The leading dimension of arrays U, VT, DIFL, DIFR,
* POLES, GIVNUM, and Z.
*
* VT (input) REAL array, dimension ( LDU, SMLSIZ+1 ).
* On entry, VT' contains the right singular vector matrices of
* all subproblems at the bottom level.
*
* K (input) INTEGER array, dimension ( N ).
*
* DIFL (input) REAL array, dimension ( LDU, NLVL ).
* where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.
*
* DIFR (input) REAL array, dimension ( LDU, 2 * NLVL ).
* On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record
* distances between singular values on the I-th level and
* singular values on the (I -1)-th level, and DIFR(*, 2 * I)
* record the normalizing factors of the right singular vectors
* matrices of subproblems on I-th level.
*
* Z (input) REAL array, dimension ( LDU, NLVL ).
* On entry, Z(1, I) contains the components of the deflation-
* adjusted updating row vector for subproblems on the I-th
* level.
*
* POLES (input) REAL array, dimension ( LDU, 2 * NLVL ).
* On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old
* singular values involved in the secular equations on the I-th
* level.
*
* GIVPTR (input) INTEGER array, dimension ( N ).
* On entry, GIVPTR( I ) records the number of Givens
* rotations performed on the I-th problem on the computation
* tree.
*
* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ).
* On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the
* locations of Givens rotations performed on the I-th level on
* the computation tree.
*
* LDGCOL (input) INTEGER, LDGCOL = > N.
* The leading dimension of arrays GIVCOL and PERM.
*
* PERM (input) INTEGER array, dimension ( LDGCOL, NLVL ).
* On entry, PERM(*, I) records permutations done on the I-th
* level of the computation tree.
*
* GIVNUM (input) REAL array, dimension ( LDU, 2 * NLVL ).
* On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-
* values of Givens rotations performed on the I-th level on the
* computation tree.
*
* C (input) REAL array, dimension ( N ).
* On entry, if the I-th subproblem is not square,
* C( I ) contains the C-value of a Givens rotation related to
* the right null space of the I-th subproblem.
*
* S (input) REAL array, dimension ( N ).
* On entry, if the I-th subproblem is not square,
* S( I ) contains the S-value of a Givens rotation related to
* the right null space of the I-th subproblem.
*
* WORK (workspace) REAL array.
* The dimension must be at least N.
*
* IWORK (workspace) INTEGER array.
* The dimension must be at least 3 * N
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Ren-Cang Li, Computer Science Division, University of
* California at Berkeley, USA
* Osni Marques, LBNL/NERSC, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
INTEGER I, I1, IC, IM1, INODE, J, LF, LL, LVL, LVL2,
$ ND, NDB1, NDIML, NDIMR, NL, NLF, NLP1, NLVL,
$ NR, NRF, NRP1, SQRE
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMM, SLALS0, SLASDT, XERBLA
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
INFO = -1
ELSE IF( SMLSIZ.LT.3 ) THEN
INFO = -2
ELSE IF( N.LT.SMLSIZ ) THEN
INFO = -3
ELSE IF( NRHS.LT.1 ) THEN
INFO = -4
ELSE IF( LDB.LT.N ) THEN
INFO = -6
ELSE IF( LDBX.LT.N ) THEN
INFO = -8
ELSE IF( LDU.LT.N ) THEN
INFO = -10
ELSE IF( LDGCOL.LT.N ) THEN
INFO = -19
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLALSA', -INFO )
RETURN
END IF
*
* Book-keeping and setting up the computation tree.
*
INODE = 1
NDIML = INODE + N
NDIMR = NDIML + N
*
CALL SLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ),
$ IWORK( NDIMR ), SMLSIZ )
*
* The following code applies back the left singular vector factors.
* For applying back the right singular vector factors, go to 50.
*
IF( ICOMPQ.EQ.1 ) THEN
GO TO 50
END IF
*
* The nodes on the bottom level of the tree were solved
* by SLASDQ. The corresponding left and right singular vector
* matrices are in explicit form. First apply back the left
* singular vector matrices.
*
NDB1 = ( ND+1 ) / 2
DO 10 I = NDB1, ND
*
* IC : center row of each node
* NL : number of rows of left subproblem
* NR : number of rows of right subproblem
* NLF: starting row of the left subproblem
* NRF: starting row of the right subproblem
*
I1 = I - 1
IC = IWORK( INODE+I1 )
NL = IWORK( NDIML+I1 )
NR = IWORK( NDIMR+I1 )
NLF = IC - NL
NRF = IC + 1
CALL SGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU,
$ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX )
CALL SGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU,
$ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX )
10 CONTINUE
*
* Next copy the rows of B that correspond to unchanged rows
* in the bidiagonal matrix to BX.
*
DO 20 I = 1, ND
IC = IWORK( INODE+I-1 )
CALL SCOPY( NRHS, B( IC, 1 ), LDB, BX( IC, 1 ), LDBX )
20 CONTINUE
*
* Finally go through the left singular vector matrices of all
* the other subproblems bottom-up on the tree.
*
J = 2**NLVL
SQRE = 0
*
DO 40 LVL = NLVL, 1, -1
LVL2 = 2*LVL - 1
*
* find the first node LF and last node LL on
* the current level LVL
*
IF( LVL.EQ.1 ) THEN
LF = 1
LL = 1
ELSE
LF = 2**( LVL-1 )
LL = 2*LF - 1
END IF
DO 30 I = LF, LL
IM1 = I - 1
IC = IWORK( INODE+IM1 )
NL = IWORK( NDIML+IM1 )
NR = IWORK( NDIMR+IM1 )
NLF = IC - NL
NRF = IC + 1
J = J - 1
CALL SLALS0( ICOMPQ, NL, NR, SQRE, NRHS, BX( NLF, 1 ), LDBX,
$ B( NLF, 1 ), LDB, PERM( NLF, LVL ),
$ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
$ GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ),
$ DIFL( NLF, LVL ), DIFR( NLF, LVL2 ),
$ Z( NLF, LVL ), K( J ), C( J ), S( J ), WORK,
$ INFO )
30 CONTINUE
40 CONTINUE
GO TO 90
*
* ICOMPQ = 1: applying back the right singular vector factors.
*
50 CONTINUE
*
* First now go through the right singular vector matrices of all
* the tree nodes top-down.
*
J = 0
DO 70 LVL = 1, NLVL
LVL2 = 2*LVL - 1
*
* Find the first node LF and last node LL on
* the current level LVL.
*
IF( LVL.EQ.1 ) THEN
LF = 1
LL = 1
ELSE
LF = 2**( LVL-1 )
LL = 2*LF - 1
END IF
DO 60 I = LL, LF, -1
IM1 = I - 1
IC = IWORK( INODE+IM1 )
NL = IWORK( NDIML+IM1 )
NR = IWORK( NDIMR+IM1 )
NLF = IC - NL
NRF = IC + 1
IF( I.EQ.LL ) THEN
SQRE = 0
ELSE
SQRE = 1
END IF
J = J + 1
CALL SLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B( NLF, 1 ), LDB,
$ BX( NLF, 1 ), LDBX, PERM( NLF, LVL ),
$ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
$ GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ),
$ DIFL( NLF, LVL ), DIFR( NLF, LVL2 ),
$ Z( NLF, LVL ), K( J ), C( J ), S( J ), WORK,
$ INFO )
60 CONTINUE
70 CONTINUE
*
* The nodes on the bottom level of the tree were solved
* by SLASDQ. The corresponding right singular vector
* matrices are in explicit form. Apply them back.
*
NDB1 = ( ND+1 ) / 2
DO 80 I = NDB1, ND
I1 = I - 1
IC = IWORK( INODE+I1 )
NL = IWORK( NDIML+I1 )
NR = IWORK( NDIMR+I1 )
NLP1 = NL + 1
IF( I.EQ.ND ) THEN
NRP1 = NR
ELSE
NRP1 = NR + 1
END IF
NLF = IC - NL
NRF = IC + 1
CALL SGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU,
$ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX )
CALL SGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU,
$ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX )
80 CONTINUE
*
90 CONTINUE
*
RETURN
*
* End of SLALSA
*
END
SUBROUTINE SLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND,
$ RANK, WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDB, N, NRHS, RANK, SMLSIZ
REAL RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL B( LDB, * ), D( * ), E( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SLALSD uses the singular value decomposition of A to solve the least
* squares problem of finding X to minimize the Euclidean norm of each
* column of A*X-B, where A is N-by-N upper bidiagonal, and X and B
* are N-by-NRHS. The solution X overwrites B.
*
* The singular values of A smaller than RCOND times the largest
* singular value are treated as zero in solving the least squares
* problem; in this case a minimum norm solution is returned.
* The actual singular values are returned in D in ascending order.
*
* This code makes very mild assumptions about floating point
* arithmetic. It will work on machines with a guard digit in
* add/subtract, or on those binary machines without guard digits
* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
* It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': D and E define an upper bidiagonal matrix.
* = 'L': D and E define a lower bidiagonal matrix.
*
* SMLSIZ (input) INTEGER
* The maximum size of the subproblems at the bottom of the
* computation tree.
*
* N (input) INTEGER
* The dimension of the bidiagonal matrix. N >= 0.
*
* NRHS (input) INTEGER
* The number of columns of B. NRHS must be at least 1.
*
* D (input/output) REAL array, dimension (N)
* On entry D contains the main diagonal of the bidiagonal
* matrix. On exit, if INFO = 0, D contains its singular values.
*
* E (input/output) REAL array, dimension (N-1)
* Contains the super-diagonal entries of the bidiagonal matrix.
* On exit, E has been destroyed.
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On input, B contains the right hand sides of the least
* squares problem. On output, B contains the solution X.
*
* LDB (input) INTEGER
* The leading dimension of B in the calling subprogram.
* LDB must be at least max(1,N).
*
* RCOND (input) REAL
* The singular values of A less than or equal to RCOND times
* the largest singular value are treated as zero in solving
* the least squares problem. If RCOND is negative,
* machine precision is used instead.
* For example, if diag(S)*X=B were the least squares problem,
* where diag(S) is a diagonal matrix of singular values, the
* solution would be X(i) = B(i) / S(i) if S(i) is greater than
* RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to
* RCOND*max(S).
*
* RANK (output) INTEGER
* The number of singular values of A greater than RCOND times
* the largest singular value.
*
* WORK (workspace) REAL array, dimension at least
* (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2),
* where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1).
*
* IWORK (workspace) INTEGER array, dimension at least
* (3*N*NLVL + 11*N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: The algorithm failed to compute an singular value while
* working on the submatrix lying in rows and columns
* INFO/(N+1) through MOD(INFO,N+1).
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Ren-Cang Li, Computer Science Division, University of
* California at Berkeley, USA
* Osni Marques, LBNL/NERSC, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 )
* ..
* .. Local Scalars ..
INTEGER BX, BXST, C, DIFL, DIFR, GIVCOL, GIVNUM,
$ GIVPTR, I, ICMPQ1, ICMPQ2, IWK, J, K, NLVL,
$ NM1, NSIZE, NSUB, NWORK, PERM, POLES, S, SIZEI,
$ SMLSZP, SQRE, ST, ST1, U, VT, Z
REAL CS, EPS, ORGNRM, R, RCND, SN, TOL
* ..
* .. External Functions ..
INTEGER ISAMAX
REAL SLAMCH, SLANST
EXTERNAL ISAMAX, SLAMCH, SLANST
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMM, SLACPY, SLALSA, SLARTG, SLASCL,
$ SLASDA, SLASDQ, SLASET, SLASRT, SROT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, REAL, SIGN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.1 ) THEN
INFO = -4
ELSE IF( ( LDB.LT.1 ) .OR. ( LDB.LT.N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLALSD', -INFO )
RETURN
END IF
*
EPS = SLAMCH( 'Epsilon' )
*
* Set up the tolerance.
*
IF( ( RCOND.LE.ZERO ) .OR. ( RCOND.GE.ONE ) ) THEN
RCND = EPS
ELSE
RCND = RCOND
END IF
*
RANK = 0
*
* Quick return if possible.
*
IF( N.EQ.0 ) THEN
RETURN
ELSE IF( N.EQ.1 ) THEN
IF( D( 1 ).EQ.ZERO ) THEN
CALL SLASET( 'A', 1, NRHS, ZERO, ZERO, B, LDB )
ELSE
RANK = 1
CALL SLASCL( 'G', 0, 0, D( 1 ), ONE, 1, NRHS, B, LDB, INFO )
D( 1 ) = ABS( D( 1 ) )
END IF
RETURN
END IF
*
* Rotate the matrix if it is lower bidiagonal.
*
IF( UPLO.EQ.'L' ) THEN
DO 10 I = 1, N - 1
CALL SLARTG( D( I ), E( I ), CS, SN, R )
D( I ) = R
E( I ) = SN*D( I+1 )
D( I+1 ) = CS*D( I+1 )
IF( NRHS.EQ.1 ) THEN
CALL SROT( 1, B( I, 1 ), 1, B( I+1, 1 ), 1, CS, SN )
ELSE
WORK( I*2-1 ) = CS
WORK( I*2 ) = SN
END IF
10 CONTINUE
IF( NRHS.GT.1 ) THEN
DO 30 I = 1, NRHS
DO 20 J = 1, N - 1
CS = WORK( J*2-1 )
SN = WORK( J*2 )
CALL SROT( 1, B( J, I ), 1, B( J+1, I ), 1, CS, SN )
20 CONTINUE
30 CONTINUE
END IF
END IF
*
* Scale.
*
NM1 = N - 1
ORGNRM = SLANST( 'M', N, D, E )
IF( ORGNRM.EQ.ZERO ) THEN
CALL SLASET( 'A', N, NRHS, ZERO, ZERO, B, LDB )
RETURN
END IF
*
CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, INFO )
*
* If N is smaller than the minimum divide size SMLSIZ, then solve
* the problem with another solver.
*
IF( N.LE.SMLSIZ ) THEN
NWORK = 1 + N*N
CALL SLASET( 'A', N, N, ZERO, ONE, WORK, N )
CALL SLASDQ( 'U', 0, N, N, 0, NRHS, D, E, WORK, N, WORK, N, B,
$ LDB, WORK( NWORK ), INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
TOL = RCND*ABS( D( ISAMAX( N, D, 1 ) ) )
DO 40 I = 1, N
IF( D( I ).LE.TOL ) THEN
CALL SLASET( 'A', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
ELSE
CALL SLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS, B( I, 1 ),
$ LDB, INFO )
RANK = RANK + 1
END IF
40 CONTINUE
CALL SGEMM( 'T', 'N', N, NRHS, N, ONE, WORK, N, B, LDB, ZERO,
$ WORK( NWORK ), N )
CALL SLACPY( 'A', N, NRHS, WORK( NWORK ), N, B, LDB )
*
* Unscale.
*
CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
CALL SLASRT( 'D', N, D, INFO )
CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO )
*
RETURN
END IF
*
* Book-keeping and setting up some constants.
*
NLVL = INT( LOG( REAL( N ) / REAL( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1
*
SMLSZP = SMLSIZ + 1
*
U = 1
VT = 1 + SMLSIZ*N
DIFL = VT + SMLSZP*N
DIFR = DIFL + NLVL*N
Z = DIFR + NLVL*N*2
C = Z + NLVL*N
S = C + N
POLES = S + N
GIVNUM = POLES + 2*NLVL*N
BX = GIVNUM + 2*NLVL*N
NWORK = BX + N*NRHS
*
SIZEI = 1 + N
K = SIZEI + N
GIVPTR = K + N
PERM = GIVPTR + N
GIVCOL = PERM + NLVL*N
IWK = GIVCOL + NLVL*N*2
*
ST = 1
SQRE = 0
ICMPQ1 = 1
ICMPQ2 = 0
NSUB = 0
*
DO 50 I = 1, N
IF( ABS( D( I ) ).LT.EPS ) THEN
D( I ) = SIGN( EPS, D( I ) )
END IF
50 CONTINUE
*
DO 60 I = 1, NM1
IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN
NSUB = NSUB + 1
IWORK( NSUB ) = ST
*
* Subproblem found. First determine its size and then
* apply divide and conquer on it.
*
IF( I.LT.NM1 ) THEN
*
* A subproblem with E(I) small for I < NM1.
*
NSIZE = I - ST + 1
IWORK( SIZEI+NSUB-1 ) = NSIZE
ELSE IF( ABS( E( I ) ).GE.EPS ) THEN
*
* A subproblem with E(NM1) not too small but I = NM1.
*
NSIZE = N - ST + 1
IWORK( SIZEI+NSUB-1 ) = NSIZE
ELSE
*
* A subproblem with E(NM1) small. This implies an
* 1-by-1 subproblem at D(N), which is not solved
* explicitly.
*
NSIZE = I - ST + 1
IWORK( SIZEI+NSUB-1 ) = NSIZE
NSUB = NSUB + 1
IWORK( NSUB ) = N
IWORK( SIZEI+NSUB-1 ) = 1
CALL SCOPY( NRHS, B( N, 1 ), LDB, WORK( BX+NM1 ), N )
END IF
ST1 = ST - 1
IF( NSIZE.EQ.1 ) THEN
*
* This is a 1-by-1 subproblem and is not solved
* explicitly.
*
CALL SCOPY( NRHS, B( ST, 1 ), LDB, WORK( BX+ST1 ), N )
ELSE IF( NSIZE.LE.SMLSIZ ) THEN
*
* This is a small subproblem and is solved by SLASDQ.
*
CALL SLASET( 'A', NSIZE, NSIZE, ZERO, ONE,
$ WORK( VT+ST1 ), N )
CALL SLASDQ( 'U', 0, NSIZE, NSIZE, 0, NRHS, D( ST ),
$ E( ST ), WORK( VT+ST1 ), N, WORK( NWORK ),
$ N, B( ST, 1 ), LDB, WORK( NWORK ), INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
CALL SLACPY( 'A', NSIZE, NRHS, B( ST, 1 ), LDB,
$ WORK( BX+ST1 ), N )
ELSE
*
* A large problem. Solve it using divide and conquer.
*
CALL SLASDA( ICMPQ1, SMLSIZ, NSIZE, SQRE, D( ST ),
$ E( ST ), WORK( U+ST1 ), N, WORK( VT+ST1 ),
$ IWORK( K+ST1 ), WORK( DIFL+ST1 ),
$ WORK( DIFR+ST1 ), WORK( Z+ST1 ),
$ WORK( POLES+ST1 ), IWORK( GIVPTR+ST1 ),
$ IWORK( GIVCOL+ST1 ), N, IWORK( PERM+ST1 ),
$ WORK( GIVNUM+ST1 ), WORK( C+ST1 ),
$ WORK( S+ST1 ), WORK( NWORK ), IWORK( IWK ),
$ INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
BXST = BX + ST1
CALL SLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, B( ST, 1 ),
$ LDB, WORK( BXST ), N, WORK( U+ST1 ), N,
$ WORK( VT+ST1 ), IWORK( K+ST1 ),
$ WORK( DIFL+ST1 ), WORK( DIFR+ST1 ),
$ WORK( Z+ST1 ), WORK( POLES+ST1 ),
$ IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N,
$ IWORK( PERM+ST1 ), WORK( GIVNUM+ST1 ),
$ WORK( C+ST1 ), WORK( S+ST1 ), WORK( NWORK ),
$ IWORK( IWK ), INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
END IF
ST = I + 1
END IF
60 CONTINUE
*
* Apply the singular values and treat the tiny ones as zero.
*
TOL = RCND*ABS( D( ISAMAX( N, D, 1 ) ) )
*
DO 70 I = 1, N
*
* Some of the elements in D can be negative because 1-by-1
* subproblems were not solved explicitly.
*
IF( ABS( D( I ) ).LE.TOL ) THEN
CALL SLASET( 'A', 1, NRHS, ZERO, ZERO, WORK( BX+I-1 ), N )
ELSE
RANK = RANK + 1
CALL SLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS,
$ WORK( BX+I-1 ), N, INFO )
END IF
D( I ) = ABS( D( I ) )
70 CONTINUE
*
* Now apply back the right singular vectors.
*
ICMPQ2 = 1
DO 80 I = 1, NSUB
ST = IWORK( I )
ST1 = ST - 1
NSIZE = IWORK( SIZEI+I-1 )
BXST = BX + ST1
IF( NSIZE.EQ.1 ) THEN
CALL SCOPY( NRHS, WORK( BXST ), N, B( ST, 1 ), LDB )
ELSE IF( NSIZE.LE.SMLSIZ ) THEN
CALL SGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
$ WORK( VT+ST1 ), N, WORK( BXST ), N, ZERO,
$ B( ST, 1 ), LDB )
ELSE
CALL SLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, WORK( BXST ), N,
$ B( ST, 1 ), LDB, WORK( U+ST1 ), N,
$ WORK( VT+ST1 ), IWORK( K+ST1 ),
$ WORK( DIFL+ST1 ), WORK( DIFR+ST1 ),
$ WORK( Z+ST1 ), WORK( POLES+ST1 ),
$ IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N,
$ IWORK( PERM+ST1 ), WORK( GIVNUM+ST1 ),
$ WORK( C+ST1 ), WORK( S+ST1 ), WORK( NWORK ),
$ IWORK( IWK ), INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
END IF
80 CONTINUE
*
* Unscale and sort the singular values.
*
CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
CALL SLASRT( 'D', N, D, INFO )
CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO )
*
RETURN
*
* End of SLALSD
*
END
SUBROUTINE SLAMRG( N1, N2, A, STRD1, STRD2, INDEX )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER N1, N2, STRD1, STRD2
* ..
* .. Array Arguments ..
INTEGER INDEX( * )
REAL A( * )
* ..
*
* Purpose
* =======
*
* SLAMRG will create a permutation list which will merge the elements
* of A (which is composed of two independently sorted sets) into a
* single set which is sorted in ascending order.
*
* Arguments
* =========
*
* N1 (input) INTEGER
* N2 (input) INTEGER
* These arguements contain the respective lengths of the two
* sorted lists to be merged.
*
* A (input) REAL array, dimension (N1+N2)
* The first N1 elements of A contain a list of numbers which
* are sorted in either ascending or descending order. Likewise
* for the final N2 elements.
*
* STRD1 (input) INTEGER
* STRD2 (input) INTEGER
* These are the strides to be taken through the array A.
* Allowable strides are 1 and -1. They indicate whether a
* subset of A is sorted in ascending (STRDx = 1) or descending
* (STRDx = -1) order.
*
* INDEX (output) INTEGER array, dimension (N1+N2)
* On exit this array will contain a permutation such that
* if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be
* sorted in ascending order.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, IND1, IND2, N1SV, N2SV
* ..
* .. Executable Statements ..
*
N1SV = N1
N2SV = N2
IF( STRD1.GT.0 ) THEN
IND1 = 1
ELSE
IND1 = N1
END IF
IF( STRD2.GT.0 ) THEN
IND2 = 1 + N1
ELSE
IND2 = N1 + N2
END IF
I = 1
* while ( (N1SV > 0) & (N2SV > 0) )
10 CONTINUE
IF( N1SV.GT.0 .AND. N2SV.GT.0 ) THEN
IF( A( IND1 ).LE.A( IND2 ) ) THEN
INDEX( I ) = IND1
I = I + 1
IND1 = IND1 + STRD1
N1SV = N1SV - 1
ELSE
INDEX( I ) = IND2
I = I + 1
IND2 = IND2 + STRD2
N2SV = N2SV - 1
END IF
GO TO 10
END IF
* end while
IF( N1SV.EQ.0 ) THEN
DO 20 N1SV = 1, N2SV
INDEX( I ) = IND2
I = I + 1
IND2 = IND2 + STRD2
20 CONTINUE
ELSE
* N2SV .EQ. 0
DO 30 N2SV = 1, N1SV
INDEX( I ) = IND1
I = I + 1
IND1 = IND1 + STRD1
30 CONTINUE
END IF
*
RETURN
*
* End of SLAMRG
*
END
FUNCTION SLANEG( N, D, LLD, SIGMA, PIVMIN, R )
IMPLICIT NONE
INTEGER SLANEG
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER N, R
REAL PIVMIN, SIGMA
* ..
* .. Array Arguments ..
REAL D( * ), LLD( * )
* ..
*
* Purpose
* =======
*
* SLANEG computes the Sturm count, the number of negative pivots
* encountered while factoring tridiagonal T - sigma I = L D L^T.
* This implementation works directly on the factors without forming
* the tridiagonal matrix T. The Sturm count is also the number of
* eigenvalues of T less than sigma.
*
* This routine is called from SLARRB.
*
* The current routine does not use the PIVMIN parameter but rather
* requires IEEE-754 propagation of Infinities and NaNs. This
* routine also has no input range restrictions but does require
* default exception handling such that x/0 produces Inf when x is
* non-zero, and Inf/Inf produces NaN. For more information, see:
*
* Marques, Riedy, and Voemel, "Benefits of IEEE-754 Features in
* Modern Symmetric Tridiagonal Eigensolvers," SIAM Journal on
* Scientific Computing, v28, n5, 2006. DOI 10.1137/050641624
* (Tech report version in LAWN 172 with the same title.)
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix.
*
* D (input) REAL array, dimension (N)
* The N diagonal elements of the diagonal matrix D.
*
* LLD (input) REAL array, dimension (N-1)
* The (N-1) elements L(i)*L(i)*D(i).
*
* SIGMA (input) REAL
* Shift amount in T - sigma I = L D L^T.
*
* PIVMIN (input) REAL
* The minimum pivot in the Sturm sequence. May be used
* when zero pivots are encountered on non-IEEE-754
* architectures.
*
* R (input) INTEGER
* The twist index for the twisted factorization that is used
* for the negcount.
*
* Further Details
* ===============
*
* Based on contributions by
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
* Jason Riedy, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* Some architectures propagate Infinities and NaNs very slowly, so
* the code computes counts in BLKLEN chunks. Then a NaN can
* propagate at most BLKLEN columns before being detected. This is
* not a general tuning parameter; it needs only to be just large
* enough that the overhead is tiny in common cases.
INTEGER BLKLEN
PARAMETER ( BLKLEN = 128 )
* ..
* .. Local Scalars ..
INTEGER BJ, J, NEG1, NEG2, NEGCNT
REAL BSAV, DMINUS, DPLUS, GAMMA, P, T, TMP
LOGICAL SAWNAN
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN, MAX
* ..
* .. External Functions ..
LOGICAL SISNAN
EXTERNAL SISNAN
* ..
* .. Executable Statements ..
NEGCNT = 0
* I) upper part: L D L^T - SIGMA I = L+ D+ L+^T
T = -SIGMA
DO 210 BJ = 1, R-1, BLKLEN
NEG1 = 0
BSAV = T
DO 21 J = BJ, MIN(BJ+BLKLEN-1, R-1)
DPLUS = D( J ) + T
IF( DPLUS.LT.ZERO ) NEG1 = NEG1 + 1
TMP = T / DPLUS
T = TMP * LLD( J ) - SIGMA
21 CONTINUE
SAWNAN = SISNAN( T )
* Run a slower version of the above loop if a NaN is detected.
* A NaN should occur only with a zero pivot after an infinite
* pivot. In that case, substituting 1 for T/DPLUS is the
* correct limit.
IF( SAWNAN ) THEN
NEG1 = 0
T = BSAV
DO 22 J = BJ, MIN(BJ+BLKLEN-1, R-1)
DPLUS = D( J ) + T
IF( DPLUS.LT.ZERO ) NEG1 = NEG1 + 1
TMP = T / DPLUS
IF (SISNAN(TMP)) TMP = ONE
T = TMP * LLD(J) - SIGMA
22 CONTINUE
END IF
NEGCNT = NEGCNT + NEG1
210 CONTINUE
*
* II) lower part: L D L^T - SIGMA I = U- D- U-^T
P = D( N ) - SIGMA
DO 230 BJ = N-1, R, -BLKLEN
NEG2 = 0
BSAV = P
DO 23 J = BJ, MAX(BJ-BLKLEN+1, R), -1
DMINUS = LLD( J ) + P
IF( DMINUS.LT.ZERO ) NEG2 = NEG2 + 1
TMP = P / DMINUS
P = TMP * D( J ) - SIGMA
23 CONTINUE
SAWNAN = SISNAN( P )
* As above, run a slower version that substitutes 1 for Inf/Inf.
*
IF( SAWNAN ) THEN
NEG2 = 0
P = BSAV
DO 24 J = BJ, MAX(BJ-BLKLEN+1, R), -1
DMINUS = LLD( J ) + P
IF( DMINUS.LT.ZERO ) NEG2 = NEG2 + 1
TMP = P / DMINUS
IF (SISNAN(TMP)) TMP = ONE
P = TMP * D(J) - SIGMA
24 CONTINUE
END IF
NEGCNT = NEGCNT + NEG2
230 CONTINUE
*
* III) Twist index
* T was shifted by SIGMA initially.
GAMMA = (T + SIGMA) + P
IF( GAMMA.LT.ZERO ) NEGCNT = NEGCNT+1
SLANEG = NEGCNT
END
REAL FUNCTION SLANGB( NORM, N, KL, KU, AB, LDAB,
$ WORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER KL, KU, LDAB, N
* ..
* .. Array Arguments ..
REAL AB( LDAB, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SLANGB returns the value of the one norm, or the Frobenius norm, or
* the infinity norm, or the element of largest absolute value of an
* n by n band matrix A, with kl sub-diagonals and ku super-diagonals.
*
* Description
* ===========
*
* SLANGB returns the value
*
* SLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm'
* (
* ( norm1(A), NORM = '1', 'O' or 'o'
* (
* ( normI(A), NORM = 'I' or 'i'
* (
* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*
* where norm1 denotes the one norm of a matrix (maximum column sum),
* normI denotes the infinity norm of a matrix (maximum row sum) and
* normF denotes the Frobenius norm of a matrix (square root of sum of
* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies the value to be returned in SLANGB as described
* above.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0. When N = 0, SLANGB is
* set to zero.
*
* KL (input) INTEGER
* The number of sub-diagonals of the matrix A. KL >= 0.
*
* KU (input) INTEGER
* The number of super-diagonals of the matrix A. KU >= 0.
*
* AB (input) REAL array, dimension (LDAB,N)
* The band matrix A, stored in rows 1 to KL+KU+1. The j-th
* column of A is stored in the j-th column of the array AB as
* follows:
* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KL+KU+1.
*
* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),
* where LWORK >= N when NORM = 'I'; otherwise, WORK is not
* referenced.
*
* =====================================================================
*
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, K, L
REAL SCALE, SUM, VALUE
* ..
* .. External Subroutines ..
EXTERNAL SLASSQ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
VALUE = ZERO
DO 20 J = 1, N
DO 10 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
10 CONTINUE
20 CONTINUE
ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
*
* Find norm1(A).
*
VALUE = ZERO
DO 40 J = 1, N
SUM = ZERO
DO 30 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
SUM = SUM + ABS( AB( I, J ) )
30 CONTINUE
VALUE = MAX( VALUE, SUM )
40 CONTINUE
ELSE IF( LSAME( NORM, 'I' ) ) THEN
*
* Find normI(A).
*
DO 50 I = 1, N
WORK( I ) = ZERO
50 CONTINUE
DO 70 J = 1, N
K = KU + 1 - J
DO 60 I = MAX( 1, J-KU ), MIN( N, J+KL )
WORK( I ) = WORK( I ) + ABS( AB( K+I, J ) )
60 CONTINUE
70 CONTINUE
VALUE = ZERO
DO 80 I = 1, N
VALUE = MAX( VALUE, WORK( I ) )
80 CONTINUE
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
DO 90 J = 1, N
L = MAX( 1, J-KU )
K = KU + 1 - J + L
CALL SLASSQ( MIN( N, J+KL )-L+1, AB( K, J ), 1, SCALE, SUM )
90 CONTINUE
VALUE = SCALE*SQRT( SUM )
END IF
*
SLANGB = VALUE
RETURN
*
* End of SLANGB
*
END
REAL FUNCTION SLANGE( NORM, M, N, A, LDA, WORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER LDA, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SLANGE returns the value of the one norm, or the Frobenius norm, or
* the infinity norm, or the element of largest absolute value of a
* real matrix A.
*
* Description
* ===========
*
* SLANGE returns the value
*
* SLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'
* (
* ( norm1(A), NORM = '1', 'O' or 'o'
* (
* ( normI(A), NORM = 'I' or 'i'
* (
* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*
* where norm1 denotes the one norm of a matrix (maximum column sum),
* normI denotes the infinity norm of a matrix (maximum row sum) and
* normF denotes the Frobenius norm of a matrix (square root of sum of
* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies the value to be returned in SLANGE as described
* above.
*
* M (input) INTEGER
* The number of rows of the matrix A. M >= 0. When M = 0,
* SLANGE is set to zero.
*
* N (input) INTEGER
* The number of columns of the matrix A. N >= 0. When N = 0,
* SLANGE is set to zero.
*
* A (input) REAL array, dimension (LDA,N)
* The m by n matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(M,1).
*
* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),
* where LWORK >= M when NORM = 'I'; otherwise, WORK is not
* referenced.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
REAL SCALE, SUM, VALUE
* ..
* .. External Subroutines ..
EXTERNAL SLASSQ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
IF( MIN( M, N ).EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
VALUE = ZERO
DO 20 J = 1, N
DO 10 I = 1, M
VALUE = MAX( VALUE, ABS( A( I, J ) ) )
10 CONTINUE
20 CONTINUE
ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
*
* Find norm1(A).
*
VALUE = ZERO
DO 40 J = 1, N
SUM = ZERO
DO 30 I = 1, M
SUM = SUM + ABS( A( I, J ) )
30 CONTINUE
VALUE = MAX( VALUE, SUM )
40 CONTINUE
ELSE IF( LSAME( NORM, 'I' ) ) THEN
*
* Find normI(A).
*
DO 50 I = 1, M
WORK( I ) = ZERO
50 CONTINUE
DO 70 J = 1, N
DO 60 I = 1, M
WORK( I ) = WORK( I ) + ABS( A( I, J ) )
60 CONTINUE
70 CONTINUE
VALUE = ZERO
DO 80 I = 1, M
VALUE = MAX( VALUE, WORK( I ) )
80 CONTINUE
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
DO 90 J = 1, N
CALL SLASSQ( M, A( 1, J ), 1, SCALE, SUM )
90 CONTINUE
VALUE = SCALE*SQRT( SUM )
END IF
*
SLANGE = VALUE
RETURN
*
* End of SLANGE
*
END
REAL FUNCTION SLANGT( NORM, N, DL, D, DU )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER N
* ..
* .. Array Arguments ..
REAL D( * ), DL( * ), DU( * )
* ..
*
* Purpose
* =======
*
* SLANGT returns the value of the one norm, or the Frobenius norm, or
* the infinity norm, or the element of largest absolute value of a
* real tridiagonal matrix A.
*
* Description
* ===========
*
* SLANGT returns the value
*
* SLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm'
* (
* ( norm1(A), NORM = '1', 'O' or 'o'
* (
* ( normI(A), NORM = 'I' or 'i'
* (
* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*
* where norm1 denotes the one norm of a matrix (maximum column sum),
* normI denotes the infinity norm of a matrix (maximum row sum) and
* normF denotes the Frobenius norm of a matrix (square root of sum of
* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies the value to be returned in SLANGT as described
* above.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0. When N = 0, SLANGT is
* set to zero.
*
* DL (input) REAL array, dimension (N-1)
* The (n-1) sub-diagonal elements of A.
*
* D (input) REAL array, dimension (N)
* The diagonal elements of A.
*
* DU (input) REAL array, dimension (N-1)
* The (n-1) super-diagonal elements of A.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I
REAL ANORM, SCALE, SUM
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SLASSQ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
IF( N.LE.0 ) THEN
ANORM = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
ANORM = ABS( D( N ) )
DO 10 I = 1, N - 1
ANORM = MAX( ANORM, ABS( DL( I ) ) )
ANORM = MAX( ANORM, ABS( D( I ) ) )
ANORM = MAX( ANORM, ABS( DU( I ) ) )
10 CONTINUE
ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' ) THEN
*
* Find norm1(A).
*
IF( N.EQ.1 ) THEN
ANORM = ABS( D( 1 ) )
ELSE
ANORM = MAX( ABS( D( 1 ) )+ABS( DL( 1 ) ),
$ ABS( D( N ) )+ABS( DU( N-1 ) ) )
DO 20 I = 2, N - 1
ANORM = MAX( ANORM, ABS( D( I ) )+ABS( DL( I ) )+
$ ABS( DU( I-1 ) ) )
20 CONTINUE
END IF
ELSE IF( LSAME( NORM, 'I' ) ) THEN
*
* Find normI(A).
*
IF( N.EQ.1 ) THEN
ANORM = ABS( D( 1 ) )
ELSE
ANORM = MAX( ABS( D( 1 ) )+ABS( DU( 1 ) ),
$ ABS( D( N ) )+ABS( DL( N-1 ) ) )
DO 30 I = 2, N - 1
ANORM = MAX( ANORM, ABS( D( I ) )+ABS( DU( I ) )+
$ ABS( DL( I-1 ) ) )
30 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
CALL SLASSQ( N, D, 1, SCALE, SUM )
IF( N.GT.1 ) THEN
CALL SLASSQ( N-1, DL, 1, SCALE, SUM )
CALL SLASSQ( N-1, DU, 1, SCALE, SUM )
END IF
ANORM = SCALE*SQRT( SUM )
END IF
*
SLANGT = ANORM
RETURN
*
* End of SLANGT
*
END
REAL FUNCTION SLANHS( NORM, N, A, LDA, WORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER LDA, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SLANHS returns the value of the one norm, or the Frobenius norm, or
* the infinity norm, or the element of largest absolute value of a
* Hessenberg matrix A.
*
* Description
* ===========
*
* SLANHS returns the value
*
* SLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm'
* (
* ( norm1(A), NORM = '1', 'O' or 'o'
* (
* ( normI(A), NORM = 'I' or 'i'
* (
* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*
* where norm1 denotes the one norm of a matrix (maximum column sum),
* normI denotes the infinity norm of a matrix (maximum row sum) and
* normF denotes the Frobenius norm of a matrix (square root of sum of
* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies the value to be returned in SLANHS as described
* above.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0. When N = 0, SLANHS is
* set to zero.
*
* A (input) REAL array, dimension (LDA,N)
* The n by n upper Hessenberg matrix A; the part of A below the
* first sub-diagonal is not referenced.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(N,1).
*
* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),
* where LWORK >= N when NORM = 'I'; otherwise, WORK is not
* referenced.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
REAL SCALE, SUM, VALUE
* ..
* .. External Subroutines ..
EXTERNAL SLASSQ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
VALUE = ZERO
DO 20 J = 1, N
DO 10 I = 1, MIN( N, J+1 )
VALUE = MAX( VALUE, ABS( A( I, J ) ) )
10 CONTINUE
20 CONTINUE
ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
*
* Find norm1(A).
*
VALUE = ZERO
DO 40 J = 1, N
SUM = ZERO
DO 30 I = 1, MIN( N, J+1 )
SUM = SUM + ABS( A( I, J ) )
30 CONTINUE
VALUE = MAX( VALUE, SUM )
40 CONTINUE
ELSE IF( LSAME( NORM, 'I' ) ) THEN
*
* Find normI(A).
*
DO 50 I = 1, N
WORK( I ) = ZERO
50 CONTINUE
DO 70 J = 1, N
DO 60 I = 1, MIN( N, J+1 )
WORK( I ) = WORK( I ) + ABS( A( I, J ) )
60 CONTINUE
70 CONTINUE
VALUE = ZERO
DO 80 I = 1, N
VALUE = MAX( VALUE, WORK( I ) )
80 CONTINUE
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
DO 90 J = 1, N
CALL SLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM )
90 CONTINUE
VALUE = SCALE*SQRT( SUM )
END IF
*
SLANHS = VALUE
RETURN
*
* End of SLANHS
*
END
REAL FUNCTION SLANSB( NORM, UPLO, N, K, AB, LDAB,
$ WORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER NORM, UPLO
INTEGER K, LDAB, N
* ..
* .. Array Arguments ..
REAL AB( LDAB, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SLANSB returns the value of the one norm, or the Frobenius norm, or
* the infinity norm, or the element of largest absolute value of an
* n by n symmetric band matrix A, with k super-diagonals.
*
* Description
* ===========
*
* SLANSB returns the value
*
* SLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm'
* (
* ( norm1(A), NORM = '1', 'O' or 'o'
* (
* ( normI(A), NORM = 'I' or 'i'
* (
* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*
* where norm1 denotes the one norm of a matrix (maximum column sum),
* normI denotes the infinity norm of a matrix (maximum row sum) and
* normF denotes the Frobenius norm of a matrix (square root of sum of
* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies the value to be returned in SLANSB as described
* above.
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* band matrix A is supplied.
* = 'U': Upper triangular part is supplied
* = 'L': Lower triangular part is supplied
*
* N (input) INTEGER
* The order of the matrix A. N >= 0. When N = 0, SLANSB is
* set to zero.
*
* K (input) INTEGER
* The number of super-diagonals or sub-diagonals of the
* band matrix A. K >= 0.
*
* AB (input) REAL array, dimension (LDAB,N)
* The upper or lower triangle of the symmetric band matrix A,
* stored in the first K+1 rows of AB. The j-th column of A is
* stored in the j-th column of the array AB as follows:
* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= K+1.
*
* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),
* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
* WORK is not referenced.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, L
REAL ABSA, SCALE, SUM, VALUE
* ..
* .. External Subroutines ..
EXTERNAL SLASSQ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = MAX( K+2-J, 1 ), K + 1
VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1, N
DO 30 I = 1, MIN( N+1-J, K+1 )
VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
30 CONTINUE
40 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
$ ( NORM.EQ.'1' ) ) THEN
*
* Find normI(A) ( = norm1(A), since A is symmetric).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 60 J = 1, N
SUM = ZERO
L = K + 1 - J
DO 50 I = MAX( 1, J-K ), J - 1
ABSA = ABS( AB( L+I, J ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
50 CONTINUE
WORK( J ) = SUM + ABS( AB( K+1, J ) )
60 CONTINUE
DO 70 I = 1, N
VALUE = MAX( VALUE, WORK( I ) )
70 CONTINUE
ELSE
DO 80 I = 1, N
WORK( I ) = ZERO
80 CONTINUE
DO 100 J = 1, N
SUM = WORK( J ) + ABS( AB( 1, J ) )
L = 1 - J
DO 90 I = J + 1, MIN( N, J+K )
ABSA = ABS( AB( L+I, J ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
90 CONTINUE
VALUE = MAX( VALUE, SUM )
100 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
IF( K.GT.0 ) THEN
IF( LSAME( UPLO, 'U' ) ) THEN
DO 110 J = 2, N
CALL SLASSQ( MIN( J-1, K ), AB( MAX( K+2-J, 1 ), J ),
$ 1, SCALE, SUM )
110 CONTINUE
L = K + 1
ELSE
DO 120 J = 1, N - 1
CALL SLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE,
$ SUM )
120 CONTINUE
L = 1
END IF
SUM = 2*SUM
ELSE
L = 1
END IF
CALL SLASSQ( N, AB( L, 1 ), LDAB, SCALE, SUM )
VALUE = SCALE*SQRT( SUM )
END IF
*
SLANSB = VALUE
RETURN
*
* End of SLANSB
*
END
REAL FUNCTION SLANSP( NORM, UPLO, N, AP, WORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER NORM, UPLO
INTEGER N
* ..
* .. Array Arguments ..
REAL AP( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SLANSP returns the value of the one norm, or the Frobenius norm, or
* the infinity norm, or the element of largest absolute value of a
* real symmetric matrix A, supplied in packed form.
*
* Description
* ===========
*
* SLANSP returns the value
*
* SLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm'
* (
* ( norm1(A), NORM = '1', 'O' or 'o'
* (
* ( normI(A), NORM = 'I' or 'i'
* (
* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*
* where norm1 denotes the one norm of a matrix (maximum column sum),
* normI denotes the infinity norm of a matrix (maximum row sum) and
* normF denotes the Frobenius norm of a matrix (square root of sum of
* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies the value to be returned in SLANSP as described
* above.
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is supplied.
* = 'U': Upper triangular part of A is supplied
* = 'L': Lower triangular part of A is supplied
*
* N (input) INTEGER
* The order of the matrix A. N >= 0. When N = 0, SLANSP is
* set to zero.
*
* AP (input) REAL array, dimension (N*(N+1)/2)
* The upper or lower triangle of the symmetric matrix A, packed
* columnwise in a linear array. The j-th column of A is stored
* in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
*
* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),
* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
* WORK is not referenced.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, K
REAL ABSA, SCALE, SUM, VALUE
* ..
* .. External Subroutines ..
EXTERNAL SLASSQ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
K = 1
DO 20 J = 1, N
DO 10 I = K, K + J - 1
VALUE = MAX( VALUE, ABS( AP( I ) ) )
10 CONTINUE
K = K + J
20 CONTINUE
ELSE
K = 1
DO 40 J = 1, N
DO 30 I = K, K + N - J
VALUE = MAX( VALUE, ABS( AP( I ) ) )
30 CONTINUE
K = K + N - J + 1
40 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
$ ( NORM.EQ.'1' ) ) THEN
*
* Find normI(A) ( = norm1(A), since A is symmetric).
*
VALUE = ZERO
K = 1
IF( LSAME( UPLO, 'U' ) ) THEN
DO 60 J = 1, N
SUM = ZERO
DO 50 I = 1, J - 1
ABSA = ABS( AP( K ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
K = K + 1
50 CONTINUE
WORK( J ) = SUM + ABS( AP( K ) )
K = K + 1
60 CONTINUE
DO 70 I = 1, N
VALUE = MAX( VALUE, WORK( I ) )
70 CONTINUE
ELSE
DO 80 I = 1, N
WORK( I ) = ZERO
80 CONTINUE
DO 100 J = 1, N
SUM = WORK( J ) + ABS( AP( K ) )
K = K + 1
DO 90 I = J + 1, N
ABSA = ABS( AP( K ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
K = K + 1
90 CONTINUE
VALUE = MAX( VALUE, SUM )
100 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
K = 2
IF( LSAME( UPLO, 'U' ) ) THEN
DO 110 J = 2, N
CALL SLASSQ( J-1, AP( K ), 1, SCALE, SUM )
K = K + J
110 CONTINUE
ELSE
DO 120 J = 1, N - 1
CALL SLASSQ( N-J, AP( K ), 1, SCALE, SUM )
K = K + N - J + 1
120 CONTINUE
END IF
SUM = 2*SUM
K = 1
DO 130 I = 1, N
IF( AP( K ).NE.ZERO ) THEN
ABSA = ABS( AP( K ) )
IF( SCALE.LT.ABSA ) THEN
SUM = ONE + SUM*( SCALE / ABSA )**2
SCALE = ABSA
ELSE
SUM = SUM + ( ABSA / SCALE )**2
END IF
END IF
IF( LSAME( UPLO, 'U' ) ) THEN
K = K + I + 1
ELSE
K = K + N - I + 1
END IF
130 CONTINUE
VALUE = SCALE*SQRT( SUM )
END IF
*
SLANSP = VALUE
RETURN
*
* End of SLANSP
*
END
REAL FUNCTION SLANST( NORM, N, D, E )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER N
* ..
* .. Array Arguments ..
REAL D( * ), E( * )
* ..
*
* Purpose
* =======
*
* SLANST returns the value of the one norm, or the Frobenius norm, or
* the infinity norm, or the element of largest absolute value of a
* real symmetric tridiagonal matrix A.
*
* Description
* ===========
*
* SLANST returns the value
*
* SLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm'
* (
* ( norm1(A), NORM = '1', 'O' or 'o'
* (
* ( normI(A), NORM = 'I' or 'i'
* (
* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*
* where norm1 denotes the one norm of a matrix (maximum column sum),
* normI denotes the infinity norm of a matrix (maximum row sum) and
* normF denotes the Frobenius norm of a matrix (square root of sum of
* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies the value to be returned in SLANST as described
* above.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0. When N = 0, SLANST is
* set to zero.
*
* D (input) REAL array, dimension (N)
* The diagonal elements of A.
*
* E (input) REAL array, dimension (N-1)
* The (n-1) sub-diagonal or super-diagonal elements of A.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I
REAL ANORM, SCALE, SUM
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SLASSQ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
IF( N.LE.0 ) THEN
ANORM = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
ANORM = ABS( D( N ) )
DO 10 I = 1, N - 1
ANORM = MAX( ANORM, ABS( D( I ) ) )
ANORM = MAX( ANORM, ABS( E( I ) ) )
10 CONTINUE
ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR.
$ LSAME( NORM, 'I' ) ) THEN
*
* Find norm1(A).
*
IF( N.EQ.1 ) THEN
ANORM = ABS( D( 1 ) )
ELSE
ANORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ),
$ ABS( E( N-1 ) )+ABS( D( N ) ) )
DO 20 I = 2, N - 1
ANORM = MAX( ANORM, ABS( D( I ) )+ABS( E( I ) )+
$ ABS( E( I-1 ) ) )
20 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
IF( N.GT.1 ) THEN
CALL SLASSQ( N-1, E, 1, SCALE, SUM )
SUM = 2*SUM
END IF
CALL SLASSQ( N, D, 1, SCALE, SUM )
ANORM = SCALE*SQRT( SUM )
END IF
*
SLANST = ANORM
RETURN
*
* End of SLANST
*
END
REAL FUNCTION SLANSY( NORM, UPLO, N, A, LDA, WORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER NORM, UPLO
INTEGER LDA, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SLANSY returns the value of the one norm, or the Frobenius norm, or
* the infinity norm, or the element of largest absolute value of a
* real symmetric matrix A.
*
* Description
* ===========
*
* SLANSY returns the value
*
* SLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm'
* (
* ( norm1(A), NORM = '1', 'O' or 'o'
* (
* ( normI(A), NORM = 'I' or 'i'
* (
* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*
* where norm1 denotes the one norm of a matrix (maximum column sum),
* normI denotes the infinity norm of a matrix (maximum row sum) and
* normF denotes the Frobenius norm of a matrix (square root of sum of
* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies the value to be returned in SLANSY as described
* above.
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is to be referenced.
* = 'U': Upper triangular part of A is referenced
* = 'L': Lower triangular part of A is referenced
*
* N (input) INTEGER
* The order of the matrix A. N >= 0. When N = 0, SLANSY is
* set to zero.
*
* A (input) REAL array, dimension (LDA,N)
* The symmetric matrix A. If UPLO = 'U', the leading n by n
* upper triangular part of A contains the upper triangular part
* of the matrix A, and the strictly lower triangular part of A
* is not referenced. If UPLO = 'L', the leading n by n lower
* triangular part of A contains the lower triangular part of
* the matrix A, and the strictly upper triangular part of A is
* not referenced.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(N,1).
*
* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),
* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
* WORK is not referenced.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
REAL ABSA, SCALE, SUM, VALUE
* ..
* .. External Subroutines ..
EXTERNAL SLASSQ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = 1, J
VALUE = MAX( VALUE, ABS( A( I, J ) ) )
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1, N
DO 30 I = J, N
VALUE = MAX( VALUE, ABS( A( I, J ) ) )
30 CONTINUE
40 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
$ ( NORM.EQ.'1' ) ) THEN
*
* Find normI(A) ( = norm1(A), since A is symmetric).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 60 J = 1, N
SUM = ZERO
DO 50 I = 1, J - 1
ABSA = ABS( A( I, J ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
50 CONTINUE
WORK( J ) = SUM + ABS( A( J, J ) )
60 CONTINUE
DO 70 I = 1, N
VALUE = MAX( VALUE, WORK( I ) )
70 CONTINUE
ELSE
DO 80 I = 1, N
WORK( I ) = ZERO
80 CONTINUE
DO 100 J = 1, N
SUM = WORK( J ) + ABS( A( J, J ) )
DO 90 I = J + 1, N
ABSA = ABS( A( I, J ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
90 CONTINUE
VALUE = MAX( VALUE, SUM )
100 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
IF( LSAME( UPLO, 'U' ) ) THEN
DO 110 J = 2, N
CALL SLASSQ( J-1, A( 1, J ), 1, SCALE, SUM )
110 CONTINUE
ELSE
DO 120 J = 1, N - 1
CALL SLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM )
120 CONTINUE
END IF
SUM = 2*SUM
CALL SLASSQ( N, A, LDA+1, SCALE, SUM )
VALUE = SCALE*SQRT( SUM )
END IF
*
SLANSY = VALUE
RETURN
*
* End of SLANSY
*
END
REAL FUNCTION SLANTB( NORM, UPLO, DIAG, N, K, AB,
$ LDAB, WORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, NORM, UPLO
INTEGER K, LDAB, N
* ..
* .. Array Arguments ..
REAL AB( LDAB, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SLANTB returns the value of the one norm, or the Frobenius norm, or
* the infinity norm, or the element of largest absolute value of an
* n by n triangular band matrix A, with ( k + 1 ) diagonals.
*
* Description
* ===========
*
* SLANTB returns the value
*
* SLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm'
* (
* ( norm1(A), NORM = '1', 'O' or 'o'
* (
* ( normI(A), NORM = 'I' or 'i'
* (
* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*
* where norm1 denotes the one norm of a matrix (maximum column sum),
* normI denotes the infinity norm of a matrix (maximum row sum) and
* normF denotes the Frobenius norm of a matrix (square root of sum of
* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies the value to be returned in SLANTB as described
* above.
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0. When N = 0, SLANTB is
* set to zero.
*
* K (input) INTEGER
* The number of super-diagonals of the matrix A if UPLO = 'U',
* or the number of sub-diagonals of the matrix A if UPLO = 'L'.
* K >= 0.
*
* AB (input) REAL array, dimension (LDAB,N)
* The upper or lower triangular band matrix A, stored in the
* first k+1 rows of AB. The j-th column of A is stored
* in the j-th column of the array AB as follows:
* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).
* Note that when DIAG = 'U', the elements of the array AB
* corresponding to the diagonal elements of the matrix A are
* not referenced, but are assumed to be one.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= K+1.
*
* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),
* where LWORK >= N when NORM = 'I'; otherwise, WORK is not
* referenced.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UDIAG
INTEGER I, J, L
REAL SCALE, SUM, VALUE
* ..
* .. External Subroutines ..
EXTERNAL SLASSQ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
IF( LSAME( DIAG, 'U' ) ) THEN
VALUE = ONE
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = MAX( K+2-J, 1 ), K
VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1, N
DO 30 I = 2, MIN( N+1-J, K+1 )
VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
30 CONTINUE
40 CONTINUE
END IF
ELSE
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 60 J = 1, N
DO 50 I = MAX( K+2-J, 1 ), K + 1
VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
50 CONTINUE
60 CONTINUE
ELSE
DO 80 J = 1, N
DO 70 I = 1, MIN( N+1-J, K+1 )
VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
70 CONTINUE
80 CONTINUE
END IF
END IF
ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
*
* Find norm1(A).
*
VALUE = ZERO
UDIAG = LSAME( DIAG, 'U' )
IF( LSAME( UPLO, 'U' ) ) THEN
DO 110 J = 1, N
IF( UDIAG ) THEN
SUM = ONE
DO 90 I = MAX( K+2-J, 1 ), K
SUM = SUM + ABS( AB( I, J ) )
90 CONTINUE
ELSE
SUM = ZERO
DO 100 I = MAX( K+2-J, 1 ), K + 1
SUM = SUM + ABS( AB( I, J ) )
100 CONTINUE
END IF
VALUE = MAX( VALUE, SUM )
110 CONTINUE
ELSE
DO 140 J = 1, N
IF( UDIAG ) THEN
SUM = ONE
DO 120 I = 2, MIN( N+1-J, K+1 )
SUM = SUM + ABS( AB( I, J ) )
120 CONTINUE
ELSE
SUM = ZERO
DO 130 I = 1, MIN( N+1-J, K+1 )
SUM = SUM + ABS( AB( I, J ) )
130 CONTINUE
END IF
VALUE = MAX( VALUE, SUM )
140 CONTINUE
END IF
ELSE IF( LSAME( NORM, 'I' ) ) THEN
*
* Find normI(A).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
IF( LSAME( DIAG, 'U' ) ) THEN
DO 150 I = 1, N
WORK( I ) = ONE
150 CONTINUE
DO 170 J = 1, N
L = K + 1 - J
DO 160 I = MAX( 1, J-K ), J - 1
WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
160 CONTINUE
170 CONTINUE
ELSE
DO 180 I = 1, N
WORK( I ) = ZERO
180 CONTINUE
DO 200 J = 1, N
L = K + 1 - J
DO 190 I = MAX( 1, J-K ), J
WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
190 CONTINUE
200 CONTINUE
END IF
ELSE
IF( LSAME( DIAG, 'U' ) ) THEN
DO 210 I = 1, N
WORK( I ) = ONE
210 CONTINUE
DO 230 J = 1, N
L = 1 - J
DO 220 I = J + 1, MIN( N, J+K )
WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
220 CONTINUE
230 CONTINUE
ELSE
DO 240 I = 1, N
WORK( I ) = ZERO
240 CONTINUE
DO 260 J = 1, N
L = 1 - J
DO 250 I = J, MIN( N, J+K )
WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
250 CONTINUE
260 CONTINUE
END IF
END IF
DO 270 I = 1, N
VALUE = MAX( VALUE, WORK( I ) )
270 CONTINUE
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
IF( LSAME( UPLO, 'U' ) ) THEN
IF( LSAME( DIAG, 'U' ) ) THEN
SCALE = ONE
SUM = N
IF( K.GT.0 ) THEN
DO 280 J = 2, N
CALL SLASSQ( MIN( J-1, K ),
$ AB( MAX( K+2-J, 1 ), J ), 1, SCALE,
$ SUM )
280 CONTINUE
END IF
ELSE
SCALE = ZERO
SUM = ONE
DO 290 J = 1, N
CALL SLASSQ( MIN( J, K+1 ), AB( MAX( K+2-J, 1 ), J ),
$ 1, SCALE, SUM )
290 CONTINUE
END IF
ELSE
IF( LSAME( DIAG, 'U' ) ) THEN
SCALE = ONE
SUM = N
IF( K.GT.0 ) THEN
DO 300 J = 1, N - 1
CALL SLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE,
$ SUM )
300 CONTINUE
END IF
ELSE
SCALE = ZERO
SUM = ONE
DO 310 J = 1, N
CALL SLASSQ( MIN( N-J+1, K+1 ), AB( 1, J ), 1, SCALE,
$ SUM )
310 CONTINUE
END IF
END IF
VALUE = SCALE*SQRT( SUM )
END IF
*
SLANTB = VALUE
RETURN
*
* End of SLANTB
*
END
REAL FUNCTION SLANTP( NORM, UPLO, DIAG, N, AP, WORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, NORM, UPLO
INTEGER N
* ..
* .. Array Arguments ..
REAL AP( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SLANTP returns the value of the one norm, or the Frobenius norm, or
* the infinity norm, or the element of largest absolute value of a
* triangular matrix A, supplied in packed form.
*
* Description
* ===========
*
* SLANTP returns the value
*
* SLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm'
* (
* ( norm1(A), NORM = '1', 'O' or 'o'
* (
* ( normI(A), NORM = 'I' or 'i'
* (
* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*
* where norm1 denotes the one norm of a matrix (maximum column sum),
* normI denotes the infinity norm of a matrix (maximum row sum) and
* normF denotes the Frobenius norm of a matrix (square root of sum of
* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies the value to be returned in SLANTP as described
* above.
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0. When N = 0, SLANTP is
* set to zero.
*
* AP (input) REAL array, dimension (N*(N+1)/2)
* The upper or lower triangular matrix A, packed columnwise in
* a linear array. The j-th column of A is stored in the array
* AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
* Note that when DIAG = 'U', the elements of the array AP
* corresponding to the diagonal elements of the matrix A are
* not referenced, but are assumed to be one.
*
* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),
* where LWORK >= N when NORM = 'I'; otherwise, WORK is not
* referenced.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UDIAG
INTEGER I, J, K
REAL SCALE, SUM, VALUE
* ..
* .. External Subroutines ..
EXTERNAL SLASSQ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
K = 1
IF( LSAME( DIAG, 'U' ) ) THEN
VALUE = ONE
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = K, K + J - 2
VALUE = MAX( VALUE, ABS( AP( I ) ) )
10 CONTINUE
K = K + J
20 CONTINUE
ELSE
DO 40 J = 1, N
DO 30 I = K + 1, K + N - J
VALUE = MAX( VALUE, ABS( AP( I ) ) )
30 CONTINUE
K = K + N - J + 1
40 CONTINUE
END IF
ELSE
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 60 J = 1, N
DO 50 I = K, K + J - 1
VALUE = MAX( VALUE, ABS( AP( I ) ) )
50 CONTINUE
K = K + J
60 CONTINUE
ELSE
DO 80 J = 1, N
DO 70 I = K, K + N - J
VALUE = MAX( VALUE, ABS( AP( I ) ) )
70 CONTINUE
K = K + N - J + 1
80 CONTINUE
END IF
END IF
ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
*
* Find norm1(A).
*
VALUE = ZERO
K = 1
UDIAG = LSAME( DIAG, 'U' )
IF( LSAME( UPLO, 'U' ) ) THEN
DO 110 J = 1, N
IF( UDIAG ) THEN
SUM = ONE
DO 90 I = K, K + J - 2
SUM = SUM + ABS( AP( I ) )
90 CONTINUE
ELSE
SUM = ZERO
DO 100 I = K, K + J - 1
SUM = SUM + ABS( AP( I ) )
100 CONTINUE
END IF
K = K + J
VALUE = MAX( VALUE, SUM )
110 CONTINUE
ELSE
DO 140 J = 1, N
IF( UDIAG ) THEN
SUM = ONE
DO 120 I = K + 1, K + N - J
SUM = SUM + ABS( AP( I ) )
120 CONTINUE
ELSE
SUM = ZERO
DO 130 I = K, K + N - J
SUM = SUM + ABS( AP( I ) )
130 CONTINUE
END IF
K = K + N - J + 1
VALUE = MAX( VALUE, SUM )
140 CONTINUE
END IF
ELSE IF( LSAME( NORM, 'I' ) ) THEN
*
* Find normI(A).
*
K = 1
IF( LSAME( UPLO, 'U' ) ) THEN
IF( LSAME( DIAG, 'U' ) ) THEN
DO 150 I = 1, N
WORK( I ) = ONE
150 CONTINUE
DO 170 J = 1, N
DO 160 I = 1, J - 1
WORK( I ) = WORK( I ) + ABS( AP( K ) )
K = K + 1
160 CONTINUE
K = K + 1
170 CONTINUE
ELSE
DO 180 I = 1, N
WORK( I ) = ZERO
180 CONTINUE
DO 200 J = 1, N
DO 190 I = 1, J
WORK( I ) = WORK( I ) + ABS( AP( K ) )
K = K + 1
190 CONTINUE
200 CONTINUE
END IF
ELSE
IF( LSAME( DIAG, 'U' ) ) THEN
DO 210 I = 1, N
WORK( I ) = ONE
210 CONTINUE
DO 230 J = 1, N
K = K + 1
DO 220 I = J + 1, N
WORK( I ) = WORK( I ) + ABS( AP( K ) )
K = K + 1
220 CONTINUE
230 CONTINUE
ELSE
DO 240 I = 1, N
WORK( I ) = ZERO
240 CONTINUE
DO 260 J = 1, N
DO 250 I = J, N
WORK( I ) = WORK( I ) + ABS( AP( K ) )
K = K + 1
250 CONTINUE
260 CONTINUE
END IF
END IF
VALUE = ZERO
DO 270 I = 1, N
VALUE = MAX( VALUE, WORK( I ) )
270 CONTINUE
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
IF( LSAME( UPLO, 'U' ) ) THEN
IF( LSAME( DIAG, 'U' ) ) THEN
SCALE = ONE
SUM = N
K = 2
DO 280 J = 2, N
CALL SLASSQ( J-1, AP( K ), 1, SCALE, SUM )
K = K + J
280 CONTINUE
ELSE
SCALE = ZERO
SUM = ONE
K = 1
DO 290 J = 1, N
CALL SLASSQ( J, AP( K ), 1, SCALE, SUM )
K = K + J
290 CONTINUE
END IF
ELSE
IF( LSAME( DIAG, 'U' ) ) THEN
SCALE = ONE
SUM = N
K = 2
DO 300 J = 1, N - 1
CALL SLASSQ( N-J, AP( K ), 1, SCALE, SUM )
K = K + N - J + 1
300 CONTINUE
ELSE
SCALE = ZERO
SUM = ONE
K = 1
DO 310 J = 1, N
CALL SLASSQ( N-J+1, AP( K ), 1, SCALE, SUM )
K = K + N - J + 1
310 CONTINUE
END IF
END IF
VALUE = SCALE*SQRT( SUM )
END IF
*
SLANTP = VALUE
RETURN
*
* End of SLANTP
*
END
REAL FUNCTION SLANTR( NORM, UPLO, DIAG, M, N, A, LDA,
$ WORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, NORM, UPLO
INTEGER LDA, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SLANTR returns the value of the one norm, or the Frobenius norm, or
* the infinity norm, or the element of largest absolute value of a
* trapezoidal or triangular matrix A.
*
* Description
* ===========
*
* SLANTR returns the value
*
* SLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm'
* (
* ( norm1(A), NORM = '1', 'O' or 'o'
* (
* ( normI(A), NORM = 'I' or 'i'
* (
* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*
* where norm1 denotes the one norm of a matrix (maximum column sum),
* normI denotes the infinity norm of a matrix (maximum row sum) and
* normF denotes the Frobenius norm of a matrix (square root of sum of
* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies the value to be returned in SLANTR as described
* above.
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower trapezoidal.
* = 'U': Upper trapezoidal
* = 'L': Lower trapezoidal
* Note that A is triangular instead of trapezoidal if M = N.
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A has unit diagonal.
* = 'N': Non-unit diagonal
* = 'U': Unit diagonal
*
* M (input) INTEGER
* The number of rows of the matrix A. M >= 0, and if
* UPLO = 'U', M <= N. When M = 0, SLANTR is set to zero.
*
* N (input) INTEGER
* The number of columns of the matrix A. N >= 0, and if
* UPLO = 'L', N <= M. When N = 0, SLANTR is set to zero.
*
* A (input) REAL array, dimension (LDA,N)
* The trapezoidal matrix A (A is triangular if M = N).
* If UPLO = 'U', the leading m by n upper trapezoidal part of
* the array A contains the upper trapezoidal matrix, and the
* strictly lower triangular part of A is not referenced.
* If UPLO = 'L', the leading m by n lower trapezoidal part of
* the array A contains the lower trapezoidal matrix, and the
* strictly upper triangular part of A is not referenced. Note
* that when DIAG = 'U', the diagonal elements of A are not
* referenced and are assumed to be one.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(M,1).
*
* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),
* where LWORK >= M when NORM = 'I'; otherwise, WORK is not
* referenced.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UDIAG
INTEGER I, J
REAL SCALE, SUM, VALUE
* ..
* .. External Subroutines ..
EXTERNAL SLASSQ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
IF( MIN( M, N ).EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
IF( LSAME( DIAG, 'U' ) ) THEN
VALUE = ONE
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = 1, MIN( M, J-1 )
VALUE = MAX( VALUE, ABS( A( I, J ) ) )
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1, N
DO 30 I = J + 1, M
VALUE = MAX( VALUE, ABS( A( I, J ) ) )
30 CONTINUE
40 CONTINUE
END IF
ELSE
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 60 J = 1, N
DO 50 I = 1, MIN( M, J )
VALUE = MAX( VALUE, ABS( A( I, J ) ) )
50 CONTINUE
60 CONTINUE
ELSE
DO 80 J = 1, N
DO 70 I = J, M
VALUE = MAX( VALUE, ABS( A( I, J ) ) )
70 CONTINUE
80 CONTINUE
END IF
END IF
ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
*
* Find norm1(A).
*
VALUE = ZERO
UDIAG = LSAME( DIAG, 'U' )
IF( LSAME( UPLO, 'U' ) ) THEN
DO 110 J = 1, N
IF( ( UDIAG ) .AND. ( J.LE.M ) ) THEN
SUM = ONE
DO 90 I = 1, J - 1
SUM = SUM + ABS( A( I, J ) )
90 CONTINUE
ELSE
SUM = ZERO
DO 100 I = 1, MIN( M, J )
SUM = SUM + ABS( A( I, J ) )
100 CONTINUE
END IF
VALUE = MAX( VALUE, SUM )
110 CONTINUE
ELSE
DO 140 J = 1, N
IF( UDIAG ) THEN
SUM = ONE
DO 120 I = J + 1, M
SUM = SUM + ABS( A( I, J ) )
120 CONTINUE
ELSE
SUM = ZERO
DO 130 I = J, M
SUM = SUM + ABS( A( I, J ) )
130 CONTINUE
END IF
VALUE = MAX( VALUE, SUM )
140 CONTINUE
END IF
ELSE IF( LSAME( NORM, 'I' ) ) THEN
*
* Find normI(A).
*
IF( LSAME( UPLO, 'U' ) ) THEN
IF( LSAME( DIAG, 'U' ) ) THEN
DO 150 I = 1, M
WORK( I ) = ONE
150 CONTINUE
DO 170 J = 1, N
DO 160 I = 1, MIN( M, J-1 )
WORK( I ) = WORK( I ) + ABS( A( I, J ) )
160 CONTINUE
170 CONTINUE
ELSE
DO 180 I = 1, M
WORK( I ) = ZERO
180 CONTINUE
DO 200 J = 1, N
DO 190 I = 1, MIN( M, J )
WORK( I ) = WORK( I ) + ABS( A( I, J ) )
190 CONTINUE
200 CONTINUE
END IF
ELSE
IF( LSAME( DIAG, 'U' ) ) THEN
DO 210 I = 1, N
WORK( I ) = ONE
210 CONTINUE
DO 220 I = N + 1, M
WORK( I ) = ZERO
220 CONTINUE
DO 240 J = 1, N
DO 230 I = J + 1, M
WORK( I ) = WORK( I ) + ABS( A( I, J ) )
230 CONTINUE
240 CONTINUE
ELSE
DO 250 I = 1, M
WORK( I ) = ZERO
250 CONTINUE
DO 270 J = 1, N
DO 260 I = J, M
WORK( I ) = WORK( I ) + ABS( A( I, J ) )
260 CONTINUE
270 CONTINUE
END IF
END IF
VALUE = ZERO
DO 280 I = 1, M
VALUE = MAX( VALUE, WORK( I ) )
280 CONTINUE
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
IF( LSAME( UPLO, 'U' ) ) THEN
IF( LSAME( DIAG, 'U' ) ) THEN
SCALE = ONE
SUM = MIN( M, N )
DO 290 J = 2, N
CALL SLASSQ( MIN( M, J-1 ), A( 1, J ), 1, SCALE, SUM )
290 CONTINUE
ELSE
SCALE = ZERO
SUM = ONE
DO 300 J = 1, N
CALL SLASSQ( MIN( M, J ), A( 1, J ), 1, SCALE, SUM )
300 CONTINUE
END IF
ELSE
IF( LSAME( DIAG, 'U' ) ) THEN
SCALE = ONE
SUM = MIN( M, N )
DO 310 J = 1, N
CALL SLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, SCALE,
$ SUM )
310 CONTINUE
ELSE
SCALE = ZERO
SUM = ONE
DO 320 J = 1, N
CALL SLASSQ( M-J+1, A( J, J ), 1, SCALE, SUM )
320 CONTINUE
END IF
END IF
VALUE = SCALE*SQRT( SUM )
END IF
*
SLANTR = VALUE
RETURN
*
* End of SLANTR
*
END
SUBROUTINE SLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
REAL A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN
* ..
*
* Purpose
* =======
*
* SLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric
* matrix in standard form:
*
* [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ]
* [ C D ] [ SN CS ] [ CC DD ] [-SN CS ]
*
* where either
* 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or
* 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex
* conjugate eigenvalues.
*
* Arguments
* =========
*
* A (input/output) REAL
* B (input/output) REAL
* C (input/output) REAL
* D (input/output) REAL
* On entry, the elements of the input matrix.
* On exit, they are overwritten by the elements of the
* standardised Schur form.
*
* RT1R (output) REAL
* RT1I (output) REAL
* RT2R (output) REAL
* RT2I (output) REAL
* The real and imaginary parts of the eigenvalues. If the
* eigenvalues are a complex conjugate pair, RT1I > 0.
*
* CS (output) REAL
* SN (output) REAL
* Parameters of the rotation matrix.
*
* Further Details
* ===============
*
* Modified by V. Sima, Research Institute for Informatics, Bucharest,
* Romania, to reduce the risk of cancellation errors,
* when computing real eigenvalues, and to ensure, if possible, that
* abs(RT1R) >= abs(RT2R).
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0E+0, HALF = 0.5E+0, ONE = 1.0E+0 )
REAL MULTPL
PARAMETER ( MULTPL = 4.0E+0 )
* ..
* .. Local Scalars ..
REAL AA, BB, BCMAX, BCMIS, CC, CS1, DD, EPS, P, SAB,
$ SAC, SCALE, SIGMA, SN1, TAU, TEMP, Z
* ..
* .. External Functions ..
REAL SLAMCH, SLAPY2
EXTERNAL SLAMCH, SLAPY2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SIGN, SQRT
* ..
* .. Executable Statements ..
*
EPS = SLAMCH( 'P' )
IF( C.EQ.ZERO ) THEN
CS = ONE
SN = ZERO
GO TO 10
*
ELSE IF( B.EQ.ZERO ) THEN
*
* Swap rows and columns
*
CS = ZERO
SN = ONE
TEMP = D
D = A
A = TEMP
B = -C
C = ZERO
GO TO 10
ELSE IF( (A-D).EQ.ZERO .AND. SIGN( ONE, B ).NE.
$ SIGN( ONE, C ) ) THEN
CS = ONE
SN = ZERO
GO TO 10
ELSE
*
TEMP = A - D
P = HALF*TEMP
BCMAX = MAX( ABS( B ), ABS( C ) )
BCMIS = MIN( ABS( B ), ABS( C ) )*SIGN( ONE, B )*SIGN( ONE, C )
SCALE = MAX( ABS( P ), BCMAX )
Z = ( P / SCALE )*P + ( BCMAX / SCALE )*BCMIS
*
* If Z is of the order of the machine accuracy, postpone the
* decision on the nature of eigenvalues
*
IF( Z.GE.MULTPL*EPS ) THEN
*
* Real eigenvalues. Compute A and D.
*
Z = P + SIGN( SQRT( SCALE )*SQRT( Z ), P )
A = D + Z
D = D - ( BCMAX / Z )*BCMIS
*
* Compute B and the rotation matrix
*
TAU = SLAPY2( C, Z )
CS = Z / TAU
SN = C / TAU
B = B - C
C = ZERO
ELSE
*
* Complex eigenvalues, or real (almost) equal eigenvalues.
* Make diagonal elements equal.
*
SIGMA = B + C
TAU = SLAPY2( SIGMA, TEMP )
CS = SQRT( HALF*( ONE+ABS( SIGMA ) / TAU ) )
SN = -( P / ( TAU*CS ) )*SIGN( ONE, SIGMA )
*
* Compute [ AA BB ] = [ A B ] [ CS -SN ]
* [ CC DD ] [ C D ] [ SN CS ]
*
AA = A*CS + B*SN
BB = -A*SN + B*CS
CC = C*CS + D*SN
DD = -C*SN + D*CS
*
* Compute [ A B ] = [ CS SN ] [ AA BB ]
* [ C D ] [-SN CS ] [ CC DD ]
*
A = AA*CS + CC*SN
B = BB*CS + DD*SN
C = -AA*SN + CC*CS
D = -BB*SN + DD*CS
*
TEMP = HALF*( A+D )
A = TEMP
D = TEMP
*
IF( C.NE.ZERO ) THEN
IF( B.NE.ZERO ) THEN
IF( SIGN( ONE, B ).EQ.SIGN( ONE, C ) ) THEN
*
* Real eigenvalues: reduce to upper triangular form
*
SAB = SQRT( ABS( B ) )
SAC = SQRT( ABS( C ) )
P = SIGN( SAB*SAC, C )
TAU = ONE / SQRT( ABS( B+C ) )
A = TEMP + P
D = TEMP - P
B = B - C
C = ZERO
CS1 = SAB*TAU
SN1 = SAC*TAU
TEMP = CS*CS1 - SN*SN1
SN = CS*SN1 + SN*CS1
CS = TEMP
END IF
ELSE
B = -C
C = ZERO
TEMP = CS
CS = -SN
SN = TEMP
END IF
END IF
END IF
*
END IF
*
10 CONTINUE
*
* Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I).
*
RT1R = A
RT2R = D
IF( C.EQ.ZERO ) THEN
RT1I = ZERO
RT2I = ZERO
ELSE
RT1I = SQRT( ABS( B ) )*SQRT( ABS( C ) )
RT2I = -RT1I
END IF
RETURN
*
* End of SLANV2
*
END
SUBROUTINE SLAPLL( N, X, INCX, Y, INCY, SSMIN )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INCX, INCY, N
REAL SSMIN
* ..
* .. Array Arguments ..
REAL X( * ), Y( * )
* ..
*
* Purpose
* =======
*
* Given two column vectors X and Y, let
*
* A = ( X Y ).
*
* The subroutine first computes the QR factorization of A = Q*R,
* and then computes the SVD of the 2-by-2 upper triangular matrix R.
* The smaller singular value of R is returned in SSMIN, which is used
* as the measurement of the linear dependency of the vectors X and Y.
*
* Arguments
* =========
*
* N (input) INTEGER
* The length of the vectors X and Y.
*
* X (input/output) REAL array,
* dimension (1+(N-1)*INCX)
* On entry, X contains the N-vector X.
* On exit, X is overwritten.
*
* INCX (input) INTEGER
* The increment between successive elements of X. INCX > 0.
*
* Y (input/output) REAL array,
* dimension (1+(N-1)*INCY)
* On entry, Y contains the N-vector Y.
* On exit, Y is overwritten.
*
* INCY (input) INTEGER
* The increment between successive elements of Y. INCY > 0.
*
* SSMIN (output) REAL
* The smallest singular value of the N-by-2 matrix A = ( X Y ).
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
REAL A11, A12, A22, C, SSMAX, TAU
* ..
* .. External Functions ..
REAL SDOT
EXTERNAL SDOT
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SLARFG, SLAS2
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.1 ) THEN
SSMIN = ZERO
RETURN
END IF
*
* Compute the QR factorization of the N-by-2 matrix ( X Y )
*
CALL SLARFG( N, X( 1 ), X( 1+INCX ), INCX, TAU )
A11 = X( 1 )
X( 1 ) = ONE
*
C = -TAU*SDOT( N, X, INCX, Y, INCY )
CALL SAXPY( N, C, X, INCX, Y, INCY )
*
CALL SLARFG( N-1, Y( 1+INCY ), Y( 1+2*INCY ), INCY, TAU )
*
A12 = Y( 1 )
A22 = Y( 1+INCY )
*
* Compute the SVD of 2-by-2 Upper triangular matrix.
*
CALL SLAS2( A11, A12, A22, SSMIN, SSMAX )
*
RETURN
*
* End of SLAPLL
*
END
SUBROUTINE SLAPMT( FORWRD, M, N, X, LDX, K )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL FORWRD
INTEGER LDX, M, N
* ..
* .. Array Arguments ..
INTEGER K( * )
REAL X( LDX, * )
* ..
*
* Purpose
* =======
*
* SLAPMT rearranges the columns of the M by N matrix X as specified
* by the permutation K(1),K(2),...,K(N) of the integers 1,...,N.
* If FORWRD = .TRUE., forward permutation:
*
* X(*,K(J)) is moved X(*,J) for J = 1,2,...,N.
*
* If FORWRD = .FALSE., backward permutation:
*
* X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N.
*
* Arguments
* =========
*
* FORWRD (input) LOGICAL
* = .TRUE., forward permutation
* = .FALSE., backward permutation
*
* M (input) INTEGER
* The number of rows of the matrix X. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix X. N >= 0.
*
* X (input/output) REAL array, dimension (LDX,N)
* On entry, the M by N matrix X.
* On exit, X contains the permuted matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X, LDX >= MAX(1,M).
*
* K (input/output) INTEGER array, dimension (N)
* On entry, K contains the permutation vector. K is used as
* internal workspace, but reset to its original value on
* output.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, II, J, IN
REAL TEMP
* ..
* .. Executable Statements ..
*
IF( N.LE.1 )
$ RETURN
*
DO 10 I = 1, N
K( I ) = -K( I )
10 CONTINUE
*
IF( FORWRD ) THEN
*
* Forward permutation
*
DO 60 I = 1, N
*
IF( K( I ).GT.0 )
$ GO TO 40
*
J = I
K( J ) = -K( J )
IN = K( J )
*
20 CONTINUE
IF( K( IN ).GT.0 )
$ GO TO 40
*
DO 30 II = 1, M
TEMP = X( II, J )
X( II, J ) = X( II, IN )
X( II, IN ) = TEMP
30 CONTINUE
*
K( IN ) = -K( IN )
J = IN
IN = K( IN )
GO TO 20
*
40 CONTINUE
*
60 CONTINUE
*
ELSE
*
* Backward permutation
*
DO 110 I = 1, N
*
IF( K( I ).GT.0 )
$ GO TO 100
*
K( I ) = -K( I )
J = K( I )
80 CONTINUE
IF( J.EQ.I )
$ GO TO 100
*
DO 90 II = 1, M
TEMP = X( II, I )
X( II, I ) = X( II, J )
X( II, J ) = TEMP
90 CONTINUE
*
K( J ) = -K( J )
J = K( J )
GO TO 80
*
100 CONTINUE
110 CONTINUE
*
END IF
*
RETURN
*
* End of SLAPMT
*
END
REAL FUNCTION SLAPY2( X, Y )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
REAL X, Y
* ..
*
* Purpose
* =======
*
* SLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary
* overflow.
*
* Arguments
* =========
*
* X (input) REAL
* Y (input) REAL
* X and Y specify the values x and y.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
REAL ONE
PARAMETER ( ONE = 1.0E0 )
* ..
* .. Local Scalars ..
REAL 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
SLAPY2 = W
ELSE
SLAPY2 = W*SQRT( ONE+( Z / W )**2 )
END IF
RETURN
*
* End of SLAPY2
*
END
REAL FUNCTION SLAPY3( X, Y, Z )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
REAL X, Y, Z
* ..
*
* Purpose
* =======
*
* SLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause
* unnecessary overflow.
*
* Arguments
* =========
*
* X (input) REAL
* Y (input) REAL
* Z (input) REAL
* X, Y and Z specify the values x, y and z.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
REAL W, XABS, YABS, ZABS
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
XABS = ABS( X )
YABS = ABS( Y )
ZABS = ABS( Z )
W = MAX( XABS, YABS, ZABS )
IF( W.EQ.ZERO ) THEN
* W can be zero for max(0,nan,0)
* adding all three entries together will make sure
* NaN will not disappear.
SLAPY3 = XABS + YABS + ZABS
ELSE
SLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+
$ ( ZABS / W )**2 )
END IF
RETURN
*
* End of SLAPY3
*
END
SUBROUTINE SLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND,
$ AMAX, EQUED )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER EQUED
INTEGER KL, KU, LDAB, M, N
REAL AMAX, COLCND, ROWCND
* ..
* .. Array Arguments ..
REAL AB( LDAB, * ), C( * ), R( * )
* ..
*
* Purpose
* =======
*
* SLAQGB equilibrates a general M by N band matrix A with KL
* subdiagonals and KU superdiagonals using the row and scaling factors
* in the vectors R and C.
*
* 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.
*
* KL (input) INTEGER
* The number of subdiagonals within the band of A. KL >= 0.
*
* KU (input) INTEGER
* The number of superdiagonals within the band of A. KU >= 0.
*
* AB (input/output) REAL array, dimension (LDAB,N)
* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
* The j-th column of A is stored in the j-th column of the
* array AB as follows:
* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
*
* On exit, the equilibrated matrix, in the same storage format
* as A. See EQUED for the form of the equilibrated matrix.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDA >= KL+KU+1.
*
* R (input) REAL array, dimension (M)
* The row scale factors for A.
*
* C (input) REAL array, dimension (N)
* The column scale factors for A.
*
* ROWCND (input) REAL
* Ratio of the smallest R(i) to the largest R(i).
*
* COLCND (input) REAL
* Ratio of the smallest C(i) to the largest C(i).
*
* AMAX (input) REAL
* Absolute value of largest matrix entry.
*
* EQUED (output) CHARACTER*1
* Specifies the form of equilibration that was done.
* = 'N': No equilibration
* = 'R': Row equilibration, i.e., A has been premultiplied by
* diag(R).
* = 'C': Column equilibration, i.e., A has been postmultiplied
* by diag(C).
* = 'B': Both row and column equilibration, i.e., A has been
* replaced by diag(R) * A * diag(C).
*
* Internal Parameters
* ===================
*
* THRESH is a threshold value used to decide if row or column scaling
* should be done based on the ratio of the row or column scaling
* factors. If ROWCND < THRESH, row scaling is done, and if
* COLCND < THRESH, column scaling is done.
*
* LARGE and SMALL are threshold values used to decide if row scaling
* should be done based on the absolute size of the largest matrix
* element. If AMAX > LARGE or AMAX < SMALL, row scaling is done.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, THRESH
PARAMETER ( ONE = 1.0E+0, THRESH = 0.1E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
REAL CJ, LARGE, SMALL
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 ) THEN
EQUED = 'N'
RETURN
END IF
*
* Initialize LARGE and SMALL.
*
SMALL = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
LARGE = ONE / SMALL
*
IF( ROWCND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE )
$ THEN
*
* No row scaling
*
IF( COLCND.GE.THRESH ) THEN
*
* No column scaling
*
EQUED = 'N'
ELSE
*
* Column scaling
*
DO 20 J = 1, N
CJ = C( J )
DO 10 I = MAX( 1, J-KU ), MIN( M, J+KL )
AB( KU+1+I-J, J ) = CJ*AB( KU+1+I-J, J )
10 CONTINUE
20 CONTINUE
EQUED = 'C'
END IF
ELSE IF( COLCND.GE.THRESH ) THEN
*
* Row scaling, no column scaling
*
DO 40 J = 1, N
DO 30 I = MAX( 1, J-KU ), MIN( M, J+KL )
AB( KU+1+I-J, J ) = R( I )*AB( KU+1+I-J, J )
30 CONTINUE
40 CONTINUE
EQUED = 'R'
ELSE
*
* Row and column scaling
*
DO 60 J = 1, N
CJ = C( J )
DO 50 I = MAX( 1, J-KU ), MIN( M, J+KL )
AB( KU+1+I-J, J ) = CJ*R( I )*AB( KU+1+I-J, J )
50 CONTINUE
60 CONTINUE
EQUED = 'B'
END IF
*
RETURN
*
* End of SLAQGB
*
END
SUBROUTINE SLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
$ EQUED )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER EQUED
INTEGER LDA, M, N
REAL AMAX, COLCND, ROWCND
* ..
* .. Array Arguments ..
REAL A( LDA, * ), C( * ), R( * )
* ..
*
* Purpose
* =======
*
* SLAQGE equilibrates a general M by N matrix A using the row and
* column scaling factors in the vectors R and C.
*
* 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) REAL array, dimension (LDA,N)
* On entry, the M by N matrix A.
* On exit, the equilibrated matrix. See EQUED for the form of
* the equilibrated matrix.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(M,1).
*
* R (input) REAL array, dimension (M)
* The row scale factors for A.
*
* C (input) REAL array, dimension (N)
* The column scale factors for A.
*
* ROWCND (input) REAL
* Ratio of the smallest R(i) to the largest R(i).
*
* COLCND (input) REAL
* Ratio of the smallest C(i) to the largest C(i).
*
* AMAX (input) REAL
* Absolute value of largest matrix entry.
*
* EQUED (output) CHARACTER*1
* Specifies the form of equilibration that was done.
* = 'N': No equilibration
* = 'R': Row equilibration, i.e., A has been premultiplied by
* diag(R).
* = 'C': Column equilibration, i.e., A has been postmultiplied
* by diag(C).
* = 'B': Both row and column equilibration, i.e., A has been
* replaced by diag(R) * A * diag(C).
*
* Internal Parameters
* ===================
*
* THRESH is a threshold value used to decide if row or column scaling
* should be done based on the ratio of the row or column scaling
* factors. If ROWCND < THRESH, row scaling is done, and if
* COLCND < THRESH, column scaling is done.
*
* LARGE and SMALL are threshold values used to decide if row scaling
* should be done based on the absolute size of the largest matrix
* element. If AMAX > LARGE or AMAX < SMALL, row scaling is done.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, THRESH
PARAMETER ( ONE = 1.0E+0, THRESH = 0.1E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
REAL CJ, LARGE, SMALL
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 ) THEN
EQUED = 'N'
RETURN
END IF
*
* Initialize LARGE and SMALL.
*
SMALL = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
LARGE = ONE / SMALL
*
IF( ROWCND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE )
$ THEN
*
* No row scaling
*
IF( COLCND.GE.THRESH ) THEN
*
* No column scaling
*
EQUED = 'N'
ELSE
*
* Column scaling
*
DO 20 J = 1, N
CJ = C( J )
DO 10 I = 1, M
A( I, J ) = CJ*A( I, J )
10 CONTINUE
20 CONTINUE
EQUED = 'C'
END IF
ELSE IF( COLCND.GE.THRESH ) THEN
*
* Row scaling, no column scaling
*
DO 40 J = 1, N
DO 30 I = 1, M
A( I, J ) = R( I )*A( I, J )
30 CONTINUE
40 CONTINUE
EQUED = 'R'
ELSE
*
* Row and column scaling
*
DO 60 J = 1, N
CJ = C( J )
DO 50 I = 1, M
A( I, J ) = CJ*R( I )*A( I, J )
50 CONTINUE
60 CONTINUE
EQUED = 'B'
END IF
*
RETURN
*
* End of SLAQGE
*
END
SUBROUTINE SLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
$ WORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, M, N, OFFSET
* ..
* .. Array Arguments ..
INTEGER JPVT( * )
REAL A( LDA, * ), TAU( * ), VN1( * ), VN2( * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* SLAQP2 computes a QR factorization with column pivoting of
* the block A(OFFSET+1:M,1:N).
* The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.
*
* 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.
*
* OFFSET (input) INTEGER
* The number of rows of the matrix A that must be pivoted
* but no factorized. OFFSET >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, the upper triangle of block A(OFFSET+1:M,1:N) is
* the triangular factor obtained; the elements in block
* A(OFFSET+1:M,1:N) below the diagonal, together with the
* array TAU, represent the orthogonal matrix Q as a product of
* elementary reflectors. Block A(1:OFFSET,1:N) has been
* accordingly pivoted, but no factorized.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* JPVT (input/output) INTEGER array, dimension (N)
* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
* to the front of A*P (a leading column); if JPVT(i) = 0,
* the i-th column of A is a free column.
* On exit, if JPVT(i) = k, then the i-th column of A*P
* was the k-th column of A.
*
* TAU (output) REAL array, dimension (min(M,N))
* The scalar factors of the elementary reflectors.
*
* VN1 (input/output) REAL array, dimension (N)
* The vector with the partial column norms.
*
* VN2 (input/output) REAL array, dimension (N)
* The vector with the exact column norms.
*
* WORK (workspace) REAL array, dimension (N)
*
* Further Details
* ===============
*
* Based on contributions by
* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
* X. Sun, Computer Science Dept., Duke University, USA
*
* Partial column norm updating strategy modified by
* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,
* University of Zagreb, Croatia.
* June 2006.
* For more details see LAPACK Working Note 176.
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, ITEMP, J, MN, OFFPI, PVT
REAL AII, TEMP, TEMP2, TOL3Z
* ..
* .. External Subroutines ..
EXTERNAL SLARF, SLARFG, SSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. External Functions ..
INTEGER ISAMAX
REAL SLAMCH, SNRM2
EXTERNAL ISAMAX, SLAMCH, SNRM2
* ..
* .. Executable Statements ..
*
MN = MIN( M-OFFSET, N )
TOL3Z = SQRT(SLAMCH('Epsilon'))
*
* Compute factorization.
*
DO 20 I = 1, MN
*
OFFPI = OFFSET + I
*
* Determine ith pivot column and swap if necessary.
*
PVT = ( I-1 ) + ISAMAX( N-I+1, VN1( I ), 1 )
*
IF( PVT.NE.I ) THEN
CALL SSWAP( 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 SLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1,
$ TAU( I ) )
ELSE
CALL SLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) )
END IF
*
IF( I.LT.N ) THEN
*
* Apply H(i)' to A(offset+i:m,i+1:n) from the left.
*
AII = A( OFFPI, I )
A( OFFPI, I ) = ONE
CALL SLARF( '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 ) = SNRM2( 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 SLAQP2
*
END
SUBROUTINE SLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1,
$ VN2, AUXV, F, LDF )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KB, LDA, LDF, M, N, NB, OFFSET
* ..
* .. Array Arguments ..
INTEGER JPVT( * )
REAL A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ),
$ VN1( * ), VN2( * )
* ..
*
* Purpose
* =======
*
* SLAQPS computes a step of QR factorization with column pivoting
* of a real M-by-N matrix A by using Blas-3. It tries to factorize
* NB columns from A starting from the row OFFSET+1, and updates all
* of the matrix with Blas-3 xGEMM.
*
* In some cases, due to catastrophic cancellations, it cannot
* factorize NB columns. Hence, the actual number of factorized
* columns is returned in KB.
*
* Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.
*
* 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
*
* OFFSET (input) INTEGER
* The number of rows of A that have been factorized in
* previous steps.
*
* NB (input) INTEGER
* The number of columns to factorize.
*
* KB (output) INTEGER
* The number of columns actually factorized.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, block A(OFFSET+1:M,1:KB) is the triangular
* factor obtained and block A(1:OFFSET,1:N) has been
* accordingly pivoted, but no factorized.
* The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has
* been updated.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* JPVT (input/output) INTEGER array, dimension (N)
* JPVT(I) = K <==> Column K of the full matrix A has been
* permuted into position I in AP.
*
* TAU (output) REAL array, dimension (KB)
* The scalar factors of the elementary reflectors.
*
* VN1 (input/output) REAL array, dimension (N)
* The vector with the partial column norms.
*
* VN2 (input/output) REAL array, dimension (N)
* The vector with the exact column norms.
*
* AUXV (input/output) REAL array, dimension (NB)
* Auxiliar vector.
*
* F (input/output) REAL array, dimension (LDF,NB)
* Matrix F' = L*Y'*A.
*
* LDF (input) INTEGER
* The leading dimension of the array F. LDF >= max(1,N).
*
* Further Details
* ===============
*
* Based on contributions by
* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
* X. Sun, Computer Science Dept., Duke University, USA
*
* Partial column norm updating strategy modified by
* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,
* University of Zagreb, Croatia.
* June 2006.
* For more details see LAPACK Working Note 176.
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER ITEMP, J, K, LASTRK, LSTICC, PVT, RK
REAL AKK, TEMP, TEMP2, TOL3Z
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SGEMV, SLARFG, SSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, NINT, REAL, SQRT
* ..
* .. External Functions ..
INTEGER ISAMAX
REAL SLAMCH, SNRM2
EXTERNAL ISAMAX, SLAMCH, SNRM2
* ..
* .. Executable Statements ..
*
LASTRK = MIN( M, N+OFFSET )
LSTICC = 0
K = 0
TOL3Z = SQRT(SLAMCH('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 ) + ISAMAX( N-K+1, VN1( K ), 1 )
IF( PVT.NE.K ) THEN
CALL SSWAP( M, A( 1, PVT ), 1, A( 1, K ), 1 )
CALL SSWAP( 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)'.
*
IF( K.GT.1 ) THEN
CALL SGEMV( '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 SLARFG( M-RK+1, A( RK, K ), A( RK+1, K ), 1, TAU( K ) )
ELSE
CALL SLARFG( 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)'*A(RK:M,K).
*
IF( K.LT.N ) THEN
CALL SGEMV( '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)'
* *A(RK:M,K).
*
IF( K.GT.1 ) THEN
CALL SGEMV( 'Transpose', M-RK+1, K-1, -TAU( K ), A( RK, 1 ),
$ LDA, A( RK, K ), 1, ZERO, AUXV( 1 ), 1 )
*
CALL SGEMV( '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)'.
*
IF( K.LT.N ) THEN
CALL SGEMV( '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 ) = REAL( 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)'.
*
IF( KB.LT.MIN( N, M-OFFSET ) ) THEN
CALL SGEMM( '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 ) = SNRM2( 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 SLAQPS
*
END
SUBROUTINE SLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
$ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
REAL H( LDH, * ), WI( * ), WORK( * ), WR( * ),
$ Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SLAQR0 computes the eigenvalues of a Hessenberg matrix H
* and, optionally, the matrices T and Z from the Schur decomposition
* H = Z T Z**T, where T is an upper quasi-triangular matrix (the
* Schur form), and Z is the orthogonal matrix of Schur vectors.
*
* Optionally Z may be postmultiplied into an input orthogonal
* matrix Q so that this routine can give the Schur factorization
* of a matrix A which has been reduced to the Hessenberg form H
* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.
*
* Arguments
* =========
*
* WANTT (input) LOGICAL
* = .TRUE. : the full Schur form T is required;
* = .FALSE.: only eigenvalues are required.
*
* WANTZ (input) LOGICAL
* = .TRUE. : the matrix of Schur vectors Z is required;
* = .FALSE.: Schur vectors are not required.
*
* N (input) INTEGER
* The order of the matrix H. N .GE. 0.
*
* 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 and, if ILO.GT.1,
* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a
* previous call to SGEBAL, and then passed to SGEHRD when the
* matrix output by SGEBAL is reduced to Hessenberg form.
* Otherwise, ILO and IHI should be set to 1 and N,
* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
* If N = 0, then ILO = 1 and IHI = 0.
*
* H (input/output) REAL array, dimension (LDH,N)
* On entry, the upper Hessenberg matrix H.
* On exit, if INFO = 0 and WANTT is .TRUE., then H contains
* the upper quasi-triangular matrix T from the Schur
* decomposition (the Schur form); 2-by-2 diagonal blocks
* (corresponding to complex conjugate pairs of eigenvalues)
* are returned in standard form, with H(i,i) = H(i+1,i+1)
* and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is
* .FALSE., then the contents of H are unspecified on exit.
* (The output value of H when INFO.GT.0 is given under the
* description of INFO below.)
*
* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and
* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.
*
* LDH (input) INTEGER
* The leading dimension of the array H. LDH .GE. max(1,N).
*
* WR (output) REAL array, dimension (IHI)
* WI (output) REAL array, dimension (IHI)
* The real and imaginary parts, respectively, of the computed
* eigenvalues of H(ILO:IHI,ILO:IHI) are stored WR(ILO:IHI)
* and WI(ILO:IHI). If two eigenvalues are computed as a
* complex conjugate pair, they are stored in consecutive
* elements of WR and WI, say the i-th and (i+1)th, with
* WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then
* the eigenvalues are stored in the same order as on the
* diagonal of the Schur form returned in H, with
* WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal
* block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and
* WI(i+1) = -WI(i).
*
* ILOZ (input) INTEGER
* IHIZ (input) INTEGER
* Specify the rows of Z to which transformations must be
* applied if WANTZ is .TRUE..
* 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.
*
* Z (input/output) REAL array, dimension (LDZ,IHI)
* If WANTZ is .FALSE., then Z is not referenced.
* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is
* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the
* orthogonal Schur factor of H(ILO:IHI,ILO:IHI).
* (The output value of Z when INFO.GT.0 is given under
* the description of INFO below.)
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. if WANTZ is .TRUE.
* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.
*
* WORK (workspace/output) REAL array, dimension LWORK
* On exit, if LWORK = -1, WORK(1) returns an estimate of
* the optimal value for LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK. LWORK .GE. max(1,N)
* is sufficient, but LWORK typically as large as 6*N may
* be required for optimal performance. A workspace query
* to determine the optimal workspace size is recommended.
*
* If LWORK = -1, then SLAQR0 does a workspace query.
* In this case, SLAQR0 checks the input parameters and
* estimates the optimal workspace size for the given
* values of N, ILO and IHI. The estimate is returned
* in WORK(1). No error message related to LWORK is
* issued by XERBLA. Neither H nor Z are accessed.
*
*
* INFO (output) INTEGER
* = 0: successful exit
* .GT. 0: if INFO = i, SLAQR0 failed to compute all of
* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
* and WI contain those eigenvalues which have been
* successfully computed. (Failures are rare.)
*
* If INFO .GT. 0 and WANT is .FALSE., then on exit,
* the remaining unconverged eigenvalues are the eigen-
* values of the upper Hessenberg matrix rows and
* columns ILO through INFO of the final, output
* value of H.
*
* If INFO .GT. 0 and WANTT is .TRUE., then on exit
*
* (*) (initial value of H)*U = U*(final value of H)
*
* where U is an orthogonal matrix. The final
* value of H is upper Hessenberg and quasi-triangular
* in rows and columns INFO+1 through IHI.
*
* If INFO .GT. 0 and WANTZ is .TRUE., then on exit
*
* (final value of Z(ILO:IHI,ILOZ:IHIZ)
* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U
*
* where U is the orthogonal matrix in (*) (regard-
* less of the value of WANTT.)
*
* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not
* accessed.
*
* ================================================================
* Based on contributions by
* Karen Braman and Ralph Byers, Department of Mathematics,
* University of Kansas, USA
*
* ================================================================
* References:
* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
* Performance, SIAM Journal of Matrix Analysis, volume 23, pages
* 929--947, 2002.
*
* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
* Algorithm Part II: Aggressive Early Deflation, SIAM Journal
* of Matrix Analysis, volume 23, pages 948--973, 2002.
*
* ================================================================
* .. Parameters ..
*
* ==== Matrices of order NTINY or smaller must be processed by
* . SLAHQR because of insufficient subdiagonal scratch space.
* . (This is a hard limit.) ====
*
* ==== Exceptional deflation windows: try to cure rare
* . slow convergence by increasing the size of the
* . deflation window after KEXNW iterations. =====
*
* ==== Exceptional shifts: try to cure rare slow convergence
* . with ad-hoc exceptional shifts every KEXSH iterations.
* . The constants WILK1 and WILK2 are used to form the
* . exceptional shifts. ====
*
INTEGER NTINY
PARAMETER ( NTINY = 11 )
INTEGER KEXNW, KEXSH
PARAMETER ( KEXNW = 5, KEXSH = 6 )
REAL WILK1, WILK2
PARAMETER ( WILK1 = 0.75e0, WILK2 = -0.4375e0 )
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0 )
* ..
* .. Local Scalars ..
REAL AA, BB, CC, CS, DD, SN, SS, SWAP
INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS,
$ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS,
$ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX,
$ NSR, NVE, NW, NWMAX, NWR
LOGICAL NWINC, SORTED
CHARACTER JBCMPZ*2
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Local Arrays ..
REAL ZDUM( 1, 1 )
* ..
* .. External Subroutines ..
EXTERNAL SLACPY, SLAHQR, SLANV2, SLAQR3, SLAQR4, SLAQR5
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, MAX, MIN, MOD, REAL
* ..
* .. Executable Statements ..
INFO = 0
*
* ==== Quick return for N = 0: nothing to do. ====
*
IF( N.EQ.0 ) THEN
WORK( 1 ) = ONE
RETURN
END IF
*
* ==== Set up job flags for ILAENV. ====
*
IF( WANTT ) THEN
JBCMPZ( 1: 1 ) = 'S'
ELSE
JBCMPZ( 1: 1 ) = 'E'
END IF
IF( WANTZ ) THEN
JBCMPZ( 2: 2 ) = 'V'
ELSE
JBCMPZ( 2: 2 ) = 'N'
END IF
*
* ==== Tiny matrices must use SLAHQR. ====
*
IF( N.LE.NTINY ) THEN
*
* ==== Estimate optimal workspace. ====
*
LWKOPT = 1
IF( LWORK.NE.-1 )
$ CALL SLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
$ ILOZ, IHIZ, Z, LDZ, INFO )
ELSE
*
* ==== Use small bulge multi-shift QR with aggressive early
* . deflation on larger-than-tiny matrices. ====
*
* ==== Hope for the best. ====
*
INFO = 0
*
* ==== NWR = recommended deflation window size. At this
* . point, N .GT. NTINY = 11, so there is enough
* . subdiagonal workspace for NWR.GE.2 as required.
* . (In fact, there is enough subdiagonal space for
* . NWR.GE.3.) ====
*
NWR = ILAENV( 13, 'SLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
NWR = MAX( 2, NWR )
NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR )
NW = NWR
*
* ==== NSR = recommended number of simultaneous shifts.
* . At this point N .GT. NTINY = 11, so there is at
* . enough subdiagonal workspace for NSR to be even
* . and greater than or equal to two as required. ====
*
NSR = ILAENV( 15, 'SLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO )
NSR = MAX( 2, NSR-MOD( NSR, 2 ) )
*
* ==== Estimate optimal workspace ====
*
* ==== Workspace query call to SLAQR3 ====
*
CALL SLAQR3( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ,
$ IHIZ, Z, LDZ, LS, LD, WR, WI, H, LDH, N, H, LDH,
$ N, H, LDH, WORK, -1 )
*
* ==== Optimal workspace = MAX(SLAQR5, SLAQR3) ====
*
LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) )
*
* ==== Quick return in case of workspace query. ====
*
IF( LWORK.EQ.-1 ) THEN
WORK( 1 ) = REAL( LWKOPT )
RETURN
END IF
*
* ==== SLAHQR/SLAQR0 crossover point ====
*
NMIN = ILAENV( 12, 'SLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
NMIN = MAX( NTINY, NMIN )
*
* ==== Nibble crossover point ====
*
NIBBLE = ILAENV( 14, 'SLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
NIBBLE = MAX( 0, NIBBLE )
*
* ==== Accumulate reflections during ttswp? Use block
* . 2-by-2 structure during matrix-matrix multiply? ====
*
KACC22 = ILAENV( 16, 'SLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
KACC22 = MAX( 0, KACC22 )
KACC22 = MIN( 2, KACC22 )
*
* ==== NWMAX = the largest possible deflation window for
* . which there is sufficient workspace. ====
*
NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 )
*
* ==== NSMAX = the Largest number of simultaneous shifts
* . for which there is sufficient workspace. ====
*
NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 )
NSMAX = NSMAX - MOD( NSMAX, 2 )
*
* ==== NDFL: an iteration count restarted at deflation. ====
*
NDFL = 1
*
* ==== ITMAX = iteration limit ====
*
ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) )
*
* ==== Last row and column in the active block ====
*
KBOT = IHI
*
* ==== Main Loop ====
*
DO 80 IT = 1, ITMAX
*
* ==== Done when KBOT falls below ILO ====
*
IF( KBOT.LT.ILO )
$ GO TO 90
*
* ==== Locate active block ====
*
DO 10 K = KBOT, ILO + 1, -1
IF( H( K, K-1 ).EQ.ZERO )
$ GO TO 20
10 CONTINUE
K = ILO
20 CONTINUE
KTOP = K
*
* ==== Select deflation window size ====
*
NH = KBOT - KTOP + 1
IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN
*
* ==== Typical deflation window. If possible and
* . advisable, nibble the entire active block.
* . If not, use size NWR or NWR+1 depending upon
* . which has the smaller corresponding subdiagonal
* . entry (a heuristic). ====
*
NWINC = .TRUE.
IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN
NW = NH
ELSE
NW = MIN( NWR, NH, NWMAX )
IF( NW.LT.NWMAX ) THEN
IF( NW.GE.NH-1 ) THEN
NW = NH
ELSE
KWTOP = KBOT - NW + 1
IF( ABS( H( KWTOP, KWTOP-1 ) ).GT.
$ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1
END IF
END IF
END IF
ELSE
*
* ==== Exceptional deflation window. If there have
* . been no deflations in KEXNW or more iterations,
* . then vary the deflation window size. At first,
* . because, larger windows are, in general, more
* . powerful than smaller ones, rapidly increase the
* . window up to the maximum reasonable and possible.
* . Then maybe try a slightly smaller window. ====
*
IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN
NW = MIN( NWMAX, NH, 2*NW )
ELSE
NWINC = .FALSE.
IF( NW.EQ.NH .AND. NH.GT.2 )
$ NW = NH - 1
END IF
END IF
*
* ==== Aggressive early deflation:
* . split workspace under the subdiagonal into
* . - an nw-by-nw work array V in the lower
* . left-hand-corner,
* . - an NW-by-at-least-NW-but-more-is-better
* . (NW-by-NHO) horizontal work array along
* . the bottom edge,
* . - an at-least-NW-but-more-is-better (NHV-by-NW)
* . vertical work array along the left-hand-edge.
* . ====
*
KV = N - NW + 1
KT = NW + 1
NHO = ( N-NW-1 ) - KT + 1
KWV = NW + 2
NVE = ( N-NW ) - KWV + 1
*
* ==== Aggressive early deflation ====
*
CALL SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
$ IHIZ, Z, LDZ, LS, LD, WR, WI, H( KV, 1 ), LDH,
$ NHO, H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH,
$ WORK, LWORK )
*
* ==== Adjust KBOT accounting for new deflations. ====
*
KBOT = KBOT - LD
*
* ==== KS points to the shifts. ====
*
KS = KBOT - LS + 1
*
* ==== Skip an expensive QR sweep if there is a (partly
* . heuristic) reason to expect that many eigenvalues
* . will deflate without it. Here, the QR sweep is
* . skipped if many eigenvalues have just been deflated
* . or if the remaining active block is small.
*
IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT-
$ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN
*
* ==== NS = nominal number of simultaneous shifts.
* . This may be lowered (slightly) if SLAQR3
* . did not provide that many shifts. ====
*
NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) )
NS = NS - MOD( NS, 2 )
*
* ==== If there have been no deflations
* . in a multiple of KEXSH iterations,
* . then try exceptional shifts.
* . Otherwise use shifts provided by
* . SLAQR3 above or from the eigenvalues
* . of a trailing principal submatrix. ====
*
IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN
KS = KBOT - NS + 1
DO 30 I = KBOT, MAX( KS+1, KTOP+2 ), -2
SS = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) )
AA = WILK1*SS + H( I, I )
BB = SS
CC = WILK2*SS
DD = AA
CALL SLANV2( AA, BB, CC, DD, WR( I-1 ), WI( I-1 ),
$ WR( I ), WI( I ), CS, SN )
30 CONTINUE
IF( KS.EQ.KTOP ) THEN
WR( KS+1 ) = H( KS+1, KS+1 )
WI( KS+1 ) = ZERO
WR( KS ) = WR( KS+1 )
WI( KS ) = WI( KS+1 )
END IF
ELSE
*
* ==== Got NS/2 or fewer shifts? Use SLAQR4 or
* . SLAHQR on a trailing principal submatrix to
* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9,
* . there is enough space below the subdiagonal
* . to fit an NS-by-NS scratch array.) ====
*
IF( KBOT-KS+1.LE.NS / 2 ) THEN
KS = KBOT - NS + 1
KT = N - NS + 1
CALL SLACPY( 'A', NS, NS, H( KS, KS ), LDH,
$ H( KT, 1 ), LDH )
IF( NS.GT.NMIN ) THEN
CALL SLAQR4( .false., .false., NS, 1, NS,
$ H( KT, 1 ), LDH, WR( KS ),
$ WI( KS ), 1, 1, ZDUM, 1, WORK,
$ LWORK, INF )
ELSE
CALL SLAHQR( .false., .false., NS, 1, NS,
$ H( KT, 1 ), LDH, WR( KS ),
$ WI( KS ), 1, 1, ZDUM, 1, INF )
END IF
KS = KS + INF
*
* ==== In case of a rare QR failure use
* . eigenvalues of the trailing 2-by-2
* . principal submatrix. ====
*
IF( KS.GE.KBOT ) THEN
AA = H( KBOT-1, KBOT-1 )
CC = H( KBOT, KBOT-1 )
BB = H( KBOT-1, KBOT )
DD = H( KBOT, KBOT )
CALL SLANV2( AA, BB, CC, DD, WR( KBOT-1 ),
$ WI( KBOT-1 ), WR( KBOT ),
$ WI( KBOT ), CS, SN )
KS = KBOT - 1
END IF
END IF
*
IF( KBOT-KS+1.GT.NS ) THEN
*
* ==== Sort the shifts (Helps a little)
* . Bubble sort keeps complex conjugate
* . pairs together. ====
*
SORTED = .false.
DO 50 K = KBOT, KS + 1, -1
IF( SORTED )
$ GO TO 60
SORTED = .true.
DO 40 I = KS, K - 1
IF( ABS( WR( I ) )+ABS( WI( I ) ).LT.
$ ABS( WR( I+1 ) )+ABS( WI( I+1 ) ) ) THEN
SORTED = .false.
*
SWAP = WR( I )
WR( I ) = WR( I+1 )
WR( I+1 ) = SWAP
*
SWAP = WI( I )
WI( I ) = WI( I+1 )
WI( I+1 ) = SWAP
END IF
40 CONTINUE
50 CONTINUE
60 CONTINUE
END IF
*
* ==== Shuffle shifts into pairs of real shifts
* . and pairs of complex conjugate shifts
* . assuming complex conjugate shifts are
* . already adjacent to one another. (Yes,
* . they are.) ====
*
DO 70 I = KBOT, KS + 2, -2
IF( WI( I ).NE.-WI( I-1 ) ) THEN
*
SWAP = WR( I )
WR( I ) = WR( I-1 )
WR( I-1 ) = WR( I-2 )
WR( I-2 ) = SWAP
*
SWAP = WI( I )
WI( I ) = WI( I-1 )
WI( I-1 ) = WI( I-2 )
WI( I-2 ) = SWAP
END IF
70 CONTINUE
END IF
*
* ==== If there are only two shifts and both are
* . real, then use only one. ====
*
IF( KBOT-KS+1.EQ.2 ) THEN
IF( WI( KBOT ).EQ.ZERO ) THEN
IF( ABS( WR( KBOT )-H( KBOT, KBOT ) ).LT.
$ ABS( WR( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN
WR( KBOT-1 ) = WR( KBOT )
ELSE
WR( KBOT ) = WR( KBOT-1 )
END IF
END IF
END IF
*
* ==== Use up to NS of the the smallest magnatiude
* . shifts. If there aren't NS shifts available,
* . then use them all, possibly dropping one to
* . make the number of shifts even. ====
*
NS = MIN( NS, KBOT-KS+1 )
NS = NS - MOD( NS, 2 )
KS = KBOT - NS + 1
*
* ==== Small-bulge multi-shift QR sweep:
* . split workspace under the subdiagonal into
* . - a KDU-by-KDU work array U in the lower
* . left-hand-corner,
* . - a KDU-by-at-least-KDU-but-more-is-better
* . (KDU-by-NHo) horizontal work array WH along
* . the bottom edge,
* . - and an at-least-KDU-but-more-is-better-by-KDU
* . (NVE-by-KDU) vertical work WV arrow along
* . the left-hand-edge. ====
*
KDU = 3*NS - 3
KU = N - KDU + 1
KWH = KDU + 1
NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1
KWV = KDU + 4
NVE = N - KDU - KWV + 1
*
* ==== Small-bulge multi-shift QR sweep ====
*
CALL SLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS,
$ WR( KS ), WI( KS ), H, LDH, ILOZ, IHIZ, Z,
$ LDZ, WORK, 3, H( KU, 1 ), LDH, NVE,
$ H( KWV, 1 ), LDH, NHO, H( KU, KWH ), LDH )
END IF
*
* ==== Note progress (or the lack of it). ====
*
IF( LD.GT.0 ) THEN
NDFL = 1
ELSE
NDFL = NDFL + 1
END IF
*
* ==== End of main loop ====
80 CONTINUE
*
* ==== Iteration limit exceeded. Set INFO to show where
* . the problem occurred and exit. ====
*
INFO = KBOT
90 CONTINUE
END IF
*
* ==== Return the optimal value of LWORK. ====
*
WORK( 1 ) = REAL( LWKOPT )
*
* ==== End of SLAQR0 ====
*
END
SUBROUTINE SLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
REAL SI1, SI2, SR1, SR2
INTEGER LDH, N
* ..
* .. Array Arguments ..
REAL H( LDH, * ), V( * )
* ..
*
* Given a 2-by-2 or 3-by-3 matrix H, SLAQR1 sets v to a
* scalar multiple of the first column of the product
*
* (*) K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I)
*
* scaling to avoid overflows and most underflows. It
* is assumed that either
*
* 1) sr1 = sr2 and si1 = -si2
* or
* 2) si1 = si2 = 0.
*
* This is useful for starting double implicit shift bulges
* in the QR algorithm.
*
*
* N (input) integer
* Order of the matrix H. N must be either 2 or 3.
*
* H (input) REAL array of dimension (LDH,N)
* The 2-by-2 or 3-by-3 matrix H in (*).
*
* LDH (input) integer
* The leading dimension of H as declared in
* the calling procedure. LDH.GE.N
*
* SR1 (input) REAL
* SI1 The shifts in (*).
* SR2
* SI2
*
* V (output) REAL array of dimension N
* A scalar multiple of the first column of the
* matrix K in (*).
*
* ================================================================
* Based on contributions by
* Karen Braman and Ralph Byers, Department of Mathematics,
* University of Kansas, USA
*
* ================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0e0 )
* ..
* .. Local Scalars ..
REAL H21S, H31S, S
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
IF( N.EQ.2 ) THEN
S = ABS( H( 1, 1 )-SR2 ) + ABS( SI2 ) + ABS( H( 2, 1 ) )
IF( S.EQ.ZERO ) THEN
V( 1 ) = ZERO
V( 2 ) = ZERO
ELSE
H21S = H( 2, 1 ) / S
V( 1 ) = H21S*H( 1, 2 ) + ( H( 1, 1 )-SR1 )*
$ ( ( H( 1, 1 )-SR2 ) / S ) - SI1*( SI2 / S )
V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-SR1-SR2 )
END IF
ELSE
S = ABS( H( 1, 1 )-SR2 ) + ABS( SI2 ) + ABS( H( 2, 1 ) ) +
$ ABS( H( 3, 1 ) )
IF( S.EQ.ZERO ) THEN
V( 1 ) = ZERO
V( 2 ) = ZERO
V( 3 ) = ZERO
ELSE
H21S = H( 2, 1 ) / S
H31S = H( 3, 1 ) / S
V( 1 ) = ( H( 1, 1 )-SR1 )*( ( H( 1, 1 )-SR2 ) / S ) -
$ SI1*( SI2 / S ) + H( 1, 2 )*H21S + H( 1, 3 )*H31S
V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-SR1-SR2 ) +
$ H( 2, 3 )*H31S
V( 3 ) = H31S*( H( 1, 1 )+H( 3, 3 )-SR1-SR2 ) +
$ H21S*H( 3, 2 )
END IF
END IF
END
SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
$ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T,
$ LDT, NV, WV, LDWV, WORK, LWORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
$ LDZ, LWORK, N, ND, NH, NS, NV, NW
LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
REAL H( LDH, * ), SI( * ), SR( * ), T( LDT, * ),
$ V( LDV, * ), WORK( * ), WV( LDWV, * ),
$ Z( LDZ, * )
* ..
*
* This subroutine is identical to SLAQR3 except that it avoids
* recursion by calling SLAHQR instead of SLAQR4.
*
*
* ******************************************************************
* Aggressive early deflation:
*
* This subroutine accepts as input an upper Hessenberg matrix
* H and performs an orthogonal similarity transformation
* designed to detect and deflate fully converged eigenvalues from
* a trailing principal submatrix. On output H has been over-
* written by a new Hessenberg matrix that is a perturbation of
* an orthogonal similarity transformation of H. It is to be
* hoped that the final version of H has many zero subdiagonal
* entries.
*
* ******************************************************************
* WANTT (input) LOGICAL
* If .TRUE., then the Hessenberg matrix H is fully updated
* so that the quasi-triangular Schur factor may be
* computed (in cooperation with the calling subroutine).
* If .FALSE., then only enough of H is updated to preserve
* the eigenvalues.
*
* WANTZ (input) LOGICAL
* If .TRUE., then the orthogonal matrix Z is updated so
* so that the orthogonal Schur factor may be computed
* (in cooperation with the calling subroutine).
* If .FALSE., then Z is not referenced.
*
* N (input) INTEGER
* The order of the matrix H and (if WANTZ is .TRUE.) the
* order of the orthogonal matrix Z.
*
* KTOP (input) INTEGER
* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.
* KBOT and KTOP together determine an isolated block
* along the diagonal of the Hessenberg matrix.
*
* KBOT (input) INTEGER
* It is assumed without a check that either
* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together
* determine an isolated block along the diagonal of the
* Hessenberg matrix.
*
* NW (input) INTEGER
* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).
*
* H (input/output) REAL array, dimension (LDH,N)
* On input the initial N-by-N section of H stores the
* Hessenberg matrix undergoing aggressive early deflation.
* On output H has been transformed by an orthogonal
* similarity transformation, perturbed, and the returned
* to Hessenberg form that (it is to be hoped) has some
* zero subdiagonal entries.
*
* LDH (input) integer
* Leading dimension of H just as declared in the calling
* subroutine. N .LE. LDH
*
* ILOZ (input) INTEGER
* IHIZ (input) INTEGER
* Specify the rows of Z to which transformations must be
* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.
*
* Z (input/output) REAL array, dimension (LDZ,IHI)
* IF WANTZ is .TRUE., then on output, the orthogonal
* similarity transformation mentioned above has been
* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.
* If WANTZ is .FALSE., then Z is unreferenced.
*
* LDZ (input) integer
* The leading dimension of Z just as declared in the
* calling subroutine. 1 .LE. LDZ.
*
* NS (output) integer
* The number of unconverged (ie approximate) eigenvalues
* returned in SR and SI that may be used as shifts by the
* calling subroutine.
*
* ND (output) integer
* The number of converged eigenvalues uncovered by this
* subroutine.
*
* SR (output) REAL array, dimension KBOT
* SI (output) REAL array, dimension KBOT
* On output, the real and imaginary parts of approximate
* eigenvalues that may be used for shifts are stored in
* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and
* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.
* The real and imaginary parts of converged eigenvalues
* are stored in SR(KBOT-ND+1) through SR(KBOT) and
* SI(KBOT-ND+1) through SI(KBOT), respectively.
*
* V (workspace) REAL array, dimension (LDV,NW)
* An NW-by-NW work array.
*
* LDV (input) integer scalar
* The leading dimension of V just as declared in the
* calling subroutine. NW .LE. LDV
*
* NH (input) integer scalar
* The number of columns of T. NH.GE.NW.
*
* T (workspace) REAL array, dimension (LDT,NW)
*
* LDT (input) integer
* The leading dimension of T just as declared in the
* calling subroutine. NW .LE. LDT
*
* NV (input) integer
* The number of rows of work array WV available for
* workspace. NV.GE.NW.
*
* WV (workspace) REAL array, dimension (LDWV,NW)
*
* LDWV (input) integer
* The leading dimension of W just as declared in the
* calling subroutine. NW .LE. LDV
*
* WORK (workspace) REAL array, dimension LWORK.
* On exit, WORK(1) is set to an estimate of the optimal value
* of LWORK for the given values of N, NW, KTOP and KBOT.
*
* LWORK (input) integer
* The dimension of the work array WORK. LWORK = 2*NW
* suffices, but greater efficiency may result from larger
* values of LWORK.
*
* If LWORK = -1, then a workspace query is assumed; SLAQR2
* only estimates the optimal workspace size for the given
* values of N, NW, KTOP and KBOT. The estimate is returned
* in WORK(1). No error message related to LWORK is issued
* by XERBLA. Neither H nor Z are accessed.
*
* ================================================================
* Based on contributions by
* Karen Braman and Ralph Byers, Department of Mathematics,
* University of Kansas, USA
*
* ==================================================================
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0 )
* ..
* .. Local Scalars ..
REAL AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S,
$ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP
INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL,
$ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2,
$ LWKOPT
LOGICAL BULGE, SORTED
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEHRD, SGEMM, SLABAD, SLACPY, SLAHQR,
$ SLANV2, SLARF, SLARFG, SLASET, SORGHR, STREXC
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, MAX, MIN, REAL, SQRT
* ..
* .. Executable Statements ..
*
* ==== Estimate optimal workspace. ====
*
JW = MIN( NW, KBOT-KTOP+1 )
IF( JW.LE.2 ) THEN
LWKOPT = 1
ELSE
*
* ==== Workspace query call to SGEHRD ====
*
CALL SGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
LWK1 = INT( WORK( 1 ) )
*
* ==== Workspace query call to SORGHR ====
*
CALL SORGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
LWK2 = INT( WORK( 1 ) )
*
* ==== Optimal workspace ====
*
LWKOPT = JW + MAX( LWK1, LWK2 )
END IF
*
* ==== Quick return in case of workspace query. ====
*
IF( LWORK.EQ.-1 ) THEN
WORK( 1 ) = REAL( LWKOPT )
RETURN
END IF
*
* ==== Nothing to do ...
* ... for an empty active block ... ====
NS = 0
ND = 0
IF( KTOP.GT.KBOT )
$ RETURN
* ... nor for an empty deflation window. ====
IF( NW.LT.1 )
$ RETURN
*
* ==== Machine constants ====
*
SAFMIN = SLAMCH( 'SAFE MINIMUM' )
SAFMAX = ONE / SAFMIN
CALL SLABAD( SAFMIN, SAFMAX )
ULP = SLAMCH( 'PRECISION' )
SMLNUM = SAFMIN*( REAL( N ) / ULP )
*
* ==== Setup deflation window ====
*
JW = MIN( NW, KBOT-KTOP+1 )
KWTOP = KBOT - JW + 1
IF( KWTOP.EQ.KTOP ) THEN
S = ZERO
ELSE
S = H( KWTOP, KWTOP-1 )
END IF
*
IF( KBOT.EQ.KWTOP ) THEN
*
* ==== 1-by-1 deflation window: not much to do ====
*
SR( KWTOP ) = H( KWTOP, KWTOP )
SI( KWTOP ) = ZERO
NS = 1
ND = 0
IF( ABS( S ).LE.MAX( SMLNUM, ULP*ABS( H( KWTOP, KWTOP ) ) ) )
$ THEN
NS = 0
ND = 1
IF( KWTOP.GT.KTOP )
$ H( KWTOP, KWTOP-1 ) = ZERO
END IF
RETURN
END IF
*
* ==== Convert to spike-triangular form. (In case of a
* . rare QR failure, this routine continues to do
* . aggressive early deflation using that part of
* . the deflation window that converged using INFQR
* . here and there to keep track.) ====
*
CALL SLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
CALL SCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
*
CALL SLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
CALL SLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ),
$ SI( KWTOP ), 1, JW, V, LDV, INFQR )
*
* ==== STREXC needs a clean margin near the diagonal ====
*
DO 10 J = 1, JW - 3
T( J+2, J ) = ZERO
T( J+3, J ) = ZERO
10 CONTINUE
IF( JW.GT.2 )
$ T( JW, JW-2 ) = ZERO
*
* ==== Deflation detection loop ====
*
NS = JW
ILST = INFQR + 1
20 CONTINUE
IF( ILST.LE.NS ) THEN
IF( NS.EQ.1 ) THEN
BULGE = .FALSE.
ELSE
BULGE = T( NS, NS-1 ).NE.ZERO
END IF
*
* ==== Small spike tip test for deflation ====
*
IF( .NOT.BULGE ) THEN
*
* ==== Real eigenvalue ====
*
FOO = ABS( T( NS, NS ) )
IF( FOO.EQ.ZERO )
$ FOO = ABS( S )
IF( ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN
*
* ==== Deflatable ====
*
NS = NS - 1
ELSE
*
* ==== Undeflatable. Move it up out of the way.
* . (STREXC can not fail in this case.) ====
*
IFST = NS
CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
$ INFO )
ILST = ILST + 1
END IF
ELSE
*
* ==== Complex conjugate pair ====
*
FOO = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )*
$ SQRT( ABS( T( NS-1, NS ) ) )
IF( FOO.EQ.ZERO )
$ FOO = ABS( S )
IF( MAX( ABS( S*V( 1, NS ) ), ABS( S*V( 1, NS-1 ) ) ).LE.
$ MAX( SMLNUM, ULP*FOO ) ) THEN
*
* ==== Deflatable ====
*
NS = NS - 2
ELSE
*
* ==== Undflatable. Move them up out of the way.
* . Fortunately, STREXC does the right thing with
* . ILST in case of a rare exchange failure. ====
*
IFST = NS
CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
$ INFO )
ILST = ILST + 2
END IF
END IF
*
* ==== End deflation detection loop ====
*
GO TO 20
END IF
*
* ==== Return to Hessenberg form ====
*
IF( NS.EQ.0 )
$ S = ZERO
*
IF( NS.LT.JW ) THEN
*
* ==== sorting diagonal blocks of T improves accuracy for
* . graded matrices. Bubble sort deals well with
* . exchange failures. ====
*
SORTED = .false.
I = NS + 1
30 CONTINUE
IF( SORTED )
$ GO TO 50
SORTED = .true.
*
KEND = I - 1
I = INFQR + 1
IF( I.EQ.NS ) THEN
K = I + 1
ELSE IF( T( I+1, I ).EQ.ZERO ) THEN
K = I + 1
ELSE
K = I + 2
END IF
40 CONTINUE
IF( K.LE.KEND ) THEN
IF( K.EQ.I+1 ) THEN
EVI = ABS( T( I, I ) )
ELSE
EVI = ABS( T( I, I ) ) + SQRT( ABS( T( I+1, I ) ) )*
$ SQRT( ABS( T( I, I+1 ) ) )
END IF
*
IF( K.EQ.KEND ) THEN
EVK = ABS( T( K, K ) )
ELSE IF( T( K+1, K ).EQ.ZERO ) THEN
EVK = ABS( T( K, K ) )
ELSE
EVK = ABS( T( K, K ) ) + SQRT( ABS( T( K+1, K ) ) )*
$ SQRT( ABS( T( K, K+1 ) ) )
END IF
*
IF( EVI.GE.EVK ) THEN
I = K
ELSE
SORTED = .false.
IFST = I
ILST = K
CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
$ INFO )
IF( INFO.EQ.0 ) THEN
I = ILST
ELSE
I = K
END IF
END IF
IF( I.EQ.KEND ) THEN
K = I + 1
ELSE IF( T( I+1, I ).EQ.ZERO ) THEN
K = I + 1
ELSE
K = I + 2
END IF
GO TO 40
END IF
GO TO 30
50 CONTINUE
END IF
*
* ==== Restore shift/eigenvalue array from T ====
*
I = JW
60 CONTINUE
IF( I.GE.INFQR+1 ) THEN
IF( I.EQ.INFQR+1 ) THEN
SR( KWTOP+I-1 ) = T( I, I )
SI( KWTOP+I-1 ) = ZERO
I = I - 1
ELSE IF( T( I, I-1 ).EQ.ZERO ) THEN
SR( KWTOP+I-1 ) = T( I, I )
SI( KWTOP+I-1 ) = ZERO
I = I - 1
ELSE
AA = T( I-1, I-1 )
CC = T( I, I-1 )
BB = T( I-1, I )
DD = T( I, I )
CALL SLANV2( AA, BB, CC, DD, SR( KWTOP+I-2 ),
$ SI( KWTOP+I-2 ), SR( KWTOP+I-1 ),
$ SI( KWTOP+I-1 ), CS, SN )
I = I - 2
END IF
GO TO 60
END IF
*
IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN
IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
*
* ==== Reflect spike back into lower triangle ====
*
CALL SCOPY( NS, V, LDV, WORK, 1 )
BETA = WORK( 1 )
CALL SLARFG( NS, BETA, WORK( 2 ), 1, TAU )
WORK( 1 ) = ONE
*
CALL SLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )
*
CALL SLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT,
$ WORK( JW+1 ) )
CALL SLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT,
$ WORK( JW+1 ) )
CALL SLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV,
$ WORK( JW+1 ) )
*
CALL SGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
$ LWORK-JW, INFO )
END IF
*
* ==== Copy updated reduced window into place ====
*
IF( KWTOP.GT.1 )
$ H( KWTOP, KWTOP-1 ) = S*V( 1, 1 )
CALL SLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH )
CALL SCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ),
$ LDH+1 )
*
* ==== Accumulate orthogonal matrix in order update
* . H and Z, if requested. (A modified version
* . of SORGHR that accumulates block Householder
* . transformations into V directly might be
* . marginally more efficient than the following.) ====
*
IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
CALL SORGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
$ LWORK-JW, INFO )
CALL SGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO,
$ WV, LDWV )
CALL SLACPY( 'A', JW, NS, WV, LDWV, V, LDV )
END IF
*
* ==== Update vertical slab in H ====
*
IF( WANTT ) THEN
LTOP = 1
ELSE
LTOP = KTOP
END IF
DO 70 KROW = LTOP, KWTOP - 1, NV
KLN = MIN( NV, KWTOP-KROW )
CALL SGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
$ LDH, V, LDV, ZERO, WV, LDWV )
CALL SLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH )
70 CONTINUE
*
* ==== Update horizontal slab in H ====
*
IF( WANTT ) THEN
DO 80 KCOL = KBOT + 1, N, NH
KLN = MIN( NH, N-KCOL+1 )
CALL SGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV,
$ H( KWTOP, KCOL ), LDH, ZERO, T, LDT )
CALL SLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ),
$ LDH )
80 CONTINUE
END IF
*
* ==== Update vertical slab in Z ====
*
IF( WANTZ ) THEN
DO 90 KROW = ILOZ, IHIZ, NV
KLN = MIN( NV, IHIZ-KROW+1 )
CALL SGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
$ LDZ, V, LDV, ZERO, WV, LDWV )
CALL SLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ),
$ LDZ )
90 CONTINUE
END IF
END IF
*
* ==== Return the number of deflations ... ====
*
ND = JW - NS
*
* ==== ... and the number of shifts. (Subtracting
* . INFQR from the spike length takes care
* . of the case of a rare QR failure while
* . calculating eigenvalues of the deflation
* . window.) ====
*
NS = NS - INFQR
*
* ==== Return optimal workspace. ====
*
WORK( 1 ) = REAL( LWKOPT )
*
* ==== End of SLAQR2 ====
*
END
SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
$ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T,
$ LDT, NV, WV, LDWV, WORK, LWORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
$ LDZ, LWORK, N, ND, NH, NS, NV, NW
LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
REAL H( LDH, * ), SI( * ), SR( * ), T( LDT, * ),
$ V( LDV, * ), WORK( * ), WV( LDWV, * ),
$ Z( LDZ, * )
* ..
*
* ******************************************************************
* Aggressive early deflation:
*
* This subroutine accepts as input an upper Hessenberg matrix
* H and performs an orthogonal similarity transformation
* designed to detect and deflate fully converged eigenvalues from
* a trailing principal submatrix. On output H has been over-
* written by a new Hessenberg matrix that is a perturbation of
* an orthogonal similarity transformation of H. It is to be
* hoped that the final version of H has many zero subdiagonal
* entries.
*
* ******************************************************************
* WANTT (input) LOGICAL
* If .TRUE., then the Hessenberg matrix H is fully updated
* so that the quasi-triangular Schur factor may be
* computed (in cooperation with the calling subroutine).
* If .FALSE., then only enough of H is updated to preserve
* the eigenvalues.
*
* WANTZ (input) LOGICAL
* If .TRUE., then the orthogonal matrix Z is updated so
* so that the orthogonal Schur factor may be computed
* (in cooperation with the calling subroutine).
* If .FALSE., then Z is not referenced.
*
* N (input) INTEGER
* The order of the matrix H and (if WANTZ is .TRUE.) the
* order of the orthogonal matrix Z.
*
* KTOP (input) INTEGER
* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.
* KBOT and KTOP together determine an isolated block
* along the diagonal of the Hessenberg matrix.
*
* KBOT (input) INTEGER
* It is assumed without a check that either
* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together
* determine an isolated block along the diagonal of the
* Hessenberg matrix.
*
* NW (input) INTEGER
* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).
*
* H (input/output) REAL array, dimension (LDH,N)
* On input the initial N-by-N section of H stores the
* Hessenberg matrix undergoing aggressive early deflation.
* On output H has been transformed by an orthogonal
* similarity transformation, perturbed, and the returned
* to Hessenberg form that (it is to be hoped) has some
* zero subdiagonal entries.
*
* LDH (input) integer
* Leading dimension of H just as declared in the calling
* subroutine. N .LE. LDH
*
* ILOZ (input) INTEGER
* IHIZ (input) INTEGER
* Specify the rows of Z to which transformations must be
* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.
*
* Z (input/output) REAL array, dimension (LDZ,IHI)
* IF WANTZ is .TRUE., then on output, the orthogonal
* similarity transformation mentioned above has been
* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.
* If WANTZ is .FALSE., then Z is unreferenced.
*
* LDZ (input) integer
* The leading dimension of Z just as declared in the
* calling subroutine. 1 .LE. LDZ.
*
* NS (output) integer
* The number of unconverged (ie approximate) eigenvalues
* returned in SR and SI that may be used as shifts by the
* calling subroutine.
*
* ND (output) integer
* The number of converged eigenvalues uncovered by this
* subroutine.
*
* SR (output) REAL array, dimension KBOT
* SI (output) REAL array, dimension KBOT
* On output, the real and imaginary parts of approximate
* eigenvalues that may be used for shifts are stored in
* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and
* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.
* The real and imaginary parts of converged eigenvalues
* are stored in SR(KBOT-ND+1) through SR(KBOT) and
* SI(KBOT-ND+1) through SI(KBOT), respectively.
*
* V (workspace) REAL array, dimension (LDV,NW)
* An NW-by-NW work array.
*
* LDV (input) integer scalar
* The leading dimension of V just as declared in the
* calling subroutine. NW .LE. LDV
*
* NH (input) integer scalar
* The number of columns of T. NH.GE.NW.
*
* T (workspace) REAL array, dimension (LDT,NW)
*
* LDT (input) integer
* The leading dimension of T just as declared in the
* calling subroutine. NW .LE. LDT
*
* NV (input) integer
* The number of rows of work array WV available for
* workspace. NV.GE.NW.
*
* WV (workspace) REAL array, dimension (LDWV,NW)
*
* LDWV (input) integer
* The leading dimension of W just as declared in the
* calling subroutine. NW .LE. LDV
*
* WORK (workspace) REAL array, dimension LWORK.
* On exit, WORK(1) is set to an estimate of the optimal value
* of LWORK for the given values of N, NW, KTOP and KBOT.
*
* LWORK (input) integer
* The dimension of the work array WORK. LWORK = 2*NW
* suffices, but greater efficiency may result from larger
* values of LWORK.
*
* If LWORK = -1, then a workspace query is assumed; SLAQR3
* only estimates the optimal workspace size for the given
* values of N, NW, KTOP and KBOT. The estimate is returned
* in WORK(1). No error message related to LWORK is issued
* by XERBLA. Neither H nor Z are accessed.
*
* ================================================================
* Based on contributions by
* Karen Braman and Ralph Byers, Department of Mathematics,
* University of Kansas, USA
*
* ==================================================================
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0 )
* ..
* .. Local Scalars ..
REAL AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S,
$ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP
INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL,
$ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3,
$ LWKOPT, NMIN
LOGICAL BULGE, SORTED
* ..
* .. External Functions ..
REAL SLAMCH
INTEGER ILAENV
EXTERNAL SLAMCH, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEHRD, SGEMM, SLABAD, SLACPY, SLAHQR,
$ SLANV2, SLAQR4, SLARF, SLARFG, SLASET, SORGHR,
$ STREXC
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, MAX, MIN, REAL, SQRT
* ..
* .. Executable Statements ..
*
* ==== Estimate optimal workspace. ====
*
JW = MIN( NW, KBOT-KTOP+1 )
IF( JW.LE.2 ) THEN
LWKOPT = 1
ELSE
*
* ==== Workspace query call to SGEHRD ====
*
CALL SGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
LWK1 = INT( WORK( 1 ) )
*
* ==== Workspace query call to SORGHR ====
*
CALL SORGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
LWK2 = INT( WORK( 1 ) )
*
* ==== Workspace query call to SLAQR4 ====
*
CALL SLAQR4( .true., .true., JW, 1, JW, T, LDT, SR, SI, 1, JW,
$ V, LDV, WORK, -1, INFQR )
LWK3 = INT( WORK( 1 ) )
*
* ==== Optimal workspace ====
*
LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 )
END IF
*
* ==== Quick return in case of workspace query. ====
*
IF( LWORK.EQ.-1 ) THEN
WORK( 1 ) = REAL( LWKOPT )
RETURN
END IF
*
* ==== Nothing to do ...
* ... for an empty active block ... ====
NS = 0
ND = 0
IF( KTOP.GT.KBOT )
$ RETURN
* ... nor for an empty deflation window. ====
IF( NW.LT.1 )
$ RETURN
*
* ==== Machine constants ====
*
SAFMIN = SLAMCH( 'SAFE MINIMUM' )
SAFMAX = ONE / SAFMIN
CALL SLABAD( SAFMIN, SAFMAX )
ULP = SLAMCH( 'PRECISION' )
SMLNUM = SAFMIN*( REAL( N ) / ULP )
*
* ==== Setup deflation window ====
*
JW = MIN( NW, KBOT-KTOP+1 )
KWTOP = KBOT - JW + 1
IF( KWTOP.EQ.KTOP ) THEN
S = ZERO
ELSE
S = H( KWTOP, KWTOP-1 )
END IF
*
IF( KBOT.EQ.KWTOP ) THEN
*
* ==== 1-by-1 deflation window: not much to do ====
*
SR( KWTOP ) = H( KWTOP, KWTOP )
SI( KWTOP ) = ZERO
NS = 1
ND = 0
IF( ABS( S ).LE.MAX( SMLNUM, ULP*ABS( H( KWTOP, KWTOP ) ) ) )
$ THEN
NS = 0
ND = 1
IF( KWTOP.GT.KTOP )
$ H( KWTOP, KWTOP-1 ) = ZERO
END IF
RETURN
END IF
*
* ==== Convert to spike-triangular form. (In case of a
* . rare QR failure, this routine continues to do
* . aggressive early deflation using that part of
* . the deflation window that converged using INFQR
* . here and there to keep track.) ====
*
CALL SLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
CALL SCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
*
CALL SLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
NMIN = ILAENV( 12, 'SLAQR3', 'SV', JW, 1, JW, LWORK )
IF( JW.GT.NMIN ) THEN
CALL SLAQR4( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ),
$ SI( KWTOP ), 1, JW, V, LDV, WORK, LWORK, INFQR )
ELSE
CALL SLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ),
$ SI( KWTOP ), 1, JW, V, LDV, INFQR )
END IF
*
* ==== STREXC needs a clean margin near the diagonal ====
*
DO 10 J = 1, JW - 3
T( J+2, J ) = ZERO
T( J+3, J ) = ZERO
10 CONTINUE
IF( JW.GT.2 )
$ T( JW, JW-2 ) = ZERO
*
* ==== Deflation detection loop ====
*
NS = JW
ILST = INFQR + 1
20 CONTINUE
IF( ILST.LE.NS ) THEN
IF( NS.EQ.1 ) THEN
BULGE = .FALSE.
ELSE
BULGE = T( NS, NS-1 ).NE.ZERO
END IF
*
* ==== Small spike tip test for deflation ====
*
IF( .NOT.BULGE ) THEN
*
* ==== Real eigenvalue ====
*
FOO = ABS( T( NS, NS ) )
IF( FOO.EQ.ZERO )
$ FOO = ABS( S )
IF( ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN
*
* ==== Deflatable ====
*
NS = NS - 1
ELSE
*
* ==== Undeflatable. Move it up out of the way.
* . (STREXC can not fail in this case.) ====
*
IFST = NS
CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
$ INFO )
ILST = ILST + 1
END IF
ELSE
*
* ==== Complex conjugate pair ====
*
FOO = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )*
$ SQRT( ABS( T( NS-1, NS ) ) )
IF( FOO.EQ.ZERO )
$ FOO = ABS( S )
IF( MAX( ABS( S*V( 1, NS ) ), ABS( S*V( 1, NS-1 ) ) ).LE.
$ MAX( SMLNUM, ULP*FOO ) ) THEN
*
* ==== Deflatable ====
*
NS = NS - 2
ELSE
*
* ==== Undflatable. Move them up out of the way.
* . Fortunately, STREXC does the right thing with
* . ILST in case of a rare exchange failure. ====
*
IFST = NS
CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
$ INFO )
ILST = ILST + 2
END IF
END IF
*
* ==== End deflation detection loop ====
*
GO TO 20
END IF
*
* ==== Return to Hessenberg form ====
*
IF( NS.EQ.0 )
$ S = ZERO
*
IF( NS.LT.JW ) THEN
*
* ==== sorting diagonal blocks of T improves accuracy for
* . graded matrices. Bubble sort deals well with
* . exchange failures. ====
*
SORTED = .false.
I = NS + 1
30 CONTINUE
IF( SORTED )
$ GO TO 50
SORTED = .true.
*
KEND = I - 1
I = INFQR + 1
IF( I.EQ.NS ) THEN
K = I + 1
ELSE IF( T( I+1, I ).EQ.ZERO ) THEN
K = I + 1
ELSE
K = I + 2
END IF
40 CONTINUE
IF( K.LE.KEND ) THEN
IF( K.EQ.I+1 ) THEN
EVI = ABS( T( I, I ) )
ELSE
EVI = ABS( T( I, I ) ) + SQRT( ABS( T( I+1, I ) ) )*
$ SQRT( ABS( T( I, I+1 ) ) )
END IF
*
IF( K.EQ.KEND ) THEN
EVK = ABS( T( K, K ) )
ELSE IF( T( K+1, K ).EQ.ZERO ) THEN
EVK = ABS( T( K, K ) )
ELSE
EVK = ABS( T( K, K ) ) + SQRT( ABS( T( K+1, K ) ) )*
$ SQRT( ABS( T( K, K+1 ) ) )
END IF
*
IF( EVI.GE.EVK ) THEN
I = K
ELSE
SORTED = .false.
IFST = I
ILST = K
CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
$ INFO )
IF( INFO.EQ.0 ) THEN
I = ILST
ELSE
I = K
END IF
END IF
IF( I.EQ.KEND ) THEN
K = I + 1
ELSE IF( T( I+1, I ).EQ.ZERO ) THEN
K = I + 1
ELSE
K = I + 2
END IF
GO TO 40
END IF
GO TO 30
50 CONTINUE
END IF
*
* ==== Restore shift/eigenvalue array from T ====
*
I = JW
60 CONTINUE
IF( I.GE.INFQR+1 ) THEN
IF( I.EQ.INFQR+1 ) THEN
SR( KWTOP+I-1 ) = T( I, I )
SI( KWTOP+I-1 ) = ZERO
I = I - 1
ELSE IF( T( I, I-1 ).EQ.ZERO ) THEN
SR( KWTOP+I-1 ) = T( I, I )
SI( KWTOP+I-1 ) = ZERO
I = I - 1
ELSE
AA = T( I-1, I-1 )
CC = T( I, I-1 )
BB = T( I-1, I )
DD = T( I, I )
CALL SLANV2( AA, BB, CC, DD, SR( KWTOP+I-2 ),
$ SI( KWTOP+I-2 ), SR( KWTOP+I-1 ),
$ SI( KWTOP+I-1 ), CS, SN )
I = I - 2
END IF
GO TO 60
END IF
*
IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN
IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
*
* ==== Reflect spike back into lower triangle ====
*
CALL SCOPY( NS, V, LDV, WORK, 1 )
BETA = WORK( 1 )
CALL SLARFG( NS, BETA, WORK( 2 ), 1, TAU )
WORK( 1 ) = ONE
*
CALL SLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )
*
CALL SLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT,
$ WORK( JW+1 ) )
CALL SLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT,
$ WORK( JW+1 ) )
CALL SLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV,
$ WORK( JW+1 ) )
*
CALL SGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
$ LWORK-JW, INFO )
END IF
*
* ==== Copy updated reduced window into place ====
*
IF( KWTOP.GT.1 )
$ H( KWTOP, KWTOP-1 ) = S*V( 1, 1 )
CALL SLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH )
CALL SCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ),
$ LDH+1 )
*
* ==== Accumulate orthogonal matrix in order update
* . H and Z, if requested. (A modified version
* . of SORGHR that accumulates block Householder
* . transformations into V directly might be
* . marginally more efficient than the following.) ====
*
IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
CALL SORGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
$ LWORK-JW, INFO )
CALL SGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO,
$ WV, LDWV )
CALL SLACPY( 'A', JW, NS, WV, LDWV, V, LDV )
END IF
*
* ==== Update vertical slab in H ====
*
IF( WANTT ) THEN
LTOP = 1
ELSE
LTOP = KTOP
END IF
DO 70 KROW = LTOP, KWTOP - 1, NV
KLN = MIN( NV, KWTOP-KROW )
CALL SGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
$ LDH, V, LDV, ZERO, WV, LDWV )
CALL SLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH )
70 CONTINUE
*
* ==== Update horizontal slab in H ====
*
IF( WANTT ) THEN
DO 80 KCOL = KBOT + 1, N, NH
KLN = MIN( NH, N-KCOL+1 )
CALL SGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV,
$ H( KWTOP, KCOL ), LDH, ZERO, T, LDT )
CALL SLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ),
$ LDH )
80 CONTINUE
END IF
*
* ==== Update vertical slab in Z ====
*
IF( WANTZ ) THEN
DO 90 KROW = ILOZ, IHIZ, NV
KLN = MIN( NV, IHIZ-KROW+1 )
CALL SGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
$ LDZ, V, LDV, ZERO, WV, LDWV )
CALL SLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ),
$ LDZ )
90 CONTINUE
END IF
END IF
*
* ==== Return the number of deflations ... ====
*
ND = JW - NS
*
* ==== ... and the number of shifts. (Subtracting
* . INFQR from the spike length takes care
* . of the case of a rare QR failure while
* . calculating eigenvalues of the deflation
* . window.) ====
*
NS = NS - INFQR
*
* ==== Return optimal workspace. ====
*
WORK( 1 ) = REAL( LWKOPT )
*
* ==== End of SLAQR3 ====
*
END
SUBROUTINE SLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
$ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
REAL H( LDH, * ), WI( * ), WORK( * ), WR( * ),
$ Z( LDZ, * )
* ..
*
* This subroutine implements one level of recursion for SLAQR0.
* It is a complete implementation of the small bulge multi-shift
* QR algorithm. It may be called by SLAQR0 and, for large enough
* deflation window size, it may be called by SLAQR3. This
* subroutine is identical to SLAQR0 except that it calls SLAQR2
* instead of SLAQR3.
*
* Purpose
* =======
*
* SLAQR4 computes the eigenvalues of a Hessenberg matrix H
* and, optionally, the matrices T and Z from the Schur decomposition
* H = Z T Z**T, where T is an upper quasi-triangular matrix (the
* Schur form), and Z is the orthogonal matrix of Schur vectors.
*
* Optionally Z may be postmultiplied into an input orthogonal
* matrix Q so that this routine can give the Schur factorization
* of a matrix A which has been reduced to the Hessenberg form H
* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.
*
* Arguments
* =========
*
* WANTT (input) LOGICAL
* = .TRUE. : the full Schur form T is required;
* = .FALSE.: only eigenvalues are required.
*
* WANTZ (input) LOGICAL
* = .TRUE. : the matrix of Schur vectors Z is required;
* = .FALSE.: Schur vectors are not required.
*
* N (input) INTEGER
* The order of the matrix H. N .GE. 0.
*
* 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 and, if ILO.GT.1,
* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a
* previous call to SGEBAL, and then passed to SGEHRD when the
* matrix output by SGEBAL is reduced to Hessenberg form.
* Otherwise, ILO and IHI should be set to 1 and N,
* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
* If N = 0, then ILO = 1 and IHI = 0.
*
* H (input/output) REAL array, dimension (LDH,N)
* On entry, the upper Hessenberg matrix H.
* On exit, if INFO = 0 and WANTT is .TRUE., then H contains
* the upper quasi-triangular matrix T from the Schur
* decomposition (the Schur form); 2-by-2 diagonal blocks
* (corresponding to complex conjugate pairs of eigenvalues)
* are returned in standard form, with H(i,i) = H(i+1,i+1)
* and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is
* .FALSE., then the contents of H are unspecified on exit.
* (The output value of H when INFO.GT.0 is given under the
* description of INFO below.)
*
* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and
* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.
*
* LDH (input) INTEGER
* The leading dimension of the array H. LDH .GE. max(1,N).
*
* WR (output) REAL array, dimension (IHI)
* WI (output) REAL array, dimension (IHI)
* The real and imaginary parts, respectively, of the computed
* eigenvalues of H(ILO:IHI,ILO:IHI) are stored WR(ILO:IHI)
* and WI(ILO:IHI). If two eigenvalues are computed as a
* complex conjugate pair, they are stored in consecutive
* elements of WR and WI, say the i-th and (i+1)th, with
* WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then
* the eigenvalues are stored in the same order as on the
* diagonal of the Schur form returned in H, with
* WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal
* block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and
* WI(i+1) = -WI(i).
*
* ILOZ (input) INTEGER
* IHIZ (input) INTEGER
* Specify the rows of Z to which transformations must be
* applied if WANTZ is .TRUE..
* 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.
*
* Z (input/output) REAL array, dimension (LDZ,IHI)
* If WANTZ is .FALSE., then Z is not referenced.
* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is
* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the
* orthogonal Schur factor of H(ILO:IHI,ILO:IHI).
* (The output value of Z when INFO.GT.0 is given under
* the description of INFO below.)
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. if WANTZ is .TRUE.
* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.
*
* WORK (workspace/output) REAL array, dimension LWORK
* On exit, if LWORK = -1, WORK(1) returns an estimate of
* the optimal value for LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK. LWORK .GE. max(1,N)
* is sufficient, but LWORK typically as large as 6*N may
* be required for optimal performance. A workspace query
* to determine the optimal workspace size is recommended.
*
* If LWORK = -1, then SLAQR4 does a workspace query.
* In this case, SLAQR4 checks the input parameters and
* estimates the optimal workspace size for the given
* values of N, ILO and IHI. The estimate is returned
* in WORK(1). No error message related to LWORK is
* issued by XERBLA. Neither H nor Z are accessed.
*
*
* INFO (output) INTEGER
* = 0: successful exit
* .GT. 0: if INFO = i, SLAQR4 failed to compute all of
* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
* and WI contain those eigenvalues which have been
* successfully computed. (Failures are rare.)
*
* If INFO .GT. 0 and WANT is .FALSE., then on exit,
* the remaining unconverged eigenvalues are the eigen-
* values of the upper Hessenberg matrix rows and
* columns ILO through INFO of the final, output
* value of H.
*
* If INFO .GT. 0 and WANTT is .TRUE., then on exit
*
* (*) (initial value of H)*U = U*(final value of H)
*
* where U is an orthogonal matrix. The final
* value of H is upper Hessenberg and quasi-triangular
* in rows and columns INFO+1 through IHI.
*
* If INFO .GT. 0 and WANTZ is .TRUE., then on exit
*
* (final value of Z(ILO:IHI,ILOZ:IHIZ)
* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U
*
* where U is the orthogonal matrix in (*) (regard-
* less of the value of WANTT.)
*
* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not
* accessed.
*
* ================================================================
* Based on contributions by
* Karen Braman and Ralph Byers, Department of Mathematics,
* University of Kansas, USA
*
* ================================================================
* References:
* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
* Performance, SIAM Journal of Matrix Analysis, volume 23, pages
* 929--947, 2002.
*
* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
* Algorithm Part II: Aggressive Early Deflation, SIAM Journal
* of Matrix Analysis, volume 23, pages 948--973, 2002.
*
* ================================================================
* .. Parameters ..
*
* ==== Matrices of order NTINY or smaller must be processed by
* . SLAHQR because of insufficient subdiagonal scratch space.
* . (This is a hard limit.) ====
*
* ==== Exceptional deflation windows: try to cure rare
* . slow convergence by increasing the size of the
* . deflation window after KEXNW iterations. =====
*
* ==== Exceptional shifts: try to cure rare slow convergence
* . with ad-hoc exceptional shifts every KEXSH iterations.
* . The constants WILK1 and WILK2 are used to form the
* . exceptional shifts. ====
*
INTEGER NTINY
PARAMETER ( NTINY = 11 )
INTEGER KEXNW, KEXSH
PARAMETER ( KEXNW = 5, KEXSH = 6 )
REAL WILK1, WILK2
PARAMETER ( WILK1 = 0.75e0, WILK2 = -0.4375e0 )
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0 )
* ..
* .. Local Scalars ..
REAL AA, BB, CC, CS, DD, SN, SS, SWAP
INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS,
$ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS,
$ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX,
$ NSR, NVE, NW, NWMAX, NWR
LOGICAL NWINC, SORTED
CHARACTER JBCMPZ*2
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Local Arrays ..
REAL ZDUM( 1, 1 )
* ..
* .. External Subroutines ..
EXTERNAL SLACPY, SLAHQR, SLANV2, SLAQR2, SLAQR5
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, MAX, MIN, MOD, REAL
* ..
* .. Executable Statements ..
INFO = 0
*
* ==== Quick return for N = 0: nothing to do. ====
*
IF( N.EQ.0 ) THEN
WORK( 1 ) = ONE
RETURN
END IF
*
* ==== Set up job flags for ILAENV. ====
*
IF( WANTT ) THEN
JBCMPZ( 1: 1 ) = 'S'
ELSE
JBCMPZ( 1: 1 ) = 'E'
END IF
IF( WANTZ ) THEN
JBCMPZ( 2: 2 ) = 'V'
ELSE
JBCMPZ( 2: 2 ) = 'N'
END IF
*
* ==== Tiny matrices must use SLAHQR. ====
*
IF( N.LE.NTINY ) THEN
*
* ==== Estimate optimal workspace. ====
*
LWKOPT = 1
IF( LWORK.NE.-1 )
$ CALL SLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
$ ILOZ, IHIZ, Z, LDZ, INFO )
ELSE
*
* ==== Use small bulge multi-shift QR with aggressive early
* . deflation on larger-than-tiny matrices. ====
*
* ==== Hope for the best. ====
*
INFO = 0
*
* ==== NWR = recommended deflation window size. At this
* . point, N .GT. NTINY = 11, so there is enough
* . subdiagonal workspace for NWR.GE.2 as required.
* . (In fact, there is enough subdiagonal space for
* . NWR.GE.3.) ====
*
NWR = ILAENV( 13, 'SLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
NWR = MAX( 2, NWR )
NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR )
NW = NWR
*
* ==== NSR = recommended number of simultaneous shifts.
* . At this point N .GT. NTINY = 11, so there is at
* . enough subdiagonal workspace for NSR to be even
* . and greater than or equal to two as required. ====
*
NSR = ILAENV( 15, 'SLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO )
NSR = MAX( 2, NSR-MOD( NSR, 2 ) )
*
* ==== Estimate optimal workspace ====
*
* ==== Workspace query call to SLAQR2 ====
*
CALL SLAQR2( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ,
$ IHIZ, Z, LDZ, LS, LD, WR, WI, H, LDH, N, H, LDH,
$ N, H, LDH, WORK, -1 )
*
* ==== Optimal workspace = MAX(SLAQR5, SLAQR2) ====
*
LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) )
*
* ==== Quick return in case of workspace query. ====
*
IF( LWORK.EQ.-1 ) THEN
WORK( 1 ) = REAL( LWKOPT )
RETURN
END IF
*
* ==== SLAHQR/SLAQR0 crossover point ====
*
NMIN = ILAENV( 12, 'SLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
NMIN = MAX( NTINY, NMIN )
*
* ==== Nibble crossover point ====
*
NIBBLE = ILAENV( 14, 'SLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
NIBBLE = MAX( 0, NIBBLE )
*
* ==== Accumulate reflections during ttswp? Use block
* . 2-by-2 structure during matrix-matrix multiply? ====
*
KACC22 = ILAENV( 16, 'SLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
KACC22 = MAX( 0, KACC22 )
KACC22 = MIN( 2, KACC22 )
*
* ==== NWMAX = the largest possible deflation window for
* . which there is sufficient workspace. ====
*
NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 )
*
* ==== NSMAX = the Largest number of simultaneous shifts
* . for which there is sufficient workspace. ====
*
NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 )
NSMAX = NSMAX - MOD( NSMAX, 2 )
*
* ==== NDFL: an iteration count restarted at deflation. ====
*
NDFL = 1
*
* ==== ITMAX = iteration limit ====
*
ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) )
*
* ==== Last row and column in the active block ====
*
KBOT = IHI
*
* ==== Main Loop ====
*
DO 80 IT = 1, ITMAX
*
* ==== Done when KBOT falls below ILO ====
*
IF( KBOT.LT.ILO )
$ GO TO 90
*
* ==== Locate active block ====
*
DO 10 K = KBOT, ILO + 1, -1
IF( H( K, K-1 ).EQ.ZERO )
$ GO TO 20
10 CONTINUE
K = ILO
20 CONTINUE
KTOP = K
*
* ==== Select deflation window size ====
*
NH = KBOT - KTOP + 1
IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN
*
* ==== Typical deflation window. If possible and
* . advisable, nibble the entire active block.
* . If not, use size NWR or NWR+1 depending upon
* . which has the smaller corresponding subdiagonal
* . entry (a heuristic). ====
*
NWINC = .TRUE.
IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN
NW = NH
ELSE
NW = MIN( NWR, NH, NWMAX )
IF( NW.LT.NWMAX ) THEN
IF( NW.GE.NH-1 ) THEN
NW = NH
ELSE
KWTOP = KBOT - NW + 1
IF( ABS( H( KWTOP, KWTOP-1 ) ).GT.
$ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1
END IF
END IF
END IF
ELSE
*
* ==== Exceptional deflation window. If there have
* . been no deflations in KEXNW or more iterations,
* . then vary the deflation window size. At first,
* . because, larger windows are, in general, more
* . powerful than smaller ones, rapidly increase the
* . window up to the maximum reasonable and possible.
* . Then maybe try a slightly smaller window. ====
*
IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN
NW = MIN( NWMAX, NH, 2*NW )
ELSE
NWINC = .FALSE.
IF( NW.EQ.NH .AND. NH.GT.2 )
$ NW = NH - 1
END IF
END IF
*
* ==== Aggressive early deflation:
* . split workspace under the subdiagonal into
* . - an nw-by-nw work array V in the lower
* . left-hand-corner,
* . - an NW-by-at-least-NW-but-more-is-better
* . (NW-by-NHO) horizontal work array along
* . the bottom edge,
* . - an at-least-NW-but-more-is-better (NHV-by-NW)
* . vertical work array along the left-hand-edge.
* . ====
*
KV = N - NW + 1
KT = NW + 1
NHO = ( N-NW-1 ) - KT + 1
KWV = NW + 2
NVE = ( N-NW ) - KWV + 1
*
* ==== Aggressive early deflation ====
*
CALL SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
$ IHIZ, Z, LDZ, LS, LD, WR, WI, H( KV, 1 ), LDH,
$ NHO, H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH,
$ WORK, LWORK )
*
* ==== Adjust KBOT accounting for new deflations. ====
*
KBOT = KBOT - LD
*
* ==== KS points to the shifts. ====
*
KS = KBOT - LS + 1
*
* ==== Skip an expensive QR sweep if there is a (partly
* . heuristic) reason to expect that many eigenvalues
* . will deflate without it. Here, the QR sweep is
* . skipped if many eigenvalues have just been deflated
* . or if the remaining active block is small.
*
IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT-
$ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN
*
* ==== NS = nominal number of simultaneous shifts.
* . This may be lowered (slightly) if SLAQR2
* . did not provide that many shifts. ====
*
NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) )
NS = NS - MOD( NS, 2 )
*
* ==== If there have been no deflations
* . in a multiple of KEXSH iterations,
* . then try exceptional shifts.
* . Otherwise use shifts provided by
* . SLAQR2 above or from the eigenvalues
* . of a trailing principal submatrix. ====
*
IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN
KS = KBOT - NS + 1
DO 30 I = KBOT, MAX( KS+1, KTOP+2 ), -2
SS = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) )
AA = WILK1*SS + H( I, I )
BB = SS
CC = WILK2*SS
DD = AA
CALL SLANV2( AA, BB, CC, DD, WR( I-1 ), WI( I-1 ),
$ WR( I ), WI( I ), CS, SN )
30 CONTINUE
IF( KS.EQ.KTOP ) THEN
WR( KS+1 ) = H( KS+1, KS+1 )
WI( KS+1 ) = ZERO
WR( KS ) = WR( KS+1 )
WI( KS ) = WI( KS+1 )
END IF
ELSE
*
* ==== Got NS/2 or fewer shifts? Use SLAHQR
* . on a trailing principal submatrix to
* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9,
* . there is enough space below the subdiagonal
* . to fit an NS-by-NS scratch array.) ====
*
IF( KBOT-KS+1.LE.NS / 2 ) THEN
KS = KBOT - NS + 1
KT = N - NS + 1
CALL SLACPY( 'A', NS, NS, H( KS, KS ), LDH,
$ H( KT, 1 ), LDH )
CALL SLAHQR( .false., .false., NS, 1, NS,
$ H( KT, 1 ), LDH, WR( KS ), WI( KS ),
$ 1, 1, ZDUM, 1, INF )
KS = KS + INF
*
* ==== In case of a rare QR failure use
* . eigenvalues of the trailing 2-by-2
* . principal submatrix. ====
*
IF( KS.GE.KBOT ) THEN
AA = H( KBOT-1, KBOT-1 )
CC = H( KBOT, KBOT-1 )
BB = H( KBOT-1, KBOT )
DD = H( KBOT, KBOT )
CALL SLANV2( AA, BB, CC, DD, WR( KBOT-1 ),
$ WI( KBOT-1 ), WR( KBOT ),
$ WI( KBOT ), CS, SN )
KS = KBOT - 1
END IF
END IF
*
IF( KBOT-KS+1.GT.NS ) THEN
*
* ==== Sort the shifts (Helps a little)
* . Bubble sort keeps complex conjugate
* . pairs together. ====
*
SORTED = .false.
DO 50 K = KBOT, KS + 1, -1
IF( SORTED )
$ GO TO 60
SORTED = .true.
DO 40 I = KS, K - 1
IF( ABS( WR( I ) )+ABS( WI( I ) ).LT.
$ ABS( WR( I+1 ) )+ABS( WI( I+1 ) ) ) THEN
SORTED = .false.
*
SWAP = WR( I )
WR( I ) = WR( I+1 )
WR( I+1 ) = SWAP
*
SWAP = WI( I )
WI( I ) = WI( I+1 )
WI( I+1 ) = SWAP
END IF
40 CONTINUE
50 CONTINUE
60 CONTINUE
END IF
*
* ==== Shuffle shifts into pairs of real shifts
* . and pairs of complex conjugate shifts
* . assuming complex conjugate shifts are
* . already adjacent to one another. (Yes,
* . they are.) ====
*
DO 70 I = KBOT, KS + 2, -2
IF( WI( I ).NE.-WI( I-1 ) ) THEN
*
SWAP = WR( I )
WR( I ) = WR( I-1 )
WR( I-1 ) = WR( I-2 )
WR( I-2 ) = SWAP
*
SWAP = WI( I )
WI( I ) = WI( I-1 )
WI( I-1 ) = WI( I-2 )
WI( I-2 ) = SWAP
END IF
70 CONTINUE
END IF
*
* ==== If there are only two shifts and both are
* . real, then use only one. ====
*
IF( KBOT-KS+1.EQ.2 ) THEN
IF( WI( KBOT ).EQ.ZERO ) THEN
IF( ABS( WR( KBOT )-H( KBOT, KBOT ) ).LT.
$ ABS( WR( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN
WR( KBOT-1 ) = WR( KBOT )
ELSE
WR( KBOT ) = WR( KBOT-1 )
END IF
END IF
END IF
*
* ==== Use up to NS of the the smallest magnatiude
* . shifts. If there aren't NS shifts available,
* . then use them all, possibly dropping one to
* . make the number of shifts even. ====
*
NS = MIN( NS, KBOT-KS+1 )
NS = NS - MOD( NS, 2 )
KS = KBOT - NS + 1
*
* ==== Small-bulge multi-shift QR sweep:
* . split workspace under the subdiagonal into
* . - a KDU-by-KDU work array U in the lower
* . left-hand-corner,
* . - a KDU-by-at-least-KDU-but-more-is-better
* . (KDU-by-NHo) horizontal work array WH along
* . the bottom edge,
* . - and an at-least-KDU-but-more-is-better-by-KDU
* . (NVE-by-KDU) vertical work WV arrow along
* . the left-hand-edge. ====
*
KDU = 3*NS - 3
KU = N - KDU + 1
KWH = KDU + 1
NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1
KWV = KDU + 4
NVE = N - KDU - KWV + 1
*
* ==== Small-bulge multi-shift QR sweep ====
*
CALL SLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS,
$ WR( KS ), WI( KS ), H, LDH, ILOZ, IHIZ, Z,
$ LDZ, WORK, 3, H( KU, 1 ), LDH, NVE,
$ H( KWV, 1 ), LDH, NHO, H( KU, KWH ), LDH )
END IF
*
* ==== Note progress (or the lack of it). ====
*
IF( LD.GT.0 ) THEN
NDFL = 1
ELSE
NDFL = NDFL + 1
END IF
*
* ==== End of main loop ====
80 CONTINUE
*
* ==== Iteration limit exceeded. Set INFO to show where
* . the problem occurred and exit. ====
*
INFO = KBOT
90 CONTINUE
END IF
*
* ==== Return the optimal value of LWORK. ====
*
WORK( 1 ) = REAL( LWKOPT )
*
* ==== End of SLAQR4 ====
*
END
SUBROUTINE SLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS,
$ SR, SI, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U,
$ LDU, NV, WV, LDWV, NH, WH, LDWH )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV,
$ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV
LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
REAL H( LDH, * ), SI( * ), SR( * ), U( LDU, * ),
$ V( LDV, * ), WH( LDWH, * ), WV( LDWV, * ),
$ Z( LDZ, * )
* ..
*
* This auxiliary subroutine called by SLAQR0 performs a
* single small-bulge multi-shift QR sweep.
*
* WANTT (input) logical scalar
* WANTT = .true. if the quasi-triangular Schur factor
* is being computed. WANTT is set to .false. otherwise.
*
* WANTZ (input) logical scalar
* WANTZ = .true. if the orthogonal Schur factor is being
* computed. WANTZ is set to .false. otherwise.
*
* KACC22 (input) integer with value 0, 1, or 2.
* Specifies the computation mode of far-from-diagonal
* orthogonal updates.
* = 0: SLAQR5 does not accumulate reflections and does not
* use matrix-matrix multiply to update far-from-diagonal
* matrix entries.
* = 1: SLAQR5 accumulates reflections and uses matrix-matrix
* multiply to update the far-from-diagonal matrix entries.
* = 2: SLAQR5 accumulates reflections, uses matrix-matrix
* multiply to update the far-from-diagonal matrix entries,
* and takes advantage of 2-by-2 block structure during
* matrix multiplies.
*
* N (input) integer scalar
* N is the order of the Hessenberg matrix H upon which this
* subroutine operates.
*
* KTOP (input) integer scalar
* KBOT (input) integer scalar
* These are the first and last rows and columns of an
* isolated diagonal block upon which the QR sweep is to be
* applied. It is assumed without a check that
* either KTOP = 1 or H(KTOP,KTOP-1) = 0
* and
* either KBOT = N or H(KBOT+1,KBOT) = 0.
*
* NSHFTS (input) integer scalar
* NSHFTS gives the number of simultaneous shifts. NSHFTS
* must be positive and even.
*
* SR (input) REAL array of size (NSHFTS)
* SI (input) REAL array of size (NSHFTS)
* SR contains the real parts and SI contains the imaginary
* parts of the NSHFTS shifts of origin that define the
* multi-shift QR sweep.
*
* H (input/output) REAL array of size (LDH,N)
* On input H contains a Hessenberg matrix. On output a
* multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied
* to the isolated diagonal block in rows and columns KTOP
* through KBOT.
*
* LDH (input) integer scalar
* LDH is the leading dimension of H just as declared in the
* calling procedure. LDH.GE.MAX(1,N).
*
* ILOZ (input) INTEGER
* IHIZ (input) INTEGER
* Specify the rows of Z to which transformations must be
* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N
*
* Z (input/output) REAL array of size (LDZ,IHI)
* If WANTZ = .TRUE., then the QR Sweep orthogonal
* similarity transformation is accumulated into
* Z(ILOZ:IHIZ,ILO:IHI) from the right.
* If WANTZ = .FALSE., then Z is unreferenced.
*
* LDZ (input) integer scalar
* LDA is the leading dimension of Z just as declared in
* the calling procedure. LDZ.GE.N.
*
* V (workspace) REAL array of size (LDV,NSHFTS/2)
*
* LDV (input) integer scalar
* LDV is the leading dimension of V as declared in the
* calling procedure. LDV.GE.3.
*
* U (workspace) REAL array of size
* (LDU,3*NSHFTS-3)
*
* LDU (input) integer scalar
* LDU is the leading dimension of U just as declared in the
* in the calling subroutine. LDU.GE.3*NSHFTS-3.
*
* NH (input) integer scalar
* NH is the number of columns in array WH available for
* workspace. NH.GE.1.
*
* WH (workspace) REAL array of size (LDWH,NH)
*
* LDWH (input) integer scalar
* Leading dimension of WH just as declared in the
* calling procedure. LDWH.GE.3*NSHFTS-3.
*
* NV (input) integer scalar
* NV is the number of rows in WV agailable for workspace.
* NV.GE.1.
*
* WV (workspace) REAL array of size
* (LDWV,3*NSHFTS-3)
*
* LDWV (input) integer scalar
* LDWV is the leading dimension of WV as declared in the
* in the calling subroutine. LDWV.GE.NV.
*
*
* ================================================================
* Based on contributions by
* Karen Braman and Ralph Byers, Department of Mathematics,
* University of Kansas, USA
*
* ============================================================
* Reference:
*
* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
* Algorithm Part I: Maintaining Well Focused Shifts, and
* Level 3 Performance, SIAM Journal of Matrix Analysis,
* volume 23, pages 929--947, 2002.
*
* ============================================================
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0 )
* ..
* .. Local Scalars ..
REAL ALPHA, BETA, H11, H12, H21, H22, REFSUM,
$ SAFMAX, SAFMIN, SCL, SMLNUM, SWAP, TST1, TST2,
$ ULP
INTEGER I, I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN,
$ JROW, JTOP, K, K1, KDU, KMS, KNZ, KRCOL, KZS,
$ M, M22, MBOT, MEND, MSTART, MTOP, NBMPS, NDCOL,
$ NS, NU
LOGICAL ACCUM, BLK22, BMP22
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Intrinsic Functions ..
*
INTRINSIC ABS, MAX, MIN, MOD, REAL
* ..
* .. Local Arrays ..
REAL VT( 3 )
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SLABAD, SLACPY, SLAQR1, SLARFG, SLASET,
$ STRMM
* ..
* .. Executable Statements ..
*
* ==== If there are no shifts, then there is nothing to do. ====
*
IF( NSHFTS.LT.2 )
$ RETURN
*
* ==== If the active block is empty or 1-by-1, then there
* . is nothing to do. ====
*
IF( KTOP.GE.KBOT )
$ RETURN
*
* ==== Shuffle shifts into pairs of real shifts and pairs
* . of complex conjugate shifts assuming complex
* . conjugate shifts are already adjacent to one
* . another. ====
*
DO 10 I = 1, NSHFTS - 2, 2
IF( SI( I ).NE.-SI( I+1 ) ) THEN
*
SWAP = SR( I )
SR( I ) = SR( I+1 )
SR( I+1 ) = SR( I+2 )
SR( I+2 ) = SWAP
*
SWAP = SI( I )
SI( I ) = SI( I+1 )
SI( I+1 ) = SI( I+2 )
SI( I+2 ) = SWAP
END IF
10 CONTINUE
*
* ==== NSHFTS is supposed to be even, but if is odd,
* . then simply reduce it by one. The shuffle above
* . ensures that the dropped shift is real and that
* . the remaining shifts are paired. ====
*
NS = NSHFTS - MOD( NSHFTS, 2 )
*
* ==== Machine constants for deflation ====
*
SAFMIN = SLAMCH( 'SAFE MINIMUM' )
SAFMAX = ONE / SAFMIN
CALL SLABAD( SAFMIN, SAFMAX )
ULP = SLAMCH( 'PRECISION' )
SMLNUM = SAFMIN*( REAL( N ) / ULP )
*
* ==== Use accumulated reflections to update far-from-diagonal
* . entries ? ====
*
ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 )
*
* ==== If so, exploit the 2-by-2 block structure? ====
*
BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 )
*
* ==== clear trash ====
*
IF( KTOP+2.LE.KBOT )
$ H( KTOP+2, KTOP ) = ZERO
*
* ==== NBMPS = number of 2-shift bulges in the chain ====
*
NBMPS = NS / 2
*
* ==== KDU = width of slab ====
*
KDU = 6*NBMPS - 3
*
* ==== Create and chase chains of NBMPS bulges ====
*
DO 220 INCOL = 3*( 1-NBMPS ) + KTOP - 1, KBOT - 2, 3*NBMPS - 2
NDCOL = INCOL + KDU
IF( ACCUM )
$ CALL SLASET( 'ALL', KDU, KDU, ZERO, ONE, U, LDU )
*
* ==== Near-the-diagonal bulge chase. The following loop
* . performs the near-the-diagonal part of a small bulge
* . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal
* . chunk extends from column INCOL to column NDCOL
* . (including both column INCOL and column NDCOL). The
* . following loop chases a 3*NBMPS column long chain of
* . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL
* . may be less than KTOP and and NDCOL may be greater than
* . KBOT indicating phantom columns from which to chase
* . bulges before they are actually introduced or to which
* . to chase bulges beyond column KBOT.) ====
*
DO 150 KRCOL = INCOL, MIN( INCOL+3*NBMPS-3, KBOT-2 )
*
* ==== Bulges number MTOP to MBOT are active double implicit
* . shift bulges. There may or may not also be small
* . 2-by-2 bulge, if there is room. The inactive bulges
* . (if any) must wait until the active bulges have moved
* . down the diagonal to make room. The phantom matrix
* . paradigm described above helps keep track. ====
*
MTOP = MAX( 1, ( ( KTOP-1 )-KRCOL+2 ) / 3+1 )
MBOT = MIN( NBMPS, ( KBOT-KRCOL ) / 3 )
M22 = MBOT + 1
BMP22 = ( MBOT.LT.NBMPS ) .AND. ( KRCOL+3*( M22-1 ) ).EQ.
$ ( KBOT-2 )
*
* ==== Generate reflections to chase the chain right
* . one column. (The minimum value of K is KTOP-1.) ====
*
DO 20 M = MTOP, MBOT
K = KRCOL + 3*( M-1 )
IF( K.EQ.KTOP-1 ) THEN
CALL SLAQR1( 3, H( KTOP, KTOP ), LDH, SR( 2*M-1 ),
$ SI( 2*M-1 ), SR( 2*M ), SI( 2*M ),
$ V( 1, M ) )
ALPHA = V( 1, M )
CALL SLARFG( 3, ALPHA, V( 2, M ), 1, V( 1, M ) )
ELSE
BETA = H( K+1, K )
V( 2, M ) = H( K+2, K )
V( 3, M ) = H( K+3, K )
CALL SLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) )
*
* ==== A Bulge may collapse because of vigilant
* . deflation or destructive underflow. (The
* . initial bulge is always collapsed.) Use
* . the two-small-subdiagonals trick to try
* . to get it started again. If V(2,M).NE.0 and
* . V(3,M) = H(K+3,K+1) = H(K+3,K+2) = 0, then
* . this bulge is collapsing into a zero
* . subdiagonal. It will be restarted next
* . trip through the loop.)
*
IF( V( 1, M ).NE.ZERO .AND.
$ ( V( 3, M ).NE.ZERO .OR. ( H( K+3,
$ K+1 ).EQ.ZERO .AND. H( K+3, K+2 ).EQ.ZERO ) ) )
$ THEN
*
* ==== Typical case: not collapsed (yet). ====
*
H( K+1, K ) = BETA
H( K+2, K ) = ZERO
H( K+3, K ) = ZERO
ELSE
*
* ==== Atypical case: collapsed. Attempt to
* . reintroduce ignoring H(K+1,K). If the
* . fill resulting from the new reflector
* . is too large, then abandon it.
* . Otherwise, use the new one. ====
*
CALL SLAQR1( 3, H( K+1, K+1 ), LDH, SR( 2*M-1 ),
$ SI( 2*M-1 ), SR( 2*M ), SI( 2*M ),
$ VT )
SCL = ABS( VT( 1 ) ) + ABS( VT( 2 ) ) +
$ ABS( VT( 3 ) )
IF( SCL.NE.ZERO ) THEN
VT( 1 ) = VT( 1 ) / SCL
VT( 2 ) = VT( 2 ) / SCL
VT( 3 ) = VT( 3 ) / SCL
END IF
*
* ==== The following is the traditional and
* . conservative two-small-subdiagonals
* . test. ====
* .
IF( ABS( H( K+1, K ) )*( ABS( VT( 2 ) )+
$ ABS( VT( 3 ) ) ).GT.ULP*ABS( VT( 1 ) )*
$ ( ABS( H( K, K ) )+ABS( H( K+1,
$ K+1 ) )+ABS( H( K+2, K+2 ) ) ) ) THEN
*
* ==== Starting a new bulge here would
* . create non-negligible fill. If
* . the old reflector is diagonal (only
* . possible with underflows), then
* . change it to I. Otherwise, use
* . it with trepidation. ====
*
IF( V( 2, M ).EQ.ZERO .AND. V( 3, M ).EQ.ZERO )
$ THEN
V( 1, M ) = ZERO
ELSE
H( K+1, K ) = BETA
H( K+2, K ) = ZERO
H( K+3, K ) = ZERO
END IF
ELSE
*
* ==== Stating a new bulge here would
* . create only negligible fill.
* . Replace the old reflector with
* . the new one. ====
*
ALPHA = VT( 1 )
CALL SLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) )
REFSUM = H( K+1, K ) + H( K+2, K )*VT( 2 ) +
$ H( K+3, K )*VT( 3 )
H( K+1, K ) = H( K+1, K ) - VT( 1 )*REFSUM
H( K+2, K ) = ZERO
H( K+3, K ) = ZERO
V( 1, M ) = VT( 1 )
V( 2, M ) = VT( 2 )
V( 3, M ) = VT( 3 )
END IF
END IF
END IF
20 CONTINUE
*
* ==== Generate a 2-by-2 reflection, if needed. ====
*
K = KRCOL + 3*( M22-1 )
IF( BMP22 ) THEN
IF( K.EQ.KTOP-1 ) THEN
CALL SLAQR1( 2, H( K+1, K+1 ), LDH, SR( 2*M22-1 ),
$ SI( 2*M22-1 ), SR( 2*M22 ), SI( 2*M22 ),
$ V( 1, M22 ) )
BETA = V( 1, M22 )
CALL SLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) )
ELSE
BETA = H( K+1, K )
V( 2, M22 ) = H( K+2, K )
CALL SLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) )
H( K+1, K ) = BETA
H( K+2, K ) = ZERO
END IF
ELSE
*
* ==== Initialize V(1,M22) here to avoid possible undefined
* . variable problems later. ====
*
V( 1, M22 ) = ZERO
END IF
*
* ==== Multiply H by reflections from the left ====
*
IF( ACCUM ) THEN
JBOT = MIN( NDCOL, KBOT )
ELSE IF( WANTT ) THEN
JBOT = N
ELSE
JBOT = KBOT
END IF
DO 40 J = MAX( KTOP, KRCOL ), JBOT
MEND = MIN( MBOT, ( J-KRCOL+2 ) / 3 )
DO 30 M = MTOP, MEND
K = KRCOL + 3*( M-1 )
REFSUM = V( 1, M )*( H( K+1, J )+V( 2, M )*
$ H( K+2, J )+V( 3, M )*H( K+3, J ) )
H( K+1, J ) = H( K+1, J ) - REFSUM
H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M )
H( K+3, J ) = H( K+3, J ) - REFSUM*V( 3, M )
30 CONTINUE
40 CONTINUE
IF( BMP22 ) THEN
K = KRCOL + 3*( M22-1 )
DO 50 J = MAX( K+1, KTOP ), JBOT
REFSUM = V( 1, M22 )*( H( K+1, J )+V( 2, M22 )*
$ H( K+2, J ) )
H( K+1, J ) = H( K+1, J ) - REFSUM
H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M22 )
50 CONTINUE
END IF
*
* ==== Multiply H by reflections from the right.
* . Delay filling in the last row until the
* . vigilant deflation check is complete. ====
*
IF( ACCUM ) THEN
JTOP = MAX( KTOP, INCOL )
ELSE IF( WANTT ) THEN
JTOP = 1
ELSE
JTOP = KTOP
END IF
DO 90 M = MTOP, MBOT
IF( V( 1, M ).NE.ZERO ) THEN
K = KRCOL + 3*( M-1 )
DO 60 J = JTOP, MIN( KBOT, K+3 )
REFSUM = V( 1, M )*( H( J, K+1 )+V( 2, M )*
$ H( J, K+2 )+V( 3, M )*H( J, K+3 ) )
H( J, K+1 ) = H( J, K+1 ) - REFSUM
H( J, K+2 ) = H( J, K+2 ) - REFSUM*V( 2, M )
H( J, K+3 ) = H( J, K+3 ) - REFSUM*V( 3, M )
60 CONTINUE
*
IF( ACCUM ) THEN
*
* ==== Accumulate U. (If necessary, update Z later
* . with with an efficient matrix-matrix
* . multiply.) ====
*
KMS = K - INCOL
DO 70 J = MAX( 1, KTOP-INCOL ), KDU
REFSUM = V( 1, M )*( U( J, KMS+1 )+V( 2, M )*
$ U( J, KMS+2 )+V( 3, M )*U( J, KMS+3 ) )
U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM
U( J, KMS+2 ) = U( J, KMS+2 ) - REFSUM*V( 2, M )
U( J, KMS+3 ) = U( J, KMS+3 ) - REFSUM*V( 3, M )
70 CONTINUE
ELSE IF( WANTZ ) THEN
*
* ==== U is not accumulated, so update Z
* . now by multiplying by reflections
* . from the right. ====
*
DO 80 J = ILOZ, IHIZ
REFSUM = V( 1, M )*( Z( J, K+1 )+V( 2, M )*
$ Z( J, K+2 )+V( 3, M )*Z( J, K+3 ) )
Z( J, K+1 ) = Z( J, K+1 ) - REFSUM
Z( J, K+2 ) = Z( J, K+2 ) - REFSUM*V( 2, M )
Z( J, K+3 ) = Z( J, K+3 ) - REFSUM*V( 3, M )
80 CONTINUE
END IF
END IF
90 CONTINUE
*
* ==== Special case: 2-by-2 reflection (if needed) ====
*
K = KRCOL + 3*( M22-1 )
IF( BMP22 .AND. ( V( 1, M22 ).NE.ZERO ) ) THEN
DO 100 J = JTOP, MIN( KBOT, K+3 )
REFSUM = V( 1, M22 )*( H( J, K+1 )+V( 2, M22 )*
$ H( J, K+2 ) )
H( J, K+1 ) = H( J, K+1 ) - REFSUM
H( J, K+2 ) = H( J, K+2 ) - REFSUM*V( 2, M22 )
100 CONTINUE
*
IF( ACCUM ) THEN
KMS = K - INCOL
DO 110 J = MAX( 1, KTOP-INCOL ), KDU
REFSUM = V( 1, M22 )*( U( J, KMS+1 )+V( 2, M22 )*
$ U( J, KMS+2 ) )
U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM
U( J, KMS+2 ) = U( J, KMS+2 ) - REFSUM*V( 2, M22 )
110 CONTINUE
ELSE IF( WANTZ ) THEN
DO 120 J = ILOZ, IHIZ
REFSUM = V( 1, M22 )*( Z( J, K+1 )+V( 2, M22 )*
$ Z( J, K+2 ) )
Z( J, K+1 ) = Z( J, K+1 ) - REFSUM
Z( J, K+2 ) = Z( J, K+2 ) - REFSUM*V( 2, M22 )
120 CONTINUE
END IF
END IF
*
* ==== Vigilant deflation check ====
*
MSTART = MTOP
IF( KRCOL+3*( MSTART-1 ).LT.KTOP )
$ MSTART = MSTART + 1
MEND = MBOT
IF( BMP22 )
$ MEND = MEND + 1
IF( KRCOL.EQ.KBOT-2 )
$ MEND = MEND + 1
DO 130 M = MSTART, MEND
K = MIN( KBOT-1, KRCOL+3*( M-1 ) )
*
* ==== The following convergence test requires that
* . the tradition small-compared-to-nearby-diagonals
* . criterion and the Ahues & Tisseur (LAWN 122, 1997)
* . criteria both be satisfied. The latter improves
* . accuracy in some examples. Falling back on an
* . alternate convergence criterion when TST1 or TST2
* . is zero (as done here) is traditional but probably
* . unnecessary. ====
*
IF( H( K+1, K ).NE.ZERO ) THEN
TST1 = ABS( H( K, K ) ) + ABS( H( K+1, K+1 ) )
IF( TST1.EQ.ZERO ) THEN
IF( K.GE.KTOP+1 )
$ TST1 = TST1 + ABS( H( K, K-1 ) )
IF( K.GE.KTOP+2 )
$ TST1 = TST1 + ABS( H( K, K-2 ) )
IF( K.GE.KTOP+3 )
$ TST1 = TST1 + ABS( H( K, K-3 ) )
IF( K.LE.KBOT-2 )
$ TST1 = TST1 + ABS( H( K+2, K+1 ) )
IF( K.LE.KBOT-3 )
$ TST1 = TST1 + ABS( H( K+3, K+1 ) )
IF( K.LE.KBOT-4 )
$ TST1 = TST1 + ABS( H( K+4, K+1 ) )
END IF
IF( ABS( H( K+1, K ) ).LE.MAX( SMLNUM, ULP*TST1 ) )
$ THEN
H12 = MAX( ABS( H( K+1, K ) ), ABS( H( K, K+1 ) ) )
H21 = MIN( ABS( H( K+1, K ) ), ABS( H( K, K+1 ) ) )
H11 = MAX( ABS( H( K+1, K+1 ) ),
$ ABS( H( K, K )-H( K+1, K+1 ) ) )
H22 = MIN( ABS( H( K+1, K+1 ) ),
$ ABS( H( K, K )-H( K+1, K+1 ) ) )
SCL = H11 + H12
TST2 = H22*( H11 / SCL )
*
IF( TST2.EQ.ZERO .OR. H21*( H12 / SCL ).LE.
$ MAX( SMLNUM, ULP*TST2 ) )H( K+1, K ) = ZERO
END IF
END IF
130 CONTINUE
*
* ==== Fill in the last row of each bulge. ====
*
MEND = MIN( NBMPS, ( KBOT-KRCOL-1 ) / 3 )
DO 140 M = MTOP, MEND
K = KRCOL + 3*( M-1 )
REFSUM = V( 1, M )*V( 3, M )*H( K+4, K+3 )
H( K+4, K+1 ) = -REFSUM
H( K+4, K+2 ) = -REFSUM*V( 2, M )
H( K+4, K+3 ) = H( K+4, K+3 ) - REFSUM*V( 3, M )
140 CONTINUE
*
* ==== End of near-the-diagonal bulge chase. ====
*
150 CONTINUE
*
* ==== Use U (if accumulated) to update far-from-diagonal
* . entries in H. If required, use U to update Z as
* . well. ====
*
IF( ACCUM ) THEN
IF( WANTT ) THEN
JTOP = 1
JBOT = N
ELSE
JTOP = KTOP
JBOT = KBOT
END IF
IF( ( .NOT.BLK22 ) .OR. ( INCOL.LT.KTOP ) .OR.
$ ( NDCOL.GT.KBOT ) .OR. ( NS.LE.2 ) ) THEN
*
* ==== Updates not exploiting the 2-by-2 block
* . structure of U. K1 and NU keep track of
* . the location and size of U in the special
* . cases of introducing bulges and chasing
* . bulges off the bottom. In these special
* . cases and in case the number of shifts
* . is NS = 2, there is no 2-by-2 block
* . structure to exploit. ====
*
K1 = MAX( 1, KTOP-INCOL )
NU = ( KDU-MAX( 0, NDCOL-KBOT ) ) - K1 + 1
*
* ==== Horizontal Multiply ====
*
DO 160 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH
JLEN = MIN( NH, JBOT-JCOL+1 )
CALL SGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ),
$ LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH,
$ LDWH )
CALL SLACPY( 'ALL', NU, JLEN, WH, LDWH,
$ H( INCOL+K1, JCOL ), LDH )
160 CONTINUE
*
* ==== Vertical multiply ====
*
DO 170 JROW = JTOP, MAX( KTOP, INCOL ) - 1, NV
JLEN = MIN( NV, MAX( KTOP, INCOL )-JROW )
CALL SGEMM( 'N', 'N', JLEN, NU, NU, ONE,
$ H( JROW, INCOL+K1 ), LDH, U( K1, K1 ),
$ LDU, ZERO, WV, LDWV )
CALL SLACPY( 'ALL', JLEN, NU, WV, LDWV,
$ H( JROW, INCOL+K1 ), LDH )
170 CONTINUE
*
* ==== Z multiply (also vertical) ====
*
IF( WANTZ ) THEN
DO 180 JROW = ILOZ, IHIZ, NV
JLEN = MIN( NV, IHIZ-JROW+1 )
CALL SGEMM( 'N', 'N', JLEN, NU, NU, ONE,
$ Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ),
$ LDU, ZERO, WV, LDWV )
CALL SLACPY( 'ALL', JLEN, NU, WV, LDWV,
$ Z( JROW, INCOL+K1 ), LDZ )
180 CONTINUE
END IF
ELSE
*
* ==== Updates exploiting U's 2-by-2 block structure.
* . (I2, I4, J2, J4 are the last rows and columns
* . of the blocks.) ====
*
I2 = ( KDU+1 ) / 2
I4 = KDU
J2 = I4 - I2
J4 = KDU
*
* ==== KZS and KNZ deal with the band of zeros
* . along the diagonal of one of the triangular
* . blocks. ====
*
KZS = ( J4-J2 ) - ( NS+1 )
KNZ = NS + 1
*
* ==== Horizontal multiply ====
*
DO 190 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH
JLEN = MIN( NH, JBOT-JCOL+1 )
*
* ==== Copy bottom of H to top+KZS of scratch ====
* (The first KZS rows get multiplied by zero.) ====
*
CALL SLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ),
$ LDH, WH( KZS+1, 1 ), LDWH )
*
* ==== Multiply by U21' ====
*
CALL SLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH )
CALL STRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE,
$ U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ),
$ LDWH )
*
* ==== Multiply top of H by U11' ====
*
CALL SGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU,
$ H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH )
*
* ==== Copy top of H bottom of WH ====
*
CALL SLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH,
$ WH( I2+1, 1 ), LDWH )
*
* ==== Multiply by U21' ====
*
CALL STRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE,
$ U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH )
*
* ==== Multiply by U22 ====
*
CALL SGEMM( 'C', 'N', I4-I2, JLEN, J4-J2, ONE,
$ U( J2+1, I2+1 ), LDU,
$ H( INCOL+1+J2, JCOL ), LDH, ONE,
$ WH( I2+1, 1 ), LDWH )
*
* ==== Copy it back ====
*
CALL SLACPY( 'ALL', KDU, JLEN, WH, LDWH,
$ H( INCOL+1, JCOL ), LDH )
190 CONTINUE
*
* ==== Vertical multiply ====
*
DO 200 JROW = JTOP, MAX( INCOL, KTOP ) - 1, NV
JLEN = MIN( NV, MAX( INCOL, KTOP )-JROW )
*
* ==== Copy right of H to scratch (the first KZS
* . columns get multiplied by zero) ====
*
CALL SLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ),
$ LDH, WV( 1, 1+KZS ), LDWV )
*
* ==== Multiply by U21 ====
*
CALL SLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV )
CALL STRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE,
$ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ),
$ LDWV )
*
* ==== Multiply by U11 ====
*
CALL SGEMM( 'N', 'N', JLEN, I2, J2, ONE,
$ H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV,
$ LDWV )
*
* ==== Copy left of H to right of scratch ====
*
CALL SLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH,
$ WV( 1, 1+I2 ), LDWV )
*
* ==== Multiply by U21 ====
*
CALL STRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE,
$ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV )
*
* ==== Multiply by U22 ====
*
CALL SGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE,
$ H( JROW, INCOL+1+J2 ), LDH,
$ U( J2+1, I2+1 ), LDU, ONE, WV( 1, 1+I2 ),
$ LDWV )
*
* ==== Copy it back ====
*
CALL SLACPY( 'ALL', JLEN, KDU, WV, LDWV,
$ H( JROW, INCOL+1 ), LDH )
200 CONTINUE
*
* ==== Multiply Z (also vertical) ====
*
IF( WANTZ ) THEN
DO 210 JROW = ILOZ, IHIZ, NV
JLEN = MIN( NV, IHIZ-JROW+1 )
*
* ==== Copy right of Z to left of scratch (first
* . KZS columns get multiplied by zero) ====
*
CALL SLACPY( 'ALL', JLEN, KNZ,
$ Z( JROW, INCOL+1+J2 ), LDZ,
$ WV( 1, 1+KZS ), LDWV )
*
* ==== Multiply by U12 ====
*
CALL SLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV,
$ LDWV )
CALL STRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE,
$ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ),
$ LDWV )
*
* ==== Multiply by U11 ====
*
CALL SGEMM( 'N', 'N', JLEN, I2, J2, ONE,
$ Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE,
$ WV, LDWV )
*
* ==== Copy left of Z to right of scratch ====
*
CALL SLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ),
$ LDZ, WV( 1, 1+I2 ), LDWV )
*
* ==== Multiply by U21 ====
*
CALL STRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE,
$ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ),
$ LDWV )
*
* ==== Multiply by U22 ====
*
CALL SGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE,
$ Z( JROW, INCOL+1+J2 ), LDZ,
$ U( J2+1, I2+1 ), LDU, ONE,
$ WV( 1, 1+I2 ), LDWV )
*
* ==== Copy the result back to Z ====
*
CALL SLACPY( 'ALL', JLEN, KDU, WV, LDWV,
$ Z( JROW, INCOL+1 ), LDZ )
210 CONTINUE
END IF
END IF
END IF
220 CONTINUE
*
* ==== End of SLAQR5 ====
*
END
SUBROUTINE SLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER EQUED, UPLO
INTEGER KD, LDAB, N
REAL AMAX, SCOND
* ..
* .. Array Arguments ..
REAL AB( LDAB, * ), S( * )
* ..
*
* Purpose
* =======
*
* SLAQSB equilibrates a symmetric band matrix A using the scaling
* factors in the vector S.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of super-diagonals of the matrix A if UPLO = 'U',
* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
*
* AB (input/output) REAL array, dimension (LDAB,N)
* On entry, the upper or lower triangle of the symmetric band
* matrix A, stored in the first KD+1 rows of the array. The
* j-th column of A is stored in the j-th column of the array AB
* as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*
* On exit, if INFO = 0, the triangular factor U or L from the
* Cholesky factorization A = U'*U or A = L*L' of the band
* matrix A, in the same storage format as A.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* S (input) REAL array, dimension (N)
* The scale factors for A.
*
* SCOND (input) REAL
* Ratio of the smallest S(i) to the largest S(i).
*
* AMAX (input) REAL
* Absolute value of largest matrix entry.
*
* EQUED (output) CHARACTER*1
* Specifies whether or not equilibration was done.
* = 'N': No equilibration.
* = 'Y': Equilibration was done, i.e., A has been replaced by
* diag(S) * A * diag(S).
*
* Internal Parameters
* ===================
*
* THRESH is a threshold value used to decide if scaling should be done
* based on the ratio of the scaling factors. If SCOND < THRESH,
* scaling is done.
*
* LARGE and SMALL are threshold values used to decide if scaling should
* be done based on the absolute size of the largest matrix element.
* If AMAX > LARGE or AMAX < SMALL, scaling is done.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, THRESH
PARAMETER ( ONE = 1.0E+0, THRESH = 0.1E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
REAL CJ, LARGE, SMALL
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH
EXTERNAL LSAME, SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.0 ) THEN
EQUED = 'N'
RETURN
END IF
*
* Initialize LARGE and SMALL.
*
SMALL = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
LARGE = ONE / SMALL
*
IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
*
* No equilibration
*
EQUED = 'N'
ELSE
*
* Replace A by diag(S) * A * diag(S).
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Upper triangle of A is stored in band format.
*
DO 20 J = 1, N
CJ = S( J )
DO 10 I = MAX( 1, J-KD ), J
AB( KD+1+I-J, J ) = CJ*S( I )*AB( KD+1+I-J, J )
10 CONTINUE
20 CONTINUE
ELSE
*
* Lower triangle of A is stored.
*
DO 40 J = 1, N
CJ = S( J )
DO 30 I = J, MIN( N, J+KD )
AB( 1+I-J, J ) = CJ*S( I )*AB( 1+I-J, J )
30 CONTINUE
40 CONTINUE
END IF
EQUED = 'Y'
END IF
*
RETURN
*
* End of SLAQSB
*
END
SUBROUTINE SLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER EQUED, UPLO
INTEGER N
REAL AMAX, SCOND
* ..
* .. Array Arguments ..
REAL AP( * ), S( * )
* ..
*
* Purpose
* =======
*
* SLAQSP equilibrates a symmetric matrix A using the scaling factors
* in the vector S.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input/output) REAL array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* A, packed columnwise in a linear array. The j-th column of A
* is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
*
* On exit, the equilibrated matrix: diag(S) * A * diag(S), in
* the same storage format as A.
*
* S (input) REAL array, dimension (N)
* The scale factors for A.
*
* SCOND (input) REAL
* Ratio of the smallest S(i) to the largest S(i).
*
* AMAX (input) REAL
* Absolute value of largest matrix entry.
*
* EQUED (output) CHARACTER*1
* Specifies whether or not equilibration was done.
* = 'N': No equilibration.
* = 'Y': Equilibration was done, i.e., A has been replaced by
* diag(S) * A * diag(S).
*
* Internal Parameters
* ===================
*
* THRESH is a threshold value used to decide if scaling should be done
* based on the ratio of the scaling factors. If SCOND < THRESH,
* scaling is done.
*
* LARGE and SMALL are threshold values used to decide if scaling should
* be done based on the absolute size of the largest matrix element.
* If AMAX > LARGE or AMAX < SMALL, scaling is done.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, THRESH
PARAMETER ( ONE = 1.0E+0, THRESH = 0.1E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, JC
REAL CJ, LARGE, SMALL
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH
EXTERNAL LSAME, SLAMCH
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.0 ) THEN
EQUED = 'N'
RETURN
END IF
*
* Initialize LARGE and SMALL.
*
SMALL = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
LARGE = ONE / SMALL
*
IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
*
* No equilibration
*
EQUED = 'N'
ELSE
*
* Replace A by diag(S) * A * diag(S).
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Upper triangle of A is stored.
*
JC = 1
DO 20 J = 1, N
CJ = S( J )
DO 10 I = 1, J
AP( JC+I-1 ) = CJ*S( I )*AP( JC+I-1 )
10 CONTINUE
JC = JC + J
20 CONTINUE
ELSE
*
* Lower triangle of A is stored.
*
JC = 1
DO 40 J = 1, N
CJ = S( J )
DO 30 I = J, N
AP( JC+I-J ) = CJ*S( I )*AP( JC+I-J )
30 CONTINUE
JC = JC + N - J + 1
40 CONTINUE
END IF
EQUED = 'Y'
END IF
*
RETURN
*
* End of SLAQSP
*
END
SUBROUTINE SLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER EQUED, UPLO
INTEGER LDA, N
REAL AMAX, SCOND
* ..
* .. Array Arguments ..
REAL A( LDA, * ), S( * )
* ..
*
* Purpose
* =======
*
* SLAQSY equilibrates a symmetric matrix A using the scaling factors
* in the vector S.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the symmetric matrix A. If UPLO = 'U', the leading
* n by n upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading n by n lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced.
*
* On exit, if EQUED = 'Y', the equilibrated matrix:
* diag(S) * A * diag(S).
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(N,1).
*
* S (input) REAL array, dimension (N)
* The scale factors for A.
*
* SCOND (input) REAL
* Ratio of the smallest S(i) to the largest S(i).
*
* AMAX (input) REAL
* Absolute value of largest matrix entry.
*
* EQUED (output) CHARACTER*1
* Specifies whether or not equilibration was done.
* = 'N': No equilibration.
* = 'Y': Equilibration was done, i.e., A has been replaced by
* diag(S) * A * diag(S).
*
* Internal Parameters
* ===================
*
* THRESH is a threshold value used to decide if scaling should be done
* based on the ratio of the scaling factors. If SCOND < THRESH,
* scaling is done.
*
* LARGE and SMALL are threshold values used to decide if scaling should
* be done based on the absolute size of the largest matrix element.
* If AMAX > LARGE or AMAX < SMALL, scaling is done.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, THRESH
PARAMETER ( ONE = 1.0E+0, THRESH = 0.1E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
REAL CJ, LARGE, SMALL
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH
EXTERNAL LSAME, SLAMCH
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.0 ) THEN
EQUED = 'N'
RETURN
END IF
*
* Initialize LARGE and SMALL.
*
SMALL = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
LARGE = ONE / SMALL
*
IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
*
* No equilibration
*
EQUED = 'N'
ELSE
*
* Replace A by diag(S) * A * diag(S).
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Upper triangle of A is stored.
*
DO 20 J = 1, N
CJ = S( J )
DO 10 I = 1, J
A( I, J ) = CJ*S( I )*A( I, J )
10 CONTINUE
20 CONTINUE
ELSE
*
* Lower triangle of A is stored.
*
DO 40 J = 1, N
CJ = S( J )
DO 30 I = J, N
A( I, J ) = CJ*S( I )*A( I, J )
30 CONTINUE
40 CONTINUE
END IF
EQUED = 'Y'
END IF
*
RETURN
*
* End of SLAQSY
*
END
SUBROUTINE SLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK,
$ INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL LREAL, LTRAN
INTEGER INFO, LDT, N
REAL SCALE, W
* ..
* .. Array Arguments ..
REAL B( * ), T( LDT, * ), WORK( * ), X( * )
* ..
*
* Purpose
* =======
*
* SLAQTR solves the real quasi-triangular system
*
* op(T)*p = scale*c, if LREAL = .TRUE.
*
* or the complex quasi-triangular systems
*
* op(T + iB)*(p+iq) = scale*(c+id), if LREAL = .FALSE.
*
* in real arithmetic, where T is upper quasi-triangular.
* If LREAL = .FALSE., then the first diagonal block of T must be
* 1 by 1, B is the specially structured matrix
*
* B = [ b(1) b(2) ... b(n) ]
* [ w ]
* [ w ]
* [ . ]
* [ w ]
*
* op(A) = A or A', A' denotes the conjugate transpose of
* matrix A.
*
* On input, X = [ c ]. On output, X = [ p ].
* [ d ] [ q ]
*
* This subroutine is designed for the condition number estimation
* in routine STRSNA.
*
* Arguments
* =========
*
* LTRAN (input) LOGICAL
* On entry, LTRAN specifies the option of conjugate transpose:
* = .FALSE., op(T+i*B) = T+i*B,
* = .TRUE., op(T+i*B) = (T+i*B)'.
*
* LREAL (input) LOGICAL
* On entry, LREAL specifies the input matrix structure:
* = .FALSE., the input is complex
* = .TRUE., the input is real
*
* N (input) INTEGER
* On entry, N specifies the order of T+i*B. N >= 0.
*
* T (input) REAL array, dimension (LDT,N)
* On entry, T contains a matrix in Schur canonical form.
* If LREAL = .FALSE., then the first diagonal block of T must
* be 1 by 1.
*
* LDT (input) INTEGER
* The leading dimension of the matrix T. LDT >= max(1,N).
*
* B (input) REAL array, dimension (N)
* On entry, B contains the elements to form the matrix
* B as described above.
* If LREAL = .TRUE., B is not referenced.
*
* W (input) REAL
* On entry, W is the diagonal element of the matrix B.
* If LREAL = .TRUE., W is not referenced.
*
* SCALE (output) REAL
* On exit, SCALE is the scale factor.
*
* X (input/output) REAL array, dimension (2*N)
* On entry, X contains the right hand side of the system.
* On exit, X is overwritten by the solution.
*
* WORK (workspace) REAL array, dimension (N)
*
* INFO (output) INTEGER
* On exit, INFO is set to
* 0: successful exit.
* 1: the some diagonal 1 by 1 block has been perturbed by
* a small number SMIN to keep nonsingularity.
* 2: the some diagonal 2 by 2 block has been perturbed by
* a small number in SLALN2 to keep nonsingularity.
* NOTE: In the interests of speed, this routine does not
* check the inputs for errors.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN
INTEGER I, IERR, J, J1, J2, JNEXT, K, N1, N2
REAL BIGNUM, EPS, REC, SCALOC, SI, SMIN, SMINW,
$ SMLNUM, SR, TJJ, TMP, XJ, XMAX, XNORM, Z
* ..
* .. Local Arrays ..
REAL D( 2, 2 ), V( 2, 2 )
* ..
* .. External Functions ..
INTEGER ISAMAX
REAL SASUM, SDOT, SLAMCH, SLANGE
EXTERNAL ISAMAX, SASUM, SDOT, SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SLADIV, SLALN2, SSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Do not test the input parameters for errors
*
NOTRAN = .NOT.LTRAN
INFO = 0
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Set constants to control overflow
*
EPS = SLAMCH( 'P' )
SMLNUM = SLAMCH( 'S' ) / EPS
BIGNUM = ONE / SMLNUM
*
XNORM = SLANGE( 'M', N, N, T, LDT, D )
IF( .NOT.LREAL )
$ XNORM = MAX( XNORM, ABS( W ), SLANGE( 'M', N, 1, B, N, D ) )
SMIN = MAX( SMLNUM, EPS*XNORM )
*
* Compute 1-norm of each column of strictly upper triangular
* part of T to control overflow in triangular solver.
*
WORK( 1 ) = ZERO
DO 10 J = 2, N
WORK( J ) = SASUM( J-1, T( 1, J ), 1 )
10 CONTINUE
*
IF( .NOT.LREAL ) THEN
DO 20 I = 2, N
WORK( I ) = WORK( I ) + ABS( B( I ) )
20 CONTINUE
END IF
*
N2 = 2*N
N1 = N
IF( .NOT.LREAL )
$ N1 = N2
K = ISAMAX( N1, X, 1 )
XMAX = ABS( X( K ) )
SCALE = ONE
*
IF( XMAX.GT.BIGNUM ) THEN
SCALE = BIGNUM / XMAX
CALL SSCAL( N1, SCALE, X, 1 )
XMAX = BIGNUM
END IF
*
IF( LREAL ) THEN
*
IF( NOTRAN ) THEN
*
* Solve T*p = scale*c
*
JNEXT = N
DO 30 J = N, 1, -1
IF( J.GT.JNEXT )
$ GO TO 30
J1 = J
J2 = J
JNEXT = J - 1
IF( J.GT.1 ) THEN
IF( T( J, J-1 ).NE.ZERO ) THEN
J1 = J - 1
JNEXT = J - 2
END IF
END IF
*
IF( J1.EQ.J2 ) THEN
*
* Meet 1 by 1 diagonal block
*
* Scale to avoid overflow when computing
* x(j) = b(j)/T(j,j)
*
XJ = ABS( X( J1 ) )
TJJ = ABS( T( J1, J1 ) )
TMP = T( J1, J1 )
IF( TJJ.LT.SMIN ) THEN
TMP = SMIN
TJJ = SMIN
INFO = 1
END IF
*
IF( XJ.EQ.ZERO )
$ GO TO 30
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.BIGNUM*TJJ ) THEN
REC = ONE / XJ
CALL SSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
X( J1 ) = X( J1 ) / TMP
XJ = ABS( X( J1 ) )
*
* Scale x if necessary to avoid overflow when adding a
* multiple of column j1 of T.
*
IF( XJ.GT.ONE ) THEN
REC = ONE / XJ
IF( WORK( J1 ).GT.( BIGNUM-XMAX )*REC ) THEN
CALL SSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
END IF
END IF
IF( J1.GT.1 ) THEN
CALL SAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
K = ISAMAX( J1-1, X, 1 )
XMAX = ABS( X( K ) )
END IF
*
ELSE
*
* Meet 2 by 2 diagonal block
*
* Call 2 by 2 linear system solve, to take
* care of possible overflow by scaling factor.
*
D( 1, 1 ) = X( J1 )
D( 2, 1 ) = X( J2 )
CALL SLALN2( .FALSE., 2, 1, SMIN, ONE, T( J1, J1 ),
$ LDT, ONE, ONE, D, 2, ZERO, ZERO, V, 2,
$ SCALOC, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 2
*
IF( SCALOC.NE.ONE ) THEN
CALL SSCAL( N, SCALOC, X, 1 )
SCALE = SCALE*SCALOC
END IF
X( J1 ) = V( 1, 1 )
X( J2 ) = V( 2, 1 )
*
* Scale V(1,1) (= X(J1)) and/or V(2,1) (=X(J2))
* to avoid overflow in updating right-hand side.
*
XJ = MAX( ABS( V( 1, 1 ) ), ABS( V( 2, 1 ) ) )
IF( XJ.GT.ONE ) THEN
REC = ONE / XJ
IF( MAX( WORK( J1 ), WORK( J2 ) ).GT.
$ ( BIGNUM-XMAX )*REC ) THEN
CALL SSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
END IF
END IF
*
* Update right-hand side
*
IF( J1.GT.1 ) THEN
CALL SAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
CALL SAXPY( J1-1, -X( J2 ), T( 1, J2 ), 1, X, 1 )
K = ISAMAX( J1-1, X, 1 )
XMAX = ABS( X( K ) )
END IF
*
END IF
*
30 CONTINUE
*
ELSE
*
* Solve T'*p = scale*c
*
JNEXT = 1
DO 40 J = 1, N
IF( J.LT.JNEXT )
$ GO TO 40
J1 = J
J2 = J
JNEXT = J + 1
IF( J.LT.N ) THEN
IF( T( J+1, J ).NE.ZERO ) THEN
J2 = J + 1
JNEXT = J + 2
END IF
END IF
*
IF( J1.EQ.J2 ) THEN
*
* 1 by 1 diagonal block
*
* Scale if necessary to avoid overflow in forming the
* right-hand side element by inner product.
*
XJ = ABS( X( J1 ) )
IF( XMAX.GT.ONE ) THEN
REC = ONE / XMAX
IF( WORK( J1 ).GT.( BIGNUM-XJ )*REC ) THEN
CALL SSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
*
X( J1 ) = X( J1 ) - SDOT( J1-1, T( 1, J1 ), 1, X, 1 )
*
XJ = ABS( X( J1 ) )
TJJ = ABS( T( J1, J1 ) )
TMP = T( J1, J1 )
IF( TJJ.LT.SMIN ) THEN
TMP = SMIN
TJJ = SMIN
INFO = 1
END IF
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.BIGNUM*TJJ ) THEN
REC = ONE / XJ
CALL SSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
X( J1 ) = X( J1 ) / TMP
XMAX = MAX( XMAX, ABS( X( J1 ) ) )
*
ELSE
*
* 2 by 2 diagonal block
*
* Scale if necessary to avoid overflow in forming the
* right-hand side elements by inner product.
*
XJ = MAX( ABS( X( J1 ) ), ABS( X( J2 ) ) )
IF( XMAX.GT.ONE ) THEN
REC = ONE / XMAX
IF( MAX( WORK( J2 ), WORK( J1 ) ).GT.( BIGNUM-XJ )*
$ REC ) THEN
CALL SSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
*
D( 1, 1 ) = X( J1 ) - SDOT( J1-1, T( 1, J1 ), 1, X,
$ 1 )
D( 2, 1 ) = X( J2 ) - SDOT( J1-1, T( 1, J2 ), 1, X,
$ 1 )
*
CALL SLALN2( .TRUE., 2, 1, SMIN, ONE, T( J1, J1 ),
$ LDT, ONE, ONE, D, 2, ZERO, ZERO, V, 2,
$ SCALOC, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 2
*
IF( SCALOC.NE.ONE ) THEN
CALL SSCAL( N, SCALOC, X, 1 )
SCALE = SCALE*SCALOC
END IF
X( J1 ) = V( 1, 1 )
X( J2 ) = V( 2, 1 )
XMAX = MAX( ABS( X( J1 ) ), ABS( X( J2 ) ), XMAX )
*
END IF
40 CONTINUE
END IF
*
ELSE
*
SMINW = MAX( EPS*ABS( W ), SMIN )
IF( NOTRAN ) THEN
*
* Solve (T + iB)*(p+iq) = c+id
*
JNEXT = N
DO 70 J = N, 1, -1
IF( J.GT.JNEXT )
$ GO TO 70
J1 = J
J2 = J
JNEXT = J - 1
IF( J.GT.1 ) THEN
IF( T( J, J-1 ).NE.ZERO ) THEN
J1 = J - 1
JNEXT = J - 2
END IF
END IF
*
IF( J1.EQ.J2 ) THEN
*
* 1 by 1 diagonal block
*
* Scale if necessary to avoid overflow in division
*
Z = W
IF( J1.EQ.1 )
$ Z = B( 1 )
XJ = ABS( X( J1 ) ) + ABS( X( N+J1 ) )
TJJ = ABS( T( J1, J1 ) ) + ABS( Z )
TMP = T( J1, J1 )
IF( TJJ.LT.SMINW ) THEN
TMP = SMINW
TJJ = SMINW
INFO = 1
END IF
*
IF( XJ.EQ.ZERO )
$ GO TO 70
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.BIGNUM*TJJ ) THEN
REC = ONE / XJ
CALL SSCAL( N2, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
CALL SLADIV( X( J1 ), X( N+J1 ), TMP, Z, SR, SI )
X( J1 ) = SR
X( N+J1 ) = SI
XJ = ABS( X( J1 ) ) + ABS( X( N+J1 ) )
*
* Scale x if necessary to avoid overflow when adding a
* multiple of column j1 of T.
*
IF( XJ.GT.ONE ) THEN
REC = ONE / XJ
IF( WORK( J1 ).GT.( BIGNUM-XMAX )*REC ) THEN
CALL SSCAL( N2, REC, X, 1 )
SCALE = SCALE*REC
END IF
END IF
*
IF( J1.GT.1 ) THEN
CALL SAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
CALL SAXPY( J1-1, -X( N+J1 ), T( 1, J1 ), 1,
$ X( N+1 ), 1 )
*
X( 1 ) = X( 1 ) + B( J1 )*X( N+J1 )
X( N+1 ) = X( N+1 ) - B( J1 )*X( J1 )
*
XMAX = ZERO
DO 50 K = 1, J1 - 1
XMAX = MAX( XMAX, ABS( X( K ) )+
$ ABS( X( K+N ) ) )
50 CONTINUE
END IF
*
ELSE
*
* Meet 2 by 2 diagonal block
*
D( 1, 1 ) = X( J1 )
D( 2, 1 ) = X( J2 )
D( 1, 2 ) = X( N+J1 )
D( 2, 2 ) = X( N+J2 )
CALL SLALN2( .FALSE., 2, 2, SMINW, ONE, T( J1, J1 ),
$ LDT, ONE, ONE, D, 2, ZERO, -W, V, 2,
$ SCALOC, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 2
*
IF( SCALOC.NE.ONE ) THEN
CALL SSCAL( 2*N, SCALOC, X, 1 )
SCALE = SCALOC*SCALE
END IF
X( J1 ) = V( 1, 1 )
X( J2 ) = V( 2, 1 )
X( N+J1 ) = V( 1, 2 )
X( N+J2 ) = V( 2, 2 )
*
* Scale X(J1), .... to avoid overflow in
* updating right hand side.
*
XJ = MAX( ABS( V( 1, 1 ) )+ABS( V( 1, 2 ) ),
$ ABS( V( 2, 1 ) )+ABS( V( 2, 2 ) ) )
IF( XJ.GT.ONE ) THEN
REC = ONE / XJ
IF( MAX( WORK( J1 ), WORK( J2 ) ).GT.
$ ( BIGNUM-XMAX )*REC ) THEN
CALL SSCAL( N2, REC, X, 1 )
SCALE = SCALE*REC
END IF
END IF
*
* Update the right-hand side.
*
IF( J1.GT.1 ) THEN
CALL SAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
CALL SAXPY( J1-1, -X( J2 ), T( 1, J2 ), 1, X, 1 )
*
CALL SAXPY( J1-1, -X( N+J1 ), T( 1, J1 ), 1,
$ X( N+1 ), 1 )
CALL SAXPY( J1-1, -X( N+J2 ), T( 1, J2 ), 1,
$ X( N+1 ), 1 )
*
X( 1 ) = X( 1 ) + B( J1 )*X( N+J1 ) +
$ B( J2 )*X( N+J2 )
X( N+1 ) = X( N+1 ) - B( J1 )*X( J1 ) -
$ B( J2 )*X( J2 )
*
XMAX = ZERO
DO 60 K = 1, J1 - 1
XMAX = MAX( ABS( X( K ) )+ABS( X( K+N ) ),
$ XMAX )
60 CONTINUE
END IF
*
END IF
70 CONTINUE
*
ELSE
*
* Solve (T + iB)'*(p+iq) = c+id
*
JNEXT = 1
DO 80 J = 1, N
IF( J.LT.JNEXT )
$ GO TO 80
J1 = J
J2 = J
JNEXT = J + 1
IF( J.LT.N ) THEN
IF( T( J+1, J ).NE.ZERO ) THEN
J2 = J + 1
JNEXT = J + 2
END IF
END IF
*
IF( J1.EQ.J2 ) THEN
*
* 1 by 1 diagonal block
*
* Scale if necessary to avoid overflow in forming the
* right-hand side element by inner product.
*
XJ = ABS( X( J1 ) ) + ABS( X( J1+N ) )
IF( XMAX.GT.ONE ) THEN
REC = ONE / XMAX
IF( WORK( J1 ).GT.( BIGNUM-XJ )*REC ) THEN
CALL SSCAL( N2, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
*
X( J1 ) = X( J1 ) - SDOT( J1-1, T( 1, J1 ), 1, X, 1 )
X( N+J1 ) = X( N+J1 ) - SDOT( J1-1, T( 1, J1 ), 1,
$ X( N+1 ), 1 )
IF( J1.GT.1 ) THEN
X( J1 ) = X( J1 ) - B( J1 )*X( N+1 )
X( N+J1 ) = X( N+J1 ) + B( J1 )*X( 1 )
END IF
XJ = ABS( X( J1 ) ) + ABS( X( J1+N ) )
*
Z = W
IF( J1.EQ.1 )
$ Z = B( 1 )
*
* Scale if necessary to avoid overflow in
* complex division
*
TJJ = ABS( T( J1, J1 ) ) + ABS( Z )
TMP = T( J1, J1 )
IF( TJJ.LT.SMINW ) THEN
TMP = SMINW
TJJ = SMINW
INFO = 1
END IF
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.BIGNUM*TJJ ) THEN
REC = ONE / XJ
CALL SSCAL( N2, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
CALL SLADIV( X( J1 ), X( N+J1 ), TMP, -Z, SR, SI )
X( J1 ) = SR
X( J1+N ) = SI
XMAX = MAX( ABS( X( J1 ) )+ABS( X( J1+N ) ), XMAX )
*
ELSE
*
* 2 by 2 diagonal block
*
* Scale if necessary to avoid overflow in forming the
* right-hand side element by inner product.
*
XJ = MAX( ABS( X( J1 ) )+ABS( X( N+J1 ) ),
$ ABS( X( J2 ) )+ABS( X( N+J2 ) ) )
IF( XMAX.GT.ONE ) THEN
REC = ONE / XMAX
IF( MAX( WORK( J1 ), WORK( J2 ) ).GT.
$ ( BIGNUM-XJ ) / XMAX ) THEN
CALL SSCAL( N2, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
*
D( 1, 1 ) = X( J1 ) - SDOT( J1-1, T( 1, J1 ), 1, X,
$ 1 )
D( 2, 1 ) = X( J2 ) - SDOT( J1-1, T( 1, J2 ), 1, X,
$ 1 )
D( 1, 2 ) = X( N+J1 ) - SDOT( J1-1, T( 1, J1 ), 1,
$ X( N+1 ), 1 )
D( 2, 2 ) = X( N+J2 ) - SDOT( J1-1, T( 1, J2 ), 1,
$ X( N+1 ), 1 )
D( 1, 1 ) = D( 1, 1 ) - B( J1 )*X( N+1 )
D( 2, 1 ) = D( 2, 1 ) - B( J2 )*X( N+1 )
D( 1, 2 ) = D( 1, 2 ) + B( J1 )*X( 1 )
D( 2, 2 ) = D( 2, 2 ) + B( J2 )*X( 1 )
*
CALL SLALN2( .TRUE., 2, 2, SMINW, ONE, T( J1, J1 ),
$ LDT, ONE, ONE, D, 2, ZERO, W, V, 2,
$ SCALOC, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 2
*
IF( SCALOC.NE.ONE ) THEN
CALL SSCAL( N2, SCALOC, X, 1 )
SCALE = SCALOC*SCALE
END IF
X( J1 ) = V( 1, 1 )
X( J2 ) = V( 2, 1 )
X( N+J1 ) = V( 1, 2 )
X( N+J2 ) = V( 2, 2 )
XMAX = MAX( ABS( X( J1 ) )+ABS( X( N+J1 ) ),
$ ABS( X( J2 ) )+ABS( X( N+J2 ) ), XMAX )
*
END IF
*
80 CONTINUE
*
END IF
*
END IF
*
RETURN
*
* End of SLAQTR
*
END
SUBROUTINE SLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD,
$ PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA,
$ R, ISUPPZ, NRMINV, RESID, RQCORR, WORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL WANTNC
INTEGER B1, BN, N, NEGCNT, R
REAL GAPTOL, LAMBDA, MINGMA, NRMINV, PIVMIN, RESID,
$ RQCORR, ZTZ
* ..
* .. Array Arguments ..
INTEGER ISUPPZ( * )
REAL D( * ), L( * ), LD( * ), LLD( * ),
$ WORK( * )
REAL Z( * )
* ..
*
* Purpose
* =======
*
* SLAR1V computes the (scaled) r-th column of the inverse of
* the sumbmatrix in rows B1 through BN of the tridiagonal matrix
* L D L^T - sigma I. When sigma is close to an eigenvalue, the
* computed vector is an accurate eigenvector. Usually, r corresponds
* to the index where the eigenvector is largest in magnitude.
* The following steps accomplish this computation :
* (a) Stationary qd transform, L D L^T - sigma I = L(+) D(+) L(+)^T,
* (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T,
* (c) Computation of the diagonal elements of the inverse of
* L D L^T - sigma I by combining the above transforms, and choosing
* r as the index where the diagonal of the inverse is (one of the)
* largest in magnitude.
* (d) Computation of the (scaled) r-th column of the inverse using the
* twisted factorization obtained by combining the top part of the
* the stationary and the bottom part of the progressive transform.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix L D L^T.
*
* B1 (input) INTEGER
* First index of the submatrix of L D L^T.
*
* BN (input) INTEGER
* Last index of the submatrix of L D L^T.
*
* LAMBDA (input) REAL
* The shift. In order to compute an accurate eigenvector,
* LAMBDA should be a good approximation to an eigenvalue
* of L D L^T.
*
* L (input) REAL array, dimension (N-1)
* The (n-1) subdiagonal elements of the unit bidiagonal matrix
* L, in elements 1 to N-1.
*
* D (input) REAL array, dimension (N)
* The n diagonal elements of the diagonal matrix D.
*
* LD (input) REAL array, dimension (N-1)
* The n-1 elements L(i)*D(i).
*
* LLD (input) REAL array, dimension (N-1)
* The n-1 elements L(i)*L(i)*D(i).
*
* PIVMIN (input) REAL
* The minimum pivot in the Sturm sequence.
*
* GAPTOL (input) REAL
* Tolerance that indicates when eigenvector entries are negligible
* w.r.t. their contribution to the residual.
*
* Z (input/output) REAL array, dimension (N)
* On input, all entries of Z must be set to 0.
* On output, Z contains the (scaled) r-th column of the
* inverse. The scaling is such that Z(R) equals 1.
*
* WANTNC (input) LOGICAL
* Specifies whether NEGCNT has to be computed.
*
* NEGCNT (output) INTEGER
* If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin
* in the matrix factorization L D L^T, and NEGCNT = -1 otherwise.
*
* ZTZ (output) REAL
* The square of the 2-norm of Z.
*
* MINGMA (output) REAL
* The reciprocal of the largest (in magnitude) diagonal
* element of the inverse of L D L^T - sigma I.
*
* R (input/output) INTEGER
* The twist index for the twisted factorization used to
* compute Z.
* On input, 0 <= R <= N. If R is input as 0, R is set to
* the index where (L D L^T - sigma I)^{-1} is largest
* in magnitude. If 1 <= R <= N, R is unchanged.
* On output, R contains the twist index used to compute Z.
* Ideally, R designates the position of the maximum entry in the
* eigenvector.
*
* ISUPPZ (output) INTEGER array, dimension (2)
* The support of the vector in Z, i.e., the vector Z is
* nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ).
*
* NRMINV (output) REAL
* NRMINV = 1/SQRT( ZTZ )
*
* RESID (output) REAL
* The residual of the FP vector.
* RESID = ABS( MINGMA )/SQRT( ZTZ )
*
* RQCORR (output) REAL
* The Rayleigh Quotient correction to LAMBDA.
* RQCORR = MINGMA*TMP
*
* WORK (workspace) REAL array, dimension (4*N)
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL SAWNAN1, SAWNAN2
INTEGER I, INDLPL, INDP, INDS, INDUMN, NEG1, NEG2, R1,
$ R2
REAL DMINUS, DPLUS, EPS, S, TMP
* ..
* .. External Functions ..
LOGICAL SISNAN
REAL SLAMCH
EXTERNAL SISNAN, SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
EPS = SLAMCH( 'Precision' )
IF( R.EQ.0 ) THEN
R1 = B1
R2 = BN
ELSE
R1 = R
R2 = R
END IF
* Storage for LPLUS
INDLPL = 0
* Storage for UMINUS
INDUMN = N
INDS = 2*N + 1
INDP = 3*N + 1
IF( B1.EQ.1 ) THEN
WORK( INDS ) = ZERO
ELSE
WORK( INDS+B1-1 ) = LLD( B1-1 )
END IF
*
* Compute the stationary transform (using the differential form)
* until the index R2.
*
SAWNAN1 = .FALSE.
NEG1 = 0
S = WORK( INDS+B1-1 ) - LAMBDA
DO 50 I = B1, R1 - 1
DPLUS = D( I ) + S
WORK( INDLPL+I ) = LD( I ) / DPLUS
IF(DPLUS.LT.ZERO) NEG1 = NEG1 + 1
WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
S = WORK( INDS+I ) - LAMBDA
50 CONTINUE
SAWNAN1 = SISNAN( S )
IF( SAWNAN1 ) GOTO 60
DO 51 I = R1, R2 - 1
DPLUS = D( I ) + S
WORK( INDLPL+I ) = LD( I ) / DPLUS
WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
S = WORK( INDS+I ) - LAMBDA
51 CONTINUE
SAWNAN1 = SISNAN( S )
*
60 CONTINUE
IF( SAWNAN1 ) THEN
* Runs a slower version of the above loop if a NaN is detected
NEG1 = 0
S = WORK( INDS+B1-1 ) - LAMBDA
DO 70 I = B1, R1 - 1
DPLUS = D( I ) + S
IF(ABS(DPLUS).LT.PIVMIN) DPLUS = -PIVMIN
WORK( INDLPL+I ) = LD( I ) / DPLUS
IF(DPLUS.LT.ZERO) NEG1 = NEG1 + 1
WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
IF( WORK( INDLPL+I ).EQ.ZERO )
$ WORK( INDS+I ) = LLD( I )
S = WORK( INDS+I ) - LAMBDA
70 CONTINUE
DO 71 I = R1, R2 - 1
DPLUS = D( I ) + S
IF(ABS(DPLUS).LT.PIVMIN) DPLUS = -PIVMIN
WORK( INDLPL+I ) = LD( I ) / DPLUS
WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
IF( WORK( INDLPL+I ).EQ.ZERO )
$ WORK( INDS+I ) = LLD( I )
S = WORK( INDS+I ) - LAMBDA
71 CONTINUE
END IF
*
* Compute the progressive transform (using the differential form)
* until the index R1
*
SAWNAN2 = .FALSE.
NEG2 = 0
WORK( INDP+BN-1 ) = D( BN ) - LAMBDA
DO 80 I = BN - 1, R1, -1
DMINUS = LLD( I ) + WORK( INDP+I )
TMP = D( I ) / DMINUS
IF(DMINUS.LT.ZERO) NEG2 = NEG2 + 1
WORK( INDUMN+I ) = L( I )*TMP
WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - LAMBDA
80 CONTINUE
TMP = WORK( INDP+R1-1 )
SAWNAN2 = SISNAN( TMP )
IF( SAWNAN2 ) THEN
* Runs a slower version of the above loop if a NaN is detected
NEG2 = 0
DO 100 I = BN-1, R1, -1
DMINUS = LLD( I ) + WORK( INDP+I )
IF(ABS(DMINUS).LT.PIVMIN) DMINUS = -PIVMIN
TMP = D( I ) / DMINUS
IF(DMINUS.LT.ZERO) NEG2 = NEG2 + 1
WORK( INDUMN+I ) = L( I )*TMP
WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - LAMBDA
IF( TMP.EQ.ZERO )
$ WORK( INDP+I-1 ) = D( I ) - LAMBDA
100 CONTINUE
END IF
*
* Find the index (from R1 to R2) of the largest (in magnitude)
* diagonal element of the inverse
*
MINGMA = WORK( INDS+R1-1 ) + WORK( INDP+R1-1 )
IF( MINGMA.LT.ZERO ) NEG1 = NEG1 + 1
IF( WANTNC ) THEN
NEGCNT = NEG1 + NEG2
ELSE
NEGCNT = -1
ENDIF
IF( ABS(MINGMA).EQ.ZERO )
$ MINGMA = EPS*WORK( INDS+R1-1 )
R = R1
DO 110 I = R1, R2 - 1
TMP = WORK( INDS+I ) + WORK( INDP+I )
IF( TMP.EQ.ZERO )
$ TMP = EPS*WORK( INDS+I )
IF( ABS( TMP ).LE.ABS( MINGMA ) ) THEN
MINGMA = TMP
R = I + 1
END IF
110 CONTINUE
*
* Compute the FP vector: solve N^T v = e_r
*
ISUPPZ( 1 ) = B1
ISUPPZ( 2 ) = BN
Z( R ) = ONE
ZTZ = ONE
*
* Compute the FP vector upwards from R
*
IF( .NOT.SAWNAN1 .AND. .NOT.SAWNAN2 ) THEN
DO 210 I = R-1, B1, -1
Z( I ) = -( WORK( INDLPL+I )*Z( I+1 ) )
IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
$ THEN
Z( I ) = ZERO
ISUPPZ( 1 ) = I + 1
GOTO 220
ENDIF
ZTZ = ZTZ + Z( I )*Z( I )
210 CONTINUE
220 CONTINUE
ELSE
* Run slower loop if NaN occurred.
DO 230 I = R - 1, B1, -1
IF( Z( I+1 ).EQ.ZERO ) THEN
Z( I ) = -( LD( I+1 ) / LD( I ) )*Z( I+2 )
ELSE
Z( I ) = -( WORK( INDLPL+I )*Z( I+1 ) )
END IF
IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
$ THEN
Z( I ) = ZERO
ISUPPZ( 1 ) = I + 1
GO TO 240
END IF
ZTZ = ZTZ + Z( I )*Z( I )
230 CONTINUE
240 CONTINUE
ENDIF
* Compute the FP vector downwards from R in blocks of size BLKSIZ
IF( .NOT.SAWNAN1 .AND. .NOT.SAWNAN2 ) THEN
DO 250 I = R, BN-1
Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) )
IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
$ THEN
Z( I+1 ) = ZERO
ISUPPZ( 2 ) = I
GO TO 260
END IF
ZTZ = ZTZ + Z( I+1 )*Z( I+1 )
250 CONTINUE
260 CONTINUE
ELSE
* Run slower loop if NaN occurred.
DO 270 I = R, BN - 1
IF( Z( I ).EQ.ZERO ) THEN
Z( I+1 ) = -( LD( I-1 ) / LD( I ) )*Z( I-1 )
ELSE
Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) )
END IF
IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
$ THEN
Z( I+1 ) = ZERO
ISUPPZ( 2 ) = I
GO TO 280
END IF
ZTZ = ZTZ + Z( I+1 )*Z( I+1 )
270 CONTINUE
280 CONTINUE
END IF
*
* Compute quantities for convergence test
*
TMP = ONE / ZTZ
NRMINV = SQRT( TMP )
RESID = ABS( MINGMA )*NRMINV
RQCORR = MINGMA*TMP
*
*
RETURN
*
* End of SLAR1V
*
END
SUBROUTINE SLAR2V( N, X, Y, Z, INCX, C, S, INCC )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INCC, INCX, N
* ..
* .. Array Arguments ..
REAL C( * ), S( * ), X( * ), Y( * ), Z( * )
* ..
*
* Purpose
* =======
*
* SLAR2V applies a vector of real plane rotations from both sides to
* a sequence of 2-by-2 real symmetric matrices, defined by the elements
* of the vectors x, y and z. For i = 1,2,...,n
*
* ( x(i) z(i) ) := ( c(i) s(i) ) ( x(i) z(i) ) ( c(i) -s(i) )
* ( z(i) y(i) ) ( -s(i) c(i) ) ( z(i) y(i) ) ( s(i) c(i) )
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of plane rotations to be applied.
*
* X (input/output) REAL array,
* dimension (1+(N-1)*INCX)
* The vector x.
*
* Y (input/output) REAL array,
* dimension (1+(N-1)*INCX)
* The vector y.
*
* Z (input/output) REAL array,
* dimension (1+(N-1)*INCX)
* The vector z.
*
* INCX (input) INTEGER
* The increment between elements of X, Y and Z. INCX > 0.
*
* C (input) REAL array, dimension (1+(N-1)*INCC)
* The cosines of the plane rotations.
*
* S (input) REAL array, dimension (1+(N-1)*INCC)
* The sines of the plane rotations.
*
* INCC (input) INTEGER
* The increment between elements of C and S. INCC > 0.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, IC, IX
REAL CI, SI, T1, T2, T3, T4, T5, T6, XI, YI, ZI
* ..
* .. Executable Statements ..
*
IX = 1
IC = 1
DO 10 I = 1, N
XI = X( IX )
YI = Y( IX )
ZI = Z( IX )
CI = C( IC )
SI = S( IC )
T1 = SI*ZI
T2 = CI*ZI
T3 = T2 - SI*XI
T4 = T2 + SI*YI
T5 = CI*XI + T1
T6 = CI*YI - T1
X( IX ) = CI*T5 + SI*T4
Y( IX ) = CI*T6 - SI*T3
Z( IX ) = CI*T4 - SI*T5
IX = IX + INCX
IC = IC + INCC
10 CONTINUE
*
* End of SLAR2V
*
RETURN
END
SUBROUTINE SLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE
INTEGER INCV, LDC, M, N
REAL TAU
* ..
* .. Array Arguments ..
REAL C( LDC, * ), V( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SLARF 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'
*
* 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) REAL 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) REAL
* The value tau in the representation of H.
*
* C (input/output) REAL 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) REAL array, dimension
* (N) if SIDE = 'L'
* or (M) if SIDE = 'R'
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. External Subroutines ..
EXTERNAL SGEMV, SGER
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Executable Statements ..
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form H * C
*
IF( TAU.NE.ZERO ) THEN
*
* w := C' * v
*
CALL SGEMV( 'Transpose', M, N, ONE, C, LDC, V, INCV, ZERO,
$ WORK, 1 )
*
* C := C - v * w'
*
CALL SGER( M, N, -TAU, V, INCV, WORK, 1, C, LDC )
END IF
ELSE
*
* Form C * H
*
IF( TAU.NE.ZERO ) THEN
*
* w := C * v
*
CALL SGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV,
$ ZERO, WORK, 1 )
*
* C := C - w * v'
*
CALL SGER( M, N, -TAU, WORK, 1, V, INCV, C, LDC )
END IF
END IF
RETURN
*
* End of SLARF
*
END
SUBROUTINE SLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
$ T, LDT, C, LDC, WORK, LDWORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIRECT, SIDE, STOREV, TRANS
INTEGER K, LDC, LDT, LDV, LDWORK, M, N
* ..
* .. Array Arguments ..
REAL C( LDC, * ), T( LDT, * ), V( LDV, * ),
$ WORK( LDWORK, * )
* ..
*
* Purpose
* =======
*
* SLARFB applies a real block reflector H or its transpose H' 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' from the Left
* = 'R': apply H or H' from the Right
*
* TRANS (input) CHARACTER*1
* = 'N': apply H (No transpose)
* = 'T': apply H' (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) REAL 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) REAL 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) REAL array, dimension (LDC,N)
* On entry, the m by n matrix C.
* On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
*
* LDC (input) INTEGER
* The leading dimension of the array C. LDA >= max(1,M).
*
* WORK (workspace) REAL 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).
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
CHARACTER TRANST
INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMM, STRMM
* ..
* .. 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' * C where C = ( C1 )
* ( C2 )
*
* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK)
*
* W := C1'
*
DO 10 J = 1, K
CALL SCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
10 CONTINUE
*
* W := W * V1
*
CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
$ K, ONE, V, LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C2'*V2
*
CALL SGEMM( 'Transpose', 'No transpose', N, K, M-K,
$ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV,
$ ONE, WORK, LDWORK )
END IF
*
* W := W * T' or W * T
*
CALL STRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W'
*
IF( M.GT.K ) THEN
*
* C2 := C2 - V2 * W'
*
CALL SGEMM( 'No transpose', 'Transpose', M-K, N, K,
$ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE,
$ C( K+1, 1 ), LDC )
END IF
*
* W := W * V1'
*
CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
$ ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W'
*
DO 30 J = 1, K
DO 20 I = 1, N
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' where C = ( C1 C2 )
*
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
*
* W := C1
*
DO 40 J = 1, K
CALL SCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
40 CONTINUE
*
* W := W * V1
*
CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
$ K, ONE, V, LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C2 * V2
*
CALL SGEMM( 'No transpose', 'No transpose', M, K, N-K,
$ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
$ ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T'
*
CALL STRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V'
*
IF( N.GT.K ) THEN
*
* C2 := C2 - W * V2'
*
CALL SGEMM( 'No transpose', 'Transpose', M, N-K, K,
$ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE,
$ C( 1, K+1 ), LDC )
END IF
*
* W := W * V1'
*
CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
$ ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 60 J = 1, K
DO 50 I = 1, M
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' * C where C = ( C1 )
* ( C2 )
*
* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK)
*
* W := C2'
*
DO 70 J = 1, K
CALL SCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
70 CONTINUE
*
* W := W * V2
*
CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
$ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C1'*V1
*
CALL SGEMM( 'Transpose', 'No transpose', N, K, M-K,
$ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T' or W * T
*
CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W'
*
IF( M.GT.K ) THEN
*
* C1 := C1 - V1 * W'
*
CALL SGEMM( 'No transpose', 'Transpose', M-K, N, K,
$ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
END IF
*
* W := W * V2'
*
CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
$ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
*
* C2 := C2 - W'
*
DO 90 J = 1, K
DO 80 I = 1, N
C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
80 CONTINUE
90 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H' where C = ( C1 C2 )
*
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
*
* W := C2
*
DO 100 J = 1, K
CALL SCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
100 CONTINUE
*
* W := W * V2
*
CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
$ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C1 * V1
*
CALL SGEMM( 'No transpose', 'No transpose', M, K, N-K,
$ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T'
*
CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V'
*
IF( N.GT.K ) THEN
*
* C1 := C1 - W * V1'
*
CALL SGEMM( 'No transpose', 'Transpose', M, N-K, K,
$ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
END IF
*
* W := W * V2'
*
CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
$ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
*
* C2 := C2 - W
*
DO 120 J = 1, K
DO 110 I = 1, M
C( I, N-K+J ) = C( I, N-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' * C where C = ( C1 )
* ( C2 )
*
* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK)
*
* W := C1'
*
DO 130 J = 1, K
CALL SCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
130 CONTINUE
*
* W := W * V1'
*
CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
$ ONE, V, LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C2'*V2'
*
CALL SGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
$ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE,
$ WORK, LDWORK )
END IF
*
* W := W * T' or W * T
*
CALL STRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V' * W'
*
IF( M.GT.K ) THEN
*
* C2 := C2 - V2' * W'
*
CALL SGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
$ V( 1, K+1 ), LDV, WORK, LDWORK, ONE,
$ C( K+1, 1 ), LDC )
END IF
*
* W := W * V1
*
CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
$ K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W'
*
DO 150 J = 1, K
DO 140 I = 1, N
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' where C = ( C1 C2 )
*
* W := C * V' = (C1*V1' + C2*V2') (stored in WORK)
*
* W := C1
*
DO 160 J = 1, K
CALL SCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
160 CONTINUE
*
* W := W * V1'
*
CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
$ ONE, V, LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C2 * V2'
*
CALL SGEMM( 'No transpose', 'Transpose', M, K, N-K,
$ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV,
$ ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T'
*
CALL STRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V
*
IF( N.GT.K ) THEN
*
* C2 := C2 - W * V2
*
CALL SGEMM( 'No transpose', 'No transpose', M, N-K, K,
$ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE,
$ C( 1, K+1 ), LDC )
END IF
*
* W := W * V1
*
CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
$ K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 180 J = 1, K
DO 170 I = 1, M
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' * C where C = ( C1 )
* ( C2 )
*
* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK)
*
* W := C2'
*
DO 190 J = 1, K
CALL SCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
190 CONTINUE
*
* W := W * V2'
*
CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
$ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C1'*V1'
*
CALL SGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
$ C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T' or W * T
*
CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V' * W'
*
IF( M.GT.K ) THEN
*
* C1 := C1 - V1' * W'
*
CALL SGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
$ V, LDV, WORK, LDWORK, ONE, C, LDC )
END IF
*
* W := W * V2
*
CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
$ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
*
* C2 := C2 - W'
*
DO 210 J = 1, K
DO 200 I = 1, N
C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
200 CONTINUE
210 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H' where C = ( C1 C2 )
*
* W := C * V' = (C1*V1' + C2*V2') (stored in WORK)
*
* W := C2
*
DO 220 J = 1, K
CALL SCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
220 CONTINUE
*
* W := W * V2'
*
CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
$ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C1 * V1'
*
CALL SGEMM( 'No transpose', 'Transpose', M, K, N-K,
$ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T'
*
CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V
*
IF( N.GT.K ) THEN
*
* C1 := C1 - W * V1
*
CALL SGEMM( 'No transpose', 'No transpose', M, N-K, K,
$ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
END IF
*
* W := W * V2
*
CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
$ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 240 J = 1, K
DO 230 I = 1, M
C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
230 CONTINUE
240 CONTINUE
*
END IF
*
END IF
END IF
*
RETURN
*
* End of SLARFB
*
END
SUBROUTINE SLARFG( N, ALPHA, X, INCX, TAU )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INCX, N
REAL ALPHA, TAU
* ..
* .. Array Arguments ..
REAL X( * )
* ..
*
* Purpose
* =======
*
* SLARFG generates a real elementary reflector H of order n, such
* that
*
* H * ( alpha ) = ( beta ), H' * 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' ) ,
* ( 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) REAL
* On entry, the value alpha.
* On exit, it is overwritten with the value beta.
*
* X (input/output) REAL 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) REAL
* The value tau.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER J, KNT
REAL BETA, RSAFMN, SAFMIN, XNORM
* ..
* .. External Functions ..
REAL SLAMCH, SLAPY2, SNRM2
EXTERNAL SLAMCH, SLAPY2, SNRM2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SIGN
* ..
* .. External Subroutines ..
EXTERNAL SSCAL
* ..
* .. Executable Statements ..
*
IF( N.LE.1 ) THEN
TAU = ZERO
RETURN
END IF
*
XNORM = SNRM2( N-1, X, INCX )
*
IF( XNORM.EQ.ZERO ) THEN
*
* H = I
*
TAU = ZERO
ELSE
*
* general case
*
BETA = -SIGN( SLAPY2( ALPHA, XNORM ), ALPHA )
SAFMIN = SLAMCH( 'S' ) / SLAMCH( 'E' )
IF( ABS( BETA ).LT.SAFMIN ) THEN
*
* XNORM, BETA may be inaccurate; scale X and recompute them
*
RSAFMN = ONE / SAFMIN
KNT = 0
10 CONTINUE
KNT = KNT + 1
CALL SSCAL( 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 = SNRM2( N-1, X, INCX )
BETA = -SIGN( SLAPY2( ALPHA, XNORM ), ALPHA )
TAU = ( BETA-ALPHA ) / BETA
CALL SSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
*
* If ALPHA is subnormal, it may lose relative accuracy
*
ALPHA = BETA
DO 20 J = 1, KNT
ALPHA = ALPHA*SAFMIN
20 CONTINUE
ELSE
TAU = ( BETA-ALPHA ) / BETA
CALL SSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
ALPHA = BETA
END IF
END IF
*
RETURN
*
* End of SLARFG
*
END
SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIRECT, STOREV
INTEGER K, LDT, LDV, N
* ..
* .. Array Arguments ..
REAL T( LDT, * ), TAU( * ), V( LDV, * )
* ..
*
* Purpose
* =======
*
* SLARFT 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'
*
* 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 * 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) REAL 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) REAL array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i).
*
* T (output) REAL 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 ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
REAL VII
* ..
* .. External Subroutines ..
EXTERNAL SGEMV, STRMV
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 20 I = 1, K
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
*
* T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i)
*
CALL SGEMV( 'Transpose', N-I+1, I-1, -TAU( I ),
$ V( I, 1 ), LDV, V( I, I ), 1, ZERO,
$ T( 1, I ), 1 )
ELSE
*
* T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)'
*
CALL SGEMV( 'No transpose', I-1, N-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 STRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T,
$ LDT, T( 1, I ), 1 )
T( I, I ) = TAU( I )
END IF
20 CONTINUE
ELSE
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
*
* T(i+1:k,i) :=
* - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i)
*
CALL SGEMV( 'Transpose', N-K+I, K-I, -TAU( I ),
$ V( 1, I+1 ), LDV, V( 1, 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
*
* T(i+1:k,i) :=
* - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)'
*
CALL SGEMV( 'No transpose', K-I, N-K+I, -TAU( I ),
$ V( I+1, 1 ), LDV, V( I, 1 ), 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 STRMV( 'Lower', 'No transpose', 'Non-unit', K-I,
$ T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
END IF
T( I, I ) = TAU( I )
END IF
40 CONTINUE
END IF
RETURN
*
* End of SLARFT
*
END
SUBROUTINE SLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE
INTEGER LDC, M, N
REAL TAU
* ..
* .. Array Arguments ..
REAL C( LDC, * ), V( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SLARFX 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'
*
* where tau is a real scalar and v is a real vector.
*
* If tau = 0, then H is taken to be the unit matrix
*
* This version uses inline code if H has order < 11.
*
* 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) REAL array, dimension (M) if SIDE = 'L'
* or (N) if SIDE = 'R'
* The vector v in the representation of H.
*
* TAU (input) REAL
* The value tau in the representation of H.
*
* C (input/output) REAL 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. LDA >= (1,M).
*
* WORK (workspace) REAL array, dimension
* (N) if SIDE = 'L'
* or (M) if SIDE = 'R'
* WORK is not referenced if H has order < 11.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER J
REAL SUM, T1, T10, T2, T3, T4, T5, T6, T7, T8, T9,
$ V1, V10, V2, V3, V4, V5, V6, V7, V8, V9
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SGEMV, SGER
* ..
* .. Executable Statements ..
*
IF( TAU.EQ.ZERO )
$ RETURN
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form H * C, where H has order m.
*
GO TO ( 10, 30, 50, 70, 90, 110, 130, 150,
$ 170, 190 )M
*
* Code for general M
*
* w := C'*v
*
CALL SGEMV( 'Transpose', M, N, ONE, C, LDC, V, 1, ZERO, WORK,
$ 1 )
*
* C := C - tau * v * w'
*
CALL SGER( M, N, -TAU, V, 1, WORK, 1, C, LDC )
GO TO 410
10 CONTINUE
*
* Special code for 1 x 1 Householder
*
T1 = ONE - TAU*V( 1 )*V( 1 )
DO 20 J = 1, N
C( 1, J ) = T1*C( 1, J )
20 CONTINUE
GO TO 410
30 CONTINUE
*
* Special code for 2 x 2 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
DO 40 J = 1, N
SUM = V1*C( 1, J ) + V2*C( 2, J )
C( 1, J ) = C( 1, J ) - SUM*T1
C( 2, J ) = C( 2, J ) - SUM*T2
40 CONTINUE
GO TO 410
50 CONTINUE
*
* Special code for 3 x 3 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
DO 60 J = 1, N
SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J )
C( 1, J ) = C( 1, J ) - SUM*T1
C( 2, J ) = C( 2, J ) - SUM*T2
C( 3, J ) = C( 3, J ) - SUM*T3
60 CONTINUE
GO TO 410
70 CONTINUE
*
* Special code for 4 x 4 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
V4 = V( 4 )
T4 = TAU*V4
DO 80 J = 1, N
SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
$ V4*C( 4, J )
C( 1, J ) = C( 1, J ) - SUM*T1
C( 2, J ) = C( 2, J ) - SUM*T2
C( 3, J ) = C( 3, J ) - SUM*T3
C( 4, J ) = C( 4, J ) - SUM*T4
80 CONTINUE
GO TO 410
90 CONTINUE
*
* Special code for 5 x 5 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
V4 = V( 4 )
T4 = TAU*V4
V5 = V( 5 )
T5 = TAU*V5
DO 100 J = 1, N
SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
$ V4*C( 4, J ) + V5*C( 5, J )
C( 1, J ) = C( 1, J ) - SUM*T1
C( 2, J ) = C( 2, J ) - SUM*T2
C( 3, J ) = C( 3, J ) - SUM*T3
C( 4, J ) = C( 4, J ) - SUM*T4
C( 5, J ) = C( 5, J ) - SUM*T5
100 CONTINUE
GO TO 410
110 CONTINUE
*
* Special code for 6 x 6 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
V4 = V( 4 )
T4 = TAU*V4
V5 = V( 5 )
T5 = TAU*V5
V6 = V( 6 )
T6 = TAU*V6
DO 120 J = 1, N
SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
$ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J )
C( 1, J ) = C( 1, J ) - SUM*T1
C( 2, J ) = C( 2, J ) - SUM*T2
C( 3, J ) = C( 3, J ) - SUM*T3
C( 4, J ) = C( 4, J ) - SUM*T4
C( 5, J ) = C( 5, J ) - SUM*T5
C( 6, J ) = C( 6, J ) - SUM*T6
120 CONTINUE
GO TO 410
130 CONTINUE
*
* Special code for 7 x 7 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
V4 = V( 4 )
T4 = TAU*V4
V5 = V( 5 )
T5 = TAU*V5
V6 = V( 6 )
T6 = TAU*V6
V7 = V( 7 )
T7 = TAU*V7
DO 140 J = 1, N
SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
$ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
$ V7*C( 7, J )
C( 1, J ) = C( 1, J ) - SUM*T1
C( 2, J ) = C( 2, J ) - SUM*T2
C( 3, J ) = C( 3, J ) - SUM*T3
C( 4, J ) = C( 4, J ) - SUM*T4
C( 5, J ) = C( 5, J ) - SUM*T5
C( 6, J ) = C( 6, J ) - SUM*T6
C( 7, J ) = C( 7, J ) - SUM*T7
140 CONTINUE
GO TO 410
150 CONTINUE
*
* Special code for 8 x 8 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
V4 = V( 4 )
T4 = TAU*V4
V5 = V( 5 )
T5 = TAU*V5
V6 = V( 6 )
T6 = TAU*V6
V7 = V( 7 )
T7 = TAU*V7
V8 = V( 8 )
T8 = TAU*V8
DO 160 J = 1, N
SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
$ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
$ V7*C( 7, J ) + V8*C( 8, J )
C( 1, J ) = C( 1, J ) - SUM*T1
C( 2, J ) = C( 2, J ) - SUM*T2
C( 3, J ) = C( 3, J ) - SUM*T3
C( 4, J ) = C( 4, J ) - SUM*T4
C( 5, J ) = C( 5, J ) - SUM*T5
C( 6, J ) = C( 6, J ) - SUM*T6
C( 7, J ) = C( 7, J ) - SUM*T7
C( 8, J ) = C( 8, J ) - SUM*T8
160 CONTINUE
GO TO 410
170 CONTINUE
*
* Special code for 9 x 9 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
V4 = V( 4 )
T4 = TAU*V4
V5 = V( 5 )
T5 = TAU*V5
V6 = V( 6 )
T6 = TAU*V6
V7 = V( 7 )
T7 = TAU*V7
V8 = V( 8 )
T8 = TAU*V8
V9 = V( 9 )
T9 = TAU*V9
DO 180 J = 1, N
SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
$ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
$ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J )
C( 1, J ) = C( 1, J ) - SUM*T1
C( 2, J ) = C( 2, J ) - SUM*T2
C( 3, J ) = C( 3, J ) - SUM*T3
C( 4, J ) = C( 4, J ) - SUM*T4
C( 5, J ) = C( 5, J ) - SUM*T5
C( 6, J ) = C( 6, J ) - SUM*T6
C( 7, J ) = C( 7, J ) - SUM*T7
C( 8, J ) = C( 8, J ) - SUM*T8
C( 9, J ) = C( 9, J ) - SUM*T9
180 CONTINUE
GO TO 410
190 CONTINUE
*
* Special code for 10 x 10 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
V4 = V( 4 )
T4 = TAU*V4
V5 = V( 5 )
T5 = TAU*V5
V6 = V( 6 )
T6 = TAU*V6
V7 = V( 7 )
T7 = TAU*V7
V8 = V( 8 )
T8 = TAU*V8
V9 = V( 9 )
T9 = TAU*V9
V10 = V( 10 )
T10 = TAU*V10
DO 200 J = 1, N
SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
$ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
$ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) +
$ V10*C( 10, J )
C( 1, J ) = C( 1, J ) - SUM*T1
C( 2, J ) = C( 2, J ) - SUM*T2
C( 3, J ) = C( 3, J ) - SUM*T3
C( 4, J ) = C( 4, J ) - SUM*T4
C( 5, J ) = C( 5, J ) - SUM*T5
C( 6, J ) = C( 6, J ) - SUM*T6
C( 7, J ) = C( 7, J ) - SUM*T7
C( 8, J ) = C( 8, J ) - SUM*T8
C( 9, J ) = C( 9, J ) - SUM*T9
C( 10, J ) = C( 10, J ) - SUM*T10
200 CONTINUE
GO TO 410
ELSE
*
* Form C * H, where H has order n.
*
GO TO ( 210, 230, 250, 270, 290, 310, 330, 350,
$ 370, 390 )N
*
* Code for general N
*
* w := C * v
*
CALL SGEMV( 'No transpose', M, N, ONE, C, LDC, V, 1, ZERO,
$ WORK, 1 )
*
* C := C - tau * w * v'
*
CALL SGER( M, N, -TAU, WORK, 1, V, 1, C, LDC )
GO TO 410
210 CONTINUE
*
* Special code for 1 x 1 Householder
*
T1 = ONE - TAU*V( 1 )*V( 1 )
DO 220 J = 1, M
C( J, 1 ) = T1*C( J, 1 )
220 CONTINUE
GO TO 410
230 CONTINUE
*
* Special code for 2 x 2 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
DO 240 J = 1, M
SUM = V1*C( J, 1 ) + V2*C( J, 2 )
C( J, 1 ) = C( J, 1 ) - SUM*T1
C( J, 2 ) = C( J, 2 ) - SUM*T2
240 CONTINUE
GO TO 410
250 CONTINUE
*
* Special code for 3 x 3 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
DO 260 J = 1, M
SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 )
C( J, 1 ) = C( J, 1 ) - SUM*T1
C( J, 2 ) = C( J, 2 ) - SUM*T2
C( J, 3 ) = C( J, 3 ) - SUM*T3
260 CONTINUE
GO TO 410
270 CONTINUE
*
* Special code for 4 x 4 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
V4 = V( 4 )
T4 = TAU*V4
DO 280 J = 1, M
SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
$ V4*C( J, 4 )
C( J, 1 ) = C( J, 1 ) - SUM*T1
C( J, 2 ) = C( J, 2 ) - SUM*T2
C( J, 3 ) = C( J, 3 ) - SUM*T3
C( J, 4 ) = C( J, 4 ) - SUM*T4
280 CONTINUE
GO TO 410
290 CONTINUE
*
* Special code for 5 x 5 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
V4 = V( 4 )
T4 = TAU*V4
V5 = V( 5 )
T5 = TAU*V5
DO 300 J = 1, M
SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
$ V4*C( J, 4 ) + V5*C( J, 5 )
C( J, 1 ) = C( J, 1 ) - SUM*T1
C( J, 2 ) = C( J, 2 ) - SUM*T2
C( J, 3 ) = C( J, 3 ) - SUM*T3
C( J, 4 ) = C( J, 4 ) - SUM*T4
C( J, 5 ) = C( J, 5 ) - SUM*T5
300 CONTINUE
GO TO 410
310 CONTINUE
*
* Special code for 6 x 6 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
V4 = V( 4 )
T4 = TAU*V4
V5 = V( 5 )
T5 = TAU*V5
V6 = V( 6 )
T6 = TAU*V6
DO 320 J = 1, M
SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
$ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 )
C( J, 1 ) = C( J, 1 ) - SUM*T1
C( J, 2 ) = C( J, 2 ) - SUM*T2
C( J, 3 ) = C( J, 3 ) - SUM*T3
C( J, 4 ) = C( J, 4 ) - SUM*T4
C( J, 5 ) = C( J, 5 ) - SUM*T5
C( J, 6 ) = C( J, 6 ) - SUM*T6
320 CONTINUE
GO TO 410
330 CONTINUE
*
* Special code for 7 x 7 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
V4 = V( 4 )
T4 = TAU*V4
V5 = V( 5 )
T5 = TAU*V5
V6 = V( 6 )
T6 = TAU*V6
V7 = V( 7 )
T7 = TAU*V7
DO 340 J = 1, M
SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
$ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
$ V7*C( J, 7 )
C( J, 1 ) = C( J, 1 ) - SUM*T1
C( J, 2 ) = C( J, 2 ) - SUM*T2
C( J, 3 ) = C( J, 3 ) - SUM*T3
C( J, 4 ) = C( J, 4 ) - SUM*T4
C( J, 5 ) = C( J, 5 ) - SUM*T5
C( J, 6 ) = C( J, 6 ) - SUM*T6
C( J, 7 ) = C( J, 7 ) - SUM*T7
340 CONTINUE
GO TO 410
350 CONTINUE
*
* Special code for 8 x 8 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
V4 = V( 4 )
T4 = TAU*V4
V5 = V( 5 )
T5 = TAU*V5
V6 = V( 6 )
T6 = TAU*V6
V7 = V( 7 )
T7 = TAU*V7
V8 = V( 8 )
T8 = TAU*V8
DO 360 J = 1, M
SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
$ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
$ V7*C( J, 7 ) + V8*C( J, 8 )
C( J, 1 ) = C( J, 1 ) - SUM*T1
C( J, 2 ) = C( J, 2 ) - SUM*T2
C( J, 3 ) = C( J, 3 ) - SUM*T3
C( J, 4 ) = C( J, 4 ) - SUM*T4
C( J, 5 ) = C( J, 5 ) - SUM*T5
C( J, 6 ) = C( J, 6 ) - SUM*T6
C( J, 7 ) = C( J, 7 ) - SUM*T7
C( J, 8 ) = C( J, 8 ) - SUM*T8
360 CONTINUE
GO TO 410
370 CONTINUE
*
* Special code for 9 x 9 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
V4 = V( 4 )
T4 = TAU*V4
V5 = V( 5 )
T5 = TAU*V5
V6 = V( 6 )
T6 = TAU*V6
V7 = V( 7 )
T7 = TAU*V7
V8 = V( 8 )
T8 = TAU*V8
V9 = V( 9 )
T9 = TAU*V9
DO 380 J = 1, M
SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
$ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
$ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 )
C( J, 1 ) = C( J, 1 ) - SUM*T1
C( J, 2 ) = C( J, 2 ) - SUM*T2
C( J, 3 ) = C( J, 3 ) - SUM*T3
C( J, 4 ) = C( J, 4 ) - SUM*T4
C( J, 5 ) = C( J, 5 ) - SUM*T5
C( J, 6 ) = C( J, 6 ) - SUM*T6
C( J, 7 ) = C( J, 7 ) - SUM*T7
C( J, 8 ) = C( J, 8 ) - SUM*T8
C( J, 9 ) = C( J, 9 ) - SUM*T9
380 CONTINUE
GO TO 410
390 CONTINUE
*
* Special code for 10 x 10 Householder
*
V1 = V( 1 )
T1 = TAU*V1
V2 = V( 2 )
T2 = TAU*V2
V3 = V( 3 )
T3 = TAU*V3
V4 = V( 4 )
T4 = TAU*V4
V5 = V( 5 )
T5 = TAU*V5
V6 = V( 6 )
T6 = TAU*V6
V7 = V( 7 )
T7 = TAU*V7
V8 = V( 8 )
T8 = TAU*V8
V9 = V( 9 )
T9 = TAU*V9
V10 = V( 10 )
T10 = TAU*V10
DO 400 J = 1, M
SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
$ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
$ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) +
$ V10*C( J, 10 )
C( J, 1 ) = C( J, 1 ) - SUM*T1
C( J, 2 ) = C( J, 2 ) - SUM*T2
C( J, 3 ) = C( J, 3 ) - SUM*T3
C( J, 4 ) = C( J, 4 ) - SUM*T4
C( J, 5 ) = C( J, 5 ) - SUM*T5
C( J, 6 ) = C( J, 6 ) - SUM*T6
C( J, 7 ) = C( J, 7 ) - SUM*T7
C( J, 8 ) = C( J, 8 ) - SUM*T8
C( J, 9 ) = C( J, 9 ) - SUM*T9
C( J, 10 ) = C( J, 10 ) - SUM*T10
400 CONTINUE
GO TO 410
END IF
410 RETURN
*
* End of SLARFX
*
END
SUBROUTINE SLARGV( N, X, INCX, Y, INCY, C, INCC )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INCC, INCX, INCY, N
* ..
* .. Array Arguments ..
REAL C( * ), X( * ), Y( * )
* ..
*
* Purpose
* =======
*
* SLARGV generates a vector of real plane rotations, determined by
* elements of the real vectors x and y. For i = 1,2,...,n
*
* ( c(i) s(i) ) ( x(i) ) = ( a(i) )
* ( -s(i) c(i) ) ( y(i) ) = ( 0 )
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of plane rotations to be generated.
*
* X (input/output) REAL array,
* dimension (1+(N-1)*INCX)
* On entry, the vector x.
* On exit, x(i) is overwritten by a(i), for i = 1,...,n.
*
* INCX (input) INTEGER
* The increment between elements of X. INCX > 0.
*
* Y (input/output) REAL array,
* dimension (1+(N-1)*INCY)
* On entry, the vector y.
* On exit, the sines of the plane rotations.
*
* INCY (input) INTEGER
* The increment between elements of Y. INCY > 0.
*
* C (output) REAL array, dimension (1+(N-1)*INCC)
* The cosines of the plane rotations.
*
* INCC (input) INTEGER
* The increment between elements of C. INCC > 0.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, IC, IX, IY
REAL F, G, T, TT
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SQRT
* ..
* .. Executable Statements ..
*
IX = 1
IY = 1
IC = 1
DO 10 I = 1, N
F = X( IX )
G = Y( IY )
IF( G.EQ.ZERO ) THEN
C( IC ) = ONE
ELSE IF( F.EQ.ZERO ) THEN
C( IC ) = ZERO
Y( IY ) = ONE
X( IX ) = G
ELSE IF( ABS( F ).GT.ABS( G ) ) THEN
T = G / F
TT = SQRT( ONE+T*T )
C( IC ) = ONE / TT
Y( IY ) = T*C( IC )
X( IX ) = F*TT
ELSE
T = F / G
TT = SQRT( ONE+T*T )
Y( IY ) = ONE / TT
C( IC ) = T*Y( IY )
X( IX ) = G*TT
END IF
IC = IC + INCC
IY = IY + INCY
IX = IX + INCX
10 CONTINUE
RETURN
*
* End of SLARGV
*
END
SUBROUTINE SLARNV( IDIST, ISEED, N, X )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IDIST, N
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
REAL X( * )
* ..
*
* Purpose
* =======
*
* SLARNV returns a vector of n random real numbers from a uniform or
* normal distribution.
*
* Arguments
* =========
*
* IDIST (input) INTEGER
* Specifies the distribution of the random numbers:
* = 1: uniform (0,1)
* = 2: uniform (-1,1)
* = 3: normal (0,1)
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry, the seed of the random number generator; the array
* elements must be between 0 and 4095, and ISEED(4) must be
* odd.
* On exit, the seed is updated.
*
* N (input) INTEGER
* The number of random numbers to be generated.
*
* X (output) REAL array, dimension (N)
* The generated random numbers.
*
* Further Details
* ===============
*
* This routine calls the auxiliary routine SLARUV to generate random
* real numbers from a uniform (0,1) distribution, in batches of up to
* 128 using vectorisable code. The Box-Muller method is used to
* transform numbers from a uniform to a normal distribution.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, TWO
PARAMETER ( ONE = 1.0E+0, TWO = 2.0E+0 )
INTEGER LV
PARAMETER ( LV = 128 )
REAL TWOPI
PARAMETER ( TWOPI = 6.2831853071795864769252867663E+0 )
* ..
* .. Local Scalars ..
INTEGER I, IL, IL2, IV
* ..
* .. Local Arrays ..
REAL U( LV )
* ..
* .. Intrinsic Functions ..
INTRINSIC COS, LOG, MIN, SQRT
* ..
* .. External Subroutines ..
EXTERNAL SLARUV
* ..
* .. Executable Statements ..
*
DO 40 IV = 1, N, LV / 2
IL = MIN( LV / 2, N-IV+1 )
IF( IDIST.EQ.3 ) THEN
IL2 = 2*IL
ELSE
IL2 = IL
END IF
*
* Call SLARUV to generate IL2 numbers from a uniform (0,1)
* distribution (IL2 <= LV)
*
CALL SLARUV( ISEED, IL2, U )
*
IF( IDIST.EQ.1 ) THEN
*
* Copy generated numbers
*
DO 10 I = 1, IL
X( IV+I-1 ) = U( I )
10 CONTINUE
ELSE IF( IDIST.EQ.2 ) THEN
*
* Convert generated numbers to uniform (-1,1) distribution
*
DO 20 I = 1, IL
X( IV+I-1 ) = TWO*U( I ) - ONE
20 CONTINUE
ELSE IF( IDIST.EQ.3 ) THEN
*
* Convert generated numbers to normal (0,1) distribution
*
DO 30 I = 1, IL
X( IV+I-1 ) = SQRT( -TWO*LOG( U( 2*I-1 ) ) )*
$ COS( TWOPI*U( 2*I ) )
30 CONTINUE
END IF
40 CONTINUE
RETURN
*
* End of SLARNV
*
END
SUBROUTINE SLARRA( N, D, E, E2, SPLTOL, TNRM,
$ NSPLIT, ISPLIT, INFO )
IMPLICIT NONE
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, N, NSPLIT
REAL SPLTOL, TNRM
* ..
* .. Array Arguments ..
INTEGER ISPLIT( * )
REAL D( * ), E( * ), E2( * )
* ..
*
* Purpose
* =======
*
* Compute the splitting points with threshold SPLTOL.
* SLARRA sets any "small" off-diagonal elements to zero.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix. N > 0.
*
* D (input) REAL array, dimension (N)
* On entry, the N diagonal elements of the tridiagonal
* matrix T.
*
* E (input/output) REAL array, dimension (N)
* On entry, the first (N-1) entries contain the subdiagonal
* elements of the tridiagonal matrix T; E(N) need not be set.
* On exit, the entries E( ISPLIT( I ) ), 1 <= I <= NSPLIT,
* are set to zero, the other entries of E are untouched.
*
* E2 (input/output) REAL array, dimension (N)
* On entry, the first (N-1) entries contain the SQUARES of the
* subdiagonal elements of the tridiagonal matrix T;
* E2(N) need not be set.
* On exit, the entries E2( ISPLIT( I ) ),
* 1 <= I <= NSPLIT, have been set to zero
*
* SPLTOL (input) REAL
* The threshold for splitting. Two criteria can be used:
* SPLTOL<0 : criterion based on absolute off-diagonal value
* SPLTOL>0 : criterion that preserves relative accuracy
*
* TNRM (input) REAL
* The norm of the matrix.
*
* NSPLIT (output) INTEGER
* The number of blocks T splits into. 1 <= NSPLIT <= N.
*
* ISPLIT (output) INTEGER array, dimension (N)
* The splitting points, at which T breaks up into blocks.
* The first block consists of rows/columns 1 to ISPLIT(1),
* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
* etc., and the NSPLIT-th consists of rows/columns
* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
*
*
* INFO (output) INTEGER
* = 0: successful exit
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
INTEGER I
REAL EABS, TMP1
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
INFO = 0
* Compute splitting points
NSPLIT = 1
IF(SPLTOL.LT.ZERO) THEN
* Criterion based on absolute off-diagonal value
TMP1 = ABS(SPLTOL)* TNRM
DO 9 I = 1, N-1
EABS = ABS( E(I) )
IF( EABS .LE. TMP1) THEN
E(I) = ZERO
E2(I) = ZERO
ISPLIT( NSPLIT ) = I
NSPLIT = NSPLIT + 1
END IF
9 CONTINUE
ELSE
* Criterion that guarantees relative accuracy
DO 10 I = 1, N-1
EABS = ABS( E(I) )
IF( EABS .LE. SPLTOL * SQRT(ABS(D(I)))*SQRT(ABS(D(I+1))) )
$ THEN
E(I) = ZERO
E2(I) = ZERO
ISPLIT( NSPLIT ) = I
NSPLIT = NSPLIT + 1
END IF
10 CONTINUE
ENDIF
ISPLIT( NSPLIT ) = N
RETURN
*
* End of SLARRA
*
END
SUBROUTINE SLARRB( N, D, LLD, IFIRST, ILAST, RTOL1,
$ RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK,
$ PIVMIN, SPDIAM, TWIST, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IFIRST, ILAST, INFO, N, OFFSET, TWIST
REAL PIVMIN, RTOL1, RTOL2, SPDIAM
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL D( * ), LLD( * ), W( * ),
$ WERR( * ), WGAP( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* Given the relatively robust representation(RRR) L D L^T, SLARRB
* does "limited" bisection to refine the eigenvalues of L D L^T,
* W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial
* guesses for these eigenvalues are input in W, the corresponding estimate
* of the error in these guesses and their gaps are input in WERR
* and WGAP, respectively. During bisection, intervals
* [left, right] are maintained by storing their mid-points and
* semi-widths in the arrays W and WERR respectively.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix.
*
* D (input) REAL array, dimension (N)
* The N diagonal elements of the diagonal matrix D.
*
* LLD (input) REAL array, dimension (N-1)
* The (N-1) elements L(i)*L(i)*D(i).
*
* IFIRST (input) INTEGER
* The index of the first eigenvalue to be computed.
*
* ILAST (input) INTEGER
* The index of the last eigenvalue to be computed.
*
* RTOL1 (input) REAL
* RTOL2 (input) REAL
* Tolerance for the convergence of the bisection intervals.
* An interval [LEFT,RIGHT] has converged if
* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
* where GAP is the (estimated) distance to the nearest
* eigenvalue.
*
* OFFSET (input) INTEGER
* Offset for the arrays W, WGAP and WERR, i.e., the IFIRST-OFFSET
* through ILAST-OFFSET elements of these arrays are to be used.
*
* W (input/output) REAL array, dimension (N)
* On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are
* estimates of the eigenvalues of L D L^T indexed IFIRST throug
* ILAST.
* On output, these estimates are refined.
*
* WGAP (input/output) REAL array, dimension (N-1)
* On input, the (estimated) gaps between consecutive
* eigenvalues of L D L^T, i.e., WGAP(I-OFFSET) is the gap between
* eigenvalues I and I+1. Note that if IFIRST.EQ.ILAST
* then WGAP(IFIRST-OFFSET) must be set to ZERO.
* On output, these gaps are refined.
*
* WERR (input/output) REAL array, dimension (N)
* On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are
* the errors in the estimates of the corresponding elements in W.
* On output, these errors are refined.
*
* WORK (workspace) REAL array, dimension (2*N)
* Workspace.
*
* IWORK (workspace) INTEGER array, dimension (2*N)
* Workspace.
*
* PIVMIN (input) DOUBLE PRECISION
* The minimum pivot in the Sturm sequence.
*
* SPDIAM (input) DOUBLE PRECISION
* The spectral diameter of the matrix.
*
* TWIST (input) INTEGER
* The twist index for the twisted factorization that is used
* for the negcount.
* TWIST = N: Compute negcount from L D L^T - LAMBDA I = L+ D+ L+^T
* TWIST = 1: Compute negcount from L D L^T - LAMBDA I = U- D- U-^T
* TWIST = R: Compute negcount from L D L^T - LAMBDA I = N(r) D(r) N(r)
*
* INFO (output) INTEGER
* Error flag.
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, TWO, HALF
PARAMETER ( ZERO = 0.0E0, TWO = 2.0E0,
$ HALF = 0.5E0 )
INTEGER MAXITR
* ..
* .. Local Scalars ..
INTEGER I, I1, II, IP, ITER, K, NEGCNT, NEXT, NINT,
$ OLNINT, PREV, R
REAL BACK, CVRGD, GAP, LEFT, LGAP, MID, MNWDTH,
$ RGAP, RIGHT, TMP, WIDTH
* ..
* .. External Functions ..
INTEGER SLANEG
EXTERNAL SLANEG
*
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
*
MAXITR = INT( ( LOG( SPDIAM+PIVMIN )-LOG( PIVMIN ) ) /
$ LOG( TWO ) ) + 2
MNWDTH = TWO * PIVMIN
*
R = TWIST
IF((R.LT.1).OR.(R.GT.N)) R = N
*
* Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ].
* The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while
* Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 )
* for an unconverged interval is set to the index of the next unconverged
* interval, and is -1 or 0 for a converged interval. Thus a linked
* list of unconverged intervals is set up.
*
I1 = IFIRST
* The number of unconverged intervals
NINT = 0
* The last unconverged interval found
PREV = 0
RGAP = WGAP( I1-OFFSET )
DO 75 I = I1, ILAST
K = 2*I
II = I - OFFSET
LEFT = W( II ) - WERR( II )
RIGHT = W( II ) + WERR( II )
LGAP = RGAP
RGAP = WGAP( II )
GAP = MIN( LGAP, RGAP )
* Make sure that [LEFT,RIGHT] contains the desired eigenvalue
* Compute negcount from dstqds facto L+D+L+^T = L D L^T - LEFT
*
* Do while( NEGCNT(LEFT).GT.I-1 )
*
BACK = WERR( II )
20 CONTINUE
NEGCNT = SLANEG( N, D, LLD, LEFT, PIVMIN, R )
IF( NEGCNT.GT.I-1 ) THEN
LEFT = LEFT - BACK
BACK = TWO*BACK
GO TO 20
END IF
*
* Do while( NEGCNT(RIGHT).LT.I )
* Compute negcount from dstqds facto L+D+L+^T = L D L^T - RIGHT
*
BACK = WERR( II )
50 CONTINUE
NEGCNT = SLANEG( N, D, LLD, RIGHT, PIVMIN, R )
IF( NEGCNT.LT.I ) THEN
RIGHT = RIGHT + BACK
BACK = TWO*BACK
GO TO 50
END IF
WIDTH = HALF*ABS( LEFT - RIGHT )
TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
CVRGD = MAX(RTOL1*GAP,RTOL2*TMP)
IF( WIDTH.LE.CVRGD .OR. WIDTH.LE.MNWDTH ) THEN
* This interval has already converged and does not need refinement.
* (Note that the gaps might change through refining the
* eigenvalues, however, they can only get bigger.)
* Remove it from the list.
IWORK( K-1 ) = -1
* Make sure that I1 always points to the first unconverged interval
IF((I.EQ.I1).AND.(I.LT.ILAST)) I1 = I + 1
IF((PREV.GE.I1).AND.(I.LE.ILAST)) IWORK( 2*PREV-1 ) = I + 1
ELSE
* unconverged interval found
PREV = I
NINT = NINT + 1
IWORK( K-1 ) = I + 1
IWORK( K ) = NEGCNT
END IF
WORK( K-1 ) = LEFT
WORK( K ) = RIGHT
75 CONTINUE
*
* Do while( NINT.GT.0 ), i.e. there are still unconverged intervals
* and while (ITER.LT.MAXITR)
*
ITER = 0
80 CONTINUE
PREV = I1 - 1
I = I1
OLNINT = NINT
DO 100 IP = 1, OLNINT
K = 2*I
II = I - OFFSET
RGAP = WGAP( II )
LGAP = RGAP
IF(II.GT.1) LGAP = WGAP( II-1 )
GAP = MIN( LGAP, RGAP )
NEXT = IWORK( K-1 )
LEFT = WORK( K-1 )
RIGHT = WORK( K )
MID = HALF*( LEFT + RIGHT )
* semiwidth of interval
WIDTH = RIGHT - MID
TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
CVRGD = MAX(RTOL1*GAP,RTOL2*TMP)
IF( ( WIDTH.LE.CVRGD ) .OR. ( WIDTH.LE.MNWDTH ).OR.
$ ( ITER.EQ.MAXITR ) )THEN
* reduce number of unconverged intervals
NINT = NINT - 1
* Mark interval as converged.
IWORK( K-1 ) = 0
IF( I1.EQ.I ) THEN
I1 = NEXT
ELSE
* Prev holds the last unconverged interval previously examined
IF(PREV.GE.I1) IWORK( 2*PREV-1 ) = NEXT
END IF
I = NEXT
GO TO 100
END IF
PREV = I
*
* Perform one bisection step
*
NEGCNT = SLANEG( N, D, LLD, MID, PIVMIN, R )
IF( NEGCNT.LE.I-1 ) THEN
WORK( K-1 ) = MID
ELSE
WORK( K ) = MID
END IF
I = NEXT
100 CONTINUE
ITER = ITER + 1
* do another loop if there are still unconverged intervals
* However, in the last iteration, all intervals are accepted
* since this is the best we can do.
IF( ( NINT.GT.0 ).AND.(ITER.LE.MAXITR) ) GO TO 80
*
*
* At this point, all the intervals have converged
DO 110 I = IFIRST, ILAST
K = 2*I
II = I - OFFSET
* All intervals marked by '0' have been refined.
IF( IWORK( K-1 ).EQ.0 ) THEN
W( II ) = HALF*( WORK( K-1 )+WORK( K ) )
WERR( II ) = WORK( K ) - W( II )
END IF
110 CONTINUE
*
DO 111 I = IFIRST+1, ILAST
K = 2*I
II = I - OFFSET
WGAP( II-1 ) = MAX( ZERO,
$ W(II) - WERR (II) - W( II-1 ) - WERR( II-1 ))
111 CONTINUE
RETURN
*
* End of SLARRB
*
END
SUBROUTINE SLARRC( JOBT, N, VL, VU, D, E, PIVMIN,
$ EIGCNT, LCNT, RCNT, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBT
INTEGER EIGCNT, INFO, LCNT, N, RCNT
REAL PIVMIN, VL, VU
* ..
* .. Array Arguments ..
REAL D( * ), E( * )
* ..
*
* Purpose
* =======
*
* Find the number of eigenvalues of the symmetric tridiagonal matrix T
* that are in the interval (VL,VU] if JOBT = 'T', and of L D L^T
* if JOBT = 'L'.
*
* Arguments
* =========
*
* JOBT (input) CHARACTER*1
* = 'T': Compute Sturm count for matrix T.
* = 'L': Compute Sturm count for matrix L D L^T.
*
* N (input) INTEGER
* The order of the matrix. N > 0.
*
* VL (input) DOUBLE PRECISION
* VU (input) DOUBLE PRECISION
* The lower and upper bounds for the eigenvalues.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* JOBT = 'T': The N diagonal elements of the tridiagonal matrix T.
* JOBT = 'L': The N diagonal elements of the diagonal matrix D.
*
* E (input) DOUBLE PRECISION array, dimension (N)
* JOBT = 'T': The N-1 offdiagonal elements of the matrix T.
* JOBT = 'L': The N-1 offdiagonal elements of the matrix L.
*
* PIVMIN (input) DOUBLE PRECISION
* The minimum pivot in the Sturm sequence for T.
*
* EIGCNT (output) INTEGER
* The number of eigenvalues of the symmetric tridiagonal matrix T
* that are in the interval (VL,VU]
*
* LCNT (output) INTEGER
* RCNT (output) INTEGER
* The left and right negcounts of the interval.
*
* INFO (output) INTEGER
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
INTEGER I
LOGICAL MATT
REAL LPIVOT, RPIVOT, SL, SU, TMP, TMP2
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Executable Statements ..
*
INFO = 0
LCNT = 0
RCNT = 0
EIGCNT = 0
MATT = LSAME( JOBT, 'T' )
IF (MATT) THEN
* Sturm sequence count on T
LPIVOT = D( 1 ) - VL
RPIVOT = D( 1 ) - VU
IF( LPIVOT.LE.ZERO ) THEN
LCNT = LCNT + 1
ENDIF
IF( RPIVOT.LE.ZERO ) THEN
RCNT = RCNT + 1
ENDIF
DO 10 I = 1, N-1
TMP = E(I)**2
LPIVOT = ( D( I+1 )-VL ) - TMP/LPIVOT
RPIVOT = ( D( I+1 )-VU ) - TMP/RPIVOT
IF( LPIVOT.LE.ZERO ) THEN
LCNT = LCNT + 1
ENDIF
IF( RPIVOT.LE.ZERO ) THEN
RCNT = RCNT + 1
ENDIF
10 CONTINUE
ELSE
* Sturm sequence count on L D L^T
SL = -VL
SU = -VU
DO 20 I = 1, N - 1
LPIVOT = D( I ) + SL
RPIVOT = D( I ) + SU
IF( LPIVOT.LE.ZERO ) THEN
LCNT = LCNT + 1
ENDIF
IF( RPIVOT.LE.ZERO ) THEN
RCNT = RCNT + 1
ENDIF
TMP = E(I) * D(I) * E(I)
*
TMP2 = TMP / LPIVOT
IF( TMP2.EQ.ZERO ) THEN
SL = TMP - VL
ELSE
SL = SL*TMP2 - VL
END IF
*
TMP2 = TMP / RPIVOT
IF( TMP2.EQ.ZERO ) THEN
SU = TMP - VU
ELSE
SU = SU*TMP2 - VU
END IF
20 CONTINUE
LPIVOT = D( N ) + SL
RPIVOT = D( N ) + SU
IF( LPIVOT.LE.ZERO ) THEN
LCNT = LCNT + 1
ENDIF
IF( RPIVOT.LE.ZERO ) THEN
RCNT = RCNT + 1
ENDIF
ENDIF
EIGCNT = RCNT - LCNT
RETURN
*
* end of SLARRC
*
END
SUBROUTINE SLARRD( RANGE, ORDER, N, VL, VU, IL, IU, GERS,
$ RELTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT,
$ M, W, WERR, WL, WU, IBLOCK, INDEXW,
$ WORK, IWORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER ORDER, RANGE
INTEGER IL, INFO, IU, M, N, NSPLIT
REAL PIVMIN, RELTOL, VL, VU, WL, WU
* ..
* .. Array Arguments ..
INTEGER IBLOCK( * ), INDEXW( * ),
$ ISPLIT( * ), IWORK( * )
REAL D( * ), E( * ), E2( * ),
$ GERS( * ), W( * ), WERR( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SLARRD computes the eigenvalues of a symmetric tridiagonal
* matrix T to suitable accuracy. This is an auxiliary code to be
* called from SSTEMR.
* The user may ask for all eigenvalues, all eigenvalues
* in the half-open interval (VL, VU], or the IL-th through IU-th
* eigenvalues.
*
* To avoid overflow, the matrix must be scaled so that its
* largest element is no greater than overflow**(1/2) *
* underflow**(1/4) in absolute value, and for greatest
* accuracy, it should not be much smaller than that.
*
* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
* Matrix", Report CS41, Computer Science Dept., Stanford
* University, July 21, 1966.
*
* Arguments
* =========
*
* RANGE (input) CHARACTER
* = 'A': ("All") all eigenvalues will be found.
* = 'V': ("Value") all eigenvalues in the half-open interval
* (VL, VU] will be found.
* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
* entire matrix) will be found.
*
* ORDER (input) CHARACTER
* = 'B': ("By Block") the eigenvalues will be grouped by
* split-off block (see IBLOCK, ISPLIT) and
* ordered from smallest to largest within
* the block.
* = 'E': ("Entire matrix")
* the eigenvalues for the entire matrix
* will be ordered from smallest to
* largest.
*
* N (input) INTEGER
* The order of the tridiagonal matrix T. N >= 0.
*
* VL (input) REAL
* VU (input) REAL
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. Eigenvalues less than or equal
* to VL, or greater than VU, will not be returned. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* GERS (input) REAL array, dimension (2*N)
* The N Gerschgorin intervals (the i-th Gerschgorin interval
* is (GERS(2*i-1), GERS(2*i)).
*
* RELTOL (input) REAL
* The minimum relative width of an interval. When an interval
* is narrower than RELTOL times the larger (in
* magnitude) endpoint, then it is considered to be
* sufficiently small, i.e., converged. Note: this should
* always be at least radix*machine epsilon.
*
* D (input) REAL array, dimension (N)
* The n diagonal elements of the tridiagonal matrix T.
*
* E (input) REAL array, dimension (N-1)
* The (n-1) off-diagonal elements of the tridiagonal matrix T.
*
* E2 (input) REAL array, dimension (N-1)
* The (n-1) squared off-diagonal elements of the tridiagonal matrix T.
*
* PIVMIN (input) REAL
* The minimum pivot allowed in the Sturm sequence for T.
*
* NSPLIT (input) INTEGER
* The number of diagonal blocks in the matrix T.
* 1 <= NSPLIT <= N.
*
* ISPLIT (input) INTEGER array, dimension (N)
* The splitting points, at which T breaks up into submatrices.
* The first submatrix consists of rows/columns 1 to ISPLIT(1),
* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
* etc., and the NSPLIT-th consists of rows/columns
* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
* (Only the first NSPLIT elements will actually be used, but
* since the user cannot know a priori what value NSPLIT will
* have, N words must be reserved for ISPLIT.)
*
* M (output) INTEGER
* The actual number of eigenvalues found. 0 <= M <= N.
* (See also the description of INFO=2,3.)
*
* W (output) REAL array, dimension (N)
* On exit, the first M elements of W will contain the
* eigenvalue approximations. SLARRD computes an interval
* I_j = (a_j, b_j] that includes eigenvalue j. The eigenvalue
* approximation is given as the interval midpoint
* W(j)= ( a_j + b_j)/2. The corresponding error is bounded by
* WERR(j) = abs( a_j - b_j)/2
*
* WERR (output) REAL array, dimension (N)
* The error bound on the corresponding eigenvalue approximation
* in W.
*
* WL (output) REAL
* WU (output) REAL
* The interval (WL, WU] contains all the wanted eigenvalues.
* If RANGE='V', then WL=VL and WU=VU.
* If RANGE='A', then WL and WU are the global Gerschgorin bounds
* on the spectrum.
* If RANGE='I', then WL and WU are computed by SLAEBZ from the
* index range specified.
*
* IBLOCK (output) INTEGER array, dimension (N)
* At each row/column j where E(j) is zero or small, the
* matrix T is considered to split into a block diagonal
* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which
* block (from 1 to the number of blocks) the eigenvalue W(i)
* belongs. (SLARRD may use the remaining N-M elements as
* workspace.)
*
* INDEXW (output) INTEGER array, dimension (N)
* The indices of the eigenvalues within each block (submatrix);
* for example, INDEXW(i)= j and IBLOCK(i)=k imply that the
* i-th eigenvalue W(i) is the j-th eigenvalue in block k.
*
* WORK (workspace) REAL array, dimension (4*N)
*
* IWORK (workspace) INTEGER array, dimension (3*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: some or all of the eigenvalues failed to converge or
* were not computed:
* =1 or 3: Bisection failed to converge for some
* eigenvalues; these eigenvalues are flagged by a
* negative block number. The effect is that the
* eigenvalues may not be as accurate as the
* absolute and relative tolerances. This is
* generally caused by unexpectedly inaccurate
* arithmetic.
* =2 or 3: RANGE='I' only: Not all of the eigenvalues
* IL:IU were found.
* Effect: M < IU+1-IL
* Cause: non-monotonic arithmetic, causing the
* Sturm sequence to be non-monotonic.
* Cure: recalculate, using RANGE='A', and pick
* out eigenvalues IL:IU. In some cases,
* increasing the PARAMETER "FUDGE" may
* make things work.
* = 4: RANGE='I', and the Gershgorin interval
* initially used was too small. No eigenvalues
* were computed.
* Probable cause: your machine has sloppy
* floating-point arithmetic.
* Cure: Increase the PARAMETER "FUDGE",
* recompile, and try again.
*
* Internal Parameters
* ===================
*
* FUDGE REAL , default = 2
* A "fudge factor" to widen the Gershgorin intervals. Ideally,
* a value of 1 should work, but on machines with sloppy
* arithmetic, this needs to be larger. The default for
* publicly released versions should be large enough to handle
* the worst machine around. Note that this has no effect
* on accuracy of the solution.
*
* Based on contributions by
* W. Kahan, University of California, Berkeley, USA
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO, HALF, FUDGE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0,
$ TWO = 2.0E0, HALF = ONE/TWO,
$ FUDGE = TWO )
INTEGER ALLRNG, VALRNG, INDRNG
PARAMETER ( ALLRNG = 1, VALRNG = 2, INDRNG = 3 )
* ..
* .. Local Scalars ..
LOGICAL NCNVRG, TOOFEW
INTEGER I, IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO,
$ IM, IN, IOFF, IOUT, IRANGE, ITMAX, ITMP1,
$ ITMP2, IW, IWOFF, J, JBLK, JDISC, JE, JEE, NB,
$ NWL, NWU
REAL ATOLI, EPS, GL, GU, RTOLI, SPDIAM, TMP1, TMP2,
$ TNORM, UFLOW, WKILL, WLU, WUL
* ..
* .. Local Arrays ..
INTEGER IDUMMA( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
REAL SLAMCH
EXTERNAL LSAME, ILAENV, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SLAEBZ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Decode RANGE
*
IF( LSAME( RANGE, 'A' ) ) THEN
IRANGE = ALLRNG
ELSE IF( LSAME( RANGE, 'V' ) ) THEN
IRANGE = VALRNG
ELSE IF( LSAME( RANGE, 'I' ) ) THEN
IRANGE = INDRNG
ELSE
IRANGE = 0
END IF
*
* Check for Errors
*
IF( IRANGE.LE.0 ) THEN
INFO = -1
ELSE IF( .NOT.(LSAME(ORDER,'B').OR.LSAME(ORDER,'E')) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( IRANGE.EQ.VALRNG ) THEN
IF( VL.GE.VU )
$ INFO = -5
ELSE IF( IRANGE.EQ.INDRNG .AND.
$ ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) ) THEN
INFO = -6
ELSE IF( IRANGE.EQ.INDRNG .AND.
$ ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) THEN
INFO = -7
END IF
*
IF( INFO.NE.0 ) THEN
RETURN
END IF
* Initialize error flags
INFO = 0
NCNVRG = .FALSE.
TOOFEW = .FALSE.
* Quick return if possible
M = 0
IF( N.EQ.0 ) RETURN
* Simplification:
IF( IRANGE.EQ.INDRNG .AND. IL.EQ.1 .AND. IU.EQ.N ) IRANGE = 1
* Get machine constants
EPS = SLAMCH( 'P' )
UFLOW = SLAMCH( 'U' )
* Special Case when N=1
* Treat case of 1x1 matrix for quick return
IF( N.EQ.1 ) THEN
IF( (IRANGE.EQ.ALLRNG).OR.
$ ((IRANGE.EQ.VALRNG).AND.(D(1).GT.VL).AND.(D(1).LE.VU)).OR.
$ ((IRANGE.EQ.INDRNG).AND.(IL.EQ.1).AND.(IU.EQ.1)) ) THEN
M = 1
W(1) = D(1)
* The computation error of the eigenvalue is zero
WERR(1) = ZERO
IBLOCK( 1 ) = 1
INDEXW( 1 ) = 1
ENDIF
RETURN
END IF
* NB is the minimum vector length for vector bisection, or 0
* if only scalar is to be done.
NB = ILAENV( 1, 'SSTEBZ', ' ', N, -1, -1, -1 )
IF( NB.LE.1 ) NB = 0
* Find global spectral radius
GL = D(1)
GU = D(1)
DO 5 I = 1,N
GL = MIN( GL, GERS( 2*I - 1))
GU = MAX( GU, GERS(2*I) )
5 CONTINUE
* Compute global Gerschgorin bounds and spectral diameter
TNORM = MAX( ABS( GL ), ABS( GU ) )
GL = GL - FUDGE*TNORM*EPS*N - FUDGE*TWO*PIVMIN
GU = GU + FUDGE*TNORM*EPS*N + FUDGE*TWO*PIVMIN
SPDIAM = GU - GL
* Input arguments for SLAEBZ:
* The relative tolerance. An interval (a,b] lies within
* "relative tolerance" if b-a < RELTOL*max(|a|,|b|),
RTOLI = RELTOL
* Set the absolute tolerance for interval convergence to zero to force
* interval convergence based on relative size of the interval.
* This is dangerous because intervals might not converge when RELTOL is
* small. But at least a very small number should be selected so that for
* strongly graded matrices, the code can get relatively accurate
* eigenvalues.
ATOLI = FUDGE*TWO*UFLOW + FUDGE*TWO*PIVMIN
IF( IRANGE.EQ.INDRNG ) THEN
* RANGE='I': Compute an interval containing eigenvalues
* IL through IU. The initial interval [GL,GU] from the global
* Gerschgorin bounds GL and GU is refined by SLAEBZ.
ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) /
$ LOG( TWO ) ) + 2
WORK( N+1 ) = GL
WORK( N+2 ) = GL
WORK( N+3 ) = GU
WORK( N+4 ) = GU
WORK( N+5 ) = GL
WORK( N+6 ) = GU
IWORK( 1 ) = -1
IWORK( 2 ) = -1
IWORK( 3 ) = N + 1
IWORK( 4 ) = N + 1
IWORK( 5 ) = IL - 1
IWORK( 6 ) = IU
*
CALL SLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN,
$ D, E, E2, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT,
$ IWORK, W, IBLOCK, IINFO )
IF( IINFO .NE. 0 ) THEN
INFO = IINFO
RETURN
END IF
* On exit, output intervals may not be ordered by ascending negcount
IF( IWORK( 6 ).EQ.IU ) THEN
WL = WORK( N+1 )
WLU = WORK( N+3 )
NWL = IWORK( 1 )
WU = WORK( N+4 )
WUL = WORK( N+2 )
NWU = IWORK( 4 )
ELSE
WL = WORK( N+2 )
WLU = WORK( N+4 )
NWL = IWORK( 2 )
WU = WORK( N+3 )
WUL = WORK( N+1 )
NWU = IWORK( 3 )
END IF
* On exit, the interval [WL, WLU] contains a value with negcount NWL,
* and [WUL, WU] contains a value with negcount NWU.
IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN
INFO = 4
RETURN
END IF
ELSEIF( IRANGE.EQ.VALRNG ) THEN
WL = VL
WU = VU
ELSEIF( IRANGE.EQ.ALLRNG ) THEN
WL = GL
WU = GU
ENDIF
* Find Eigenvalues -- Loop Over blocks and recompute NWL and NWU.
* NWL accumulates the number of eigenvalues .le. WL,
* NWU accumulates the number of eigenvalues .le. WU
M = 0
IEND = 0
INFO = 0
NWL = 0
NWU = 0
*
DO 70 JBLK = 1, NSPLIT
IOFF = IEND
IBEGIN = IOFF + 1
IEND = ISPLIT( JBLK )
IN = IEND - IOFF
*
IF( IN.EQ.1 ) THEN
* 1x1 block
IF( WL.GE.D( IBEGIN )-PIVMIN )
$ NWL = NWL + 1
IF( WU.GE.D( IBEGIN )-PIVMIN )
$ NWU = NWU + 1
IF( IRANGE.EQ.ALLRNG .OR.
$ ( WL.LT.D( IBEGIN )-PIVMIN
$ .AND. WU.GE. D( IBEGIN )-PIVMIN ) ) THEN
M = M + 1
W( M ) = D( IBEGIN )
WERR(M) = ZERO
* The gap for a single block doesn't matter for the later
* algorithm and is assigned an arbitrary large value
IBLOCK( M ) = JBLK
INDEXW( M ) = 1
END IF
* Disabled 2x2 case because of a failure on the following matrix
* RANGE = 'I', IL = IU = 4
* Original Tridiagonal, d = [
* -0.150102010615740E+00
* -0.849897989384260E+00
* -0.128208148052635E-15
* 0.128257718286320E-15
* ];
* e = [
* -0.357171383266986E+00
* -0.180411241501588E-15
* -0.175152352710251E-15
* ];
*
* ELSE IF( IN.EQ.2 ) THEN
** 2x2 block
* DISC = SQRT( (HALF*(D(IBEGIN)-D(IEND)))**2 + E(IBEGIN)**2 )
* TMP1 = HALF*(D(IBEGIN)+D(IEND))
* L1 = TMP1 - DISC
* IF( WL.GE. L1-PIVMIN )
* $ NWL = NWL + 1
* IF( WU.GE. L1-PIVMIN )
* $ NWU = NWU + 1
* IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L1-PIVMIN .AND. WU.GE.
* $ L1-PIVMIN ) ) THEN
* M = M + 1
* W( M ) = L1
** The uncertainty of eigenvalues of a 2x2 matrix is very small
* WERR( M ) = EPS * ABS( W( M ) ) * TWO
* IBLOCK( M ) = JBLK
* INDEXW( M ) = 1
* ENDIF
* L2 = TMP1 + DISC
* IF( WL.GE. L2-PIVMIN )
* $ NWL = NWL + 1
* IF( WU.GE. L2-PIVMIN )
* $ NWU = NWU + 1
* IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L2-PIVMIN .AND. WU.GE.
* $ L2-PIVMIN ) ) THEN
* M = M + 1
* W( M ) = L2
** The uncertainty of eigenvalues of a 2x2 matrix is very small
* WERR( M ) = EPS * ABS( W( M ) ) * TWO
* IBLOCK( M ) = JBLK
* INDEXW( M ) = 2
* ENDIF
ELSE
* General Case - block of size IN >= 2
* Compute local Gerschgorin interval and use it as the initial
* interval for SLAEBZ
GU = D( IBEGIN )
GL = D( IBEGIN )
TMP1 = ZERO
DO 40 J = IBEGIN, IEND
GL = MIN( GL, GERS( 2*J - 1))
GU = MAX( GU, GERS(2*J) )
40 CONTINUE
SPDIAM = GU - GL
GL = GL - FUDGE*SPDIAM*EPS*IN - FUDGE*PIVMIN
GU = GU + FUDGE*SPDIAM*EPS*IN + FUDGE*PIVMIN
*
IF( IRANGE.GT.1 ) THEN
IF( GU.LT.WL ) THEN
* the local block contains none of the wanted eigenvalues
NWL = NWL + IN
NWU = NWU + IN
GO TO 70
END IF
* refine search interval if possible, only range (WL,WU] matters
GL = MAX( GL, WL )
GU = MIN( GU, WU )
IF( GL.GE.GU )
$ GO TO 70
END IF
* Find negcount of initial interval boundaries GL and GU
WORK( N+1 ) = GL
WORK( N+IN+1 ) = GU
CALL SLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
$ D( IBEGIN ), E( IBEGIN ), E2( IBEGIN ),
$ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM,
$ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
IF( IINFO .NE. 0 ) THEN
INFO = IINFO
RETURN
END IF
*
NWL = NWL + IWORK( 1 )
NWU = NWU + IWORK( IN+1 )
IWOFF = M - IWORK( 1 )
* Compute Eigenvalues
ITMAX = INT( ( LOG( GU-GL+PIVMIN )-LOG( PIVMIN ) ) /
$ LOG( TWO ) ) + 2
CALL SLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
$ D( IBEGIN ), E( IBEGIN ), E2( IBEGIN ),
$ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT,
$ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
IF( IINFO .NE. 0 ) THEN
INFO = IINFO
RETURN
END IF
*
* Copy eigenvalues into W and IBLOCK
* Use -JBLK for block number for unconverged eigenvalues.
* Loop over the number of output intervals from SLAEBZ
DO 60 J = 1, IOUT
* eigenvalue approximation is middle point of interval
TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) )
* semi length of error interval
TMP2 = HALF*ABS( WORK( J+N )-WORK( J+IN+N ) )
IF( J.GT.IOUT-IINFO ) THEN
* Flag non-convergence.
NCNVRG = .TRUE.
IB = -JBLK
ELSE
IB = JBLK
END IF
DO 50 JE = IWORK( J ) + 1 + IWOFF,
$ IWORK( J+IN ) + IWOFF
W( JE ) = TMP1
WERR( JE ) = TMP2
INDEXW( JE ) = JE - IWOFF
IBLOCK( JE ) = IB
50 CONTINUE
60 CONTINUE
*
M = M + IM
END IF
70 CONTINUE
* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU
* If NWL+1 < IL or NWU > IU, discard extra eigenvalues.
IF( IRANGE.EQ.INDRNG ) THEN
IDISCL = IL - 1 - NWL
IDISCU = NWU - IU
*
IF( IDISCL.GT.0 ) THEN
IM = 0
DO 80 JE = 1, M
* Remove some of the smallest eigenvalues from the left so that
* at the end IDISCL =0. Move all eigenvalues up to the left.
IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN
IDISCL = IDISCL - 1
ELSE
IM = IM + 1
W( IM ) = W( JE )
WERR( IM ) = WERR( JE )
INDEXW( IM ) = INDEXW( JE )
IBLOCK( IM ) = IBLOCK( JE )
END IF
80 CONTINUE
M = IM
END IF
IF( IDISCU.GT.0 ) THEN
* Remove some of the largest eigenvalues from the right so that
* at the end IDISCU =0. Move all eigenvalues up to the left.
IM=M+1
DO 81 JE = M, 1, -1
IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN
IDISCU = IDISCU - 1
ELSE
IM = IM - 1
W( IM ) = W( JE )
WERR( IM ) = WERR( JE )
INDEXW( IM ) = INDEXW( JE )
IBLOCK( IM ) = IBLOCK( JE )
END IF
81 CONTINUE
JEE = 0
DO 82 JE = IM, M
JEE = JEE + 1
W( JEE ) = W( JE )
WERR( JEE ) = WERR( JE )
INDEXW( JEE ) = INDEXW( JE )
IBLOCK( JEE ) = IBLOCK( JE )
82 CONTINUE
M = M-IM+1
END IF
IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
* Code to deal with effects of bad arithmetic. (If N(w) is
* monotone non-decreasing, this should never happen.)
* Some low eigenvalues to be discarded are not in (WL,WLU],
* or high eigenvalues to be discarded are not in (WUL,WU]
* so just kill off the smallest IDISCL/largest IDISCU
* eigenvalues, by marking the corresponding IBLOCK = 0
IF( IDISCL.GT.0 ) THEN
WKILL = WU
DO 100 JDISC = 1, IDISCL
IW = 0
DO 90 JE = 1, M
IF( IBLOCK( JE ).NE.0 .AND.
$ ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN
IW = JE
WKILL = W( JE )
END IF
90 CONTINUE
IBLOCK( IW ) = 0
100 CONTINUE
END IF
IF( IDISCU.GT.0 ) THEN
WKILL = WL
DO 120 JDISC = 1, IDISCU
IW = 0
DO 110 JE = 1, M
IF( IBLOCK( JE ).NE.0 .AND.
$ ( W( JE ).GE.WKILL .OR. IW.EQ.0 ) ) THEN
IW = JE
WKILL = W( JE )
END IF
110 CONTINUE
IBLOCK( IW ) = 0
120 CONTINUE
END IF
* Now erase all eigenvalues with IBLOCK set to zero
IM = 0
DO 130 JE = 1, M
IF( IBLOCK( JE ).NE.0 ) THEN
IM = IM + 1
W( IM ) = W( JE )
WERR( IM ) = WERR( JE )
INDEXW( IM ) = INDEXW( JE )
IBLOCK( IM ) = IBLOCK( JE )
END IF
130 CONTINUE
M = IM
END IF
IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN
TOOFEW = .TRUE.
END IF
END IF
*
IF(( IRANGE.EQ.ALLRNG .AND. M.NE.N ).OR.
$ ( IRANGE.EQ.INDRNG .AND. M.NE.IU-IL+1 ) ) THEN
TOOFEW = .TRUE.
END IF
* If ORDER='B', do nothing the eigenvalues are already sorted by
* block.
* If ORDER='E', sort the eigenvalues from smallest to largest
IF( LSAME(ORDER,'E') .AND. NSPLIT.GT.1 ) THEN
DO 150 JE = 1, M - 1
IE = 0
TMP1 = W( JE )
DO 140 J = JE + 1, M
IF( W( J ).LT.TMP1 ) THEN
IE = J
TMP1 = W( J )
END IF
140 CONTINUE
IF( IE.NE.0 ) THEN
TMP2 = WERR( IE )
ITMP1 = IBLOCK( IE )
ITMP2 = INDEXW( IE )
W( IE ) = W( JE )
WERR( IE ) = WERR( JE )
IBLOCK( IE ) = IBLOCK( JE )
INDEXW( IE ) = INDEXW( JE )
W( JE ) = TMP1
WERR( JE ) = TMP2
IBLOCK( JE ) = ITMP1
INDEXW( JE ) = ITMP2
END IF
150 CONTINUE
END IF
*
INFO = 0
IF( NCNVRG )
$ INFO = INFO + 1
IF( TOOFEW )
$ INFO = INFO + 2
RETURN
*
* End of SLARRD
*
END
SUBROUTINE SLARRE( RANGE, N, VL, VU, IL, IU, D, E, E2,
$ RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT, M,
$ W, WERR, WGAP, IBLOCK, INDEXW, GERS, PIVMIN,
$ WORK, IWORK, INFO )
IMPLICIT NONE
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER RANGE
INTEGER IL, INFO, IU, M, N, NSPLIT
REAL PIVMIN, RTOL1, RTOL2, SPLTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * ),
$ INDEXW( * )
REAL D( * ), E( * ), E2( * ), GERS( * ),
$ W( * ),WERR( * ), WGAP( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* To find the desired eigenvalues of a given real symmetric
* tridiagonal matrix T, SLARRE sets any "small" off-diagonal
* elements to zero, and for each unreduced block T_i, it finds
* (a) a suitable shift at one end of the block's spectrum,
* (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and
* (c) eigenvalues of each L_i D_i L_i^T.
* The representations and eigenvalues found are then used by
* SSTEMR to compute the eigenvectors of T.
* The accuracy varies depending on whether bisection is used to
* find a few eigenvalues or the dqds algorithm (subroutine SLASQ2) to
* conpute all and then discard any unwanted one.
* As an added benefit, SLARRE also outputs the n
* Gerschgorin intervals for the matrices L_i D_i L_i^T.
*
* Arguments
* =========
*
* RANGE (input) CHARACTER
* = 'A': ("All") all eigenvalues will be found.
* = 'V': ("Value") all eigenvalues in the half-open interval
* (VL, VU] will be found.
* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
* entire matrix) will be found.
*
* N (input) INTEGER
* The order of the matrix. N > 0.
*
* VL (input/output) REAL
* VU (input/output) REAL
* If RANGE='V', the lower and upper bounds for the eigenvalues.
* Eigenvalues less than or equal to VL, or greater than VU,
* will not be returned. VL < VU.
* If RANGE='I' or ='A', SLARRE computes bounds on the desired
* part of the spectrum.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N.
*
* D (input/output) REAL array, dimension (N)
* On entry, the N diagonal elements of the tridiagonal
* matrix T.
* On exit, the N diagonal elements of the diagonal
* matrices D_i.
*
* E (input/output) REAL array, dimension (N)
* On entry, the first (N-1) entries contain the subdiagonal
* elements of the tridiagonal matrix T; E(N) need not be set.
* On exit, E contains the subdiagonal elements of the unit
* bidiagonal matrices L_i. The entries E( ISPLIT( I ) ),
* 1 <= I <= NSPLIT, contain the base points sigma_i on output.
*
* E2 (input/output) REAL array, dimension (N)
* On entry, the first (N-1) entries contain the SQUARES of the
* subdiagonal elements of the tridiagonal matrix T;
* E2(N) need not be set.
* On exit, the entries E2( ISPLIT( I ) ),
* 1 <= I <= NSPLIT, have been set to zero
*
* RTOL1 (input) REAL
* RTOL2 (input) REAL
* Parameters for bisection.
* An interval [LEFT,RIGHT] has converged if
* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
*
* SPLTOL (input) REAL
* The threshold for splitting.
*
* NSPLIT (output) INTEGER
* The number of blocks T splits into. 1 <= NSPLIT <= N.
*
* ISPLIT (output) INTEGER array, dimension (N)
* The splitting points, at which T breaks up into blocks.
* The first block consists of rows/columns 1 to ISPLIT(1),
* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
* etc., and the NSPLIT-th consists of rows/columns
* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
*
* M (output) INTEGER
* The total number of eigenvalues (of all L_i D_i L_i^T)
* found.
*
* W (output) REAL array, dimension (N)
* The first M elements contain the eigenvalues. The
* eigenvalues of each of the blocks, L_i D_i L_i^T, are
* sorted in ascending order ( SLARRE may use the
* remaining N-M elements as workspace).
*
* WERR (output) REAL array, dimension (N)
* The error bound on the corresponding eigenvalue in W.
*
* WGAP (output) REAL array, dimension (N)
* The separation from the right neighbor eigenvalue in W.
* The gap is only with respect to the eigenvalues of the same block
* as each block has its own representation tree.
* Exception: at the right end of a block we store the left gap
*
* IBLOCK (output) INTEGER array, dimension (N)
* The indices of the blocks (submatrices) associated with the
* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue
* W(i) belongs to the first block from the top, =2 if W(i)
* belongs to the second block, etc.
*
* INDEXW (output) INTEGER array, dimension (N)
* The indices of the eigenvalues within each block (submatrix);
* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the
* i-th eigenvalue W(i) is the 10-th eigenvalue in block 2
*
* GERS (output) REAL array, dimension (2*N)
* The N Gerschgorin intervals (the i-th Gerschgorin interval
* is (GERS(2*i-1), GERS(2*i)).
*
* PIVMIN (output) DOUBLE PRECISION
* The minimum pivot in the Sturm sequence for T.
*
* WORK (workspace) REAL array, dimension (6*N)
* Workspace.
*
* IWORK (workspace) INTEGER array, dimension (5*N)
* Workspace.
*
* INFO (output) INTEGER
* = 0: successful exit
* > 0: A problem occured in SLARRE.
* < 0: One of the called subroutines signaled an internal problem.
* Needs inspection of the corresponding parameter IINFO
* for further information.
*
* =-1: Problem in SLARRD.
* = 2: No base representation could be found in MAXTRY iterations.
* Increasing MAXTRY and recompilation might be a remedy.
* =-3: Problem in SLARRB when computing the refined root
* representation for SLASQ2.
* =-4: Problem in SLARRB when preforming bisection on the
* desired part of the spectrum.
* =-5: Problem in SLASQ2.
* =-6: Problem in SLASQ2.
*
* Further Details
* The base representations are required to suffer very little
* element growth and consequently define all their eigenvalues to
* high relative accuracy.
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL FAC, FOUR, FOURTH, FUDGE, HALF, HNDRD,
$ MAXGROWTH, ONE, PERT, TWO, ZERO
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0,
$ TWO = 2.0E0, FOUR=4.0E0,
$ HNDRD = 100.0E0,
$ PERT = 4.0E0,
$ HALF = ONE/TWO, FOURTH = ONE/FOUR, FAC= HALF,
$ MAXGROWTH = 64.0E0, FUDGE = 2.0E0 )
INTEGER MAXTRY, ALLRNG, INDRNG, VALRNG
PARAMETER ( MAXTRY = 6, ALLRNG = 1, INDRNG = 2,
$ VALRNG = 3 )
* ..
* .. Local Scalars ..
LOGICAL FORCEB, NOREP, USEDQD
INTEGER CNT, CNT1, CNT2, I, IBEGIN, IDUM, IEND, IINFO,
$ IN, INDL, INDU, IRANGE, J, JBLK, MB, MM,
$ WBEGIN, WEND
REAL AVGAP, BSRTOL, CLWDTH, DMAX, DPIVOT, EABS,
$ EMAX, EOLD, EPS, GL, GU, ISLEFT, ISRGHT, RTL,
$ RTOL, S1, S2, SAFMIN, SGNDEF, SIGMA, SPDIAM,
$ TAU, TMP, TMP1
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH
EXTERNAL SLAMCH, LSAME
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLARNV, SLARRA, SLARRB, SLARRC, SLARRD,
$ SLASQ2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Decode RANGE
*
IF( LSAME( RANGE, 'A' ) ) THEN
IRANGE = ALLRNG
ELSE IF( LSAME( RANGE, 'V' ) ) THEN
IRANGE = VALRNG
ELSE IF( LSAME( RANGE, 'I' ) ) THEN
IRANGE = INDRNG
END IF
M = 0
* Get machine constants
SAFMIN = SLAMCH( 'S' )
EPS = SLAMCH( 'P' )
* Set parameters
RTL = HNDRD*EPS
* If one were ever to ask for less initial precision in BSRTOL,
* one should keep in mind that for the subset case, the extremal
* eigenvalues must be at least as accurate as the current setting
* (eigenvalues in the middle need not as much accuracy)
BSRTOL = SQRT(EPS)*(0.5E-3)
* Treat case of 1x1 matrix for quick return
IF( N.EQ.1 ) THEN
IF( (IRANGE.EQ.ALLRNG).OR.
$ ((IRANGE.EQ.VALRNG).AND.(D(1).GT.VL).AND.(D(1).LE.VU)).OR.
$ ((IRANGE.EQ.INDRNG).AND.(IL.EQ.1).AND.(IU.EQ.1)) ) THEN
M = 1
W(1) = D(1)
* The computation error of the eigenvalue is zero
WERR(1) = ZERO
WGAP(1) = ZERO
IBLOCK( 1 ) = 1
INDEXW( 1 ) = 1
GERS(1) = D( 1 )
GERS(2) = D( 1 )
ENDIF
* store the shift for the initial RRR, which is zero in this case
E(1) = ZERO
RETURN
END IF
* General case: tridiagonal matrix of order > 1
*
* Init WERR, WGAP. Compute Gerschgorin intervals and spectral diameter.
* Compute maximum off-diagonal entry and pivmin.
GL = D(1)
GU = D(1)
EOLD = ZERO
EMAX = ZERO
E(N) = ZERO
DO 5 I = 1,N
WERR(I) = ZERO
WGAP(I) = ZERO
EABS = ABS( E(I) )
IF( EABS .GE. EMAX ) THEN
EMAX = EABS
END IF
TMP1 = EABS + EOLD
GERS( 2*I-1) = D(I) - TMP1
GL = MIN( GL, GERS( 2*I - 1))
GERS( 2*I ) = D(I) + TMP1
GU = MAX( GU, GERS(2*I) )
EOLD = EABS
5 CONTINUE
* The minimum pivot allowed in the Sturm sequence for T
PIVMIN = SAFMIN * MAX( ONE, EMAX**2 )
* Compute spectral diameter. The Gerschgorin bounds give an
* estimate that is wrong by at most a factor of SQRT(2)
SPDIAM = GU - GL
* Compute splitting points
CALL SLARRA( N, D, E, E2, SPLTOL, SPDIAM,
$ NSPLIT, ISPLIT, IINFO )
* Can force use of bisection instead of faster DQDS.
* Option left in the code for future multisection work.
FORCEB = .FALSE.
IF( (IRANGE.EQ.ALLRNG) .AND. (.NOT. FORCEB) ) THEN
* Set interval [VL,VU] that contains all eigenvalues
VL = GL
VU = GU
ELSE
* We call SLARRD to find crude approximations to the eigenvalues
* in the desired range. In case IRANGE = INDRNG, we also obtain the
* interval (VL,VU] that contains all the wanted eigenvalues.
* An interval [LEFT,RIGHT] has converged if
* RIGHT-LEFT.LT.RTOL*MAX(ABS(LEFT),ABS(RIGHT))
* SLARRD needs a WORK of size 4*N, IWORK of size 3*N
CALL SLARRD( RANGE, 'B', N, VL, VU, IL, IU, GERS,
$ BSRTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT,
$ MM, W, WERR, VL, VU, IBLOCK, INDEXW,
$ WORK, IWORK, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = -1
RETURN
ENDIF
* Make sure that the entries M+1 to N in W, WERR, IBLOCK, INDEXW are 0
DO 14 I = MM+1,N
W( I ) = ZERO
WERR( I ) = ZERO
IBLOCK( I ) = 0
INDEXW( I ) = 0
14 CONTINUE
END IF
***
* Loop over unreduced blocks
IBEGIN = 1
WBEGIN = 1
DO 170 JBLK = 1, NSPLIT
IEND = ISPLIT( JBLK )
IN = IEND - IBEGIN + 1
* 1 X 1 block
IF( IN.EQ.1 ) THEN
IF( (IRANGE.EQ.ALLRNG).OR.( (IRANGE.EQ.VALRNG).AND.
$ ( D( IBEGIN ).GT.VL ).AND.( D( IBEGIN ).LE.VU ) )
$ .OR. ( (IRANGE.EQ.INDRNG).AND.(IBLOCK(WBEGIN).EQ.JBLK))
$ ) THEN
M = M + 1
W( M ) = D( IBEGIN )
WERR(M) = ZERO
* The gap for a single block doesn't matter for the later
* algorithm and is assigned an arbitrary large value
WGAP(M) = ZERO
IBLOCK( M ) = JBLK
INDEXW( M ) = 1
WBEGIN = WBEGIN + 1
ENDIF
* E( IEND ) holds the shift for the initial RRR
E( IEND ) = ZERO
IBEGIN = IEND + 1
GO TO 170
END IF
*
* Blocks of size larger than 1x1
*
* E( IEND ) will hold the shift for the initial RRR, for now set it =0
E( IEND ) = ZERO
*
* Find local outer bounds GL,GU for the block
GL = D(IBEGIN)
GU = D(IBEGIN)
DO 15 I = IBEGIN , IEND
GL = MIN( GERS( 2*I-1 ), GL )
GU = MAX( GERS( 2*I ), GU )
15 CONTINUE
SPDIAM = GU - GL
IF(.NOT. ((IRANGE.EQ.ALLRNG).AND.(.NOT.FORCEB)) ) THEN
* Count the number of eigenvalues in the current block.
MB = 0
DO 20 I = WBEGIN,MM
IF( IBLOCK(I).EQ.JBLK ) THEN
MB = MB+1
ELSE
GOTO 21
ENDIF
20 CONTINUE
21 CONTINUE
IF( MB.EQ.0) THEN
* No eigenvalue in the current block lies in the desired range
* E( IEND ) holds the shift for the initial RRR
E( IEND ) = ZERO
IBEGIN = IEND + 1
GO TO 170
ELSE
* Decide whether dqds or bisection is more efficient
USEDQD = ( (MB .GT. FAC*IN) .AND. (.NOT.FORCEB) )
WEND = WBEGIN + MB - 1
* Calculate gaps for the current block
* In later stages, when representations for individual
* eigenvalues are different, we use SIGMA = E( IEND ).
SIGMA = ZERO
DO 30 I = WBEGIN, WEND - 1
WGAP( I ) = MAX( ZERO,
$ W(I+1)-WERR(I+1) - (W(I)+WERR(I)) )
30 CONTINUE
WGAP( WEND ) = MAX( ZERO,
$ VU - SIGMA - (W( WEND )+WERR( WEND )))
* Find local index of the first and last desired evalue.
INDL = INDEXW(WBEGIN)
INDU = INDEXW( WEND )
ENDIF
ENDIF
IF(( (IRANGE.EQ.ALLRNG) .AND. (.NOT. FORCEB) ).OR.USEDQD) THEN
* Case of DQDS
* Find approximations to the extremal eigenvalues of the block
CALL SLARRK( IN, 1, GL, GU, D(IBEGIN),
$ E2(IBEGIN), PIVMIN, RTL, TMP, TMP1, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = -1
RETURN
ENDIF
ISLEFT = MAX(GL, TMP - TMP1
$ - HNDRD * EPS* ABS(TMP - TMP1))
CALL SLARRK( IN, IN, GL, GU, D(IBEGIN),
$ E2(IBEGIN), PIVMIN, RTL, TMP, TMP1, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = -1
RETURN
ENDIF
ISRGHT = MIN(GU, TMP + TMP1
$ + HNDRD * EPS * ABS(TMP + TMP1))
* Improve the estimate of the spectral diameter
SPDIAM = ISRGHT - ISLEFT
ELSE
* Case of bisection
* Find approximations to the wanted extremal eigenvalues
ISLEFT = MAX(GL, W(WBEGIN) - WERR(WBEGIN)
$ - HNDRD * EPS*ABS(W(WBEGIN)- WERR(WBEGIN) ))
ISRGHT = MIN(GU,W(WEND) + WERR(WEND)
$ + HNDRD * EPS * ABS(W(WEND)+ WERR(WEND)))
ENDIF
* Decide whether the base representation for the current block
* L_JBLK D_JBLK L_JBLK^T = T_JBLK - sigma_JBLK I
* should be on the left or the right end of the current block.
* The strategy is to shift to the end which is "more populated"
* Furthermore, decide whether to use DQDS for the computation of
* the eigenvalue approximations at the end of SLARRE or bisection.
* dqds is chosen if all eigenvalues are desired or the number of
* eigenvalues to be computed is large compared to the blocksize.
IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN
* If all the eigenvalues have to be computed, we use dqd
USEDQD = .TRUE.
* INDL is the local index of the first eigenvalue to compute
INDL = 1
INDU = IN
* MB = number of eigenvalues to compute
MB = IN
WEND = WBEGIN + MB - 1
* Define 1/4 and 3/4 points of the spectrum
S1 = ISLEFT + FOURTH * SPDIAM
S2 = ISRGHT - FOURTH * SPDIAM
ELSE
* SLARRD has computed IBLOCK and INDEXW for each eigenvalue
* approximation.
* choose sigma
IF( USEDQD ) THEN
S1 = ISLEFT + FOURTH * SPDIAM
S2 = ISRGHT - FOURTH * SPDIAM
ELSE
TMP = MIN(ISRGHT,VU) - MAX(ISLEFT,VL)
S1 = MAX(ISLEFT,VL) + FOURTH * TMP
S2 = MIN(ISRGHT,VU) - FOURTH * TMP
ENDIF
ENDIF
* Compute the negcount at the 1/4 and 3/4 points
IF(MB.GT.1) THEN
CALL SLARRC( 'T', IN, S1, S2, D(IBEGIN),
$ E(IBEGIN), PIVMIN, CNT, CNT1, CNT2, IINFO)
ENDIF
IF(MB.EQ.1) THEN
SIGMA = GL
SGNDEF = ONE
ELSEIF( CNT1 - INDL .GE. INDU - CNT2 ) THEN
IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN
SIGMA = MAX(ISLEFT,GL)
ELSEIF( USEDQD ) THEN
* use Gerschgorin bound as shift to get pos def matrix
* for dqds
SIGMA = ISLEFT
ELSE
* use approximation of the first desired eigenvalue of the
* block as shift
SIGMA = MAX(ISLEFT,VL)
ENDIF
SGNDEF = ONE
ELSE
IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN
SIGMA = MIN(ISRGHT,GU)
ELSEIF( USEDQD ) THEN
* use Gerschgorin bound as shift to get neg def matrix
* for dqds
SIGMA = ISRGHT
ELSE
* use approximation of the first desired eigenvalue of the
* block as shift
SIGMA = MIN(ISRGHT,VU)
ENDIF
SGNDEF = -ONE
ENDIF
* An initial SIGMA has been chosen that will be used for computing
* T - SIGMA I = L D L^T
* Define the increment TAU of the shift in case the initial shift
* needs to be refined to obtain a factorization with not too much
* element growth.
IF( USEDQD ) THEN
* The initial SIGMA was to the outer end of the spectrum
* the matrix is definite and we need not retreat.
TAU = SPDIAM*EPS*N + TWO*PIVMIN
ELSE
IF(MB.GT.1) THEN
CLWDTH = W(WEND) + WERR(WEND) - W(WBEGIN) - WERR(WBEGIN)
AVGAP = ABS(CLWDTH / REAL(WEND-WBEGIN))
IF( SGNDEF.EQ.ONE ) THEN
TAU = HALF*MAX(WGAP(WBEGIN),AVGAP)
TAU = MAX(TAU,WERR(WBEGIN))
ELSE
TAU = HALF*MAX(WGAP(WEND-1),AVGAP)
TAU = MAX(TAU,WERR(WEND))
ENDIF
ELSE
TAU = WERR(WBEGIN)
ENDIF
ENDIF
*
DO 80 IDUM = 1, MAXTRY
* Compute L D L^T factorization of tridiagonal matrix T - sigma I.
* Store D in WORK(1:IN), L in WORK(IN+1:2*IN), and reciprocals of
* pivots in WORK(2*IN+1:3*IN)
DPIVOT = D( IBEGIN ) - SIGMA
WORK( 1 ) = DPIVOT
DMAX = ABS( WORK(1) )
J = IBEGIN
DO 70 I = 1, IN - 1
WORK( 2*IN+I ) = ONE / WORK( I )
TMP = E( J )*WORK( 2*IN+I )
WORK( IN+I ) = TMP
DPIVOT = ( D( J+1 )-SIGMA ) - TMP*E( J )
WORK( I+1 ) = DPIVOT
DMAX = MAX( DMAX, ABS(DPIVOT) )
J = J + 1
70 CONTINUE
* check for element growth
IF( DMAX .GT. MAXGROWTH*SPDIAM ) THEN
NOREP = .TRUE.
ELSE
NOREP = .FALSE.
ENDIF
IF( USEDQD .AND. .NOT.NOREP ) THEN
* Ensure the definiteness of the representation
* All entries of D (of L D L^T) must have the same sign
DO 71 I = 1, IN
TMP = SGNDEF*WORK( I )
IF( TMP.LT.ZERO ) NOREP = .TRUE.
71 CONTINUE
ENDIF
IF(NOREP) THEN
* Note that in the case of IRANGE=ALLRNG, we use the Gerschgorin
* shift which makes the matrix definite. So we should end up
* here really only in the case of IRANGE = VALRNG or INDRNG.
IF( IDUM.EQ.MAXTRY-1 ) THEN
IF( SGNDEF.EQ.ONE ) THEN
* The fudged Gerschgorin shift should succeed
SIGMA =
$ GL - FUDGE*SPDIAM*EPS*N - FUDGE*TWO*PIVMIN
ELSE
SIGMA =
$ GU + FUDGE*SPDIAM*EPS*N + FUDGE*TWO*PIVMIN
END IF
ELSE
SIGMA = SIGMA - SGNDEF * TAU
TAU = TWO * TAU
END IF
ELSE
* an initial RRR is found
GO TO 83
END IF
80 CONTINUE
* if the program reaches this point, no base representation could be
* found in MAXTRY iterations.
INFO = 2
RETURN
83 CONTINUE
* At this point, we have found an initial base representation
* T - SIGMA I = L D L^T with not too much element growth.
* Store the shift.
E( IEND ) = SIGMA
* Store D and L.
CALL SCOPY( IN, WORK, 1, D( IBEGIN ), 1 )
CALL SCOPY( IN-1, WORK( IN+1 ), 1, E( IBEGIN ), 1 )
IF(MB.GT.1 ) THEN
*
* Perturb each entry of the base representation by a small
* (but random) relative amount to overcome difficulties with
* glued matrices.
*
DO 122 I = 1, 4
ISEED( I ) = 1
122 CONTINUE
CALL SLARNV(2, ISEED, 2*IN-1, WORK(1))
DO 125 I = 1,IN-1
D(IBEGIN+I-1) = D(IBEGIN+I-1)*(ONE+EPS*PERT*WORK(I))
E(IBEGIN+I-1) = E(IBEGIN+I-1)*(ONE+EPS*PERT*WORK(IN+I))
125 CONTINUE
D(IEND) = D(IEND)*(ONE+EPS*FOUR*WORK(IN))
*
ENDIF
*
* Don't update the Gerschgorin intervals because keeping track
* of the updates would be too much work in SLARRV.
* We update W instead and use it to locate the proper Gerschgorin
* intervals.
* Compute the required eigenvalues of L D L' by bisection or dqds
IF ( .NOT.USEDQD ) THEN
* If SLARRD has been used, shift the eigenvalue approximations
* according to their representation. This is necessary for
* a uniform SLARRV since dqds computes eigenvalues of the
* shifted representation. In SLARRV, W will always hold the
* UNshifted eigenvalue approximation.
DO 134 J=WBEGIN,WEND
W(J) = W(J) - SIGMA
WERR(J) = WERR(J) + ABS(W(J)) * EPS
134 CONTINUE
* call SLARRB to reduce eigenvalue error of the approximations
* from SLARRD
DO 135 I = IBEGIN, IEND-1
WORK( I ) = D( I ) * E( I )**2
135 CONTINUE
* use bisection to find EV from INDL to INDU
CALL SLARRB(IN, D(IBEGIN), WORK(IBEGIN),
$ INDL, INDU, RTOL1, RTOL2, INDL-1,
$ W(WBEGIN), WGAP(WBEGIN), WERR(WBEGIN),
$ WORK( 2*N+1 ), IWORK, PIVMIN, SPDIAM,
$ IN, IINFO )
IF( IINFO .NE. 0 ) THEN
INFO = -4
RETURN
END IF
* SLARRB computes all gaps correctly except for the last one
* Record distance to VU/GU
WGAP( WEND ) = MAX( ZERO,
$ ( VU-SIGMA ) - ( W( WEND ) + WERR( WEND ) ) )
DO 138 I = INDL, INDU
M = M + 1
IBLOCK(M) = JBLK
INDEXW(M) = I
138 CONTINUE
ELSE
* Call dqds to get all eigs (and then possibly delete unwanted
* eigenvalues).
* Note that dqds finds the eigenvalues of the L D L^T representation
* of T to high relative accuracy. High relative accuracy
* might be lost when the shift of the RRR is subtracted to obtain
* the eigenvalues of T. However, T is not guaranteed to define its
* eigenvalues to high relative accuracy anyway.
* Set RTOL to the order of the tolerance used in SLASQ2
* This is an ESTIMATED error, the worst case bound is 4*N*EPS
* which is usually too large and requires unnecessary work to be
* done by bisection when computing the eigenvectors
RTOL = LOG(REAL(IN)) * FOUR * EPS
J = IBEGIN
DO 140 I = 1, IN - 1
WORK( 2*I-1 ) = ABS( D( J ) )
WORK( 2*I ) = E( J )*E( J )*WORK( 2*I-1 )
J = J + 1
140 CONTINUE
WORK( 2*IN-1 ) = ABS( D( IEND ) )
WORK( 2*IN ) = ZERO
CALL SLASQ2( IN, WORK, IINFO )
IF( IINFO .NE. 0 ) THEN
* If IINFO = -5 then an index is part of a tight cluster
* and should be changed. The index is in IWORK(1) and the
* gap is in WORK(N+1)
INFO = -5
RETURN
ELSE
* Test that all eigenvalues are positive as expected
DO 149 I = 1, IN
IF( WORK( I ).LT.ZERO ) THEN
INFO = -6
RETURN
ENDIF
149 CONTINUE
END IF
IF( SGNDEF.GT.ZERO ) THEN
DO 150 I = INDL, INDU
M = M + 1
W( M ) = WORK( IN-I+1 )
IBLOCK( M ) = JBLK
INDEXW( M ) = I
150 CONTINUE
ELSE
DO 160 I = INDL, INDU
M = M + 1
W( M ) = -WORK( I )
IBLOCK( M ) = JBLK
INDEXW( M ) = I
160 CONTINUE
END IF
DO 165 I = M - MB + 1, M
* the value of RTOL below should be the tolerance in SLASQ2
WERR( I ) = RTOL * ABS( W(I) )
165 CONTINUE
DO 166 I = M - MB + 1, M - 1
* compute the right gap between the intervals
WGAP( I ) = MAX( ZERO,
$ W(I+1)-WERR(I+1) - (W(I)+WERR(I)) )
166 CONTINUE
WGAP( M ) = MAX( ZERO,
$ ( VU-SIGMA ) - ( W( M ) + WERR( M ) ) )
END IF
* proceed with next block
IBEGIN = IEND + 1
WBEGIN = WEND + 1
170 CONTINUE
*
RETURN
*
* end of SLARRE
*
END
SUBROUTINE SLARRF( N, D, L, LD, CLSTRT, CLEND,
$ W, WGAP, WERR,
$ SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA,
$ DPLUS, LPLUS, WORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
**
* .. Scalar Arguments ..
INTEGER CLSTRT, CLEND, INFO, N
REAL CLGAPL, CLGAPR, PIVMIN, SIGMA, SPDIAM
* ..
* .. Array Arguments ..
REAL D( * ), DPLUS( * ), L( * ), LD( * ),
$ LPLUS( * ), W( * ), WGAP( * ), WERR( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* Given the initial representation L D L^T and its cluster of close
* eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ...
* W( CLEND ), SLARRF finds a new relatively robust representation
* L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the
* eigenvalues of L(+) D(+) L(+)^T is relatively isolated.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix (subblock, if the matrix splitted).
*
* D (input) REAL array, dimension (N)
* The N diagonal elements of the diagonal matrix D.
*
* L (input) REAL array, dimension (N-1)
* The (N-1) subdiagonal elements of the unit bidiagonal
* matrix L.
*
* LD (input) REAL array, dimension (N-1)
* The (N-1) elements L(i)*D(i).
*
* CLSTRT (input) INTEGER
* The index of the first eigenvalue in the cluster.
*
* CLEND (input) INTEGER
* The index of the last eigenvalue in the cluster.
*
* W (input) REAL array, dimension >= (CLEND-CLSTRT+1)
* The eigenvalue APPROXIMATIONS of L D L^T in ascending order.
* W( CLSTRT ) through W( CLEND ) form the cluster of relatively
* close eigenalues.
*
* WGAP (input/output) REAL array, dimension >= (CLEND-CLSTRT+1)
* The separation from the right neighbor eigenvalue in W.
*
* WERR (input) REAL array, dimension >= (CLEND-CLSTRT+1)
* WERR contain the semiwidth of the uncertainty
* interval of the corresponding eigenvalue APPROXIMATION in W
*
* SPDIAM (input) estimate of the spectral diameter obtained from the
* Gerschgorin intervals
*
* CLGAPL, CLGAPR (input) absolute gap on each end of the cluster.
* Set by the calling routine to protect against shifts too close
* to eigenvalues outside the cluster.
*
* PIVMIN (input) DOUBLE PRECISION
* The minimum pivot allowed in the Sturm sequence.
*
* SIGMA (output) REAL
* The shift used to form L(+) D(+) L(+)^T.
*
* DPLUS (output) REAL array, dimension (N)
* The N diagonal elements of the diagonal matrix D(+).
*
* LPLUS (output) REAL array, dimension (N-1)
* The first (N-1) elements of LPLUS contain the subdiagonal
* elements of the unit bidiagonal matrix L(+).
*
* WORK (workspace) REAL array, dimension (2*N)
* Workspace.
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL FOUR, MAXGROWTH1, MAXGROWTH2, ONE, QUART, TWO,
$ ZERO
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ FOUR = 4.0E0, QUART = 0.25E0,
$ MAXGROWTH1 = 8.E0,
$ MAXGROWTH2 = 8.E0 )
* ..
* .. Local Scalars ..
LOGICAL DORRR1, FORCER, NOFAIL, SAWNAN1, SAWNAN2, TRYRRR1
INTEGER I, INDX, KTRY, KTRYMAX, SLEFT, SRIGHT, SHIFT
PARAMETER ( KTRYMAX = 1, SLEFT = 1, SRIGHT = 2 )
REAL AVGAP, BESTSHIFT, CLWDTH, EPS, FACT, FAIL,
$ FAIL2, GROWTHBOUND, LDELTA, LDMAX, LSIGMA,
$ MAX1, MAX2, MINGAP, OLDP, PROD, RDELTA, RDMAX,
$ RRR1, RRR2, RSIGMA, S, SMLGROWTH, TMP, ZNM2
* ..
* .. External Functions ..
LOGICAL SISNAN
REAL SLAMCH
EXTERNAL SISNAN, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SCOPY
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
INFO = 0
FACT = REAL(2**KTRYMAX)
EPS = SLAMCH( 'Precision' )
SHIFT = 0
FORCER = .FALSE.
* Note that we cannot guarantee that for any of the shifts tried,
* the factorization has a small or even moderate element growth.
* There could be Ritz values at both ends of the cluster and despite
* backing off, there are examples where all factorizations tried
* (in IEEE mode, allowing zero pivots & infinities) have INFINITE
* element growth.
* For this reason, we should use PIVMIN in this subroutine so that at
* least the L D L^T factorization exists. It can be checked afterwards
* whether the element growth caused bad residuals/orthogonality.
* Decide whether the code should accept the best among all
* representations despite large element growth or signal INFO=1
NOFAIL = .TRUE.
*
* Compute the average gap length of the cluster
CLWDTH = ABS(W(CLEND)-W(CLSTRT)) + WERR(CLEND) + WERR(CLSTRT)
AVGAP = CLWDTH / REAL(CLEND-CLSTRT)
MINGAP = MIN(CLGAPL, CLGAPR)
* Initial values for shifts to both ends of cluster
LSIGMA = MIN(W( CLSTRT ),W( CLEND )) - WERR( CLSTRT )
RSIGMA = MAX(W( CLSTRT ),W( CLEND )) + WERR( CLEND )
* Use a small fudge to make sure that we really shift to the outside
LSIGMA = LSIGMA - ABS(LSIGMA)* TWO * EPS
RSIGMA = RSIGMA + ABS(RSIGMA)* TWO * EPS
* Compute upper bounds for how much to back off the initial shifts
LDMAX = QUART * MINGAP + TWO * PIVMIN
RDMAX = QUART * MINGAP + TWO * PIVMIN
LDELTA = MAX(AVGAP,WGAP( CLSTRT ))/FACT
RDELTA = MAX(AVGAP,WGAP( CLEND-1 ))/FACT
*
* Initialize the record of the best representation found
*
S = SLAMCH( 'S' )
SMLGROWTH = ONE / S
FAIL = REAL(N-1)*MINGAP/(SPDIAM*EPS)
FAIL2 = REAL(N-1)*MINGAP/(SPDIAM*SQRT(EPS))
BESTSHIFT = LSIGMA
*
* while (KTRY <= KTRYMAX)
KTRY = 0
GROWTHBOUND = MAXGROWTH1*SPDIAM
5 CONTINUE
SAWNAN1 = .FALSE.
SAWNAN2 = .FALSE.
* Ensure that we do not back off too much of the initial shifts
LDELTA = MIN(LDMAX,LDELTA)
RDELTA = MIN(RDMAX,RDELTA)
* Compute the element growth when shifting to both ends of the cluster
* accept the shift if there is no element growth at one of the two ends
* Left end
S = -LSIGMA
DPLUS( 1 ) = D( 1 ) + S
IF(ABS(DPLUS(1)).LT.PIVMIN) THEN
DPLUS(1) = -PIVMIN
* Need to set SAWNAN1 because refined RRR test should not be used
* in this case
SAWNAN1 = .TRUE.
ENDIF
MAX1 = ABS( DPLUS( 1 ) )
DO 6 I = 1, N - 1
LPLUS( I ) = LD( I ) / DPLUS( I )
S = S*LPLUS( I )*L( I ) - LSIGMA
DPLUS( I+1 ) = D( I+1 ) + S
IF(ABS(DPLUS(I+1)).LT.PIVMIN) THEN
DPLUS(I+1) = -PIVMIN
* Need to set SAWNAN1 because refined RRR test should not be used
* in this case
SAWNAN1 = .TRUE.
ENDIF
MAX1 = MAX( MAX1,ABS(DPLUS(I+1)) )
6 CONTINUE
SAWNAN1 = SAWNAN1 .OR. SISNAN( MAX1 )
IF( FORCER .OR.
$ (MAX1.LE.GROWTHBOUND .AND. .NOT.SAWNAN1 ) ) THEN
SIGMA = LSIGMA
SHIFT = SLEFT
GOTO 100
ENDIF
* Right end
S = -RSIGMA
WORK( 1 ) = D( 1 ) + S
IF(ABS(WORK(1)).LT.PIVMIN) THEN
WORK(1) = -PIVMIN
* Need to set SAWNAN2 because refined RRR test should not be used
* in this case
SAWNAN2 = .TRUE.
ENDIF
MAX2 = ABS( WORK( 1 ) )
DO 7 I = 1, N - 1
WORK( N+I ) = LD( I ) / WORK( I )
S = S*WORK( N+I )*L( I ) - RSIGMA
WORK( I+1 ) = D( I+1 ) + S
IF(ABS(WORK(I+1)).LT.PIVMIN) THEN
WORK(I+1) = -PIVMIN
* Need to set SAWNAN2 because refined RRR test should not be used
* in this case
SAWNAN2 = .TRUE.
ENDIF
MAX2 = MAX( MAX2,ABS(WORK(I+1)) )
7 CONTINUE
SAWNAN2 = SAWNAN2 .OR. SISNAN( MAX2 )
IF( FORCER .OR.
$ (MAX2.LE.GROWTHBOUND .AND. .NOT.SAWNAN2 ) ) THEN
SIGMA = RSIGMA
SHIFT = SRIGHT
GOTO 100
ENDIF
* If we are at this point, both shifts led to too much element growth
* Record the better of the two shifts (provided it didn't lead to NaN)
IF(SAWNAN1.AND.SAWNAN2) THEN
* both MAX1 and MAX2 are NaN
GOTO 50
ELSE
IF( .NOT.SAWNAN1 ) THEN
INDX = 1
IF(MAX1.LE.SMLGROWTH) THEN
SMLGROWTH = MAX1
BESTSHIFT = LSIGMA
ENDIF
ENDIF
IF( .NOT.SAWNAN2 ) THEN
IF(SAWNAN1 .OR. MAX2.LE.MAX1) INDX = 2
IF(MAX2.LE.SMLGROWTH) THEN
SMLGROWTH = MAX2
BESTSHIFT = RSIGMA
ENDIF
ENDIF
ENDIF
* If we are here, both the left and the right shift led to
* element growth. If the element growth is moderate, then
* we may still accept the representation, if it passes a
* refined test for RRR. This test supposes that no NaN occurred.
* Moreover, we use the refined RRR test only for isolated clusters.
IF((CLWDTH.LT.MINGAP/REAL(128)) .AND.
$ (MIN(MAX1,MAX2).LT.FAIL2)
$ .AND.(.NOT.SAWNAN1).AND.(.NOT.SAWNAN2)) THEN
DORRR1 = .TRUE.
ELSE
DORRR1 = .FALSE.
ENDIF
TRYRRR1 = .TRUE.
IF( TRYRRR1 .AND. DORRR1 ) THEN
IF(INDX.EQ.1) THEN
TMP = ABS( DPLUS( N ) )
ZNM2 = ONE
PROD = ONE
OLDP = ONE
DO 15 I = N-1, 1, -1
IF( PROD .LE. EPS ) THEN
PROD =
$ ((DPLUS(I+1)*WORK(N+I+1))/(DPLUS(I)*WORK(N+I)))*OLDP
ELSE
PROD = PROD*ABS(WORK(N+I))
END IF
OLDP = PROD
ZNM2 = ZNM2 + PROD**2
TMP = MAX( TMP, ABS( DPLUS( I ) * PROD ))
15 CONTINUE
RRR1 = TMP/( SPDIAM * SQRT( ZNM2 ) )
IF (RRR1.LE.MAXGROWTH2) THEN
SIGMA = LSIGMA
SHIFT = SLEFT
GOTO 100
ENDIF
ELSE IF(INDX.EQ.2) THEN
TMP = ABS( WORK( N ) )
ZNM2 = ONE
PROD = ONE
OLDP = ONE
DO 16 I = N-1, 1, -1
IF( PROD .LE. EPS ) THEN
PROD = ((WORK(I+1)*LPLUS(I+1))/(WORK(I)*LPLUS(I)))*OLDP
ELSE
PROD = PROD*ABS(LPLUS(I))
END IF
OLDP = PROD
ZNM2 = ZNM2 + PROD**2
TMP = MAX( TMP, ABS( WORK( I ) * PROD ))
16 CONTINUE
RRR2 = TMP/( SPDIAM * SQRT( ZNM2 ) )
IF (RRR2.LE.MAXGROWTH2) THEN
SIGMA = RSIGMA
SHIFT = SRIGHT
GOTO 100
ENDIF
END IF
ENDIF
50 CONTINUE
IF (KTRY.LT.KTRYMAX) THEN
* If we are here, both shifts failed also the RRR test.
* Back off to the outside
LSIGMA = MAX( LSIGMA - LDELTA,
$ LSIGMA - LDMAX)
RSIGMA = MIN( RSIGMA + RDELTA,
$ RSIGMA + RDMAX )
LDELTA = TWO * LDELTA
RDELTA = TWO * RDELTA
KTRY = KTRY + 1
GOTO 5
ELSE
* None of the representations investigated satisfied our
* criteria. Take the best one we found.
IF((SMLGROWTH.LT.FAIL).OR.NOFAIL) THEN
LSIGMA = BESTSHIFT
RSIGMA = BESTSHIFT
FORCER = .TRUE.
GOTO 5
ELSE
INFO = 1
RETURN
ENDIF
END IF
100 CONTINUE
IF (SHIFT.EQ.SLEFT) THEN
ELSEIF (SHIFT.EQ.SRIGHT) THEN
* store new L and D back into DPLUS, LPLUS
CALL SCOPY( N, WORK, 1, DPLUS, 1 )
CALL SCOPY( N-1, WORK(N+1), 1, LPLUS, 1 )
ENDIF
RETURN
*
* End of SLARRF
*
END
SUBROUTINE SLARRJ( N, D, E2, IFIRST, ILAST,
$ RTOL, OFFSET, W, WERR, WORK, IWORK,
$ PIVMIN, SPDIAM, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IFIRST, ILAST, INFO, N, OFFSET
REAL PIVMIN, RTOL, SPDIAM
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL D( * ), E2( * ), W( * ),
$ WERR( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* Given the initial eigenvalue approximations of T, SLARRJ
* does bisection to refine the eigenvalues of T,
* W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial
* guesses for these eigenvalues are input in W, the corresponding estimate
* of the error in these guesses in WERR. During bisection, intervals
* [left, right] are maintained by storing their mid-points and
* semi-widths in the arrays W and WERR respectively.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix.
*
* D (input) REAL array, dimension (N)
* The N diagonal elements of T.
*
* E2 (input) REAL array, dimension (N-1)
* The Squares of the (N-1) subdiagonal elements of T.
*
* IFIRST (input) INTEGER
* The index of the first eigenvalue to be computed.
*
* ILAST (input) INTEGER
* The index of the last eigenvalue to be computed.
*
* RTOL (input) REAL
* Tolerance for the convergence of the bisection intervals.
* An interval [LEFT,RIGHT] has converged if
* RIGHT-LEFT.LT.RTOL*MAX(|LEFT|,|RIGHT|).
*
* OFFSET (input) INTEGER
* Offset for the arrays W and WERR, i.e., the IFIRST-OFFSET
* through ILAST-OFFSET elements of these arrays are to be used.
*
* W (input/output) REAL array, dimension (N)
* On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are
* estimates of the eigenvalues of L D L^T indexed IFIRST through
* ILAST.
* On output, these estimates are refined.
*
* WERR (input/output) REAL array, dimension (N)
* On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are
* the errors in the estimates of the corresponding elements in W.
* On output, these errors are refined.
*
* WORK (workspace) REAL array, dimension (2*N)
* Workspace.
*
* IWORK (workspace) INTEGER array, dimension (2*N)
* Workspace.
*
* PIVMIN (input) DOUBLE PRECISION
* The minimum pivot in the Sturm sequence for T.
*
* SPDIAM (input) DOUBLE PRECISION
* The spectral diameter of T.
*
* INFO (output) INTEGER
* Error flag.
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO, HALF
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ HALF = 0.5E0 )
INTEGER MAXITR
* ..
* .. Local Scalars ..
INTEGER CNT, I, I1, I2, II, ITER, J, K, NEXT, NINT,
$ OLNINT, P, PREV, SAVI1
REAL DPLUS, FAC, LEFT, MID, RIGHT, S, TMP, WIDTH
*
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
INFO = 0
*
MAXITR = INT( ( LOG( SPDIAM+PIVMIN )-LOG( PIVMIN ) ) /
$ LOG( TWO ) ) + 2
*
* Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ].
* The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while
* Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 )
* for an unconverged interval is set to the index of the next unconverged
* interval, and is -1 or 0 for a converged interval. Thus a linked
* list of unconverged intervals is set up.
*
I1 = IFIRST
I2 = ILAST
* The number of unconverged intervals
NINT = 0
* The last unconverged interval found
PREV = 0
DO 75 I = I1, I2
K = 2*I
II = I - OFFSET
LEFT = W( II ) - WERR( II )
MID = W(II)
RIGHT = W( II ) + WERR( II )
WIDTH = RIGHT - MID
TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
* The following test prevents the test of converged intervals
IF( WIDTH.LT.RTOL*TMP ) THEN
* This interval has already converged and does not need refinement.
* (Note that the gaps might change through refining the
* eigenvalues, however, they can only get bigger.)
* Remove it from the list.
IWORK( K-1 ) = -1
* Make sure that I1 always points to the first unconverged interval
IF((I.EQ.I1).AND.(I.LT.I2)) I1 = I + 1
IF((PREV.GE.I1).AND.(I.LE.I2)) IWORK( 2*PREV-1 ) = I + 1
ELSE
* unconverged interval found
PREV = I
* Make sure that [LEFT,RIGHT] contains the desired eigenvalue
*
* Do while( CNT(LEFT).GT.I-1 )
*
FAC = ONE
20 CONTINUE
CNT = 0
S = LEFT
DPLUS = D( 1 ) - S
IF( DPLUS.LT.ZERO ) CNT = CNT + 1
DO 30 J = 2, N
DPLUS = D( J ) - S - E2( J-1 )/DPLUS
IF( DPLUS.LT.ZERO ) CNT = CNT + 1
30 CONTINUE
IF( CNT.GT.I-1 ) THEN
LEFT = LEFT - WERR( II )*FAC
FAC = TWO*FAC
GO TO 20
END IF
*
* Do while( CNT(RIGHT).LT.I )
*
FAC = ONE
50 CONTINUE
CNT = 0
S = RIGHT
DPLUS = D( 1 ) - S
IF( DPLUS.LT.ZERO ) CNT = CNT + 1
DO 60 J = 2, N
DPLUS = D( J ) - S - E2( J-1 )/DPLUS
IF( DPLUS.LT.ZERO ) CNT = CNT + 1
60 CONTINUE
IF( CNT.LT.I ) THEN
RIGHT = RIGHT + WERR( II )*FAC
FAC = TWO*FAC
GO TO 50
END IF
NINT = NINT + 1
IWORK( K-1 ) = I + 1
IWORK( K ) = CNT
END IF
WORK( K-1 ) = LEFT
WORK( K ) = RIGHT
75 CONTINUE
SAVI1 = I1
*
* Do while( NINT.GT.0 ), i.e. there are still unconverged intervals
* and while (ITER.LT.MAXITR)
*
ITER = 0
80 CONTINUE
PREV = I1 - 1
I = I1
OLNINT = NINT
DO 100 P = 1, OLNINT
K = 2*I
II = I - OFFSET
NEXT = IWORK( K-1 )
LEFT = WORK( K-1 )
RIGHT = WORK( K )
MID = HALF*( LEFT + RIGHT )
* semiwidth of interval
WIDTH = RIGHT - MID
TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
IF( ( WIDTH.LT.RTOL*TMP ) .OR.
$ (ITER.EQ.MAXITR) )THEN
* reduce number of unconverged intervals
NINT = NINT - 1
* Mark interval as converged.
IWORK( K-1 ) = 0
IF( I1.EQ.I ) THEN
I1 = NEXT
ELSE
* Prev holds the last unconverged interval previously examined
IF(PREV.GE.I1) IWORK( 2*PREV-1 ) = NEXT
END IF
I = NEXT
GO TO 100
END IF
PREV = I
*
* Perform one bisection step
*
CNT = 0
S = MID
DPLUS = D( 1 ) - S
IF( DPLUS.LT.ZERO ) CNT = CNT + 1
DO 90 J = 2, N
DPLUS = D( J ) - S - E2( J-1 )/DPLUS
IF( DPLUS.LT.ZERO ) CNT = CNT + 1
90 CONTINUE
IF( CNT.LE.I-1 ) THEN
WORK( K-1 ) = MID
ELSE
WORK( K ) = MID
END IF
I = NEXT
100 CONTINUE
ITER = ITER + 1
* do another loop if there are still unconverged intervals
* However, in the last iteration, all intervals are accepted
* since this is the best we can do.
IF( ( NINT.GT.0 ).AND.(ITER.LE.MAXITR) ) GO TO 80
*
*
* At this point, all the intervals have converged
DO 110 I = SAVI1, ILAST
K = 2*I
II = I - OFFSET
* All intervals marked by '0' have been refined.
IF( IWORK( K-1 ).EQ.0 ) THEN
W( II ) = HALF*( WORK( K-1 )+WORK( K ) )
WERR( II ) = WORK( K ) - W( II )
END IF
110 CONTINUE
*
RETURN
*
* End of SLARRJ
*
END
SUBROUTINE SLARRK( N, IW, GL, GU,
$ D, E2, PIVMIN, RELTOL, W, WERR, INFO)
IMPLICIT NONE
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, IW, N
REAL PIVMIN, RELTOL, GL, GU, W, WERR
* ..
* .. Array Arguments ..
REAL D( * ), E2( * )
* ..
*
* Purpose
* =======
*
* SLARRK computes one eigenvalue of a symmetric tridiagonal
* matrix T to suitable accuracy. This is an auxiliary code to be
* called from SSTEMR.
*
* To avoid overflow, the matrix must be scaled so that its
* largest element is no greater than overflow**(1/2) *
* underflow**(1/4) in absolute value, and for greatest
* accuracy, it should not be much smaller than that.
*
* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
* Matrix", Report CS41, Computer Science Dept., Stanford
* University, July 21, 1966.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the tridiagonal matrix T. N >= 0.
*
* IW (input) INTEGER
* The index of the eigenvalues to be returned.
*
* GL (input) REAL
* GU (input) REAL
* An upper and a lower bound on the eigenvalue.
*
* D (input) REAL array, dimension (N)
* The n diagonal elements of the tridiagonal matrix T.
*
* E2 (input) REAL array, dimension (N-1)
* The (n-1) squared off-diagonal elements of the tridiagonal matrix T.
*
* PIVMIN (input) REAL
* The minimum pivot allowed in the Sturm sequence for T.
*
* RELTOL (input) REAL
* The minimum relative width of an interval. When an interval
* is narrower than RELTOL times the larger (in
* magnitude) endpoint, then it is considered to be
* sufficiently small, i.e., converged. Note: this should
* always be at least radix*machine epsilon.
*
* W (output) REAL
*
* WERR (output) REAL
* The error bound on the corresponding eigenvalue approximation
* in W.
*
* INFO (output) INTEGER
* = 0: Eigenvalue converged
* = -1: Eigenvalue did NOT converge
*
* Internal Parameters
* ===================
*
* FUDGE REAL , default = 2
* A "fudge factor" to widen the Gershgorin intervals.
*
* =====================================================================
*
* .. Parameters ..
REAL FUDGE, HALF, TWO, ZERO
PARAMETER ( HALF = 0.5E0, TWO = 2.0E0,
$ FUDGE = TWO, ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
INTEGER I, IT, ITMAX, NEGCNT
REAL ATOLI, EPS, LEFT, MID, RIGHT, RTOLI, TMP1,
$ TMP2, TNORM
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX
* ..
* .. Executable Statements ..
*
* Get machine constants
EPS = SLAMCH( 'P' )
TNORM = MAX( ABS( GL ), ABS( GU ) )
RTOLI = RELTOL
ATOLI = FUDGE*TWO*PIVMIN
ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) /
$ LOG( TWO ) ) + 2
INFO = -1
LEFT = GL - FUDGE*TNORM*EPS*N - FUDGE*TWO*PIVMIN
RIGHT = GU + FUDGE*TNORM*EPS*N + FUDGE*TWO*PIVMIN
IT = 0
10 CONTINUE
*
* Check if interval converged or maximum number of iterations reached
*
TMP1 = ABS( RIGHT - LEFT )
TMP2 = MAX( ABS(RIGHT), ABS(LEFT) )
IF( TMP1.LT.MAX( ATOLI, PIVMIN, RTOLI*TMP2 ) ) THEN
INFO = 0
GOTO 30
ENDIF
IF(IT.GT.ITMAX)
$ GOTO 30
*
* Count number of negative pivots for mid-point
*
IT = IT + 1
MID = HALF * (LEFT + RIGHT)
NEGCNT = 0
TMP1 = D( 1 ) - MID
IF( ABS( TMP1 ).LT.PIVMIN )
$ TMP1 = -PIVMIN
IF( TMP1.LE.ZERO )
$ NEGCNT = NEGCNT + 1
*
DO 20 I = 2, N
TMP1 = D( I ) - E2( I-1 ) / TMP1 - MID
IF( ABS( TMP1 ).LT.PIVMIN )
$ TMP1 = -PIVMIN
IF( TMP1.LE.ZERO )
$ NEGCNT = NEGCNT + 1
20 CONTINUE
IF(NEGCNT.GE.IW) THEN
RIGHT = MID
ELSE
LEFT = MID
ENDIF
GOTO 10
30 CONTINUE
*
* Converged or maximum number of iterations reached
*
W = HALF * (LEFT + RIGHT)
WERR = HALF * ABS( RIGHT - LEFT )
RETURN
*
* End of SLARRK
*
END
SUBROUTINE SLARRR( N, D, E, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER N, INFO
* ..
* .. Array Arguments ..
REAL D( * ), E( * )
* ..
*
*
* Purpose
* =======
*
* Perform tests to decide whether the symmetric tridiagonal matrix T
* warrants expensive computations which guarantee high relative accuracy
* in the eigenvalues.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix. N > 0.
*
* D (input) REAL array, dimension (N)
* The N diagonal elements of the tridiagonal matrix T.
*
* E (input/output) REAL array, dimension (N)
* On entry, the first (N-1) entries contain the subdiagonal
* elements of the tridiagonal matrix T; E(N) is set to ZERO.
*
* INFO (output) INTEGER
* INFO = 0(default) : the matrix warrants computations preserving
* relative accuracy.
* INFO = 1 : the matrix warrants computations guaranteeing
* only absolute accuracy.
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, RELCOND
PARAMETER ( ZERO = 0.0E0,
$ RELCOND = 0.999E0 )
* ..
* .. Local Scalars ..
INTEGER I
LOGICAL YESREL
REAL EPS, SAFMIN, SMLNUM, RMIN, TMP, TMP2,
$ OFFDIG, OFFDIG2
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
* As a default, do NOT go for relative-accuracy preserving computations.
INFO = 1
SAFMIN = SLAMCH( 'Safe minimum' )
EPS = SLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
RMIN = SQRT( SMLNUM )
* Tests for relative accuracy
*
* Test for scaled diagonal dominance
* Scale the diagonal entries to one and check whether the sum of the
* off-diagonals is less than one
*
* The sdd relative error bounds have a 1/(1- 2*x) factor in them,
* x = max(OFFDIG + OFFDIG2), so when x is close to 1/2, no relative
* accuracy is promised. In the notation of the code fragment below,
* 1/(1 - (OFFDIG + OFFDIG2)) is the condition number.
* We don't think it is worth going into "sdd mode" unless the relative
* condition number is reasonable, not 1/macheps.
* The threshold should be compatible with other thresholds used in the
* code. We set OFFDIG + OFFDIG2 <= .999 =: RELCOND, it corresponds
* to losing at most 3 decimal digits: 1 / (1 - (OFFDIG + OFFDIG2)) <= 1000
* instead of the current OFFDIG + OFFDIG2 < 1
*
YESREL = .TRUE.
OFFDIG = ZERO
TMP = SQRT(ABS(D(1)))
IF (TMP.LT.RMIN) YESREL = .FALSE.
IF(.NOT.YESREL) GOTO 11
DO 10 I = 2, N
TMP2 = SQRT(ABS(D(I)))
IF (TMP2.LT.RMIN) YESREL = .FALSE.
IF(.NOT.YESREL) GOTO 11
OFFDIG2 = ABS(E(I-1))/(TMP*TMP2)
IF(OFFDIG+OFFDIG2.GE.RELCOND) YESREL = .FALSE.
IF(.NOT.YESREL) GOTO 11
TMP = TMP2
OFFDIG = OFFDIG2
10 CONTINUE
11 CONTINUE
IF( YESREL ) THEN
INFO = 0
RETURN
ELSE
ENDIF
*
*
* *** MORE TO BE IMPLEMENTED ***
*
*
* Test if the lower bidiagonal matrix L from T = L D L^T
* (zero shift facto) is well conditioned
*
*
* Test if the upper bidiagonal matrix U from T = U D U^T
* (zero shift facto) is well conditioned.
* In this case, the matrix needs to be flipped and, at the end
* of the eigenvector computation, the flip needs to be applied
* to the computed eigenvectors (and the support)
*
*
RETURN
*
* END OF SLARRR
*
END
SUBROUTINE SLARRV( N, VL, VU, D, L, PIVMIN,
$ ISPLIT, M, DOL, DOU, MINRGP,
$ RTOL1, RTOL2, W, WERR, WGAP,
$ IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ,
$ WORK, IWORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER DOL, DOU, INFO, LDZ, M, N
REAL MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU
* ..
* .. Array Arguments ..
INTEGER IBLOCK( * ), INDEXW( * ), ISPLIT( * ),
$ ISUPPZ( * ), IWORK( * )
REAL D( * ), GERS( * ), L( * ), W( * ), WERR( * ),
$ WGAP( * ), WORK( * )
REAL Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SLARRV computes the eigenvectors of the tridiagonal matrix
* T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T.
* The input eigenvalues should have been computed by SLARRE.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* VL (input) REAL
* VU (input) REAL
* Lower and upper bounds of the interval that contains the desired
* eigenvalues. VL < VU. Needed to compute gaps on the left or right
* end of the extremal eigenvalues in the desired RANGE.
*
* D (input/output) REAL array, dimension (N)
* On entry, the N diagonal elements of the diagonal matrix D.
* On exit, D may be overwritten.
*
* L (input/output) REAL array, dimension (N)
* On entry, the (N-1) subdiagonal elements of the unit
* bidiagonal matrix L are in elements 1 to N-1 of L
* (if the matrix is not splitted.) At the end of each block
* is stored the corresponding shift as given by SLARRE.
* On exit, L is overwritten.
*
* PIVMIN (in) DOUBLE PRECISION
* The minimum pivot allowed in the Sturm sequence.
*
* ISPLIT (input) INTEGER array, dimension (N)
* The splitting points, at which T breaks up into blocks.
* The first block consists of rows/columns 1 to
* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
* through ISPLIT( 2 ), etc.
*
* M (input) INTEGER
* The total number of input eigenvalues. 0 <= M <= N.
*
* DOL (input) INTEGER
* DOU (input) INTEGER
* If the user wants to compute only selected eigenvectors from all
* the eigenvalues supplied, he can specify an index range DOL:DOU.
* Or else the setting DOL=1, DOU=M should be applied.
* Note that DOL and DOU refer to the order in which the eigenvalues
* are stored in W.
* If the user wants to compute only selected eigenpairs, then
* the columns DOL-1 to DOU+1 of the eigenvector space Z contain the
* computed eigenvectors. All other columns of Z are set to zero.
*
* MINRGP (input) REAL
*
* RTOL1 (input) REAL
* RTOL2 (input) REAL
* Parameters for bisection.
* An interval [LEFT,RIGHT] has converged if
* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
*
* W (input/output) REAL array, dimension (N)
* The first M elements of W contain the APPROXIMATE eigenvalues for
* which eigenvectors are to be computed. The eigenvalues
* should be grouped by split-off block and ordered from
* smallest to largest within the block ( The output array
* W from SLARRE is expected here ). Furthermore, they are with
* respect to the shift of the corresponding root representation
* for their block. On exit, W holds the eigenvalues of the
* UNshifted matrix.
*
* WERR (input/output) REAL array, dimension (N)
* The first M elements contain the semiwidth of the uncertainty
* interval of the corresponding eigenvalue in W
*
* WGAP (input/output) REAL array, dimension (N)
* The separation from the right neighbor eigenvalue in W.
*
* IBLOCK (input) INTEGER array, dimension (N)
* The indices of the blocks (submatrices) associated with the
* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue
* W(i) belongs to the first block from the top, =2 if W(i)
* belongs to the second block, etc.
*
* INDEXW (input) INTEGER array, dimension (N)
* The indices of the eigenvalues within each block (submatrix);
* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the
* i-th eigenvalue W(i) is the 10-th eigenvalue in the second block.
*
* GERS (input) REAL array, dimension (2*N)
* The N Gerschgorin intervals (the i-th Gerschgorin interval
* is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should
* be computed from the original UNshifted matrix.
*
* Z (output) REAL array, dimension (LDZ, max(1,M) )
* If INFO = 0, the first M columns of Z contain the
* orthonormal eigenvectors of the matrix T
* corresponding to the input eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* Note: the user must ensure that at least max(1,M) columns are
* supplied in the array Z.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )
* The support of the eigenvectors in Z, i.e., the indices
* indicating the nonzero elements in Z. The I-th eigenvector
* is nonzero only in elements ISUPPZ( 2*I-1 ) through
* ISUPPZ( 2*I ).
*
* WORK (workspace) REAL array, dimension (12*N)
*
* IWORK (workspace) INTEGER array, dimension (7*N)
*
* INFO (output) INTEGER
* = 0: successful exit
*
* > 0: A problem occured in SLARRV.
* < 0: One of the called subroutines signaled an internal problem.
* Needs inspection of the corresponding parameter IINFO
* for further information.
*
* =-1: Problem in SLARRB when refining a child's eigenvalues.
* =-2: Problem in SLARRF when computing the RRR of a child.
* When a child is inside a tight cluster, it can be difficult
* to find an RRR. A partial remedy from the user's point of
* view is to make the parameter MINRGP smaller and recompile.
* However, as the orthogonality of the computed vectors is
* proportional to 1/MINRGP, the user should be aware that
* he might be trading in precision when he decreases MINRGP.
* =-3: Problem in SLARRB when refining a single eigenvalue
* after the Rayleigh correction was rejected.
* = 5: The Rayleigh Quotient Iteration failed to converge to
* full accuracy in MAXITR steps.
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXITR
PARAMETER ( MAXITR = 10 )
REAL ZERO, ONE, TWO, THREE, FOUR, HALF
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0,
$ TWO = 2.0E0, THREE = 3.0E0,
$ FOUR = 4.0E0, HALF = 0.5E0)
* ..
* .. Local Scalars ..
LOGICAL ESKIP, NEEDBS, STP2II, TRYRQC, USEDBS, USEDRQ
INTEGER DONE, I, IBEGIN, IDONE, IEND, II, IINDC1,
$ IINDC2, IINDR, IINDWK, IINFO, IM, IN, INDEIG,
$ INDLD, INDLLD, INDWRK, ISUPMN, ISUPMX, ITER,
$ ITMP1, J, JBLK, K, MINIWSIZE, MINWSIZE, NCLUS,
$ NDEPTH, NEGCNT, NEWCLS, NEWFST, NEWFTT, NEWLST,
$ NEWSIZ, OFFSET, OLDCLS, OLDFST, OLDIEN, OLDLST,
$ OLDNCL, P, PARITY, Q, WBEGIN, WEND, WINDEX,
$ WINDMN, WINDPL, ZFROM, ZTO, ZUSEDL, ZUSEDU,
$ ZUSEDW
REAL BSTRES, BSTW, EPS, FUDGE, GAP, GAPTOL, GL, GU,
$ LAMBDA, LEFT, LGAP, MINGMA, NRMINV, RESID,
$ RGAP, RIGHT, RQCORR, RQTOL, SAVGAP, SGNDEF,
$ SIGMA, SPDIAM, SSIGMA, TAU, TMP, TOL, ZTZ
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLAR1V, SLARRB, SLARRF, SLASET,
$ SSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, REAL, MAX, MIN
* ..
* .. Executable Statements ..
* ..
* The first N entries of WORK are reserved for the eigenvalues
INDLD = N+1
INDLLD= 2*N+1
INDWRK= 3*N+1
MINWSIZE = 12 * N
DO 5 I= 1,MINWSIZE
WORK( I ) = ZERO
5 CONTINUE
* IWORK(IINDR+1:IINDR+N) hold the twist indices R for the
* factorization used to compute the FP vector
IINDR = 0
* IWORK(IINDC1+1:IINC2+N) are used to store the clusters of the current
* layer and the one above.
IINDC1 = N
IINDC2 = 2*N
IINDWK = 3*N + 1
MINIWSIZE = 7 * N
DO 10 I= 1,MINIWSIZE
IWORK( I ) = 0
10 CONTINUE
ZUSEDL = 1
IF(DOL.GT.1) THEN
* Set lower bound for use of Z
ZUSEDL = DOL-1
ENDIF
ZUSEDU = M
IF(DOU.LT.M) THEN
* Set lower bound for use of Z
ZUSEDU = DOU+1
ENDIF
* The width of the part of Z that is used
ZUSEDW = ZUSEDU - ZUSEDL + 1
CALL SLASET( 'Full', N, ZUSEDW, ZERO, ZERO,
$ Z(1,ZUSEDL), LDZ )
EPS = SLAMCH( 'Precision' )
RQTOL = TWO * EPS
*
* Set expert flags for standard code.
TRYRQC = .TRUE.
IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN
ELSE
* Only selected eigenpairs are computed. Since the other evalues
* are not refined by RQ iteration, bisection has to compute to full
* accuracy.
RTOL1 = FOUR * EPS
RTOL2 = FOUR * EPS
ENDIF
* The entries WBEGIN:WEND in W, WERR, WGAP correspond to the
* desired eigenvalues. The support of the nonzero eigenvector
* entries is contained in the interval IBEGIN:IEND.
* Remark that if k eigenpairs are desired, then the eigenvectors
* are stored in k contiguous columns of Z.
* DONE is the number of eigenvectors already computed
DONE = 0
IBEGIN = 1
WBEGIN = 1
DO 170 JBLK = 1, IBLOCK( M )
IEND = ISPLIT( JBLK )
SIGMA = L( IEND )
* Find the eigenvectors of the submatrix indexed IBEGIN
* through IEND.
WEND = WBEGIN - 1
15 CONTINUE
IF( WEND.LT.M ) THEN
IF( IBLOCK( WEND+1 ).EQ.JBLK ) THEN
WEND = WEND + 1
GO TO 15
END IF
END IF
IF( WEND.LT.WBEGIN ) THEN
IBEGIN = IEND + 1
GO TO 170
ELSEIF( (WEND.LT.DOL).OR.(WBEGIN.GT.DOU) ) THEN
IBEGIN = IEND + 1
WBEGIN = WEND + 1
GO TO 170
END IF
* Find local spectral diameter of the block
GL = GERS( 2*IBEGIN-1 )
GU = GERS( 2*IBEGIN )
DO 20 I = IBEGIN+1 , IEND
GL = MIN( GERS( 2*I-1 ), GL )
GU = MAX( GERS( 2*I ), GU )
20 CONTINUE
SPDIAM = GU - GL
* OLDIEN is the last index of the previous block
OLDIEN = IBEGIN - 1
* Calculate the size of the current block
IN = IEND - IBEGIN + 1
* The number of eigenvalues in the current block
IM = WEND - WBEGIN + 1
* This is for a 1x1 block
IF( IBEGIN.EQ.IEND ) THEN
DONE = DONE+1
Z( IBEGIN, WBEGIN ) = ONE
ISUPPZ( 2*WBEGIN-1 ) = IBEGIN
ISUPPZ( 2*WBEGIN ) = IBEGIN
W( WBEGIN ) = W( WBEGIN ) + SIGMA
WORK( WBEGIN ) = W( WBEGIN )
IBEGIN = IEND + 1
WBEGIN = WBEGIN + 1
GO TO 170
END IF
* The desired (shifted) eigenvalues are stored in W(WBEGIN:WEND)
* Note that these can be approximations, in this case, the corresp.
* entries of WERR give the size of the uncertainty interval.
* The eigenvalue approximations will be refined when necessary as
* high relative accuracy is required for the computation of the
* corresponding eigenvectors.
CALL SCOPY( IM, W( WBEGIN ), 1,
& WORK( WBEGIN ), 1 )
* We store in W the eigenvalue approximations w.r.t. the original
* matrix T.
DO 30 I=1,IM
W(WBEGIN+I-1) = W(WBEGIN+I-1)+SIGMA
30 CONTINUE
* NDEPTH is the current depth of the representation tree
NDEPTH = 0
* PARITY is either 1 or 0
PARITY = 1
* NCLUS is the number of clusters for the next level of the
* representation tree, we start with NCLUS = 1 for the root
NCLUS = 1
IWORK( IINDC1+1 ) = 1
IWORK( IINDC1+2 ) = IM
* IDONE is the number of eigenvectors already computed in the current
* block
IDONE = 0
* loop while( IDONE.LT.IM )
* generate the representation tree for the current block and
* compute the eigenvectors
40 CONTINUE
IF( IDONE.LT.IM ) THEN
* This is a crude protection against infinitely deep trees
IF( NDEPTH.GT.M ) THEN
INFO = -2
RETURN
ENDIF
* breadth first processing of the current level of the representation
* tree: OLDNCL = number of clusters on current level
OLDNCL = NCLUS
* reset NCLUS to count the number of child clusters
NCLUS = 0
*
PARITY = 1 - PARITY
IF( PARITY.EQ.0 ) THEN
OLDCLS = IINDC1
NEWCLS = IINDC2
ELSE
OLDCLS = IINDC2
NEWCLS = IINDC1
END IF
* Process the clusters on the current level
DO 150 I = 1, OLDNCL
J = OLDCLS + 2*I
* OLDFST, OLDLST = first, last index of current cluster.
* cluster indices start with 1 and are relative
* to WBEGIN when accessing W, WGAP, WERR, Z
OLDFST = IWORK( J-1 )
OLDLST = IWORK( J )
IF( NDEPTH.GT.0 ) THEN
* Retrieve relatively robust representation (RRR) of cluster
* that has been computed at the previous level
* The RRR is stored in Z and overwritten once the eigenvectors
* have been computed or when the cluster is refined
IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN
* Get representation from location of the leftmost evalue
* of the cluster
J = WBEGIN + OLDFST - 1
ELSE
IF(WBEGIN+OLDFST-1.LT.DOL) THEN
* Get representation from the left end of Z array
J = DOL - 1
ELSEIF(WBEGIN+OLDFST-1.GT.DOU) THEN
* Get representation from the right end of Z array
J = DOU
ELSE
J = WBEGIN + OLDFST - 1
ENDIF
ENDIF
CALL SCOPY( IN, Z( IBEGIN, J ), 1, D( IBEGIN ), 1 )
CALL SCOPY( IN-1, Z( IBEGIN, J+1 ), 1, L( IBEGIN ),
$ 1 )
SIGMA = Z( IEND, J+1 )
* Set the corresponding entries in Z to zero
CALL SLASET( 'Full', IN, 2, ZERO, ZERO,
$ Z( IBEGIN, J), LDZ )
END IF
* Compute DL and DLL of current RRR
DO 50 J = IBEGIN, IEND-1
TMP = D( J )*L( J )
WORK( INDLD-1+J ) = TMP
WORK( INDLLD-1+J ) = TMP*L( J )
50 CONTINUE
IF( NDEPTH.GT.0 ) THEN
* P and Q are index of the first and last eigenvalue to compute
* within the current block
P = INDEXW( WBEGIN-1+OLDFST )
Q = INDEXW( WBEGIN-1+OLDLST )
* Offset for the arrays WORK, WGAP and WERR, i.e., th P-OFFSET
* thru' Q-OFFSET elements of these arrays are to be used.
C OFFSET = P-OLDFST
OFFSET = INDEXW( WBEGIN ) - 1
* perform limited bisection (if necessary) to get approximate
* eigenvalues to the precision needed.
CALL SLARRB( IN, D( IBEGIN ),
$ WORK(INDLLD+IBEGIN-1),
$ P, Q, RTOL1, RTOL2, OFFSET,
$ WORK(WBEGIN),WGAP(WBEGIN),WERR(WBEGIN),
$ WORK( INDWRK ), IWORK( IINDWK ),
$ PIVMIN, SPDIAM, IN, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = -1
RETURN
ENDIF
* We also recompute the extremal gaps. W holds all eigenvalues
* of the unshifted matrix and must be used for computation
* of WGAP, the entries of WORK might stem from RRRs with
* different shifts. The gaps from WBEGIN-1+OLDFST to
* WBEGIN-1+OLDLST are correctly computed in SLARRB.
* However, we only allow the gaps to become greater since
* this is what should happen when we decrease WERR
IF( OLDFST.GT.1) THEN
WGAP( WBEGIN+OLDFST-2 ) =
$ MAX(WGAP(WBEGIN+OLDFST-2),
$ W(WBEGIN+OLDFST-1)-WERR(WBEGIN+OLDFST-1)
$ - W(WBEGIN+OLDFST-2)-WERR(WBEGIN+OLDFST-2) )
ENDIF
IF( WBEGIN + OLDLST -1 .LT. WEND ) THEN
WGAP( WBEGIN+OLDLST-1 ) =
$ MAX(WGAP(WBEGIN+OLDLST-1),
$ W(WBEGIN+OLDLST)-WERR(WBEGIN+OLDLST)
$ - W(WBEGIN+OLDLST-1)-WERR(WBEGIN+OLDLST-1) )
ENDIF
* Each time the eigenvalues in WORK get refined, we store
* the newly found approximation with all shifts applied in W
DO 53 J=OLDFST,OLDLST
W(WBEGIN+J-1) = WORK(WBEGIN+J-1)+SIGMA
53 CONTINUE
END IF
* Process the current node.
NEWFST = OLDFST
DO 140 J = OLDFST, OLDLST
IF( J.EQ.OLDLST ) THEN
* we are at the right end of the cluster, this is also the
* boundary of the child cluster
NEWLST = J
ELSE IF ( WGAP( WBEGIN + J -1).GE.
$ MINRGP* ABS( WORK(WBEGIN + J -1) ) ) THEN
* the right relative gap is big enough, the child cluster
* (NEWFST,..,NEWLST) is well separated from the following
NEWLST = J
ELSE
* inside a child cluster, the relative gap is not
* big enough.
GOTO 140
END IF
* Compute size of child cluster found
NEWSIZ = NEWLST - NEWFST + 1
* NEWFTT is the place in Z where the new RRR or the computed
* eigenvector is to be stored
IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN
* Store representation at location of the leftmost evalue
* of the cluster
NEWFTT = WBEGIN + NEWFST - 1
ELSE
IF(WBEGIN+NEWFST-1.LT.DOL) THEN
* Store representation at the left end of Z array
NEWFTT = DOL - 1
ELSEIF(WBEGIN+NEWFST-1.GT.DOU) THEN
* Store representation at the right end of Z array
NEWFTT = DOU
ELSE
NEWFTT = WBEGIN + NEWFST - 1
ENDIF
ENDIF
IF( NEWSIZ.GT.1) THEN
*
* Current child is not a singleton but a cluster.
* Compute and store new representation of child.
*
*
* Compute left and right cluster gap.
*
* LGAP and RGAP are not computed from WORK because
* the eigenvalue approximations may stem from RRRs
* different shifts. However, W hold all eigenvalues
* of the unshifted matrix. Still, the entries in WGAP
* have to be computed from WORK since the entries
* in W might be of the same order so that gaps are not
* exhibited correctly for very close eigenvalues.
IF( NEWFST.EQ.1 ) THEN
LGAP = MAX( ZERO,
$ W(WBEGIN)-WERR(WBEGIN) - VL )
ELSE
LGAP = WGAP( WBEGIN+NEWFST-2 )
ENDIF
RGAP = WGAP( WBEGIN+NEWLST-1 )
*
* Compute left- and rightmost eigenvalue of child
* to high precision in order to shift as close
* as possible and obtain as large relative gaps
* as possible
*
DO 55 K =1,2
IF(K.EQ.1) THEN
P = INDEXW( WBEGIN-1+NEWFST )
ELSE
P = INDEXW( WBEGIN-1+NEWLST )
ENDIF
OFFSET = INDEXW( WBEGIN ) - 1
CALL SLARRB( IN, D(IBEGIN),
$ WORK( INDLLD+IBEGIN-1 ),P,P,
$ RQTOL, RQTOL, OFFSET,
$ WORK(WBEGIN),WGAP(WBEGIN),
$ WERR(WBEGIN),WORK( INDWRK ),
$ IWORK( IINDWK ), PIVMIN, SPDIAM,
$ IN, IINFO )
55 CONTINUE
*
IF((WBEGIN+NEWLST-1.LT.DOL).OR.
$ (WBEGIN+NEWFST-1.GT.DOU)) THEN
* if the cluster contains no desired eigenvalues
* skip the computation of that branch of the rep. tree
*
* We could skip before the refinement of the extremal
* eigenvalues of the child, but then the representation
* tree could be different from the one when nothing is
* skipped. For this reason we skip at this place.
IDONE = IDONE + NEWLST - NEWFST + 1
GOTO 139
ENDIF
*
* Compute RRR of child cluster.
* Note that the new RRR is stored in Z
*
C SLARRF needs LWORK = 2*N
CALL SLARRF( IN, D( IBEGIN ), L( IBEGIN ),
$ WORK(INDLD+IBEGIN-1),
$ NEWFST, NEWLST, WORK(WBEGIN),
$ WGAP(WBEGIN), WERR(WBEGIN),
$ SPDIAM, LGAP, RGAP, PIVMIN, TAU,
$ Z(IBEGIN, NEWFTT),Z(IBEGIN, NEWFTT+1),
$ WORK( INDWRK ), IINFO )
IF( IINFO.EQ.0 ) THEN
* a new RRR for the cluster was found by SLARRF
* update shift and store it
SSIGMA = SIGMA + TAU
Z( IEND, NEWFTT+1 ) = SSIGMA
* WORK() are the midpoints and WERR() the semi-width
* Note that the entries in W are unchanged.
DO 116 K = NEWFST, NEWLST
FUDGE =
$ THREE*EPS*ABS(WORK(WBEGIN+K-1))
WORK( WBEGIN + K - 1 ) =
$ WORK( WBEGIN + K - 1) - TAU
FUDGE = FUDGE +
$ FOUR*EPS*ABS(WORK(WBEGIN+K-1))
* Fudge errors
WERR( WBEGIN + K - 1 ) =
$ WERR( WBEGIN + K - 1 ) + FUDGE
* Gaps are not fudged. Provided that WERR is small
* when eigenvalues are close, a zero gap indicates
* that a new representation is needed for resolving
* the cluster. A fudge could lead to a wrong decision
* of judging eigenvalues 'separated' which in
* reality are not. This could have a negative impact
* on the orthogonality of the computed eigenvectors.
116 CONTINUE
NCLUS = NCLUS + 1
K = NEWCLS + 2*NCLUS
IWORK( K-1 ) = NEWFST
IWORK( K ) = NEWLST
ELSE
INFO = -2
RETURN
ENDIF
ELSE
*
* Compute eigenvector of singleton
*
ITER = 0
*
TOL = FOUR * LOG(REAL(IN)) * EPS
*
K = NEWFST
WINDEX = WBEGIN + K - 1
WINDMN = MAX(WINDEX - 1,1)
WINDPL = MIN(WINDEX + 1,M)
LAMBDA = WORK( WINDEX )
DONE = DONE + 1
* Check if eigenvector computation is to be skipped
IF((WINDEX.LT.DOL).OR.
$ (WINDEX.GT.DOU)) THEN
ESKIP = .TRUE.
GOTO 125
ELSE
ESKIP = .FALSE.
ENDIF
LEFT = WORK( WINDEX ) - WERR( WINDEX )
RIGHT = WORK( WINDEX ) + WERR( WINDEX )
INDEIG = INDEXW( WINDEX )
* Note that since we compute the eigenpairs for a child,
* all eigenvalue approximations are w.r.t the same shift.
* In this case, the entries in WORK should be used for
* computing the gaps since they exhibit even very small
* differences in the eigenvalues, as opposed to the
* entries in W which might "look" the same.
IF( K .EQ. 1) THEN
* In the case RANGE='I' and with not much initial
* accuracy in LAMBDA and VL, the formula
* LGAP = MAX( ZERO, (SIGMA - VL) + LAMBDA )
* can lead to an overestimation of the left gap and
* thus to inadequately early RQI 'convergence'.
* Prevent this by forcing a small left gap.
LGAP = EPS*MAX(ABS(LEFT),ABS(RIGHT))
ELSE
LGAP = WGAP(WINDMN)
ENDIF
IF( K .EQ. IM) THEN
* In the case RANGE='I' and with not much initial
* accuracy in LAMBDA and VU, the formula
* can lead to an overestimation of the right gap and
* thus to inadequately early RQI 'convergence'.
* Prevent this by forcing a small right gap.
RGAP = EPS*MAX(ABS(LEFT),ABS(RIGHT))
ELSE
RGAP = WGAP(WINDEX)
ENDIF
GAP = MIN( LGAP, RGAP )
IF(( K .EQ. 1).OR.(K .EQ. IM)) THEN
* The eigenvector support can become wrong
* because significant entries could be cut off due to a
* large GAPTOL parameter in LAR1V. Prevent this.
GAPTOL = ZERO
ELSE
GAPTOL = GAP * EPS
ENDIF
ISUPMN = IN
ISUPMX = 1
* Update WGAP so that it holds the minimum gap
* to the left or the right. This is crucial in the
* case where bisection is used to ensure that the
* eigenvalue is refined up to the required precision.
* The correct value is restored afterwards.
SAVGAP = WGAP(WINDEX)
WGAP(WINDEX) = GAP
* We want to use the Rayleigh Quotient Correction
* as often as possible since it converges quadratically
* when we are close enough to the desired eigenvalue.
* However, the Rayleigh Quotient can have the wrong sign
* and lead us away from the desired eigenvalue. In this
* case, the best we can do is to use bisection.
USEDBS = .FALSE.
USEDRQ = .FALSE.
* Bisection is initially turned off unless it is forced
NEEDBS = .NOT.TRYRQC
120 CONTINUE
* Check if bisection should be used to refine eigenvalue
IF(NEEDBS) THEN
* Take the bisection as new iterate
USEDBS = .TRUE.
ITMP1 = IWORK( IINDR+WINDEX )
OFFSET = INDEXW( WBEGIN ) - 1
CALL SLARRB( IN, D(IBEGIN),
$ WORK(INDLLD+IBEGIN-1),INDEIG,INDEIG,
$ ZERO, TWO*EPS, OFFSET,
$ WORK(WBEGIN),WGAP(WBEGIN),
$ WERR(WBEGIN),WORK( INDWRK ),
$ IWORK( IINDWK ), PIVMIN, SPDIAM,
$ ITMP1, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = -3
RETURN
ENDIF
LAMBDA = WORK( WINDEX )
* Reset twist index from inaccurate LAMBDA to
* force computation of true MINGMA
IWORK( IINDR+WINDEX ) = 0
ENDIF
* Given LAMBDA, compute the eigenvector.
CALL SLAR1V( IN, 1, IN, LAMBDA, D( IBEGIN ),
$ L( IBEGIN ), WORK(INDLD+IBEGIN-1),
$ WORK(INDLLD+IBEGIN-1),
$ PIVMIN, GAPTOL, Z( IBEGIN, WINDEX ),
$ .NOT.USEDBS, NEGCNT, ZTZ, MINGMA,
$ IWORK( IINDR+WINDEX ), ISUPPZ( 2*WINDEX-1 ),
$ NRMINV, RESID, RQCORR, WORK( INDWRK ) )
IF(ITER .EQ. 0) THEN
BSTRES = RESID
BSTW = LAMBDA
ELSEIF(RESID.LT.BSTRES) THEN
BSTRES = RESID
BSTW = LAMBDA
ENDIF
ISUPMN = MIN(ISUPMN,ISUPPZ( 2*WINDEX-1 ))
ISUPMX = MAX(ISUPMX,ISUPPZ( 2*WINDEX ))
ITER = ITER + 1
* sin alpha <= |resid|/gap
* Note that both the residual and the gap are
* proportional to the matrix, so ||T|| doesn't play
* a role in the quotient
*
* Convergence test for Rayleigh-Quotient iteration
* (omitted when Bisection has been used)
*
IF( RESID.GT.TOL*GAP .AND. ABS( RQCORR ).GT.
$ RQTOL*ABS( LAMBDA ) .AND. .NOT. USEDBS)
$ THEN
* We need to check that the RQCORR update doesn't
* move the eigenvalue away from the desired one and
* towards a neighbor. -> protection with bisection
IF(INDEIG.LE.NEGCNT) THEN
* The wanted eigenvalue lies to the left
SGNDEF = -ONE
ELSE
* The wanted eigenvalue lies to the right
SGNDEF = ONE
ENDIF
* We only use the RQCORR if it improves the
* the iterate reasonably.
IF( ( RQCORR*SGNDEF.GE.ZERO )
$ .AND.( LAMBDA + RQCORR.LE. RIGHT)
$ .AND.( LAMBDA + RQCORR.GE. LEFT)
$ ) THEN
USEDRQ = .TRUE.
* Store new midpoint of bisection interval in WORK
IF(SGNDEF.EQ.ONE) THEN
* The current LAMBDA is on the left of the true
* eigenvalue
LEFT = LAMBDA
* We prefer to assume that the error estimate
* is correct. We could make the interval not
* as a bracket but to be modified if the RQCORR
* chooses to. In this case, the RIGHT side should
* be modified as follows:
* RIGHT = MAX(RIGHT, LAMBDA + RQCORR)
ELSE
* The current LAMBDA is on the right of the true
* eigenvalue
RIGHT = LAMBDA
* See comment about assuming the error estimate is
* correct above.
* LEFT = MIN(LEFT, LAMBDA + RQCORR)
ENDIF
WORK( WINDEX ) =
$ HALF * (RIGHT + LEFT)
* Take RQCORR since it has the correct sign and
* improves the iterate reasonably
LAMBDA = LAMBDA + RQCORR
* Update width of error interval
WERR( WINDEX ) =
$ HALF * (RIGHT-LEFT)
ELSE
NEEDBS = .TRUE.
ENDIF
IF(RIGHT-LEFT.LT.RQTOL*ABS(LAMBDA)) THEN
* The eigenvalue is computed to bisection accuracy
* compute eigenvector and stop
USEDBS = .TRUE.
GOTO 120
ELSEIF( ITER.LT.MAXITR ) THEN
GOTO 120
ELSEIF( ITER.EQ.MAXITR ) THEN
NEEDBS = .TRUE.
GOTO 120
ELSE
INFO = 5
RETURN
END IF
ELSE
STP2II = .FALSE.
IF(USEDRQ .AND. USEDBS .AND.
$ BSTRES.LE.RESID) THEN
LAMBDA = BSTW
STP2II = .TRUE.
ENDIF
IF (STP2II) THEN
* improve error angle by second step
CALL SLAR1V( IN, 1, IN, LAMBDA,
$ D( IBEGIN ), L( IBEGIN ),
$ WORK(INDLD+IBEGIN-1),
$ WORK(INDLLD+IBEGIN-1),
$ PIVMIN, GAPTOL, Z( IBEGIN, WINDEX ),
$ .NOT.USEDBS, NEGCNT, ZTZ, MINGMA,
$ IWORK( IINDR+WINDEX ),
$ ISUPPZ( 2*WINDEX-1 ),
$ NRMINV, RESID, RQCORR, WORK( INDWRK ) )
ENDIF
WORK( WINDEX ) = LAMBDA
END IF
*
* Compute FP-vector support w.r.t. whole matrix
*
ISUPPZ( 2*WINDEX-1 ) = ISUPPZ( 2*WINDEX-1 )+OLDIEN
ISUPPZ( 2*WINDEX ) = ISUPPZ( 2*WINDEX )+OLDIEN
ZFROM = ISUPPZ( 2*WINDEX-1 )
ZTO = ISUPPZ( 2*WINDEX )
ISUPMN = ISUPMN + OLDIEN
ISUPMX = ISUPMX + OLDIEN
* Ensure vector is ok if support in the RQI has changed
IF(ISUPMN.LT.ZFROM) THEN
DO 122 II = ISUPMN,ZFROM-1
Z( II, WINDEX ) = ZERO
122 CONTINUE
ENDIF
IF(ISUPMX.GT.ZTO) THEN
DO 123 II = ZTO+1,ISUPMX
Z( II, WINDEX ) = ZERO
123 CONTINUE
ENDIF
CALL SSCAL( ZTO-ZFROM+1, NRMINV,
$ Z( ZFROM, WINDEX ), 1 )
125 CONTINUE
* Update W
W( WINDEX ) = LAMBDA+SIGMA
* Recompute the gaps on the left and right
* But only allow them to become larger and not
* smaller (which can only happen through "bad"
* cancellation and doesn't reflect the theory
* where the initial gaps are underestimated due
* to WERR being too crude.)
IF(.NOT.ESKIP) THEN
IF( K.GT.1) THEN
WGAP( WINDMN ) = MAX( WGAP(WINDMN),
$ W(WINDEX)-WERR(WINDEX)
$ - W(WINDMN)-WERR(WINDMN) )
ENDIF
IF( WINDEX.LT.WEND ) THEN
WGAP( WINDEX ) = MAX( SAVGAP,
$ W( WINDPL )-WERR( WINDPL )
$ - W( WINDEX )-WERR( WINDEX) )
ENDIF
ENDIF
IDONE = IDONE + 1
ENDIF
* here ends the code for the current child
*
139 CONTINUE
* Proceed to any remaining child nodes
NEWFST = J + 1
140 CONTINUE
150 CONTINUE
NDEPTH = NDEPTH + 1
GO TO 40
END IF
IBEGIN = IEND + 1
WBEGIN = WEND + 1
170 CONTINUE
*
RETURN
*
* End of SLARRV
*
END
SUBROUTINE SLARTG( F, G, CS, SN, R )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
REAL CS, F, G, R, SN
* ..
*
* Purpose
* =======
*
* SLARTG generate a plane rotation so that
*
* [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1.
* [ -SN CS ] [ G ] [ 0 ]
*
* This is a slower, more accurate version of the BLAS1 routine SROTG,
* with the following other differences:
* F and G are unchanged on return.
* If G=0, then CS=1 and SN=0.
* If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any
* floating point operations (saves work in SBDSQR when
* there are zeros on the diagonal).
*
* If F exceeds G in magnitude, CS will be positive.
*
* Arguments
* =========
*
* F (input) REAL
* The first component of vector to be rotated.
*
* G (input) REAL
* The second component of vector to be rotated.
*
* CS (output) REAL
* The cosine of the rotation.
*
* SN (output) REAL
* The sine of the rotation.
*
* R (output) REAL
* The nonzero component of the rotated vector.
*
* This version has a few statements commented out for thread safety
* (machine parameters are computed on each entry). 10 feb 03, SJH.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
REAL ONE
PARAMETER ( ONE = 1.0E0 )
REAL TWO
PARAMETER ( TWO = 2.0E0 )
* ..
* .. Local Scalars ..
* LOGICAL FIRST
INTEGER COUNT, I
REAL EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX, SQRT
* ..
* .. Save statement ..
* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2
* ..
* .. Data statements ..
* DATA FIRST / .TRUE. /
* ..
* .. Executable Statements ..
*
* IF( FIRST ) THEN
SAFMIN = SLAMCH( 'S' )
EPS = SLAMCH( 'E' )
SAFMN2 = SLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
$ LOG( SLAMCH( 'B' ) ) / TWO )
SAFMX2 = ONE / SAFMN2
* FIRST = .FALSE.
* END IF
IF( G.EQ.ZERO ) THEN
CS = ONE
SN = ZERO
R = F
ELSE IF( F.EQ.ZERO ) THEN
CS = ZERO
SN = ONE
R = G
ELSE
F1 = F
G1 = G
SCALE = MAX( ABS( F1 ), ABS( G1 ) )
IF( SCALE.GE.SAFMX2 ) THEN
COUNT = 0
10 CONTINUE
COUNT = COUNT + 1
F1 = F1*SAFMN2
G1 = G1*SAFMN2
SCALE = MAX( ABS( F1 ), ABS( G1 ) )
IF( SCALE.GE.SAFMX2 )
$ GO TO 10
R = SQRT( F1**2+G1**2 )
CS = F1 / R
SN = G1 / R
DO 20 I = 1, COUNT
R = R*SAFMX2
20 CONTINUE
ELSE IF( SCALE.LE.SAFMN2 ) THEN
COUNT = 0
30 CONTINUE
COUNT = COUNT + 1
F1 = F1*SAFMX2
G1 = G1*SAFMX2
SCALE = MAX( ABS( F1 ), ABS( G1 ) )
IF( SCALE.LE.SAFMN2 )
$ GO TO 30
R = SQRT( F1**2+G1**2 )
CS = F1 / R
SN = G1 / R
DO 40 I = 1, COUNT
R = R*SAFMN2
40 CONTINUE
ELSE
R = SQRT( F1**2+G1**2 )
CS = F1 / R
SN = G1 / R
END IF
IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN
CS = -CS
SN = -SN
R = -R
END IF
END IF
RETURN
*
* End of SLARTG
*
END
SUBROUTINE SLARTV( N, X, INCX, Y, INCY, C, S, INCC )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INCC, INCX, INCY, N
* ..
* .. Array Arguments ..
REAL C( * ), S( * ), X( * ), Y( * )
* ..
*
* Purpose
* =======
*
* SLARTV applies a vector of real plane rotations to elements of the
* real vectors x and y. For i = 1,2,...,n
*
* ( x(i) ) := ( c(i) s(i) ) ( x(i) )
* ( y(i) ) ( -s(i) c(i) ) ( y(i) )
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of plane rotations to be applied.
*
* X (input/output) REAL array,
* dimension (1+(N-1)*INCX)
* The vector x.
*
* INCX (input) INTEGER
* The increment between elements of X. INCX > 0.
*
* Y (input/output) REAL array,
* dimension (1+(N-1)*INCY)
* The vector y.
*
* INCY (input) INTEGER
* The increment between elements of Y. INCY > 0.
*
* C (input) REAL array, dimension (1+(N-1)*INCC)
* The cosines of the plane rotations.
*
* S (input) REAL array, dimension (1+(N-1)*INCC)
* The sines of the plane rotations.
*
* INCC (input) INTEGER
* The increment between elements of C and S. INCC > 0.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, IC, IX, IY
REAL XI, YI
* ..
* .. Executable Statements ..
*
IX = 1
IY = 1
IC = 1
DO 10 I = 1, N
XI = X( IX )
YI = Y( IY )
X( IX ) = C( IC )*XI + S( IC )*YI
Y( IY ) = C( IC )*YI - S( IC )*XI
IX = IX + INCX
IY = IY + INCY
IC = IC + INCC
10 CONTINUE
RETURN
*
* End of SLARTV
*
END
SUBROUTINE SLARUV( ISEED, N, X )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER N
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
REAL X( N )
* ..
*
* Purpose
* =======
*
* SLARUV returns a vector of n random real numbers from a uniform (0,1)
* distribution (n <= 128).
*
* This is an auxiliary routine called by SLARNV and CLARNV.
*
* Arguments
* =========
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry, the seed of the random number generator; the array
* elements must be between 0 and 4095, and ISEED(4) must be
* odd.
* On exit, the seed is updated.
*
* N (input) INTEGER
* The number of random numbers to be generated. N <= 128.
*
* X (output) REAL array, dimension (N)
* The generated random numbers.
*
* Further Details
* ===============
*
* This routine uses a multiplicative congruential method with modulus
* 2**48 and multiplier 33952834046453 (see G.S.Fishman,
* 'Multiplicative congruential random number generators with modulus
* 2**b: an exhaustive analysis for b = 32 and a partial analysis for
* b = 48', Math. Comp. 189, pp 331-344, 1990).
*
* 48-bit integers are stored in 4 integer array elements with 12 bits
* per element. Hence the routine is portable across machines with
* integers of 32 bits or more.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E0 )
INTEGER LV, IPW2
REAL R
PARAMETER ( LV = 128, IPW2 = 4096, R = ONE / IPW2 )
* ..
* .. Local Scalars ..
INTEGER I, I1, I2, I3, I4, IT1, IT2, IT3, IT4, J
* ..
* .. Local Arrays ..
INTEGER MM( LV, 4 )
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN, MOD, REAL
* ..
* .. Data statements ..
DATA ( MM( 1, J ), J = 1, 4 ) / 494, 322, 2508,
$ 2549 /
DATA ( MM( 2, J ), J = 1, 4 ) / 2637, 789, 3754,
$ 1145 /
DATA ( MM( 3, J ), J = 1, 4 ) / 255, 1440, 1766,
$ 2253 /
DATA ( MM( 4, J ), J = 1, 4 ) / 2008, 752, 3572,
$ 305 /
DATA ( MM( 5, J ), J = 1, 4 ) / 1253, 2859, 2893,
$ 3301 /
DATA ( MM( 6, J ), J = 1, 4 ) / 3344, 123, 307,
$ 1065 /
DATA ( MM( 7, J ), J = 1, 4 ) / 4084, 1848, 1297,
$ 3133 /
DATA ( MM( 8, J ), J = 1, 4 ) / 1739, 643, 3966,
$ 2913 /
DATA ( MM( 9, J ), J = 1, 4 ) / 3143, 2405, 758,
$ 3285 /
DATA ( MM( 10, J ), J = 1, 4 ) / 3468, 2638, 2598,
$ 1241 /
DATA ( MM( 11, J ), J = 1, 4 ) / 688, 2344, 3406,
$ 1197 /
DATA ( MM( 12, J ), J = 1, 4 ) / 1657, 46, 2922,
$ 3729 /
DATA ( MM( 13, J ), J = 1, 4 ) / 1238, 3814, 1038,
$ 2501 /
DATA ( MM( 14, J ), J = 1, 4 ) / 3166, 913, 2934,
$ 1673 /
DATA ( MM( 15, J ), J = 1, 4 ) / 1292, 3649, 2091,
$ 541 /
DATA ( MM( 16, J ), J = 1, 4 ) / 3422, 339, 2451,
$ 2753 /
DATA ( MM( 17, J ), J = 1, 4 ) / 1270, 3808, 1580,
$ 949 /
DATA ( MM( 18, J ), J = 1, 4 ) / 2016, 822, 1958,
$ 2361 /
DATA ( MM( 19, J ), J = 1, 4 ) / 154, 2832, 2055,
$ 1165 /
DATA ( MM( 20, J ), J = 1, 4 ) / 2862, 3078, 1507,
$ 4081 /
DATA ( MM( 21, J ), J = 1, 4 ) / 697, 3633, 1078,
$ 2725 /
DATA ( MM( 22, J ), J = 1, 4 ) / 1706, 2970, 3273,
$ 3305 /
DATA ( MM( 23, J ), J = 1, 4 ) / 491, 637, 17,
$ 3069 /
DATA ( MM( 24, J ), J = 1, 4 ) / 931, 2249, 854,
$ 3617 /
DATA ( MM( 25, J ), J = 1, 4 ) / 1444, 2081, 2916,
$ 3733 /
DATA ( MM( 26, J ), J = 1, 4 ) / 444, 4019, 3971,
$ 409 /
DATA ( MM( 27, J ), J = 1, 4 ) / 3577, 1478, 2889,
$ 2157 /
DATA ( MM( 28, J ), J = 1, 4 ) / 3944, 242, 3831,
$ 1361 /
DATA ( MM( 29, J ), J = 1, 4 ) / 2184, 481, 2621,
$ 3973 /
DATA ( MM( 30, J ), J = 1, 4 ) / 1661, 2075, 1541,
$ 1865 /
DATA ( MM( 31, J ), J = 1, 4 ) / 3482, 4058, 893,
$ 2525 /
DATA ( MM( 32, J ), J = 1, 4 ) / 657, 622, 736,
$ 1409 /
DATA ( MM( 33, J ), J = 1, 4 ) / 3023, 3376, 3992,
$ 3445 /
DATA ( MM( 34, J ), J = 1, 4 ) / 3618, 812, 787,
$ 3577 /
DATA ( MM( 35, J ), J = 1, 4 ) / 1267, 234, 2125,
$ 77 /
DATA ( MM( 36, J ), J = 1, 4 ) / 1828, 641, 2364,
$ 3761 /
DATA ( MM( 37, J ), J = 1, 4 ) / 164, 4005, 2460,
$ 2149 /
DATA ( MM( 38, J ), J = 1, 4 ) / 3798, 1122, 257,
$ 1449 /
DATA ( MM( 39, J ), J = 1, 4 ) / 3087, 3135, 1574,
$ 3005 /
DATA ( MM( 40, J ), J = 1, 4 ) / 2400, 2640, 3912,
$ 225 /
DATA ( MM( 41, J ), J = 1, 4 ) / 2870, 2302, 1216,
$ 85 /
DATA ( MM( 42, J ), J = 1, 4 ) / 3876, 40, 3248,
$ 3673 /
DATA ( MM( 43, J ), J = 1, 4 ) / 1905, 1832, 3401,
$ 3117 /
DATA ( MM( 44, J ), J = 1, 4 ) / 1593, 2247, 2124,
$ 3089 /
DATA ( MM( 45, J ), J = 1, 4 ) / 1797, 2034, 2762,
$ 1349 /
DATA ( MM( 46, J ), J = 1, 4 ) / 1234, 2637, 149,
$ 2057 /
DATA ( MM( 47, J ), J = 1, 4 ) / 3460, 1287, 2245,
$ 413 /
DATA ( MM( 48, J ), J = 1, 4 ) / 328, 1691, 166,
$ 65 /
DATA ( MM( 49, J ), J = 1, 4 ) / 2861, 496, 466,
$ 1845 /
DATA ( MM( 50, J ), J = 1, 4 ) / 1950, 1597, 4018,
$ 697 /
DATA ( MM( 51, J ), J = 1, 4 ) / 617, 2394, 1399,
$ 3085 /
DATA ( MM( 52, J ), J = 1, 4 ) / 2070, 2584, 190,
$ 3441 /
DATA ( MM( 53, J ), J = 1, 4 ) / 3331, 1843, 2879,
$ 1573 /
DATA ( MM( 54, J ), J = 1, 4 ) / 769, 336, 153,
$ 3689 /
DATA ( MM( 55, J ), J = 1, 4 ) / 1558, 1472, 2320,
$ 2941 /
DATA ( MM( 56, J ), J = 1, 4 ) / 2412, 2407, 18,
$ 929 /
DATA ( MM( 57, J ), J = 1, 4 ) / 2800, 433, 712,
$ 533 /
DATA ( MM( 58, J ), J = 1, 4 ) / 189, 2096, 2159,
$ 2841 /
DATA ( MM( 59, J ), J = 1, 4 ) / 287, 1761, 2318,
$ 4077 /
DATA ( MM( 60, J ), J = 1, 4 ) / 2045, 2810, 2091,
$ 721 /
DATA ( MM( 61, J ), J = 1, 4 ) / 1227, 566, 3443,
$ 2821 /
DATA ( MM( 62, J ), J = 1, 4 ) / 2838, 442, 1510,
$ 2249 /
DATA ( MM( 63, J ), J = 1, 4 ) / 209, 41, 449,
$ 2397 /
DATA ( MM( 64, J ), J = 1, 4 ) / 2770, 1238, 1956,
$ 2817 /
DATA ( MM( 65, J ), J = 1, 4 ) / 3654, 1086, 2201,
$ 245 /
DATA ( MM( 66, J ), J = 1, 4 ) / 3993, 603, 3137,
$ 1913 /
DATA ( MM( 67, J ), J = 1, 4 ) / 192, 840, 3399,
$ 1997 /
DATA ( MM( 68, J ), J = 1, 4 ) / 2253, 3168, 1321,
$ 3121 /
DATA ( MM( 69, J ), J = 1, 4 ) / 3491, 1499, 2271,
$ 997 /
DATA ( MM( 70, J ), J = 1, 4 ) / 2889, 1084, 3667,
$ 1833 /
DATA ( MM( 71, J ), J = 1, 4 ) / 2857, 3438, 2703,
$ 2877 /
DATA ( MM( 72, J ), J = 1, 4 ) / 2094, 2408, 629,
$ 1633 /
DATA ( MM( 73, J ), J = 1, 4 ) / 1818, 1589, 2365,
$ 981 /
DATA ( MM( 74, J ), J = 1, 4 ) / 688, 2391, 2431,
$ 2009 /
DATA ( MM( 75, J ), J = 1, 4 ) / 1407, 288, 1113,
$ 941 /
DATA ( MM( 76, J ), J = 1, 4 ) / 634, 26, 3922,
$ 2449 /
DATA ( MM( 77, J ), J = 1, 4 ) / 3231, 512, 2554,
$ 197 /
DATA ( MM( 78, J ), J = 1, 4 ) / 815, 1456, 184,
$ 2441 /
DATA ( MM( 79, J ), J = 1, 4 ) / 3524, 171, 2099,
$ 285 /
DATA ( MM( 80, J ), J = 1, 4 ) / 1914, 1677, 3228,
$ 1473 /
DATA ( MM( 81, J ), J = 1, 4 ) / 516, 2657, 4012,
$ 2741 /
DATA ( MM( 82, J ), J = 1, 4 ) / 164, 2270, 1921,
$ 3129 /
DATA ( MM( 83, J ), J = 1, 4 ) / 303, 2587, 3452,
$ 909 /
DATA ( MM( 84, J ), J = 1, 4 ) / 2144, 2961, 3901,
$ 2801 /
DATA ( MM( 85, J ), J = 1, 4 ) / 3480, 1970, 572,
$ 421 /
DATA ( MM( 86, J ), J = 1, 4 ) / 119, 1817, 3309,
$ 4073 /
DATA ( MM( 87, J ), J = 1, 4 ) / 3357, 676, 3171,
$ 2813 /
DATA ( MM( 88, J ), J = 1, 4 ) / 837, 1410, 817,
$ 2337 /
DATA ( MM( 89, J ), J = 1, 4 ) / 2826, 3723, 3039,
$ 1429 /
DATA ( MM( 90, J ), J = 1, 4 ) / 2332, 2803, 1696,
$ 1177 /
DATA ( MM( 91, J ), J = 1, 4 ) / 2089, 3185, 1256,
$ 1901 /
DATA ( MM( 92, J ), J = 1, 4 ) / 3780, 184, 3715,
$ 81 /
DATA ( MM( 93, J ), J = 1, 4 ) / 1700, 663, 2077,
$ 1669 /
DATA ( MM( 94, J ), J = 1, 4 ) / 3712, 499, 3019,
$ 2633 /
DATA ( MM( 95, J ), J = 1, 4 ) / 150, 3784, 1497,
$ 2269 /
DATA ( MM( 96, J ), J = 1, 4 ) / 2000, 1631, 1101,
$ 129 /
DATA ( MM( 97, J ), J = 1, 4 ) / 3375, 1925, 717,
$ 1141 /
DATA ( MM( 98, J ), J = 1, 4 ) / 1621, 3912, 51,
$ 249 /
DATA ( MM( 99, J ), J = 1, 4 ) / 3090, 1398, 981,
$ 3917 /
DATA ( MM( 100, J ), J = 1, 4 ) / 3765, 1349, 1978,
$ 2481 /
DATA ( MM( 101, J ), J = 1, 4 ) / 1149, 1441, 1813,
$ 3941 /
DATA ( MM( 102, J ), J = 1, 4 ) / 3146, 2224, 3881,
$ 2217 /
DATA ( MM( 103, J ), J = 1, 4 ) / 33, 2411, 76,
$ 2749 /
DATA ( MM( 104, J ), J = 1, 4 ) / 3082, 1907, 3846,
$ 3041 /
DATA ( MM( 105, J ), J = 1, 4 ) / 2741, 3192, 3694,
$ 1877 /
DATA ( MM( 106, J ), J = 1, 4 ) / 359, 2786, 1682,
$ 345 /
DATA ( MM( 107, J ), J = 1, 4 ) / 3316, 382, 124,
$ 2861 /
DATA ( MM( 108, J ), J = 1, 4 ) / 1749, 37, 1660,
$ 1809 /
DATA ( MM( 109, J ), J = 1, 4 ) / 185, 759, 3997,
$ 3141 /
DATA ( MM( 110, J ), J = 1, 4 ) / 2784, 2948, 479,
$ 2825 /
DATA ( MM( 111, J ), J = 1, 4 ) / 2202, 1862, 1141,
$ 157 /
DATA ( MM( 112, J ), J = 1, 4 ) / 2199, 3802, 886,
$ 2881 /
DATA ( MM( 113, J ), J = 1, 4 ) / 1364, 2423, 3514,
$ 3637 /
DATA ( MM( 114, J ), J = 1, 4 ) / 1244, 2051, 1301,
$ 1465 /
DATA ( MM( 115, J ), J = 1, 4 ) / 2020, 2295, 3604,
$ 2829 /
DATA ( MM( 116, J ), J = 1, 4 ) / 3160, 1332, 1888,
$ 2161 /
DATA ( MM( 117, J ), J = 1, 4 ) / 2785, 1832, 1836,
$ 3365 /
DATA ( MM( 118, J ), J = 1, 4 ) / 2772, 2405, 1990,
$ 361 /
DATA ( MM( 119, J ), J = 1, 4 ) / 1217, 3638, 2058,
$ 2685 /
DATA ( MM( 120, J ), J = 1, 4 ) / 1822, 3661, 692,
$ 3745 /
DATA ( MM( 121, J ), J = 1, 4 ) / 1245, 327, 1194,
$ 2325 /
DATA ( MM( 122, J ), J = 1, 4 ) / 2252, 3660, 20,
$ 3609 /
DATA ( MM( 123, J ), J = 1, 4 ) / 3904, 716, 3285,
$ 3821 /
DATA ( MM( 124, J ), J = 1, 4 ) / 2774, 1842, 2046,
$ 3537 /
DATA ( MM( 125, J ), J = 1, 4 ) / 997, 3987, 2107,
$ 517 /
DATA ( MM( 126, J ), J = 1, 4 ) / 2573, 1368, 3508,
$ 3017 /
DATA ( MM( 127, J ), J = 1, 4 ) / 1148, 1848, 3525,
$ 2141 /
DATA ( MM( 128, J ), J = 1, 4 ) / 545, 2366, 3801,
$ 1537 /
* ..
* .. Executable Statements ..
*
I1 = ISEED( 1 )
I2 = ISEED( 2 )
I3 = ISEED( 3 )
I4 = ISEED( 4 )
*
DO 10 I = 1, MIN( N, LV )
*
20 CONTINUE
*
* Multiply the seed by i-th power of the multiplier modulo 2**48
*
IT4 = I4*MM( I, 4 )
IT3 = IT4 / IPW2
IT4 = IT4 - IPW2*IT3
IT3 = IT3 + I3*MM( I, 4 ) + I4*MM( I, 3 )
IT2 = IT3 / IPW2
IT3 = IT3 - IPW2*IT2
IT2 = IT2 + I2*MM( I, 4 ) + I3*MM( I, 3 ) + I4*MM( I, 2 )
IT1 = IT2 / IPW2
IT2 = IT2 - IPW2*IT1
IT1 = IT1 + I1*MM( I, 4 ) + I2*MM( I, 3 ) + I3*MM( I, 2 ) +
$ I4*MM( I, 1 )
IT1 = MOD( IT1, IPW2 )
*
* Convert 48-bit integer to a real number in the interval (0,1)
*
X( I ) = R*( REAL( IT1 )+R*( REAL( IT2 )+R*( REAL( IT3 )+R*
$ REAL( IT4 ) ) ) )
*
IF (X( I ).EQ.1.0) THEN
* If a real number has n bits of precision, and the first
* n bits of the 48-bit integer above happen to be all 1 (which
* will occur about once every 2**n calls), then X( I ) will
* be rounded to exactly 1.0. In IEEE single precision arithmetic,
* this will happen relatively often since n = 24.
* Since X( I ) is not supposed to return exactly 0.0 or 1.0,
* the statistically correct thing to do in this situation is
* simply to iterate again.
* N.B. the case X( I ) = 0.0 should not be possible.
I1 = I1 + 2
I2 = I2 + 2
I3 = I3 + 2
I4 = I4 + 2
GOTO 20
END IF
*
10 CONTINUE
*
* Return final value of seed
*
ISEED( 1 ) = IT1
ISEED( 2 ) = IT2
ISEED( 3 ) = IT3
ISEED( 4 ) = IT4
RETURN
*
* End of SLARUV
*
END
SUBROUTINE SLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE
INTEGER INCV, L, LDC, M, N
REAL TAU
* ..
* .. Array Arguments ..
REAL C( LDC, * ), V( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SLARZ 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'
*
* where tau is a real scalar and v is a real vector.
*
* If tau = 0, then H is taken to be the unit matrix.
*
*
* H is a product of k elementary reflectors as returned by STZRZF.
*
* 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.
*
* L (input) INTEGER
* The number of entries of the vector V containing
* the meaningful part of the Householder vectors.
* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
*
* V (input) REAL array, dimension (1+(L-1)*abs(INCV))
* The vector v in the representation of H as returned by
* STZRZF. V is not used if TAU = 0.
*
* INCV (input) INTEGER
* The increment between elements of v. INCV <> 0.
*
* TAU (input) REAL
* The value tau in the representation of H.
*
* C (input/output) REAL 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) REAL array, dimension
* (N) if SIDE = 'L'
* or (M) if SIDE = 'R'
*
* Further Details
* ===============
*
* Based on contributions by
* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, SGEMV, SGER
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Executable Statements ..
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form H * C
*
IF( TAU.NE.ZERO ) THEN
*
* w( 1:n ) = C( 1, 1:n )
*
CALL SCOPY( N, C, LDC, WORK, 1 )
*
* w( 1:n ) = w( 1:n ) + C( m-l+1:m, 1:n )' * v( 1:l )
*
CALL SGEMV( 'Transpose', L, N, ONE, C( M-L+1, 1 ), LDC, V,
$ INCV, ONE, WORK, 1 )
*
* C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n )
*
CALL SAXPY( N, -TAU, WORK, 1, C, LDC )
*
* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ...
* tau * v( 1:l ) * w( 1:n )'
*
CALL SGER( L, N, -TAU, V, INCV, WORK, 1, C( M-L+1, 1 ),
$ LDC )
END IF
*
ELSE
*
* Form C * H
*
IF( TAU.NE.ZERO ) THEN
*
* w( 1:m ) = C( 1:m, 1 )
*
CALL SCOPY( M, C, 1, WORK, 1 )
*
* w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l )
*
CALL SGEMV( 'No transpose', M, L, ONE, C( 1, N-L+1 ), LDC,
$ V, INCV, ONE, WORK, 1 )
*
* C( 1:m, 1 ) = C( 1:m, 1 ) - tau * w( 1:m )
*
CALL SAXPY( M, -TAU, WORK, 1, C, 1 )
*
* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ...
* tau * w( 1:m ) * v( 1:l )'
*
CALL SGER( M, L, -TAU, WORK, 1, V, INCV, C( 1, N-L+1 ),
$ LDC )
*
END IF
*
END IF
*
RETURN
*
* End of SLARZ
*
END
SUBROUTINE SLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V,
$ LDV, T, LDT, C, LDC, WORK, LDWORK )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIRECT, SIDE, STOREV, TRANS
INTEGER K, L, LDC, LDT, LDV, LDWORK, M, N
* ..
* .. Array Arguments ..
REAL C( LDC, * ), T( LDT, * ), V( LDV, * ),
$ WORK( LDWORK, * )
* ..
*
* Purpose
* =======
*
* SLARZB applies a real block reflector H or its transpose H**T to
* a real distributed M-by-N C from the left or the right.
*
* Currently, only STOREV = 'R' and DIRECT = 'B' are supported.
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* = 'L': apply H or H' from the Left
* = 'R': apply H or H' from the Right
*
* TRANS (input) CHARACTER*1
* = 'N': apply H (No transpose)
* = 'C': apply H' (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, not supported yet)
* = '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 (not supported yet)
* = '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).
*
* L (input) INTEGER
* The number of columns of the matrix V containing the
* meaningful part of the Householder reflectors.
* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
*
* V (input) REAL array, dimension (LDV,NV).
* If STOREV = 'C', NV = K; if STOREV = 'R', NV = L.
*
* LDV (input) INTEGER
* The leading dimension of the array V.
* If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K.
*
* T (input) REAL 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) REAL array, dimension (LDC,N)
* On entry, the M-by-N matrix C.
* On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
*
* LDC (input) INTEGER
* The leading dimension of the array C. LDC >= max(1,M).
*
* WORK (workspace) REAL 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
* ===============
*
* Based on contributions by
* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
CHARACTER TRANST
INTEGER I, INFO, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMM, STRMM, XERBLA
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
* Check for currently supported options
*
INFO = 0
IF( .NOT.LSAME( DIRECT, 'B' ) ) THEN
INFO = -3
ELSE IF( .NOT.LSAME( STOREV, 'R' ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLARZB', -INFO )
RETURN
END IF
*
IF( LSAME( TRANS, 'N' ) ) THEN
TRANST = 'T'
ELSE
TRANST = 'N'
END IF
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form H * C or H' * C
*
* W( 1:n, 1:k ) = C( 1:k, 1:n )'
*
DO 10 J = 1, K
CALL SCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
10 CONTINUE
*
* W( 1:n, 1:k ) = W( 1:n, 1:k ) + ...
* C( m-l+1:m, 1:n )' * V( 1:k, 1:l )'
*
IF( L.GT.0 )
$ CALL SGEMM( 'Transpose', 'Transpose', N, K, L, ONE,
$ C( M-L+1, 1 ), LDC, V, LDV, ONE, WORK, LDWORK )
*
* W( 1:n, 1:k ) = W( 1:n, 1:k ) * T' or W( 1:m, 1:k ) * T
*
CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, ONE, T,
$ LDT, WORK, LDWORK )
*
* C( 1:k, 1:n ) = C( 1:k, 1:n ) - W( 1:n, 1:k )'
*
DO 30 J = 1, N
DO 20 I = 1, K
C( I, J ) = C( I, J ) - WORK( J, I )
20 CONTINUE
30 CONTINUE
*
* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ...
* V( 1:k, 1:l )' * W( 1:n, 1:k )'
*
IF( L.GT.0 )
$ CALL SGEMM( 'Transpose', 'Transpose', L, N, K, -ONE, V, LDV,
$ WORK, LDWORK, ONE, C( M-L+1, 1 ), LDC )
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H'
*
* W( 1:m, 1:k ) = C( 1:m, 1:k )
*
DO 40 J = 1, K
CALL SCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
40 CONTINUE
*
* W( 1:m, 1:k ) = W( 1:m, 1:k ) + ...
* C( 1:m, n-l+1:n ) * V( 1:k, 1:l )'
*
IF( L.GT.0 )
$ CALL SGEMM( 'No transpose', 'Transpose', M, K, L, ONE,
$ C( 1, N-L+1 ), LDC, V, LDV, ONE, WORK, LDWORK )
*
* W( 1:m, 1:k ) = W( 1:m, 1:k ) * T or W( 1:m, 1:k ) * T'
*
CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, ONE, T,
$ LDT, WORK, LDWORK )
*
* C( 1:m, 1:k ) = C( 1:m, 1:k ) - W( 1:m, 1:k )
*
DO 60 J = 1, K
DO 50 I = 1, M
C( I, J ) = C( I, J ) - WORK( I, J )
50 CONTINUE
60 CONTINUE
*
* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ...
* W( 1:m, 1:k ) * V( 1:k, 1:l )
*
IF( L.GT.0 )
$ CALL SGEMM( 'No transpose', 'No transpose', M, L, K, -ONE,
$ WORK, LDWORK, V, LDV, ONE, C( 1, N-L+1 ), LDC )
*
END IF
*
RETURN
*
* End of SLARZB
*
END
SUBROUTINE SLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIRECT, STOREV
INTEGER K, LDT, LDV, N
* ..
* .. Array Arguments ..
REAL T( LDT, * ), TAU( * ), V( LDV, * )
* ..
*
* Purpose
* =======
*
* SLARZT 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'
*
* 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 * V
*
* Currently, only STOREV = 'R' and DIRECT = 'B' are supported.
*
* 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, not supported yet)
* = '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 (not supported yet)
* = '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) REAL 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) REAL array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i).
*
* T (output) REAL 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
* ===============
*
* Based on contributions by
* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*
* 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_____
* ( v1 v2 v3 ) / \
* ( v1 v2 v3 ) ( v1 v1 v1 v1 v1 . . . . 1 )
* V = ( v1 v2 v3 ) ( v2 v2 v2 v2 v2 . . . 1 )
* ( v1 v2 v3 ) ( v3 v3 v3 v3 v3 . . 1 )
* ( v1 v2 v3 )
* . . .
* . . .
* 1 . .
* 1 .
* 1
*
* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
*
* ______V_____
* 1 / \
* . 1 ( 1 . . . . v1 v1 v1 v1 v1 )
* . . 1 ( . 1 . . . v2 v2 v2 v2 v2 )
* . . . ( . . 1 . . v3 v3 v3 v3 v3 )
* . . .
* ( v1 v2 v3 )
* ( v1 v2 v3 )
* V = ( v1 v2 v3 )
* ( v1 v2 v3 )
* ( v1 v2 v3 )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
* ..
* .. External Subroutines ..
EXTERNAL SGEMV, STRMV, XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Executable Statements ..
*
* Check for currently supported options
*
INFO = 0
IF( .NOT.LSAME( DIRECT, 'B' ) ) THEN
INFO = -1
ELSE IF( .NOT.LSAME( STOREV, 'R' ) ) THEN
INFO = -2
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLARZT', -INFO )
RETURN
END IF
*
DO 20 I = K, 1, -1
IF( TAU( I ).EQ.ZERO ) THEN
*
* H(i) = I
*
DO 10 J = I, K
T( J, I ) = ZERO
10 CONTINUE
ELSE
*
* general case
*
IF( I.LT.K ) THEN
*
* T(i+1:k,i) = - tau(i) * V(i+1:k,1:n) * V(i,1:n)'
*
CALL SGEMV( 'No transpose', K-I, N, -TAU( I ),
$ V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO,
$ T( I+1, I ), 1 )
*
* T(i+1:k,i) = T(i+1:k,i+1:k) * T(i+1:k,i)
*
CALL STRMV( 'Lower', 'No transpose', 'Non-unit', K-I,
$ T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
END IF
T( I, I ) = TAU( I )
END IF
20 CONTINUE
RETURN
*
* End of SLARZT
*
END
SUBROUTINE SLAS2( F, G, H, SSMIN, SSMAX )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
REAL F, G, H, SSMAX, SSMIN
* ..
*
* Purpose
* =======
*
* SLAS2 computes the singular values of the 2-by-2 matrix
* [ F G ]
* [ 0 H ].
* On return, SSMIN is the smaller singular value and SSMAX is the
* larger singular value.
*
* Arguments
* =========
*
* F (input) REAL
* The (1,1) element of the 2-by-2 matrix.
*
* G (input) REAL
* The (1,2) element of the 2-by-2 matrix.
*
* H (input) REAL
* The (2,2) element of the 2-by-2 matrix.
*
* SSMIN (output) REAL
* The smaller singular value.
*
* SSMAX (output) REAL
* The larger singular value.
*
* Further Details
* ===============
*
* Barring over/underflow, all output quantities are correct to within
* a few units in the last place (ulps), even in the absence of a guard
* digit in addition/subtraction.
*
* In IEEE arithmetic, the code works correctly if one matrix element is
* infinite.
*
* Overflow will not occur unless the largest singular value itself
* overflows, or is within a few ulps of overflow. (On machines with
* partial overflow, like the Cray, overflow may occur if the largest
* singular value is within a factor of 2 of overflow.)
*
* Underflow is harmless if underflow is gradual. Otherwise, results
* may correspond to a matrix modified by perturbations of size near
* the underflow threshold.
*
* ====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
REAL ONE
PARAMETER ( ONE = 1.0E0 )
REAL TWO
PARAMETER ( TWO = 2.0E0 )
* ..
* .. Local Scalars ..
REAL AS, AT, AU, C, FA, FHMN, FHMX, GA, HA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
FA = ABS( F )
GA = ABS( G )
HA = ABS( H )
FHMN = MIN( FA, HA )
FHMX = MAX( FA, HA )
IF( FHMN.EQ.ZERO ) THEN
SSMIN = ZERO
IF( FHMX.EQ.ZERO ) THEN
SSMAX = GA
ELSE
SSMAX = MAX( FHMX, GA )*SQRT( ONE+
$ ( MIN( FHMX, GA ) / MAX( FHMX, GA ) )**2 )
END IF
ELSE
IF( GA.LT.FHMX ) THEN
AS = ONE + FHMN / FHMX
AT = ( FHMX-FHMN ) / FHMX
AU = ( GA / FHMX )**2
C = TWO / ( SQRT( AS*AS+AU )+SQRT( AT*AT+AU ) )
SSMIN = FHMN*C
SSMAX = FHMX / C
ELSE
AU = FHMX / GA
IF( AU.EQ.ZERO ) THEN
*
* Avoid possible harmful underflow if exponent range
* asymmetric (true SSMIN may not underflow even if
* AU underflows)
*
SSMIN = ( FHMN*FHMX ) / GA
SSMAX = GA
ELSE
AS = ONE + FHMN / FHMX
AT = ( FHMX-FHMN ) / FHMX
C = ONE / ( SQRT( ONE+( AS*AU )**2 )+
$ SQRT( ONE+( AT*AU )**2 ) )
SSMIN = ( FHMN*C )*AU
SSMIN = SSMIN + SSMIN
SSMAX = GA / ( C+C )
END IF
END IF
END IF
RETURN
*
* End of SLAS2
*
END
SUBROUTINE SLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TYPE
INTEGER INFO, KL, KU, LDA, M, N
REAL CFROM, CTO
* ..
* .. Array Arguments ..
REAL A( LDA, * )
* ..
*
* Purpose
* =======
*
* SLASCL multiplies the M by N real matrix A by the real scalar
* CTO/CFROM. This is done without over/underflow as long as the final
* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
* A may be full, upper triangular, lower triangular, upper Hessenberg,
* or banded.
*
* Arguments
* =========
*
* TYPE (input) CHARACTER*1
* TYPE indices the storage type of the input matrix.
* = 'G': A is a full matrix.
* = 'L': A is a lower triangular matrix.
* = 'U': A is an upper triangular matrix.
* = 'H': A is an upper Hessenberg matrix.
* = 'B': A is a symmetric band matrix with lower bandwidth KL
* and upper bandwidth KU and with the only the lower
* half stored.
* = 'Q': A is a symmetric band matrix with lower bandwidth KL
* and upper bandwidth KU and with the only the upper
* half stored.
* = 'Z': A is a band matrix with lower bandwidth KL and upper
* bandwidth KU.
*
* KL (input) INTEGER
* The lower bandwidth of A. Referenced only if TYPE = 'B',
* 'Q' or 'Z'.
*
* KU (input) INTEGER
* The upper bandwidth of A. Referenced only if TYPE = 'B',
* 'Q' or 'Z'.
*
* CFROM (input) REAL
* CTO (input) REAL
* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
* without over/underflow if the final result CTO*A(I,J)/CFROM
* can be represented without over/underflow. CFROM must be
* nonzero.
*
* 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) REAL array, dimension (LDA,N)
* The matrix to be multiplied by CTO/CFROM. See TYPE for the
* storage type.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* INFO (output) INTEGER
* 0 - successful exit
* <0 - if INFO = -i, the i-th argument had an illegal value.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL DONE
INTEGER I, ITYPE, J, K1, K2, K3, K4
REAL BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH
EXTERNAL LSAME, SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
*
IF( LSAME( TYPE, 'G' ) ) THEN
ITYPE = 0
ELSE IF( LSAME( TYPE, 'L' ) ) THEN
ITYPE = 1
ELSE IF( LSAME( TYPE, 'U' ) ) THEN
ITYPE = 2
ELSE IF( LSAME( TYPE, 'H' ) ) THEN
ITYPE = 3
ELSE IF( LSAME( TYPE, 'B' ) ) THEN
ITYPE = 4
ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
ITYPE = 5
ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
ITYPE = 6
ELSE
ITYPE = -1
END IF
*
IF( ITYPE.EQ.-1 ) THEN
INFO = -1
ELSE IF( CFROM.EQ.ZERO ) THEN
INFO = -4
ELSE IF( M.LT.0 ) THEN
INFO = -6
ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
$ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
INFO = -7
ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
INFO = -9
ELSE IF( ITYPE.GE.4 ) THEN
IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
INFO = -2
ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
$ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
$ THEN
INFO = -3
ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
$ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
$ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
INFO = -9
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLASCL', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. M.EQ.0 )
$ RETURN
*
* Get machine parameters
*
SMLNUM = SLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
*
CFROMC = CFROM
CTOC = CTO
*
10 CONTINUE
CFROM1 = CFROMC*SMLNUM
CTO1 = CTOC / BIGNUM
IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
MUL = SMLNUM
DONE = .FALSE.
CFROMC = CFROM1
ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
MUL = BIGNUM
DONE = .FALSE.
CTOC = CTO1
ELSE
MUL = CTOC / CFROMC
DONE = .TRUE.
END IF
*
IF( ITYPE.EQ.0 ) THEN
*
* Full matrix
*
DO 30 J = 1, N
DO 20 I = 1, M
A( I, J ) = A( I, J )*MUL
20 CONTINUE
30 CONTINUE
*
ELSE IF( ITYPE.EQ.1 ) THEN
*
* Lower triangular matrix
*
DO 50 J = 1, N
DO 40 I = J, M
A( I, J ) = A( I, J )*MUL
40 CONTINUE
50 CONTINUE
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Upper triangular matrix
*
DO 70 J = 1, N
DO 60 I = 1, MIN( J, M )
A( I, J ) = A( I, J )*MUL
60 CONTINUE
70 CONTINUE
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* Upper Hessenberg matrix
*
DO 90 J = 1, N
DO 80 I = 1, MIN( J+1, M )
A( I, J ) = A( I, J )*MUL
80 CONTINUE
90 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Lower half of a symmetric band matrix
*
K3 = KL + 1
K4 = N + 1
DO 110 J = 1, N
DO 100 I = 1, MIN( K3, K4-J )
A( I, J ) = A( I, J )*MUL
100 CONTINUE
110 CONTINUE
*
ELSE IF( ITYPE.EQ.5 ) THEN
*
* Upper half of a symmetric band matrix
*
K1 = KU + 2
K3 = KU + 1
DO 130 J = 1, N
DO 120 I = MAX( K1-J, 1 ), K3
A( I, J ) = A( I, J )*MUL
120 CONTINUE
130 CONTINUE
*
ELSE IF( ITYPE.EQ.6 ) THEN
*
* Band matrix
*
K1 = KL + KU + 2
K2 = KL + 1
K3 = 2*KL + KU + 1
K4 = KL + KU + 1 + M
DO 150 J = 1, N
DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
A( I, J ) = A( I, J )*MUL
140 CONTINUE
150 CONTINUE
*
END IF
*
IF( .NOT.DONE )
$ GO TO 10
*
RETURN
*
* End of SLASCL
*
END
SUBROUTINE SLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK,
$ WORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDU, LDVT, N, SMLSIZ, SQRE
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL D( * ), E( * ), U( LDU, * ), VT( LDVT, * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* Using a divide and conquer approach, SLASD0 computes the singular
* value decomposition (SVD) of a real upper bidiagonal N-by-M
* matrix B with diagonal D and offdiagonal E, where M = N + SQRE.
* The algorithm computes orthogonal matrices U and VT such that
* B = U * S * VT. The singular values S are overwritten on D.
*
* A related subroutine, SLASDA, computes only the singular values,
* and optionally, the singular vectors in compact form.
*
* Arguments
* =========
*
* N (input) INTEGER
* On entry, the row dimension of the upper bidiagonal matrix.
* This is also the dimension of the main diagonal array D.
*
* SQRE (input) INTEGER
* Specifies the column dimension of the bidiagonal matrix.
* = 0: The bidiagonal matrix has column dimension M = N;
* = 1: The bidiagonal matrix has column dimension M = N+1;
*
* D (input/output) REAL array, dimension (N)
* On entry D contains the main diagonal of the bidiagonal
* matrix.
* On exit D, if INFO = 0, contains its singular values.
*
* E (input) REAL array, dimension (M-1)
* Contains the subdiagonal entries of the bidiagonal matrix.
* On exit, E has been destroyed.
*
* U (output) REAL array, dimension at least (LDQ, N)
* On exit, U contains the left singular vectors.
*
* LDU (input) INTEGER
* On entry, leading dimension of U.
*
* VT (output) REAL array, dimension at least (LDVT, M)
* On exit, VT' contains the right singular vectors.
*
* LDVT (input) INTEGER
* On entry, leading dimension of VT.
*
* SMLSIZ (input) INTEGER
* On entry, maximum size of the subproblems at the
* bottom of the computation tree.
*
* IWORK (workspace) INTEGER array, dimension (8*N)
*
* WORK (workspace) REAL array, dimension (3*M**2+2*M)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an singular value did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, I1, IC, IDXQ, IDXQC, IM1, INODE, ITEMP, IWK,
$ J, LF, LL, LVL, M, NCC, ND, NDB1, NDIML, NDIMR,
$ NL, NLF, NLP1, NLVL, NR, NRF, NRP1, SQREI
REAL ALPHA, BETA
* ..
* .. External Subroutines ..
EXTERNAL SLASD1, SLASDQ, SLASDT, XERBLA
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
INFO = -2
END IF
*
M = N + SQRE
*
IF( LDU.LT.N ) THEN
INFO = -6
ELSE IF( LDVT.LT.M ) THEN
INFO = -8
ELSE IF( SMLSIZ.LT.3 ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLASD0', -INFO )
RETURN
END IF
*
* If the input matrix is too small, call SLASDQ to find the SVD.
*
IF( N.LE.SMLSIZ ) THEN
CALL SLASDQ( 'U', SQRE, N, M, N, 0, D, E, VT, LDVT, U, LDU, U,
$ LDU, WORK, INFO )
RETURN
END IF
*
* Set up the computation tree.
*
INODE = 1
NDIML = INODE + N
NDIMR = NDIML + N
IDXQ = NDIMR + N
IWK = IDXQ + N
CALL SLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ),
$ IWORK( NDIMR ), SMLSIZ )
*
* For the nodes on bottom level of the tree, solve
* their subproblems by SLASDQ.
*
NDB1 = ( ND+1 ) / 2
NCC = 0
DO 30 I = NDB1, ND
*
* IC : center row of each node
* NL : number of rows of left subproblem
* NR : number of rows of right subproblem
* NLF: starting row of the left subproblem
* NRF: starting row of the right subproblem
*
I1 = I - 1
IC = IWORK( INODE+I1 )
NL = IWORK( NDIML+I1 )
NLP1 = NL + 1
NR = IWORK( NDIMR+I1 )
NRP1 = NR + 1
NLF = IC - NL
NRF = IC + 1
SQREI = 1
CALL SLASDQ( 'U', SQREI, NL, NLP1, NL, NCC, D( NLF ), E( NLF ),
$ VT( NLF, NLF ), LDVT, U( NLF, NLF ), LDU,
$ U( NLF, NLF ), LDU, WORK, INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
ITEMP = IDXQ + NLF - 2
DO 10 J = 1, NL
IWORK( ITEMP+J ) = J
10 CONTINUE
IF( I.EQ.ND ) THEN
SQREI = SQRE
ELSE
SQREI = 1
END IF
NRP1 = NR + SQREI
CALL SLASDQ( 'U', SQREI, NR, NRP1, NR, NCC, D( NRF ), E( NRF ),
$ VT( NRF, NRF ), LDVT, U( NRF, NRF ), LDU,
$ U( NRF, NRF ), LDU, WORK, INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
ITEMP = IDXQ + IC
DO 20 J = 1, NR
IWORK( ITEMP+J-1 ) = J
20 CONTINUE
30 CONTINUE
*
* Now conquer each subproblem bottom-up.
*
DO 50 LVL = NLVL, 1, -1
*
* Find the first node LF and last node LL on the
* current level LVL.
*
IF( LVL.EQ.1 ) THEN
LF = 1
LL = 1
ELSE
LF = 2**( LVL-1 )
LL = 2*LF - 1
END IF
DO 40 I = LF, LL
IM1 = I - 1
IC = IWORK( INODE+IM1 )
NL = IWORK( NDIML+IM1 )
NR = IWORK( NDIMR+IM1 )
NLF = IC - NL
IF( ( SQRE.EQ.0 ) .AND. ( I.EQ.LL ) ) THEN
SQREI = SQRE
ELSE
SQREI = 1
END IF
IDXQC = IDXQ + NLF - 1
ALPHA = D( IC )
BETA = E( IC )
CALL SLASD1( NL, NR, SQREI, D( NLF ), ALPHA, BETA,
$ U( NLF, NLF ), LDU, VT( NLF, NLF ), LDVT,
$ IWORK( IDXQC ), IWORK( IWK ), WORK, INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
40 CONTINUE
50 CONTINUE
*
RETURN
*
* End of SLASD0
*
END
SUBROUTINE SLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT,
$ IDXQ, IWORK, WORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDU, LDVT, NL, NR, SQRE
REAL ALPHA, BETA
* ..
* .. Array Arguments ..
INTEGER IDXQ( * ), IWORK( * )
REAL D( * ), U( LDU, * ), VT( LDVT, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B,
* where N = NL + NR + 1 and M = N + SQRE. SLASD1 is called from SLASD0.
*
* A related subroutine SLASD7 handles the case in which the singular
* values (and the singular vectors in factored form) are desired.
*
* SLASD1 computes the SVD as follows:
*
* ( D1(in) 0 0 0 )
* B = U(in) * ( Z1' a Z2' b ) * VT(in)
* ( 0 0 D2(in) 0 )
*
* = U(out) * ( D(out) 0) * VT(out)
*
* where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M
* with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros
* elsewhere; and the entry b is empty if SQRE = 0.
*
* The left singular vectors of the original matrix are stored in U, and
* the transpose of the right singular vectors are stored in VT, and the
* singular values are in D. The algorithm consists of three stages:
*
* The first stage consists of deflating the size of the problem
* when there are multiple singular values or when there are zeros in
* the Z vector. For each such occurence the dimension of the
* secular equation problem is reduced by one. This stage is
* performed by the routine SLASD2.
*
* The second stage consists of calculating the updated
* singular values. This is done by finding the square roots of the
* roots of the secular equation via the routine SLASD4 (as called
* by SLASD3). This routine also calculates the singular vectors of
* the current problem.
*
* The final stage consists of computing the updated singular vectors
* directly using the updated singular values. The singular vectors
* for the current problem are multiplied with the singular vectors
* from the overall problem.
*
* Arguments
* =========
*
* NL (input) INTEGER
* The row dimension of the upper block. NL >= 1.
*
* NR (input) INTEGER
* The row dimension of the lower block. NR >= 1.
*
* SQRE (input) INTEGER
* = 0: the lower block is an NR-by-NR square matrix.
* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
*
* The bidiagonal matrix has row dimension N = NL + NR + 1,
* and column dimension M = N + SQRE.
*
* D (input/output) REAL array, dimension (NL+NR+1).
* N = NL+NR+1
* On entry D(1:NL,1:NL) contains the singular values of the
* upper block; and D(NL+2:N) contains the singular values of
* the lower block. On exit D(1:N) contains the singular values
* of the modified matrix.
*
* ALPHA (input/output) REAL
* Contains the diagonal element associated with the added row.
*
* BETA (input/output) REAL
* Contains the off-diagonal element associated with the added
* row.
*
* U (input/output) REAL array, dimension (LDU,N)
* On entry U(1:NL, 1:NL) contains the left singular vectors of
* the upper block; U(NL+2:N, NL+2:N) contains the left singular
* vectors of the lower block. On exit U contains the left
* singular vectors of the bidiagonal matrix.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= max( 1, N ).
*
* VT (input/output) REAL array, dimension (LDVT,M)
* where M = N + SQRE.
* On entry VT(1:NL+1, 1:NL+1)' contains the right singular
* vectors of the upper block; VT(NL+2:M, NL+2:M)' contains
* the right singular vectors of the lower block. On exit
* VT' contains the right singular vectors of the
* bidiagonal matrix.
*
* LDVT (input) INTEGER
* The leading dimension of the array VT. LDVT >= max( 1, M ).
*
* IDXQ (output) INTEGER array, dimension (N)
* This contains the permutation which will reintegrate the
* subproblem just solved back into sorted order, i.e.
* D( IDXQ( I = 1, N ) ) will be in ascending order.
*
* IWORK (workspace) INTEGER array, dimension (4*N)
*
* WORK (workspace) REAL array, dimension (3*M**2+2*M)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an singular value did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
*
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER COLTYP, I, IDX, IDXC, IDXP, IQ, ISIGMA, IU2,
$ IVT2, IZ, K, LDQ, LDU2, LDVT2, M, N, N1, N2
REAL ORGNRM
* ..
* .. External Subroutines ..
EXTERNAL SLAMRG, SLASCL, SLASD2, SLASD3, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( NL.LT.1 ) THEN
INFO = -1
ELSE IF( NR.LT.1 ) THEN
INFO = -2
ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
INFO = -3
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLASD1', -INFO )
RETURN
END IF
*
N = NL + NR + 1
M = N + SQRE
*
* The following values are for bookkeeping purposes only. They are
* integer pointers which indicate the portion of the workspace
* used by a particular array in SLASD2 and SLASD3.
*
LDU2 = N
LDVT2 = M
*
IZ = 1
ISIGMA = IZ + M
IU2 = ISIGMA + N
IVT2 = IU2 + LDU2*N
IQ = IVT2 + LDVT2*M
*
IDX = 1
IDXC = IDX + N
COLTYP = IDXC + N
IDXP = COLTYP + N
*
* Scale.
*
ORGNRM = MAX( ABS( ALPHA ), ABS( BETA ) )
D( NL+1 ) = ZERO
DO 10 I = 1, N
IF( ABS( D( I ) ).GT.ORGNRM ) THEN
ORGNRM = ABS( D( I ) )
END IF
10 CONTINUE
CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
ALPHA = ALPHA / ORGNRM
BETA = BETA / ORGNRM
*
* Deflate singular values.
*
CALL SLASD2( NL, NR, SQRE, K, D, WORK( IZ ), ALPHA, BETA, U, LDU,
$ VT, LDVT, WORK( ISIGMA ), WORK( IU2 ), LDU2,
$ WORK( IVT2 ), LDVT2, IWORK( IDXP ), IWORK( IDX ),
$ IWORK( IDXC ), IDXQ, IWORK( COLTYP ), INFO )
*
* Solve Secular Equation and update singular vectors.
*
LDQ = K
CALL SLASD3( NL, NR, SQRE, K, D, WORK( IQ ), LDQ, WORK( ISIGMA ),
$ U, LDU, WORK( IU2 ), LDU2, VT, LDVT, WORK( IVT2 ),
$ LDVT2, IWORK( IDXC ), IWORK( COLTYP ), WORK( IZ ),
$ INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
*
* Unscale.
*
CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
*
* Prepare the IDXQ sorting permutation.
*
N1 = K
N2 = N - K
CALL SLAMRG( N1, N2, D, 1, -1, IDXQ )
*
RETURN
*
* End of SLASD1
*
END
SUBROUTINE SLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT,
$ LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX,
$ IDXC, IDXQ, COLTYP, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDU, LDU2, LDVT, LDVT2, NL, NR, SQRE
REAL ALPHA, BETA
* ..
* .. Array Arguments ..
INTEGER COLTYP( * ), IDX( * ), IDXC( * ), IDXP( * ),
$ IDXQ( * )
REAL D( * ), DSIGMA( * ), U( LDU, * ),
$ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ),
$ Z( * )
* ..
*
* Purpose
* =======
*
* SLASD2 merges the two sets of singular values together into a single
* sorted set. Then it tries to deflate the size of the problem.
* There are two ways in which deflation can occur: when two or more
* singular values are close together or if there is a tiny entry in the
* Z vector. For each such occurrence the order of the related secular
* equation problem is reduced by one.
*
* SLASD2 is called from SLASD1.
*
* Arguments
* =========
*
* NL (input) INTEGER
* The row dimension of the upper block. NL >= 1.
*
* NR (input) INTEGER
* The row dimension of the lower block. NR >= 1.
*
* SQRE (input) INTEGER
* = 0: the lower block is an NR-by-NR square matrix.
* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
*
* The bidiagonal matrix has N = NL + NR + 1 rows and
* M = N + SQRE >= N columns.
*
* K (output) INTEGER
* Contains the dimension of the non-deflated matrix,
* This is the order of the related secular equation. 1 <= K <=N.
*
* D (input/output) REAL array, dimension (N)
* On entry D contains the singular values of the two submatrices
* to be combined. On exit D contains the trailing (N-K) updated
* singular values (those which were deflated) sorted into
* increasing order.
*
* Z (output) REAL array, dimension (N)
* On exit Z contains the updating row vector in the secular
* equation.
*
* ALPHA (input) REAL
* Contains the diagonal element associated with the added row.
*
* BETA (input) REAL
* Contains the off-diagonal element associated with the added
* row.
*
* U (input/output) REAL array, dimension (LDU,N)
* On entry U contains the left singular vectors of two
* submatrices in the two square blocks with corners at (1,1),
* (NL, NL), and (NL+2, NL+2), (N,N).
* On exit U contains the trailing (N-K) updated left singular
* vectors (those which were deflated) in its last N-K columns.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= N.
*
* VT (input/output) REAL array, dimension (LDVT,M)
* On entry VT' contains the right singular vectors of two
* submatrices in the two square blocks with corners at (1,1),
* (NL+1, NL+1), and (NL+2, NL+2), (M,M).
* On exit VT' contains the trailing (N-K) updated right singular
* vectors (those which were deflated) in its last N-K columns.
* In case SQRE =1, the last row of VT spans the right null
* space.
*
* LDVT (input) INTEGER
* The leading dimension of the array VT. LDVT >= M.
*
* DSIGMA (output) REAL array, dimension (N)
* Contains a copy of the diagonal elements (K-1 singular values
* and one zero) in the secular equation.
*
* U2 (output) REAL array, dimension (LDU2,N)
* Contains a copy of the first K-1 left singular vectors which
* will be used by SLASD3 in a matrix multiply (SGEMM) to solve
* for the new left singular vectors. U2 is arranged into four
* blocks. The first block contains a column with 1 at NL+1 and
* zero everywhere else; the second block contains non-zero
* entries only at and above NL; the third contains non-zero
* entries only below NL+1; and the fourth is dense.
*
* LDU2 (input) INTEGER
* The leading dimension of the array U2. LDU2 >= N.
*
* VT2 (output) REAL array, dimension (LDVT2,N)
* VT2' contains a copy of the first K right singular vectors
* which will be used by SLASD3 in a matrix multiply (SGEMM) to
* solve for the new right singular vectors. VT2 is arranged into
* three blocks. The first block contains a row that corresponds
* to the special 0 diagonal element in SIGMA; the second block
* contains non-zeros only at and before NL +1; the third block
* contains non-zeros only at and after NL +2.
*
* LDVT2 (input) INTEGER
* The leading dimension of the array VT2. LDVT2 >= M.
*
* IDXP (workspace) INTEGER array, dimension (N)
* This will contain the permutation used to place deflated
* values of D at the end of the array. On output IDXP(2:K)
* points to the nondeflated D-values and IDXP(K+1:N)
* points to the deflated singular values.
*
* IDX (workspace) INTEGER array, dimension (N)
* This will contain the permutation used to sort the contents of
* D into ascending order.
*
* IDXC (output) INTEGER array, dimension (N)
* This will contain the permutation used to arrange the columns
* of the deflated U matrix into three groups: the first group
* contains non-zero entries only at and above NL, the second
* contains non-zero entries only below NL+2, and the third is
* dense.
*
* IDXQ (input/output) INTEGER array, dimension (N)
* This contains the permutation which separately sorts the two
* sub-problems in D into ascending order. Note that entries in
* the first hlaf of this permutation must first be moved one
* position backward; and entries in the second half
* must first have NL+1 added to their values.
*
* COLTYP (workspace/output) INTEGER array, dimension (N)
* As workspace, this will contain a label which will indicate
* which of the following types a column in the U2 matrix or a
* row in the VT2 matrix is:
* 1 : non-zero in the upper half only
* 2 : non-zero in the lower half only
* 3 : dense
* 4 : deflated
*
* On exit, it is an array of dimension 4, with COLTYP(I) being
* the dimension of the I-th type columns.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO, EIGHT
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0,
$ EIGHT = 8.0E+0 )
* ..
* .. Local Arrays ..
INTEGER CTOT( 4 ), PSM( 4 )
* ..
* .. Local Scalars ..
INTEGER CT, I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M,
$ N, NLP1, NLP2
REAL C, EPS, HLFTOL, S, TAU, TOL, Z1
* ..
* .. External Functions ..
REAL SLAMCH, SLAPY2
EXTERNAL SLAMCH, SLAPY2
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLACPY, SLAMRG, SLASET, SROT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( NL.LT.1 ) THEN
INFO = -1
ELSE IF( NR.LT.1 ) THEN
INFO = -2
ELSE IF( ( SQRE.NE.1 ) .AND. ( SQRE.NE.0 ) ) THEN
INFO = -3
END IF
*
N = NL + NR + 1
M = N + SQRE
*
IF( LDU.LT.N ) THEN
INFO = -10
ELSE IF( LDVT.LT.M ) THEN
INFO = -12
ELSE IF( LDU2.LT.N ) THEN
INFO = -15
ELSE IF( LDVT2.LT.M ) THEN
INFO = -17
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLASD2', -INFO )
RETURN
END IF
*
NLP1 = NL + 1
NLP2 = NL + 2
*
* Generate the first part of the vector Z; and move the singular
* values in the first part of D one position backward.
*
Z1 = ALPHA*VT( NLP1, NLP1 )
Z( 1 ) = Z1
DO 10 I = NL, 1, -1
Z( I+1 ) = ALPHA*VT( I, NLP1 )
D( I+1 ) = D( I )
IDXQ( I+1 ) = IDXQ( I ) + 1
10 CONTINUE
*
* Generate the second part of the vector Z.
*
DO 20 I = NLP2, M
Z( I ) = BETA*VT( I, NLP2 )
20 CONTINUE
*
* Initialize some reference arrays.
*
DO 30 I = 2, NLP1
COLTYP( I ) = 1
30 CONTINUE
DO 40 I = NLP2, N
COLTYP( I ) = 2
40 CONTINUE
*
* Sort the singular values into increasing order
*
DO 50 I = NLP2, N
IDXQ( I ) = IDXQ( I ) + NLP1
50 CONTINUE
*
* DSIGMA, IDXC, IDXC, and the first column of U2
* are used as storage space.
*
DO 60 I = 2, N
DSIGMA( I ) = D( IDXQ( I ) )
U2( I, 1 ) = Z( IDXQ( I ) )
IDXC( I ) = COLTYP( IDXQ( I ) )
60 CONTINUE
*
CALL SLAMRG( NL, NR, DSIGMA( 2 ), 1, 1, IDX( 2 ) )
*
DO 70 I = 2, N
IDXI = 1 + IDX( I )
D( I ) = DSIGMA( IDXI )
Z( I ) = U2( IDXI, 1 )
COLTYP( I ) = IDXC( IDXI )
70 CONTINUE
*
* Calculate the allowable deflation tolerance
*
EPS = SLAMCH( 'Epsilon' )
TOL = MAX( ABS( ALPHA ), ABS( BETA ) )
TOL = EIGHT*EPS*MAX( ABS( D( N ) ), TOL )
*
* There are 2 kinds of deflation -- first a value in the z-vector
* is small, second two (or more) singular values are very close
* together (their difference is small).
*
* If the value in the z-vector is small, we simply permute the
* array so that the corresponding singular value is moved to the
* end.
*
* If two values in the D-vector are close, we perform a two-sided
* rotation designed to make one of the corresponding z-vector
* entries zero, and then permute the array so that the deflated
* singular value is moved to the end.
*
* If there are multiple singular values then the problem deflates.
* Here the number of equal singular values are found. As each equal
* singular value is found, an elementary reflector is computed to
* rotate the corresponding singular subspace so that the
* corresponding components of Z are zero in this new basis.
*
K = 1
K2 = N + 1
DO 80 J = 2, N
IF( ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
IDXP( K2 ) = J
COLTYP( J ) = 4
IF( J.EQ.N )
$ GO TO 120
ELSE
JPREV = J
GO TO 90
END IF
80 CONTINUE
90 CONTINUE
J = JPREV
100 CONTINUE
J = J + 1
IF( J.GT.N )
$ GO TO 110
IF( ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
IDXP( K2 ) = J
COLTYP( J ) = 4
ELSE
*
* Check if singular values are close enough to allow deflation.
*
IF( ABS( D( J )-D( JPREV ) ).LE.TOL ) THEN
*
* Deflation is possible.
*
S = Z( JPREV )
C = Z( J )
*
* Find sqrt(a**2+b**2) without overflow or
* destructive underflow.
*
TAU = SLAPY2( C, S )
C = C / TAU
S = -S / TAU
Z( J ) = TAU
Z( JPREV ) = ZERO
*
* Apply back the Givens rotation to the left and right
* singular vector matrices.
*
IDXJP = IDXQ( IDX( JPREV )+1 )
IDXJ = IDXQ( IDX( J )+1 )
IF( IDXJP.LE.NLP1 ) THEN
IDXJP = IDXJP - 1
END IF
IF( IDXJ.LE.NLP1 ) THEN
IDXJ = IDXJ - 1
END IF
CALL SROT( N, U( 1, IDXJP ), 1, U( 1, IDXJ ), 1, C, S )
CALL SROT( M, VT( IDXJP, 1 ), LDVT, VT( IDXJ, 1 ), LDVT, C,
$ S )
IF( COLTYP( J ).NE.COLTYP( JPREV ) ) THEN
COLTYP( J ) = 3
END IF
COLTYP( JPREV ) = 4
K2 = K2 - 1
IDXP( K2 ) = JPREV
JPREV = J
ELSE
K = K + 1
U2( K, 1 ) = Z( JPREV )
DSIGMA( K ) = D( JPREV )
IDXP( K ) = JPREV
JPREV = J
END IF
END IF
GO TO 100
110 CONTINUE
*
* Record the last singular value.
*
K = K + 1
U2( K, 1 ) = Z( JPREV )
DSIGMA( K ) = D( JPREV )
IDXP( K ) = JPREV
*
120 CONTINUE
*
* Count up the total number of the various types of columns, then
* form a permutation which positions the four column types into
* four groups of uniform structure (although one or more of these
* groups may be empty).
*
DO 130 J = 1, 4
CTOT( J ) = 0
130 CONTINUE
DO 140 J = 2, N
CT = COLTYP( J )
CTOT( CT ) = CTOT( CT ) + 1
140 CONTINUE
*
* PSM(*) = Position in SubMatrix (of types 1 through 4)
*
PSM( 1 ) = 2
PSM( 2 ) = 2 + CTOT( 1 )
PSM( 3 ) = PSM( 2 ) + CTOT( 2 )
PSM( 4 ) = PSM( 3 ) + CTOT( 3 )
*
* Fill out the IDXC array so that the permutation which it induces
* will place all type-1 columns first, all type-2 columns next,
* then all type-3's, and finally all type-4's, starting from the
* second column. This applies similarly to the rows of VT.
*
DO 150 J = 2, N
JP = IDXP( J )
CT = COLTYP( JP )
IDXC( PSM( CT ) ) = J
PSM( CT ) = PSM( CT ) + 1
150 CONTINUE
*
* Sort the singular values and corresponding singular vectors into
* DSIGMA, U2, and VT2 respectively. The singular values/vectors
* which were not deflated go into the first K slots of DSIGMA, U2,
* and VT2 respectively, while those which were deflated go into the
* last N - K slots, except that the first column/row will be treated
* separately.
*
DO 160 J = 2, N
JP = IDXP( J )
DSIGMA( J ) = D( JP )
IDXJ = IDXQ( IDX( IDXP( IDXC( J ) ) )+1 )
IF( IDXJ.LE.NLP1 ) THEN
IDXJ = IDXJ - 1
END IF
CALL SCOPY( N, U( 1, IDXJ ), 1, U2( 1, J ), 1 )
CALL SCOPY( M, VT( IDXJ, 1 ), LDVT, VT2( J, 1 ), LDVT2 )
160 CONTINUE
*
* Determine DSIGMA(1), DSIGMA(2) and Z(1)
*
DSIGMA( 1 ) = ZERO
HLFTOL = TOL / TWO
IF( ABS( DSIGMA( 2 ) ).LE.HLFTOL )
$ DSIGMA( 2 ) = HLFTOL
IF( M.GT.N ) THEN
Z( 1 ) = SLAPY2( Z1, Z( M ) )
IF( Z( 1 ).LE.TOL ) THEN
C = ONE
S = ZERO
Z( 1 ) = TOL
ELSE
C = Z1 / Z( 1 )
S = Z( M ) / Z( 1 )
END IF
ELSE
IF( ABS( Z1 ).LE.TOL ) THEN
Z( 1 ) = TOL
ELSE
Z( 1 ) = Z1
END IF
END IF
*
* Move the rest of the updating row to Z.
*
CALL SCOPY( K-1, U2( 2, 1 ), 1, Z( 2 ), 1 )
*
* Determine the first column of U2, the first row of VT2 and the
* last row of VT.
*
CALL SLASET( 'A', N, 1, ZERO, ZERO, U2, LDU2 )
U2( NLP1, 1 ) = ONE
IF( M.GT.N ) THEN
DO 170 I = 1, NLP1
VT( M, I ) = -S*VT( NLP1, I )
VT2( 1, I ) = C*VT( NLP1, I )
170 CONTINUE
DO 180 I = NLP2, M
VT2( 1, I ) = S*VT( M, I )
VT( M, I ) = C*VT( M, I )
180 CONTINUE
ELSE
CALL SCOPY( M, VT( NLP1, 1 ), LDVT, VT2( 1, 1 ), LDVT2 )
END IF
IF( M.GT.N ) THEN
CALL SCOPY( M, VT( M, 1 ), LDVT, VT2( M, 1 ), LDVT2 )
END IF
*
* The deflated singular values and their corresponding vectors go
* into the back of D, U, and V respectively.
*
IF( N.GT.K ) THEN
CALL SCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 )
CALL SLACPY( 'A', N, N-K, U2( 1, K+1 ), LDU2, U( 1, K+1 ),
$ LDU )
CALL SLACPY( 'A', N-K, M, VT2( K+1, 1 ), LDVT2, VT( K+1, 1 ),
$ LDVT )
END IF
*
* Copy CTOT into COLTYP for referencing in SLASD3.
*
DO 190 J = 1, 4
COLTYP( J ) = CTOT( J )
190 CONTINUE
*
RETURN
*
* End of SLASD2
*
END
SUBROUTINE SLASD3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2,
$ LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z,
$ INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDQ, LDU, LDU2, LDVT, LDVT2, NL, NR,
$ SQRE
* ..
* .. Array Arguments ..
INTEGER CTOT( * ), IDXC( * )
REAL D( * ), DSIGMA( * ), Q( LDQ, * ), U( LDU, * ),
$ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ),
$ Z( * )
* ..
*
* Purpose
* =======
*
* SLASD3 finds all the square roots of the roots of the secular
* equation, as defined by the values in D and Z. It makes the
* appropriate calls to SLASD4 and then updates the singular
* vectors by matrix multiplication.
*
* This code makes very mild assumptions about floating point
* arithmetic. It will work on machines with a guard digit in
* add/subtract, or on those binary machines without guard digits
* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
* It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* SLASD3 is called from SLASD1.
*
* Arguments
* =========
*
* NL (input) INTEGER
* The row dimension of the upper block. NL >= 1.
*
* NR (input) INTEGER
* The row dimension of the lower block. NR >= 1.
*
* SQRE (input) INTEGER
* = 0: the lower block is an NR-by-NR square matrix.
* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
*
* The bidiagonal matrix has N = NL + NR + 1 rows and
* M = N + SQRE >= N columns.
*
* K (input) INTEGER
* The size of the secular equation, 1 =< K = < N.
*
* D (output) REAL array, dimension(K)
* On exit the square roots of the roots of the secular equation,
* in ascending order.
*
* Q (workspace) REAL array,
* dimension at least (LDQ,K).
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= K.
*
* DSIGMA (input/output) REAL array, dimension(K)
* The first K elements of this array contain the old roots
* of the deflated updating problem. These are the poles
* of the secular equation.
*
* U (output) REAL array, dimension (LDU, N)
* The last N - K columns of this matrix contain the deflated
* left singular vectors.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= N.
*
* U2 (input) REAL array, dimension (LDU2, N)
* The first K columns of this matrix contain the non-deflated
* left singular vectors for the split problem.
*
* LDU2 (input) INTEGER
* The leading dimension of the array U2. LDU2 >= N.
*
* VT (output) REAL array, dimension (LDVT, M)
* The last M - K columns of VT' contain the deflated
* right singular vectors.
*
* LDVT (input) INTEGER
* The leading dimension of the array VT. LDVT >= N.
*
* VT2 (input/output) REAL array, dimension (LDVT2, N)
* The first K columns of VT2' contain the non-deflated
* right singular vectors for the split problem.
*
* LDVT2 (input) INTEGER
* The leading dimension of the array VT2. LDVT2 >= N.
*
* IDXC (input) INTEGER array, dimension (N)
* The permutation used to arrange the columns of U (and rows of
* VT) into three groups: the first group contains non-zero
* entries only at and above (or before) NL +1; the second
* contains non-zero entries only at and below (or after) NL+2;
* and the third is dense. The first column of U and the row of
* VT are treated separately, however.
*
* The rows of the singular vectors found by SLASD4
* must be likewise permuted before the matrix multiplies can
* take place.
*
* CTOT (input) INTEGER array, dimension (4)
* A count of the total number of the various types of columns
* in U (or rows in VT), as described in IDXC. The fourth column
* type is any column which has been deflated.
*
* Z (input/output) REAL array, dimension (K)
* The first K elements of this array contain the components
* of the deflation-adjusted updating row vector.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an singular value did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO, NEGONE
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0,
$ NEGONE = -1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER CTEMP, I, J, JC, KTEMP, M, N, NLP1, NLP2, NRP1
REAL RHO, TEMP
* ..
* .. External Functions ..
REAL SLAMC3, SNRM2
EXTERNAL SLAMC3, SNRM2
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMM, SLACPY, SLASCL, SLASD4, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( NL.LT.1 ) THEN
INFO = -1
ELSE IF( NR.LT.1 ) THEN
INFO = -2
ELSE IF( ( SQRE.NE.1 ) .AND. ( SQRE.NE.0 ) ) THEN
INFO = -3
END IF
*
N = NL + NR + 1
M = N + SQRE
NLP1 = NL + 1
NLP2 = NL + 2
*
IF( ( K.LT.1 ) .OR. ( K.GT.N ) ) THEN
INFO = -4
ELSE IF( LDQ.LT.K ) THEN
INFO = -7
ELSE IF( LDU.LT.N ) THEN
INFO = -10
ELSE IF( LDU2.LT.N ) THEN
INFO = -12
ELSE IF( LDVT.LT.M ) THEN
INFO = -14
ELSE IF( LDVT2.LT.M ) THEN
INFO = -16
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLASD3', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( K.EQ.1 ) THEN
D( 1 ) = ABS( Z( 1 ) )
CALL SCOPY( M, VT2( 1, 1 ), LDVT2, VT( 1, 1 ), LDVT )
IF( Z( 1 ).GT.ZERO ) THEN
CALL SCOPY( N, U2( 1, 1 ), 1, U( 1, 1 ), 1 )
ELSE
DO 10 I = 1, N
U( I, 1 ) = -U2( I, 1 )
10 CONTINUE
END IF
RETURN
END IF
*
* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can
* be computed with high relative accuracy (barring over/underflow).
* This is a problem on machines without a guard digit in
* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I),
* which on any of these machines zeros out the bottommost
* bit of DSIGMA(I) if it is 1; this makes the subsequent
* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation
* occurs. On binary machines with a guard digit (almost all
* machines) it does not change DSIGMA(I) at all. On hexadecimal
* and decimal machines with a guard digit, it slightly
* changes the bottommost bits of DSIGMA(I). It does not account
* for hexadecimal or decimal machines without guard digits
* (we know of none). We use a subroutine call to compute
* 2*DSIGMA(I) to prevent optimizing compilers from eliminating
* this code.
*
DO 20 I = 1, K
DSIGMA( I ) = SLAMC3( DSIGMA( I ), DSIGMA( I ) ) - DSIGMA( I )
20 CONTINUE
*
* Keep a copy of Z.
*
CALL SCOPY( K, Z, 1, Q, 1 )
*
* Normalize Z.
*
RHO = SNRM2( K, Z, 1 )
CALL SLASCL( 'G', 0, 0, RHO, ONE, K, 1, Z, K, INFO )
RHO = RHO*RHO
*
* Find the new singular values.
*
DO 30 J = 1, K
CALL SLASD4( K, J, DSIGMA, Z, U( 1, J ), RHO, D( J ),
$ VT( 1, J ), INFO )
*
* If the zero finder fails, the computation is terminated.
*
IF( INFO.NE.0 ) THEN
RETURN
END IF
30 CONTINUE
*
* Compute updated Z.
*
DO 60 I = 1, K
Z( I ) = U( I, K )*VT( I, K )
DO 40 J = 1, I - 1
Z( I ) = Z( I )*( U( I, J )*VT( I, J ) /
$ ( DSIGMA( I )-DSIGMA( J ) ) /
$ ( DSIGMA( I )+DSIGMA( J ) ) )
40 CONTINUE
DO 50 J = I, K - 1
Z( I ) = Z( I )*( U( I, J )*VT( I, J ) /
$ ( DSIGMA( I )-DSIGMA( J+1 ) ) /
$ ( DSIGMA( I )+DSIGMA( J+1 ) ) )
50 CONTINUE
Z( I ) = SIGN( SQRT( ABS( Z( I ) ) ), Q( I, 1 ) )
60 CONTINUE
*
* Compute left singular vectors of the modified diagonal matrix,
* and store related information for the right singular vectors.
*
DO 90 I = 1, K
VT( 1, I ) = Z( 1 ) / U( 1, I ) / VT( 1, I )
U( 1, I ) = NEGONE
DO 70 J = 2, K
VT( J, I ) = Z( J ) / U( J, I ) / VT( J, I )
U( J, I ) = DSIGMA( J )*VT( J, I )
70 CONTINUE
TEMP = SNRM2( K, U( 1, I ), 1 )
Q( 1, I ) = U( 1, I ) / TEMP
DO 80 J = 2, K
JC = IDXC( J )
Q( J, I ) = U( JC, I ) / TEMP
80 CONTINUE
90 CONTINUE
*
* Update the left singular vector matrix.
*
IF( K.EQ.2 ) THEN
CALL SGEMM( 'N', 'N', N, K, K, ONE, U2, LDU2, Q, LDQ, ZERO, U,
$ LDU )
GO TO 100
END IF
IF( CTOT( 1 ).GT.0 ) THEN
CALL SGEMM( 'N', 'N', NL, K, CTOT( 1 ), ONE, U2( 1, 2 ), LDU2,
$ Q( 2, 1 ), LDQ, ZERO, U( 1, 1 ), LDU )
IF( CTOT( 3 ).GT.0 ) THEN
KTEMP = 2 + CTOT( 1 ) + CTOT( 2 )
CALL SGEMM( 'N', 'N', NL, K, CTOT( 3 ), ONE, U2( 1, KTEMP ),
$ LDU2, Q( KTEMP, 1 ), LDQ, ONE, U( 1, 1 ), LDU )
END IF
ELSE IF( CTOT( 3 ).GT.0 ) THEN
KTEMP = 2 + CTOT( 1 ) + CTOT( 2 )
CALL SGEMM( 'N', 'N', NL, K, CTOT( 3 ), ONE, U2( 1, KTEMP ),
$ LDU2, Q( KTEMP, 1 ), LDQ, ZERO, U( 1, 1 ), LDU )
ELSE
CALL SLACPY( 'F', NL, K, U2, LDU2, U, LDU )
END IF
CALL SCOPY( K, Q( 1, 1 ), LDQ, U( NLP1, 1 ), LDU )
KTEMP = 2 + CTOT( 1 )
CTEMP = CTOT( 2 ) + CTOT( 3 )
CALL SGEMM( 'N', 'N', NR, K, CTEMP, ONE, U2( NLP2, KTEMP ), LDU2,
$ Q( KTEMP, 1 ), LDQ, ZERO, U( NLP2, 1 ), LDU )
*
* Generate the right singular vectors.
*
100 CONTINUE
DO 120 I = 1, K
TEMP = SNRM2( K, VT( 1, I ), 1 )
Q( I, 1 ) = VT( 1, I ) / TEMP
DO 110 J = 2, K
JC = IDXC( J )
Q( I, J ) = VT( JC, I ) / TEMP
110 CONTINUE
120 CONTINUE
*
* Update the right singular vector matrix.
*
IF( K.EQ.2 ) THEN
CALL SGEMM( 'N', 'N', K, M, K, ONE, Q, LDQ, VT2, LDVT2, ZERO,
$ VT, LDVT )
RETURN
END IF
KTEMP = 1 + CTOT( 1 )
CALL SGEMM( 'N', 'N', K, NLP1, KTEMP, ONE, Q( 1, 1 ), LDQ,
$ VT2( 1, 1 ), LDVT2, ZERO, VT( 1, 1 ), LDVT )
KTEMP = 2 + CTOT( 1 ) + CTOT( 2 )
IF( KTEMP.LE.LDVT2 )
$ CALL SGEMM( 'N', 'N', K, NLP1, CTOT( 3 ), ONE, Q( 1, KTEMP ),
$ LDQ, VT2( KTEMP, 1 ), LDVT2, ONE, VT( 1, 1 ),
$ LDVT )
*
KTEMP = CTOT( 1 ) + 1
NRP1 = NR + SQRE
IF( KTEMP.GT.1 ) THEN
DO 130 I = 1, K
Q( I, KTEMP ) = Q( I, 1 )
130 CONTINUE
DO 140 I = NLP2, M
VT2( KTEMP, I ) = VT2( 1, I )
140 CONTINUE
END IF
CTEMP = 1 + CTOT( 2 ) + CTOT( 3 )
CALL SGEMM( 'N', 'N', K, NRP1, CTEMP, ONE, Q( 1, KTEMP ), LDQ,
$ VT2( KTEMP, NLP2 ), LDVT2, ZERO, VT( 1, NLP2 ), LDVT )
*
RETURN
*
* End of SLASD3
*
END
SUBROUTINE SLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER I, INFO, N
REAL RHO, SIGMA
* ..
* .. Array Arguments ..
REAL D( * ), DELTA( * ), WORK( * ), Z( * )
* ..
*
* Purpose
* =======
*
* This subroutine computes the square root of the I-th updated
* eigenvalue of a positive symmetric rank-one modification to
* a positive diagonal matrix whose entries are given as the squares
* of the corresponding entries in the array d, and that
*
* 0 <= D(i) < D(j) for i < j
*
* and that RHO > 0. This is arranged by the calling routine, and is
* no loss in generality. The rank-one modified system is thus
*
* diag( D ) * diag( D ) + RHO * Z * Z_transpose.
*
* where we assume the Euclidean norm of Z is 1.
*
* The method consists of approximating the rational functions in the
* secular equation by simpler interpolating rational functions.
*
* Arguments
* =========
*
* N (input) INTEGER
* The length of all arrays.
*
* I (input) INTEGER
* The index of the eigenvalue to be computed. 1 <= I <= N.
*
* D (input) REAL array, dimension ( N )
* The original eigenvalues. It is assumed that they are in
* order, 0 <= D(I) < D(J) for I < J.
*
* Z (input) REAL array, dimension (N)
* The components of the updating vector.
*
* DELTA (output) REAL array, dimension (N)
* If N .ne. 1, DELTA contains (D(j) - sigma_I) in its j-th
* component. If N = 1, then DELTA(1) = 1. The vector DELTA
* contains the information necessary to construct the
* (singular) eigenvectors.
*
* RHO (input) REAL
* The scalar in the symmetric updating formula.
*
* SIGMA (output) REAL
* The computed sigma_I, the I-th updated eigenvalue.
*
* WORK (workspace) REAL array, dimension (N)
* If N .ne. 1, WORK contains (D(j) + sigma_I) in its j-th
* component. If N = 1, then WORK( 1 ) = 1.
*
* INFO (output) INTEGER
* = 0: successful exit
* > 0: if INFO = 1, the updating process failed.
*
* Internal Parameters
* ===================
*
* Logical variable ORGATI (origin-at-i?) is used for distinguishing
* whether D(i) or D(i+1) is treated as the origin.
*
* ORGATI = .true. origin at i
* ORGATI = .false. origin at i+1
*
* Logical variable SWTCH3 (switch-for-3-poles?) is for noting
* if we are working with THREE poles!
*
* MAXIT is the maximum number of iterations allowed for each
* eigenvalue.
*
* Further Details
* ===============
*
* Based on contributions by
* Ren-Cang Li, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXIT
PARAMETER ( MAXIT = 20 )
REAL ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0,
$ THREE = 3.0E+0, FOUR = 4.0E+0, EIGHT = 8.0E+0,
$ TEN = 10.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL ORGATI, SWTCH, SWTCH3
INTEGER II, IIM1, IIP1, IP1, ITER, J, NITER
REAL A, B, C, DELSQ, DELSQ2, DPHI, DPSI, DTIIM,
$ DTIIP, DTIPSQ, DTISQ, DTNSQ, DTNSQ1, DW, EPS,
$ ERRETM, ETA, PHI, PREW, PSI, RHOINV, SG2LB,
$ SG2UB, TAU, TEMP, TEMP1, TEMP2, W
* ..
* .. Local Arrays ..
REAL DD( 3 ), ZZ( 3 )
* ..
* .. External Subroutines ..
EXTERNAL SLAED6, SLASD5
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Since this routine is called in an inner loop, we do no argument
* checking.
*
* Quick return for N=1 and 2.
*
INFO = 0
IF( N.EQ.1 ) THEN
*
* Presumably, I=1 upon entry
*
SIGMA = SQRT( D( 1 )*D( 1 )+RHO*Z( 1 )*Z( 1 ) )
DELTA( 1 ) = ONE
WORK( 1 ) = ONE
RETURN
END IF
IF( N.EQ.2 ) THEN
CALL SLASD5( I, D, Z, DELTA, RHO, SIGMA, WORK )
RETURN
END IF
*
* Compute machine epsilon
*
EPS = SLAMCH( 'Epsilon' )
RHOINV = ONE / RHO
*
* The case I = N
*
IF( I.EQ.N ) THEN
*
* Initialize some basic variables
*
II = N - 1
NITER = 1
*
* Calculate initial guess
*
TEMP = RHO / TWO
*
* If ||Z||_2 is not one, then TEMP should be set to
* RHO * ||Z||_2^2 / TWO
*
TEMP1 = TEMP / ( D( N )+SQRT( D( N )*D( N )+TEMP ) )
DO 10 J = 1, N
WORK( J ) = D( J ) + D( N ) + TEMP1
DELTA( J ) = ( D( J )-D( N ) ) - TEMP1
10 CONTINUE
*
PSI = ZERO
DO 20 J = 1, N - 2
PSI = PSI + Z( J )*Z( J ) / ( DELTA( J )*WORK( J ) )
20 CONTINUE
*
C = RHOINV + PSI
W = C + Z( II )*Z( II ) / ( DELTA( II )*WORK( II ) ) +
$ Z( N )*Z( N ) / ( DELTA( N )*WORK( N ) )
*
IF( W.LE.ZERO ) THEN
TEMP1 = SQRT( D( N )*D( N )+RHO )
TEMP = Z( N-1 )*Z( N-1 ) / ( ( D( N-1 )+TEMP1 )*
$ ( D( N )-D( N-1 )+RHO / ( D( N )+TEMP1 ) ) ) +
$ Z( N )*Z( N ) / RHO
*
* The following TAU is to approximate
* SIGMA_n^2 - D( N )*D( N )
*
IF( C.LE.TEMP ) THEN
TAU = RHO
ELSE
DELSQ = ( D( N )-D( N-1 ) )*( D( N )+D( N-1 ) )
A = -C*DELSQ + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
B = Z( N )*Z( N )*DELSQ
IF( A.LT.ZERO ) THEN
TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
ELSE
TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
END IF
END IF
*
* It can be proved that
* D(N)^2+RHO/2 <= SIGMA_n^2 < D(N)^2+TAU <= D(N)^2+RHO
*
ELSE
DELSQ = ( D( N )-D( N-1 ) )*( D( N )+D( N-1 ) )
A = -C*DELSQ + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
B = Z( N )*Z( N )*DELSQ
*
* The following TAU is to approximate
* SIGMA_n^2 - D( N )*D( N )
*
IF( A.LT.ZERO ) THEN
TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
ELSE
TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
END IF
*
* It can be proved that
* D(N)^2 < D(N)^2+TAU < SIGMA(N)^2 < D(N)^2+RHO/2
*
END IF
*
* The following ETA is to approximate SIGMA_n - D( N )
*
ETA = TAU / ( D( N )+SQRT( D( N )*D( N )+TAU ) )
*
SIGMA = D( N ) + ETA
DO 30 J = 1, N
DELTA( J ) = ( D( J )-D( I ) ) - ETA
WORK( J ) = D( J ) + D( I ) + ETA
30 CONTINUE
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 40 J = 1, II
TEMP = Z( J ) / ( DELTA( J )*WORK( J ) )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
40 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
TEMP = Z( N ) / ( DELTA( N )*WORK( N ) )
PHI = Z( N )*TEMP
DPHI = TEMP*TEMP
ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
$ ABS( TAU )*( DPSI+DPHI )
*
W = RHOINV + PHI + PSI
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
GO TO 240
END IF
*
* Calculate the new step
*
NITER = NITER + 1
DTNSQ1 = WORK( N-1 )*DELTA( N-1 )
DTNSQ = WORK( N )*DELTA( N )
C = W - DTNSQ1*DPSI - DTNSQ*DPHI
A = ( DTNSQ+DTNSQ1 )*W - DTNSQ*DTNSQ1*( DPSI+DPHI )
B = DTNSQ*DTNSQ1*W
IF( C.LT.ZERO )
$ C = ABS( C )
IF( C.EQ.ZERO ) THEN
ETA = RHO - SIGMA*SIGMA
ELSE IF( A.GE.ZERO ) THEN
ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
IF( W*ETA.GT.ZERO )
$ ETA = -W / ( DPSI+DPHI )
TEMP = ETA - DTNSQ
IF( TEMP.GT.RHO )
$ ETA = RHO + DTNSQ
*
TAU = TAU + ETA
ETA = ETA / ( SIGMA+SQRT( ETA+SIGMA*SIGMA ) )
DO 50 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
WORK( J ) = WORK( J ) + ETA
50 CONTINUE
*
SIGMA = SIGMA + ETA
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 60 J = 1, II
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
60 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
TEMP = Z( N ) / ( WORK( N )*DELTA( N ) )
PHI = Z( N )*TEMP
DPHI = TEMP*TEMP
ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
$ ABS( TAU )*( DPSI+DPHI )
*
W = RHOINV + PHI + PSI
*
* Main loop to update the values of the array DELTA
*
ITER = NITER + 1
*
DO 90 NITER = ITER, MAXIT
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
GO TO 240
END IF
*
* Calculate the new step
*
DTNSQ1 = WORK( N-1 )*DELTA( N-1 )
DTNSQ = WORK( N )*DELTA( N )
C = W - DTNSQ1*DPSI - DTNSQ*DPHI
A = ( DTNSQ+DTNSQ1 )*W - DTNSQ1*DTNSQ*( DPSI+DPHI )
B = DTNSQ1*DTNSQ*W
IF( A.GE.ZERO ) THEN
ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
IF( W*ETA.GT.ZERO )
$ ETA = -W / ( DPSI+DPHI )
TEMP = ETA - DTNSQ
IF( TEMP.LE.ZERO )
$ ETA = ETA / TWO
*
TAU = TAU + ETA
ETA = ETA / ( SIGMA+SQRT( ETA+SIGMA*SIGMA ) )
DO 70 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
WORK( J ) = WORK( J ) + ETA
70 CONTINUE
*
SIGMA = SIGMA + ETA
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 80 J = 1, II
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
80 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
TEMP = Z( N ) / ( WORK( N )*DELTA( N ) )
PHI = Z( N )*TEMP
DPHI = TEMP*TEMP
ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
$ ABS( TAU )*( DPSI+DPHI )
*
W = RHOINV + PHI + PSI
90 CONTINUE
*
* Return with INFO = 1, NITER = MAXIT and not converged
*
INFO = 1
GO TO 240
*
* End for the case I = N
*
ELSE
*
* The case for I < N
*
NITER = 1
IP1 = I + 1
*
* Calculate initial guess
*
DELSQ = ( D( IP1 )-D( I ) )*( D( IP1 )+D( I ) )
DELSQ2 = DELSQ / TWO
TEMP = DELSQ2 / ( D( I )+SQRT( D( I )*D( I )+DELSQ2 ) )
DO 100 J = 1, N
WORK( J ) = D( J ) + D( I ) + TEMP
DELTA( J ) = ( D( J )-D( I ) ) - TEMP
100 CONTINUE
*
PSI = ZERO
DO 110 J = 1, I - 1
PSI = PSI + Z( J )*Z( J ) / ( WORK( J )*DELTA( J ) )
110 CONTINUE
*
PHI = ZERO
DO 120 J = N, I + 2, -1
PHI = PHI + Z( J )*Z( J ) / ( WORK( J )*DELTA( J ) )
120 CONTINUE
C = RHOINV + PSI + PHI
W = C + Z( I )*Z( I ) / ( WORK( I )*DELTA( I ) ) +
$ Z( IP1 )*Z( IP1 ) / ( WORK( IP1 )*DELTA( IP1 ) )
*
IF( W.GT.ZERO ) THEN
*
* d(i)^2 < the ith sigma^2 < (d(i)^2+d(i+1)^2)/2
*
* We choose d(i) as origin.
*
ORGATI = .TRUE.
SG2LB = ZERO
SG2UB = DELSQ2
A = C*DELSQ + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 )
B = Z( I )*Z( I )*DELSQ
IF( A.GT.ZERO ) THEN
TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
ELSE
TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
END IF
*
* TAU now is an estimation of SIGMA^2 - D( I )^2. The
* following, however, is the corresponding estimation of
* SIGMA - D( I ).
*
ETA = TAU / ( D( I )+SQRT( D( I )*D( I )+TAU ) )
ELSE
*
* (d(i)^2+d(i+1)^2)/2 <= the ith sigma^2 < d(i+1)^2/2
*
* We choose d(i+1) as origin.
*
ORGATI = .FALSE.
SG2LB = -DELSQ2
SG2UB = ZERO
A = C*DELSQ - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 )
B = Z( IP1 )*Z( IP1 )*DELSQ
IF( A.LT.ZERO ) THEN
TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) )
ELSE
TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C )
END IF
*
* TAU now is an estimation of SIGMA^2 - D( IP1 )^2. The
* following, however, is the corresponding estimation of
* SIGMA - D( IP1 ).
*
ETA = TAU / ( D( IP1 )+SQRT( ABS( D( IP1 )*D( IP1 )+
$ TAU ) ) )
END IF
*
IF( ORGATI ) THEN
II = I
SIGMA = D( I ) + ETA
DO 130 J = 1, N
WORK( J ) = D( J ) + D( I ) + ETA
DELTA( J ) = ( D( J )-D( I ) ) - ETA
130 CONTINUE
ELSE
II = I + 1
SIGMA = D( IP1 ) + ETA
DO 140 J = 1, N
WORK( J ) = D( J ) + D( IP1 ) + ETA
DELTA( J ) = ( D( J )-D( IP1 ) ) - ETA
140 CONTINUE
END IF
IIM1 = II - 1
IIP1 = II + 1
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 150 J = 1, IIM1
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
150 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
DPHI = ZERO
PHI = ZERO
DO 160 J = N, IIP1, -1
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PHI = PHI + Z( J )*TEMP
DPHI = DPHI + TEMP*TEMP
ERRETM = ERRETM + PHI
160 CONTINUE
*
W = RHOINV + PHI + PSI
*
* W is the value of the secular function with
* its ii-th element removed.
*
SWTCH3 = .FALSE.
IF( ORGATI ) THEN
IF( W.LT.ZERO )
$ SWTCH3 = .TRUE.
ELSE
IF( W.GT.ZERO )
$ SWTCH3 = .TRUE.
END IF
IF( II.EQ.1 .OR. II.EQ.N )
$ SWTCH3 = .FALSE.
*
TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
DW = DPSI + DPHI + TEMP*TEMP
TEMP = Z( II )*TEMP
W = W + TEMP
ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
$ THREE*ABS( TEMP ) + ABS( TAU )*DW
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
GO TO 240
END IF
*
IF( W.LE.ZERO ) THEN
SG2LB = MAX( SG2LB, TAU )
ELSE
SG2UB = MIN( SG2UB, TAU )
END IF
*
* Calculate the new step
*
NITER = NITER + 1
IF( .NOT.SWTCH3 ) THEN
DTIPSQ = WORK( IP1 )*DELTA( IP1 )
DTISQ = WORK( I )*DELTA( I )
IF( ORGATI ) THEN
C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2
ELSE
C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2
END IF
A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW
B = DTIPSQ*DTISQ*W
IF( C.EQ.ZERO ) THEN
IF( A.EQ.ZERO ) THEN
IF( ORGATI ) THEN
A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ*( DPSI+DPHI )
ELSE
A = Z( IP1 )*Z( IP1 ) + DTISQ*DTISQ*( DPSI+DPHI )
END IF
END IF
ETA = B / A
ELSE IF( A.LE.ZERO ) THEN
ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
ELSE
*
* Interpolation using THREE most relevant poles
*
DTIIM = WORK( IIM1 )*DELTA( IIM1 )
DTIIP = WORK( IIP1 )*DELTA( IIP1 )
TEMP = RHOINV + PSI + PHI
IF( ORGATI ) THEN
TEMP1 = Z( IIM1 ) / DTIIM
TEMP1 = TEMP1*TEMP1
C = ( TEMP - DTIIP*( DPSI+DPHI ) ) -
$ ( D( IIM1 )-D( IIP1 ) )*( D( IIM1 )+D( IIP1 ) )*TEMP1
ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
IF( DPSI.LT.TEMP1 ) THEN
ZZ( 3 ) = DTIIP*DTIIP*DPHI
ELSE
ZZ( 3 ) = DTIIP*DTIIP*( ( DPSI-TEMP1 )+DPHI )
END IF
ELSE
TEMP1 = Z( IIP1 ) / DTIIP
TEMP1 = TEMP1*TEMP1
C = ( TEMP - DTIIM*( DPSI+DPHI ) ) -
$ ( D( IIP1 )-D( IIM1 ) )*( D( IIM1 )+D( IIP1 ) )*TEMP1
IF( DPHI.LT.TEMP1 ) THEN
ZZ( 1 ) = DTIIM*DTIIM*DPSI
ELSE
ZZ( 1 ) = DTIIM*DTIIM*( DPSI+( DPHI-TEMP1 ) )
END IF
ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
END IF
ZZ( 2 ) = Z( II )*Z( II )
DD( 1 ) = DTIIM
DD( 2 ) = DELTA( II )*WORK( II )
DD( 3 ) = DTIIP
CALL SLAED6( NITER, ORGATI, C, DD, ZZ, W, ETA, INFO )
IF( INFO.NE.0 )
$ GO TO 240
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
IF( W*ETA.GE.ZERO )
$ ETA = -W / DW
IF( ORGATI ) THEN
TEMP1 = WORK( I )*DELTA( I )
TEMP = ETA - TEMP1
ELSE
TEMP1 = WORK( IP1 )*DELTA( IP1 )
TEMP = ETA - TEMP1
END IF
IF( TEMP.GT.SG2UB .OR. TEMP.LT.SG2LB ) THEN
IF( W.LT.ZERO ) THEN
ETA = ( SG2UB-TAU ) / TWO
ELSE
ETA = ( SG2LB-TAU ) / TWO
END IF
END IF
*
TAU = TAU + ETA
ETA = ETA / ( SIGMA+SQRT( SIGMA*SIGMA+ETA ) )
*
PREW = W
*
SIGMA = SIGMA + ETA
DO 170 J = 1, N
WORK( J ) = WORK( J ) + ETA
DELTA( J ) = DELTA( J ) - ETA
170 CONTINUE
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 180 J = 1, IIM1
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
180 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
DPHI = ZERO
PHI = ZERO
DO 190 J = N, IIP1, -1
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PHI = PHI + Z( J )*TEMP
DPHI = DPHI + TEMP*TEMP
ERRETM = ERRETM + PHI
190 CONTINUE
*
TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
DW = DPSI + DPHI + TEMP*TEMP
TEMP = Z( II )*TEMP
W = RHOINV + PHI + PSI + TEMP
ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
$ THREE*ABS( TEMP ) + ABS( TAU )*DW
*
IF( W.LE.ZERO ) THEN
SG2LB = MAX( SG2LB, TAU )
ELSE
SG2UB = MIN( SG2UB, TAU )
END IF
*
SWTCH = .FALSE.
IF( ORGATI ) THEN
IF( -W.GT.ABS( PREW ) / TEN )
$ SWTCH = .TRUE.
ELSE
IF( W.GT.ABS( PREW ) / TEN )
$ SWTCH = .TRUE.
END IF
*
* Main loop to update the values of the array DELTA and WORK
*
ITER = NITER + 1
*
DO 230 NITER = ITER, MAXIT
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
GO TO 240
END IF
*
* Calculate the new step
*
IF( .NOT.SWTCH3 ) THEN
DTIPSQ = WORK( IP1 )*DELTA( IP1 )
DTISQ = WORK( I )*DELTA( I )
IF( .NOT.SWTCH ) THEN
IF( ORGATI ) THEN
C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2
ELSE
C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2
END IF
ELSE
TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
IF( ORGATI ) THEN
DPSI = DPSI + TEMP*TEMP
ELSE
DPHI = DPHI + TEMP*TEMP
END IF
C = W - DTISQ*DPSI - DTIPSQ*DPHI
END IF
A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW
B = DTIPSQ*DTISQ*W
IF( C.EQ.ZERO ) THEN
IF( A.EQ.ZERO ) THEN
IF( .NOT.SWTCH ) THEN
IF( ORGATI ) THEN
A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ*
$ ( DPSI+DPHI )
ELSE
A = Z( IP1 )*Z( IP1 ) +
$ DTISQ*DTISQ*( DPSI+DPHI )
END IF
ELSE
A = DTISQ*DTISQ*DPSI + DTIPSQ*DTIPSQ*DPHI
END IF
END IF
ETA = B / A
ELSE IF( A.LE.ZERO ) THEN
ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
ELSE
*
* Interpolation using THREE most relevant poles
*
DTIIM = WORK( IIM1 )*DELTA( IIM1 )
DTIIP = WORK( IIP1 )*DELTA( IIP1 )
TEMP = RHOINV + PSI + PHI
IF( SWTCH ) THEN
C = TEMP - DTIIM*DPSI - DTIIP*DPHI
ZZ( 1 ) = DTIIM*DTIIM*DPSI
ZZ( 3 ) = DTIIP*DTIIP*DPHI
ELSE
IF( ORGATI ) THEN
TEMP1 = Z( IIM1 ) / DTIIM
TEMP1 = TEMP1*TEMP1
TEMP2 = ( D( IIM1 )-D( IIP1 ) )*
$ ( D( IIM1 )+D( IIP1 ) )*TEMP1
C = TEMP - DTIIP*( DPSI+DPHI ) - TEMP2
ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
IF( DPSI.LT.TEMP1 ) THEN
ZZ( 3 ) = DTIIP*DTIIP*DPHI
ELSE
ZZ( 3 ) = DTIIP*DTIIP*( ( DPSI-TEMP1 )+DPHI )
END IF
ELSE
TEMP1 = Z( IIP1 ) / DTIIP
TEMP1 = TEMP1*TEMP1
TEMP2 = ( D( IIP1 )-D( IIM1 ) )*
$ ( D( IIM1 )+D( IIP1 ) )*TEMP1
C = TEMP - DTIIM*( DPSI+DPHI ) - TEMP2
IF( DPHI.LT.TEMP1 ) THEN
ZZ( 1 ) = DTIIM*DTIIM*DPSI
ELSE
ZZ( 1 ) = DTIIM*DTIIM*( DPSI+( DPHI-TEMP1 ) )
END IF
ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
END IF
END IF
DD( 1 ) = DTIIM
DD( 2 ) = DELTA( II )*WORK( II )
DD( 3 ) = DTIIP
CALL SLAED6( NITER, ORGATI, C, DD, ZZ, W, ETA, INFO )
IF( INFO.NE.0 )
$ GO TO 240
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
IF( W*ETA.GE.ZERO )
$ ETA = -W / DW
IF( ORGATI ) THEN
TEMP1 = WORK( I )*DELTA( I )
TEMP = ETA - TEMP1
ELSE
TEMP1 = WORK( IP1 )*DELTA( IP1 )
TEMP = ETA - TEMP1
END IF
IF( TEMP.GT.SG2UB .OR. TEMP.LT.SG2LB ) THEN
IF( W.LT.ZERO ) THEN
ETA = ( SG2UB-TAU ) / TWO
ELSE
ETA = ( SG2LB-TAU ) / TWO
END IF
END IF
*
TAU = TAU + ETA
ETA = ETA / ( SIGMA+SQRT( SIGMA*SIGMA+ETA ) )
*
SIGMA = SIGMA + ETA
DO 200 J = 1, N
WORK( J ) = WORK( J ) + ETA
DELTA( J ) = DELTA( J ) - ETA
200 CONTINUE
*
PREW = W
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 210 J = 1, IIM1
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
210 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
DPHI = ZERO
PHI = ZERO
DO 220 J = N, IIP1, -1
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PHI = PHI + Z( J )*TEMP
DPHI = DPHI + TEMP*TEMP
ERRETM = ERRETM + PHI
220 CONTINUE
*
TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
DW = DPSI + DPHI + TEMP*TEMP
TEMP = Z( II )*TEMP
W = RHOINV + PHI + PSI + TEMP
ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
$ THREE*ABS( TEMP ) + ABS( TAU )*DW
IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN )
$ SWTCH = .NOT.SWTCH
*
IF( W.LE.ZERO ) THEN
SG2LB = MAX( SG2LB, TAU )
ELSE
SG2UB = MIN( SG2UB, TAU )
END IF
*
230 CONTINUE
*
* Return with INFO = 1, NITER = MAXIT and not converged
*
INFO = 1
*
END IF
*
240 CONTINUE
RETURN
*
* End of SLASD4
*
END
SUBROUTINE SLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER I
REAL DSIGMA, RHO
* ..
* .. Array Arguments ..
REAL D( 2 ), DELTA( 2 ), WORK( 2 ), Z( 2 )
* ..
*
* Purpose
* =======
*
* This subroutine computes the square root of the I-th eigenvalue
* of a positive symmetric rank-one modification of a 2-by-2 diagonal
* matrix
*
* diag( D ) * diag( D ) + RHO * Z * transpose(Z) .
*
* The diagonal entries in the array D are assumed to satisfy
*
* 0 <= D(i) < D(j) for i < j .
*
* We also assume RHO > 0 and that the Euclidean norm of the vector
* Z is one.
*
* Arguments
* =========
*
* I (input) INTEGER
* The index of the eigenvalue to be computed. I = 1 or I = 2.
*
* D (input) REAL array, dimension (2)
* The original eigenvalues. We assume 0 <= D(1) < D(2).
*
* Z (input) REAL array, dimension (2)
* The components of the updating vector.
*
* DELTA (output) REAL array, dimension (2)
* Contains (D(j) - sigma_I) in its j-th component.
* The vector DELTA contains the information necessary
* to construct the eigenvectors.
*
* RHO (input) REAL
* The scalar in the symmetric updating formula.
*
* DSIGMA (output) REAL
* The computed sigma_I, the I-th updated eigenvalue.
*
* WORK (workspace) REAL array, dimension (2)
* WORK contains (D(j) + sigma_I) in its j-th component.
*
* Further Details
* ===============
*
* Based on contributions by
* Ren-Cang Li, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO, THREE, FOUR
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0,
$ THREE = 3.0E+0, FOUR = 4.0E+0 )
* ..
* .. Local Scalars ..
REAL B, C, DEL, DELSQ, TAU, W
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SQRT
* ..
* .. Executable Statements ..
*
DEL = D( 2 ) - D( 1 )
DELSQ = DEL*( D( 2 )+D( 1 ) )
IF( I.EQ.1 ) THEN
W = ONE + FOUR*RHO*( Z( 2 )*Z( 2 ) / ( D( 1 )+THREE*D( 2 ) )-
$ Z( 1 )*Z( 1 ) / ( THREE*D( 1 )+D( 2 ) ) ) / DEL
IF( W.GT.ZERO ) THEN
B = DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
C = RHO*Z( 1 )*Z( 1 )*DELSQ
*
* B > ZERO, always
*
* The following TAU is DSIGMA * DSIGMA - D( 1 ) * D( 1 )
*
TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) )
*
* The following TAU is DSIGMA - D( 1 )
*
TAU = TAU / ( D( 1 )+SQRT( D( 1 )*D( 1 )+TAU ) )
DSIGMA = D( 1 ) + TAU
DELTA( 1 ) = -TAU
DELTA( 2 ) = DEL - TAU
WORK( 1 ) = TWO*D( 1 ) + TAU
WORK( 2 ) = ( D( 1 )+TAU ) + D( 2 )
* DELTA( 1 ) = -Z( 1 ) / TAU
* DELTA( 2 ) = Z( 2 ) / ( DEL-TAU )
ELSE
B = -DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
C = RHO*Z( 2 )*Z( 2 )*DELSQ
*
* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 )
*
IF( B.GT.ZERO ) THEN
TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) )
ELSE
TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO
END IF
*
* The following TAU is DSIGMA - D( 2 )
*
TAU = TAU / ( D( 2 )+SQRT( ABS( D( 2 )*D( 2 )+TAU ) ) )
DSIGMA = D( 2 ) + TAU
DELTA( 1 ) = -( DEL+TAU )
DELTA( 2 ) = -TAU
WORK( 1 ) = D( 1 ) + TAU + D( 2 )
WORK( 2 ) = TWO*D( 2 ) + TAU
* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
* DELTA( 2 ) = -Z( 2 ) / TAU
END IF
* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
* DELTA( 1 ) = DELTA( 1 ) / TEMP
* DELTA( 2 ) = DELTA( 2 ) / TEMP
ELSE
*
* Now I=2
*
B = -DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
C = RHO*Z( 2 )*Z( 2 )*DELSQ
*
* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 )
*
IF( B.GT.ZERO ) THEN
TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO
ELSE
TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) )
END IF
*
* The following TAU is DSIGMA - D( 2 )
*
TAU = TAU / ( D( 2 )+SQRT( D( 2 )*D( 2 )+TAU ) )
DSIGMA = D( 2 ) + TAU
DELTA( 1 ) = -( DEL+TAU )
DELTA( 2 ) = -TAU
WORK( 1 ) = D( 1 ) + TAU + D( 2 )
WORK( 2 ) = TWO*D( 2 ) + TAU
* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
* DELTA( 2 ) = -Z( 2 ) / TAU
* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
* DELTA( 1 ) = DELTA( 1 ) / TEMP
* DELTA( 2 ) = DELTA( 2 ) / TEMP
END IF
RETURN
*
* End of SLASD5
*
END
SUBROUTINE SLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA,
$ IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM,
$ LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK,
$ IWORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL,
$ NR, SQRE
REAL ALPHA, BETA, C, S
* ..
* .. Array Arguments ..
INTEGER GIVCOL( LDGCOL, * ), IDXQ( * ), IWORK( * ),
$ PERM( * )
REAL D( * ), DIFL( * ), DIFR( * ),
$ GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ),
$ VF( * ), VL( * ), WORK( * ), Z( * )
* ..
*
* Purpose
* =======
*
* SLASD6 computes the SVD of an updated upper bidiagonal matrix B
* obtained by merging two smaller ones by appending a row. This
* routine is used only for the problem which requires all singular
* values and optionally singular vector matrices in factored form.
* B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE.
* A related subroutine, SLASD1, handles the case in which all singular
* values and singular vectors of the bidiagonal matrix are desired.
*
* SLASD6 computes the SVD as follows:
*
* ( D1(in) 0 0 0 )
* B = U(in) * ( Z1' a Z2' b ) * VT(in)
* ( 0 0 D2(in) 0 )
*
* = U(out) * ( D(out) 0) * VT(out)
*
* where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M
* with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros
* elsewhere; and the entry b is empty if SQRE = 0.
*
* The singular values of B can be computed using D1, D2, the first
* components of all the right singular vectors of the lower block, and
* the last components of all the right singular vectors of the upper
* block. These components are stored and updated in VF and VL,
* respectively, in SLASD6. Hence U and VT are not explicitly
* referenced.
*
* The singular values are stored in D. The algorithm consists of two
* stages:
*
* The first stage consists of deflating the size of the problem
* when there are multiple singular values or if there is a zero
* in the Z vector. For each such occurence the dimension of the
* secular equation problem is reduced by one. This stage is
* performed by the routine SLASD7.
*
* The second stage consists of calculating the updated
* singular values. This is done by finding the roots of the
* secular equation via the routine SLASD4 (as called by SLASD8).
* This routine also updates VF and VL and computes the distances
* between the updated singular values and the old singular
* values.
*
* SLASD6 is called from SLASDA.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* Specifies whether singular vectors are to be computed in
* factored form:
* = 0: Compute singular values only.
* = 1: Compute singular vectors in factored form as well.
*
* NL (input) INTEGER
* The row dimension of the upper block. NL >= 1.
*
* NR (input) INTEGER
* The row dimension of the lower block. NR >= 1.
*
* SQRE (input) INTEGER
* = 0: the lower block is an NR-by-NR square matrix.
* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
*
* The bidiagonal matrix has row dimension N = NL + NR + 1,
* and column dimension M = N + SQRE.
*
* D (input/output) REAL array, dimension (NL+NR+1).
* On entry D(1:NL,1:NL) contains the singular values of the
* upper block, and D(NL+2:N) contains the singular values
* of the lower block. On exit D(1:N) contains the singular
* values of the modified matrix.
*
* VF (input/output) REAL array, dimension (M)
* On entry, VF(1:NL+1) contains the first components of all
* right singular vectors of the upper block; and VF(NL+2:M)
* contains the first components of all right singular vectors
* of the lower block. On exit, VF contains the first components
* of all right singular vectors of the bidiagonal matrix.
*
* VL (input/output) REAL array, dimension (M)
* On entry, VL(1:NL+1) contains the last components of all
* right singular vectors of the upper block; and VL(NL+2:M)
* contains the last components of all right singular vectors of
* the lower block. On exit, VL contains the last components of
* all right singular vectors of the bidiagonal matrix.
*
* ALPHA (input/output) REAL
* Contains the diagonal element associated with the added row.
*
* BETA (input/output) REAL
* Contains the off-diagonal element associated with the added
* row.
*
* IDXQ (output) INTEGER array, dimension (N)
* This contains the permutation which will reintegrate the
* subproblem just solved back into sorted order, i.e.
* D( IDXQ( I = 1, N ) ) will be in ascending order.
*
* PERM (output) INTEGER array, dimension ( N )
* The permutations (from deflation and sorting) to be applied
* to each block. Not referenced if ICOMPQ = 0.
*
* GIVPTR (output) INTEGER
* The number of Givens rotations which took place in this
* subproblem. Not referenced if ICOMPQ = 0.
*
* GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )
* Each pair of numbers indicates a pair of columns to take place
* in a Givens rotation. Not referenced if ICOMPQ = 0.
*
* LDGCOL (input) INTEGER
* leading dimension of GIVCOL, must be at least N.
*
* GIVNUM (output) REAL array, dimension ( LDGNUM, 2 )
* Each number indicates the C or S value to be used in the
* corresponding Givens rotation. Not referenced if ICOMPQ = 0.
*
* LDGNUM (input) INTEGER
* The leading dimension of GIVNUM and POLES, must be at least N.
*
* POLES (output) REAL array, dimension ( LDGNUM, 2 )
* On exit, POLES(1,*) is an array containing the new singular
* values obtained from solving the secular equation, and
* POLES(2,*) is an array containing the poles in the secular
* equation. Not referenced if ICOMPQ = 0.
*
* DIFL (output) REAL array, dimension ( N )
* On exit, DIFL(I) is the distance between I-th updated
* (undeflated) singular value and the I-th (undeflated) old
* singular value.
*
* DIFR (output) REAL array,
* dimension ( LDGNUM, 2 ) if ICOMPQ = 1 and
* dimension ( N ) if ICOMPQ = 0.
* On exit, DIFR(I, 1) is the distance between I-th updated
* (undeflated) singular value and the I+1-th (undeflated) old
* singular value.
*
* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the
* normalizing factors for the right singular vector matrix.
*
* See SLASD8 for details on DIFL and DIFR.
*
* Z (output) REAL array, dimension ( M )
* The first elements of this array contain the components
* of the deflation-adjusted updating row vector.
*
* K (output) INTEGER
* Contains the dimension of the non-deflated matrix,
* This is the order of the related secular equation. 1 <= K <=N.
*
* C (output) REAL
* C contains garbage if SQRE =0 and the C-value of a Givens
* rotation related to the right null space if SQRE = 1.
*
* S (output) REAL
* S contains garbage if SQRE =0 and the S-value of a Givens
* rotation related to the right null space if SQRE = 1.
*
* WORK (workspace) REAL array, dimension ( 4 * M )
*
* IWORK (workspace) INTEGER array, dimension ( 3 * N )
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an singular value did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, IDX, IDXC, IDXP, ISIGMA, IVFW, IVLW, IW, M,
$ N, N1, N2
REAL ORGNRM
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLAMRG, SLASCL, SLASD7, SLASD8, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
N = NL + NR + 1
M = N + SQRE
*
IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
INFO = -1
ELSE IF( NL.LT.1 ) THEN
INFO = -2
ELSE IF( NR.LT.1 ) THEN
INFO = -3
ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
INFO = -4
ELSE IF( LDGCOL.LT.N ) THEN
INFO = -14
ELSE IF( LDGNUM.LT.N ) THEN
INFO = -16
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLASD6', -INFO )
RETURN
END IF
*
* The following values are for bookkeeping purposes only. They are
* integer pointers which indicate the portion of the workspace
* used by a particular array in SLASD7 and SLASD8.
*
ISIGMA = 1
IW = ISIGMA + N
IVFW = IW + M
IVLW = IVFW + M
*
IDX = 1
IDXC = IDX + N
IDXP = IDXC + N
*
* Scale.
*
ORGNRM = MAX( ABS( ALPHA ), ABS( BETA ) )
D( NL+1 ) = ZERO
DO 10 I = 1, N
IF( ABS( D( I ) ).GT.ORGNRM ) THEN
ORGNRM = ABS( D( I ) )
END IF
10 CONTINUE
CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
ALPHA = ALPHA / ORGNRM
BETA = BETA / ORGNRM
*
* Sort and Deflate singular values.
*
CALL SLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, WORK( IW ), VF,
$ WORK( IVFW ), VL, WORK( IVLW ), ALPHA, BETA,
$ WORK( ISIGMA ), IWORK( IDX ), IWORK( IDXP ), IDXQ,
$ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, C, S,
$ INFO )
*
* Solve Secular Equation, compute DIFL, DIFR, and update VF, VL.
*
CALL SLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDGNUM,
$ WORK( ISIGMA ), WORK( IW ), INFO )
*
* Save the poles if ICOMPQ = 1.
*
IF( ICOMPQ.EQ.1 ) THEN
CALL SCOPY( K, D, 1, POLES( 1, 1 ), 1 )
CALL SCOPY( K, WORK( ISIGMA ), 1, POLES( 1, 2 ), 1 )
END IF
*
* Unscale.
*
CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
*
* Prepare the IDXQ sorting permutation.
*
N1 = K
N2 = N - K
CALL SLAMRG( N1, N2, D, 1, -1, IDXQ )
*
RETURN
*
* End of SLASD6
*
END
SUBROUTINE SLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL,
$ VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ,
$ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM,
$ C, S, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL,
$ NR, SQRE
REAL ALPHA, BETA, C, S
* ..
* .. Array Arguments ..
INTEGER GIVCOL( LDGCOL, * ), IDX( * ), IDXP( * ),
$ IDXQ( * ), PERM( * )
REAL D( * ), DSIGMA( * ), GIVNUM( LDGNUM, * ),
$ VF( * ), VFW( * ), VL( * ), VLW( * ), Z( * ),
$ ZW( * )
* ..
*
* Purpose
* =======
*
* SLASD7 merges the two sets of singular values together into a single
* sorted set. Then it tries to deflate the size of the problem. There
* are two ways in which deflation can occur: when two or more singular
* values are close together or if there is a tiny entry in the Z
* vector. For each such occurrence the order of the related
* secular equation problem is reduced by one.
*
* SLASD7 is called from SLASD6.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* Specifies whether singular vectors are to be computed
* in compact form, as follows:
* = 0: Compute singular values only.
* = 1: Compute singular vectors of upper
* bidiagonal matrix in compact form.
*
* NL (input) INTEGER
* The row dimension of the upper block. NL >= 1.
*
* NR (input) INTEGER
* The row dimension of the lower block. NR >= 1.
*
* SQRE (input) INTEGER
* = 0: the lower block is an NR-by-NR square matrix.
* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
*
* The bidiagonal matrix has
* N = NL + NR + 1 rows and
* M = N + SQRE >= N columns.
*
* K (output) INTEGER
* Contains the dimension of the non-deflated matrix, this is
* the order of the related secular equation. 1 <= K <=N.
*
* D (input/output) REAL array, dimension ( N )
* On entry D contains the singular values of the two submatrices
* to be combined. On exit D contains the trailing (N-K) updated
* singular values (those which were deflated) sorted into
* increasing order.
*
* Z (output) REAL array, dimension ( M )
* On exit Z contains the updating row vector in the secular
* equation.
*
* ZW (workspace) REAL array, dimension ( M )
* Workspace for Z.
*
* VF (input/output) REAL array, dimension ( M )
* On entry, VF(1:NL+1) contains the first components of all
* right singular vectors of the upper block; and VF(NL+2:M)
* contains the first components of all right singular vectors
* of the lower block. On exit, VF contains the first components
* of all right singular vectors of the bidiagonal matrix.
*
* VFW (workspace) REAL array, dimension ( M )
* Workspace for VF.
*
* VL (input/output) REAL array, dimension ( M )
* On entry, VL(1:NL+1) contains the last components of all
* right singular vectors of the upper block; and VL(NL+2:M)
* contains the last components of all right singular vectors
* of the lower block. On exit, VL contains the last components
* of all right singular vectors of the bidiagonal matrix.
*
* VLW (workspace) REAL array, dimension ( M )
* Workspace for VL.
*
* ALPHA (input) REAL
* Contains the diagonal element associated with the added row.
*
* BETA (input) REAL
* Contains the off-diagonal element associated with the added
* row.
*
* DSIGMA (output) REAL array, dimension ( N )
* Contains a copy of the diagonal elements (K-1 singular values
* and one zero) in the secular equation.
*
* IDX (workspace) INTEGER array, dimension ( N )
* This will contain the permutation used to sort the contents of
* D into ascending order.
*
* IDXP (workspace) INTEGER array, dimension ( N )
* This will contain the permutation used to place deflated
* values of D at the end of the array. On output IDXP(2:K)
* points to the nondeflated D-values and IDXP(K+1:N)
* points to the deflated singular values.
*
* IDXQ (input) INTEGER array, dimension ( N )
* This contains the permutation which separately sorts the two
* sub-problems in D into ascending order. Note that entries in
* the first half of this permutation must first be moved one
* position backward; and entries in the second half
* must first have NL+1 added to their values.
*
* PERM (output) INTEGER array, dimension ( N )
* The permutations (from deflation and sorting) to be applied
* to each singular block. Not referenced if ICOMPQ = 0.
*
* GIVPTR (output) INTEGER
* The number of Givens rotations which took place in this
* subproblem. Not referenced if ICOMPQ = 0.
*
* GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )
* Each pair of numbers indicates a pair of columns to take place
* in a Givens rotation. Not referenced if ICOMPQ = 0.
*
* LDGCOL (input) INTEGER
* The leading dimension of GIVCOL, must be at least N.
*
* GIVNUM (output) REAL array, dimension ( LDGNUM, 2 )
* Each number indicates the C or S value to be used in the
* corresponding Givens rotation. Not referenced if ICOMPQ = 0.
*
* LDGNUM (input) INTEGER
* The leading dimension of GIVNUM, must be at least N.
*
* C (output) REAL
* C contains garbage if SQRE =0 and the C-value of a Givens
* rotation related to the right null space if SQRE = 1.
*
* S (output) REAL
* S contains garbage if SQRE =0 and the S-value of a Givens
* rotation related to the right null space if SQRE = 1.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO, EIGHT
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0,
$ EIGHT = 8.0E+0 )
* ..
* .. Local Scalars ..
*
INTEGER I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M, N,
$ NLP1, NLP2
REAL EPS, HLFTOL, TAU, TOL, Z1
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLAMRG, SROT, XERBLA
* ..
* .. External Functions ..
REAL SLAMCH, SLAPY2
EXTERNAL SLAMCH, SLAPY2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
N = NL + NR + 1
M = N + SQRE
*
IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
INFO = -1
ELSE IF( NL.LT.1 ) THEN
INFO = -2
ELSE IF( NR.LT.1 ) THEN
INFO = -3
ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
INFO = -4
ELSE IF( LDGCOL.LT.N ) THEN
INFO = -22
ELSE IF( LDGNUM.LT.N ) THEN
INFO = -24
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLASD7', -INFO )
RETURN
END IF
*
NLP1 = NL + 1
NLP2 = NL + 2
IF( ICOMPQ.EQ.1 ) THEN
GIVPTR = 0
END IF
*
* Generate the first part of the vector Z and move the singular
* values in the first part of D one position backward.
*
Z1 = ALPHA*VL( NLP1 )
VL( NLP1 ) = ZERO
TAU = VF( NLP1 )
DO 10 I = NL, 1, -1
Z( I+1 ) = ALPHA*VL( I )
VL( I ) = ZERO
VF( I+1 ) = VF( I )
D( I+1 ) = D( I )
IDXQ( I+1 ) = IDXQ( I ) + 1
10 CONTINUE
VF( 1 ) = TAU
*
* Generate the second part of the vector Z.
*
DO 20 I = NLP2, M
Z( I ) = BETA*VF( I )
VF( I ) = ZERO
20 CONTINUE
*
* Sort the singular values into increasing order
*
DO 30 I = NLP2, N
IDXQ( I ) = IDXQ( I ) + NLP1
30 CONTINUE
*
* DSIGMA, IDXC, IDXC, and ZW are used as storage space.
*
DO 40 I = 2, N
DSIGMA( I ) = D( IDXQ( I ) )
ZW( I ) = Z( IDXQ( I ) )
VFW( I ) = VF( IDXQ( I ) )
VLW( I ) = VL( IDXQ( I ) )
40 CONTINUE
*
CALL SLAMRG( NL, NR, DSIGMA( 2 ), 1, 1, IDX( 2 ) )
*
DO 50 I = 2, N
IDXI = 1 + IDX( I )
D( I ) = DSIGMA( IDXI )
Z( I ) = ZW( IDXI )
VF( I ) = VFW( IDXI )
VL( I ) = VLW( IDXI )
50 CONTINUE
*
* Calculate the allowable deflation tolerence
*
EPS = SLAMCH( 'Epsilon' )
TOL = MAX( ABS( ALPHA ), ABS( BETA ) )
TOL = EIGHT*EIGHT*EPS*MAX( ABS( D( N ) ), TOL )
*
* There are 2 kinds of deflation -- first a value in the z-vector
* is small, second two (or more) singular values are very close
* together (their difference is small).
*
* If the value in the z-vector is small, we simply permute the
* array so that the corresponding singular value is moved to the
* end.
*
* If two values in the D-vector are close, we perform a two-sided
* rotation designed to make one of the corresponding z-vector
* entries zero, and then permute the array so that the deflated
* singular value is moved to the end.
*
* If there are multiple singular values then the problem deflates.
* Here the number of equal singular values are found. As each equal
* singular value is found, an elementary reflector is computed to
* rotate the corresponding singular subspace so that the
* corresponding components of Z are zero in this new basis.
*
K = 1
K2 = N + 1
DO 60 J = 2, N
IF( ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
IDXP( K2 ) = J
IF( J.EQ.N )
$ GO TO 100
ELSE
JPREV = J
GO TO 70
END IF
60 CONTINUE
70 CONTINUE
J = JPREV
80 CONTINUE
J = J + 1
IF( J.GT.N )
$ GO TO 90
IF( ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
IDXP( K2 ) = J
ELSE
*
* Check if singular values are close enough to allow deflation.
*
IF( ABS( D( J )-D( JPREV ) ).LE.TOL ) THEN
*
* Deflation is possible.
*
S = Z( JPREV )
C = Z( J )
*
* Find sqrt(a**2+b**2) without overflow or
* destructive underflow.
*
TAU = SLAPY2( C, S )
Z( J ) = TAU
Z( JPREV ) = ZERO
C = C / TAU
S = -S / TAU
*
* Record the appropriate Givens rotation
*
IF( ICOMPQ.EQ.1 ) THEN
GIVPTR = GIVPTR + 1
IDXJP = IDXQ( IDX( JPREV )+1 )
IDXJ = IDXQ( IDX( J )+1 )
IF( IDXJP.LE.NLP1 ) THEN
IDXJP = IDXJP - 1
END IF
IF( IDXJ.LE.NLP1 ) THEN
IDXJ = IDXJ - 1
END IF
GIVCOL( GIVPTR, 2 ) = IDXJP
GIVCOL( GIVPTR, 1 ) = IDXJ
GIVNUM( GIVPTR, 2 ) = C
GIVNUM( GIVPTR, 1 ) = S
END IF
CALL SROT( 1, VF( JPREV ), 1, VF( J ), 1, C, S )
CALL SROT( 1, VL( JPREV ), 1, VL( J ), 1, C, S )
K2 = K2 - 1
IDXP( K2 ) = JPREV
JPREV = J
ELSE
K = K + 1
ZW( K ) = Z( JPREV )
DSIGMA( K ) = D( JPREV )
IDXP( K ) = JPREV
JPREV = J
END IF
END IF
GO TO 80
90 CONTINUE
*
* Record the last singular value.
*
K = K + 1
ZW( K ) = Z( JPREV )
DSIGMA( K ) = D( JPREV )
IDXP( K ) = JPREV
*
100 CONTINUE
*
* Sort the singular values into DSIGMA. The singular values which
* were not deflated go into the first K slots of DSIGMA, except
* that DSIGMA(1) is treated separately.
*
DO 110 J = 2, N
JP = IDXP( J )
DSIGMA( J ) = D( JP )
VFW( J ) = VF( JP )
VLW( J ) = VL( JP )
110 CONTINUE
IF( ICOMPQ.EQ.1 ) THEN
DO 120 J = 2, N
JP = IDXP( J )
PERM( J ) = IDXQ( IDX( JP )+1 )
IF( PERM( J ).LE.NLP1 ) THEN
PERM( J ) = PERM( J ) - 1
END IF
120 CONTINUE
END IF
*
* The deflated singular values go back into the last N - K slots of
* D.
*
CALL SCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 )
*
* Determine DSIGMA(1), DSIGMA(2), Z(1), VF(1), VL(1), VF(M), and
* VL(M).
*
DSIGMA( 1 ) = ZERO
HLFTOL = TOL / TWO
IF( ABS( DSIGMA( 2 ) ).LE.HLFTOL )
$ DSIGMA( 2 ) = HLFTOL
IF( M.GT.N ) THEN
Z( 1 ) = SLAPY2( Z1, Z( M ) )
IF( Z( 1 ).LE.TOL ) THEN
C = ONE
S = ZERO
Z( 1 ) = TOL
ELSE
C = Z1 / Z( 1 )
S = -Z( M ) / Z( 1 )
END IF
CALL SROT( 1, VF( M ), 1, VF( 1 ), 1, C, S )
CALL SROT( 1, VL( M ), 1, VL( 1 ), 1, C, S )
ELSE
IF( ABS( Z1 ).LE.TOL ) THEN
Z( 1 ) = TOL
ELSE
Z( 1 ) = Z1
END IF
END IF
*
* Restore Z, VF, and VL.
*
CALL SCOPY( K-1, ZW( 2 ), 1, Z( 2 ), 1 )
CALL SCOPY( N-1, VFW( 2 ), 1, VF( 2 ), 1 )
CALL SCOPY( N-1, VLW( 2 ), 1, VL( 2 ), 1 )
*
RETURN
*
* End of SLASD7
*
END
SUBROUTINE SLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR,
$ DSIGMA, WORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER ICOMPQ, INFO, K, LDDIFR
* ..
* .. Array Arguments ..
REAL D( * ), DIFL( * ), DIFR( LDDIFR, * ),
$ DSIGMA( * ), VF( * ), VL( * ), WORK( * ),
$ Z( * )
* ..
*
* Purpose
* =======
*
* SLASD8 finds the square roots of the roots of the secular equation,
* as defined by the values in DSIGMA and Z. It makes the appropriate
* calls to SLASD4, and stores, for each element in D, the distance
* to its two nearest poles (elements in DSIGMA). It also updates
* the arrays VF and VL, the first and last components of all the
* right singular vectors of the original bidiagonal matrix.
*
* SLASD8 is called from SLASD6.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* Specifies whether singular vectors are to be computed in
* factored form in the calling routine:
* = 0: Compute singular values only.
* = 1: Compute singular vectors in factored form as well.
*
* K (input) INTEGER
* The number of terms in the rational function to be solved
* by SLASD4. K >= 1.
*
* D (output) REAL array, dimension ( K )
* On output, D contains the updated singular values.
*
* Z (input) REAL array, dimension ( K )
* The first K elements of this array contain the components
* of the deflation-adjusted updating row vector.
*
* VF (input/output) REAL array, dimension ( K )
* On entry, VF contains information passed through DBEDE8.
* On exit, VF contains the first K components of the first
* components of all right singular vectors of the bidiagonal
* matrix.
*
* VL (input/output) REAL array, dimension ( K )
* On entry, VL contains information passed through DBEDE8.
* On exit, VL contains the first K components of the last
* components of all right singular vectors of the bidiagonal
* matrix.
*
* DIFL (output) REAL array, dimension ( K )
* On exit, DIFL(I) = D(I) - DSIGMA(I).
*
* DIFR (output) REAL array,
* dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and
* dimension ( K ) if ICOMPQ = 0.
* On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not
* defined and will not be referenced.
*
* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the
* normalizing factors for the right singular vector matrix.
*
* LDDIFR (input) INTEGER
* The leading dimension of DIFR, must be at least K.
*
* DSIGMA (input) REAL array, dimension ( K )
* The first K elements of this array contain the old roots
* of the deflated updating problem. These are the poles
* of the secular equation.
*
* WORK (workspace) REAL array, dimension at least 3 * K
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an singular value did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, IWK1, IWK2, IWK2I, IWK3, IWK3I, J
REAL DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, RHO, TEMP
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLASCL, SLASD4, SLASET, XERBLA
* ..
* .. External Functions ..
REAL SDOT, SLAMC3, SNRM2
EXTERNAL SDOT, SLAMC3, SNRM2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
INFO = -1
ELSE IF( K.LT.1 ) THEN
INFO = -2
ELSE IF( LDDIFR.LT.K ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLASD8', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( K.EQ.1 ) THEN
D( 1 ) = ABS( Z( 1 ) )
DIFL( 1 ) = D( 1 )
IF( ICOMPQ.EQ.1 ) THEN
DIFL( 2 ) = ONE
DIFR( 1, 2 ) = ONE
END IF
RETURN
END IF
*
* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can
* be computed with high relative accuracy (barring over/underflow).
* This is a problem on machines without a guard digit in
* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I),
* which on any of these machines zeros out the bottommost
* bit of DSIGMA(I) if it is 1; this makes the subsequent
* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation
* occurs. On binary machines with a guard digit (almost all
* machines) it does not change DSIGMA(I) at all. On hexadecimal
* and decimal machines with a guard digit, it slightly
* changes the bottommost bits of DSIGMA(I). It does not account
* for hexadecimal or decimal machines without guard digits
* (we know of none). We use a subroutine call to compute
* 2*DSIGMA(I) to prevent optimizing compilers from eliminating
* this code.
*
DO 10 I = 1, K
DSIGMA( I ) = SLAMC3( DSIGMA( I ), DSIGMA( I ) ) - DSIGMA( I )
10 CONTINUE
*
* Book keeping.
*
IWK1 = 1
IWK2 = IWK1 + K
IWK3 = IWK2 + K
IWK2I = IWK2 - 1
IWK3I = IWK3 - 1
*
* Normalize Z.
*
RHO = SNRM2( K, Z, 1 )
CALL SLASCL( 'G', 0, 0, RHO, ONE, K, 1, Z, K, INFO )
RHO = RHO*RHO
*
* Initialize WORK(IWK3).
*
CALL SLASET( 'A', K, 1, ONE, ONE, WORK( IWK3 ), K )
*
* Compute the updated singular values, the arrays DIFL, DIFR,
* and the updated Z.
*
DO 40 J = 1, K
CALL SLASD4( K, J, DSIGMA, Z, WORK( IWK1 ), RHO, D( J ),
$ WORK( IWK2 ), INFO )
*
* If the root finder fails, the computation is terminated.
*
IF( INFO.NE.0 ) THEN
RETURN
END IF
WORK( IWK3I+J ) = WORK( IWK3I+J )*WORK( J )*WORK( IWK2I+J )
DIFL( J ) = -WORK( J )
DIFR( J, 1 ) = -WORK( J+1 )
DO 20 I = 1, J - 1
WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )*
$ WORK( IWK2I+I ) / ( DSIGMA( I )-
$ DSIGMA( J ) ) / ( DSIGMA( I )+
$ DSIGMA( J ) )
20 CONTINUE
DO 30 I = J + 1, K
WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )*
$ WORK( IWK2I+I ) / ( DSIGMA( I )-
$ DSIGMA( J ) ) / ( DSIGMA( I )+
$ DSIGMA( J ) )
30 CONTINUE
40 CONTINUE
*
* Compute updated Z.
*
DO 50 I = 1, K
Z( I ) = SIGN( SQRT( ABS( WORK( IWK3I+I ) ) ), Z( I ) )
50 CONTINUE
*
* Update VF and VL.
*
DO 80 J = 1, K
DIFLJ = DIFL( J )
DJ = D( J )
DSIGJ = -DSIGMA( J )
IF( J.LT.K ) THEN
DIFRJ = -DIFR( J, 1 )
DSIGJP = -DSIGMA( J+1 )
END IF
WORK( J ) = -Z( J ) / DIFLJ / ( DSIGMA( J )+DJ )
DO 60 I = 1, J - 1
WORK( I ) = Z( I ) / ( SLAMC3( DSIGMA( I ), DSIGJ )-DIFLJ )
$ / ( DSIGMA( I )+DJ )
60 CONTINUE
DO 70 I = J + 1, K
WORK( I ) = Z( I ) / ( SLAMC3( DSIGMA( I ), DSIGJP )+DIFRJ )
$ / ( DSIGMA( I )+DJ )
70 CONTINUE
TEMP = SNRM2( K, WORK, 1 )
WORK( IWK2I+J ) = SDOT( K, WORK, 1, VF, 1 ) / TEMP
WORK( IWK3I+J ) = SDOT( K, WORK, 1, VL, 1 ) / TEMP
IF( ICOMPQ.EQ.1 ) THEN
DIFR( J, 2 ) = TEMP
END IF
80 CONTINUE
*
CALL SCOPY( K, WORK( IWK2 ), 1, VF, 1 )
CALL SCOPY( K, WORK( IWK3 ), 1, VL, 1 )
*
RETURN
*
* End of SLASD8
*
END
SUBROUTINE SLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K,
$ DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL,
$ PERM, GIVNUM, C, S, WORK, IWORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER ICOMPQ, INFO, LDGCOL, LDU, N, SMLSIZ, SQRE
* ..
* .. Array Arguments ..
INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ),
$ K( * ), PERM( LDGCOL, * )
REAL C( * ), D( * ), DIFL( LDU, * ), DIFR( LDU, * ),
$ E( * ), GIVNUM( LDU, * ), POLES( LDU, * ),
$ S( * ), U( LDU, * ), VT( LDU, * ), WORK( * ),
$ Z( LDU, * )
* ..
*
* Purpose
* =======
*
* Using a divide and conquer approach, SLASDA computes the singular
* value decomposition (SVD) of a real upper bidiagonal N-by-M matrix
* B with diagonal D and offdiagonal E, where M = N + SQRE. The
* algorithm computes the singular values in the SVD B = U * S * VT.
* The orthogonal matrices U and VT are optionally computed in
* compact form.
*
* A related subroutine, SLASD0, computes the singular values and
* the singular vectors in explicit form.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* Specifies whether singular vectors are to be computed
* in compact form, as follows
* = 0: Compute singular values only.
* = 1: Compute singular vectors of upper bidiagonal
* matrix in compact form.
*
* SMLSIZ (input) INTEGER
* The maximum size of the subproblems at the bottom of the
* computation tree.
*
* N (input) INTEGER
* The row dimension of the upper bidiagonal matrix. This is
* also the dimension of the main diagonal array D.
*
* SQRE (input) INTEGER
* Specifies the column dimension of the bidiagonal matrix.
* = 0: The bidiagonal matrix has column dimension M = N;
* = 1: The bidiagonal matrix has column dimension M = N + 1.
*
* D (input/output) REAL array, dimension ( N )
* On entry D contains the main diagonal of the bidiagonal
* matrix. On exit D, if INFO = 0, contains its singular values.
*
* E (input) REAL array, dimension ( M-1 )
* Contains the subdiagonal entries of the bidiagonal matrix.
* On exit, E has been destroyed.
*
* U (output) REAL array,
* dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced
* if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left
* singular vector matrices of all subproblems at the bottom
* level.
*
* LDU (input) INTEGER, LDU = > N.
* The leading dimension of arrays U, VT, DIFL, DIFR, POLES,
* GIVNUM, and Z.
*
* VT (output) REAL array,
* dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced
* if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT' contains the right
* singular vector matrices of all subproblems at the bottom
* level.
*
* K (output) INTEGER array, dimension ( N )
* if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0.
* If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th
* secular equation on the computation tree.
*
* DIFL (output) REAL array, dimension ( LDU, NLVL ),
* where NLVL = floor(log_2 (N/SMLSIZ))).
*
* DIFR (output) REAL array,
* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and
* dimension ( N ) if ICOMPQ = 0.
* If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1)
* record distances between singular values on the I-th
* level and singular values on the (I -1)-th level, and
* DIFR(1:N, 2 * I ) contains the normalizing factors for
* the right singular vector matrix. See SLASD8 for details.
*
* Z (output) REAL array,
* dimension ( LDU, NLVL ) if ICOMPQ = 1 and
* dimension ( N ) if ICOMPQ = 0.
* The first K elements of Z(1, I) contain the components of
* the deflation-adjusted updating row vector for subproblems
* on the I-th level.
*
* POLES (output) REAL array,
* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced
* if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and
* POLES(1, 2*I) contain the new and old singular values
* involved in the secular equations on the I-th level.
*
* GIVPTR (output) INTEGER array,
* dimension ( N ) if ICOMPQ = 1, and not referenced if
* ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records
* the number of Givens rotations performed on the I-th
* problem on the computation tree.
*
* GIVCOL (output) INTEGER array,
* dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not
* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,
* GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations
* of Givens rotations performed on the I-th level on the
* computation tree.
*
* LDGCOL (input) INTEGER, LDGCOL = > N.
* The leading dimension of arrays GIVCOL and PERM.
*
* PERM (output) INTEGER array, dimension ( LDGCOL, NLVL )
* if ICOMPQ = 1, and not referenced
* if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records
* permutations done on the I-th level of the computation tree.
*
* GIVNUM (output) REAL array,
* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not
* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,
* GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S-
* values of Givens rotations performed on the I-th level on
* the computation tree.
*
* C (output) REAL array,
* dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0.
* If ICOMPQ = 1 and the I-th subproblem is not square, on exit,
* C( I ) contains the C-value of a Givens rotation related to
* the right null space of the I-th subproblem.
*
* S (output) REAL array, dimension ( N ) if
* ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1
* and the I-th subproblem is not square, on exit, S( I )
* contains the S-value of a Givens rotation related to
* the right null space of the I-th subproblem.
*
* WORK (workspace) REAL array, dimension
* (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)).
*
* IWORK (workspace) INTEGER array, dimension (7*N).
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an singular value did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, I1, IC, IDXQ, IDXQI, IM1, INODE, ITEMP, IWK,
$ J, LF, LL, LVL, LVL2, M, NCC, ND, NDB1, NDIML,
$ NDIMR, NL, NLF, NLP1, NLVL, NR, NRF, NRP1, NRU,
$ NWORK1, NWORK2, SMLSZP, SQREI, VF, VFI, VL, VLI
REAL ALPHA, BETA
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLASD6, SLASDQ, SLASDT, SLASET, XERBLA
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
INFO = -1
ELSE IF( SMLSIZ.LT.3 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
INFO = -4
ELSE IF( LDU.LT.( N+SQRE ) ) THEN
INFO = -8
ELSE IF( LDGCOL.LT.N ) THEN
INFO = -17
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLASDA', -INFO )
RETURN
END IF
*
M = N + SQRE
*
* If the input matrix is too small, call SLASDQ to find the SVD.
*
IF( N.LE.SMLSIZ ) THEN
IF( ICOMPQ.EQ.0 ) THEN
CALL SLASDQ( 'U', SQRE, N, 0, 0, 0, D, E, VT, LDU, U, LDU,
$ U, LDU, WORK, INFO )
ELSE
CALL SLASDQ( 'U', SQRE, N, M, N, 0, D, E, VT, LDU, U, LDU,
$ U, LDU, WORK, INFO )
END IF
RETURN
END IF
*
* Book-keeping and set up the computation tree.
*
INODE = 1
NDIML = INODE + N
NDIMR = NDIML + N
IDXQ = NDIMR + N
IWK = IDXQ + N
*
NCC = 0
NRU = 0
*
SMLSZP = SMLSIZ + 1
VF = 1
VL = VF + M
NWORK1 = VL + M
NWORK2 = NWORK1 + SMLSZP*SMLSZP
*
CALL SLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ),
$ IWORK( NDIMR ), SMLSIZ )
*
* for the nodes on bottom level of the tree, solve
* their subproblems by SLASDQ.
*
NDB1 = ( ND+1 ) / 2
DO 30 I = NDB1, ND
*
* IC : center row of each node
* NL : number of rows of left subproblem
* NR : number of rows of right subproblem
* NLF: starting row of the left subproblem
* NRF: starting row of the right subproblem
*
I1 = I - 1
IC = IWORK( INODE+I1 )
NL = IWORK( NDIML+I1 )
NLP1 = NL + 1
NR = IWORK( NDIMR+I1 )
NLF = IC - NL
NRF = IC + 1
IDXQI = IDXQ + NLF - 2
VFI = VF + NLF - 1
VLI = VL + NLF - 1
SQREI = 1
IF( ICOMPQ.EQ.0 ) THEN
CALL SLASET( 'A', NLP1, NLP1, ZERO, ONE, WORK( NWORK1 ),
$ SMLSZP )
CALL SLASDQ( 'U', SQREI, NL, NLP1, NRU, NCC, D( NLF ),
$ E( NLF ), WORK( NWORK1 ), SMLSZP,
$ WORK( NWORK2 ), NL, WORK( NWORK2 ), NL,
$ WORK( NWORK2 ), INFO )
ITEMP = NWORK1 + NL*SMLSZP
CALL SCOPY( NLP1, WORK( NWORK1 ), 1, WORK( VFI ), 1 )
CALL SCOPY( NLP1, WORK( ITEMP ), 1, WORK( VLI ), 1 )
ELSE
CALL SLASET( 'A', NL, NL, ZERO, ONE, U( NLF, 1 ), LDU )
CALL SLASET( 'A', NLP1, NLP1, ZERO, ONE, VT( NLF, 1 ), LDU )
CALL SLASDQ( 'U', SQREI, NL, NLP1, NL, NCC, D( NLF ),
$ E( NLF ), VT( NLF, 1 ), LDU, U( NLF, 1 ), LDU,
$ U( NLF, 1 ), LDU, WORK( NWORK1 ), INFO )
CALL SCOPY( NLP1, VT( NLF, 1 ), 1, WORK( VFI ), 1 )
CALL SCOPY( NLP1, VT( NLF, NLP1 ), 1, WORK( VLI ), 1 )
END IF
IF( INFO.NE.0 ) THEN
RETURN
END IF
DO 10 J = 1, NL
IWORK( IDXQI+J ) = J
10 CONTINUE
IF( ( I.EQ.ND ) .AND. ( SQRE.EQ.0 ) ) THEN
SQREI = 0
ELSE
SQREI = 1
END IF
IDXQI = IDXQI + NLP1
VFI = VFI + NLP1
VLI = VLI + NLP1
NRP1 = NR + SQREI
IF( ICOMPQ.EQ.0 ) THEN
CALL SLASET( 'A', NRP1, NRP1, ZERO, ONE, WORK( NWORK1 ),
$ SMLSZP )
CALL SLASDQ( 'U', SQREI, NR, NRP1, NRU, NCC, D( NRF ),
$ E( NRF ), WORK( NWORK1 ), SMLSZP,
$ WORK( NWORK2 ), NR, WORK( NWORK2 ), NR,
$ WORK( NWORK2 ), INFO )
ITEMP = NWORK1 + ( NRP1-1 )*SMLSZP
CALL SCOPY( NRP1, WORK( NWORK1 ), 1, WORK( VFI ), 1 )
CALL SCOPY( NRP1, WORK( ITEMP ), 1, WORK( VLI ), 1 )
ELSE
CALL SLASET( 'A', NR, NR, ZERO, ONE, U( NRF, 1 ), LDU )
CALL SLASET( 'A', NRP1, NRP1, ZERO, ONE, VT( NRF, 1 ), LDU )
CALL SLASDQ( 'U', SQREI, NR, NRP1, NR, NCC, D( NRF ),
$ E( NRF ), VT( NRF, 1 ), LDU, U( NRF, 1 ), LDU,
$ U( NRF, 1 ), LDU, WORK( NWORK1 ), INFO )
CALL SCOPY( NRP1, VT( NRF, 1 ), 1, WORK( VFI ), 1 )
CALL SCOPY( NRP1, VT( NRF, NRP1 ), 1, WORK( VLI ), 1 )
END IF
IF( INFO.NE.0 ) THEN
RETURN
END IF
DO 20 J = 1, NR
IWORK( IDXQI+J ) = J
20 CONTINUE
30 CONTINUE
*
* Now conquer each subproblem bottom-up.
*
J = 2**NLVL
DO 50 LVL = NLVL, 1, -1
LVL2 = LVL*2 - 1
*
* Find the first node LF and last node LL on
* the current level LVL.
*
IF( LVL.EQ.1 ) THEN
LF = 1
LL = 1
ELSE
LF = 2**( LVL-1 )
LL = 2*LF - 1
END IF
DO 40 I = LF, LL
IM1 = I - 1
IC = IWORK( INODE+IM1 )
NL = IWORK( NDIML+IM1 )
NR = IWORK( NDIMR+IM1 )
NLF = IC - NL
NRF = IC + 1
IF( I.EQ.LL ) THEN
SQREI = SQRE
ELSE
SQREI = 1
END IF
VFI = VF + NLF - 1
VLI = VL + NLF - 1
IDXQI = IDXQ + NLF - 1
ALPHA = D( IC )
BETA = E( IC )
IF( ICOMPQ.EQ.0 ) THEN
CALL SLASD6( ICOMPQ, NL, NR, SQREI, D( NLF ),
$ WORK( VFI ), WORK( VLI ), ALPHA, BETA,
$ IWORK( IDXQI ), PERM, GIVPTR( 1 ), GIVCOL,
$ LDGCOL, GIVNUM, LDU, POLES, DIFL, DIFR, Z,
$ K( 1 ), C( 1 ), S( 1 ), WORK( NWORK1 ),
$ IWORK( IWK ), INFO )
ELSE
J = J - 1
CALL SLASD6( ICOMPQ, NL, NR, SQREI, D( NLF ),
$ WORK( VFI ), WORK( VLI ), ALPHA, BETA,
$ IWORK( IDXQI ), PERM( NLF, LVL ),
$ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
$ GIVNUM( NLF, LVL2 ), LDU,
$ POLES( NLF, LVL2 ), DIFL( NLF, LVL ),
$ DIFR( NLF, LVL2 ), Z( NLF, LVL ), K( J ),
$ C( J ), S( J ), WORK( NWORK1 ),
$ IWORK( IWK ), INFO )
END IF
IF( INFO.NE.0 ) THEN
RETURN
END IF
40 CONTINUE
50 CONTINUE
*
RETURN
*
* End of SLASDA
*
END
SUBROUTINE SLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT,
$ U, LDU, C, LDC, WORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU, SQRE
* ..
* .. Array Arguments ..
REAL C( LDC, * ), D( * ), E( * ), U( LDU, * ),
$ VT( LDVT, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SLASDQ computes the singular value decomposition (SVD) of a real
* (upper or lower) bidiagonal matrix with diagonal D and offdiagonal
* E, accumulating the transformations if desired. Letting B denote
* the input bidiagonal matrix, the algorithm computes orthogonal
* matrices Q and P such that B = Q * S * P' (P' denotes the transpose
* of P). The singular values S are overwritten on D.
*
* The input matrix U is changed to U * Q if desired.
* The input matrix VT is changed to P' * VT if desired.
* The input matrix C is changed to Q' * C if desired.
*
* See "Computing Small Singular Values of Bidiagonal Matrices With
* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
* LAPACK Working Note #3, for a detailed description of the algorithm.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* On entry, UPLO specifies whether the input bidiagonal matrix
* is upper or lower bidiagonal, and wether it is square are
* not.
* UPLO = 'U' or 'u' B is upper bidiagonal.
* UPLO = 'L' or 'l' B is lower bidiagonal.
*
* SQRE (input) INTEGER
* = 0: then the input matrix is N-by-N.
* = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and
* (N+1)-by-N if UPLU = 'L'.
*
* The bidiagonal matrix has
* N = NL + NR + 1 rows and
* M = N + SQRE >= N columns.
*
* N (input) INTEGER
* On entry, N specifies the number of rows and columns
* in the matrix. N must be at least 0.
*
* NCVT (input) INTEGER
* On entry, NCVT specifies the number of columns of
* the matrix VT. NCVT must be at least 0.
*
* NRU (input) INTEGER
* On entry, NRU specifies the number of rows of
* the matrix U. NRU must be at least 0.
*
* NCC (input) INTEGER
* On entry, NCC specifies the number of columns of
* the matrix C. NCC must be at least 0.
*
* D (input/output) REAL array, dimension (N)
* On entry, D contains the diagonal entries of the
* bidiagonal matrix whose SVD is desired. On normal exit,
* D contains the singular values in ascending order.
*
* E (input/output) REAL array.
* dimension is (N-1) if SQRE = 0 and N if SQRE = 1.
* On entry, the entries of E contain the offdiagonal entries
* of the bidiagonal matrix whose SVD is desired. On normal
* exit, E will contain 0. If the algorithm does not converge,
* D and E will contain the diagonal and superdiagonal entries
* of a bidiagonal matrix orthogonally equivalent to the one
* given as input.
*
* VT (input/output) REAL array, dimension (LDVT, NCVT)
* On entry, contains a matrix which on exit has been
* premultiplied by P', dimension N-by-NCVT if SQRE = 0
* and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0).
*
* LDVT (input) INTEGER
* On entry, LDVT specifies the leading dimension of VT as
* declared in the calling (sub) program. LDVT must be at
* least 1. If NCVT is nonzero LDVT must also be at least N.
*
* U (input/output) REAL array, dimension (LDU, N)
* On entry, contains a matrix which on exit has been
* postmultiplied by Q, dimension NRU-by-N if SQRE = 0
* and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0).
*
* LDU (input) INTEGER
* On entry, LDU specifies the leading dimension of U as
* declared in the calling (sub) program. LDU must be at
* least max( 1, NRU ) .
*
* C (input/output) REAL array, dimension (LDC, NCC)
* On entry, contains an N-by-NCC matrix which on exit
* has been premultiplied by Q' dimension N-by-NCC if SQRE = 0
* and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0).
*
* LDC (input) INTEGER
* On entry, LDC specifies the leading dimension of C as
* declared in the calling (sub) program. LDC must be at
* least 1. If NCC is nonzero, LDC must also be at least N.
*
* WORK (workspace) REAL array, dimension (4*N)
* Workspace. Only referenced if one of NCVT, NRU, or NCC is
* nonzero, and if N is at least 2.
*
* INFO (output) INTEGER
* On exit, a value of 0 indicates a successful exit.
* If INFO < 0, argument number -INFO is illegal.
* If INFO > 0, the algorithm did not converge, and INFO
* specifies how many superdiagonals did not converge.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL ROTATE
INTEGER I, ISUB, IUPLO, J, NP1, SQRE1
REAL CS, R, SMIN, SN
* ..
* .. External Subroutines ..
EXTERNAL SBDSQR, SLARTG, SLASR, SSWAP, XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IUPLO = 0
IF( LSAME( UPLO, 'U' ) )
$ IUPLO = 1
IF( LSAME( UPLO, 'L' ) )
$ IUPLO = 2
IF( IUPLO.EQ.0 ) THEN
INFO = -1
ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NCVT.LT.0 ) THEN
INFO = -4
ELSE IF( NRU.LT.0 ) THEN
INFO = -5
ELSE IF( NCC.LT.0 ) THEN
INFO = -6
ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR.
$ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN
INFO = -10
ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN
INFO = -12
ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR.
$ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN
INFO = -14
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLASDQ', -INFO )
RETURN
END IF
IF( N.EQ.0 )
$ RETURN
*
* ROTATE is true if any singular vectors desired, false otherwise
*
ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 )
NP1 = N + 1
SQRE1 = SQRE
*
* If matrix non-square upper bidiagonal, rotate to be lower
* bidiagonal. The rotations are on the right.
*
IF( ( IUPLO.EQ.1 ) .AND. ( SQRE1.EQ.1 ) ) THEN
DO 10 I = 1, N - 1
CALL SLARTG( D( I ), E( I ), CS, SN, R )
D( I ) = R
E( I ) = SN*D( I+1 )
D( I+1 ) = CS*D( I+1 )
IF( ROTATE ) THEN
WORK( I ) = CS
WORK( N+I ) = SN
END IF
10 CONTINUE
CALL SLARTG( D( N ), E( N ), CS, SN, R )
D( N ) = R
E( N ) = ZERO
IF( ROTATE ) THEN
WORK( N ) = CS
WORK( N+N ) = SN
END IF
IUPLO = 2
SQRE1 = 0
*
* Update singular vectors if desired.
*
IF( NCVT.GT.0 )
$ CALL SLASR( 'L', 'V', 'F', NP1, NCVT, WORK( 1 ),
$ WORK( NP1 ), VT, LDVT )
END IF
*
* If matrix lower bidiagonal, rotate to be upper bidiagonal
* by applying Givens rotations on the left.
*
IF( IUPLO.EQ.2 ) THEN
DO 20 I = 1, N - 1
CALL SLARTG( D( I ), E( I ), CS, SN, R )
D( I ) = R
E( I ) = SN*D( I+1 )
D( I+1 ) = CS*D( I+1 )
IF( ROTATE ) THEN
WORK( I ) = CS
WORK( N+I ) = SN
END IF
20 CONTINUE
*
* If matrix (N+1)-by-N lower bidiagonal, one additional
* rotation is needed.
*
IF( SQRE1.EQ.1 ) THEN
CALL SLARTG( D( N ), E( N ), CS, SN, R )
D( N ) = R
IF( ROTATE ) THEN
WORK( N ) = CS
WORK( N+N ) = SN
END IF
END IF
*
* Update singular vectors if desired.
*
IF( NRU.GT.0 ) THEN
IF( SQRE1.EQ.0 ) THEN
CALL SLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ),
$ WORK( NP1 ), U, LDU )
ELSE
CALL SLASR( 'R', 'V', 'F', NRU, NP1, WORK( 1 ),
$ WORK( NP1 ), U, LDU )
END IF
END IF
IF( NCC.GT.0 ) THEN
IF( SQRE1.EQ.0 ) THEN
CALL SLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ),
$ WORK( NP1 ), C, LDC )
ELSE
CALL SLASR( 'L', 'V', 'F', NP1, NCC, WORK( 1 ),
$ WORK( NP1 ), C, LDC )
END IF
END IF
END IF
*
* Call SBDSQR to compute the SVD of the reduced real
* N-by-N upper bidiagonal matrix.
*
CALL SBDSQR( 'U', N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C,
$ LDC, WORK, INFO )
*
* Sort the singular values into ascending order (insertion sort on
* singular values, but only one transposition per singular vector)
*
DO 40 I = 1, N
*
* Scan for smallest D(I).
*
ISUB = I
SMIN = D( I )
DO 30 J = I + 1, N
IF( D( J ).LT.SMIN ) THEN
ISUB = J
SMIN = D( J )
END IF
30 CONTINUE
IF( ISUB.NE.I ) THEN
*
* Swap singular values and vectors.
*
D( ISUB ) = D( I )
D( I ) = SMIN
IF( NCVT.GT.0 )
$ CALL SSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( I, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL SSWAP( NRU, U( 1, ISUB ), 1, U( 1, I ), 1 )
IF( NCC.GT.0 )
$ CALL SSWAP( NCC, C( ISUB, 1 ), LDC, C( I, 1 ), LDC )
END IF
40 CONTINUE
*
RETURN
*
* End of SLASDQ
*
END
SUBROUTINE SLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LVL, MSUB, N, ND
* ..
* .. Array Arguments ..
INTEGER INODE( * ), NDIML( * ), NDIMR( * )
* ..
*
* Purpose
* =======
*
* SLASDT creates a tree of subproblems for bidiagonal divide and
* conquer.
*
* Arguments
* =========
*
* N (input) INTEGER
* On entry, the number of diagonal elements of the
* bidiagonal matrix.
*
* LVL (output) INTEGER
* On exit, the number of levels on the computation tree.
*
* ND (output) INTEGER
* On exit, the number of nodes on the tree.
*
* INODE (output) INTEGER array, dimension ( N )
* On exit, centers of subproblems.
*
* NDIML (output) INTEGER array, dimension ( N )
* On exit, row dimensions of left children.
*
* NDIMR (output) INTEGER array, dimension ( N )
* On exit, row dimensions of right children.
*
* MSUB (input) INTEGER.
* On entry, the maximum row dimension each subproblem at the
* bottom of the tree can be of.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL TWO
PARAMETER ( TWO = 2.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, IL, IR, LLST, MAXN, NCRNT, NLVL
REAL TEMP
* ..
* .. Intrinsic Functions ..
INTRINSIC INT, LOG, MAX, REAL
* ..
* .. Executable Statements ..
*
* Find the number of levels on the tree.
*
MAXN = MAX( 1, N )
TEMP = LOG( REAL( MAXN ) / REAL( MSUB+1 ) ) / LOG( TWO )
LVL = INT( TEMP ) + 1
*
I = N / 2
INODE( 1 ) = I + 1
NDIML( 1 ) = I
NDIMR( 1 ) = N - I - 1
IL = 0
IR = 1
LLST = 1
DO 20 NLVL = 1, LVL - 1
*
* Constructing the tree at (NLVL+1)-st level. The number of
* nodes created on this level is LLST * 2.
*
DO 10 I = 0, LLST - 1
IL = IL + 2
IR = IR + 2
NCRNT = LLST + I
NDIML( IL ) = NDIML( NCRNT ) / 2
NDIMR( IL ) = NDIML( NCRNT ) - NDIML( IL ) - 1
INODE( IL ) = INODE( NCRNT ) - NDIMR( IL ) - 1
NDIML( IR ) = NDIMR( NCRNT ) / 2
NDIMR( IR ) = NDIMR( NCRNT ) - NDIML( IR ) - 1
INODE( IR ) = INODE( NCRNT ) + NDIML( IR ) + 1
10 CONTINUE
LLST = LLST*2
20 CONTINUE
ND = LLST*2 - 1
*
RETURN
*
* End of SLASDT
*
END
SUBROUTINE SLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDA, M, N
REAL ALPHA, BETA
* ..
* .. Array Arguments ..
REAL A( LDA, * )
* ..
*
* Purpose
* =======
*
* SLASET initializes an m-by-n matrix A to BETA on the diagonal and
* ALPHA on the offdiagonals.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies the part of the matrix A to be set.
* = 'U': Upper triangular part is set; the strictly lower
* triangular part of A is not changed.
* = 'L': Lower triangular part is set; the strictly upper
* triangular part of A is not changed.
* Otherwise: All of the matrix A is set.
*
* 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.
*
* ALPHA (input) REAL
* The constant to which the offdiagonal elements are to be set.
*
* BETA (input) REAL
* The constant to which the diagonal elements are to be set.
*
* A (input/output) REAL array, dimension (LDA,N)
* On exit, the leading m-by-n submatrix of A is set as follows:
*
* if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n,
* if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n,
* otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j,
*
* and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n).
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Set the strictly upper triangular or trapezoidal part of the
* array to ALPHA.
*
DO 20 J = 2, N
DO 10 I = 1, MIN( J-1, M )
A( I, J ) = ALPHA
10 CONTINUE
20 CONTINUE
*
ELSE IF( LSAME( UPLO, 'L' ) ) THEN
*
* Set the strictly lower triangular or trapezoidal part of the
* array to ALPHA.
*
DO 40 J = 1, MIN( M, N )
DO 30 I = J + 1, M
A( I, J ) = ALPHA
30 CONTINUE
40 CONTINUE
*
ELSE
*
* Set the leading m-by-n submatrix to ALPHA.
*
DO 60 J = 1, N
DO 50 I = 1, M
A( I, J ) = ALPHA
50 CONTINUE
60 CONTINUE
END IF
*
* Set the first min(M,N) diagonal elements to BETA.
*
DO 70 I = 1, MIN( M, N )
A( I, I ) = BETA
70 CONTINUE
*
RETURN
*
* End of SLASET
*
END
SUBROUTINE SLASQ1( N, D, E, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, N
* ..
* .. Array Arguments ..
REAL D( * ), E( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SLASQ1 computes the singular values of a real N-by-N bidiagonal
* matrix with diagonal D and off-diagonal E. The singular values
* are computed to high relative accuracy, in the absence of
* denormalization, underflow and overflow. The algorithm was first
* presented in
*
* "Accurate singular values and differential qd algorithms" by K. V.
* Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230,
* 1994,
*
* and the present implementation is described in "An implementation of
* the dqds Algorithm (Positive Case)", LAPACK Working Note.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of rows and columns in the matrix. N >= 0.
*
* D (input/output) REAL array, dimension (N)
* On entry, D contains the diagonal elements of the
* bidiagonal matrix whose SVD is desired. On normal exit,
* D contains the singular values in decreasing order.
*
* E (input/output) REAL array, dimension (N)
* On entry, elements E(1:N-1) contain the off-diagonal elements
* of the bidiagonal matrix whose SVD is desired.
* On exit, E is overwritten.
*
* WORK (workspace) REAL array, dimension (4*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: the algorithm failed
* = 1, a split was marked by a positive value in E
* = 2, current block of Z not diagonalized after 30*N
* iterations (in inner while loop)
* = 3, termination criterion of outer while loop not met
* (program created more than N unreduced blocks)
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
INTEGER I, IINFO
REAL EPS, SCALE, SAFMIN, SIGMN, SIGMX
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLAS2, SLASCL, SLASQ2, SLASRT, XERBLA
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -2
CALL XERBLA( 'SLASQ1', -INFO )
RETURN
ELSE IF( N.EQ.0 ) THEN
RETURN
ELSE IF( N.EQ.1 ) THEN
D( 1 ) = ABS( D( 1 ) )
RETURN
ELSE IF( N.EQ.2 ) THEN
CALL SLAS2( D( 1 ), E( 1 ), D( 2 ), SIGMN, SIGMX )
D( 1 ) = SIGMX
D( 2 ) = SIGMN
RETURN
END IF
*
* Estimate the largest singular value.
*
SIGMX = ZERO
DO 10 I = 1, N - 1
D( I ) = ABS( D( I ) )
SIGMX = MAX( SIGMX, ABS( E( I ) ) )
10 CONTINUE
D( N ) = ABS( D( N ) )
*
* Early return if SIGMX is zero (matrix is already diagonal).
*
IF( SIGMX.EQ.ZERO ) THEN
CALL SLASRT( 'D', N, D, IINFO )
RETURN
END IF
*
DO 20 I = 1, N
SIGMX = MAX( SIGMX, D( I ) )
20 CONTINUE
*
* Copy D and E into WORK (in the Z format) and scale (squaring the
* input data makes scaling by a power of the radix pointless).
*
EPS = SLAMCH( 'Precision' )
SAFMIN = SLAMCH( 'Safe minimum' )
SCALE = SQRT( EPS / SAFMIN )
CALL SCOPY( N, D, 1, WORK( 1 ), 2 )
CALL SCOPY( N-1, E, 1, WORK( 2 ), 2 )
CALL SLASCL( 'G', 0, 0, SIGMX, SCALE, 2*N-1, 1, WORK, 2*N-1,
$ IINFO )
*
* Compute the q's and e's.
*
DO 30 I = 1, 2*N - 1
WORK( I ) = WORK( I )**2
30 CONTINUE
WORK( 2*N ) = ZERO
*
CALL SLASQ2( N, WORK, INFO )
*
IF( INFO.EQ.0 ) THEN
DO 40 I = 1, N
D( I ) = SQRT( WORK( I ) )
40 CONTINUE
CALL SLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, D, N, IINFO )
END IF
*
RETURN
*
* End of SLASQ1
*
END
SUBROUTINE SLASQ2( N, Z, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call SLAZQ3 in place of SLASQ3, 13 Feb 03, SJH.
*
* .. Scalar Arguments ..
INTEGER INFO, N
* ..
* .. Array Arguments ..
REAL Z( * )
* ..
*
* Purpose
* =======
*
* SLASQ2 computes all the eigenvalues of the symmetric positive
* definite tridiagonal matrix associated with the qd array Z to high
* relative accuracy are computed to high relative accuracy, in the
* absence of denormalization, underflow and overflow.
*
* To see the relation of Z to the tridiagonal matrix, let L be a
* unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and
* let U be an upper bidiagonal matrix with 1's above and diagonal
* Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the
* symmetric tridiagonal to which it is similar.
*
* Note : SLASQ2 defines a logical variable, IEEE, which is true
* on machines which follow ieee-754 floating-point standard in their
* handling of infinities and NaNs, and false otherwise. This variable
* is passed to SLAZQ3.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of rows and columns in the matrix. N >= 0.
*
* Z (workspace) REAL array, dimension (4*N)
* On entry Z holds the qd array. On exit, entries 1 to N hold
* the eigenvalues in decreasing order, Z( 2*N+1 ) holds the
* trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If
* N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 )
* holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of
* shifts that failed.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if the i-th argument is a scalar and had an illegal
* value, then INFO = -i, if the i-th argument is an
* array and the j-entry had an illegal value, then
* INFO = -(i*100+j)
* > 0: the algorithm failed
* = 1, a split was marked by a positive value in E
* = 2, current block of Z not diagonalized after 30*N
* iterations (in inner while loop)
* = 3, termination criterion of outer while loop not met
* (program created more than N unreduced blocks)
*
* Further Details
* ===============
* Local Variables: I0:N0 defines a current unreduced segment of Z.
* The shifts are accumulated in SIGMA. Iteration count is in ITER.
* Ping-pong is controlled by PP (alternates between 0 and 1).
*
* =====================================================================
*
* .. Parameters ..
REAL CBIAS
PARAMETER ( CBIAS = 1.50E0 )
REAL ZERO, HALF, ONE, TWO, FOUR, HUNDRD
PARAMETER ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0,
$ TWO = 2.0E0, FOUR = 4.0E0, HUNDRD = 100.0E0 )
* ..
* .. Local Scalars ..
LOGICAL IEEE
INTEGER I0, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, K,
$ N0, NBIG, NDIV, NFAIL, PP, SPLT, TTYPE
REAL D, DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, E,
$ EMAX, EMIN, EPS, OLDEMN, QMAX, QMIN, S, SAFMIN,
$ SIGMA, T, TAU, TEMP, TOL, TOL2, TRACE, ZMAX
* ..
* .. External Subroutines ..
EXTERNAL SLAZQ3, SLASRT, XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
REAL SLAMCH
EXTERNAL ILAENV, SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL, SQRT
* ..
* .. Executable Statements ..
*
* Test the input arguments.
* (in case SLASQ2 is not called by SLASQ1)
*
INFO = 0
EPS = SLAMCH( 'Precision' )
SAFMIN = SLAMCH( 'Safe minimum' )
TOL = EPS*HUNDRD
TOL2 = TOL**2
*
IF( N.LT.0 ) THEN
INFO = -1
CALL XERBLA( 'SLASQ2', 1 )
RETURN
ELSE IF( N.EQ.0 ) THEN
RETURN
ELSE IF( N.EQ.1 ) THEN
*
* 1-by-1 case.
*
IF( Z( 1 ).LT.ZERO ) THEN
INFO = -201
CALL XERBLA( 'SLASQ2', 2 )
END IF
RETURN
ELSE IF( N.EQ.2 ) THEN
*
* 2-by-2 case.
*
IF( Z( 2 ).LT.ZERO .OR. Z( 3 ).LT.ZERO ) THEN
INFO = -2
CALL XERBLA( 'SLASQ2', 2 )
RETURN
ELSE IF( Z( 3 ).GT.Z( 1 ) ) THEN
D = Z( 3 )
Z( 3 ) = Z( 1 )
Z( 1 ) = D
END IF
Z( 5 ) = Z( 1 ) + Z( 2 ) + Z( 3 )
IF( Z( 2 ).GT.Z( 3 )*TOL2 ) THEN
T = HALF*( ( Z( 1 )-Z( 3 ) )+Z( 2 ) )
S = Z( 3 )*( Z( 2 ) / T )
IF( S.LE.T ) THEN
S = Z( 3 )*( Z( 2 ) / ( T*( ONE+SQRT( ONE+S / T ) ) ) )
ELSE
S = Z( 3 )*( Z( 2 ) / ( T+SQRT( T )*SQRT( T+S ) ) )
END IF
T = Z( 1 ) + ( S+Z( 2 ) )
Z( 3 ) = Z( 3 )*( Z( 1 ) / T )
Z( 1 ) = T
END IF
Z( 2 ) = Z( 3 )
Z( 6 ) = Z( 2 ) + Z( 1 )
RETURN
END IF
*
* Check for negative data and compute sums of q's and e's.
*
Z( 2*N ) = ZERO
EMIN = Z( 2 )
QMAX = ZERO
ZMAX = ZERO
D = ZERO
E = ZERO
*
DO 10 K = 1, 2*( N-1 ), 2
IF( Z( K ).LT.ZERO ) THEN
INFO = -( 200+K )
CALL XERBLA( 'SLASQ2', 2 )
RETURN
ELSE IF( Z( K+1 ).LT.ZERO ) THEN
INFO = -( 200+K+1 )
CALL XERBLA( 'SLASQ2', 2 )
RETURN
END IF
D = D + Z( K )
E = E + Z( K+1 )
QMAX = MAX( QMAX, Z( K ) )
EMIN = MIN( EMIN, Z( K+1 ) )
ZMAX = MAX( QMAX, ZMAX, Z( K+1 ) )
10 CONTINUE
IF( Z( 2*N-1 ).LT.ZERO ) THEN
INFO = -( 200+2*N-1 )
CALL XERBLA( 'SLASQ2', 2 )
RETURN
END IF
D = D + Z( 2*N-1 )
QMAX = MAX( QMAX, Z( 2*N-1 ) )
ZMAX = MAX( QMAX, ZMAX )
*
* Check for diagonality.
*
IF( E.EQ.ZERO ) THEN
DO 20 K = 2, N
Z( K ) = Z( 2*K-1 )
20 CONTINUE
CALL SLASRT( 'D', N, Z, IINFO )
Z( 2*N-1 ) = D
RETURN
END IF
*
TRACE = D + E
*
* Check for zero data.
*
IF( TRACE.EQ.ZERO ) THEN
Z( 2*N-1 ) = ZERO
RETURN
END IF
*
* Check whether the machine is IEEE conformable.
*
IEEE = ILAENV( 10, 'SLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 .AND.
$ ILAENV( 11, 'SLASQ2', 'N', 1, 2, 3, 4 ).EQ.1
*
* Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...).
*
DO 30 K = 2*N, 2, -2
Z( 2*K ) = ZERO
Z( 2*K-1 ) = Z( K )
Z( 2*K-2 ) = ZERO
Z( 2*K-3 ) = Z( K-1 )
30 CONTINUE
*
I0 = 1
N0 = N
*
* Reverse the qd-array, if warranted.
*
IF( CBIAS*Z( 4*I0-3 ).LT.Z( 4*N0-3 ) ) THEN
IPN4 = 4*( I0+N0 )
DO 40 I4 = 4*I0, 2*( I0+N0-1 ), 4
TEMP = Z( I4-3 )
Z( I4-3 ) = Z( IPN4-I4-3 )
Z( IPN4-I4-3 ) = TEMP
TEMP = Z( I4-1 )
Z( I4-1 ) = Z( IPN4-I4-5 )
Z( IPN4-I4-5 ) = TEMP
40 CONTINUE
END IF
*
* Initial split checking via dqd and Li's test.
*
PP = 0
*
DO 80 K = 1, 2
*
D = Z( 4*N0+PP-3 )
DO 50 I4 = 4*( N0-1 ) + PP, 4*I0 + PP, -4
IF( Z( I4-1 ).LE.TOL2*D ) THEN
Z( I4-1 ) = -ZERO
D = Z( I4-3 )
ELSE
D = Z( I4-3 )*( D / ( D+Z( I4-1 ) ) )
END IF
50 CONTINUE
*
* dqd maps Z to ZZ plus Li's test.
*
EMIN = Z( 4*I0+PP+1 )
D = Z( 4*I0+PP-3 )
DO 60 I4 = 4*I0 + PP, 4*( N0-1 ) + PP, 4
Z( I4-2*PP-2 ) = D + Z( I4-1 )
IF( Z( I4-1 ).LE.TOL2*D ) THEN
Z( I4-1 ) = -ZERO
Z( I4-2*PP-2 ) = D
Z( I4-2*PP ) = ZERO
D = Z( I4+1 )
ELSE IF( SAFMIN*Z( I4+1 ).LT.Z( I4-2*PP-2 ) .AND.
$ SAFMIN*Z( I4-2*PP-2 ).LT.Z( I4+1 ) ) THEN
TEMP = Z( I4+1 ) / Z( I4-2*PP-2 )
Z( I4-2*PP ) = Z( I4-1 )*TEMP
D = D*TEMP
ELSE
Z( I4-2*PP ) = Z( I4+1 )*( Z( I4-1 ) / Z( I4-2*PP-2 ) )
D = Z( I4+1 )*( D / Z( I4-2*PP-2 ) )
END IF
EMIN = MIN( EMIN, Z( I4-2*PP ) )
60 CONTINUE
Z( 4*N0-PP-2 ) = D
*
* Now find qmax.
*
QMAX = Z( 4*I0-PP-2 )
DO 70 I4 = 4*I0 - PP + 2, 4*N0 - PP - 2, 4
QMAX = MAX( QMAX, Z( I4 ) )
70 CONTINUE
*
* Prepare for the next iteration on K.
*
PP = 1 - PP
80 CONTINUE
*
* Initialise variables to pass to SLAZQ3
*
TTYPE = 0
DMIN1 = ZERO
DMIN2 = ZERO
DN = ZERO
DN1 = ZERO
DN2 = ZERO
TAU = ZERO
*
ITER = 2
NFAIL = 0
NDIV = 2*( N0-I0 )
*
DO 140 IWHILA = 1, N + 1
IF( N0.LT.1 )
$ GO TO 150
*
* While array unfinished do
*
* E(N0) holds the value of SIGMA when submatrix in I0:N0
* splits from the rest of the array, but is negated.
*
DESIG = ZERO
IF( N0.EQ.N ) THEN
SIGMA = ZERO
ELSE
SIGMA = -Z( 4*N0-1 )
END IF
IF( SIGMA.LT.ZERO ) THEN
INFO = 1
RETURN
END IF
*
* Find last unreduced submatrix's top index I0, find QMAX and
* EMIN. Find Gershgorin-type bound if Q's much greater than E's.
*
EMAX = ZERO
IF( N0.GT.I0 ) THEN
EMIN = ABS( Z( 4*N0-5 ) )
ELSE
EMIN = ZERO
END IF
QMIN = Z( 4*N0-3 )
QMAX = QMIN
DO 90 I4 = 4*N0, 8, -4
IF( Z( I4-5 ).LE.ZERO )
$ GO TO 100
IF( QMIN.GE.FOUR*EMAX ) THEN
QMIN = MIN( QMIN, Z( I4-3 ) )
EMAX = MAX( EMAX, Z( I4-5 ) )
END IF
QMAX = MAX( QMAX, Z( I4-7 )+Z( I4-5 ) )
EMIN = MIN( EMIN, Z( I4-5 ) )
90 CONTINUE
I4 = 4
*
100 CONTINUE
I0 = I4 / 4
*
* Store EMIN for passing to SLAZQ3.
*
Z( 4*N0-1 ) = EMIN
*
* Put -(initial shift) into DMIN.
*
DMIN = -MAX( ZERO, QMIN-TWO*SQRT( QMIN )*SQRT( EMAX ) )
*
* Now I0:N0 is unreduced. PP = 0 for ping, PP = 1 for pong.
*
PP = 0
*
NBIG = 30*( N0-I0+1 )
DO 120 IWHILB = 1, NBIG
IF( I0.GT.N0 )
$ GO TO 130
*
* While submatrix unfinished take a good dqds step.
*
CALL SLAZQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL,
$ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1,
$ DN2, TAU )
*
PP = 1 - PP
*
* When EMIN is very small check for splits.
*
IF( PP.EQ.0 .AND. N0-I0.GE.3 ) THEN
IF( Z( 4*N0 ).LE.TOL2*QMAX .OR.
$ Z( 4*N0-1 ).LE.TOL2*SIGMA ) THEN
SPLT = I0 - 1
QMAX = Z( 4*I0-3 )
EMIN = Z( 4*I0-1 )
OLDEMN = Z( 4*I0 )
DO 110 I4 = 4*I0, 4*( N0-3 ), 4
IF( Z( I4 ).LE.TOL2*Z( I4-3 ) .OR.
$ Z( I4-1 ).LE.TOL2*SIGMA ) THEN
Z( I4-1 ) = -SIGMA
SPLT = I4 / 4
QMAX = ZERO
EMIN = Z( I4+3 )
OLDEMN = Z( I4+4 )
ELSE
QMAX = MAX( QMAX, Z( I4+1 ) )
EMIN = MIN( EMIN, Z( I4-1 ) )
OLDEMN = MIN( OLDEMN, Z( I4 ) )
END IF
110 CONTINUE
Z( 4*N0-1 ) = EMIN
Z( 4*N0 ) = OLDEMN
I0 = SPLT + 1
END IF
END IF
*
120 CONTINUE
*
INFO = 2
RETURN
*
* end IWHILB
*
130 CONTINUE
*
140 CONTINUE
*
INFO = 3
RETURN
*
* end IWHILA
*
150 CONTINUE
*
* Move q's to the front.
*
DO 160 K = 2, N
Z( K ) = Z( 4*K-3 )
160 CONTINUE
*
* Sort and compute sum of eigenvalues.
*
CALL SLASRT( 'D', N, Z, IINFO )
*
E = ZERO
DO 170 K = N, 1, -1
E = E + Z( K )
170 CONTINUE
*
* Store trace, sum(eigenvalues) and information on performance.
*
Z( 2*N+1 ) = TRACE
Z( 2*N+2 ) = E
Z( 2*N+3 ) = REAL( ITER )
Z( 2*N+4 ) = REAL( NDIV ) / REAL( N**2 )
Z( 2*N+5 ) = HUNDRD*NFAIL / REAL( ITER )
RETURN
*
* End of SLASQ2
*
END
SUBROUTINE SLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL,
$ ITER, NDIV, IEEE )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL IEEE
INTEGER I0, ITER, N0, NDIV, NFAIL, PP
REAL DESIG, DMIN, QMAX, SIGMA
* ..
* .. Array Arguments ..
REAL Z( * )
* ..
*
* Purpose
* =======
*
* SLASQ3 checks for deflation, computes a shift (TAU) and calls dqds.
* In case of failure it changes shifts, and tries again until output
* is positive.
*
* Arguments
* =========
*
* I0 (input) INTEGER
* First index.
*
* N0 (input) INTEGER
* Last index.
*
* Z (input) REAL array, dimension ( 4*N )
* Z holds the qd array.
*
* PP (input) INTEGER
* PP=0 for ping, PP=1 for pong.
*
* DMIN (output) REAL
* Minimum value of d.
*
* SIGMA (output) REAL
* Sum of shifts used in current segment.
*
* DESIG (input/output) REAL
* Lower order part of SIGMA
*
* QMAX (input) REAL
* Maximum value of q.
*
* NFAIL (output) INTEGER
* Number of times shift was too big.
*
* ITER (output) INTEGER
* Number of iterations.
*
* NDIV (output) INTEGER
* Number of divisions.
*
* TTYPE (output) INTEGER
* Shift type.
*
* IEEE (input) LOGICAL
* Flag for IEEE or non IEEE arithmetic (passed to SLASQ5).
*
* =====================================================================
*
* .. Parameters ..
REAL CBIAS
PARAMETER ( CBIAS = 1.50E0 )
REAL ZERO, QURTR, HALF, ONE, TWO, HUNDRD
PARAMETER ( ZERO = 0.0E0, QURTR = 0.250E0, HALF = 0.5E0,
$ ONE = 1.0E0, TWO = 2.0E0, HUNDRD = 100.0E0 )
* ..
* .. Local Scalars ..
INTEGER IPN4, J4, N0IN, NN, TTYPE
REAL DMIN1, DMIN2, DN, DN1, DN2, EPS, S, SAFMIN, T,
$ TAU, TEMP, TOL, TOL2
* ..
* .. External Subroutines ..
EXTERNAL SLASQ4, SLASQ5, SLASQ6
* ..
* .. External Function ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Save statement ..
SAVE TTYPE
SAVE DMIN1, DMIN2, DN, DN1, DN2, TAU
* ..
* .. Data statement ..
DATA TTYPE / 0 /
DATA DMIN1 / ZERO /, DMIN2 / ZERO /, DN / ZERO /,
$ DN1 / ZERO /, DN2 / ZERO /, TAU / ZERO /
* ..
* .. Executable Statements ..
*
N0IN = N0
EPS = SLAMCH( 'Precision' )
SAFMIN = SLAMCH( 'Safe minimum' )
TOL = EPS*HUNDRD
TOL2 = TOL**2
*
* Check for deflation.
*
10 CONTINUE
*
IF( N0.LT.I0 )
$ RETURN
IF( N0.EQ.I0 )
$ GO TO 20
NN = 4*N0 + PP
IF( N0.EQ.( I0+1 ) )
$ GO TO 40
*
* Check whether E(N0-1) is negligible, 1 eigenvalue.
*
IF( Z( NN-5 ).GT.TOL2*( SIGMA+Z( NN-3 ) ) .AND.
$ Z( NN-2*PP-4 ).GT.TOL2*Z( NN-7 ) )
$ GO TO 30
*
20 CONTINUE
*
Z( 4*N0-3 ) = Z( 4*N0+PP-3 ) + SIGMA
N0 = N0 - 1
GO TO 10
*
* Check whether E(N0-2) is negligible, 2 eigenvalues.
*
30 CONTINUE
*
IF( Z( NN-9 ).GT.TOL2*SIGMA .AND.
$ Z( NN-2*PP-8 ).GT.TOL2*Z( NN-11 ) )
$ GO TO 50
*
40 CONTINUE
*
IF( Z( NN-3 ).GT.Z( NN-7 ) ) THEN
S = Z( NN-3 )
Z( NN-3 ) = Z( NN-7 )
Z( NN-7 ) = S
END IF
IF( Z( NN-5 ).GT.Z( NN-3 )*TOL2 ) THEN
T = HALF*( ( Z( NN-7 )-Z( NN-3 ) )+Z( NN-5 ) )
S = Z( NN-3 )*( Z( NN-5 ) / T )
IF( S.LE.T ) THEN
S = Z( NN-3 )*( Z( NN-5 ) /
$ ( T*( ONE+SQRT( ONE+S / T ) ) ) )
ELSE
S = Z( NN-3 )*( Z( NN-5 ) / ( T+SQRT( T )*SQRT( T+S ) ) )
END IF
T = Z( NN-7 ) + ( S+Z( NN-5 ) )
Z( NN-3 ) = Z( NN-3 )*( Z( NN-7 ) / T )
Z( NN-7 ) = T
END IF
Z( 4*N0-7 ) = Z( NN-7 ) + SIGMA
Z( 4*N0-3 ) = Z( NN-3 ) + SIGMA
N0 = N0 - 2
GO TO 10
*
50 CONTINUE
*
* Reverse the qd-array, if warranted.
*
IF( DMIN.LE.ZERO .OR. N0.LT.N0IN ) THEN
IF( CBIAS*Z( 4*I0+PP-3 ).LT.Z( 4*N0+PP-3 ) ) THEN
IPN4 = 4*( I0+N0 )
DO 60 J4 = 4*I0, 2*( I0+N0-1 ), 4
TEMP = Z( J4-3 )
Z( J4-3 ) = Z( IPN4-J4-3 )
Z( IPN4-J4-3 ) = TEMP
TEMP = Z( J4-2 )
Z( J4-2 ) = Z( IPN4-J4-2 )
Z( IPN4-J4-2 ) = TEMP
TEMP = Z( J4-1 )
Z( J4-1 ) = Z( IPN4-J4-5 )
Z( IPN4-J4-5 ) = TEMP
TEMP = Z( J4 )
Z( J4 ) = Z( IPN4-J4-4 )
Z( IPN4-J4-4 ) = TEMP
60 CONTINUE
IF( N0-I0.LE.4 ) THEN
Z( 4*N0+PP-1 ) = Z( 4*I0+PP-1 )
Z( 4*N0-PP ) = Z( 4*I0-PP )
END IF
DMIN2 = MIN( DMIN2, Z( 4*N0+PP-1 ) )
Z( 4*N0+PP-1 ) = MIN( Z( 4*N0+PP-1 ), Z( 4*I0+PP-1 ),
$ Z( 4*I0+PP+3 ) )
Z( 4*N0-PP ) = MIN( Z( 4*N0-PP ), Z( 4*I0-PP ),
$ Z( 4*I0-PP+4 ) )
QMAX = MAX( QMAX, Z( 4*I0+PP-3 ), Z( 4*I0+PP+1 ) )
DMIN = -ZERO
END IF
END IF
*
IF( DMIN.LT.ZERO .OR. SAFMIN*QMAX.LT.MIN( Z( 4*N0+PP-1 ),
$ Z( 4*N0+PP-9 ), DMIN2+Z( 4*N0-PP ) ) ) THEN
*
* Choose a shift.
*
CALL SLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1,
$ DN2, TAU, TTYPE )
*
* Call dqds until DMIN > 0.
*
80 CONTINUE
*
CALL SLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN,
$ DN1, DN2, IEEE )
*
NDIV = NDIV + ( N0-I0+2 )
ITER = ITER + 1
*
* Check status.
*
IF( DMIN.GE.ZERO .AND. DMIN1.GT.ZERO ) THEN
*
* Success.
*
GO TO 100
*
ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND.
$ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND.
$ ABS( DN ).LT.TOL*SIGMA ) THEN
*
* Convergence hidden by negative DN.
*
Z( 4*( N0-1 )-PP+2 ) = ZERO
DMIN = ZERO
GO TO 100
ELSE IF( DMIN.LT.ZERO ) THEN
*
* TAU too big. Select new TAU and try again.
*
NFAIL = NFAIL + 1
IF( TTYPE.LT.-22 ) THEN
*
* Failed twice. Play it safe.
*
TAU = ZERO
ELSE IF( DMIN1.GT.ZERO ) THEN
*
* Late failure. Gives excellent shift.
*
TAU = ( TAU+DMIN )*( ONE-TWO*EPS )
TTYPE = TTYPE - 11
ELSE
*
* Early failure. Divide by 4.
*
TAU = QURTR*TAU
TTYPE = TTYPE - 12
END IF
GO TO 80
ELSE IF( DMIN.NE.DMIN ) THEN
*
* NaN.
*
TAU = ZERO
GO TO 80
ELSE
*
* Possible underflow. Play it safe.
*
GO TO 90
END IF
END IF
*
* Risk of underflow.
*
90 CONTINUE
CALL SLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 )
NDIV = NDIV + ( N0-I0+2 )
ITER = ITER + 1
TAU = ZERO
*
100 CONTINUE
IF( TAU.LT.SIGMA ) THEN
DESIG = DESIG + TAU
T = SIGMA + DESIG
DESIG = DESIG - ( T-SIGMA )
ELSE
T = SIGMA + TAU
DESIG = SIGMA - ( T-TAU ) + DESIG
END IF
SIGMA = T
*
RETURN
*
* End of SLASQ3
*
END
SUBROUTINE SLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN,
$ DN1, DN2, TAU, TTYPE )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER I0, N0, N0IN, PP, TTYPE
REAL DMIN, DMIN1, DMIN2, DN, DN1, DN2, TAU
* ..
* .. Array Arguments ..
REAL Z( * )
* ..
*
* Purpose
* =======
*
* SLASQ4 computes an approximation TAU to the smallest eigenvalue
* using values of d from the previous transform.
*
* I0 (input) INTEGER
* First index.
*
* N0 (input) INTEGER
* Last index.
*
* Z (input) REAL array, dimension ( 4*N )
* Z holds the qd array.
*
* PP (input) INTEGER
* PP=0 for ping, PP=1 for pong.
*
* N0IN (input) INTEGER
* The value of N0 at start of EIGTEST.
*
* DMIN (input) REAL
* Minimum value of d.
*
* DMIN1 (input) REAL
* Minimum value of d, excluding D( N0 ).
*
* DMIN2 (input) REAL
* Minimum value of d, excluding D( N0 ) and D( N0-1 ).
*
* DN (input) REAL
* d(N)
*
* DN1 (input) REAL
* d(N-1)
*
* DN2 (input) REAL
* d(N-2)
*
* TAU (output) REAL
* This is the shift.
*
* TTYPE (output) INTEGER
* Shift type.
*
* Further Details
* ===============
* CNST1 = 9/16
*
* =====================================================================
*
* .. Parameters ..
REAL CNST1, CNST2, CNST3
PARAMETER ( CNST1 = 0.5630E0, CNST2 = 1.010E0,
$ CNST3 = 1.050E0 )
REAL QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD
PARAMETER ( QURTR = 0.250E0, THIRD = 0.3330E0,
$ HALF = 0.50E0, ZERO = 0.0E0, ONE = 1.0E0,
$ TWO = 2.0E0, HUNDRD = 100.0E0 )
* ..
* .. Local Scalars ..
INTEGER I4, NN, NP
REAL A2, B1, B2, G, GAM, GAP1, GAP2, S
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Save statement ..
SAVE G
* ..
* .. Data statement ..
DATA G / ZERO /
* ..
* .. Executable Statements ..
*
* A negative DMIN forces the shift to take that absolute value
* TTYPE records the type of shift.
*
IF( DMIN.LE.ZERO ) THEN
TAU = -DMIN
TTYPE = -1
RETURN
END IF
*
NN = 4*N0 + PP
IF( N0IN.EQ.N0 ) THEN
*
* No eigenvalues deflated.
*
IF( DMIN.EQ.DN .OR. DMIN.EQ.DN1 ) THEN
*
B1 = SQRT( Z( NN-3 ) )*SQRT( Z( NN-5 ) )
B2 = SQRT( Z( NN-7 ) )*SQRT( Z( NN-9 ) )
A2 = Z( NN-7 ) + Z( NN-5 )
*
* Cases 2 and 3.
*
IF( DMIN.EQ.DN .AND. DMIN1.EQ.DN1 ) THEN
GAP2 = DMIN2 - A2 - DMIN2*QURTR
IF( GAP2.GT.ZERO .AND. GAP2.GT.B2 ) THEN
GAP1 = A2 - DN - ( B2 / GAP2 )*B2
ELSE
GAP1 = A2 - DN - ( B1+B2 )
END IF
IF( GAP1.GT.ZERO .AND. GAP1.GT.B1 ) THEN
S = MAX( DN-( B1 / GAP1 )*B1, HALF*DMIN )
TTYPE = -2
ELSE
S = ZERO
IF( DN.GT.B1 )
$ S = DN - B1
IF( A2.GT.( B1+B2 ) )
$ S = MIN( S, A2-( B1+B2 ) )
S = MAX( S, THIRD*DMIN )
TTYPE = -3
END IF
ELSE
*
* Case 4.
*
TTYPE = -4
S = QURTR*DMIN
IF( DMIN.EQ.DN ) THEN
GAM = DN
A2 = ZERO
IF( Z( NN-5 ) .GT. Z( NN-7 ) )
$ RETURN
B2 = Z( NN-5 ) / Z( NN-7 )
NP = NN - 9
ELSE
NP = NN - 2*PP
B2 = Z( NP-2 )
GAM = DN1
IF( Z( NP-4 ) .GT. Z( NP-2 ) )
$ RETURN
A2 = Z( NP-4 ) / Z( NP-2 )
IF( Z( NN-9 ) .GT. Z( NN-11 ) )
$ RETURN
B2 = Z( NN-9 ) / Z( NN-11 )
NP = NN - 13
END IF
*
* Approximate contribution to norm squared from I < NN-1.
*
A2 = A2 + B2
DO 10 I4 = NP, 4*I0 - 1 + PP, -4
IF( B2.EQ.ZERO )
$ GO TO 20
B1 = B2
IF( Z( I4 ) .GT. Z( I4-2 ) )
$ RETURN
B2 = B2*( Z( I4 ) / Z( I4-2 ) )
A2 = A2 + B2
IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 )
$ GO TO 20
10 CONTINUE
20 CONTINUE
A2 = CNST3*A2
*
* Rayleigh quotient residual bound.
*
IF( A2.LT.CNST1 )
$ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 )
END IF
ELSE IF( DMIN.EQ.DN2 ) THEN
*
* Case 5.
*
TTYPE = -5
S = QURTR*DMIN
*
* Compute contribution to norm squared from I > NN-2.
*
NP = NN - 2*PP
B1 = Z( NP-2 )
B2 = Z( NP-6 )
GAM = DN2
IF( Z( NP-8 ).GT.B2 .OR. Z( NP-4 ).GT.B1 )
$ RETURN
A2 = ( Z( NP-8 ) / B2 )*( ONE+Z( NP-4 ) / B1 )
*
* Approximate contribution to norm squared from I < NN-2.
*
IF( N0-I0.GT.2 ) THEN
B2 = Z( NN-13 ) / Z( NN-15 )
A2 = A2 + B2
DO 30 I4 = NN - 17, 4*I0 - 1 + PP, -4
IF( B2.EQ.ZERO )
$ GO TO 40
B1 = B2
IF( Z( I4 ) .GT. Z( I4-2 ) )
$ RETURN
B2 = B2*( Z( I4 ) / Z( I4-2 ) )
A2 = A2 + B2
IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 )
$ GO TO 40
30 CONTINUE
40 CONTINUE
A2 = CNST3*A2
END IF
*
IF( A2.LT.CNST1 )
$ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 )
ELSE
*
* Case 6, no information to guide us.
*
IF( TTYPE.EQ.-6 ) THEN
G = G + THIRD*( ONE-G )
ELSE IF( TTYPE.EQ.-18 ) THEN
G = QURTR*THIRD
ELSE
G = QURTR
END IF
S = G*DMIN
TTYPE = -6
END IF
*
ELSE IF( N0IN.EQ.( N0+1 ) ) THEN
*
* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN.
*
IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN
*
* Cases 7 and 8.
*
TTYPE = -7
S = THIRD*DMIN1
IF( Z( NN-5 ).GT.Z( NN-7 ) )
$ RETURN
B1 = Z( NN-5 ) / Z( NN-7 )
B2 = B1
IF( B2.EQ.ZERO )
$ GO TO 60
DO 50 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4
A2 = B1
IF( Z( I4 ).GT.Z( I4-2 ) )
$ RETURN
B1 = B1*( Z( I4 ) / Z( I4-2 ) )
B2 = B2 + B1
IF( HUNDRD*MAX( B1, A2 ).LT.B2 )
$ GO TO 60
50 CONTINUE
60 CONTINUE
B2 = SQRT( CNST3*B2 )
A2 = DMIN1 / ( ONE+B2**2 )
GAP2 = HALF*DMIN2 - A2
IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN
S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) )
ELSE
S = MAX( S, A2*( ONE-CNST2*B2 ) )
TTYPE = -8
END IF
ELSE
*
* Case 9.
*
S = QURTR*DMIN1
IF( DMIN1.EQ.DN1 )
$ S = HALF*DMIN1
TTYPE = -9
END IF
*
ELSE IF( N0IN.EQ.( N0+2 ) ) THEN
*
* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN.
*
* Cases 10 and 11.
*
IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN
TTYPE = -10
S = THIRD*DMIN2
IF( Z( NN-5 ).GT.Z( NN-7 ) )
$ RETURN
B1 = Z( NN-5 ) / Z( NN-7 )
B2 = B1
IF( B2.EQ.ZERO )
$ GO TO 80
DO 70 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4
IF( Z( I4 ).GT.Z( I4-2 ) )
$ RETURN
B1 = B1*( Z( I4 ) / Z( I4-2 ) )
B2 = B2 + B1
IF( HUNDRD*B1.LT.B2 )
$ GO TO 80
70 CONTINUE
80 CONTINUE
B2 = SQRT( CNST3*B2 )
A2 = DMIN2 / ( ONE+B2**2 )
GAP2 = Z( NN-7 ) + Z( NN-9 ) -
$ SQRT( Z( NN-11 ) )*SQRT( Z( NN-9 ) ) - A2
IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN
S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) )
ELSE
S = MAX( S, A2*( ONE-CNST2*B2 ) )
END IF
ELSE
S = QURTR*DMIN2
TTYPE = -11
END IF
ELSE IF( N0IN.GT.( N0+2 ) ) THEN
*
* Case 12, more than two eigenvalues deflated. No information.
*
S = ZERO
TTYPE = -12
END IF
*
TAU = S
RETURN
*
* End of SLASQ4
*
END
SUBROUTINE SLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN,
$ DNM1, DNM2, IEEE )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL IEEE
INTEGER I0, N0, PP
REAL DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU
* ..
* .. Array Arguments ..
REAL Z( * )
* ..
*
* Purpose
* =======
*
* SLASQ5 computes one dqds transform in ping-pong form, one
* version for IEEE machines another for non IEEE machines.
*
* Arguments
* =========
*
* I0 (input) INTEGER
* First index.
*
* N0 (input) INTEGER
* Last index.
*
* Z (input) REAL array, dimension ( 4*N )
* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid
* an extra argument.
*
* PP (input) INTEGER
* PP=0 for ping, PP=1 for pong.
*
* TAU (input) REAL
* This is the shift.
*
* DMIN (output) REAL
* Minimum value of d.
*
* DMIN1 (output) REAL
* Minimum value of d, excluding D( N0 ).
*
* DMIN2 (output) REAL
* Minimum value of d, excluding D( N0 ) and D( N0-1 ).
*
* DN (output) REAL
* d(N0), the last value of d.
*
* DNM1 (output) REAL
* d(N0-1).
*
* DNM2 (output) REAL
* d(N0-2).
*
* IEEE (input) LOGICAL
* Flag for IEEE or non IEEE arithmetic.
*
* =====================================================================
*
* .. Parameter ..
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
INTEGER J4, J4P2
REAL D, EMIN, TEMP
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
IF( ( N0-I0-1 ).LE.0 )
$ RETURN
*
J4 = 4*I0 + PP - 3
EMIN = Z( J4+4 )
D = Z( J4 ) - TAU
DMIN = D
DMIN1 = -Z( J4 )
*
IF( IEEE ) THEN
*
* Code for IEEE arithmetic.
*
IF( PP.EQ.0 ) THEN
DO 10 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-2 ) = D + Z( J4-1 )
TEMP = Z( J4+1 ) / Z( J4-2 )
D = D*TEMP - TAU
DMIN = MIN( DMIN, D )
Z( J4 ) = Z( J4-1 )*TEMP
EMIN = MIN( Z( J4 ), EMIN )
10 CONTINUE
ELSE
DO 20 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-3 ) = D + Z( J4 )
TEMP = Z( J4+2 ) / Z( J4-3 )
D = D*TEMP - TAU
DMIN = MIN( DMIN, D )
Z( J4-1 ) = Z( J4 )*TEMP
EMIN = MIN( Z( J4-1 ), EMIN )
20 CONTINUE
END IF
*
* Unroll last two steps.
*
DNM2 = D
DMIN2 = DMIN
J4 = 4*( N0-2 ) - PP
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM2 + Z( J4P2 )
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU
DMIN = MIN( DMIN, DNM1 )
*
DMIN1 = DMIN
J4 = J4 + 4
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM1 + Z( J4P2 )
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU
DMIN = MIN( DMIN, DN )
*
ELSE
*
* Code for non IEEE arithmetic.
*
IF( PP.EQ.0 ) THEN
DO 30 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-2 ) = D + Z( J4-1 )
IF( D.LT.ZERO ) THEN
RETURN
ELSE
Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) )
D = Z( J4+1 )*( D / Z( J4-2 ) ) - TAU
END IF
DMIN = MIN( DMIN, D )
EMIN = MIN( EMIN, Z( J4 ) )
30 CONTINUE
ELSE
DO 40 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-3 ) = D + Z( J4 )
IF( D.LT.ZERO ) THEN
RETURN
ELSE
Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) )
D = Z( J4+2 )*( D / Z( J4-3 ) ) - TAU
END IF
DMIN = MIN( DMIN, D )
EMIN = MIN( EMIN, Z( J4-1 ) )
40 CONTINUE
END IF
*
* Unroll last two steps.
*
DNM2 = D
DMIN2 = DMIN
J4 = 4*( N0-2 ) - PP
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM2 + Z( J4P2 )
IF( DNM2.LT.ZERO ) THEN
RETURN
ELSE
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU
END IF
DMIN = MIN( DMIN, DNM1 )
*
DMIN1 = DMIN
J4 = J4 + 4
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM1 + Z( J4P2 )
IF( DNM1.LT.ZERO ) THEN
RETURN
ELSE
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU
END IF
DMIN = MIN( DMIN, DN )
*
END IF
*
Z( J4+2 ) = DN
Z( 4*N0-PP ) = EMIN
RETURN
*
* End of SLASQ5
*
END
SUBROUTINE SLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN,
$ DNM1, DNM2 )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER I0, N0, PP
REAL DMIN, DMIN1, DMIN2, DN, DNM1, DNM2
* ..
* .. Array Arguments ..
REAL Z( * )
* ..
*
* Purpose
* =======
*
* SLASQ6 computes one dqd (shift equal to zero) transform in
* ping-pong form, with protection against underflow and overflow.
*
* Arguments
* =========
*
* I0 (input) INTEGER
* First index.
*
* N0 (input) INTEGER
* Last index.
*
* Z (input) REAL array, dimension ( 4*N )
* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid
* an extra argument.
*
* PP (input) INTEGER
* PP=0 for ping, PP=1 for pong.
*
* DMIN (output) REAL
* Minimum value of d.
*
* DMIN1 (output) REAL
* Minimum value of d, excluding D( N0 ).
*
* DMIN2 (output) REAL
* Minimum value of d, excluding D( N0 ) and D( N0-1 ).
*
* DN (output) REAL
* d(N0), the last value of d.
*
* DNM1 (output) REAL
* d(N0-1).
*
* DNM2 (output) REAL
* d(N0-2).
*
* =====================================================================
*
* .. Parameter ..
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
INTEGER J4, J4P2
REAL D, EMIN, SAFMIN, TEMP
* ..
* .. External Function ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
IF( ( N0-I0-1 ).LE.0 )
$ RETURN
*
SAFMIN = SLAMCH( 'Safe minimum' )
J4 = 4*I0 + PP - 3
EMIN = Z( J4+4 )
D = Z( J4 )
DMIN = D
*
IF( PP.EQ.0 ) THEN
DO 10 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-2 ) = D + Z( J4-1 )
IF( Z( J4-2 ).EQ.ZERO ) THEN
Z( J4 ) = ZERO
D = Z( J4+1 )
DMIN = D
EMIN = ZERO
ELSE IF( SAFMIN*Z( J4+1 ).LT.Z( J4-2 ) .AND.
$ SAFMIN*Z( J4-2 ).LT.Z( J4+1 ) ) THEN
TEMP = Z( J4+1 ) / Z( J4-2 )
Z( J4 ) = Z( J4-1 )*TEMP
D = D*TEMP
ELSE
Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) )
D = Z( J4+1 )*( D / Z( J4-2 ) )
END IF
DMIN = MIN( DMIN, D )
EMIN = MIN( EMIN, Z( J4 ) )
10 CONTINUE
ELSE
DO 20 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-3 ) = D + Z( J4 )
IF( Z( J4-3 ).EQ.ZERO ) THEN
Z( J4-1 ) = ZERO
D = Z( J4+2 )
DMIN = D
EMIN = ZERO
ELSE IF( SAFMIN*Z( J4+2 ).LT.Z( J4-3 ) .AND.
$ SAFMIN*Z( J4-3 ).LT.Z( J4+2 ) ) THEN
TEMP = Z( J4+2 ) / Z( J4-3 )
Z( J4-1 ) = Z( J4 )*TEMP
D = D*TEMP
ELSE
Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) )
D = Z( J4+2 )*( D / Z( J4-3 ) )
END IF
DMIN = MIN( DMIN, D )
EMIN = MIN( EMIN, Z( J4-1 ) )
20 CONTINUE
END IF
*
* Unroll last two steps.
*
DNM2 = D
DMIN2 = DMIN
J4 = 4*( N0-2 ) - PP
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM2 + Z( J4P2 )
IF( Z( J4-2 ).EQ.ZERO ) THEN
Z( J4 ) = ZERO
DNM1 = Z( J4P2+2 )
DMIN = DNM1
EMIN = ZERO
ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND.
$ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN
TEMP = Z( J4P2+2 ) / Z( J4-2 )
Z( J4 ) = Z( J4P2 )*TEMP
DNM1 = DNM2*TEMP
ELSE
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) )
END IF
DMIN = MIN( DMIN, DNM1 )
*
DMIN1 = DMIN
J4 = J4 + 4
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM1 + Z( J4P2 )
IF( Z( J4-2 ).EQ.ZERO ) THEN
Z( J4 ) = ZERO
DN = Z( J4P2+2 )
DMIN = DN
EMIN = ZERO
ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND.
$ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN
TEMP = Z( J4P2+2 ) / Z( J4-2 )
Z( J4 ) = Z( J4P2 )*TEMP
DN = DNM1*TEMP
ELSE
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) )
END IF
DMIN = MIN( DMIN, DN )
*
Z( J4+2 ) = DN
Z( 4*N0-PP ) = EMIN
RETURN
*
* End of SLASQ6
*
END
SUBROUTINE SLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIRECT, PIVOT, SIDE
INTEGER LDA, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), C( * ), S( * )
* ..
*
* Purpose
* =======
*
* SLASR applies a sequence of plane rotations to a real matrix A,
* from either the left or the right.
*
* When SIDE = 'L', the transformation takes the form
*
* A := P*A
*
* and when SIDE = 'R', the transformation takes the form
*
* A := A*P**T
*
* where P is an orthogonal matrix consisting of a sequence of z plane
* rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',
* and P**T is the transpose of P.
*
* When DIRECT = 'F' (Forward sequence), then
*
* P = P(z-1) * ... * P(2) * P(1)
*
* and when DIRECT = 'B' (Backward sequence), then
*
* P = P(1) * P(2) * ... * P(z-1)
*
* where P(k) is a plane rotation matrix defined by the 2-by-2 rotation
*
* R(k) = ( c(k) s(k) )
* = ( -s(k) c(k) ).
*
* When PIVOT = 'V' (Variable pivot), the rotation is performed
* for the plane (k,k+1), i.e., P(k) has the form
*
* P(k) = ( 1 )
* ( ... )
* ( 1 )
* ( c(k) s(k) )
* ( -s(k) c(k) )
* ( 1 )
* ( ... )
* ( 1 )
*
* where R(k) appears as a rank-2 modification to the identity matrix in
* rows and columns k and k+1.
*
* When PIVOT = 'T' (Top pivot), the rotation is performed for the
* plane (1,k+1), so P(k) has the form
*
* P(k) = ( c(k) s(k) )
* ( 1 )
* ( ... )
* ( 1 )
* ( -s(k) c(k) )
* ( 1 )
* ( ... )
* ( 1 )
*
* where R(k) appears in rows and columns 1 and k+1.
*
* Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is
* performed for the plane (k,z), giving P(k) the form
*
* P(k) = ( 1 )
* ( ... )
* ( 1 )
* ( c(k) s(k) )
* ( 1 )
* ( ... )
* ( 1 )
* ( -s(k) c(k) )
*
* where R(k) appears in rows and columns k and z. The rotations are
* performed without ever forming P(k) explicitly.
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* Specifies whether the plane rotation matrix P is applied to
* A on the left or the right.
* = 'L': Left, compute A := P*A
* = 'R': Right, compute A:= A*P**T
*
* PIVOT (input) CHARACTER*1
* Specifies the plane for which P(k) is a plane rotation
* matrix.
* = 'V': Variable pivot, the plane (k,k+1)
* = 'T': Top pivot, the plane (1,k+1)
* = 'B': Bottom pivot, the plane (k,z)
*
* DIRECT (input) CHARACTER*1
* Specifies whether P is a forward or backward sequence of
* plane rotations.
* = 'F': Forward, P = P(z-1)*...*P(2)*P(1)
* = 'B': Backward, P = P(1)*P(2)*...*P(z-1)
*
* M (input) INTEGER
* The number of rows of the matrix A. If m <= 1, an immediate
* return is effected.
*
* N (input) INTEGER
* The number of columns of the matrix A. If n <= 1, an
* immediate return is effected.
*
* C (input) REAL array, dimension
* (M-1) if SIDE = 'L'
* (N-1) if SIDE = 'R'
* The cosines c(k) of the plane rotations.
*
* S (input) REAL array, dimension
* (M-1) if SIDE = 'L'
* (N-1) if SIDE = 'R'
* The sines s(k) of the plane rotations. The 2-by-2 plane
* rotation part of the matrix P(k), R(k), has the form
* R(k) = ( c(k) s(k) )
* ( -s(k) c(k) ).
*
* A (input/output) REAL array, dimension (LDA,N)
* The M-by-N matrix A. On exit, A is overwritten by P*A if
* SIDE = 'R' or by A*P**T if SIDE = 'L'.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
REAL CTEMP, STEMP, TEMP
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN
INFO = 1
ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT,
$ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN
INFO = 2
ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) )
$ THEN
INFO = 3
ELSE IF( M.LT.0 ) THEN
INFO = 4
ELSE IF( N.LT.0 ) THEN
INFO = 5
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = 9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLASR ', INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) )
$ RETURN
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form P * A
*
IF( LSAME( PIVOT, 'V' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 20 J = 1, M - 1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 10 I = 1, N
TEMP = A( J+1, I )
A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
10 CONTINUE
END IF
20 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 40 J = M - 1, 1, -1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 30 I = 1, N
TEMP = A( J+1, I )
A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
30 CONTINUE
END IF
40 CONTINUE
END IF
ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 60 J = 2, M
CTEMP = C( J-1 )
STEMP = S( J-1 )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 50 I = 1, N
TEMP = A( J, I )
A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
50 CONTINUE
END IF
60 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 80 J = M, 2, -1
CTEMP = C( J-1 )
STEMP = S( J-1 )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 70 I = 1, N
TEMP = A( J, I )
A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
70 CONTINUE
END IF
80 CONTINUE
END IF
ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 100 J = 1, M - 1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 90 I = 1, N
TEMP = A( J, I )
A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
90 CONTINUE
END IF
100 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 120 J = M - 1, 1, -1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 110 I = 1, N
TEMP = A( J, I )
A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
110 CONTINUE
END IF
120 CONTINUE
END IF
END IF
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form A * P'
*
IF( LSAME( PIVOT, 'V' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 140 J = 1, N - 1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 130 I = 1, M
TEMP = A( I, J+1 )
A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
130 CONTINUE
END IF
140 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 160 J = N - 1, 1, -1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 150 I = 1, M
TEMP = A( I, J+1 )
A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
150 CONTINUE
END IF
160 CONTINUE
END IF
ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 180 J = 2, N
CTEMP = C( J-1 )
STEMP = S( J-1 )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 170 I = 1, M
TEMP = A( I, J )
A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
170 CONTINUE
END IF
180 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 200 J = N, 2, -1
CTEMP = C( J-1 )
STEMP = S( J-1 )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 190 I = 1, M
TEMP = A( I, J )
A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
190 CONTINUE
END IF
200 CONTINUE
END IF
ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 220 J = 1, N - 1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 210 I = 1, M
TEMP = A( I, J )
A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
210 CONTINUE
END IF
220 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 240 J = N - 1, 1, -1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 230 I = 1, M
TEMP = A( I, J )
A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
230 CONTINUE
END IF
240 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of SLASR
*
END
SUBROUTINE SLASRT( ID, N, D, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER ID
INTEGER INFO, N
* ..
* .. Array Arguments ..
REAL D( * )
* ..
*
* Purpose
* =======
*
* Sort the numbers in D in increasing order (if ID = 'I') or
* in decreasing order (if ID = 'D' ).
*
* Use Quick Sort, reverting to Insertion sort on arrays of
* size <= 20. Dimension of STACK limits N to about 2**32.
*
* Arguments
* =========
*
* ID (input) CHARACTER*1
* = 'I': sort D in increasing order;
* = 'D': sort D in decreasing order.
*
* N (input) INTEGER
* The length of the array D.
*
* D (input/output) REAL array, dimension (N)
* On entry, the array to be sorted.
* On exit, D has been sorted into increasing order
* (D(1) <= ... <= D(N) ) or into decreasing order
* (D(1) >= ... >= D(N) ), depending on ID.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
INTEGER SELECT
PARAMETER ( SELECT = 20 )
* ..
* .. Local Scalars ..
INTEGER DIR, ENDD, I, J, START, STKPNT
REAL D1, D2, D3, DMNMX, TMP
* ..
* .. Local Arrays ..
INTEGER STACK( 2, 32 )
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
* Test the input paramters.
*
INFO = 0
DIR = -1
IF( LSAME( ID, 'D' ) ) THEN
DIR = 0
ELSE IF( LSAME( ID, 'I' ) ) THEN
DIR = 1
END IF
IF( DIR.EQ.-1 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLASRT', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.1 )
$ RETURN
*
STKPNT = 1
STACK( 1, 1 ) = 1
STACK( 2, 1 ) = N
10 CONTINUE
START = STACK( 1, STKPNT )
ENDD = STACK( 2, STKPNT )
STKPNT = STKPNT - 1
IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN
*
* Do Insertion sort on D( START:ENDD )
*
IF( DIR.EQ.0 ) THEN
*
* Sort into decreasing order
*
DO 30 I = START + 1, ENDD
DO 20 J = I, START + 1, -1
IF( D( J ).GT.D( J-1 ) ) THEN
DMNMX = D( J )
D( J ) = D( J-1 )
D( J-1 ) = DMNMX
ELSE
GO TO 30
END IF
20 CONTINUE
30 CONTINUE
*
ELSE
*
* Sort into increasing order
*
DO 50 I = START + 1, ENDD
DO 40 J = I, START + 1, -1
IF( D( J ).LT.D( J-1 ) ) THEN
DMNMX = D( J )
D( J ) = D( J-1 )
D( J-1 ) = DMNMX
ELSE
GO TO 50
END IF
40 CONTINUE
50 CONTINUE
*
END IF
*
ELSE IF( ENDD-START.GT.SELECT ) THEN
*
* Partition D( START:ENDD ) and stack parts, largest one first
*
* Choose partition entry as median of 3
*
D1 = D( START )
D2 = D( ENDD )
I = ( START+ENDD ) / 2
D3 = D( I )
IF( D1.LT.D2 ) THEN
IF( D3.LT.D1 ) THEN
DMNMX = D1
ELSE IF( D3.LT.D2 ) THEN
DMNMX = D3
ELSE
DMNMX = D2
END IF
ELSE
IF( D3.LT.D2 ) THEN
DMNMX = D2
ELSE IF( D3.LT.D1 ) THEN
DMNMX = D3
ELSE
DMNMX = D1
END IF
END IF
*
IF( DIR.EQ.0 ) THEN
*
* Sort into decreasing order
*
I = START - 1
J = ENDD + 1
60 CONTINUE
70 CONTINUE
J = J - 1
IF( D( J ).LT.DMNMX )
$ GO TO 70
80 CONTINUE
I = I + 1
IF( D( I ).GT.DMNMX )
$ GO TO 80
IF( I.LT.J ) THEN
TMP = D( I )
D( I ) = D( J )
D( J ) = TMP
GO TO 60
END IF
IF( J-START.GT.ENDD-J-1 ) THEN
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = START
STACK( 2, STKPNT ) = J
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = J + 1
STACK( 2, STKPNT ) = ENDD
ELSE
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = J + 1
STACK( 2, STKPNT ) = ENDD
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = START
STACK( 2, STKPNT ) = J
END IF
ELSE
*
* Sort into increasing order
*
I = START - 1
J = ENDD + 1
90 CONTINUE
100 CONTINUE
J = J - 1
IF( D( J ).GT.DMNMX )
$ GO TO 100
110 CONTINUE
I = I + 1
IF( D( I ).LT.DMNMX )
$ GO TO 110
IF( I.LT.J ) THEN
TMP = D( I )
D( I ) = D( J )
D( J ) = TMP
GO TO 90
END IF
IF( J-START.GT.ENDD-J-1 ) THEN
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = START
STACK( 2, STKPNT ) = J
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = J + 1
STACK( 2, STKPNT ) = ENDD
ELSE
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = J + 1
STACK( 2, STKPNT ) = ENDD
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = START
STACK( 2, STKPNT ) = J
END IF
END IF
END IF
IF( STKPNT.GT.0 )
$ GO TO 10
RETURN
*
* End of SLASRT
*
END
SUBROUTINE SLASSQ( N, X, INCX, SCALE, SUMSQ )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INCX, N
REAL SCALE, SUMSQ
* ..
* .. Array Arguments ..
REAL X( * )
* ..
*
* Purpose
* =======
*
* SLASSQ returns the values scl and smsq such that
*
* ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
*
* where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is
* assumed to be non-negative and scl returns the value
*
* scl = max( scale, abs( x( i ) ) ).
*
* scale and sumsq must be supplied in SCALE and SUMSQ and
* scl and smsq are overwritten on SCALE and SUMSQ respectively.
*
* The routine makes only one pass through the vector x.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of elements to be used from the vector X.
*
* X (input) REAL array, dimension (N)
* The vector for which a scaled sum of squares is computed.
* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
*
* INCX (input) INTEGER
* The increment between successive values of the vector X.
* INCX > 0.
*
* SCALE (input/output) REAL
* On entry, the value scale in the equation above.
* On exit, SCALE is overwritten with scl , the scaling factor
* for the sum of squares.
*
* SUMSQ (input/output) REAL
* On entry, the value sumsq in the equation above.
* On exit, SUMSQ is overwritten with smsq , the basic sum of
* squares from which scl has been factored out.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER IX
REAL ABSXI
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
IF( N.GT.0 ) THEN
DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX
IF( X( IX ).NE.ZERO ) THEN
ABSXI = ABS( X( IX ) )
IF( SCALE.LT.ABSXI ) THEN
SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2
SCALE = ABSXI
ELSE
SUMSQ = SUMSQ + ( ABSXI / SCALE )**2
END IF
END IF
10 CONTINUE
END IF
RETURN
*
* End of SLASSQ
*
END
SUBROUTINE SLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
REAL CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN
* ..
*
* Purpose
* =======
*
* SLASV2 computes the singular value decomposition of a 2-by-2
* triangular matrix
* [ F G ]
* [ 0 H ].
* On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the
* smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and
* right singular vectors for abs(SSMAX), giving the decomposition
*
* [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ]
* [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ].
*
* Arguments
* =========
*
* F (input) REAL
* The (1,1) element of the 2-by-2 matrix.
*
* G (input) REAL
* The (1,2) element of the 2-by-2 matrix.
*
* H (input) REAL
* The (2,2) element of the 2-by-2 matrix.
*
* SSMIN (output) REAL
* abs(SSMIN) is the smaller singular value.
*
* SSMAX (output) REAL
* abs(SSMAX) is the larger singular value.
*
* SNL (output) REAL
* CSL (output) REAL
* The vector (CSL, SNL) is a unit left singular vector for the
* singular value abs(SSMAX).
*
* SNR (output) REAL
* CSR (output) REAL
* The vector (CSR, SNR) is a unit right singular vector for the
* singular value abs(SSMAX).
*
* Further Details
* ===============
*
* Any input parameter may be aliased with any output parameter.
*
* Barring over/underflow and assuming a guard digit in subtraction, all
* output quantities are correct to within a few units in the last
* place (ulps).
*
* In IEEE arithmetic, the code works correctly if one matrix element is
* infinite.
*
* Overflow will not occur unless the largest singular value itself
* overflows or is within a few ulps of overflow. (On machines with
* partial overflow, like the Cray, overflow may occur if the largest
* singular value is within a factor of 2 of overflow.)
*
* Underflow is harmless if underflow is gradual. Otherwise, results
* may correspond to a matrix modified by perturbations of size near
* the underflow threshold.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
REAL HALF
PARAMETER ( HALF = 0.5E0 )
REAL ONE
PARAMETER ( ONE = 1.0E0 )
REAL TWO
PARAMETER ( TWO = 2.0E0 )
REAL FOUR
PARAMETER ( FOUR = 4.0E0 )
* ..
* .. Local Scalars ..
LOGICAL GASMAL, SWAP
INTEGER PMAX
REAL A, CLT, CRT, D, FA, FT, GA, GT, HA, HT, L, M,
$ MM, R, S, SLT, SRT, T, TEMP, TSIGN, TT
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SIGN, SQRT
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Executable Statements ..
*
FT = F
FA = ABS( FT )
HT = H
HA = ABS( H )
*
* PMAX points to the maximum absolute element of matrix
* PMAX = 1 if F largest in absolute values
* PMAX = 2 if G largest in absolute values
* PMAX = 3 if H largest in absolute values
*
PMAX = 1
SWAP = ( HA.GT.FA )
IF( SWAP ) THEN
PMAX = 3
TEMP = FT
FT = HT
HT = TEMP
TEMP = FA
FA = HA
HA = TEMP
*
* Now FA .ge. HA
*
END IF
GT = G
GA = ABS( GT )
IF( GA.EQ.ZERO ) THEN
*
* Diagonal matrix
*
SSMIN = HA
SSMAX = FA
CLT = ONE
CRT = ONE
SLT = ZERO
SRT = ZERO
ELSE
GASMAL = .TRUE.
IF( GA.GT.FA ) THEN
PMAX = 2
IF( ( FA / GA ).LT.SLAMCH( 'EPS' ) ) THEN
*
* Case of very large GA
*
GASMAL = .FALSE.
SSMAX = GA
IF( HA.GT.ONE ) THEN
SSMIN = FA / ( GA / HA )
ELSE
SSMIN = ( FA / GA )*HA
END IF
CLT = ONE
SLT = HT / GT
SRT = ONE
CRT = FT / GT
END IF
END IF
IF( GASMAL ) THEN
*
* Normal case
*
D = FA - HA
IF( D.EQ.FA ) THEN
*
* Copes with infinite F or H
*
L = ONE
ELSE
L = D / FA
END IF
*
* Note that 0 .le. L .le. 1
*
M = GT / FT
*
* Note that abs(M) .le. 1/macheps
*
T = TWO - L
*
* Note that T .ge. 1
*
MM = M*M
TT = T*T
S = SQRT( TT+MM )
*
* Note that 1 .le. S .le. 1 + 1/macheps
*
IF( L.EQ.ZERO ) THEN
R = ABS( M )
ELSE
R = SQRT( L*L+MM )
END IF
*
* Note that 0 .le. R .le. 1 + 1/macheps
*
A = HALF*( S+R )
*
* Note that 1 .le. A .le. 1 + abs(M)
*
SSMIN = HA / A
SSMAX = FA*A
IF( MM.EQ.ZERO ) THEN
*
* Note that M is very tiny
*
IF( L.EQ.ZERO ) THEN
T = SIGN( TWO, FT )*SIGN( ONE, GT )
ELSE
T = GT / SIGN( D, FT ) + M / T
END IF
ELSE
T = ( M / ( S+T )+M / ( R+L ) )*( ONE+A )
END IF
L = SQRT( T*T+FOUR )
CRT = TWO / L
SRT = T / L
CLT = ( CRT+SRT*M ) / A
SLT = ( HT / FT )*SRT / A
END IF
END IF
IF( SWAP ) THEN
CSL = SRT
SNL = CRT
CSR = SLT
SNR = CLT
ELSE
CSL = CLT
SNL = SLT
CSR = CRT
SNR = SRT
END IF
*
* Correct signs of SSMAX and SSMIN
*
IF( PMAX.EQ.1 )
$ TSIGN = SIGN( ONE, CSR )*SIGN( ONE, CSL )*SIGN( ONE, F )
IF( PMAX.EQ.2 )
$ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, CSL )*SIGN( ONE, G )
IF( PMAX.EQ.3 )
$ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, SNL )*SIGN( ONE, H )
SSMAX = SIGN( SSMAX, TSIGN )
SSMIN = SIGN( SSMIN, TSIGN*SIGN( ONE, F )*SIGN( ONE, H ) )
RETURN
*
* End of SLASV2
*
END
SUBROUTINE SLASWP( N, A, LDA, K1, K2, IPIV, INCX )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INCX, K1, K2, LDA, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
REAL A( LDA, * )
* ..
*
* Purpose
* =======
*
* SLASWP 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) REAL 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
REAL 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 SLASWP
*
END
SUBROUTINE SLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR,
$ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL LTRANL, LTRANR
INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2
REAL SCALE, XNORM
* ..
* .. Array Arguments ..
REAL B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ),
$ X( LDX, * )
* ..
*
* Purpose
* =======
*
* SLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in
*
* op(TL)*X + ISGN*X*op(TR) = SCALE*B,
*
* where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or
* -1. op(T) = T or T', where T' denotes the transpose of T.
*
* Arguments
* =========
*
* LTRANL (input) LOGICAL
* On entry, LTRANL specifies the op(TL):
* = .FALSE., op(TL) = TL,
* = .TRUE., op(TL) = TL'.
*
* LTRANR (input) LOGICAL
* On entry, LTRANR specifies the op(TR):
* = .FALSE., op(TR) = TR,
* = .TRUE., op(TR) = TR'.
*
* ISGN (input) INTEGER
* On entry, ISGN specifies the sign of the equation
* as described before. ISGN may only be 1 or -1.
*
* N1 (input) INTEGER
* On entry, N1 specifies the order of matrix TL.
* N1 may only be 0, 1 or 2.
*
* N2 (input) INTEGER
* On entry, N2 specifies the order of matrix TR.
* N2 may only be 0, 1 or 2.
*
* TL (input) REAL array, dimension (LDTL,2)
* On entry, TL contains an N1 by N1 matrix.
*
* LDTL (input) INTEGER
* The leading dimension of the matrix TL. LDTL >= max(1,N1).
*
* TR (input) REAL array, dimension (LDTR,2)
* On entry, TR contains an N2 by N2 matrix.
*
* LDTR (input) INTEGER
* The leading dimension of the matrix TR. LDTR >= max(1,N2).
*
* B (input) REAL array, dimension (LDB,2)
* On entry, the N1 by N2 matrix B contains the right-hand
* side of the equation.
*
* LDB (input) INTEGER
* The leading dimension of the matrix B. LDB >= max(1,N1).
*
* SCALE (output) REAL
* On exit, SCALE contains the scale factor. SCALE is chosen
* less than or equal to 1 to prevent the solution overflowing.
*
* X (output) REAL array, dimension (LDX,2)
* On exit, X contains the N1 by N2 solution.
*
* LDX (input) INTEGER
* The leading dimension of the matrix X. LDX >= max(1,N1).
*
* XNORM (output) REAL
* On exit, XNORM is the infinity-norm of the solution.
*
* INFO (output) INTEGER
* On exit, INFO is set to
* 0: successful exit.
* 1: TL and TR have too close eigenvalues, so TL or
* TR is perturbed to get a nonsingular equation.
* NOTE: In the interests of speed, this routine does not
* check the inputs for errors.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
REAL TWO, HALF, EIGHT
PARAMETER ( TWO = 2.0E+0, HALF = 0.5E+0, EIGHT = 8.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL BSWAP, XSWAP
INTEGER I, IP, IPIV, IPSV, J, JP, JPSV, K
REAL BET, EPS, GAM, L21, SGN, SMIN, SMLNUM, TAU1,
$ TEMP, U11, U12, U22, XMAX
* ..
* .. Local Arrays ..
LOGICAL BSWPIV( 4 ), XSWPIV( 4 )
INTEGER JPIV( 4 ), LOCL21( 4 ), LOCU12( 4 ),
$ LOCU22( 4 )
REAL BTMP( 4 ), T16( 4, 4 ), TMP( 4 ), X2( 2 )
* ..
* .. External Functions ..
INTEGER ISAMAX
REAL SLAMCH
EXTERNAL ISAMAX, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Data statements ..
DATA LOCU12 / 3, 4, 1, 2 / , LOCL21 / 2, 1, 4, 3 / ,
$ LOCU22 / 4, 3, 2, 1 /
DATA XSWPIV / .FALSE., .FALSE., .TRUE., .TRUE. /
DATA BSWPIV / .FALSE., .TRUE., .FALSE., .TRUE. /
* ..
* .. Executable Statements ..
*
* Do not check the input parameters for errors
*
INFO = 0
*
* Quick return if possible
*
IF( N1.EQ.0 .OR. N2.EQ.0 )
$ RETURN
*
* Set constants to control overflow
*
EPS = SLAMCH( 'P' )
SMLNUM = SLAMCH( 'S' ) / EPS
SGN = ISGN
*
K = N1 + N1 + N2 - 2
GO TO ( 10, 20, 30, 50 )K
*
* 1 by 1: TL11*X + SGN*X*TR11 = B11
*
10 CONTINUE
TAU1 = TL( 1, 1 ) + SGN*TR( 1, 1 )
BET = ABS( TAU1 )
IF( BET.LE.SMLNUM ) THEN
TAU1 = SMLNUM
BET = SMLNUM
INFO = 1
END IF
*
SCALE = ONE
GAM = ABS( B( 1, 1 ) )
IF( SMLNUM*GAM.GT.BET )
$ SCALE = ONE / GAM
*
X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / TAU1
XNORM = ABS( X( 1, 1 ) )
RETURN
*
* 1 by 2:
* TL11*[X11 X12] + ISGN*[X11 X12]*op[TR11 TR12] = [B11 B12]
* [TR21 TR22]
*
20 CONTINUE
*
SMIN = MAX( EPS*MAX( ABS( TL( 1, 1 ) ), ABS( TR( 1, 1 ) ),
$ ABS( TR( 1, 2 ) ), ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ),
$ SMLNUM )
TMP( 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 )
TMP( 4 ) = TL( 1, 1 ) + SGN*TR( 2, 2 )
IF( LTRANR ) THEN
TMP( 2 ) = SGN*TR( 2, 1 )
TMP( 3 ) = SGN*TR( 1, 2 )
ELSE
TMP( 2 ) = SGN*TR( 1, 2 )
TMP( 3 ) = SGN*TR( 2, 1 )
END IF
BTMP( 1 ) = B( 1, 1 )
BTMP( 2 ) = B( 1, 2 )
GO TO 40
*
* 2 by 1:
* op[TL11 TL12]*[X11] + ISGN* [X11]*TR11 = [B11]
* [TL21 TL22] [X21] [X21] [B21]
*
30 CONTINUE
SMIN = MAX( EPS*MAX( ABS( TR( 1, 1 ) ), ABS( TL( 1, 1 ) ),
$ ABS( TL( 1, 2 ) ), ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ),
$ SMLNUM )
TMP( 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 )
TMP( 4 ) = TL( 2, 2 ) + SGN*TR( 1, 1 )
IF( LTRANL ) THEN
TMP( 2 ) = TL( 1, 2 )
TMP( 3 ) = TL( 2, 1 )
ELSE
TMP( 2 ) = TL( 2, 1 )
TMP( 3 ) = TL( 1, 2 )
END IF
BTMP( 1 ) = B( 1, 1 )
BTMP( 2 ) = B( 2, 1 )
40 CONTINUE
*
* Solve 2 by 2 system using complete pivoting.
* Set pivots less than SMIN to SMIN.
*
IPIV = ISAMAX( 4, TMP, 1 )
U11 = TMP( IPIV )
IF( ABS( U11 ).LE.SMIN ) THEN
INFO = 1
U11 = SMIN
END IF
U12 = TMP( LOCU12( IPIV ) )
L21 = TMP( LOCL21( IPIV ) ) / U11
U22 = TMP( LOCU22( IPIV ) ) - U12*L21
XSWAP = XSWPIV( IPIV )
BSWAP = BSWPIV( IPIV )
IF( ABS( U22 ).LE.SMIN ) THEN
INFO = 1
U22 = SMIN
END IF
IF( BSWAP ) THEN
TEMP = BTMP( 2 )
BTMP( 2 ) = BTMP( 1 ) - L21*TEMP
BTMP( 1 ) = TEMP
ELSE
BTMP( 2 ) = BTMP( 2 ) - L21*BTMP( 1 )
END IF
SCALE = ONE
IF( ( TWO*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( U22 ) .OR.
$ ( TWO*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( U11 ) ) THEN
SCALE = HALF / MAX( ABS( BTMP( 1 ) ), ABS( BTMP( 2 ) ) )
BTMP( 1 ) = BTMP( 1 )*SCALE
BTMP( 2 ) = BTMP( 2 )*SCALE
END IF
X2( 2 ) = BTMP( 2 ) / U22
X2( 1 ) = BTMP( 1 ) / U11 - ( U12 / U11 )*X2( 2 )
IF( XSWAP ) THEN
TEMP = X2( 2 )
X2( 2 ) = X2( 1 )
X2( 1 ) = TEMP
END IF
X( 1, 1 ) = X2( 1 )
IF( N1.EQ.1 ) THEN
X( 1, 2 ) = X2( 2 )
XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) )
ELSE
X( 2, 1 ) = X2( 2 )
XNORM = MAX( ABS( X( 1, 1 ) ), ABS( X( 2, 1 ) ) )
END IF
RETURN
*
* 2 by 2:
* op[TL11 TL12]*[X11 X12] +ISGN* [X11 X12]*op[TR11 TR12] = [B11 B12]
* [TL21 TL22] [X21 X22] [X21 X22] [TR21 TR22] [B21 B22]
*
* Solve equivalent 4 by 4 system using complete pivoting.
* Set pivots less than SMIN to SMIN.
*
50 CONTINUE
SMIN = MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ),
$ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) )
SMIN = MAX( SMIN, ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ),
$ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) )
SMIN = MAX( EPS*SMIN, SMLNUM )
BTMP( 1 ) = ZERO
CALL SCOPY( 16, BTMP, 0, T16, 1 )
T16( 1, 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 )
T16( 2, 2 ) = TL( 2, 2 ) + SGN*TR( 1, 1 )
T16( 3, 3 ) = TL( 1, 1 ) + SGN*TR( 2, 2 )
T16( 4, 4 ) = TL( 2, 2 ) + SGN*TR( 2, 2 )
IF( LTRANL ) THEN
T16( 1, 2 ) = TL( 2, 1 )
T16( 2, 1 ) = TL( 1, 2 )
T16( 3, 4 ) = TL( 2, 1 )
T16( 4, 3 ) = TL( 1, 2 )
ELSE
T16( 1, 2 ) = TL( 1, 2 )
T16( 2, 1 ) = TL( 2, 1 )
T16( 3, 4 ) = TL( 1, 2 )
T16( 4, 3 ) = TL( 2, 1 )
END IF
IF( LTRANR ) THEN
T16( 1, 3 ) = SGN*TR( 1, 2 )
T16( 2, 4 ) = SGN*TR( 1, 2 )
T16( 3, 1 ) = SGN*TR( 2, 1 )
T16( 4, 2 ) = SGN*TR( 2, 1 )
ELSE
T16( 1, 3 ) = SGN*TR( 2, 1 )
T16( 2, 4 ) = SGN*TR( 2, 1 )
T16( 3, 1 ) = SGN*TR( 1, 2 )
T16( 4, 2 ) = SGN*TR( 1, 2 )
END IF
BTMP( 1 ) = B( 1, 1 )
BTMP( 2 ) = B( 2, 1 )
BTMP( 3 ) = B( 1, 2 )
BTMP( 4 ) = B( 2, 2 )
*
* Perform elimination
*
DO 100 I = 1, 3
XMAX = ZERO
DO 70 IP = I, 4
DO 60 JP = I, 4
IF( ABS( T16( IP, JP ) ).GE.XMAX ) THEN
XMAX = ABS( T16( IP, JP ) )
IPSV = IP
JPSV = JP
END IF
60 CONTINUE
70 CONTINUE
IF( IPSV.NE.I ) THEN
CALL SSWAP( 4, T16( IPSV, 1 ), 4, T16( I, 1 ), 4 )
TEMP = BTMP( I )
BTMP( I ) = BTMP( IPSV )
BTMP( IPSV ) = TEMP
END IF
IF( JPSV.NE.I )
$ CALL SSWAP( 4, T16( 1, JPSV ), 1, T16( 1, I ), 1 )
JPIV( I ) = JPSV
IF( ABS( T16( I, I ) ).LT.SMIN ) THEN
INFO = 1
T16( I, I ) = SMIN
END IF
DO 90 J = I + 1, 4
T16( J, I ) = T16( J, I ) / T16( I, I )
BTMP( J ) = BTMP( J ) - T16( J, I )*BTMP( I )
DO 80 K = I + 1, 4
T16( J, K ) = T16( J, K ) - T16( J, I )*T16( I, K )
80 CONTINUE
90 CONTINUE
100 CONTINUE
IF( ABS( T16( 4, 4 ) ).LT.SMIN )
$ T16( 4, 4 ) = SMIN
SCALE = ONE
IF( ( EIGHT*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T16( 1, 1 ) ) .OR.
$ ( EIGHT*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T16( 2, 2 ) ) .OR.
$ ( EIGHT*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T16( 3, 3 ) ) .OR.
$ ( EIGHT*SMLNUM )*ABS( BTMP( 4 ) ).GT.ABS( T16( 4, 4 ) ) ) THEN
SCALE = ( ONE / EIGHT ) / MAX( ABS( BTMP( 1 ) ),
$ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ), ABS( BTMP( 4 ) ) )
BTMP( 1 ) = BTMP( 1 )*SCALE
BTMP( 2 ) = BTMP( 2 )*SCALE
BTMP( 3 ) = BTMP( 3 )*SCALE
BTMP( 4 ) = BTMP( 4 )*SCALE
END IF
DO 120 I = 1, 4
K = 5 - I
TEMP = ONE / T16( K, K )
TMP( K ) = BTMP( K )*TEMP
DO 110 J = K + 1, 4
TMP( K ) = TMP( K ) - ( TEMP*T16( K, J ) )*TMP( J )
110 CONTINUE
120 CONTINUE
DO 130 I = 1, 3
IF( JPIV( 4-I ).NE.4-I ) THEN
TEMP = TMP( 4-I )
TMP( 4-I ) = TMP( JPIV( 4-I ) )
TMP( JPIV( 4-I ) ) = TEMP
END IF
130 CONTINUE
X( 1, 1 ) = TMP( 1 )
X( 2, 1 ) = TMP( 2 )
X( 1, 2 ) = TMP( 3 )
X( 2, 2 ) = TMP( 4 )
XNORM = MAX( ABS( TMP( 1 ) )+ABS( TMP( 3 ) ),
$ ABS( TMP( 2 ) )+ABS( TMP( 4 ) ) )
RETURN
*
* End of SLASY2
*
END
SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, KB, LDA, LDW, N, NB
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
REAL A( LDA, * ), W( LDW, * )
* ..
*
* Purpose
* =======
*
* SLASYF computes a partial factorization of a real symmetric matrix A
* using the Bunch-Kaufman diagonal pivoting method. The partial
* factorization has the form:
*
* A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
* ( 0 U22 ) ( 0 D ) ( U12' U22' )
*
* A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L'
* ( L21 I ) ( 0 A22 ) ( 0 I )
*
* where the order of D is at most NB. The actual order is returned in
* the argument KB, and is either NB or NB-1, or N if N <= NB.
*
* SLASYF is an auxiliary routine called by SSYTRF. It uses blocked code
* (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or
* A22 (if UPLO = 'L').
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* NB (input) INTEGER
* The maximum number of columns of the matrix A that should be
* factored. NB should be at least 2 to allow for 2-by-2 pivot
* blocks.
*
* KB (output) INTEGER
* The number of columns of A that were actually factored.
* KB is either NB-1 or NB, or N if N <= NB.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the symmetric matrix A. If UPLO = 'U', the leading
* n-by-n upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading n-by-n lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced.
* On exit, A contains details of the partial factorization.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* IPIV (output) INTEGER array, dimension (N)
* Details of the interchanges and the block structure of D.
* If UPLO = 'U', only the last KB elements of IPIV are set;
* if UPLO = 'L', only the first KB elements are set.
*
* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
* interchanged and D(k,k) is a 1-by-1 diagonal block.
* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*
* W (workspace) REAL array, dimension (LDW,NB)
*
* LDW (input) INTEGER
* The leading dimension of the array W. LDW >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* > 0: if INFO = k, D(k,k) is exactly zero. The factorization
* has been completed, but the block diagonal matrix D is
* exactly singular.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
REAL EIGHT, SEVTEN
PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
* ..
* .. Local Scalars ..
INTEGER IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP,
$ KSTEP, KW
REAL ABSAKK, ALPHA, COLMAX, D11, D21, D22, R1,
$ ROWMAX, T
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
EXTERNAL LSAME, ISAMAX
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMM, SGEMV, SSCAL, SSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Initialize ALPHA for use in choosing pivot block size.
*
ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Factorize the trailing columns of A using the upper triangle
* of A and working backwards, and compute the matrix W = U12*D
* for use in updating A11
*
* K is the main loop index, decreasing from N in steps of 1 or 2
*
* KW is the column of W which corresponds to column K of A
*
K = N
10 CONTINUE
KW = NB + K - N
*
* Exit from loop
*
IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 )
$ GO TO 30
*
* Copy column K of A to column KW of W and update it
*
CALL SCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 )
IF( K.LT.N )
$ CALL SGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), LDA,
$ W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 )
*
KSTEP = 1
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = ABS( W( K, KW ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value
*
IF( K.GT.1 ) THEN
IMAX = ISAMAX( K-1, W( 1, KW ), 1 )
COLMAX = ABS( W( IMAX, KW ) )
ELSE
COLMAX = ZERO
END IF
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* Column K is zero: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
ELSE
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE
*
* Copy column IMAX to column KW-1 of W and update it
*
CALL SCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )
CALL SCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA,
$ W( IMAX+1, KW-1 ), 1 )
IF( K.LT.N )
$ CALL SGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ),
$ LDA, W( IMAX, KW+1 ), LDW, ONE,
$ W( 1, KW-1 ), 1 )
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value
*
JMAX = IMAX + ISAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 )
ROWMAX = ABS( W( JMAX, KW-1 ) )
IF( IMAX.GT.1 ) THEN
JMAX = ISAMAX( IMAX-1, W( 1, KW-1 ), 1 )
ROWMAX = MAX( ROWMAX, ABS( W( JMAX, KW-1 ) ) )
END IF
*
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE IF( ABS( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX ) THEN
*
* interchange rows and columns K and IMAX, use 1-by-1
* pivot block
*
KP = IMAX
*
* copy column KW-1 of W to column KW
*
CALL SCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
ELSE
*
* interchange rows and columns K-1 and IMAX, use 2-by-2
* pivot block
*
KP = IMAX
KSTEP = 2
END IF
END IF
*
KK = K - KSTEP + 1
KKW = NB + KK - N
*
* Updated column KP is already stored in column KKW of W
*
IF( KP.NE.KK ) THEN
*
* Copy non-updated column KK to column KP
*
A( KP, K ) = A( KK, K )
CALL SCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
$ LDA )
CALL SCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 )
*
* Interchange rows KK and KP in last KK columns of A and W
*
CALL SSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA )
CALL SSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
$ LDW )
END IF
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column KW of W now holds
*
* W(k) = U(k)*D(k)
*
* where U(k) is the k-th column of U
*
* Store U(k) in column k of A
*
CALL SCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
R1 = ONE / A( K, K )
CALL SSCAL( K-1, R1, A( 1, K ), 1 )
ELSE
*
* 2-by-2 pivot block D(k): columns KW and KW-1 of W now
* hold
*
* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
*
* where U(k) and U(k-1) are the k-th and (k-1)-th columns
* of U
*
IF( K.GT.2 ) THEN
*
* Store U(k) and U(k-1) in columns k and k-1 of A
*
D21 = W( K-1, KW )
D11 = W( K, KW ) / D21
D22 = W( K-1, KW-1 ) / D21
T = ONE / ( D11*D22-ONE )
D21 = T / D21
DO 20 J = 1, K - 2
A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) )
A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) )
20 CONTINUE
END IF
*
* Copy D(k) to A
*
A( K-1, K-1 ) = W( K-1, KW-1 )
A( K-1, K ) = W( K-1, KW )
A( K, K ) = W( K, KW )
END IF
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -KP
IPIV( K-1 ) = -KP
END IF
*
* Decrease K and return to the start of the main loop
*
K = K - KSTEP
GO TO 10
*
30 CONTINUE
*
* Update the upper triangle of A11 (= A(1:k,1:k)) as
*
* A11 := A11 - U12*D*U12' = A11 - U12*W'
*
* computing blocks of NB columns at a time
*
DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB
JB = MIN( NB, K-J+1 )
*
* Update the upper triangle of the diagonal block
*
DO 40 JJ = J, J + JB - 1
CALL SGEMV( 'No transpose', JJ-J+1, N-K, -ONE,
$ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, ONE,
$ A( J, JJ ), 1 )
40 CONTINUE
*
* Update the rectangular superdiagonal block
*
CALL SGEMM( 'No transpose', 'Transpose', J-1, JB, N-K, -ONE,
$ A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, ONE,
$ A( 1, J ), LDA )
50 CONTINUE
*
* Put U12 in standard form by partially undoing the interchanges
* in columns k+1:n
*
J = K + 1
60 CONTINUE
JJ = J
JP = IPIV( J )
IF( JP.LT.0 ) THEN
JP = -JP
J = J + 1
END IF
J = J + 1
IF( JP.NE.JJ .AND. J.LE.N )
$ CALL SSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA )
IF( J.LE.N )
$ GO TO 60
*
* Set KB to the number of columns factorized
*
KB = N - K
*
ELSE
*
* Factorize the leading columns of A using the lower triangle
* of A and working forwards, and compute the matrix W = L21*D
* for use in updating A22
*
* K is the main loop index, increasing from 1 in steps of 1 or 2
*
K = 1
70 CONTINUE
*
* Exit from loop
*
IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N )
$ GO TO 90
*
* Copy column K of A to column K of W and update it
*
CALL SCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 )
CALL SGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), LDA,
$ W( K, 1 ), LDW, ONE, W( K, K ), 1 )
*
KSTEP = 1
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = ABS( W( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value
*
IF( K.LT.N ) THEN
IMAX = K + ISAMAX( N-K, W( K+1, K ), 1 )
COLMAX = ABS( W( IMAX, K ) )
ELSE
COLMAX = ZERO
END IF
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* Column K is zero: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
ELSE
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE
*
* Copy column IMAX to column K+1 of W and update it
*
CALL SCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 )
CALL SCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, W( IMAX, K+1 ),
$ 1 )
CALL SGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ),
$ LDA, W( IMAX, 1 ), LDW, ONE, W( K, K+1 ), 1 )
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value
*
JMAX = K - 1 + ISAMAX( IMAX-K, W( K, K+1 ), 1 )
ROWMAX = ABS( W( JMAX, K+1 ) )
IF( IMAX.LT.N ) THEN
JMAX = IMAX + ISAMAX( N-IMAX, W( IMAX+1, K+1 ), 1 )
ROWMAX = MAX( ROWMAX, ABS( W( JMAX, K+1 ) ) )
END IF
*
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE IF( ABS( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX ) THEN
*
* interchange rows and columns K and IMAX, use 1-by-1
* pivot block
*
KP = IMAX
*
* copy column K+1 of W to column K
*
CALL SCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
ELSE
*
* interchange rows and columns K+1 and IMAX, use 2-by-2
* pivot block
*
KP = IMAX
KSTEP = 2
END IF
END IF
*
KK = K + KSTEP - 1
*
* Updated column KP is already stored in column KK of W
*
IF( KP.NE.KK ) THEN
*
* Copy non-updated column KK to column KP
*
A( KP, K ) = A( KK, K )
CALL SCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA )
CALL SCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 )
*
* Interchange rows KK and KP in first KK columns of A and W
*
CALL SSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
CALL SSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
END IF
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column k of W now holds
*
* W(k) = L(k)*D(k)
*
* where L(k) is the k-th column of L
*
* Store L(k) in column k of A
*
CALL SCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
IF( K.LT.N ) THEN
R1 = ONE / A( K, K )
CALL SSCAL( N-K, R1, A( K+1, K ), 1 )
END IF
ELSE
*
* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
*
* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
*
* where L(k) and L(k+1) are the k-th and (k+1)-th columns
* of L
*
IF( K.LT.N-1 ) THEN
*
* Store L(k) and L(k+1) in columns k and k+1 of A
*
D21 = W( K+1, K )
D11 = W( K+1, K+1 ) / D21
D22 = W( K, K ) / D21
T = ONE / ( D11*D22-ONE )
D21 = T / D21
DO 80 J = K + 2, N
A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) )
A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) )
80 CONTINUE
END IF
*
* Copy D(k) to A
*
A( K, K ) = W( K, K )
A( K+1, K ) = W( K+1, K )
A( K+1, K+1 ) = W( K+1, K+1 )
END IF
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -KP
IPIV( K+1 ) = -KP
END IF
*
* Increase K and return to the start of the main loop
*
K = K + KSTEP
GO TO 70
*
90 CONTINUE
*
* Update the lower triangle of A22 (= A(k:n,k:n)) as
*
* A22 := A22 - L21*D*L21' = A22 - L21*W'
*
* computing blocks of NB columns at a time
*
DO 110 J = K, N, NB
JB = MIN( NB, N-J+1 )
*
* Update the lower triangle of the diagonal block
*
DO 100 JJ = J, J + JB - 1
CALL SGEMV( 'No transpose', J+JB-JJ, K-1, -ONE,
$ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, ONE,
$ A( JJ, JJ ), 1 )
100 CONTINUE
*
* Update the rectangular subdiagonal block
*
IF( J+JB.LE.N )
$ CALL SGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
$ K-1, -ONE, A( J+JB, 1 ), LDA, W( J, 1 ), LDW,
$ ONE, A( J+JB, J ), LDA )
110 CONTINUE
*
* Put L21 in standard form by partially undoing the interchanges
* in columns 1:k-1
*
J = K - 1
120 CONTINUE
JJ = J
JP = IPIV( J )
IF( JP.LT.0 ) THEN
JP = -JP
J = J - 1
END IF
J = J - 1
IF( JP.NE.JJ .AND. J.GE.1 )
$ CALL SSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA )
IF( J.GE.1 )
$ GO TO 120
*
* Set KB to the number of columns factorized
*
KB = K - 1
*
END IF
RETURN
*
* End of SLASYF
*
END
SUBROUTINE SLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X,
$ SCALE, CNORM, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, NORMIN, TRANS, UPLO
INTEGER INFO, KD, LDAB, N
REAL SCALE
* ..
* .. Array Arguments ..
REAL AB( LDAB, * ), CNORM( * ), X( * )
* ..
*
* Purpose
* =======
*
* SLATBS solves one of the triangular systems
*
* A *x = s*b or A'*x = s*b
*
* with scaling to prevent overflow, where A is an upper or lower
* triangular band matrix. Here A' denotes the transpose of A, x and b
* are n-element vectors, and s is a scaling factor, usually less than
* or equal to 1, chosen so that the components of x will be less than
* the overflow threshold. If the unscaled problem will not cause
* overflow, the Level 2 BLAS routine STBSV is called. If the matrix A
* is singular (A(j,j) = 0 for some j), then s is set to 0 and a
* non-trivial solution to A*x = 0 is returned.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the operation applied to A.
* = 'N': Solve A * x = s*b (No transpose)
* = 'T': Solve A'* x = s*b (Transpose)
* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* NORMIN (input) CHARACTER*1
* Specifies whether CNORM has been set or not.
* = 'Y': CNORM contains the column norms on entry
* = 'N': CNORM is not set on entry. On exit, the norms will
* be computed and stored in CNORM.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of subdiagonals or superdiagonals in the
* triangular matrix A. KD >= 0.
*
* AB (input) REAL array, dimension (LDAB,N)
* The upper or lower triangular band matrix A, stored in the
* first KD+1 rows of the array. The j-th column of A is stored
* in the j-th column of the array AB as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* X (input/output) REAL array, dimension (N)
* On entry, the right hand side b of the triangular system.
* On exit, X is overwritten by the solution vector x.
*
* SCALE (output) REAL
* The scaling factor s for the triangular system
* A * x = s*b or A'* x = s*b.
* If SCALE = 0, the matrix A is singular or badly scaled, and
* the vector x is an exact or approximate solution to A*x = 0.
*
* CNORM (input or output) REAL array, dimension (N)
*
* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
* contains the norm of the off-diagonal part of the j-th column
* of A. If TRANS = 'N', CNORM(j) must be greater than or equal
* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
* must be greater than or equal to the 1-norm.
*
* If NORMIN = 'N', CNORM is an output argument and CNORM(j)
* returns the 1-norm of the offdiagonal part of the j-th column
* of A.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
*
* Further Details
* ======= =======
*
* A rough bound on x is computed; if that is less than overflow, STBSV
* is called, otherwise, specific code is used which checks for possible
* overflow or divide-by-zero at every operation.
*
* A columnwise scheme is used for solving A*x = b. The basic algorithm
* if A is lower triangular is
*
* x[1:n] := b[1:n]
* for j = 1, ..., n
* x(j) := x(j) / A(j,j)
* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
* end
*
* Define bounds on the components of x after j iterations of the loop:
* M(j) = bound on x[1:j]
* G(j) = bound on x[j+1:n]
* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
*
* Then for iteration j+1 we have
* M(j+1) <= G(j) / | A(j+1,j+1) |
* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
*
* where CNORM(j+1) is greater than or equal to the infinity-norm of
* column j+1 of A, not counting the diagonal. Hence
*
* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
* 1<=i<=j
* and
*
* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
* 1<=i< j
*
* Since |x(j)| <= M(j), we use the Level 2 BLAS routine STBSV if the
* reciprocal of the largest M(j), j=1,..,n, is larger than
* max(underflow, 1/overflow).
*
* The bound on x(j) is also used to determine when a step in the
* columnwise method can be performed without fear of overflow. If
* the computed bound is greater than a large constant, x is scaled to
* prevent overflow, but if the bound overflows, x is set to 0, x(j) to
* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
*
* Similarly, a row-wise scheme is used to solve A'*x = b. The basic
* algorithm for A upper triangular is
*
* for j = 1, ..., n
* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)
* end
*
* We simultaneously compute two bounds
* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j
* M(j) = bound on x(i), 1<=i<=j
*
* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
* Then the bound on x(j) is
*
* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
*
* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
* 1<=i<=j
*
* and we can safely call STBSV if 1/M(n) and 1/G(n) are both greater
* than max(underflow, 1/overflow).
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0E+0, HALF = 0.5E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN, NOUNIT, UPPER
INTEGER I, IMAX, J, JFIRST, JINC, JLAST, JLEN, MAIND
REAL BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS,
$ TMAX, TSCAL, USCAL, XBND, XJ, XMAX
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SASUM, SDOT, SLAMCH
EXTERNAL LSAME, ISAMAX, SASUM, SDOT, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SSCAL, STBSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOTRAN = LSAME( TRANS, 'N' )
NOUNIT = LSAME( DIAG, 'N' )
*
* Test the input parameters.
*
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
$ LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -3
ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT.
$ LSAME( NORMIN, 'N' ) ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( KD.LT.0 ) THEN
INFO = -6
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLATBS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Determine machine dependent parameters to control overflow.
*
SMLNUM = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
BIGNUM = ONE / SMLNUM
SCALE = ONE
*
IF( LSAME( NORMIN, 'N' ) ) THEN
*
* Compute the 1-norm of each column, not including the diagonal.
*
IF( UPPER ) THEN
*
* A is upper triangular.
*
DO 10 J = 1, N
JLEN = MIN( KD, J-1 )
CNORM( J ) = SASUM( JLEN, AB( KD+1-JLEN, J ), 1 )
10 CONTINUE
ELSE
*
* A is lower triangular.
*
DO 20 J = 1, N
JLEN = MIN( KD, N-J )
IF( JLEN.GT.0 ) THEN
CNORM( J ) = SASUM( JLEN, AB( 2, J ), 1 )
ELSE
CNORM( J ) = ZERO
END IF
20 CONTINUE
END IF
END IF
*
* Scale the column norms by TSCAL if the maximum element in CNORM is
* greater than BIGNUM.
*
IMAX = ISAMAX( N, CNORM, 1 )
TMAX = CNORM( IMAX )
IF( TMAX.LE.BIGNUM ) THEN
TSCAL = ONE
ELSE
TSCAL = ONE / ( SMLNUM*TMAX )
CALL SSCAL( N, TSCAL, CNORM, 1 )
END IF
*
* Compute a bound on the computed solution vector to see if the
* Level 2 BLAS routine STBSV can be used.
*
J = ISAMAX( N, X, 1 )
XMAX = ABS( X( J ) )
XBND = XMAX
IF( NOTRAN ) THEN
*
* Compute the growth in A * x = b.
*
IF( UPPER ) THEN
JFIRST = N
JLAST = 1
JINC = -1
MAIND = KD + 1
ELSE
JFIRST = 1
JLAST = N
JINC = 1
MAIND = 1
END IF
*
IF( TSCAL.NE.ONE ) THEN
GROW = ZERO
GO TO 50
END IF
*
IF( NOUNIT ) THEN
*
* A is non-unit triangular.
*
* Compute GROW = 1/G(j) and XBND = 1/M(j).
* Initially, G(0) = max{x(i), i=1,...,n}.
*
GROW = ONE / MAX( XBND, SMLNUM )
XBND = GROW
DO 30 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 50
*
* M(j) = G(j-1) / abs(A(j,j))
*
TJJ = ABS( AB( MAIND, J ) )
XBND = MIN( XBND, MIN( ONE, TJJ )*GROW )
IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN
*
* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
*
GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) )
ELSE
*
* G(j) could overflow, set GROW to 0.
*
GROW = ZERO
END IF
30 CONTINUE
GROW = XBND
ELSE
*
* A is unit triangular.
*
* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
*
GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
DO 40 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 50
*
* G(j) = G(j-1)*( 1 + CNORM(j) )
*
GROW = GROW*( ONE / ( ONE+CNORM( J ) ) )
40 CONTINUE
END IF
50 CONTINUE
*
ELSE
*
* Compute the growth in A' * x = b.
*
IF( UPPER ) THEN
JFIRST = 1
JLAST = N
JINC = 1
MAIND = KD + 1
ELSE
JFIRST = N
JLAST = 1
JINC = -1
MAIND = 1
END IF
*
IF( TSCAL.NE.ONE ) THEN
GROW = ZERO
GO TO 80
END IF
*
IF( NOUNIT ) THEN
*
* A is non-unit triangular.
*
* Compute GROW = 1/G(j) and XBND = 1/M(j).
* Initially, M(0) = max{x(i), i=1,...,n}.
*
GROW = ONE / MAX( XBND, SMLNUM )
XBND = GROW
DO 60 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 80
*
* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
*
XJ = ONE + CNORM( J )
GROW = MIN( GROW, XBND / XJ )
*
* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
*
TJJ = ABS( AB( MAIND, J ) )
IF( XJ.GT.TJJ )
$ XBND = XBND*( TJJ / XJ )
60 CONTINUE
GROW = MIN( GROW, XBND )
ELSE
*
* A is unit triangular.
*
* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
*
GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
DO 70 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 80
*
* G(j) = ( 1 + CNORM(j) )*G(j-1)
*
XJ = ONE + CNORM( J )
GROW = GROW / XJ
70 CONTINUE
END IF
80 CONTINUE
END IF
*
IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN
*
* Use the Level 2 BLAS solve if the reciprocal of the bound on
* elements of X is not too small.
*
CALL STBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, X, 1 )
ELSE
*
* Use a Level 1 BLAS solve, scaling intermediate results.
*
IF( XMAX.GT.BIGNUM ) THEN
*
* Scale X so that its components are less than or equal to
* BIGNUM in absolute value.
*
SCALE = BIGNUM / XMAX
CALL SSCAL( N, SCALE, X, 1 )
XMAX = BIGNUM
END IF
*
IF( NOTRAN ) THEN
*
* Solve A * x = b
*
DO 100 J = JFIRST, JLAST, JINC
*
* Compute x(j) = b(j) / A(j,j), scaling x if necessary.
*
XJ = ABS( X( J ) )
IF( NOUNIT ) THEN
TJJS = AB( MAIND, J )*TSCAL
ELSE
TJJS = TSCAL
IF( TSCAL.EQ.ONE )
$ GO TO 95
END IF
TJJ = ABS( TJJS )
IF( TJJ.GT.SMLNUM ) THEN
*
* abs(A(j,j)) > SMLNUM:
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale x by 1/b(j).
*
REC = ONE / XJ
CALL SSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
X( J ) = X( J ) / TJJS
XJ = ABS( X( J ) )
ELSE IF( TJJ.GT.ZERO ) THEN
*
* 0 < abs(A(j,j)) <= SMLNUM:
*
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
* to avoid overflow when dividing by A(j,j).
*
REC = ( TJJ*BIGNUM ) / XJ
IF( CNORM( J ).GT.ONE ) THEN
*
* Scale by 1/CNORM(j) to avoid overflow when
* multiplying x(j) times column j.
*
REC = REC / CNORM( J )
END IF
CALL SSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
X( J ) = X( J ) / TJJS
XJ = ABS( X( J ) )
ELSE
*
* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
* scale = 0, and compute a solution to A*x = 0.
*
DO 90 I = 1, N
X( I ) = ZERO
90 CONTINUE
X( J ) = ONE
XJ = ONE
SCALE = ZERO
XMAX = ZERO
END IF
95 CONTINUE
*
* Scale x if necessary to avoid overflow when adding a
* multiple of column j of A.
*
IF( XJ.GT.ONE ) THEN
REC = ONE / XJ
IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN
*
* Scale x by 1/(2*abs(x(j))).
*
REC = REC*HALF
CALL SSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
END IF
ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
*
* Scale x by 1/2.
*
CALL SSCAL( N, HALF, X, 1 )
SCALE = SCALE*HALF
END IF
*
IF( UPPER ) THEN
IF( J.GT.1 ) THEN
*
* Compute the update
* x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) -
* x(j)* A(max(1,j-kd):j-1,j)
*
JLEN = MIN( KD, J-1 )
CALL SAXPY( JLEN, -X( J )*TSCAL,
$ AB( KD+1-JLEN, J ), 1, X( J-JLEN ), 1 )
I = ISAMAX( J-1, X, 1 )
XMAX = ABS( X( I ) )
END IF
ELSE IF( J.LT.N ) THEN
*
* Compute the update
* x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) -
* x(j) * A(j+1:min(j+kd,n),j)
*
JLEN = MIN( KD, N-J )
IF( JLEN.GT.0 )
$ CALL SAXPY( JLEN, -X( J )*TSCAL, AB( 2, J ), 1,
$ X( J+1 ), 1 )
I = J + ISAMAX( N-J, X( J+1 ), 1 )
XMAX = ABS( X( I ) )
END IF
100 CONTINUE
*
ELSE
*
* Solve A' * x = b
*
DO 140 J = JFIRST, JLAST, JINC
*
* Compute x(j) = b(j) - sum A(k,j)*x(k).
* k<>j
*
XJ = ABS( X( J ) )
USCAL = TSCAL
REC = ONE / MAX( XMAX, ONE )
IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
*
* If x(j) could overflow, scale x by 1/(2*XMAX).
*
REC = REC*HALF
IF( NOUNIT ) THEN
TJJS = AB( MAIND, J )*TSCAL
ELSE
TJJS = TSCAL
END IF
TJJ = ABS( TJJS )
IF( TJJ.GT.ONE ) THEN
*
* Divide by A(j,j) when scaling x if A(j,j) > 1.
*
REC = MIN( ONE, REC*TJJ )
USCAL = USCAL / TJJS
END IF
IF( REC.LT.ONE ) THEN
CALL SSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
*
SUMJ = ZERO
IF( USCAL.EQ.ONE ) THEN
*
* If the scaling needed for A in the dot product is 1,
* call SDOT to perform the dot product.
*
IF( UPPER ) THEN
JLEN = MIN( KD, J-1 )
SUMJ = SDOT( JLEN, AB( KD+1-JLEN, J ), 1,
$ X( J-JLEN ), 1 )
ELSE
JLEN = MIN( KD, N-J )
IF( JLEN.GT.0 )
$ SUMJ = SDOT( JLEN, AB( 2, J ), 1, X( J+1 ), 1 )
END IF
ELSE
*
* Otherwise, use in-line code for the dot product.
*
IF( UPPER ) THEN
JLEN = MIN( KD, J-1 )
DO 110 I = 1, JLEN
SUMJ = SUMJ + ( AB( KD+I-JLEN, J )*USCAL )*
$ X( J-JLEN-1+I )
110 CONTINUE
ELSE
JLEN = MIN( KD, N-J )
DO 120 I = 1, JLEN
SUMJ = SUMJ + ( AB( I+1, J )*USCAL )*X( J+I )
120 CONTINUE
END IF
END IF
*
IF( USCAL.EQ.TSCAL ) THEN
*
* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j)
* was not used to scale the dotproduct.
*
X( J ) = X( J ) - SUMJ
XJ = ABS( X( J ) )
IF( NOUNIT ) THEN
*
* Compute x(j) = x(j) / A(j,j), scaling if necessary.
*
TJJS = AB( MAIND, J )*TSCAL
ELSE
TJJS = TSCAL
IF( TSCAL.EQ.ONE )
$ GO TO 135
END IF
TJJ = ABS( TJJS )
IF( TJJ.GT.SMLNUM ) THEN
*
* abs(A(j,j)) > SMLNUM:
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale X by 1/abs(x(j)).
*
REC = ONE / XJ
CALL SSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
X( J ) = X( J ) / TJJS
ELSE IF( TJJ.GT.ZERO ) THEN
*
* 0 < abs(A(j,j)) <= SMLNUM:
*
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
*
REC = ( TJJ*BIGNUM ) / XJ
CALL SSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
X( J ) = X( J ) / TJJS
ELSE
*
* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
* scale = 0, and compute a solution to A'*x = 0.
*
DO 130 I = 1, N
X( I ) = ZERO
130 CONTINUE
X( J ) = ONE
SCALE = ZERO
XMAX = ZERO
END IF
135 CONTINUE
ELSE
*
* Compute x(j) := x(j) / A(j,j) - sumj if the dot
* product has already been divided by 1/A(j,j).
*
X( J ) = X( J ) / TJJS - SUMJ
END IF
XMAX = MAX( XMAX, ABS( X( J ) ) )
140 CONTINUE
END IF
SCALE = SCALE / TSCAL
END IF
*
* Scale the column norms by 1/TSCAL for return.
*
IF( TSCAL.NE.ONE ) THEN
CALL SSCAL( N, ONE / TSCAL, CNORM, 1 )
END IF
*
RETURN
*
* End of SLATBS
*
END
SUBROUTINE SLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV,
$ JPIV )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IJOB, LDZ, N
REAL RDSCAL, RDSUM
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), JPIV( * )
REAL RHS( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SLATDF uses the LU factorization of the n-by-n matrix Z computed by
* SGETC2 and computes a contribution to the reciprocal Dif-estimate
* by solving Z * x = b for x, and choosing the r.h.s. b such that
* the norm of x is as large as possible. On entry RHS = b holds the
* contribution from earlier solved sub-systems, and on return RHS = x.
*
* The factorization of Z returned by SGETC2 has the form Z = P*L*U*Q,
* where P and Q are permutation matrices. L is lower triangular with
* unit diagonal elements and U is upper triangular.
*
* Arguments
* =========
*
* IJOB (input) INTEGER
* IJOB = 2: First compute an approximative null-vector e
* of Z using SGECON, e is normalized and solve for
* Zx = +-e - f with the sign giving the greater value
* of 2-norm(x). About 5 times as expensive as Default.
* IJOB .ne. 2: Local look ahead strategy where all entries of
* the r.h.s. b is choosen as either +1 or -1 (Default).
*
* N (input) INTEGER
* The number of columns of the matrix Z.
*
* Z (input) REAL array, dimension (LDZ, N)
* On entry, the LU part of the factorization of the n-by-n
* matrix Z computed by SGETC2: Z = P * L * U * Q
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDA >= max(1, N).
*
* RHS (input/output) REAL array, dimension N.
* On entry, RHS contains contributions from other subsystems.
* On exit, RHS contains the solution of the subsystem with
* entries acoording to the value of IJOB (see above).
*
* RDSUM (input/output) REAL
* On entry, the sum of squares of computed contributions to
* the Dif-estimate under computation by STGSYL, where the
* scaling factor RDSCAL (see below) has been factored out.
* On exit, the corresponding sum of squares updated with the
* contributions from the current sub-system.
* If TRANS = 'T' RDSUM is not touched.
* NOTE: RDSUM only makes sense when STGSY2 is called by STGSYL.
*
* RDSCAL (input/output) REAL
* On entry, scaling factor used to prevent overflow in RDSUM.
* On exit, RDSCAL is updated w.r.t. the current contributions
* in RDSUM.
* If TRANS = 'T', RDSCAL is not touched.
* NOTE: RDSCAL only makes sense when STGSY2 is called by
* STGSYL.
*
* IPIV (input) INTEGER array, dimension (N).
* The pivot indices; for 1 <= i <= N, row i of the
* matrix has been interchanged with row IPIV(i).
*
* JPIV (input) INTEGER array, dimension (N).
* The pivot indices; for 1 <= j <= N, column j of the
* matrix has been interchanged with column JPIV(j).
*
* Further Details
* ===============
*
* Based on contributions by
* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
* Umea University, S-901 87 Umea, Sweden.
*
* This routine is a further developed implementation of algorithm
* BSOLVE in [1] using complete pivoting in the LU factorization.
*
* [1] Bo Kagstrom and Lars Westin,
* Generalized Schur Methods with Condition Estimators for
* Solving the Generalized Sylvester Equation, IEEE Transactions
* on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.
*
* [2] Peter Poromaa,
* On Efficient and Robust Estimators for the Separation
* between two Regular Matrix Pairs with Applications in
* Condition Estimation. Report IMINF-95.05, Departement of
* Computing Science, Umea University, S-901 87 Umea, Sweden, 1995.
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXDIM
PARAMETER ( MAXDIM = 8 )
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J, K
REAL BM, BP, PMONE, SMINU, SPLUS, TEMP
* ..
* .. Local Arrays ..
INTEGER IWORK( MAXDIM )
REAL WORK( 4*MAXDIM ), XM( MAXDIM ), XP( MAXDIM )
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, SGECON, SGESC2, SLASSQ, SLASWP,
$ SSCAL
* ..
* .. External Functions ..
REAL SASUM, SDOT
EXTERNAL SASUM, SDOT
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SQRT
* ..
* .. Executable Statements ..
*
IF( IJOB.NE.2 ) THEN
*
* Apply permutations IPIV to RHS
*
CALL SLASWP( 1, RHS, LDZ, 1, N-1, IPIV, 1 )
*
* Solve for L-part choosing RHS either to +1 or -1.
*
PMONE = -ONE
*
DO 10 J = 1, N - 1
BP = RHS( J ) + ONE
BM = RHS( J ) - ONE
SPLUS = ONE
*
* Look-ahead for L-part RHS(1:N-1) = + or -1, SPLUS and
* SMIN computed more efficiently than in BSOLVE [1].
*
SPLUS = SPLUS + SDOT( N-J, Z( J+1, J ), 1, Z( J+1, J ), 1 )
SMINU = SDOT( N-J, Z( J+1, J ), 1, RHS( J+1 ), 1 )
SPLUS = SPLUS*RHS( J )
IF( SPLUS.GT.SMINU ) THEN
RHS( J ) = BP
ELSE IF( SMINU.GT.SPLUS ) THEN
RHS( J ) = BM
ELSE
*
* In this case the updating sums are equal and we can
* choose RHS(J) +1 or -1. The first time this happens
* we choose -1, thereafter +1. This is a simple way to
* get good estimates of matrices like Byers well-known
* example (see [1]). (Not done in BSOLVE.)
*
RHS( J ) = RHS( J ) + PMONE
PMONE = ONE
END IF
*
* Compute the remaining r.h.s.
*
TEMP = -RHS( J )
CALL SAXPY( N-J, TEMP, Z( J+1, J ), 1, RHS( J+1 ), 1 )
*
10 CONTINUE
*
* Solve for U-part, look-ahead for RHS(N) = +-1. This is not done
* in BSOLVE and will hopefully give us a better estimate because
* any ill-conditioning of the original matrix is transfered to U
* and not to L. U(N, N) is an approximation to sigma_min(LU).
*
CALL SCOPY( N-1, RHS, 1, XP, 1 )
XP( N ) = RHS( N ) + ONE
RHS( N ) = RHS( N ) - ONE
SPLUS = ZERO
SMINU = ZERO
DO 30 I = N, 1, -1
TEMP = ONE / Z( I, I )
XP( I ) = XP( I )*TEMP
RHS( I ) = RHS( I )*TEMP
DO 20 K = I + 1, N
XP( I ) = XP( I ) - XP( K )*( Z( I, K )*TEMP )
RHS( I ) = RHS( I ) - RHS( K )*( Z( I, K )*TEMP )
20 CONTINUE
SPLUS = SPLUS + ABS( XP( I ) )
SMINU = SMINU + ABS( RHS( I ) )
30 CONTINUE
IF( SPLUS.GT.SMINU )
$ CALL SCOPY( N, XP, 1, RHS, 1 )
*
* Apply the permutations JPIV to the computed solution (RHS)
*
CALL SLASWP( 1, RHS, LDZ, 1, N-1, JPIV, -1 )
*
* Compute the sum of squares
*
CALL SLASSQ( N, RHS, 1, RDSCAL, RDSUM )
*
ELSE
*
* IJOB = 2, Compute approximate nullvector XM of Z
*
CALL SGECON( 'I', N, Z, LDZ, ONE, TEMP, WORK, IWORK, INFO )
CALL SCOPY( N, WORK( N+1 ), 1, XM, 1 )
*
* Compute RHS
*
CALL SLASWP( 1, XM, LDZ, 1, N-1, IPIV, -1 )
TEMP = ONE / SQRT( SDOT( N, XM, 1, XM, 1 ) )
CALL SSCAL( N, TEMP, XM, 1 )
CALL SCOPY( N, XM, 1, XP, 1 )
CALL SAXPY( N, ONE, RHS, 1, XP, 1 )
CALL SAXPY( N, -ONE, XM, 1, RHS, 1 )
CALL SGESC2( N, Z, LDZ, RHS, IPIV, JPIV, TEMP )
CALL SGESC2( N, Z, LDZ, XP, IPIV, JPIV, TEMP )
IF( SASUM( N, XP, 1 ).GT.SASUM( N, RHS, 1 ) )
$ CALL SCOPY( N, XP, 1, RHS, 1 )
*
* Compute the sum of squares
*
CALL SLASSQ( N, RHS, 1, RDSCAL, RDSUM )
*
END IF
*
RETURN
*
* End of SLATDF
*
END
SUBROUTINE SLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE,
$ CNORM, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, NORMIN, TRANS, UPLO
INTEGER INFO, N
REAL SCALE
* ..
* .. Array Arguments ..
REAL AP( * ), CNORM( * ), X( * )
* ..
*
* Purpose
* =======
*
* SLATPS solves one of the triangular systems
*
* A *x = s*b or A'*x = s*b
*
* with scaling to prevent overflow, where A is an upper or lower
* triangular matrix stored in packed form. Here A' denotes the
* transpose of A, x and b are n-element vectors, and s is a scaling
* factor, usually less than or equal to 1, chosen so that the
* components of x will be less than the overflow threshold. If the
* unscaled problem will not cause overflow, the Level 2 BLAS routine
* STPSV is called. If the matrix A is singular (A(j,j) = 0 for some j),
* then s is set to 0 and a non-trivial solution to A*x = 0 is returned.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the operation applied to A.
* = 'N': Solve A * x = s*b (No transpose)
* = 'T': Solve A'* x = s*b (Transpose)
* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* NORMIN (input) CHARACTER*1
* Specifies whether CNORM has been set or not.
* = 'Y': CNORM contains the column norms on entry
* = 'N': CNORM is not set on entry. On exit, the norms will
* be computed and stored in CNORM.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input) REAL array, dimension (N*(N+1)/2)
* The upper or lower triangular matrix A, packed columnwise in
* a linear array. The j-th column of A is stored in the array
* AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
*
* X (input/output) REAL array, dimension (N)
* On entry, the right hand side b of the triangular system.
* On exit, X is overwritten by the solution vector x.
*
* SCALE (output) REAL
* The scaling factor s for the triangular system
* A * x = s*b or A'* x = s*b.
* If SCALE = 0, the matrix A is singular or badly scaled, and
* the vector x is an exact or approximate solution to A*x = 0.
*
* CNORM (input or output) REAL array, dimension (N)
*
* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
* contains the norm of the off-diagonal part of the j-th column
* of A. If TRANS = 'N', CNORM(j) must be greater than or equal
* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
* must be greater than or equal to the 1-norm.
*
* If NORMIN = 'N', CNORM is an output argument and CNORM(j)
* returns the 1-norm of the offdiagonal part of the j-th column
* of A.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
*
* Further Details
* ======= =======
*
* A rough bound on x is computed; if that is less than overflow, STPSV
* is called, otherwise, specific code is used which checks for possible
* overflow or divide-by-zero at every operation.
*
* A columnwise scheme is used for solving A*x = b. The basic algorithm
* if A is lower triangular is
*
* x[1:n] := b[1:n]
* for j = 1, ..., n
* x(j) := x(j) / A(j,j)
* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
* end
*
* Define bounds on the components of x after j iterations of the loop:
* M(j) = bound on x[1:j]
* G(j) = bound on x[j+1:n]
* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
*
* Then for iteration j+1 we have
* M(j+1) <= G(j) / | A(j+1,j+1) |
* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
*
* where CNORM(j+1) is greater than or equal to the infinity-norm of
* column j+1 of A, not counting the diagonal. Hence
*
* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
* 1<=i<=j
* and
*
* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
* 1<=i< j
*
* Since |x(j)| <= M(j), we use the Level 2 BLAS routine STPSV if the
* reciprocal of the largest M(j), j=1,..,n, is larger than
* max(underflow, 1/overflow).
*
* The bound on x(j) is also used to determine when a step in the
* columnwise method can be performed without fear of overflow. If
* the computed bound is greater than a large constant, x is scaled to
* prevent overflow, but if the bound overflows, x is set to 0, x(j) to
* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
*
* Similarly, a row-wise scheme is used to solve A'*x = b. The basic
* algorithm for A upper triangular is
*
* for j = 1, ..., n
* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)
* end
*
* We simultaneously compute two bounds
* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j
* M(j) = bound on x(i), 1<=i<=j
*
* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
* Then the bound on x(j) is
*
* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
*
* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
* 1<=i<=j
*
* and we can safely call STPSV if 1/M(n) and 1/G(n) are both greater
* than max(underflow, 1/overflow).
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0E+0, HALF = 0.5E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN, NOUNIT, UPPER
INTEGER I, IMAX, IP, J, JFIRST, JINC, JLAST, JLEN
REAL BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS,
$ TMAX, TSCAL, USCAL, XBND, XJ, XMAX
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SASUM, SDOT, SLAMCH
EXTERNAL LSAME, ISAMAX, SASUM, SDOT, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SSCAL, STPSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOTRAN = LSAME( TRANS, 'N' )
NOUNIT = LSAME( DIAG, 'N' )
*
* Test the input parameters.
*
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
$ LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -3
ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT.
$ LSAME( NORMIN, 'N' ) ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLATPS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Determine machine dependent parameters to control overflow.
*
SMLNUM = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
BIGNUM = ONE / SMLNUM
SCALE = ONE
*
IF( LSAME( NORMIN, 'N' ) ) THEN
*
* Compute the 1-norm of each column, not including the diagonal.
*
IF( UPPER ) THEN
*
* A is upper triangular.
*
IP = 1
DO 10 J = 1, N
CNORM( J ) = SASUM( J-1, AP( IP ), 1 )
IP = IP + J
10 CONTINUE
ELSE
*
* A is lower triangular.
*
IP = 1
DO 20 J = 1, N - 1
CNORM( J ) = SASUM( N-J, AP( IP+1 ), 1 )
IP = IP + N - J + 1
20 CONTINUE
CNORM( N ) = ZERO
END IF
END IF
*
* Scale the column norms by TSCAL if the maximum element in CNORM is
* greater than BIGNUM.
*
IMAX = ISAMAX( N, CNORM, 1 )
TMAX = CNORM( IMAX )
IF( TMAX.LE.BIGNUM ) THEN
TSCAL = ONE
ELSE
TSCAL = ONE / ( SMLNUM*TMAX )
CALL SSCAL( N, TSCAL, CNORM, 1 )
END IF
*
* Compute a bound on the computed solution vector to see if the
* Level 2 BLAS routine STPSV can be used.
*
J = ISAMAX( N, X, 1 )
XMAX = ABS( X( J ) )
XBND = XMAX
IF( NOTRAN ) THEN
*
* Compute the growth in A * x = b.
*
IF( UPPER ) THEN
JFIRST = N
JLAST = 1
JINC = -1
ELSE
JFIRST = 1
JLAST = N
JINC = 1
END IF
*
IF( TSCAL.NE.ONE ) THEN
GROW = ZERO
GO TO 50
END IF
*
IF( NOUNIT ) THEN
*
* A is non-unit triangular.
*
* Compute GROW = 1/G(j) and XBND = 1/M(j).
* Initially, G(0) = max{x(i), i=1,...,n}.
*
GROW = ONE / MAX( XBND, SMLNUM )
XBND = GROW
IP = JFIRST*( JFIRST+1 ) / 2
JLEN = N
DO 30 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 50
*
* M(j) = G(j-1) / abs(A(j,j))
*
TJJ = ABS( AP( IP ) )
XBND = MIN( XBND, MIN( ONE, TJJ )*GROW )
IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN
*
* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
*
GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) )
ELSE
*
* G(j) could overflow, set GROW to 0.
*
GROW = ZERO
END IF
IP = IP + JINC*JLEN
JLEN = JLEN - 1
30 CONTINUE
GROW = XBND
ELSE
*
* A is unit triangular.
*
* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
*
GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
DO 40 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 50
*
* G(j) = G(j-1)*( 1 + CNORM(j) )
*
GROW = GROW*( ONE / ( ONE+CNORM( J ) ) )
40 CONTINUE
END IF
50 CONTINUE
*
ELSE
*
* Compute the growth in A' * x = b.
*
IF( UPPER ) THEN
JFIRST = 1
JLAST = N
JINC = 1
ELSE
JFIRST = N
JLAST = 1
JINC = -1
END IF
*
IF( TSCAL.NE.ONE ) THEN
GROW = ZERO
GO TO 80
END IF
*
IF( NOUNIT ) THEN
*
* A is non-unit triangular.
*
* Compute GROW = 1/G(j) and XBND = 1/M(j).
* Initially, M(0) = max{x(i), i=1,...,n}.
*
GROW = ONE / MAX( XBND, SMLNUM )
XBND = GROW
IP = JFIRST*( JFIRST+1 ) / 2
JLEN = 1
DO 60 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 80
*
* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
*
XJ = ONE + CNORM( J )
GROW = MIN( GROW, XBND / XJ )
*
* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
*
TJJ = ABS( AP( IP ) )
IF( XJ.GT.TJJ )
$ XBND = XBND*( TJJ / XJ )
JLEN = JLEN + 1
IP = IP + JINC*JLEN
60 CONTINUE
GROW = MIN( GROW, XBND )
ELSE
*
* A is unit triangular.
*
* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
*
GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
DO 70 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 80
*
* G(j) = ( 1 + CNORM(j) )*G(j-1)
*
XJ = ONE + CNORM( J )
GROW = GROW / XJ
70 CONTINUE
END IF
80 CONTINUE
END IF
*
IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN
*
* Use the Level 2 BLAS solve if the reciprocal of the bound on
* elements of X is not too small.
*
CALL STPSV( UPLO, TRANS, DIAG, N, AP, X, 1 )
ELSE
*
* Use a Level 1 BLAS solve, scaling intermediate results.
*
IF( XMAX.GT.BIGNUM ) THEN
*
* Scale X so that its components are less than or equal to
* BIGNUM in absolute value.
*
SCALE = BIGNUM / XMAX
CALL SSCAL( N, SCALE, X, 1 )
XMAX = BIGNUM
END IF
*
IF( NOTRAN ) THEN
*
* Solve A * x = b
*
IP = JFIRST*( JFIRST+1 ) / 2
DO 100 J = JFIRST, JLAST, JINC
*
* Compute x(j) = b(j) / A(j,j), scaling x if necessary.
*
XJ = ABS( X( J ) )
IF( NOUNIT ) THEN
TJJS = AP( IP )*TSCAL
ELSE
TJJS = TSCAL
IF( TSCAL.EQ.ONE )
$ GO TO 95
END IF
TJJ = ABS( TJJS )
IF( TJJ.GT.SMLNUM ) THEN
*
* abs(A(j,j)) > SMLNUM:
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale x by 1/b(j).
*
REC = ONE / XJ
CALL SSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
X( J ) = X( J ) / TJJS
XJ = ABS( X( J ) )
ELSE IF( TJJ.GT.ZERO ) THEN
*
* 0 < abs(A(j,j)) <= SMLNUM:
*
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
* to avoid overflow when dividing by A(j,j).
*
REC = ( TJJ*BIGNUM ) / XJ
IF( CNORM( J ).GT.ONE ) THEN
*
* Scale by 1/CNORM(j) to avoid overflow when
* multiplying x(j) times column j.
*
REC = REC / CNORM( J )
END IF
CALL SSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
X( J ) = X( J ) / TJJS
XJ = ABS( X( J ) )
ELSE
*
* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
* scale = 0, and compute a solution to A*x = 0.
*
DO 90 I = 1, N
X( I ) = ZERO
90 CONTINUE
X( J ) = ONE
XJ = ONE
SCALE = ZERO
XMAX = ZERO
END IF
95 CONTINUE
*
* Scale x if necessary to avoid overflow when adding a
* multiple of column j of A.
*
IF( XJ.GT.ONE ) THEN
REC = ONE / XJ
IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN
*
* Scale x by 1/(2*abs(x(j))).
*
REC = REC*HALF
CALL SSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
END IF
ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
*
* Scale x by 1/2.
*
CALL SSCAL( N, HALF, X, 1 )
SCALE = SCALE*HALF
END IF
*
IF( UPPER ) THEN
IF( J.GT.1 ) THEN
*
* Compute the update
* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j)
*
CALL SAXPY( J-1, -X( J )*TSCAL, AP( IP-J+1 ), 1, X,
$ 1 )
I = ISAMAX( J-1, X, 1 )
XMAX = ABS( X( I ) )
END IF
IP = IP - J
ELSE
IF( J.LT.N ) THEN
*
* Compute the update
* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j)
*
CALL SAXPY( N-J, -X( J )*TSCAL, AP( IP+1 ), 1,
$ X( J+1 ), 1 )
I = J + ISAMAX( N-J, X( J+1 ), 1 )
XMAX = ABS( X( I ) )
END IF
IP = IP + N - J + 1
END IF
100 CONTINUE
*
ELSE
*
* Solve A' * x = b
*
IP = JFIRST*( JFIRST+1 ) / 2
JLEN = 1
DO 140 J = JFIRST, JLAST, JINC
*
* Compute x(j) = b(j) - sum A(k,j)*x(k).
* k<>j
*
XJ = ABS( X( J ) )
USCAL = TSCAL
REC = ONE / MAX( XMAX, ONE )
IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
*
* If x(j) could overflow, scale x by 1/(2*XMAX).
*
REC = REC*HALF
IF( NOUNIT ) THEN
TJJS = AP( IP )*TSCAL
ELSE
TJJS = TSCAL
END IF
TJJ = ABS( TJJS )
IF( TJJ.GT.ONE ) THEN
*
* Divide by A(j,j) when scaling x if A(j,j) > 1.
*
REC = MIN( ONE, REC*TJJ )
USCAL = USCAL / TJJS
END IF
IF( REC.LT.ONE ) THEN
CALL SSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
*
SUMJ = ZERO
IF( USCAL.EQ.ONE ) THEN
*
* If the scaling needed for A in the dot product is 1,
* call SDOT to perform the dot product.
*
IF( UPPER ) THEN
SUMJ = SDOT( J-1, AP( IP-J+1 ), 1, X, 1 )
ELSE IF( J.LT.N ) THEN
SUMJ = SDOT( N-J, AP( IP+1 ), 1, X( J+1 ), 1 )
END IF
ELSE
*
* Otherwise, use in-line code for the dot product.
*
IF( UPPER ) THEN
DO 110 I = 1, J - 1
SUMJ = SUMJ + ( AP( IP-J+I )*USCAL )*X( I )
110 CONTINUE
ELSE IF( J.LT.N ) THEN
DO 120 I = 1, N - J
SUMJ = SUMJ + ( AP( IP+I )*USCAL )*X( J+I )
120 CONTINUE
END IF
END IF
*
IF( USCAL.EQ.TSCAL ) THEN
*
* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j)
* was not used to scale the dotproduct.
*
X( J ) = X( J ) - SUMJ
XJ = ABS( X( J ) )
IF( NOUNIT ) THEN
*
* Compute x(j) = x(j) / A(j,j), scaling if necessary.
*
TJJS = AP( IP )*TSCAL
ELSE
TJJS = TSCAL
IF( TSCAL.EQ.ONE )
$ GO TO 135
END IF
TJJ = ABS( TJJS )
IF( TJJ.GT.SMLNUM ) THEN
*
* abs(A(j,j)) > SMLNUM:
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale X by 1/abs(x(j)).
*
REC = ONE / XJ
CALL SSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
X( J ) = X( J ) / TJJS
ELSE IF( TJJ.GT.ZERO ) THEN
*
* 0 < abs(A(j,j)) <= SMLNUM:
*
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
*
REC = ( TJJ*BIGNUM ) / XJ
CALL SSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
X( J ) = X( J ) / TJJS
ELSE
*
* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
* scale = 0, and compute a solution to A'*x = 0.
*
DO 130 I = 1, N
X( I ) = ZERO
130 CONTINUE
X( J ) = ONE
SCALE = ZERO
XMAX = ZERO
END IF
135 CONTINUE
ELSE
*
* Compute x(j) := x(j) / A(j,j) - sumj if the dot
* product has already been divided by 1/A(j,j).
*
X( J ) = X( J ) / TJJS - SUMJ
END IF
XMAX = MAX( XMAX, ABS( X( J ) ) )
JLEN = JLEN + 1
IP = IP + JINC*JLEN
140 CONTINUE
END IF
SCALE = SCALE / TSCAL
END IF
*
* Scale the column norms by 1/TSCAL for return.
*
IF( TSCAL.NE.ONE ) THEN
CALL SSCAL( N, ONE / TSCAL, CNORM, 1 )
END IF
*
RETURN
*
* End of SLATPS
*
END
SUBROUTINE SLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDA, LDW, N, NB
* ..
* .. Array Arguments ..
REAL A( LDA, * ), E( * ), TAU( * ), W( LDW, * )
* ..
*
* Purpose
* =======
*
* SLATRD reduces NB rows and columns of a real symmetric matrix A to
* symmetric tridiagonal form by an orthogonal similarity
* transformation Q' * A * Q, and returns the matrices V and W which are
* needed to apply the transformation to the unreduced part of A.
*
* If UPLO = 'U', SLATRD reduces the last NB rows and columns of a
* matrix, of which the upper triangle is supplied;
* if UPLO = 'L', SLATRD reduces the first NB rows and columns of a
* matrix, of which the lower triangle is supplied.
*
* This is an auxiliary routine called by SSYTRD.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The order of the matrix A.
*
* NB (input) INTEGER
* The number of rows and columns to be reduced.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the symmetric matrix A. If UPLO = 'U', the leading
* n-by-n upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading n-by-n lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced.
* On exit:
* if UPLO = 'U', the last NB columns have been reduced to
* tridiagonal form, with the diagonal elements overwriting
* the diagonal elements of A; the elements above the diagonal
* with the array TAU, represent the orthogonal matrix Q as a
* product of elementary reflectors;
* if UPLO = 'L', the first NB columns have been reduced to
* tridiagonal form, with the diagonal elements overwriting
* the diagonal elements of A; 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 >= (1,N).
*
* E (output) REAL array, dimension (N-1)
* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal
* elements of the last NB columns of the reduced matrix;
* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of
* the first NB columns of the reduced matrix.
*
* TAU (output) REAL array, dimension (N-1)
* The scalar factors of the elementary reflectors, stored in
* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.
* See Further Details.
*
* W (output) REAL array, dimension (LDW,NB)
* The n-by-nb matrix W required to update the unreduced part
* of A.
*
* LDW (input) INTEGER
* The leading dimension of the array W. LDW >= max(1,N).
*
* Further Details
* ===============
*
* If UPLO = 'U', the matrix Q is represented as a product of elementary
* reflectors
*
* Q = H(n) H(n-1) . . . H(n-nb+1).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a real scalar, and v is a real vector with
* v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),
* and tau in TAU(i-1).
*
* If UPLO = 'L', the matrix Q is represented as a product of elementary
* reflectors
*
* Q = H(1) H(2) . . . H(nb).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a real scalar, and v is a real vector with
* v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
* and tau in TAU(i).
*
* The elements of the vectors v together form the n-by-nb matrix V
* which is needed, with W, to apply the transformation to the unreduced
* part of the matrix, using a symmetric rank-2k update of the form:
* A := A - V*W' - W*V'.
*
* The contents of A on exit are illustrated by the following examples
* with n = 5 and nb = 2:
*
* if UPLO = 'U': if UPLO = 'L':
*
* ( a a a v4 v5 ) ( d )
* ( a a v4 v5 ) ( 1 d )
* ( a 1 v5 ) ( v1 1 a )
* ( d 1 ) ( v1 v2 a a )
* ( d ) ( v1 v2 a a a )
*
* where d denotes a diagonal element of the reduced matrix, a denotes
* an element of the original matrix that is unchanged, and vi denotes
* an element of the vector defining H(i).
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, HALF
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, HALF = 0.5E+0 )
* ..
* .. Local Scalars ..
INTEGER I, IW
REAL ALPHA
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SGEMV, SLARFG, SSCAL, SSYMV
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SDOT
EXTERNAL LSAME, SDOT
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Reduce last NB columns of upper triangle
*
DO 10 I = N, N - NB + 1, -1
IW = I - N + NB
IF( I.LT.N ) THEN
*
* Update A(1:i,i)
*
CALL SGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ),
$ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 )
CALL SGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ),
$ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 )
END IF
IF( I.GT.1 ) THEN
*
* Generate elementary reflector H(i) to annihilate
* A(1:i-2,i)
*
CALL SLARFG( I-1, A( I-1, I ), A( 1, I ), 1, TAU( I-1 ) )
E( I-1 ) = A( I-1, I )
A( I-1, I ) = ONE
*
* Compute W(1:i-1,i)
*
CALL SSYMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1,
$ ZERO, W( 1, IW ), 1 )
IF( I.LT.N ) THEN
CALL SGEMV( 'Transpose', I-1, N-I, ONE, W( 1, IW+1 ),
$ LDW, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 )
CALL SGEMV( 'No transpose', I-1, N-I, -ONE,
$ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE,
$ W( 1, IW ), 1 )
CALL SGEMV( 'Transpose', I-1, N-I, ONE, A( 1, I+1 ),
$ LDA, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 )
CALL SGEMV( 'No transpose', I-1, N-I, -ONE,
$ W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE,
$ W( 1, IW ), 1 )
END IF
CALL SSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 )
ALPHA = -HALF*TAU( I-1 )*SDOT( I-1, W( 1, IW ), 1,
$ A( 1, I ), 1 )
CALL SAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 )
END IF
*
10 CONTINUE
ELSE
*
* Reduce first NB columns of lower triangle
*
DO 20 I = 1, NB
*
* Update A(i:n,i)
*
CALL SGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ),
$ LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 )
CALL SGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ),
$ LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 )
IF( I.LT.N ) THEN
*
* Generate elementary reflector H(i) to annihilate
* A(i+2:n,i)
*
CALL SLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1,
$ TAU( I ) )
E( I ) = A( I+1, I )
A( I+1, I ) = ONE
*
* Compute W(i+1:n,i)
*
CALL SSYMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA,
$ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 )
CALL SGEMV( 'Transpose', N-I, I-1, ONE, W( I+1, 1 ), LDW,
$ A( I+1, I ), 1, ZERO, W( 1, I ), 1 )
CALL SGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ),
$ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
CALL SGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA,
$ A( I+1, I ), 1, ZERO, W( 1, I ), 1 )
CALL SGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ),
$ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
CALL SSCAL( N-I, TAU( I ), W( I+1, I ), 1 )
ALPHA = -HALF*TAU( I )*SDOT( N-I, W( I+1, I ), 1,
$ A( I+1, I ), 1 )
CALL SAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 )
END IF
*
20 CONTINUE
END IF
*
RETURN
*
* End of SLATRD
*
END
SUBROUTINE SLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE,
$ CNORM, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, NORMIN, TRANS, UPLO
INTEGER INFO, LDA, N
REAL SCALE
* ..
* .. Array Arguments ..
REAL A( LDA, * ), CNORM( * ), X( * )
* ..
*
* Purpose
* =======
*
* SLATRS solves one of the triangular systems
*
* A *x = s*b or A'*x = s*b
*
* with scaling to prevent overflow. Here A is an upper or lower
* triangular matrix, A' denotes the transpose of A, x and b are
* n-element vectors, and s is a scaling factor, usually less than
* or equal to 1, chosen so that the components of x will be less than
* the overflow threshold. If the unscaled problem will not cause
* overflow, the Level 2 BLAS routine STRSV is called. If the matrix A
* is singular (A(j,j) = 0 for some j), then s is set to 0 and a
* non-trivial solution to A*x = 0 is returned.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the operation applied to A.
* = 'N': Solve A * x = s*b (No transpose)
* = 'T': Solve A'* x = s*b (Transpose)
* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* NORMIN (input) CHARACTER*1
* Specifies whether CNORM has been set or not.
* = 'Y': CNORM contains the column norms on entry
* = 'N': CNORM is not set on entry. On exit, the norms will
* be computed and stored in CNORM.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The triangular matrix A. If UPLO = 'U', the leading n by n
* upper triangular part of the array A contains the upper
* triangular matrix, and the strictly lower triangular part of
* A is not referenced. If UPLO = 'L', the leading n by n lower
* triangular part of the array A contains the lower triangular
* matrix, and the strictly upper triangular part of A is not
* referenced. If DIAG = 'U', the diagonal elements of A are
* also not referenced and are assumed to be 1.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max (1,N).
*
* X (input/output) REAL array, dimension (N)
* On entry, the right hand side b of the triangular system.
* On exit, X is overwritten by the solution vector x.
*
* SCALE (output) REAL
* The scaling factor s for the triangular system
* A * x = s*b or A'* x = s*b.
* If SCALE = 0, the matrix A is singular or badly scaled, and
* the vector x is an exact or approximate solution to A*x = 0.
*
* CNORM (input or output) REAL array, dimension (N)
*
* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
* contains the norm of the off-diagonal part of the j-th column
* of A. If TRANS = 'N', CNORM(j) must be greater than or equal
* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
* must be greater than or equal to the 1-norm.
*
* If NORMIN = 'N', CNORM is an output argument and CNORM(j)
* returns the 1-norm of the offdiagonal part of the j-th column
* of A.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
*
* Further Details
* ======= =======
*
* A rough bound on x is computed; if that is less than overflow, STRSV
* is called, otherwise, specific code is used which checks for possible
* overflow or divide-by-zero at every operation.
*
* A columnwise scheme is used for solving A*x = b. The basic algorithm
* if A is lower triangular is
*
* x[1:n] := b[1:n]
* for j = 1, ..., n
* x(j) := x(j) / A(j,j)
* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
* end
*
* Define bounds on the components of x after j iterations of the loop:
* M(j) = bound on x[1:j]
* G(j) = bound on x[j+1:n]
* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
*
* Then for iteration j+1 we have
* M(j+1) <= G(j) / | A(j+1,j+1) |
* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
*
* where CNORM(j+1) is greater than or equal to the infinity-norm of
* column j+1 of A, not counting the diagonal. Hence
*
* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
* 1<=i<=j
* and
*
* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
* 1<=i< j
*
* Since |x(j)| <= M(j), we use the Level 2 BLAS routine STRSV if the
* reciprocal of the largest M(j), j=1,..,n, is larger than
* max(underflow, 1/overflow).
*
* The bound on x(j) is also used to determine when a step in the
* columnwise method can be performed without fear of overflow. If
* the computed bound is greater than a large constant, x is scaled to
* prevent overflow, but if the bound overflows, x is set to 0, x(j) to
* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
*
* Similarly, a row-wise scheme is used to solve A'*x = b. The basic
* algorithm for A upper triangular is
*
* for j = 1, ..., n
* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)
* end
*
* We simultaneously compute two bounds
* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j
* M(j) = bound on x(i), 1<=i<=j
*
* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
* Then the bound on x(j) is
*
* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
*
* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
* 1<=i<=j
*
* and we can safely call STRSV if 1/M(n) and 1/G(n) are both greater
* than max(underflow, 1/overflow).
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0E+0, HALF = 0.5E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN, NOUNIT, UPPER
INTEGER I, IMAX, J, JFIRST, JINC, JLAST
REAL BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS,
$ TMAX, TSCAL, USCAL, XBND, XJ, XMAX
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SASUM, SDOT, SLAMCH
EXTERNAL LSAME, ISAMAX, SASUM, SDOT, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SSCAL, STRSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOTRAN = LSAME( TRANS, 'N' )
NOUNIT = LSAME( DIAG, 'N' )
*
* Test the input parameters.
*
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
$ LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -3
ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT.
$ LSAME( NORMIN, 'N' ) ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLATRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Determine machine dependent parameters to control overflow.
*
SMLNUM = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
BIGNUM = ONE / SMLNUM
SCALE = ONE
*
IF( LSAME( NORMIN, 'N' ) ) THEN
*
* Compute the 1-norm of each column, not including the diagonal.
*
IF( UPPER ) THEN
*
* A is upper triangular.
*
DO 10 J = 1, N
CNORM( J ) = SASUM( J-1, A( 1, J ), 1 )
10 CONTINUE
ELSE
*
* A is lower triangular.
*
DO 20 J = 1, N - 1
CNORM( J ) = SASUM( N-J, A( J+1, J ), 1 )
20 CONTINUE
CNORM( N ) = ZERO
END IF
END IF
*
* Scale the column norms by TSCAL if the maximum element in CNORM is
* greater than BIGNUM.
*
IMAX = ISAMAX( N, CNORM, 1 )
TMAX = CNORM( IMAX )
IF( TMAX.LE.BIGNUM ) THEN
TSCAL = ONE
ELSE
TSCAL = ONE / ( SMLNUM*TMAX )
CALL SSCAL( N, TSCAL, CNORM, 1 )
END IF
*
* Compute a bound on the computed solution vector to see if the
* Level 2 BLAS routine STRSV can be used.
*
J = ISAMAX( N, X, 1 )
XMAX = ABS( X( J ) )
XBND = XMAX
IF( NOTRAN ) THEN
*
* Compute the growth in A * x = b.
*
IF( UPPER ) THEN
JFIRST = N
JLAST = 1
JINC = -1
ELSE
JFIRST = 1
JLAST = N
JINC = 1
END IF
*
IF( TSCAL.NE.ONE ) THEN
GROW = ZERO
GO TO 50
END IF
*
IF( NOUNIT ) THEN
*
* A is non-unit triangular.
*
* Compute GROW = 1/G(j) and XBND = 1/M(j).
* Initially, G(0) = max{x(i), i=1,...,n}.
*
GROW = ONE / MAX( XBND, SMLNUM )
XBND = GROW
DO 30 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 50
*
* M(j) = G(j-1) / abs(A(j,j))
*
TJJ = ABS( A( J, J ) )
XBND = MIN( XBND, MIN( ONE, TJJ )*GROW )
IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN
*
* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
*
GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) )
ELSE
*
* G(j) could overflow, set GROW to 0.
*
GROW = ZERO
END IF
30 CONTINUE
GROW = XBND
ELSE
*
* A is unit triangular.
*
* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
*
GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
DO 40 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 50
*
* G(j) = G(j-1)*( 1 + CNORM(j) )
*
GROW = GROW*( ONE / ( ONE+CNORM( J ) ) )
40 CONTINUE
END IF
50 CONTINUE
*
ELSE
*
* Compute the growth in A' * x = b.
*
IF( UPPER ) THEN
JFIRST = 1
JLAST = N
JINC = 1
ELSE
JFIRST = N
JLAST = 1
JINC = -1
END IF
*
IF( TSCAL.NE.ONE ) THEN
GROW = ZERO
GO TO 80
END IF
*
IF( NOUNIT ) THEN
*
* A is non-unit triangular.
*
* Compute GROW = 1/G(j) and XBND = 1/M(j).
* Initially, M(0) = max{x(i), i=1,...,n}.
*
GROW = ONE / MAX( XBND, SMLNUM )
XBND = GROW
DO 60 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 80
*
* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
*
XJ = ONE + CNORM( J )
GROW = MIN( GROW, XBND / XJ )
*
* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
*
TJJ = ABS( A( J, J ) )
IF( XJ.GT.TJJ )
$ XBND = XBND*( TJJ / XJ )
60 CONTINUE
GROW = MIN( GROW, XBND )
ELSE
*
* A is unit triangular.
*
* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
*
GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
DO 70 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 80
*
* G(j) = ( 1 + CNORM(j) )*G(j-1)
*
XJ = ONE + CNORM( J )
GROW = GROW / XJ
70 CONTINUE
END IF
80 CONTINUE
END IF
*
IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN
*
* Use the Level 2 BLAS solve if the reciprocal of the bound on
* elements of X is not too small.
*
CALL STRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 )
ELSE
*
* Use a Level 1 BLAS solve, scaling intermediate results.
*
IF( XMAX.GT.BIGNUM ) THEN
*
* Scale X so that its components are less than or equal to
* BIGNUM in absolute value.
*
SCALE = BIGNUM / XMAX
CALL SSCAL( N, SCALE, X, 1 )
XMAX = BIGNUM
END IF
*
IF( NOTRAN ) THEN
*
* Solve A * x = b
*
DO 100 J = JFIRST, JLAST, JINC
*
* Compute x(j) = b(j) / A(j,j), scaling x if necessary.
*
XJ = ABS( X( J ) )
IF( NOUNIT ) THEN
TJJS = A( J, J )*TSCAL
ELSE
TJJS = TSCAL
IF( TSCAL.EQ.ONE )
$ GO TO 95
END IF
TJJ = ABS( TJJS )
IF( TJJ.GT.SMLNUM ) THEN
*
* abs(A(j,j)) > SMLNUM:
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale x by 1/b(j).
*
REC = ONE / XJ
CALL SSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
X( J ) = X( J ) / TJJS
XJ = ABS( X( J ) )
ELSE IF( TJJ.GT.ZERO ) THEN
*
* 0 < abs(A(j,j)) <= SMLNUM:
*
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
* to avoid overflow when dividing by A(j,j).
*
REC = ( TJJ*BIGNUM ) / XJ
IF( CNORM( J ).GT.ONE ) THEN
*
* Scale by 1/CNORM(j) to avoid overflow when
* multiplying x(j) times column j.
*
REC = REC / CNORM( J )
END IF
CALL SSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
X( J ) = X( J ) / TJJS
XJ = ABS( X( J ) )
ELSE
*
* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
* scale = 0, and compute a solution to A*x = 0.
*
DO 90 I = 1, N
X( I ) = ZERO
90 CONTINUE
X( J ) = ONE
XJ = ONE
SCALE = ZERO
XMAX = ZERO
END IF
95 CONTINUE
*
* Scale x if necessary to avoid overflow when adding a
* multiple of column j of A.
*
IF( XJ.GT.ONE ) THEN
REC = ONE / XJ
IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN
*
* Scale x by 1/(2*abs(x(j))).
*
REC = REC*HALF
CALL SSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
END IF
ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
*
* Scale x by 1/2.
*
CALL SSCAL( N, HALF, X, 1 )
SCALE = SCALE*HALF
END IF
*
IF( UPPER ) THEN
IF( J.GT.1 ) THEN
*
* Compute the update
* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j)
*
CALL SAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X,
$ 1 )
I = ISAMAX( J-1, X, 1 )
XMAX = ABS( X( I ) )
END IF
ELSE
IF( J.LT.N ) THEN
*
* Compute the update
* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j)
*
CALL SAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1,
$ X( J+1 ), 1 )
I = J + ISAMAX( N-J, X( J+1 ), 1 )
XMAX = ABS( X( I ) )
END IF
END IF
100 CONTINUE
*
ELSE
*
* Solve A' * x = b
*
DO 140 J = JFIRST, JLAST, JINC
*
* Compute x(j) = b(j) - sum A(k,j)*x(k).
* k<>j
*
XJ = ABS( X( J ) )
USCAL = TSCAL
REC = ONE / MAX( XMAX, ONE )
IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
*
* If x(j) could overflow, scale x by 1/(2*XMAX).
*
REC = REC*HALF
IF( NOUNIT ) THEN
TJJS = A( J, J )*TSCAL
ELSE
TJJS = TSCAL
END IF
TJJ = ABS( TJJS )
IF( TJJ.GT.ONE ) THEN
*
* Divide by A(j,j) when scaling x if A(j,j) > 1.
*
REC = MIN( ONE, REC*TJJ )
USCAL = USCAL / TJJS
END IF
IF( REC.LT.ONE ) THEN
CALL SSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
*
SUMJ = ZERO
IF( USCAL.EQ.ONE ) THEN
*
* If the scaling needed for A in the dot product is 1,
* call SDOT to perform the dot product.
*
IF( UPPER ) THEN
SUMJ = SDOT( J-1, A( 1, J ), 1, X, 1 )
ELSE IF( J.LT.N ) THEN
SUMJ = SDOT( N-J, A( J+1, J ), 1, X( J+1 ), 1 )
END IF
ELSE
*
* Otherwise, use in-line code for the dot product.
*
IF( UPPER ) THEN
DO 110 I = 1, J - 1
SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I )
110 CONTINUE
ELSE IF( J.LT.N ) THEN
DO 120 I = J + 1, N
SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I )
120 CONTINUE
END IF
END IF
*
IF( USCAL.EQ.TSCAL ) THEN
*
* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j)
* was not used to scale the dotproduct.
*
X( J ) = X( J ) - SUMJ
XJ = ABS( X( J ) )
IF( NOUNIT ) THEN
TJJS = A( J, J )*TSCAL
ELSE
TJJS = TSCAL
IF( TSCAL.EQ.ONE )
$ GO TO 135
END IF
*
* Compute x(j) = x(j) / A(j,j), scaling if necessary.
*
TJJ = ABS( TJJS )
IF( TJJ.GT.SMLNUM ) THEN
*
* abs(A(j,j)) > SMLNUM:
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale X by 1/abs(x(j)).
*
REC = ONE / XJ
CALL SSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
X( J ) = X( J ) / TJJS
ELSE IF( TJJ.GT.ZERO ) THEN
*
* 0 < abs(A(j,j)) <= SMLNUM:
*
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
*
REC = ( TJJ*BIGNUM ) / XJ
CALL SSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
X( J ) = X( J ) / TJJS
ELSE
*
* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
* scale = 0, and compute a solution to A'*x = 0.
*
DO 130 I = 1, N
X( I ) = ZERO
130 CONTINUE
X( J ) = ONE
SCALE = ZERO
XMAX = ZERO
END IF
135 CONTINUE
ELSE
*
* Compute x(j) := x(j) / A(j,j) - sumj if the dot
* product has already been divided by 1/A(j,j).
*
X( J ) = X( J ) / TJJS - SUMJ
END IF
XMAX = MAX( XMAX, ABS( X( J ) ) )
140 CONTINUE
END IF
SCALE = SCALE / TSCAL
END IF
*
* Scale the column norms by 1/TSCAL for return.
*
IF( TSCAL.NE.ONE ) THEN
CALL SSCAL( N, ONE / TSCAL, CNORM, 1 )
END IF
*
RETURN
*
* End of SLATRS
*
END
SUBROUTINE SLATRZ( M, N, L, A, LDA, TAU, WORK )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER L, LDA, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SLATRZ factors the M-by-(M+L) real upper trapezoidal matrix
* [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z, by means
* of orthogonal transformations. Z is an (M+L)-by-(M+L) orthogonal
* matrix and, R and A1 are M-by-M upper triangular matrices.
*
* 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.
*
* L (input) INTEGER
* The number of columns of the matrix A containing the
* meaningful part of the Householder vectors. N-M >= L >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the leading M-by-N upper trapezoidal part of the
* array A must contain the matrix to be factorized.
* On exit, the leading M-by-M upper triangular part of A
* contains the upper triangular matrix R, and elements N-L+1 to
* N of the first M rows of A, with the array TAU, represent the
* orthogonal matrix Z as a product of M elementary reflectors.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* TAU (output) REAL array, dimension (M)
* The scalar factors of the elementary reflectors.
*
* WORK (workspace) REAL array, dimension (M)
*
* Further Details
* ===============
*
* Based on contributions by
* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*
* The factorization is obtained by Householder's method. The kth
* transformation matrix, Z( k ), which is used to introduce zeros into
* the ( m - k + 1 )th row of A, is given in the form
*
* Z( k ) = ( I 0 ),
* ( 0 T( k ) )
*
* where
*
* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),
* ( 0 )
* ( z( k ) )
*
* tau is a scalar and z( k ) is an l element vector. tau and z( k )
* are chosen to annihilate the elements of the kth row of A2.
*
* The scalar tau is returned in the kth element of TAU and the vector
* u( k ) in the kth row of A2, such that the elements of z( k ) are
* in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in
* the upper triangular part of A1.
*
* Z is given by
*
* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I
* ..
* .. External Subroutines ..
EXTERNAL SLARFG, SLARZ
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
* Quick return if possible
*
IF( M.EQ.0 ) THEN
RETURN
ELSE IF( M.EQ.N ) THEN
DO 10 I = 1, N
TAU( I ) = ZERO
10 CONTINUE
RETURN
END IF
*
DO 20 I = M, 1, -1
*
* Generate elementary reflector H(i) to annihilate
* [ A(i,i) A(i,n-l+1:n) ]
*
CALL SLARFG( L+1, A( I, I ), A( I, N-L+1 ), LDA, TAU( I ) )
*
* Apply H(i) to A(1:i-1,i:n) from the right
*
CALL SLARZ( 'Right', I-1, N-I+1, L, A( I, N-L+1 ), LDA,
$ TAU( I ), A( 1, I ), LDA, WORK )
*
20 CONTINUE
*
RETURN
*
* End of SLATRZ
*
END
SUBROUTINE SLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE
INTEGER INCV, LDC, M, N
REAL TAU
* ..
* .. Array Arguments ..
REAL C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* This routine is deprecated and has been replaced by routine SORMRZ.
*
* SLATZM applies a Householder matrix generated by STZRQF to a matrix.
*
* Let P = I - tau*u*u', u = ( 1 ),
* ( v )
* where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if
* SIDE = 'R'.
*
* If SIDE equals 'L', let
* C = [ C1 ] 1
* [ C2 ] m-1
* n
* Then C is overwritten by P*C.
*
* If SIDE equals 'R', let
* C = [ C1, C2 ] m
* 1 n-1
* Then C is overwritten by C*P.
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* = 'L': form P * C
* = 'R': form C * P
*
* M (input) INTEGER
* The number of rows of the matrix C.
*
* N (input) INTEGER
* The number of columns of the matrix C.
*
* V (input) REAL array, dimension
* (1 + (M-1)*abs(INCV)) if SIDE = 'L'
* (1 + (N-1)*abs(INCV)) if SIDE = 'R'
* The vector v in the representation of P. V is not used
* if TAU = 0.
*
* INCV (input) INTEGER
* The increment between elements of v. INCV <> 0
*
* TAU (input) REAL
* The value tau in the representation of P.
*
* C1 (input/output) REAL array, dimension
* (LDC,N) if SIDE = 'L'
* (M,1) if SIDE = 'R'
* On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1
* if SIDE = 'R'.
*
* On exit, the first row of P*C if SIDE = 'L', or the first
* column of C*P if SIDE = 'R'.
*
* C2 (input/output) REAL array, dimension
* (LDC, N) if SIDE = 'L'
* (LDC, N-1) if SIDE = 'R'
* On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the
* m x (n - 1) matrix C2 if SIDE = 'R'.
*
* On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P
* if SIDE = 'R'.
*
* LDC (input) INTEGER
* The leading dimension of the arrays C1 and C2. LDC >= (1,M).
*
* WORK (workspace) REAL array, dimension
* (N) if SIDE = 'L'
* (M) if SIDE = 'R'
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, SGEMV, SGER
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
IF( ( MIN( M, N ).EQ.0 ) .OR. ( TAU.EQ.ZERO ) )
$ RETURN
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* w := C1 + v' * C2
*
CALL SCOPY( N, C1, LDC, WORK, 1 )
CALL SGEMV( 'Transpose', M-1, N, ONE, C2, LDC, V, INCV, ONE,
$ WORK, 1 )
*
* [ C1 ] := [ C1 ] - tau* [ 1 ] * w'
* [ C2 ] [ C2 ] [ v ]
*
CALL SAXPY( N, -TAU, WORK, 1, C1, LDC )
CALL SGER( M-1, N, -TAU, V, INCV, WORK, 1, C2, LDC )
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* w := C1 + C2 * v
*
CALL SCOPY( M, C1, 1, WORK, 1 )
CALL SGEMV( 'No transpose', M, N-1, ONE, C2, LDC, V, INCV, ONE,
$ WORK, 1 )
*
* [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v']
*
CALL SAXPY( M, -TAU, WORK, 1, C1, 1 )
CALL SGER( M, N-1, -TAU, WORK, 1, V, INCV, C2, LDC )
END IF
*
RETURN
*
* End of SLATZM
*
END
SUBROUTINE SLAUU2( UPLO, N, A, LDA, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
REAL A( LDA, * )
* ..
*
* Purpose
* =======
*
* SLAUU2 computes the product U * U' or L' * L, where the triangular
* factor U or L is stored in the upper or lower triangular part of
* the array A.
*
* If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
* overwriting the factor U in A.
* If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
* overwriting the factor L in A.
*
* This is the unblocked form of the algorithm, calling Level 2 BLAS.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the triangular factor stored in the array A
* is upper or lower triangular:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The order of the triangular factor U or L. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the triangular factor U or L.
* On exit, if UPLO = 'U', the upper triangle of A is
* overwritten with the upper triangle of the product U * U';
* if UPLO = 'L', the lower triangle of A is overwritten with
* the lower triangle of the product L' * L.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I
REAL AII
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SDOT
EXTERNAL LSAME, SDOT
* ..
* .. External Subroutines ..
EXTERNAL SGEMV, SSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLAUU2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Compute the product U * U'.
*
DO 10 I = 1, N
AII = A( I, I )
IF( I.LT.N ) THEN
A( I, I ) = SDOT( N-I+1, A( I, I ), LDA, A( I, I ), LDA )
CALL SGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ),
$ LDA, A( I, I+1 ), LDA, AII, A( 1, I ), 1 )
ELSE
CALL SSCAL( I, AII, A( 1, I ), 1 )
END IF
10 CONTINUE
*
ELSE
*
* Compute the product L' * L.
*
DO 20 I = 1, N
AII = A( I, I )
IF( I.LT.N ) THEN
A( I, I ) = SDOT( N-I+1, A( I, I ), 1, A( I, I ), 1 )
CALL SGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA,
$ A( I+1, I ), 1, AII, A( I, 1 ), LDA )
ELSE
CALL SSCAL( I, AII, A( I, 1 ), LDA )
END IF
20 CONTINUE
END IF
*
RETURN
*
* End of SLAUU2
*
END
SUBROUTINE SLAUUM( UPLO, N, A, LDA, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
REAL A( LDA, * )
* ..
*
* Purpose
* =======
*
* SLAUUM computes the product U * U' or L' * L, where the triangular
* factor U or L is stored in the upper or lower triangular part of
* the array A.
*
* If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
* overwriting the factor U in A.
* If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
* overwriting the factor L in A.
*
* This is the blocked form of the algorithm, calling Level 3 BLAS.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the triangular factor stored in the array A
* is upper or lower triangular:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The order of the triangular factor U or L. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the triangular factor U or L.
* On exit, if UPLO = 'U', the upper triangle of A is
* overwritten with the upper triangle of the product U * U';
* if UPLO = 'L', the lower triangle of A is overwritten with
* the lower triangle of the product L' * L.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, IB, NB
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SLAUU2, SSYRK, STRMM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLAUUM', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Determine the block size for this environment.
*
NB = ILAENV( 1, 'SLAUUM', UPLO, N, -1, -1, -1 )
*
IF( NB.LE.1 .OR. NB.GE.N ) THEN
*
* Use unblocked code
*
CALL SLAUU2( UPLO, N, A, LDA, INFO )
ELSE
*
* Use blocked code
*
IF( UPPER ) THEN
*
* Compute the product U * U'.
*
DO 10 I = 1, N, NB
IB = MIN( NB, N-I+1 )
CALL STRMM( 'Right', 'Upper', 'Transpose', 'Non-unit',
$ I-1, IB, ONE, A( I, I ), LDA, A( 1, I ),
$ LDA )
CALL SLAUU2( 'Upper', IB, A( I, I ), LDA, INFO )
IF( I+IB.LE.N ) THEN
CALL SGEMM( 'No transpose', 'Transpose', I-1, IB,
$ N-I-IB+1, ONE, A( 1, I+IB ), LDA,
$ A( I, I+IB ), LDA, ONE, A( 1, I ), LDA )
CALL SSYRK( 'Upper', 'No transpose', IB, N-I-IB+1,
$ ONE, A( I, I+IB ), LDA, ONE, A( I, I ),
$ LDA )
END IF
10 CONTINUE
ELSE
*
* Compute the product L' * L.
*
DO 20 I = 1, N, NB
IB = MIN( NB, N-I+1 )
CALL STRMM( 'Left', 'Lower', 'Transpose', 'Non-unit', IB,
$ I-1, ONE, A( I, I ), LDA, A( I, 1 ), LDA )
CALL SLAUU2( 'Lower', IB, A( I, I ), LDA, INFO )
IF( I+IB.LE.N ) THEN
CALL SGEMM( 'Transpose', 'No transpose', IB, I-1,
$ N-I-IB+1, ONE, A( I+IB, I ), LDA,
$ A( I+IB, 1 ), LDA, ONE, A( I, 1 ), LDA )
CALL SSYRK( 'Lower', 'Transpose', IB, N-I-IB+1, ONE,
$ A( I+IB, I ), LDA, ONE, A( I, I ), LDA )
END IF
20 CONTINUE
END IF
END IF
*
RETURN
*
* End of SLAUUM
*
END
SUBROUTINE SLAZQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL,
$ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1,
$ DN2, TAU )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL IEEE
INTEGER I0, ITER, N0, NDIV, NFAIL, PP, TTYPE
REAL DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, QMAX,
$ SIGMA, TAU
* ..
* .. Array Arguments ..
REAL Z( * )
* ..
*
* Purpose
* =======
*
* SLAZQ3 checks for deflation, computes a shift (TAU) and calls dqds.
* In case of failure it changes shifts, and tries again until output
* is positive.
*
* Arguments
* =========
*
* I0 (input) INTEGER
* First index.
*
* N0 (input) INTEGER
* Last index.
*
* Z (input) REAL array, dimension ( 4*N )
* Z holds the qd array.
*
* PP (input) INTEGER
* PP=0 for ping, PP=1 for pong.
*
* DMIN (output) REAL
* Minimum value of d.
*
* SIGMA (output) REAL
* Sum of shifts used in current segment.
*
* DESIG (input/output) REAL
* Lower order part of SIGMA
*
* QMAX (input) REAL
* Maximum value of q.
*
* NFAIL (output) INTEGER
* Number of times shift was too big.
*
* ITER (output) INTEGER
* Number of iterations.
*
* NDIV (output) INTEGER
* Number of divisions.
*
* IEEE (input) LOGICAL
* Flag for IEEE or non IEEE arithmetic (passed to SLASQ5).
*
* TTYPE (input/output) INTEGER
* Shift type. TTYPE is passed as an argument in order to save
* its value between calls to SLAZQ3
*
* DMIN1 (input/output) REAL
* DMIN2 (input/output) REAL
* DN (input/output) REAL
* DN1 (input/output) REAL
* DN2 (input/output) REAL
* TAU (input/output) REAL
* These are passed as arguments in order to save their values
* between calls to SLAZQ3
*
* This is a thread safe version of SLASQ3, which passes TTYPE, DMIN1,
* DMIN2, DN, DN1. DN2 and TAU through the argument list in place of
* declaring them in a SAVE statment.
*
* =====================================================================
*
* .. Parameters ..
REAL CBIAS
PARAMETER ( CBIAS = 1.50E0 )
REAL ZERO, QURTR, HALF, ONE, TWO, HUNDRD
PARAMETER ( ZERO = 0.0E0, QURTR = 0.250E0, HALF = 0.5E0,
$ ONE = 1.0E0, TWO = 2.0E0, HUNDRD = 100.0E0 )
* ..
* .. Local Scalars ..
INTEGER IPN4, J4, N0IN, NN
REAL EPS, G, S, SAFMIN, T, TEMP, TOL, TOL2
* ..
* .. External Subroutines ..
EXTERNAL SLASQ5, SLASQ6, SLAZQ4
* ..
* .. External Function ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MIN, SQRT
* ..
* .. Executable Statements ..
*
N0IN = N0
EPS = SLAMCH( 'Precision' )
SAFMIN = SLAMCH( 'Safe minimum' )
TOL = EPS*HUNDRD
TOL2 = TOL**2
G = ZERO
*
* Check for deflation.
*
10 CONTINUE
*
IF( N0.LT.I0 )
$ RETURN
IF( N0.EQ.I0 )
$ GO TO 20
NN = 4*N0 + PP
IF( N0.EQ.( I0+1 ) )
$ GO TO 40
*
* Check whether E(N0-1) is negligible, 1 eigenvalue.
*
IF( Z( NN-5 ).GT.TOL2*( SIGMA+Z( NN-3 ) ) .AND.
$ Z( NN-2*PP-4 ).GT.TOL2*Z( NN-7 ) )
$ GO TO 30
*
20 CONTINUE
*
Z( 4*N0-3 ) = Z( 4*N0+PP-3 ) + SIGMA
N0 = N0 - 1
GO TO 10
*
* Check whether E(N0-2) is negligible, 2 eigenvalues.
*
30 CONTINUE
*
IF( Z( NN-9 ).GT.TOL2*SIGMA .AND.
$ Z( NN-2*PP-8 ).GT.TOL2*Z( NN-11 ) )
$ GO TO 50
*
40 CONTINUE
*
IF( Z( NN-3 ).GT.Z( NN-7 ) ) THEN
S = Z( NN-3 )
Z( NN-3 ) = Z( NN-7 )
Z( NN-7 ) = S
END IF
IF( Z( NN-5 ).GT.Z( NN-3 )*TOL2 ) THEN
T = HALF*( ( Z( NN-7 )-Z( NN-3 ) )+Z( NN-5 ) )
S = Z( NN-3 )*( Z( NN-5 ) / T )
IF( S.LE.T ) THEN
S = Z( NN-3 )*( Z( NN-5 ) /
$ ( T*( ONE+SQRT( ONE+S / T ) ) ) )
ELSE
S = Z( NN-3 )*( Z( NN-5 ) / ( T+SQRT( T )*SQRT( T+S ) ) )
END IF
T = Z( NN-7 ) + ( S+Z( NN-5 ) )
Z( NN-3 ) = Z( NN-3 )*( Z( NN-7 ) / T )
Z( NN-7 ) = T
END IF
Z( 4*N0-7 ) = Z( NN-7 ) + SIGMA
Z( 4*N0-3 ) = Z( NN-3 ) + SIGMA
N0 = N0 - 2
GO TO 10
*
50 CONTINUE
*
* Reverse the qd-array, if warranted.
*
IF( DMIN.LE.ZERO .OR. N0.LT.N0IN ) THEN
IF( CBIAS*Z( 4*I0+PP-3 ).LT.Z( 4*N0+PP-3 ) ) THEN
IPN4 = 4*( I0+N0 )
DO 60 J4 = 4*I0, 2*( I0+N0-1 ), 4
TEMP = Z( J4-3 )
Z( J4-3 ) = Z( IPN4-J4-3 )
Z( IPN4-J4-3 ) = TEMP
TEMP = Z( J4-2 )
Z( J4-2 ) = Z( IPN4-J4-2 )
Z( IPN4-J4-2 ) = TEMP
TEMP = Z( J4-1 )
Z( J4-1 ) = Z( IPN4-J4-5 )
Z( IPN4-J4-5 ) = TEMP
TEMP = Z( J4 )
Z( J4 ) = Z( IPN4-J4-4 )
Z( IPN4-J4-4 ) = TEMP
60 CONTINUE
IF( N0-I0.LE.4 ) THEN
Z( 4*N0+PP-1 ) = Z( 4*I0+PP-1 )
Z( 4*N0-PP ) = Z( 4*I0-PP )
END IF
DMIN2 = MIN( DMIN2, Z( 4*N0+PP-1 ) )
Z( 4*N0+PP-1 ) = MIN( Z( 4*N0+PP-1 ), Z( 4*I0+PP-1 ),
$ Z( 4*I0+PP+3 ) )
Z( 4*N0-PP ) = MIN( Z( 4*N0-PP ), Z( 4*I0-PP ),
$ Z( 4*I0-PP+4 ) )
QMAX = MAX( QMAX, Z( 4*I0+PP-3 ), Z( 4*I0+PP+1 ) )
DMIN = -ZERO
END IF
END IF
*
IF( DMIN.LT.ZERO .OR. SAFMIN*QMAX.LT.MIN( Z( 4*N0+PP-1 ),
$ Z( 4*N0+PP-9 ), DMIN2+Z( 4*N0-PP ) ) ) THEN
*
* Choose a shift.
*
CALL SLAZQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1,
$ DN2, TAU, TTYPE, G )
*
* Call dqds until DMIN > 0.
*
80 CONTINUE
*
CALL SLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN,
$ DN1, DN2, IEEE )
*
NDIV = NDIV + ( N0-I0+2 )
ITER = ITER + 1
*
* Check status.
*
IF( DMIN.GE.ZERO .AND. DMIN1.GT.ZERO ) THEN
*
* Success.
*
GO TO 100
*
ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND.
$ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND.
$ ABS( DN ).LT.TOL*SIGMA ) THEN
*
* Convergence hidden by negative DN.
*
Z( 4*( N0-1 )-PP+2 ) = ZERO
DMIN = ZERO
GO TO 100
ELSE IF( DMIN.LT.ZERO ) THEN
*
* TAU too big. Select new TAU and try again.
*
NFAIL = NFAIL + 1
IF( TTYPE.LT.-22 ) THEN
*
* Failed twice. Play it safe.
*
TAU = ZERO
ELSE IF( DMIN1.GT.ZERO ) THEN
*
* Late failure. Gives excellent shift.
*
TAU = ( TAU+DMIN )*( ONE-TWO*EPS )
TTYPE = TTYPE - 11
ELSE
*
* Early failure. Divide by 4.
*
TAU = QURTR*TAU
TTYPE = TTYPE - 12
END IF
GO TO 80
ELSE IF( DMIN.NE.DMIN ) THEN
*
* NaN.
*
TAU = ZERO
GO TO 80
ELSE
*
* Possible underflow. Play it safe.
*
GO TO 90
END IF
END IF
*
* Risk of underflow.
*
90 CONTINUE
CALL SLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 )
NDIV = NDIV + ( N0-I0+2 )
ITER = ITER + 1
TAU = ZERO
*
100 CONTINUE
IF( TAU.LT.SIGMA ) THEN
DESIG = DESIG + TAU
T = SIGMA + DESIG
DESIG = DESIG - ( T-SIGMA )
ELSE
T = SIGMA + TAU
DESIG = SIGMA - ( T-TAU ) + DESIG
END IF
SIGMA = T
*
RETURN
*
* End of SLAZQ3
*
END
SUBROUTINE SLAZQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN,
$ DN1, DN2, TAU, TTYPE, G )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER I0, N0, N0IN, PP, TTYPE
REAL DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU
* ..
* .. Array Arguments ..
REAL Z( * )
* ..
*
* Purpose
* =======
*
* SLAZQ4 computes an approximation TAU to the smallest eigenvalue
* using values of d from the previous transform.
*
* I0 (input) INTEGER
* First index.
*
* N0 (input) INTEGER
* Last index.
*
* Z (input) REAL array, dimension ( 4*N )
* Z holds the qd array.
*
* PP (input) INTEGER
* PP=0 for ping, PP=1 for pong.
*
* N0IN (input) INTEGER
* The value of N0 at start of EIGTEST.
*
* DMIN (input) REAL
* Minimum value of d.
*
* DMIN1 (input) REAL
* Minimum value of d, excluding D( N0 ).
*
* DMIN2 (input) REAL
* Minimum value of d, excluding D( N0 ) and D( N0-1 ).
*
* DN (input) REAL
* d(N)
*
* DN1 (input) REAL
* d(N-1)
*
* DN2 (input) REAL
* d(N-2)
*
* TAU (output) REAL
* This is the shift.
*
* TTYPE (output) INTEGER
* Shift type.
*
* G (input/output) REAL
* G is passed as an argument in order to save its value between
* calls to SLAZQ4
*
* Further Details
* ===============
* CNST1 = 9/16
*
* This is a thread safe version of SLASQ4, which passes G through the
* argument list in place of declaring G in a SAVE statment.
*
* =====================================================================
*
* .. Parameters ..
REAL CNST1, CNST2, CNST3
PARAMETER ( CNST1 = 0.5630E0, CNST2 = 1.010E0,
$ CNST3 = 1.050E0 )
REAL QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD
PARAMETER ( QURTR = 0.250E0, THIRD = 0.3330E0,
$ HALF = 0.50E0, ZERO = 0.0E0, ONE = 1.0E0,
$ TWO = 2.0E0, HUNDRD = 100.0E0 )
* ..
* .. Local Scalars ..
INTEGER I4, NN, NP
REAL A2, B1, B2, GAM, GAP1, GAP2, S
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* A negative DMIN forces the shift to take that absolute value
* TTYPE records the type of shift.
*
IF( DMIN.LE.ZERO ) THEN
TAU = -DMIN
TTYPE = -1
RETURN
END IF
*
NN = 4*N0 + PP
IF( N0IN.EQ.N0 ) THEN
*
* No eigenvalues deflated.
*
IF( DMIN.EQ.DN .OR. DMIN.EQ.DN1 ) THEN
*
B1 = SQRT( Z( NN-3 ) )*SQRT( Z( NN-5 ) )
B2 = SQRT( Z( NN-7 ) )*SQRT( Z( NN-9 ) )
A2 = Z( NN-7 ) + Z( NN-5 )
*
* Cases 2 and 3.
*
IF( DMIN.EQ.DN .AND. DMIN1.EQ.DN1 ) THEN
GAP2 = DMIN2 - A2 - DMIN2*QURTR
IF( GAP2.GT.ZERO .AND. GAP2.GT.B2 ) THEN
GAP1 = A2 - DN - ( B2 / GAP2 )*B2
ELSE
GAP1 = A2 - DN - ( B1+B2 )
END IF
IF( GAP1.GT.ZERO .AND. GAP1.GT.B1 ) THEN
S = MAX( DN-( B1 / GAP1 )*B1, HALF*DMIN )
TTYPE = -2
ELSE
S = ZERO
IF( DN.GT.B1 )
$ S = DN - B1
IF( A2.GT.( B1+B2 ) )
$ S = MIN( S, A2-( B1+B2 ) )
S = MAX( S, THIRD*DMIN )
TTYPE = -3
END IF
ELSE
*
* Case 4.
*
TTYPE = -4
S = QURTR*DMIN
IF( DMIN.EQ.DN ) THEN
GAM = DN
A2 = ZERO
IF( Z( NN-5 ) .GT. Z( NN-7 ) )
$ RETURN
B2 = Z( NN-5 ) / Z( NN-7 )
NP = NN - 9
ELSE
NP = NN - 2*PP
B2 = Z( NP-2 )
GAM = DN1
IF( Z( NP-4 ) .GT. Z( NP-2 ) )
$ RETURN
A2 = Z( NP-4 ) / Z( NP-2 )
IF( Z( NN-9 ) .GT. Z( NN-11 ) )
$ RETURN
B2 = Z( NN-9 ) / Z( NN-11 )
NP = NN - 13
END IF
*
* Approximate contribution to norm squared from I < NN-1.
*
A2 = A2 + B2
DO 10 I4 = NP, 4*I0 - 1 + PP, -4
IF( B2.EQ.ZERO )
$ GO TO 20
B1 = B2
IF( Z( I4 ) .GT. Z( I4-2 ) )
$ RETURN
B2 = B2*( Z( I4 ) / Z( I4-2 ) )
A2 = A2 + B2
IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 )
$ GO TO 20
10 CONTINUE
20 CONTINUE
A2 = CNST3*A2
*
* Rayleigh quotient residual bound.
*
IF( A2.LT.CNST1 )
$ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 )
END IF
ELSE IF( DMIN.EQ.DN2 ) THEN
*
* Case 5.
*
TTYPE = -5
S = QURTR*DMIN
*
* Compute contribution to norm squared from I > NN-2.
*
NP = NN - 2*PP
B1 = Z( NP-2 )
B2 = Z( NP-6 )
GAM = DN2
IF( Z( NP-8 ).GT.B2 .OR. Z( NP-4 ).GT.B1 )
$ RETURN
A2 = ( Z( NP-8 ) / B2 )*( ONE+Z( NP-4 ) / B1 )
*
* Approximate contribution to norm squared from I < NN-2.
*
IF( N0-I0.GT.2 ) THEN
B2 = Z( NN-13 ) / Z( NN-15 )
A2 = A2 + B2
DO 30 I4 = NN - 17, 4*I0 - 1 + PP, -4
IF( B2.EQ.ZERO )
$ GO TO 40
B1 = B2
IF( Z( I4 ) .GT. Z( I4-2 ) )
$ RETURN
B2 = B2*( Z( I4 ) / Z( I4-2 ) )
A2 = A2 + B2
IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 )
$ GO TO 40
30 CONTINUE
40 CONTINUE
A2 = CNST3*A2
END IF
*
IF( A2.LT.CNST1 )
$ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 )
ELSE
*
* Case 6, no information to guide us.
*
IF( TTYPE.EQ.-6 ) THEN
G = G + THIRD*( ONE-G )
ELSE IF( TTYPE.EQ.-18 ) THEN
G = QURTR*THIRD
ELSE
G = QURTR
END IF
S = G*DMIN
TTYPE = -6
END IF
*
ELSE IF( N0IN.EQ.( N0+1 ) ) THEN
*
* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN.
*
IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN
*
* Cases 7 and 8.
*
TTYPE = -7
S = THIRD*DMIN1
IF( Z( NN-5 ).GT.Z( NN-7 ) )
$ RETURN
B1 = Z( NN-5 ) / Z( NN-7 )
B2 = B1
IF( B2.EQ.ZERO )
$ GO TO 60
DO 50 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4
A2 = B1
IF( Z( I4 ).GT.Z( I4-2 ) )
$ RETURN
B1 = B1*( Z( I4 ) / Z( I4-2 ) )
B2 = B2 + B1
IF( HUNDRD*MAX( B1, A2 ).LT.B2 )
$ GO TO 60
50 CONTINUE
60 CONTINUE
B2 = SQRT( CNST3*B2 )
A2 = DMIN1 / ( ONE+B2**2 )
GAP2 = HALF*DMIN2 - A2
IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN
S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) )
ELSE
S = MAX( S, A2*( ONE-CNST2*B2 ) )
TTYPE = -8
END IF
ELSE
*
* Case 9.
*
S = QURTR*DMIN1
IF( DMIN1.EQ.DN1 )
$ S = HALF*DMIN1
TTYPE = -9
END IF
*
ELSE IF( N0IN.EQ.( N0+2 ) ) THEN
*
* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN.
*
* Cases 10 and 11.
*
IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN
TTYPE = -10
S = THIRD*DMIN2
IF( Z( NN-5 ).GT.Z( NN-7 ) )
$ RETURN
B1 = Z( NN-5 ) / Z( NN-7 )
B2 = B1
IF( B2.EQ.ZERO )
$ GO TO 80
DO 70 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4
IF( Z( I4 ).GT.Z( I4-2 ) )
$ RETURN
B1 = B1*( Z( I4 ) / Z( I4-2 ) )
B2 = B2 + B1
IF( HUNDRD*B1.LT.B2 )
$ GO TO 80
70 CONTINUE
80 CONTINUE
B2 = SQRT( CNST3*B2 )
A2 = DMIN2 / ( ONE+B2**2 )
GAP2 = Z( NN-7 ) + Z( NN-9 ) -
$ SQRT( Z( NN-11 ) )*SQRT( Z( NN-9 ) ) - A2
IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN
S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) )
ELSE
S = MAX( S, A2*( ONE-CNST2*B2 ) )
END IF
ELSE
S = QURTR*DMIN2
TTYPE = -11
END IF
ELSE IF( N0IN.GT.( N0+2 ) ) THEN
*
* Case 12, more than two eigenvalues deflated. No information.
*
S = ZERO
TTYPE = -12
END IF
*
TAU = S
RETURN
*
* End of SLAZQ4
*
END
SUBROUTINE SOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDQ, N
* ..
* .. Array Arguments ..
REAL AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SOPGTR generates a real orthogonal matrix Q which is defined as the
* product of n-1 elementary reflectors H(i) of order n, as returned by
* SSPTRD using packed storage:
*
* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
*
* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangular packed storage used in previous
* call to SSPTRD;
* = 'L': Lower triangular packed storage used in previous
* call to SSPTRD.
*
* N (input) INTEGER
* The order of the matrix Q. N >= 0.
*
* AP (input) REAL array, dimension (N*(N+1)/2)
* The vectors which define the elementary reflectors, as
* returned by SSPTRD.
*
* TAU (input) REAL array, dimension (N-1)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by SSPTRD.
*
* Q (output) REAL array, dimension (LDQ,N)
* The N-by-N orthogonal matrix Q.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* WORK (workspace) REAL array, dimension (N-1)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, IINFO, IJ, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SORG2L, SORG2R, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SOPGTR', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Q was determined by a call to SSPTRD with UPLO = 'U'
*
* Unpack the vectors which define the elementary reflectors and
* set the last row and column of Q equal to those of the unit
* matrix
*
IJ = 2
DO 20 J = 1, N - 1
DO 10 I = 1, J - 1
Q( I, J ) = AP( IJ )
IJ = IJ + 1
10 CONTINUE
IJ = IJ + 2
Q( N, J ) = ZERO
20 CONTINUE
DO 30 I = 1, N - 1
Q( I, N ) = ZERO
30 CONTINUE
Q( N, N ) = ONE
*
* Generate Q(1:n-1,1:n-1)
*
CALL SORG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO )
*
ELSE
*
* Q was determined by a call to SSPTRD with UPLO = 'L'.
*
* Unpack the vectors which define the elementary reflectors and
* set the first row and column of Q equal to those of the unit
* matrix
*
Q( 1, 1 ) = ONE
DO 40 I = 2, N
Q( I, 1 ) = ZERO
40 CONTINUE
IJ = 3
DO 60 J = 2, N
Q( 1, J ) = ZERO
DO 50 I = J + 1, N
Q( I, J ) = AP( IJ )
IJ = IJ + 1
50 CONTINUE
IJ = IJ + 2
60 CONTINUE
IF( N.GT.1 ) THEN
*
* Generate Q(2:n,2:n)
*
CALL SORG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK,
$ IINFO )
END IF
END IF
RETURN
*
* End of SOPGTR
*
END
SUBROUTINE SOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS, UPLO
INTEGER INFO, LDC, M, N
* ..
* .. Array Arguments ..
REAL AP( * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SOPMTR 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 of order nq, with nq = m if
* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
* nq-1 elementary reflectors, as returned by SSPTRD using packed
* storage:
*
* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
*
* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* = 'L': apply Q or Q**T from the Left;
* = 'R': apply Q or Q**T from the Right.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangular packed storage used in previous
* call to SSPTRD;
* = 'L': Lower triangular packed storage used in previous
* call to SSPTRD.
*
* 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.
*
* AP (input) REAL array, dimension
* (M*(M+1)/2) if SIDE = 'L'
* (N*(N+1)/2) if SIDE = 'R'
* The vectors which define the elementary reflectors, as
* returned by SSPTRD. AP is modified by the routine but
* restored on exit.
*
* TAU (input) REAL array, dimension (M-1) if SIDE = 'L'
* or (N-1) if SIDE = 'R'
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by SSPTRD.
*
* C (input/output) REAL 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) REAL 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 ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL FORWRD, LEFT, NOTRAN, UPPER
INTEGER I, I1, I2, I3, IC, II, JC, MI, NI, NQ
REAL AII
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SLARF, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LEFT = LSAME( SIDE, 'L' )
NOTRAN = LSAME( TRANS, 'N' )
UPPER = LSAME( UPLO, 'U' )
*
* 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.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
INFO = -3
ELSE IF( M.LT.0 ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SOPMTR', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Q was determined by a call to SSPTRD with UPLO = 'U'
*
FORWRD = ( LEFT .AND. NOTRAN ) .OR.
$ ( .NOT.LEFT .AND. .NOT.NOTRAN )
*
IF( FORWRD ) THEN
I1 = 1
I2 = NQ - 1
I3 = 1
II = 2
ELSE
I1 = NQ - 1
I2 = 1
I3 = -1
II = NQ*( NQ+1 ) / 2 - 1
END IF
*
IF( LEFT ) THEN
NI = N
ELSE
MI = M
END IF
*
DO 10 I = I1, I2, I3
IF( LEFT ) THEN
*
* H(i) is applied to C(1:i,1:n)
*
MI = I
ELSE
*
* H(i) is applied to C(1:m,1:i)
*
NI = I
END IF
*
* Apply H(i)
*
AII = AP( II )
AP( II ) = ONE
CALL SLARF( SIDE, MI, NI, AP( II-I+1 ), 1, TAU( I ), C, LDC,
$ WORK )
AP( II ) = AII
*
IF( FORWRD ) THEN
II = II + I + 2
ELSE
II = II - I - 1
END IF
10 CONTINUE
ELSE
*
* Q was determined by a call to SSPTRD with UPLO = 'L'.
*
FORWRD = ( LEFT .AND. .NOT.NOTRAN ) .OR.
$ ( .NOT.LEFT .AND. NOTRAN )
*
IF( FORWRD ) THEN
I1 = 1
I2 = NQ - 1
I3 = 1
II = 2
ELSE
I1 = NQ - 1
I2 = 1
I3 = -1
II = NQ*( NQ+1 ) / 2 - 1
END IF
*
IF( LEFT ) THEN
NI = N
JC = 1
ELSE
MI = M
IC = 1
END IF
*
DO 20 I = I1, I2, I3
AII = AP( II )
AP( II ) = ONE
IF( LEFT ) THEN
*
* H(i) is applied to C(i+1:m,1:n)
*
MI = M - I
IC = I + 1
ELSE
*
* H(i) is applied to C(1:m,i+1:n)
*
NI = N - I
JC = I + 1
END IF
*
* Apply H(i)
*
CALL SLARF( SIDE, MI, NI, AP( II ), 1, TAU( I ),
$ C( IC, JC ), LDC, WORK )
AP( II ) = AII
*
IF( FORWRD ) THEN
II = II + NQ - I + 1
ELSE
II = II - NQ + I - 2
END IF
20 CONTINUE
END IF
RETURN
*
* End of SOPMTR
*
END
SUBROUTINE SORG2L( M, N, K, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SORG2L generates an m by n real matrix Q with orthonormal columns,
* which is defined as the last n columns of a product of k elementary
* reflectors of order m
*
* Q = H(k) . . . H(2) H(1)
*
* as returned by SGEQLF.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix Q. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix Q. M >= N >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* matrix Q. N >= K >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the (n-k+i)-th column must contain the vector which
* defines the elementary reflector H(i), for i = 1,2,...,k, as
* returned by SGEQLF in the last k columns of its array
* argument A.
* On exit, the m by n matrix Q.
*
* LDA (input) INTEGER
* The first dimension of the array A. LDA >= max(1,M).
*
* TAU (input) REAL array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by SGEQLF.
*
* WORK (workspace) REAL array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument has an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, II, J, L
* ..
* .. External Subroutines ..
EXTERNAL SLARF, SSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SORG2L', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
* Initialise columns 1:n-k to columns of the unit matrix
*
DO 20 J = 1, N - K
DO 10 L = 1, M
A( L, J ) = ZERO
10 CONTINUE
A( M-N+J, J ) = ONE
20 CONTINUE
*
DO 40 I = 1, K
II = N - K + I
*
* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left
*
A( M-N+II, II ) = ONE
CALL SLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A,
$ LDA, WORK )
CALL SSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 )
A( M-N+II, II ) = ONE - TAU( I )
*
* Set A(m-k+i+1:m,n-k+i) to zero
*
DO 30 L = M - N + II + 1, M
A( L, II ) = ZERO
30 CONTINUE
40 CONTINUE
RETURN
*
* End of SORG2L
*
END
SUBROUTINE SORG2R( M, N, K, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SORG2R generates an m by n real matrix Q with orthonormal columns,
* which is defined as the first n columns of a product of k elementary
* reflectors of order m
*
* Q = H(1) H(2) . . . H(k)
*
* as returned by SGEQRF.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix Q. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix Q. M >= N >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* matrix Q. N >= K >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the i-th column must contain the vector which
* defines the elementary reflector H(i), for i = 1,2,...,k, as
* returned by SGEQRF in the first k columns of its array
* argument A.
* On exit, the m-by-n matrix Q.
*
* LDA (input) INTEGER
* The first dimension of the array A. LDA >= max(1,M).
*
* TAU (input) REAL array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by SGEQRF.
*
* WORK (workspace) REAL array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument has an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, L
* ..
* .. External Subroutines ..
EXTERNAL SLARF, SSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SORG2R', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
* Initialise columns k+1:n to columns of the unit matrix
*
DO 20 J = K + 1, N
DO 10 L = 1, M
A( L, J ) = ZERO
10 CONTINUE
A( J, J ) = ONE
20 CONTINUE
*
DO 40 I = K, 1, -1
*
* Apply H(i) to A(i:m,i:n) from the left
*
IF( I.LT.N ) THEN
A( I, I ) = ONE
CALL SLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
$ A( I, I+1 ), LDA, WORK )
END IF
IF( I.LT.M )
$ CALL SSCAL( M-I, -TAU( I ), A( I+1, I ), 1 )
A( I, I ) = ONE - TAU( I )
*
* Set A(1:i-1,i) to zero
*
DO 30 L = 1, I - 1
A( L, I ) = ZERO
30 CONTINUE
40 CONTINUE
RETURN
*
* End of SORG2R
*
END
SUBROUTINE SORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER VECT
INTEGER INFO, K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SORGBR generates one of the real orthogonal matrices Q or P**T
* determined by SGEBRD when reducing a real matrix A to bidiagonal
* form: A = Q * B * P**T. Q and P**T are defined as products of
* elementary reflectors H(i) or G(i) respectively.
*
* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q
* is of order M:
* if m >= k, Q = H(1) H(2) . . . H(k) and SORGBR returns the first n
* columns of Q, where m >= n >= k;
* if m < k, Q = H(1) H(2) . . . H(m-1) and SORGBR returns Q as an
* M-by-M matrix.
*
* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T
* is of order N:
* if k < n, P**T = G(k) . . . G(2) G(1) and SORGBR returns the first m
* rows of P**T, where n >= m >= k;
* if k >= n, P**T = G(n-1) . . . G(2) G(1) and SORGBR returns P**T as
* an N-by-N matrix.
*
* Arguments
* =========
*
* VECT (input) CHARACTER*1
* Specifies whether the matrix Q or the matrix P**T is
* required, as defined in the transformation applied by SGEBRD:
* = 'Q': generate Q;
* = 'P': generate P**T.
*
* M (input) INTEGER
* The number of rows of the matrix Q or P**T to be returned.
* M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix Q or P**T to be returned.
* N >= 0.
* If VECT = 'Q', M >= N >= min(M,K);
* if VECT = 'P', N >= M >= min(N,K).
*
* K (input) INTEGER
* If VECT = 'Q', the number of columns in the original M-by-K
* matrix reduced by SGEBRD.
* If VECT = 'P', the number of rows in the original K-by-N
* matrix reduced by SGEBRD.
* K >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the vectors which define the elementary reflectors,
* as returned by SGEBRD.
* On exit, the M-by-N matrix Q or P**T.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* TAU (input) REAL array, dimension
* (min(M,K)) if VECT = 'Q'
* (min(N,K)) if VECT = 'P'
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i) or G(i), which determines Q or P**T, as
* returned by SGEBRD in its array argument TAUQ or TAUP.
*
* WORK (workspace/output) REAL 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,min(M,N)).
* For optimum performance LWORK >= min(M,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
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, WANTQ
INTEGER I, IINFO, J, LWKOPT, MN, NB
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL ILAENV, LSAME
* ..
* .. External Subroutines ..
EXTERNAL SORGLQ, SORGQR, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
WANTQ = LSAME( VECT, 'Q' )
MN = MIN( M, N )
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN
INFO = -1
ELSE IF( M.LT.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 .OR. ( WANTQ .AND. ( N.GT.M .OR. N.LT.MIN( M,
$ K ) ) ) .OR. ( .NOT.WANTQ .AND. ( M.GT.N .OR. M.LT.
$ MIN( N, K ) ) ) ) THEN
INFO = -3
ELSE IF( K.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -6
ELSE IF( LWORK.LT.MAX( 1, MN ) .AND. .NOT.LQUERY ) THEN
INFO = -9
END IF
*
IF( INFO.EQ.0 ) THEN
IF( WANTQ ) THEN
NB = ILAENV( 1, 'SORGQR', ' ', M, N, K, -1 )
ELSE
NB = ILAENV( 1, 'SORGLQ', ' ', M, N, K, -1 )
END IF
LWKOPT = MAX( 1, MN )*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SORGBR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
IF( WANTQ ) THEN
*
* Form Q, determined by a call to SGEBRD to reduce an m-by-k
* matrix
*
IF( M.GE.K ) THEN
*
* If m >= k, assume m >= n >= k
*
CALL SORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO )
*
ELSE
*
* If m < k, assume m = n
*
* Shift the vectors which define the elementary reflectors one
* column to the right, and set the first row and column of Q
* to those of the unit matrix
*
DO 20 J = M, 2, -1
A( 1, J ) = ZERO
DO 10 I = J + 1, M
A( I, J ) = A( I, J-1 )
10 CONTINUE
20 CONTINUE
A( 1, 1 ) = ONE
DO 30 I = 2, M
A( I, 1 ) = ZERO
30 CONTINUE
IF( M.GT.1 ) THEN
*
* Form Q(2:m,2:m)
*
CALL SORGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK,
$ LWORK, IINFO )
END IF
END IF
ELSE
*
* Form P', determined by a call to SGEBRD to reduce a k-by-n
* matrix
*
IF( K.LT.N ) THEN
*
* If k < n, assume k <= m <= n
*
CALL SORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO )
*
ELSE
*
* If k >= n, assume m = n
*
* Shift the vectors which define the elementary reflectors one
* row downward, and set the first row and column of P' to
* those of the unit matrix
*
A( 1, 1 ) = ONE
DO 40 I = 2, N
A( I, 1 ) = ZERO
40 CONTINUE
DO 60 J = 2, N
DO 50 I = J - 1, 2, -1
A( I, J ) = A( I-1, J )
50 CONTINUE
A( 1, J ) = ZERO
60 CONTINUE
IF( N.GT.1 ) THEN
*
* Form P'(2:n,2:n)
*
CALL SORGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
$ LWORK, IINFO )
END IF
END IF
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of SORGBR
*
END
SUBROUTINE SORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IHI, ILO, INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SORGHR generates a real orthogonal matrix Q which is defined as the
* product of IHI-ILO elementary reflectors of order N, as returned by
* SGEHRD:
*
* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix Q. N >= 0.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* ILO and IHI must have the same values as in the previous call
* of SGEHRD. Q is equal to the unit matrix except in the
* submatrix Q(ilo+1:ihi,ilo+1:ihi).
* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the vectors which define the elementary reflectors,
* as returned by SGEHRD.
* On exit, the N-by-N orthogonal matrix Q.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* TAU (input) REAL array, dimension (N-1)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by SGEHRD.
*
* WORK (workspace/output) REAL 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 >= IHI-ILO.
* For optimum performance LWORK >= (IHI-ILO)*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
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IINFO, J, LWKOPT, NB, NH
* ..
* .. External Subroutines ..
EXTERNAL SORGQR, XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
NH = IHI - ILO
LQUERY = ( LWORK.EQ.-1 )
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
INFO = -2
ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LWORK.LT.MAX( 1, NH ) .AND. .NOT.LQUERY ) THEN
INFO = -8
END IF
*
IF( INFO.EQ.0 ) THEN
NB = ILAENV( 1, 'SORGQR', ' ', NH, NH, NH, -1 )
LWKOPT = MAX( 1, NH )*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SORGHR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
* Shift the vectors which define the elementary reflectors one
* column to the right, and set the first ilo and the last n-ihi
* rows and columns to those of the unit matrix
*
DO 40 J = IHI, ILO + 1, -1
DO 10 I = 1, J - 1
A( I, J ) = ZERO
10 CONTINUE
DO 20 I = J + 1, IHI
A( I, J ) = A( I, J-1 )
20 CONTINUE
DO 30 I = IHI + 1, N
A( I, J ) = ZERO
30 CONTINUE
40 CONTINUE
DO 60 J = 1, ILO
DO 50 I = 1, N
A( I, J ) = ZERO
50 CONTINUE
A( J, J ) = ONE
60 CONTINUE
DO 80 J = IHI + 1, N
DO 70 I = 1, N
A( I, J ) = ZERO
70 CONTINUE
A( J, J ) = ONE
80 CONTINUE
*
IF( NH.GT.0 ) THEN
*
* Generate Q(ilo+1:ihi,ilo+1:ihi)
*
CALL SORGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ),
$ WORK, LWORK, IINFO )
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of SORGHR
*
END
SUBROUTINE SORGL2( M, N, K, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SORGL2 generates an m by n real matrix Q with orthonormal rows,
* which is defined as the first m rows of a product of k elementary
* reflectors of order n
*
* Q = H(k) . . . H(2) H(1)
*
* as returned by SGELQF.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix Q. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix Q. N >= M.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* matrix Q. M >= K >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the i-th row must contain the vector which defines
* the elementary reflector H(i), for i = 1,2,...,k, as returned
* by SGELQF in the first k rows of its array argument A.
* On exit, the m-by-n matrix Q.
*
* LDA (input) INTEGER
* The first dimension of the array A. LDA >= max(1,M).
*
* TAU (input) REAL array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by SGELQF.
*
* WORK (workspace) REAL array, dimension (M)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument has an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, L
* ..
* .. External Subroutines ..
EXTERNAL SLARF, SSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SORGL2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.LE.0 )
$ RETURN
*
IF( K.LT.M ) THEN
*
* Initialise rows k+1:m to rows of the unit matrix
*
DO 20 J = 1, N
DO 10 L = K + 1, M
A( L, J ) = ZERO
10 CONTINUE
IF( J.GT.K .AND. J.LE.M )
$ A( J, J ) = ONE
20 CONTINUE
END IF
*
DO 40 I = K, 1, -1
*
* Apply H(i) to A(i:m,i:n) from the right
*
IF( I.LT.N ) THEN
IF( I.LT.M ) THEN
A( I, I ) = ONE
CALL SLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
$ TAU( I ), A( I+1, I ), LDA, WORK )
END IF
CALL SSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA )
END IF
A( I, I ) = ONE - TAU( I )
*
* Set A(i,1:i-1) to zero
*
DO 30 L = 1, I - 1
A( I, L ) = ZERO
30 CONTINUE
40 CONTINUE
RETURN
*
* End of SORGL2
*
END
SUBROUTINE SORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SORGLQ generates an M-by-N real matrix Q with orthonormal rows,
* which is defined as the first M rows of a product of K elementary
* reflectors of order N
*
* Q = H(k) . . . H(2) H(1)
*
* as returned by SGELQF.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix Q. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix Q. N >= M.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* matrix Q. M >= K >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the i-th row must contain the vector which defines
* the elementary reflector H(i), for i = 1,2,...,k, as returned
* by SGELQF in the first k rows of its array argument A.
* On exit, the M-by-N matrix Q.
*
* LDA (input) INTEGER
* The first dimension of the array A. LDA >= max(1,M).
*
* TAU (input) REAL array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by SGELQF.
*
* WORK (workspace/output) REAL 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,M).
* For optimum performance LWORK >= M*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 has an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
$ LWKOPT, NB, NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL SLARFB, SLARFT, SORGL2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
NB = ILAENV( 1, 'SORGLQ', ' ', M, N, K, -1 )
LWKOPT = MAX( 1, M )*NB
WORK( 1 ) = LWKOPT
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SORGLQ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.LE.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
NBMIN = 2
NX = 0
IWS = M
IF( NB.GT.1 .AND. NB.LT.K ) THEN
*
* Determine when to cross over from blocked to unblocked code.
*
NX = MAX( 0, ILAENV( 3, 'SORGLQ', ' ', M, N, K, -1 ) )
IF( NX.LT.K ) THEN
*
* Determine if workspace is large enough for blocked code.
*
LDWORK = M
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, 'SORGLQ', ' ', M, N, K, -1 ) )
END IF
END IF
END IF
*
IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
*
* Use blocked code after the last block.
* The first kk rows are handled by the block method.
*
KI = ( ( K-NX-1 ) / NB )*NB
KK = MIN( K, KI+NB )
*
* Set A(kk+1:m,1:kk) to zero.
*
DO 20 J = 1, KK
DO 10 I = KK + 1, M
A( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
KK = 0
END IF
*
* Use unblocked code for the last or only block.
*
IF( KK.LT.M )
$ CALL SORGL2( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA,
$ TAU( KK+1 ), WORK, IINFO )
*
IF( KK.GT.0 ) THEN
*
* Use blocked code
*
DO 50 I = KI + 1, 1, -NB
IB = MIN( NB, K-I+1 )
IF( I+IB.LE.M ) THEN
*
* Form the triangular factor of the block reflector
* H = H(i) H(i+1) . . . H(i+ib-1)
*
CALL SLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ),
$ LDA, TAU( I ), WORK, LDWORK )
*
* Apply H' to A(i+ib:m,i:n) from the right
*
CALL SLARFB( 'Right', 'Transpose', 'Forward', 'Rowwise',
$ M-I-IB+1, N-I+1, IB, A( I, I ), LDA, WORK,
$ LDWORK, A( I+IB, I ), LDA, WORK( IB+1 ),
$ LDWORK )
END IF
*
* Apply H' to columns i:n of current block
*
CALL SORGL2( IB, N-I+1, IB, A( I, I ), LDA, TAU( I ), WORK,
$ IINFO )
*
* Set columns 1:i-1 of current block to zero
*
DO 40 J = 1, I - 1
DO 30 L = I, I + IB - 1
A( L, J ) = ZERO
30 CONTINUE
40 CONTINUE
50 CONTINUE
END IF
*
WORK( 1 ) = IWS
RETURN
*
* End of SORGLQ
*
END
SUBROUTINE SORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SORGQL generates an M-by-N real matrix Q with orthonormal columns,
* which is defined as the last N columns of a product of K elementary
* reflectors of order M
*
* Q = H(k) . . . H(2) H(1)
*
* as returned by SGEQLF.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix Q. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix Q. M >= N >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* matrix Q. N >= K >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the (n-k+i)-th column must contain the vector which
* defines the elementary reflector H(i), for i = 1,2,...,k, as
* returned by SGEQLF in the last k columns of its array
* argument A.
* On exit, the M-by-N matrix Q.
*
* LDA (input) INTEGER
* The first dimension of the array A. LDA >= max(1,M).
*
* TAU (input) REAL array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by SGEQLF.
*
* WORK (workspace/output) REAL 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 has an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT,
$ NB, NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL SLARFB, SLARFT, SORG2L, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
*
IF( INFO.EQ.0 ) THEN
IF( N.EQ.0 ) THEN
LWKOPT = 1
ELSE
NB = ILAENV( 1, 'SORGQL', ' ', M, N, K, -1 )
LWKOPT = N*NB
END IF
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -8
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SORGQL', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 ) THEN
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, 'SORGQL', ' ', M, N, K, -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, 'SORGQL', ' ', M, N, K, -1 ) )
END IF
END IF
END IF
*
IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
*
* Use blocked code after the first block.
* The last kk columns are handled by the block method.
*
KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB )
*
* Set A(m-kk+1:m,1:n-kk) to zero.
*
DO 20 J = 1, N - KK
DO 10 I = M - KK + 1, M
A( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
KK = 0
END IF
*
* Use unblocked code for the first or only block.
*
CALL SORG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO )
*
IF( KK.GT.0 ) THEN
*
* Use blocked code
*
DO 50 I = K - KK + 1, K, NB
IB = MIN( NB, K-I+1 )
IF( N-K+I.GT.1 ) THEN
*
* Form the triangular factor of the block reflector
* H = H(i+ib-1) . . . H(i+1) H(i)
*
CALL SLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB,
$ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK )
*
* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left
*
CALL SLARFB( 'Left', 'No transpose', 'Backward',
$ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB,
$ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA,
$ WORK( IB+1 ), LDWORK )
END IF
*
* Apply H to rows 1:m-k+i+ib-1 of current block
*
CALL SORG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA,
$ TAU( I ), WORK, IINFO )
*
* Set rows m-k+i+ib:m of current block to zero
*
DO 40 J = N - K + I, N - K + I + IB - 1
DO 30 L = M - K + I + IB, M
A( L, J ) = ZERO
30 CONTINUE
40 CONTINUE
50 CONTINUE
END IF
*
WORK( 1 ) = IWS
RETURN
*
* End of SORGQL
*
END
SUBROUTINE SORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SORGQR generates an M-by-N real matrix Q with orthonormal columns,
* which is defined as the first N columns of a product of K elementary
* reflectors of order M
*
* Q = H(1) H(2) . . . H(k)
*
* as returned by SGEQRF.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix Q. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix Q. M >= N >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* matrix Q. N >= K >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the i-th column must contain the vector which
* defines the elementary reflector H(i), for i = 1,2,...,k, as
* returned by SGEQRF in the first k columns of its array
* argument A.
* On exit, the M-by-N matrix Q.
*
* LDA (input) INTEGER
* The first dimension of the array A. LDA >= max(1,M).
*
* TAU (input) REAL array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by SGEQRF.
*
* WORK (workspace/output) REAL 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 has an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
$ LWKOPT, NB, NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL SLARFB, SLARFT, SORG2R, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
NB = ILAENV( 1, 'SORGQR', ' ', M, N, K, -1 )
LWKOPT = MAX( 1, N )*NB
WORK( 1 ) = LWKOPT
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SORGQR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.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, 'SORGQR', ' ', M, N, K, -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, 'SORGQR', ' ', M, N, K, -1 ) )
END IF
END IF
END IF
*
IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
*
* Use blocked code after the last block.
* The first kk columns are handled by the block method.
*
KI = ( ( K-NX-1 ) / NB )*NB
KK = MIN( K, KI+NB )
*
* Set A(1:kk,kk+1:n) to zero.
*
DO 20 J = KK + 1, N
DO 10 I = 1, KK
A( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
KK = 0
END IF
*
* Use unblocked code for the last or only block.
*
IF( KK.LT.N )
$ CALL SORG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA,
$ TAU( KK+1 ), WORK, IINFO )
*
IF( KK.GT.0 ) THEN
*
* Use blocked code
*
DO 50 I = KI + 1, 1, -NB
IB = MIN( NB, K-I+1 )
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 SLARFT( 'Forward', 'Columnwise', M-I+1, IB,
$ A( I, I ), LDA, TAU( I ), WORK, LDWORK )
*
* Apply H to A(i:m,i+ib:n) from the left
*
CALL SLARFB( 'Left', 'No 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
*
* Apply H to rows i:m of current block
*
CALL SORG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK,
$ IINFO )
*
* Set rows 1:i-1 of current block to zero
*
DO 40 J = I, I + IB - 1
DO 30 L = 1, I - 1
A( L, J ) = ZERO
30 CONTINUE
40 CONTINUE
50 CONTINUE
END IF
*
WORK( 1 ) = IWS
RETURN
*
* End of SORGQR
*
END
SUBROUTINE SORGR2( M, N, K, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SORGR2 generates an m by n real matrix Q with orthonormal rows,
* which is defined as the last m rows of a product of k elementary
* reflectors of order n
*
* Q = H(1) H(2) . . . H(k)
*
* as returned by SGERQF.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix Q. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix Q. N >= M.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* matrix Q. M >= K >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the (m-k+i)-th row must contain the vector which
* defines the elementary reflector H(i), for i = 1,2,...,k, as
* returned by SGERQF in the last k rows of its array argument
* A.
* On exit, the m by n matrix Q.
*
* LDA (input) INTEGER
* The first dimension of the array A. LDA >= max(1,M).
*
* TAU (input) REAL array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by SGERQF.
*
* WORK (workspace) REAL array, dimension (M)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument has an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, II, J, L
* ..
* .. External Subroutines ..
EXTERNAL SLARF, SSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SORGR2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.LE.0 )
$ RETURN
*
IF( K.LT.M ) THEN
*
* Initialise rows 1:m-k to rows of the unit matrix
*
DO 20 J = 1, N
DO 10 L = 1, M - K
A( L, J ) = ZERO
10 CONTINUE
IF( J.GT.N-M .AND. J.LE.N-K )
$ A( M-N+J, J ) = ONE
20 CONTINUE
END IF
*
DO 40 I = 1, K
II = M - K + I
*
* Apply H(i) to A(1:m-k+i,1:n-k+i) from the right
*
A( II, N-M+II ) = ONE
CALL SLARF( 'Right', II-1, N-M+II, A( II, 1 ), LDA, TAU( I ),
$ A, LDA, WORK )
CALL SSCAL( N-M+II-1, -TAU( I ), A( II, 1 ), LDA )
A( II, N-M+II ) = ONE - TAU( I )
*
* Set A(m-k+i,n-k+i+1:n) to zero
*
DO 30 L = N - M + II + 1, N
A( II, L ) = ZERO
30 CONTINUE
40 CONTINUE
RETURN
*
* End of SORGR2
*
END
SUBROUTINE SORGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SORGRQ generates an M-by-N real matrix Q with orthonormal rows,
* which is defined as the last M rows of a product of K elementary
* reflectors of order N
*
* Q = H(1) H(2) . . . H(k)
*
* as returned by SGERQF.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix Q. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix Q. N >= M.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* matrix Q. M >= K >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the (m-k+i)-th row must contain the vector which
* defines the elementary reflector H(i), for i = 1,2,...,k, as
* returned by SGERQF in the last k rows of its array argument
* A.
* On exit, the M-by-N matrix Q.
*
* LDA (input) INTEGER
* The first dimension of the array A. LDA >= max(1,M).
*
* TAU (input) REAL array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by SGERQF.
*
* WORK (workspace/output) REAL 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,M).
* For optimum performance LWORK >= M*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 has an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, II, IINFO, IWS, J, KK, L, LDWORK,
$ LWKOPT, NB, NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL SLARFB, SLARFT, SORGR2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
*
IF( INFO.EQ.0 ) THEN
IF( M.LE.0 ) THEN
LWKOPT = 1
ELSE
NB = ILAENV( 1, 'SORGRQ', ' ', M, N, K, -1 )
LWKOPT = M*NB
END IF
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
INFO = -8
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SORGRQ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.LE.0 ) THEN
RETURN
END IF
*
NBMIN = 2
NX = 0
IWS = M
IF( NB.GT.1 .AND. NB.LT.K ) THEN
*
* Determine when to cross over from blocked to unblocked code.
*
NX = MAX( 0, ILAENV( 3, 'SORGRQ', ' ', M, N, K, -1 ) )
IF( NX.LT.K ) THEN
*
* Determine if workspace is large enough for blocked code.
*
LDWORK = M
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, 'SORGRQ', ' ', M, N, K, -1 ) )
END IF
END IF
END IF
*
IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
*
* Use blocked code after the first block.
* The last kk rows are handled by the block method.
*
KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB )
*
* Set A(1:m-kk,n-kk+1:n) to zero.
*
DO 20 J = N - KK + 1, N
DO 10 I = 1, M - KK
A( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
KK = 0
END IF
*
* Use unblocked code for the first or only block.
*
CALL SORGR2( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO )
*
IF( KK.GT.0 ) THEN
*
* Use blocked code
*
DO 50 I = K - KK + 1, K, NB
IB = MIN( NB, K-I+1 )
II = M - K + I
IF( II.GT.1 ) THEN
*
* Form the triangular factor of the block reflector
* H = H(i+ib-1) . . . H(i+1) H(i)
*
CALL SLARFT( 'Backward', 'Rowwise', N-K+I+IB-1, IB,
$ A( II, 1 ), LDA, TAU( I ), WORK, LDWORK )
*
* Apply H' to A(1:m-k+i-1,1:n-k+i+ib-1) from the right
*
CALL SLARFB( 'Right', 'Transpose', 'Backward', 'Rowwise',
$ II-1, N-K+I+IB-1, IB, A( II, 1 ), LDA, WORK,
$ LDWORK, A, LDA, WORK( IB+1 ), LDWORK )
END IF
*
* Apply H' to columns 1:n-k+i+ib-1 of current block
*
CALL SORGR2( IB, N-K+I+IB-1, IB, A( II, 1 ), LDA, TAU( I ),
$ WORK, IINFO )
*
* Set columns n-k+i+ib:n of current block to zero
*
DO 40 L = N - K + I + IB, N
DO 30 J = II, II + IB - 1
A( J, L ) = ZERO
30 CONTINUE
40 CONTINUE
50 CONTINUE
END IF
*
WORK( 1 ) = IWS
RETURN
*
* End of SORGRQ
*
END
SUBROUTINE SORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SORGTR generates a real orthogonal matrix Q which is defined as the
* product of n-1 elementary reflectors of order N, as returned by
* SSYTRD:
*
* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
*
* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A contains elementary reflectors
* from SSYTRD;
* = 'L': Lower triangle of A contains elementary reflectors
* from SSYTRD.
*
* N (input) INTEGER
* The order of the matrix Q. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the vectors which define the elementary reflectors,
* as returned by SSYTRD.
* On exit, the N-by-N orthogonal matrix Q.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* TAU (input) REAL array, dimension (N-1)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by SSYTRD.
*
* WORK (workspace/output) REAL 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-1).
* For optimum performance LWORK >= (N-1)*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
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, UPPER
INTEGER I, IINFO, J, LWKOPT, NB
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL ILAENV, LSAME
* ..
* .. External Subroutines ..
EXTERNAL SORGQL, SORGQR, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN
INFO = -7
END IF
*
IF( INFO.EQ.0 ) THEN
IF ( UPPER ) THEN
NB = ILAENV( 1, 'SORGQL', ' ', N-1, N-1, N-1, -1 )
ELSE
NB = ILAENV( 1, 'SORGQR', ' ', N-1, N-1, N-1, -1 )
END IF
LWKOPT = MAX( 1, N-1 )*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SORGTR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
IF( UPPER ) THEN
*
* Q was determined by a call to SSYTRD with UPLO = 'U'
*
* Shift the vectors which define the elementary reflectors one
* column to the left, and set the last row and column of Q to
* those of the unit matrix
*
DO 20 J = 1, N - 1
DO 10 I = 1, J - 1
A( I, J ) = A( I, J+1 )
10 CONTINUE
A( N, J ) = ZERO
20 CONTINUE
DO 30 I = 1, N - 1
A( I, N ) = ZERO
30 CONTINUE
A( N, N ) = ONE
*
* Generate Q(1:n-1,1:n-1)
*
CALL SORGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO )
*
ELSE
*
* Q was determined by a call to SSYTRD with UPLO = 'L'.
*
* Shift the vectors which define the elementary reflectors one
* column to the right, and set the first row and column of Q to
* those of the unit matrix
*
DO 50 J = N, 2, -1
A( 1, J ) = ZERO
DO 40 I = J + 1, N
A( I, J ) = A( I, J-1 )
40 CONTINUE
50 CONTINUE
A( 1, 1 ) = ONE
DO 60 I = 2, N
A( I, 1 ) = ZERO
60 CONTINUE
IF( N.GT.1 ) THEN
*
* Generate Q(2:n,2:n)
*
CALL SORGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
$ LWORK, IINFO )
END IF
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of SORGTR
*
END
SUBROUTINE SORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SORM2L overwrites the general real m by n matrix C with
*
* Q * C if SIDE = 'L' and TRANS = 'N', or
*
* Q'* C if SIDE = 'L' and TRANS = 'T', or
*
* C * Q if SIDE = 'R' and TRANS = 'N', or
*
* C * Q' if SIDE = 'R' and TRANS = 'T',
*
* where Q is a real orthogonal matrix defined as the product of k
* elementary reflectors
*
* Q = H(k) . . . H(2) H(1)
*
* as returned by SGEQLF. 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' from the Left
* = 'R': apply Q or Q' from the Right
*
* TRANS (input) CHARACTER*1
* = 'N': apply Q (No transpose)
* = 'T': apply Q' (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) REAL 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
* SGEQLF in the last 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) REAL array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by SGEQLF.
*
* C (input/output) REAL array, dimension (LDC,N)
* On entry, the m by n matrix C.
* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
*
* LDC (input) INTEGER
* The leading dimension of the array C. LDC >= max(1,M).
*
* WORK (workspace) REAL 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 ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, MI, NI, NQ
REAL AII
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SLARF, 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( 'SORM2L', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
$ RETURN
*
IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) )
$ THEN
I1 = 1
I2 = K
I3 = 1
ELSE
I1 = K
I2 = 1
I3 = -1
END IF
*
IF( LEFT ) THEN
NI = N
ELSE
MI = M
END IF
*
DO 10 I = I1, I2, I3
IF( LEFT ) THEN
*
* H(i) is applied to C(1:m-k+i,1:n)
*
MI = M - K + I
ELSE
*
* H(i) is applied to C(1:m,1:n-k+i)
*
NI = N - K + I
END IF
*
* Apply H(i)
*
AII = A( NQ-K+I, I )
A( NQ-K+I, I ) = ONE
CALL SLARF( SIDE, MI, NI, A( 1, I ), 1, TAU( I ), C, LDC,
$ WORK )
A( NQ-K+I, I ) = AII
10 CONTINUE
RETURN
*
* End of SORM2L
*
END
SUBROUTINE SORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SORM2R overwrites the general real m by n matrix C with
*
* Q * C if SIDE = 'L' and TRANS = 'N', or
*
* Q'* C if SIDE = 'L' and TRANS = 'T', or
*
* C * Q if SIDE = 'R' and TRANS = 'N', or
*
* C * Q' 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 SGEQRF. 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' from the Left
* = 'R': apply Q or Q' from the Right
*
* TRANS (input) CHARACTER*1
* = 'N': apply Q (No transpose)
* = 'T': apply Q' (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) REAL 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
* SGEQRF 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) REAL array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by SGEQRF.
*
* C (input/output) REAL array, dimension (LDC,N)
* On entry, the m by n matrix C.
* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
*
* LDC (input) INTEGER
* The leading dimension of the array C. LDC >= max(1,M).
*
* WORK (workspace) REAL 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 ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
REAL AII
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SLARF, 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( 'SORM2R', -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 SLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ),
$ LDC, WORK )
A( I, I ) = AII
10 CONTINUE
RETURN
*
* End of SORM2R
*
END
SUBROUTINE SORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C,
$ LDC, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS, VECT
INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), C( LDC, * ), TAU( * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* If VECT = 'Q', SORMBR 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
*
* If VECT = 'P', SORMBR overwrites the general real M-by-N matrix C
* with
* SIDE = 'L' SIDE = 'R'
* TRANS = 'N': P * C C * P
* TRANS = 'T': P**T * C C * P**T
*
* Here Q and P**T are the orthogonal matrices determined by SGEBRD when
* reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and
* P**T are defined as products of elementary reflectors H(i) and G(i)
* respectively.
*
* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the
* order of the orthogonal matrix Q or P**T that is applied.
*
* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:
* if nq >= k, Q = H(1) H(2) . . . H(k);
* if nq < k, Q = H(1) H(2) . . . H(nq-1).
*
* If VECT = 'P', A is assumed to have been a K-by-NQ matrix:
* if k < nq, P = G(1) G(2) . . . G(k);
* if k >= nq, P = G(1) G(2) . . . G(nq-1).
*
* Arguments
* =========
*
* VECT (input) CHARACTER*1
* = 'Q': apply Q or Q**T;
* = 'P': apply P or P**T.
*
* SIDE (input) CHARACTER*1
* = 'L': apply Q, Q**T, P or P**T from the Left;
* = 'R': apply Q, Q**T, P or P**T from the Right.
*
* TRANS (input) CHARACTER*1
* = 'N': No transpose, apply Q or P;
* = 'T': Transpose, apply Q**T or P**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
* If VECT = 'Q', the number of columns in the original
* matrix reduced by SGEBRD.
* If VECT = 'P', the number of rows in the original
* matrix reduced by SGEBRD.
* K >= 0.
*
* A (input) REAL array, dimension
* (LDA,min(nq,K)) if VECT = 'Q'
* (LDA,nq) if VECT = 'P'
* The vectors which define the elementary reflectors H(i) and
* G(i), whose products determine the matrices Q and P, as
* returned by SGEBRD.
*
* LDA (input) INTEGER
* The leading dimension of the array A.
* If VECT = 'Q', LDA >= max(1,nq);
* if VECT = 'P', LDA >= max(1,min(nq,K)).
*
* TAU (input) REAL array, dimension (min(nq,K))
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i) or G(i) which determines Q or P, as returned
* by SGEBRD in the array argument TAUQ or TAUP.
*
* C (input/output) REAL 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
* or P*C or P**T*C or C*P or C*P**T.
*
* LDC (input) INTEGER
* The leading dimension of the array C. LDC >= max(1,M).
*
* WORK (workspace/output) REAL 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
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN
CHARACTER TRANST
INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL ILAENV, LSAME
* ..
* .. External Subroutines ..
EXTERNAL SORMLQ, SORMQR, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
APPLYQ = LSAME( VECT, 'Q' )
LEFT = LSAME( SIDE, 'L' )
NOTRAN = LSAME( TRANS, 'N' )
LQUERY = ( LWORK.EQ.-1 )
*
* NQ is the order of Q or P and NW is the minimum dimension of WORK
*
IF( LEFT ) THEN
NQ = M
NW = N
ELSE
NQ = N
NW = M
END IF
IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN
INFO = -1
ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
INFO = -3
ELSE IF( M.LT.0 ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( K.LT.0 ) THEN
INFO = -6
ELSE IF( ( APPLYQ .AND. LDA.LT.MAX( 1, NQ ) ) .OR.
$ ( .NOT.APPLYQ .AND. LDA.LT.MAX( 1, MIN( NQ, K ) ) ) )
$ THEN
INFO = -8
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -11
ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
*
IF( INFO.EQ.0 ) THEN
IF( APPLYQ ) THEN
IF( LEFT ) THEN
NB = ILAENV( 1, 'SORMQR', SIDE // TRANS, M-1, N, M-1,
$ -1 )
ELSE
NB = ILAENV( 1, 'SORMQR', SIDE // TRANS, M, N-1, N-1,
$ -1 )
END IF
ELSE
IF( LEFT ) THEN
NB = ILAENV( 1, 'SORMLQ', SIDE // TRANS, M-1, N, M-1,
$ -1 )
ELSE
NB = ILAENV( 1, 'SORMLQ', SIDE // TRANS, M, N-1, N-1,
$ -1 )
END IF
END IF
LWKOPT = MAX( 1, NW )*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SORMBR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
WORK( 1 ) = 1
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
IF( APPLYQ ) THEN
*
* Apply Q
*
IF( NQ.GE.K ) THEN
*
* Q was determined by a call to SGEBRD with nq >= k
*
CALL SORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, IINFO )
ELSE IF( NQ.GT.1 ) THEN
*
* Q was determined by a call to SGEBRD with nq < k
*
IF( LEFT ) THEN
MI = M - 1
NI = N
I1 = 2
I2 = 1
ELSE
MI = M
NI = N - 1
I1 = 1
I2 = 2
END IF
CALL SORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU,
$ C( I1, I2 ), LDC, WORK, LWORK, IINFO )
END IF
ELSE
*
* Apply P
*
IF( NOTRAN ) THEN
TRANST = 'T'
ELSE
TRANST = 'N'
END IF
IF( NQ.GT.K ) THEN
*
* P was determined by a call to SGEBRD with nq > k
*
CALL SORMLQ( SIDE, TRANST, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, IINFO )
ELSE IF( NQ.GT.1 ) THEN
*
* P was determined by a call to SGEBRD with nq <= k
*
IF( LEFT ) THEN
MI = M - 1
NI = N
I1 = 2
I2 = 1
ELSE
MI = M
NI = N - 1
I1 = 1
I2 = 2
END IF
CALL SORMLQ( SIDE, TRANST, MI, NI, NQ-1, A( 1, 2 ), LDA,
$ TAU, C( I1, I2 ), LDC, WORK, LWORK, IINFO )
END IF
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of SORMBR
*
END
SUBROUTINE SORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C,
$ LDC, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), C( LDC, * ), TAU( * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* SORMHR 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 of order nq, with nq = m if
* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
* IHI-ILO elementary reflectors, as returned by SGEHRD:
*
* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
*
* 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.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* ILO and IHI must have the same values as in the previous call
* of SGEHRD. Q is equal to the unit matrix except in the
* submatrix Q(ilo+1:ihi,ilo+1:ihi).
* If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and
* ILO = 1 and IHI = 0, if M = 0;
* if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and
* ILO = 1 and IHI = 0, if N = 0.
*
* A (input) REAL array, dimension
* (LDA,M) if SIDE = 'L'
* (LDA,N) if SIDE = 'R'
* The vectors which define the elementary reflectors, as
* returned by SGEHRD.
*
* LDA (input) INTEGER
* The leading dimension of the array A.
* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
*
* TAU (input) REAL array, dimension
* (M-1) if SIDE = 'L'
* (N-1) if SIDE = 'R'
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by SGEHRD.
*
* C (input/output) REAL 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) REAL 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
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LEFT, LQUERY
INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL ILAENV, LSAME
* ..
* .. External Subroutines ..
EXTERNAL SORMQR, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
NH = IHI - ILO
LEFT = LSAME( SIDE, 'L' )
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.LSAME( TRANS, 'N' ) .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( ILO.LT.1 .OR. ILO.GT.MAX( 1, NQ ) ) THEN
INFO = -5
ELSE IF( IHI.LT.MIN( ILO, NQ ) .OR. IHI.GT.NQ ) THEN
INFO = -6
ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
INFO = -8
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -11
ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
*
IF( INFO.EQ.0 ) THEN
IF( LEFT ) THEN
NB = ILAENV( 1, 'SORMQR', SIDE // TRANS, NH, N, NH, -1 )
ELSE
NB = ILAENV( 1, 'SORMQR', SIDE // TRANS, M, NH, NH, -1 )
END IF
LWKOPT = MAX( 1, NW )*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SORMHR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. NH.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
IF( LEFT ) THEN
MI = NH
NI = N
I1 = ILO + 1
I2 = 1
ELSE
MI = M
NI = NH
I1 = 1
I2 = ILO + 1
END IF
*
CALL SORMQR( SIDE, TRANS, MI, NI, NH, A( ILO+1, ILO ), LDA,
$ TAU( ILO ), C( I1, I2 ), LDC, WORK, LWORK, IINFO )
*
WORK( 1 ) = LWKOPT
RETURN
*
* End of SORMHR
*
END
SUBROUTINE SORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SORML2 overwrites the general real m by n matrix C with
*
* Q * C if SIDE = 'L' and TRANS = 'N', or
*
* Q'* C if SIDE = 'L' and TRANS = 'T', or
*
* C * Q if SIDE = 'R' and TRANS = 'N', or
*
* C * Q' if SIDE = 'R' and TRANS = 'T',
*
* where Q is a real orthogonal matrix defined as the product of k
* elementary reflectors
*
* Q = H(k) . . . H(2) H(1)
*
* as returned by SGELQF. 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' from the Left
* = 'R': apply Q or Q' from the Right
*
* TRANS (input) CHARACTER*1
* = 'N': apply Q (No transpose)
* = 'T': apply Q' (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) REAL array, dimension
* (LDA,M) if SIDE = 'L',
* (LDA,N) if SIDE = 'R'
* The i-th row must contain the vector which defines the
* elementary reflector H(i), for i = 1,2,...,k, as returned by
* SGELQF in the first k rows 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. LDA >= max(1,K).
*
* TAU (input) REAL array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by SGELQF.
*
* C (input/output) REAL array, dimension (LDC,N)
* On entry, the m by n matrix C.
* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
*
* LDC (input) INTEGER
* The leading dimension of the array C. LDC >= max(1,M).
*
* WORK (workspace) REAL 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 ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
REAL AII
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SLARF, 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, K ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SORML2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
$ RETURN
*
IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.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 SLARF( SIDE, MI, NI, A( I, I ), LDA, TAU( I ),
$ C( IC, JC ), LDC, WORK )
A( I, I ) = AII
10 CONTINUE
RETURN
*
* End of SORML2
*
END
SUBROUTINE SORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), C( LDC, * ), TAU( * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* SORMLQ 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(k) . . . H(2) H(1)
*
* as returned by SGELQF. 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) REAL array, dimension
* (LDA,M) if SIDE = 'L',
* (LDA,N) if SIDE = 'R'
* The i-th row must contain the vector which defines the
* elementary reflector H(i), for i = 1,2,...,k, as returned by
* SGELQF in the first k rows 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. LDA >= max(1,K).
*
* TAU (input) REAL array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by SGELQF.
*
* C (input/output) REAL 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) REAL 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
CHARACTER TRANST
INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK,
$ LWKOPT, MI, NB, NBMIN, NI, NQ, NW
* ..
* .. Local Arrays ..
REAL T( LDT, NBMAX )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL SLARFB, SLARFT, SORML2, 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, K ) ) 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, 'SORMLQ', SIDE // TRANS, M, N, K,
$ -1 ) )
LWKOPT = MAX( 1, NW )*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SORMLQ', -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, 'SORMLQ', 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 SORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
$ IINFO )
ELSE
*
* Use blocked code
*
IF( ( LEFT .AND. NOTRAN ) .OR.
$ ( .NOT.LEFT .AND. .NOT.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
*
IF( NOTRAN ) THEN
TRANST = 'T'
ELSE
TRANST = 'N'
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 SLARFT( 'Forward', 'Rowwise', NQ-I+1, IB, A( I, I ),
$ LDA, TAU( I ), T, LDT )
IF( LEFT ) THEN
*
* H or H' is applied to C(i:m,1:n)
*
MI = M - I + 1
IC = I
ELSE
*
* H or H' is applied to C(1:m,i:n)
*
NI = N - I + 1
JC = I
END IF
*
* Apply H or H'
*
CALL SLARFB( SIDE, TRANST, 'Forward', 'Rowwise', 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 SORMLQ
*
END
SUBROUTINE SORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), C( LDC, * ), TAU( * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* SORMQL 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(k) . . . H(2) H(1)
*
* as returned by SGEQLF. 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) REAL 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
* SGEQLF in the last 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) REAL array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by SGEQLF.
*
* C (input/output) REAL 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) REAL 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, IINFO, IWS, LDWORK, LWKOPT,
$ MI, NB, NBMIN, NI, NQ, NW
* ..
* .. Local Arrays ..
REAL T( LDT, NBMAX )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL SLARFB, SLARFT, SORM2L, 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 = MAX( 1, N )
ELSE
NQ = N
NW = MAX( 1, 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
END IF
*
IF( INFO.EQ.0 ) THEN
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
LWKOPT = 1
ELSE
*
* 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, 'SORMQL', SIDE // TRANS, M, N,
$ K, -1 ) )
LWKOPT = NW*NB
END IF
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SORMQL', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
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, 'SORMQL', 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 SORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
$ IINFO )
ELSE
*
* Use blocked code
*
IF( ( LEFT .AND. NOTRAN ) .OR.
$ ( .NOT.LEFT .AND. .NOT.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
ELSE
MI = M
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+ib-1) . . . H(i+1) H(i)
*
CALL SLARFT( 'Backward', 'Columnwise', NQ-K+I+IB-1, IB,
$ A( 1, I ), LDA, TAU( I ), T, LDT )
IF( LEFT ) THEN
*
* H or H' is applied to C(1:m-k+i+ib-1,1:n)
*
MI = M - K + I + IB - 1
ELSE
*
* H or H' is applied to C(1:m,1:n-k+i+ib-1)
*
NI = N - K + I + IB - 1
END IF
*
* Apply H or H'
*
CALL SLARFB( SIDE, TRANS, 'Backward', 'Columnwise', MI, NI,
$ IB, A( 1, I ), LDA, T, LDT, C, LDC, WORK,
$ LDWORK )
10 CONTINUE
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of SORMQL
*
END
SUBROUTINE SORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), C( LDC, * ), TAU( * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* SORMQR 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 SGEQRF. 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) REAL 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
* SGEQRF 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) REAL array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by SGEQRF.
*
* C (input/output) REAL 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) REAL 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 ..
REAL T( LDT, NBMAX )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL SLARFB, SLARFT, SORM2R, 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, 'SORMQR', SIDE // TRANS, M, N, K,
$ -1 ) )
LWKOPT = MAX( 1, NW )*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SORMQR', -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, 'SORMQR', 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 SORM2R( 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 SLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ),
$ LDA, TAU( I ), T, LDT )
IF( LEFT ) THEN
*
* H or H' is applied to C(i:m,1:n)
*
MI = M - I + 1
IC = I
ELSE
*
* H or H' is applied to C(1:m,i:n)
*
NI = N - I + 1
JC = I
END IF
*
* Apply H or H'
*
CALL SLARFB( 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 SORMQR
*
END
SUBROUTINE SORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SORMR2 overwrites the general real m by n matrix C with
*
* Q * C if SIDE = 'L' and TRANS = 'N', or
*
* Q'* C if SIDE = 'L' and TRANS = 'T', or
*
* C * Q if SIDE = 'R' and TRANS = 'N', or
*
* C * Q' 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 SGERQF. 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' from the Left
* = 'R': apply Q or Q' from the Right
*
* TRANS (input) CHARACTER*1
* = 'N': apply Q (No transpose)
* = 'T': apply Q' (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) REAL array, dimension
* (LDA,M) if SIDE = 'L',
* (LDA,N) if SIDE = 'R'
* The i-th row must contain the vector which defines the
* elementary reflector H(i), for i = 1,2,...,k, as returned by
* SGERQF in the last k rows 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. LDA >= max(1,K).
*
* TAU (input) REAL array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by SGERQF.
*
* C (input/output) REAL array, dimension (LDC,N)
* On entry, the m by n matrix C.
* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
*
* LDC (input) INTEGER
* The leading dimension of the array C. LDC >= max(1,M).
*
* WORK (workspace) REAL 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 ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, MI, NI, NQ
REAL AII
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SLARF, 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, K ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SORMR2', -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
ELSE
MI = M
END IF
*
DO 10 I = I1, I2, I3
IF( LEFT ) THEN
*
* H(i) is applied to C(1:m-k+i,1:n)
*
MI = M - K + I
ELSE
*
* H(i) is applied to C(1:m,1:n-k+i)
*
NI = N - K + I
END IF
*
* Apply H(i)
*
AII = A( I, NQ-K+I )
A( I, NQ-K+I ) = ONE
CALL SLARF( SIDE, MI, NI, A( I, 1 ), LDA, TAU( I ), C, LDC,
$ WORK )
A( I, NQ-K+I ) = AII
10 CONTINUE
RETURN
*
* End of SORMR2
*
END
SUBROUTINE SORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC,
$ WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, L, LDA, LDC, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SORMR3 overwrites the general real m by n matrix C with
*
* Q * C if SIDE = 'L' and TRANS = 'N', or
*
* Q'* C if SIDE = 'L' and TRANS = 'T', or
*
* C * Q if SIDE = 'R' and TRANS = 'N', or
*
* C * Q' 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 STZRZF. 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' from the Left
* = 'R': apply Q or Q' from the Right
*
* TRANS (input) CHARACTER*1
* = 'N': apply Q (No transpose)
* = 'T': apply Q' (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.
*
* L (input) INTEGER
* The number of columns of the matrix A containing
* the meaningful part of the Householder reflectors.
* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
*
* A (input) REAL array, dimension
* (LDA,M) if SIDE = 'L',
* (LDA,N) if SIDE = 'R'
* The i-th row must contain the vector which defines the
* elementary reflector H(i), for i = 1,2,...,k, as returned by
* STZRZF in the last k rows 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. LDA >= max(1,K).
*
* TAU (input) REAL array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by STZRZF.
*
* C (input/output) REAL array, dimension (LDC,N)
* On entry, the m-by-n matrix C.
* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
*
* LDC (input) INTEGER
* The leading dimension of the array C. LDC >= max(1,M).
*
* WORK (workspace) REAL 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
*
* Further Details
* ===============
*
* Based on contributions by
* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, IC, JA, JC, MI, NI, NQ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SLARZ, 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( L.LT.0 .OR. ( LEFT .AND. ( L.GT.M ) ) .OR.
$ ( .NOT.LEFT .AND. ( L.GT.N ) ) ) THEN
INFO = -6
ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
INFO = -8
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -11
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SORMR3', -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
JA = M - L + 1
JC = 1
ELSE
MI = M
JA = N - L + 1
IC = 1
END IF
*
DO 10 I = I1, I2, I3
IF( LEFT ) THEN
*
* H(i) or H(i)' is applied to C(i:m,1:n)
*
MI = M - I + 1
IC = I
ELSE
*
* H(i) or H(i)' is applied to C(1:m,i:n)
*
NI = N - I + 1
JC = I
END IF
*
* Apply H(i) or H(i)'
*
CALL SLARZ( SIDE, MI, NI, L, A( I, JA ), LDA, TAU( I ),
$ C( IC, JC ), LDC, WORK )
*
10 CONTINUE
*
RETURN
*
* End of SORMR3
*
END
SUBROUTINE SORMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), C( LDC, * ), TAU( * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* SORMRQ 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 SGERQF. 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) REAL array, dimension
* (LDA,M) if SIDE = 'L',
* (LDA,N) if SIDE = 'R'
* The i-th row must contain the vector which defines the
* elementary reflector H(i), for i = 1,2,...,k, as returned by
* SGERQF in the last k rows 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. LDA >= max(1,K).
*
* TAU (input) REAL array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by SGERQF.
*
* C (input/output) REAL 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) REAL 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
CHARACTER TRANST
INTEGER I, I1, I2, I3, IB, IINFO, IWS, LDWORK, LWKOPT,
$ MI, NB, NBMIN, NI, NQ, NW
* ..
* .. Local Arrays ..
REAL T( LDT, NBMAX )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL SLARFB, SLARFT, SORMR2, 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 = MAX( 1, N )
ELSE
NQ = N
NW = MAX( 1, 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, K ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
END IF
*
IF( INFO.EQ.0 ) THEN
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
LWKOPT = 1
ELSE
*
* 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, 'SORMRQ', SIDE // TRANS, M, N,
$ K, -1 ) )
LWKOPT = NW*NB
END IF
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SORMRQ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
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, 'SORMRQ', 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 SORMR2( 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
ELSE
MI = M
END IF
*
IF( NOTRAN ) THEN
TRANST = 'T'
ELSE
TRANST = 'N'
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+ib-1) . . . H(i+1) H(i)
*
CALL SLARFT( 'Backward', 'Rowwise', NQ-K+I+IB-1, IB,
$ A( I, 1 ), LDA, TAU( I ), T, LDT )
IF( LEFT ) THEN
*
* H or H' is applied to C(1:m-k+i+ib-1,1:n)
*
MI = M - K + I + IB - 1
ELSE
*
* H or H' is applied to C(1:m,1:n-k+i+ib-1)
*
NI = N - K + I + IB - 1
END IF
*
* Apply H or H'
*
CALL SLARFB( SIDE, TRANST, 'Backward', 'Rowwise', MI, NI,
$ IB, A( I, 1 ), LDA, T, LDT, C, LDC, WORK,
$ LDWORK )
10 CONTINUE
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of SORMRQ
*
END
SUBROUTINE SORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC,
$ WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* January 2007
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, L, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SORMRZ 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 STZRZF. 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.
*
* L (input) INTEGER
* The number of columns of the matrix A containing
* the meaningful part of the Householder reflectors.
* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
*
* A (input) REAL array, dimension
* (LDA,M) if SIDE = 'L',
* (LDA,N) if SIDE = 'R'
* The i-th row must contain the vector which defines the
* elementary reflector H(i), for i = 1,2,...,k, as returned by
* STZRZF in the last k rows 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. LDA >= max(1,K).
*
* TAU (input) REAL array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by STZRZF.
*
* C (input/output) REAL array, dimension (LDC,N)
* On entry, the M-by-N matrix C.
* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
*
* LDC (input) INTEGER
* The leading dimension of the array C. LDC >= max(1,M).
*
* WORK (workspace/output) REAL 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
*
* Further Details
* ===============
*
* Based on contributions by
* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*
* =====================================================================
*
* .. Parameters ..
INTEGER NBMAX, LDT
PARAMETER ( NBMAX = 64, LDT = NBMAX+1 )
* ..
* .. Local Scalars ..
LOGICAL LEFT, LQUERY, NOTRAN
CHARACTER TRANST
INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JA, JC,
$ LDWORK, LWKOPT, MI, NB, NBMIN, NI, NQ, NW
* ..
* .. Local Arrays ..
REAL T( LDT, NBMAX )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL SLARZB, SLARZT, SORMR3, 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 = MAX( 1, N )
ELSE
NQ = N
NW = MAX( 1, 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( L.LT.0 .OR. ( LEFT .AND. ( L.GT.M ) ) .OR.
$ ( .NOT.LEFT .AND. ( L.GT.N ) ) ) THEN
INFO = -6
ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
INFO = -8
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -11
END IF
*
IF( INFO.EQ.0 ) THEN
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
LWKOPT = 1
ELSE
*
* 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, 'SORMRQ', SIDE // TRANS, M, N,
$ K, -1 ) )
LWKOPT = NW*NB
END IF
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SORMRZ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
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, 'SORMRQ', 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 SORMR3( SIDE, TRANS, M, N, K, L, 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
JA = M - L + 1
ELSE
MI = M
IC = 1
JA = N - L + 1
END IF
*
IF( NOTRAN ) THEN
TRANST = 'T'
ELSE
TRANST = 'N'
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+ib-1) . . . H(i+1) H(i)
*
CALL SLARZT( 'Backward', 'Rowwise', L, IB, A( I, JA ), LDA,
$ TAU( I ), T, LDT )
*
IF( LEFT ) THEN
*
* H or H' is applied to C(i:m,1:n)
*
MI = M - I + 1
IC = I
ELSE
*
* H or H' is applied to C(1:m,i:n)
*
NI = N - I + 1
JC = I
END IF
*
* Apply H or H'
*
CALL SLARZB( SIDE, TRANST, 'Backward', 'Rowwise', MI, NI,
$ IB, L, A( I, JA ), LDA, T, LDT, C( IC, JC ),
$ LDC, WORK, LDWORK )
10 CONTINUE
*
END IF
*
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of SORMRZ
*
END
SUBROUTINE SORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC,
$ WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS, UPLO
INTEGER INFO, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), C( LDC, * ), TAU( * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* SORMTR 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 of order nq, with nq = m if
* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
* nq-1 elementary reflectors, as returned by SSYTRD:
*
* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
*
* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* = 'L': apply Q or Q**T from the Left;
* = 'R': apply Q or Q**T from the Right.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A contains elementary reflectors
* from SSYTRD;
* = 'L': Lower triangle of A contains elementary reflectors
* from SSYTRD.
*
* 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.
*
* A (input) REAL array, dimension
* (LDA,M) if SIDE = 'L'
* (LDA,N) if SIDE = 'R'
* The vectors which define the elementary reflectors, as
* returned by SSYTRD.
*
* LDA (input) INTEGER
* The leading dimension of the array A.
* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
*
* TAU (input) REAL array, dimension
* (M-1) if SIDE = 'L'
* (N-1) if SIDE = 'R'
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by SSYTRD.
*
* C (input/output) REAL 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) REAL 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
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LEFT, LQUERY, UPPER
INTEGER I1, I2, IINFO, LWKOPT, MI, NI, NB, NQ, NW
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL ILAENV, LSAME
* ..
* .. External Subroutines ..
EXTERNAL SORMQL, SORMQR, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LEFT = LSAME( SIDE, 'L' )
UPPER = LSAME( UPLO, 'U' )
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.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) )
$ THEN
INFO = -3
ELSE IF( M.LT.0 ) THEN
INFO = -4
ELSE IF( N.LT.0 ) 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
IF( UPPER ) THEN
IF( LEFT ) THEN
NB = ILAENV( 1, 'SORMQL', SIDE // TRANS, M-1, N, M-1,
$ -1 )
ELSE
NB = ILAENV( 1, 'SORMQL', SIDE // TRANS, M, N-1, N-1,
$ -1 )
END IF
ELSE
IF( LEFT ) THEN
NB = ILAENV( 1, 'SORMQR', SIDE // TRANS, M-1, N, M-1,
$ -1 )
ELSE
NB = ILAENV( 1, 'SORMQR', SIDE // TRANS, M, N-1, N-1,
$ -1 )
END IF
END IF
LWKOPT = MAX( 1, NW )*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SORMTR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
IF( LEFT ) THEN
MI = M - 1
NI = N
ELSE
MI = M
NI = N - 1
END IF
*
IF( UPPER ) THEN
*
* Q was determined by a call to SSYTRD with UPLO = 'U'
*
CALL SORMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C,
$ LDC, WORK, LWORK, IINFO )
ELSE
*
* Q was determined by a call to SSYTRD with UPLO = 'L'
*
IF( LEFT ) THEN
I1 = 2
I2 = 1
ELSE
I1 = 1
I2 = 2
END IF
CALL SORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU,
$ C( I1, I2 ), LDC, WORK, LWORK, IINFO )
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of SORMTR
*
END
SUBROUTINE SPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK,
$ IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, KD, LDAB, N
REAL ANORM, RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL AB( LDAB, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SPBCON estimates the reciprocal of the condition number (in the
* 1-norm) of a real symmetric positive definite band matrix using the
* Cholesky factorization A = U**T*U or A = L*L**T computed by SPBTRF.
*
* An estimate is obtained for norm(inv(A)), and the reciprocal of the
* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangular factor stored in AB;
* = 'L': Lower triangular factor stored in AB.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
*
* AB (input) REAL array, dimension (LDAB,N)
* The triangular factor U or L from the Cholesky factorization
* A = U**T*U or A = L*L**T of the band matrix A, stored in the
* first KD+1 rows of the array. The j-th column of U or L is
* stored in the j-th column of the array AB as follows:
* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* ANORM (input) REAL
* The 1-norm (or infinity-norm) of the symmetric band matrix A.
*
* RCOND (output) REAL
* The reciprocal of the condition number of the matrix A,
* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
* estimate of the 1-norm of inv(A) computed in this routine.
*
* WORK (workspace) REAL array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
CHARACTER NORMIN
INTEGER IX, KASE
REAL AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SLAMCH
EXTERNAL LSAME, ISAMAX, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SLACN2, SLATBS, SRSCL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( KD.LT.0 ) THEN
INFO = -3
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -5
ELSE IF( ANORM.LT.ZERO ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPBCON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
RCOND = ZERO
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
ELSE IF( ANORM.EQ.ZERO ) THEN
RETURN
END IF
*
SMLNUM = SLAMCH( 'Safe minimum' )
*
* Estimate the 1-norm of the inverse.
*
KASE = 0
NORMIN = 'N'
10 CONTINUE
CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( UPPER ) THEN
*
* Multiply by inv(U').
*
CALL SLATBS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N,
$ KD, AB, LDAB, WORK, SCALEL, WORK( 2*N+1 ),
$ INFO )
NORMIN = 'Y'
*
* Multiply by inv(U).
*
CALL SLATBS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
$ KD, AB, LDAB, WORK, SCALEU, WORK( 2*N+1 ),
$ INFO )
ELSE
*
* Multiply by inv(L).
*
CALL SLATBS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N,
$ KD, AB, LDAB, WORK, SCALEL, WORK( 2*N+1 ),
$ INFO )
NORMIN = 'Y'
*
* Multiply by inv(L').
*
CALL SLATBS( 'Lower', 'Transpose', 'Non-unit', NORMIN, N,
$ KD, AB, LDAB, WORK, SCALEU, WORK( 2*N+1 ),
$ INFO )
END IF
*
* Multiply by 1/SCALE if doing so will not cause overflow.
*
SCALE = SCALEL*SCALEU
IF( SCALE.NE.ONE ) THEN
IX = ISAMAX( N, WORK, 1 )
IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
$ GO TO 20
CALL SRSCL( N, SCALE, WORK, 1 )
END IF
GO TO 10
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / AINVNM ) / ANORM
*
20 CONTINUE
*
RETURN
*
* End of SPBCON
*
END
SUBROUTINE SPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, KD, LDAB, N
REAL AMAX, SCOND
* ..
* .. Array Arguments ..
REAL AB( LDAB, * ), S( * )
* ..
*
* Purpose
* =======
*
* SPBEQU computes row and column scalings intended to equilibrate a
* symmetric positive definite band matrix A and reduce its condition
* number (with respect to the two-norm). S contains the scale factors,
* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
* choice of S puts the condition number of B within a factor N of the
* smallest possible condition number over all possible diagonal
* scalings.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangular of A is stored;
* = 'L': Lower triangular of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
*
* AB (input) REAL array, dimension (LDAB,N)
* The upper or lower triangle of the symmetric band matrix A,
* stored in the first KD+1 rows of the array. The j-th column
* of A is stored in the j-th column of the array AB as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*
* LDAB (input) INTEGER
* The leading dimension of the array A. LDAB >= KD+1.
*
* S (output) REAL array, dimension (N)
* If INFO = 0, S contains the scale factors for A.
*
* SCOND (output) REAL
* If INFO = 0, S contains the ratio of the smallest S(i) to
* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
* large nor too small, it is not worth scaling by S.
*
* AMAX (output) REAL
* Absolute value of largest matrix element. If AMAX is very
* close to overflow or very close to underflow, the matrix
* should be scaled.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = i, the i-th diagonal element is nonpositive.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, J
REAL SMIN
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( KD.LT.0 ) THEN
INFO = -3
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPBEQU', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
SCOND = ONE
AMAX = ZERO
RETURN
END IF
*
IF( UPPER ) THEN
J = KD + 1
ELSE
J = 1
END IF
*
* Initialize SMIN and AMAX.
*
S( 1 ) = AB( J, 1 )
SMIN = S( 1 )
AMAX = S( 1 )
*
* Find the minimum and maximum diagonal elements.
*
DO 10 I = 2, N
S( I ) = AB( J, I )
SMIN = MIN( SMIN, S( I ) )
AMAX = MAX( AMAX, S( I ) )
10 CONTINUE
*
IF( SMIN.LE.ZERO ) THEN
*
* Find the first non-positive diagonal element and return.
*
DO 20 I = 1, N
IF( S( I ).LE.ZERO ) THEN
INFO = I
RETURN
END IF
20 CONTINUE
ELSE
*
* Set the scale factors to the reciprocals
* of the diagonal elements.
*
DO 30 I = 1, N
S( I ) = ONE / SQRT( S( I ) )
30 CONTINUE
*
* Compute SCOND = min(S(I)) / max(S(I))
*
SCOND = SQRT( SMIN ) / SQRT( AMAX )
END IF
RETURN
*
* End of SPBEQU
*
END
SUBROUTINE SPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B,
$ LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
$ BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* SPBRFS improves the computed solution to a system of linear
* equations when the coefficient matrix is symmetric positive definite
* and banded, and provides error bounds and backward error estimates
* for the solution.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrices B and X. NRHS >= 0.
*
* AB (input) REAL array, dimension (LDAB,N)
* The upper or lower triangle of the symmetric band matrix A,
* stored in the first KD+1 rows of the array. The j-th column
* of A is stored in the j-th column of the array AB as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* AFB (input) REAL array, dimension (LDAFB,N)
* The triangular factor U or L from the Cholesky factorization
* A = U**T*U or A = L*L**T of the band matrix A as computed by
* SPBTRF, in the same storage format as A (see AB).
*
* LDAFB (input) INTEGER
* The leading dimension of the array AFB. LDAFB >= KD+1.
*
* B (input) REAL array, dimension (LDB,NRHS)
* The right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input/output) REAL array, dimension (LDX,NRHS)
* On entry, the solution matrix X, as computed by SPBTRS.
* On exit, the improved solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* FERR (output) REAL array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) REAL array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Internal Parameters
* ===================
*
* ITMAX is the maximum number of steps of iterative refinement.
*
* =====================================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 5 )
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
REAL TWO
PARAMETER ( TWO = 2.0E+0 )
REAL THREE
PARAMETER ( THREE = 3.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER COUNT, I, J, K, KASE, L, NZ
REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, SLACN2, SPBTRS, SSBMV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH
EXTERNAL LSAME, SLAMCH
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( KD.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -6
ELSE IF( LDAFB.LT.KD+1 ) THEN
INFO = -8
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -10
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPBRFS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
DO 10 J = 1, NRHS
FERR( J ) = ZERO
BERR( J ) = ZERO
10 CONTINUE
RETURN
END IF
*
* NZ = maximum number of nonzero elements in each row of A, plus 1
*
NZ = MIN( N+1, 2*KD+2 )
EPS = SLAMCH( 'Epsilon' )
SAFMIN = SLAMCH( 'Safe minimum' )
SAFE1 = NZ*SAFMIN
SAFE2 = SAFE1 / EPS
*
* Do for each right hand side
*
DO 140 J = 1, NRHS
*
COUNT = 1
LSTRES = THREE
20 CONTINUE
*
* Loop until stopping criterion is satisfied.
*
* Compute residual R = B - A * X
*
CALL SCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
CALL SSBMV( UPLO, N, KD, -ONE, AB, LDAB, X( 1, J ), 1, ONE,
$ WORK( N+1 ), 1 )
*
* Compute componentwise relative backward error from formula
*
* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
*
* where abs(Z) is the componentwise absolute value of the matrix
* or vector Z. If the i-th component of the denominator is less
* than SAFE2, then SAFE1 is added to the i-th components of the
* numerator and denominator before dividing.
*
DO 30 I = 1, N
WORK( I ) = ABS( B( I, J ) )
30 CONTINUE
*
* Compute abs(A)*abs(X) + abs(B).
*
IF( UPPER ) THEN
DO 50 K = 1, N
S = ZERO
XK = ABS( X( K, J ) )
L = KD + 1 - K
DO 40 I = MAX( 1, K-KD ), K - 1
WORK( I ) = WORK( I ) + ABS( AB( L+I, K ) )*XK
S = S + ABS( AB( L+I, K ) )*ABS( X( I, J ) )
40 CONTINUE
WORK( K ) = WORK( K ) + ABS( AB( KD+1, K ) )*XK + S
50 CONTINUE
ELSE
DO 70 K = 1, N
S = ZERO
XK = ABS( X( K, J ) )
WORK( K ) = WORK( K ) + ABS( AB( 1, K ) )*XK
L = 1 - K
DO 60 I = K + 1, MIN( N, K+KD )
WORK( I ) = WORK( I ) + ABS( AB( L+I, K ) )*XK
S = S + ABS( AB( L+I, K ) )*ABS( X( I, J ) )
60 CONTINUE
WORK( K ) = WORK( K ) + S
70 CONTINUE
END IF
S = ZERO
DO 80 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
ELSE
S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
$ ( WORK( I )+SAFE1 ) )
END IF
80 CONTINUE
BERR( J ) = S
*
* Test stopping criterion. Continue iterating if
* 1) The residual BERR(J) is larger than machine epsilon, and
* 2) BERR(J) decreased by at least a factor of 2 during the
* last iteration, and
* 3) At most ITMAX iterations tried.
*
IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
$ COUNT.LE.ITMAX ) THEN
*
* Update solution and try again.
*
CALL SPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK( N+1 ), N,
$ INFO )
CALL SAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
LSTRES = BERR( J )
COUNT = COUNT + 1
GO TO 20
END IF
*
* Bound error from formula
*
* norm(X - XTRUE) / norm(X) .le. FERR =
* norm( abs(inv(A))*
* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
*
* where
* norm(Z) is the magnitude of the largest component of Z
* inv(A) is the inverse of A
* abs(Z) is the componentwise absolute value of the matrix or
* vector Z
* NZ is the maximum number of nonzeros in any row of A, plus 1
* EPS is machine epsilon
*
* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
* is incremented by SAFE1 if the i-th component of
* abs(A)*abs(X) + abs(B) is less than SAFE2.
*
* Use SLACN2 to estimate the infinity-norm of the matrix
* inv(A) * diag(W),
* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
*
DO 90 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
ELSE
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
END IF
90 CONTINUE
*
KASE = 0
100 CONTINUE
CALL SLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
$ KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Multiply by diag(W)*inv(A').
*
CALL SPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK( N+1 ), N,
$ INFO )
DO 110 I = 1, N
WORK( N+I ) = WORK( N+I )*WORK( I )
110 CONTINUE
ELSE IF( KASE.EQ.2 ) THEN
*
* Multiply by inv(A)*diag(W).
*
DO 120 I = 1, N
WORK( N+I ) = WORK( N+I )*WORK( I )
120 CONTINUE
CALL SPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK( N+1 ), N,
$ INFO )
END IF
GO TO 100
END IF
*
* Normalize error.
*
LSTRES = ZERO
DO 130 I = 1, N
LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
130 CONTINUE
IF( LSTRES.NE.ZERO )
$ FERR( J ) = FERR( J ) / LSTRES
*
140 CONTINUE
*
RETURN
*
* End of SPBRFS
*
END
SUBROUTINE SPBSTF( UPLO, N, KD, AB, LDAB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, KD, LDAB, N
* ..
* .. Array Arguments ..
REAL AB( LDAB, * )
* ..
*
* Purpose
* =======
*
* SPBSTF computes a split Cholesky factorization of a real
* symmetric positive definite band matrix A.
*
* This routine is designed to be used in conjunction with SSBGST.
*
* The factorization has the form A = S**T*S where S is a band matrix
* of the same bandwidth as A and the following structure:
*
* S = ( U )
* ( M L )
*
* where U is upper triangular of order m = (n+kd)/2, and L is lower
* triangular of order n-m.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
*
* AB (input/output) REAL array, dimension (LDAB,N)
* On entry, the upper or lower triangle of the symmetric band
* matrix A, stored in the first kd+1 rows of the array. The
* j-th column of A is stored in the j-th column of the array AB
* as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*
* On exit, if INFO = 0, the factor S from the split Cholesky
* factorization A = S**T*S. See Further Details.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, the factorization could not be completed,
* because the updated element a(i,i) was negative; the
* matrix A is not positive definite.
*
* Further Details
* ===============
*
* The band storage scheme is illustrated by the following example, when
* N = 7, KD = 2:
*
* S = ( s11 s12 s13 )
* ( s22 s23 s24 )
* ( s33 s34 )
* ( s44 )
* ( s53 s54 s55 )
* ( s64 s65 s66 )
* ( s75 s76 s77 )
*
* If UPLO = 'U', the array AB holds:
*
* on entry: on exit:
*
* * * a13 a24 a35 a46 a57 * * s13 s24 s53 s64 s75
* * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54 s65 s76
* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77
*
* If UPLO = 'L', the array AB holds:
*
* on entry: on exit:
*
* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77
* a21 a32 a43 a54 a65 a76 * s12 s23 s34 s54 s65 s76 *
* a31 a42 a53 a64 a64 * * s13 s24 s53 s64 s75 * *
*
* Array elements marked * are not used by the routine.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, KLD, KM, M
REAL AJJ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SSCAL, SSYR, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( KD.LT.0 ) THEN
INFO = -3
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPBSTF', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
KLD = MAX( 1, LDAB-1 )
*
* Set the splitting point m.
*
M = ( N+KD ) / 2
*
IF( UPPER ) THEN
*
* Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m).
*
DO 10 J = N, M + 1, -1
*
* Compute s(j,j) and test for non-positive-definiteness.
*
AJJ = AB( KD+1, J )
IF( AJJ.LE.ZERO )
$ GO TO 50
AJJ = SQRT( AJJ )
AB( KD+1, J ) = AJJ
KM = MIN( J-1, KD )
*
* Compute elements j-km:j-1 of the j-th column and update the
* the leading submatrix within the band.
*
CALL SSCAL( KM, ONE / AJJ, AB( KD+1-KM, J ), 1 )
CALL SSYR( 'Upper', KM, -ONE, AB( KD+1-KM, J ), 1,
$ AB( KD+1, J-KM ), KLD )
10 CONTINUE
*
* Factorize the updated submatrix A(1:m,1:m) as U**T*U.
*
DO 20 J = 1, M
*
* Compute s(j,j) and test for non-positive-definiteness.
*
AJJ = AB( KD+1, J )
IF( AJJ.LE.ZERO )
$ GO TO 50
AJJ = SQRT( AJJ )
AB( KD+1, J ) = AJJ
KM = MIN( KD, M-J )
*
* Compute elements j+1:j+km of the j-th row and update the
* trailing submatrix within the band.
*
IF( KM.GT.0 ) THEN
CALL SSCAL( KM, ONE / AJJ, AB( KD, J+1 ), KLD )
CALL SSYR( 'Upper', KM, -ONE, AB( KD, J+1 ), KLD,
$ AB( KD+1, J+1 ), KLD )
END IF
20 CONTINUE
ELSE
*
* Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m).
*
DO 30 J = N, M + 1, -1
*
* Compute s(j,j) and test for non-positive-definiteness.
*
AJJ = AB( 1, J )
IF( AJJ.LE.ZERO )
$ GO TO 50
AJJ = SQRT( AJJ )
AB( 1, J ) = AJJ
KM = MIN( J-1, KD )
*
* Compute elements j-km:j-1 of the j-th row and update the
* trailing submatrix within the band.
*
CALL SSCAL( KM, ONE / AJJ, AB( KM+1, J-KM ), KLD )
CALL SSYR( 'Lower', KM, -ONE, AB( KM+1, J-KM ), KLD,
$ AB( 1, J-KM ), KLD )
30 CONTINUE
*
* Factorize the updated submatrix A(1:m,1:m) as U**T*U.
*
DO 40 J = 1, M
*
* Compute s(j,j) and test for non-positive-definiteness.
*
AJJ = AB( 1, J )
IF( AJJ.LE.ZERO )
$ GO TO 50
AJJ = SQRT( AJJ )
AB( 1, J ) = AJJ
KM = MIN( KD, M-J )
*
* Compute elements j+1:j+km of the j-th column and update the
* trailing submatrix within the band.
*
IF( KM.GT.0 ) THEN
CALL SSCAL( KM, ONE / AJJ, AB( 2, J ), 1 )
CALL SSYR( 'Lower', KM, -ONE, AB( 2, J ), 1,
$ AB( 1, J+1 ), KLD )
END IF
40 CONTINUE
END IF
RETURN
*
50 CONTINUE
INFO = J
RETURN
*
* End of SPBSTF
*
END
SUBROUTINE SPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, KD, LDAB, LDB, N, NRHS
* ..
* .. Array Arguments ..
REAL AB( LDAB, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* SPBSV computes the solution to a real system of linear equations
* A * X = B,
* where A is an N-by-N symmetric positive definite band matrix and X
* and B are N-by-NRHS matrices.
*
* The Cholesky decomposition is used to factor A as
* A = U**T * U, if UPLO = 'U', or
* A = L * L**T, if UPLO = 'L',
* where U is an upper triangular band matrix, and L is a lower
* triangular band matrix, with the same number of superdiagonals or
* subdiagonals as A. The factored form of A is then used to solve the
* system of equations A * X = B.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The number of linear equations, i.e., the order of the
* matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrix B. NRHS >= 0.
*
* AB (input/output) REAL array, dimension (LDAB,N)
* On entry, the upper or lower triangle of the symmetric band
* matrix A, stored in the first KD+1 rows of the array. The
* j-th column of A is stored in the j-th column of the array AB
* as follows:
* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).
* See below for further details.
*
* On exit, if INFO = 0, the triangular factor U or L from the
* Cholesky factorization A = U**T*U or A = L*L**T of the band
* matrix A, in the same storage format as A.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the N-by-NRHS right hand side matrix B.
* On exit, if INFO = 0, the N-by-NRHS 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
* > 0: if INFO = i, the leading minor of order i of A is not
* positive definite, so the factorization could not be
* completed, and the solution has not been computed.
*
* Further Details
* ===============
*
* The band storage scheme is illustrated by the following example, when
* N = 6, KD = 2, and UPLO = 'U':
*
* On entry: On exit:
*
* * * a13 a24 a35 a46 * * u13 u24 u35 u46
* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
*
* Similarly, if UPLO = 'L' the format of A is as follows:
*
* On entry: On exit:
*
* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
* a31 a42 a53 a64 * * l31 l42 l53 l64 * *
*
* Array elements marked * are not used by the routine.
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SPBTRF, SPBTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( KD.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -6
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPBSV ', -INFO )
RETURN
END IF
*
* Compute the Cholesky factorization A = U'*U or A = L*L'.
*
CALL SPBTRF( UPLO, N, KD, AB, LDAB, INFO )
IF( INFO.EQ.0 ) THEN
*
* Solve the system A*X = B, overwriting B with X.
*
CALL SPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
*
END IF
RETURN
*
* End of SPBSV
*
END
SUBROUTINE SPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB,
$ EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR,
$ WORK, IWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER EQUED, FACT, UPLO
INTEGER INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS
REAL RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
$ BERR( * ), FERR( * ), S( * ), WORK( * ),
$ X( LDX, * )
* ..
*
* Purpose
* =======
*
* SPBSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to
* compute the solution to a real system of linear equations
* A * X = B,
* where A is an N-by-N symmetric positive definite band matrix and X
* and B are N-by-NRHS matrices.
*
* Error bounds on the solution and a condition estimate are also
* provided.
*
* Description
* ===========
*
* The following steps are performed:
*
* 1. If FACT = 'E', real scaling factors are computed to equilibrate
* the system:
* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
* Whether or not the system will be equilibrated depends on the
* scaling of the matrix A, but if equilibration is used, A is
* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
*
* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
* factor the matrix A (after equilibration if FACT = 'E') as
* A = U**T * U, if UPLO = 'U', or
* A = L * L**T, if UPLO = 'L',
* where U is an upper triangular band matrix, and L is a lower
* triangular band matrix.
*
* 3. If the leading i-by-i principal minor is not positive definite,
* then the routine returns with INFO = i. Otherwise, the factored
* form of A is used to estimate the condition number of the matrix
* A. If the reciprocal of the condition number is less than machine
* precision, INFO = N+1 is returned as a warning, but the routine
* still goes on to solve for X and compute error bounds as
* described below.
*
* 4. The system of equations is solved for X using the factored form
* of A.
*
* 5. Iterative refinement is applied to improve the computed solution
* matrix and calculate error bounds and backward error estimates
* for it.
*
* 6. If equilibration was used, the matrix X is premultiplied by
* diag(S) so that it solves the original system before
* equilibration.
*
* Arguments
* =========
*
* FACT (input) CHARACTER*1
* Specifies whether or not the factored form of the matrix A is
* supplied on entry, and if not, whether the matrix A should be
* equilibrated before it is factored.
* = 'F': On entry, AFB contains the factored form of A.
* If EQUED = 'Y', the matrix A has been equilibrated
* with scaling factors given by S. AB and AFB will not
* be modified.
* = 'N': The matrix A will be copied to AFB and factored.
* = 'E': The matrix A will be equilibrated if necessary, then
* copied to AFB and factored.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The number of linear equations, i.e., the order of the
* matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
*
* NRHS (input) INTEGER
* The number of right-hand sides, i.e., the number of columns
* of the matrices B and X. NRHS >= 0.
*
* AB (input/output) REAL array, dimension (LDAB,N)
* On entry, the upper or lower triangle of the symmetric band
* matrix A, stored in the first KD+1 rows of the array, except
* if FACT = 'F' and EQUED = 'Y', then A must contain the
* equilibrated matrix diag(S)*A*diag(S). The j-th column of A
* is stored in the j-th column of the array AB as follows:
* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).
* See below for further details.
*
* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
* diag(S)*A*diag(S).
*
* LDAB (input) INTEGER
* The leading dimension of the array A. LDAB >= KD+1.
*
* AFB (input or output) REAL array, dimension (LDAFB,N)
* If FACT = 'F', then AFB is an input argument and on entry
* contains the triangular factor U or L from the Cholesky
* factorization A = U**T*U or A = L*L**T of the band matrix
* A, in the same storage format as A (see AB). If EQUED = 'Y',
* then AFB is the factored form of the equilibrated matrix A.
*
* If FACT = 'N', then AFB is an output argument and on exit
* returns the triangular factor U or L from the Cholesky
* factorization A = U**T*U or A = L*L**T.
*
* If FACT = 'E', then AFB is an output argument and on exit
* returns the triangular factor U or L from the Cholesky
* factorization A = U**T*U or A = L*L**T of the equilibrated
* matrix A (see the description of A for the form of the
* equilibrated matrix).
*
* LDAFB (input) INTEGER
* The leading dimension of the array AFB. LDAFB >= KD+1.
*
* EQUED (input or output) CHARACTER*1
* Specifies the form of equilibration that was done.
* = 'N': No equilibration (always true if FACT = 'N').
* = 'Y': Equilibration was done, i.e., A has been replaced by
* diag(S) * A * diag(S).
* EQUED is an input argument if FACT = 'F'; otherwise, it is an
* output argument.
*
* S (input or output) REAL array, dimension (N)
* The scale factors for A; not accessed if EQUED = 'N'. S is
* an input argument if FACT = 'F'; otherwise, S is an output
* argument. If FACT = 'F' and EQUED = 'Y', each element of S
* must be positive.
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the N-by-NRHS right hand side matrix B.
* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
* B is overwritten by diag(S) * B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (output) REAL array, dimension (LDX,NRHS)
* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
* the original system of equations. Note that if EQUED = 'Y',
* A and B are modified on exit, and the solution to the
* equilibrated system is inv(diag(S))*X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* RCOND (output) REAL
* The estimate of the reciprocal condition number of the matrix
* A after equilibration (if done). If RCOND is less than the
* machine precision (in particular, if RCOND = 0), the matrix
* is singular to working precision. This condition is
* indicated by a return code of INFO > 0.
*
* FERR (output) REAL array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) REAL array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, and i is
* <= N: the leading minor of order i of A is
* not positive definite, so the factorization
* could not be completed, and the solution has not
* been computed. RCOND = 0 is returned.
* = N+1: U is nonsingular, but RCOND is less than machine
* precision, meaning that the matrix is singular
* to working precision. Nevertheless, the
* solution and error bounds are computed because
* there are a number of situations where the
* computed solution can be more accurate than the
* value of RCOND would suggest.
*
* Further Details
* ===============
*
* The band storage scheme is illustrated by the following example, when
* N = 6, KD = 2, and UPLO = 'U':
*
* Two-dimensional storage of the symmetric matrix A:
*
* a11 a12 a13
* a22 a23 a24
* a33 a34 a35
* a44 a45 a46
* a55 a56
* (aij=conjg(aji)) a66
*
* Band storage of the upper triangle of A:
*
* * * a13 a24 a35 a46
* * a12 a23 a34 a45 a56
* a11 a22 a33 a44 a55 a66
*
* Similarly, if UPLO = 'L' the format of A is as follows:
*
* a11 a22 a33 a44 a55 a66
* a21 a32 a43 a54 a65 *
* a31 a42 a53 a64 * *
*
* Array elements marked * are not used by the routine.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL EQUIL, NOFACT, RCEQU, UPPER
INTEGER I, INFEQU, J, J1, J2
REAL AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANSB
EXTERNAL LSAME, SLAMCH, SLANSB
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLACPY, SLAQSB, SPBCON, SPBEQU, SPBRFS,
$ SPBTRF, SPBTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
NOFACT = LSAME( FACT, 'N' )
EQUIL = LSAME( FACT, 'E' )
UPPER = LSAME( UPLO, 'U' )
IF( NOFACT .OR. EQUIL ) THEN
EQUED = 'N'
RCEQU = .FALSE.
ELSE
RCEQU = LSAME( EQUED, 'Y' )
SMLNUM = SLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
END IF
*
* Test the input parameters.
*
IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
$ THEN
INFO = -1
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( KD.LT.0 ) THEN
INFO = -4
ELSE IF( NRHS.LT.0 ) THEN
INFO = -5
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -7
ELSE IF( LDAFB.LT.KD+1 ) THEN
INFO = -9
ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
$ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
INFO = -10
ELSE
IF( RCEQU ) THEN
SMIN = BIGNUM
SMAX = ZERO
DO 10 J = 1, N
SMIN = MIN( SMIN, S( J ) )
SMAX = MAX( SMAX, S( J ) )
10 CONTINUE
IF( SMIN.LE.ZERO ) THEN
INFO = -11
ELSE IF( N.GT.0 ) THEN
SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
ELSE
SCOND = ONE
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -13
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -15
END IF
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPBSVX', -INFO )
RETURN
END IF
*
IF( EQUIL ) THEN
*
* Compute row and column scalings to equilibrate the matrix A.
*
CALL SPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFEQU )
IF( INFEQU.EQ.0 ) THEN
*
* Equilibrate the matrix.
*
CALL SLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )
RCEQU = LSAME( EQUED, 'Y' )
END IF
END IF
*
* Scale the right-hand side.
*
IF( RCEQU ) THEN
DO 30 J = 1, NRHS
DO 20 I = 1, N
B( I, J ) = S( I )*B( I, J )
20 CONTINUE
30 CONTINUE
END IF
*
IF( NOFACT .OR. EQUIL ) THEN
*
* Compute the Cholesky factorization A = U'*U or A = L*L'.
*
IF( UPPER ) THEN
DO 40 J = 1, N
J1 = MAX( J-KD, 1 )
CALL SCOPY( J-J1+1, AB( KD+1-J+J1, J ), 1,
$ AFB( KD+1-J+J1, J ), 1 )
40 CONTINUE
ELSE
DO 50 J = 1, N
J2 = MIN( J+KD, N )
CALL SCOPY( J2-J+1, AB( 1, J ), 1, AFB( 1, J ), 1 )
50 CONTINUE
END IF
*
CALL SPBTRF( UPLO, N, KD, AFB, LDAFB, INFO )
*
* Return if INFO is non-zero.
*
IF( INFO.GT.0 )THEN
RCOND = ZERO
RETURN
END IF
END IF
*
* Compute the norm of the matrix A.
*
ANORM = SLANSB( '1', UPLO, N, KD, AB, LDAB, WORK )
*
* Compute the reciprocal of the condition number of A.
*
CALL SPBCON( UPLO, N, KD, AFB, LDAFB, ANORM, RCOND, WORK, IWORK,
$ INFO )
*
* Compute the solution matrix X.
*
CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
CALL SPBTRS( UPLO, N, KD, NRHS, AFB, LDAFB, X, LDX, INFO )
*
* Use iterative refinement to improve the computed solution and
* compute error bounds and backward error estimates for it.
*
CALL SPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X,
$ LDX, FERR, BERR, WORK, IWORK, INFO )
*
* Transform the solution matrix X to a solution of the original
* system.
*
IF( RCEQU ) THEN
DO 70 J = 1, NRHS
DO 60 I = 1, N
X( I, J ) = S( I )*X( I, J )
60 CONTINUE
70 CONTINUE
DO 80 J = 1, NRHS
FERR( J ) = FERR( J ) / SCOND
80 CONTINUE
END IF
*
* Set INFO = N+1 if the matrix is singular to working precision.
*
IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
$ INFO = N + 1
*
RETURN
*
* End of SPBSVX
*
END
SUBROUTINE SPBTF2( UPLO, N, KD, AB, LDAB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, KD, LDAB, N
* ..
* .. Array Arguments ..
REAL AB( LDAB, * )
* ..
*
* Purpose
* =======
*
* SPBTF2 computes the Cholesky factorization of a real symmetric
* positive definite band matrix A.
*
* The factorization has the form
* A = U' * U , if UPLO = 'U', or
* A = L * L', if UPLO = 'L',
* where U is an upper triangular matrix, U' is the transpose of U, and
* L is lower triangular.
*
* This is the unblocked version of the algorithm, calling Level 2 BLAS.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of super-diagonals of the matrix A if UPLO = 'U',
* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
*
* AB (input/output) REAL array, dimension (LDAB,N)
* On entry, the upper or lower triangle of the symmetric band
* matrix A, stored in the first KD+1 rows of the array. The
* j-th column of A is stored in the j-th column of the array AB
* as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*
* On exit, if INFO = 0, the triangular factor U or L from the
* Cholesky factorization A = U'*U or A = L*L' of the band
* matrix A, in the same storage format as A.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
* > 0: if INFO = k, the leading minor of order k is not
* positive definite, and the factorization could not be
* completed.
*
* Further Details
* ===============
*
* The band storage scheme is illustrated by the following example, when
* N = 6, KD = 2, and UPLO = 'U':
*
* On entry: On exit:
*
* * * a13 a24 a35 a46 * * u13 u24 u35 u46
* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
*
* Similarly, if UPLO = 'L' the format of A is as follows:
*
* On entry: On exit:
*
* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
* a31 a42 a53 a64 * * l31 l42 l53 l64 * *
*
* Array elements marked * are not used by the routine.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, KLD, KN
REAL AJJ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SSCAL, SSYR, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( KD.LT.0 ) THEN
INFO = -3
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPBTF2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
KLD = MAX( 1, LDAB-1 )
*
IF( UPPER ) THEN
*
* Compute the Cholesky factorization A = U'*U.
*
DO 10 J = 1, N
*
* Compute U(J,J) and test for non-positive-definiteness.
*
AJJ = AB( KD+1, J )
IF( AJJ.LE.ZERO )
$ GO TO 30
AJJ = SQRT( AJJ )
AB( KD+1, J ) = AJJ
*
* Compute elements J+1:J+KN of row J and update the
* trailing submatrix within the band.
*
KN = MIN( KD, N-J )
IF( KN.GT.0 ) THEN
CALL SSCAL( KN, ONE / AJJ, AB( KD, J+1 ), KLD )
CALL SSYR( 'Upper', KN, -ONE, AB( KD, J+1 ), KLD,
$ AB( KD+1, J+1 ), KLD )
END IF
10 CONTINUE
ELSE
*
* Compute the Cholesky factorization A = L*L'.
*
DO 20 J = 1, N
*
* Compute L(J,J) and test for non-positive-definiteness.
*
AJJ = AB( 1, J )
IF( AJJ.LE.ZERO )
$ GO TO 30
AJJ = SQRT( AJJ )
AB( 1, J ) = AJJ
*
* Compute elements J+1:J+KN of column J and update the
* trailing submatrix within the band.
*
KN = MIN( KD, N-J )
IF( KN.GT.0 ) THEN
CALL SSCAL( KN, ONE / AJJ, AB( 2, J ), 1 )
CALL SSYR( 'Lower', KN, -ONE, AB( 2, J ), 1,
$ AB( 1, J+1 ), KLD )
END IF
20 CONTINUE
END IF
RETURN
*
30 CONTINUE
INFO = J
RETURN
*
* End of SPBTF2
*
END
SUBROUTINE SPBTRF( UPLO, N, KD, AB, LDAB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, KD, LDAB, N
* ..
* .. Array Arguments ..
REAL AB( LDAB, * )
* ..
*
* Purpose
* =======
*
* SPBTRF computes the Cholesky factorization of a real symmetric
* positive definite band matrix A.
*
* The factorization has the form
* A = U**T * U, if UPLO = 'U', or
* A = L * L**T, if UPLO = 'L',
* where U is an upper triangular matrix and L is lower triangular.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
*
* AB (input/output) REAL array, dimension (LDAB,N)
* On entry, the upper or lower triangle of the symmetric band
* matrix A, stored in the first KD+1 rows of the array. The
* j-th column of A is stored in the j-th column of the array AB
* as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*
* On exit, if INFO = 0, the triangular factor U or L from the
* Cholesky factorization A = U**T*U or A = L*L**T of the band
* matrix A, in the same storage format as A.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, the leading minor of order i is not
* positive definite, and the factorization could not be
* completed.
*
* Further Details
* ===============
*
* The band storage scheme is illustrated by the following example, when
* N = 6, KD = 2, and UPLO = 'U':
*
* On entry: On exit:
*
* * * a13 a24 a35 a46 * * u13 u24 u35 u46
* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
*
* Similarly, if UPLO = 'L' the format of A is as follows:
*
* On entry: On exit:
*
* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
* a31 a42 a53 a64 * * l31 l42 l53 l64 * *
*
* Array elements marked * are not used by the routine.
*
* Contributed by
* Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
INTEGER NBMAX, LDWORK
PARAMETER ( NBMAX = 32, LDWORK = NBMAX+1 )
* ..
* .. Local Scalars ..
INTEGER I, I2, I3, IB, II, J, JJ, NB
* ..
* .. Local Arrays ..
REAL WORK( LDWORK, NBMAX )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SPBTF2, SPOTF2, SSYRK, STRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( ( .NOT.LSAME( UPLO, 'U' ) ) .AND.
$ ( .NOT.LSAME( UPLO, 'L' ) ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( KD.LT.0 ) THEN
INFO = -3
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPBTRF', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Determine the block size for this environment
*
NB = ILAENV( 1, 'SPBTRF', UPLO, N, KD, -1, -1 )
*
* The block size must not exceed the semi-bandwidth KD, and must not
* exceed the limit set by the size of the local array WORK.
*
NB = MIN( NB, NBMAX )
*
IF( NB.LE.1 .OR. NB.GT.KD ) THEN
*
* Use unblocked code
*
CALL SPBTF2( UPLO, N, KD, AB, LDAB, INFO )
ELSE
*
* Use blocked code
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Compute the Cholesky factorization of a symmetric band
* matrix, given the upper triangle of the matrix in band
* storage.
*
* Zero the upper triangle of the work array.
*
DO 20 J = 1, NB
DO 10 I = 1, J - 1
WORK( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
*
* Process the band matrix one diagonal block at a time.
*
DO 70 I = 1, N, NB
IB = MIN( NB, N-I+1 )
*
* Factorize the diagonal block
*
CALL SPOTF2( UPLO, IB, AB( KD+1, I ), LDAB-1, II )
IF( II.NE.0 ) THEN
INFO = I + II - 1
GO TO 150
END IF
IF( I+IB.LE.N ) THEN
*
* Update the relevant part of the trailing submatrix.
* If A11 denotes the diagonal block which has just been
* factorized, then we need to update the remaining
* blocks in the diagram:
*
* A11 A12 A13
* A22 A23
* A33
*
* The numbers of rows and columns in the partitioning
* are IB, I2, I3 respectively. The blocks A12, A22 and
* A23 are empty if IB = KD. The upper triangle of A13
* lies outside the band.
*
I2 = MIN( KD-IB, N-I-IB+1 )
I3 = MIN( IB, N-I-KD+1 )
*
IF( I2.GT.0 ) THEN
*
* Update A12
*
CALL STRSM( 'Left', 'Upper', 'Transpose',
$ 'Non-unit', IB, I2, ONE, AB( KD+1, I ),
$ LDAB-1, AB( KD+1-IB, I+IB ), LDAB-1 )
*
* Update A22
*
CALL SSYRK( 'Upper', 'Transpose', I2, IB, -ONE,
$ AB( KD+1-IB, I+IB ), LDAB-1, ONE,
$ AB( KD+1, I+IB ), LDAB-1 )
END IF
*
IF( I3.GT.0 ) THEN
*
* Copy the lower triangle of A13 into the work array.
*
DO 40 JJ = 1, I3
DO 30 II = JJ, IB
WORK( II, JJ ) = AB( II-JJ+1, JJ+I+KD-1 )
30 CONTINUE
40 CONTINUE
*
* Update A13 (in the work array).
*
CALL STRSM( 'Left', 'Upper', 'Transpose',
$ 'Non-unit', IB, I3, ONE, AB( KD+1, I ),
$ LDAB-1, WORK, LDWORK )
*
* Update A23
*
IF( I2.GT.0 )
$ CALL SGEMM( 'Transpose', 'No Transpose', I2, I3,
$ IB, -ONE, AB( KD+1-IB, I+IB ),
$ LDAB-1, WORK, LDWORK, ONE,
$ AB( 1+IB, I+KD ), LDAB-1 )
*
* Update A33
*
CALL SSYRK( 'Upper', 'Transpose', I3, IB, -ONE,
$ WORK, LDWORK, ONE, AB( KD+1, I+KD ),
$ LDAB-1 )
*
* Copy the lower triangle of A13 back into place.
*
DO 60 JJ = 1, I3
DO 50 II = JJ, IB
AB( II-JJ+1, JJ+I+KD-1 ) = WORK( II, JJ )
50 CONTINUE
60 CONTINUE
END IF
END IF
70 CONTINUE
ELSE
*
* Compute the Cholesky factorization of a symmetric band
* matrix, given the lower triangle of the matrix in band
* storage.
*
* Zero the lower triangle of the work array.
*
DO 90 J = 1, NB
DO 80 I = J + 1, NB
WORK( I, J ) = ZERO
80 CONTINUE
90 CONTINUE
*
* Process the band matrix one diagonal block at a time.
*
DO 140 I = 1, N, NB
IB = MIN( NB, N-I+1 )
*
* Factorize the diagonal block
*
CALL SPOTF2( UPLO, IB, AB( 1, I ), LDAB-1, II )
IF( II.NE.0 ) THEN
INFO = I + II - 1
GO TO 150
END IF
IF( I+IB.LE.N ) THEN
*
* Update the relevant part of the trailing submatrix.
* If A11 denotes the diagonal block which has just been
* factorized, then we need to update the remaining
* blocks in the diagram:
*
* A11
* A21 A22
* A31 A32 A33
*
* The numbers of rows and columns in the partitioning
* are IB, I2, I3 respectively. The blocks A21, A22 and
* A32 are empty if IB = KD. The lower triangle of A31
* lies outside the band.
*
I2 = MIN( KD-IB, N-I-IB+1 )
I3 = MIN( IB, N-I-KD+1 )
*
IF( I2.GT.0 ) THEN
*
* Update A21
*
CALL STRSM( 'Right', 'Lower', 'Transpose',
$ 'Non-unit', I2, IB, ONE, AB( 1, I ),
$ LDAB-1, AB( 1+IB, I ), LDAB-1 )
*
* Update A22
*
CALL SSYRK( 'Lower', 'No Transpose', I2, IB, -ONE,
$ AB( 1+IB, I ), LDAB-1, ONE,
$ AB( 1, I+IB ), LDAB-1 )
END IF
*
IF( I3.GT.0 ) THEN
*
* Copy the upper triangle of A31 into the work array.
*
DO 110 JJ = 1, IB
DO 100 II = 1, MIN( JJ, I3 )
WORK( II, JJ ) = AB( KD+1-JJ+II, JJ+I-1 )
100 CONTINUE
110 CONTINUE
*
* Update A31 (in the work array).
*
CALL STRSM( 'Right', 'Lower', 'Transpose',
$ 'Non-unit', I3, IB, ONE, AB( 1, I ),
$ LDAB-1, WORK, LDWORK )
*
* Update A32
*
IF( I2.GT.0 )
$ CALL SGEMM( 'No transpose', 'Transpose', I3, I2,
$ IB, -ONE, WORK, LDWORK,
$ AB( 1+IB, I ), LDAB-1, ONE,
$ AB( 1+KD-IB, I+IB ), LDAB-1 )
*
* Update A33
*
CALL SSYRK( 'Lower', 'No Transpose', I3, IB, -ONE,
$ WORK, LDWORK, ONE, AB( 1, I+KD ),
$ LDAB-1 )
*
* Copy the upper triangle of A31 back into place.
*
DO 130 JJ = 1, IB
DO 120 II = 1, MIN( JJ, I3 )
AB( KD+1-JJ+II, JJ+I-1 ) = WORK( II, JJ )
120 CONTINUE
130 CONTINUE
END IF
END IF
140 CONTINUE
END IF
END IF
RETURN
*
150 CONTINUE
RETURN
*
* End of SPBTRF
*
END
SUBROUTINE SPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, KD, LDAB, LDB, N, NRHS
* ..
* .. Array Arguments ..
REAL AB( LDAB, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* SPBTRS solves a system of linear equations A*X = B with a symmetric
* positive definite band matrix A using the Cholesky factorization
* A = U**T*U or A = L*L**T computed by SPBTRF.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangular factor stored in AB;
* = 'L': Lower triangular factor stored in AB.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrix B. NRHS >= 0.
*
* AB (input) REAL array, dimension (LDAB,N)
* The triangular factor U or L from the Cholesky factorization
* A = U**T*U or A = L*L**T of the band matrix A, stored in the
* first KD+1 rows of the array. The j-th column of U or L is
* stored in the j-th column of the array AB as follows:
* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* B (input/output) REAL 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
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL STBSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( KD.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -6
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPBTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Solve A*X = B where A = U'*U.
*
DO 10 J = 1, NRHS
*
* Solve U'*X = B, overwriting B with X.
*
CALL STBSV( 'Upper', 'Transpose', 'Non-unit', N, KD, AB,
$ LDAB, B( 1, J ), 1 )
*
* Solve U*X = B, overwriting B with X.
*
CALL STBSV( 'Upper', 'No transpose', 'Non-unit', N, KD, AB,
$ LDAB, B( 1, J ), 1 )
10 CONTINUE
ELSE
*
* Solve A*X = B where A = L*L'.
*
DO 20 J = 1, NRHS
*
* Solve L*X = B, overwriting B with X.
*
CALL STBSV( 'Lower', 'No transpose', 'Non-unit', N, KD, AB,
$ LDAB, B( 1, J ), 1 )
*
* Solve L'*X = B, overwriting B with X.
*
CALL STBSV( 'Lower', 'Transpose', 'Non-unit', N, KD, AB,
$ LDAB, B( 1, J ), 1 )
20 CONTINUE
END IF
*
RETURN
*
* End of SPBTRS
*
END
SUBROUTINE SPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
REAL ANORM, RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL A( LDA, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SPOCON estimates the reciprocal of the condition number (in the
* 1-norm) of a real symmetric positive definite matrix using the
* Cholesky factorization A = U**T*U or A = L*L**T computed by SPOTRF.
*
* An estimate is obtained for norm(inv(A)), and the reciprocal of the
* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The triangular factor U or L from the Cholesky factorization
* A = U**T*U or A = L*L**T, as computed by SPOTRF.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* ANORM (input) REAL
* The 1-norm (or infinity-norm) of the symmetric matrix A.
*
* RCOND (output) REAL
* The reciprocal of the condition number of the matrix A,
* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
* estimate of the 1-norm of inv(A) computed in this routine.
*
* WORK (workspace) REAL array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
CHARACTER NORMIN
INTEGER IX, KASE
REAL AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SLAMCH
EXTERNAL LSAME, ISAMAX, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SLACN2, SLATRS, SRSCL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( ANORM.LT.ZERO ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPOCON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
RCOND = ZERO
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
ELSE IF( ANORM.EQ.ZERO ) THEN
RETURN
END IF
*
SMLNUM = SLAMCH( 'Safe minimum' )
*
* Estimate the 1-norm of inv(A).
*
KASE = 0
NORMIN = 'N'
10 CONTINUE
CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( UPPER ) THEN
*
* Multiply by inv(U').
*
CALL SLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, A,
$ LDA, WORK, SCALEL, WORK( 2*N+1 ), INFO )
NORMIN = 'Y'
*
* Multiply by inv(U).
*
CALL SLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
$ A, LDA, WORK, SCALEU, WORK( 2*N+1 ), INFO )
ELSE
*
* Multiply by inv(L).
*
CALL SLATRS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N,
$ A, LDA, WORK, SCALEL, WORK( 2*N+1 ), INFO )
NORMIN = 'Y'
*
* Multiply by inv(L').
*
CALL SLATRS( 'Lower', 'Transpose', 'Non-unit', NORMIN, N, A,
$ LDA, WORK, SCALEU, WORK( 2*N+1 ), INFO )
END IF
*
* Multiply by 1/SCALE if doing so will not cause overflow.
*
SCALE = SCALEL*SCALEU
IF( SCALE.NE.ONE ) THEN
IX = ISAMAX( N, WORK, 1 )
IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
$ GO TO 20
CALL SRSCL( N, SCALE, WORK, 1 )
END IF
GO TO 10
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / AINVNM ) / ANORM
*
20 CONTINUE
RETURN
*
* End of SPOCON
*
END
SUBROUTINE SPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, N
REAL AMAX, SCOND
* ..
* .. Array Arguments ..
REAL A( LDA, * ), S( * )
* ..
*
* Purpose
* =======
*
* SPOEQU computes row and column scalings intended to equilibrate a
* symmetric positive definite matrix A and reduce its condition number
* (with respect to the two-norm). S contains the scale factors,
* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
* choice of S puts the condition number of B within a factor N of the
* smallest possible condition number over all possible diagonal
* scalings.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The N-by-N symmetric positive definite matrix whose scaling
* factors are to be computed. Only the diagonal elements of A
* are referenced.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* S (output) REAL array, dimension (N)
* If INFO = 0, S contains the scale factors for A.
*
* SCOND (output) REAL
* If INFO = 0, S contains the ratio of the smallest S(i) to
* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
* large nor too small, it is not worth scaling by S.
*
* AMAX (output) REAL
* Absolute value of largest matrix element. If AMAX is very
* close to overflow or very close to underflow, the matrix
* should be scaled.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, the i-th diagonal element is nonpositive.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I
REAL SMIN
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -3
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPOEQU', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
SCOND = ONE
AMAX = ZERO
RETURN
END IF
*
* Find the minimum and maximum diagonal elements.
*
S( 1 ) = A( 1, 1 )
SMIN = S( 1 )
AMAX = S( 1 )
DO 10 I = 2, N
S( I ) = A( I, I )
SMIN = MIN( SMIN, S( I ) )
AMAX = MAX( AMAX, S( I ) )
10 CONTINUE
*
IF( SMIN.LE.ZERO ) THEN
*
* Find the first non-positive diagonal element and return.
*
DO 20 I = 1, N
IF( S( I ).LE.ZERO ) THEN
INFO = I
RETURN
END IF
20 CONTINUE
ELSE
*
* Set the scale factors to the reciprocals
* of the diagonal elements.
*
DO 30 I = 1, N
S( I ) = ONE / SQRT( S( I ) )
30 CONTINUE
*
* Compute SCOND = min(S(I)) / max(S(I))
*
SCOND = SQRT( SMIN ) / SQRT( AMAX )
END IF
RETURN
*
* End of SPOEQU
*
END
SUBROUTINE SPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X,
$ LDX, FERR, BERR, WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
$ BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* SPORFS improves the computed solution to a system of linear
* equations when the coefficient matrix is symmetric positive definite,
* and provides error bounds and backward error estimates for the
* solution.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* 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 matrices B and X. NRHS >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
* upper triangular part of A contains the upper triangular part
* of the matrix A, and the strictly lower triangular part of A
* is not referenced. If UPLO = 'L', the leading N-by-N lower
* triangular part of A contains the lower triangular part of
* the matrix A, and the strictly upper triangular part of A is
* not referenced.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* AF (input) REAL array, dimension (LDAF,N)
* The triangular factor U or L from the Cholesky factorization
* A = U**T*U or A = L*L**T, as computed by SPOTRF.
*
* LDAF (input) INTEGER
* The leading dimension of the array AF. LDAF >= max(1,N).
*
* B (input) REAL array, dimension (LDB,NRHS)
* The right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input/output) REAL array, dimension (LDX,NRHS)
* On entry, the solution matrix X, as computed by SPOTRS.
* On exit, the improved solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* FERR (output) REAL array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) REAL array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Internal Parameters
* ===================
*
* ITMAX is the maximum number of steps of iterative refinement.
*
* =====================================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 5 )
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
REAL TWO
PARAMETER ( TWO = 2.0E+0 )
REAL THREE
PARAMETER ( THREE = 3.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER COUNT, I, J, K, KASE, NZ
REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, SLACN2, SPOTRS, SSYMV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH
EXTERNAL LSAME, SLAMCH
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) 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( LDAF.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -11
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPORFS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
DO 10 J = 1, NRHS
FERR( J ) = ZERO
BERR( J ) = ZERO
10 CONTINUE
RETURN
END IF
*
* NZ = maximum number of nonzero elements in each row of A, plus 1
*
NZ = N + 1
EPS = SLAMCH( 'Epsilon' )
SAFMIN = SLAMCH( 'Safe minimum' )
SAFE1 = NZ*SAFMIN
SAFE2 = SAFE1 / EPS
*
* Do for each right hand side
*
DO 140 J = 1, NRHS
*
COUNT = 1
LSTRES = THREE
20 CONTINUE
*
* Loop until stopping criterion is satisfied.
*
* Compute residual R = B - A * X
*
CALL SCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
CALL SSYMV( UPLO, N, -ONE, A, LDA, X( 1, J ), 1, ONE,
$ WORK( N+1 ), 1 )
*
* Compute componentwise relative backward error from formula
*
* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
*
* where abs(Z) is the componentwise absolute value of the matrix
* or vector Z. If the i-th component of the denominator is less
* than SAFE2, then SAFE1 is added to the i-th components of the
* numerator and denominator before dividing.
*
DO 30 I = 1, N
WORK( I ) = ABS( B( I, J ) )
30 CONTINUE
*
* Compute abs(A)*abs(X) + abs(B).
*
IF( UPPER ) THEN
DO 50 K = 1, N
S = ZERO
XK = ABS( X( K, J ) )
DO 40 I = 1, K - 1
WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
40 CONTINUE
WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK + S
50 CONTINUE
ELSE
DO 70 K = 1, N
S = ZERO
XK = ABS( X( K, J ) )
WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK
DO 60 I = K + 1, N
WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
60 CONTINUE
WORK( K ) = WORK( K ) + S
70 CONTINUE
END IF
S = ZERO
DO 80 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
ELSE
S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
$ ( WORK( I )+SAFE1 ) )
END IF
80 CONTINUE
BERR( J ) = S
*
* Test stopping criterion. Continue iterating if
* 1) The residual BERR(J) is larger than machine epsilon, and
* 2) BERR(J) decreased by at least a factor of 2 during the
* last iteration, and
* 3) At most ITMAX iterations tried.
*
IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
$ COUNT.LE.ITMAX ) THEN
*
* Update solution and try again.
*
CALL SPOTRS( UPLO, N, 1, AF, LDAF, WORK( N+1 ), N, INFO )
CALL SAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
LSTRES = BERR( J )
COUNT = COUNT + 1
GO TO 20
END IF
*
* Bound error from formula
*
* norm(X - XTRUE) / norm(X) .le. FERR =
* norm( abs(inv(A))*
* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
*
* where
* norm(Z) is the magnitude of the largest component of Z
* inv(A) is the inverse of A
* abs(Z) is the componentwise absolute value of the matrix or
* vector Z
* NZ is the maximum number of nonzeros in any row of A, plus 1
* EPS is machine epsilon
*
* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
* is incremented by SAFE1 if the i-th component of
* abs(A)*abs(X) + abs(B) is less than SAFE2.
*
* Use SLACN2 to estimate the infinity-norm of the matrix
* inv(A) * diag(W),
* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
*
DO 90 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
ELSE
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
END IF
90 CONTINUE
*
KASE = 0
100 CONTINUE
CALL SLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
$ KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Multiply by diag(W)*inv(A').
*
CALL SPOTRS( UPLO, N, 1, AF, LDAF, WORK( N+1 ), N, INFO )
DO 110 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
110 CONTINUE
ELSE IF( KASE.EQ.2 ) THEN
*
* Multiply by inv(A)*diag(W).
*
DO 120 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
120 CONTINUE
CALL SPOTRS( UPLO, N, 1, AF, LDAF, WORK( N+1 ), N, INFO )
END IF
GO TO 100
END IF
*
* Normalize error.
*
LSTRES = ZERO
DO 130 I = 1, N
LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
130 CONTINUE
IF( LSTRES.NE.ZERO )
$ FERR( J ) = FERR( J ) / LSTRES
*
140 CONTINUE
*
RETURN
*
* End of SPORFS
*
END
SUBROUTINE SPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* SPOSV computes the solution to a real system of linear equations
* A * X = B,
* where A is an N-by-N symmetric positive definite matrix and X and B
* are N-by-NRHS matrices.
*
* The Cholesky decomposition is used to factor A as
* A = U**T* U, if UPLO = 'U', or
* A = L * L**T, if UPLO = 'L',
* where U is an upper triangular matrix and L is a lower triangular
* matrix. The factored form of A is then used to solve the system of
* equations A * X = B.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The number of linear equations, i.e., 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/output) REAL array, dimension (LDA,N)
* On entry, the symmetric matrix A. If UPLO = 'U', the leading
* N-by-N upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading N-by-N lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced.
*
* On exit, if INFO = 0, the factor U or L from the Cholesky
* factorization A = U**T*U or A = L*L**T.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the N-by-NRHS right hand side matrix B.
* On exit, if INFO = 0, the N-by-NRHS 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
* > 0: if INFO = i, the leading minor of order i of A is not
* positive definite, so the factorization could not be
* completed, and the solution has not been computed.
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SPOTRF, SPOTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) 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 = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPOSV ', -INFO )
RETURN
END IF
*
* Compute the Cholesky factorization A = U'*U or A = L*L'.
*
CALL SPOTRF( UPLO, N, A, LDA, INFO )
IF( INFO.EQ.0 ) THEN
*
* Solve the system A*X = B, overwriting B with X.
*
CALL SPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
*
END IF
RETURN
*
* End of SPOSV
*
END
SUBROUTINE SPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED,
$ S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK,
$ IWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER EQUED, FACT, UPLO
INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
REAL RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
$ BERR( * ), FERR( * ), S( * ), WORK( * ),
$ X( LDX, * )
* ..
*
* Purpose
* =======
*
* SPOSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to
* compute the solution to a real system of linear equations
* A * X = B,
* where A is an N-by-N symmetric positive definite matrix and X and B
* are N-by-NRHS matrices.
*
* Error bounds on the solution and a condition estimate are also
* provided.
*
* Description
* ===========
*
* The following steps are performed:
*
* 1. If FACT = 'E', real scaling factors are computed to equilibrate
* the system:
* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
* Whether or not the system will be equilibrated depends on the
* scaling of the matrix A, but if equilibration is used, A is
* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
*
* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
* factor the matrix A (after equilibration if FACT = 'E') as
* A = U**T* U, if UPLO = 'U', or
* A = L * L**T, if UPLO = 'L',
* where U is an upper triangular matrix and L is a lower triangular
* matrix.
*
* 3. If the leading i-by-i principal minor is not positive definite,
* then the routine returns with INFO = i. Otherwise, the factored
* form of A is used to estimate the condition number of the matrix
* A. If the reciprocal of the condition number is less than machine
* precision, INFO = N+1 is returned as a warning, but the routine
* still goes on to solve for X and compute error bounds as
* described below.
*
* 4. The system of equations is solved for X using the factored form
* of A.
*
* 5. Iterative refinement is applied to improve the computed solution
* matrix and calculate error bounds and backward error estimates
* for it.
*
* 6. If equilibration was used, the matrix X is premultiplied by
* diag(S) so that it solves the original system before
* equilibration.
*
* Arguments
* =========
*
* FACT (input) CHARACTER*1
* Specifies whether or not the factored form of the matrix A is
* supplied on entry, and if not, whether the matrix A should be
* equilibrated before it is factored.
* = 'F': On entry, AF contains the factored form of A.
* If EQUED = 'Y', the matrix A has been equilibrated
* with scaling factors given by S. A and AF will not
* be modified.
* = 'N': The matrix A will be copied to AF and factored.
* = 'E': The matrix A will be equilibrated if necessary, then
* copied to AF and factored.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The number of linear equations, i.e., 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 matrices B and X. NRHS >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the symmetric matrix A, except if FACT = 'F' and
* EQUED = 'Y', then A must contain the equilibrated matrix
* diag(S)*A*diag(S). If UPLO = 'U', the leading
* N-by-N upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading N-by-N lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced. A is not modified if
* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
*
* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
* diag(S)*A*diag(S).
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* AF (input or output) REAL array, dimension (LDAF,N)
* If FACT = 'F', then AF is an input argument and on entry
* contains the triangular factor U or L from the Cholesky
* factorization A = U**T*U or A = L*L**T, in the same storage
* format as A. If EQUED .ne. 'N', then AF is the factored form
* of the equilibrated matrix diag(S)*A*diag(S).
*
* If FACT = 'N', then AF is an output argument and on exit
* returns the triangular factor U or L from the Cholesky
* factorization A = U**T*U or A = L*L**T of the original
* matrix A.
*
* If FACT = 'E', then AF is an output argument and on exit
* returns the triangular factor U or L from the Cholesky
* factorization A = U**T*U or A = L*L**T of the equilibrated
* matrix A (see the description of A for the form of the
* equilibrated matrix).
*
* LDAF (input) INTEGER
* The leading dimension of the array AF. LDAF >= max(1,N).
*
* EQUED (input or output) CHARACTER*1
* Specifies the form of equilibration that was done.
* = 'N': No equilibration (always true if FACT = 'N').
* = 'Y': Equilibration was done, i.e., A has been replaced by
* diag(S) * A * diag(S).
* EQUED is an input argument if FACT = 'F'; otherwise, it is an
* output argument.
*
* S (input or output) REAL array, dimension (N)
* The scale factors for A; not accessed if EQUED = 'N'. S is
* an input argument if FACT = 'F'; otherwise, S is an output
* argument. If FACT = 'F' and EQUED = 'Y', each element of S
* must be positive.
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the N-by-NRHS right hand side matrix B.
* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
* B is overwritten by diag(S) * B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (output) REAL array, dimension (LDX,NRHS)
* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
* the original system of equations. Note that if EQUED = 'Y',
* A and B are modified on exit, and the solution to the
* equilibrated system is inv(diag(S))*X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* RCOND (output) REAL
* The estimate of the reciprocal condition number of the matrix
* A after equilibration (if done). If RCOND is less than the
* machine precision (in particular, if RCOND = 0), the matrix
* is singular to working precision. This condition is
* indicated by a return code of INFO > 0.
*
* FERR (output) REAL array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) REAL array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, and i is
* <= N: the leading minor of order i of A is
* not positive definite, so the factorization
* could not be completed, and the solution has not
* been computed. RCOND = 0 is returned.
* = N+1: U is nonsingular, but RCOND is less than machine
* precision, meaning that the matrix is singular
* to working precision. Nevertheless, the
* solution and error bounds are computed because
* there are a number of situations where the
* computed solution can be more accurate than the
* value of RCOND would suggest.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL EQUIL, NOFACT, RCEQU
INTEGER I, INFEQU, J
REAL AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANSY
EXTERNAL LSAME, SLAMCH, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL SLACPY, SLAQSY, SPOCON, SPOEQU, SPORFS, SPOTRF,
$ SPOTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
NOFACT = LSAME( FACT, 'N' )
EQUIL = LSAME( FACT, 'E' )
IF( NOFACT .OR. EQUIL ) THEN
EQUED = 'N'
RCEQU = .FALSE.
ELSE
RCEQU = LSAME( EQUED, 'Y' )
SMLNUM = SLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
END IF
*
* Test the input parameters.
*
IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
$ THEN
INFO = -1
ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
$ THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
$ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
INFO = -9
ELSE
IF( RCEQU ) THEN
SMIN = BIGNUM
SMAX = ZERO
DO 10 J = 1, N
SMIN = MIN( SMIN, S( J ) )
SMAX = MAX( SMAX, S( J ) )
10 CONTINUE
IF( SMIN.LE.ZERO ) THEN
INFO = -10
ELSE IF( N.GT.0 ) THEN
SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
ELSE
SCOND = ONE
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -12
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -14
END IF
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPOSVX', -INFO )
RETURN
END IF
*
IF( EQUIL ) THEN
*
* Compute row and column scalings to equilibrate the matrix A.
*
CALL SPOEQU( N, A, LDA, S, SCOND, AMAX, INFEQU )
IF( INFEQU.EQ.0 ) THEN
*
* Equilibrate the matrix.
*
CALL SLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )
RCEQU = LSAME( EQUED, 'Y' )
END IF
END IF
*
* Scale the right hand side.
*
IF( RCEQU ) THEN
DO 30 J = 1, NRHS
DO 20 I = 1, N
B( I, J ) = S( I )*B( I, J )
20 CONTINUE
30 CONTINUE
END IF
*
IF( NOFACT .OR. EQUIL ) THEN
*
* Compute the Cholesky factorization A = U'*U or A = L*L'.
*
CALL SLACPY( UPLO, N, N, A, LDA, AF, LDAF )
CALL SPOTRF( UPLO, N, AF, LDAF, INFO )
*
* Return if INFO is non-zero.
*
IF( INFO.GT.0 )THEN
RCOND = ZERO
RETURN
END IF
END IF
*
* Compute the norm of the matrix A.
*
ANORM = SLANSY( '1', UPLO, N, A, LDA, WORK )
*
* Compute the reciprocal of the condition number of A.
*
CALL SPOCON( UPLO, N, AF, LDAF, ANORM, RCOND, WORK, IWORK, INFO )
*
* Compute the solution matrix X.
*
CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
CALL SPOTRS( UPLO, N, NRHS, AF, LDAF, X, LDX, INFO )
*
* Use iterative refinement to improve the computed solution and
* compute error bounds and backward error estimates for it.
*
CALL SPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX,
$ FERR, BERR, WORK, IWORK, INFO )
*
* Transform the solution matrix X to a solution of the original
* system.
*
IF( RCEQU ) THEN
DO 50 J = 1, NRHS
DO 40 I = 1, N
X( I, J ) = S( I )*X( I, J )
40 CONTINUE
50 CONTINUE
DO 60 J = 1, NRHS
FERR( J ) = FERR( J ) / SCOND
60 CONTINUE
END IF
*
* Set INFO = N+1 if the matrix is singular to working precision.
*
IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
$ INFO = N + 1
*
RETURN
*
* End of SPOSVX
*
END
SUBROUTINE SPOTF2( UPLO, N, A, LDA, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
REAL A( LDA, * )
* ..
*
* Purpose
* =======
*
* SPOTF2 computes the Cholesky factorization of a real symmetric
* positive definite matrix A.
*
* The factorization has the form
* A = U' * U , if UPLO = 'U', or
* A = L * L', if UPLO = 'L',
* where U is an upper triangular matrix and L is lower triangular.
*
* This is the unblocked version of the algorithm, calling Level 2 BLAS.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the symmetric matrix A. If UPLO = 'U', the leading
* n by n upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading n by n lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced.
*
* On exit, if INFO = 0, the factor U or L from the Cholesky
* factorization A = U'*U or A = L*L'.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
* > 0: if INFO = k, the leading minor of order k is not
* positive definite, and the factorization could not be
* completed.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J
REAL AJJ
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SDOT
EXTERNAL LSAME, SDOT
* ..
* .. External Subroutines ..
EXTERNAL SGEMV, SSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPOTF2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Compute the Cholesky factorization A = U'*U.
*
DO 10 J = 1, N
*
* Compute U(J,J) and test for non-positive-definiteness.
*
AJJ = A( J, J ) - SDOT( J-1, A( 1, J ), 1, A( 1, J ), 1 )
IF( AJJ.LE.ZERO ) THEN
A( J, J ) = AJJ
GO TO 30
END IF
AJJ = SQRT( AJJ )
A( J, J ) = AJJ
*
* Compute elements J+1:N of row J.
*
IF( J.LT.N ) THEN
CALL SGEMV( 'Transpose', J-1, N-J, -ONE, A( 1, J+1 ),
$ LDA, A( 1, J ), 1, ONE, A( J, J+1 ), LDA )
CALL SSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA )
END IF
10 CONTINUE
ELSE
*
* Compute the Cholesky factorization A = L*L'.
*
DO 20 J = 1, N
*
* Compute L(J,J) and test for non-positive-definiteness.
*
AJJ = A( J, J ) - SDOT( J-1, A( J, 1 ), LDA, A( J, 1 ),
$ LDA )
IF( AJJ.LE.ZERO ) THEN
A( J, J ) = AJJ
GO TO 30
END IF
AJJ = SQRT( AJJ )
A( J, J ) = AJJ
*
* Compute elements J+1:N of column J.
*
IF( J.LT.N ) THEN
CALL SGEMV( 'No transpose', N-J, J-1, -ONE, A( J+1, 1 ),
$ LDA, A( J, 1 ), LDA, ONE, A( J+1, J ), 1 )
CALL SSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 )
END IF
20 CONTINUE
END IF
GO TO 40
*
30 CONTINUE
INFO = J
*
40 CONTINUE
RETURN
*
* End of SPOTF2
*
END
SUBROUTINE SPOTRF( UPLO, N, A, LDA, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
REAL A( LDA, * )
* ..
*
* Purpose
* =======
*
* SPOTRF computes the Cholesky factorization of a real symmetric
* positive definite matrix A.
*
* The factorization has the form
* A = U**T * U, if UPLO = 'U', or
* A = L * L**T, if UPLO = 'L',
* where U is an upper triangular matrix and L is lower triangular.
*
* This is the block version of the algorithm, calling Level 3 BLAS.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the symmetric matrix A. If UPLO = 'U', the leading
* N-by-N upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading N-by-N lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced.
*
* On exit, if INFO = 0, the factor U or L from the Cholesky
* factorization A = U**T*U or A = L*L**T.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, the leading minor of order i is not
* positive definite, and the factorization could not be
* completed.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, JB, NB
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SPOTF2, SSYRK, STRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPOTRF', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Determine the block size for this environment.
*
NB = ILAENV( 1, 'SPOTRF', UPLO, N, -1, -1, -1 )
IF( NB.LE.1 .OR. NB.GE.N ) THEN
*
* Use unblocked code.
*
CALL SPOTF2( UPLO, N, A, LDA, INFO )
ELSE
*
* Use blocked code.
*
IF( UPPER ) THEN
*
* Compute the Cholesky factorization A = U'*U.
*
DO 10 J = 1, N, NB
*
* Update and factorize the current diagonal block and test
* for non-positive-definiteness.
*
JB = MIN( NB, N-J+1 )
CALL SSYRK( 'Upper', 'Transpose', JB, J-1, -ONE,
$ A( 1, J ), LDA, ONE, A( J, J ), LDA )
CALL SPOTF2( 'Upper', JB, A( J, J ), LDA, INFO )
IF( INFO.NE.0 )
$ GO TO 30
IF( J+JB.LE.N ) THEN
*
* Compute the current block row.
*
CALL SGEMM( 'Transpose', 'No transpose', JB, N-J-JB+1,
$ J-1, -ONE, A( 1, J ), LDA, A( 1, J+JB ),
$ LDA, ONE, A( J, J+JB ), LDA )
CALL STRSM( 'Left', 'Upper', 'Transpose', 'Non-unit',
$ JB, N-J-JB+1, ONE, A( J, J ), LDA,
$ A( J, J+JB ), LDA )
END IF
10 CONTINUE
*
ELSE
*
* Compute the Cholesky factorization A = L*L'.
*
DO 20 J = 1, N, NB
*
* Update and factorize the current diagonal block and test
* for non-positive-definiteness.
*
JB = MIN( NB, N-J+1 )
CALL SSYRK( 'Lower', 'No transpose', JB, J-1, -ONE,
$ A( J, 1 ), LDA, ONE, A( J, J ), LDA )
CALL SPOTF2( 'Lower', JB, A( J, J ), LDA, INFO )
IF( INFO.NE.0 )
$ GO TO 30
IF( J+JB.LE.N ) THEN
*
* Compute the current block column.
*
CALL SGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
$ J-1, -ONE, A( J+JB, 1 ), LDA, A( J, 1 ),
$ LDA, ONE, A( J+JB, J ), LDA )
CALL STRSM( 'Right', 'Lower', 'Transpose', 'Non-unit',
$ N-J-JB+1, JB, ONE, A( J, J ), LDA,
$ A( J+JB, J ), LDA )
END IF
20 CONTINUE
END IF
END IF
GO TO 40
*
30 CONTINUE
INFO = INFO + J - 1
*
40 CONTINUE
RETURN
*
* End of SPOTRF
*
END
SUBROUTINE SPOTRI( UPLO, N, A, LDA, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
REAL A( LDA, * )
* ..
*
* Purpose
* =======
*
* SPOTRI computes the inverse of a real symmetric positive definite
* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
* computed by SPOTRF.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the triangular factor U or L from the Cholesky
* factorization A = U**T*U or A = L*L**T, as computed by
* SPOTRF.
* On exit, the upper or lower triangle of the (symmetric)
* inverse of A, overwriting the input factor U or L.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, the (i,i) element of the factor U or L is
* zero, and the inverse could not be computed.
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SLAUUM, STRTRI, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPOTRI', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Invert the triangular Cholesky factor U or L.
*
CALL STRTRI( UPLO, 'Non-unit', N, A, LDA, INFO )
IF( INFO.GT.0 )
$ RETURN
*
* Form inv(U)*inv(U)' or inv(L)'*inv(L).
*
CALL SLAUUM( UPLO, N, A, LDA, INFO )
*
RETURN
*
* End of SPOTRI
*
END
SUBROUTINE SPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* SPOTRS solves a system of linear equations A*X = B with a symmetric
* positive definite matrix A using the Cholesky factorization
* A = U**T*U or A = L*L**T computed by SPOTRF.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* 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) REAL array, dimension (LDA,N)
* The triangular factor U or L from the Cholesky factorization
* A = U**T*U or A = L*L**T, as computed by SPOTRF.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input/output) REAL 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 ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL STRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) 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 = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPOTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Solve A*X = B where A = U'*U.
*
* Solve U'*X = B, overwriting B with X.
*
CALL STRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS,
$ ONE, A, LDA, B, LDB )
*
* Solve U*X = B, overwriting B with X.
*
CALL STRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N,
$ NRHS, ONE, A, LDA, B, LDB )
ELSE
*
* Solve A*X = B where A = L*L'.
*
* Solve L*X = B, overwriting B with X.
*
CALL STRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', N,
$ NRHS, ONE, A, LDA, B, LDB )
*
* Solve L'*X = B, overwriting B with X.
*
CALL STRSM( 'Left', 'Lower', 'Transpose', 'Non-unit', N, NRHS,
$ ONE, A, LDA, B, LDB )
END IF
*
RETURN
*
* End of SPOTRS
*
END
SUBROUTINE SPPCON( UPLO, N, AP, ANORM, RCOND, WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, N
REAL ANORM, RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL AP( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SPPCON estimates the reciprocal of the condition number (in the
* 1-norm) of a real symmetric positive definite packed matrix using
* the Cholesky factorization A = U**T*U or A = L*L**T computed by
* SPPTRF.
*
* An estimate is obtained for norm(inv(A)), and the reciprocal of the
* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input) REAL array, dimension (N*(N+1)/2)
* The triangular factor U or L from the Cholesky factorization
* A = U**T*U or A = L*L**T, packed columnwise in a linear
* array. The j-th column of U or L is stored in the array AP
* as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
*
* ANORM (input) REAL
* The 1-norm (or infinity-norm) of the symmetric matrix A.
*
* RCOND (output) REAL
* The reciprocal of the condition number of the matrix A,
* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
* estimate of the 1-norm of inv(A) computed in this routine.
*
* WORK (workspace) REAL array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
CHARACTER NORMIN
INTEGER IX, KASE
REAL AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SLAMCH
EXTERNAL LSAME, ISAMAX, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SLACN2, SLATPS, SRSCL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ANORM.LT.ZERO ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPPCON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
RCOND = ZERO
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
ELSE IF( ANORM.EQ.ZERO ) THEN
RETURN
END IF
*
SMLNUM = SLAMCH( 'Safe minimum' )
*
* Estimate the 1-norm of the inverse.
*
KASE = 0
NORMIN = 'N'
10 CONTINUE
CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( UPPER ) THEN
*
* Multiply by inv(U').
*
CALL SLATPS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N,
$ AP, WORK, SCALEL, WORK( 2*N+1 ), INFO )
NORMIN = 'Y'
*
* Multiply by inv(U).
*
CALL SLATPS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
$ AP, WORK, SCALEU, WORK( 2*N+1 ), INFO )
ELSE
*
* Multiply by inv(L).
*
CALL SLATPS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N,
$ AP, WORK, SCALEL, WORK( 2*N+1 ), INFO )
NORMIN = 'Y'
*
* Multiply by inv(L').
*
CALL SLATPS( 'Lower', 'Transpose', 'Non-unit', NORMIN, N,
$ AP, WORK, SCALEU, WORK( 2*N+1 ), INFO )
END IF
*
* Multiply by 1/SCALE if doing so will not cause overflow.
*
SCALE = SCALEL*SCALEU
IF( SCALE.NE.ONE ) THEN
IX = ISAMAX( N, WORK, 1 )
IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
$ GO TO 20
CALL SRSCL( N, SCALE, WORK, 1 )
END IF
GO TO 10
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / AINVNM ) / ANORM
*
20 CONTINUE
RETURN
*
* End of SPPCON
*
END
SUBROUTINE SPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, N
REAL AMAX, SCOND
* ..
* .. Array Arguments ..
REAL AP( * ), S( * )
* ..
*
* Purpose
* =======
*
* SPPEQU computes row and column scalings intended to equilibrate a
* symmetric positive definite matrix A in packed storage and reduce
* its condition number (with respect to the two-norm). S contains the
* scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix
* B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.
* This choice of S puts the condition number of B within a factor N of
* the smallest possible condition number over all possible diagonal
* scalings.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input) REAL array, dimension (N*(N+1)/2)
* The upper or lower triangle of the symmetric matrix A, packed
* columnwise in a linear array. The j-th column of A is stored
* in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
*
* S (output) REAL array, dimension (N)
* If INFO = 0, S contains the scale factors for A.
*
* SCOND (output) REAL
* If INFO = 0, S contains the ratio of the smallest S(i) to
* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
* large nor too small, it is not worth scaling by S.
*
* AMAX (output) REAL
* Absolute value of largest matrix element. If AMAX is very
* close to overflow or very close to underflow, the matrix
* should be scaled.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, the i-th diagonal element is nonpositive.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, JJ
REAL SMIN
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPPEQU', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
SCOND = ONE
AMAX = ZERO
RETURN
END IF
*
* Initialize SMIN and AMAX.
*
S( 1 ) = AP( 1 )
SMIN = S( 1 )
AMAX = S( 1 )
*
IF( UPPER ) THEN
*
* UPLO = 'U': Upper triangle of A is stored.
* Find the minimum and maximum diagonal elements.
*
JJ = 1
DO 10 I = 2, N
JJ = JJ + I
S( I ) = AP( JJ )
SMIN = MIN( SMIN, S( I ) )
AMAX = MAX( AMAX, S( I ) )
10 CONTINUE
*
ELSE
*
* UPLO = 'L': Lower triangle of A is stored.
* Find the minimum and maximum diagonal elements.
*
JJ = 1
DO 20 I = 2, N
JJ = JJ + N - I + 2
S( I ) = AP( JJ )
SMIN = MIN( SMIN, S( I ) )
AMAX = MAX( AMAX, S( I ) )
20 CONTINUE
END IF
*
IF( SMIN.LE.ZERO ) THEN
*
* Find the first non-positive diagonal element and return.
*
DO 30 I = 1, N
IF( S( I ).LE.ZERO ) THEN
INFO = I
RETURN
END IF
30 CONTINUE
ELSE
*
* Set the scale factors to the reciprocals
* of the diagonal elements.
*
DO 40 I = 1, N
S( I ) = ONE / SQRT( S( I ) )
40 CONTINUE
*
* Compute SCOND = min(S(I)) / max(S(I))
*
SCOND = SQRT( SMIN ) / SQRT( AMAX )
END IF
RETURN
*
* End of SPPEQU
*
END
SUBROUTINE SPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR,
$ BERR, WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL AFP( * ), AP( * ), B( LDB, * ), BERR( * ),
$ FERR( * ), WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* SPPRFS improves the computed solution to a system of linear
* equations when the coefficient matrix is symmetric positive definite
* and packed, and provides error bounds and backward error estimates
* for the solution.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* 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 matrices B and X. NRHS >= 0.
*
* AP (input) REAL array, dimension (N*(N+1)/2)
* The upper or lower triangle of the symmetric matrix A, packed
* columnwise in a linear array. The j-th column of A is stored
* in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
*
* AFP (input) REAL array, dimension (N*(N+1)/2)
* The triangular factor U or L from the Cholesky factorization
* A = U**T*U or A = L*L**T, as computed by SPPTRF/CPPTRF,
* packed columnwise in a linear array in the same format as A
* (see AP).
*
* B (input) REAL array, dimension (LDB,NRHS)
* The right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input/output) REAL array, dimension (LDX,NRHS)
* On entry, the solution matrix X, as computed by SPPTRS.
* On exit, the improved solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* FERR (output) REAL array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) REAL array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Internal Parameters
* ===================
*
* ITMAX is the maximum number of steps of iterative refinement.
*
* =====================================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 5 )
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
REAL TWO
PARAMETER ( TWO = 2.0E+0 )
REAL THREE
PARAMETER ( THREE = 3.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER COUNT, I, IK, J, K, KASE, KK, NZ
REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, SLACN2, SPPTRS, SSPMV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH
EXTERNAL LSAME, SLAMCH
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPPRFS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
DO 10 J = 1, NRHS
FERR( J ) = ZERO
BERR( J ) = ZERO
10 CONTINUE
RETURN
END IF
*
* NZ = maximum number of nonzero elements in each row of A, plus 1
*
NZ = N + 1
EPS = SLAMCH( 'Epsilon' )
SAFMIN = SLAMCH( 'Safe minimum' )
SAFE1 = NZ*SAFMIN
SAFE2 = SAFE1 / EPS
*
* Do for each right hand side
*
DO 140 J = 1, NRHS
*
COUNT = 1
LSTRES = THREE
20 CONTINUE
*
* Loop until stopping criterion is satisfied.
*
* Compute residual R = B - A * X
*
CALL SCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
CALL SSPMV( UPLO, N, -ONE, AP, X( 1, J ), 1, ONE, WORK( N+1 ),
$ 1 )
*
* Compute componentwise relative backward error from formula
*
* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
*
* where abs(Z) is the componentwise absolute value of the matrix
* or vector Z. If the i-th component of the denominator is less
* than SAFE2, then SAFE1 is added to the i-th components of the
* numerator and denominator before dividing.
*
DO 30 I = 1, N
WORK( I ) = ABS( B( I, J ) )
30 CONTINUE
*
* Compute abs(A)*abs(X) + abs(B).
*
KK = 1
IF( UPPER ) THEN
DO 50 K = 1, N
S = ZERO
XK = ABS( X( K, J ) )
IK = KK
DO 40 I = 1, K - 1
WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK
S = S + ABS( AP( IK ) )*ABS( X( I, J ) )
IK = IK + 1
40 CONTINUE
WORK( K ) = WORK( K ) + ABS( AP( KK+K-1 ) )*XK + S
KK = KK + K
50 CONTINUE
ELSE
DO 70 K = 1, N
S = ZERO
XK = ABS( X( K, J ) )
WORK( K ) = WORK( K ) + ABS( AP( KK ) )*XK
IK = KK + 1
DO 60 I = K + 1, N
WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK
S = S + ABS( AP( IK ) )*ABS( X( I, J ) )
IK = IK + 1
60 CONTINUE
WORK( K ) = WORK( K ) + S
KK = KK + ( N-K+1 )
70 CONTINUE
END IF
S = ZERO
DO 80 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
ELSE
S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
$ ( WORK( I )+SAFE1 ) )
END IF
80 CONTINUE
BERR( J ) = S
*
* Test stopping criterion. Continue iterating if
* 1) The residual BERR(J) is larger than machine epsilon, and
* 2) BERR(J) decreased by at least a factor of 2 during the
* last iteration, and
* 3) At most ITMAX iterations tried.
*
IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
$ COUNT.LE.ITMAX ) THEN
*
* Update solution and try again.
*
CALL SPPTRS( UPLO, N, 1, AFP, WORK( N+1 ), N, INFO )
CALL SAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
LSTRES = BERR( J )
COUNT = COUNT + 1
GO TO 20
END IF
*
* Bound error from formula
*
* norm(X - XTRUE) / norm(X) .le. FERR =
* norm( abs(inv(A))*
* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
*
* where
* norm(Z) is the magnitude of the largest component of Z
* inv(A) is the inverse of A
* abs(Z) is the componentwise absolute value of the matrix or
* vector Z
* NZ is the maximum number of nonzeros in any row of A, plus 1
* EPS is machine epsilon
*
* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
* is incremented by SAFE1 if the i-th component of
* abs(A)*abs(X) + abs(B) is less than SAFE2.
*
* Use SLACN2 to estimate the infinity-norm of the matrix
* inv(A) * diag(W),
* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
*
DO 90 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
ELSE
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
END IF
90 CONTINUE
*
KASE = 0
100 CONTINUE
CALL SLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
$ KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Multiply by diag(W)*inv(A').
*
CALL SPPTRS( UPLO, N, 1, AFP, WORK( N+1 ), N, INFO )
DO 110 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
110 CONTINUE
ELSE IF( KASE.EQ.2 ) THEN
*
* Multiply by inv(A)*diag(W).
*
DO 120 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
120 CONTINUE
CALL SPPTRS( UPLO, N, 1, AFP, WORK( N+1 ), N, INFO )
END IF
GO TO 100
END IF
*
* Normalize error.
*
LSTRES = ZERO
DO 130 I = 1, N
LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
130 CONTINUE
IF( LSTRES.NE.ZERO )
$ FERR( J ) = FERR( J ) / LSTRES
*
140 CONTINUE
*
RETURN
*
* End of SPPRFS
*
END
SUBROUTINE SPPSV( UPLO, N, NRHS, AP, B, LDB, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
REAL AP( * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* SPPSV computes the solution to a real system of linear equations
* A * X = B,
* where A is an N-by-N symmetric positive definite matrix stored in
* packed format and X and B are N-by-NRHS matrices.
*
* The Cholesky decomposition is used to factor A as
* A = U**T* U, if UPLO = 'U', or
* A = L * L**T, if UPLO = 'L',
* where U is an upper triangular matrix and L is a lower triangular
* matrix. The factored form of A is then used to solve the system of
* equations A * X = B.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The number of linear equations, i.e., 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.
*
* AP (input/output) REAL array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* A, packed columnwise in a linear array. The j-th column of A
* is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
* See below for further details.
*
* On exit, if INFO = 0, the factor U or L from the Cholesky
* factorization A = U**T*U or A = L*L**T, in the same storage
* format as A.
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the N-by-NRHS right hand side matrix B.
* On exit, if INFO = 0, the N-by-NRHS 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
* > 0: if INFO = i, the leading minor of order i of A is not
* positive definite, so the factorization could not be
* completed, and the solution has not been computed.
*
* Further Details
* ===============
*
* The packed storage scheme is illustrated by the following example
* when N = 4, UPLO = 'U':
*
* Two-dimensional storage of the symmetric matrix A:
*
* a11 a12 a13 a14
* a22 a23 a24
* a33 a34 (aij = conjg(aji))
* a44
*
* Packed storage of the upper triangle of A:
*
* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SPPTRF, SPPTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPPSV ', -INFO )
RETURN
END IF
*
* Compute the Cholesky factorization A = U'*U or A = L*L'.
*
CALL SPPTRF( UPLO, N, AP, INFO )
IF( INFO.EQ.0 ) THEN
*
* Solve the system A*X = B, overwriting B with X.
*
CALL SPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )
*
END IF
RETURN
*
* End of SPPSV
*
END
SUBROUTINE SPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB,
$ X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER EQUED, FACT, UPLO
INTEGER INFO, LDB, LDX, N, NRHS
REAL RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL AFP( * ), AP( * ), B( LDB, * ), BERR( * ),
$ FERR( * ), S( * ), WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* SPPSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to
* compute the solution to a real system of linear equations
* A * X = B,
* where A is an N-by-N symmetric positive definite matrix stored in
* packed format and X and B are N-by-NRHS matrices.
*
* Error bounds on the solution and a condition estimate are also
* provided.
*
* Description
* ===========
*
* The following steps are performed:
*
* 1. If FACT = 'E', real scaling factors are computed to equilibrate
* the system:
* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
* Whether or not the system will be equilibrated depends on the
* scaling of the matrix A, but if equilibration is used, A is
* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
*
* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
* factor the matrix A (after equilibration if FACT = 'E') as
* A = U**T* U, if UPLO = 'U', or
* A = L * L**T, if UPLO = 'L',
* where U is an upper triangular matrix and L is a lower triangular
* matrix.
*
* 3. If the leading i-by-i principal minor is not positive definite,
* then the routine returns with INFO = i. Otherwise, the factored
* form of A is used to estimate the condition number of the matrix
* A. If the reciprocal of the condition number is less than machine
* precision, INFO = N+1 is returned as a warning, but the routine
* still goes on to solve for X and compute error bounds as
* described below.
*
* 4. The system of equations is solved for X using the factored form
* of A.
*
* 5. Iterative refinement is applied to improve the computed solution
* matrix and calculate error bounds and backward error estimates
* for it.
*
* 6. If equilibration was used, the matrix X is premultiplied by
* diag(S) so that it solves the original system before
* equilibration.
*
* Arguments
* =========
*
* FACT (input) CHARACTER*1
* Specifies whether or not the factored form of the matrix A is
* supplied on entry, and if not, whether the matrix A should be
* equilibrated before it is factored.
* = 'F': On entry, AFP contains the factored form of A.
* If EQUED = 'Y', the matrix A has been equilibrated
* with scaling factors given by S. AP and AFP will not
* be modified.
* = 'N': The matrix A will be copied to AFP and factored.
* = 'E': The matrix A will be equilibrated if necessary, then
* copied to AFP and factored.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The number of linear equations, i.e., 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 matrices B and X. NRHS >= 0.
*
* AP (input/output) REAL array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* A, packed columnwise in a linear array, except if FACT = 'F'
* and EQUED = 'Y', then A must contain the equilibrated matrix
* diag(S)*A*diag(S). The j-th column of A is stored in the
* array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
* See below for further details. A is not modified if
* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
*
* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
* diag(S)*A*diag(S).
*
* AFP (input or output) REAL array, dimension
* (N*(N+1)/2)
* If FACT = 'F', then AFP is an input argument and on entry
* contains the triangular factor U or L from the Cholesky
* factorization A = U'*U or A = L*L', in the same storage
* format as A. If EQUED .ne. 'N', then AFP is the factored
* form of the equilibrated matrix A.
*
* If FACT = 'N', then AFP is an output argument and on exit
* returns the triangular factor U or L from the Cholesky
* factorization A = U'*U or A = L*L' of the original matrix A.
*
* If FACT = 'E', then AFP is an output argument and on exit
* returns the triangular factor U or L from the Cholesky
* factorization A = U'*U or A = L*L' of the equilibrated
* matrix A (see the description of AP for the form of the
* equilibrated matrix).
*
* EQUED (input or output) CHARACTER*1
* Specifies the form of equilibration that was done.
* = 'N': No equilibration (always true if FACT = 'N').
* = 'Y': Equilibration was done, i.e., A has been replaced by
* diag(S) * A * diag(S).
* EQUED is an input argument if FACT = 'F'; otherwise, it is an
* output argument.
*
* S (input or output) REAL array, dimension (N)
* The scale factors for A; not accessed if EQUED = 'N'. S is
* an input argument if FACT = 'F'; otherwise, S is an output
* argument. If FACT = 'F' and EQUED = 'Y', each element of S
* must be positive.
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the N-by-NRHS right hand side matrix B.
* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
* B is overwritten by diag(S) * B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (output) REAL array, dimension (LDX,NRHS)
* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
* the original system of equations. Note that if EQUED = 'Y',
* A and B are modified on exit, and the solution to the
* equilibrated system is inv(diag(S))*X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* RCOND (output) REAL
* The estimate of the reciprocal condition number of the matrix
* A after equilibration (if done). If RCOND is less than the
* machine precision (in particular, if RCOND = 0), the matrix
* is singular to working precision. This condition is
* indicated by a return code of INFO > 0.
*
* FERR (output) REAL array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) REAL array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, and i is
* <= N: the leading minor of order i of A is
* not positive definite, so the factorization
* could not be completed, and the solution has not
* been computed. RCOND = 0 is returned.
* = N+1: U is nonsingular, but RCOND is less than machine
* precision, meaning that the matrix is singular
* to working precision. Nevertheless, the
* solution and error bounds are computed because
* there are a number of situations where the
* computed solution can be more accurate than the
* value of RCOND would suggest.
*
* Further Details
* ===============
*
* The packed storage scheme is illustrated by the following example
* when N = 4, UPLO = 'U':
*
* Two-dimensional storage of the symmetric matrix A:
*
* a11 a12 a13 a14
* a22 a23 a24
* a33 a34 (aij = conjg(aji))
* a44
*
* Packed storage of the upper triangle of A:
*
* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL EQUIL, NOFACT, RCEQU
INTEGER I, INFEQU, J
REAL AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANSP
EXTERNAL LSAME, SLAMCH, SLANSP
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLACPY, SLAQSP, SPPCON, SPPEQU, SPPRFS,
$ SPPTRF, SPPTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
NOFACT = LSAME( FACT, 'N' )
EQUIL = LSAME( FACT, 'E' )
IF( NOFACT .OR. EQUIL ) THEN
EQUED = 'N'
RCEQU = .FALSE.
ELSE
RCEQU = LSAME( EQUED, 'Y' )
SMLNUM = SLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
END IF
*
* Test the input parameters.
*
IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
$ THEN
INFO = -1
ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
$ THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.0 ) THEN
INFO = -4
ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
$ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
INFO = -7
ELSE
IF( RCEQU ) THEN
SMIN = BIGNUM
SMAX = ZERO
DO 10 J = 1, N
SMIN = MIN( SMIN, S( J ) )
SMAX = MAX( SMAX, S( J ) )
10 CONTINUE
IF( SMIN.LE.ZERO ) THEN
INFO = -8
ELSE IF( N.GT.0 ) THEN
SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
ELSE
SCOND = ONE
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -10
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -12
END IF
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPPSVX', -INFO )
RETURN
END IF
*
IF( EQUIL ) THEN
*
* Compute row and column scalings to equilibrate the matrix A.
*
CALL SPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFEQU )
IF( INFEQU.EQ.0 ) THEN
*
* Equilibrate the matrix.
*
CALL SLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )
RCEQU = LSAME( EQUED, 'Y' )
END IF
END IF
*
* Scale the right-hand side.
*
IF( RCEQU ) THEN
DO 30 J = 1, NRHS
DO 20 I = 1, N
B( I, J ) = S( I )*B( I, J )
20 CONTINUE
30 CONTINUE
END IF
*
IF( NOFACT .OR. EQUIL ) THEN
*
* Compute the Cholesky factorization A = U'*U or A = L*L'.
*
CALL SCOPY( N*( N+1 ) / 2, AP, 1, AFP, 1 )
CALL SPPTRF( UPLO, N, AFP, INFO )
*
* Return if INFO is non-zero.
*
IF( INFO.GT.0 )THEN
RCOND = ZERO
RETURN
END IF
END IF
*
* Compute the norm of the matrix A.
*
ANORM = SLANSP( 'I', UPLO, N, AP, WORK )
*
* Compute the reciprocal of the condition number of A.
*
CALL SPPCON( UPLO, N, AFP, ANORM, RCOND, WORK, IWORK, INFO )
*
* Compute the solution matrix X.
*
CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
CALL SPPTRS( UPLO, N, NRHS, AFP, X, LDX, INFO )
*
* Use iterative refinement to improve the computed solution and
* compute error bounds and backward error estimates for it.
*
CALL SPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR,
$ WORK, IWORK, INFO )
*
* Transform the solution matrix X to a solution of the original
* system.
*
IF( RCEQU ) THEN
DO 50 J = 1, NRHS
DO 40 I = 1, N
X( I, J ) = S( I )*X( I, J )
40 CONTINUE
50 CONTINUE
DO 60 J = 1, NRHS
FERR( J ) = FERR( J ) / SCOND
60 CONTINUE
END IF
*
* Set INFO = N+1 if the matrix is singular to working precision.
*
IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
$ INFO = N + 1
*
RETURN
*
* End of SPPSVX
*
END
SUBROUTINE SPPTRF( UPLO, N, AP, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, N
* ..
* .. Array Arguments ..
REAL AP( * )
* ..
*
* Purpose
* =======
*
* SPPTRF computes the Cholesky factorization of a real symmetric
* positive definite matrix A stored in packed format.
*
* The factorization has the form
* A = U**T * U, if UPLO = 'U', or
* A = L * L**T, if UPLO = 'L',
* where U is an upper triangular matrix and L is lower triangular.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input/output) REAL array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* A, packed columnwise in a linear array. The j-th column of A
* is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
* See below for further details.
*
* On exit, if INFO = 0, the triangular factor U or L from the
* Cholesky factorization A = U**T*U or A = L*L**T, in the same
* storage format as A.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, the leading minor of order i is not
* positive definite, and the factorization could not be
* completed.
*
* Further Details
* ======= =======
*
* The packed storage scheme is illustrated by the following example
* when N = 4, UPLO = 'U':
*
* Two-dimensional storage of the symmetric matrix A:
*
* a11 a12 a13 a14
* a22 a23 a24
* a33 a34 (aij = aji)
* a44
*
* Packed storage of the upper triangle of A:
*
* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, JC, JJ
REAL AJJ
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SDOT
EXTERNAL LSAME, SDOT
* ..
* .. External Subroutines ..
EXTERNAL SSCAL, SSPR, STPSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPPTRF', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Compute the Cholesky factorization A = U'*U.
*
JJ = 0
DO 10 J = 1, N
JC = JJ + 1
JJ = JJ + J
*
* Compute elements 1:J-1 of column J.
*
IF( J.GT.1 )
$ CALL STPSV( 'Upper', 'Transpose', 'Non-unit', J-1, AP,
$ AP( JC ), 1 )
*
* Compute U(J,J) and test for non-positive-definiteness.
*
AJJ = AP( JJ ) - SDOT( J-1, AP( JC ), 1, AP( JC ), 1 )
IF( AJJ.LE.ZERO ) THEN
AP( JJ ) = AJJ
GO TO 30
END IF
AP( JJ ) = SQRT( AJJ )
10 CONTINUE
ELSE
*
* Compute the Cholesky factorization A = L*L'.
*
JJ = 1
DO 20 J = 1, N
*
* Compute L(J,J) and test for non-positive-definiteness.
*
AJJ = AP( JJ )
IF( AJJ.LE.ZERO ) THEN
AP( JJ ) = AJJ
GO TO 30
END IF
AJJ = SQRT( AJJ )
AP( JJ ) = AJJ
*
* Compute elements J+1:N of column J and update the trailing
* submatrix.
*
IF( J.LT.N ) THEN
CALL SSCAL( N-J, ONE / AJJ, AP( JJ+1 ), 1 )
CALL SSPR( 'Lower', N-J, -ONE, AP( JJ+1 ), 1,
$ AP( JJ+N-J+1 ) )
JJ = JJ + N - J + 1
END IF
20 CONTINUE
END IF
GO TO 40
*
30 CONTINUE
INFO = J
*
40 CONTINUE
RETURN
*
* End of SPPTRF
*
END
SUBROUTINE SPPTRI( UPLO, N, AP, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, N
* ..
* .. Array Arguments ..
REAL AP( * )
* ..
*
* Purpose
* =======
*
* SPPTRI computes the inverse of a real symmetric positive definite
* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
* computed by SPPTRF.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangular factor is stored in AP;
* = 'L': Lower triangular factor is stored in AP.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input/output) REAL array, dimension (N*(N+1)/2)
* On entry, the triangular factor U or L from the Cholesky
* factorization A = U**T*U or A = L*L**T, packed columnwise as
* a linear array. The j-th column of U or L is stored in the
* array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
*
* On exit, the upper or lower triangle of the (symmetric)
* inverse of A, overwriting the input factor U or L.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, the (i,i) element of the factor U or L is
* zero, and the inverse could not be computed.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, JC, JJ, JJN
REAL AJJ
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SDOT
EXTERNAL LSAME, SDOT
* ..
* .. External Subroutines ..
EXTERNAL SSCAL, SSPR, STPMV, STPTRI, XERBLA
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPPTRI', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Invert the triangular Cholesky factor U or L.
*
CALL STPTRI( UPLO, 'Non-unit', N, AP, INFO )
IF( INFO.GT.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Compute the product inv(U) * inv(U)'.
*
JJ = 0
DO 10 J = 1, N
JC = JJ + 1
JJ = JJ + J
IF( J.GT.1 )
$ CALL SSPR( 'Upper', J-1, ONE, AP( JC ), 1, AP )
AJJ = AP( JJ )
CALL SSCAL( J, AJJ, AP( JC ), 1 )
10 CONTINUE
*
ELSE
*
* Compute the product inv(L)' * inv(L).
*
JJ = 1
DO 20 J = 1, N
JJN = JJ + N - J + 1
AP( JJ ) = SDOT( N-J+1, AP( JJ ), 1, AP( JJ ), 1 )
IF( J.LT.N )
$ CALL STPMV( 'Lower', 'Transpose', 'Non-unit', N-J,
$ AP( JJN ), AP( JJ+1 ), 1 )
JJ = JJN
20 CONTINUE
END IF
*
RETURN
*
* End of SPPTRI
*
END
SUBROUTINE SPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
REAL AP( * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* SPPTRS solves a system of linear equations A*X = B with a symmetric
* positive definite matrix A in packed storage using the Cholesky
* factorization A = U**T*U or A = L*L**T computed by SPPTRF.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* 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.
*
* AP (input) REAL array, dimension (N*(N+1)/2)
* The triangular factor U or L from the Cholesky factorization
* A = U**T*U or A = L*L**T, packed columnwise in a linear
* array. The j-th column of U or L is stored in the array AP
* as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
*
* B (input/output) REAL 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
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL STPSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPPTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Solve A*X = B where A = U'*U.
*
DO 10 I = 1, NRHS
*
* Solve U'*X = B, overwriting B with X.
*
CALL STPSV( 'Upper', 'Transpose', 'Non-unit', N, AP,
$ B( 1, I ), 1 )
*
* Solve U*X = B, overwriting B with X.
*
CALL STPSV( 'Upper', 'No transpose', 'Non-unit', N, AP,
$ B( 1, I ), 1 )
10 CONTINUE
ELSE
*
* Solve A*X = B where A = L*L'.
*
DO 20 I = 1, NRHS
*
* Solve L*Y = B, overwriting B with X.
*
CALL STPSV( 'Lower', 'No transpose', 'Non-unit', N, AP,
$ B( 1, I ), 1 )
*
* Solve L'*X = Y, overwriting B with X.
*
CALL STPSV( 'Lower', 'Transpose', 'Non-unit', N, AP,
$ B( 1, I ), 1 )
20 CONTINUE
END IF
*
RETURN
*
* End of SPPTRS
*
END
SUBROUTINE SPTCON( N, D, E, ANORM, RCOND, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, N
REAL ANORM, RCOND
* ..
* .. Array Arguments ..
REAL D( * ), E( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SPTCON computes the reciprocal of the condition number (in the
* 1-norm) of a real symmetric positive definite tridiagonal matrix
* using the factorization A = L*D*L**T or A = U**T*D*U computed by
* SPTTRF.
*
* Norm(inv(A)) is computed by a direct method, and the reciprocal of
* the condition number is computed as
* RCOND = 1 / (ANORM * norm(inv(A))).
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* D (input) REAL array, dimension (N)
* The n diagonal elements of the diagonal matrix D from the
* factorization of A, as computed by SPTTRF.
*
* E (input) REAL array, dimension (N-1)
* The (n-1) off-diagonal elements of the unit bidiagonal factor
* U or L from the factorization of A, as computed by SPTTRF.
*
* ANORM (input) REAL
* The 1-norm of the original matrix A.
*
* RCOND (output) REAL
* The reciprocal of the condition number of the matrix A,
* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the
* 1-norm of inv(A) computed in this routine.
*
* WORK (workspace) REAL array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Further Details
* ===============
*
* The method used is described in Nicholas J. Higham, "Efficient
* Algorithms for Computing the Condition Number of a Tridiagonal
* Matrix", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, IX
REAL AINVNM
* ..
* .. External Functions ..
INTEGER ISAMAX
EXTERNAL ISAMAX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
* Test the input arguments.
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( ANORM.LT.ZERO ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPTCON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
RCOND = ZERO
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
ELSE IF( ANORM.EQ.ZERO ) THEN
RETURN
END IF
*
* Check that D(1:N) is positive.
*
DO 10 I = 1, N
IF( D( I ).LE.ZERO )
$ RETURN
10 CONTINUE
*
* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by
*
* m(i,j) = abs(A(i,j)), i = j,
* m(i,j) = -abs(A(i,j)), i .ne. j,
*
* and e = [ 1, 1, ..., 1 ]'. Note M(A) = M(L)*D*M(L)'.
*
* Solve M(L) * x = e.
*
WORK( 1 ) = ONE
DO 20 I = 2, N
WORK( I ) = ONE + WORK( I-1 )*ABS( E( I-1 ) )
20 CONTINUE
*
* Solve D * M(L)' * x = b.
*
WORK( N ) = WORK( N ) / D( N )
DO 30 I = N - 1, 1, -1
WORK( I ) = WORK( I ) / D( I ) + WORK( I+1 )*ABS( E( I ) )
30 CONTINUE
*
* Compute AINVNM = max(x(i)), 1<=i<=n.
*
IX = ISAMAX( N, WORK, 1 )
AINVNM = ABS( WORK( IX ) )
*
* Compute the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / AINVNM ) / ANORM
*
RETURN
*
* End of SPTCON
*
END
SUBROUTINE SPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER COMPZ
INTEGER INFO, LDZ, N
* ..
* .. Array Arguments ..
REAL D( * ), E( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SPTEQR computes all eigenvalues and, optionally, eigenvectors of a
* symmetric positive definite tridiagonal matrix by first factoring the
* matrix using SPTTRF, and then calling SBDSQR to compute the singular
* values of the bidiagonal factor.
*
* This routine computes the eigenvalues of the positive definite
* tridiagonal matrix to high relative accuracy. This means that if the
* eigenvalues range over many orders of magnitude in size, then the
* small eigenvalues and corresponding eigenvectors will be computed
* more accurately than, for example, with the standard QR method.
*
* The eigenvectors of a full or band symmetric positive definite matrix
* can also be found if SSYTRD, SSPTRD, or SSBTRD has been used to
* reduce this matrix to tridiagonal form. (The reduction to tridiagonal
* form, however, may preclude the possibility of obtaining high
* relative accuracy in the small eigenvalues of the original matrix, if
* these eigenvalues range over many orders of magnitude.)
*
* Arguments
* =========
*
* COMPZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only.
* = 'V': Compute eigenvectors of original symmetric
* matrix also. Array Z contains the orthogonal
* matrix used to reduce the original matrix to
* tridiagonal form.
* = 'I': Compute eigenvectors of tridiagonal matrix also.
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) REAL array, dimension (N)
* On entry, the n diagonal elements of the tridiagonal
* matrix.
* On normal exit, D contains the eigenvalues, in descending
* order.
*
* E (input/output) REAL array, dimension (N-1)
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix.
* On exit, E has been destroyed.
*
* Z (input/output) REAL array, dimension (LDZ, N)
* On entry, if COMPZ = 'V', the orthogonal matrix used in the
* reduction to tridiagonal form.
* On exit, if COMPZ = 'V', the orthonormal eigenvectors of the
* original symmetric matrix;
* if COMPZ = 'I', the orthonormal eigenvectors of the
* tridiagonal matrix.
* If INFO > 0 on exit, Z contains the eigenvectors associated
* with only the stored eigenvalues.
* If COMPZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* COMPZ = 'V' or 'I', LDZ >= max(1,N).
*
* WORK (workspace) REAL array, dimension (4*N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = i, and i is:
* <= N the Cholesky factorization of the matrix could
* not be performed because the i-th principal minor
* was not positive definite.
* > N the SVD algorithm failed to converge;
* if INFO = N+i, i off-diagonal elements of the
* bidiagonal factor did not converge to zero.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SBDSQR, SLASET, SPTTRF, XERBLA
* ..
* .. Local Arrays ..
REAL C( 1, 1 ), VT( 1, 1 )
* ..
* .. Local Scalars ..
INTEGER I, ICOMPZ, NRU
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( LSAME( COMPZ, 'N' ) ) THEN
ICOMPZ = 0
ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
ICOMPZ = 1
ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
ICOMPZ = 2
ELSE
ICOMPZ = -1
END IF
IF( ICOMPZ.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
$ N ) ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPTEQR', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( ICOMPZ.GT.0 )
$ Z( 1, 1 ) = ONE
RETURN
END IF
IF( ICOMPZ.EQ.2 )
$ CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
*
* Call SPTTRF to factor the matrix.
*
CALL SPTTRF( N, D, E, INFO )
IF( INFO.NE.0 )
$ RETURN
DO 10 I = 1, N
D( I ) = SQRT( D( I ) )
10 CONTINUE
DO 20 I = 1, N - 1
E( I ) = E( I )*D( I )
20 CONTINUE
*
* Call SBDSQR to compute the singular values/vectors of the
* bidiagonal factor.
*
IF( ICOMPZ.GT.0 ) THEN
NRU = N
ELSE
NRU = 0
END IF
CALL SBDSQR( 'Lower', N, 0, NRU, 0, D, E, VT, 1, Z, LDZ, C, 1,
$ WORK, INFO )
*
* Square the singular values.
*
IF( INFO.EQ.0 ) THEN
DO 30 I = 1, N
D( I ) = D( I )*D( I )
30 CONTINUE
ELSE
INFO = N + INFO
END IF
*
RETURN
*
* End of SPTEQR
*
END
SUBROUTINE SPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR,
$ BERR, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
REAL B( LDB, * ), BERR( * ), D( * ), DF( * ),
$ E( * ), EF( * ), FERR( * ), WORK( * ),
$ X( LDX, * )
* ..
*
* Purpose
* =======
*
* SPTRFS improves the computed solution to a system of linear
* equations when the coefficient matrix is symmetric positive definite
* and tridiagonal, and provides error bounds and backward error
* estimates for the solution.
*
* Arguments
* =========
*
* 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.
*
* D (input) REAL array, dimension (N)
* The n diagonal elements of the tridiagonal matrix A.
*
* E (input) REAL array, dimension (N-1)
* The (n-1) subdiagonal elements of the tridiagonal matrix A.
*
* DF (input) REAL array, dimension (N)
* The n diagonal elements of the diagonal matrix D from the
* factorization computed by SPTTRF.
*
* EF (input) REAL array, dimension (N-1)
* The (n-1) subdiagonal elements of the unit bidiagonal factor
* L from the factorization computed by SPTTRF.
*
* B (input) REAL array, dimension (LDB,NRHS)
* The right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input/output) REAL array, dimension (LDX,NRHS)
* On entry, the solution matrix X, as computed by SPTTRS.
* On exit, the improved solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* FERR (output) REAL array, dimension (NRHS)
* The forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j).
*
* BERR (output) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) REAL array, dimension (2*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Internal Parameters
* ===================
*
* ITMAX is the maximum number of steps of iterative refinement.
*
* =====================================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 5 )
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
REAL TWO
PARAMETER ( TWO = 2.0E+0 )
REAL THREE
PARAMETER ( THREE = 3.0E+0 )
* ..
* .. Local Scalars ..
INTEGER COUNT, I, IX, J, NZ
REAL BI, CX, DX, EPS, EX, LSTRES, S, SAFE1, SAFE2,
$ SAFMIN
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SPTTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. External Functions ..
INTEGER ISAMAX
REAL SLAMCH
EXTERNAL ISAMAX, SLAMCH
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( NRHS.LT.0 ) THEN
INFO = -2
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPTRFS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
DO 10 J = 1, NRHS
FERR( J ) = ZERO
BERR( J ) = ZERO
10 CONTINUE
RETURN
END IF
*
* NZ = maximum number of nonzero elements in each row of A, plus 1
*
NZ = 4
EPS = SLAMCH( 'Epsilon' )
SAFMIN = SLAMCH( 'Safe minimum' )
SAFE1 = NZ*SAFMIN
SAFE2 = SAFE1 / EPS
*
* Do for each right hand side
*
DO 90 J = 1, NRHS
*
COUNT = 1
LSTRES = THREE
20 CONTINUE
*
* Loop until stopping criterion is satisfied.
*
* Compute residual R = B - A * X. Also compute
* abs(A)*abs(x) + abs(b) for use in the backward error bound.
*
IF( N.EQ.1 ) THEN
BI = B( 1, J )
DX = D( 1 )*X( 1, J )
WORK( N+1 ) = BI - DX
WORK( 1 ) = ABS( BI ) + ABS( DX )
ELSE
BI = B( 1, J )
DX = D( 1 )*X( 1, J )
EX = E( 1 )*X( 2, J )
WORK( N+1 ) = BI - DX - EX
WORK( 1 ) = ABS( BI ) + ABS( DX ) + ABS( EX )
DO 30 I = 2, N - 1
BI = B( I, J )
CX = E( I-1 )*X( I-1, J )
DX = D( I )*X( I, J )
EX = E( I )*X( I+1, J )
WORK( N+I ) = BI - CX - DX - EX
WORK( I ) = ABS( BI ) + ABS( CX ) + ABS( DX ) + ABS( EX )
30 CONTINUE
BI = B( N, J )
CX = E( N-1 )*X( N-1, J )
DX = D( N )*X( N, J )
WORK( N+N ) = BI - CX - DX
WORK( N ) = ABS( BI ) + ABS( CX ) + ABS( DX )
END IF
*
* Compute componentwise relative backward error from formula
*
* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
*
* where abs(Z) is the componentwise absolute value of the matrix
* or vector Z. If the i-th component of the denominator is less
* than SAFE2, then SAFE1 is added to the i-th components of the
* numerator and denominator before dividing.
*
S = ZERO
DO 40 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
ELSE
S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
$ ( WORK( I )+SAFE1 ) )
END IF
40 CONTINUE
BERR( J ) = S
*
* Test stopping criterion. Continue iterating if
* 1) The residual BERR(J) is larger than machine epsilon, and
* 2) BERR(J) decreased by at least a factor of 2 during the
* last iteration, and
* 3) At most ITMAX iterations tried.
*
IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
$ COUNT.LE.ITMAX ) THEN
*
* Update solution and try again.
*
CALL SPTTRS( N, 1, DF, EF, WORK( N+1 ), N, INFO )
CALL SAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
LSTRES = BERR( J )
COUNT = COUNT + 1
GO TO 20
END IF
*
* Bound error from formula
*
* norm(X - XTRUE) / norm(X) .le. FERR =
* norm( abs(inv(A))*
* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
*
* where
* norm(Z) is the magnitude of the largest component of Z
* inv(A) is the inverse of A
* abs(Z) is the componentwise absolute value of the matrix or
* vector Z
* NZ is the maximum number of nonzeros in any row of A, plus 1
* EPS is machine epsilon
*
* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
* is incremented by SAFE1 if the i-th component of
* abs(A)*abs(X) + abs(B) is less than SAFE2.
*
DO 50 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
ELSE
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
END IF
50 CONTINUE
IX = ISAMAX( N, WORK, 1 )
FERR( J ) = WORK( IX )
*
* Estimate the norm of inv(A).
*
* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by
*
* m(i,j) = abs(A(i,j)), i = j,
* m(i,j) = -abs(A(i,j)), i .ne. j,
*
* and e = [ 1, 1, ..., 1 ]'. Note M(A) = M(L)*D*M(L)'.
*
* Solve M(L) * x = e.
*
WORK( 1 ) = ONE
DO 60 I = 2, N
WORK( I ) = ONE + WORK( I-1 )*ABS( EF( I-1 ) )
60 CONTINUE
*
* Solve D * M(L)' * x = b.
*
WORK( N ) = WORK( N ) / DF( N )
DO 70 I = N - 1, 1, -1
WORK( I ) = WORK( I ) / DF( I ) + WORK( I+1 )*ABS( EF( I ) )
70 CONTINUE
*
* Compute norm(inv(A)) = max(x(i)), 1<=i<=n.
*
IX = ISAMAX( N, WORK, 1 )
FERR( J ) = FERR( J )*ABS( WORK( IX ) )
*
* Normalize error.
*
LSTRES = ZERO
DO 80 I = 1, N
LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
80 CONTINUE
IF( LSTRES.NE.ZERO )
$ FERR( J ) = FERR( J ) / LSTRES
*
90 CONTINUE
*
RETURN
*
* End of SPTRFS
*
END
SUBROUTINE SPTSV( N, NRHS, D, E, B, LDB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
REAL B( LDB, * ), D( * ), E( * )
* ..
*
* Purpose
* =======
*
* SPTSV computes the solution to a real system of linear equations
* A*X = B, where A is an N-by-N symmetric positive definite tridiagonal
* matrix, and X and B are N-by-NRHS matrices.
*
* A is factored as A = L*D*L**T, and the factored form of A is then
* used to solve the system of equations.
*
* Arguments
* =========
*
* 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.
*
* D (input/output) REAL array, dimension (N)
* On entry, the n diagonal elements of the tridiagonal matrix
* A. On exit, the n diagonal elements of the diagonal matrix
* D from the factorization A = L*D*L**T.
*
* E (input/output) REAL array, dimension (N-1)
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix A. On exit, the (n-1) subdiagonal elements of the
* unit bidiagonal factor L from the L*D*L**T factorization of
* A. (E can also be regarded as the superdiagonal of the unit
* bidiagonal factor U from the U**T*D*U factorization of A.)
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the N-by-NRHS right hand side matrix B.
* On exit, if INFO = 0, the N-by-NRHS 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
* > 0: if INFO = i, the leading minor of order i is not
* positive definite, and the solution has not been
* computed. The factorization has not been completed
* unless i = N.
*
* =====================================================================
*
* .. External Subroutines ..
EXTERNAL SPTTRF, SPTTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( NRHS.LT.0 ) THEN
INFO = -2
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPTSV ', -INFO )
RETURN
END IF
*
* Compute the L*D*L' (or U'*D*U) factorization of A.
*
CALL SPTTRF( N, D, E, INFO )
IF( INFO.EQ.0 ) THEN
*
* Solve the system A*X = B, overwriting B with X.
*
CALL SPTTRS( N, NRHS, D, E, B, LDB, INFO )
END IF
RETURN
*
* End of SPTSV
*
END
SUBROUTINE SPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX,
$ RCOND, FERR, BERR, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER FACT
INTEGER INFO, LDB, LDX, N, NRHS
REAL RCOND
* ..
* .. Array Arguments ..
REAL B( LDB, * ), BERR( * ), D( * ), DF( * ),
$ E( * ), EF( * ), FERR( * ), WORK( * ),
$ X( LDX, * )
* ..
*
* Purpose
* =======
*
* SPTSVX uses the factorization A = L*D*L**T to compute the solution
* to a real system of linear equations A*X = B, where A is an N-by-N
* symmetric positive definite tridiagonal matrix and X and B are
* N-by-NRHS matrices.
*
* Error bounds on the solution and a condition estimate are also
* provided.
*
* Description
* ===========
*
* The following steps are performed:
*
* 1. If FACT = 'N', the matrix A is factored as A = L*D*L**T, where L
* is a unit lower bidiagonal matrix and D is diagonal. The
* factorization can also be regarded as having the form
* A = U**T*D*U.
*
* 2. If the leading i-by-i principal minor is not positive definite,
* then the routine returns with INFO = i. Otherwise, the factored
* form of A is used to estimate the condition number of the matrix
* A. If the reciprocal of the condition number is less than machine
* precision, INFO = N+1 is returned as a warning, but the routine
* still goes on to solve for X and compute error bounds as
* described below.
*
* 3. The system of equations is solved for X using the factored form
* of A.
*
* 4. Iterative refinement is applied to improve the computed solution
* matrix and calculate error bounds and backward error estimates
* for it.
*
* Arguments
* =========
*
* FACT (input) CHARACTER*1
* Specifies whether or not the factored form of A has been
* supplied on entry.
* = 'F': On entry, DF and EF contain the factored form of A.
* D, E, DF, and EF will not be modified.
* = 'N': The matrix A will be copied to DF and EF and
* factored.
*
* 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 matrices B and X. NRHS >= 0.
*
* D (input) REAL array, dimension (N)
* The n diagonal elements of the tridiagonal matrix A.
*
* E (input) REAL array, dimension (N-1)
* The (n-1) subdiagonal elements of the tridiagonal matrix A.
*
* DF (input or output) REAL array, dimension (N)
* If FACT = 'F', then DF is an input argument and on entry
* contains the n diagonal elements of the diagonal matrix D
* from the L*D*L**T factorization of A.
* If FACT = 'N', then DF is an output argument and on exit
* contains the n diagonal elements of the diagonal matrix D
* from the L*D*L**T factorization of A.
*
* EF (input or output) REAL array, dimension (N-1)
* If FACT = 'F', then EF is an input argument and on entry
* contains the (n-1) subdiagonal elements of the unit
* bidiagonal factor L from the L*D*L**T factorization of A.
* If FACT = 'N', then EF is an output argument and on exit
* contains the (n-1) subdiagonal elements of the unit
* bidiagonal factor L from the L*D*L**T factorization of A.
*
* B (input) REAL array, dimension (LDB,NRHS)
* The N-by-NRHS right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (output) REAL array, dimension (LDX,NRHS)
* If INFO = 0 of INFO = N+1, the N-by-NRHS solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* RCOND (output) REAL
* The reciprocal condition number of the matrix A. If RCOND
* is less than the machine precision (in particular, if
* RCOND = 0), the matrix is singular to working precision.
* This condition is indicated by a return code of INFO > 0.
*
* FERR (output) REAL array, dimension (NRHS)
* The forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j).
*
* BERR (output) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in any
* element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) REAL array, dimension (2*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, and i is
* <= N: the leading minor of order i of A is
* not positive definite, so the factorization
* could not be completed, and the solution has not
* been computed. RCOND = 0 is returned.
* = N+1: U is nonsingular, but RCOND is less than machine
* precision, meaning that the matrix is singular
* to working precision. Nevertheless, the
* solution and error bounds are computed because
* there are a number of situations where the
* computed solution can be more accurate than the
* value of RCOND would suggest.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOFACT
REAL ANORM
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANST
EXTERNAL LSAME, SLAMCH, SLANST
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLACPY, SPTCON, SPTRFS, SPTTRF, SPTTRS,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
NOFACT = LSAME( FACT, 'N' )
IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -11
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPTSVX', -INFO )
RETURN
END IF
*
IF( NOFACT ) THEN
*
* Compute the L*D*L' (or U'*D*U) factorization of A.
*
CALL SCOPY( N, D, 1, DF, 1 )
IF( N.GT.1 )
$ CALL SCOPY( N-1, E, 1, EF, 1 )
CALL SPTTRF( N, DF, EF, INFO )
*
* Return if INFO is non-zero.
*
IF( INFO.GT.0 )THEN
RCOND = ZERO
RETURN
END IF
END IF
*
* Compute the norm of the matrix A.
*
ANORM = SLANST( '1', N, D, E )
*
* Compute the reciprocal of the condition number of A.
*
CALL SPTCON( N, DF, EF, ANORM, RCOND, WORK, INFO )
*
* Compute the solution vectors X.
*
CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
CALL SPTTRS( N, NRHS, DF, EF, X, LDX, INFO )
*
* Use iterative refinement to improve the computed solutions and
* compute error bounds and backward error estimates for them.
*
CALL SPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR,
$ WORK, INFO )
*
* Set INFO = N+1 if the matrix is singular to working precision.
*
IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
$ INFO = N + 1
*
RETURN
*
* End of SPTSVX
*
END
SUBROUTINE SPTTRF( N, D, E, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, N
* ..
* .. Array Arguments ..
REAL D( * ), E( * )
* ..
*
* Purpose
* =======
*
* SPTTRF computes the L*D*L' factorization of a real symmetric
* positive definite tridiagonal matrix A. The factorization may also
* be regarded as having the form A = U'*D*U.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* D (input/output) REAL array, dimension (N)
* On entry, the n diagonal elements of the tridiagonal matrix
* A. On exit, the n diagonal elements of the diagonal matrix
* D from the L*D*L' factorization of A.
*
* E (input/output) REAL array, dimension (N-1)
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix A. On exit, the (n-1) subdiagonal elements of the
* unit bidiagonal factor L from the L*D*L' factorization of A.
* E can also be regarded as the superdiagonal of the unit
* bidiagonal factor U from the U'*D*U factorization of A.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
* > 0: if INFO = k, the leading minor of order k is not
* positive definite; if k < N, the factorization could not
* be completed, while if k = N, the factorization was
* completed, but D(N) <= 0.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, I4
REAL EI
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MOD
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
CALL XERBLA( 'SPTTRF', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Compute the L*D*L' (or U'*D*U) factorization of A.
*
I4 = MOD( N-1, 4 )
DO 10 I = 1, I4
IF( D( I ).LE.ZERO ) THEN
INFO = I
GO TO 30
END IF
EI = E( I )
E( I ) = EI / D( I )
D( I+1 ) = D( I+1 ) - E( I )*EI
10 CONTINUE
*
DO 20 I = I4 + 1, N - 4, 4
*
* Drop out of the loop if d(i) <= 0: the matrix is not positive
* definite.
*
IF( D( I ).LE.ZERO ) THEN
INFO = I
GO TO 30
END IF
*
* Solve for e(i) and d(i+1).
*
EI = E( I )
E( I ) = EI / D( I )
D( I+1 ) = D( I+1 ) - E( I )*EI
*
IF( D( I+1 ).LE.ZERO ) THEN
INFO = I + 1
GO TO 30
END IF
*
* Solve for e(i+1) and d(i+2).
*
EI = E( I+1 )
E( I+1 ) = EI / D( I+1 )
D( I+2 ) = D( I+2 ) - E( I+1 )*EI
*
IF( D( I+2 ).LE.ZERO ) THEN
INFO = I + 2
GO TO 30
END IF
*
* Solve for e(i+2) and d(i+3).
*
EI = E( I+2 )
E( I+2 ) = EI / D( I+2 )
D( I+3 ) = D( I+3 ) - E( I+2 )*EI
*
IF( D( I+3 ).LE.ZERO ) THEN
INFO = I + 3
GO TO 30
END IF
*
* Solve for e(i+3) and d(i+4).
*
EI = E( I+3 )
E( I+3 ) = EI / D( I+3 )
D( I+4 ) = D( I+4 ) - E( I+3 )*EI
20 CONTINUE
*
* Check d(n) for positive definiteness.
*
IF( D( N ).LE.ZERO )
$ INFO = N
*
30 CONTINUE
RETURN
*
* End of SPTTRF
*
END
SUBROUTINE SPTTRS( N, NRHS, D, E, B, LDB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
REAL B( LDB, * ), D( * ), E( * )
* ..
*
* Purpose
* =======
*
* SPTTRS solves a tridiagonal system of the form
* A * X = B
* using the L*D*L' factorization of A computed by SPTTRF. D is a
* diagonal matrix specified in the vector D, L is a unit bidiagonal
* matrix whose subdiagonal is specified in the vector E, and X and B
* are N by NRHS matrices.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the tridiagonal 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.
*
* D (input) REAL array, dimension (N)
* The n diagonal elements of the diagonal matrix D from the
* L*D*L' factorization of A.
*
* E (input) REAL array, dimension (N-1)
* The (n-1) subdiagonal elements of the unit bidiagonal factor
* L from the L*D*L' factorization of A. E can also be regarded
* as the superdiagonal of the unit bidiagonal factor U from the
* factorization A = U'*D*U.
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the right hand side vectors B for the system of
* linear equations.
* On exit, the solution vectors, X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER J, JB, NB
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. External Subroutines ..
EXTERNAL SPTTS2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments.
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( NRHS.LT.0 ) THEN
INFO = -2
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPTTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
* Determine the number of right-hand sides to solve at a time.
*
IF( NRHS.EQ.1 ) THEN
NB = 1
ELSE
NB = MAX( 1, ILAENV( 1, 'SPTTRS', ' ', N, NRHS, -1, -1 ) )
END IF
*
IF( NB.GE.NRHS ) THEN
CALL SPTTS2( N, NRHS, D, E, B, LDB )
ELSE
DO 10 J = 1, NRHS, NB
JB = MIN( NRHS-J+1, NB )
CALL SPTTS2( N, JB, D, E, B( 1, J ), LDB )
10 CONTINUE
END IF
*
RETURN
*
* End of SPTTRS
*
END
SUBROUTINE SPTTS2( N, NRHS, D, E, B, LDB )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDB, N, NRHS
* ..
* .. Array Arguments ..
REAL B( LDB, * ), D( * ), E( * )
* ..
*
* Purpose
* =======
*
* SPTTS2 solves a tridiagonal system of the form
* A * X = B
* using the L*D*L' factorization of A computed by SPTTRF. D is a
* diagonal matrix specified in the vector D, L is a unit bidiagonal
* matrix whose subdiagonal is specified in the vector E, and X and B
* are N by NRHS matrices.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the tridiagonal 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.
*
* D (input) REAL array, dimension (N)
* The n diagonal elements of the diagonal matrix D from the
* L*D*L' factorization of A.
*
* E (input) REAL array, dimension (N-1)
* The (n-1) subdiagonal elements of the unit bidiagonal factor
* L from the L*D*L' factorization of A. E can also be regarded
* as the superdiagonal of the unit bidiagonal factor U from the
* factorization A = U'*D*U.
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the right hand side vectors B for the system of
* linear equations.
* On exit, the solution vectors, X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J
* ..
* .. External Subroutines ..
EXTERNAL SSCAL
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.1 ) THEN
IF( N.EQ.1 )
$ CALL SSCAL( NRHS, 1. / D( 1 ), B, LDB )
RETURN
END IF
*
* Solve A * X = B using the factorization A = L*D*L',
* overwriting each right hand side vector with its solution.
*
DO 30 J = 1, NRHS
*
* Solve L * x = b.
*
DO 10 I = 2, N
B( I, J ) = B( I, J ) - B( I-1, J )*E( I-1 )
10 CONTINUE
*
* Solve D * L' * x = b.
*
B( N, J ) = B( N, J ) / D( N )
DO 20 I = N - 1, 1, -1
B( I, J ) = B( I, J ) / D( I ) - B( I+1, J )*E( I )
20 CONTINUE
30 CONTINUE
*
RETURN
*
* End of SPTTS2
*
END
SUBROUTINE SRSCL( N, SA, SX, INCX )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INCX, N
REAL SA
* ..
* .. Array Arguments ..
REAL SX( * )
* ..
*
* Purpose
* =======
*
* SRSCL multiplies an n-element real vector x by the real scalar 1/a.
* This is done without overflow or underflow as long as
* the final result x/a does not overflow or underflow.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of components of the vector x.
*
* SA (input) REAL
* The scalar a which is used to divide each component of x.
* SA must be >= 0, or the subroutine will divide by zero.
*
* SX (input/output) REAL array, dimension
* (1+(N-1)*abs(INCX))
* The n-element vector x.
*
* INCX (input) INTEGER
* The increment between successive values of the vector SX.
* > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL DONE
REAL BIGNUM, CDEN, CDEN1, CNUM, CNUM1, MUL, SMLNUM
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SLABAD, SSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
* Get machine parameters
*
SMLNUM = SLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
*
* Initialize the denominator to SA and the numerator to 1.
*
CDEN = SA
CNUM = ONE
*
10 CONTINUE
CDEN1 = CDEN*SMLNUM
CNUM1 = CNUM / BIGNUM
IF( ABS( CDEN1 ).GT.ABS( CNUM ) .AND. CNUM.NE.ZERO ) THEN
*
* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM.
*
MUL = SMLNUM
DONE = .FALSE.
CDEN = CDEN1
ELSE IF( ABS( CNUM1 ).GT.ABS( CDEN ) ) THEN
*
* Pre-multiply X by BIGNUM if CDEN is small compared to CNUM.
*
MUL = BIGNUM
DONE = .FALSE.
CNUM = CNUM1
ELSE
*
* Multiply X by CNUM / CDEN and return.
*
MUL = CNUM / CDEN
DONE = .TRUE.
END IF
*
* Scale the vector X by MUL
*
CALL SSCAL( N, MUL, SX, INCX )
*
IF( .NOT.DONE )
$ GO TO 10
*
RETURN
*
* End of SRSCL
*
END
SUBROUTINE SSBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK,
$ INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, KD, LDAB, LDZ, N
* ..
* .. Array Arguments ..
REAL AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SSBEV computes all the eigenvalues and, optionally, eigenvectors of
* a real symmetric band matrix A.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
*
* AB (input/output) REAL array, dimension (LDAB, N)
* On entry, the upper or lower triangle of the symmetric band
* matrix A, stored in the first KD+1 rows of the array. The
* j-th column of A is stored in the j-th column of the array AB
* as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*
* On exit, AB is overwritten by values generated during the
* reduction to tridiagonal form. If UPLO = 'U', the first
* superdiagonal and the diagonal of the tridiagonal matrix T
* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
* the diagonal and first subdiagonal of T are returned in the
* first two rows of AB.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD + 1.
*
* W (output) REAL array, dimension (N)
* If INFO = 0, the eigenvalues in ascending order.
*
* Z (output) REAL array, dimension (LDZ, N)
* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
* eigenvectors of the matrix A, with the i-th column of Z
* holding the eigenvector associated with W(i).
* If JOBZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace) REAL array, dimension (max(1,3*N-2))
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, the algorithm failed to converge; i
* off-diagonal elements of an intermediate tridiagonal
* form did not converge to zero.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL LOWER, WANTZ
INTEGER IINFO, IMAX, INDE, INDWRK, ISCALE
REAL ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
$ SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANSB
EXTERNAL LSAME, SLAMCH, SLANSB
* ..
* .. External Subroutines ..
EXTERNAL SLASCL, SSBTRD, SSCAL, SSTEQR, SSTERF, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
LOWER = LSAME( UPLO, 'L' )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( KD.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -6
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -9
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSBEV ', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( LOWER ) THEN
W( 1 ) = AB( 1, 1 )
ELSE
W( 1 ) = AB( KD+1, 1 )
END IF
IF( WANTZ )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = SLAMCH( 'Safe minimum' )
EPS = SLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = SQRT( BIGNUM )
*
* Scale matrix to allowable range, if necessary.
*
ANRM = SLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK )
ISCALE = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 ) THEN
IF( LOWER ) THEN
CALL SLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
ELSE
CALL SLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
END IF
END IF
*
* Call SSBTRD to reduce symmetric band matrix to tridiagonal form.
*
INDE = 1
INDWRK = INDE + N
CALL SSBTRD( JOBZ, UPLO, N, KD, AB, LDAB, W, WORK( INDE ), Z, LDZ,
$ WORK( INDWRK ), IINFO )
*
* For eigenvalues only, call SSTERF. For eigenvectors, call SSTEQR.
*
IF( .NOT.WANTZ ) THEN
CALL SSTERF( N, W, WORK( INDE ), INFO )
ELSE
CALL SSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ),
$ INFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = N
ELSE
IMAX = INFO - 1
END IF
CALL SSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
RETURN
*
* End of SSBEV
*
END
SUBROUTINE SSBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK,
$ LWORK, IWORK, LIWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, KD, LDAB, LDZ, LIWORK, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SSBEVD computes all the eigenvalues and, optionally, eigenvectors of
* a real symmetric band matrix A. If eigenvectors are desired, it uses
* a divide and conquer algorithm.
*
* The divide and conquer algorithm makes very mild assumptions about
* floating point arithmetic. It will work on machines with a guard
* digit in add/subtract, or on those binary machines without guard
* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
* Cray-2. It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
*
* AB (input/output) REAL array, dimension (LDAB, N)
* On entry, the upper or lower triangle of the symmetric band
* matrix A, stored in the first KD+1 rows of the array. The
* j-th column of A is stored in the j-th column of the array AB
* as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*
* On exit, AB is overwritten by values generated during the
* reduction to tridiagonal form. If UPLO = 'U', the first
* superdiagonal and the diagonal of the tridiagonal matrix T
* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
* the diagonal and first subdiagonal of T are returned in the
* first two rows of AB.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD + 1.
*
* W (output) REAL array, dimension (N)
* If INFO = 0, the eigenvalues in ascending order.
*
* Z (output) REAL array, dimension (LDZ, N)
* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
* eigenvectors of the matrix A, with the i-th column of Z
* holding the eigenvector associated with W(i).
* If JOBZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace/output) REAL array,
* dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* IF N <= 1, LWORK must be at least 1.
* If JOBZ = 'N' and N > 2, LWORK must be at least 2*N.
* If JOBZ = 'V' and N > 2, LWORK must be at least
* ( 1 + 5*N + 2*N**2 ).
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal sizes of the WORK and IWORK
* arrays, returns these values as the first entries of the WORK
* and IWORK arrays, and no error message related to LWORK or
* LIWORK is issued by XERBLA.
*
* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array LIWORK.
* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.
* If JOBZ = 'V' and N > 2, LIWORK must be at least 3 + 5*N.
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal sizes of the WORK and
* IWORK arrays, returns these values as the first entries of
* the WORK and IWORK arrays, and no error message related to
* LWORK or LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, the algorithm failed to converge; i
* off-diagonal elements of an intermediate tridiagonal
* form did not converge to zero.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LOWER, LQUERY, WANTZ
INTEGER IINFO, INDE, INDWK2, INDWRK, ISCALE, LIWMIN,
$ LLWRK2, LWMIN
REAL ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
$ SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANSB
EXTERNAL LSAME, SLAMCH, SLANSB
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SLACPY, SLASCL, SSBTRD, SSCAL, SSTEDC,
$ SSTERF, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
LOWER = LSAME( UPLO, 'L' )
LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
INFO = 0
IF( N.LE.1 ) THEN
LIWMIN = 1
LWMIN = 1
ELSE
IF( WANTZ ) THEN
LIWMIN = 3 + 5*N
LWMIN = 1 + 5*N + 2*N**2
ELSE
LIWMIN = 1
LWMIN = 2*N
END IF
END IF
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( KD.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -6
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -9
END IF
*
IF( INFO.EQ.0 ) THEN
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -11
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSBEVD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
W( 1 ) = AB( 1, 1 )
IF( WANTZ )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = SLAMCH( 'Safe minimum' )
EPS = SLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = SQRT( BIGNUM )
*
* Scale matrix to allowable range, if necessary.
*
ANRM = SLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK )
ISCALE = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 ) THEN
IF( LOWER ) THEN
CALL SLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
ELSE
CALL SLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
END IF
END IF
*
* Call SSBTRD to reduce symmetric band matrix to tridiagonal form.
*
INDE = 1
INDWRK = INDE + N
INDWK2 = INDWRK + N*N
LLWRK2 = LWORK - INDWK2 + 1
CALL SSBTRD( JOBZ, UPLO, N, KD, AB, LDAB, W, WORK( INDE ), Z, LDZ,
$ WORK( INDWRK ), IINFO )
*
* For eigenvalues only, call SSTERF. For eigenvectors, call SSTEDC.
*
IF( .NOT.WANTZ ) THEN
CALL SSTERF( N, W, WORK( INDE ), INFO )
ELSE
CALL SSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N,
$ WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO )
CALL SGEMM( 'N', 'N', N, N, N, ONE, Z, LDZ, WORK( INDWRK ), N,
$ ZERO, WORK( INDWK2 ), N )
CALL SLACPY( 'A', N, N, WORK( INDWK2 ), N, Z, LDZ )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( ISCALE.EQ.1 )
$ CALL SSCAL( N, ONE / SIGMA, W, 1 )
*
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
RETURN
*
* End of SSBEVD
*
END
SUBROUTINE SSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL,
$ VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK,
$ IFAIL, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE, UPLO
INTEGER IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N
REAL ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER IFAIL( * ), IWORK( * )
REAL AB( LDAB, * ), Q( LDQ, * ), W( * ), WORK( * ),
$ Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SSBEVX computes selected eigenvalues and, optionally, eigenvectors
* of a real symmetric band matrix A. Eigenvalues and eigenvectors can
* be selected by specifying either a range of values or a range of
* indices for the desired eigenvalues.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* RANGE (input) CHARACTER*1
* = 'A': all eigenvalues will be found;
* = 'V': all eigenvalues in the half-open interval (VL,VU]
* will be found;
* = 'I': the IL-th through IU-th eigenvalues will be found.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
*
* AB (input/output) REAL array, dimension (LDAB, N)
* On entry, the upper or lower triangle of the symmetric band
* matrix A, stored in the first KD+1 rows of the array. The
* j-th column of A is stored in the j-th column of the array AB
* as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*
* On exit, AB is overwritten by values generated during the
* reduction to tridiagonal form. If UPLO = 'U', the first
* superdiagonal and the diagonal of the tridiagonal matrix T
* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
* the diagonal and first subdiagonal of T are returned in the
* first two rows of AB.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD + 1.
*
* Q (output) REAL array, dimension (LDQ, N)
* If JOBZ = 'V', the N-by-N orthogonal matrix used in the
* reduction to tridiagonal form.
* If JOBZ = 'N', the array Q is not referenced.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. If JOBZ = 'V', then
* LDQ >= max(1,N).
*
* VL (input) REAL
* VU (input) REAL
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* ABSTOL (input) REAL
* The absolute error tolerance for the eigenvalues.
* An approximate eigenvalue is accepted as converged
* when it is determined to lie in an interval [a,b]
* of width less than or equal to
*
* ABSTOL + EPS * max( |a|,|b| ) ,
*
* where EPS is the machine precision. If ABSTOL is less than
* or equal to zero, then EPS*|T| will be used in its place,
* where |T| is the 1-norm of the tridiagonal matrix obtained
* by reducing AB to tridiagonal form.
*
* Eigenvalues will be computed most accurately when ABSTOL is
* set to twice the underflow threshold 2*SLAMCH('S'), not zero.
* If this routine returns with INFO>0, indicating that some
* eigenvectors did not converge, try setting ABSTOL to
* 2*SLAMCH('S').
*
* See "Computing Small Singular Values of Bidiagonal Matrices
* with Guaranteed High Relative Accuracy," by Demmel and
* Kahan, LAPACK Working Note #3.
*
* M (output) INTEGER
* The total number of eigenvalues found. 0 <= M <= N.
* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*
* W (output) REAL array, dimension (N)
* The first M elements contain the selected eigenvalues in
* ascending order.
*
* Z (output) REAL array, dimension (LDZ, max(1,M))
* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
* contain the orthonormal eigenvectors of the matrix A
* corresponding to the selected eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* If an eigenvector fails to converge, then that column of Z
* contains the latest approximation to the eigenvector, and the
* index of the eigenvector is returned in IFAIL.
* If JOBZ = 'N', then Z is not referenced.
* Note: the user must ensure that at least max(1,M) columns are
* supplied in the array Z; if RANGE = 'V', the exact value of M
* is not known in advance and an upper bound must be used.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace) REAL array, dimension (7*N)
*
* IWORK (workspace) INTEGER array, dimension (5*N)
*
* IFAIL (output) INTEGER array, dimension (N)
* If JOBZ = 'V', then if INFO = 0, the first M elements of
* IFAIL are zero. If INFO > 0, then IFAIL contains the
* indices of the eigenvectors that failed to converge.
* If JOBZ = 'N', then IFAIL is not referenced.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = i, then i eigenvectors failed to converge.
* Their indices are stored in array IFAIL.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, LOWER, TEST, VALEIG, WANTZ
CHARACTER ORDER
INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
$ INDISP, INDIWO, INDWRK, ISCALE, ITMP1, J, JJ,
$ NSPLIT
REAL ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
$ SIGMA, SMLNUM, TMP1, VLL, VUU
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANSB
EXTERNAL LSAME, SLAMCH, SLANSB
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMV, SLACPY, SLASCL, SSBTRD, SSCAL,
$ SSTEBZ, SSTEIN, SSTEQR, SSTERF, SSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
LOWER = LSAME( UPLO, 'L' )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
INFO = -2
ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( KD.LT.0 ) THEN
INFO = -5
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -7
ELSE IF( WANTZ .AND. LDQ.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE
IF( VALEIG ) THEN
IF( N.GT.0 .AND. VU.LE.VL )
$ INFO = -11
ELSE IF( INDEIG ) THEN
IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
INFO = -12
ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
INFO = -13
END IF
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) )
$ INFO = -18
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSBEVX', -INFO )
RETURN
END IF
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
M = 1
IF( LOWER ) THEN
TMP1 = AB( 1, 1 )
ELSE
TMP1 = AB( KD+1, 1 )
END IF
IF( VALEIG ) THEN
IF( .NOT.( VL.LT.TMP1 .AND. VU.GE.TMP1 ) )
$ M = 0
END IF
IF( M.EQ.1 ) THEN
W( 1 ) = TMP1
IF( WANTZ )
$ Z( 1, 1 ) = ONE
END IF
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = SLAMCH( 'Safe minimum' )
EPS = SLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
*
* Scale matrix to allowable range, if necessary.
*
ISCALE = 0
ABSTLL = ABSTOL
IF ( VALEIG ) THEN
VLL = VL
VUU = VU
ELSE
VLL = ZERO
VUU = ZERO
ENDIF
ANRM = SLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK )
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 ) THEN
IF( LOWER ) THEN
CALL SLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
ELSE
CALL SLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
END IF
IF( ABSTOL.GT.0 )
$ ABSTLL = ABSTOL*SIGMA
IF( VALEIG ) THEN
VLL = VL*SIGMA
VUU = VU*SIGMA
END IF
END IF
*
* Call SSBTRD to reduce symmetric band matrix to tridiagonal form.
*
INDD = 1
INDE = INDD + N
INDWRK = INDE + N
CALL SSBTRD( JOBZ, UPLO, N, KD, AB, LDAB, WORK( INDD ),
$ WORK( INDE ), Q, LDQ, WORK( INDWRK ), IINFO )
*
* If all eigenvalues are desired and ABSTOL is less than or equal
* to zero, then call SSTERF or SSTEQR. If this fails for some
* eigenvalue, then try SSTEBZ.
*
TEST = .FALSE.
IF (INDEIG) THEN
IF (IL.EQ.1 .AND. IU.EQ.N) THEN
TEST = .TRUE.
END IF
END IF
IF ((ALLEIG .OR. TEST) .AND. (ABSTOL.LE.ZERO)) THEN
CALL SCOPY( N, WORK( INDD ), 1, W, 1 )
INDEE = INDWRK + 2*N
IF( .NOT.WANTZ ) THEN
CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
CALL SSTERF( N, W, WORK( INDEE ), INFO )
ELSE
CALL SLACPY( 'A', N, N, Q, LDQ, Z, LDZ )
CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
CALL SSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ,
$ WORK( INDWRK ), INFO )
IF( INFO.EQ.0 ) THEN
DO 10 I = 1, N
IFAIL( I ) = 0
10 CONTINUE
END IF
END IF
IF( INFO.EQ.0 ) THEN
M = N
GO TO 30
END IF
INFO = 0
END IF
*
* Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN.
*
IF( WANTZ ) THEN
ORDER = 'B'
ELSE
ORDER = 'E'
END IF
INDIBL = 1
INDISP = INDIBL + N
INDIWO = INDISP + N
CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
$ WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
$ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ),
$ IWORK( INDIWO ), INFO )
*
IF( WANTZ ) THEN
CALL SSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
$ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
$ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO )
*
* Apply orthogonal matrix used in reduction to tridiagonal
* form to eigenvectors returned by SSTEIN.
*
DO 20 J = 1, M
CALL SCOPY( N, Z( 1, J ), 1, WORK( 1 ), 1 )
CALL SGEMV( 'N', N, N, ONE, Q, LDQ, WORK, 1, ZERO,
$ Z( 1, J ), 1 )
20 CONTINUE
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
30 CONTINUE
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = M
ELSE
IMAX = INFO - 1
END IF
CALL SSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
* If eigenvalues are not in order, then sort them, along with
* eigenvectors.
*
IF( WANTZ ) THEN
DO 50 J = 1, M - 1
I = 0
TMP1 = W( J )
DO 40 JJ = J + 1, M
IF( W( JJ ).LT.TMP1 ) THEN
I = JJ
TMP1 = W( JJ )
END IF
40 CONTINUE
*
IF( I.NE.0 ) THEN
ITMP1 = IWORK( INDIBL+I-1 )
W( I ) = W( J )
IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
W( J ) = TMP1
IWORK( INDIBL+J-1 ) = ITMP1
CALL SSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
IF( INFO.NE.0 ) THEN
ITMP1 = IFAIL( I )
IFAIL( I ) = IFAIL( J )
IFAIL( J ) = ITMP1
END IF
END IF
50 CONTINUE
END IF
*
RETURN
*
* End of SSBEVX
*
END
SUBROUTINE SSBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X,
$ LDX, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO, VECT
INTEGER INFO, KA, KB, LDAB, LDBB, LDX, N
* ..
* .. Array Arguments ..
REAL AB( LDAB, * ), BB( LDBB, * ), WORK( * ),
$ X( LDX, * )
* ..
*
* Purpose
* =======
*
* SSBGST reduces a real symmetric-definite banded generalized
* eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y,
* such that C has the same bandwidth as A.
*
* B must have been previously factorized as S**T*S by SPBSTF, using a
* split Cholesky factorization. A is overwritten by C = X**T*A*X, where
* X = S**(-1)*Q and Q is an orthogonal matrix chosen to preserve the
* bandwidth of A.
*
* Arguments
* =========
*
* VECT (input) CHARACTER*1
* = 'N': do not form the transformation matrix X;
* = 'V': form X.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* KA (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
*
* KB (input) INTEGER
* The number of superdiagonals of the matrix B if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0.
*
* AB (input/output) REAL array, dimension (LDAB,N)
* On entry, the upper or lower triangle of the symmetric band
* matrix A, stored in the first ka+1 rows of the array. The
* j-th column of A is stored in the j-th column of the array AB
* as follows:
* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
*
* On exit, the transformed matrix X**T*A*X, stored in the same
* format as A.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KA+1.
*
* BB (input) REAL array, dimension (LDBB,N)
* The banded factor S from the split Cholesky factorization of
* B, as returned by SPBSTF, stored in the first KB+1 rows of
* the array.
*
* LDBB (input) INTEGER
* The leading dimension of the array BB. LDBB >= KB+1.
*
* X (output) REAL array, dimension (LDX,N)
* If VECT = 'V', the n-by-n matrix X.
* If VECT = 'N', the array X is not referenced.
*
* LDX (input) INTEGER
* The leading dimension of the array X.
* LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.
*
* WORK (workspace) REAL array, dimension (2*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPDATE, UPPER, WANTX
INTEGER I, I0, I1, I2, INCA, J, J1, J1T, J2, J2T, K,
$ KA1, KB1, KBT, L, M, NR, NRT, NX
REAL BII, RA, RA1, T
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SGER, SLAR2V, SLARGV, SLARTG, SLARTV, SLASET,
$ SROT, SSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
WANTX = LSAME( VECT, 'V' )
UPPER = LSAME( UPLO, 'U' )
KA1 = KA + 1
KB1 = KB + 1
INFO = 0
IF( .NOT.WANTX .AND. .NOT.LSAME( VECT, 'N' ) ) THEN
INFO = -1
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( KA.LT.0 ) THEN
INFO = -4
ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
INFO = -5
ELSE IF( LDAB.LT.KA+1 ) THEN
INFO = -7
ELSE IF( LDBB.LT.KB+1 ) THEN
INFO = -9
ELSE IF( LDX.LT.1 .OR. WANTX .AND. LDX.LT.MAX( 1, N ) ) THEN
INFO = -11
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSBGST', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
INCA = LDAB*KA1
*
* Initialize X to the unit matrix, if needed
*
IF( WANTX )
$ CALL SLASET( 'Full', N, N, ZERO, ONE, X, LDX )
*
* Set M to the splitting point m. It must be the same value as is
* used in SPBSTF. The chosen value allows the arrays WORK and RWORK
* to be of dimension (N).
*
M = ( N+KB ) / 2
*
* The routine works in two phases, corresponding to the two halves
* of the split Cholesky factorization of B as S**T*S where
*
* S = ( U )
* ( M L )
*
* with U upper triangular of order m, and L lower triangular of
* order n-m. S has the same bandwidth as B.
*
* S is treated as a product of elementary matrices:
*
* S = S(m)*S(m-1)*...*S(2)*S(1)*S(m+1)*S(m+2)*...*S(n-1)*S(n)
*
* where S(i) is determined by the i-th row of S.
*
* In phase 1, the index i takes the values n, n-1, ... , m+1;
* in phase 2, it takes the values 1, 2, ... , m.
*
* For each value of i, the current matrix A is updated by forming
* inv(S(i))**T*A*inv(S(i)). This creates a triangular bulge outside
* the band of A. The bulge is then pushed down toward the bottom of
* A in phase 1, and up toward the top of A in phase 2, by applying
* plane rotations.
*
* There are kb*(kb+1)/2 elements in the bulge, but at most 2*kb-1
* of them are linearly independent, so annihilating a bulge requires
* only 2*kb-1 plane rotations. The rotations are divided into a 1st
* set of kb-1 rotations, and a 2nd set of kb rotations.
*
* Wherever possible, rotations are generated and applied in vector
* operations of length NR between the indices J1 and J2 (sometimes
* replaced by modified values NRT, J1T or J2T).
*
* The cosines and sines of the rotations are stored in the array
* WORK. The cosines of the 1st set of rotations are stored in
* elements n+2:n+m-kb-1 and the sines of the 1st set in elements
* 2:m-kb-1; the cosines of the 2nd set are stored in elements
* n+m-kb+1:2*n and the sines of the second set in elements m-kb+1:n.
*
* The bulges are not formed explicitly; nonzero elements outside the
* band are created only when they are required for generating new
* rotations; they are stored in the array WORK, in positions where
* they are later overwritten by the sines of the rotations which
* annihilate them.
*
* **************************** Phase 1 *****************************
*
* The logical structure of this phase is:
*
* UPDATE = .TRUE.
* DO I = N, M + 1, -1
* use S(i) to update A and create a new bulge
* apply rotations to push all bulges KA positions downward
* END DO
* UPDATE = .FALSE.
* DO I = M + KA + 1, N - 1
* apply rotations to push all bulges KA positions downward
* END DO
*
* To avoid duplicating code, the two loops are merged.
*
UPDATE = .TRUE.
I = N + 1
10 CONTINUE
IF( UPDATE ) THEN
I = I - 1
KBT = MIN( KB, I-1 )
I0 = I - 1
I1 = MIN( N, I+KA )
I2 = I - KBT + KA1
IF( I.LT.M+1 ) THEN
UPDATE = .FALSE.
I = I + 1
I0 = M
IF( KA.EQ.0 )
$ GO TO 480
GO TO 10
END IF
ELSE
I = I + KA
IF( I.GT.N-1 )
$ GO TO 480
END IF
*
IF( UPPER ) THEN
*
* Transform A, working with the upper triangle
*
IF( UPDATE ) THEN
*
* Form inv(S(i))**T * A * inv(S(i))
*
BII = BB( KB1, I )
DO 20 J = I, I1
AB( I-J+KA1, J ) = AB( I-J+KA1, J ) / BII
20 CONTINUE
DO 30 J = MAX( 1, I-KA ), I
AB( J-I+KA1, I ) = AB( J-I+KA1, I ) / BII
30 CONTINUE
DO 60 K = I - KBT, I - 1
DO 40 J = I - KBT, K
AB( J-K+KA1, K ) = AB( J-K+KA1, K ) -
$ BB( J-I+KB1, I )*AB( K-I+KA1, I ) -
$ BB( K-I+KB1, I )*AB( J-I+KA1, I ) +
$ AB( KA1, I )*BB( J-I+KB1, I )*
$ BB( K-I+KB1, I )
40 CONTINUE
DO 50 J = MAX( 1, I-KA ), I - KBT - 1
AB( J-K+KA1, K ) = AB( J-K+KA1, K ) -
$ BB( K-I+KB1, I )*AB( J-I+KA1, I )
50 CONTINUE
60 CONTINUE
DO 80 J = I, I1
DO 70 K = MAX( J-KA, I-KBT ), I - 1
AB( K-J+KA1, J ) = AB( K-J+KA1, J ) -
$ BB( K-I+KB1, I )*AB( I-J+KA1, J )
70 CONTINUE
80 CONTINUE
*
IF( WANTX ) THEN
*
* post-multiply X by inv(S(i))
*
CALL SSCAL( N-M, ONE / BII, X( M+1, I ), 1 )
IF( KBT.GT.0 )
$ CALL SGER( N-M, KBT, -ONE, X( M+1, I ), 1,
$ BB( KB1-KBT, I ), 1, X( M+1, I-KBT ), LDX )
END IF
*
* store a(i,i1) in RA1 for use in next loop over K
*
RA1 = AB( I-I1+KA1, I1 )
END IF
*
* Generate and apply vectors of rotations to chase all the
* existing bulges KA positions down toward the bottom of the
* band
*
DO 130 K = 1, KB - 1
IF( UPDATE ) THEN
*
* Determine the rotations which would annihilate the bulge
* which has in theory just been created
*
IF( I-K+KA.LT.N .AND. I-K.GT.1 ) THEN
*
* generate rotation to annihilate a(i,i-k+ka+1)
*
CALL SLARTG( AB( K+1, I-K+KA ), RA1,
$ WORK( N+I-K+KA-M ), WORK( I-K+KA-M ),
$ RA )
*
* create nonzero element a(i-k,i-k+ka+1) outside the
* band and store it in WORK(i-k)
*
T = -BB( KB1-K, I )*RA1
WORK( I-K ) = WORK( N+I-K+KA-M )*T -
$ WORK( I-K+KA-M )*AB( 1, I-K+KA )
AB( 1, I-K+KA ) = WORK( I-K+KA-M )*T +
$ WORK( N+I-K+KA-M )*AB( 1, I-K+KA )
RA1 = RA
END IF
END IF
J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
NR = ( N-J2+KA ) / KA1
J1 = J2 + ( NR-1 )*KA1
IF( UPDATE ) THEN
J2T = MAX( J2, I+2*KA-K+1 )
ELSE
J2T = J2
END IF
NRT = ( N-J2T+KA ) / KA1
DO 90 J = J2T, J1, KA1
*
* create nonzero element a(j-ka,j+1) outside the band
* and store it in WORK(j-m)
*
WORK( J-M ) = WORK( J-M )*AB( 1, J+1 )
AB( 1, J+1 ) = WORK( N+J-M )*AB( 1, J+1 )
90 CONTINUE
*
* generate rotations in 1st set to annihilate elements which
* have been created outside the band
*
IF( NRT.GT.0 )
$ CALL SLARGV( NRT, AB( 1, J2T ), INCA, WORK( J2T-M ), KA1,
$ WORK( N+J2T-M ), KA1 )
IF( NR.GT.0 ) THEN
*
* apply rotations in 1st set from the right
*
DO 100 L = 1, KA - 1
CALL SLARTV( NR, AB( KA1-L, J2 ), INCA,
$ AB( KA-L, J2+1 ), INCA, WORK( N+J2-M ),
$ WORK( J2-M ), KA1 )
100 CONTINUE
*
* apply rotations in 1st set from both sides to diagonal
* blocks
*
CALL SLAR2V( NR, AB( KA1, J2 ), AB( KA1, J2+1 ),
$ AB( KA, J2+1 ), INCA, WORK( N+J2-M ),
$ WORK( J2-M ), KA1 )
*
END IF
*
* start applying rotations in 1st set from the left
*
DO 110 L = KA - 1, KB - K + 1, -1
NRT = ( N-J2+L ) / KA1
IF( NRT.GT.0 )
$ CALL SLARTV( NRT, AB( L, J2+KA1-L ), INCA,
$ AB( L+1, J2+KA1-L ), INCA,
$ WORK( N+J2-M ), WORK( J2-M ), KA1 )
110 CONTINUE
*
IF( WANTX ) THEN
*
* post-multiply X by product of rotations in 1st set
*
DO 120 J = J2, J1, KA1
CALL SROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
$ WORK( N+J-M ), WORK( J-M ) )
120 CONTINUE
END IF
130 CONTINUE
*
IF( UPDATE ) THEN
IF( I2.LE.N .AND. KBT.GT.0 ) THEN
*
* create nonzero element a(i-kbt,i-kbt+ka+1) outside the
* band and store it in WORK(i-kbt)
*
WORK( I-KBT ) = -BB( KB1-KBT, I )*RA1
END IF
END IF
*
DO 170 K = KB, 1, -1
IF( UPDATE ) THEN
J2 = I - K - 1 + MAX( 2, K-I0+1 )*KA1
ELSE
J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
END IF
*
* finish applying rotations in 2nd set from the left
*
DO 140 L = KB - K, 1, -1
NRT = ( N-J2+KA+L ) / KA1
IF( NRT.GT.0 )
$ CALL SLARTV( NRT, AB( L, J2-L+1 ), INCA,
$ AB( L+1, J2-L+1 ), INCA, WORK( N+J2-KA ),
$ WORK( J2-KA ), KA1 )
140 CONTINUE
NR = ( N-J2+KA ) / KA1
J1 = J2 + ( NR-1 )*KA1
DO 150 J = J1, J2, -KA1
WORK( J ) = WORK( J-KA )
WORK( N+J ) = WORK( N+J-KA )
150 CONTINUE
DO 160 J = J2, J1, KA1
*
* create nonzero element a(j-ka,j+1) outside the band
* and store it in WORK(j)
*
WORK( J ) = WORK( J )*AB( 1, J+1 )
AB( 1, J+1 ) = WORK( N+J )*AB( 1, J+1 )
160 CONTINUE
IF( UPDATE ) THEN
IF( I-K.LT.N-KA .AND. K.LE.KBT )
$ WORK( I-K+KA ) = WORK( I-K )
END IF
170 CONTINUE
*
DO 210 K = KB, 1, -1
J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
NR = ( N-J2+KA ) / KA1
J1 = J2 + ( NR-1 )*KA1
IF( NR.GT.0 ) THEN
*
* generate rotations in 2nd set to annihilate elements
* which have been created outside the band
*
CALL SLARGV( NR, AB( 1, J2 ), INCA, WORK( J2 ), KA1,
$ WORK( N+J2 ), KA1 )
*
* apply rotations in 2nd set from the right
*
DO 180 L = 1, KA - 1
CALL SLARTV( NR, AB( KA1-L, J2 ), INCA,
$ AB( KA-L, J2+1 ), INCA, WORK( N+J2 ),
$ WORK( J2 ), KA1 )
180 CONTINUE
*
* apply rotations in 2nd set from both sides to diagonal
* blocks
*
CALL SLAR2V( NR, AB( KA1, J2 ), AB( KA1, J2+1 ),
$ AB( KA, J2+1 ), INCA, WORK( N+J2 ),
$ WORK( J2 ), KA1 )
*
END IF
*
* start applying rotations in 2nd set from the left
*
DO 190 L = KA - 1, KB - K + 1, -1
NRT = ( N-J2+L ) / KA1
IF( NRT.GT.0 )
$ CALL SLARTV( NRT, AB( L, J2+KA1-L ), INCA,
$ AB( L+1, J2+KA1-L ), INCA, WORK( N+J2 ),
$ WORK( J2 ), KA1 )
190 CONTINUE
*
IF( WANTX ) THEN
*
* post-multiply X by product of rotations in 2nd set
*
DO 200 J = J2, J1, KA1
CALL SROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
$ WORK( N+J ), WORK( J ) )
200 CONTINUE
END IF
210 CONTINUE
*
DO 230 K = 1, KB - 1
J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
*
* finish applying rotations in 1st set from the left
*
DO 220 L = KB - K, 1, -1
NRT = ( N-J2+L ) / KA1
IF( NRT.GT.0 )
$ CALL SLARTV( NRT, AB( L, J2+KA1-L ), INCA,
$ AB( L+1, J2+KA1-L ), INCA,
$ WORK( N+J2-M ), WORK( J2-M ), KA1 )
220 CONTINUE
230 CONTINUE
*
IF( KB.GT.1 ) THEN
DO 240 J = N - 1, I - KB + 2*KA + 1, -1
WORK( N+J-M ) = WORK( N+J-KA-M )
WORK( J-M ) = WORK( J-KA-M )
240 CONTINUE
END IF
*
ELSE
*
* Transform A, working with the lower triangle
*
IF( UPDATE ) THEN
*
* Form inv(S(i))**T * A * inv(S(i))
*
BII = BB( 1, I )
DO 250 J = I, I1
AB( J-I+1, I ) = AB( J-I+1, I ) / BII
250 CONTINUE
DO 260 J = MAX( 1, I-KA ), I
AB( I-J+1, J ) = AB( I-J+1, J ) / BII
260 CONTINUE
DO 290 K = I - KBT, I - 1
DO 270 J = I - KBT, K
AB( K-J+1, J ) = AB( K-J+1, J ) -
$ BB( I-J+1, J )*AB( I-K+1, K ) -
$ BB( I-K+1, K )*AB( I-J+1, J ) +
$ AB( 1, I )*BB( I-J+1, J )*
$ BB( I-K+1, K )
270 CONTINUE
DO 280 J = MAX( 1, I-KA ), I - KBT - 1
AB( K-J+1, J ) = AB( K-J+1, J ) -
$ BB( I-K+1, K )*AB( I-J+1, J )
280 CONTINUE
290 CONTINUE
DO 310 J = I, I1
DO 300 K = MAX( J-KA, I-KBT ), I - 1
AB( J-K+1, K ) = AB( J-K+1, K ) -
$ BB( I-K+1, K )*AB( J-I+1, I )
300 CONTINUE
310 CONTINUE
*
IF( WANTX ) THEN
*
* post-multiply X by inv(S(i))
*
CALL SSCAL( N-M, ONE / BII, X( M+1, I ), 1 )
IF( KBT.GT.0 )
$ CALL SGER( N-M, KBT, -ONE, X( M+1, I ), 1,
$ BB( KBT+1, I-KBT ), LDBB-1,
$ X( M+1, I-KBT ), LDX )
END IF
*
* store a(i1,i) in RA1 for use in next loop over K
*
RA1 = AB( I1-I+1, I )
END IF
*
* Generate and apply vectors of rotations to chase all the
* existing bulges KA positions down toward the bottom of the
* band
*
DO 360 K = 1, KB - 1
IF( UPDATE ) THEN
*
* Determine the rotations which would annihilate the bulge
* which has in theory just been created
*
IF( I-K+KA.LT.N .AND. I-K.GT.1 ) THEN
*
* generate rotation to annihilate a(i-k+ka+1,i)
*
CALL SLARTG( AB( KA1-K, I ), RA1, WORK( N+I-K+KA-M ),
$ WORK( I-K+KA-M ), RA )
*
* create nonzero element a(i-k+ka+1,i-k) outside the
* band and store it in WORK(i-k)
*
T = -BB( K+1, I-K )*RA1
WORK( I-K ) = WORK( N+I-K+KA-M )*T -
$ WORK( I-K+KA-M )*AB( KA1, I-K )
AB( KA1, I-K ) = WORK( I-K+KA-M )*T +
$ WORK( N+I-K+KA-M )*AB( KA1, I-K )
RA1 = RA
END IF
END IF
J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
NR = ( N-J2+KA ) / KA1
J1 = J2 + ( NR-1 )*KA1
IF( UPDATE ) THEN
J2T = MAX( J2, I+2*KA-K+1 )
ELSE
J2T = J2
END IF
NRT = ( N-J2T+KA ) / KA1
DO 320 J = J2T, J1, KA1
*
* create nonzero element a(j+1,j-ka) outside the band
* and store it in WORK(j-m)
*
WORK( J-M ) = WORK( J-M )*AB( KA1, J-KA+1 )
AB( KA1, J-KA+1 ) = WORK( N+J-M )*AB( KA1, J-KA+1 )
320 CONTINUE
*
* generate rotations in 1st set to annihilate elements which
* have been created outside the band
*
IF( NRT.GT.0 )
$ CALL SLARGV( NRT, AB( KA1, J2T-KA ), INCA, WORK( J2T-M ),
$ KA1, WORK( N+J2T-M ), KA1 )
IF( NR.GT.0 ) THEN
*
* apply rotations in 1st set from the left
*
DO 330 L = 1, KA - 1
CALL SLARTV( NR, AB( L+1, J2-L ), INCA,
$ AB( L+2, J2-L ), INCA, WORK( N+J2-M ),
$ WORK( J2-M ), KA1 )
330 CONTINUE
*
* apply rotations in 1st set from both sides to diagonal
* blocks
*
CALL SLAR2V( NR, AB( 1, J2 ), AB( 1, J2+1 ), AB( 2, J2 ),
$ INCA, WORK( N+J2-M ), WORK( J2-M ), KA1 )
*
END IF
*
* start applying rotations in 1st set from the right
*
DO 340 L = KA - 1, KB - K + 1, -1
NRT = ( N-J2+L ) / KA1
IF( NRT.GT.0 )
$ CALL SLARTV( NRT, AB( KA1-L+1, J2 ), INCA,
$ AB( KA1-L, J2+1 ), INCA, WORK( N+J2-M ),
$ WORK( J2-M ), KA1 )
340 CONTINUE
*
IF( WANTX ) THEN
*
* post-multiply X by product of rotations in 1st set
*
DO 350 J = J2, J1, KA1
CALL SROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
$ WORK( N+J-M ), WORK( J-M ) )
350 CONTINUE
END IF
360 CONTINUE
*
IF( UPDATE ) THEN
IF( I2.LE.N .AND. KBT.GT.0 ) THEN
*
* create nonzero element a(i-kbt+ka+1,i-kbt) outside the
* band and store it in WORK(i-kbt)
*
WORK( I-KBT ) = -BB( KBT+1, I-KBT )*RA1
END IF
END IF
*
DO 400 K = KB, 1, -1
IF( UPDATE ) THEN
J2 = I - K - 1 + MAX( 2, K-I0+1 )*KA1
ELSE
J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
END IF
*
* finish applying rotations in 2nd set from the right
*
DO 370 L = KB - K, 1, -1
NRT = ( N-J2+KA+L ) / KA1
IF( NRT.GT.0 )
$ CALL SLARTV( NRT, AB( KA1-L+1, J2-KA ), INCA,
$ AB( KA1-L, J2-KA+1 ), INCA,
$ WORK( N+J2-KA ), WORK( J2-KA ), KA1 )
370 CONTINUE
NR = ( N-J2+KA ) / KA1
J1 = J2 + ( NR-1 )*KA1
DO 380 J = J1, J2, -KA1
WORK( J ) = WORK( J-KA )
WORK( N+J ) = WORK( N+J-KA )
380 CONTINUE
DO 390 J = J2, J1, KA1
*
* create nonzero element a(j+1,j-ka) outside the band
* and store it in WORK(j)
*
WORK( J ) = WORK( J )*AB( KA1, J-KA+1 )
AB( KA1, J-KA+1 ) = WORK( N+J )*AB( KA1, J-KA+1 )
390 CONTINUE
IF( UPDATE ) THEN
IF( I-K.LT.N-KA .AND. K.LE.KBT )
$ WORK( I-K+KA ) = WORK( I-K )
END IF
400 CONTINUE
*
DO 440 K = KB, 1, -1
J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
NR = ( N-J2+KA ) / KA1
J1 = J2 + ( NR-1 )*KA1
IF( NR.GT.0 ) THEN
*
* generate rotations in 2nd set to annihilate elements
* which have been created outside the band
*
CALL SLARGV( NR, AB( KA1, J2-KA ), INCA, WORK( J2 ), KA1,
$ WORK( N+J2 ), KA1 )
*
* apply rotations in 2nd set from the left
*
DO 410 L = 1, KA - 1
CALL SLARTV( NR, AB( L+1, J2-L ), INCA,
$ AB( L+2, J2-L ), INCA, WORK( N+J2 ),
$ WORK( J2 ), KA1 )
410 CONTINUE
*
* apply rotations in 2nd set from both sides to diagonal
* blocks
*
CALL SLAR2V( NR, AB( 1, J2 ), AB( 1, J2+1 ), AB( 2, J2 ),
$ INCA, WORK( N+J2 ), WORK( J2 ), KA1 )
*
END IF
*
* start applying rotations in 2nd set from the right
*
DO 420 L = KA - 1, KB - K + 1, -1
NRT = ( N-J2+L ) / KA1
IF( NRT.GT.0 )
$ CALL SLARTV( NRT, AB( KA1-L+1, J2 ), INCA,
$ AB( KA1-L, J2+1 ), INCA, WORK( N+J2 ),
$ WORK( J2 ), KA1 )
420 CONTINUE
*
IF( WANTX ) THEN
*
* post-multiply X by product of rotations in 2nd set
*
DO 430 J = J2, J1, KA1
CALL SROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
$ WORK( N+J ), WORK( J ) )
430 CONTINUE
END IF
440 CONTINUE
*
DO 460 K = 1, KB - 1
J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
*
* finish applying rotations in 1st set from the right
*
DO 450 L = KB - K, 1, -1
NRT = ( N-J2+L ) / KA1
IF( NRT.GT.0 )
$ CALL SLARTV( NRT, AB( KA1-L+1, J2 ), INCA,
$ AB( KA1-L, J2+1 ), INCA, WORK( N+J2-M ),
$ WORK( J2-M ), KA1 )
450 CONTINUE
460 CONTINUE
*
IF( KB.GT.1 ) THEN
DO 470 J = N - 1, I - KB + 2*KA + 1, -1
WORK( N+J-M ) = WORK( N+J-KA-M )
WORK( J-M ) = WORK( J-KA-M )
470 CONTINUE
END IF
*
END IF
*
GO TO 10
*
480 CONTINUE
*
* **************************** Phase 2 *****************************
*
* The logical structure of this phase is:
*
* UPDATE = .TRUE.
* DO I = 1, M
* use S(i) to update A and create a new bulge
* apply rotations to push all bulges KA positions upward
* END DO
* UPDATE = .FALSE.
* DO I = M - KA - 1, 2, -1
* apply rotations to push all bulges KA positions upward
* END DO
*
* To avoid duplicating code, the two loops are merged.
*
UPDATE = .TRUE.
I = 0
490 CONTINUE
IF( UPDATE ) THEN
I = I + 1
KBT = MIN( KB, M-I )
I0 = I + 1
I1 = MAX( 1, I-KA )
I2 = I + KBT - KA1
IF( I.GT.M ) THEN
UPDATE = .FALSE.
I = I - 1
I0 = M + 1
IF( KA.EQ.0 )
$ RETURN
GO TO 490
END IF
ELSE
I = I - KA
IF( I.LT.2 )
$ RETURN
END IF
*
IF( I.LT.M-KBT ) THEN
NX = M
ELSE
NX = N
END IF
*
IF( UPPER ) THEN
*
* Transform A, working with the upper triangle
*
IF( UPDATE ) THEN
*
* Form inv(S(i))**T * A * inv(S(i))
*
BII = BB( KB1, I )
DO 500 J = I1, I
AB( J-I+KA1, I ) = AB( J-I+KA1, I ) / BII
500 CONTINUE
DO 510 J = I, MIN( N, I+KA )
AB( I-J+KA1, J ) = AB( I-J+KA1, J ) / BII
510 CONTINUE
DO 540 K = I + 1, I + KBT
DO 520 J = K, I + KBT
AB( K-J+KA1, J ) = AB( K-J+KA1, J ) -
$ BB( I-J+KB1, J )*AB( I-K+KA1, K ) -
$ BB( I-K+KB1, K )*AB( I-J+KA1, J ) +
$ AB( KA1, I )*BB( I-J+KB1, J )*
$ BB( I-K+KB1, K )
520 CONTINUE
DO 530 J = I + KBT + 1, MIN( N, I+KA )
AB( K-J+KA1, J ) = AB( K-J+KA1, J ) -
$ BB( I-K+KB1, K )*AB( I-J+KA1, J )
530 CONTINUE
540 CONTINUE
DO 560 J = I1, I
DO 550 K = I + 1, MIN( J+KA, I+KBT )
AB( J-K+KA1, K ) = AB( J-K+KA1, K ) -
$ BB( I-K+KB1, K )*AB( J-I+KA1, I )
550 CONTINUE
560 CONTINUE
*
IF( WANTX ) THEN
*
* post-multiply X by inv(S(i))
*
CALL SSCAL( NX, ONE / BII, X( 1, I ), 1 )
IF( KBT.GT.0 )
$ CALL SGER( NX, KBT, -ONE, X( 1, I ), 1, BB( KB, I+1 ),
$ LDBB-1, X( 1, I+1 ), LDX )
END IF
*
* store a(i1,i) in RA1 for use in next loop over K
*
RA1 = AB( I1-I+KA1, I )
END IF
*
* Generate and apply vectors of rotations to chase all the
* existing bulges KA positions up toward the top of the band
*
DO 610 K = 1, KB - 1
IF( UPDATE ) THEN
*
* Determine the rotations which would annihilate the bulge
* which has in theory just been created
*
IF( I+K-KA1.GT.0 .AND. I+K.LT.M ) THEN
*
* generate rotation to annihilate a(i+k-ka-1,i)
*
CALL SLARTG( AB( K+1, I ), RA1, WORK( N+I+K-KA ),
$ WORK( I+K-KA ), RA )
*
* create nonzero element a(i+k-ka-1,i+k) outside the
* band and store it in WORK(m-kb+i+k)
*
T = -BB( KB1-K, I+K )*RA1
WORK( M-KB+I+K ) = WORK( N+I+K-KA )*T -
$ WORK( I+K-KA )*AB( 1, I+K )
AB( 1, I+K ) = WORK( I+K-KA )*T +
$ WORK( N+I+K-KA )*AB( 1, I+K )
RA1 = RA
END IF
END IF
J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
NR = ( J2+KA-1 ) / KA1
J1 = J2 - ( NR-1 )*KA1
IF( UPDATE ) THEN
J2T = MIN( J2, I-2*KA+K-1 )
ELSE
J2T = J2
END IF
NRT = ( J2T+KA-1 ) / KA1
DO 570 J = J1, J2T, KA1
*
* create nonzero element a(j-1,j+ka) outside the band
* and store it in WORK(j)
*
WORK( J ) = WORK( J )*AB( 1, J+KA-1 )
AB( 1, J+KA-1 ) = WORK( N+J )*AB( 1, J+KA-1 )
570 CONTINUE
*
* generate rotations in 1st set to annihilate elements which
* have been created outside the band
*
IF( NRT.GT.0 )
$ CALL SLARGV( NRT, AB( 1, J1+KA ), INCA, WORK( J1 ), KA1,
$ WORK( N+J1 ), KA1 )
IF( NR.GT.0 ) THEN
*
* apply rotations in 1st set from the left
*
DO 580 L = 1, KA - 1
CALL SLARTV( NR, AB( KA1-L, J1+L ), INCA,
$ AB( KA-L, J1+L ), INCA, WORK( N+J1 ),
$ WORK( J1 ), KA1 )
580 CONTINUE
*
* apply rotations in 1st set from both sides to diagonal
* blocks
*
CALL SLAR2V( NR, AB( KA1, J1 ), AB( KA1, J1-1 ),
$ AB( KA, J1 ), INCA, WORK( N+J1 ),
$ WORK( J1 ), KA1 )
*
END IF
*
* start applying rotations in 1st set from the right
*
DO 590 L = KA - 1, KB - K + 1, -1
NRT = ( J2+L-1 ) / KA1
J1T = J2 - ( NRT-1 )*KA1
IF( NRT.GT.0 )
$ CALL SLARTV( NRT, AB( L, J1T ), INCA,
$ AB( L+1, J1T-1 ), INCA, WORK( N+J1T ),
$ WORK( J1T ), KA1 )
590 CONTINUE
*
IF( WANTX ) THEN
*
* post-multiply X by product of rotations in 1st set
*
DO 600 J = J1, J2, KA1
CALL SROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
$ WORK( N+J ), WORK( J ) )
600 CONTINUE
END IF
610 CONTINUE
*
IF( UPDATE ) THEN
IF( I2.GT.0 .AND. KBT.GT.0 ) THEN
*
* create nonzero element a(i+kbt-ka-1,i+kbt) outside the
* band and store it in WORK(m-kb+i+kbt)
*
WORK( M-KB+I+KBT ) = -BB( KB1-KBT, I+KBT )*RA1
END IF
END IF
*
DO 650 K = KB, 1, -1
IF( UPDATE ) THEN
J2 = I + K + 1 - MAX( 2, K+I0-M )*KA1
ELSE
J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
END IF
*
* finish applying rotations in 2nd set from the right
*
DO 620 L = KB - K, 1, -1
NRT = ( J2+KA+L-1 ) / KA1
J1T = J2 - ( NRT-1 )*KA1
IF( NRT.GT.0 )
$ CALL SLARTV( NRT, AB( L, J1T+KA ), INCA,
$ AB( L+1, J1T+KA-1 ), INCA,
$ WORK( N+M-KB+J1T+KA ),
$ WORK( M-KB+J1T+KA ), KA1 )
620 CONTINUE
NR = ( J2+KA-1 ) / KA1
J1 = J2 - ( NR-1 )*KA1
DO 630 J = J1, J2, KA1
WORK( M-KB+J ) = WORK( M-KB+J+KA )
WORK( N+M-KB+J ) = WORK( N+M-KB+J+KA )
630 CONTINUE
DO 640 J = J1, J2, KA1
*
* create nonzero element a(j-1,j+ka) outside the band
* and store it in WORK(m-kb+j)
*
WORK( M-KB+J ) = WORK( M-KB+J )*AB( 1, J+KA-1 )
AB( 1, J+KA-1 ) = WORK( N+M-KB+J )*AB( 1, J+KA-1 )
640 CONTINUE
IF( UPDATE ) THEN
IF( I+K.GT.KA1 .AND. K.LE.KBT )
$ WORK( M-KB+I+K-KA ) = WORK( M-KB+I+K )
END IF
650 CONTINUE
*
DO 690 K = KB, 1, -1
J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
NR = ( J2+KA-1 ) / KA1
J1 = J2 - ( NR-1 )*KA1
IF( NR.GT.0 ) THEN
*
* generate rotations in 2nd set to annihilate elements
* which have been created outside the band
*
CALL SLARGV( NR, AB( 1, J1+KA ), INCA, WORK( M-KB+J1 ),
$ KA1, WORK( N+M-KB+J1 ), KA1 )
*
* apply rotations in 2nd set from the left
*
DO 660 L = 1, KA - 1
CALL SLARTV( NR, AB( KA1-L, J1+L ), INCA,
$ AB( KA-L, J1+L ), INCA,
$ WORK( N+M-KB+J1 ), WORK( M-KB+J1 ), KA1 )
660 CONTINUE
*
* apply rotations in 2nd set from both sides to diagonal
* blocks
*
CALL SLAR2V( NR, AB( KA1, J1 ), AB( KA1, J1-1 ),
$ AB( KA, J1 ), INCA, WORK( N+M-KB+J1 ),
$ WORK( M-KB+J1 ), KA1 )
*
END IF
*
* start applying rotations in 2nd set from the right
*
DO 670 L = KA - 1, KB - K + 1, -1
NRT = ( J2+L-1 ) / KA1
J1T = J2 - ( NRT-1 )*KA1
IF( NRT.GT.0 )
$ CALL SLARTV( NRT, AB( L, J1T ), INCA,
$ AB( L+1, J1T-1 ), INCA,
$ WORK( N+M-KB+J1T ), WORK( M-KB+J1T ),
$ KA1 )
670 CONTINUE
*
IF( WANTX ) THEN
*
* post-multiply X by product of rotations in 2nd set
*
DO 680 J = J1, J2, KA1
CALL SROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
$ WORK( N+M-KB+J ), WORK( M-KB+J ) )
680 CONTINUE
END IF
690 CONTINUE
*
DO 710 K = 1, KB - 1
J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
*
* finish applying rotations in 1st set from the right
*
DO 700 L = KB - K, 1, -1
NRT = ( J2+L-1 ) / KA1
J1T = J2 - ( NRT-1 )*KA1
IF( NRT.GT.0 )
$ CALL SLARTV( NRT, AB( L, J1T ), INCA,
$ AB( L+1, J1T-1 ), INCA, WORK( N+J1T ),
$ WORK( J1T ), KA1 )
700 CONTINUE
710 CONTINUE
*
IF( KB.GT.1 ) THEN
DO 720 J = 2, MIN( I+KB, M ) - 2*KA - 1
WORK( N+J ) = WORK( N+J+KA )
WORK( J ) = WORK( J+KA )
720 CONTINUE
END IF
*
ELSE
*
* Transform A, working with the lower triangle
*
IF( UPDATE ) THEN
*
* Form inv(S(i))**T * A * inv(S(i))
*
BII = BB( 1, I )
DO 730 J = I1, I
AB( I-J+1, J ) = AB( I-J+1, J ) / BII
730 CONTINUE
DO 740 J = I, MIN( N, I+KA )
AB( J-I+1, I ) = AB( J-I+1, I ) / BII
740 CONTINUE
DO 770 K = I + 1, I + KBT
DO 750 J = K, I + KBT
AB( J-K+1, K ) = AB( J-K+1, K ) -
$ BB( J-I+1, I )*AB( K-I+1, I ) -
$ BB( K-I+1, I )*AB( J-I+1, I ) +
$ AB( 1, I )*BB( J-I+1, I )*
$ BB( K-I+1, I )
750 CONTINUE
DO 760 J = I + KBT + 1, MIN( N, I+KA )
AB( J-K+1, K ) = AB( J-K+1, K ) -
$ BB( K-I+1, I )*AB( J-I+1, I )
760 CONTINUE
770 CONTINUE
DO 790 J = I1, I
DO 780 K = I + 1, MIN( J+KA, I+KBT )
AB( K-J+1, J ) = AB( K-J+1, J ) -
$ BB( K-I+1, I )*AB( I-J+1, J )
780 CONTINUE
790 CONTINUE
*
IF( WANTX ) THEN
*
* post-multiply X by inv(S(i))
*
CALL SSCAL( NX, ONE / BII, X( 1, I ), 1 )
IF( KBT.GT.0 )
$ CALL SGER( NX, KBT, -ONE, X( 1, I ), 1, BB( 2, I ), 1,
$ X( 1, I+1 ), LDX )
END IF
*
* store a(i,i1) in RA1 for use in next loop over K
*
RA1 = AB( I-I1+1, I1 )
END IF
*
* Generate and apply vectors of rotations to chase all the
* existing bulges KA positions up toward the top of the band
*
DO 840 K = 1, KB - 1
IF( UPDATE ) THEN
*
* Determine the rotations which would annihilate the bulge
* which has in theory just been created
*
IF( I+K-KA1.GT.0 .AND. I+K.LT.M ) THEN
*
* generate rotation to annihilate a(i,i+k-ka-1)
*
CALL SLARTG( AB( KA1-K, I+K-KA ), RA1,
$ WORK( N+I+K-KA ), WORK( I+K-KA ), RA )
*
* create nonzero element a(i+k,i+k-ka-1) outside the
* band and store it in WORK(m-kb+i+k)
*
T = -BB( K+1, I )*RA1
WORK( M-KB+I+K ) = WORK( N+I+K-KA )*T -
$ WORK( I+K-KA )*AB( KA1, I+K-KA )
AB( KA1, I+K-KA ) = WORK( I+K-KA )*T +
$ WORK( N+I+K-KA )*AB( KA1, I+K-KA )
RA1 = RA
END IF
END IF
J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
NR = ( J2+KA-1 ) / KA1
J1 = J2 - ( NR-1 )*KA1
IF( UPDATE ) THEN
J2T = MIN( J2, I-2*KA+K-1 )
ELSE
J2T = J2
END IF
NRT = ( J2T+KA-1 ) / KA1
DO 800 J = J1, J2T, KA1
*
* create nonzero element a(j+ka,j-1) outside the band
* and store it in WORK(j)
*
WORK( J ) = WORK( J )*AB( KA1, J-1 )
AB( KA1, J-1 ) = WORK( N+J )*AB( KA1, J-1 )
800 CONTINUE
*
* generate rotations in 1st set to annihilate elements which
* have been created outside the band
*
IF( NRT.GT.0 )
$ CALL SLARGV( NRT, AB( KA1, J1 ), INCA, WORK( J1 ), KA1,
$ WORK( N+J1 ), KA1 )
IF( NR.GT.0 ) THEN
*
* apply rotations in 1st set from the right
*
DO 810 L = 1, KA - 1
CALL SLARTV( NR, AB( L+1, J1 ), INCA, AB( L+2, J1-1 ),
$ INCA, WORK( N+J1 ), WORK( J1 ), KA1 )
810 CONTINUE
*
* apply rotations in 1st set from both sides to diagonal
* blocks
*
CALL SLAR2V( NR, AB( 1, J1 ), AB( 1, J1-1 ),
$ AB( 2, J1-1 ), INCA, WORK( N+J1 ),
$ WORK( J1 ), KA1 )
*
END IF
*
* start applying rotations in 1st set from the left
*
DO 820 L = KA - 1, KB - K + 1, -1
NRT = ( J2+L-1 ) / KA1
J1T = J2 - ( NRT-1 )*KA1
IF( NRT.GT.0 )
$ CALL SLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA,
$ AB( KA1-L, J1T-KA1+L ), INCA,
$ WORK( N+J1T ), WORK( J1T ), KA1 )
820 CONTINUE
*
IF( WANTX ) THEN
*
* post-multiply X by product of rotations in 1st set
*
DO 830 J = J1, J2, KA1
CALL SROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
$ WORK( N+J ), WORK( J ) )
830 CONTINUE
END IF
840 CONTINUE
*
IF( UPDATE ) THEN
IF( I2.GT.0 .AND. KBT.GT.0 ) THEN
*
* create nonzero element a(i+kbt,i+kbt-ka-1) outside the
* band and store it in WORK(m-kb+i+kbt)
*
WORK( M-KB+I+KBT ) = -BB( KBT+1, I )*RA1
END IF
END IF
*
DO 880 K = KB, 1, -1
IF( UPDATE ) THEN
J2 = I + K + 1 - MAX( 2, K+I0-M )*KA1
ELSE
J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
END IF
*
* finish applying rotations in 2nd set from the left
*
DO 850 L = KB - K, 1, -1
NRT = ( J2+KA+L-1 ) / KA1
J1T = J2 - ( NRT-1 )*KA1
IF( NRT.GT.0 )
$ CALL SLARTV( NRT, AB( KA1-L+1, J1T+L-1 ), INCA,
$ AB( KA1-L, J1T+L-1 ), INCA,
$ WORK( N+M-KB+J1T+KA ),
$ WORK( M-KB+J1T+KA ), KA1 )
850 CONTINUE
NR = ( J2+KA-1 ) / KA1
J1 = J2 - ( NR-1 )*KA1
DO 860 J = J1, J2, KA1
WORK( M-KB+J ) = WORK( M-KB+J+KA )
WORK( N+M-KB+J ) = WORK( N+M-KB+J+KA )
860 CONTINUE
DO 870 J = J1, J2, KA1
*
* create nonzero element a(j+ka,j-1) outside the band
* and store it in WORK(m-kb+j)
*
WORK( M-KB+J ) = WORK( M-KB+J )*AB( KA1, J-1 )
AB( KA1, J-1 ) = WORK( N+M-KB+J )*AB( KA1, J-1 )
870 CONTINUE
IF( UPDATE ) THEN
IF( I+K.GT.KA1 .AND. K.LE.KBT )
$ WORK( M-KB+I+K-KA ) = WORK( M-KB+I+K )
END IF
880 CONTINUE
*
DO 920 K = KB, 1, -1
J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
NR = ( J2+KA-1 ) / KA1
J1 = J2 - ( NR-1 )*KA1
IF( NR.GT.0 ) THEN
*
* generate rotations in 2nd set to annihilate elements
* which have been created outside the band
*
CALL SLARGV( NR, AB( KA1, J1 ), INCA, WORK( M-KB+J1 ),
$ KA1, WORK( N+M-KB+J1 ), KA1 )
*
* apply rotations in 2nd set from the right
*
DO 890 L = 1, KA - 1
CALL SLARTV( NR, AB( L+1, J1 ), INCA, AB( L+2, J1-1 ),
$ INCA, WORK( N+M-KB+J1 ), WORK( M-KB+J1 ),
$ KA1 )
890 CONTINUE
*
* apply rotations in 2nd set from both sides to diagonal
* blocks
*
CALL SLAR2V( NR, AB( 1, J1 ), AB( 1, J1-1 ),
$ AB( 2, J1-1 ), INCA, WORK( N+M-KB+J1 ),
$ WORK( M-KB+J1 ), KA1 )
*
END IF
*
* start applying rotations in 2nd set from the left
*
DO 900 L = KA - 1, KB - K + 1, -1
NRT = ( J2+L-1 ) / KA1
J1T = J2 - ( NRT-1 )*KA1
IF( NRT.GT.0 )
$ CALL SLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA,
$ AB( KA1-L, J1T-KA1+L ), INCA,
$ WORK( N+M-KB+J1T ), WORK( M-KB+J1T ),
$ KA1 )
900 CONTINUE
*
IF( WANTX ) THEN
*
* post-multiply X by product of rotations in 2nd set
*
DO 910 J = J1, J2, KA1
CALL SROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
$ WORK( N+M-KB+J ), WORK( M-KB+J ) )
910 CONTINUE
END IF
920 CONTINUE
*
DO 940 K = 1, KB - 1
J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
*
* finish applying rotations in 1st set from the left
*
DO 930 L = KB - K, 1, -1
NRT = ( J2+L-1 ) / KA1
J1T = J2 - ( NRT-1 )*KA1
IF( NRT.GT.0 )
$ CALL SLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA,
$ AB( KA1-L, J1T-KA1+L ), INCA,
$ WORK( N+J1T ), WORK( J1T ), KA1 )
930 CONTINUE
940 CONTINUE
*
IF( KB.GT.1 ) THEN
DO 950 J = 2, MIN( I+KB, M ) - 2*KA - 1
WORK( N+J ) = WORK( N+J+KA )
WORK( J ) = WORK( J+KA )
950 CONTINUE
END IF
*
END IF
*
GO TO 490
*
* End of SSBGST
*
END
SUBROUTINE SSBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z,
$ LDZ, WORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, KA, KB, LDAB, LDBB, LDZ, N
* ..
* .. Array Arguments ..
REAL AB( LDAB, * ), BB( LDBB, * ), W( * ),
$ WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SSBGV computes all the eigenvalues, and optionally, the eigenvectors
* of a real generalized symmetric-definite banded eigenproblem, of
* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric
* and banded, and B is also positive definite.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangles of A and B are stored;
* = 'L': Lower triangles of A and B are stored.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* KA (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
*
* KB (input) INTEGER
* The number of superdiagonals of the matrix B if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KB >= 0.
*
* AB (input/output) REAL array, dimension (LDAB, N)
* On entry, the upper or lower triangle of the symmetric band
* matrix A, stored in the first ka+1 rows of the array. The
* j-th column of A is stored in the j-th column of the array AB
* as follows:
* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
*
* On exit, the contents of AB are destroyed.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KA+1.
*
* BB (input/output) REAL array, dimension (LDBB, N)
* On entry, the upper or lower triangle of the symmetric band
* matrix B, stored in the first kb+1 rows of the array. The
* j-th column of B is stored in the j-th column of the array BB
* as follows:
* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).
*
* On exit, the factor S from the split Cholesky factorization
* B = S**T*S, as returned by SPBSTF.
*
* LDBB (input) INTEGER
* The leading dimension of the array BB. LDBB >= KB+1.
*
* W (output) REAL array, dimension (N)
* If INFO = 0, the eigenvalues in ascending order.
*
* Z (output) REAL array, dimension (LDZ, N)
* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
* eigenvectors, with the i-th column of Z holding the
* eigenvector associated with W(i). The eigenvectors are
* normalized so that Z**T*B*Z = I.
* If JOBZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= N.
*
* WORK (workspace) REAL array, dimension (3*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, and i is:
* <= N: the algorithm failed to converge:
* i off-diagonal elements of an intermediate
* tridiagonal form did not converge to zero;
* > N: if INFO = N + i, for 1 <= i <= N, then SPBSTF
* returned INFO = i: B is not positive definite.
* The factorization of B could not be completed and
* no eigenvalues or eigenvectors were computed.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL UPPER, WANTZ
CHARACTER VECT
INTEGER IINFO, INDE, INDWRK
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SPBSTF, SSBGST, SSBTRD, SSTEQR, SSTERF, XERBLA
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
UPPER = LSAME( UPLO, 'U' )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( KA.LT.0 ) THEN
INFO = -4
ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
INFO = -5
ELSE IF( LDAB.LT.KA+1 ) THEN
INFO = -7
ELSE IF( LDBB.LT.KB+1 ) THEN
INFO = -9
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSBGV ', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Form a split Cholesky factorization of B.
*
CALL SPBSTF( UPLO, N, KB, BB, LDBB, INFO )
IF( INFO.NE.0 ) THEN
INFO = N + INFO
RETURN
END IF
*
* Transform problem to standard eigenvalue problem.
*
INDE = 1
INDWRK = INDE + N
CALL SSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Z, LDZ,
$ WORK( INDWRK ), IINFO )
*
* Reduce to tridiagonal form.
*
IF( WANTZ ) THEN
VECT = 'U'
ELSE
VECT = 'N'
END IF
CALL SSBTRD( VECT, UPLO, N, KA, AB, LDAB, W, WORK( INDE ), Z, LDZ,
$ WORK( INDWRK ), IINFO )
*
* For eigenvalues only, call SSTERF. For eigenvectors, call SSTEQR.
*
IF( .NOT.WANTZ ) THEN
CALL SSTERF( N, W, WORK( INDE ), INFO )
ELSE
CALL SSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ),
$ INFO )
END IF
RETURN
*
* End of SSBGV
*
END
SUBROUTINE SSBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W,
$ Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, KA, KB, LDAB, LDBB, LDZ, LIWORK, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL AB( LDAB, * ), BB( LDBB, * ), W( * ),
$ WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SSBGVD computes all the eigenvalues, and optionally, the eigenvectors
* of a real generalized symmetric-definite banded eigenproblem, of the
* form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric and
* banded, and B is also positive definite. If eigenvectors are
* desired, it uses a divide and conquer algorithm.
*
* The divide and conquer algorithm makes very mild assumptions about
* floating point arithmetic. It will work on machines with a guard
* digit in add/subtract, or on those binary machines without guard
* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
* Cray-2. It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangles of A and B are stored;
* = 'L': Lower triangles of A and B are stored.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* KA (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
*
* KB (input) INTEGER
* The number of superdiagonals of the matrix B if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KB >= 0.
*
* AB (input/output) REAL array, dimension (LDAB, N)
* On entry, the upper or lower triangle of the symmetric band
* matrix A, stored in the first ka+1 rows of the array. The
* j-th column of A is stored in the j-th column of the array AB
* as follows:
* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
*
* On exit, the contents of AB are destroyed.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KA+1.
*
* BB (input/output) REAL array, dimension (LDBB, N)
* On entry, the upper or lower triangle of the symmetric band
* matrix B, stored in the first kb+1 rows of the array. The
* j-th column of B is stored in the j-th column of the array BB
* as follows:
* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).
*
* On exit, the factor S from the split Cholesky factorization
* B = S**T*S, as returned by SPBSTF.
*
* LDBB (input) INTEGER
* The leading dimension of the array BB. LDBB >= KB+1.
*
* W (output) REAL array, dimension (N)
* If INFO = 0, the eigenvalues in ascending order.
*
* Z (output) REAL array, dimension (LDZ, N)
* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
* eigenvectors, with the i-th column of Z holding the
* eigenvector associated with W(i). The eigenvectors are
* normalized so Z**T*B*Z = I.
* If JOBZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace/output) REAL 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 N <= 1, LWORK >= 1.
* If JOBZ = 'N' and N > 1, LWORK >= 3*N.
* If JOBZ = 'V' and N > 1, LWORK >= 1 + 5*N + 2*N**2.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal sizes of the WORK and IWORK
* arrays, returns these values as the first entries of the WORK
* and IWORK arrays, and no error message related to LWORK or
* LIWORK is issued by XERBLA.
*
* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK.
* If JOBZ = 'N' or N <= 1, LIWORK >= 1.
* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal sizes of the WORK and
* IWORK arrays, returns these values as the first entries of
* the WORK and IWORK arrays, and no error message related to
* LWORK or LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, and i is:
* <= N: the algorithm failed to converge:
* i off-diagonal elements of an intermediate
* tridiagonal form did not converge to zero;
* > N: if INFO = N + i, for 1 <= i <= N, then SPBSTF
* returned INFO = i: B is not positive definite.
* The factorization of B could not be completed and
* no eigenvalues or eigenvectors were computed.
*
* Further Details
* ===============
*
* Based on contributions by
* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, UPPER, WANTZ
CHARACTER VECT
INTEGER IINFO, INDE, INDWK2, INDWRK, LIWMIN, LLWRK2,
$ LWMIN
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SLACPY, SPBSTF, SSBGST, SSBTRD, SSTEDC,
$ SSTERF, XERBLA
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
UPPER = LSAME( UPLO, 'U' )
LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
INFO = 0
IF( N.LE.1 ) THEN
LIWMIN = 1
LWMIN = 1
ELSE IF( WANTZ ) THEN
LIWMIN = 3 + 5*N
LWMIN = 1 + 5*N + 2*N**2
ELSE
LIWMIN = 1
LWMIN = 2*N
END IF
*
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( KA.LT.0 ) THEN
INFO = -4
ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
INFO = -5
ELSE IF( LDAB.LT.KA+1 ) THEN
INFO = -7
ELSE IF( LDBB.LT.KB+1 ) THEN
INFO = -9
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -12
END IF
*
IF( INFO.EQ.0 ) THEN
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -14
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -16
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSBGVD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Form a split Cholesky factorization of B.
*
CALL SPBSTF( UPLO, N, KB, BB, LDBB, INFO )
IF( INFO.NE.0 ) THEN
INFO = N + INFO
RETURN
END IF
*
* Transform problem to standard eigenvalue problem.
*
INDE = 1
INDWRK = INDE + N
INDWK2 = INDWRK + N*N
LLWRK2 = LWORK - INDWK2 + 1
CALL SSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Z, LDZ,
$ WORK( INDWRK ), IINFO )
*
* Reduce to tridiagonal form.
*
IF( WANTZ ) THEN
VECT = 'U'
ELSE
VECT = 'N'
END IF
CALL SSBTRD( VECT, UPLO, N, KA, AB, LDAB, W, WORK( INDE ), Z, LDZ,
$ WORK( INDWRK ), IINFO )
*
* For eigenvalues only, call SSTERF. For eigenvectors, call SSTEDC.
*
IF( .NOT.WANTZ ) THEN
CALL SSTERF( N, W, WORK( INDE ), INFO )
ELSE
CALL SSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N,
$ WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO )
CALL SGEMM( 'N', 'N', N, N, N, ONE, Z, LDZ, WORK( INDWRK ), N,
$ ZERO, WORK( INDWK2 ), N )
CALL SLACPY( 'A', N, N, WORK( INDWK2 ), N, Z, LDZ )
END IF
*
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
RETURN
*
* End of SSBGVD
*
END
SUBROUTINE SSBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB,
$ LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z,
$ LDZ, WORK, IWORK, IFAIL, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE, UPLO
INTEGER IL, INFO, IU, KA, KB, LDAB, LDBB, LDQ, LDZ, M,
$ N
REAL ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER IFAIL( * ), IWORK( * )
REAL AB( LDAB, * ), BB( LDBB, * ), Q( LDQ, * ),
$ W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SSBGVX computes selected eigenvalues, and optionally, eigenvectors
* of a real generalized symmetric-definite banded eigenproblem, of
* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric
* and banded, and B is also positive definite. Eigenvalues and
* eigenvectors can be selected by specifying either all eigenvalues,
* a range of values or a range of indices for the desired eigenvalues.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* RANGE (input) CHARACTER*1
* = 'A': all eigenvalues will be found.
* = 'V': all eigenvalues in the half-open interval (VL,VU]
* will be found.
* = 'I': the IL-th through IU-th eigenvalues will be found.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangles of A and B are stored;
* = 'L': Lower triangles of A and B are stored.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* KA (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
*
* KB (input) INTEGER
* The number of superdiagonals of the matrix B if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KB >= 0.
*
* AB (input/output) REAL array, dimension (LDAB, N)
* On entry, the upper or lower triangle of the symmetric band
* matrix A, stored in the first ka+1 rows of the array. The
* j-th column of A is stored in the j-th column of the array AB
* as follows:
* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
*
* On exit, the contents of AB are destroyed.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KA+1.
*
* BB (input/output) REAL array, dimension (LDBB, N)
* On entry, the upper or lower triangle of the symmetric band
* matrix B, stored in the first kb+1 rows of the array. The
* j-th column of B is stored in the j-th column of the array BB
* as follows:
* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).
*
* On exit, the factor S from the split Cholesky factorization
* B = S**T*S, as returned by SPBSTF.
*
* LDBB (input) INTEGER
* The leading dimension of the array BB. LDBB >= KB+1.
*
* Q (output) REAL array, dimension (LDQ, N)
* If JOBZ = 'V', the n-by-n matrix used in the reduction of
* A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x,
* and consequently C to tridiagonal form.
* If JOBZ = 'N', the array Q is not referenced.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. If JOBZ = 'N',
* LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N).
*
* VL (input) REAL
* VU (input) REAL
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* ABSTOL (input) REAL
* The absolute error tolerance for the eigenvalues.
* An approximate eigenvalue is accepted as converged
* when it is determined to lie in an interval [a,b]
* of width less than or equal to
*
* ABSTOL + EPS * max( |a|,|b| ) ,
*
* where EPS is the machine precision. If ABSTOL is less than
* or equal to zero, then EPS*|T| will be used in its place,
* where |T| is the 1-norm of the tridiagonal matrix obtained
* by reducing A to tridiagonal form.
*
* Eigenvalues will be computed most accurately when ABSTOL is
* set to twice the underflow threshold 2*SLAMCH('S'), not zero.
* If this routine returns with INFO>0, indicating that some
* eigenvectors did not converge, try setting ABSTOL to
* 2*SLAMCH('S').
*
* M (output) INTEGER
* The total number of eigenvalues found. 0 <= M <= N.
* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*
* W (output) REAL array, dimension (N)
* If INFO = 0, the eigenvalues in ascending order.
*
* Z (output) REAL array, dimension (LDZ, N)
* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
* eigenvectors, with the i-th column of Z holding the
* eigenvector associated with W(i). The eigenvectors are
* normalized so Z**T*B*Z = I.
* If JOBZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace/output) REAL array, dimension (7N)
*
* IWORK (workspace/output) INTEGER array, dimension (5N)
*
* IFAIL (output) INTEGER array, dimension (M)
* If JOBZ = 'V', then if INFO = 0, the first M elements of
* IFAIL are zero. If INFO > 0, then IFAIL contains the
* indices of the eigenvalues that failed to converge.
* If JOBZ = 'N', then IFAIL is not referenced.
*
* INFO (output) INTEGER
* = 0 : successful exit
* < 0 : if INFO = -i, the i-th argument had an illegal value
* <= N: if INFO = i, then i eigenvectors failed to converge.
* Their indices are stored in IFAIL.
* > N : SPBSTF returned an error code; i.e.,
* if INFO = N + i, for 1 <= i <= N, then the leading
* minor of order i of B is not positive definite.
* The factorization of B could not be completed and
* no eigenvalues or eigenvectors were computed.
*
* Further Details
* ===============
*
* Based on contributions by
* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, TEST, UPPER, VALEIG, WANTZ
CHARACTER ORDER, VECT
INTEGER I, IINFO, INDD, INDE, INDEE, INDIBL, INDISP,
$ INDIWO, INDWRK, ITMP1, J, JJ, NSPLIT
REAL TMP1
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMV, SLACPY, SPBSTF, SSBGST, SSBTRD,
$ SSTEBZ, SSTEIN, SSTEQR, SSTERF, SSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
UPPER = LSAME( UPLO, 'U' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
INFO = -2
ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( KA.LT.0 ) THEN
INFO = -5
ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
INFO = -6
ELSE IF( LDAB.LT.KA+1 ) THEN
INFO = -8
ELSE IF( LDBB.LT.KB+1 ) THEN
INFO = -10
ELSE IF( LDQ.LT.1 .OR. ( WANTZ .AND. LDQ.LT.N ) ) THEN
INFO = -12
ELSE
IF( VALEIG ) THEN
IF( N.GT.0 .AND. VU.LE.VL )
$ INFO = -14
ELSE IF( INDEIG ) THEN
IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
INFO = -15
ELSE IF ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
INFO = -16
END IF
END IF
END IF
IF( INFO.EQ.0) THEN
IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -21
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSBGVX', -INFO )
RETURN
END IF
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 )
$ RETURN
*
* Form a split Cholesky factorization of B.
*
CALL SPBSTF( UPLO, N, KB, BB, LDBB, INFO )
IF( INFO.NE.0 ) THEN
INFO = N + INFO
RETURN
END IF
*
* Transform problem to standard eigenvalue problem.
*
CALL SSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ,
$ WORK, IINFO )
*
* Reduce symmetric band matrix to tridiagonal form.
*
INDD = 1
INDE = INDD + N
INDWRK = INDE + N
IF( WANTZ ) THEN
VECT = 'U'
ELSE
VECT = 'N'
END IF
CALL SSBTRD( VECT, UPLO, N, KA, AB, LDAB, WORK( INDD ),
$ WORK( INDE ), Q, LDQ, WORK( INDWRK ), IINFO )
*
* If all eigenvalues are desired and ABSTOL is less than or equal
* to zero, then call SSTERF or SSTEQR. If this fails for some
* eigenvalue, then try SSTEBZ.
*
TEST = .FALSE.
IF( INDEIG ) THEN
IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
TEST = .TRUE.
END IF
END IF
IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN
CALL SCOPY( N, WORK( INDD ), 1, W, 1 )
INDEE = INDWRK + 2*N
CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
IF( .NOT.WANTZ ) THEN
CALL SSTERF( N, W, WORK( INDEE ), INFO )
ELSE
CALL SLACPY( 'A', N, N, Q, LDQ, Z, LDZ )
CALL SSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ,
$ WORK( INDWRK ), INFO )
IF( INFO.EQ.0 ) THEN
DO 10 I = 1, N
IFAIL( I ) = 0
10 CONTINUE
END IF
END IF
IF( INFO.EQ.0 ) THEN
M = N
GO TO 30
END IF
INFO = 0
END IF
*
* Otherwise, call SSTEBZ and, if eigenvectors are desired,
* call SSTEIN.
*
IF( WANTZ ) THEN
ORDER = 'B'
ELSE
ORDER = 'E'
END IF
INDIBL = 1
INDISP = INDIBL + N
INDIWO = INDISP + N
CALL SSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL,
$ WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
$ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ),
$ IWORK( INDIWO ), INFO )
*
IF( WANTZ ) THEN
CALL SSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
$ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
$ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO )
*
* Apply transformation matrix used in reduction to tridiagonal
* form to eigenvectors returned by SSTEIN.
*
DO 20 J = 1, M
CALL SCOPY( N, Z( 1, J ), 1, WORK( 1 ), 1 )
CALL SGEMV( 'N', N, N, ONE, Q, LDQ, WORK, 1, ZERO,
$ Z( 1, J ), 1 )
20 CONTINUE
END IF
*
30 CONTINUE
*
* If eigenvalues are not in order, then sort them, along with
* eigenvectors.
*
IF( WANTZ ) THEN
DO 50 J = 1, M - 1
I = 0
TMP1 = W( J )
DO 40 JJ = J + 1, M
IF( W( JJ ).LT.TMP1 ) THEN
I = JJ
TMP1 = W( JJ )
END IF
40 CONTINUE
*
IF( I.NE.0 ) THEN
ITMP1 = IWORK( INDIBL+I-1 )
W( I ) = W( J )
IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
W( J ) = TMP1
IWORK( INDIBL+J-1 ) = ITMP1
CALL SSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
IF( INFO.NE.0 ) THEN
ITMP1 = IFAIL( I )
IFAIL( I ) = IFAIL( J )
IFAIL( J ) = ITMP1
END IF
END IF
50 CONTINUE
END IF
*
RETURN
*
* End of SSBGVX
*
END
SUBROUTINE SSBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ,
$ WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO, VECT
INTEGER INFO, KD, LDAB, LDQ, N
* ..
* .. Array Arguments ..
REAL AB( LDAB, * ), D( * ), E( * ), Q( LDQ, * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* SSBTRD reduces a real symmetric band matrix A to symmetric
* tridiagonal form T by an orthogonal similarity transformation:
* Q**T * A * Q = T.
*
* Arguments
* =========
*
* VECT (input) CHARACTER*1
* = 'N': do not form Q;
* = 'V': form Q;
* = 'U': update a matrix X, by forming X*Q.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals of the matrix A if UPLO = 'U',
* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
*
* AB (input/output) REAL array, dimension (LDAB,N)
* On entry, the upper or lower triangle of the symmetric band
* matrix A, stored in the first KD+1 rows of the array. The
* j-th column of A is stored in the j-th column of the array AB
* as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
* On exit, the diagonal elements of AB are overwritten by the
* diagonal elements of the tridiagonal matrix T; if KD > 0, the
* elements on the first superdiagonal (if UPLO = 'U') or the
* first subdiagonal (if UPLO = 'L') are overwritten by the
* off-diagonal elements of T; the rest of AB is overwritten by
* values generated during the reduction.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* D (output) REAL array, dimension (N)
* The diagonal elements of the tridiagonal matrix T.
*
* E (output) REAL array, dimension (N-1)
* The off-diagonal elements of the tridiagonal matrix T:
* E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.
*
* Q (input/output) REAL array, dimension (LDQ,N)
* On entry, if VECT = 'U', then Q must contain an N-by-N
* matrix X; if VECT = 'N' or 'V', then Q need not be set.
*
* On exit:
* if VECT = 'V', Q contains the N-by-N orthogonal matrix Q;
* if VECT = 'U', Q contains the product X*Q;
* if VECT = 'N', the array Q is not referenced.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q.
* LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.
*
* WORK (workspace) REAL array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Further Details
* ===============
*
* Modified by Linda Kaufman, Bell Labs.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL INITQ, UPPER, WANTQ
INTEGER I, I2, IBL, INCA, INCX, IQAEND, IQB, IQEND, J,
$ J1, J1END, J1INC, J2, JEND, JIN, JINC, K, KD1,
$ KDM1, KDN, L, LAST, LEND, NQ, NR, NRT
REAL TEMP
* ..
* .. External Subroutines ..
EXTERNAL SLAR2V, SLARGV, SLARTG, SLARTV, SLASET, SROT,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INITQ = LSAME( VECT, 'V' )
WANTQ = INITQ .OR. LSAME( VECT, 'U' )
UPPER = LSAME( UPLO, 'U' )
KD1 = KD + 1
KDM1 = KD - 1
INCX = LDAB - 1
IQEND = 1
*
INFO = 0
IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'N' ) ) THEN
INFO = -1
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( KD.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.KD1 ) THEN
INFO = -6
ELSE IF( LDQ.LT.MAX( 1, N ) .AND. WANTQ ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSBTRD', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Initialize Q to the unit matrix, if needed
*
IF( INITQ )
$ CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
*
* Wherever possible, plane rotations are generated and applied in
* vector operations of length NR over the index set J1:J2:KD1.
*
* The cosines and sines of the plane rotations are stored in the
* arrays D and WORK.
*
INCA = KD1*LDAB
KDN = MIN( N-1, KD )
IF( UPPER ) THEN
*
IF( KD.GT.1 ) THEN
*
* Reduce to tridiagonal form, working with upper triangle
*
NR = 0
J1 = KDN + 2
J2 = 1
*
DO 90 I = 1, N - 2
*
* Reduce i-th row of matrix to tridiagonal form
*
DO 80 K = KDN + 1, 2, -1
J1 = J1 + KDN
J2 = J2 + KDN
*
IF( NR.GT.0 ) THEN
*
* generate plane rotations to annihilate nonzero
* elements which have been created outside the band
*
CALL SLARGV( NR, AB( 1, J1-1 ), INCA, WORK( J1 ),
$ KD1, D( J1 ), KD1 )
*
* apply rotations from the right
*
*
* Dependent on the the number of diagonals either
* SLARTV or SROT is used
*
IF( NR.GE.2*KD-1 ) THEN
DO 10 L = 1, KD - 1
CALL SLARTV( NR, AB( L+1, J1-1 ), INCA,
$ AB( L, J1 ), INCA, D( J1 ),
$ WORK( J1 ), KD1 )
10 CONTINUE
*
ELSE
JEND = J1 + ( NR-1 )*KD1
DO 20 JINC = J1, JEND, KD1
CALL SROT( KDM1, AB( 2, JINC-1 ), 1,
$ AB( 1, JINC ), 1, D( JINC ),
$ WORK( JINC ) )
20 CONTINUE
END IF
END IF
*
*
IF( K.GT.2 ) THEN
IF( K.LE.N-I+1 ) THEN
*
* generate plane rotation to annihilate a(i,i+k-1)
* within the band
*
CALL SLARTG( AB( KD-K+3, I+K-2 ),
$ AB( KD-K+2, I+K-1 ), D( I+K-1 ),
$ WORK( I+K-1 ), TEMP )
AB( KD-K+3, I+K-2 ) = TEMP
*
* apply rotation from the right
*
CALL SROT( K-3, AB( KD-K+4, I+K-2 ), 1,
$ AB( KD-K+3, I+K-1 ), 1, D( I+K-1 ),
$ WORK( I+K-1 ) )
END IF
NR = NR + 1
J1 = J1 - KDN - 1
END IF
*
* apply plane rotations from both sides to diagonal
* blocks
*
IF( NR.GT.0 )
$ CALL SLAR2V( NR, AB( KD1, J1-1 ), AB( KD1, J1 ),
$ AB( KD, J1 ), INCA, D( J1 ),
$ WORK( J1 ), KD1 )
*
* apply plane rotations from the left
*
IF( NR.GT.0 ) THEN
IF( 2*KD-1.LT.NR ) THEN
*
* Dependent on the the number of diagonals either
* SLARTV or SROT is used
*
DO 30 L = 1, KD - 1
IF( J2+L.GT.N ) THEN
NRT = NR - 1
ELSE
NRT = NR
END IF
IF( NRT.GT.0 )
$ CALL SLARTV( NRT, AB( KD-L, J1+L ), INCA,
$ AB( KD-L+1, J1+L ), INCA,
$ D( J1 ), WORK( J1 ), KD1 )
30 CONTINUE
ELSE
J1END = J1 + KD1*( NR-2 )
IF( J1END.GE.J1 ) THEN
DO 40 JIN = J1, J1END, KD1
CALL SROT( KD-1, AB( KD-1, JIN+1 ), INCX,
$ AB( KD, JIN+1 ), INCX,
$ D( JIN ), WORK( JIN ) )
40 CONTINUE
END IF
LEND = MIN( KDM1, N-J2 )
LAST = J1END + KD1
IF( LEND.GT.0 )
$ CALL SROT( LEND, AB( KD-1, LAST+1 ), INCX,
$ AB( KD, LAST+1 ), INCX, D( LAST ),
$ WORK( LAST ) )
END IF
END IF
*
IF( WANTQ ) THEN
*
* accumulate product of plane rotations in Q
*
IF( INITQ ) THEN
*
* take advantage of the fact that Q was
* initially the Identity matrix
*
IQEND = MAX( IQEND, J2 )
I2 = MAX( 0, K-3 )
IQAEND = 1 + I*KD
IF( K.EQ.2 )
$ IQAEND = IQAEND + KD
IQAEND = MIN( IQAEND, IQEND )
DO 50 J = J1, J2, KD1
IBL = I - I2 / KDM1
I2 = I2 + 1
IQB = MAX( 1, J-IBL )
NQ = 1 + IQAEND - IQB
IQAEND = MIN( IQAEND+KD, IQEND )
CALL SROT( NQ, Q( IQB, J-1 ), 1, Q( IQB, J ),
$ 1, D( J ), WORK( J ) )
50 CONTINUE
ELSE
*
DO 60 J = J1, J2, KD1
CALL SROT( N, Q( 1, J-1 ), 1, Q( 1, J ), 1,
$ D( J ), WORK( J ) )
60 CONTINUE
END IF
*
END IF
*
IF( J2+KDN.GT.N ) THEN
*
* adjust J2 to keep within the bounds of the matrix
*
NR = NR - 1
J2 = J2 - KDN - 1
END IF
*
DO 70 J = J1, J2, KD1
*
* create nonzero element a(j-1,j+kd) outside the band
* and store it in WORK
*
WORK( J+KD ) = WORK( J )*AB( 1, J+KD )
AB( 1, J+KD ) = D( J )*AB( 1, J+KD )
70 CONTINUE
80 CONTINUE
90 CONTINUE
END IF
*
IF( KD.GT.0 ) THEN
*
* copy off-diagonal elements to E
*
DO 100 I = 1, N - 1
E( I ) = AB( KD, I+1 )
100 CONTINUE
ELSE
*
* set E to zero if original matrix was diagonal
*
DO 110 I = 1, N - 1
E( I ) = ZERO
110 CONTINUE
END IF
*
* copy diagonal elements to D
*
DO 120 I = 1, N
D( I ) = AB( KD1, I )
120 CONTINUE
*
ELSE
*
IF( KD.GT.1 ) THEN
*
* Reduce to tridiagonal form, working with lower triangle
*
NR = 0
J1 = KDN + 2
J2 = 1
*
DO 210 I = 1, N - 2
*
* Reduce i-th column of matrix to tridiagonal form
*
DO 200 K = KDN + 1, 2, -1
J1 = J1 + KDN
J2 = J2 + KDN
*
IF( NR.GT.0 ) THEN
*
* generate plane rotations to annihilate nonzero
* elements which have been created outside the band
*
CALL SLARGV( NR, AB( KD1, J1-KD1 ), INCA,
$ WORK( J1 ), KD1, D( J1 ), KD1 )
*
* apply plane rotations from one side
*
*
* Dependent on the the number of diagonals either
* SLARTV or SROT is used
*
IF( NR.GT.2*KD-1 ) THEN
DO 130 L = 1, KD - 1
CALL SLARTV( NR, AB( KD1-L, J1-KD1+L ), INCA,
$ AB( KD1-L+1, J1-KD1+L ), INCA,
$ D( J1 ), WORK( J1 ), KD1 )
130 CONTINUE
ELSE
JEND = J1 + KD1*( NR-1 )
DO 140 JINC = J1, JEND, KD1
CALL SROT( KDM1, AB( KD, JINC-KD ), INCX,
$ AB( KD1, JINC-KD ), INCX,
$ D( JINC ), WORK( JINC ) )
140 CONTINUE
END IF
*
END IF
*
IF( K.GT.2 ) THEN
IF( K.LE.N-I+1 ) THEN
*
* generate plane rotation to annihilate a(i+k-1,i)
* within the band
*
CALL SLARTG( AB( K-1, I ), AB( K, I ),
$ D( I+K-1 ), WORK( I+K-1 ), TEMP )
AB( K-1, I ) = TEMP
*
* apply rotation from the left
*
CALL SROT( K-3, AB( K-2, I+1 ), LDAB-1,
$ AB( K-1, I+1 ), LDAB-1, D( I+K-1 ),
$ WORK( I+K-1 ) )
END IF
NR = NR + 1
J1 = J1 - KDN - 1
END IF
*
* apply plane rotations from both sides to diagonal
* blocks
*
IF( NR.GT.0 )
$ CALL SLAR2V( NR, AB( 1, J1-1 ), AB( 1, J1 ),
$ AB( 2, J1-1 ), INCA, D( J1 ),
$ WORK( J1 ), KD1 )
*
* apply plane rotations from the right
*
*
* Dependent on the the number of diagonals either
* SLARTV or SROT is used
*
IF( NR.GT.0 ) THEN
IF( NR.GT.2*KD-1 ) THEN
DO 150 L = 1, KD - 1
IF( J2+L.GT.N ) THEN
NRT = NR - 1
ELSE
NRT = NR
END IF
IF( NRT.GT.0 )
$ CALL SLARTV( NRT, AB( L+2, J1-1 ), INCA,
$ AB( L+1, J1 ), INCA, D( J1 ),
$ WORK( J1 ), KD1 )
150 CONTINUE
ELSE
J1END = J1 + KD1*( NR-2 )
IF( J1END.GE.J1 ) THEN
DO 160 J1INC = J1, J1END, KD1
CALL SROT( KDM1, AB( 3, J1INC-1 ), 1,
$ AB( 2, J1INC ), 1, D( J1INC ),
$ WORK( J1INC ) )
160 CONTINUE
END IF
LEND = MIN( KDM1, N-J2 )
LAST = J1END + KD1
IF( LEND.GT.0 )
$ CALL SROT( LEND, AB( 3, LAST-1 ), 1,
$ AB( 2, LAST ), 1, D( LAST ),
$ WORK( LAST ) )
END IF
END IF
*
*
*
IF( WANTQ ) THEN
*
* accumulate product of plane rotations in Q
*
IF( INITQ ) THEN
*
* take advantage of the fact that Q was
* initially the Identity matrix
*
IQEND = MAX( IQEND, J2 )
I2 = MAX( 0, K-3 )
IQAEND = 1 + I*KD
IF( K.EQ.2 )
$ IQAEND = IQAEND + KD
IQAEND = MIN( IQAEND, IQEND )
DO 170 J = J1, J2, KD1
IBL = I - I2 / KDM1
I2 = I2 + 1
IQB = MAX( 1, J-IBL )
NQ = 1 + IQAEND - IQB
IQAEND = MIN( IQAEND+KD, IQEND )
CALL SROT( NQ, Q( IQB, J-1 ), 1, Q( IQB, J ),
$ 1, D( J ), WORK( J ) )
170 CONTINUE
ELSE
*
DO 180 J = J1, J2, KD1
CALL SROT( N, Q( 1, J-1 ), 1, Q( 1, J ), 1,
$ D( J ), WORK( J ) )
180 CONTINUE
END IF
END IF
*
IF( J2+KDN.GT.N ) THEN
*
* adjust J2 to keep within the bounds of the matrix
*
NR = NR - 1
J2 = J2 - KDN - 1
END IF
*
DO 190 J = J1, J2, KD1
*
* create nonzero element a(j+kd,j-1) outside the
* band and store it in WORK
*
WORK( J+KD ) = WORK( J )*AB( KD1, J )
AB( KD1, J ) = D( J )*AB( KD1, J )
190 CONTINUE
200 CONTINUE
210 CONTINUE
END IF
*
IF( KD.GT.0 ) THEN
*
* copy off-diagonal elements to E
*
DO 220 I = 1, N - 1
E( I ) = AB( 2, I )
220 CONTINUE
ELSE
*
* set E to zero if original matrix was diagonal
*
DO 230 I = 1, N - 1
E( I ) = ZERO
230 CONTINUE
END IF
*
* copy diagonal elements to D
*
DO 240 I = 1, N
D( I ) = AB( 1, I )
240 CONTINUE
END IF
*
RETURN
*
* End of SSBTRD
*
END
SUBROUTINE SSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, IWORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call SLACN2 in place of SLACON, 5 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, N
REAL ANORM, RCOND
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), IWORK( * )
REAL AP( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SSPCON estimates the reciprocal of the condition number (in the
* 1-norm) of a real symmetric packed matrix A using the factorization
* A = U*D*U**T or A = L*D*L**T computed by SSPTRF.
*
* An estimate is obtained for norm(inv(A)), and the reciprocal of the
* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the details of the factorization are stored
* as an upper or lower triangular matrix.
* = 'U': Upper triangular, form is A = U*D*U**T;
* = 'L': Lower triangular, form is A = L*D*L**T.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input) REAL array, dimension (N*(N+1)/2)
* The block diagonal matrix D and the multipliers used to
* obtain the factor U or L as computed by SSPTRF, stored as a
* packed triangular matrix.
*
* IPIV (input) INTEGER array, dimension (N)
* Details of the interchanges and the block structure of D
* as determined by SSPTRF.
*
* ANORM (input) REAL
* The 1-norm of the original matrix A.
*
* RCOND (output) REAL
* The reciprocal of the condition number of the matrix A,
* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
* estimate of the 1-norm of inv(A) computed in this routine.
*
* WORK (workspace) REAL array, dimension (2*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, IP, KASE
REAL AINVNM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SLACN2, SSPTRS, XERBLA
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ANORM.LT.ZERO ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSPCON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
RCOND = ZERO
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
ELSE IF( ANORM.LE.ZERO ) THEN
RETURN
END IF
*
* Check that the diagonal matrix D is nonsingular.
*
IF( UPPER ) THEN
*
* Upper triangular storage: examine D from bottom to top
*
IP = N*( N+1 ) / 2
DO 10 I = N, 1, -1
IF( IPIV( I ).GT.0 .AND. AP( IP ).EQ.ZERO )
$ RETURN
IP = IP - I
10 CONTINUE
ELSE
*
* Lower triangular storage: examine D from top to bottom.
*
IP = 1
DO 20 I = 1, N
IF( IPIV( I ).GT.0 .AND. AP( IP ).EQ.ZERO )
$ RETURN
IP = IP + N - I + 1
20 CONTINUE
END IF
*
* Estimate the 1-norm of the inverse.
*
KASE = 0
30 CONTINUE
CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
*
* Multiply by inv(L*D*L') or inv(U*D*U').
*
CALL SSPTRS( UPLO, N, 1, AP, IPIV, WORK, N, INFO )
GO TO 30
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / AINVNM ) / ANORM
*
RETURN
*
* End of SSPCON
*
END
SUBROUTINE SSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, LDZ, N
* ..
* .. Array Arguments ..
REAL AP( * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SSPEV computes all the eigenvalues and, optionally, eigenvectors of a
* real symmetric matrix A in packed storage.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input/output) REAL array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* A, packed columnwise in a linear array. The j-th column of A
* is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
*
* On exit, AP is overwritten by values generated during the
* reduction to tridiagonal form. If UPLO = 'U', the diagonal
* and first superdiagonal of the tridiagonal matrix T overwrite
* the corresponding elements of A, and if UPLO = 'L', the
* diagonal and first subdiagonal of T overwrite the
* corresponding elements of A.
*
* W (output) REAL array, dimension (N)
* If INFO = 0, the eigenvalues in ascending order.
*
* Z (output) REAL array, dimension (LDZ, N)
* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
* eigenvectors of the matrix A, with the i-th column of Z
* holding the eigenvector associated with W(i).
* If JOBZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace) REAL array, dimension (3*N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = i, the algorithm failed to converge; i
* off-diagonal elements of an intermediate tridiagonal
* form did not converge to zero.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL WANTZ
INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE
REAL ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
$ SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANSP
EXTERNAL LSAME, SLAMCH, SLANSP
* ..
* .. External Subroutines ..
EXTERNAL SOPGTR, SSCAL, SSPTRD, SSTEQR, SSTERF, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) )
$ THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -7
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSPEV ', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
W( 1 ) = AP( 1 )
IF( WANTZ )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = SLAMCH( 'Safe minimum' )
EPS = SLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = SQRT( BIGNUM )
*
* Scale matrix to allowable range, if necessary.
*
ANRM = SLANSP( 'M', UPLO, N, AP, WORK )
ISCALE = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 ) THEN
CALL SSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
END IF
*
* Call SSPTRD to reduce symmetric packed matrix to tridiagonal form.
*
INDE = 1
INDTAU = INDE + N
CALL SSPTRD( UPLO, N, AP, W, WORK( INDE ), WORK( INDTAU ), IINFO )
*
* For eigenvalues only, call SSTERF. For eigenvectors, first call
* SOPGTR to generate the orthogonal matrix, then call SSTEQR.
*
IF( .NOT.WANTZ ) THEN
CALL SSTERF( N, W, WORK( INDE ), INFO )
ELSE
INDWRK = INDTAU + N
CALL SOPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ,
$ WORK( INDWRK ), IINFO )
CALL SSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDTAU ),
$ INFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = N
ELSE
IMAX = INFO - 1
END IF
CALL SSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
RETURN
*
* End of SSPEV
*
END
SUBROUTINE SSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK,
$ IWORK, LIWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, LDZ, LIWORK, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL AP( * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SSPEVD computes all the eigenvalues and, optionally, eigenvectors
* of a real symmetric matrix A in packed storage. If eigenvectors are
* desired, it uses a divide and conquer algorithm.
*
* The divide and conquer algorithm makes very mild assumptions about
* floating point arithmetic. It will work on machines with a guard
* digit in add/subtract, or on those binary machines without guard
* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
* Cray-2. It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input/output) REAL array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* A, packed columnwise in a linear array. The j-th column of A
* is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
*
* On exit, AP is overwritten by values generated during the
* reduction to tridiagonal form. If UPLO = 'U', the diagonal
* and first superdiagonal of the tridiagonal matrix T overwrite
* the corresponding elements of A, and if UPLO = 'L', the
* diagonal and first subdiagonal of T overwrite the
* corresponding elements of A.
*
* W (output) REAL array, dimension (N)
* If INFO = 0, the eigenvalues in ascending order.
*
* Z (output) REAL array, dimension (LDZ, N)
* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
* eigenvectors of the matrix A, with the i-th column of Z
* holding the eigenvector associated with W(i).
* If JOBZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
* On exit, if INFO = 0, WORK(1) returns the required LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* If N <= 1, LWORK must be at least 1.
* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N.
* If JOBZ = 'V' and N > 1, LWORK must be at least
* 1 + 6*N + N**2.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the required sizes of the WORK and IWORK
* arrays, returns these values as the first entries of the WORK
* and IWORK arrays, and no error message related to LWORK or
* LIWORK is issued by XERBLA.
*
* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK.
* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.
* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the required sizes of the WORK and
* IWORK arrays, returns these values as the first entries of
* the WORK and IWORK arrays, and no error message related to
* LWORK or LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = i, the algorithm failed to converge; i
* off-diagonal elements of an intermediate tridiagonal
* form did not converge to zero.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, WANTZ
INTEGER IINFO, INDE, INDTAU, INDWRK, ISCALE, LIWMIN,
$ LLWORK, LWMIN
REAL ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
$ SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANSP
EXTERNAL LSAME, SLAMCH, SLANSP
* ..
* .. External Subroutines ..
EXTERNAL SOPMTR, SSCAL, SSPTRD, SSTEDC, SSTERF, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) )
$ THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -7
END IF
*
IF( INFO.EQ.0 ) THEN
IF( N.LE.1 ) THEN
LIWMIN = 1
LWMIN = 1
ELSE
IF( WANTZ ) THEN
LIWMIN = 3 + 5*N
LWMIN = 1 + 6*N + N**2
ELSE
LIWMIN = 1
LWMIN = 2*N
END IF
END IF
IWORK( 1 ) = LIWMIN
WORK( 1 ) = LWMIN
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -9
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -11
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSPEVD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
W( 1 ) = AP( 1 )
IF( WANTZ )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = SLAMCH( 'Safe minimum' )
EPS = SLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = SQRT( BIGNUM )
*
* Scale matrix to allowable range, if necessary.
*
ANRM = SLANSP( 'M', UPLO, N, AP, WORK )
ISCALE = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 ) THEN
CALL SSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
END IF
*
* Call SSPTRD to reduce symmetric packed matrix to tridiagonal form.
*
INDE = 1
INDTAU = INDE + N
CALL SSPTRD( UPLO, N, AP, W, WORK( INDE ), WORK( INDTAU ), IINFO )
*
* For eigenvalues only, call SSTERF. For eigenvectors, first call
* SSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the
* tridiagonal matrix, then call SOPMTR to multiply it by the
* Householder transformations represented in AP.
*
IF( .NOT.WANTZ ) THEN
CALL SSTERF( N, W, WORK( INDE ), INFO )
ELSE
INDWRK = INDTAU + N
LLWORK = LWORK - INDWRK + 1
CALL SSTEDC( 'I', N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ),
$ LLWORK, IWORK, LIWORK, INFO )
CALL SOPMTR( 'L', UPLO, 'N', N, N, AP, WORK( INDTAU ), Z, LDZ,
$ WORK( INDWRK ), IINFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( ISCALE.EQ.1 )
$ CALL SSCAL( N, ONE / SIGMA, W, 1 )
*
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
RETURN
*
* End of SSPEVD
*
END
SUBROUTINE SSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU,
$ ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL,
$ INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE, UPLO
INTEGER IL, INFO, IU, LDZ, M, N
REAL ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER IFAIL( * ), IWORK( * )
REAL AP( * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SSPEVX computes selected eigenvalues and, optionally, eigenvectors
* of a real symmetric matrix A in packed storage. Eigenvalues/vectors
* can be selected by specifying either a range of values or a range of
* indices for the desired eigenvalues.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* RANGE (input) CHARACTER*1
* = 'A': all eigenvalues will be found;
* = 'V': all eigenvalues in the half-open interval (VL,VU]
* will be found;
* = 'I': the IL-th through IU-th eigenvalues will be found.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input/output) REAL array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* A, packed columnwise in a linear array. The j-th column of A
* is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
*
* On exit, AP is overwritten by values generated during the
* reduction to tridiagonal form. If UPLO = 'U', the diagonal
* and first superdiagonal of the tridiagonal matrix T overwrite
* the corresponding elements of A, and if UPLO = 'L', the
* diagonal and first subdiagonal of T overwrite the
* corresponding elements of A.
*
* VL (input) REAL
* VU (input) REAL
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* ABSTOL (input) REAL
* The absolute error tolerance for the eigenvalues.
* An approximate eigenvalue is accepted as converged
* when it is determined to lie in an interval [a,b]
* of width less than or equal to
*
* ABSTOL + EPS * max( |a|,|b| ) ,
*
* where EPS is the machine precision. If ABSTOL is less than
* or equal to zero, then EPS*|T| will be used in its place,
* where |T| is the 1-norm of the tridiagonal matrix obtained
* by reducing AP to tridiagonal form.
*
* Eigenvalues will be computed most accurately when ABSTOL is
* set to twice the underflow threshold 2*SLAMCH('S'), not zero.
* If this routine returns with INFO>0, indicating that some
* eigenvectors did not converge, try setting ABSTOL to
* 2*SLAMCH('S').
*
* See "Computing Small Singular Values of Bidiagonal Matrices
* with Guaranteed High Relative Accuracy," by Demmel and
* Kahan, LAPACK Working Note #3.
*
* M (output) INTEGER
* The total number of eigenvalues found. 0 <= M <= N.
* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*
* W (output) REAL array, dimension (N)
* If INFO = 0, the selected eigenvalues in ascending order.
*
* Z (output) REAL array, dimension (LDZ, max(1,M))
* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
* contain the orthonormal eigenvectors of the matrix A
* corresponding to the selected eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* If an eigenvector fails to converge, then that column of Z
* contains the latest approximation to the eigenvector, and the
* index of the eigenvector is returned in IFAIL.
* If JOBZ = 'N', then Z is not referenced.
* Note: the user must ensure that at least max(1,M) columns are
* supplied in the array Z; if RANGE = 'V', the exact value of M
* is not known in advance and an upper bound must be used.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace) REAL array, dimension (8*N)
*
* IWORK (workspace) INTEGER array, dimension (5*N)
*
* IFAIL (output) INTEGER array, dimension (N)
* If JOBZ = 'V', then if INFO = 0, the first M elements of
* IFAIL are zero. If INFO > 0, then IFAIL contains the
* indices of the eigenvectors that failed to converge.
* If JOBZ = 'N', then IFAIL is not referenced.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, then i eigenvectors failed to converge.
* Their indices are stored in array IFAIL.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, TEST, VALEIG, WANTZ
CHARACTER ORDER
INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
$ INDISP, INDIWO, INDTAU, INDWRK, ISCALE, ITMP1,
$ J, JJ, NSPLIT
REAL ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
$ SIGMA, SMLNUM, TMP1, VLL, VUU
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANSP
EXTERNAL LSAME, SLAMCH, SLANSP
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SOPGTR, SOPMTR, SSCAL, SSPTRD, SSTEBZ,
$ SSTEIN, SSTEQR, SSTERF, SSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
INFO = -2
ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) )
$ THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE
IF( VALEIG ) THEN
IF( N.GT.0 .AND. VU.LE.VL )
$ INFO = -7
ELSE IF( INDEIG ) THEN
IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
INFO = -9
END IF
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) )
$ INFO = -14
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSPEVX', -INFO )
RETURN
END IF
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( ALLEIG .OR. INDEIG ) THEN
M = 1
W( 1 ) = AP( 1 )
ELSE
IF( VL.LT.AP( 1 ) .AND. VU.GE.AP( 1 ) ) THEN
M = 1
W( 1 ) = AP( 1 )
END IF
END IF
IF( WANTZ )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = SLAMCH( 'Safe minimum' )
EPS = SLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
*
* Scale matrix to allowable range, if necessary.
*
ISCALE = 0
ABSTLL = ABSTOL
IF ( VALEIG ) THEN
VLL = VL
VUU = VU
ELSE
VLL = ZERO
VUU = ZERO
ENDIF
ANRM = SLANSP( 'M', UPLO, N, AP, WORK )
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 ) THEN
CALL SSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
IF( ABSTOL.GT.0 )
$ ABSTLL = ABSTOL*SIGMA
IF( VALEIG ) THEN
VLL = VL*SIGMA
VUU = VU*SIGMA
END IF
END IF
*
* Call SSPTRD to reduce symmetric packed matrix to tridiagonal form.
*
INDTAU = 1
INDE = INDTAU + N
INDD = INDE + N
INDWRK = INDD + N
CALL SSPTRD( UPLO, N, AP, WORK( INDD ), WORK( INDE ),
$ WORK( INDTAU ), IINFO )
*
* If all eigenvalues are desired and ABSTOL is less than or equal
* to zero, then call SSTERF or SOPGTR and SSTEQR. If this fails
* for some eigenvalue, then try SSTEBZ.
*
TEST = .FALSE.
IF (INDEIG) THEN
IF (IL.EQ.1 .AND. IU.EQ.N) THEN
TEST = .TRUE.
END IF
END IF
IF ((ALLEIG .OR. TEST) .AND. (ABSTOL.LE.ZERO)) THEN
CALL SCOPY( N, WORK( INDD ), 1, W, 1 )
INDEE = INDWRK + 2*N
IF( .NOT.WANTZ ) THEN
CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
CALL SSTERF( N, W, WORK( INDEE ), INFO )
ELSE
CALL SOPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ,
$ WORK( INDWRK ), IINFO )
CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
CALL SSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ,
$ WORK( INDWRK ), INFO )
IF( INFO.EQ.0 ) THEN
DO 10 I = 1, N
IFAIL( I ) = 0
10 CONTINUE
END IF
END IF
IF( INFO.EQ.0 ) THEN
M = N
GO TO 20
END IF
INFO = 0
END IF
*
* Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN.
*
IF( WANTZ ) THEN
ORDER = 'B'
ELSE
ORDER = 'E'
END IF
INDIBL = 1
INDISP = INDIBL + N
INDIWO = INDISP + N
CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
$ WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
$ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ),
$ IWORK( INDIWO ), INFO )
*
IF( WANTZ ) THEN
CALL SSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
$ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
$ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO )
*
* Apply orthogonal matrix used in reduction to tridiagonal
* form to eigenvectors returned by SSTEIN.
*
CALL SOPMTR( 'L', UPLO, 'N', N, M, AP, WORK( INDTAU ), Z, LDZ,
$ WORK( INDWRK ), INFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
20 CONTINUE
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = M
ELSE
IMAX = INFO - 1
END IF
CALL SSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
* If eigenvalues are not in order, then sort them, along with
* eigenvectors.
*
IF( WANTZ ) THEN
DO 40 J = 1, M - 1
I = 0
TMP1 = W( J )
DO 30 JJ = J + 1, M
IF( W( JJ ).LT.TMP1 ) THEN
I = JJ
TMP1 = W( JJ )
END IF
30 CONTINUE
*
IF( I.NE.0 ) THEN
ITMP1 = IWORK( INDIBL+I-1 )
W( I ) = W( J )
IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
W( J ) = TMP1
IWORK( INDIBL+J-1 ) = ITMP1
CALL SSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
IF( INFO.NE.0 ) THEN
ITMP1 = IFAIL( I )
IFAIL( I ) = IFAIL( J )
IFAIL( J ) = ITMP1
END IF
END IF
40 CONTINUE
END IF
*
RETURN
*
* End of SSPEVX
*
END
SUBROUTINE SSPGST( ITYPE, UPLO, N, AP, BP, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, ITYPE, N
* ..
* .. Array Arguments ..
REAL AP( * ), BP( * )
* ..
*
* Purpose
* =======
*
* SSPGST reduces a real symmetric-definite generalized eigenproblem
* to standard form, using packed storage.
*
* If ITYPE = 1, the problem is A*x = lambda*B*x,
* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)
*
* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.
*
* B must have been previously factorized as U**T*U or L*L**T by SPPTRF.
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);
* = 2 or 3: compute U*A*U**T or L**T*A*L.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored and B is factored as
* U**T*U;
* = 'L': Lower triangle of A is stored and B is factored as
* L*L**T.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* AP (input/output) REAL array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* A, packed columnwise in a linear array. The j-th column of A
* is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
*
* On exit, if INFO = 0, the transformed matrix, stored in the
* same format as A.
*
* BP (input) REAL array, dimension (N*(N+1)/2)
* The triangular factor from the Cholesky factorization of B,
* stored in the same format as A, as returned by SPPTRF.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, HALF
PARAMETER ( ONE = 1.0, HALF = 0.5 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, J1, J1J1, JJ, K, K1, K1K1, KK
REAL AJJ, AKK, BJJ, BKK, CT
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SSCAL, SSPMV, SSPR2, STPMV, STPSV,
$ XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SDOT
EXTERNAL LSAME, SDOT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
INFO = -1
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSPGST', -INFO )
RETURN
END IF
*
IF( ITYPE.EQ.1 ) THEN
IF( UPPER ) THEN
*
* Compute inv(U')*A*inv(U)
*
* J1 and JJ are the indices of A(1,j) and A(j,j)
*
JJ = 0
DO 10 J = 1, N
J1 = JJ + 1
JJ = JJ + J
*
* Compute the j-th column of the upper triangle of A
*
BJJ = BP( JJ )
CALL STPSV( UPLO, 'Transpose', 'Nonunit', J, BP,
$ AP( J1 ), 1 )
CALL SSPMV( UPLO, J-1, -ONE, AP, BP( J1 ), 1, ONE,
$ AP( J1 ), 1 )
CALL SSCAL( J-1, ONE / BJJ, AP( J1 ), 1 )
AP( JJ ) = ( AP( JJ )-SDOT( J-1, AP( J1 ), 1, BP( J1 ),
$ 1 ) ) / BJJ
10 CONTINUE
ELSE
*
* Compute inv(L)*A*inv(L')
*
* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1)
*
KK = 1
DO 20 K = 1, N
K1K1 = KK + N - K + 1
*
* Update the lower triangle of A(k:n,k:n)
*
AKK = AP( KK )
BKK = BP( KK )
AKK = AKK / BKK**2
AP( KK ) = AKK
IF( K.LT.N ) THEN
CALL SSCAL( N-K, ONE / BKK, AP( KK+1 ), 1 )
CT = -HALF*AKK
CALL SAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 )
CALL SSPR2( UPLO, N-K, -ONE, AP( KK+1 ), 1,
$ BP( KK+1 ), 1, AP( K1K1 ) )
CALL SAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 )
CALL STPSV( UPLO, 'No transpose', 'Non-unit', N-K,
$ BP( K1K1 ), AP( KK+1 ), 1 )
END IF
KK = K1K1
20 CONTINUE
END IF
ELSE
IF( UPPER ) THEN
*
* Compute U*A*U'
*
* K1 and KK are the indices of A(1,k) and A(k,k)
*
KK = 0
DO 30 K = 1, N
K1 = KK + 1
KK = KK + K
*
* Update the upper triangle of A(1:k,1:k)
*
AKK = AP( KK )
BKK = BP( KK )
CALL STPMV( UPLO, 'No transpose', 'Non-unit', K-1, BP,
$ AP( K1 ), 1 )
CT = HALF*AKK
CALL SAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 )
CALL SSPR2( UPLO, K-1, ONE, AP( K1 ), 1, BP( K1 ), 1,
$ AP )
CALL SAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 )
CALL SSCAL( K-1, BKK, AP( K1 ), 1 )
AP( KK ) = AKK*BKK**2
30 CONTINUE
ELSE
*
* Compute L'*A*L
*
* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1)
*
JJ = 1
DO 40 J = 1, N
J1J1 = JJ + N - J + 1
*
* Compute the j-th column of the lower triangle of A
*
AJJ = AP( JJ )
BJJ = BP( JJ )
AP( JJ ) = AJJ*BJJ + SDOT( N-J, AP( JJ+1 ), 1,
$ BP( JJ+1 ), 1 )
CALL SSCAL( N-J, BJJ, AP( JJ+1 ), 1 )
CALL SSPMV( UPLO, N-J, ONE, AP( J1J1 ), BP( JJ+1 ), 1,
$ ONE, AP( JJ+1 ), 1 )
CALL STPMV( UPLO, 'Transpose', 'Non-unit', N-J+1,
$ BP( JJ ), AP( JJ ), 1 )
JJ = J1J1
40 CONTINUE
END IF
END IF
RETURN
*
* End of SSPGST
*
END
SUBROUTINE SSPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK,
$ INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, ITYPE, LDZ, N
* ..
* .. Array Arguments ..
REAL AP( * ), BP( * ), W( * ), WORK( * ),
$ Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SSPGV computes all the eigenvalues and, optionally, the eigenvectors
* of a real generalized symmetric-definite eigenproblem, of the form
* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
* Here A and B are assumed to be symmetric, stored in packed format,
* and B is also positive definite.
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* Specifies the problem type to be solved:
* = 1: A*x = (lambda)*B*x
* = 2: A*B*x = (lambda)*x
* = 3: B*A*x = (lambda)*x
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangles of A and B are stored;
* = 'L': Lower triangles of A and B are stored.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* AP (input/output) REAL array, dimension
* (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* A, packed columnwise in a linear array. The j-th column of A
* is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
*
* On exit, the contents of AP are destroyed.
*
* BP (input/output) REAL array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* B, packed columnwise in a linear array. The j-th column of B
* is stored in the array BP as follows:
* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
*
* On exit, the triangular factor U or L from the Cholesky
* factorization B = U**T*U or B = L*L**T, in the same storage
* format as B.
*
* W (output) REAL array, dimension (N)
* If INFO = 0, the eigenvalues in ascending order.
*
* Z (output) REAL array, dimension (LDZ, N)
* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
* eigenvectors. The eigenvectors are normalized as follows:
* if ITYPE = 1 or 2, Z**T*B*Z = I;
* if ITYPE = 3, Z**T*inv(B)*Z = I.
* If JOBZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace) REAL array, dimension (3*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: SPPTRF or SSPEV returned an error code:
* <= N: if INFO = i, SSPEV failed to converge;
* i off-diagonal elements of an intermediate
* tridiagonal form did not converge to zero.
* > N: if INFO = n + i, for 1 <= i <= n, then the leading
* minor of order i of B is not positive definite.
* The factorization of B could not be completed and
* no eigenvalues or eigenvectors were computed.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL UPPER, WANTZ
CHARACTER TRANS
INTEGER J, NEIG
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SPPTRF, SSPEV, SSPGST, STPMV, STPSV, XERBLA
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
UPPER = LSAME( UPLO, 'U' )
*
INFO = 0
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
INFO = -1
ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -2
ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSPGV ', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Form a Cholesky factorization of B.
*
CALL SPPTRF( UPLO, N, BP, INFO )
IF( INFO.NE.0 ) THEN
INFO = N + INFO
RETURN
END IF
*
* Transform problem to standard eigenvalue problem and solve.
*
CALL SSPGST( ITYPE, UPLO, N, AP, BP, INFO )
CALL SSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO )
*
IF( WANTZ ) THEN
*
* Backtransform eigenvectors to the original problem.
*
NEIG = N
IF( INFO.GT.0 )
$ NEIG = INFO - 1
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
*
* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
*
IF( UPPER ) THEN
TRANS = 'N'
ELSE
TRANS = 'T'
END IF
*
DO 10 J = 1, NEIG
CALL STPSV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
$ 1 )
10 CONTINUE
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* For B*A*x=(lambda)*x;
* backtransform eigenvectors: x = L*y or U'*y
*
IF( UPPER ) THEN
TRANS = 'T'
ELSE
TRANS = 'N'
END IF
*
DO 20 J = 1, NEIG
CALL STPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
$ 1 )
20 CONTINUE
END IF
END IF
RETURN
*
* End of SSPGV
*
END
SUBROUTINE SSPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK,
$ LWORK, IWORK, LIWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, ITYPE, LDZ, LIWORK, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL AP( * ), BP( * ), W( * ), WORK( * ),
$ Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SSPGVD computes all the eigenvalues, and optionally, the eigenvectors
* of a real generalized symmetric-definite eigenproblem, of the form
* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
* B are assumed to be symmetric, stored in packed format, and B is also
* positive definite.
* If eigenvectors are desired, it uses a divide and conquer algorithm.
*
* The divide and conquer algorithm makes very mild assumptions about
* floating point arithmetic. It will work on machines with a guard
* digit in add/subtract, or on those binary machines without guard
* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
* Cray-2. It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* Specifies the problem type to be solved:
* = 1: A*x = (lambda)*B*x
* = 2: A*B*x = (lambda)*x
* = 3: B*A*x = (lambda)*x
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangles of A and B are stored;
* = 'L': Lower triangles of A and B are stored.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* AP (input/output) REAL array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* A, packed columnwise in a linear array. The j-th column of A
* is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
*
* On exit, the contents of AP are destroyed.
*
* BP (input/output) REAL array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* B, packed columnwise in a linear array. The j-th column of B
* is stored in the array BP as follows:
* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
*
* On exit, the triangular factor U or L from the Cholesky
* factorization B = U**T*U or B = L*L**T, in the same storage
* format as B.
*
* W (output) REAL array, dimension (N)
* If INFO = 0, the eigenvalues in ascending order.
*
* Z (output) REAL array, dimension (LDZ, N)
* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
* eigenvectors. The eigenvectors are normalized as follows:
* if ITYPE = 1 or 2, Z**T*B*Z = I;
* if ITYPE = 3, Z**T*inv(B)*Z = I.
* If JOBZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
* On exit, if INFO = 0, WORK(1) returns the required LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* If N <= 1, LWORK >= 1.
* If JOBZ = 'N' and N > 1, LWORK >= 2*N.
* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the required sizes of the WORK and IWORK
* arrays, returns these values as the first entries of the WORK
* and IWORK arrays, and no error message related to LWORK or
* LIWORK is issued by XERBLA.
*
* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK.
* If JOBZ = 'N' or N <= 1, LIWORK >= 1.
* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the required sizes of the WORK and
* IWORK arrays, returns these values as the first entries of
* the WORK and IWORK arrays, and no error message related to
* LWORK or LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: SPPTRF or SSPEVD returned an error code:
* <= N: if INFO = i, SSPEVD failed to converge;
* i off-diagonal elements of an intermediate
* tridiagonal form did not converge to zero;
* > N: if INFO = N + i, for 1 <= i <= N, then the leading
* minor of order i of B is not positive definite.
* The factorization of B could not be completed and
* no eigenvalues or eigenvectors were computed.
*
* Further Details
* ===============
*
* Based on contributions by
* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
*
* =====================================================================
*
* .. Parameters ..
REAL TWO
PARAMETER ( TWO = 2.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, UPPER, WANTZ
CHARACTER TRANS
INTEGER J, LIWMIN, LWMIN, NEIG
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SPPTRF, SSPEVD, SSPGST, STPMV, STPSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, REAL
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
UPPER = LSAME( UPLO, 'U' )
LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
INFO = 0
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
INFO = -1
ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -2
ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -9
END IF
*
IF( INFO.EQ.0 ) THEN
IF( N.LE.1 ) THEN
LIWMIN = 1
LWMIN = 1
ELSE
IF( WANTZ ) THEN
LIWMIN = 3 + 5*N
LWMIN = 1 + 6*N + 2*N**2
ELSE
LIWMIN = 1
LWMIN = 2*N
END IF
END IF
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -11
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSPGVD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Form a Cholesky factorization of BP.
*
CALL SPPTRF( UPLO, N, BP, INFO )
IF( INFO.NE.0 ) THEN
INFO = N + INFO
RETURN
END IF
*
* Transform problem to standard eigenvalue problem and solve.
*
CALL SSPGST( ITYPE, UPLO, N, AP, BP, INFO )
CALL SSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, IWORK,
$ LIWORK, INFO )
LWMIN = MAX( REAL( LWMIN ), REAL( WORK( 1 ) ) )
LIWMIN = MAX( REAL( LIWMIN ), REAL( IWORK( 1 ) ) )
*
IF( WANTZ ) THEN
*
* Backtransform eigenvectors to the original problem.
*
NEIG = N
IF( INFO.GT.0 )
$ NEIG = INFO - 1
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
*
* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
*
IF( UPPER ) THEN
TRANS = 'N'
ELSE
TRANS = 'T'
END IF
*
DO 10 J = 1, NEIG
CALL STPSV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
$ 1 )
10 CONTINUE
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* For B*A*x=(lambda)*x;
* backtransform eigenvectors: x = L*y or U'*y
*
IF( UPPER ) THEN
TRANS = 'T'
ELSE
TRANS = 'N'
END IF
*
DO 20 J = 1, NEIG
CALL STPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
$ 1 )
20 CONTINUE
END IF
END IF
*
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
RETURN
*
* End of SSPGVD
*
END
SUBROUTINE SSPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU,
$ IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK,
$ IFAIL, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE, UPLO
INTEGER IL, INFO, ITYPE, IU, LDZ, M, N
REAL ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER IFAIL( * ), IWORK( * )
REAL AP( * ), BP( * ), W( * ), WORK( * ),
$ Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SSPGVX computes selected eigenvalues, and optionally, eigenvectors
* of a real generalized symmetric-definite eigenproblem, of the form
* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A
* and B are assumed to be symmetric, stored in packed storage, and B
* is also positive definite. Eigenvalues and eigenvectors can be
* selected by specifying either a range of values or a range of indices
* for the desired eigenvalues.
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* Specifies the problem type to be solved:
* = 1: A*x = (lambda)*B*x
* = 2: A*B*x = (lambda)*x
* = 3: B*A*x = (lambda)*x
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* RANGE (input) CHARACTER*1
* = 'A': all eigenvalues will be found.
* = 'V': all eigenvalues in the half-open interval (VL,VU]
* will be found.
* = 'I': the IL-th through IU-th eigenvalues will be found.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A and B are stored;
* = 'L': Lower triangle of A and B are stored.
*
* N (input) INTEGER
* The order of the matrix pencil (A,B). N >= 0.
*
* AP (input/output) REAL array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* A, packed columnwise in a linear array. The j-th column of A
* is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
*
* On exit, the contents of AP are destroyed.
*
* BP (input/output) REAL array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* B, packed columnwise in a linear array. The j-th column of B
* is stored in the array BP as follows:
* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
*
* On exit, the triangular factor U or L from the Cholesky
* factorization B = U**T*U or B = L*L**T, in the same storage
* format as B.
*
* VL (input) REAL
* VU (input) REAL
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* ABSTOL (input) REAL
* The absolute error tolerance for the eigenvalues.
* An approximate eigenvalue is accepted as converged
* when it is determined to lie in an interval [a,b]
* of width less than or equal to
*
* ABSTOL + EPS * max( |a|,|b| ) ,
*
* where EPS is the machine precision. If ABSTOL is less than
* or equal to zero, then EPS*|T| will be used in its place,
* where |T| is the 1-norm of the tridiagonal matrix obtained
* by reducing A to tridiagonal form.
*
* Eigenvalues will be computed most accurately when ABSTOL is
* set to twice the underflow threshold 2*SLAMCH('S'), not zero.
* If this routine returns with INFO>0, indicating that some
* eigenvectors did not converge, try setting ABSTOL to
* 2*SLAMCH('S').
*
* M (output) INTEGER
* The total number of eigenvalues found. 0 <= M <= N.
* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*
* W (output) REAL array, dimension (N)
* On normal exit, the first M elements contain the selected
* eigenvalues in ascending order.
*
* Z (output) REAL array, dimension (LDZ, max(1,M))
* If JOBZ = 'N', then Z is not referenced.
* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
* contain the orthonormal eigenvectors of the matrix A
* corresponding to the selected eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* The eigenvectors are normalized as follows:
* if ITYPE = 1 or 2, Z**T*B*Z = I;
* if ITYPE = 3, Z**T*inv(B)*Z = I.
*
* If an eigenvector fails to converge, then that column of Z
* contains the latest approximation to the eigenvector, and the
* index of the eigenvector is returned in IFAIL.
* Note: the user must ensure that at least max(1,M) columns are
* supplied in the array Z; if RANGE = 'V', the exact value of M
* is not known in advance and an upper bound must be used.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace) REAL array, dimension (8*N)
*
* IWORK (workspace) INTEGER array, dimension (5*N)
*
* IFAIL (output) INTEGER array, dimension (N)
* If JOBZ = 'V', then if INFO = 0, the first M elements of
* IFAIL are zero. If INFO > 0, then IFAIL contains the
* indices of the eigenvectors that failed to converge.
* If JOBZ = 'N', then IFAIL is not referenced.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: SPPTRF or SSPEVX returned an error code:
* <= N: if INFO = i, SSPEVX failed to converge;
* i eigenvectors failed to converge. Their indices
* are stored in array IFAIL.
* > N: if INFO = N + i, for 1 <= i <= N, then the leading
* minor of order i of B is not positive definite.
* The factorization of B could not be completed and
* no eigenvalues or eigenvectors were computed.
*
* Further Details
* ===============
*
* Based on contributions by
* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, UPPER, VALEIG, WANTZ
CHARACTER TRANS
INTEGER J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SPPTRF, SSPEVX, SSPGST, STPMV, STPSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
UPPER = LSAME( UPLO, 'U' )
WANTZ = LSAME( JOBZ, 'V' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
*
INFO = 0
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
INFO = -1
ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -2
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
INFO = -3
ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE
IF( VALEIG ) THEN
IF( N.GT.0 .AND. VU.LE.VL ) THEN
INFO = -9
END IF
ELSE IF( INDEIG ) THEN
IF( IL.LT.1 ) THEN
INFO = -10
ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
INFO = -11
END IF
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -16
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSPGVX', -INFO )
RETURN
END IF
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 )
$ RETURN
*
* Form a Cholesky factorization of B.
*
CALL SPPTRF( UPLO, N, BP, INFO )
IF( INFO.NE.0 ) THEN
INFO = N + INFO
RETURN
END IF
*
* Transform problem to standard eigenvalue problem and solve.
*
CALL SSPGST( ITYPE, UPLO, N, AP, BP, INFO )
CALL SSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M,
$ W, Z, LDZ, WORK, IWORK, IFAIL, INFO )
*
IF( WANTZ ) THEN
*
* Backtransform eigenvectors to the original problem.
*
IF( INFO.GT.0 )
$ M = INFO - 1
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
*
* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
*
IF( UPPER ) THEN
TRANS = 'N'
ELSE
TRANS = 'T'
END IF
*
DO 10 J = 1, M
CALL STPSV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
$ 1 )
10 CONTINUE
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* For B*A*x=(lambda)*x;
* backtransform eigenvectors: x = L*y or U'*y
*
IF( UPPER ) THEN
TRANS = 'T'
ELSE
TRANS = 'N'
END IF
*
DO 20 J = 1, M
CALL STPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
$ 1 )
20 CONTINUE
END IF
END IF
*
RETURN
*
* End of SSPGVX
*
END
SUBROUTINE SSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX,
$ FERR, BERR, WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call SLACN2 in place of SLACON, 5 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), IWORK( * )
REAL AFP( * ), AP( * ), B( LDB, * ), BERR( * ),
$ FERR( * ), WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* SSPRFS improves the computed solution to a system of linear
* equations when the coefficient matrix is symmetric indefinite
* and packed, and provides error bounds and backward error estimates
* for the solution.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* 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 matrices B and X. NRHS >= 0.
*
* AP (input) REAL array, dimension (N*(N+1)/2)
* The upper or lower triangle of the symmetric matrix A, packed
* columnwise in a linear array. The j-th column of A is stored
* in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
*
* AFP (input) REAL array, dimension (N*(N+1)/2)
* The factored form of the matrix A. AFP contains the block
* diagonal matrix D and the multipliers used to obtain the
* factor U or L from the factorization A = U*D*U**T or
* A = L*D*L**T as computed by SSPTRF, stored as a packed
* triangular matrix.
*
* IPIV (input) INTEGER array, dimension (N)
* Details of the interchanges and the block structure of D
* as determined by SSPTRF.
*
* B (input) REAL array, dimension (LDB,NRHS)
* The right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input/output) REAL array, dimension (LDX,NRHS)
* On entry, the solution matrix X, as computed by SSPTRS.
* On exit, the improved solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* FERR (output) REAL array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) REAL array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Internal Parameters
* ===================
*
* ITMAX is the maximum number of steps of iterative refinement.
*
* =====================================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 5 )
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
REAL TWO
PARAMETER ( TWO = 2.0E+0 )
REAL THREE
PARAMETER ( THREE = 3.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER COUNT, I, IK, J, K, KASE, KK, NZ
REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, SLACN2, SSPMV, SSPTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH
EXTERNAL LSAME, SLAMCH
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSPRFS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
DO 10 J = 1, NRHS
FERR( J ) = ZERO
BERR( J ) = ZERO
10 CONTINUE
RETURN
END IF
*
* NZ = maximum number of nonzero elements in each row of A, plus 1
*
NZ = N + 1
EPS = SLAMCH( 'Epsilon' )
SAFMIN = SLAMCH( 'Safe minimum' )
SAFE1 = NZ*SAFMIN
SAFE2 = SAFE1 / EPS
*
* Do for each right hand side
*
DO 140 J = 1, NRHS
*
COUNT = 1
LSTRES = THREE
20 CONTINUE
*
* Loop until stopping criterion is satisfied.
*
* Compute residual R = B - A * X
*
CALL SCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
CALL SSPMV( UPLO, N, -ONE, AP, X( 1, J ), 1, ONE, WORK( N+1 ),
$ 1 )
*
* Compute componentwise relative backward error from formula
*
* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
*
* where abs(Z) is the componentwise absolute value of the matrix
* or vector Z. If the i-th component of the denominator is less
* than SAFE2, then SAFE1 is added to the i-th components of the
* numerator and denominator before dividing.
*
DO 30 I = 1, N
WORK( I ) = ABS( B( I, J ) )
30 CONTINUE
*
* Compute abs(A)*abs(X) + abs(B).
*
KK = 1
IF( UPPER ) THEN
DO 50 K = 1, N
S = ZERO
XK = ABS( X( K, J ) )
IK = KK
DO 40 I = 1, K - 1
WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK
S = S + ABS( AP( IK ) )*ABS( X( I, J ) )
IK = IK + 1
40 CONTINUE
WORK( K ) = WORK( K ) + ABS( AP( KK+K-1 ) )*XK + S
KK = KK + K
50 CONTINUE
ELSE
DO 70 K = 1, N
S = ZERO
XK = ABS( X( K, J ) )
WORK( K ) = WORK( K ) + ABS( AP( KK ) )*XK
IK = KK + 1
DO 60 I = K + 1, N
WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK
S = S + ABS( AP( IK ) )*ABS( X( I, J ) )
IK = IK + 1
60 CONTINUE
WORK( K ) = WORK( K ) + S
KK = KK + ( N-K+1 )
70 CONTINUE
END IF
S = ZERO
DO 80 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
ELSE
S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
$ ( WORK( I )+SAFE1 ) )
END IF
80 CONTINUE
BERR( J ) = S
*
* Test stopping criterion. Continue iterating if
* 1) The residual BERR(J) is larger than machine epsilon, and
* 2) BERR(J) decreased by at least a factor of 2 during the
* last iteration, and
* 3) At most ITMAX iterations tried.
*
IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
$ COUNT.LE.ITMAX ) THEN
*
* Update solution and try again.
*
CALL SSPTRS( UPLO, N, 1, AFP, IPIV, WORK( N+1 ), N, INFO )
CALL SAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
LSTRES = BERR( J )
COUNT = COUNT + 1
GO TO 20
END IF
*
* Bound error from formula
*
* norm(X - XTRUE) / norm(X) .le. FERR =
* norm( abs(inv(A))*
* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
*
* where
* norm(Z) is the magnitude of the largest component of Z
* inv(A) is the inverse of A
* abs(Z) is the componentwise absolute value of the matrix or
* vector Z
* NZ is the maximum number of nonzeros in any row of A, plus 1
* EPS is machine epsilon
*
* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
* is incremented by SAFE1 if the i-th component of
* abs(A)*abs(X) + abs(B) is less than SAFE2.
*
* Use SLACN2 to estimate the infinity-norm of the matrix
* inv(A) * diag(W),
* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
*
DO 90 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
ELSE
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
END IF
90 CONTINUE
*
KASE = 0
100 CONTINUE
CALL SLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
$ KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Multiply by diag(W)*inv(A').
*
CALL SSPTRS( UPLO, N, 1, AFP, IPIV, WORK( N+1 ), N,
$ INFO )
DO 110 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
110 CONTINUE
ELSE IF( KASE.EQ.2 ) THEN
*
* Multiply by inv(A)*diag(W).
*
DO 120 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
120 CONTINUE
CALL SSPTRS( UPLO, N, 1, AFP, IPIV, WORK( N+1 ), N,
$ INFO )
END IF
GO TO 100
END IF
*
* Normalize error.
*
LSTRES = ZERO
DO 130 I = 1, N
LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
130 CONTINUE
IF( LSTRES.NE.ZERO )
$ FERR( J ) = FERR( J ) / LSTRES
*
140 CONTINUE
*
RETURN
*
* End of SSPRFS
*
END
SUBROUTINE SSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
REAL AP( * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* SSPSV computes the solution to a real system of linear equations
* A * X = B,
* where A is an N-by-N symmetric matrix stored in packed format and X
* and B are N-by-NRHS matrices.
*
* The diagonal pivoting method is used to factor A as
* A = U * D * U**T, if UPLO = 'U', or
* A = L * D * L**T, if UPLO = 'L',
* where U (or L) is a product of permutation and unit upper (lower)
* triangular matrices, D is symmetric and block diagonal with 1-by-1
* and 2-by-2 diagonal blocks. The factored form of A is then used to
* solve the system of equations A * X = B.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The number of linear equations, i.e., 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.
*
* AP (input/output) REAL array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* A, packed columnwise in a linear array. The j-th column of A
* is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
* See below for further details.
*
* On exit, the block diagonal matrix D and the multipliers used
* to obtain the factor U or L from the factorization
* A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as
* a packed triangular matrix in the same storage format as A.
*
* IPIV (output) INTEGER array, dimension (N)
* Details of the interchanges and the block structure of D, as
* determined by SSPTRF. If IPIV(k) > 0, then rows and columns
* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1
* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,
* then rows and columns k-1 and -IPIV(k) were interchanged and
* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and
* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and
* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2
* diagonal block.
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the N-by-NRHS right hand side matrix B.
* On exit, if INFO = 0, the N-by-NRHS 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
* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
* has been completed, but the block diagonal matrix D is
* exactly singular, so the solution could not be
* computed.
*
* Further Details
* ===============
*
* The packed storage scheme is illustrated by the following example
* when N = 4, UPLO = 'U':
*
* Two-dimensional storage of the symmetric matrix A:
*
* a11 a12 a13 a14
* a22 a23 a24
* a33 a34 (aij = aji)
* a44
*
* Packed storage of the upper triangle of A:
*
* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SSPTRF, SSPTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSPSV ', -INFO )
RETURN
END IF
*
* Compute the factorization A = U*D*U' or A = L*D*L'.
*
CALL SSPTRF( UPLO, N, AP, IPIV, INFO )
IF( INFO.EQ.0 ) THEN
*
* Solve the system A*X = B, overwriting B with X.
*
CALL SSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
*
END IF
RETURN
*
* End of SSPSV
*
END
SUBROUTINE SSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X,
$ LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER FACT, UPLO
INTEGER INFO, LDB, LDX, N, NRHS
REAL RCOND
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), IWORK( * )
REAL AFP( * ), AP( * ), B( LDB, * ), BERR( * ),
$ FERR( * ), WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* SSPSVX uses the diagonal pivoting factorization A = U*D*U**T or
* A = L*D*L**T to compute the solution to a real system of linear
* equations A * X = B, where A is an N-by-N symmetric matrix stored
* in packed format and X and B are N-by-NRHS matrices.
*
* Error bounds on the solution and a condition estimate are also
* provided.
*
* Description
* ===========
*
* The following steps are performed:
*
* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as
* A = U * D * U**T, if UPLO = 'U', or
* A = L * D * L**T, if UPLO = 'L',
* where U (or L) is a product of permutation and unit upper (lower)
* triangular matrices and D is symmetric and block diagonal with
* 1-by-1 and 2-by-2 diagonal blocks.
*
* 2. If some D(i,i)=0, so that D is exactly singular, then the routine
* returns with INFO = i. Otherwise, the factored form of A is used
* to estimate the condition number of the matrix A. If the
* reciprocal of the condition number is less than machine precision,
* INFO = N+1 is returned as a warning, but the routine still goes on
* to solve for X and compute error bounds as described below.
*
* 3. The system of equations is solved for X using the factored form
* of A.
*
* 4. Iterative refinement is applied to improve the computed solution
* matrix and calculate error bounds and backward error estimates
* for it.
*
* Arguments
* =========
*
* FACT (input) CHARACTER*1
* Specifies whether or not the factored form of A has been
* supplied on entry.
* = 'F': On entry, AFP and IPIV contain the factored form of
* A. AP, AFP and IPIV will not be modified.
* = 'N': The matrix A will be copied to AFP and factored.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The number of linear equations, i.e., 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 matrices B and X. NRHS >= 0.
*
* AP (input) REAL array, dimension (N*(N+1)/2)
* The upper or lower triangle of the symmetric matrix A, packed
* columnwise in a linear array. The j-th column of A is stored
* in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
* See below for further details.
*
* AFP (input or output) REAL array, dimension
* (N*(N+1)/2)
* If FACT = 'F', then AFP is an input argument and on entry
* contains the block diagonal matrix D and the multipliers used
* to obtain the factor U or L from the factorization
* A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as
* a packed triangular matrix in the same storage format as A.
*
* If FACT = 'N', then AFP is an output argument and on exit
* contains the block diagonal matrix D and the multipliers used
* to obtain the factor U or L from the factorization
* A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as
* a packed triangular matrix in the same storage format as A.
*
* IPIV (input or output) INTEGER array, dimension (N)
* If FACT = 'F', then IPIV is an input argument and on entry
* contains details of the interchanges and the block structure
* of D, as determined by SSPTRF.
* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
* interchanged and D(k,k) is a 1-by-1 diagonal block.
* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*
* If FACT = 'N', then IPIV is an output argument and on exit
* contains details of the interchanges and the block structure
* of D, as determined by SSPTRF.
*
* B (input) REAL array, dimension (LDB,NRHS)
* The N-by-NRHS right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (output) REAL array, dimension (LDX,NRHS)
* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* RCOND (output) REAL
* The estimate of the reciprocal condition number of the matrix
* A. If RCOND is less than the machine precision (in
* particular, if RCOND = 0), the matrix is singular to working
* precision. This condition is indicated by a return code of
* INFO > 0.
*
* FERR (output) REAL array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) REAL array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, and i is
* <= N: D(i,i) is exactly zero. The factorization
* has been completed but the factor D is exactly
* singular, so the solution and error bounds could
* not be computed. RCOND = 0 is returned.
* = N+1: D is nonsingular, but RCOND is less than machine
* precision, meaning that the matrix is singular
* to working precision. Nevertheless, the
* solution and error bounds are computed because
* there are a number of situations where the
* computed solution can be more accurate than the
* value of RCOND would suggest.
*
* Further Details
* ===============
*
* The packed storage scheme is illustrated by the following example
* when N = 4, UPLO = 'U':
*
* Two-dimensional storage of the symmetric matrix A:
*
* a11 a12 a13 a14
* a22 a23 a24
* a33 a34 (aij = aji)
* a44
*
* Packed storage of the upper triangle of A:
*
* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOFACT
REAL ANORM
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANSP
EXTERNAL LSAME, SLAMCH, SLANSP
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLACPY, SSPCON, SSPRFS, SSPTRF, SSPTRS,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
NOFACT = LSAME( FACT, 'N' )
IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
INFO = -1
ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
$ THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.0 ) THEN
INFO = -4
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -11
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSPSVX', -INFO )
RETURN
END IF
*
IF( NOFACT ) THEN
*
* Compute the factorization A = U*D*U' or A = L*D*L'.
*
CALL SCOPY( N*( N+1 ) / 2, AP, 1, AFP, 1 )
CALL SSPTRF( UPLO, N, AFP, IPIV, INFO )
*
* Return if INFO is non-zero.
*
IF( INFO.GT.0 )THEN
RCOND = ZERO
RETURN
END IF
END IF
*
* Compute the norm of the matrix A.
*
ANORM = SLANSP( 'I', UPLO, N, AP, WORK )
*
* Compute the reciprocal of the condition number of A.
*
CALL SSPCON( UPLO, N, AFP, IPIV, ANORM, RCOND, WORK, IWORK, INFO )
*
* Compute the solution vectors X.
*
CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
CALL SSPTRS( UPLO, N, NRHS, AFP, IPIV, X, LDX, INFO )
*
* Use iterative refinement to improve the computed solutions and
* compute error bounds and backward error estimates for them.
*
CALL SSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR,
$ BERR, WORK, IWORK, INFO )
*
* Set INFO = N+1 if the matrix is singular to working precision.
*
IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
$ INFO = N + 1
*
RETURN
*
* End of SSPSVX
*
END
SUBROUTINE SSPTRD( UPLO, N, AP, D, E, TAU, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, N
* ..
* .. Array Arguments ..
REAL AP( * ), D( * ), E( * ), TAU( * )
* ..
*
* Purpose
* =======
*
* SSPTRD reduces a real symmetric matrix A stored in packed form to
* symmetric tridiagonal form T by an orthogonal similarity
* transformation: Q**T * A * Q = T.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input/output) REAL array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* A, packed columnwise in a linear array. The j-th column of A
* is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
* On exit, if UPLO = 'U', the diagonal and first superdiagonal
* of A are overwritten by the corresponding elements of the
* tridiagonal matrix T, and the elements above the first
* superdiagonal, with the array TAU, represent the orthogonal
* matrix Q as a product of elementary reflectors; if UPLO
* = 'L', the diagonal and first subdiagonal of A are over-
* written by the corresponding elements of the tridiagonal
* matrix T, and the elements below the first subdiagonal, with
* the array TAU, represent the orthogonal matrix Q as a product
* of elementary reflectors. See Further Details.
*
* D (output) REAL array, dimension (N)
* The diagonal elements of the tridiagonal matrix T:
* D(i) = A(i,i).
*
* E (output) REAL array, dimension (N-1)
* The off-diagonal elements of the tridiagonal matrix T:
* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
*
* TAU (output) REAL array, dimension (N-1)
* The scalar factors of the elementary reflectors (see Further
* Details).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Further Details
* ===============
*
* If UPLO = 'U', the matrix Q is represented as a product of elementary
* reflectors
*
* Q = H(n-1) . . . H(2) H(1).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a real scalar, and v is a real vector with
* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,
* overwriting A(1:i-1,i+1), and tau is stored in TAU(i).
*
* If UPLO = 'L', the matrix Q is represented as a product of elementary
* reflectors
*
* Q = H(1) H(2) . . . H(n-1).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a real scalar, and v is a real vector with
* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,
* overwriting A(i+2:n,i), and tau is stored in TAU(i).
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO, HALF
PARAMETER ( ONE = 1.0, ZERO = 0.0, HALF = 1.0 / 2.0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, I1, I1I1, II
REAL ALPHA, TAUI
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SLARFG, SSPMV, SSPR2, XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SDOT
EXTERNAL LSAME, SDOT
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSPTRD', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Reduce the upper triangle of A.
* I1 is the index in AP of A(1,I+1).
*
I1 = N*( N-1 ) / 2 + 1
DO 10 I = N - 1, 1, -1
*
* Generate elementary reflector H(i) = I - tau * v * v'
* to annihilate A(1:i-1,i+1)
*
CALL SLARFG( I, AP( I1+I-1 ), AP( I1 ), 1, TAUI )
E( I ) = AP( I1+I-1 )
*
IF( TAUI.NE.ZERO ) THEN
*
* Apply H(i) from both sides to A(1:i,1:i)
*
AP( I1+I-1 ) = ONE
*
* Compute y := tau * A * v storing y in TAU(1:i)
*
CALL SSPMV( UPLO, I, TAUI, AP, AP( I1 ), 1, ZERO, TAU,
$ 1 )
*
* Compute w := y - 1/2 * tau * (y'*v) * v
*
ALPHA = -HALF*TAUI*SDOT( I, TAU, 1, AP( I1 ), 1 )
CALL SAXPY( I, ALPHA, AP( I1 ), 1, TAU, 1 )
*
* Apply the transformation as a rank-2 update:
* A := A - v * w' - w * v'
*
CALL SSPR2( UPLO, I, -ONE, AP( I1 ), 1, TAU, 1, AP )
*
AP( I1+I-1 ) = E( I )
END IF
D( I+1 ) = AP( I1+I )
TAU( I ) = TAUI
I1 = I1 - I
10 CONTINUE
D( 1 ) = AP( 1 )
ELSE
*
* Reduce the lower triangle of A. II is the index in AP of
* A(i,i) and I1I1 is the index of A(i+1,i+1).
*
II = 1
DO 20 I = 1, N - 1
I1I1 = II + N - I + 1
*
* Generate elementary reflector H(i) = I - tau * v * v'
* to annihilate A(i+2:n,i)
*
CALL SLARFG( N-I, AP( II+1 ), AP( II+2 ), 1, TAUI )
E( I ) = AP( II+1 )
*
IF( TAUI.NE.ZERO ) THEN
*
* Apply H(i) from both sides to A(i+1:n,i+1:n)
*
AP( II+1 ) = ONE
*
* Compute y := tau * A * v storing y in TAU(i:n-1)
*
CALL SSPMV( UPLO, N-I, TAUI, AP( I1I1 ), AP( II+1 ), 1,
$ ZERO, TAU( I ), 1 )
*
* Compute w := y - 1/2 * tau * (y'*v) * v
*
ALPHA = -HALF*TAUI*SDOT( N-I, TAU( I ), 1, AP( II+1 ),
$ 1 )
CALL SAXPY( N-I, ALPHA, AP( II+1 ), 1, TAU( I ), 1 )
*
* Apply the transformation as a rank-2 update:
* A := A - v * w' - w * v'
*
CALL SSPR2( UPLO, N-I, -ONE, AP( II+1 ), 1, TAU( I ), 1,
$ AP( I1I1 ) )
*
AP( II+1 ) = E( I )
END IF
D( I ) = AP( II )
TAU( I ) = TAUI
II = I1I1
20 CONTINUE
D( N ) = AP( II )
END IF
*
RETURN
*
* End of SSPTRD
*
END
SUBROUTINE SSPTRF( UPLO, N, AP, IPIV, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
REAL AP( * )
* ..
*
* Purpose
* =======
*
* SSPTRF computes the factorization of a real symmetric matrix A stored
* in packed format using the Bunch-Kaufman diagonal pivoting method:
*
* A = U*D*U**T or A = L*D*L**T
*
* where U (or L) is a product of permutation and unit upper (lower)
* triangular matrices, and D is symmetric and block diagonal with
* 1-by-1 and 2-by-2 diagonal blocks.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input/output) REAL array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the symmetric matrix
* A, packed columnwise in a linear array. The j-th column of A
* is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
*
* On exit, the block diagonal matrix D and the multipliers used
* to obtain the factor U or L, stored as a packed triangular
* matrix overwriting A (see below for further details).
*
* IPIV (output) INTEGER array, dimension (N)
* Details of the interchanges and the block structure of D.
* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
* interchanged and D(k,k) is a 1-by-1 diagonal block.
* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
* has been completed, but the block diagonal matrix D is
* exactly singular, and division by zero will occur if it
* is used to solve a system of equations.
*
* Further Details
* ===============
*
* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services
* Company
*
* If UPLO = 'U', then A = U*D*U', where
* U = P(n)*U(n)* ... *P(k)U(k)* ...,
* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
* that if the diagonal block D(k) is of order s (s = 1 or 2), then
*
* ( I v 0 ) k-s
* U(k) = ( 0 I 0 ) s
* ( 0 0 I ) n-k
* k-s s n-k
*
* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
* and A(k,k), and v overwrites A(1:k-2,k-1:k).
*
* If UPLO = 'L', then A = L*D*L', where
* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
* that if the diagonal block D(k) is of order s (s = 1 or 2), then
*
* ( I 0 0 ) k-1
* L(k) = ( 0 I 0 ) s
* ( 0 v I ) n-k-s+1
* k-1 s n-k-s+1
*
* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
REAL EIGHT, SEVTEN
PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, IMAX, J, JMAX, K, KC, KK, KNC, KP, KPC,
$ KSTEP, KX, NPP
REAL ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, R1,
$ ROWMAX, T, WK, WKM1, WKP1
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
EXTERNAL LSAME, ISAMAX
* ..
* .. External Subroutines ..
EXTERNAL SSCAL, SSPR, SSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSPTRF', -INFO )
RETURN
END IF
*
* Initialize ALPHA for use in choosing pivot block size.
*
ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
*
IF( UPPER ) THEN
*
* Factorize A as U*D*U' using the upper triangle of A
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2
*
K = N
KC = ( N-1 )*N / 2 + 1
10 CONTINUE
KNC = KC
*
* If K < 1, exit from loop
*
IF( K.LT.1 )
$ GO TO 110
KSTEP = 1
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = ABS( AP( KC+K-1 ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value
*
IF( K.GT.1 ) THEN
IMAX = ISAMAX( K-1, AP( KC ), 1 )
COLMAX = ABS( AP( KC+IMAX-1 ) )
ELSE
COLMAX = ZERO
END IF
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* Column K is zero: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
ELSE
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value
*
ROWMAX = ZERO
JMAX = IMAX
KX = IMAX*( IMAX+1 ) / 2 + IMAX
DO 20 J = IMAX + 1, K
IF( ABS( AP( KX ) ).GT.ROWMAX ) THEN
ROWMAX = ABS( AP( KX ) )
JMAX = J
END IF
KX = KX + J
20 CONTINUE
KPC = ( IMAX-1 )*IMAX / 2 + 1
IF( IMAX.GT.1 ) THEN
JMAX = ISAMAX( IMAX-1, AP( KPC ), 1 )
ROWMAX = MAX( ROWMAX, ABS( AP( KPC+JMAX-1 ) ) )
END IF
*
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE IF( ABS( AP( KPC+IMAX-1 ) ).GE.ALPHA*ROWMAX ) THEN
*
* interchange rows and columns K and IMAX, use 1-by-1
* pivot block
*
KP = IMAX
ELSE
*
* interchange rows and columns K-1 and IMAX, use 2-by-2
* pivot block
*
KP = IMAX
KSTEP = 2
END IF
END IF
*
KK = K - KSTEP + 1
IF( KSTEP.EQ.2 )
$ KNC = KNC - K + 1
IF( KP.NE.KK ) THEN
*
* Interchange rows and columns KK and KP in the leading
* submatrix A(1:k,1:k)
*
CALL SSWAP( KP-1, AP( KNC ), 1, AP( KPC ), 1 )
KX = KPC + KP - 1
DO 30 J = KP + 1, KK - 1
KX = KX + J - 1
T = AP( KNC+J-1 )
AP( KNC+J-1 ) = AP( KX )
AP( KX ) = T
30 CONTINUE
T = AP( KNC+KK-1 )
AP( KNC+KK-1 ) = AP( KPC+KP-1 )
AP( KPC+KP-1 ) = T
IF( KSTEP.EQ.2 ) THEN
T = AP( KC+K-2 )
AP( KC+K-2 ) = AP( KC+KP-1 )
AP( KC+KP-1 ) = T
END IF
END IF
*
* Update the leading submatrix
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column k now holds
*
* W(k) = U(k)*D(k)
*
* where U(k) is the k-th column of U
*
* Perform a rank-1 update of A(1:k-1,1:k-1) as
*
* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)'
*
R1 = ONE / AP( KC+K-1 )
CALL SSPR( UPLO, K-1, -R1, AP( KC ), 1, AP )
*
* Store U(k) in column k
*
CALL SSCAL( K-1, R1, AP( KC ), 1 )
ELSE
*
* 2-by-2 pivot block D(k): columns k and k-1 now hold
*
* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
*
* where U(k) and U(k-1) are the k-th and (k-1)-th columns
* of U
*
* Perform a rank-2 update of A(1:k-2,1:k-2) as
*
* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )'
* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )'
*
IF( K.GT.2 ) THEN
*
D12 = AP( K-1+( K-1 )*K / 2 )
D22 = AP( K-1+( K-2 )*( K-1 ) / 2 ) / D12
D11 = AP( K+( K-1 )*K / 2 ) / D12
T = ONE / ( D11*D22-ONE )
D12 = T / D12
*
DO 50 J = K - 2, 1, -1
WKM1 = D12*( D11*AP( J+( K-2 )*( K-1 ) / 2 )-
$ AP( J+( K-1 )*K / 2 ) )
WK = D12*( D22*AP( J+( K-1 )*K / 2 )-
$ AP( J+( K-2 )*( K-1 ) / 2 ) )
DO 40 I = J, 1, -1
AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) -
$ AP( I+( K-1 )*K / 2 )*WK -
$ AP( I+( K-2 )*( K-1 ) / 2 )*WKM1
40 CONTINUE
AP( J+( K-1 )*K / 2 ) = WK
AP( J+( K-2 )*( K-1 ) / 2 ) = WKM1
50 CONTINUE
*
END IF
*
END IF
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -KP
IPIV( K-1 ) = -KP
END IF
*
* Decrease K and return to the start of the main loop
*
K = K - KSTEP
KC = KNC - K
GO TO 10
*
ELSE
*
* Factorize A as L*D*L' using the lower triangle of A
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2
*
K = 1
KC = 1
NPP = N*( N+1 ) / 2
60 CONTINUE
KNC = KC
*
* If K > N, exit from loop
*
IF( K.GT.N )
$ GO TO 110
KSTEP = 1
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = ABS( AP( KC ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value
*
IF( K.LT.N ) THEN
IMAX = K + ISAMAX( N-K, AP( KC+1 ), 1 )
COLMAX = ABS( AP( KC+IMAX-K ) )
ELSE
COLMAX = ZERO
END IF
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* Column K is zero: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
ELSE
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value
*
ROWMAX = ZERO
KX = KC + IMAX - K
DO 70 J = K, IMAX - 1
IF( ABS( AP( KX ) ).GT.ROWMAX ) THEN
ROWMAX = ABS( AP( KX ) )
JMAX = J
END IF
KX = KX + N - J
70 CONTINUE
KPC = NPP - ( N-IMAX+1 )*( N-IMAX+2 ) / 2 + 1
IF( IMAX.LT.N ) THEN
JMAX = IMAX + ISAMAX( N-IMAX, AP( KPC+1 ), 1 )
ROWMAX = MAX( ROWMAX, ABS( AP( KPC+JMAX-IMAX ) ) )
END IF
*
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE IF( ABS( AP( KPC ) ).GE.ALPHA*ROWMAX ) THEN
*
* interchange rows and columns K and IMAX, use 1-by-1
* pivot block
*
KP = IMAX
ELSE
*
* interchange rows and columns K+1 and IMAX, use 2-by-2
* pivot block
*
KP = IMAX
KSTEP = 2
END IF
END IF
*
KK = K + KSTEP - 1
IF( KSTEP.EQ.2 )
$ KNC = KNC + N - K + 1
IF( KP.NE.KK ) THEN
*
* Interchange rows and columns KK and KP in the trailing
* submatrix A(k:n,k:n)
*
IF( KP.LT.N )
$ CALL SSWAP( N-KP, AP( KNC+KP-KK+1 ), 1, AP( KPC+1 ),
$ 1 )
KX = KNC + KP - KK
DO 80 J = KK + 1, KP - 1
KX = KX + N - J + 1
T = AP( KNC+J-KK )
AP( KNC+J-KK ) = AP( KX )
AP( KX ) = T
80 CONTINUE
T = AP( KNC )
AP( KNC ) = AP( KPC )
AP( KPC ) = T
IF( KSTEP.EQ.2 ) THEN
T = AP( KC+1 )
AP( KC+1 ) = AP( KC+KP-K )
AP( KC+KP-K ) = T
END IF
END IF
*
* Update the trailing submatrix
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column k now holds
*
* W(k) = L(k)*D(k)
*
* where L(k) is the k-th column of L
*
IF( K.LT.N ) THEN
*
* Perform a rank-1 update of A(k+1:n,k+1:n) as
*
* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)'
*
R1 = ONE / AP( KC )
CALL SSPR( UPLO, N-K, -R1, AP( KC+1 ), 1,
$ AP( KC+N-K+1 ) )
*
* Store L(k) in column K
*
CALL SSCAL( N-K, R1, AP( KC+1 ), 1 )
END IF
ELSE
*
* 2-by-2 pivot block D(k): columns K and K+1 now hold
*
* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
*
* where L(k) and L(k+1) are the k-th and (k+1)-th columns
* of L
*
IF( K.LT.N-1 ) THEN
*
* Perform a rank-2 update of A(k+2:n,k+2:n) as
*
* A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )'
* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )'
*
D21 = AP( K+1+( K-1 )*( 2*N-K ) / 2 )
D11 = AP( K+1+K*( 2*N-K-1 ) / 2 ) / D21
D22 = AP( K+( K-1 )*( 2*N-K ) / 2 ) / D21
T = ONE / ( D11*D22-ONE )
D21 = T / D21
*
DO 100 J = K + 2, N
WK = D21*( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )-
$ AP( J+K*( 2*N-K-1 ) / 2 ) )
WKP1 = D21*( D22*AP( J+K*( 2*N-K-1 ) / 2 )-
$ AP( J+( K-1 )*( 2*N-K ) / 2 ) )
*
DO 90 I = J, N
AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )*
$ ( 2*N-J ) / 2 ) - AP( I+( K-1 )*( 2*N-K ) /
$ 2 )*WK - AP( I+K*( 2*N-K-1 ) / 2 )*WKP1
90 CONTINUE
*
AP( J+( K-1 )*( 2*N-K ) / 2 ) = WK
AP( J+K*( 2*N-K-1 ) / 2 ) = WKP1
*
100 CONTINUE
END IF
END IF
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -KP
IPIV( K+1 ) = -KP
END IF
*
* Increase K and return to the start of the main loop
*
K = K + KSTEP
KC = KNC + N - K + 2
GO TO 60
*
END IF
*
110 CONTINUE
RETURN
*
* End of SSPTRF
*
END
SUBROUTINE SSPTRI( UPLO, N, AP, IPIV, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
REAL AP( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SSPTRI computes the inverse of a real symmetric indefinite matrix
* A in packed storage using the factorization A = U*D*U**T or
* A = L*D*L**T computed by SSPTRF.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the details of the factorization are stored
* as an upper or lower triangular matrix.
* = 'U': Upper triangular, form is A = U*D*U**T;
* = 'L': Lower triangular, form is A = L*D*L**T.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input/output) REAL array, dimension (N*(N+1)/2)
* On entry, the block diagonal matrix D and the multipliers
* used to obtain the factor U or L as computed by SSPTRF,
* stored as a packed triangular matrix.
*
* On exit, if INFO = 0, the (symmetric) inverse of the original
* matrix, stored as a packed triangular matrix. The j-th column
* of inv(A) is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;
* if UPLO = 'L',
* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.
*
* IPIV (input) INTEGER array, dimension (N)
* Details of the interchanges and the block structure of D
* as determined by SSPTRF.
*
* WORK (workspace) REAL array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
* inverse could not be computed.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, K, KC, KCNEXT, KP, KPC, KSTEP, KX, NPP
REAL AK, AKKP1, AKP1, D, T, TEMP
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SDOT
EXTERNAL LSAME, SDOT
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SSPMV, SSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSPTRI', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Check that the diagonal matrix D is nonsingular.
*
IF( UPPER ) THEN
*
* Upper triangular storage: examine D from bottom to top
*
KP = N*( N+1 ) / 2
DO 10 INFO = N, 1, -1
IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO )
$ RETURN
KP = KP - INFO
10 CONTINUE
ELSE
*
* Lower triangular storage: examine D from top to bottom.
*
KP = 1
DO 20 INFO = 1, N
IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO )
$ RETURN
KP = KP + N - INFO + 1
20 CONTINUE
END IF
INFO = 0
*
IF( UPPER ) THEN
*
* Compute inv(A) from the factorization A = U*D*U'.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
KC = 1
30 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 50
*
KCNEXT = KC + K
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Invert the diagonal block.
*
AP( KC+K-1 ) = ONE / AP( KC+K-1 )
*
* Compute column K of the inverse.
*
IF( K.GT.1 ) THEN
CALL SCOPY( K-1, AP( KC ), 1, WORK, 1 )
CALL SSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, AP( KC ),
$ 1 )
AP( KC+K-1 ) = AP( KC+K-1 ) -
$ SDOT( K-1, WORK, 1, AP( KC ), 1 )
END IF
KSTEP = 1
ELSE
*
* 2 x 2 diagonal block
*
* Invert the diagonal block.
*
T = ABS( AP( KCNEXT+K-1 ) )
AK = AP( KC+K-1 ) / T
AKP1 = AP( KCNEXT+K ) / T
AKKP1 = AP( KCNEXT+K-1 ) / T
D = T*( AK*AKP1-ONE )
AP( KC+K-1 ) = AKP1 / D
AP( KCNEXT+K ) = AK / D
AP( KCNEXT+K-1 ) = -AKKP1 / D
*
* Compute columns K and K+1 of the inverse.
*
IF( K.GT.1 ) THEN
CALL SCOPY( K-1, AP( KC ), 1, WORK, 1 )
CALL SSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, AP( KC ),
$ 1 )
AP( KC+K-1 ) = AP( KC+K-1 ) -
$ SDOT( K-1, WORK, 1, AP( KC ), 1 )
AP( KCNEXT+K-1 ) = AP( KCNEXT+K-1 ) -
$ SDOT( K-1, AP( KC ), 1, AP( KCNEXT ),
$ 1 )
CALL SCOPY( K-1, AP( KCNEXT ), 1, WORK, 1 )
CALL SSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO,
$ AP( KCNEXT ), 1 )
AP( KCNEXT+K ) = AP( KCNEXT+K ) -
$ SDOT( K-1, WORK, 1, AP( KCNEXT ), 1 )
END IF
KSTEP = 2
KCNEXT = KCNEXT + K + 1
END IF
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K ) THEN
*
* Interchange rows and columns K and KP in the leading
* submatrix A(1:k+1,1:k+1)
*
KPC = ( KP-1 )*KP / 2 + 1
CALL SSWAP( KP-1, AP( KC ), 1, AP( KPC ), 1 )
KX = KPC + KP - 1
DO 40 J = KP + 1, K - 1
KX = KX + J - 1
TEMP = AP( KC+J-1 )
AP( KC+J-1 ) = AP( KX )
AP( KX ) = TEMP
40 CONTINUE
TEMP = AP( KC+K-1 )
AP( KC+K-1 ) = AP( KPC+KP-1 )
AP( KPC+KP-1 ) = TEMP
IF( KSTEP.EQ.2 ) THEN
TEMP = AP( KC+K+K-1 )
AP( KC+K+K-1 ) = AP( KC+K+KP-1 )
AP( KC+K+KP-1 ) = TEMP
END IF
END IF
*
K = K + KSTEP
KC = KCNEXT
GO TO 30
50 CONTINUE
*
ELSE
*
* Compute inv(A) from the factorization A = L*D*L'.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
NPP = N*( N+1 ) / 2
K = N
KC = NPP
60 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 80
*
KCNEXT = KC - ( N-K+2 )
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Invert the diagonal block.
*
AP( KC ) = ONE / AP( KC )
*
* Compute column K of the inverse.
*
IF( K.LT.N ) THEN
CALL SCOPY( N-K, AP( KC+1 ), 1, WORK, 1 )
CALL SSPMV( UPLO, N-K, -ONE, AP( KC+N-K+1 ), WORK, 1,
$ ZERO, AP( KC+1 ), 1 )
AP( KC ) = AP( KC ) - SDOT( N-K, WORK, 1, AP( KC+1 ), 1 )
END IF
KSTEP = 1
ELSE
*
* 2 x 2 diagonal block
*
* Invert the diagonal block.
*
T = ABS( AP( KCNEXT+1 ) )
AK = AP( KCNEXT ) / T
AKP1 = AP( KC ) / T
AKKP1 = AP( KCNEXT+1 ) / T
D = T*( AK*AKP1-ONE )
AP( KCNEXT ) = AKP1 / D
AP( KC ) = AK / D
AP( KCNEXT+1 ) = -AKKP1 / D
*
* Compute columns K-1 and K of the inverse.
*
IF( K.LT.N ) THEN
CALL SCOPY( N-K, AP( KC+1 ), 1, WORK, 1 )
CALL SSPMV( UPLO, N-K, -ONE, AP( KC+( N-K+1 ) ), WORK, 1,
$ ZERO, AP( KC+1 ), 1 )
AP( KC ) = AP( KC ) - SDOT( N-K, WORK, 1, AP( KC+1 ), 1 )
AP( KCNEXT+1 ) = AP( KCNEXT+1 ) -
$ SDOT( N-K, AP( KC+1 ), 1,
$ AP( KCNEXT+2 ), 1 )
CALL SCOPY( N-K, AP( KCNEXT+2 ), 1, WORK, 1 )
CALL SSPMV( UPLO, N-K, -ONE, AP( KC+( N-K+1 ) ), WORK, 1,
$ ZERO, AP( KCNEXT+2 ), 1 )
AP( KCNEXT ) = AP( KCNEXT ) -
$ SDOT( N-K, WORK, 1, AP( KCNEXT+2 ), 1 )
END IF
KSTEP = 2
KCNEXT = KCNEXT - ( N-K+3 )
END IF
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K ) THEN
*
* Interchange rows and columns K and KP in the trailing
* submatrix A(k-1:n,k-1:n)
*
KPC = NPP - ( N-KP+1 )*( N-KP+2 ) / 2 + 1
IF( KP.LT.N )
$ CALL SSWAP( N-KP, AP( KC+KP-K+1 ), 1, AP( KPC+1 ), 1 )
KX = KC + KP - K
DO 70 J = K + 1, KP - 1
KX = KX + N - J + 1
TEMP = AP( KC+J-K )
AP( KC+J-K ) = AP( KX )
AP( KX ) = TEMP
70 CONTINUE
TEMP = AP( KC )
AP( KC ) = AP( KPC )
AP( KPC ) = TEMP
IF( KSTEP.EQ.2 ) THEN
TEMP = AP( KC-N+K-1 )
AP( KC-N+K-1 ) = AP( KC-N+KP-1 )
AP( KC-N+KP-1 ) = TEMP
END IF
END IF
*
K = K - KSTEP
KC = KCNEXT
GO TO 60
80 CONTINUE
END IF
*
RETURN
*
* End of SSPTRI
*
END
SUBROUTINE SSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
REAL AP( * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* SSPTRS solves a system of linear equations A*X = B with a real
* symmetric matrix A stored in packed format using the factorization
* A = U*D*U**T or A = L*D*L**T computed by SSPTRF.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the details of the factorization are stored
* as an upper or lower triangular matrix.
* = 'U': Upper triangular, form is A = U*D*U**T;
* = 'L': Lower triangular, form is A = L*D*L**T.
*
* 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.
*
* AP (input) REAL array, dimension (N*(N+1)/2)
* The block diagonal matrix D and the multipliers used to
* obtain the factor U or L as computed by SSPTRF, stored as a
* packed triangular matrix.
*
* IPIV (input) INTEGER array, dimension (N)
* Details of the interchanges and the block structure of D
* as determined by SSPTRF.
*
* B (input/output) REAL 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 ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, K, KC, KP
REAL AK, AKM1, AKM1K, BK, BKM1, DENOM
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SGEMV, SGER, SSCAL, SSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSPTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Solve A*X = B, where A = U*D*U'.
*
* First solve U*D*X = B, overwriting B with X.
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = N
KC = N*( N+1 ) / 2 + 1
10 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 30
*
KC = KC - K
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(U(K)), where U(K) is the transformation
* stored in column K of A.
*
CALL SGER( K-1, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB,
$ B( 1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
CALL SSCAL( NRHS, ONE / AP( KC+K-1 ), B( K, 1 ), LDB )
K = K - 1
ELSE
*
* 2 x 2 diagonal block
*
* Interchange rows K-1 and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K-1 )
$ CALL SSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(U(K)), where U(K) is the transformation
* stored in columns K-1 and K of A.
*
CALL SGER( K-2, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB,
$ B( 1, 1 ), LDB )
CALL SGER( K-2, NRHS, -ONE, AP( KC-( K-1 ) ), 1,
$ B( K-1, 1 ), LDB, B( 1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
AKM1K = AP( KC+K-2 )
AKM1 = AP( KC-1 ) / AKM1K
AK = AP( KC+K-1 ) / AKM1K
DENOM = AKM1*AK - ONE
DO 20 J = 1, NRHS
BKM1 = B( K-1, J ) / AKM1K
BK = B( K, J ) / AKM1K
B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
20 CONTINUE
KC = KC - K + 1
K = K - 2
END IF
*
GO TO 10
30 CONTINUE
*
* Next solve U'*X = B, overwriting B with X.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
KC = 1
40 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 50
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Multiply by inv(U'(K)), where U(K) is the transformation
* stored in column K of A.
*
CALL SGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, AP( KC ),
$ 1, ONE, B( K, 1 ), LDB )
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
KC = KC + K
K = K + 1
ELSE
*
* 2 x 2 diagonal block
*
* Multiply by inv(U'(K+1)), where U(K+1) is the transformation
* stored in columns K and K+1 of A.
*
CALL SGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, AP( KC ),
$ 1, ONE, B( K, 1 ), LDB )
CALL SGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB,
$ AP( KC+K ), 1, ONE, B( K+1, 1 ), LDB )
*
* Interchange rows K and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K )
$ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
KC = KC + 2*K + 1
K = K + 2
END IF
*
GO TO 40
50 CONTINUE
*
ELSE
*
* Solve A*X = B, where A = L*D*L'.
*
* First solve L*D*X = B, overwriting B with X.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
KC = 1
60 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 80
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(L(K)), where L(K) is the transformation
* stored in column K of A.
*
IF( K.LT.N )
$ CALL SGER( N-K, NRHS, -ONE, AP( KC+1 ), 1, B( K, 1 ),
$ LDB, B( K+1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
CALL SSCAL( NRHS, ONE / AP( KC ), B( K, 1 ), LDB )
KC = KC + N - K + 1
K = K + 1
ELSE
*
* 2 x 2 diagonal block
*
* Interchange rows K+1 and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K+1 )
$ CALL SSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(L(K)), where L(K) is the transformation
* stored in columns K and K+1 of A.
*
IF( K.LT.N-1 ) THEN
CALL SGER( N-K-1, NRHS, -ONE, AP( KC+2 ), 1, B( K, 1 ),
$ LDB, B( K+2, 1 ), LDB )
CALL SGER( N-K-1, NRHS, -ONE, AP( KC+N-K+2 ), 1,
$ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
END IF
*
* Multiply by the inverse of the diagonal block.
*
AKM1K = AP( KC+1 )
AKM1 = AP( KC ) / AKM1K
AK = AP( KC+N-K+1 ) / AKM1K
DENOM = AKM1*AK - ONE
DO 70 J = 1, NRHS
BKM1 = B( K, J ) / AKM1K
BK = B( K+1, J ) / AKM1K
B( K, J ) = ( AK*BKM1-BK ) / DENOM
B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
70 CONTINUE
KC = KC + 2*( N-K ) + 1
K = K + 2
END IF
*
GO TO 60
80 CONTINUE
*
* Next solve L'*X = B, overwriting B with X.
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = N
KC = N*( N+1 ) / 2 + 1
90 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 100
*
KC = KC - ( N-K+1 )
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Multiply by inv(L'(K)), where L(K) is the transformation
* stored in column K of A.
*
IF( K.LT.N )
$ CALL SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
$ LDB, AP( KC+1 ), 1, ONE, B( K, 1 ), LDB )
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
K = K - 1
ELSE
*
* 2 x 2 diagonal block
*
* Multiply by inv(L'(K-1)), where L(K-1) is the transformation
* stored in columns K-1 and K of A.
*
IF( K.LT.N ) THEN
CALL SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
$ LDB, AP( KC+1 ), 1, ONE, B( K, 1 ), LDB )
CALL SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
$ LDB, AP( KC-( N-K ) ), 1, ONE, B( K-1, 1 ),
$ LDB )
END IF
*
* Interchange rows K and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K )
$ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
KC = KC - ( N-K+2 )
K = K - 2
END IF
*
GO TO 90
100 CONTINUE
END IF
*
RETURN
*
* End of SSPTRS
*
END
SUBROUTINE SSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E,
$ M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
* 8-18-00: Increase FUDGE factor for T3E (eca)
*
* .. Scalar Arguments ..
CHARACTER ORDER, RANGE
INTEGER IL, INFO, IU, M, N, NSPLIT
REAL ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * )
REAL D( * ), E( * ), W( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SSTEBZ computes the eigenvalues of a symmetric tridiagonal
* matrix T. The user may ask for all eigenvalues, all eigenvalues
* in the half-open interval (VL, VU], or the IL-th through IU-th
* eigenvalues.
*
* To avoid overflow, the matrix must be scaled so that its
* largest element is no greater than overflow**(1/2) *
* underflow**(1/4) in absolute value, and for greatest
* accuracy, it should not be much smaller than that.
*
* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
* Matrix", Report CS41, Computer Science Dept., Stanford
* University, July 21, 1966.
*
* Arguments
* =========
*
* RANGE (input) CHARACTER*1
* = 'A': ("All") all eigenvalues will be found.
* = 'V': ("Value") all eigenvalues in the half-open interval
* (VL, VU] will be found.
* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
* entire matrix) will be found.
*
* ORDER (input) CHARACTER*1
* = 'B': ("By Block") the eigenvalues will be grouped by
* split-off block (see IBLOCK, ISPLIT) and
* ordered from smallest to largest within
* the block.
* = 'E': ("Entire matrix")
* the eigenvalues for the entire matrix
* will be ordered from smallest to
* largest.
*
* N (input) INTEGER
* The order of the tridiagonal matrix T. N >= 0.
*
* VL (input) REAL
* VU (input) REAL
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. Eigenvalues less than or equal
* to VL, or greater than VU, will not be returned. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* ABSTOL (input) REAL
* The absolute tolerance for the eigenvalues. An eigenvalue
* (or cluster) is considered to be located if it has been
* determined to lie in an interval whose width is ABSTOL or
* less. If ABSTOL is less than or equal to zero, then ULP*|T|
* will be used, where |T| means the 1-norm of T.
*
* Eigenvalues will be computed most accurately when ABSTOL is
* set to twice the underflow threshold 2*SLAMCH('S'), not zero.
*
* D (input) REAL array, dimension (N)
* The n diagonal elements of the tridiagonal matrix T.
*
* E (input) REAL array, dimension (N-1)
* The (n-1) off-diagonal elements of the tridiagonal matrix T.
*
* M (output) INTEGER
* The actual number of eigenvalues found. 0 <= M <= N.
* (See also the description of INFO=2,3.)
*
* NSPLIT (output) INTEGER
* The number of diagonal blocks in the matrix T.
* 1 <= NSPLIT <= N.
*
* W (output) REAL array, dimension (N)
* On exit, the first M elements of W will contain the
* eigenvalues. (SSTEBZ may use the remaining N-M elements as
* workspace.)
*
* IBLOCK (output) INTEGER array, dimension (N)
* At each row/column j where E(j) is zero or small, the
* matrix T is considered to split into a block diagonal
* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which
* block (from 1 to the number of blocks) the eigenvalue W(i)
* belongs. (SSTEBZ may use the remaining N-M elements as
* workspace.)
*
* ISPLIT (output) INTEGER array, dimension (N)
* The splitting points, at which T breaks up into submatrices.
* The first submatrix consists of rows/columns 1 to ISPLIT(1),
* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
* etc., and the NSPLIT-th consists of rows/columns
* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
* (Only the first NSPLIT elements will actually be used, but
* since the user cannot know a priori what value NSPLIT will
* have, N words must be reserved for ISPLIT.)
*
* WORK (workspace) REAL array, dimension (4*N)
*
* IWORK (workspace) INTEGER array, dimension (3*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: some or all of the eigenvalues failed to converge or
* were not computed:
* =1 or 3: Bisection failed to converge for some
* eigenvalues; these eigenvalues are flagged by a
* negative block number. The effect is that the
* eigenvalues may not be as accurate as the
* absolute and relative tolerances. This is
* generally caused by unexpectedly inaccurate
* arithmetic.
* =2 or 3: RANGE='I' only: Not all of the eigenvalues
* IL:IU were found.
* Effect: M < IU+1-IL
* Cause: non-monotonic arithmetic, causing the
* Sturm sequence to be non-monotonic.
* Cure: recalculate, using RANGE='A', and pick
* out eigenvalues IL:IU. In some cases,
* increasing the PARAMETER "FUDGE" may
* make things work.
* = 4: RANGE='I', and the Gershgorin interval
* initially used was too small. No eigenvalues
* were computed.
* Probable cause: your machine has sloppy
* floating-point arithmetic.
* Cure: Increase the PARAMETER "FUDGE",
* recompile, and try again.
*
* Internal Parameters
* ===================
*
* RELFAC REAL, default = 2.0e0
* The relative tolerance. An interval (a,b] lies within
* "relative tolerance" if b-a < RELFAC*ulp*max(|a|,|b|),
* where "ulp" is the machine precision (distance from 1 to
* the next larger floating point number.)
*
* FUDGE REAL, default = 2
* A "fudge factor" to widen the Gershgorin intervals. Ideally,
* a value of 1 should work, but on machines with sloppy
* arithmetic, this needs to be larger. The default for
* publicly released versions should be large enough to handle
* the worst machine around. Note that this has no effect
* on accuracy of the solution.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO, HALF
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ HALF = 1.0E0 / TWO )
REAL FUDGE, RELFAC
PARAMETER ( FUDGE = 2.1E0, RELFAC = 2.0E0 )
* ..
* .. Local Scalars ..
LOGICAL NCNVRG, TOOFEW
INTEGER IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO,
$ IM, IN, IOFF, IORDER, IOUT, IRANGE, ITMAX,
$ ITMP1, IW, IWOFF, J, JB, JDISC, JE, NB, NWL,
$ NWU
REAL ATOLI, BNORM, GL, GU, PIVMIN, RTOLI, SAFEMN,
$ TMP1, TMP2, TNORM, ULP, WKILL, WL, WLU, WU, WUL
* ..
* .. Local Arrays ..
INTEGER IDUMMA( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
REAL SLAMCH
EXTERNAL LSAME, ILAENV, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SLAEBZ, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Decode RANGE
*
IF( LSAME( RANGE, 'A' ) ) THEN
IRANGE = 1
ELSE IF( LSAME( RANGE, 'V' ) ) THEN
IRANGE = 2
ELSE IF( LSAME( RANGE, 'I' ) ) THEN
IRANGE = 3
ELSE
IRANGE = 0
END IF
*
* Decode ORDER
*
IF( LSAME( ORDER, 'B' ) ) THEN
IORDER = 2
ELSE IF( LSAME( ORDER, 'E' ) ) THEN
IORDER = 1
ELSE
IORDER = 0
END IF
*
* Check for Errors
*
IF( IRANGE.LE.0 ) THEN
INFO = -1
ELSE IF( IORDER.LE.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( IRANGE.EQ.2 ) THEN
IF( VL.GE.VU ) INFO = -5
ELSE IF( IRANGE.EQ.3 .AND. ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) )
$ THEN
INFO = -6
ELSE IF( IRANGE.EQ.3 .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) )
$ THEN
INFO = -7
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSTEBZ', -INFO )
RETURN
END IF
*
* Initialize error flags
*
INFO = 0
NCNVRG = .FALSE.
TOOFEW = .FALSE.
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 )
$ RETURN
*
* Simplifications:
*
IF( IRANGE.EQ.3 .AND. IL.EQ.1 .AND. IU.EQ.N )
$ IRANGE = 1
*
* Get machine constants
* NB is the minimum vector length for vector bisection, or 0
* if only scalar is to be done.
*
SAFEMN = SLAMCH( 'S' )
ULP = SLAMCH( 'P' )
RTOLI = ULP*RELFAC
NB = ILAENV( 1, 'SSTEBZ', ' ', N, -1, -1, -1 )
IF( NB.LE.1 )
$ NB = 0
*
* Special Case when N=1
*
IF( N.EQ.1 ) THEN
NSPLIT = 1
ISPLIT( 1 ) = 1
IF( IRANGE.EQ.2 .AND. ( VL.GE.D( 1 ) .OR. VU.LT.D( 1 ) ) ) THEN
M = 0
ELSE
W( 1 ) = D( 1 )
IBLOCK( 1 ) = 1
M = 1
END IF
RETURN
END IF
*
* Compute Splitting Points
*
NSPLIT = 1
WORK( N ) = ZERO
PIVMIN = ONE
*
CDIR$ NOVECTOR
DO 10 J = 2, N
TMP1 = E( J-1 )**2
IF( ABS( D( J )*D( J-1 ) )*ULP**2+SAFEMN.GT.TMP1 ) THEN
ISPLIT( NSPLIT ) = J - 1
NSPLIT = NSPLIT + 1
WORK( J-1 ) = ZERO
ELSE
WORK( J-1 ) = TMP1
PIVMIN = MAX( PIVMIN, TMP1 )
END IF
10 CONTINUE
ISPLIT( NSPLIT ) = N
PIVMIN = PIVMIN*SAFEMN
*
* Compute Interval and ATOLI
*
IF( IRANGE.EQ.3 ) THEN
*
* RANGE='I': Compute the interval containing eigenvalues
* IL through IU.
*
* Compute Gershgorin interval for entire (split) matrix
* and use it as the initial interval
*
GU = D( 1 )
GL = D( 1 )
TMP1 = ZERO
*
DO 20 J = 1, N - 1
TMP2 = SQRT( WORK( J ) )
GU = MAX( GU, D( J )+TMP1+TMP2 )
GL = MIN( GL, D( J )-TMP1-TMP2 )
TMP1 = TMP2
20 CONTINUE
*
GU = MAX( GU, D( N )+TMP1 )
GL = MIN( GL, D( N )-TMP1 )
TNORM = MAX( ABS( GL ), ABS( GU ) )
GL = GL - FUDGE*TNORM*ULP*N - FUDGE*TWO*PIVMIN
GU = GU + FUDGE*TNORM*ULP*N + FUDGE*PIVMIN
*
* Compute Iteration parameters
*
ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) /
$ LOG( TWO ) ) + 2
IF( ABSTOL.LE.ZERO ) THEN
ATOLI = ULP*TNORM
ELSE
ATOLI = ABSTOL
END IF
*
WORK( N+1 ) = GL
WORK( N+2 ) = GL
WORK( N+3 ) = GU
WORK( N+4 ) = GU
WORK( N+5 ) = GL
WORK( N+6 ) = GU
IWORK( 1 ) = -1
IWORK( 2 ) = -1
IWORK( 3 ) = N + 1
IWORK( 4 ) = N + 1
IWORK( 5 ) = IL - 1
IWORK( 6 ) = IU
*
CALL SLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN, D, E,
$ WORK, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT,
$ IWORK, W, IBLOCK, IINFO )
*
IF( IWORK( 6 ).EQ.IU ) THEN
WL = WORK( N+1 )
WLU = WORK( N+3 )
NWL = IWORK( 1 )
WU = WORK( N+4 )
WUL = WORK( N+2 )
NWU = IWORK( 4 )
ELSE
WL = WORK( N+2 )
WLU = WORK( N+4 )
NWL = IWORK( 2 )
WU = WORK( N+3 )
WUL = WORK( N+1 )
NWU = IWORK( 3 )
END IF
*
IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN
INFO = 4
RETURN
END IF
ELSE
*
* RANGE='A' or 'V' -- Set ATOLI
*
TNORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ),
$ ABS( D( N ) )+ABS( E( N-1 ) ) )
*
DO 30 J = 2, N - 1
TNORM = MAX( TNORM, ABS( D( J ) )+ABS( E( J-1 ) )+
$ ABS( E( J ) ) )
30 CONTINUE
*
IF( ABSTOL.LE.ZERO ) THEN
ATOLI = ULP*TNORM
ELSE
ATOLI = ABSTOL
END IF
*
IF( IRANGE.EQ.2 ) THEN
WL = VL
WU = VU
ELSE
WL = ZERO
WU = ZERO
END IF
END IF
*
* Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU.
* NWL accumulates the number of eigenvalues .le. WL,
* NWU accumulates the number of eigenvalues .le. WU
*
M = 0
IEND = 0
INFO = 0
NWL = 0
NWU = 0
*
DO 70 JB = 1, NSPLIT
IOFF = IEND
IBEGIN = IOFF + 1
IEND = ISPLIT( JB )
IN = IEND - IOFF
*
IF( IN.EQ.1 ) THEN
*
* Special Case -- IN=1
*
IF( IRANGE.EQ.1 .OR. WL.GE.D( IBEGIN )-PIVMIN )
$ NWL = NWL + 1
IF( IRANGE.EQ.1 .OR. WU.GE.D( IBEGIN )-PIVMIN )
$ NWU = NWU + 1
IF( IRANGE.EQ.1 .OR. ( WL.LT.D( IBEGIN )-PIVMIN .AND. WU.GE.
$ D( IBEGIN )-PIVMIN ) ) THEN
M = M + 1
W( M ) = D( IBEGIN )
IBLOCK( M ) = JB
END IF
ELSE
*
* General Case -- IN > 1
*
* Compute Gershgorin Interval
* and use it as the initial interval
*
GU = D( IBEGIN )
GL = D( IBEGIN )
TMP1 = ZERO
*
DO 40 J = IBEGIN, IEND - 1
TMP2 = ABS( E( J ) )
GU = MAX( GU, D( J )+TMP1+TMP2 )
GL = MIN( GL, D( J )-TMP1-TMP2 )
TMP1 = TMP2
40 CONTINUE
*
GU = MAX( GU, D( IEND )+TMP1 )
GL = MIN( GL, D( IEND )-TMP1 )
BNORM = MAX( ABS( GL ), ABS( GU ) )
GL = GL - FUDGE*BNORM*ULP*IN - FUDGE*PIVMIN
GU = GU + FUDGE*BNORM*ULP*IN + FUDGE*PIVMIN
*
* Compute ATOLI for the current submatrix
*
IF( ABSTOL.LE.ZERO ) THEN
ATOLI = ULP*MAX( ABS( GL ), ABS( GU ) )
ELSE
ATOLI = ABSTOL
END IF
*
IF( IRANGE.GT.1 ) THEN
IF( GU.LT.WL ) THEN
NWL = NWL + IN
NWU = NWU + IN
GO TO 70
END IF
GL = MAX( GL, WL )
GU = MIN( GU, WU )
IF( GL.GE.GU )
$ GO TO 70
END IF
*
* Set Up Initial Interval
*
WORK( N+1 ) = GL
WORK( N+IN+1 ) = GU
CALL SLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
$ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ),
$ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM,
$ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
*
NWL = NWL + IWORK( 1 )
NWU = NWU + IWORK( IN+1 )
IWOFF = M - IWORK( 1 )
*
* Compute Eigenvalues
*
ITMAX = INT( ( LOG( GU-GL+PIVMIN )-LOG( PIVMIN ) ) /
$ LOG( TWO ) ) + 2
CALL SLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
$ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ),
$ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT,
$ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
*
* Copy Eigenvalues Into W and IBLOCK
* Use -JB for block number for unconverged eigenvalues.
*
DO 60 J = 1, IOUT
TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) )
*
* Flag non-convergence.
*
IF( J.GT.IOUT-IINFO ) THEN
NCNVRG = .TRUE.
IB = -JB
ELSE
IB = JB
END IF
DO 50 JE = IWORK( J ) + 1 + IWOFF,
$ IWORK( J+IN ) + IWOFF
W( JE ) = TMP1
IBLOCK( JE ) = IB
50 CONTINUE
60 CONTINUE
*
M = M + IM
END IF
70 CONTINUE
*
* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU
* If NWL+1 < IL or NWU > IU, discard extra eigenvalues.
*
IF( IRANGE.EQ.3 ) THEN
IM = 0
IDISCL = IL - 1 - NWL
IDISCU = NWU - IU
*
IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
DO 80 JE = 1, M
IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN
IDISCL = IDISCL - 1
ELSE IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN
IDISCU = IDISCU - 1
ELSE
IM = IM + 1
W( IM ) = W( JE )
IBLOCK( IM ) = IBLOCK( JE )
END IF
80 CONTINUE
M = IM
END IF
IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
*
* Code to deal with effects of bad arithmetic:
* Some low eigenvalues to be discarded are not in (WL,WLU],
* or high eigenvalues to be discarded are not in (WUL,WU]
* so just kill off the smallest IDISCL/largest IDISCU
* eigenvalues, by simply finding the smallest/largest
* eigenvalue(s).
*
* (If N(w) is monotone non-decreasing, this should never
* happen.)
*
IF( IDISCL.GT.0 ) THEN
WKILL = WU
DO 100 JDISC = 1, IDISCL
IW = 0
DO 90 JE = 1, M
IF( IBLOCK( JE ).NE.0 .AND.
$ ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN
IW = JE
WKILL = W( JE )
END IF
90 CONTINUE
IBLOCK( IW ) = 0
100 CONTINUE
END IF
IF( IDISCU.GT.0 ) THEN
*
WKILL = WL
DO 120 JDISC = 1, IDISCU
IW = 0
DO 110 JE = 1, M
IF( IBLOCK( JE ).NE.0 .AND.
$ ( W( JE ).GT.WKILL .OR. IW.EQ.0 ) ) THEN
IW = JE
WKILL = W( JE )
END IF
110 CONTINUE
IBLOCK( IW ) = 0
120 CONTINUE
END IF
IM = 0
DO 130 JE = 1, M
IF( IBLOCK( JE ).NE.0 ) THEN
IM = IM + 1
W( IM ) = W( JE )
IBLOCK( IM ) = IBLOCK( JE )
END IF
130 CONTINUE
M = IM
END IF
IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN
TOOFEW = .TRUE.
END IF
END IF
*
* If ORDER='B', do nothing -- the eigenvalues are already sorted
* by block.
* If ORDER='E', sort the eigenvalues from smallest to largest
*
IF( IORDER.EQ.1 .AND. NSPLIT.GT.1 ) THEN
DO 150 JE = 1, M - 1
IE = 0
TMP1 = W( JE )
DO 140 J = JE + 1, M
IF( W( J ).LT.TMP1 ) THEN
IE = J
TMP1 = W( J )
END IF
140 CONTINUE
*
IF( IE.NE.0 ) THEN
ITMP1 = IBLOCK( IE )
W( IE ) = W( JE )
IBLOCK( IE ) = IBLOCK( JE )
W( JE ) = TMP1
IBLOCK( JE ) = ITMP1
END IF
150 CONTINUE
END IF
*
INFO = 0
IF( NCNVRG )
$ INFO = INFO + 1
IF( TOOFEW )
$ INFO = INFO + 2
RETURN
*
* End of SSTEBZ
*
END
SUBROUTINE SSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK,
$ LIWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER COMPZ
INTEGER INFO, LDZ, LIWORK, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL D( * ), E( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SSTEDC computes all eigenvalues and, optionally, eigenvectors of a
* symmetric tridiagonal matrix using the divide and conquer method.
* The eigenvectors of a full or band real symmetric matrix can also be
* found if SSYTRD or SSPTRD or SSBTRD has been used to reduce this
* matrix to tridiagonal form.
*
* This code makes very mild assumptions about floating point
* arithmetic. It will work on machines with a guard digit in
* add/subtract, or on those binary machines without guard digits
* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
* It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none. See SLAED3 for details.
*
* Arguments
* =========
*
* COMPZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only.
* = 'I': Compute eigenvectors of tridiagonal matrix also.
* = 'V': Compute eigenvectors of original dense symmetric
* matrix also. On entry, Z contains the orthogonal
* matrix used to reduce the original matrix to
* tridiagonal form.
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* D (input/output) REAL array, dimension (N)
* On entry, the diagonal elements of the tridiagonal matrix.
* On exit, if INFO = 0, the eigenvalues in ascending order.
*
* E (input/output) REAL array, dimension (N-1)
* On entry, the subdiagonal elements of the tridiagonal matrix.
* On exit, E has been destroyed.
*
* Z (input/output) REAL array, dimension (LDZ,N)
* On entry, if COMPZ = 'V', then Z contains the orthogonal
* matrix used in the reduction to tridiagonal form.
* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
* orthonormal eigenvectors of the original symmetric matrix,
* and if COMPZ = 'I', Z contains the orthonormal eigenvectors
* of the symmetric tridiagonal matrix.
* If COMPZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1.
* If eigenvectors are desired, then LDZ >= max(1,N).
*
* WORK (workspace/output) REAL 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 COMPZ = 'N' or N <= 1 then LWORK must be at least 1.
* If COMPZ = 'V' and N > 1 then LWORK must be at least
* ( 1 + 3*N + 2*N*lg N + 3*N**2 ),
* where lg( N ) = smallest integer k such
* that 2**k >= N.
* If COMPZ = 'I' and N > 1 then LWORK must be at least
* ( 1 + 4*N + N**2 ).
* Note that for COMPZ = 'I' or 'V', then if N is less than or
* equal to the minimum divide size, usually 25, then LWORK need
* only be max(1,2*(N-1)).
*
* 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.
*
* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK.
* If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1.
* If COMPZ = 'V' and N > 1 then LIWORK must be at least
* ( 6 + 6*N + 5*N*lg N ).
* If COMPZ = 'I' and N > 1 then LIWORK must be at least
* ( 3 + 5*N ).
* Note that for COMPZ = 'I' or 'V', then if N is less than or
* equal to the minimum divide size, usually 25, then LIWORK
* need only be 1.
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal size of the IWORK array,
* returns this value as the first entry of the IWORK array, and
* no error message related to LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: The algorithm failed to compute an eigenvalue while
* working on the submatrix lying in rows and columns
* INFO/(N+1) through mod(INFO,N+1).
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
* Modified by Francoise Tisseur, University of Tennessee.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER FINISH, I, ICOMPZ, II, J, K, LGN, LIWMIN,
$ LWMIN, M, SMLSIZ, START, STOREZ, STRTRW
REAL EPS, ORGNRM, P, TINY
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
REAL SLAMCH, SLANST
EXTERNAL ILAENV, LSAME, SLAMCH, SLANST
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SLACPY, SLAED0, SLASCL, SLASET, SLASRT,
$ SSTEQR, SSTERF, SSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX, MOD, REAL, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
IF( LSAME( COMPZ, 'N' ) ) THEN
ICOMPZ = 0
ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
ICOMPZ = 1
ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
ICOMPZ = 2
ELSE
ICOMPZ = -1
END IF
IF( ICOMPZ.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ( LDZ.LT.1 ) .OR.
$ ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, N ) ) ) THEN
INFO = -6
END IF
*
IF( INFO.EQ.0 ) THEN
*
* Compute the workspace requirements
*
SMLSIZ = ILAENV( 9, 'SSTEDC', ' ', 0, 0, 0, 0 )
IF( N.LE.1 .OR. ICOMPZ.EQ.0 ) THEN
LIWMIN = 1
LWMIN = 1
ELSE IF( N.LE.SMLSIZ ) THEN
LIWMIN = 1
LWMIN = 2*( N - 1 )
ELSE
LGN = INT( LOG( REAL( N ) )/LOG( TWO ) )
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IF( ICOMPZ.EQ.1 ) THEN
LWMIN = 1 + 3*N + 2*N*LGN + 3*N**2
LIWMIN = 6 + 6*N + 5*N*LGN
ELSE IF( ICOMPZ.EQ.2 ) THEN
LWMIN = 1 + 4*N + N**2
LIWMIN = 3 + 5*N
END IF
END IF
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
IF( LWORK.LT.LWMIN .AND. .NOT. LQUERY ) THEN
INFO = -8
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT. LQUERY ) THEN
INFO = -10
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSTEDC', -INFO )
RETURN
ELSE IF (LQUERY) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
IF( N.EQ.1 ) THEN
IF( ICOMPZ.NE.0 )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* If the following conditional clause is removed, then the routine
* will use the Divide and Conquer routine to compute only the
* eigenvalues, which requires (3N + 3N**2) real workspace and
* (2 + 5N + 2N lg(N)) integer workspace.
* Since on many architectures SSTERF is much faster than any other
* algorithm for finding eigenvalues only, it is used here
* as the default. If the conditional clause is removed, then
* information on the size of workspace needs to be changed.
*
* If COMPZ = 'N', use SSTERF to compute the eigenvalues.
*
IF( ICOMPZ.EQ.0 ) THEN
CALL SSTERF( N, D, E, INFO )
GO TO 50
END IF
*
* If N is smaller than the minimum divide size (SMLSIZ+1), then
* solve the problem with another solver.
*
IF( N.LE.SMLSIZ ) THEN
*
CALL SSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
*
ELSE
*
* If COMPZ = 'V', the Z matrix must be stored elsewhere for later
* use.
*
IF( ICOMPZ.EQ.1 ) THEN
STOREZ = 1 + N*N
ELSE
STOREZ = 1
END IF
*
IF( ICOMPZ.EQ.2 ) THEN
CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
END IF
*
* Scale.
*
ORGNRM = SLANST( 'M', N, D, E )
IF( ORGNRM.EQ.ZERO )
$ GO TO 50
*
EPS = SLAMCH( 'Epsilon' )
*
START = 1
*
* while ( START <= N )
*
10 CONTINUE
IF( START.LE.N ) THEN
*
* Let FINISH be the position of the next subdiagonal entry
* such that E( FINISH ) <= TINY or FINISH = N if no such
* subdiagonal exists. The matrix identified by the elements
* between START and FINISH constitutes an independent
* sub-problem.
*
FINISH = START
20 CONTINUE
IF( FINISH.LT.N ) THEN
TINY = EPS*SQRT( ABS( D( FINISH ) ) )*
$ SQRT( ABS( D( FINISH+1 ) ) )
IF( ABS( E( FINISH ) ).GT.TINY ) THEN
FINISH = FINISH + 1
GO TO 20
END IF
END IF
*
* (Sub) Problem determined. Compute its size and solve it.
*
M = FINISH - START + 1
IF( M.EQ.1 ) THEN
START = FINISH + 1
GO TO 10
END IF
IF( M.GT.SMLSIZ ) THEN
*
* Scale.
*
ORGNRM = SLANST( 'M', M, D( START ), E( START ) )
CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ), M,
$ INFO )
CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1, E( START ),
$ M-1, INFO )
*
IF( ICOMPZ.EQ.1 ) THEN
STRTRW = 1
ELSE
STRTRW = START
END IF
CALL SLAED0( ICOMPZ, N, M, D( START ), E( START ),
$ Z( STRTRW, START ), LDZ, WORK( 1 ), N,
$ WORK( STOREZ ), IWORK, INFO )
IF( INFO.NE.0 ) THEN
INFO = ( INFO / ( M+1 )+START-1 )*( N+1 ) +
$ MOD( INFO, ( M+1 ) ) + START - 1
GO TO 50
END IF
*
* Scale back.
*
CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ), M,
$ INFO )
*
ELSE
IF( ICOMPZ.EQ.1 ) THEN
*
* Since QR won't update a Z matrix which is larger than
* the length of D, we must solve the sub-problem in a
* workspace and then multiply back into Z.
*
CALL SSTEQR( 'I', M, D( START ), E( START ), WORK, M,
$ WORK( M*M+1 ), INFO )
CALL SLACPY( 'A', N, M, Z( 1, START ), LDZ,
$ WORK( STOREZ ), N )
CALL SGEMM( 'N', 'N', N, M, M, ONE,
$ WORK( STOREZ ), N, WORK, M, ZERO,
$ Z( 1, START ), LDZ )
ELSE IF( ICOMPZ.EQ.2 ) THEN
CALL SSTEQR( 'I', M, D( START ), E( START ),
$ Z( START, START ), LDZ, WORK, INFO )
ELSE
CALL SSTERF( M, D( START ), E( START ), INFO )
END IF
IF( INFO.NE.0 ) THEN
INFO = START*( N+1 ) + FINISH
GO TO 50
END IF
END IF
*
START = FINISH + 1
GO TO 10
END IF
*
* endwhile
*
* If the problem split any number of times, then the eigenvalues
* will not be properly ordered. Here we permute the eigenvalues
* (and the associated eigenvectors) into ascending order.
*
IF( M.NE.N ) THEN
IF( ICOMPZ.EQ.0 ) THEN
*
* Use Quick Sort
*
CALL SLASRT( 'I', N, D, INFO )
*
ELSE
*
* Use Selection Sort to minimize swaps of eigenvectors
*
DO 40 II = 2, N
I = II - 1
K = I
P = D( I )
DO 30 J = II, N
IF( D( J ).LT.P ) THEN
K = J
P = D( J )
END IF
30 CONTINUE
IF( K.NE.I ) THEN
D( K ) = D( I )
D( I ) = P
CALL SSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
END IF
40 CONTINUE
END IF
END IF
END IF
*
50 CONTINUE
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
RETURN
*
* End of SSTEDC
*
END
SUBROUTINE SSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
$ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK,
$ LIWORK, INFO )
IMPLICIT NONE
*
*
* -- LAPACK computational routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE
INTEGER IL, INFO, IU, LDZ, LIWORK, LWORK, M, N
REAL ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER ISUPPZ( * ), IWORK( * )
REAL D( * ), E( * ), W( * ), WORK( * )
REAL Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SSTEGR computes selected eigenvalues and, optionally, eigenvectors
* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
* a well defined set of pairwise different real eigenvalues, the corresponding
* real eigenvectors are pairwise orthogonal.
*
* The spectrum may be computed either completely or partially by specifying
* either an interval (VL,VU] or a range of indices IL:IU for the desired
* eigenvalues.
*
* SSTEGR is a compatability wrapper around the improved SSTEMR routine.
* See SSTEMR for further details.
*
* One important change is that the ABSTOL parameter no longer provides any
* benefit and hence is no longer used.
*
* Note : SSTEGR and SSTEMR work only on machines which follow
* IEEE-754 floating-point standard in their handling of infinities and
* NaNs. Normal execution may create these exceptiona values and hence
* may abort due to a floating point exception in environments which
* do not conform to the IEEE-754 standard.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* RANGE (input) CHARACTER*1
* = 'A': all eigenvalues will be found.
* = 'V': all eigenvalues in the half-open interval (VL,VU]
* will be found.
* = 'I': the IL-th through IU-th eigenvalues will be found.
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) REAL array, dimension (N)
* On entry, the N diagonal elements of the tridiagonal matrix
* T. On exit, D is overwritten.
*
* E (input/output) REAL array, dimension (N)
* On entry, the (N-1) subdiagonal elements of the tridiagonal
* matrix T in elements 1 to N-1 of E. E(N) need not be set on
* input, but is used internally as workspace.
* On exit, E is overwritten.
*
* VL (input) REAL
* VU (input) REAL
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* ABSTOL (input) REAL
* Unused. Was the absolute error tolerance for the
* eigenvalues/eigenvectors in previous versions.
*
* M (output) INTEGER
* The total number of eigenvalues found. 0 <= M <= N.
* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*
* W (output) REAL array, dimension (N)
* The first M elements contain the selected eigenvalues in
* ascending order.
*
* Z (output) REAL array, dimension (LDZ, max(1,M) )
* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
* contain the orthonormal eigenvectors of the matrix T
* corresponding to the selected eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* If JOBZ = 'N', then Z is not referenced.
* Note: the user must ensure that at least max(1,M) columns are
* supplied in the array Z; if RANGE = 'V', the exact value of M
* is not known in advance and an upper bound must be used.
* Supplying N columns is always safe.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', then LDZ >= max(1,N).
*
* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
* The support of the eigenvectors in Z, i.e., the indices
* indicating the nonzero elements in Z. The i-th computed eigenvector
* is nonzero only in elements ISUPPZ( 2*i-1 ) through
* ISUPPZ( 2*i ). This is relevant in the case when the matrix
* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
*
* WORK (workspace/output) REAL array, dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns the optimal
* (and minimal) LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK. LWORK >= max(1,18*N)
* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
* 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.
*
* IWORK (workspace/output) INTEGER array, dimension (LIWORK)
* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK. LIWORK >= max(1,10*N)
* if the eigenvectors are desired, and LIWORK >= max(1,8*N)
* if only the eigenvalues are to be computed.
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal size of the IWORK array,
* returns this value as the first entry of the IWORK array, and
* no error message related to LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* On exit, INFO
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = 1X, internal error in SLARRE,
* if INFO = 2X, internal error in SLARRV.
* Here, the digit X = ABS( IINFO ) < 10, where IINFO is
* the nonzero error code returned by SLARRE or
* SLARRV, respectively.
*
* Further Details
* ===============
*
* Based on contributions by
* Inderjit Dhillon, IBM Almaden, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, LBNL/NERSC, USA
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL TRYRAC
* ..
* .. External Subroutines ..
EXTERNAL SSTEMR
* ..
* .. Executable Statements ..
INFO = 0
TRYRAC = .FALSE.
CALL SSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
$ M, W, Z, LDZ, N, ISUPPZ, TRYRAC, WORK, LWORK,
$ IWORK, LIWORK, INFO )
*
* End of SSTEGR
*
END
SUBROUTINE SSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK,
$ IWORK, IFAIL, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDZ, M, N
* ..
* .. Array Arguments ..
INTEGER IBLOCK( * ), IFAIL( * ), ISPLIT( * ),
$ IWORK( * )
REAL D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SSTEIN computes the eigenvectors of a real symmetric tridiagonal
* matrix T corresponding to specified eigenvalues, using inverse
* iteration.
*
* The maximum number of iterations allowed for each eigenvector is
* specified by an internal parameter MAXITS (currently set to 5).
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input) REAL array, dimension (N)
* The n diagonal elements of the tridiagonal matrix T.
*
* E (input) REAL array, dimension (N-1)
* The (n-1) subdiagonal elements of the tridiagonal matrix
* T, in elements 1 to N-1.
*
* M (input) INTEGER
* The number of eigenvectors to be found. 0 <= M <= N.
*
* W (input) REAL array, dimension (N)
* The first M elements of W contain the eigenvalues for
* which eigenvectors are to be computed. The eigenvalues
* should be grouped by split-off block and ordered from
* smallest to largest within the block. ( The output array
* W from SSTEBZ with ORDER = 'B' is expected here. )
*
* IBLOCK (input) INTEGER array, dimension (N)
* The submatrix indices associated with the corresponding
* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to
* the first submatrix from the top, =2 if W(i) belongs to
* the second submatrix, etc. ( The output array IBLOCK
* from SSTEBZ is expected here. )
*
* ISPLIT (input) INTEGER array, dimension (N)
* The splitting points, at which T breaks up into submatrices.
* The first submatrix consists of rows/columns 1 to
* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
* through ISPLIT( 2 ), etc.
* ( The output array ISPLIT from SSTEBZ is expected here. )
*
* Z (output) REAL array, dimension (LDZ, M)
* The computed eigenvectors. The eigenvector associated
* with the eigenvalue W(i) is stored in the i-th column of
* Z. Any vector which fails to converge is set to its current
* iterate after MAXITS iterations.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= max(1,N).
*
* WORK (workspace) REAL array, dimension (5*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* IFAIL (output) INTEGER array, dimension (M)
* On normal exit, all elements of IFAIL are zero.
* If one or more eigenvectors fail to converge after
* MAXITS iterations, then their indices are stored in
* array IFAIL.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, then i eigenvectors failed to converge
* in MAXITS iterations. Their indices are stored in
* array IFAIL.
*
* Internal Parameters
* ===================
*
* MAXITS INTEGER, default = 5
* The maximum number of iterations performed.
*
* EXTRA INTEGER, default = 2
* The number of iterations performed after norm growth
* criterion is satisfied, should be at least 1.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TEN, ODM3, ODM1
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TEN = 1.0E+1,
$ ODM3 = 1.0E-3, ODM1 = 1.0E-1 )
INTEGER MAXITS, EXTRA
PARAMETER ( MAXITS = 5, EXTRA = 2 )
* ..
* .. Local Scalars ..
INTEGER B1, BLKSIZ, BN, GPIND, I, IINFO, INDRV1,
$ INDRV2, INDRV3, INDRV4, INDRV5, ITS, J, J1,
$ JBLK, JMAX, NBLK, NRMCHK
REAL CTR, EPS, EPS1, NRM, ONENRM, ORTOL, PERTOL,
$ SCL, SEP, STPCRT, TOL, XJ, XJM
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 )
* ..
* .. External Functions ..
INTEGER ISAMAX
REAL SASUM, SDOT, SLAMCH, SNRM2
EXTERNAL ISAMAX, SASUM, SDOT, SLAMCH, SNRM2
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, SLAGTF, SLAGTS, SLARNV, SSCAL,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
DO 10 I = 1, M
IFAIL( I ) = 0
10 CONTINUE
*
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( M.LT.0 .OR. M.GT.N ) THEN
INFO = -4
ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE
DO 20 J = 2, M
IF( IBLOCK( J ).LT.IBLOCK( J-1 ) ) THEN
INFO = -6
GO TO 30
END IF
IF( IBLOCK( J ).EQ.IBLOCK( J-1 ) .AND. W( J ).LT.W( J-1 ) )
$ THEN
INFO = -5
GO TO 30
END IF
20 CONTINUE
30 CONTINUE
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSTEIN', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. M.EQ.0 ) THEN
RETURN
ELSE IF( N.EQ.1 ) THEN
Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
EPS = SLAMCH( 'Precision' )
*
* Initialize seed for random number generator SLARNV.
*
DO 40 I = 1, 4
ISEED( I ) = 1
40 CONTINUE
*
* Initialize pointers.
*
INDRV1 = 0
INDRV2 = INDRV1 + N
INDRV3 = INDRV2 + N
INDRV4 = INDRV3 + N
INDRV5 = INDRV4 + N
*
* Compute eigenvectors of matrix blocks.
*
J1 = 1
DO 160 NBLK = 1, IBLOCK( M )
*
* Find starting and ending indices of block nblk.
*
IF( NBLK.EQ.1 ) THEN
B1 = 1
ELSE
B1 = ISPLIT( NBLK-1 ) + 1
END IF
BN = ISPLIT( NBLK )
BLKSIZ = BN - B1 + 1
IF( BLKSIZ.EQ.1 )
$ GO TO 60
GPIND = B1
*
* Compute reorthogonalization criterion and stopping criterion.
*
ONENRM = ABS( D( B1 ) ) + ABS( E( B1 ) )
ONENRM = MAX( ONENRM, ABS( D( BN ) )+ABS( E( BN-1 ) ) )
DO 50 I = B1 + 1, BN - 1
ONENRM = MAX( ONENRM, ABS( D( I ) )+ABS( E( I-1 ) )+
$ ABS( E( I ) ) )
50 CONTINUE
ORTOL = ODM3*ONENRM
*
STPCRT = SQRT( ODM1 / BLKSIZ )
*
* Loop through eigenvalues of block nblk.
*
60 CONTINUE
JBLK = 0
DO 150 J = J1, M
IF( IBLOCK( J ).NE.NBLK ) THEN
J1 = J
GO TO 160
END IF
JBLK = JBLK + 1
XJ = W( J )
*
* Skip all the work if the block size is one.
*
IF( BLKSIZ.EQ.1 ) THEN
WORK( INDRV1+1 ) = ONE
GO TO 120
END IF
*
* If eigenvalues j and j-1 are too close, add a relatively
* small perturbation.
*
IF( JBLK.GT.1 ) THEN
EPS1 = ABS( EPS*XJ )
PERTOL = TEN*EPS1
SEP = XJ - XJM
IF( SEP.LT.PERTOL )
$ XJ = XJM + PERTOL
END IF
*
ITS = 0
NRMCHK = 0
*
* Get random starting vector.
*
CALL SLARNV( 2, ISEED, BLKSIZ, WORK( INDRV1+1 ) )
*
* Copy the matrix T so it won't be destroyed in factorization.
*
CALL SCOPY( BLKSIZ, D( B1 ), 1, WORK( INDRV4+1 ), 1 )
CALL SCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV2+2 ), 1 )
CALL SCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV3+1 ), 1 )
*
* Compute LU factors with partial pivoting ( PT = LU )
*
TOL = ZERO
CALL SLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, WORK( INDRV2+2 ),
$ WORK( INDRV3+1 ), TOL, WORK( INDRV5+1 ), IWORK,
$ IINFO )
*
* Update iteration count.
*
70 CONTINUE
ITS = ITS + 1
IF( ITS.GT.MAXITS )
$ GO TO 100
*
* Normalize and scale the righthand side vector Pb.
*
SCL = BLKSIZ*ONENRM*MAX( EPS,
$ ABS( WORK( INDRV4+BLKSIZ ) ) ) /
$ SASUM( BLKSIZ, WORK( INDRV1+1 ), 1 )
CALL SSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 )
*
* Solve the system LU = Pb.
*
CALL SLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), WORK( INDRV2+2 ),
$ WORK( INDRV3+1 ), WORK( INDRV5+1 ), IWORK,
$ WORK( INDRV1+1 ), TOL, IINFO )
*
* Reorthogonalize by modified Gram-Schmidt if eigenvalues are
* close enough.
*
IF( JBLK.EQ.1 )
$ GO TO 90
IF( ABS( XJ-XJM ).GT.ORTOL )
$ GPIND = J
IF( GPIND.NE.J ) THEN
DO 80 I = GPIND, J - 1
CTR = -SDOT( BLKSIZ, WORK( INDRV1+1 ), 1, Z( B1, I ),
$ 1 )
CALL SAXPY( BLKSIZ, CTR, Z( B1, I ), 1,
$ WORK( INDRV1+1 ), 1 )
80 CONTINUE
END IF
*
* Check the infinity norm of the iterate.
*
90 CONTINUE
JMAX = ISAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 )
NRM = ABS( WORK( INDRV1+JMAX ) )
*
* Continue for additional iterations after norm reaches
* stopping criterion.
*
IF( NRM.LT.STPCRT )
$ GO TO 70
NRMCHK = NRMCHK + 1
IF( NRMCHK.LT.EXTRA+1 )
$ GO TO 70
*
GO TO 110
*
* If stopping criterion was not satisfied, update info and
* store eigenvector number in array ifail.
*
100 CONTINUE
INFO = INFO + 1
IFAIL( INFO ) = J
*
* Accept iterate as jth eigenvector.
*
110 CONTINUE
SCL = ONE / SNRM2( BLKSIZ, WORK( INDRV1+1 ), 1 )
JMAX = ISAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 )
IF( WORK( INDRV1+JMAX ).LT.ZERO )
$ SCL = -SCL
CALL SSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 )
120 CONTINUE
DO 130 I = 1, N
Z( I, J ) = ZERO
130 CONTINUE
DO 140 I = 1, BLKSIZ
Z( B1+I-1, J ) = WORK( INDRV1+I )
140 CONTINUE
*
* Save the shift to check eigenvalue spacing at next
* iteration.
*
XJM = XJ
*
150 CONTINUE
160 CONTINUE
*
RETURN
*
* End of SSTEIN
*
END
SUBROUTINE SSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
$ M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK,
$ IWORK, LIWORK, INFO )
IMPLICIT NONE
*
* -- LAPACK computational routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE
LOGICAL TRYRAC
INTEGER IL, INFO, IU, LDZ, NZC, LIWORK, LWORK, M, N
REAL VL, VU
* ..
* .. Array Arguments ..
INTEGER ISUPPZ( * ), IWORK( * )
REAL D( * ), E( * ), W( * ), WORK( * )
REAL Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SSTEMR computes selected eigenvalues and, optionally, eigenvectors
* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
* a well defined set of pairwise different real eigenvalues, the corresponding
* real eigenvectors are pairwise orthogonal.
*
* The spectrum may be computed either completely or partially by specifying
* either an interval (VL,VU] or a range of indices IL:IU for the desired
* eigenvalues.
*
* Depending on the number of desired eigenvalues, these are computed either
* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are
* computed by the use of various suitable L D L^T factorizations near clusters
* of close eigenvalues (referred to as RRRs, Relatively Robust
* Representations). An informal sketch of the algorithm follows.
*
* For each unreduced block (submatrix) of T,
* (a) Compute T - sigma I = L D L^T, so that L and D
* define all the wanted eigenvalues to high relative accuracy.
* This means that small relative changes in the entries of D and L
* cause only small relative changes in the eigenvalues and
* eigenvectors. The standard (unfactored) representation of the
* tridiagonal matrix T does not have this property in general.
* (b) Compute the eigenvalues to suitable accuracy.
* If the eigenvectors are desired, the algorithm attains full
* accuracy of the computed eigenvalues only right before
* the corresponding vectors have to be computed, see steps c) and d).
* (c) For each cluster of close eigenvalues, select a new
* shift close to the cluster, find a new factorization, and refine
* the shifted eigenvalues to suitable accuracy.
* (d) For each eigenvalue with a large enough relative separation compute
* the corresponding eigenvector by forming a rank revealing twisted
* factorization. Go back to (c) for any clusters that remain.
*
* For more details, see:
* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
* 2004. Also LAPACK Working Note 154.
* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
* tridiagonal eigenvalue/eigenvector problem",
* Computer Science Division Technical Report No. UCB/CSD-97-971,
* UC Berkeley, May 1997.
*
* Notes:
* 1.SSTEMR works only on machines which follow IEEE-754
* floating-point standard in their handling of infinities and NaNs.
* This permits the use of efficient inner loops avoiding a check for
* zero divisors.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* RANGE (input) CHARACTER*1
* = 'A': all eigenvalues will be found.
* = 'V': all eigenvalues in the half-open interval (VL,VU]
* will be found.
* = 'I': the IL-th through IU-th eigenvalues will be found.
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) REAL array, dimension (N)
* On entry, the N diagonal elements of the tridiagonal matrix
* T. On exit, D is overwritten.
*
* E (input/output) REAL array, dimension (N)
* On entry, the (N-1) subdiagonal elements of the tridiagonal
* matrix T in elements 1 to N-1 of E. E(N) need not be set on
* input, but is used internally as workspace.
* On exit, E is overwritten.
*
* VL (input) REAL
* VU (input) REAL
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* M (output) INTEGER
* The total number of eigenvalues found. 0 <= M <= N.
* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*
* W (output) REAL array, dimension (N)
* The first M elements contain the selected eigenvalues in
* ascending order.
*
* Z (output) REAL array, dimension (LDZ, max(1,M) )
* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
* contain the orthonormal eigenvectors of the matrix T
* corresponding to the selected eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* If JOBZ = 'N', then Z is not referenced.
* Note: the user must ensure that at least max(1,M) columns are
* supplied in the array Z; if RANGE = 'V', the exact value of M
* is not known in advance and can be computed with a workspace
* query by setting NZC = -1, see below.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', then LDZ >= max(1,N).
*
* NZC (input) INTEGER
* The number of eigenvectors to be held in the array Z.
* If RANGE = 'A', then NZC >= max(1,N).
* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].
* If RANGE = 'I', then NZC >= IU-IL+1.
* If NZC = -1, then a workspace query is assumed; the
* routine calculates the number of columns of the array Z that
* are needed to hold the eigenvectors.
* This value is returned as the first entry of the Z array, and
* no error message related to NZC is issued by XERBLA.
*
* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
* The support of the eigenvectors in Z, i.e., the indices
* indicating the nonzero elements in Z. The i-th computed eigenvector
* is nonzero only in elements ISUPPZ( 2*i-1 ) through
* ISUPPZ( 2*i ). This is relevant in the case when the matrix
* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
*
* TRYRAC (input/output) LOGICAL
* If TRYRAC.EQ..TRUE., indicates that the code should check whether
* the tridiagonal matrix defines its eigenvalues to high relative
* accuracy. If so, the code uses relative-accuracy preserving
* algorithms that might be (a bit) slower depending on the matrix.
* If the matrix does not define its eigenvalues to high relative
* accuracy, the code can uses possibly faster algorithms.
* If TRYRAC.EQ..FALSE., the code is not required to guarantee
* relatively accurate eigenvalues and can use the fastest possible
* techniques.
* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix
* does not define its eigenvalues to high relative accuracy.
*
* WORK (workspace/output) REAL array, dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns the optimal
* (and minimal) LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK. LWORK >= max(1,18*N)
* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
* 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.
*
* IWORK (workspace/output) INTEGER array, dimension (LIWORK)
* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK. LIWORK >= max(1,10*N)
* if the eigenvectors are desired, and LIWORK >= max(1,8*N)
* if only the eigenvalues are to be computed.
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal size of the IWORK array,
* returns this value as the first entry of the IWORK array, and
* no error message related to LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* On exit, INFO
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = 1X, internal error in SLARRE,
* if INFO = 2X, internal error in SLARRV.
* Here, the digit X = ABS( IINFO ) < 10, where IINFO is
* the nonzero error code returned by SLARRE or
* SLARRV, respectively.
*
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, FOUR, MINRGP
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0,
$ FOUR = 4.0E0,
$ MINRGP = 3.0E-3 )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, LQUERY, VALEIG, WANTZ, ZQUERY
INTEGER I, IBEGIN, IEND, IFIRST, IIL, IINDBL, IINDW,
$ IINDWK, IINFO, IINSPL, IIU, ILAST, IN, INDD,
$ INDE2, INDERR, INDGP, INDGRS, INDWRK, ITMP,
$ ITMP2, J, JBLK, JJ, LIWMIN, LWMIN, NSPLIT,
$ NZCMIN, OFFSET, WBEGIN, WEND
REAL BIGNUM, CS, EPS, PIVMIN, R1, R2, RMAX, RMIN,
$ RTOL1, RTOL2, SAFMIN, SCALE, SMLNUM, SN,
$ THRESH, TMP, TNRM, WL, WU
* ..
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANST
EXTERNAL LSAME, SLAMCH, SLANST
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLAE2, SLAEV2, SLARRC, SLARRE, SLARRJ,
$ SLARRR, SLARRV, SLASRT, SSCAL, SSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
*
LQUERY = ( ( LWORK.EQ.-1 ).OR.( LIWORK.EQ.-1 ) )
ZQUERY = ( NZC.EQ.-1 )
TRYRAC = ( INFO.NE.0 )
* SSTEMR needs WORK of size 6*N, IWORK of size 3*N.
* In addition, SLARRE needs WORK of size 6*N, IWORK of size 5*N.
* Furthermore, SLARRV needs WORK of size 12*N, IWORK of size 7*N.
IF( WANTZ ) THEN
LWMIN = 18*N
LIWMIN = 10*N
ELSE
* need less workspace if only the eigenvalues are wanted
LWMIN = 12*N
LIWMIN = 8*N
ENDIF
WL = ZERO
WU = ZERO
IIL = 0
IIU = 0
IF( VALEIG ) THEN
* We do not reference VL, VU in the cases RANGE = 'I','A'
* The interval (WL, WU] contains all the wanted eigenvalues.
* It is either given by the user or computed in SLARRE.
WL = VL
WU = VU
ELSEIF( INDEIG ) THEN
* We do not reference IL, IU in the cases RANGE = 'V','A'
IIL = IL
IIU = IU
ENDIF
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( VALEIG .AND. N.GT.0 .AND. WU.LE.WL ) THEN
INFO = -7
ELSE IF( INDEIG .AND. ( IIL.LT.1 .OR. IIL.GT.N ) ) THEN
INFO = -8
ELSE IF( INDEIG .AND. ( IIU.LT.IIL .OR. IIU.GT.N ) ) THEN
INFO = -9
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -13
ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -17
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -19
END IF
*
* Get machine constants.
*
SAFMIN = SLAMCH( 'Safe minimum' )
EPS = SLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
*
IF( INFO.EQ.0 ) THEN
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
IF( WANTZ .AND. ALLEIG ) THEN
NZCMIN = N
ELSE IF( WANTZ .AND. VALEIG ) THEN
CALL SLARRC( 'T', N, VL, VU, D, E, SAFMIN,
$ NZCMIN, ITMP, ITMP2, INFO )
ELSE IF( WANTZ .AND. INDEIG ) THEN
NZCMIN = IIU-IIL+1
ELSE
* WANTZ .EQ. FALSE.
NZCMIN = 0
ENDIF
IF( ZQUERY .AND. INFO.EQ.0 ) THEN
Z( 1,1 ) = NZCMIN
ELSE IF( NZC.LT.NZCMIN .AND. .NOT.ZQUERY ) THEN
INFO = -14
END IF
END IF
IF( INFO.NE.0 ) THEN
*
CALL XERBLA( 'SSTEMR', -INFO )
*
RETURN
ELSE IF( LQUERY .OR. ZQUERY ) THEN
RETURN
END IF
*
* Handle N = 0, 1, and 2 cases immediately
*
M = 0
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( ALLEIG .OR. INDEIG ) THEN
M = 1
W( 1 ) = D( 1 )
ELSE
IF( WL.LT.D( 1 ) .AND. WU.GE.D( 1 ) ) THEN
M = 1
W( 1 ) = D( 1 )
END IF
END IF
IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
Z( 1, 1 ) = ONE
ISUPPZ(1) = 1
ISUPPZ(2) = 1
END IF
RETURN
END IF
*
IF( N.EQ.2 ) THEN
IF( .NOT.WANTZ ) THEN
CALL SLAE2( D(1), E(1), D(2), R1, R2 )
ELSE IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
CALL SLAEV2( D(1), E(1), D(2), R1, R2, CS, SN )
END IF
IF( ALLEIG.OR.
$ (VALEIG.AND.(R2.GT.WL).AND.
$ (R2.LE.WU)).OR.
$ (INDEIG.AND.(IIL.EQ.1)) ) THEN
M = M+1
W( M ) = R2
IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
Z( 1, M ) = -SN
Z( 2, M ) = CS
* Note: At most one of SN and CS can be zero.
IF (SN.NE.ZERO) THEN
IF (CS.NE.ZERO) THEN
ISUPPZ(2*M-1) = 1
ISUPPZ(2*M-1) = 2
ELSE
ISUPPZ(2*M-1) = 1
ISUPPZ(2*M-1) = 1
END IF
ELSE
ISUPPZ(2*M-1) = 2
ISUPPZ(2*M) = 2
END IF
ENDIF
ENDIF
IF( ALLEIG.OR.
$ (VALEIG.AND.(R1.GT.WL).AND.
$ (R1.LE.WU)).OR.
$ (INDEIG.AND.(IIU.EQ.2)) ) THEN
M = M+1
W( M ) = R1
IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
Z( 1, M ) = CS
Z( 2, M ) = SN
* Note: At most one of SN and CS can be zero.
IF (SN.NE.ZERO) THEN
IF (CS.NE.ZERO) THEN
ISUPPZ(2*M-1) = 1
ISUPPZ(2*M-1) = 2
ELSE
ISUPPZ(2*M-1) = 1
ISUPPZ(2*M-1) = 1
END IF
ELSE
ISUPPZ(2*M-1) = 2
ISUPPZ(2*M) = 2
END IF
ENDIF
ENDIF
RETURN
END IF
* Continue with general N
INDGRS = 1
INDERR = 2*N + 1
INDGP = 3*N + 1
INDD = 4*N + 1
INDE2 = 5*N + 1
INDWRK = 6*N + 1
*
IINSPL = 1
IINDBL = N + 1
IINDW = 2*N + 1
IINDWK = 3*N + 1
*
* Scale matrix to allowable range, if necessary.
* The allowable range is related to the PIVMIN parameter; see the
* comments in SLARRD. The preference for scaling small values
* up is heuristic; we expect users' matrices not to be close to the
* RMAX threshold.
*
SCALE = ONE
TNRM = SLANST( 'M', N, D, E )
IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
SCALE = RMIN / TNRM
ELSE IF( TNRM.GT.RMAX ) THEN
SCALE = RMAX / TNRM
END IF
IF( SCALE.NE.ONE ) THEN
CALL SSCAL( N, SCALE, D, 1 )
CALL SSCAL( N-1, SCALE, E, 1 )
TNRM = TNRM*SCALE
IF( VALEIG ) THEN
* If eigenvalues in interval have to be found,
* scale (WL, WU] accordingly
WL = WL*SCALE
WU = WU*SCALE
ENDIF
END IF
*
* Compute the desired eigenvalues of the tridiagonal after splitting
* into smaller subblocks if the corresponding off-diagonal elements
* are small
* THRESH is the splitting parameter for SLARRE
* A negative THRESH forces the old splitting criterion based on the
* size of the off-diagonal. A positive THRESH switches to splitting
* which preserves relative accuracy.
*
IF( TRYRAC ) THEN
* Test whether the matrix warrants the more expensive relative approach.
CALL SLARRR( N, D, E, IINFO )
ELSE
* The user does not care about relative accurately eigenvalues
IINFO = -1
ENDIF
* Set the splitting criterion
IF (IINFO.EQ.0) THEN
THRESH = EPS
ELSE
THRESH = -EPS
* relative accuracy is desired but T does not guarantee it
TRYRAC = .FALSE.
ENDIF
*
IF( TRYRAC ) THEN
* Copy original diagonal, needed to guarantee relative accuracy
CALL SCOPY(N,D,1,WORK(INDD),1)
ENDIF
* Store the squares of the offdiagonal values of T
DO 5 J = 1, N-1
WORK( INDE2+J-1 ) = E(J)**2
5 CONTINUE
* Set the tolerance parameters for bisection
IF( .NOT.WANTZ ) THEN
* SLARRE computes the eigenvalues to full precision.
RTOL1 = FOUR * EPS
RTOL2 = FOUR * EPS
ELSE
* SLARRE computes the eigenvalues to less than full precision.
* SLARRV will refine the eigenvalue approximations, and we can
* need less accurate initial bisection in SLARRE.
* Note: these settings do only affect the subset case and SLARRE
RTOL1 = MAX( SQRT(EPS)*5.0E-2, FOUR * EPS )
RTOL2 = MAX( SQRT(EPS)*5.0E-3, FOUR * EPS )
ENDIF
CALL SLARRE( RANGE, N, WL, WU, IIL, IIU, D, E,
$ WORK(INDE2), RTOL1, RTOL2, THRESH, NSPLIT,
$ IWORK( IINSPL ), M, W, WORK( INDERR ),
$ WORK( INDGP ), IWORK( IINDBL ),
$ IWORK( IINDW ), WORK( INDGRS ), PIVMIN,
$ WORK( INDWRK ), IWORK( IINDWK ), IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 10 + ABS( IINFO )
RETURN
END IF
* Note that if RANGE .NE. 'V', SLARRE computes bounds on the desired
* part of the spectrum. All desired eigenvalues are contained in
* (WL,WU]
IF( WANTZ ) THEN
*
* Compute the desired eigenvectors corresponding to the computed
* eigenvalues
*
CALL SLARRV( N, WL, WU, D, E,
$ PIVMIN, IWORK( IINSPL ), M,
$ 1, M, MINRGP, RTOL1, RTOL2,
$ W, WORK( INDERR ), WORK( INDGP ), IWORK( IINDBL ),
$ IWORK( IINDW ), WORK( INDGRS ), Z, LDZ,
$ ISUPPZ, WORK( INDWRK ), IWORK( IINDWK ), IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 20 + ABS( IINFO )
RETURN
END IF
ELSE
* SLARRE computes eigenvalues of the (shifted) root representation
* SLARRV returns the eigenvalues of the unshifted matrix.
* However, if the eigenvectors are not desired by the user, we need
* to apply the corresponding shifts from SLARRE to obtain the
* eigenvalues of the original matrix.
DO 20 J = 1, M
ITMP = IWORK( IINDBL+J-1 )
W( J ) = W( J ) + E( IWORK( IINSPL+ITMP-1 ) )
20 CONTINUE
END IF
*
IF ( TRYRAC ) THEN
* Refine computed eigenvalues so that they are relatively accurate
* with respect to the original matrix T.
IBEGIN = 1
WBEGIN = 1
DO 39 JBLK = 1, IWORK( IINDBL+M-1 )
IEND = IWORK( IINSPL+JBLK-1 )
IN = IEND - IBEGIN + 1
WEND = WBEGIN - 1
* check if any eigenvalues have to be refined in this block
36 CONTINUE
IF( WEND.LT.M ) THEN
IF( IWORK( IINDBL+WEND ).EQ.JBLK ) THEN
WEND = WEND + 1
GO TO 36
END IF
END IF
IF( WEND.LT.WBEGIN ) THEN
IBEGIN = IEND + 1
GO TO 39
END IF
OFFSET = IWORK(IINDW+WBEGIN-1)-1
IFIRST = IWORK(IINDW+WBEGIN-1)
ILAST = IWORK(IINDW+WEND-1)
RTOL2 = FOUR * EPS
CALL SLARRJ( IN,
$ WORK(INDD+IBEGIN-1), WORK(INDE2+IBEGIN-1),
$ IFIRST, ILAST, RTOL2, OFFSET, W(WBEGIN),
$ WORK( INDERR+WBEGIN-1 ),
$ WORK( INDWRK ), IWORK( IINDWK ), PIVMIN,
$ TNRM, IINFO )
IBEGIN = IEND + 1
WBEGIN = WEND + 1
39 CONTINUE
ENDIF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( SCALE.NE.ONE ) THEN
CALL SSCAL( M, ONE / SCALE, W, 1 )
END IF
*
* If eigenvalues are not in increasing order, then sort them,
* possibly along with eigenvectors.
*
IF( NSPLIT.GT.1 ) THEN
IF( .NOT. WANTZ ) THEN
CALL SLASRT( 'I', M, W, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 3
RETURN
END IF
ELSE
DO 60 J = 1, M - 1
I = 0
TMP = W( J )
DO 50 JJ = J + 1, M
IF( W( JJ ).LT.TMP ) THEN
I = JJ
TMP = W( JJ )
END IF
50 CONTINUE
IF( I.NE.0 ) THEN
W( I ) = W( J )
W( J ) = TMP
IF( WANTZ ) THEN
CALL SSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
ITMP = ISUPPZ( 2*I-1 )
ISUPPZ( 2*I-1 ) = ISUPPZ( 2*J-1 )
ISUPPZ( 2*J-1 ) = ITMP
ITMP = ISUPPZ( 2*I )
ISUPPZ( 2*I ) = ISUPPZ( 2*J )
ISUPPZ( 2*J ) = ITMP
END IF
END IF
60 CONTINUE
END IF
ENDIF
*
*
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
RETURN
*
* End of SSTEMR
*
END
SUBROUTINE SSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER COMPZ
INTEGER INFO, LDZ, N
* ..
* .. Array Arguments ..
REAL D( * ), E( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SSTEQR computes all eigenvalues and, optionally, eigenvectors of a
* symmetric tridiagonal matrix using the implicit QL or QR method.
* The eigenvectors of a full or band symmetric matrix can also be found
* if SSYTRD or SSPTRD or SSBTRD has been used to reduce this matrix to
* tridiagonal form.
*
* Arguments
* =========
*
* COMPZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only.
* = 'V': Compute eigenvalues and eigenvectors of the original
* symmetric matrix. On entry, Z must contain the
* orthogonal matrix used to reduce the original matrix
* to tridiagonal form.
* = 'I': Compute eigenvalues and eigenvectors of the
* tridiagonal matrix. Z is initialized to the identity
* matrix.
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) REAL array, dimension (N)
* On entry, the diagonal elements of the tridiagonal matrix.
* On exit, if INFO = 0, the eigenvalues in ascending order.
*
* E (input/output) REAL array, dimension (N-1)
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix.
* On exit, E has been destroyed.
*
* Z (input/output) REAL array, dimension (LDZ, N)
* On entry, if COMPZ = 'V', then Z contains the orthogonal
* matrix used in the reduction to tridiagonal form.
* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
* orthonormal eigenvectors of the original symmetric matrix,
* and if COMPZ = 'I', Z contains the orthonormal eigenvectors
* of the symmetric tridiagonal matrix.
* If COMPZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* eigenvectors are desired, then LDZ >= max(1,N).
*
* WORK (workspace) REAL array, dimension (max(1,2*N-2))
* If COMPZ = 'N', then WORK is not referenced.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: the algorithm has failed to find all the eigenvalues in
* a total of 30*N iterations; if INFO = i, then i
* elements of E have not converged to zero; on exit, D
* and E contain the elements of a symmetric tridiagonal
* matrix which is orthogonally similar to the original
* matrix.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO, THREE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ THREE = 3.0E0 )
INTEGER MAXIT
PARAMETER ( MAXIT = 30 )
* ..
* .. Local Scalars ..
INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND,
$ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1,
$ NM1, NMAXIT
REAL ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2,
$ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANST, SLAPY2
EXTERNAL LSAME, SLAMCH, SLANST, SLAPY2
* ..
* .. External Subroutines ..
EXTERNAL SLAE2, SLAEV2, SLARTG, SLASCL, SLASET, SLASR,
$ SLASRT, SSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( LSAME( COMPZ, 'N' ) ) THEN
ICOMPZ = 0
ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
ICOMPZ = 1
ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
ICOMPZ = 2
ELSE
ICOMPZ = -1
END IF
IF( ICOMPZ.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
$ N ) ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSTEQR', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( ICOMPZ.EQ.2 )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Determine the unit roundoff and over/underflow thresholds.
*
EPS = SLAMCH( 'E' )
EPS2 = EPS**2
SAFMIN = SLAMCH( 'S' )
SAFMAX = ONE / SAFMIN
SSFMAX = SQRT( SAFMAX ) / THREE
SSFMIN = SQRT( SAFMIN ) / EPS2
*
* Compute the eigenvalues and eigenvectors of the tridiagonal
* matrix.
*
IF( ICOMPZ.EQ.2 )
$ CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
*
NMAXIT = N*MAXIT
JTOT = 0
*
* Determine where the matrix splits and choose QL or QR iteration
* for each block, according to whether top or bottom diagonal
* element is smaller.
*
L1 = 1
NM1 = N - 1
*
10 CONTINUE
IF( L1.GT.N )
$ GO TO 160
IF( L1.GT.1 )
$ E( L1-1 ) = ZERO
IF( L1.LE.NM1 ) THEN
DO 20 M = L1, NM1
TST = ABS( E( M ) )
IF( TST.EQ.ZERO )
$ GO TO 30
IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+
$ 1 ) ) ) )*EPS ) THEN
E( M ) = ZERO
GO TO 30
END IF
20 CONTINUE
END IF
M = N
*
30 CONTINUE
L = L1
LSV = L
LEND = M
LENDSV = LEND
L1 = M + 1
IF( LEND.EQ.L )
$ GO TO 10
*
* Scale submatrix in rows and columns L to LEND
*
ANORM = SLANST( 'I', LEND-L+1, D( L ), E( L ) )
ISCALE = 0
IF( ANORM.EQ.ZERO )
$ GO TO 10
IF( ANORM.GT.SSFMAX ) THEN
ISCALE = 1
CALL SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
$ INFO )
ELSE IF( ANORM.LT.SSFMIN ) THEN
ISCALE = 2
CALL SLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL SLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N,
$ INFO )
END IF
*
* Choose between QL and QR iteration
*
IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
LEND = LSV
L = LENDSV
END IF
*
IF( LEND.GT.L ) THEN
*
* QL Iteration
*
* Look for small subdiagonal element.
*
40 CONTINUE
IF( L.NE.LEND ) THEN
LENDM1 = LEND - 1
DO 50 M = L, LENDM1
TST = ABS( E( M ) )**2
IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+
$ SAFMIN )GO TO 60
50 CONTINUE
END IF
*
M = LEND
*
60 CONTINUE
IF( M.LT.LEND )
$ E( M ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 80
*
* If remaining matrix is 2-by-2, use SLAE2 or SLAEV2
* to compute its eigensystem.
*
IF( M.EQ.L+1 ) THEN
IF( ICOMPZ.GT.0 ) THEN
CALL SLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S )
WORK( L ) = C
WORK( N-1+L ) = S
CALL SLASR( 'R', 'V', 'B', N, 2, WORK( L ),
$ WORK( N-1+L ), Z( 1, L ), LDZ )
ELSE
CALL SLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 )
END IF
D( L ) = RT1
D( L+1 ) = RT2
E( L ) = ZERO
L = L + 2
IF( L.LE.LEND )
$ GO TO 40
GO TO 140
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 140
JTOT = JTOT + 1
*
* Form shift.
*
G = ( D( L+1 )-P ) / ( TWO*E( L ) )
R = SLAPY2( G, ONE )
G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) )
*
S = ONE
C = ONE
P = ZERO
*
* Inner loop
*
MM1 = M - 1
DO 70 I = MM1, L, -1
F = S*E( I )
B = C*E( I )
CALL SLARTG( G, F, C, S, R )
IF( I.NE.M-1 )
$ E( I+1 ) = R
G = D( I+1 ) - P
R = ( D( I )-G )*S + TWO*C*B
P = S*R
D( I+1 ) = G + P
G = C*R - B
*
* If eigenvectors are desired, then save rotations.
*
IF( ICOMPZ.GT.0 ) THEN
WORK( I ) = C
WORK( N-1+I ) = -S
END IF
*
70 CONTINUE
*
* If eigenvectors are desired, then apply saved rotations.
*
IF( ICOMPZ.GT.0 ) THEN
MM = M - L + 1
CALL SLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ),
$ Z( 1, L ), LDZ )
END IF
*
D( L ) = D( L ) - P
E( L ) = G
GO TO 40
*
* Eigenvalue found.
*
80 CONTINUE
D( L ) = P
*
L = L + 1
IF( L.LE.LEND )
$ GO TO 40
GO TO 140
*
ELSE
*
* QR Iteration
*
* Look for small superdiagonal element.
*
90 CONTINUE
IF( L.NE.LEND ) THEN
LENDP1 = LEND + 1
DO 100 M = L, LENDP1, -1
TST = ABS( E( M-1 ) )**2
IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+
$ SAFMIN )GO TO 110
100 CONTINUE
END IF
*
M = LEND
*
110 CONTINUE
IF( M.GT.LEND )
$ E( M-1 ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 130
*
* If remaining matrix is 2-by-2, use SLAE2 or SLAEV2
* to compute its eigensystem.
*
IF( M.EQ.L-1 ) THEN
IF( ICOMPZ.GT.0 ) THEN
CALL SLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S )
WORK( M ) = C
WORK( N-1+M ) = S
CALL SLASR( 'R', 'V', 'F', N, 2, WORK( M ),
$ WORK( N-1+M ), Z( 1, L-1 ), LDZ )
ELSE
CALL SLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 )
END IF
D( L-1 ) = RT1
D( L ) = RT2
E( L-1 ) = ZERO
L = L - 2
IF( L.GE.LEND )
$ GO TO 90
GO TO 140
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 140
JTOT = JTOT + 1
*
* Form shift.
*
G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) )
R = SLAPY2( G, ONE )
G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) )
*
S = ONE
C = ONE
P = ZERO
*
* Inner loop
*
LM1 = L - 1
DO 120 I = M, LM1
F = S*E( I )
B = C*E( I )
CALL SLARTG( G, F, C, S, R )
IF( I.NE.M )
$ E( I-1 ) = R
G = D( I ) - P
R = ( D( I+1 )-G )*S + TWO*C*B
P = S*R
D( I ) = G + P
G = C*R - B
*
* If eigenvectors are desired, then save rotations.
*
IF( ICOMPZ.GT.0 ) THEN
WORK( I ) = C
WORK( N-1+I ) = S
END IF
*
120 CONTINUE
*
* If eigenvectors are desired, then apply saved rotations.
*
IF( ICOMPZ.GT.0 ) THEN
MM = L - M + 1
CALL SLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ),
$ Z( 1, M ), LDZ )
END IF
*
D( L ) = D( L ) - P
E( LM1 ) = G
GO TO 90
*
* Eigenvalue found.
*
130 CONTINUE
D( L ) = P
*
L = L - 1
IF( L.GE.LEND )
$ GO TO 90
GO TO 140
*
END IF
*
* Undo scaling if necessary
*
140 CONTINUE
IF( ISCALE.EQ.1 ) THEN
CALL SLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
CALL SLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ),
$ N, INFO )
ELSE IF( ISCALE.EQ.2 ) THEN
CALL SLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
CALL SLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ),
$ N, INFO )
END IF
*
* Check for no convergence to an eigenvalue after a total
* of N*MAXIT iterations.
*
IF( JTOT.LT.NMAXIT )
$ GO TO 10
DO 150 I = 1, N - 1
IF( E( I ).NE.ZERO )
$ INFO = INFO + 1
150 CONTINUE
GO TO 190
*
* Order eigenvalues and eigenvectors.
*
160 CONTINUE
IF( ICOMPZ.EQ.0 ) THEN
*
* Use Quick Sort
*
CALL SLASRT( 'I', N, D, INFO )
*
ELSE
*
* Use Selection Sort to minimize swaps of eigenvectors
*
DO 180 II = 2, N
I = II - 1
K = I
P = D( I )
DO 170 J = II, N
IF( D( J ).LT.P ) THEN
K = J
P = D( J )
END IF
170 CONTINUE
IF( K.NE.I ) THEN
D( K ) = D( I )
D( I ) = P
CALL SSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
END IF
180 CONTINUE
END IF
*
190 CONTINUE
RETURN
*
* End of SSTEQR
*
END
SUBROUTINE SSTERF( N, D, E, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, N
* ..
* .. Array Arguments ..
REAL D( * ), E( * )
* ..
*
* Purpose
* =======
*
* SSTERF computes all eigenvalues of a symmetric tridiagonal matrix
* using the Pal-Walker-Kahan variant of the QL or QR algorithm.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) REAL array, dimension (N)
* On entry, the n diagonal elements of the tridiagonal matrix.
* On exit, if INFO = 0, the eigenvalues in ascending order.
*
* E (input/output) REAL array, dimension (N-1)
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix.
* On exit, E has been destroyed.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: the algorithm failed to find all of the eigenvalues in
* a total of 30*N iterations; if INFO = i, then i
* elements of E have not converged to zero.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO, THREE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ THREE = 3.0E0 )
INTEGER MAXIT
PARAMETER ( MAXIT = 30 )
* ..
* .. Local Scalars ..
INTEGER I, ISCALE, JTOT, L, L1, LEND, LENDSV, LSV, M,
$ NMAXIT
REAL ALPHA, ANORM, BB, C, EPS, EPS2, GAMMA, OLDC,
$ OLDGAM, P, R, RT1, RT2, RTE, S, SAFMAX, SAFMIN,
$ SIGMA, SSFMAX, SSFMIN
* ..
* .. External Functions ..
REAL SLAMCH, SLANST, SLAPY2
EXTERNAL SLAMCH, SLANST, SLAPY2
* ..
* .. External Subroutines ..
EXTERNAL SLAE2, SLASCL, SLASRT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
* Quick return if possible
*
IF( N.LT.0 ) THEN
INFO = -1
CALL XERBLA( 'SSTERF', -INFO )
RETURN
END IF
IF( N.LE.1 )
$ RETURN
*
* Determine the unit roundoff for this environment.
*
EPS = SLAMCH( 'E' )
EPS2 = EPS**2
SAFMIN = SLAMCH( 'S' )
SAFMAX = ONE / SAFMIN
SSFMAX = SQRT( SAFMAX ) / THREE
SSFMIN = SQRT( SAFMIN ) / EPS2
*
* Compute the eigenvalues of the tridiagonal matrix.
*
NMAXIT = N*MAXIT
SIGMA = ZERO
JTOT = 0
*
* Determine where the matrix splits and choose QL or QR iteration
* for each block, according to whether top or bottom diagonal
* element is smaller.
*
L1 = 1
*
10 CONTINUE
IF( L1.GT.N )
$ GO TO 170
IF( L1.GT.1 )
$ E( L1-1 ) = ZERO
DO 20 M = L1, N - 1
IF( ABS( E( M ) ).LE.( SQRT( ABS( D( M ) ) )*
$ SQRT( ABS( D( M+1 ) ) ) )*EPS ) THEN
E( M ) = ZERO
GO TO 30
END IF
20 CONTINUE
M = N
*
30 CONTINUE
L = L1
LSV = L
LEND = M
LENDSV = LEND
L1 = M + 1
IF( LEND.EQ.L )
$ GO TO 10
*
* Scale submatrix in rows and columns L to LEND
*
ANORM = SLANST( 'I', LEND-L+1, D( L ), E( L ) )
ISCALE = 0
IF( ANORM.GT.SSFMAX ) THEN
ISCALE = 1
CALL SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
$ INFO )
ELSE IF( ANORM.LT.SSFMIN ) THEN
ISCALE = 2
CALL SLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL SLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N,
$ INFO )
END IF
*
DO 40 I = L, LEND - 1
E( I ) = E( I )**2
40 CONTINUE
*
* Choose between QL and QR iteration
*
IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
LEND = LSV
L = LENDSV
END IF
*
IF( LEND.GE.L ) THEN
*
* QL Iteration
*
* Look for small subdiagonal element.
*
50 CONTINUE
IF( L.NE.LEND ) THEN
DO 60 M = L, LEND - 1
IF( ABS( E( M ) ).LE.EPS2*ABS( D( M )*D( M+1 ) ) )
$ GO TO 70
60 CONTINUE
END IF
M = LEND
*
70 CONTINUE
IF( M.LT.LEND )
$ E( M ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 90
*
* If remaining matrix is 2 by 2, use SLAE2 to compute its
* eigenvalues.
*
IF( M.EQ.L+1 ) THEN
RTE = SQRT( E( L ) )
CALL SLAE2( D( L ), RTE, D( L+1 ), RT1, RT2 )
D( L ) = RT1
D( L+1 ) = RT2
E( L ) = ZERO
L = L + 2
IF( L.LE.LEND )
$ GO TO 50
GO TO 150
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 150
JTOT = JTOT + 1
*
* Form shift.
*
RTE = SQRT( E( L ) )
SIGMA = ( D( L+1 )-P ) / ( TWO*RTE )
R = SLAPY2( SIGMA, ONE )
SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) )
*
C = ONE
S = ZERO
GAMMA = D( M ) - SIGMA
P = GAMMA*GAMMA
*
* Inner loop
*
DO 80 I = M - 1, L, -1
BB = E( I )
R = P + BB
IF( I.NE.M-1 )
$ E( I+1 ) = S*R
OLDC = C
C = P / R
S = BB / R
OLDGAM = GAMMA
ALPHA = D( I )
GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM
D( I+1 ) = OLDGAM + ( ALPHA-GAMMA )
IF( C.NE.ZERO ) THEN
P = ( GAMMA*GAMMA ) / C
ELSE
P = OLDC*BB
END IF
80 CONTINUE
*
E( L ) = S*P
D( L ) = SIGMA + GAMMA
GO TO 50
*
* Eigenvalue found.
*
90 CONTINUE
D( L ) = P
*
L = L + 1
IF( L.LE.LEND )
$ GO TO 50
GO TO 150
*
ELSE
*
* QR Iteration
*
* Look for small superdiagonal element.
*
100 CONTINUE
DO 110 M = L, LEND + 1, -1
IF( ABS( E( M-1 ) ).LE.EPS2*ABS( D( M )*D( M-1 ) ) )
$ GO TO 120
110 CONTINUE
M = LEND
*
120 CONTINUE
IF( M.GT.LEND )
$ E( M-1 ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 140
*
* If remaining matrix is 2 by 2, use SLAE2 to compute its
* eigenvalues.
*
IF( M.EQ.L-1 ) THEN
RTE = SQRT( E( L-1 ) )
CALL SLAE2( D( L ), RTE, D( L-1 ), RT1, RT2 )
D( L ) = RT1
D( L-1 ) = RT2
E( L-1 ) = ZERO
L = L - 2
IF( L.GE.LEND )
$ GO TO 100
GO TO 150
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 150
JTOT = JTOT + 1
*
* Form shift.
*
RTE = SQRT( E( L-1 ) )
SIGMA = ( D( L-1 )-P ) / ( TWO*RTE )
R = SLAPY2( SIGMA, ONE )
SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) )
*
C = ONE
S = ZERO
GAMMA = D( M ) - SIGMA
P = GAMMA*GAMMA
*
* Inner loop
*
DO 130 I = M, L - 1
BB = E( I )
R = P + BB
IF( I.NE.M )
$ E( I-1 ) = S*R
OLDC = C
C = P / R
S = BB / R
OLDGAM = GAMMA
ALPHA = D( I+1 )
GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM
D( I ) = OLDGAM + ( ALPHA-GAMMA )
IF( C.NE.ZERO ) THEN
P = ( GAMMA*GAMMA ) / C
ELSE
P = OLDC*BB
END IF
130 CONTINUE
*
E( L-1 ) = S*P
D( L ) = SIGMA + GAMMA
GO TO 100
*
* Eigenvalue found.
*
140 CONTINUE
D( L ) = P
*
L = L - 1
IF( L.GE.LEND )
$ GO TO 100
GO TO 150
*
END IF
*
* Undo scaling if necessary
*
150 CONTINUE
IF( ISCALE.EQ.1 )
$ CALL SLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
IF( ISCALE.EQ.2 )
$ CALL SLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
*
* Check for no convergence to an eigenvalue after a total
* of N*MAXIT iterations.
*
IF( JTOT.LT.NMAXIT )
$ GO TO 10
DO 160 I = 1, N - 1
IF( E( I ).NE.ZERO )
$ INFO = INFO + 1
160 CONTINUE
GO TO 180
*
* Sort eigenvalues in increasing order.
*
170 CONTINUE
CALL SLASRT( 'I', N, D, INFO )
*
180 CONTINUE
RETURN
*
* End of SSTERF
*
END
SUBROUTINE SSTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ
INTEGER INFO, LDZ, N
* ..
* .. Array Arguments ..
REAL D( * ), E( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SSTEV computes all eigenvalues and, optionally, eigenvectors of a
* real symmetric tridiagonal matrix A.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) REAL array, dimension (N)
* On entry, the n diagonal elements of the tridiagonal matrix
* A.
* On exit, if INFO = 0, the eigenvalues in ascending order.
*
* E (input/output) REAL array, dimension (N-1)
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix A, stored in elements 1 to N-1 of E.
* On exit, the contents of E are destroyed.
*
* Z (output) REAL array, dimension (LDZ, N)
* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
* eigenvectors of the matrix A, with the i-th column of Z
* holding the eigenvector associated with D(i).
* If JOBZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace) REAL array, dimension (max(1,2*N-2))
* If JOBZ = 'N', WORK is not referenced.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, the algorithm failed to converge; i
* off-diagonal elements of E did not converge to zero.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL WANTZ
INTEGER IMAX, ISCALE
REAL BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM,
$ TNRM
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANST
EXTERNAL LSAME, SLAMCH, SLANST
* ..
* .. External Subroutines ..
EXTERNAL SSCAL, SSTEQR, SSTERF, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -6
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSTEV ', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( WANTZ )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = SLAMCH( 'Safe minimum' )
EPS = SLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = SQRT( BIGNUM )
*
* Scale matrix to allowable range, if necessary.
*
ISCALE = 0
TNRM = SLANST( 'M', N, D, E )
IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / TNRM
ELSE IF( TNRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / TNRM
END IF
IF( ISCALE.EQ.1 ) THEN
CALL SSCAL( N, SIGMA, D, 1 )
CALL SSCAL( N-1, SIGMA, E( 1 ), 1 )
END IF
*
* For eigenvalues only, call SSTERF. For eigenvalues and
* eigenvectors, call SSTEQR.
*
IF( .NOT.WANTZ ) THEN
CALL SSTERF( N, D, E, INFO )
ELSE
CALL SSTEQR( 'I', N, D, E, Z, LDZ, WORK, INFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = N
ELSE
IMAX = INFO - 1
END IF
CALL SSCAL( IMAX, ONE / SIGMA, D, 1 )
END IF
*
RETURN
*
* End of SSTEV
*
END
SUBROUTINE SSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK,
$ LIWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ
INTEGER INFO, LDZ, LIWORK, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL D( * ), E( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SSTEVD computes all eigenvalues and, optionally, eigenvectors of a
* real symmetric tridiagonal matrix. If eigenvectors are desired, it
* uses a divide and conquer algorithm.
*
* The divide and conquer algorithm makes very mild assumptions about
* floating point arithmetic. It will work on machines with a guard
* digit in add/subtract, or on those binary machines without guard
* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
* Cray-2. It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) REAL array, dimension (N)
* On entry, the n diagonal elements of the tridiagonal matrix
* A.
* On exit, if INFO = 0, the eigenvalues in ascending order.
*
* E (input/output) REAL array, dimension (N-1)
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix A, stored in elements 1 to N-1 of E.
* On exit, the contents of E are destroyed.
*
* Z (output) REAL array, dimension (LDZ, N)
* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
* eigenvectors of the matrix A, with the i-th column of Z
* holding the eigenvector associated with D(i).
* If JOBZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace/output) REAL array,
* dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* If JOBZ = 'N' or N <= 1 then LWORK must be at least 1.
* If JOBZ = 'V' and N > 1 then LWORK must be at least
* ( 1 + 4*N + N**2 ).
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal sizes of the WORK and IWORK
* arrays, returns these values as the first entries of the WORK
* and IWORK arrays, and no error message related to LWORK or
* LIWORK is issued by XERBLA.
*
* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK.
* If JOBZ = 'N' or N <= 1 then LIWORK must be at least 1.
* If JOBZ = 'V' and N > 1 then LIWORK must be at least 3+5*N.
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal sizes of the WORK and
* IWORK arrays, returns these values as the first entries of
* the WORK and IWORK arrays, and no error message related to
* LWORK or LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, the algorithm failed to converge; i
* off-diagonal elements of E did not converge to zero.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, WANTZ
INTEGER ISCALE, LIWMIN, LWMIN
REAL BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM,
$ TNRM
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANST
EXTERNAL LSAME, SLAMCH, SLANST
* ..
* .. External Subroutines ..
EXTERNAL SSCAL, SSTEDC, SSTERF, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
INFO = 0
LIWMIN = 1
LWMIN = 1
IF( N.GT.1 .AND. WANTZ ) THEN
LWMIN = 1 + 4*N + N**2
LIWMIN = 3 + 5*N
END IF
*
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -6
END IF
*
IF( INFO.EQ.0 ) THEN
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -8
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -10
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSTEVD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( WANTZ )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = SLAMCH( 'Safe minimum' )
EPS = SLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = SQRT( BIGNUM )
*
* Scale matrix to allowable range, if necessary.
*
ISCALE = 0
TNRM = SLANST( 'M', N, D, E )
IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / TNRM
ELSE IF( TNRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / TNRM
END IF
IF( ISCALE.EQ.1 ) THEN
CALL SSCAL( N, SIGMA, D, 1 )
CALL SSCAL( N-1, SIGMA, E( 1 ), 1 )
END IF
*
* For eigenvalues only, call SSTERF. For eigenvalues and
* eigenvectors, call SSTEDC.
*
IF( .NOT.WANTZ ) THEN
CALL SSTERF( N, D, E, INFO )
ELSE
CALL SSTEDC( 'I', N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK,
$ INFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( ISCALE.EQ.1 )
$ CALL SSCAL( N, ONE / SIGMA, D, 1 )
*
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
RETURN
*
* End of SSTEVD
*
END
SUBROUTINE SSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL,
$ M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK,
$ LIWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE
INTEGER IL, INFO, IU, LDZ, LIWORK, LWORK, M, N
REAL ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER ISUPPZ( * ), IWORK( * )
REAL D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SSTEVR computes selected eigenvalues and, optionally, eigenvectors
* of a real symmetric tridiagonal matrix T. Eigenvalues and
* eigenvectors can be selected by specifying either a range of values
* or a range of indices for the desired eigenvalues.
*
* Whenever possible, SSTEVR calls SSTEMR to compute the
* eigenspectrum using Relatively Robust Representations. SSTEMR
* computes eigenvalues by the dqds algorithm, while orthogonal
* eigenvectors are computed from various "good" L D L^T representations
* (also known as Relatively Robust Representations). Gram-Schmidt
* orthogonalization is avoided as far as possible. More specifically,
* the various steps of the algorithm are as follows. For the i-th
* unreduced block of T,
* (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T
* is a relatively robust representation,
* (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high
* relative accuracy by the dqds algorithm,
* (c) If there is a cluster of close eigenvalues, "choose" sigma_i
* close to the cluster, and go to step (a),
* (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T,
* compute the corresponding eigenvector by forming a
* rank-revealing twisted factorization.
* The desired accuracy of the output can be specified by the input
* parameter ABSTOL.
*
* For more details, see "A new O(n^2) algorithm for the symmetric
* tridiagonal eigenvalue/eigenvector problem", by Inderjit Dhillon,
* Computer Science Division Technical Report No. UCB//CSD-97-971,
* UC Berkeley, May 1997.
*
*
* Note 1 : SSTEVR calls SSTEMR when the full spectrum is requested
* on machines which conform to the ieee-754 floating point standard.
* SSTEVR calls SSTEBZ and SSTEIN on non-ieee machines and
* when partial spectrum requests are made.
*
* Normal execution of SSTEMR may create NaNs and infinities and
* hence may abort due to a floating point exception in environments
* which do not handle NaNs and infinities in the ieee standard default
* manner.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* RANGE (input) CHARACTER*1
* = 'A': all eigenvalues will be found.
* = 'V': all eigenvalues in the half-open interval (VL,VU]
* will be found.
* = 'I': the IL-th through IU-th eigenvalues will be found.
********** For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and
********** SSTEIN are called
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) REAL array, dimension (N)
* On entry, the n diagonal elements of the tridiagonal matrix
* A.
* On exit, D may be multiplied by a constant factor chosen
* to avoid over/underflow in computing the eigenvalues.
*
* E (input/output) REAL array, dimension (max(1,N-1))
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix A in elements 1 to N-1 of E.
* On exit, E may be multiplied by a constant factor chosen
* to avoid over/underflow in computing the eigenvalues.
*
* VL (input) REAL
* VU (input) REAL
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* ABSTOL (input) REAL
* The absolute error tolerance for the eigenvalues.
* An approximate eigenvalue is accepted as converged
* when it is determined to lie in an interval [a,b]
* of width less than or equal to
*
* ABSTOL + EPS * max( |a|,|b| ) ,
*
* where EPS is the machine precision. If ABSTOL is less than
* or equal to zero, then EPS*|T| will be used in its place,
* where |T| is the 1-norm of the tridiagonal matrix obtained
* by reducing A to tridiagonal form.
*
* See "Computing Small Singular Values of Bidiagonal Matrices
* with Guaranteed High Relative Accuracy," by Demmel and
* Kahan, LAPACK Working Note #3.
*
* If high relative accuracy is important, set ABSTOL to
* SLAMCH( 'Safe minimum' ). Doing so will guarantee that
* eigenvalues are computed to high relative accuracy when
* possible in future releases. The current code does not
* make any guarantees about high relative accuracy, but
* future releases will. See J. Barlow and J. Demmel,
* "Computing Accurate Eigensystems of Scaled Diagonally
* Dominant Matrices", LAPACK Working Note #7, for a discussion
* of which matrices define their eigenvalues to high relative
* accuracy.
*
* M (output) INTEGER
* The total number of eigenvalues found. 0 <= M <= N.
* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*
* W (output) REAL array, dimension (N)
* The first M elements contain the selected eigenvalues in
* ascending order.
*
* Z (output) REAL array, dimension (LDZ, max(1,M) )
* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
* contain the orthonormal eigenvectors of the matrix A
* corresponding to the selected eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* Note: the user must ensure that at least max(1,M) columns are
* supplied in the array Z; if RANGE = 'V', the exact value of M
* is not known in advance and an upper bound must be used.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )
* The support of the eigenvectors in Z, i.e., the indices
* indicating the nonzero elements in Z. The i-th eigenvector
* is nonzero only in elements ISUPPZ( 2*i-1 ) through
* ISUPPZ( 2*i ).
********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1
*
* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
* On exit, if INFO = 0, WORK(1) returns the optimal (and
* minimal) LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK. LWORK >= 20*N.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal sizes of the WORK and IWORK
* arrays, returns these values as the first entries of the WORK
* and IWORK arrays, and no error message related to LWORK or
* LIWORK is issued by XERBLA.
*
* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if INFO = 0, IWORK(1) returns the optimal (and
* minimal) LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK. LIWORK >= 10*N.
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal sizes of the WORK and
* IWORK arrays, returns these values as the first entries of
* the WORK and IWORK arrays, and no error message related to
* LWORK or LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: Internal error
*
* Further Details
* ===============
*
* Based on contributions by
* Inderjit Dhillon, IBM Almaden, USA
* Osni Marques, LBNL/NERSC, USA
* Ken Stanley, Computer Science Division, University of
* California at Berkeley, USA
* Jason Riedy, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, TEST, LQUERY, VALEIG, WANTZ,
$ TRYRAC
CHARACTER ORDER
INTEGER I, IEEEOK, IMAX, INDIBL, INDIFL, INDISP,
$ INDIWO, ISCALE, J, JJ, LIWMIN, LWMIN, NSPLIT
REAL BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM,
$ TMP1, TNRM, VLL, VUU
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
REAL SLAMCH, SLANST
EXTERNAL LSAME, ILAENV, SLAMCH, SLANST
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SSCAL, SSTEBZ, SSTEMR, SSTEIN, SSTERF,
$ SSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
*
* Test the input parameters.
*
IEEEOK = ILAENV( 10, 'SSTEVR', 'N', 1, 2, 3, 4 )
*
WANTZ = LSAME( JOBZ, 'V' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
*
LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LIWORK.EQ.-1 ) )
LWMIN = MAX( 1, 20*N )
LIWMIN = MAX(1, 10*N )
*
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE
IF( VALEIG ) THEN
IF( N.GT.0 .AND. VU.LE.VL )
$ INFO = -7
ELSE IF( INDEIG ) THEN
IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
INFO = -9
END IF
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -14
END IF
END IF
*
IF( INFO.EQ.0 ) THEN
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -17
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -19
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSTEVR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( ALLEIG .OR. INDEIG ) THEN
M = 1
W( 1 ) = D( 1 )
ELSE
IF( VL.LT.D( 1 ) .AND. VU.GE.D( 1 ) ) THEN
M = 1
W( 1 ) = D( 1 )
END IF
END IF
IF( WANTZ )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = SLAMCH( 'Safe minimum' )
EPS = SLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
*
*
* Scale matrix to allowable range, if necessary.
*
ISCALE = 0
VLL = VL
VUU = VU
*
TNRM = SLANST( 'M', N, D, E )
IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / TNRM
ELSE IF( TNRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / TNRM
END IF
IF( ISCALE.EQ.1 ) THEN
CALL SSCAL( N, SIGMA, D, 1 )
CALL SSCAL( N-1, SIGMA, E( 1 ), 1 )
IF( VALEIG ) THEN
VLL = VL*SIGMA
VUU = VU*SIGMA
END IF
END IF
* Initialize indices into workspaces. Note: These indices are used only
* if SSTERF or SSTEMR fail.
* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in SSTEBZ and
* stores the block indices of each of the M<=N eigenvalues.
INDIBL = 1
* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in SSTEBZ and
* stores the starting and finishing indices of each block.
INDISP = INDIBL + N
* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors
* that corresponding to eigenvectors that fail to converge in
* SSTEIN. This information is discarded; if any fail, the driver
* returns INFO > 0.
INDIFL = INDISP + N
* INDIWO is the offset of the remaining integer workspace.
INDIWO = INDISP + N
*
* If all eigenvalues are desired, then
* call SSTERF or SSTEMR. If this fails for some eigenvalue, then
* try SSTEBZ.
*
*
TEST = .FALSE.
IF( INDEIG ) THEN
IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
TEST = .TRUE.
END IF
END IF
IF( ( ALLEIG .OR. TEST ) .AND. IEEEOK.EQ.1 ) THEN
CALL SCOPY( N-1, E( 1 ), 1, WORK( 1 ), 1 )
IF( .NOT.WANTZ ) THEN
CALL SCOPY( N, D, 1, W, 1 )
CALL SSTERF( N, W, WORK, INFO )
ELSE
CALL SCOPY( N, D, 1, WORK( N+1 ), 1 )
IF (ABSTOL .LE. TWO*N*EPS) THEN
TRYRAC = .TRUE.
ELSE
TRYRAC = .FALSE.
END IF
CALL SSTEMR( JOBZ, 'A', N, WORK( N+1 ), WORK, VL, VU, IL,
$ IU, M, W, Z, LDZ, N, ISUPPZ, TRYRAC,
$ WORK( 2*N+1 ), LWORK-2*N, IWORK, LIWORK, INFO )
*
END IF
IF( INFO.EQ.0 ) THEN
M = N
GO TO 10
END IF
INFO = 0
END IF
*
* Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN.
*
IF( WANTZ ) THEN
ORDER = 'B'
ELSE
ORDER = 'E'
END IF
CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTOL, D, E, M,
$ NSPLIT, W, IWORK( INDIBL ), IWORK( INDISP ), WORK,
$ IWORK( INDIWO ), INFO )
*
IF( WANTZ ) THEN
CALL SSTEIN( N, D, E, M, W, IWORK( INDIBL ), IWORK( INDISP ),
$ Z, LDZ, WORK, IWORK( INDIWO ), IWORK( INDIFL ),
$ INFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
10 CONTINUE
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = M
ELSE
IMAX = INFO - 1
END IF
CALL SSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
* If eigenvalues are not in order, then sort them, along with
* eigenvectors.
*
IF( WANTZ ) THEN
DO 30 J = 1, M - 1
I = 0
TMP1 = W( J )
DO 20 JJ = J + 1, M
IF( W( JJ ).LT.TMP1 ) THEN
I = JJ
TMP1 = W( JJ )
END IF
20 CONTINUE
*
IF( I.NE.0 ) THEN
W( I ) = W( J )
W( J ) = TMP1
CALL SSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
END IF
30 CONTINUE
END IF
*
* Causes problems with tests 19 & 20:
* IF (wantz .and. INDEIG ) Z( 1,1) = Z(1,1) / 1.002 + .002
*
*
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
RETURN
*
* End of SSTEVR
*
END
SUBROUTINE SSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL,
$ M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE
INTEGER IL, INFO, IU, LDZ, M, N
REAL ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER IFAIL( * ), IWORK( * )
REAL D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SSTEVX computes selected eigenvalues and, optionally, eigenvectors
* of a real symmetric tridiagonal matrix A. Eigenvalues and
* eigenvectors can be selected by specifying either a range of values
* or a range of indices for the desired eigenvalues.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* RANGE (input) CHARACTER*1
* = 'A': all eigenvalues will be found.
* = 'V': all eigenvalues in the half-open interval (VL,VU]
* will be found.
* = 'I': the IL-th through IU-th eigenvalues will be found.
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) REAL array, dimension (N)
* On entry, the n diagonal elements of the tridiagonal matrix
* A.
* On exit, D may be multiplied by a constant factor chosen
* to avoid over/underflow in computing the eigenvalues.
*
* E (input/output) REAL array, dimension (max(1,N-1))
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix A in elements 1 to N-1 of E.
* On exit, E may be multiplied by a constant factor chosen
* to avoid over/underflow in computing the eigenvalues.
*
* VL (input) REAL
* VU (input) REAL
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* ABSTOL (input) REAL
* The absolute error tolerance for the eigenvalues.
* An approximate eigenvalue is accepted as converged
* when it is determined to lie in an interval [a,b]
* of width less than or equal to
*
* ABSTOL + EPS * max( |a|,|b| ) ,
*
* where EPS is the machine precision. If ABSTOL is less
* than or equal to zero, then EPS*|T| will be used in
* its place, where |T| is the 1-norm of the tridiagonal
* matrix.
*
* Eigenvalues will be computed most accurately when ABSTOL is
* set to twice the underflow threshold 2*SLAMCH('S'), not zero.
* If this routine returns with INFO>0, indicating that some
* eigenvectors did not converge, try setting ABSTOL to
* 2*SLAMCH('S').
*
* See "Computing Small Singular Values of Bidiagonal Matrices
* with Guaranteed High Relative Accuracy," by Demmel and
* Kahan, LAPACK Working Note #3.
*
* M (output) INTEGER
* The total number of eigenvalues found. 0 <= M <= N.
* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*
* W (output) REAL array, dimension (N)
* The first M elements contain the selected eigenvalues in
* ascending order.
*
* Z (output) REAL array, dimension (LDZ, max(1,M) )
* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
* contain the orthonormal eigenvectors of the matrix A
* corresponding to the selected eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* If an eigenvector fails to converge (INFO > 0), then that
* column of Z contains the latest approximation to the
* eigenvector, and the index of the eigenvector is returned
* in IFAIL. If JOBZ = 'N', then Z is not referenced.
* Note: the user must ensure that at least max(1,M) columns are
* supplied in the array Z; if RANGE = 'V', the exact value of M
* is not known in advance and an upper bound must be used.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace) REAL array, dimension (5*N)
*
* IWORK (workspace) INTEGER array, dimension (5*N)
*
* IFAIL (output) INTEGER array, dimension (N)
* If JOBZ = 'V', then if INFO = 0, the first M elements of
* IFAIL are zero. If INFO > 0, then IFAIL contains the
* indices of the eigenvectors that failed to converge.
* If JOBZ = 'N', then IFAIL is not referenced.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, then i eigenvectors failed to converge.
* Their indices are stored in array IFAIL.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, TEST, VALEIG, WANTZ
CHARACTER ORDER
INTEGER I, IMAX, INDIBL, INDISP, INDIWO, INDWRK,
$ ISCALE, ITMP1, J, JJ, NSPLIT
REAL BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM,
$ TMP1, TNRM, VLL, VUU
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANST
EXTERNAL LSAME, SLAMCH, SLANST
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SSCAL, SSTEBZ, SSTEIN, SSTEQR, SSTERF,
$ SSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE
IF( VALEIG ) THEN
IF( N.GT.0 .AND. VU.LE.VL )
$ INFO = -7
ELSE IF( INDEIG ) THEN
IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
INFO = -9
END IF
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) )
$ INFO = -14
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSTEVX', -INFO )
RETURN
END IF
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( ALLEIG .OR. INDEIG ) THEN
M = 1
W( 1 ) = D( 1 )
ELSE
IF( VL.LT.D( 1 ) .AND. VU.GE.D( 1 ) ) THEN
M = 1
W( 1 ) = D( 1 )
END IF
END IF
IF( WANTZ )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = SLAMCH( 'Safe minimum' )
EPS = SLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
*
* Scale matrix to allowable range, if necessary.
*
ISCALE = 0
IF ( VALEIG ) THEN
VLL = VL
VUU = VU
ELSE
VLL = ZERO
VUU = ZERO
ENDIF
TNRM = SLANST( 'M', N, D, E )
IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / TNRM
ELSE IF( TNRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / TNRM
END IF
IF( ISCALE.EQ.1 ) THEN
CALL SSCAL( N, SIGMA, D, 1 )
CALL SSCAL( N-1, SIGMA, E( 1 ), 1 )
IF( VALEIG ) THEN
VLL = VL*SIGMA
VUU = VU*SIGMA
END IF
END IF
*
* If all eigenvalues are desired and ABSTOL is less than zero, then
* call SSTERF or SSTEQR. If this fails for some eigenvalue, then
* try SSTEBZ.
*
TEST = .FALSE.
IF( INDEIG ) THEN
IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
TEST = .TRUE.
END IF
END IF
IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN
CALL SCOPY( N, D, 1, W, 1 )
CALL SCOPY( N-1, E( 1 ), 1, WORK( 1 ), 1 )
INDWRK = N + 1
IF( .NOT.WANTZ ) THEN
CALL SSTERF( N, W, WORK, INFO )
ELSE
CALL SSTEQR( 'I', N, W, WORK, Z, LDZ, WORK( INDWRK ), INFO )
IF( INFO.EQ.0 ) THEN
DO 10 I = 1, N
IFAIL( I ) = 0
10 CONTINUE
END IF
END IF
IF( INFO.EQ.0 ) THEN
M = N
GO TO 20
END IF
INFO = 0
END IF
*
* Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN.
*
IF( WANTZ ) THEN
ORDER = 'B'
ELSE
ORDER = 'E'
END IF
INDWRK = 1
INDIBL = 1
INDISP = INDIBL + N
INDIWO = INDISP + N
CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTOL, D, E, M,
$ NSPLIT, W, IWORK( INDIBL ), IWORK( INDISP ),
$ WORK( INDWRK ), IWORK( INDIWO ), INFO )
*
IF( WANTZ ) THEN
CALL SSTEIN( N, D, E, M, W, IWORK( INDIBL ), IWORK( INDISP ),
$ Z, LDZ, WORK( INDWRK ), IWORK( INDIWO ), IFAIL,
$ INFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
20 CONTINUE
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = M
ELSE
IMAX = INFO - 1
END IF
CALL SSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
* If eigenvalues are not in order, then sort them, along with
* eigenvectors.
*
IF( WANTZ ) THEN
DO 40 J = 1, M - 1
I = 0
TMP1 = W( J )
DO 30 JJ = J + 1, M
IF( W( JJ ).LT.TMP1 ) THEN
I = JJ
TMP1 = W( JJ )
END IF
30 CONTINUE
*
IF( I.NE.0 ) THEN
ITMP1 = IWORK( INDIBL+I-1 )
W( I ) = W( J )
IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
W( J ) = TMP1
IWORK( INDIBL+J-1 ) = ITMP1
CALL SSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
IF( INFO.NE.0 ) THEN
ITMP1 = IFAIL( I )
IFAIL( I ) = IFAIL( J )
IFAIL( J ) = ITMP1
END IF
END IF
40 CONTINUE
END IF
*
RETURN
*
* End of SSTEVX
*
END
SUBROUTINE SSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK,
$ IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
REAL ANORM, RCOND
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), IWORK( * )
REAL A( LDA, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SSYCON estimates the reciprocal of the condition number (in the
* 1-norm) of a real symmetric matrix A using the factorization
* A = U*D*U**T or A = L*D*L**T computed by SSYTRF.
*
* An estimate is obtained for norm(inv(A)), and the reciprocal of the
* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the details of the factorization are stored
* as an upper or lower triangular matrix.
* = 'U': Upper triangular, form is A = U*D*U**T;
* = 'L': Lower triangular, form is A = L*D*L**T.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The block diagonal matrix D and the multipliers used to
* obtain the factor U or L as computed by SSYTRF.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* IPIV (input) INTEGER array, dimension (N)
* Details of the interchanges and the block structure of D
* as determined by SSYTRF.
*
* ANORM (input) REAL
* The 1-norm of the original matrix A.
*
* RCOND (output) REAL
* The reciprocal of the condition number of the matrix A,
* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
* estimate of the 1-norm of inv(A) computed in this routine.
*
* WORK (workspace) REAL array, dimension (2*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, KASE
REAL AINVNM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SLACN2, SSYTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( ANORM.LT.ZERO ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSYCON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
RCOND = ZERO
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
ELSE IF( ANORM.LE.ZERO ) THEN
RETURN
END IF
*
* Check that the diagonal matrix D is nonsingular.
*
IF( UPPER ) THEN
*
* Upper triangular storage: examine D from bottom to top
*
DO 10 I = N, 1, -1
IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
$ RETURN
10 CONTINUE
ELSE
*
* Lower triangular storage: examine D from top to bottom.
*
DO 20 I = 1, N
IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
$ RETURN
20 CONTINUE
END IF
*
* Estimate the 1-norm of the inverse.
*
KASE = 0
30 CONTINUE
CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
*
* Multiply by inv(L*D*L') or inv(U*D*U').
*
CALL SSYTRS( UPLO, N, 1, A, LDA, IPIV, WORK, N, INFO )
GO TO 30
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / AINVNM ) / ANORM
*
RETURN
*
* End of SSYCON
*
END
SUBROUTINE SSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), W( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SSYEV computes all eigenvalues and, optionally, eigenvectors of a
* real symmetric matrix A.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) REAL array, dimension (LDA, N)
* On entry, the symmetric matrix A. If UPLO = 'U', the
* leading N-by-N upper triangular part of A contains the
* upper triangular part of the matrix A. If UPLO = 'L',
* the leading N-by-N lower triangular part of A contains
* the lower triangular part of the matrix A.
* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
* orthonormal eigenvectors of the matrix A.
* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
* or the upper triangle (if UPLO='U') of A, including the
* diagonal, is destroyed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* W (output) REAL array, dimension (N)
* If INFO = 0, the eigenvalues in ascending order.
*
* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The length of the array WORK. LWORK >= max(1,3*N-1).
* For optimal efficiency, LWORK >= (NB+2)*N,
* where NB is the blocksize for SSYTRD returned by ILAENV.
*
* 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
* > 0: if INFO = i, the algorithm failed to converge; i
* off-diagonal elements of an intermediate tridiagonal
* form did not converge to zero.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL LOWER, LQUERY, WANTZ
INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE,
$ LLWORK, LWKOPT, NB
REAL ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
$ SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
REAL SLAMCH, SLANSY
EXTERNAL ILAENV, LSAME, SLAMCH, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL SLASCL, SORGTR, SSCAL, SSTEQR, SSTERF, SSYTRD,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
LOWER = LSAME( UPLO, 'L' )
LQUERY = ( LWORK.EQ.-1 )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
END IF
*
IF( INFO.EQ.0 ) THEN
NB = ILAENV( 1, 'SSYTRD', UPLO, N, -1, -1, -1 )
LWKOPT = MAX( 1, ( NB+2 )*N )
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.MAX( 1, 3*N-1 ) .AND. .NOT.LQUERY )
$ INFO = -8
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSYEV ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
RETURN
END IF
*
IF( N.EQ.1 ) THEN
W( 1 ) = A( 1, 1 )
WORK( 1 ) = 2
IF( WANTZ )
$ A( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = SLAMCH( 'Safe minimum' )
EPS = SLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = SQRT( BIGNUM )
*
* Scale matrix to allowable range, if necessary.
*
ANRM = SLANSY( 'M', UPLO, N, A, LDA, WORK )
ISCALE = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 )
$ CALL SLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO )
*
* Call SSYTRD to reduce symmetric matrix to tridiagonal form.
*
INDE = 1
INDTAU = INDE + N
INDWRK = INDTAU + N
LLWORK = LWORK - INDWRK + 1
CALL SSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ),
$ WORK( INDWRK ), LLWORK, IINFO )
*
* For eigenvalues only, call SSTERF. For eigenvectors, first call
* SORGTR to generate the orthogonal matrix, then call SSTEQR.
*
IF( .NOT.WANTZ ) THEN
CALL SSTERF( N, W, WORK( INDE ), INFO )
ELSE
CALL SORGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ),
$ LLWORK, IINFO )
CALL SSTEQR( JOBZ, N, W, WORK( INDE ), A, LDA, WORK( INDTAU ),
$ INFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = N
ELSE
IMAX = INFO - 1
END IF
CALL SSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
* Set WORK(1) to optimal workspace size.
*
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of SSYEV
*
END
SUBROUTINE SSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK,
$ LIWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, LDA, LIWORK, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL A( LDA, * ), W( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SSYEVD computes all eigenvalues and, optionally, eigenvectors of a
* real symmetric matrix A. If eigenvectors are desired, it uses a
* divide and conquer algorithm.
*
* The divide and conquer algorithm makes very mild assumptions about
* floating point arithmetic. It will work on machines with a guard
* digit in add/subtract, or on those binary machines without guard
* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
* Cray-2. It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Because of large use of BLAS of level 3, SSYEVD needs N**2 more
* workspace than SSYEVX.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) REAL array, dimension (LDA, N)
* On entry, the symmetric matrix A. If UPLO = 'U', the
* leading N-by-N upper triangular part of A contains the
* upper triangular part of the matrix A. If UPLO = 'L',
* the leading N-by-N lower triangular part of A contains
* the lower triangular part of the matrix A.
* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
* orthonormal eigenvectors of the matrix A.
* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
* or the upper triangle (if UPLO='U') of A, including the
* diagonal, is destroyed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* W (output) REAL array, dimension (N)
* If INFO = 0, the eigenvalues in ascending order.
*
* WORK (workspace/output) REAL array,
* dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* If N <= 1, LWORK must be at least 1.
* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1.
* If JOBZ = 'V' and N > 1, LWORK must be at least
* 1 + 6*N + 2*N**2.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal sizes of the WORK and IWORK
* arrays, returns these values as the first entries of the WORK
* and IWORK arrays, and no error message related to LWORK or
* LIWORK is issued by XERBLA.
*
* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK.
* If N <= 1, LIWORK must be at least 1.
* If JOBZ = 'N' and N > 1, LIWORK must be at least 1.
* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal sizes of the WORK and
* IWORK arrays, returns these values as the first entries of
* the WORK and IWORK arrays, and no error message related to
* LWORK or LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i and JOBZ = 'N', then the algorithm failed
* to converge; i off-diagonal elements of an intermediate
* tridiagonal form did not converge to zero;
* if INFO = i and JOBZ = 'V', then the algorithm failed
* to compute an eigenvalue while working on the submatrix
* lying in rows and columns INFO/(N+1) through
* mod(INFO,N+1).
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
* Modified by Francoise Tisseur, University of Tennessee.
*
* Modified description of INFO. Sven, 16 Feb 05.
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
*
LOGICAL LOWER, LQUERY, WANTZ
INTEGER IINFO, INDE, INDTAU, INDWK2, INDWRK, ISCALE,
$ LIOPT, LIWMIN, LLWORK, LLWRK2, LOPT, LWMIN
REAL ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
$ SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
REAL SLAMCH, SLANSY
EXTERNAL ILAENV, LSAME, SLAMCH, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL SLACPY, SLASCL, SORMTR, SSCAL, SSTEDC, SSTERF,
$ SSYTRD, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
LOWER = LSAME( UPLO, 'L' )
LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
END IF
*
IF( INFO.EQ.0 ) THEN
IF( N.LE.1 ) THEN
LIWMIN = 1
LWMIN = 1
LOPT = LWMIN
LIOPT = LIWMIN
ELSE
IF( WANTZ ) THEN
LIWMIN = 3 + 5*N
LWMIN = 1 + 6*N + 2*N**2
ELSE
LIWMIN = 1
LWMIN = 2*N + 1
END IF
LOPT = MAX( LWMIN, 2*N +
$ ILAENV( 1, 'SSYTRD', UPLO, N, -1, -1, -1 ) )
LIOPT = LIWMIN
END IF
WORK( 1 ) = LOPT
IWORK( 1 ) = LIOPT
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -8
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -10
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSYEVD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
W( 1 ) = A( 1, 1 )
IF( WANTZ )
$ A( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = SLAMCH( 'Safe minimum' )
EPS = SLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = SQRT( BIGNUM )
*
* Scale matrix to allowable range, if necessary.
*
ANRM = SLANSY( 'M', UPLO, N, A, LDA, WORK )
ISCALE = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 )
$ CALL SLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO )
*
* Call SSYTRD to reduce symmetric matrix to tridiagonal form.
*
INDE = 1
INDTAU = INDE + N
INDWRK = INDTAU + N
LLWORK = LWORK - INDWRK + 1
INDWK2 = INDWRK + N*N
LLWRK2 = LWORK - INDWK2 + 1
*
CALL SSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ),
$ WORK( INDWRK ), LLWORK, IINFO )
*
* For eigenvalues only, call SSTERF. For eigenvectors, first call
* SSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the
* tridiagonal matrix, then call SORMTR to multiply it by the
* Householder transformations stored in A.
*
IF( .NOT.WANTZ ) THEN
CALL SSTERF( N, W, WORK( INDE ), INFO )
ELSE
CALL SSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N,
$ WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO )
CALL SORMTR( 'L', UPLO, 'N', N, N, A, LDA, WORK( INDTAU ),
$ WORK( INDWRK ), N, WORK( INDWK2 ), LLWRK2, IINFO )
CALL SLACPY( 'A', N, N, WORK( INDWRK ), N, A, LDA )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( ISCALE.EQ.1 )
$ CALL SSCAL( N, ONE / SIGMA, W, 1 )
*
WORK( 1 ) = LOPT
IWORK( 1 ) = LIOPT
*
RETURN
*
* End of SSYEVD
*
END
SUBROUTINE SSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU,
$ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK,
$ IWORK, LIWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE, UPLO
INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LWORK, M, N
REAL ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER ISUPPZ( * ), IWORK( * )
REAL A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SSYEVR computes selected eigenvalues and, optionally, eigenvectors
* of a real symmetric matrix A. Eigenvalues and eigenvectors can be
* selected by specifying either a range of values or a range of
* indices for the desired eigenvalues.
*
* SSYEVR first reduces the matrix A to tridiagonal form T with a call
* to SSYTRD. Then, whenever possible, SSYEVR calls SSTEMR to compute
* the eigenspectrum using Relatively Robust Representations. SSTEMR
* computes eigenvalues by the dqds algorithm, while orthogonal
* eigenvectors are computed from various "good" L D L^T representations
* (also known as Relatively Robust Representations). Gram-Schmidt
* orthogonalization is avoided as far as possible. More specifically,
* the various steps of the algorithm are as follows.
*
* For each unreduced block (submatrix) of T,
* (a) Compute T - sigma I = L D L^T, so that L and D
* define all the wanted eigenvalues to high relative accuracy.
* This means that small relative changes in the entries of D and L
* cause only small relative changes in the eigenvalues and
* eigenvectors. The standard (unfactored) representation of the
* tridiagonal matrix T does not have this property in general.
* (b) Compute the eigenvalues to suitable accuracy.
* If the eigenvectors are desired, the algorithm attains full
* accuracy of the computed eigenvalues only right before
* the corresponding vectors have to be computed, see steps c) and d).
* (c) For each cluster of close eigenvalues, select a new
* shift close to the cluster, find a new factorization, and refine
* the shifted eigenvalues to suitable accuracy.
* (d) For each eigenvalue with a large enough relative separation compute
* the corresponding eigenvector by forming a rank revealing twisted
* factorization. Go back to (c) for any clusters that remain.
*
* The desired accuracy of the output can be specified by the input
* parameter ABSTOL.
*
* For more details, see SSTEMR's documentation and:
* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
* 2004. Also LAPACK Working Note 154.
* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
* tridiagonal eigenvalue/eigenvector problem",
* Computer Science Division Technical Report No. UCB/CSD-97-971,
* UC Berkeley, May 1997.
*
*
* Note 1 : SSYEVR calls SSTEMR when the full spectrum is requested
* on machines which conform to the ieee-754 floating point standard.
* SSYEVR calls SSTEBZ and SSTEIN on non-ieee machines and
* when partial spectrum requests are made.
*
* Normal execution of SSTEMR may create NaNs and infinities and
* hence may abort due to a floating point exception in environments
* which do not handle NaNs and infinities in the ieee standard default
* manner.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* RANGE (input) CHARACTER*1
* = 'A': all eigenvalues will be found.
* = 'V': all eigenvalues in the half-open interval (VL,VU]
* will be found.
* = 'I': the IL-th through IU-th eigenvalues will be found.
********** For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and
********** SSTEIN are called
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) REAL array, dimension (LDA, N)
* On entry, the symmetric matrix A. If UPLO = 'U', the
* leading N-by-N upper triangular part of A contains the
* upper triangular part of the matrix A. If UPLO = 'L',
* the leading N-by-N lower triangular part of A contains
* the lower triangular part of the matrix A.
* On exit, the lower triangle (if UPLO='L') or the upper
* triangle (if UPLO='U') of A, including the diagonal, is
* destroyed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* VL (input) REAL
* VU (input) REAL
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* ABSTOL (input) REAL
* The absolute error tolerance for the eigenvalues.
* An approximate eigenvalue is accepted as converged
* when it is determined to lie in an interval [a,b]
* of width less than or equal to
*
* ABSTOL + EPS * max( |a|,|b| ) ,
*
* where EPS is the machine precision. If ABSTOL is less than
* or equal to zero, then EPS*|T| will be used in its place,
* where |T| is the 1-norm of the tridiagonal matrix obtained
* by reducing A to tridiagonal form.
*
* See "Computing Small Singular Values of Bidiagonal Matrices
* with Guaranteed High Relative Accuracy," by Demmel and
* Kahan, LAPACK Working Note #3.
*
* If high relative accuracy is important, set ABSTOL to
* SLAMCH( 'Safe minimum' ). Doing so will guarantee that
* eigenvalues are computed to high relative accuracy when
* possible in future releases. The current code does not
* make any guarantees about high relative accuracy, but
* future releases will. See J. Barlow and J. Demmel,
* "Computing Accurate Eigensystems of Scaled Diagonally
* Dominant Matrices", LAPACK Working Note #7, for a discussion
* of which matrices define their eigenvalues to high relative
* accuracy.
*
* M (output) INTEGER
* The total number of eigenvalues found. 0 <= M <= N.
* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*
* W (output) REAL array, dimension (N)
* The first M elements contain the selected eigenvalues in
* ascending order.
*
* Z (output) REAL array, dimension (LDZ, max(1,M))
* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
* contain the orthonormal eigenvectors of the matrix A
* corresponding to the selected eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* If JOBZ = 'N', then Z is not referenced.
* Note: the user must ensure that at least max(1,M) columns are
* supplied in the array Z; if RANGE = 'V', the exact value of M
* is not known in advance and an upper bound must be used.
* Supplying N columns is always safe.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )
* The support of the eigenvectors in Z, i.e., the indices
* indicating the nonzero elements in Z. The i-th eigenvector
* is nonzero only in elements ISUPPZ( 2*i-1 ) through
* ISUPPZ( 2*i ).
********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1
*
* WORK (workspace/output) REAL 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,26*N).
* For optimal efficiency, LWORK >= (NB+6)*N,
* where NB is the max of the blocksize for SSYTRD and SORMTR
* returned by ILAENV.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal sizes of the WORK and IWORK
* arrays, returns these values as the first entries of the WORK
* and IWORK arrays, and no error message related to LWORK or
* LIWORK is issued by XERBLA.
*
* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if INFO = 0, IWORK(1) returns the optimal LWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK. LIWORK >= max(1,10*N).
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal sizes of the WORK and
* IWORK arrays, returns these values as the first entries of
* the WORK and IWORK arrays, and no error message related to
* LWORK or LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: Internal error
*
* Further Details
* ===============
*
* Based on contributions by
* Inderjit Dhillon, IBM Almaden, USA
* Osni Marques, LBNL/NERSC, USA
* Ken Stanley, Computer Science Division, University of
* California at Berkeley, USA
* Jason Riedy, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG,
$ WANTZ, TRYRAC
CHARACTER ORDER
INTEGER I, IEEEOK, IINFO, IMAX, INDD, INDDD, INDE,
$ INDEE, INDIBL, INDIFL, INDISP, INDIWO, INDTAU,
$ INDWK, INDWKN, ISCALE, J, JJ, LIWMIN,
$ LLWORK, LLWRKN, LWKOPT, LWMIN, NB, NSPLIT
REAL ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
$ SIGMA, SMLNUM, TMP1, VLL, VUU
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
REAL SLAMCH, SLANSY
EXTERNAL LSAME, ILAENV, SLAMCH, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SORMTR, SSCAL, SSTEBZ, SSTEMR, SSTEIN,
$ SSTERF, SSWAP, SSYTRD, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
IEEEOK = ILAENV( 10, 'SSYEVR', 'N', 1, 2, 3, 4 )
*
LOWER = LSAME( UPLO, 'L' )
WANTZ = LSAME( JOBZ, 'V' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
*
LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LIWORK.EQ.-1 ) )
*
LWMIN = MAX( 1, 26*N )
LIWMIN = MAX( 1, 10*N )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
INFO = -2
ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE
IF( VALEIG ) THEN
IF( N.GT.0 .AND. VU.LE.VL )
$ INFO = -8
ELSE IF( INDEIG ) THEN
IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
INFO = -10
END IF
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -15
END IF
END IF
*
IF( INFO.EQ.0 ) THEN
NB = ILAENV( 1, 'SSYTRD', UPLO, N, -1, -1, -1 )
NB = MAX( NB, ILAENV( 1, 'SORMTR', UPLO, N, -1, -1, -1 ) )
LWKOPT = MAX( ( NB+1 )*N, LWMIN )
WORK( 1 ) = LWKOPT
IWORK( 1 ) = LIWMIN
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -18
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -20
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSYEVR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
IF( N.EQ.1 ) THEN
WORK( 1 ) = 26
IF( ALLEIG .OR. INDEIG ) THEN
M = 1
W( 1 ) = A( 1, 1 )
ELSE
IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN
M = 1
W( 1 ) = A( 1, 1 )
END IF
END IF
IF( WANTZ )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = SLAMCH( 'Safe minimum' )
EPS = SLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
*
* Scale matrix to allowable range, if necessary.
*
ISCALE = 0
ABSTLL = ABSTOL
IF (VALEIG) THEN
VLL = VL
VUU = VU
END IF
ANRM = SLANSY( 'M', UPLO, N, A, LDA, WORK )
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 ) THEN
IF( LOWER ) THEN
DO 10 J = 1, N
CALL SSCAL( N-J+1, SIGMA, A( J, J ), 1 )
10 CONTINUE
ELSE
DO 20 J = 1, N
CALL SSCAL( J, SIGMA, A( 1, J ), 1 )
20 CONTINUE
END IF
IF( ABSTOL.GT.0 )
$ ABSTLL = ABSTOL*SIGMA
IF( VALEIG ) THEN
VLL = VL*SIGMA
VUU = VU*SIGMA
END IF
END IF
* Initialize indices into workspaces. Note: The IWORK indices are
* used only if SSTERF or SSTEMR fail.
* WORK(INDTAU:INDTAU+N-1) stores the scalar factors of the
* elementary reflectors used in SSYTRD.
INDTAU = 1
* WORK(INDD:INDD+N-1) stores the tridiagonal's diagonal entries.
INDD = INDTAU + N
* WORK(INDE:INDE+N-1) stores the off-diagonal entries of the
* tridiagonal matrix from SSYTRD.
INDE = INDD + N
* WORK(INDDD:INDDD+N-1) is a copy of the diagonal entries over
* -written by SSTEMR (the SSTERF path copies the diagonal to W).
INDDD = INDE + N
* WORK(INDEE:INDEE+N-1) is a copy of the off-diagonal entries over
* -written while computing the eigenvalues in SSTERF and SSTEMR.
INDEE = INDDD + N
* INDWK is the starting offset of the left-over workspace, and
* LLWORK is the remaining workspace size.
INDWK = INDEE + N
LLWORK = LWORK - INDWK + 1
* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in SSTEBZ and
* stores the block indices of each of the M<=N eigenvalues.
INDIBL = 1
* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in SSTEBZ and
* stores the starting and finishing indices of each block.
INDISP = INDIBL + N
* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors
* that corresponding to eigenvectors that fail to converge in
* SSTEIN. This information is discarded; if any fail, the driver
* returns INFO > 0.
INDIFL = INDISP + N
* INDIWO is the offset of the remaining integer workspace.
INDIWO = INDISP + N
*
* Call SSYTRD to reduce symmetric matrix to tridiagonal form.
*
CALL SSYTRD( UPLO, N, A, LDA, WORK( INDD ), WORK( INDE ),
$ WORK( INDTAU ), WORK( INDWK ), LLWORK, IINFO )
*
* If all eigenvalues are desired
* then call SSTERF or SSTEMR and SORMTR.
*
TEST = .FALSE.
IF( INDEIG ) THEN
IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
TEST = .TRUE.
END IF
END IF
IF( ( ALLEIG.OR.TEST ) .AND. ( IEEEOK.EQ.1 ) ) THEN
IF( .NOT.WANTZ ) THEN
CALL SCOPY( N, WORK( INDD ), 1, W, 1 )
CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
CALL SSTERF( N, W, WORK( INDEE ), INFO )
ELSE
CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
CALL SCOPY( N, WORK( INDD ), 1, WORK( INDDD ), 1 )
*
IF (ABSTOL .LE. TWO*N*EPS) THEN
TRYRAC = .TRUE.
ELSE
TRYRAC = .FALSE.
END IF
CALL SSTEMR( JOBZ, 'A', N, WORK( INDDD ), WORK( INDEE ),
$ VL, VU, IL, IU, M, W, Z, LDZ, N, ISUPPZ,
$ TRYRAC, WORK( INDWK ), LWORK, IWORK, LIWORK,
$ INFO )
*
*
*
* Apply orthogonal matrix used in reduction to tridiagonal
* form to eigenvectors returned by SSTEIN.
*
IF( WANTZ .AND. INFO.EQ.0 ) THEN
INDWKN = INDE
LLWRKN = LWORK - INDWKN + 1
CALL SORMTR( 'L', UPLO, 'N', N, M, A, LDA,
$ WORK( INDTAU ), Z, LDZ, WORK( INDWKN ),
$ LLWRKN, IINFO )
END IF
END IF
*
*
IF( INFO.EQ.0 ) THEN
* Everything worked. Skip SSTEBZ/SSTEIN. IWORK(:) are
* undefined.
M = N
GO TO 30
END IF
INFO = 0
END IF
*
* Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN.
* Also call SSTEBZ and SSTEIN if SSTEMR fails.
*
IF( WANTZ ) THEN
ORDER = 'B'
ELSE
ORDER = 'E'
END IF
CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
$ WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
$ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWK ),
$ IWORK( INDIWO ), INFO )
*
IF( WANTZ ) THEN
CALL SSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
$ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
$ WORK( INDWK ), IWORK( INDIWO ), IWORK( INDIFL ),
$ INFO )
*
* Apply orthogonal matrix used in reduction to tridiagonal
* form to eigenvectors returned by SSTEIN.
*
INDWKN = INDE
LLWRKN = LWORK - INDWKN + 1
CALL SORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z,
$ LDZ, WORK( INDWKN ), LLWRKN, IINFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
* Jump here if SSTEMR/SSTEIN succeeded.
30 CONTINUE
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = M
ELSE
IMAX = INFO - 1
END IF
CALL SSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
* If eigenvalues are not in order, then sort them, along with
* eigenvectors. Note: We do not sort the IFAIL portion of IWORK.
* It may not be initialized (if SSTEMR/SSTEIN succeeded), and we do
* not return this detailed information to the user.
*
IF( WANTZ ) THEN
DO 50 J = 1, M - 1
I = 0
TMP1 = W( J )
DO 40 JJ = J + 1, M
IF( W( JJ ).LT.TMP1 ) THEN
I = JJ
TMP1 = W( JJ )
END IF
40 CONTINUE
*
IF( I.NE.0 ) THEN
W( I ) = W( J )
W( J ) = TMP1
CALL SSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
END IF
50 CONTINUE
END IF
*
* Set WORK(1) to optimal workspace size.
*
WORK( 1 ) = LWKOPT
IWORK( 1 ) = LIWMIN
*
RETURN
*
* End of SSYEVR
*
END
SUBROUTINE SSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU,
$ ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK,
$ IFAIL, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE, UPLO
INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N
REAL ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER IFAIL( * ), IWORK( * )
REAL A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SSYEVX computes selected eigenvalues and, optionally, eigenvectors
* of a real symmetric matrix A. Eigenvalues and eigenvectors can be
* selected by specifying either a range of values or a range of indices
* for the desired eigenvalues.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* RANGE (input) CHARACTER*1
* = 'A': all eigenvalues will be found.
* = 'V': all eigenvalues in the half-open interval (VL,VU]
* will be found.
* = 'I': the IL-th through IU-th eigenvalues will be found.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) REAL array, dimension (LDA, N)
* On entry, the symmetric matrix A. If UPLO = 'U', the
* leading N-by-N upper triangular part of A contains the
* upper triangular part of the matrix A. If UPLO = 'L',
* the leading N-by-N lower triangular part of A contains
* the lower triangular part of the matrix A.
* On exit, the lower triangle (if UPLO='L') or the upper
* triangle (if UPLO='U') of A, including the diagonal, is
* destroyed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* VL (input) REAL
* VU (input) REAL
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* ABSTOL (input) REAL
* The absolute error tolerance for the eigenvalues.
* An approximate eigenvalue is accepted as converged
* when it is determined to lie in an interval [a,b]
* of width less than or equal to
*
* ABSTOL + EPS * max( |a|,|b| ) ,
*
* where EPS is the machine precision. If ABSTOL is less than
* or equal to zero, then EPS*|T| will be used in its place,
* where |T| is the 1-norm of the tridiagonal matrix obtained
* by reducing A to tridiagonal form.
*
* Eigenvalues will be computed most accurately when ABSTOL is
* set to twice the underflow threshold 2*SLAMCH('S'), not zero.
* If this routine returns with INFO>0, indicating that some
* eigenvectors did not converge, try setting ABSTOL to
* 2*SLAMCH('S').
*
* See "Computing Small Singular Values of Bidiagonal Matrices
* with Guaranteed High Relative Accuracy," by Demmel and
* Kahan, LAPACK Working Note #3.
*
* M (output) INTEGER
* The total number of eigenvalues found. 0 <= M <= N.
* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*
* W (output) REAL array, dimension (N)
* On normal exit, the first M elements contain the selected
* eigenvalues in ascending order.
*
* Z (output) REAL array, dimension (LDZ, max(1,M))
* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
* contain the orthonormal eigenvectors of the matrix A
* corresponding to the selected eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* If an eigenvector fails to converge, then that column of Z
* contains the latest approximation to the eigenvector, and the
* index of the eigenvector is returned in IFAIL.
* If JOBZ = 'N', then Z is not referenced.
* Note: the user must ensure that at least max(1,M) columns are
* supplied in the array Z; if RANGE = 'V', the exact value of M
* is not known in advance and an upper bound must be used.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The length of the array WORK. LWORK >= 1, when N <= 1;
* otherwise 8*N.
* For optimal efficiency, LWORK >= (NB+3)*N,
* where NB is the max of the blocksize for SSYTRD and SORMTR
* returned by ILAENV.
*
* 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.
*
* IWORK (workspace) INTEGER array, dimension (5*N)
*
* IFAIL (output) INTEGER array, dimension (N)
* If JOBZ = 'V', then if INFO = 0, the first M elements of
* IFAIL are zero. If INFO > 0, then IFAIL contains the
* indices of the eigenvectors that failed to converge.
* If JOBZ = 'N', then IFAIL is not referenced.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, then i eigenvectors failed to converge.
* Their indices are stored in array IFAIL.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG,
$ WANTZ
CHARACTER ORDER
INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
$ INDISP, INDIWO, INDTAU, INDWKN, INDWRK, ISCALE,
$ ITMP1, J, JJ, LLWORK, LLWRKN, LWKMIN,
$ LWKOPT, NB, NSPLIT
REAL ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
$ SIGMA, SMLNUM, TMP1, VLL, VUU
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
REAL SLAMCH, SLANSY
EXTERNAL LSAME, ILAENV, SLAMCH, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLACPY, SORGTR, SORMTR, SSCAL, SSTEBZ,
$ SSTEIN, SSTEQR, SSTERF, SSWAP, SSYTRD, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
LOWER = LSAME( UPLO, 'L' )
WANTZ = LSAME( JOBZ, 'V' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
LQUERY = ( LWORK.EQ.-1 )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
INFO = -2
ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE
IF( VALEIG ) THEN
IF( N.GT.0 .AND. VU.LE.VL )
$ INFO = -8
ELSE IF( INDEIG ) THEN
IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
INFO = -10
END IF
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -15
END IF
END IF
*
IF( INFO.EQ.0 ) THEN
IF( N.LE.1 ) THEN
LWKMIN = 1
WORK( 1 ) = LWKMIN
ELSE
LWKMIN = 8*N
NB = ILAENV( 1, 'SSYTRD', UPLO, N, -1, -1, -1 )
NB = MAX( NB, ILAENV( 1, 'SORMTR', UPLO, N, -1, -1, -1 ) )
LWKOPT = MAX( LWKMIN, ( NB + 3 )*N )
WORK( 1 ) = LWKOPT
END IF
*
IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY )
$ INFO = -17
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSYEVX', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 ) THEN
RETURN
END IF
*
IF( N.EQ.1 ) THEN
IF( ALLEIG .OR. INDEIG ) THEN
M = 1
W( 1 ) = A( 1, 1 )
ELSE
IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN
M = 1
W( 1 ) = A( 1, 1 )
END IF
END IF
IF( WANTZ )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = SLAMCH( 'Safe minimum' )
EPS = SLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
*
* Scale matrix to allowable range, if necessary.
*
ISCALE = 0
ABSTLL = ABSTOL
IF( VALEIG ) THEN
VLL = VL
VUU = VU
END IF
ANRM = SLANSY( 'M', UPLO, N, A, LDA, WORK )
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 ) THEN
IF( LOWER ) THEN
DO 10 J = 1, N
CALL SSCAL( N-J+1, SIGMA, A( J, J ), 1 )
10 CONTINUE
ELSE
DO 20 J = 1, N
CALL SSCAL( J, SIGMA, A( 1, J ), 1 )
20 CONTINUE
END IF
IF( ABSTOL.GT.0 )
$ ABSTLL = ABSTOL*SIGMA
IF( VALEIG ) THEN
VLL = VL*SIGMA
VUU = VU*SIGMA
END IF
END IF
*
* Call SSYTRD to reduce symmetric matrix to tridiagonal form.
*
INDTAU = 1
INDE = INDTAU + N
INDD = INDE + N
INDWRK = INDD + N
LLWORK = LWORK - INDWRK + 1
CALL SSYTRD( UPLO, N, A, LDA, WORK( INDD ), WORK( INDE ),
$ WORK( INDTAU ), WORK( INDWRK ), LLWORK, IINFO )
*
* If all eigenvalues are desired and ABSTOL is less than or equal to
* zero, then call SSTERF or SORGTR and SSTEQR. If this fails for
* some eigenvalue, then try SSTEBZ.
*
TEST = .FALSE.
IF( INDEIG ) THEN
IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
TEST = .TRUE.
END IF
END IF
IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN
CALL SCOPY( N, WORK( INDD ), 1, W, 1 )
INDEE = INDWRK + 2*N
IF( .NOT.WANTZ ) THEN
CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
CALL SSTERF( N, W, WORK( INDEE ), INFO )
ELSE
CALL SLACPY( 'A', N, N, A, LDA, Z, LDZ )
CALL SORGTR( UPLO, N, Z, LDZ, WORK( INDTAU ),
$ WORK( INDWRK ), LLWORK, IINFO )
CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
CALL SSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ,
$ WORK( INDWRK ), INFO )
IF( INFO.EQ.0 ) THEN
DO 30 I = 1, N
IFAIL( I ) = 0
30 CONTINUE
END IF
END IF
IF( INFO.EQ.0 ) THEN
M = N
GO TO 40
END IF
INFO = 0
END IF
*
* Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN.
*
IF( WANTZ ) THEN
ORDER = 'B'
ELSE
ORDER = 'E'
END IF
INDIBL = 1
INDISP = INDIBL + N
INDIWO = INDISP + N
CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
$ WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
$ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ),
$ IWORK( INDIWO ), INFO )
*
IF( WANTZ ) THEN
CALL SSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
$ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
$ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO )
*
* Apply orthogonal matrix used in reduction to tridiagonal
* form to eigenvectors returned by SSTEIN.
*
INDWKN = INDE
LLWRKN = LWORK - INDWKN + 1
CALL SORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z,
$ LDZ, WORK( INDWKN ), LLWRKN, IINFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
40 CONTINUE
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = M
ELSE
IMAX = INFO - 1
END IF
CALL SSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
* If eigenvalues are not in order, then sort them, along with
* eigenvectors.
*
IF( WANTZ ) THEN
DO 60 J = 1, M - 1
I = 0
TMP1 = W( J )
DO 50 JJ = J + 1, M
IF( W( JJ ).LT.TMP1 ) THEN
I = JJ
TMP1 = W( JJ )
END IF
50 CONTINUE
*
IF( I.NE.0 ) THEN
ITMP1 = IWORK( INDIBL+I-1 )
W( I ) = W( J )
IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
W( J ) = TMP1
IWORK( INDIBL+J-1 ) = ITMP1
CALL SSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
IF( INFO.NE.0 ) THEN
ITMP1 = IFAIL( I )
IFAIL( I ) = IFAIL( J )
IFAIL( J ) = ITMP1
END IF
END IF
60 CONTINUE
END IF
*
* Set WORK(1) to optimal workspace size.
*
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of SSYEVX
*
END
SUBROUTINE SSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, ITYPE, LDA, LDB, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* SSYGS2 reduces a real symmetric-definite generalized eigenproblem
* to standard form.
*
* If ITYPE = 1, the problem is A*x = lambda*B*x,
* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')
*
* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.
*
* B must have been previously factorized as U'*U or L*L' by SPOTRF.
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');
* = 2 or 3: compute U*A*U' or L'*A*L.
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored, and how B has been factorized.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the symmetric matrix A. If UPLO = 'U', the leading
* n by n upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading n by n lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced.
*
* On exit, if INFO = 0, the transformed matrix, stored in the
* same format as A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input) REAL array, dimension (LDB,N)
* The triangular factor from the Cholesky factorization of B,
* as returned by SPOTRF.
*
* 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 ..
REAL ONE, HALF
PARAMETER ( ONE = 1.0, HALF = 0.5 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER K
REAL AKK, BKK, CT
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SSCAL, SSYR2, STRMV, STRSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
INFO = -1
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSYGS2', -INFO )
RETURN
END IF
*
IF( ITYPE.EQ.1 ) THEN
IF( UPPER ) THEN
*
* Compute inv(U')*A*inv(U)
*
DO 10 K = 1, N
*
* Update the upper triangle of A(k:n,k:n)
*
AKK = A( K, K )
BKK = B( K, K )
AKK = AKK / BKK**2
A( K, K ) = AKK
IF( K.LT.N ) THEN
CALL SSCAL( N-K, ONE / BKK, A( K, K+1 ), LDA )
CT = -HALF*AKK
CALL SAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ),
$ LDA )
CALL SSYR2( UPLO, N-K, -ONE, A( K, K+1 ), LDA,
$ B( K, K+1 ), LDB, A( K+1, K+1 ), LDA )
CALL SAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ),
$ LDA )
CALL STRSV( UPLO, 'Transpose', 'Non-unit', N-K,
$ B( K+1, K+1 ), LDB, A( K, K+1 ), LDA )
END IF
10 CONTINUE
ELSE
*
* Compute inv(L)*A*inv(L')
*
DO 20 K = 1, N
*
* Update the lower triangle of A(k:n,k:n)
*
AKK = A( K, K )
BKK = B( K, K )
AKK = AKK / BKK**2
A( K, K ) = AKK
IF( K.LT.N ) THEN
CALL SSCAL( N-K, ONE / BKK, A( K+1, K ), 1 )
CT = -HALF*AKK
CALL SAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 )
CALL SSYR2( UPLO, N-K, -ONE, A( K+1, K ), 1,
$ B( K+1, K ), 1, A( K+1, K+1 ), LDA )
CALL SAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 )
CALL STRSV( UPLO, 'No transpose', 'Non-unit', N-K,
$ B( K+1, K+1 ), LDB, A( K+1, K ), 1 )
END IF
20 CONTINUE
END IF
ELSE
IF( UPPER ) THEN
*
* Compute U*A*U'
*
DO 30 K = 1, N
*
* Update the upper triangle of A(1:k,1:k)
*
AKK = A( K, K )
BKK = B( K, K )
CALL STRMV( UPLO, 'No transpose', 'Non-unit', K-1, B,
$ LDB, A( 1, K ), 1 )
CT = HALF*AKK
CALL SAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 )
CALL SSYR2( UPLO, K-1, ONE, A( 1, K ), 1, B( 1, K ), 1,
$ A, LDA )
CALL SAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 )
CALL SSCAL( K-1, BKK, A( 1, K ), 1 )
A( K, K ) = AKK*BKK**2
30 CONTINUE
ELSE
*
* Compute L'*A*L
*
DO 40 K = 1, N
*
* Update the lower triangle of A(1:k,1:k)
*
AKK = A( K, K )
BKK = B( K, K )
CALL STRMV( UPLO, 'Transpose', 'Non-unit', K-1, B, LDB,
$ A( K, 1 ), LDA )
CT = HALF*AKK
CALL SAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA )
CALL SSYR2( UPLO, K-1, ONE, A( K, 1 ), LDA, B( K, 1 ),
$ LDB, A, LDA )
CALL SAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA )
CALL SSCAL( K-1, BKK, A( K, 1 ), LDA )
A( K, K ) = AKK*BKK**2
40 CONTINUE
END IF
END IF
RETURN
*
* End of SSYGS2
*
END
SUBROUTINE SSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, ITYPE, LDA, LDB, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* SSYGST reduces a real symmetric-definite generalized eigenproblem
* to standard form.
*
* If ITYPE = 1, the problem is A*x = lambda*B*x,
* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)
*
* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.
*
* B must have been previously factorized as U**T*U or L*L**T by SPOTRF.
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);
* = 2 or 3: compute U*A*U**T or L**T*A*L.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored and B is factored as
* U**T*U;
* = 'L': Lower triangle of A is stored and B is factored as
* L*L**T.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the symmetric matrix A. If UPLO = 'U', the leading
* N-by-N upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading N-by-N lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced.
*
* On exit, if INFO = 0, the transformed matrix, stored in the
* same format as A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input) REAL array, dimension (LDB,N)
* The triangular factor from the Cholesky factorization of B,
* as returned by SPOTRF.
*
* 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 ..
REAL ONE, HALF
PARAMETER ( ONE = 1.0, HALF = 0.5 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER K, KB, NB
* ..
* .. External Subroutines ..
EXTERNAL SSYGS2, SSYMM, SSYR2K, STRMM, STRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
INFO = -1
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSYGST', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Determine the block size for this environment.
*
NB = ILAENV( 1, 'SSYGST', UPLO, N, -1, -1, -1 )
*
IF( NB.LE.1 .OR. NB.GE.N ) THEN
*
* Use unblocked code
*
CALL SSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
ELSE
*
* Use blocked code
*
IF( ITYPE.EQ.1 ) THEN
IF( UPPER ) THEN
*
* Compute inv(U')*A*inv(U)
*
DO 10 K = 1, N, NB
KB = MIN( N-K+1, NB )
*
* Update the upper triangle of A(k:n,k:n)
*
CALL SSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
$ B( K, K ), LDB, INFO )
IF( K+KB.LE.N ) THEN
CALL STRSM( 'Left', UPLO, 'Transpose', 'Non-unit',
$ KB, N-K-KB+1, ONE, B( K, K ), LDB,
$ A( K, K+KB ), LDA )
CALL SSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF,
$ A( K, K ), LDA, B( K, K+KB ), LDB, ONE,
$ A( K, K+KB ), LDA )
CALL SSYR2K( UPLO, 'Transpose', N-K-KB+1, KB, -ONE,
$ A( K, K+KB ), LDA, B( K, K+KB ), LDB,
$ ONE, A( K+KB, K+KB ), LDA )
CALL SSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF,
$ A( K, K ), LDA, B( K, K+KB ), LDB, ONE,
$ A( K, K+KB ), LDA )
CALL STRSM( 'Right', UPLO, 'No transpose',
$ 'Non-unit', KB, N-K-KB+1, ONE,
$ B( K+KB, K+KB ), LDB, A( K, K+KB ),
$ LDA )
END IF
10 CONTINUE
ELSE
*
* Compute inv(L)*A*inv(L')
*
DO 20 K = 1, N, NB
KB = MIN( N-K+1, NB )
*
* Update the lower triangle of A(k:n,k:n)
*
CALL SSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
$ B( K, K ), LDB, INFO )
IF( K+KB.LE.N ) THEN
CALL STRSM( 'Right', UPLO, 'Transpose', 'Non-unit',
$ N-K-KB+1, KB, ONE, B( K, K ), LDB,
$ A( K+KB, K ), LDA )
CALL SSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF,
$ A( K, K ), LDA, B( K+KB, K ), LDB, ONE,
$ A( K+KB, K ), LDA )
CALL SSYR2K( UPLO, 'No transpose', N-K-KB+1, KB,
$ -ONE, A( K+KB, K ), LDA, B( K+KB, K ),
$ LDB, ONE, A( K+KB, K+KB ), LDA )
CALL SSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF,
$ A( K, K ), LDA, B( K+KB, K ), LDB, ONE,
$ A( K+KB, K ), LDA )
CALL STRSM( 'Left', UPLO, 'No transpose',
$ 'Non-unit', N-K-KB+1, KB, ONE,
$ B( K+KB, K+KB ), LDB, A( K+KB, K ),
$ LDA )
END IF
20 CONTINUE
END IF
ELSE
IF( UPPER ) THEN
*
* Compute U*A*U'
*
DO 30 K = 1, N, NB
KB = MIN( N-K+1, NB )
*
* Update the upper triangle of A(1:k+kb-1,1:k+kb-1)
*
CALL STRMM( 'Left', UPLO, 'No transpose', 'Non-unit',
$ K-1, KB, ONE, B, LDB, A( 1, K ), LDA )
CALL SSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ),
$ LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA )
CALL SSYR2K( UPLO, 'No transpose', K-1, KB, ONE,
$ A( 1, K ), LDA, B( 1, K ), LDB, ONE, A,
$ LDA )
CALL SSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ),
$ LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA )
CALL STRMM( 'Right', UPLO, 'Transpose', 'Non-unit',
$ K-1, KB, ONE, B( K, K ), LDB, A( 1, K ),
$ LDA )
CALL SSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
$ B( K, K ), LDB, INFO )
30 CONTINUE
ELSE
*
* Compute L'*A*L
*
DO 40 K = 1, N, NB
KB = MIN( N-K+1, NB )
*
* Update the lower triangle of A(1:k+kb-1,1:k+kb-1)
*
CALL STRMM( 'Right', UPLO, 'No transpose', 'Non-unit',
$ KB, K-1, ONE, B, LDB, A( K, 1 ), LDA )
CALL SSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ),
$ LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA )
CALL SSYR2K( UPLO, 'Transpose', K-1, KB, ONE,
$ A( K, 1 ), LDA, B( K, 1 ), LDB, ONE, A,
$ LDA )
CALL SSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ),
$ LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA )
CALL STRMM( 'Left', UPLO, 'Transpose', 'Non-unit', KB,
$ K-1, ONE, B( K, K ), LDB, A( K, 1 ), LDA )
CALL SSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
$ B( K, K ), LDB, INFO )
40 CONTINUE
END IF
END IF
END IF
RETURN
*
* End of SSYGST
*
END
SUBROUTINE SSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK,
$ LWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, ITYPE, LDA, LDB, LWORK, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), W( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SSYGV computes all the eigenvalues, and optionally, the eigenvectors
* of a real generalized symmetric-definite eigenproblem, of the form
* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
* Here A and B are assumed to be symmetric and B is also
* positive definite.
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* Specifies the problem type to be solved:
* = 1: A*x = (lambda)*B*x
* = 2: A*B*x = (lambda)*x
* = 3: B*A*x = (lambda)*x
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangles of A and B are stored;
* = 'L': Lower triangles of A and B are stored.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* A (input/output) REAL array, dimension (LDA, N)
* On entry, the symmetric matrix A. If UPLO = 'U', the
* leading N-by-N upper triangular part of A contains the
* upper triangular part of the matrix A. If UPLO = 'L',
* the leading N-by-N lower triangular part of A contains
* the lower triangular part of the matrix A.
*
* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
* matrix Z of eigenvectors. The eigenvectors are normalized
* as follows:
* if ITYPE = 1 or 2, Z**T*B*Z = I;
* if ITYPE = 3, Z**T*inv(B)*Z = I.
* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
* or the lower triangle (if UPLO='L') of A, including the
* diagonal, is destroyed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input/output) REAL array, dimension (LDB, N)
* On entry, the symmetric positive definite matrix B.
* If UPLO = 'U', the leading N-by-N upper triangular part of B
* contains the upper triangular part of the matrix B.
* If UPLO = 'L', the leading N-by-N lower triangular part of B
* contains the lower triangular part of the matrix B.
*
* On exit, if INFO <= N, the part of B containing the matrix is
* overwritten by the triangular factor U or L from the Cholesky
* factorization B = U**T*U or B = L*L**T.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* W (output) REAL array, dimension (N)
* If INFO = 0, the eigenvalues in ascending order.
*
* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The length of the array WORK. LWORK >= max(1,3*N-1).
* For optimal efficiency, LWORK >= (NB+2)*N,
* where NB is the blocksize for SSYTRD returned by ILAENV.
*
* 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
* > 0: SPOTRF or SSYEV returned an error code:
* <= N: if INFO = i, SSYEV failed to converge;
* i off-diagonal elements of an intermediate
* tridiagonal form did not converge to zero;
* > N: if INFO = N + i, for 1 <= i <= N, then the leading
* minor of order i of B is not positive definite.
* The factorization of B could not be completed and
* no eigenvalues or eigenvectors were computed.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, UPPER, WANTZ
CHARACTER TRANS
INTEGER LWKMIN, LWKOPT, NB, NEIG
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL ILAENV, LSAME
* ..
* .. External Subroutines ..
EXTERNAL SPOTRF, SSYEV, SSYGST, STRMM, STRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
UPPER = LSAME( UPLO, 'U' )
LQUERY = ( LWORK.EQ.-1 )
*
INFO = 0
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
INFO = -1
ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -2
ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
*
IF( INFO.EQ.0 ) THEN
LWKMIN = MAX( 1, 3*N - 1 )
NB = ILAENV( 1, 'SSYTRD', UPLO, N, -1, -1, -1 )
LWKOPT = MAX( LWKMIN, ( NB + 2 )*N )
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
INFO = -11
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSYGV ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Form a Cholesky factorization of B.
*
CALL SPOTRF( UPLO, N, B, LDB, INFO )
IF( INFO.NE.0 ) THEN
INFO = N + INFO
RETURN
END IF
*
* Transform problem to standard eigenvalue problem and solve.
*
CALL SSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
CALL SSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )
*
IF( WANTZ ) THEN
*
* Backtransform eigenvectors to the original problem.
*
NEIG = N
IF( INFO.GT.0 )
$ NEIG = INFO - 1
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
*
* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
*
IF( UPPER ) THEN
TRANS = 'N'
ELSE
TRANS = 'T'
END IF
*
CALL STRSM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE,
$ B, LDB, A, LDA )
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* For B*A*x=(lambda)*x;
* backtransform eigenvectors: x = L*y or U'*y
*
IF( UPPER ) THEN
TRANS = 'T'
ELSE
TRANS = 'N'
END IF
*
CALL STRMM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE,
$ B, LDB, A, LDA )
END IF
END IF
*
WORK( 1 ) = LWKOPT
RETURN
*
* End of SSYGV
*
END
SUBROUTINE SSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK,
$ LWORK, IWORK, LIWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, ITYPE, LDA, LDB, LIWORK, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL A( LDA, * ), B( LDB, * ), W( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SSYGVD computes all the eigenvalues, and optionally, the eigenvectors
* of a real generalized symmetric-definite eigenproblem, of the form
* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
* B are assumed to be symmetric and B is also positive definite.
* If eigenvectors are desired, it uses a divide and conquer algorithm.
*
* The divide and conquer algorithm makes very mild assumptions about
* floating point arithmetic. It will work on machines with a guard
* digit in add/subtract, or on those binary machines without guard
* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
* Cray-2. It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* Specifies the problem type to be solved:
* = 1: A*x = (lambda)*B*x
* = 2: A*B*x = (lambda)*x
* = 3: B*A*x = (lambda)*x
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangles of A and B are stored;
* = 'L': Lower triangles of A and B are stored.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* A (input/output) REAL array, dimension (LDA, N)
* On entry, the symmetric matrix A. If UPLO = 'U', the
* leading N-by-N upper triangular part of A contains the
* upper triangular part of the matrix A. If UPLO = 'L',
* the leading N-by-N lower triangular part of A contains
* the lower triangular part of the matrix A.
*
* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
* matrix Z of eigenvectors. The eigenvectors are normalized
* as follows:
* if ITYPE = 1 or 2, Z**T*B*Z = I;
* if ITYPE = 3, Z**T*inv(B)*Z = I.
* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
* or the lower triangle (if UPLO='L') of A, including the
* diagonal, is destroyed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input/output) REAL array, dimension (LDB, N)
* On entry, the symmetric matrix B. If UPLO = 'U', the
* leading N-by-N upper triangular part of B contains the
* upper triangular part of the matrix B. If UPLO = 'L',
* the leading N-by-N lower triangular part of B contains
* the lower triangular part of the matrix B.
*
* On exit, if INFO <= N, the part of B containing the matrix is
* overwritten by the triangular factor U or L from the Cholesky
* factorization B = U**T*U or B = L*L**T.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* W (output) REAL array, dimension (N)
* If INFO = 0, the eigenvalues in ascending order.
*
* WORK (workspace/output) REAL 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 N <= 1, LWORK >= 1.
* If JOBZ = 'N' and N > 1, LWORK >= 2*N+1.
* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal sizes of the WORK and IWORK
* arrays, returns these values as the first entries of the WORK
* and IWORK arrays, and no error message related to LWORK or
* LIWORK is issued by XERBLA.
*
* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK.
* If N <= 1, LIWORK >= 1.
* If JOBZ = 'N' and N > 1, LIWORK >= 1.
* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal sizes of the WORK and
* IWORK arrays, returns these values as the first entries of
* the WORK and IWORK arrays, and no error message related to
* LWORK or LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: SPOTRF or SSYEVD returned an error code:
* <= N: if INFO = i and JOBZ = 'N', then the algorithm
* failed to converge; i off-diagonal elements of an
* intermediate tridiagonal form did not converge to
* zero;
* if INFO = i and JOBZ = 'V', then the algorithm
* failed to compute an eigenvalue while working on
* the submatrix lying in rows and columns INFO/(N+1)
* through mod(INFO,N+1);
* > N: if INFO = N + i, for 1 <= i <= N, then the leading
* minor of order i of B is not positive definite.
* The factorization of B could not be completed and
* no eigenvalues or eigenvectors were computed.
*
* Further Details
* ===============
*
* Based on contributions by
* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
*
* Modified so that no backsubstitution is performed if SSYEVD fails to
* converge (NEIG in old code could be greater than N causing out of
* bounds reference to A - reported by Ralf Meyer). Also corrected the
* description of INFO and the test on ITYPE. Sven, 16 Feb 05.
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, UPPER, WANTZ
CHARACTER TRANS
INTEGER LIOPT, LIWMIN, LOPT, LWMIN
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SPOTRF, SSYEVD, SSYGST, STRMM, STRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, REAL
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
UPPER = LSAME( UPLO, 'U' )
LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
INFO = 0
IF( N.LE.1 ) THEN
LIWMIN = 1
LWMIN = 1
ELSE IF( WANTZ ) THEN
LIWMIN = 3 + 5*N
LWMIN = 1 + 6*N + 2*N**2
ELSE
LIWMIN = 1
LWMIN = 2*N + 1
END IF
LOPT = LWMIN
LIOPT = LIWMIN
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
INFO = -1
ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -2
ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
*
IF( INFO.EQ.0 ) THEN
WORK( 1 ) = LOPT
IWORK( 1 ) = LIOPT
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -11
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSYGVD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Form a Cholesky factorization of B.
*
CALL SPOTRF( UPLO, N, B, LDB, INFO )
IF( INFO.NE.0 ) THEN
INFO = N + INFO
RETURN
END IF
*
* Transform problem to standard eigenvalue problem and solve.
*
CALL SSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
CALL SSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, LIWORK,
$ INFO )
LOPT = MAX( REAL( LOPT ), REAL( WORK( 1 ) ) )
LIOPT = MAX( REAL( LIOPT ), REAL( IWORK( 1 ) ) )
*
IF( WANTZ .AND. INFO.EQ.0 ) THEN
*
* Backtransform eigenvectors to the original problem.
*
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
*
* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
*
IF( UPPER ) THEN
TRANS = 'N'
ELSE
TRANS = 'T'
END IF
*
CALL STRSM( 'Left', UPLO, TRANS, 'Non-unit', N, N, ONE,
$ B, LDB, A, LDA )
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* For B*A*x=(lambda)*x;
* backtransform eigenvectors: x = L*y or U'*y
*
IF( UPPER ) THEN
TRANS = 'T'
ELSE
TRANS = 'N'
END IF
*
CALL STRMM( 'Left', UPLO, TRANS, 'Non-unit', N, N, ONE,
$ B, LDB, A, LDA )
END IF
END IF
*
WORK( 1 ) = LOPT
IWORK( 1 ) = LIOPT
*
RETURN
*
* End of SSYGVD
*
END
SUBROUTINE SSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB,
$ VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK,
$ LWORK, IWORK, IFAIL, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE, UPLO
INTEGER IL, INFO, ITYPE, IU, LDA, LDB, LDZ, LWORK, M, N
REAL ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER IFAIL( * ), IWORK( * )
REAL A( LDA, * ), B( LDB, * ), W( * ), WORK( * ),
$ Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SSYGVX computes selected eigenvalues, and optionally, eigenvectors
* of a real generalized symmetric-definite eigenproblem, of the form
* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A
* and B are assumed to be symmetric and B is also positive definite.
* Eigenvalues and eigenvectors can be selected by specifying either a
* range of values or a range of indices for the desired eigenvalues.
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* Specifies the problem type to be solved:
* = 1: A*x = (lambda)*B*x
* = 2: A*B*x = (lambda)*x
* = 3: B*A*x = (lambda)*x
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* RANGE (input) CHARACTER*1
* = 'A': all eigenvalues will be found.
* = 'V': all eigenvalues in the half-open interval (VL,VU]
* will be found.
* = 'I': the IL-th through IU-th eigenvalues will be found.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A and B are stored;
* = 'L': Lower triangle of A and B are stored.
*
* N (input) INTEGER
* The order of the matrix pencil (A,B). N >= 0.
*
* A (input/output) REAL array, dimension (LDA, N)
* On entry, the symmetric matrix A. If UPLO = 'U', the
* leading N-by-N upper triangular part of A contains the
* upper triangular part of the matrix A. If UPLO = 'L',
* the leading N-by-N lower triangular part of A contains
* the lower triangular part of the matrix A.
*
* On exit, the lower triangle (if UPLO='L') or the upper
* triangle (if UPLO='U') of A, including the diagonal, is
* destroyed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input/output) REAL array, dimension (LDA, N)
* On entry, the symmetric matrix B. If UPLO = 'U', the
* leading N-by-N upper triangular part of B contains the
* upper triangular part of the matrix B. If UPLO = 'L',
* the leading N-by-N lower triangular part of B contains
* the lower triangular part of the matrix B.
*
* On exit, if INFO <= N, the part of B containing the matrix is
* overwritten by the triangular factor U or L from the Cholesky
* factorization B = U**T*U or B = L*L**T.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* VL (input) REAL
* VU (input) REAL
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* ABSTOL (input) REAL
* The absolute error tolerance for the eigenvalues.
* An approximate eigenvalue is accepted as converged
* when it is determined to lie in an interval [a,b]
* of width less than or equal to
*
* ABSTOL + EPS * max( |a|,|b| ) ,
*
* where EPS is the machine precision. If ABSTOL is less than
* or equal to zero, then EPS*|T| will be used in its place,
* where |T| is the 1-norm of the tridiagonal matrix obtained
* by reducing A to tridiagonal form.
*
* Eigenvalues will be computed most accurately when ABSTOL is
* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
* If this routine returns with INFO>0, indicating that some
* eigenvectors did not converge, try setting ABSTOL to
* 2*SLAMCH('S').
*
* M (output) INTEGER
* The total number of eigenvalues found. 0 <= M <= N.
* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*
* W (output) REAL array, dimension (N)
* On normal exit, the first M elements contain the selected
* eigenvalues in ascending order.
*
* Z (output) REAL array, dimension (LDZ, max(1,M))
* If JOBZ = 'N', then Z is not referenced.
* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
* contain the orthonormal eigenvectors of the matrix A
* corresponding to the selected eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* The eigenvectors are normalized as follows:
* if ITYPE = 1 or 2, Z**T*B*Z = I;
* if ITYPE = 3, Z**T*inv(B)*Z = I.
*
* If an eigenvector fails to converge, then that column of Z
* contains the latest approximation to the eigenvector, and the
* index of the eigenvector is returned in IFAIL.
* Note: the user must ensure that at least max(1,M) columns are
* supplied in the array Z; if RANGE = 'V', the exact value of M
* is not known in advance and an upper bound must be used.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The length of the array WORK. LWORK >= max(1,8*N).
* For optimal efficiency, LWORK >= (NB+3)*N,
* where NB is the blocksize for SSYTRD returned by ILAENV.
*
* 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.
*
* IWORK (workspace) INTEGER array, dimension (5*N)
*
* IFAIL (output) INTEGER array, dimension (N)
* If JOBZ = 'V', then if INFO = 0, the first M elements of
* IFAIL are zero. If INFO > 0, then IFAIL contains the
* indices of the eigenvectors that failed to converge.
* If JOBZ = 'N', then IFAIL is not referenced.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: SPOTRF or SSYEVX returned an error code:
* <= N: if INFO = i, SSYEVX failed to converge;
* i eigenvectors failed to converge. Their indices
* are stored in array IFAIL.
* > N: if INFO = N + i, for 1 <= i <= N, then the leading
* minor of order i of B is not positive definite.
* The factorization of B could not be completed and
* no eigenvalues or eigenvectors were computed.
*
* Further Details
* ===============
*
* Based on contributions by
* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, LQUERY, UPPER, VALEIG, WANTZ
CHARACTER TRANS
INTEGER LWKMIN, LWKOPT, NB
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL ILAENV, LSAME
* ..
* .. External Subroutines ..
EXTERNAL SPOTRF, SSYEVX, SSYGST, STRMM, STRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
UPPER = LSAME( UPLO, 'U' )
WANTZ = LSAME( JOBZ, 'V' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
LQUERY = ( LWORK.EQ.-1 )
*
INFO = 0
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
INFO = -1
ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -2
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
INFO = -3
ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE
IF( VALEIG ) THEN
IF( N.GT.0 .AND. VU.LE.VL )
$ INFO = -11
ELSE IF( INDEIG ) THEN
IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
INFO = -12
ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
INFO = -13
END IF
END IF
END IF
IF (INFO.EQ.0) THEN
IF (LDZ.LT.1 .OR. (WANTZ .AND. LDZ.LT.N)) THEN
INFO = -18
END IF
END IF
*
IF( INFO.EQ.0 ) THEN
LWKMIN = MAX( 1, 8*N )
NB = ILAENV( 1, 'SSYTRD', UPLO, N, -1, -1, -1 )
LWKOPT = MAX( LWKMIN, ( NB + 3 )*N )
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
INFO = -20
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSYGVX', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 ) THEN
RETURN
END IF
*
* Form a Cholesky factorization of B.
*
CALL SPOTRF( UPLO, N, B, LDB, INFO )
IF( INFO.NE.0 ) THEN
INFO = N + INFO
RETURN
END IF
*
* Transform problem to standard eigenvalue problem and solve.
*
CALL SSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
CALL SSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL,
$ M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO )
*
IF( WANTZ ) THEN
*
* Backtransform eigenvectors to the original problem.
*
IF( INFO.GT.0 )
$ M = INFO - 1
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
*
* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
*
IF( UPPER ) THEN
TRANS = 'N'
ELSE
TRANS = 'T'
END IF
*
CALL STRSM( 'Left', UPLO, TRANS, 'Non-unit', N, M, ONE, B,
$ LDB, Z, LDZ )
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* For B*A*x=(lambda)*x;
* backtransform eigenvectors: x = L*y or U'*y
*
IF( UPPER ) THEN
TRANS = 'T'
ELSE
TRANS = 'N'
END IF
*
CALL STRMM( 'Left', UPLO, TRANS, 'Non-unit', N, M, ONE, B,
$ LDB, Z, LDZ )
END IF
END IF
*
* Set WORK(1) to optimal workspace size.
*
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of SSYGVX
*
END
SUBROUTINE SSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB,
$ X, LDX, FERR, BERR, WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), IWORK( * )
REAL A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
$ BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* SSYRFS improves the computed solution to a system of linear
* equations when the coefficient matrix is symmetric indefinite, and
* provides error bounds and backward error estimates for the solution.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* 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 matrices B and X. NRHS >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
* upper triangular part of A contains the upper triangular part
* of the matrix A, and the strictly lower triangular part of A
* is not referenced. If UPLO = 'L', the leading N-by-N lower
* triangular part of A contains the lower triangular part of
* the matrix A, and the strictly upper triangular part of A is
* not referenced.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* AF (input) REAL array, dimension (LDAF,N)
* The factored form of the matrix A. AF contains the block
* diagonal matrix D and the multipliers used to obtain the
* factor U or L from the factorization A = U*D*U**T or
* A = L*D*L**T as computed by SSYTRF.
*
* LDAF (input) INTEGER
* The leading dimension of the array AF. LDAF >= max(1,N).
*
* IPIV (input) INTEGER array, dimension (N)
* Details of the interchanges and the block structure of D
* as determined by SSYTRF.
*
* B (input) REAL array, dimension (LDB,NRHS)
* The right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input/output) REAL array, dimension (LDX,NRHS)
* On entry, the solution matrix X, as computed by SSYTRS.
* On exit, the improved solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* FERR (output) REAL array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) REAL array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Internal Parameters
* ===================
*
* ITMAX is the maximum number of steps of iterative refinement.
*
* =====================================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 5 )
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
REAL TWO
PARAMETER ( TWO = 2.0E+0 )
REAL THREE
PARAMETER ( THREE = 3.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER COUNT, I, J, K, KASE, NZ
REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, SLACN2, SSYMV, SSYTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH
EXTERNAL LSAME, SLAMCH
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) 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( LDAF.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -10
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSYRFS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
DO 10 J = 1, NRHS
FERR( J ) = ZERO
BERR( J ) = ZERO
10 CONTINUE
RETURN
END IF
*
* NZ = maximum number of nonzero elements in each row of A, plus 1
*
NZ = N + 1
EPS = SLAMCH( 'Epsilon' )
SAFMIN = SLAMCH( 'Safe minimum' )
SAFE1 = NZ*SAFMIN
SAFE2 = SAFE1 / EPS
*
* Do for each right hand side
*
DO 140 J = 1, NRHS
*
COUNT = 1
LSTRES = THREE
20 CONTINUE
*
* Loop until stopping criterion is satisfied.
*
* Compute residual R = B - A * X
*
CALL SCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
CALL SSYMV( UPLO, N, -ONE, A, LDA, X( 1, J ), 1, ONE,
$ WORK( N+1 ), 1 )
*
* Compute componentwise relative backward error from formula
*
* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
*
* where abs(Z) is the componentwise absolute value of the matrix
* or vector Z. If the i-th component of the denominator is less
* than SAFE2, then SAFE1 is added to the i-th components of the
* numerator and denominator before dividing.
*
DO 30 I = 1, N
WORK( I ) = ABS( B( I, J ) )
30 CONTINUE
*
* Compute abs(A)*abs(X) + abs(B).
*
IF( UPPER ) THEN
DO 50 K = 1, N
S = ZERO
XK = ABS( X( K, J ) )
DO 40 I = 1, K - 1
WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
40 CONTINUE
WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK + S
50 CONTINUE
ELSE
DO 70 K = 1, N
S = ZERO
XK = ABS( X( K, J ) )
WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK
DO 60 I = K + 1, N
WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
60 CONTINUE
WORK( K ) = WORK( K ) + S
70 CONTINUE
END IF
S = ZERO
DO 80 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
ELSE
S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
$ ( WORK( I )+SAFE1 ) )
END IF
80 CONTINUE
BERR( J ) = S
*
* Test stopping criterion. Continue iterating if
* 1) The residual BERR(J) is larger than machine epsilon, and
* 2) BERR(J) decreased by at least a factor of 2 during the
* last iteration, and
* 3) At most ITMAX iterations tried.
*
IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
$ COUNT.LE.ITMAX ) THEN
*
* Update solution and try again.
*
CALL SSYTRS( UPLO, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
$ INFO )
CALL SAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
LSTRES = BERR( J )
COUNT = COUNT + 1
GO TO 20
END IF
*
* Bound error from formula
*
* norm(X - XTRUE) / norm(X) .le. FERR =
* norm( abs(inv(A))*
* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
*
* where
* norm(Z) is the magnitude of the largest component of Z
* inv(A) is the inverse of A
* abs(Z) is the componentwise absolute value of the matrix or
* vector Z
* NZ is the maximum number of nonzeros in any row of A, plus 1
* EPS is machine epsilon
*
* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
* is incremented by SAFE1 if the i-th component of
* abs(A)*abs(X) + abs(B) is less than SAFE2.
*
* Use SLACN2 to estimate the infinity-norm of the matrix
* inv(A) * diag(W),
* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
*
DO 90 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
ELSE
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
END IF
90 CONTINUE
*
KASE = 0
100 CONTINUE
CALL SLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
$ KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Multiply by diag(W)*inv(A').
*
CALL SSYTRS( UPLO, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
$ INFO )
DO 110 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
110 CONTINUE
ELSE IF( KASE.EQ.2 ) THEN
*
* Multiply by inv(A)*diag(W).
*
DO 120 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
120 CONTINUE
CALL SSYTRS( UPLO, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
$ INFO )
END IF
GO TO 100
END IF
*
* Normalize error.
*
LSTRES = ZERO
DO 130 I = 1, N
LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
130 CONTINUE
IF( LSTRES.NE.ZERO )
$ FERR( J ) = FERR( J ) / LSTRES
*
140 CONTINUE
*
RETURN
*
* End of SSYRFS
*
END
SUBROUTINE SSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK,
$ LWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LDB, LWORK, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
REAL A( LDA, * ), B( LDB, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SSYSV computes the solution to a real system of linear equations
* A * X = B,
* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
* matrices.
*
* The diagonal pivoting method is used to factor A as
* A = U * D * U**T, if UPLO = 'U', or
* A = L * D * L**T, if UPLO = 'L',
* where U (or L) is a product of permutation and unit upper (lower)
* triangular matrices, and D is symmetric and block diagonal with
* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then
* used to solve the system of equations A * X = B.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The number of linear equations, i.e., 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/output) REAL array, dimension (LDA,N)
* On entry, the symmetric matrix A. If UPLO = 'U', the leading
* N-by-N upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading N-by-N lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced.
*
* On exit, if INFO = 0, the block diagonal matrix D and the
* multipliers used to obtain the factor U or L from the
* factorization A = U*D*U**T or A = L*D*L**T as computed by
* SSYTRF.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* IPIV (output) INTEGER array, dimension (N)
* Details of the interchanges and the block structure of D, as
* determined by SSYTRF. If IPIV(k) > 0, then rows and columns
* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1
* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,
* then rows and columns k-1 and -IPIV(k) were interchanged and
* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and
* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and
* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2
* diagonal block.
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the N-by-NRHS right hand side matrix B.
* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The length of WORK. LWORK >= 1, and for best performance
* LWORK >= max(1,N*NB), where NB is the optimal blocksize for
* SSYTRF.
*
* 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
* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
* has been completed, but the block diagonal matrix D is
* exactly singular, so the solution could not be computed.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER LWKOPT, NB
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL ILAENV, LSAME
* ..
* .. External Subroutines ..
EXTERNAL SSYTRF, SSYTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) 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
ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
INFO = -10
END IF
*
IF( INFO.EQ.0 ) THEN
IF( N.EQ.0 ) THEN
LWKOPT = 1
ELSE
NB = ILAENV( 1, 'SSYTRF', UPLO, N, -1, -1, -1 )
LWKOPT = N*NB
END IF
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSYSV ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Compute the factorization A = U*D*U' or A = L*D*L'.
*
CALL SSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
IF( INFO.EQ.0 ) THEN
*
* Solve the system A*X = B, overwriting B with X.
*
CALL SSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
END IF
*
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of SSYSV
*
END
SUBROUTINE SSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B,
$ LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK,
$ IWORK, INFO )
*
* -- LAPACK driver routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER FACT, UPLO
INTEGER INFO, LDA, LDAF, LDB, LDX, LWORK, N, NRHS
REAL RCOND
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), IWORK( * )
REAL A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
$ BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* SSYSVX uses the diagonal pivoting factorization to compute the
* solution to a real system of linear equations A * X = B,
* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
* matrices.
*
* Error bounds on the solution and a condition estimate are also
* provided.
*
* Description
* ===========
*
* The following steps are performed:
*
* 1. If FACT = 'N', the diagonal pivoting method is used to factor A.
* The form of the factorization is
* A = U * D * U**T, if UPLO = 'U', or
* A = L * D * L**T, if UPLO = 'L',
* where U (or L) is a product of permutation and unit upper (lower)
* triangular matrices, and D is symmetric and block diagonal with
* 1-by-1 and 2-by-2 diagonal blocks.
*
* 2. If some D(i,i)=0, so that D is exactly singular, then the routine
* returns with INFO = i. Otherwise, the factored form of A is used
* to estimate the condition number of the matrix A. If the
* reciprocal of the condition number is less than machine precision,
* INFO = N+1 is returned as a warning, but the routine still goes on
* to solve for X and compute error bounds as described below.
*
* 3. The system of equations is solved for X using the factored form
* of A.
*
* 4. Iterative refinement is applied to improve the computed solution
* matrix and calculate error bounds and backward error estimates
* for it.
*
* Arguments
* =========
*
* FACT (input) CHARACTER*1
* Specifies whether or not the factored form of A has been
* supplied on entry.
* = 'F': On entry, AF and IPIV contain the factored form of
* A. AF and IPIV will not be modified.
* = 'N': The matrix A will be copied to AF and factored.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The number of linear equations, i.e., 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 matrices B and X. NRHS >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
* upper triangular part of A contains the upper triangular part
* of the matrix A, and the strictly lower triangular part of A
* is not referenced. If UPLO = 'L', the leading N-by-N lower
* triangular part of A contains the lower triangular part of
* the matrix A, and the strictly upper triangular part of A is
* not referenced.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* AF (input or output) REAL array, dimension (LDAF,N)
* If FACT = 'F', then AF is an input argument and on entry
* contains the block diagonal matrix D and the multipliers used
* to obtain the factor U or L from the factorization
* A = U*D*U**T or A = L*D*L**T as computed by SSYTRF.
*
* If FACT = 'N', then AF is an output argument and on exit
* returns the block diagonal matrix D and the multipliers used
* to obtain the factor U or L from the factorization
* A = U*D*U**T or A = L*D*L**T.
*
* LDAF (input) INTEGER
* The leading dimension of the array AF. LDAF >= max(1,N).
*
* IPIV (input or output) INTEGER array, dimension (N)
* If FACT = 'F', then IPIV is an input argument and on entry
* contains details of the interchanges and the block structure
* of D, as determined by SSYTRF.
* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
* interchanged and D(k,k) is a 1-by-1 diagonal block.
* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*
* If FACT = 'N', then IPIV is an output argument and on exit
* contains details of the interchanges and the block structure
* of D, as determined by SSYTRF.
*
* B (input) REAL array, dimension (LDB,NRHS)
* The N-by-NRHS right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (output) REAL array, dimension (LDX,NRHS)
* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* RCOND (output) REAL
* The estimate of the reciprocal condition number of the matrix
* A. If RCOND is less than the machine precision (in
* particular, if RCOND = 0), the matrix is singular to working
* precision. This condition is indicated by a return code of
* INFO > 0.
*
* FERR (output) REAL array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The length of WORK. LWORK >= max(1,3*N), and for best
* performance, when FACT = 'N', LWORK >= max(1,3*N,N*NB), where
* NB is the optimal blocksize for SSYTRF.
*
* 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.
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, and i is
* <= N: D(i,i) is exactly zero. The factorization
* has been completed but the factor D is exactly
* singular, so the solution and error bounds could
* not be computed. RCOND = 0 is returned.
* = N+1: D is nonsingular, but RCOND is less than machine
* precision, meaning that the matrix is singular
* to working precision. Nevertheless, the
* solution and error bounds are computed because
* there are a number of situations where the
* computed solution can be more accurate than the
* value of RCOND would suggest.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, NOFACT
INTEGER LWKOPT, NB
REAL ANORM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
REAL SLAMCH, SLANSY
EXTERNAL ILAENV, LSAME, SLAMCH, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL SLACPY, SSYCON, SSYRFS, SSYTRF, SSYTRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
NOFACT = LSAME( FACT, 'N' )
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
INFO = -1
ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
$ THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -11
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -13
ELSE IF( LWORK.LT.MAX( 1, 3*N ) .AND. .NOT.LQUERY ) THEN
INFO = -18
END IF
*
IF( INFO.EQ.0 ) THEN
LWKOPT = MAX( 1, 3*N )
IF( NOFACT ) THEN
NB = ILAENV( 1, 'SSYTRF', UPLO, N, -1, -1, -1 )
LWKOPT = MAX( LWKOPT, N*NB )
END IF
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSYSVX', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
IF( NOFACT ) THEN
*
* Compute the factorization A = U*D*U' or A = L*D*L'.
*
CALL SLACPY( UPLO, N, N, A, LDA, AF, LDAF )
CALL SSYTRF( UPLO, N, AF, LDAF, IPIV, WORK, LWORK, INFO )
*
* Return if INFO is non-zero.
*
IF( INFO.GT.0 )THEN
RCOND = ZERO
RETURN
END IF
END IF
*
* Compute the norm of the matrix A.
*
ANORM = SLANSY( 'I', UPLO, N, A, LDA, WORK )
*
* Compute the reciprocal of the condition number of A.
*
CALL SSYCON( UPLO, N, AF, LDAF, IPIV, ANORM, RCOND, WORK, IWORK,
$ INFO )
*
* Compute the solution vectors X.
*
CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
CALL SSYTRS( UPLO, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO )
*
* Use iterative refinement to improve the computed solutions and
* compute error bounds and backward error estimates for them.
*
CALL SSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X,
$ LDX, FERR, BERR, WORK, IWORK, INFO )
*
* Set INFO = N+1 if the matrix is singular to working precision.
*
IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
$ INFO = N + 1
*
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of SSYSVX
*
END
SUBROUTINE SSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), D( * ), E( * ), TAU( * )
* ..
*
* Purpose
* =======
*
* SSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal
* form T by an orthogonal similarity transformation: Q' * A * Q = T.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the symmetric matrix A. If UPLO = 'U', the leading
* n-by-n upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading n-by-n lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced.
* On exit, if UPLO = 'U', the diagonal and first superdiagonal
* of A are overwritten by the corresponding elements of the
* tridiagonal matrix T, and the elements above the first
* superdiagonal, with the array TAU, represent the orthogonal
* matrix Q as a product of elementary reflectors; if UPLO
* = 'L', the diagonal and first subdiagonal of A are over-
* written by the corresponding elements of the tridiagonal
* matrix T, and the elements below the first subdiagonal, 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,N).
*
* D (output) REAL array, dimension (N)
* The diagonal elements of the tridiagonal matrix T:
* D(i) = A(i,i).
*
* E (output) REAL array, dimension (N-1)
* The off-diagonal elements of the tridiagonal matrix T:
* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
*
* TAU (output) REAL array, dimension (N-1)
* The scalar factors of the elementary reflectors (see Further
* Details).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* If UPLO = 'U', the matrix Q is represented as a product of elementary
* reflectors
*
* Q = H(n-1) . . . H(2) H(1).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a real scalar, and v is a real vector with
* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
* A(1:i-1,i+1), and tau in TAU(i).
*
* If UPLO = 'L', the matrix Q is represented as a product of elementary
* reflectors
*
* Q = H(1) H(2) . . . H(n-1).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a real scalar, and v is a real vector with
* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
* and tau in TAU(i).
*
* The contents of A on exit are illustrated by the following examples
* with n = 5:
*
* if UPLO = 'U': if UPLO = 'L':
*
* ( d e v2 v3 v4 ) ( d )
* ( d e v3 v4 ) ( e d )
* ( d e v4 ) ( v1 e d )
* ( d e ) ( v1 v2 e d )
* ( d ) ( v1 v2 v3 e d )
*
* where d and e denote diagonal and off-diagonal elements of T, and vi
* denotes an element of the vector defining H(i).
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO, HALF
PARAMETER ( ONE = 1.0, ZERO = 0.0, HALF = 1.0 / 2.0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I
REAL ALPHA, TAUI
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SLARFG, SSYMV, SSYR2, XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SDOT
EXTERNAL LSAME, SDOT
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSYTD2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Reduce the upper triangle of A
*
DO 10 I = N - 1, 1, -1
*
* Generate elementary reflector H(i) = I - tau * v * v'
* to annihilate A(1:i-1,i+1)
*
CALL SLARFG( I, A( I, I+1 ), A( 1, I+1 ), 1, TAUI )
E( I ) = A( I, I+1 )
*
IF( TAUI.NE.ZERO ) THEN
*
* Apply H(i) from both sides to A(1:i,1:i)
*
A( I, I+1 ) = ONE
*
* Compute x := tau * A * v storing x in TAU(1:i)
*
CALL SSYMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO,
$ TAU, 1 )
*
* Compute w := x - 1/2 * tau * (x'*v) * v
*
ALPHA = -HALF*TAUI*SDOT( I, TAU, 1, A( 1, I+1 ), 1 )
CALL SAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 )
*
* Apply the transformation as a rank-2 update:
* A := A - v * w' - w * v'
*
CALL SSYR2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A,
$ LDA )
*
A( I, I+1 ) = E( I )
END IF
D( I+1 ) = A( I+1, I+1 )
TAU( I ) = TAUI
10 CONTINUE
D( 1 ) = A( 1, 1 )
ELSE
*
* Reduce the lower triangle of A
*
DO 20 I = 1, N - 1
*
* Generate elementary reflector H(i) = I - tau * v * v'
* to annihilate A(i+2:n,i)
*
CALL SLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1,
$ TAUI )
E( I ) = A( I+1, I )
*
IF( TAUI.NE.ZERO ) THEN
*
* Apply H(i) from both sides to A(i+1:n,i+1:n)
*
A( I+1, I ) = ONE
*
* Compute x := tau * A * v storing y in TAU(i:n-1)
*
CALL SSYMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA,
$ A( I+1, I ), 1, ZERO, TAU( I ), 1 )
*
* Compute w := x - 1/2 * tau * (x'*v) * v
*
ALPHA = -HALF*TAUI*SDOT( N-I, TAU( I ), 1, A( I+1, I ),
$ 1 )
CALL SAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 )
*
* Apply the transformation as a rank-2 update:
* A := A - v * w' - w * v'
*
CALL SSYR2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1,
$ A( I+1, I+1 ), LDA )
*
A( I+1, I ) = E( I )
END IF
D( I ) = A( I, I )
TAU( I ) = TAUI
20 CONTINUE
D( N ) = A( N, N )
END IF
*
RETURN
*
* End of SSYTD2
*
END
SUBROUTINE SSYTF2( UPLO, N, A, LDA, IPIV, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
REAL A( LDA, * )
* ..
*
* Purpose
* =======
*
* SSYTF2 computes the factorization of a real symmetric matrix A using
* the Bunch-Kaufman diagonal pivoting method:
*
* A = U*D*U' or A = L*D*L'
*
* where U (or L) is a product of permutation and unit upper (lower)
* triangular matrices, U' is the transpose of U, and D is symmetric and
* block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
*
* This is the unblocked version of the algorithm, calling Level 2 BLAS.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the symmetric matrix A. If UPLO = 'U', the leading
* n-by-n upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading n-by-n lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced.
*
* On exit, the block diagonal matrix D and the multipliers used
* to obtain the factor U or L (see below for further details).
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* IPIV (output) INTEGER array, dimension (N)
* Details of the interchanges and the block structure of D.
* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
* interchanged and D(k,k) is a 1-by-1 diagonal block.
* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
* > 0: if INFO = k, D(k,k) is exactly zero. The factorization
* has been completed, but the block diagonal matrix D is
* exactly singular, and division by zero will occur if it
* is used to solve a system of equations.
*
* Further Details
* ===============
*
* 09-29-06 - patch from
* Bobby Cheng, MathWorks
*
* Replace l.204 and l.372
* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
* by
* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN
*
* 01-01-96 - Based on modifications by
* J. Lewis, Boeing Computer Services Company
* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
* 1-96 - Based on modifications by J. Lewis, Boeing Computer Services
* Company
*
* If UPLO = 'U', then A = U*D*U', where
* U = P(n)*U(n)* ... *P(k)U(k)* ...,
* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
* that if the diagonal block D(k) is of order s (s = 1 or 2), then
*
* ( I v 0 ) k-s
* U(k) = ( 0 I 0 ) s
* ( 0 0 I ) n-k
* k-s s n-k
*
* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
* and A(k,k), and v overwrites A(1:k-2,k-1:k).
*
* If UPLO = 'L', then A = L*D*L', where
* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
* that if the diagonal block D(k) is of order s (s = 1 or 2), then
*
* ( I 0 0 ) k-1
* L(k) = ( 0 I 0 ) s
* ( 0 v I ) n-k-s+1
* k-1 s n-k-s+1
*
* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
REAL EIGHT, SEVTEN
PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, IMAX, J, JMAX, K, KK, KP, KSTEP
REAL ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, R1,
$ ROWMAX, T, WK, WKM1, WKP1
* ..
* .. External Functions ..
LOGICAL LSAME, SISNAN
INTEGER ISAMAX
EXTERNAL LSAME, ISAMAX, SISNAN
* ..
* .. External Subroutines ..
EXTERNAL SSCAL, SSWAP, SSYR, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSYTF2', -INFO )
RETURN
END IF
*
* Initialize ALPHA for use in choosing pivot block size.
*
ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
*
IF( UPPER ) THEN
*
* Factorize A as U*D*U' using the upper triangle of A
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2
*
K = N
10 CONTINUE
*
* If K < 1, exit from loop
*
IF( K.LT.1 )
$ GO TO 70
KSTEP = 1
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = ABS( A( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value
*
IF( K.GT.1 ) THEN
IMAX = ISAMAX( K-1, A( 1, K ), 1 )
COLMAX = ABS( A( IMAX, K ) )
ELSE
COLMAX = ZERO
END IF
*
IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN
*
* Column K is zero or contains a NaN: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
ELSE
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value
*
JMAX = IMAX + ISAMAX( K-IMAX, A( IMAX, IMAX+1 ), LDA )
ROWMAX = ABS( A( IMAX, JMAX ) )
IF( IMAX.GT.1 ) THEN
JMAX = ISAMAX( IMAX-1, A( 1, IMAX ), 1 )
ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) )
END IF
*
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN
*
* interchange rows and columns K and IMAX, use 1-by-1
* pivot block
*
KP = IMAX
ELSE
*
* interchange rows and columns K-1 and IMAX, use 2-by-2
* pivot block
*
KP = IMAX
KSTEP = 2
END IF
END IF
*
KK = K - KSTEP + 1
IF( KP.NE.KK ) THEN
*
* Interchange rows and columns KK and KP in the leading
* submatrix A(1:k,1:k)
*
CALL SSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
CALL SSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ),
$ LDA )
T = A( KK, KK )
A( KK, KK ) = A( KP, KP )
A( KP, KP ) = T
IF( KSTEP.EQ.2 ) THEN
T = A( K-1, K )
A( K-1, K ) = A( KP, K )
A( KP, K ) = T
END IF
END IF
*
* Update the leading submatrix
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column k now holds
*
* W(k) = U(k)*D(k)
*
* where U(k) is the k-th column of U
*
* Perform a rank-1 update of A(1:k-1,1:k-1) as
*
* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)'
*
R1 = ONE / A( K, K )
CALL SSYR( UPLO, K-1, -R1, A( 1, K ), 1, A, LDA )
*
* Store U(k) in column k
*
CALL SSCAL( K-1, R1, A( 1, K ), 1 )
ELSE
*
* 2-by-2 pivot block D(k): columns k and k-1 now hold
*
* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
*
* where U(k) and U(k-1) are the k-th and (k-1)-th columns
* of U
*
* Perform a rank-2 update of A(1:k-2,1:k-2) as
*
* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )'
* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )'
*
IF( K.GT.2 ) THEN
*
D12 = A( K-1, K )
D22 = A( K-1, K-1 ) / D12
D11 = A( K, K ) / D12
T = ONE / ( D11*D22-ONE )
D12 = T / D12
*
DO 30 J = K - 2, 1, -1
WKM1 = D12*( D11*A( J, K-1 )-A( J, K ) )
WK = D12*( D22*A( J, K )-A( J, K-1 ) )
DO 20 I = J, 1, -1
A( I, J ) = A( I, J ) - A( I, K )*WK -
$ A( I, K-1 )*WKM1
20 CONTINUE
A( J, K ) = WK
A( J, K-1 ) = WKM1
30 CONTINUE
*
END IF
*
END IF
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -KP
IPIV( K-1 ) = -KP
END IF
*
* Decrease K and return to the start of the main loop
*
K = K - KSTEP
GO TO 10
*
ELSE
*
* Factorize A as L*D*L' using the lower triangle of A
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2
*
K = 1
40 CONTINUE
*
* If K > N, exit from loop
*
IF( K.GT.N )
$ GO TO 70
KSTEP = 1
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = ABS( A( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value
*
IF( K.LT.N ) THEN
IMAX = K + ISAMAX( N-K, A( K+1, K ), 1 )
COLMAX = ABS( A( IMAX, K ) )
ELSE
COLMAX = ZERO
END IF
*
IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN
*
* Column K is zero or contains a NaN: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
ELSE
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value
*
JMAX = K - 1 + ISAMAX( IMAX-K, A( IMAX, K ), LDA )
ROWMAX = ABS( A( IMAX, JMAX ) )
IF( IMAX.LT.N ) THEN
JMAX = IMAX + ISAMAX( N-IMAX, A( IMAX+1, IMAX ), 1 )
ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) )
END IF
*
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN
*
* interchange rows and columns K and IMAX, use 1-by-1
* pivot block
*
KP = IMAX
ELSE
*
* interchange rows and columns K+1 and IMAX, use 2-by-2
* pivot block
*
KP = IMAX
KSTEP = 2
END IF
END IF
*
KK = K + KSTEP - 1
IF( KP.NE.KK ) THEN
*
* Interchange rows and columns KK and KP in the trailing
* submatrix A(k:n,k:n)
*
IF( KP.LT.N )
$ CALL SSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
CALL SSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
$ LDA )
T = A( KK, KK )
A( KK, KK ) = A( KP, KP )
A( KP, KP ) = T
IF( KSTEP.EQ.2 ) THEN
T = A( K+1, K )
A( K+1, K ) = A( KP, K )
A( KP, K ) = T
END IF
END IF
*
* Update the trailing submatrix
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column k now holds
*
* W(k) = L(k)*D(k)
*
* where L(k) is the k-th column of L
*
IF( K.LT.N ) THEN
*
* Perform a rank-1 update of A(k+1:n,k+1:n) as
*
* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)'
*
D11 = ONE / A( K, K )
CALL SSYR( UPLO, N-K, -D11, A( K+1, K ), 1,
$ A( K+1, K+1 ), LDA )
*
* Store L(k) in column K
*
CALL SSCAL( N-K, D11, A( K+1, K ), 1 )
END IF
ELSE
*
* 2-by-2 pivot block D(k)
*
IF( K.LT.N-1 ) THEN
*
* Perform a rank-2 update of A(k+2:n,k+2:n) as
*
* A := A - ( (A(k) A(k+1))*D(k)**(-1) ) * (A(k) A(k+1))'
*
* where L(k) and L(k+1) are the k-th and (k+1)-th
* columns of L
*
D21 = A( K+1, K )
D11 = A( K+1, K+1 ) / D21
D22 = A( K, K ) / D21
T = ONE / ( D11*D22-ONE )
D21 = T / D21
*
DO 60 J = K + 2, N
*
WK = D21*( D11*A( J, K )-A( J, K+1 ) )
WKP1 = D21*( D22*A( J, K+1 )-A( J, K ) )
*
DO 50 I = J, N
A( I, J ) = A( I, J ) - A( I, K )*WK -
$ A( I, K+1 )*WKP1
50 CONTINUE
*
A( J, K ) = WK
A( J, K+1 ) = WKP1
*
60 CONTINUE
END IF
END IF
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -KP
IPIV( K+1 ) = -KP
END IF
*
* Increase K and return to the start of the main loop
*
K = K + KSTEP
GO TO 40
*
END IF
*
70 CONTINUE
*
RETURN
*
* End of SSYTF2
*
END
SUBROUTINE SSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), D( * ), E( * ), TAU( * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* SSYTRD reduces a real symmetric matrix A to real symmetric
* tridiagonal form T by an orthogonal similarity transformation:
* Q**T * A * Q = T.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the symmetric matrix A. If UPLO = 'U', the leading
* N-by-N upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading N-by-N lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced.
* On exit, if UPLO = 'U', the diagonal and first superdiagonal
* of A are overwritten by the corresponding elements of the
* tridiagonal matrix T, and the elements above the first
* superdiagonal, with the array TAU, represent the orthogonal
* matrix Q as a product of elementary reflectors; if UPLO
* = 'L', the diagonal and first subdiagonal of A are over-
* written by the corresponding elements of the tridiagonal
* matrix T, and the elements below the first subdiagonal, 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,N).
*
* D (output) REAL array, dimension (N)
* The diagonal elements of the tridiagonal matrix T:
* D(i) = A(i,i).
*
* E (output) REAL array, dimension (N-1)
* The off-diagonal elements of the tridiagonal matrix T:
* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
*
* TAU (output) REAL array, dimension (N-1)
* The scalar factors of the elementary reflectors (see Further
* Details).
*
* WORK (workspace/output) REAL 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 >= 1.
* 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
* ===============
*
* If UPLO = 'U', the matrix Q is represented as a product of elementary
* reflectors
*
* Q = H(n-1) . . . H(2) H(1).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a real scalar, and v is a real vector with
* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
* A(1:i-1,i+1), and tau in TAU(i).
*
* If UPLO = 'L', the matrix Q is represented as a product of elementary
* reflectors
*
* Q = H(1) H(2) . . . H(n-1).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a real scalar, and v is a real vector with
* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
* and tau in TAU(i).
*
* The contents of A on exit are illustrated by the following examples
* with n = 5:
*
* if UPLO = 'U': if UPLO = 'L':
*
* ( d e v2 v3 v4 ) ( d )
* ( d e v3 v4 ) ( e d )
* ( d e v4 ) ( v1 e d )
* ( d e ) ( v1 v2 e d )
* ( d ) ( v1 v2 v3 e d )
*
* where d and e denote diagonal and off-diagonal elements of T, and vi
* denotes an element of the vector defining H(i).
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, UPPER
INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB,
$ NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL SLATRD, SSYR2K, SSYTD2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
INFO = -9
END IF
*
IF( INFO.EQ.0 ) THEN
*
* Determine the block size.
*
NB = ILAENV( 1, 'SSYTRD', UPLO, N, -1, -1, -1 )
LWKOPT = N*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSYTRD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
NX = N
IWS = 1
IF( NB.GT.1 .AND. NB.LT.N ) THEN
*
* Determine when to cross over from blocked to unblocked code
* (last block is always handled by unblocked code).
*
NX = MAX( NB, ILAENV( 3, 'SSYTRD', UPLO, N, -1, -1, -1 ) )
IF( NX.LT.N ) 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: determine the
* minimum value of NB, and reduce NB or force use of
* unblocked code by setting NX = N.
*
NB = MAX( LWORK / LDWORK, 1 )
NBMIN = ILAENV( 2, 'SSYTRD', UPLO, N, -1, -1, -1 )
IF( NB.LT.NBMIN )
$ NX = N
END IF
ELSE
NX = N
END IF
ELSE
NB = 1
END IF
*
IF( UPPER ) THEN
*
* Reduce the upper triangle of A.
* Columns 1:kk are handled by the unblocked method.
*
KK = N - ( ( N-NX+NB-1 ) / NB )*NB
DO 20 I = N - NB + 1, KK + 1, -NB
*
* Reduce columns i:i+nb-1 to tridiagonal form and form the
* matrix W which is needed to update the unreduced part of
* the matrix
*
CALL SLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK,
$ LDWORK )
*
* Update the unreduced submatrix A(1:i-1,1:i-1), using an
* update of the form: A := A - V*W' - W*V'
*
CALL SSYR2K( UPLO, 'No transpose', I-1, NB, -ONE, A( 1, I ),
$ LDA, WORK, LDWORK, ONE, A, LDA )
*
* Copy superdiagonal elements back into A, and diagonal
* elements into D
*
DO 10 J = I, I + NB - 1
A( J-1, J ) = E( J-1 )
D( J ) = A( J, J )
10 CONTINUE
20 CONTINUE
*
* Use unblocked code to reduce the last or only block
*
CALL SSYTD2( UPLO, KK, A, LDA, D, E, TAU, IINFO )
ELSE
*
* Reduce the lower triangle of A
*
DO 40 I = 1, N - NX, NB
*
* Reduce columns i:i+nb-1 to tridiagonal form and form the
* matrix W which is needed to update the unreduced part of
* the matrix
*
CALL SLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ),
$ TAU( I ), WORK, LDWORK )
*
* Update the unreduced submatrix A(i+ib:n,i+ib:n), using
* an update of the form: A := A - V*W' - W*V'
*
CALL SSYR2K( UPLO, 'No transpose', N-I-NB+1, NB, -ONE,
$ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE,
$ A( I+NB, I+NB ), LDA )
*
* Copy subdiagonal elements back into A, and diagonal
* elements into D
*
DO 30 J = I, I + NB - 1
A( J+1, J ) = E( J )
D( J ) = A( J, J )
30 CONTINUE
40 CONTINUE
*
* Use unblocked code to reduce the last or only block
*
CALL SSYTD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ),
$ TAU( I ), IINFO )
END IF
*
WORK( 1 ) = LWKOPT
RETURN
*
* End of SSYTRD
*
END
SUBROUTINE SSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
REAL A( LDA, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SSYTRF computes the factorization of a real symmetric matrix A using
* the Bunch-Kaufman diagonal pivoting method. The form of the
* factorization is
*
* A = U*D*U**T or A = L*D*L**T
*
* where U (or L) is a product of permutation and unit upper (lower)
* triangular matrices, and D is symmetric and block diagonal with
* 1-by-1 and 2-by-2 diagonal blocks.
*
* This is the blocked version of the algorithm, calling Level 3 BLAS.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the symmetric matrix A. If UPLO = 'U', the leading
* N-by-N upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading N-by-N lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced.
*
* On exit, the block diagonal matrix D and the multipliers used
* to obtain the factor U or L (see below for further details).
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* IPIV (output) INTEGER array, dimension (N)
* Details of the interchanges and the block structure of D.
* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
* interchanged and D(k,k) is a 1-by-1 diagonal block.
* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*
* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The length of WORK. LWORK >=1. For best performance
* LWORK >= N*NB, where NB is the block size returned by ILAENV.
*
* 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
* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
* has been completed, but the block diagonal matrix D is
* exactly singular, and division by zero will occur if it
* is used to solve a system of equations.
*
* Further Details
* ===============
*
* If UPLO = 'U', then A = U*D*U', where
* U = P(n)*U(n)* ... *P(k)U(k)* ...,
* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
* that if the diagonal block D(k) is of order s (s = 1 or 2), then
*
* ( I v 0 ) k-s
* U(k) = ( 0 I 0 ) s
* ( 0 0 I ) n-k
* k-s s n-k
*
* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
* and A(k,k), and v overwrites A(1:k-2,k-1:k).
*
* If UPLO = 'L', then A = L*D*L', where
* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
* that if the diagonal block D(k) is of order s (s = 1 or 2), then
*
* ( I 0 0 ) k-1
* L(k) = ( 0 I 0 ) s
* ( 0 v I ) n-k-s+1
* k-1 s n-k-s+1
*
* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LQUERY, UPPER
INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL SLASYF, SSYTF2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
INFO = -7
END IF
*
IF( INFO.EQ.0 ) THEN
*
* Determine the block size
*
NB = ILAENV( 1, 'SSYTRF', UPLO, N, -1, -1, -1 )
LWKOPT = N*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSYTRF', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
NBMIN = 2
LDWORK = N
IF( NB.GT.1 .AND. NB.LT.N ) THEN
IWS = LDWORK*NB
IF( LWORK.LT.IWS ) THEN
NB = MAX( LWORK / LDWORK, 1 )
NBMIN = MAX( 2, ILAENV( 2, 'SSYTRF', UPLO, N, -1, -1, -1 ) )
END IF
ELSE
IWS = 1
END IF
IF( NB.LT.NBMIN )
$ NB = N
*
IF( UPPER ) THEN
*
* Factorize A as U*D*U' using the upper triangle of A
*
* K is the main loop index, decreasing from N to 1 in steps of
* KB, where KB is the number of columns factorized by SLASYF;
* KB is either NB or NB-1, or K for the last block
*
K = N
10 CONTINUE
*
* If K < 1, exit from loop
*
IF( K.LT.1 )
$ GO TO 40
*
IF( K.GT.NB ) THEN
*
* Factorize columns k-kb+1:k of A and use blocked code to
* update columns 1:k-kb
*
CALL SLASYF( UPLO, K, NB, KB, A, LDA, IPIV, WORK, LDWORK,
$ IINFO )
ELSE
*
* Use unblocked code to factorize columns 1:k of A
*
CALL SSYTF2( UPLO, K, A, LDA, IPIV, IINFO )
KB = K
END IF
*
* Set INFO on the first occurrence of a zero pivot
*
IF( INFO.EQ.0 .AND. IINFO.GT.0 )
$ INFO = IINFO
*
* Decrease K and return to the start of the main loop
*
K = K - KB
GO TO 10
*
ELSE
*
* Factorize A as L*D*L' using the lower triangle of A
*
* K is the main loop index, increasing from 1 to N in steps of
* KB, where KB is the number of columns factorized by SLASYF;
* KB is either NB or NB-1, or N-K+1 for the last block
*
K = 1
20 CONTINUE
*
* If K > N, exit from loop
*
IF( K.GT.N )
$ GO TO 40
*
IF( K.LE.N-NB ) THEN
*
* Factorize columns k:k+kb-1 of A and use blocked code to
* update columns k+kb:n
*
CALL SLASYF( UPLO, N-K+1, NB, KB, A( K, K ), LDA, IPIV( K ),
$ WORK, LDWORK, IINFO )
ELSE
*
* Use unblocked code to factorize columns k:n of A
*
CALL SSYTF2( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ), IINFO )
KB = N - K + 1
END IF
*
* Set INFO on the first occurrence of a zero pivot
*
IF( INFO.EQ.0 .AND. IINFO.GT.0 )
$ INFO = IINFO + K - 1
*
* Adjust IPIV
*
DO 30 J = K, K + KB - 1
IF( IPIV( J ).GT.0 ) THEN
IPIV( J ) = IPIV( J ) + K - 1
ELSE
IPIV( J ) = IPIV( J ) - K + 1
END IF
30 CONTINUE
*
* Increase K and return to the start of the main loop
*
K = K + KB
GO TO 20
*
END IF
*
40 CONTINUE
WORK( 1 ) = LWKOPT
RETURN
*
* End of SSYTRF
*
END
SUBROUTINE SSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
REAL A( LDA, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SSYTRI computes the inverse of a real symmetric indefinite matrix
* A using the factorization A = U*D*U**T or A = L*D*L**T computed by
* SSYTRF.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the details of the factorization are stored
* as an upper or lower triangular matrix.
* = 'U': Upper triangular, form is A = U*D*U**T;
* = 'L': Lower triangular, form is A = L*D*L**T.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the block diagonal matrix D and the multipliers
* used to obtain the factor U or L as computed by SSYTRF.
*
* On exit, if INFO = 0, the (symmetric) inverse of the original
* matrix. If UPLO = 'U', the upper triangular part of the
* inverse is formed and the part of A below the diagonal is not
* referenced; if UPLO = 'L' the lower triangular part of the
* inverse is formed and the part of A above the diagonal is
* not referenced.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* IPIV (input) INTEGER array, dimension (N)
* Details of the interchanges and the block structure of D
* as determined by SSYTRF.
*
* WORK (workspace) REAL array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
* inverse could not be computed.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER K, KP, KSTEP
REAL AK, AKKP1, AKP1, D, T, TEMP
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SDOT
EXTERNAL LSAME, SDOT
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SSWAP, SSYMV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSYTRI', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Check that the diagonal matrix D is nonsingular.
*
IF( UPPER ) THEN
*
* Upper triangular storage: examine D from bottom to top
*
DO 10 INFO = N, 1, -1
IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO )
$ RETURN
10 CONTINUE
ELSE
*
* Lower triangular storage: examine D from top to bottom.
*
DO 20 INFO = 1, N
IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO )
$ RETURN
20 CONTINUE
END IF
INFO = 0
*
IF( UPPER ) THEN
*
* Compute inv(A) from the factorization A = U*D*U'.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
30 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 40
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Invert the diagonal block.
*
A( K, K ) = ONE / A( K, K )
*
* Compute column K of the inverse.
*
IF( K.GT.1 ) THEN
CALL SCOPY( K-1, A( 1, K ), 1, WORK, 1 )
CALL SSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
$ A( 1, K ), 1 )
A( K, K ) = A( K, K ) - SDOT( K-1, WORK, 1, A( 1, K ),
$ 1 )
END IF
KSTEP = 1
ELSE
*
* 2 x 2 diagonal block
*
* Invert the diagonal block.
*
T = ABS( A( K, K+1 ) )
AK = A( K, K ) / T
AKP1 = A( K+1, K+1 ) / T
AKKP1 = A( K, K+1 ) / T
D = T*( AK*AKP1-ONE )
A( K, K ) = AKP1 / D
A( K+1, K+1 ) = AK / D
A( K, K+1 ) = -AKKP1 / D
*
* Compute columns K and K+1 of the inverse.
*
IF( K.GT.1 ) THEN
CALL SCOPY( K-1, A( 1, K ), 1, WORK, 1 )
CALL SSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
$ A( 1, K ), 1 )
A( K, K ) = A( K, K ) - SDOT( K-1, WORK, 1, A( 1, K ),
$ 1 )
A( K, K+1 ) = A( K, K+1 ) -
$ SDOT( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 )
CALL SCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 )
CALL SSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
$ A( 1, K+1 ), 1 )
A( K+1, K+1 ) = A( K+1, K+1 ) -
$ SDOT( K-1, WORK, 1, A( 1, K+1 ), 1 )
END IF
KSTEP = 2
END IF
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K ) THEN
*
* Interchange rows and columns K and KP in the leading
* submatrix A(1:k+1,1:k+1)
*
CALL SSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
CALL SSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA )
TEMP = A( K, K )
A( K, K ) = A( KP, KP )
A( KP, KP ) = TEMP
IF( KSTEP.EQ.2 ) THEN
TEMP = A( K, K+1 )
A( K, K+1 ) = A( KP, K+1 )
A( KP, K+1 ) = TEMP
END IF
END IF
*
K = K + KSTEP
GO TO 30
40 CONTINUE
*
ELSE
*
* Compute inv(A) from the factorization A = L*D*L'.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = N
50 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 60
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Invert the diagonal block.
*
A( K, K ) = ONE / A( K, K )
*
* Compute column K of the inverse.
*
IF( K.LT.N ) THEN
CALL SCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
CALL SSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
$ ZERO, A( K+1, K ), 1 )
A( K, K ) = A( K, K ) - SDOT( N-K, WORK, 1, A( K+1, K ),
$ 1 )
END IF
KSTEP = 1
ELSE
*
* 2 x 2 diagonal block
*
* Invert the diagonal block.
*
T = ABS( A( K, K-1 ) )
AK = A( K-1, K-1 ) / T
AKP1 = A( K, K ) / T
AKKP1 = A( K, K-1 ) / T
D = T*( AK*AKP1-ONE )
A( K-1, K-1 ) = AKP1 / D
A( K, K ) = AK / D
A( K, K-1 ) = -AKKP1 / D
*
* Compute columns K-1 and K of the inverse.
*
IF( K.LT.N ) THEN
CALL SCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
CALL SSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
$ ZERO, A( K+1, K ), 1 )
A( K, K ) = A( K, K ) - SDOT( N-K, WORK, 1, A( K+1, K ),
$ 1 )
A( K, K-1 ) = A( K, K-1 ) -
$ SDOT( N-K, A( K+1, K ), 1, A( K+1, K-1 ),
$ 1 )
CALL SCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 )
CALL SSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
$ ZERO, A( K+1, K-1 ), 1 )
A( K-1, K-1 ) = A( K-1, K-1 ) -
$ SDOT( N-K, WORK, 1, A( K+1, K-1 ), 1 )
END IF
KSTEP = 2
END IF
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K ) THEN
*
* Interchange rows and columns K and KP in the trailing
* submatrix A(k-1:n,k-1:n)
*
IF( KP.LT.N )
$ CALL SSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
CALL SSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA )
TEMP = A( K, K )
A( K, K ) = A( KP, KP )
A( KP, KP ) = TEMP
IF( KSTEP.EQ.2 ) THEN
TEMP = A( K, K-1 )
A( K, K-1 ) = A( KP, K-1 )
A( KP, K-1 ) = TEMP
END IF
END IF
*
K = K - KSTEP
GO TO 50
60 CONTINUE
END IF
*
RETURN
*
* End of SSYTRI
*
END
SUBROUTINE SSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
REAL A( LDA, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* SSYTRS solves a system of linear equations A*X = B with a real
* symmetric matrix A using the factorization A = U*D*U**T or
* A = L*D*L**T computed by SSYTRF.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the details of the factorization are stored
* as an upper or lower triangular matrix.
* = 'U': Upper triangular, form is A = U*D*U**T;
* = 'L': Lower triangular, form is A = L*D*L**T.
*
* 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) REAL array, dimension (LDA,N)
* The block diagonal matrix D and the multipliers used to
* obtain the factor U or L as computed by SSYTRF.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* IPIV (input) INTEGER array, dimension (N)
* Details of the interchanges and the block structure of D
* as determined by SSYTRF.
*
* B (input/output) REAL 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 ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, K, KP
REAL AK, AKM1, AKM1K, BK, BKM1, DENOM
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SGEMV, SGER, SSCAL, SSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) 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( 'SSYTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Solve A*X = B, where A = U*D*U'.
*
* First solve U*D*X = B, overwriting B with X.
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = N
10 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 30
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(U(K)), where U(K) is the transformation
* stored in column K of A.
*
CALL SGER( K-1, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB,
$ B( 1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
CALL SSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB )
K = K - 1
ELSE
*
* 2 x 2 diagonal block
*
* Interchange rows K-1 and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K-1 )
$ CALL SSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(U(K)), where U(K) is the transformation
* stored in columns K-1 and K of A.
*
CALL SGER( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB,
$ B( 1, 1 ), LDB )
CALL SGER( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ),
$ LDB, B( 1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
AKM1K = A( K-1, K )
AKM1 = A( K-1, K-1 ) / AKM1K
AK = A( K, K ) / AKM1K
DENOM = AKM1*AK - ONE
DO 20 J = 1, NRHS
BKM1 = B( K-1, J ) / AKM1K
BK = B( K, J ) / AKM1K
B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
20 CONTINUE
K = K - 2
END IF
*
GO TO 10
30 CONTINUE
*
* Next solve U'*X = B, overwriting B with X.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
40 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 50
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Multiply by inv(U'(K)), where U(K) is the transformation
* stored in column K of A.
*
CALL SGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, K ),
$ 1, ONE, B( K, 1 ), LDB )
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
K = K + 1
ELSE
*
* 2 x 2 diagonal block
*
* Multiply by inv(U'(K+1)), where U(K+1) is the transformation
* stored in columns K and K+1 of A.
*
CALL SGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, K ),
$ 1, ONE, B( K, 1 ), LDB )
CALL SGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB,
$ A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB )
*
* Interchange rows K and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K )
$ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
K = K + 2
END IF
*
GO TO 40
50 CONTINUE
*
ELSE
*
* Solve A*X = B, where A = L*D*L'.
*
* First solve L*D*X = B, overwriting B with X.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
60 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 80
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(L(K)), where L(K) is the transformation
* stored in column K of A.
*
IF( K.LT.N )
$ CALL SGER( N-K, NRHS, -ONE, A( K+1, K ), 1, B( K, 1 ),
$ LDB, B( K+1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
CALL SSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB )
K = K + 1
ELSE
*
* 2 x 2 diagonal block
*
* Interchange rows K+1 and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K+1 )
$ CALL SSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(L(K)), where L(K) is the transformation
* stored in columns K and K+1 of A.
*
IF( K.LT.N-1 ) THEN
CALL SGER( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K, 1 ),
$ LDB, B( K+2, 1 ), LDB )
CALL SGER( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1,
$ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
END IF
*
* Multiply by the inverse of the diagonal block.
*
AKM1K = A( K+1, K )
AKM1 = A( K, K ) / AKM1K
AK = A( K+1, K+1 ) / AKM1K
DENOM = AKM1*AK - ONE
DO 70 J = 1, NRHS
BKM1 = B( K, J ) / AKM1K
BK = B( K+1, J ) / AKM1K
B( K, J ) = ( AK*BKM1-BK ) / DENOM
B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
70 CONTINUE
K = K + 2
END IF
*
GO TO 60
80 CONTINUE
*
* Next solve L'*X = B, overwriting B with X.
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = N
90 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 100
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Multiply by inv(L'(K)), where L(K) is the transformation
* stored in column K of A.
*
IF( K.LT.N )
$ CALL SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
$ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB )
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
K = K - 1
ELSE
*
* 2 x 2 diagonal block
*
* Multiply by inv(L'(K-1)), where L(K-1) is the transformation
* stored in columns K-1 and K of A.
*
IF( K.LT.N ) THEN
CALL SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
$ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB )
CALL SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
$ LDB, A( K+1, K-1 ), 1, ONE, B( K-1, 1 ),
$ LDB )
END IF
*
* Interchange rows K and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K )
$ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
K = K - 2
END IF
*
GO TO 90
100 CONTINUE
END IF
*
RETURN
*
* End of SSYTRS
*
END
SUBROUTINE STBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK,
$ IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER DIAG, NORM, UPLO
INTEGER INFO, KD, LDAB, N
REAL RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL AB( LDAB, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* STBCON estimates the reciprocal of the condition number of a
* triangular band matrix A, in either the 1-norm or the infinity-norm.
*
* The norm of A is computed and an estimate is obtained for
* norm(inv(A)), then the reciprocal of the condition number is
* computed as
* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies whether the 1-norm condition number or the
* infinity-norm condition number is required:
* = '1' or 'O': 1-norm;
* = 'I': Infinity-norm.
*
* UPLO (input) CHARACTER*1
* = 'U': A is upper triangular;
* = 'L': A is lower triangular.
*
* DIAG (input) CHARACTER*1
* = 'N': A is non-unit triangular;
* = 'U': A is unit triangular.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals or subdiagonals of the
* triangular band matrix A. KD >= 0.
*
* AB (input) REAL array, dimension (LDAB,N)
* The upper or lower triangular band matrix A, stored in the
* first kd+1 rows of the array. The j-th column of A is stored
* in the j-th column of the array AB as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
* If DIAG = 'U', the diagonal elements of A are not referenced
* and are assumed to be 1.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* RCOND (output) REAL
* The reciprocal of the condition number of the matrix A,
* computed as RCOND = 1/(norm(A) * norm(inv(A))).
*
* WORK (workspace) REAL array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT, ONENRM, UPPER
CHARACTER NORMIN
INTEGER IX, KASE, KASE1
REAL AINVNM, ANORM, SCALE, SMLNUM, XNORM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SLAMCH, SLANTB
EXTERNAL LSAME, ISAMAX, SLAMCH, SLANTB
* ..
* .. External Subroutines ..
EXTERNAL SLACN2, SLATBS, SRSCL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, REAL
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
NOUNIT = LSAME( DIAG, 'N' )
*
IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
INFO = -1
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( KD.LT.0 ) THEN
INFO = -5
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STBCON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
END IF
*
RCOND = ZERO
SMLNUM = SLAMCH( 'Safe minimum' )*REAL( MAX( 1, N ) )
*
* Compute the norm of the triangular matrix A.
*
ANORM = SLANTB( NORM, UPLO, DIAG, N, KD, AB, LDAB, WORK )
*
* Continue only if ANORM > 0.
*
IF( ANORM.GT.ZERO ) THEN
*
* Estimate the norm of the inverse of A.
*
AINVNM = ZERO
NORMIN = 'N'
IF( ONENRM ) THEN
KASE1 = 1
ELSE
KASE1 = 2
END IF
KASE = 0
10 CONTINUE
CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.KASE1 ) THEN
*
* Multiply by inv(A).
*
CALL SLATBS( UPLO, 'No transpose', DIAG, NORMIN, N, KD,
$ AB, LDAB, WORK, SCALE, WORK( 2*N+1 ), INFO )
ELSE
*
* Multiply by inv(A').
*
CALL SLATBS( UPLO, 'Transpose', DIAG, NORMIN, N, KD, AB,
$ LDAB, WORK, SCALE, WORK( 2*N+1 ), INFO )
END IF
NORMIN = 'Y'
*
* Multiply by 1/SCALE if doing so will not cause overflow.
*
IF( SCALE.NE.ONE ) THEN
IX = ISAMAX( N, WORK, 1 )
XNORM = ABS( WORK( IX ) )
IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO )
$ GO TO 20
CALL SRSCL( N, SCALE, WORK, 1 )
END IF
GO TO 10
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / ANORM ) / AINVNM
END IF
*
20 CONTINUE
RETURN
*
* End of STBCON
*
END
SUBROUTINE STBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B,
$ LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER INFO, KD, LDAB, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL AB( LDAB, * ), B( LDB, * ), BERR( * ),
$ FERR( * ), WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* STBRFS provides error bounds and backward error estimates for the
* solution to a system of linear equations with a triangular band
* coefficient matrix.
*
* The solution matrix X must be computed by STBTRS or some other
* means before entering this routine. STBRFS does not do iterative
* refinement because doing so cannot improve the backward error.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': A is upper triangular;
* = 'L': A is lower triangular.
*
* 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**H * X = B (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* = 'N': A is non-unit triangular;
* = 'U': A is unit triangular.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals or subdiagonals of the
* triangular band matrix A. KD >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrices B and X. NRHS >= 0.
*
* AB (input) REAL array, dimension (LDAB,N)
* The upper or lower triangular band matrix A, stored in the
* first kd+1 rows of the array. The j-th column of A is stored
* in the j-th column of the array AB as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
* If DIAG = 'U', the diagonal elements of A are not referenced
* and are assumed to be 1.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* B (input) REAL array, dimension (LDB,NRHS)
* The right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input) REAL array, dimension (LDX,NRHS)
* The solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* FERR (output) REAL array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) REAL array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN, NOUNIT, UPPER
CHARACTER TRANST
INTEGER I, J, K, KASE, NZ
REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, SLACN2, STBMV, STBSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH
EXTERNAL LSAME, SLAMCH
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOTRAN = LSAME( TRANS, 'N' )
NOUNIT = LSAME( DIAG, 'N' )
*
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
$ LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( KD.LT.0 ) THEN
INFO = -5
ELSE IF( NRHS.LT.0 ) THEN
INFO = -6
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -8
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -10
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STBRFS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
DO 10 J = 1, NRHS
FERR( J ) = ZERO
BERR( J ) = ZERO
10 CONTINUE
RETURN
END IF
*
IF( NOTRAN ) THEN
TRANST = 'T'
ELSE
TRANST = 'N'
END IF
*
* NZ = maximum number of nonzero elements in each row of A, plus 1
*
NZ = KD + 2
EPS = SLAMCH( 'Epsilon' )
SAFMIN = SLAMCH( 'Safe minimum' )
SAFE1 = NZ*SAFMIN
SAFE2 = SAFE1 / EPS
*
* Do for each right hand side
*
DO 250 J = 1, NRHS
*
* Compute residual R = B - op(A) * X,
* where op(A) = A or A', depending on TRANS.
*
CALL SCOPY( N, X( 1, J ), 1, WORK( N+1 ), 1 )
CALL STBMV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, WORK( N+1 ),
$ 1 )
CALL SAXPY( N, -ONE, B( 1, J ), 1, WORK( N+1 ), 1 )
*
* Compute componentwise relative backward error from formula
*
* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
*
* where abs(Z) is the componentwise absolute value of the matrix
* or vector Z. If the i-th component of the denominator is less
* than SAFE2, then SAFE1 is added to the i-th components of the
* numerator and denominator before dividing.
*
DO 20 I = 1, N
WORK( I ) = ABS( B( I, J ) )
20 CONTINUE
*
IF( NOTRAN ) THEN
*
* Compute abs(A)*abs(X) + abs(B).
*
IF( UPPER ) THEN
IF( NOUNIT ) THEN
DO 40 K = 1, N
XK = ABS( X( K, J ) )
DO 30 I = MAX( 1, K-KD ), K
WORK( I ) = WORK( I ) +
$ ABS( AB( KD+1+I-K, K ) )*XK
30 CONTINUE
40 CONTINUE
ELSE
DO 60 K = 1, N
XK = ABS( X( K, J ) )
DO 50 I = MAX( 1, K-KD ), K - 1
WORK( I ) = WORK( I ) +
$ ABS( AB( KD+1+I-K, K ) )*XK
50 CONTINUE
WORK( K ) = WORK( K ) + XK
60 CONTINUE
END IF
ELSE
IF( NOUNIT ) THEN
DO 80 K = 1, N
XK = ABS( X( K, J ) )
DO 70 I = K, MIN( N, K+KD )
WORK( I ) = WORK( I ) + ABS( AB( 1+I-K, K ) )*XK
70 CONTINUE
80 CONTINUE
ELSE
DO 100 K = 1, N
XK = ABS( X( K, J ) )
DO 90 I = K + 1, MIN( N, K+KD )
WORK( I ) = WORK( I ) + ABS( AB( 1+I-K, K ) )*XK
90 CONTINUE
WORK( K ) = WORK( K ) + XK
100 CONTINUE
END IF
END IF
ELSE
*
* Compute abs(A')*abs(X) + abs(B).
*
IF( UPPER ) THEN
IF( NOUNIT ) THEN
DO 120 K = 1, N
S = ZERO
DO 110 I = MAX( 1, K-KD ), K
S = S + ABS( AB( KD+1+I-K, K ) )*
$ ABS( X( I, J ) )
110 CONTINUE
WORK( K ) = WORK( K ) + S
120 CONTINUE
ELSE
DO 140 K = 1, N
S = ABS( X( K, J ) )
DO 130 I = MAX( 1, K-KD ), K - 1
S = S + ABS( AB( KD+1+I-K, K ) )*
$ ABS( X( I, J ) )
130 CONTINUE
WORK( K ) = WORK( K ) + S
140 CONTINUE
END IF
ELSE
IF( NOUNIT ) THEN
DO 160 K = 1, N
S = ZERO
DO 150 I = K, MIN( N, K+KD )
S = S + ABS( AB( 1+I-K, K ) )*ABS( X( I, J ) )
150 CONTINUE
WORK( K ) = WORK( K ) + S
160 CONTINUE
ELSE
DO 180 K = 1, N
S = ABS( X( K, J ) )
DO 170 I = K + 1, MIN( N, K+KD )
S = S + ABS( AB( 1+I-K, K ) )*ABS( X( I, J ) )
170 CONTINUE
WORK( K ) = WORK( K ) + S
180 CONTINUE
END IF
END IF
END IF
S = ZERO
DO 190 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
ELSE
S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
$ ( WORK( I )+SAFE1 ) )
END IF
190 CONTINUE
BERR( J ) = S
*
* Bound error from formula
*
* norm(X - XTRUE) / norm(X) .le. FERR =
* norm( abs(inv(op(A)))*
* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
*
* where
* norm(Z) is the magnitude of the largest component of Z
* inv(op(A)) is the inverse of op(A)
* abs(Z) is the componentwise absolute value of the matrix or
* vector Z
* NZ is the maximum number of nonzeros in any row of A, plus 1
* EPS is machine epsilon
*
* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
* is incremented by SAFE1 if the i-th component of
* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
*
* Use SLACN2 to estimate the infinity-norm of the matrix
* inv(op(A)) * diag(W),
* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
*
DO 200 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
ELSE
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
END IF
200 CONTINUE
*
KASE = 0
210 CONTINUE
CALL SLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
$ KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Multiply by diag(W)*inv(op(A)').
*
CALL STBSV( UPLO, TRANST, DIAG, N, KD, AB, LDAB,
$ WORK( N+1 ), 1 )
DO 220 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
220 CONTINUE
ELSE
*
* Multiply by inv(op(A))*diag(W).
*
DO 230 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
230 CONTINUE
CALL STBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB,
$ WORK( N+1 ), 1 )
END IF
GO TO 210
END IF
*
* Normalize error.
*
LSTRES = ZERO
DO 240 I = 1, N
LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
240 CONTINUE
IF( LSTRES.NE.ZERO )
$ FERR( J ) = FERR( J ) / LSTRES
*
250 CONTINUE
*
RETURN
*
* End of STBRFS
*
END
SUBROUTINE STBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B,
$ LDB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER INFO, KD, LDAB, LDB, N, NRHS
* ..
* .. Array Arguments ..
REAL AB( LDAB, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* STBTRS solves a triangular system of the form
*
* A * X = B or A**T * X = B,
*
* where A is a triangular band matrix of order N, and B is an
* N-by NRHS matrix. A check is made to verify that A is nonsingular.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': A is upper triangular;
* = 'L': A is lower triangular.
*
* TRANS (input) CHARACTER*1
* Specifies the form the system of equations:
* = 'N': A * X = B (No transpose)
* = 'T': A**T * X = B (Transpose)
* = 'C': A**H * X = B (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* = 'N': A is non-unit triangular;
* = 'U': A is unit triangular.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals or subdiagonals of the
* triangular band matrix A. KD >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrix B. NRHS >= 0.
*
* AB (input) REAL array, dimension (LDAB,N)
* The upper or lower triangular band matrix A, stored in the
* first kd+1 rows of AB. The j-th column of A is stored
* in the j-th column of the array AB as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
* If DIAG = 'U', the diagonal elements of A are not referenced
* and are assumed to be 1.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the right hand side matrix B.
* On exit, if INFO = 0, 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
* > 0: if INFO = i, the i-th diagonal element of A is zero,
* indicating that the matrix is singular and the
* solutions X have not been computed.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT, UPPER
INTEGER J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL STBSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
NOUNIT = LSAME( DIAG, 'N' )
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .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.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( KD.LT.0 ) THEN
INFO = -5
ELSE IF( NRHS.LT.0 ) THEN
INFO = -6
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -8
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STBTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Check for singularity.
*
IF( NOUNIT ) THEN
IF( UPPER ) THEN
DO 10 INFO = 1, N
IF( AB( KD+1, INFO ).EQ.ZERO )
$ RETURN
10 CONTINUE
ELSE
DO 20 INFO = 1, N
IF( AB( 1, INFO ).EQ.ZERO )
$ RETURN
20 CONTINUE
END IF
END IF
INFO = 0
*
* Solve A * X = B or A' * X = B.
*
DO 30 J = 1, NRHS
CALL STBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, B( 1, J ), 1 )
30 CONTINUE
*
RETURN
*
* End of STBTRS
*
END
SUBROUTINE STGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL,
$ LDVL, VR, LDVR, MM, M, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER HOWMNY, SIDE
INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N
* ..
* .. Array Arguments ..
LOGICAL SELECT( * )
REAL P( LDP, * ), S( LDS, * ), VL( LDVL, * ),
$ VR( LDVR, * ), WORK( * )
* ..
*
*
* Purpose
* =======
*
* STGEVC computes some or all of the right and/or left eigenvectors of
* a pair of real matrices (S,P), where S is a quasi-triangular matrix
* and P is upper triangular. Matrix pairs of this type are produced by
* the generalized Schur factorization of a matrix pair (A,B):
*
* A = Q*S*Z**T, B = Q*P*Z**T
*
* as computed by SGGHRD + SHGEQZ.
*
* The right eigenvector x and the left eigenvector y of (S,P)
* corresponding to an eigenvalue w are defined by:
*
* S*x = w*P*x, (y**H)*S = w*(y**H)*P,
*
* where y**H denotes the conjugate tranpose of y.
* The eigenvalues are not input to this routine, but are computed
* directly from the diagonal blocks of S and P.
*
* This routine returns the matrices X and/or Y of right and left
* eigenvectors of (S,P), or the products Z*X and/or Q*Y,
* where Z and Q are input matrices.
* If Q and Z are the orthogonal factors from the generalized Schur
* factorization of a matrix pair (A,B), then Z*X and Q*Y
* are the matrices of right and left eigenvectors of (A,B).
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* = 'R': compute right eigenvectors only;
* = 'L': compute left eigenvectors only;
* = 'B': compute both right and left eigenvectors.
*
* HOWMNY (input) CHARACTER*1
* = 'A': compute all right and/or left eigenvectors;
* = 'B': compute all right and/or left eigenvectors,
* backtransformed by the matrices in VR and/or VL;
* = 'S': compute selected right and/or left eigenvectors,
* specified by the logical array SELECT.
*
* SELECT (input) LOGICAL array, dimension (N)
* If HOWMNY='S', SELECT specifies the eigenvectors to be
* computed. If w(j) is a real eigenvalue, the corresponding
* real eigenvector is computed if SELECT(j) is .TRUE..
* If w(j) and w(j+1) are the real and imaginary parts of a
* complex eigenvalue, the corresponding complex eigenvector
* is computed if either SELECT(j) or SELECT(j+1) is .TRUE.,
* and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is
* set to .FALSE..
* Not referenced if HOWMNY = 'A' or 'B'.
*
* N (input) INTEGER
* The order of the matrices S and P. N >= 0.
*
* S (input) REAL array, dimension (LDS,N)
* The upper quasi-triangular matrix S from a generalized Schur
* factorization, as computed by SHGEQZ.
*
* LDS (input) INTEGER
* The leading dimension of array S. LDS >= max(1,N).
*
* P (input) REAL array, dimension (LDP,N)
* The upper triangular matrix P from a generalized Schur
* factorization, as computed by SHGEQZ.
* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks
* of S must be in positive diagonal form.
*
* LDP (input) INTEGER
* The leading dimension of array P. LDP >= max(1,N).
*
* VL (input/output) REAL array, dimension (LDVL,MM)
* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
* contain an N-by-N matrix Q (usually the orthogonal matrix Q
* of left Schur vectors returned by SHGEQZ).
* On exit, if SIDE = 'L' or 'B', VL contains:
* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);
* if HOWMNY = 'B', the matrix Q*Y;
* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by
* SELECT, stored consecutively in the columns of
* VL, in the same order as their eigenvalues.
*
* A complex eigenvector corresponding to a complex eigenvalue
* is stored in two consecutive columns, the first holding the
* real part, and the second the imaginary part.
*
* Not referenced if SIDE = 'R'.
*
* LDVL (input) INTEGER
* The leading dimension of array VL. LDVL >= 1, and if
* SIDE = 'L' or 'B', LDVL >= N.
*
* VR (input/output) REAL array, dimension (LDVR,MM)
* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
* contain an N-by-N matrix Z (usually the orthogonal matrix Z
* of right Schur vectors returned by SHGEQZ).
*
* On exit, if SIDE = 'R' or 'B', VR contains:
* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);
* if HOWMNY = 'B' or 'b', the matrix Z*X;
* if HOWMNY = 'S' or 's', the right eigenvectors of (S,P)
* specified by SELECT, stored consecutively in the
* columns of VR, in the same order as their
* eigenvalues.
*
* A complex eigenvector corresponding to a complex eigenvalue
* is stored in two consecutive columns, the first holding the
* real part and the second the imaginary part.
*
* Not referenced if SIDE = 'L'.
*
* LDVR (input) INTEGER
* The leading dimension of the array VR. LDVR >= 1, and if
* SIDE = 'R' or 'B', LDVR >= N.
*
* MM (input) INTEGER
* The number of columns in the arrays VL and/or VR. MM >= M.
*
* M (output) INTEGER
* The number of columns in the arrays VL and/or VR actually
* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M
* is set to N. Each selected real eigenvector occupies one
* column and each selected complex eigenvector occupies two
* columns.
*
* WORK (workspace) REAL array, dimension (6*N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: the 2-by-2 block (INFO:INFO+1) does not have a complex
* eigenvalue.
*
* Further Details
* ===============
*
* Allocation of workspace:
* ---------- -- ---------
*
* WORK( j ) = 1-norm of j-th column of A, above the diagonal
* WORK( N+j ) = 1-norm of j-th column of B, above the diagonal
* WORK( 2*N+1:3*N ) = real part of eigenvector
* WORK( 3*N+1:4*N ) = imaginary part of eigenvector
* WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector
* WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector
*
* Rowwise vs. columnwise solution methods:
* ------- -- ---------- -------- -------
*
* Finding a generalized eigenvector consists basically of solving the
* singular triangular system
*
* (A - w B) x = 0 (for right) or: (A - w B)**H y = 0 (for left)
*
* Consider finding the i-th right eigenvector (assume all eigenvalues
* are real). The equation to be solved is:
* n i
* 0 = sum C(j,k) v(k) = sum C(j,k) v(k) for j = i,. . .,1
* k=j k=j
*
* where C = (A - w B) (The components v(i+1:n) are 0.)
*
* The "rowwise" method is:
*
* (1) v(i) := 1
* for j = i-1,. . .,1:
* i
* (2) compute s = - sum C(j,k) v(k) and
* k=j+1
*
* (3) v(j) := s / C(j,j)
*
* Step 2 is sometimes called the "dot product" step, since it is an
* inner product between the j-th row and the portion of the eigenvector
* that has been computed so far.
*
* The "columnwise" method consists basically in doing the sums
* for all the rows in parallel. As each v(j) is computed, the
* contribution of v(j) times the j-th column of C is added to the
* partial sums. Since FORTRAN arrays are stored columnwise, this has
* the advantage that at each step, the elements of C that are accessed
* are adjacent to one another, whereas with the rowwise method, the
* elements accessed at a step are spaced LDS (and LDP) words apart.
*
* When finding left eigenvectors, the matrix in question is the
* transpose of the one in storage, so the rowwise method then
* actually accesses columns of A and B at each step, and so is the
* preferred method.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, SAFETY
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0,
$ SAFETY = 1.0E+2 )
* ..
* .. Local Scalars ..
LOGICAL COMPL, COMPR, IL2BY2, ILABAD, ILALL, ILBACK,
$ ILBBAD, ILCOMP, ILCPLX, LSA, LSB
INTEGER I, IBEG, IEIG, IEND, IHWMNY, IINFO, IM, ISIDE,
$ J, JA, JC, JE, JR, JW, NA, NW
REAL ACOEF, ACOEFA, ANORM, ASCALE, BCOEFA, BCOEFI,
$ BCOEFR, BIG, BIGNUM, BNORM, BSCALE, CIM2A,
$ CIM2B, CIMAGA, CIMAGB, CRE2A, CRE2B, CREALA,
$ CREALB, DMIN, SAFMIN, SALFAR, SBETA, SCALE,
$ SMALL, TEMP, TEMP2, TEMP2I, TEMP2R, ULP, XMAX,
$ XSCALE
* ..
* .. Local Arrays ..
REAL BDIAG( 2 ), SUM( 2, 2 ), SUMS( 2, 2 ),
$ SUMP( 2, 2 )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH
EXTERNAL LSAME, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SGEMV, SLABAD, SLACPY, SLAG2, SLALN2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Decode and Test the input parameters
*
IF( LSAME( HOWMNY, 'A' ) ) THEN
IHWMNY = 1
ILALL = .TRUE.
ILBACK = .FALSE.
ELSE IF( LSAME( HOWMNY, 'S' ) ) THEN
IHWMNY = 2
ILALL = .FALSE.
ILBACK = .FALSE.
ELSE IF( LSAME( HOWMNY, 'B' ) ) THEN
IHWMNY = 3
ILALL = .TRUE.
ILBACK = .TRUE.
ELSE
IHWMNY = -1
ILALL = .TRUE.
END IF
*
IF( LSAME( SIDE, 'R' ) ) THEN
ISIDE = 1
COMPL = .FALSE.
COMPR = .TRUE.
ELSE IF( LSAME( SIDE, 'L' ) ) THEN
ISIDE = 2
COMPL = .TRUE.
COMPR = .FALSE.
ELSE IF( LSAME( SIDE, 'B' ) ) THEN
ISIDE = 3
COMPL = .TRUE.
COMPR = .TRUE.
ELSE
ISIDE = -1
END IF
*
INFO = 0
IF( ISIDE.LT.0 ) THEN
INFO = -1
ELSE IF( IHWMNY.LT.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDS.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDP.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STGEVC', -INFO )
RETURN
END IF
*
* Count the number of eigenvectors to be computed
*
IF( .NOT.ILALL ) THEN
IM = 0
ILCPLX = .FALSE.
DO 10 J = 1, N
IF( ILCPLX ) THEN
ILCPLX = .FALSE.
GO TO 10
END IF
IF( J.LT.N ) THEN
IF( S( J+1, J ).NE.ZERO )
$ ILCPLX = .TRUE.
END IF
IF( ILCPLX ) THEN
IF( SELECT( J ) .OR. SELECT( J+1 ) )
$ IM = IM + 2
ELSE
IF( SELECT( J ) )
$ IM = IM + 1
END IF
10 CONTINUE
ELSE
IM = N
END IF
*
* Check 2-by-2 diagonal blocks of A, B
*
ILABAD = .FALSE.
ILBBAD = .FALSE.
DO 20 J = 1, N - 1
IF( S( J+1, J ).NE.ZERO ) THEN
IF( P( J, J ).EQ.ZERO .OR. P( J+1, J+1 ).EQ.ZERO .OR.
$ P( J, J+1 ).NE.ZERO )ILBBAD = .TRUE.
IF( J.LT.N-1 ) THEN
IF( S( J+2, J+1 ).NE.ZERO )
$ ILABAD = .TRUE.
END IF
END IF
20 CONTINUE
*
IF( ILABAD ) THEN
INFO = -5
ELSE IF( ILBBAD ) THEN
INFO = -7
ELSE IF( COMPL .AND. LDVL.LT.N .OR. LDVL.LT.1 ) THEN
INFO = -10
ELSE IF( COMPR .AND. LDVR.LT.N .OR. LDVR.LT.1 ) THEN
INFO = -12
ELSE IF( MM.LT.IM ) THEN
INFO = -13
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STGEVC', -INFO )
RETURN
END IF
*
* Quick return if possible
*
M = IM
IF( N.EQ.0 )
$ RETURN
*
* Machine Constants
*
SAFMIN = SLAMCH( 'Safe minimum' )
BIG = ONE / SAFMIN
CALL SLABAD( SAFMIN, BIG )
ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
SMALL = SAFMIN*N / ULP
BIG = ONE / SMALL
BIGNUM = ONE / ( SAFMIN*N )
*
* Compute the 1-norm of each column of the strictly upper triangular
* part (i.e., excluding all elements belonging to the diagonal
* blocks) of A and B to check for possible overflow in the
* triangular solver.
*
ANORM = ABS( S( 1, 1 ) )
IF( N.GT.1 )
$ ANORM = ANORM + ABS( S( 2, 1 ) )
BNORM = ABS( P( 1, 1 ) )
WORK( 1 ) = ZERO
WORK( N+1 ) = ZERO
*
DO 50 J = 2, N
TEMP = ZERO
TEMP2 = ZERO
IF( S( J, J-1 ).EQ.ZERO ) THEN
IEND = J - 1
ELSE
IEND = J - 2
END IF
DO 30 I = 1, IEND
TEMP = TEMP + ABS( S( I, J ) )
TEMP2 = TEMP2 + ABS( P( I, J ) )
30 CONTINUE
WORK( J ) = TEMP
WORK( N+J ) = TEMP2
DO 40 I = IEND + 1, MIN( J+1, N )
TEMP = TEMP + ABS( S( I, J ) )
TEMP2 = TEMP2 + ABS( P( I, J ) )
40 CONTINUE
ANORM = MAX( ANORM, TEMP )
BNORM = MAX( BNORM, TEMP2 )
50 CONTINUE
*
ASCALE = ONE / MAX( ANORM, SAFMIN )
BSCALE = ONE / MAX( BNORM, SAFMIN )
*
* Left eigenvectors
*
IF( COMPL ) THEN
IEIG = 0
*
* Main loop over eigenvalues
*
ILCPLX = .FALSE.
DO 220 JE = 1, N
*
* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or
* (b) this would be the second of a complex pair.
* Check for complex eigenvalue, so as to be sure of which
* entry(-ies) of SELECT to look at.
*
IF( ILCPLX ) THEN
ILCPLX = .FALSE.
GO TO 220
END IF
NW = 1
IF( JE.LT.N ) THEN
IF( S( JE+1, JE ).NE.ZERO ) THEN
ILCPLX = .TRUE.
NW = 2
END IF
END IF
IF( ILALL ) THEN
ILCOMP = .TRUE.
ELSE IF( ILCPLX ) THEN
ILCOMP = SELECT( JE ) .OR. SELECT( JE+1 )
ELSE
ILCOMP = SELECT( JE )
END IF
IF( .NOT.ILCOMP )
$ GO TO 220
*
* Decide if (a) singular pencil, (b) real eigenvalue, or
* (c) complex eigenvalue.
*
IF( .NOT.ILCPLX ) THEN
IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND.
$ ABS( P( JE, JE ) ).LE.SAFMIN ) THEN
*
* Singular matrix pencil -- return unit eigenvector
*
IEIG = IEIG + 1
DO 60 JR = 1, N
VL( JR, IEIG ) = ZERO
60 CONTINUE
VL( IEIG, IEIG ) = ONE
GO TO 220
END IF
END IF
*
* Clear vector
*
DO 70 JR = 1, NW*N
WORK( 2*N+JR ) = ZERO
70 CONTINUE
* T
* Compute coefficients in ( a A - b B ) y = 0
* a is ACOEF
* b is BCOEFR + i*BCOEFI
*
IF( .NOT.ILCPLX ) THEN
*
* Real eigenvalue
*
TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE,
$ ABS( P( JE, JE ) )*BSCALE, SAFMIN )
SALFAR = ( TEMP*S( JE, JE ) )*ASCALE
SBETA = ( TEMP*P( JE, JE ) )*BSCALE
ACOEF = SBETA*ASCALE
BCOEFR = SALFAR*BSCALE
BCOEFI = ZERO
*
* Scale to avoid underflow
*
SCALE = ONE
LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEF ).LT.SMALL
LSB = ABS( SALFAR ).GE.SAFMIN .AND. ABS( BCOEFR ).LT.
$ SMALL
IF( LSA )
$ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG )
IF( LSB )
$ SCALE = MAX( SCALE, ( SMALL / ABS( SALFAR ) )*
$ MIN( BNORM, BIG ) )
IF( LSA .OR. LSB ) THEN
SCALE = MIN( SCALE, ONE /
$ ( SAFMIN*MAX( ONE, ABS( ACOEF ),
$ ABS( BCOEFR ) ) ) )
IF( LSA ) THEN
ACOEF = ASCALE*( SCALE*SBETA )
ELSE
ACOEF = SCALE*ACOEF
END IF
IF( LSB ) THEN
BCOEFR = BSCALE*( SCALE*SALFAR )
ELSE
BCOEFR = SCALE*BCOEFR
END IF
END IF
ACOEFA = ABS( ACOEF )
BCOEFA = ABS( BCOEFR )
*
* First component is 1
*
WORK( 2*N+JE ) = ONE
XMAX = ONE
ELSE
*
* Complex eigenvalue
*
CALL SLAG2( S( JE, JE ), LDS, P( JE, JE ), LDP,
$ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2,
$ BCOEFI )
BCOEFI = -BCOEFI
IF( BCOEFI.EQ.ZERO ) THEN
INFO = JE
RETURN
END IF
*
* Scale to avoid over/underflow
*
ACOEFA = ABS( ACOEF )
BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
SCALE = ONE
IF( ACOEFA*ULP.LT.SAFMIN .AND. ACOEFA.GE.SAFMIN )
$ SCALE = ( SAFMIN / ULP ) / ACOEFA
IF( BCOEFA*ULP.LT.SAFMIN .AND. BCOEFA.GE.SAFMIN )
$ SCALE = MAX( SCALE, ( SAFMIN / ULP ) / BCOEFA )
IF( SAFMIN*ACOEFA.GT.ASCALE )
$ SCALE = ASCALE / ( SAFMIN*ACOEFA )
IF( SAFMIN*BCOEFA.GT.BSCALE )
$ SCALE = MIN( SCALE, BSCALE / ( SAFMIN*BCOEFA ) )
IF( SCALE.NE.ONE ) THEN
ACOEF = SCALE*ACOEF
ACOEFA = ABS( ACOEF )
BCOEFR = SCALE*BCOEFR
BCOEFI = SCALE*BCOEFI
BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
END IF
*
* Compute first two components of eigenvector
*
TEMP = ACOEF*S( JE+1, JE )
TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE )
TEMP2I = -BCOEFI*P( JE, JE )
IF( ABS( TEMP ).GT.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN
WORK( 2*N+JE ) = ONE
WORK( 3*N+JE ) = ZERO
WORK( 2*N+JE+1 ) = -TEMP2R / TEMP
WORK( 3*N+JE+1 ) = -TEMP2I / TEMP
ELSE
WORK( 2*N+JE+1 ) = ONE
WORK( 3*N+JE+1 ) = ZERO
TEMP = ACOEF*S( JE, JE+1 )
WORK( 2*N+JE ) = ( BCOEFR*P( JE+1, JE+1 )-ACOEF*
$ S( JE+1, JE+1 ) ) / TEMP
WORK( 3*N+JE ) = BCOEFI*P( JE+1, JE+1 ) / TEMP
END IF
XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ),
$ ABS( WORK( 2*N+JE+1 ) )+ABS( WORK( 3*N+JE+1 ) ) )
END IF
*
DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN )
*
* T
* Triangular solve of (a A - b B) y = 0
*
* T
* (rowwise in (a A - b B) , or columnwise in (a A - b B) )
*
IL2BY2 = .FALSE.
*
DO 160 J = JE + NW, N
IF( IL2BY2 ) THEN
IL2BY2 = .FALSE.
GO TO 160
END IF
*
NA = 1
BDIAG( 1 ) = P( J, J )
IF( J.LT.N ) THEN
IF( S( J+1, J ).NE.ZERO ) THEN
IL2BY2 = .TRUE.
BDIAG( 2 ) = P( J+1, J+1 )
NA = 2
END IF
END IF
*
* Check whether scaling is necessary for dot products
*
XSCALE = ONE / MAX( ONE, XMAX )
TEMP = MAX( WORK( J ), WORK( N+J ),
$ ACOEFA*WORK( J )+BCOEFA*WORK( N+J ) )
IF( IL2BY2 )
$ TEMP = MAX( TEMP, WORK( J+1 ), WORK( N+J+1 ),
$ ACOEFA*WORK( J+1 )+BCOEFA*WORK( N+J+1 ) )
IF( TEMP.GT.BIGNUM*XSCALE ) THEN
DO 90 JW = 0, NW - 1
DO 80 JR = JE, J - 1
WORK( ( JW+2 )*N+JR ) = XSCALE*
$ WORK( ( JW+2 )*N+JR )
80 CONTINUE
90 CONTINUE
XMAX = XMAX*XSCALE
END IF
*
* Compute dot products
*
* j-1
* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k)
* k=je
*
* To reduce the op count, this is done as
*
* _ j-1 _ j-1
* a*conjg( sum S(k,j)*x(k) ) - b*conjg( sum P(k,j)*x(k) )
* k=je k=je
*
* which may cause underflow problems if A or B are close
* to underflow. (E.g., less than SMALL.)
*
*
* A series of compiler directives to defeat vectorization
* for the next loop
*
*$PL$ CMCHAR=' '
CDIR$ NEXTSCALAR
C$DIR SCALAR
CDIR$ NEXT SCALAR
CVD$L NOVECTOR
CDEC$ NOVECTOR
CVD$ NOVECTOR
*VDIR NOVECTOR
*VOCL LOOP,SCALAR
CIBM PREFER SCALAR
*$PL$ CMCHAR='*'
*
DO 120 JW = 1, NW
*
*$PL$ CMCHAR=' '
CDIR$ NEXTSCALAR
C$DIR SCALAR
CDIR$ NEXT SCALAR
CVD$L NOVECTOR
CDEC$ NOVECTOR
CVD$ NOVECTOR
*VDIR NOVECTOR
*VOCL LOOP,SCALAR
CIBM PREFER SCALAR
*$PL$ CMCHAR='*'
*
DO 110 JA = 1, NA
SUMS( JA, JW ) = ZERO
SUMP( JA, JW ) = ZERO
*
DO 100 JR = JE, J - 1
SUMS( JA, JW ) = SUMS( JA, JW ) +
$ S( JR, J+JA-1 )*
$ WORK( ( JW+1 )*N+JR )
SUMP( JA, JW ) = SUMP( JA, JW ) +
$ P( JR, J+JA-1 )*
$ WORK( ( JW+1 )*N+JR )
100 CONTINUE
110 CONTINUE
120 CONTINUE
*
*$PL$ CMCHAR=' '
CDIR$ NEXTSCALAR
C$DIR SCALAR
CDIR$ NEXT SCALAR
CVD$L NOVECTOR
CDEC$ NOVECTOR
CVD$ NOVECTOR
*VDIR NOVECTOR
*VOCL LOOP,SCALAR
CIBM PREFER SCALAR
*$PL$ CMCHAR='*'
*
DO 130 JA = 1, NA
IF( ILCPLX ) THEN
SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) +
$ BCOEFR*SUMP( JA, 1 ) -
$ BCOEFI*SUMP( JA, 2 )
SUM( JA, 2 ) = -ACOEF*SUMS( JA, 2 ) +
$ BCOEFR*SUMP( JA, 2 ) +
$ BCOEFI*SUMP( JA, 1 )
ELSE
SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) +
$ BCOEFR*SUMP( JA, 1 )
END IF
130 CONTINUE
*
* T
* Solve ( a A - b B ) y = SUM(,)
* with scaling and perturbation of the denominator
*
CALL SLALN2( .TRUE., NA, NW, DMIN, ACOEF, S( J, J ), LDS,
$ BDIAG( 1 ), BDIAG( 2 ), SUM, 2, BCOEFR,
$ BCOEFI, WORK( 2*N+J ), N, SCALE, TEMP,
$ IINFO )
IF( SCALE.LT.ONE ) THEN
DO 150 JW = 0, NW - 1
DO 140 JR = JE, J - 1
WORK( ( JW+2 )*N+JR ) = SCALE*
$ WORK( ( JW+2 )*N+JR )
140 CONTINUE
150 CONTINUE
XMAX = SCALE*XMAX
END IF
XMAX = MAX( XMAX, TEMP )
160 CONTINUE
*
* Copy eigenvector to VL, back transforming if
* HOWMNY='B'.
*
IEIG = IEIG + 1
IF( ILBACK ) THEN
DO 170 JW = 0, NW - 1
CALL SGEMV( 'N', N, N+1-JE, ONE, VL( 1, JE ), LDVL,
$ WORK( ( JW+2 )*N+JE ), 1, ZERO,
$ WORK( ( JW+4 )*N+1 ), 1 )
170 CONTINUE
CALL SLACPY( ' ', N, NW, WORK( 4*N+1 ), N, VL( 1, JE ),
$ LDVL )
IBEG = 1
ELSE
CALL SLACPY( ' ', N, NW, WORK( 2*N+1 ), N, VL( 1, IEIG ),
$ LDVL )
IBEG = JE
END IF
*
* Scale eigenvector
*
XMAX = ZERO
IF( ILCPLX ) THEN
DO 180 J = IBEG, N
XMAX = MAX( XMAX, ABS( VL( J, IEIG ) )+
$ ABS( VL( J, IEIG+1 ) ) )
180 CONTINUE
ELSE
DO 190 J = IBEG, N
XMAX = MAX( XMAX, ABS( VL( J, IEIG ) ) )
190 CONTINUE
END IF
*
IF( XMAX.GT.SAFMIN ) THEN
XSCALE = ONE / XMAX
*
DO 210 JW = 0, NW - 1
DO 200 JR = IBEG, N
VL( JR, IEIG+JW ) = XSCALE*VL( JR, IEIG+JW )
200 CONTINUE
210 CONTINUE
END IF
IEIG = IEIG + NW - 1
*
220 CONTINUE
END IF
*
* Right eigenvectors
*
IF( COMPR ) THEN
IEIG = IM + 1
*
* Main loop over eigenvalues
*
ILCPLX = .FALSE.
DO 500 JE = N, 1, -1
*
* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or
* (b) this would be the second of a complex pair.
* Check for complex eigenvalue, so as to be sure of which
* entry(-ies) of SELECT to look at -- if complex, SELECT(JE)
* or SELECT(JE-1).
* If this is a complex pair, the 2-by-2 diagonal block
* corresponding to the eigenvalue is in rows/columns JE-1:JE
*
IF( ILCPLX ) THEN
ILCPLX = .FALSE.
GO TO 500
END IF
NW = 1
IF( JE.GT.1 ) THEN
IF( S( JE, JE-1 ).NE.ZERO ) THEN
ILCPLX = .TRUE.
NW = 2
END IF
END IF
IF( ILALL ) THEN
ILCOMP = .TRUE.
ELSE IF( ILCPLX ) THEN
ILCOMP = SELECT( JE ) .OR. SELECT( JE-1 )
ELSE
ILCOMP = SELECT( JE )
END IF
IF( .NOT.ILCOMP )
$ GO TO 500
*
* Decide if (a) singular pencil, (b) real eigenvalue, or
* (c) complex eigenvalue.
*
IF( .NOT.ILCPLX ) THEN
IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND.
$ ABS( P( JE, JE ) ).LE.SAFMIN ) THEN
*
* Singular matrix pencil -- unit eigenvector
*
IEIG = IEIG - 1
DO 230 JR = 1, N
VR( JR, IEIG ) = ZERO
230 CONTINUE
VR( IEIG, IEIG ) = ONE
GO TO 500
END IF
END IF
*
* Clear vector
*
DO 250 JW = 0, NW - 1
DO 240 JR = 1, N
WORK( ( JW+2 )*N+JR ) = ZERO
240 CONTINUE
250 CONTINUE
*
* Compute coefficients in ( a A - b B ) x = 0
* a is ACOEF
* b is BCOEFR + i*BCOEFI
*
IF( .NOT.ILCPLX ) THEN
*
* Real eigenvalue
*
TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE,
$ ABS( P( JE, JE ) )*BSCALE, SAFMIN )
SALFAR = ( TEMP*S( JE, JE ) )*ASCALE
SBETA = ( TEMP*P( JE, JE ) )*BSCALE
ACOEF = SBETA*ASCALE
BCOEFR = SALFAR*BSCALE
BCOEFI = ZERO
*
* Scale to avoid underflow
*
SCALE = ONE
LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEF ).LT.SMALL
LSB = ABS( SALFAR ).GE.SAFMIN .AND. ABS( BCOEFR ).LT.
$ SMALL
IF( LSA )
$ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG )
IF( LSB )
$ SCALE = MAX( SCALE, ( SMALL / ABS( SALFAR ) )*
$ MIN( BNORM, BIG ) )
IF( LSA .OR. LSB ) THEN
SCALE = MIN( SCALE, ONE /
$ ( SAFMIN*MAX( ONE, ABS( ACOEF ),
$ ABS( BCOEFR ) ) ) )
IF( LSA ) THEN
ACOEF = ASCALE*( SCALE*SBETA )
ELSE
ACOEF = SCALE*ACOEF
END IF
IF( LSB ) THEN
BCOEFR = BSCALE*( SCALE*SALFAR )
ELSE
BCOEFR = SCALE*BCOEFR
END IF
END IF
ACOEFA = ABS( ACOEF )
BCOEFA = ABS( BCOEFR )
*
* First component is 1
*
WORK( 2*N+JE ) = ONE
XMAX = ONE
*
* Compute contribution from column JE of A and B to sum
* (See "Further Details", above.)
*
DO 260 JR = 1, JE - 1
WORK( 2*N+JR ) = BCOEFR*P( JR, JE ) -
$ ACOEF*S( JR, JE )
260 CONTINUE
ELSE
*
* Complex eigenvalue
*
CALL SLAG2( S( JE-1, JE-1 ), LDS, P( JE-1, JE-1 ), LDP,
$ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2,
$ BCOEFI )
IF( BCOEFI.EQ.ZERO ) THEN
INFO = JE - 1
RETURN
END IF
*
* Scale to avoid over/underflow
*
ACOEFA = ABS( ACOEF )
BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
SCALE = ONE
IF( ACOEFA*ULP.LT.SAFMIN .AND. ACOEFA.GE.SAFMIN )
$ SCALE = ( SAFMIN / ULP ) / ACOEFA
IF( BCOEFA*ULP.LT.SAFMIN .AND. BCOEFA.GE.SAFMIN )
$ SCALE = MAX( SCALE, ( SAFMIN / ULP ) / BCOEFA )
IF( SAFMIN*ACOEFA.GT.ASCALE )
$ SCALE = ASCALE / ( SAFMIN*ACOEFA )
IF( SAFMIN*BCOEFA.GT.BSCALE )
$ SCALE = MIN( SCALE, BSCALE / ( SAFMIN*BCOEFA ) )
IF( SCALE.NE.ONE ) THEN
ACOEF = SCALE*ACOEF
ACOEFA = ABS( ACOEF )
BCOEFR = SCALE*BCOEFR
BCOEFI = SCALE*BCOEFI
BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
END IF
*
* Compute first two components of eigenvector
* and contribution to sums
*
TEMP = ACOEF*S( JE, JE-1 )
TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE )
TEMP2I = -BCOEFI*P( JE, JE )
IF( ABS( TEMP ).GE.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN
WORK( 2*N+JE ) = ONE
WORK( 3*N+JE ) = ZERO
WORK( 2*N+JE-1 ) = -TEMP2R / TEMP
WORK( 3*N+JE-1 ) = -TEMP2I / TEMP
ELSE
WORK( 2*N+JE-1 ) = ONE
WORK( 3*N+JE-1 ) = ZERO
TEMP = ACOEF*S( JE-1, JE )
WORK( 2*N+JE ) = ( BCOEFR*P( JE-1, JE-1 )-ACOEF*
$ S( JE-1, JE-1 ) ) / TEMP
WORK( 3*N+JE ) = BCOEFI*P( JE-1, JE-1 ) / TEMP
END IF
*
XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ),
$ ABS( WORK( 2*N+JE-1 ) )+ABS( WORK( 3*N+JE-1 ) ) )
*
* Compute contribution from columns JE and JE-1
* of A and B to the sums.
*
CREALA = ACOEF*WORK( 2*N+JE-1 )
CIMAGA = ACOEF*WORK( 3*N+JE-1 )
CREALB = BCOEFR*WORK( 2*N+JE-1 ) -
$ BCOEFI*WORK( 3*N+JE-1 )
CIMAGB = BCOEFI*WORK( 2*N+JE-1 ) +
$ BCOEFR*WORK( 3*N+JE-1 )
CRE2A = ACOEF*WORK( 2*N+JE )
CIM2A = ACOEF*WORK( 3*N+JE )
CRE2B = BCOEFR*WORK( 2*N+JE ) - BCOEFI*WORK( 3*N+JE )
CIM2B = BCOEFI*WORK( 2*N+JE ) + BCOEFR*WORK( 3*N+JE )
DO 270 JR = 1, JE - 2
WORK( 2*N+JR ) = -CREALA*S( JR, JE-1 ) +
$ CREALB*P( JR, JE-1 ) -
$ CRE2A*S( JR, JE ) + CRE2B*P( JR, JE )
WORK( 3*N+JR ) = -CIMAGA*S( JR, JE-1 ) +
$ CIMAGB*P( JR, JE-1 ) -
$ CIM2A*S( JR, JE ) + CIM2B*P( JR, JE )
270 CONTINUE
END IF
*
DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN )
*
* Columnwise triangular solve of (a A - b B) x = 0
*
IL2BY2 = .FALSE.
DO 370 J = JE - NW, 1, -1
*
* If a 2-by-2 block, is in position j-1:j, wait until
* next iteration to process it (when it will be j:j+1)
*
IF( .NOT.IL2BY2 .AND. J.GT.1 ) THEN
IF( S( J, J-1 ).NE.ZERO ) THEN
IL2BY2 = .TRUE.
GO TO 370
END IF
END IF
BDIAG( 1 ) = P( J, J )
IF( IL2BY2 ) THEN
NA = 2
BDIAG( 2 ) = P( J+1, J+1 )
ELSE
NA = 1
END IF
*
* Compute x(j) (and x(j+1), if 2-by-2 block)
*
CALL SLALN2( .FALSE., NA, NW, DMIN, ACOEF, S( J, J ),
$ LDS, BDIAG( 1 ), BDIAG( 2 ), WORK( 2*N+J ),
$ N, BCOEFR, BCOEFI, SUM, 2, SCALE, TEMP,
$ IINFO )
IF( SCALE.LT.ONE ) THEN
*
DO 290 JW = 0, NW - 1
DO 280 JR = 1, JE
WORK( ( JW+2 )*N+JR ) = SCALE*
$ WORK( ( JW+2 )*N+JR )
280 CONTINUE
290 CONTINUE
END IF
XMAX = MAX( SCALE*XMAX, TEMP )
*
DO 310 JW = 1, NW
DO 300 JA = 1, NA
WORK( ( JW+1 )*N+J+JA-1 ) = SUM( JA, JW )
300 CONTINUE
310 CONTINUE
*
* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling
*
IF( J.GT.1 ) THEN
*
* Check whether scaling is necessary for sum.
*
XSCALE = ONE / MAX( ONE, XMAX )
TEMP = ACOEFA*WORK( J ) + BCOEFA*WORK( N+J )
IF( IL2BY2 )
$ TEMP = MAX( TEMP, ACOEFA*WORK( J+1 )+BCOEFA*
$ WORK( N+J+1 ) )
TEMP = MAX( TEMP, ACOEFA, BCOEFA )
IF( TEMP.GT.BIGNUM*XSCALE ) THEN
*
DO 330 JW = 0, NW - 1
DO 320 JR = 1, JE
WORK( ( JW+2 )*N+JR ) = XSCALE*
$ WORK( ( JW+2 )*N+JR )
320 CONTINUE
330 CONTINUE
XMAX = XMAX*XSCALE
END IF
*
* Compute the contributions of the off-diagonals of
* column j (and j+1, if 2-by-2 block) of A and B to the
* sums.
*
*
DO 360 JA = 1, NA
IF( ILCPLX ) THEN
CREALA = ACOEF*WORK( 2*N+J+JA-1 )
CIMAGA = ACOEF*WORK( 3*N+J+JA-1 )
CREALB = BCOEFR*WORK( 2*N+J+JA-1 ) -
$ BCOEFI*WORK( 3*N+J+JA-1 )
CIMAGB = BCOEFI*WORK( 2*N+J+JA-1 ) +
$ BCOEFR*WORK( 3*N+J+JA-1 )
DO 340 JR = 1, J - 1
WORK( 2*N+JR ) = WORK( 2*N+JR ) -
$ CREALA*S( JR, J+JA-1 ) +
$ CREALB*P( JR, J+JA-1 )
WORK( 3*N+JR ) = WORK( 3*N+JR ) -
$ CIMAGA*S( JR, J+JA-1 ) +
$ CIMAGB*P( JR, J+JA-1 )
340 CONTINUE
ELSE
CREALA = ACOEF*WORK( 2*N+J+JA-1 )
CREALB = BCOEFR*WORK( 2*N+J+JA-1 )
DO 350 JR = 1, J - 1
WORK( 2*N+JR ) = WORK( 2*N+JR ) -
$ CREALA*S( JR, J+JA-1 ) +
$ CREALB*P( JR, J+JA-1 )
350 CONTINUE
END IF
360 CONTINUE
END IF
*
IL2BY2 = .FALSE.
370 CONTINUE
*
* Copy eigenvector to VR, back transforming if
* HOWMNY='B'.
*
IEIG = IEIG - NW
IF( ILBACK ) THEN
*
DO 410 JW = 0, NW - 1
DO 380 JR = 1, N
WORK( ( JW+4 )*N+JR ) = WORK( ( JW+2 )*N+1 )*
$ VR( JR, 1 )
380 CONTINUE
*
* A series of compiler directives to defeat
* vectorization for the next loop
*
*
DO 400 JC = 2, JE
DO 390 JR = 1, N
WORK( ( JW+4 )*N+JR ) = WORK( ( JW+4 )*N+JR ) +
$ WORK( ( JW+2 )*N+JC )*VR( JR, JC )
390 CONTINUE
400 CONTINUE
410 CONTINUE
*
DO 430 JW = 0, NW - 1
DO 420 JR = 1, N
VR( JR, IEIG+JW ) = WORK( ( JW+4 )*N+JR )
420 CONTINUE
430 CONTINUE
*
IEND = N
ELSE
DO 450 JW = 0, NW - 1
DO 440 JR = 1, N
VR( JR, IEIG+JW ) = WORK( ( JW+2 )*N+JR )
440 CONTINUE
450 CONTINUE
*
IEND = JE
END IF
*
* Scale eigenvector
*
XMAX = ZERO
IF( ILCPLX ) THEN
DO 460 J = 1, IEND
XMAX = MAX( XMAX, ABS( VR( J, IEIG ) )+
$ ABS( VR( J, IEIG+1 ) ) )
460 CONTINUE
ELSE
DO 470 J = 1, IEND
XMAX = MAX( XMAX, ABS( VR( J, IEIG ) ) )
470 CONTINUE
END IF
*
IF( XMAX.GT.SAFMIN ) THEN
XSCALE = ONE / XMAX
DO 490 JW = 0, NW - 1
DO 480 JR = 1, IEND
VR( JR, IEIG+JW ) = XSCALE*VR( JR, IEIG+JW )
480 CONTINUE
490 CONTINUE
END IF
500 CONTINUE
END IF
*
RETURN
*
* End of STGEVC
*
END
SUBROUTINE STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
$ LDZ, J1, N1, N2, WORK, LWORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL WANTQ, WANTZ
INTEGER INFO, J1, LDA, LDB, LDQ, LDZ, LWORK, N, N1, N2
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
$ WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* STGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22)
* of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair
* (A, B) by an orthogonal equivalence transformation.
*
* (A, B) must be in generalized real Schur canonical form (as returned
* by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2
* diagonal blocks. B is upper triangular.
*
* Optionally, the matrices Q and Z of generalized Schur vectors are
* updated.
*
* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'
* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'
*
*
* Arguments
* =========
*
* WANTQ (input) LOGICAL
* .TRUE. : update the left transformation matrix Q;
* .FALSE.: do not update Q.
*
* WANTZ (input) LOGICAL
* .TRUE. : update the right transformation matrix Z;
* .FALSE.: do not update Z.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* A (input/output) REAL arrays, dimensions (LDA,N)
* On entry, the matrix A in the pair (A, B).
* On exit, the updated matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input/output) REAL arrays, dimensions (LDB,N)
* On entry, the matrix B in the pair (A, B).
* On exit, the updated matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* Q (input/output) REAL array, dimension (LDZ,N)
* On entry, if WANTQ = .TRUE., the orthogonal matrix Q.
* On exit, the updated matrix Q.
* Not referenced if WANTQ = .FALSE..
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= 1.
* If WANTQ = .TRUE., LDQ >= N.
*
* Z (input/output) REAL array, dimension (LDZ,N)
* On entry, if WANTZ =.TRUE., the orthogonal matrix Z.
* On exit, the updated matrix Z.
* Not referenced if WANTZ = .FALSE..
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1.
* If WANTZ = .TRUE., LDZ >= N.
*
* J1 (input) INTEGER
* The index to the first block (A11, B11). 1 <= J1 <= N.
*
* N1 (input) INTEGER
* The order of the first block (A11, B11). N1 = 0, 1 or 2.
*
* N2 (input) INTEGER
* The order of the second block (A22, B22). N2 = 0, 1 or 2.
*
* WORK (workspace) REAL array, dimension (MAX(1,LWORK)).
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* LWORK >= MAX( N*(N2+N1), (N2+N1)*(N2+N1)*2 )
*
* INFO (output) INTEGER
* =0: Successful exit
* >0: If INFO = 1, the transformed matrix (A, B) would be
* too far from generalized Schur form; the blocks are
* not swapped and (A, B) and (Q, Z) are unchanged.
* The problem of swapping is too ill-conditioned.
* <0: If INFO = -16: LWORK is too small. Appropriate value
* for LWORK is returned in WORK(1).
*
* Further Details
* ===============
*
* Based on contributions by
* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
* Umea University, S-901 87 Umea, Sweden.
*
* In the current code both weak and strong stability tests are
* performed. The user can omit the strong stability test by changing
* the internal logical parameter WANDS to .FALSE.. See ref. [2] for
* details.
*
* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
*
* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
* Eigenvalues of a Regular Matrix Pair (A, B) and Condition
* Estimation: Theory, Algorithms and Software,
* Report UMINF - 94.04, Department of Computing Science, Umea
* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working
* Note 87. To appear in Numerical Algorithms, 1996.
*
* =====================================================================
* Replaced various illegal calls to SCOPY by calls to SLASET, or by DO
* loops. Sven Hammarling, 1/5/02.
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
REAL TEN
PARAMETER ( TEN = 1.0E+01 )
INTEGER LDST
PARAMETER ( LDST = 4 )
LOGICAL WANDS
PARAMETER ( WANDS = .TRUE. )
* ..
* .. Local Scalars ..
LOGICAL STRONG, WEAK
INTEGER I, IDUM, LINFO, M
REAL BQRA21, BRQA21, DDUM, DNORM, DSCALE, DSUM, EPS,
$ F, G, SA, SB, SCALE, SMLNUM, SS, THRESH, WS
* ..
* .. Local Arrays ..
INTEGER IWORK( LDST )
REAL AI( 2 ), AR( 2 ), BE( 2 ), IR( LDST, LDST ),
$ IRCOP( LDST, LDST ), LI( LDST, LDST ),
$ LICOP( LDST, LDST ), S( LDST, LDST ),
$ SCPY( LDST, LDST ), T( LDST, LDST ),
$ TAUL( LDST ), TAUR( LDST ), TCPY( LDST, LDST )
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SGEQR2, SGERQ2, SLACPY, SLAGV2, SLARTG,
$ SLASET, SLASSQ, SORG2R, SORGR2, SORM2R, SORMR2,
$ SROT, SSCAL, STGSY2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Quick return if possible
*
IF( N.LE.1 .OR. N1.LE.0 .OR. N2.LE.0 )
$ RETURN
IF( N1.GT.N .OR. ( J1+N1 ).GT.N )
$ RETURN
M = N1 + N2
IF( LWORK.LT.MAX( N*M, M*M*2 ) ) THEN
INFO = -16
WORK( 1 ) = MAX( N*M, M*M*2 )
RETURN
END IF
*
WEAK = .FALSE.
STRONG = .FALSE.
*
* Make a local copy of selected block
*
CALL SLASET( 'Full', LDST, LDST, ZERO, ZERO, LI, LDST )
CALL SLASET( 'Full', LDST, LDST, ZERO, ZERO, IR, LDST )
CALL SLACPY( 'Full', M, M, A( J1, J1 ), LDA, S, LDST )
CALL SLACPY( 'Full', M, M, B( J1, J1 ), LDB, T, LDST )
*
* Compute threshold for testing acceptance of swapping.
*
EPS = SLAMCH( 'P' )
SMLNUM = SLAMCH( 'S' ) / EPS
DSCALE = ZERO
DSUM = ONE
CALL SLACPY( 'Full', M, M, S, LDST, WORK, M )
CALL SLASSQ( M*M, WORK, 1, DSCALE, DSUM )
CALL SLACPY( 'Full', M, M, T, LDST, WORK, M )
CALL SLASSQ( M*M, WORK, 1, DSCALE, DSUM )
DNORM = DSCALE*SQRT( DSUM )
THRESH = MAX( TEN*EPS*DNORM, SMLNUM )
*
IF( M.EQ.2 ) THEN
*
* CASE 1: Swap 1-by-1 and 1-by-1 blocks.
*
* Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks
* using Givens rotations and perform the swap tentatively.
*
F = S( 2, 2 )*T( 1, 1 ) - T( 2, 2 )*S( 1, 1 )
G = S( 2, 2 )*T( 1, 2 ) - T( 2, 2 )*S( 1, 2 )
SB = ABS( T( 2, 2 ) )
SA = ABS( S( 2, 2 ) )
CALL SLARTG( F, G, IR( 1, 2 ), IR( 1, 1 ), DDUM )
IR( 2, 1 ) = -IR( 1, 2 )
IR( 2, 2 ) = IR( 1, 1 )
CALL SROT( 2, S( 1, 1 ), 1, S( 1, 2 ), 1, IR( 1, 1 ),
$ IR( 2, 1 ) )
CALL SROT( 2, T( 1, 1 ), 1, T( 1, 2 ), 1, IR( 1, 1 ),
$ IR( 2, 1 ) )
IF( SA.GE.SB ) THEN
CALL SLARTG( S( 1, 1 ), S( 2, 1 ), LI( 1, 1 ), LI( 2, 1 ),
$ DDUM )
ELSE
CALL SLARTG( T( 1, 1 ), T( 2, 1 ), LI( 1, 1 ), LI( 2, 1 ),
$ DDUM )
END IF
CALL SROT( 2, S( 1, 1 ), LDST, S( 2, 1 ), LDST, LI( 1, 1 ),
$ LI( 2, 1 ) )
CALL SROT( 2, T( 1, 1 ), LDST, T( 2, 1 ), LDST, LI( 1, 1 ),
$ LI( 2, 1 ) )
LI( 2, 2 ) = LI( 1, 1 )
LI( 1, 2 ) = -LI( 2, 1 )
*
* Weak stability test:
* |S21| + |T21| <= O(EPS * F-norm((S, T)))
*
WS = ABS( S( 2, 1 ) ) + ABS( T( 2, 1 ) )
WEAK = WS.LE.THRESH
IF( .NOT.WEAK )
$ GO TO 70
*
IF( WANDS ) THEN
*
* Strong stability test:
* F-norm((A-QL'*S*QR, B-QL'*T*QR)) <= O(EPS*F-norm((A,B)))
*
CALL SLACPY( 'Full', M, M, A( J1, J1 ), LDA, WORK( M*M+1 ),
$ M )
CALL SGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO,
$ WORK, M )
CALL SGEMM( 'N', 'T', M, M, M, -ONE, WORK, M, IR, LDST, ONE,
$ WORK( M*M+1 ), M )
DSCALE = ZERO
DSUM = ONE
CALL SLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
*
CALL SLACPY( 'Full', M, M, B( J1, J1 ), LDB, WORK( M*M+1 ),
$ M )
CALL SGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO,
$ WORK, M )
CALL SGEMM( 'N', 'T', M, M, M, -ONE, WORK, M, IR, LDST, ONE,
$ WORK( M*M+1 ), M )
CALL SLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
SS = DSCALE*SQRT( DSUM )
STRONG = SS.LE.THRESH
IF( .NOT.STRONG )
$ GO TO 70
END IF
*
* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and
* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)).
*
CALL SROT( J1+1, A( 1, J1 ), 1, A( 1, J1+1 ), 1, IR( 1, 1 ),
$ IR( 2, 1 ) )
CALL SROT( J1+1, B( 1, J1 ), 1, B( 1, J1+1 ), 1, IR( 1, 1 ),
$ IR( 2, 1 ) )
CALL SROT( N-J1+1, A( J1, J1 ), LDA, A( J1+1, J1 ), LDA,
$ LI( 1, 1 ), LI( 2, 1 ) )
CALL SROT( N-J1+1, B( J1, J1 ), LDB, B( J1+1, J1 ), LDB,
$ LI( 1, 1 ), LI( 2, 1 ) )
*
* Set N1-by-N2 (2,1) - blocks to ZERO.
*
A( J1+1, J1 ) = ZERO
B( J1+1, J1 ) = ZERO
*
* Accumulate transformations into Q and Z if requested.
*
IF( WANTZ )
$ CALL SROT( N, Z( 1, J1 ), 1, Z( 1, J1+1 ), 1, IR( 1, 1 ),
$ IR( 2, 1 ) )
IF( WANTQ )
$ CALL SROT( N, Q( 1, J1 ), 1, Q( 1, J1+1 ), 1, LI( 1, 1 ),
$ LI( 2, 1 ) )
*
* Exit with INFO = 0 if swap was successfully performed.
*
RETURN
*
ELSE
*
* CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2
* and 2-by-2 blocks.
*
* Solve the generalized Sylvester equation
* S11 * R - L * S22 = SCALE * S12
* T11 * R - L * T22 = SCALE * T12
* for R and L. Solutions in LI and IR.
*
CALL SLACPY( 'Full', N1, N2, T( 1, N1+1 ), LDST, LI, LDST )
CALL SLACPY( 'Full', N1, N2, S( 1, N1+1 ), LDST,
$ IR( N2+1, N1+1 ), LDST )
CALL STGSY2( 'N', 0, N1, N2, S, LDST, S( N1+1, N1+1 ), LDST,
$ IR( N2+1, N1+1 ), LDST, T, LDST, T( N1+1, N1+1 ),
$ LDST, LI, LDST, SCALE, DSUM, DSCALE, IWORK, IDUM,
$ LINFO )
*
* Compute orthogonal matrix QL:
*
* QL' * LI = [ TL ]
* [ 0 ]
* where
* LI = [ -L ]
* [ SCALE * identity(N2) ]
*
DO 10 I = 1, N2
CALL SSCAL( N1, -ONE, LI( 1, I ), 1 )
LI( N1+I, I ) = SCALE
10 CONTINUE
CALL SGEQR2( M, N2, LI, LDST, TAUL, WORK, LINFO )
IF( LINFO.NE.0 )
$ GO TO 70
CALL SORG2R( M, M, N2, LI, LDST, TAUL, WORK, LINFO )
IF( LINFO.NE.0 )
$ GO TO 70
*
* Compute orthogonal matrix RQ:
*
* IR * RQ' = [ 0 TR],
*
* where IR = [ SCALE * identity(N1), R ]
*
DO 20 I = 1, N1
IR( N2+I, I ) = SCALE
20 CONTINUE
CALL SGERQ2( N1, M, IR( N2+1, 1 ), LDST, TAUR, WORK, LINFO )
IF( LINFO.NE.0 )
$ GO TO 70
CALL SORGR2( M, M, N1, IR, LDST, TAUR, WORK, LINFO )
IF( LINFO.NE.0 )
$ GO TO 70
*
* Perform the swapping tentatively:
*
CALL SGEMM( 'T', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO,
$ WORK, M )
CALL SGEMM( 'N', 'T', M, M, M, ONE, WORK, M, IR, LDST, ZERO, S,
$ LDST )
CALL SGEMM( 'T', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO,
$ WORK, M )
CALL SGEMM( 'N', 'T', M, M, M, ONE, WORK, M, IR, LDST, ZERO, T,
$ LDST )
CALL SLACPY( 'F', M, M, S, LDST, SCPY, LDST )
CALL SLACPY( 'F', M, M, T, LDST, TCPY, LDST )
CALL SLACPY( 'F', M, M, IR, LDST, IRCOP, LDST )
CALL SLACPY( 'F', M, M, LI, LDST, LICOP, LDST )
*
* Triangularize the B-part by an RQ factorization.
* Apply transformation (from left) to A-part, giving S.
*
CALL SGERQ2( M, M, T, LDST, TAUR, WORK, LINFO )
IF( LINFO.NE.0 )
$ GO TO 70
CALL SORMR2( 'R', 'T', M, M, M, T, LDST, TAUR, S, LDST, WORK,
$ LINFO )
IF( LINFO.NE.0 )
$ GO TO 70
CALL SORMR2( 'L', 'N', M, M, M, T, LDST, TAUR, IR, LDST, WORK,
$ LINFO )
IF( LINFO.NE.0 )
$ GO TO 70
*
* Compute F-norm(S21) in BRQA21. (T21 is 0.)
*
DSCALE = ZERO
DSUM = ONE
DO 30 I = 1, N2
CALL SLASSQ( N1, S( N2+1, I ), 1, DSCALE, DSUM )
30 CONTINUE
BRQA21 = DSCALE*SQRT( DSUM )
*
* Triangularize the B-part by a QR factorization.
* Apply transformation (from right) to A-part, giving S.
*
CALL SGEQR2( M, M, TCPY, LDST, TAUL, WORK, LINFO )
IF( LINFO.NE.0 )
$ GO TO 70
CALL SORM2R( 'L', 'T', M, M, M, TCPY, LDST, TAUL, SCPY, LDST,
$ WORK, INFO )
CALL SORM2R( 'R', 'N', M, M, M, TCPY, LDST, TAUL, LICOP, LDST,
$ WORK, INFO )
IF( LINFO.NE.0 )
$ GO TO 70
*
* Compute F-norm(S21) in BQRA21. (T21 is 0.)
*
DSCALE = ZERO
DSUM = ONE
DO 40 I = 1, N2
CALL SLASSQ( N1, SCPY( N2+1, I ), 1, DSCALE, DSUM )
40 CONTINUE
BQRA21 = DSCALE*SQRT( DSUM )
*
* Decide which method to use.
* Weak stability test:
* F-norm(S21) <= O(EPS * F-norm((S, T)))
*
IF( BQRA21.LE.BRQA21 .AND. BQRA21.LE.THRESH ) THEN
CALL SLACPY( 'F', M, M, SCPY, LDST, S, LDST )
CALL SLACPY( 'F', M, M, TCPY, LDST, T, LDST )
CALL SLACPY( 'F', M, M, IRCOP, LDST, IR, LDST )
CALL SLACPY( 'F', M, M, LICOP, LDST, LI, LDST )
ELSE IF( BRQA21.GE.THRESH ) THEN
GO TO 70
END IF
*
* Set lower triangle of B-part to zero
*
CALL SLASET( 'Lower', M-1, M-1, ZERO, ZERO, T(2,1), LDST )
*
IF( WANDS ) THEN
*
* Strong stability test:
* F-norm((A-QL*S*QR', B-QL*T*QR')) <= O(EPS*F-norm((A,B)))
*
CALL SLACPY( 'Full', M, M, A( J1, J1 ), LDA, WORK( M*M+1 ),
$ M )
CALL SGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO,
$ WORK, M )
CALL SGEMM( 'N', 'N', M, M, M, -ONE, WORK, M, IR, LDST, ONE,
$ WORK( M*M+1 ), M )
DSCALE = ZERO
DSUM = ONE
CALL SLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
*
CALL SLACPY( 'Full', M, M, B( J1, J1 ), LDB, WORK( M*M+1 ),
$ M )
CALL SGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO,
$ WORK, M )
CALL SGEMM( 'N', 'N', M, M, M, -ONE, WORK, M, IR, LDST, ONE,
$ WORK( M*M+1 ), M )
CALL SLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
SS = DSCALE*SQRT( DSUM )
STRONG = ( SS.LE.THRESH )
IF( .NOT.STRONG )
$ GO TO 70
*
END IF
*
* If the swap is accepted ("weakly" and "strongly"), apply the
* transformations and set N1-by-N2 (2,1)-block to zero.
*
CALL SLASET( 'Full', N1, N2, ZERO, ZERO, S(N2+1,1), LDST )
*
* copy back M-by-M diagonal block starting at index J1 of (A, B)
*
CALL SLACPY( 'F', M, M, S, LDST, A( J1, J1 ), LDA )
CALL SLACPY( 'F', M, M, T, LDST, B( J1, J1 ), LDB )
CALL SLASET( 'Full', LDST, LDST, ZERO, ZERO, T, LDST )
*
* Standardize existing 2-by-2 blocks.
*
DO 50 I = 1, M*M
WORK(I) = ZERO
50 CONTINUE
WORK( 1 ) = ONE
T( 1, 1 ) = ONE
IDUM = LWORK - M*M - 2
IF( N2.GT.1 ) THEN
CALL SLAGV2( A( J1, J1 ), LDA, B( J1, J1 ), LDB, AR, AI, BE,
$ WORK( 1 ), WORK( 2 ), T( 1, 1 ), T( 2, 1 ) )
WORK( M+1 ) = -WORK( 2 )
WORK( M+2 ) = WORK( 1 )
T( N2, N2 ) = T( 1, 1 )
T( 1, 2 ) = -T( 2, 1 )
END IF
WORK( M*M ) = ONE
T( M, M ) = ONE
*
IF( N1.GT.1 ) THEN
CALL SLAGV2( A( J1+N2, J1+N2 ), LDA, B( J1+N2, J1+N2 ), LDB,
$ TAUR, TAUL, WORK( M*M+1 ), WORK( N2*M+N2+1 ),
$ WORK( N2*M+N2+2 ), T( N2+1, N2+1 ),
$ T( M, M-1 ) )
WORK( M*M ) = WORK( N2*M+N2+1 )
WORK( M*M-1 ) = -WORK( N2*M+N2+2 )
T( M, M ) = T( N2+1, N2+1 )
T( M-1, M ) = -T( M, M-1 )
END IF
CALL SGEMM( 'T', 'N', N2, N1, N2, ONE, WORK, M, A( J1, J1+N2 ),
$ LDA, ZERO, WORK( M*M+1 ), N2 )
CALL SLACPY( 'Full', N2, N1, WORK( M*M+1 ), N2, A( J1, J1+N2 ),
$ LDA )
CALL SGEMM( 'T', 'N', N2, N1, N2, ONE, WORK, M, B( J1, J1+N2 ),
$ LDB, ZERO, WORK( M*M+1 ), N2 )
CALL SLACPY( 'Full', N2, N1, WORK( M*M+1 ), N2, B( J1, J1+N2 ),
$ LDB )
CALL SGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, WORK, M, ZERO,
$ WORK( M*M+1 ), M )
CALL SLACPY( 'Full', M, M, WORK( M*M+1 ), M, LI, LDST )
CALL SGEMM( 'N', 'N', N2, N1, N1, ONE, A( J1, J1+N2 ), LDA,
$ T( N2+1, N2+1 ), LDST, ZERO, WORK, N2 )
CALL SLACPY( 'Full', N2, N1, WORK, N2, A( J1, J1+N2 ), LDA )
CALL SGEMM( 'N', 'N', N2, N1, N1, ONE, B( J1, J1+N2 ), LDB,
$ T( N2+1, N2+1 ), LDST, ZERO, WORK, N2 )
CALL SLACPY( 'Full', N2, N1, WORK, N2, B( J1, J1+N2 ), LDB )
CALL SGEMM( 'T', 'N', M, M, M, ONE, IR, LDST, T, LDST, ZERO,
$ WORK, M )
CALL SLACPY( 'Full', M, M, WORK, M, IR, LDST )
*
* Accumulate transformations into Q and Z if requested.
*
IF( WANTQ ) THEN
CALL SGEMM( 'N', 'N', N, M, M, ONE, Q( 1, J1 ), LDQ, LI,
$ LDST, ZERO, WORK, N )
CALL SLACPY( 'Full', N, M, WORK, N, Q( 1, J1 ), LDQ )
*
END IF
*
IF( WANTZ ) THEN
CALL SGEMM( 'N', 'N', N, M, M, ONE, Z( 1, J1 ), LDZ, IR,
$ LDST, ZERO, WORK, N )
CALL SLACPY( 'Full', N, M, WORK, N, Z( 1, J1 ), LDZ )
*
END IF
*
* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and
* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)).
*
I = J1 + M
IF( I.LE.N ) THEN
CALL SGEMM( 'T', 'N', M, N-I+1, M, ONE, LI, LDST,
$ A( J1, I ), LDA, ZERO, WORK, M )
CALL SLACPY( 'Full', M, N-I+1, WORK, M, A( J1, I ), LDA )
CALL SGEMM( 'T', 'N', M, N-I+1, M, ONE, LI, LDST,
$ B( J1, I ), LDB, ZERO, WORK, M )
CALL SLACPY( 'Full', M, N-I+1, WORK, M, B( J1, I ), LDB )
END IF
I = J1 - 1
IF( I.GT.0 ) THEN
CALL SGEMM( 'N', 'N', I, M, M, ONE, A( 1, J1 ), LDA, IR,
$ LDST, ZERO, WORK, I )
CALL SLACPY( 'Full', I, M, WORK, I, A( 1, J1 ), LDA )
CALL SGEMM( 'N', 'N', I, M, M, ONE, B( 1, J1 ), LDB, IR,
$ LDST, ZERO, WORK, I )
CALL SLACPY( 'Full', I, M, WORK, I, B( 1, J1 ), LDB )
END IF
*
* Exit with INFO = 0 if swap was successfully performed.
*
RETURN
*
END IF
*
* Exit with INFO = 1 if swap was rejected.
*
70 CONTINUE
*
INFO = 1
RETURN
*
* End of STGEX2
*
END
SUBROUTINE STGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
$ LDZ, IFST, ILST, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL WANTQ, WANTZ
INTEGER IFST, ILST, INFO, LDA, LDB, LDQ, LDZ, LWORK, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
$ WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* STGEXC reorders the generalized real Schur decomposition of a real
* matrix pair (A,B) using an orthogonal equivalence transformation
*
* (A, B) = Q * (A, B) * Z',
*
* so that the diagonal block of (A, B) with row index IFST is moved
* to row ILST.
*
* (A, B) must be in generalized real Schur canonical form (as returned
* by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2
* diagonal blocks. B is upper triangular.
*
* Optionally, the matrices Q and Z of generalized Schur vectors are
* updated.
*
* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'
* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'
*
*
* Arguments
* =========
*
* WANTQ (input) LOGICAL
* .TRUE. : update the left transformation matrix Q;
* .FALSE.: do not update Q.
*
* WANTZ (input) LOGICAL
* .TRUE. : update the right transformation matrix Z;
* .FALSE.: do not update Z.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the matrix A in generalized real Schur canonical
* form.
* On exit, the updated matrix A, again in generalized
* real Schur canonical form.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input/output) REAL array, dimension (LDB,N)
* On entry, the matrix B in generalized real Schur canonical
* form (A,B).
* On exit, the updated matrix B, again in generalized
* real Schur canonical form (A,B).
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* Q (input/output) REAL array, dimension (LDZ,N)
* On entry, if WANTQ = .TRUE., the orthogonal matrix Q.
* On exit, the updated matrix Q.
* If WANTQ = .FALSE., Q is not referenced.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= 1.
* If WANTQ = .TRUE., LDQ >= N.
*
* Z (input/output) REAL array, dimension (LDZ,N)
* On entry, if WANTZ = .TRUE., the orthogonal matrix Z.
* On exit, the updated matrix Z.
* If WANTZ = .FALSE., Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1.
* If WANTZ = .TRUE., LDZ >= N.
*
* IFST (input/output) INTEGER
* ILST (input/output) INTEGER
* Specify the reordering of the diagonal blocks of (A, B).
* The block with row index IFST is moved to row ILST, by a
* sequence of swapping between adjacent blocks.
* On exit, if IFST pointed on entry to the second row of
* a 2-by-2 block, it is changed to point to the first row;
* ILST always points to the first row of the block in its
* final position (which may differ from its input value by
* +1 or -1). 1 <= IFST, ILST <= N.
*
* WORK (workspace/output) REAL 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 >= 1 when N <= 1, otherwise LWORK >= 4*N + 16.
*
* 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.
* =1: The transformed matrix pair (A, B) would be too far
* from generalized Schur form; the problem is ill-
* conditioned. (A, B) may have been partially reordered,
* and ILST points to the first row of the current
* position of the block being moved.
*
* Further Details
* ===============
*
* Based on contributions by
* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
* Umea University, S-901 87 Umea, Sweden.
*
* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER HERE, LWMIN, NBF, NBL, NBNEXT
* ..
* .. External Subroutines ..
EXTERNAL STGEX2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Decode and test input arguments.
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDQ.LT.1 .OR. WANTQ .AND. ( LDQ.LT.MAX( 1, N ) ) ) THEN
INFO = -9
ELSE IF( LDZ.LT.1 .OR. WANTZ .AND. ( LDZ.LT.MAX( 1, N ) ) ) THEN
INFO = -11
ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN
INFO = -12
ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN
INFO = -13
END IF
*
IF( INFO.EQ.0 ) THEN
IF( N.LE.1 ) THEN
LWMIN = 1
ELSE
LWMIN = 4*N + 16
END IF
WORK(1) = LWMIN
*
IF (LWORK.LT.LWMIN .AND. .NOT.LQUERY) THEN
INFO = -15
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STGEXC', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.1 )
$ RETURN
*
* Determine the first row of the specified block and find out
* if it is 1-by-1 or 2-by-2.
*
IF( IFST.GT.1 ) THEN
IF( A( IFST, IFST-1 ).NE.ZERO )
$ IFST = IFST - 1
END IF
NBF = 1
IF( IFST.LT.N ) THEN
IF( A( IFST+1, IFST ).NE.ZERO )
$ NBF = 2
END IF
*
* Determine the first row of the final block
* and find out if it is 1-by-1 or 2-by-2.
*
IF( ILST.GT.1 ) THEN
IF( A( ILST, ILST-1 ).NE.ZERO )
$ ILST = ILST - 1
END IF
NBL = 1
IF( ILST.LT.N ) THEN
IF( A( ILST+1, ILST ).NE.ZERO )
$ NBL = 2
END IF
IF( IFST.EQ.ILST )
$ RETURN
*
IF( IFST.LT.ILST ) THEN
*
* Update ILST.
*
IF( NBF.EQ.2 .AND. NBL.EQ.1 )
$ ILST = ILST - 1
IF( NBF.EQ.1 .AND. NBL.EQ.2 )
$ ILST = ILST + 1
*
HERE = IFST
*
10 CONTINUE
*
* Swap with next one below.
*
IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
*
* Current block either 1-by-1 or 2-by-2.
*
NBNEXT = 1
IF( HERE+NBF+1.LE.N ) THEN
IF( A( HERE+NBF+1, HERE+NBF ).NE.ZERO )
$ NBNEXT = 2
END IF
CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
$ LDZ, HERE, NBF, NBNEXT, WORK, LWORK, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
HERE = HERE + NBNEXT
*
* Test if 2-by-2 block breaks into two 1-by-1 blocks.
*
IF( NBF.EQ.2 ) THEN
IF( A( HERE+1, HERE ).EQ.ZERO )
$ NBF = 3
END IF
*
ELSE
*
* Current block consists of two 1-by-1 blocks, each of which
* must be swapped individually.
*
NBNEXT = 1
IF( HERE+3.LE.N ) THEN
IF( A( HERE+3, HERE+2 ).NE.ZERO )
$ NBNEXT = 2
END IF
CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
$ LDZ, HERE+1, 1, NBNEXT, WORK, LWORK, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
IF( NBNEXT.EQ.1 ) THEN
*
* Swap two 1-by-1 blocks.
*
CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
$ LDZ, HERE, 1, 1, WORK, LWORK, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
HERE = HERE + 1
*
ELSE
*
* Recompute NBNEXT in case of 2-by-2 split.
*
IF( A( HERE+2, HERE+1 ).EQ.ZERO )
$ NBNEXT = 1
IF( NBNEXT.EQ.2 ) THEN
*
* 2-by-2 block did not split.
*
CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
$ Z, LDZ, HERE, 1, NBNEXT, WORK, LWORK,
$ INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
HERE = HERE + 2
ELSE
*
* 2-by-2 block did split.
*
CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
$ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
HERE = HERE + 1
CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
$ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
HERE = HERE + 1
END IF
*
END IF
END IF
IF( HERE.LT.ILST )
$ GO TO 10
ELSE
HERE = IFST
*
20 CONTINUE
*
* Swap with next one below.
*
IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
*
* Current block either 1-by-1 or 2-by-2.
*
NBNEXT = 1
IF( HERE.GE.3 ) THEN
IF( A( HERE-1, HERE-2 ).NE.ZERO )
$ NBNEXT = 2
END IF
CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
$ LDZ, HERE-NBNEXT, NBNEXT, NBF, WORK, LWORK,
$ INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
HERE = HERE - NBNEXT
*
* Test if 2-by-2 block breaks into two 1-by-1 blocks.
*
IF( NBF.EQ.2 ) THEN
IF( A( HERE+1, HERE ).EQ.ZERO )
$ NBF = 3
END IF
*
ELSE
*
* Current block consists of two 1-by-1 blocks, each of which
* must be swapped individually.
*
NBNEXT = 1
IF( HERE.GE.3 ) THEN
IF( A( HERE-1, HERE-2 ).NE.ZERO )
$ NBNEXT = 2
END IF
CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
$ LDZ, HERE-NBNEXT, NBNEXT, 1, WORK, LWORK,
$ INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
IF( NBNEXT.EQ.1 ) THEN
*
* Swap two 1-by-1 blocks.
*
CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
$ LDZ, HERE, NBNEXT, 1, WORK, LWORK, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
HERE = HERE - 1
ELSE
*
* Recompute NBNEXT in case of 2-by-2 split.
*
IF( A( HERE, HERE-1 ).EQ.ZERO )
$ NBNEXT = 1
IF( NBNEXT.EQ.2 ) THEN
*
* 2-by-2 block did not split.
*
CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
$ Z, LDZ, HERE-1, 2, 1, WORK, LWORK, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
HERE = HERE - 2
ELSE
*
* 2-by-2 block did split.
*
CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
$ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
HERE = HERE - 1
CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
$ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
HERE = HERE - 1
END IF
END IF
END IF
IF( HERE.GT.ILST )
$ GO TO 20
END IF
ILST = HERE
WORK( 1 ) = LWMIN
RETURN
*
* End of STGEXC
*
END
SUBROUTINE STGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB,
$ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, M, PL,
$ PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO )
*
* -- LAPACK routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* January 2007
*
* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
*
* .. Scalar Arguments ..
LOGICAL WANTQ, WANTZ
INTEGER IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK,
$ M, N
REAL PL, PR
* ..
* .. Array Arguments ..
LOGICAL SELECT( * )
INTEGER IWORK( * )
REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
$ B( LDB, * ), BETA( * ), DIF( * ), Q( LDQ, * ),
$ WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* STGSEN reorders the generalized real Schur decomposition of a real
* matrix pair (A, B) (in terms of an orthonormal equivalence trans-
* formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues
* appears in the leading diagonal blocks of the upper quasi-triangular
* matrix A and the upper triangular B. The leading columns of Q and
* Z form orthonormal bases of the corresponding left and right eigen-
* spaces (deflating subspaces). (A, B) must be in generalized real
* Schur canonical form (as returned by SGGES), i.e. A is block upper
* triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper
* triangular.
*
* STGSEN also computes the generalized eigenvalues
*
* w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j)
*
* of the reordered matrix pair (A, B).
*
* Optionally, STGSEN computes the estimates of reciprocal condition
* numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),
* (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)
* between the matrix pairs (A11, B11) and (A22,B22) that correspond to
* the selected cluster and the eigenvalues outside the cluster, resp.,
* and norms of "projections" onto left and right eigenspaces w.r.t.
* the selected cluster in the (1,1)-block.
*
* Arguments
* =========
*
* IJOB (input) INTEGER
* Specifies whether condition numbers are required for the
* cluster of eigenvalues (PL and PR) or the deflating subspaces
* (Difu and Difl):
* =0: Only reorder w.r.t. SELECT. No extras.
* =1: Reciprocal of norms of "projections" onto left and right
* eigenspaces w.r.t. the selected cluster (PL and PR).
* =2: Upper bounds on Difu and Difl. F-norm-based estimate
* (DIF(1:2)).
* =3: Estimate of Difu and Difl. 1-norm-based estimate
* (DIF(1:2)).
* About 5 times as expensive as IJOB = 2.
* =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic
* version to get it all.
* =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)
*
* WANTQ (input) LOGICAL
* .TRUE. : update the left transformation matrix Q;
* .FALSE.: do not update Q.
*
* WANTZ (input) LOGICAL
* .TRUE. : update the right transformation matrix Z;
* .FALSE.: do not update Z.
*
* SELECT (input) LOGICAL array, dimension (N)
* SELECT specifies the eigenvalues in the selected cluster.
* To select a real eigenvalue w(j), SELECT(j) must be set to
* .TRUE.. To select a complex conjugate pair of eigenvalues
* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,
* either SELECT(j) or SELECT(j+1) or both must be set to
* .TRUE.; a complex conjugate pair of eigenvalues must be
* either both included in the cluster or both excluded.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* A (input/output) REAL array, dimension(LDA,N)
* On entry, the upper quasi-triangular matrix A, with (A, B) in
* generalized real Schur canonical form.
* On exit, A is overwritten by the reordered matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input/output) REAL array, dimension(LDB,N)
* On entry, the upper triangular matrix B, with (A, B) in
* generalized real Schur canonical form.
* On exit, B is overwritten by the reordered matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* ALPHAR (output) REAL array, dimension (N)
* ALPHAI (output) REAL array, dimension (N)
* BETA (output) REAL array, dimension (N)
* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i
* and BETA(j),j=1,...,N are the diagonals of the complex Schur
* form (S,T) that would result if the 2-by-2 diagonal blocks of
* the real generalized Schur form of (A,B) were further reduced
* to triangular form using complex unitary transformations.
* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
* positive, then the j-th and (j+1)-st eigenvalues are a
* complex conjugate pair, with ALPHAI(j+1) negative.
*
* Q (input/output) REAL array, dimension (LDQ,N)
* On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.
* On exit, Q has been postmultiplied by the left orthogonal
* transformation matrix which reorder (A, B); The leading M
* columns of Q form orthonormal bases for the specified pair of
* left eigenspaces (deflating subspaces).
* If WANTQ = .FALSE., Q is not referenced.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= 1;
* and if WANTQ = .TRUE., LDQ >= N.
*
* Z (input/output) REAL array, dimension (LDZ,N)
* On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.
* On exit, Z has been postmultiplied by the left orthogonal
* transformation matrix which reorder (A, B); The leading M
* columns of Z form orthonormal bases for the specified pair of
* left eigenspaces (deflating subspaces).
* If WANTZ = .FALSE., Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1;
* If WANTZ = .TRUE., LDZ >= N.
*
* M (output) INTEGER
* The dimension of the specified pair of left and right eigen-
* spaces (deflating subspaces). 0 <= M <= N.
*
* PL (output) REAL
* PR (output) REAL
* If IJOB = 1, 4 or 5, PL, PR are lower bounds on the
* reciprocal of the norm of "projections" onto left and right
* eigenspaces with respect to the selected cluster.
* 0 < PL, PR <= 1.
* If M = 0 or M = N, PL = PR = 1.
* If IJOB = 0, 2 or 3, PL and PR are not referenced.
*
* DIF (output) REAL array, dimension (2).
* If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.
* If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on
* Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based
* estimates of Difu and Difl.
* If M = 0 or N, DIF(1:2) = F-norm([A, B]).
* If IJOB = 0 or 1, DIF is not referenced.
*
* WORK (workspace/output) REAL 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 >= 4*N+16.
* If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)).
* If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)).
*
* 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.
*
* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
* IF IJOB = 0, IWORK is not referenced. Otherwise,
* on exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK. LIWORK >= 1.
* If IJOB = 1, 2 or 4, LIWORK >= N+6.
* If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6).
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal size of the IWORK array,
* returns this value as the first entry of the IWORK array, and
* no error message related to LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* =0: Successful exit.
* <0: If INFO = -i, the i-th argument had an illegal value.
* =1: Reordering of (A, B) failed because the transformed
* matrix pair (A, B) would be too far from generalized
* Schur form; the problem is very ill-conditioned.
* (A, B) may have been partially reordered.
* If requested, 0 is returned in DIF(*), PL and PR.
*
* Further Details
* ===============
*
* STGSEN first collects the selected eigenvalues by computing
* orthogonal U and W that move them to the top left corner of (A, B).
* In other words, the selected eigenvalues are the eigenvalues of
* (A11, B11) in:
*
* U'*(A, B)*W = (A11 A12) (B11 B12) n1
* ( 0 A22),( 0 B22) n2
* n1 n2 n1 n2
*
* where N = n1+n2 and U' means the transpose of U. The first n1 columns
* of U and W span the specified pair of left and right eigenspaces
* (deflating subspaces) of (A, B).
*
* If (A, B) has been obtained from the generalized real Schur
* decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the
* reordered generalized real Schur form of (C, D) is given by
*
* (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',
*
* and the first n1 columns of Q*U and Z*W span the corresponding
* deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).
*
* Note that if the selected eigenvalue is sufficiently ill-conditioned,
* then its value may differ significantly from its value before
* reordering.
*
* The reciprocal condition numbers of the left and right eigenspaces
* spanned by the first n1 columns of U and W (or Q*U and Z*W) may
* be returned in DIF(1:2), corresponding to Difu and Difl, resp.
*
* The Difu and Difl are defined as:
*
* Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )
* and
* Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],
*
* where sigma-min(Zu) is the smallest singular value of the
* (2*n1*n2)-by-(2*n1*n2) matrix
*
* Zu = [ kron(In2, A11) -kron(A22', In1) ]
* [ kron(In2, B11) -kron(B22', In1) ].
*
* Here, Inx is the identity matrix of size nx and A22' is the
* transpose of A22. kron(X, Y) is the Kronecker product between
* the matrices X and Y.
*
* When DIF(2) is small, small changes in (A, B) can cause large changes
* in the deflating subspace. An approximate (asymptotic) bound on the
* maximum angular error in the computed deflating subspaces is
*
* EPS * norm((A, B)) / DIF(2),
*
* where EPS is the machine precision.
*
* The reciprocal norm of the projectors on the left and right
* eigenspaces associated with (A11, B11) may be returned in PL and PR.
* They are computed as follows. First we compute L and R so that
* P*(A, B)*Q is block diagonal, where
*
* P = ( I -L ) n1 Q = ( I R ) n1
* ( 0 I ) n2 and ( 0 I ) n2
* n1 n2 n1 n2
*
* and (L, R) is the solution to the generalized Sylvester equation
*
* A11*R - L*A22 = -A12
* B11*R - L*B22 = -B12
*
* Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).
* An approximate (asymptotic) bound on the average absolute error of
* the selected eigenvalues is
*
* EPS * norm((A, B)) / PL.
*
* There are also global error bounds which valid for perturbations up
* to a certain restriction: A lower bound (x) on the smallest
* F-norm(E,F) for which an eigenvalue of (A11, B11) may move and
* coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),
* (i.e. (A + E, B + F), is
*
* x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).
*
* An approximate bound on x can be computed from DIF(1:2), PL and PR.
*
* If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed
* (L', R') and unperturbed (L, R) left and right deflating subspaces
* associated with the selected cluster in the (1,1)-blocks can be
* bounded as
*
* max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))
* max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))
*
* See LAPACK User's Guide section 4.11 or the following references
* for more information.
*
* Note that if the default method for computing the Frobenius-norm-
* based estimate DIF is not wanted (see SLATDF), then the parameter
* IDIFJB (see below) should be changed from 3 to 4 (routine SLATDF
* (IJOB = 2 will be used)). See STGSYL for more details.
*
* Based on contributions by
* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
* Umea University, S-901 87 Umea, Sweden.
*
* References
* ==========
*
* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
*
* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
* Eigenvalues of a Regular Matrix Pair (A, B) and Condition
* Estimation: Theory, Algorithms and Software,
* Report UMINF - 94.04, Department of Computing Science, Umea
* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working
* Note 87. To appear in Numerical Algorithms, 1996.
*
* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
* for Solving the Generalized Sylvester Equation and Estimating the
* Separation between Regular Matrix Pairs, Report UMINF - 93.23,
* Department of Computing Science, Umea University, S-901 87 Umea,
* Sweden, December 1993, Revised April 1994, Also as LAPACK Working
* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,
* 1996.
*
* =====================================================================
*
* .. Parameters ..
INTEGER IDIFJB
PARAMETER ( IDIFJB = 3 )
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, PAIR, SWAP, WANTD, WANTD1, WANTD2,
$ WANTP
INTEGER I, IERR, IJB, K, KASE, KK, KS, LIWMIN, LWMIN,
$ MN2, N1, N2
REAL DSCALE, DSUM, EPS, RDSCAL, SMLNUM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL SLACN2, SLACPY, SLAG2, SLASSQ, STGEXC, STGSYL,
$ XERBLA
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Decode and test the input parameters
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
IF( IJOB.LT.0 .OR. IJOB.GT.5 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
INFO = -14
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -16
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STGSEN', -INFO )
RETURN
END IF
*
* Get machine constants
*
EPS = SLAMCH( 'P' )
SMLNUM = SLAMCH( 'S' ) / EPS
IERR = 0
*
WANTP = IJOB.EQ.1 .OR. IJOB.GE.4
WANTD1 = IJOB.EQ.2 .OR. IJOB.EQ.4
WANTD2 = IJOB.EQ.3 .OR. IJOB.EQ.5
WANTD = WANTD1 .OR. WANTD2
*
* Set M to the dimension of the specified pair of deflating
* subspaces.
*
M = 0
PAIR = .FALSE.
DO 10 K = 1, N
IF( PAIR ) THEN
PAIR = .FALSE.
ELSE
IF( K.LT.N ) THEN
IF( A( K+1, K ).EQ.ZERO ) THEN
IF( SELECT( K ) )
$ M = M + 1
ELSE
PAIR = .TRUE.
IF( SELECT( K ) .OR. SELECT( K+1 ) )
$ M = M + 2
END IF
ELSE
IF( SELECT( N ) )
$ M = M + 1
END IF
END IF
10 CONTINUE
*
IF( IJOB.EQ.1 .OR. IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN
LWMIN = MAX( 1, 4*N+16, 2*M*(N-M) )
LIWMIN = MAX( 1, N+6 )
ELSE IF( IJOB.EQ.3 .OR. IJOB.EQ.5 ) THEN
LWMIN = MAX( 1, 4*N+16, 4*M*(N-M) )
LIWMIN = MAX( 1, 2*M*(N-M), N+6 )
ELSE
LWMIN = MAX( 1, 4*N+16 )
LIWMIN = 1
END IF
*
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -22
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -24
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STGSEN', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible.
*
IF( M.EQ.N .OR. M.EQ.0 ) THEN
IF( WANTP ) THEN
PL = ONE
PR = ONE
END IF
IF( WANTD ) THEN
DSCALE = ZERO
DSUM = ONE
DO 20 I = 1, N
CALL SLASSQ( N, A( 1, I ), 1, DSCALE, DSUM )
CALL SLASSQ( N, B( 1, I ), 1, DSCALE, DSUM )
20 CONTINUE
DIF( 1 ) = DSCALE*SQRT( DSUM )
DIF( 2 ) = DIF( 1 )
END IF
GO TO 60
END IF
*
* Collect the selected blocks at the top-left corner of (A, B).
*
KS = 0
PAIR = .FALSE.
DO 30 K = 1, N
IF( PAIR ) THEN
PAIR = .FALSE.
ELSE
*
SWAP = SELECT( K )
IF( K.LT.N ) THEN
IF( A( K+1, K ).NE.ZERO ) THEN
PAIR = .TRUE.
SWAP = SWAP .OR. SELECT( K+1 )
END IF
END IF
*
IF( SWAP ) THEN
KS = KS + 1
*
* Swap the K-th block to position KS.
* Perform the reordering of diagonal blocks in (A, B)
* by orthogonal transformation matrices and update
* Q and Z accordingly (if requested):
*
KK = K
IF( K.NE.KS )
$ CALL STGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
$ Z, LDZ, KK, KS, WORK, LWORK, IERR )
*
IF( IERR.GT.0 ) THEN
*
* Swap is rejected: exit.
*
INFO = 1
IF( WANTP ) THEN
PL = ZERO
PR = ZERO
END IF
IF( WANTD ) THEN
DIF( 1 ) = ZERO
DIF( 2 ) = ZERO
END IF
GO TO 60
END IF
*
IF( PAIR )
$ KS = KS + 1
END IF
END IF
30 CONTINUE
IF( WANTP ) THEN
*
* Solve generalized Sylvester equation for R and L
* and compute PL and PR.
*
N1 = M
N2 = N - M
I = N1 + 1
IJB = 0
CALL SLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 )
CALL SLACPY( 'Full', N1, N2, B( 1, I ), LDB, WORK( N1*N2+1 ),
$ N1 )
CALL STGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK,
$ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), N1,
$ DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ),
$ LWORK-2*N1*N2, IWORK, IERR )
*
* Estimate the reciprocal of norms of "projections" onto left
* and right eigenspaces.
*
RDSCAL = ZERO
DSUM = ONE
CALL SLASSQ( N1*N2, WORK, 1, RDSCAL, DSUM )
PL = RDSCAL*SQRT( DSUM )
IF( PL.EQ.ZERO ) THEN
PL = ONE
ELSE
PL = DSCALE / ( SQRT( DSCALE*DSCALE / PL+PL )*SQRT( PL ) )
END IF
RDSCAL = ZERO
DSUM = ONE
CALL SLASSQ( N1*N2, WORK( N1*N2+1 ), 1, RDSCAL, DSUM )
PR = RDSCAL*SQRT( DSUM )
IF( PR.EQ.ZERO ) THEN
PR = ONE
ELSE
PR = DSCALE / ( SQRT( DSCALE*DSCALE / PR+PR )*SQRT( PR ) )
END IF
END IF
*
IF( WANTD ) THEN
*
* Compute estimates of Difu and Difl.
*
IF( WANTD1 ) THEN
N1 = M
N2 = N - M
I = N1 + 1
IJB = IDIFJB
*
* Frobenius norm-based Difu-estimate.
*
CALL STGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK,
$ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ),
$ N1, DSCALE, DIF( 1 ), WORK( 2*N1*N2+1 ),
$ LWORK-2*N1*N2, IWORK, IERR )
*
* Frobenius norm-based Difl-estimate.
*
CALL STGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, WORK,
$ N2, B( I, I ), LDB, B, LDB, WORK( N1*N2+1 ),
$ N2, DSCALE, DIF( 2 ), WORK( 2*N1*N2+1 ),
$ LWORK-2*N1*N2, IWORK, IERR )
ELSE
*
*
* Compute 1-norm-based estimates of Difu and Difl using
* reversed communication with SLACN2. In each step a
* generalized Sylvester equation or a transposed variant
* is solved.
*
KASE = 0
N1 = M
N2 = N - M
I = N1 + 1
IJB = 0
MN2 = 2*N1*N2
*
* 1-norm-based estimate of Difu.
*
40 CONTINUE
CALL SLACN2( MN2, WORK( MN2+1 ), WORK, IWORK, DIF( 1 ),
$ KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Solve generalized Sylvester equation.
*
CALL STGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA,
$ WORK, N1, B, LDB, B( I, I ), LDB,
$ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ),
$ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
$ IERR )
ELSE
*
* Solve the transposed variant.
*
CALL STGSYL( 'T', IJB, N1, N2, A, LDA, A( I, I ), LDA,
$ WORK, N1, B, LDB, B( I, I ), LDB,
$ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ),
$ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
$ IERR )
END IF
GO TO 40
END IF
DIF( 1 ) = DSCALE / DIF( 1 )
*
* 1-norm-based estimate of Difl.
*
50 CONTINUE
CALL SLACN2( MN2, WORK( MN2+1 ), WORK, IWORK, DIF( 2 ),
$ KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Solve generalized Sylvester equation.
*
CALL STGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA,
$ WORK, N2, B( I, I ), LDB, B, LDB,
$ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ),
$ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
$ IERR )
ELSE
*
* Solve the transposed variant.
*
CALL STGSYL( 'T', IJB, N2, N1, A( I, I ), LDA, A, LDA,
$ WORK, N2, B( I, I ), LDB, B, LDB,
$ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ),
$ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
$ IERR )
END IF
GO TO 50
END IF
DIF( 2 ) = DSCALE / DIF( 2 )
*
END IF
END IF
*
60 CONTINUE
*
* Compute generalized eigenvalues of reordered pair (A, B) and
* normalize the generalized Schur form.
*
PAIR = .FALSE.
DO 70 K = 1, N
IF( PAIR ) THEN
PAIR = .FALSE.
ELSE
*
IF( K.LT.N ) THEN
IF( A( K+1, K ).NE.ZERO ) THEN
PAIR = .TRUE.
END IF
END IF
*
IF( PAIR ) THEN
*
* Compute the eigenvalue(s) at position K.
*
WORK( 1 ) = A( K, K )
WORK( 2 ) = A( K+1, K )
WORK( 3 ) = A( K, K+1 )
WORK( 4 ) = A( K+1, K+1 )
WORK( 5 ) = B( K, K )
WORK( 6 ) = B( K+1, K )
WORK( 7 ) = B( K, K+1 )
WORK( 8 ) = B( K+1, K+1 )
CALL SLAG2( WORK, 2, WORK( 5 ), 2, SMLNUM*EPS, BETA( K ),
$ BETA( K+1 ), ALPHAR( K ), ALPHAR( K+1 ),
$ ALPHAI( K ) )
ALPHAI( K+1 ) = -ALPHAI( K )
*
ELSE
*
IF( SIGN( ONE, B( K, K ) ).LT.ZERO ) THEN
*
* If B(K,K) is negative, make it positive
*
DO 80 I = 1, N
A( K, I ) = -A( K, I )
B( K, I ) = -B( K, I )
Q( I, K ) = -Q( I, K )
80 CONTINUE
END IF
*
ALPHAR( K ) = A( K, K )
ALPHAI( K ) = ZERO
BETA( K ) = B( K, K )
*
END IF
END IF
70 CONTINUE
*
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
RETURN
*
* End of STGSEN
*
END
SUBROUTINE STGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B,
$ LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV,
$ Q, LDQ, WORK, NCYCLE, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBQ, JOBU, JOBV
INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N,
$ NCYCLE, P
REAL TOLA, TOLB
* ..
* .. Array Arguments ..
REAL A( LDA, * ), ALPHA( * ), B( LDB, * ),
$ BETA( * ), Q( LDQ, * ), U( LDU, * ),
$ V( LDV, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* STGSJA computes the generalized singular value decomposition (GSVD)
* of two real upper triangular (or trapezoidal) matrices A and B.
*
* On entry, it is assumed that matrices A and B have the following
* forms, which may be obtained by the preprocessing subroutine SGGSVP
* from a general M-by-N matrix A and P-by-N matrix B:
*
* N-K-L K L
* A = K ( 0 A12 A13 ) if M-K-L >= 0;
* L ( 0 0 A23 )
* M-K-L ( 0 0 0 )
*
* N-K-L K L
* A = K ( 0 A12 A13 ) if M-K-L < 0;
* M-K ( 0 0 A23 )
*
* N-K-L K L
* B = L ( 0 0 B13 )
* P-L ( 0 0 0 )
*
* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
* otherwise A23 is (M-K)-by-L upper trapezoidal.
*
* On exit,
*
* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ),
*
* where U, V and Q are orthogonal matrices, Z' denotes the transpose
* of Z, R is a nonsingular upper triangular matrix, and D1 and D2 are
* ``diagonal'' matrices, which are of the following structures:
*
* If M-K-L >= 0,
*
* K L
* D1 = K ( I 0 )
* L ( 0 C )
* M-K-L ( 0 0 )
*
* K L
* D2 = L ( 0 S )
* P-L ( 0 0 )
*
* N-K-L K L
* ( 0 R ) = K ( 0 R11 R12 ) K
* L ( 0 0 R22 ) L
*
* where
*
* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),
* S = diag( BETA(K+1), ... , BETA(K+L) ),
* C**2 + S**2 = I.
*
* R is stored in A(1:K+L,N-K-L+1:N) on exit.
*
* If M-K-L < 0,
*
* K M-K K+L-M
* D1 = K ( I 0 0 )
* M-K ( 0 C 0 )
*
* K M-K K+L-M
* D2 = M-K ( 0 S 0 )
* K+L-M ( 0 0 I )
* P-L ( 0 0 0 )
*
* N-K-L K M-K K+L-M
* ( 0 R ) = K ( 0 R11 R12 R13 )
* M-K ( 0 0 R22 R23 )
* K+L-M ( 0 0 0 R33 )
*
* where
* C = diag( ALPHA(K+1), ... , ALPHA(M) ),
* S = diag( BETA(K+1), ... , BETA(M) ),
* C**2 + S**2 = I.
*
* R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored
* ( 0 R22 R23 )
* in B(M-K+1:L,N+M-K-L+1:N) on exit.
*
* The computation of the orthogonal transformation matrices U, V or Q
* is optional. These matrices may either be formed explicitly, or they
* may be postmultiplied into input matrices U1, V1, or Q1.
*
* Arguments
* =========
*
* JOBU (input) CHARACTER*1
* = 'U': U must contain an orthogonal matrix U1 on entry, and
* the product U1*U is returned;
* = 'I': U is initialized to the unit matrix, and the
* orthogonal matrix U is returned;
* = 'N': U is not computed.
*
* JOBV (input) CHARACTER*1
* = 'V': V must contain an orthogonal matrix V1 on entry, and
* the product V1*V is returned;
* = 'I': V is initialized to the unit matrix, and the
* orthogonal matrix V is returned;
* = 'N': V is not computed.
*
* JOBQ (input) CHARACTER*1
* = 'Q': Q must contain an orthogonal matrix Q1 on entry, and
* the product Q1*Q is returned;
* = 'I': Q is initialized to the unit matrix, and the
* orthogonal matrix Q is returned;
* = 'N': Q is not computed.
*
* M (input) INTEGER
* The number of rows of the matrix A. M >= 0.
*
* P (input) INTEGER
* The number of rows of the matrix B. P >= 0.
*
* N (input) INTEGER
* The number of columns of the matrices A and B. N >= 0.
*
* K (input) INTEGER
* L (input) INTEGER
* K and L specify the subblocks in the input matrices A and B:
* A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,N-L+1:N)
* of A and B, whose GSVD is going to be computed by STGSJA.
* See Further details.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular
* matrix R or part of R. See Purpose for details.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input/output) REAL array, dimension (LDB,N)
* On entry, the P-by-N matrix B.
* On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains
* a part of R. See Purpose for details.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,P).
*
* TOLA (input) REAL
* TOLB (input) REAL
* TOLA and TOLB are the convergence criteria for the Jacobi-
* Kogbetliantz iteration procedure. Generally, they are the
* same as used in the preprocessing step, say
* TOLA = max(M,N)*norm(A)*MACHEPS,
* TOLB = max(P,N)*norm(B)*MACHEPS.
*
* ALPHA (output) REAL array, dimension (N)
* BETA (output) REAL array, dimension (N)
* On exit, ALPHA and BETA contain the generalized singular
* value pairs of A and B;
* ALPHA(1:K) = 1,
* BETA(1:K) = 0,
* and if M-K-L >= 0,
* ALPHA(K+1:K+L) = diag(C),
* BETA(K+1:K+L) = diag(S),
* or if M-K-L < 0,
* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0
* BETA(K+1:M) = S, BETA(M+1:K+L) = 1.
* Furthermore, if K+L < N,
* ALPHA(K+L+1:N) = 0 and
* BETA(K+L+1:N) = 0.
*
* U (input/output) REAL array, dimension (LDU,M)
* On entry, if JOBU = 'U', U must contain a matrix U1 (usually
* the orthogonal matrix returned by SGGSVP).
* On exit,
* if JOBU = 'I', U contains the orthogonal matrix U;
* if JOBU = 'U', U contains the product U1*U.
* If JOBU = 'N', U is not referenced.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= max(1,M) if
* JOBU = 'U'; LDU >= 1 otherwise.
*
* V (input/output) REAL array, dimension (LDV,P)
* On entry, if JOBV = 'V', V must contain a matrix V1 (usually
* the orthogonal matrix returned by SGGSVP).
* On exit,
* if JOBV = 'I', V contains the orthogonal matrix V;
* if JOBV = 'V', V contains the product V1*V.
* If JOBV = 'N', V is not referenced.
*
* LDV (input) INTEGER
* The leading dimension of the array V. LDV >= max(1,P) if
* JOBV = 'V'; LDV >= 1 otherwise.
*
* Q (input/output) REAL array, dimension (LDQ,N)
* On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually
* the orthogonal matrix returned by SGGSVP).
* On exit,
* if JOBQ = 'I', Q contains the orthogonal matrix Q;
* if JOBQ = 'Q', Q contains the product Q1*Q.
* If JOBQ = 'N', Q is not referenced.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N) if
* JOBQ = 'Q'; LDQ >= 1 otherwise.
*
* WORK (workspace) REAL array, dimension (2*N)
*
* NCYCLE (output) INTEGER
* The number of cycles required for convergence.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* = 1: the procedure does not converge after MAXIT cycles.
*
* Internal Parameters
* ===================
*
* MAXIT INTEGER
* MAXIT specifies the total loops that the iterative procedure
* may take. If after MAXIT cycles, the routine fails to
* converge, we return INFO = 1.
*
* Further Details
* ===============
*
* STGSJA essentially uses a variant of Kogbetliantz algorithm to reduce
* min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L
* matrix B13 to the form:
*
* U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1,
*
* where U1, V1 and Q1 are orthogonal matrix, and Z' is the transpose
* of Z. C1 and S1 are diagonal matrices satisfying
*
* C1**2 + S1**2 = I,
*
* and R1 is an L-by-L nonsingular upper triangular matrix.
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXIT
PARAMETER ( MAXIT = 40 )
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
*
LOGICAL INITQ, INITU, INITV, UPPER, WANTQ, WANTU, WANTV
INTEGER I, J, KCYCLE
REAL A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, ERROR,
$ GAMMA, RWK, SNQ, SNU, SNV, SSMIN
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLAGS2, SLAPLL, SLARTG, SLASET, SROT,
$ SSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Decode and test the input parameters
*
INITU = LSAME( JOBU, 'I' )
WANTU = INITU .OR. LSAME( JOBU, 'U' )
*
INITV = LSAME( JOBV, 'I' )
WANTV = INITV .OR. LSAME( JOBV, 'V' )
*
INITQ = LSAME( JOBQ, 'I' )
WANTQ = INITQ .OR. LSAME( JOBQ, 'Q' )
*
INFO = 0
IF( .NOT.( INITU .OR. WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( INITV .OR. WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN
INFO = -2
ELSE IF( .NOT.( INITQ .OR. WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN
INFO = -3
ELSE IF( M.LT.0 ) THEN
INFO = -4
ELSE IF( P.LT.0 ) THEN
INFO = -5
ELSE IF( N.LT.0 ) THEN
INFO = -6
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -10
ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
INFO = -12
ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN
INFO = -18
ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN
INFO = -20
ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
INFO = -22
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STGSJA', -INFO )
RETURN
END IF
*
* Initialize U, V and Q, if necessary
*
IF( INITU )
$ CALL SLASET( 'Full', M, M, ZERO, ONE, U, LDU )
IF( INITV )
$ CALL SLASET( 'Full', P, P, ZERO, ONE, V, LDV )
IF( INITQ )
$ CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
*
* Loop until convergence
*
UPPER = .FALSE.
DO 40 KCYCLE = 1, MAXIT
*
UPPER = .NOT.UPPER
*
DO 20 I = 1, L - 1
DO 10 J = I + 1, L
*
A1 = ZERO
A2 = ZERO
A3 = ZERO
IF( K+I.LE.M )
$ A1 = A( K+I, N-L+I )
IF( K+J.LE.M )
$ A3 = A( K+J, N-L+J )
*
B1 = B( I, N-L+I )
B3 = B( J, N-L+J )
*
IF( UPPER ) THEN
IF( K+I.LE.M )
$ A2 = A( K+I, N-L+J )
B2 = B( I, N-L+J )
ELSE
IF( K+J.LE.M )
$ A2 = A( K+J, N-L+I )
B2 = B( J, N-L+I )
END IF
*
CALL SLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU,
$ CSV, SNV, CSQ, SNQ )
*
* Update (K+I)-th and (K+J)-th rows of matrix A: U'*A
*
IF( K+J.LE.M )
$ CALL SROT( L, A( K+J, N-L+1 ), LDA, A( K+I, N-L+1 ),
$ LDA, CSU, SNU )
*
* Update I-th and J-th rows of matrix B: V'*B
*
CALL SROT( L, B( J, N-L+1 ), LDB, B( I, N-L+1 ), LDB,
$ CSV, SNV )
*
* Update (N-L+I)-th and (N-L+J)-th columns of matrices
* A and B: A*Q and B*Q
*
CALL SROT( MIN( K+L, M ), A( 1, N-L+J ), 1,
$ A( 1, N-L+I ), 1, CSQ, SNQ )
*
CALL SROT( L, B( 1, N-L+J ), 1, B( 1, N-L+I ), 1, CSQ,
$ SNQ )
*
IF( UPPER ) THEN
IF( K+I.LE.M )
$ A( K+I, N-L+J ) = ZERO
B( I, N-L+J ) = ZERO
ELSE
IF( K+J.LE.M )
$ A( K+J, N-L+I ) = ZERO
B( J, N-L+I ) = ZERO
END IF
*
* Update orthogonal matrices U, V, Q, if desired.
*
IF( WANTU .AND. K+J.LE.M )
$ CALL SROT( M, U( 1, K+J ), 1, U( 1, K+I ), 1, CSU,
$ SNU )
*
IF( WANTV )
$ CALL SROT( P, V( 1, J ), 1, V( 1, I ), 1, CSV, SNV )
*
IF( WANTQ )
$ CALL SROT( N, Q( 1, N-L+J ), 1, Q( 1, N-L+I ), 1, CSQ,
$ SNQ )
*
10 CONTINUE
20 CONTINUE
*
IF( .NOT.UPPER ) THEN
*
* The matrices A13 and B13 were lower triangular at the start
* of the cycle, and are now upper triangular.
*
* Convergence test: test the parallelism of the corresponding
* rows of A and B.
*
ERROR = ZERO
DO 30 I = 1, MIN( L, M-K )
CALL SCOPY( L-I+1, A( K+I, N-L+I ), LDA, WORK, 1 )
CALL SCOPY( L-I+1, B( I, N-L+I ), LDB, WORK( L+1 ), 1 )
CALL SLAPLL( L-I+1, WORK, 1, WORK( L+1 ), 1, SSMIN )
ERROR = MAX( ERROR, SSMIN )
30 CONTINUE
*
IF( ABS( ERROR ).LE.MIN( TOLA, TOLB ) )
$ GO TO 50
END IF
*
* End of cycle loop
*
40 CONTINUE
*
* The algorithm has not converged after MAXIT cycles.
*
INFO = 1
GO TO 100
*
50 CONTINUE
*
* If ERROR <= MIN(TOLA,TOLB), then the algorithm has converged.
* Compute the generalized singular value pairs (ALPHA, BETA), and
* set the triangular matrix R to array A.
*
DO 60 I = 1, K
ALPHA( I ) = ONE
BETA( I ) = ZERO
60 CONTINUE
*
DO 70 I = 1, MIN( L, M-K )
*
A1 = A( K+I, N-L+I )
B1 = B( I, N-L+I )
*
IF( A1.NE.ZERO ) THEN
GAMMA = B1 / A1
*
* change sign if necessary
*
IF( GAMMA.LT.ZERO ) THEN
CALL SSCAL( L-I+1, -ONE, B( I, N-L+I ), LDB )
IF( WANTV )
$ CALL SSCAL( P, -ONE, V( 1, I ), 1 )
END IF
*
CALL SLARTG( ABS( GAMMA ), ONE, BETA( K+I ), ALPHA( K+I ),
$ RWK )
*
IF( ALPHA( K+I ).GE.BETA( K+I ) ) THEN
CALL SSCAL( L-I+1, ONE / ALPHA( K+I ), A( K+I, N-L+I ),
$ LDA )
ELSE
CALL SSCAL( L-I+1, ONE / BETA( K+I ), B( I, N-L+I ),
$ LDB )
CALL SCOPY( L-I+1, B( I, N-L+I ), LDB, A( K+I, N-L+I ),
$ LDA )
END IF
*
ELSE
*
ALPHA( K+I ) = ZERO
BETA( K+I ) = ONE
CALL SCOPY( L-I+1, B( I, N-L+I ), LDB, A( K+I, N-L+I ),
$ LDA )
*
END IF
*
70 CONTINUE
*
* Post-assignment
*
DO 80 I = M + 1, K + L
ALPHA( I ) = ZERO
BETA( I ) = ONE
80 CONTINUE
*
IF( K+L.LT.N ) THEN
DO 90 I = K + L + 1, N
ALPHA( I ) = ZERO
BETA( I ) = ZERO
90 CONTINUE
END IF
*
100 CONTINUE
NCYCLE = KCYCLE
RETURN
*
* End of STGSJA
*
END
SUBROUTINE STGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL,
$ LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK,
$ IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER HOWMNY, JOB
INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, M, MM, N
* ..
* .. Array Arguments ..
LOGICAL SELECT( * )
INTEGER IWORK( * )
REAL A( LDA, * ), B( LDB, * ), DIF( * ), S( * ),
$ VL( LDVL, * ), VR( LDVR, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* STGSNA estimates reciprocal condition numbers for specified
* eigenvalues and/or eigenvectors of a matrix pair (A, B) in
* generalized real Schur canonical form (or of any matrix pair
* (Q*A*Z', Q*B*Z') with orthogonal matrices Q and Z, where
* Z' denotes the transpose of Z.
*
* (A, B) must be in generalized real Schur form (as returned by SGGES),
* i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal
* blocks. B is upper triangular.
*
*
* Arguments
* =========
*
* JOB (input) CHARACTER*1
* Specifies whether condition numbers are required for
* eigenvalues (S) or eigenvectors (DIF):
* = 'E': for eigenvalues only (S);
* = 'V': for eigenvectors only (DIF);
* = 'B': for both eigenvalues and eigenvectors (S and DIF).
*
* HOWMNY (input) CHARACTER*1
* = 'A': compute condition numbers for all eigenpairs;
* = 'S': compute condition numbers for selected eigenpairs
* specified by the array SELECT.
*
* SELECT (input) LOGICAL array, dimension (N)
* If HOWMNY = 'S', SELECT specifies the eigenpairs for which
* condition numbers are required. To select condition numbers
* for the eigenpair corresponding to a real eigenvalue w(j),
* SELECT(j) must be set to .TRUE.. To select condition numbers
* corresponding to a complex conjugate pair of eigenvalues w(j)
* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be
* set to .TRUE..
* If HOWMNY = 'A', SELECT is not referenced.
*
* N (input) INTEGER
* The order of the square matrix pair (A, B). N >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The upper quasi-triangular matrix A in the pair (A,B).
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input) REAL array, dimension (LDB,N)
* The upper triangular matrix B in the pair (A,B).
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* VL (input) REAL array, dimension (LDVL,M)
* If JOB = 'E' or 'B', VL must contain left eigenvectors of
* (A, B), corresponding to the eigenpairs specified by HOWMNY
* and SELECT. The eigenvectors must be stored in consecutive
* columns of VL, as returned by STGEVC.
* If JOB = 'V', VL is not referenced.
*
* LDVL (input) INTEGER
* The leading dimension of the array VL. LDVL >= 1.
* If JOB = 'E' or 'B', LDVL >= N.
*
* VR (input) REAL array, dimension (LDVR,M)
* If JOB = 'E' or 'B', VR must contain right eigenvectors of
* (A, B), corresponding to the eigenpairs specified by HOWMNY
* and SELECT. The eigenvectors must be stored in consecutive
* columns ov VR, as returned by STGEVC.
* If JOB = 'V', VR is not referenced.
*
* LDVR (input) INTEGER
* The leading dimension of the array VR. LDVR >= 1.
* If JOB = 'E' or 'B', LDVR >= N.
*
* S (output) REAL array, dimension (MM)
* If JOB = 'E' or 'B', the reciprocal condition numbers of the
* selected eigenvalues, stored in consecutive elements of the
* array. For a complex conjugate pair of eigenvalues two
* consecutive elements of S are set to the same value. Thus
* S(j), DIF(j), and the j-th columns of VL and VR all
* correspond to the same eigenpair (but not in general the
* j-th eigenpair, unless all eigenpairs are selected).
* If JOB = 'V', S is not referenced.
*
* DIF (output) REAL array, dimension (MM)
* If JOB = 'V' or 'B', the estimated reciprocal condition
* numbers of the selected eigenvectors, stored in consecutive
* elements of the array. For a complex eigenvector two
* consecutive elements of DIF are set to the same value. If
* the eigenvalues cannot be reordered to compute DIF(j), DIF(j)
* is set to 0; this can only occur when the true value would be
* very small anyway.
* If JOB = 'E', DIF is not referenced.
*
* MM (input) INTEGER
* The number of elements in the arrays S and DIF. MM >= M.
*
* M (output) INTEGER
* The number of elements of the arrays S and DIF used to store
* the specified condition numbers; for each selected real
* eigenvalue one element is used, and for each selected complex
* conjugate pair of eigenvalues, two elements are used.
* If HOWMNY = 'A', M is set to N.
*
* WORK (workspace/output) REAL 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).
* If JOB = 'V' or 'B' LWORK >= 2*N*(N+2)+16.
*
* 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.
*
* IWORK (workspace) INTEGER array, dimension (N + 6)
* If JOB = 'E', IWORK is not referenced.
*
* INFO (output) INTEGER
* =0: Successful exit
* <0: If INFO = -i, the i-th argument had an illegal value
*
*
* Further Details
* ===============
*
* The reciprocal of the condition number of a generalized eigenvalue
* w = (a, b) is defined as
*
* S(w) = (|u'Av|**2 + |u'Bv|**2)**(1/2) / (norm(u)*norm(v))
*
* where u and v are the left and right eigenvectors of (A, B)
* corresponding to w; |z| denotes the absolute value of the complex
* number, and norm(u) denotes the 2-norm of the vector u.
* The pair (a, b) corresponds to an eigenvalue w = a/b (= u'Av/u'Bv)
* of the matrix pair (A, B). If both a and b equal zero, then (A B) is
* singular and S(I) = -1 is returned.
*
* An approximate error bound on the chordal distance between the i-th
* computed generalized eigenvalue w and the corresponding exact
* eigenvalue lambda is
*
* chord(w, lambda) <= EPS * norm(A, B) / S(I)
*
* where EPS is the machine precision.
*
* The reciprocal of the condition number DIF(i) of right eigenvector u
* and left eigenvector v corresponding to the generalized eigenvalue w
* is defined as follows:
*
* a) If the i-th eigenvalue w = (a,b) is real
*
* Suppose U and V are orthogonal transformations such that
*
* U'*(A, B)*V = (S, T) = ( a * ) ( b * ) 1
* ( 0 S22 ),( 0 T22 ) n-1
* 1 n-1 1 n-1
*
* Then the reciprocal condition number DIF(i) is
*
* Difl((a, b), (S22, T22)) = sigma-min( Zl ),
*
* where sigma-min(Zl) denotes the smallest singular value of the
* 2(n-1)-by-2(n-1) matrix
*
* Zl = [ kron(a, In-1) -kron(1, S22) ]
* [ kron(b, In-1) -kron(1, T22) ] .
*
* Here In-1 is the identity matrix of size n-1. kron(X, Y) is the
* Kronecker product between the matrices X and Y.
*
* Note that if the default method for computing DIF(i) is wanted
* (see SLATDF), then the parameter DIFDRI (see below) should be
* changed from 3 to 4 (routine SLATDF(IJOB = 2 will be used)).
* See STGSYL for more details.
*
* b) If the i-th and (i+1)-th eigenvalues are complex conjugate pair,
*
* Suppose U and V are orthogonal transformations such that
*
* U'*(A, B)*V = (S, T) = ( S11 * ) ( T11 * ) 2
* ( 0 S22 ),( 0 T22) n-2
* 2 n-2 2 n-2
*
* and (S11, T11) corresponds to the complex conjugate eigenvalue
* pair (w, conjg(w)). There exist unitary matrices U1 and V1 such
* that
*
* U1'*S11*V1 = ( s11 s12 ) and U1'*T11*V1 = ( t11 t12 )
* ( 0 s22 ) ( 0 t22 )
*
* where the generalized eigenvalues w = s11/t11 and
* conjg(w) = s22/t22.
*
* Then the reciprocal condition number DIF(i) is bounded by
*
* min( d1, max( 1, |real(s11)/real(s22)| )*d2 )
*
* where, d1 = Difl((s11, t11), (s22, t22)) = sigma-min(Z1), where
* Z1 is the complex 2-by-2 matrix
*
* Z1 = [ s11 -s22 ]
* [ t11 -t22 ],
*
* This is done by computing (using real arithmetic) the
* roots of the characteristical polynomial det(Z1' * Z1 - lambda I),
* where Z1' denotes the conjugate transpose of Z1 and det(X) denotes
* the determinant of X.
*
* and d2 is an upper bound on Difl((S11, T11), (S22, T22)), i.e. an
* upper bound on sigma-min(Z2), where Z2 is (2n-2)-by-(2n-2)
*
* Z2 = [ kron(S11', In-2) -kron(I2, S22) ]
* [ kron(T11', In-2) -kron(I2, T22) ]
*
* Note that if the default method for computing DIF is wanted (see
* SLATDF), then the parameter DIFDRI (see below) should be changed
* from 3 to 4 (routine SLATDF(IJOB = 2 will be used)). See STGSYL
* for more details.
*
* For each eigenvalue/vector specified by SELECT, DIF stores a
* Frobenius norm-based estimate of Difl.
*
* An approximate error bound for the i-th computed eigenvector VL(i) or
* VR(i) is given by
*
* EPS * norm(A, B) / DIF(i).
*
* See ref. [2-3] for more details and further references.
*
* Based on contributions by
* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
* Umea University, S-901 87 Umea, Sweden.
*
* References
* ==========
*
* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
*
* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
* Eigenvalues of a Regular Matrix Pair (A, B) and Condition
* Estimation: Theory, Algorithms and Software,
* Report UMINF - 94.04, Department of Computing Science, Umea
* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working
* Note 87. To appear in Numerical Algorithms, 1996.
*
* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
* for Solving the Generalized Sylvester Equation and Estimating the
* Separation between Regular Matrix Pairs, Report UMINF - 93.23,
* Department of Computing Science, Umea University, S-901 87 Umea,
* Sweden, December 1993, Revised April 1994, Also as LAPACK Working
* Note 75. To appear in ACM Trans. on Math. Software, Vol 22,
* No 1, 1996.
*
* =====================================================================
*
* .. Parameters ..
INTEGER DIFDRI
PARAMETER ( DIFDRI = 3 )
REAL ZERO, ONE, TWO, FOUR
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0,
$ FOUR = 4.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, PAIR, SOMCON, WANTBH, WANTDF, WANTS
INTEGER I, IERR, IFST, ILST, IZ, K, KS, LWMIN, N1, N2
REAL ALPHAI, ALPHAR, ALPRQT, BETA, C1, C2, COND,
$ EPS, LNRM, RNRM, ROOT1, ROOT2, SCALE, SMLNUM,
$ TMPII, TMPIR, TMPRI, TMPRR, UHAV, UHAVI, UHBV,
$ UHBVI
* ..
* .. Local Arrays ..
REAL DUMMY( 1 ), DUMMY1( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SDOT, SLAMCH, SLAPY2, SNRM2
EXTERNAL LSAME, SDOT, SLAMCH, SLAPY2, SNRM2
* ..
* .. External Subroutines ..
EXTERNAL SGEMV, SLACPY, SLAG2, STGEXC, STGSYL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Decode and test the input parameters
*
WANTBH = LSAME( JOB, 'B' )
WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
WANTDF = LSAME( JOB, 'V' ) .OR. WANTBH
*
SOMCON = LSAME( HOWMNY, 'S' )
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
*
IF( .NOT.WANTS .AND. .NOT.WANTDF ) THEN
INFO = -1
ELSE IF( .NOT.LSAME( HOWMNY, 'A' ) .AND. .NOT.SOMCON ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( WANTS .AND. LDVL.LT.N ) THEN
INFO = -10
ELSE IF( WANTS .AND. LDVR.LT.N ) THEN
INFO = -12
ELSE
*
* Set M to the number of eigenpairs for which condition numbers
* are required, and test MM.
*
IF( SOMCON ) THEN
M = 0
PAIR = .FALSE.
DO 10 K = 1, N
IF( PAIR ) THEN
PAIR = .FALSE.
ELSE
IF( K.LT.N ) THEN
IF( A( K+1, K ).EQ.ZERO ) THEN
IF( SELECT( K ) )
$ M = M + 1
ELSE
PAIR = .TRUE.
IF( SELECT( K ) .OR. SELECT( K+1 ) )
$ M = M + 2
END IF
ELSE
IF( SELECT( N ) )
$ M = M + 1
END IF
END IF
10 CONTINUE
ELSE
M = N
END IF
*
IF( N.EQ.0 ) THEN
LWMIN = 1
ELSE IF( LSAME( JOB, 'V' ) .OR. LSAME( JOB, 'B' ) ) THEN
LWMIN = 2*N*( N + 2 ) + 16
ELSE
LWMIN = N
END IF
WORK( 1 ) = LWMIN
*
IF( MM.LT.M ) THEN
INFO = -15
ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -18
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STGSNA', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Get machine constants
*
EPS = SLAMCH( 'P' )
SMLNUM = SLAMCH( 'S' ) / EPS
KS = 0
PAIR = .FALSE.
*
DO 20 K = 1, N
*
* Determine whether A(k,k) begins a 1-by-1 or 2-by-2 block.
*
IF( PAIR ) THEN
PAIR = .FALSE.
GO TO 20
ELSE
IF( K.LT.N )
$ PAIR = A( K+1, K ).NE.ZERO
END IF
*
* Determine whether condition numbers are required for the k-th
* eigenpair.
*
IF( SOMCON ) THEN
IF( PAIR ) THEN
IF( .NOT.SELECT( K ) .AND. .NOT.SELECT( K+1 ) )
$ GO TO 20
ELSE
IF( .NOT.SELECT( K ) )
$ GO TO 20
END IF
END IF
*
KS = KS + 1
*
IF( WANTS ) THEN
*
* Compute the reciprocal condition number of the k-th
* eigenvalue.
*
IF( PAIR ) THEN
*
* Complex eigenvalue pair.
*
RNRM = SLAPY2( SNRM2( N, VR( 1, KS ), 1 ),
$ SNRM2( N, VR( 1, KS+1 ), 1 ) )
LNRM = SLAPY2( SNRM2( N, VL( 1, KS ), 1 ),
$ SNRM2( N, VL( 1, KS+1 ), 1 ) )
CALL SGEMV( 'N', N, N, ONE, A, LDA, VR( 1, KS ), 1, ZERO,
$ WORK, 1 )
TMPRR = SDOT( N, WORK, 1, VL( 1, KS ), 1 )
TMPRI = SDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
CALL SGEMV( 'N', N, N, ONE, A, LDA, VR( 1, KS+1 ), 1,
$ ZERO, WORK, 1 )
TMPII = SDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
TMPIR = SDOT( N, WORK, 1, VL( 1, KS ), 1 )
UHAV = TMPRR + TMPII
UHAVI = TMPIR - TMPRI
CALL SGEMV( 'N', N, N, ONE, B, LDB, VR( 1, KS ), 1, ZERO,
$ WORK, 1 )
TMPRR = SDOT( N, WORK, 1, VL( 1, KS ), 1 )
TMPRI = SDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
CALL SGEMV( 'N', N, N, ONE, B, LDB, VR( 1, KS+1 ), 1,
$ ZERO, WORK, 1 )
TMPII = SDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
TMPIR = SDOT( N, WORK, 1, VL( 1, KS ), 1 )
UHBV = TMPRR + TMPII
UHBVI = TMPIR - TMPRI
UHAV = SLAPY2( UHAV, UHAVI )
UHBV = SLAPY2( UHBV, UHBVI )
COND = SLAPY2( UHAV, UHBV )
S( KS ) = COND / ( RNRM*LNRM )
S( KS+1 ) = S( KS )
*
ELSE
*
* Real eigenvalue.
*
RNRM = SNRM2( N, VR( 1, KS ), 1 )
LNRM = SNRM2( N, VL( 1, KS ), 1 )
CALL SGEMV( 'N', N, N, ONE, A, LDA, VR( 1, KS ), 1, ZERO,
$ WORK, 1 )
UHAV = SDOT( N, WORK, 1, VL( 1, KS ), 1 )
CALL SGEMV( 'N', N, N, ONE, B, LDB, VR( 1, KS ), 1, ZERO,
$ WORK, 1 )
UHBV = SDOT( N, WORK, 1, VL( 1, KS ), 1 )
COND = SLAPY2( UHAV, UHBV )
IF( COND.EQ.ZERO ) THEN
S( KS ) = -ONE
ELSE
S( KS ) = COND / ( RNRM*LNRM )
END IF
END IF
END IF
*
IF( WANTDF ) THEN
IF( N.EQ.1 ) THEN
DIF( KS ) = SLAPY2( A( 1, 1 ), B( 1, 1 ) )
GO TO 20
END IF
*
* Estimate the reciprocal condition number of the k-th
* eigenvectors.
IF( PAIR ) THEN
*
* Copy the 2-by 2 pencil beginning at (A(k,k), B(k, k)).
* Compute the eigenvalue(s) at position K.
*
WORK( 1 ) = A( K, K )
WORK( 2 ) = A( K+1, K )
WORK( 3 ) = A( K, K+1 )
WORK( 4 ) = A( K+1, K+1 )
WORK( 5 ) = B( K, K )
WORK( 6 ) = B( K+1, K )
WORK( 7 ) = B( K, K+1 )
WORK( 8 ) = B( K+1, K+1 )
CALL SLAG2( WORK, 2, WORK( 5 ), 2, SMLNUM*EPS, BETA,
$ DUMMY1( 1 ), ALPHAR, DUMMY( 1 ), ALPHAI )
ALPRQT = ONE
C1 = TWO*( ALPHAR*ALPHAR+ALPHAI*ALPHAI+BETA*BETA )
C2 = FOUR*BETA*BETA*ALPHAI*ALPHAI
ROOT1 = C1 + SQRT( C1*C1-4.0*C2 )
ROOT2 = C2 / ROOT1
ROOT1 = ROOT1 / TWO
COND = MIN( SQRT( ROOT1 ), SQRT( ROOT2 ) )
END IF
*
* Copy the matrix (A, B) to the array WORK and swap the
* diagonal block beginning at A(k,k) to the (1,1) position.
*
CALL SLACPY( 'Full', N, N, A, LDA, WORK, N )
CALL SLACPY( 'Full', N, N, B, LDB, WORK( N*N+1 ), N )
IFST = K
ILST = 1
*
CALL STGEXC( .FALSE., .FALSE., N, WORK, N, WORK( N*N+1 ), N,
$ DUMMY, 1, DUMMY1, 1, IFST, ILST,
$ WORK( N*N*2+1 ), LWORK-2*N*N, IERR )
*
IF( IERR.GT.0 ) THEN
*
* Ill-conditioned problem - swap rejected.
*
DIF( KS ) = ZERO
ELSE
*
* Reordering successful, solve generalized Sylvester
* equation for R and L,
* A22 * R - L * A11 = A12
* B22 * R - L * B11 = B12,
* and compute estimate of Difl((A11,B11), (A22, B22)).
*
N1 = 1
IF( WORK( 2 ).NE.ZERO )
$ N1 = 2
N2 = N - N1
IF( N2.EQ.0 ) THEN
DIF( KS ) = COND
ELSE
I = N*N + 1
IZ = 2*N*N + 1
CALL STGSYL( 'N', DIFDRI, N2, N1, WORK( N*N1+N1+1 ),
$ N, WORK, N, WORK( N1+1 ), N,
$ WORK( N*N1+N1+I ), N, WORK( I ), N,
$ WORK( N1+I ), N, SCALE, DIF( KS ),
$ WORK( IZ+1 ), LWORK-2*N*N, IWORK, IERR )
*
IF( PAIR )
$ DIF( KS ) = MIN( MAX( ONE, ALPRQT )*DIF( KS ),
$ COND )
END IF
END IF
IF( PAIR )
$ DIF( KS+1 ) = DIF( KS )
END IF
IF( PAIR )
$ KS = KS + 1
*
20 CONTINUE
WORK( 1 ) = LWMIN
RETURN
*
* End of STGSNA
*
END
SUBROUTINE STGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D,
$ LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL,
$ IWORK, PQ, INFO )
*
* -- LAPACK auxiliary routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* January 2007
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N,
$ PQ
REAL RDSCAL, RDSUM, SCALE
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL A( LDA, * ), B( LDB, * ), C( LDC, * ),
$ D( LDD, * ), E( LDE, * ), F( LDF, * )
* ..
*
* Purpose
* =======
*
* STGSY2 solves the generalized Sylvester equation:
*
* A * R - L * B = scale * C (1)
* D * R - L * E = scale * F,
*
* using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices,
* (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,
* N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E)
* must be in generalized Schur canonical form, i.e. A, B are upper
* quasi triangular and D, E are upper triangular. The solution (R, L)
* overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor
* chosen to avoid overflow.
*
* In matrix notation solving equation (1) corresponds to solve
* Z*x = scale*b, where Z is defined as
*
* Z = [ kron(In, A) -kron(B', Im) ] (2)
* [ kron(In, D) -kron(E', Im) ],
*
* Ik is the identity matrix of size k and X' is the transpose of X.
* kron(X, Y) is the Kronecker product between the matrices X and Y.
* In the process of solving (1), we solve a number of such systems
* where Dim(In), Dim(In) = 1 or 2.
*
* If TRANS = 'T', solve the transposed system Z'*y = scale*b for y,
* which is equivalent to solve for R and L in
*
* A' * R + D' * L = scale * C (3)
* R * B' + L * E' = scale * -F
*
* This case is used to compute an estimate of Dif[(A, D), (B, E)] =
* sigma_min(Z) using reverse communicaton with SLACON.
*
* STGSY2 also (IJOB >= 1) contributes to the computation in STGSYL
* of an upper bound on the separation between to matrix pairs. Then
* the input (A, D), (B, E) are sub-pencils of the matrix pair in
* STGSYL. See STGSYL for details.
*
* Arguments
* =========
*
* TRANS (input) CHARACTER*1
* = 'N', solve the generalized Sylvester equation (1).
* = 'T': solve the 'transposed' system (3).
*
* IJOB (input) INTEGER
* Specifies what kind of functionality to be performed.
* = 0: solve (1) only.
* = 1: A contribution from this subsystem to a Frobenius
* norm-based estimate of the separation between two matrix
* pairs is computed. (look ahead strategy is used).
* = 2: A contribution from this subsystem to a Frobenius
* norm-based estimate of the separation between two matrix
* pairs is computed. (SGECON on sub-systems is used.)
* Not referenced if TRANS = 'T'.
*
* M (input) INTEGER
* On entry, M specifies the order of A and D, and the row
* dimension of C, F, R and L.
*
* N (input) INTEGER
* On entry, N specifies the order of B and E, and the column
* dimension of C, F, R and L.
*
* A (input) REAL array, dimension (LDA, M)
* On entry, A contains an upper quasi triangular matrix.
*
* LDA (input) INTEGER
* The leading dimension of the matrix A. LDA >= max(1, M).
*
* B (input) REAL array, dimension (LDB, N)
* On entry, B contains an upper quasi triangular matrix.
*
* LDB (input) INTEGER
* The leading dimension of the matrix B. LDB >= max(1, N).
*
* C (input/output) REAL array, dimension (LDC, N)
* On entry, C contains the right-hand-side of the first matrix
* equation in (1).
* On exit, if IJOB = 0, C has been overwritten by the
* solution R.
*
* LDC (input) INTEGER
* The leading dimension of the matrix C. LDC >= max(1, M).
*
* D (input) REAL array, dimension (LDD, M)
* On entry, D contains an upper triangular matrix.
*
* LDD (input) INTEGER
* The leading dimension of the matrix D. LDD >= max(1, M).
*
* E (input) REAL array, dimension (LDE, N)
* On entry, E contains an upper triangular matrix.
*
* LDE (input) INTEGER
* The leading dimension of the matrix E. LDE >= max(1, N).
*
* F (input/output) REAL array, dimension (LDF, N)
* On entry, F contains the right-hand-side of the second matrix
* equation in (1).
* On exit, if IJOB = 0, F has been overwritten by the
* solution L.
*
* LDF (input) INTEGER
* The leading dimension of the matrix F. LDF >= max(1, M).
*
* SCALE (output) REAL
* On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions
* R and L (C and F on entry) will hold the solutions to a
* slightly perturbed system but the input matrices A, B, D and
* E have not been changed. If SCALE = 0, R and L will hold the
* solutions to the homogeneous system with C = F = 0. Normally,
* SCALE = 1.
*
* RDSUM (input/output) REAL
* On entry, the sum of squares of computed contributions to
* the Dif-estimate under computation by STGSYL, where the
* scaling factor RDSCAL (see below) has been factored out.
* On exit, the corresponding sum of squares updated with the
* contributions from the current sub-system.
* If TRANS = 'T' RDSUM is not touched.
* NOTE: RDSUM only makes sense when STGSY2 is called by STGSYL.
*
* RDSCAL (input/output) REAL
* On entry, scaling factor used to prevent overflow in RDSUM.
* On exit, RDSCAL is updated w.r.t. the current contributions
* in RDSUM.
* If TRANS = 'T', RDSCAL is not touched.
* NOTE: RDSCAL only makes sense when STGSY2 is called by
* STGSYL.
*
* IWORK (workspace) INTEGER array, dimension (M+N+2)
*
* PQ (output) INTEGER
* On exit, the number of subsystems (of size 2-by-2, 4-by-4 and
* 8-by-8) solved by this routine.
*
* INFO (output) INTEGER
* On exit, if INFO is set to
* =0: Successful exit
* <0: If INFO = -i, the i-th argument had an illegal value.
* >0: The matrix pairs (A, D) and (B, E) have common or very
* close eigenvalues.
*
* Further Details
* ===============
*
* Based on contributions by
* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
* Umea University, S-901 87 Umea, Sweden.
*
* =====================================================================
* Replaced various illegal calls to SCOPY by calls to SLASET.
* Sven Hammarling, 27/5/02.
*
* .. Parameters ..
INTEGER LDZ
PARAMETER ( LDZ = 8 )
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN
INTEGER I, IE, IERR, II, IS, ISP1, J, JE, JJ, JS, JSP1,
$ K, MB, NB, P, Q, ZDIM
REAL ALPHA, SCALOC
* ..
* .. Local Arrays ..
INTEGER IPIV( LDZ ), JPIV( LDZ )
REAL RHS( LDZ ), Z( LDZ, LDZ )
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, SGEMM, SGEMV, SGER, SGESC2,
$ SGETC2, SSCAL, SLASET, SLATDF, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Decode and test input parameters
*
INFO = 0
IERR = 0
NOTRAN = LSAME( TRANS, 'N' )
IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
INFO = -1
ELSE IF( NOTRAN ) THEN
IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.2 ) ) THEN
INFO = -2
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( M.LE.0 ) THEN
INFO = -3
ELSE IF( N.LE.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
ELSE IF( LDD.LT.MAX( 1, M ) ) THEN
INFO = -12
ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
INFO = -14
ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
INFO = -16
END IF
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STGSY2', -INFO )
RETURN
END IF
*
* Determine block structure of A
*
PQ = 0
P = 0
I = 1
10 CONTINUE
IF( I.GT.M )
$ GO TO 20
P = P + 1
IWORK( P ) = I
IF( I.EQ.M )
$ GO TO 20
IF( A( I+1, I ).NE.ZERO ) THEN
I = I + 2
ELSE
I = I + 1
END IF
GO TO 10
20 CONTINUE
IWORK( P+1 ) = M + 1
*
* Determine block structure of B
*
Q = P + 1
J = 1
30 CONTINUE
IF( J.GT.N )
$ GO TO 40
Q = Q + 1
IWORK( Q ) = J
IF( J.EQ.N )
$ GO TO 40
IF( B( J+1, J ).NE.ZERO ) THEN
J = J + 2
ELSE
J = J + 1
END IF
GO TO 30
40 CONTINUE
IWORK( Q+1 ) = N + 1
PQ = P*( Q-P-1 )
*
IF( NOTRAN ) THEN
*
* Solve (I, J) - subsystem
* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J)
* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J)
* for I = P, P - 1, ..., 1; J = 1, 2, ..., Q
*
SCALE = ONE
SCALOC = ONE
DO 120 J = P + 2, Q
JS = IWORK( J )
JSP1 = JS + 1
JE = IWORK( J+1 ) - 1
NB = JE - JS + 1
DO 110 I = P, 1, -1
*
IS = IWORK( I )
ISP1 = IS + 1
IE = IWORK( I+1 ) - 1
MB = IE - IS + 1
ZDIM = MB*NB*2
*
IF( ( MB.EQ.1 ) .AND. ( NB.EQ.1 ) ) THEN
*
* Build a 2-by-2 system Z * x = RHS
*
Z( 1, 1 ) = A( IS, IS )
Z( 2, 1 ) = D( IS, IS )
Z( 1, 2 ) = -B( JS, JS )
Z( 2, 2 ) = -E( JS, JS )
*
* Set up right hand side(s)
*
RHS( 1 ) = C( IS, JS )
RHS( 2 ) = F( IS, JS )
*
* Solve Z * x = RHS
*
CALL SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
IF( IERR.GT.0 )
$ INFO = IERR
*
IF( IJOB.EQ.0 ) THEN
CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
$ SCALOC )
IF( SCALOC.NE.ONE ) THEN
DO 50 K = 1, N
CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
CALL SSCAL( M, SCALOC, F( 1, K ), 1 )
50 CONTINUE
SCALE = SCALE*SCALOC
END IF
ELSE
CALL SLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM,
$ RDSCAL, IPIV, JPIV )
END IF
*
* Unpack solution vector(s)
*
C( IS, JS ) = RHS( 1 )
F( IS, JS ) = RHS( 2 )
*
* Substitute R(I, J) and L(I, J) into remaining
* equation.
*
IF( I.GT.1 ) THEN
ALPHA = -RHS( 1 )
CALL SAXPY( IS-1, ALPHA, A( 1, IS ), 1, C( 1, JS ),
$ 1 )
CALL SAXPY( IS-1, ALPHA, D( 1, IS ), 1, F( 1, JS ),
$ 1 )
END IF
IF( J.LT.Q ) THEN
CALL SAXPY( N-JE, RHS( 2 ), B( JS, JE+1 ), LDB,
$ C( IS, JE+1 ), LDC )
CALL SAXPY( N-JE, RHS( 2 ), E( JS, JE+1 ), LDE,
$ F( IS, JE+1 ), LDF )
END IF
*
ELSE IF( ( MB.EQ.1 ) .AND. ( NB.EQ.2 ) ) THEN
*
* Build a 4-by-4 system Z * x = RHS
*
Z( 1, 1 ) = A( IS, IS )
Z( 2, 1 ) = ZERO
Z( 3, 1 ) = D( IS, IS )
Z( 4, 1 ) = ZERO
*
Z( 1, 2 ) = ZERO
Z( 2, 2 ) = A( IS, IS )
Z( 3, 2 ) = ZERO
Z( 4, 2 ) = D( IS, IS )
*
Z( 1, 3 ) = -B( JS, JS )
Z( 2, 3 ) = -B( JS, JSP1 )
Z( 3, 3 ) = -E( JS, JS )
Z( 4, 3 ) = -E( JS, JSP1 )
*
Z( 1, 4 ) = -B( JSP1, JS )
Z( 2, 4 ) = -B( JSP1, JSP1 )
Z( 3, 4 ) = ZERO
Z( 4, 4 ) = -E( JSP1, JSP1 )
*
* Set up right hand side(s)
*
RHS( 1 ) = C( IS, JS )
RHS( 2 ) = C( IS, JSP1 )
RHS( 3 ) = F( IS, JS )
RHS( 4 ) = F( IS, JSP1 )
*
* Solve Z * x = RHS
*
CALL SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
IF( IERR.GT.0 )
$ INFO = IERR
*
IF( IJOB.EQ.0 ) THEN
CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
$ SCALOC )
IF( SCALOC.NE.ONE ) THEN
DO 60 K = 1, N
CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
CALL SSCAL( M, SCALOC, F( 1, K ), 1 )
60 CONTINUE
SCALE = SCALE*SCALOC
END IF
ELSE
CALL SLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM,
$ RDSCAL, IPIV, JPIV )
END IF
*
* Unpack solution vector(s)
*
C( IS, JS ) = RHS( 1 )
C( IS, JSP1 ) = RHS( 2 )
F( IS, JS ) = RHS( 3 )
F( IS, JSP1 ) = RHS( 4 )
*
* Substitute R(I, J) and L(I, J) into remaining
* equation.
*
IF( I.GT.1 ) THEN
CALL SGER( IS-1, NB, -ONE, A( 1, IS ), 1, RHS( 1 ),
$ 1, C( 1, JS ), LDC )
CALL SGER( IS-1, NB, -ONE, D( 1, IS ), 1, RHS( 1 ),
$ 1, F( 1, JS ), LDF )
END IF
IF( J.LT.Q ) THEN
CALL SAXPY( N-JE, RHS( 3 ), B( JS, JE+1 ), LDB,
$ C( IS, JE+1 ), LDC )
CALL SAXPY( N-JE, RHS( 3 ), E( JS, JE+1 ), LDE,
$ F( IS, JE+1 ), LDF )
CALL SAXPY( N-JE, RHS( 4 ), B( JSP1, JE+1 ), LDB,
$ C( IS, JE+1 ), LDC )
CALL SAXPY( N-JE, RHS( 4 ), E( JSP1, JE+1 ), LDE,
$ F( IS, JE+1 ), LDF )
END IF
*
ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN
*
* Build a 4-by-4 system Z * x = RHS
*
Z( 1, 1 ) = A( IS, IS )
Z( 2, 1 ) = A( ISP1, IS )
Z( 3, 1 ) = D( IS, IS )
Z( 4, 1 ) = ZERO
*
Z( 1, 2 ) = A( IS, ISP1 )
Z( 2, 2 ) = A( ISP1, ISP1 )
Z( 3, 2 ) = D( IS, ISP1 )
Z( 4, 2 ) = D( ISP1, ISP1 )
*
Z( 1, 3 ) = -B( JS, JS )
Z( 2, 3 ) = ZERO
Z( 3, 3 ) = -E( JS, JS )
Z( 4, 3 ) = ZERO
*
Z( 1, 4 ) = ZERO
Z( 2, 4 ) = -B( JS, JS )
Z( 3, 4 ) = ZERO
Z( 4, 4 ) = -E( JS, JS )
*
* Set up right hand side(s)
*
RHS( 1 ) = C( IS, JS )
RHS( 2 ) = C( ISP1, JS )
RHS( 3 ) = F( IS, JS )
RHS( 4 ) = F( ISP1, JS )
*
* Solve Z * x = RHS
*
CALL SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
IF( IERR.GT.0 )
$ INFO = IERR
IF( IJOB.EQ.0 ) THEN
CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
$ SCALOC )
IF( SCALOC.NE.ONE ) THEN
DO 70 K = 1, N
CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
CALL SSCAL( M, SCALOC, F( 1, K ), 1 )
70 CONTINUE
SCALE = SCALE*SCALOC
END IF
ELSE
CALL SLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM,
$ RDSCAL, IPIV, JPIV )
END IF
*
* Unpack solution vector(s)
*
C( IS, JS ) = RHS( 1 )
C( ISP1, JS ) = RHS( 2 )
F( IS, JS ) = RHS( 3 )
F( ISP1, JS ) = RHS( 4 )
*
* Substitute R(I, J) and L(I, J) into remaining
* equation.
*
IF( I.GT.1 ) THEN
CALL SGEMV( 'N', IS-1, MB, -ONE, A( 1, IS ), LDA,
$ RHS( 1 ), 1, ONE, C( 1, JS ), 1 )
CALL SGEMV( 'N', IS-1, MB, -ONE, D( 1, IS ), LDD,
$ RHS( 1 ), 1, ONE, F( 1, JS ), 1 )
END IF
IF( J.LT.Q ) THEN
CALL SGER( MB, N-JE, ONE, RHS( 3 ), 1,
$ B( JS, JE+1 ), LDB, C( IS, JE+1 ), LDC )
CALL SGER( MB, N-JE, ONE, RHS( 3 ), 1,
$ E( JS, JE+1 ), LDE, F( IS, JE+1 ), LDF )
END IF
*
ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN
*
* Build an 8-by-8 system Z * x = RHS
*
CALL SLASET( 'F', LDZ, LDZ, ZERO, ZERO, Z, LDZ )
*
Z( 1, 1 ) = A( IS, IS )
Z( 2, 1 ) = A( ISP1, IS )
Z( 5, 1 ) = D( IS, IS )
*
Z( 1, 2 ) = A( IS, ISP1 )
Z( 2, 2 ) = A( ISP1, ISP1 )
Z( 5, 2 ) = D( IS, ISP1 )
Z( 6, 2 ) = D( ISP1, ISP1 )
*
Z( 3, 3 ) = A( IS, IS )
Z( 4, 3 ) = A( ISP1, IS )
Z( 7, 3 ) = D( IS, IS )
*
Z( 3, 4 ) = A( IS, ISP1 )
Z( 4, 4 ) = A( ISP1, ISP1 )
Z( 7, 4 ) = D( IS, ISP1 )
Z( 8, 4 ) = D( ISP1, ISP1 )
*
Z( 1, 5 ) = -B( JS, JS )
Z( 3, 5 ) = -B( JS, JSP1 )
Z( 5, 5 ) = -E( JS, JS )
Z( 7, 5 ) = -E( JS, JSP1 )
*
Z( 2, 6 ) = -B( JS, JS )
Z( 4, 6 ) = -B( JS, JSP1 )
Z( 6, 6 ) = -E( JS, JS )
Z( 8, 6 ) = -E( JS, JSP1 )
*
Z( 1, 7 ) = -B( JSP1, JS )
Z( 3, 7 ) = -B( JSP1, JSP1 )
Z( 7, 7 ) = -E( JSP1, JSP1 )
*
Z( 2, 8 ) = -B( JSP1, JS )
Z( 4, 8 ) = -B( JSP1, JSP1 )
Z( 8, 8 ) = -E( JSP1, JSP1 )
*
* Set up right hand side(s)
*
K = 1
II = MB*NB + 1
DO 80 JJ = 0, NB - 1
CALL SCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 )
CALL SCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ), 1 )
K = K + MB
II = II + MB
80 CONTINUE
*
* Solve Z * x = RHS
*
CALL SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
IF( IERR.GT.0 )
$ INFO = IERR
IF( IJOB.EQ.0 ) THEN
CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
$ SCALOC )
IF( SCALOC.NE.ONE ) THEN
DO 90 K = 1, N
CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
CALL SSCAL( M, SCALOC, F( 1, K ), 1 )
90 CONTINUE
SCALE = SCALE*SCALOC
END IF
ELSE
CALL SLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM,
$ RDSCAL, IPIV, JPIV )
END IF
*
* Unpack solution vector(s)
*
K = 1
II = MB*NB + 1
DO 100 JJ = 0, NB - 1
CALL SCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 )
CALL SCOPY( MB, RHS( II ), 1, F( IS, JS+JJ ), 1 )
K = K + MB
II = II + MB
100 CONTINUE
*
* Substitute R(I, J) and L(I, J) into remaining
* equation.
*
IF( I.GT.1 ) THEN
CALL SGEMM( 'N', 'N', IS-1, NB, MB, -ONE,
$ A( 1, IS ), LDA, RHS( 1 ), MB, ONE,
$ C( 1, JS ), LDC )
CALL SGEMM( 'N', 'N', IS-1, NB, MB, -ONE,
$ D( 1, IS ), LDD, RHS( 1 ), MB, ONE,
$ F( 1, JS ), LDF )
END IF
IF( J.LT.Q ) THEN
K = MB*NB + 1
CALL SGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ),
$ MB, B( JS, JE+1 ), LDB, ONE,
$ C( IS, JE+1 ), LDC )
CALL SGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ),
$ MB, E( JS, JE+1 ), LDE, ONE,
$ F( IS, JE+1 ), LDF )
END IF
*
END IF
*
110 CONTINUE
120 CONTINUE
ELSE
*
* Solve (I, J) - subsystem
* A(I, I)' * R(I, J) + D(I, I)' * L(J, J) = C(I, J)
* R(I, I) * B(J, J) + L(I, J) * E(J, J) = -F(I, J)
* for I = 1, 2, ..., P, J = Q, Q - 1, ..., 1
*
SCALE = ONE
SCALOC = ONE
DO 200 I = 1, P
*
IS = IWORK( I )
ISP1 = IS + 1
IE = IWORK( I+1 ) - 1
MB = IE - IS + 1
DO 190 J = Q, P + 2, -1
*
JS = IWORK( J )
JSP1 = JS + 1
JE = IWORK( J+1 ) - 1
NB = JE - JS + 1
ZDIM = MB*NB*2
IF( ( MB.EQ.1 ) .AND. ( NB.EQ.1 ) ) THEN
*
* Build a 2-by-2 system Z' * x = RHS
*
Z( 1, 1 ) = A( IS, IS )
Z( 2, 1 ) = -B( JS, JS )
Z( 1, 2 ) = D( IS, IS )
Z( 2, 2 ) = -E( JS, JS )
*
* Set up right hand side(s)
*
RHS( 1 ) = C( IS, JS )
RHS( 2 ) = F( IS, JS )
*
* Solve Z' * x = RHS
*
CALL SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
IF( IERR.GT.0 )
$ INFO = IERR
*
CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
IF( SCALOC.NE.ONE ) THEN
DO 130 K = 1, N
CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
CALL SSCAL( M, SCALOC, F( 1, K ), 1 )
130 CONTINUE
SCALE = SCALE*SCALOC
END IF
*
* Unpack solution vector(s)
*
C( IS, JS ) = RHS( 1 )
F( IS, JS ) = RHS( 2 )
*
* Substitute R(I, J) and L(I, J) into remaining
* equation.
*
IF( J.GT.P+2 ) THEN
ALPHA = RHS( 1 )
CALL SAXPY( JS-1, ALPHA, B( 1, JS ), 1, F( IS, 1 ),
$ LDF )
ALPHA = RHS( 2 )
CALL SAXPY( JS-1, ALPHA, E( 1, JS ), 1, F( IS, 1 ),
$ LDF )
END IF
IF( I.LT.P ) THEN
ALPHA = -RHS( 1 )
CALL SAXPY( M-IE, ALPHA, A( IS, IE+1 ), LDA,
$ C( IE+1, JS ), 1 )
ALPHA = -RHS( 2 )
CALL SAXPY( M-IE, ALPHA, D( IS, IE+1 ), LDD,
$ C( IE+1, JS ), 1 )
END IF
*
ELSE IF( ( MB.EQ.1 ) .AND. ( NB.EQ.2 ) ) THEN
*
* Build a 4-by-4 system Z' * x = RHS
*
Z( 1, 1 ) = A( IS, IS )
Z( 2, 1 ) = ZERO
Z( 3, 1 ) = -B( JS, JS )
Z( 4, 1 ) = -B( JSP1, JS )
*
Z( 1, 2 ) = ZERO
Z( 2, 2 ) = A( IS, IS )
Z( 3, 2 ) = -B( JS, JSP1 )
Z( 4, 2 ) = -B( JSP1, JSP1 )
*
Z( 1, 3 ) = D( IS, IS )
Z( 2, 3 ) = ZERO
Z( 3, 3 ) = -E( JS, JS )
Z( 4, 3 ) = ZERO
*
Z( 1, 4 ) = ZERO
Z( 2, 4 ) = D( IS, IS )
Z( 3, 4 ) = -E( JS, JSP1 )
Z( 4, 4 ) = -E( JSP1, JSP1 )
*
* Set up right hand side(s)
*
RHS( 1 ) = C( IS, JS )
RHS( 2 ) = C( IS, JSP1 )
RHS( 3 ) = F( IS, JS )
RHS( 4 ) = F( IS, JSP1 )
*
* Solve Z' * x = RHS
*
CALL SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
IF( IERR.GT.0 )
$ INFO = IERR
CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
IF( SCALOC.NE.ONE ) THEN
DO 140 K = 1, N
CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
CALL SSCAL( M, SCALOC, F( 1, K ), 1 )
140 CONTINUE
SCALE = SCALE*SCALOC
END IF
*
* Unpack solution vector(s)
*
C( IS, JS ) = RHS( 1 )
C( IS, JSP1 ) = RHS( 2 )
F( IS, JS ) = RHS( 3 )
F( IS, JSP1 ) = RHS( 4 )
*
* Substitute R(I, J) and L(I, J) into remaining
* equation.
*
IF( J.GT.P+2 ) THEN
CALL SAXPY( JS-1, RHS( 1 ), B( 1, JS ), 1,
$ F( IS, 1 ), LDF )
CALL SAXPY( JS-1, RHS( 2 ), B( 1, JSP1 ), 1,
$ F( IS, 1 ), LDF )
CALL SAXPY( JS-1, RHS( 3 ), E( 1, JS ), 1,
$ F( IS, 1 ), LDF )
CALL SAXPY( JS-1, RHS( 4 ), E( 1, JSP1 ), 1,
$ F( IS, 1 ), LDF )
END IF
IF( I.LT.P ) THEN
CALL SGER( M-IE, NB, -ONE, A( IS, IE+1 ), LDA,
$ RHS( 1 ), 1, C( IE+1, JS ), LDC )
CALL SGER( M-IE, NB, -ONE, D( IS, IE+1 ), LDD,
$ RHS( 3 ), 1, C( IE+1, JS ), LDC )
END IF
*
ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN
*
* Build a 4-by-4 system Z' * x = RHS
*
Z( 1, 1 ) = A( IS, IS )
Z( 2, 1 ) = A( IS, ISP1 )
Z( 3, 1 ) = -B( JS, JS )
Z( 4, 1 ) = ZERO
*
Z( 1, 2 ) = A( ISP1, IS )
Z( 2, 2 ) = A( ISP1, ISP1 )
Z( 3, 2 ) = ZERO
Z( 4, 2 ) = -B( JS, JS )
*
Z( 1, 3 ) = D( IS, IS )
Z( 2, 3 ) = D( IS, ISP1 )
Z( 3, 3 ) = -E( JS, JS )
Z( 4, 3 ) = ZERO
*
Z( 1, 4 ) = ZERO
Z( 2, 4 ) = D( ISP1, ISP1 )
Z( 3, 4 ) = ZERO
Z( 4, 4 ) = -E( JS, JS )
*
* Set up right hand side(s)
*
RHS( 1 ) = C( IS, JS )
RHS( 2 ) = C( ISP1, JS )
RHS( 3 ) = F( IS, JS )
RHS( 4 ) = F( ISP1, JS )
*
* Solve Z' * x = RHS
*
CALL SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
IF( IERR.GT.0 )
$ INFO = IERR
*
CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
IF( SCALOC.NE.ONE ) THEN
DO 150 K = 1, N
CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
CALL SSCAL( M, SCALOC, F( 1, K ), 1 )
150 CONTINUE
SCALE = SCALE*SCALOC
END IF
*
* Unpack solution vector(s)
*
C( IS, JS ) = RHS( 1 )
C( ISP1, JS ) = RHS( 2 )
F( IS, JS ) = RHS( 3 )
F( ISP1, JS ) = RHS( 4 )
*
* Substitute R(I, J) and L(I, J) into remaining
* equation.
*
IF( J.GT.P+2 ) THEN
CALL SGER( MB, JS-1, ONE, RHS( 1 ), 1, B( 1, JS ),
$ 1, F( IS, 1 ), LDF )
CALL SGER( MB, JS-1, ONE, RHS( 3 ), 1, E( 1, JS ),
$ 1, F( IS, 1 ), LDF )
END IF
IF( I.LT.P ) THEN
CALL SGEMV( 'T', MB, M-IE, -ONE, A( IS, IE+1 ),
$ LDA, RHS( 1 ), 1, ONE, C( IE+1, JS ),
$ 1 )
CALL SGEMV( 'T', MB, M-IE, -ONE, D( IS, IE+1 ),
$ LDD, RHS( 3 ), 1, ONE, C( IE+1, JS ),
$ 1 )
END IF
*
ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN
*
* Build an 8-by-8 system Z' * x = RHS
*
CALL SLASET( 'F', LDZ, LDZ, ZERO, ZERO, Z, LDZ )
*
Z( 1, 1 ) = A( IS, IS )
Z( 2, 1 ) = A( IS, ISP1 )
Z( 5, 1 ) = -B( JS, JS )
Z( 7, 1 ) = -B( JSP1, JS )
*
Z( 1, 2 ) = A( ISP1, IS )
Z( 2, 2 ) = A( ISP1, ISP1 )
Z( 6, 2 ) = -B( JS, JS )
Z( 8, 2 ) = -B( JSP1, JS )
*
Z( 3, 3 ) = A( IS, IS )
Z( 4, 3 ) = A( IS, ISP1 )
Z( 5, 3 ) = -B( JS, JSP1 )
Z( 7, 3 ) = -B( JSP1, JSP1 )
*
Z( 3, 4 ) = A( ISP1, IS )
Z( 4, 4 ) = A( ISP1, ISP1 )
Z( 6, 4 ) = -B( JS, JSP1 )
Z( 8, 4 ) = -B( JSP1, JSP1 )
*
Z( 1, 5 ) = D( IS, IS )
Z( 2, 5 ) = D( IS, ISP1 )
Z( 5, 5 ) = -E( JS, JS )
*
Z( 2, 6 ) = D( ISP1, ISP1 )
Z( 6, 6 ) = -E( JS, JS )
*
Z( 3, 7 ) = D( IS, IS )
Z( 4, 7 ) = D( IS, ISP1 )
Z( 5, 7 ) = -E( JS, JSP1 )
Z( 7, 7 ) = -E( JSP1, JSP1 )
*
Z( 4, 8 ) = D( ISP1, ISP1 )
Z( 6, 8 ) = -E( JS, JSP1 )
Z( 8, 8 ) = -E( JSP1, JSP1 )
*
* Set up right hand side(s)
*
K = 1
II = MB*NB + 1
DO 160 JJ = 0, NB - 1
CALL SCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 )
CALL SCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ), 1 )
K = K + MB
II = II + MB
160 CONTINUE
*
*
* Solve Z' * x = RHS
*
CALL SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
IF( IERR.GT.0 )
$ INFO = IERR
*
CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
IF( SCALOC.NE.ONE ) THEN
DO 170 K = 1, N
CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
CALL SSCAL( M, SCALOC, F( 1, K ), 1 )
170 CONTINUE
SCALE = SCALE*SCALOC
END IF
*
* Unpack solution vector(s)
*
K = 1
II = MB*NB + 1
DO 180 JJ = 0, NB - 1
CALL SCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 )
CALL SCOPY( MB, RHS( II ), 1, F( IS, JS+JJ ), 1 )
K = K + MB
II = II + MB
180 CONTINUE
*
* Substitute R(I, J) and L(I, J) into remaining
* equation.
*
IF( J.GT.P+2 ) THEN
CALL SGEMM( 'N', 'T', MB, JS-1, NB, ONE,
$ C( IS, JS ), LDC, B( 1, JS ), LDB, ONE,
$ F( IS, 1 ), LDF )
CALL SGEMM( 'N', 'T', MB, JS-1, NB, ONE,
$ F( IS, JS ), LDF, E( 1, JS ), LDE, ONE,
$ F( IS, 1 ), LDF )
END IF
IF( I.LT.P ) THEN
CALL SGEMM( 'T', 'N', M-IE, NB, MB, -ONE,
$ A( IS, IE+1 ), LDA, C( IS, JS ), LDC,
$ ONE, C( IE+1, JS ), LDC )
CALL SGEMM( 'T', 'N', M-IE, NB, MB, -ONE,
$ D( IS, IE+1 ), LDD, F( IS, JS ), LDF,
$ ONE, C( IE+1, JS ), LDC )
END IF
*
END IF
*
190 CONTINUE
200 CONTINUE
*
END IF
RETURN
*
* End of STGSY2
*
END
SUBROUTINE STGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D,
$ LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK,
$ IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF,
$ LWORK, M, N
REAL DIF, SCALE
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL A( LDA, * ), B( LDB, * ), C( LDC, * ),
$ D( LDD, * ), E( LDE, * ), F( LDF, * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* STGSYL solves the generalized Sylvester equation:
*
* A * R - L * B = scale * C (1)
* D * R - L * E = scale * F
*
* where R and L are unknown m-by-n matrices, (A, D), (B, E) and
* (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n,
* respectively, with real entries. (A, D) and (B, E) must be in
* generalized (real) Schur canonical form, i.e. A, B are upper quasi
* triangular and D, E are upper triangular.
*
* The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output
* scaling factor chosen to avoid overflow.
*
* In matrix notation (1) is equivalent to solve Zx = scale b, where
* Z is defined as
*
* Z = [ kron(In, A) -kron(B', Im) ] (2)
* [ kron(In, D) -kron(E', Im) ].
*
* Here Ik is the identity matrix of size k and X' is the transpose of
* X. kron(X, Y) is the Kronecker product between the matrices X and Y.
*
* If TRANS = 'T', STGSYL solves the transposed system Z'*y = scale*b,
* which is equivalent to solve for R and L in
*
* A' * R + D' * L = scale * C (3)
* R * B' + L * E' = scale * (-F)
*
* This case (TRANS = 'T') is used to compute an one-norm-based estimate
* of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D)
* and (B,E), using SLACON.
*
* If IJOB >= 1, STGSYL computes a Frobenius norm-based estimate
* of Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the
* reciprocal of the smallest singular value of Z. See [1-2] for more
* information.
*
* This is a level 3 BLAS algorithm.
*
* Arguments
* =========
*
* TRANS (input) CHARACTER*1
* = 'N', solve the generalized Sylvester equation (1).
* = 'T', solve the 'transposed' system (3).
*
* IJOB (input) INTEGER
* Specifies what kind of functionality to be performed.
* =0: solve (1) only.
* =1: The functionality of 0 and 3.
* =2: The functionality of 0 and 4.
* =3: Only an estimate of Dif[(A,D), (B,E)] is computed.
* (look ahead strategy IJOB = 1 is used).
* =4: Only an estimate of Dif[(A,D), (B,E)] is computed.
* ( SGECON on sub-systems is used ).
* Not referenced if TRANS = 'T'.
*
* M (input) INTEGER
* The order of the matrices A and D, and the row dimension of
* the matrices C, F, R and L.
*
* N (input) INTEGER
* The order of the matrices B and E, and the column dimension
* of the matrices C, F, R and L.
*
* A (input) REAL array, dimension (LDA, M)
* The upper quasi triangular matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1, M).
*
* B (input) REAL array, dimension (LDB, N)
* The upper quasi triangular matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1, N).
*
* C (input/output) REAL array, dimension (LDC, N)
* On entry, C contains the right-hand-side of the first matrix
* equation in (1) or (3).
* On exit, if IJOB = 0, 1 or 2, C has been overwritten by
* the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R,
* the solution achieved during the computation of the
* Dif-estimate.
*
* LDC (input) INTEGER
* The leading dimension of the array C. LDC >= max(1, M).
*
* D (input) REAL array, dimension (LDD, M)
* The upper triangular matrix D.
*
* LDD (input) INTEGER
* The leading dimension of the array D. LDD >= max(1, M).
*
* E (input) REAL array, dimension (LDE, N)
* The upper triangular matrix E.
*
* LDE (input) INTEGER
* The leading dimension of the array E. LDE >= max(1, N).
*
* F (input/output) REAL array, dimension (LDF, N)
* On entry, F contains the right-hand-side of the second matrix
* equation in (1) or (3).
* On exit, if IJOB = 0, 1 or 2, F has been overwritten by
* the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L,
* the solution achieved during the computation of the
* Dif-estimate.
*
* LDF (input) INTEGER
* The leading dimension of the array F. LDF >= max(1, M).
*
* DIF (output) REAL
* On exit DIF is the reciprocal of a lower bound of the
* reciprocal of the Dif-function, i.e. DIF is an upper bound of
* Dif[(A,D), (B,E)] = sigma_min(Z), where Z as in (2).
* IF IJOB = 0 or TRANS = 'T', DIF is not touched.
*
* SCALE (output) REAL
* On exit SCALE is the scaling factor in (1) or (3).
* If 0 < SCALE < 1, C and F hold the solutions R and L, resp.,
* to a slightly perturbed system but the input matrices A, B, D
* and E have not been changed. If SCALE = 0, C and F hold the
* solutions R and L, respectively, to the homogeneous system
* with C = F = 0. Normally, SCALE = 1.
*
* WORK (workspace/output) REAL 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 > = 1.
* If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N).
*
* 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.
*
* IWORK (workspace) INTEGER array, dimension (M+N+6)
*
* INFO (output) INTEGER
* =0: successful exit
* <0: If INFO = -i, the i-th argument had an illegal value.
* >0: (A, D) and (B, E) have common or close eigenvalues.
*
* Further Details
* ===============
*
* Based on contributions by
* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
* Umea University, S-901 87 Umea, Sweden.
*
* [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
* for Solving the Generalized Sylvester Equation and Estimating the
* Separation between Regular Matrix Pairs, Report UMINF - 93.23,
* Department of Computing Science, Umea University, S-901 87 Umea,
* Sweden, December 1993, Revised April 1994, Also as LAPACK Working
* Note 75. To appear in ACM Trans. on Math. Software, Vol 22,
* No 1, 1996.
*
* [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester
* Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal.
* Appl., 15(4):1045-1060, 1994
*
* [3] B. Kagstrom and L. Westin, Generalized Schur Methods with
* Condition Estimators for Solving the Generalized Sylvester
* Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7,
* July 1989, pp 745-751.
*
* =====================================================================
* Replaced various illegal calls to SCOPY by calls to SLASET.
* Sven Hammarling, 1/5/02.
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, NOTRAN
INTEGER I, IE, IFUNC, IROUND, IS, ISOLVE, J, JE, JS, K,
$ LINFO, LWMIN, MB, NB, P, PPQQ, PQ, Q
REAL DSCALE, DSUM, SCALE2, SCALOC
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SLACPY, SLASET, SSCAL, STGSY2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, REAL, SQRT
* ..
* .. Executable Statements ..
*
* Decode and test input parameters
*
INFO = 0
NOTRAN = LSAME( TRANS, 'N' )
LQUERY = ( LWORK.EQ.-1 )
*
IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
INFO = -1
ELSE IF( NOTRAN ) THEN
IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.4 ) ) THEN
INFO = -2
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( M.LE.0 ) THEN
INFO = -3
ELSE IF( N.LE.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -6
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
ELSE IF( LDD.LT.MAX( 1, M ) ) THEN
INFO = -12
ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
INFO = -14
ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
INFO = -16
END IF
END IF
*
IF( INFO.EQ.0 ) THEN
IF( NOTRAN ) THEN
IF( IJOB.EQ.1 .OR. IJOB.EQ.2 ) THEN
LWMIN = MAX( 1, 2*M*N )
ELSE
LWMIN = 1
END IF
ELSE
LWMIN = 1
END IF
WORK( 1 ) = LWMIN
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -20
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STGSYL', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
SCALE = 1
IF( NOTRAN ) THEN
IF( IJOB.NE.0 ) THEN
DIF = 0
END IF
END IF
RETURN
END IF
*
* Determine optimal block sizes MB and NB
*
MB = ILAENV( 2, 'STGSYL', TRANS, M, N, -1, -1 )
NB = ILAENV( 5, 'STGSYL', TRANS, M, N, -1, -1 )
*
ISOLVE = 1
IFUNC = 0
IF( NOTRAN ) THEN
IF( IJOB.GE.3 ) THEN
IFUNC = IJOB - 2
CALL SLASET( 'F', M, N, ZERO, ZERO, C, LDC )
CALL SLASET( 'F', M, N, ZERO, ZERO, F, LDF )
ELSE IF( IJOB.GE.1 .AND. NOTRAN ) THEN
ISOLVE = 2
END IF
END IF
*
IF( ( MB.LE.1 .AND. NB.LE.1 ) .OR. ( MB.GE.M .AND. NB.GE.N ) )
$ THEN
*
DO 30 IROUND = 1, ISOLVE
*
* Use unblocked Level 2 solver
*
DSCALE = ZERO
DSUM = ONE
PQ = 0
CALL STGSY2( TRANS, IFUNC, M, N, A, LDA, B, LDB, C, LDC, D,
$ LDD, E, LDE, F, LDF, SCALE, DSUM, DSCALE,
$ IWORK, PQ, INFO )
IF( DSCALE.NE.ZERO ) THEN
IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN
DIF = SQRT( REAL( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) )
ELSE
DIF = SQRT( REAL( PQ ) ) / ( DSCALE*SQRT( DSUM ) )
END IF
END IF
*
IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN
IF( NOTRAN ) THEN
IFUNC = IJOB
END IF
SCALE2 = SCALE
CALL SLACPY( 'F', M, N, C, LDC, WORK, M )
CALL SLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M )
CALL SLASET( 'F', M, N, ZERO, ZERO, C, LDC )
CALL SLASET( 'F', M, N, ZERO, ZERO, F, LDF )
ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN
CALL SLACPY( 'F', M, N, WORK, M, C, LDC )
CALL SLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF )
SCALE = SCALE2
END IF
30 CONTINUE
*
RETURN
END IF
*
* Determine block structure of A
*
P = 0
I = 1
40 CONTINUE
IF( I.GT.M )
$ GO TO 50
P = P + 1
IWORK( P ) = I
I = I + MB
IF( I.GE.M )
$ GO TO 50
IF( A( I, I-1 ).NE.ZERO )
$ I = I + 1
GO TO 40
50 CONTINUE
*
IWORK( P+1 ) = M + 1
IF( IWORK( P ).EQ.IWORK( P+1 ) )
$ P = P - 1
*
* Determine block structure of B
*
Q = P + 1
J = 1
60 CONTINUE
IF( J.GT.N )
$ GO TO 70
Q = Q + 1
IWORK( Q ) = J
J = J + NB
IF( J.GE.N )
$ GO TO 70
IF( B( J, J-1 ).NE.ZERO )
$ J = J + 1
GO TO 60
70 CONTINUE
*
IWORK( Q+1 ) = N + 1
IF( IWORK( Q ).EQ.IWORK( Q+1 ) )
$ Q = Q - 1
*
IF( NOTRAN ) THEN
*
DO 150 IROUND = 1, ISOLVE
*
* Solve (I, J)-subsystem
* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J)
* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J)
* for I = P, P - 1,..., 1; J = 1, 2,..., Q
*
DSCALE = ZERO
DSUM = ONE
PQ = 0
SCALE = ONE
DO 130 J = P + 2, Q
JS = IWORK( J )
JE = IWORK( J+1 ) - 1
NB = JE - JS + 1
DO 120 I = P, 1, -1
IS = IWORK( I )
IE = IWORK( I+1 ) - 1
MB = IE - IS + 1
PPQQ = 0
CALL STGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA,
$ B( JS, JS ), LDB, C( IS, JS ), LDC,
$ D( IS, IS ), LDD, E( JS, JS ), LDE,
$ F( IS, JS ), LDF, SCALOC, DSUM, DSCALE,
$ IWORK( Q+2 ), PPQQ, LINFO )
IF( LINFO.GT.0 )
$ INFO = LINFO
*
PQ = PQ + PPQQ
IF( SCALOC.NE.ONE ) THEN
DO 80 K = 1, JS - 1
CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
CALL SSCAL( M, SCALOC, F( 1, K ), 1 )
80 CONTINUE
DO 90 K = JS, JE
CALL SSCAL( IS-1, SCALOC, C( 1, K ), 1 )
CALL SSCAL( IS-1, SCALOC, F( 1, K ), 1 )
90 CONTINUE
DO 100 K = JS, JE
CALL SSCAL( M-IE, SCALOC, C( IE+1, K ), 1 )
CALL SSCAL( M-IE, SCALOC, F( IE+1, K ), 1 )
100 CONTINUE
DO 110 K = JE + 1, N
CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
CALL SSCAL( M, SCALOC, F( 1, K ), 1 )
110 CONTINUE
SCALE = SCALE*SCALOC
END IF
*
* Substitute R(I, J) and L(I, J) into remaining
* equation.
*
IF( I.GT.1 ) THEN
CALL SGEMM( 'N', 'N', IS-1, NB, MB, -ONE,
$ A( 1, IS ), LDA, C( IS, JS ), LDC, ONE,
$ C( 1, JS ), LDC )
CALL SGEMM( 'N', 'N', IS-1, NB, MB, -ONE,
$ D( 1, IS ), LDD, C( IS, JS ), LDC, ONE,
$ F( 1, JS ), LDF )
END IF
IF( J.LT.Q ) THEN
CALL SGEMM( 'N', 'N', MB, N-JE, NB, ONE,
$ F( IS, JS ), LDF, B( JS, JE+1 ), LDB,
$ ONE, C( IS, JE+1 ), LDC )
CALL SGEMM( 'N', 'N', MB, N-JE, NB, ONE,
$ F( IS, JS ), LDF, E( JS, JE+1 ), LDE,
$ ONE, F( IS, JE+1 ), LDF )
END IF
120 CONTINUE
130 CONTINUE
IF( DSCALE.NE.ZERO ) THEN
IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN
DIF = SQRT( REAL( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) )
ELSE
DIF = SQRT( REAL( PQ ) ) / ( DSCALE*SQRT( DSUM ) )
END IF
END IF
IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN
IF( NOTRAN ) THEN
IFUNC = IJOB
END IF
SCALE2 = SCALE
CALL SLACPY( 'F', M, N, C, LDC, WORK, M )
CALL SLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M )
CALL SLASET( 'F', M, N, ZERO, ZERO, C, LDC )
CALL SLASET( 'F', M, N, ZERO, ZERO, F, LDF )
ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN
CALL SLACPY( 'F', M, N, WORK, M, C, LDC )
CALL SLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF )
SCALE = SCALE2
END IF
150 CONTINUE
*
ELSE
*
* Solve transposed (I, J)-subsystem
* A(I, I)' * R(I, J) + D(I, I)' * L(I, J) = C(I, J)
* R(I, J) * B(J, J)' + L(I, J) * E(J, J)' = -F(I, J)
* for I = 1,2,..., P; J = Q, Q-1,..., 1
*
SCALE = ONE
DO 210 I = 1, P
IS = IWORK( I )
IE = IWORK( I+1 ) - 1
MB = IE - IS + 1
DO 200 J = Q, P + 2, -1
JS = IWORK( J )
JE = IWORK( J+1 ) - 1
NB = JE - JS + 1
CALL STGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA,
$ B( JS, JS ), LDB, C( IS, JS ), LDC,
$ D( IS, IS ), LDD, E( JS, JS ), LDE,
$ F( IS, JS ), LDF, SCALOC, DSUM, DSCALE,
$ IWORK( Q+2 ), PPQQ, LINFO )
IF( LINFO.GT.0 )
$ INFO = LINFO
IF( SCALOC.NE.ONE ) THEN
DO 160 K = 1, JS - 1
CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
CALL SSCAL( M, SCALOC, F( 1, K ), 1 )
160 CONTINUE
DO 170 K = JS, JE
CALL SSCAL( IS-1, SCALOC, C( 1, K ), 1 )
CALL SSCAL( IS-1, SCALOC, F( 1, K ), 1 )
170 CONTINUE
DO 180 K = JS, JE
CALL SSCAL( M-IE, SCALOC, C( IE+1, K ), 1 )
CALL SSCAL( M-IE, SCALOC, F( IE+1, K ), 1 )
180 CONTINUE
DO 190 K = JE + 1, N
CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
CALL SSCAL( M, SCALOC, F( 1, K ), 1 )
190 CONTINUE
SCALE = SCALE*SCALOC
END IF
*
* Substitute R(I, J) and L(I, J) into remaining equation.
*
IF( J.GT.P+2 ) THEN
CALL SGEMM( 'N', 'T', MB, JS-1, NB, ONE, C( IS, JS ),
$ LDC, B( 1, JS ), LDB, ONE, F( IS, 1 ),
$ LDF )
CALL SGEMM( 'N', 'T', MB, JS-1, NB, ONE, F( IS, JS ),
$ LDF, E( 1, JS ), LDE, ONE, F( IS, 1 ),
$ LDF )
END IF
IF( I.LT.P ) THEN
CALL SGEMM( 'T', 'N', M-IE, NB, MB, -ONE,
$ A( IS, IE+1 ), LDA, C( IS, JS ), LDC, ONE,
$ C( IE+1, JS ), LDC )
CALL SGEMM( 'T', 'N', M-IE, NB, MB, -ONE,
$ D( IS, IE+1 ), LDD, F( IS, JS ), LDF, ONE,
$ C( IE+1, JS ), LDC )
END IF
200 CONTINUE
210 CONTINUE
*
END IF
*
WORK( 1 ) = LWMIN
*
RETURN
*
* End of STGSYL
*
END
SUBROUTINE STPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER DIAG, NORM, UPLO
INTEGER INFO, N
REAL RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL AP( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* STPCON estimates the reciprocal of the condition number of a packed
* triangular matrix A, in either the 1-norm or the infinity-norm.
*
* The norm of A is computed and an estimate is obtained for
* norm(inv(A)), then the reciprocal of the condition number is
* computed as
* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies whether the 1-norm condition number or the
* infinity-norm condition number is required:
* = '1' or 'O': 1-norm;
* = 'I': Infinity-norm.
*
* UPLO (input) CHARACTER*1
* = 'U': A is upper triangular;
* = 'L': A is lower triangular.
*
* DIAG (input) CHARACTER*1
* = 'N': A is non-unit triangular;
* = 'U': A is unit triangular.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input) REAL array, dimension (N*(N+1)/2)
* The upper or lower triangular matrix A, packed columnwise in
* a linear array. The j-th column of A is stored in the array
* AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
* If DIAG = 'U', the diagonal elements of A are not referenced
* and are assumed to be 1.
*
* RCOND (output) REAL
* The reciprocal of the condition number of the matrix A,
* computed as RCOND = 1/(norm(A) * norm(inv(A))).
*
* WORK (workspace) REAL array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT, ONENRM, UPPER
CHARACTER NORMIN
INTEGER IX, KASE, KASE1
REAL AINVNM, ANORM, SCALE, SMLNUM, XNORM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SLAMCH, SLANTP
EXTERNAL LSAME, ISAMAX, SLAMCH, SLANTP
* ..
* .. External Subroutines ..
EXTERNAL SLACN2, SLATPS, SRSCL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, REAL
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
NOUNIT = LSAME( DIAG, 'N' )
*
IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
INFO = -1
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STPCON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
END IF
*
RCOND = ZERO
SMLNUM = SLAMCH( 'Safe minimum' )*REAL( MAX( 1, N ) )
*
* Compute the norm of the triangular matrix A.
*
ANORM = SLANTP( NORM, UPLO, DIAG, N, AP, WORK )
*
* Continue only if ANORM > 0.
*
IF( ANORM.GT.ZERO ) THEN
*
* Estimate the norm of the inverse of A.
*
AINVNM = ZERO
NORMIN = 'N'
IF( ONENRM ) THEN
KASE1 = 1
ELSE
KASE1 = 2
END IF
KASE = 0
10 CONTINUE
CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.KASE1 ) THEN
*
* Multiply by inv(A).
*
CALL SLATPS( UPLO, 'No transpose', DIAG, NORMIN, N, AP,
$ WORK, SCALE, WORK( 2*N+1 ), INFO )
ELSE
*
* Multiply by inv(A').
*
CALL SLATPS( UPLO, 'Transpose', DIAG, NORMIN, N, AP,
$ WORK, SCALE, WORK( 2*N+1 ), INFO )
END IF
NORMIN = 'Y'
*
* Multiply by 1/SCALE if doing so will not cause overflow.
*
IF( SCALE.NE.ONE ) THEN
IX = ISAMAX( N, WORK, 1 )
XNORM = ABS( WORK( IX ) )
IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO )
$ GO TO 20
CALL SRSCL( N, SCALE, WORK, 1 )
END IF
GO TO 10
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / ANORM ) / AINVNM
END IF
*
20 CONTINUE
RETURN
*
* End of STPCON
*
END
SUBROUTINE STPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX,
$ FERR, BERR, WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER INFO, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL AP( * ), B( LDB, * ), BERR( * ), FERR( * ),
$ WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* STPRFS provides error bounds and backward error estimates for the
* solution to a system of linear equations with a triangular packed
* coefficient matrix.
*
* The solution matrix X must be computed by STPTRS or some other
* means before entering this routine. STPRFS does not do iterative
* refinement because doing so cannot improve the backward error.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': A is upper triangular;
* = 'L': A is lower triangular.
*
* 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**H * X = B (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* = 'N': A is non-unit triangular;
* = 'U': A is unit triangular.
*
* 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 matrices B and X. NRHS >= 0.
*
* AP (input) REAL array, dimension (N*(N+1)/2)
* The upper or lower triangular matrix A, packed columnwise in
* a linear array. The j-th column of A is stored in the array
* AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
* If DIAG = 'U', the diagonal elements of A are not referenced
* and are assumed to be 1.
*
* B (input) REAL array, dimension (LDB,NRHS)
* The right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input) REAL array, dimension (LDX,NRHS)
* The solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* FERR (output) REAL array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) REAL array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN, NOUNIT, UPPER
CHARACTER TRANST
INTEGER I, J, K, KASE, KC, NZ
REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, SLACN2, STPMV, STPSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH
EXTERNAL LSAME, SLAMCH
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOTRAN = LSAME( TRANS, 'N' )
NOUNIT = LSAME( DIAG, 'N' )
*
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
$ LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( NRHS.LT.0 ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STPRFS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
DO 10 J = 1, NRHS
FERR( J ) = ZERO
BERR( J ) = ZERO
10 CONTINUE
RETURN
END IF
*
IF( NOTRAN ) THEN
TRANST = 'T'
ELSE
TRANST = 'N'
END IF
*
* NZ = maximum number of nonzero elements in each row of A, plus 1
*
NZ = N + 1
EPS = SLAMCH( 'Epsilon' )
SAFMIN = SLAMCH( 'Safe minimum' )
SAFE1 = NZ*SAFMIN
SAFE2 = SAFE1 / EPS
*
* Do for each right hand side
*
DO 250 J = 1, NRHS
*
* Compute residual R = B - op(A) * X,
* where op(A) = A or A', depending on TRANS.
*
CALL SCOPY( N, X( 1, J ), 1, WORK( N+1 ), 1 )
CALL STPMV( UPLO, TRANS, DIAG, N, AP, WORK( N+1 ), 1 )
CALL SAXPY( N, -ONE, B( 1, J ), 1, WORK( N+1 ), 1 )
*
* Compute componentwise relative backward error from formula
*
* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
*
* where abs(Z) is the componentwise absolute value of the matrix
* or vector Z. If the i-th component of the denominator is less
* than SAFE2, then SAFE1 is added to the i-th components of the
* numerator and denominator before dividing.
*
DO 20 I = 1, N
WORK( I ) = ABS( B( I, J ) )
20 CONTINUE
*
IF( NOTRAN ) THEN
*
* Compute abs(A)*abs(X) + abs(B).
*
IF( UPPER ) THEN
KC = 1
IF( NOUNIT ) THEN
DO 40 K = 1, N
XK = ABS( X( K, J ) )
DO 30 I = 1, K
WORK( I ) = WORK( I ) + ABS( AP( KC+I-1 ) )*XK
30 CONTINUE
KC = KC + K
40 CONTINUE
ELSE
DO 60 K = 1, N
XK = ABS( X( K, J ) )
DO 50 I = 1, K - 1
WORK( I ) = WORK( I ) + ABS( AP( KC+I-1 ) )*XK
50 CONTINUE
WORK( K ) = WORK( K ) + XK
KC = KC + K
60 CONTINUE
END IF
ELSE
KC = 1
IF( NOUNIT ) THEN
DO 80 K = 1, N
XK = ABS( X( K, J ) )
DO 70 I = K, N
WORK( I ) = WORK( I ) + ABS( AP( KC+I-K ) )*XK
70 CONTINUE
KC = KC + N - K + 1
80 CONTINUE
ELSE
DO 100 K = 1, N
XK = ABS( X( K, J ) )
DO 90 I = K + 1, N
WORK( I ) = WORK( I ) + ABS( AP( KC+I-K ) )*XK
90 CONTINUE
WORK( K ) = WORK( K ) + XK
KC = KC + N - K + 1
100 CONTINUE
END IF
END IF
ELSE
*
* Compute abs(A')*abs(X) + abs(B).
*
IF( UPPER ) THEN
KC = 1
IF( NOUNIT ) THEN
DO 120 K = 1, N
S = ZERO
DO 110 I = 1, K
S = S + ABS( AP( KC+I-1 ) )*ABS( X( I, J ) )
110 CONTINUE
WORK( K ) = WORK( K ) + S
KC = KC + K
120 CONTINUE
ELSE
DO 140 K = 1, N
S = ABS( X( K, J ) )
DO 130 I = 1, K - 1
S = S + ABS( AP( KC+I-1 ) )*ABS( X( I, J ) )
130 CONTINUE
WORK( K ) = WORK( K ) + S
KC = KC + K
140 CONTINUE
END IF
ELSE
KC = 1
IF( NOUNIT ) THEN
DO 160 K = 1, N
S = ZERO
DO 150 I = K, N
S = S + ABS( AP( KC+I-K ) )*ABS( X( I, J ) )
150 CONTINUE
WORK( K ) = WORK( K ) + S
KC = KC + N - K + 1
160 CONTINUE
ELSE
DO 180 K = 1, N
S = ABS( X( K, J ) )
DO 170 I = K + 1, N
S = S + ABS( AP( KC+I-K ) )*ABS( X( I, J ) )
170 CONTINUE
WORK( K ) = WORK( K ) + S
KC = KC + N - K + 1
180 CONTINUE
END IF
END IF
END IF
S = ZERO
DO 190 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
ELSE
S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
$ ( WORK( I )+SAFE1 ) )
END IF
190 CONTINUE
BERR( J ) = S
*
* Bound error from formula
*
* norm(X - XTRUE) / norm(X) .le. FERR =
* norm( abs(inv(op(A)))*
* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
*
* where
* norm(Z) is the magnitude of the largest component of Z
* inv(op(A)) is the inverse of op(A)
* abs(Z) is the componentwise absolute value of the matrix or
* vector Z
* NZ is the maximum number of nonzeros in any row of A, plus 1
* EPS is machine epsilon
*
* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
* is incremented by SAFE1 if the i-th component of
* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
*
* Use SLACN2 to estimate the infinity-norm of the matrix
* inv(op(A)) * diag(W),
* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
*
DO 200 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
ELSE
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
END IF
200 CONTINUE
*
KASE = 0
210 CONTINUE
CALL SLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
$ KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Multiply by diag(W)*inv(op(A)').
*
CALL STPSV( UPLO, TRANST, DIAG, N, AP, WORK( N+1 ), 1 )
DO 220 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
220 CONTINUE
ELSE
*
* Multiply by inv(op(A))*diag(W).
*
DO 230 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
230 CONTINUE
CALL STPSV( UPLO, TRANS, DIAG, N, AP, WORK( N+1 ), 1 )
END IF
GO TO 210
END IF
*
* Normalize error.
*
LSTRES = ZERO
DO 240 I = 1, N
LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
240 CONTINUE
IF( LSTRES.NE.ZERO )
$ FERR( J ) = FERR( J ) / LSTRES
*
250 CONTINUE
*
RETURN
*
* End of STPRFS
*
END
SUBROUTINE STPTRI( UPLO, DIAG, N, AP, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, UPLO
INTEGER INFO, N
* ..
* .. Array Arguments ..
REAL AP( * )
* ..
*
* Purpose
* =======
*
* STPTRI computes the inverse of a real upper or lower triangular
* matrix A stored in packed format.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': A is upper triangular;
* = 'L': A is lower triangular.
*
* DIAG (input) CHARACTER*1
* = 'N': A is non-unit triangular;
* = 'U': A is unit triangular.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input/output) REAL array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangular matrix A, stored
* columnwise in a linear array. The j-th column of A is stored
* in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n.
* See below for further details.
* On exit, the (triangular) inverse of the original matrix, in
* the same packed storage format.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, A(i,i) is exactly zero. The triangular
* matrix is singular and its inverse can not be computed.
*
* Further Details
* ===============
*
* A triangular matrix A can be transferred to packed storage using one
* of the following program segments:
*
* UPLO = 'U': UPLO = 'L':
*
* JC = 1 JC = 1
* DO 2 J = 1, N DO 2 J = 1, N
* DO 1 I = 1, J DO 1 I = J, N
* AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J)
* 1 CONTINUE 1 CONTINUE
* JC = JC + J JC = JC + N - J + 1
* 2 CONTINUE 2 CONTINUE
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT, UPPER
INTEGER J, JC, JCLAST, JJ
REAL AJJ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SSCAL, STPMV, XERBLA
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOUNIT = LSAME( DIAG, 'N' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STPTRI', -INFO )
RETURN
END IF
*
* Check for singularity if non-unit.
*
IF( NOUNIT ) THEN
IF( UPPER ) THEN
JJ = 0
DO 10 INFO = 1, N
JJ = JJ + INFO
IF( AP( JJ ).EQ.ZERO )
$ RETURN
10 CONTINUE
ELSE
JJ = 1
DO 20 INFO = 1, N
IF( AP( JJ ).EQ.ZERO )
$ RETURN
JJ = JJ + N - INFO + 1
20 CONTINUE
END IF
INFO = 0
END IF
*
IF( UPPER ) THEN
*
* Compute inverse of upper triangular matrix.
*
JC = 1
DO 30 J = 1, N
IF( NOUNIT ) THEN
AP( JC+J-1 ) = ONE / AP( JC+J-1 )
AJJ = -AP( JC+J-1 )
ELSE
AJJ = -ONE
END IF
*
* Compute elements 1:j-1 of j-th column.
*
CALL STPMV( 'Upper', 'No transpose', DIAG, J-1, AP,
$ AP( JC ), 1 )
CALL SSCAL( J-1, AJJ, AP( JC ), 1 )
JC = JC + J
30 CONTINUE
*
ELSE
*
* Compute inverse of lower triangular matrix.
*
JC = N*( N+1 ) / 2
DO 40 J = N, 1, -1
IF( NOUNIT ) THEN
AP( JC ) = ONE / AP( JC )
AJJ = -AP( JC )
ELSE
AJJ = -ONE
END IF
IF( J.LT.N ) THEN
*
* Compute elements j+1:n of j-th column.
*
CALL STPMV( 'Lower', 'No transpose', DIAG, N-J,
$ AP( JCLAST ), AP( JC+1 ), 1 )
CALL SSCAL( N-J, AJJ, AP( JC+1 ), 1 )
END IF
JCLAST = JC
JC = JC - N + J - 2
40 CONTINUE
END IF
*
RETURN
*
* End of STPTRI
*
END
SUBROUTINE STPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
REAL AP( * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* STPTRS solves a triangular system of the form
*
* A * X = B or A**T * X = B,
*
* where A is a triangular matrix of order N stored in packed format,
* and B is an N-by-NRHS matrix. A check is made to verify that A is
* nonsingular.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': A is upper triangular;
* = 'L': A is lower triangular.
*
* 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**H * X = B (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* = 'N': A is non-unit triangular;
* = 'U': A is unit triangular.
*
* 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.
*
* AP (input) REAL array, dimension (N*(N+1)/2)
* The upper or lower triangular matrix A, packed columnwise in
* a linear array. The j-th column of A is stored in the array
* AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the right hand side matrix B.
* On exit, if INFO = 0, 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
* > 0: if INFO = i, the i-th diagonal element of A is zero,
* indicating that the matrix is singular and the
* solutions X have not been computed.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT, UPPER
INTEGER J, JC
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL STPSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOUNIT = LSAME( DIAG, 'N' )
IF( .NOT.UPPER .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.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( NRHS.LT.0 ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STPTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Check for singularity.
*
IF( NOUNIT ) THEN
IF( UPPER ) THEN
JC = 1
DO 10 INFO = 1, N
IF( AP( JC+INFO-1 ).EQ.ZERO )
$ RETURN
JC = JC + INFO
10 CONTINUE
ELSE
JC = 1
DO 20 INFO = 1, N
IF( AP( JC ).EQ.ZERO )
$ RETURN
JC = JC + N - INFO + 1
20 CONTINUE
END IF
END IF
INFO = 0
*
* Solve A * x = b or A' * x = b.
*
DO 30 J = 1, NRHS
CALL STPSV( UPLO, TRANS, DIAG, N, AP, B( 1, J ), 1 )
30 CONTINUE
*
RETURN
*
* End of STPTRS
*
END
SUBROUTINE STRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK,
$ IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER DIAG, NORM, UPLO
INTEGER INFO, LDA, N
REAL RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL A( LDA, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* STRCON estimates the reciprocal of the condition number of a
* triangular matrix A, in either the 1-norm or the infinity-norm.
*
* The norm of A is computed and an estimate is obtained for
* norm(inv(A)), then the reciprocal of the condition number is
* computed as
* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies whether the 1-norm condition number or the
* infinity-norm condition number is required:
* = '1' or 'O': 1-norm;
* = 'I': Infinity-norm.
*
* UPLO (input) CHARACTER*1
* = 'U': A is upper triangular;
* = 'L': A is lower triangular.
*
* DIAG (input) CHARACTER*1
* = 'N': A is non-unit triangular;
* = 'U': A is unit triangular.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The triangular matrix A. If UPLO = 'U', the leading N-by-N
* upper triangular part of the array A contains the upper
* triangular matrix, and the strictly lower triangular part of
* A is not referenced. If UPLO = 'L', the leading N-by-N lower
* triangular part of the array A contains the lower triangular
* matrix, and the strictly upper triangular part of A is not
* referenced. If DIAG = 'U', the diagonal elements of A are
* also not referenced and are assumed to be 1.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* RCOND (output) REAL
* The reciprocal of the condition number of the matrix A,
* computed as RCOND = 1/(norm(A) * norm(inv(A))).
*
* WORK (workspace) REAL array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT, ONENRM, UPPER
CHARACTER NORMIN
INTEGER IX, KASE, KASE1
REAL AINVNM, ANORM, SCALE, SMLNUM, XNORM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SLAMCH, SLANTR
EXTERNAL LSAME, ISAMAX, SLAMCH, SLANTR
* ..
* .. External Subroutines ..
EXTERNAL SLACN2, SLATRS, SRSCL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, REAL
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
NOUNIT = LSAME( DIAG, 'N' )
*
IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
INFO = -1
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STRCON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
END IF
*
RCOND = ZERO
SMLNUM = SLAMCH( 'Safe minimum' )*REAL( MAX( 1, N ) )
*
* Compute the norm of the triangular matrix A.
*
ANORM = SLANTR( NORM, UPLO, DIAG, N, N, A, LDA, WORK )
*
* Continue only if ANORM > 0.
*
IF( ANORM.GT.ZERO ) THEN
*
* Estimate the norm of the inverse of A.
*
AINVNM = ZERO
NORMIN = 'N'
IF( ONENRM ) THEN
KASE1 = 1
ELSE
KASE1 = 2
END IF
KASE = 0
10 CONTINUE
CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.KASE1 ) THEN
*
* Multiply by inv(A).
*
CALL SLATRS( UPLO, 'No transpose', DIAG, NORMIN, N, A,
$ LDA, WORK, SCALE, WORK( 2*N+1 ), INFO )
ELSE
*
* Multiply by inv(A').
*
CALL SLATRS( UPLO, 'Transpose', DIAG, NORMIN, N, A, LDA,
$ WORK, SCALE, WORK( 2*N+1 ), INFO )
END IF
NORMIN = 'Y'
*
* Multiply by 1/SCALE if doing so will not cause overflow.
*
IF( SCALE.NE.ONE ) THEN
IX = ISAMAX( N, WORK, 1 )
XNORM = ABS( WORK( IX ) )
IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO )
$ GO TO 20
CALL SRSCL( N, SCALE, WORK, 1 )
END IF
GO TO 10
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / ANORM ) / AINVNM
END IF
*
20 CONTINUE
RETURN
*
* End of STRCON
*
END
SUBROUTINE STREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
$ LDVR, MM, M, WORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER HOWMNY, SIDE
INTEGER INFO, LDT, LDVL, LDVR, M, MM, N
* ..
* .. Array Arguments ..
LOGICAL SELECT( * )
REAL T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* STREVC computes some or all of the right and/or left eigenvectors of
* a real upper quasi-triangular matrix T.
* Matrices of this type are produced by the Schur factorization of
* a real general matrix: A = Q*T*Q**T, as computed by SHSEQR.
*
* The right eigenvector x and the left eigenvector y of T corresponding
* to an eigenvalue w are defined by:
*
* T*x = w*x, (y**H)*T = w*(y**H)
*
* where y**H denotes the conjugate transpose of y.
* The eigenvalues are not input to this routine, but are read directly
* from the diagonal blocks of T.
*
* This routine returns the matrices X and/or Y of right and left
* eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
* input matrix. If Q is the orthogonal factor that reduces a matrix
* A to Schur form T, then Q*X and Q*Y are the matrices of right and
* left eigenvectors of A.
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* = 'R': compute right eigenvectors only;
* = 'L': compute left eigenvectors only;
* = 'B': compute both right and left eigenvectors.
*
* HOWMNY (input) CHARACTER*1
* = 'A': compute all right and/or left eigenvectors;
* = 'B': compute all right and/or left eigenvectors,
* backtransformed by the matrices in VR and/or VL;
* = 'S': compute selected right and/or left eigenvectors,
* as indicated by the logical array SELECT.
*
* SELECT (input/output) LOGICAL array, dimension (N)
* If HOWMNY = 'S', SELECT specifies the eigenvectors to be
* computed.
* If w(j) is a real eigenvalue, the corresponding real
* eigenvector is computed if SELECT(j) is .TRUE..
* If w(j) and w(j+1) are the real and imaginary parts of a
* complex eigenvalue, the corresponding complex eigenvector is
* computed if either SELECT(j) or SELECT(j+1) is .TRUE., and
* on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to
* .FALSE..
* Not referenced if HOWMNY = 'A' or 'B'.
*
* N (input) INTEGER
* The order of the matrix T. N >= 0.
*
* T (input) REAL array, dimension (LDT,N)
* The upper quasi-triangular matrix T in Schur canonical form.
*
* LDT (input) INTEGER
* The leading dimension of the array T. LDT >= max(1,N).
*
* VL (input/output) REAL array, dimension (LDVL,MM)
* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
* contain an N-by-N matrix Q (usually the orthogonal matrix Q
* of Schur vectors returned by SHSEQR).
* On exit, if SIDE = 'L' or 'B', VL contains:
* if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
* if HOWMNY = 'B', the matrix Q*Y;
* if HOWMNY = 'S', the left eigenvectors of T specified by
* SELECT, stored consecutively in the columns
* of VL, in the same order as their
* eigenvalues.
* A complex eigenvector corresponding to a complex eigenvalue
* is stored in two consecutive columns, the first holding the
* real part, and the second the imaginary part.
* Not referenced if SIDE = 'R'.
*
* LDVL (input) INTEGER
* The leading dimension of the array VL. LDVL >= 1, and if
* SIDE = 'L' or 'B', LDVL >= N.
*
* VR (input/output) REAL array, dimension (LDVR,MM)
* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
* contain an N-by-N matrix Q (usually the orthogonal matrix Q
* of Schur vectors returned by SHSEQR).
* On exit, if SIDE = 'R' or 'B', VR contains:
* if HOWMNY = 'A', the matrix X of right eigenvectors of T;
* if HOWMNY = 'B', the matrix Q*X;
* if HOWMNY = 'S', the right eigenvectors of T specified by
* SELECT, stored consecutively in the columns
* of VR, in the same order as their
* eigenvalues.
* A complex eigenvector corresponding to a complex eigenvalue
* is stored in two consecutive columns, the first holding the
* real part and the second the imaginary part.
* Not referenced if SIDE = 'L'.
*
* LDVR (input) INTEGER
* The leading dimension of the array VR. LDVR >= 1, and if
* SIDE = 'R' or 'B', LDVR >= N.
*
* MM (input) INTEGER
* The number of columns in the arrays VL and/or VR. MM >= M.
*
* M (output) INTEGER
* The number of columns in the arrays VL and/or VR actually
* used to store the eigenvectors.
* If HOWMNY = 'A' or 'B', M is set to N.
* Each selected real eigenvector occupies one column and each
* selected complex eigenvector occupies two columns.
*
* WORK (workspace) REAL array, dimension (3*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Further Details
* ===============
*
* The algorithm used in this program is basically backward (forward)
* substitution, with scaling to make the the code robust against
* possible overflow.
*
* Each eigenvector is normalized so that the element of largest
* magnitude has magnitude 1; here the magnitude of a complex number
* (x,y) is taken to be |x| + |y|.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL ALLV, BOTHV, LEFTV, OVER, PAIR, RIGHTV, SOMEV
INTEGER I, IERR, II, IP, IS, J, J1, J2, JNXT, K, KI, N2
REAL BETA, BIGNUM, EMAX, OVFL, REC, REMAX, SCALE,
$ SMIN, SMLNUM, ULP, UNFL, VCRIT, VMAX, WI, WR,
$ XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SDOT, SLAMCH
EXTERNAL LSAME, ISAMAX, SDOT, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, SGEMV, SLABAD, SLALN2, SSCAL,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Local Arrays ..
REAL X( 2, 2 )
* ..
* .. Executable Statements ..
*
* Decode and test the input parameters
*
BOTHV = LSAME( SIDE, 'B' )
RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV
LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV
*
ALLV = LSAME( HOWMNY, 'A' )
OVER = LSAME( HOWMNY, 'B' )
SOMEV = LSAME( HOWMNY, 'S' )
*
INFO = 0
IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
INFO = -1
ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN
INFO = -8
ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN
INFO = -10
ELSE
*
* Set M to the number of columns required to store the selected
* eigenvectors, standardize the array SELECT if necessary, and
* test MM.
*
IF( SOMEV ) THEN
M = 0
PAIR = .FALSE.
DO 10 J = 1, N
IF( PAIR ) THEN
PAIR = .FALSE.
SELECT( J ) = .FALSE.
ELSE
IF( J.LT.N ) THEN
IF( T( J+1, J ).EQ.ZERO ) THEN
IF( SELECT( J ) )
$ M = M + 1
ELSE
PAIR = .TRUE.
IF( SELECT( J ) .OR. SELECT( J+1 ) ) THEN
SELECT( J ) = .TRUE.
M = M + 2
END IF
END IF
ELSE
IF( SELECT( N ) )
$ M = M + 1
END IF
END IF
10 CONTINUE
ELSE
M = N
END IF
*
IF( MM.LT.M ) THEN
INFO = -11
END IF
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STREVC', -INFO )
RETURN
END IF
*
* Quick return if possible.
*
IF( N.EQ.0 )
$ RETURN
*
* Set the constants to control overflow.
*
UNFL = SLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
CALL SLABAD( UNFL, OVFL )
ULP = SLAMCH( 'Precision' )
SMLNUM = UNFL*( N / ULP )
BIGNUM = ( ONE-ULP ) / SMLNUM
*
* Compute 1-norm of each column of strictly upper triangular
* part of T to control overflow in triangular solver.
*
WORK( 1 ) = ZERO
DO 30 J = 2, N
WORK( J ) = ZERO
DO 20 I = 1, J - 1
WORK( J ) = WORK( J ) + ABS( T( I, J ) )
20 CONTINUE
30 CONTINUE
*
* Index IP is used to specify the real or complex eigenvalue:
* IP = 0, real eigenvalue,
* 1, first of conjugate complex pair: (wr,wi)
* -1, second of conjugate complex pair: (wr,wi)
*
N2 = 2*N
*
IF( RIGHTV ) THEN
*
* Compute right eigenvectors.
*
IP = 0
IS = M
DO 140 KI = N, 1, -1
*
IF( IP.EQ.1 )
$ GO TO 130
IF( KI.EQ.1 )
$ GO TO 40
IF( T( KI, KI-1 ).EQ.ZERO )
$ GO TO 40
IP = -1
*
40 CONTINUE
IF( SOMEV ) THEN
IF( IP.EQ.0 ) THEN
IF( .NOT.SELECT( KI ) )
$ GO TO 130
ELSE
IF( .NOT.SELECT( KI-1 ) )
$ GO TO 130
END IF
END IF
*
* Compute the KI-th eigenvalue (WR,WI).
*
WR = T( KI, KI )
WI = ZERO
IF( IP.NE.0 )
$ WI = SQRT( ABS( T( KI, KI-1 ) ) )*
$ SQRT( ABS( T( KI-1, KI ) ) )
SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM )
*
IF( IP.EQ.0 ) THEN
*
* Real right eigenvector
*
WORK( KI+N ) = ONE
*
* Form right-hand side
*
DO 50 K = 1, KI - 1
WORK( K+N ) = -T( K, KI )
50 CONTINUE
*
* Solve the upper quasi-triangular system:
* (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK.
*
JNXT = KI - 1
DO 60 J = KI - 1, 1, -1
IF( J.GT.JNXT )
$ GO TO 60
J1 = J
J2 = J
JNXT = J - 1
IF( J.GT.1 ) THEN
IF( T( J, J-1 ).NE.ZERO ) THEN
J1 = J - 1
JNXT = J - 2
END IF
END IF
*
IF( J1.EQ.J2 ) THEN
*
* 1-by-1 diagonal block
*
CALL SLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ),
$ LDT, ONE, ONE, WORK( J+N ), N, WR,
$ ZERO, X, 2, SCALE, XNORM, IERR )
*
* Scale X(1,1) to avoid overflow when updating
* the right-hand side.
*
IF( XNORM.GT.ONE ) THEN
IF( WORK( J ).GT.BIGNUM / XNORM ) THEN
X( 1, 1 ) = X( 1, 1 ) / XNORM
SCALE = SCALE / XNORM
END IF
END IF
*
* Scale if necessary
*
IF( SCALE.NE.ONE )
$ CALL SSCAL( KI, SCALE, WORK( 1+N ), 1 )
WORK( J+N ) = X( 1, 1 )
*
* Update right-hand side
*
CALL SAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1,
$ WORK( 1+N ), 1 )
*
ELSE
*
* 2-by-2 diagonal block
*
CALL SLALN2( .FALSE., 2, 1, SMIN, ONE,
$ T( J-1, J-1 ), LDT, ONE, ONE,
$ WORK( J-1+N ), N, WR, ZERO, X, 2,
$ SCALE, XNORM, IERR )
*
* Scale X(1,1) and X(2,1) to avoid overflow when
* updating the right-hand side.
*
IF( XNORM.GT.ONE ) THEN
BETA = MAX( WORK( J-1 ), WORK( J ) )
IF( BETA.GT.BIGNUM / XNORM ) THEN
X( 1, 1 ) = X( 1, 1 ) / XNORM
X( 2, 1 ) = X( 2, 1 ) / XNORM
SCALE = SCALE / XNORM
END IF
END IF
*
* Scale if necessary
*
IF( SCALE.NE.ONE )
$ CALL SSCAL( KI, SCALE, WORK( 1+N ), 1 )
WORK( J-1+N ) = X( 1, 1 )
WORK( J+N ) = X( 2, 1 )
*
* Update right-hand side
*
CALL SAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1,
$ WORK( 1+N ), 1 )
CALL SAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1,
$ WORK( 1+N ), 1 )
END IF
60 CONTINUE
*
* Copy the vector x or Q*x to VR and normalize.
*
IF( .NOT.OVER ) THEN
CALL SCOPY( KI, WORK( 1+N ), 1, VR( 1, IS ), 1 )
*
II = ISAMAX( KI, VR( 1, IS ), 1 )
REMAX = ONE / ABS( VR( II, IS ) )
CALL SSCAL( KI, REMAX, VR( 1, IS ), 1 )
*
DO 70 K = KI + 1, N
VR( K, IS ) = ZERO
70 CONTINUE
ELSE
IF( KI.GT.1 )
$ CALL SGEMV( 'N', N, KI-1, ONE, VR, LDVR,
$ WORK( 1+N ), 1, WORK( KI+N ),
$ VR( 1, KI ), 1 )
*
II = ISAMAX( N, VR( 1, KI ), 1 )
REMAX = ONE / ABS( VR( II, KI ) )
CALL SSCAL( N, REMAX, VR( 1, KI ), 1 )
END IF
*
ELSE
*
* Complex right eigenvector.
*
* Initial solve
* [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]*X = 0.
* [ (T(KI,KI-1) T(KI,KI) ) ]
*
IF( ABS( T( KI-1, KI ) ).GE.ABS( T( KI, KI-1 ) ) ) THEN
WORK( KI-1+N ) = ONE
WORK( KI+N2 ) = WI / T( KI-1, KI )
ELSE
WORK( KI-1+N ) = -WI / T( KI, KI-1 )
WORK( KI+N2 ) = ONE
END IF
WORK( KI+N ) = ZERO
WORK( KI-1+N2 ) = ZERO
*
* Form right-hand side
*
DO 80 K = 1, KI - 2
WORK( K+N ) = -WORK( KI-1+N )*T( K, KI-1 )
WORK( K+N2 ) = -WORK( KI+N2 )*T( K, KI )
80 CONTINUE
*
* Solve upper quasi-triangular system:
* (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2)
*
JNXT = KI - 2
DO 90 J = KI - 2, 1, -1
IF( J.GT.JNXT )
$ GO TO 90
J1 = J
J2 = J
JNXT = J - 1
IF( J.GT.1 ) THEN
IF( T( J, J-1 ).NE.ZERO ) THEN
J1 = J - 1
JNXT = J - 2
END IF
END IF
*
IF( J1.EQ.J2 ) THEN
*
* 1-by-1 diagonal block
*
CALL SLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ),
$ LDT, ONE, ONE, WORK( J+N ), N, WR, WI,
$ X, 2, SCALE, XNORM, IERR )
*
* Scale X(1,1) and X(1,2) to avoid overflow when
* updating the right-hand side.
*
IF( XNORM.GT.ONE ) THEN
IF( WORK( J ).GT.BIGNUM / XNORM ) THEN
X( 1, 1 ) = X( 1, 1 ) / XNORM
X( 1, 2 ) = X( 1, 2 ) / XNORM
SCALE = SCALE / XNORM
END IF
END IF
*
* Scale if necessary
*
IF( SCALE.NE.ONE ) THEN
CALL SSCAL( KI, SCALE, WORK( 1+N ), 1 )
CALL SSCAL( KI, SCALE, WORK( 1+N2 ), 1 )
END IF
WORK( J+N ) = X( 1, 1 )
WORK( J+N2 ) = X( 1, 2 )
*
* Update the right-hand side
*
CALL SAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1,
$ WORK( 1+N ), 1 )
CALL SAXPY( J-1, -X( 1, 2 ), T( 1, J ), 1,
$ WORK( 1+N2 ), 1 )
*
ELSE
*
* 2-by-2 diagonal block
*
CALL SLALN2( .FALSE., 2, 2, SMIN, ONE,
$ T( J-1, J-1 ), LDT, ONE, ONE,
$ WORK( J-1+N ), N, WR, WI, X, 2, SCALE,
$ XNORM, IERR )
*
* Scale X to avoid overflow when updating
* the right-hand side.
*
IF( XNORM.GT.ONE ) THEN
BETA = MAX( WORK( J-1 ), WORK( J ) )
IF( BETA.GT.BIGNUM / XNORM ) THEN
REC = ONE / XNORM
X( 1, 1 ) = X( 1, 1 )*REC
X( 1, 2 ) = X( 1, 2 )*REC
X( 2, 1 ) = X( 2, 1 )*REC
X( 2, 2 ) = X( 2, 2 )*REC
SCALE = SCALE*REC
END IF
END IF
*
* Scale if necessary
*
IF( SCALE.NE.ONE ) THEN
CALL SSCAL( KI, SCALE, WORK( 1+N ), 1 )
CALL SSCAL( KI, SCALE, WORK( 1+N2 ), 1 )
END IF
WORK( J-1+N ) = X( 1, 1 )
WORK( J+N ) = X( 2, 1 )
WORK( J-1+N2 ) = X( 1, 2 )
WORK( J+N2 ) = X( 2, 2 )
*
* Update the right-hand side
*
CALL SAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1,
$ WORK( 1+N ), 1 )
CALL SAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1,
$ WORK( 1+N ), 1 )
CALL SAXPY( J-2, -X( 1, 2 ), T( 1, J-1 ), 1,
$ WORK( 1+N2 ), 1 )
CALL SAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1,
$ WORK( 1+N2 ), 1 )
END IF
90 CONTINUE
*
* Copy the vector x or Q*x to VR and normalize.
*
IF( .NOT.OVER ) THEN
CALL SCOPY( KI, WORK( 1+N ), 1, VR( 1, IS-1 ), 1 )
CALL SCOPY( KI, WORK( 1+N2 ), 1, VR( 1, IS ), 1 )
*
EMAX = ZERO
DO 100 K = 1, KI
EMAX = MAX( EMAX, ABS( VR( K, IS-1 ) )+
$ ABS( VR( K, IS ) ) )
100 CONTINUE
*
REMAX = ONE / EMAX
CALL SSCAL( KI, REMAX, VR( 1, IS-1 ), 1 )
CALL SSCAL( KI, REMAX, VR( 1, IS ), 1 )
*
DO 110 K = KI + 1, N
VR( K, IS-1 ) = ZERO
VR( K, IS ) = ZERO
110 CONTINUE
*
ELSE
*
IF( KI.GT.2 ) THEN
CALL SGEMV( 'N', N, KI-2, ONE, VR, LDVR,
$ WORK( 1+N ), 1, WORK( KI-1+N ),
$ VR( 1, KI-1 ), 1 )
CALL SGEMV( 'N', N, KI-2, ONE, VR, LDVR,
$ WORK( 1+N2 ), 1, WORK( KI+N2 ),
$ VR( 1, KI ), 1 )
ELSE
CALL SSCAL( N, WORK( KI-1+N ), VR( 1, KI-1 ), 1 )
CALL SSCAL( N, WORK( KI+N2 ), VR( 1, KI ), 1 )
END IF
*
EMAX = ZERO
DO 120 K = 1, N
EMAX = MAX( EMAX, ABS( VR( K, KI-1 ) )+
$ ABS( VR( K, KI ) ) )
120 CONTINUE
REMAX = ONE / EMAX
CALL SSCAL( N, REMAX, VR( 1, KI-1 ), 1 )
CALL SSCAL( N, REMAX, VR( 1, KI ), 1 )
END IF
END IF
*
IS = IS - 1
IF( IP.NE.0 )
$ IS = IS - 1
130 CONTINUE
IF( IP.EQ.1 )
$ IP = 0
IF( IP.EQ.-1 )
$ IP = 1
140 CONTINUE
END IF
*
IF( LEFTV ) THEN
*
* Compute left eigenvectors.
*
IP = 0
IS = 1
DO 260 KI = 1, N
*
IF( IP.EQ.-1 )
$ GO TO 250
IF( KI.EQ.N )
$ GO TO 150
IF( T( KI+1, KI ).EQ.ZERO )
$ GO TO 150
IP = 1
*
150 CONTINUE
IF( SOMEV ) THEN
IF( .NOT.SELECT( KI ) )
$ GO TO 250
END IF
*
* Compute the KI-th eigenvalue (WR,WI).
*
WR = T( KI, KI )
WI = ZERO
IF( IP.NE.0 )
$ WI = SQRT( ABS( T( KI, KI+1 ) ) )*
$ SQRT( ABS( T( KI+1, KI ) ) )
SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM )
*
IF( IP.EQ.0 ) THEN
*
* Real left eigenvector.
*
WORK( KI+N ) = ONE
*
* Form right-hand side
*
DO 160 K = KI + 1, N
WORK( K+N ) = -T( KI, K )
160 CONTINUE
*
* Solve the quasi-triangular system:
* (T(KI+1:N,KI+1:N) - WR)'*X = SCALE*WORK
*
VMAX = ONE
VCRIT = BIGNUM
*
JNXT = KI + 1
DO 170 J = KI + 1, N
IF( J.LT.JNXT )
$ GO TO 170
J1 = J
J2 = J
JNXT = J + 1
IF( J.LT.N ) THEN
IF( T( J+1, J ).NE.ZERO ) THEN
J2 = J + 1
JNXT = J + 2
END IF
END IF
*
IF( J1.EQ.J2 ) THEN
*
* 1-by-1 diagonal block
*
* Scale if necessary to avoid overflow when forming
* the right-hand side.
*
IF( WORK( J ).GT.VCRIT ) THEN
REC = ONE / VMAX
CALL SSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
VMAX = ONE
VCRIT = BIGNUM
END IF
*
WORK( J+N ) = WORK( J+N ) -
$ SDOT( J-KI-1, T( KI+1, J ), 1,
$ WORK( KI+1+N ), 1 )
*
* Solve (T(J,J)-WR)'*X = WORK
*
CALL SLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ),
$ LDT, ONE, ONE, WORK( J+N ), N, WR,
$ ZERO, X, 2, SCALE, XNORM, IERR )
*
* Scale if necessary
*
IF( SCALE.NE.ONE )
$ CALL SSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
WORK( J+N ) = X( 1, 1 )
VMAX = MAX( ABS( WORK( J+N ) ), VMAX )
VCRIT = BIGNUM / VMAX
*
ELSE
*
* 2-by-2 diagonal block
*
* Scale if necessary to avoid overflow when forming
* the right-hand side.
*
BETA = MAX( WORK( J ), WORK( J+1 ) )
IF( BETA.GT.VCRIT ) THEN
REC = ONE / VMAX
CALL SSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
VMAX = ONE
VCRIT = BIGNUM
END IF
*
WORK( J+N ) = WORK( J+N ) -
$ SDOT( J-KI-1, T( KI+1, J ), 1,
$ WORK( KI+1+N ), 1 )
*
WORK( J+1+N ) = WORK( J+1+N ) -
$ SDOT( J-KI-1, T( KI+1, J+1 ), 1,
$ WORK( KI+1+N ), 1 )
*
* Solve
* [T(J,J)-WR T(J,J+1) ]'* X = SCALE*( WORK1 )
* [T(J+1,J) T(J+1,J+1)-WR] ( WORK2 )
*
CALL SLALN2( .TRUE., 2, 1, SMIN, ONE, T( J, J ),
$ LDT, ONE, ONE, WORK( J+N ), N, WR,
$ ZERO, X, 2, SCALE, XNORM, IERR )
*
* Scale if necessary
*
IF( SCALE.NE.ONE )
$ CALL SSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
WORK( J+N ) = X( 1, 1 )
WORK( J+1+N ) = X( 2, 1 )
*
VMAX = MAX( ABS( WORK( J+N ) ),
$ ABS( WORK( J+1+N ) ), VMAX )
VCRIT = BIGNUM / VMAX
*
END IF
170 CONTINUE
*
* Copy the vector x or Q*x to VL and normalize.
*
IF( .NOT.OVER ) THEN
CALL SCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 )
*
II = ISAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1
REMAX = ONE / ABS( VL( II, IS ) )
CALL SSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 )
*
DO 180 K = 1, KI - 1
VL( K, IS ) = ZERO
180 CONTINUE
*
ELSE
*
IF( KI.LT.N )
$ CALL SGEMV( 'N', N, N-KI, ONE, VL( 1, KI+1 ), LDVL,
$ WORK( KI+1+N ), 1, WORK( KI+N ),
$ VL( 1, KI ), 1 )
*
II = ISAMAX( N, VL( 1, KI ), 1 )
REMAX = ONE / ABS( VL( II, KI ) )
CALL SSCAL( N, REMAX, VL( 1, KI ), 1 )
*
END IF
*
ELSE
*
* Complex left eigenvector.
*
* Initial solve:
* ((T(KI,KI) T(KI,KI+1) )' - (WR - I* WI))*X = 0.
* ((T(KI+1,KI) T(KI+1,KI+1)) )
*
IF( ABS( T( KI, KI+1 ) ).GE.ABS( T( KI+1, KI ) ) ) THEN
WORK( KI+N ) = WI / T( KI, KI+1 )
WORK( KI+1+N2 ) = ONE
ELSE
WORK( KI+N ) = ONE
WORK( KI+1+N2 ) = -WI / T( KI+1, KI )
END IF
WORK( KI+1+N ) = ZERO
WORK( KI+N2 ) = ZERO
*
* Form right-hand side
*
DO 190 K = KI + 2, N
WORK( K+N ) = -WORK( KI+N )*T( KI, K )
WORK( K+N2 ) = -WORK( KI+1+N2 )*T( KI+1, K )
190 CONTINUE
*
* Solve complex quasi-triangular system:
* ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2
*
VMAX = ONE
VCRIT = BIGNUM
*
JNXT = KI + 2
DO 200 J = KI + 2, N
IF( J.LT.JNXT )
$ GO TO 200
J1 = J
J2 = J
JNXT = J + 1
IF( J.LT.N ) THEN
IF( T( J+1, J ).NE.ZERO ) THEN
J2 = J + 1
JNXT = J + 2
END IF
END IF
*
IF( J1.EQ.J2 ) THEN
*
* 1-by-1 diagonal block
*
* Scale if necessary to avoid overflow when
* forming the right-hand side elements.
*
IF( WORK( J ).GT.VCRIT ) THEN
REC = ONE / VMAX
CALL SSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
CALL SSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 )
VMAX = ONE
VCRIT = BIGNUM
END IF
*
WORK( J+N ) = WORK( J+N ) -
$ SDOT( J-KI-2, T( KI+2, J ), 1,
$ WORK( KI+2+N ), 1 )
WORK( J+N2 ) = WORK( J+N2 ) -
$ SDOT( J-KI-2, T( KI+2, J ), 1,
$ WORK( KI+2+N2 ), 1 )
*
* Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2
*
CALL SLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ),
$ LDT, ONE, ONE, WORK( J+N ), N, WR,
$ -WI, X, 2, SCALE, XNORM, IERR )
*
* Scale if necessary
*
IF( SCALE.NE.ONE ) THEN
CALL SSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
CALL SSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 )
END IF
WORK( J+N ) = X( 1, 1 )
WORK( J+N2 ) = X( 1, 2 )
VMAX = MAX( ABS( WORK( J+N ) ),
$ ABS( WORK( J+N2 ) ), VMAX )
VCRIT = BIGNUM / VMAX
*
ELSE
*
* 2-by-2 diagonal block
*
* Scale if necessary to avoid overflow when forming
* the right-hand side elements.
*
BETA = MAX( WORK( J ), WORK( J+1 ) )
IF( BETA.GT.VCRIT ) THEN
REC = ONE / VMAX
CALL SSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
CALL SSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 )
VMAX = ONE
VCRIT = BIGNUM
END IF
*
WORK( J+N ) = WORK( J+N ) -
$ SDOT( J-KI-2, T( KI+2, J ), 1,
$ WORK( KI+2+N ), 1 )
*
WORK( J+N2 ) = WORK( J+N2 ) -
$ SDOT( J-KI-2, T( KI+2, J ), 1,
$ WORK( KI+2+N2 ), 1 )
*
WORK( J+1+N ) = WORK( J+1+N ) -
$ SDOT( J-KI-2, T( KI+2, J+1 ), 1,
$ WORK( KI+2+N ), 1 )
*
WORK( J+1+N2 ) = WORK( J+1+N2 ) -
$ SDOT( J-KI-2, T( KI+2, J+1 ), 1,
$ WORK( KI+2+N2 ), 1 )
*
* Solve 2-by-2 complex linear equation
* ([T(j,j) T(j,j+1) ]'-(wr-i*wi)*I)*X = SCALE*B
* ([T(j+1,j) T(j+1,j+1)] )
*
CALL SLALN2( .TRUE., 2, 2, SMIN, ONE, T( J, J ),
$ LDT, ONE, ONE, WORK( J+N ), N, WR,
$ -WI, X, 2, SCALE, XNORM, IERR )
*
* Scale if necessary
*
IF( SCALE.NE.ONE ) THEN
CALL SSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
CALL SSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 )
END IF
WORK( J+N ) = X( 1, 1 )
WORK( J+N2 ) = X( 1, 2 )
WORK( J+1+N ) = X( 2, 1 )
WORK( J+1+N2 ) = X( 2, 2 )
VMAX = MAX( ABS( X( 1, 1 ) ), ABS( X( 1, 2 ) ),
$ ABS( X( 2, 1 ) ), ABS( X( 2, 2 ) ), VMAX )
VCRIT = BIGNUM / VMAX
*
END IF
200 CONTINUE
*
* Copy the vector x or Q*x to VL and normalize.
*
IF( .NOT.OVER ) THEN
CALL SCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 )
CALL SCOPY( N-KI+1, WORK( KI+N2 ), 1, VL( KI, IS+1 ),
$ 1 )
*
EMAX = ZERO
DO 220 K = KI, N
EMAX = MAX( EMAX, ABS( VL( K, IS ) )+
$ ABS( VL( K, IS+1 ) ) )
220 CONTINUE
REMAX = ONE / EMAX
CALL SSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 )
CALL SSCAL( N-KI+1, REMAX, VL( KI, IS+1 ), 1 )
*
DO 230 K = 1, KI - 1
VL( K, IS ) = ZERO
VL( K, IS+1 ) = ZERO
230 CONTINUE
ELSE
IF( KI.LT.N-1 ) THEN
CALL SGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ),
$ LDVL, WORK( KI+2+N ), 1, WORK( KI+N ),
$ VL( 1, KI ), 1 )
CALL SGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ),
$ LDVL, WORK( KI+2+N2 ), 1,
$ WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 )
ELSE
CALL SSCAL( N, WORK( KI+N ), VL( 1, KI ), 1 )
CALL SSCAL( N, WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 )
END IF
*
EMAX = ZERO
DO 240 K = 1, N
EMAX = MAX( EMAX, ABS( VL( K, KI ) )+
$ ABS( VL( K, KI+1 ) ) )
240 CONTINUE
REMAX = ONE / EMAX
CALL SSCAL( N, REMAX, VL( 1, KI ), 1 )
CALL SSCAL( N, REMAX, VL( 1, KI+1 ), 1 )
*
END IF
*
END IF
*
IS = IS + 1
IF( IP.NE.0 )
$ IS = IS + 1
250 CONTINUE
IF( IP.EQ.-1 )
$ IP = 0
IF( IP.EQ.1 )
$ IP = -1
*
260 CONTINUE
*
END IF
*
RETURN
*
* End of STREVC
*
END
SUBROUTINE STREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER COMPQ
INTEGER IFST, ILST, INFO, LDQ, LDT, N
* ..
* .. Array Arguments ..
REAL Q( LDQ, * ), T( LDT, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* STREXC reorders the real Schur factorization of a real matrix
* A = Q*T*Q**T, so that the diagonal block of T with row index IFST is
* moved to row ILST.
*
* The real Schur form T is reordered by an orthogonal similarity
* transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors
* is updated by postmultiplying it with Z.
*
* T must be in Schur canonical form (as returned by SHSEQR), that is,
* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
* 2-by-2 diagonal block has its diagonal elements equal and its
* off-diagonal elements of opposite sign.
*
* Arguments
* =========
*
* COMPQ (input) CHARACTER*1
* = 'V': update the matrix Q of Schur vectors;
* = 'N': do not update Q.
*
* N (input) INTEGER
* The order of the matrix T. N >= 0.
*
* T (input/output) REAL array, dimension (LDT,N)
* On entry, the upper quasi-triangular matrix T, in Schur
* Schur canonical form.
* On exit, the reordered upper quasi-triangular matrix, again
* in Schur canonical form.
*
* LDT (input) INTEGER
* The leading dimension of the array T. LDT >= max(1,N).
*
* Q (input/output) REAL array, dimension (LDQ,N)
* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
* On exit, if COMPQ = 'V', Q has been postmultiplied by the
* orthogonal transformation matrix Z which reorders T.
* If COMPQ = 'N', Q is not referenced.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* IFST (input/output) INTEGER
* ILST (input/output) INTEGER
* Specify the reordering of the diagonal blocks of T.
* The block with row index IFST is moved to row ILST, by a
* sequence of transpositions between adjacent blocks.
* On exit, if IFST pointed on entry to the second row of a
* 2-by-2 block, it is changed to point to the first row; ILST
* always points to the first row of the block in its final
* position (which may differ from its input value by +1 or -1).
* 1 <= IFST <= N; 1 <= ILST <= N.
*
* WORK (workspace) REAL array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* = 1: two adjacent blocks were too close to swap (the problem
* is very ill-conditioned); T may have been partially
* reordered, and ILST points to the first row of the
* current position of the block being moved.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL WANTQ
INTEGER HERE, NBF, NBL, NBNEXT
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SLAEXC, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Decode and test the input arguments.
*
INFO = 0
WANTQ = LSAME( COMPQ, 'V' )
IF( .NOT.WANTQ .AND. .NOT.LSAME( COMPQ, 'N' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN
INFO = -6
ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN
INFO = -7
ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STREXC', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.1 )
$ RETURN
*
* Determine the first row of specified block
* and find out it is 1 by 1 or 2 by 2.
*
IF( IFST.GT.1 ) THEN
IF( T( IFST, IFST-1 ).NE.ZERO )
$ IFST = IFST - 1
END IF
NBF = 1
IF( IFST.LT.N ) THEN
IF( T( IFST+1, IFST ).NE.ZERO )
$ NBF = 2
END IF
*
* Determine the first row of the final block
* and find out it is 1 by 1 or 2 by 2.
*
IF( ILST.GT.1 ) THEN
IF( T( ILST, ILST-1 ).NE.ZERO )
$ ILST = ILST - 1
END IF
NBL = 1
IF( ILST.LT.N ) THEN
IF( T( ILST+1, ILST ).NE.ZERO )
$ NBL = 2
END IF
*
IF( IFST.EQ.ILST )
$ RETURN
*
IF( IFST.LT.ILST ) THEN
*
* Update ILST
*
IF( NBF.EQ.2 .AND. NBL.EQ.1 )
$ ILST = ILST - 1
IF( NBF.EQ.1 .AND. NBL.EQ.2 )
$ ILST = ILST + 1
*
HERE = IFST
*
10 CONTINUE
*
* Swap block with next one below
*
IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
*
* Current block either 1 by 1 or 2 by 2
*
NBNEXT = 1
IF( HERE+NBF+1.LE.N ) THEN
IF( T( HERE+NBF+1, HERE+NBF ).NE.ZERO )
$ NBNEXT = 2
END IF
CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, NBF, NBNEXT,
$ WORK, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
HERE = HERE + NBNEXT
*
* Test if 2 by 2 block breaks into two 1 by 1 blocks
*
IF( NBF.EQ.2 ) THEN
IF( T( HERE+1, HERE ).EQ.ZERO )
$ NBF = 3
END IF
*
ELSE
*
* Current block consists of two 1 by 1 blocks each of which
* must be swapped individually
*
NBNEXT = 1
IF( HERE+3.LE.N ) THEN
IF( T( HERE+3, HERE+2 ).NE.ZERO )
$ NBNEXT = 2
END IF
CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE+1, 1, NBNEXT,
$ WORK, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
IF( NBNEXT.EQ.1 ) THEN
*
* Swap two 1 by 1 blocks, no problems possible
*
CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, NBNEXT,
$ WORK, INFO )
HERE = HERE + 1
ELSE
*
* Recompute NBNEXT in case 2 by 2 split
*
IF( T( HERE+2, HERE+1 ).EQ.ZERO )
$ NBNEXT = 1
IF( NBNEXT.EQ.2 ) THEN
*
* 2 by 2 Block did not split
*
CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1,
$ NBNEXT, WORK, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
HERE = HERE + 2
ELSE
*
* 2 by 2 Block did split
*
CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1,
$ WORK, INFO )
CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE+1, 1, 1,
$ WORK, INFO )
HERE = HERE + 2
END IF
END IF
END IF
IF( HERE.LT.ILST )
$ GO TO 10
*
ELSE
*
HERE = IFST
20 CONTINUE
*
* Swap block with next one above
*
IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
*
* Current block either 1 by 1 or 2 by 2
*
NBNEXT = 1
IF( HERE.GE.3 ) THEN
IF( T( HERE-1, HERE-2 ).NE.ZERO )
$ NBNEXT = 2
END IF
CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-NBNEXT, NBNEXT,
$ NBF, WORK, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
HERE = HERE - NBNEXT
*
* Test if 2 by 2 block breaks into two 1 by 1 blocks
*
IF( NBF.EQ.2 ) THEN
IF( T( HERE+1, HERE ).EQ.ZERO )
$ NBF = 3
END IF
*
ELSE
*
* Current block consists of two 1 by 1 blocks each of which
* must be swapped individually
*
NBNEXT = 1
IF( HERE.GE.3 ) THEN
IF( T( HERE-1, HERE-2 ).NE.ZERO )
$ NBNEXT = 2
END IF
CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-NBNEXT, NBNEXT,
$ 1, WORK, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
IF( NBNEXT.EQ.1 ) THEN
*
* Swap two 1 by 1 blocks, no problems possible
*
CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, NBNEXT, 1,
$ WORK, INFO )
HERE = HERE - 1
ELSE
*
* Recompute NBNEXT in case 2 by 2 split
*
IF( T( HERE, HERE-1 ).EQ.ZERO )
$ NBNEXT = 1
IF( NBNEXT.EQ.2 ) THEN
*
* 2 by 2 Block did not split
*
CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-1, 2, 1,
$ WORK, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
HERE = HERE - 2
ELSE
*
* 2 by 2 Block did split
*
CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1,
$ WORK, INFO )
CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-1, 1, 1,
$ WORK, INFO )
HERE = HERE - 2
END IF
END IF
END IF
IF( HERE.GT.ILST )
$ GO TO 20
END IF
ILST = HERE
*
RETURN
*
* End of STREXC
*
END
SUBROUTINE STRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X,
$ LDX, FERR, BERR, WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER INFO, LDA, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ),
$ WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* STRRFS provides error bounds and backward error estimates for the
* solution to a system of linear equations with a triangular
* coefficient matrix.
*
* The solution matrix X must be computed by STRTRS or some other
* means before entering this routine. STRRFS does not do iterative
* refinement because doing so cannot improve the backward error.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': A is upper triangular;
* = 'L': A is lower triangular.
*
* 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**H * X = B (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* = 'N': A is non-unit triangular;
* = 'U': A is unit triangular.
*
* 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 matrices B and X. NRHS >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The triangular matrix A. If UPLO = 'U', the leading N-by-N
* upper triangular part of the array A contains the upper
* triangular matrix, and the strictly lower triangular part of
* A is not referenced. If UPLO = 'L', the leading N-by-N lower
* triangular part of the array A contains the lower triangular
* matrix, and the strictly upper triangular part of A is not
* referenced. If DIAG = 'U', the diagonal elements of A are
* also not referenced and are assumed to be 1.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input) REAL array, dimension (LDB,NRHS)
* The right hand side matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input) REAL array, dimension (LDX,NRHS)
* The solution matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* FERR (output) REAL array, dimension (NRHS)
* The estimated forward error bound for each solution vector
* X(j) (the j-th column of the solution matrix X).
* If XTRUE is the true solution corresponding to X(j), FERR(j)
* is an estimated upper bound for the magnitude of the largest
* element in (X(j) - XTRUE) divided by the magnitude of the
* largest element in X(j). The estimate is as reliable as
* the estimate for RCOND, and is almost always a slight
* overestimate of the true error.
*
* BERR (output) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* WORK (workspace) REAL array, dimension (3*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN, NOUNIT, UPPER
CHARACTER TRANST
INTEGER I, J, K, KASE, NZ
REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, SLACN2, STRMV, STRSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH
EXTERNAL LSAME, SLAMCH
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOTRAN = LSAME( TRANS, 'N' )
NOUNIT = LSAME( DIAG, 'N' )
*
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
$ LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( NRHS.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -11
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STRRFS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
DO 10 J = 1, NRHS
FERR( J ) = ZERO
BERR( J ) = ZERO
10 CONTINUE
RETURN
END IF
*
IF( NOTRAN ) THEN
TRANST = 'T'
ELSE
TRANST = 'N'
END IF
*
* NZ = maximum number of nonzero elements in each row of A, plus 1
*
NZ = N + 1
EPS = SLAMCH( 'Epsilon' )
SAFMIN = SLAMCH( 'Safe minimum' )
SAFE1 = NZ*SAFMIN
SAFE2 = SAFE1 / EPS
*
* Do for each right hand side
*
DO 250 J = 1, NRHS
*
* Compute residual R = B - op(A) * X,
* where op(A) = A or A', depending on TRANS.
*
CALL SCOPY( N, X( 1, J ), 1, WORK( N+1 ), 1 )
CALL STRMV( UPLO, TRANS, DIAG, N, A, LDA, WORK( N+1 ), 1 )
CALL SAXPY( N, -ONE, B( 1, J ), 1, WORK( N+1 ), 1 )
*
* Compute componentwise relative backward error from formula
*
* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
*
* where abs(Z) is the componentwise absolute value of the matrix
* or vector Z. If the i-th component of the denominator is less
* than SAFE2, then SAFE1 is added to the i-th components of the
* numerator and denominator before dividing.
*
DO 20 I = 1, N
WORK( I ) = ABS( B( I, J ) )
20 CONTINUE
*
IF( NOTRAN ) THEN
*
* Compute abs(A)*abs(X) + abs(B).
*
IF( UPPER ) THEN
IF( NOUNIT ) THEN
DO 40 K = 1, N
XK = ABS( X( K, J ) )
DO 30 I = 1, K
WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
30 CONTINUE
40 CONTINUE
ELSE
DO 60 K = 1, N
XK = ABS( X( K, J ) )
DO 50 I = 1, K - 1
WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
50 CONTINUE
WORK( K ) = WORK( K ) + XK
60 CONTINUE
END IF
ELSE
IF( NOUNIT ) THEN
DO 80 K = 1, N
XK = ABS( X( K, J ) )
DO 70 I = K, N
WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
70 CONTINUE
80 CONTINUE
ELSE
DO 100 K = 1, N
XK = ABS( X( K, J ) )
DO 90 I = K + 1, N
WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
90 CONTINUE
WORK( K ) = WORK( K ) + XK
100 CONTINUE
END IF
END IF
ELSE
*
* Compute abs(A')*abs(X) + abs(B).
*
IF( UPPER ) THEN
IF( NOUNIT ) THEN
DO 120 K = 1, N
S = ZERO
DO 110 I = 1, K
S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
110 CONTINUE
WORK( K ) = WORK( K ) + S
120 CONTINUE
ELSE
DO 140 K = 1, N
S = ABS( X( K, J ) )
DO 130 I = 1, K - 1
S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
130 CONTINUE
WORK( K ) = WORK( K ) + S
140 CONTINUE
END IF
ELSE
IF( NOUNIT ) THEN
DO 160 K = 1, N
S = ZERO
DO 150 I = K, N
S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
150 CONTINUE
WORK( K ) = WORK( K ) + S
160 CONTINUE
ELSE
DO 180 K = 1, N
S = ABS( X( K, J ) )
DO 170 I = K + 1, N
S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
170 CONTINUE
WORK( K ) = WORK( K ) + S
180 CONTINUE
END IF
END IF
END IF
S = ZERO
DO 190 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
ELSE
S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
$ ( WORK( I )+SAFE1 ) )
END IF
190 CONTINUE
BERR( J ) = S
*
* Bound error from formula
*
* norm(X - XTRUE) / norm(X) .le. FERR =
* norm( abs(inv(op(A)))*
* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
*
* where
* norm(Z) is the magnitude of the largest component of Z
* inv(op(A)) is the inverse of op(A)
* abs(Z) is the componentwise absolute value of the matrix or
* vector Z
* NZ is the maximum number of nonzeros in any row of A, plus 1
* EPS is machine epsilon
*
* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
* is incremented by SAFE1 if the i-th component of
* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
*
* Use SLACN2 to estimate the infinity-norm of the matrix
* inv(op(A)) * diag(W),
* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
*
DO 200 I = 1, N
IF( WORK( I ).GT.SAFE2 ) THEN
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
ELSE
WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
END IF
200 CONTINUE
*
KASE = 0
210 CONTINUE
CALL SLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
$ KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Multiply by diag(W)*inv(op(A)').
*
CALL STRSV( UPLO, TRANST, DIAG, N, A, LDA, WORK( N+1 ),
$ 1 )
DO 220 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
220 CONTINUE
ELSE
*
* Multiply by inv(op(A))*diag(W).
*
DO 230 I = 1, N
WORK( N+I ) = WORK( I )*WORK( N+I )
230 CONTINUE
CALL STRSV( UPLO, TRANS, DIAG, N, A, LDA, WORK( N+1 ),
$ 1 )
END IF
GO TO 210
END IF
*
* Normalize error.
*
LSTRES = ZERO
DO 240 I = 1, N
LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
240 CONTINUE
IF( LSTRES.NE.ZERO )
$ FERR( J ) = FERR( J ) / LSTRES
*
250 CONTINUE
*
RETURN
*
* End of STRRFS
*
END
SUBROUTINE STRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI,
$ M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER COMPQ, JOB
INTEGER INFO, LDQ, LDT, LIWORK, LWORK, M, N
REAL S, SEP
* ..
* .. Array Arguments ..
LOGICAL SELECT( * )
INTEGER IWORK( * )
REAL Q( LDQ, * ), T( LDT, * ), WI( * ), WORK( * ),
$ WR( * )
* ..
*
* Purpose
* =======
*
* STRSEN reorders the real Schur factorization of a real matrix
* A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in
* the leading diagonal blocks of the upper quasi-triangular matrix T,
* and the leading columns of Q form an orthonormal basis of the
* corresponding right invariant subspace.
*
* Optionally the routine computes the reciprocal condition numbers of
* the cluster of eigenvalues and/or the invariant subspace.
*
* T must be in Schur canonical form (as returned by SHSEQR), that is,
* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
* 2-by-2 diagonal block has its diagonal elemnts equal and its
* off-diagonal elements of opposite sign.
*
* Arguments
* =========
*
* JOB (input) CHARACTER*1
* Specifies whether condition numbers are required for the
* cluster of eigenvalues (S) or the invariant subspace (SEP):
* = 'N': none;
* = 'E': for eigenvalues only (S);
* = 'V': for invariant subspace only (SEP);
* = 'B': for both eigenvalues and invariant subspace (S and
* SEP).
*
* COMPQ (input) CHARACTER*1
* = 'V': update the matrix Q of Schur vectors;
* = 'N': do not update Q.
*
* SELECT (input) LOGICAL array, dimension (N)
* SELECT specifies the eigenvalues in the selected cluster. To
* select a real eigenvalue w(j), SELECT(j) must be set to
* .TRUE.. To select a complex conjugate pair of eigenvalues
* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,
* either SELECT(j) or SELECT(j+1) or both must be set to
* .TRUE.; a complex conjugate pair of eigenvalues must be
* either both included in the cluster or both excluded.
*
* N (input) INTEGER
* The order of the matrix T. N >= 0.
*
* T (input/output) REAL array, dimension (LDT,N)
* On entry, the upper quasi-triangular matrix T, in Schur
* canonical form.
* On exit, T is overwritten by the reordered matrix T, again in
* Schur canonical form, with the selected eigenvalues in the
* leading diagonal blocks.
*
* LDT (input) INTEGER
* The leading dimension of the array T. LDT >= max(1,N).
*
* Q (input/output) REAL array, dimension (LDQ,N)
* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
* On exit, if COMPQ = 'V', Q has been postmultiplied by the
* orthogonal transformation matrix which reorders T; the
* leading M columns of Q form an orthonormal basis for the
* specified invariant subspace.
* If COMPQ = 'N', Q is not referenced.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q.
* LDQ >= 1; and if COMPQ = 'V', LDQ >= N.
*
* WR (output) REAL array, dimension (N)
* WI (output) REAL array, dimension (N)
* The real and imaginary parts, respectively, of the reordered
* eigenvalues of T. The eigenvalues are stored in the same
* order as on the diagonal of T, with WR(i) = T(i,i) and, if
* T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and
* WI(i+1) = -WI(i). Note that if a complex eigenvalue is
* sufficiently ill-conditioned, then its value may differ
* significantly from its value before reordering.
*
* M (output) INTEGER
* The dimension of the specified invariant subspace.
* 0 < = M <= N.
*
* S (output) REAL
* If JOB = 'E' or 'B', S is a lower bound on the reciprocal
* condition number for the selected cluster of eigenvalues.
* S cannot underestimate the true reciprocal condition number
* by more than a factor of sqrt(N). If M = 0 or N, S = 1.
* If JOB = 'N' or 'V', S is not referenced.
*
* SEP (output) REAL
* If JOB = 'V' or 'B', SEP is the estimated reciprocal
* condition number of the specified invariant subspace. If
* M = 0 or N, SEP = norm(T).
* If JOB = 'N' or 'E', SEP is not referenced.
*
* WORK (workspace/output) REAL 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 JOB = 'N', LWORK >= max(1,N);
* if JOB = 'E', LWORK >= max(1,M*(N-M));
* if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).
*
* 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.
*
* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK.
* If JOB = 'N' or 'E', LIWORK >= 1;
* if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)).
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal size of the IWORK array,
* returns this value as the first entry of the IWORK array, and
* no error message related to LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* = 1: reordering of T failed because some eigenvalues are too
* close to separate (the problem is very ill-conditioned);
* T may have been partially reordered, and WR and WI
* contain the eigenvalues in the same order as in T; S and
* SEP (if requested) are set to zero.
*
* Further Details
* ===============
*
* STRSEN first collects the selected eigenvalues by computing an
* orthogonal transformation Z to move them to the top left corner of T.
* In other words, the selected eigenvalues are the eigenvalues of T11
* in:
*
* Z'*T*Z = ( T11 T12 ) n1
* ( 0 T22 ) n2
* n1 n2
*
* where N = n1+n2 and Z' means the transpose of Z. The first n1 columns
* of Z span the specified invariant subspace of T.
*
* If T has been obtained from the real Schur factorization of a matrix
* A = Q*T*Q', then the reordered real Schur factorization of A is given
* by A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span
* the corresponding invariant subspace of A.
*
* The reciprocal condition number of the average of the eigenvalues of
* T11 may be returned in S. S lies between 0 (very badly conditioned)
* and 1 (very well conditioned). It is computed as follows. First we
* compute R so that
*
* P = ( I R ) n1
* ( 0 0 ) n2
* n1 n2
*
* is the projector on the invariant subspace associated with T11.
* R is the solution of the Sylvester equation:
*
* T11*R - R*T22 = T12.
*
* Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote
* the two-norm of M. Then S is computed as the lower bound
*
* (1 + F-norm(R)**2)**(-1/2)
*
* on the reciprocal of 2-norm(P), the true reciprocal condition number.
* S cannot underestimate 1 / 2-norm(P) by more than a factor of
* sqrt(N).
*
* An approximate error bound for the computed average of the
* eigenvalues of T11 is
*
* EPS * norm(T) / S
*
* where EPS is the machine precision.
*
* The reciprocal condition number of the right invariant subspace
* spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.
* SEP is defined as the separation of T11 and T22:
*
* sep( T11, T22 ) = sigma-min( C )
*
* where sigma-min(C) is the smallest singular value of the
* n1*n2-by-n1*n2 matrix
*
* C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )
*
* I(m) is an m by m identity matrix, and kprod denotes the Kronecker
* product. We estimate sigma-min(C) by the reciprocal of an estimate of
* the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)
* cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).
*
* When SEP is small, small changes in T can cause large changes in
* the invariant subspace. An approximate bound on the maximum angular
* error in the computed right invariant subspace is
*
* EPS * norm(T) / SEP
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, PAIR, SWAP, WANTBH, WANTQ, WANTS,
$ WANTSP
INTEGER IERR, K, KASE, KK, KS, LIWMIN, LWMIN, N1, N2,
$ NN
REAL EST, RNORM, SCALE
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLANGE
EXTERNAL LSAME, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SLACN2, SLACPY, STREXC, STRSYL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Decode and test the input parameters
*
WANTBH = LSAME( JOB, 'B' )
WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH
WANTQ = LSAME( COMPQ, 'V' )
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.WANTS .AND. .NOT.WANTSP )
$ THEN
INFO = -1
ELSE IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
INFO = -8
ELSE
*
* Set M to the dimension of the specified invariant subspace,
* and test LWORK and LIWORK.
*
M = 0
PAIR = .FALSE.
DO 10 K = 1, N
IF( PAIR ) THEN
PAIR = .FALSE.
ELSE
IF( K.LT.N ) THEN
IF( T( K+1, K ).EQ.ZERO ) THEN
IF( SELECT( K ) )
$ M = M + 1
ELSE
PAIR = .TRUE.
IF( SELECT( K ) .OR. SELECT( K+1 ) )
$ M = M + 2
END IF
ELSE
IF( SELECT( N ) )
$ M = M + 1
END IF
END IF
10 CONTINUE
*
N1 = M
N2 = N - M
NN = N1*N2
*
IF( WANTSP ) THEN
LWMIN = MAX( 1, 2*NN )
LIWMIN = MAX( 1, NN )
ELSE IF( LSAME( JOB, 'N' ) ) THEN
LWMIN = MAX( 1, N )
LIWMIN = 1
ELSE IF( LSAME( JOB, 'E' ) ) THEN
LWMIN = MAX( 1, NN )
LIWMIN = 1
END IF
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -15
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -17
END IF
END IF
*
IF( INFO.EQ.0 ) THEN
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STRSEN', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible.
*
IF( M.EQ.N .OR. M.EQ.0 ) THEN
IF( WANTS )
$ S = ONE
IF( WANTSP )
$ SEP = SLANGE( '1', N, N, T, LDT, WORK )
GO TO 40
END IF
*
* Collect the selected blocks at the top-left corner of T.
*
KS = 0
PAIR = .FALSE.
DO 20 K = 1, N
IF( PAIR ) THEN
PAIR = .FALSE.
ELSE
SWAP = SELECT( K )
IF( K.LT.N ) THEN
IF( T( K+1, K ).NE.ZERO ) THEN
PAIR = .TRUE.
SWAP = SWAP .OR. SELECT( K+1 )
END IF
END IF
IF( SWAP ) THEN
KS = KS + 1
*
* Swap the K-th block to position KS.
*
IERR = 0
KK = K
IF( K.NE.KS )
$ CALL STREXC( COMPQ, N, T, LDT, Q, LDQ, KK, KS, WORK,
$ IERR )
IF( IERR.EQ.1 .OR. IERR.EQ.2 ) THEN
*
* Blocks too close to swap: exit.
*
INFO = 1
IF( WANTS )
$ S = ZERO
IF( WANTSP )
$ SEP = ZERO
GO TO 40
END IF
IF( PAIR )
$ KS = KS + 1
END IF
END IF
20 CONTINUE
*
IF( WANTS ) THEN
*
* Solve Sylvester equation for R:
*
* T11*R - R*T22 = scale*T12
*
CALL SLACPY( 'F', N1, N2, T( 1, N1+1 ), LDT, WORK, N1 )
CALL STRSYL( 'N', 'N', -1, N1, N2, T, LDT, T( N1+1, N1+1 ),
$ LDT, WORK, N1, SCALE, IERR )
*
* Estimate the reciprocal of the condition number of the cluster
* of eigenvalues.
*
RNORM = SLANGE( 'F', N1, N2, WORK, N1, WORK )
IF( RNORM.EQ.ZERO ) THEN
S = ONE
ELSE
S = SCALE / ( SQRT( SCALE*SCALE / RNORM+RNORM )*
$ SQRT( RNORM ) )
END IF
END IF
*
IF( WANTSP ) THEN
*
* Estimate sep(T11,T22).
*
EST = ZERO
KASE = 0
30 CONTINUE
CALL SLACN2( NN, WORK( NN+1 ), WORK, IWORK, EST, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Solve T11*R - R*T22 = scale*X.
*
CALL STRSYL( 'N', 'N', -1, N1, N2, T, LDT,
$ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE,
$ IERR )
ELSE
*
* Solve T11'*R - R*T22' = scale*X.
*
CALL STRSYL( 'T', 'T', -1, N1, N2, T, LDT,
$ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE,
$ IERR )
END IF
GO TO 30
END IF
*
SEP = SCALE / EST
END IF
*
40 CONTINUE
*
* Store the output eigenvalues in WR and WI.
*
DO 50 K = 1, N
WR( K ) = T( K, K )
WI( K ) = ZERO
50 CONTINUE
DO 60 K = 1, N - 1
IF( T( K+1, K ).NE.ZERO ) THEN
WI( K ) = SQRT( ABS( T( K, K+1 ) ) )*
$ SQRT( ABS( T( K+1, K ) ) )
WI( K+1 ) = -WI( K )
END IF
60 CONTINUE
*
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
RETURN
*
* End of STRSEN
*
END
SUBROUTINE STRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
$ LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
*
* .. Scalar Arguments ..
CHARACTER HOWMNY, JOB
INTEGER INFO, LDT, LDVL, LDVR, LDWORK, M, MM, N
* ..
* .. Array Arguments ..
LOGICAL SELECT( * )
INTEGER IWORK( * )
REAL S( * ), SEP( * ), T( LDT, * ), VL( LDVL, * ),
$ VR( LDVR, * ), WORK( LDWORK, * )
* ..
*
* Purpose
* =======
*
* STRSNA estimates reciprocal condition numbers for specified
* eigenvalues and/or right eigenvectors of a real upper
* quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q
* orthogonal).
*
* T must be in Schur canonical form (as returned by SHSEQR), that is,
* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
* 2-by-2 diagonal block has its diagonal elements equal and its
* off-diagonal elements of opposite sign.
*
* Arguments
* =========
*
* JOB (input) CHARACTER*1
* Specifies whether condition numbers are required for
* eigenvalues (S) or eigenvectors (SEP):
* = 'E': for eigenvalues only (S);
* = 'V': for eigenvectors only (SEP);
* = 'B': for both eigenvalues and eigenvectors (S and SEP).
*
* HOWMNY (input) CHARACTER*1
* = 'A': compute condition numbers for all eigenpairs;
* = 'S': compute condition numbers for selected eigenpairs
* specified by the array SELECT.
*
* SELECT (input) LOGICAL array, dimension (N)
* If HOWMNY = 'S', SELECT specifies the eigenpairs for which
* condition numbers are required. To select condition numbers
* for the eigenpair corresponding to a real eigenvalue w(j),
* SELECT(j) must be set to .TRUE.. To select condition numbers
* corresponding to a complex conjugate pair of eigenvalues w(j)
* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be
* set to .TRUE..
* If HOWMNY = 'A', SELECT is not referenced.
*
* N (input) INTEGER
* The order of the matrix T. N >= 0.
*
* T (input) REAL array, dimension (LDT,N)
* The upper quasi-triangular matrix T, in Schur canonical form.
*
* LDT (input) INTEGER
* The leading dimension of the array T. LDT >= max(1,N).
*
* VL (input) REAL array, dimension (LDVL,M)
* If JOB = 'E' or 'B', VL must contain left eigenvectors of T
* (or of any Q*T*Q**T with Q orthogonal), corresponding to the
* eigenpairs specified by HOWMNY and SELECT. The eigenvectors
* must be stored in consecutive columns of VL, as returned by
* SHSEIN or STREVC.
* If JOB = 'V', VL is not referenced.
*
* LDVL (input) INTEGER
* The leading dimension of the array VL.
* LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.
*
* VR (input) REAL array, dimension (LDVR,M)
* If JOB = 'E' or 'B', VR must contain right eigenvectors of T
* (or of any Q*T*Q**T with Q orthogonal), corresponding to the
* eigenpairs specified by HOWMNY and SELECT. The eigenvectors
* must be stored in consecutive columns of VR, as returned by
* SHSEIN or STREVC.
* If JOB = 'V', VR is not referenced.
*
* LDVR (input) INTEGER
* The leading dimension of the array VR.
* LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.
*
* S (output) REAL array, dimension (MM)
* If JOB = 'E' or 'B', the reciprocal condition numbers of the
* selected eigenvalues, stored in consecutive elements of the
* array. For a complex conjugate pair of eigenvalues two
* consecutive elements of S are set to the same value. Thus
* S(j), SEP(j), and the j-th columns of VL and VR all
* correspond to the same eigenpair (but not in general the
* j-th eigenpair, unless all eigenpairs are selected).
* If JOB = 'V', S is not referenced.
*
* SEP (output) REAL array, dimension (MM)
* If JOB = 'V' or 'B', the estimated reciprocal condition
* numbers of the selected eigenvectors, stored in consecutive
* elements of the array. For a complex eigenvector two
* consecutive elements of SEP are set to the same value. If
* the eigenvalues cannot be reordered to compute SEP(j), SEP(j)
* is set to 0; this can only occur when the true value would be
* very small anyway.
* If JOB = 'E', SEP is not referenced.
*
* MM (input) INTEGER
* The number of elements in the arrays S (if JOB = 'E' or 'B')
* and/or SEP (if JOB = 'V' or 'B'). MM >= M.
*
* M (output) INTEGER
* The number of elements of the arrays S and/or SEP actually
* used to store the estimated condition numbers.
* If HOWMNY = 'A', M is set to N.
*
* WORK (workspace) REAL array, dimension (LDWORK,N+6)
* If JOB = 'E', WORK is not referenced.
*
* LDWORK (input) INTEGER
* The leading dimension of the array WORK.
* LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.
*
* IWORK (workspace) INTEGER array, dimension (2*(N-1))
* If JOB = 'E', IWORK is not referenced.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Further Details
* ===============
*
* The reciprocal of the condition number of an eigenvalue lambda is
* defined as
*
* S(lambda) = |v'*u| / (norm(u)*norm(v))
*
* where u and v are the right and left eigenvectors of T corresponding
* to lambda; v' denotes the conjugate-transpose of v, and norm(u)
* denotes the Euclidean norm. These reciprocal condition numbers always
* lie between zero (very badly conditioned) and one (very well
* conditioned). If n = 1, S(lambda) is defined to be 1.
*
* An approximate error bound for a computed eigenvalue W(i) is given by
*
* EPS * norm(T) / S(i)
*
* where EPS is the machine precision.
*
* The reciprocal of the condition number of the right eigenvector u
* corresponding to lambda is defined as follows. Suppose
*
* T = ( lambda c )
* ( 0 T22 )
*
* Then the reciprocal condition number is
*
* SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )
*
* where sigma-min denotes the smallest singular value. We approximate
* the smallest singular value by the reciprocal of an estimate of the
* one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is
* defined to be abs(T(1,1)).
*
* An approximate error bound for a computed right eigenvector VR(i)
* is given by
*
* EPS * norm(T) / SEP(i)
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL PAIR, SOMCON, WANTBH, WANTS, WANTSP
INTEGER I, IERR, IFST, ILST, J, K, KASE, KS, N2, NN
REAL BIGNUM, COND, CS, DELTA, DUMM, EPS, EST, LNRM,
$ MU, PROD, PROD1, PROD2, RNRM, SCALE, SMLNUM, SN
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
REAL DUMMY( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SDOT, SLAMCH, SLAPY2, SNRM2
EXTERNAL LSAME, SDOT, SLAMCH, SLAPY2, SNRM2
* ..
* .. External Subroutines ..
EXTERNAL SLABAD, SLACN2, SLACPY, SLAQTR, STREXC, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Decode and test the input parameters
*
WANTBH = LSAME( JOB, 'B' )
WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH
*
SOMCON = LSAME( HOWMNY, 'S' )
*
INFO = 0
IF( .NOT.WANTS .AND. .NOT.WANTSP ) THEN
INFO = -1
ELSE IF( .NOT.LSAME( HOWMNY, 'A' ) .AND. .NOT.SOMCON ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDVL.LT.1 .OR. ( WANTS .AND. LDVL.LT.N ) ) THEN
INFO = -8
ELSE IF( LDVR.LT.1 .OR. ( WANTS .AND. LDVR.LT.N ) ) THEN
INFO = -10
ELSE
*
* Set M to the number of eigenpairs for which condition numbers
* are required, and test MM.
*
IF( SOMCON ) THEN
M = 0
PAIR = .FALSE.
DO 10 K = 1, N
IF( PAIR ) THEN
PAIR = .FALSE.
ELSE
IF( K.LT.N ) THEN
IF( T( K+1, K ).EQ.ZERO ) THEN
IF( SELECT( K ) )
$ M = M + 1
ELSE
PAIR = .TRUE.
IF( SELECT( K ) .OR. SELECT( K+1 ) )
$ M = M + 2
END IF
ELSE
IF( SELECT( N ) )
$ M = M + 1
END IF
END IF
10 CONTINUE
ELSE
M = N
END IF
*
IF( MM.LT.M ) THEN
INFO = -13
ELSE IF( LDWORK.LT.1 .OR. ( WANTSP .AND. LDWORK.LT.N ) ) THEN
INFO = -16
END IF
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STRSNA', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( SOMCON ) THEN
IF( .NOT.SELECT( 1 ) )
$ RETURN
END IF
IF( WANTS )
$ S( 1 ) = ONE
IF( WANTSP )
$ SEP( 1 ) = ABS( T( 1, 1 ) )
RETURN
END IF
*
* Get machine constants
*
EPS = SLAMCH( 'P' )
SMLNUM = SLAMCH( 'S' ) / EPS
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
*
KS = 0
PAIR = .FALSE.
DO 60 K = 1, N
*
* Determine whether T(k,k) begins a 1-by-1 or 2-by-2 block.
*
IF( PAIR ) THEN
PAIR = .FALSE.
GO TO 60
ELSE
IF( K.LT.N )
$ PAIR = T( K+1, K ).NE.ZERO
END IF
*
* Determine whether condition numbers are required for the k-th
* eigenpair.
*
IF( SOMCON ) THEN
IF( PAIR ) THEN
IF( .NOT.SELECT( K ) .AND. .NOT.SELECT( K+1 ) )
$ GO TO 60
ELSE
IF( .NOT.SELECT( K ) )
$ GO TO 60
END IF
END IF
*
KS = KS + 1
*
IF( WANTS ) THEN
*
* Compute the reciprocal condition number of the k-th
* eigenvalue.
*
IF( .NOT.PAIR ) THEN
*
* Real eigenvalue.
*
PROD = SDOT( N, VR( 1, KS ), 1, VL( 1, KS ), 1 )
RNRM = SNRM2( N, VR( 1, KS ), 1 )
LNRM = SNRM2( N, VL( 1, KS ), 1 )
S( KS ) = ABS( PROD ) / ( RNRM*LNRM )
ELSE
*
* Complex eigenvalue.
*
PROD1 = SDOT( N, VR( 1, KS ), 1, VL( 1, KS ), 1 )
PROD1 = PROD1 + SDOT( N, VR( 1, KS+1 ), 1, VL( 1, KS+1 ),
$ 1 )
PROD2 = SDOT( N, VL( 1, KS ), 1, VR( 1, KS+1 ), 1 )
PROD2 = PROD2 - SDOT( N, VL( 1, KS+1 ), 1, VR( 1, KS ),
$ 1 )
RNRM = SLAPY2( SNRM2( N, VR( 1, KS ), 1 ),
$ SNRM2( N, VR( 1, KS+1 ), 1 ) )
LNRM = SLAPY2( SNRM2( N, VL( 1, KS ), 1 ),
$ SNRM2( N, VL( 1, KS+1 ), 1 ) )
COND = SLAPY2( PROD1, PROD2 ) / ( RNRM*LNRM )
S( KS ) = COND
S( KS+1 ) = COND
END IF
END IF
*
IF( WANTSP ) THEN
*
* Estimate the reciprocal condition number of the k-th
* eigenvector.
*
* Copy the matrix T to the array WORK and swap the diagonal
* block beginning at T(k,k) to the (1,1) position.
*
CALL SLACPY( 'Full', N, N, T, LDT, WORK, LDWORK )
IFST = K
ILST = 1
CALL STREXC( 'No Q', N, WORK, LDWORK, DUMMY, 1, IFST, ILST,
$ WORK( 1, N+1 ), IERR )
*
IF( IERR.EQ.1 .OR. IERR.EQ.2 ) THEN
*
* Could not swap because blocks not well separated
*
SCALE = ONE
EST = BIGNUM
ELSE
*
* Reordering successful
*
IF( WORK( 2, 1 ).EQ.ZERO ) THEN
*
* Form C = T22 - lambda*I in WORK(2:N,2:N).
*
DO 20 I = 2, N
WORK( I, I ) = WORK( I, I ) - WORK( 1, 1 )
20 CONTINUE
N2 = 1
NN = N - 1
ELSE
*
* Triangularize the 2 by 2 block by unitary
* transformation U = [ cs i*ss ]
* [ i*ss cs ].
* such that the (1,1) position of WORK is complex
* eigenvalue lambda with positive imaginary part. (2,2)
* position of WORK is the complex eigenvalue lambda
* with negative imaginary part.
*
MU = SQRT( ABS( WORK( 1, 2 ) ) )*
$ SQRT( ABS( WORK( 2, 1 ) ) )
DELTA = SLAPY2( MU, WORK( 2, 1 ) )
CS = MU / DELTA
SN = -WORK( 2, 1 ) / DELTA
*
* Form
*
* C' = WORK(2:N,2:N) + i*[rwork(1) ..... rwork(n-1) ]
* [ mu ]
* [ .. ]
* [ .. ]
* [ mu ]
* where C' is conjugate transpose of complex matrix C,
* and RWORK is stored starting in the N+1-st column of
* WORK.
*
DO 30 J = 3, N
WORK( 2, J ) = CS*WORK( 2, J )
WORK( J, J ) = WORK( J, J ) - WORK( 1, 1 )
30 CONTINUE
WORK( 2, 2 ) = ZERO
*
WORK( 1, N+1 ) = TWO*MU
DO 40 I = 2, N - 1
WORK( I, N+1 ) = SN*WORK( 1, I+1 )
40 CONTINUE
N2 = 2
NN = 2*( N-1 )
END IF
*
* Estimate norm(inv(C'))
*
EST = ZERO
KASE = 0
50 CONTINUE
CALL SLACN2( NN, WORK( 1, N+2 ), WORK( 1, N+4 ), IWORK,
$ EST, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
IF( N2.EQ.1 ) THEN
*
* Real eigenvalue: solve C'*x = scale*c.
*
CALL SLAQTR( .TRUE., .TRUE., N-1, WORK( 2, 2 ),
$ LDWORK, DUMMY, DUMM, SCALE,
$ WORK( 1, N+4 ), WORK( 1, N+6 ),
$ IERR )
ELSE
*
* Complex eigenvalue: solve
* C'*(p+iq) = scale*(c+id) in real arithmetic.
*
CALL SLAQTR( .TRUE., .FALSE., N-1, WORK( 2, 2 ),
$ LDWORK, WORK( 1, N+1 ), MU, SCALE,
$ WORK( 1, N+4 ), WORK( 1, N+6 ),
$ IERR )
END IF
ELSE
IF( N2.EQ.1 ) THEN
*
* Real eigenvalue: solve C*x = scale*c.
*
CALL SLAQTR( .FALSE., .TRUE., N-1, WORK( 2, 2 ),
$ LDWORK, DUMMY, DUMM, SCALE,
$ WORK( 1, N+4 ), WORK( 1, N+6 ),
$ IERR )
ELSE
*
* Complex eigenvalue: solve
* C*(p+iq) = scale*(c+id) in real arithmetic.
*
CALL SLAQTR( .FALSE., .FALSE., N-1,
$ WORK( 2, 2 ), LDWORK,
$ WORK( 1, N+1 ), MU, SCALE,
$ WORK( 1, N+4 ), WORK( 1, N+6 ),
$ IERR )
*
END IF
END IF
*
GO TO 50
END IF
END IF
*
SEP( KS ) = SCALE / MAX( EST, SMLNUM )
IF( PAIR )
$ SEP( KS+1 ) = SEP( KS )
END IF
*
IF( PAIR )
$ KS = KS + 1
*
60 CONTINUE
RETURN
*
* End of STRSNA
*
END
SUBROUTINE STRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C,
$ LDC, SCALE, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANA, TRANB
INTEGER INFO, ISGN, LDA, LDB, LDC, M, N
REAL SCALE
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), C( LDC, * )
* ..
*
* Purpose
* =======
*
* STRSYL solves the real Sylvester matrix equation:
*
* op(A)*X + X*op(B) = scale*C or
* op(A)*X - X*op(B) = scale*C,
*
* where op(A) = A or A**T, and A and B are both upper quasi-
* triangular. A is M-by-M and B is N-by-N; the right hand side C and
* the solution X are M-by-N; and scale is an output scale factor, set
* <= 1 to avoid overflow in X.
*
* A and B must be in Schur canonical form (as returned by SHSEQR), that
* is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks;
* each 2-by-2 diagonal block has its diagonal elements equal and its
* off-diagonal elements of opposite sign.
*
* Arguments
* =========
*
* TRANA (input) CHARACTER*1
* Specifies the option op(A):
* = 'N': op(A) = A (No transpose)
* = 'T': op(A) = A**T (Transpose)
* = 'C': op(A) = A**H (Conjugate transpose = Transpose)
*
* TRANB (input) CHARACTER*1
* Specifies the option op(B):
* = 'N': op(B) = B (No transpose)
* = 'T': op(B) = B**T (Transpose)
* = 'C': op(B) = B**H (Conjugate transpose = Transpose)
*
* ISGN (input) INTEGER
* Specifies the sign in the equation:
* = +1: solve op(A)*X + X*op(B) = scale*C
* = -1: solve op(A)*X - X*op(B) = scale*C
*
* M (input) INTEGER
* The order of the matrix A, and the number of rows in the
* matrices X and C. M >= 0.
*
* N (input) INTEGER
* The order of the matrix B, and the number of columns in the
* matrices X and C. N >= 0.
*
* A (input) REAL array, dimension (LDA,M)
* The upper quasi-triangular matrix A, in Schur canonical form.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input) REAL array, dimension (LDB,N)
* The upper quasi-triangular matrix B, in Schur canonical form.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* C (input/output) REAL array, dimension (LDC,N)
* On entry, the M-by-N right hand side matrix C.
* On exit, C is overwritten by the solution matrix X.
*
* LDC (input) INTEGER
* The leading dimension of the array C. LDC >= max(1,M)
*
* SCALE (output) REAL
* The scale factor, scale, set <= 1 to avoid overflow in X.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* = 1: A and B have common or very close eigenvalues; perturbed
* values were used to solve the equation (but the matrices
* A and B are unchanged).
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRNA, NOTRNB
INTEGER IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT
REAL A11, BIGNUM, DA11, DB, EPS, SCALOC, SGN, SMIN,
$ SMLNUM, SUML, SUMR, XNORM
* ..
* .. Local Arrays ..
REAL DUM( 1 ), VEC( 2, 2 ), X( 2, 2 )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SDOT, SLAMCH, SLANGE
EXTERNAL LSAME, SDOT, SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SLABAD, SLALN2, SLASY2, SSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL
* ..
* .. Executable Statements ..
*
* Decode and Test input parameters
*
NOTRNA = LSAME( TRANA, 'N' )
NOTRNB = LSAME( TRANB, 'N' )
*
INFO = 0
IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. .NOT.
$ LSAME( TRANA, 'C' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'T' ) .AND. .NOT.
$ LSAME( TRANB, 'C' ) ) THEN
INFO = -2
ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN
INFO = -3
ELSE IF( M.LT.0 ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -11
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STRSYL', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
* Set constants to control overflow
*
EPS = SLAMCH( 'P' )
SMLNUM = SLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
SMLNUM = SMLNUM*REAL( M*N ) / EPS
BIGNUM = ONE / SMLNUM
*
SMIN = MAX( SMLNUM, EPS*SLANGE( 'M', M, M, A, LDA, DUM ),
$ EPS*SLANGE( 'M', N, N, B, LDB, DUM ) )
*
SCALE = ONE
SGN = ISGN
*
IF( NOTRNA .AND. NOTRNB ) THEN
*
* Solve A*X + ISGN*X*B = scale*C.
*
* The (K,L)th block of X is determined starting from
* bottom-left corner column by column by
*
* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
*
* Where
* M L-1
* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)].
* I=K+1 J=1
*
* Start column loop (index = L)
* L1 (L2) : column index of the first (first) row of X(K,L).
*
LNEXT = 1
DO 70 L = 1, N
IF( L.LT.LNEXT )
$ GO TO 70
IF( L.EQ.N ) THEN
L1 = L
L2 = L
ELSE
IF( B( L+1, L ).NE.ZERO ) THEN
L1 = L
L2 = L + 1
LNEXT = L + 2
ELSE
L1 = L
L2 = L
LNEXT = L + 1
END IF
END IF
*
* Start row loop (index = K)
* K1 (K2): row index of the first (last) row of X(K,L).
*
KNEXT = M
DO 60 K = M, 1, -1
IF( K.GT.KNEXT )
$ GO TO 60
IF( K.EQ.1 ) THEN
K1 = K
K2 = K
ELSE
IF( A( K, K-1 ).NE.ZERO ) THEN
K1 = K - 1
K2 = K
KNEXT = K - 2
ELSE
K1 = K
K2 = K
KNEXT = K - 1
END IF
END IF
*
IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
SUML = SDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
$ C( MIN( K1+1, M ), L1 ), 1 )
SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
SCALOC = ONE
*
A11 = A( K1, K1 ) + SGN*B( L1, L1 )
DA11 = ABS( A11 )
IF( DA11.LE.SMIN ) THEN
A11 = SMIN
DA11 = SMIN
INFO = 1
END IF
DB = ABS( VEC( 1, 1 ) )
IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
IF( DB.GT.BIGNUM*DA11 )
$ SCALOC = ONE / DB
END IF
X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
*
IF( SCALOC.NE.ONE ) THEN
DO 10 J = 1, N
CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
10 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
*
ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
*
SUML = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
$ C( MIN( K2+1, M ), L1 ), 1 )
SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
*
SUML = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
$ C( MIN( K2+1, M ), L1 ), 1 )
SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
*
CALL SLALN2( .FALSE., 2, 1, SMIN, ONE, A( K1, K1 ),
$ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ),
$ ZERO, X, 2, SCALOC, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 1
*
IF( SCALOC.NE.ONE ) THEN
DO 20 J = 1, N
CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
20 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
C( K2, L1 ) = X( 2, 1 )
*
ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
*
SUML = SDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
$ C( MIN( K1+1, M ), L1 ), 1 )
SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) )
*
SUML = SDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
$ C( MIN( K1+1, M ), L2 ), 1 )
SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) )
*
CALL SLALN2( .TRUE., 2, 1, SMIN, ONE, B( L1, L1 ),
$ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ),
$ ZERO, X, 2, SCALOC, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 1
*
IF( SCALOC.NE.ONE ) THEN
DO 40 J = 1, N
CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
40 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
C( K1, L2 ) = X( 2, 1 )
*
ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
*
SUML = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
$ C( MIN( K2+1, M ), L1 ), 1 )
SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
*
SUML = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
$ C( MIN( K2+1, M ), L2 ), 1 )
SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR )
*
SUML = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
$ C( MIN( K2+1, M ), L1 ), 1 )
SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
*
SUML = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
$ C( MIN( K2+1, M ), L2 ), 1 )
SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L2 ), 1 )
VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR )
*
CALL SLASY2( .FALSE., .FALSE., ISGN, 2, 2,
$ A( K1, K1 ), LDA, B( L1, L1 ), LDB, VEC,
$ 2, SCALOC, X, 2, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 1
*
IF( SCALOC.NE.ONE ) THEN
DO 50 J = 1, N
CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
50 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
C( K1, L2 ) = X( 1, 2 )
C( K2, L1 ) = X( 2, 1 )
C( K2, L2 ) = X( 2, 2 )
END IF
*
60 CONTINUE
*
70 CONTINUE
*
ELSE IF( .NOT.NOTRNA .AND. NOTRNB ) THEN
*
* Solve A' *X + ISGN*X*B = scale*C.
*
* The (K,L)th block of X is determined starting from
* upper-left corner column by column by
*
* A(K,K)'*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
*
* Where
* K-1 L-1
* R(K,L) = SUM [A(I,K)'*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)]
* I=1 J=1
*
* Start column loop (index = L)
* L1 (L2): column index of the first (last) row of X(K,L)
*
LNEXT = 1
DO 130 L = 1, N
IF( L.LT.LNEXT )
$ GO TO 130
IF( L.EQ.N ) THEN
L1 = L
L2 = L
ELSE
IF( B( L+1, L ).NE.ZERO ) THEN
L1 = L
L2 = L + 1
LNEXT = L + 2
ELSE
L1 = L
L2 = L
LNEXT = L + 1
END IF
END IF
*
* Start row loop (index = K)
* K1 (K2): row index of the first (last) row of X(K,L)
*
KNEXT = 1
DO 120 K = 1, M
IF( K.LT.KNEXT )
$ GO TO 120
IF( K.EQ.M ) THEN
K1 = K
K2 = K
ELSE
IF( A( K+1, K ).NE.ZERO ) THEN
K1 = K
K2 = K + 1
KNEXT = K + 2
ELSE
K1 = K
K2 = K
KNEXT = K + 1
END IF
END IF
*
IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
SCALOC = ONE
*
A11 = A( K1, K1 ) + SGN*B( L1, L1 )
DA11 = ABS( A11 )
IF( DA11.LE.SMIN ) THEN
A11 = SMIN
DA11 = SMIN
INFO = 1
END IF
DB = ABS( VEC( 1, 1 ) )
IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
IF( DB.GT.BIGNUM*DA11 )
$ SCALOC = ONE / DB
END IF
X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
*
IF( SCALOC.NE.ONE ) THEN
DO 80 J = 1, N
CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
80 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
*
ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
*
SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
*
SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
*
CALL SLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ),
$ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ),
$ ZERO, X, 2, SCALOC, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 1
*
IF( SCALOC.NE.ONE ) THEN
DO 90 J = 1, N
CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
90 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
C( K2, L1 ) = X( 2, 1 )
*
ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
*
SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) )
*
SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) )
*
CALL SLALN2( .TRUE., 2, 1, SMIN, ONE, B( L1, L1 ),
$ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ),
$ ZERO, X, 2, SCALOC, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 1
*
IF( SCALOC.NE.ONE ) THEN
DO 100 J = 1, N
CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
100 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
C( K1, L2 ) = X( 2, 1 )
*
ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
*
SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
*
SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR )
*
SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
*
SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 )
SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L2 ), 1 )
VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR )
*
CALL SLASY2( .TRUE., .FALSE., ISGN, 2, 2, A( K1, K1 ),
$ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X,
$ 2, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 1
*
IF( SCALOC.NE.ONE ) THEN
DO 110 J = 1, N
CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
110 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
C( K1, L2 ) = X( 1, 2 )
C( K2, L1 ) = X( 2, 1 )
C( K2, L2 ) = X( 2, 2 )
END IF
*
120 CONTINUE
130 CONTINUE
*
ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN
*
* Solve A'*X + ISGN*X*B' = scale*C.
*
* The (K,L)th block of X is determined starting from
* top-right corner column by column by
*
* A(K,K)'*X(K,L) + ISGN*X(K,L)*B(L,L)' = C(K,L) - R(K,L)
*
* Where
* K-1 N
* R(K,L) = SUM [A(I,K)'*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)'].
* I=1 J=L+1
*
* Start column loop (index = L)
* L1 (L2): column index of the first (last) row of X(K,L)
*
LNEXT = N
DO 190 L = N, 1, -1
IF( L.GT.LNEXT )
$ GO TO 190
IF( L.EQ.1 ) THEN
L1 = L
L2 = L
ELSE
IF( B( L, L-1 ).NE.ZERO ) THEN
L1 = L - 1
L2 = L
LNEXT = L - 2
ELSE
L1 = L
L2 = L
LNEXT = L - 1
END IF
END IF
*
* Start row loop (index = K)
* K1 (K2): row index of the first (last) row of X(K,L)
*
KNEXT = 1
DO 180 K = 1, M
IF( K.LT.KNEXT )
$ GO TO 180
IF( K.EQ.M ) THEN
K1 = K
K2 = K
ELSE
IF( A( K+1, K ).NE.ZERO ) THEN
K1 = K
K2 = K + 1
KNEXT = K + 2
ELSE
K1 = K
K2 = K
KNEXT = K + 1
END IF
END IF
*
IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
SUMR = SDOT( N-L1, C( K1, MIN( L1+1, N ) ), LDC,
$ B( L1, MIN( L1+1, N ) ), LDB )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
SCALOC = ONE
*
A11 = A( K1, K1 ) + SGN*B( L1, L1 )
DA11 = ABS( A11 )
IF( DA11.LE.SMIN ) THEN
A11 = SMIN
DA11 = SMIN
INFO = 1
END IF
DB = ABS( VEC( 1, 1 ) )
IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
IF( DB.GT.BIGNUM*DA11 )
$ SCALOC = ONE / DB
END IF
X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
*
IF( SCALOC.NE.ONE ) THEN
DO 140 J = 1, N
CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
140 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
*
ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
*
SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
$ B( L1, MIN( L2+1, N ) ), LDB )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
*
SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
SUMR = SDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
$ B( L1, MIN( L2+1, N ) ), LDB )
VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
*
CALL SLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ),
$ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ),
$ ZERO, X, 2, SCALOC, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 1
*
IF( SCALOC.NE.ONE ) THEN
DO 150 J = 1, N
CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
150 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
C( K2, L1 ) = X( 2, 1 )
*
ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
*
SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
$ B( L1, MIN( L2+1, N ) ), LDB )
VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) )
*
SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
$ B( L2, MIN( L2+1, N ) ), LDB )
VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) )
*
CALL SLALN2( .FALSE., 2, 1, SMIN, ONE, B( L1, L1 ),
$ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ),
$ ZERO, X, 2, SCALOC, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 1
*
IF( SCALOC.NE.ONE ) THEN
DO 160 J = 1, N
CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
160 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
C( K1, L2 ) = X( 2, 1 )
*
ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
*
SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
$ B( L1, MIN( L2+1, N ) ), LDB )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
*
SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
$ B( L2, MIN( L2+1, N ) ), LDB )
VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR )
*
SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
SUMR = SDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
$ B( L1, MIN( L2+1, N ) ), LDB )
VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
*
SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 )
SUMR = SDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
$ B( L2, MIN(L2+1, N ) ), LDB )
VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR )
*
CALL SLASY2( .TRUE., .TRUE., ISGN, 2, 2, A( K1, K1 ),
$ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X,
$ 2, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 1
*
IF( SCALOC.NE.ONE ) THEN
DO 170 J = 1, N
CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
170 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
C( K1, L2 ) = X( 1, 2 )
C( K2, L1 ) = X( 2, 1 )
C( K2, L2 ) = X( 2, 2 )
END IF
*
180 CONTINUE
190 CONTINUE
*
ELSE IF( NOTRNA .AND. .NOT.NOTRNB ) THEN
*
* Solve A*X + ISGN*X*B' = scale*C.
*
* The (K,L)th block of X is determined starting from
* bottom-right corner column by column by
*
* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L)' = C(K,L) - R(K,L)
*
* Where
* M N
* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)'].
* I=K+1 J=L+1
*
* Start column loop (index = L)
* L1 (L2): column index of the first (last) row of X(K,L)
*
LNEXT = N
DO 250 L = N, 1, -1
IF( L.GT.LNEXT )
$ GO TO 250
IF( L.EQ.1 ) THEN
L1 = L
L2 = L
ELSE
IF( B( L, L-1 ).NE.ZERO ) THEN
L1 = L - 1
L2 = L
LNEXT = L - 2
ELSE
L1 = L
L2 = L
LNEXT = L - 1
END IF
END IF
*
* Start row loop (index = K)
* K1 (K2): row index of the first (last) row of X(K,L)
*
KNEXT = M
DO 240 K = M, 1, -1
IF( K.GT.KNEXT )
$ GO TO 240
IF( K.EQ.1 ) THEN
K1 = K
K2 = K
ELSE
IF( A( K, K-1 ).NE.ZERO ) THEN
K1 = K - 1
K2 = K
KNEXT = K - 2
ELSE
K1 = K
K2 = K
KNEXT = K - 1
END IF
END IF
*
IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
SUML = SDOT( M-K1, A( K1, MIN(K1+1, M ) ), LDA,
$ C( MIN( K1+1, M ), L1 ), 1 )
SUMR = SDOT( N-L1, C( K1, MIN( L1+1, N ) ), LDC,
$ B( L1, MIN( L1+1, N ) ), LDB )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
SCALOC = ONE
*
A11 = A( K1, K1 ) + SGN*B( L1, L1 )
DA11 = ABS( A11 )
IF( DA11.LE.SMIN ) THEN
A11 = SMIN
DA11 = SMIN
INFO = 1
END IF
DB = ABS( VEC( 1, 1 ) )
IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
IF( DB.GT.BIGNUM*DA11 )
$ SCALOC = ONE / DB
END IF
X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
*
IF( SCALOC.NE.ONE ) THEN
DO 200 J = 1, N
CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
200 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
*
ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
*
SUML = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
$ C( MIN( K2+1, M ), L1 ), 1 )
SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
$ B( L1, MIN( L2+1, N ) ), LDB )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
*
SUML = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
$ C( MIN( K2+1, M ), L1 ), 1 )
SUMR = SDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
$ B( L1, MIN( L2+1, N ) ), LDB )
VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
*
CALL SLALN2( .FALSE., 2, 1, SMIN, ONE, A( K1, K1 ),
$ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ),
$ ZERO, X, 2, SCALOC, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 1
*
IF( SCALOC.NE.ONE ) THEN
DO 210 J = 1, N
CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
210 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
C( K2, L1 ) = X( 2, 1 )
*
ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
*
SUML = SDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
$ C( MIN( K1+1, M ), L1 ), 1 )
SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
$ B( L1, MIN( L2+1, N ) ), LDB )
VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) )
*
SUML = SDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
$ C( MIN( K1+1, M ), L2 ), 1 )
SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
$ B( L2, MIN( L2+1, N ) ), LDB )
VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) )
*
CALL SLALN2( .FALSE., 2, 1, SMIN, ONE, B( L1, L1 ),
$ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ),
$ ZERO, X, 2, SCALOC, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 1
*
IF( SCALOC.NE.ONE ) THEN
DO 220 J = 1, N
CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
220 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
C( K1, L2 ) = X( 2, 1 )
*
ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
*
SUML = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
$ C( MIN( K2+1, M ), L1 ), 1 )
SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
$ B( L1, MIN( L2+1, N ) ), LDB )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
*
SUML = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
$ C( MIN( K2+1, M ), L2 ), 1 )
SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
$ B( L2, MIN( L2+1, N ) ), LDB )
VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR )
*
SUML = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
$ C( MIN( K2+1, M ), L1 ), 1 )
SUMR = SDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
$ B( L1, MIN( L2+1, N ) ), LDB )
VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
*
SUML = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
$ C( MIN( K2+1, M ), L2 ), 1 )
SUMR = SDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
$ B( L2, MIN( L2+1, N ) ), LDB )
VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR )
*
CALL SLASY2( .FALSE., .TRUE., ISGN, 2, 2, A( K1, K1 ),
$ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X,
$ 2, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 1
*
IF( SCALOC.NE.ONE ) THEN
DO 230 J = 1, N
CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
230 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
C( K1, L2 ) = X( 1, 2 )
C( K2, L1 ) = X( 2, 1 )
C( K2, L2 ) = X( 2, 2 )
END IF
*
240 CONTINUE
250 CONTINUE
*
END IF
*
RETURN
*
* End of STRSYL
*
END
SUBROUTINE STRTI2( UPLO, DIAG, N, A, LDA, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
REAL A( LDA, * )
* ..
*
* Purpose
* =======
*
* STRTI2 computes the inverse of a real upper or lower triangular
* matrix.
*
* This is the Level 2 BLAS version of the algorithm.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the triangular matrix A. If UPLO = 'U', the
* leading n by n upper triangular part of the array A contains
* the upper triangular matrix, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading n by n lower triangular part of the array A contains
* the lower triangular matrix, and the strictly upper
* triangular part of A is not referenced. If DIAG = 'U', the
* diagonal elements of A are also not referenced and are
* assumed to be 1.
*
* On exit, the (triangular) inverse of the original matrix, in
* the same storage format.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT, UPPER
INTEGER J
REAL AJJ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SSCAL, STRMV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOUNIT = LSAME( DIAG, 'N' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STRTI2', -INFO )
RETURN
END IF
*
IF( UPPER ) THEN
*
* Compute inverse of upper triangular matrix.
*
DO 10 J = 1, N
IF( NOUNIT ) THEN
A( J, J ) = ONE / A( J, J )
AJJ = -A( J, J )
ELSE
AJJ = -ONE
END IF
*
* Compute elements 1:j-1 of j-th column.
*
CALL STRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA,
$ A( 1, J ), 1 )
CALL SSCAL( J-1, AJJ, A( 1, J ), 1 )
10 CONTINUE
ELSE
*
* Compute inverse of lower triangular matrix.
*
DO 20 J = N, 1, -1
IF( NOUNIT ) THEN
A( J, J ) = ONE / A( J, J )
AJJ = -A( J, J )
ELSE
AJJ = -ONE
END IF
IF( J.LT.N ) THEN
*
* Compute elements j+1:n of j-th column.
*
CALL STRMV( 'Lower', 'No transpose', DIAG, N-J,
$ A( J+1, J+1 ), LDA, A( J+1, J ), 1 )
CALL SSCAL( N-J, AJJ, A( J+1, J ), 1 )
END IF
20 CONTINUE
END IF
*
RETURN
*
* End of STRTI2
*
END
SUBROUTINE STRTRI( UPLO, DIAG, N, A, LDA, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
REAL A( LDA, * )
* ..
*
* Purpose
* =======
*
* STRTRI computes the inverse of a real upper or lower triangular
* matrix A.
*
* This is the Level 3 BLAS version of the algorithm.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': A is upper triangular;
* = 'L': A is lower triangular.
*
* DIAG (input) CHARACTER*1
* = 'N': A is non-unit triangular;
* = 'U': A is unit triangular.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the triangular matrix A. If UPLO = 'U', the
* leading N-by-N upper triangular part of the array A contains
* the upper triangular matrix, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading N-by-N lower triangular part of the array A contains
* the lower triangular matrix, and the strictly upper
* triangular part of A is not referenced. If DIAG = 'U', the
* diagonal elements of A are also not referenced and are
* assumed to be 1.
* On exit, the (triangular) inverse of the original matrix, in
* the same storage format.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, A(i,i) is exactly zero. The triangular
* matrix is singular and its inverse can not be computed.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT, UPPER
INTEGER J, JB, NB, NN
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL STRMM, STRSM, STRTI2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOUNIT = LSAME( DIAG, 'N' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STRTRI', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Check for singularity if non-unit.
*
IF( NOUNIT ) THEN
DO 10 INFO = 1, N
IF( A( INFO, INFO ).EQ.ZERO )
$ RETURN
10 CONTINUE
INFO = 0
END IF
*
* Determine the block size for this environment.
*
NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )
IF( NB.LE.1 .OR. NB.GE.N ) THEN
*
* Use unblocked code
*
CALL STRTI2( UPLO, DIAG, N, A, LDA, INFO )
ELSE
*
* Use blocked code
*
IF( UPPER ) THEN
*
* Compute inverse of upper triangular matrix
*
DO 20 J = 1, N, NB
JB = MIN( NB, N-J+1 )
*
* Compute rows 1:j-1 of current block column
*
CALL STRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1,
$ JB, ONE, A, LDA, A( 1, J ), LDA )
CALL STRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1,
$ JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA )
*
* Compute inverse of current diagonal block
*
CALL STRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO )
20 CONTINUE
ELSE
*
* Compute inverse of lower triangular matrix
*
NN = ( ( N-1 ) / NB )*NB + 1
DO 30 J = NN, 1, -NB
JB = MIN( NB, N-J+1 )
IF( J+JB.LE.N ) THEN
*
* Compute rows j+jb:n of current block column
*
CALL STRMM( 'Left', 'Lower', 'No transpose', DIAG,
$ N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA,
$ A( J+JB, J ), LDA )
CALL STRSM( 'Right', 'Lower', 'No transpose', DIAG,
$ N-J-JB+1, JB, -ONE, A( J, J ), LDA,
$ A( J+JB, J ), LDA )
END IF
*
* Compute inverse of current diagonal block
*
CALL STRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO )
30 CONTINUE
END IF
END IF
*
RETURN
*
* End of STRTRI
*
END
SUBROUTINE STRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* STRTRS solves a triangular system of the form
*
* A * X = B or A**T * X = B,
*
* where A is a triangular matrix of order N, and B is an N-by-NRHS
* matrix. A check is made to verify that A is nonsingular.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': A is upper triangular;
* = 'L': A is lower triangular.
*
* 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**H * X = B (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* = 'N': A is non-unit triangular;
* = 'U': A is unit triangular.
*
* 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) REAL array, dimension (LDA,N)
* The triangular matrix A. If UPLO = 'U', the leading N-by-N
* upper triangular part of the array A contains the upper
* triangular matrix, and the strictly lower triangular part of
* A is not referenced. If UPLO = 'L', the leading N-by-N lower
* triangular part of the array A contains the lower triangular
* matrix, and the strictly upper triangular part of A is not
* referenced. If DIAG = 'U', the diagonal elements of A are
* also not referenced and are assumed to be 1.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the right hand side matrix B.
* On exit, if INFO = 0, 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
* > 0: if INFO = i, the i-th diagonal element of A is zero,
* indicating that the matrix is singular and the solutions
* X have not been computed.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL STRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
NOUNIT = LSAME( DIAG, 'N' )
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.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( NRHS.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STRTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Check for singularity.
*
IF( NOUNIT ) THEN
DO 10 INFO = 1, N
IF( A( INFO, INFO ).EQ.ZERO )
$ RETURN
10 CONTINUE
END IF
INFO = 0
*
* Solve A * x = b or A' * x = b.
*
CALL STRSM( 'Left', UPLO, TRANS, DIAG, N, NRHS, ONE, A, LDA, B,
$ LDB )
*
RETURN
*
* End of STRTRS
*
END
SUBROUTINE STZRQF( M, N, A, LDA, TAU, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), TAU( * )
* ..
*
* Purpose
* =======
*
* This routine is deprecated and has been replaced by routine STZRZF.
*
* STZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A
* to upper triangular form by means of orthogonal transformations.
*
* The upper trapezoidal matrix A is factored as
*
* A = ( R 0 ) * Z,
*
* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper
* triangular matrix.
*
* 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 >= M.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the leading M-by-N upper trapezoidal part of the
* array A must contain the matrix to be factorized.
* On exit, the leading M-by-M upper triangular part of A
* contains the upper triangular matrix R, and elements M+1 to
* N of the first M rows of A, with the array TAU, represent the
* orthogonal matrix Z as a product of M elementary reflectors.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* TAU (output) REAL array, dimension (M)
* The scalar factors of the elementary reflectors.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Further Details
* ===============
*
* The factorization is obtained by Householder's method. The kth
* transformation matrix, Z( k ), which is used to introduce zeros into
* the ( m - k + 1 )th row of A, is given in the form
*
* Z( k ) = ( I 0 ),
* ( 0 T( k ) )
*
* where
*
* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),
* ( 0 )
* ( z( k ) )
*
* tau is a scalar and z( k ) is an ( n - m ) element vector.
* tau and z( k ) are chosen to annihilate the elements of the kth row
* of X.
*
* The scalar tau is returned in the kth element of TAU and the vector
* u( k ) in the kth row of A, such that the elements of z( k ) are
* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in
* the upper triangular part of A.
*
* Z is given by
*
* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, K, M1
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, SGEMV, SGER, SLARFG, XERBLA
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.M ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STZRQF', -INFO )
RETURN
END IF
*
* Perform the factorization.
*
IF( M.EQ.0 )
$ RETURN
IF( M.EQ.N ) THEN
DO 10 I = 1, N
TAU( I ) = ZERO
10 CONTINUE
ELSE
M1 = MIN( M+1, N )
DO 20 K = M, 1, -1
*
* Use a Householder reflection to zero the kth row of A.
* First set up the reflection.
*
CALL SLARFG( N-M+1, A( K, K ), A( K, M1 ), LDA, TAU( K ) )
*
IF( ( TAU( K ).NE.ZERO ) .AND. ( K.GT.1 ) ) THEN
*
* We now perform the operation A := A*P( k ).
*
* Use the first ( k - 1 ) elements of TAU to store a( k ),
* where a( k ) consists of the first ( k - 1 ) elements of
* the kth column of A. Also let B denote the first
* ( k - 1 ) rows of the last ( n - m ) columns of A.
*
CALL SCOPY( K-1, A( 1, K ), 1, TAU, 1 )
*
* Form w = a( k ) + B*z( k ) in TAU.
*
CALL SGEMV( 'No transpose', K-1, N-M, ONE, A( 1, M1 ),
$ LDA, A( K, M1 ), LDA, ONE, TAU, 1 )
*
* Now form a( k ) := a( k ) - tau*w
* and B := B - tau*w*z( k )'.
*
CALL SAXPY( K-1, -TAU( K ), TAU, 1, A( 1, K ), 1 )
CALL SGER( K-1, N-M, -TAU( K ), TAU, 1, A( K, M1 ), LDA,
$ A( 1, M1 ), LDA )
END IF
20 CONTINUE
END IF
*
RETURN
*
* End of STZRQF
*
END
SUBROUTINE STZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* STZRZF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A
* to upper triangular form by means of orthogonal transformations.
*
* The upper trapezoidal matrix A is factored as
*
* A = ( R 0 ) * Z,
*
* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper
* triangular matrix.
*
* 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 >= M.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the leading M-by-N upper trapezoidal part of the
* array A must contain the matrix to be factorized.
* On exit, the leading M-by-M upper triangular part of A
* contains the upper triangular matrix R, and elements M+1 to
* N of the first M rows of A, with the array TAU, represent the
* orthogonal matrix Z as a product of M elementary reflectors.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* TAU (output) REAL array, dimension (M)
* The scalar factors of the elementary reflectors.
*
* WORK (workspace/output) REAL 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,M).
* For optimum performance LWORK >= M*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
* ===============
*
* Based on contributions by
* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*
* The factorization is obtained by Householder's method. The kth
* transformation matrix, Z( k ), which is used to introduce zeros into
* the ( m - k + 1 )th row of A, is given in the form
*
* Z( k ) = ( I 0 ),
* ( 0 T( k ) )
*
* where
*
* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),
* ( 0 )
* ( z( k ) )
*
* tau is a scalar and z( k ) is an ( n - m ) element vector.
* tau and z( k ) are chosen to annihilate the elements of the kth row
* of X.
*
* The scalar tau is returned in the kth element of TAU and the vector
* u( k ) in the kth row of A, such that the elements of z( k ) are
* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in
* the upper triangular part of A.
*
* Z is given by
*
* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IWS, KI, KK, LDWORK, LWKOPT, M1, MU, NB,
$ NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL SLARZB, SLARZT, SLATRZ, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.M ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
END IF
*
IF( INFO.EQ.0 ) THEN
IF( M.EQ.0 .OR. M.EQ.N ) THEN
LWKOPT = 1
ELSE
*
* Determine the block size.
*
NB = ILAENV( 1, 'SGERQF', ' ', M, N, -1, -1 )
LWKOPT = M*NB
END IF
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
INFO = -7
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STZRZF', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 ) THEN
RETURN
ELSE IF( M.EQ.N ) THEN
DO 10 I = 1, N
TAU( I ) = ZERO
10 CONTINUE
RETURN
END IF
*
NBMIN = 2
NX = 1
IWS = M
IF( NB.GT.1 .AND. NB.LT.M ) THEN
*
* Determine when to cross over from blocked to unblocked code.
*
NX = MAX( 0, ILAENV( 3, 'SGERQF', ' ', M, N, -1, -1 ) )
IF( NX.LT.M ) THEN
*
* Determine if workspace is large enough for blocked code.
*
LDWORK = M
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, 'SGERQF', ' ', M, N, -1,
$ -1 ) )
END IF
END IF
END IF
*
IF( NB.GE.NBMIN .AND. NB.LT.M .AND. NX.LT.M ) THEN
*
* Use blocked code initially.
* The last kk rows are handled by the block method.
*
M1 = MIN( M+1, N )
KI = ( ( M-NX-1 ) / NB )*NB
KK = MIN( M, KI+NB )
*
DO 20 I = M - KK + KI + 1, M - KK + 1, -NB
IB = MIN( M-I+1, NB )
*
* Compute the TZ factorization of the current block
* A(i:i+ib-1,i:n)
*
CALL SLATRZ( IB, N-I+1, N-M, A( I, I ), LDA, TAU( I ),
$ WORK )
IF( I.GT.1 ) THEN
*
* Form the triangular factor of the block reflector
* H = H(i+ib-1) . . . H(i+1) H(i)
*
CALL SLARZT( 'Backward', 'Rowwise', N-M, IB, A( I, M1 ),
$ LDA, TAU( I ), WORK, LDWORK )
*
* Apply H to A(1:i-1,i:n) from the right
*
CALL SLARZB( 'Right', 'No transpose', 'Backward',
$ 'Rowwise', I-1, N-I+1, IB, N-M, A( I, M1 ),
$ LDA, WORK, LDWORK, A( 1, I ), LDA,
$ WORK( IB+1 ), LDWORK )
END IF
20 CONTINUE
MU = I + NB - 1
ELSE
MU = M
END IF
*
* Use unblocked code to factor the last or only block
*
IF( MU.GT.0 )
$ CALL SLATRZ( MU, N, N-M, A, LDA, TAU, WORK )
*
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of STZRZF
*
END
DOUBLE PRECISION FUNCTION DLAMCH( CMACH )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. 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 ..
LOGICAL FIRST, LRND
INTEGER BETA, IMAX, IMIN, IT
DOUBLE PRECISION BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN,
$ RND, SFMIN, SMALL, T
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DLAMC2
* ..
* .. Save statement ..
SAVE FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN,
$ EMAX, RMAX, PREC
* ..
* .. Data statements ..
DATA FIRST / .TRUE. /
* ..
* .. Executable Statements ..
*
IF( FIRST ) THEN
CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX )
BASE = BETA
T = IT
IF( LRND ) THEN
RND = ONE
EPS = ( BASE**( 1-IT ) ) / 2
ELSE
RND = ZERO
EPS = BASE**( 1-IT )
END IF
PREC = EPS*BASE
EMIN = IMIN
EMAX = IMAX
SFMIN = RMIN
SMALL = ONE / RMAX
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
END IF
*
IF( LSAME( CMACH, 'E' ) ) THEN
RMACH = EPS
ELSE IF( LSAME( CMACH, 'S' ) ) THEN
RMACH = SFMIN
ELSE IF( LSAME( CMACH, 'B' ) ) THEN
RMACH = BASE
ELSE IF( LSAME( CMACH, 'P' ) ) THEN
RMACH = PREC
ELSE IF( LSAME( CMACH, 'N' ) ) THEN
RMACH = T
ELSE IF( LSAME( CMACH, 'R' ) ) THEN
RMACH = RND
ELSE IF( LSAME( CMACH, 'M' ) ) THEN
RMACH = EMIN
ELSE IF( LSAME( CMACH, 'U' ) ) THEN
RMACH = RMIN
ELSE IF( LSAME( CMACH, 'L' ) ) THEN
RMACH = EMAX
ELSE IF( LSAME( CMACH, 'O' ) ) THEN
RMACH = RMAX
END IF
*
DLAMCH = RMACH
FIRST = .FALSE.
RETURN
*
* End of DLAMCH
*
END
*
************************************************************************
*
SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL IEEE1, RND
INTEGER BETA, T
* ..
*
* Purpose
* =======
*
* DLAMC1 determines the machine parameters given by BETA, T, RND, and
* IEEE1.
*
* Arguments
* =========
*
* BETA (output) INTEGER
* The base of the machine.
*
* T (output) INTEGER
* The number of ( BETA ) digits in the mantissa.
*
* RND (output) LOGICAL
* Specifies whether proper rounding ( RND = .TRUE. ) or
* chopping ( RND = .FALSE. ) occurs in addition. This may not
* be a reliable guide to the way in which the machine performs
* its arithmetic.
*
* IEEE1 (output) LOGICAL
* Specifies whether rounding appears to be done in the IEEE
* 'round to nearest' style.
*
* Further Details
* ===============
*
* The routine is based on the routine ENVRON by Malcolm and
* incorporates suggestions by Gentleman and Marovich. See
*
* Malcolm M. A. (1972) Algorithms to reveal properties of
* floating-point arithmetic. Comms. of the ACM, 15, 949-951.
*
* Gentleman W. M. and Marovich S. B. (1974) More on algorithms
* that reveal properties of floating point arithmetic units.
* Comms. of the ACM, 17, 276-277.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL FIRST, LIEEE1, LRND
INTEGER LBETA, LT
DOUBLE PRECISION A, B, C, F, ONE, QTR, SAVEC, T1, T2
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMC3
EXTERNAL DLAMC3
* ..
* .. Save statement ..
SAVE FIRST, LIEEE1, LBETA, LRND, LT
* ..
* .. Data statements ..
DATA FIRST / .TRUE. /
* ..
* .. Executable Statements ..
*
IF( FIRST ) THEN
ONE = 1
*
* LBETA, LIEEE1, LT and LRND are the local values of BETA,
* IEEE1, T and RND.
*
* Throughout this routine we use the function DLAMC3 to ensure
* that relevant values are stored and not held in registers, or
* are not affected by optimizers.
*
* Compute a = 2.0**m with the smallest positive integer m such
* that
*
* fl( a + 1.0 ) = a.
*
A = 1
C = 1
*
*+ WHILE( C.EQ.ONE )LOOP
10 CONTINUE
IF( C.EQ.ONE ) THEN
A = 2*A
C = DLAMC3( A, ONE )
C = DLAMC3( C, -A )
GO TO 10
END IF
*+ END WHILE
*
* Now compute b = 2.0**m with the smallest positive integer m
* such that
*
* fl( a + b ) .gt. a.
*
B = 1
C = DLAMC3( A, B )
*
*+ WHILE( C.EQ.A )LOOP
20 CONTINUE
IF( C.EQ.A ) THEN
B = 2*B
C = DLAMC3( A, B )
GO TO 20
END IF
*+ END WHILE
*
* Now compute the base. a and c are neighbouring floating point
* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so
* their difference is beta. Adding 0.25 to c is to ensure that it
* is truncated to beta and not ( beta - 1 ).
*
QTR = ONE / 4
SAVEC = C
C = DLAMC3( C, -A )
LBETA = C + QTR
*
* Now determine whether rounding or chopping occurs, by adding a
* bit less than beta/2 and a bit more than beta/2 to a.
*
B = LBETA
F = DLAMC3( B / 2, -B / 100 )
C = DLAMC3( F, A )
IF( C.EQ.A ) THEN
LRND = .TRUE.
ELSE
LRND = .FALSE.
END IF
F = DLAMC3( B / 2, B / 100 )
C = DLAMC3( F, A )
IF( ( LRND ) .AND. ( C.EQ.A ) )
$ LRND = .FALSE.
*
* Try and decide whether rounding is done in the IEEE 'round to
* nearest' style. B/2 is half a unit in the last place of the two
* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit
* zero, and SAVEC is odd. Thus adding B/2 to A should not change
* A, but adding B/2 to SAVEC should change SAVEC.
*
T1 = DLAMC3( B / 2, A )
T2 = DLAMC3( B / 2, SAVEC )
LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND
*
* Now find the mantissa, t. It should be the integer part of
* log to the base beta of a, however it is safer to determine t
* by powering. So we find t as the smallest positive integer for
* which
*
* fl( beta**t + 1.0 ) = 1.0.
*
LT = 0
A = 1
C = 1
*
*+ WHILE( C.EQ.ONE )LOOP
30 CONTINUE
IF( C.EQ.ONE ) THEN
LT = LT + 1
A = A*LBETA
C = DLAMC3( A, ONE )
C = DLAMC3( C, -A )
GO TO 30
END IF
*+ END WHILE
*
END IF
*
BETA = LBETA
T = LT
RND = LRND
IEEE1 = LIEEE1
FIRST = .FALSE.
RETURN
*
* End of DLAMC1
*
END
*
************************************************************************
*
SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL RND
INTEGER BETA, EMAX, EMIN, T
DOUBLE PRECISION EPS, RMAX, RMIN
* ..
*
* Purpose
* =======
*
* DLAMC2 determines the machine parameters specified in its argument
* list.
*
* Arguments
* =========
*
* BETA (output) INTEGER
* The base of the machine.
*
* T (output) INTEGER
* The number of ( BETA ) digits in the mantissa.
*
* RND (output) LOGICAL
* Specifies whether proper rounding ( RND = .TRUE. ) or
* chopping ( RND = .FALSE. ) occurs in addition. This may not
* be a reliable guide to the way in which the machine performs
* its arithmetic.
*
* EPS (output) DOUBLE PRECISION
* The smallest positive number such that
*
* fl( 1.0 - EPS ) .LT. 1.0,
*
* where fl denotes the computed value.
*
* EMIN (output) INTEGER
* The minimum exponent before (gradual) underflow occurs.
*
* RMIN (output) DOUBLE PRECISION
* The smallest normalized number for the machine, given by
* BASE**( EMIN - 1 ), where BASE is the floating point value
* of BETA.
*
* EMAX (output) INTEGER
* The maximum exponent before overflow occurs.
*
* RMAX (output) DOUBLE PRECISION
* The largest positive number for the machine, given by
* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point
* value of BETA.
*
* Further Details
* ===============
*
* The computation of EPS is based on a routine PARANOIA by
* W. Kahan of the University of California at Berkeley.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND
INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT,
$ NGNMIN, NGPMIN
DOUBLE PRECISION A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE,
$ SIXTH, SMALL, THIRD, TWO, ZERO
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMC3
EXTERNAL DLAMC3
* ..
* .. External Subroutines ..
EXTERNAL DLAMC1, DLAMC4, DLAMC5
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Save statement ..
SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX,
$ LRMIN, LT
* ..
* .. Data statements ..
DATA FIRST / .TRUE. / , IWARN / .FALSE. /
* ..
* .. Executable Statements ..
*
IF( FIRST ) THEN
ZERO = 0
ONE = 1
TWO = 2
*
* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of
* BETA, T, RND, EPS, EMIN and RMIN.
*
* Throughout this routine we use the function DLAMC3 to ensure
* that relevant values are stored and not held in registers, or
* are not affected by optimizers.
*
* DLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1.
*
CALL DLAMC1( LBETA, LT, LRND, LIEEE1 )
*
* Start to find EPS.
*
B = LBETA
A = B**( -LT )
LEPS = A
*
* Try some tricks to see whether or not this is the correct EPS.
*
B = TWO / 3
HALF = ONE / 2
SIXTH = DLAMC3( B, -HALF )
THIRD = DLAMC3( SIXTH, SIXTH )
B = DLAMC3( THIRD, -HALF )
B = DLAMC3( B, SIXTH )
B = ABS( B )
IF( B.LT.LEPS )
$ B = LEPS
*
LEPS = 1
*
*+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP
10 CONTINUE
IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN
LEPS = B
C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) )
C = DLAMC3( HALF, -C )
B = DLAMC3( HALF, C )
C = DLAMC3( HALF, -B )
B = DLAMC3( HALF, C )
GO TO 10
END IF
*+ END WHILE
*
IF( A.LT.LEPS )
$ LEPS = A
*
* Computation of EPS complete.
*
* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)).
* Keep dividing A by BETA until (gradual) underflow occurs. This
* is detected when we cannot recover the previous A.
*
RBASE = ONE / LBETA
SMALL = ONE
DO 20 I = 1, 3
SMALL = DLAMC3( SMALL*RBASE, ZERO )
20 CONTINUE
A = DLAMC3( ONE, SMALL )
CALL DLAMC4( NGPMIN, ONE, LBETA )
CALL DLAMC4( NGNMIN, -ONE, LBETA )
CALL DLAMC4( GPMIN, A, LBETA )
CALL DLAMC4( GNMIN, -A, LBETA )
IEEE = .FALSE.
*
IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN
IF( NGPMIN.EQ.GPMIN ) THEN
LEMIN = NGPMIN
* ( Non twos-complement machines, no gradual underflow;
* e.g., VAX )
ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN
LEMIN = NGPMIN - 1 + LT
IEEE = .TRUE.
* ( Non twos-complement machines, with gradual underflow;
* e.g., IEEE standard followers )
ELSE
LEMIN = MIN( NGPMIN, GPMIN )
* ( A guess; no known machine )
IWARN = .TRUE.
END IF
*
ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN
IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN
LEMIN = MAX( NGPMIN, NGNMIN )
* ( Twos-complement machines, no gradual underflow;
* e.g., CYBER 205 )
ELSE
LEMIN = MIN( NGPMIN, NGNMIN )
* ( A guess; no known machine )
IWARN = .TRUE.
END IF
*
ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND.
$ ( GPMIN.EQ.GNMIN ) ) THEN
IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN
LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT
* ( Twos-complement machines with gradual underflow;
* no known machine )
ELSE
LEMIN = MIN( NGPMIN, NGNMIN )
* ( A guess; no known machine )
IWARN = .TRUE.
END IF
*
ELSE
LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN )
* ( A guess; no known machine )
IWARN = .TRUE.
END IF
FIRST = .FALSE.
***
* Comment out this if block if EMIN is ok
IF( IWARN ) THEN
FIRST = .TRUE.
WRITE( 6, FMT = 9999 )LEMIN
END IF
***
*
* Assume IEEE arithmetic if we found denormalised numbers above,
* or if arithmetic seems to round in the IEEE style, determined
* in routine DLAMC1. A true IEEE machine should have both things
* true; however, faulty machines may have one or the other.
*
IEEE = IEEE .OR. LIEEE1
*
* Compute RMIN by successive division by BETA. We could compute
* RMIN as BASE**( EMIN - 1 ), but some machines underflow during
* this computation.
*
LRMIN = 1
DO 30 I = 1, 1 - LEMIN
LRMIN = DLAMC3( LRMIN*RBASE, ZERO )
30 CONTINUE
*
* Finally, call DLAMC5 to compute EMAX and RMAX.
*
CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX )
END IF
*
BETA = LBETA
T = LT
RND = LRND
EPS = LEPS
EMIN = LEMIN
RMIN = LRMIN
EMAX = LEMAX
RMAX = LRMAX
*
RETURN
*
9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-',
$ ' EMIN = ', I8, /
$ ' If, after inspection, the value EMIN looks',
$ ' acceptable please comment out ',
$ / ' the IF block as marked within the code of routine',
$ ' DLAMC2,', / ' otherwise supply EMIN explicitly.', / )
*
* End of DLAMC2
*
END
*
************************************************************************
*
DOUBLE PRECISION FUNCTION DLAMC3( A, B )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
DOUBLE PRECISION A, B
* ..
*
* Purpose
* =======
*
* DLAMC3 is intended to force A and B to be stored prior to doing
* the addition of A and B , for use in situations where optimizers
* might hold one of these in a register.
*
* Arguments
* =========
*
* A (input) DOUBLE PRECISION
* B (input) DOUBLE PRECISION
* The values A and B.
*
* =====================================================================
*
* .. Executable Statements ..
*
DLAMC3 = A + B
*
RETURN
*
* End of DLAMC3
*
END
*
************************************************************************
*
SUBROUTINE DLAMC4( EMIN, START, BASE )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER BASE, EMIN
DOUBLE PRECISION START
* ..
*
* Purpose
* =======
*
* DLAMC4 is a service routine for DLAMC2.
*
* Arguments
* =========
*
* EMIN (output) INTEGER
* The minimum exponent before (gradual) underflow, computed by
* setting A = START and dividing by BASE until the previous A
* can not be recovered.
*
* START (input) DOUBLE PRECISION
* The starting point for determining EMIN.
*
* BASE (input) INTEGER
* The base of the machine.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I
DOUBLE PRECISION A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMC3
EXTERNAL DLAMC3
* ..
* .. Executable Statements ..
*
A = START
ONE = 1
RBASE = ONE / BASE
ZERO = 0
EMIN = 1
B1 = DLAMC3( A*RBASE, ZERO )
C1 = A
C2 = A
D1 = A
D2 = A
*+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND.
* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP
10 CONTINUE
IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND.
$ ( D2.EQ.A ) ) THEN
EMIN = EMIN - 1
A = B1
B1 = DLAMC3( A / BASE, ZERO )
C1 = DLAMC3( B1*BASE, ZERO )
D1 = ZERO
DO 20 I = 1, BASE
D1 = D1 + B1
20 CONTINUE
B2 = DLAMC3( A*RBASE, ZERO )
C2 = DLAMC3( B2 / RBASE, ZERO )
D2 = ZERO
DO 30 I = 1, BASE
D2 = D2 + B2
30 CONTINUE
GO TO 10
END IF
*+ END WHILE
*
RETURN
*
* End of DLAMC4
*
END
*
************************************************************************
*
SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL IEEE
INTEGER BETA, EMAX, EMIN, P
DOUBLE PRECISION RMAX
* ..
*
* Purpose
* =======
*
* DLAMC5 attempts to compute RMAX, the largest machine floating-point
* number, without overflow. It assumes that EMAX + abs(EMIN) sum
* approximately to a power of 2. It will fail on machines where this
* assumption does not hold, for example, the Cyber 205 (EMIN = -28625,
* EMAX = 28718). It will also fail if the value supplied for EMIN is
* too large (i.e. too close to zero), probably with overflow.
*
* Arguments
* =========
*
* BETA (input) INTEGER
* The base of floating-point arithmetic.
*
* P (input) INTEGER
* The number of base BETA digits in the mantissa of a
* floating-point value.
*
* EMIN (input) INTEGER
* The minimum exponent before (gradual) underflow.
*
* IEEE (input) LOGICAL
* A logical flag specifying whether or not the arithmetic
* system is thought to comply with the IEEE standard.
*
* EMAX (output) INTEGER
* The largest exponent before overflow
*
* RMAX (output) DOUBLE PRECISION
* The largest machine floating-point number.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP
DOUBLE PRECISION OLDY, RECBAS, Y, Z
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMC3
EXTERNAL DLAMC3
* ..
* .. Intrinsic Functions ..
INTRINSIC MOD
* ..
* .. Executable Statements ..
*
* First compute LEXP and UEXP, two powers of 2 that bound
* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum
* approximately to the bound that is closest to abs(EMIN).
* (EMAX is the exponent of the required number RMAX).
*
LEXP = 1
EXBITS = 1
10 CONTINUE
TRY = LEXP*2
IF( TRY.LE.( -EMIN ) ) THEN
LEXP = TRY
EXBITS = EXBITS + 1
GO TO 10
END IF
IF( LEXP.EQ.-EMIN ) THEN
UEXP = LEXP
ELSE
UEXP = TRY
EXBITS = EXBITS + 1
END IF
*
* Now -LEXP is less than or equal to EMIN, and -UEXP is greater
* than or equal to EMIN. EXBITS is the number of bits needed to
* store the exponent.
*
IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN
EXPSUM = 2*LEXP
ELSE
EXPSUM = 2*UEXP
END IF
*
* EXPSUM is the exponent range, approximately equal to
* EMAX - EMIN + 1 .
*
EMAX = EXPSUM + EMIN - 1
NBITS = 1 + EXBITS + P
*
* NBITS is the total number of bits needed to store a
* floating-point number.
*
IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN
*
* Either there are an odd number of bits used to store a
* floating-point number, which is unlikely, or some bits are
* not used in the representation of numbers, which is possible,
* (e.g. Cray machines) or the mantissa has an implicit bit,
* (e.g. IEEE machines, Dec Vax machines), which is perhaps the
* most likely. We have to assume the last alternative.
* If this is true, then we need to reduce EMAX by one because
* there must be some way of representing zero in an implicit-bit
* system. On machines like Cray, we are reducing EMAX by one
* unnecessarily.
*
EMAX = EMAX - 1
END IF
*
IF( IEEE ) THEN
*
* Assume we are on an IEEE machine which reserves one exponent
* for infinity and NaN.
*
EMAX = EMAX - 1
END IF
*
* Now create RMAX, the largest machine number, which should
* be equal to (1.0 - BETA**(-P)) * BETA**EMAX .
*
* First compute 1.0 - BETA**(-P), being careful that the
* result is less than 1.0 .
*
RECBAS = ONE / BETA
Z = BETA - ONE
Y = ZERO
DO 20 I = 1, P
Z = Z*RECBAS
IF( Y.LT.ONE )
$ OLDY = Y
Y = DLAMC3( Y, Z )
20 CONTINUE
IF( Y.GE.ONE )
$ Y = OLDY
*
* Now multiply by BETA**EMAX to get RMAX.
*
DO 30 I = 1, EMAX
Y = DLAMC3( Y*BETA, ZERO )
30 CONTINUE
*
RMAX = Y
RETURN
*
* End of DLAMC5
*
END
DOUBLE PRECISION FUNCTION DSECND( )
*
* -- LAPACK auxiliary routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* February 2007
*
* Purpose
* =======
*
* DSECND returns the user time for a process in seconds.
* This version gets the time from the EXTERNAL system function ETIME.
*
* =====================================================================
*
* .. Local Scalars ..
REAL T1
* ..
* .. Local Arrays ..
REAL TARRAY( 2 )
* ..
* .. External Functions ..
REAL ETIME
EXTERNAL ETIME
* ..
* .. Executable Statements ..
*
T1 = ETIME( TARRAY )
DSECND = TARRAY( 1 )
RETURN
*
* End of DSECND
*
END
LOGICAL FUNCTION LSAME( CA, CB )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER CA, CB
* ..
*
* Purpose
* =======
*
* LSAME returns .TRUE. if CA is the same letter as CB regardless of
* case.
*
* Arguments
* =========
*
* CA (input) CHARACTER*1
* CB (input) CHARACTER*1
* CA and CB specify the single characters to be compared.
*
* =====================================================================
*
* .. Intrinsic Functions ..
INTRINSIC ICHAR
* ..
* .. Local Scalars ..
INTEGER INTA, INTB, ZCODE
* ..
* .. Executable Statements ..
*
* 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
REAL FUNCTION SECOND( )
*
* -- LAPACK auxiliary routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* February 2007
*
* Purpose
* =======
*
* SECOND returns the user time for a process in seconds.
* This version gets the time from the EXTERNAL system function ETIME.
*
* =====================================================================
*
* .. Local Scalars ..
REAL T1
* ..
* .. Local Arrays ..
REAL TARRAY( 2 )
* ..
* .. External Functions ..
REAL ETIME
EXTERNAL ETIME
* ..
* .. Executable Statements ..
*
T1 = ETIME( TARRAY )
SECOND = TARRAY( 1 )
RETURN
*
* End of SECOND
*
END
REAL FUNCTION SLAMCH( CMACH )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER CMACH
* ..
*
* Purpose
* =======
*
* SLAMCH determines single precision machine parameters.
*
* Arguments
* =========
*
* CMACH (input) CHARACTER*1
* Specifies the value to be returned by SLAMCH:
* = 'E' or 'e', SLAMCH := eps
* = 'S' or 's , SLAMCH := sfmin
* = 'B' or 'b', SLAMCH := base
* = 'P' or 'p', SLAMCH := eps*base
* = 'N' or 'n', SLAMCH := t
* = 'R' or 'r', SLAMCH := rnd
* = 'M' or 'm', SLAMCH := emin
* = 'U' or 'u', SLAMCH := rmin
* = 'L' or 'l', SLAMCH := emax
* = 'O' or 'o', SLAMCH := 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 ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL FIRST, LRND
INTEGER BETA, IMAX, IMIN, IT
REAL BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN,
$ RND, SFMIN, SMALL, T
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SLAMC2
* ..
* .. Save statement ..
SAVE FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN,
$ EMAX, RMAX, PREC
* ..
* .. Data statements ..
DATA FIRST / .TRUE. /
* ..
* .. Executable Statements ..
*
IF( FIRST ) THEN
CALL SLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX )
BASE = BETA
T = IT
IF( LRND ) THEN
RND = ONE
EPS = ( BASE**( 1-IT ) ) / 2
ELSE
RND = ZERO
EPS = BASE**( 1-IT )
END IF
PREC = EPS*BASE
EMIN = IMIN
EMAX = IMAX
SFMIN = RMIN
SMALL = ONE / RMAX
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
END IF
*
IF( LSAME( CMACH, 'E' ) ) THEN
RMACH = EPS
ELSE IF( LSAME( CMACH, 'S' ) ) THEN
RMACH = SFMIN
ELSE IF( LSAME( CMACH, 'B' ) ) THEN
RMACH = BASE
ELSE IF( LSAME( CMACH, 'P' ) ) THEN
RMACH = PREC
ELSE IF( LSAME( CMACH, 'N' ) ) THEN
RMACH = T
ELSE IF( LSAME( CMACH, 'R' ) ) THEN
RMACH = RND
ELSE IF( LSAME( CMACH, 'M' ) ) THEN
RMACH = EMIN
ELSE IF( LSAME( CMACH, 'U' ) ) THEN
RMACH = RMIN
ELSE IF( LSAME( CMACH, 'L' ) ) THEN
RMACH = EMAX
ELSE IF( LSAME( CMACH, 'O' ) ) THEN
RMACH = RMAX
END IF
*
SLAMCH = RMACH
FIRST = .FALSE.
RETURN
*
* End of SLAMCH
*
END
*
************************************************************************
*
SUBROUTINE SLAMC1( BETA, T, RND, IEEE1 )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL IEEE1, RND
INTEGER BETA, T
* ..
*
* Purpose
* =======
*
* SLAMC1 determines the machine parameters given by BETA, T, RND, and
* IEEE1.
*
* Arguments
* =========
*
* BETA (output) INTEGER
* The base of the machine.
*
* T (output) INTEGER
* The number of ( BETA ) digits in the mantissa.
*
* RND (output) LOGICAL
* Specifies whether proper rounding ( RND = .TRUE. ) or
* chopping ( RND = .FALSE. ) occurs in addition. This may not
* be a reliable guide to the way in which the machine performs
* its arithmetic.
*
* IEEE1 (output) LOGICAL
* Specifies whether rounding appears to be done in the IEEE
* 'round to nearest' style.
*
* Further Details
* ===============
*
* The routine is based on the routine ENVRON by Malcolm and
* incorporates suggestions by Gentleman and Marovich. See
*
* Malcolm M. A. (1972) Algorithms to reveal properties of
* floating-point arithmetic. Comms. of the ACM, 15, 949-951.
*
* Gentleman W. M. and Marovich S. B. (1974) More on algorithms
* that reveal properties of floating point arithmetic units.
* Comms. of the ACM, 17, 276-277.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL FIRST, LIEEE1, LRND
INTEGER LBETA, LT
REAL A, B, C, F, ONE, QTR, SAVEC, T1, T2
* ..
* .. External Functions ..
REAL SLAMC3
EXTERNAL SLAMC3
* ..
* .. Save statement ..
SAVE FIRST, LIEEE1, LBETA, LRND, LT
* ..
* .. Data statements ..
DATA FIRST / .TRUE. /
* ..
* .. Executable Statements ..
*
IF( FIRST ) THEN
ONE = 1
*
* LBETA, LIEEE1, LT and LRND are the local values of BETA,
* IEEE1, T and RND.
*
* Throughout this routine we use the function SLAMC3 to ensure
* that relevant values are stored and not held in registers, or
* are not affected by optimizers.
*
* Compute a = 2.0**m with the smallest positive integer m such
* that
*
* fl( a + 1.0 ) = a.
*
A = 1
C = 1
*
*+ WHILE( C.EQ.ONE )LOOP
10 CONTINUE
IF( C.EQ.ONE ) THEN
A = 2*A
C = SLAMC3( A, ONE )
C = SLAMC3( C, -A )
GO TO 10
END IF
*+ END WHILE
*
* Now compute b = 2.0**m with the smallest positive integer m
* such that
*
* fl( a + b ) .gt. a.
*
B = 1
C = SLAMC3( A, B )
*
*+ WHILE( C.EQ.A )LOOP
20 CONTINUE
IF( C.EQ.A ) THEN
B = 2*B
C = SLAMC3( A, B )
GO TO 20
END IF
*+ END WHILE
*
* Now compute the base. a and c are neighbouring floating point
* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so
* their difference is beta. Adding 0.25 to c is to ensure that it
* is truncated to beta and not ( beta - 1 ).
*
QTR = ONE / 4
SAVEC = C
C = SLAMC3( C, -A )
LBETA = C + QTR
*
* Now determine whether rounding or chopping occurs, by adding a
* bit less than beta/2 and a bit more than beta/2 to a.
*
B = LBETA
F = SLAMC3( B / 2, -B / 100 )
C = SLAMC3( F, A )
IF( C.EQ.A ) THEN
LRND = .TRUE.
ELSE
LRND = .FALSE.
END IF
F = SLAMC3( B / 2, B / 100 )
C = SLAMC3( F, A )
IF( ( LRND ) .AND. ( C.EQ.A ) )
$ LRND = .FALSE.
*
* Try and decide whether rounding is done in the IEEE 'round to
* nearest' style. B/2 is half a unit in the last place of the two
* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit
* zero, and SAVEC is odd. Thus adding B/2 to A should not change
* A, but adding B/2 to SAVEC should change SAVEC.
*
T1 = SLAMC3( B / 2, A )
T2 = SLAMC3( B / 2, SAVEC )
LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND
*
* Now find the mantissa, t. It should be the integer part of
* log to the base beta of a, however it is safer to determine t
* by powering. So we find t as the smallest positive integer for
* which
*
* fl( beta**t + 1.0 ) = 1.0.
*
LT = 0
A = 1
C = 1
*
*+ WHILE( C.EQ.ONE )LOOP
30 CONTINUE
IF( C.EQ.ONE ) THEN
LT = LT + 1
A = A*LBETA
C = SLAMC3( A, ONE )
C = SLAMC3( C, -A )
GO TO 30
END IF
*+ END WHILE
*
END IF
*
BETA = LBETA
T = LT
RND = LRND
IEEE1 = LIEEE1
FIRST = .FALSE.
RETURN
*
* End of SLAMC1
*
END
*
************************************************************************
*
SUBROUTINE SLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL RND
INTEGER BETA, EMAX, EMIN, T
REAL EPS, RMAX, RMIN
* ..
*
* Purpose
* =======
*
* SLAMC2 determines the machine parameters specified in its argument
* list.
*
* Arguments
* =========
*
* BETA (output) INTEGER
* The base of the machine.
*
* T (output) INTEGER
* The number of ( BETA ) digits in the mantissa.
*
* RND (output) LOGICAL
* Specifies whether proper rounding ( RND = .TRUE. ) or
* chopping ( RND = .FALSE. ) occurs in addition. This may not
* be a reliable guide to the way in which the machine performs
* its arithmetic.
*
* EPS (output) REAL
* The smallest positive number such that
*
* fl( 1.0 - EPS ) .LT. 1.0,
*
* where fl denotes the computed value.
*
* EMIN (output) INTEGER
* The minimum exponent before (gradual) underflow occurs.
*
* RMIN (output) REAL
* The smallest normalized number for the machine, given by
* BASE**( EMIN - 1 ), where BASE is the floating point value
* of BETA.
*
* EMAX (output) INTEGER
* The maximum exponent before overflow occurs.
*
* RMAX (output) REAL
* The largest positive number for the machine, given by
* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point
* value of BETA.
*
* Further Details
* ===============
*
* The computation of EPS is based on a routine PARANOIA by
* W. Kahan of the University of California at Berkeley.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND
INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT,
$ NGNMIN, NGPMIN
REAL A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE,
$ SIXTH, SMALL, THIRD, TWO, ZERO
* ..
* .. External Functions ..
REAL SLAMC3
EXTERNAL SLAMC3
* ..
* .. External Subroutines ..
EXTERNAL SLAMC1, SLAMC4, SLAMC5
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Save statement ..
SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX,
$ LRMIN, LT
* ..
* .. Data statements ..
DATA FIRST / .TRUE. / , IWARN / .FALSE. /
* ..
* .. Executable Statements ..
*
IF( FIRST ) THEN
ZERO = 0
ONE = 1
TWO = 2
*
* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of
* BETA, T, RND, EPS, EMIN and RMIN.
*
* Throughout this routine we use the function SLAMC3 to ensure
* that relevant values are stored and not held in registers, or
* are not affected by optimizers.
*
* SLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1.
*
CALL SLAMC1( LBETA, LT, LRND, LIEEE1 )
*
* Start to find EPS.
*
B = LBETA
A = B**( -LT )
LEPS = A
*
* Try some tricks to see whether or not this is the correct EPS.
*
B = TWO / 3
HALF = ONE / 2
SIXTH = SLAMC3( B, -HALF )
THIRD = SLAMC3( SIXTH, SIXTH )
B = SLAMC3( THIRD, -HALF )
B = SLAMC3( B, SIXTH )
B = ABS( B )
IF( B.LT.LEPS )
$ B = LEPS
*
LEPS = 1
*
*+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP
10 CONTINUE
IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN
LEPS = B
C = SLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) )
C = SLAMC3( HALF, -C )
B = SLAMC3( HALF, C )
C = SLAMC3( HALF, -B )
B = SLAMC3( HALF, C )
GO TO 10
END IF
*+ END WHILE
*
IF( A.LT.LEPS )
$ LEPS = A
*
* Computation of EPS complete.
*
* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)).
* Keep dividing A by BETA until (gradual) underflow occurs. This
* is detected when we cannot recover the previous A.
*
RBASE = ONE / LBETA
SMALL = ONE
DO 20 I = 1, 3
SMALL = SLAMC3( SMALL*RBASE, ZERO )
20 CONTINUE
A = SLAMC3( ONE, SMALL )
CALL SLAMC4( NGPMIN, ONE, LBETA )
CALL SLAMC4( NGNMIN, -ONE, LBETA )
CALL SLAMC4( GPMIN, A, LBETA )
CALL SLAMC4( GNMIN, -A, LBETA )
IEEE = .FALSE.
*
IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN
IF( NGPMIN.EQ.GPMIN ) THEN
LEMIN = NGPMIN
* ( Non twos-complement machines, no gradual underflow;
* e.g., VAX )
ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN
LEMIN = NGPMIN - 1 + LT
IEEE = .TRUE.
* ( Non twos-complement machines, with gradual underflow;
* e.g., IEEE standard followers )
ELSE
LEMIN = MIN( NGPMIN, GPMIN )
* ( A guess; no known machine )
IWARN = .TRUE.
END IF
*
ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN
IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN
LEMIN = MAX( NGPMIN, NGNMIN )
* ( Twos-complement machines, no gradual underflow;
* e.g., CYBER 205 )
ELSE
LEMIN = MIN( NGPMIN, NGNMIN )
* ( A guess; no known machine )
IWARN = .TRUE.
END IF
*
ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND.
$ ( GPMIN.EQ.GNMIN ) ) THEN
IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN
LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT
* ( Twos-complement machines with gradual underflow;
* no known machine )
ELSE
LEMIN = MIN( NGPMIN, NGNMIN )
* ( A guess; no known machine )
IWARN = .TRUE.
END IF
*
ELSE
LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN )
* ( A guess; no known machine )
IWARN = .TRUE.
END IF
FIRST = .FALSE.
***
* Comment out this if block if EMIN is ok
IF( IWARN ) THEN
FIRST = .TRUE.
WRITE( 6, FMT = 9999 )LEMIN
END IF
***
*
* Assume IEEE arithmetic if we found denormalised numbers above,
* or if arithmetic seems to round in the IEEE style, determined
* in routine SLAMC1. A true IEEE machine should have both things
* true; however, faulty machines may have one or the other.
*
IEEE = IEEE .OR. LIEEE1
*
* Compute RMIN by successive division by BETA. We could compute
* RMIN as BASE**( EMIN - 1 ), but some machines underflow during
* this computation.
*
LRMIN = 1
DO 30 I = 1, 1 - LEMIN
LRMIN = SLAMC3( LRMIN*RBASE, ZERO )
30 CONTINUE
*
* Finally, call SLAMC5 to compute EMAX and RMAX.
*
CALL SLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX )
END IF
*
BETA = LBETA
T = LT
RND = LRND
EPS = LEPS
EMIN = LEMIN
RMIN = LRMIN
EMAX = LEMAX
RMAX = LRMAX
*
RETURN
*
9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-',
$ ' EMIN = ', I8, /
$ ' If, after inspection, the value EMIN looks',
$ ' acceptable please comment out ',
$ / ' the IF block as marked within the code of routine',
$ ' SLAMC2,', / ' otherwise supply EMIN explicitly.', / )
*
* End of SLAMC2
*
END
*
************************************************************************
*
REAL FUNCTION SLAMC3( A, B )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
REAL A, B
* ..
*
* Purpose
* =======
*
* SLAMC3 is intended to force A and B to be stored prior to doing
* the addition of A and B , for use in situations where optimizers
* might hold one of these in a register.
*
* Arguments
* =========
*
* A (input) REAL
* B (input) REAL
* The values A and B.
*
* =====================================================================
*
* .. Executable Statements ..
*
SLAMC3 = A + B
*
RETURN
*
* End of SLAMC3
*
END
*
************************************************************************
*
SUBROUTINE SLAMC4( EMIN, START, BASE )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER BASE
INTEGER EMIN
REAL START
* ..
*
* Purpose
* =======
*
* SLAMC4 is a service routine for SLAMC2.
*
* Arguments
* =========
*
* EMIN (output) INTEGER
* The minimum exponent before (gradual) underflow, computed by
* setting A = START and dividing by BASE until the previous A
* can not be recovered.
*
* START (input) REAL
* The starting point for determining EMIN.
*
* BASE (input) INTEGER
* The base of the machine.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I
REAL A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO
* ..
* .. External Functions ..
REAL SLAMC3
EXTERNAL SLAMC3
* ..
* .. Executable Statements ..
*
A = START
ONE = 1
RBASE = ONE / BASE
ZERO = 0
EMIN = 1
B1 = SLAMC3( A*RBASE, ZERO )
C1 = A
C2 = A
D1 = A
D2 = A
*+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND.
* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP
10 CONTINUE
IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND.
$ ( D2.EQ.A ) ) THEN
EMIN = EMIN - 1
A = B1
B1 = SLAMC3( A / BASE, ZERO )
C1 = SLAMC3( B1*BASE, ZERO )
D1 = ZERO
DO 20 I = 1, BASE
D1 = D1 + B1
20 CONTINUE
B2 = SLAMC3( A*RBASE, ZERO )
C2 = SLAMC3( B2 / RBASE, ZERO )
D2 = ZERO
DO 30 I = 1, BASE
D2 = D2 + B2
30 CONTINUE
GO TO 10
END IF
*+ END WHILE
*
RETURN
*
* End of SLAMC4
*
END
*
************************************************************************
*
SUBROUTINE SLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL IEEE
INTEGER BETA, EMAX, EMIN, P
REAL RMAX
* ..
*
* Purpose
* =======
*
* SLAMC5 attempts to compute RMAX, the largest machine floating-point
* number, without overflow. It assumes that EMAX + abs(EMIN) sum
* approximately to a power of 2. It will fail on machines where this
* assumption does not hold, for example, the Cyber 205 (EMIN = -28625,
* EMAX = 28718). It will also fail if the value supplied for EMIN is
* too large (i.e. too close to zero), probably with overflow.
*
* Arguments
* =========
*
* BETA (input) INTEGER
* The base of floating-point arithmetic.
*
* P (input) INTEGER
* The number of base BETA digits in the mantissa of a
* floating-point value.
*
* EMIN (input) INTEGER
* The minimum exponent before (gradual) underflow.
*
* IEEE (input) LOGICAL
* A logical flag specifying whether or not the arithmetic
* system is thought to comply with the IEEE standard.
*
* EMAX (output) INTEGER
* The largest exponent before overflow
*
* RMAX (output) REAL
* The largest machine floating-point number.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP
REAL OLDY, RECBAS, Y, Z
* ..
* .. External Functions ..
REAL SLAMC3
EXTERNAL SLAMC3
* ..
* .. Intrinsic Functions ..
INTRINSIC MOD
* ..
* .. Executable Statements ..
*
* First compute LEXP and UEXP, two powers of 2 that bound
* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum
* approximately to the bound that is closest to abs(EMIN).
* (EMAX is the exponent of the required number RMAX).
*
LEXP = 1
EXBITS = 1
10 CONTINUE
TRY = LEXP*2
IF( TRY.LE.( -EMIN ) ) THEN
LEXP = TRY
EXBITS = EXBITS + 1
GO TO 10
END IF
IF( LEXP.EQ.-EMIN ) THEN
UEXP = LEXP
ELSE
UEXP = TRY
EXBITS = EXBITS + 1
END IF
*
* Now -LEXP is less than or equal to EMIN, and -UEXP is greater
* than or equal to EMIN. EXBITS is the number of bits needed to
* store the exponent.
*
IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN
EXPSUM = 2*LEXP
ELSE
EXPSUM = 2*UEXP
END IF
*
* EXPSUM is the exponent range, approximately equal to
* EMAX - EMIN + 1 .
*
EMAX = EXPSUM + EMIN - 1
NBITS = 1 + EXBITS + P
*
* NBITS is the total number of bits needed to store a
* floating-point number.
*
IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN
*
* Either there are an odd number of bits used to store a
* floating-point number, which is unlikely, or some bits are
* not used in the representation of numbers, which is possible,
* (e.g. Cray machines) or the mantissa has an implicit bit,
* (e.g. IEEE machines, Dec Vax machines), which is perhaps the
* most likely. We have to assume the last alternative.
* If this is true, then we need to reduce EMAX by one because
* there must be some way of representing zero in an implicit-bit
* system. On machines like Cray, we are reducing EMAX by one
* unnecessarily.
*
EMAX = EMAX - 1
END IF
*
IF( IEEE ) THEN
*
* Assume we are on an IEEE machine which reserves one exponent
* for infinity and NaN.
*
EMAX = EMAX - 1
END IF
*
* Now create RMAX, the largest machine number, which should
* be equal to (1.0 - BETA**(-P)) * BETA**EMAX .
*
* First compute 1.0 - BETA**(-P), being careful that the
* result is less than 1.0 .
*
RECBAS = ONE / BETA
Z = BETA - ONE
Y = ZERO
DO 20 I = 1, P
Z = Z*RECBAS
IF( Y.LT.ONE )
$ OLDY = Y
Y = SLAMC3( Y, Z )
20 CONTINUE
IF( Y.GE.ONE )
$ Y = OLDY
*
* Now multiply by BETA**EMAX to get RMAX.
*
DO 30 I = 1, EMAX
Y = SLAMC3( Y*BETA, ZERO )
30 CONTINUE
*
RMAX = Y
RETURN
*
* End of SLAMC5
*
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/Makefile_javasrc 0000644 0001750 0001750 00000001616 10616442116 022715 0 ustar osallou osallou .PHONY: lib all testers err blas lapack util
ROOT=..
include $(ROOT)/make.def
lib: util err blas lapack
all: lib testers
testers: err blas lapack
cd $(ROOT)/$(TESTING_DIR);$(MAKE) -f Makefile_javasrc
timers: err blas lapack
cd $(ROOT)/$(TIMING_DIR);$(MAKE) -f Makefile_javasrc
err:
cd $(ROOT)/$(ERR_DIR);$(MAKE) -f Makefile_javasrc
blas: util err
cd $(ROOT)/$(BLAS_DIR);$(MAKE) -f Makefile_javasrc
lapack: util err blas
cd $(ROOT)/$(LAPACK_DIR);$(MAKE) -f Makefile_javasrc
util:
cd $(ROOT)/$(UTIL_DIR);$(MAKE)
clean:
cd $(ROOT)/$(ERR_DIR);$(MAKE) -f Makefile_javasrc clean
cd $(ROOT)/$(BLAS_DIR);$(MAKE) -f Makefile_javasrc clean
cd $(ROOT)/$(LAPACK_DIR);$(MAKE) -f Makefile_javasrc clean
cd $(ROOT)/$(TESTING_DIR);$(MAKE) -f Makefile_javasrc clean
cd $(ROOT)/$(TIMING_DIR);$(MAKE) -f Makefile_javasrc clean
cd $(ROOT)/$(UTIL_DIR);$(MAKE) -f Makefile_javasrc clean
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/ 0000755 0001750 0001750 00000000000 11734055026 021031 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/Makefile 0000644 0001750 0001750 00000001201 10616163241 022460 0 ustar osallou osallou .PHONY: runtimers eigtimer lintimer clean
ROOT=../..
include $(ROOT)/make.def
timers: eigtimer lintimer seigtimer slintimer
eigtimer: $(ROOT)/$(EIGTIME_IDX)
seigtimer: $(ROOT)/$(SEIGTIME_IDX)
lintimer: $(ROOT)/$(LINTIME_IDX)
slintimer: $(ROOT)/$(SLINTIME_IDX)
$(ROOT)/$(EIGTIME_IDX):
cd eig;$(MAKE)
$(ROOT)/$(SEIGTIME_IDX):
cd seig;$(MAKE)
$(ROOT)/$(LINTIME_IDX):
cd lin;$(MAKE)
$(ROOT)/$(SLINTIME_IDX):
cd slin;$(MAKE)
runtimers:
cd eig;$(MAKE) runtimer
cd lin;$(MAKE) runtimer
cd seig;$(MAKE) runtimer
cd slin;$(MAKE) runtimer
clean:
cd eig;$(MAKE) clean
cd lin;$(MAKE) clean
cd seig;$(MAKE) clean
cd slin;$(MAKE) clean
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/seig/ 0000755 0001750 0001750 00000000000 11734055026 021760 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/seig/sseptim.in 0000644 0001750 0001750 00000001015 10616163244 023771 0 ustar osallou osallou SEP: Data file for timing Symmetric Eigenvalue Problem routines
5 Number of values of N
10 20 40 60 80 Values of N (dimension)
2 Number of values of parameters
1 16 Values of NB (blocksize)
81 81 Values of LDA (leading dimension)
0.05 Minimum time in seconds
4 Number of matrix types
SST T T T T T T T T T T T T T T T T T T T T T T T
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/seig/seigtime.f 0000644 0001750 0001750 00001734052 10616163244 023751 0 ustar osallou osallou SUBROUTINE ATIMIN( PATH, LINE, NSUBS, NAMES, TIMSUB, NOUT, INFO )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
CHARACTER*( * ) PATH
INTEGER INFO, NOUT, NSUBS
* ..
* .. Array Arguments ..
LOGICAL TIMSUB( * )
CHARACTER*( * ) NAMES( * )
* ..
*
* Purpose
* =======
*
* ATIMIN interprets the input line for the timing routines.
* The LOGICAL array TIMSUB returns .true. for each routine to be
* timed and .false. for the routines which are not to be timed.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*(*)
* The LAPACK path name of the calling routine. The path name
* may be at most 6 characters long. If LINE(1:LEN(PATH)) is
* the same as PATH, then the input line is searched for NSUBS
* non-blank characters, otherwise, the input line is assumed to
* specify a single subroutine name.
*
* LINE (input) CHARACTER*80
* The input line to be evaluated. The path or subroutine name
* must begin in column 1 and the part of the line after the
* name is used to indicate the routines to be timed.
* See below for further details.
*
* NSUBS (input) INTEGER
* The number of subroutines in the LAPACK path name of the
* calling routine.
*
* NAMES (input) CHARACTER*(*) array, dimension (NSUBS)
* The names of the subroutines in the LAPACK path name of the
* calling routine.
*
* TIMSUB (output) LOGICAL array, dimension (NSUBS)
* For each I from 1 to NSUBS, TIMSUB( I ) is set to .true. if
* the subroutine NAMES( I ) is to be timed; otherwise,
* TIMSUB( I ) is set to .false.
*
* NOUT (input) INTEGER
* The unit number on which error messages will be printed.
*
* INFO (output) INTEGER
* The return status of this routine.
* = -1: Unrecognized path or subroutine name
* = 0: Normal return
* = 1: Name was recognized, but no timing requested
*
* Further Details
* ======= =======
*
* An input line begins with a subroutine or path name, optionally
* followed by one or more non-blank characters indicating the specific
* routines to be timed.
*
* If the character string in PATH appears at the beginning of LINE,
* up to NSUBS routines may be timed. If LINE is blank after the path
* name, all the routines in the path will be timed. If LINE is not
* blank after the path name, the rest of the line is searched
* for NSUBS nonblank characters, and if the i-th such character is
* 't' or 'T', then the i-th subroutine in this path will be timed.
* For example, the input line
* SGE T T T T
* requests timing of the first 4 subroutines in the SGE path.
*
* If the character string in PATH does not appear at the beginning of
* LINE, then LINE is assumed to begin with a subroutine name. The name
* is assumed to end in column 6 or in column i if column i+1 is blank
* and i+1 <= 6. If LINE is completely blank after the subroutine name,
* the routine will be timed. If LINE is not blank after the subroutine
* name, then the subroutine will be timed if the first non-blank after
* the name is 't' or 'T'.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL REQ
CHARACTER*6 CNAME
INTEGER I, ISTART, ISTOP, ISUB, LCNAME, LNAMES, LPATH
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Intrinsic Functions ..
INTRINSIC LEN, MIN
* ..
* .. Executable Statements ..
*
*
* Initialize
*
INFO = 0
LCNAME = 1
DO 10 I = 2, 6
IF( LINE( I: I ).EQ.' ' )
$ GO TO 20
LCNAME = I
10 CONTINUE
20 CONTINUE
LPATH = MIN( LCNAME+1, LEN( PATH ) )
LNAMES = MIN( LCNAME+1, LEN( NAMES( 1 ) ) )
CNAME = LINE( 1: LCNAME )
*
DO 30 I = 1, NSUBS
TIMSUB( I ) = .FALSE.
30 CONTINUE
ISTOP = 0
*
* Check for a valid path or subroutine name.
*
IF( LCNAME.LE.LEN( PATH ) .AND. LSAMEN( LPATH, CNAME, PATH ) )
$ THEN
ISTART = 1
ISTOP = NSUBS
ELSE IF( LCNAME.LE.LEN( NAMES( 1 ) ) ) THEN
DO 40 I = 1, NSUBS
IF( LSAMEN( LNAMES, CNAME, NAMES( I ) ) ) THEN
ISTART = I
ISTOP = I
END IF
40 CONTINUE
END IF
*
IF( ISTOP.EQ.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
9999 FORMAT( 1X, A, ': Unrecognized path or subroutine name', / )
INFO = -1
GO TO 110
END IF
*
* Search the rest of the input line for 1 or NSUBS nonblank
* characters, where 'T' or 't' means 'Time this routine'.
*
ISUB = ISTART
DO 50 I = LCNAME + 1, 80
IF( LINE( I: I ).NE.' ' ) THEN
TIMSUB( ISUB ) = LSAME( LINE( I: I ), 'T' )
ISUB = ISUB + 1
IF( ISUB.GT.ISTOP )
$ GO TO 60
END IF
50 CONTINUE
60 CONTINUE
*
* If no characters appear after the routine or path name, then
* time the routine or all the routines in the path.
*
IF( ISUB.EQ.ISTART ) THEN
DO 70 I = ISTART, ISTOP
TIMSUB( I ) = .TRUE.
70 CONTINUE
ELSE
*
* Test to see if any timing was requested.
*
REQ = .FALSE.
DO 80 I = ISTART, ISUB - 1
REQ = REQ .OR. TIMSUB( I )
80 CONTINUE
IF( .NOT.REQ ) THEN
WRITE( NOUT, FMT = 9998 )CNAME
9998 FORMAT( 1X, A, ' was not timed', / )
INFO = 1
GO TO 110
END IF
90 CONTINUE
*
* If fewer than NSUBS characters are specified for a path name,
* the rest are assumed to be 'F'.
*
DO 100 I = ISUB, ISTOP
TIMSUB( I ) = .FALSE.
100 CONTINUE
END IF
110 CONTINUE
RETURN
*
* End of ATIMIN
*
END
SUBROUTINE CDIV(AR,AI,BR,BI,CR,CI)
REAL AR,AI,BR,BI,CR,CI
C
C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
C
REAL S,ARS,AIS,BRS,BIS
S = ABS(BR) + ABS(BI)
ARS = AR/S
AIS = AI/S
BRS = BR/S
BIS = BI/S
S = BRS**2 + BIS**2
CR = (ARS*BRS + AIS*BIS)/S
CI = (AIS*BRS - ARS*BIS)/S
RETURN
END
REAL FUNCTION EPSLON (X)
REAL X
C
C ESTIMATE UNIT ROUNDOFF IN QUANTITIES OF SIZE X.
C
REAL A,B,C,EPS
C
C THIS PROGRAM SHOULD FUNCTION PROPERLY ON ALL SYSTEMS
C SATISFYING THE FOLLOWING TWO ASSUMPTIONS,
C 1. THE BASE USED IN REPRESENTING FLOATING POINT
C NUMBERS IS NOT A POWER OF THREE.
C 2. THE QUANTITY A IN STATEMENT 10 IS REPRESENTED TO
C THE ACCURACY USED IN FLOATING POINT VARIABLES
C THAT ARE STORED IN MEMORY.
C THE STATEMENT NUMBER 10 AND THE GO TO 10 ARE INTENDED TO
C FORCE OPTIMIZING COMPILERS TO GENERATE CODE SATISFYING
C ASSUMPTION 2.
C UNDER THESE ASSUMPTIONS, IT SHOULD BE TRUE THAT,
C A IS NOT EXACTLY EQUAL TO FOUR-THIRDS,
C B HAS A ZERO FOR ITS LAST BIT OR DIGIT,
C C IS NOT EXACTLY EQUAL TO ONE,
C EPS MEASURES THE SEPARATION OF 1.0 FROM
C THE NEXT LARGER FLOATING POINT NUMBER.
C THE DEVELOPERS OF EISPACK WOULD APPRECIATE BEING INFORMED
C ABOUT ANY SYSTEMS WHERE THESE ASSUMPTIONS DO NOT HOLD.
C
C THIS VERSION DATED 4/6/83.
C
A = 4.0E0/3.0E0
10 B = A - 1.0E0
C = B + B + B
EPS = ABS(C-1.0E0)
IF (EPS .EQ. 0.0E0) GO TO 10
EPSLON = EPS*ABS(X)
RETURN
END
SUBROUTINE HQR(NM,N,LOW,IGH,H,WR,WI,IERR)
C
INTEGER I,J,K,L,M,N,EN,LL,MM,NA,NM,IGH,ITN,ITS,LOW,MP2,ENM2,IERR
REAL H(NM,N),WR(N),WI(N)
REAL P,Q,R,S,T,W,X,Y,ZZ,NORM,TST1,TST2
LOGICAL NOTLAS
*
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT
* ITCNT IS INITIALIZED TO 0, OPS IS ONLY INCREMENTED
* OPST IS USED TO ACCUMULATE SMALL CONTRIBUTIONS TO OPS
* TO AVOID ROUNDOFF ERROR
* .. COMMON BLOCKS ..
COMMON /LATIME/ OPS, ITCNT
* ..
* .. SCALARS IN COMMON ..
REAL OPS, ITCNT, OPST
* ..
C
C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR,
C NUM. MATH. 14, 219-231(1970) BY MARTIN, PETERS, AND WILKINSON.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 359-371(1971).
C
C THIS SUBROUTINE FINDS THE EIGENVALUES OF A REAL
C UPPER HESSENBERG MATRIX BY THE QR METHOD.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRIX.
C
C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED,
C SET LOW=1, IGH=N.
C
C H CONTAINS THE UPPER HESSENBERG MATRIX. INFORMATION ABOUT
C THE TRANSFORMATIONS USED IN THE REDUCTION TO HESSENBERG
C FORM BY ELMHES OR ORTHES, IF PERFORMED, IS STORED
C IN THE REMAINING TRIANGLE UNDER THE HESSENBERG MATRIX.
C
C ON OUTPUT
C
C H HAS BEEN DESTROYED. THEREFORE, IT MUST BE SAVED
C BEFORE CALLING HQR IF SUBSEQUENT CALCULATION AND
C BACK TRANSFORMATION OF EIGENVECTORS IS TO BE PERFORMED.
C
C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
C RESPECTIVELY, OF THE EIGENVALUES. THE EIGENVALUES
C ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS
C OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE
C HAVING THE POSITIVE IMAGINARY PART FIRST. IF AN
C ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
C FOR INDICES IERR+1,...,N.
C
C IERR IS SET TO
C ZERO FOR NORMAL RETURN,
C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C MODIFIED ON 11/1/89; ADJUSTING INDICES OF LOOPS
C 200, 210, 230, AND 240 TO INCREASE PERFORMANCE. JACK DONGARRA
C
C ------------------------------------------------------------------
C
*
EXTERNAL SLAMCH
REAL SLAMCH, UNFL,OVFL,ULP,SMLNUM,SMALL
IF (N.LE.0) RETURN
*
*
* INITIALIZE
ITCNT = 0
OPST = 0
IERR = 0
K = 1
C .......... STORE ROOTS ISOLATED BY BALANC
C AND COMPUTE MATRIX NORM ..........
DO 50 I = 1, N
IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50
WR(I) = H(I,I)
WI(I) = 0.0E0
50 CONTINUE
*
* INCREMENT OPCOUNT FOR COMPUTING MATRIX NORM
OPS = OPS + (IGH-LOW+1)*(IGH-LOW+2)/2
*
* COMPUTE THE 1-NORM OF MATRIX H
*
NORM = 0.0E0
DO 5 J = LOW, IGH
S = 0.0E0
DO 4 I = LOW, MIN(IGH,J+1)
S = S + ABS(H(I,J))
4 CONTINUE
NORM = MAX(NORM, S)
5 CONTINUE
*
UNFL = SLAMCH( 'SAFE MINIMUM' )
OVFL = SLAMCH( 'OVERFLOW' )
ULP = SLAMCH( 'EPSILON' )*SLAMCH( 'BASE' )
SMLNUM = MAX( UNFL*( N / ULP ), N / ( ULP*OVFL ) )
SMALL = MAX( SMLNUM, ULP*NORM )
C
EN = IGH
T = 0.0E0
ITN = 30*N
C .......... SEARCH FOR NEXT EIGENVALUES ..........
60 IF (EN .LT. LOW) GO TO 1001
ITS = 0
NA = EN - 1
ENM2 = NA - 1
C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
* REPLACE SPLITTING CRITERION WITH NEW ONE AS IN LAPACK
*
70 DO 80 LL = LOW, EN
L = EN + LOW - LL
IF (L .EQ. LOW) GO TO 100
S = ABS(H(L-1,L-1)) + ABS(H(L,L))
IF (S .EQ. 0.0E0) S = NORM
IF (ABS(H(L,L-1)) .LE. MAX(ULP*S,SMALL)) GO TO 100
80 CONTINUE
C .......... FORM SHIFT ..........
100 CONTINUE
*
* INCREMENT OP COUNT FOR CONVERGENCE TEST
OPS = OPS + 2*(EN-L+1)
X = H(EN,EN)
IF (L .EQ. EN) GO TO 270
Y = H(NA,NA)
W = H(EN,NA) * H(NA,EN)
IF (L .EQ. NA) GO TO 280
IF (ITN .EQ. 0) GO TO 1000
IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130
C .......... FORM EXCEPTIONAL SHIFT ..........
*
* INCREMENT OP COUNT FOR FORMING EXCEPTIONAL SHIFT
OPS = OPS + (EN-LOW+6)
T = T + X
C
DO 120 I = LOW, EN
120 H(I,I) = H(I,I) - X
C
S = ABS(H(EN,NA)) + ABS(H(NA,ENM2))
X = 0.75E0 * S
Y = X
W = -0.4375E0 * S * S
130 ITS = ITS + 1
ITN = ITN - 1
*
* UPDATE ITERATION NUMBER
ITCNT = 30*N - ITN
C .......... LOOK FOR TWO CONSECUTIVE SMALL
C SUB-DIAGONAL ELEMENTS.
C FOR M=EN-2 STEP -1 UNTIL L DO -- ..........
* REPLACE SPLITTING CRITERION WITH NEW ONE AS IN LAPACK
DO 140 MM = L, ENM2
M = ENM2 + L - MM
ZZ = H(M,M)
R = X - ZZ
S = Y - ZZ
P = (R * S - W) / H(M+1,M) + H(M,M+1)
Q = H(M+1,M+1) - ZZ - R - S
R = H(M+2,M+1)
S = ABS(P) + ABS(Q) + ABS(R)
P = P / S
Q = Q / S
R = R / S
IF (M .EQ. L) GO TO 150
TST1 = ABS(P)*(ABS(H(M-1,M-1)) + ABS(ZZ) + ABS(H(M+1,M+1)))
TST2 = ABS(H(M,M-1))*(ABS(Q) + ABS(R))
IF ( TST2 .LE. MAX(ULP*TST1,SMALL) ) GO TO 150
140 CONTINUE
C
150 CONTINUE
*
* INCREMENT OPCOUNT FOR LOOP 140
OPST = OPST + 20*(ENM2-M+1)
MP2 = M + 2
C
DO 160 I = MP2, EN
H(I,I-2) = 0.0E0
IF (I .EQ. MP2) GO TO 160
H(I,I-3) = 0.0E0
160 CONTINUE
C .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND
C COLUMNS M TO EN ..........
*
* INCREMENT OPCOUNT FOR LOOP 260
OPST = OPST + 18*(NA-M+1)
DO 260 K = M, NA
NOTLAS = K .NE. NA
IF (K .EQ. M) GO TO 170
P = H(K,K-1)
Q = H(K+1,K-1)
R = 0.0E0
IF (NOTLAS) R = H(K+2,K-1)
X = ABS(P) + ABS(Q) + ABS(R)
IF (X .EQ. 0.0E0) GO TO 260
P = P / X
Q = Q / X
R = R / X
170 S = SIGN(SQRT(P*P+Q*Q+R*R),P)
IF (K .EQ. M) GO TO 180
H(K,K-1) = -S * X
GO TO 190
180 IF (L .NE. M) H(K,K-1) = -H(K,K-1)
190 P = P + S
X = P / S
Y = Q / S
ZZ = R / S
Q = Q / P
R = R / P
IF (NOTLAS) GO TO 225
C .......... ROW MODIFICATION ..........
*
* INCREMENT OPCOUNT
OPS = OPS + 6*(EN-K+1)
DO 200 J = K, EN
P = H(K,J) + Q * H(K+1,J)
H(K,J) = H(K,J) - P * X
H(K+1,J) = H(K+1,J) - P * Y
200 CONTINUE
C
J = MIN0(EN,K+3)
C .......... COLUMN MODIFICATION ..........
*
* INCREMENT OPCOUNT
OPS = OPS + 6*(J-L+1)
DO 210 I = L, J
P = X * H(I,K) + Y * H(I,K+1)
H(I,K) = H(I,K) - P
H(I,K+1) = H(I,K+1) - P * Q
210 CONTINUE
GO TO 255
225 CONTINUE
C .......... ROW MODIFICATION ..........
*
* INCREMENT OPCOUNT
OPS = OPS + 10*(EN-K+1)
DO 230 J = K, EN
P = H(K,J) + Q * H(K+1,J) + R * H(K+2,J)
H(K,J) = H(K,J) - P * X
H(K+1,J) = H(K+1,J) - P * Y
H(K+2,J) = H(K+2,J) - P * ZZ
230 CONTINUE
C
J = MIN0(EN,K+3)
C .......... COLUMN MODIFICATION ..........
*
* INCREMENT OPCOUNT
OPS = OPS + 10*(J-L+1)
DO 240 I = L, J
P = X * H(I,K) + Y * H(I,K+1) + ZZ * H(I,K+2)
H(I,K) = H(I,K) - P
H(I,K+1) = H(I,K+1) - P * Q
H(I,K+2) = H(I,K+2) - P * R
240 CONTINUE
255 CONTINUE
C
260 CONTINUE
C
GO TO 70
C .......... ONE ROOT FOUND ..........
270 WR(EN) = X + T
WI(EN) = 0.0E0
EN = NA
GO TO 60
C .......... TWO ROOTS FOUND ..........
280 P = (Y - X) / 2.0E0
Q = P * P + W
ZZ = SQRT(ABS(Q))
X = X + T
*
* INCREMENT OP COUNT FOR FINDING TWO ROOTS.
OPST = OPST + 8
IF (Q .LT. 0.0E0) GO TO 320
C .......... REAL PAIR ..........
ZZ = P + SIGN(ZZ,P)
WR(NA) = X + ZZ
WR(EN) = WR(NA)
IF (ZZ .NE. 0.0E0) WR(EN) = X - W / ZZ
WI(NA) = 0.0E0
WI(EN) = 0.0E0
GO TO 330
C .......... COMPLEX PAIR ..........
320 WR(NA) = X + P
WR(EN) = X + P
WI(NA) = ZZ
WI(EN) = -ZZ
330 EN = ENM2
GO TO 60
C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
C CONVERGED AFTER 30*N ITERATIONS ..........
1000 IERR = EN
1001 CONTINUE
*
* COMPUTE FINAL OP COUNT
OPS = OPS + OPST
RETURN
END
SUBROUTINE HQR2(NM,N,LOW,IGH,H,WR,WI,Z,IERR)
C
INTEGER I,J,K,L,M,N,EN,II,JJ,LL,MM,NA,NM,NN,
X IGH,ITN,ITS,LOW,MP2,ENM2,IERR
REAL H(NM,N),WR(N),WI(N),Z(NM,N)
REAL P,Q,R,S,T,W,X,Y,RA,SA,VI,VR,ZZ,NORM,TST1,TST2
LOGICAL NOTLAS
*
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT
* ITCNT IS INITIALIZED TO 0, OPS IS ONLY INCREMENTED
* OPST IS USED TO ACCUMULATE SMALL CONTRIBUTIONS TO OPS
* TO AVOID ROUNDOFF ERROR
* .. COMMON BLOCKS ..
COMMON /LATIME/ OPS, ITCNT
* ..
* .. SCALARS IN COMMON ..
REAL OPS, ITCNT, OPST
* ..
C
C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR2,
C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
C
C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
C OF A REAL UPPER HESSENBERG MATRIX BY THE QR METHOD. THE
C EIGENVECTORS OF A REAL GENERAL MATRIX CAN ALSO BE FOUND
C IF ELMHES AND ELTRAN OR ORTHES AND ORTRAN HAVE
C BEEN USED TO REDUCE THIS GENERAL MATRIX TO HESSENBERG FORM
C AND TO ACCUMULATE THE SIMILARITY TRANSFORMATIONS.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRIX.
C
C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED,
C SET LOW=1, IGH=N.
C
C H CONTAINS THE UPPER HESSENBERG MATRIX.
C
C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED BY ELTRAN
C AFTER THE REDUCTION BY ELMHES, OR BY ORTRAN AFTER THE
C REDUCTION BY ORTHES, IF PERFORMED. IF THE EIGENVECTORS
C OF THE HESSENBERG MATRIX ARE DESIRED, Z MUST CONTAIN THE
C IDENTITY MATRIX.
C
C ON OUTPUT
C
C H HAS BEEN DESTROYED.
C
C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
C RESPECTIVELY, OF THE EIGENVALUES. THE EIGENVALUES
C ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS
C OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE
C HAVING THE POSITIVE IMAGINARY PART FIRST. IF AN
C ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
C FOR INDICES IERR+1,...,N.
C
C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS.
C IF THE I-TH EIGENVALUE IS REAL, THE I-TH COLUMN OF Z
C CONTAINS ITS EIGENVECTOR. IF THE I-TH EIGENVALUE IS COMPLEX
C WITH POSITIVE IMAGINARY PART, THE I-TH AND (I+1)-TH
C COLUMNS OF Z CONTAIN THE REAL AND IMAGINARY PARTS OF ITS
C EIGENVECTOR. THE EIGENVECTORS ARE UNNORMALIZED. IF AN
C ERROR EXIT IS MADE, NONE OF THE EIGENVECTORS HAS BEEN FOUND.
C
C IERR IS SET TO
C ZERO FOR NORMAL RETURN,
C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
C
C CALLS CDIV FOR COMPLEX DIVISION.
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
*
EXTERNAL SLAMCH
REAL SLAMCH, UNFL,OVFL,ULP,SMLNUM,SMALL
IF (N.LE.0) RETURN
*
* INITIALIZE
*
ITCNT = 0
OPST = 0
C
IERR = 0
K = 1
C .......... STORE ROOTS ISOLATED BY BALANC
C AND COMPUTE MATRIX NORM ..........
DO 50 I = 1, N
IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50
WR(I) = H(I,I)
WI(I) = 0.0E0
50 CONTINUE
*
* INCREMENT OPCOUNT FOR COMPUTING MATRIX NORM
OPS = OPS + (IGH-LOW+1)*(IGH-LOW+2)/2
*
* COMPUTE THE 1-NORM OF MATRIX H
*
NORM = 0.0E0
DO 5 J = LOW, IGH
S = 0.0E0
DO 4 I = LOW, MIN(IGH,J+1)
S = S + ABS(H(I,J))
4 CONTINUE
NORM = MAX(NORM, S)
5 CONTINUE
C
UNFL = SLAMCH( 'SAFE MINIMUM' )
OVFL = SLAMCH( 'OVERFLOW' )
ULP = SLAMCH( 'EPSILON' )*SLAMCH( 'BASE' )
SMLNUM = MAX( UNFL*( N / ULP ), N / ( ULP*OVFL ) )
SMALL = MAX( SMLNUM, ULP*NORM )
C
EN = IGH
T = 0.0E0
ITN = 30*N
C .......... SEARCH FOR NEXT EIGENVALUES ..........
60 IF (EN .LT. LOW) GO TO 340
ITS = 0
NA = EN - 1
ENM2 = NA - 1
C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
* REPLACE SPLITTING CRITERION WITH NEW ONE AS IN LAPACK
*
70 DO 80 LL = LOW, EN
L = EN + LOW - LL
IF (L .EQ. LOW) GO TO 100
S = ABS(H(L-1,L-1)) + ABS(H(L,L))
IF (S .EQ. 0.0E0) S = NORM
IF ( ABS(H(L,L-1)) .LE. MAX(ULP*S,SMALL) ) GO TO 100
80 CONTINUE
C .......... FORM SHIFT ..........
100 CONTINUE
*
* INCREMENT OP COUNT FOR CONVERGENCE TEST
OPS = OPS + 2*(EN-L+1)
X = H(EN,EN)
IF (L .EQ. EN) GO TO 270
Y = H(NA,NA)
W = H(EN,NA) * H(NA,EN)
IF (L .EQ. NA) GO TO 280
IF (ITN .EQ. 0) GO TO 1000
IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130
C .......... FORM EXCEPTIONAL SHIFT ..........
*
* INCREMENT OP COUNT
OPS = OPS + (EN-LOW+6)
T = T + X
C
DO 120 I = LOW, EN
120 H(I,I) = H(I,I) - X
C
S = ABS(H(EN,NA)) + ABS(H(NA,ENM2))
X = 0.75E0 * S
Y = X
W = -0.4375E0 * S * S
130 ITS = ITS + 1
ITN = ITN - 1
*
* UPDATE ITERATION NUMBER
ITCNT = 30*N - ITN
C .......... LOOK FOR TWO CONSECUTIVE SMALL
C SUB-DIAGONAL ELEMENTS.
C FOR M=EN-2 STEP -1 UNTIL L DO -- ..........
DO 140 MM = L, ENM2
M = ENM2 + L - MM
ZZ = H(M,M)
R = X - ZZ
S = Y - ZZ
P = (R * S - W) / H(M+1,M) + H(M,M+1)
Q = H(M+1,M+1) - ZZ - R - S
R = H(M+2,M+1)
S = ABS(P) + ABS(Q) + ABS(R)
P = P / S
Q = Q / S
R = R / S
IF (M .EQ. L) GO TO 150
TST1 = ABS(P)*(ABS(H(M-1,M-1)) + ABS(ZZ) + ABS(H(M+1,M+1)))
TST2 = ABS(H(M,M-1))*(ABS(Q) + ABS(R))
IF ( TST2 .LE. MAX(ULP*TST1,SMALL) ) GO TO 150
140 CONTINUE
C
150 CONTINUE
*
* INCREMENT OPCOUNT FOR LOOP 140
OPST = OPST + 20*(ENM2-M+1)
MP2 = M + 2
C
DO 160 I = MP2, EN
H(I,I-2) = 0.0E0
IF (I .EQ. MP2) GO TO 160
H(I,I-3) = 0.0E0
160 CONTINUE
C .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND
C COLUMNS M TO EN ..........
*
* INCREMENT OPCOUNT FOR LOOP 260
OPST = OPST + 18*(NA-M+1)
DO 260 K = M, NA
NOTLAS = K .NE. NA
IF (K .EQ. M) GO TO 170
P = H(K,K-1)
Q = H(K+1,K-1)
R = 0.0E0
IF (NOTLAS) R = H(K+2,K-1)
X = ABS(P) + ABS(Q) + ABS(R)
IF (X .EQ. 0.0E0) GO TO 260
P = P / X
Q = Q / X
R = R / X
170 S = SIGN(SQRT(P*P+Q*Q+R*R),P)
IF (K .EQ. M) GO TO 180
H(K,K-1) = -S * X
GO TO 190
180 IF (L .NE. M) H(K,K-1) = -H(K,K-1)
190 P = P + S
X = P / S
Y = Q / S
ZZ = R / S
Q = Q / P
R = R / P
IF (NOTLAS) GO TO 225
C .......... ROW MODIFICATION ..........
*
* INCREMENT OP COUNT FOR LOOP 200
OPS = OPS + 6*(N-K+1)
DO 200 J = K, N
P = H(K,J) + Q * H(K+1,J)
H(K,J) = H(K,J) - P * X
H(K+1,J) = H(K+1,J) - P * Y
200 CONTINUE
C
J = MIN0(EN,K+3)
C .......... COLUMN MODIFICATION ..........
*
* INCREMENT OPCOUNT FOR LOOP 210
OPS = OPS + 6*J
DO 210 I = 1, J
P = X * H(I,K) + Y * H(I,K+1)
H(I,K) = H(I,K) - P
H(I,K+1) = H(I,K+1) - P * Q
210 CONTINUE
C .......... ACCUMULATE TRANSFORMATIONS ..........
*
* INCREMENT OPCOUNT FOR LOOP 220
OPS = OPS + 6*(IGH-LOW + 1)
DO 220 I = LOW, IGH
P = X * Z(I,K) + Y * Z(I,K+1)
Z(I,K) = Z(I,K) - P
Z(I,K+1) = Z(I,K+1) - P * Q
220 CONTINUE
GO TO 255
225 CONTINUE
C .......... ROW MODIFICATION ..........
*
* INCREMENT OPCOUNT FOR LOOP 230
OPS = OPS + 10*(N-K+1)
DO 230 J = K, N
P = H(K,J) + Q * H(K+1,J) + R * H(K+2,J)
H(K,J) = H(K,J) - P * X
H(K+1,J) = H(K+1,J) - P * Y
H(K+2,J) = H(K+2,J) - P * ZZ
230 CONTINUE
C
J = MIN0(EN,K+3)
C .......... COLUMN MODIFICATION ..........
*
* INCREMENT OPCOUNT FOR LOOP 240
OPS = OPS + 10*J
DO 240 I = 1, J
P = X * H(I,K) + Y * H(I,K+1) + ZZ * H(I,K+2)
H(I,K) = H(I,K) - P
H(I,K+1) = H(I,K+1) - P * Q
H(I,K+2) = H(I,K+2) - P * R
240 CONTINUE
C .......... ACCUMULATE TRANSFORMATIONS ..........
*
* INCREMENT OPCOUNT FOR LOOP 250
OPS = OPS + 10*(IGH-LOW+1)
DO 250 I = LOW, IGH
P = X * Z(I,K) + Y * Z(I,K+1) + ZZ * Z(I,K+2)
Z(I,K) = Z(I,K) - P
Z(I,K+1) = Z(I,K+1) - P * Q
Z(I,K+2) = Z(I,K+2) - P * R
250 CONTINUE
255 CONTINUE
C
260 CONTINUE
C
GO TO 70
C .......... ONE ROOT FOUND ..........
270 H(EN,EN) = X + T
WR(EN) = H(EN,EN)
WI(EN) = 0.0E0
EN = NA
GO TO 60
C .......... TWO ROOTS FOUND ..........
280 P = (Y - X) / 2.0E0
Q = P * P + W
ZZ = SQRT(ABS(Q))
H(EN,EN) = X + T
X = H(EN,EN)
H(NA,NA) = Y + T
IF (Q .LT. 0.0E0) GO TO 320
C .......... REAL PAIR ..........
ZZ = P + SIGN(ZZ,P)
WR(NA) = X + ZZ
WR(EN) = WR(NA)
IF (ZZ .NE. 0.0E0) WR(EN) = X - W / ZZ
WI(NA) = 0.0E0
WI(EN) = 0.0E0
X = H(EN,NA)
S = ABS(X) + ABS(ZZ)
P = X / S
Q = ZZ / S
R = SQRT(P*P+Q*Q)
P = P / R
Q = Q / R
*
* INCREMENT OP COUNT FOR FINDING TWO ROOTS.
OPST = OPST + 18
*
* INCREMENT OP COUNT FOR MODIFICATION AND ACCUMULATION
* IN LOOP 290, 300, 310
OPS = OPS + 6*(N-NA+1) + 6*EN + 6*(IGH-LOW+1)
C .......... ROW MODIFICATION ..........
DO 290 J = NA, N
ZZ = H(NA,J)
H(NA,J) = Q * ZZ + P * H(EN,J)
H(EN,J) = Q * H(EN,J) - P * ZZ
290 CONTINUE
C .......... COLUMN MODIFICATION ..........
DO 300 I = 1, EN
ZZ = H(I,NA)
H(I,NA) = Q * ZZ + P * H(I,EN)
H(I,EN) = Q * H(I,EN) - P * ZZ
300 CONTINUE
C .......... ACCUMULATE TRANSFORMATIONS ..........
DO 310 I = LOW, IGH
ZZ = Z(I,NA)
Z(I,NA) = Q * ZZ + P * Z(I,EN)
Z(I,EN) = Q * Z(I,EN) - P * ZZ
310 CONTINUE
C
GO TO 330
C .......... COMPLEX PAIR ..........
320 WR(NA) = X + P
WR(EN) = X + P
WI(NA) = ZZ
WI(EN) = -ZZ
*
* INCREMENT OP COUNT FOR FINDING COMPLEX PAIR.
OPST = OPST + 9
330 EN = ENM2
GO TO 60
C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
C VECTORS OF UPPER TRIANGULAR FORM ..........
340 IF (NORM .EQ. 0.0E0) GO TO 1001
C .......... FOR EN=N STEP -1 UNTIL 1 DO -- ..........
DO 800 NN = 1, N
EN = N + 1 - NN
P = WR(EN)
Q = WI(EN)
NA = EN - 1
IF (Q) 710, 600, 800
C .......... REAL VECTOR ..........
600 M = EN
H(EN,EN) = 1.0E0
IF (NA .EQ. 0) GO TO 800
C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
DO 700 II = 1, NA
I = EN - II
W = H(I,I) - P
R = 0.0E0
C
*
* INCREMENT OP COUNT FOR LOOP 610
OPST = OPST + 2*(EN - M+1)
DO 610 J = M, EN
610 R = R + H(I,J) * H(J,EN)
C
IF (WI(I) .GE. 0.0E0) GO TO 630
ZZ = W
S = R
GO TO 700
630 M = I
IF (WI(I) .NE. 0.0E0) GO TO 640
T = W
IF (T .NE. 0.0E0) GO TO 635
TST1 = NORM
T = TST1
632 T = 0.01E0 * T
TST2 = NORM + T
IF (TST2 .GT. TST1) GO TO 632
635 H(I,EN) = -R / T
GO TO 680
C .......... SOLVE REAL EQUATIONS ..........
640 X = H(I,I+1)
Y = H(I+1,I)
Q = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I)
T = (X * S - ZZ * R) / Q
*
* INCREMENT OP COUNT FOR SOLVING REAL EQUATION.
OPST = OPST + 13
H(I,EN) = T
IF (ABS(X) .LE. ABS(ZZ)) GO TO 650
H(I+1,EN) = (-R - W * T) / X
GO TO 680
650 H(I+1,EN) = (-S - Y * T) / ZZ
C
C .......... OVERFLOW CONTROL ..........
680 T = ABS(H(I,EN))
IF (T .EQ. 0.0E0) GO TO 700
TST1 = T
TST2 = TST1 + 1.0E0/TST1
IF (TST2 .GT. TST1) GO TO 700
*
* INCREMENT OP COUNT.
OPST = OPST + (EN-I+1)
DO 690 J = I, EN
H(J,EN) = H(J,EN)/T
690 CONTINUE
C
700 CONTINUE
C .......... END REAL VECTOR ..........
GO TO 800
C .......... COMPLEX VECTOR ..........
710 M = NA
C .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT
C EIGENVECTOR MATRIX IS TRIANGULAR ..........
IF (ABS(H(EN,NA)) .LE. ABS(H(NA,EN))) GO TO 720
H(NA,NA) = Q / H(EN,NA)
H(NA,EN) = -(H(EN,EN) - P) / H(EN,NA)
*
* INCREMENT OP COUNT.
OPST = OPST + 3
GO TO 730
720 CALL CDIV(0.0E0,-H(NA,EN),H(NA,NA)-P,Q,H(NA,NA),H(NA,EN))
*
* INCREMENT OP COUNT IF (ABS(H(EN,NA)) .LE. ABS(H(NA,EN)))
OPST = OPST + 16
730 H(EN,NA) = 0.0E0
H(EN,EN) = 1.0E0
ENM2 = NA - 1
IF (ENM2 .EQ. 0) GO TO 800
C .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- ..........
DO 795 II = 1, ENM2
I = NA - II
W = H(I,I) - P
RA = 0.0E0
SA = 0.0E0
C
*
* INCREMENT OP COUNT FOR LOOP 760
OPST = OPST + 4*(EN-M+1)
DO 760 J = M, EN
RA = RA + H(I,J) * H(J,NA)
SA = SA + H(I,J) * H(J,EN)
760 CONTINUE
C
IF (WI(I) .GE. 0.0E0) GO TO 770
ZZ = W
R = RA
S = SA
GO TO 795
770 M = I
IF (WI(I) .NE. 0.0E0) GO TO 780
CALL CDIV(-RA,-SA,W,Q,H(I,NA),H(I,EN))
*
* INCREMENT OP COUNT FOR CDIV
OPST = OPST + 16
GO TO 790
C .......... SOLVE COMPLEX EQUATIONS ..........
780 X = H(I,I+1)
Y = H(I+1,I)
VR = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I) - Q * Q
VI = (WR(I) - P) * 2.0E0 * Q
*
* INCREMENT OPCOUNT (AVERAGE) FOR SOLVING COMPLEX EQUATIONS
OPST = OPST + 42
IF (VR .NE. 0.0E0 .OR. VI .NE. 0.0E0) GO TO 784
TST1 = NORM * (ABS(W) + ABS(Q) + ABS(X)
X + ABS(Y) + ABS(ZZ))
VR = TST1
783 VR = 0.01E0 * VR
TST2 = TST1 + VR
IF (TST2 .GT. TST1) GO TO 783
784 CALL CDIV(X*R-ZZ*RA+Q*SA,X*S-ZZ*SA-Q*RA,VR,VI,
X H(I,NA),H(I,EN))
IF (ABS(X) .LE. ABS(ZZ) + ABS(Q)) GO TO 785
H(I+1,NA) = (-RA - W * H(I,NA) + Q * H(I,EN)) / X
H(I+1,EN) = (-SA - W * H(I,EN) - Q * H(I,NA)) / X
GO TO 790
785 CALL CDIV(-R-Y*H(I,NA),-S-Y*H(I,EN),ZZ,Q,
X H(I+1,NA),H(I+1,EN))
C
C .......... OVERFLOW CONTROL ..........
790 T = AMAX1(ABS(H(I,NA)), ABS(H(I,EN)))
IF (T .EQ. 0.0E0) GO TO 795
TST1 = T
TST2 = TST1 + 1.0E0/TST1
IF (TST2 .GT. TST1) GO TO 795
*
* INCREMENT OP COUNT.
OPST = OPST + 2*(EN-I+1)
DO 792 J = I, EN
H(J,NA) = H(J,NA)/T
H(J,EN) = H(J,EN)/T
792 CONTINUE
C
795 CONTINUE
C .......... END COMPLEX VECTOR ..........
800 CONTINUE
C .......... END BACK SUBSTITUTION.
C VECTORS OF ISOLATED ROOTS ..........
DO 840 I = 1, N
IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840
C
DO 820 J = I, N
820 Z(I,J) = H(I,J)
C
840 CONTINUE
C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
C VECTORS OF ORIGINAL FULL MATRIX.
C FOR J=N STEP -1 UNTIL LOW DO -- ..........
DO 880 JJ = LOW, N
J = N + LOW - JJ
M = MIN0(J,IGH)
C
*
* INCREMENT OP COUNT.
OPS = OPS + 2*(IGH-LOW+1)*(M-LOW+1)
DO 880 I = LOW, IGH
ZZ = 0.0E0
C
DO 860 K = LOW, M
860 ZZ = ZZ + Z(I,K) * H(K,J)
C
Z(I,J) = ZZ
880 CONTINUE
C
GO TO 1001
C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
C CONVERGED AFTER 30*N ITERATIONS ..........
1000 IERR = EN
1001 CONTINUE
*
* COMPUTE FINAL OP COUNT
OPS = OPS + OPST
RETURN
END
SUBROUTINE IMTQL1(N,D,E,IERR)
*
* EISPACK ROUTINE
* MODIFIED FOR COMPARISON WITH LAPACK ROUTINES.
*
* CONVERGENCE TEST WAS MODIFIED TO BE THE SAME AS IN SSTEQR.
*
C
INTEGER I,J,L,M,N,II,MML,IERR
REAL D(N),E(N)
REAL B,C,F,G,P,R,S,TST1,TST2,PYTHAG
REAL EPS, TST
REAL SLAMCH
*
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT
* ITCNT IS INITIALIZED TO 0, OPS IS ONLY INCREMENTED
* OPST IS USED TO ACCUMULATE CONTRIBUTIONS TO OPS FROM
* FUNCTION PYTHAG. IT IS PASSED TO AND FROM PYTHAG
* THROUGH COMMON BLOCK PYTHOP.
* .. COMMON BLOCKS ..
COMMON / LATIME / OPS, ITCNT
COMMON / PYTHOP / OPST
*
* .. SCALARS IN COMMON ..
REAL ITCNT, OPS, OPST
* ..
C
C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE IMTQL1,
C NUM. MATH. 12, 377-383(1968) BY MARTIN AND WILKINSON,
C AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971).
C
C THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC
C TRIDIAGONAL MATRIX BY THE IMPLICIT QL METHOD.
C
C ON INPUT
C
C N IS THE ORDER OF THE MATRIX.
C
C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
C
C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY.
C
C ON OUTPUT
C
C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN
C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND
C ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE
C THE SMALLEST EIGENVALUES.
C
C E HAS BEEN DESTROYED.
C
C IERR IS SET TO
C ZERO FOR NORMAL RETURN,
C J IF THE J-TH EIGENVALUE HAS NOT BEEN
C DETERMINED AFTER 40 ITERATIONS.
C
C CALLS PYTHAG FOR SQRT(A*A + B*B) .
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
C
IERR = 0
IF (N .EQ. 1) GO TO 1001
*
* INITIALIZE ITERATION COUNT AND OPST
ITCNT = 0
OPST = 0
*
* DETERMINE THE UNIT ROUNDOFF FOR THIS ENVIRONMENT.
*
EPS = SLAMCH( 'EPSILON' )
C
DO 100 I = 2, N
100 E(I-1) = E(I)
C
E(N) = 0.0E0
C
DO 290 L = 1, N
J = 0
C .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT ..........
105 DO 110 M = L, N
IF (M .EQ. N) GO TO 120
TST = ABS( E(M) )
IF( TST .LE. EPS * ( ABS(D(M)) + ABS(D(M+1)) ) ) GO TO 120
* TST1 = ABS(D(M)) + ABS(D(M+1))
* TST2 = TST1 + ABS(E(M))
* IF (TST2 .EQ. TST1) GO TO 120
110 CONTINUE
C
120 P = D(L)
*
* INCREMENT OPCOUNT FOR FINDING SMALL SUBDIAGONAL ELEMENT.
OPS = OPS + 2*( MIN(M,N-1)-L+1 )
IF (M .EQ. L) GO TO 215
IF (J .EQ. 40) GO TO 1000
J = J + 1
C .......... FORM SHIFT ..........
G = (D(L+1) - P) / (2.0E0 * E(L))
R = PYTHAG(G,1.0E0)
G = D(M) - P + E(L) / (G + SIGN(R,G))
*
* INCREMENT OPCOUNT FOR FORMING SHIFT.
OPS = OPS + 7
S = 1.0E0
C = 1.0E0
P = 0.0E0
MML = M - L
C .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
DO 200 II = 1, MML
I = M - II
F = S * E(I)
B = C * E(I)
R = PYTHAG(F,G)
E(I+1) = R
IF (R .EQ. 0.0E0) GO TO 210
S = F / R
C = G / R
G = D(I+1) - P
R = (D(I) - G) * S + 2.0E0 * C * B
P = S * R
D(I+1) = G + P
G = C * R - B
200 CONTINUE
C
D(L) = D(L) - P
E(L) = G
E(M) = 0.0E0
*
* INCREMENT OPCOUNT FOR INNER LOOP.
OPS = OPS + MML*14 + 1
*
* INCREMENT ITERATION COUNTER
ITCNT = ITCNT + 1
GO TO 105
C .......... RECOVER FROM UNDERFLOW ..........
210 D(I+1) = D(I+1) - P
E(M) = 0.0E0
*
* INCREMENT OPCOUNT FOR INNER LOOP, WHEN UNDERFLOW OCCURS.
OPS = OPS + 2+(II-1)*14 + 1
GO TO 105
C .......... ORDER EIGENVALUES ..........
215 IF (L .EQ. 1) GO TO 250
C .......... FOR I=L STEP -1 UNTIL 2 DO -- ..........
DO 230 II = 2, L
I = L + 2 - II
IF (P .GE. D(I-1)) GO TO 270
D(I) = D(I-1)
230 CONTINUE
C
250 I = 1
270 D(I) = P
290 CONTINUE
C
GO TO 1001
C .......... SET ERROR -- NO CONVERGENCE TO AN
C EIGENVALUE AFTER 40 ITERATIONS ..........
1000 IERR = L
1001 CONTINUE
*
* COMPUTE FINAL OP COUNT
OPS = OPS + OPST
RETURN
END
SUBROUTINE IMTQL2(NM,N,D,E,Z,IERR)
*
* EISPACK ROUTINE. MODIFIED FOR COMPARISON WITH LAPACK.
*
* CONVERGENCE TEST WAS MODIFIED TO BE THE SAME AS IN SSTEQR.
*
C
INTEGER I,J,K,L,M,N,II,NM,MML,IERR
REAL D(N),E(N),Z(NM,N)
REAL B,C,F,G,P,R,S,TST1,TST2,PYTHAG
REAL EPS, TST
REAL SLAMCH
*
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT
* ITCNT IS INITIALIZED TO 0, OPS IS ONLY INCREMENTED
* OPST IS USED TO ACCUMULATE CONTRIBUTIONS TO OPS FROM
* FUNCTION PYTHAG. IT IS PASSED TO AND FROM PYTHAG
* THROUGH COMMON BLOCK PYTHOP.
* .. COMMON BLOCKS ..
COMMON / LATIME / OPS, ITCNT
COMMON / PYTHOP / OPST
* ..
* .. SCALARS IN COMMON ..
REAL ITCNT, OPS, OPST
* ..
C
C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE IMTQL2,
C NUM. MATH. 12, 377-383(1968) BY MARTIN AND WILKINSON,
C AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971).
C
C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
C OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE IMPLICIT QL METHOD.
C THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO
C BE FOUND IF TRED2 HAS BEEN USED TO REDUCE THIS
C FULL MATRIX TO TRIDIAGONAL FORM.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRIX.
C
C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
C
C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY.
C
C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
C REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS
C OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN
C THE IDENTITY MATRIX.
C
C ON OUTPUT
C
C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN
C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT
C UNORDERED FOR INDICES 1,2,...,IERR-1.
C
C E HAS BEEN DESTROYED.
C
C Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC
C TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE,
C Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED
C EIGENVALUES.
C
C IERR IS SET TO
C ZERO FOR NORMAL RETURN,
C J IF THE J-TH EIGENVALUE HAS NOT BEEN
C DETERMINED AFTER 40 ITERATIONS.
C
C CALLS PYTHAG FOR SQRT(A*A + B*B) .
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
C
IERR = 0
IF (N .EQ. 1) GO TO 1001
*
* INITIALIZE ITERATION COUNT AND OPST
ITCNT = 0
OPST = 0
*
* DETERMINE UNIT ROUNDOFF FOR THIS MACHINE.
EPS = SLAMCH( 'EPSILON' )
C
DO 100 I = 2, N
100 E(I-1) = E(I)
C
E(N) = 0.0E0
C
DO 240 L = 1, N
J = 0
C .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT ..........
105 DO 110 M = L, N
IF (M .EQ. N) GO TO 120
* TST1 = ABS(D(M)) + ABS(D(M+1))
* TST2 = TST1 + ABS(E(M))
* IF (TST2 .EQ. TST1) GO TO 120
TST = ABS( E(M) )
IF( TST .LE. EPS * ( ABS(D(M)) + ABS(D(M+1)) ) ) GO TO 120
110 CONTINUE
C
120 P = D(L)
*
* INCREMENT OPCOUNT FOR FINDING SMALL SUBDIAGONAL ELEMENT.
OPS = OPS + 2*( MIN(M,N)-L+1 )
IF (M .EQ. L) GO TO 240
IF (J .EQ. 40) GO TO 1000
J = J + 1
C .......... FORM SHIFT ..........
G = (D(L+1) - P) / (2.0E0 * E(L))
R = PYTHAG(G,1.0E0)
G = D(M) - P + E(L) / (G + SIGN(R,G))
*
* INCREMENT OPCOUNT FOR FORMING SHIFT.
OPS = OPS + 7
S = 1.0E0
C = 1.0E0
P = 0.0E0
MML = M - L
C .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
DO 200 II = 1, MML
I = M - II
F = S * E(I)
B = C * E(I)
R = PYTHAG(F,G)
E(I+1) = R
IF (R .EQ. 0.0E0) GO TO 210
S = F / R
C = G / R
G = D(I+1) - P
R = (D(I) - G) * S + 2.0E0 * C * B
P = S * R
D(I+1) = G + P
G = C * R - B
C .......... FORM VECTOR ..........
DO 180 K = 1, N
F = Z(K,I+1)
Z(K,I+1) = S * Z(K,I) + C * F
Z(K,I) = C * Z(K,I) - S * F
180 CONTINUE
C
200 CONTINUE
C
D(L) = D(L) - P
E(L) = G
E(M) = 0.0E0
*
* INCREMENT OPCOUNT FOR INNER LOOP.
OPS = OPS + MML*( 14+6*N ) + 1
*
* INCREMENT ITERATION COUNTER
ITCNT = ITCNT + 1
GO TO 105
C .......... RECOVER FROM UNDERFLOW ..........
210 D(I+1) = D(I+1) - P
E(M) = 0.0E0
*
* INCREMENT OPCOUNT FOR INNER LOOP, WHEN UNDERFLOW OCCURS.
OPS = OPS + 2+(II-1)*(14+6*N) + 1
GO TO 105
240 CONTINUE
C .......... ORDER EIGENVALUES AND EIGENVECTORS ..........
DO 300 II = 2, N
I = II - 1
K = I
P = D(I)
C
DO 260 J = II, N
IF (D(J) .GE. P) GO TO 260
K = J
P = D(J)
260 CONTINUE
C
IF (K .EQ. I) GO TO 300
D(K) = D(I)
D(I) = P
C
DO 280 J = 1, N
P = Z(J,I)
Z(J,I) = Z(J,K)
Z(J,K) = P
280 CONTINUE
C
300 CONTINUE
C
GO TO 1001
C .......... SET ERROR -- NO CONVERGENCE TO AN
C EIGENVALUE AFTER 40 ITERATIONS ..........
1000 IERR = L
1001 CONTINUE
*
* COMPUTE FINAL OP COUNT
OPS = OPS + OPST
RETURN
END
SUBROUTINE INVIT(NM,N,A,WR,WI,SELECT,MM,M,Z,IERR,RM1,RV1,RV2)
C
INTEGER I,J,K,L,M,N,S,II,IP,MM,MP,NM,NS,N1,UK,IP1,ITS,KM1,IERR
REAL A(NM,N),WR(N),WI(N),Z(NM,MM),RM1(N,N),
X RV1(N),RV2(N)
REAL T,W,X,Y,EPS3,NORM,NORMV,GROWTO,ILAMBD,
X PYTHAG,RLAMBD,UKROOT
LOGICAL SELECT(N)
*
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT
* ITCNT IS INITIALIZED TO 0, OPS IS ONLY INCREMENTED
* OPST IS USED TO ACCUMULATE SMALL CONTRIBUTIONS TO OPS
* TO AVOID ROUNDOFF ERROR
* .. COMMON BLOCKS ..
COMMON /LATIME/ OPS, ITCNT
* ..
* .. SCALARS IN COMMON ..
REAL OPS, ITCNT, OPST
* ..
C
C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE INVIT
C BY PETERS AND WILKINSON.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971).
C
C THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A REAL UPPER
C HESSENBERG MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES,
C USING INVERSE ITERATION.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRIX.
C
C A CONTAINS THE HESSENBERG MATRIX.
C
C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, RESPECTIVELY,
C OF THE EIGENVALUES OF THE MATRIX. THE EIGENVALUES MUST BE
C STORED IN A MANNER IDENTICAL TO THAT OF SUBROUTINE HQR,
C WHICH RECOGNIZES POSSIBLE SPLITTING OF THE MATRIX.
C
C SELECT SPECIFIES THE EIGENVECTORS TO BE FOUND. THE
C EIGENVECTOR CORRESPONDING TO THE J-TH EIGENVALUE IS
C SPECIFIED BY SETTING SELECT(J) TO .TRUE..
C
C MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF
C COLUMNS REQUIRED TO STORE THE EIGENVECTORS TO BE FOUND.
C NOTE THAT TWO COLUMNS ARE REQUIRED TO STORE THE
C EIGENVECTOR CORRESPONDING TO A COMPLEX EIGENVALUE.
C
C ON OUTPUT
C
C A AND WI ARE UNALTERED.
C
C WR MAY HAVE BEEN ALTERED SINCE CLOSE EIGENVALUES ARE PERTURBED
C SLIGHTLY IN SEARCHING FOR INDEPENDENT EIGENVECTORS.
C
C SELECT MAY HAVE BEEN ALTERED. IF THE ELEMENTS CORRESPONDING
C TO A PAIR OF CONJUGATE COMPLEX EIGENVALUES WERE EACH
C INITIALLY SET TO .TRUE., THE PROGRAM RESETS THE SECOND OF
C THE TWO ELEMENTS TO .FALSE..
C
C M IS THE NUMBER OF COLUMNS ACTUALLY USED TO STORE
C THE EIGENVECTORS.
C
C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS.
C IF THE NEXT SELECTED EIGENVALUE IS REAL, THE NEXT COLUMN
C OF Z CONTAINS ITS EIGENVECTOR. IF THE EIGENVALUE IS
C COMPLEX, THE NEXT TWO COLUMNS OF Z CONTAIN THE REAL AND
C IMAGINARY PARTS OF ITS EIGENVECTOR. THE EIGENVECTORS ARE
C NORMALIZED SO THAT THE COMPONENT OF LARGEST MAGNITUDE IS 1.
C ANY VECTOR WHICH FAILS THE ACCEPTANCE TEST IS SET TO ZERO.
C
C IERR IS SET TO
C ZERO FOR NORMAL RETURN,
C -(2*N+1) IF MORE THAN MM COLUMNS OF Z ARE NECESSARY
C TO STORE THE EIGENVECTORS CORRESPONDING TO
C THE SPECIFIED EIGENVALUES.
C -K IF THE ITERATION CORRESPONDING TO THE K-TH
C VALUE FAILS,
C -(N+K) IF BOTH ERROR SITUATIONS OCCUR.
C
C RM1, RV1, AND RV2 ARE TEMPORARY STORAGE ARRAYS. NOTE THAT RM1
C IS SQUARE OF DIMENSION N BY N AND, AUGMENTED BY TWO COLUMNS
C OF Z, IS THE TRANSPOSE OF THE CORRESPONDING ALGOL B ARRAY.
C
C THE ALGOL PROCEDURE GUESSVEC APPEARS IN INVIT IN LINE.
C
C CALLS CDIV FOR COMPLEX DIVISION.
C CALLS PYTHAG FOR SQRT(A*A + B*B) .
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
*
* GET ULP FROM SLAMCH FOR NEW SMALL PERTURBATION AS IN LAPACK
EXTERNAL SLAMCH
REAL SLAMCH, ULP
IF (N.LE.0) RETURN
ULP = SLAMCH( 'EPSILON' )
C
*
* INITIALIZE
OPST = 0
IERR = 0
UK = 0
S = 1
C .......... IP = 0, REAL EIGENVALUE
C 1, FIRST OF CONJUGATE COMPLEX PAIR
C -1, SECOND OF CONJUGATE COMPLEX PAIR ..........
IP = 0
N1 = N - 1
C
DO 980 K = 1, N
IF (WI(K) .EQ. 0.0E0 .OR. IP .LT. 0) GO TO 100
IP = 1
IF (SELECT(K) .AND. SELECT(K+1)) SELECT(K+1) = .FALSE.
100 IF (.NOT. SELECT(K)) GO TO 960
IF (WI(K) .NE. 0.0E0) S = S + 1
IF (S .GT. MM) GO TO 1000
IF (UK .GE. K) GO TO 200
C .......... CHECK FOR POSSIBLE SPLITTING ..........
DO 120 UK = K, N
IF (UK .EQ. N) GO TO 140
IF (A(UK+1,UK) .EQ. 0.0E0) GO TO 140
120 CONTINUE
C .......... COMPUTE INFINITY NORM OF LEADING UK BY UK
C (HESSENBERG) MATRIX ..........
140 NORM = 0.0E0
MP = 1
C
*
* INCREMENT OPCOUNT FOR COMPUTING MATRIX NORM
OPS = OPS + UK*(UK-1)/2
DO 180 I = 1, UK
X = 0.0E0
C
DO 160 J = MP, UK
160 X = X + ABS(A(I,J))
C
IF (X .GT. NORM) NORM = X
MP = I
180 CONTINUE
C .......... EPS3 REPLACES ZERO PIVOT IN DECOMPOSITION
C AND CLOSE ROOTS ARE MODIFIED BY EPS3 ..........
IF (NORM .EQ. 0.0E0) NORM = 1.0E0
* EPS3 = EPSLON(NORM)
*
* INCREMENT OPCOUNT
OPST = OPST + 3
EPS3 = NORM*ULP
C .......... GROWTO IS THE CRITERION FOR THE GROWTH ..........
UKROOT = UK
UKROOT = SQRT(UKROOT)
GROWTO = 0.1E0 / UKROOT
200 RLAMBD = WR(K)
ILAMBD = WI(K)
IF (K .EQ. 1) GO TO 280
KM1 = K - 1
GO TO 240
C .......... PERTURB EIGENVALUE IF IT IS CLOSE
C TO ANY PREVIOUS EIGENVALUE ..........
220 RLAMBD = RLAMBD + EPS3
C .......... FOR I=K-1 STEP -1 UNTIL 1 DO -- ..........
240 DO 260 II = 1, KM1
I = K - II
IF (SELECT(I) .AND. ABS(WR(I)-RLAMBD) .LT. EPS3 .AND.
X ABS(WI(I)-ILAMBD) .LT. EPS3) GO TO 220
260 CONTINUE
*
* INCREMENT OPCOUNT FOR LOOP 260 (ASSUME THAT ALL EIGENVALUES
* ARE DIFFERENT)
OPST = OPST + 2*(K-1)
C
WR(K) = RLAMBD
C .......... PERTURB CONJUGATE EIGENVALUE TO MATCH ..........
IP1 = K + IP
WR(IP1) = RLAMBD
C .......... FORM UPPER HESSENBERG A-RLAMBD*I (TRANSPOSED)
C AND INITIAL REAL VECTOR ..........
280 MP = 1
C
*
* INCREMENT OP COUNT FOR LOOP 320
OPS = OPS + UK
DO 320 I = 1, UK
C
DO 300 J = MP, UK
300 RM1(J,I) = A(I,J)
C
RM1(I,I) = RM1(I,I) - RLAMBD
MP = I
RV1(I) = EPS3
320 CONTINUE
C
ITS = 0
IF (ILAMBD .NE. 0.0E0) GO TO 520
C .......... REAL EIGENVALUE.
C TRIANGULAR DECOMPOSITION WITH INTERCHANGES,
C REPLACING ZERO PIVOTS BY EPS3 ..........
IF (UK .EQ. 1) GO TO 420
C
*
* INCREMENT OPCOUNT LU DECOMPOSITION
OPS = OPS + (UK-1)*(UK+2)
DO 400 I = 2, UK
MP = I - 1
IF (ABS(RM1(MP,I)) .LE. ABS(RM1(MP,MP))) GO TO 360
C
DO 340 J = MP, UK
Y = RM1(J,I)
RM1(J,I) = RM1(J,MP)
RM1(J,MP) = Y
340 CONTINUE
C
360 IF (RM1(MP,MP) .EQ. 0.0E0) RM1(MP,MP) = EPS3
X = RM1(MP,I) / RM1(MP,MP)
IF (X .EQ. 0.0E0) GO TO 400
C
DO 380 J = I, UK
380 RM1(J,I) = RM1(J,I) - X * RM1(J,MP)
C
400 CONTINUE
C
420 IF (RM1(UK,UK) .EQ. 0.0E0) RM1(UK,UK) = EPS3
C .......... BACK SUBSTITUTION FOR REAL VECTOR
C FOR I=UK STEP -1 UNTIL 1 DO -- ..........
440 DO 500 II = 1, UK
I = UK + 1 - II
Y = RV1(I)
IF (I .EQ. UK) GO TO 480
IP1 = I + 1
C
DO 460 J = IP1, UK
460 Y = Y - RM1(J,I) * RV1(J)
C
480 RV1(I) = Y / RM1(I,I)
500 CONTINUE
*
* INCREMENT OP COUNT FOR BACK SUBSTITUTION LOOP 500
OPS = OPS + UK*(UK+1)
C
GO TO 740
C .......... COMPLEX EIGENVALUE.
C TRIANGULAR DECOMPOSITION WITH INTERCHANGES,
C REPLACING ZERO PIVOTS BY EPS3. STORE IMAGINARY
C PARTS IN UPPER TRIANGLE STARTING AT (1,3) ..........
520 NS = N - S
Z(1,S-1) = -ILAMBD
Z(1,S) = 0.0E0
IF (N .EQ. 2) GO TO 550
RM1(1,3) = -ILAMBD
Z(1,S-1) = 0.0E0
IF (N .EQ. 3) GO TO 550
C
DO 540 I = 4, N
540 RM1(1,I) = 0.0E0
C
550 DO 640 I = 2, UK
MP = I - 1
W = RM1(MP,I)
IF (I .LT. N) T = RM1(MP,I+1)
IF (I .EQ. N) T = Z(MP,S-1)
X = RM1(MP,MP) * RM1(MP,MP) + T * T
IF (W * W .LE. X) GO TO 580
X = RM1(MP,MP) / W
Y = T / W
RM1(MP,MP) = W
IF (I .LT. N) RM1(MP,I+1) = 0.0E0
IF (I .EQ. N) Z(MP,S-1) = 0.0E0
C
*
* INCREMENT OPCOUNT FOR LOOP 560
OPS = OPS + 4*(UK-I+1)
DO 560 J = I, UK
W = RM1(J,I)
RM1(J,I) = RM1(J,MP) - X * W
RM1(J,MP) = W
IF (J .LT. N1) GO TO 555
L = J - NS
Z(I,L) = Z(MP,L) - Y * W
Z(MP,L) = 0.0E0
GO TO 560
555 RM1(I,J+2) = RM1(MP,J+2) - Y * W
RM1(MP,J+2) = 0.0E0
560 CONTINUE
C
RM1(I,I) = RM1(I,I) - Y * ILAMBD
IF (I .LT. N1) GO TO 570
L = I - NS
Z(MP,L) = -ILAMBD
Z(I,L) = Z(I,L) + X * ILAMBD
GO TO 640
570 RM1(MP,I+2) = -ILAMBD
RM1(I,I+2) = RM1(I,I+2) + X * ILAMBD
GO TO 640
580 IF (X .NE. 0.0E0) GO TO 600
RM1(MP,MP) = EPS3
IF (I .LT. N) RM1(MP,I+1) = 0.0E0
IF (I .EQ. N) Z(MP,S-1) = 0.0E0
T = 0.0E0
X = EPS3 * EPS3
600 W = W / X
X = RM1(MP,MP) * W
Y = -T * W
C
*
* INCREMENT OPCOUNT FOR LOOP 620
OPS = OPS + 6*(UK-I+1)
DO 620 J = I, UK
IF (J .LT. N1) GO TO 610
L = J - NS
T = Z(MP,L)
Z(I,L) = -X * T - Y * RM1(J,MP)
GO TO 615
610 T = RM1(MP,J+2)
RM1(I,J+2) = -X * T - Y * RM1(J,MP)
615 RM1(J,I) = RM1(J,I) - X * RM1(J,MP) + Y * T
620 CONTINUE
C
IF (I .LT. N1) GO TO 630
L = I - NS
Z(I,L) = Z(I,L) - ILAMBD
GO TO 640
630 RM1(I,I+2) = RM1(I,I+2) - ILAMBD
640 CONTINUE
*
* INCREMENT OP COUNT (AVERAGE) FOR COMPUTING
* THE SCALARS IN LOOP 640
OPS = OPS + 10*(UK -1)
C
IF (UK .LT. N1) GO TO 650
L = UK - NS
T = Z(UK,L)
GO TO 655
650 T = RM1(UK,UK+2)
655 IF (RM1(UK,UK) .EQ. 0.0E0 .AND. T .EQ. 0.0E0) RM1(UK,UK) = EPS3
C .......... BACK SUBSTITUTION FOR COMPLEX VECTOR
C FOR I=UK STEP -1 UNTIL 1 DO -- ..........
660 DO 720 II = 1, UK
I = UK + 1 - II
X = RV1(I)
Y = 0.0E0
IF (I .EQ. UK) GO TO 700
IP1 = I + 1
C
DO 680 J = IP1, UK
IF (J .LT. N1) GO TO 670
L = J - NS
T = Z(I,L)
GO TO 675
670 T = RM1(I,J+2)
675 X = X - RM1(J,I) * RV1(J) + T * RV2(J)
Y = Y - RM1(J,I) * RV2(J) - T * RV1(J)
680 CONTINUE
C
700 IF (I .LT. N1) GO TO 710
L = I - NS
T = Z(I,L)
GO TO 715
710 T = RM1(I,I+2)
715 CALL CDIV(X,Y,RM1(I,I),T,RV1(I),RV2(I))
720 CONTINUE
*
* INCREMENT OP COUNT FOR LOOP 720.
OPS = OPS + 4*UK*(UK+3)
C .......... ACCEPTANCE TEST FOR REAL OR COMPLEX
C EIGENVECTOR AND NORMALIZATION ..........
740 ITS = ITS + 1
NORM = 0.0E0
NORMV = 0.0E0
C
DO 780 I = 1, UK
IF (ILAMBD .EQ. 0.0E0) X = ABS(RV1(I))
IF (ILAMBD .NE. 0.0E0) X = PYTHAG(RV1(I),RV2(I))
IF (NORMV .GE. X) GO TO 760
NORMV = X
J = I
760 NORM = NORM + X
780 CONTINUE
*
* INCREMENT OP COUNT ACCEPTANCE TEST
IF (ILAMBD .EQ. 0.0E0) OPS = OPS + UK
IF (ILAMBD .NE. 0.0E0) OPS = OPS + 16*UK
C
IF (NORM .LT. GROWTO) GO TO 840
C .......... ACCEPT VECTOR ..........
X = RV1(J)
IF (ILAMBD .EQ. 0.0E0) X = 1.0E0 / X
IF (ILAMBD .NE. 0.0E0) Y = RV2(J)
C
*
* INCREMENT OPCOUNT FOR LOOP 820
IF (ILAMBD .EQ. 0.0E0) OPS = OPS + UK
IF (ILAMBD .NE. 0.0E0) OPS = OPS + 16*UK
DO 820 I = 1, UK
IF (ILAMBD .NE. 0.0E0) GO TO 800
Z(I,S) = RV1(I) * X
GO TO 820
800 CALL CDIV(RV1(I),RV2(I),X,Y,Z(I,S-1),Z(I,S))
820 CONTINUE
C
IF (UK .EQ. N) GO TO 940
J = UK + 1
GO TO 900
C .......... IN-LINE PROCEDURE FOR CHOOSING
C A NEW STARTING VECTOR ..........
840 IF (ITS .GE. UK) GO TO 880
X = UKROOT
Y = EPS3 / (X + 1.0E0)
RV1(1) = EPS3
C
DO 860 I = 2, UK
860 RV1(I) = Y
C
J = UK - ITS + 1
RV1(J) = RV1(J) - EPS3 * X
IF (ILAMBD .EQ. 0.0E0) GO TO 440
GO TO 660
C .......... SET ERROR -- UNACCEPTED EIGENVECTOR ..........
880 J = 1
IERR = -K
C .......... SET REMAINING VECTOR COMPONENTS TO ZERO ..........
900 DO 920 I = J, N
Z(I,S) = 0.0E0
IF (ILAMBD .NE. 0.0E0) Z(I,S-1) = 0.0E0
920 CONTINUE
C
940 S = S + 1
960 IF (IP .EQ. (-1)) IP = 0
IF (IP .EQ. 1) IP = -1
980 CONTINUE
C
GO TO 1001
C .......... SET ERROR -- UNDERESTIMATE OF EIGENVECTOR
C SPACE REQUIRED ..........
1000 IF (IERR .NE. 0) IERR = IERR - N
IF (IERR .EQ. 0) IERR = -(2 * N + 1)
1001 M = S - 1 - IABS(IP)
*
* COMPUTE FINAL OP COUNT
OPS = OPS + OPST
RETURN
END
SUBROUTINE ORTHES(NM,N,LOW,IGH,A,ORT)
C
INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
REAL A(NM,N),ORT(IGH)
REAL F,G,H,SCALE
*
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT
* ITCNT IS INITIALIZED TO 0, OPS IS ONLY INCREMENTED
* OPST IS USED TO ACCUMULATE SMALL CONTRIBUTIONS TO OPS
* TO AVOID ROUNDOFF ERROR
* .. COMMON BLOCKS ..
COMMON /LATIME/ OPS, ITCNT
* ..
* .. SCALARS IN COMMON ..
REAL OPS, ITCNT, OPST
* ..
C
C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTHES,
C NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
C
C GIVEN A REAL GENERAL MATRIX, THIS SUBROUTINE
C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
C ORTHOGONAL SIMILARITY TRANSFORMATIONS.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRIX.
C
C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED,
C SET LOW=1, IGH=N.
C
C A CONTAINS THE INPUT MATRIX.
C
C ON OUTPUT
C
C A CONTAINS THE HESSENBERG MATRIX. INFORMATION ABOUT
C THE ORTHOGONAL TRANSFORMATIONS USED IN THE REDUCTION
C IS STORED IN THE REMAINING TRIANGLE UNDER THE
C HESSENBERG MATRIX.
C
C ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS.
C ONLY ELEMENTS LOW THROUGH IGH ARE USED.
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
C
IF (N.LE.0) RETURN
LA = IGH - 1
KP1 = LOW + 1
IF (LA .LT. KP1) GO TO 200
C
*
* INCREMENT OP COUNR FOR COMPUTING G,H,ORT(M),.. IN LOOP 180
OPS = OPS + 6*(LA - KP1 + 1)
DO 180 M = KP1, LA
H = 0.0E0
ORT(M) = 0.0E0
SCALE = 0.0E0
C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
*
* INCREMENT OP COUNT FOR LOOP 90
OPS = OPS + (IGH-M +1)
DO 90 I = M, IGH
90 SCALE = SCALE + ABS(A(I,M-1))
C
IF (SCALE .EQ. 0.0E0) GO TO 180
MP = M + IGH
C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
*
* INCREMENT OP COUNT FOR LOOP 100
OPS = OPS + 3*(IGH-M+1)
DO 100 II = M, IGH
I = MP - II
ORT(I) = A(I,M-1) / SCALE
H = H + ORT(I) * ORT(I)
100 CONTINUE
C
G = -SIGN(SQRT(H),ORT(M))
H = H - ORT(M) * G
ORT(M) = ORT(M) - G
C .......... FORM (I-(U*UT)/H) * A ..........
*
* INCREMENT OP COUNT FOR LOOP 130 AND 160
OPS = OPS + (N-M+1+IGH)*(4*(IGH-M+1) + 1)
DO 130 J = M, N
F = 0.0E0
C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
DO 110 II = M, IGH
I = MP - II
F = F + ORT(I) * A(I,J)
110 CONTINUE
C
F = F / H
C
DO 120 I = M, IGH
120 A(I,J) = A(I,J) - F * ORT(I)
C
130 CONTINUE
C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
DO 160 I = 1, IGH
F = 0.0E0
C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
DO 140 JJ = M, IGH
J = MP - JJ
F = F + ORT(J) * A(I,J)
140 CONTINUE
C
F = F / H
C
DO 150 J = M, IGH
150 A(I,J) = A(I,J) - F * ORT(J)
C
160 CONTINUE
C
ORT(M) = SCALE * ORT(M)
A(M,M-1) = SCALE * G
180 CONTINUE
C
200 RETURN
END
REAL FUNCTION PYTHAG(A,B)
REAL A,B
C
C FINDS SQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
C
*
* COMMON BLOCK TO RETURN OPERATION COUNT
* OPST IS ONLY INCREMENTED HERE
* .. COMMON BLOCKS ..
COMMON / PYTHOP / OPST
* ..
* .. SCALARS IN COMMON
REAL OPST
* ..
REAL P,R,S,T,U
P = AMAX1(ABS(A),ABS(B))
IF (P .EQ. 0.0E0) GO TO 20
R = (AMIN1(ABS(A),ABS(B))/P)**2
*
* INCREMENT OPST
OPST = OPST + 2
10 CONTINUE
T = 4.0E0 + R
IF (T .EQ. 4.0E0) GO TO 20
S = R/T
U = 1.0E0 + 2.0E0*S
P = U*P
R = (S/U)**2 * R
*
* INCREMENT OPST
OPST = OPST + 8
GO TO 10
20 PYTHAG = P
RETURN
END
SUBROUTINE TQLRAT(N,D,E2,IERR)
*
* EISPACK ROUTINE.
* MODIFIED FOR COMPARISON WITH LAPACK ROUTINES.
*
* CONVERGENCE TEST WAS MODIFIED TO BE THE SAME AS IN SSTEQR.
*
C
INTEGER I,J,L,M,N,II,L1,MML,IERR
REAL D(N),E2(N)
REAL B,C,F,G,H,P,R,S,T,EPSLON,PYTHAG
REAL EPS, TST
REAL SLAMCH
*
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT
* ITCNT IS INITIALIZED TO 0, OPS IS ONLY INCREMENTED
* OPST IS USED TO ACCUMULATE CONTRIBUTIONS TO OPS FROM
* FUNCTION PYTHAG. IT IS PASSED TO AND FROM PYTHAG
* THROUGH COMMON BLOCK PYTHOP.
* .. COMMON BLOCKS ..
COMMON / LATIME / OPS, ITCNT
COMMON / PYTHOP / OPST
* ..
* .. SCALARS IN COMMON ..
REAL ITCNT, OPS, OPST
* ..
C
C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQLRAT,
C ALGORITHM 464, COMM. ACM 16, 689(1973) BY REINSCH.
C
C THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC
C TRIDIAGONAL MATRIX BY THE RATIONAL QL METHOD.
C
C ON INPUT
C
C N IS THE ORDER OF THE MATRIX.
C
C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
C
C E2 CONTAINS THE SQUARES OF THE SUBDIAGONAL ELEMENTS OF THE
C INPUT MATRIX IN ITS LAST N-1 POSITIONS. E2(1) IS ARBITRARY.
C
C ON OUTPUT
C
C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN
C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND
C ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE
C THE SMALLEST EIGENVALUES.
C
C E2 HAS BEEN DESTROYED.
C
C IERR IS SET TO
C ZERO FOR NORMAL RETURN,
C J IF THE J-TH EIGENVALUE HAS NOT BEEN
C DETERMINED AFTER 30 ITERATIONS.
C
C CALLS PYTHAG FOR SQRT(A*A + B*B) .
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
C
IERR = 0
IF (N .EQ. 1) GO TO 1001
*
* INITIALIZE ITERATION COUNT AND OPST
ITCNT = 0
OPST = 0
*
* DETERMINE THE UNIT ROUNDOFF FOR THIS ENVIRONMENT.
*
EPS = SLAMCH( 'EPSILON' )
C
DO 100 I = 2, N
100 E2(I-1) = E2(I)
C
F = 0.0E0
T = 0.0E0
E2(N) = 0.0E0
C
DO 290 L = 1, N
J = 0
H = ABS(D(L)) + SQRT(E2(L))
IF (T .GT. H) GO TO 105
T = H
B = EPSLON(T)
C = B * B
*
* INCREMENT OPCOUNT FOR THIS SECTION.
* (FUNCTION EPSLON IS COUNTED AS 6 FLOPS. THIS IS THE MINIMUM
* NUMBER REQUIRED, BUT COUNTING THEM EXACTLY WOULD AFFECT
* THE TIMING.)
OPS = OPS + 9
C .......... LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT ..........
105 DO 110 M = L, N
IF( M .EQ. N ) GO TO 120
TST = SQRT( ABS( E2(M) ) )
IF( TST .LE. EPS * ( ABS(D(M)) + ABS(D(M+1)) ) ) GO TO 120
* IF (E2(M) .LE. C) GO TO 120
C .......... E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
C THROUGH THE BOTTOM OF THE LOOP ..........
110 CONTINUE
C
120 CONTINUE
*
* INCREMENT OPCOUNT FOR FINDING SMALL SUBDIAGONAL ELEMENT.
OPS = OPS + 3*( MIN(M,N-1)-L+1 )
IF (M .EQ. L) GO TO 210
130 IF (J .EQ. 30) GO TO 1000
J = J + 1
C .......... FORM SHIFT ..........
L1 = L + 1
S = SQRT(E2(L))
G = D(L)
P = (D(L1) - G) / (2.0E0 * S)
R = PYTHAG(P,1.0E0)
D(L) = S / (P + SIGN(R,P))
H = G - D(L)
C
DO 140 I = L1, N
140 D(I) = D(I) - H
C
F = F + H
*
* INCREMENT OPCOUNT FOR FORMING SHIFT AND SUBTRACTING.
OPS = OPS + 8 + (I-L1+1)
C .......... RATIONAL QL TRANSFORMATION ..........
G = D(M)
IF (G .EQ. 0.0E0) G = B
H = G
S = 0.0E0
MML = M - L
C .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
DO 200 II = 1, MML
I = M - II
P = G * H
R = P + E2(I)
E2(I+1) = S * R
S = E2(I) / R
D(I+1) = H + S * (H + D(I))
G = D(I) - E2(I) / G
IF (G .EQ. 0.0E0) G = B
H = G * P / R
200 CONTINUE
C
E2(L) = S * G
D(L) = H
*
* INCREMENT OPCOUNT FOR INNER LOOP.
OPS = OPS + MML*11 + 1
*
* INCREMENT ITERATION COUNTER
ITCNT = ITCNT + 1
C .......... GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST ..........
IF (H .EQ. 0.0E0) GO TO 210
IF (ABS(E2(L)) .LE. ABS(C/H)) GO TO 210
E2(L) = H * E2(L)
IF (E2(L) .NE. 0.0E0) GO TO 130
210 P = D(L) + F
C .......... ORDER EIGENVALUES ..........
IF (L .EQ. 1) GO TO 250
C .......... FOR I=L STEP -1 UNTIL 2 DO -- ..........
DO 230 II = 2, L
I = L + 2 - II
IF (P .GE. D(I-1)) GO TO 270
D(I) = D(I-1)
230 CONTINUE
C
250 I = 1
270 D(I) = P
290 CONTINUE
C
GO TO 1001
C .......... SET ERROR -- NO CONVERGENCE TO AN
C EIGENVALUE AFTER 30 ITERATIONS ..........
1000 IERR = L
1001 CONTINUE
*
* COMPUTE FINAL OP COUNT
OPS = OPS + OPST
RETURN
END
SUBROUTINE TRED1(NM,N,A,D,E,E2)
C
INTEGER I,J,K,L,N,II,NM,JP1
REAL A(NM,N),D(N),E(N),E2(N)
REAL F,G,H,SCALE
*
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT.
* ITCNT IS INITIALIZED TO 0, OPS IS ONLY INCREMENTED.
* .. COMMON BLOCKS ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. SCALARS IN COMMON ..
REAL ITCNT, OPS
* ..
C
C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED1,
C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C
C THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX
C TO A SYMMETRIC TRIDIAGONAL MATRIX USING
C ORTHOGONAL SIMILARITY TRANSFORMATIONS.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRIX.
C
C A CONTAINS THE REAL SYMMETRIC INPUT MATRIX. ONLY THE
C LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED.
C
C ON OUTPUT
C
C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS-
C FORMATIONS USED IN THE REDUCTION IN ITS STRICT LOWER
C TRIANGLE. THE FULL UPPER TRIANGLE OF A IS UNALTERED.
C
C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX.
C
C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO.
C
C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
C
*
OPS = OPS + MAX( 0.0E0, (4.0E0/3.0E0)*REAL(N)**3 +
$ 12.0E0*REAL(N)**2 +
$ (11.0E0/3.0E0)*N - 22 )
*
DO 100 I = 1, N
D(I) = A(N,I)
A(N,I) = A(I,I)
100 CONTINUE
C .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........
DO 300 II = 1, N
I = N + 1 - II
L = I - 1
H = 0.0E0
SCALE = 0.0E0
IF (L .LT. 1) GO TO 130
C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) ..........
DO 120 K = 1, L
120 SCALE = SCALE + ABS(D(K))
C
IF (SCALE .NE. 0.0E0) GO TO 140
C
DO 125 J = 1, L
D(J) = A(L,J)
A(L,J) = A(I,J)
A(I,J) = 0.0E0
125 CONTINUE
C
130 E(I) = 0.0E0
E2(I) = 0.0E0
GO TO 300
C
140 DO 150 K = 1, L
D(K) = D(K) / SCALE
H = H + D(K) * D(K)
150 CONTINUE
C
E2(I) = SCALE * SCALE * H
F = D(L)
G = -SIGN(SQRT(H),F)
E(I) = SCALE * G
H = H - F * G
D(L) = F - G
IF (L .EQ. 1) GO TO 285
C .......... FORM A*U ..........
DO 170 J = 1, L
170 E(J) = 0.0E0
C
DO 240 J = 1, L
F = D(J)
G = E(J) + A(J,J) * F
JP1 = J + 1
IF (L .LT. JP1) GO TO 220
C
DO 200 K = JP1, L
G = G + A(K,J) * D(K)
E(K) = E(K) + A(K,J) * F
200 CONTINUE
C
220 E(J) = G
240 CONTINUE
C .......... FORM P ..........
F = 0.0E0
C
DO 245 J = 1, L
E(J) = E(J) / H
F = F + E(J) * D(J)
245 CONTINUE
C
H = F / (H + H)
C .......... FORM Q ..........
DO 250 J = 1, L
250 E(J) = E(J) - H * D(J)
C .......... FORM REDUCED A ..........
DO 280 J = 1, L
F = D(J)
G = E(J)
C
DO 260 K = J, L
260 A(K,J) = A(K,J) - F * E(K) - G * D(K)
C
280 CONTINUE
C
285 DO 290 J = 1, L
F = D(J)
D(J) = A(L,J)
A(L,J) = A(I,J)
A(I,J) = F * SCALE
290 CONTINUE
C
300 CONTINUE
C
RETURN
END
SUBROUTINE BISECT(N,EPS1,D,E,E2,LB,UB,MM,M,W,IND,IERR,RV4,RV5)
*
* EISPACK ROUTINE.
* MODIFIED FOR COMPARISON WITH LAPACK ROUTINES.
*
* CONVERGENCE TEST WAS MODIFIED TO BE THE SAME AS IN SSTEBZ.
*
C
INTEGER I,J,K,L,M,N,P,Q,R,S,II,MM,M1,M2,TAG,IERR,ISTURM
REAL D(N),E(N),E2(N),W(MM),RV4(N),RV5(N)
REAL U,V,LB,T1,T2,UB,XU,X0,X1,EPS1,TST1,TST2,EPSLON
INTEGER IND(MM)
*
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT
* ITCNT IS INITIALIZED TO 0, OPS IS ONLY INCREMENTED
* .. COMMON BLOCKS ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. SCALARS IN COMMON ..
REAL ITCNT, OPS
* ..
C
C THIS SUBROUTINE IS A TRANSLATION OF THE BISECTION TECHNIQUE
C IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971).
C
C THIS SUBROUTINE FINDS THOSE EIGENVALUES OF A TRIDIAGONAL
C SYMMETRIC MATRIX WHICH LIE IN A SPECIFIED INTERVAL,
C USING BISECTION.
C
C ON INPUT
C
C N IS THE ORDER OF THE MATRIX.
C
C EPS1 IS AN ABSOLUTE ERROR TOLERANCE FOR THE COMPUTED
C EIGENVALUES. IF THE INPUT EPS1 IS NON-POSITIVE,
C IT IS RESET FOR EACH SUBMATRIX TO A DEFAULT VALUE,
C NAMELY, MINUS THE PRODUCT OF THE RELATIVE MACHINE
C PRECISION AND THE 1-NORM OF THE SUBMATRIX.
C
C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
C
C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY.
C
C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
C E2(1) IS ARBITRARY.
C
C LB AND UB DEFINE THE INTERVAL TO BE SEARCHED FOR EIGENVALUES.
C IF LB IS NOT LESS THAN UB, NO EIGENVALUES WILL BE FOUND.
C
C MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF
C EIGENVALUES IN THE INTERVAL. WARNING. IF MORE THAN
C MM EIGENVALUES ARE DETERMINED TO LIE IN THE INTERVAL,
C AN ERROR RETURN IS MADE WITH NO EIGENVALUES FOUND.
C
C ON OUTPUT
C
C EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS
C (LAST) DEFAULT VALUE.
C
C D AND E ARE UNALTERED.
C
C ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED
C AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE
C MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES.
C E2(1) IS ALSO SET TO ZERO.
C
C M IS THE NUMBER OF EIGENVALUES DETERMINED TO LIE IN (LB,UB).
C
C W CONTAINS THE M EIGENVALUES IN ASCENDING ORDER.
C
C IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES
C ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W --
C 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM
C THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC..
C
C IERR IS SET TO
C ZERO FOR NORMAL RETURN,
C 3*N+1 IF M EXCEEDS MM.
C
C RV4 AND RV5 ARE TEMPORARY STORAGE ARRAYS.
C
C THE ALGOL PROCEDURE STURMCNT CONTAINED IN TRISTURM
C APPEARS IN BISECT IN-LINE.
C
C NOTE THAT SUBROUTINE TQL1 OR IMTQL1 IS GENERALLY FASTER THAN
C BISECT, IF MORE THAN N/4 EIGENVALUES ARE TO BE FOUND.
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
C
REAL ONE
PARAMETER ( ONE = 1.0E0 )
REAL RELFAC
PARAMETER ( RELFAC = 2.0E0 )
REAL ATOLI, RTOLI, SAFEMN, TMP1, TMP2, TNORM, ULP
REAL SLAMCH, PIVMIN
EXTERNAL SLAMCH
* INITIALIZE ITERATION COUNT.
ITCNT = 0
SAFEMN = SLAMCH( 'S' )
ULP = SLAMCH( 'E' )*SLAMCH( 'B' )
RTOLI = ULP*RELFAC
IERR = 0
TAG = 0
T1 = LB
T2 = UB
C .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES ..........
DO 40 I = 1, N
IF (I .EQ. 1) GO TO 20
CCC TST1 = ABS(D(I)) + ABS(D(I-1))
CCC TST2 = TST1 + ABS(E(I))
CCC IF (TST2 .GT. TST1) GO TO 40
TMP1 = E( I )**2
IF( ABS( D(I)*D(I-1) )*ULP**2+SAFEMN.LE.TMP1 )
$ GO TO 40
20 E2(I) = 0.0E0
40 CONTINUE
* INCREMENT OPCOUNT FOR DETERMINING IF MATRIX SPLITS.
OPS = OPS + 5*( N-1 )
C
C COMPUTE QUANTITIES NEEDED FOR CONVERGENCE TEST.
TMP1 = D( 1 ) - ABS( E( 2 ) )
TMP2 = D( 1 ) + ABS( E( 2 ) )
PIVMIN = ONE
DO 41 I = 2, N - 1
TMP1 = MIN( TMP1, D( I )-ABS( E( I ) )-ABS( E( I+1 ) ) )
TMP2 = MAX( TMP2, D( I )+ABS( E( I ) )+ABS( E( I+1 ) ) )
PIVMIN = MAX( PIVMIN, E( I )**2 )
41 CONTINUE
TMP1 = MIN( TMP1, D( N )-ABS( E( N ) ) )
TMP2 = MAX( TMP2, D( N )+ABS( E( N ) ) )
PIVMIN = MAX( PIVMIN, E( N )**2 )
PIVMIN = PIVMIN*SAFEMN
TNORM = MAX( ABS(TMP1), ABS(TMP2) )
ATOLI = ULP*TNORM
* INCREMENT OPCOUNT FOR COMPUTING THESE QUANTITIES.
OPS = OPS + 4*( N-1 )
C
C .......... DETERMINE THE NUMBER OF EIGENVALUES
C IN THE INTERVAL ..........
P = 1
Q = N
X1 = UB
ISTURM = 1
GO TO 320
60 M = S
X1 = LB
ISTURM = 2
GO TO 320
80 M = M - S
IF (M .GT. MM) GO TO 980
Q = 0
R = 0
C .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING
C INTERVAL BY THE GERSCHGORIN BOUNDS ..........
100 IF (R .EQ. M) GO TO 1001
TAG = TAG + 1
P = Q + 1
XU = D(P)
X0 = D(P)
U = 0.0E0
C
DO 120 Q = P, N
X1 = U
U = 0.0E0
V = 0.0E0
IF (Q .EQ. N) GO TO 110
U = ABS(E(Q+1))
V = E2(Q+1)
110 XU = AMIN1(D(Q)-(X1+U),XU)
X0 = AMAX1(D(Q)+(X1+U),X0)
IF (V .EQ. 0.0E0) GO TO 140
120 CONTINUE
* INCREMENT OPCOUNT FOR REFINING INTERVAL.
OPS = OPS + ( N-P+1 )*2
C
140 X1 = EPSLON(AMAX1(ABS(XU),ABS(X0)))
IF (EPS1 .LE. 0.0E0) EPS1 = -X1
IF (P .NE. Q) GO TO 180
C .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL ..........
IF (T1 .GT. D(P) .OR. D(P) .GE. T2) GO TO 940
M1 = P
M2 = P
RV5(P) = D(P)
GO TO 900
180 X1 = X1 * (Q - P + 1)
LB = AMAX1(T1,XU-X1)
UB = AMIN1(T2,X0+X1)
X1 = LB
ISTURM = 3
GO TO 320
200 M1 = S + 1
X1 = UB
ISTURM = 4
GO TO 320
220 M2 = S
IF (M1 .GT. M2) GO TO 940
C .......... FIND ROOTS BY BISECTION ..........
X0 = UB
ISTURM = 5
C
DO 240 I = M1, M2
RV5(I) = UB
RV4(I) = LB
240 CONTINUE
C .......... LOOP FOR K-TH EIGENVALUE
C FOR K=M2 STEP -1 UNTIL M1 DO --
C (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) ..........
K = M2
250 XU = LB
C .......... FOR I=K STEP -1 UNTIL M1 DO -- ..........
DO 260 II = M1, K
I = M1 + K - II
IF (XU .GE. RV4(I)) GO TO 260
XU = RV4(I)
GO TO 280
260 CONTINUE
C
280 IF (X0 .GT. RV5(K)) X0 = RV5(K)
C .......... NEXT BISECTION STEP ..........
300 X1 = (XU + X0) * 0.5E0
CCC IF ((X0 - XU) .LE. ABS(EPS1)) GO TO 420
CCC TST1 = 2.0E0 * (ABS(XU) + ABS(X0))
CCC TST2 = TST1 + (X0 - XU)
CCC IF (TST2 .EQ. TST1) GO TO 420
TMP1 = ABS( X0 - XU )
TMP2 = MAX( ABS( X0 ), ABS( XU ) )
IF( TMP1.LT.MAX( ATOLI, PIVMIN, RTOLI*TMP2 ) )
$ GO TO 420
C .......... IN-LINE PROCEDURE FOR STURM SEQUENCE ..........
320 S = P - 1
U = 1.0E0
C
DO 340 I = P, Q
IF (U .NE. 0.0E0) GO TO 325
V = ABS(E(I)) / EPSLON(1.0E0)
IF (E2(I) .EQ. 0.0E0) V = 0.0E0
GO TO 330
325 V = E2(I) / U
330 U = D(I) - X1 - V
IF (U .LT. 0.0E0) S = S + 1
340 CONTINUE
* INCREMENT OPCOUNT FOR STURM SEQUENCE.
OPS = OPS + ( Q-P+1 )*3
* INCREMENT ITERATION COUNTER.
ITCNT = ITCNT + 1
C
GO TO (60,80,200,220,360), ISTURM
C .......... REFINE INTERVALS ..........
360 IF (S .GE. K) GO TO 400
XU = X1
IF (S .GE. M1) GO TO 380
RV4(M1) = X1
GO TO 300
380 RV4(S+1) = X1
IF (RV5(S) .GT. X1) RV5(S) = X1
GO TO 300
400 X0 = X1
GO TO 300
C .......... K-TH EIGENVALUE FOUND ..........
420 RV5(K) = X1
K = K - 1
IF (K .GE. M1) GO TO 250
C .......... ORDER EIGENVALUES TAGGED WITH THEIR
C SUBMATRIX ASSOCIATIONS ..........
900 S = R
R = R + M2 - M1 + 1
J = 1
K = M1
C
DO 920 L = 1, R
IF (J .GT. S) GO TO 910
IF (K .GT. M2) GO TO 940
IF (RV5(K) .GE. W(L)) GO TO 915
C
DO 905 II = J, S
I = L + S - II
W(I+1) = W(I)
IND(I+1) = IND(I)
905 CONTINUE
C
910 W(L) = RV5(K)
IND(L) = TAG
K = K + 1
GO TO 920
915 J = J + 1
920 CONTINUE
C
940 IF (Q .LT. N) GO TO 100
GO TO 1001
C .......... SET ERROR -- UNDERESTIMATE OF NUMBER OF
C EIGENVALUES IN INTERVAL ..........
980 IERR = 3 * N + 1
1001 LB = T1
UB = T2
RETURN
END
SUBROUTINE TINVIT(NM,N,D,E,E2,M,W,IND,Z,
X IERR,RV1,RV2,RV3,RV4,RV6)
*
* EISPACK ROUTINE.
*
* CONVERGENCE TEST WAS NOT MODIFIED, SINCE IT SHOULD GIVE
* APPROXIMATELY THE SAME LEVEL OF ACCURACY AS LAPACK ROUTINE,
* ALTHOUGH THE EIGENVECTORS MAY NOT BE AS CLOSE TO ORTHOGONAL.
*
C
INTEGER I,J,M,N,P,Q,R,S,II,IP,JJ,NM,ITS,TAG,IERR,GROUP
REAL D(N),E(N),E2(N),W(M),Z(NM,M),
X RV1(N),RV2(N),RV3(N),RV4(N),RV6(N)
REAL U,V,UK,XU,X0,X1,EPS2,EPS3,EPS4,NORM,ORDER,EPSLON,
X PYTHAG
INTEGER IND(M)
*
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT
* ITCNT IS INITIALIZED TO 0, OPS IS ONLY INCREMENTED
* .. COMMON BLOCKS ..
COMMON / LATIME / OPS, ITCNT
COMMON / PYTHOP / OPST
* ..
* .. SCALARS IN COMMON ..
REAL ITCNT, OPS, OPST
* ..
C
C THIS SUBROUTINE IS A TRANSLATION OF THE INVERSE ITERATION TECH-
C NIQUE IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971).
C
C THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A TRIDIAGONAL
C SYMMETRIC MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES,
C USING INVERSE ITERATION.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRIX.
C
C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
C
C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY.
C
C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E,
C WITH ZEROS CORRESPONDING TO NEGLIGIBLE ELEMENTS OF E.
C E(I) IS CONSIDERED NEGLIGIBLE IF IT IS NOT LARGER THAN
C THE PRODUCT OF THE RELATIVE MACHINE PRECISION AND THE SUM
C OF THE MAGNITUDES OF D(I) AND D(I-1). E2(1) MUST CONTAIN
C 0.0E0 IF THE EIGENVALUES ARE IN ASCENDING ORDER, OR 2.0E0
C IF THE EIGENVALUES ARE IN DESCENDING ORDER. IF BISECT,
C TRIDIB, OR IMTQLV HAS BEEN USED TO FIND THE EIGENVALUES,
C THEIR OUTPUT E2 ARRAY IS EXACTLY WHAT IS EXPECTED HERE.
C
C M IS THE NUMBER OF SPECIFIED EIGENVALUES.
C
C W CONTAINS THE M EIGENVALUES IN ASCENDING OR DESCENDING ORDER.
C
C IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES
C ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W --
C 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM
C THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC.
C
C ON OUTPUT
C
C ALL INPUT ARRAYS ARE UNALTERED.
C
C Z CONTAINS THE ASSOCIATED SET OF ORTHONORMAL EIGENVECTORS.
C ANY VECTOR WHICH FAILS TO CONVERGE IS SET TO ZERO.
C
C IERR IS SET TO
C ZERO FOR NORMAL RETURN,
C -R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH
C EIGENVALUE FAILS TO CONVERGE IN 5 ITERATIONS.
C
C RV1, RV2, RV3, RV4, AND RV6 ARE TEMPORARY STORAGE ARRAYS.
C
C CALLS PYTHAG FOR SQRT(A*A + B*B) .
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
C
* INITIALIZE ITERATION COUNT.
ITCNT = 0
IERR = 0
IF (M .EQ. 0) GO TO 1001
TAG = 0
ORDER = 1.0E0 - E2(1)
Q = 0
C .......... ESTABLISH AND PROCESS NEXT SUBMATRIX ..........
100 P = Q + 1
C
DO 120 Q = P, N
IF (Q .EQ. N) GO TO 140
IF (E2(Q+1) .EQ. 0.0E0) GO TO 140
120 CONTINUE
C .......... FIND VECTORS BY INVERSE ITERATION ..........
140 TAG = TAG + 1
S = 0
C
DO 920 R = 1, M
IF (IND(R) .NE. TAG) GO TO 920
ITS = 1
X1 = W(R)
IF (S .NE. 0) GO TO 510
C .......... CHECK FOR ISOLATED ROOT ..........
XU = 1.0E0
IF (P .NE. Q) GO TO 490
RV6(P) = 1.0E0
GO TO 870
490 NORM = ABS(D(P))
IP = P + 1
C
DO 500 I = IP, Q
500 NORM = AMAX1(NORM, ABS(D(I))+ABS(E(I)))
C .......... EPS2 IS THE CRITERION FOR GROUPING,
C EPS3 REPLACES ZERO PIVOTS AND EQUAL
C ROOTS ARE MODIFIED BY EPS3,
C EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW ..........
EPS2 = 1.0E-3 * NORM
EPS3 = EPSLON(NORM)
UK = Q - P + 1
EPS4 = UK * EPS3
UK = EPS4 / SQRT(UK)
* INCREMENT OPCOUNT FOR COMPUTING CRITERIA.
OPS = OPS + ( Q-IP+4 )
S = P
505 GROUP = 0
GO TO 520
C .......... LOOK FOR CLOSE OR COINCIDENT ROOTS ..........
510 IF (ABS(X1-X0) .GE. EPS2) GO TO 505
GROUP = GROUP + 1
IF (ORDER * (X1 - X0) .LE. 0.0E0) X1 = X0 + ORDER * EPS3
C .......... ELIMINATION WITH INTERCHANGES AND
C INITIALIZATION OF VECTOR ..........
520 V = 0.0E0
C
DO 580 I = P, Q
RV6(I) = UK
IF (I .EQ. P) GO TO 560
IF (ABS(E(I)) .LT. ABS(U)) GO TO 540
C .......... WARNING -- A DIVIDE CHECK MAY OCCUR HERE IF
C E2 ARRAY HAS NOT BEEN SPECIFIED CORRECTLY ..........
XU = U / E(I)
RV4(I) = XU
RV1(I-1) = E(I)
RV2(I-1) = D(I) - X1
RV3(I-1) = 0.0E0
IF (I .NE. Q) RV3(I-1) = E(I+1)
U = V - XU * RV2(I-1)
V = -XU * RV3(I-1)
GO TO 580
540 XU = E(I) / U
RV4(I) = XU
RV1(I-1) = U
RV2(I-1) = V
RV3(I-1) = 0.0E0
560 U = D(I) - X1 - XU * V
IF (I .NE. Q) V = E(I+1)
580 CONTINUE
* INCREMENT OPCOUNT FOR ELIMINATION.
OPS = OPS + ( Q-P+1 )*5
C
IF (U .EQ. 0.0E0) U = EPS3
RV1(Q) = U
RV2(Q) = 0.0E0
RV3(Q) = 0.0E0
C .......... BACK SUBSTITUTION
C FOR I=Q STEP -1 UNTIL P DO -- ..........
600 DO 620 II = P, Q
I = P + Q - II
RV6(I) = (RV6(I) - U * RV2(I) - V * RV3(I)) / RV1(I)
V = U
U = RV6(I)
620 CONTINUE
* INCREMENT OPCOUNT FOR BACK SUBSTITUTION.
OPS = OPS + ( Q-P+1 )*5
C .......... ORTHOGONALIZE WITH RESPECT TO PREVIOUS
C MEMBERS OF GROUP ..........
IF (GROUP .EQ. 0) GO TO 700
J = R
C
DO 680 JJ = 1, GROUP
630 J = J - 1
IF (IND(J) .NE. TAG) GO TO 630
XU = 0.0E0
C
DO 640 I = P, Q
640 XU = XU + RV6(I) * Z(I,J)
C
DO 660 I = P, Q
660 RV6(I) = RV6(I) - XU * Z(I,J)
C
* INCREMENT OPCOUNT FOR ORTHOGONALIZING.
OPS = OPS + ( Q-P+1 )*4
680 CONTINUE
C
700 NORM = 0.0E0
C
DO 720 I = P, Q
720 NORM = NORM + ABS(RV6(I))
* INCREMENT OPCOUNT FOR COMPUTING NORM.
OPS = OPS + ( Q-P+1 )
C
IF (NORM .GE. 1.0E0) GO TO 840
C .......... FORWARD SUBSTITUTION ..........
IF (ITS .EQ. 5) GO TO 830
IF (NORM .NE. 0.0E0) GO TO 740
RV6(S) = EPS4
S = S + 1
IF (S .GT. Q) S = P
GO TO 780
740 XU = EPS4 / NORM
C
DO 760 I = P, Q
760 RV6(I) = RV6(I) * XU
C .......... ELIMINATION OPERATIONS ON NEXT VECTOR
C ITERATE ..........
780 DO 820 I = IP, Q
U = RV6(I)
C .......... IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE
C WAS PERFORMED EARLIER IN THE
C TRIANGULARIZATION PROCESS ..........
IF (RV1(I-1) .NE. E(I)) GO TO 800
U = RV6(I-1)
RV6(I-1) = RV6(I)
800 RV6(I) = U - RV4(I) * RV6(I-1)
820 CONTINUE
* INCREMENT OPCOUNT FOR FORWARD SUBSTITUTION.
OPS = OPS + ( Q-P+1 ) + ( Q-IP+1 )*2
C
ITS = ITS + 1
* INCREMENT ITERATION COUNTER.
ITCNT = ITCNT + 1
GO TO 600
C .......... SET ERROR -- NON-CONVERGED EIGENVECTOR ..........
830 IERR = -R
XU = 0.0E0
GO TO 870
C .......... NORMALIZE SO THAT SUM OF SQUARES IS
C 1 AND EXPAND TO FULL ORDER ..........
840 U = 0.0E0
C
DO 860 I = P, Q
860 U = PYTHAG(U,RV6(I))
C
XU = 1.0E0 / U
C
870 DO 880 I = 1, N
880 Z(I,R) = 0.0E0
C
DO 900 I = P, Q
900 Z(I,R) = RV6(I) * XU
* INCREMENT OPCOUNT FOR NORMALIZING.
OPS = OPS + ( Q-P+1 )
C
X0 = X1
920 CONTINUE
C
IF (Q .LT. N) GO TO 100
* INCREMENT OPCOUNT FOR USE OF FUNCTION PYTHAG.
OPS = OPS + OPST
1001 RETURN
END
SUBROUTINE TRIDIB(N,EPS1,D,E,E2,LB,UB,M11,M,W,IND,IERR,RV4,RV5)
*
* EISPACK ROUTINE.
* MODIFIED FOR COMPARISON WITH LAPACK ROUTINES.
*
* CONVERGENCE TEST WAS MODIFIED TO BE THE SAME AS IN SSTEBZ.
*
C
INTEGER I,J,K,L,M,N,P,Q,R,S,II,M1,M2,M11,M22,TAG,IERR,ISTURM
REAL D(N),E(N),E2(N),W(M),RV4(N),RV5(N)
REAL U,V,LB,T1,T2,UB,XU,X0,X1,EPS1,TST1,TST2,EPSLON
INTEGER IND(M)
*
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT
* ITCNT IS INITIALIZED TO 0, OPS IS ONLY INCREMENTED
* .. COMMON BLOCKS ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. SCALARS IN COMMON ..
REAL ITCNT, OPS
* ..
C
C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BISECT,
C NUM. MATH. 9, 386-393(1967) BY BARTH, MARTIN, AND WILKINSON.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 249-256(1971).
C
C THIS SUBROUTINE FINDS THOSE EIGENVALUES OF A TRIDIAGONAL
C SYMMETRIC MATRIX BETWEEN SPECIFIED BOUNDARY INDICES,
C USING BISECTION.
C
C ON INPUT
C
C N IS THE ORDER OF THE MATRIX.
C
C EPS1 IS AN ABSOLUTE ERROR TOLERANCE FOR THE COMPUTED
C EIGENVALUES. IF THE INPUT EPS1 IS NON-POSITIVE,
C IT IS RESET FOR EACH SUBMATRIX TO A DEFAULT VALUE,
C NAMELY, MINUS THE PRODUCT OF THE RELATIVE MACHINE
C PRECISION AND THE 1-NORM OF THE SUBMATRIX.
C
C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
C
C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY.
C
C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
C E2(1) IS ARBITRARY.
C
C M11 SPECIFIES THE LOWER BOUNDARY INDEX FOR THE DESIRED
C EIGENVALUES.
C
C M SPECIFIES THE NUMBER OF EIGENVALUES DESIRED. THE UPPER
C BOUNDARY INDEX M22 IS THEN OBTAINED AS M22=M11+M-1.
C
C ON OUTPUT
C
C EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS
C (LAST) DEFAULT VALUE.
C
C D AND E ARE UNALTERED.
C
C ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED
C AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE
C MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES.
C E2(1) IS ALSO SET TO ZERO.
C
C LB AND UB DEFINE AN INTERVAL CONTAINING EXACTLY THE DESIRED
C EIGENVALUES.
C
C W CONTAINS, IN ITS FIRST M POSITIONS, THE EIGENVALUES
C BETWEEN INDICES M11 AND M22 IN ASCENDING ORDER.
C
C IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES
C ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W --
C 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM
C THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC..
C
C IERR IS SET TO
C ZERO FOR NORMAL RETURN,
C 3*N+1 IF MULTIPLE EIGENVALUES AT INDEX M11 MAKE
C UNIQUE SELECTION IMPOSSIBLE,
C 3*N+2 IF MULTIPLE EIGENVALUES AT INDEX M22 MAKE
C UNIQUE SELECTION IMPOSSIBLE.
C
C RV4 AND RV5 ARE TEMPORARY STORAGE ARRAYS.
C
C NOTE THAT SUBROUTINE TQL1, IMTQL1, OR TQLRAT IS GENERALLY FASTER
C THAN TRIDIB, IF MORE THAN N/4 EIGENVALUES ARE TO BE FOUND.
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
C
REAL ONE
PARAMETER ( ONE = 1.0E0 )
REAL RELFAC
PARAMETER ( RELFAC = 2.0E0 )
REAL ATOLI, RTOLI, SAFEMN, TMP1, TMP2, TNORM, ULP
REAL SLAMCH, PIVMIN
EXTERNAL SLAMCH
* INITIALIZE ITERATION COUNT.
ITCNT = 0
SAFEMN = SLAMCH( 'S' )
ULP = SLAMCH( 'E' )*SLAMCH( 'B' )
RTOLI = ULP*RELFAC
IERR = 0
TAG = 0
XU = D(1)
X0 = D(1)
U = 0.0E0
C .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES AND DETERMINE AN
C INTERVAL CONTAINING ALL THE EIGENVALUES ..........
PIVMIN = ONE
DO 40 I = 1, N
X1 = U
U = 0.0E0
IF (I .NE. N) U = ABS(E(I+1))
XU = AMIN1(D(I)-(X1+U),XU)
X0 = AMAX1(D(I)+(X1+U),X0)
IF (I .EQ. 1) GO TO 20
CCC TST1 = ABS(D(I)) + ABS(D(I-1))
CCC TST2 = TST1 + ABS(E(I))
CCC IF (TST2 .GT. TST1) GO TO 40
TMP1 = E( I )**2
IF( ABS( D(I)*D(I-1) )*ULP**2+SAFEMN.LE.TMP1 ) THEN
PIVMIN = MAX( PIVMIN, TMP1 )
GO TO 40
END IF
20 E2(I) = 0.0E0
40 CONTINUE
PIVMIN = PIVMIN*SAFEMN
TNORM = MAX( ABS( XU ), ABS( X0 ) )
ATOLI = ULP*TNORM
* INCREMENT OPCOUNT FOR DETERMINING IF MATRIX SPLITS.
OPS = OPS + 9*( N-1 )
C
X1 = N
X1 = X1 * EPSLON(AMAX1(ABS(XU),ABS(X0)))
XU = XU - X1
T1 = XU
X0 = X0 + X1
T2 = X0
C .......... DETERMINE AN INTERVAL CONTAINING EXACTLY
C THE DESIRED EIGENVALUES ..........
P = 1
Q = N
M1 = M11 - 1
IF (M1 .EQ. 0) GO TO 75
ISTURM = 1
50 V = X1
X1 = XU + (X0 - XU) * 0.5E0
IF (X1 .EQ. V) GO TO 980
GO TO 320
60 IF (S - M1) 65, 73, 70
65 XU = X1
GO TO 50
70 X0 = X1
GO TO 50
73 XU = X1
T1 = X1
75 M22 = M1 + M
IF (M22 .EQ. N) GO TO 90
X0 = T2
ISTURM = 2
GO TO 50
80 IF (S - M22) 65, 85, 70
85 T2 = X1
90 Q = 0
R = 0
C .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING
C INTERVAL BY THE GERSCHGORIN BOUNDS ..........
100 IF (R .EQ. M) GO TO 1001
TAG = TAG + 1
P = Q + 1
XU = D(P)
X0 = D(P)
U = 0.0E0
C
DO 120 Q = P, N
X1 = U
U = 0.0E0
V = 0.0E0
IF (Q .EQ. N) GO TO 110
U = ABS(E(Q+1))
V = E2(Q+1)
110 XU = AMIN1(D(Q)-(X1+U),XU)
X0 = AMAX1(D(Q)+(X1+U),X0)
IF (V .EQ. 0.0E0) GO TO 140
120 CONTINUE
* INCREMENT OPCOUNT FOR REFINING INTERVAL.
OPS = OPS + ( N-P+1 )*2
C
140 X1 = EPSLON(AMAX1(ABS(XU),ABS(X0)))
IF (EPS1 .LE. 0.0E0) EPS1 = -X1
IF (P .NE. Q) GO TO 180
C .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL ..........
IF (T1 .GT. D(P) .OR. D(P) .GE. T2) GO TO 940
M1 = P
M2 = P
RV5(P) = D(P)
GO TO 900
180 X1 = X1 * (Q - P + 1)
LB = AMAX1(T1,XU-X1)
UB = AMIN1(T2,X0+X1)
X1 = LB
ISTURM = 3
GO TO 320
200 M1 = S + 1
X1 = UB
ISTURM = 4
GO TO 320
220 M2 = S
IF (M1 .GT. M2) GO TO 940
C .......... FIND ROOTS BY BISECTION ..........
X0 = UB
ISTURM = 5
C
DO 240 I = M1, M2
RV5(I) = UB
RV4(I) = LB
240 CONTINUE
C .......... LOOP FOR K-TH EIGENVALUE
C FOR K=M2 STEP -1 UNTIL M1 DO --
C (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) ..........
K = M2
250 XU = LB
C .......... FOR I=K STEP -1 UNTIL M1 DO -- ..........
DO 260 II = M1, K
I = M1 + K - II
IF (XU .GE. RV4(I)) GO TO 260
XU = RV4(I)
GO TO 280
260 CONTINUE
C
280 IF (X0 .GT. RV5(K)) X0 = RV5(K)
C .......... NEXT BISECTION STEP ..........
300 X1 = (XU + X0) * 0.5E0
CCC IF ((X0 - XU) .LE. ABS(EPS1)) GO TO 420
CCC TST1 = 2.0E0 * (ABS(XU) + ABS(X0))
CCC TST2 = TST1 + (X0 - XU)
CCC IF (TST2 .EQ. TST1) GO TO 420
TMP1 = ABS( X0 - XU )
TMP2 = MAX( ABS( X0 ), ABS( XU ) )
IF( TMP1.LT.MAX( ATOLI, PIVMIN, RTOLI*TMP2 ) )
$ GO TO 420
C .......... IN-LINE PROCEDURE FOR STURM SEQUENCE ..........
320 S = P - 1
U = 1.0E0
C
DO 340 I = P, Q
IF (U .NE. 0.0E0) GO TO 325
V = ABS(E(I)) / EPSLON(1.0E0)
IF (E2(I) .EQ. 0.0E0) V = 0.0E0
GO TO 330
325 V = E2(I) / U
330 U = D(I) - X1 - V
IF (U .LT. 0.0E0) S = S + 1
340 CONTINUE
* INCREMENT OPCOUNT FOR STURM SEQUENCE.
OPS = OPS + ( Q-P+1 )*3
* INCREMENT ITERATION COUNTER.
ITCNT = ITCNT + 1
C
GO TO (60,80,200,220,360), ISTURM
C .......... REFINE INTERVALS ..........
360 IF (S .GE. K) GO TO 400
XU = X1
IF (S .GE. M1) GO TO 380
RV4(M1) = X1
GO TO 300
380 RV4(S+1) = X1
IF (RV5(S) .GT. X1) RV5(S) = X1
GO TO 300
400 X0 = X1
GO TO 300
C .......... K-TH EIGENVALUE FOUND ..........
420 RV5(K) = X1
K = K - 1
IF (K .GE. M1) GO TO 250
C .......... ORDER EIGENVALUES TAGGED WITH THEIR
C SUBMATRIX ASSOCIATIONS ..........
900 S = R
R = R + M2 - M1 + 1
J = 1
K = M1
C
DO 920 L = 1, R
IF (J .GT. S) GO TO 910
IF (K .GT. M2) GO TO 940
IF (RV5(K) .GE. W(L)) GO TO 915
C
DO 905 II = J, S
I = L + S - II
W(I+1) = W(I)
IND(I+1) = IND(I)
905 CONTINUE
C
910 W(L) = RV5(K)
IND(L) = TAG
K = K + 1
GO TO 920
915 J = J + 1
920 CONTINUE
C
940 IF (Q .LT. N) GO TO 100
GO TO 1001
C .......... SET ERROR -- INTERVAL CANNOT BE FOUND CONTAINING
C EXACTLY THE DESIRED EIGENVALUES ..........
980 IERR = 3 * N + ISTURM
1001 LB = T1
UB = T2
RETURN
END
SUBROUTINE SSVDC(X,LDX,N,P,S,E,U,LDU,V,LDV,WORK,JOB,INFO)
INTEGER LDX,N,P,LDU,LDV,JOB,INFO
REAL X(LDX,*),S(*),E(*),U(LDU,*),V(LDV,*),WORK(*)
*
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT
* ITCNT IS INITIALIZED TO 0, IOPS IS ONLY INCREMENTED
* IOPST IS USED TO ACCUMULATE SMALL CONTRIBUTIONS TO IOPS
* TO AVOID ROUNDOFF ERROR
* .. COMMON BLOCKS ..
COMMON /LATIME/ IOPS, ITCNT
* ..
* .. SCALARS IN COMMON ..
REAL IOPS, ITCNT, IOPST
* ..
C
C
C SSVDC IS A SUBROUTINE TO REDUCE A REAL NXP MATRIX X BY
C ORTHOGONAL TRANSFORMATIONS U AND V TO DIAGONAL FORM. THE
C DIAGONAL ELEMENTS S(I) ARE THE SINGULAR VALUES OF X. THE
C COLUMNS OF U ARE THE CORRESPONDING LEFT SINGULAR VECTORS,
C AND THE COLUMNS OF V THE RIGHT SINGULAR VECTORS.
C
C ON ENTRY
C
C X REAL(LDX,P), WHERE LDX.GE.N.
C X CONTAINS THE MATRIX WHOSE SINGULAR VALUE
C DECOMPOSITION IS TO BE COMPUTED. X IS
C DESTROYED BY SSVDC.
C
C LDX INTEGER.
C LDX IS THE LEADING DIMENSION OF THE ARRAY X.
C
C N INTEGER.
C N IS THE NUMBER OF ROWS OF THE MATRIX X.
C
C P INTEGER.
C P IS THE NUMBER OF COLUMNS OF THE MATRIX X.
C
C LDU INTEGER.
C LDU IS THE LEADING DIMENSION OF THE ARRAY U.
C (SEE BELOW).
C
C LDV INTEGER.
C LDV IS THE LEADING DIMENSION OF THE ARRAY V.
C (SEE BELOW).
C
C WORK REAL(N).
C WORK IS A SCRATCH ARRAY.
C
C JOB INTEGER.
C JOB CONTROLS THE COMPUTATION OF THE SINGULAR
C VECTORS. IT HAS THE DECIMAL EXPANSION AB
C WITH THE FOLLOWING MEANING
C
C A.EQ.0 DO NOT COMPUTE THE LEFT SINGULAR
C VECTORS.
C A.EQ.1 RETURN THE N LEFT SINGULAR VECTORS
C IN U.
C A.GE.2 RETURN THE FIRST MIN(N,P) SINGULAR
C VECTORS IN U.
C B.EQ.0 DO NOT COMPUTE THE RIGHT SINGULAR
C VECTORS.
C B.EQ.1 RETURN THE RIGHT SINGULAR VECTORS
C IN V.
C
C ON RETURN
C
C S REAL(MM), WHERE MM=MIN(N+1,P).
C THE FIRST MIN(N,P) ENTRIES OF S CONTAIN THE
C SINGULAR VALUES OF X ARRANGED IN DESCENDING
C ORDER OF MAGNITUDE.
C
C E REAL(P).
C E ORDINARILY CONTAINS ZEROS. HOWEVER SEE THE
C DISCUSSION OF INFO FOR EXCEPTIONS.
C
C U REAL(LDU,K), WHERE LDU.GE.N. IF JOBA.EQ.1 THEN
C K.EQ.N, IF JOBA.GE.2 THEN
C K.EQ.MIN(N,P).
C U CONTAINS THE MATRIX OF LEFT SINGULAR VECTORS.
C U IS NOT REFERENCED IF JOBA.EQ.0. IF N.LE.P
C OR IF JOBA.EQ.2, THEN U MAY BE IDENTIFIED WITH X
C IN THE SUBROUTINE CALL.
C
C V REAL(LDV,P), WHERE LDV.GE.P.
C V CONTAINS THE MATRIX OF RIGHT SINGULAR VECTORS.
C V IS NOT REFERENCED IF JOB.EQ.0. IF P.LE.N,
C THEN V MAY BE IDENTIFIED WITH X IN THE
C SUBROUTINE CALL.
C
C INFO INTEGER.
C THE SINGULAR VALUES (AND THEIR CORRESPONDING
C SINGULAR VECTORS) S(INFO+1),S(INFO+2),...,S(M)
C ARE CORRECT (HERE M=MIN(N,P)). THUS IF
C INFO.EQ.0, ALL THE SINGULAR VALUES AND THEIR
C VECTORS ARE CORRECT. IN ANY EVENT, THE MATRIX
C B = TRANS(U)*X*V IS THE BIDIAGONAL MATRIX
C WITH THE ELEMENTS OF S ON ITS DIAGONAL AND THE
C ELEMENTS OF E ON ITS SUPER-DIAGONAL (TRANS(U)
C IS THE TRANSPOSE OF U). THUS THE SINGULAR
C VALUES OF X AND B ARE THE SAME.
C
C LINPACK. THIS VERSION DATED 03/19/79 .
C CORRECTION TO SHIFT CALCULATION MADE 2/85.
C G.W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB.
C
C ***** USES THE FOLLOWING FUNCTIONS AND SUBPROGRAMS.
C
C EXTERNAL SROT
C BLAS SAXPY,SDOT,SSCAL,SSWAP,SNRM2,SROTG
C FORTRAN ABS,AMAX1,MAX0,MIN0,MOD,SQRT
C
C INTERNAL VARIABLES
C
INTEGER I,ITER,J,JOBU,K,KASE,KK,L,LL,LLS,LM1,LP1,LS,LU,M,MAXIT,
* MM,MM1,MP1,NCT,NCTP1,NCU,NRT,NRTP1
REAL SDOT,T
REAL B,C,CS,EL,EMM1,F,G,SNRM2,SCALE,SHIFT,SL,SM,SN,SMM1,T1,TEST
* REAL ZTEST,R
LOGICAL WANTU,WANTV
*
* GET EPS FROM SLAMCH FOR NEW STOPPING CRITERION
EXTERNAL SLAMCH
REAL SLAMCH, EPS
IF (N.LE.0 .OR. P.LE.0) RETURN
EPS = SLAMCH( 'EPSILON' )
*
C
C
C SET THE MAXIMUM NUMBER OF ITERATIONS.
C
MAXIT = 50
C
C DETERMINE WHAT IS TO BE COMPUTED.
C
WANTU = .FALSE.
WANTV = .FALSE.
JOBU = MOD(JOB,100)/10
NCU = N
IF (JOBU .GT. 1) NCU = MIN0(N,P)
IF (JOBU .NE. 0) WANTU = .TRUE.
IF (MOD(JOB,10) .NE. 0) WANTV = .TRUE.
C
C REDUCE X TO BIDIAGONAL FORM, STORING THE DIAGONAL ELEMENTS
C IN S AND THE SUPER-DIAGONAL ELEMENTS IN E.
C
*
* INITIALIZE OP COUNT
IOPST = 0
INFO = 0
NCT = MIN0(N-1,P)
NRT = MAX0(0,MIN0(P-2,N))
LU = MAX0(NCT,NRT)
IF (LU .LT. 1) GO TO 170
DO 160 L = 1, LU
LP1 = L + 1
IF (L .GT. NCT) GO TO 20
C
C COMPUTE THE TRANSFORMATION FOR THE L-TH COLUMN AND
C PLACE THE L-TH DIAGONAL IN S(L).
C
*
* INCREMENT OP COUNT
IOPS = IOPS + (2*(N-L+1)+1)
S(L) = SNRM2(N-L+1,X(L,L),1)
IF (S(L) .EQ. 0.0E0) GO TO 10
IF (X(L,L) .NE. 0.0E0) S(L) = SIGN(S(L),X(L,L))
*
* INCREMENT OP COUNT
IOPS = IOPS + (N-L+3)
CALL SSCAL(N-L+1,1.0E0/S(L),X(L,L),1)
X(L,L) = 1.0E0 + X(L,L)
10 CONTINUE
S(L) = -S(L)
20 CONTINUE
IF (P .LT. LP1) GO TO 50
DO 40 J = LP1, P
IF (L .GT. NCT) GO TO 30
IF (S(L) .EQ. 0.0E0) GO TO 30
C
C APPLY THE TRANSFORMATION.
C
*
* INCREMENT OP COUNT
IOPS = IOPS + (4*(N-L)+5)
T = -SDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L)
CALL SAXPY(N-L+1,T,X(L,L),1,X(L,J),1)
30 CONTINUE
C
C PLACE THE L-TH ROW OF X INTO E FOR THE
C SUBSEQUENT CALCULATION OF THE ROW TRANSFORMATION.
C
E(J) = X(L,J)
40 CONTINUE
50 CONTINUE
IF (.NOT.WANTU .OR. L .GT. NCT) GO TO 70
C
C PLACE THE TRANSFORMATION IN U FOR SUBSEQUENT BACK
C MULTIPLICATION.
C
DO 60 I = L, N
U(I,L) = X(I,L)
60 CONTINUE
70 CONTINUE
IF (L .GT. NRT) GO TO 150
C
C COMPUTE THE L-TH ROW TRANSFORMATION AND PLACE THE
C L-TH SUPER-DIAGONAL IN E(L).
C
*
* INCREMENT OP COUNT
IOPS = IOPS + (2*(P-L)+1)
E(L) = SNRM2(P-L,E(LP1),1)
IF (E(L) .EQ. 0.0E0) GO TO 80
IF (E(LP1) .NE. 0.0E0) E(L) = SIGN(E(L),E(LP1))
*
* INCREMENT OP COUNT
IOPS = IOPS + (P-L+2)
CALL SSCAL(P-L,1.0E0/E(L),E(LP1),1)
E(LP1) = 1.0E0 + E(LP1)
80 CONTINUE
E(L) = -E(L)
IF (LP1 .GT. N .OR. E(L) .EQ. 0.0E0) GO TO 120
C
C APPLY THE TRANSFORMATION.
C
DO 90 I = LP1, N
WORK(I) = 0.0E0
90 CONTINUE
*
* INCREMENT OP COUNT
IOPS = IOPS + FLOAT(4*(N-L)+1)*(P-L)
DO 100 J = LP1, P
CALL SAXPY(N-L,E(J),X(LP1,J),1,WORK(LP1),1)
100 CONTINUE
DO 110 J = LP1, P
CALL SAXPY(N-L,-E(J)/E(LP1),WORK(LP1),1,X(LP1,J),1)
110 CONTINUE
120 CONTINUE
IF (.NOT.WANTV) GO TO 140
C
C PLACE THE TRANSFORMATION IN V FOR SUBSEQUENT
C BACK MULTIPLICATION.
C
DO 130 I = LP1, P
V(I,L) = E(I)
130 CONTINUE
140 CONTINUE
150 CONTINUE
160 CONTINUE
170 CONTINUE
C
C SET UP THE FINAL BIDIAGONAL MATRIX OR ORDER M.
C
M = MIN0(P,N+1)
NCTP1 = NCT + 1
NRTP1 = NRT + 1
IF (NCT .LT. P) S(NCTP1) = X(NCTP1,NCTP1)
IF (N .LT. M) S(M) = 0.0E0
IF (NRTP1 .LT. M) E(NRTP1) = X(NRTP1,M)
E(M) = 0.0E0
C
C IF REQUIRED, GENERATE U.
C
IF (.NOT.WANTU) GO TO 300
IF (NCU .LT. NCTP1) GO TO 200
DO 190 J = NCTP1, NCU
DO 180 I = 1, N
U(I,J) = 0.0E0
180 CONTINUE
U(J,J) = 1.0E0
190 CONTINUE
200 CONTINUE
IF (NCT .LT. 1) GO TO 290
DO 280 LL = 1, NCT
L = NCT - LL + 1
IF (S(L) .EQ. 0.0E0) GO TO 250
LP1 = L + 1
IF (NCU .LT. LP1) GO TO 220
*
* INCREMENT OP COUNT
IOPS = IOPS + (FLOAT(4*(N-L)+5)*(NCU-L)+(N-L+2))
DO 210 J = LP1, NCU
T = -SDOT(N-L+1,U(L,L),1,U(L,J),1)/U(L,L)
CALL SAXPY(N-L+1,T,U(L,L),1,U(L,J),1)
210 CONTINUE
220 CONTINUE
CALL SSCAL(N-L+1,-1.0E0,U(L,L),1)
U(L,L) = 1.0E0 + U(L,L)
LM1 = L - 1
IF (LM1 .LT. 1) GO TO 240
DO 230 I = 1, LM1
U(I,L) = 0.0E0
230 CONTINUE
240 CONTINUE
GO TO 270
250 CONTINUE
DO 260 I = 1, N
U(I,L) = 0.0E0
260 CONTINUE
U(L,L) = 1.0E0
270 CONTINUE
280 CONTINUE
290 CONTINUE
300 CONTINUE
C
C IF IT IS REQUIRED, GENERATE V.
C
IF (.NOT.WANTV) GO TO 350
DO 340 LL = 1, P
L = P - LL + 1
LP1 = L + 1
IF (L .GT. NRT) GO TO 320
IF (E(L) .EQ. 0.0E0) GO TO 320
*
* INCREMENT OP COUNT
IOPS = IOPS + FLOAT(4*(P-L)+1)*(P-L)
DO 310 J = LP1, P
T = -SDOT(P-L,V(LP1,L),1,V(LP1,J),1)/V(LP1,L)
CALL SAXPY(P-L,T,V(LP1,L),1,V(LP1,J),1)
310 CONTINUE
320 CONTINUE
DO 330 I = 1, P
V(I,L) = 0.0E0
330 CONTINUE
V(L,L) = 1.0E0
340 CONTINUE
350 CONTINUE
C
C MAIN ITERATION LOOP FOR THE SINGULAR VALUES.
C
MM = M
*
* INITIALIZE ITERATION COUNTER
ITCNT = 0
ITER = 0
360 CONTINUE
C
C QUIT IF ALL THE SINGULAR VALUES HAVE BEEN FOUND.
C
C ...EXIT
IF (M .EQ. 0) GO TO 620
C
C IF TOO MANY ITERATIONS HAVE BEEN PERFORMED, SET
C FLAG AND RETURN.
C
*
* UPDATE ITERATION COUNTER
ITCNT = ITER
IF (ITER .LT. MAXIT) GO TO 370
INFO = M
C ......EXIT
GO TO 620
370 CONTINUE
C
C THIS SECTION OF THE PROGRAM INSPECTS FOR
C NEGLIGIBLE ELEMENTS IN THE S AND E ARRAYS. ON
C COMPLETION THE VARIABLES KASE AND L ARE SET AS FOLLOWS.
C
C KASE = 1 IF S(M) AND E(L-1) ARE NEGLIGIBLE AND L.LT.M
C KASE = 2 IF S(L) IS NEGLIGIBLE AND L.LT.M
C KASE = 3 IF E(L-1) IS NEGLIGIBLE, L.LT.M, AND
C S(L), ..., S(M) ARE NOT NEGLIGIBLE (QR STEP).
C KASE = 4 IF E(M-1) IS NEGLIGIBLE (CONVERGENCE).
C
DO 390 LL = 1, M
L = M - LL
C ...EXIT
IF (L .EQ. 0) GO TO 400
*
* INCREMENT OP COUNT
IOPST = IOPST + 2
TEST = ABS(S(L)) + ABS(S(L+1))
*
* REPLACE STOPPING CRITERION WITH NEW ONE AS IN LAPACK
*
* ZTEST = TEST + ABS(E(L))
* IF (ZTEST .NE. TEST) GO TO 380
IF (ABS(E(L)) .GT. EPS * TEST) GOTO 380
*
E(L) = 0.0E0
C ......EXIT
GO TO 400
380 CONTINUE
390 CONTINUE
400 CONTINUE
IF (L .NE. M - 1) GO TO 410
KASE = 4
GO TO 480
410 CONTINUE
LP1 = L + 1
MP1 = M + 1
DO 430 LLS = LP1, MP1
LS = M - LLS + LP1
C ...EXIT
IF (LS .EQ. L) GO TO 440
TEST = 0.0E0
*
* INCREMENT OP COUNT
IOPST = IOPST + 3
IF (LS .NE. M) TEST = TEST + ABS(E(LS))
IF (LS .NE. L + 1) TEST = TEST + ABS(E(LS-1))
*
* REPLACE STOPPING CRITERION WITH NEW ONE AS IN LAPACK
*
* ZTEST = TEST + ABS(S(LS))
* IF (ZTEST .NE. TEST) GO TO 420
IF (ABS(S(LS)) .GT. EPS * TEST) GOTO 420
*
S(LS) = 0.0E0
C ......EXIT
GO TO 440
420 CONTINUE
430 CONTINUE
440 CONTINUE
IF (LS .NE. L) GO TO 450
KASE = 3
GO TO 470
450 CONTINUE
IF (LS .NE. M) GO TO 460
KASE = 1
GO TO 470
460 CONTINUE
KASE = 2
L = LS
470 CONTINUE
480 CONTINUE
L = L + 1
C
C PERFORM THE TASK INDICATED BY KASE.
C
GO TO (490,520,540,570), KASE
C
C DEFLATE NEGLIGIBLE S(M).
C
490 CONTINUE
MM1 = M - 1
F = E(M-1)
E(M-1) = 0.0E0
*
* INCREMENT OP COUNT
IOPS = IOPS + ((MM1-L+1)*13 - 2)
IF (WANTV) IOPS = IOPS + FLOAT(MM1-L+1)*6*P
DO 510 KK = L, MM1
K = MM1 - KK + L
T1 = S(K)
CALL SROTG(T1,F,CS,SN)
S(K) = T1
IF (K .EQ. L) GO TO 500
F = -SN*E(K-1)
E(K-1) = CS*E(K-1)
500 CONTINUE
IF (WANTV) CALL SROT(P,V(1,K),1,V(1,M),1,CS,SN)
510 CONTINUE
GO TO 610
C
C SPLIT AT NEGLIGIBLE S(L).
C
520 CONTINUE
F = E(L-1)
E(L-1) = 0.0E0
*
* INCREMENT OP COUNT
IOPS = IOPS + (M-L+1)*13
IF (WANTU) IOPS = IOPS + FLOAT(M-L+1)*6*N
DO 530 K = L, M
T1 = S(K)
CALL SROTG(T1,F,CS,SN)
S(K) = T1
F = -SN*E(K)
E(K) = CS*E(K)
IF (WANTU) CALL SROT(N,U(1,K),1,U(1,L-1),1,CS,SN)
530 CONTINUE
GO TO 610
C
C PERFORM ONE QR STEP.
C
540 CONTINUE
C
C CALCULATE THE SHIFT.
C
*
* INCREMENT OP COUNT
IOPST = IOPST + 23
SCALE = AMAX1(ABS(S(M)),ABS(S(M-1)),ABS(E(M-1)),ABS(S(L)),
* ABS(E(L)))
SM = S(M)/SCALE
SMM1 = S(M-1)/SCALE
EMM1 = E(M-1)/SCALE
SL = S(L)/SCALE
EL = E(L)/SCALE
B = ((SMM1 + SM)*(SMM1 - SM) + EMM1**2)/2.0E0
C = (SM*EMM1)**2
SHIFT = 0.0E0
IF (B .EQ. 0.0E0 .AND. C .EQ. 0.0E0) GO TO 550
SHIFT = SQRT(B**2+C)
IF (B .LT. 0.0E0) SHIFT = -SHIFT
SHIFT = C/(B + SHIFT)
550 CONTINUE
F = (SL + SM)*(SL - SM) + SHIFT
G = SL*EL
C
C CHASE ZEROS.
C
MM1 = M - 1
*
* INCREMENT OP COUNT
IOPS = IOPS + (MM1-L+1)*38
IF (WANTV) IOPS = IOPS+FLOAT(MM1-L+1)*6*P
IF (WANTU) IOPS = IOPS+FLOAT(MAX((MIN(MM1,N-1)-L+1),0))*6*N
DO 560 K = L, MM1
CALL SROTG(F,G,CS,SN)
IF (K .NE. L) E(K-1) = F
F = CS*S(K) + SN*E(K)
E(K) = CS*E(K) - SN*S(K)
G = SN*S(K+1)
S(K+1) = CS*S(K+1)
IF (WANTV) CALL SROT(P,V(1,K),1,V(1,K+1),1,CS,SN)
CALL SROTG(F,G,CS,SN)
S(K) = F
F = CS*E(K) + SN*S(K+1)
S(K+1) = -SN*E(K) + CS*S(K+1)
G = SN*E(K+1)
E(K+1) = CS*E(K+1)
IF (WANTU .AND. K .LT. N)
* CALL SROT(N,U(1,K),1,U(1,K+1),1,CS,SN)
560 CONTINUE
E(M-1) = F
ITER = ITER + 1
GO TO 610
C
C CONVERGENCE.
C
570 CONTINUE
C
C MAKE THE SINGULAR VALUE POSITIVE.
C
IF (S(L) .GE. 0.0E0) GO TO 580
S(L) = -S(L)
*
* INCREMENT OP COUNT
IF (WANTV) IOPS = IOPS + P
IF (WANTV) CALL SSCAL(P,-1.0E0,V(1,L),1)
580 CONTINUE
C
C ORDER THE SINGULAR VALUE.
C
590 IF (L .EQ. MM) GO TO 600
C ...EXIT
IF (S(L) .GE. S(L+1)) GO TO 600
T = S(L)
S(L) = S(L+1)
S(L+1) = T
IF (WANTV .AND. L .LT. P)
* CALL SSWAP(P,V(1,L),1,V(1,L+1),1)
IF (WANTU .AND. L .LT. N)
* CALL SSWAP(N,U(1,L),1,U(1,L+1),1)
L = L + 1
GO TO 590
600 CONTINUE
ITER = 0
M = M - 1
610 CONTINUE
GO TO 360
620 CONTINUE
*
* COMPUTE FINAL OPCOUNT
IOPS = IOPS + IOPST
RETURN
END
SUBROUTINE QZHES(NM,N,A,B,MATZ,Z)
C
INTEGER I,J,K,L,N,LB,L1,NM,NK1,NM1,NM2
REAL A(NM,N),B(NM,N),Z(NM,N)
REAL R,S,T,U1,U2,V1,V2,RHO
LOGICAL MATZ
*
* ---------------------- BEGIN TIMING CODE -------------------------
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT
* ITCNT IS INITIALIZED TO 0, OPS IS ONLY INCREMENTED
* OPST IS USED TO ACCUMULATE SMALL CONTRIBUTIONS TO OPS
* TO AVOID ROUNDOFF ERROR
* .. COMMON BLOCKS ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. SCALARS IN COMMON ..
REAL ITCNT, OPS
* ..
* ----------------------- END TIMING CODE --------------------------
*
C
C THIS SUBROUTINE IS THE FIRST STEP OF THE QZ ALGORITHM
C FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS,
C SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART.
C
C THIS SUBROUTINE ACCEPTS A PAIR OF REAL GENERAL MATRICES AND
C REDUCES ONE OF THEM TO UPPER HESSENBERG FORM AND THE OTHER
C TO UPPER TRIANGULAR FORM USING ORTHOGONAL TRANSFORMATIONS.
C IT IS USUALLY FOLLOWED BY QZIT, QZVAL AND, POSSIBLY, QZVEC.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRICES.
C
C A CONTAINS A REAL GENERAL MATRIX.
C
C B CONTAINS A REAL GENERAL MATRIX.
C
C MATZ SHOULD BE SET TO .TRUE. IF THE RIGHT HAND TRANSFORMATIONS
C ARE TO BE ACCUMULATED FOR LATER USE IN COMPUTING
C EIGENVECTORS, AND TO .FALSE. OTHERWISE.
C
C ON OUTPUT
C
C A HAS BEEN REDUCED TO UPPER HESSENBERG FORM. THE ELEMENTS
C BELOW THE FIRST SUBDIAGONAL HAVE BEEN SET TO ZERO.
C
C B HAS BEEN REDUCED TO UPPER TRIANGULAR FORM. THE ELEMENTS
C BELOW THE MAIN DIAGONAL HAVE BEEN SET TO ZERO.
C
C Z CONTAINS THE PRODUCT OF THE RIGHT HAND TRANSFORMATIONS IF
C MATZ HAS BEEN SET TO .TRUE. OTHERWISE, Z IS NOT REFERENCED.
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
C
C .......... INITIALIZE Z ..........
IF (.NOT. MATZ) GO TO 10
C
DO 3 J = 1, N
C
DO 2 I = 1, N
Z(I,J) = 0.0E0
2 CONTINUE
C
Z(J,J) = 1.0E0
3 CONTINUE
C .......... REDUCE B TO UPPER TRIANGULAR FORM ..........
10 IF (N .LE. 1) GO TO 170
NM1 = N - 1
C
DO 100 L = 1, NM1
L1 = L + 1
S = 0.0E0
C
DO 20 I = L1, N
S = S + ABS(B(I,L))
20 CONTINUE
C
IF (S .EQ. 0.0E0) GO TO 100
S = S + ABS(B(L,L))
R = 0.0E0
C
DO 25 I = L, N
B(I,L) = B(I,L) / S
R = R + B(I,L)**2
25 CONTINUE
C
R = SIGN(SQRT(R),B(L,L))
B(L,L) = B(L,L) + R
RHO = R * B(L,L)
C
DO 50 J = L1, N
T = 0.0E0
C
DO 30 I = L, N
T = T + B(I,L) * B(I,J)
30 CONTINUE
C
T = -T / RHO
C
DO 40 I = L, N
B(I,J) = B(I,J) + T * B(I,L)
40 CONTINUE
C
50 CONTINUE
C
DO 80 J = 1, N
T = 0.0E0
C
DO 60 I = L, N
T = T + B(I,L) * A(I,J)
60 CONTINUE
C
T = -T / RHO
C
DO 70 I = L, N
A(I,J) = A(I,J) + T * B(I,L)
70 CONTINUE
C
80 CONTINUE
C
B(L,L) = -S * R
C
DO 90 I = L1, N
B(I,L) = 0.0E0
90 CONTINUE
C
100 CONTINUE
*
* ---------------------- BEGIN TIMING CODE -------------------------
OPS = OPS + REAL( 8*N**2 + 17*N + 24 )*REAL( N-1 ) / 3.0E0
* ----------------------- END TIMING CODE --------------------------
*
C .......... REDUCE A TO UPPER HESSENBERG FORM, WHILE
C KEEPING B TRIANGULAR ..........
IF (N .EQ. 2) GO TO 170
NM2 = N - 2
C
DO 160 K = 1, NM2
NK1 = NM1 - K
C .......... FOR L=N-1 STEP -1 UNTIL K+1 DO -- ..........
DO 150 LB = 1, NK1
L = N - LB
L1 = L + 1
C .......... ZERO A(L+1,K) ..........
S = ABS(A(L,K)) + ABS(A(L1,K))
IF (S .EQ. 0.0E0) GO TO 150
U1 = A(L,K) / S
U2 = A(L1,K) / S
R = SIGN(SQRT(U1*U1+U2*U2),U1)
V1 = -(U1 + R) / R
V2 = -U2 / R
U2 = V2 / V1
C
DO 110 J = K, N
T = A(L,J) + U2 * A(L1,J)
A(L,J) = A(L,J) + T * V1
A(L1,J) = A(L1,J) + T * V2
110 CONTINUE
C
A(L1,K) = 0.0E0
C
DO 120 J = L, N
T = B(L,J) + U2 * B(L1,J)
B(L,J) = B(L,J) + T * V1
B(L1,J) = B(L1,J) + T * V2
120 CONTINUE
C .......... ZERO B(L+1,L) ..........
S = ABS(B(L1,L1)) + ABS(B(L1,L))
IF (S .EQ. 0.0E0) GO TO 150
U1 = B(L1,L1) / S
U2 = B(L1,L) / S
R = SIGN(SQRT(U1*U1+U2*U2),U1)
V1 = -(U1 + R) / R
V2 = -U2 / R
U2 = V2 / V1
C
DO 130 I = 1, L1
T = B(I,L1) + U2 * B(I,L)
B(I,L1) = B(I,L1) + T * V1
B(I,L) = B(I,L) + T * V2
130 CONTINUE
C
B(L1,L) = 0.0E0
C
DO 140 I = 1, N
T = A(I,L1) + U2 * A(I,L)
A(I,L1) = A(I,L1) + T * V1
A(I,L) = A(I,L) + T * V2
140 CONTINUE
C
IF (.NOT. MATZ) GO TO 150
C
DO 145 I = 1, N
T = Z(I,L1) + U2 * Z(I,L)
Z(I,L1) = Z(I,L1) + T * V1
Z(I,L) = Z(I,L) + T * V2
145 CONTINUE
C
150 CONTINUE
C
160 CONTINUE
C
*
* ---------------------- BEGIN TIMING CODE -------------------------
IF( MATZ ) THEN
OPS = OPS + REAL( 11*N + 20 )*REAL( N-1 )*REAL( N-2 )
ELSE
OPS = OPS + REAL( 8*N + 20 )*REAL( N-1 )*REAL( N-2 )
END IF
* ----------------------- END TIMING CODE --------------------------
*
170 RETURN
END
SUBROUTINE QZIT(NM,N,A,B,EPS1,MATZ,Z,IERR)
C
INTEGER I,J,K,L,N,EN,K1,K2,LD,LL,L1,NA,NM,ISH,ITN,ITS,KM1,LM1,
X ENM2,IERR,LOR1,ENORN
REAL A(NM,N),B(NM,N),Z(NM,N)
REAL R,S,T,A1,A2,A3,EP,SH,U1,U2,U3,V1,V2,V3,ANI,A11,
X A12,A21,A22,A33,A34,A43,A44,BNI,B11,B12,B22,B33,B34,
X B44,EPSA,EPSB,EPS1,ANORM,BNORM,EPSLON
LOGICAL MATZ,NOTLAS
*
* ---------------------- BEGIN TIMING CODE -------------------------
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT
* ITCNT IS INITIALIZED TO 0, OPS IS ONLY INCREMENTED
* OPST IS USED TO ACCUMULATE SMALL CONTRIBUTIONS TO OPS
* TO AVOID ROUNDOFF ERROR
* .. COMMON BLOCKS ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. SCALARS IN COMMON ..
REAL ITCNT, OPS
* ..
REAL OPST
* ----------------------- END TIMING CODE --------------------------
*
C
C THIS SUBROUTINE IS THE SECOND STEP OF THE QZ ALGORITHM
C FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS,
C SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART,
C AS MODIFIED IN TECHNICAL NOTE NASA TN D-7305(1973) BY WARD.
C
C THIS SUBROUTINE ACCEPTS A PAIR OF REAL MATRICES, ONE OF THEM
C IN UPPER HESSENBERG FORM AND THE OTHER IN UPPER TRIANGULAR FORM.
C IT REDUCES THE HESSENBERG MATRIX TO QUASI-TRIANGULAR FORM USING
C ORTHOGONAL TRANSFORMATIONS WHILE MAINTAINING THE TRIANGULAR FORM
C OF THE OTHER MATRIX. IT IS USUALLY PRECEDED BY QZHES AND
C FOLLOWED BY QZVAL AND, POSSIBLY, QZVEC.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRICES.
C
C A CONTAINS A REAL UPPER HESSENBERG MATRIX.
C
C B CONTAINS A REAL UPPER TRIANGULAR MATRIX.
C
C EPS1 IS A TOLERANCE USED TO DETERMINE NEGLIGIBLE ELEMENTS.
C EPS1 = 0.0 (OR NEGATIVE) MAY BE INPUT, IN WHICH CASE AN
C ELEMENT WILL BE NEGLECTED ONLY IF IT IS LESS THAN ROUNDOFF
C ERROR TIMES THE NORM OF ITS MATRIX. IF THE INPUT EPS1 IS
C POSITIVE, THEN AN ELEMENT WILL BE CONSIDERED NEGLIGIBLE
C IF IT IS LESS THAN EPS1 TIMES THE NORM OF ITS MATRIX. A
C POSITIVE VALUE OF EPS1 MAY RESULT IN FASTER EXECUTION,
C BUT LESS ACCURATE RESULTS.
C
C MATZ SHOULD BE SET TO .TRUE. IF THE RIGHT HAND TRANSFORMATIONS
C ARE TO BE ACCUMULATED FOR LATER USE IN COMPUTING
C EIGENVECTORS, AND TO .FALSE. OTHERWISE.
C
C Z CONTAINS, IF MATZ HAS BEEN SET TO .TRUE., THE
C TRANSFORMATION MATRIX PRODUCED IN THE REDUCTION
C BY QZHES, IF PERFORMED, OR ELSE THE IDENTITY MATRIX.
C IF MATZ HAS BEEN SET TO .FALSE., Z IS NOT REFERENCED.
C
C ON OUTPUT
C
C A HAS BEEN REDUCED TO QUASI-TRIANGULAR FORM. THE ELEMENTS
C BELOW THE FIRST SUBDIAGONAL ARE STILL ZERO AND NO TWO
C CONSECUTIVE SUBDIAGONAL ELEMENTS ARE NONZERO.
C
C B IS STILL IN UPPER TRIANGULAR FORM, ALTHOUGH ITS ELEMENTS
C HAVE BEEN ALTERED. THE LOCATION B(N,1) IS USED TO STORE
C EPS1 TIMES THE NORM OF B FOR LATER USE BY QZVAL AND QZVEC.
C
C Z CONTAINS THE PRODUCT OF THE RIGHT HAND TRANSFORMATIONS
C (FOR BOTH STEPS) IF MATZ HAS BEEN SET TO .TRUE..
C
C IERR IS SET TO
C ZERO FOR NORMAL RETURN,
C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
C
IERR = 0
C .......... COMPUTE EPSA,EPSB ..........
ANORM = 0.0E0
BNORM = 0.0E0
C
DO 30 I = 1, N
ANI = 0.0E0
IF (I .NE. 1) ANI = ABS(A(I,I-1))
BNI = 0.0E0
C
DO 20 J = I, N
ANI = ANI + ABS(A(I,J))
BNI = BNI + ABS(B(I,J))
20 CONTINUE
C
IF (ANI .GT. ANORM) ANORM = ANI
IF (BNI .GT. BNORM) BNORM = BNI
30 CONTINUE
*
* ---------------------- BEGIN TIMING CODE -------------------------
OPS = OPS + REAL( N*( N+1 ) )
OPST = 0.0E0
ITCNT = 0
* ----------------------- END TIMING CODE --------------------------
*
C
IF (ANORM .EQ. 0.0E0) ANORM = 1.0E0
IF (BNORM .EQ. 0.0E0) BNORM = 1.0E0
EP = EPS1
IF (EP .GT. 0.0E0) GO TO 50
C .......... USE ROUNDOFF LEVEL IF EPS1 IS ZERO ..........
EP = EPSLON(1.0E0)
50 EPSA = EP * ANORM
EPSB = EP * BNORM
C .......... REDUCE A TO QUASI-TRIANGULAR FORM, WHILE
C KEEPING B TRIANGULAR ..........
LOR1 = 1
ENORN = N
EN = N
ITN = 30*N
C .......... BEGIN QZ STEP ..........
60 IF (EN .LE. 2) GO TO 1001
IF (.NOT. MATZ) ENORN = EN
ITS = 0
NA = EN - 1
ENM2 = NA - 1
70 ISH = 2
*
* ---------------------- BEGIN TIMING CODE -------------------------
OPS = OPS + OPST
OPST = 0.0E0
ITCNT = ITCNT + 1
* ----------------------- END TIMING CODE --------------------------
*
C .......... CHECK FOR CONVERGENCE OR REDUCIBILITY.
C FOR L=EN STEP -1 UNTIL 1 DO -- ..........
DO 80 LL = 1, EN
LM1 = EN - LL
L = LM1 + 1
IF (L .EQ. 1) GO TO 95
IF (ABS(A(L,LM1)) .LE. EPSA) GO TO 90
80 CONTINUE
C
90 A(L,LM1) = 0.0E0
IF (L .LT. NA) GO TO 95
C .......... 1-BY-1 OR 2-BY-2 BLOCK ISOLATED ..........
EN = LM1
GO TO 60
C .......... CHECK FOR SMALL TOP OF B ..........
95 LD = L
100 L1 = L + 1
B11 = B(L,L)
IF (ABS(B11) .GT. EPSB) GO TO 120
B(L,L) = 0.0E0
S = ABS(A(L,L)) + ABS(A(L1,L))
U1 = A(L,L) / S
U2 = A(L1,L) / S
R = SIGN(SQRT(U1*U1+U2*U2),U1)
V1 = -(U1 + R) / R
V2 = -U2 / R
U2 = V2 / V1
C
DO 110 J = L, ENORN
T = A(L,J) + U2 * A(L1,J)
A(L,J) = A(L,J) + T * V1
A(L1,J) = A(L1,J) + T * V2
T = B(L,J) + U2 * B(L1,J)
B(L,J) = B(L,J) + T * V1
B(L1,J) = B(L1,J) + T * V2
110 CONTINUE
C
* ---------------------- BEGIN TIMING CODE -------------------------
OPST = OPST + REAL( 12*( ENORN+1-L ) + 11 )
* ----------------------- END TIMING CODE --------------------------
IF (L .NE. 1) A(L,LM1) = -A(L,LM1)
LM1 = L
L = L1
GO TO 90
120 A11 = A(L,L) / B11
A21 = A(L1,L) / B11
IF (ISH .EQ. 1) GO TO 140
C .......... ITERATION STRATEGY ..........
IF (ITN .EQ. 0) GO TO 1000
IF (ITS .EQ. 10) GO TO 155
C .......... DETERMINE TYPE OF SHIFT ..........
B22 = B(L1,L1)
IF (ABS(B22) .LT. EPSB) B22 = EPSB
B33 = B(NA,NA)
IF (ABS(B33) .LT. EPSB) B33 = EPSB
B44 = B(EN,EN)
IF (ABS(B44) .LT. EPSB) B44 = EPSB
A33 = A(NA,NA) / B33
A34 = A(NA,EN) / B44
A43 = A(EN,NA) / B33
A44 = A(EN,EN) / B44
B34 = B(NA,EN) / B44
T = 0.5E0 * (A43 * B34 - A33 - A44)
R = T * T + A34 * A43 - A33 * A44
* ---------------------- BEGIN TIMING CODE -------------------------
OPST = OPST + REAL( 16 )
* ----------------------- END TIMING CODE --------------------------
IF (R .LT. 0.0E0) GO TO 150
C .......... DETERMINE SINGLE SHIFT ZEROTH COLUMN OF A ..........
ISH = 1
R = SQRT(R)
SH = -T + R
S = -T - R
IF (ABS(S-A44) .LT. ABS(SH-A44)) SH = S
C .......... LOOK FOR TWO CONSECUTIVE SMALL
C SUB-DIAGONAL ELEMENTS OF A.
C FOR L=EN-2 STEP -1 UNTIL LD DO -- ..........
DO 130 LL = LD, ENM2
L = ENM2 + LD - LL
IF (L .EQ. LD) GO TO 140
LM1 = L - 1
L1 = L + 1
T = A(L,L)
IF (ABS(B(L,L)) .GT. EPSB) T = T - SH * B(L,L)
* --------------------- BEGIN TIMING CODE -----------------------
IF (ABS(A(L,LM1)) .LE. ABS(T/A(L1,L)) * EPSA) THEN
OPST = OPST + REAL( 5 + 4*( LL+1-LD ) )
GO TO 100
END IF
* ---------------------- END TIMING CODE ------------------------
130 CONTINUE
* ---------------------- BEGIN TIMING CODE -------------------------
OPST = OPST + REAL( 5 + 4*( ENM2+1-LD ) )
* ----------------------- END TIMING CODE --------------------------
C
140 A1 = A11 - SH
A2 = A21
IF (L .NE. LD) A(L,LM1) = -A(L,LM1)
GO TO 160
C .......... DETERMINE DOUBLE SHIFT ZEROTH COLUMN OF A ..........
150 A12 = A(L,L1) / B22
A22 = A(L1,L1) / B22
B12 = B(L,L1) / B22
A1 = ((A33 - A11) * (A44 - A11) - A34 * A43 + A43 * B34 * A11)
X / A21 + A12 - A11 * B12
A2 = (A22 - A11) - A21 * B12 - (A33 - A11) - (A44 - A11)
X + A43 * B34
A3 = A(L1+1,L1) / B22
* ---------------------- BEGIN TIMING CODE -------------------------
OPST = OPST + REAL( 25 )
* ----------------------- END TIMING CODE --------------------------
GO TO 160
C .......... AD HOC SHIFT ..........
155 A1 = 0.0E0
A2 = 1.0E0
A3 = 1.1605E0
160 ITS = ITS + 1
ITN = ITN - 1
IF (.NOT. MATZ) LOR1 = LD
C .......... MAIN LOOP ..........
DO 260 K = L, NA
NOTLAS = K .NE. NA .AND. ISH .EQ. 2
K1 = K + 1
K2 = K + 2
KM1 = MAX0(K-1,L)
LL = MIN0(EN,K1+ISH)
IF (NOTLAS) GO TO 190
C .......... ZERO A(K+1,K-1) ..........
IF (K .EQ. L) GO TO 170
A1 = A(K,KM1)
A2 = A(K1,KM1)
170 S = ABS(A1) + ABS(A2)
IF (S .EQ. 0.0E0) GO TO 70
U1 = A1 / S
U2 = A2 / S
R = SIGN(SQRT(U1*U1+U2*U2),U1)
V1 = -(U1 + R) / R
V2 = -U2 / R
U2 = V2 / V1
C
DO 180 J = KM1, ENORN
T = A(K,J) + U2 * A(K1,J)
A(K,J) = A(K,J) + T * V1
A(K1,J) = A(K1,J) + T * V2
T = B(K,J) + U2 * B(K1,J)
B(K,J) = B(K,J) + T * V1
B(K1,J) = B(K1,J) + T * V2
180 CONTINUE
C
* --------------------- BEGIN TIMING CODE -----------------------
OPST = OPST + REAL( 11 + 12*( ENORN+1-KM1 ) )
* ---------------------- END TIMING CODE ------------------------
IF (K .NE. L) A(K1,KM1) = 0.0E0
GO TO 240
C .......... ZERO A(K+1,K-1) AND A(K+2,K-1) ..........
190 IF (K .EQ. L) GO TO 200
A1 = A(K,KM1)
A2 = A(K1,KM1)
A3 = A(K2,KM1)
200 S = ABS(A1) + ABS(A2) + ABS(A3)
IF (S .EQ. 0.0E0) GO TO 260
U1 = A1 / S
U2 = A2 / S
U3 = A3 / S
R = SIGN(SQRT(U1*U1+U2*U2+U3*U3),U1)
V1 = -(U1 + R) / R
V2 = -U2 / R
V3 = -U3 / R
U2 = V2 / V1
U3 = V3 / V1
C
DO 210 J = KM1, ENORN
T = A(K,J) + U2 * A(K1,J) + U3 * A(K2,J)
A(K,J) = A(K,J) + T * V1
A(K1,J) = A(K1,J) + T * V2
A(K2,J) = A(K2,J) + T * V3
T = B(K,J) + U2 * B(K1,J) + U3 * B(K2,J)
B(K,J) = B(K,J) + T * V1
B(K1,J) = B(K1,J) + T * V2
B(K2,J) = B(K2,J) + T * V3
210 CONTINUE
* --------------------- BEGIN TIMING CODE -----------------------
OPST = OPST + REAL( 17 + 20*( ENORN+1-KM1 ) )
* ---------------------- END TIMING CODE ------------------------
C
IF (K .EQ. L) GO TO 220
A(K1,KM1) = 0.0E0
A(K2,KM1) = 0.0E0
C .......... ZERO B(K+2,K+1) AND B(K+2,K) ..........
220 S = ABS(B(K2,K2)) + ABS(B(K2,K1)) + ABS(B(K2,K))
IF (S .EQ. 0.0E0) GO TO 240
U1 = B(K2,K2) / S
U2 = B(K2,K1) / S
U3 = B(K2,K) / S
R = SIGN(SQRT(U1*U1+U2*U2+U3*U3),U1)
V1 = -(U1 + R) / R
V2 = -U2 / R
V3 = -U3 / R
U2 = V2 / V1
U3 = V3 / V1
C
DO 230 I = LOR1, LL
T = A(I,K2) + U2 * A(I,K1) + U3 * A(I,K)
A(I,K2) = A(I,K2) + T * V1
A(I,K1) = A(I,K1) + T * V2
A(I,K) = A(I,K) + T * V3
T = B(I,K2) + U2 * B(I,K1) + U3 * B(I,K)
B(I,K2) = B(I,K2) + T * V1
B(I,K1) = B(I,K1) + T * V2
B(I,K) = B(I,K) + T * V3
230 CONTINUE
* --------------------- BEGIN TIMING CODE -----------------------
OPST = OPST + REAL( 17 + 20*( LL+1-LOR1 ) )
* ---------------------- END TIMING CODE ------------------------
C
B(K2,K) = 0.0E0
B(K2,K1) = 0.0E0
IF (.NOT. MATZ) GO TO 240
C
DO 235 I = 1, N
T = Z(I,K2) + U2 * Z(I,K1) + U3 * Z(I,K)
Z(I,K2) = Z(I,K2) + T * V1
Z(I,K1) = Z(I,K1) + T * V2
Z(I,K) = Z(I,K) + T * V3
235 CONTINUE
* --------------------- BEGIN TIMING CODE -----------------------
OPST = OPST + REAL( 10*N )
* ---------------------- END TIMING CODE ------------------------
C .......... ZERO B(K+1,K) ..........
240 S = ABS(B(K1,K1)) + ABS(B(K1,K))
IF (S .EQ. 0.0E0) GO TO 260
U1 = B(K1,K1) / S
U2 = B(K1,K) / S
R = SIGN(SQRT(U1*U1+U2*U2),U1)
V1 = -(U1 + R) / R
V2 = -U2 / R
U2 = V2 / V1
C
DO 250 I = LOR1, LL
T = A(I,K1) + U2 * A(I,K)
A(I,K1) = A(I,K1) + T * V1
A(I,K) = A(I,K) + T * V2
T = B(I,K1) + U2 * B(I,K)
B(I,K1) = B(I,K1) + T * V1
B(I,K) = B(I,K) + T * V2
250 CONTINUE
* --------------------- BEGIN TIMING CODE -----------------------
OPST = OPST + REAL( 11 + 12*( LL+1-LOR1 ) )
* ---------------------- END TIMING CODE ------------------------
C
B(K1,K) = 0.0E0
IF (.NOT. MATZ) GO TO 260
C
DO 255 I = 1, N
T = Z(I,K1) + U2 * Z(I,K)
Z(I,K1) = Z(I,K1) + T * V1
Z(I,K) = Z(I,K) + T * V2
255 CONTINUE
* --------------------- BEGIN TIMING CODE -----------------------
OPST = OPST + REAL( 6*N )
* ---------------------- END TIMING CODE ------------------------
C
260 CONTINUE
C .......... END QZ STEP ..........
GO TO 70
C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
C CONVERGED AFTER 30*N ITERATIONS ..........
1000 IERR = EN
C .......... SAVE EPSB FOR USE BY QZVAL AND QZVEC ..........
1001 IF (N .GT. 1) B(N,1) = EPSB
*
* ---------------------- BEGIN TIMING CODE -------------------------
OPS = OPS + OPST
OPST = 0.0E0
* ----------------------- END TIMING CODE --------------------------
*
RETURN
END
SUBROUTINE QZVAL(NM,N,A,B,ALFR,ALFI,BETA,MATZ,Z)
C
INTEGER I,J,N,EN,NA,NM,NN,ISW
REAL A(NM,N),B(NM,N),ALFR(N),ALFI(N),BETA(N),Z(NM,N)
REAL C,D,E,R,S,T,AN,A1,A2,BN,CQ,CZ,DI,DR,EI,TI,TR,U1,
X U2,V1,V2,A1I,A11,A12,A2I,A21,A22,B11,B12,B22,SQI,SQR,
X SSI,SSR,SZI,SZR,A11I,A11R,A12I,A12R,A22I,A22R,EPSB
LOGICAL MATZ
*
* ---------------------- BEGIN TIMING CODE -------------------------
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT
* ITCNT IS INITIALIZED TO 0, OPS IS ONLY INCREMENTED
* OPST IS USED TO ACCUMULATE SMALL CONTRIBUTIONS TO OPS
* TO AVOID ROUNDOFF ERROR
* .. COMMON BLOCKS ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. SCALARS IN COMMON ..
REAL ITCNT, OPS
* ..
REAL OPST, OPST2
* ----------------------- END TIMING CODE --------------------------
*
C
C THIS SUBROUTINE IS THE THIRD STEP OF THE QZ ALGORITHM
C FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS,
C SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART.
C
C THIS SUBROUTINE ACCEPTS A PAIR OF REAL MATRICES, ONE OF THEM
C IN QUASI-TRIANGULAR FORM AND THE OTHER IN UPPER TRIANGULAR FORM.
C IT REDUCES THE QUASI-TRIANGULAR MATRIX FURTHER, SO THAT ANY
C REMAINING 2-BY-2 BLOCKS CORRESPOND TO PAIRS OF COMPLEX
C EIGENVALUES, AND RETURNS QUANTITIES WHOSE RATIOS GIVE THE
C GENERALIZED EIGENVALUES. IT IS USUALLY PRECEDED BY QZHES
C AND QZIT AND MAY BE FOLLOWED BY QZVEC.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRICES.
C
C A CONTAINS A REAL UPPER QUASI-TRIANGULAR MATRIX.
C
C B CONTAINS A REAL UPPER TRIANGULAR MATRIX. IN ADDITION,
C LOCATION B(N,1) CONTAINS THE TOLERANCE QUANTITY (EPSB)
C COMPUTED AND SAVED IN QZIT.
C
C MATZ SHOULD BE SET TO .TRUE. IF THE RIGHT HAND TRANSFORMATIONS
C ARE TO BE ACCUMULATED FOR LATER USE IN COMPUTING
C EIGENVECTORS, AND TO .FALSE. OTHERWISE.
C
C Z CONTAINS, IF MATZ HAS BEEN SET TO .TRUE., THE
C TRANSFORMATION MATRIX PRODUCED IN THE REDUCTIONS BY QZHES
C AND QZIT, IF PERFORMED, OR ELSE THE IDENTITY MATRIX.
C IF MATZ HAS BEEN SET TO .FALSE., Z IS NOT REFERENCED.
C
C ON OUTPUT
C
C A HAS BEEN REDUCED FURTHER TO A QUASI-TRIANGULAR MATRIX
C IN WHICH ALL NONZERO SUBDIAGONAL ELEMENTS CORRESPOND TO
C PAIRS OF COMPLEX EIGENVALUES.
C
C B IS STILL IN UPPER TRIANGULAR FORM, ALTHOUGH ITS ELEMENTS
C HAVE BEEN ALTERED. B(N,1) IS UNALTERED.
C
C ALFR AND ALFI CONTAIN THE REAL AND IMAGINARY PARTS OF THE
C DIAGONAL ELEMENTS OF THE TRIANGULAR MATRIX THAT WOULD BE
C OBTAINED IF A WERE REDUCED COMPLETELY TO TRIANGULAR FORM
C BY UNITARY TRANSFORMATIONS. NON-ZERO VALUES OF ALFI OCCUR
C IN PAIRS, THE FIRST MEMBER POSITIVE AND THE SECOND NEGATIVE.
C
C BETA CONTAINS THE DIAGONAL ELEMENTS OF THE CORRESPONDING B,
C NORMALIZED TO BE REAL AND NON-NEGATIVE. THE GENERALIZED
C EIGENVALUES ARE THEN THE RATIOS ((ALFR+I*ALFI)/BETA).
C
C Z CONTAINS THE PRODUCT OF THE RIGHT HAND TRANSFORMATIONS
C (FOR ALL THREE STEPS) IF MATZ HAS BEEN SET TO .TRUE.
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
C
EPSB = B(N,1)
ISW = 1
C .......... FIND EIGENVALUES OF QUASI-TRIANGULAR MATRICES.
C FOR EN=N STEP -1 UNTIL 1 DO -- ..........
*
* ---------------------- BEGIN TIMING CODE -------------------------
OPST = 0.0E0
OPST2 = 0.0E0
* ----------------------- END TIMING CODE --------------------------
*
DO 510 NN = 1, N
*
* --------------------- BEGIN TIMING CODE -----------------------
OPST = OPST + OPST2
OPST2 = 0.0E0
* ---------------------- END TIMING CODE ------------------------
*
EN = N + 1 - NN
NA = EN - 1
IF (ISW .EQ. 2) GO TO 505
IF (EN .EQ. 1) GO TO 410
IF (A(EN,NA) .NE. 0.0E0) GO TO 420
C .......... 1-BY-1 BLOCK, ONE REAL ROOT ..........
410 ALFR(EN) = A(EN,EN)
IF (B(EN,EN) .LT. 0.0E0) ALFR(EN) = -ALFR(EN)
BETA(EN) = ABS(B(EN,EN))
ALFI(EN) = 0.0E0
GO TO 510
C .......... 2-BY-2 BLOCK ..........
420 IF (ABS(B(NA,NA)) .LE. EPSB) GO TO 455
IF (ABS(B(EN,EN)) .GT. EPSB) GO TO 430
A1 = A(EN,EN)
A2 = A(EN,NA)
BN = 0.0E0
GO TO 435
430 AN = ABS(A(NA,NA)) + ABS(A(NA,EN)) + ABS(A(EN,NA))
X + ABS(A(EN,EN))
BN = ABS(B(NA,NA)) + ABS(B(NA,EN)) + ABS(B(EN,EN))
A11 = A(NA,NA) / AN
A12 = A(NA,EN) / AN
A21 = A(EN,NA) / AN
A22 = A(EN,EN) / AN
B11 = B(NA,NA) / BN
B12 = B(NA,EN) / BN
B22 = B(EN,EN) / BN
E = A11 / B11
EI = A22 / B22
S = A21 / (B11 * B22)
T = (A22 - E * B22) / B22
IF (ABS(E) .LE. ABS(EI)) GO TO 431
E = EI
T = (A11 - E * B11) / B11
431 C = 0.5E0 * (T - S * B12)
D = C * C + S * (A12 - E * B12)
* --------------------- BEGIN TIMING CODE -----------------------
OPST2 = OPST2 + REAL( 28 )
* ---------------------- END TIMING CODE ------------------------
IF (D .LT. 0.0E0) GO TO 480
C .......... TWO REAL ROOTS.
C ZERO BOTH A(EN,NA) AND B(EN,NA) ..........
E = E + (C + SIGN(SQRT(D),C))
A11 = A11 - E * B11
A12 = A12 - E * B12
A22 = A22 - E * B22
* --------------------- BEGIN TIMING CODE -----------------------
OPST2 = OPST2 + REAL( 11 )
* ---------------------- END TIMING CODE ------------------------
IF (ABS(A11) + ABS(A12) .LT.
X ABS(A21) + ABS(A22)) GO TO 432
A1 = A12
A2 = A11
GO TO 435
432 A1 = A22
A2 = A21
C .......... CHOOSE AND APPLY REAL Z ..........
435 S = ABS(A1) + ABS(A2)
U1 = A1 / S
U2 = A2 / S
R = SIGN(SQRT(U1*U1+U2*U2),U1)
V1 = -(U1 + R) / R
V2 = -U2 / R
U2 = V2 / V1
C
DO 440 I = 1, EN
T = A(I,EN) + U2 * A(I,NA)
A(I,EN) = A(I,EN) + T * V1
A(I,NA) = A(I,NA) + T * V2
T = B(I,EN) + U2 * B(I,NA)
B(I,EN) = B(I,EN) + T * V1
B(I,NA) = B(I,NA) + T * V2
440 CONTINUE
* --------------------- BEGIN TIMING CODE -----------------------
OPST2 = OPST2 + REAL( 11 + 12*EN )
* ---------------------- END TIMING CODE ------------------------
C
IF (.NOT. MATZ) GO TO 450
C
DO 445 I = 1, N
T = Z(I,EN) + U2 * Z(I,NA)
Z(I,EN) = Z(I,EN) + T * V1
Z(I,NA) = Z(I,NA) + T * V2
445 CONTINUE
* --------------------- BEGIN TIMING CODE -----------------------
OPST2 = OPST2 + REAL( 6*N )
* ---------------------- END TIMING CODE ------------------------
C
450 IF (BN .EQ. 0.0E0) GO TO 475
IF (AN .LT. ABS(E) * BN) GO TO 455
A1 = B(NA,NA)
A2 = B(EN,NA)
GO TO 460
455 A1 = A(NA,NA)
A2 = A(EN,NA)
C .......... CHOOSE AND APPLY REAL Q ..........
460 S = ABS(A1) + ABS(A2)
IF (S .EQ. 0.0E0) GO TO 475
U1 = A1 / S
U2 = A2 / S
R = SIGN(SQRT(U1*U1+U2*U2),U1)
V1 = -(U1 + R) / R
V2 = -U2 / R
U2 = V2 / V1
C
DO 470 J = NA, N
T = A(NA,J) + U2 * A(EN,J)
A(NA,J) = A(NA,J) + T * V1
A(EN,J) = A(EN,J) + T * V2
T = B(NA,J) + U2 * B(EN,J)
B(NA,J) = B(NA,J) + T * V1
B(EN,J) = B(EN,J) + T * V2
470 CONTINUE
* --------------------- BEGIN TIMING CODE -----------------------
OPST2 = OPST2 + REAL( 11 + 12*( N+1-NA ) )
* ---------------------- END TIMING CODE ------------------------
C
475 A(EN,NA) = 0.0E0
B(EN,NA) = 0.0E0
ALFR(NA) = A(NA,NA)
ALFR(EN) = A(EN,EN)
IF (B(NA,NA) .LT. 0.0E0) ALFR(NA) = -ALFR(NA)
IF (B(EN,EN) .LT. 0.0E0) ALFR(EN) = -ALFR(EN)
BETA(NA) = ABS(B(NA,NA))
BETA(EN) = ABS(B(EN,EN))
ALFI(EN) = 0.0E0
ALFI(NA) = 0.0E0
GO TO 505
C .......... TWO COMPLEX ROOTS ..........
480 E = E + C
EI = SQRT(-D)
A11R = A11 - E * B11
A11I = EI * B11
A12R = A12 - E * B12
A12I = EI * B12
A22R = A22 - E * B22
A22I = EI * B22
IF (ABS(A11R) + ABS(A11I) + ABS(A12R) + ABS(A12I) .LT.
X ABS(A21) + ABS(A22R) + ABS(A22I)) GO TO 482
A1 = A12R
A1I = A12I
A2 = -A11R
A2I = -A11I
GO TO 485
482 A1 = A22R
A1I = A22I
A2 = -A21
A2I = 0.0E0
C .......... CHOOSE COMPLEX Z ..........
485 CZ = SQRT(A1*A1+A1I*A1I)
IF (CZ .EQ. 0.0E0) GO TO 487
SZR = (A1 * A2 + A1I * A2I) / CZ
SZI = (A1 * A2I - A1I * A2) / CZ
R = SQRT(CZ*CZ+SZR*SZR+SZI*SZI)
CZ = CZ / R
SZR = SZR / R
SZI = SZI / R
GO TO 490
487 SZR = 1.0E0
SZI = 0.0E0
490 IF (AN .LT. (ABS(E) + EI) * BN) GO TO 492
A1 = CZ * B11 + SZR * B12
A1I = SZI * B12
A2 = SZR * B22
A2I = SZI * B22
GO TO 495
492 A1 = CZ * A11 + SZR * A12
A1I = SZI * A12
A2 = CZ * A21 + SZR * A22
A2I = SZI * A22
C .......... CHOOSE COMPLEX Q ..........
495 CQ = SQRT(A1*A1+A1I*A1I)
IF (CQ .EQ. 0.0E0) GO TO 497
SQR = (A1 * A2 + A1I * A2I) / CQ
SQI = (A1 * A2I - A1I * A2) / CQ
R = SQRT(CQ*CQ+SQR*SQR+SQI*SQI)
CQ = CQ / R
SQR = SQR / R
SQI = SQI / R
GO TO 500
497 SQR = 1.0E0
SQI = 0.0E0
C .......... COMPUTE DIAGONAL ELEMENTS THAT WOULD RESULT
C IF TRANSFORMATIONS WERE APPLIED ..........
500 SSR = SQR * SZR + SQI * SZI
SSI = SQR * SZI - SQI * SZR
I = 1
TR = CQ * CZ * A11 + CQ * SZR * A12 + SQR * CZ * A21
X + SSR * A22
TI = CQ * SZI * A12 - SQI * CZ * A21 + SSI * A22
DR = CQ * CZ * B11 + CQ * SZR * B12 + SSR * B22
DI = CQ * SZI * B12 + SSI * B22
GO TO 503
502 I = 2
TR = SSR * A11 - SQR * CZ * A12 - CQ * SZR * A21
X + CQ * CZ * A22
TI = -SSI * A11 - SQI * CZ * A12 + CQ * SZI * A21
DR = SSR * B11 - SQR * CZ * B12 + CQ * CZ * B22
DI = -SSI * B11 - SQI * CZ * B12
503 T = TI * DR - TR * DI
J = NA
IF (T .LT. 0.0E0) J = EN
R = SQRT(DR*DR+DI*DI)
BETA(J) = BN * R
ALFR(J) = AN * (TR * DR + TI * DI) / R
ALFI(J) = AN * T / R
IF (I .EQ. 1) GO TO 502
* --------------------- BEGIN TIMING CODE -----------------------
OPST2 = OPST2 + REAL( 151 )
* ---------------------- END TIMING CODE ------------------------
505 ISW = 3 - ISW
510 CONTINUE
*
* ---------------------- BEGIN TIMING CODE -------------------------
OPS = OPS + ( OPST + OPST2 )
* ----------------------- END TIMING CODE --------------------------
*
B(N,1) = EPSB
C
RETURN
END
SUBROUTINE QZVEC(NM,N,A,B,ALFR,ALFI,BETA,Z)
C
INTEGER I,J,K,M,N,EN,II,JJ,NA,NM,NN,ISW,ENM2
REAL A(NM,N),B(NM,N),ALFR(N),ALFI(N),BETA(N),Z(NM,N)
REAL D,Q,R,S,T,W,X,Y,DI,DR,RA,RR,SA,TI,TR,T1,T2,W1,X1,
X ZZ,Z1,ALFM,ALMI,ALMR,BETM,EPSB
*
* ---------------------- BEGIN TIMING CODE -------------------------
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT
* ITCNT IS INITIALIZED TO 0, OPS IS ONLY INCREMENTED
* OPST IS USED TO ACCUMULATE SMALL CONTRIBUTIONS TO OPS
* TO AVOID ROUNDOFF ERROR
* .. COMMON BLOCKS ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. SCALARS IN COMMON ..
REAL ITCNT, OPS
* ..
INTEGER IN2BY2
* ----------------------- END TIMING CODE --------------------------
*
C
C THIS SUBROUTINE IS THE OPTIONAL FOURTH STEP OF THE QZ ALGORITHM
C FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS,
C SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART.
C
C THIS SUBROUTINE ACCEPTS A PAIR OF REAL MATRICES, ONE OF THEM IN
C QUASI-TRIANGULAR FORM (IN WHICH EACH 2-BY-2 BLOCK CORRESPONDS TO
C A PAIR OF COMPLEX EIGENVALUES) AND THE OTHER IN UPPER TRIANGULAR
C FORM. IT COMPUTES THE EIGENVECTORS OF THE TRIANGULAR PROBLEM AND
C TRANSFORMS THE RESULTS BACK TO THE ORIGINAL COORDINATE SYSTEM.
C IT IS USUALLY PRECEDED BY QZHES, QZIT, AND QZVAL.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRICES.
C
C A CONTAINS A REAL UPPER QUASI-TRIANGULAR MATRIX.
C
C B CONTAINS A REAL UPPER TRIANGULAR MATRIX. IN ADDITION,
C LOCATION B(N,1) CONTAINS THE TOLERANCE QUANTITY (EPSB)
C COMPUTED AND SAVED IN QZIT.
C
C ALFR, ALFI, AND BETA ARE VECTORS WITH COMPONENTS WHOSE
C RATIOS ((ALFR+I*ALFI)/BETA) ARE THE GENERALIZED
C EIGENVALUES. THEY ARE USUALLY OBTAINED FROM QZVAL.
C
C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
C REDUCTIONS BY QZHES, QZIT, AND QZVAL, IF PERFORMED.
C IF THE EIGENVECTORS OF THE TRIANGULAR PROBLEM ARE
C DESIRED, Z MUST CONTAIN THE IDENTITY MATRIX.
C
C ON OUTPUT
C
C A IS UNALTERED. ITS SUBDIAGONAL ELEMENTS PROVIDE INFORMATION
C ABOUT THE STORAGE OF THE COMPLEX EIGENVECTORS.
C
C B HAS BEEN DESTROYED.
C
C ALFR, ALFI, AND BETA ARE UNALTERED.
C
C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS.
C IF ALFI(I) .EQ. 0.0, THE I-TH EIGENVALUE IS REAL AND
C THE I-TH COLUMN OF Z CONTAINS ITS EIGENVECTOR.
C IF ALFI(I) .NE. 0.0, THE I-TH EIGENVALUE IS COMPLEX.
C IF ALFI(I) .GT. 0.0, THE EIGENVALUE IS THE FIRST OF
C A COMPLEX PAIR AND THE I-TH AND (I+1)-TH COLUMNS
C OF Z CONTAIN ITS EIGENVECTOR.
C IF ALFI(I) .LT. 0.0, THE EIGENVALUE IS THE SECOND OF
C A COMPLEX PAIR AND THE (I-1)-TH AND I-TH COLUMNS
C OF Z CONTAIN THE CONJUGATE OF ITS EIGENVECTOR.
C EACH EIGENVECTOR IS NORMALIZED SO THAT THE MODULUS
C OF ITS LARGEST COMPONENT IS 1.0 .
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
C
EPSB = B(N,1)
ISW = 1
C .......... FOR EN=N STEP -1 UNTIL 1 DO -- ..........
DO 800 NN = 1, N
* --------------------- BEGIN TIMING CODE -----------------------
IN2BY2 = 0
* ---------------------- END TIMING CODE ------------------------
EN = N + 1 - NN
NA = EN - 1
IF (ISW .EQ. 2) GO TO 795
IF (ALFI(EN) .NE. 0.0E0) GO TO 710
C .......... REAL VECTOR ..........
M = EN
B(EN,EN) = 1.0E0
IF (NA .EQ. 0) GO TO 800
ALFM = ALFR(M)
BETM = BETA(M)
C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
DO 700 II = 1, NA
I = EN - II
W = BETM * A(I,I) - ALFM * B(I,I)
R = 0.0E0
C
DO 610 J = M, EN
610 R = R + (BETM * A(I,J) - ALFM * B(I,J)) * B(J,EN)
C
IF (I .EQ. 1 .OR. ISW .EQ. 2) GO TO 630
IF (BETM * A(I,I-1) .EQ. 0.0E0) GO TO 630
ZZ = W
S = R
GO TO 690
630 M = I
IF (ISW .EQ. 2) GO TO 640
C .......... REAL 1-BY-1 BLOCK ..........
T = W
IF (W .EQ. 0.0E0) T = EPSB
B(I,EN) = -R / T
GO TO 700
C .......... REAL 2-BY-2 BLOCK ..........
640 X = BETM * A(I,I+1) - ALFM * B(I,I+1)
Y = BETM * A(I+1,I)
Q = W * ZZ - X * Y
T = (X * S - ZZ * R) / Q
B(I,EN) = T
* ------------------- BEGIN TIMING CODE ----------------------
IN2BY2 = IN2BY2 + 1
* -------------------- END TIMING CODE -----------------------
IF (ABS(X) .LE. ABS(ZZ)) GO TO 650
B(I+1,EN) = (-R - W * T) / X
GO TO 690
650 B(I+1,EN) = (-S - Y * T) / ZZ
690 ISW = 3 - ISW
700 CONTINUE
C .......... END REAL VECTOR ..........
* --------------------- BEGIN TIMING CODE -----------------------
OPS = OPS + ( 5.0E0/2.0E0 )*REAL( ( EN+2 )*( EN-1 ) + IN2BY2 )
* ---------------------- END TIMING CODE ------------------------
GO TO 800
C .......... COMPLEX VECTOR ..........
710 M = NA
ALMR = ALFR(M)
ALMI = ALFI(M)
BETM = BETA(M)
C .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT
C EIGENVECTOR MATRIX IS TRIANGULAR ..........
Y = BETM * A(EN,NA)
B(NA,NA) = -ALMI * B(EN,EN) / Y
B(NA,EN) = (ALMR * B(EN,EN) - BETM * A(EN,EN)) / Y
B(EN,NA) = 0.0E0
B(EN,EN) = 1.0E0
ENM2 = NA - 1
IF (ENM2 .EQ. 0) GO TO 795
C .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- ..........
DO 790 II = 1, ENM2
I = NA - II
W = BETM * A(I,I) - ALMR * B(I,I)
W1 = -ALMI * B(I,I)
RA = 0.0E0
SA = 0.0E0
C
DO 760 J = M, EN
X = BETM * A(I,J) - ALMR * B(I,J)
X1 = -ALMI * B(I,J)
RA = RA + X * B(J,NA) - X1 * B(J,EN)
SA = SA + X * B(J,EN) + X1 * B(J,NA)
760 CONTINUE
C
IF (I .EQ. 1 .OR. ISW .EQ. 2) GO TO 770
IF (BETM * A(I,I-1) .EQ. 0.0E0) GO TO 770
ZZ = W
Z1 = W1
R = RA
S = SA
ISW = 2
GO TO 790
770 M = I
IF (ISW .EQ. 2) GO TO 780
C .......... COMPLEX 1-BY-1 BLOCK ..........
TR = -RA
TI = -SA
773 DR = W
DI = W1
C .......... COMPLEX DIVIDE (T1,T2) = (TR,TI) / (DR,DI) ..........
775 IF (ABS(DI) .GT. ABS(DR)) GO TO 777
RR = DI / DR
D = DR + DI * RR
T1 = (TR + TI * RR) / D
T2 = (TI - TR * RR) / D
GO TO (787,782), ISW
777 RR = DR / DI
D = DR * RR + DI
T1 = (TR * RR + TI) / D
T2 = (TI * RR - TR) / D
GO TO (787,782), ISW
C .......... COMPLEX 2-BY-2 BLOCK ..........
780 X = BETM * A(I,I+1) - ALMR * B(I,I+1)
X1 = -ALMI * B(I,I+1)
Y = BETM * A(I+1,I)
TR = Y * RA - W * R + W1 * S
TI = Y * SA - W * S - W1 * R
DR = W * ZZ - W1 * Z1 - X * Y
DI = W * Z1 + W1 * ZZ - X1 * Y
* ------------------- BEGIN TIMING CODE ----------------------
IN2BY2 = IN2BY2 + 1
* -------------------- END TIMING CODE -----------------------
IF (DR .EQ. 0.0E0 .AND. DI .EQ. 0.0E0) DR = EPSB
GO TO 775
782 B(I+1,NA) = T1
B(I+1,EN) = T2
ISW = 1
IF (ABS(Y) .GT. ABS(W) + ABS(W1)) GO TO 785
TR = -RA - X * B(I+1,NA) + X1 * B(I+1,EN)
TI = -SA - X * B(I+1,EN) - X1 * B(I+1,NA)
GO TO 773
785 T1 = (-R - ZZ * B(I+1,NA) + Z1 * B(I+1,EN)) / Y
T2 = (-S - ZZ * B(I+1,EN) - Z1 * B(I+1,NA)) / Y
787 B(I,NA) = T1
B(I,EN) = T2
790 CONTINUE
* --------------------- BEGIN TIMING CODE -----------------------
OPS = OPS + REAL( ( 6*EN-7 )*( EN-2 ) + 31*IN2BY2 )
* ---------------------- END TIMING CODE ------------------------
C .......... END COMPLEX VECTOR ..........
795 ISW = 3 - ISW
800 CONTINUE
C .......... END BACK SUBSTITUTION.
C TRANSFORM TO ORIGINAL COORDINATE SYSTEM.
C FOR J=N STEP -1 UNTIL 1 DO -- ..........
DO 880 JJ = 1, N
J = N + 1 - JJ
C
DO 880 I = 1, N
ZZ = 0.0E0
C
DO 860 K = 1, J
860 ZZ = ZZ + Z(I,K) * B(K,J)
C
Z(I,J) = ZZ
880 CONTINUE
* ----------------------- BEGIN TIMING CODE ------------------------
OPS = OPS + REAL( N**2 )*REAL( N+1 )
* ------------------------ END TIMING CODE -------------------------
C .......... NORMALIZE SO THAT MODULUS OF LARGEST
C COMPONENT OF EACH VECTOR IS 1.
C (ISW IS 1 INITIALLY FROM BEFORE) ..........
* ------------------------ BEGIN TIMING CODE -----------------------
IN2BY2 = 0
* ------------------------- END TIMING CODE ------------------------
DO 950 J = 1, N
D = 0.0E0
IF (ISW .EQ. 2) GO TO 920
IF (ALFI(J) .NE. 0.0E0) GO TO 945
C
DO 890 I = 1, N
IF (ABS(Z(I,J)) .GT. D) D = ABS(Z(I,J))
890 CONTINUE
C
DO 900 I = 1, N
900 Z(I,J) = Z(I,J) / D
C
GO TO 950
C
920 DO 930 I = 1, N
R = ABS(Z(I,J-1)) + ABS(Z(I,J))
IF (R .NE. 0.0E0) R = R * SQRT((Z(I,J-1)/R)**2
X +(Z(I,J)/R)**2)
IF (R .GT. D) D = R
930 CONTINUE
C
DO 940 I = 1, N
Z(I,J-1) = Z(I,J-1) / D
Z(I,J) = Z(I,J) / D
940 CONTINUE
* ---------------------- BEGIN TIMING CODE ----------------------
IN2BY2 = IN2BY2 + 1
* ----------------------- END TIMING CODE -----------------------
C
945 ISW = 3 - ISW
950 CONTINUE
* ------------------------ BEGIN TIMING CODE -----------------------
OPS = OPS + REAL( N*( N + 5*IN2BY2 ) )
* ------------------------- END TIMING CODE ------------------------
C
RETURN
END
SUBROUTINE SLAQZH( ILQ, ILZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ,
$ Z, LDZ, WORK, INFO )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
LOGICAL ILQ, ILZ
INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
$ WORK( N ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* This calls the LAPACK routines to perform the function of
* QZHES. It is similar in function to SGGHRD, except that
* B is not assumed to be upper-triangular.
*
* It reduces a pair of matrices (A,B) to a Hessenberg-triangular
* pair (H,T). More specifically, it computes orthogonal matrices
* Q and Z, an (upper) Hessenberg matrix H, and an upper triangular
* matrix T such that:
*
* A = Q H Z' and B = Q T Z'
*
*
* Arguments
* =========
*
* ILQ (input) LOGICAL
* = .FALSE. do not compute Q.
* = .TRUE. compute Q.
*
* ILZ (input) LOGICAL
* = .FALSE. do not compute Z.
* = .TRUE. compute Z.
*
* N (input) INTEGER
* The number of rows and columns in the matrices A, B, Q, and
* Z. N must be at least 0.
*
* ILO (input) INTEGER
* Columns 1 through ILO-1 of A and B are assumed to be in
* upper triangular form already, and will not be modified.
* ILO must be at least 1.
*
* IHI (input) INTEGER
* Rows IHI+1 through N of A and B are assumed to be in upper
* triangular form already, and will not be touched. IHI may
* not be greater than N.
*
* A (input/output) REAL array, dimension (LDA, N)
* On entry, the first of the pair of N x N general matrices to
* be reduced.
* On exit, the upper triangle and the first subdiagonal of A
* are overwritten with the Hessenberg matrix H, and the rest
* is set to zero.
*
* LDA (input) INTEGER
* The leading dimension of A as declared in the calling
* program. LDA must be at least max ( 1, N ) .
*
* B (input/output) REAL array, dimension (LDB, N)
* On entry, the second of the pair of N x N general matrices to
* be reduced.
* On exit, the transformed matrix T = Q' B Z, which is upper
* triangular.
*
* LDB (input) INTEGER
* The leading dimension of B as declared in the calling
* program. LDB must be at least max ( 1, N ) .
*
* Q (output) REAL array, dimension (LDQ,N)
* If ILQ = .TRUE., Q will contain the orthogonal matrix Q.
* (See "Purpose", above.)
* Will not be referenced if ILQ = .FALSE.
*
* LDQ (input) INTEGER
* The leading dimension of the matrix Q. LDQ must be at
* least 1 and at least N.
*
* Z (output) REAL array, dimension (LDZ,N)
* If ILZ = .TRUE., Z will contain the orthogonal matrix Z.
* (See "Purpose", above.)
* May be referenced even if ILZ = .FALSE.
*
* LDZ (input) INTEGER
* The leading dimension of the matrix Z. LDZ must be at
* least 1 and at least N.
*
* WORK (workspace) REAL array, dimension (N)
* Workspace.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: errors that usually indicate LAPACK problems:
* = 2: error return from SGEQRF;
* = 3: error return from SORMQR;
* = 4: error return from SORGQR;
* = 5: error return from SGGHRD.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
CHARACTER COMPQ, COMPZ
INTEGER ICOLS, IINFO, IROWS
* ..
* .. External Subroutines ..
EXTERNAL SGEQRF, SGGHRD, SLACPY, SLASET, SORGQR, SORMQR
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Reduce B to triangular form, and initialize Q and/or Z
*
IROWS = IHI + 1 - ILO
ICOLS = N + 1 - ILO
CALL SGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK, Z, N*LDZ,
$ IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 2
GO TO 10
END IF
*
CALL SORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
$ WORK, A( ILO, ILO ), LDA, Z, N*LDZ, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 3
GO TO 10
END IF
*
IF( ILQ ) THEN
CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
CALL SLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
$ Q( ILO+1, ILO ), LDQ )
CALL SORGQR( IROWS, IROWS, IROWS, Q( ILO, ILO ), LDQ, WORK, Z,
$ N*LDZ, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 4
GO TO 10
END IF
END IF
*
* Reduce to generalized Hessenberg form
*
IF( ILQ ) THEN
COMPQ = 'V'
ELSE
COMPQ = 'N'
END IF
*
IF( ILZ ) THEN
COMPZ = 'I'
ELSE
COMPZ = 'N'
END IF
*
CALL SGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z,
$ LDZ, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 5
GO TO 10
END IF
*
* End
*
10 CONTINUE
*
RETURN
*
* End of SLAQZH
*
END
SUBROUTINE SLATM4( ITYPE, N, NZ1, NZ2, ISIGN, AMAGN, RCOND,
$ TRIANG, IDIST, ISEED, A, LDA )
*
* -- LAPACK auxiliary test routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
INTEGER IDIST, ISIGN, ITYPE, LDA, N, NZ1, NZ2
REAL AMAGN, RCOND, TRIANG
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
REAL A( LDA, * )
* ..
*
* Purpose
* =======
*
* SLATM4 generates basic square matrices, which may later be
* multiplied by others in order to produce test matrices. It is
* intended mainly to be used to test the generalized eigenvalue
* routines.
*
* It first generates the diagonal and (possibly) subdiagonal,
* according to the value of ITYPE, NZ1, NZ2, ISIGN, AMAGN, and RCOND.
* It then fills in the upper triangle with random numbers, if TRIANG is
* non-zero.
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* The "type" of matrix on the diagonal and sub-diagonal.
* If ITYPE < 0, then type abs(ITYPE) is generated and then
* swapped end for end (A(I,J) := A'(N-J,N-I).) See also
* the description of AMAGN and ISIGN.
*
* Special types:
* = 0: the zero matrix.
* = 1: the identity.
* = 2: a transposed Jordan block.
* = 3: If N is odd, then a k+1 x k+1 transposed Jordan block
* followed by a k x k identity block, where k=(N-1)/2.
* If N is even, then k=(N-2)/2, and a zero diagonal entry
* is tacked onto the end.
*
* Diagonal types. The diagonal consists of NZ1 zeros, then
* k=N-NZ1-NZ2 nonzeros. The subdiagonal is zero. ITYPE
* specifies the nonzero diagonal entries as follows:
* = 4: 1, ..., k
* = 5: 1, RCOND, ..., RCOND
* = 6: 1, ..., 1, RCOND
* = 7: 1, a, a^2, ..., a^(k-1)=RCOND
* = 8: 1, 1-d, 1-2*d, ..., 1-(k-1)*d=RCOND
* = 9: random numbers chosen from (RCOND,1)
* = 10: random numbers with distribution IDIST (see SLARND.)
*
* N (input) INTEGER
* The order of the matrix.
*
* NZ1 (input) INTEGER
* If abs(ITYPE) > 3, then the first NZ1 diagonal entries will
* be zero.
*
* NZ2 (input) INTEGER
* If abs(ITYPE) > 3, then the last NZ2 diagonal entries will
* be zero.
*
* ISIGN (input) INTEGER
* = 0: The sign of the diagonal and subdiagonal entries will
* be left unchanged.
* = 1: The diagonal and subdiagonal entries will have their
* sign changed at random.
* = 2: If ITYPE is 2 or 3, then the same as ISIGN=1.
* Otherwise, with probability 0.5, odd-even pairs of
* diagonal entries A(2*j-1,2*j-1), A(2*j,2*j) will be
* converted to a 2x2 block by pre- and post-multiplying
* by distinct random orthogonal rotations. The remaining
* diagonal entries will have their sign changed at random.
*
* AMAGN (input) REAL
* The diagonal and subdiagonal entries will be multiplied by
* AMAGN.
*
* RCOND (input) REAL
* If abs(ITYPE) > 4, then the smallest diagonal entry will be
* entry will be RCOND. RCOND must be between 0 and 1.
*
* TRIANG (input) REAL
* The entries above the diagonal will be random numbers with
* magnitude bounded by TRIANG (i.e., random numbers multiplied
* by TRIANG.)
*
* IDIST (input) INTEGER
* Specifies the type of distribution to be used to generate a
* random matrix.
* = 1: UNIFORM( 0, 1 )
* = 2: UNIFORM( -1, 1 )
* = 3: NORMAL ( 0, 1 )
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The values of ISEED are changed on exit, and can
* be used in the next call to SLATM4 to continue the same
* random number sequence.
* Note: ISEED(4) should be odd, for the random number generator
* used at present.
*
* A (output) REAL array, dimension (LDA, N)
* Array to be computed.
*
* LDA (input) INTEGER
* Leading dimension of A. Must be at least 1 and at least N.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 )
REAL HALF
PARAMETER ( HALF = ONE / TWO )
* ..
* .. Local Scalars ..
INTEGER I, IOFF, ISDB, ISDE, JC, JD, JR, K, KBEG, KEND,
$ KLEN
REAL ALPHA, CL, CR, SAFMIN, SL, SR, SV1, SV2, TEMP
* ..
* .. External Functions ..
REAL SLAMCH, SLARAN, SLARND
EXTERNAL SLAMCH, SLARAN, SLARND
* ..
* .. External Subroutines ..
EXTERNAL SLASET
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, EXP, LOG, MAX, MIN, MOD, REAL, SQRT
* ..
* .. Executable Statements ..
*
IF( N.LE.0 )
$ RETURN
CALL SLASET( 'Full', N, N, ZERO, ZERO, A, LDA )
*
* Insure a correct ISEED
*
IF( MOD( ISEED( 4 ), 2 ).NE.1 )
$ ISEED( 4 ) = ISEED( 4 ) + 1
*
* Compute diagonal and subdiagonal according to ITYPE, NZ1, NZ2,
* and RCOND
*
IF( ITYPE.NE.0 ) THEN
IF( ABS( ITYPE ).GE.4 ) THEN
KBEG = MAX( 1, MIN( N, NZ1+1 ) )
KEND = MAX( KBEG, MIN( N, N-NZ2 ) )
KLEN = KEND + 1 - KBEG
ELSE
KBEG = 1
KEND = N
KLEN = N
END IF
ISDB = 1
ISDE = 0
GO TO ( 10, 30, 50, 80, 100, 120, 140, 160,
$ 180, 200 )ABS( ITYPE )
*
* |ITYPE| = 1: Identity
*
10 CONTINUE
DO 20 JD = 1, N
A( JD, JD ) = ONE
20 CONTINUE
GO TO 220
*
* |ITYPE| = 2: Transposed Jordan block
*
30 CONTINUE
DO 40 JD = 1, N - 1
A( JD+1, JD ) = ONE
40 CONTINUE
ISDB = 1
ISDE = N - 1
GO TO 220
*
* |ITYPE| = 3: Transposed Jordan block, followed by the identity.
*
50 CONTINUE
K = ( N-1 ) / 2
DO 60 JD = 1, K
A( JD+1, JD ) = ONE
60 CONTINUE
ISDB = 1
ISDE = K
DO 70 JD = K + 2, 2*K + 1
A( JD, JD ) = ONE
70 CONTINUE
GO TO 220
*
* |ITYPE| = 4: 1,...,k
*
80 CONTINUE
DO 90 JD = KBEG, KEND
A( JD, JD ) = REAL( JD-NZ1 )
90 CONTINUE
GO TO 220
*
* |ITYPE| = 5: One large D value:
*
100 CONTINUE
DO 110 JD = KBEG + 1, KEND
A( JD, JD ) = RCOND
110 CONTINUE
A( KBEG, KBEG ) = ONE
GO TO 220
*
* |ITYPE| = 6: One small D value:
*
120 CONTINUE
DO 130 JD = KBEG, KEND - 1
A( JD, JD ) = ONE
130 CONTINUE
A( KEND, KEND ) = RCOND
GO TO 220
*
* |ITYPE| = 7: Exponentially distributed D values:
*
140 CONTINUE
A( KBEG, KBEG ) = ONE
IF( KLEN.GT.1 ) THEN
ALPHA = RCOND**( ONE / REAL( KLEN-1 ) )
DO 150 I = 2, KLEN
A( NZ1+I, NZ1+I ) = ALPHA**( I-1 )
150 CONTINUE
END IF
GO TO 220
*
* |ITYPE| = 8: Arithmetically distributed D values:
*
160 CONTINUE
A( KBEG, KBEG ) = ONE
IF( KLEN.GT.1 ) THEN
ALPHA = ( ONE-RCOND ) / REAL( KLEN-1 )
DO 170 I = 2, KLEN
A( NZ1+I, NZ1+I ) = REAL( KLEN-I )*ALPHA + RCOND
170 CONTINUE
END IF
GO TO 220
*
* |ITYPE| = 9: Randomly distributed D values on ( RCOND, 1):
*
180 CONTINUE
ALPHA = LOG( RCOND )
DO 190 JD = KBEG, KEND
A( JD, JD ) = EXP( ALPHA*SLARAN( ISEED ) )
190 CONTINUE
GO TO 220
*
* |ITYPE| = 10: Randomly distributed D values from DIST
*
200 CONTINUE
DO 210 JD = KBEG, KEND
A( JD, JD ) = SLARND( IDIST, ISEED )
210 CONTINUE
*
220 CONTINUE
*
* Scale by AMAGN
*
DO 230 JD = KBEG, KEND
A( JD, JD ) = AMAGN*REAL( A( JD, JD ) )
230 CONTINUE
DO 240 JD = ISDB, ISDE
A( JD+1, JD ) = AMAGN*REAL( A( JD+1, JD ) )
240 CONTINUE
*
* If ISIGN = 1 or 2, assign random signs to diagonal and
* subdiagonal
*
IF( ISIGN.GT.0 ) THEN
DO 250 JD = KBEG, KEND
IF( REAL( A( JD, JD ) ).NE.ZERO ) THEN
IF( SLARAN( ISEED ).GT.HALF )
$ A( JD, JD ) = -A( JD, JD )
END IF
250 CONTINUE
DO 260 JD = ISDB, ISDE
IF( REAL( A( JD+1, JD ) ).NE.ZERO ) THEN
IF( SLARAN( ISEED ).GT.HALF )
$ A( JD+1, JD ) = -A( JD+1, JD )
END IF
260 CONTINUE
END IF
*
* Reverse if ITYPE < 0
*
IF( ITYPE.LT.0 ) THEN
DO 270 JD = KBEG, ( KBEG+KEND-1 ) / 2
TEMP = A( JD, JD )
A( JD, JD ) = A( KBEG+KEND-JD, KBEG+KEND-JD )
A( KBEG+KEND-JD, KBEG+KEND-JD ) = TEMP
270 CONTINUE
DO 280 JD = 1, ( N-1 ) / 2
TEMP = A( JD+1, JD )
A( JD+1, JD ) = A( N+1-JD, N-JD )
A( N+1-JD, N-JD ) = TEMP
280 CONTINUE
END IF
*
* If ISIGN = 2, and no subdiagonals already, then apply
* random rotations to make 2x2 blocks.
*
IF( ISIGN.EQ.2 .AND. ITYPE.NE.2 .AND. ITYPE.NE.3 ) THEN
SAFMIN = SLAMCH( 'S' )
DO 290 JD = KBEG, KEND - 1, 2
IF( SLARAN( ISEED ).GT.HALF ) THEN
*
* Rotation on left.
*
CL = TWO*SLARAN( ISEED ) - ONE
SL = TWO*SLARAN( ISEED ) - ONE
TEMP = ONE / MAX( SAFMIN, SQRT( CL**2+SL**2 ) )
CL = CL*TEMP
SL = SL*TEMP
*
* Rotation on right.
*
CR = TWO*SLARAN( ISEED ) - ONE
SR = TWO*SLARAN( ISEED ) - ONE
TEMP = ONE / MAX( SAFMIN, SQRT( CR**2+SR**2 ) )
CR = CR*TEMP
SR = SR*TEMP
*
* Apply
*
SV1 = A( JD, JD )
SV2 = A( JD+1, JD+1 )
A( JD, JD ) = CL*CR*SV1 + SL*SR*SV2
A( JD+1, JD ) = -SL*CR*SV1 + CL*SR*SV2
A( JD, JD+1 ) = -CL*SR*SV1 + SL*CR*SV2
A( JD+1, JD+1 ) = SL*SR*SV1 + CL*CR*SV2
END IF
290 CONTINUE
END IF
*
END IF
*
* Fill in upper triangle (except for 2x2 blocks)
*
IF( TRIANG.NE.ZERO ) THEN
IF( ISIGN.NE.2 .OR. ITYPE.EQ.2 .OR. ITYPE.EQ.3 ) THEN
IOFF = 1
ELSE
IOFF = 2
DO 300 JR = 1, N - 1
IF( A( JR+1, JR ).EQ.ZERO )
$ A( JR, JR+1 ) = TRIANG*SLARND( IDIST, ISEED )
300 CONTINUE
END IF
*
DO 320 JC = 2, N
DO 310 JR = 1, JC - IOFF
A( JR, JC ) = TRIANG*SLARND( IDIST, ISEED )
310 CONTINUE
320 CONTINUE
END IF
*
RETURN
*
* End of SLATM4
*
END
REAL FUNCTION SMFLOP( OPS, TIME, INFO )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
INTEGER INFO
REAL OPS, TIME
* ..
*
* Purpose
* =======
*
* SMFLOP computes the megaflop rate given the number of operations
* and time in seconds. This is basically just a divide operation,
* but care is taken not to divide by zero.
*
* Arguments
* =========
*
* OPS - REAL
* On entry, OPS is the number of floating point operations
* performed by the timed routine.
*
* TIME - REAL
* On entry, TIME is the total time in seconds used by the
* timed routine.
*
* INFO - INTEGER
* On entry, INFO specifies the return code from the timed
* routine. If INFO is not 0, then SMFLOP returns a negative
* value, indicating an error.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, REAL
* ..
* .. Executable Statements ..
*
IF( TIME.LE.ZERO ) THEN
SMFLOP = ZERO
ELSE
SMFLOP = OPS / ( 1.0E6*TIME )
END IF
IF( INFO.NE.0 )
$ SMFLOP = -ABS( REAL( INFO ) )
RETURN
*
* End of SMFLOP
*
END
REAL FUNCTION SOPBL3( SUBNAM, M, N, K )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
INTEGER K, M, N
* ..
*
* Purpose
* =======
*
* SOPBL3 computes an approximation of the number of floating point
* operations used by a subroutine SUBNAM with the given values
* of the parameters M, N, and K.
*
* This version counts operations for the Level 3 BLAS.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* M (input) INTEGER
* N (input) INTEGER
* K (input) INTEGER
* M, N, and K contain parameter values used by the Level 3
* BLAS. The output matrix is always M x N or N x N if
* symmetric, but K has different uses in different
* contexts. For example, in the matrix-matrix multiply
* routine, we have
* C = A * B
* where C is M x N, A is M x K, and B is K x N.
* In xSYMM, xTRMM, and xTRSM, K indicates whether the matrix
* A is applied on the left or right. If K <= 0, the matrix
* is applied on the left, if K > 0, on the right.
*
* =====================================================================
*
* .. Local Scalars ..
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 C3
REAL ADDS, EK, EM, EN, MULTS
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR.
$ .NOT.( LSAME( SUBNAM, 'S' ) .OR. LSAME( SUBNAM, 'D' ) .OR.
$ LSAME( SUBNAM, 'C' ) .OR. LSAME( SUBNAM, 'Z' ) ) ) THEN
SOPBL3 = 0
RETURN
END IF
*
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
MULTS = 0
ADDS = 0
EM = M
EN = N
EK = K
*
* ----------------------
* Matrix-matrix products
* assume beta = 1
* ----------------------
*
IF( LSAMEN( 3, C3, 'MM ' ) ) THEN
*
IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
MULTS = EM*EK*EN
ADDS = EM*EK*EN
*
ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) ) THEN
*
* IF K <= 0, assume A multiplies B on the left.
*
IF( K.LE.0 ) THEN
MULTS = EM*EM*EN
ADDS = EM*EM*EN
ELSE
MULTS = EM*EN*EN
ADDS = EM*EN*EN
END IF
*
ELSE IF( LSAMEN( 2, C2, 'TR' ) ) THEN
*
IF( K.LE.0 ) THEN
MULTS = EN*EM*( EM+1. ) / 2.
ADDS = EN*EM*( EM-1. ) / 2.
ELSE
MULTS = EM*EN*( EN+1. ) / 2.
ADDS = EM*EN*( EN-1. ) / 2.
END IF
*
END IF
*
* ------------------------------------------------
* Rank-K update of a symmetric or Hermitian matrix
* ------------------------------------------------
*
ELSE IF( LSAMEN( 3, C3, 'RK ' ) ) THEN
*
IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) ) THEN
*
MULTS = EK*EM*( EM+1. ) / 2.
ADDS = EK*EM*( EM+1. ) / 2.
END IF
*
* ------------------------------------------------
* Rank-2K update of a symmetric or Hermitian matrix
* ------------------------------------------------
*
ELSE IF( LSAMEN( 3, C3, 'R2K' ) ) THEN
*
IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) ) THEN
*
MULTS = EK*EM*EM
ADDS = EK*EM*EM + EM
END IF
*
* -----------------------------------------
* Solving system with many right hand sides
* -----------------------------------------
*
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'TRSM ' ) ) THEN
*
IF( K.LE.0 ) THEN
MULTS = EN*EM*( EM+1. ) / 2.
ADDS = EN*EM*( EM-1. ) / 2.
ELSE
MULTS = EM*EN*( EN+1. ) / 2.
ADDS = EM*EN*( EN-1. ) / 2.
END IF
*
END IF
*
* ------------------------------------------------
* Compute the total number of operations.
* For real and double precision routines, count
* 1 for each multiply and 1 for each add.
* For complex and complex*16 routines, count
* 6 for each multiply and 2 for each add.
* ------------------------------------------------
*
IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN
*
SOPBL3 = MULTS + ADDS
*
ELSE
*
SOPBL3 = 6*MULTS + 2*ADDS
*
END IF
*
RETURN
*
* End of SOPBL3
*
END
REAL FUNCTION SOPLA2( SUBNAM, OPTS, M, N, K, L, NB )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
CHARACTER*( * ) OPTS
INTEGER K, L, M, N, NB
* ..
*
* Purpose
* =======
*
* SOPLA2 computes an approximation of the number of floating point
* operations used by the subroutine SUBNAM with character options
* OPTS and parameters M, N, K, L, and NB.
*
* This version counts operations for the LAPACK subroutines that
* call other LAPACK routines.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* OPTS (input) CHRACTER*(*)
* A string of character options to subroutine SUBNAM.
*
* M (input) INTEGER
* The number of rows of the coefficient matrix.
*
* N (input) INTEGER
* The number of columns of the coefficient matrix.
*
* K (input) INTEGER
* A third problem dimension, if needed.
*
* L (input) INTEGER
* A fourth problem dimension, if needed.
*
* NB (input) INTEGER
* The block size. If needed, NB >= 1.
*
* Notes
* =====
*
* In the comments below, the association is given between arguments
* in the requested subroutine and local arguments. For example,
*
* xORMBR: VECT // SIDE // TRANS, M, N, K => OPTS, M, N, K
*
* means that the character string VECT // SIDE // TRANS is passed to
* the argument OPTS, and the integer parameters M, N, and K are passed
* to the arguments M, N, and K,
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL CORZ, SORD
CHARACTER C1, SIDE, UPLO, VECT
CHARACTER*2 C2
CHARACTER*3 C3
CHARACTER*6 SUB2
INTEGER IHI, ILO, ISIDE, MI, NI, NQ
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
REAL SOPLA
EXTERNAL LSAME, LSAMEN, SOPLA
* ..
* .. Executable Statements ..
*
* ---------------------------------------------------------
* Initialize SOPLA2 to 0 and do a quick return if possible.
* ---------------------------------------------------------
*
SOPLA2 = 0
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
SORD = LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' )
CORZ = LSAME( C1, 'C' ) .OR. LSAME( C1, 'Z' )
IF( M.LE.0 .OR. .NOT.( SORD .OR. CORZ ) )
$ RETURN
*
* -------------------
* Orthogonal matrices
* -------------------
*
IF( ( SORD .AND. LSAMEN( 2, C2, 'OR' ) ) .OR.
$ ( CORZ .AND. LSAMEN( 2, C2, 'UN' ) ) ) THEN
*
IF( LSAMEN( 3, C3, 'GBR' ) ) THEN
*
* -GBR: VECT, M, N, K => OPTS, M, N, K
*
VECT = OPTS( 1: 1 )
IF( LSAME( VECT, 'Q' ) ) THEN
SUB2 = SUBNAM( 1: 3 ) // 'GQR'
IF( M.GE.K ) THEN
SOPLA2 = SOPLA( SUB2, M, N, K, 0, NB )
ELSE
SOPLA2 = SOPLA( SUB2, M-1, M-1, M-1, 0, NB )
END IF
ELSE
SUB2 = SUBNAM( 1: 3 ) // 'GLQ'
IF( K.LT.N ) THEN
SOPLA2 = SOPLA( SUB2, M, N, K, 0, NB )
ELSE
SOPLA2 = SOPLA( SUB2, N-1, N-1, N-1, 0, NB )
END IF
END IF
*
ELSE IF( LSAMEN( 3, C3, 'MBR' ) ) THEN
*
* -MBR: VECT // SIDE // TRANS, M, N, K => OPTS, M, N, K
*
VECT = OPTS( 1: 1 )
SIDE = OPTS( 2: 2 )
IF( LSAME( SIDE, 'L' ) ) THEN
NQ = M
ISIDE = 0
ELSE
NQ = N
ISIDE = 1
END IF
IF( LSAME( VECT, 'Q' ) ) THEN
SUB2 = SUBNAM( 1: 3 ) // 'MQR'
IF( NQ.GE.K ) THEN
SOPLA2 = SOPLA( SUB2, M, N, K, ISIDE, NB )
ELSE IF( ISIDE.EQ.0 ) THEN
SOPLA2 = SOPLA( SUB2, M-1, N, NQ-1, ISIDE, NB )
ELSE
SOPLA2 = SOPLA( SUB2, M, N-1, NQ-1, ISIDE, NB )
END IF
ELSE
SUB2 = SUBNAM( 1: 3 ) // 'MLQ'
IF( NQ.GT.K ) THEN
SOPLA2 = SOPLA( SUB2, M, N, K, ISIDE, NB )
ELSE IF( ISIDE.EQ.0 ) THEN
SOPLA2 = SOPLA( SUB2, M-1, N, NQ-1, ISIDE, NB )
ELSE
SOPLA2 = SOPLA( SUB2, M, N-1, NQ-1, ISIDE, NB )
END IF
END IF
*
ELSE IF( LSAMEN( 3, C3, 'GHR' ) ) THEN
*
* -GHR: N, ILO, IHI => M, N, K
*
ILO = N
IHI = K
SUB2 = SUBNAM( 1: 3 ) // 'GQR'
SOPLA2 = SOPLA( SUB2, IHI-ILO, IHI-ILO, IHI-ILO, 0, NB )
*
ELSE IF( LSAMEN( 3, C3, 'MHR' ) ) THEN
*
* -MHR: SIDE // TRANS, M, N, ILO, IHI => OPTS, M, N, K, L
*
SIDE = OPTS( 1: 1 )
ILO = K
IHI = L
IF( LSAME( SIDE, 'L' ) ) THEN
MI = IHI - ILO
NI = N
ISIDE = -1
ELSE
MI = M
NI = IHI - ILO
ISIDE = 1
END IF
SUB2 = SUBNAM( 1: 3 ) // 'MQR'
SOPLA2 = SOPLA( SUB2, MI, NI, IHI-ILO, ISIDE, NB )
*
ELSE IF( LSAMEN( 3, C3, 'GTR' ) ) THEN
*
* -GTR: UPLO, N => OPTS, M
*
UPLO = OPTS( 1: 1 )
IF( LSAME( UPLO, 'U' ) ) THEN
SUB2 = SUBNAM( 1: 3 ) // 'GQL'
SOPLA2 = SOPLA( SUB2, M-1, M-1, M-1, 0, NB )
ELSE
SUB2 = SUBNAM( 1: 3 ) // 'GQR'
SOPLA2 = SOPLA( SUB2, M-1, M-1, M-1, 0, NB )
END IF
*
ELSE IF( LSAMEN( 3, C3, 'MTR' ) ) THEN
*
* -MTR: SIDE // UPLO // TRANS, M, N => OPTS, M, N
*
SIDE = OPTS( 1: 1 )
UPLO = OPTS( 2: 2 )
IF( LSAME( SIDE, 'L' ) ) THEN
MI = M - 1
NI = N
NQ = M
ISIDE = -1
ELSE
MI = M
NI = N - 1
NQ = N
ISIDE = 1
END IF
*
IF( LSAME( UPLO, 'U' ) ) THEN
SUB2 = SUBNAM( 1: 3 ) // 'MQL'
SOPLA2 = SOPLA( SUB2, MI, NI, NQ-1, ISIDE, NB )
ELSE
SUB2 = SUBNAM( 1: 3 ) // 'MQR'
SOPLA2 = SOPLA( SUB2, MI, NI, NQ-1, ISIDE, NB )
END IF
*
END IF
END IF
*
RETURN
*
* End of SOPLA2
*
END
REAL FUNCTION SOPLA( SUBNAM, M, N, KL, KU, NB )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
INTEGER KL, KU, M, N, NB
* ..
*
* Purpose
* =======
*
* SOPLA computes an approximation of the number of floating point
* operations used by the subroutine SUBNAM with the given values
* of the parameters M, N, KL, KU, and NB.
*
* This version counts operations for the LAPACK subroutines.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* M (input) INTEGER
* The number of rows of the coefficient matrix. M >= 0.
*
* N (input) INTEGER
* The number of columns of the coefficient matrix.
* For solve routine when the matrix is square,
* N is the number of right hand sides. N >= 0.
*
* KL (input) INTEGER
* The lower band width of the coefficient matrix.
* If needed, 0 <= KL <= M-1.
* For xGEQRS, KL is the number of right hand sides.
*
* KU (input) INTEGER
* The upper band width of the coefficient matrix.
* If needed, 0 <= KU <= N-1.
*
* NB (input) INTEGER
* The block size. If needed, NB >= 1.
*
* Notes
* =====
*
* In the comments below, the association is given between arguments
* in the requested subroutine and local arguments. For example,
*
* xGETRS: N, NRHS => M, N
*
* means that arguments N and NRHS in SGETRS are passed to arguments
* M and N in this procedure.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL SORD, CORZ
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 C3
INTEGER I
REAL ADDFAC, ADDS, EK, EM, EN, EMN, MULFAC, MULTS,
$ WL, WU
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* --------------------------------------------------------
* Initialize SOPLA to 0 and do a quick return if possible.
* --------------------------------------------------------
*
SOPLA = 0
MULTS = 0
ADDS = 0
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
SORD = LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' )
CORZ = LSAME( C1, 'C' ) .OR. LSAME( C1, 'Z' )
IF( M.LE.0 .OR. .NOT.( SORD .OR. CORZ ) )
$ RETURN
*
* ---------------------------------------------------------
* If the coefficient matrix is real, count each add as 1
* operation and each multiply as 1 operation.
* If the coefficient matrix is complex, count each add as 2
* operations and each multiply as 6 operations.
* ---------------------------------------------------------
*
IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN
ADDFAC = 1
MULFAC = 1
ELSE
ADDFAC = 2
MULFAC = 6
END IF
EM = M
EN = N
EK = KL
*
* ---------------------------------
* GE: GEneral rectangular matrices
* ---------------------------------
*
IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
* xGETRF: M, N => M, N
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
EMN = MIN( M, N )
ADDS = EMN*( EM*EN - ( EM+EN )*( EMN+1. )/2. +
$ ( EMN+1. )*( 2.*EMN+1. )/6. )
MULTS = ADDS + EMN*( EM - ( EMN+1. )/2. )
*
* xGETRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*EM*EM
ADDS = EN*( EM*( EM-1. ) )
*
* xGETRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 5./6.+EM*( 1./2.+EM*( 2./3. ) ) )
ADDS = EM*( 5./6.+EM*( -3./2.+EM*( 2./3. ) ) )
*
* xGEQRF or xGEQLF: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'QRF' ) .OR. LSAMEN( 3, C3, 'QR2' )
$ .OR. LSAMEN( 3, C3, 'QLF' ) .OR. LSAMEN( 3, C3, 'QL2' ) )
$ THEN
IF( M.GE.N ) THEN
MULTS = EN*( ( ( 23./6. )+EM+EN/2. )+EN*( EM-EN/3. ) )
ADDS = EN*( ( 5./6. )+EN*( 1./2.+( EM-EN/3. ) ) )
ELSE
MULTS = EM*( ( ( 23./6. )+2.*EN-EM/2. )+EM*( EN-EM/3. ) )
ADDS = EM*( ( 5./6. )+EN-EM/2.+EM*( EN-EM/3. ) )
END IF
*
* xGERQF or xGELQF: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'RQF' ) .OR. LSAMEN( 3, C3, 'RQ2' )
$ .OR. LSAMEN( 3, C3, 'LQF' ) .OR. LSAMEN( 3, C3, 'LQ2' ) )
$ THEN
IF( M.GE.N ) THEN
MULTS = EN*( ( ( 29./6. )+EM+EN/2. )+EN*( EM-EN/3. ) )
ADDS = EN*( ( 5./6. )+EM+EN*( -1./2.+( EM-EN/3. ) ) )
ELSE
MULTS = EM*( ( ( 29./6. )+2.*EN-EM/2. )+EM*( EN-EM/3. ) )
ADDS = EM*( ( 5./6. )+EM/2.+EM*( EN-EM/3. ) )
END IF
*
* xGEQPF: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'QPF' ) ) THEN
EMN = MIN( M, N )
MULTS = 2*EN*EN + EMN*( 3*EM + 5*EN + 2*EM*EN -
$ ( EMN+1 )*( 4+EN+EM - ( 2*EMN+1 ) / 3 ) )
ADDS = EN*EN + EMN*( 2*EM + EN + 2*EM*EN -
$ ( EMN+1 )*( 2+EN+EM - ( 2*EMN+1 ) / 3 ) )
*
* xGEQRS or xGERQS: M, N, NRHS => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'QRS' ) .OR. LSAMEN( 3, C3, 'RQS' ) )
$ THEN
MULTS = EK*( EN*( 2.-EK ) +EM*( 2.*EN + (EM+1.)/2. ) )
ADDS = EK*( EN*( 1.-EK ) + EM*( 2.*EN + (EM-1.)/2. ) )
*
* xGELQS or xGEQLS: M, N, NRHS => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'LQS' ) .OR. LSAMEN( 3, C3, 'QLS' ) )
$ THEN
MULTS = EK*( EM*( 2.-EK ) +EN*( 2.*EM + (EN+1.)/2. ) )
ADDS = EK*( EM*( 1.-EK ) + EN*( 2.*EM + (EN-1.)/2. ) )
*
* xGEBRD: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'BRD' ) ) THEN
IF( M.GE.N ) THEN
MULTS = EN*( 20./3.+EN*( 2.+( 2.*EM-( 2./3. )*EN ) ) )
ADDS = EN*( 5./3.+( EN-EM )+EN*( 2.*EM-( 2./3. )*EN ) )
ELSE
MULTS = EM*( 20./3.+EM*( 2.+( 2.*EN-( 2./3. )*EM ) ) )
ADDS = EM*( 5./3.+( EM-EN )+EM*( 2.*EN-( 2./3. )*EM ) )
END IF
*
* xGEHRD: N => M
*
ELSE IF( LSAMEN( 3, C3, 'HRD' ) ) THEN
IF( M.EQ.1 ) THEN
MULTS = 0.
ADDS = 0.
ELSE
MULTS = -13. + EM*( -7./6.+EM*( 0.5+EM*( 5./3. ) ) )
ADDS = -8. + EM*( -2./3.+EM*( -1.+EM*( 5./3. ) ) )
END IF
*
END IF
*
* ----------------------------
* GB: General Banded matrices
* ----------------------------
* Note: The operation count is overestimated because
* it is assumed that the factor U fills in to the maximum
* extent, i.e., that its bandwidth goes from KU to KL + KU.
*
ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
*
* xGBTRF: M, N, KL, KU => M, N, KL, KU
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
DO 10 I = MIN( M, N ), 1, -1
WL = MAX( 0, MIN( KL, M-I ) )
WU = MAX( 0, MIN( KL+KU, N-I ) )
MULTS = MULTS + WL*( 1.+WU )
ADDS = ADDS + WL*WU
10 CONTINUE
*
* xGBTRS: N, NRHS, KL, KU => M, N, KL, KU
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
WL = MAX( 0, MIN( KL, M-1 ) )
WU = MAX( 0, MIN( KL+KU, M-1 ) )
MULTS = EN*( EM*( WL+1.+WU )-0.5*
$ ( WL*( WL+1. )+WU*( WU+1. ) ) )
ADDS = EN*( EM*( WL+WU )-0.5*( WL*( WL+1. )+WU*( WU+1. ) ) )
*
END IF
*
* --------------------------------------
* PO: POsitive definite matrices
* PP: Positive definite Packed matrices
* --------------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'PP' ) ) THEN
*
* xPOTRF: N => M
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = EM*( 1./3.+EM*( 1./2.+EM*( 1./6. ) ) )
ADDS = ( 1./6. )*EM*( -1.+EM*EM )
*
* xPOTRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*( EM*( EM+1. ) )
ADDS = EN*( EM*( EM-1. ) )
*
* xPOTRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 2./3.+EM*( 1.+EM*( 1./3. ) ) )
ADDS = EM*( 1./6.+EM*( -1./2.+EM*( 1./3. ) ) )
*
END IF
*
* ------------------------------------
* PB: Positive definite Band matrices
* ------------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN
*
* xPBTRF: N, K => M, KL
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = EK*( -2./3.+EK*( -1.+EK*( -1./3. ) ) ) +
$ EM*( 1.+EK*( 3./2.+EK*( 1./2. ) ) )
ADDS = EK*( -1./6.+EK*( -1./2.+EK*( -1./3. ) ) ) +
$ EM*( EK/2.*( 1.+EK ) )
*
* xPBTRS: N, NRHS, K => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*( ( 2*EM-EK )*( EK+1. ) )
ADDS = EN*( EK*( 2*EM-( EK+1. ) ) )
*
END IF
*
* --------------------------------------------------------
* SY: SYmmetric indefinite matrices
* SP: Symmetric indefinite Packed matrices
* HE: HErmitian indefinite matrices (complex only)
* HP: Hermitian indefinite Packed matrices (complex only)
* --------------------------------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHP' ) ) THEN
*
* xSYTRF: N => M
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = EM*( 10./3.+EM*( 1./2.+EM*( 1./6. ) ) )
ADDS = EM / 6.*( -1.+EM*EM )
*
* xSYTRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*EM*EM
ADDS = EN*( EM*( EM-1. ) )
*
* xSYTRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 2./3.+EM*EM*( 1./3. ) )
ADDS = EM*( -1./3.+EM*EM*( 1./3. ) )
*
* xSYTRD, xSYTD2: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRD' ) .OR. LSAMEN( 3, C3, 'TD2' ) )
$ THEN
IF( M.EQ.1 ) THEN
MULTS = 0.
ADDS = 0.
ELSE
MULTS = -15. + EM*( -1./6.+EM*( 5./2.+EM*( 2./3. ) ) )
ADDS = -4. + EM*( -8./3.+EM*( 1.+EM*( 2./3. ) ) )
END IF
END IF
*
* -------------------
* Triangular matrices
* -------------------
*
ELSE IF( LSAMEN( 2, C2, 'TR' ) .OR. LSAMEN( 2, C2, 'TP' ) ) THEN
*
* xTRTRS: N, NRHS => M, N
*
IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*EM*( EM+1. ) / 2.
ADDS = EN*EM*( EM-1. ) / 2.
*
* xTRTRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 1./3.+EM*( 1./2.+EM*( 1./6. ) ) )
ADDS = EM*( 1./3.+EM*( -1./2.+EM*( 1./6. ) ) )
*
END IF
*
ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
*
* xTBTRS: N, NRHS, K => M, N, KL
*
IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*( EM*( EM+1. ) / 2. -
$ ( EM-EK-1. )*( EM-EK ) / 2. )
ADDS = EN*( EM*( EM-1. ) / 2. -
$ ( EM-EK-1. )*( EM-EK ) / 2. )
END IF
*
* --------------------
* Trapezoidal matrices
* --------------------
*
ELSE IF( LSAMEN( 2, C2, 'TZ' ) ) THEN
*
* xTZRQF: M, N => M, N
*
IF( LSAMEN( 3, C3, 'RQF' ) ) THEN
EMN = MIN( M, N )
MULTS = 3*EM*( EN-EM+1 ) +
$ ( 2*EN-2*EM+3 )*( EM*EM - EMN*( EMN+1 )/2 )
ADDS = ( EN-EM+1 )*( EM + 2*EM*EM-EMN*( EMN+1 ) )
END IF
*
* -------------------
* Orthogonal matrices
* -------------------
*
ELSE IF( ( SORD .AND. LSAMEN( 2, C2, 'OR' ) ) .OR.
$ ( CORZ .AND. LSAMEN( 2, C2, 'UN' ) ) ) THEN
*
* -MQR, -MLQ, -MQL, or -MRQ: M, N, K, SIDE => M, N, KL, KU
* where KU<= 0 indicates SIDE = 'L'
* and KU> 0 indicates SIDE = 'R'
*
IF( LSAMEN( 3, C3, 'MQR' ) .OR. LSAMEN( 3, C3, 'MLQ' ) .OR.
$ LSAMEN( 3, C3, 'MQL' ) .OR. LSAMEN( 3, C3, 'MRQ' ) ) THEN
IF( KU.LE.0 ) THEN
MULTS = EK*EN*( 2.*EM + 2. - EK )
ADDS = EK*EN*( 2.*EM + 1. - EK )
ELSE
MULTS = EK*( EM*( 2.*EN - EK )+ ( EM+EN+( 1.-EK )/2. ) )
ADDS = EK*EM*( 2.*EN + 1. - EK )
END IF
*
* -GQR or -GQL: M, N, K => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'GQR' ) .OR. LSAMEN( 3, C3, 'GQL' ) )
$ THEN
MULTS = EK*( -5./3. + ( 2.*EN - EK ) +
$ ( 2.*EM*EN + EK*( ( 2./3. )*EK - EM - EN ) ) )
ADDS = EK*( 1./3. + ( EN - EM ) +
$ ( 2.*EM*EN + EK*( ( 2./3. )*EK - EM - EN ) ) )
*
* -GLQ or -GRQ: M, N, K => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'GLQ' ) .OR. LSAMEN( 3, C3, 'GRQ' ) )
$ THEN
MULTS = EK*( -2./3. + ( EM + EN - EK ) +
$ ( 2.*EM*EN + EK*( ( 2./3. )*EK - EM - EN ) ) )
ADDS = EK*( 1./3. + ( EM - EN ) +
$ ( 2.*EM*EN + EK*( ( 2./3. )*EK - EM - EN ) ) )
*
END IF
*
END IF
*
SOPLA = MULFAC*MULTS + ADDFAC*ADDS
*
RETURN
*
* End of SOPLA
*
END
SUBROUTINE SPRTBE( SUBNAM, NTYPES, DOTYPE, NSIZES, NN, INPARM,
$ PNAMES, NPARMS, NP1, NP2, NP3, NP4, OPS, LDO1,
$ LDO2, TIMES, LDT1, LDT2, RWORK, LLWORK, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
CHARACTER*( * ) SUBNAM
INTEGER INPARM, LDO1, LDO2, LDT1, LDT2, NOUT, NPARMS,
$ NSIZES, NTYPES
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( NTYPES ), LLWORK( NPARMS )
CHARACTER*( * ) PNAMES( * )
INTEGER NN( NSIZES ), NP1( * ), NP2( * ), NP3( * ),
$ NP4( * )
REAL OPS( LDO1, LDO2, * ), RWORK( * ),
$ TIMES( LDT1, LDT2, * )
* ..
*
* Purpose
* =======
*
* SPRTBE prints out timing information for the eigenvalue routines.
* The table has NTYPES block rows and NSIZES columns, with NPARMS
* individual rows in each block row. There are INPARM quantities
* which depend on rows (currently, INPARM <= 4).
*
* Arguments (none are modified)
* =========
*
* SUBNAM - CHARACTER*(*)
* The label for the output.
*
* NTYPES - INTEGER
* The number of values of DOTYPE, and also the
* number of sets of rows of the table.
*
* DOTYPE - LOGICAL array of dimension( NTYPES )
* If DOTYPE(j) is .TRUE., then block row j (which includes
* data from RESLTS( i, j, k ), for all i and k) will be
* printed. If DOTYPE(j) is .FALSE., then block row j will
* not be printed.
*
* NSIZES - INTEGER
* The number of values of NN, and also the
* number of columns of the table.
*
* NN - INTEGER array of dimension( NSIZES )
* The values of N used to label each column.
*
* INPARM - INTEGER
* The number of different parameters which are functions of
* the row number. At the moment, INPARM <= 4.
*
* PNAMES - CHARACTER*(*) array of dimension( INPARM )
* The label for the columns.
*
* NPARMS - INTEGER
* The number of values for each "parameter", i.e., the
* number of rows for each value of DOTYPE.
*
* NP1 - INTEGER array of dimension( NPARMS )
* The first quantity which depends on row number.
*
* NP2 - INTEGER array of dimension( NPARMS )
* The second quantity which depends on row number.
*
* NP3 - INTEGER array of dimension( NPARMS )
* The third quantity which depends on row number.
*
* NP4 - INTEGER array of dimension( NPARMS )
* The fourth quantity which depends on row number.
*
* OPS - REAL array of dimension( LDT1, LDT2, NSIZES )
* The operation counts. The first index indicates the row,
* the second index indicates the block row, and the last
* indicates the column.
*
* LDO1 - INTEGER
* The first dimension of OPS. It must be at least
* min( 1, NPARMS ).
*
* LDO2 - INTEGER
* The second dimension of OPS. It must be at least
* min( 1, NTYPES ).
*
* TIMES - REAL array of dimension( LDT1, LDT2, NSIZES )
* The times (in seconds). The first index indicates the row,
* the second index indicates the block row, and the last
* indicates the column.
*
* LDT1 - INTEGER
* The first dimension of RESLTS. It must be at least
* min( 1, NPARMS ).
*
* LDT2 - INTEGER
* The second dimension of RESLTS. It must be at least
* min( 1, NTYPES ).
*
* RWORK - REAL array of dimension( NSIZES*NTYPES*NPARMS )
* Real workspace.
* Modified.
*
* LLWORK - LOGICAL array of dimension( NPARMS )
* Logical workspace. It is used to turn on or off specific
* lines in the output. If LLWORK(i) is .TRUE., then row i
* (which includes data from OPS(i,j,k) or TIMES(i,j,k) for
* all j and k) will be printed. If LLWORK(i) is
* .FALSE., then row i will not be printed.
* Modified.
*
* NOUT - INTEGER
* The output unit number on which the table
* is to be printed. If NOUT <= 0, no output is printed.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LTEMP
INTEGER I, IINFO, ILINE, ILINES, IPAR, J, JP, JS, JT
* ..
* .. External Functions ..
REAL SMFLOP
EXTERNAL SMFLOP
* ..
* .. External Subroutines ..
EXTERNAL SPRTBS
* ..
* .. Executable Statements ..
*
*
* First line
*
WRITE( NOUT, FMT = 9999 )SUBNAM
*
* Set up which lines are to be printed.
*
LLWORK( 1 ) = .TRUE.
ILINES = 1
DO 20 IPAR = 2, NPARMS
LLWORK( IPAR ) = .TRUE.
DO 10 J = 1, IPAR - 1
LTEMP = .FALSE.
IF( INPARM.GE.1 .AND. NP1( J ).NE.NP1( IPAR ) )
$ LTEMP = .TRUE.
IF( INPARM.GE.2 .AND. NP2( J ).NE.NP2( IPAR ) )
$ LTEMP = .TRUE.
IF( INPARM.GE.3 .AND. NP3( J ).NE.NP3( IPAR ) )
$ LTEMP = .TRUE.
IF( INPARM.GE.4 .AND. NP4( J ).NE.NP4( IPAR ) )
$ LTEMP = .TRUE.
IF( .NOT.LTEMP )
$ LLWORK( IPAR ) = .FALSE.
10 CONTINUE
IF( LLWORK( IPAR ) )
$ ILINES = ILINES + 1
20 CONTINUE
IF( ILINES.EQ.1 ) THEN
IF( INPARM.EQ.1 ) THEN
WRITE( NOUT, FMT = 9995 )PNAMES( 1 ), NP1( 1 )
ELSE IF( INPARM.EQ.2 ) THEN
WRITE( NOUT, FMT = 9995 )PNAMES( 1 ), NP1( 1 ),
$ PNAMES( 2 ), NP2( 1 )
ELSE IF( INPARM.EQ.3 ) THEN
WRITE( NOUT, FMT = 9995 )PNAMES( 1 ), NP1( 1 ),
$ PNAMES( 2 ), NP2( 1 ), PNAMES( 3 ), NP3( 1 )
ELSE IF( INPARM.EQ.4 ) THEN
WRITE( NOUT, FMT = 9995 )PNAMES( 1 ), NP1( 1 ),
$ PNAMES( 2 ), NP2( 1 ), PNAMES( 3 ), NP3( 1 ),
$ PNAMES( 4 ), NP4( 1 )
END IF
ELSE
ILINE = 0
DO 30 J = 1, NPARMS
IF( LLWORK( J ) ) THEN
ILINE = ILINE + 1
IF( INPARM.EQ.1 ) THEN
WRITE( NOUT, FMT = 9994 )ILINE, PNAMES( 1 ), NP1( J )
ELSE IF( INPARM.EQ.2 ) THEN
WRITE( NOUT, FMT = 9994 )ILINE, PNAMES( 1 ),
$ NP1( J ), PNAMES( 2 ), NP2( J )
ELSE IF( INPARM.EQ.3 ) THEN
WRITE( NOUT, FMT = 9994 )ILINE, PNAMES( 1 ),
$ NP1( J ), PNAMES( 2 ), NP2( J ), PNAMES( 3 ),
$ NP3( J )
ELSE IF( INPARM.EQ.4 ) THEN
WRITE( NOUT, FMT = 9994 )ILINE, PNAMES( 1 ),
$ NP1( J ), PNAMES( 2 ), NP2( J ), PNAMES( 3 ),
$ NP3( J ), PNAMES( 4 ), NP4( J )
END IF
END IF
30 CONTINUE
END IF
*
* Execution Times
*
WRITE( NOUT, FMT = 9996 )
CALL SPRTBS( 'Type', 'N ', NTYPES, DOTYPE, NSIZES, NN, NPARMS,
$ LLWORK, TIMES, LDT1, LDT2, NOUT )
*
* Operation Counts
*
WRITE( NOUT, FMT = 9997 )
CALL SPRTBS( 'Type', 'N ', NTYPES, DOTYPE, NSIZES, NN, NPARMS,
$ LLWORK, OPS, LDO1, LDO2, NOUT )
*
* Megaflop Rates
*
IINFO = 0
DO 60 JS = 1, NSIZES
DO 50 JT = 1, NTYPES
IF( DOTYPE( JT ) ) THEN
DO 40 JP = 1, NPARMS
I = JP + NPARMS*( JT-1+NTYPES*( JS-1 ) )
RWORK( I ) = SMFLOP( OPS( JP, JT, JS ),
$ TIMES( JP, JT, JS ), IINFO )
40 CONTINUE
END IF
50 CONTINUE
60 CONTINUE
*
WRITE( NOUT, FMT = 9998 )
CALL SPRTBS( 'Type', 'N ', NTYPES, DOTYPE, NSIZES, NN, NPARMS,
$ LLWORK, RWORK, NPARMS, NTYPES, NOUT )
*
9999 FORMAT( / / / ' ****** Results for ', A, ' ******' )
9998 FORMAT( / ' *** Speed in megaflops ***' )
9997 FORMAT( / ' *** Number of floating-point operations ***' )
9996 FORMAT( / ' *** Time in seconds ***' )
9995 FORMAT( 5X, : 'with ', A, '=', I5, 3( : ', ', A, '=', I5 ) )
9994 FORMAT( 5X, : 'line ', I2, ' with ', A, '=', I5,
$ 3( : ', ', A, '=', I5 ) )
RETURN
*
* End of SPRTBE
*
END
SUBROUTINE SPRTBG( SUBNAM, NTYPES, DOTYPE, NSIZES, NN, INPARM,
$ PNAMES, NPARMS, NP1, NP2, NP3, NP4, NP5, NP6,
$ OPS, LDO1, LDO2, TIMES, LDT1, LDT2, RWORK,
$ LLWORK, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
CHARACTER*( * ) SUBNAM
INTEGER INPARM, LDO1, LDO2, LDT1, LDT2, NOUT, NPARMS,
$ NSIZES, NTYPES
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( NTYPES ), LLWORK( NPARMS )
CHARACTER*( * ) PNAMES( * )
INTEGER NN( NSIZES ), NP1( * ), NP2( * ), NP3( * ),
$ NP4( * ), NP5( * ), NP6( * )
REAL OPS( LDO1, LDO2, * ), RWORK( * ),
$ TIMES( LDT1, LDT2, * )
* ..
*
* Purpose
* =======
*
* SPRTBG prints out timing information for the eigenvalue routines.
* The table has NTYPES block rows and NSIZES columns, with NPARMS
* individual rows in each block row. There are INPARM quantities
* which depend on rows (currently, INPARM <= 4).
*
* Arguments (none are modified)
* =========
*
* SUBNAM - CHARACTER*(*)
* The label for the output.
*
* NTYPES - INTEGER
* The number of values of DOTYPE, and also the
* number of sets of rows of the table.
*
* DOTYPE - LOGICAL array of dimension( NTYPES )
* If DOTYPE(j) is .TRUE., then block row j (which includes
* data from RESLTS( i, j, k ), for all i and k) will be
* printed. If DOTYPE(j) is .FALSE., then block row j will
* not be printed.
*
* NSIZES - INTEGER
* The number of values of NN, and also the
* number of columns of the table.
*
* NN - INTEGER array of dimension( NSIZES )
* The values of N used to label each column.
*
* INPARM - INTEGER
* The number of different parameters which are functions of
* the row number. At the moment, INPARM <= 4.
*
* PNAMES - CHARACTER*(*) array of dimension( INPARM )
* The label for the columns.
*
* NPARMS - INTEGER
* The number of values for each "parameter", i.e., the
* number of rows for each value of DOTYPE.
*
* NP1 - INTEGER array of dimension( NPARMS )
* The first quantity which depends on row number.
*
* NP2 - INTEGER array of dimension( NPARMS )
* The second quantity which depends on row number.
*
* NP3 - INTEGER array of dimension( NPARMS )
* The third quantity which depends on row number.
*
* NP4 - INTEGER array of dimension( NPARMS )
* The fourth quantity which depends on row number.
*
* NP5 - INTEGER array of dimension( NPARMS )
* The fifth quantity which depends on row number.
*
* NP6 - INTEGER array of dimension( NPARMS )
* The sixth quantity which depends on row number.
*
* OPS - REAL array of dimension( LDT1, LDT2, NSIZES )
* The operation counts. The first index indicates the row,
* the second index indicates the block row, and the last
* indicates the column.
*
* LDO1 - INTEGER
* The first dimension of OPS. It must be at least
* min( 1, NPARMS ).
*
* LDO2 - INTEGER
* The second dimension of OPS. It must be at least
* min( 1, NTYPES ).
*
* TIMES - REAL array of dimension( LDT1, LDT2, NSIZES )
* The times (in seconds). The first index indicates the row,
* the second index indicates the block row, and the last
* indicates the column.
*
* LDT1 - INTEGER
* The first dimension of RESLTS. It must be at least
* min( 1, NPARMS ).
*
* LDT2 - INTEGER
* The second dimension of RESLTS. It must be at least
* min( 1, NTYPES ).
*
* RWORK - REAL array of dimension( NSIZES*NTYPES*NPARMS )
* Real workspace.
* Modified.
*
* LLWORK - LOGICAL array of dimension( NPARMS )
* Logical workspace. It is used to turn on or off specific
* lines in the output. If LLWORK(i) is .TRUE., then row i
* (which includes data from OPS(i,j,k) or TIMES(i,j,k) for
* all j and k) will be printed. If LLWORK(i) is
* .FALSE., then row i will not be printed.
* Modified.
*
* NOUT - INTEGER
* The output unit number on which the table
* is to be printed. If NOUT <= 0, no output is printed.
*
* =====================================================================
*
* .. Local Scalars ..
CHARACTER*40 FRMATA, FRMATI
LOGICAL LTEMP
INTEGER I, IINFO, ILINE, ILINES, IPADA, IPADI, IPAR, J,
$ JP, JS, JT
* ..
* .. External Functions ..
REAL SMFLOP
EXTERNAL SMFLOP
* ..
* .. External Subroutines ..
EXTERNAL SPRTBS
* ..
* .. Executable Statements ..
*
*
* First line
*
WRITE( NOUT, FMT = 9999 )SUBNAM
*
* Set up which lines are to be printed.
*
LLWORK( 1 ) = .TRUE.
ILINES = 1
DO 20 IPAR = 2, NPARMS
LLWORK( IPAR ) = .TRUE.
DO 10 J = 1, IPAR - 1
LTEMP = .FALSE.
IF( INPARM.GE.1 .AND. NP1( J ).NE.NP1( IPAR ) )
$ LTEMP = .TRUE.
IF( INPARM.GE.2 .AND. NP2( J ).NE.NP2( IPAR ) )
$ LTEMP = .TRUE.
IF( INPARM.GE.3 .AND. NP3( J ).NE.NP3( IPAR ) )
$ LTEMP = .TRUE.
IF( INPARM.GE.4 .AND. NP4( J ).NE.NP4( IPAR ) )
$ LTEMP = .TRUE.
IF( INPARM.GE.5 .AND. NP5( J ).NE.NP5( IPAR ) )
$ LTEMP = .TRUE.
IF( INPARM.GE.6 .AND. NP6( J ).NE.NP6( IPAR ) )
$ LTEMP = .TRUE.
IF( .NOT.LTEMP )
$ LLWORK( IPAR ) = .FALSE.
10 CONTINUE
IF( LLWORK( IPAR ) )
$ ILINES = ILINES + 1
20 CONTINUE
IF( ILINES.EQ.1 ) THEN
IF( INPARM.EQ.1 ) THEN
WRITE( NOUT, FMT = 9995 )PNAMES( 1 ), NP1( 1 )
ELSE IF( INPARM.EQ.2 ) THEN
WRITE( NOUT, FMT = 9995 )PNAMES( 1 ), NP1( 1 ),
$ PNAMES( 2 ), NP2( 1 )
ELSE IF( INPARM.EQ.3 ) THEN
WRITE( NOUT, FMT = 9995 )PNAMES( 1 ), NP1( 1 ),
$ PNAMES( 2 ), NP2( 1 ), PNAMES( 3 ), NP3( 1 )
ELSE IF( INPARM.EQ.4 ) THEN
WRITE( NOUT, FMT = 9995 )PNAMES( 1 ), NP1( 1 ),
$ PNAMES( 2 ), NP2( 1 ), PNAMES( 3 ), NP3( 1 ),
$ PNAMES( 4 ), NP4( 1 )
ELSE IF( INPARM.EQ.5 ) THEN
WRITE( NOUT, FMT = 9995 )PNAMES( 1 ), NP1( 1 ),
$ PNAMES( 2 ), NP2( 1 ), PNAMES( 3 ), NP3( 1 ),
$ PNAMES( 4 ), NP4( 1 ), PNAMES( 5 ), NP5( 1 )
ELSE IF( INPARM.EQ.6 ) THEN
WRITE( NOUT, FMT = 9995 )PNAMES( 1 ), NP1( 1 ),
$ PNAMES( 2 ), NP2( 1 ), PNAMES( 3 ), NP3( 1 ),
$ PNAMES( 4 ), NP4( 1 ), PNAMES( 5 ), NP5( 1 ),
$ PNAMES( 6 ), NP6( 1 )
END IF
ELSE
ILINE = 0
*
* Compute output format statement.
*
IPADI = MAX( LEN( PNAMES( 1 ) ) - 3, 1 )
WRITE( FRMATI, FMT = 9980 ) IPADI
IPADA = 5 + IPADI - LEN( PNAMES( 1 ) )
WRITE( FRMATA, FMT = 9981 ) IPADA
WRITE( NOUT, FMT = FRMATA )
$ ( PNAMES( J ), J = 1, MIN( 6, INPARM ) )
DO 30 J = 1, NPARMS
IF( LLWORK( J ) ) THEN
ILINE = ILINE + 1
IF( INPARM.EQ.1 ) THEN
WRITE( NOUT, FMT = FRMATI )ILINE, NP1( J )
ELSE IF( INPARM.EQ.2 ) THEN
WRITE( NOUT, FMT = FRMATI )ILINE, NP1( J ), NP2( J )
ELSE IF( INPARM.EQ.3 ) THEN
WRITE( NOUT, FMT = FRMATI )ILINE, NP1( J ), NP2( J ),
$ NP3( J )
ELSE IF( INPARM.EQ.4 ) THEN
WRITE( NOUT, FMT = FRMATI )ILINE, NP1( J ), NP2( J ),
$ NP3( J ), NP4( J )
ELSE IF( INPARM.EQ.5 ) THEN
WRITE( NOUT, FMT = FRMATI )ILINE, NP1( J ), NP2( J ),
$ NP3( J ), NP4( J ), NP5( J )
ELSE IF( INPARM.EQ.6 ) THEN
WRITE( NOUT, FMT = FRMATI )ILINE, NP1( J ), NP2( J ),
$ NP3( J ), NP4( J ), NP5( J ), NP6( J )
END IF
END IF
30 CONTINUE
END IF
*
* Execution Times
*
WRITE( NOUT, FMT = 9996 )
CALL SPRTBS( 'Type', 'N ', NTYPES, DOTYPE, NSIZES, NN, NPARMS,
$ LLWORK, TIMES, LDT1, LDT2, NOUT )
*
* Operation Counts
*
WRITE( NOUT, FMT = 9997 )
CALL SPRTBS( 'Type', 'N ', NTYPES, DOTYPE, NSIZES, NN, NPARMS,
$ LLWORK, OPS, LDO1, LDO2, NOUT )
*
* Megaflop Rates
*
IINFO = 0
DO 60 JS = 1, NSIZES
DO 50 JT = 1, NTYPES
IF( DOTYPE( JT ) ) THEN
DO 40 JP = 1, NPARMS
I = JP + NPARMS*( JT-1+NTYPES*( JS-1 ) )
RWORK( I ) = SMFLOP( OPS( JP, JT, JS ),
$ TIMES( JP, JT, JS ), IINFO )
40 CONTINUE
END IF
50 CONTINUE
60 CONTINUE
*
WRITE( NOUT, FMT = 9998 )
CALL SPRTBS( 'Type', 'N ', NTYPES, DOTYPE, NSIZES, NN, NPARMS,
$ LLWORK, RWORK, NPARMS, NTYPES, NOUT )
*
9999 FORMAT( / / / ' ****** Results for ', A, ' ******' )
9998 FORMAT( / ' *** Speed in megaflops ***' )
9997 FORMAT( / ' *** Number of floating-point operations ***' )
9996 FORMAT( / ' *** Time in seconds ***' )
9995 FORMAT( 5X, : 'with ', 4( A, '=', I5, : ', ' ) /
$ 10X, 2( A, '=', I5, : ', ' ) )
*
* Format statements for generating format statements.
* 9981 generates a string 21+2+11=34 characters long.
* 9980 generates a string 16+2+12=30 characters long.
*
9981 FORMAT( '( 5X, : ''line '' , 6( ', I2, 'X, A, : ) )' )
9980 FORMAT( '( 5X, : I5 , 6( ', I2, 'X, I5, : ) )' )
RETURN
*
* End of SPRTBG
*
END
SUBROUTINE SPRTBR( LAB1, LAB2, NTYPES, DOTYPE, NSIZES, MM, NN,
$ NPARMS, DOLINE, RESLTS, LDR1, LDR2, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
CHARACTER*( * ) LAB1, LAB2
INTEGER LDR1, LDR2, NOUT, NPARMS, NSIZES, NTYPES
* ..
* .. Array Arguments ..
LOGICAL DOLINE( NPARMS ), DOTYPE( NTYPES )
INTEGER MM( NSIZES ), NN( NSIZES )
REAL RESLTS( LDR1, LDR2, * )
* ..
*
* Purpose
* =======
*
* SPRTBR prints a table of timing data for the timing programs.
* The table has NTYPES block rows and NSIZES columns, with NPARMS
* individual rows in each block row.
*
* Arguments (none are modified)
* =========
*
* LAB1 - CHARACTER*(*)
* The label for the rows.
*
* LAB2 - CHARACTER*(*)
* The label for the columns.
*
* NTYPES - INTEGER
* The number of values of DOTYPE, and also the
* number of sets of rows of the table.
*
* DOTYPE - LOGICAL array of dimension( NTYPES )
* If DOTYPE(j) is .TRUE., then block row j (which includes
* data from RESLTS( i, j, k ), for all i and k) will be
* printed. If DOTYPE(j) is .FALSE., then block row j will
* not be printed.
*
* NSIZES - INTEGER
* The number of values of NN, and also the
* number of columns of the table.
*
* MM - INTEGER array of dimension( NSIZES )
* The values of M used to label each column.
*
* NN - INTEGER array of dimension( NSIZES )
* The values of N used to label each column.
*
* NPARMS - INTEGER
* The number of values of LDA, hence the
* number of rows for each value of DOTYPE.
*
* DOLINE - LOGICAL array of dimension( NPARMS )
* If DOLINE(i) is .TRUE., then row i (which includes data
* from RESLTS( i, j, k ) for all j and k) will be printed.
* If DOLINE(i) is .FALSE., then row i will not be printed.
*
* RESLTS - REAL array of dimension( LDR1, LDR2, NSIZES )
* The timing results. The first index indicates the row,
* the second index indicates the block row, and the last
* indicates the column.
*
* LDR1 - INTEGER
* The first dimension of RESLTS. It must be at least
* min( 1, NPARMS ).
*
* LDR2 - INTEGER
* The second dimension of RESLTS. It must be at least
* min( 1, NTYPES ).
*
* NOUT - INTEGER
* The output unit number on which the table
* is to be printed. If NOUT <= 0, no output is printed.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, ILINE, J, K
* ..
* .. Executable Statements ..
*
IF( NOUT.LE.0 )
$ RETURN
IF( NPARMS.LE.0 )
$ RETURN
WRITE( NOUT, FMT = 9999 )LAB2,
$ ( MM( I ), NN( I ), I = 1, NSIZES )
WRITE( NOUT, FMT = 9998 )LAB1
*
DO 20 J = 1, NTYPES
ILINE = 0
IF( DOTYPE( J ) ) THEN
DO 10 I = 1, NPARMS
IF( DOLINE( I ) ) THEN
ILINE = ILINE + 1
IF( ILINE.LE.1 ) THEN
WRITE( NOUT, FMT = 9997 )J,
$ ( RESLTS( I, J, K ), K = 1, NSIZES )
ELSE
WRITE( NOUT, FMT = 9996 )( RESLTS( I, J, K ),
$ K = 1, NSIZES )
END IF
END IF
10 CONTINUE
IF( ILINE.GT.1 .AND. J.LT.NTYPES )
$ WRITE( NOUT, FMT = * )
END IF
20 CONTINUE
RETURN
*
9999 FORMAT( 7X, A4, ( 12( '(', I4, ',', I4, ')', : ) ) )
9998 FORMAT( 3X, A4 )
9997 FORMAT( 3X, I4, 4X, 1P, ( 12( 3X, G8.2 ) ) )
9996 FORMAT( 11X, 1P, ( 12( 3X, G8.2 ) ) )
*
* End of SPRTBR
*
END
SUBROUTINE SPRTBS( LAB1, LAB2, NTYPES, DOTYPE, NSIZES, NN, NPARMS,
$ DOLINE, RESLTS, LDR1, LDR2, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
CHARACTER*( * ) LAB1, LAB2
INTEGER LDR1, LDR2, NOUT, NPARMS, NSIZES, NTYPES
* ..
* .. Array Arguments ..
LOGICAL DOLINE( NPARMS ), DOTYPE( NTYPES )
INTEGER NN( NSIZES )
REAL RESLTS( LDR1, LDR2, * )
* ..
*
* Purpose
* =======
*
* SPRTBS prints a table of timing data for the timing programs.
* The table has NTYPES block rows and NSIZES columns, with NPARMS
* individual rows in each block row.
*
* Arguments (none are modified)
* =========
*
* LAB1 - CHARACTER*(*)
* The label for the rows.
*
* LAB2 - CHARACTER*(*)
* The label for the columns.
*
* NTYPES - INTEGER
* The number of values of DOTYPE, and also the
* number of sets of rows of the table.
*
* DOTYPE - LOGICAL array of dimension( NTYPES )
* If DOTYPE(j) is .TRUE., then block row j (which includes
* data from RESLTS( i, j, k ), for all i and k) will be
* printed. If DOTYPE(j) is .FALSE., then block row j will
* not be printed.
*
* NSIZES - INTEGER
* The number of values of NN, and also the
* number of columns of the table.
*
* NN - INTEGER array of dimension( NSIZES )
* The values of N used to label each column.
*
* NPARMS - INTEGER
* The number of values of LDA, hence the
* number of rows for each value of DOTYPE.
*
* DOLINE - LOGICAL array of dimension( NPARMS )
* If DOLINE(i) is .TRUE., then row i (which includes data
* from RESLTS( i, j, k ) for all j and k) will be printed.
* If DOLINE(i) is .FALSE., then row i will not be printed.
*
* RESLTS - REAL array of dimension( LDR1, LDR2, NSIZES )
* The timing results. The first index indicates the row,
* the second index indicates the block row, and the last
* indicates the column.
*
* LDR1 - INTEGER
* The first dimension of RESLTS. It must be at least
* min( 1, NPARMS ).
*
* LDR2 - INTEGER
* The second dimension of RESLTS. It must be at least
* min( 1, NTYPES ).
*
* NOUT - INTEGER
* The output unit number on which the table
* is to be printed. If NOUT <= 0, no output is printed.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, ILINE, J, K
* ..
* .. Executable Statements ..
*
IF( NOUT.LE.0 )
$ RETURN
IF( NPARMS.LE.0 )
$ RETURN
WRITE( NOUT, FMT = 9999 )LAB2, ( NN( I ), I = 1, NSIZES )
WRITE( NOUT, FMT = 9998 )LAB1
*
DO 20 J = 1, NTYPES
ILINE = 0
IF( DOTYPE( J ) ) THEN
DO 10 I = 1, NPARMS
IF( DOLINE( I ) ) THEN
ILINE = ILINE + 1
IF( ILINE.LE.1 ) THEN
WRITE( NOUT, FMT = 9997 )J,
$ ( RESLTS( I, J, K ), K = 1, NSIZES )
ELSE
WRITE( NOUT, FMT = 9996 )( RESLTS( I, J, K ),
$ K = 1, NSIZES )
END IF
END IF
10 CONTINUE
IF( ILINE.GT.1 .AND. J.LT.NTYPES )
$ WRITE( NOUT, FMT = * )
END IF
20 CONTINUE
RETURN
*
9999 FORMAT( 6X, A4, I6, 11I9 )
9998 FORMAT( 3X, A4 )
9997 FORMAT( 3X, I4, 4X, 1P, 12( 1X, G8.2 ) )
9996 FORMAT( 11X, 1P, 12( 1X, G8.2 ) )
*
* End of SPRTBS
*
END
SUBROUTINE SPRTBV( SUBNAM, NTYPES, DOTYPE, NSIZES, MM, NN, INPARM,
$ PNAMES, NPARMS, NP1, NP2, OPS, LDO1, LDO2,
$ TIMES, LDT1, LDT2, RWORK, LLWORK, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
CHARACTER*( * ) SUBNAM
INTEGER INPARM, LDO1, LDO2, LDT1, LDT2, NOUT, NPARMS,
$ NSIZES, NTYPES
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( NTYPES ), LLWORK( NPARMS )
CHARACTER*( * ) PNAMES( * )
INTEGER MM( NSIZES ), NN( NSIZES ), NP1( * ), NP2( * )
REAL OPS( LDO1, LDO2, * ), RWORK( * ),
$ TIMES( LDT1, LDT2, * )
* ..
*
* Purpose
* =======
*
* SPRTBV prints out timing information for the eigenvalue routines.
* The table has NTYPES block rows and NSIZES columns, with NPARMS
* individual rows in each block row. There are INPARM quantities
* which depend on rows (currently, INPARM <= 4).
*
* Arguments (none are modified)
* =========
*
* SUBNAM - CHARACTER*(*)
* The label for the output.
*
* NTYPES - INTEGER
* The number of values of DOTYPE, and also the
* number of sets of rows of the table.
*
* DOTYPE - LOGICAL array of dimension( NTYPES )
* If DOTYPE(j) is .TRUE., then block row j (which includes
* data from RESLTS( i, j, k ), for all i and k) will be
* printed. If DOTYPE(j) is .FALSE., then block row j will
* not be printed.
*
* NSIZES - INTEGER
* The number of values of NN, and also the
* number of columns of the table.
*
* MM - INTEGER array of dimension( NSIZES )
* The values of M used to label each column.
*
* NN - INTEGER array of dimension( NSIZES )
* The values of N used to label each column.
*
* INPARM - INTEGER
* The number of different parameters which are functions of
* the row number. At the moment, INPARM <= 4.
*
* PNAMES - CHARACTER*(*) array of dimension( INPARM )
* The label for the columns.
*
* NPARMS - INTEGER
* The number of values for each "parameter", i.e., the
* number of rows for each value of DOTYPE.
*
* NP1 - INTEGER array of dimension( NPARMS )
* The first quantity which depends on row number.
*
* NP2 - INTEGER array of dimension( NPARMS )
* The second quantity which depends on row number.
*
* OPS - REAL array of dimension( LDT1, LDT2, NSIZES )
* The operation counts. The first index indicates the row,
* the second index indicates the block row, and the last
* indicates the column.
*
* LDO1 - INTEGER
* The first dimension of OPS. It must be at least
* min( 1, NPARMS ).
*
* LDO2 - INTEGER
* The second dimension of OPS. It must be at least
* min( 1, NTYPES ).
*
* TIMES - REAL array of dimension( LDT1, LDT2, NSIZES )
* The times (in seconds). The first index indicates the row,
* the second index indicates the block row, and the last
* indicates the column.
*
* LDT1 - INTEGER
* The first dimension of RESLTS. It must be at least
* min( 1, NPARMS ).
*
* LDT2 - INTEGER
* The second dimension of RESLTS. It must be at least
* min( 1, NTYPES ).
*
* RWORK - REAL array of dimension( NSIZES*NTYPES*NPARMS )
* Real workspace.
* Modified.
*
* LLWORK - LOGICAL array of dimension( NPARMS )
* Logical workspace. It is used to turn on or off specific
* lines in the output. If LLWORK(i) is .TRUE., then row i
* (which includes data from OPS(i,j,k) or TIMES(i,j,k) for
* all j and k) will be printed. If LLWORK(i) is
* .FALSE., then row i will not be printed.
* Modified.
*
* NOUT - INTEGER
* The output unit number on which the table
* is to be printed. If NOUT <= 0, no output is printed.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LTEMP
INTEGER I, IINFO, ILINE, ILINES, IPAR, J, JP, JS, JT
* ..
* .. External Functions ..
REAL SMFLOP
EXTERNAL SMFLOP
* ..
* .. External Subroutines ..
EXTERNAL SPRTBR
* ..
* .. Executable Statements ..
*
*
* First line
*
WRITE( NOUT, FMT = 9999 )SUBNAM
*
* Set up which lines are to be printed.
*
LLWORK( 1 ) = .TRUE.
ILINES = 1
DO 20 IPAR = 2, NPARMS
LLWORK( IPAR ) = .TRUE.
DO 10 J = 1, IPAR - 1
LTEMP = .FALSE.
IF( INPARM.GE.1 .AND. NP1( J ).NE.NP1( IPAR ) )
$ LTEMP = .TRUE.
IF( INPARM.GE.2 .AND. NP2( J ).NE.NP2( IPAR ) )
$ LTEMP = .TRUE.
IF( .NOT.LTEMP )
$ LLWORK( IPAR ) = .FALSE.
10 CONTINUE
IF( LLWORK( IPAR ) )
$ ILINES = ILINES + 1
20 CONTINUE
IF( ILINES.EQ.1 ) THEN
IF( INPARM.EQ.1 ) THEN
WRITE( NOUT, FMT = 9995 )PNAMES( 1 ), NP1( 1 )
ELSE IF( INPARM.EQ.2 ) THEN
WRITE( NOUT, FMT = 9995 )PNAMES( 1 ), NP1( 1 ),
$ PNAMES( 2 ), NP2( 1 )
END IF
ELSE
ILINE = 0
DO 30 J = 1, NPARMS
IF( LLWORK( J ) ) THEN
ILINE = ILINE + 1
IF( INPARM.EQ.1 ) THEN
WRITE( NOUT, FMT = 9994 )ILINE, PNAMES( 1 ), NP1( J )
ELSE IF( INPARM.EQ.2 ) THEN
WRITE( NOUT, FMT = 9994 )ILINE, PNAMES( 1 ),
$ NP1( J ), PNAMES( 2 ), NP2( J )
END IF
END IF
30 CONTINUE
END IF
*
* Execution Times
*
WRITE( NOUT, FMT = 9996 )
CALL SPRTBR( 'Type', 'M,N ', NTYPES, DOTYPE, NSIZES, MM, NN,
$ NPARMS, LLWORK, TIMES, LDT1, LDT2, NOUT )
*
* Operation Counts
*
WRITE( NOUT, FMT = 9997 )
CALL SPRTBR( 'Type', 'M,N ', NTYPES, DOTYPE, NSIZES, MM, NN,
$ NPARMS, LLWORK, OPS, LDO1, LDO2, NOUT )
*
* Megaflop Rates
*
IINFO = 0
DO 60 JS = 1, NSIZES
DO 50 JT = 1, NTYPES
IF( DOTYPE( JT ) ) THEN
DO 40 JP = 1, NPARMS
I = JP + NPARMS*( JT-1+NTYPES*( JS-1 ) )
RWORK( I ) = SMFLOP( OPS( JP, JT, JS ),
$ TIMES( JP, JT, JS ), IINFO )
40 CONTINUE
END IF
50 CONTINUE
60 CONTINUE
*
WRITE( NOUT, FMT = 9998 )
CALL SPRTBR( 'Type', 'M,N ', NTYPES, DOTYPE, NSIZES, MM, NN,
$ NPARMS, LLWORK, RWORK, NPARMS, NTYPES, NOUT )
*
9999 FORMAT( / / / ' ****** Results for ', A, ' ******' )
9998 FORMAT( / ' *** Speed in megaflops ***' )
9997 FORMAT( / ' *** Number of floating-point operations ***' )
9996 FORMAT( / ' *** Time in seconds ***' )
9995 FORMAT( 5X, : 'with ', A, '=', I5, 3( : ', ', A, '=', I5 ) )
9994 FORMAT( 5X, : 'line ', I2, ' with ', A, '=', I5,
$ 3( : ', ', A, '=', I5 ) )
RETURN
*
* End of SPRTBV
*
END
SUBROUTINE STIM21( LINE, NSIZES, NN, NTYPES, DOTYPE, NPARMS, NNB,
$ NSHFTS, MAXBS, LDAS, TIMMIN, NOUT, ISEED, A, H,
$ Z, W, WORK, LWORK, LLWORK, IWORK, TIMES, LDT1,
$ LDT2, LDT3, OPCNTS, LDO1, LDO2, LDO3, INFO )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER INFO, LDO1, LDO2, LDO3, LDT1, LDT2, LDT3,
$ LWORK, NOUT, NPARMS, NSIZES, NTYPES
REAL TIMMIN
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * ), LLWORK( * )
INTEGER ISEED( * ), IWORK( * ), LDAS( * ), MAXBS( * ),
$ NN( * ), NNB( * ), NSHFTS( * )
REAL A( * ), H( * ), OPCNTS( LDO1, LDO2, LDO3, * ),
$ TIMES( LDT1, LDT2, LDT3, * ), W( * ),
$ WORK( * ), Z( * )
* ..
*
* Purpose
* =======
*
* STIM21 times the LAPACK routines for the REAL
* non-symmetric eigenvalue problem.
*
* For each N value in NN(1:NSIZES) and .TRUE. value in
* DOTYPE(1:NTYPES), a matrix will be generated and used to test the
* selected routines. Thus, NSIZES*(number of .TRUE. values in
* DOTYPE) matrices will be generated.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* On entry, LINE contains the input line which requested
* this routine. This line may contain a subroutine name,
* such as SGEHRD, indicating that only routine SGEHRD will
* be timed, or it may contain a generic name, such as SHS.
* In this case, the rest of the line is scanned for the
* first 12 non-blank characters, corresponding to the twelve
* combinations of subroutine and options:
* LAPACK:
* 1: SGEHRD
* 2: SHSEQR(JOB='E')
* 3: SHSEQR(JOB='S')
* 4: SHSEQR(JOB='I')
* 5: STREVC(JOB='L')
* 6: STREVC(JOB='R')
* 7: SHSEIN(JOB='L')
* 8: SHSEIN(JOB='R')
* EISPACK:
* 9: ORTHES (compare with SGEHRD)
* 10: HQR (compare w/ SHSEQR -- JOB='E')
* 11: HQR2 (compare w/ SHSEQR(JOB='I') plus STREVC(JOB='R'))
* 12: INVIT (compare with SHSEIN)
* If a character is 'T' or 't', the corresponding routine in
* this path is timed. If the entire line is blank, all the
* routines in the path are timed.
*
* NSIZES (input) INTEGER
* The number of values of N contained in the vector NN.
*
* NN (input) INTEGER array, dimension( NSIZES )
* The values of the matrix size N to be tested. For each
* N value in the array NN, and each .TRUE. value in DOTYPE,
* a matrix A will be generated and used to test the routines.
*
* NTYPES (input) INTEGER
* The number of types in DOTYPE. Only the first MAXTYP
* elements will be examined. Exception: if NSIZES=1 and
* NTYPES=MAXTYP+1, and DOTYPE=MAXTYP*f,t, then the input
* value of A will be used.
*
* DOTYPE (input) LOGICAL
* If DOTYPE(j) is .TRUE., then a matrix of type j will be
* generated. The matrix A has the form X**(-1) T X, where
* X is orthogonal (for j=1--4) or has condition sqrt(ULP)
* (for j=5--8), and T has random O(1) entries in the upper
* triangle and:
* (j=1,5) evenly spaced entries 1, ..., ULP with random signs
* (j=2,6) geometrically spaced entries 1, ..., ULP with random
* signs
* (j=3,7) "clustered" entries 1, ULP,..., ULP with random
* signs
* (j=4,8) real or complex conjugate paired eigenvalues
* randomly chosen from ( ULP, 1 )
* on the diagonal.
*
* NPARMS (input) INTEGER
* The number of values in each of the arrays NNB, NSHFTS,
* MAXBS, and LDAS. For each matrix A generated according to
* NN and DOTYPE, tests will be run with (NB,NSHIFT,MAXB,LDA)=
* (NNB(1), NSHFTS(1), MAXBS(1), LDAS(1)),...,
* (NNB(NPARMS), NSHFTS(NPARMS), MAXBS(NPARMS), LDAS(NPARMS))
*
* NNB (input) INTEGER array, dimension( NPARMS )
* The values of the blocksize ("NB") to be tested.
*
* NSHFTS (input) INTEGER array, dimension( NPARMS )
* The values of the number of shifts ("NSHIFT") to be tested.
*
* MAXBS (input) INTEGER array, dimension( NPARMS )
* The values of "MAXB", the size of largest submatrix to be
* processed by SLAHQR (EISPACK method), to be tested.
*
* LDAS (input) INTEGER array, dimension( NPARMS )
* The values of LDA, the leading dimension of all matrices,
* to be tested.
*
* TIMMIN (input) REAL
* The minimum time a subroutine will be timed.
*
* NOUT (input) INTEGER
* If NOUT > 0 then NOUT specifies the unit number
* on which the output will be printed. If NOUT <= 0, no
* output is printed.
*
* ISEED (input/output) INTEGER array, dimension( 4 )
* The random seed used by the random number generator, used
* by the test matrix generator. It is used and updated on
* each call to STIM21
*
* A (workspace) REAL array,
* dimension( max(NN)*max(LDAS) )
* (a) During the testing of SGEHRD, the original matrix to
* be tested.
* (b) Later, the Schur form of the original matrix.
*
* H (workspace) REAL array,
* dimension( max(NN)*max(LDAS) )
* The Hessenberg form of the original matrix.
*
* Z (workspace) REAL array,
* dimension( max(NN)*max(LDAS) )
* Various output arrays: from SGEHRD and SHSEQR, the
* orthogonal reduction matrices; from STREVC and SHSEIN,
* the eigenvector matrices.
*
* W (workspace) REAL array,
* dimension( 2*max(LDAS) )
* Treated as an LDA x 2 matrix whose 1st column holds WR, the
* real parts of the eigenvalues, and whose 2nd column holds
* WI, the imaginary parts of the eigenvalues of A.
*
* WORK (workspace) REAL array, dimension( LWORK )
*
* LWORK (input) INTEGER
* Number of elements in WORK. It must be at least
* (a) max(NN)*( 3*max(NNB) + 2 )
* (b) max(NN)*( max(NNB+NSHFTS) + 1 )
* (c) max(NSHFTS)*( max(NSHFTS) + max(NN) )
* (d) max(MAXBS)*( max(MAXBS) + max(NN) )
* (e) ( max(NN) + 2 )**2 + max(NN)
* (f) NSIZES*NTYPES*NPARMS
*
* LLWORK (workspace) LOGICAL array, dimension( max( max(NN), NPARMS ))
*
* IWORK (workspace) INTEGER array, dimension( 2*max(NN) )
* Workspace needed for parameters IFAILL and IFAILR in call
* to SHSEIN.
*
* TIMES (output) REAL array,
* dimension (LDT1,LDT2,LDT3,NSUBS)
* TIMES(i,j,k,l) will be set to the run time (in seconds) for
* subroutine l, with N=NN(k), matrix type j, and LDA=LDAS(i),
* MAXB=MAXBS(i), NBLOCK=NNB(i), and NSHIFT=NSHFTS(i).
*
* LDT1 (input) INTEGER
* The first dimension of TIMES. LDT1 >= min( 1, NPARMS ).
*
* LDT2 (input) INTEGER
* The second dimension of TIMES. LDT2 >= min( 1, NTYPES ).
*
* LDT3 (input) INTEGER
* The third dimension of TIMES. LDT3 >= min( 1, NSIZES ).
*
* OPCNTS (output) REAL array,
* dimension (LDO1,LDO2,LDO3,NSUBS)
* OPCNTS(i,j,k,l) will be set to the number of floating-point
* operations executed by subroutine l, with N=NN(k), matrix
* type j, and LDA=LDAS(i), MAXB=MAXBS(i), NBLOCK=NNB(i), and
* NSHIFT=NSHFTS(i).
*
* LDO1 (input) INTEGER
* The first dimension of OPCNTS. LDO1 >= min( 1, NPARMS ).
*
* LDO2 (input) INTEGER
* The second dimension of OPCNTS. LDO2 >= min( 1, NTYPES ).
*
* LDO3 (input) INTEGER
* The third dimension of OPCNTS. LDO3 >= min( 1, NSIZES ).
*
* INFO (output) INTEGER
* Error flag. It will be set to zero if no error occurred.
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXTYP, NSUBS
PARAMETER ( MAXTYP = 8, NSUBS = 12 )
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL RUNHQR, RUNHRD, RUNORT, RUNQRE, RUNQRS
INTEGER IC, ICONDS, IINFO, IMODE, IN, IPAR, ISUB,
$ ITEMP, ITYPE, J, J1, J2, J3, J4, JC, JR, LASTL,
$ LASTNL, LDA, LDAMIN, LDH, LDT, LDW, MAXB,
$ MBMAX, MTYPES, N, NB, NBMAX, NMAX,
$ NSBMAX, NSHIFT, NSMAX
REAL CONDS, RTULP, RTULPI, S1, S2, TIME, ULP,
$ ULPINV, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER ADUMMA( 1 )
CHARACTER*4 PNAMES( 4 )
CHARACTER*9 SUBNAM( NSUBS )
INTEGER INPARM( NSUBS ), IOLDSD( 4 ), KCONDS( MAXTYP ),
$ KMODE( MAXTYP )
* ..
* .. External Functions ..
REAL SLAMCH, SECOND, SOPLA
EXTERNAL SLAMCH, SECOND, SOPLA
* ..
* .. External Subroutines ..
EXTERNAL ATIMIN, HQR, HQR2, INVIT, ORTHES, SGEHRD,
$ SHSEIN, SHSEQR, SLACPY, SLATME, SLASET, SPRTBE,
$ STREVC, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL, SQRT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Data statements ..
DATA SUBNAM / 'SGEHRD', 'SHSEQR(E)', 'SHSEQR(S)',
$ 'SHSEQR(V)', 'STREVC(L)', 'STREVC(R)',
$ 'SHSEIN(L)', 'SHSEIN(R)', 'ORTHES', 'HQR',
$ 'HQR2', 'INVIT' /
DATA INPARM / 2, 4, 4, 4, 1, 1, 1, 1, 1, 1, 1, 1 /
DATA PNAMES / 'LDA', 'NB', 'NS', 'MAXB' /
DATA KMODE / 4, 3, 1, 5, 4, 3, 1, 5 /
DATA KCONDS / 4*1, 4*2 /
* ..
* .. Executable Statements ..
*
* Quick Return
*
INFO = 0
IF( NSIZES.LE.0 .OR. NTYPES.LE.0 .OR. NPARMS.LE.0 )
$ RETURN
*
* Extract the timing request from the input line.
*
CALL ATIMIN( 'SHS', LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ RETURN
*
* Compute Maximum Values
*
NMAX = 0
DO 10 J1 = 1, NSIZES
NMAX = MAX( NMAX, NN( J1 ) )
10 CONTINUE
*
LDAMIN = 2*MAX( 1, NMAX )
NBMAX = 0
NSMAX = 0
MBMAX = 0
NSBMAX = 0
DO 20 J1 = 1, NPARMS
LDAMIN = MIN( LDAMIN, LDAS( J1 ) )
NBMAX = MAX( NBMAX, NNB( J1 ) )
NSMAX = MAX( NSMAX, NSHFTS( J1 ) )
MBMAX = MAX( MBMAX, MAXBS( J1 ) )
NSBMAX = MAX( NSBMAX, NNB( J1 )+NSHFTS( J1 ) )
20 CONTINUE
*
* Check that N <= LDA for the input values.
*
IF( NMAX.GT.LDAMIN ) THEN
INFO = -10
WRITE( NOUT, FMT = 9999 )LINE( 1: 6 )
9999 FORMAT( 1X, A, ' timing run not attempted -- N > LDA', / )
RETURN
END IF
*
* Check LWORK
*
IF( LWORK.LT.MAX( NMAX*MAX( 3*NBMAX+2, NSBMAX+1 ),
$ NSMAX*( NSMAX+NMAX ), MBMAX*( MBMAX+NMAX ),
$ ( NMAX+1 )*( NMAX+4 ), NSIZES*NTYPES*NPARMS ) ) THEN
INFO = -19
WRITE( NOUT, FMT = 9998 )LINE( 1: 6 )
9998 FORMAT( 1X, A, ' timing run not attempted -- LWORK too small.',
$ / )
RETURN
END IF
*
* Check to see whether SGEHRD or SHSEQR must be run.
*
* RUNQRE -- if SHSEQR must be run to get eigenvalues.
* RUNQRS -- if SHSEQR must be run to get Schur form.
* RUNHRD -- if SGEHRD must be run.
*
RUNQRS = .FALSE.
RUNQRE = .FALSE.
RUNHRD = .FALSE.
IF( TIMSUB( 5 ) .OR. TIMSUB( 6 ) )
$ RUNQRS = .TRUE.
IF( ( TIMSUB( 7 ) .OR. TIMSUB( 8 ) ) )
$ RUNQRE = .TRUE.
IF( TIMSUB( 2 ) .OR. TIMSUB( 3 ) .OR. TIMSUB( 4 ) .OR. RUNQRS .OR.
$ RUNQRE )RUNHRD = .TRUE.
IF( TIMSUB( 3 ) .OR. TIMSUB( 4 ) .OR. RUNQRS )
$ RUNQRE = .FALSE.
IF( TIMSUB( 4 ) )
$ RUNQRS = .FALSE.
*
* Check to see whether ORTHES or HQR must be run.
*
* RUNHQR -- if HQR must be run to get eigenvalues.
* RUNORT -- if ORTHES must be run.
*
RUNHQR = .FALSE.
RUNORT = .FALSE.
IF( TIMSUB( 12 ) )
$ RUNHQR = .TRUE.
IF( TIMSUB( 10 ) .OR. TIMSUB( 11 ) .OR. RUNHQR )
$ RUNORT = .TRUE.
IF( TIMSUB( 10 ) .OR. TIMSUB( 11 ) )
$ RUNHQR = .FALSE.
IF( TIMSUB( 9 ) )
$ RUNORT = .FALSE.
*
* Various Constants
*
ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
ULPINV = ONE / ULP
RTULP = SQRT( ULP )
RTULPI = ONE / RTULP
*
* Zero out OPCNTS, TIMES
*
DO 60 J4 = 1, NSUBS
DO 50 J3 = 1, NSIZES
DO 40 J2 = 1, NTYPES
DO 30 J1 = 1, NPARMS
OPCNTS( J1, J2, J3, J4 ) = ZERO
TIMES( J1, J2, J3, J4 ) = ZERO
30 CONTINUE
40 CONTINUE
50 CONTINUE
60 CONTINUE
*
* Do for each value of N:
*
DO 620 IN = 1, NSIZES
*
N = NN( IN )
*
* Do for each .TRUE. value in DOTYPE:
*
MTYPES = MIN( MAXTYP, NTYPES )
IF( NTYPES.EQ.MAXTYP+1 .AND. NSIZES.EQ.1 )
$ MTYPES = NTYPES
DO 610 ITYPE = 1, MTYPES
IF( .NOT.DOTYPE( ITYPE ) )
$ GO TO 610
*
* Save random number seed for error messages
*
DO 70 J = 1, 4
IOLDSD( J ) = ISEED( J )
70 CONTINUE
*
*-----------------------------------------------------------------------
*
* Time the LAPACK Routines
*
* Generate A
*
IF( ITYPE.LE.MAXTYP ) THEN
IMODE = KMODE( ITYPE )
ICONDS = KCONDS( ITYPE )
IF( ICONDS.EQ.1 ) THEN
CONDS = ONE
ELSE
CONDS = RTULPI
END IF
ADUMMA( 1 ) = ' '
CALL SLATME( N, 'S', ISEED, WORK, IMODE, ULPINV, ONE,
$ ADUMMA, 'T', 'T', 'T', WORK( N+1 ), 4,
$ CONDS, N, N, ONE, A, N, WORK( 2*N+1 ),
$ IINFO )
END IF
*
* Time SGEHRD for each pair NNB(j), LDAS(j)
*
IF( TIMSUB( 1 ) ) THEN
DO 110 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
*
* If this combination of (NB,LDA) has occurred before,
* just use that value.
*
LASTNL = 0
DO 80 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) .AND. NB.EQ.
$ MIN( N, NNB( J ) ) )LASTNL = J
80 CONTINUE
*
IF( LASTNL.EQ.0 ) THEN
CALL XLAENV( 1, NB )
CALL XLAENV( 2, 2 )
CALL XLAENV( 3, NB )
*
* Time SGEHRD
*
IC = 0
OPS = ZERO
S1 = SECOND( )
90 CONTINUE
CALL SLACPY( 'Full', N, N, A, N, H, LDA )
*
CALL SGEHRD( N, 1, N, H, LDA, WORK,
$ WORK(N+1), LWORK-N, IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 1 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 610
END IF
*
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 90
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 100 J = 1, IC
CALL SLACPY( 'Full', N, N, A, N, Z, LDA )
100 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 1 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 1 ) = SOPLA( 'SGEHRD',
$ N, 1, N, 0, NB )
ELSE
OPCNTS( IPAR, ITYPE, IN, 1 ) = OPCNTS( LASTNL,
$ ITYPE, IN, 1 )
TIMES( IPAR, ITYPE, IN, 1 ) = TIMES( LASTNL, ITYPE,
$ IN, 1 )
END IF
110 CONTINUE
LDH = LDA
ELSE
IF( RUNHRD ) THEN
CALL SLACPY( 'Full', N, N, A, N, H, N )
*
CALL SGEHRD( N, 1, N, H, N, WORK, WORK( N+1 ),
$ LWORK-N, IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 1 ), IINFO, N,
$ ITYPE, 0, IOLDSD
INFO = ABS( IINFO )
GO TO 610
END IF
LDH = N
END IF
END IF
*
* Time SHSEQR with JOB='E' for each 4-tuple
* NNB(j), NSHFTS(j), MAXBS(j), LDAS(j)
*
IF( TIMSUB( 2 ) ) THEN
DO 140 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = 1
NSHIFT = NSHFTS( IPAR )
MAXB = MAXBS( IPAR )
CALL XLAENV( 4, NSHIFT )
CALL XLAENV( 8, MAXB )
*
* Time SHSEQR with JOB='E'
*
IC = 0
OPS = ZERO
S1 = SECOND( )
120 CONTINUE
CALL SLACPY( 'Full', N, N, H, LDH, A, LDA )
*
CALL SHSEQR( 'E', 'N', N, 1, N, A, LDA, W, W( LDA+1 ),
$ Z, LDA, WORK, LWORK, IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 2 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 610
END IF
*
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 120
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 130 J = 1, IC
CALL SLACPY( 'Full', N, N, H, LDH, Z, LDA )
130 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 2 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 2 ) = OPS / REAL( IC )
140 CONTINUE
LDT = 0
LDW = LDA
ELSE
IF( RUNQRE ) THEN
CALL SLACPY( 'Full', N, N, H, LDH, A, N )
*
CALL SHSEQR( 'E', 'N', N, 1, N, A, N, W, W( N+1 ),
$ Z, N, WORK, LWORK, IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 2 ), IINFO, N,
$ ITYPE, 0, IOLDSD
INFO = ABS( IINFO )
GO TO 610
END IF
LDT = 0
LDW = N
END IF
END IF
*
* Time SHSEQR with JOB='S' for each 4-tuple
* NNB(j), NSHFTS(j), MAXBS(j), LDAS(j)
*
IF( TIMSUB( 3 ) ) THEN
DO 170 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NSHIFT = NSHFTS( IPAR )
MAXB = MAXBS( IPAR )
NB = 1
CALL XLAENV( 4, NSHIFT )
CALL XLAENV( 8, MAXB )
*
* Time SHSEQR with JOB='S'
*
IC = 0
OPS = ZERO
S1 = SECOND( )
150 CONTINUE
CALL SLACPY( 'Full', N, N, H, LDH, A, LDA )
*
CALL SHSEQR( 'S', 'N', N, 1, N, A, LDA, W, W( LDA+1 ),
$ Z, LDA, WORK, LWORK, IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 3 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 610
END IF
*
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 150
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 160 J = 1, IC
CALL SLACPY( 'Full', N, N, H, LDH, Z, LDA )
160 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 3 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 3 ) = OPS / REAL( IC )
170 CONTINUE
LDT = LDA
LDW = LDA
ELSE
IF( RUNQRS ) THEN
CALL SLACPY( 'Full', N, N, H, LDH, A, N )
*
CALL SHSEQR( 'S', 'N', N, 1, N, A, N, W, W( N+1 ),
$ Z, N, WORK, LWORK, IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 3 ), IINFO, N,
$ ITYPE, 0, IOLDSD
INFO = ABS( IINFO )
GO TO 610
END IF
LDT = N
LDW = N
END IF
END IF
*
* Time SHSEQR with JOB='I' for each 4-tuple
* NNB(j), NSHFTS(j), MAXBS(j), LDAS(j)
*
IF( TIMSUB( 4 ) ) THEN
DO 200 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NSHIFT = NSHFTS( IPAR )
MAXB = MAXBS( IPAR )
NB = 1
CALL XLAENV( 4, NSHIFT )
CALL XLAENV( 8, MAXB )
*
* Time SHSEQR with JOB='I'
*
IC = 0
OPS = ZERO
S1 = SECOND( )
180 CONTINUE
CALL SLACPY( 'Full', N, N, H, LDH, A, LDA )
*
CALL SHSEQR( 'S', 'I', N, 1, N, A, LDA, W, W( LDA+1 ),
$ Z, LDA, WORK, LWORK, IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 4 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 610
END IF
*
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 180
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 190 J = 1, IC
CALL SLACPY( 'Full', N, N, H, LDH, Z, LDA )
190 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 4 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 4 ) = OPS / REAL( IC )
200 CONTINUE
LDT = LDA
LDW = LDA
END IF
*
* Time STREVC and SHSEIN with various values of LDA
*
* Select All Eigenvectors
*
DO 210 J = 1, N
LLWORK( J ) = .TRUE.
210 CONTINUE
*
DO 370 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 220 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
220 CONTINUE
*
* Time STREVC
*
IF( ( TIMSUB( 5 ) .OR. TIMSUB( 6 ) ) .AND. LASTL.EQ.0 )
$ THEN
*
* Copy T (which is in A) if necessary to get right LDA.
*
IF( LDA.GT.LDT ) THEN
DO 240 JC = N, 1, -1
DO 230 JR = N, 1, -1
A( JR+( JC-1 )*LDA ) = A( JR+( JC-1 )*LDT )
230 CONTINUE
240 CONTINUE
ELSE IF( LDA.LT.LDT ) THEN
DO 260 JC = 1, N
DO 250 JR = 1, N
A( JR+( JC-1 )*LDA ) = A( JR+( JC-1 )*LDT )
250 CONTINUE
260 CONTINUE
END IF
LDT = LDA
*
* Time STREVC for Left Eigenvectors
*
IF( TIMSUB( 5 ) ) THEN
IC = 0
OPS = ZERO
S1 = SECOND( )
270 CONTINUE
*
CALL STREVC( 'L', 'A', LLWORK, N, A, LDA, Z, LDA,
$ Z, LDA, N, ITEMP, WORK, IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 5 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 610
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 270
*
TIMES( IPAR, ITYPE, IN, 5 ) = TIME / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 5 ) = OPS / REAL( IC )
END IF
*
* Time STREVC for Right Eigenvectors
*
IF( TIMSUB( 6 ) ) THEN
IC = 0
OPS = ZERO
S1 = SECOND( )
280 CONTINUE
CALL STREVC( 'R', 'A', LLWORK, N, A, LDA, Z, LDA,
$ Z, LDA, N, ITEMP, WORK, IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 6 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 610
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 280
*
TIMES( IPAR, ITYPE, IN, 6 ) = TIME / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 6 ) = OPS / REAL( IC )
END IF
ELSE
IF( TIMSUB( 5 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 5 ) = OPCNTS( LASTL,
$ ITYPE, IN, 5 )
TIMES( IPAR, ITYPE, IN, 5 ) = TIMES( LASTL, ITYPE,
$ IN, 5 )
END IF
IF( TIMSUB( 6 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 6 ) = OPCNTS( LASTL,
$ ITYPE, IN, 6 )
TIMES( IPAR, ITYPE, IN, 6 ) = TIMES( LASTL, ITYPE,
$ IN, 6 )
END IF
END IF
*
* Time SHSEIN
*
IF( ( TIMSUB( 7 ) .OR. TIMSUB( 8 ) ) .AND. LASTL.EQ.0 )
$ THEN
*
* Copy H if necessary to get right LDA.
*
IF( LDA.GT.LDH ) THEN
DO 300 JC = N, 1, -1
DO 290 JR = N, 1, -1
H( JR+( JC-1 )*LDA ) = H( JR+( JC-1 )*LDH )
290 CONTINUE
W( JC+LDA ) = W( JC+LDH )
300 CONTINUE
ELSE IF( LDA.LT.LDH ) THEN
DO 320 JC = 1, N
DO 310 JR = 1, N
H( JR+( JC-1 )*LDA ) = H( JR+( JC-1 )*LDH )
310 CONTINUE
W( JC+LDA ) = W( JC+LDH )
320 CONTINUE
END IF
LDH = LDA
*
* Copy W if necessary to get right LDA.
*
IF( LDA.GT.LDW ) THEN
DO 330 J = N, 1, -1
W( J+LDA ) = W( J+LDW )
330 CONTINUE
ELSE IF( LDA.LT.LDW ) THEN
DO 340 J = 1, N
W( J+LDA ) = W( J+LDW )
340 CONTINUE
END IF
LDW = LDA
*
* Time SHSEIN for Left Eigenvectors
*
IF( TIMSUB( 7 ) ) THEN
IC = 0
OPS = ZERO
S1 = SECOND( )
350 CONTINUE
*
CALL SHSEIN( 'L', 'Q', 'N', LLWORK, N, H, LDA, W,
$ W( LDA+1 ), Z, LDA, Z, LDA, N, ITEMP,
$ WORK, IWORK, IWORK( N+1 ), IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 7 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 610
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 350
*
TIMES( IPAR, ITYPE, IN, 7 ) = TIME / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 7 ) = OPS / REAL( IC )
END IF
*
* Time SHSEIN for Right Eigenvectors
*
IF( TIMSUB( 8 ) ) THEN
IC = 0
OPS = ZERO
S1 = SECOND( )
360 CONTINUE
*
CALL SHSEIN( 'R', 'Q', 'N', LLWORK, N, H, LDA, W,
$ W( LDA+1 ), Z, LDA, Z, LDA, N, ITEMP,
$ WORK, IWORK, IWORK( N+1 ), IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 8 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 610
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 360
*
TIMES( IPAR, ITYPE, IN, 8 ) = TIME / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 8 ) = OPS / REAL( IC )
END IF
ELSE
IF( TIMSUB( 7 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 7 ) = OPCNTS( LASTL,
$ ITYPE, IN, 7 )
TIMES( IPAR, ITYPE, IN, 7 ) = TIMES( LASTL, ITYPE,
$ IN, 7 )
END IF
IF( TIMSUB( 8 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 8 ) = OPCNTS( LASTL,
$ ITYPE, IN, 8 )
TIMES( IPAR, ITYPE, IN, 8 ) = TIMES( LASTL, ITYPE,
$ IN, 8 )
END IF
END IF
370 CONTINUE
*
*-----------------------------------------------------------------------
*
* Time the EISPACK Routines
*
* Restore random number seed
*
DO 380 J = 1, 4
ISEED( J ) = IOLDSD( J )
380 CONTINUE
*
* Re-generate A
*
IF( ITYPE.LE.MAXTYP ) THEN
IMODE = KMODE( ITYPE )
IF( ICONDS.EQ.1 ) THEN
CONDS = ONE
ELSE
CONDS = RTULPI
END IF
CALL SLATME( N, 'S', ISEED, WORK, IMODE, ULPINV, ONE,
$ ADUMMA, 'T', 'T', 'T', WORK( N+1 ), 4,
$ CONDS, N, N, ONE, A, N, WORK( 2*N+1 ),
$ IINFO )
END IF
*
* Time ORTHES for each LDAS(j)
*
IF( TIMSUB( 9 ) ) THEN
DO 420 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has come up before, just use
* the value previously computed.
LASTL = 0
DO 390 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
390 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time ORTHES
*
IC = 0
OPS = ZERO
S1 = SECOND( )
*
400 CONTINUE
CALL SLACPY( 'Full', N, N, A, N, H, LDA )
*
CALL ORTHES( LDA, N, 1, N, H, WORK )
*
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 400
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 410 J = 1, IC
CALL SLACPY( 'Full', N, N, A, N, Z, LDA )
410 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
* OPS1 = ( 20*N**3 - 3*N**2 - 23*N ) / 6 - 17
*
TIMES( IPAR, ITYPE, IN, 9 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 9 ) = OPS / REAL( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 9 ) = OPCNTS( LASTL,
$ ITYPE, IN, 9 )
TIMES( IPAR, ITYPE, IN, 9 ) = TIMES( LASTL, ITYPE,
$ IN, 9 )
END IF
LDH = LDA
420 CONTINUE
ELSE
IF( RUNORT ) THEN
CALL SLACPY( 'Full', N, N, A, N, H, N )
*
CALL ORTHES( N, N, 1, N, H, WORK )
*
LDH = N
END IF
END IF
*
* Time HQR for each LDAS(j)
*
IF( TIMSUB( 10 ) ) THEN
DO 460 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 430 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
430 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time HQR
*
IC = 0
OPS = ZERO
S1 = SECOND( )
440 CONTINUE
CALL SLACPY( 'Full', N, N, H, LDH, A, LDA )
*
CALL HQR( LDA, N, 1, N, A, W, W( LDA+1 ), IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 10 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 610
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 440
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 450 J = 1, IC
CALL SLACPY( 'Full', N, N, H, LDH, Z, LDA )
450 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 10 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 10 ) = OPS / REAL( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 10 ) = OPCNTS( LASTL,
$ ITYPE, IN, 10 )
TIMES( IPAR, ITYPE, IN, 10 ) = TIMES( LASTL, ITYPE,
$ IN, 10 )
END IF
LDW = LDA
460 CONTINUE
ELSE
IF( RUNHQR ) THEN
CALL SLACPY( 'Full', N, N, A, N, H, N )
*
CALL HQR( N, N, 1, N, A, W, W( N+1 ), IINFO )
*
LDW = N
END IF
END IF
*
* Time HQR2 for each LDAS(j)
*
IF( TIMSUB( 11 ) ) THEN
DO 500 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 470 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
470 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time HQR2
*
IC = 0
OPS = ZERO
S1 = SECOND( )
480 CONTINUE
CALL SLACPY( 'Full', N, N, H, LDH, A, LDA )
CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDA )
*
CALL HQR2( LDA, N, 1, N, A, W, W( LDA+1 ), Z,
$ IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 11 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 610
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 480
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 490 J = 1, IC
CALL SLACPY( 'Full', N, N, H, LDH, Z, LDA )
490 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 11 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 11 ) = OPS / REAL( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 11 ) = OPCNTS( LASTL,
$ ITYPE, IN, 11 )
TIMES( IPAR, ITYPE, IN, 11 ) = TIMES( LASTL, ITYPE,
$ IN, 11 )
END IF
LDW = LDA
500 CONTINUE
END IF
*
* Time INVIT for each LDAS(j)
*
* Select All Eigenvectors
*
DO 510 J = 1, N
LLWORK( J ) = .TRUE.
510 CONTINUE
*
IF( TIMSUB( 12 ) ) THEN
DO 600 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 520 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
520 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Copy H if necessary to get right LDA.
*
IF( LDA.GT.LDH ) THEN
DO 540 JC = N, 1, -1
DO 530 JR = N, 1, -1
H( JR+( JC-1 )*LDA ) = H( JR+( JC-1 )*
$ LDH )
530 CONTINUE
540 CONTINUE
ELSE IF( LDA.LT.LDH ) THEN
DO 560 JC = 1, N
DO 550 JR = 1, N
H( JR+( JC-1 )*LDA ) = H( JR+( JC-1 )*
$ LDH )
550 CONTINUE
560 CONTINUE
END IF
LDH = LDA
*
* Copy W if necessary to get right LDA.
*
IF( LDA.GT.LDW ) THEN
DO 570 J = N, 1, -1
W( J+LDA ) = W( J+LDW )
570 CONTINUE
ELSE IF( LDA.LT.LDW ) THEN
DO 580 J = 1, N
W( J+LDA ) = W( J+LDW )
580 CONTINUE
END IF
LDW = LDA
*
* Time INVIT for right eigenvectors.
*
IC = 0
OPS = ZERO
S1 = SECOND( )
590 CONTINUE
*
CALL INVIT( LDA, N, H, W, W( LDA+1 ), LLWORK, N,
$ ITEMP, Z, IINFO, WORK( 2*N+1 ), WORK,
$ WORK( N+1 ) )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 12 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 610
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 590
*
* TIME = TIME / REAL( IC )
* OPS1 = OPS / REAL( IC )
* OPCNTS( IPAR, ITYPE, IN, 12 ) = OPS1
* TIMES( IPAR, ITYPE, IN, 12 ) = SMFLOP( OPS1, TIME,
* $ IINFO )
*
TIMES( IPAR, ITYPE, IN, 12 ) = TIME / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 12 ) = OPS / REAL( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 12 ) = OPCNTS( LASTL,
$ ITYPE, IN, 12 )
TIMES( IPAR, ITYPE, IN, 12 ) = TIMES( LASTL, ITYPE,
$ IN, 12 )
END IF
600 CONTINUE
END IF
*
610 CONTINUE
620 CONTINUE
*
*-----------------------------------------------------------------------
*
* Print a table of results for each timed routine.
*
ISUB = 1
IF( TIMSUB( ISUB ) ) THEN
CALL SPRTBE( SUBNAM( ISUB ), MTYPES, DOTYPE, NSIZES, NN,
$ INPARM( ISUB ), PNAMES, NPARMS, LDAS, NNB,
$ NSHFTS, MAXBS, OPCNTS( 1, 1, 1, ISUB ), LDO1,
$ LDO2, TIMES( 1, 1, 1, ISUB ), LDT1, LDT2, WORK,
$ LLWORK, NOUT )
END IF
*
DO 625 IN = 1, NPARMS
NNB( IN ) = 1
625 CONTINUE
*
DO 630 ISUB = 2, NSUBS
IF( TIMSUB( ISUB ) ) THEN
CALL SPRTBE( SUBNAM( ISUB ), MTYPES, DOTYPE, NSIZES, NN,
$ INPARM( ISUB ), PNAMES, NPARMS, LDAS, NNB,
$ NSHFTS, MAXBS, OPCNTS( 1, 1, 1, ISUB ), LDO1,
$ LDO2, TIMES( 1, 1, 1, ISUB ), LDT1, LDT2, WORK,
$ LLWORK, NOUT )
END IF
630 CONTINUE
*
RETURN
*
* End of STIM21
*
9997 FORMAT( ' STIM21: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', ITYPE=', I6, ', IPAR=', I6, ', ISEED=(',
$ 3( I5, ',' ), I5, ')' )
*
END
SUBROUTINE STIM22( LINE, NSIZES, NN, NTYPES, DOTYPE, NPARMS, NNB,
$ LDAS, TIMMIN, NOUT, ISEED, A, D, E, E2, Z, Z1,
$ WORK, LWORK, LLWORK, IWORK, TIMES, LDT1, LDT2,
$ LDT3, OPCNTS, LDO1, LDO2, LDO3, INFO )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 20, 2000
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER INFO, LDO1, LDO2, LDO3, LDT1, LDT2, LDT3,
$ LWORK, NOUT, NPARMS, NSIZES, NTYPES
REAL TIMMIN
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * ), LLWORK( * )
INTEGER ISEED( * ), IWORK( * ), LDAS( * ), NN( * ),
$ NNB( * )
REAL A( * ), D( * ), E( * ), E2( * ),
$ OPCNTS( LDO1, LDO2, LDO3, * ),
$ TIMES( LDT1, LDT2, LDT3, * ), WORK( * ),
$ Z( * ), Z1( * )
* ..
*
* Purpose
* =======
*
* STIM22 times the LAPACK routines for the real symmetric
* eigenvalue problem.
*
* For each N value in NN(1:NSIZES) and .TRUE. value in
* DOTYPE(1:NTYPES), a matrix will be generated and used to test the
* selected routines. Thus, NSIZES*(number of .TRUE. values in
* DOTYPE) matrices will be generated.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* On entry, LINE contains the input line which requested
* this routine. This line may contain a subroutine name,
* such as SSYTRD, indicating that only routine SSYTRD will
* be timed, or it may contain a generic name, such as SST.
* In this case, the rest of the line is scanned for the
* first 23 non-blank characters, corresponding to the eight
* combinations of subroutine and options:
* LAPACK:
* 1: SSYTRD
* 2: SORGTR
* 3: SORMTR
* 4: SSTEQR(VECT='N')
* 5: SSTEQR(VECT='V')
* 6: SSTERF
* 7: SPTEQR(VECT='N')
* 8: SPTEQR(VECT='V')
* 9: SSTEBZ(RANGE='I')
* 10: SSTEBZ(RANGE='V')
* 11: SSTEIN
* 12: SSTEDC(COMPQ='N')
* 13: SSTEDC(COMPQ='I')
* 14: SSTEDC(COMPQ='V')
* 15: SSTEGR(COMPQ='N')
* 16: SSTEGR(COMPQ='V')
* EISPACK:
* 17: TRED1 (compare with SSYTRD)
* 18: IMTQL1 (compare w/ SSTEQR -- VECT='N')
* 19: IMTQL2 (compare w/ SSTEQR -- VECT='V')
* 20: TQLRAT (compare with SSTERF)
* 21: TRIDIB (compare with SSTEBZ -- RANGE='I')
* 22: BISECT (compare with SSTEBZ -- RANGE='V')
* 23: TINVIT (compare with SSTEIN)
* If a character is 'T' or 't', the corresponding routine in
* this path is timed. If the entire line is blank, all the
* routines in the path are timed.
*
* NSIZES (input) INTEGER
* The number of values of N contained in the vector NN.
*
* NN (input) INTEGER array, dimension( NSIZES )
* The values of the matrix size N to be tested. For each
* N value in the array NN, and each .TRUE. value in DOTYPE,
* a matrix A will be generated and used to test the routines.
*
* NTYPES (input) INTEGER
* The number of types in DOTYPE. Only the first MAXTYP
* elements will be examined. Exception: if NSIZES=1 and
* NTYPES=MAXTYP+1, and DOTYPE=MAXTYP*f,t, then the input
* value of A will be used.
*
* DOTYPE (input) LOGICAL
* If DOTYPE(j) is .TRUE., then a matrix of type j will be
* generated. The matrix A has the form X**(-1) D X, where
* X is orthogonal and D is diagonal with:
* (j=1) evenly spaced entries 1, ..., ULP with random signs.
* (j=2) geometrically spaced entries 1, ..., ULP with random
* signs.
* (j=3) "clustered" entries 1, ULP,..., ULP with random
* signs.
* (j=4) entries randomly chosen from ( ULP, 1 ).
*
* NPARMS (input) INTEGER
* The number of values in each of the arrays NNB and LDAS.
* For each matrix A generated according to NN and DOTYPE,
* tests will be run with (NB,LDA)=
* (NNB(1),LDAS(1)),...,(NNB(NPARMS), LDAS(NPARMS))
*
* NNB (input) INTEGER array, dimension( NPARMS )
* The values of the blocksize ("NB") to be tested.
*
* LDAS (input) INTEGER array, dimension( NPARMS )
* The values of LDA, the leading dimension of all matrices,
* to be tested.
*
* TIMMIN (input) REAL
* The minimum time a subroutine will be timed.
*
* NOUT (input) INTEGER
* If NOUT > 0 then NOUT specifies the unit number
* on which the output will be printed. If NOUT <= 0, no
* output is printed.
*
* ISEED (input/output) INTEGER array, dimension( 4 )
* The random seed used by the random number generator, used
* by the test matrix generator. It is used and updated on
* each call to STIM22
*
* A (workspace) REAL array,
* dimension( max(NN)*max(LDAS) )
* The original matrix to be tested.
*
* D (workspace) REAL array,
* dimension( max(NN) )
* The diagonal of the tridiagonal generated by SSYTRD/TRED1.
*
* E (workspace) REAL array,
* dimension( max(NN) )
* The off-diagonal of the tridiagonal generated by
* SSYTRD/TRED1.
*
* E2 (workspace) REAL array,
* dimension( max(NN) )
* The square of the off-diagonal of the tridiagonal generated
* by TRED1. (Used by TQLRAT.)
*
* Z (workspace) REAL array,
* dimension( max(NN)*max(LDAS) )
* Various output arrays.
*
* WORK (workspace) REAL array, dimension( LWORK )
*
* LWORK (input) INTEGER
* Number of elements in WORK. It must be at least
* (a) max( (NNB + 2 )*LDAS )
* (b) max( 5*LDAS )
* (c) NSIZES*NTYPES*NPARMS
* (d) 2*LDAS + 1 + 3*maxNN + 2*maxNN*log2(maxNN) + 3*maxNN**2
* where maxNN = maximum matrix dimension in NN
* log2(x) = smallest integer power of 2 .ge. x
*
* LLWORK (workspace) LOGICAL array of dimension( NPARMS ),
*
* IWORK (workspace) INTEGER array of dimension
* 6 + 6*maxNN + 5*maxNN*log2(maxNN)
*
* TIMES (output) REAL array,
* dimension (LDT1,LDT2,LDT3,NSUBS)
* TIMES(i,j,k,l) will be set to the run time (in seconds) for
* subroutine l, with N=NN(k), matrix type j, and LDA=LDAS(i),
* NBLOCK=NNB(i).
*
* LDT1 (input) INTEGER
* The first dimension of TIMES. LDT1 >= min( 1, NPARMS ).
*
* LDT2 (input) INTEGER
* The second dimension of TIMES. LDT2 >= min( 1, NTYPES ).
*
* LDT3 (input) INTEGER
* The third dimension of TIMES. LDT3 >= min( 1, NSIZES ).
*
* OPCNTS (output) REAL array,
* dimension (LDO1,LDO2,LDO3,NSUBS)
* OPCNTS(i,j,k,l) will be set to the number of floating-point
* operations executed by subroutine l, with N=NN(k), matrix
* type j, and LDA=LDAS(i), NBLOCK=NNB(i).
*
* LDO1 (input) INTEGER
* The first dimension of OPCNTS. LDO1 >= min( 1, NPARMS ).
*
* LDO2 (input) INTEGER
* The second dimension of OPCNTS. LDO2 >= min( 1, NTYPES ).
*
* LDO3 (input) INTEGER
* The third dimension of OPCNTS. LDO3 >= min( 1, NSIZES ).
*
* INFO (output) INTEGER
* Error flag. It will be set to zero if no error occurred.
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXTYP, NSUBS
PARAMETER ( MAXTYP = 4, NSUBS = 23 )
REAL ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 )
* ..
* .. Local Scalars ..
LOGICAL RUNTR1, RUNTRD
CHARACTER UPLO
INTEGER I, IC, IINFO, IL, ILWORK, IMODE, IN, INFSOK,
$ IPAR, ISUB, ITYPE, IU, J, J1, J2, J3, J4,
$ LASTL, LDA, LGN, LIWEDC, LIWEVR, LWEDC, LWEVR,
$ M, M11, MM, MMM, MTYPES, N, NANSOK, NB, NSPLIT
REAL ABSTOL, EPS1, RLB, RUB, S1, S2, TIME, ULP,
$ ULPINV, UNTIME, VL, VU
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER*4 PNAMES( 4 )
CHARACTER*9 SUBNAM( NSUBS )
INTEGER IDUMMA( 1 ), INPARM( NSUBS ), IOLDSD( 4 ),
$ KMODE( MAXTYP )
* ..
* .. External Functions ..
INTEGER ILAENV
REAL SECOND, SLAMCH, SOPLA, SOPLA2
EXTERNAL ILAENV, SECOND, SLAMCH, SOPLA, SOPLA2
* ..
* .. External Subroutines ..
EXTERNAL ATIMIN, BISECT, IMTQL1, IMTQL2, SCOPY, SLACPY,
$ SLASET, SLATMS, SORGTR, SORMTR, SPRTBE, SPTEQR,
$ SSTEBZ, SSTEDC, SSTEGR, SSTEIN, SSTEQR, SSTERF,
$ SSYTRD, TINVIT, TQLRAT, TRED1, TRIDIB, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX, MIN, REAL
* ..
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
* .. Data statements ..
DATA SUBNAM / 'SSYTRD', 'SORGTR', 'SORMTR',
$ 'SSTEQR(N)', 'SSTEQR(V)', 'SSTERF',
$ 'SPTEQR(N)', 'SPTEQR(V)', 'SSTEBZ(I)',
$ 'SSTEBZ(V)', 'SSTEIN', 'SSTEDC(N)',
$ 'SSTEDC(I)', 'SSTEDC(V)', 'SSTEGR(N)',
$ 'SSTEGR(V)', 'TRED1', 'IMTQL1', 'IMTQL2',
$ 'TQLRAT', 'TRIDIB', 'BISECT', 'TINVIT' /
DATA INPARM / 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
$ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 /
DATA PNAMES / 'LDA', 'NB', 'bad1', 'bad2' /
DATA KMODE / 4, 3, 1, 5 /
* ..
* .. Executable Statements ..
*
*
* Extract the timing request from the input line.
*
CALL ATIMIN( 'SST', LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
*
* Disable timing of SSTEGR if we're non-IEEE-754 compliant.
*
NANSOK = ILAENV( 10, 'SSTEGR', ' ', 0, 0, 0, 0 )
INFSOK = ILAENV( 11, 'SSTEGR', ' ', 0, 0, 0, 0 )
IF( NANSOK.NE.1 .OR. INFSOK.NE.1 ) THEN
TIMSUB(15) = .FALSE.
TIMSUB(16) = .FALSE.
END IF
*
IF( INFO.NE.0 )
$ RETURN
*
* Check that N <= LDA for the input values.
*
DO 20 J2 = 1, NSIZES
DO 10 J1 = 1, NPARMS
IF( NN( J2 ).GT.LDAS( J1 ) ) THEN
INFO = -8
WRITE( NOUT, FMT = 9999 )LINE( 1: 6 )
9999 FORMAT( 1X, A, ' timing run not attempted -- N > LDA',
$ / )
RETURN
END IF
10 CONTINUE
20 CONTINUE
*
* Check LWORK
*
ILWORK = NSIZES*NPARMS*NTYPES
DO 30 J1 = 1, NPARMS
ILWORK = MAX( ILWORK, 5*LDAS( J1 ),
$ ( NNB( J1 )+2 )*LDAS( J1 ) )
30 CONTINUE
IF( ILWORK.GT.LWORK ) THEN
INFO = -18
WRITE( NOUT, FMT = 9998 )LINE( 1: 6 )
9998 FORMAT( 1X, A, ' timing run not attempted -- LWORK too small.',
$ / )
RETURN
END IF
*
* Check to see whether SSYTRD must be run.
*
* RUNTRD -- if SSYTRD must be run.
*
RUNTRD = .FALSE.
IF( TIMSUB( 4 ) .OR. TIMSUB( 5 ) .OR. TIMSUB( 6 ) .OR.
$ TIMSUB( 7 ) .OR. TIMSUB( 8 ) .OR. TIMSUB( 9 ) .OR.
$ TIMSUB( 10 ) .OR. TIMSUB( 11 ) .OR. TIMSUB( 12 ) .OR.
$ TIMSUB( 13 ) .OR. TIMSUB( 14 ) .OR. TIMSUB( 15 ) .OR.
$ TIMSUB( 16 ) )
$ RUNTRD = .TRUE.
*
* Check to see whether TRED1 must be run.
*
* RUNTR1 -- if TRED1 must be run.
*
RUNTR1 = .FALSE.
IF( TIMSUB( 17 ) .OR. TIMSUB( 18 ) .OR. TIMSUB( 19 ) .OR.
$ TIMSUB( 20 ) .OR. TIMSUB( 21 ) .OR. TIMSUB( 22 ) .OR.
$ TIMSUB( 23 ) )
$ RUNTR1 = .TRUE.
*
* Various Constants
*
ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
ULPINV = ONE / ULP
CALL XLAENV( 9, 25 )
*
* Zero out OPCNTS, TIMES
*
DO 70 J4 = 1, NSUBS
DO 60 J3 = 1, NSIZES
DO 50 J2 = 1, NTYPES
DO 40 J1 = 1, NPARMS
OPCNTS( J1, J2, J3, J4 ) = ZERO
TIMES( J1, J2, J3, J4 ) = ZERO
40 CONTINUE
50 CONTINUE
60 CONTINUE
70 CONTINUE
*
* Do for each value of N:
*
DO 940 IN = 1, NSIZES
*
N = NN( IN )
IF( N.GT.0 ) THEN
LGN = INT( LOG( REAL( N ) ) / LOG( TWO ) )
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
LWEDC = 1 + 4*N + 2*N*LGN + 3*N**2
LIWEDC = 6 + 6*N + 5*N*LGN
LWEVR = 18*N
LIWEVR = 10*N
ELSE
LWEDC = 8
LIWEDC = 12
LWEVR = 1
LIWEVR = 1
END IF
*
* Do for each .TRUE. value in DOTYPE:
*
MTYPES = MIN( MAXTYP, NTYPES )
IF( NTYPES.EQ.MAXTYP+1 .AND. NSIZES.EQ.1 )
$ MTYPES = NTYPES
DO 930 ITYPE = 1, MTYPES
IF( .NOT.DOTYPE( ITYPE ) )
$ GO TO 930
*
* Save random number seed for error messages
*
DO 80 J = 1, 4
IOLDSD( J ) = ISEED( J )
80 CONTINUE
*
*-----------------------------------------------------------------------
*
* Time the LAPACK Routines
*
* Generate A
*
UPLO = 'L'
IF( ITYPE.LE.MAXTYP ) THEN
IMODE = KMODE( ITYPE )
CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, ULPINV,
$ ONE, N, N, UPLO, A, N, WORK( N+1 ), IINFO )
END IF
*
* Time SSYTRD for each pair NNB(j), LDAS(j)
*
IF( TIMSUB( 1 ) ) THEN
DO 110 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
CALL XLAENV( 1, NB )
CALL XLAENV( 2, 2 )
CALL XLAENV( 3, NB )
*
* Time SSYTRD
*
IC = 0
OPS = ZERO
S1 = SECOND( )
90 CONTINUE
CALL SLACPY( UPLO, N, N, A, N, Z, LDA )
CALL SSYTRD( UPLO, N, Z, LDA, D, E, WORK, WORK( N+1 ),
$ LWORK-N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 1 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 590
END IF
*
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 90
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 100 J = 1, IC
CALL SLACPY( UPLO, N, N, A, N, Z, LDA )
100 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 1 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 1 ) = SOPLA( 'SSYTRD', N, 0,
$ 0, 0, NB )
110 CONTINUE
ELSE
IF( RUNTRD ) THEN
CALL SLACPY( UPLO, N, N, A, N, Z, N )
CALL SSYTRD( UPLO, N, Z, N, D, E, WORK, WORK( N+1 ),
$ LWORK-N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 1 ), IINFO, N,
$ ITYPE, 0, IOLDSD
INFO = ABS( IINFO )
GO TO 590
END IF
END IF
END IF
*
* Time SORGTR for each pair NNB(j), LDAS(j)
*
IF( TIMSUB( 2 ) ) THEN
DO 140 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
CALL XLAENV( 1, NB )
CALL XLAENV( 2, 2 )
CALL XLAENV( 3, NB )
*
* Time SORGTR
*
CALL SLACPY( UPLO, N, N, A, N, Z, LDA )
CALL SSYTRD( UPLO, N, Z, LDA, D, E, WORK, WORK( N+1 ),
$ LWORK-N, IINFO )
IC = 0
OPS = ZERO
S1 = SECOND( )
120 CONTINUE
CALL SLACPY( 'F', N, N, Z, LDA, Z1, LDA )
CALL SORGTR( UPLO, N, Z1, LDA, WORK, WORK( N+1 ),
$ LWORK-N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 2 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 590
END IF
*
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 120
*
* Subtract the time used in SLACPY
*
S1 = SECOND( )
DO 130 J = 1, IC
CALL SLACPY( 'F', N, N, Z, LDA, Z1, LDA )
130 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 2 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 2 ) = SOPLA2( 'SORGTR', UPLO,
$ N, N, N, 0, NB )
140 CONTINUE
END IF
*
* Time SORMTR for each pair NNB(j), LDAS(j)
*
IF( TIMSUB( 3 ) ) THEN
DO 170 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
CALL XLAENV( 1, NB )
CALL XLAENV( 2, 2 )
CALL XLAENV( 3, NB )
*
* Time SORMTR
*
CALL SLACPY( UPLO, N, N, A, N, Z, LDA )
CALL SSYTRD( UPLO, N, Z, LDA, D, E, WORK, WORK( N+1 ),
$ LWORK-N, IINFO )
IC = 0
OPS = ZERO
S1 = SECOND( )
150 CONTINUE
CALL SCOPY( N, D, 1, WORK( LDA+1 ), 1 )
CALL SCOPY( N-1, E, 1, WORK( 2*LDA+1 ), 1 )
CALL SSTEDC( 'N', N, WORK( LDA+1 ), WORK( 2*LDA+1 ),
$ Z1, LDA, WORK( 3*LDA+1 ), LWEDC, IWORK,
$ LIWEDC, IINFO )
CALL SORMTR( 'L', UPLO, 'N', N, N, Z, LDA, WORK, Z1,
$ LDA, WORK( N+1 ), LWORK-N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 3 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 590
END IF
*
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 150
*
* Subtract the time used in SCOPY and SSTEDC
*
S1 = SECOND( )
DO 160 J = 1, IC
CALL SCOPY( N, D, 1, WORK( LDA+1 ), 1 )
CALL SCOPY( N-1, E, 1, WORK( 2*LDA+1 ), 1 )
CALL SSTEDC( 'N', N, WORK( LDA+1 ),
$ WORK( 2*LDA+1 ), Z1, LDA,
$ WORK( 3*LDA+1 ), LWEDC, IWORK, LIWEDC,
$ IINFO )
160 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 3 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 3 ) = SOPLA2( 'SORMTR',
$ UPLO//UPLO, N, N, N, 0, NB )
170 CONTINUE
END IF
*
* Time SSTEQR, SSTERF, SPTEQR, SSTEBZ, SSTEIN, SSTEDC, SSTERV
* for each distinct LDA=LDAS(j)
*
IF( TIMSUB( 4 ) .OR. TIMSUB( 5 ) .OR. TIMSUB( 6 ) .OR.
$ TIMSUB( 7 ) .OR. TIMSUB( 8 ) .OR. TIMSUB( 9 ) .OR.
$ TIMSUB( 10 ) .OR. TIMSUB( 11 ) .OR. TIMSUB( 12 ) .OR.
$ TIMSUB( 13 ) .OR. TIMSUB( 14 ) .OR. TIMSUB( 15 ) .OR.
$ TIMSUB( 16 ) ) THEN
DO 580 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 180 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
180 CONTINUE
IF( LASTL.EQ.0 ) THEN
*
* Time SSTEQR with VECT='N'
*
IF( TIMSUB( 4 ) ) THEN
IC = 0
OPS = ZERO
S1 = SECOND( )
190 CONTINUE
CALL SCOPY( N, D, 1, WORK, 1 )
CALL SCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
CALL SSTEQR( 'N', N, WORK, WORK( LDA+1 ), Z,
$ LDA, WORK( 2*LDA+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 4 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 190
*
* Subtract the time used in SCOPY.
*
S1 = SECOND( )
DO 200 J = 1, IC
CALL SCOPY( N, D, 1, WORK, 1 )
CALL SCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
200 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 4 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 4 ) = OPS / REAL( IC )
END IF
*
* Time SSTEQR with VECT='V'
*
210 CONTINUE
IF( TIMSUB( 5 ) ) THEN
IC = 0
OPS = ZERO
S1 = SECOND( )
220 CONTINUE
CALL SCOPY( N, D, 1, WORK, 1 )
CALL SCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
CALL SLASET( 'Full', LDA, N, ONE, TWO, Z, LDA )
CALL SSTEQR( 'V', N, WORK, WORK( LDA+1 ), Z,
$ LDA, WORK( 2*LDA+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 5 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 240
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 220
*
* Subtract the time used in SCOPY.
*
S1 = SECOND( )
DO 230 J = 1, IC
CALL SLASET( 'Full', LDA, N, ONE, TWO, Z,
$ LDA )
CALL SCOPY( N, D, 1, WORK, 1 )
CALL SCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
230 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 5 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 5 ) = OPS / REAL( IC )
END IF
*
* Time SSTERF
*
240 CONTINUE
IF( TIMSUB( 6 ) ) THEN
IC = 0
OPS = ZERO
S1 = SECOND( )
250 CONTINUE
CALL SCOPY( N, D, 1, WORK, 1 )
CALL SCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
CALL SSTERF( N, WORK, WORK( LDA+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 6 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 270
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 250
*
* Subtract the time used in SCOPY.
*
S1 = SECOND( )
DO 260 J = 1, IC
CALL SCOPY( N, D, 1, WORK, 1 )
CALL SCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
260 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 6 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 6 ) = OPS / REAL( IC )
END IF
*
* Time SPTEQR with VECT='N'
*
270 CONTINUE
IF( TIMSUB( 7 ) ) THEN
*
* Modify the tridiagonal matrix to make it
* positive definite.
E2( 1 ) = ABS( D( 1 ) ) + ABS( E( 1 ) )
DO 280 I = 2, N - 1
E2( I ) = ABS( D( I ) ) + ABS( E( I ) ) +
$ ABS( E( I-1 ) )
280 CONTINUE
E2( N ) = ABS( D( N ) ) + ABS( E( N-1 ) )
IC = 0
OPS = ZERO
S1 = SECOND( )
290 CONTINUE
CALL SCOPY( N, E2, 1, WORK, 1 )
CALL SCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
CALL SPTEQR( 'N', N, WORK, WORK( LDA+1 ), Z,
$ LDA, WORK( 2*LDA+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 7 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 310
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 290
*
* Subtract the time used in SCOPY.
*
S1 = SECOND( )
DO 300 J = 1, IC
CALL SCOPY( N, D, 1, WORK, 1 )
CALL SCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
300 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 7 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 7 ) = OPS / REAL( IC )
END IF
*
* Time SPTEQR with VECT='V'
*
310 CONTINUE
IF( TIMSUB( 8 ) ) THEN
*
* Modify the tridiagonal matrix to make it
* positive definite.
E2( 1 ) = ABS( D( 1 ) ) + ABS( E( 1 ) )
DO 320 I = 2, N - 1
E2( I ) = ABS( D( I ) ) + ABS( E( I ) ) +
$ ABS( E( I-1 ) )
320 CONTINUE
E2( N ) = ABS( D( N ) ) + ABS( E( N-1 ) )
IC = 0
OPS = ZERO
S1 = SECOND( )
330 CONTINUE
CALL SCOPY( N, E2, 1, WORK, 1 )
CALL SCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
CALL SPTEQR( 'V', N, WORK, WORK( LDA+1 ), Z,
$ LDA, WORK( 2*LDA+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 8 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 350
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 330
*
* Subtract the time used in SCOPY.
*
S1 = SECOND( )
DO 340 J = 1, IC
CALL SCOPY( N, D, 1, WORK, 1 )
CALL SCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
340 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 8 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 8 ) = OPS / REAL( IC )
END IF
*
* Time SSTEBZ(I)
*
350 CONTINUE
IF( TIMSUB( 9 ) ) THEN
IL = 1
IU = N
ABSTOL = ZERO
IC = 0
OPS = ZERO
S1 = SECOND( )
360 CONTINUE
CALL SSTEBZ( 'I', 'B', N, VL, VU, IL, IU,
$ ABSTOL, D, E, MM, NSPLIT, WORK,
$ IWORK, IWORK( LDA+1 ),
$ WORK( 2*LDA+1 ), IWORK( 2*LDA+1 ),
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 9 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 370
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 360
UNTIME = ZERO
*
TIMES( IPAR, ITYPE, IN, 9 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 9 ) = OPS / REAL( IC )
END IF
*
* Time SSTEBZ(V)
*
370 CONTINUE
IF( TIMSUB( 10 ) ) THEN
IF( N.EQ.1 ) THEN
VL = D( 1 ) - ABS( D( 1 ) )
VU = D( 1 ) + ABS( D( 1 ) )
ELSE
VL = D( 1 ) - ABS( E( 1 ) )
VU = D( 1 ) + ABS( E( 1 ) )
DO 380 I = 2, N - 1
VL = MIN( VL, D( I )-ABS( E( I ) )-
$ ABS( E( I-1 ) ) )
VU = MAX( VU, D( I )+ABS( E( I ) )+
$ ABS( E( I-1 ) ) )
380 CONTINUE
VL = MIN( VL, D( N )-ABS( E( N-1 ) ) )
VU = MAX( VU, D( N )+ABS( E( N-1 ) ) )
END IF
ABSTOL = ZERO
IC = 0
OPS = ZERO
S1 = SECOND( )
390 CONTINUE
CALL SSTEBZ( 'V', 'B', N, VL, VU, IL, IU,
$ ABSTOL, D, E, MM, NSPLIT, WORK,
$ IWORK, IWORK( LDA+1 ),
$ WORK( 2*LDA+1 ), IWORK( 2*LDA+1 ),
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 10 ),
$ IINFO, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 400
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 390
UNTIME = ZERO
*
TIMES( IPAR, ITYPE, IN, 10 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 10 ) = OPS / REAL( IC )
END IF
*
* Time SSTEIN
*
400 CONTINUE
IF( TIMSUB( 11 ) ) THEN
IC = 0
OPS = ZERO
S1 = SECOND( )
410 CONTINUE
CALL SSTEIN( N, D, E, MM, WORK, IWORK,
$ IWORK( LDA+1 ), Z, LDA,
$ WORK( LDA+1 ), IWORK( 2*LDA+1 ),
$ IWORK( 3*LDA+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 11 ),
$ IINFO, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 420
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 410
UNTIME = ZERO
*
TIMES( IPAR, ITYPE, IN, 11 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 11 ) = OPS / REAL( IC )
END IF
*
* Time SSTEDC with COMPQ='N'
*
420 CONTINUE
IF( TIMSUB( 12 ) ) THEN
IC = 0
OPS = ZERO
S1 = SECOND( )
430 CONTINUE
CALL SCOPY( N, D, 1, WORK, 1 )
CALL SCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
CALL SSTEDC( 'N', N, WORK, WORK( LDA+1 ), Z,
$ LDA, WORK( 2*LDA+1 ), LWEDC, IWORK,
$ LIWEDC, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 12 ),
$ IINFO, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 450
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 430
*
* Subtract the time used in SCOPY.
*
S1 = SECOND( )
DO 440 J = 1, IC
CALL SCOPY( N, D, 1, WORK, 1 )
CALL SCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
440 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 12 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 12 ) = OPS / REAL( IC )
END IF
*
* Time SSTEDC with COMPQ='I'
*
450 CONTINUE
IF( TIMSUB( 13 ) ) THEN
IC = 0
OPS = ZERO
S1 = SECOND( )
460 CONTINUE
CALL SCOPY( N, D, 1, WORK, 1 )
CALL SCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
CALL SLASET( 'Full', LDA, N, ONE, TWO, Z, LDA )
CALL SSTEDC( 'I', N, WORK, WORK( LDA+1 ), Z,
$ LDA, WORK( 2*LDA+1 ), LWEDC, IWORK,
$ LIWEDC, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 13 ),
$ IINFO, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 480
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 460
*
* Subtract the time used in SCOPY.
*
S1 = SECOND( )
DO 470 J = 1, IC
CALL SLASET( 'Full', LDA, N, ONE, TWO, Z,
$ LDA )
CALL SCOPY( N, D, 1, WORK, 1 )
CALL SCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
470 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 13 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 13 ) = OPS / REAL( IC )
END IF
480 CONTINUE
*
* Time SSTEDC with COMPQ='V'
*
IF( TIMSUB( 14 ) ) THEN
IC = 0
OPS = ZERO
S1 = SECOND( )
490 CONTINUE
CALL SCOPY( N, D, 1, WORK, 1 )
CALL SCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
CALL SLASET( 'Full', LDA, N, ONE, TWO, Z, LDA )
CALL SSTEDC( 'V', N, WORK, WORK( LDA+1 ), Z,
$ LDA, WORK( 2*LDA+1 ), LWEDC, IWORK,
$ LIWEDC, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 14 ),
$ IINFO, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 510
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 490
*
* Subtract the time used in SCOPY.
*
S1 = SECOND( )
DO 500 J = 1, IC
CALL SLASET( 'Full', LDA, N, ONE, TWO, Z,
$ LDA )
CALL SCOPY( N, D, 1, WORK, 1 )
CALL SCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
500 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 14 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 14 ) = OPS / REAL( IC )
END IF
510 CONTINUE
*
* Time SSTEGR with COMPQ='N'
*
IF( TIMSUB( 15 ) ) THEN
ABSTOL = ZERO
VL = ZERO
VU = ZERO
IL = 1
IU = N
IC = 0
OPS = ZERO
S1 = SECOND( )
520 CONTINUE
CALL SCOPY( N, D, 1, WORK, 1 )
CALL SCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
CALL SSTEGR( 'N', 'A', N, WORK, WORK( LDA+1 ),
$ VL, VU, IL, IU, ABSTOL, M,
$ WORK( 2*LDA+1 ), Z, LDA, IWORK,
$ WORK( 3*LDA+1 ), LWEVR,
$ IWORK( 2*LDA+1 ), LIWEVR, INFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 15 ),
$ IINFO, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 540
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 520
*
* Subtract the time used in SCOPY.
*
S1 = SECOND( )
DO 530 J = 1, IC
CALL SLASET( 'Full', LDA, N, ONE, TWO, Z,
$ LDA )
CALL SCOPY( N, D, 1, WORK, 1 )
CALL SCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
530 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 15 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 15 ) = OPS / REAL( IC )
END IF
540 CONTINUE
*
* Time SSTEGR with COMPQ='V'
*
IF( TIMSUB( 16 ) ) THEN
ABSTOL = ZERO
VL = ZERO
VU = ZERO
IL = 1
IU = N
IC = 0
OPS = ZERO
S1 = SECOND( )
550 CONTINUE
CALL SCOPY( N, D, 1, WORK, 1 )
CALL SCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
CALL SSTEGR( 'V', 'A', N, WORK, WORK( LDA+1 ),
$ VL, VU, IL, IU, ABSTOL, M,
$ WORK( 2*LDA+1 ), Z, LDA, IWORK,
$ WORK( 3*LDA+1 ), LWEVR,
$ IWORK( 2*LDA+1 ), LIWEVR, INFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 16 ),
$ IINFO, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 570
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 550
*
* Subtract the time used in SCOPY.
*
S1 = SECOND( )
DO 560 J = 1, IC
CALL SLASET( 'Full', LDA, N, ONE, TWO, Z,
$ LDA )
CALL SCOPY( N, D, 1, WORK, 1 )
CALL SCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
560 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 16 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 16 ) = OPS / REAL( IC )
END IF
570 CONTINUE
*
ELSE
IF( TIMSUB( 4 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 4 ) = OPCNTS( LASTL,
$ ITYPE, IN, 4 )
TIMES( IPAR, ITYPE, IN, 4 ) = TIMES( LASTL,
$ ITYPE, IN, 4 )
END IF
IF( TIMSUB( 5 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 5 ) = OPCNTS( LASTL,
$ ITYPE, IN, 5 )
TIMES( IPAR, ITYPE, IN, 5 ) = TIMES( LASTL,
$ ITYPE, IN, 5 )
END IF
IF( TIMSUB( 6 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 6 ) = OPCNTS( LASTL,
$ ITYPE, IN, 6 )
TIMES( IPAR, ITYPE, IN, 6 ) = TIMES( LASTL,
$ ITYPE, IN, 6 )
END IF
IF( TIMSUB( 7 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 7 ) = OPCNTS( LASTL,
$ ITYPE, IN, 7 )
TIMES( IPAR, ITYPE, IN, 7 ) = TIMES( LASTL,
$ ITYPE, IN, 7 )
END IF
IF( TIMSUB( 8 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 8 ) = OPCNTS( LASTL,
$ ITYPE, IN, 8 )
TIMES( IPAR, ITYPE, IN, 8 ) = TIMES( LASTL,
$ ITYPE, IN, 8 )
END IF
IF( TIMSUB( 9 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 9 ) = OPCNTS( LASTL,
$ ITYPE, IN, 9 )
TIMES( IPAR, ITYPE, IN, 9 ) = TIMES( LASTL,
$ ITYPE, IN, 9 )
END IF
IF( TIMSUB( 10 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 10 ) = OPCNTS( LASTL,
$ ITYPE, IN, 10 )
TIMES( IPAR, ITYPE, IN, 10 ) = TIMES( LASTL,
$ ITYPE, IN, 10 )
END IF
IF( TIMSUB( 11 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 11 ) = OPCNTS( LASTL,
$ ITYPE, IN, 11 )
TIMES( IPAR, ITYPE, IN, 11 ) = TIMES( LASTL,
$ ITYPE, IN, 11 )
END IF
IF( TIMSUB( 12 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 12 ) = OPCNTS( LASTL,
$ ITYPE, IN, 12 )
TIMES( IPAR, ITYPE, IN, 12 ) = TIMES( LASTL,
$ ITYPE, IN, 12 )
END IF
IF( TIMSUB( 13 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 13 ) = OPCNTS( LASTL,
$ ITYPE, IN, 13 )
TIMES( IPAR, ITYPE, IN, 13 ) = TIMES( LASTL,
$ ITYPE, IN, 13 )
END IF
IF( TIMSUB( 14 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 14 ) = OPCNTS( LASTL,
$ ITYPE, IN, 14 )
TIMES( IPAR, ITYPE, IN, 14 ) = TIMES( LASTL,
$ ITYPE, IN, 14 )
END IF
IF( TIMSUB( 15 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 15 ) = OPCNTS( LASTL,
$ ITYPE, IN, 15 )
TIMES( IPAR, ITYPE, IN, 15 ) = TIMES( LASTL,
$ ITYPE, IN, 15 )
END IF
IF( TIMSUB( 16 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 16 ) = OPCNTS( LASTL,
$ ITYPE, IN, 16 )
TIMES( IPAR, ITYPE, IN, 16 ) = TIMES( LASTL,
$ ITYPE, IN, 16 )
END IF
END IF
580 CONTINUE
END IF
590 CONTINUE
*
*-----------------------------------------------------------------------
*
* Time the EISPACK Routines
*
* Skip routines if N <= 0 (EISPACK requirement)
*
IF( N.LE.0 )
$ GO TO 930
*
* Time TRED1 for each LDAS(j)
*
IF( TIMSUB( 17 ) ) THEN
DO 630 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 600 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
600 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time TRED1
*
IC = 0
OPS = ZERO
S1 = SECOND( )
610 CONTINUE
CALL SLACPY( 'L', N, N, A, N, Z, LDA )
CALL TRED1( LDA, N, Z, D, E, E2 )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 610
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 620 J = 1, IC
CALL SLACPY( 'L', N, N, A, N, Z, LDA )
620 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 17 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 17 ) = OPS / REAL( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 17 ) = OPCNTS( LASTL,
$ ITYPE, IN, 17 )
TIMES( IPAR, ITYPE, IN, 17 ) = TIMES( LASTL, ITYPE,
$ IN, 17 )
END IF
630 CONTINUE
ELSE
IF( RUNTR1 ) THEN
CALL SLACPY( 'L', N, N, A, N, Z, LDA )
CALL TRED1( LDA, N, Z, D, E, E2 )
END IF
END IF
*
* Time IMTQL1 for each LDAS(j)
*
IF( TIMSUB( 18 ) ) THEN
DO 670 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 640 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
640 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time IMTQL1
*
IC = 0
OPS = ZERO
S1 = SECOND( )
650 CONTINUE
CALL SCOPY( N, D, 1, WORK, 1 )
CALL SCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
CALL IMTQL1( N, WORK, WORK( LDA+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 18 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 680
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 650
*
* Subtract the time used in SCOPY.
*
S1 = SECOND( )
DO 660 J = 1, IC
CALL SCOPY( N, D, 1, WORK, 1 )
CALL SCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
660 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 18 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 18 ) = OPS / REAL( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 18 ) = OPCNTS( LASTL,
$ ITYPE, IN, 18 )
TIMES( IPAR, ITYPE, IN, 18 ) = TIMES( LASTL, ITYPE,
$ IN, 18 )
END IF
670 CONTINUE
END IF
*
* Time IMTQL2 for each LDAS(j)
*
680 CONTINUE
IF( TIMSUB( 19 ) ) THEN
DO 720 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 690 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
690 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time IMTQL2
*
IC = 0
OPS = ZERO
S1 = SECOND( )
700 CONTINUE
CALL SCOPY( N, D, 1, WORK, 1 )
CALL SCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
CALL SLASET( 'Full', N, N, ONE, TWO, Z, LDA )
CALL IMTQL2( LDA, N, WORK, WORK( LDA+1 ), Z,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 19 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 730
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 700
*
* Subtract the time used in SCOPY.
*
S1 = SECOND( )
DO 710 J = 1, IC
CALL SCOPY( N, D, 1, WORK, 1 )
CALL SCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
CALL SLASET( 'Full', N, N, ONE, TWO, Z, LDA )
710 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 19 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 19 ) = OPS / REAL( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 19 ) = OPCNTS( LASTL,
$ ITYPE, IN, 19 )
TIMES( IPAR, ITYPE, IN, 19 ) = TIMES( LASTL, ITYPE,
$ IN, 19 )
END IF
720 CONTINUE
END IF
*
* Time TQLRAT for each LDAS(j)
*
730 CONTINUE
IF( TIMSUB( 20 ) ) THEN
DO 770 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 740 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
740 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time TQLRAT
*
IC = 0
OPS = ZERO
S1 = SECOND( )
750 CONTINUE
CALL SCOPY( N, D, 1, WORK, 1 )
CALL SCOPY( N-1, E2, 1, WORK( LDA+1 ), 1 )
CALL TQLRAT( N, WORK, WORK( LDA+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 20 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 780
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 750
*
* Subtract the time used in SCOPY.
*
S1 = SECOND( )
DO 760 J = 1, IC
CALL SCOPY( N, D, 1, WORK, 1 )
CALL SCOPY( N-1, E2, 1, WORK( LDA+1 ), 1 )
760 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 20 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 20 ) = OPS / REAL( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 20 ) = OPCNTS( LASTL,
$ ITYPE, IN, 20 )
TIMES( IPAR, ITYPE, IN, 20 ) = TIMES( LASTL, ITYPE,
$ IN, 20 )
END IF
770 CONTINUE
END IF
*
* Time TRIDIB for each LDAS(j)
*
780 CONTINUE
IF( TIMSUB( 21 ) ) THEN
DO 820 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 790 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
790 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time TRIDIB
*
IC = 0
OPS = ZERO
EPS1 = ZERO
RLB = ZERO
RUB = ZERO
M11 = 1
MM = N
S1 = SECOND( )
800 CONTINUE
CALL SCOPY( N, D, 1, WORK, 1 )
CALL SCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
CALL SCOPY( N-1, E2, 1, WORK( 2*LDA+1 ), 1 )
CALL TRIDIB( N, EPS1, WORK( 1 ), WORK( LDA+1 ),
$ WORK( 2*LDA+1 ), RLB, RUB, M11, MM,
$ WORK( 3*LDA+1 ), IWORK, IINFO,
$ WORK( 4*LDA+1 ), WORK( 5*LDA+1 ) )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 21 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 830
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 800
*
* Subtract the time used in SCOPY.
*
S1 = SECOND( )
DO 810 J = 1, IC
CALL SCOPY( N, D, 1, WORK, 1 )
CALL SCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
CALL SCOPY( N-1, E2, 1, WORK( 2*LDA+1 ), 1 )
810 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 21 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 21 ) = OPS / REAL( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 21 ) = OPCNTS( LASTL,
$ ITYPE, IN, 21 )
TIMES( IPAR, ITYPE, IN, 21 ) = TIMES( LASTL, ITYPE,
$ IN, 21 )
END IF
820 CONTINUE
END IF
*
* Time BISECT for each LDAS(j)
*
830 CONTINUE
IF( TIMSUB( 22 ) ) THEN
DO 880 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 840 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
840 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time BISECT
*
VL = D( 1 ) - ABS( E( 2 ) )
VU = D( 1 ) + ABS( E( 2 ) )
DO 850 I = 2, N - 1
VL = MIN( VL, D( I )-ABS( E( I+1 ) )-
$ ABS( E( I ) ) )
VU = MAX( VU, D( I )+ABS( E( I+1 ) )+
$ ABS( E( I ) ) )
850 CONTINUE
VL = MIN( VL, D( N )-ABS( E( N ) ) )
VU = MAX( VU, D( N )+ABS( E( N ) ) )
IC = 0
OPS = ZERO
EPS1 = ZERO
MM = N
MMM = 0
S1 = SECOND( )
860 CONTINUE
CALL SCOPY( N, D, 1, WORK, 1 )
CALL SCOPY( N, E, 1, WORK( LDA+1 ), 1 )
CALL SCOPY( N, E2, 1, WORK( 2*LDA+1 ), 1 )
CALL BISECT( N, EPS1, WORK( 1 ), WORK( LDA+1 ),
$ WORK( 2*LDA+1 ), VL, VU, MM, MMM,
$ WORK( 3*LDA+1 ), IWORK, IINFO,
$ WORK( 4*LDA+1 ), WORK( 5*LDA+1 ) )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 22 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 890
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 860
*
* Subtract the time used in SCOPY.
*
S1 = SECOND( )
DO 870 J = 1, IC
CALL SCOPY( N, D, 1, WORK, 1 )
CALL SCOPY( N, E, 1, WORK( LDA+1 ), 1 )
CALL SCOPY( N, E2, 1, WORK( 2*LDA+1 ), 1 )
870 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 22 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 22 ) = OPS / REAL( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 22 ) = OPCNTS( LASTL,
$ ITYPE, IN, 22 )
TIMES( IPAR, ITYPE, IN, 22 ) = TIMES( LASTL, ITYPE,
$ IN, 22 )
END IF
880 CONTINUE
END IF
*
* Time TINVIT for each LDAS(j)
*
890 CONTINUE
IF( TIMSUB( 23 ) ) THEN
CALL SCOPY( N, WORK( 3*LDA+1 ), 1, WORK( 1 ), 1 )
DO 920 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 900 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
900 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time TINVIT
*
IC = 0
OPS = ZERO
S1 = SECOND( )
910 CONTINUE
CALL TINVIT( LDA, N, D, E, E2, MMM, WORK, IWORK, Z,
$ IINFO, WORK( LDA+1 ), WORK( 2*LDA+1 ),
$ WORK( 3*LDA+1 ), WORK( 4*LDA+1 ),
$ WORK( 5*LDA+1 ) )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 23 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 930
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 910
UNTIME = ZERO
*
TIMES( IPAR, ITYPE, IN, 23 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 23 ) = OPS / REAL( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 23 ) = OPCNTS( LASTL,
$ ITYPE, IN, 23 )
TIMES( IPAR, ITYPE, IN, 23 ) = TIMES( LASTL, ITYPE,
$ IN, 23 )
END IF
920 CONTINUE
END IF
*
930 CONTINUE
940 CONTINUE
*
*-----------------------------------------------------------------------
*
* Print a table of results for each timed routine.
*
DO 950 ISUB = 1, NSUBS
IF( TIMSUB( ISUB ) ) THEN
CALL SPRTBE( SUBNAM( ISUB ), MTYPES, DOTYPE, NSIZES, NN,
$ INPARM( ISUB ), PNAMES, NPARMS, LDAS, NNB,
$ IDUMMA, IDUMMA, OPCNTS( 1, 1, 1, ISUB ), LDO1,
$ LDO2, TIMES( 1, 1, 1, ISUB ), LDT1, LDT2, WORK,
$ LLWORK, NOUT )
END IF
950 CONTINUE
*
9997 FORMAT( ' STIM22: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', ITYPE=', I6, ', IPAR=', I6, ', ISEED=(',
$ 3( I5, ',' ), I5, ')' )
*
RETURN
*
* End of STIM22
*
END
SUBROUTINE STIM26( LINE, NSIZES, NN, MM, NTYPES, DOTYPE, NPARMS,
$ NNB, LDAS, TIMMIN, NOUT, ISEED, A, H, U, VT, D,
$ E, TAUP, TAUQ, WORK, LWORK, IWORK, LLWORK,
$ TIMES, LDT1, LDT2, LDT3, OPCNTS, LDO1, LDO2,
$ LDO3, INFO )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER INFO, LDO1, LDO2, LDO3, LDT1, LDT2, LDT3,
$ LWORK, NOUT, NPARMS, NSIZES, NTYPES
REAL TIMMIN
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * ), LLWORK( * )
INTEGER ISEED( * ), IWORK( * ), LDAS( * ), MM( * ),
$ NN( * ), NNB( * )
REAL A( * ), D( * ), E( * ), H( * ),
$ OPCNTS( LDO1, LDO2, LDO3, * ), TAUP( * ),
$ TAUQ( * ), TIMES( LDT1, LDT2, LDT3, * ),
$ U( * ), VT( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* STIM26 times the LAPACK routines for the REAL
* singular value decomposition.
*
* For each N value in NN(1:NSIZES), M value in MM(1:NSIZES),
* and .TRUE. value in DOTYPE(1:NTYPES), a matrix will be generated
* and used to test the selected routines. Thus, NSIZES*(number of
* .TRUE. values in DOTYPE) matrices will be generated.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* On entry, LINE contains the input line which requested
* this routine. This line may contain a subroutine name,
* such as SGEBRD, indicating that only routine SGEBRD will
* be timed, or it may contain a generic name, such as SBD.
* In this case, the rest of the line is scanned for the
* first 11 non-blank characters, corresponding to the eleven
* combinations of subroutine and options:
* LAPACK:
* 1: SGEBRD
* (labeled SGEBRD in the output)
* 2: SBDSQR (singular values only)
* (labeled SBDSQR in the output)
* 3: SBDSQR (singular values and left singular vectors;
* assume original matrix M by N)
* (labeled SBDSQR(L) in the output)
* 4: SBDSQR (singular values and right singular vectors;
* assume original matrix M by N)
* (labeled SBDSQR(R) in the output)
* 5: SBDSQR (singular values and left and right singular
* vectors; assume original matrix M by N)
* (labeled SBDSQR(B) in the output)
* 6: SBDSQR (singular value and multiply square MIN(M,N)
* matrix by transpose of left singular vectors)
* (labeled SBDSQR(V) in the output)
* 7: SGEBRD+SBDSQR (singular values only)
* (labeled LAPSVD in the output)
* 8: SGEBRD+SORGBR+SBDSQR(L) (singular values and min(M,N)
* left singular vectors)
* (labeled LAPSVD(l) in the output)
* 9: SGEBRD+SORGBR+SBDSQR(L) (singular values and M left
* singular vectors)
* (labeled LAPSVD(L) in the output)
* 10: SGEBRD+SORGBR+SBDSQR(R) (singular values and N right
* singular vectors)
* (labeled LAPSVD(R) in the output)
* 11: SGEBRD+SORGBR+SBDSQR(B) (singular values and min(M,N)
* left singular vectors and N
* right singular vectors)
* (labeled LAPSVD(B) in the output)
* 12: SBDSDC (singular values and left and right singular
* vectors; assume original matrix min(M,N) by
* min(M,N))
* (labeled SBDSDC(B) in the output)
* 13: SGESDD (singular values and min(M,N) left singular
* vectors and N right singular vectors if M>=N,
* singular values and M left singular vectors
* and min(M,N) right singular vectors otherwise.)
* (labeled SGESDD(B) in the output)
* LINPACK:
* 14: SSVDC (singular values only) (comparable to 7 above)
* (labeled LINSVD in the output)
* 15: SSVDC (singular values and min(M,N) left singular
* vectors) (comparable to 8 above)
* (labeled LINSVD(l) in the output)
* 16: SSVDC (singular values and M left singular vectors)
* (comparable to 9 above)
* (labeled LINSVD(L) in the output)
* 17: SSVDC (singular values and N right singular vectors)
* (comparable to 10 above)
* (labeled LINSVD(R) in the output)
* 18: SSVDC (singular values and min(M,N) left singular
* vectors and N right singular vectors)
* (comparable to 11 above)
* (labeled LINSVD(B) in the output)
*
* If a character is 'T' or 't', the corresponding routine in
* this path is timed. If the entire line is blank, all the
* routines in the path are timed.
*
* NSIZES (input) INTEGER
* The number of values of N contained in the vector NN.
*
* NN (input) INTEGER array, dimension( NSIZES )
* The numbers of columns of the matrices to be tested. For
* each N value in the array NN, and each .TRUE. value in
* DOTYPE, a matrix A will be generated and used to test the
* routines.
*
* MM (input) INTEGER array, dimension( NSIZES )
* The numbers of rows of the matrices to be tested. For
* each M value in the array MM, and each .TRUE. value in
* DOTYPE, a matrix A will be generated and used to test the
* routines.
*
* NTYPES (input) INTEGER
* The number of types in DOTYPE. Only the first MAXTYP
* elements will be examined. Exception: if NSIZES=1 and
* NTYPES=MAXTYP+1, and DOTYPE=MAXTYP*f,t, then the input
* value of A will be used.
*
* DOTYPE (input) LOGICAL
* If DOTYPE(j) is .TRUE., then a matrix of type j will be
* generated as follows:
* j=1: A = U*D*V where U and V are random orthogonal
* matrices and D has evenly spaced entries 1,...,ULP
* with random signs on the diagonal
* j=2: A = U*D*V where U and V are random orthogonal
* matrices and D has geometrically spaced entries
* 1,...,ULP with random signs on the diagonal
* j=3: A = U*D*V where U and V are random orthogonal
* matrices and D has "clustered" entries
* 1,ULP,...,ULP with random signs on the diagonal
* j=4: A contains uniform random numbers from [-1,1]
* j=5: A is a special nearly bidiagonal matrix, where the
* upper bidiagonal entries are exp(-2*r*log(ULP))
* and the nonbidiagonal entries are r*ULP, where r
* is a uniform random number from [0,1]
*
* NPARMS (input) INTEGER
* The number of values in each of the arrays NNB and LDAS.
* For each matrix A generated according to NN, MM and DOTYPE,
* tests will be run with (NB,,LDA)= (NNB(1), LDAS(1)),...,
* (NNB(NPARMS), LDAS(NPARMS)).
*
* NNB (input) INTEGER array, dimension( NPARMS )
* The values of the blocksize ("NB") to be tested.
*
* LDAS (input) INTEGER array, dimension( NPARMS )
* The values of LDA, the leading dimension of all matrices,
* to be tested.
*
* TIMMIN (input) REAL
* The minimum time a subroutine will be timed.
*
* NOUT (input) INTEGER
* If NOUT > 0 then NOUT specifies the unit number
* on which the output will be printed. If NOUT <= 0, no
* output is printed.
*
* ISEED (input/output) INTEGER array, dimension( 4 )
* The random seed used by the random number generator, used
* by the test matrix generator. It is used and updated on
* each call to STIM26.
*
* A (workspace) REAL array,
* dimension( max(NN)*max(LDAS))
* During the testing of SGEBRD, the original dense matrix.
*
* H (workspace) REAL array,
* dimension( max(NN)*max(LDAS))
* The Householder vectors used to reduce A to bidiagonal
* form (as returned by SGEBD2.)
*
* U (workspace) REAL array,
* dimension( max(NN,MM)*max(LDAS) )
* The left singular vectors of the original matrix.
*
* VT (workspace) REAL array,
* dimension( max(NN,MM)*max(LDAS) )
* The right singular vectors of the original matrix.
*
* D (workspace) REAL array, dimension( max(NN,MM) )
* Diagonal entries of bidiagonal matrix to which A
* is reduced.
*
* E (workspace) REAL array, dimension( max(NN,MM) )
* Offdiagonal entries of bidiagonal matrix to which A
* is reduced.
*
* TAUP (workspace) REAL array, dimension( max(NN,MM) )
* The coefficients for the Householder transformations
* applied on the right to reduce A to bidiagonal form.
*
* TAUQ (workspace) REAL array, dimension( max(NN,MM) )
* The coefficients for the Householder transformations
* applied on the left to reduce A to bidiagonal form.
*
* WORK (workspace) REAL array, dimension( LWORK )
*
* LWORK (input) INTEGER
* Number of elements in WORK. Must be at least
* MAX(6*MIN(M,N),3*MAX(M,N),NSIZES*NPARMS*NTYPES)
*
* IWORK (workspace) INTEGER array, dimension at least 8*min(M,N).
*
* LLWORK (workspace) LOGICAL array, dimension( NPARMS ),
*
* TIMES (output) REAL array,
* dimension (LDT1,LDT2,LDT3,NSUBS)
* TIMES(i,j,k,l) will be set to the run time (in seconds) for
* subroutine/path l, with N=NN(k), M=MM(k), matrix type j,
* LDA=LDAS(i), and NBLOCK=NNB(i).
*
* LDT1 (input) INTEGER
* The first dimension of TIMES. LDT1 >= min( 1, NPARMS ).
*
* LDT2 (input) INTEGER
* The second dimension of TIMES. LDT2 >= min( 1, NTYPES ).
*
* LDT3 (input) INTEGER
* The third dimension of TIMES. LDT3 >= min( 1, NSIZES ).
*
* OPCNTS (output) REAL array,
* dimension (LDO1,LDO2,LDO3,NSUBS)
* OPCNTS(i,j,k,l) will be set to the number of floating-point
* operations executed by subroutine/path l, with N=NN(k),
* M=MM(k), matrix type j, LDA=LDAS(i), and NBLOCK=NNB(i).
*
* LDO1 (input) INTEGER
* The first dimension of OPCNTS. LDO1 >= min( 1, NPARMS ).
*
* LDO2 (input) INTEGER
* The second dimension of OPCNTS. LDO2 >= min( 1, NTYPES ).
*
* LDO3 (input) INTEGER
* The third dimension of OPCNTS. LDO3 >= min( 1, NSIZES ).
*
* INFO (output) INTEGER
* Error flag. It will be set to zero if no error occurred.
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXTYP, NSUBS
PARAMETER ( MAXTYP = 5, NSUBS = 18 )
REAL ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 )
* ..
* .. Local Scalars ..
LOGICAL RUNBRD, TRNBRD
CHARACTER UPLO
INTEGER IC, IINFO, IMODE, IN, IPAR, ISUB, ITYPE,
$ J, J1, J2, J3, J4, KU, KVT, LASTNL, LDA,
$ LDH, M, MINMN, MTYPES, N, NB
REAL CONDS, ESUM, S1, S2, TIME, ULP, ULPINV, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER*4 PNAMES( 2 )
CHARACTER*9 SUBNAM( NSUBS )
INTEGER INPARM( NSUBS ), IOLDSD( 4 ), JDUM( 1 ),
$ KMODE( 3 )
REAL DUM( 1 )
* ..
* .. External Functions ..
REAL SECOND, SASUM, SLAMCH, SLARND,
$ SOPLA, SOPLA2
EXTERNAL SECOND, SASUM, SLAMCH, SLARND,
$ SOPLA, SOPLA2
* ..
* .. External Subroutines ..
EXTERNAL SBDSDC, SBDSQR, SCOPY, SGEBRD,
$ SGESDD, SLACPY, SLASET, SLATMR,
$ SLATMS, SORGBR, SPRTBV, SSVDC,
$ ATIMIN, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL, ABS, EXP, LOG, MAX, MIN
* ..
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
* .. Data statements ..
DATA SUBNAM / 'SGEBRD', 'SBDSQR', 'SBDSQR(L)',
$ 'SBDSQR(R)', 'SBDSQR(B)', 'SBDSQR(V)',
$ 'LAPSVD', 'LAPSVD(l)', 'LAPSVD(L)',
$ 'LAPSVD(R)', 'LAPSVD(B)', 'SBDSDC(B)',
$ 'SGESDD(B)', 'LINSVD', 'LINSVD(l)',
$ 'LINSVD(L)', 'LINSVD(R)', 'LINSVD(B)' /
DATA INPARM / 2, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 1, 2,
$ 1, 1, 1, 1, 1 /
DATA PNAMES / 'LDA', 'NB' /
DATA KMODE / 4, 3, 1 /
* ..
* .. Executable Statements ..
*
*
* Extract the timing request from the input line.
*
CALL ATIMIN( 'SBD', LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ RETURN
*
* Check LWORK and
* Check that N <= LDA and M <= LDA for the input values.
*
DO 20 J2 = 1, NSIZES
IF( LWORK.LT.MAX( 6*MIN( MM( J2 ), NN( J2 ) ), 3*MAX( MM( J2 ),
$ NN( J2 ) ), NSIZES*NPARMS*NTYPES ) ) THEN
INFO = -22
WRITE( NOUT, FMT = 9999 )LINE( 1: 6 )
RETURN
END IF
DO 10 J1 = 1, NPARMS
IF( MAX( NN( J2 ), MM( J2 ) ).GT.LDAS( J1 ) ) THEN
INFO = -9
WRITE( NOUT, FMT = 9999 )LINE( 1: 6 )
9999 FORMAT( 1X, A, ' timing run not attempted', / )
RETURN
END IF
10 CONTINUE
20 CONTINUE
*
* Check to see whether SGEBRD must be run.
*
* RUNBRD -- if SGEBRD must be run without timing.
* TRNBRD -- if SGEBRD must be run with timing.
*
RUNBRD = .FALSE.
TRNBRD = .FALSE.
IF( TIMSUB( 2 ) .OR. TIMSUB( 3 ) .OR. TIMSUB( 4 ) .OR.
$ TIMSUB( 5 ) .OR. TIMSUB( 6 ) )RUNBRD = .TRUE.
IF( TIMSUB( 1 ) )
$ RUNBRD = .FALSE.
IF( TIMSUB( 7 ) .OR. TIMSUB( 8 ) .OR. TIMSUB( 9 ) .OR.
$ TIMSUB( 10 ) .OR. TIMSUB( 11 ) )TRNBRD = .TRUE.
*
* Various Constants
*
ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
ULPINV = ONE / ULP
CALL XLAENV( 9, 25 )
*
* Zero out OPCNTS, TIMES
*
DO 60 J4 = 1, NSUBS
DO 50 J3 = 1, NSIZES
DO 40 J2 = 1, NTYPES
DO 30 J1 = 1, NPARMS
OPCNTS( J1, J2, J3, J4 ) = ZERO
TIMES( J1, J2, J3, J4 ) = ZERO
30 CONTINUE
40 CONTINUE
50 CONTINUE
60 CONTINUE
*
* Do for each value of N:
*
DO 750 IN = 1, NSIZES
*
N = NN( IN )
M = MM( IN )
MINMN = MIN( M, N )
IF( M.GE.N ) THEN
UPLO = 'U'
KU = MINMN
KVT = MAX( MINMN-1, 0 )
ELSE
UPLO = 'L'
KU = MAX( MINMN-1, 0 )
KVT = MINMN
END IF
*
* Do for each .TRUE. value in DOTYPE:
*
MTYPES = MIN( MAXTYP, NTYPES )
IF( NTYPES.EQ.MAXTYP+1 .AND. NSIZES.EQ.1 )
$ MTYPES = NTYPES
DO 740 ITYPE = 1, MTYPES
IF( .NOT.DOTYPE( ITYPE ) )
$ GO TO 740
*
* Save random number seed for error messages
*
DO 70 J = 1, 4
IOLDSD( J ) = ISEED( J )
70 CONTINUE
*
*-----------------------------------------------------------------------
*
* Time the LAPACK Routines
*
* Generate A
*
IF( ITYPE.LE.MAXTYP ) THEN
IF( ITYPE.GE.1 .AND. ITYPE.LE.3 ) THEN
IMODE = KMODE( ITYPE )
CALL SLATMS( M, N, 'U', ISEED, 'N', D, IMODE, ULPINV,
$ ONE, M, N, 'N', A, M, WORK, INFO )
ELSE IF( ITYPE.GE.4 .AND. ITYPE.LE.5 ) THEN
IF( ITYPE.EQ.4 )
$ CONDS = -ONE
IF( ITYPE.EQ.5 )
$ CONDS = ULP
CALL SLATMR( M, N, 'S', ISEED, 'N', D, 6, ZERO, ONE,
$ 'T', 'N', D, 0, ONE, D, 0, ONE, 'N',
$ JDUM, M, N, ZERO, CONDS, 'N', A, M, JDUM,
$ INFO )
IF( ITYPE.EQ.5 ) THEN
CONDS = -TWO*LOG( ULP )
DO 80 J = 1, ( MINMN-1 )*M + MINMN, M + 1
A( J ) = EXP( CONDS*SLARND( 1, ISEED ) )
80 CONTINUE
IF( M.GE.N ) THEN
DO 90 J = M + 1, ( MINMN-1 )*M + MINMN - 1,
$ M + 1
A( J ) = EXP( CONDS*SLARND( 1, ISEED ) )
90 CONTINUE
ELSE
DO 100 J = 2, ( MINMN-2 )*M + MINMN, M + 1
A( J ) = EXP( CONDS*SLARND( 1, ISEED ) )
100 CONTINUE
END IF
END IF
END IF
END IF
*
* Time SGEBRD for each pair NNB(j), LDAS(j)
*
IF( TIMSUB( 1 ) .OR. TRNBRD ) THEN
DO 130 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
CALL XLAENV( 1, NB )
CALL XLAENV( 2, 2 )
CALL XLAENV( 3, NB )
*
* Time SGEBRD
*
IC = 0
OPS = ZERO
S1 = SECOND( )
110 CONTINUE
CALL SLACPY( 'Full', M, N, A, M, H, LDA )
CALL SGEBRD( M, N, H, LDA, D, E, TAUQ, TAUP, WORK,
$ LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 1 ), IINFO, M, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
*
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 110
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 120 J = 1, IC
CALL SLACPY( 'Full', M, N, A, M, U, LDA )
120 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 1 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 1 ) = SOPLA( 'SGEBRD', M, N,
$ 0, 0, NB )
130 CONTINUE
LDH = LDA
ELSE
IF( RUNBRD ) THEN
CALL SLACPY( 'Full', M, N, A, M, H, M )
CALL SGEBRD( M, N, H, M, D, E, TAUQ, TAUP, WORK,
$ LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 1 ), IINFO, M, N,
$ ITYPE, 0, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
LDH = M
END IF
END IF
*
* Time SBDSQR (singular values only) for each pair
* NNB(j), LDAS(j)
*
IF( TIMSUB( 2 ) .OR. TIMSUB( 7 ) ) THEN
DO 170 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
*
* If this value of LDA has been used before, just
* use that value
*
LASTNL = 0
DO 140 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTNL = J
140 CONTINUE
*
IF( LASTNL.EQ.0 ) THEN
*
* Time SBDSQR (singular values only)
*
IC = 0
OPS = ZERO
S1 = SECOND( )
150 CONTINUE
CALL SCOPY( MINMN, D, 1, WORK, 1 )
CALL SCOPY( MINMN-1, E, 1, WORK( MINMN+1 ), 1 )
CALL SBDSQR( UPLO, MINMN, 0, 0, 0, WORK,
$ WORK( MINMN+1 ), VT, LDA, U, LDA, U,
$ LDA, WORK( 2*MINMN+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 2 ), IINFO, M,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 150
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 160 J = 1, IC
CALL SCOPY( MINMN, D, 1, WORK, 1 )
CALL SCOPY( MINMN-1, E, 1, WORK( MINMN+1 ), 1 )
160 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 2 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 2 ) = OPS / REAL( IC )
*
ELSE
*
TIMES( IPAR, ITYPE, IN, 2 ) = TIMES( LASTNL, ITYPE,
$ IN, 2 )
OPCNTS( IPAR, ITYPE, IN, 2 ) = OPCNTS( LASTNL,
$ ITYPE, IN, 2 )
END IF
170 CONTINUE
END IF
*
* Time SBDSQR (singular values and left singular vectors,
* assume original matrix square) for each pair NNB(j), LDAS(j)
*
IF( TIMSUB( 3 ) .OR. TIMSUB( 8 ) .OR. TIMSUB( 9 ) ) THEN
DO 210 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
*
* If this value of LDA has been used before, just
* use that value
*
LASTNL = 0
DO 180 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTNL = J
180 CONTINUE
*
IF( LASTNL.EQ.0 ) THEN
*
* Time SBDSQR (singular values and left singular
* vectors, assume original matrix square)
*
IC = 0
OPS = ZERO
S1 = SECOND( )
190 CONTINUE
CALL SLASET( 'Full', M, MINMN, ONE, TWO, U, LDA )
CALL SCOPY( MINMN, D, 1, WORK, 1 )
CALL SCOPY( MINMN-1, E, 1, WORK( MINMN+1 ), 1 )
CALL SBDSQR( UPLO, MINMN, 0, M, 0, WORK,
$ WORK( MINMN+1 ), VT, LDA, U, LDA, U,
$ LDA, WORK( 2*MINMN+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 3 ), IINFO, M,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 190
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 200 J = 1, IC
CALL SLASET( 'Full', M, MINMN, ONE, TWO, U,
$ LDA )
CALL SCOPY( MINMN, D, 1, WORK, 1 )
CALL SCOPY( MINMN-1, E, 1, WORK( MINMN+1 ), 1 )
200 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 3 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 3 ) = OPS / REAL( IC )
*
ELSE
*
TIMES( IPAR, ITYPE, IN, 3 ) = TIMES( LASTNL, ITYPE,
$ IN, 3 )
OPCNTS( IPAR, ITYPE, IN, 3 ) = OPCNTS( LASTNL,
$ ITYPE, IN, 3 )
END IF
210 CONTINUE
END IF
*
* Time SBDSQR (singular values and right singular vectors,
* assume original matrix square) for each pair NNB(j), LDAS(j)
*
IF( TIMSUB( 4 ) .OR. TIMSUB( 10 ) ) THEN
DO 250 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
*
* If this value of LDA has been used before, just
* use that value
*
LASTNL = 0
DO 220 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTNL = J
220 CONTINUE
*
IF( LASTNL.EQ.0 ) THEN
*
* Time SBDSQR (singular values and right singular
* vectors, assume original matrix square)
*
IC = 0
OPS = ZERO
S1 = SECOND( )
230 CONTINUE
CALL SLASET( 'Full', MINMN, N, ONE, TWO, VT, LDA )
CALL SCOPY( MINMN, D, 1, WORK, 1 )
CALL SCOPY( MINMN-1, E, 1, WORK( MINMN+1 ), 1 )
CALL SBDSQR( UPLO, MINMN, N, 0, 0, WORK,
$ WORK( MINMN+1 ), VT, LDA, U, LDA, U,
$ LDA, WORK( 2*MINMN+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 4 ), IINFO, M,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 230
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 240 J = 1, IC
CALL SLASET( 'Full', MINMN, N, ONE, TWO, VT,
$ LDA )
CALL SCOPY( MINMN, D, 1, WORK, 1 )
CALL SCOPY( MINMN-1, E, 1, WORK( MINMN+1 ), 1 )
240 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 4 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 4 ) = OPS / REAL( IC )
*
ELSE
*
TIMES( IPAR, ITYPE, IN, 4 ) = TIMES( LASTNL, ITYPE,
$ IN, 4 )
OPCNTS( IPAR, ITYPE, IN, 4 ) = OPCNTS( LASTNL,
$ ITYPE, IN, 4 )
END IF
250 CONTINUE
END IF
*
* Time SBDSQR (singular values and left and right singular
* vectors,assume original matrix square) for each pair
* NNB(j), LDAS(j)
*
IF( TIMSUB( 5 ) .OR. TIMSUB( 11 ) ) THEN
DO 290 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
*
* If this value of LDA has been used before, just
* use that value
*
LASTNL = 0
DO 260 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTNL = J
260 CONTINUE
*
IF( LASTNL.EQ.0 ) THEN
*
* Time SBDSQR (singular values and left and right
* singular vectors, assume original matrix square)
*
IC = 0
OPS = ZERO
S1 = SECOND( )
270 CONTINUE
CALL SLASET( 'Full', MINMN, N, ONE, TWO, VT, LDA )
CALL SLASET( 'Full', M, MINMN, ONE, TWO, U, LDA )
CALL SCOPY( MINMN, D, 1, WORK, 1 )
CALL SCOPY( MINMN-1, E, 1, WORK( MINMN+1 ), 1 )
CALL SBDSQR( UPLO, MINMN, N, M, 0, WORK,
$ WORK( MINMN+1 ), VT, LDA, U, LDA, U,
$ LDA, WORK( 2*MINMN+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 5 ), IINFO, M,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 270
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 280 J = 1, IC
CALL SLASET( 'Full', MINMN, N, ONE, TWO, VT,
$ LDA )
CALL SLASET( 'Full', M, MINMN, ONE, TWO, U,
$ LDA )
CALL SCOPY( MINMN, D, 1, WORK, 1 )
CALL SCOPY( MINMN-1, E, 1, WORK( MINMN+1 ), 1 )
280 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 5 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 5 ) = OPS / REAL( IC )
*
ELSE
*
TIMES( IPAR, ITYPE, IN, 5 ) = TIMES( LASTNL, ITYPE,
$ IN, 5 )
OPCNTS( IPAR, ITYPE, IN, 5 ) = OPCNTS( LASTNL,
$ ITYPE, IN, 5 )
END IF
290 CONTINUE
END IF
*
* Time SBDSQR (singular values and multiply square matrix
* by transpose of left singular vectors) for each pair
* NNB(j), LDAS(j)
*
IF( TIMSUB( 6 ) ) THEN
DO 330 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
*
* If this value of LDA has been used before, just
* use that value
*
LASTNL = 0
DO 300 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTNL = J
300 CONTINUE
*
IF( LASTNL.EQ.0 ) THEN
*
* Time SBDSQR (singular values and multiply square
* matrix by transpose of left singular vectors)
*
IC = 0
OPS = ZERO
S1 = SECOND( )
310 CONTINUE
CALL SLASET( 'Full', MINMN, MINMN, ONE, TWO, U,
$ LDA )
CALL SCOPY( MINMN, D, 1, WORK, 1 )
CALL SCOPY( MINMN-1, E, 1, WORK( MINMN+1 ), 1 )
CALL SBDSQR( UPLO, MINMN, 0, 0, MINMN, WORK,
$ WORK( MINMN+1 ), VT, LDA, U, LDA, U,
$ LDA, WORK( 2*MINMN+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 6 ), IINFO, M,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 310
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 320 J = 1, IC
CALL SLASET( 'Full', MINMN, MINMN, ONE, TWO, U,
$ LDA )
CALL SCOPY( MINMN, D, 1, WORK, 1 )
CALL SCOPY( MINMN-1, E, 1, WORK( MINMN+1 ), 1 )
320 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 6 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 6 ) = OPS / REAL( IC )
*
ELSE
*
TIMES( IPAR, ITYPE, IN, 6 ) = TIMES( LASTNL, ITYPE,
$ IN, 6 )
OPCNTS( IPAR, ITYPE, IN, 6 ) = OPCNTS( LASTNL,
$ ITYPE, IN, 6 )
END IF
330 CONTINUE
END IF
*
* Time SGEBRD+SBDSQR (singular values only) for each pair
* NNB(j), LDAS(j)
* Use previously computed timings for SGEBRD & SBDSQR
*
IF( TIMSUB( 7 ) ) THEN
DO 340 IPAR = 1, NPARMS
TIMES( IPAR, ITYPE, IN, 7 ) = TIMES( IPAR, ITYPE, IN,
$ 1 ) + TIMES( IPAR, ITYPE, IN, 2 )
OPCNTS( IPAR, ITYPE, IN, 7 ) = OPCNTS( IPAR, ITYPE,
$ IN, 1 ) + OPCNTS( IPAR, ITYPE, IN, 2 )
340 CONTINUE
END IF
*
* Time SGEBRD+SORGBR+SBDSQR (singular values and min(M,N)
* left singular vectors) for each pair NNB(j), LDAS(j)
*
* Use previously computed timings for SGEBRD & SBDSQR
*
IF( TIMSUB( 8 ) ) THEN
DO 370 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
CALL XLAENV( 1, NB )
CALL XLAENV( 2, 2 )
CALL XLAENV( 3, NB )
*
* Time SGEBRD+SORGBR+SBDSQR (singular values and
* min(M,N) left singular vectors)
*
IC = 0
OPS = ZERO
S1 = SECOND( )
350 CONTINUE
CALL SLACPY( 'L', M, MINMN, H, LDH, U, LDA )
CALL SORGBR( 'Q', M, MINMN, KU, U, LDA, TAUQ, WORK,
$ LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 8 ), IINFO, M, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 350
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 360 J = 1, IC
CALL SLACPY( 'L', M, MINMN, H, LDH, U, LDA )
360 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 8 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC ) + TIMES( IPAR, ITYPE, IN, 1 ) +
$ TIMES( IPAR, ITYPE, IN, 3 )
OPCNTS( IPAR, ITYPE, IN, 8 ) = SOPLA2( 'SORGBR', 'Q',
$ M, MINMN, KU, 0, NB ) + OPCNTS( IPAR, ITYPE, IN,
$ 1 ) + OPCNTS( IPAR, ITYPE, IN, 3 )
370 CONTINUE
END IF
*
* Time SGEBRD+SORGBR+SBDSQR (singular values and M
* left singular vectors) for each pair NNB(j), LDAS(j)
*
* Use previously computed timings for SGEBRD & SBDSQR
*
IF( TIMSUB( 9 ) ) THEN
DO 400 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
CALL XLAENV( 1, NB )
CALL XLAENV( 2, 2 )
CALL XLAENV( 3, NB )
*
* Time SGEBRD+SORGBR+SBDSQR (singular values and
* M left singular vectors)
*
IC = 0
OPS = ZERO
S1 = SECOND( )
380 CONTINUE
CALL SLACPY( 'L', M, MINMN, H, LDH, U, LDA )
CALL SORGBR( 'Q', M, M, KU, U, LDA, TAUQ, WORK, LWORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 9 ), IINFO, M, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 380
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 390 J = 1, IC
CALL SLACPY( 'L', M, MINMN, H, LDH, U, LDA )
390 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 9 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC ) + TIMES( IPAR, ITYPE, IN, 1 ) +
$ TIMES( IPAR, ITYPE, IN, 3 )
OPCNTS( IPAR, ITYPE, IN, 9 ) = SOPLA2( 'SORGBR', 'Q',
$ M, M, KU, 0, NB ) + OPCNTS( IPAR, ITYPE, IN, 1 ) +
$ OPCNTS( IPAR, ITYPE, IN, 3 )
400 CONTINUE
END IF
*
* Time SGEBRD+SORGBR+SBDSQR (singular values and N
* right singular vectors) for each pair NNB(j), LDAS(j)
*
* Use previously computed timings for SGEBRD & SBDSQR
*
IF( TIMSUB( 10 ) ) THEN
DO 430 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
CALL XLAENV( 1, NB )
CALL XLAENV( 2, 2 )
CALL XLAENV( 3, NB )
*
* Time SGEBRD+SORGBR+SBDSQR (singular values and
* N right singular vectors)
*
IC = 0
OPS = ZERO
S1 = SECOND( )
410 CONTINUE
CALL SLACPY( 'U', MINMN, N, H, LDH, VT, LDA )
CALL SORGBR( 'P', N, N, KVT, VT, LDA, TAUP, WORK,
$ LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 10 ), IINFO, M,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 410
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 420 J = 1, IC
CALL SLACPY( 'U', MINMN, N, H, LDH, VT, LDA )
420 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 10 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC ) + TIMES( IPAR, ITYPE, IN, 1 ) +
$ TIMES( IPAR, ITYPE, IN, 4 )
OPCNTS( IPAR, ITYPE, IN, 10 ) = SOPLA2( 'SORGBR', 'P',
$ N, N, KVT, 0, NB ) + OPCNTS( IPAR, ITYPE, IN, 1 ) +
$ OPCNTS( IPAR, ITYPE, IN, 4 )
430 CONTINUE
END IF
*
* Time SGEBRD+SORGBR+SBDSQR (singular values and min(M,N) left
* singular vectors and N right singular vectors) for each pair
* NNB(j), LDAS(j)
*
* Use previously computed timings for SGEBRD & SBDSQR
*
IF( TIMSUB( 11 ) ) THEN
DO 460 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
CALL XLAENV( 1, NB )
CALL XLAENV( 2, 2 )
CALL XLAENV( 3, NB )
*
* Time SGEBRD+SORGBR+SBDSQR (singular values and
* min(M,N) left singular vectors and N right singular
* vectors)
*
IC = 0
OPS = ZERO
S1 = SECOND( )
440 CONTINUE
CALL SLACPY( 'L', M, MINMN, H, LDH, U, LDA )
CALL SORGBR( 'Q', M, MINMN, KU, U, LDA, TAUQ, WORK,
$ LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 11 ), IINFO, M,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
CALL SLACPY( 'U', MINMN, N, H, LDH, VT, LDA )
CALL SORGBR( 'P', N, N, KVT, VT, LDA, TAUP, WORK,
$ LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 11 ), IINFO, M,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 440
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 450 J = 1, IC
CALL SLACPY( 'L', MINMN, MINMN, H, LDH, VT, LDA )
450 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 11 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC ) + TIMES( IPAR, ITYPE, IN, 1 ) +
$ TIMES( IPAR, ITYPE, IN, 5 )
OPCNTS( IPAR, ITYPE, IN, 11 ) = SOPLA2( 'SORGBR', 'Q',
$ M, MINMN, KU, 0, NB ) + SOPLA2( 'SORGBR', 'P', N,
$ N, KVT, 0, NB ) + OPCNTS( IPAR, ITYPE, IN, 1 ) +
$ OPCNTS( IPAR, ITYPE, IN, 5 )
460 CONTINUE
END IF
*
* Time SBDSDC (singular values and left and right singular
* vectors,assume original matrix square) for each pair
* NNB(j), LDAS(j)
*
IF( TIMSUB( 12 ) ) THEN
ESUM = SASUM( MINMN-1, E, 1 )
IF( ESUM.EQ.ZERO ) THEN
CALL SLACPY( 'Full', M, N, A, M, H, M )
CALL SGEBRD( M, N, H, M, D, E, TAUQ, TAUP, WORK,
$ LWORK, IINFO )
END IF
DO 500 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
*
* If this value of LDA has been used before, just
* use that value
*
LASTNL = 0
DO 470 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTNL = J
470 CONTINUE
*
IF( LASTNL.EQ.0 ) THEN
*
* Time SBDSDC (singular values and left and right
* singular vectors, assume original matrix square).
*
IC = 0
OPS = ZERO
S1 = SECOND( )
480 CONTINUE
CALL SCOPY( MINMN, D, 1, WORK, 1 )
CALL SCOPY( MINMN-1, E, 1, WORK( MINMN+1 ), 1 )
CALL SBDSDC( UPLO, 'I', MINMN, WORK,
$ WORK( MINMN+1 ), U, LDA, VT, LDA, DUM,
$ JDUM, WORK( 2*MINMN+1 ), IWORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 12 ), IINFO,
$ M, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 480
*
* Subtract the time used in SCOPY.
*
S1 = SECOND( )
DO 490 J = 1, IC
CALL SCOPY( MINMN, D, 1, WORK, 1 )
CALL SCOPY( MINMN-1, E, 1, WORK( MINMN+1 ), 1 )
490 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 12 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 12 ) = OPS / REAL( IC )
*
ELSE
*
TIMES( IPAR, ITYPE, IN, 12 ) = TIMES( LASTNL,
$ ITYPE, IN, 12 )
OPCNTS( IPAR, ITYPE, IN, 12 ) = OPCNTS( LASTNL,
$ ITYPE, IN, 12 )
END IF
500 CONTINUE
END IF
*
* Time SGESDD( singular values and min(M,N) left singular
* vectors and N right singular vectors when M>=N,
* singular values and M left singular vectors and min(M,N)
* right singular vectors otherwise) for each pair
* NNB(j), LDAS(j)
*
IF( TIMSUB( 13 ) ) THEN
DO 530 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
CALL XLAENV( 1, NB )
CALL XLAENV( 2, 2 )
CALL XLAENV( 3, NB )
*
* Time SGESDD(singular values and min(M,N) left singular
* vectors and N right singular vectors when M>=N;
* singular values and M left singular vectors and
* min(M,N) right singular vectors)
*
IC = 0
OPS = ZERO
S1 = SECOND( )
510 CONTINUE
CALL SLACPY( 'Full', M, N, A, M, H, LDA )
CALL SGESDD( 'S', M, N, H, LDA, WORK, U, LDA, VT, LDA,
$ WORK( MINMN+1 ), LWORK-MINMN, IWORK,
$ IINFO )
S2 = SECOND( )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 13 ), IINFO, M,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 510
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 520 J = 1, IC
CALL SLACPY( 'Full', M, N, A, M, H, LDA )
520 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 13 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 13 ) = OPS / REAL( IC )
530 CONTINUE
END IF
*
* Time SSVDC (singular values only) for each pair
* NNB(j), LDAS(j)
*
IF( TIMSUB( 14 ) ) THEN
DO 570 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has been used before, just
* use that value
*
LASTNL = 0
DO 540 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTNL = J
540 CONTINUE
*
IF( LASTNL.EQ.0 ) THEN
*
* Time SSVDC (singular values only)
*
IC = 0
OPS = ZERO
S1 = SECOND( )
550 CONTINUE
CALL SLACPY( 'Full', M, N, A, M, H, LDA )
CALL SSVDC( H, LDA, M, N, D, E, U, LDA, VT, LDA,
$ WORK, 0, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 14 ), IINFO,
$ M, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 550
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 560 J = 1, IC
CALL SLACPY( 'Full', M, N, A, M, H, LDA )
560 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 14 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 14 ) = OPS / REAL( IC )
*
ELSE
*
TIMES( IPAR, ITYPE, IN, 14 ) = TIMES( LASTNL,
$ ITYPE, IN, 14 )
OPCNTS( IPAR, ITYPE, IN, 14 ) = OPCNTS( LASTNL,
$ ITYPE, IN, 14 )
END IF
570 CONTINUE
END IF
*
* Time SSVDC (singular values and min(M,N) left singular
* vectors) for each pair NNB(j), LDAS(j)
*
IF( TIMSUB( 15 ) ) THEN
DO 610 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has been used before, just
* use that value
*
LASTNL = 0
DO 580 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTNL = J
580 CONTINUE
*
IF( LASTNL.EQ.0 ) THEN
*
* Time SSVDC (singular values and min(M,N) left
* singular vectors)
*
IC = 0
OPS = ZERO
S1 = SECOND( )
590 CONTINUE
CALL SLACPY( 'Full', M, N, A, M, H, LDA )
CALL SSVDC( H, LDA, M, N, D, E, U, LDA, VT, LDA,
$ WORK, 20, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 15 ), IINFO,
$ M, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 590
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 600 J = 1, IC
CALL SLACPY( 'Full', M, N, A, M, H, LDA )
600 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 15 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 15 ) = OPS / REAL( IC )
*
ELSE
*
TIMES( IPAR, ITYPE, IN, 15 ) = TIMES( LASTNL,
$ ITYPE, IN, 15 )
OPCNTS( IPAR, ITYPE, IN, 15 ) = OPCNTS( LASTNL,
$ ITYPE, IN, 15 )
END IF
610 CONTINUE
END IF
*
* Time SSVDC (singular values and M left singular
* vectors) for each pair NNB(j), LDAS(j)
*
IF( TIMSUB( 16 ) ) THEN
DO 650 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has been used before, just
* use that value
*
LASTNL = 0
DO 620 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTNL = J
620 CONTINUE
*
IF( LASTNL.EQ.0 ) THEN
*
* Time SSVDC (singular values and M left singular
* vectors)
*
IC = 0
OPS = ZERO
S1 = SECOND( )
630 CONTINUE
CALL SLACPY( 'Full', M, N, A, M, H, LDA )
CALL SSVDC( H, LDA, M, N, D, E, U, LDA, VT, LDA,
$ WORK, 10, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 16 ), IINFO,
$ M, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 630
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 640 J = 1, IC
CALL SLACPY( 'Full', M, N, A, M, H, LDA )
640 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 16 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 16 ) = OPS / REAL( IC )
*
ELSE
*
TIMES( IPAR, ITYPE, IN, 16 ) = TIMES( LASTNL,
$ ITYPE, IN, 16 )
OPCNTS( IPAR, ITYPE, IN, 16 ) = OPCNTS( LASTNL,
$ ITYPE, IN, 16 )
END IF
650 CONTINUE
END IF
*
* Time SSVDC (singular values and N right singular
* vectors) for each pair NNB(j), LDAS(j)
*
IF( TIMSUB( 17 ) ) THEN
DO 690 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has been used before, just
* use that value
*
LASTNL = 0
DO 660 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTNL = J
660 CONTINUE
*
IF( LASTNL.EQ.0 ) THEN
*
* Time SSVDC (singular values and N right singular
* vectors)
*
IC = 0
OPS = ZERO
S1 = SECOND( )
670 CONTINUE
CALL SLACPY( 'Full', M, N, A, M, H, LDA )
CALL SSVDC( H, LDA, M, N, D, E, U, LDA, VT, LDA,
$ WORK, 1, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 17 ), IINFO,
$ M, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 670
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 680 J = 1, IC
CALL SLACPY( 'Full', M, N, A, M, H, LDA )
680 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 17 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 17 ) = OPS / REAL( IC )
*
ELSE
*
TIMES( IPAR, ITYPE, IN, 17 ) = TIMES( LASTNL,
$ ITYPE, IN, 17 )
OPCNTS( IPAR, ITYPE, IN, 17 ) = OPCNTS( LASTNL,
$ ITYPE, IN, 17 )
END IF
690 CONTINUE
END IF
*
* Time SSVDC (singular values and min(M,N) left singular
* vectors and N right singular vectors) for each pair
* NNB(j), LDAS(j)
*
IF( TIMSUB( 18 ) ) THEN
DO 730 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has been used before, just
* use that value
*
LASTNL = 0
DO 700 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTNL = J
700 CONTINUE
*
IF( LASTNL.EQ.0 ) THEN
*
* Time SSVDC (singular values and min(M,N) left
* singular vectors and N right singular vectors)
*
IC = 0
OPS = ZERO
S1 = SECOND( )
710 CONTINUE
CALL SLACPY( 'Full', M, N, A, M, H, LDA )
CALL SSVDC( H, LDA, M, N, D, E, U, LDA, VT, LDA,
$ WORK, 21, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 18 ), IINFO,
$ M, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 710
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 720 J = 1, IC
CALL SLACPY( 'Full', M, N, A, M, H, LDA )
720 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 18 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 18 ) = OPS / REAL( IC )
*
ELSE
*
TIMES( IPAR, ITYPE, IN, 18 ) = TIMES( LASTNL,
$ ITYPE, IN, 18 )
OPCNTS( IPAR, ITYPE, IN, 18 ) = OPCNTS( LASTNL,
$ ITYPE, IN, 18 )
END IF
730 CONTINUE
END IF
*
740 CONTINUE
750 CONTINUE
*
*-----------------------------------------------------------------------
*
* Print a table of results for each timed routine.
*
DO 760 ISUB = 1, NSUBS
IF( TIMSUB( ISUB ) ) THEN
CALL SPRTBV( SUBNAM( ISUB ), NTYPES, DOTYPE, NSIZES, MM, NN,
$ INPARM( ISUB ), PNAMES, NPARMS, LDAS, NNB,
$ OPCNTS( 1, 1, 1, ISUB ), LDO1, LDO2,
$ TIMES( 1, 1, 1, ISUB ), LDT1, LDT2, WORK,
$ LLWORK, NOUT )
END IF
760 CONTINUE
*
RETURN
*
* End of STIM26
*
9998 FORMAT( ' STIM26: ', A, ' returned INFO=', I6, '.', / 9X, 'M=',
$ I6, ', N=', I6, ', ITYPE=', I6, ', IPAR=', I6, ', ',
$ ' ISEED=(', 4( I5, ',' ), I5, ')' )
*
END
SUBROUTINE STIM51( LINE, NSIZES, NN, NTYPES, DOTYPE, NPARMS, NNB,
$ NSHFTS, NEISPS, MINNBS, MINBKS, LDAS, TIMMIN,
$ NOUT, ISEED, A, B, H, T, Q, Z, W, WORK, LWORK,
$ LLWORK, TIMES, LDT1, LDT2, LDT3, OPCNTS, LDO1,
$ LDO2, LDO3, INFO )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER INFO, LDO1, LDO2, LDO3, LDT1, LDT2, LDT3,
$ LWORK, NOUT, NPARMS, NSIZES, NTYPES
REAL TIMMIN
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * ), LLWORK( * )
INTEGER ISEED( * ), LDAS( * ), MINBKS( * ),
$ MINNBS( * ), NEISPS( * ), NN( * ), NNB( * ),
$ NSHFTS( * )
REAL A( * ), B( * ), H( * ),
$ OPCNTS( LDO1, LDO2, LDO3, * ), Q( * ), T( * ),
$ TIMES( LDT1, LDT2, LDT3, * ), W( * ),
$ WORK( * ), Z( * )
* ..
*
* Purpose
* =======
*
* STIM51 times the LAPACK routines for the real non-symmetric
* generalized eigenvalue problem A x = w B x.
*
* For each N value in NN(1:NSIZES) and .TRUE. value in
* DOTYPE(1:NTYPES), a pair of matrices will be generated and used to
* test the selected routines. Thus, NSIZES*(number of .TRUE. values
* in DOTYPE) matrices will be generated.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line which requested this routine. This line may
* contain a subroutine name, such as SGGHRD, indicating that
* only routine SGGHRD will be timed, or it may contain a
* generic name, such as SHG. In this case, the rest of the
* line is scanned for the first 18 non-blank characters,
* corresponding to the eighteen combinations of subroutine and
* options:
* LAPACK: Table Heading:
* 1: SGGHRD(no Q, no Z) (+SGEQRF, etc.) 'SGGHRD(N)'
* 2: SGGHRD(Q only) (+SGEQRF, etc.) 'SGGHRD(Q)'
* 3: SGGHRD(Z only) (+SGEQRF, etc.) 'SGGHRD(Z)'
* 4: SGGHRD(Q and Z) (+SGEQRF, etc.) 'SGGHRD(Q,Z)'
* 5: SHGEQZ(Eigenvalues only) 'SHGEQZ(E)'
* 6: SHGEQZ(Schur form only) 'SHGEQZ(S)'
* 7: SHGEQZ(Schur form and Q) 'SHGEQZ(Q)'
* 8: SHGEQZ(Schur form and Z) 'SHGEQZ(Z)'
* 9: SHGEQZ(Schur form, Q and Z) 'SHGEQZ(Q,Z)'
* 10: STGEVC(SIDE='L', HOWMNY='A') 'STGEVC(L,A)'
* 11: STGEVC(SIDE='L', HOWMNY='B') 'STGEVC(L,B)'
* 12: STGEVC(SIDE='R', HOWMNY='A') 'STGEVC(R,A)'
* 13: STGEVC(SIDE='R', HOWMNY='B') 'STGEVC(R,B)'
* EISPACK: Compare w/: Table Heading:
* 14: QZHES w/ matz=.false. 1 'QZHES(F)'
* 15: QZHES w/ matz=.true. 3 'QZHES(T)'
* 16: QZIT and QZVAL w/ matz=.false. 5 'QZIT(F)'
* 17: QZIT and QZVAL w/ matz=.true. 8 'QZIT(T)'
* 18: QZVEC 13 'QZVEC'
* If a character is 'T' or 't', the corresponding routine in
* this path is timed. If the entire line is blank, all the
* routines in the path are timed.
*
* Note that since QZHES does more than SGGHRD, the
* "SGGHRD" timing also includes the time for the calls
* to SGEQRF, SORMQR, and (if Q is computed) SORGQR
* which are necessary to get the same functionality
* as QZHES.
*
* NSIZES (input) INTEGER
* The number of values of N contained in the vector NN.
*
* NN (input) INTEGER array, dimension (NSIZES)
* The values of the matrix size N to be tested. For each
* N value in the array NN, and each .TRUE. value in DOTYPE,
* a matrix A will be generated and used to test the routines.
*
* NTYPES (input) INTEGER
* The number of types in DOTYPE. Only the first MAXTYP
* elements will be examined. Exception: if NSIZES=1 and
* NTYPES=MAXTYP+1, and DOTYPE=MAXTYP*f,t, then the input
* value of A will be used.
*
* DOTYPE (input) LOGICAL
* If DOTYPE(j) is .TRUE., then a pair of matrices (A,B) of
* type j will be generated. A and B have the form U T1 V
* and U T2 V , resp., where U and V are orthogonal, T1 is
* block upper triangular (with 1x1 and 2x2 diagonal blocks),
* and T2 is upper triangular. T2 has random O(1) entries in
* the strict upper triangle and ( 0, 1, 0, 1, 1, ..., 1, 0 )
* on the diagonal, while T1 has random O(1) entries in the
* strict (block) upper triangle, its block diagonal will have
* the singular values:
* (j=1) 0, 0, 1, 1, ULP,..., ULP, 0.
* (j=2) 0, 0, 1, 1, 1-d, 1-2*d, ..., 1-(N-5)*d=ULP, 0.
*
* 2 N-5
* (j=3) 0, 0, 1, 1, a, a , ..., a =ULP, 0.
* (j=4) 0, 0, 1, r1, r2, ..., r(N-4), 0, where r1, etc.
* are random numbers in (ULP,1).
*
* NPARMS (input) INTEGER
* The number of values in each of the arrays NNB, NSHFTS,
* NEISPS, and LDAS. For each matrix A generated according to
* NN and DOTYPE, tests will be run with (NB,NSHIFT,NEISP,LDA)=
* (NNB(1), NSHFTS(1), NEISPS(1), LDAS(1)),...,
* (NNB(NPARMS), NSHFTS(NPARMS), NEISPS(NPARMS), LDAS(NPARMS))
*
* NNB (input) INTEGER array, dimension (NPARMS)
* The values of the blocksize ("NB") to be tested. They must
* be at least 1. Currently, this is only used by SGEQRF,
* etc., in the timing of SGGHRD.
*
* NSHFTS (input) INTEGER array, dimension (NPARMS)
* The values of the number of shifts ("NSHIFT") to be tested.
* (Currently not used.)
*
* NEISPS (input) INTEGER array, dimension (NPARMS)
* The values of "NEISP", the size of largest submatrix to be
* processed by SLAEQZ (EISPACK method), to be tested.
* (Currently not used.)
*
* MINNBS (input) INTEGER array, dimension (NPARMS)
* The values of "MINNB", the minimum size of a product of
* transformations which may be applied as a blocked
* transformation, to be tested. (Currently not used.)
*
* MINBKS (input) INTEGER array, dimension (NPARMS)
* The values of "MINBK", the minimum number of rows/columns
* to be updated with a blocked transformation, to be tested.
* (Currently not used.)
*
* LDAS (input) INTEGER array, dimension (NPARMS)
* The values of LDA, the leading dimension of all matrices,
* to be tested.
*
* TIMMIN (input) REAL
* The minimum time a subroutine will be timed.
*
* NOUT (input) INTEGER
* If NOUT > 0 then NOUT specifies the unit number
* on which the output will be printed. If NOUT <= 0, no
* output is printed.
*
* ISEED (input/output) INTEGER array, dimension (4)
* The random seed used by the random number generator, used
* by the test matrix generator. It is used and updated on
* each call to STIM51
*
* A (workspace) REAL array, dimension
* (max(NN)*max(LDAS))
* (a) During the testing of SGGHRD, "A", the original
* left-hand-side matrix to be tested.
* (b) Later, "S", the Schur form of the original "A" matrix.
*
* B (workspace) REAL array, dimension
* (max(NN)*max(LDAS))
* (a) During the testing of SGGHRD, "B", the original
* right-hand-side matrix to be tested.
* (b) Later, "P", the Schur form of the original "B" matrix.
*
* H (workspace) REAL array, dimension
* (max(NN)*max(LDAS))
* (a) During the testing of SGGHRD and SHGEQZ, "H", the
* Hessenberg form of the original "A" matrix.
* (b) During the testing of STGEVC, "L", the matrix of left
* eigenvectors.
*
* T (workspace) REAL array, dimension
* (max(NN)*max(LDAS))
* (a) During the testing of SGGHRD and SHGEQZ, "T", the
* triangular form of the original "B" matrix.
* (b) During the testing of STGEVC, "R", the matrix of right
* eigenvectors.
*
* Q (workspace) REAL array, dimension
* (max(NN)*max(LDAS))
* The orthogonal matrix on the left generated by SGGHRD. If
* SHGEQZ computes only Q or Z, then that matrix is stored here.
* If both Q and Z are computed, the Q matrix goes here.
*
* Z (workspace) REAL array, dimension
* (max(NN)*max(LDAS))
* The orthogonal matrix on the right generated by SGGHRD.
* If SHGEQZ computes both Q and Z, the Z matrix is stored here.
* Also used as scratch space for timing the SLACPY calls.
*
* W (workspace) REAL array, dimension (3*max(LDAS))
* Treated as an LDA x 3 matrix whose 1st and 2nd columns hold
* ALPHAR and ALPHAI, the real and imaginary parts of the
* diagonal entries of "S" that would result from reducing "S"
* and "P" simultaneously to triangular form), and whose 3rd
* column holds BETA, the diagonal entries of "P" that would so
* result.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* Number of elements in WORK. It must be at least
* (a) 6*max(NN)
* (b) NSIZES*NTYPES*NPARMS
*
* LLWORK (workspace) LOGICAL array, dimension (max( max(NN), NPARMS ))
*
* TIMES (output) REAL array, dimension
* (LDT1,LDT2,LDT3,NSUBS)
* TIMES(i,j,k,l) will be set to the run time (in seconds) for
* subroutine l, with N=NN(k), matrix type j, and LDA=LDAS(i),
* NEISP=NEISPS(i), NBLOCK=NNB(i), NSHIFT=NSHFTS(i),
* MINNB=MINNBS(i), and MINBLK=MINBKS(i).
*
* LDT1 (input) INTEGER
* The first dimension of TIMES. LDT1 >= min( 1, NPARMS ).
*
* LDT2 (input) INTEGER
* The second dimension of TIMES. LDT2 >= min( 1, NTYPES ).
*
* LDT3 (input) INTEGER
* The third dimension of TIMES. LDT3 >= min( 1, NSIZES ).
*
* OPCNTS (output) REAL array, dimension
* (LDO1,LDO2,LDO3,NSUBS)
* OPCNTS(i,j,k,l) will be set to the number of floating-point
* operations executed by subroutine l, with N=NN(k), matrix
* type j, and LDA=LDAS(i), NEISP=NEISPS(i), NBLOCK=NNB(i),
* NSHIFT=NSHFTS(i), MINNB=MINNBS(i), and MINBLK=MINBKS(i).
*
* LDO1 (input) INTEGER
* The first dimension of OPCNTS. LDO1 >= min( 1, NPARMS ).
*
* LDO2 (input) INTEGER
* The second dimension of OPCNTS. LDO2 >= min( 1, NTYPES ).
*
* LDO3 (input) INTEGER
* The third dimension of OPCNTS. LDO3 >= min( 1, NSIZES ).
*
* INFO (output) INTEGER
* Error flag. It will be set to zero if no error occurred.
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXTYP, NSUBS
PARAMETER ( MAXTYP = 4, NSUBS = 18 )
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL RUNEQ, RUNES, RUNHES, RUNHRD, RUNQZ
INTEGER IC, IINFO, IN, IPAR, ISUB, ITEMP, ITYPE, J, J1,
$ J2, J3, J4, JC, JR, LASTL, LDA, LDAMIN, LDH,
$ LDQ, LDS, LDW, MINBLK, MINNB, MTYPES, N, N1,
$ NB, NBSMAX, NEISP, NMAX, NSHIFT
REAL S1, S2, TIME, ULP, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER*6 PNAMES( 6 )
CHARACTER*11 SUBNAM( NSUBS )
INTEGER INPARM( NSUBS ), IOLDSD( 4 ), KATYPE( MAXTYP )
* ..
* .. External Functions ..
REAL SECOND, SLAMCH, SLARND, SOPLA
EXTERNAL SECOND, SLAMCH, SLARND, SOPLA
* ..
* .. External Subroutines ..
EXTERNAL ATIMIN, QZHES, QZIT, QZVAL, QZVEC, SHGEQZ,
$ SLACPY, SLAQZH, SLARFG, SLATM4, SLASET, SORM2R,
$ SPRTBG, STGEVC, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL, SIGN
* ..
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
* .. Data statements ..
DATA SUBNAM / 'SGGHRD(N)', 'SGGHRD(Q)', 'SGGHRD(Z)',
$ 'SGGHRD(Q,Z)', 'SHGEQZ(E)', 'SHGEQZ(S)',
$ 'SHGEQZ(Q)', 'SHGEQZ(Z)', 'SHGEQZ(Q,Z)',
$ 'STGEVC(L,A)', 'STGEVC(L,B)', 'STGEVC(R,A)',
$ 'STGEVC(R,B)', 'QZHES(F)', 'QZHES(T)',
$ 'QZIT(F)', 'QZIT(T)', 'QZVEC' /
DATA INPARM / 4*2, 5*1, 4*1, 5*1 /
DATA PNAMES / ' LDA', ' NB', ' NS',
$ ' NEISP', ' MINNB', 'MINBLK' /
DATA KATYPE / 5, 8, 7, 9 /
* ..
* .. Executable Statements ..
*
* Quick Return
*
INFO = 0
IF( NSIZES.LE.0 .OR. NTYPES.LE.0 .OR. NPARMS.LE.0 )
$ RETURN
*
* Extract the timing request from the input line.
*
CALL ATIMIN( 'SHG', LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ RETURN
*
* Compute Maximum Values
*
NMAX = 0
DO 10 J1 = 1, NSIZES
NMAX = MAX( NMAX, NN( J1 ) )
10 CONTINUE
*
LDAMIN = 2*MAX( 1, NMAX )
NBSMAX = 0
DO 20 J1 = 1, NPARMS
LDAMIN = MIN( LDAMIN, LDAS( J1 ) )
NBSMAX = MAX( NBSMAX, NNB( J1 )+NSHFTS( J1 ) )
20 CONTINUE
*
* Check that N <= LDA for the input values.
*
IF( NMAX.GT.LDAMIN ) THEN
INFO = -12
WRITE( NOUT, FMT = 9999 )LINE( 1: 6 )
9999 FORMAT( 1X, A, ' timing run not attempted -- N > LDA', / )
RETURN
END IF
*
* Check LWORK
*
IF( LWORK.LT.MAX( ( NBSMAX+1 )*( 2*NBSMAX+NMAX+1 ), 6*NMAX,
$ NSIZES*NTYPES*NPARMS ) ) THEN
INFO = -24
WRITE( NOUT, FMT = 9998 )LINE( 1: 6 )
9998 FORMAT( 1X, A, ' timing run not attempted -- LWORK too small.',
$ / )
RETURN
END IF
*
* Check to see whether SGGHRD or SHGEQZ must be run.
* RUNHRD -- if SGGHRD must be run.
* RUNES -- if SHGEQZ must be run to get Schur form.
* RUNEQ -- if SHGEQZ must be run to get Schur form and Q.
*
RUNHRD = .FALSE.
RUNES = .FALSE.
RUNEQ = .FALSE.
*
IF( TIMSUB( 10 ) .OR. TIMSUB( 12 ) )
$ RUNES = .TRUE.
IF( TIMSUB( 11 ) .OR. TIMSUB( 13 ) )
$ RUNEQ = .TRUE.
IF( TIMSUB( 5 ) .OR. TIMSUB( 6 ) .OR. TIMSUB( 7 ) .OR.
$ TIMSUB( 8 ) .OR. TIMSUB( 9 ) .OR. RUNES .OR. RUNEQ )
$ RUNHRD = .TRUE.
*
IF( TIMSUB( 6 ) .OR. TIMSUB( 7 ) .OR. TIMSUB( 8 ) .OR.
$ TIMSUB( 9 ) .OR. RUNEQ )RUNES = .FALSE.
IF( TIMSUB( 7 ) .OR. TIMSUB( 8 ) .OR. TIMSUB( 9 ) )
$ RUNEQ = .FALSE.
IF( TIMSUB( 1 ) .OR. TIMSUB( 2 ) .OR. TIMSUB( 3 ) .OR.
$ TIMSUB( 4 ) )RUNHRD = .FALSE.
*
* Check to see whether QZHES or QZIT must be run.
*
* RUNHES -- if QZHES must be run.
* RUNQZ -- if QZIT and QZVAL must be run (w/ MATZ=.TRUE.).
*
RUNHES = .FALSE.
RUNQZ = .FALSE.
*
IF( TIMSUB( 18 ) )
$ RUNQZ = .TRUE.
IF( TIMSUB( 16 ) .OR. TIMSUB( 17 ) .OR. RUNQZ )
$ RUNHES = .TRUE.
IF( TIMSUB( 17 ) )
$ RUNQZ = .FALSE.
IF( TIMSUB( 14 ) .OR. TIMSUB( 15 ) )
$ RUNHES = .FALSE.
*
* Various Constants
*
ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
*
* Zero out OPCNTS, TIMES
*
DO 60 J4 = 1, NSUBS
DO 50 J3 = 1, NSIZES
DO 40 J2 = 1, NTYPES
DO 30 J1 = 1, NPARMS
OPCNTS( J1, J2, J3, J4 ) = ZERO
TIMES( J1, J2, J3, J4 ) = ZERO
30 CONTINUE
40 CONTINUE
50 CONTINUE
60 CONTINUE
*
* Do for each value of N:
*
DO 930 IN = 1, NSIZES
*
N = NN( IN )
N1 = MAX( 1, N )
*
* Do for each .TRUE. value in DOTYPE:
*
MTYPES = MIN( MAXTYP, NTYPES )
IF( NTYPES.EQ.MAXTYP+1 .AND. NSIZES.EQ.1 )
$ MTYPES = NTYPES
DO 920 ITYPE = 1, MTYPES
IF( .NOT.DOTYPE( ITYPE ) )
$ GO TO 920
*
* Save random number seed for error messages
*
DO 70 J = 1, 4
IOLDSD( J ) = ISEED( J )
70 CONTINUE
*
* Time the LAPACK Routines
*
* Generate A and B
*
IF( ITYPE.LE.MAXTYP ) THEN
*
* Generate A (w/o rotation)
*
CALL SLATM4( KATYPE( ITYPE ), N, 3, 1, 2, ONE, ULP, ONE,
$ 2, ISEED, A, N1 )
IF( 3.LE.N )
$ A( 3+2*N1 ) = ONE
*
* Generate B (w/o rotation)
*
CALL SLATM4( 8, N, 3, 1, 0, ONE, ONE, ONE, 2, ISEED, B,
$ N1 )
IF( 2.LE.N )
$ B( 2+N1 ) = ONE
*
IF( N.GT.0 ) THEN
*
* Include rotations
*
* Generate U, V as Householder transformations times
* a diagonal matrix.
*
DO 90 JC = 1, N - 1
IC = ( JC-1 )*N1
DO 80 JR = JC, N
Q( JR+IC ) = SLARND( 3, ISEED )
Z( JR+IC ) = SLARND( 3, ISEED )
80 CONTINUE
CALL SLARFG( N+1-JC, Q( JC+IC ), Q( JC+1+IC ), 1,
$ WORK( JC ) )
WORK( 2*N+JC ) = SIGN( ONE, Q( JC+IC ) )
Q( JC+IC ) = ONE
CALL SLARFG( N+1-JC, Z( JC+IC ), Z( JC+1+IC ), 1,
$ WORK( N+JC ) )
WORK( 3*N+JC ) = SIGN( ONE, Z( JC+IC ) )
Z( JC+IC ) = ONE
90 CONTINUE
IC = ( N-1 )*N1
Q( N+IC ) = ONE
WORK( N ) = ZERO
WORK( 3*N ) = SIGN( ONE, SLARND( 2, ISEED ) )
Z( N+IC ) = ONE
WORK( 2*N ) = ZERO
WORK( 4*N ) = SIGN( ONE, SLARND( 2, ISEED ) )
*
* Apply the diagonal matrices
*
DO 110 JC = 1, N
DO 100 JR = 1, N
A( JR+IC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
$ A( JR+IC )
B( JR+IC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
$ B( JR+IC )
100 CONTINUE
110 CONTINUE
CALL SORM2R( 'L', 'N', N, N, N-1, Q, N1, WORK, A, N1,
$ WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 120
CALL SORM2R( 'R', 'T', N, N, N-1, Z, N1, WORK( N+1 ),
$ A, N1, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 120
CALL SORM2R( 'L', 'N', N, N, N-1, Q, N1, WORK, B, N1,
$ WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 120
CALL SORM2R( 'R', 'T', N, N, N-1, Z, N1, WORK( N+1 ),
$ B, N1, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 120
END IF
120 CONTINUE
END IF
*
* . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
*
* Time SGGHRD
*
* Time SGEQRF+SGGHRD('N','N',...) for each pair
* (LDAS(j),NNB(j))
*
IF( TIMSUB( 1 ) ) THEN
DO 160 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = NNB( IPAR )
IF( LDA.LT.N1 ) THEN
TIMES( IPAR, ITYPE, IN, 1 ) = ZERO
OPCNTS( IPAR, ITYPE, IN, 1 ) = ZERO
GO TO 160
END IF
*
* If this value of (NB,LDA) has occurred before,
* just use that value.
*
LASTL = 0
DO 130 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) .AND. NB.EQ.NNB( J ) )
$ LASTL = J
130 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time SGGHRD, computing neither Q nor Z
* (Actually, time SGEQRF + SORMQR + SGGHRD.)
*
CALL XLAENV( 1, NB )
IC = 0
OPS = ZERO
S1 = SECOND( )
140 CONTINUE
CALL SLACPY( 'Full', N, N, A, N1, H, LDA )
CALL SLACPY( 'Full', N, N, B, N1, T, LDA )
CALL SLAQZH( .FALSE., .FALSE., N, 1, N, H, LDA, T,
$ LDA, Q, LDA, Z, LDA, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 1 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
*
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 140
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 150 J = 1, IC
CALL SLACPY( 'Full', N, N, A, N1, Z, LDA )
CALL SLACPY( 'Full', N, N, B, N1, Z, LDA )
150 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 1 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 1 ) = OPS / REAL( IC ) +
$ SOPLA( 'SGEQRF', N, N, 0, 0, NB ) +
$ SOPLA( 'SORMQR', N, N, 0, 0, NB )
LDH = LDA
ELSE
OPCNTS( IPAR, ITYPE, IN, 1 ) = OPCNTS( LASTL,
$ ITYPE, IN, 1 )
TIMES( IPAR, ITYPE, IN, 1 ) = TIMES( LASTL, ITYPE,
$ IN, 1 )
END IF
160 CONTINUE
ELSE IF( RUNHRD ) THEN
CALL SLACPY( 'Full', N, N, A, N1, H, N1 )
CALL SLACPY( 'Full', N, N, B, N1, T, N1 )
CALL SLAQZH( .FALSE., .FALSE., N, 1, N, H, N1, T, N1, Q,
$ N1, Z, N1, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 1 ), IINFO, N,
$ ITYPE, 0, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
LDH = N
END IF
*
* Time SGGHRD('I','N',...) for each pair (LDAS(j),NNB(j))
*
IF( TIMSUB( 2 ) ) THEN
DO 200 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = NNB( IPAR )
IF( LDA.LT.N1 ) THEN
TIMES( IPAR, ITYPE, IN, 2 ) = ZERO
OPCNTS( IPAR, ITYPE, IN, 2 ) = ZERO
GO TO 200
END IF
*
* If this value of (NB,LDA) has occurred before,
* just use that value.
*
LASTL = 0
DO 170 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) .AND. NB.EQ.NNB( J ) )
$ LASTL = J
170 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time SGGHRD, computing Q but not Z
* (Actually, SGEQRF + SORMQR + SORGQR + SGGHRD.)
*
CALL XLAENV( 1, NB )
IC = 0
OPS = ZERO
S1 = SECOND( )
180 CONTINUE
CALL SLACPY( 'Full', N, N, A, N1, H, LDA )
CALL SLACPY( 'Full', N, N, B, N1, T, LDA )
CALL SLAQZH( .TRUE., .FALSE., N, 1, N, H, LDA, T,
$ LDA, Q, LDA, Z, LDA, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 2 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
*
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 180
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 190 J = 1, IC
CALL SLACPY( 'Full', N, N, A, N1, Z, LDA )
CALL SLACPY( 'Full', N, N, B, N1, Z, LDA )
190 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 2 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 2 ) = OPS / REAL( IC ) +
$ SOPLA( 'SGEQRF', N, N, 0, 0, NB ) +
$ SOPLA( 'SORMQR', N, N, 0, 0, NB ) +
$ SOPLA( 'SORGQR', N, N, 0, 0, NB )
LDH = LDA
ELSE
OPCNTS( IPAR, ITYPE, IN, 2 ) = OPCNTS( LASTL,
$ ITYPE, IN, 2 )
TIMES( IPAR, ITYPE, IN, 2 ) = TIMES( LASTL, ITYPE,
$ IN, 2 )
END IF
200 CONTINUE
END IF
*
* Time SGGHRD('N','I',...) for each pair (LDAS(j),NNB(j))
*
IF( TIMSUB( 3 ) ) THEN
DO 240 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = NNB( IPAR )
IF( LDA.LT.N1 ) THEN
TIMES( IPAR, ITYPE, IN, 3 ) = ZERO
OPCNTS( IPAR, ITYPE, IN, 3 ) = ZERO
GO TO 240
END IF
*
* If this value of (NB,LDA) has occurred before,
* just use that value.
*
LASTL = 0
DO 210 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) .AND. NB.EQ.NNB( J ) )
$ LASTL = J
210 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time SGGHRD, computing Z but not Q
* (Actually, SGEQRF + SORMQR + SGGHRD.)
*
CALL XLAENV( 1, NB )
IC = 0
OPS = ZERO
S1 = SECOND( )
220 CONTINUE
CALL SLACPY( 'Full', N, N, A, N1, H, LDA )
CALL SLACPY( 'Full', N, N, B, N1, T, LDA )
CALL SLAQZH( .FALSE., .TRUE., N, 1, N, H, LDA, T,
$ LDA, Q, LDA, Z, LDA, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 3 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
*
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 220
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 230 J = 1, IC
CALL SLACPY( 'Full', N, N, A, N1, Z, LDA )
CALL SLACPY( 'Full', N, N, B, N1, Z, LDA )
230 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 3 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 3 ) = OPS / REAL( IC ) +
$ SOPLA( 'SGEQRF', N, N, 0, 0, NB ) +
$ SOPLA( 'SORMQR', N, N, 0, 0, NB )
LDH = LDA
ELSE
OPCNTS( IPAR, ITYPE, IN, 3 ) = OPCNTS( LASTL,
$ ITYPE, IN, 3 )
TIMES( IPAR, ITYPE, IN, 3 ) = TIMES( LASTL, ITYPE,
$ IN, 3 )
END IF
240 CONTINUE
END IF
*
* Time SGGHRD('I','I',...) for each pair (LDAS(j),NNB(j))
*
IF( TIMSUB( 4 ) ) THEN
DO 280 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = NNB( IPAR )
IF( LDA.LT.N1 ) THEN
TIMES( IPAR, ITYPE, IN, 4 ) = ZERO
OPCNTS( IPAR, ITYPE, IN, 4 ) = ZERO
GO TO 280
END IF
*
* If this value of (NB,LDA) has occurred before,
* just use that value.
*
LASTL = 0
DO 250 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) .AND. NB.EQ.NNB( J ) )
$ LASTL = J
250 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time SGGHRD, computing Q and Z
* (Actually, SGEQRF + SORMQR + SORGQR + SGGHRD.)
*
CALL XLAENV( 1, NB )
IC = 0
OPS = ZERO
S1 = SECOND( )
260 CONTINUE
CALL SLACPY( 'Full', N, N, A, N1, H, LDA )
CALL SLACPY( 'Full', N, N, B, N1, T, LDA )
CALL SLAQZH( .TRUE., .TRUE., N, 1, N, H, LDA, T,
$ LDA, Q, LDA, Z, LDA, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 4 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
*
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 260
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 270 J = 1, IC
CALL SLACPY( 'Full', N, N, A, N1, Z, LDA )
CALL SLACPY( 'Full', N, N, B, N1, Z, LDA )
270 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 4 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 4 ) = OPS / REAL( IC ) +
$ SOPLA( 'SGEQRF', N, N, 0, 0, NB ) +
$ SOPLA( 'SORMQR', N, N, 0, 0, NB ) +
$ SOPLA( 'SORGQR', N, N, 0, 0, NB )
LDH = LDA
ELSE
OPCNTS( IPAR, ITYPE, IN, 4 ) = OPCNTS( LASTL,
$ ITYPE, IN, 4 )
TIMES( IPAR, ITYPE, IN, 4 ) = TIMES( LASTL, ITYPE,
$ IN, 4 )
END IF
280 CONTINUE
END IF
*
* . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
*
* Time SHGEQZ
*
* Time SHGEQZ with JOB='E' for each value of LDAS(j)
*
IF( TIMSUB( 5 ) ) THEN
DO 320 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
IF( LDA.LT.N1 ) THEN
TIMES( IPAR, ITYPE, IN, 5 ) = ZERO
OPCNTS( IPAR, ITYPE, IN, 5 ) = ZERO
GO TO 320
END IF
*
* If this value of LDA has occurred before,
* just use that value.
*
LASTL = 0
DO 290 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
290 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time SHGEQZ with JOB='E'
*
IC = 0
OPS = ZERO
S1 = SECOND( )
300 CONTINUE
CALL SLACPY( 'Full', N, N, H, LDH, A, LDA )
CALL SLACPY( 'Full', N, N, T, LDH, B, LDA )
CALL SHGEQZ( 'E', 'N', 'N', N, 1, N, A, LDA, B,
$ LDA, W, W( LDA+1 ), W( 2*LDA+1 ), Q,
$ LDA, Z, LDA, WORK, LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 5 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 300
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 310 J = 1, IC
CALL SLACPY( 'Full', N, N, H, LDH, Z, LDA )
CALL SLACPY( 'Full', N, N, T, LDH, Z, LDA )
310 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 5 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 5 ) = OPS / REAL( IC )
LDS = 0
LDQ = 0
ELSE
OPCNTS( IPAR, ITYPE, IN, 5 ) = OPCNTS( LASTL,
$ ITYPE, IN, 5 )
TIMES( IPAR, ITYPE, IN, 5 ) = TIMES( LASTL, ITYPE,
$ IN, 5 )
END IF
320 CONTINUE
END IF
*
* Time SHGEQZ with JOB='S', COMPQ=COMPZ='N' for each value
* of LDAS(j)
*
IF( TIMSUB( 6 ) ) THEN
DO 360 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
IF( LDA.LT.N1 ) THEN
TIMES( IPAR, ITYPE, IN, 6 ) = ZERO
OPCNTS( IPAR, ITYPE, IN, 6 ) = ZERO
GO TO 360
END IF
*
* If this value of LDA has occurred before,
* just use that value.
*
LASTL = 0
DO 330 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
330 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time SHGEQZ with JOB='S', COMPQ=COMPZ='N'
*
IC = 0
OPS = ZERO
S1 = SECOND( )
340 CONTINUE
CALL SLACPY( 'Full', N, N, H, LDH, A, LDA )
CALL SLACPY( 'Full', N, N, T, LDH, B, LDA )
CALL SHGEQZ( 'S', 'N', 'N', N, 1, N, A, LDA, B,
$ LDA, W, W( LDA+1 ), W( 2*LDA+1 ), Q,
$ LDA, Z, LDA, WORK, LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 6 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 340
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 350 J = 1, IC
CALL SLACPY( 'Full', N, N, H, LDH, Z, LDA )
CALL SLACPY( 'Full', N, N, T, LDH, Z, LDA )
350 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 6 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 6 ) = OPS / REAL( IC )
LDS = LDA
LDQ = 0
ELSE
OPCNTS( IPAR, ITYPE, IN, 6 ) = OPCNTS( LASTL,
$ ITYPE, IN, 6 )
TIMES( IPAR, ITYPE, IN, 6 ) = TIMES( LASTL, ITYPE,
$ IN, 6 )
END IF
360 CONTINUE
ELSE IF( RUNES ) THEN
CALL SLACPY( 'Full', N, N, H, LDH, A, N1 )
CALL SLACPY( 'Full', N, N, T, LDH, B, N1 )
CALL SHGEQZ( 'S', 'N', 'N', N, 1, N, A, N1, B, N1, W,
$ W( N1+1 ), W( 2*N1+1 ), Q, N1, Z, N1, WORK,
$ LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 6 ), IINFO, N,
$ ITYPE, 0, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
LDS = N1
LDQ = 0
END IF
*
* Time SHGEQZ with JOB='S', COMPQ='I', COMPZ='N' for each
* value of LDAS(j)
*
IF( TIMSUB( 7 ) ) THEN
DO 400 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
IF( LDA.LT.N1 ) THEN
TIMES( IPAR, ITYPE, IN, 7 ) = ZERO
OPCNTS( IPAR, ITYPE, IN, 7 ) = ZERO
GO TO 400
END IF
*
* If this value of LDA has occurred before,
* just use that value.
*
LASTL = 0
DO 370 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
370 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time SHGEQZ with JOB='S', COMPQ='I', COMPZ='N'
*
IC = 0
OPS = ZERO
S1 = SECOND( )
380 CONTINUE
CALL SLACPY( 'Full', N, N, H, LDH, A, LDA )
CALL SLACPY( 'Full', N, N, T, LDH, B, LDA )
CALL SHGEQZ( 'S', 'I', 'N', N, 1, N, A, LDA, B,
$ LDA, W, W( LDA+1 ), W( 2*LDA+1 ), Q,
$ LDA, Z, LDA, WORK, LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 7 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 380
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 390 J = 1, IC
CALL SLACPY( 'Full', N, N, H, LDH, Z, LDA )
CALL SLACPY( 'Full', N, N, T, LDH, Z, LDA )
390 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 7 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 7 ) = OPS / REAL( IC )
LDS = LDA
LDQ = LDA
ELSE
OPCNTS( IPAR, ITYPE, IN, 7 ) = OPCNTS( LASTL,
$ ITYPE, IN, 7 )
TIMES( IPAR, ITYPE, IN, 7 ) = TIMES( LASTL, ITYPE,
$ IN, 7 )
END IF
400 CONTINUE
ELSE IF( RUNEQ ) THEN
CALL SLACPY( 'Full', N, N, H, LDH, A, N1 )
CALL SLACPY( 'Full', N, N, T, LDH, B, N1 )
CALL SHGEQZ( 'S', 'I', 'N', N, 1, N, A, N1, B, N1, W,
$ W( N1+1 ), W( 2*N1+1 ), Q, N1, Z, N1, WORK,
$ LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 7 ), IINFO, N,
$ ITYPE, 0, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
LDS = N1
LDQ = N1
END IF
*
* Time SHGEQZ with JOB='S', COMPQ='N', COMPZ='I' for each
* value of LDAS(j)
*
IF( TIMSUB( 8 ) ) THEN
DO 440 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
IF( LDA.LT.N1 ) THEN
TIMES( IPAR, ITYPE, IN, 8 ) = ZERO
OPCNTS( IPAR, ITYPE, IN, 8 ) = ZERO
GO TO 440
END IF
*
* If this value of LDA has occurred before,
* just use that value.
*
LASTL = 0
DO 410 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
410 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
NB = MIN( N, NNB( IPAR ) )
NSHIFT = NSHFTS( IPAR )
NEISP = NEISPS( IPAR )
MINNB = MINNBS( IPAR )
MINBLK = MINBKS( IPAR )
*
* Time SHGEQZ with JOB='S', COMPQ='N', COMPZ='I'
* (Note that the "Z" matrix is stored in the array Q)
*
IC = 0
OPS = ZERO
S1 = SECOND( )
420 CONTINUE
CALL SLACPY( 'Full', N, N, H, LDH, A, LDA )
CALL SLACPY( 'Full', N, N, T, LDH, B, LDA )
CALL SHGEQZ( 'S', 'N', 'I', N, 1, N, A, LDA, B,
$ LDA, W, W( LDA+1 ), W( 2*LDA+1 ), Z,
$ LDA, Q, LDA, WORK, LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 8 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 420
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 430 J = 1, IC
CALL SLACPY( 'Full', N, N, H, LDH, Z, LDA )
CALL SLACPY( 'Full', N, N, T, LDH, Z, LDA )
430 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 8 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 8 ) = OPS / REAL( IC )
LDS = LDA
LDQ = LDA
ELSE
OPCNTS( IPAR, ITYPE, IN, 8 ) = OPCNTS( LASTL,
$ ITYPE, IN, 8 )
TIMES( IPAR, ITYPE, IN, 8 ) = TIMES( LASTL, ITYPE,
$ IN, 8 )
END IF
440 CONTINUE
END IF
*
* Time SHGEQZ with JOB='S', COMPQ='I', COMPZ='I' for each
* value of LDAS(j)
*
IF( TIMSUB( 9 ) ) THEN
DO 480 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
IF( LDA.LT.N1 ) THEN
TIMES( IPAR, ITYPE, IN, 9 ) = ZERO
OPCNTS( IPAR, ITYPE, IN, 9 ) = ZERO
GO TO 480
END IF
*
* If this value of LDA has occurred before,
* just use that value.
*
LASTL = 0
DO 450 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
450 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time SHGEQZ with JOB='S', COMPQ='I', COMPZ='I'
*
IC = 0
OPS = ZERO
S1 = SECOND( )
460 CONTINUE
CALL SLACPY( 'Full', N, N, H, LDH, A, LDA )
CALL SLACPY( 'Full', N, N, T, LDH, B, LDA )
CALL SHGEQZ( 'S', 'I', 'I', N, 1, N, A, LDA, B,
$ LDA, W, W( LDA+1 ), W( 2*LDA+1 ), Q,
$ LDA, Z, LDA, WORK, LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 9 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 460
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 470 J = 1, IC
CALL SLACPY( 'Full', N, N, H, LDH, Z, LDA )
CALL SLACPY( 'Full', N, N, T, LDH, Z, LDA )
470 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 9 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 9 ) = OPS / REAL( IC )
LDS = LDA
LDQ = LDA
ELSE
OPCNTS( IPAR, ITYPE, IN, 9 ) = OPCNTS( LASTL,
$ ITYPE, IN, 9 )
TIMES( IPAR, ITYPE, IN, 9 ) = TIMES( LASTL, ITYPE,
$ IN, 9 )
END IF
480 CONTINUE
END IF
*
* . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
*
* Time STGEVC
*
IF( TIMSUB( 10 ) .OR. TIMSUB( 11 ) .OR. TIMSUB( 12 ) .OR.
$ TIMSUB( 13 ) ) THEN
DO 610 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
IF( LDA.LT.N1 ) THEN
DO 490 J = 10, 13
IF( TIMSUB( J ) ) THEN
TIMES( IPAR, ITYPE, IN, J ) = ZERO
OPCNTS( IPAR, ITYPE, IN, J ) = ZERO
END IF
490 CONTINUE
GO TO 610
END IF
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 500 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
500 CONTINUE
*
* Time STGEVC if this is a new value of LDA
*
IF( LASTL.EQ.0 ) THEN
*
* Copy S (which is in A) and P (which is in B)
* if necessary to get right LDA.
*
IF( LDA.GT.LDS ) THEN
DO 520 JC = N, 1, -1
DO 510 JR = N, 1, -1
A( JR+( JC-1 )*LDA ) = A( JR+( JC-1 )*
$ LDS )
B( JR+( JC-1 )*LDA ) = B( JR+( JC-1 )*
$ LDS )
510 CONTINUE
520 CONTINUE
ELSE IF( LDA.LT.LDS ) THEN
DO 540 JC = 1, N
DO 530 JR = 1, N
A( JR+( JC-1 )*LDA ) = A( JR+( JC-1 )*
$ LDS )
B( JR+( JC-1 )*LDA ) = B( JR+( JC-1 )*
$ LDS )
530 CONTINUE
540 CONTINUE
END IF
LDS = LDA
*
* Time STGEVC for Left Eigenvectors only,
* without back transforming
*
IF( TIMSUB( 10 ) ) THEN
IC = 0
OPS = ZERO
S1 = SECOND( )
550 CONTINUE
CALL STGEVC( 'L', 'A', LLWORK, N, A, LDA, B,
$ LDA, H, LDA, T, LDA, N, ITEMP,
$ WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 10 ),
$ IINFO, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 550
*
TIMES( IPAR, ITYPE, IN, 10 ) = TIME / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 10 ) = OPS / REAL( IC )
END IF
*
* Time STGEVC for Left Eigenvectors only,
* with back transforming
*
IF( TIMSUB( 11 ) ) THEN
IC = 0
OPS = ZERO
S1 = SECOND( )
560 CONTINUE
CALL SLACPY( 'Full', N, N, Q, LDQ, H, LDA )
CALL STGEVC( 'L', 'B', LLWORK, N, A, LDA, B,
$ LDA, H, LDA, T, LDA, N, ITEMP,
$ WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 11 ),
$ IINFO, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 560
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 570 J = 1, IC
CALL SLACPY( 'Full', N, N, Q, LDQ, H, LDA )
570 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 11 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 11 ) = OPS / REAL( IC )
END IF
*
* Time STGEVC for Right Eigenvectors only,
* without back transforming
*
IF( TIMSUB( 12 ) ) THEN
IC = 0
OPS = ZERO
S1 = SECOND( )
580 CONTINUE
CALL STGEVC( 'R', 'A', LLWORK, N, A, LDA, B,
$ LDA, H, LDA, T, LDA, N, ITEMP,
$ WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 12 ),
$ IINFO, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 580
*
TIMES( IPAR, ITYPE, IN, 12 ) = TIME / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 12 ) = OPS / REAL( IC )
END IF
*
* Time STGEVC for Right Eigenvectors only,
* with back transforming
*
IF( TIMSUB( 13 ) ) THEN
IC = 0
OPS = ZERO
S1 = SECOND( )
590 CONTINUE
CALL SLACPY( 'Full', N, N, Q, LDQ, T, LDA )
CALL STGEVC( 'R', 'B', LLWORK, N, A, LDA, B,
$ LDA, H, LDA, T, LDA, N, ITEMP,
$ WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 13 ),
$ IINFO, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 590
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 600 J = 1, IC
CALL SLACPY( 'Full', N, N, Q, LDQ, T, LDA )
600 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 13 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 13 ) = OPS / REAL( IC )
END IF
*
ELSE
*
* If this LDA has previously appeared, use the
* previously computed value(s).
*
IF( TIMSUB( 10 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 10 ) = OPCNTS( LASTL,
$ ITYPE, IN, 10 )
TIMES( IPAR, ITYPE, IN, 10 ) = TIMES( LASTL,
$ ITYPE, IN, 10 )
END IF
IF( TIMSUB( 11 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 11 ) = OPCNTS( LASTL,
$ ITYPE, IN, 11 )
TIMES( IPAR, ITYPE, IN, 11 ) = TIMES( LASTL,
$ ITYPE, IN, 11 )
END IF
IF( TIMSUB( 12 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 12 ) = OPCNTS( LASTL,
$ ITYPE, IN, 12 )
TIMES( IPAR, ITYPE, IN, 12 ) = TIMES( LASTL,
$ ITYPE, IN, 12 )
END IF
IF( TIMSUB( 13 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 13 ) = OPCNTS( LASTL,
$ ITYPE, IN, 13 )
TIMES( IPAR, ITYPE, IN, 13 ) = TIMES( LASTL,
$ ITYPE, IN, 13 )
END IF
END IF
610 CONTINUE
END IF
*
* Time the EISPACK Routines
*
* Restore random number seed
*
DO 620 J = 1, 4
ISEED( J ) = IOLDSD( J )
620 CONTINUE
*
* Re-generate A
*
IF( ITYPE.LE.MAXTYP ) THEN
*
* Generate A (w/o rotation)
*
CALL SLATM4( KATYPE( ITYPE ), N, 3, 1, 2, ONE, ULP, ONE,
$ 2, ISEED, A, N1 )
IF( 3.LE.N )
$ A( 3+2*N1 ) = ONE
*
* Generate B (w/o rotation)
*
CALL SLATM4( 8, N, 3, 1, 0, ONE, ONE, ONE, 2, ISEED, B,
$ N1 )
IF( 2.LE.N )
$ B( 2+N1 ) = ONE
*
IF( N.GT.0 ) THEN
*
* Include rotations
*
* Generate U, V as Householder transformations times
* a diagonal matrix.
*
DO 640 JC = 1, N - 1
IC = ( JC-1 )*N1
DO 630 JR = JC, N
Q( JR+IC ) = SLARND( 3, ISEED )
Z( JR+IC ) = SLARND( 3, ISEED )
630 CONTINUE
CALL SLARFG( N+1-JC, Q( JC+IC ), Q( JC+1+IC ), 1,
$ WORK( JC ) )
WORK( 2*N+JC ) = SIGN( ONE, Q( JC+IC ) )
Q( JC+IC ) = ONE
CALL SLARFG( N+1-JC, Z( JC+IC ), Z( JC+1+IC ), 1,
$ WORK( N+JC ) )
WORK( 3*N+JC ) = SIGN( ONE, Z( JC+IC ) )
Z( JC+IC ) = ONE
640 CONTINUE
IC = ( N-1 )*N1
Q( N+IC ) = ONE
WORK( N ) = ZERO
WORK( 3*N ) = SIGN( ONE, SLARND( 2, ISEED ) )
Z( N+IC ) = ONE
WORK( 2*N ) = ZERO
WORK( 4*N ) = SIGN( ONE, SLARND( 2, ISEED ) )
*
* Apply the diagonal matrices
*
DO 660 JC = 1, N
DO 650 JR = 1, N
A( JR+IC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
$ A( JR+IC )
B( JR+IC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
$ B( JR+IC )
650 CONTINUE
660 CONTINUE
CALL SORM2R( 'L', 'N', N, N, N-1, Q, N1, WORK, A, N1,
$ WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 670
CALL SORM2R( 'R', 'T', N, N, N-1, Z, N1, WORK( N+1 ),
$ A, N1, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 670
CALL SORM2R( 'L', 'N', N, N, N-1, Q, N1, WORK, B, N1,
$ WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 670
CALL SORM2R( 'R', 'T', N, N, N-1, Z, N1, WORK( N+1 ),
$ B, N1, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 670
END IF
670 CONTINUE
END IF
*
* Time QZHES w/ MATZ=.FALSE. for each LDAS(j)
*
IF( TIMSUB( 14 ) ) THEN
DO 710 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
IF( LDA.LT.N1 ) THEN
TIMES( IPAR, ITYPE, IN, 14 ) = ZERO
OPCNTS( IPAR, ITYPE, IN, 14 ) = ZERO
GO TO 710
END IF
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 680 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
680 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time QZHES( ...,.FALSE.,..)
*
IC = 0
OPS = ZERO
S1 = SECOND( )
690 CONTINUE
CALL SLACPY( 'Full', N, N, A, N1, H, LDA )
CALL SLACPY( 'Full', N, N, B, N1, T, LDA )
CALL QZHES( LDA, N, H, T, .FALSE., Q )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 690
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 700 J = 1, IC
CALL SLACPY( 'Full', N, N, A, N1, Z, LDA )
CALL SLACPY( 'Full', N, N, B, N1, Z, LDA )
700 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 14 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 14 ) = OPS / REAL( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 14 ) = OPCNTS( LASTL,
$ ITYPE, IN, 14 )
TIMES( IPAR, ITYPE, IN, 14 ) = TIMES( LASTL, ITYPE,
$ IN, 14 )
END IF
LDH = LDA
710 CONTINUE
ELSE IF( RUNHES ) THEN
CALL SLACPY( 'Full', N, N, A, N1, H, N1 )
CALL SLACPY( 'Full', N, N, B, N1, T, N1 )
CALL QZHES( N1, N, H, T, .FALSE., Q )
LDH = N1
END IF
*
* Time QZHES w/ MATZ=.TRUE. for each LDAS(j)
*
IF( TIMSUB( 15 ) ) THEN
DO 750 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
IF( LDA.LT.N1 ) THEN
TIMES( IPAR, ITYPE, IN, 15 ) = ZERO
OPCNTS( IPAR, ITYPE, IN, 15 ) = ZERO
GO TO 750
END IF
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 720 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
720 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time QZHES( ...,.TRUE.,..)
*
IC = 0
OPS = ZERO
S1 = SECOND( )
730 CONTINUE
CALL SLACPY( 'Full', N, N, A, N1, H, LDA )
CALL SLACPY( 'Full', N, N, B, N1, T, LDA )
CALL QZHES( LDA, N, H, T, .TRUE., Q )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 730
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 740 J = 1, IC
CALL SLACPY( 'Full', N, N, A, N1, Z, LDA )
CALL SLACPY( 'Full', N, N, B, N1, Z, LDA )
740 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 15 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 15 ) = OPS / REAL( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 15 ) = OPCNTS( LASTL,
$ ITYPE, IN, 15 )
TIMES( IPAR, ITYPE, IN, 15 ) = TIMES( LASTL, ITYPE,
$ IN, 15 )
END IF
LDH = LDA
750 CONTINUE
END IF
*
* Time QZIT and QZVAL w/ MATZ=.FALSE. for each LDAS(j)
*
IF( TIMSUB( 16 ) ) THEN
DO 790 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
IF( LDA.LT.N1 ) THEN
TIMES( IPAR, ITYPE, IN, 16 ) = ZERO
OPCNTS( IPAR, ITYPE, IN, 16 ) = ZERO
GO TO 790
END IF
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 760 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
760 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time QZIT and QZVAL with MATZ=.FALSE.
*
IC = 0
OPS = ZERO
S1 = SECOND( )
770 CONTINUE
CALL SLACPY( 'Full', N, N, H, LDH, A, LDA )
CALL SLACPY( 'Full', N, N, T, LDH, B, LDA )
CALL QZIT( LDA, N, A, B, ZERO, .FALSE., Q, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 16 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
*
CALL QZVAL( LDA, N, A, B, W, W( LDA+1 ),
$ W( 2*LDA+1 ), .FALSE., Q )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 770
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 780 J = 1, IC
CALL SLACPY( 'Full', N, N, H, LDH, Z, LDA )
CALL SLACPY( 'Full', N, N, T, LDH, Z, LDA )
780 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 16 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 16 ) = OPS / REAL( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 16 ) = OPCNTS( LASTL,
$ ITYPE, IN, 16 )
TIMES( IPAR, ITYPE, IN, 16 ) = TIMES( LASTL, ITYPE,
$ IN, 16 )
END IF
LDS = 0
790 CONTINUE
END IF
*
* Time QZIT and QZVAL w/ MATZ=.TRUE. for each LDAS(j)
*
IF( TIMSUB( 17 ) ) THEN
DO 830 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
IF( LDA.LT.N1 ) THEN
TIMES( IPAR, ITYPE, IN, 17 ) = ZERO
OPCNTS( IPAR, ITYPE, IN, 17 ) = ZERO
GO TO 830
END IF
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 800 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
800 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time QZIT and QZVAL with MATZ=.TRUE.
*
IC = 0
OPS = ZERO
S1 = SECOND( )
810 CONTINUE
CALL SLACPY( 'Full', N, N, H, LDH, A, LDA )
CALL SLACPY( 'Full', N, N, T, LDH, B, LDA )
CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDA )
CALL QZIT( LDA, N, A, B, ZERO, .TRUE., Q, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 17 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
*
CALL QZVAL( LDA, N, A, B, W, W( LDA+1 ),
$ W( 2*LDA+1 ), .TRUE., Q )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 810
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 820 J = 1, IC
CALL SLACPY( 'Full', N, N, H, LDH, Z, LDA )
CALL SLACPY( 'Full', N, N, T, LDH, Z, LDA )
CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDA )
820 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 17 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 17 ) = OPS / REAL( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 17 ) = OPCNTS( LASTL,
$ ITYPE, IN, 17 )
TIMES( IPAR, ITYPE, IN, 17 ) = TIMES( LASTL, ITYPE,
$ IN, 17 )
END IF
LDS = LDA
LDW = LDA
830 CONTINUE
ELSE IF( RUNQZ ) THEN
CALL SLACPY( 'Full', N, N, H, LDH, A, N1 )
CALL SLACPY( 'Full', N, N, T, LDH, B, N1 )
CALL SLASET( 'Full', N, N, ZERO, ONE, Q, N1 )
CALL QZIT( N1, N, A, B, ZERO, .TRUE., Q, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 17 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
*
CALL QZVAL( N1, N, A, B, W, W( N1+1 ), W( 2*N1+1 ),
$ .TRUE., Q )
LDS = N1
LDW = N1
END IF
*
* Time QZVEC for each LDAS(j)
*
IF( TIMSUB( 18 ) ) THEN
DO 910 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
IF( LDA.LT.N1 ) THEN
TIMES( IPAR, ITYPE, IN, 18 ) = ZERO
OPCNTS( IPAR, ITYPE, IN, 18 ) = ZERO
GO TO 910
END IF
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 840 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
840 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Copy W if necessary to get right LDA.
*
IF( LDA.GT.LDW ) THEN
DO 860 JC = 3, 1, -1
DO 850 JR = N, 1, -1
W( JR+( JC-1 )*LDA ) = W( JR+( JC-1 )*
$ LDW )
850 CONTINUE
860 CONTINUE
ELSE IF( LDA.LT.LDW ) THEN
DO 880 JC = 1, 3
DO 870 JR = 1, N
W( JR+( JC-1 )*LDA ) = W( JR+( JC-1 )*
$ LDW )
870 CONTINUE
880 CONTINUE
END IF
LDW = LDA
*
* Time QZVEC
*
IC = 0
OPS = ZERO
S1 = SECOND( )
890 CONTINUE
CALL SLACPY( 'Full', N, N, A, LDS, H, LDA )
CALL SLACPY( 'Full', N, N, B, LDS, T, LDA )
CALL SLACPY( 'Full', N, N, Q, LDS, Z, LDA )
CALL QZVEC( LDA, N, H, T, W, W( LDA+1 ),
$ W( 2*LDA+1 ), Z )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 890
*
* Subtract the time used in SLACPY.
*
S1 = SECOND( )
DO 900 J = 1, IC
CALL SLACPY( 'Full', N, N, A, LDS, Z, LDA )
CALL SLACPY( 'Full', N, N, B, LDS, Z, LDA )
CALL SLACPY( 'Full', N, N, Q, LDS, Z, LDA )
900 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 18 ) = MAX( TIME-UNTIME,
$ ZERO ) / REAL( IC )
OPCNTS( IPAR, ITYPE, IN, 18 ) = OPS / REAL( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 18 ) = OPCNTS( LASTL,
$ ITYPE, IN, 18 )
TIMES( IPAR, ITYPE, IN, 18 ) = TIMES( LASTL, ITYPE,
$ IN, 18 )
END IF
910 CONTINUE
END IF
*
920 CONTINUE
930 CONTINUE
*
* Print a table of results for each timed routine.
*
DO 940 ISUB = 1, NSUBS
IF( TIMSUB( ISUB ) ) THEN
CALL SPRTBG( SUBNAM( ISUB ), MTYPES, DOTYPE, NSIZES, NN,
$ INPARM( ISUB ), PNAMES, NPARMS, LDAS, NNB,
$ NSHFTS, NEISPS, MINNBS, MINBKS,
$ OPCNTS( 1, 1, 1, ISUB ), LDO1, LDO2,
$ TIMES( 1, 1, 1, ISUB ), LDT1, LDT2, WORK,
$ LLWORK, NOUT )
END IF
940 CONTINUE
*
RETURN
*
* End of STIM51
*
9997 FORMAT( ' STIM51: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', ITYPE=', I6, ', IPAR=', I6, ', ISEED=(',
$ 3( I5, ',' ), I5, ')' )
*
END
PROGRAM STIMEE
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* Purpose
* =======
*
* STIMEE is the main timing program for the REAL matrix
* eigenvalue routines in LAPACK.
*
* There are four sets of routines that can be timed:
*
* NEP (Nonsymmetric Eigenvalue Problem):
* Includes SGEHRD, SHSEQR, STREVC, and SHSEIN
*
* SEP (Symmetric Eigenvalue Problem):
* Includes SSYTRD, SORGTR, SORMTR, SSTEQR, SSTERF, SPTEQR, SSTEBZ,
* SSTEIN, and SSTEDC
*
* SVD (Singular Value Decomposition):
* Includes SGEBRD, SBDSQR, SORGBR, SBDSDC and SGESDD
*
* GEP (Generalized nonsymmetric Eigenvalue Problem):
* Includes SGGHRD, SHGEQZ, and STGEVC
*
* Each test path has a different input file. The first line of the
* input file should contain the characters NEP, SEP, SVD, or GEP in
* columns 1-3. The number of remaining lines depends on what is found
* on the first line.
*
*-----------------------------------------------------------------------
*
* NEP input file:
*
* line 2: NN, INTEGER
* Number of values of N.
*
* line 3: NVAL, INTEGER array, dimension (NN)
* The values for the matrix dimension N.
*
* line 4: NPARM, INTEGER
* Number of values of the parameters NB, NS, MAXB, and LDA.
*
* line 5: NBVAL, INTEGER array, dimension (NPARM)
* The values for the blocksize NB.
*
* line 6: NSVAL, INTEGER array, dimension (NPARM)
* The values for the number of shifts.
*
* line 7: MXBVAL, INTEGER array, dimension (NPARM)
* The values for MAXB, used in determining whether multishift
* will be used.
*
* line 8: LDAVAL, INTEGER array, dimension (NPARM)
* The values for the leading dimension LDA.
*
* line 9: TIMMIN, REAL
* The minimum time (in seconds) that a subroutine will be
* timed. If TIMMIN is zero, each routine should be timed only
* once.
*
* line 10: NTYPES, INTEGER
* The number of matrix types to be used in the timing run.
* If NTYPES >= MAXTYP, all the types are used.
*
* If 0 < NTYPES < MAXTYP, then line 11 specifies NTYPES integer
* values, which are the numbers of the matrix types to be used.
*
* The remaining lines specify a path name and the specific routines to
* be timed. For the nonsymmetric eigenvalue problem, the path name is
* 'SHS'. A line to request all the routines in this path has the form
* SHS T T T T T T T T T T T T
* where the first 3 characters specify the path name, and up to MAXTYP
* nonblank characters may appear in columns 4-80. If the k-th such
* character is 'T' or 't', the k-th routine will be timed. If at least
* one but fewer than 12 nonblank characters are specified, the
* remaining routines will not be timed. If columns 4-80 are blank, all
* the routines will be timed, so the input line
* SHS
* is equivalent to the line above.
*
*-----------------------------------------------------------------------
*
* SEP input file:
*
* line 2: NN, INTEGER
* Number of values of N.
*
* line 3: NVAL, INTEGER array, dimension (NN)
* The values for the matrix dimension N.
*
* line 4: NPARM, INTEGER
* Number of values of the parameters NB and LDA.
*
* line 5: NBVAL, INTEGER array, dimension (NPARM)
* The values for the blocksize NB.
*
* line 6: LDAVAL, INTEGER array, dimension (NPARM)
* The values for the leading dimension LDA.
*
* line 7: TIMMIN, REAL
* The minimum time (in seconds) that a subroutine will be
* timed. If TIMMIN is zero, each routine should be timed only
* once.
*
* line 8: NTYPES, INTEGER
* The number of matrix types to be used in the timing run.
* If NTYPES >= MAXTYP, all the types are used.
*
* If 0 < NTYPES < MAXTYP, then line 9 specifies NTYPES integer
* values, which are the numbers of the matrix types to be used.
*
* The remaining lines specify a path name and the specific routines to
* be timed as for the NEP input file. For the symmetric eigenvalue
* problem, the path name is 'SST' and up to 8 routines may be timed.
*
*-----------------------------------------------------------------------
*
* SVD input file:
*
* line 2: NN, INTEGER
* Number of values of M and N.
*
* line 3: MVAL, INTEGER array, dimension (NN)
* The values for the matrix dimension M.
*
* line 4: NVAL, INTEGER array, dimension (NN)
* The values for the matrix dimension N.
*
* line 5: NPARM, INTEGER
* Number of values of the parameters NB and LDA.
*
* line 6: NBVAL, INTEGER array, dimension (NPARM)
* The values for the blocksize NB.
*
* line 7: LDAVAL, INTEGER array, dimension (NPARM)
* The values for the leading dimension LDA.
*
* line 8: TIMMIN, REAL
* The minimum time (in seconds) that a subroutine will be
* timed. If TIMMIN is zero, each routine should be timed only
* once.
*
* line 9: NTYPES, INTEGER
* The number of matrix types to be used in the timing run.
* If NTYPES >= MAXTYP, all the types are used.
*
* If 0 < NTYPES < MAXTYP, then line 10 specifies NTYPES integer
* values, which are the numbers of the matrix types to be used.
*
* The remaining lines specify a path name and the specific routines to
* be timed as for the NEP input file. For the singular value
* decomposition the path name is 'SBD' and up to 16 routines may be
* timed.
*
*-----------------------------------------------------------------------
*
* GEP input file:
*
* line 2: NN, INTEGER
* Number of values of N.
*
* line 3: NVAL, INTEGER array, dimension (NN)
* The values for the matrix dimension N.
*
* line 4: NPARM, INTEGER
* Number of values of the parameters NB, NS, MAXB, and LDA.
*
* line 5: NBVAL, INTEGER array, dimension (NPARM)
* The values for the blocksize NB.
*
* line 6: NSVAL, INTEGER array, dimension (NPARM)
* The values for the number of shifts.
*
* line 7: NEIVAL, INTEGER array, dimension (NPARM)
* The values for NEISP, used in determining whether multishift
* will be used.
*
* line 8: NBMVAL, INTEGER array, dimension (NPARM)
* The values for MINNB, used in determining minimum blocksize.
*
* line 9: NBKVAL, INTEGER array, dimension (NPARM)
* The values for MINBLK, also used in determining minimum
* blocksize.
*
* line 10: LDAVAL, INTEGER array, dimension (NPARM)
* The values for the leading dimension LDA.
*
* line 11: TIMMIN, REAL
* The minimum time (in seconds) that a subroutine will be
* timed. If TIMMIN is zero, each routine should be timed only
* once.
*
* line 12: NTYPES, INTEGER
* The number of matrix types to be used in the timing run.
* If NTYPES >= MAXTYP, all the types are used.
*
* If 0 < NTYPES < MAXTYP, then line 13 specifies NTYPES integer
* values, which are the numbers of the matrix types to be used.
*
* The remaining lines specify a path name and the specific routines to
* be timed. For the nonsymmetric eigenvalue problem, the path name is
* 'SHG'. A line to request all the routines in this path has the form
* SHG T T T T T T T T T T T T T T T T T T
* where the first 3 characters specify the path name, and up to MAXTYP
* nonblank characters may appear in columns 4-80. If the k-th such
* character is 'T' or 't', the k-th routine will be timed. If at least
* one but fewer than 18 nonblank characters are specified, the
* remaining routines will not be timed. If columns 4-80 are blank, all
* the routines will be timed, so the input line
* SHG
* is equivalent to the line above.
*
*=======================================================================
*
* The workspace requirements in terms of square matrices for the
* different test paths are as follows:
*
* NEP: 3 N**2 + N*(3*NB+2)
* SEP: 2 N**2 + N*(2*N) + N
* SVD: 4 N**2 + MAX( 6*N, MAXIN*MAXPRM*MAXT )
* GEP: 6 N**2 + 3*N
*
* MAXN is currently set to 400,
* LG2MXN = ceiling of log-base-2 of MAXN = 9, and LDAMAX = 420.
* The real work space needed is LWORK = MAX( MAXN*(4*MAXN+2),
* 2*LDAMAX+1+3*MAXN+2*MAXN*LG2MXN+3*MAXN**2 ), and the integer
* workspace needed is LIWRK2 = 6 + 6*MAXN + 5*MAXN*LG2MXN.
* For SVD, we assume NRHS may be as big
* as N. The parameter NEED is set to 4 to allow for 4 NxN matrices
* for SVD.
*
* .. Parameters ..
INTEGER MAXN, LDAMAX, LG2MXN
PARAMETER ( MAXN = 400, LDAMAX = 420, LG2MXN = 9 )
INTEGER NEED
PARAMETER ( NEED = 6 )
INTEGER LIWRK2
PARAMETER ( LIWRK2 = 6+6*MAXN+5*MAXN*LG2MXN )
INTEGER LWORK
PARAMETER ( LWORK = 2*LDAMAX+1+3*MAXN+2*MAXN*LG2MXN+
$ 4*MAXN**2 )
INTEGER MAXIN, MAXPRM, MAXT, MAXSUB
PARAMETER ( MAXIN = 12, MAXPRM = 10, MAXT = 10,
$ MAXSUB = 25 )
INTEGER NIN, NOUT
PARAMETER ( NIN = 5, NOUT = 6 )
* ..
* .. Local Scalars ..
LOGICAL FATAL, GEP, NEP, SEP, SVD
CHARACTER*3 C3, PATH
CHARACTER*6 VNAME
CHARACTER*80 LINE
INTEGER I, INFO, MAXTYP, NN, NPARMS, NTYPES
REAL S1, S2, TIMMIN
* ..
* .. Local Arrays ..
LOGICAL DOTYPE( MAXT ), LOGWRK( MAXN )
INTEGER ISEED( 4 ), IWORK( MAXT ), IWORK2( LIWRK2 ),
$ LDAVAL( MAXPRM ), MVAL( MAXIN ),
$ MXBVAL( MAXPRM ), MXTYPE( 4 ),
$ NBKVAL( MAXPRM ), NBMVAL( MAXPRM ),
$ NBVAL( MAXPRM ), NSVAL( MAXPRM ), NVAL( MAXIN )
REAL A( LDAMAX*MAXN, NEED ), D( MAXN, 4 ),
$ OPCNTS( MAXPRM, MAXT, MAXIN, MAXSUB ),
$ RESULT( MAXPRM, MAXT, MAXIN, MAXSUB ),
$ WORK( LWORK )
* ..
* .. External Functions ..
LOGICAL LSAMEN
REAL SECOND
EXTERNAL LSAMEN, SECOND
* ..
* .. External Subroutines ..
EXTERNAL STIM21, STIM22, STIM26, STIM51
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
* .. Arrays in Common ..
INTEGER IPARMS( 100 )
* ..
* .. Common blocks ..
COMMON / CLAENV / IPARMS
COMMON / LATIME / OPS, ITCNT
* ..
* .. Save statement ..
SAVE / CLAENV /
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Data statements ..
DATA ISEED / 0, 0, 0, 1 /
DATA MXTYPE / 8, 4, 5, 4 /
* ..
* .. Executable Statements ..
*
S1 = SECOND( )
FATAL = .FALSE.
NEP = .FALSE.
SEP = .FALSE.
SVD = .FALSE.
GEP = .FALSE.
*
* Read the 3-character test path
*
READ( NIN, FMT = '(A3)', END = 160 )PATH
NEP = LSAMEN( 3, PATH, 'NEP' ) .OR. LSAMEN( 3, PATH, 'SHS' )
SEP = LSAMEN( 3, PATH, 'SEP' ) .OR. LSAMEN( 3, PATH, 'SST' )
SVD = LSAMEN( 3, PATH, 'SVD' ) .OR. LSAMEN( 3, PATH, 'SBD' )
GEP = LSAMEN( 3, PATH, 'GEP' ) .OR. LSAMEN( 3, PATH, 'SHG' )
*
* Report values of parameters as they are read.
*
IF( NEP ) THEN
WRITE( NOUT, FMT = 9993 )
ELSE IF( SEP ) THEN
WRITE( NOUT, FMT = 9992 )
ELSE IF( SVD ) THEN
WRITE( NOUT, FMT = 9991 )
ELSE IF( GEP ) THEN
WRITE( NOUT, FMT = 9990 )
ELSE
WRITE( NOUT, FMT = 9996 )PATH
STOP
END IF
WRITE( NOUT, FMT = 9985 )
WRITE( NOUT, FMT = 9989 )
*
* Read the number of values of M and N.
*
READ( NIN, FMT = * )NN
IF( NN.LT.1 ) THEN
WRITE( NOUT, FMT = 9995 )'NN ', NN, 1
NN = 0
FATAL = .TRUE.
ELSE IF( NN.GT.MAXIN ) THEN
WRITE( NOUT, FMT = 9994 )'NN ', NN, MAXIN
NN = 0
FATAL = .TRUE.
END IF
*
* Read the values of M
*
READ( NIN, FMT = * )( MVAL( I ), I = 1, NN )
IF( SVD ) THEN
VNAME = ' M'
ELSE
VNAME = ' N'
END IF
DO 10 I = 1, NN
IF( MVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9995 )VNAME, MVAL( I ), 0
FATAL = .TRUE.
ELSE IF( MVAL( I ).GT.MAXN ) THEN
WRITE( NOUT, FMT = 9994 )VNAME, MVAL( I ), MAXN
FATAL = .TRUE.
END IF
10 CONTINUE
*
* Read the values of N
*
IF( SVD ) THEN
WRITE( NOUT, FMT = 9988 )'M ', ( MVAL( I ), I = 1, NN )
READ( NIN, FMT = * )( NVAL( I ), I = 1, NN )
DO 20 I = 1, NN
IF( NVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9995 )'N ', NVAL( I ), 0
FATAL = .TRUE.
ELSE IF( NVAL( I ).GT.MAXN ) THEN
WRITE( NOUT, FMT = 9994 )'N ', NVAL( I ), MAXN
FATAL = .TRUE.
END IF
20 CONTINUE
ELSE
DO 30 I = 1, NN
NVAL( I ) = MVAL( I )
30 CONTINUE
END IF
WRITE( NOUT, FMT = 9988 )'N ', ( NVAL( I ), I = 1, NN )
*
* Read the number of parameter values.
*
READ( NIN, FMT = * )NPARMS
IF( NPARMS.LT.1 ) THEN
WRITE( NOUT, FMT = 9995 )'NPARMS', NPARMS, 1
NPARMS = 0
FATAL = .TRUE.
ELSE IF( NPARMS.GT.MAXIN ) THEN
WRITE( NOUT, FMT = 9994 )'NPARMS', NPARMS, MAXIN
NPARMS = 0
FATAL = .TRUE.
END IF
*
* Read the values of NB
*
READ( NIN, FMT = * )( NBVAL( I ), I = 1, NPARMS )
DO 40 I = 1, NPARMS
IF( NBVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9995 )'NB ', NBVAL( I ), 0
FATAL = .TRUE.
END IF
40 CONTINUE
WRITE( NOUT, FMT = 9988 )'NB ', ( NBVAL( I ), I = 1, NPARMS )
*
IF( NEP .OR. GEP ) THEN
*
* Read the values of NSHIFT
*
READ( NIN, FMT = * )( NSVAL( I ), I = 1, NPARMS )
DO 50 I = 1, NPARMS
IF( NSVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9995 )'NS ', NSVAL( I ), 0
FATAL = .TRUE.
END IF
50 CONTINUE
WRITE( NOUT, FMT = 9988 )'NS ', ( NSVAL( I ), I = 1, NPARMS )
*
* Read the values of MAXB
*
READ( NIN, FMT = * )( MXBVAL( I ), I = 1, NPARMS )
DO 60 I = 1, NPARMS
IF( MXBVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9995 )'MAXB', MXBVAL( I ), 0
FATAL = .TRUE.
END IF
60 CONTINUE
WRITE( NOUT, FMT = 9988 )'MAXB',
$ ( MXBVAL( I ), I = 1, NPARMS )
ELSE
DO 70 I = 1, NPARMS
NSVAL( I ) = 1
MXBVAL( I ) = 1
70 CONTINUE
END IF
*
IF( GEP ) THEN
*
* Read the values of NBMIN
*
READ( NIN, FMT = * )( NBMVAL( I ), I = 1, NPARMS )
DO 80 I = 1, NPARMS
IF( NBMVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9995 )'NBMIN', NBMVAL( I ), 0
FATAL = .TRUE.
END IF
80 CONTINUE
WRITE( NOUT, FMT = 9988 )'NBMIN',
$ ( NBMVAL( I ), I = 1, NPARMS )
*
* Read the values of MINBLK
*
READ( NIN, FMT = * )( NBKVAL( I ), I = 1, NPARMS )
DO 90 I = 1, NPARMS
IF( NBKVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9995 )'MINBLK', NBKVAL( I ), 0
FATAL = .TRUE.
END IF
90 CONTINUE
WRITE( NOUT, FMT = 9988 )'MINBLK',
$ ( NBKVAL( I ), I = 1, NPARMS )
ELSE
DO 100 I = 1, NPARMS
NBMVAL( I ) = MAXN + 1
NBKVAL( I ) = MAXN + 1
100 CONTINUE
END IF
*
* Read the values of LDA
*
READ( NIN, FMT = * )( LDAVAL( I ), I = 1, NPARMS )
DO 110 I = 1, NPARMS
IF( LDAVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9995 )'LDA ', LDAVAL( I ), 0
FATAL = .TRUE.
ELSE IF( LDAVAL( I ).GT.LDAMAX ) THEN
WRITE( NOUT, FMT = 9994 )'LDA ', LDAVAL( I ), LDAMAX
FATAL = .TRUE.
END IF
110 CONTINUE
WRITE( NOUT, FMT = 9988 )'LDA ', ( LDAVAL( I ), I = 1, NPARMS )
*
* Read the minimum time a subroutine will be timed.
*
READ( NIN, FMT = * )TIMMIN
WRITE( NOUT, FMT = 9987 )TIMMIN
*
* Read the number of matrix types to use in timing.
*
READ( NIN, FMT = * )NTYPES
IF( NTYPES.LT.0 ) THEN
WRITE( NOUT, FMT = 9995 )'NTYPES', NTYPES, 0
FATAL = .TRUE.
NTYPES = 0
END IF
*
* Read the matrix types.
*
IF( NEP ) THEN
MAXTYP = MXTYPE( 1 )
ELSE IF( SEP ) THEN
MAXTYP = MXTYPE( 2 )
ELSE IF( SVD ) THEN
MAXTYP = MXTYPE( 3 )
ELSE
MAXTYP = MXTYPE( 4 )
END IF
IF( NTYPES.LT.MAXTYP ) THEN
READ( NIN, FMT = * )( IWORK( I ), I = 1, NTYPES )
DO 120 I = 1, MAXTYP
DOTYPE( I ) = .FALSE.
120 CONTINUE
DO 130 I = 1, NTYPES
IF( IWORK( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9995 )'TYPE', IWORK( I ), 0
FATAL = .TRUE.
ELSE IF( IWORK( I ).GT.MAXTYP ) THEN
WRITE( NOUT, FMT = 9994 )'TYPE', IWORK( I ), MAXTYP
FATAL = .TRUE.
ELSE
DOTYPE( IWORK( I ) ) = .TRUE.
END IF
130 CONTINUE
ELSE
NTYPES = MAXTYP
DO 140 I = 1, MAXT
DOTYPE( I ) = .TRUE.
140 CONTINUE
END IF
*
IF( FATAL ) THEN
WRITE( NOUT, FMT = 9999 )
9999 FORMAT( / ' Execution not attempted due to input errors' )
STOP
END IF
*
* Read the input lines indicating the test path and the routines
* to be timed. The first three characters indicate the test path.
*
150 CONTINUE
READ( NIN, FMT = '(A80)', END = 160 )LINE
C3 = LINE( 1: 3 )
*
* -------------------------------------
* NEP: Nonsymmetric Eigenvalue Problem
* -------------------------------------
*
IF( LSAMEN( 3, C3, 'SHS' ) .OR. LSAMEN( 3, C3, 'NEP' ) ) THEN
CALL STIM21( LINE, NN, NVAL, MAXTYP, DOTYPE, NPARMS, NBVAL,
$ NSVAL, MXBVAL, LDAVAL, TIMMIN, NOUT, ISEED,
$ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), D( 1, 1 ), WORK,
$ LWORK, LOGWRK, IWORK2, RESULT, MAXPRM, MAXT,
$ MAXIN, OPCNTS, MAXPRM, MAXT, MAXIN, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9986 )'STIM21', INFO
*
* ----------------------------------
* SEP: Symmetric Eigenvalue Problem
* ----------------------------------
*
ELSE IF( LSAMEN( 3, C3, 'SST' ) .OR. LSAMEN( 3, C3, 'SEP' ) ) THEN
CALL STIM22( LINE, NN, NVAL, MAXTYP, DOTYPE, NPARMS, NBVAL,
$ LDAVAL, TIMMIN, NOUT, ISEED, A( 1, 1 ), D( 1, 1 ),
$ D( 1, 2 ), D( 1, 3 ), A( 1, 2 ), A( 1, 3 ), WORK,
$ LWORK, LOGWRK, IWORK2, RESULT, MAXPRM, MAXT,
$ MAXIN, OPCNTS, MAXPRM, MAXT, MAXIN, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9986 )'STIM22', INFO
*
* ----------------------------------
* SVD: Singular Value Decomposition
* ----------------------------------
*
ELSE IF( LSAMEN( 3, C3, 'SBD' ) .OR. LSAMEN( 3, C3, 'SVD' ) ) THEN
CALL STIM26( LINE, NN, NVAL, MVAL, MAXTYP, DOTYPE, NPARMS,
$ NBVAL, LDAVAL, TIMMIN, NOUT, ISEED, A( 1, 1 ),
$ A( 1, 2 ), A( 1, 3 ), A( 1, 4 ), D( 1, 1 ),
$ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), WORK, LWORK,
$ IWORK2, LOGWRK, RESULT, MAXPRM, MAXT, MAXIN,
$ OPCNTS, MAXPRM, MAXT, MAXIN, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9986 )'STIM26', INFO
*
* -------------------------------------------------
* GEP: Generalized Nonsymmetric Eigenvalue Problem
* -------------------------------------------------
*
ELSE IF( LSAMEN( 3, C3, 'SHG' ) .OR. LSAMEN( 3, C3, 'GEP' ) ) THEN
CALL STIM51( LINE, NN, NVAL, MAXTYP, DOTYPE, NPARMS, NBVAL,
$ NSVAL, MXBVAL, NBMVAL, NBKVAL, LDAVAL, TIMMIN,
$ NOUT, ISEED, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
$ A( 1, 4 ), A( 1, 5 ), A( 1, 6 ), D( 1, 1 ), WORK,
$ LWORK, LOGWRK, RESULT, MAXPRM, MAXT, MAXIN,
$ OPCNTS, MAXPRM, MAXT, MAXIN, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9986 )'STIM51', INFO
ELSE
WRITE( NOUT, FMT = * )
WRITE( NOUT, FMT = * )
WRITE( NOUT, FMT = 9996 )C3
END IF
GO TO 150
160 CONTINUE
WRITE( NOUT, FMT = 9998 )
9998 FORMAT( / / ' End of timing run' )
S2 = SECOND( )
WRITE( NOUT, FMT = 9997 )S2 - S1
*
9997 FORMAT( ' Total time used = ', F12.2, ' seconds', / )
9996 FORMAT( 1X, A3, ': Unrecognized path name' )
9995 FORMAT( ' *** Invalid input value: ', A6, '=', I6, '; must be >=',
$ I6 )
9994 FORMAT( ' *** Invalid input value: ', A6, '=', I6, '; must be <=',
$ I6 )
9993 FORMAT( ' Timing the Nonsymmetric Eigenvalue Problem routines',
$ / ' SGEHRD, SHSEQR, STREVC, and SHSEIN' )
9992 FORMAT( ' Timing the Symmetric Eigenvalue Problem routines',
$ / ' SSYTRD, SSTEQR, and SSTERF' )
9991 FORMAT( ' Timing the Singular Value Decomposition routines',
$ / ' SGEBRD, SBDSQR, SORGBR, SBDSDC and SGESDD' )
9990 FORMAT( ' Timing the Generalized Eigenvalue Problem routines',
$ / ' SGGHRD, SHGEQZ, and STGEVC ' )
9989 FORMAT( / ' The following parameter values will be used:' )
9988 FORMAT( ' Values of ', A5, ': ', 10I6, / 19X, 10I6 )
9987 FORMAT( / ' Minimum time a subroutine will be timed = ', F8.2,
$ ' seconds', / )
9986 FORMAT( ' *** Error code from ', A6, ' = ', I4 )
9985 FORMAT( / ' LAPACK VERSION 3.0, released June 30, 1999 ' )
*
* End of STIMEE
*
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/seig/Makefile 0000644 0001750 0001750 00000002657 10616442122 023425 0 ustar osallou osallou .PHONY: DUMMY util
.SUFFIXES: .f .java
ROOT=../../..
include $(ROOT)/make.def
BLAS=$(ROOT)/$(BLAS_IDX)
LAPACK=$(ROOT)/$(LAPACK_IDX)
SMATGEN=$(ROOT)/$(SMATGEN_IDX)
XERBLAFLAGS= -c .:$(ROOT)/$(BLAS_OBJ) -p $(ERR_PACKAGE)
F2JFLAGS=-c .:eigsrc/$(OUTDIR):$(ROOT)/$(BLAS_OBJ):$(ROOT)/$(LAPACK_OBJ):$(ROOT)/$(SMATGEN_OBJ) -p $(SEIGTIME_PACKAGE) -o $(OUTDIR)
TIMER_CLASSPATH=-cp .:./obj:eigsrc/$(OUTDIR):$(ROOT)/$(SMATGEN_OBJ):$(ROOT)/$(BLAS_OBJ):$(ROOT)/$(LAPACK_OBJ):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
timer: $(BLAS) $(LAPACK) $(SMATGEN) eigsrc/$(OUTDIR)/Seigsrc.f2j $(OUTDIR)/Seigtime.f2j util
/bin/rm -f $(SEIGTIME_JAR)
cd eigsrc/$(OUTDIR); $(JAR) cvf ../../$(SEIGTIME_JAR) `find . -name "*.class"`
cd $(OUTDIR); $(JAR) uvf ../$(SEIGTIME_JAR) `find . -name "*.class"`
eigsrc/$(OUTDIR)/Seigsrc.f2j: eigsrc/seigsrc.f
cd eigsrc;$(MAKE)
$(OUTDIR)/Seigtime.f2j: seigtime.f
$(F2J) $(F2JFLAGS) seigtime.f > /dev/null
$(BLAS):
cd $(ROOT)/$(BLAS_DIR); $(MAKE)
$(LAPACK):
cd $(ROOT)/$(LAPACK_DIR); $(MAKE)
$(SMATGEN):
cd $(ROOT)/$(SMATGEN_DIR); $(MAKE)
util:
cd $(ROOT)/$(UTIL_DIR); $(MAKE)
runtimer: small
small: timer s*.in
large: timer input_files_large/S*.in
*.in: DUMMY
java $(MORE_MEM_FLAG) $(TIMER_CLASSPATH) $(SEIGTIME_PACKAGE).Stimee < $@
input_files_large/*.in: DUMMY
java $(MORE_MEM_FLAG) $(TIMER_CLASSPATH) $(SEIGTIME_PACKAGE).Stimee < $@
clean:
cd eigsrc;$(MAKE) clean
/bin/rm -rf *.java *.class *.f2j $(OUTDIR) $(SEIGTIME_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/seig/sgeptim.in 0000644 0001750 0001750 00000001424 10616163244 023761 0 ustar osallou osallou GEP: Data file for timing Generalized Nonsymmetric Eigenvalue Problem
4 Number of values of N
10 20 30 40 Values of N (dimension)
4 Number of parameter values
10 10 10 10 Values of NB (blocksize)
2 2 4 4 Values of NS (no. of shifts)
100 2 4 4 Values of MAXB (multishift crossover pt)
100 100 100 10 Values of MINNB (minimum blocksize)
100 100 100 10 Values of MINBLK (minimum blocksize)
81 81 81 81 Values of LDA (leading dimension)
0.05 Minimum time in seconds
5 Number of matrix types
SHG T T T T T T T T T T T T T T T T T T
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/seig/eigsrc/ 0000755 0001750 0001750 00000000000 11734055026 023234 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/seig/eigsrc/Makefile 0000644 0001750 0001750 00000000766 10616163244 024705 0 ustar osallou osallou .SUFFIXES: .f .java
ROOT=../../../..
include $(ROOT)/make.def
SBLAS=$(ROOT)/$(SBLAS_IDX)
SLAPACK=$(ROOT)/$(SLAPACK_IDX)
F2JFLAGS=-c .:$(ROOT)/$(SBLAS_OBJ):$(ROOT)/$(ERR_OBJ):$(ROOT)/$(SLAPACK_OBJ) -p $(SEIGSRC_PACKAGE) -o $(OUTDIR)
tester: $(SBLAS) $(SLAPACK) $(OUTDIR)/Seigsrc.f2j
$(OUTDIR)/Seigsrc.f2j: seigsrc.f
$(F2J) $(F2JFLAGS) $< > /dev/null
$(SBLAS):
cd $(ROOT)/$(SBLAS_DIR); $(MAKE)
$(SLAPACK):
cd $(ROOT)/$(SLAPACK_DIR); $(MAKE)
clean:
/bin/rm -rf *.java *.class *.f2j $(OUTDIR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/seig/eigsrc/seigsrc.f 0000644 0001750 0001750 00003105315 10616163244 025052 0 ustar osallou osallou SUBROUTINE SBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ,
$ WORK, IWORK, INFO )
*
* -- LAPACK routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
CHARACTER COMPQ, UPLO
INTEGER INFO, LDU, LDVT, N
* ..
* .. Array Arguments ..
INTEGER IQ( * ), IWORK( * )
REAL D( * ), E( * ), Q( * ), U( LDU, * ),
$ VT( LDVT, * ), WORK( * )
* ..
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SBDSDC computes the singular value decomposition (SVD) of a real
* N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT,
* using a divide and conquer method, where S is a diagonal matrix
* with non-negative diagonal elements (the singular values of B), and
* U and VT are orthogonal matrices of left and right singular vectors,
* respectively. SBDSDC can be used to compute all singular values,
* and optionally, singular vectors or singular vectors in compact form.
*
* This code makes very mild assumptions about floating point
* arithmetic. It will work on machines with a guard digit in
* add/subtract, or on those binary machines without guard digits
* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
* It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none. See SLASD3 for details.
*
* The code currently call SLASDQ if singular values only are desired.
* However, it can be slightly modified to compute singular values
* using the divide and conquer method.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': B is upper bidiagonal.
* = 'L': B is lower bidiagonal.
*
* COMPQ (input) CHARACTER*1
* Specifies whether singular vectors are to be computed
* as follows:
* = 'N': Compute singular values only;
* = 'P': Compute singular values and compute singular
* vectors in compact form;
* = 'I': Compute singular values and singular vectors.
*
* N (input) INTEGER
* The order of the matrix B. N >= 0.
*
* D (input/output) REAL array, dimension (N)
* On entry, the n diagonal elements of the bidiagonal matrix B.
* On exit, if INFO=0, the singular values of B.
*
* E (input/output) REAL array, dimension (N)
* On entry, the elements of E contain the offdiagonal
* elements of the bidiagonal matrix whose SVD is desired.
* On exit, E has been destroyed.
*
* U (output) REAL array, dimension (LDU,N)
* If COMPQ = 'I', then:
* On exit, if INFO = 0, U contains the left singular vectors
* of the bidiagonal matrix.
* For other values of COMPQ, U is not referenced.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= 1.
* If singular vectors are desired, then LDU >= max( 1, N ).
*
* VT (output) REAL array, dimension (LDVT,N)
* If COMPQ = 'I', then:
* On exit, if INFO = 0, VT' contains the right singular
* vectors of the bidiagonal matrix.
* For other values of COMPQ, VT is not referenced.
*
* LDVT (input) INTEGER
* The leading dimension of the array VT. LDVT >= 1.
* If singular vectors are desired, then LDVT >= max( 1, N ).
*
* Q (output) REAL array, dimension (LDQ)
* If COMPQ = 'P', then:
* On exit, if INFO = 0, Q and IQ contain the left
* and right singular vectors in a compact form,
* requiring O(N log N) space instead of 2*N**2.
* In particular, Q contains all the REAL data in
* LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))
* words of memory, where SMLSIZ is returned by ILAENV and
* is equal to the maximum size of the subproblems at the
* bottom of the computation tree (usually about 25).
* For other values of COMPQ, Q is not referenced.
*
* IQ (output) INTEGER array, dimension (LDIQ)
* If COMPQ = 'P', then:
* On exit, if INFO = 0, Q and IQ contain the left
* and right singular vectors in a compact form,
* requiring O(N log N) space instead of 2*N**2.
* In particular, IQ contains all INTEGER data in
* LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))
* words of memory, where SMLSIZ is returned by ILAENV and
* is equal to the maximum size of the subproblems at the
* bottom of the computation tree (usually about 25).
* For other values of COMPQ, IQ is not referenced.
*
* WORK (workspace) REAL array, dimension (LWORK)
* If COMPQ = 'N' then LWORK >= (4 * N).
* If COMPQ = 'P' then LWORK >= (6 * N).
* If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N).
*
* IWORK (workspace) INTEGER array, dimension (7*N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: The algorithm failed to compute an singular value.
* The update process of divide and conquer failed.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
* ..
* .. Local Scalars ..
INTEGER DIFL, DIFR, GIVCOL, GIVNUM, GIVPTR, I, IC,
$ ICOMPQ, IERR, II, IS, IU, IUPLO, IVT, J, K, KK,
$ MLVL, NM1, NSIZE, PERM, POLES, QSTART, SMLSIZ,
$ SMLSZP, SQRE, START, WSTART, Z
REAL CS, EPS, ORGNRM, P, R, SN
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
REAL SLAMCH, SLANST
EXTERNAL SLAMCH, SLANST, ILAENV, LSAME
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLARTG, SLASCL, SLASD0, SLASDA, SLASDQ,
$ SLASET, SLASR, SSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL, ABS, INT, LOG, SIGN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IUPLO = 0
IF( LSAME( UPLO, 'U' ) )
$ IUPLO = 1
IF( LSAME( UPLO, 'L' ) )
$ IUPLO = 2
IF( LSAME( COMPQ, 'N' ) ) THEN
ICOMPQ = 0
ELSE IF( LSAME( COMPQ, 'P' ) ) THEN
ICOMPQ = 1
ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
ICOMPQ = 2
ELSE
ICOMPQ = -1
END IF
IF( IUPLO.EQ.0 ) THEN
INFO = -1
ELSE IF( ICOMPQ.LT.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ( LDU.LT.1 ) .OR. ( ( ICOMPQ.EQ.2 ) .AND. ( LDU.LT.
$ N ) ) ) THEN
INFO = -7
ELSE IF( ( LDVT.LT.1 ) .OR. ( ( ICOMPQ.EQ.2 ) .AND. ( LDVT.LT.
$ N ) ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SBDSDC', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
SMLSIZ = ILAENV( 9, 'SBDSDC', ' ', 0, 0, 0, 0 )
IF( N.EQ.1 ) THEN
IF( ICOMPQ.EQ.1 ) THEN
Q( 1 ) = SIGN( ONE, D( 1 ) )
Q( 1+SMLSIZ*N ) = ONE
ELSE IF( ICOMPQ.EQ.2 ) THEN
U( 1, 1 ) = SIGN( ONE, D( 1 ) )
VT( 1, 1 ) = ONE
END IF
D( 1 ) = ABS( D( 1 ) )
RETURN
END IF
NM1 = N - 1
*
* If matrix lower bidiagonal, rotate to be upper bidiagonal
* by applying Givens rotations on the left
*
WSTART = 1
QSTART = 3
IF( ICOMPQ.EQ.1 ) THEN
CALL SCOPY( N, D, 1, Q( 1 ), 1 )
CALL SCOPY( N-1, E, 1, Q( N+1 ), 1 )
END IF
IF( IUPLO.EQ.2 ) THEN
QSTART = 5
WSTART = 2*N - 1
OPS = OPS + REAL( 8*( N-1 ) )
DO 10 I = 1, N - 1
CALL SLARTG( D( I ), E( I ), CS, SN, R )
D( I ) = R
E( I ) = SN*D( I+1 )
D( I+1 ) = CS*D( I+1 )
IF( ICOMPQ.EQ.1 ) THEN
Q( I+2*N ) = CS
Q( I+3*N ) = SN
ELSE IF( ICOMPQ.EQ.2 ) THEN
WORK( I ) = CS
WORK( NM1+I ) = -SN
END IF
10 CONTINUE
END IF
*
* If ICOMPQ = 0, use SLASDQ to compute the singular values.
*
IF( ICOMPQ.EQ.0 ) THEN
CALL SLASDQ( 'U', 0, N, 0, 0, 0, D, E, VT, LDVT, U, LDU, U,
$ LDU, WORK( WSTART ), INFO )
GO TO 40
END IF
*
* If N is smaller than the minimum divide size SMLSIZ, then solve
* the problem with another solver.
*
IF( N.LE.SMLSIZ ) THEN
IF( ICOMPQ.EQ.2 ) THEN
CALL SLASET( 'A', N, N, ZERO, ONE, U, LDU )
CALL SLASET( 'A', N, N, ZERO, ONE, VT, LDVT )
CALL SLASDQ( 'U', 0, N, N, N, 0, D, E, VT, LDVT, U, LDU, U,
$ LDU, WORK( WSTART ), INFO )
ELSE IF( ICOMPQ.EQ.1 ) THEN
IU = 1
IVT = IU + N
CALL SLASET( 'A', N, N, ZERO, ONE, Q( IU+( QSTART-1 )*N ),
$ N )
CALL SLASET( 'A', N, N, ZERO, ONE, Q( IVT+( QSTART-1 )*N ),
$ N )
CALL SLASDQ( 'U', 0, N, N, N, 0, D, E,
$ Q( IVT+( QSTART-1 )*N ), N,
$ Q( IU+( QSTART-1 )*N ), N,
$ Q( IU+( QSTART-1 )*N ), N, WORK( WSTART ),
$ INFO )
END IF
GO TO 40
END IF
*
IF( ICOMPQ.EQ.2 ) THEN
CALL SLASET( 'A', N, N, ZERO, ONE, U, LDU )
CALL SLASET( 'A', N, N, ZERO, ONE, VT, LDVT )
END IF
*
* Scale.
*
ORGNRM = SLANST( 'M', N, D, E )
IF( ORGNRM.EQ.ZERO )
$ RETURN
OPS = OPS + REAL( N + NM1 )
CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, IERR )
CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, IERR )
*
EPS = SLAMCH( 'Epsilon' )
*
MLVL = INT( LOG( REAL( N ) / REAL( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1
SMLSZP = SMLSIZ + 1
*
IF( ICOMPQ.EQ.1 ) THEN
IU = 1
IVT = 1 + SMLSIZ
DIFL = IVT + SMLSZP
DIFR = DIFL + MLVL
Z = DIFR + MLVL*2
IC = Z + MLVL
IS = IC + 1
POLES = IS + 1
GIVNUM = POLES + 2*MLVL
*
K = 1
GIVPTR = 2
PERM = 3
GIVCOL = PERM + MLVL
END IF
*
DO 20 I = 1, N
IF( ABS( D( I ) ).LT.EPS ) THEN
D( I ) = SIGN( EPS, D( I ) )
END IF
20 CONTINUE
*
START = 1
SQRE = 0
*
DO 30 I = 1, NM1
IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN
*
* Subproblem found. First determine its size and then
* apply divide and conquer on it.
*
IF( I.LT.NM1 ) THEN
*
* A subproblem with E(I) small for I < NM1.
*
NSIZE = I - START + 1
ELSE IF( ABS( E( I ) ).GE.EPS ) THEN
*
* A subproblem with E(NM1) not too small but I = NM1.
*
NSIZE = N - START + 1
ELSE
*
* A subproblem with E(NM1) small. This implies an
* 1-by-1 subproblem at D(N). Solve this 1-by-1 problem
* first.
*
NSIZE = I - START + 1
IF( ICOMPQ.EQ.2 ) THEN
U( N, N ) = SIGN( ONE, D( N ) )
VT( N, N ) = ONE
ELSE IF( ICOMPQ.EQ.1 ) THEN
Q( N+( QSTART-1 )*N ) = SIGN( ONE, D( N ) )
Q( N+( SMLSIZ+QSTART-1 )*N ) = ONE
END IF
D( N ) = ABS( D( N ) )
END IF
IF( ICOMPQ.EQ.2 ) THEN
CALL SLASD0( NSIZE, SQRE, D( START ), E( START ),
$ U( START, START ), LDU, VT( START, START ),
$ LDVT, SMLSIZ, IWORK, WORK( WSTART ), INFO )
ELSE
CALL SLASDA( ICOMPQ, SMLSIZ, NSIZE, SQRE, D( START ),
$ E( START ), Q( START+( IU+QSTART-2 )*N ), N,
$ Q( START+( IVT+QSTART-2 )*N ),
$ IQ( START+K*N ), Q( START+( DIFL+QSTART-2 )*
$ N ), Q( START+( DIFR+QSTART-2 )*N ),
$ Q( START+( Z+QSTART-2 )*N ),
$ Q( START+( POLES+QSTART-2 )*N ),
$ IQ( START+GIVPTR*N ), IQ( START+GIVCOL*N ),
$ N, IQ( START+PERM*N ),
$ Q( START+( GIVNUM+QSTART-2 )*N ),
$ Q( START+( IC+QSTART-2 )*N ),
$ Q( START+( IS+QSTART-2 )*N ),
$ WORK( WSTART ), IWORK, INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
END IF
START = I + 1
END IF
30 CONTINUE
*
* Unscale
*
OPS = OPS + REAL( N )
CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, IERR )
40 CONTINUE
*
* Use Selection Sort to minimize swaps of singular vectors
*
DO 60 II = 2, N
I = II - 1
KK = I
P = D( I )
DO 50 J = II, N
IF( D( J ).GT.P ) THEN
KK = J
P = D( J )
END IF
50 CONTINUE
IF( KK.NE.I ) THEN
D( KK ) = D( I )
D( I ) = P
IF( ICOMPQ.EQ.1 ) THEN
IQ( I ) = KK
ELSE IF( ICOMPQ.EQ.2 ) THEN
CALL SSWAP( N, U( 1, I ), 1, U( 1, KK ), 1 )
CALL SSWAP( N, VT( I, 1 ), LDVT, VT( KK, 1 ), LDVT )
END IF
ELSE IF( ICOMPQ.EQ.1 ) THEN
IQ( I ) = I
END IF
60 CONTINUE
*
* If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO
*
IF( ICOMPQ.EQ.1 ) THEN
IF( IUPLO.EQ.1 ) THEN
IQ( N ) = 1
ELSE
IQ( N ) = 0
END IF
END IF
*
* If B is lower bidiagonal, update U by those Givens rotations
* which rotated B to be upper bidiagonal
*
IF( ( IUPLO.EQ.2 ) .AND. ( ICOMPQ.EQ.2 ) ) THEN
OPS = OPS + REAL( 6*( N-1 )*N )
CALL SLASR( 'L', 'V', 'B', N, N, WORK( 1 ), WORK( N ), U, LDU )
END IF
*
RETURN
*
* End of SBDSDC
*
END
SUBROUTINE SBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U,
$ LDU, C, LDC, WORK, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU
* ..
* .. Array Arguments ..
REAL C( LDC, * ), D( * ), E( * ), U( LDU, * ),
$ VT( LDVT, * ), WORK( * )
* ..
* Common block to return operation count and iteration count
* ITCNT is initialized to 0, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SBDSQR computes the singular value decomposition (SVD) of a real
* N-by-N (upper or lower) bidiagonal matrix B: B = Q * S * P' (P'
* denotes the transpose of P), where S is a diagonal matrix with
* non-negative diagonal elements (the singular values of B), and Q
* and P are orthogonal matrices.
*
* The routine computes S, and optionally computes U * Q, P' * VT,
* or Q' * C, for given real input matrices U, VT, and C.
*
* See "Computing Small Singular Values of Bidiagonal Matrices With
* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,
* no. 5, pp. 873-912, Sept 1990) and
* "Accurate singular values and differential qd algorithms," by
* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics
* Department, University of California at Berkeley, July 1992
* for a detailed description of the algorithm.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': B is upper bidiagonal;
* = 'L': B is lower bidiagonal.
*
* N (input) INTEGER
* The order of the matrix B. N >= 0.
*
* NCVT (input) INTEGER
* The number of columns of the matrix VT. NCVT >= 0.
*
* NRU (input) INTEGER
* The number of rows of the matrix U. NRU >= 0.
*
* NCC (input) INTEGER
* The number of columns of the matrix C. NCC >= 0.
*
* D (input/output) REAL array, dimension (N)
* On entry, the n diagonal elements of the bidiagonal matrix B.
* On exit, if INFO=0, the singular values of B in decreasing
* order.
*
* E (input/output) REAL array, dimension (N)
* On entry, the elements of E contain the
* offdiagonal elements of the bidiagonal matrix whose SVD
* is desired. On normal exit (INFO = 0), E is destroyed.
* If the algorithm does not converge (INFO > 0), D and E
* will contain the diagonal and superdiagonal elements of a
* bidiagonal matrix orthogonally equivalent to the one given
* as input. E(N) is used for workspace.
*
* VT (input/output) REAL array, dimension (LDVT, NCVT)
* On entry, an N-by-NCVT matrix VT.
* On exit, VT is overwritten by P' * VT.
* VT is not referenced if NCVT = 0.
*
* LDVT (input) INTEGER
* The leading dimension of the array VT.
* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.
*
* U (input/output) REAL array, dimension (LDU, N)
* On entry, an NRU-by-N matrix U.
* On exit, U is overwritten by U * Q.
* U is not referenced if NRU = 0.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= max(1,NRU).
*
* C (input/output) REAL array, dimension (LDC, NCC)
* On entry, an N-by-NCC matrix C.
* On exit, C is overwritten by Q' * C.
* C is not referenced if NCC = 0.
*
* LDC (input) INTEGER
* The leading dimension of the array C.
* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.
*
* WORK (workspace) REAL array, dimension (4*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: If INFO = -i, the i-th argument had an illegal value
* > 0: the algorithm did not converge; D and E contain the
* elements of a bidiagonal matrix which is orthogonally
* similar to the input matrix B; if INFO = i, i
* elements of E have not converged to zero.
*
* Internal Parameters
* ===================
*
* TOLMUL REAL, default = max(10,min(100,EPS**(-1/8)))
* TOLMUL controls the convergence criterion of the QR loop.
* If it is positive, TOLMUL*EPS is the desired relative
* precision in the computed singular values.
* If it is negative, abs(TOLMUL*EPS*sigma_max) is the
* desired absolute accuracy in the computed singular
* values (corresponds to relative accuracy
* abs(TOLMUL*EPS) in the largest singular value.
* abs(TOLMUL) should be between 1 and 1/EPS, and preferably
* between 10 (for fast convergence) and .1/EPS
* (for there to be some accuracy in the results).
* Default is to lose at either one eighth or 2 of the
* available decimal digits in each computed singular value
* (whichever is smaller).
*
* MAXITR INTEGER, default = 6
* MAXITR controls the maximum number of passes of the
* algorithm through its inner loop. The algorithms stops
* (and so fails to converge) if the number of passes
* through the inner loop exceeds MAXITR*N**2.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
REAL ONE
PARAMETER ( ONE = 1.0E0 )
REAL NEGONE
PARAMETER ( NEGONE = -1.0E0 )
REAL HNDRTH
PARAMETER ( HNDRTH = 0.01E0 )
REAL TEN
PARAMETER ( TEN = 10.0E0 )
REAL HNDRD
PARAMETER ( HNDRD = 100.0E0 )
REAL MEIGTH
PARAMETER ( MEIGTH = -0.125E0 )
INTEGER MAXITR
PARAMETER ( MAXITR = 6 )
* ..
* .. Local Scalars ..
LOGICAL LOWER, ROTATE
INTEGER I, IDIR, ISUB, ITER, J, LL, LLL, M, MAXIT, NM1,
$ NM12, NM13, OLDLL, OLDM
REAL ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU,
$ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL,
$ SINR, SLL, SMAX, SMIN, SMINL, SMINLO, SMINOA,
$ SN, THRESH, TOL, TOLMUL, UNFL
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH
EXTERNAL LSAME, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SLARTG, SLAS2, SLASQ1, SLASR, SLASV2, SROT,
$ SSCAL, SSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
LOWER = LSAME( UPLO, 'L' )
IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LOWER ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NCVT.LT.0 ) THEN
INFO = -3
ELSE IF( NRU.LT.0 ) THEN
INFO = -4
ELSE IF( NCC.LT.0 ) THEN
INFO = -5
ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR.
$ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN
INFO = -9
ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN
INFO = -11
ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR.
$ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN
INFO = -13
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SBDSQR', -INFO )
RETURN
END IF
IF( N.EQ.0 )
$ RETURN
IF( N.EQ.1 )
$ GO TO 160
*
* ROTATE is true if any singular vectors desired, false otherwise
*
ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 )
*
* If no singular vectors desired, use qd algorithm
*
IF( .NOT.ROTATE ) THEN
CALL SLASQ1( N, D, E, WORK, INFO )
RETURN
END IF
*
NM1 = N - 1
NM12 = NM1 + NM1
NM13 = NM12 + NM1
IDIR = 0
*
* Get machine constants
*
EPS = SLAMCH( 'Epsilon' )
UNFL = SLAMCH( 'Safe minimum' )
*
* If matrix lower bidiagonal, rotate to be upper bidiagonal
* by applying Givens rotations on the left
*
IF( LOWER ) THEN
OPS = OPS + REAL( N-1 )*( 8+6*( NRU+NCC ) )
DO 10 I = 1, N - 1
CALL SLARTG( D( I ), E( I ), CS, SN, R )
D( I ) = R
E( I ) = SN*D( I+1 )
D( I+1 ) = CS*D( I+1 )
WORK( I ) = CS
WORK( NM1+I ) = SN
10 CONTINUE
*
* Update singular vectors if desired
*
IF( NRU.GT.0 )
$ CALL SLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ), WORK( N ), U,
$ LDU )
IF( NCC.GT.0 )
$ CALL SLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ), WORK( N ), C,
$ LDC )
END IF
*
* Compute singular values to relative accuracy TOL
* (By setting TOL to be negative, algorithm will compute
* singular values to absolute accuracy ABS(TOL)*norm(input matrix))
*
OPS = OPS + 4
TOLMUL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) )
TOL = TOLMUL*EPS
*
* Compute approximate maximum, minimum singular values
*
SMAX = ZERO
DO 20 I = 1, N
SMAX = MAX( SMAX, ABS( D( I ) ) )
20 CONTINUE
DO 30 I = 1, N - 1
SMAX = MAX( SMAX, ABS( E( I ) ) )
30 CONTINUE
SMINL = ZERO
IF( TOL.GE.ZERO ) THEN
*
* Relative accuracy desired
*
SMINOA = ABS( D( 1 ) )
IF( SMINOA.EQ.ZERO )
$ GO TO 50
MU = SMINOA
OPS = OPS + 3*N - 1
DO 40 I = 2, N
MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) )
SMINOA = MIN( SMINOA, MU )
IF( SMINOA.EQ.ZERO )
$ GO TO 50
40 CONTINUE
50 CONTINUE
SMINOA = SMINOA / SQRT( REAL( N ) )
THRESH = MAX( TOL*SMINOA, MAXITR*N*N*UNFL )
ELSE
*
* Absolute accuracy desired
*
THRESH = MAX( ABS( TOL )*SMAX, MAXITR*N*N*UNFL )
END IF
*
* Prepare for main iteration loop for the singular values
* (MAXIT is the maximum number of passes through the inner
* loop permitted before nonconvergence signalled.)
*
MAXIT = MAXITR*N*N
ITER = 0
OLDLL = -1
OLDM = -1
*
* M points to last element of unconverged part of matrix
*
M = N
*
* Begin main iteration loop
*
60 CONTINUE
*
* Check for convergence or exceeding iteration count
*
IF( M.LE.1 )
$ GO TO 160
IF( ITER.GT.MAXIT )
$ GO TO 200
*
* Find diagonal block of matrix to work on
*
IF( TOL.LT.ZERO .AND. ABS( D( M ) ).LE.THRESH )
$ D( M ) = ZERO
SMAX = ABS( D( M ) )
SMIN = SMAX
DO 70 LLL = 1, M - 1
LL = M - LLL
ABSS = ABS( D( LL ) )
ABSE = ABS( E( LL ) )
IF( TOL.LT.ZERO .AND. ABSS.LE.THRESH )
$ D( LL ) = ZERO
IF( ABSE.LE.THRESH )
$ GO TO 80
SMIN = MIN( SMIN, ABSS )
SMAX = MAX( SMAX, ABSS, ABSE )
70 CONTINUE
LL = 0
GO TO 90
80 CONTINUE
E( LL ) = ZERO
*
* Matrix splits since E(LL) = 0
*
IF( LL.EQ.M-1 ) THEN
*
* Convergence of bottom singular value, return to top of loop
*
M = M - 1
GO TO 60
END IF
90 CONTINUE
LL = LL + 1
*
* E(LL) through E(M-1) are nonzero, E(LL-1) is zero
*
IF( LL.EQ.M-1 ) THEN
*
* 2 by 2 block, handle separately
*
OPS = OPS + 37 + 6*( NCVT+NRU+NCC )
CALL SLASV2( D( M-1 ), E( M-1 ), D( M ), SIGMN, SIGMX, SINR,
$ COSR, SINL, COSL )
D( M-1 ) = SIGMX
E( M-1 ) = ZERO
D( M ) = SIGMN
*
* Compute singular vectors, if desired
*
IF( NCVT.GT.0 )
$ CALL SROT( NCVT, VT( M-1, 1 ), LDVT, VT( M, 1 ), LDVT, COSR,
$ SINR )
IF( NRU.GT.0 )
$ CALL SROT( NRU, U( 1, M-1 ), 1, U( 1, M ), 1, COSL, SINL )
IF( NCC.GT.0 )
$ CALL SROT( NCC, C( M-1, 1 ), LDC, C( M, 1 ), LDC, COSL,
$ SINL )
M = M - 2
GO TO 60
END IF
*
* If working on new submatrix, choose shift direction
* (from larger end diagonal element towards smaller)
*
IF( LL.GT.OLDM .OR. M.LT.OLDLL ) THEN
IF( ABS( D( LL ) ).GE.ABS( D( M ) ) ) THEN
*
* Chase bulge from top (big end) to bottom (small end)
*
IDIR = 1
ELSE
*
* Chase bulge from bottom (big end) to top (small end)
*
IDIR = 2
END IF
END IF
*
* Apply convergence tests
*
IF( IDIR.EQ.1 ) THEN
*
* Run convergence test in forward direction
* First apply standard test to bottom of matrix
*
OPS = OPS + 1
IF( ABS( E( M-1 ) ).LE.ABS( TOL )*ABS( D( M ) ) .OR.
$ ( TOL.LT.ZERO .AND. ABS( E( M-1 ) ).LE.THRESH ) ) THEN
E( M-1 ) = ZERO
GO TO 60
END IF
*
IF( TOL.GE.ZERO ) THEN
*
* If relative accuracy desired,
* apply convergence criterion forward
*
MU = ABS( D( LL ) )
SMINL = MU
DO 100 LLL = LL, M - 1
IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
E( LLL ) = ZERO
GO TO 60
END IF
SMINLO = SMINL
OPS = OPS + 4
MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
SMINL = MIN( SMINL, MU )
100 CONTINUE
END IF
*
ELSE
*
* Run convergence test in backward direction
* First apply standard test to top of matrix
*
OPS = OPS + 1
IF( ABS( E( LL ) ).LE.ABS( TOL )*ABS( D( LL ) ) .OR.
$ ( TOL.LT.ZERO .AND. ABS( E( LL ) ).LE.THRESH ) ) THEN
E( LL ) = ZERO
GO TO 60
END IF
*
IF( TOL.GE.ZERO ) THEN
*
* If relative accuracy desired,
* apply convergence criterion backward
*
MU = ABS( D( M ) )
SMINL = MU
DO 110 LLL = M - 1, LL, -1
IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
E( LLL ) = ZERO
GO TO 60
END IF
SMINLO = SMINL
OPS = OPS + 4
MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
SMINL = MIN( SMINL, MU )
110 CONTINUE
END IF
END IF
OLDLL = LL
OLDM = M
*
* Compute shift. First, test if shifting would ruin relative
* accuracy, and if so set the shift to zero.
*
OPS = OPS + 4
IF( TOL.GE.ZERO .AND. N*TOL*( SMINL / SMAX ).LE.
$ MAX( EPS, HNDRTH*TOL ) ) THEN
*
* Use a zero shift to avoid loss of relative accuracy
*
SHIFT = ZERO
ELSE
*
* Compute the shift from 2-by-2 block at end of matrix
*
OPS = OPS + 20
IF( IDIR.EQ.1 ) THEN
SLL = ABS( D( LL ) )
CALL SLAS2( D( M-1 ), E( M-1 ), D( M ), SHIFT, R )
ELSE
SLL = ABS( D( M ) )
CALL SLAS2( D( LL ), E( LL ), D( LL+1 ), SHIFT, R )
END IF
*
* Test if shift negligible, and if so set to zero
*
IF( SLL.GT.ZERO ) THEN
IF( ( SHIFT / SLL )**2.LT.EPS )
$ SHIFT = ZERO
END IF
END IF
*
* Increment iteration count
*
ITER = ITER + M - LL
*
* If SHIFT = 0, do simplified QR iteration
*
IF( SHIFT.EQ.ZERO ) THEN
OPS = OPS + 2 + REAL( M-LL )*( 20+6*( NCVT+NRU+NCC ) )
IF( IDIR.EQ.1 ) THEN
*
* Chase bulge from top to bottom
* Save cosines and sines for later singular vector updates
*
CS = ONE
OLDCS = ONE
DO 120 I = LL, M - 1
CALL SLARTG( D( I )*CS, E( I ), CS, SN, R )
IF( I.GT.LL )
$ E( I-1 ) = OLDSN*R
CALL SLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) )
WORK( I-LL+1 ) = CS
WORK( I-LL+1+NM1 ) = SN
WORK( I-LL+1+NM12 ) = OLDCS
WORK( I-LL+1+NM13 ) = OLDSN
120 CONTINUE
H = D( M )*CS
D( M ) = H*OLDCS
E( M-1 ) = H*OLDSN
*
* Update singular vectors
*
IF( NCVT.GT.0 )
$ CALL SLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ),
$ WORK( N ), VT( LL, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL SLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ),
$ WORK( NM13+1 ), U( 1, LL ), LDU )
IF( NCC.GT.0 )
$ CALL SLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ),
$ WORK( NM13+1 ), C( LL, 1 ), LDC )
*
* Test convergence
*
IF( ABS( E( M-1 ) ).LE.THRESH )
$ E( M-1 ) = ZERO
*
ELSE
*
* Chase bulge from bottom to top
* Save cosines and sines for later singular vector updates
*
CS = ONE
OLDCS = ONE
DO 130 I = M, LL + 1, -1
CALL SLARTG( D( I )*CS, E( I-1 ), CS, SN, R )
IF( I.LT.M )
$ E( I ) = OLDSN*R
CALL SLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) )
WORK( I-LL ) = CS
WORK( I-LL+NM1 ) = -SN
WORK( I-LL+NM12 ) = OLDCS
WORK( I-LL+NM13 ) = -OLDSN
130 CONTINUE
H = D( LL )*CS
D( LL ) = H*OLDCS
E( LL ) = H*OLDSN
*
* Update singular vectors
*
IF( NCVT.GT.0 )
$ CALL SLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ),
$ WORK( NM13+1 ), VT( LL, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL SLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ),
$ WORK( N ), U( 1, LL ), LDU )
IF( NCC.GT.0 )
$ CALL SLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ),
$ WORK( N ), C( LL, 1 ), LDC )
*
* Test convergence
*
IF( ABS( E( LL ) ).LE.THRESH )
$ E( LL ) = ZERO
END IF
ELSE
*
* Use nonzero shift
*
OPS = OPS + 2 + ( M-LL )*( 32+6*( NCVT+NRU+NCC ) )
IF( IDIR.EQ.1 ) THEN
*
* Chase bulge from top to bottom
* Save cosines and sines for later singular vector updates
*
F = ( ABS( D( LL ) )-SHIFT )*
$ ( SIGN( ONE, D( LL ) )+SHIFT / D( LL ) )
G = E( LL )
DO 140 I = LL, M - 1
CALL SLARTG( F, G, COSR, SINR, R )
IF( I.GT.LL )
$ E( I-1 ) = R
F = COSR*D( I ) + SINR*E( I )
E( I ) = COSR*E( I ) - SINR*D( I )
G = SINR*D( I+1 )
D( I+1 ) = COSR*D( I+1 )
CALL SLARTG( F, G, COSL, SINL, R )
D( I ) = R
F = COSL*E( I ) + SINL*D( I+1 )
D( I+1 ) = COSL*D( I+1 ) - SINL*E( I )
IF( I.LT.M-1 ) THEN
G = SINL*E( I+1 )
E( I+1 ) = COSL*E( I+1 )
END IF
WORK( I-LL+1 ) = COSR
WORK( I-LL+1+NM1 ) = SINR
WORK( I-LL+1+NM12 ) = COSL
WORK( I-LL+1+NM13 ) = SINL
140 CONTINUE
E( M-1 ) = F
*
* Update singular vectors
*
IF( NCVT.GT.0 )
$ CALL SLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ),
$ WORK( N ), VT( LL, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL SLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ),
$ WORK( NM13+1 ), U( 1, LL ), LDU )
IF( NCC.GT.0 )
$ CALL SLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ),
$ WORK( NM13+1 ), C( LL, 1 ), LDC )
*
* Test convergence
*
IF( ABS( E( M-1 ) ).LE.THRESH )
$ E( M-1 ) = ZERO
*
ELSE
*
* Chase bulge from bottom to top
* Save cosines and sines for later singular vector updates
*
F = ( ABS( D( M ) )-SHIFT )*( SIGN( ONE, D( M ) )+SHIFT /
$ D( M ) )
G = E( M-1 )
DO 150 I = M, LL + 1, -1
CALL SLARTG( F, G, COSR, SINR, R )
IF( I.LT.M )
$ E( I ) = R
F = COSR*D( I ) + SINR*E( I-1 )
E( I-1 ) = COSR*E( I-1 ) - SINR*D( I )
G = SINR*D( I-1 )
D( I-1 ) = COSR*D( I-1 )
CALL SLARTG( F, G, COSL, SINL, R )
D( I ) = R
F = COSL*E( I-1 ) + SINL*D( I-1 )
D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 )
IF( I.GT.LL+1 ) THEN
G = SINL*E( I-2 )
E( I-2 ) = COSL*E( I-2 )
END IF
WORK( I-LL ) = COSR
WORK( I-LL+NM1 ) = -SINR
WORK( I-LL+NM12 ) = COSL
WORK( I-LL+NM13 ) = -SINL
150 CONTINUE
E( LL ) = F
*
* Test convergence
*
IF( ABS( E( LL ) ).LE.THRESH )
$ E( LL ) = ZERO
*
* Update singular vectors if desired
*
IF( NCVT.GT.0 )
$ CALL SLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ),
$ WORK( NM13+1 ), VT( LL, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL SLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ),
$ WORK( N ), U( 1, LL ), LDU )
IF( NCC.GT.0 )
$ CALL SLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ),
$ WORK( N ), C( LL, 1 ), LDC )
END IF
END IF
*
* QR iteration finished, go back and check convergence
*
GO TO 60
*
* All singular values converged, so make them positive
*
160 CONTINUE
DO 170 I = 1, N
IF( D( I ).LT.ZERO ) THEN
D( I ) = -D( I )
*
* Change sign of singular vectors, if desired
*
OPS = OPS + NCVT
IF( NCVT.GT.0 )
$ CALL SSCAL( NCVT, NEGONE, VT( I, 1 ), LDVT )
END IF
170 CONTINUE
*
* Sort the singular values into decreasing order (insertion sort on
* singular values, but only one transposition per singular vector)
*
DO 190 I = 1, N - 1
*
* Scan for smallest D(I)
*
ISUB = 1
SMIN = D( 1 )
DO 180 J = 2, N + 1 - I
IF( D( J ).LE.SMIN ) THEN
ISUB = J
SMIN = D( J )
END IF
180 CONTINUE
IF( ISUB.NE.N+1-I ) THEN
*
* Swap singular values and vectors
*
D( ISUB ) = D( N+1-I )
D( N+1-I ) = SMIN
IF( NCVT.GT.0 )
$ CALL SSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ),
$ LDVT )
IF( NRU.GT.0 )
$ CALL SSWAP( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 )
IF( NCC.GT.0 )
$ CALL SSWAP( NCC, C( ISUB, 1 ), LDC, C( N+1-I, 1 ), LDC )
END IF
190 CONTINUE
GO TO 220
*
* Maximum number of iterations exceeded, failure to converge
*
200 CONTINUE
INFO = 0
DO 210 I = 1, N - 1
IF( E( I ).NE.ZERO )
$ INFO = INFO + 1
210 CONTINUE
220 CONTINUE
RETURN
*
* End of SBDSQR
*
END
SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK,
$ LWORK, IWORK, INFO )
*
* -- LAPACK driver routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
CHARACTER JOBZ
INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL A( LDA, * ), S( * ), U( LDU, * ),
$ VT( LDVT, * ), WORK( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SGESDD computes the singular value decomposition (SVD) of a real
* M-by-N matrix A, optionally computing the left and right singular
* vectors. If singular vectors are desired, it uses a
* divide-and-conquer algorithm.
*
* The SVD is written
*
* A = U * SIGMA * transpose(V)
*
* where SIGMA is an M-by-N matrix which is zero except for its
* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and
* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA
* are the singular values of A; they are real and non-negative, and
* are returned in descending order. The first min(m,n) columns of
* U and V are the left and right singular vectors of A.
*
* Note that the routine returns VT = V**T, not V.
*
* The divide and conquer algorithm makes very mild assumptions about
* floating point arithmetic. It will work on machines with a guard
* digit in add/subtract, or on those binary machines without guard
* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
* Cray-2. It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* Specifies options for computing all or part of the matrix U:
* = 'A': all M columns of U and all N rows of V**T are
* returned in the arrays U and VT;
* = 'S': the first min(M,N) columns of U and the first
* min(M,N) rows of V**T are returned in the arrays U
* and VT;
* = 'O': If M >= N, the first N columns of U are overwritten
* on the array A and all rows of V**T are returned in
* the array VT;
* otherwise, all columns of U are returned in the
* array U and the first M rows of V**T are overwritten
* in the array VT;
* = 'N': no columns of U or rows of V**T are computed.
*
* M (input) INTEGER
* The number of rows of the input matrix A. M >= 0.
*
* N (input) INTEGER
* The number of columns of the input matrix A. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit,
* if JOBZ = 'O', A is overwritten with the first N columns
* of U (the left singular vectors, stored
* columnwise) if M >= N;
* A is overwritten with the first M rows
* of V**T (the right singular vectors, stored
* rowwise) otherwise.
* if JOBZ .ne. 'O', the contents of A are destroyed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* S (output) REAL array, dimension (min(M,N))
* The singular values of A, sorted so that S(i) >= S(i+1).
*
* U (output) REAL array, dimension (LDU,UCOL)
* UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;
* UCOL = min(M,N) if JOBZ = 'S'.
* If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M
* orthogonal matrix U;
* if JOBZ = 'S', U contains the first min(M,N) columns of U
* (the left singular vectors, stored columnwise);
* if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= 1; if
* JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.
*
* VT (output) REAL array, dimension (LDVT,N)
* If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the
* N-by-N orthogonal matrix V**T;
* if JOBZ = 'S', VT contains the first min(M,N) rows of
* V**T (the right singular vectors, stored rowwise);
* if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.
*
* LDVT (input) INTEGER
* The leading dimension of the array VT. LDVT >= 1; if
* JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;
* if JOBZ = 'S', LDVT >= min(M,N).
*
* WORK (workspace/output) REAL array, dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK;
*
* LWORK (input) INTEGER
* The dimension of the array WORK. LWORK >= 1.
* If JOBZ = 'N',
* LWORK >= 3*min(M,N) + max(max(M,N),6*min(M,N)).
* If JOBZ = 'O',
* LWORK >= 3*min(M,N)*min(M,N) +
* max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)).
* If JOBZ = 'S' or 'A'
* LWORK >= 3*min(M,N)*min(M,N) +
* max(max(M,N),4*min(M,N)*min(M,N)+4*min(M,N)).
* For good performance, LWORK should generally be larger.
* If LWORK < 0 but other input arguments are legal, WORK(1)
* returns the optimal LWORK.
*
* IWORK (workspace) INTEGER array, dimension (8*min(M,N))
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: SBDSDC did not converge, updating process failed.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, WNTQA, WNTQAS, WNTQN, WNTQO, WNTQS
INTEGER BDSPAC, BLK, CHUNK, I, IE, IERR, IL,
$ IR, ISCL, ITAU, ITAUP, ITAUQ, IU, IVT, LDWKVT,
$ LDWRKL, LDWRKR, LDWRKU, MAXWRK, MINMN, MINWRK,
$ MNTHR, NB, NWORK, WRKBL
REAL ANRM, BIGNUM, EPS, SMLNUM
* ..
* .. Local Arrays ..
INTEGER IDUM( 1 )
REAL DUM( 1 )
* ..
* .. External Subroutines ..
EXTERNAL SBDSDC, SGEBRD, SGELQF, SGEMM, SGEQRF, SLACPY,
$ SLASCL, SLASET, SORGBR, SORGLQ, SORGQR, SORMBR,
$ XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
REAL SLAMCH, SLANGE, SOPBL3, SOPLA, SOPLA2
EXTERNAL ILAENV, LSAME, SLAMCH, SLANGE, SOPBL3, SOPLA,
$ SOPLA2
* ..
* .. Intrinsic Functions ..
INTRINSIC INT, MAX, MIN, REAL, SQRT
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
MINMN = MIN( M, N )
MNTHR = INT( MINMN*11.0E0 / 6.0E0 )
WNTQA = LSAME( JOBZ, 'A' )
WNTQS = LSAME( JOBZ, 'S' )
WNTQAS = WNTQA .OR. WNTQS
WNTQO = LSAME( JOBZ, 'O' )
WNTQN = LSAME( JOBZ, 'N' )
MINWRK = 1
MAXWRK = 1
LQUERY = ( LWORK.EQ.-1 )
*
IF( .NOT.( WNTQA .OR. WNTQS .OR. WNTQO .OR. WNTQN ) ) 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 = -5
ELSE IF( LDU.LT.1 .OR. ( WNTQAS .AND. LDU.LT.M ) .OR.
$ ( WNTQO .AND. M.LT.N .AND. LDU.LT.M ) ) THEN
INFO = -8
ELSE IF( LDVT.LT.1 .OR. ( WNTQA .AND. LDVT.LT.N ) .OR.
$ ( WNTQS .AND. LDVT.LT.MINMN ) .OR.
$ ( WNTQO .AND. M.GE.N .AND. LDVT.LT.N ) ) THEN
INFO = -10
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.)
*
IF( INFO.EQ.0 .AND. M.GT.0 .AND. N.GT.0 ) THEN
IF( M.GE.N ) THEN
*
* Compute space needed for SBDSDC
*
IF( WNTQN ) THEN
BDSPAC = 7*N
ELSE
BDSPAC = 3*N*N + 4*N
END IF
IF( M.GE.MNTHR ) THEN
IF( WNTQN ) THEN
*
* Path 1 (M much larger than N, JOBZ='N')
*
WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1,
$ -1 )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
MAXWRK = MAX( WRKBL, BDSPAC+N )
MINWRK = BDSPAC + N
ELSE IF( WNTQO ) THEN
*
* Path 2 (M much larger than N, JOBZ='O')
*
WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'SORGQR', ' ', M,
$ N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'SORMBR', 'QLN', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*N )
MAXWRK = WRKBL + 2*N*N
MINWRK = BDSPAC + 2*N*N + 3*N
ELSE IF( WNTQS ) THEN
*
* Path 3 (M much larger than N, JOBZ='S')
*
WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'SORGQR', ' ', M,
$ N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'SORMBR', 'QLN', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*N )
MAXWRK = WRKBL + N*N
MINWRK = BDSPAC + N*N + 3*N
ELSE IF( WNTQA ) THEN
*
* Path 4 (M much larger than N, JOBZ='A')
*
WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'SORGQR', ' ', M,
$ M, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'SORMBR', 'QLN', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*N )
MAXWRK = WRKBL + N*N
MINWRK = BDSPAC + N*N + 3*N
END IF
ELSE
*
* Path 5 (M at least N, but not much larger)
*
WRKBL = 3*N + ( M+N )*ILAENV( 1, 'SGEBRD', ' ', M, N, -1,
$ -1 )
IF( WNTQN ) THEN
MAXWRK = MAX( WRKBL, BDSPAC+3*N )
MINWRK = 3*N + MAX( M, BDSPAC )
ELSE IF( WNTQO ) THEN
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'SORMBR', 'QLN', M, N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*N )
MAXWRK = WRKBL + M*N
MINWRK = 3*N + MAX( M, N*N+BDSPAC )
ELSE IF( WNTQS ) THEN
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'SORMBR', 'QLN', M, N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) )
MAXWRK = MAX( WRKBL, BDSPAC+3*N )
MINWRK = 3*N + MAX( M, BDSPAC )
ELSE IF( WNTQA ) THEN
WRKBL = MAX( WRKBL, 3*N+M*
$ ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) )
MAXWRK = MAX( MAXWRK, BDSPAC+3*N )
MINWRK = 3*N + MAX( M, BDSPAC )
END IF
END IF
ELSE
*
* Compute space needed for SBDSDC
*
IF( WNTQN ) THEN
BDSPAC = 7*M
ELSE
BDSPAC = 3*M*M + 4*M
END IF
IF( N.GE.MNTHR ) THEN
IF( WNTQN ) THEN
*
* Path 1t (N much larger than M, JOBZ='N')
*
WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1,
$ -1 )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
MAXWRK = MAX( WRKBL, BDSPAC+M )
MINWRK = BDSPAC + M
ELSE IF( WNTQO ) THEN
*
* Path 2t (N much larger than M, JOBZ='O')
*
WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'SORGLQ', ' ', M,
$ N, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'SORMBR', 'QLN', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'SORMBR', 'PRT', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*M )
MAXWRK = WRKBL + 2*M*M
MINWRK = BDSPAC + 2*M*M + 3*M
ELSE IF( WNTQS ) THEN
*
* Path 3t (N much larger than M, JOBZ='S')
*
WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'SORGLQ', ' ', M,
$ N, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'SORMBR', 'QLN', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'SORMBR', 'PRT', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*M )
MAXWRK = WRKBL + M*M
MINWRK = BDSPAC + M*M + 3*M
ELSE IF( WNTQA ) THEN
*
* Path 4t (N much larger than M, JOBZ='A')
*
WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'SORGLQ', ' ', N,
$ N, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'SORMBR', 'QLN', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'SORMBR', 'PRT', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*M )
MAXWRK = WRKBL + M*M
MINWRK = BDSPAC + M*M + 3*M
END IF
ELSE
*
* Path 5t (N greater than M, but not much larger)
*
WRKBL = 3*M + ( M+N )*ILAENV( 1, 'SGEBRD', ' ', M, N, -1,
$ -1 )
IF( WNTQN ) THEN
MAXWRK = MAX( WRKBL, BDSPAC+3*M )
MINWRK = 3*M + MAX( N, BDSPAC )
ELSE IF( WNTQO ) THEN
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'SORMBR', 'PRT', M, N, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*M )
MAXWRK = WRKBL + M*N
MINWRK = 3*M + MAX( N, M*M+BDSPAC )
ELSE IF( WNTQS ) THEN
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'SORMBR', 'PRT', M, N, M, -1 ) )
MAXWRK = MAX( WRKBL, BDSPAC+3*M )
MINWRK = 3*M + MAX( N, BDSPAC )
ELSE IF( WNTQA ) THEN
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'SORMBR', 'PRT', N, N, M, -1 ) )
MAXWRK = MAX( WRKBL, BDSPAC+3*M )
MINWRK = 3*M + MAX( N, BDSPAC )
END IF
END IF
END IF
WORK( 1 ) = MAXWRK
END IF
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGESDD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
IF( LWORK.GE.1 )
$ WORK( 1 ) = ONE
RETURN
END IF
*
* Get machine constants
*
EPS = SLAMCH( 'P' )
SMLNUM = SQRT( SLAMCH( 'S' ) ) / EPS
BIGNUM = ONE / SMLNUM
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = SLANGE( 'M', M, N, A, LDA, DUM )
ISCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
ISCL = 1
OPS = OPS + REAL( M*N )
CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR )
ELSE IF( ANRM.GT.BIGNUM ) THEN
ISCL = 1
OPS = OPS + REAL( M*N )
CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR )
END IF
*
IF( M.GE.N ) THEN
*
* A has at least as many rows as columns. If A has sufficiently
* more rows than columns, first reduce using the QR
* decomposition (if sufficient workspace available)
*
IF( M.GE.MNTHR ) THEN
*
IF( WNTQN ) THEN
*
* Path 1 (M much larger than N, JOBZ='N')
* No singular vectors to be computed
*
ITAU = 1
NWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need 2*N, prefer N+N*NB)
*
NB = ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
OPS = OPS + SOPLA( 'SGEQRF', M, N, 0, 0, NB )
CALL SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Zero out below R
*
CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
IE = 1
ITAUQ = IE + N
ITAUP = ITAUQ + N
NWORK = ITAUP + N
*
* Bidiagonalize R in A
* (Workspace: need 4*N, prefer 3*N+2*N*NB)
*
NB = ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 )
OPS = OPS + SOPLA( 'SGEBRD', N, N, 0, 0, NB )
CALL SGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
NWORK = IE + N
*
* Perform bidiagonal SVD, computing singular values only
* (Workspace: need N+BDSPAC)
*
CALL SBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1,
$ DUM, IDUM, WORK( NWORK ), IWORK, INFO )
*
ELSE IF( WNTQO ) THEN
*
* Path 2 (M much larger than N, JOBZ = 'O')
* N left singular vectors to be overwritten on A and
* N right singular vectors to be computed in VT
*
IR = 1
*
* WORK(IR) is LDWRKR by N
*
IF( LWORK.GE.LDA*N+N*N+3*N+BDSPAC ) THEN
LDWRKR = LDA
ELSE
LDWRKR = ( LWORK-N*N-3*N-BDSPAC ) / N
END IF
ITAU = IR + LDWRKR*N
NWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
NB = ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
OPS = OPS + SOPLA( 'SGEQRF', M, N, 0, 0, NB )
CALL SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Copy R to WORK(IR), zeroing out below it
*
CALL SLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ),
$ LDWRKR )
*
* Generate Q in A
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
NB = ILAENV( 1, 'SORGQR', ' ', M, N, N, -1 )
OPS = OPS + SOPLA( 'SORGQR', M, N, N, 0, NB )
CALL SORGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
NWORK = ITAUP + N
*
* Bidiagonalize R in VT, copying result to WORK(IR)
* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
*
NB = ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 )
OPS = OPS + SOPLA( 'SGEBRD', N, N, 0, 0, NB )
CALL SGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* WORK(IU) is N by N
*
IU = NWORK
NWORK = IU + N*N
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in WORK(IU) and computing right
* singular vectors of bidiagonal matrix in VT
* (Workspace: need N+N*N+BDSPAC)
*
CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N,
$ VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Overwrite WORK(IU) by left singular vectors of R
* and VT by right singular vectors of R
* (Workspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB)
*
NB = ILAENV( 1, 'SORMBR', 'QLN', N, N, N, -1 )
OPS = OPS + SOPLA2( 'SORMBR', 'QLN', N, N, N, 0, NB )
CALL SORMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IU ), N, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
NB = ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 )
OPS = OPS + SOPLA2( 'SORMBR', 'PRT', N, N, N, 0, NB )
CALL SORMBR( 'P', 'R', 'T', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Multiply Q in A by left singular vectors of R in
* WORK(IU), storing result in WORK(IR) and copying to A
* (Workspace: need 2*N*N, prefer N*N+M*N)
*
DO 10 I = 1, M, LDWRKR
CHUNK = MIN( M-I+1, LDWRKR )
OPS = OPS + SOPBL3( 'SGEMM ', CHUNK, N, N )
CALL SGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
$ LDA, WORK( IU ), N, ZERO, WORK( IR ),
$ LDWRKR )
CALL SLACPY( 'F', CHUNK, N, WORK( IR ), LDWRKR,
$ A( I, 1 ), LDA )
10 CONTINUE
*
ELSE IF( WNTQS ) THEN
*
* Path 3 (M much larger than N, JOBZ='S')
* N left singular vectors to be computed in U and
* N right singular vectors to be computed in VT
*
IR = 1
*
* WORK(IR) is N by N
*
LDWRKR = N
ITAU = IR + LDWRKR*N
NWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
NB = ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
OPS = OPS + SOPLA( 'SGEQRF', M, N, 0, 0, NB )
CALL SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Copy R to WORK(IR), zeroing out below it
*
CALL SLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ),
$ LDWRKR )
*
* Generate Q in A
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
NB = ILAENV( 1, 'SORGQR', ' ', M, N, N, -1 )
OPS = OPS + SOPLA( 'SORGQR', M, N, N, 0, NB )
CALL SORGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
NWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IR)
* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
*
NB = MAX( 1, ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
OPS = OPS + SOPLA( 'SGEBRD', N, N, 0, 0, NB )
CALL SGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagoal matrix in U and computing right singular
* vectors of bidiagonal matrix in VT
* (Workspace: need N+BDSPAC)
*
CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT,
$ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Overwrite U by left singular vectors of R and VT
* by right singular vectors of R
* (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB)
*
NB = ILAENV( 1, 'SORMBR', 'QLN', N, N, N, -1 )
OPS = OPS + SOPLA2( 'SORMBR', 'QLN', N, N, N, 0, NB )
CALL SORMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
NB = ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 )
OPS = OPS + SOPLA2( 'SORMBR', 'PRT', N, N, N, 0, NB )
CALL SORMBR( 'P', 'R', 'T', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Multiply Q in A by left singular vectors of R in
* WORK(IR), storing result in U
* (Workspace: need N*N)
*
CALL SLACPY( 'F', N, N, U, LDU, WORK( IR ), LDWRKR )
OPS = OPS + SOPBL3( 'SGEMM ', M, N, N )
CALL SGEMM( 'N', 'N', M, N, N, ONE, A, LDA, WORK( IR ),
$ LDWRKR, ZERO, U, LDU )
*
ELSE IF( WNTQA ) THEN
*
* Path 4 (M much larger than N, JOBZ='A')
* M left singular vectors to be computed in U and
* N right singular vectors to be computed in VT
*
IU = 1
*
* WORK(IU) is N by N
*
LDWRKU = N
ITAU = IU + LDWRKU*N
NWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
NB = ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
OPS = OPS + SOPLA( 'SGEQRF', M, N, 0, 0, NB )
CALL SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
NB = ILAENV( 1, 'SORGQR', ' ', M, M, N, -1 )
OPS = OPS + SOPLA( 'SORGQR', M, M, N, 0, NB )
CALL SORGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Produce R in A, zeroing out other entries
*
CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
NWORK = ITAUP + N
*
* Bidiagonalize R in A
* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
*
NB = ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 )
OPS = OPS + SOPLA( 'SGEBRD', N, N, 0, 0, NB )
CALL SGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in WORK(IU) and computing right
* singular vectors of bidiagonal matrix in VT
* (Workspace: need N+N*N+BDSPAC)
*
CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N,
$ VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Overwrite WORK(IU) by left singular vectors of R and VT
* by right singular vectors of R
* (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB)
*
NB = ILAENV( 1, 'SORMBR', 'QLN', N, N, N, -1 )
OPS = OPS + SOPLA2( 'SORMBR', 'QLN', N, N, N, 0, NB )
CALL SORMBR( 'Q', 'L', 'N', N, N, N, A, LDA,
$ WORK( ITAUQ ), WORK( IU ), LDWRKU,
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
NB = ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 )
OPS = OPS + SOPLA2( 'SORMBR', 'PRT', N, N, N, 0, NB )
CALL SORMBR( 'P', 'R', 'T', N, N, N, A, LDA,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Multiply Q in U by left singular vectors of R in
* WORK(IU), storing result in A
* (Workspace: need N*N)
*
OPS = OPS + SOPBL3( 'SGEMM ', M, N, N )
CALL SGEMM( 'N', 'N', M, N, N, ONE, U, LDU, WORK( IU ),
$ LDWRKU, ZERO, A, LDA )
*
* Copy left singular vectors of A from A to U
*
CALL SLACPY( 'F', M, N, A, LDA, U, LDU )
*
END IF
*
ELSE
*
* M .LT. MNTHR
*
* Path 5 (M at least N, but not much larger)
* Reduce to bidiagonal form without QR decomposition
*
IE = 1
ITAUQ = IE + N
ITAUP = ITAUQ + N
NWORK = ITAUP + N
*
* Bidiagonalize A
* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB)
*
NB = MAX( 1, ILAENV( 1, 'SGEBRD', ' ', M, N, -1, -1 ) )
OPS = OPS + SOPLA( 'SGEBRD', M, N, 0, 0, NB )
CALL SGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
IF( WNTQN ) THEN
*
* Perform bidiagonal SVD, only computing singular values
* (Workspace: need N+BDSPAC)
*
CALL SBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1,
$ DUM, IDUM, WORK( NWORK ), IWORK, INFO )
ELSE IF( WNTQO ) THEN
IU = NWORK
IF( LWORK.GE.M*N+3*N+BDSPAC ) THEN
*
* WORK( IU ) is M by N
*
LDWRKU = M
NWORK = IU + LDWRKU*N
CALL SLASET( 'F', M, N, ZERO, ZERO, WORK( IU ),
$ LDWRKU )
ELSE
*
* WORK( IU ) is N by N
*
LDWRKU = N
NWORK = IU + LDWRKU*N
*
* WORK(IR) is LDWRKR by N
*
IR = NWORK
LDWRKR = ( LWORK-N*N-3*N ) / N
END IF
NWORK = IU + LDWRKU*N
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in WORK(IU) and computing right
* singular vectors of bidiagonal matrix in VT
* (Workspace: need N+N*N+BDSPAC)
*
CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ),
$ LDWRKU, VT, LDVT, DUM, IDUM, WORK( NWORK ),
$ IWORK, INFO )
*
* Overwrite VT by right singular vectors of A
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
NB = ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 )
OPS = OPS + SOPLA2( 'SORMBR', 'PRT', N, N, N, 0, NB )
CALL SORMBR( 'P', 'R', 'T', N, N, N, A, LDA,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
IF( LWORK.GE.M*N+3*N+BDSPAC ) THEN
*
* Overwrite WORK(IU) by left singular vectors of A
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
NB = ILAENV( 1, 'SORMBR', 'QLN', M, N, N, -1 )
OPS = OPS + SOPLA2( 'SORMBR', 'QLN', M, N, N, 0, NB )
CALL SORMBR( 'Q', 'L', 'N', M, N, N, A, LDA,
$ WORK( ITAUQ ), WORK( IU ), LDWRKU,
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Copy left singular vectors of A from WORK(IU) to A
*
CALL SLACPY( 'F', M, N, WORK( IU ), LDWRKU, A, LDA )
ELSE
*
* Generate Q in A
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
NB = ILAENV( 1, 'SORGBR', 'Q', M, N, N, -1 )
OPS = OPS + SOPLA2( 'SORGBR', 'Q', M, N, N, 0, NB )
CALL SORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Multiply Q in A by left singular vectors of
* bidiagonal matrix in WORK(IU), storing result in
* WORK(IR) and copying to A
* (Workspace: need 2*N*N, prefer N*N+M*N)
*
DO 20 I = 1, M, LDWRKR
CHUNK = MIN( M-I+1, LDWRKR )
OPS = OPS + SOPBL3( 'SGEMM ', CHUNK, N, N )
CALL SGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
$ LDA, WORK( IU ), LDWRKU, ZERO,
$ WORK( IR ), LDWRKR )
CALL SLACPY( 'F', CHUNK, N, WORK( IR ), LDWRKR,
$ A( I, 1 ), LDA )
20 CONTINUE
END IF
*
ELSE IF( WNTQS ) THEN
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U and computing right singular
* vectors of bidiagonal matrix in VT
* (Workspace: need N+BDSPAC)
*
CALL SLASET( 'F', M, N, ZERO, ZERO, U, LDU )
CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT,
$ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Overwrite U by left singular vectors of A and VT
* by right singular vectors of A
* (Workspace: need 3*N, prefer 2*N+N*NB)
*
NB = ILAENV( 1, 'SORMBR', 'QLN', M, N, N, -1 )
OPS = OPS + SOPLA2( 'SORMBR', 'QLN', M, N, N, 0, NB )
CALL SORMBR( 'Q', 'L', 'N', M, N, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
NB = ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 )
OPS = OPS + SOPLA2( 'SORMBR', 'PRT', N, N, N, 0, NB )
CALL SORMBR( 'P', 'R', 'T', N, N, N, A, LDA,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
ELSE IF( WNTQA ) THEN
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U and computing right singular
* vectors of bidiagonal matrix in VT
* (Workspace: need N+BDSPAC)
*
CALL SLASET( 'F', M, M, ZERO, ZERO, U, LDU )
CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT,
$ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Set the right corner of U to identity matrix
*
CALL SLASET( 'F', M-N, M-N, ZERO, ONE, U( N+1, N+1 ),
$ LDU )
*
* Overwrite U by left singular vectors of A and VT
* by right singular vectors of A
* (Workspace: need N*N+2*N+M, prefer N*N+2*N+M*NB)
*
NB = ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 )
OPS = OPS + SOPLA2( 'SORMBR', 'QLN', M, M, N, 0, NB )
CALL SORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
NB = ILAENV( 1, 'SORMBR', 'PRT', N, N, M, -1 )
OPS = OPS + SOPLA2( 'SORMBR', 'PRT', N, N, M, 0, NB )
CALL SORMBR( 'P', 'R', 'T', N, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
END IF
*
END IF
*
ELSE
*
* A has more columns than rows. If A has sufficiently more
* columns than rows, first reduce using the LQ decomposition (if
* sufficient workspace available)
*
IF( N.GE.MNTHR ) THEN
*
IF( WNTQN ) THEN
*
* Path 1t (N much larger than M, JOBZ='N')
* No singular vectors to be computed
*
ITAU = 1
NWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need 2*M, prefer M+M*NB)
*
NB = ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
OPS = OPS + SOPLA( 'SGELQF', M, N, 0, 0, NB )
CALL SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Zero out above L
*
CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA )
IE = 1
ITAUQ = IE + M
ITAUP = ITAUQ + M
NWORK = ITAUP + M
*
* Bidiagonalize L in A
* (Workspace: need 4*M, prefer 3*M+2*M*NB)
*
NB = ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 )
OPS = OPS + SOPLA( 'SGEBRD', M, M, 0, 0, NB )
CALL SGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
NWORK = IE + M
*
* Perform bidiagonal SVD, computing singular values only
* (Workspace: need M+BDSPAC)
*
CALL SBDSDC( 'U', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1,
$ DUM, IDUM, WORK( NWORK ), IWORK, INFO )
*
ELSE IF( WNTQO ) THEN
*
* Path 2t (N much larger than M, JOBZ='O')
* M right singular vectors to be overwritten on A and
* M left singular vectors to be computed in U
*
IVT = 1
*
* IVT is M by M
*
IL = IVT + M*M
IF( LWORK.GE.M*N+M*M+3*M+BDSPAC ) THEN
*
* WORK(IL) is M by N
*
LDWRKL = M
CHUNK = N
ELSE
LDWRKL = M
CHUNK = ( LWORK-M*M ) / M
END IF
ITAU = IL + LDWRKL*M
NWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
NB = ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
OPS = OPS + SOPLA( 'SGELQF', M, N, 0, 0, NB )
CALL SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Copy L to WORK(IL), zeroing about above it
*
CALL SLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL )
CALL SLASET( 'U', M-1, M-1, ZERO, ZERO,
$ WORK( IL+LDWRKL ), LDWRKL )
*
* Generate Q in A
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
NB = ILAENV( 1, 'SORGLQ', ' ', M, N, M, -1 )
OPS = OPS + SOPLA( 'SORGLQ', M, N, M, 0, NB )
CALL SORGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
NWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IL)
* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
*
NB = ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 )
OPS = OPS + SOPLA( 'SGEBRD', M, M, 0, 0, NB )
CALL SGEBRD( M, M, WORK( IL ), LDWRKL, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U, and computing right singular
* vectors of bidiagonal matrix in WORK(IVT)
* (Workspace: need M+M*M+BDSPAC)
*
CALL SBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU,
$ WORK( IVT ), M, DUM, IDUM, WORK( NWORK ),
$ IWORK, INFO )
*
* Overwrite U by left singular vectors of L and WORK(IVT)
* by right singular vectors of L
* (Workspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB)
*
NB = ILAENV( 1, 'SORMBR', 'QLN', M, M, M, -1 )
OPS = OPS + SOPLA2( 'SORMBR', 'QLN', M, M, M, 0, NB )
CALL SORMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
NB = ILAENV( 1, 'SORMBR', 'PRT', M, M, M, -1 )
OPS = OPS + SOPLA2( 'SORMBR', 'PRT', M, M, M, 0, NB )
CALL SORMBR( 'P', 'R', 'T', M, M, M, WORK( IL ), LDWRKL,
$ WORK( ITAUP ), WORK( IVT ), M,
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Multiply right singular vectors of L in WORK(IVT) by Q
* in A, storing result in WORK(IL) and copying to A
* (Workspace: need 2*M*M, prefer M*M+M*N)
*
DO 30 I = 1, N, CHUNK
BLK = MIN( N-I+1, CHUNK )
OPS = OPS + SOPBL3( 'SGEMM ', M, BLK, M )
CALL SGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IVT ), M,
$ A( 1, I ), LDA, ZERO, WORK( IL ), LDWRKL )
CALL SLACPY( 'F', M, BLK, WORK( IL ), LDWRKL,
$ A( 1, I ), LDA )
30 CONTINUE
*
ELSE IF( WNTQS ) THEN
*
* Path 3t (N much larger than M, JOBZ='S')
* M right singular vectors to be computed in VT and
* M left singular vectors to be computed in U
*
IL = 1
*
* WORK(IL) is M by M
*
LDWRKL = M
ITAU = IL + LDWRKL*M
NWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
NB = ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
OPS = OPS + SOPLA( 'SGELQF', M, N, 0, 0, NB )
CALL SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Copy L to WORK(IL), zeroing out above it
*
CALL SLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL )
CALL SLASET( 'U', M-1, M-1, ZERO, ZERO,
$ WORK( IL+LDWRKL ), LDWRKL )
*
* Generate Q in A
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
NB = ILAENV( 1, 'SORGLQ', ' ', M, N, M, -1 )
OPS = OPS + SOPLA( 'SORGLQ', M, N, M, 0, NB )
CALL SORGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
NWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IU), copying result to U
* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
*
NB = MAX( 1, ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
OPS = OPS + SOPLA( 'SGEBRD', M, M, 0, 0, NB )
CALL SGEBRD( M, M, WORK( IL ), LDWRKL, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U and computing right singular
* vectors of bidiagonal matrix in VT
* (Workspace: need M+BDSPAC)
*
CALL SBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, VT,
$ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Overwrite U by left singular vectors of L and VT
* by right singular vectors of L
* (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB)
*
NB = ILAENV( 1, 'SORMBR', 'QLN', M, M, M, -1 )
OPS = OPS + SOPLA2( 'SORMBR', 'QLN', M, M, M, 0, NB )
CALL SORMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
NB = ILAENV( 1, 'SORMBR', 'PRT', M, M, M, -1 )
OPS = OPS + SOPLA2( 'SORMBR', 'PRT', M, M, M, 0, NB )
CALL SORMBR( 'P', 'R', 'T', M, M, M, WORK( IL ), LDWRKL,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Multiply right singular vectors of L in WORK(IL) by
* Q in A, storing result in VT
* (Workspace: need M*M)
*
CALL SLACPY( 'F', M, M, VT, LDVT, WORK( IL ), LDWRKL )
OPS = OPS + SOPBL3( 'SGEMM ', M, N, M )
CALL SGEMM( 'N', 'N', M, N, M, ONE, WORK( IL ), LDWRKL,
$ A, LDA, ZERO, VT, LDVT )
*
ELSE IF( WNTQA ) THEN
*
* Path 4t (N much larger than M, JOBZ='A')
* N right singular vectors to be computed in VT and
* M left singular vectors to be computed in U
*
IVT = 1
*
* WORK(IVT) is M by M
*
LDWKVT = M
ITAU = IVT + LDWKVT*M
NWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
NB = ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
OPS = OPS + SOPLA( 'SGELQF', M, N, 0, 0, NB )
CALL SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
NB = ILAENV( 1, 'SORGLQ', ' ', N, N, M, -1 )
OPS = OPS + SOPLA( 'SORGLQ', N, N, M, 0, NB )
CALL SORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Produce L in A, zeroing out other entries
*
CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
NWORK = ITAUP + M
*
* Bidiagonalize L in A
* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
*
NB = ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 )
OPS = OPS + SOPLA( 'SGEBRD', M, M, 0, 0, NB )
CALL SGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U and computing right singular
* vectors of bidiagonal matrix in WORK(IVT)
* (Workspace: need M+M*M+BDSPAC)
*
CALL SBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU,
$ WORK( IVT ), LDWKVT, DUM, IDUM,
$ WORK( NWORK ), IWORK, INFO )
*
* Overwrite U by left singular vectors of L and WORK(IVT)
* by right singular vectors of L
* (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB)
*
NB = ILAENV( 1, 'SORMBR', 'QLN', M, M, M, -1 )
OPS = OPS + SOPLA2( 'SORMBR', 'QLN', M, M, M, 0, NB )
CALL SORMBR( 'Q', 'L', 'N', M, M, M, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
NB = ILAENV( 1, 'SORMBR', 'PRT', M, M, M, -1 )
OPS = OPS + SOPLA2( 'SORMBR', 'PRT', M, M, M, 0, NB )
CALL SORMBR( 'P', 'R', 'T', M, M, M, A, LDA,
$ WORK( ITAUP ), WORK( IVT ), LDWKVT,
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Multiply right singular vectors of L in WORK(IVT) by
* Q in VT, storing result in A
* (Workspace: need M*M)
*
OPS = OPS + SOPBL3( 'SGEMM ', M, N, M )
CALL SGEMM( 'N', 'N', M, N, M, ONE, WORK( IVT ), LDWKVT,
$ VT, LDVT, ZERO, A, LDA )
*
* Copy right singular vectors of A from A to VT
*
CALL SLACPY( 'F', M, N, A, LDA, VT, LDVT )
*
END IF
*
ELSE
*
* N .LT. MNTHR
*
* Path 5t (N greater than M, but not much larger)
* Reduce to bidiagonal form without LQ decomposition
*
IE = 1
ITAUQ = IE + M
ITAUP = ITAUQ + M
NWORK = ITAUP + M
*
* Bidiagonalize A
* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
*
NB = MAX( 1, ILAENV( 1, 'SGEBRD', ' ', M, N, -1, -1 ) )
OPS = OPS + SOPLA( 'SGEBRD', M, N, 0, 0, NB )
CALL SGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
IF( WNTQN ) THEN
*
* Perform bidiagonal SVD, only computing singular values
* (Workspace: need M+BDSPAC)
*
CALL SBDSDC( 'L', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1,
$ DUM, IDUM, WORK( NWORK ), IWORK, INFO )
ELSE IF( WNTQO ) THEN
LDWKVT = M
IVT = NWORK
IF( LWORK.GE.M*N+3*M+BDSPAC ) THEN
*
* WORK( IVT ) is M by N
*
CALL SLASET( 'F', M, N, ZERO, ZERO, WORK( IVT ),
$ LDWKVT )
NWORK = IVT + LDWKVT*N
ELSE
*
* WORK( IVT ) is M by M
*
NWORK = IVT + LDWKVT*M
IL = NWORK
*
* WORK(IL) is M by CHUNK
*
CHUNK = ( LWORK-M*M-3*M ) / M
END IF
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U and computing right singular
* vectors of bidiagonal matrix in WORK(IVT)
* (Workspace: need M*M+BDSPAC)
*
CALL SBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU,
$ WORK( IVT ), LDWKVT, DUM, IDUM,
$ WORK( NWORK ), IWORK, INFO )
*
* Overwrite U by left singular vectors of A
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
NB = ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 )
OPS = OPS + SOPLA2( 'SORMBR', 'QLN', M, M, N, 0, NB )
CALL SORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
IF( LWORK.GE.M*N+3*M+BDSPAC ) THEN
*
* Overwrite WORK(IVT) by left singular vectors of A
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
NB = ILAENV( 1, 'SORMBR', 'PRT', M, N, M, -1 )
OPS = OPS + SOPLA2( 'SORMBR', 'PRT', M, N, M, 0, NB )
CALL SORMBR( 'P', 'R', 'T', M, N, M, A, LDA,
$ WORK( ITAUP ), WORK( IVT ), LDWKVT,
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Copy right singular vectors of A from WORK(IVT) to A
*
CALL SLACPY( 'F', M, N, WORK( IVT ), LDWKVT, A, LDA )
ELSE
*
* Generate P**T in A
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
NB = ILAENV( 1, 'SORGBR', 'P', M, N, M, -1 )
OPS = OPS + SOPLA2( 'SORGBR', 'P', M, N, M, 0, NB )
CALL SORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Multiply Q in A by right singular vectors of
* bidiagonal matrix in WORK(IVT), storing result in
* WORK(IL) and copying to A
* (Workspace: need 2*M*M, prefer M*M+M*N)
*
DO 40 I = 1, N, CHUNK
BLK = MIN( N-I+1, CHUNK )
OPS = OPS + SOPBL3( 'SGEMM ', M, BLK, M )
CALL SGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IVT ),
$ LDWKVT, A( 1, I ), LDA, ZERO,
$ WORK( IL ), M )
CALL SLACPY( 'F', M, BLK, WORK( IL ), M, A( 1, I ),
$ LDA )
40 CONTINUE
END IF
ELSE IF( WNTQS ) THEN
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U and computing right singular
* vectors of bidiagonal matrix in VT
* (Workspace: need M+BDSPAC)
*
CALL SLASET( 'F', M, N, ZERO, ZERO, VT, LDVT )
CALL SBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT,
$ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Overwrite U by left singular vectors of A and VT
* by right singular vectors of A
* (Workspace: need 3*M, prefer 2*M+M*NB)
*
NB = ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 )
OPS = OPS + SOPLA2( 'SORMBR', 'QLN', M, M, N, 0, NB )
CALL SORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
NB = ILAENV( 1, 'SORMBR', 'PRT', M, N, M, -1 )
OPS = OPS + SOPLA2( 'SORMBR', 'PRT', M, N, M, 0, NB )
CALL SORMBR( 'P', 'R', 'T', M, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
ELSE IF( WNTQA ) THEN
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U and computing right singular
* vectors of bidiagonal matrix in VT
* (Workspace: need M+BDSPAC)
*
CALL SLASET( 'F', N, N, ZERO, ZERO, VT, LDVT )
CALL SBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT,
$ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Set the right corner of VT to identity matrix
*
CALL SLASET( 'F', N-M, N-M, ZERO, ONE, VT( M+1, M+1 ),
$ LDVT )
*
* Overwrite U by left singular vectors of A and VT
* by right singular vectors of A
* (Workspace: need 2*M+N, prefer 2*M+N*NB)
*
NB = ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 )
OPS = OPS + SOPLA2( 'SORMBR', 'QLN', M, M, N, 0, NB )
CALL SORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
NB = ILAENV( 1, 'SORMBR', 'PRT', N, N, M, -1 )
OPS = OPS + SOPLA2( 'SORMBR', 'PRT', N, N, M, 0, NB )
CALL SORMBR( 'P', 'R', 'T', N, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
END IF
*
END IF
*
END IF
*
* Undo scaling if necessary
*
IF( ISCL.EQ.1 ) THEN
IF( ANRM.GT.BIGNUM ) THEN
OPS = OPS + REAL( MINMN )
CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
$ IERR )
END IF
IF( ANRM.LT.SMLNUM ) THEN
OPS = OPS + REAL( MINMN )
CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
$ IERR )
END IF
END IF
*
* Return optimal workspace in WORK(1)
*
WORK( 1 ) = REAL( MAXWRK )
*
RETURN
*
* End of SGESDD
*
END
SUBROUTINE SGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q,
$ LDQ, Z, LDZ, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
CHARACTER COMPQ, COMPZ
INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
$ Z( LDZ, * )
* ..
* ---------------------- Begin Timing Code -------------------------
* Common block to return operation count and iteration count
* ITCNT is initialized to 0, OPS is only incremented
* OPST is used to accumulate small contributions to OPS
* to avoid roundoff error
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
* ----------------------- End Timing Code --------------------------
*
*
* Purpose
* =======
*
* SGGHRD reduces a pair of real matrices (A,B) to generalized upper
* Hessenberg form using orthogonal transformations, where A is a
* general matrix and B is upper triangular: Q' * A * Z = H and
* Q' * B * Z = T, where H is upper Hessenberg, T is upper triangular,
* and Q and Z are orthogonal, and ' means transpose.
*
* The orthogonal matrices Q and Z are determined as products of Givens
* rotations. They may either be formed explicitly, or they may be
* postmultiplied into input matrices Q1 and Z1, so that
*
* Q1 * A * Z1' = (Q1*Q) * H * (Z1*Z)'
* Q1 * B * Z1' = (Q1*Q) * T * (Z1*Z)'
*
* Arguments
* =========
*
* COMPQ (input) CHARACTER*1
* = 'N': do not compute Q;
* = 'I': Q is initialized to the unit matrix, and the
* orthogonal matrix Q is returned;
* = 'V': Q must contain an orthogonal matrix Q1 on entry,
* and the product Q1*Q is returned.
*
* COMPZ (input) CHARACTER*1
* = 'N': do not compute Z;
* = 'I': Z is initialized to the unit matrix, and the
* orthogonal matrix Z is returned;
* = 'V': Z must contain an orthogonal matrix Z1 on entry,
* and the product Z1*Z is returned.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* It is assumed that A is already upper triangular in rows and
* columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally set
* by a previous call to SGGBAL; otherwise they should be set
* to 1 and N respectively.
* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
*
* A (input/output) REAL array, dimension (LDA, N)
* On entry, the N-by-N general matrix to be reduced.
* On exit, the upper triangle and the first subdiagonal of A
* are overwritten with the upper Hessenberg matrix H, and the
* rest is set to zero.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input/output) REAL array, dimension (LDB, N)
* On entry, the N-by-N upper triangular matrix B.
* On exit, the upper triangular matrix T = Q' B Z. The
* elements below the diagonal are set to zero.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* Q (input/output) REAL array, dimension (LDQ, N)
* If COMPQ='N': Q is not referenced.
* If COMPQ='I': on entry, Q need not be set, and on exit it
* contains the orthogonal matrix Q, where Q'
* is the product of the Givens transformations
* which are applied to A and B on the left.
* If COMPQ='V': on entry, Q must contain an orthogonal matrix
* Q1, and on exit this is overwritten by Q1*Q.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q.
* LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.
*
* Z (input/output) REAL array, dimension (LDZ, N)
* If COMPZ='N': Z is not referenced.
* If COMPZ='I': on entry, Z need not be set, and on exit it
* contains the orthogonal matrix Z, which is
* the product of the Givens transformations
* which are applied to A and B on the right.
* If COMPZ='V': on entry, Z must contain an orthogonal matrix
* Z1, and on exit this is overwritten by Z1*Z.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z.
* LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* This routine reduces A to Hessenberg and B to triangular form by
* an unblocked reduction, as described in _Matrix_Computations_,
* by Golub and Van Loan (Johns Hopkins Press.)
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL ILQ, ILZ
INTEGER ICOMPQ, ICOMPZ, JCOL, JROW
REAL C, S, TEMP
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SLARTG, SLASET, SROT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, REAL
* ..
* .. Executable Statements ..
*
* Decode COMPQ
*
IF( LSAME( COMPQ, 'N' ) ) THEN
ILQ = .FALSE.
ICOMPQ = 1
ELSE IF( LSAME( COMPQ, 'V' ) ) THEN
ILQ = .TRUE.
ICOMPQ = 2
ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
ILQ = .TRUE.
ICOMPQ = 3
ELSE
ICOMPQ = 0
END IF
*
* Decode COMPZ
*
IF( LSAME( COMPZ, 'N' ) ) THEN
ILZ = .FALSE.
ICOMPZ = 1
ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
ILZ = .TRUE.
ICOMPZ = 2
ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
ILZ = .TRUE.
ICOMPZ = 3
ELSE
ICOMPZ = 0
END IF
*
* Test the input parameters.
*
INFO = 0
IF( ICOMPQ.LE.0 ) THEN
INFO = -1
ELSE IF( ICOMPZ.LE.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ILO.LT.1 ) THEN
INFO = -4
ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN
INFO = -11
ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN
INFO = -13
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGGHRD', -INFO )
RETURN
END IF
*
* Initialize Q and Z if desired.
*
IF( ICOMPQ.EQ.3 )
$ CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
IF( ICOMPZ.EQ.3 )
$ CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
*
* Quick return if possible
*
IF( N.LE.1 )
$ RETURN
*
* Zero out lower triangle of B
*
DO 20 JCOL = 1, N - 1
DO 10 JROW = JCOL + 1, N
B( JROW, JCOL ) = ZERO
10 CONTINUE
20 CONTINUE
*
* Reduce A and B
*
DO 40 JCOL = ILO, IHI - 2
*
DO 30 JROW = IHI, JCOL + 2, -1
*
* Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL)
*
TEMP = A( JROW-1, JCOL )
CALL SLARTG( TEMP, A( JROW, JCOL ), C, S,
$ A( JROW-1, JCOL ) )
A( JROW, JCOL ) = ZERO
CALL SROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA,
$ A( JROW, JCOL+1 ), LDA, C, S )
CALL SROT( N+2-JROW, B( JROW-1, JROW-1 ), LDB,
$ B( JROW, JROW-1 ), LDB, C, S )
IF( ILQ )
$ CALL SROT( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, C, S )
*
* Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1)
*
TEMP = B( JROW, JROW )
CALL SLARTG( TEMP, B( JROW, JROW-1 ), C, S,
$ B( JROW, JROW ) )
B( JROW, JROW-1 ) = ZERO
CALL SROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, C, S )
CALL SROT( JROW-1, B( 1, JROW ), 1, B( 1, JROW-1 ), 1, C,
$ S )
IF( ILZ )
$ CALL SROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, C, S )
30 CONTINUE
40 CONTINUE
*
* ---------------------- Begin Timing Code -------------------------
* Operation count: factor
* * number of calls to SLARTG TEMP *7
* * total number of rows/cols
* rotated in A and B TEMP*[6n + 2(ihi-ilo) + 5]/6 *6
* * rows rotated in Q TEMP*n/2 *6
* * rows rotated in Z TEMP*n/2 *6
*
TEMP = REAL( IHI-ILO )*REAL( IHI-ILO-1 )
JROW = 6*N + 2*( IHI-ILO ) + 12
IF( ILQ )
$ JROW = JROW + 3*N
IF( ILZ )
$ JROW = JROW + 3*N
OPS = OPS + REAL( JROW )*TEMP
ITCNT = ZERO
*
* ----------------------- End Timing Code --------------------------
*
RETURN
*
* End of SGGHRD
*
END
SUBROUTINE SHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB,
$ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK,
$ LWORK, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER COMPQ, COMPZ, JOB
INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, LWORK, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
$ B( LDB, * ), BETA( * ), Q( LDQ, * ), WORK( * ),
$ Z( LDZ, * )
* ..
* ---------------------- Begin Timing Code -------------------------
* Common block to return operation count and iteration count
* ITCNT is initialized to 0, OPS is only incremented
* OPST is used to accumulate small contributions to OPS
* to avoid roundoff error
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
* ----------------------- End Timing Code --------------------------
*
* Purpose
* =======
*
* SHGEQZ implements a single-/double-shift version of the QZ method for
* finding the generalized eigenvalues
*
* w(j)=(ALPHAR(j) + i*ALPHAI(j))/BETAR(j) of the equation
*
* det( A - w(i) B ) = 0
*
* In addition, the pair A,B may be reduced to generalized Schur form:
* B is upper triangular, and A is block upper triangular, where the
* diagonal blocks are either 1-by-1 or 2-by-2, the 2-by-2 blocks having
* complex generalized eigenvalues (see the description of the argument
* JOB.)
*
* If JOB='S', then the pair (A,B) is simultaneously reduced to Schur
* form by applying one orthogonal tranformation (usually called Q) on
* the left and another (usually called Z) on the right. The 2-by-2
* upper-triangular diagonal blocks of B corresponding to 2-by-2 blocks
* of A will be reduced to positive diagonal matrices. (I.e.,
* if A(j+1,j) is non-zero, then B(j+1,j)=B(j,j+1)=0 and B(j,j) and
* B(j+1,j+1) will be positive.)
*
* If JOB='E', then at each iteration, the same transformations
* are computed, but they are only applied to those parts of A and B
* which are needed to compute ALPHAR, ALPHAI, and BETAR.
*
* If JOB='S' and COMPQ and COMPZ are 'V' or 'I', then the orthogonal
* transformations used to reduce (A,B) are accumulated into the arrays
* Q and Z s.t.:
*
* Q(in) A(in) Z(in)* = Q(out) A(out) Z(out)*
* Q(in) B(in) Z(in)* = Q(out) B(out) Z(out)*
*
* Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix
* Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973),
* pp. 241--256.
*
* Arguments
* =========
*
* JOB (input) CHARACTER*1
* = 'E': compute only ALPHAR, ALPHAI, and BETA. A and B will
* not necessarily be put into generalized Schur form.
* = 'S': put A and B into generalized Schur form, as well
* as computing ALPHAR, ALPHAI, and BETA.
*
* COMPQ (input) CHARACTER*1
* = 'N': do not modify Q.
* = 'V': multiply the array Q on the right by the transpose of
* the orthogonal tranformation that is applied to the
* left side of A and B to reduce them to Schur form.
* = 'I': like COMPQ='V', except that Q will be initialized to
* the identity first.
*
* COMPZ (input) CHARACTER*1
* = 'N': do not modify Z.
* = 'V': multiply the array Z on the right by the orthogonal
* tranformation that is applied to the right side of
* A and B to reduce them to Schur form.
* = 'I': like COMPZ='V', except that Z will be initialized to
* the identity first.
*
* N (input) INTEGER
* The order of the matrices A, B, Q, and Z. N >= 0.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* It is assumed that A is already upper triangular in rows and
* columns 1:ILO-1 and IHI+1:N.
* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
*
* A (input/output) REAL array, dimension (LDA, N)
* On entry, the N-by-N upper Hessenberg matrix A. Elements
* below the subdiagonal must be zero.
* If JOB='S', then on exit A and B will have been
* simultaneously reduced to generalized Schur form.
* If JOB='E', then on exit A will have been destroyed.
* The diagonal blocks will be correct, but the off-diagonal
* portion will be meaningless.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max( 1, N ).
*
* B (input/output) REAL array, dimension (LDB, N)
* On entry, the N-by-N upper triangular matrix B. Elements
* below the diagonal must be zero. 2-by-2 blocks in B
* corresponding to 2-by-2 blocks in A will be reduced to
* positive diagonal form. (I.e., if A(j+1,j) is non-zero,
* then B(j+1,j)=B(j,j+1)=0 and B(j,j) and B(j+1,j+1) will be
* positive.)
* If JOB='S', then on exit A and B will have been
* simultaneously reduced to Schur form.
* If JOB='E', then on exit B will have been destroyed.
* Elements corresponding to diagonal blocks of A will be
* correct, but the off-diagonal portion will be meaningless.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max( 1, N ).
*
* ALPHAR (output) REAL array, dimension (N)
* ALPHAR(1:N) will be set to real parts of the diagonal
* elements of A that would result from reducing A and B to
* Schur form and then further reducing them both to triangular
* form using unitary transformations s.t. the diagonal of B
* was non-negative real. Thus, if A(j,j) is in a 1-by-1 block
* (i.e., A(j+1,j)=A(j,j+1)=0), then ALPHAR(j)=A(j,j).
* Note that the (real or complex) values
* (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the
* generalized eigenvalues of the matrix pencil A - wB.
*
* ALPHAI (output) REAL array, dimension (N)
* ALPHAI(1:N) will be set to imaginary parts of the diagonal
* elements of A that would result from reducing A and B to
* Schur form and then further reducing them both to triangular
* form using unitary transformations s.t. the diagonal of B
* was non-negative real. Thus, if A(j,j) is in a 1-by-1 block
* (i.e., A(j+1,j)=A(j,j+1)=0), then ALPHAR(j)=0.
* Note that the (real or complex) values
* (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the
* generalized eigenvalues of the matrix pencil A - wB.
*
* BETA (output) REAL array, dimension (N)
* BETA(1:N) will be set to the (real) diagonal elements of B
* that would result from reducing A and B to Schur form and
* then further reducing them both to triangular form using
* unitary transformations s.t. the diagonal of B was
* non-negative real. Thus, if A(j,j) is in a 1-by-1 block
* (i.e., A(j+1,j)=A(j,j+1)=0), then BETA(j)=B(j,j).
* Note that the (real or complex) values
* (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the
* generalized eigenvalues of the matrix pencil A - wB.
* (Note that BETA(1:N) will always be non-negative, and no
* BETAI is necessary.)
*
* Q (input/output) REAL array, dimension (LDQ, N)
* If COMPQ='N', then Q will not be referenced.
* If COMPQ='V' or 'I', then the transpose of the orthogonal
* transformations which are applied to A and B on the left
* will be applied to the array Q on the right.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= 1.
* If COMPQ='V' or 'I', then LDQ >= N.
*
* Z (input/output) REAL array, dimension (LDZ, N)
* If COMPZ='N', then Z will not be referenced.
* If COMPZ='V' or 'I', then the orthogonal transformations
* which are applied to A and B on the right will be applied
* to the array Z on the right.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1.
* If COMPZ='V' or 'I', then LDZ >= N.
*
* WORK (workspace/output) REAL array, dimension (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).
*
* 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
* = 1,...,N: the QZ iteration did not converge. (A,B) is not
* in Schur form, but ALPHAR(i), ALPHAI(i), and
* BETA(i), i=INFO+1,...,N should be correct.
* = N+1,...,2*N: the shift calculation failed. (A,B) is not
* in Schur form, but ALPHAR(i), ALPHAI(i), and
* BETA(i), i=INFO-N+1,...,N should be correct.
* > 2*N: various "impossible" errors.
*
* Further Details
* ===============
*
* Iteration counters:
*
* JITER -- counts iterations.
* IITER -- counts iterations run since ILAST was last
* changed. This is therefore reset only when a 1-by-1 or
* 2-by-2 block deflates off the bottom.
*
* =====================================================================
*
* .. Parameters ..
REAL HALF, ZERO, ONE, SAFETY
PARAMETER ( HALF = 0.5E+0, ZERO = 0.0E+0, ONE = 1.0E+0,
$ SAFETY = 1.0E+2 )
* ..
* .. Local Scalars ..
LOGICAL ILAZR2, ILAZRO, ILPIVT, ILQ, ILSCHR, ILZ,
$ LQUERY
INTEGER ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST,
$ ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER,
$ JR, MAXIT, NQ, NZ
REAL A11, A12, A1I, A1R, A21, A22, A2I, A2R, AD11,
$ AD11L, AD12, AD12L, AD21, AD21L, AD22, AD22L,
$ AD32L, AN, ANORM, ASCALE, ATOL, B11, B1A, B1I,
$ B1R, B22, B2A, B2I, B2R, BN, BNORM, BSCALE,
$ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL,
$ CQ, CR, CZ, ESHIFT, OPST, S, S1, S1INV, S2,
$ SAFMAX, SAFMIN, SCALE, SL, SQI, SQR, SR, SZI,
$ SZR, T, TAU, TEMP, TEMP2, TEMPI, TEMPR, U1,
$ U12, U12L, U2, ULP, VS, W11, W12, W21, W22,
$ WABS, WI, WR, WR2
* ..
* .. Local Arrays ..
REAL V( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANHS, SLAPY2, SLAPY3
EXTERNAL LSAME, SLAMCH, SLANHS, SLAPY2, SLAPY3
* ..
* .. External Subroutines ..
EXTERNAL SLAG2, SLARFG, SLARTG, SLASET, SLASV2, SROT,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL, SQRT
* ..
* .. Executable Statements ..
*
* Decode JOB, COMPQ, COMPZ
*
IF( LSAME( JOB, 'E' ) ) THEN
ILSCHR = .FALSE.
ISCHUR = 1
ELSE IF( LSAME( JOB, 'S' ) ) THEN
ILSCHR = .TRUE.
ISCHUR = 2
ELSE
ISCHUR = 0
END IF
*
IF( LSAME( COMPQ, 'N' ) ) THEN
ILQ = .FALSE.
ICOMPQ = 1
NQ = 0
ELSE IF( LSAME( COMPQ, 'V' ) ) THEN
ILQ = .TRUE.
ICOMPQ = 2
NQ = N
ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
ILQ = .TRUE.
ICOMPQ = 3
NQ = N
ELSE
ICOMPQ = 0
END IF
*
IF( LSAME( COMPZ, 'N' ) ) THEN
ILZ = .FALSE.
ICOMPZ = 1
NZ = 0
ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
ILZ = .TRUE.
ICOMPZ = 2
NZ = N
ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
ILZ = .TRUE.
ICOMPZ = 3
NZ = N
ELSE
ICOMPZ = 0
END IF
*
* Check Argument Values
*
INFO = 0
WORK( 1 ) = MAX( 1, N )
LQUERY = ( LWORK.EQ.-1 )
IF( ISCHUR.EQ.0 ) THEN
INFO = -1
ELSE IF( ICOMPQ.EQ.0 ) THEN
INFO = -2
ELSE IF( ICOMPZ.EQ.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( ILO.LT.1 ) THEN
INFO = -5
ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
INFO = -6
ELSE IF( LDA.LT.N ) THEN
INFO = -8
ELSE IF( LDB.LT.N ) THEN
INFO = -10
ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN
INFO = -15
ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN
INFO = -17
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -19
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SHGEQZ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 ) THEN
WORK( 1 ) = REAL( 1 )
* --------------------- Begin Timing Code -----------------------
ITCNT = ZERO
* ---------------------- End Timing Code ------------------------
RETURN
END IF
*
* Initialize Q and Z
*
IF( ICOMPQ.EQ.3 )
$ CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
IF( ICOMPZ.EQ.3 )
$ CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
*
* Machine Constants
*
IN = IHI + 1 - ILO
SAFMIN = SLAMCH( 'S' )
SAFMAX = ONE / SAFMIN
ULP = SLAMCH( 'E' )*SLAMCH( 'B' )
ANORM = SLANHS( 'F', IN, A( ILO, ILO ), LDA, WORK )
BNORM = SLANHS( 'F', IN, B( ILO, ILO ), LDB, WORK )
ATOL = MAX( SAFMIN, ULP*ANORM )
BTOL = MAX( SAFMIN, ULP*BNORM )
ASCALE = ONE / MAX( SAFMIN, ANORM )
BSCALE = ONE / MAX( SAFMIN, BNORM )
*
* Set Eigenvalues IHI+1:N
*
DO 30 J = IHI + 1, N
IF( B( J, J ).LT.ZERO ) THEN
IF( ILSCHR ) THEN
DO 10 JR = 1, J
A( JR, J ) = -A( JR, J )
B( JR, J ) = -B( JR, J )
10 CONTINUE
ELSE
A( J, J ) = -A( J, J )
B( J, J ) = -B( J, J )
END IF
IF( ILZ ) THEN
DO 20 JR = 1, N
Z( JR, J ) = -Z( JR, J )
20 CONTINUE
END IF
END IF
ALPHAR( J ) = A( J, J )
ALPHAI( J ) = ZERO
BETA( J ) = B( J, J )
30 CONTINUE
*
* ---------------------- Begin Timing Code -------------------------
* Count ops for norms, etc.
OPST = ZERO
OPS = OPS + REAL( 2*N**2+6*N )
* ----------------------- End Timing Code --------------------------
*
*
* If IHI < ILO, skip QZ steps
*
IF( IHI.LT.ILO )
$ GO TO 380
*
* MAIN QZ ITERATION LOOP
*
* Initialize dynamic indices
*
* Eigenvalues ILAST+1:N have been found.
* Column operations modify rows IFRSTM:whatever.
* Row operations modify columns whatever:ILASTM.
*
* If only eigenvalues are being computed, then
* IFRSTM is the row of the last splitting row above row ILAST;
* this is always at least ILO.
* IITER counts iterations since the last eigenvalue was found,
* to tell when to use an extraordinary shift.
* MAXIT is the maximum number of QZ sweeps allowed.
*
ILAST = IHI
IF( ILSCHR ) THEN
IFRSTM = 1
ILASTM = N
ELSE
IFRSTM = ILO
ILASTM = IHI
END IF
IITER = 0
ESHIFT = ZERO
MAXIT = 30*( IHI-ILO+1 )
*
DO 360 JITER = 1, MAXIT
*
* Split the matrix if possible.
*
* Two tests:
* 1: A(j,j-1)=0 or j=ILO
* 2: B(j,j)=0
*
IF( ILAST.EQ.ILO ) THEN
*
* Special case: j=ILAST
*
GO TO 80
ELSE
IF( ABS( A( ILAST, ILAST-1 ) ).LE.ATOL ) THEN
A( ILAST, ILAST-1 ) = ZERO
GO TO 80
END IF
END IF
*
IF( ABS( B( ILAST, ILAST ) ).LE.BTOL ) THEN
B( ILAST, ILAST ) = ZERO
GO TO 70
END IF
*
* General case: j unfl )
* __
* (sA - wB) ( CZ -SZ )
* ( SZ CZ )
*
C11R = S1*A11 - WR*B11
C11I = -WI*B11
C12 = S1*A12
C21 = S1*A21
C22R = S1*A22 - WR*B22
C22I = -WI*B22
*
IF( ABS( C11R )+ABS( C11I )+ABS( C12 ).GT.ABS( C21 )+
$ ABS( C22R )+ABS( C22I ) ) THEN
T = SLAPY3( C12, C11R, C11I )
CZ = C12 / T
SZR = -C11R / T
SZI = -C11I / T
ELSE
CZ = SLAPY2( C22R, C22I )
IF( CZ.LE.SAFMIN ) THEN
CZ = ZERO
SZR = ONE
SZI = ZERO
ELSE
TEMPR = C22R / CZ
TEMPI = C22I / CZ
T = SLAPY2( CZ, C21 )
CZ = CZ / T
SZR = -C21*TEMPR / T
SZI = C21*TEMPI / T
END IF
END IF
*
* Compute Givens rotation on left
*
* ( CQ SQ )
* ( __ ) A or B
* ( -SQ CQ )
*
AN = ABS( A11 ) + ABS( A12 ) + ABS( A21 ) + ABS( A22 )
BN = ABS( B11 ) + ABS( B22 )
WABS = ABS( WR ) + ABS( WI )
IF( S1*AN.GT.WABS*BN ) THEN
CQ = CZ*B11
SQR = SZR*B22
SQI = -SZI*B22
ELSE
A1R = CZ*A11 + SZR*A12
A1I = SZI*A12
A2R = CZ*A21 + SZR*A22
A2I = SZI*A22
CQ = SLAPY2( A1R, A1I )
IF( CQ.LE.SAFMIN ) THEN
CQ = ZERO
SQR = ONE
SQI = ZERO
ELSE
TEMPR = A1R / CQ
TEMPI = A1I / CQ
SQR = TEMPR*A2R + TEMPI*A2I
SQI = TEMPI*A2R - TEMPR*A2I
END IF
END IF
T = SLAPY3( CQ, SQR, SQI )
CQ = CQ / T
SQR = SQR / T
SQI = SQI / T
*
* Compute diagonal elements of QBZ
*
TEMPR = SQR*SZR - SQI*SZI
TEMPI = SQR*SZI + SQI*SZR
B1R = CQ*CZ*B11 + TEMPR*B22
B1I = TEMPI*B22
B1A = SLAPY2( B1R, B1I )
B2R = CQ*CZ*B22 + TEMPR*B11
B2I = -TEMPI*B11
B2A = SLAPY2( B2R, B2I )
*
* Normalize so beta > 0, and Im( alpha1 ) > 0
*
BETA( ILAST-1 ) = B1A
BETA( ILAST ) = B2A
ALPHAR( ILAST-1 ) = ( WR*B1A )*S1INV
ALPHAI( ILAST-1 ) = ( WI*B1A )*S1INV
ALPHAR( ILAST ) = ( WR*B2A )*S1INV
ALPHAI( ILAST ) = -( WI*B2A )*S1INV
*
* ------------------- Begin Timing Code ----------------------
OPST = OPST + REAL( 93 )
* -------------------- End Timing Code -----------------------
*
* Step 3: Go to next block -- exit if finished.
*
ILAST = IFIRST - 1
IF( ILAST.LT.ILO )
$ GO TO 380
*
* Reset counters
*
IITER = 0
ESHIFT = ZERO
IF( .NOT.ILSCHR ) THEN
ILASTM = ILAST
IF( IFRSTM.GT.ILAST )
$ IFRSTM = ILO
END IF
GO TO 350
ELSE
*
* Usual case: 3x3 or larger block, using Francis implicit
* double-shift
*
* 2
* Eigenvalue equation is w - c w + d = 0,
*
* -1 2 -1
* so compute 1st column of (A B ) - c A B + d
* using the formula in QZIT (from EISPACK)
*
* We assume that the block is at least 3x3
*
AD11 = ( ASCALE*A( ILAST-1, ILAST-1 ) ) /
$ ( BSCALE*B( ILAST-1, ILAST-1 ) )
AD21 = ( ASCALE*A( ILAST, ILAST-1 ) ) /
$ ( BSCALE*B( ILAST-1, ILAST-1 ) )
AD12 = ( ASCALE*A( ILAST-1, ILAST ) ) /
$ ( BSCALE*B( ILAST, ILAST ) )
AD22 = ( ASCALE*A( ILAST, ILAST ) ) /
$ ( BSCALE*B( ILAST, ILAST ) )
U12 = B( ILAST-1, ILAST ) / B( ILAST, ILAST )
AD11L = ( ASCALE*A( IFIRST, IFIRST ) ) /
$ ( BSCALE*B( IFIRST, IFIRST ) )
AD21L = ( ASCALE*A( IFIRST+1, IFIRST ) ) /
$ ( BSCALE*B( IFIRST, IFIRST ) )
AD12L = ( ASCALE*A( IFIRST, IFIRST+1 ) ) /
$ ( BSCALE*B( IFIRST+1, IFIRST+1 ) )
AD22L = ( ASCALE*A( IFIRST+1, IFIRST+1 ) ) /
$ ( BSCALE*B( IFIRST+1, IFIRST+1 ) )
AD32L = ( ASCALE*A( IFIRST+2, IFIRST+1 ) ) /
$ ( BSCALE*B( IFIRST+1, IFIRST+1 ) )
U12L = B( IFIRST, IFIRST+1 ) / B( IFIRST+1, IFIRST+1 )
*
V( 1 ) = ( AD11-AD11L )*( AD22-AD11L ) - AD12*AD21 +
$ AD21*U12*AD11L + ( AD12L-AD11L*U12L )*AD21L
V( 2 ) = ( ( AD22L-AD11L )-AD21L*U12L-( AD11-AD11L )-
$ ( AD22-AD11L )+AD21*U12 )*AD21L
V( 3 ) = AD32L*AD21L
*
ISTART = IFIRST
*
CALL SLARFG( 3, V( 1 ), V( 2 ), 1, TAU )
V( 1 ) = ONE
*
* Sweep
*
DO 290 J = ISTART, ILAST - 2
*
* All but last elements: use 3x3 Householder transforms.
*
* Zero (j-1)st column of A
*
IF( J.GT.ISTART ) THEN
V( 1 ) = A( J, J-1 )
V( 2 ) = A( J+1, J-1 )
V( 3 ) = A( J+2, J-1 )
*
CALL SLARFG( 3, A( J, J-1 ), V( 2 ), 1, TAU )
V( 1 ) = ONE
A( J+1, J-1 ) = ZERO
A( J+2, J-1 ) = ZERO
END IF
*
DO 230 JC = J, ILASTM
TEMP = TAU*( A( J, JC )+V( 2 )*A( J+1, JC )+V( 3 )*
$ A( J+2, JC ) )
A( J, JC ) = A( J, JC ) - TEMP
A( J+1, JC ) = A( J+1, JC ) - TEMP*V( 2 )
A( J+2, JC ) = A( J+2, JC ) - TEMP*V( 3 )
TEMP2 = TAU*( B( J, JC )+V( 2 )*B( J+1, JC )+V( 3 )*
$ B( J+2, JC ) )
B( J, JC ) = B( J, JC ) - TEMP2
B( J+1, JC ) = B( J+1, JC ) - TEMP2*V( 2 )
B( J+2, JC ) = B( J+2, JC ) - TEMP2*V( 3 )
230 CONTINUE
IF( ILQ ) THEN
DO 240 JR = 1, N
TEMP = TAU*( Q( JR, J )+V( 2 )*Q( JR, J+1 )+V( 3 )*
$ Q( JR, J+2 ) )
Q( JR, J ) = Q( JR, J ) - TEMP
Q( JR, J+1 ) = Q( JR, J+1 ) - TEMP*V( 2 )
Q( JR, J+2 ) = Q( JR, J+2 ) - TEMP*V( 3 )
240 CONTINUE
END IF
*
* Zero j-th column of B (see SLAGBC for details)
*
* Swap rows to pivot
*
ILPIVT = .FALSE.
TEMP = MAX( ABS( B( J+1, J+1 ) ), ABS( B( J+1, J+2 ) ) )
TEMP2 = MAX( ABS( B( J+2, J+1 ) ), ABS( B( J+2, J+2 ) ) )
IF( MAX( TEMP, TEMP2 ).LT.SAFMIN ) THEN
SCALE = ZERO
U1 = ONE
U2 = ZERO
GO TO 250
ELSE IF( TEMP.GE.TEMP2 ) THEN
W11 = B( J+1, J+1 )
W21 = B( J+2, J+1 )
W12 = B( J+1, J+2 )
W22 = B( J+2, J+2 )
U1 = B( J+1, J )
U2 = B( J+2, J )
ELSE
W21 = B( J+1, J+1 )
W11 = B( J+2, J+1 )
W22 = B( J+1, J+2 )
W12 = B( J+2, J+2 )
U2 = B( J+1, J )
U1 = B( J+2, J )
END IF
*
* Swap columns if nec.
*
IF( ABS( W12 ).GT.ABS( W11 ) ) THEN
ILPIVT = .TRUE.
TEMP = W12
TEMP2 = W22
W12 = W11
W22 = W21
W11 = TEMP
W21 = TEMP2
END IF
*
* LU-factor
*
TEMP = W21 / W11
U2 = U2 - TEMP*U1
W22 = W22 - TEMP*W12
W21 = ZERO
*
* Compute SCALE
*
SCALE = ONE
IF( ABS( W22 ).LT.SAFMIN ) THEN
SCALE = ZERO
U2 = ONE
U1 = -W12 / W11
GO TO 250
END IF
IF( ABS( W22 ).LT.ABS( U2 ) )
$ SCALE = ABS( W22 / U2 )
IF( ABS( W11 ).LT.ABS( U1 ) )
$ SCALE = MIN( SCALE, ABS( W11 / U1 ) )
*
* Solve
*
U2 = ( SCALE*U2 ) / W22
U1 = ( SCALE*U1-W12*U2 ) / W11
*
250 CONTINUE
IF( ILPIVT ) THEN
TEMP = U2
U2 = U1
U1 = TEMP
END IF
*
* Compute Householder Vector
*
T = SQRT( SCALE**2+U1**2+U2**2 )
TAU = ONE + SCALE / T
VS = -ONE / ( SCALE+T )
V( 1 ) = ONE
V( 2 ) = VS*U1
V( 3 ) = VS*U2
*
* Apply transformations from the right.
*
DO 260 JR = IFRSTM, MIN( J+3, ILAST )
TEMP = TAU*( A( JR, J )+V( 2 )*A( JR, J+1 )+V( 3 )*
$ A( JR, J+2 ) )
A( JR, J ) = A( JR, J ) - TEMP
A( JR, J+1 ) = A( JR, J+1 ) - TEMP*V( 2 )
A( JR, J+2 ) = A( JR, J+2 ) - TEMP*V( 3 )
260 CONTINUE
DO 270 JR = IFRSTM, J + 2
TEMP = TAU*( B( JR, J )+V( 2 )*B( JR, J+1 )+V( 3 )*
$ B( JR, J+2 ) )
B( JR, J ) = B( JR, J ) - TEMP
B( JR, J+1 ) = B( JR, J+1 ) - TEMP*V( 2 )
B( JR, J+2 ) = B( JR, J+2 ) - TEMP*V( 3 )
270 CONTINUE
IF( ILZ ) THEN
DO 280 JR = 1, N
TEMP = TAU*( Z( JR, J )+V( 2 )*Z( JR, J+1 )+V( 3 )*
$ Z( JR, J+2 ) )
Z( JR, J ) = Z( JR, J ) - TEMP
Z( JR, J+1 ) = Z( JR, J+1 ) - TEMP*V( 2 )
Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 )
280 CONTINUE
END IF
B( J+1, J ) = ZERO
B( J+2, J ) = ZERO
290 CONTINUE
*
* Last elements: Use Givens rotations
*
* Rotations from the left
*
J = ILAST - 1
TEMP = A( J, J-1 )
CALL SLARTG( TEMP, A( J+1, J-1 ), C, S, A( J, J-1 ) )
A( J+1, J-1 ) = ZERO
*
DO 300 JC = J, ILASTM
TEMP = C*A( J, JC ) + S*A( J+1, JC )
A( J+1, JC ) = -S*A( J, JC ) + C*A( J+1, JC )
A( J, JC ) = TEMP
TEMP2 = C*B( J, JC ) + S*B( J+1, JC )
B( J+1, JC ) = -S*B( J, JC ) + C*B( J+1, JC )
B( J, JC ) = TEMP2
300 CONTINUE
IF( ILQ ) THEN
DO 310 JR = 1, N
TEMP = C*Q( JR, J ) + S*Q( JR, J+1 )
Q( JR, J+1 ) = -S*Q( JR, J ) + C*Q( JR, J+1 )
Q( JR, J ) = TEMP
310 CONTINUE
END IF
*
* Rotations from the right.
*
TEMP = B( J+1, J+1 )
CALL SLARTG( TEMP, B( J+1, J ), C, S, B( J+1, J+1 ) )
B( J+1, J ) = ZERO
*
DO 320 JR = IFRSTM, ILAST
TEMP = C*A( JR, J+1 ) + S*A( JR, J )
A( JR, J ) = -S*A( JR, J+1 ) + C*A( JR, J )
A( JR, J+1 ) = TEMP
320 CONTINUE
DO 330 JR = IFRSTM, ILAST - 1
TEMP = C*B( JR, J+1 ) + S*B( JR, J )
B( JR, J ) = -S*B( JR, J+1 ) + C*B( JR, J )
B( JR, J+1 ) = TEMP
330 CONTINUE
IF( ILZ ) THEN
DO 340 JR = 1, N
TEMP = C*Z( JR, J+1 ) + S*Z( JR, J )
Z( JR, J ) = -S*Z( JR, J+1 ) + C*Z( JR, J )
Z( JR, J+1 ) = TEMP
340 CONTINUE
END IF
*
* ------------------- Begin Timing Code ----------------------
OPST = OPST + ( REAL( 14+30-10+52+12*( ILASTM-IFRSTM )+6*
$ ( NQ+NZ ) )+REAL( ILAST-1-ISTART )*
$ REAL( 14+24+90+20*( ILASTM-IFRSTM )+10*( NQ+NZ ) ) )
* -------------------- End Timing Code -----------------------
*
* End of Double-Shift code
*
END IF
*
GO TO 350
*
* End of iteration loop
*
350 CONTINUE
* --------------------- Begin Timing Code -----------------------
OPS = OPS + OPST
OPST = ZERO
* ---------------------- End Timing Code ------------------------
*
*
360 CONTINUE
*
* Drop-through = non-convergence
*
370 CONTINUE
* ---------------------- Begin Timing Code -------------------------
OPS = OPS + OPST
OPST = ZERO
* ----------------------- End Timing Code --------------------------
*
INFO = ILAST
GO TO 420
*
* Successful completion of all QZ steps
*
380 CONTINUE
*
* Set Eigenvalues 1:ILO-1
*
DO 410 J = 1, ILO - 1
IF( B( J, J ).LT.ZERO ) THEN
IF( ILSCHR ) THEN
DO 390 JR = 1, J
A( JR, J ) = -A( JR, J )
B( JR, J ) = -B( JR, J )
390 CONTINUE
ELSE
A( J, J ) = -A( J, J )
B( J, J ) = -B( J, J )
END IF
IF( ILZ ) THEN
DO 400 JR = 1, N
Z( JR, J ) = -Z( JR, J )
400 CONTINUE
END IF
END IF
ALPHAR( J ) = A( J, J )
ALPHAI( J ) = ZERO
BETA( J ) = B( J, J )
410 CONTINUE
*
* Normal Termination
*
INFO = 0
*
* Exit (other than argument error) -- return optimal workspace size
*
420 CONTINUE
*
* ---------------------- Begin Timing Code -------------------------
OPS = OPS + OPST
OPST = ZERO
ITCNT = JITER
* ----------------------- End Timing Code --------------------------
*
WORK( 1 ) = REAL( N )
RETURN
*
* End of SHGEQZ
*
END
SUBROUTINE SHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI,
$ VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL,
$ IFAILR, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
CHARACTER EIGSRC, INITV, SIDE
INTEGER INFO, LDH, LDVL, LDVR, M, MM, N
* ..
* .. Array Arguments ..
LOGICAL SELECT( * )
INTEGER IFAILL( * ), IFAILR( * )
REAL H( LDH, * ), VL( LDVL, * ), VR( LDVR, * ),
$ WI( * ), WORK( * ), WR( * )
* ..
* Common block to return operation count.
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SHSEIN uses inverse iteration to find specified right and/or left
* eigenvectors of a real upper Hessenberg matrix H.
*
* The right eigenvector x and the left eigenvector y of the matrix H
* corresponding to an eigenvalue w are defined by:
*
* H * x = w * x, y**h * H = w * y**h
*
* where y**h denotes the conjugate transpose of the vector y.
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* = 'R': compute right eigenvectors only;
* = 'L': compute left eigenvectors only;
* = 'B': compute both right and left eigenvectors.
*
* EIGSRC (input) CHARACTER*1
* Specifies the source of eigenvalues supplied in (WR,WI):
* = 'Q': the eigenvalues were found using SHSEQR; thus, if
* H has zero subdiagonal elements, and so is
* block-triangular, then the j-th eigenvalue can be
* assumed to be an eigenvalue of the block containing
* the j-th row/column. This property allows SHSEIN to
* perform inverse iteration on just one diagonal block.
* = 'N': no assumptions are made on the correspondence
* between eigenvalues and diagonal blocks. In this
* case, SHSEIN must always perform inverse iteration
* using the whole matrix H.
*
* INITV (input) CHARACTER*1
* = 'N': no initial vectors are supplied;
* = 'U': user-supplied initial vectors are stored in the arrays
* VL and/or VR.
*
* SELECT (input/output) LOGICAL array, dimension(N)
* Specifies the eigenvectors to be computed. To select the
* real eigenvector corresponding to a real eigenvalue WR(j),
* SELECT(j) must be set to .TRUE.. To select the complex
* eigenvector corresponding to a complex eigenvalue
* (WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)),
* either SELECT(j) or SELECT(j+1) or both must be set to
* .TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is
* .FALSE..
*
* N (input) INTEGER
* The order of the matrix H. N >= 0.
*
* H (input) REAL array, dimension (LDH,N)
* The upper Hessenberg matrix H.
*
* LDH (input) INTEGER
* The leading dimension of the array H. LDH >= max(1,N).
*
* WR (input/output) REAL array, dimension (N)
* WI (input) REAL array, dimension (N)
* On entry, the real and imaginary parts of the eigenvalues of
* H; a complex conjugate pair of eigenvalues must be stored in
* consecutive elements of WR and WI.
* On exit, WR may have been altered since close eigenvalues
* are perturbed slightly in searching for independent
* eigenvectors.
*
* VL (input/output) REAL array, dimension (LDVL,MM)
* On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must
* contain starting vectors for the inverse iteration for the
* left eigenvectors; the starting vector for each eigenvector
* must be in the same column(s) in which the eigenvector will
* be stored.
* On exit, if SIDE = 'L' or 'B', the left eigenvectors
* specified by SELECT will be stored consecutively in the
* columns of VL, in the same order as their eigenvalues. A
* complex eigenvector corresponding to a complex eigenvalue is
* stored in two consecutive columns, the first holding the real
* part and the second the imaginary part.
* If SIDE = 'R', VL is not referenced.
*
* LDVL (input) INTEGER
* The leading dimension of the array VL.
* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
*
* VR (input/output) REAL array, dimension (LDVR,MM)
* On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must
* contain starting vectors for the inverse iteration for the
* right eigenvectors; the starting vector for each eigenvector
* must be in the same column(s) in which the eigenvector will
* be stored.
* On exit, if SIDE = 'R' or 'B', the right eigenvectors
* specified by SELECT will be stored consecutively in the
* columns of VR, in the same order as their eigenvalues. A
* complex eigenvector corresponding to a complex eigenvalue is
* stored in two consecutive columns, the first holding the real
* part and the second the imaginary part.
* If SIDE = 'L', VR is not referenced.
*
* LDVR (input) INTEGER
* The leading dimension of the array VR.
* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
*
* MM (input) INTEGER
* The number of columns in the arrays VL and/or VR. MM >= M.
*
* M (output) INTEGER
* The number of columns in the arrays VL and/or VR required to
* store the eigenvectors; each selected real eigenvector
* occupies one column and each selected complex eigenvector
* occupies two columns.
*
* WORK (workspace) REAL array, dimension ((N+2)*N)
*
* IFAILL (output) INTEGER array, dimension (MM)
* If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left
* eigenvector in the i-th column of VL (corresponding to the
* eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the
* eigenvector converged satisfactorily. If the i-th and (i+1)th
* columns of VL hold a complex eigenvector, then IFAILL(i) and
* IFAILL(i+1) are set to the same value.
* If SIDE = 'R', IFAILL is not referenced.
*
* IFAILR (output) INTEGER array, dimension (MM)
* If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right
* eigenvector in the i-th column of VR (corresponding to the
* eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the
* eigenvector converged satisfactorily. If the i-th and (i+1)th
* columns of VR hold a complex eigenvector, then IFAILR(i) and
* IFAILR(i+1) are set to the same value.
* If SIDE = 'L', IFAILR is not referenced.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, i is the number of eigenvectors which
* failed to converge; see IFAILL and IFAILR for further
* details.
*
* Further Details
* ===============
*
* Each eigenvector is normalized so that the element of largest
* magnitude has magnitude 1; here the magnitude of a complex number
* (x,y) is taken to be |x|+|y|.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL BOTHV, FROMQR, LEFTV, NOINIT, PAIR, RIGHTV
INTEGER I, IINFO, K, KL, KLN, KR, KSI, KSR, LDWORK
REAL BIGNUM, EPS3, HNORM, OPST, SMLNUM, ULP, UNFL,
$ WKI, WKR
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANHS
EXTERNAL LSAME, SLAMCH, SLANHS
* ..
* .. External Subroutines ..
EXTERNAL SLAEIN, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Decode and test the input parameters.
*
BOTHV = LSAME( SIDE, 'B' )
RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV
LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV
*
FROMQR = LSAME( EIGSRC, 'Q' )
*
NOINIT = LSAME( INITV, 'N' )
*
* Set M to the number of columns required to store the selected
* eigenvectors, and standardize the array SELECT.
*
M = 0
PAIR = .FALSE.
DO 10 K = 1, N
IF( PAIR ) THEN
PAIR = .FALSE.
SELECT( K ) = .FALSE.
ELSE
IF( WI( K ).EQ.ZERO ) THEN
IF( SELECT( K ) )
$ M = M + 1
ELSE
PAIR = .TRUE.
IF( SELECT( K ) .OR. SELECT( K+1 ) ) THEN
SELECT( K ) = .TRUE.
M = M + 2
END IF
END IF
END IF
10 CONTINUE
*
INFO = 0
IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
INFO = -1
ELSE IF( .NOT.FROMQR .AND. .NOT.LSAME( EIGSRC, 'N' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOINIT .AND. .NOT.LSAME( INITV, 'U' ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN
INFO = -11
ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN
INFO = -13
ELSE IF( MM.LT.M ) THEN
INFO = -14
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SHSEIN', -INFO )
RETURN
END IF
***
* Initialize
OPST = 0
***
*
* Quick return if possible.
*
IF( N.EQ.0 )
$ RETURN
*
* Set machine-dependent constants.
*
UNFL = SLAMCH( 'Safe minimum' )
ULP = SLAMCH( 'Precision' )
SMLNUM = UNFL*( N / ULP )
BIGNUM = ( ONE-ULP ) / SMLNUM
*
LDWORK = N + 1
*
KL = 1
KLN = 0
IF( FROMQR ) THEN
KR = 0
ELSE
KR = N
END IF
KSR = 1
*
DO 120 K = 1, N
IF( SELECT( K ) ) THEN
*
* Compute eigenvector(s) corresponding to W(K).
*
IF( FROMQR ) THEN
*
* If affiliation of eigenvalues is known, check whether
* the matrix splits.
*
* Determine KL and KR such that 1 <= KL <= K <= KR <= N
* and H(KL,KL-1) and H(KR+1,KR) are zero (or KL = 1 or
* KR = N).
*
* Then inverse iteration can be performed with the
* submatrix H(KL:N,KL:N) for a left eigenvector, and with
* the submatrix H(1:KR,1:KR) for a right eigenvector.
*
DO 20 I = K, KL + 1, -1
IF( H( I, I-1 ).EQ.ZERO )
$ GO TO 30
20 CONTINUE
30 CONTINUE
KL = I
IF( K.GT.KR ) THEN
DO 40 I = K, N - 1
IF( H( I+1, I ).EQ.ZERO )
$ GO TO 50
40 CONTINUE
50 CONTINUE
KR = I
END IF
END IF
*
IF( KL.NE.KLN ) THEN
KLN = KL
*
* Compute infinity-norm of submatrix H(KL:KR,KL:KR) if it
* has not ben computed before.
*
HNORM = SLANHS( 'I', KR-KL+1, H( KL, KL ), LDH, WORK )
***
* Increment opcount for computing the norm of matrix
OPS = OPS + N*( N+1 ) / 2
***
IF( HNORM.GT.ZERO ) THEN
EPS3 = HNORM*ULP
ELSE
EPS3 = SMLNUM
END IF
END IF
*
* Perturb eigenvalue if it is close to any previous
* selected eigenvalues affiliated to the submatrix
* H(KL:KR,KL:KR). Close roots are modified by EPS3.
*
WKR = WR( K )
WKI = WI( K )
60 CONTINUE
DO 70 I = K - 1, KL, -1
IF( SELECT( I ) .AND. ABS( WR( I )-WKR )+
$ ABS( WI( I )-WKI ).LT.EPS3 ) THEN
WKR = WKR + EPS3
GO TO 60
END IF
70 CONTINUE
WR( K ) = WKR
***
* Increment opcount for loop 70
OPST = OPST + 2*( K-KL )
**
*
PAIR = WKI.NE.ZERO
IF( PAIR ) THEN
KSI = KSR + 1
ELSE
KSI = KSR
END IF
IF( LEFTV ) THEN
*
* Compute left eigenvector.
*
CALL SLAEIN( .FALSE., NOINIT, N-KL+1, H( KL, KL ), LDH,
$ WKR, WKI, VL( KL, KSR ), VL( KL, KSI ),
$ WORK, LDWORK, WORK( N*N+N+1 ), EPS3, SMLNUM,
$ BIGNUM, IINFO )
IF( IINFO.GT.0 ) THEN
IF( PAIR ) THEN
INFO = INFO + 2
ELSE
INFO = INFO + 1
END IF
IFAILL( KSR ) = K
IFAILL( KSI ) = K
ELSE
IFAILL( KSR ) = 0
IFAILL( KSI ) = 0
END IF
DO 80 I = 1, KL - 1
VL( I, KSR ) = ZERO
80 CONTINUE
IF( PAIR ) THEN
DO 90 I = 1, KL - 1
VL( I, KSI ) = ZERO
90 CONTINUE
END IF
END IF
IF( RIGHTV ) THEN
*
* Compute right eigenvector.
*
CALL SLAEIN( .TRUE., NOINIT, KR, H, LDH, WKR, WKI,
$ VR( 1, KSR ), VR( 1, KSI ), WORK, LDWORK,
$ WORK( N*N+N+1 ), EPS3, SMLNUM, BIGNUM,
$ IINFO )
IF( IINFO.GT.0 ) THEN
IF( PAIR ) THEN
INFO = INFO + 2
ELSE
INFO = INFO + 1
END IF
IFAILR( KSR ) = K
IFAILR( KSI ) = K
ELSE
IFAILR( KSR ) = 0
IFAILR( KSI ) = 0
END IF
DO 100 I = KR + 1, N
VR( I, KSR ) = ZERO
100 CONTINUE
IF( PAIR ) THEN
DO 110 I = KR + 1, N
VR( I, KSI ) = ZERO
110 CONTINUE
END IF
END IF
*
IF( PAIR ) THEN
KSR = KSR + 2
ELSE
KSR = KSR + 1
END IF
END IF
120 CONTINUE
*
***
* Compute final op count
OPS = OPS + OPST
***
RETURN
*
* End of SHSEIN
*
END
SUBROUTINE SHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z,
$ LDZ, WORK, LWORK, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER COMPZ, JOB
INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N
* ..
* .. Array Arguments ..
REAL H( LDH, * ), WI( * ), WORK( * ), WR( * ),
$ Z( LDZ, * )
* ..
* Common block to return operation count.
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SHSEQR computes the eigenvalues of a real upper Hessenberg matrix H
* and, optionally, the matrices T and Z from the Schur decomposition
* H = Z T Z**T, where T is an upper quasi-triangular matrix (the Schur
* form), and Z is the orthogonal matrix of Schur vectors.
*
* Optionally Z may be postmultiplied into an input orthogonal matrix Q,
* so that this routine can give the Schur factorization of a matrix A
* which has been reduced to the Hessenberg form H by the orthogonal
* matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.
*
* Arguments
* =========
*
* JOB (input) CHARACTER*1
* = 'E': compute eigenvalues only;
* = 'S': compute eigenvalues and the Schur form T.
*
* COMPZ (input) CHARACTER*1
* = 'N': no Schur vectors are computed;
* = 'I': Z is initialized to the unit matrix and the matrix Z
* of Schur vectors of H is returned;
* = 'V': Z must contain an orthogonal matrix Q on entry, and
* the product Q*Z is returned.
*
* N (input) INTEGER
* The order of the matrix H. N >= 0.
*
* 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. ILO and IHI are normally
* set by a previous call to SGEBAL, and then passed to SGEHRD
* when the matrix output by SGEBAL is reduced to Hessenberg
* form. Otherwise ILO and IHI should be set to 1 and N
* respectively.
* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
*
* H (input/output) REAL array, dimension (LDH,N)
* On entry, the upper Hessenberg matrix H.
* On exit, if JOB = 'S', H contains the upper quasi-triangular
* matrix T from the Schur decomposition (the Schur form);
* 2-by-2 diagonal blocks (corresponding to complex conjugate
* pairs of eigenvalues) are returned in standard form, with
* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. If JOB = 'E',
* the contents of H are unspecified on exit.
*
* LDH (input) INTEGER
* The leading dimension of the array H. LDH >= max(1,N).
*
* WR (output) REAL array, dimension (N)
* WI (output) REAL array, dimension (N)
* The real and imaginary parts, respectively, of the computed
* eigenvalues. If two eigenvalues are computed as a complex
* conjugate pair, they are stored in consecutive elements of
* WR and WI, say the i-th and (i+1)th, with WI(i) > 0 and
* WI(i+1) < 0. If JOB = 'S', the eigenvalues are stored in the
* same order as on the diagonal of the Schur form returned in
* H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2
* diagonal block, WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and
* WI(i+1) = -WI(i).
*
* Z (input/output) REAL array, dimension (LDZ,N)
* If COMPZ = 'N': Z is not referenced.
* If COMPZ = 'I': on entry, Z need not be set, and on exit, Z
* contains the orthogonal matrix Z of the Schur vectors of H.
* If COMPZ = 'V': on entry Z must contain an N-by-N matrix Q,
* which is assumed to be equal to the unit matrix except for
* the submatrix Z(ILO:IHI,ILO:IHI); on exit Z contains Q*Z.
* Normally Q is the orthogonal matrix generated by SORGHR after
* the call to SGEHRD which formed the Hessenberg matrix H.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z.
* LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise.
*
* WORK (workspace/output) REAL array, dimension (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).
*
* 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
* > 0: if INFO = i, SHSEQR failed to compute all of the
* eigenvalues in a total of 30*(IHI-ILO+1) iterations;
* elements 1:ilo-1 and i+1:n of WR and WI contain those
* eigenvalues which have been successfully computed.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
REAL CONST
PARAMETER ( CONST = 1.5E+0 )
INTEGER NSMAX, LDS
PARAMETER ( NSMAX = 15, LDS = NSMAX )
* ..
* .. Local Scalars ..
LOGICAL INITZ, LQUERY, WANTT, WANTZ
INTEGER I, I1, I2, IERR, II, ITEMP, ITN, ITS, J, K, L,
$ MAXB, NH, NR, NS, NV
REAL ABSW, OPST, OVFL, SMLNUM, TAU, TEMP, TST1, ULP,
$ UNFL
* ..
* .. Local Arrays ..
REAL S( LDS, NSMAX ), V( NSMAX+1 ), VV( NSMAX+1 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV, ISAMAX
REAL SLAMCH, SLANHS, SLAPY2
EXTERNAL LSAME, ILAENV, ISAMAX, SLAMCH, SLANHS, SLAPY2
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMV, SLABAD, SLACPY, SLAHQR, SLARFG,
$ SLARFX, SLASET, SSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Decode and test the input parameters
*
WANTT = LSAME( JOB, 'S' )
INITZ = LSAME( COMPZ, 'I' )
WANTZ = INITZ .OR. LSAME( COMPZ, 'V' )
*
INFO = 0
WORK( 1 ) = MAX( 1, N )
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN
INFO = -1
ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
INFO = -5
ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDZ.LT.1 .OR. WANTZ .AND. LDZ.LT.MAX( 1, N ) ) THEN
INFO = -11
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SHSEQR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
***
* Initialize
OPST = 0
***
*
* Initialize Z, if necessary
*
IF( INITZ )
$ CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
*
* Store the eigenvalues isolated by SGEBAL.
*
DO 10 I = 1, ILO - 1
WR( I ) = H( I, I )
WI( I ) = ZERO
10 CONTINUE
DO 20 I = IHI + 1, N
WR( I ) = H( I, I )
WI( I ) = ZERO
20 CONTINUE
*
* Quick return if possible.
*
IF( N.EQ.0 )
$ RETURN
IF( ILO.EQ.IHI ) THEN
WR( ILO ) = H( ILO, ILO )
WI( ILO ) = ZERO
RETURN
END IF
*
* Set rows and columns ILO to IHI to zero below the first
* subdiagonal.
*
DO 40 J = ILO, IHI - 2
DO 30 I = J + 2, N
H( I, J ) = ZERO
30 CONTINUE
40 CONTINUE
NH = IHI - ILO + 1
*
* Determine the order of the multi-shift QR algorithm to be used.
*
NS = ILAENV( 4, 'SHSEQR', JOB // COMPZ, N, ILO, IHI, -1 )
MAXB = ILAENV( 8, 'SHSEQR', JOB // COMPZ, N, ILO, IHI, -1 )
IF( NS.LE.2 .OR. NS.GT.NH .OR. MAXB.GE.NH ) THEN
*
* Use the standard double-shift algorithm
*
CALL SLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO,
$ IHI, Z, LDZ, INFO )
RETURN
END IF
MAXB = MAX( 3, MAXB )
NS = MIN( NS, MAXB, NSMAX )
*
* Now 2 < NS <= MAXB < NH.
*
* Set machine-dependent constants for the stopping criterion.
* If norm(H) <= sqrt(OVFL), overflow should not occur.
*
UNFL = SLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
CALL SLABAD( UNFL, OVFL )
ULP = SLAMCH( 'Precision' )
SMLNUM = UNFL*( NH / ULP )
*
* I1 and I2 are the indices of the first row and last column of H
* to which transformations must be applied. If eigenvalues only are
* being computed, I1 and I2 are set inside the main loop.
*
IF( WANTT ) THEN
I1 = 1
I2 = N
END IF
*
* ITN is the total number of multiple-shift QR iterations allowed.
*
ITN = 30*NH
*
* The main loop begins here. I is the loop index and decreases from
* IHI to ILO in steps of at most MAXB. Each iteration of the loop
* works with the active submatrix in rows and columns L to I.
* Eigenvalues I+1 to IHI have already converged. Either L = ILO or
* H(L,L-1) is negligible so that the matrix splits.
*
I = IHI
50 CONTINUE
L = ILO
IF( I.LT.ILO )
$ GO TO 170
*
* Perform multiple-shift QR iterations on rows and columns ILO to I
* until a submatrix of order at most MAXB splits off at the bottom
* because a subdiagonal element has become negligible.
*
DO 150 ITS = 0, ITN
*
* Look for a single small subdiagonal element.
*
DO 60 K = I, L + 1, -1
TST1 = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) )
IF( TST1.EQ.ZERO ) THEN
TST1 = SLANHS( '1', I-L+1, H( L, L ), LDH, WORK )
***
* Increment op count
OPS = OPS + ( I-L+1 )*( I-L+2 ) / 2
***
END IF
IF( ABS( H( K, K-1 ) ).LE.MAX( ULP*TST1, SMLNUM ) )
$ GO TO 70
60 CONTINUE
70 CONTINUE
L = K
***
* Increment op count
OPST = OPST + 3*( I-L+1 )
***
IF( L.GT.ILO ) THEN
*
* H(L,L-1) is negligible.
*
H( L, L-1 ) = ZERO
END IF
*
* Exit from loop if a submatrix of order <= MAXB has split off.
*
IF( L.GE.I-MAXB+1 )
$ GO TO 160
*
* Now the active submatrix is in rows and columns L to I. If
* eigenvalues only are being computed, only the active submatrix
* need be transformed.
*
IF( .NOT.WANTT ) THEN
I1 = L
I2 = I
END IF
*
IF( ITS.EQ.20 .OR. ITS.EQ.30 ) THEN
*
* Exceptional shifts.
*
DO 80 II = I - NS + 1, I
WR( II ) = CONST*( ABS( H( II, II-1 ) )+
$ ABS( H( II, II ) ) )
WI( II ) = ZERO
80 CONTINUE
***
* Increment op count
OPST = OPST + 2*NS
***
ELSE
*
* Use eigenvalues of trailing submatrix of order NS as shifts.
*
CALL SLACPY( 'Full', NS, NS, H( I-NS+1, I-NS+1 ), LDH, S,
$ LDS )
CALL SLAHQR( .FALSE., .FALSE., NS, 1, NS, S, LDS,
$ WR( I-NS+1 ), WI( I-NS+1 ), 1, NS, Z, LDZ,
$ IERR )
IF( IERR.GT.0 ) THEN
*
* If SLAHQR failed to compute all NS eigenvalues, use the
* unconverged diagonal elements as the remaining shifts.
*
DO 90 II = 1, IERR
WR( I-NS+II ) = S( II, II )
WI( I-NS+II ) = ZERO
90 CONTINUE
END IF
END IF
*
* Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns))
* where G is the Hessenberg submatrix H(L:I,L:I) and w is
* the vector of shifts (stored in WR and WI). The result is
* stored in the local array V.
*
V( 1 ) = ONE
DO 100 II = 2, NS + 1
V( II ) = ZERO
100 CONTINUE
NV = 1
DO 120 J = I - NS + 1, I
IF( WI( J ).GE.ZERO ) THEN
IF( WI( J ).EQ.ZERO ) THEN
*
* real shift
*
CALL SCOPY( NV+1, V, 1, VV, 1 )
CALL SGEMV( 'No transpose', NV+1, NV, ONE, H( L, L ),
$ LDH, VV, 1, -WR( J ), V, 1 )
NV = NV + 1
***
* Increment op count
OPST = OPST + 2*NV*( NV+1 ) + NV + 1
***
ELSE IF( WI( J ).GT.ZERO ) THEN
*
* complex conjugate pair of shifts
*
CALL SCOPY( NV+1, V, 1, VV, 1 )
CALL SGEMV( 'No transpose', NV+1, NV, ONE, H( L, L ),
$ LDH, V, 1, -TWO*WR( J ), VV, 1 )
ITEMP = ISAMAX( NV+1, VV, 1 )
TEMP = ONE / MAX( ABS( VV( ITEMP ) ), SMLNUM )
CALL SSCAL( NV+1, TEMP, VV, 1 )
ABSW = SLAPY2( WR( J ), WI( J ) )
TEMP = ( TEMP*ABSW )*ABSW
CALL SGEMV( 'No transpose', NV+2, NV+1, ONE,
$ H( L, L ), LDH, VV, 1, TEMP, V, 1 )
NV = NV + 2
***
* Increment op count
OPST = OPST + 4*( NV+1 )**2 + 4*NV + 9
***
END IF
*
* Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero,
* reset it to the unit vector.
*
ITEMP = ISAMAX( NV, V, 1 )
***
* Increment op count
OPST = OPST + NV
***
TEMP = ABS( V( ITEMP ) )
IF( TEMP.EQ.ZERO ) THEN
V( 1 ) = ONE
DO 110 II = 2, NV
V( II ) = ZERO
110 CONTINUE
ELSE
TEMP = MAX( TEMP, SMLNUM )
CALL SSCAL( NV, ONE / TEMP, V, 1 )
***
* Increment op count
OPST = OPST + NV
***
END IF
END IF
120 CONTINUE
*
* Multiple-shift QR step
*
DO 140 K = L, I - 1
*
* The first iteration of this loop determines a reflection G
* from the vector V and applies it from left and right to H,
* thus creating a nonzero bulge below the subdiagonal.
*
* Each subsequent iteration determines a reflection G to
* restore the Hessenberg form in the (K-1)th column, and thus
* chases the bulge one step toward the bottom of the active
* submatrix. NR is the order of G.
*
NR = MIN( NS+1, I-K+1 )
IF( K.GT.L )
$ CALL SCOPY( NR, H( K, K-1 ), 1, V, 1 )
CALL SLARFG( NR, V( 1 ), V( 2 ), 1, TAU )
***
* Increment op count
OPST = OPST + 3*NR + 9
***
IF( K.GT.L ) THEN
H( K, K-1 ) = V( 1 )
DO 130 II = K + 1, I
H( II, K-1 ) = ZERO
130 CONTINUE
END IF
V( 1 ) = ONE
*
* Apply G from the left to transform the rows of the matrix in
* columns K to I2.
*
CALL SLARFX( 'Left', NR, I2-K+1, V, TAU, H( K, K ), LDH,
$ WORK )
*
* Apply G from the right to transform the columns of the
* matrix in rows I1 to min(K+NR,I).
*
CALL SLARFX( 'Right', MIN( K+NR, I )-I1+1, NR, V, TAU,
$ H( I1, K ), LDH, WORK )
***
* Increment op count
OPS = OPS + ( 4*NR-2 )*( I2-I1+2+MIN( NR, I-K ) )
***
*
IF( WANTZ ) THEN
*
* Accumulate transformations in the matrix Z
*
CALL SLARFX( 'Right', NH, NR, V, TAU, Z( ILO, K ), LDZ,
$ WORK )
***
* Increment op count
OPS = OPS + ( 4*NR-2 )*NH
***
END IF
140 CONTINUE
*
150 CONTINUE
*
* Failure to converge in remaining number of iterations
*
INFO = I
RETURN
*
160 CONTINUE
*
* A submatrix of order <= MAXB in rows and columns L to I has split
* off. Use the double-shift QR algorithm to handle it.
*
CALL SLAHQR( WANTT, WANTZ, N, L, I, H, LDH, WR, WI, ILO, IHI, Z,
$ LDZ, INFO )
IF( INFO.GT.0 )
$ RETURN
*
* Decrement number of remaining iterations, and return to start of
* the main loop with a new value of I.
*
ITN = ITN - ITS
I = L - 1
GO TO 50
*
170 CONTINUE
***
* Compute final op count
OPS = OPS + OPST
***
WORK( 1 ) = MAX( 1, N )
RETURN
*
* End of SHSEQR
*
END
SUBROUTINE SLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL,
$ RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT,
$ NAB, WORK, IWORK, INFO )
*
* -- LAPACK auxiliary routine (instrum. to count ops. version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER IJOB, INFO, MINP, MMAX, MOUT, N, NBMIN, NITMAX
REAL ABSTOL, PIVMIN, RELTOL
* ..
* .. Array Arguments ..
INTEGER IWORK( * ), NAB( MMAX, * ), NVAL( * )
REAL AB( MMAX, * ), C( * ), D( * ), E( * ), E2( * ),
$ WORK( * )
* ..
* Common block to return operation count and iteration count
* ITCNT and OPS are only incremented (not initialized)
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*-----------------------------------------------------------------------
*
* Purpose
* =======
*
* SLAEBZ contains the iteration loops which compute and use the
* function N(w), which is the count of eigenvalues of a symmetric
* tridiagonal matrix T less than or equal to its argument w. It
* performs a choice of two types of loops:
*
* IJOB=1, followed by
* IJOB=2: It takes as input a list of intervals and returns a list of
* sufficiently small intervals whose union contains the same
* eigenvalues as the union of the original intervals.
* The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP.
* The output interval (AB(j,1),AB(j,2)] will contain
* eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT.
*
* IJOB=3: It performs a binary search in each input interval
* (AB(j,1),AB(j,2)] for a point w(j) such that
* N(w(j))=NVAL(j), and uses C(j) as the starting point of
* the search. If such a w(j) is found, then on output
* AB(j,1)=AB(j,2)=w. If no such w(j) is found, then on output
* (AB(j,1),AB(j,2)] will be a small interval containing the
* point where N(w) jumps through NVAL(j), unless that point
* lies outside the initial interval.
*
* Note that the intervals are in all cases half-open intervals,
* i.e., of the form (a,b] , which includes b but not a .
*
* To avoid underflow, the matrix should be scaled so that its largest
* element is no greater than overflow**(1/2) * underflow**(1/4)
* in absolute value. To assure the most accurate computation
* of small eigenvalues, the matrix should be scaled to be
* not much smaller than that, either.
*
* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
* Matrix", Report CS41, Computer Science Dept., Stanford
* University, July 21, 1966
*
* Note: the arguments are, in general, *not* checked for unreasonable
* values.
*
* Arguments
* =========
*
* IJOB (input) INTEGER
* Specifies what is to be done:
* = 1: Compute NAB for the initial intervals.
* = 2: Perform bisection iteration to find eigenvalues of T.
* = 3: Perform bisection iteration to invert N(w), i.e.,
* to find a point which has a specified number of
* eigenvalues of T to its left.
* Other values will cause SLAEBZ to return with INFO=-1.
*
* NITMAX (input) INTEGER
* The maximum number of "levels" of bisection to be
* performed, i.e., an interval of width W will not be made
* smaller than 2^(-NITMAX) * W. If not all intervals
* have converged after NITMAX iterations, then INFO is set
* to the number of non-converged intervals.
*
* N (input) INTEGER
* The dimension n of the tridiagonal matrix T. It must be at
* least 1.
*
* MMAX (input) INTEGER
* The maximum number of intervals. If more than MMAX intervals
* are generated, then SLAEBZ will quit with INFO=MMAX+1.
*
* MINP (input) INTEGER
* The initial number of intervals. It may not be greater than
* MMAX.
*
* NBMIN (input) INTEGER
* The smallest number of intervals that should be processed
* using a vector loop. If zero, then only the scalar loop
* will be used.
*
* ABSTOL (input) REAL
* The minimum (absolute) width of an interval. When an
* interval is narrower than ABSTOL, or than RELTOL times the
* larger (in magnitude) endpoint, then it is considered to be
* sufficiently small, i.e., converged. This must be at least
* zero.
*
* RELTOL (input) REAL
* The minimum relative width of an interval. When an interval
* is narrower than ABSTOL, or than RELTOL times the larger (in
* magnitude) endpoint, then it is considered to be
* sufficiently small, i.e., converged. Note: this should
* always be at least radix*machine epsilon.
*
* PIVMIN (input) REAL
* The minimum absolute value of a "pivot" in the Sturm
* sequence loop. This *must* be at least max |e(j)**2| *
* safe_min and at least safe_min, where safe_min is at least
* the smallest number that can divide one without overflow.
*
* D (input) REAL array, dimension (N)
* The diagonal elements of the tridiagonal matrix T.
*
* E (input) REAL array, dimension (N)
* The offdiagonal elements of the tridiagonal matrix T in
* positions 1 through N-1. E(N) is arbitrary.
*
* E2 (input) REAL array, dimension (N)
* The squares of the offdiagonal elements of the tridiagonal
* matrix T. E2(N) is ignored.
*
* NVAL (input/output) INTEGER array, dimension (MINP)
* If IJOB=1 or 2, not referenced.
* If IJOB=3, the desired values of N(w). The elements of NVAL
* will be reordered to correspond with the intervals in AB.
* Thus, NVAL(j) on output will not, in general be the same as
* NVAL(j) on input, but it will correspond with the interval
* (AB(j,1),AB(j,2)] on output.
*
* AB (input/output) REAL array, dimension (MMAX,2)
* The endpoints of the intervals. AB(j,1) is a(j), the left
* endpoint of the j-th interval, and AB(j,2) is b(j), the
* right endpoint of the j-th interval. The input intervals
* will, in general, be modified, split, and reordered by the
* calculation.
*
* C (input/output) REAL array, dimension (MMAX)
* If IJOB=1, ignored.
* If IJOB=2, workspace.
* If IJOB=3, then on input C(j) should be initialized to the
* first search point in the binary search.
*
* MOUT (output) INTEGER
* If IJOB=1, the number of eigenvalues in the intervals.
* If IJOB=2 or 3, the number of intervals output.
* If IJOB=3, MOUT will equal MINP.
*
* NAB (input/output) INTEGER array, dimension (MMAX,2)
* If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)).
* If IJOB=2, then on input, NAB(i,j) should be set. It must
* satisfy the condition:
* N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)),
* which means that in interval i only eigenvalues
* NAB(i,1)+1,...,NAB(i,2) will be considered. Usually,
* NAB(i,j)=N(AB(i,j)), from a previous call to SLAEBZ with
* IJOB=1.
* On output, NAB(i,j) will contain
* max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of
* the input interval that the output interval
* (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the
* the input values of NAB(k,1) and NAB(k,2).
* If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)),
* unless N(w) > NVAL(i) for all search points w , in which
* case NAB(i,1) will not be modified, i.e., the output
* value will be the same as the input value (modulo
* reorderings -- see NVAL and AB), or unless N(w) < NVAL(i)
* for all search points w , in which case NAB(i,2) will
* not be modified. Normally, NAB should be set to some
* distinctive value(s) before SLAEBZ is called.
*
* WORK (workspace) REAL array, dimension (MMAX)
* Workspace.
*
* IWORK (workspace) INTEGER array, dimension (MMAX)
* Workspace.
*
* INFO (output) INTEGER
* = 0: All intervals converged.
* = 1--MMAX: The last INFO intervals did not converge.
* = MMAX+1: More than MMAX intervals were generated.
*
* Further Details
* ===============
*
* This routine is intended to be called only by other LAPACK
* routines, thus the interface is less user-friendly. It is intended
* for two purposes:
*
* (a) finding eigenvalues. In this case, SLAEBZ should have one or
* more initial intervals set up in AB, and SLAEBZ should be called
* with IJOB=1. This sets up NAB, and also counts the eigenvalues.
* Intervals with no eigenvalues would usually be thrown out at
* this point. Also, if not all the eigenvalues in an interval i
* are desired, NAB(i,1) can be increased or NAB(i,2) decreased.
* For example, set NAB(i,1)=NAB(i,2)-1 to get the largest
* eigenvalue. SLAEBZ is then called with IJOB=2 and MMAX
* no smaller than the value of MOUT returned by the call with
* IJOB=1. After this (IJOB=2) call, eigenvalues NAB(i,1)+1
* through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the
* tolerance specified by ABSTOL and RELTOL.
*
* (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l).
* In this case, start with a Gershgorin interval (a,b). Set up
* AB to contain 2 search intervals, both initially (a,b). One
* NVAL element should contain f-1 and the other should contain l
* , while C should contain a and b, resp. NAB(i,1) should be -1
* and NAB(i,2) should be N+1, to flag an error if the desired
* interval does not lie in (a,b). SLAEBZ is then called with
* IJOB=3. On exit, if w(f-1) < w(f), then one of the intervals --
* j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while
* if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r
* >= 0, then the interval will have N(AB(j,1))=NAB(j,1)=f-k and
* N(AB(j,2))=NAB(j,2)=f+r. The cases w(l) < w(l+1) and
* w(l-r)=...=w(l+k) are handled similarly.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, TWO, HALF
PARAMETER ( ZERO = 0.0E0, TWO = 2.0E0,
$ HALF = 1.0E0 / TWO )
* ..
* .. Local Scalars ..
INTEGER ITMP1, ITMP2, J, JI, JIT, JP, KF, KFNEW, KL,
$ KLNEW
REAL TMP1, TMP2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Check for Errors
*
INFO = 0
IF( IJOB.LT.1 .OR. IJOB.GT.3 ) THEN
INFO = -1
RETURN
END IF
*
* Initialize NAB
*
IF( IJOB.EQ.1 ) THEN
*
* Compute the number of eigenvalues in the initial intervals.
*
MOUT = 0
CDIR$ NOVECTOR
DO 30 JI = 1, MINP
DO 20 JP = 1, 2
TMP1 = D( 1 ) - AB( JI, JP )
IF( ABS( TMP1 ).LT.PIVMIN )
$ TMP1 = -PIVMIN
NAB( JI, JP ) = 0
IF( TMP1.LE.ZERO )
$ NAB( JI, JP ) = 1
*
DO 10 J = 2, N
TMP1 = D( J ) - E2( J-1 ) / TMP1 - AB( JI, JP )
IF( ABS( TMP1 ).LT.PIVMIN )
$ TMP1 = -PIVMIN
IF( TMP1.LE.ZERO )
$ NAB( JI, JP ) = NAB( JI, JP ) + 1
10 CONTINUE
20 CONTINUE
MOUT = MOUT + NAB( JI, 2 ) - NAB( JI, 1 )
30 CONTINUE
*
* Increment opcount for determining the number of eigenvalues
* in the initial intervals.
*
OPS = OPS + MINP*2*( N-1 )*3
RETURN
END IF
*
* Initialize for loop
*
* KF and KL have the following meaning:
* Intervals 1,...,KF-1 have converged.
* Intervals KF,...,KL still need to be refined.
*
KF = 1
KL = MINP
*
* If IJOB=2, initialize C.
* If IJOB=3, use the user-supplied starting point.
*
IF( IJOB.EQ.2 ) THEN
DO 40 JI = 1, MINP
C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) )
40 CONTINUE
*
* Increment opcount for initializing C.
*
OPS = OPS + MINP*2
END IF
*
* Iteration loop
*
DO 130 JIT = 1, NITMAX
*
* Loop over intervals
*
IF( KL-KF+1.GE.NBMIN .AND. NBMIN.GT.0 ) THEN
*
* Begin of Parallel Version of the loop
*
DO 60 JI = KF, KL
*
* Compute N(c), the number of eigenvalues less than c
*
WORK( JI ) = D( 1 ) - C( JI )
IWORK( JI ) = 0
IF( WORK( JI ).LE.PIVMIN ) THEN
IWORK( JI ) = 1
WORK( JI ) = MIN( WORK( JI ), -PIVMIN )
END IF
*
DO 50 J = 2, N
WORK( JI ) = D( J ) - E2( J-1 ) / WORK( JI ) - C( JI )
IF( WORK( JI ).LE.PIVMIN ) THEN
IWORK( JI ) = IWORK( JI ) + 1
WORK( JI ) = MIN( WORK( JI ), -PIVMIN )
END IF
50 CONTINUE
60 CONTINUE
*
* Increment iteration counter.
*
ITCNT = ITCNT + KL - KF + 1
*
* Increment opcount for evaluating Sturm sequences on
* each interval.
*
OPS = OPS + ( KL-KF+1 )*( N-1 )*3
*
IF( IJOB.LE.2 ) THEN
*
* IJOB=2: Choose all intervals containing eigenvalues.
*
KLNEW = KL
DO 70 JI = KF, KL
*
* Insure that N(w) is monotone
*
IWORK( JI ) = MIN( NAB( JI, 2 ),
$ MAX( NAB( JI, 1 ), IWORK( JI ) ) )
*
* Update the Queue -- add intervals if both halves
* contain eigenvalues.
*
IF( IWORK( JI ).EQ.NAB( JI, 2 ) ) THEN
*
* No eigenvalue in the upper interval:
* just use the lower interval.
*
AB( JI, 2 ) = C( JI )
*
ELSE IF( IWORK( JI ).EQ.NAB( JI, 1 ) ) THEN
*
* No eigenvalue in the lower interval:
* just use the upper interval.
*
AB( JI, 1 ) = C( JI )
ELSE
KLNEW = KLNEW + 1
IF( KLNEW.LE.MMAX ) THEN
*
* Eigenvalue in both intervals -- add upper to
* queue.
*
AB( KLNEW, 2 ) = AB( JI, 2 )
NAB( KLNEW, 2 ) = NAB( JI, 2 )
AB( KLNEW, 1 ) = C( JI )
NAB( KLNEW, 1 ) = IWORK( JI )
AB( JI, 2 ) = C( JI )
NAB( JI, 2 ) = IWORK( JI )
ELSE
INFO = MMAX + 1
END IF
END IF
70 CONTINUE
IF( INFO.NE.0 )
$ RETURN
KL = KLNEW
ELSE
*
* IJOB=3: Binary search. Keep only the interval containing
* w s.t. N(w) = NVAL
*
DO 80 JI = KF, KL
IF( IWORK( JI ).LE.NVAL( JI ) ) THEN
AB( JI, 1 ) = C( JI )
NAB( JI, 1 ) = IWORK( JI )
END IF
IF( IWORK( JI ).GE.NVAL( JI ) ) THEN
AB( JI, 2 ) = C( JI )
NAB( JI, 2 ) = IWORK( JI )
END IF
80 CONTINUE
END IF
*
ELSE
*
* End of Parallel Version of the loop
*
* Begin of Serial Version of the loop
*
KLNEW = KL
DO 100 JI = KF, KL
*
* Compute N(w), the number of eigenvalues less than w
*
TMP1 = C( JI )
TMP2 = D( 1 ) - TMP1
ITMP1 = 0
IF( TMP2.LE.PIVMIN ) THEN
ITMP1 = 1
TMP2 = MIN( TMP2, -PIVMIN )
END IF
*
* A series of compiler directives to defeat vectorization
* for the next loop
*
*$PL$ CMCHAR=' '
CDIR$ NEXTSCALAR
C$DIR SCALAR
CDIR$ NEXT SCALAR
CVD$L NOVECTOR
CDEC$ NOVECTOR
CVD$ NOVECTOR
*VDIR NOVECTOR
*VOCL LOOP,SCALAR
CIBM PREFER SCALAR
*$PL$ CMCHAR='*'
*
DO 90 J = 2, N
TMP2 = D( J ) - E2( J-1 ) / TMP2 - TMP1
IF( TMP2.LE.PIVMIN ) THEN
ITMP1 = ITMP1 + 1
TMP2 = MIN( TMP2, -PIVMIN )
END IF
90 CONTINUE
*
IF( IJOB.LE.2 ) THEN
*
* IJOB=2: Choose all intervals containing eigenvalues.
*
* Insure that N(w) is monotone
*
ITMP1 = MIN( NAB( JI, 2 ),
$ MAX( NAB( JI, 1 ), ITMP1 ) )
*
* Update the Queue -- add intervals if both halves
* contain eigenvalues.
*
IF( ITMP1.EQ.NAB( JI, 2 ) ) THEN
*
* No eigenvalue in the upper interval:
* just use the lower interval.
*
AB( JI, 2 ) = TMP1
*
ELSE IF( ITMP1.EQ.NAB( JI, 1 ) ) THEN
*
* No eigenvalue in the lower interval:
* just use the upper interval.
*
AB( JI, 1 ) = TMP1
ELSE IF( KLNEW.LT.MMAX ) THEN
*
* Eigenvalue in both intervals -- add upper to queue.
*
KLNEW = KLNEW + 1
AB( KLNEW, 2 ) = AB( JI, 2 )
NAB( KLNEW, 2 ) = NAB( JI, 2 )
AB( KLNEW, 1 ) = TMP1
NAB( KLNEW, 1 ) = ITMP1
AB( JI, 2 ) = TMP1
NAB( JI, 2 ) = ITMP1
ELSE
INFO = MMAX + 1
RETURN
END IF
ELSE
*
* IJOB=3: Binary search. Keep only the interval
* containing w s.t. N(w) = NVAL
*
IF( ITMP1.LE.NVAL( JI ) ) THEN
AB( JI, 1 ) = TMP1
NAB( JI, 1 ) = ITMP1
END IF
IF( ITMP1.GE.NVAL( JI ) ) THEN
AB( JI, 2 ) = TMP1
NAB( JI, 2 ) = ITMP1
END IF
END IF
100 CONTINUE
*
* Increment iteration counter.
*
ITCNT = ITCNT + KL - KF + 1
*
* Increment opcount for evaluating Sturm sequences on
* each interval.
*
OPS = OPS + ( KL-KF+1 )*( N-1 )*3
KL = KLNEW
*
* End of Serial Version of the loop
*
END IF
*
* Check for convergence
*
KFNEW = KF
DO 110 JI = KF, KL
TMP1 = ABS( AB( JI, 2 )-AB( JI, 1 ) )
TMP2 = MAX( ABS( AB( JI, 2 ) ), ABS( AB( JI, 1 ) ) )
IF( TMP1.LT.MAX( ABSTOL, PIVMIN, RELTOL*TMP2 ) .OR.
$ NAB( JI, 1 ).GE.NAB( JI, 2 ) ) THEN
*
* Converged -- Swap with position KFNEW,
* then increment KFNEW
*
IF( JI.GT.KFNEW ) THEN
TMP1 = AB( JI, 1 )
TMP2 = AB( JI, 2 )
ITMP1 = NAB( JI, 1 )
ITMP2 = NAB( JI, 2 )
AB( JI, 1 ) = AB( KFNEW, 1 )
AB( JI, 2 ) = AB( KFNEW, 2 )
NAB( JI, 1 ) = NAB( KFNEW, 1 )
NAB( JI, 2 ) = NAB( KFNEW, 2 )
AB( KFNEW, 1 ) = TMP1
AB( KFNEW, 2 ) = TMP2
NAB( KFNEW, 1 ) = ITMP1
NAB( KFNEW, 2 ) = ITMP2
IF( IJOB.EQ.3 ) THEN
ITMP1 = NVAL( JI )
NVAL( JI ) = NVAL( KFNEW )
NVAL( KFNEW ) = ITMP1
END IF
END IF
KFNEW = KFNEW + 1
END IF
110 CONTINUE
KF = KFNEW
*
* Choose Midpoints
*
DO 120 JI = KF, KL
C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) )
120 CONTINUE
*
* Increment opcount for convergence check and choosing midpoints.
*
OPS = OPS + ( KL-KF+1 )*4
*
* If no more intervals to refine, quit.
*
IF( KF.GT.KL )
$ GO TO 140
130 CONTINUE
*
* Converged
*
140 CONTINUE
INFO = MAX( KL+1-KF, 0 )
MOUT = KL
*
RETURN
*
* End of SLAEBZ
*
END
SUBROUTINE SLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS,
$ WORK, IWORK, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ),
$ WORK( * )
* ..
* Common block to return operation count and iteration count
* ITCNT is unchanged, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLAED0 computes all eigenvalues and corresponding eigenvectors of a
* symmetric tridiagonal matrix using the divide and conquer method.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* = 0: Compute eigenvalues only.
* = 1: Compute eigenvectors of original dense symmetric matrix
* also. On entry, Q contains the orthogonal matrix used
* to reduce the original matrix to tridiagonal form.
* = 2: Compute eigenvalues and eigenvectors of tridiagonal
* matrix.
*
* QSIZ (input) INTEGER
* The dimension of the orthogonal matrix used to reduce
* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* D (input/output) REAL array, dimension (N)
* On entry, the main diagonal of the tridiagonal matrix.
* On exit, its eigenvalues.
*
* E (input) REAL array, dimension (N-1)
* The off-diagonal elements of the tridiagonal matrix.
* On exit, E has been destroyed.
*
* Q (input/output) REAL array, dimension (LDQ, N)
* On entry, Q must contain an N-by-N orthogonal matrix.
* If ICOMPQ = 0 Q is not referenced.
* If ICOMPQ = 1 On entry, Q is a subset of the columns of the
* orthogonal matrix used to reduce the full
* matrix to tridiagonal form corresponding to
* the subset of the full matrix which is being
* decomposed at this time.
* If ICOMPQ = 2 On entry, Q will be the identity matrix.
* On exit, Q contains the eigenvectors of the
* tridiagonal matrix.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. If eigenvectors are
* desired, then LDQ >= max(1,N). In any case, LDQ >= 1.
*
* QSTORE (workspace) REAL array, dimension (LDQS, N)
* Referenced only when ICOMPQ = 1. Used to store parts of
* the eigenvector matrix when the updating matrix multiplies
* take place.
*
* LDQS (input) INTEGER
* The leading dimension of the array QSTORE. If ICOMPQ = 1,
* then LDQS >= max(1,N). In any case, LDQS >= 1.
*
* WORK (workspace) REAL array,
* If ICOMPQ = 0 or 1, the dimension of WORK must be at least
* 1 + 3*N + 2*N*lg N + 2*N**2
* ( lg( N ) = smallest integer k
* such that 2^k >= N )
* If ICOMPQ = 2, the dimension of WORK must be at least
* 4*N + N**2.
*
* IWORK (workspace) INTEGER array,
* If ICOMPQ = 0 or 1, the dimension of IWORK must be at least
* 6 + 6*N + 5*N*lg N.
* ( lg( N ) = smallest integer k
* such that 2^k >= N )
* If ICOMPQ = 2, the dimension of IWORK must be at least
* 3 + 5*N.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: The algorithm failed to compute an eigenvalue while
* working on the submatrix lying in rows and columns
* INFO/(N+1) through mod(INFO,N+1).
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO
PARAMETER ( ZERO = 0.E0, ONE = 1.E0, TWO = 2.E0 )
* ..
* .. Local Scalars ..
INTEGER CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM,
$ IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM,
$ J, K, LGN, MATSIZ, MSD2, SMLSIZ, SMM1, SPM1,
$ SPM2, SUBMAT, SUBPBS, TLVLS
REAL TEMP
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMM, SLACPY, SLAED1, SLAED7, SSTEQR,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX, REAL
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.2 ) THEN
INFO = -1
ELSE IF( ( ICOMPQ.EQ.1 ) .AND. ( QSIZ.LT.MAX( 0, N ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDQS.LT.MAX( 1, N ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLAED0', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
SMLSIZ = ILAENV( 9, 'SLAED0', ' ', 0, 0, 0, 0 )
*
* Determine the size and placement of the submatrices, and save in
* the leading elements of IWORK.
*
IWORK( 1 ) = N
SUBPBS = 1
TLVLS = 0
10 CONTINUE
IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN
DO 20 J = SUBPBS, 1, -1
IWORK( 2*J ) = ( IWORK( J )+1 ) / 2
IWORK( 2*J-1 ) = IWORK( J ) / 2
20 CONTINUE
TLVLS = TLVLS + 1
SUBPBS = 2*SUBPBS
GO TO 10
END IF
DO 30 J = 2, SUBPBS
IWORK( J ) = IWORK( J ) + IWORK( J-1 )
30 CONTINUE
*
* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1
* using rank-1 modifications (cuts).
*
SPM1 = SUBPBS - 1
OPS = OPS + 2*SPM1
DO 40 I = 1, SPM1
SUBMAT = IWORK( I ) + 1
SMM1 = SUBMAT - 1
D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) )
D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) )
40 CONTINUE
*
INDXQ = 4*N + 3
IF( ICOMPQ.NE.2 ) THEN
*
* Set up workspaces for eigenvalues only/accumulate new vectors
* routine
*
OPS = OPS + 3
TEMP = LOG( REAL( N ) ) / LOG( TWO )
LGN = INT( TEMP )
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IPRMPT = INDXQ + N + 1
IPERM = IPRMPT + N*LGN
IQPTR = IPERM + N*LGN
IGIVPT = IQPTR + N + 2
IGIVCL = IGIVPT + N*LGN
*
IGIVNM = 1
IQ = IGIVNM + 2*N*LGN
IWREM = IQ + N**2 + 1
*
* Initialize pointers
*
DO 50 I = 0, SUBPBS
IWORK( IPRMPT+I ) = 1
IWORK( IGIVPT+I ) = 1
50 CONTINUE
IWORK( IQPTR ) = 1
END IF
*
* Solve each submatrix eigenproblem at the bottom of the divide and
* conquer tree.
*
CURR = 0
DO 70 I = 0, SPM1
IF( I.EQ.0 ) THEN
SUBMAT = 1
MATSIZ = IWORK( 1 )
ELSE
SUBMAT = IWORK( I ) + 1
MATSIZ = IWORK( I+1 ) - IWORK( I )
END IF
IF( ICOMPQ.EQ.2 ) THEN
CALL SSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
$ Q( SUBMAT, SUBMAT ), LDQ, WORK, INFO )
IF( INFO.NE.0 )
$ GO TO 130
ELSE
CALL SSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
$ WORK( IQ-1+IWORK( IQPTR+CURR ) ), MATSIZ, WORK,
$ INFO )
IF( INFO.NE.0 )
$ GO TO 130
IF( ICOMPQ.EQ.1 ) THEN
OPS = OPS + 2*REAL( QSIZ )*MATSIZ*MATSIZ
CALL SGEMM( 'N', 'N', QSIZ, MATSIZ, MATSIZ, ONE,
$ Q( 1, SUBMAT ), LDQ, WORK( IQ-1+IWORK( IQPTR+
$ CURR ) ), MATSIZ, ZERO, QSTORE( 1, SUBMAT ),
$ LDQS )
END IF
IWORK( IQPTR+CURR+1 ) = IWORK( IQPTR+CURR ) + MATSIZ**2
CURR = CURR + 1
END IF
K = 1
DO 60 J = SUBMAT, IWORK( I+1 )
IWORK( INDXQ+J ) = K
K = K + 1
60 CONTINUE
70 CONTINUE
*
* Successively merge eigensystems of adjacent submatrices
* into eigensystem for the corresponding larger matrix.
*
* while ( SUBPBS > 1 )
*
CURLVL = 1
80 CONTINUE
IF( SUBPBS.GT.1 ) THEN
SPM2 = SUBPBS - 2
DO 90 I = 0, SPM2, 2
IF( I.EQ.0 ) THEN
SUBMAT = 1
MATSIZ = IWORK( 2 )
MSD2 = IWORK( 1 )
CURPRB = 0
ELSE
SUBMAT = IWORK( I ) + 1
MATSIZ = IWORK( I+2 ) - IWORK( I )
MSD2 = MATSIZ / 2
CURPRB = CURPRB + 1
END IF
*
* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2)
* into an eigensystem of size MATSIZ.
* SLAED1 is used only for the full eigensystem of a tridiagonal
* matrix.
* SLAED7 handles the cases in which eigenvalues only or eigenvalues
* and eigenvectors of a full symmetric matrix (which was reduced to
* tridiagonal form) are desired.
*
IF( ICOMPQ.EQ.2 ) THEN
CALL SLAED1( MATSIZ, D( SUBMAT ), Q( SUBMAT, SUBMAT ),
$ LDQ, IWORK( INDXQ+SUBMAT ),
$ E( SUBMAT+MSD2-1 ), MSD2, WORK,
$ IWORK( SUBPBS+1 ), INFO )
ELSE
CALL SLAED7( ICOMPQ, MATSIZ, QSIZ, TLVLS, CURLVL, CURPRB,
$ D( SUBMAT ), QSTORE( 1, SUBMAT ), LDQS,
$ IWORK( INDXQ+SUBMAT ), E( SUBMAT+MSD2-1 ),
$ MSD2, WORK( IQ ), IWORK( IQPTR ),
$ IWORK( IPRMPT ), IWORK( IPERM ),
$ IWORK( IGIVPT ), IWORK( IGIVCL ),
$ WORK( IGIVNM ), WORK( IWREM ),
$ IWORK( SUBPBS+1 ), INFO )
END IF
IF( INFO.NE.0 )
$ GO TO 130
IWORK( I / 2+1 ) = IWORK( I+2 )
90 CONTINUE
SUBPBS = SUBPBS / 2
CURLVL = CURLVL + 1
GO TO 80
END IF
*
* end while
*
* Re-merge the eigenvalues/vectors which were deflated at the final
* merge step.
*
IF( ICOMPQ.EQ.1 ) THEN
DO 100 I = 1, N
J = IWORK( INDXQ+I )
WORK( I ) = D( J )
CALL SCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 )
100 CONTINUE
CALL SCOPY( N, WORK, 1, D, 1 )
ELSE IF( ICOMPQ.EQ.2 ) THEN
DO 110 I = 1, N
J = IWORK( INDXQ+I )
WORK( I ) = D( J )
CALL SCOPY( N, Q( 1, J ), 1, WORK( N*I+1 ), 1 )
110 CONTINUE
CALL SCOPY( N, WORK, 1, D, 1 )
CALL SLACPY( 'A', N, N, WORK( N+1 ), N, Q, LDQ )
ELSE
DO 120 I = 1, N
J = IWORK( INDXQ+I )
WORK( I ) = D( J )
120 CONTINUE
CALL SCOPY( N, WORK, 1, D, 1 )
END IF
GO TO 140
*
130 CONTINUE
INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1
*
140 CONTINUE
RETURN
*
* End of SLAED0
*
END
SUBROUTINE SLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK,
$ INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER CUTPNT, INFO, LDQ, N
REAL RHO
* ..
* .. Array Arguments ..
INTEGER INDXQ( * ), IWORK( * )
REAL D( * ), Q( LDQ, * ), WORK( * )
* ..
* Common block to return operation count and iteration count
* ITCNT is unchanged, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLAED1 computes the updated eigensystem of a diagonal
* matrix after modification by a rank-one symmetric matrix. This
* routine is used only for the eigenproblem which requires all
* eigenvalues and eigenvectors of a tridiagonal matrix. SLAED7 handles
* the case in which eigenvalues only or eigenvalues and eigenvectors
* of a full symmetric matrix (which was reduced to tridiagonal form)
* are desired.
*
* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)
*
* where Z = Q'u, u is a vector of length N with ones in the
* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
*
* The eigenvectors of the original matrix are stored in Q, and the
* eigenvalues are in D. The algorithm consists of three stages:
*
* The first stage consists of deflating the size of the problem
* when there are multiple eigenvalues or if there is a zero in
* the Z vector. For each such occurence the dimension of the
* secular equation problem is reduced by one. This stage is
* performed by the routine SLAED2.
*
* The second stage consists of calculating the updated
* eigenvalues. This is done by finding the roots of the secular
* equation via the routine SLAED4 (as called by SLAED3).
* This routine also calculates the eigenvectors of the current
* problem.
*
* The final stage consists of computing the updated eigenvectors
* directly using the updated eigenvalues. The eigenvectors for
* the current problem are multiplied with the eigenvectors from
* the overall problem.
*
* Arguments
* =========
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* D (input/output) REAL array, dimension (N)
* On entry, the eigenvalues of the rank-1-perturbed matrix.
* On exit, the eigenvalues of the repaired matrix.
*
* Q (input/output) REAL array, dimension (LDQ,N)
* On entry, the eigenvectors of the rank-1-perturbed matrix.
* On exit, the eigenvectors of the repaired tridiagonal matrix.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* INDXQ (input/output) INTEGER array, dimension (N)
* On entry, the permutation which separately sorts the two
* subproblems in D into ascending order.
* On exit, the permutation which will reintegrate the
* subproblems back into sorted order,
* i.e. D( INDXQ( I = 1, N ) ) will be in ascending order.
*
* RHO (input) REAL
* The subdiagonal entry used to create the rank-1 modification.
*
* CUTPNT (input) INTEGER
* The location of the last eigenvalue in the leading sub-matrix.
* min(1,N) <= CUTPNT <= N/2.
*
* WORK (workspace) REAL array, dimension (4*N + N**2)
*
* IWORK (workspace) INTEGER array, dimension (4*N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an eigenvalue did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
* Modified by Francoise Tisseur, University of Tennessee.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER COLTYP, CPP1, I, IDLMDA, INDX, INDXC, INDXP,
$ IQ2, IS, IW, IZ, K, N1, N2
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLAED2, SLAED3, SLAMRG, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( MIN( 1, N / 2 ).GT.CUTPNT .OR. ( N / 2 ).LT.CUTPNT ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLAED1', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* The following values are integer pointers which indicate
* the portion of the workspace
* used by a particular array in SLAED2 and SLAED3.
*
IZ = 1
IDLMDA = IZ + N
IW = IDLMDA + N
IQ2 = IW + N
*
INDX = 1
INDXC = INDX + N
COLTYP = INDXC + N
INDXP = COLTYP + N
*
*
* Form the z-vector which consists of the last row of Q_1 and the
* first row of Q_2.
*
CALL SCOPY( CUTPNT, Q( CUTPNT, 1 ), LDQ, WORK( IZ ), 1 )
CPP1 = CUTPNT + 1
CALL SCOPY( N-CUTPNT, Q( CPP1, CPP1 ), LDQ, WORK( IZ+CUTPNT ), 1 )
*
* Deflate eigenvalues.
*
CALL SLAED2( K, N, CUTPNT, D, Q, LDQ, INDXQ, RHO, WORK( IZ ),
$ WORK( IDLMDA ), WORK( IW ), WORK( IQ2 ),
$ IWORK( INDX ), IWORK( INDXC ), IWORK( INDXP ),
$ IWORK( COLTYP ), INFO )
*
IF( INFO.NE.0 )
$ GO TO 20
*
* Solve Secular Equation.
*
IF( K.NE.0 ) THEN
IS = ( IWORK( COLTYP )+IWORK( COLTYP+1 ) )*CUTPNT +
$ ( IWORK( COLTYP+1 )+IWORK( COLTYP+2 ) )*( N-CUTPNT ) + IQ2
CALL SLAED3( K, N, CUTPNT, D, Q, LDQ, RHO, WORK( IDLMDA ),
$ WORK( IQ2 ), IWORK( INDXC ), IWORK( COLTYP ),
$ WORK( IW ), WORK( IS ), INFO )
IF( INFO.NE.0 )
$ GO TO 20
*
* Prepare the INDXQ sorting permutation.
*
N1 = K
N2 = N - K
CALL SLAMRG( N1, N2, D, 1, -1, INDXQ )
ELSE
DO 10 I = 1, N
INDXQ( I ) = I
10 CONTINUE
END IF
*
20 CONTINUE
RETURN
*
* End of SLAED1
*
END
SUBROUTINE SLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W,
$ Q2, INDX, INDXC, INDXP, COLTYP, INFO )
*
* -- LAPACK routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDQ, N, N1
REAL RHO
* ..
* .. Array Arguments ..
INTEGER COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ),
$ INDXQ( * )
REAL D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
$ W( * ), Z( * )
* ..
* Common block to return operation count and iteration count
* ITCNT is unchanged, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLAED2 merges the two sets of eigenvalues together into a single
* sorted set. Then it tries to deflate the size of the problem.
* There are two ways in which deflation can occur: when two or more
* eigenvalues are close together or if there is a tiny entry in the
* Z vector. For each such occurrence the order of the related secular
* equation problem is reduced by one.
*
* Arguments
* =========
*
* K (output) INTEGER
* The number of non-deflated eigenvalues, and the order of the
* related secular equation. 0 <= K <=N.
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* N1 (input) INTEGER
* The location of the last eigenvalue in the leading sub-matrix.
* min(1,N) <= N1 <= N/2.
*
* D (input/output) REAL array, dimension (N)
* On entry, D contains the eigenvalues of the two submatrices to
* be combined.
* On exit, D contains the trailing (N-K) updated eigenvalues
* (those which were deflated) sorted into increasing order.
*
* Q (input/output) REAL array, dimension (LDQ, N)
* On entry, Q contains the eigenvectors of two submatrices in
* the two square blocks with corners at (1,1), (N1,N1)
* and (N1+1, N1+1), (N,N).
* On exit, Q contains the trailing (N-K) updated eigenvectors
* (those which were deflated) in its last N-K columns.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* INDXQ (input/output) INTEGER array, dimension (N)
* The permutation which separately sorts the two sub-problems
* in D into ascending order. Note that elements in the second
* half of this permutation must first have N1 added to their
* values. Destroyed on exit.
*
* RHO (input/output) REAL
* On entry, the off-diagonal element associated with the rank-1
* cut which originally split the two submatrices which are now
* being recombined.
* On exit, RHO has been modified to the value required by
* SLAED3.
*
* Z (input) REAL array, dimension (N)
* On entry, Z contains the updating vector (the last
* row of the first sub-eigenvector matrix and the first row of
* the second sub-eigenvector matrix).
* On exit, the contents of Z have been destroyed by the updating
* process.
*
* DLAMDA (output) REAL array, dimension (N)
* A copy of the first K eigenvalues which will be used by
* SLAED3 to form the secular equation.
*
* W (output) REAL array, dimension (N)
* The first k values of the final deflation-altered z-vector
* which will be passed to SLAED3.
*
* Q2 (output) REAL array, dimension (N1**2+(N-N1)**2)
* A copy of the first K eigenvectors which will be used by
* SLAED3 in a matrix multiply (SGEMM) to solve for the new
* eigenvectors.
*
* INDX (workspace) INTEGER array, dimension (N)
* The permutation used to sort the contents of DLAMDA into
* ascending order.
*
* INDXC (output) INTEGER array, dimension (N)
* The permutation used to arrange the columns of the deflated
* Q matrix into three groups: the first group contains non-zero
* elements only at and above N1, the second contains
* non-zero elements only below N1, and the third is dense.
*
* INDXP (workspace) INTEGER array, dimension (N)
* The permutation used to place deflated values of D at the end
* of the array. INDXP(1:K) points to the nondeflated D-values
* and INDXP(K+1:N) points to the deflated eigenvalues.
*
* COLTYP (workspace/output) INTEGER array, dimension (N)
* During execution, a label which will indicate which of the
* following types a column in the Q2 matrix is:
* 1 : non-zero in the upper half only;
* 2 : dense;
* 3 : non-zero in the lower half only;
* 4 : deflated.
* On exit, COLTYP(i) is the number of columns of type i,
* for i=1 to 4 only.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
* Modified by Francoise Tisseur, University of Tennessee.
*
* =====================================================================
*
* .. Parameters ..
REAL MONE, ZERO, ONE, TWO, EIGHT
PARAMETER ( MONE = -1.0E0, ZERO = 0.0E0, ONE = 1.0E0,
$ TWO = 2.0E0, EIGHT = 8.0E0 )
* ..
* .. Local Arrays ..
INTEGER CTOT( 4 ), PSM( 4 )
* ..
* .. Local Scalars ..
INTEGER CT, I, IMAX, IQ1, IQ2, J, JMAX, JS, K2, N1P1,
$ N2, NJ, PJ
REAL C, EPS, S, T, TAU, TOL
* ..
* .. External Functions ..
INTEGER ISAMAX
REAL SLAMCH, SLAPY2
EXTERNAL ISAMAX, SLAMCH, SLAPY2
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLACPY, SLAMRG, SROT, SSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( MIN( 1, ( N / 2 ) ).GT.N1 .OR. ( N / 2 ).LT.N1 ) THEN
INFO = -3
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLAED2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
N2 = N - N1
N1P1 = N1 + 1
*
IF( RHO.LT.ZERO ) THEN
OPS = OPS + N2
CALL SSCAL( N2, MONE, Z( N1P1 ), 1 )
END IF
*
* Normalize z so that norm(z) = 1. Since z is the concatenation of
* two normalized vectors, norm2(z) = sqrt(2).
*
OPS = OPS + N + 3
T = ONE / SQRT( TWO )
CALL SSCAL( N, T, Z, 1 )
*
* RHO = ABS( norm(z)**2 * RHO )
*
RHO = ABS( TWO*RHO )
*
* Sort the eigenvalues into increasing order
*
DO 10 I = N1P1, N
INDXQ( I ) = INDXQ( I ) + N1
10 CONTINUE
*
* re-integrate the deflated parts from the last pass
*
DO 20 I = 1, N
DLAMDA( I ) = D( INDXQ( I ) )
20 CONTINUE
CALL SLAMRG( N1, N2, DLAMDA, 1, 1, INDXC )
DO 30 I = 1, N
INDX( I ) = INDXQ( INDXC( I ) )
30 CONTINUE
*
* Calculate the allowable deflation tolerance
*
IMAX = ISAMAX( N, Z, 1 )
JMAX = ISAMAX( N, D, 1 )
EPS = SLAMCH( 'Epsilon' )
OPS = OPS + 2
TOL = EIGHT*EPS*MAX( ABS( D( JMAX ) ), ABS( Z( IMAX ) ) )
*
* If the rank-1 modifier is small enough, no more needs to be done
* except to reorganize Q so that its columns correspond with the
* elements in D.
*
OPS = OPS + 1
IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN
K = 0
IQ2 = 1
DO 40 J = 1, N
I = INDX( J )
CALL SCOPY( N, Q( 1, I ), 1, Q2( IQ2 ), 1 )
DLAMDA( J ) = D( I )
IQ2 = IQ2 + N
40 CONTINUE
CALL SLACPY( 'A', N, N, Q2, N, Q, LDQ )
CALL SCOPY( N, DLAMDA, 1, D, 1 )
GO TO 190
END IF
*
* If there are multiple eigenvalues then the problem deflates. Here
* the number of equal eigenvalues are found. As each equal
* eigenvalue is found, an elementary reflector is computed to rotate
* the corresponding eigensubspace so that the corresponding
* components of Z are zero in this new basis.
*
DO 50 I = 1, N1
COLTYP( I ) = 1
50 CONTINUE
DO 60 I = N1P1, N
COLTYP( I ) = 3
60 CONTINUE
*
*
K = 0
K2 = N + 1
DO 70 J = 1, N
NJ = INDX( J )
OPS = OPS + 1
IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
COLTYP( NJ ) = 4
INDXP( K2 ) = NJ
IF( J.EQ.N )
$ GO TO 100
ELSE
PJ = NJ
GO TO 80
END IF
70 CONTINUE
80 CONTINUE
J = J + 1
NJ = INDX( J )
IF( J.GT.N )
$ GO TO 100
OPS = OPS + 1
IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
COLTYP( NJ ) = 4
INDXP( K2 ) = NJ
ELSE
*
* Check if eigenvalues are close enough to allow deflation.
*
S = Z( PJ )
C = Z( NJ )
*
* Find sqrt(a**2+b**2) without overflow or
* destructive underflow.
*
OPS = OPS + 10
TAU = SLAPY2( C, S )
T = D( NJ ) - D( PJ )
C = C / TAU
S = -S / TAU
IF( ABS( T*C*S ).LE.TOL ) THEN
*
* Deflation is possible.
*
Z( NJ ) = TAU
Z( PJ ) = ZERO
IF( COLTYP( NJ ).NE.COLTYP( PJ ) )
$ COLTYP( NJ ) = 2
COLTYP( PJ ) = 4
OPS = OPS + 6*N
CALL SROT( N, Q( 1, PJ ), 1, Q( 1, NJ ), 1, C, S )
OPS = OPS + 10
T = D( PJ )*C**2 + D( NJ )*S**2
D( NJ ) = D( PJ )*S**2 + D( NJ )*C**2
D( PJ ) = T
K2 = K2 - 1
I = 1
90 CONTINUE
IF( K2+I.LE.N ) THEN
IF( D( PJ ).LT.D( INDXP( K2+I ) ) ) THEN
INDXP( K2+I-1 ) = INDXP( K2+I )
INDXP( K2+I ) = PJ
I = I + 1
GO TO 90
ELSE
INDXP( K2+I-1 ) = PJ
END IF
ELSE
INDXP( K2+I-1 ) = PJ
END IF
PJ = NJ
ELSE
K = K + 1
DLAMDA( K ) = D( PJ )
W( K ) = Z( PJ )
INDXP( K ) = PJ
PJ = NJ
END IF
END IF
GO TO 80
100 CONTINUE
*
* Record the last eigenvalue.
*
K = K + 1
DLAMDA( K ) = D( PJ )
W( K ) = Z( PJ )
INDXP( K ) = PJ
*
* Count up the total number of the various types of columns, then
* form a permutation which positions the four column types into
* four uniform groups (although one or more of these groups may be
* empty).
*
DO 110 J = 1, 4
CTOT( J ) = 0
110 CONTINUE
DO 120 J = 1, N
CT = COLTYP( J )
CTOT( CT ) = CTOT( CT ) + 1
120 CONTINUE
*
* PSM(*) = Position in SubMatrix (of types 1 through 4)
*
PSM( 1 ) = 1
PSM( 2 ) = 1 + CTOT( 1 )
PSM( 3 ) = PSM( 2 ) + CTOT( 2 )
PSM( 4 ) = PSM( 3 ) + CTOT( 3 )
K = N - CTOT( 4 )
*
* Fill out the INDXC array so that the permutation which it induces
* will place all type-1 columns first, all type-2 columns next,
* then all type-3's, and finally all type-4's.
*
DO 130 J = 1, N
JS = INDXP( J )
CT = COLTYP( JS )
INDX( PSM( CT ) ) = JS
INDXC( PSM( CT ) ) = J
PSM( CT ) = PSM( CT ) + 1
130 CONTINUE
*
* Sort the eigenvalues and corresponding eigenvectors into DLAMDA
* and Q2 respectively. The eigenvalues/vectors which were not
* deflated go into the first K slots of DLAMDA and Q2 respectively,
* while those which were deflated go into the last N - K slots.
*
I = 1
IQ1 = 1
IQ2 = 1 + ( CTOT( 1 )+CTOT( 2 ) )*N1
DO 140 J = 1, CTOT( 1 )
JS = INDX( I )
CALL SCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 )
Z( I ) = D( JS )
I = I + 1
IQ1 = IQ1 + N1
140 CONTINUE
*
DO 150 J = 1, CTOT( 2 )
JS = INDX( I )
CALL SCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 )
CALL SCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 )
Z( I ) = D( JS )
I = I + 1
IQ1 = IQ1 + N1
IQ2 = IQ2 + N2
150 CONTINUE
*
DO 160 J = 1, CTOT( 3 )
JS = INDX( I )
CALL SCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 )
Z( I ) = D( JS )
I = I + 1
IQ2 = IQ2 + N2
160 CONTINUE
*
IQ1 = IQ2
DO 170 J = 1, CTOT( 4 )
JS = INDX( I )
CALL SCOPY( N, Q( 1, JS ), 1, Q2( IQ2 ), 1 )
IQ2 = IQ2 + N
Z( I ) = D( JS )
I = I + 1
170 CONTINUE
*
* The deflated eigenvalues and their corresponding vectors go back
* into the last N - K slots of D and Q respectively.
*
CALL SLACPY( 'A', N, CTOT( 4 ), Q2( IQ1 ), N, Q( 1, K+1 ), LDQ )
CALL SCOPY( N-K, Z( K+1 ), 1, D( K+1 ), 1 )
*
* Copy CTOT into COLTYP for referencing in SLAED3.
*
DO 180 J = 1, 4
COLTYP( J ) = CTOT( J )
180 CONTINUE
*
190 CONTINUE
RETURN
*
* End of SLAED2
*
END
SUBROUTINE SLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX,
$ CTOT, W, S, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
* Courant Institute, NAG Ltd., and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDQ, N, N1
REAL RHO
* ..
* .. Array Arguments ..
INTEGER CTOT( * ), INDX( * )
REAL D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
$ S( * ), W( * )
* ..
* Common block to return operation count and iteration count
* ITCNT is unchanged, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLAED3 finds the roots of the secular equation, as defined by the
* values in D, W, and RHO, between 1 and K. It makes the
* appropriate calls to SLAED4 and then updates the eigenvectors by
* multiplying the matrix of eigenvectors of the pair of eigensystems
* being combined by the matrix of eigenvectors of the K-by-K system
* which is solved here.
*
* This code makes very mild assumptions about floating point
* arithmetic. It will work on machines with a guard digit in
* add/subtract, or on those binary machines without guard digits
* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
* It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Arguments
* =========
*
* K (input) INTEGER
* The number of terms in the rational function to be solved by
* SLAED4. K >= 0.
*
* N (input) INTEGER
* The number of rows and columns in the Q matrix.
* N >= K (deflation may result in N>K).
*
* N1 (input) INTEGER
* The location of the last eigenvalue in the leading submatrix.
* min(1,N) <= N1 <= N/2.
*
* D (output) REAL array, dimension (N)
* D(I) contains the updated eigenvalues for
* 1 <= I <= K.
*
* Q (output) REAL array, dimension (LDQ,N)
* Initially the first K columns are used as workspace.
* On output the columns 1 to K contain
* the updated eigenvectors.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* RHO (input) REAL
* The value of the parameter in the rank one update equation.
* RHO >= 0 required.
*
* DLAMDA (input/output) REAL array, dimension (K)
* The first K elements of this array contain the old roots
* of the deflated updating problem. These are the poles
* of the secular equation. May be changed on output by
* having lowest order bit set to zero on Cray X-MP, Cray Y-MP,
* Cray-2, or Cray C-90, as described above.
*
* Q2 (input) REAL array, dimension (LDQ2, N)
* The first K columns of this matrix contain the non-deflated
* eigenvectors for the split problem.
*
* INDX (input) INTEGER array, dimension (N)
* The permutation used to arrange the columns of the deflated
* Q matrix into three groups (see SLAED2).
* The rows of the eigenvectors found by SLAED4 must be likewise
* permuted before the matrix multiply can take place.
*
* CTOT (input) INTEGER array, dimension (4)
* A count of the total number of the various types of columns
* in Q, as described in INDX. The fourth column type is any
* column which has been deflated.
*
* W (input/output) REAL array, dimension (K)
* The first K elements of this array contain the components
* of the deflation-adjusted updating vector. Destroyed on
* output.
*
* S (workspace) REAL array, dimension (N1 + 1)*K
* Will contain the eigenvectors of the repaired matrix which
* will be multiplied by the previously accumulated eigenvectors
* to update the system.
*
* LDS (input) INTEGER
* The leading dimension of S. LDS >= max(1,K).
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an eigenvalue did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
* Modified by Francoise Tisseur, University of Tennessee.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
INTEGER I, II, IQ2, J, N12, N2, N23
REAL TEMP
* ..
* .. External Functions ..
REAL SLAMC3, SNRM2
EXTERNAL SLAMC3, SNRM2
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMM, SLACPY, SLAED4, SLASET, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( K.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.K ) THEN
INFO = -2
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLAED3', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( K.EQ.0 )
$ RETURN
*
* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
* be computed with high relative accuracy (barring over/underflow).
* This is a problem on machines without a guard digit in
* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
* which on any of these machines zeros out the bottommost
* bit of DLAMDA(I) if it is 1; this makes the subsequent
* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
* occurs. On binary machines with a guard digit (almost all
* machines) it does not change DLAMDA(I) at all. On hexadecimal
* and decimal machines with a guard digit, it slightly
* changes the bottommost bits of DLAMDA(I). It does not account
* for hexadecimal or decimal machines without guard digits
* (we know of none). We use a subroutine call to compute
* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating
* this code.
*
OPS = OPS + 2*N
DO 10 I = 1, K
DLAMDA( I ) = SLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I )
10 CONTINUE
*
DO 20 J = 1, K
CALL SLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO )
*
* If the zero finder fails, the computation is terminated.
*
IF( INFO.NE.0 )
$ GO TO 120
20 CONTINUE
*
IF( K.EQ.1 )
$ GO TO 110
IF( K.EQ.2 ) THEN
DO 30 J = 1, K
W( 1 ) = Q( 1, J )
W( 2 ) = Q( 2, J )
II = INDX( 1 )
Q( 1, J ) = W( II )
II = INDX( 2 )
Q( 2, J ) = W( II )
30 CONTINUE
GO TO 110
END IF
*
* Compute updated W.
*
CALL SCOPY( K, W, 1, S, 1 )
*
* Initialize W(I) = Q(I,I)
*
CALL SCOPY( K, Q, LDQ+1, W, 1 )
OPS = OPS + 3*K*( K-1 )
DO 60 J = 1, K
DO 40 I = 1, J - 1
W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
40 CONTINUE
DO 50 I = J + 1, K
W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
50 CONTINUE
60 CONTINUE
OPS = OPS + K
DO 70 I = 1, K
W( I ) = SIGN( SQRT( -W( I ) ), S( I ) )
70 CONTINUE
*
* Compute eigenvectors of the modified rank-1 modification.
*
OPS = OPS + 4*K*K
DO 100 J = 1, K
DO 80 I = 1, K
S( I ) = W( I ) / Q( I, J )
80 CONTINUE
TEMP = SNRM2( K, S, 1 )
DO 90 I = 1, K
II = INDX( I )
Q( I, J ) = S( II ) / TEMP
90 CONTINUE
100 CONTINUE
*
* Compute the updated eigenvectors.
*
110 CONTINUE
*
N2 = N - N1
N12 = CTOT( 1 ) + CTOT( 2 )
N23 = CTOT( 2 ) + CTOT( 3 )
*
CALL SLACPY( 'A', N23, K, Q( CTOT( 1 )+1, 1 ), LDQ, S, N23 )
IQ2 = N1*N12 + 1
IF( N23.NE.0 ) THEN
OPS = OPS + 2*REAL( N2 )*K*N23
CALL SGEMM( 'N', 'N', N2, K, N23, ONE, Q2( IQ2 ), N2, S, N23,
$ ZERO, Q( N1+1, 1 ), LDQ )
ELSE
CALL SLASET( 'A', N2, K, ZERO, ZERO, Q( N1+1, 1 ), LDQ )
END IF
*
CALL SLACPY( 'A', N12, K, Q, LDQ, S, N12 )
IF( N12.NE.0 ) THEN
OPS = OPS + 2*REAL( N1 )*K*N12
CALL SGEMM( 'N', 'N', N1, K, N12, ONE, Q2, N1, S, N12, ZERO, Q,
$ LDQ )
ELSE
CALL SLASET( 'A', N1, K, ZERO, ZERO, Q( 1, 1 ), LDQ )
END IF
*
*
120 CONTINUE
RETURN
*
* End of SLAED3
*
END
SUBROUTINE SLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
* Courant Institute, NAG Ltd., and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER I, INFO, N
REAL DLAM, RHO
* ..
* .. Array Arguments ..
REAL D( * ), DELTA( * ), Z( * )
* ..
* Common block to return operation count and iteration count
* ITCNT is unchanged, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* This subroutine computes the I-th updated eigenvalue of a symmetric
* rank-one modification to a diagonal matrix whose elements are
* given in the array d, and that
*
* D(i) < D(j) for i < j
*
* and that RHO > 0. This is arranged by the calling routine, and is
* no loss in generality. The rank-one modified system is thus
*
* diag( D ) + RHO * Z * Z_transpose.
*
* where we assume the Euclidean norm of Z is 1.
*
* The method consists of approximating the rational functions in the
* secular equation by simpler interpolating rational functions.
*
* Arguments
* =========
*
* N (input) INTEGER
* The length of all arrays.
*
* I (input) INTEGER
* The index of the eigenvalue to be computed. 1 <= I <= N.
*
* D (input) REAL array, dimension (N)
* The original eigenvalues. It is assumed that they are in
* order, D(I) < D(J) for I < J.
*
* Z (input) REAL array, dimension (N)
* The components of the updating vector.
*
* DELTA (output) REAL array, dimension (N)
* If N .ne. 1, DELTA contains (D(j) - lambda_I) in its j-th
* component. If N = 1, then DELTA(1) = 1. The vector DELTA
* contains the information necessary to construct the
* eigenvectors.
*
* RHO (input) REAL
* The scalar in the symmetric updating formula.
*
* DLAM (output) REAL
* The computed lambda_I, the I-th updated eigenvalue.
*
* INFO (output) INTEGER
* = 0: successful exit
* > 0: if INFO = 1, the updating process failed.
*
* Internal Parameters
* ===================
*
* Logical variable ORGATI (origin-at-i?) is used for distinguishing
* whether D(i) or D(i+1) is treated as the origin.
*
* ORGATI = .true. origin at i
* ORGATI = .false. origin at i+1
*
* Logical variable SWTCH3 (switch-for-3-poles?) is for noting
* if we are working with THREE poles!
*
* MAXIT is the maximum number of iterations allowed for each
* eigenvalue.
*
* Further Details
* ===============
*
* Based on contributions by
* Ren-Cang Li, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXIT
PARAMETER ( MAXIT = 20 )
REAL ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ THREE = 3.0E0, FOUR = 4.0E0, EIGHT = 8.0E0,
$ TEN = 10.0E0 )
* ..
* .. Local Scalars ..
LOGICAL ORGATI, SWTCH, SWTCH3
INTEGER II, IIM1, IIP1, IP1, ITER, J, NITER
REAL A, B, C, DEL, DPHI, DPSI, DW, EPS, ERRETM, ETA,
$ PHI, PREW, PSI, RHOINV, TAU, TEMP, TEMP1, W
* ..
* .. Local Arrays ..
REAL ZZ( 3 )
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SLAED5, SLAED6
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SQRT
* ..
* .. Executable Statements ..
*
* Since this routine is called in an inner loop, we do no argument
* checking.
*
* Quick return for N=1 and 2.
*
INFO = 0
IF( N.EQ.1 ) THEN
*
* Presumably, I=1 upon entry
*
OPS = OPS + 3
DLAM = D( 1 ) + RHO*Z( 1 )*Z( 1 )
DELTA( 1 ) = ONE
RETURN
END IF
IF( N.EQ.2 ) THEN
CALL SLAED5( I, D, Z, DELTA, RHO, DLAM )
RETURN
END IF
*
* Compute machine epsilon
*
EPS = SLAMCH( 'Epsilon' )
OPS = OPS + 1
RHOINV = ONE / RHO
*
* The case I = N
*
IF( I.EQ.N ) THEN
*
* Initialize some basic variables
*
II = N - 1
NITER = 1
*
* Calculate initial guess
*
OPS = OPS + 5*N + 1
TEMP = RHO / TWO
*
* If ||Z||_2 is not one, then TEMP should be set to
* RHO * ||Z||_2^2 / TWO
*
DO 10 J = 1, N
DELTA( J ) = ( D( J )-D( I ) ) - TEMP
10 CONTINUE
*
PSI = ZERO
DO 20 J = 1, N - 2
PSI = PSI + Z( J )*Z( J ) / DELTA( J )
20 CONTINUE
*
C = RHOINV + PSI
W = C + Z( II )*Z( II ) / DELTA( II ) +
$ Z( N )*Z( N ) / DELTA( N )
*
IF( W.LE.ZERO ) THEN
OPS = OPS + 7
TEMP = Z( N-1 )*Z( N-1 ) / ( D( N )-D( N-1 )+RHO ) +
$ Z( N )*Z( N ) / RHO
IF( C.LE.TEMP ) THEN
TAU = RHO
ELSE
OPS = OPS + 14
DEL = D( N ) - D( N-1 )
A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
B = Z( N )*Z( N )*DEL
IF( A.LT.ZERO ) THEN
TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
ELSE
TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
END IF
END IF
*
* It can be proved that
* D(N)+RHO/2 <= LAMBDA(N) < D(N)+TAU <= D(N)+RHO
*
ELSE
OPS = OPS + 16
DEL = D( N ) - D( N-1 )
A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
B = Z( N )*Z( N )*DEL
IF( A.LT.ZERO ) THEN
TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
ELSE
TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
END IF
*
* It can be proved that
* D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2
*
END IF
*
OPS = OPS + 2*N + 6*II + 14
DO 30 J = 1, N
DELTA( J ) = ( D( J )-D( I ) ) - TAU
30 CONTINUE
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 40 J = 1, II
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
40 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
TEMP = Z( N ) / DELTA( N )
PHI = Z( N )*TEMP
DPHI = TEMP*TEMP
ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
$ ABS( TAU )*( DPSI+DPHI )
*
W = RHOINV + PHI + PSI
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
OPS = OPS + 1
DLAM = D( I ) + TAU
GO TO 250
END IF
*
* Calculate the new step
*
OPS = OPS + 12
NITER = NITER + 1
C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI
A = ( DELTA( N-1 )+DELTA( N ) )*W -
$ DELTA( N-1 )*DELTA( N )*( DPSI+DPHI )
B = DELTA( N-1 )*DELTA( N )*W
IF( C.LT.ZERO )
$ C = ABS( C )
IF( C.EQ.ZERO ) THEN
* ETA = B/A
OPS = OPS + 1
ETA = RHO - TAU
ELSE IF( A.GE.ZERO ) THEN
OPS = OPS + 8
ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
OPS = OPS + 8
ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
OPS = OPS + N + 6*II + 16
IF( W*ETA.GT.ZERO ) THEN
OPS = OPS + 2
ETA = -W / ( DPSI+DPHI )
END IF
TEMP = TAU + ETA
IF( TEMP.GT.RHO ) THEN
OPS = OPS + 1
ETA = RHO - TAU
END IF
DO 50 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
50 CONTINUE
*
TAU = TAU + ETA
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 60 J = 1, II
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
60 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
TEMP = Z( N ) / DELTA( N )
PHI = Z( N )*TEMP
DPHI = TEMP*TEMP
ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
$ ABS( TAU )*( DPSI+DPHI )
*
W = RHOINV + PHI + PSI
*
* Main loop to update the values of the array DELTA
*
ITER = NITER + 1
*
DO 90 NITER = ITER, MAXIT
*
* Test for convergence
*
OPS = OPS + 1
IF( ABS( W ).LE.EPS*ERRETM ) THEN
OPS = OPS + 1
DLAM = D( I ) + TAU
GO TO 250
END IF
*
* Calculate the new step
*
OPS = OPS + 36 + N + 6*II
C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI
A = ( DELTA( N-1 )+DELTA( N ) )*W -
$ DELTA( N-1 )*DELTA( N )*( DPSI+DPHI )
B = DELTA( N-1 )*DELTA( N )*W
IF( A.GE.ZERO ) THEN
ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
IF( W*ETA.GT.ZERO )
$ ETA = -W / ( DPSI+DPHI )
TEMP = TAU + ETA
IF( TEMP.LE.ZERO )
$ ETA = ETA / TWO
DO 70 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
70 CONTINUE
*
TAU = TAU + ETA
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 80 J = 1, II
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
80 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
TEMP = Z( N ) / DELTA( N )
PHI = Z( N )*TEMP
DPHI = TEMP*TEMP
ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
$ ABS( TAU )*( DPSI+DPHI )
*
W = RHOINV + PHI + PSI
90 CONTINUE
*
* Return with INFO = 1, NITER = MAXIT and not converged
*
INFO = 1
OPS = OPS + 1
DLAM = D( I ) + TAU
GO TO 250
*
* End for the case I = N
*
ELSE
*
* The case for I < N
*
NITER = 1
IP1 = I + 1
*
* Calculate initial guess
*
TEMP = ( D( IP1 )-D( I ) ) / TWO
DO 100 J = 1, N
DELTA( J ) = ( D( J )-D( I ) ) - TEMP
100 CONTINUE
*
PSI = ZERO
DO 110 J = 1, I - 1
PSI = PSI + Z( J )*Z( J ) / DELTA( J )
110 CONTINUE
*
PHI = ZERO
DO 120 J = N, I + 2, -1
PHI = PHI + Z( J )*Z( J ) / DELTA( J )
120 CONTINUE
C = RHOINV + PSI + PHI
W = C + Z( I )*Z( I ) / DELTA( I ) +
$ Z( IP1 )*Z( IP1 ) / DELTA( IP1 )
*
IF( W.GT.ZERO ) THEN
*
* d(i)< the ith eigenvalue < (d(i)+d(i+1))/2
*
* We choose d(i) as origin.
*
ORGATI = .TRUE.
DEL = D( IP1 ) - D( I )
A = C*DEL + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 )
B = Z( I )*Z( I )*DEL
IF( A.GT.ZERO ) THEN
TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
ELSE
TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
END IF
ELSE
*
* (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1)
*
* We choose d(i+1) as origin.
*
ORGATI = .FALSE.
DEL = D( IP1 ) - D( I )
A = C*DEL - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 )
B = Z( IP1 )*Z( IP1 )*DEL
IF( A.LT.ZERO ) THEN
TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) )
ELSE
TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C )
END IF
END IF
*
IF( ORGATI ) THEN
DO 130 J = 1, N
DELTA( J ) = ( D( J )-D( I ) ) - TAU
130 CONTINUE
ELSE
DO 140 J = 1, N
DELTA( J ) = ( D( J )-D( IP1 ) ) - TAU
140 CONTINUE
END IF
IF( ORGATI ) THEN
II = I
ELSE
II = I + 1
END IF
IIM1 = II - 1
IIP1 = II + 1
OPS = OPS + 13*N + 6*( IIM1-IIP1 ) + 45
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 150 J = 1, IIM1
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
150 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
DPHI = ZERO
PHI = ZERO
DO 160 J = N, IIP1, -1
TEMP = Z( J ) / DELTA( J )
PHI = PHI + Z( J )*TEMP
DPHI = DPHI + TEMP*TEMP
ERRETM = ERRETM + PHI
160 CONTINUE
*
W = RHOINV + PHI + PSI
*
* W is the value of the secular function with
* its ii-th element removed.
*
SWTCH3 = .FALSE.
IF( ORGATI ) THEN
IF( W.LT.ZERO )
$ SWTCH3 = .TRUE.
ELSE
IF( W.GT.ZERO )
$ SWTCH3 = .TRUE.
END IF
IF( II.EQ.1 .OR. II.EQ.N )
$ SWTCH3 = .FALSE.
*
TEMP = Z( II ) / DELTA( II )
DW = DPSI + DPHI + TEMP*TEMP
TEMP = Z( II )*TEMP
W = W + TEMP
ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
$ THREE*ABS( TEMP ) + ABS( TAU )*DW
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
IF( ORGATI ) THEN
DLAM = D( I ) + TAU
ELSE
DLAM = D( IP1 ) + TAU
END IF
GO TO 250
END IF
*
* Calculate the new step
*
OPS = OPS + 14
NITER = NITER + 1
IF( .NOT.SWTCH3 ) THEN
IF( ORGATI ) THEN
C = W - DELTA( IP1 )*DW - ( D( I )-D( IP1 ) )*
$ ( Z( I ) / DELTA( I ) )**2
ELSE
C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )*
$ ( Z( IP1 ) / DELTA( IP1 ) )**2
END IF
A = ( DELTA( I )+DELTA( IP1 ) )*W -
$ DELTA( I )*DELTA( IP1 )*DW
B = DELTA( I )*DELTA( IP1 )*W
IF( C.EQ.ZERO ) THEN
IF( A.EQ.ZERO ) THEN
OPS = OPS + 5
IF( ORGATI ) THEN
A = Z( I )*Z( I ) + DELTA( IP1 )*DELTA( IP1 )*
$ ( DPSI+DPHI )
ELSE
A = Z( IP1 )*Z( IP1 ) + DELTA( I )*DELTA( I )*
$ ( DPSI+DPHI )
END IF
END IF
ETA = B / A
ELSE IF( A.LE.ZERO ) THEN
OPS = OPS + 8
ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
OPS = OPS + 8
ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
ELSE
*
* Interpolation using THREE most relevant poles
*
OPS = OPS + 15
TEMP = RHOINV + PSI + PHI
IF( ORGATI ) THEN
TEMP1 = Z( IIM1 ) / DELTA( IIM1 )
TEMP1 = TEMP1*TEMP1
C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) -
$ ( D( IIM1 )-D( IIP1 ) )*TEMP1
ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*
$ ( ( DPSI-TEMP1 )+DPHI )
ELSE
TEMP1 = Z( IIP1 ) / DELTA( IIP1 )
TEMP1 = TEMP1*TEMP1
C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) -
$ ( D( IIP1 )-D( IIM1 ) )*TEMP1
ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*
$ ( DPSI+( DPHI-TEMP1 ) )
ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
END IF
ZZ( 2 ) = Z( II )*Z( II )
CALL SLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA,
$ INFO )
IF( INFO.NE.0 )
$ GO TO 250
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
OPS = OPS + 18 + 7*N + 6*( IIM1-IIP1 )
IF( W*ETA.GE.ZERO ) THEN
OPS = OPS + 1
ETA = -W / DW
END IF
TEMP = TAU + ETA
DEL = ( D( IP1 )-D( I ) ) / TWO
IF( ORGATI ) THEN
IF( TEMP.GE.DEL ) THEN
OPS = OPS + 1
ETA = DEL - TAU
END IF
IF( TEMP.LE.ZERO ) THEN
OPS = OPS + 1
ETA = ETA / TWO
END IF
ELSE
IF( TEMP.LE.-DEL ) THEN
OPS = OPS + 1
ETA = -DEL - TAU
END IF
IF( TEMP.GE.ZERO ) THEN
OPS = OPS + 1
ETA = ETA / TWO
END IF
END IF
*
PREW = W
*
170 CONTINUE
DO 180 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
180 CONTINUE
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 190 J = 1, IIM1
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
190 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
DPHI = ZERO
PHI = ZERO
DO 200 J = N, IIP1, -1
TEMP = Z( J ) / DELTA( J )
PHI = PHI + Z( J )*TEMP
DPHI = DPHI + TEMP*TEMP
ERRETM = ERRETM + PHI
200 CONTINUE
*
TEMP = Z( II ) / DELTA( II )
DW = DPSI + DPHI + TEMP*TEMP
TEMP = Z( II )*TEMP
W = RHOINV + PHI + PSI + TEMP
ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
$ THREE*ABS( TEMP ) + ABS( TAU+ETA )*DW
*
SWTCH = .FALSE.
IF( ORGATI ) THEN
IF( -W.GT.ABS( PREW ) / TEN )
$ SWTCH = .TRUE.
ELSE
IF( W.GT.ABS( PREW ) / TEN )
$ SWTCH = .TRUE.
END IF
*
TAU = TAU + ETA
*
* Main loop to update the values of the array DELTA
*
ITER = NITER + 1
*
DO 240 NITER = ITER, MAXIT
*
* Test for convergence
*
OPS = OPS + 1
IF( ABS( W ).LE.EPS*ERRETM ) THEN
OPS = OPS + 1
IF( ORGATI ) THEN
DLAM = D( I ) + TAU
ELSE
DLAM = D( IP1 ) + TAU
END IF
GO TO 250
END IF
*
* Calculate the new step
*
IF( .NOT.SWTCH3 ) THEN
OPS = OPS + 14
IF( .NOT.SWTCH ) THEN
IF( ORGATI ) THEN
C = W - DELTA( IP1 )*DW -
$ ( D( I )-D( IP1 ) )*( Z( I ) / DELTA( I ) )**2
ELSE
C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )*
$ ( Z( IP1 ) / DELTA( IP1 ) )**2
END IF
ELSE
TEMP = Z( II ) / DELTA( II )
IF( ORGATI ) THEN
DPSI = DPSI + TEMP*TEMP
ELSE
DPHI = DPHI + TEMP*TEMP
END IF
C = W - DELTA( I )*DPSI - DELTA( IP1 )*DPHI
END IF
A = ( DELTA( I )+DELTA( IP1 ) )*W -
$ DELTA( I )*DELTA( IP1 )*DW
B = DELTA( I )*DELTA( IP1 )*W
IF( C.EQ.ZERO ) THEN
IF( A.EQ.ZERO ) THEN
OPS = OPS + 5
IF( .NOT.SWTCH ) THEN
IF( ORGATI ) THEN
A = Z( I )*Z( I ) + DELTA( IP1 )*
$ DELTA( IP1 )*( DPSI+DPHI )
ELSE
A = Z( IP1 )*Z( IP1 ) +
$ DELTA( I )*DELTA( I )*( DPSI+DPHI )
END IF
ELSE
A = DELTA( I )*DELTA( I )*DPSI +
$ DELTA( IP1 )*DELTA( IP1 )*DPHI
END IF
END IF
OPS = OPS + 1
ETA = B / A
ELSE IF( A.LE.ZERO ) THEN
OPS = OPS + 8
ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
OPS = OPS + 8
ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
ELSE
*
* Interpolation using THREE most relevant poles
*
OPS = OPS + 2
TEMP = RHOINV + PSI + PHI
IF( SWTCH ) THEN
OPS = OPS + 10
C = TEMP - DELTA( IIM1 )*DPSI - DELTA( IIP1 )*DPHI
ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*DPSI
ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*DPHI
ELSE
OPS = OPS + 14
IF( ORGATI ) THEN
TEMP1 = Z( IIM1 ) / DELTA( IIM1 )
TEMP1 = TEMP1*TEMP1
C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) -
$ ( D( IIM1 )-D( IIP1 ) )*TEMP1
ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*
$ ( ( DPSI-TEMP1 )+DPHI )
ELSE
TEMP1 = Z( IIP1 ) / DELTA( IIP1 )
TEMP1 = TEMP1*TEMP1
C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) -
$ ( D( IIP1 )-D( IIM1 ) )*TEMP1
ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*
$ ( DPSI+( DPHI-TEMP1 ) )
ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
END IF
END IF
CALL SLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA,
$ INFO )
IF( INFO.NE.0 )
$ GO TO 250
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
OPS = OPS + 7*N + 6*( IIM1-IIP1 ) + 18
IF( W*ETA.GE.ZERO ) THEN
OPS = OPS + 1
ETA = -W / DW
END IF
TEMP = TAU + ETA
DEL = ( D( IP1 )-D( I ) ) / TWO
IF( ORGATI ) THEN
IF( TEMP.GE.DEL ) THEN
ETA = DEL - TAU
OPS = OPS + 1
END IF
IF( TEMP.LE.ZERO ) THEN
ETA = ETA / TWO
OPS = OPS + 1
END IF
ELSE
IF( TEMP.LE.-DEL ) THEN
ETA = -DEL - TAU
OPS = OPS + 1
END IF
IF( TEMP.GE.ZERO ) THEN
ETA = ETA / TWO
OPS = OPS + 1
END IF
END IF
*
DO 210 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
210 CONTINUE
*
TAU = TAU + ETA
PREW = W
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 220 J = 1, IIM1
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
220 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
DPHI = ZERO
PHI = ZERO
DO 230 J = N, IIP1, -1
TEMP = Z( J ) / DELTA( J )
PHI = PHI + Z( J )*TEMP
DPHI = DPHI + TEMP*TEMP
ERRETM = ERRETM + PHI
230 CONTINUE
*
TEMP = Z( II ) / DELTA( II )
DW = DPSI + DPHI + TEMP*TEMP
TEMP = Z( II )*TEMP
W = RHOINV + PHI + PSI + TEMP
ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
$ THREE*ABS( TEMP ) + ABS( TAU )*DW
IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN )
$ SWTCH = .NOT.SWTCH
*
240 CONTINUE
*
* Return with INFO = 1, NITER = MAXIT and not converged
*
INFO = 1
OPS = OPS + 1
IF( ORGATI ) THEN
DLAM = D( I ) + TAU
ELSE
DLAM = D( IP1 ) + TAU
END IF
*
END IF
*
250 CONTINUE
RETURN
*
* End of SLAED4
*
END
SUBROUTINE SLAED5( I, D, Z, DELTA, RHO, DLAM )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
* Courant Institute, NAG Ltd., and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
INTEGER I
REAL DLAM, RHO
* ..
* .. Array Arguments ..
REAL D( 2 ), DELTA( 2 ), Z( 2 )
* ..
* Common block to return operation count and iteration count
* ITCNT is unchanged, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* This subroutine computes the I-th eigenvalue of a symmetric rank-one
* modification of a 2-by-2 diagonal matrix
*
* diag( D ) + RHO * Z * transpose(Z) .
*
* The diagonal elements in the array D are assumed to satisfy
*
* D(i) < D(j) for i < j .
*
* We also assume RHO > 0 and that the Euclidean norm of the vector
* Z is one.
*
* Arguments
* =========
*
* I (input) INTEGER
* The index of the eigenvalue to be computed. I = 1 or I = 2.
*
* D (input) REAL array, dimension (2)
* The original eigenvalues. We assume D(1) < D(2).
*
* Z (input) REAL array, dimension (2)
* The components of the updating vector.
*
* DELTA (output) REAL array, dimension (2)
* The vector DELTA contains the information necessary
* to construct the eigenvectors.
*
* RHO (input) REAL
* The scalar in the symmetric updating formula.
*
* DLAM (output) REAL
* The computed lambda_I, the I-th updated eigenvalue.
*
* Further Details
* ===============
*
* Based on contributions by
* Ren-Cang Li, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO, FOUR
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ FOUR = 4.0E0 )
* ..
* .. Local Scalars ..
REAL B, C, DEL, TAU, TEMP, W
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SQRT
* ..
* .. Executable Statements ..
*
DEL = D( 2 ) - D( 1 )
IF( I.EQ.1 ) THEN
W = ONE + TWO*RHO*( Z( 2 )*Z( 2 )-Z( 1 )*Z( 1 ) ) / DEL
IF( W.GT.ZERO ) THEN
OPS = OPS + 33
B = DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
C = RHO*Z( 1 )*Z( 1 )*DEL
*
* B > ZERO, always
*
TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) )
DLAM = D( 1 ) + TAU
DELTA( 1 ) = -Z( 1 ) / TAU
DELTA( 2 ) = Z( 2 ) / ( DEL-TAU )
ELSE
OPS = OPS + 31
B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
C = RHO*Z( 2 )*Z( 2 )*DEL
IF( B.GT.ZERO ) THEN
TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) )
ELSE
TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO
END IF
DLAM = D( 2 ) + TAU
DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
DELTA( 2 ) = -Z( 2 ) / TAU
END IF
TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
DELTA( 1 ) = DELTA( 1 ) / TEMP
DELTA( 2 ) = DELTA( 2 ) / TEMP
ELSE
*
* Now I=2
*
OPS = OPS + 24
B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
C = RHO*Z( 2 )*Z( 2 )*DEL
IF( B.GT.ZERO ) THEN
TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO
ELSE
TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) )
END IF
DLAM = D( 2 ) + TAU
DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
DELTA( 2 ) = -Z( 2 ) / TAU
TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
DELTA( 1 ) = DELTA( 1 ) / TEMP
DELTA( 2 ) = DELTA( 2 ) / TEMP
END IF
RETURN
*
* End OF SLAED5
*
END
SUBROUTINE SLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
* Courant Institute, NAG Ltd., and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
LOGICAL ORGATI
INTEGER INFO, KNITER
REAL FINIT, RHO, TAU
* ..
* .. Array Arguments ..
REAL D( 3 ), Z( 3 )
* ..
* Common block to return operation count and iteration count
* ITCNT is unchanged, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLAED6 computes the positive or negative root (closest to the origin)
* of
* z(1) z(2) z(3)
* f(x) = rho + --------- + ---------- + ---------
* d(1)-x d(2)-x d(3)-x
*
* It is assumed that
*
* if ORGATI = .true. the root is between d(2) and d(3);
* otherwise it is between d(1) and d(2)
*
* This routine will be called by SLAED4 when necessary. In most cases,
* the root sought is the smallest in magnitude, though it might not be
* in some extremely rare situations.
*
* Arguments
* =========
*
* KNITER (input) INTEGER
* Refer to SLAED4 for its significance.
*
* ORGATI (input) LOGICAL
* If ORGATI is true, the needed root is between d(2) and
* d(3); otherwise it is between d(1) and d(2). See
* SLAED4 for further details.
*
* RHO (input) REAL
* Refer to the equation f(x) above.
*
* D (input) REAL array, dimension (3)
* D satisfies d(1) < d(2) < d(3).
*
* Z (input) REAL array, dimension (3)
* Each of the elements in z must be positive.
*
* FINIT (input) REAL
* The value of f at 0. It is more accurate than the one
* evaluated inside this routine (if someone wants to do
* so).
*
* TAU (output) REAL
* The root of the equation f(x).
*
* INFO (output) INTEGER
* = 0: successful exit
* > 0: if INFO = 1, failure to converge
*
* Further Details
* ===============
*
* Based on contributions by
* Ren-Cang Li, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXIT
PARAMETER ( MAXIT = 20 )
REAL ZERO, ONE, TWO, THREE, FOUR, EIGHT
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ THREE = 3.0E0, FOUR = 4.0E0, EIGHT = 8.0E0 )
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Local Arrays ..
REAL DSCALE( 3 ), ZSCALE( 3 )
* ..
* .. Local Scalars ..
LOGICAL FIRST, SCALE
INTEGER I, ITER, NITER
REAL A, B, BASE, C, DDF, DF, EPS, ERRETM, ETA, F,
$ FC, SCLFAC, SCLINV, SMALL1, SMALL2, SMINV1,
$ SMINV2, TEMP, TEMP1, TEMP2, TEMP3, TEMP4
* ..
* .. Save statement ..
SAVE FIRST, SMALL1, SMINV1, SMALL2, SMINV2, EPS
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT
* ..
* .. Data statements ..
DATA FIRST / .TRUE. /
* ..
* .. Executable Statements ..
*
INFO = 0
*
NITER = 1
TAU = ZERO
IF( KNITER.EQ.2 ) THEN
IF( ORGATI ) THEN
TEMP = ( D( 3 )-D( 2 ) ) / TWO
C = RHO + Z( 1 ) / ( ( D( 1 )-D( 2 ) )-TEMP )
A = C*( D( 2 )+D( 3 ) ) + Z( 2 ) + Z( 3 )
B = C*D( 2 )*D( 3 ) + Z( 2 )*D( 3 ) + Z( 3 )*D( 2 )
ELSE
TEMP = ( D( 1 )-D( 2 ) ) / TWO
C = RHO + Z( 3 ) / ( ( D( 3 )-D( 2 ) )-TEMP )
A = C*( D( 1 )+D( 2 ) ) + Z( 1 ) + Z( 2 )
B = C*D( 1 )*D( 2 ) + Z( 1 )*D( 2 ) + Z( 2 )*D( 1 )
END IF
TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) )
A = A / TEMP
B = B / TEMP
C = C / TEMP
OPS = OPS + 19
IF( C.EQ.ZERO ) THEN
TAU = B / A
OPS = OPS + 1
ELSE IF( A.LE.ZERO ) THEN
OPS = OPS + 8
TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
OPS = OPS + 8
TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
OPS = OPS + 9
TEMP = RHO + Z( 1 ) / ( D( 1 )-TAU ) +
$ Z( 2 ) / ( D( 2 )-TAU ) + Z( 3 ) / ( D( 3 )-TAU )
IF( ABS( FINIT ).LE.ABS( TEMP ) )
$ TAU = ZERO
END IF
*
* On first call to routine, get machine parameters for
* possible scaling to avoid overflow
*
IF( FIRST ) THEN
EPS = SLAMCH( 'Epsilon' )
BASE = SLAMCH( 'Base' )
SMALL1 = BASE**( INT( LOG( SLAMCH( 'SafMin' ) ) / LOG( BASE ) /
$ THREE ) )
SMINV1 = ONE / SMALL1
SMALL2 = SMALL1*SMALL1
SMINV2 = SMINV1*SMINV1
FIRST = .FALSE.
END IF
*
* Determine if scaling of inputs necessary to avoid overflow
* when computing 1/TEMP**3
*
OPS = OPS + 2
IF( ORGATI ) THEN
TEMP = MIN( ABS( D( 2 )-TAU ), ABS( D( 3 )-TAU ) )
ELSE
TEMP = MIN( ABS( D( 1 )-TAU ), ABS( D( 2 )-TAU ) )
END IF
SCALE = .FALSE.
IF( TEMP.LE.SMALL1 ) THEN
SCALE = .TRUE.
IF( TEMP.LE.SMALL2 ) THEN
*
* Scale up by power of radix nearest 1/SAFMIN**(2/3)
*
SCLFAC = SMINV2
SCLINV = SMALL2
ELSE
*
* Scale up by power of radix nearest 1/SAFMIN**(1/3)
*
SCLFAC = SMINV1
SCLINV = SMALL1
END IF
*
* Scaling up safe because D, Z, TAU scaled elsewhere to be O(1)
*
OPS = OPS + 7
DO 10 I = 1, 3
DSCALE( I ) = D( I )*SCLFAC
ZSCALE( I ) = Z( I )*SCLFAC
10 CONTINUE
TAU = TAU*SCLFAC
ELSE
*
* Copy D and Z to DSCALE and ZSCALE
*
DO 20 I = 1, 3
DSCALE( I ) = D( I )
ZSCALE( I ) = Z( I )
20 CONTINUE
END IF
*
FC = ZERO
DF = ZERO
DDF = ZERO
OPS = OPS + 11
DO 30 I = 1, 3
TEMP = ONE / ( DSCALE( I )-TAU )
TEMP1 = ZSCALE( I )*TEMP
TEMP2 = TEMP1*TEMP
TEMP3 = TEMP2*TEMP
FC = FC + TEMP1 / DSCALE( I )
DF = DF + TEMP2
DDF = DDF + TEMP3
30 CONTINUE
F = FINIT + TAU*FC
*
IF( ABS( F ).LE.ZERO )
$ GO TO 60
*
* Iteration begins
*
* It is not hard to see that
*
* 1) Iterations will go up monotonically
* if FINIT < 0;
*
* 2) Iterations will go down monotonically
* if FINIT > 0.
*
ITER = NITER + 1
*
DO 50 NITER = ITER, MAXIT
*
OPS = OPS + 18
IF( ORGATI ) THEN
TEMP1 = DSCALE( 2 ) - TAU
TEMP2 = DSCALE( 3 ) - TAU
ELSE
TEMP1 = DSCALE( 1 ) - TAU
TEMP2 = DSCALE( 2 ) - TAU
END IF
A = ( TEMP1+TEMP2 )*F - TEMP1*TEMP2*DF
B = TEMP1*TEMP2*F
C = F - ( TEMP1+TEMP2 )*DF + TEMP1*TEMP2*DDF
TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) )
A = A / TEMP
B = B / TEMP
C = C / TEMP
IF( C.EQ.ZERO ) THEN
OPS = OPS + 1
ETA = B / A
ELSE IF( A.LE.ZERO ) THEN
OPS = OPS + 8
ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
OPS = OPS + 8
ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
IF( F*ETA.GE.ZERO ) THEN
OPS = OPS + 1
ETA = -F / DF
END IF
*
OPS = OPS + 1
TEMP = ETA + TAU
IF( ORGATI ) THEN
IF( ETA.GT.ZERO .AND. TEMP.GE.DSCALE( 3 ) ) THEN
OPS = OPS + 2
ETA = ( DSCALE( 3 )-TAU ) / TWO
END IF
IF( ETA.LT.ZERO .AND. TEMP.LE.DSCALE( 2 ) ) THEN
OPS = OPS + 2
ETA = ( DSCALE( 2 )-TAU ) / TWO
END IF
ELSE
IF( ETA.GT.ZERO .AND. TEMP.GE.DSCALE( 2 ) ) THEN
OPS = OPS + 2
ETA = ( DSCALE( 2 )-TAU ) / TWO
END IF
IF( ETA.LT.ZERO .AND. TEMP.LE.DSCALE( 1 ) ) THEN
OPS = OPS + 2
ETA = ( DSCALE( 1 )-TAU ) / TWO
END IF
END IF
OPS = OPS + 1
TAU = TAU + ETA
*
FC = ZERO
ERRETM = ZERO
DF = ZERO
DDF = ZERO
OPS = OPS + 37
DO 40 I = 1, 3
TEMP = ONE / ( DSCALE( I )-TAU )
TEMP1 = ZSCALE( I )*TEMP
TEMP2 = TEMP1*TEMP
TEMP3 = TEMP2*TEMP
TEMP4 = TEMP1 / DSCALE( I )
FC = FC + TEMP4
ERRETM = ERRETM + ABS( TEMP4 )
DF = DF + TEMP2
DDF = DDF + TEMP3
40 CONTINUE
F = FINIT + TAU*FC
ERRETM = EIGHT*( ABS( FINIT )+ABS( TAU )*ERRETM ) +
$ ABS( TAU )*DF
IF( ABS( F ).LE.EPS*ERRETM )
$ GO TO 60
50 CONTINUE
INFO = 1
60 CONTINUE
*
* Undo scaling
*
IF( SCALE ) THEN
OPS = OPS + 1
TAU = TAU*SCLINV
END IF
RETURN
*
* End of SLAED6
*
END
SUBROUTINE SLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q,
$ LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR,
$ PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK,
$ INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
INTEGER CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N,
$ QSIZ, TLVLS
REAL RHO
* ..
* .. Array Arguments ..
INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),
$ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )
REAL D( * ), GIVNUM( 2, * ), Q( LDQ, * ),
$ QSTORE( * ), WORK( * )
* ..
* Common block to return operation count and iteration count
* ITCNT is unchanged, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLAED7 computes the updated eigensystem of a diagonal
* matrix after modification by a rank-one symmetric matrix. This
* routine is used only for the eigenproblem which requires all
* eigenvalues and optionally eigenvectors of a dense symmetric matrix
* that has been reduced to tridiagonal form. SLAED1 handles
* the case in which all eigenvalues and eigenvectors of a symmetric
* tridiagonal matrix are desired.
*
* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)
*
* where Z = Q'u, u is a vector of length N with ones in the
* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
*
* The eigenvectors of the original matrix are stored in Q, and the
* eigenvalues are in D. The algorithm consists of three stages:
*
* The first stage consists of deflating the size of the problem
* when there are multiple eigenvalues or if there is a zero in
* the Z vector. For each such occurence the dimension of the
* secular equation problem is reduced by one. This stage is
* performed by the routine SLAED8.
*
* The second stage consists of calculating the updated
* eigenvalues. This is done by finding the roots of the secular
* equation via the routine SLAED4 (as called by SLAED9).
* This routine also calculates the eigenvectors of the current
* problem.
*
* The final stage consists of computing the updated eigenvectors
* directly using the updated eigenvalues. The eigenvectors for
* the current problem are multiplied with the eigenvectors from
* the overall problem.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* = 0: Compute eigenvalues only.
* = 1: Compute eigenvectors of original dense symmetric matrix
* also. On entry, Q contains the orthogonal matrix used
* to reduce the original matrix to tridiagonal form.
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* QSIZ (input) INTEGER
* The dimension of the orthogonal matrix used to reduce
* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.
*
* TLVLS (input) INTEGER
* The total number of merging levels in the overall divide and
* conquer tree.
*
* CURLVL (input) INTEGER
* The current level in the overall merge routine,
* 0 <= CURLVL <= TLVLS.
*
* CURPBM (input) INTEGER
* The current problem in the current level in the overall
* merge routine (counting from upper left to lower right).
*
* D (input/output) REAL array, dimension (N)
* On entry, the eigenvalues of the rank-1-perturbed matrix.
* On exit, the eigenvalues of the repaired matrix.
*
* Q (input/output) REAL array, dimension (LDQ, N)
* On entry, the eigenvectors of the rank-1-perturbed matrix.
* On exit, the eigenvectors of the repaired tridiagonal matrix.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* INDXQ (output) INTEGER array, dimension (N)
* The permutation which will reintegrate the subproblem just
* solved back into sorted order, i.e., D( INDXQ( I = 1, N ) )
* will be in ascending order.
*
* RHO (input) REAL
* The subdiagonal element used to create the rank-1
* modification.
*
* CUTPNT (input) INTEGER
* Contains the location of the last eigenvalue in the leading
* sub-matrix. min(1,N) <= CUTPNT <= N.
*
* QSTORE (input/output) REAL array, dimension (N**2+1)
* Stores eigenvectors of submatrices encountered during
* divide and conquer, packed together. QPTR points to
* beginning of the submatrices.
*
* QPTR (input/output) INTEGER array, dimension (N+2)
* List of indices pointing to beginning of submatrices stored
* in QSTORE. The submatrices are numbered starting at the
* bottom left of the divide and conquer tree, from left to
* right and bottom to top.
*
* PRMPTR (input) INTEGER array, dimension (N lg N)
* Contains a list of pointers which indicate where in PERM a
* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)
* indicates the size of the permutation and also the size of
* the full, non-deflated problem.
*
* PERM (input) INTEGER array, dimension (N lg N)
* Contains the permutations (from deflation and sorting) to be
* applied to each eigenblock.
*
* GIVPTR (input) INTEGER array, dimension (N lg N)
* Contains a list of pointers which indicate where in GIVCOL a
* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)
* indicates the number of Givens rotations.
*
* GIVCOL (input) INTEGER array, dimension (2, N lg N)
* Each pair of numbers indicates a pair of columns to take place
* in a Givens rotation.
*
* GIVNUM (input) REAL array, dimension (2, N lg N)
* Each number indicates the S value to be used in the
* corresponding Givens rotation.
*
* WORK (workspace) REAL array, dimension (3*N+QSIZ*N)
*
* IWORK (workspace) INTEGER array, dimension (4*N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an eigenvalue did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
INTEGER COLTYP, CURR, I, IDLMDA, INDX, INDXC, INDXP,
$ IQ2, IS, IW, IZ, K, LDQ2, N1, N2, PTR
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SLAED8, SLAED9, SLAEDA, SLAMRG, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN
INFO = -4
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( MIN( 1, N ).GT.CUTPNT .OR. N.LT.CUTPNT ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLAED7', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* The following values are for bookkeeping purposes only. They are
* integer pointers which indicate the portion of the workspace
* used by a particular array in SLAED8 and SLAED9.
*
IF( ICOMPQ.EQ.1 ) THEN
LDQ2 = QSIZ
ELSE
LDQ2 = N
END IF
*
IZ = 1
IDLMDA = IZ + N
IW = IDLMDA + N
IQ2 = IW + N
IS = IQ2 + N*LDQ2
*
INDX = 1
INDXC = INDX + N
COLTYP = INDXC + N
INDXP = COLTYP + N
*
* Form the z-vector which consists of the last row of Q_1 and the
* first row of Q_2.
*
PTR = 1 + 2**TLVLS
DO 10 I = 1, CURLVL - 1
PTR = PTR + 2**( TLVLS-I )
10 CONTINUE
CURR = PTR + CURPBM
CALL SLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,
$ GIVCOL, GIVNUM, QSTORE, QPTR, WORK( IZ ),
$ WORK( IZ+N ), INFO )
*
* When solving the final problem, we no longer need the stored data,
* so we will overwrite the data from this level onto the previously
* used storage space.
*
IF( CURLVL.EQ.TLVLS ) THEN
QPTR( CURR ) = 1
PRMPTR( CURR ) = 1
GIVPTR( CURR ) = 1
END IF
*
* Sort and Deflate eigenvalues.
*
CALL SLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, CUTPNT,
$ WORK( IZ ), WORK( IDLMDA ), WORK( IQ2 ), LDQ2,
$ WORK( IW ), PERM( PRMPTR( CURR ) ), GIVPTR( CURR+1 ),
$ GIVCOL( 1, GIVPTR( CURR ) ),
$ GIVNUM( 1, GIVPTR( CURR ) ), IWORK( INDXP ),
$ IWORK( INDX ), INFO )
PRMPTR( CURR+1 ) = PRMPTR( CURR ) + N
GIVPTR( CURR+1 ) = GIVPTR( CURR+1 ) + GIVPTR( CURR )
*
* Solve Secular Equation.
*
IF( K.NE.0 ) THEN
CALL SLAED9( K, 1, K, N, D, WORK( IS ), K, RHO, WORK( IDLMDA ),
$ WORK( IW ), QSTORE( QPTR( CURR ) ), K, INFO )
IF( INFO.NE.0 )
$ GO TO 30
IF( ICOMPQ.EQ.1 ) THEN
OPS = OPS + 2*REAL( QSIZ )*K*K
CALL SGEMM( 'N', 'N', QSIZ, K, K, ONE, WORK( IQ2 ), LDQ2,
$ QSTORE( QPTR( CURR ) ), K, ZERO, Q, LDQ )
END IF
QPTR( CURR+1 ) = QPTR( CURR ) + K**2
*
* Prepare the INDXQ sorting permutation.
*
N1 = K
N2 = N - K
CALL SLAMRG( N1, N2, D, 1, -1, INDXQ )
ELSE
QPTR( CURR+1 ) = QPTR( CURR )
DO 20 I = 1, N
INDXQ( I ) = I
20 CONTINUE
END IF
*
30 CONTINUE
RETURN
*
* End of SLAED7
*
END
SUBROUTINE SLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO,
$ CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR,
$ GIVCOL, GIVNUM, INDXP, INDX, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
* Courant Institute, NAG Ltd., and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
INTEGER CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N,
$ QSIZ
REAL RHO
* ..
* .. Array Arguments ..
INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ),
$ INDXQ( * ), PERM( * )
REAL D( * ), DLAMDA( * ), GIVNUM( 2, * ),
$ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * )
* ..
* Common block to return operation count and iteration count
* ITCNT is unchanged, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLAED8 merges the two sets of eigenvalues together into a single
* sorted set. Then it tries to deflate the size of the problem.
* There are two ways in which deflation can occur: when two or more
* eigenvalues are close together or if there is a tiny element in the
* Z vector. For each such occurrence the order of the related secular
* equation problem is reduced by one.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* = 0: Compute eigenvalues only.
* = 1: Compute eigenvectors of original dense symmetric matrix
* also. On entry, Q contains the orthogonal matrix used
* to reduce the original matrix to tridiagonal form.
*
* K (output) INTEGER
* The number of non-deflated eigenvalues, and the order of the
* related secular equation.
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* QSIZ (input) INTEGER
* The dimension of the orthogonal matrix used to reduce
* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.
*
* D (input/output) REAL array, dimension (N)
* On entry, the eigenvalues of the two submatrices to be
* combined. On exit, the trailing (N-K) updated eigenvalues
* (those which were deflated) sorted into increasing order.
*
* Q (input/output) REAL array, dimension (LDQ,N)
* If ICOMPQ = 0, Q is not referenced. Otherwise,
* on entry, Q contains the eigenvectors of the partially solved
* system which has been previously updated in matrix
* multiplies with other partially solved eigensystems.
* On exit, Q contains the trailing (N-K) updated eigenvectors
* (those which were deflated) in its last N-K columns.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* INDXQ (input) INTEGER array, dimension (N)
* The permutation which separately sorts the two sub-problems
* in D into ascending order. Note that elements in the second
* half of this permutation must first have CUTPNT added to
* their values in order to be accurate.
*
* RHO (input/output) REAL
* On entry, the off-diagonal element associated with the rank-1
* cut which originally split the two submatrices which are now
* being recombined.
* On exit, RHO has been modified to the value required by
* SLAED3.
*
* CUTPNT (input) INTEGER
* The location of the last eigenvalue in the leading
* sub-matrix. min(1,N) <= CUTPNT <= N.
*
* Z (input) REAL array, dimension (N)
* On entry, Z contains the updating vector (the last row of
* the first sub-eigenvector matrix and the first row of the
* second sub-eigenvector matrix).
* On exit, the contents of Z are destroyed by the updating
* process.
*
* DLAMDA (output) REAL array, dimension (N)
* A copy of the first K eigenvalues which will be used by
* SLAED3 to form the secular equation.
*
* Q2 (output) REAL array, dimension (LDQ2,N)
* If ICOMPQ = 0, Q2 is not referenced. Otherwise,
* a copy of the first K eigenvectors which will be used by
* SLAED7 in a matrix multiply (SGEMM) to update the new
* eigenvectors.
*
* LDQ2 (input) INTEGER
* The leading dimension of the array Q2. LDQ2 >= max(1,N).
*
* W (output) REAL array, dimension (N)
* The first k values of the final deflation-altered z-vector and
* will be passed to SLAED3.
*
* PERM (output) INTEGER array, dimension (N)
* The permutations (from deflation and sorting) to be applied
* to each eigenblock.
*
* GIVPTR (output) INTEGER
* The number of Givens rotations which took place in this
* subproblem.
*
* GIVCOL (output) INTEGER array, dimension (2, N)
* Each pair of numbers indicates a pair of columns to take place
* in a Givens rotation.
*
* GIVNUM (output) REAL array, dimension (2, N)
* Each number indicates the S value to be used in the
* corresponding Givens rotation.
*
* INDXP (workspace) INTEGER array, dimension (N)
* The permutation used to place deflated values of D at the end
* of the array. INDXP(1:K) points to the nondeflated D-values
* and INDXP(K+1:N) points to the deflated eigenvalues.
*
* INDX (workspace) INTEGER array, dimension (N)
* The permutation used to sort the contents of D into ascending
* order.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL MONE, ZERO, ONE, TWO, EIGHT
PARAMETER ( MONE = -1.0E0, ZERO = 0.0E0, ONE = 1.0E0,
$ TWO = 2.0E0, EIGHT = 8.0E0 )
* ..
* .. Local Scalars ..
*
INTEGER I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2
REAL C, EPS, S, T, TAU, TOL
* ..
* .. External Functions ..
INTEGER ISAMAX
REAL SLAMCH, SLAPY2
EXTERNAL ISAMAX, SLAMCH, SLAPY2
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLACPY, SLAMRG, SROT, SSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN
INFO = -4
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN
INFO = -10
ELSE IF( LDQ2.LT.MAX( 1, N ) ) THEN
INFO = -14
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLAED8', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
N1 = CUTPNT
N2 = N - N1
N1P1 = N1 + 1
*
IF( RHO.LT.ZERO ) THEN
OPS = OPS + N2
CALL SSCAL( N2, MONE, Z( N1P1 ), 1 )
END IF
*
* Normalize z so that norm(z) = 1
*
OPS = OPS + N + 6
T = ONE / SQRT( TWO )
DO 10 J = 1, N
INDX( J ) = J
10 CONTINUE
CALL SSCAL( N, T, Z, 1 )
RHO = ABS( TWO*RHO )
*
* Sort the eigenvalues into increasing order
*
DO 20 I = CUTPNT + 1, N
INDXQ( I ) = INDXQ( I ) + CUTPNT
20 CONTINUE
DO 30 I = 1, N
DLAMDA( I ) = D( INDXQ( I ) )
W( I ) = Z( INDXQ( I ) )
30 CONTINUE
I = 1
J = CUTPNT + 1
CALL SLAMRG( N1, N2, DLAMDA, 1, 1, INDX )
DO 40 I = 1, N
D( I ) = DLAMDA( INDX( I ) )
Z( I ) = W( INDX( I ) )
40 CONTINUE
*
* Calculate the allowable deflation tolerence
*
IMAX = ISAMAX( N, Z, 1 )
JMAX = ISAMAX( N, D, 1 )
EPS = SLAMCH( 'Epsilon' )
TOL = EIGHT*EPS*ABS( D( JMAX ) )
*
* If the rank-1 modifier is small enough, no more needs to be done
* except to reorganize Q so that its columns correspond with the
* elements in D.
*
IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN
K = 0
IF( ICOMPQ.EQ.0 ) THEN
DO 50 J = 1, N
PERM( J ) = INDXQ( INDX( J ) )
50 CONTINUE
ELSE
DO 60 J = 1, N
PERM( J ) = INDXQ( INDX( J ) )
CALL SCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
60 CONTINUE
CALL SLACPY( 'A', QSIZ, N, Q2( 1, 1 ), LDQ2, Q( 1, 1 ),
$ LDQ )
END IF
RETURN
END IF
*
* If there are multiple eigenvalues then the problem deflates. Here
* the number of equal eigenvalues are found. As each equal
* eigenvalue is found, an elementary reflector is computed to rotate
* the corresponding eigensubspace so that the corresponding
* components of Z are zero in this new basis.
*
K = 0
GIVPTR = 0
K2 = N + 1
DO 70 J = 1, N
OPS = OPS + 1
IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
INDXP( K2 ) = J
IF( J.EQ.N )
$ GO TO 110
ELSE
JLAM = J
GO TO 80
END IF
70 CONTINUE
80 CONTINUE
J = J + 1
IF( J.GT.N )
$ GO TO 100
OPS = OPS + 1
IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
INDXP( K2 ) = J
ELSE
*
* Check if eigenvalues are close enough to allow deflation.
*
S = Z( JLAM )
C = Z( J )
*
* Find sqrt(a**2+b**2) without overflow or
* destructive underflow.
*
OPS = OPS + 10
TAU = SLAPY2( C, S )
T = D( J ) - D( JLAM )
C = C / TAU
S = -S / TAU
IF( ABS( T*C*S ).LE.TOL ) THEN
*
* Deflation is possible.
*
Z( J ) = TAU
Z( JLAM ) = ZERO
*
* Record the appropriate Givens rotation
*
GIVPTR = GIVPTR + 1
GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) )
GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) )
GIVNUM( 1, GIVPTR ) = C
GIVNUM( 2, GIVPTR ) = S
IF( ICOMPQ.EQ.1 ) THEN
OPS = OPS + 6*QSIZ
CALL SROT( QSIZ, Q( 1, INDXQ( INDX( JLAM ) ) ), 1,
$ Q( 1, INDXQ( INDX( J ) ) ), 1, C, S )
END IF
OPS = OPS + 10
T = D( JLAM )*C*C + D( J )*S*S
D( J ) = D( JLAM )*S*S + D( J )*C*C
D( JLAM ) = T
K2 = K2 - 1
I = 1
90 CONTINUE
IF( K2+I.LE.N ) THEN
IF( D( JLAM ).LT.D( INDXP( K2+I ) ) ) THEN
INDXP( K2+I-1 ) = INDXP( K2+I )
INDXP( K2+I ) = JLAM
I = I + 1
GO TO 90
ELSE
INDXP( K2+I-1 ) = JLAM
END IF
ELSE
INDXP( K2+I-1 ) = JLAM
END IF
JLAM = J
ELSE
K = K + 1
W( K ) = Z( JLAM )
DLAMDA( K ) = D( JLAM )
INDXP( K ) = JLAM
JLAM = J
END IF
END IF
GO TO 80
100 CONTINUE
*
* Record the last eigenvalue.
*
K = K + 1
W( K ) = Z( JLAM )
DLAMDA( K ) = D( JLAM )
INDXP( K ) = JLAM
*
110 CONTINUE
*
* Sort the eigenvalues and corresponding eigenvectors into DLAMDA
* and Q2 respectively. The eigenvalues/vectors which were not
* deflated go into the first K slots of DLAMDA and Q2 respectively,
* while those which were deflated go into the last N - K slots.
*
IF( ICOMPQ.EQ.0 ) THEN
DO 120 J = 1, N
JP = INDXP( J )
DLAMDA( J ) = D( JP )
PERM( J ) = INDXQ( INDX( JP ) )
120 CONTINUE
ELSE
DO 130 J = 1, N
JP = INDXP( J )
DLAMDA( J ) = D( JP )
PERM( J ) = INDXQ( INDX( JP ) )
CALL SCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
130 CONTINUE
END IF
*
* The deflated eigenvalues and their corresponding vectors go back
* into the last N - K slots of D and Q respectively.
*
IF( K.LT.N ) THEN
IF( ICOMPQ.EQ.0 ) THEN
CALL SCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )
ELSE
CALL SCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )
CALL SLACPY( 'A', QSIZ, N-K, Q2( 1, K+1 ), LDQ2,
$ Q( 1, K+1 ), LDQ )
END IF
END IF
*
RETURN
*
* End of SLAED8
*
END
SUBROUTINE SLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W,
$ S, LDS, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
* Courant Institute, NAG Ltd., and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N
REAL RHO
* ..
* .. Array Arguments ..
REAL D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ),
$ W( * )
* ..
* Common block to return operation count and iteration count
* ITCNT is unchanged, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLAED9 finds the roots of the secular equation, as defined by the
* values in D, Z, and RHO, between KSTART and KSTOP. It makes the
* appropriate calls to SLAED4 and then stores the new matrix of
* eigenvectors for use in calculating the next level of Z vectors.
*
* Arguments
* =========
*
* K (input) INTEGER
* The number of terms in the rational function to be solved by
* SLAED4. K >= 0.
*
* KSTART (input) INTEGER
* KSTOP (input) INTEGER
* The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP
* are to be computed. 1 <= KSTART <= KSTOP <= K.
*
* N (input) INTEGER
* The number of rows and columns in the Q matrix.
* N >= K (delation may result in N > K).
*
* D (output) REAL array, dimension (N)
* D(I) contains the updated eigenvalues
* for KSTART <= I <= KSTOP.
*
* Q (workspace) REAL array, dimension (LDQ,N)
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max( 1, N ).
*
* RHO (input) REAL
* The value of the parameter in the rank one update equation.
* RHO >= 0 required.
*
* DLAMDA (input) REAL array, dimension (K)
* The first K elements of this array contain the old roots
* of the deflated updating problem. These are the poles
* of the secular equation.
*
* W (input) REAL array, dimension (K)
* The first K elements of this array contain the components
* of the deflation-adjusted updating vector.
*
* S (output) REAL array, dimension (LDS, K)
* Will contain the eigenvectors of the repaired matrix which
* will be stored for subsequent Z vector calculation and
* multiplied by the previously accumulated eigenvectors
* to update the system.
*
* LDS (input) INTEGER
* The leading dimension of S. LDS >= max( 1, K ).
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an eigenvalue did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J
REAL TEMP
* ..
* .. External Functions ..
REAL SLAMC3, SNRM2
EXTERNAL SLAMC3, SNRM2
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLAED4, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( K.LT.0 ) THEN
INFO = -1
ELSE IF( KSTART.LT.1 .OR. KSTART.GT.MAX( 1, K ) ) THEN
INFO = -2
ELSE IF( MAX( 1, KSTOP ).LT.KSTART .OR. KSTOP.GT.MAX( 1, K ) )
$ THEN
INFO = -3
ELSE IF( N.LT.K ) THEN
INFO = -4
ELSE IF( LDQ.LT.MAX( 1, K ) ) THEN
INFO = -7
ELSE IF( LDS.LT.MAX( 1, K ) ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLAED9', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( K.EQ.0 )
$ RETURN
*
* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
* be computed with high relative accuracy (barring over/underflow).
* This is a problem on machines without a guard digit in
* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
* which on any of these machines zeros out the bottommost
* bit of DLAMDA(I) if it is 1; this makes the subsequent
* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
* occurs. On binary machines with a guard digit (almost all
* machines) it does not change DLAMDA(I) at all. On hexadecimal
* and decimal machines with a guard digit, it slightly
* changes the bottommost bits of DLAMDA(I). It does not account
* for hexadecimal or decimal machines without guard digits
* (we know of none). We use a subroutine call to compute
* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating
* this code.
*
OPS = OPS + 2*N
DO 10 I = 1, N
DLAMDA( I ) = SLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I )
10 CONTINUE
*
DO 20 J = KSTART, KSTOP
CALL SLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO )
*
* If the zero finder fails, the computation is terminated.
*
IF( INFO.NE.0 )
$ GO TO 120
20 CONTINUE
*
IF( K.EQ.1 .OR. K.EQ.2 ) THEN
DO 40 I = 1, K
DO 30 J = 1, K
S( J, I ) = Q( J, I )
30 CONTINUE
40 CONTINUE
GO TO 120
END IF
*
* Compute updated W.
*
CALL SCOPY( K, W, 1, S, 1 )
*
* Initialize W(I) = Q(I,I)
*
CALL SCOPY( K, Q, LDQ+1, W, 1 )
OPS = OPS + 3*K*( K-1 ) + K
DO 70 J = 1, K
DO 50 I = 1, J - 1
W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
50 CONTINUE
DO 60 I = J + 1, K
W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
60 CONTINUE
70 CONTINUE
DO 80 I = 1, K
W( I ) = SIGN( SQRT( -W( I ) ), S( I, 1 ) )
80 CONTINUE
*
* Compute eigenvectors of the modified rank-1 modification.
*
OPS = OPS + 4*K*K
DO 110 J = 1, K
DO 90 I = 1, K
Q( I, J ) = W( I ) / Q( I, J )
90 CONTINUE
TEMP = SNRM2( K, Q( 1, J ), 1 )
DO 100 I = 1, K
S( I, J ) = Q( I, J ) / TEMP
100 CONTINUE
110 CONTINUE
*
120 CONTINUE
RETURN
*
* End of SLAED9
*
END
SUBROUTINE SLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,
$ GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
INTEGER CURLVL, CURPBM, INFO, N, TLVLS
* ..
* .. Array Arguments ..
INTEGER GIVCOL( 2, * ), GIVPTR( * ), PERM( * ),
$ PRMPTR( * ), QPTR( * )
REAL GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * )
* ..
* Common block to return operation count and iteration count
* ITCNT is unchanged, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLAEDA computes the Z vector corresponding to the merge step in the
* CURLVLth step of the merge process with TLVLS steps for the CURPBMth
* problem.
*
* Arguments
* =========
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* TLVLS (input) INTEGER
* The total number of merging levels in the overall divide and
* conquer tree.
*
* CURLVL (input) INTEGER
* The current level in the overall merge routine,
* 0 <= curlvl <= tlvls.
*
* CURPBM (input) INTEGER
* The current problem in the current level in the overall
* merge routine (counting from upper left to lower right).
*
* PRMPTR (input) INTEGER array, dimension (N lg N)
* Contains a list of pointers which indicate where in PERM a
* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)
* indicates the size of the permutation and incidentally the
* size of the full, non-deflated problem.
*
* PERM (input) INTEGER array, dimension (N lg N)
* Contains the permutations (from deflation and sorting) to be
* applied to each eigenblock.
*
* GIVPTR (input) INTEGER array, dimension (N lg N)
* Contains a list of pointers which indicate where in GIVCOL a
* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)
* indicates the number of Givens rotations.
*
* GIVCOL (input) INTEGER array, dimension (2, N lg N)
* Each pair of numbers indicates a pair of columns to take place
* in a Givens rotation.
*
* GIVNUM (input) REAL array, dimension (2, N lg N)
* Each number indicates the S value to be used in the
* corresponding Givens rotation.
*
* Q (input) REAL array, dimension (N**2)
* Contains the square eigenblocks from previous levels, the
* starting positions for blocks are given by QPTR.
*
* QPTR (input) INTEGER array, dimension (N+2)
* Contains a list of pointers which indicate where in Q an
* eigenblock is stored. SQRT( QPTR(i+1) - QPTR(i) ) indicates
* the size of the block.
*
* Z (output) REAL array, dimension (N)
* On output this vector contains the updating vector (the last
* row of the first sub-eigenvector matrix and the first row of
* the second sub-eigenvector matrix).
*
* ZTEMP (workspace) REAL array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
INTEGER BSIZ1, BSIZ2, CURR, I, K, MID, PSIZ1, PSIZ2,
$ PTR, ZPTR1
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMV, SROT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC INT, REAL, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( N.LT.0 ) THEN
INFO = -1
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLAEDA', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Determine location of first number in second half.
*
MID = N / 2 + 1
*
* Gather last/first rows of appropriate eigenblocks into center of Z
*
PTR = 1
*
* Determine location of lowest level subproblem in the full storage
* scheme
*
CURR = PTR + CURPBM*2**CURLVL + 2**( CURLVL-1 ) - 1
*
* Determine size of these matrices. We add HALF to the value of
* the SQRT in case the machine underestimates one of these square
* roots.
*
OPS = OPS + 8
BSIZ1 = INT( HALF+SQRT( REAL( QPTR( CURR+1 )-QPTR( CURR ) ) ) )
BSIZ2 = INT( HALF+SQRT( REAL( QPTR( CURR+2 )-QPTR( CURR+1 ) ) ) )
DO 10 K = 1, MID - BSIZ1 - 1
Z( K ) = ZERO
10 CONTINUE
CALL SCOPY( BSIZ1, Q( QPTR( CURR )+BSIZ1-1 ), BSIZ1,
$ Z( MID-BSIZ1 ), 1 )
CALL SCOPY( BSIZ2, Q( QPTR( CURR+1 ) ), BSIZ2, Z( MID ), 1 )
DO 20 K = MID + BSIZ2, N
Z( K ) = ZERO
20 CONTINUE
*
* Loop thru remaining levels 1 -> CURLVL applying the Givens
* rotations and permutation and then multiplying the center matrices
* against the current Z.
*
PTR = 2**TLVLS + 1
DO 70 K = 1, CURLVL - 1
CURR = PTR + CURPBM*2**( CURLVL-K ) + 2**( CURLVL-K-1 ) - 1
PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR )
PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 )
ZPTR1 = MID - PSIZ1
*
* Apply Givens at CURR and CURR+1
*
OPS = OPS + 6*( GIVPTR( CURR+2 )-GIVPTR( CURR ) )
DO 30 I = GIVPTR( CURR ), GIVPTR( CURR+1 ) - 1
CALL SROT( 1, Z( ZPTR1+GIVCOL( 1, I )-1 ), 1,
$ Z( ZPTR1+GIVCOL( 2, I )-1 ), 1, GIVNUM( 1, I ),
$ GIVNUM( 2, I ) )
30 CONTINUE
DO 40 I = GIVPTR( CURR+1 ), GIVPTR( CURR+2 ) - 1
CALL SROT( 1, Z( MID-1+GIVCOL( 1, I ) ), 1,
$ Z( MID-1+GIVCOL( 2, I ) ), 1, GIVNUM( 1, I ),
$ GIVNUM( 2, I ) )
40 CONTINUE
PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR )
PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 )
DO 50 I = 0, PSIZ1 - 1
ZTEMP( I+1 ) = Z( ZPTR1+PERM( PRMPTR( CURR )+I )-1 )
50 CONTINUE
DO 60 I = 0, PSIZ2 - 1
ZTEMP( PSIZ1+I+1 ) = Z( MID+PERM( PRMPTR( CURR+1 )+I )-1 )
60 CONTINUE
*
* Multiply Blocks at CURR and CURR+1
*
* Determine size of these matrices. We add HALF to the value of
* the SQRT in case the machine underestimates one of these
* square roots.
*
OPS = OPS + 8
BSIZ1 = INT( HALF+SQRT( REAL( QPTR( CURR+1 )-QPTR( CURR ) ) ) )
BSIZ2 = INT( HALF+SQRT( REAL( QPTR( CURR+2 )-QPTR( CURR+
$ 1 ) ) ) )
IF( BSIZ1.GT.0 ) THEN
OPS = OPS + 2*BSIZ1*BSIZ1
CALL SGEMV( 'T', BSIZ1, BSIZ1, ONE, Q( QPTR( CURR ) ),
$ BSIZ1, ZTEMP( 1 ), 1, ZERO, Z( ZPTR1 ), 1 )
END IF
CALL SCOPY( PSIZ1-BSIZ1, ZTEMP( BSIZ1+1 ), 1, Z( ZPTR1+BSIZ1 ),
$ 1 )
IF( BSIZ2.GT.0 ) THEN
OPS = OPS + 2*BSIZ2*BSIZ2
CALL SGEMV( 'T', BSIZ2, BSIZ2, ONE, Q( QPTR( CURR+1 ) ),
$ BSIZ2, ZTEMP( PSIZ1+1 ), 1, ZERO, Z( MID ), 1 )
END IF
CALL SCOPY( PSIZ2-BSIZ2, ZTEMP( PSIZ1+BSIZ2+1 ), 1,
$ Z( MID+BSIZ2 ), 1 )
*
PTR = PTR + 2**( TLVLS-K )
70 CONTINUE
*
RETURN
*
* End of SLAEDA
*
END
SUBROUTINE SLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B,
$ LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO )
*
* -- LAPACK auxiliary routine (instrumented to count operations) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
LOGICAL NOINIT, RIGHTV
INTEGER INFO, LDB, LDH, N
REAL BIGNUM, EPS3, SMLNUM, WI, WR
* ..
* .. Array Arguments ..
REAL B( LDB, * ), H( LDH, * ), VI( * ), VR( * ),
$ WORK( * )
* ..
* Common block to return operation count.
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLAEIN uses inverse iteration to find a right or left eigenvector
* corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg
* matrix H.
*
* Arguments
* =========
*
* RIGHTV (input) LOGICAL
* = .TRUE. : compute right eigenvector;
* = .FALSE.: compute left eigenvector.
*
* NOINIT (input) LOGICAL
* = .TRUE. : no initial vector supplied in (VR,VI).
* = .FALSE.: initial vector supplied in (VR,VI).
*
* N (input) INTEGER
* The order of the matrix H. N >= 0.
*
* H (input) REAL array, dimension (LDH,N)
* The upper Hessenberg matrix H.
*
* LDH (input) INTEGER
* The leading dimension of the array H. LDH >= max(1,N).
*
* WR (input) REAL
* WI (input) REAL
* The real and imaginary parts of the eigenvalue of H whose
* corresponding right or left eigenvector is to be computed.
*
* VR (input/output) REAL array, dimension (N)
* VI (input/output) REAL array, dimension (N)
* On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain
* a real starting vector for inverse iteration using the real
* eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI
* must contain the real and imaginary parts of a complex
* starting vector for inverse iteration using the complex
* eigenvalue (WR,WI); otherwise VR and VI need not be set.
* On exit, if WI = 0.0 (real eigenvalue), VR contains the
* computed real eigenvector; if WI.ne.0.0 (complex eigenvalue),
* VR and VI contain the real and imaginary parts of the
* computed complex eigenvector. The eigenvector is normalized
* so that the component of largest magnitude has magnitude 1;
* here the magnitude of a complex number (x,y) is taken to be
* |x| + |y|.
* VI is not referenced if WI = 0.0.
*
* B (workspace) REAL array, dimension (LDB,N)
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= N+1.
*
* WORK (workspace) REAL array, dimension (N)
*
* EPS3 (input) REAL
* A small machine-dependent value which is used to perturb
* close eigenvalues, and to replace zero pivots.
*
* SMLNUM (input) REAL
* A machine-dependent value close to the underflow threshold.
*
* BIGNUM (input) REAL
* A machine-dependent value close to the overflow threshold.
*
* INFO (output) INTEGER
* = 0: successful exit
* = 1: inverse iteration did not converge; VR is set to the
* last iterate, and so is VI if WI.ne.0.0.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TENTH
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TENTH = 1.0E-1 )
* ..
* .. Local Scalars ..
CHARACTER NORMIN, TRANS
INTEGER I, I1, I2, I3, IERR, ITS, J
REAL ABSBII, ABSBJJ, EI, EJ, GROWTO, NORM, NRMSML,
$ OPST, REC, ROOTN, SCALE, TEMP, VCRIT, VMAX,
$ VNORM, W, W1, X, XI, XR, Y
* ..
* .. External Functions ..
INTEGER ISAMAX
REAL SASUM, SLAPY2, SNRM2
EXTERNAL ISAMAX, SASUM, SLAPY2, SNRM2
* ..
* .. External Subroutines ..
EXTERNAL SLADIV, SLATRS, SSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, REAL, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
***
* Initialize
OPST = 0
***
*
* GROWTO is the threshold used in the acceptance test for an
* eigenvector.
*
ROOTN = SQRT( REAL( N ) )
GROWTO = TENTH / ROOTN
NRMSML = MAX( ONE, EPS3*ROOTN )*SMLNUM
***
* Increment op count for computing ROOTN, GROWTO and NRMSML
OPST = OPST + 4
***
*
* Form B = H - (WR,WI)*I (except that the subdiagonal elements and
* the imaginary parts of the diagonal elements are not stored).
*
DO 20 J = 1, N
DO 10 I = 1, J - 1
B( I, J ) = H( I, J )
10 CONTINUE
B( J, J ) = H( J, J ) - WR
20 CONTINUE
***
OPST = OPST + N
***
*
IF( WI.EQ.ZERO ) THEN
*
* Real eigenvalue.
*
IF( NOINIT ) THEN
*
* Set initial vector.
*
DO 30 I = 1, N
VR( I ) = EPS3
30 CONTINUE
ELSE
*
* Scale supplied initial vector.
*
VNORM = SNRM2( N, VR, 1 )
CALL SSCAL( N, ( EPS3*ROOTN ) / MAX( VNORM, NRMSML ), VR,
$ 1 )
***
OPST = OPST + ( 3*N+2 )
***
END IF
*
IF( RIGHTV ) THEN
*
* LU decomposition with partial pivoting of B, replacing zero
* pivots by EPS3.
*
DO 60 I = 1, N - 1
EI = H( I+1, I )
IF( ABS( B( I, I ) ).LT.ABS( EI ) ) THEN
*
* Interchange rows and eliminate.
*
X = B( I, I ) / EI
B( I, I ) = EI
DO 40 J = I + 1, N
TEMP = B( I+1, J )
B( I+1, J ) = B( I, J ) - X*TEMP
B( I, J ) = TEMP
40 CONTINUE
ELSE
*
* Eliminate without interchange.
*
IF( B( I, I ).EQ.ZERO )
$ B( I, I ) = EPS3
X = EI / B( I, I )
IF( X.NE.ZERO ) THEN
DO 50 J = I + 1, N
B( I+1, J ) = B( I+1, J ) - X*B( I, J )
50 CONTINUE
END IF
END IF
60 CONTINUE
IF( B( N, N ).EQ.ZERO )
$ B( N, N ) = EPS3
***
* Increment op count for LU decomposition
OPS = OPS + ( N-1 )*( N+1 )
***
*
TRANS = 'N'
*
ELSE
*
* UL decomposition with partial pivoting of B, replacing zero
* pivots by EPS3.
*
DO 90 J = N, 2, -1
EJ = H( J, J-1 )
IF( ABS( B( J, J ) ).LT.ABS( EJ ) ) THEN
*
* Interchange columns and eliminate.
*
X = B( J, J ) / EJ
B( J, J ) = EJ
DO 70 I = 1, J - 1
TEMP = B( I, J-1 )
B( I, J-1 ) = B( I, J ) - X*TEMP
B( I, J ) = TEMP
70 CONTINUE
ELSE
*
* Eliminate without interchange.
*
IF( B( J, J ).EQ.ZERO )
$ B( J, J ) = EPS3
X = EJ / B( J, J )
IF( X.NE.ZERO ) THEN
DO 80 I = 1, J - 1
B( I, J-1 ) = B( I, J-1 ) - X*B( I, J )
80 CONTINUE
END IF
END IF
90 CONTINUE
IF( B( 1, 1 ).EQ.ZERO )
$ B( 1, 1 ) = EPS3
***
* Increment op count for UL decomposition
OPS = OPS + ( N-1 )*( N+1 )
***
*
TRANS = 'T'
*
END IF
*
NORMIN = 'N'
DO 110 ITS = 1, N
*
* Solve U*x = scale*v for a right eigenvector
* or U'*x = scale*v for a left eigenvector,
* overwriting x on v.
*
CALL SLATRS( 'Upper', TRANS, 'Nonunit', NORMIN, N, B, LDB,
$ VR, SCALE, WORK, IERR )
***
* Increment opcount for triangular solver, assuming that
* ops SLATRS = ops STRSV, with no scaling in SLATRS.
OPS = OPS + N*N
***
NORMIN = 'Y'
*
* Test for sufficient growth in the norm of v.
*
VNORM = SASUM( N, VR, 1 )
***
OPST = OPST + N
***
IF( VNORM.GE.GROWTO*SCALE )
$ GO TO 120
*
* Choose new orthogonal starting vector and try again.
*
TEMP = EPS3 / ( ROOTN+ONE )
VR( 1 ) = EPS3
DO 100 I = 2, N
VR( I ) = TEMP
100 CONTINUE
VR( N-ITS+1 ) = VR( N-ITS+1 ) - EPS3*ROOTN
***
OPST = OPST + 4
***
110 CONTINUE
*
* Failure to find eigenvector in N iterations.
*
INFO = 1
*
120 CONTINUE
*
* Normalize eigenvector.
*
I = ISAMAX( N, VR, 1 )
CALL SSCAL( N, ONE / ABS( VR( I ) ), VR, 1 )
***
OPST = OPST + ( 2*N+1 )
***
ELSE
*
* Complex eigenvalue.
*
IF( NOINIT ) THEN
*
* Set initial vector.
*
DO 130 I = 1, N
VR( I ) = EPS3
VI( I ) = ZERO
130 CONTINUE
ELSE
*
* Scale supplied initial vector.
*
NORM = SLAPY2( SNRM2( N, VR, 1 ), SNRM2( N, VI, 1 ) )
REC = ( EPS3*ROOTN ) / MAX( NORM, NRMSML )
CALL SSCAL( N, REC, VR, 1 )
CALL SSCAL( N, REC, VI, 1 )
***
OPST = OPST + ( 6*N+5 )
***
END IF
*
IF( RIGHTV ) THEN
*
* LU decomposition with partial pivoting of B, replacing zero
* pivots by EPS3.
*
* The imaginary part of the (i,j)-th element of U is stored in
* B(j+1,i).
*
B( 2, 1 ) = -WI
DO 140 I = 2, N
B( I+1, 1 ) = ZERO
140 CONTINUE
*
DO 170 I = 1, N - 1
ABSBII = SLAPY2( B( I, I ), B( I+1, I ) )
EI = H( I+1, I )
IF( ABSBII.LT.ABS( EI ) ) THEN
*
* Interchange rows and eliminate.
*
XR = B( I, I ) / EI
XI = B( I+1, I ) / EI
B( I, I ) = EI
B( I+1, I ) = ZERO
DO 150 J = I + 1, N
TEMP = B( I+1, J )
B( I+1, J ) = B( I, J ) - XR*TEMP
B( J+1, I+1 ) = B( J+1, I ) - XI*TEMP
B( I, J ) = TEMP
B( J+1, I ) = ZERO
150 CONTINUE
B( I+2, I ) = -WI
B( I+1, I+1 ) = B( I+1, I+1 ) - XI*WI
B( I+2, I+1 ) = B( I+2, I+1 ) + XR*WI
***
OPST = OPST + ( 4*( N-I )+6 )
***
ELSE
*
* Eliminate without interchanging rows.
*
IF( ABSBII.EQ.ZERO ) THEN
B( I, I ) = EPS3
B( I+1, I ) = ZERO
ABSBII = EPS3
END IF
EI = ( EI / ABSBII ) / ABSBII
XR = B( I, I )*EI
XI = -B( I+1, I )*EI
DO 160 J = I + 1, N
B( I+1, J ) = B( I+1, J ) - XR*B( I, J ) +
$ XI*B( J+1, I )
B( J+1, I+1 ) = -XR*B( J+1, I ) - XI*B( I, J )
160 CONTINUE
B( I+2, I+1 ) = B( I+2, I+1 ) - WI
***
OPST = OPST + ( 7*( N-I )+4 )
***
END IF
*
* Compute 1-norm of offdiagonal elements of i-th row.
*
WORK( I ) = SASUM( N-I, B( I, I+1 ), LDB ) +
$ SASUM( N-I, B( I+2, I ), 1 )
***
OPST = OPST + ( 2*( N-I )+4 )
***
170 CONTINUE
IF( B( N, N ).EQ.ZERO .AND. B( N+1, N ).EQ.ZERO )
$ B( N, N ) = EPS3
WORK( N ) = ZERO
*
I1 = N
I2 = 1
I3 = -1
ELSE
*
* UL decomposition with partial pivoting of conjg(B),
* replacing zero pivots by EPS3.
*
* The imaginary part of the (i,j)-th element of U is stored in
* B(j+1,i).
*
B( N+1, N ) = WI
DO 180 J = 1, N - 1
B( N+1, J ) = ZERO
180 CONTINUE
*
DO 210 J = N, 2, -1
EJ = H( J, J-1 )
ABSBJJ = SLAPY2( B( J, J ), B( J+1, J ) )
IF( ABSBJJ.LT.ABS( EJ ) ) THEN
*
* Interchange columns and eliminate
*
XR = B( J, J ) / EJ
XI = B( J+1, J ) / EJ
B( J, J ) = EJ
B( J+1, J ) = ZERO
DO 190 I = 1, J - 1
TEMP = B( I, J-1 )
B( I, J-1 ) = B( I, J ) - XR*TEMP
B( J, I ) = B( J+1, I ) - XI*TEMP
B( I, J ) = TEMP
B( J+1, I ) = ZERO
190 CONTINUE
B( J+1, J-1 ) = WI
B( J-1, J-1 ) = B( J-1, J-1 ) + XI*WI
B( J, J-1 ) = B( J, J-1 ) - XR*WI
***
OPST = OPST + ( 4*( J-1 )+6 )
***
ELSE
*
* Eliminate without interchange.
*
IF( ABSBJJ.EQ.ZERO ) THEN
B( J, J ) = EPS3
B( J+1, J ) = ZERO
ABSBJJ = EPS3
END IF
EJ = ( EJ / ABSBJJ ) / ABSBJJ
XR = B( J, J )*EJ
XI = -B( J+1, J )*EJ
DO 200 I = 1, J - 1
B( I, J-1 ) = B( I, J-1 ) - XR*B( I, J ) +
$ XI*B( J+1, I )
B( J, I ) = -XR*B( J+1, I ) - XI*B( I, J )
200 CONTINUE
B( J, J-1 ) = B( J, J-1 ) + WI
***
OPST = OPST + ( 7*( J-1 )+4 )
***
END IF
*
* Compute 1-norm of offdiagonal elements of j-th column.
*
WORK( J ) = SASUM( J-1, B( 1, J ), 1 ) +
$ SASUM( J-1, B( J+1, 1 ), LDB )
***
OPST = OPST + ( 2*( J-1 )+4 )
***
210 CONTINUE
IF( B( 1, 1 ).EQ.ZERO .AND. B( 2, 1 ).EQ.ZERO )
$ B( 1, 1 ) = EPS3
WORK( 1 ) = ZERO
*
I1 = 1
I2 = N
I3 = 1
END IF
*
DO 270 ITS = 1, N
SCALE = ONE
VMAX = ONE
VCRIT = BIGNUM
*
* Solve U*(xr,xi) = scale*(vr,vi) for a right eigenvector,
* or U'*(xr,xi) = scale*(vr,vi) for a left eigenvector,
* overwriting (xr,xi) on (vr,vi).
*
DO 250 I = I1, I2, I3
*
IF( WORK( I ).GT.VCRIT ) THEN
REC = ONE / VMAX
CALL SSCAL( N, REC, VR, 1 )
CALL SSCAL( N, REC, VI, 1 )
SCALE = SCALE*REC
VMAX = ONE
VCRIT = BIGNUM
END IF
*
XR = VR( I )
XI = VI( I )
IF( RIGHTV ) THEN
DO 220 J = I + 1, N
XR = XR - B( I, J )*VR( J ) + B( J+1, I )*VI( J )
XI = XI - B( I, J )*VI( J ) - B( J+1, I )*VR( J )
220 CONTINUE
ELSE
DO 230 J = 1, I - 1
XR = XR - B( J, I )*VR( J ) + B( I+1, J )*VI( J )
XI = XI - B( J, I )*VI( J ) - B( I+1, J )*VR( J )
230 CONTINUE
END IF
*
W = ABS( B( I, I ) ) + ABS( B( I+1, I ) )
IF( W.GT.SMLNUM ) THEN
IF( W.LT.ONE ) THEN
W1 = ABS( XR ) + ABS( XI )
IF( W1.GT.W*BIGNUM ) THEN
REC = ONE / W1
CALL SSCAL( N, REC, VR, 1 )
CALL SSCAL( N, REC, VI, 1 )
XR = VR( I )
XI = VI( I )
SCALE = SCALE*REC
VMAX = VMAX*REC
END IF
END IF
*
* Divide by diagonal element of B.
*
CALL SLADIV( XR, XI, B( I, I ), B( I+1, I ), VR( I ),
$ VI( I ) )
VMAX = MAX( ABS( VR( I ) )+ABS( VI( I ) ), VMAX )
VCRIT = BIGNUM / VMAX
***
OPST = OPST + 9
***
ELSE
DO 240 J = 1, N
VR( J ) = ZERO
VI( J ) = ZERO
240 CONTINUE
VR( I ) = ONE
VI( I ) = ONE
SCALE = ZERO
VMAX = ONE
VCRIT = BIGNUM
END IF
250 CONTINUE
***
* Increment op count for loop 260, assuming no scaling
OPS = OPS + 4*N*( N-1 )
***
*
* Test for sufficient growth in the norm of (VR,VI).
*
VNORM = SASUM( N, VR, 1 ) + SASUM( N, VI, 1 )
***
OPST = OPST + 2*N
***
IF( VNORM.GE.GROWTO*SCALE )
$ GO TO 280
*
* Choose a new orthogonal starting vector and try again.
*
Y = EPS3 / ( ROOTN+ONE )
VR( 1 ) = EPS3
VI( 1 ) = ZERO
*
DO 260 I = 2, N
VR( I ) = Y
VI( I ) = ZERO
260 CONTINUE
VR( N-ITS+1 ) = VR( N-ITS+1 ) - EPS3*ROOTN
***
OPST = OPST + 4
***
270 CONTINUE
*
* Failure to find eigenvector in N iterations
*
INFO = 1
*
280 CONTINUE
*
* Normalize eigenvector.
*
VNORM = ZERO
DO 290 I = 1, N
VNORM = MAX( VNORM, ABS( VR( I ) )+ABS( VI( I ) ) )
290 CONTINUE
CALL SSCAL( N, ONE / VNORM, VR, 1 )
CALL SSCAL( N, ONE / VNORM, VI, 1 )
***
OPST = OPST + ( 4*N+1 )
***
*
END IF
*
***
* Compute final op count
OPS = OPS + OPST
***
RETURN
*
* End of SLAEIN
*
END
SUBROUTINE SLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
$ ILOZ, IHIZ, Z, LDZ, INFO )
*
* -- LAPACK auxiliary routine (instrum. to count ops. version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
LOGICAL WANTT, WANTZ
INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
* ..
* .. Array Arguments ..
REAL H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * )
* ..
* Common block to return operation count.
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLAHQR is an auxiliary routine called by SHSEQR to update the
* eigenvalues and Schur decomposition already computed by SHSEQR, by
* dealing with the Hessenberg submatrix in rows and columns ILO to IHI.
*
* Arguments
* =========
*
* WANTT (input) LOGICAL
* = .TRUE. : the full Schur form T is required;
* = .FALSE.: only eigenvalues are required.
*
* WANTZ (input) LOGICAL
* = .TRUE. : the matrix of Schur vectors Z is required;
* = .FALSE.: Schur vectors are not required.
*
* N (input) INTEGER
* The order of the matrix H. N >= 0.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* It is assumed that H is already upper quasi-triangular in
* rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless
* ILO = 1). SLAHQR works primarily with the Hessenberg
* submatrix in rows and columns ILO to IHI, but applies
* transformations to all of H if WANTT is .TRUE..
* 1 <= ILO <= max(1,IHI); IHI <= N.
*
* H (input/output) REAL array, dimension (LDH,N)
* On entry, the upper Hessenberg matrix H.
* On exit, if WANTT is .TRUE., H is upper quasi-triangular in
* rows and columns ILO:IHI, with any 2-by-2 diagonal blocks in
* standard form. If WANTT is .FALSE., the contents of H are
* unspecified on exit.
*
* LDH (input) INTEGER
* The leading dimension of the array H. LDH >= max(1,N).
*
* WR (output) REAL array, dimension (N)
* WI (output) REAL array, dimension (N)
* The real and imaginary parts, respectively, of the computed
* eigenvalues ILO to IHI are stored in the corresponding
* elements of WR and WI. If two eigenvalues are computed as a
* complex conjugate pair, they are stored in consecutive
* elements of WR and WI, say the i-th and (i+1)th, with
* WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the
* eigenvalues are stored in the same order as on the diagonal
* of the Schur form returned in H, with WR(i) = H(i,i), and, if
* H(i:i+1,i:i+1) is a 2-by-2 diagonal block,
* WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i).
*
* ILOZ (input) INTEGER
* IHIZ (input) INTEGER
* Specify the rows of Z to which transformations must be
* applied if WANTZ is .TRUE..
* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
*
* Z (input/output) REAL array, dimension (LDZ,N)
* If WANTZ is .TRUE., on entry Z must contain the current
* matrix Z of transformations accumulated by SHSEQR, and on
* exit Z has been updated; transformations are applied only to
* the submatrix Z(ILOZ:IHIZ,ILO:IHI).
* If WANTZ is .FALSE., Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* > 0: SLAHQR failed to compute all the eigenvalues ILO to IHI
* in a total of 30*(IHI-ILO+1) iterations; if INFO = i,
* elements i+1:ihi of WR and WI contain those eigenvalues
* which have been successfully computed.
*
* Further Details
* ===============
*
* 2-96 Based on modifications by
* David Day, Sandia National Laboratory, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, HALF
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, HALF = 0.5E0 )
REAL DAT1, DAT2
PARAMETER ( DAT1 = 0.75E+0, DAT2 = -0.4375E+0 )
* ..
* .. Local Scalars ..
INTEGER I, I1, I2, ITN, ITS, J, K, L, M, NH, NR, NZ
REAL AVE, CS, DISC, H00, H10, H11, H12, H21, H22,
$ H33, H33S, H43H34, H44, H44S, OPST, OVFL, S,
$ SMLNUM, SN, SUM, T1, T2, T3, TST1, ULP, UNFL,
$ V1, V2, V3
* ..
* .. Local Arrays ..
REAL V( 3 ), WORK( 1 )
* ..
* .. External Functions ..
REAL SLAMCH, SLANHS
EXTERNAL SLAMCH, SLANHS
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLABAD, SLANV2, SLARFG, SROT
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SIGN, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
***
* Initialize
OPST = 0
***
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
IF( ILO.EQ.IHI ) THEN
WR( ILO ) = H( ILO, ILO )
WI( ILO ) = ZERO
RETURN
END IF
*
NH = IHI - ILO + 1
NZ = IHIZ - ILOZ + 1
*
* Set machine-dependent constants for the stopping criterion.
* If norm(H) <= sqrt(OVFL), overflow should not occur.
*
UNFL = SLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
CALL SLABAD( UNFL, OVFL )
ULP = SLAMCH( 'Precision' )
SMLNUM = UNFL*( NH / ULP )
*
* I1 and I2 are the indices of the first row and last column of H
* to which transformations must be applied. If eigenvalues only are
* being computed, I1 and I2 are set inside the main loop.
*
IF( WANTT ) THEN
I1 = 1
I2 = N
END IF
*
* ITN is the total number of QR iterations allowed.
*
ITN = 30*NH
*
* The main loop begins here. I is the loop index and decreases from
* IHI to ILO in steps of 1 or 2. Each iteration of the loop works
* with the active submatrix in rows and columns L to I.
* Eigenvalues I+1 to IHI have already converged. Either L = ILO or
* H(L,L-1) is negligible so that the matrix splits.
*
I = IHI
10 CONTINUE
L = ILO
IF( I.LT.ILO )
$ GO TO 150
*
* Perform QR iterations on rows and columns ILO to I until a
* submatrix of order 1 or 2 splits off at the bottom because a
* subdiagonal element has become negligible.
*
DO 130 ITS = 0, ITN
*
* Look for a single small subdiagonal element.
*
DO 20 K = I, L + 1, -1
TST1 = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) )
IF( TST1.EQ.ZERO ) THEN
TST1 = SLANHS( '1', I-L+1, H( L, L ), LDH, WORK )
***
* Increment op count
OPS = OPS + ( I-L+1 )*( I-L+2 ) / 2
***
END IF
IF( ABS( H( K, K-1 ) ).LE.MAX( ULP*TST1, SMLNUM ) )
$ GO TO 30
20 CONTINUE
30 CONTINUE
L = K
***
* Increment op count
OPST = OPST + 3*( I-L+1 )
***
IF( L.GT.ILO ) THEN
*
* H(L,L-1) is negligible
*
H( L, L-1 ) = ZERO
END IF
*
* Exit from loop if a submatrix of order 1 or 2 has split off.
*
IF( L.GE.I-1 )
$ GO TO 140
*
* Now the active submatrix is in rows and columns L to I. If
* eigenvalues only are being computed, only the active submatrix
* need be transformed.
*
IF( .NOT.WANTT ) THEN
I1 = L
I2 = I
END IF
*
IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN
*
* Exceptional shift.
*
S = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) )
H44 = DAT1*S + H( I, I )
H33 = H44
H43H34 = DAT2*S*S
***
* Increment op count
OPST = OPST + 5
***
ELSE
*
* Prepare to use Francis' double shift
* (i.e. 2nd degree generalized Rayleigh quotient)
*
H44 = H( I, I )
H33 = H( I-1, I-1 )
H43H34 = H( I, I-1 )*H( I-1, I )
S = H( I-1, I-2 )*H( I-1, I-2 )
DISC = ( H33-H44 )*HALF
DISC = DISC*DISC + H43H34
***
* Increment op count
OPST = OPST + 6
***
IF( DISC.GT.ZERO ) THEN
*
* Real roots: use Wilkinson's shift twice
*
DISC = SQRT( DISC )
AVE = HALF*( H33+H44 )
***
* Increment op count
OPST = OPST + 2
***
IF( ABS( H33 )-ABS( H44 ).GT.ZERO ) THEN
H33 = H33*H44 - H43H34
H44 = H33 / ( SIGN( DISC, AVE )+AVE )
***
* Increment op count
OPST = OPST + 4
***
ELSE
H44 = SIGN( DISC, AVE ) + AVE
***
* Increment op count
OPST = OPST + 1
***
END IF
H33 = H44
H43H34 = ZERO
END IF
END IF
*
* Look for two consecutive small subdiagonal elements.
*
DO 40 M = I - 2, L, -1
*
* Determine the effect of starting the double-shift QR
* iteration at row M, and see if this would make H(M,M-1)
* negligible.
*
H11 = H( M, M )
H22 = H( M+1, M+1 )
H21 = H( M+1, M )
H12 = H( M, M+1 )
H44S = H44 - H11
H33S = H33 - H11
V1 = ( H33S*H44S-H43H34 ) / H21 + H12
V2 = H22 - H11 - H33S - H44S
V3 = H( M+2, M+1 )
S = ABS( V1 ) + ABS( V2 ) + ABS( V3 )
V1 = V1 / S
V2 = V2 / S
V3 = V3 / S
V( 1 ) = V1
V( 2 ) = V2
V( 3 ) = V3
IF( M.EQ.L )
$ GO TO 50
H00 = H( M-1, M-1 )
H10 = H( M, M-1 )
TST1 = ABS( V1 )*( ABS( H00 )+ABS( H11 )+ABS( H22 ) )
IF( ABS( H10 )*( ABS( V2 )+ABS( V3 ) ).LE.ULP*TST1 )
$ GO TO 50
40 CONTINUE
50 CONTINUE
***
* Increment op count
OPST = OPST + 20*( I-M-1 )
***
*
* Double-shift QR step
*
DO 120 K = M, I - 1
*
* The first iteration of this loop determines a reflection G
* from the vector V and applies it from left and right to H,
* thus creating a nonzero bulge below the subdiagonal.
*
* Each subsequent iteration determines a reflection G to
* restore the Hessenberg form in the (K-1)th column, and thus
* chases the bulge one step toward the bottom of the active
* submatrix. NR is the order of G.
*
NR = MIN( 3, I-K+1 )
IF( K.GT.M )
$ CALL SCOPY( NR, H( K, K-1 ), 1, V, 1 )
CALL SLARFG( NR, V( 1 ), V( 2 ), 1, T1 )
***
* Increment op count
OPST = OPST + 3*NR + 9
***
IF( K.GT.M ) THEN
H( K, K-1 ) = V( 1 )
H( K+1, K-1 ) = ZERO
IF( K.LT.I-1 )
$ H( K+2, K-1 ) = ZERO
ELSE IF( M.GT.L ) THEN
H( K, K-1 ) = -H( K, K-1 )
END IF
V2 = V( 2 )
T2 = T1*V2
IF( NR.EQ.3 ) THEN
V3 = V( 3 )
T3 = T1*V3
*
* Apply G from the left to transform the rows of the matrix
* in columns K to I2.
*
DO 60 J = K, I2
SUM = H( K, J ) + V2*H( K+1, J ) + V3*H( K+2, J )
H( K, J ) = H( K, J ) - SUM*T1
H( K+1, J ) = H( K+1, J ) - SUM*T2
H( K+2, J ) = H( K+2, J ) - SUM*T3
60 CONTINUE
*
* Apply G from the right to transform the columns of the
* matrix in rows I1 to min(K+3,I).
*
DO 70 J = I1, MIN( K+3, I )
SUM = H( J, K ) + V2*H( J, K+1 ) + V3*H( J, K+2 )
H( J, K ) = H( J, K ) - SUM*T1
H( J, K+1 ) = H( J, K+1 ) - SUM*T2
H( J, K+2 ) = H( J, K+2 ) - SUM*T3
70 CONTINUE
***
* Increment op count
OPS = OPS + 10*( I2-I1+2+MIN( 3, I-K ) )
***
*
IF( WANTZ ) THEN
*
* Accumulate transformations in the matrix Z
*
DO 80 J = ILOZ, IHIZ
SUM = Z( J, K ) + V2*Z( J, K+1 ) + V3*Z( J, K+2 )
Z( J, K ) = Z( J, K ) - SUM*T1
Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2
Z( J, K+2 ) = Z( J, K+2 ) - SUM*T3
80 CONTINUE
***
* Increment op count
OPS = OPS + 10*NZ
***
END IF
ELSE IF( NR.EQ.2 ) THEN
*
* Apply G from the left to transform the rows of the matrix
* in columns K to I2.
*
DO 90 J = K, I2
SUM = H( K, J ) + V2*H( K+1, J )
H( K, J ) = H( K, J ) - SUM*T1
H( K+1, J ) = H( K+1, J ) - SUM*T2
90 CONTINUE
*
* Apply G from the right to transform the columns of the
* matrix in rows I1 to min(K+3,I).
*
DO 100 J = I1, I
SUM = H( J, K ) + V2*H( J, K+1 )
H( J, K ) = H( J, K ) - SUM*T1
H( J, K+1 ) = H( J, K+1 ) - SUM*T2
100 CONTINUE
***
* Increment op count
OPS = OPS + 6*( I2-I1+3 )
***
*
IF( WANTZ ) THEN
*
* Accumulate transformations in the matrix Z
*
DO 110 J = ILOZ, IHIZ
SUM = Z( J, K ) + V2*Z( J, K+1 )
Z( J, K ) = Z( J, K ) - SUM*T1
Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2
110 CONTINUE
***
* Increment op count
OPS = OPS + 6*NZ
***
END IF
END IF
120 CONTINUE
*
130 CONTINUE
*
* Failure to converge in remaining number of iterations
*
INFO = I
RETURN
*
140 CONTINUE
*
IF( L.EQ.I ) THEN
*
* H(I,I-1) is negligible: one eigenvalue has converged.
*
WR( I ) = H( I, I )
WI( I ) = ZERO
ELSE IF( L.EQ.I-1 ) THEN
*
* H(I-1,I-2) is negligible: a pair of eigenvalues have converged.
*
* Transform the 2-by-2 submatrix to standard Schur form,
* and compute and store the eigenvalues.
*
CALL SLANV2( H( I-1, I-1 ), H( I-1, I ), H( I, I-1 ),
$ H( I, I ), WR( I-1 ), WI( I-1 ), WR( I ), WI( I ),
$ CS, SN )
*
IF( WANTT ) THEN
*
* Apply the transformation to the rest of H.
*
IF( I2.GT.I )
$ CALL SROT( I2-I, H( I-1, I+1 ), LDH, H( I, I+1 ), LDH,
$ CS, SN )
CALL SROT( I-I1-1, H( I1, I-1 ), 1, H( I1, I ), 1, CS, SN )
***
* Increment op count
OPS = OPS + 6*( I2-I1-1 )
***
END IF
IF( WANTZ ) THEN
*
* Apply the transformation to Z.
*
CALL SROT( NZ, Z( ILOZ, I-1 ), 1, Z( ILOZ, I ), 1, CS, SN )
***
* Increment op count
OPS = OPS + 6*NZ
***
END IF
END IF
*
* Decrement number of remaining iterations, and return to start of
* the main loop with new value of I.
*
ITN = ITN - ITS
I = L - 1
GO TO 10
*
150 CONTINUE
***
* Compute final op count
OPS = OPS + OPST
***
RETURN
*
* End of SLAHQR
*
END
SUBROUTINE SLAR1V( N, B1, BN, SIGMA, D, L, LD, LLD, GERSCH, Z,
$ ZTZ, MINGMA, R, ISUPPZ, WORK )
*
* -- LAPACK auxiliary routine (instru to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER B1, BN, N, R
REAL MINGMA, SIGMA, ZTZ
* ..
* .. Array Arguments ..
INTEGER ISUPPZ( * )
REAL D( * ), GERSCH( * ), L( * ), LD( * ), LLD( * ),
$ WORK( * ), Z( * )
* ..
* Common block to return operation count
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLAR1V computes the (scaled) r-th column of the inverse of
* the sumbmatrix in rows B1 through BN of the tridiagonal matrix
* L D L^T - sigma I. The following steps accomplish this computation :
* (a) Stationary qd transform, L D L^T - sigma I = L(+) D(+) L(+)^T,
* (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T,
* (c) Computation of the diagonal elements of the inverse of
* L D L^T - sigma I by combining the above transforms, and choosing
* r as the index where the diagonal of the inverse is (one of the)
* largest in magnitude.
* (d) Computation of the (scaled) r-th column of the inverse using the
* twisted factorization obtained by combining the top part of the
* the stationary and the bottom part of the progressive transform.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix L D L^T.
*
* B1 (input) INTEGER
* First index of the submatrix of L D L^T.
*
* BN (input) INTEGER
* Last index of the submatrix of L D L^T.
*
* SIGMA (input) REAL
* The shift. Initially, when R = 0, SIGMA should be a good
* approximation to an eigenvalue of L D L^T.
*
* L (input) REAL array, dimension (N-1)
* The (n-1) subdiagonal elements of the unit bidiagonal matrix
* L, in elements 1 to N-1.
*
* D (input) REAL array, dimension (N)
* The n diagonal elements of the diagonal matrix D.
*
* LD (input) REAL array, dimension (N-1)
* The n-1 elements L(i)*D(i).
*
* LLD (input) REAL array, dimension (N-1)
* The n-1 elements L(i)*L(i)*D(i).
*
* GERSCH (input) REAL array, dimension (2*N)
* The n Gerschgorin intervals. These are used to restrict
* the initial search for R, when R is input as 0.
*
* Z (output) REAL array, dimension (N)
* The (scaled) r-th column of the inverse. Z(R) is returned
* to be 1.
*
* ZTZ (output) REAL
* The square of the norm of Z.
*
* MINGMA (output) REAL
* The reciprocal of the largest (in magnitude) diagonal
* element of the inverse of L D L^T - sigma I.
*
* R (input/output) INTEGER
* Initially, R should be input to be 0 and is then output as
* the index where the diagonal element of the inverse is
* largest in magnitude. In later iterations, this same value
* of R should be input.
*
* ISUPPZ (output) INTEGER array, dimension (2)
* The support of the vector in Z, i.e., the vector Z is
* nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ).
*
* WORK (workspace) REAL array, dimension (4*N)
*
* Further Details
* ===============
*
* Based on contributions by
* Inderjit Dhillon, IBM Almaden, USA
* Osni Marques, LBNL/NERSC, USA
*
* =====================================================================
*
* .. Parameters ..
INTEGER BLKSIZ
PARAMETER ( BLKSIZ = 32 )
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL SAWNAN
INTEGER FROM, I, INDP, INDS, INDUMN, J, R1, R2, TO
REAL DMINUS, DPLUS, EPS, S, TMP
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL
* ..
* .. Executable Statements ..
*
EPS = SLAMCH( 'Precision' )
IF( R.EQ.0 ) THEN
*
* Eliminate the top and bottom indices from the possible values
* of R where the desired eigenvector is largest in magnitude.
*
R1 = B1
DO 10 I = B1, BN
IF( SIGMA.GE.GERSCH( 2*I-1 ) .OR. SIGMA.LE.GERSCH( 2*I ) )
$ THEN
R1 = I
GO TO 20
END IF
10 CONTINUE
20 CONTINUE
R2 = BN
DO 30 I = BN, B1, -1
IF( SIGMA.GE.GERSCH( 2*I-1 ) .OR. SIGMA.LE.GERSCH( 2*I ) )
$ THEN
R2 = I
GO TO 40
END IF
30 CONTINUE
40 CONTINUE
ELSE
R1 = R
R2 = R
END IF
*
INDUMN = N
INDS = 2*N + 1
INDP = 3*N + 1
SAWNAN = .FALSE.
*
* Compute the stationary transform (using the differential form)
* untill the index R2
*
IF( B1.EQ.1 ) THEN
WORK( INDS ) = ZERO
ELSE
WORK( INDS ) = LLD( B1-1 )
END IF
OPS = OPS + REAL( 1 )
S = WORK( INDS ) - SIGMA
DO 50 I = B1, R2 - 1
OPS = OPS + REAL( 5 )
DPLUS = D( I ) + S
WORK( I ) = LD( I ) / DPLUS
WORK( INDS+I ) = S*WORK( I )*L( I )
S = WORK( INDS+I ) - SIGMA
50 CONTINUE
*
IF( .NOT.( S.GT.ZERO .OR. S.LT.ONE ) ) THEN
*
* Run a slower version of the above loop if a NaN is detected
*
SAWNAN = .TRUE.
J = B1 + 1
60 CONTINUE
IF( WORK( INDS+J ).GT.ZERO .OR. WORK( INDS+J ).LT.ONE ) THEN
J = J + 1
GO TO 60
END IF
WORK( INDS+J ) = LLD( J )
S = WORK( INDS+J ) - SIGMA
DO 70 I = J + 1, R2 - 1
OPS = OPS + REAL( 3 )
DPLUS = D( I ) + S
WORK( I ) = LD( I ) / DPLUS
IF( WORK( I ).EQ.ZERO ) THEN
WORK( INDS+I ) = LLD( I )
ELSE
OPS = OPS + REAL( 2 )
WORK( INDS+I ) = S*WORK( I )*L( I )
END IF
S = WORK( INDS+I ) - SIGMA
70 CONTINUE
END IF
OPS = OPS + REAL( 1 )
WORK( INDP+BN-1 ) = D( BN ) - SIGMA
DO 80 I = BN - 1, R1, -1
OPS = OPS + REAL( 5 )
DMINUS = LLD( I ) + WORK( INDP+I )
TMP = D( I ) / DMINUS
WORK( INDUMN+I ) = L( I )*TMP
WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - SIGMA
80 CONTINUE
TMP = WORK( INDP+R1-1 )
IF( .NOT.( TMP.GT.ZERO .OR. TMP.LT.ONE ) ) THEN
*
* Run a slower version of the above loop if a NaN is detected
*
SAWNAN = .TRUE.
J = BN - 3
90 CONTINUE
IF( WORK( INDP+J ).GT.ZERO .OR. WORK( INDP+J ).LT.ONE ) THEN
J = J - 1
GO TO 90
END IF
OPS = OPS + REAL( 1 )
WORK( INDP+J ) = D( J+1 ) - SIGMA
DO 100 I = J, R1, -1
OPS = OPS + REAL( 3 )
DMINUS = LLD( I ) + WORK( INDP+I )
TMP = D( I ) / DMINUS
WORK( INDUMN+I ) = L( I )*TMP
IF( TMP.EQ.ZERO ) THEN
OPS = OPS + REAL( 1 )
WORK( INDP+I-1 ) = D( I ) - SIGMA
ELSE
OPS = OPS + REAL( 2 )
WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - SIGMA
END IF
100 CONTINUE
END IF
*
* Find the index (from R1 to R2) of the largest (in magnitude)
* diagonal element of the inverse
*
MINGMA = WORK( INDS+R1-1 ) + WORK( INDP+R1-1 )
IF( MINGMA.EQ.ZERO )
$ MINGMA = EPS*WORK( INDS+R1-1 )
R = R1
DO 110 I = R1, R2 - 1
OPS = OPS + REAL( 1 )
TMP = WORK( INDS+I ) + WORK( INDP+I )
IF( TMP.EQ.ZERO ) THEN
OPS = OPS + REAL( 1 )
TMP = EPS*WORK( INDS+I )
END IF
IF( ABS( TMP ).LT.ABS( MINGMA ) ) THEN
MINGMA = TMP
R = I + 1
END IF
110 CONTINUE
*
* Compute the (scaled) r-th column of the inverse
*
ISUPPZ( 1 ) = B1
ISUPPZ( 2 ) = BN
Z( R ) = ONE
ZTZ = ONE
IF( .NOT.SAWNAN ) THEN
FROM = R - 1
TO = MAX( R-BLKSIZ, B1 )
120 CONTINUE
IF( FROM.GE.B1 ) THEN
DO 130 I = FROM, TO, -1
OPS = OPS + REAL( 3 )
Z( I ) = -( WORK( I )*Z( I+1 ) )
ZTZ = ZTZ + Z( I )*Z( I )
130 CONTINUE
IF( ABS( Z( TO ) ).LE.EPS .AND. ABS( Z( TO+1 ) ).LE.EPS )
$ THEN
ISUPPZ( 1 ) = TO + 2
ELSE
FROM = TO - 1
TO = MAX( TO-BLKSIZ, B1 )
GO TO 120
END IF
END IF
FROM = R + 1
TO = MIN( R+BLKSIZ, BN )
140 CONTINUE
IF( FROM.LE.BN ) THEN
DO 150 I = FROM, TO
OPS = OPS + REAL( 3 )
Z( I ) = -( WORK( INDUMN+I-1 )*Z( I-1 ) )
ZTZ = ZTZ + Z( I )*Z( I )
150 CONTINUE
IF( ABS( Z( TO ) ).LE.EPS .AND. ABS( Z( TO-1 ) ).LE.EPS )
$ THEN
ISUPPZ( 2 ) = TO - 2
ELSE
FROM = TO + 1
TO = MIN( TO+BLKSIZ, BN )
GO TO 140
END IF
END IF
ELSE
DO 160 I = R - 1, B1, -1
IF( Z( I+1 ).EQ.ZERO ) THEN
OPS = OPS + REAL( 2 )
Z( I ) = -( LD( I+1 ) / LD( I ) )*Z( I+2 )
ELSE IF( ABS( Z( I+1 ) ).LE.EPS .AND. ABS( Z( I+2 ) ).LE.
$ EPS ) THEN
ISUPPZ( 1 ) = I + 3
GO TO 170
ELSE
OPS = OPS + REAL( 1 )
Z( I ) = -( WORK( I )*Z( I+1 ) )
END IF
OPS = OPS + REAL( 2 )
ZTZ = ZTZ + Z( I )*Z( I )
160 CONTINUE
170 CONTINUE
DO 180 I = R, BN - 1
IF( Z( I ).EQ.ZERO ) THEN
OPS = OPS + REAL( 2 )
Z( I+1 ) = -( LD( I-1 ) / LD( I ) )*Z( I-1 )
ELSE IF( ABS( Z( I ) ).LE.EPS .AND. ABS( Z( I-1 ) ).LE.EPS )
$ THEN
ISUPPZ( 2 ) = I - 2
GO TO 190
ELSE
OPS = OPS + REAL( 1 )
Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) )
END IF
OPS = OPS + REAL( 2 )
ZTZ = ZTZ + Z( I+1 )*Z( I+1 )
180 CONTINUE
190 CONTINUE
END IF
DO 200 I = B1, ISUPPZ( 1 ) - 3
Z( I ) = ZERO
200 CONTINUE
DO 210 I = ISUPPZ( 2 ) + 3, BN
Z( I ) = ZERO
210 CONTINUE
*
RETURN
*
* End of SLAR1V
*
END
SUBROUTINE SLARRB( N, D, L, LD, LLD, IFIRST, ILAST, SIGMA, RELTOL,
$ W, WGAP, WERR, WORK, IWORK, INFO )
*
* -- LAPACK auxiliary routine (instru to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER IFIRST, ILAST, INFO, N
REAL RELTOL, SIGMA
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL D( * ), L( * ), LD( * ), LLD( * ), W( * ),
$ WERR( * ), WGAP( * ), WORK( * )
* ..
* Common block to return operation count
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* Given the relatively robust representation(RRR) L D L^T, SLARRB
* does ``limited'' bisection to locate the eigenvalues of L D L^T,
* W( IFIRST ) thru' W( ILAST ), to more accuracy. Intervals
* [left, right] are maintained by storing their mid-points and
* semi-widths in the arrays W and WERR respectively.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix.
*
* D (input) REAL array, dimension (N)
* The n diagonal elements of the diagonal matrix D.
*
* L (input) REAL array, dimension (N-1)
* The n-1 subdiagonal elements of the unit bidiagonal matrix L.
*
* LD (input) REAL array, dimension (N-1)
* The n-1 elements L(i)*D(i).
*
* LLD (input) REAL array, dimension (N-1)
* The n-1 elements L(i)*L(i)*D(i).
*
* IFIRST (input) INTEGER
* The index of the first eigenvalue in the cluster.
*
* ILAST (input) INTEGER
* The index of the last eigenvalue in the cluster.
*
* SIGMA (input) REAL
* The shift used to form L D L^T (see SLARRF).
*
* RELTOL (input) REAL
* The relative tolerance.
*
* W (input/output) REAL array, dimension (N)
* On input, W( IFIRST ) thru' W( ILAST ) are estimates of the
* corresponding eigenvalues of L D L^T.
* On output, these estimates are ``refined''.
*
* WGAP (input/output) REAL array, dimension (N)
* The gaps between the eigenvalues of L D L^T. Very small
* gaps are changed on output.
*
* WERR (input/output) REAL array, dimension (N)
* On input, WERR( IFIRST ) thru' WERR( ILAST ) are the errors
* in the estimates W( IFIRST ) thru' W( ILAST ).
* On output, these are the ``refined'' errors.
*
*****Reminder to Inder --- WORK is never used in this subroutine *****
* WORK (input) REAL array, dimension (???)
* Workspace.
*
* IWORK (input) INTEGER array, dimension (2*N)
* Workspace.
*
*****Reminder to Inder --- INFO is never set in this subroutine ******
* INFO (output) INTEGER
* Error flag.
*
* Further Details
* ===============
*
* Based on contributions by
* Inderjit Dhillon, IBM Almaden, USA
* Osni Marques, LBNL/NERSC, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, TWO, HALF
PARAMETER ( ZERO = 0.0E0, TWO = 2.0E0, HALF = 0.5E0 )
* ..
* .. Local Scalars ..
INTEGER CNT, I, I1, I2, INITI1, INITI2, J, K, NCNVRG,
$ NEIG, NINT, NRIGHT, OLNINT
REAL DELTA, EPS, GAP, LEFT, MID, PERT, RIGHT, S,
$ THRESH, TMP, WIDTH
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
EPS = SLAMCH( 'Precision' )
I1 = IFIRST
I2 = IFIRST
NEIG = ILAST - IFIRST + 1
NCNVRG = 0
THRESH = RELTOL
DO 10 I = IFIRST, ILAST
OPS = OPS + REAL( 3 )
IWORK( I ) = 0
PERT = EPS*( ABS( SIGMA )+ABS( W( I ) ) )
WERR( I ) = WERR( I ) + PERT
IF( WGAP( I ).LT.PERT )
$ WGAP( I ) = PERT
10 CONTINUE
DO 20 I = I1, ILAST
IF( I.EQ.1 ) THEN
GAP = WGAP( I )
ELSE IF( I.EQ.N ) THEN
GAP = WGAP( I-1 )
ELSE
GAP = MIN( WGAP( I-1 ), WGAP( I ) )
END IF
OPS = OPS + REAL( 1 )
IF( WERR( I ).LT.THRESH*GAP ) THEN
NCNVRG = NCNVRG + 1
IWORK( I ) = 1
IF( I1.EQ.I )
$ I1 = I1 + 1
ELSE
I2 = I
END IF
20 CONTINUE
*
* Initialize the unconverged intervals.
*
I = I1
NINT = 0
RIGHT = ZERO
30 CONTINUE
IF( I.LE.I2 ) THEN
IF( IWORK( I ).EQ.0 ) THEN
DELTA = EPS
OPS = OPS + REAL( 1 )
LEFT = W( I ) - WERR( I )
*
* Do while( CNT(LEFT).GT.I-1 )
*
40 CONTINUE
IF( I.GT.I1 .AND. LEFT.LE.RIGHT ) THEN
LEFT = RIGHT
CNT = I - 1
ELSE
S = -LEFT
CNT = 0
DO 50 J = 1, N - 1
OPS = OPS + REAL( 5 )
TMP = D( J ) + S
S = S*( LD( J ) / TMP )*L( J ) - LEFT
IF( TMP.LT.ZERO )
$ CNT = CNT + 1
50 CONTINUE
TMP = D( N ) + S
IF( TMP.LT.ZERO )
$ CNT = CNT + 1
IF( CNT.GT.I-1 ) THEN
OPS = OPS + REAL( 4 )
DELTA = TWO*DELTA
LEFT = LEFT - ( ABS( SIGMA )+ABS( LEFT ) )*DELTA
GO TO 40
END IF
END IF
OPS = OPS + REAL( 1 )
DELTA = EPS
RIGHT = W( I ) + WERR( I )
*
* Do while( CNT(RIGHT).LT.I )
*
60 CONTINUE
S = -RIGHT
CNT = 0
OPS = OPS + REAL( 5*(N-1)+1 )
DO 70 J = 1, N - 1
TMP = D( J ) + S
S = S*( LD( J ) / TMP )*L( J ) - RIGHT
IF( TMP.LT.ZERO )
$ CNT = CNT + 1
70 CONTINUE
TMP = D( N ) + S
IF( TMP.LT.ZERO )
$ CNT = CNT + 1
IF( CNT.LT.I ) THEN
OPS = OPS + REAL( 4 )
DELTA = TWO*DELTA
RIGHT = RIGHT + ( ABS( SIGMA )+ABS( RIGHT ) )*DELTA
GO TO 60
END IF
WERR( I ) = LEFT
W( I ) = RIGHT
IWORK( N+I ) = CNT
NINT = NINT + 1
I = CNT + 1
ELSE
I = I + 1
END IF
GO TO 30
END IF
*
* While( NCNVRG.LT.NEIG )
*
INITI1 = I1
INITI2 = I2
80 CONTINUE
IF( NCNVRG.LT.NEIG ) THEN
OLNINT = NINT
I = I1
DO 100 K = 1, OLNINT
NRIGHT = IWORK( N+I )
IF( IWORK( I ).EQ.0 ) THEN
OPS = OPS + REAL( 2 )
MID = HALF*( WERR( I )+W( I ) )
S = -MID
CNT = 0
OPS = OPS + REAL( 5*(N-1)+1 )
DO 90 J = 1, N - 1
TMP = D( J ) + S
S = S*( LD( J ) / TMP )*L( J ) - MID
IF( TMP.LT.ZERO )
$ CNT = CNT + 1
90 CONTINUE
TMP = D( N ) + S
IF( TMP.LT.ZERO )
$ CNT = CNT + 1
CNT = MAX( I-1, MIN( NRIGHT, CNT ) )
IF( I.EQ.NRIGHT ) THEN
IF( I.EQ.IFIRST ) THEN
OPS = OPS + REAL( 1 )
GAP = WERR( I+1 ) - W( I )
ELSE IF( I.EQ.ILAST ) THEN
OPS = OPS + REAL( 1 )
GAP = WERR( I ) - W( I-1 )
ELSE
OPS = OPS + REAL( 2 )
GAP = MIN( WERR( I+1 )-W( I ), WERR( I )-W( I-1 ) )
END IF
OPS = OPS + REAL( 2 )
WIDTH = W( I ) - MID
IF( WIDTH.LT.THRESH*GAP ) THEN
NCNVRG = NCNVRG + 1
IWORK( I ) = 1
IF( I1.EQ.I ) THEN
I1 = I1 + 1
NINT = NINT - 1
END IF
END IF
END IF
IF( IWORK( I ).EQ.0 )
$ I2 = K
IF( CNT.EQ.I-1 ) THEN
WERR( I ) = MID
ELSE IF( CNT.EQ.NRIGHT ) THEN
W( I ) = MID
ELSE
IWORK( N+I ) = CNT
NINT = NINT + 1
WERR( CNT+1 ) = MID
W( CNT+1 ) = W( I )
W( I ) = MID
I = CNT + 1
IWORK( N+I ) = NRIGHT
END IF
END IF
I = NRIGHT + 1
100 CONTINUE
NINT = NINT - OLNINT + I2
GO TO 80
END IF
DO 110 I = INITI1, INITI2
OPS = OPS + REAL( 3 )
W( I ) = HALF*( WERR( I )+W( I ) )
WERR( I ) = W( I ) - WERR( I )
110 CONTINUE
*
RETURN
*
* End of SLARRB
*
END
SUBROUTINE SLARRE( N, D, E, TOL, NSPLIT, ISPLIT, M, W, WOFF,
$ GERSCH, WORK, INFO )
*
* -- LAPACK auxiliary routine (instru to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER INFO, M, N, NSPLIT
REAL TOL
* ..
* .. Array Arguments ..
INTEGER ISPLIT( * )
REAL D( * ), E( * ), GERSCH( * ), W( * ), WOFF( * ),
$ WORK( * )
* ..
* Common block to return operation count
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* Given the tridiagonal matrix T, SLARRE sets "small" off-diagonal
* elements to zero, and for each unreduced block T_i, it finds
* (i) the numbers sigma_i
* (ii) the base T_i - sigma_i I = L_i D_i L_i^T representations and
* (iii) eigenvalues of each L_i D_i L_i^T.
* The representations and eigenvalues found are then used by
* SSTEGR to compute the eigenvectors of a symmetric tridiagonal
* matrix. Currently, the base representations are limited to being
* positive or negative definite, and the eigenvalues of the definite
* matrices are found by the dqds algorithm (subroutine SLASQ2). As
* an added benefit, SLARRE also outputs the n Gerschgorin
* intervals for each L_i D_i L_i^T.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix.
*
* D (input/output) REAL array, dimension (N)
* On entry, the n diagonal elements of the tridiagonal
* matrix T.
* On exit, the n diagonal elements of the diagonal
* matrices D_i.
*
* E (input/output) REAL array, dimension (N)
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix T; E(N) need not be set.
* On exit, the subdiagonal elements of the unit bidiagonal
* matrices L_i.
*
* TOL (input) REAL
* The threshold for splitting. If on input |E(i)| < TOL, then
* the matrix T is split into smaller blocks.
*
* NSPLIT (input) INTEGER
* The number of blocks T splits into. 1 <= NSPLIT <= N.
*
* ISPLIT (output) INTEGER array, dimension (2*N)
* The splitting points, at which T breaks up into submatrices.
* The first submatrix consists of rows/columns 1 to ISPLIT(1),
* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
* etc., and the NSPLIT-th consists of rows/columns
* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
*
* M (output) INTEGER
* The total number of eigenvalues (of all the L_i D_i L_i^T)
* found.
*
* W (output) REAL array, dimension (N)
* The first M elements contain the eigenvalues. The
* eigenvalues of each of the blocks, L_i D_i L_i^T, are
* sorted in ascending order.
*
* WOFF (output) REAL array, dimension (N)
* The NSPLIT base points sigma_i.
*
* GERSCH (output) REAL array, dimension (2*N)
* The n Gerschgorin intervals.
*
* WORK (input) REAL array, dimension (4*N???)
* Workspace.
*
* INFO (output) INTEGER
* Output error code from SLASQ2
*
* Further Details
* ===============
*
* Based on contributions by
* Inderjit Dhillon, IBM Almaden, USA
* Osni Marques, LBNL/NERSC, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO, FOUR, FOURTH
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ FOUR = 4.0E0, FOURTH = ONE / FOUR )
* ..
* .. Local Scalars ..
INTEGER CNT, I, IBEGIN, IEND, IN, J, JBLK, MAXCNT
REAL DELTA, EPS, GL, GU, NRM, OFFD, S, SGNDEF,
$ SIGMA, TAU, TMP1, WIDTH
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLASQ2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL
* ..
* .. Executable Statements ..
*
INFO = 0
EPS = SLAMCH( 'Precision' )
*
* Compute Splitting Points
*
NSPLIT = 1
DO 10 I = 1, N - 1
IF( ABS( E( I ) ).LE.TOL ) THEN
ISPLIT( NSPLIT ) = I
NSPLIT = NSPLIT + 1
END IF
10 CONTINUE
ISPLIT( NSPLIT ) = N
*
IBEGIN = 1
DO 170 JBLK = 1, NSPLIT
IEND = ISPLIT( JBLK )
IF( IBEGIN.EQ.IEND ) THEN
W( IBEGIN ) = D( IBEGIN )
WOFF( JBLK ) = ZERO
IBEGIN = IEND + 1
GO TO 170
END IF
IN = IEND - IBEGIN + 1
*
* Form the n Gerschgorin intervals
*
OPS = OPS + REAL( 4 )
GL = D( IBEGIN ) - ABS( E( IBEGIN ) )
GU = D( IBEGIN ) + ABS( E( IBEGIN ) )
GERSCH( 2*IBEGIN-1 ) = GL
GERSCH( 2*IBEGIN ) = GU
GERSCH( 2*IEND-1 ) = D( IEND ) - ABS( E( IEND-1 ) )
GERSCH( 2*IEND ) = D( IEND ) + ABS( E( IEND-1 ) )
GL = MIN( GERSCH( 2*IEND-1 ), GL )
GU = MAX( GERSCH( 2*IEND ), GU )
DO 20 I = IBEGIN + 1, IEND - 1
OPS = OPS + REAL( 3 )
OFFD = ABS( E( I-1 ) ) + ABS( E( I ) )
GERSCH( 2*I-1 ) = D( I ) - OFFD
GL = MIN( GERSCH( 2*I-1 ), GL )
GERSCH( 2*I ) = D( I ) + OFFD
GU = MAX( GERSCH( 2*I ), GU )
20 CONTINUE
NRM = MAX( ABS( GL ), ABS( GU ) )
*
* Find the number SIGMA where the base representation
* T - sigma I = L D L^T is to be formed.
*
WIDTH = GU - GL
DO 30 I = IBEGIN, IEND - 1
OPS = OPS + REAL( 1 )
WORK( I ) = E( I )*E( I )
30 CONTINUE
OPS = OPS + REAL( 6 )
DO 50 J = 1, 2
IF( J.EQ.1 ) THEN
TAU = GL + FOURTH*WIDTH
ELSE
TAU = GU - FOURTH*WIDTH
END IF
TMP1 = D( IBEGIN ) - TAU
IF( TMP1.LT.ZERO ) THEN
CNT = 1
ELSE
CNT = 0
END IF
DO 40 I = IBEGIN + 1, IEND
OPS = OPS + REAL( 3 )
TMP1 = D( I ) - TAU - WORK( I-1 ) / TMP1
IF( TMP1.LT.ZERO )
$ CNT = CNT + 1
40 CONTINUE
IF( CNT.EQ.0 ) THEN
GL = TAU
ELSE IF( CNT.EQ.IN ) THEN
GU = TAU
END IF
IF( J.EQ.1 ) THEN
MAXCNT = CNT
SIGMA = GL
SGNDEF = ONE
ELSE
IF( IN-CNT.GT.MAXCNT ) THEN
SIGMA = GU
SGNDEF = -ONE
END IF
END IF
50 CONTINUE
*
* Find the base L D L^T representation
*
OPS = OPS + REAL( 1 )
WORK( 3*IN ) = ONE
DELTA = EPS
TAU = SGNDEF*NRM
60 CONTINUE
OPS = OPS + REAL( 3+5*(IN-1) )
SIGMA = SIGMA - DELTA*TAU
WORK( 1 ) = D( IBEGIN ) - SIGMA
J = IBEGIN
DO 70 I = 1, IN - 1
WORK( 2*IN+I ) = ONE / WORK( 2*I-1 )
TMP1 = E( J )*WORK( 2*IN+I )
WORK( 2*I+1 ) = ( D( J+1 )-SIGMA ) - TMP1*E( J )
WORK( 2*I ) = TMP1
J = J + 1
70 CONTINUE
OPS = OPS + REAL( IN )
DO 80 I = IN, 1, -1
TMP1 = SGNDEF*WORK( 2*I-1 )
IF( TMP1.LT.ZERO .OR. WORK( 2*IN+I ).EQ.ZERO .OR. .NOT.
$ ( TMP1.GT.ZERO .OR. TMP1.LT.ONE ) ) THEN
OPS = OPS + REAL( 1 )
DELTA = TWO*DELTA
GO TO 60
END IF
J = J - 1
80 CONTINUE
*
OPS = OPS + REAL( IN-1 )
J = IBEGIN
D( IBEGIN ) = WORK( 1 )
WORK( 1 ) = ABS( WORK( 1 ) )
DO 90 I = 1, IN - 1
TMP1 = E( J )
E( J ) = WORK( 2*I )
WORK( 2*I ) = ABS( TMP1*WORK( 2*I ) )
J = J + 1
D( J ) = WORK( 2*I+1 )
WORK( 2*I+1 ) = ABS( WORK( 2*I+1 ) )
90 CONTINUE
*
CALL SLASQ2( IN, WORK, INFO )
*
OPS = OPS + REAL( 2 )
TAU = SGNDEF*WORK( IN )
WORK( 3*IN ) = ONE
DELTA = TWO*EPS
100 CONTINUE
OPS = OPS + REAL( 2 )
TAU = TAU*( ONE-DELTA )
*
OPS = OPS + REAL( 9*(IN-1)+1 )
S = -TAU
J = IBEGIN
DO 110 I = 1, IN - 1
WORK( I ) = D( J ) + S
WORK( 2*IN+I ) = ONE / WORK( I )
* WORK( N+I ) = ( E( I ) * D( I ) ) / WORK( I )
WORK( IN+I ) = ( E( J )*D( J ) )*WORK( 2*IN+I )
S = S*WORK( IN+I )*E( J ) - TAU
J = J + 1
110 CONTINUE
WORK( IN ) = D( IEND ) + S
*
* Checking to see if all the diagonal elements of the new
* L D L^T representation have the same sign
*
OPS = OPS + REAL( IN+1 )
DO 120 I = IN, 1, -1
TMP1 = SGNDEF*WORK( I )
IF( TMP1.LT.ZERO .OR. WORK( 2*IN+I ).EQ.ZERO .OR. .NOT.
$ ( TMP1.GT.ZERO .OR. TMP1.LT.ONE ) ) THEN
OPS = OPS + REAL( 1 )
DELTA = TWO*DELTA
GO TO 100
END IF
120 CONTINUE
*
SIGMA = SIGMA + TAU
CALL SCOPY( IN, WORK, 1, D( IBEGIN ), 1 )
CALL SCOPY( IN-1, WORK( IN+1 ), 1, E( IBEGIN ), 1 )
WOFF( JBLK ) = SIGMA
*
* Update the n Gerschgorin intervals
*
OPS = OPS + REAL( 2 )
DO 130 I = IBEGIN, IEND
GERSCH( 2*I-1 ) = GERSCH( 2*I-1 ) - SIGMA
GERSCH( 2*I ) = GERSCH( 2*I ) - SIGMA
130 CONTINUE
*
* Compute the eigenvalues of L D L^T.
*
J = IBEGIN
OPS = OPS + REAL( 2*(IN-1) )
DO 140 I = 1, IN - 1
WORK( 2*I-1 ) = ABS( D( J ) )
WORK( 2*I ) = E( J )*E( J )*WORK( 2*I-1 )
J = J + 1
140 CONTINUE
WORK( 2*IN-1 ) = ABS( D( IEND ) )
*
CALL SLASQ2( IN, WORK, INFO )
*
J = IBEGIN
IF( SGNDEF.GT.ZERO ) THEN
DO 150 I = 1, IN
W( J ) = WORK( IN-I+1 )
J = J + 1
150 CONTINUE
ELSE
DO 160 I = 1, IN
W( J ) = -WORK( I )
J = J + 1
160 CONTINUE
END IF
IBEGIN = IEND + 1
170 CONTINUE
M = N
*
RETURN
*
* End of SLARRE
*
END
SUBROUTINE SLARRF( N, D, L, LD, LLD, IFIRST, ILAST, W, DPLUS,
$ LPLUS, WORK, IWORK, INFO )
*
* -- LAPACK auxiliary routine (instru to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER IFIRST, ILAST, INFO, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL D( * ), DPLUS( * ), L( * ), LD( * ), LLD( * ),
$ LPLUS( * ), W( * ), WORK( * )
* ..
* Common block to return operation count
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* Given the initial representation L D L^T and its cluster of close
* eigenvalues (in a relative measure), W( IFIRST ), W( IFIRST+1 ), ...
* W( ILAST ), SLARRF finds a new relatively robust representation
* L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the
* eigenvalues of L(+) D(+) L(+)^T is relatively isolated.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix.
*
* D (input) REAL array, dimension (N)
* The n diagonal elements of the diagonal matrix D.
*
* L (input) REAL array, dimension (N-1)
* The (n-1) subdiagonal elements of the unit bidiagonal
* matrix L.
*
* LD (input) REAL array, dimension (N-1)
* The n-1 elements L(i)*D(i).
*
* LLD (input) REAL array, dimension (N-1)
* The n-1 elements L(i)*L(i)*D(i).
*
* IFIRST (input) INTEGER
* The index of the first eigenvalue in the cluster.
*
* ILAST (input) INTEGER
* The index of the last eigenvalue in the cluster.
*
* W (input/output) REAL array, dimension (N)
* On input, the eigenvalues of L D L^T in ascending order.
* W( IFIRST ) through W( ILAST ) form the cluster of relatively
* close eigenalues.
* On output, W( IFIRST ) thru' W( ILAST ) are estimates of the
* corresponding eigenvalues of L(+) D(+) L(+)^T.
*
* SIGMA (input) REAL
* The shift used to form L(+) D(+) L(+)^T.
*
* DPLUS (output) REAL array, dimension (N)
* The n diagonal elements of the diagonal matrix D(+).
*
* LPLUS (output) REAL array, dimension (N)
* The first (n-1) elements of LPLUS contain the subdiagonal
* elements of the unit bidiagonal matrix L(+). LPLUS( N ) is
* set to SIGMA.
*
* WORK (input) REAL array, dimension (???)
* Workspace.
*
* Further Details
* ===============
*
* Based on contributions by
* Inderjit Dhillon, IBM Almaden, USA
* Osni Marques, LBNL/NERSC, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, TWO
PARAMETER ( ZERO = 0.0E0, TWO = 2.0E0 )
* ..
* .. Local Scalars ..
INTEGER I
REAL DELTA, EPS, S, SIGMA
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, REAL
* ..
* .. Executable Statements ..
*
INFO = 0
EPS = SLAMCH( 'Precision' )
IF( IFIRST.EQ.1 ) THEN
SIGMA = W( IFIRST )
ELSE IF( ILAST.EQ.N ) THEN
SIGMA = W( ILAST )
ELSE
INFO = 1
RETURN
END IF
*
* Compute the new relatively robust representation (RRR)
*
OPS = OPS + REAL( 3 )
DELTA = TWO*EPS
10 CONTINUE
IF( IFIRST.EQ.1 ) THEN
SIGMA = SIGMA - ABS( SIGMA )*DELTA
ELSE
SIGMA = SIGMA + ABS( SIGMA )*DELTA
END IF
S = -SIGMA
OPS = OPS + REAL( 5*(N-1)+1 )
DO 20 I = 1, N - 1
DPLUS( I ) = D( I ) + S
LPLUS( I ) = LD( I ) / DPLUS( I )
S = S*LPLUS( I )*L( I ) - SIGMA
20 CONTINUE
DPLUS( N ) = D( N ) + S
IF( IFIRST.EQ.1 ) THEN
DO 30 I = 1, N
IF( DPLUS( I ).LT.ZERO ) THEN
OPS = OPS + REAL( 1 )
DELTA = TWO*DELTA
GO TO 10
END IF
30 CONTINUE
ELSE
DO 40 I = 1, N
IF( DPLUS( I ).GT.ZERO ) THEN
OPS = OPS + REAL( 1 )
DELTA = TWO*DELTA
GO TO 10
END IF
40 CONTINUE
END IF
DO 50 I = IFIRST, ILAST
OPS = OPS + REAL( 1 )
W( I ) = W( I ) - SIGMA
50 CONTINUE
LPLUS( N ) = SIGMA
*
RETURN
*
* End of SLARRF
*
END
SUBROUTINE SLARRV( N, D, L, ISPLIT, M, W, IBLOCK, GERSCH, TOL, Z,
$ LDZ, ISUPPZ, WORK, IWORK, INFO )
*
* -- LAPACK auxiliary routine (instru to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER INFO, LDZ, M, N
REAL TOL
* ..
* .. Array Arguments ..
INTEGER IBLOCK( * ), ISPLIT( * ), ISUPPZ( * ),
$ IWORK( * )
REAL D( * ), GERSCH( * ), L( * ), W( * ), WORK( * ),
$ Z( LDZ, * )
* ..
* Common block to return operation count
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLARRV computes the eigenvectors of the tridiagonal matrix
* T = L D L^T given L, D and the eigenvalues of L D L^T.
* The input eigenvalues should have high relative accuracy with
* respect to the entries of L and D. The desired accuracy of the
* output can be specified by the input parameter TOL.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) REAL array, dimension (N)
* On entry, the n diagonal elements of the diagonal matrix D.
* On exit, D may be overwritten.
*
* L (input/output) REAL array, dimension (N-1)
* On entry, the (n-1) subdiagonal elements of the unit
* bidiagonal matrix L in elements 1 to N-1 of L. L(N) need
* not be set. On exit, L is overwritten.
*
* ISPLIT (input) INTEGER array, dimension (N)
* The splitting points, at which T breaks up into submatrices.
* The first submatrix consists of rows/columns 1 to
* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
* through ISPLIT( 2 ), etc.
*
* TOL (input) REAL
* The absolute error tolerance for the
* eigenvalues/eigenvectors.
* Errors in the input eigenvalues must be bounded by TOL.
* The eigenvectors output have residual norms
* bounded by TOL, and the dot products between different
* eigenvectors are bounded by TOL. TOL must be at least
* N*EPS*|T|, where EPS is the machine precision and |T| is
* the 1-norm of the tridiagonal matrix.
*
* M (input) INTEGER
* The total number of eigenvalues found. 0 <= M <= N.
* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*
* W (input) REAL array, dimension (N)
* The first M elements of W contain the eigenvalues for
* which eigenvectors are to be computed. The eigenvalues
* should be grouped by split-off block and ordered from
* smallest to largest within the block ( The output array
* W from SLARRE is expected here ).
* Errors in W must be bounded by TOL (see above).
*
* IBLOCK (input) INTEGER array, dimension (N)
* The submatrix indices associated with the corresponding
* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to
* the first submatrix from the top, =2 if W(i) belongs to
* the second submatrix, etc.
*
* Z (output) REAL array, dimension (LDZ, max(1,M) )
* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
* contain the orthonormal eigenvectors of the matrix T
* corresponding to the selected eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* If JOBZ = 'N', then Z is not referenced.
* Note: the user must ensure that at least max(1,M) columns are
* supplied in the array Z; if RANGE = 'V', the exact value of M
* is not known in advance and an upper bound must be used.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
* The support of the eigenvectors in Z, i.e., the indices
* indicating the nonzero elements in Z. The i-th eigenvector
* is nonzero only in elements ISUPPZ( 2*i-1 ) through
* ISUPPZ( 2*i ).
*
* WORK (workspace) REAL array, dimension (13*N)
*
* IWORK (workspace) INTEGER array, dimension (6*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = 1, internal error in SLARRB
* if INFO = 2, internal error in SSTEIN
*
* Further Details
* ===============
*
* Based on contributions by
* Inderjit Dhillon, IBM Almaden, USA
* Osni Marques, LBNL/NERSC, USA
* Ken Stanley, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
INTEGER MGSSIZ
PARAMETER ( MGSSIZ = 20 )
REAL ZERO, ONE, FOUR
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, FOUR = 4.0E0 )
* ..
* .. Local Scalars ..
LOGICAL MGSCLS
INTEGER I, IBEGIN, IEND, IINDC1, IINDC2, IINDR, IINDWK,
$ IINFO, IM, IN, INDERR, INDGAP, INDLD, INDLLD,
$ INDWRK, ITER, ITMP1, ITMP2, J, JBLK, K, KTOT,
$ LSBDPT, MAXITR, NCLUS, NDEPTH, NDONE, NEWCLS,
$ NEWFRS, NEWFTT, NEWLST, NEWSIZ, NSPLIT, OLDCLS,
$ OLDFST, OLDIEN, OLDLST, OLDNCL, P, Q,
$ TEMP( 1 )
REAL EPS, GAP, LAMBDA, MGSTOL, MINGMA, MINRGP,
$ NRMINV, RELGAP, RELTOL, RESID, RQCORR, SIGMA,
$ TMP1, ZTZ
* ..
* .. External Functions ..
REAL SDOT, SLAMCH, SNRM2
EXTERNAL SDOT, SLAMCH, SNRM2
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, SLAR1V, SLARRB, SLARRF, SLASET,
$ SSCAL, SSTEIN
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INDERR = N + 1
INDLD = 2*N
INDLLD = 3*N
INDGAP = 4*N
INDWRK = 5*N + 1
*
IINDR = N
IINDC1 = 2*N
IINDC2 = 3*N
IINDWK = 4*N + 1
*
EPS = SLAMCH( 'Precision' )
*
DO 10 I = 1, 2*N
IWORK( I ) = 0
10 CONTINUE
OPS = OPS + REAL( M+1 )
DO 20 I = 1, M
WORK( INDERR+I-1 ) = EPS*ABS( W( I ) )
20 CONTINUE
CALL SLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ )
MGSTOL = 5.0E0*EPS
*
NSPLIT = IBLOCK( M )
IBEGIN = 1
DO 170 JBLK = 1, NSPLIT
IEND = ISPLIT( JBLK )
*
* Find the eigenvectors of the submatrix indexed IBEGIN
* through IEND.
*
IF( IBEGIN.EQ.IEND ) THEN
Z( IBEGIN, IBEGIN ) = ONE
ISUPPZ( 2*IBEGIN-1 ) = IBEGIN
ISUPPZ( 2*IBEGIN ) = IBEGIN
IBEGIN = IEND + 1
GO TO 170
END IF
OLDIEN = IBEGIN - 1
IN = IEND - OLDIEN
OPS = OPS + REAL( 1 )
RELTOL = MIN( 1.0E-2, ONE / REAL( IN ) )
IM = IN
CALL SCOPY( IM, W( IBEGIN ), 1, WORK, 1 )
OPS = OPS + REAL( IN-1 )
DO 30 I = 1, IN - 1
WORK( INDGAP+I ) = WORK( I+1 ) - WORK( I )
30 CONTINUE
WORK( INDGAP+IN ) = MAX( ABS( WORK( IN ) ), EPS )
NDONE = 0
*
NDEPTH = 0
LSBDPT = 1
NCLUS = 1
IWORK( IINDC1+1 ) = 1
IWORK( IINDC1+2 ) = IN
*
* While( NDONE.LT.IM ) do
*
40 CONTINUE
IF( NDONE.LT.IM ) THEN
OLDNCL = NCLUS
NCLUS = 0
LSBDPT = 1 - LSBDPT
DO 150 I = 1, OLDNCL
IF( LSBDPT.EQ.0 ) THEN
OLDCLS = IINDC1
NEWCLS = IINDC2
ELSE
OLDCLS = IINDC2
NEWCLS = IINDC1
END IF
*
* If NDEPTH > 1, retrieve the relatively robust
* representation (RRR) and perform limited bisection
* (if necessary) to get approximate eigenvalues.
*
J = OLDCLS + 2*I
OLDFST = IWORK( J-1 )
OLDLST = IWORK( J )
IF( NDEPTH.GT.0 ) THEN
J = OLDIEN + OLDFST
CALL SCOPY( IN, Z( IBEGIN, J ), 1, D( IBEGIN ), 1 )
CALL SCOPY( IN, Z( IBEGIN, J+1 ), 1, L( IBEGIN ), 1 )
SIGMA = L( IEND )
END IF
K = IBEGIN
OPS = OPS + REAL( 2*(IN-1) )
DO 50 J = 1, IN - 1
WORK( INDLD+J ) = D( K )*L( K )
WORK( INDLLD+J ) = WORK( INDLD+J )*L( K )
K = K + 1
50 CONTINUE
IF( NDEPTH.GT.0 ) THEN
CALL SLARRB( IN, D( IBEGIN ), L( IBEGIN ),
$ WORK( INDLD+1 ), WORK( INDLLD+1 ),
$ OLDFST, OLDLST, SIGMA, RELTOL, WORK,
$ WORK( INDGAP+1 ), WORK( INDERR ),
$ WORK( INDWRK ), IWORK( IINDWK ), IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 1
RETURN
END IF
END IF
*
* Classify eigenvalues of the current representation (RRR)
* as (i) isolated, (ii) loosely clustered or (iii) tightly
* clustered
*
NEWFRS = OLDFST
DO 140 J = OLDFST, OLDLST
OPS = OPS + REAL( 1 )
IF( J.EQ.OLDLST .OR. WORK( INDGAP+J ).GE.RELTOL*
$ ABS( WORK( J ) ) ) THEN
NEWLST = J
ELSE
*
* continue (to the next loop)
*
OPS = OPS + REAL( 1 )
RELGAP = WORK( INDGAP+J ) / ABS( WORK( J ) )
IF( J.EQ.NEWFRS ) THEN
MINRGP = RELGAP
ELSE
MINRGP = MIN( MINRGP, RELGAP )
END IF
GO TO 140
END IF
NEWSIZ = NEWLST - NEWFRS + 1
MAXITR = 10
NEWFTT = OLDIEN + NEWFRS
IF( NEWSIZ.GT.1 ) THEN
MGSCLS = NEWSIZ.LE.MGSSIZ .AND. MINRGP.GE.MGSTOL
IF( .NOT.MGSCLS ) THEN
CALL SLARRF( IN, D( IBEGIN ), L( IBEGIN ),
$ WORK( INDLD+1 ), WORK( INDLLD+1 ),
$ NEWFRS, NEWLST, WORK,
$ Z( IBEGIN, NEWFTT ),
$ Z( IBEGIN, NEWFTT+1 ),
$ WORK( INDWRK ), IWORK( IINDWK ),
$ INFO )
IF( INFO.EQ.0 ) THEN
NCLUS = NCLUS + 1
K = NEWCLS + 2*NCLUS
IWORK( K-1 ) = NEWFRS
IWORK( K ) = NEWLST
ELSE
INFO = 0
IF( MINRGP.GE.MGSTOL ) THEN
MGSCLS = .TRUE.
ELSE
*
* Call SSTEIN to process this tight cluster.
* This happens only if MINRGP <= MGSTOL
* and SLARRF returns INFO = 1. The latter
* means that a new RRR to "break" the
* cluster could not be found.
*
WORK( INDWRK ) = D( IBEGIN )
OPS = OPS + REAL( IN-1 )
DO 60 K = 1, IN - 1
WORK( INDWRK+K ) = D( IBEGIN+K ) +
$ WORK( INDLLD+K )
60 CONTINUE
DO 70 K = 1, NEWSIZ
IWORK( IINDWK+K-1 ) = 1
70 CONTINUE
DO 80 K = NEWFRS, NEWLST
ISUPPZ( 2*( IBEGIN+K )-3 ) = 1
ISUPPZ( 2*( IBEGIN+K )-2 ) = IN
80 CONTINUE
TEMP( 1 ) = IN
CALL SSTEIN( IN, WORK( INDWRK ),
$ WORK( INDLD+1 ), NEWSIZ,
$ WORK( NEWFRS ),
$ IWORK( IINDWK ), TEMP( 1 ),
$ Z( IBEGIN, NEWFTT ), LDZ,
$ WORK( INDWRK+IN ),
$ IWORK( IINDWK+IN ),
$ IWORK( IINDWK+2*IN ), IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 2
RETURN
END IF
NDONE = NDONE + NEWSIZ
END IF
END IF
END IF
ELSE
MGSCLS = .FALSE.
END IF
IF( NEWSIZ.EQ.1 .OR. MGSCLS ) THEN
KTOT = NEWFTT
DO 100 K = NEWFRS, NEWLST
ITER = 0
90 CONTINUE
LAMBDA = WORK( K )
CALL SLAR1V( IN, 1, IN, LAMBDA, D( IBEGIN ),
$ L( IBEGIN ), WORK( INDLD+1 ),
$ WORK( INDLLD+1 ),
$ GERSCH( 2*OLDIEN+1 ),
$ Z( IBEGIN, KTOT ), ZTZ, MINGMA,
$ IWORK( IINDR+KTOT ),
$ ISUPPZ( 2*KTOT-1 ),
$ WORK( INDWRK ) )
OPS = OPS + REAL( 4 )
TMP1 = ONE / ZTZ
NRMINV = SQRT( TMP1 )
RESID = ABS( MINGMA )*NRMINV
RQCORR = MINGMA*TMP1
IF( K.EQ.IN ) THEN
GAP = WORK( INDGAP+K-1 )
ELSE IF( K.EQ.1 ) THEN
GAP = WORK( INDGAP+K )
ELSE
GAP = MIN( WORK( INDGAP+K-1 ),
$ WORK( INDGAP+K ) )
END IF
ITER = ITER + 1
OPS = OPS + REAL( 3 )
IF( RESID.GT.TOL*GAP .AND. ABS( RQCORR ).GT.
$ FOUR*EPS*ABS( LAMBDA ) ) THEN
OPS = OPS + REAL( 1 )
WORK( K ) = LAMBDA + RQCORR
IF( ITER.LT.MAXITR ) THEN
GO TO 90
END IF
END IF
IWORK( KTOT ) = 1
IF( NEWSIZ.EQ.1 )
$ NDONE = NDONE + 1
OPS = OPS + REAL( IN )
CALL SSCAL( IN, NRMINV, Z( IBEGIN, KTOT ), 1 )
KTOT = KTOT + 1
100 CONTINUE
IF( NEWSIZ.GT.1 ) THEN
ITMP1 = ISUPPZ( 2*NEWFTT-1 )
ITMP2 = ISUPPZ( 2*NEWFTT )
KTOT = OLDIEN + NEWLST
DO 120 P = NEWFTT + 1, KTOT
DO 110 Q = NEWFTT, P - 1
OPS = OPS + REAL( 4*IN )
TMP1 = -SDOT( IN, Z( IBEGIN, P ), 1,
$ Z( IBEGIN, Q ), 1 )
CALL SAXPY( IN, TMP1, Z( IBEGIN, Q ), 1,
$ Z( IBEGIN, P ), 1 )
110 CONTINUE
OPS = OPS + REAL( 3*IN+1 )
TMP1 = ONE / SNRM2( IN, Z( IBEGIN, P ), 1 )
CALL SSCAL( IN, TMP1, Z( IBEGIN, P ), 1 )
ITMP1 = MIN( ITMP1, ISUPPZ( 2*P-1 ) )
ITMP2 = MAX( ITMP2, ISUPPZ( 2*P ) )
120 CONTINUE
DO 130 P = NEWFTT, KTOT
ISUPPZ( 2*P-1 ) = ITMP1
ISUPPZ( 2*P ) = ITMP2
130 CONTINUE
NDONE = NDONE + NEWSIZ
END IF
END IF
NEWFRS = J + 1
140 CONTINUE
150 CONTINUE
NDEPTH = NDEPTH + 1
GO TO 40
END IF
J = 2*IBEGIN
DO 160 I = IBEGIN, IEND
ISUPPZ( J-1 ) = ISUPPZ( J-1 ) + OLDIEN
ISUPPZ( J ) = ISUPPZ( J ) + OLDIEN
J = J + 2
160 CONTINUE
IBEGIN = IEND + 1
170 CONTINUE
*
RETURN
*
* End of SLARRV
*
END
SUBROUTINE SLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK,
$ WORK, INFO )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER INFO, LDU, LDVT, N, SMLSIZ, SQRE
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL D( * ), E( * ), U( LDU, * ), VT( LDVT, * ),
$ WORK( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* Using a divide and conquer approach, SLASD0 computes the singular
* value decomposition (SVD) of a real upper bidiagonal N-by-M
* matrix B with diagonal D and offdiagonal E, where M = N + SQRE.
* The algorithm computes orthogonal matrices U and VT such that
* B = U * S * VT. The singular values S are overwritten on D.
*
* A related subroutine, SLASDA, computes only the singular values,
* and optionally, the singular vectors in compact form.
*
* Arguments
* =========
*
* N (input) INTEGER
* On entry, the row dimension of the upper bidiagonal matrix.
* This is also the dimension of the main diagonal array D.
*
* SQRE (input) INTEGER
* Specifies the column dimension of the bidiagonal matrix.
* = 0: The bidiagonal matrix has column dimension M = N;
* = 1: The bidiagonal matrix has column dimension M = N+1;
*
* D (input/output) REAL array, dimension (N)
* On entry D contains the main diagonal of the bidiagonal
* matrix.
* On exit D, if INFO = 0, contains its singular values.
*
* E (input) REAL array, dimension (M-1)
* Contains the subdiagonal entries of the bidiagonal matrix.
* On exit, E has been destroyed.
*
* U (output) REAL array, dimension at least (LDQ, N)
* On exit, U contains the left singular vectors.
*
* LDU (input) INTEGER
* On entry, leading dimension of U.
*
* VT (output) REAL array, dimension at least (LDVT, M)
* On exit, VT' contains the right singular vectors.
*
* LDVT (input) INTEGER
* On entry, leading dimension of VT.
*
* SMLSIZ (input) INTEGER
* On entry, maximum size of the subproblems at the
* bottom of the computation tree.
*
* IWORK INTEGER work array.
* Dimension must be at least (8 * N)
*
* WORK REAL work array.
* Dimension must be at least (3 * M**2 + 2 * M)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an singular value did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, I1, IC, IDXQ, IDXQC, IM1, INODE, ITEMP, IWK,
$ J, LF, LL, LVL, M, NCC, ND, NDB1, NDIML, NDIMR,
$ NL, NLF, NLP1, NLVL, NR, NRF, NRP1, SQREI
REAL ALPHA, BETA
* ..
* .. External Subroutines ..
EXTERNAL SLASD1, SLASDQ, SLASDT, XERBLA
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
INFO = -2
END IF
*
M = N + SQRE
*
IF( LDU.LT.N ) THEN
INFO = -6
ELSE IF( LDVT.LT.M ) THEN
INFO = -8
ELSE IF( SMLSIZ.LT.3 ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLASD0', -INFO )
RETURN
END IF
*
* If the input matrix is too small, call SLASDQ to find the SVD.
*
IF( N.LE.SMLSIZ ) THEN
CALL SLASDQ( 'U', SQRE, N, M, N, 0, D, E, VT, LDVT, U, LDU, U,
$ LDU, WORK, INFO )
RETURN
END IF
*
* Set up the computation tree.
*
INODE = 1
NDIML = INODE + N
NDIMR = NDIML + N
IDXQ = NDIMR + N
IWK = IDXQ + N
CALL SLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ),
$ IWORK( NDIMR ), SMLSIZ )
*
* For the nodes on bottom level of the tree, solve
* their subproblems by SLASDQ.
*
NDB1 = ( ND+1 ) / 2
NCC = 0
DO 30 I = NDB1, ND
*
* IC : center row of each node
* NL : number of rows of left subproblem
* NR : number of rows of right subproblem
* NLF: starting row of the left subproblem
* NRF: starting row of the right subproblem
*
I1 = I - 1
IC = IWORK( INODE+I1 )
NL = IWORK( NDIML+I1 )
NLP1 = NL + 1
NR = IWORK( NDIMR+I1 )
NRP1 = NR + 1
NLF = IC - NL
NRF = IC + 1
SQREI = 1
CALL SLASDQ( 'U', SQREI, NL, NLP1, NL, NCC, D( NLF ), E( NLF ),
$ VT( NLF, NLF ), LDVT, U( NLF, NLF ), LDU,
$ U( NLF, NLF ), LDU, WORK, INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
ITEMP = IDXQ + NLF - 2
DO 10 J = 1, NL
IWORK( ITEMP+J ) = J
10 CONTINUE
IF( I.EQ.ND ) THEN
SQREI = SQRE
ELSE
SQREI = 1
END IF
NRP1 = NR + SQREI
CALL SLASDQ( 'U', SQREI, NR, NRP1, NR, NCC, D( NRF ), E( NRF ),
$ VT( NRF, NRF ), LDVT, U( NRF, NRF ), LDU,
$ U( NRF, NRF ), LDU, WORK, INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
ITEMP = IDXQ + IC
DO 20 J = 1, NR
IWORK( ITEMP+J-1 ) = J
20 CONTINUE
30 CONTINUE
*
* Now conquer each subproblem bottom-up.
*
DO 50 LVL = NLVL, 1, -1
*
* Find the first node LF and last node LL on the
* current level LVL.
*
IF( LVL.EQ.1 ) THEN
LF = 1
LL = 1
ELSE
LF = 2**( LVL-1 )
LL = 2*LF - 1
END IF
DO 40 I = LF, LL
IM1 = I - 1
IC = IWORK( INODE+IM1 )
NL = IWORK( NDIML+IM1 )
NR = IWORK( NDIMR+IM1 )
NLF = IC - NL
IF( ( SQRE.EQ.0 ) .AND. ( I.EQ.LL ) ) THEN
SQREI = SQRE
ELSE
SQREI = 1
END IF
IDXQC = IDXQ + NLF - 1
ALPHA = D( IC )
BETA = E( IC )
CALL SLASD1( NL, NR, SQREI, D( NLF ), ALPHA, BETA,
$ U( NLF, NLF ), LDU, VT( NLF, NLF ), LDVT,
$ IWORK( IDXQC ), IWORK( IWK ), WORK, INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
40 CONTINUE
50 CONTINUE
*
RETURN
*
* End of SLASD0
*
END
SUBROUTINE SLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT,
$ IDXQ, IWORK, WORK, INFO )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER INFO, LDU, LDVT, NL, NR, SQRE
REAL ALPHA, BETA
* ..
* .. Array Arguments ..
INTEGER IDXQ( * ), IWORK( * )
REAL D( * ), U( LDU, * ), VT( LDVT, * ), WORK( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B,
* where N = NL + NR + 1 and M = N + SQRE. SLASD1 is called from SLASD0.
*
* A related subroutine SLASD7 handles the case in which the singular
* values (and the singular vectors in factored form) are desired.
*
* SLASD1 computes the SVD as follows:
*
* ( D1(in) 0 0 0 )
* B = U(in) * ( Z1' a Z2' b ) * VT(in)
* ( 0 0 D2(in) 0 )
*
* = U(out) * ( D(out) 0) * VT(out)
*
* where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M
* with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros
* elsewhere; and the entry b is empty if SQRE = 0.
*
* The left singular vectors of the original matrix are stored in U, and
* the transpose of the right singular vectors are stored in VT, and the
* singular values are in D. The algorithm consists of three stages:
*
* The first stage consists of deflating the size of the problem
* when there are multiple singular values or when there are zeros in
* the Z vector. For each such occurence the dimension of the
* secular equation problem is reduced by one. This stage is
* performed by the routine SLASD2.
*
* The second stage consists of calculating the updated
* singular values. This is done by finding the square roots of the
* roots of the secular equation via the routine SLASD4 (as called
* by SLASD3). This routine also calculates the singular vectors of
* the current problem.
*
* The final stage consists of computing the updated singular vectors
* directly using the updated singular values. The singular vectors
* for the current problem are multiplied with the singular vectors
* from the overall problem.
*
* Arguments
* =========
*
* NL (input) INTEGER
* The row dimension of the upper block. NL >= 1.
*
* NR (input) INTEGER
* The row dimension of the lower block. NR >= 1.
*
* SQRE (input) INTEGER
* = 0: the lower block is an NR-by-NR square matrix.
* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
*
* The bidiagonal matrix has row dimension N = NL + NR + 1,
* and column dimension M = N + SQRE.
*
* D (input/output) REAL array,
* dimension (N = NL+NR+1).
* On entry D(1:NL,1:NL) contains the singular values of the
* upper block; and D(NL+2:N) contains the singular values of
* the lower block. On exit D(1:N) contains the singular values
* of the modified matrix.
*
* ALPHA (input) REAL
* Contains the diagonal element associated with the added row.
*
* BETA (input) REAL
* Contains the off-diagonal element associated with the added
* row.
*
* U (input/output) REAL array, dimension(LDU,N)
* On entry U(1:NL, 1:NL) contains the left singular vectors of
* the upper block; U(NL+2:N, NL+2:N) contains the left singular
* vectors of the lower block. On exit U contains the left
* singular vectors of the bidiagonal matrix.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= max( 1, N ).
*
* VT (input/output) REAL array, dimension(LDVT,M)
* where M = N + SQRE.
* On entry VT(1:NL+1, 1:NL+1)' contains the right singular
* vectors of the upper block; VT(NL+2:M, NL+2:M)' contains
* the right singular vectors of the lower block. On exit
* VT' contains the right singular vectors of the
* bidiagonal matrix.
*
* LDVT (input) INTEGER
* The leading dimension of the array VT. LDVT >= max( 1, M ).
*
* IDXQ (output) INTEGER array, dimension(N)
* This contains the permutation which will reintegrate the
* subproblem just solved back into sorted order, i.e.
* D( IDXQ( I = 1, N ) ) will be in ascending order.
*
* IWORK (workspace) INTEGER array, dimension( 4 * N )
*
* WORK (workspace) REAL array, dimension( 3*M**2 + 2*M )
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an singular value did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
*
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
INTEGER COLTYP, I, IDX, IDXC, IDXP, IQ, ISIGMA, IU2,
$ IVT2, IZ, K, LDQ, LDU2, LDVT2, M, N, N1, N2
REAL ORGNRM
* ..
* .. External Subroutines ..
EXTERNAL SLAMRG, SLASCL, SLASD2, SLASD3, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL, ABS, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( NL.LT.1 ) THEN
INFO = -1
ELSE IF( NR.LT.1 ) THEN
INFO = -2
ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
INFO = -3
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLASD1', -INFO )
RETURN
END IF
*
N = NL + NR + 1
M = N + SQRE
*
* The following values are for bookkeeping purposes only. They are
* integer pointers which indicate the portion of the workspace
* used by a particular array in SLASD2 and SLASD3.
*
LDU2 = N
LDVT2 = M
*
IZ = 1
ISIGMA = IZ + M
IU2 = ISIGMA + N
IVT2 = IU2 + LDU2*N
IQ = IVT2 + LDVT2*M
*
IDX = 1
IDXC = IDX + N
COLTYP = IDXC + N
IDXP = COLTYP + N
*
* Scale.
*
ORGNRM = MAX( ABS( ALPHA ), ABS( BETA ) )
D( NL+1 ) = ZERO
DO 10 I = 1, N
IF( ABS( D( I ) ).GT.ORGNRM ) THEN
ORGNRM = ABS( D( I ) )
END IF
10 CONTINUE
OPS = OPS + REAL( N + 2 )
CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
ALPHA = ALPHA / ORGNRM
BETA = BETA / ORGNRM
*
* Deflate singular values.
*
CALL SLASD2( NL, NR, SQRE, K, D, WORK( IZ ), ALPHA, BETA, U, LDU,
$ VT, LDVT, WORK( ISIGMA ), WORK( IU2 ), LDU2,
$ WORK( IVT2 ), LDVT2, IWORK( IDXP ), IWORK( IDX ),
$ IWORK( IDXC ), IDXQ, IWORK( COLTYP ), INFO )
*
* Solve Secular Equation and update singular vectors.
*
LDQ = K
CALL SLASD3( NL, NR, SQRE, K, D, WORK( IQ ), LDQ, WORK( ISIGMA ),
$ U, LDU, WORK( IU2 ), LDU2, VT, LDVT, WORK( IVT2 ),
$ LDVT2, IWORK( IDXC ), IWORK( COLTYP ), WORK( IZ ),
$ INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
*
* Unscale.
*
OPS = OPS + REAL( N )
CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
*
* Prepare the IDXQ sorting permutation.
*
N1 = K
N2 = N - K
CALL SLAMRG( N1, N2, D, 1, -1, IDXQ )
*
RETURN
*
* End of SLASD1
*
END
SUBROUTINE SLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT,
$ LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX,
$ IDXC, IDXQ, COLTYP, INFO )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
* Courant Institute, NAG Ltd., and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDU, LDU2, LDVT, LDVT2, NL, NR, SQRE
REAL ALPHA, BETA
* ..
* .. Array Arguments ..
INTEGER COLTYP( * ), IDX( * ), IDXC( * ), IDXP( * ),
$ IDXQ( * )
REAL D( * ), DSIGMA( * ), U( LDU, * ),
$ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ),
$ Z( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLASD2 merges the two sets of singular values together into a single
* sorted set. Then it tries to deflate the size of the problem.
* There are two ways in which deflation can occur: when two or more
* singular values are close together or if there is a tiny entry in the
* Z vector. For each such occurrence the order of the related secular
* equation problem is reduced by one.
*
* SLASD2 is called from SLASD1.
*
* Arguments
* =========
*
* NL (input) INTEGER
* The row dimension of the upper block. NL >= 1.
*
* NR (input) INTEGER
* The row dimension of the lower block. NR >= 1.
*
* SQRE (input) INTEGER
* = 0: the lower block is an NR-by-NR square matrix.
* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
*
* The bidiagonal matrix has N = NL + NR + 1 rows and
* M = N + SQRE >= N columns.
*
* K (output) INTEGER
* Contains the dimension of the non-deflated matrix,
* This is the order of the related secular equation. 1 <= K <=N.
*
* D (input/output) REAL array, dimension(N)
* On entry D contains the singular values of the two submatrices
* to be combined. On exit D contains the trailing (N-K) updated
* singular values (those which were deflated) sorted into
* increasing order.
*
* ALPHA (input) REAL
* Contains the diagonal element associated with the added row.
*
* BETA (input) REAL
* Contains the off-diagonal element associated with the added
* row.
*
* U (input/output) REAL array, dimension(LDU,N)
* On entry U contains the left singular vectors of two
* submatrices in the two square blocks with corners at (1,1),
* (NL, NL), and (NL+2, NL+2), (N,N).
* On exit U contains the trailing (N-K) updated left singular
* vectors (those which were deflated) in its last N-K columns.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= N.
*
* Z (output) REAL array, dimension(N)
* On exit Z contains the updating row vector in the secular
* equation.
*
* DSIGMA (output) REAL array, dimension (N)
* Contains a copy of the diagonal elements (K-1 singular values
* and one zero) in the secular equation.
*
* U2 (output) REAL array, dimension(LDU2,N)
* Contains a copy of the first K-1 left singular vectors which
* will be used by SLASD3 in a matrix multiply (SGEMM) to solve
* for the new left singular vectors. U2 is arranged into four
* blocks. The first block contains a column with 1 at NL+1 and
* zero everywhere else; the second block contains non-zero
* entries only at and above NL; the third contains non-zero
* entries only below NL+1; and the fourth is dense.
*
* LDU2 (input) INTEGER
* The leading dimension of the array U2. LDU2 >= N.
*
* VT (input/output) REAL array, dimension(LDVT,M)
* On entry VT' contains the right singular vectors of two
* submatrices in the two square blocks with corners at (1,1),
* (NL+1, NL+1), and (NL+2, NL+2), (M,M).
* On exit VT' contains the trailing (N-K) updated right singular
* vectors (those which were deflated) in its last N-K columns.
* In case SQRE =1, the last row of VT spans the right null
* space.
*
* LDVT (input) INTEGER
* The leading dimension of the array VT. LDVT >= M.
*
* VT2 (output) REAL array, dimension(LDVT2,N)
* VT2' contains a copy of the first K right singular vectors
* which will be used by SLASD3 in a matrix multiply (SGEMM) to
* solve for the new right singular vectors. VT2 is arranged into
* three blocks. The first block contains a row that corresponds
* to the special 0 diagonal element in SIGMA; the second block
* contains non-zeros only at and before NL +1; the third block
* contains non-zeros only at and after NL +2.
*
* LDVT2 (input) INTEGER
* The leading dimension of the array VT2. LDVT2 >= M.
*
* IDXP (workspace) INTEGER array, dimension(N)
* This will contain the permutation used to place deflated
* values of D at the end of the array. On output IDXP(2:K)
* points to the nondeflated D-values and IDXP(K+1:N)
* points to the deflated singular values.
*
* IDX (workspace) INTEGER array, dimension(N)
* This will contain the permutation used to sort the contents of
* D into ascending order.
*
* IDXC (output) INTEGER array, dimension(N)
* This will contain the permutation used to arrange the columns
* of the deflated U matrix into three groups: the first group
* contains non-zero entries only at and above NL, the second
* contains non-zero entries only below NL+2, and the third is
* dense.
*
* COLTYP (workspace/output) INTEGER array, dimension(N)
* As workspace, this will contain a label which will indicate
* which of the following types a column in the U2 matrix or a
* row in the VT2 matrix is:
* 1 : non-zero in the upper half only
* 2 : non-zero in the lower half only
* 3 : dense
* 4 : deflated
*
* On exit, it is an array of dimension 4, with COLTYP(I) being
* the dimension of the I-th type columns.
*
* IDXQ (input) INTEGER array, dimension(N)
* This contains the permutation which separately sorts the two
* sub-problems in D into ascending order. Note that entries in
* the first hlaf of this permutation must first be moved one
* position backward; and entries in the second half
* must first have NL+1 added to their values.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO, EIGHT
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ EIGHT = 8.0E0 )
* ..
* .. Local Arrays ..
INTEGER CTOT( 4 ), PSM( 4 )
* ..
* .. Local Scalars ..
INTEGER CT, I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M,
$ N, NLP1, NLP2
REAL C, EPS, HLFTOL, S, TAU, TOL, Z1
* ..
* .. External Functions ..
REAL SLAMCH, SLAPY2
EXTERNAL SLAMCH, SLAPY2
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLACPY, SLAMRG, SLASET, SROT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL, ABS, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( NL.LT.1 ) THEN
INFO = -1
ELSE IF( NR.LT.1 ) THEN
INFO = -2
ELSE IF( ( SQRE.NE.1 ) .AND. ( SQRE.NE.0 ) ) THEN
INFO = -3
END IF
*
N = NL + NR + 1
M = N + SQRE
*
IF( LDU.LT.N ) THEN
INFO = -10
ELSE IF( LDVT.LT.M ) THEN
INFO = -12
ELSE IF( LDU2.LT.N ) THEN
INFO = -15
ELSE IF( LDVT2.LT.M ) THEN
INFO = -17
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLASD2', -INFO )
RETURN
END IF
*
NLP1 = NL + 1
NLP2 = NL + 2
*
* Generate the first part of the vector Z; and move the singular
* values in the first part of D one position backward.
*
OPS = OPS + REAL( 1 + NL )
Z1 = ALPHA*VT( NLP1, NLP1 )
Z( 1 ) = Z1
DO 10 I = NL, 1, -1
Z( I+1 ) = ALPHA*VT( I, NLP1 )
D( I+1 ) = D( I )
IDXQ( I+1 ) = IDXQ( I ) + 1
10 CONTINUE
*
* Generate the second part of the vector Z.
*
OPS = OPS + REAL( M-NLP2+1 )
DO 20 I = NLP2, M
Z( I ) = BETA*VT( I, NLP2 )
20 CONTINUE
*
* Initialize some reference arrays.
*
DO 30 I = 2, NLP1
COLTYP( I ) = 1
30 CONTINUE
DO 40 I = NLP2, N
COLTYP( I ) = 2
40 CONTINUE
*
* Sort the singular values into increasing order
*
DO 50 I = NLP2, N
IDXQ( I ) = IDXQ( I ) + NLP1
50 CONTINUE
*
* DSIGMA, IDXC, IDXC, and the first column of U2
* are used as storage space.
*
DO 60 I = 2, N
DSIGMA( I ) = D( IDXQ( I ) )
U2( I, 1 ) = Z( IDXQ( I ) )
IDXC( I ) = COLTYP( IDXQ( I ) )
60 CONTINUE
*
CALL SLAMRG( NL, NR, DSIGMA( 2 ), 1, 1, IDX( 2 ) )
*
DO 70 I = 2, N
IDXI = 1 + IDX( I )
D( I ) = DSIGMA( IDXI )
Z( I ) = U2( IDXI, 1 )
COLTYP( I ) = IDXC( IDXI )
70 CONTINUE
*
* Calculate the allowable deflation tolerance
*
OPS = OPS + REAL( 2 )
EPS = SLAMCH( 'Epsilon' )
TOL = MAX( ABS( ALPHA ), ABS( BETA ) )
TOL = EIGHT*EPS*MAX( ABS( D( N ) ), TOL )
*
* There are 2 kinds of deflation -- first a value in the z-vector
* is small, second two (or more) singular values are very close
* together (their difference is small).
*
* If the value in the z-vector is small, we simply permute the
* array so that the corresponding singular value is moved to the
* end.
*
* If two values in the D-vector are close, we perform a two-sided
* rotation designed to make one of the corresponding z-vector
* entries zero, and then permute the array so that the deflated
* singular value is moved to the end.
*
* If there are multiple singular values then the problem deflates.
* Here the number of equal singular values are found. As each equal
* singular value is found, an elementary reflector is computed to
* rotate the corresponding singular subspace so that the
* corresponding components of Z are zero in this new basis.
*
K = 1
K2 = N + 1
DO 80 J = 2, N
IF( ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
IDXP( K2 ) = J
COLTYP( J ) = 4
IF( J.EQ.N )
$ GO TO 120
ELSE
JPREV = J
GO TO 90
END IF
80 CONTINUE
90 CONTINUE
J = JPREV
100 CONTINUE
J = J + 1
IF( J.GT.N )
$ GO TO 110
IF( ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
IDXP( K2 ) = J
COLTYP( J ) = 4
ELSE
*
* Check if singular values are close enough to allow deflation.
*
OPS = OPS + REAL( 1 )
IF( ABS( D( J )-D( JPREV ) ).LE.TOL ) THEN
*
* Deflation is possible.
*
S = Z( JPREV )
C = Z( J )
*
* Find sqrt(a**2+b**2) without overflow or
* destructive underflow.
*
OPS = OPS + REAL( 7 )
TAU = SLAPY2( C, S )
C = C / TAU
S = -S / TAU
Z( J ) = TAU
Z( JPREV ) = ZERO
*
* Apply back the Givens rotation to the left and right
* singular vector matrices.
*
IDXJP = IDXQ( IDX( JPREV )+1 )
IDXJ = IDXQ( IDX( J )+1 )
IF( IDXJP.LE.NLP1 ) THEN
IDXJP = IDXJP - 1
END IF
IF( IDXJ.LE.NLP1 ) THEN
IDXJ = IDXJ - 1
END IF
OPS = OPS + REAL( 12 )
CALL SROT( N, U( 1, IDXJP ), 1, U( 1, IDXJ ), 1, C, S )
CALL SROT( M, VT( IDXJP, 1 ), LDVT, VT( IDXJ, 1 ), LDVT, C,
$ S )
IF( COLTYP( J ).NE.COLTYP( JPREV ) ) THEN
COLTYP( J ) = 3
END IF
COLTYP( JPREV ) = 4
K2 = K2 - 1
IDXP( K2 ) = JPREV
JPREV = J
ELSE
K = K + 1
U2( K, 1 ) = Z( JPREV )
DSIGMA( K ) = D( JPREV )
IDXP( K ) = JPREV
JPREV = J
END IF
END IF
GO TO 100
110 CONTINUE
*
* Record the last singular value.
*
K = K + 1
U2( K, 1 ) = Z( JPREV )
DSIGMA( K ) = D( JPREV )
IDXP( K ) = JPREV
*
120 CONTINUE
*
* Count up the total number of the various types of columns, then
* form a permutation which positions the four column types into
* four groups of uniform structure (although one or more of these
* groups may be empty).
*
DO 130 J = 1, 4
CTOT( J ) = 0
130 CONTINUE
DO 140 J = 2, N
CT = COLTYP( J )
CTOT( CT ) = CTOT( CT ) + 1
140 CONTINUE
*
* PSM(*) = Position in SubMatrix (of types 1 through 4)
*
PSM( 1 ) = 2
PSM( 2 ) = 2 + CTOT( 1 )
PSM( 3 ) = PSM( 2 ) + CTOT( 2 )
PSM( 4 ) = PSM( 3 ) + CTOT( 3 )
*
* Fill out the IDXC array so that the permutation which it induces
* will place all type-1 columns first, all type-2 columns next,
* then all type-3's, and finally all type-4's, starting from the
* second column. This applies similarly to the rows of VT.
*
DO 150 J = 2, N
JP = IDXP( J )
CT = COLTYP( JP )
IDXC( PSM( CT ) ) = J
PSM( CT ) = PSM( CT ) + 1
150 CONTINUE
*
* Sort the singular values and corresponding singular vectors into
* DSIGMA, U2, and VT2 respectively. The singular values/vectors
* which were not deflated go into the first K slots of DSIGMA, U2,
* and VT2 respectively, while those which were deflated go into the
* last N - K slots, except that the first column/row will be treated
* separately.
*
DO 160 J = 2, N
JP = IDXP( J )
DSIGMA( J ) = D( JP )
IDXJ = IDXQ( IDX( IDXP( IDXC( J ) ) )+1 )
IF( IDXJ.LE.NLP1 ) THEN
IDXJ = IDXJ - 1
END IF
CALL SCOPY( N, U( 1, IDXJ ), 1, U2( 1, J ), 1 )
CALL SCOPY( M, VT( IDXJ, 1 ), LDVT, VT2( J, 1 ), LDVT2 )
160 CONTINUE
*
* Determine DSIGMA(1), DSIGMA(2) and Z(1)
*
OPS = OPS + REAL( 1 )
DSIGMA( 1 ) = ZERO
HLFTOL = TOL / TWO
IF( ABS( DSIGMA( 2 ) ).LE.HLFTOL )
$ DSIGMA( 2 ) = HLFTOL
IF( M.GT.N ) THEN
OPS = OPS + REAL( 5 )
Z( 1 ) = SLAPY2( Z1, Z( M ) )
IF( Z( 1 ).LE.TOL ) THEN
C = ONE
S = ZERO
Z( 1 ) = TOL
ELSE
OPS = OPS + REAL( 2 )
C = Z1 / Z( 1 )
S = Z( M ) / Z( 1 )
END IF
ELSE
IF( ABS( Z1 ).LE.TOL ) THEN
Z( 1 ) = TOL
ELSE
Z( 1 ) = Z1
END IF
END IF
*
* Move the rest of the updating row to Z.
*
CALL SCOPY( K-1, U2( 2, 1 ), 1, Z( 2 ), 1 )
*
* Determine the first column of U2, the first row of VT2 and the
* last row of VT.
*
CALL SLASET( 'A', N, 1, ZERO, ZERO, U2, LDU2 )
U2( NLP1, 1 ) = ONE
IF( M.GT.N ) THEN
OPS = OPS + REAL( NLP1*2 )
DO 170 I = 1, NLP1
VT( M, I ) = -S*VT( NLP1, I )
VT2( 1, I ) = C*VT( NLP1, I )
170 CONTINUE
OPS = OPS + REAL( (M-NLP2+1)*2 )
DO 180 I = NLP2, M
VT2( 1, I ) = S*VT( M, I )
VT( M, I ) = C*VT( M, I )
180 CONTINUE
ELSE
CALL SCOPY( M, VT( NLP1, 1 ), LDVT, VT2( 1, 1 ), LDVT2 )
END IF
IF( M.GT.N ) THEN
CALL SCOPY( M, VT( M, 1 ), LDVT, VT2( M, 1 ), LDVT2 )
END IF
*
* The deflated singular values and their corresponding vectors go
* into the back of D, U, and V respectively.
*
IF( N.GT.K ) THEN
CALL SCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 )
CALL SLACPY( 'A', N, N-K, U2( 1, K+1 ), LDU2, U( 1, K+1 ),
$ LDU )
CALL SLACPY( 'A', N-K, M, VT2( K+1, 1 ), LDVT2, VT( K+1, 1 ),
$ LDVT )
END IF
*
* Copy CTOT into COLTYP for referencing in SLASD3.
*
DO 190 J = 1, 4
COLTYP( J ) = CTOT( J )
190 CONTINUE
*
RETURN
*
* End of SLASD2
*
END
SUBROUTINE SLASD3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2,
$ LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z,
$ INFO )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
* Courant Institute, NAG Ltd., and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDQ, LDU, LDU2, LDVT, LDVT2, NL, NR,
$ SQRE
* ..
* .. Array Arguments ..
INTEGER CTOT( * ), IDXC( * )
REAL D( * ), DSIGMA( * ), Q( LDQ, * ), U( LDU, * ),
$ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ),
$ Z( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLASD3 finds all the square roots of the roots of the secular
* equation, as defined by the values in D and Z. It makes the
* appropriate calls to SLASD4 and then updates the singular
* vectors by matrix multiplication.
*
* This code makes very mild assumptions about floating point
* arithmetic. It will work on machines with a guard digit in
* add/subtract, or on those binary machines without guard digits
* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
* It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* SLASD3 is called from SLASD1.
*
* Arguments
* =========
*
* NL (input) INTEGER
* The row dimension of the upper block. NL >= 1.
*
* NR (input) INTEGER
* The row dimension of the lower block. NR >= 1.
*
* SQRE (input) INTEGER
* = 0: the lower block is an NR-by-NR square matrix.
* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
*
* The bidiagonal matrix has N = NL + NR + 1 rows and
* M = N + SQRE >= N columns.
*
* K (input) INTEGER
* The size of the secular equation, 1 =< K = < N.
*
* D (output) REAL array, dimension(K)
* On exit the square roots of the roots of the secular equation,
* in ascending order.
*
* Q (workspace) REAL array,
* dimension at least (LDQ,K).
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= K.
*
* DSIGMA (input) REAL array, dimension(K)
* The first K elements of this array contain the old roots
* of the deflated updating problem. These are the poles
* of the secular equation.
*
* U (input) REAL array, dimension (LDU, N)
* The last N - K columns of this matrix contain the deflated
* left singular vectors.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= N.
*
* U2 (input) REAL array, dimension (LDU2, N)
* The first K columns of this matrix contain the non-deflated
* left singular vectors for the split problem.
*
* LDU2 (input) INTEGER
* The leading dimension of the array U2. LDU2 >= N.
*
* VT (input) REAL array, dimension (LDVT, M)
* The last M - K columns of VT' contain the deflated
* right singular vectors.
*
* LDVT (input) INTEGER
* The leading dimension of the array VT. LDVT >= N.
*
* VT2 (input) REAL array, dimension (LDVT2, N)
* The first K columns of VT2' contain the non-deflated
* right singular vectors for the split problem.
*
* LDVT2 (input) INTEGER
* The leading dimension of the array VT2. LDVT2 >= N.
*
* IDXC (input) INTEGER array, dimension ( N )
* The permutation used to arrange the columns of U (and rows of
* VT) into three groups: the first group contains non-zero
* entries only at and above (or before) NL +1; the second
* contains non-zero entries only at and below (or after) NL+2;
* and the third is dense. The first column of U and the row of
* VT are treated separately, however.
*
* The rows of the singular vectors found by SLASD4
* must be likewise permuted before the matrix multiplies can
* take place.
*
* CTOT (input) INTEGER array, dimension ( 4 )
* A count of the total number of the various types of columns
* in U (or rows in VT), as described in IDXC. The fourth column
* type is any column which has been deflated.
*
* Z (input) REAL array, dimension (K)
* The first K elements of this array contain the components
* of the deflation-adjusted updating row vector.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an singular value did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO, NEGONE
PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0, NEGONE = -1.0E0 )
* ..
* .. Local Scalars ..
INTEGER CTEMP, I, J, JC, KTEMP, M, N, NLP1, NLP2, NRP1
REAL RHO, TEMP
* ..
* .. External Functions ..
REAL SLAMC3, SNRM2, SOPBL3
EXTERNAL SLAMC3, SNRM2, SOPBL3
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMM, SLACPY, SLASCL, SLASD4, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL, ABS, MAX, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( NL.LT.1 ) THEN
INFO = -1
ELSE IF( NR.LT.1 ) THEN
INFO = -2
ELSE IF( ( SQRE.NE.1 ) .AND. ( SQRE.NE.0 ) ) THEN
INFO = -3
END IF
*
N = NL + NR + 1
M = N + SQRE
NLP1 = NL + 1
NLP2 = NL + 2
*
IF( ( K.LT.1 ) .OR. ( K.GT.N ) ) THEN
INFO = -4
ELSE IF( LDQ.LT.K ) THEN
INFO = -7
ELSE IF( LDU.LT.N ) THEN
INFO = -10
ELSE IF( LDU2.LT.N ) THEN
INFO = -12
ELSE IF( LDVT.LT.M ) THEN
INFO = -14
ELSE IF( LDVT2.LT.M ) THEN
INFO = -16
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLASD3', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( K.EQ.1 ) THEN
D( 1 ) = ABS( Z( 1 ) )
CALL SCOPY( M, VT2( 1, 1 ), LDVT2, VT( 1, 1 ), LDVT )
IF( Z( 1 ).GT.ZERO ) THEN
CALL SCOPY( N, U2( 1, 1 ), 1, U( 1, 1 ), 1 )
ELSE
DO 10 I = 1, N
U( I, 1 ) = -U2( I, 1 )
10 CONTINUE
END IF
RETURN
END IF
*
* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can
* be computed with high relative accuracy (barring over/underflow).
* This is a problem on machines without a guard digit in
* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I),
* which on any of these machines zeros out the bottommost
* bit of DSIGMA(I) if it is 1; this makes the subsequent
* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation
* occurs. On binary machines with a guard digit (almost all
* machines) it does not change DSIGMA(I) at all. On hexadecimal
* and decimal machines with a guard digit, it slightly
* changes the bottommost bits of DSIGMA(I). It does not account
* for hexadecimal or decimal machines without guard digits
* (we know of none). We use a subroutine call to compute
* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating
* this code.
*
DO 20 I = 1, K
DSIGMA( I ) = SLAMC3( DSIGMA( I ), DSIGMA( I ) ) - DSIGMA( I )
20 CONTINUE
*
* Keep a copy of Z.
*
CALL SCOPY( K, Z, 1, Q, 1 )
*
* Normalize Z.
*
OPS = OPS + REAL( K*3 + 1)
RHO = SNRM2( K, Z, 1 )
CALL SLASCL( 'G', 0, 0, RHO, ONE, K, 1, Z, K, INFO )
RHO = RHO*RHO
*
* Find the new singular values.
*
DO 30 J = 1, K
CALL SLASD4( K, J, DSIGMA, Z, U( 1, J ), RHO, D( J ),
$ VT( 1, J ), INFO )
*
* If the zero finder fails, the computation is terminated.
*
IF( INFO.NE.0 ) THEN
RETURN
END IF
30 CONTINUE
*
* Compute updated Z.
*
OPS = OPS + REAL( K*2 )
DO 60 I = 1, K
Z( I ) = U( I, K )*VT( I, K )
OPS = OPS + REAL( (I-1)*6 )
DO 40 J = 1, I - 1
Z( I ) = Z( I )*( U( I, J )*VT( I, J ) /
$ ( DSIGMA( I )-DSIGMA( J ) ) /
$ ( DSIGMA( I )+DSIGMA( J ) ) )
40 CONTINUE
OPS = OPS + REAL( (K-I)*6 )
DO 50 J = I, K - 1
Z( I ) = Z( I )*( U( I, J )*VT( I, J ) /
$ ( DSIGMA( I )-DSIGMA( J+1 ) ) /
$ ( DSIGMA( I )+DSIGMA( J+1 ) ) )
50 CONTINUE
Z( I ) = SIGN( SQRT( ABS( Z( I ) ) ), Q( I, 1 ) )
60 CONTINUE
*
* Compute left singular vectors of the modified diagonal matrix,
* and store related information for the right singular vectors.
*
OPS = OPS + REAL( K*(3+K*2) + MAX(0,(K-1)*4) )
DO 90 I = 1, K
VT( 1, I ) = Z( 1 ) / U( 1, I ) / VT( 1, I )
U( 1, I ) = NEGONE
DO 70 J = 2, K
VT( J, I ) = Z( J ) / U( J, I ) / VT( J, I )
U( J, I ) = DSIGMA( J )*VT( J, I )
70 CONTINUE
TEMP = SNRM2( K, U( 1, I ), 1 )
Q( 1, I ) = U( 1, I ) / TEMP
DO 80 J = 2, K
JC = IDXC( J )
Q( J, I ) = U( JC, I ) / TEMP
80 CONTINUE
90 CONTINUE
*
* Update the left singular vector matrix.
*
IF( K.EQ.2 ) THEN
OPS = OPS + SOPBL3( 'SGEMM ', N, K, K )
CALL SGEMM( 'N', 'N', N, K, K, ONE, U2, LDU2, Q, LDQ, ZERO, U,
$ LDU )
GO TO 100
END IF
IF( CTOT( 1 ).GT.0 ) THEN
OPS = OPS + SOPBL3( 'SGEMM ', NL, K, CTOT( 1 ) )
CALL SGEMM( 'N', 'N', NL, K, CTOT( 1 ), ONE, U2( 1, 2 ), LDU2,
$ Q( 2, 1 ), LDQ, ZERO, U( 1, 1 ), LDU )
IF( CTOT( 3 ).GT.0 ) THEN
KTEMP = 2 + CTOT( 1 ) + CTOT( 2 )
OPS = OPS + SOPBL3( 'SGEMM ', NL, K, CTOT( 3 ) )
CALL SGEMM( 'N', 'N', NL, K, CTOT( 3 ), ONE, U2( 1, KTEMP ),
$ LDU2, Q( KTEMP, 1 ), LDQ, ONE, U( 1, 1 ), LDU )
END IF
ELSE IF( CTOT( 3 ).GT.0 ) THEN
KTEMP = 2 + CTOT( 1 ) + CTOT( 2 )
OPS = OPS + SOPBL3( 'SGEMM ', NL, K, CTOT( 3 ) )
CALL SGEMM( 'N', 'N', NL, K, CTOT( 3 ), ONE, U2( 1, KTEMP ),
$ LDU2, Q( KTEMP, 1 ), LDQ, ZERO, U( 1, 1 ), LDU )
ELSE
CALL SLACPY( 'F', NL, K, U2, LDU2, U, LDU )
END IF
CALL SCOPY( K, Q( 1, 1 ), LDQ, U( NLP1, 1 ), LDU )
KTEMP = 2 + CTOT( 1 )
CTEMP = CTOT( 2 ) + CTOT( 3 )
OPS = OPS + SOPBL3( 'SGEMM ', NR, K, CTEMP )
CALL SGEMM( 'N', 'N', NR, K, CTEMP, ONE, U2( NLP2, KTEMP ), LDU2,
$ Q( KTEMP, 1 ), LDQ, ZERO, U( NLP2, 1 ), LDU )
*
* Generate the right singular vectors.
*
100 CONTINUE
OPS = OPS + REAL( K*(K*2+1) + MAX(0,K-1) )
DO 120 I = 1, K
TEMP = SNRM2( K, VT( 1, I ), 1 )
Q( I, 1 ) = VT( 1, I ) / TEMP
DO 110 J = 2, K
JC = IDXC( J )
Q( I, J ) = VT( JC, I ) / TEMP
110 CONTINUE
120 CONTINUE
*
* Update the right singular vector matrix.
*
IF( K.EQ.2 ) THEN
OPS = OPS + SOPBL3( 'SGEMM ', K, M, K )
CALL SGEMM( 'N', 'N', K, M, K, ONE, Q, LDQ, VT2, LDVT2, ZERO,
$ VT, LDVT )
RETURN
END IF
KTEMP = 1 + CTOT( 1 )
OPS = OPS + SOPBL3( 'SGEMM ', K, NLP1, KTEMP )
CALL SGEMM( 'N', 'N', K, NLP1, KTEMP, ONE, Q( 1, 1 ), LDQ,
$ VT2( 1, 1 ), LDVT2, ZERO, VT( 1, 1 ), LDVT )
KTEMP = 2 + CTOT( 1 ) + CTOT( 2 )
OPS = OPS + SOPBL3( 'SGEMM ', K, NLP1, CTOT( 3 ) )
IF( KTEMP.LE.LDVT2 )
$ CALL SGEMM( 'N', 'N', K, NLP1, CTOT( 3 ), ONE, Q( 1, KTEMP ),
$ LDQ, VT2( KTEMP, 1 ), LDVT2, ONE, VT( 1, 1 ),
$ LDVT )
*
KTEMP = CTOT( 1 ) + 1
NRP1 = NR + SQRE
IF( KTEMP.GT.1 ) THEN
DO 130 I = 1, K
Q( I, KTEMP ) = Q( I, 1 )
130 CONTINUE
DO 140 I = NLP2, M
VT2( KTEMP, I ) = VT2( 1, I )
140 CONTINUE
END IF
CTEMP = 1 + CTOT( 2 ) + CTOT( 3 )
OPS = OPS + SOPBL3( 'SGEMM ', K, NRP1, CTEMP )
CALL SGEMM( 'N', 'N', K, NRP1, CTEMP, ONE, Q( 1, KTEMP ), LDQ,
$ VT2( KTEMP, NLP2 ), LDVT2, ZERO, VT( 1, NLP2 ), LDVT )
*
RETURN
*
* End of SLASD3
*
END
SUBROUTINE SLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
* Courant Institute, NAG Ltd., and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
INTEGER I, INFO, N
REAL RHO, SIGMA
* ..
* .. Array Arguments ..
REAL D( * ), DELTA( * ), WORK( * ), Z( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* This subroutine computes the square root of the I-th updated
* eigenvalue of a positive symmetric rank-one modification to
* a positive diagonal matrix whose entries are given as the squares
* of the corresponding entries in the array d, and that
*
* 0 <= D(i) < D(j) for i < j
*
* and that RHO > 0. This is arranged by the calling routine, and is
* no loss in generality. The rank-one modified system is thus
*
* diag( D ) * diag( D ) + RHO * Z * Z_transpose.
*
* where we assume the Euclidean norm of Z is 1.
*
* The method consists of approximating the rational functions in the
* secular equation by simpler interpolating rational functions.
*
* Arguments
* =========
*
* N (input) INTEGER
* The length of all arrays.
*
* I (input) INTEGER
* The index of the eigenvalue to be computed. 1 <= I <= N.
*
* D (input) REAL array, dimension ( N )
* The original eigenvalues. It is assumed that they are in
* order, 0 <= D(I) < D(J) for I < J.
*
* Z (input) REAL array, dimension ( N )
* The components of the updating vector.
*
* DELTA (output) REAL array, dimension ( N )
* If N .ne. 1, DELTA contains (D(j) - sigma_I) in its j-th
* component. If N = 1, then DELTA(1) = 1. The vector DELTA
* contains the information necessary to construct the
* (singular) eigenvectors.
*
* RHO (input) REAL
* The scalar in the symmetric updating formula.
*
* SIGMA (output) REAL
* The computed lambda_I, the I-th updated eigenvalue.
*
* WORK (workspace) REAL array, dimension ( N )
* If N .ne. 1, WORK contains (D(j) + sigma_I) in its j-th
* component. If N = 1, then WORK( 1 ) = 1.
*
* INFO (output) INTEGER
* = 0: successful exit
* > 0: if INFO = 1, the updating process failed.
*
* Internal Parameters
* ===================
*
* Logical variable ORGATI (origin-at-i?) is used for distinguishing
* whether D(i) or D(i+1) is treated as the origin.
*
* ORGATI = .true. origin at i
* ORGATI = .false. origin at i+1
*
* Logical variable SWTCH3 (switch-for-3-poles?) is for noting
* if we are working with THREE poles!
*
* MAXIT is the maximum number of iterations allowed for each
* eigenvalue.
*
* Further Details
* ===============
*
* Based on contributions by
* Ren-Cang Li, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXIT
PARAMETER ( MAXIT = 20 )
REAL ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ THREE = 3.0E0, FOUR = 4.0E0, EIGHT = 8.0E0,
$ TEN = 10.0E0 )
* ..
* .. Local Scalars ..
LOGICAL ORGATI, SWTCH, SWTCH3
INTEGER II, IIM1, IIP1, IP1, ITER, J, NITER
REAL A, B, C, DELSQ, DELSQ2, DPHI, DPSI, DTIIM,
$ DTIIP, DTIPSQ, DTISQ, DTNSQ, DTNSQ1, DW, EPS,
$ ERRETM, ETA, PHI, PREW, PSI, RHOINV, SG2LB,
$ SG2UB, TAU, TEMP, TEMP1, TEMP2, W
* ..
* .. Local Arrays ..
REAL DD( 3 ), ZZ( 3 )
* ..
* .. External Subroutines ..
EXTERNAL SLAED6, SLASD5
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL, ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Since this routine is called in an inner loop, we do no argument
* checking.
*
* Quick return for N=1 and 2.
*
INFO = 0
IF( N.EQ.1 ) THEN
*
* Presumably, I=1 upon entry
*
OPS = OPS + REAL( 5 )
SIGMA = SQRT( D( 1 )*D( 1 )+RHO*Z( 1 )*Z( 1 ) )
DELTA( 1 ) = ONE
WORK( 1 ) = ONE
RETURN
END IF
IF( N.EQ.2 ) THEN
CALL SLASD5( I, D, Z, DELTA, RHO, SIGMA, WORK )
RETURN
END IF
*
* Compute machine epsilon
*
EPS = SLAMCH( 'Epsilon' )
OPS = OPS + REAL( 1 )
RHOINV = ONE / RHO
*
* The case I = N
*
IF( I.EQ.N ) THEN
*
* Initialize some basic variables
*
II = N - 1
NITER = 1
*
* Calculate initial guess
*
OPS = OPS + REAL( 1 )
TEMP = RHO / TWO
*
* If ||Z||_2 is not one, then TEMP should be set to
* RHO * ||Z||_2^2 / TWO
*
OPS = OPS + REAL( 5 + 4*N )
TEMP1 = TEMP / ( D( N )+SQRT( D( N )*D( N )+TEMP ) )
DO 10 J = 1, N
WORK( J ) = D( J ) + D( N ) + TEMP1
DELTA( J ) = ( D( J )-D( N ) ) - TEMP1
10 CONTINUE
*
PSI = ZERO
OPS = OPS + REAL( 4*( N-2 ) )
DO 20 J = 1, N - 2
PSI = PSI + Z( J )*Z( J ) / ( DELTA( J )*WORK( J ) )
20 CONTINUE
*
OPS = OPS + REAL( 9 )
C = RHOINV + PSI
W = C + Z( II )*Z( II ) / ( DELTA( II )*WORK( II ) ) +
$ Z( N )*Z( N ) / ( DELTA( N )*WORK( N ) )
*
IF( W.LE.ZERO ) THEN
OPS = OPS + REAL( 14 )
TEMP1 = SQRT( D( N )*D( N )+RHO )
TEMP = Z( N-1 )*Z( N-1 ) / ( ( D( N-1 )+TEMP1 )*
$ ( D( N )-D( N-1 )+RHO / ( D( N )+TEMP1 ) ) ) +
$ Z( N )*Z( N ) / RHO
*
* The following TAU is to approximate
* SIGMA_n^2 - D( N )*D( N )
*
IF( C.LE.TEMP ) THEN
TAU = RHO
ELSE
OPS = OPS + REAL( 10 )
DELSQ = ( D( N )-D( N-1 ) )*( D( N )+D( N-1 ) )
A = -C*DELSQ + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
B = Z( N )*Z( N )*DELSQ
IF( A.LT.ZERO ) THEN
OPS = OPS + REAL( 8 )
TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
ELSE
OPS = OPS + REAL( 8 )
TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
END IF
END IF
*
* It can be proved that
* D(N)^2+RHO/2 <= SIGMA_n^2 < D(N)^2+TAU <= D(N)^2+RHO
*
ELSE
OPS = OPS + REAL( 10 )
DELSQ = ( D( N )-D( N-1 ) )*( D( N )+D( N-1 ) )
A = -C*DELSQ + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
B = Z( N )*Z( N )*DELSQ
*
* The following TAU is to approximate
* SIGMA_n^2 - D( N )*D( N )
*
IF( A.LT.ZERO ) THEN
OPS = OPS + REAL( 8 )
TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
ELSE
OPS = OPS + REAL( 8 )
TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
END IF
*
* It can be proved that
* D(N)^2 < D(N)^2+TAU < SIGMA(N)^2 < D(N)^2+RHO/2
*
END IF
*
* The following ETA is to approximate SIGMA_n - D( N )
*
OPS = OPS + REAL( 5 )
ETA = TAU / ( D( N )+SQRT( D( N )*D( N )+TAU ) )
*
OPS = OPS + REAL( 1 + 4*N )
SIGMA = D( N ) + ETA
DO 30 J = 1, N
DELTA( J ) = ( D( J )-D( I ) ) - ETA
WORK( J ) = D( J ) + D( I ) + ETA
30 CONTINUE
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
OPS = OPS + REAL( II*7 )
DO 40 J = 1, II
TEMP = Z( J ) / ( DELTA( J )*WORK( J ) )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
40 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
OPS = OPS + REAL( 14 )
TEMP = Z( N ) / ( DELTA( N )*WORK( N ) )
PHI = Z( N )*TEMP
DPHI = TEMP*TEMP
ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
$ ABS( TAU )*( DPSI+DPHI )
*
W = RHOINV + PHI + PSI
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
GO TO 240
END IF
*
* Calculate the new step
*
NITER = NITER + 1
OPS = OPS + REAL( 14 )
DTNSQ1 = WORK( N-1 )*DELTA( N-1 )
DTNSQ = WORK( N )*DELTA( N )
C = W - DTNSQ1*DPSI - DTNSQ*DPHI
A = ( DTNSQ+DTNSQ1 )*W - DTNSQ*DTNSQ1*( DPSI+DPHI )
B = DTNSQ*DTNSQ1*W
IF( C.LT.ZERO )
$ C = ABS( C )
IF( C.EQ.ZERO ) THEN
OPS = OPS + REAL( 2 )
ETA = RHO - SIGMA*SIGMA
ELSE IF( A.GE.ZERO ) THEN
OPS = OPS + REAL( 8 )
ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
OPS = OPS + REAL( 8 )
ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
OPS = OPS + REAL( 1 )
IF( W*ETA.GT.ZERO ) THEN
OPS = OPS + REAL( 2 )
ETA = -W / ( DPSI+DPHI )
END IF
TEMP = ETA - DTNSQ
IF( TEMP.GT.RHO ) THEN
OPS = OPS + REAL( 1 )
ETA = RHO + DTNSQ
END IF
*
OPS = OPS + REAL( 6 + 2*N + 1 )
TAU = TAU + ETA
ETA = ETA / ( SIGMA+SQRT( ETA+SIGMA*SIGMA ) )
DO 50 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
WORK( J ) = WORK( J ) + ETA
50 CONTINUE
*
SIGMA = SIGMA + ETA
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
OPS = OPS + REAL( 7*II )
DO 60 J = 1, II
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
60 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
OPS = OPS + REAL( 14 )
TEMP = Z( N ) / ( WORK( N )*DELTA( N ) )
PHI = Z( N )*TEMP
DPHI = TEMP*TEMP
ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
$ ABS( TAU )*( DPSI+DPHI )
*
W = RHOINV + PHI + PSI
*
* Main loop to update the values of the array DELTA
*
ITER = NITER + 1
*
DO 90 NITER = ITER, MAXIT
*
* Test for convergence
*
OPS = OPS + REAL( 1 )
IF( ABS( W ).LE.EPS*ERRETM ) THEN
GO TO 240
END IF
*
* Calculate the new step
*
OPS = OPS + REAL( 22 )
DTNSQ1 = WORK( N-1 )*DELTA( N-1 )
DTNSQ = WORK( N )*DELTA( N )
C = W - DTNSQ1*DPSI - DTNSQ*DPHI
A = ( DTNSQ+DTNSQ1 )*W - DTNSQ1*DTNSQ*( DPSI+DPHI )
B = DTNSQ1*DTNSQ*W
IF( A.GE.ZERO ) THEN
ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
OPS = OPS + REAL( 2 )
IF( W*ETA.GT.ZERO ) THEN
OPS = OPS + REAL( 2 )
ETA = -W / ( DPSI+DPHI )
END IF
TEMP = ETA - DTNSQ
IF( TEMP.LE.ZERO ) THEN
OPS = OPS + REAL( 1 )
ETA = ETA / TWO
END IF
*
OPS = OPS + REAL( 6 + 2*N + 1 )
TAU = TAU + ETA
ETA = ETA / ( SIGMA+SQRT( ETA+SIGMA*SIGMA ) )
DO 70 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
WORK( J ) = WORK( J ) + ETA
70 CONTINUE
*
SIGMA = SIGMA + ETA
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
OPS = OPS + REAL( 7*II )
DO 80 J = 1, II
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
80 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
OPS = OPS + REAL( 14 )
TEMP = Z( N ) / ( WORK( N )*DELTA( N ) )
PHI = Z( N )*TEMP
DPHI = TEMP*TEMP
ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
$ ABS( TAU )*( DPSI+DPHI )
*
W = RHOINV + PHI + PSI
90 CONTINUE
*
* Return with INFO = 1, NITER = MAXIT and not converged
*
INFO = 1
GO TO 240
*
* End for the case I = N
*
ELSE
*
* The case for I < N
*
NITER = 1
IP1 = I + 1
*
* Calculate initial guess
*
OPS = OPS + REAL( 9 + 4*N )
DELSQ = ( D( IP1 )-D( I ) )*( D( IP1 )+D( I ) )
DELSQ2 = DELSQ / TWO
TEMP = DELSQ2 / ( D( I )+SQRT( D( I )*D( I )+DELSQ2 ) )
DO 100 J = 1, N
WORK( J ) = D( J ) + D( I ) + TEMP
DELTA( J ) = ( D( J )-D( I ) ) - TEMP
100 CONTINUE
*
PSI = ZERO
OPS = OPS + REAL( 4*( I-1 ) )
DO 110 J = 1, I - 1
PSI = PSI + Z( J )*Z( J ) / ( WORK( J )*DELTA( J ) )
110 CONTINUE
*
PHI = ZERO
OPS = OPS + REAL( 4*( N-I-1 ) + 10 )
DO 120 J = N, I + 2, -1
PHI = PHI + Z( J )*Z( J ) / ( WORK( J )*DELTA( J ) )
120 CONTINUE
C = RHOINV + PSI + PHI
W = C + Z( I )*Z( I ) / ( WORK( I )*DELTA( I ) ) +
$ Z( IP1 )*Z( IP1 ) / ( WORK( IP1 )*DELTA( IP1 ) )
*
IF( W.GT.ZERO ) THEN
*
* d(i)^2 < the ith sigma^2 < (d(i)^2+d(i+1)^2)/2
*
* We choose d(i) as origin.
*
OPS = OPS + REAL( 20 )
ORGATI = .TRUE.
SG2LB = ZERO
SG2UB = DELSQ2
A = C*DELSQ + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 )
B = Z( I )*Z( I )*DELSQ
IF( A.GT.ZERO ) THEN
TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
ELSE
TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
END IF
*
* TAU now is an estimation of SIGMA^2 - D( I )^2. The
* following, however, is the corresponding estimation of
* SIGMA - D( I ).
*
ETA = TAU / ( D( I )+SQRT( D( I )*D( I )+TAU ) )
ELSE
*
* (d(i)^2+d(i+1)^2)/2 <= the ith sigma^2 < d(i+1)^2/2
*
* We choose d(i+1) as origin.
*
OPS = OPS + REAL( 20 )
ORGATI = .FALSE.
SG2LB = -DELSQ2
SG2UB = ZERO
A = C*DELSQ - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 )
B = Z( IP1 )*Z( IP1 )*DELSQ
IF( A.LT.ZERO ) THEN
TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) )
ELSE
TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C )
END IF
*
* TAU now is an estimation of SIGMA^2 - D( IP1 )^2. The
* following, however, is the corresponding estimation of
* SIGMA - D( IP1 ).
*
ETA = TAU / ( D( IP1 )+SQRT( ABS( D( IP1 )*D( IP1 )+
$ TAU ) ) )
END IF
*
OPS = OPS + REAL( 1 + 4*N )
IF( ORGATI ) THEN
II = I
SIGMA = D( I ) + ETA
DO 130 J = 1, N
WORK( J ) = D( J ) + D( I ) + ETA
DELTA( J ) = ( D( J )-D( I ) ) - ETA
130 CONTINUE
ELSE
II = I + 1
SIGMA = D( IP1 ) + ETA
DO 140 J = 1, N
WORK( J ) = D( J ) + D( IP1 ) + ETA
DELTA( J ) = ( D( J )-D( IP1 ) ) - ETA
140 CONTINUE
END IF
IIM1 = II - 1
IIP1 = II + 1
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
OPS = OPS + REAL( 7*IIM1 )
DO 150 J = 1, IIM1
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
150 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
DPHI = ZERO
PHI = ZERO
OPS = OPS + REAL( 7*( N-IIP1+1 ) + 2 )
DO 160 J = N, IIP1, -1
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PHI = PHI + Z( J )*TEMP
DPHI = DPHI + TEMP*TEMP
ERRETM = ERRETM + PHI
160 CONTINUE
*
W = RHOINV + PHI + PSI
*
* W is the value of the secular function with
* its ii-th element removed.
*
SWTCH3 = .FALSE.
IF( ORGATI ) THEN
IF( W.LT.ZERO )
$ SWTCH3 = .TRUE.
ELSE
IF( W.GT.ZERO )
$ SWTCH3 = .TRUE.
END IF
IF( II.EQ.1 .OR. II.EQ.N )
$ SWTCH3 = .FALSE.
*
OPS = OPS + REAL( 17 )
TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
DW = DPSI + DPHI + TEMP*TEMP
TEMP = Z( II )*TEMP
W = W + TEMP
ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
$ THREE*ABS( TEMP ) + ABS( TAU )*DW
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
GO TO 240
END IF
*
IF( W.LE.ZERO ) THEN
SG2LB = MAX( SG2LB, TAU )
ELSE
SG2UB = MIN( SG2UB, TAU )
END IF
*
* Calculate the new step
*
NITER = NITER + 1
IF( .NOT.SWTCH3 ) THEN
OPS = OPS + REAL( 15 )
DTIPSQ = WORK( IP1 )*DELTA( IP1 )
DTISQ = WORK( I )*DELTA( I )
IF( ORGATI ) THEN
C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2
ELSE
C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2
END IF
A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW
B = DTIPSQ*DTISQ*W
IF( C.EQ.ZERO ) THEN
IF( A.EQ.ZERO ) THEN
OPS = OPS + REAL( 5 )
IF( ORGATI ) THEN
A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ*( DPSI+DPHI )
ELSE
A = Z( IP1 )*Z( IP1 ) + DTISQ*DTISQ*( DPSI+DPHI )
END IF
END IF
OPS = OPS + REAL( 1 )
ETA = B / A
ELSE IF( A.LE.ZERO ) THEN
OPS = OPS + REAL( 8 )
ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
OPS = OPS + REAL( 8 )
ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
ELSE
*
* Interpolation using THREE most relevant poles
*
OPS = OPS + REAL( 15 )
DTIIM = WORK( IIM1 )*DELTA( IIM1 )
DTIIP = WORK( IIP1 )*DELTA( IIP1 )
TEMP = RHOINV + PSI + PHI
IF( ORGATI ) THEN
TEMP1 = Z( IIM1 ) / DTIIM
TEMP1 = TEMP1*TEMP1
C = ( TEMP - DTIIP*( DPSI+DPHI ) ) -
$ ( D( IIM1 )-D( IIP1 ) )*( D( IIM1 )+D( IIP1 ) )*TEMP1
ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
IF( DPSI.LT.TEMP1 ) THEN
OPS = OPS + REAL( 2 )
ZZ( 3 ) = DTIIP*DTIIP*DPHI
ELSE
OPS = OPS + REAL( 4 )
ZZ( 3 ) = DTIIP*DTIIP*( ( DPSI-TEMP1 )+DPHI )
END IF
ELSE
TEMP1 = Z( IIP1 ) / DTIIP
TEMP1 = TEMP1*TEMP1
C = ( TEMP - DTIIM*( DPSI+DPHI ) ) -
$ ( D( IIP1 )-D( IIM1 ) )*( D( IIM1 )+D( IIP1 ) )*TEMP1
IF( DPHI.LT.TEMP1 ) THEN
OPS = OPS + REAL( 2 )
ZZ( 1 ) = DTIIM*DTIIM*DPSI
ELSE
OPS = OPS + REAL( 4 )
ZZ( 1 ) = DTIIM*DTIIM*( DPSI+( DPHI-TEMP1 ) )
END IF
ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
END IF
OPS = OPS + REAL( 2 )
ZZ( 2 ) = Z( II )*Z( II )
DD( 1 ) = DTIIM
DD( 2 ) = DELTA( II )*WORK( II )
DD( 3 ) = DTIIP
CALL SLAED6( NITER, ORGATI, C, DD, ZZ, W, ETA, INFO )
IF( INFO.NE.0 )
$ GO TO 240
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
OPS = OPS + REAL( 1 )
IF( W*ETA.GE.ZERO ) THEN
OPS = OPS + REAL( 1 )
ETA = -W / DW
END IF
OPS = OPS + REAL( 8 )
IF( ORGATI ) THEN
TEMP1 = WORK( I )*DELTA( I )
TEMP = ETA - TEMP1
ELSE
TEMP1 = WORK( IP1 )*DELTA( IP1 )
TEMP = ETA - TEMP1
END IF
IF( TEMP.GT.SG2UB .OR. TEMP.LT.SG2LB ) THEN
OPS = OPS + REAL( 2 )
IF( W.LT.ZERO ) THEN
ETA = ( SG2UB-TAU ) / TWO
ELSE
ETA = ( SG2LB-TAU ) / TWO
END IF
END IF
*
TAU = TAU + ETA
ETA = ETA / ( SIGMA+SQRT( SIGMA*SIGMA+ETA ) )
*
PREW = W
*
OPS = OPS + REAL( 1 + 2*N )
SIGMA = SIGMA + ETA
DO 170 J = 1, N
WORK( J ) = WORK( J ) + ETA
DELTA( J ) = DELTA( J ) - ETA
170 CONTINUE
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
OPS = OPS + REAL( 7*IIM1 )
DO 180 J = 1, IIM1
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
180 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
DPHI = ZERO
PHI = ZERO
OPS = OPS + REAL( 7*(N-IIM1+1) )
DO 190 J = N, IIP1, -1
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PHI = PHI + Z( J )*TEMP
DPHI = DPHI + TEMP*TEMP
ERRETM = ERRETM + PHI
190 CONTINUE
*
OPS = OPS + REAL( 19 )
TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
DW = DPSI + DPHI + TEMP*TEMP
TEMP = Z( II )*TEMP
W = RHOINV + PHI + PSI + TEMP
ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
$ THREE*ABS( TEMP ) + ABS( TAU )*DW
*
IF( W.LE.ZERO ) THEN
SG2LB = MAX( SG2LB, TAU )
ELSE
SG2UB = MIN( SG2UB, TAU )
END IF
*
SWTCH = .FALSE.
IF( ORGATI ) THEN
IF( -W.GT.ABS( PREW ) / TEN )
$ SWTCH = .TRUE.
ELSE
IF( W.GT.ABS( PREW ) / TEN )
$ SWTCH = .TRUE.
END IF
*
* Main loop to update the values of the array DELTA and WORK
*
ITER = NITER + 1
*
DO 230 NITER = ITER, MAXIT
*
* Test for convergence
*
OPS = OPS + REAL( 1 )
IF( ABS( W ).LE.EPS*ERRETM ) THEN
GO TO 240
END IF
*
* Calculate the new step
*
IF( .NOT.SWTCH3 ) THEN
OPS = OPS + REAL( 2 )
DTIPSQ = WORK( IP1 )*DELTA( IP1 )
DTISQ = WORK( I )*DELTA( I )
IF( .NOT.SWTCH ) THEN
OPS = OPS + REAL( 6 )
IF( ORGATI ) THEN
C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2
ELSE
C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2
END IF
ELSE
OPS = OPS + REAL( 8 )
TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
IF( ORGATI ) THEN
DPSI = DPSI + TEMP*TEMP
ELSE
DPHI = DPHI + TEMP*TEMP
END IF
C = W - DTISQ*DPSI - DTIPSQ*DPHI
END IF
OPS = OPS + REAL( 7 )
A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW
B = DTIPSQ*DTISQ*W
IF( C.EQ.ZERO ) THEN
IF( A.EQ.ZERO ) THEN
OPS = OPS + REAL( 5 )
IF( .NOT.SWTCH ) THEN
IF( ORGATI ) THEN
A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ*
$ ( DPSI+DPHI )
ELSE
A = Z( IP1 )*Z( IP1 ) +
$ DTISQ*DTISQ*( DPSI+DPHI )
END IF
ELSE
A = DTISQ*DTISQ*DPSI + DTIPSQ*DTIPSQ*DPHI
END IF
END IF
OPS = OPS + REAL( 1 )
ETA = B / A
ELSE IF( A.LE.ZERO ) THEN
OPS = OPS + REAL( 8 )
ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
OPS = OPS + REAL( 8 )
ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
ELSE
*
* Interpolation using THREE most relevant poles
*
OPS = OPS + REAL( 4 )
DTIIM = WORK( IIM1 )*DELTA( IIM1 )
DTIIP = WORK( IIP1 )*DELTA( IIP1 )
TEMP = RHOINV + PSI + PHI
IF( SWTCH ) THEN
OPS = OPS + REAL( 8 )
C = TEMP - DTIIM*DPSI - DTIIP*DPHI
ZZ( 1 ) = DTIIM*DTIIM*DPSI
ZZ( 3 ) = DTIIP*DTIIP*DPHI
ELSE
IF( ORGATI ) THEN
OPS = OPS + REAL( 11 )
TEMP1 = Z( IIM1 ) / DTIIM
TEMP1 = TEMP1*TEMP1
TEMP2 = ( D( IIM1 )-D( IIP1 ) )*
$ ( D( IIM1 )+D( IIP1 ) )*TEMP1
C = TEMP - DTIIP*( DPSI+DPHI ) - TEMP2
ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
IF( DPSI.LT.TEMP1 ) THEN
OPS = OPS + REAL( 2 )
ZZ( 3 ) = DTIIP*DTIIP*DPHI
ELSE
OPS = OPS + REAL( 4 )
ZZ( 3 ) = DTIIP*DTIIP*( ( DPSI-TEMP1 )+DPHI )
END IF
ELSE
OPS = OPS + REAL( 10 )
TEMP1 = Z( IIP1 ) / DTIIP
TEMP1 = TEMP1*TEMP1
TEMP2 = ( D( IIP1 )-D( IIM1 ) )*
$ ( D( IIM1 )+D( IIP1 ) )*TEMP1
C = TEMP - DTIIM*( DPSI+DPHI ) - TEMP2
IF( DPHI.LT.TEMP1 ) THEN
OPS = OPS + REAL( 2 )
ZZ( 1 ) = DTIIM*DTIIM*DPSI
ELSE
OPS = OPS + REAL( 4 )
ZZ( 1 ) = DTIIM*DTIIM*( DPSI+( DPHI-TEMP1 ) )
END IF
OPS = OPS + REAL( 1 )
ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
END IF
END IF
OPS = OPS + REAL( 1 )
DD( 1 ) = DTIIM
DD( 2 ) = DELTA( II )*WORK( II )
DD( 3 ) = DTIIP
CALL SLAED6( NITER, ORGATI, C, DD, ZZ, W, ETA, INFO )
IF( INFO.NE.0 )
$ GO TO 240
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
OPS = OPS + REAL( 1 )
IF( W*ETA.GE.ZERO ) THEN
OPS = OPS + REAL( 1 )
ETA = -W / DW
END IF
OPS = OPS + REAL( 2 )
IF( ORGATI ) THEN
TEMP1 = WORK( I )*DELTA( I )
TEMP = ETA - TEMP1
ELSE
TEMP1 = WORK( IP1 )*DELTA( IP1 )
TEMP = ETA - TEMP1
END IF
IF( TEMP.GT.SG2UB .OR. TEMP.LT.SG2LB ) THEN
OPS = OPS + REAL( 2 )
IF( W.LT.ZERO ) THEN
ETA = ( SG2UB-TAU ) / TWO
ELSE
ETA = ( SG2LB-TAU ) / TWO
END IF
END IF
*
OPS = OPS + REAL( 6 )
TAU = TAU + ETA
ETA = ETA / ( SIGMA+SQRT( SIGMA*SIGMA+ETA ) )
*
OPS = OPS + REAL( 1 + 2*N )
SIGMA = SIGMA + ETA
DO 200 J = 1, N
WORK( J ) = WORK( J ) + ETA
DELTA( J ) = DELTA( J ) - ETA
200 CONTINUE
*
PREW = W
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
OPS = OPS + REAL( 7*IIM1 )
DO 210 J = 1, IIM1
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
210 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
DPHI = ZERO
PHI = ZERO
OPS = OPS + REAL( 7*( IIM1-N+1 ) )
DO 220 J = N, IIP1, -1
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PHI = PHI + Z( J )*TEMP
DPHI = DPHI + TEMP*TEMP
ERRETM = ERRETM + PHI
220 CONTINUE
*
OPS = OPS + REAL( 19 )
TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
DW = DPSI + DPHI + TEMP*TEMP
TEMP = Z( II )*TEMP
W = RHOINV + PHI + PSI + TEMP
ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
$ THREE*ABS( TEMP ) + ABS( TAU )*DW
IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN )
$ SWTCH = .NOT.SWTCH
*
IF( W.LE.ZERO ) THEN
SG2LB = MAX( SG2LB, TAU )
ELSE
SG2UB = MIN( SG2UB, TAU )
END IF
*
230 CONTINUE
*
* Return with INFO = 1, NITER = MAXIT and not converged
*
INFO = 1
*
END IF
*
240 CONTINUE
RETURN
*
* End of SLASD4
*
END
SUBROUTINE SLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
* Courant Institute, NAG Ltd., and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER I
REAL DSIGMA, RHO
* ..
* .. Array Arguments ..
REAL D( 2 ), DELTA( 2 ), WORK( 2 ), Z( 2 )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* This subroutine computes the square root of the I-th eigenvalue
* of a positive symmetric rank-one modification of a 2-by-2 diagonal
* matrix
*
* diag( D ) * diag( D ) + RHO * Z * transpose(Z) .
*
* The diagonal entries in the array D are assumed to satisfy
*
* 0 <= D(i) < D(j) for i < j .
*
* We also assume RHO > 0 and that the Euclidean norm of the vector
* Z is one.
*
* Arguments
* =========
*
* I (input) INTEGER
* The index of the eigenvalue to be computed. I = 1 or I = 2.
*
* D (input) REAL array, dimension ( 2 )
* The original eigenvalues. We assume 0 <= D(1) < D(2).
*
* Z (input) REAL array, dimension ( 2 )
* The components of the updating vector.
*
* DELTA (output) REAL array, dimension ( 2 )
* Contains (D(j) - lambda_I) in its j-th component.
* The vector DELTA contains the information necessary
* to construct the eigenvectors.
*
* RHO (input) REAL
* The scalar in the symmetric updating formula.
*
* DSIGMA (output) REAL
* The computed lambda_I, the I-th updated eigenvalue.
*
* WORK (workspace) REAL array, dimension ( 2 )
* WORK contains (D(j) + sigma_I) in its j-th component.
*
* Further Details
* ===============
*
* Based on contributions by
* Ren-Cang Li, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO, THREE, FOUR
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ THREE = 3.0E0, FOUR = 4.0E0 )
* ..
* .. Local Scalars ..
REAL B, C, DEL, DELSQ, TAU, W
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL, ABS, SQRT
* ..
* .. Executable Statements ..
*
OPS = OPS + REAL( 3 )
DEL = D( 2 ) - D( 1 )
DELSQ = DEL*( D( 2 )+D( 1 ) )
IF( I.EQ.1 ) THEN
OPS = OPS + REAL( 13 )
W = ONE + FOUR*RHO*( Z( 2 )*Z( 2 ) / ( D( 1 )+THREE*D( 2 ) )-
$ Z( 1 )*Z( 1 ) / ( THREE*D( 1 )+D( 2 ) ) ) / DEL
IF( W.GT.ZERO ) THEN
OPS = OPS + REAL( 8 )
B = DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
C = RHO*Z( 1 )*Z( 1 )*DELSQ
*
* B > ZERO, always
*
* The following TAU is DSIGMA * DSIGMA - D( 1 ) * D( 1 )
*
OPS = OPS + REAL( 7 )
TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) )
*
* The following TAU is DSIGMA - D( 1 )
*
OPS = OPS + REAL( 14 )
TAU = TAU / ( D( 1 )+SQRT( D( 1 )*D( 1 )+TAU ) )
DSIGMA = D( 1 ) + TAU
DELTA( 1 ) = -TAU
DELTA( 2 ) = DEL - TAU
WORK( 1 ) = TWO*D( 1 ) + TAU
WORK( 2 ) = ( D( 1 )+TAU ) + D( 2 )
* DELTA( 1 ) = -Z( 1 ) / TAU
* DELTA( 2 ) = Z( 2 ) / ( DEL-TAU )
ELSE
OPS = OPS + REAL( 8 )
B = -DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
C = RHO*Z( 2 )*Z( 2 )*DELSQ
*
* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 )
*
IF( B.GT.ZERO ) THEN
OPS = OPS + REAL( 7 )
TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) )
ELSE
OPS = OPS + REAL( 6 )
TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO
END IF
*
* The following TAU is DSIGMA - D( 2 )
*
OPS = OPS + REAL( 14 )
TAU = TAU / ( D( 2 )+SQRT( ABS( D( 2 )*D( 2 )+TAU ) ) )
DSIGMA = D( 2 ) + TAU
DELTA( 1 ) = -( DEL+TAU )
DELTA( 2 ) = -TAU
WORK( 1 ) = D( 1 ) + TAU + D( 2 )
WORK( 2 ) = TWO*D( 2 ) + TAU
* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
* DELTA( 2 ) = -Z( 2 ) / TAU
END IF
OPS = OPS + REAL( 6 )
* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
* DELTA( 1 ) = DELTA( 1 ) / TEMP
* DELTA( 2 ) = DELTA( 2 ) / TEMP
ELSE
*
* Now I=2
*
OPS = OPS + REAL( 8 )
B = -DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
C = RHO*Z( 2 )*Z( 2 )*DELSQ
*
* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 )
*
IF( B.GT.ZERO ) THEN
OPS = OPS + REAL( 6 )
TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO
ELSE
OPS = OPS + REAL( 7 )
TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) )
END IF
*
* The following TAU is DSIGMA - D( 2 )
*
OPS = OPS + REAL( 20 )
TAU = TAU / ( D( 2 )+SQRT( D( 2 )*D( 2 )+TAU ) )
DSIGMA = D( 2 ) + TAU
DELTA( 1 ) = -( DEL+TAU )
DELTA( 2 ) = -TAU
WORK( 1 ) = D( 1 ) + TAU + D( 2 )
WORK( 2 ) = TWO*D( 2 ) + TAU
* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
* DELTA( 2 ) = -Z( 2 ) / TAU
* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
* DELTA( 1 ) = DELTA( 1 ) / TEMP
* DELTA( 2 ) = DELTA( 2 ) / TEMP
END IF
RETURN
*
* End of SLASD5
*
END
SUBROUTINE SLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA,
$ IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM,
$ LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK,
$ IWORK, INFO )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL,
$ NR, SQRE
REAL ALPHA, BETA, C, S
* ..
* .. Array Arguments ..
INTEGER GIVCOL( LDGCOL, * ), IDXQ( * ), IWORK( * ),
$ PERM( * )
REAL D( * ), DIFL( * ), DIFR( * ),
$ GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ),
$ VF( * ), VL( * ), WORK( * ), Z( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLASD6 computes the SVD of an updated upper bidiagonal matrix B
* obtained by merging two smaller ones by appending a row. This
* routine is used only for the problem which requires all singular
* values and optionally singular vector matrices in factored form.
* B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE.
* A related subroutine, SLASD1, handles the case in which all singular
* values and singular vectors of the bidiagonal matrix are desired.
*
* SLASD6 computes the SVD as follows:
*
* ( D1(in) 0 0 0 )
* B = U(in) * ( Z1' a Z2' b ) * VT(in)
* ( 0 0 D2(in) 0 )
*
* = U(out) * ( D(out) 0) * VT(out)
*
* where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M
* with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros
* elsewhere; and the entry b is empty if SQRE = 0.
*
* The singular values of B can be computed using D1, D2, the first
* components of all the right singular vectors of the lower block, and
* the last components of all the right singular vectors of the upper
* block. These components are stored and updated in VF and VL,
* respectively, in SLASD6. Hence U and VT are not explicitly
* referenced.
*
* The singular values are stored in D. The algorithm consists of two
* stages:
*
* The first stage consists of deflating the size of the problem
* when there are multiple singular values or if there is a zero
* in the Z vector. For each such occurence the dimension of the
* secular equation problem is reduced by one. This stage is
* performed by the routine SLASD7.
*
* The second stage consists of calculating the updated
* singular values. This is done by finding the roots of the
* secular equation via the routine SLASD4 (as called by SLASD8).
* This routine also updates VF and VL and computes the distances
* between the updated singular values and the old singular
* values.
*
* SLASD6 is called from SLASDA.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* Specifies whether singular vectors are to be computed in
* factored form:
* = 0: Compute singular values only.
* = 1: Compute singular vectors in factored form as well.
*
* NL (input) INTEGER
* The row dimension of the upper block. NL >= 1.
*
* NR (input) INTEGER
* The row dimension of the lower block. NR >= 1.
*
* SQRE (input) INTEGER
* = 0: the lower block is an NR-by-NR square matrix.
* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
*
* The bidiagonal matrix has row dimension N = NL + NR + 1,
* and column dimension M = N + SQRE.
*
* D (input/output) REAL array, dimension ( NL+NR+1 ).
* On entry D(1:NL,1:NL) contains the singular values of the
* upper block, and D(NL+2:N) contains the singular values
* of the lower block. On exit D(1:N) contains the singular
* values of the modified matrix.
*
* VF (input/output) REAL array, dimension ( M )
* On entry, VF(1:NL+1) contains the first components of all
* right singular vectors of the upper block; and VF(NL+2:M)
* contains the first components of all right singular vectors
* of the lower block. On exit, VF contains the first components
* of all right singular vectors of the bidiagonal matrix.
*
* VL (input/output) REAL array, dimension ( M )
* On entry, VL(1:NL+1) contains the last components of all
* right singular vectors of the upper block; and VL(NL+2:M)
* contains the last components of all right singular vectors of
* the lower block. On exit, VL contains the last components of
* all right singular vectors of the bidiagonal matrix.
*
* ALPHA (input) REAL
* Contains the diagonal element associated with the added row.
*
* BETA (input) REAL
* Contains the off-diagonal element associated with the added
* row.
*
* IDXQ (output) INTEGER array, dimension ( N )
* This contains the permutation which will reintegrate the
* subproblem just solved back into sorted order, i.e.
* D( IDXQ( I = 1, N ) ) will be in ascending order.
*
* PERM (output) INTEGER array, dimension ( N )
* The permutations (from deflation and sorting) to be applied
* to each block. Not referenced if ICOMPQ = 0.
*
* GIVPTR (output) INTEGER
* The number of Givens rotations which took place in this
* subproblem. Not referenced if ICOMPQ = 0.
*
* GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )
* Each pair of numbers indicates a pair of columns to take place
* in a Givens rotation. Not referenced if ICOMPQ = 0.
*
* LDGCOL (input) INTEGER
* leading dimension of GIVCOL, must be at least N.
*
* GIVNUM (output) REAL array, dimension ( LDGNUM, 2 )
* Each number indicates the C or S value to be used in the
* corresponding Givens rotation. Not referenced if ICOMPQ = 0.
*
* LDGNUM (input) INTEGER
* The leading dimension of GIVNUM and POLES, must be at least N.
*
* POLES (output) REAL array, dimension ( LDGNUM, 2 )
* On exit, POLES(1,*) is an array containing the new singular
* values obtained from solving the secular equation, and
* POLES(2,*) is an array containing the poles in the secular
* equation. Not referenced if ICOMPQ = 0.
*
* DIFL (output) REAL array, dimension ( N )
* On exit, DIFL(I) is the distance between I-th updated
* (undeflated) singular value and the I-th (undeflated) old
* singular value.
*
* DIFR (output) REAL array,
* dimension ( LDGNUM, 2 ) if ICOMPQ = 1 and
* dimension ( N ) if ICOMPQ = 0.
* On exit, DIFR(I, 1) is the distance between I-th updated
* (undeflated) singular value and the I+1-th (undeflated) old
* singular value.
*
* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the
* normalizing factors for the right singular vector matrix.
*
* See SLASD8 for details on DIFL and DIFR.
*
* Z (output) REAL array, dimension ( M )
* The first elements of this array contain the components
* of the deflation-adjusted updating row vector.
*
* K (output) INTEGER
* Contains the dimension of the non-deflated matrix,
* This is the order of the related secular equation. 1 <= K <=N.
*
* C (output) REAL
* C contains garbage if SQRE =0 and the C-value of a Givens
* rotation related to the right null space if SQRE = 1.
*
* S (output) REAL
* S contains garbage if SQRE =0 and the S-value of a Givens
* rotation related to the right null space if SQRE = 1.
*
* WORK (workspace) REAL array, dimension ( 4 * M )
*
* IWORK (workspace) INTEGER array, dimension ( 3 * N )
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an singular value did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
INTEGER I, IDX, IDXC, IDXP, ISIGMA, IVFW, IVLW, IW, M,
$ N, N1, N2
REAL ORGNRM
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLAMRG, SLASCL, SLASD7, SLASD8, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL, ABS, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
N = NL + NR + 1
M = N + SQRE
*
IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
INFO = -1
ELSE IF( NL.LT.1 ) THEN
INFO = -2
ELSE IF( NR.LT.1 ) THEN
INFO = -3
ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
INFO = -4
ELSE IF( LDGCOL.LT.N ) THEN
INFO = -14
ELSE IF( LDGNUM.LT.N ) THEN
INFO = -16
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLASD6', -INFO )
RETURN
END IF
*
* The following values are for bookkeeping purposes only. They are
* integer pointers which indicate the portion of the workspace
* used by a particular array in SLASD7 and SLASD8.
*
ISIGMA = 1
IW = ISIGMA + N
IVFW = IW + M
IVLW = IVFW + M
*
IDX = 1
IDXC = IDX + N
IDXP = IDXC + N
*
* Scale.
*
ORGNRM = MAX( ABS( ALPHA ), ABS( BETA ) )
D( NL+1 ) = ZERO
DO 10 I = 1, N
IF( ABS( D( I ) ).GT.ORGNRM ) THEN
ORGNRM = ABS( D( I ) )
END IF
10 CONTINUE
OPS = OPS + REAL( N + 2 )
CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
ALPHA = ALPHA / ORGNRM
BETA = BETA / ORGNRM
*
* Sort and Deflate singular values.
*
CALL SLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, WORK( IW ), VF,
$ WORK( IVFW ), VL, WORK( IVLW ), ALPHA, BETA,
$ WORK( ISIGMA ), IWORK( IDX ), IWORK( IDXP ), IDXQ,
$ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, C, S,
$ INFO )
*
* Solve Secular Equation, compute DIFL, DIFR, and update VF, VL.
*
CALL SLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDGNUM,
$ WORK( ISIGMA ), WORK( IW ), INFO )
*
* Save the poles if ICOMPQ = 1.
*
IF( ICOMPQ.EQ.1 ) THEN
CALL SCOPY( K, D, 1, POLES( 1, 1 ), 1 )
CALL SCOPY( K, WORK( ISIGMA ), 1, POLES( 1, 2 ), 1 )
END IF
*
* Unscale.
*
OPS = OPS + REAL( N )
CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
*
* Prepare the IDXQ sorting permutation.
*
N1 = K
N2 = N - K
CALL SLAMRG( N1, N2, D, 1, -1, IDXQ )
*
RETURN
*
* End of SLASD6
*
END
SUBROUTINE SLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL,
$ VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ,
$ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM,
$ C, S, INFO )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
* Courant Institute, NAG Ltd., and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL,
$ NR, SQRE
REAL ALPHA, BETA, C, S
* ..
* .. Array Arguments ..
INTEGER GIVCOL( LDGCOL, * ), IDX( * ), IDXP( * ),
$ IDXQ( * ), PERM( * )
REAL D( * ), DSIGMA( * ), GIVNUM( LDGNUM, * ),
$ VF( * ), VFW( * ), VL( * ), VLW( * ), Z( * ),
$ ZW( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLASD7 merges the two sets of singular values together into a single
* sorted set. Then it tries to deflate the size of the problem. There
* are two ways in which deflation can occur: when two or more singular
* values are close together or if there is a tiny entry in the Z
* vector. For each such occurrence the order of the related
* secular equation problem is reduced by one.
*
* SLASD7 is called from SLASD6.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* Specifies whether singular vectors are to be computed
* in compact form, as follows:
* = 0: Compute singular values only.
* = 1: Compute singular vectors of upper
* bidiagonal matrix in compact form.
*
* NL (input) INTEGER
* The row dimension of the upper block. NL >= 1.
*
* NR (input) INTEGER
* The row dimension of the lower block. NR >= 1.
*
* SQRE (input) INTEGER
* = 0: the lower block is an NR-by-NR square matrix.
* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
*
* The bidiagonal matrix has
* N = NL + NR + 1 rows and
* M = N + SQRE >= N columns.
*
* K (output) INTEGER
* Contains the dimension of the non-deflated matrix, this is
* the order of the related secular equation. 1 <= K <=N.
*
* D (input/output) REAL array, dimension ( N )
* On entry D contains the singular values of the two submatrices
* to be combined. On exit D contains the trailing (N-K) updated
* singular values (those which were deflated) sorted into
* increasing order.
*
* Z (output) REAL array, dimension ( M )
* On exit Z contains the updating row vector in the secular
* equation.
*
* ZW (workspace) REAL array, dimension ( M )
* Workspace for Z.
*
* VF (input/output) REAL array, dimension ( M )
* On entry, VF(1:NL+1) contains the first components of all
* right singular vectors of the upper block; and VF(NL+2:M)
* contains the first components of all right singular vectors
* of the lower block. On exit, VF contains the first components
* of all right singular vectors of the bidiagonal matrix.
*
* VFW (workspace) REAL array, dimension ( M )
* Workspace for VF.
*
* VL (input/output) REAL array, dimension ( M )
* On entry, VL(1:NL+1) contains the last components of all
* right singular vectors of the upper block; and VL(NL+2:M)
* contains the last components of all right singular vectors
* of the lower block. On exit, VL contains the last components
* of all right singular vectors of the bidiagonal matrix.
*
* VLW (workspace) REAL array, dimension ( M )
* Workspace for VL.
*
* ALPHA (input) REAL
* Contains the diagonal element associated with the added row.
*
* BETA (input) REAL
* Contains the off-diagonal element associated with the added
* row.
*
* DSIGMA (output) REAL array, dimension ( N )
* Contains a copy of the diagonal elements (K-1 singular values
* and one zero) in the secular equation.
*
* IDX (workspace) INTEGER array, dimension ( N )
* This will contain the permutation used to sort the contents of
* D into ascending order.
*
* IDXP (workspace) INTEGER array, dimension ( N )
* This will contain the permutation used to place deflated
* values of D at the end of the array. On output IDXP(2:K)
* points to the nondeflated D-values and IDXP(K+1:N)
* points to the deflated singular values.
*
* IDXQ (input) INTEGER array, dimension ( N )
* This contains the permutation which separately sorts the two
* sub-problems in D into ascending order. Note that entries in
* the first half of this permutation must first be moved one
* position backward; and entries in the second half
* must first have NL+1 added to their values.
*
* PERM (output) INTEGER array, dimension ( N )
* The permutations (from deflation and sorting) to be applied
* to each singular block. Not referenced if ICOMPQ = 0.
*
* GIVPTR (output) INTEGER
* The number of Givens rotations which took place in this
* subproblem. Not referenced if ICOMPQ = 0.
*
* GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )
* Each pair of numbers indicates a pair of columns to take place
* in a Givens rotation. Not referenced if ICOMPQ = 0.
*
* LDGCOL (input) INTEGER
* The leading dimension of GIVCOL, must be at least N.
*
* GIVNUM (output) REAL array, dimension ( LDGNUM, 2 )
* Each number indicates the C or S value to be used in the
* corresponding Givens rotation. Not referenced if ICOMPQ = 0.
*
* LDGNUM (input) INTEGER
* The leading dimension of GIVNUM, must be at least N.
*
* C (output) REAL
* C contains garbage if SQRE =0 and the C-value of a Givens
* rotation related to the right null space if SQRE = 1.
*
* S (output) REAL
* S contains garbage if SQRE =0 and the S-value of a Givens
* rotation related to the right null space if SQRE = 1.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO, EIGHT
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ EIGHT = 8.0E0 )
* ..
* .. Local Scalars ..
*
INTEGER I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M, N,
$ NLP1, NLP2
REAL EPS, HLFTOL, TAU, TOL, Z1
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLAMRG, SROT, XERBLA
* ..
* .. External Functions ..
REAL SLAMCH, SLAPY2
EXTERNAL SLAMCH, SLAPY2
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL, ABS, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
N = NL + NR + 1
M = N + SQRE
*
IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
INFO = -1
ELSE IF( NL.LT.1 ) THEN
INFO = -2
ELSE IF( NR.LT.1 ) THEN
INFO = -3
ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
INFO = -4
ELSE IF( LDGCOL.LT.N ) THEN
INFO = -22
ELSE IF( LDGNUM.LT.N ) THEN
INFO = -24
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLASD7', -INFO )
RETURN
END IF
*
NLP1 = NL + 1
NLP2 = NL + 2
IF( ICOMPQ.EQ.1 ) THEN
GIVPTR = 0
END IF
*
* Generate the first part of the vector Z and move the singular
* values in the first part of D one position backward.
*
OPS = OPS + REAL( 1 + NL )
Z1 = ALPHA*VL( NLP1 )
VL( NLP1 ) = ZERO
TAU = VF( NLP1 )
DO 10 I = NL, 1, -1
Z( I+1 ) = ALPHA*VL( I )
VL( I ) = ZERO
VF( I+1 ) = VF( I )
D( I+1 ) = D( I )
IDXQ( I+1 ) = IDXQ( I ) + 1
10 CONTINUE
VF( 1 ) = TAU
*
* Generate the second part of the vector Z.
*
OPS = OPS + REAL( ( M-NLP2+1 ) )
DO 20 I = NLP2, M
Z( I ) = BETA*VF( I )
VF( I ) = ZERO
20 CONTINUE
*
* Sort the singular values into increasing order
*
DO 30 I = NLP2, N
IDXQ( I ) = IDXQ( I ) + NLP1
30 CONTINUE
*
* DSIGMA, IDXC, IDXC, and ZW are used as storage space.
*
DO 40 I = 2, N
DSIGMA( I ) = D( IDXQ( I ) )
ZW( I ) = Z( IDXQ( I ) )
VFW( I ) = VF( IDXQ( I ) )
VLW( I ) = VL( IDXQ( I ) )
40 CONTINUE
*
CALL SLAMRG( NL, NR, DSIGMA( 2 ), 1, 1, IDX( 2 ) )
*
DO 50 I = 2, N
IDXI = 1 + IDX( I )
D( I ) = DSIGMA( IDXI )
Z( I ) = ZW( IDXI )
VF( I ) = VFW( IDXI )
VL( I ) = VLW( IDXI )
50 CONTINUE
*
* Calculate the allowable deflation tolerence
*
OPS = OPS + REAL( 3 )
EPS = SLAMCH( 'Epsilon' )
TOL = MAX( ABS( ALPHA ), ABS( BETA ) )
TOL = EIGHT*EIGHT*EPS*MAX( ABS( D( N ) ), TOL )
*
* There are 2 kinds of deflation -- first a value in the z-vector
* is small, second two (or more) singular values are very close
* together (their difference is small).
*
* If the value in the z-vector is small, we simply permute the
* array so that the corresponding singular value is moved to the
* end.
*
* If two values in the D-vector are close, we perform a two-sided
* rotation designed to make one of the corresponding z-vector
* entries zero, and then permute the array so that the deflated
* singular value is moved to the end.
*
* If there are multiple singular values then the problem deflates.
* Here the number of equal singular values are found. As each equal
* singular value is found, an elementary reflector is computed to
* rotate the corresponding singular subspace so that the
* corresponding components of Z are zero in this new basis.
*
K = 1
K2 = N + 1
DO 60 J = 2, N
IF( ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
IDXP( K2 ) = J
IF( J.EQ.N )
$ GO TO 100
ELSE
JPREV = J
GO TO 70
END IF
60 CONTINUE
70 CONTINUE
J = JPREV
80 CONTINUE
J = J + 1
IF( J.GT.N )
$ GO TO 90
IF( ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
IDXP( K2 ) = J
ELSE
*
* Check if singular values are close enough to allow deflation.
*
OPS = OPS + REAL( 1 )
IF( ABS( D( J )-D( JPREV ) ).LE.TOL ) THEN
*
* Deflation is possible.
*
S = Z( JPREV )
C = Z( J )
*
* Find sqrt(a**2+b**2) without overflow or
* destructive underflow.
*
OPS = OPS + REAL( 7 )
TAU = SLAPY2( C, S )
Z( J ) = TAU
Z( JPREV ) = ZERO
C = C / TAU
S = -S / TAU
*
* Record the appropriate Givens rotation
*
IF( ICOMPQ.EQ.1 ) THEN
GIVPTR = GIVPTR + 1
IDXJP = IDXQ( IDX( JPREV )+1 )
IDXJ = IDXQ( IDX( J )+1 )
IF( IDXJP.LE.NLP1 ) THEN
IDXJP = IDXJP - 1
END IF
IF( IDXJ.LE.NLP1 ) THEN
IDXJ = IDXJ - 1
END IF
GIVCOL( GIVPTR, 2 ) = IDXJP
GIVCOL( GIVPTR, 1 ) = IDXJ
GIVNUM( GIVPTR, 2 ) = C
GIVNUM( GIVPTR, 1 ) = S
END IF
OPS = OPS + REAL( 12 )
CALL SROT( 1, VF( JPREV ), 1, VF( J ), 1, C, S )
CALL SROT( 1, VL( JPREV ), 1, VL( J ), 1, C, S )
K2 = K2 - 1
IDXP( K2 ) = JPREV
JPREV = J
ELSE
K = K + 1
ZW( K ) = Z( JPREV )
DSIGMA( K ) = D( JPREV )
IDXP( K ) = JPREV
JPREV = J
END IF
END IF
GO TO 80
90 CONTINUE
*
* Record the last singular value.
*
K = K + 1
ZW( K ) = Z( JPREV )
DSIGMA( K ) = D( JPREV )
IDXP( K ) = JPREV
*
100 CONTINUE
*
* Sort the singular values into DSIGMA. The singular values which
* were not deflated go into the first K slots of DSIGMA, except
* that DSIGMA(1) is treated separately.
*
DO 110 J = 2, N
JP = IDXP( J )
DSIGMA( J ) = D( JP )
VFW( J ) = VF( JP )
VLW( J ) = VL( JP )
110 CONTINUE
IF( ICOMPQ.EQ.1 ) THEN
DO 120 J = 2, N
JP = IDXP( J )
PERM( J ) = IDXQ( IDX( JP )+1 )
IF( PERM( J ).LE.NLP1 ) THEN
PERM( J ) = PERM( J ) - 1
END IF
120 CONTINUE
END IF
*
* The deflated singular values go back into the last N - K slots of
* D.
*
CALL SCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 )
*
* Determine DSIGMA(1), DSIGMA(2), Z(1), VF(1), VL(1), VF(M), and
* VL(M).
*
OPS = OPS + REAL( 1 )
DSIGMA( 1 ) = ZERO
HLFTOL = TOL / TWO
IF( ABS( DSIGMA( 2 ) ).LE.HLFTOL )
$ DSIGMA( 2 ) = HLFTOL
IF( M.GT.N ) THEN
OPS = OPS + REAL( 5 )
Z( 1 ) = SLAPY2( Z1, Z( M ) )
IF( Z( 1 ).LE.TOL ) THEN
C = ONE
S = ZERO
Z( 1 ) = TOL
ELSE
OPS = OPS + REAL( 2 )
C = Z1 / Z( 1 )
S = -Z( M ) / Z( 1 )
END IF
OPS = OPS + REAL( 12 )
CALL SROT( 1, VF( M ), 1, VF( 1 ), 1, C, S )
CALL SROT( 1, VL( M ), 1, VL( 1 ), 1, C, S )
ELSE
IF( ABS( Z1 ).LE.TOL ) THEN
Z( 1 ) = TOL
ELSE
Z( 1 ) = Z1
END IF
END IF
*
* Restore Z, VF, and VL.
*
CALL SCOPY( K-1, ZW( 2 ), 1, Z( 2 ), 1 )
CALL SCOPY( N-1, VFW( 2 ), 1, VF( 2 ), 1 )
CALL SCOPY( N-1, VLW( 2 ), 1, VL( 2 ), 1 )
*
RETURN
*
* End of SLASD7
*
END
SUBROUTINE SLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR,
$ DSIGMA, WORK, INFO )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
* Courant Institute, NAG Ltd., and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER ICOMPQ, INFO, K, LDDIFR
* ..
* .. Array Arguments ..
REAL D( * ), DIFL( * ), DIFR( LDDIFR, * ),
$ DSIGMA( * ), VF( * ), VL( * ), WORK( * ),
$ Z( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLASD8 finds the square roots of the roots of the secular equation,
* as defined by the values in DSIGMA and Z. It makes the appropriate
* calls to SLASD4, and stores, for each element in D, the distance
* to its two nearest poles (elements in DSIGMA). It also updates
* the arrays VF and VL, the first and last components of all the
* right singular vectors of the original bidiagonal matrix.
*
* SLASD8 is called from SLASD6.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* Specifies whether singular vectors are to be computed in
* factored form in the calling routine:
* = 0: Compute singular values only.
* = 1: Compute singular vectors in factored form as well.
*
* K (input) INTEGER
* The number of terms in the rational function to be solved
* by SLASD4. K >= 1.
*
* D (output) REAL array, dimension ( K )
* On output, D contains the updated singular values.
*
* Z (input) REAL array, dimension ( K )
* The first K elements of this array contain the components
* of the deflation-adjusted updating row vector.
*
* VF (input/output) REAL array, dimension ( K )
* On entry, VF contains information passed through DBEDE8.
* On exit, VF contains the first K components of the first
* components of all right singular vectors of the bidiagonal
* matrix.
*
* VL (input/output) REAL array, dimension ( K )
* On entry, VL contains information passed through DBEDE8.
* On exit, VL contains the first K components of the last
* components of all right singular vectors of the bidiagonal
* matrix.
*
* DIFL (output) REAL array, dimension ( K )
* On exit, DIFL(I) = D(I) - DSIGMA(I).
*
* DIFR (output) REAL array,
* dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and
* dimension ( K ) if ICOMPQ = 0.
* On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not
* defined and will not be referenced.
*
* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the
* normalizing factors for the right singular vector matrix.
*
* LDDIFR (input) INTEGER
* The leading dimension of DIFR, must be at least K.
*
* DSIGMA (input) REAL array, dimension ( K )
* The first K elements of this array contain the old roots
* of the deflated updating problem. These are the poles
* of the secular equation.
*
* WORK (workspace) REAL array, dimension at least 3 * K
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an singular value did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E0 )
* ..
* .. Local Scalars ..
INTEGER I, IWK1, IWK2, IWK2I, IWK3, IWK3I, J
REAL DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, RHO, TEMP
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLASCL, SLASD4, SLASET, XERBLA
* ..
* .. External Functions ..
REAL SDOT, SLAMC3, SNRM2
EXTERNAL SDOT, SLAMC3, SNRM2
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL, ABS, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
INFO = -1
ELSE IF( K.LT.1 ) THEN
INFO = -2
ELSE IF( LDDIFR.LT.K ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLASD8', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( K.EQ.1 ) THEN
D( 1 ) = ABS( Z( 1 ) )
DIFL( 1 ) = D( 1 )
IF( ICOMPQ.EQ.1 ) THEN
DIFL( 2 ) = ONE
DIFR( 1, 2 ) = ONE
END IF
RETURN
END IF
*
* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can
* be computed with high relative accuracy (barring over/underflow).
* This is a problem on machines without a guard digit in
* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I),
* which on any of these machines zeros out the bottommost
* bit of DSIGMA(I) if it is 1; this makes the subsequent
* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation
* occurs. On binary machines with a guard digit (almost all
* machines) it does not change DSIGMA(I) at all. On hexadecimal
* and decimal machines with a guard digit, it slightly
* changes the bottommost bits of DSIGMA(I). It does not account
* for hexadecimal or decimal machines without guard digits
* (we know of none). We use a subroutine call to compute
* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating
* this code.
*
OPS = OPS + REAL( 2*K )
DO 10 I = 1, K
DSIGMA( I ) = SLAMC3( DSIGMA( I ), DSIGMA( I ) ) - DSIGMA( I )
10 CONTINUE
*
* Book keeping.
*
IWK1 = 1
IWK2 = IWK1 + K
IWK3 = IWK2 + K
IWK2I = IWK2 - 1
IWK3I = IWK3 - 1
*
* Normalize Z.
*
OPS = OPS + REAL( 3*K + 1 )
RHO = SNRM2( K, Z, 1 )
CALL SLASCL( 'G', 0, 0, RHO, ONE, K, 1, Z, K, INFO )
RHO = RHO*RHO
*
* Initialize WORK(IWK3).
*
CALL SLASET( 'A', K, 1, ONE, ONE, WORK( IWK3 ), K )
*
* Compute the updated singular values, the arrays DIFL, DIFR,
* and the updated Z.
*
DO 40 J = 1, K
CALL SLASD4( K, J, DSIGMA, Z, WORK( IWK1 ), RHO, D( J ),
$ WORK( IWK2 ), INFO )
*
* If the root finder fails, the computation is terminated.
*
IF( INFO.NE.0 ) THEN
RETURN
END IF
OPS = OPS + REAL( 2 )
WORK( IWK3I+J ) = WORK( IWK3I+J )*WORK( J )*WORK( IWK2I+J )
DIFL( J ) = -WORK( J )
DIFR( J, 1 ) = -WORK( J+1 )
OPS = OPS + REAL( 6*( J - 1 ) )
DO 20 I = 1, J - 1
WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )*
$ WORK( IWK2I+I ) / ( DSIGMA( I )-
$ DSIGMA( J ) ) / ( DSIGMA( I )+
$ DSIGMA( J ) )
20 CONTINUE
OPS = OPS + REAL( 6*( K-J ) )
DO 30 I = J + 1, K
WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )*
$ WORK( IWK2I+I ) / ( DSIGMA( I )-
$ DSIGMA( J ) ) / ( DSIGMA( I )+
$ DSIGMA( J ) )
30 CONTINUE
40 CONTINUE
*
* Compute updated Z.
*
OPS = OPS + REAL( K )
DO 50 I = 1, K
Z( I ) = SIGN( SQRT( ABS( WORK( IWK3I+I ) ) ), Z( I ) )
50 CONTINUE
*
* Update VF and VL.
*
DO 80 J = 1, K
DIFLJ = DIFL( J )
DJ = D( J )
DSIGJ = -DSIGMA( J )
IF( J.LT.K ) THEN
DIFRJ = -DIFR( J, 1 )
DSIGJP = -DSIGMA( J+1 )
END IF
OPS = OPS + REAL( 3 )
WORK( J ) = -Z( J ) / DIFLJ / ( DSIGMA( J )+DJ )
OPS = OPS + REAL( 5*( J-1 ) )
DO 60 I = 1, J - 1
WORK( I ) = Z( I ) / ( SLAMC3( DSIGMA( I ), DSIGJ )-DIFLJ )
$ / ( DSIGMA( I )+DJ )
60 CONTINUE
OPS = OPS + REAL( 5*( K-J ) )
DO 70 I = J + 1, K
WORK( I ) = Z( I ) / ( SLAMC3( DSIGMA( I ), DSIGJP )+DIFRJ )
$ / ( DSIGMA( I )+DJ )
70 CONTINUE
OPS = OPS + REAL( 6*K )
TEMP = SNRM2( K, WORK, 1 )
WORK( IWK2I+J ) = SDOT( K, WORK, 1, VF, 1 ) / TEMP
WORK( IWK3I+J ) = SDOT( K, WORK, 1, VL, 1 ) / TEMP
IF( ICOMPQ.EQ.1 ) THEN
DIFR( J, 2 ) = TEMP
END IF
80 CONTINUE
*
CALL SCOPY( K, WORK( IWK2 ), 1, VF, 1 )
CALL SCOPY( K, WORK( IWK3 ), 1, VL, 1 )
*
RETURN
*
* End of SLASD8
*
END
SUBROUTINE SLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K,
$ DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL,
$ PERM, GIVNUM, C, S, WORK, IWORK, INFO )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER ICOMPQ, INFO, LDGCOL, LDU, N, SMLSIZ, SQRE
* ..
* .. Array Arguments ..
INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ),
$ K( * ), PERM( LDGCOL, * )
REAL C( * ), D( * ), DIFL( LDU, * ), DIFR( LDU, * ),
$ E( * ), GIVNUM( LDU, * ), POLES( LDU, * ),
$ S( * ), U( LDU, * ), VT( LDU, * ), WORK( * ),
$ Z( LDU, * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* Using a divide and conquer approach, SLASDA computes the singular
* value decomposition (SVD) of a real upper bidiagonal N-by-M matrix
* B with diagonal D and offdiagonal E, where M = N + SQRE. The
* algorithm computes the singular values in the SVD B = U * S * VT.
* The orthogonal matrices U and VT are optionally computed in
* compact form.
*
* A related subroutine, SLASD0, computes the singular values and
* the singular vectors in explicit form.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* Specifies whether singular vectors are to be computed
* in compact form, as follows
* = 0: Compute singular values only.
* = 1: Compute singular vectors of upper bidiagonal
* matrix in compact form.
*
* SMLSIZ (input) INTEGER
* The maximum size of the subproblems at the bottom of the
* computation tree.
*
* N (input) INTEGER
* The row dimension of the upper bidiagonal matrix. This is
* also the dimension of the main diagonal array D.
*
* SQRE (input) INTEGER
* Specifies the column dimension of the bidiagonal matrix.
* = 0: The bidiagonal matrix has column dimension M = N;
* = 1: The bidiagonal matrix has column dimension M = N + 1.
*
* D (input/output) REAL array, dimension ( N )
* On entry D contains the main diagonal of the bidiagonal
* matrix. On exit D, if INFO = 0, contains its singular values.
*
* E (input) REAL array, dimension ( M-1 )
* Contains the subdiagonal entries of the bidiagonal matrix.
* On exit, E has been destroyed.
*
* U (output) REAL array,
* dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced
* if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left
* singular vector matrices of all subproblems at the bottom
* level.
*
* LDU (input) INTEGER, LDU = > N.
* The leading dimension of arrays U, VT, DIFL, DIFR, POLES,
* GIVNUM, and Z.
*
* VT (output) REAL array,
* dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced
* if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT' contains the right
* singular vector matrices of all subproblems at the bottom
* level.
*
* K (output) INTEGER array,
* dimension ( N ) if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0.
* If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th
* secular equation on the computation tree.
*
* DIFL (output) REAL array, dimension ( LDU, NLVL ),
* where NLVL = floor(log_2 (N/SMLSIZ))).
*
* DIFR (output) REAL array,
* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and
* dimension ( N ) if ICOMPQ = 0.
* If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1)
* record distances between singular values on the I-th
* level and singular values on the (I -1)-th level, and
* DIFR(1:N, 2 * I ) contains the normalizing factors for
* the right singular vector matrix. See SLASD8 for details.
*
* Z (output) REAL array,
* dimension ( LDU, NLVL ) if ICOMPQ = 1 and
* dimension ( N ) if ICOMPQ = 0.
* The first K elements of Z(1, I) contain the components of
* the deflation-adjusted updating row vector for subproblems
* on the I-th level.
*
* POLES (output) REAL array,
* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced
* if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and
* POLES(1, 2*I) contain the new and old singular values
* involved in the secular equations on the I-th level.
*
* GIVPTR (output) INTEGER array,
* dimension ( N ) if ICOMPQ = 1, and not referenced if
* ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records
* the number of Givens rotations performed on the I-th
* problem on the computation tree.
*
* GIVCOL (output) INTEGER array,
* dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not
* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,
* GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations
* of Givens rotations performed on the I-th level on the
* computation tree.
*
* LDGCOL (input) INTEGER, LDGCOL = > N.
* The leading dimension of arrays GIVCOL and PERM.
*
* PERM (output) INTEGER array,
* dimension ( LDGCOL, NLVL ) if ICOMPQ = 1, and not referenced
* if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records
* permutations done on the I-th level of the computation tree.
*
* GIVNUM (output) REAL array,
* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not
* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,
* GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S-
* values of Givens rotations performed on the I-th level on
* the computation tree.
*
* C (output) REAL array,
* dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0.
* If ICOMPQ = 1 and the I-th subproblem is not square, on exit,
* C( I ) contains the C-value of a Givens rotation related to
* the right null space of the I-th subproblem.
*
* S (output) REAL array, dimension ( N ) if
* ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1
* and the I-th subproblem is not square, on exit, S( I )
* contains the S-value of a Givens rotation related to
* the right null space of the I-th subproblem.
*
* WORK (workspace) REAL array
* If ICOMPQ = 0 its dimension must be at least
* (2 * N + max(4 * N, (SMLSIZ + 4)*(SMLSIZ + 1))).
* and if ICOMPQ = 1, dimension must be at least (6 * N).
*
* IWORK (workspace) INTEGER array.
* Dimension must be at least (7 * N).
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an singular value did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
INTEGER I, I1, IC, IDXQ, IDXQI, IM1, INODE, ITEMP, IWK,
$ J, LF, LL, LVL, LVL2, M, NCC, ND, NDB1, NDIML,
$ NDIMR, NL, NLF, NLP1, NLVL, NR, NRF, NRP1, NRU,
$ NWORK1, NWORK2, SMLSZP, SQREI, VF, VFI, VL, VLI
REAL ALPHA, BETA
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLASD6, SLASDQ, SLASDT, SLASET, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
INFO = -1
ELSE IF( SMLSIZ.LT.3 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
INFO = -4
ELSE IF( LDU.LT.( N+SQRE ) ) THEN
INFO = -8
ELSE IF( LDGCOL.LT.N ) THEN
INFO = -17
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLASDA', -INFO )
RETURN
END IF
*
M = N + SQRE
*
* If the input matrix is too small, call SLASDQ to find the SVD.
*
IF( N.LE.SMLSIZ ) THEN
IF( ICOMPQ.EQ.0 ) THEN
CALL SLASDQ( 'U', SQRE, N, 0, 0, 0, D, E, VT, LDU, U, LDU,
$ U, LDU, WORK, INFO )
ELSE
CALL SLASDQ( 'U', SQRE, N, M, N, 0, D, E, VT, LDU, U, LDU,
$ U, LDU, WORK, INFO )
END IF
RETURN
END IF
*
* Book-keeping and set up the computation tree.
*
INODE = 1
NDIML = INODE + N
NDIMR = NDIML + N
IDXQ = NDIMR + N
IWK = IDXQ + N
*
NCC = 0
NRU = 0
*
SMLSZP = SMLSIZ + 1
VF = 1
VL = VF + M
NWORK1 = VL + M
NWORK2 = NWORK1 + SMLSZP*SMLSZP
*
CALL SLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ),
$ IWORK( NDIMR ), SMLSIZ )
*
* for the nodes on bottom level of the tree, solve
* their subproblems by SLASDQ.
*
OPS = OPS + REAL( 1 )
NDB1 = ( ND+1 ) / 2
DO 30 I = NDB1, ND
*
* IC : center row of each node
* NL : number of rows of left subproblem
* NR : number of rows of right subproblem
* NLF: starting row of the left subproblem
* NRF: starting row of the right subproblem
*
I1 = I - 1
IC = IWORK( INODE+I1 )
NL = IWORK( NDIML+I1 )
NLP1 = NL + 1
NR = IWORK( NDIMR+I1 )
NLF = IC - NL
NRF = IC + 1
IDXQI = IDXQ + NLF - 2
VFI = VF + NLF - 1
VLI = VL + NLF - 1
SQREI = 1
IF( ICOMPQ.EQ.0 ) THEN
CALL SLASET( 'A', NLP1, NLP1, ZERO, ONE, WORK( NWORK1 ),
$ SMLSZP )
CALL SLASDQ( 'U', SQREI, NL, NLP1, NRU, NCC, D( NLF ),
$ E( NLF ), WORK( NWORK1 ), SMLSZP,
$ WORK( NWORK2 ), NL, WORK( NWORK2 ), NL,
$ WORK( NWORK2 ), INFO )
ITEMP = NWORK1 + NL*SMLSZP
CALL SCOPY( NLP1, WORK( NWORK1 ), 1, WORK( VFI ), 1 )
CALL SCOPY( NLP1, WORK( ITEMP ), 1, WORK( VLI ), 1 )
ELSE
CALL SLASET( 'A', NL, NL, ZERO, ONE, U( NLF, 1 ), LDU )
CALL SLASET( 'A', NLP1, NLP1, ZERO, ONE, VT( NLF, 1 ), LDU )
CALL SLASDQ( 'U', SQREI, NL, NLP1, NL, NCC, D( NLF ),
$ E( NLF ), VT( NLF, 1 ), LDU, U( NLF, 1 ), LDU,
$ U( NLF, 1 ), LDU, WORK( NWORK1 ), INFO )
CALL SCOPY( NLP1, VT( NLF, 1 ), 1, WORK( VFI ), 1 )
CALL SCOPY( NLP1, VT( NLF, NLP1 ), 1, WORK( VLI ), 1 )
END IF
IF( INFO.NE.0 ) THEN
RETURN
END IF
DO 10 J = 1, NL
IWORK( IDXQI+J ) = J
10 CONTINUE
IF( ( I.EQ.ND ) .AND. ( SQRE.EQ.0 ) ) THEN
SQREI = 0
ELSE
SQREI = 1
END IF
IDXQI = IDXQI + NLP1
VFI = VFI + NLP1
VLI = VLI + NLP1
NRP1 = NR + SQREI
IF( ICOMPQ.EQ.0 ) THEN
CALL SLASET( 'A', NRP1, NRP1, ZERO, ONE, WORK( NWORK1 ),
$ SMLSZP )
CALL SLASDQ( 'U', SQREI, NR, NRP1, NRU, NCC, D( NRF ),
$ E( NRF ), WORK( NWORK1 ), SMLSZP,
$ WORK( NWORK2 ), NR, WORK( NWORK2 ), NR,
$ WORK( NWORK2 ), INFO )
ITEMP = NWORK1 + ( NRP1-1 )*SMLSZP
CALL SCOPY( NRP1, WORK( NWORK1 ), 1, WORK( VFI ), 1 )
CALL SCOPY( NRP1, WORK( ITEMP ), 1, WORK( VLI ), 1 )
ELSE
CALL SLASET( 'A', NR, NR, ZERO, ONE, U( NRF, 1 ), LDU )
CALL SLASET( 'A', NRP1, NRP1, ZERO, ONE, VT( NRF, 1 ), LDU )
CALL SLASDQ( 'U', SQREI, NR, NRP1, NR, NCC, D( NRF ),
$ E( NRF ), VT( NRF, 1 ), LDU, U( NRF, 1 ), LDU,
$ U( NRF, 1 ), LDU, WORK( NWORK1 ), INFO )
CALL SCOPY( NRP1, VT( NRF, 1 ), 1, WORK( VFI ), 1 )
CALL SCOPY( NRP1, VT( NRF, NRP1 ), 1, WORK( VLI ), 1 )
END IF
IF( INFO.NE.0 ) THEN
RETURN
END IF
DO 20 J = 1, NR
IWORK( IDXQI+J ) = J
20 CONTINUE
30 CONTINUE
*
* Now conquer each subproblem bottom-up.
*
J = 2**NLVL
DO 50 LVL = NLVL, 1, -1
LVL2 = LVL*2 - 1
*
* Find the first node LF and last node LL on
* the current level LVL.
*
IF( LVL.EQ.1 ) THEN
LF = 1
LL = 1
ELSE
LF = 2**( LVL-1 )
LL = 2*LF - 1
END IF
DO 40 I = LF, LL
IM1 = I - 1
IC = IWORK( INODE+IM1 )
NL = IWORK( NDIML+IM1 )
NR = IWORK( NDIMR+IM1 )
NLF = IC - NL
NRF = IC + 1
IF( I.EQ.LL ) THEN
SQREI = SQRE
ELSE
SQREI = 1
END IF
VFI = VF + NLF - 1
VLI = VL + NLF - 1
IDXQI = IDXQ + NLF - 1
ALPHA = D( IC )
BETA = E( IC )
IF( ICOMPQ.EQ.0 ) THEN
CALL SLASD6( ICOMPQ, NL, NR, SQREI, D( NLF ),
$ WORK( VFI ), WORK( VLI ), ALPHA, BETA,
$ IWORK( IDXQI ), PERM, GIVPTR( 1 ), GIVCOL,
$ LDGCOL, GIVNUM, LDU, POLES, DIFL, DIFR, Z,
$ K( 1 ), C( 1 ), S( 1 ), WORK( NWORK1 ),
$ IWORK( IWK ), INFO )
ELSE
J = J - 1
CALL SLASD6( ICOMPQ, NL, NR, SQREI, D( NLF ),
$ WORK( VFI ), WORK( VLI ), ALPHA, BETA,
$ IWORK( IDXQI ), PERM( NLF, LVL ),
$ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
$ GIVNUM( NLF, LVL2 ), LDU,
$ POLES( NLF, LVL2 ), DIFL( NLF, LVL ),
$ DIFR( NLF, LVL2 ), Z( NLF, LVL ), K( J ),
$ C( J ), S( J ), WORK( NWORK1 ),
$ IWORK( IWK ), INFO )
END IF
IF( INFO.NE.0 ) THEN
RETURN
END IF
40 CONTINUE
50 CONTINUE
*
RETURN
*
* End of SLASDA
*
END
SUBROUTINE SLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT,
$ U, LDU, C, LDC, WORK, INFO )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU, SQRE
* ..
* .. Array Arguments ..
REAL C( LDC, * ), D( * ), E( * ), U( LDU, * ),
$ VT( LDVT, * ), WORK( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLASDQ computes the singular value decomposition (SVD) of a real
* (upper or lower) bidiagonal matrix with diagonal D and offdiagonal
* E, accumulating the transformations if desired. Letting B denote
* the input bidiagonal matrix, the algorithm computes orthogonal
* matrices Q and P such that B = Q * S * P' (P' denotes the transpose
* of P). The singular values S are overwritten on D.
*
* The input matrix U is changed to U * Q if desired.
* The input matrix VT is changed to P' * VT if desired.
* The input matrix C is changed to Q' * C if desired.
*
* See "Computing Small Singular Values of Bidiagonal Matrices With
* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
* LAPACK Working Note #3, for a detailed description of the algorithm.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* On entry, UPLO specifies whether the input bidiagonal matrix
* is upper or lower bidiagonal, and wether it is square are
* not.
* UPLO = 'U' or 'u' B is upper bidiagonal.
* UPLO = 'L' or 'l' B is lower bidiagonal.
*
* SQRE (input) INTEGER
* = 0: then the input matrix is N-by-N.
* = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and
* (N+1)-by-N if UPLU = 'L'.
*
* The bidiagonal matrix has
* N = NL + NR + 1 rows and
* M = N + SQRE >= N columns.
*
* N (input) INTEGER
* On entry, N specifies the number of rows and columns
* in the matrix. N must be at least 0.
*
* NCVT (input) INTEGER
* On entry, NCVT specifies the number of columns of
* the matrix VT. NCVT must be at least 0.
*
* NRU (input) INTEGER
* On entry, NRU specifies the number of rows of
* the matrix U. NRU must be at least 0.
*
* NCC (input) INTEGER
* On entry, NCC specifies the number of columns of
* the matrix C. NCC must be at least 0.
*
* D (input/output) REAL array, dimension (N)
* On entry, D contains the diagonal entries of the
* bidiagonal matrix whose SVD is desired. On normal exit,
* D contains the singular values in ascending order.
*
* E (input/output) REAL array.
* dimension is (N-1) if SQRE = 0 and N if SQRE = 1.
* On entry, the entries of E contain the offdiagonal entries
* of the bidiagonal matrix whose SVD is desired. On normal
* exit, E will contain 0. If the algorithm does not converge,
* D and E will contain the diagonal and superdiagonal entries
* of a bidiagonal matrix orthogonally equivalent to the one
* given as input.
*
* VT (input/output) REAL array, dimension (LDVT, NCVT)
* On entry, contains a matrix which on exit has been
* premultiplied by P', dimension N-by-NCVT if SQRE = 0
* and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0).
*
* LDVT (input) INTEGER
* On entry, LDVT specifies the leading dimension of VT as
* declared in the calling (sub) program. LDVT must be at
* least 1. If NCVT is nonzero LDVT must also be at least N.
*
* U (input/output) REAL array, dimension (LDU, N)
* On entry, contains a matrix which on exit has been
* postmultiplied by Q, dimension NRU-by-N if SQRE = 0
* and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0).
*
* LDU (input) INTEGER
* On entry, LDU specifies the leading dimension of U as
* declared in the calling (sub) program. LDU must be at
* least max( 1, NRU ) .
*
* C (input/output) REAL array, dimension (LDC, NCC)
* On entry, contains an N-by-NCC matrix which on exit
* has been premultiplied by Q' dimension N-by-NCC if SQRE = 0
* and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0).
*
* LDC (input) INTEGER
* On entry, LDC specifies the leading dimension of C as
* declared in the calling (sub) program. LDC must be at
* least 1. If NCC is nonzero, LDC must also be at least N.
*
* WORK (workspace) REAL array, dimension (MAX( 1, 4*N ))
* Workspace. Only referenced if one of NCVT, NRU, or NCC is
* nonzero, and if N is at least 2.
*
* INFO (output) INTEGER
* On exit, a value of 0 indicates a successful exit.
* If INFO < 0, argument number -INFO is illegal.
* If INFO > 0, the algorithm did not converge, and INFO
* specifies how many superdiagonals did not converge.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
LOGICAL ROTATE
INTEGER I, ISUB, IUPLO, J, NP1, SQRE1
REAL CS, R, SMIN, SN
* ..
* .. External Subroutines ..
EXTERNAL SBDSQR, SLARTG, SLASR, SSWAP, XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IUPLO = 0
IF( LSAME( UPLO, 'U' ) )
$ IUPLO = 1
IF( LSAME( UPLO, 'L' ) )
$ IUPLO = 2
IF( IUPLO.EQ.0 ) THEN
INFO = -1
ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NCVT.LT.0 ) THEN
INFO = -4
ELSE IF( NRU.LT.0 ) THEN
INFO = -5
ELSE IF( NCC.LT.0 ) THEN
INFO = -6
ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR.
$ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN
INFO = -10
ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN
INFO = -12
ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR.
$ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN
INFO = -14
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SBDSQR', -INFO )
RETURN
END IF
IF( N.EQ.0 )
$ RETURN
*
* ROTATE is true if any singular vectors desired, false otherwise
*
ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 )
NP1 = N + 1
SQRE1 = SQRE
*
* If matrix non-square upper bidiagonal, rotate to be lower
* bidiagonal. The rotations are on the right.
*
IF( ( IUPLO.EQ.1 ) .AND. ( SQRE1.EQ.1 ) ) THEN
OPS = OPS + REAL( 8*( N-1 ) )
DO 10 I = 1, N - 1
CALL SLARTG( D( I ), E( I ), CS, SN, R )
D( I ) = R
E( I ) = SN*D( I+1 )
D( I+1 ) = CS*D( I+1 )
IF( ROTATE ) THEN
WORK( I ) = CS
WORK( N+I ) = SN
END IF
10 CONTINUE
OPS = OPS + REAL( 6 )
CALL SLARTG( D( N ), E( N ), CS, SN, R )
D( N ) = R
E( N ) = ZERO
IF( ROTATE ) THEN
WORK( N ) = CS
WORK( N+N ) = SN
END IF
IUPLO = 2
SQRE1 = 0
*
* Update singular vectors if desired.
*
IF( NCVT.GT.0 ) THEN
OPS = OPS + REAL( 6*( NP1-1 )*NCVT )
CALL SLASR( 'L', 'V', 'F', NP1, NCVT, WORK( 1 ),
$ WORK( NP1 ), VT, LDVT )
END IF
END IF
*
* If matrix lower bidiagonal, rotate to be upper bidiagonal
* by applying Givens rotations on the left.
*
IF( IUPLO.EQ.2 ) THEN
OPS = OPS + REAL( 8*( N-1 ) )
DO 20 I = 1, N - 1
CALL SLARTG( D( I ), E( I ), CS, SN, R )
D( I ) = R
E( I ) = SN*D( I+1 )
D( I+1 ) = CS*D( I+1 )
IF( ROTATE ) THEN
WORK( I ) = CS
WORK( N+I ) = SN
END IF
20 CONTINUE
*
* If matrix (N+1)-by-N lower bidiagonal, one additional
* rotation is needed.
*
IF( SQRE1.EQ.1 ) THEN
OPS = OPS + REAL( 6 )
CALL SLARTG( D( N ), E( N ), CS, SN, R )
D( N ) = R
IF( ROTATE ) THEN
WORK( N ) = CS
WORK( N+N ) = SN
END IF
END IF
*
* Update singular vectors if desired.
*
IF( NRU.GT.0 ) THEN
IF( SQRE1.EQ.0 ) THEN
OPS = OPS + REAL( 6*( N-1 )*NRU )
CALL SLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ),
$ WORK( NP1 ), U, LDU )
ELSE
OPS = OPS + REAL( 6*N*NRU )
CALL SLASR( 'R', 'V', 'F', NRU, NP1, WORK( 1 ),
$ WORK( NP1 ), U, LDU )
END IF
END IF
IF( NCC.GT.0 ) THEN
IF( SQRE1.EQ.0 ) THEN
OPS = OPS + REAL( 6*( N-1 )*NCC )
CALL SLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ),
$ WORK( NP1 ), C, LDC )
ELSE
OPS = OPS + REAL( 6*N*NCC )
CALL SLASR( 'L', 'V', 'F', NP1, NCC, WORK( 1 ),
$ WORK( NP1 ), C, LDC )
END IF
END IF
END IF
*
* Call SBDSQR to compute the SVD of the reduced real
* N-by-N upper bidiagonal matrix.
*
CALL SBDSQR( 'U', N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C,
$ LDC, WORK, INFO )
*
* Sort the singular values into ascending order (insertion sort on
* singular values, but only one transposition per singular vector)
*
DO 40 I = 1, N
*
* Scan for smallest D(I).
*
ISUB = I
SMIN = D( I )
DO 30 J = I + 1, N
IF( D( J ).LT.SMIN ) THEN
ISUB = J
SMIN = D( J )
END IF
30 CONTINUE
IF( ISUB.NE.I ) THEN
*
* Swap singular values and vectors.
*
D( ISUB ) = D( I )
D( I ) = SMIN
IF( NCVT.GT.0 )
$ CALL SSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( I, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL SSWAP( NRU, U( 1, ISUB ), 1, U( 1, I ), 1 )
IF( NCC.GT.0 )
$ CALL SSWAP( NCC, C( ISUB, 1 ), LDC, C( I, 1 ), LDC )
END IF
40 CONTINUE
*
RETURN
*
* End of SLASDQ
*
END
SUBROUTINE SLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB )
*
* -- LAPACK auxiliary routine (instrum to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
INTEGER LVL, MSUB, N, ND
* ..
* .. Array Arguments ..
INTEGER INODE( * ), NDIML( * ), NDIMR( * )
* ..
* Common block to return operation count
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLASDT creates a tree of subproblems for bidiagonal divide and
* conquer.
*
* Arguments
* =========
*
* N (input) INTEGER
* On entry, the number of diagonal elements of the
* bidiagonal matrix.
*
* LVL (output) INTEGER
* On exit, the number of levels on the computation tree.
*
* ND (output) INTEGER
* On exit, the number of nodes on the tree.
*
* INODE (output) INTEGER array, dimension ( N )
* On exit, centers of subproblems.
*
* NDIML (output) INTEGER array, dimension ( N )
* On exit, row dimensions of left children.
*
* NDIMR (output) INTEGER array, dimension ( N )
* On exit, row dimensions of right children.
*
* MSUB (input) INTEGER.
* On entry, the maximum row dimension each subproblem at the
* bottom of the tree can be of.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
REAL TWO
PARAMETER ( TWO = 2.0E0 )
* ..
* .. Local Scalars ..
INTEGER I, IL, IR, LLST, MAXN, NCRNT, NLVL
REAL TEMP
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL, INT, LOG, MAX
* ..
* .. Executable Statements ..
*
* Find the number of levels on the tree.
*
OPS = OPS + REAL( 2 )
MAXN = MAX( 1, N )
TEMP = LOG( REAL( MAXN ) / REAL( MSUB+1 ) ) / LOG( TWO )
LVL = INT( TEMP ) + 1
*
I = N / 2
INODE( 1 ) = I + 1
NDIML( 1 ) = I
NDIMR( 1 ) = N - I - 1
IL = 0
IR = 1
LLST = 1
DO 20 NLVL = 1, LVL - 1
*
* Constructing the tree at (NLVL+1)-st level. The number of
* nodes created on this level is LLST * 2.
*
DO 10 I = 0, LLST - 1
IL = IL + 2
IR = IR + 2
NCRNT = LLST + I
NDIML( IL ) = NDIML( NCRNT ) / 2
NDIMR( IL ) = NDIML( NCRNT ) - NDIML( IL ) - 1
INODE( IL ) = INODE( NCRNT ) - NDIMR( IL ) - 1
NDIML( IR ) = NDIMR( NCRNT ) / 2
NDIMR( IR ) = NDIMR( NCRNT ) - NDIML( IR ) - 1
INODE( IR ) = INODE( NCRNT ) + NDIML( IR ) + 1
10 CONTINUE
LLST = LLST*2
20 CONTINUE
ND = LLST*2 - 1
*
RETURN
*
* End of SLASDT
*
END
SUBROUTINE SLASQ1( N, D, E, WORK, INFO )
*
* -- LAPACK routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
INTEGER INFO, N
* ..
* .. Array Arguments ..
REAL D( * ), E( * ), WORK( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLASQ1 computes the singular values of a real N-by-N bidiagonal
* matrix with diagonal D and off-diagonal E. The singular values
* are computed to high relative accuracy, in the absence of
* denormalization, underflow and overflow. The algorithm was first
* presented in
*
* "Accurate singular values and differential qd algorithms" by K. V.
* Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230,
* 1994,
*
* and the present implementation is described in "An implementation of
* the dqds Algorithm (Positive Case)", LAPACK Working Note.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of rows and columns in the matrix. N >= 0.
*
* D (input/output) REAL array, dimension (N)
* On entry, D contains the diagonal elements of the
* bidiagonal matrix whose SVD is desired. On normal exit,
* D contains the singular values in decreasing order.
*
* E (input/output) REAL array, dimension (N)
* On entry, elements E(1:N-1) contain the off-diagonal elements
* of the bidiagonal matrix whose SVD is desired.
* On exit, E is overwritten.
*
* WORK (workspace) REAL array, dimension (4*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: the algorithm failed
* = 1, a split was marked by a positive value in E
* = 2, current block of Z not diagonalized after 30*N
* iterations (in inner while loop)
* = 3, termination criterion of outer while loop not met
* (program created more than N unreduced blocks)
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
INTEGER I, IINFO
REAL EPS, SCALE, SAFMIN, SIGMN, SIGMX
* ..
* .. External Subroutines ..
EXTERNAL SLAS2, SLASQ2, SLASRT, XERBLA
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, REAL, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -2
CALL XERBLA( 'SLASQ1', -INFO )
RETURN
ELSE IF( N.EQ.0 ) THEN
RETURN
ELSE IF( N.EQ.1 ) THEN
D( 1 ) = ABS( D( 1 ) )
RETURN
ELSE IF( N.EQ.2 ) THEN
CALL SLAS2( D( 1 ), E( 1 ), D( 2 ), SIGMN, SIGMX )
D( 1 ) = SIGMX
D( 2 ) = SIGMN
RETURN
END IF
*
* Estimate the largest singular value.
*
SIGMX = ZERO
DO 10 I = 1, N - 1
D( I ) = ABS( D( I ) )
SIGMX = MAX( SIGMX, ABS( E( I ) ) )
10 CONTINUE
D( N ) = ABS( D( N ) )
*
* Early return if SIGMX is zero (matrix is already diagonal).
*
IF( SIGMX.EQ.ZERO ) THEN
CALL SLASRT( 'D', N, D, IINFO )
RETURN
END IF
*
DO 20 I = 1, N
SIGMX = MAX( SIGMX, D( I ) )
20 CONTINUE
*
* Copy D and E into WORK (in the Z format) and scale (squaring the
* input data makes scaling by a power of the radix pointless).
*
OPS = OPS + REAL( 1 + 2*N )
EPS = SLAMCH( 'Precision' )
SAFMIN = SLAMCH( 'Safe minimum' )
SCALE = SQRT( EPS / SAFMIN )
CALL SCOPY( N, D, 1, WORK( 1 ), 2 )
CALL SCOPY( N-1, E, 1, WORK( 2 ), 2 )
CALL SLASCL( 'G', 0, 0, SIGMX, SCALE, 2*N-1, 1, WORK, 2*N-1,
$ IINFO )
*
* Compute the q's and e's.
*
OPS = OPS + REAL( 2*N-1 )
DO 30 I = 1, 2*N - 1
WORK( I ) = WORK( I )**2
30 CONTINUE
WORK( 2*N ) = ZERO
*
CALL SLASQ2( N, WORK, INFO )
*
IF( INFO.EQ.0 ) THEN
OPS = OPS + REAL( 2*N )
DO 40 I = 1, N
D( I ) = SQRT( WORK( I ) )
40 CONTINUE
CALL SLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, D, N, IINFO )
END IF
*
RETURN
*
* End of SLASQ1
*
END
SUBROUTINE SLASQ2( N, Z, INFO )
*
* -- LAPACK routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
INTEGER INFO, N
* ..
* .. Array Arguments ..
REAL Z( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLASQ2 computes all the eigenvalues of the symmetric positive
* definite tridiagonal matrix associated with the qd array Z to high
* relative accuracy are computed to high relative accuracy, in the
* absence of denormalization, underflow and overflow.
*
* To see the relation of Z to the tridiagonal matrix, let L be a
* unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and
* let U be an upper bidiagonal matrix with 1's above and diagonal
* Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the
* symmetric tridiagonal to which it is similar.
*
* Note : SLASQ2 defines a logical variable, IEEE, which is true
* on machines which follow ieee-754 floating-point standard in their
* handling of infinities and NaNs, and false otherwise. This variable
* is passed to SLASQ3.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of rows and columns in the matrix. N >= 0.
*
* Z (workspace) REAL array, dimension ( 4*N )
* On entry Z holds the qd array. On exit, entries 1 to N hold
* the eigenvalues in decreasing order, Z( 2*N+1 ) holds the
* trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If
* N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 )
* holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of
* shifts that failed.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if the i-th argument is a scalar and had an illegal
* value, then INFO = -i, if the i-th argument is an
* array and the j-entry had an illegal value, then
* INFO = -(i*100+j)
* > 0: the algorithm failed
* = 1, a split was marked by a positive value in E
* = 2, current block of Z not diagonalized after 30*N
* iterations (in inner while loop)
* = 3, termination criterion of outer while loop not met
* (program created more than N unreduced blocks)
*
* Further Details
* ===============
* Local Variables: I0:N0 defines a current unreduced segment of Z.
* The shifts are accumulated in SIGMA. Iteration count is in ITER.
* Ping-pong is controlled by PP (alternates between 0 and 1).
*
* =====================================================================
*
* .. Parameters ..
REAL CBIAS
PARAMETER ( CBIAS = 1.50E0 )
REAL ZERO, HALF, ONE, TWO, FOUR, HUNDRD
PARAMETER ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0,
$ TWO = 2.0E0, FOUR = 4.0E0, HUNDRD = 100.0E0 )
* ..
* .. Local Scalars ..
LOGICAL IEEE
INTEGER I0, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, K,
$ N0, NBIG, NDIV, NFAIL, PP, SPLT
REAL D, DESIG, DMIN, E, EMAX, EMIN, EPS, OLDEMN,
$ QMAX, QMIN, S, SAFMIN, SIGMA, T, TEMP, TOL,
$ TOL2, TRACE, ZMAX
* ..
* .. External Subroutines ..
EXTERNAL SLASQ3, SLASRT, XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
REAL SLAMCH
EXTERNAL ILAENV, SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL, SQRT
* ..
* .. Executable Statements ..
*
* Test the input arguments.
* (in case SLASQ2 is not called by SLASQ1)
*
OPS = OPS + REAL( 2 )
INFO = 0
EPS = SLAMCH( 'Precision' )
SAFMIN = SLAMCH( 'Safe minimum' )
TOL = EPS*HUNDRD
TOL2 = TOL**2
*
IF( N.LT.0 ) THEN
INFO = -1
CALL XERBLA( 'SLASQ2', 1 )
RETURN
ELSE IF( N.EQ.0 ) THEN
RETURN
ELSE IF( N.EQ.1 ) THEN
*
* 1-by-1 case.
*
IF( Z( 1 ).LT.ZERO ) THEN
INFO = -201
CALL XERBLA( 'SLASQ2', 2 )
END IF
RETURN
ELSE IF( N.EQ.2 ) THEN
*
* 2-by-2 case.
*
IF( Z( 2 ).LT.ZERO .OR. Z( 3 ).LT.ZERO ) THEN
INFO = -2
CALL XERBLA( 'SLASQ2', 2 )
RETURN
ELSE IF( Z( 3 ).GT.Z( 1 ) ) THEN
D = Z( 3 )
Z( 3 ) = Z( 1 )
Z( 1 ) = D
END IF
OPS = OPS + REAL( 4 )
Z( 5 ) = Z( 1 ) + Z( 2 ) + Z( 3 )
IF( Z( 2 ).GT.Z( 3 )*TOL2 ) THEN
OPS = OPS + REAL( 16 )
T = HALF*( ( Z( 1 )-Z( 3 ) )+Z( 2 ) )
S = Z( 3 )*( Z( 2 ) / T )
IF( S.LE.T ) THEN
S = Z( 3 )*( Z( 2 ) / ( T*( ONE+SQRT( ONE+S / T ) ) ) )
ELSE
S = Z( 3 )*( Z( 2 ) / ( T+SQRT( T )*SQRT( T+S ) ) )
END IF
T = Z( 1 ) + ( S+Z( 2 ) )
Z( 3 ) = Z( 3 )*( Z( 1 ) / T )
Z( 1 ) = T
END IF
Z( 2 ) = Z( 3 )
Z( 6 ) = Z( 2 ) + Z( 1 )
RETURN
END IF
*
* Check for negative data and compute sums of q's and e's.
*
Z( 2*N ) = ZERO
EMIN = Z( 2 )
QMAX = ZERO
ZMAX = ZERO
D = ZERO
E = ZERO
*
OPS = OPS + REAL( 2*N )
DO 10 K = 1, 2*( N-1 ), 2
IF( Z( K ).LT.ZERO ) THEN
INFO = -( 200+K )
CALL XERBLA( 'SLASQ2', 2 )
RETURN
ELSE IF( Z( K+1 ).LT.ZERO ) THEN
INFO = -( 200+K+1 )
CALL XERBLA( 'SLASQ2', 2 )
RETURN
END IF
D = D + Z( K )
E = E + Z( K+1 )
QMAX = MAX( QMAX, Z( K ) )
EMIN = MIN( EMIN, Z( K+1 ) )
ZMAX = MAX( QMAX, ZMAX, Z( K+1 ) )
10 CONTINUE
IF( Z( 2*N-1 ).LT.ZERO ) THEN
INFO = -( 200+2*N-1 )
CALL XERBLA( 'SLASQ2', 2 )
RETURN
END IF
D = D + Z( 2*N-1 )
QMAX = MAX( QMAX, Z( 2*N-1 ) )
ZMAX = MAX( QMAX, ZMAX )
*
* Check for diagonality.
*
IF( E.EQ.ZERO ) THEN
DO 20 K = 2, N
Z( K ) = Z( 2*K-1 )
20 CONTINUE
CALL SLASRT( 'D', N, Z, IINFO )
Z( 2*N-1 ) = D
RETURN
END IF
*
TRACE = D + E
*
* Check for zero data.
*
IF( TRACE.EQ.ZERO ) THEN
Z( 2*N-1 ) = ZERO
RETURN
END IF
*
* Check whether the machine is IEEE conformable.
*
IEEE = ILAENV( 10, 'SLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 .AND.
$ ILAENV( 11, 'SLASQ2', 'N', 1, 2, 3, 4 ).EQ.1
*
* Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...).
*
DO 30 K = 2*N, 2, -2
Z( 2*K ) = ZERO
Z( 2*K-1 ) = Z( K )
Z( 2*K-2 ) = ZERO
Z( 2*K-3 ) = Z( K-1 )
30 CONTINUE
*
I0 = 1
N0 = N
*
* Reverse the qd-array, if warranted.
*
OPS = OPS + REAL( 1 )
IF( CBIAS*Z( 4*I0-3 ).LT.Z( 4*N0-3 ) ) THEN
IPN4 = 4*( I0+N0 )
DO 40 I4 = 4*I0, 2*( I0+N0-1 ), 4
TEMP = Z( I4-3 )
Z( I4-3 ) = Z( IPN4-I4-3 )
Z( IPN4-I4-3 ) = TEMP
TEMP = Z( I4-1 )
Z( I4-1 ) = Z( IPN4-I4-5 )
Z( IPN4-I4-5 ) = TEMP
40 CONTINUE
END IF
*
* Initial split checking via dqd and Li's test.
*
PP = 0
*
DO 80 K = 1, 2
*
OPS = OPS + REAL( N0-I0 )
D = Z( 4*N0+PP-3 )
DO 50 I4 = 4*( N0-1 ) + PP, 4*I0 + PP, -4
IF( Z( I4-1 ).LE.TOL2*D ) THEN
Z( I4-1 ) = -ZERO
D = Z( I4-3 )
ELSE
OPS = OPS + REAL( 3 )
D = Z( I4-3 )*( D / ( D+Z( I4-1 ) ) )
END IF
50 CONTINUE
*
* dqd maps Z to ZZ plus Li's test.
*
OPS = OPS + REAL( N0-I0 )
EMIN = Z( 4*I0+PP+1 )
D = Z( 4*I0+PP-3 )
DO 60 I4 = 4*I0 + PP, 4*( N0-1 ) + PP, 4
Z( I4-2*PP-2 ) = D + Z( I4-1 )
IF( Z( I4-1 ).LE.TOL2*D ) THEN
Z( I4-1 ) = -ZERO
Z( I4-2*PP-2 ) = D
Z( I4-2*PP ) = ZERO
D = Z( I4+1 )
ELSE IF( SAFMIN*Z( I4+1 ).LT.Z( I4-2*PP-2 ) .AND.
$ SAFMIN*Z( I4-2*PP-2 ).LT.Z( I4+1 ) ) THEN
OPS = OPS + REAL( 5 )
TEMP = Z( I4+1 ) / Z( I4-2*PP-2 )
Z( I4-2*PP ) = Z( I4-1 )*TEMP
D = D*TEMP
ELSE
OPS = OPS + REAL( 5 )
Z( I4-2*PP ) = Z( I4+1 )*( Z( I4-1 ) / Z( I4-2*PP-2 ) )
D = Z( I4+1 )*( D / Z( I4-2*PP-2 ) )
END IF
EMIN = MIN( EMIN, Z( I4-2*PP ) )
60 CONTINUE
Z( 4*N0-PP-2 ) = D
*
* Now find qmax.
*
QMAX = Z( 4*I0-PP-2 )
DO 70 I4 = 4*I0 - PP + 2, 4*N0 - PP - 2, 4
QMAX = MAX( QMAX, Z( I4 ) )
70 CONTINUE
*
* Prepare for the next iteration on K.
*
PP = 1 - PP
80 CONTINUE
*
ITER = 2
NFAIL = 0
NDIV = 2*( N0-I0 )
*
DO 140 IWHILA = 1, N + 1
IF( N0.LT.1 )
$ GO TO 150
*
* While array unfinished do
*
* E(N0) holds the value of SIGMA when submatrix in I0:N0
* splits from the rest of the array, but is negated.
*
DESIG = ZERO
IF( N0.EQ.N ) THEN
SIGMA = ZERO
ELSE
SIGMA = -Z( 4*N0-1 )
END IF
IF( SIGMA.LT.ZERO ) THEN
INFO = 1
RETURN
END IF
*
* Find last unreduced submatrix's top index I0, find QMAX and
* EMIN. Find Gershgorin-type bound if Q's much greater than E's.
*
EMAX = ZERO
IF( N0.GT.I0 ) THEN
EMIN = ABS( Z( 4*N0-5 ) )
ELSE
EMIN = ZERO
END IF
QMIN = Z( 4*N0-3 )
QMAX = QMIN
DO 90 I4 = 4*N0, 8, -4
IF( Z( I4-5 ).LE.ZERO )
$ GO TO 100
OPS = OPS + REAL( 2 )
IF( QMIN.GE.FOUR*EMAX ) THEN
QMIN = MIN( QMIN, Z( I4-3 ) )
EMAX = MAX( EMAX, Z( I4-5 ) )
END IF
QMAX = MAX( QMAX, Z( I4-7 )+Z( I4-5 ) )
EMIN = MIN( EMIN, Z( I4-5 ) )
90 CONTINUE
I4 = 4
*
100 CONTINUE
I0 = I4 / 4
*
* Store EMIN for passing to SLASQ3.
*
Z( 4*N0-1 ) = EMIN
*
* Put -(initial shift) into DMIN.
*
OPS = OPS + REAL( 5 )
DMIN = -MAX( ZERO, QMIN-TWO*SQRT( QMIN )*SQRT( EMAX ) )
*
* Now I0:N0 is unreduced. PP = 0 for ping, PP = 1 for pong.
*
PP = 0
*
NBIG = 30*( N0-I0+1 )
DO 120 IWHILB = 1, NBIG
IF( I0.GT.N0 )
$ GO TO 130
*
* While submatrix unfinished take a good dqds step.
*
CALL SLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL,
$ ITER, NDIV, IEEE )
*
PP = 1 - PP
*
* When EMIN is very small check for splits.
*
IF( PP.EQ.0 .AND. N0-I0.GE.3 ) THEN
OPS = OPS + REAL( 2 )
IF( Z( 4*N0 ).LE.TOL2*QMAX .OR.
$ Z( 4*N0-1 ).LE.TOL2*SIGMA ) THEN
SPLT = I0 - 1
QMAX = Z( 4*I0-3 )
EMIN = Z( 4*I0-1 )
OLDEMN = Z( 4*I0 )
DO 110 I4 = 4*I0, 4*( N0-3 ), 4
OPS = OPS + REAL( 1 )
IF( Z( I4 ).LE.TOL2*Z( I4-3 ) .OR.
$ Z( I4-1 ).LE.TOL2*SIGMA ) THEN
Z( I4-1 ) = -SIGMA
SPLT = I4 / 4
QMAX = ZERO
EMIN = Z( I4+3 )
OLDEMN = Z( I4+4 )
ELSE
QMAX = MAX( QMAX, Z( I4+1 ) )
EMIN = MIN( EMIN, Z( I4-1 ) )
OLDEMN = MIN( OLDEMN, Z( I4 ) )
END IF
110 CONTINUE
Z( 4*N0-1 ) = EMIN
Z( 4*N0 ) = OLDEMN
I0 = SPLT + 1
END IF
END IF
*
120 CONTINUE
*
INFO = 2
RETURN
*
* end IWHILB
*
130 CONTINUE
*
140 CONTINUE
*
INFO = 3
RETURN
*
* end IWHILA
*
150 CONTINUE
*
* Move q's to the front.
*
DO 160 K = 2, N
Z( K ) = Z( 4*K-3 )
160 CONTINUE
*
* Sort and compute sum of eigenvalues.
*
CALL SLASRT( 'D', N, Z, IINFO )
*
E = ZERO
DO 170 K = N, 1, -1
E = E + Z( K )
170 CONTINUE
*
* Store trace, sum(eigenvalues) and information on performance.
*
Z( 2*N+1 ) = TRACE
Z( 2*N+2 ) = E
Z( 2*N+3 ) = REAL( ITER )
Z( 2*N+4 ) = REAL( NDIV ) / REAL( N**2 )
Z( 2*N+5 ) = HUNDRD*NFAIL / REAL( ITER )
RETURN
*
* End of SLASQ2
*
END
SUBROUTINE SLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL,
$ ITER, NDIV, IEEE )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* May 17, 2000
*
* .. Scalar Arguments ..
LOGICAL IEEE
INTEGER I0, ITER, N0, NDIV, NFAIL, PP
REAL DESIG, DMIN, QMAX, SIGMA
* ..
* .. Array Arguments ..
REAL Z( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLASQ3 checks for deflation, computes a shift (TAU) and calls dqds.
* In case of failure it changes shifts, and tries again until output
* is positive.
*
* Arguments
* =========
*
* I0 (input) INTEGER
* First index.
*
* N0 (input) INTEGER
* Last index.
*
* Z (input) REAL array, dimension ( 4*N )
* Z holds the qd array.
*
* PP (input) INTEGER
* PP=0 for ping, PP=1 for pong.
*
* DMIN (output) REAL
* Minimum value of d.
*
* SIGMA (output) REAL
* Sum of shifts used in current segment.
*
* DESIG (input/output) REAL
* Lower order part of SIGMA
*
* QMAX (input) REAL
* Maximum value of q.
*
* NFAIL (output) INTEGER
* Number of times shift was too big.
*
* ITER (output) INTEGER
* Number of iterations.
*
* NDIV (output) INTEGER
* Number of divisions.
*
* TTYPE (output) INTEGER
* Shift type.
*
* IEEE (input) LOGICAL
* Flag for IEEE or non IEEE arithmetic (passed to SLASQ5).
*
* =====================================================================
*
* .. Parameters ..
REAL CBIAS
PARAMETER ( CBIAS = 1.50E0 )
REAL ZERO, QURTR, HALF, ONE, TWO, HUNDRD
PARAMETER ( ZERO = 0.0E0, QURTR = 0.250E0, HALF = 0.5E0,
$ ONE = 1.0E0, TWO = 2.0E0, HUNDRD = 100.0E0 )
* ..
* .. Local Scalars ..
INTEGER IPN4, J4, N0IN, NN, TTYPE
REAL DMIN1, DMIN2, DN, DN1, DN2, EPS, S, SAFMIN, T,
$ TAU, TEMP, TOL, TOL2
* ..
* .. External Subroutines ..
EXTERNAL SLASQ4, SLASQ5, SLASQ6
* ..
* .. External Function ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MIN, REAL, SQRT
* ..
* .. Save statement ..
SAVE TTYPE
SAVE DMIN1, DMIN2, DN, DN1, DN2, TAU
* ..
* .. Data statement ..
DATA TTYPE / 0 /
DATA DMIN1 / ZERO /, DMIN2 / ZERO /, DN / ZERO /,
$ DN1 / ZERO /, DN2 / ZERO /, TAU / ZERO /
* ..
* .. Executable Statements ..
*
OPS = OPS + REAL( 2 )
N0IN = N0
EPS = SLAMCH( 'Precision' )
SAFMIN = SLAMCH( 'Safe minimum' )
TOL = EPS*HUNDRD
TOL2 = TOL**2
*
* Check for deflation.
*
10 CONTINUE
*
IF( N0.LT.I0 )
$ RETURN
IF( N0.EQ.I0 )
$ GO TO 20
NN = 4*N0 + PP
IF( N0.EQ.( I0+1 ) )
$ GO TO 40
*
* Check whether E(N0-1) is negligible, 1 eigenvalue.
*
OPS = OPS + REAL( 3 )
IF( Z( NN-5 ).GT.TOL2*( SIGMA+Z( NN-3 ) ) .AND.
$ Z( NN-2*PP-4 ).GT.TOL2*Z( NN-7 ) )
$ GO TO 30
*
20 CONTINUE
*
OPS = OPS + REAL( 1 )
Z( 4*N0-3 ) = Z( 4*N0+PP-3 ) + SIGMA
N0 = N0 - 1
GO TO 10
*
* Check whether E(N0-2) is negligible, 2 eigenvalues.
*
30 CONTINUE
*
OPS = OPS + REAL( 2 )
IF( Z( NN-9 ).GT.TOL2*SIGMA .AND.
$ Z( NN-2*PP-8 ).GT.TOL2*Z( NN-11 ) )
$ GO TO 50
*
40 CONTINUE
*
IF( Z( NN-3 ).GT.Z( NN-7 ) ) THEN
S = Z( NN-3 )
Z( NN-3 ) = Z( NN-7 )
Z( NN-7 ) = S
END IF
OPS = OPS + REAL( 3 )
IF( Z( NN-5 ).GT.Z( NN-3 )*TOL2 ) THEN
OPS = OPS + REAL( 5 )
T = HALF*( ( Z( NN-7 )-Z( NN-3 ) )+Z( NN-5 ) )
S = Z( NN-3 )*( Z( NN-5 ) / T )
IF( S.LE.T ) THEN
OPS = OPS + REAL( 7 )
S = Z( NN-3 )*( Z( NN-5 ) /
$ ( T*( ONE+SQRT( ONE+S / T ) ) ) )
ELSE
OPS = OPS + REAL( 6 )
S = Z( NN-3 )*( Z( NN-5 ) / ( T+SQRT( T )*SQRT( T+S ) ) )
END IF
OPS = OPS + REAL( 4 )
T = Z( NN-7 ) + ( S+Z( NN-5 ) )
Z( NN-3 ) = Z( NN-3 )*( Z( NN-7 ) / T )
Z( NN-7 ) = T
END IF
Z( 4*N0-7 ) = Z( NN-7 ) + SIGMA
Z( 4*N0-3 ) = Z( NN-3 ) + SIGMA
N0 = N0 - 2
GO TO 10
*
50 CONTINUE
*
* Reverse the qd-array, if warranted.
*
IF( DMIN.LE.ZERO .OR. N0.LT.N0IN ) THEN
OPS = OPS + REAL( 1 )
IF( CBIAS*Z( 4*I0+PP-3 ).LT.Z( 4*N0+PP-3 ) ) THEN
IPN4 = 4*( I0+N0 )
DO 60 J4 = 4*I0, 2*( I0+N0-1 ), 4
TEMP = Z( J4-3 )
Z( J4-3 ) = Z( IPN4-J4-3 )
Z( IPN4-J4-3 ) = TEMP
TEMP = Z( J4-2 )
Z( J4-2 ) = Z( IPN4-J4-2 )
Z( IPN4-J4-2 ) = TEMP
TEMP = Z( J4-1 )
Z( J4-1 ) = Z( IPN4-J4-5 )
Z( IPN4-J4-5 ) = TEMP
TEMP = Z( J4 )
Z( J4 ) = Z( IPN4-J4-4 )
Z( IPN4-J4-4 ) = TEMP
60 CONTINUE
IF( N0-I0.LE.4 ) THEN
Z( 4*N0+PP-1 ) = Z( 4*I0+PP-1 )
Z( 4*N0-PP ) = Z( 4*I0-PP )
END IF
DMIN2 = MIN( DMIN2, Z( 4*N0+PP-1 ) )
Z( 4*N0+PP-1 ) = MIN( Z( 4*N0+PP-1 ), Z( 4*I0+PP-1 ),
$ Z( 4*I0+PP+3 ) )
Z( 4*N0-PP ) = MIN( Z( 4*N0-PP ), Z( 4*I0-PP ),
$ Z( 4*I0-PP+4 ) )
QMAX = MAX( QMAX, Z( 4*I0+PP-3 ), Z( 4*I0+PP+1 ) )
DMIN = -ZERO
END IF
END IF
*
70 CONTINUE
*
IF( DMIN.LT.ZERO .OR. SAFMIN*QMAX.LT.MIN( Z( 4*N0+PP-1 ),
$ Z( 4*N0+PP-9 ), DMIN2+Z( 4*N0-PP ) ) ) THEN
*
* Choose a shift.
*
CALL SLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1,
$ DN2, TAU, TTYPE )
*
* Call dqds until DMIN > 0.
*
80 CONTINUE
*
CALL SLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN,
$ DN1, DN2, IEEE )
*
NDIV = NDIV + ( N0-I0+2 )
ITER = ITER + 1
*
* Check status.
*
IF( DMIN.GE.ZERO .AND. DMIN1.GT.ZERO ) THEN
*
* Success.
*
GO TO 100
*
ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND.
$ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND.
$ ABS( DN ).LT.TOL*SIGMA ) THEN
*
* Convergence hidden by negative DN.
*
OPS = OPS + REAL( 2 )
Z( 4*( N0-1 )-PP+2 ) = ZERO
DMIN = ZERO
GO TO 100
ELSE IF( DMIN.LT.ZERO ) THEN
*
* TAU too big. Select new TAU and try again.
*
NFAIL = NFAIL + 1
IF( TTYPE.LT.-22 ) THEN
*
* Failed twice. Play it safe.
*
TAU = ZERO
ELSE IF( DMIN1.GT.ZERO ) THEN
*
* Late failure. Gives excellent shift.
*
OPS = OPS + REAL( 4 )
TAU = ( TAU+DMIN )*( ONE-TWO*EPS )
TTYPE = TTYPE - 11
ELSE
*
* Early failure. Divide by 4.
*
OPS = OPS + REAL( 1 )
TAU = QURTR*TAU
TTYPE = TTYPE - 12
END IF
GO TO 80
ELSE IF( DMIN.NE.DMIN ) THEN
*
* NaN.
*
TAU = ZERO
GO TO 80
ELSE
*
* Possible underflow. Play it safe.
*
GO TO 90
END IF
END IF
*
* Risk of underflow.
*
90 CONTINUE
CALL SLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 )
NDIV = NDIV + ( N0-I0+2 )
ITER = ITER + 1
TAU = ZERO
*
100 CONTINUE
OPS = OPS + REAL( 4 )
IF( TAU.LT.SIGMA ) THEN
DESIG = DESIG + TAU
T = SIGMA + DESIG
DESIG = DESIG - ( T-SIGMA )
ELSE
T = SIGMA + TAU
DESIG = SIGMA - ( T-TAU ) + DESIG
END IF
SIGMA = T
*
RETURN
*
* End of SLASQ3
*
END
SUBROUTINE SLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN,
$ DN1, DN2, TAU, TTYPE )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* May 17, 2000
*
* .. Scalar Arguments ..
INTEGER I0, N0, N0IN, PP, TTYPE
REAL DMIN, DMIN1, DMIN2, DN, DN1, DN2, TAU
* ..
* .. Array Arguments ..
REAL Z( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLASQ4 computes an approximation TAU to the smallest eigenvalue
* using values of d from the previous transform.
*
* I0 (input) INTEGER
* First index.
*
* N0 (input) INTEGER
* Last index.
*
* Z (input) REAL array, dimension ( 4*N )
* Z holds the qd array.
*
* PP (input) INTEGER
* PP=0 for ping, PP=1 for pong.
*
* NOIN (input) INTEGER
* The value of N0 at start of EIGTEST.
*
* DMIN (input) REAL
* Minimum value of d.
*
* DMIN1 (input) REAL
* Minimum value of d, excluding D( N0 ).
*
* DMIN2 (input) REAL
* Minimum value of d, excluding D( N0 ) and D( N0-1 ).
*
* DN (input) REAL
* d(N)
*
* DN1 (input) REAL
* d(N-1)
*
* DN2 (input) REAL
* d(N-2)
*
* TAU (output) REAL
* This is the shift.
*
* TTYPE (output) INTEGER
* Shift type.
*
* Further Details
* ===============
* CNST1 = 9/16
*
* =====================================================================
*
* .. Parameters ..
REAL CNST1, CNST2, CNST3
PARAMETER ( CNST1 = 0.5630E0, CNST2 = 1.010E0,
$ CNST3 = 1.050E0 )
REAL QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD
PARAMETER ( QURTR = 0.250E0, THIRD = 0.3330E0,
$ HALF = 0.50E0, ZERO = 0.0E0, ONE = 1.0E0,
$ TWO = 2.0E0, HUNDRD = 100.0E0 )
* ..
* .. Local Scalars ..
INTEGER I4, NN, NP
REAL A2, B1, B2, G, GAM, GAP1, GAP2, S
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL, SQRT
* ..
* .. Save statement ..
SAVE G
* ..
* .. Data statement ..
DATA G / ZERO /
* ..
* .. Executable Statements ..
*
* A negative DMIN forces the shift to take that absolute value
* TTYPE records the type of shift.
*
IF( DMIN.LE.ZERO ) THEN
TAU = -DMIN
TTYPE = -1
RETURN
END IF
*
NN = 4*N0 + PP
IF( N0IN.EQ.N0 ) THEN
*
* No eigenvalues deflated.
*
IF( DMIN.EQ.DN .OR. DMIN.EQ.DN1 ) THEN
*
OPS = OPS + REAL( 7 )
B1 = SQRT( Z( NN-3 ) )*SQRT( Z( NN-5 ) )
B2 = SQRT( Z( NN-7 ) )*SQRT( Z( NN-9 ) )
A2 = Z( NN-7 ) + Z( NN-5 )
*
* Cases 2 and 3.
*
IF( DMIN.EQ.DN .AND. DMIN1.EQ.DN1 ) THEN
OPS = OPS + REAL( 3 )
GAP2 = DMIN2 - A2 - DMIN2*QURTR
IF( GAP2.GT.ZERO .AND. GAP2.GT.B2 ) THEN
OPS = OPS + REAL( 4 )
GAP1 = A2 - DN - ( B2 / GAP2 )*B2
ELSE
OPS = OPS + REAL( 3 )
GAP1 = A2 - DN - ( B1+B2 )
END IF
IF( GAP1.GT.ZERO .AND. GAP1.GT.B1 ) THEN
OPS = OPS + REAL( 4 )
S = MAX( DN-( B1 / GAP1 )*B1, HALF*DMIN )
TTYPE = -2
ELSE
OPS = OPS + REAL( 2 )
S = ZERO
IF( DN.GT.B1 )
$ S = DN - B1
IF( A2.GT.( B1+B2 ) )
$ S = MIN( S, A2-( B1+B2 ) )
S = MAX( S, THIRD*DMIN )
TTYPE = -3
END IF
ELSE
*
* Case 4.
*
TTYPE = -4
OPS = OPS + REAL( 1 )
S = QURTR*DMIN
IF( DMIN.EQ.DN ) THEN
OPS = OPS + REAL( 1 )
GAM = DN
A2 = ZERO
IF( Z( NN-5 ) .GT. Z( NN-7 ) )
$ RETURN
B2 = Z( NN-5 ) / Z( NN-7 )
NP = NN - 9
ELSE
OPS = OPS + REAL( 2 )
NP = NN - 2*PP
B2 = Z( NP-2 )
GAM = DN1
IF( Z( NP-4 ) .GT. Z( NP-2 ) )
$ RETURN
A2 = Z( NP-4 ) / Z( NP-2 )
IF( Z( NN-9 ) .GT. Z( NN-11 ) )
$ RETURN
B2 = Z( NN-9 ) / Z( NN-11 )
NP = NN - 13
END IF
*
* Approximate contribution to norm squared from I < NN-1.
*
A2 = A2 + B2
DO 10 I4 = NP, 4*I0 - 1 + PP, -4
OPS = OPS + REAL( 5 )
IF( B2.EQ.ZERO )
$ GO TO 20
B1 = B2
IF( Z( I4 ) .GT. Z( I4-2 ) )
$ RETURN
B2 = B2*( Z( I4 ) / Z( I4-2 ) )
A2 = A2 + B2
IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 )
$ GO TO 20
10 CONTINUE
20 CONTINUE
OPS = OPS + REAL( 1 )
A2 = CNST3*A2
*
* Rayleigh quotient residual bound.
*
OPS = OPS + REAL( 5 )
IF( A2.LT.CNST1 )
$ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 )
END IF
ELSE IF( DMIN.EQ.DN2 ) THEN
*
* Case 5.
*
TTYPE = -5
OPS = OPS + REAL( 1 )
S = QURTR*DMIN
*
* Compute contribution to norm squared from I > NN-2.
*
OPS = OPS + REAL( 4 )
NP = NN - 2*PP
B1 = Z( NP-2 )
B2 = Z( NP-6 )
GAM = DN2
IF( Z( NP-8 ).GT.B2 .OR. Z( NP-4 ).GT.B1 )
$ RETURN
A2 = ( Z( NP-8 ) / B2 )*( ONE+Z( NP-4 ) / B1 )
*
* Approximate contribution to norm squared from I < NN-2.
*
IF( N0-I0.GT.2 ) THEN
OPS = OPS + REAL( 3 )
B2 = Z( NN-13 ) / Z( NN-15 )
A2 = A2 + B2
DO 30 I4 = NN - 17, 4*I0 - 1 + PP, -4
OPS = OPS + REAL( 5 )
IF( B2.EQ.ZERO )
$ GO TO 40
B1 = B2
IF( Z( I4 ) .GT. Z( I4-2 ) )
$ RETURN
B2 = B2*( Z( I4 ) / Z( I4-2 ) )
A2 = A2 + B2
IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 )
$ GO TO 40
30 CONTINUE
40 CONTINUE
A2 = CNST3*A2
END IF
*
OPS = OPS + REAL( 5 )
IF( A2.LT.CNST1 )
$ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 )
ELSE
*
* Case 6, no information to guide us.
*
IF( TTYPE.EQ.-6 ) THEN
OPS = OPS + REAL( 3 )
G = G + THIRD*( ONE-G )
ELSE IF( TTYPE.EQ.-18 ) THEN
OPS = OPS + REAL( 1 )
G = QURTR*THIRD
ELSE
G = QURTR
END IF
OPS = OPS + REAL( 1 )
S = G*DMIN
TTYPE = -6
END IF
*
ELSE IF( N0IN.EQ.( N0+1 ) ) THEN
*
* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN.
*
IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN
*
* Cases 7 and 8.
*
TTYPE = -7
OPS = OPS + REAL( 2 )
S = THIRD*DMIN1
IF( Z( NN-5 ).GT.Z( NN-7 ) )
$ RETURN
B1 = Z( NN-5 ) / Z( NN-7 )
B2 = B1
IF( B2.EQ.ZERO )
$ GO TO 60
DO 50 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4
OPS = OPS + REAL( 4 )
A2 = B1
IF( Z( I4 ).GT.Z( I4-2 ) )
$ RETURN
B1 = B1*( Z( I4 ) / Z( I4-2 ) )
B2 = B2 + B1
IF( HUNDRD*MAX( B1, A2 ).LT.B2 )
$ GO TO 60
50 CONTINUE
60 CONTINUE
OPS = OPS + REAL( 8 )
B2 = SQRT( CNST3*B2 )
A2 = DMIN1 / ( ONE+B2**2 )
GAP2 = HALF*DMIN2 - A2
IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN
OPS = OPS + REAL( 7 )
S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) )
ELSE
OPS = OPS + REAL( 4 )
S = MAX( S, A2*( ONE-CNST2*B2 ) )
TTYPE = -8
END IF
ELSE
*
* Case 9.
*
OPS = OPS + REAL( 2 )
S = QURTR*DMIN1
IF( DMIN1.EQ.DN1 )
$ S = HALF*DMIN1
TTYPE = -9
END IF
*
ELSE IF( N0IN.EQ.( N0+2 ) ) THEN
*
* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN.
*
* Cases 10 and 11.
*
OPS = OPS + REAL( 1 )
IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN
TTYPE = -10
OPS = OPS + REAL( 1 )
S = THIRD*DMIN2
IF( Z( NN-5 ).GT.Z( NN-7 ) )
$ RETURN
B1 = Z( NN-5 ) / Z( NN-7 )
B2 = B1
IF( B2.EQ.ZERO )
$ GO TO 80
DO 70 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4
OPS = OPS + REAL( 4 )
IF( Z( I4 ).GT.Z( I4-2 ) )
$ RETURN
B1 = B1*( Z( I4 ) / Z( I4-2 ) )
B2 = B2 + B1
IF( HUNDRD*B1.LT.B2 )
$ GO TO 80
70 CONTINUE
80 CONTINUE
OPS = OPS + REAL( 12 )
B2 = SQRT( CNST3*B2 )
A2 = DMIN2 / ( ONE+B2**2 )
GAP2 = Z( NN-7 ) + Z( NN-9 ) -
$ SQRT( Z( NN-11 ) )*SQRT( Z( NN-9 ) ) - A2
IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN
OPS = OPS + REAL( 7 )
S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) )
ELSE
OPS = OPS + REAL( 4 )
S = MAX( S, A2*( ONE-CNST2*B2 ) )
END IF
ELSE
OPS = OPS + REAL( 1 )
S = QURTR*DMIN2
TTYPE = -11
END IF
ELSE IF( N0IN.GT.( N0+2 ) ) THEN
*
* Case 12, more than two eigenvalues deflated. No information.
*
S = ZERO
TTYPE = -12
END IF
*
TAU = S
RETURN
*
* End of SLASQ4
*
END
SUBROUTINE SLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN,
$ DNM1, DNM2, IEEE )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* May 17, 2000
*
* .. Scalar Arguments ..
LOGICAL IEEE
INTEGER I0, N0, PP
REAL DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU
* ..
* .. Array Arguments ..
REAL Z( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLASQ5 computes one dqds transform in ping-pong form, one
* version for IEEE machines another for non IEEE machines.
*
* Arguments
* =========
*
* I0 (input) INTEGER
* First index.
*
* N0 (input) INTEGER
* Last index.
*
* Z (input) REAL array, dimension ( 4*N )
* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid
* an extra argument.
*
* PP (input) INTEGER
* PP=0 for ping, PP=1 for pong.
*
* TAU (input) REAL
* This is the shift.
*
* DMIN (output) REAL
* Minimum value of d.
*
* DMIN1 (output) REAL
* Minimum value of d, excluding D( N0 ).
*
* DMIN2 (output) REAL
* Minimum value of d, excluding D( N0 ) and D( N0-1 ).
*
* DN (output) REAL
* d(N0), the last value of d.
*
* DNM1 (output) REAL
* d(N0-1).
*
* DNM2 (output) REAL
* d(N0-2).
*
* IEEE (input) LOGICAL
* Flag for IEEE or non IEEE arithmetic.
*
* =====================================================================
*
* .. Parameter ..
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
INTEGER J4, J4P2
REAL D, EMIN, TEMP
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN, REAL
* ..
* .. Executable Statements ..
*
IF( ( N0-I0-1 ).LE.0 )
$ RETURN
*
OPS = OPS + REAL( 1 )
J4 = 4*I0 + PP - 3
EMIN = Z( J4+4 )
D = Z( J4 ) - TAU
DMIN = D
DMIN1 = -Z( J4 )
*
IF( IEEE ) THEN
*
* Code for IEEE arithmetic.
*
IF( PP.EQ.0 ) THEN
DO 10 J4 = 4*I0, 4*( N0-3 ), 4
OPS = OPS + REAL( 5 )
Z( J4-2 ) = D + Z( J4-1 )
TEMP = Z( J4+1 ) / Z( J4-2 )
D = D*TEMP - TAU
DMIN = MIN( DMIN, D )
Z( J4 ) = Z( J4-1 )*TEMP
EMIN = MIN( Z( J4 ), EMIN )
10 CONTINUE
ELSE
DO 20 J4 = 4*I0, 4*( N0-3 ), 4
OPS = OPS + REAL( 5 )
Z( J4-3 ) = D + Z( J4 )
TEMP = Z( J4+2 ) / Z( J4-3 )
D = D*TEMP - TAU
DMIN = MIN( DMIN, D )
Z( J4-1 ) = Z( J4 )*TEMP
EMIN = MIN( Z( J4-1 ), EMIN )
20 CONTINUE
END IF
*
* Unroll last two steps.
*
OPS = OPS + REAL( 6 )
DNM2 = D
DMIN2 = DMIN
J4 = 4*( N0-2 ) - PP
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM2 + Z( J4P2 )
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU
DMIN = MIN( DMIN, DNM1 )
*
OPS = OPS + REAL( 6 )
DMIN1 = DMIN
J4 = J4 + 4
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM1 + Z( J4P2 )
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU
DMIN = MIN( DMIN, DN )
*
ELSE
*
* Code for non IEEE arithmetic.
*
IF( PP.EQ.0 ) THEN
DO 30 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-2 ) = D + Z( J4-1 )
IF( D.LT.ZERO ) THEN
RETURN
ELSE
OPS = OPS + REAL( 5 )
Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) )
D = Z( J4+1 )*( D / Z( J4-2 ) ) - TAU
END IF
DMIN = MIN( DMIN, D )
EMIN = MIN( EMIN, Z( J4 ) )
30 CONTINUE
ELSE
DO 40 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-3 ) = D + Z( J4 )
IF( D.LT.ZERO ) THEN
RETURN
ELSE
OPS = OPS + REAL( 5 )
Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) )
D = Z( J4+2 )*( D / Z( J4-3 ) ) - TAU
END IF
DMIN = MIN( DMIN, D )
EMIN = MIN( EMIN, Z( J4-1 ) )
40 CONTINUE
END IF
*
* Unroll last two steps.
*
OPS = OPS + REAL( 1 )
DNM2 = D
DMIN2 = DMIN
J4 = 4*( N0-2 ) - PP
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM2 + Z( J4P2 )
IF( DNM2.LT.ZERO ) THEN
RETURN
ELSE
OPS = OPS + REAL( 5 )
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU
END IF
DMIN = MIN( DMIN, DNM1 )
*
OPS = OPS + REAL( 1 )
DMIN1 = DMIN
J4 = J4 + 4
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM1 + Z( J4P2 )
IF( DNM1.LT.ZERO ) THEN
RETURN
ELSE
OPS = OPS + REAL( 5 )
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU
END IF
DMIN = MIN( DMIN, DN )
*
END IF
*
Z( J4+2 ) = DN
Z( 4*N0-PP ) = EMIN
RETURN
*
* End of SLASQ5
*
END
SUBROUTINE SLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN,
$ DNM1, DNM2 )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
INTEGER I0, N0, PP
REAL DMIN, DMIN1, DMIN2, DN, DNM1, DNM2
* ..
* .. Array Arguments ..
REAL Z( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLASQ6 computes one dqd (shift equal to zero) transform in
* ping-pong form, with protection against underflow and overflow.
*
* Arguments
* =========
*
* I0 (input) INTEGER
* First index.
*
* N0 (input) INTEGER
* Last index.
*
* Z (input) REAL array, dimension ( 4*N )
* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid
* an extra argument.
*
* PP (input) INTEGER
* PP=0 for ping, PP=1 for pong.
*
* DMIN (output) REAL
* Minimum value of d.
*
* DMIN1 (output) REAL
* Minimum value of d, excluding D( N0 ).
*
* DMIN2 (output) REAL
* Minimum value of d, excluding D( N0 ) and D( N0-1 ).
*
* DN (output) REAL
* d(N0), the last value of d.
*
* DNM1 (output) REAL
* d(N0-1).
*
* DNM2 (output) REAL
* d(N0-2).
*
* =====================================================================
*
* .. Parameter ..
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
INTEGER J4, J4P2
REAL D, EMIN, SAFMIN, TEMP
* ..
* .. External Function ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN, REAL
* ..
* .. Executable Statements ..
*
IF( ( N0-I0-1 ).LE.0 )
$ RETURN
*
SAFMIN = SLAMCH( 'Safe minimum' )
J4 = 4*I0 + PP - 3
EMIN = Z( J4+4 )
D = Z( J4 )
DMIN = D
*
IF( PP.EQ.0 ) THEN
DO 10 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-2 ) = D + Z( J4-1 )
IF( Z( J4-2 ).EQ.ZERO ) THEN
Z( J4 ) = ZERO
D = Z( J4+1 )
DMIN = D
EMIN = ZERO
ELSE IF( SAFMIN*Z( J4+1 ).LT.Z( J4-2 ) .AND.
$ SAFMIN*Z( J4-2 ).LT.Z( J4+1 ) ) THEN
OPS = OPS + REAL( 2 )
TEMP = Z( J4+1 ) / Z( J4-2 )
Z( J4 ) = Z( J4-1 )*TEMP
D = D*TEMP
ELSE
OPS = OPS + REAL( 4 )
Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) )
D = Z( J4+1 )*( D / Z( J4-2 ) )
END IF
DMIN = MIN( DMIN, D )
EMIN = MIN( EMIN, Z( J4 ) )
10 CONTINUE
ELSE
DO 20 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-3 ) = D + Z( J4 )
IF( Z( J4-3 ).EQ.ZERO ) THEN
Z( J4-1 ) = ZERO
D = Z( J4+2 )
DMIN = D
EMIN = ZERO
ELSE IF( SAFMIN*Z( J4+2 ).LT.Z( J4-3 ) .AND.
$ SAFMIN*Z( J4-3 ).LT.Z( J4+2 ) ) THEN
OPS = OPS + REAL( 2 )
TEMP = Z( J4+2 ) / Z( J4-3 )
Z( J4-1 ) = Z( J4 )*TEMP
D = D*TEMP
ELSE
OPS = OPS + REAL( 4 )
Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) )
D = Z( J4+2 )*( D / Z( J4-3 ) )
END IF
DMIN = MIN( DMIN, D )
EMIN = MIN( EMIN, Z( J4-1 ) )
20 CONTINUE
END IF
*
* Unroll last two steps.
*
OPS = OPS + REAL( 1 )
DNM2 = D
DMIN2 = DMIN
J4 = 4*( N0-2 ) - PP
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM2 + Z( J4P2 )
IF( Z( J4-2 ).EQ.ZERO ) THEN
Z( J4 ) = ZERO
DNM1 = Z( J4P2+2 )
DMIN = DNM1
EMIN = ZERO
ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND.
$ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN
OPS = OPS + REAL( 3 )
TEMP = Z( J4P2+2 ) / Z( J4-2 )
Z( J4 ) = Z( J4P2 )*TEMP
DNM1 = DNM2*TEMP
ELSE
OPS = OPS + REAL( 4 )
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) )
END IF
DMIN = MIN( DMIN, DNM1 )
*
OPS = OPS + REAL( 1 )
DMIN1 = DMIN
J4 = J4 + 4
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM1 + Z( J4P2 )
IF( Z( J4-2 ).EQ.ZERO ) THEN
Z( J4 ) = ZERO
DN = Z( J4P2+2 )
DMIN = DN
EMIN = ZERO
ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND.
$ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN
OPS = OPS + REAL( 3 )
TEMP = Z( J4P2+2 ) / Z( J4-2 )
Z( J4 ) = Z( J4P2 )*TEMP
DN = DNM1*TEMP
ELSE
OPS = OPS + REAL( 4 )
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) )
END IF
DMIN = MIN( DMIN, DN )
*
Z( J4+2 ) = DN
Z( 4*N0-PP ) = EMIN
RETURN
*
* End of SLASQ6
*
END
SUBROUTINE SPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
CHARACTER COMPZ
INTEGER INFO, LDZ, N
* ..
* .. Array Arguments ..
REAL D( * ), E( * ), WORK( * ), Z( LDZ, * )
* ..
* Common block to return operation count and iteration count
* ITCNT is initialized to 0, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SPTEQR computes all eigenvalues and, optionally, eigenvectors of a
* symmetric positive definite tridiagonal matrix by first factoring the
* matrix using SPTTRF, and then calling SBDSQR to compute the singular
* values of the bidiagonal factor.
*
* This routine computes the eigenvalues of the positive definite
* tridiagonal matrix to high relative accuracy. This means that if the
* eigenvalues range over many orders of magnitude in size, then the
* small eigenvalues and corresponding eigenvectors will be computed
* more accurately than, for example, with the standard QR method.
*
* The eigenvectors of a full or band symmetric positive definite matrix
* can also be found if SSYTRD, SSPTRD, or SSBTRD has been used to
* reduce this matrix to tridiagonal form. (The reduction to tridiagonal
* form, however, may preclude the possibility of obtaining high
* relative accuracy in the small eigenvalues of the original matrix, if
* these eigenvalues range over many orders of magnitude.)
*
* Arguments
* =========
*
* COMPZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only.
* = 'V': Compute eigenvectors of original symmetric
* matrix also. Array Z contains the orthogonal
* matrix used to reduce the original matrix to
* tridiagonal form.
* = 'I': Compute eigenvectors of tridiagonal matrix also.
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) REAL array, dimension (N)
* On entry, the n diagonal elements of the tridiagonal
* matrix.
* On normal exit, D contains the eigenvalues, in descending
* order.
*
* E (input/output) REAL array, dimension (N-1)
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix.
* On exit, E has been destroyed.
*
* Z (input/output) REAL array, dimension (LDZ, N)
* On entry, if COMPZ = 'V', the orthogonal matrix used in the
* reduction to tridiagonal form.
* On exit, if COMPZ = 'V', the orthonormal eigenvectors of the
* original symmetric matrix;
* if COMPZ = 'I', the orthonormal eigenvectors of the
* tridiagonal matrix.
* If INFO > 0 on exit, Z contains the eigenvectors associated
* with only the stored eigenvalues.
* If COMPZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* COMPZ = 'V' or 'I', LDZ >= max(1,N).
*
* WORK (workspace) REAL array, dimension (4*N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = i, and i is:
* <= N the Cholesky factorization of the matrix could
* not be performed because the i-th principal minor
* was not positive definite.
* > N the SVD algorithm failed to converge;
* if INFO = N+i, i off-diagonal elements of the
* bidiagonal factor did not converge to zero.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SBDSQR, SLASET, SPTTRF, XERBLA
* ..
* .. Local Arrays ..
REAL C( 1, 1 ), VT( 1, 1 )
* ..
* .. Local Scalars ..
INTEGER I, ICOMPZ, NRU
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( LSAME( COMPZ, 'N' ) ) THEN
ICOMPZ = 0
ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
ICOMPZ = 1
ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
ICOMPZ = 2
ELSE
ICOMPZ = -1
END IF
IF( ICOMPZ.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
$ N ) ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SPTEQR', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( ICOMPZ.GT.0 )
$ Z( 1, 1 ) = ONE
RETURN
END IF
IF( ICOMPZ.EQ.2 )
$ CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
*
* Call SPTTRF to factor the matrix.
*
OPS = OPS + 5*N - 4
CALL SPTTRF( N, D, E, INFO )
IF( INFO.NE.0 )
$ RETURN
DO 10 I = 1, N
D( I ) = SQRT( D( I ) )
10 CONTINUE
DO 20 I = 1, N - 1
E( I ) = E( I )*D( I )
20 CONTINUE
*
* Call SBDSQR to compute the singular values/vectors of the
* bidiagonal factor.
*
IF( ICOMPZ.GT.0 ) THEN
NRU = N
ELSE
NRU = 0
END IF
CALL SBDSQR( 'Lower', N, 0, NRU, 0, D, E, VT, 1, Z, LDZ, C, 1,
$ WORK, INFO )
*
* Square the singular values.
*
IF( INFO.EQ.0 ) THEN
OPS = OPS + N
DO 30 I = 1, N
D( I ) = D( I )*D( I )
30 CONTINUE
ELSE
INFO = N + INFO
END IF
*
RETURN
*
* End of SPTEQR
*
END
SUBROUTINE SSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E,
$ M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK,
$ INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER ORDER, RANGE
INTEGER IL, INFO, IU, M, N, NSPLIT
REAL ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * )
REAL D( * ), E( * ), W( * ), WORK( * )
* ..
* Common block to return operation count and iteration count
* ITCNT is initialized to 0, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SSTEBZ computes the eigenvalues of a symmetric tridiagonal
* matrix T. The user may ask for all eigenvalues, all eigenvalues
* in the half-open interval (VL, VU], or the IL-th through IU-th
* eigenvalues.
*
* To avoid overflow, the matrix must be scaled so that its
* largest element is no greater than overflow**(1/2) *
* underflow**(1/4) in absolute value, and for greatest
* accuracy, it should not be much smaller than that.
*
* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
* Matrix", Report CS41, Computer Science Dept., Stanford
* University, July 21, 1966.
*
* Arguments
* =========
*
* RANGE (input) CHARACTER
* = 'A': ("All") all eigenvalues will be found.
* = 'V': ("Value") all eigenvalues in the half-open interval
* (VL, VU] will be found.
* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
* entire matrix) will be found.
*
* ORDER (input) CHARACTER
* = 'B': ("By Block") the eigenvalues will be grouped by
* split-off block (see IBLOCK, ISPLIT) and
* ordered from smallest to largest within
* the block.
* = 'E': ("Entire matrix")
* the eigenvalues for the entire matrix
* will be ordered from smallest to
* largest.
*
* N (input) INTEGER
* The order of the tridiagonal matrix T. N >= 0.
*
* VL (input) REAL
* VU (input) REAL
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. Eigenvalues less than or equal
* to VL, or greater than VU, will not be returned. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* ABSTOL (input) REAL
* The absolute tolerance for the eigenvalues. An eigenvalue
* (or cluster) is considered to be located if it has been
* determined to lie in an interval whose width is ABSTOL or
* less. If ABSTOL is less than or equal to zero, then ULP*|T|
* will be used, where |T| means the 1-norm of T.
*
* Eigenvalues will be computed most accurately when ABSTOL is
* set to twice the underflow threshold 2*SLAMCH('S'), not zero.
*
* D (input) REAL array, dimension (N)
* The n diagonal elements of the tridiagonal matrix T.
*
* E (input) REAL array, dimension (N-1)
* The (n-1) off-diagonal elements of the tridiagonal matrix T.
*
* M (output) INTEGER
* The actual number of eigenvalues found. 0 <= M <= N.
* (See also the description of INFO=2,3.)
*
* NSPLIT (output) INTEGER
* The number of diagonal blocks in the matrix T.
* 1 <= NSPLIT <= N.
*
* W (output) REAL array, dimension (N)
* On exit, the first M elements of W will contain the
* eigenvalues. (SSTEBZ may use the remaining N-M elements as
* workspace.)
*
* IBLOCK (output) INTEGER array, dimension (N)
* At each row/column j where E(j) is zero or small, the
* matrix T is considered to split into a block diagonal
* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which
* block (from 1 to the number of blocks) the eigenvalue W(i)
* belongs. (SSTEBZ may use the remaining N-M elements as
* workspace.)
*
* ISPLIT (output) INTEGER array, dimension (N)
* The splitting points, at which T breaks up into submatrices.
* The first submatrix consists of rows/columns 1 to ISPLIT(1),
* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
* etc., and the NSPLIT-th consists of rows/columns
* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
* (Only the first NSPLIT elements will actually be used, but
* since the user cannot know a priori what value NSPLIT will
* have, N words must be reserved for ISPLIT.)
*
* WORK (workspace) REAL array, dimension (4*N)
*
* IWORK (workspace) INTEGER array, dimension (3*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: some or all of the eigenvalues failed to converge or
* were not computed:
* =1 or 3: Bisection failed to converge for some
* eigenvalues; these eigenvalues are flagged by a
* negative block number. The effect is that the
* eigenvalues may not be as accurate as the
* absolute and relative tolerances. This is
* generally caused by unexpectedly inaccurate
* arithmetic.
* =2 or 3: RANGE='I' only: Not all of the eigenvalues
* IL:IU were found.
* Effect: M < IU+1-IL
* Cause: non-monotonic arithmetic, causing the
* Sturm sequence to be non-monotonic.
* Cure: recalculate, using RANGE='A', and pick
* out eigenvalues IL:IU. In some cases,
* increasing the PARAMETER "FUDGE" may
* make things work.
* = 4: RANGE='I', and the Gershgorin interval
* initially used was too small. No eigenvalues
* were computed.
* Probable cause: your machine has sloppy
* floating-point arithmetic.
* Cure: Increase the PARAMETER "FUDGE",
* recompile, and try again.
*
* Internal Parameters
* ===================
*
* RELFAC REAL, default = 2.0e0
* The relative tolerance. An interval (a,b] lies within
* "relative tolerance" if b-a < RELFAC*ulp*max(|a|,|b|),
* where "ulp" is the machine precision (distance from 1 to
* the next larger floating point number.)
*
* FUDGE REAL, default = 2
* A "fudge factor" to widen the Gershgorin intervals. Ideally,
* a value of 1 should work, but on machines with sloppy
* arithmetic, this needs to be larger. The default for
* publicly released versions should be large enough to handle
* the worst machine around. Note that this has no effect
* on accuracy of the solution.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO, HALF
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ HALF = 1.0E0 / TWO )
REAL FUDGE, RELFAC
PARAMETER ( FUDGE = 2.0E0, RELFAC = 2.0E0 )
* ..
* .. Local Scalars ..
LOGICAL NCNVRG, TOOFEW
INTEGER IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO,
$ IM, IN, IOFF, IORDER, IOUT, IRANGE, ITMAX,
$ ITMP1, IW, IWOFF, J, JB, JDISC, JE, NB, NWL,
$ NWU
REAL ATOLI, BNORM, GL, GU, PIVMIN, RTOLI, SAFEMN,
$ TMP1, TMP2, TNORM, ULP, WKILL, WL, WLU, WU, WUL
* ..
* .. Local Arrays ..
INTEGER IDUMMA( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
REAL SLAMCH
EXTERNAL LSAME, ILAENV, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SLAEBZ, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Decode RANGE
*
IF( LSAME( RANGE, 'A' ) ) THEN
IRANGE = 1
ELSE IF( LSAME( RANGE, 'V' ) ) THEN
IRANGE = 2
ELSE IF( LSAME( RANGE, 'I' ) ) THEN
IRANGE = 3
ELSE
IRANGE = 0
END IF
*
* Decode ORDER
*
IF( LSAME( ORDER, 'B' ) ) THEN
IORDER = 2
ELSE IF( LSAME( ORDER, 'E' ) ) THEN
IORDER = 1
ELSE
IORDER = 0
END IF
*
* Check for Errors
*
IF( IRANGE.LE.0 ) THEN
INFO = -1
ELSE IF( IORDER.LE.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( IRANGE.EQ.2 ) THEN
IF( VL.GE.VU ) INFO = -5
ELSE IF( IRANGE.EQ.3 .AND. ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) )
$ THEN
INFO = -6
ELSE IF( IRANGE.EQ.3 .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) )
$ THEN
INFO = -7
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSTEBZ', -INFO )
RETURN
END IF
*
* Initialize error flags
*
INFO = 0
NCNVRG = .FALSE.
TOOFEW = .FALSE.
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 )
$ RETURN
*
* Simplifications:
*
IF( IRANGE.EQ.3 .AND. IL.EQ.1 .AND. IU.EQ.N )
$ IRANGE = 1
*
* Get machine constants
* NB is the minimum vector length for vector bisection, or 0
* if only scalar is to be done.
*
SAFEMN = SLAMCH( 'S' )
ULP = SLAMCH( 'P' )
OPS = OPS + 1
RTOLI = ULP*RELFAC
NB = ILAENV( 1, 'SSTEBZ', ' ', N, -1, -1, -1 )
IF( NB.LE.1 )
$ NB = 0
*
* Special Case when N=1
*
IF( N.EQ.1 ) THEN
NSPLIT = 1
ISPLIT( 1 ) = 1
IF( IRANGE.EQ.2 .AND. ( VL.GE.D( 1 ) .OR. VU.LT.D( 1 ) ) ) THEN
M = 0
ELSE
W( 1 ) = D( 1 )
IBLOCK( 1 ) = 1
M = 1
END IF
RETURN
END IF
*
* Compute Splitting Points
*
NSPLIT = 1
WORK( N ) = ZERO
PIVMIN = ONE
*
OPS = OPS + ( N-1 )*5 + 1
CDIR$ NOVECTOR
DO 10 J = 2, N
TMP1 = E( J-1 )**2
IF( ABS( D( J )*D( J-1 ) )*ULP**2+SAFEMN.GT.TMP1 ) THEN
ISPLIT( NSPLIT ) = J - 1
NSPLIT = NSPLIT + 1
WORK( J-1 ) = ZERO
ELSE
WORK( J-1 ) = TMP1
PIVMIN = MAX( PIVMIN, TMP1 )
END IF
10 CONTINUE
ISPLIT( NSPLIT ) = N
PIVMIN = PIVMIN*SAFEMN
*
* Compute Interval and ATOLI
*
IF( IRANGE.EQ.3 ) THEN
*
* RANGE='I': Compute the interval containing eigenvalues
* IL through IU.
*
* Compute Gershgorin interval for entire (split) matrix
* and use it as the initial interval
*
GU = D( 1 )
GL = D( 1 )
TMP1 = ZERO
*
OPS = OPS + 5*( N-1 ) + 23
DO 20 J = 1, N - 1
TMP2 = SQRT( WORK( J ) )
GU = MAX( GU, D( J )+TMP1+TMP2 )
GL = MIN( GL, D( J )-TMP1-TMP2 )
TMP1 = TMP2
20 CONTINUE
*
GU = MAX( GU, D( N )+TMP1 )
GL = MIN( GL, D( N )-TMP1 )
TNORM = MAX( ABS( GL ), ABS( GU ) )
GL = GL - FUDGE*TNORM*ULP*N - FUDGE*TWO*PIVMIN
GU = GU + FUDGE*TNORM*ULP*N + FUDGE*PIVMIN
*
* Compute Iteration parameters
*
ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) /
$ LOG( TWO ) ) + 2
IF( ABSTOL.LE.ZERO ) THEN
ATOLI = ULP*TNORM
ELSE
ATOLI = ABSTOL
END IF
*
WORK( N+1 ) = GL
WORK( N+2 ) = GL
WORK( N+3 ) = GU
WORK( N+4 ) = GU
WORK( N+5 ) = GL
WORK( N+6 ) = GU
IWORK( 1 ) = -1
IWORK( 2 ) = -1
IWORK( 3 ) = N + 1
IWORK( 4 ) = N + 1
IWORK( 5 ) = IL - 1
IWORK( 6 ) = IU
*
CALL SLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN, D, E,
$ WORK, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT,
$ IWORK, W, IBLOCK, IINFO )
*
IF( IWORK( 6 ).EQ.IU ) THEN
WL = WORK( N+1 )
WLU = WORK( N+3 )
NWL = IWORK( 1 )
WU = WORK( N+4 )
WUL = WORK( N+2 )
NWU = IWORK( 4 )
ELSE
WL = WORK( N+2 )
WLU = WORK( N+4 )
NWL = IWORK( 2 )
WU = WORK( N+3 )
WUL = WORK( N+1 )
NWU = IWORK( 3 )
END IF
*
IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN
INFO = 4
RETURN
END IF
ELSE
*
* RANGE='A' or 'V' -- Set ATOLI
*
OPS = OPS + 3 + 2*( N-2 )
TNORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ),
$ ABS( D( N ) )+ABS( E( N-1 ) ) )
*
DO 30 J = 2, N - 1
TNORM = MAX( TNORM, ABS( D( J ) )+ABS( E( J-1 ) )+
$ ABS( E( J ) ) )
30 CONTINUE
*
IF( ABSTOL.LE.ZERO ) THEN
ATOLI = ULP*TNORM
ELSE
ATOLI = ABSTOL
END IF
*
IF( IRANGE.EQ.2 ) THEN
WL = VL
WU = VU
ELSE
WL = ZERO
WU = ZERO
END IF
END IF
*
* Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU.
* NWL accumulates the number of eigenvalues .le. WL,
* NWU accumulates the number of eigenvalues .le. WU
*
M = 0
IEND = 0
INFO = 0
NWL = 0
NWU = 0
*
DO 70 JB = 1, NSPLIT
IOFF = IEND
IBEGIN = IOFF + 1
IEND = ISPLIT( JB )
IN = IEND - IOFF
*
IF( IN.EQ.1 ) THEN
*
* Special Case -- IN=1
*
OPS = OPS + 4
IF( IRANGE.EQ.1 .OR. WL.GE.D( IBEGIN )-PIVMIN )
$ NWL = NWL + 1
IF( IRANGE.EQ.1 .OR. WU.GE.D( IBEGIN )-PIVMIN )
$ NWU = NWU + 1
IF( IRANGE.EQ.1 .OR. ( WL.LT.D( IBEGIN )-PIVMIN .AND. WU.GE.
$ D( IBEGIN )-PIVMIN ) ) THEN
M = M + 1
W( M ) = D( IBEGIN )
IBLOCK( M ) = JB
END IF
ELSE
*
* General Case -- IN > 1
*
* Compute Gershgorin Interval
* and use it as the initial interval
*
GU = D( IBEGIN )
GL = D( IBEGIN )
TMP1 = ZERO
*
OPS = OPS + 4*( IEND-IBEGIN ) + 13
DO 40 J = IBEGIN, IEND - 1
TMP2 = ABS( E( J ) )
GU = MAX( GU, D( J )+TMP1+TMP2 )
GL = MIN( GL, D( J )-TMP1-TMP2 )
TMP1 = TMP2
40 CONTINUE
*
GU = MAX( GU, D( IEND )+TMP1 )
GL = MIN( GL, D( IEND )-TMP1 )
BNORM = MAX( ABS( GL ), ABS( GU ) )
GL = GL - FUDGE*BNORM*ULP*IN - FUDGE*PIVMIN
GU = GU + FUDGE*BNORM*ULP*IN + FUDGE*PIVMIN
*
* Compute ATOLI for the current submatrix
*
IF( ABSTOL.LE.ZERO ) THEN
ATOLI = ULP*MAX( ABS( GL ), ABS( GU ) )
ELSE
ATOLI = ABSTOL
END IF
*
IF( IRANGE.GT.1 ) THEN
IF( GU.LT.WL ) THEN
NWL = NWL + IN
NWU = NWU + IN
GO TO 70
END IF
GL = MAX( GL, WL )
GU = MIN( GU, WU )
IF( GL.GE.GU )
$ GO TO 70
END IF
*
* Set Up Initial Interval
*
WORK( N+1 ) = GL
WORK( N+IN+1 ) = GU
CALL SLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
$ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ),
$ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM,
$ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
*
NWL = NWL + IWORK( 1 )
NWU = NWU + IWORK( IN+1 )
IWOFF = M - IWORK( 1 )
*
* Compute Eigenvalues
*
OPS = OPS + 8
ITMAX = INT( ( LOG( GU-GL+PIVMIN )-LOG( PIVMIN ) ) /
$ LOG( TWO ) ) + 2
CALL SLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
$ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ),
$ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT,
$ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
*
* Copy Eigenvalues Into W and IBLOCK
* Use -JB for block number for unconverged eigenvalues.
*
OPS = OPS + 2*IOUT
DO 60 J = 1, IOUT
TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) )
*
* Flag non-convergence.
*
IF( J.GT.IOUT-IINFO ) THEN
NCNVRG = .TRUE.
IB = -JB
ELSE
IB = JB
END IF
DO 50 JE = IWORK( J ) + 1 + IWOFF,
$ IWORK( J+IN ) + IWOFF
W( JE ) = TMP1
IBLOCK( JE ) = IB
50 CONTINUE
60 CONTINUE
*
M = M + IM
END IF
70 CONTINUE
*
* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU
* If NWL+1 < IL or NWU > IU, discard extra eigenvalues.
*
IF( IRANGE.EQ.3 ) THEN
IM = 0
IDISCL = IL - 1 - NWL
IDISCU = NWU - IU
*
IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
DO 80 JE = 1, M
IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN
IDISCL = IDISCL - 1
ELSE IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN
IDISCU = IDISCU - 1
ELSE
IM = IM + 1
W( IM ) = W( JE )
IBLOCK( IM ) = IBLOCK( JE )
END IF
80 CONTINUE
M = IM
END IF
IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
*
* Code to deal with effects of bad arithmetic:
* Some low eigenvalues to be discarded are not in (WL,WLU],
* or high eigenvalues to be discarded are not in (WUL,WU]
* so just kill off the smallest IDISCL/largest IDISCU
* eigenvalues, by simply finding the smallest/largest
* eigenvalue(s).
*
* (If N(w) is monotone non-decreasing, this should never
* happen.)
*
IF( IDISCL.GT.0 ) THEN
WKILL = WU
DO 100 JDISC = 1, IDISCL
IW = 0
DO 90 JE = 1, M
IF( IBLOCK( JE ).NE.0 .AND.
$ ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN
IW = JE
WKILL = W( JE )
END IF
90 CONTINUE
IBLOCK( IW ) = 0
100 CONTINUE
END IF
IF( IDISCU.GT.0 ) THEN
*
WKILL = WL
DO 120 JDISC = 1, IDISCU
IW = 0
DO 110 JE = 1, M
IF( IBLOCK( JE ).NE.0 .AND.
$ ( W( JE ).GT.WKILL .OR. IW.EQ.0 ) ) THEN
IW = JE
WKILL = W( JE )
END IF
110 CONTINUE
IBLOCK( IW ) = 0
120 CONTINUE
END IF
IM = 0
DO 130 JE = 1, M
IF( IBLOCK( JE ).NE.0 ) THEN
IM = IM + 1
W( IM ) = W( JE )
IBLOCK( IM ) = IBLOCK( JE )
END IF
130 CONTINUE
M = IM
END IF
IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN
TOOFEW = .TRUE.
END IF
END IF
*
* If ORDER='B', do nothing -- the eigenvalues are already sorted
* by block.
* If ORDER='E', sort the eigenvalues from smallest to largest
*
IF( IORDER.EQ.1 .AND. NSPLIT.GT.1 ) THEN
DO 150 JE = 1, M - 1
IE = 0
TMP1 = W( JE )
DO 140 J = JE + 1, M
IF( W( J ).LT.TMP1 ) THEN
IE = J
TMP1 = W( J )
END IF
140 CONTINUE
*
IF( IE.NE.0 ) THEN
ITMP1 = IBLOCK( IE )
W( IE ) = W( JE )
IBLOCK( IE ) = IBLOCK( JE )
W( JE ) = TMP1
IBLOCK( JE ) = ITMP1
END IF
150 CONTINUE
END IF
*
INFO = 0
IF( NCNVRG )
$ INFO = INFO + 1
IF( TOOFEW )
$ INFO = INFO + 2
RETURN
*
* End of SSTEBZ
*
END
SUBROUTINE SSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK,
$ LIWORK, INFO )
*
* -- LAPACK driver routine (instrum. to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER COMPZ
INTEGER INFO, LDZ, LIWORK, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL D( * ), E( * ), WORK( * ), Z( LDZ, * )
* ..
* Common block to return operation count and iteration count
* ITCNT is initialized to 0, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SSTEDC computes all eigenvalues and, optionally, eigenvectors of a
* symmetric tridiagonal matrix using the divide and conquer method.
* The eigenvectors of a full or band real symmetric matrix can also be
* found if SSYTRD or SSPTRD or SSBTRD has been used to reduce this
* matrix to tridiagonal form.
*
* This code makes very mild assumptions about floating point
* arithmetic. It will work on machines with a guard digit in
* add/subtract, or on those binary machines without guard digits
* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
* It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none. See SLAED3 for details.
*
* Arguments
* =========
*
* COMPZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only.
* = 'I': Compute eigenvectors of tridiagonal matrix also.
* = 'V': Compute eigenvectors of original dense symmetric
* matrix also. On entry, Z contains the orthogonal
* matrix used to reduce the original matrix to
* tridiagonal form.
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* D (input/output) REAL array, dimension (N)
* On entry, the diagonal elements of the tridiagonal matrix.
* On exit, if INFO = 0, the eigenvalues in ascending order.
*
* E (input/output) REAL array, dimension (N-1)
* On entry, the subdiagonal elements of the tridiagonal matrix.
* On exit, E has been destroyed.
*
* Z (input/output) REAL array, dimension (LDZ,N)
* On entry, if COMPZ = 'V', then Z contains the orthogonal
* matrix used in the reduction to tridiagonal form.
* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
* orthonormal eigenvectors of the original symmetric matrix,
* and if COMPZ = 'I', Z contains the orthonormal eigenvectors
* of the symmetric tridiagonal matrix.
* If COMPZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1.
* If eigenvectors are desired, then LDZ >= max(1,N).
*
* WORK (workspace/output) REAL array,
* dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* If COMPZ = 'N' or N <= 1 then LWORK must be at least 1.
* If COMPZ = 'V' and N > 1 then LWORK must be at least
* ( 1 + 3*N + 2*N*lg N + 3*N**2 ),
* where lg( N ) = smallest integer k such
* that 2**k >= N.
* If COMPZ = 'I' and N > 1 then LWORK must be at least
* ( 1 + 4*N + N**2 ).
*
* 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.
*
* IWORK (workspace/output) INTEGER array, dimension (LIWORK)
* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK.
* If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1.
* If COMPZ = 'V' and N > 1 then LIWORK must be at least
* ( 6 + 6*N + 5*N*lg N ).
* If COMPZ = 'I' and N > 1 then LIWORK must be at least
* ( 3 + 5*N ).
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal size of the IWORK array,
* returns this value as the first entry of the IWORK array, and
* no error message related to LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: The algorithm failed to compute an eigenvalue while
* working on the submatrix lying in rows and columns
* INFO/(N+1) through mod(INFO,N+1).
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
* Modified by Francoise Tisseur, University of Tennessee.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER END, I, ICOMPZ, II, J, K, LGN, LIWMIN, LWMIN,
$ M, SMLSIZ, START, STOREZ, STRTRW
REAL EPS, ORGNRM, P, TINY
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
REAL SLAMCH, SLANST
EXTERNAL ILAENV, LSAME, SLAMCH, SLANST
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SLACPY, SLAED0, SLASCL, SLASET, SLASRT,
$ SSTEQR, SSTERF, SSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX, MOD, REAL, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
IF( LSAME( COMPZ, 'N' ) ) THEN
ICOMPZ = 0
ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
ICOMPZ = 1
ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
ICOMPZ = 2
ELSE
ICOMPZ = -1
END IF
IF( N.LE.1 .OR. ICOMPZ.LE.0 ) THEN
LIWMIN = 1
LWMIN = 1
ELSE
LGN = INT( LOG( REAL( N ) ) / LOG( TWO ) )
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IF( ICOMPZ.EQ.1 ) THEN
LWMIN = 1 + 3*N + 2*N*LGN + 3*N**2
LIWMIN = 6 + 6*N + 5*N*LGN
ELSE IF( ICOMPZ.EQ.2 ) THEN
LWMIN = 1 + 4*N + N**2
LIWMIN = 3 + 5*N
END IF
END IF
IF( ICOMPZ.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
$ N ) ) ) THEN
INFO = -6
ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -8
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -10
END IF
*
IF( INFO.EQ.0 ) THEN
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSTEDC', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
ITCNT = 0
IF( N.EQ.0 )
$ RETURN
IF( N.EQ.1 ) THEN
IF( ICOMPZ.NE.0 )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
SMLSIZ = ILAENV( 9, 'SSTEDC', ' ', 0, 0, 0, 0 )
*
* If the following conditional clause is removed, then the routine
* will use the Divide and Conquer routine to compute only the
* eigenvalues, which requires (3N + 3N**2) real workspace and
* (2 + 5N + 2N lg(N)) integer workspace.
* Since on many architectures SSTERF is much faster than any other
* algorithm for finding eigenvalues only, it is used here
* as the default.
*
* If COMPZ = 'N', use SSTERF to compute the eigenvalues.
*
IF( ICOMPZ.EQ.0 ) THEN
CALL SSTERF( N, D, E, INFO )
RETURN
END IF
*
* If N is smaller than the minimum divide size (SMLSIZ+1), then
* solve the problem with another solver.
*
IF( N.LE.SMLSIZ ) THEN
IF( ICOMPZ.EQ.0 ) THEN
CALL SSTERF( N, D, E, INFO )
RETURN
ELSE IF( ICOMPZ.EQ.2 ) THEN
CALL SSTEQR( 'I', N, D, E, Z, LDZ, WORK, INFO )
RETURN
ELSE
CALL SSTEQR( 'V', N, D, E, Z, LDZ, WORK, INFO )
RETURN
END IF
END IF
*
* If COMPZ = 'V', the Z matrix must be stored elsewhere for later
* use.
*
IF( ICOMPZ.EQ.1 ) THEN
STOREZ = 1 + N*N
ELSE
STOREZ = 1
END IF
*
IF( ICOMPZ.EQ.2 ) THEN
CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
END IF
*
* Scale.
*
ORGNRM = SLANST( 'M', N, D, E )
IF( ORGNRM.EQ.ZERO )
$ RETURN
*
EPS = SLAMCH( 'Epsilon' )
*
START = 1
*
* while ( START <= N )
*
10 CONTINUE
IF( START.LE.N ) THEN
*
* Let END be the position of the next subdiagonal entry such that
* E( END ) <= TINY or END = N if no such subdiagonal exists. The
* matrix identified by the elements between START and END
* constitutes an independent sub-problem.
*
END = START
20 CONTINUE
IF( END.LT.N ) THEN
OPS = OPS + 4
TINY = EPS*SQRT( ABS( D( END ) ) )*SQRT( ABS( D( END+1 ) ) )
IF( ABS( E( END ) ).GT.TINY ) THEN
END = END + 1
GO TO 20
END IF
END IF
*
* (Sub) Problem determined. Compute its size and solve it.
*
M = END - START + 1
IF( M.EQ.1 ) THEN
START = END + 1
GO TO 10
END IF
IF( M.GT.SMLSIZ ) THEN
INFO = SMLSIZ
*
* Scale.
*
ORGNRM = SLANST( 'M', M, D( START ), E( START ) )
OPS = OPS + 2*M - 1
CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ), M,
$ INFO )
CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1, E( START ),
$ M-1, INFO )
*
IF( ICOMPZ.EQ.1 ) THEN
STRTRW = 1
ELSE
STRTRW = START
END IF
CALL SLAED0( ICOMPZ, N, M, D( START ), E( START ),
$ Z( STRTRW, START ), LDZ, WORK( 1 ), N,
$ WORK( STOREZ ), IWORK, INFO )
IF( INFO.NE.0 ) THEN
INFO = ( INFO / ( M+1 )+START-1 )*( N+1 ) +
$ MOD( INFO, ( M+1 ) ) + START - 1
RETURN
END IF
*
* Scale back.
*
OPS = OPS + M
CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ), M,
$ INFO )
*
ELSE
IF( ICOMPZ.EQ.1 ) THEN
*
* Since QR won't update a Z matrix which is larger than the
* length of D, we must solve the sub-problem in a workspace and
* then multiply back into Z.
*
CALL SSTEQR( 'I', M, D( START ), E( START ), WORK, M,
$ WORK( M*M+1 ), INFO )
CALL SLACPY( 'A', N, M, Z( 1, START ), LDZ,
$ WORK( STOREZ ), N )
OPS = OPS + 2*REAL( N )*M*M
CALL SGEMM( 'N', 'N', N, M, M, ONE, WORK( STOREZ ), LDZ,
$ WORK, M, ZERO, Z( 1, START ), LDZ )
ELSE IF( ICOMPZ.EQ.2 ) THEN
CALL SSTEQR( 'I', M, D( START ), E( START ),
$ Z( START, START ), LDZ, WORK, INFO )
ELSE
CALL SSTERF( M, D( START ), E( START ), INFO )
END IF
IF( INFO.NE.0 ) THEN
INFO = START*( N+1 ) + END
RETURN
END IF
END IF
*
START = END + 1
GO TO 10
END IF
*
* endwhile
*
* If the problem split any number of times, then the eigenvalues
* will not be properly ordered. Here we permute the eigenvalues
* (and the associated eigenvectors) into ascending order.
*
IF( M.NE.N ) THEN
IF( ICOMPZ.EQ.0 ) THEN
*
* Use Quick Sort
*
CALL SLASRT( 'I', N, D, INFO )
*
ELSE
*
* Use Selection Sort to minimize swaps of eigenvectors
*
DO 40 II = 2, N
I = II - 1
K = I
P = D( I )
DO 30 J = II, N
IF( D( J ).LT.P ) THEN
K = J
P = D( J )
END IF
30 CONTINUE
IF( K.NE.I ) THEN
D( K ) = D( I )
D( I ) = P
CALL SSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
END IF
40 CONTINUE
END IF
END IF
*
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
RETURN
*
* End of SSTEDC
*
END
SUBROUTINE SSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL,
$ M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK,
$ LIWORK, INFO )
*
* -- LAPACK computational routine (instru to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE
INTEGER IL, INFO, IU, LDZ, LIWORK, LWORK, M, N
REAL ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER ISUPPZ( * ), IWORK( * )
REAL D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
* Common block to return operation count
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SSTEGR computes eigenvalues by the dqds algorithm, while
* orthogonal eigenvectors are computed from various "good" L D L^T
* representations (also known as Relatively Robust Representations).
* Gram-Schmidt orthogonalization is avoided as far as possible. More
* specifically, the various steps of the algorithm are as follows.
* For the i-th unreduced block of T,
* (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T
* is a relatively robust representation,
* (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high
* relative accuracy by the dqds algorithm,
* (c) If there is a cluster of close eigenvalues, "choose" sigma_i
* close to the cluster, and go to step (a),
* (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T,
* compute the corresponding eigenvector by forming a
* rank-revealing twisted factorization.
* The desired accuracy of the output can be specified by the input
* parameter ABSTOL.
*
* For more details, see "A new O(n^2) algorithm for the symmetric
* tridiagonal eigenvalue/eigenvector problem", by Inderjit Dhillon,
* Computer Science Division Technical Report No. UCB/CSD-97-971,
* UC Berkeley, May 1997.
*
* Note 1 : Currently SSTEGR is only set up to find ALL the n
* eigenvalues and eigenvectors of T in O(n^2) time
* Note 2 : Currently the routine SSTEIN is called when an appropriate
* sigma_i cannot be chosen in step (c) above. SSTEIN invokes modified
* Gram-Schmidt when eigenvalues are close.
* Note 3 : SSTEGR works only on machines which follow ieee-754
* floating-point standard in their handling of infinities and NaNs.
* Normal execution of SSTEGR may create NaNs and infinities and hence
* may abort due to a floating point exception in environments which
* do not conform to the ieee standard.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* RANGE (input) CHARACTER*1
* = 'A': all eigenvalues will be found.
* = 'V': all eigenvalues in the half-open interval (VL,VU]
* will be found.
* = 'I': the IL-th through IU-th eigenvalues will be found.
********** Only RANGE = 'A' is currently supported *********************
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) REAL array, dimension (N)
* On entry, the n diagonal elements of the tridiagonal matrix
* T. On exit, D is overwritten.
*
* E (input/output) REAL array, dimension (N)
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix T in elements 1 to N-1 of E; E(N) need not be set.
* On exit, E is overwritten.
*
* VL (input) REAL
* VU (input) REAL
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* ABSTOL (input) REAL
* The absolute error tolerance for the
* eigenvalues/eigenvectors. IF JOBZ = 'V', the eigenvalues and
* eigenvectors output have residual norms bounded by ABSTOL,
* and the dot products between different eigenvectors are
* bounded by ABSTOL. If ABSTOL is less than N*EPS*|T|, then
* N*EPS*|T| will be used in its place, where EPS is the
* machine precision and |T| is the 1-norm of the tridiagonal
* matrix. The eigenvalues are computed to an accuracy of
* EPS*|T| irrespective of ABSTOL. If high relative accuracy
* is important, set ABSTOL to DLAMCH( 'Safe minimum' ).
* See Barlow and Demmel "Computing Accurate Eigensystems of
* Scaled Diagonally Dominant Matrices", LAPACK Working Note #7
* for a discussion of which matrices define their eigenvalues
* to high relative accuracy.
*
* M (output) INTEGER
* The total number of eigenvalues found. 0 <= M <= N.
* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*
* W (output) REAL array, dimension (N)
* The first M elements contain the selected eigenvalues in
* ascending order.
*
* Z (output) REAL array, dimension (LDZ, max(1,M) )
* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
* contain the orthonormal eigenvectors of the matrix T
* corresponding to the selected eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* If JOBZ = 'N', then Z is not referenced.
* Note: the user must ensure that at least max(1,M) columns are
* supplied in the array Z; if RANGE = 'V', the exact value of M
* is not known in advance and an upper bound must be used.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
* The support of the eigenvectors in Z, i.e., the indices
* indicating the nonzero elements in Z. The i-th eigenvector
* is nonzero only in elements ISUPPZ( 2*i-1 ) through
* ISUPPZ( 2*i ).
*
* WORK (workspace/output) REAL array, dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns the optimal
* (and minimal) LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK. LWORK >= max(1,18*N)
*
* 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.
*
* IWORK (workspace/output) INTEGER array, dimension (LIWORK)
* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK. LIWORK >= max(1,10*N)
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal size of the IWORK array,
* returns this value as the first entry of the IWORK array, and
* no error message related to LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = 1, internal error in SLARRE,
* if INFO = 2, internal error in SLARRV.
*
* Further Details
* ===============
*
* Based on contributions by
* Inderjit Dhillon, IBM Almaden, USA
* Osni Marques, LBNL/NERSC, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, LQUERY, VALEIG, WANTZ
INTEGER I, IBEGIN, IEND, IINDBL, IINDWK, IINFO, IINSPL,
$ INDGRS, INDWOF, INDWRK, ITMP, J, JJ, LIWMIN,
$ LWMIN, NSPLIT
REAL BIGNUM, EPS, RMAX, RMIN, SAFMIN, SCALE, SMLNUM,
$ THRESH, TMP, TNRM, TOL
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANST
EXTERNAL LSAME, SLAMCH, SLANST
* ..
* .. External Subroutines ..
EXTERNAL SLARRE, SLARRV, SLASET, SSCAL, SSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
*
LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LIWORK.EQ.-1 ) )
LWMIN = 18*N
LIWMIN = 10*N
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
INFO = -2
*
* The following two lines need to be removed once the
* RANGE = 'V' and RANGE = 'I' options are provided.
*
ELSE IF( VALEIG .OR. INDEIG ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( VALEIG .AND. N.GT.0 .AND. VU.LE.VL ) THEN
INFO = -7
ELSE IF( INDEIG .AND. IL.LT.1 ) THEN
INFO = -8
* The following change should be made in DSTEVX also, otherwise
* IL can be specified as N+1 and IU as N.
* ELSE IF( INDEIG .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) THEN
ELSE IF( INDEIG .AND. ( IU.LT.IL .OR. IU.GT.N ) ) THEN
INFO = -9
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -14
ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -17
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -19
END IF
IF( INFO.EQ.0 ) THEN
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSTEGR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( ALLEIG .OR. INDEIG ) THEN
M = 1
W( 1 ) = D( 1 )
ELSE
IF( VL.LT.D( 1 ) .AND. VU.GE.D( 1 ) ) THEN
M = 1
W( 1 ) = D( 1 )
END IF
END IF
IF( WANTZ )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
OPS = OPS + REAL( 7 )
SAFMIN = SLAMCH( 'Safe minimum' )
EPS = SLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
*
* Scale matrix to allowable range, if necessary.
*
SCALE = ONE
TNRM = SLANST( 'M', N, D, E )
IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
OPS = OPS + REAL( 1 )
SCALE = RMIN / TNRM
ELSE IF( TNRM.GT.RMAX ) THEN
OPS = OPS + REAL( 1 )
SCALE = RMAX / TNRM
END IF
IF( SCALE.NE.ONE ) THEN
OPS = OPS + REAL( 2*N )
CALL SSCAL( N, SCALE, D, 1 )
CALL SSCAL( N-1, SCALE, E, 1 )
TNRM = TNRM*SCALE
END IF
INDGRS = 1
INDWOF = 2*N + 1
INDWRK = 3*N + 1
*
IINSPL = 1
IINDBL = N + 1
IINDWK = 2*N + 1
*
CALL SLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ )
*
* Compute the desired eigenvalues of the tridiagonal after splitting
* into smaller subblocks if the corresponding of-diagonal elements
* are small
*
OPS = OPS + REAL( 1 )
THRESH = EPS*TNRM
CALL SLARRE( N, D, E, THRESH, NSPLIT, IWORK( IINSPL ), M, W,
$ WORK( INDWOF ), WORK( INDGRS ), WORK( INDWRK ),
$ IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 1
RETURN
END IF
*
IF( WANTZ ) THEN
*
* Compute the desired eigenvectors corresponding to the computed
* eigenvalues
*
OPS = OPS + REAL( 1 )
TOL = MAX( ABSTOL, REAL( N )*THRESH )
IBEGIN = 1
DO 20 I = 1, NSPLIT
IEND = IWORK( IINSPL+I-1 )
DO 10 J = IBEGIN, IEND
IWORK( IINDBL+J-1 ) = I
10 CONTINUE
IBEGIN = IEND + 1
20 CONTINUE
*
CALL SLARRV( N, D, E, IWORK( IINSPL ), M, W, IWORK( IINDBL ),
$ WORK( INDGRS ), TOL, Z, LDZ, ISUPPZ,
$ WORK( INDWRK ), IWORK( IINDWK ), IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 2
RETURN
END IF
*
END IF
*
IBEGIN = 1
DO 40 I = 1, NSPLIT
IEND = IWORK( IINSPL+I-1 )
DO 30 J = IBEGIN, IEND
OPS = OPS + REAL( 1 )
W( J ) = W( J ) + WORK( INDWOF+I-1 )
30 CONTINUE
IBEGIN = IEND + 1
40 CONTINUE
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( SCALE.NE.ONE ) THEN
CALL SSCAL( M, ONE / SCALE, W, 1 )
END IF
*
* If eigenvalues are not in order, then sort them, along with
* eigenvectors.
*
IF( NSPLIT.GT.1 ) THEN
DO 60 J = 1, M - 1
I = 0
TMP = W( J )
DO 50 JJ = J + 1, M
IF( W( JJ ).LT.TMP ) THEN
I = JJ
TMP = W( JJ )
END IF
50 CONTINUE
IF( I.NE.0 ) THEN
W( I ) = W( J )
W( J ) = TMP
IF( WANTZ ) THEN
CALL SSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
ITMP = ISUPPZ( 2*I-1 )
ISUPPZ( 2*I-1 ) = ISUPPZ( 2*J-1 )
ISUPPZ( 2*J-1 ) = ITMP
ITMP = ISUPPZ( 2*I )
ISUPPZ( 2*I ) = ISUPPZ( 2*J )
ISUPPZ( 2*J ) = ITMP
END IF
END IF
60 CONTINUE
END IF
*
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
RETURN
*
* End of SSTEGR
*
END
SUBROUTINE SSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK,
$ IWORK, IFAIL, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
INTEGER INFO, LDZ, M, N
* ..
* .. Array Arguments ..
INTEGER IBLOCK( * ), IFAIL( * ), ISPLIT( * ),
$ IWORK( * )
REAL D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
* Common block to return operation count and iteration count
* ITCNT is initialized to 0, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SSTEIN computes the eigenvectors of a real symmetric tridiagonal
* matrix T corresponding to specified eigenvalues, using inverse
* iteration.
*
* The maximum number of iterations allowed for each eigenvector is
* specified by an internal parameter MAXITS (currently set to 5).
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input) REAL array, dimension (N)
* The n diagonal elements of the tridiagonal matrix T.
*
* E (input) REAL array, dimension (N)
* The (n-1) subdiagonal elements of the tridiagonal matrix
* T, in elements 1 to N-1. E(N) need not be set.
*
* M (input) INTEGER
* The number of eigenvectors to be found. 0 <= M <= N.
*
* W (input) REAL array, dimension (N)
* The first M elements of W contain the eigenvalues for
* which eigenvectors are to be computed. The eigenvalues
* should be grouped by split-off block and ordered from
* smallest to largest within the block. ( The output array
* W from SSTEBZ with ORDER = 'B' is expected here. )
*
* IBLOCK (input) INTEGER array, dimension (N)
* The submatrix indices associated with the corresponding
* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to
* the first submatrix from the top, =2 if W(i) belongs to
* the second submatrix, etc. ( The output array IBLOCK
* from SSTEBZ is expected here. )
*
* ISPLIT (input) INTEGER array, dimension (N)
* The splitting points, at which T breaks up into submatrices.
* The first submatrix consists of rows/columns 1 to
* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
* through ISPLIT( 2 ), etc.
* ( The output array ISPLIT from SSTEBZ is expected here. )
*
* Z (output) REAL array, dimension (LDZ, M)
* The computed eigenvectors. The eigenvector associated
* with the eigenvalue W(i) is stored in the i-th column of
* Z. Any vector which fails to converge is set to its current
* iterate after MAXITS iterations.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= max(1,N).
*
* WORK (workspace) REAL array, dimension (5*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* IFAIL (output) INTEGER array, dimension (M)
* On normal exit, all elements of IFAIL are zero.
* If one or more eigenvectors fail to converge after
* MAXITS iterations, then their indices are stored in
* array IFAIL.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, then i eigenvectors failed to converge
* in MAXITS iterations. Their indices are stored in
* array IFAIL.
*
* Internal Parameters
* ===================
*
* MAXITS INTEGER, default = 5
* The maximum number of iterations performed.
*
* EXTRA INTEGER, default = 2
* The number of iterations performed after norm growth
* criterion is satisfied, should be at least 1.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TEN, ODM3, ODM1
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TEN = 1.0E+1,
$ ODM3 = 1.0E-3, ODM1 = 1.0E-1 )
INTEGER MAXITS, EXTRA
PARAMETER ( MAXITS = 5, EXTRA = 2 )
* ..
* .. Local Scalars ..
INTEGER B1, BLKSIZ, BN, GPIND, I, IINFO, INDRV1,
$ INDRV2, INDRV3, INDRV4, INDRV5, ITS, J, J1,
$ JBLK, JMAX, NBLK, NRMCHK
REAL CTR, EPS, EPS1, NRM, ONENRM, ORTOL, PERTOL,
$ SCL, SEP, STPCRT, TOL, XJ, XJM
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 )
* ..
* .. External Functions ..
INTEGER ISAMAX
REAL SASUM, SDOT, SLAMCH, SNRM2
EXTERNAL ISAMAX, SASUM, SDOT, SLAMCH, SNRM2
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, SLAGTF, SLAGTS, SLARNV, SSCAL,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
DO 10 I = 1, M
IFAIL( I ) = 0
10 CONTINUE
*
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( M.LT.0 .OR. M.GT.N ) THEN
INFO = -4
ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE
DO 20 J = 2, M
IF( IBLOCK( J ).LT.IBLOCK( J-1 ) ) THEN
INFO = -6
GO TO 30
END IF
IF( IBLOCK( J ).EQ.IBLOCK( J-1 ) .AND. W( J ).LT.W( J-1 ) )
$ THEN
INFO = -5
GO TO 30
END IF
20 CONTINUE
30 CONTINUE
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSTEIN', -INFO )
RETURN
END IF
*
* Initialize iteration count.
*
ITCNT = 0
*
* Quick return if possible
*
IF( N.EQ.0 .OR. M.EQ.0 ) THEN
RETURN
ELSE IF( N.EQ.1 ) THEN
Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
EPS = SLAMCH( 'Precision' )
*
* Initialize seed for random number generator SLARNV.
*
DO 40 I = 1, 4
ISEED( I ) = 1
40 CONTINUE
*
* Initialize pointers.
*
INDRV1 = 0
INDRV2 = INDRV1 + N
INDRV3 = INDRV2 + N
INDRV4 = INDRV3 + N
INDRV5 = INDRV4 + N
*
* Compute eigenvectors of matrix blocks.
*
J1 = 1
DO 160 NBLK = 1, IBLOCK( M )
*
* Find starting and ending indices of block nblk.
*
IF( NBLK.EQ.1 ) THEN
B1 = 1
ELSE
B1 = ISPLIT( NBLK-1 ) + 1
END IF
BN = ISPLIT( NBLK )
BLKSIZ = BN - B1 + 1
IF( BLKSIZ.EQ.1 )
$ GO TO 60
GPIND = B1
*
* Compute reorthogonalization criterion and stopping criterion.
*
ONENRM = ABS( D( B1 ) ) + ABS( E( B1 ) )
ONENRM = MAX( ONENRM, ABS( D( BN ) )+ABS( E( BN-1 ) ) )
DO 50 I = B1 + 1, BN - 1
ONENRM = MAX( ONENRM, ABS( D( I ) )+ABS( E( I-1 ) )+
$ ABS( E( I ) ) )
50 CONTINUE
ORTOL = ODM3*ONENRM
*
STPCRT = SQRT( ODM1 / BLKSIZ )
*
* Increment opcount for computing criteria.
*
OPS = OPS + ( BN-B1 )*2 + 3
*
* Loop through eigenvalues of block nblk.
*
60 CONTINUE
JBLK = 0
DO 150 J = J1, M
IF( IBLOCK( J ).NE.NBLK ) THEN
J1 = J
GO TO 160
END IF
JBLK = JBLK + 1
XJ = W( J )
*
* Skip all the work if the block size is one.
*
IF( BLKSIZ.EQ.1 ) THEN
WORK( INDRV1+1 ) = ONE
GO TO 120
END IF
*
* If eigenvalues j and j-1 are too close, add a relatively
* small perturbation.
*
IF( JBLK.GT.1 ) THEN
EPS1 = ABS( EPS*XJ )
PERTOL = TEN*EPS1
SEP = XJ - XJM
IF( SEP.LT.PERTOL )
$ XJ = XJM + PERTOL
END IF
*
ITS = 0
NRMCHK = 0
*
* Get random starting vector.
*
CALL SLARNV( 2, ISEED, BLKSIZ, WORK( INDRV1+1 ) )
*
* Increment opcount for getting random starting vector.
* ( SLARND(2,.) requires 9 flops. )
*
OPS = OPS + BLKSIZ*9
*
* Copy the matrix T so it won't be destroyed in factorization.
*
CALL SCOPY( BLKSIZ, D( B1 ), 1, WORK( INDRV4+1 ), 1 )
CALL SCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV2+2 ), 1 )
CALL SCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV3+1 ), 1 )
*
* Compute LU factors with partial pivoting ( PT = LU )
*
TOL = ZERO
CALL SLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, WORK( INDRV2+2 ),
$ WORK( INDRV3+1 ), TOL, WORK( INDRV5+1 ), IWORK,
$ IINFO )
*
* Increment opcount for computing LU factors.
* ( SLAGTF(BLKSIZ,...) requires about 8*BLKSIZ flops. )
*
OPS = OPS + 8*BLKSIZ
*
* Update iteration count.
*
70 CONTINUE
ITS = ITS + 1
IF( ITS.GT.MAXITS )
$ GO TO 100
*
* Normalize and scale the righthand side vector Pb.
*
SCL = BLKSIZ*ONENRM*MAX( EPS,
$ ABS( WORK( INDRV4+BLKSIZ ) ) ) /
$ SASUM( BLKSIZ, WORK( INDRV1+1 ), 1 )
CALL SSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 )
*
* Solve the system LU = Pb.
*
CALL SLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), WORK( INDRV2+2 ),
$ WORK( INDRV3+1 ), WORK( INDRV5+1 ), IWORK,
$ WORK( INDRV1+1 ), TOL, IINFO )
*
* Increment opcount for scaling and solving linear system.
* ( SLAGTS(-1,BLKSIZ,...) requires about 8*BLKSIZ flops. )
*
OPS = OPS + 3 + 10*BLKSIZ
*
* Reorthogonalize by modified Gram-Schmidt if eigenvalues are
* close enough.
*
IF( JBLK.EQ.1 )
$ GO TO 90
IF( ABS( XJ-XJM ).GT.ORTOL )
$ GPIND = J
IF( GPIND.NE.J ) THEN
DO 80 I = GPIND, J - 1
CTR = -SDOT( BLKSIZ, WORK( INDRV1+1 ), 1, Z( B1, I ),
$ 1 )
CALL SAXPY( BLKSIZ, CTR, Z( B1, I ), 1,
$ WORK( INDRV1+1 ), 1 )
80 CONTINUE
*
* Increment opcount for reorthogonalizing.
*
OPS = OPS + ( J-GPIND )*BLKSIZ*4
*
END IF
*
* Check the infinity norm of the iterate.
*
90 CONTINUE
JMAX = ISAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 )
NRM = ABS( WORK( INDRV1+JMAX ) )
*
* Continue for additional iterations after norm reaches
* stopping criterion.
*
IF( NRM.LT.STPCRT )
$ GO TO 70
NRMCHK = NRMCHK + 1
IF( NRMCHK.LT.EXTRA+1 )
$ GO TO 70
*
GO TO 110
*
* If stopping criterion was not satisfied, update info and
* store eigenvector number in array ifail.
*
100 CONTINUE
INFO = INFO + 1
IFAIL( INFO ) = J
*
* Accept iterate as jth eigenvector.
*
110 CONTINUE
SCL = ONE / SNRM2( BLKSIZ, WORK( INDRV1+1 ), 1 )
JMAX = ISAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 )
IF( WORK( INDRV1+JMAX ).LT.ZERO )
$ SCL = -SCL
CALL SSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 )
*
* Increment opcount for scaling.
*
OPS = OPS + 3*BLKSIZ
*
120 CONTINUE
DO 130 I = 1, N
Z( I, J ) = ZERO
130 CONTINUE
DO 140 I = 1, BLKSIZ
Z( B1+I-1, J ) = WORK( INDRV1+I )
140 CONTINUE
*
* Save the shift to check eigenvalue spacing at next
* iteration.
*
XJM = XJ
*
150 CONTINUE
160 CONTINUE
*
RETURN
*
* End of SSTEIN
*
END
SUBROUTINE SSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
CHARACTER COMPZ
INTEGER INFO, LDZ, N
* ..
* .. Array Arguments ..
REAL D( * ), E( * ), WORK( * ), Z( LDZ, * )
* ..
* Common block to return operation count and iteration count
* ITCNT is initialized to 0, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SSTEQR computes all eigenvalues and, optionally, eigenvectors of a
* symmetric tridiagonal matrix using the implicit QL or QR method.
* The eigenvectors of a full or band symmetric matrix can also be found
* if SSYTRD or SSPTRD or SSBTRD has been used to reduce this matrix to
* tridiagonal form.
*
* Arguments
* =========
*
* COMPZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only.
* = 'V': Compute eigenvalues and eigenvectors of the original
* symmetric matrix. On entry, Z must contain the
* orthogonal matrix used to reduce the original matrix
* to tridiagonal form.
* = 'I': Compute eigenvalues and eigenvectors of the
* tridiagonal matrix. Z is initialized to the identity
* matrix.
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) REAL array, dimension (N)
* On entry, the diagonal elements of the tridiagonal matrix.
* On exit, if INFO = 0, the eigenvalues in ascending order.
*
* E (input/output) REAL array, dimension (N-1)
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix.
* On exit, E has been destroyed.
*
* Z (input/output) REAL array, dimension (LDZ, N)
* On entry, if COMPZ = 'V', then Z contains the orthogonal
* matrix used in the reduction to tridiagonal form.
* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
* orthonormal eigenvectors of the original symmetric matrix,
* and if COMPZ = 'I', Z contains the orthonormal eigenvectors
* of the symmetric tridiagonal matrix.
* If COMPZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* eigenvectors are desired, then LDZ >= max(1,N).
*
* WORK (workspace) REAL array, dimension (max(1,2*N-2))
* If COMPZ = 'N', then WORK is not referenced.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: the algorithm has failed to find all the eigenvalues in
* a total of 30*N iterations; if INFO = i, then i
* elements of E have not converged to zero; on exit, D
* and E contain the elements of a symmetric tridiagonal
* matrix which is orthogonally similar to the original
* matrix.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO, THREE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ THREE = 3.0E0 )
INTEGER MAXIT
PARAMETER ( MAXIT = 30 )
* ..
* .. Local Scalars ..
INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND,
$ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1,
$ NM1, NMAXIT
REAL ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2,
$ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANST, SLAPY2
EXTERNAL LSAME, SLAMCH, SLANST, SLAPY2
* ..
* .. External Subroutines ..
EXTERNAL SLAE2, SLAEV2, SLARTG, SLASCL, SLASET, SLASR,
$ SLASRT, SSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( LSAME( COMPZ, 'N' ) ) THEN
ICOMPZ = 0
ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
ICOMPZ = 1
ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
ICOMPZ = 2
ELSE
ICOMPZ = -1
END IF
IF( ICOMPZ.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
$ N ) ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSTEQR', -INFO )
RETURN
END IF
*
* Quick return if possible
*
ITCNT = 0
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( ICOMPZ.EQ.2 )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Determine the unit roundoff and over/underflow thresholds.
*
OPS = OPS + 6
EPS = SLAMCH( 'E' )
EPS2 = EPS**2
SAFMIN = SLAMCH( 'S' )
SAFMAX = ONE / SAFMIN
SSFMAX = SQRT( SAFMAX ) / THREE
SSFMIN = SQRT( SAFMIN ) / EPS2
*
* Compute the eigenvalues and eigenvectors of the tridiagonal
* matrix.
*
IF( ICOMPZ.EQ.2 )
$ CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
*
NMAXIT = N*MAXIT
JTOT = 0
*
* Determine where the matrix splits and choose QL or QR iteration
* for each block, according to whether top or bottom diagonal
* element is smaller.
*
L1 = 1
NM1 = N - 1
*
10 CONTINUE
IF( L1.GT.N )
$ GO TO 160
IF( L1.GT.1 )
$ E( L1-1 ) = ZERO
IF( L1.LE.NM1 ) THEN
DO 20 M = L1, NM1
TST = ABS( E( M ) )
IF( TST.EQ.ZERO )
$ GO TO 30
OPS = OPS + 4
IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+
$ 1 ) ) ) )*EPS ) THEN
E( M ) = ZERO
GO TO 30
END IF
20 CONTINUE
END IF
M = N
*
30 CONTINUE
L = L1
LSV = L
LEND = M
LENDSV = LEND
L1 = M + 1
IF( LEND.EQ.L )
$ GO TO 10
*
* Scale submatrix in rows and columns L to LEND
*
OPS = OPS + 2*( LEND-L+1 )
ANORM = SLANST( 'I', LEND-L+1, D( L ), E( L ) )
ISCALE = 0
IF( ANORM.EQ.ZERO )
$ GO TO 10
IF( ANORM.GT.SSFMAX ) THEN
ISCALE = 1
OPS = OPS + 2*( LEND-L ) + 1
CALL SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
$ INFO )
ELSE IF( ANORM.LT.SSFMIN ) THEN
ISCALE = 2
OPS = OPS + 2*( LEND-L ) + 1
CALL SLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL SLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N,
$ INFO )
END IF
*
* Choose between QL and QR iteration
*
IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
LEND = LSV
L = LENDSV
END IF
*
IF( LEND.GT.L ) THEN
*
* QL Iteration
*
* Look for small subdiagonal element.
*
40 CONTINUE
IF( L.NE.LEND ) THEN
LENDM1 = LEND - 1
DO 50 M = L, LENDM1
TST = ABS( E( M ) )**2
OPS = OPS + 4
IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+
$ SAFMIN )GO TO 60
50 CONTINUE
END IF
*
M = LEND
*
60 CONTINUE
IF( M.LT.LEND )
$ E( M ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 80
*
* If remaining matrix is 2-by-2, use SLAE2 or SLAEV2
* to compute its eigensystem.
*
IF( M.EQ.L+1 ) THEN
IF( ICOMPZ.GT.0 ) THEN
OPS = OPS + 22
CALL SLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S )
WORK( L ) = C
WORK( N-1+L ) = S
OPS = OPS + 6*N
CALL SLASR( 'R', 'V', 'B', N, 2, WORK( L ),
$ WORK( N-1+L ), Z( 1, L ), LDZ )
ELSE
OPS = OPS + 15
CALL SLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 )
END IF
D( L ) = RT1
D( L+1 ) = RT2
E( L ) = ZERO
L = L + 2
IF( L.LE.LEND )
$ GO TO 40
GO TO 140
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 140
JTOT = JTOT + 1
*
* Form shift.
*
OPS = OPS + 12
G = ( D( L+1 )-P ) / ( TWO*E( L ) )
R = SLAPY2( G, ONE )
G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) )
*
S = ONE
C = ONE
P = ZERO
*
* Inner loop
*
MM1 = M - 1
OPS = OPS + 18*( M-L )
DO 70 I = MM1, L, -1
F = S*E( I )
B = C*E( I )
CALL SLARTG( G, F, C, S, R )
IF( I.NE.M-1 )
$ E( I+1 ) = R
G = D( I+1 ) - P
R = ( D( I )-G )*S + TWO*C*B
P = S*R
D( I+1 ) = G + P
G = C*R - B
*
* If eigenvectors are desired, then save rotations.
*
IF( ICOMPZ.GT.0 ) THEN
WORK( I ) = C
WORK( N-1+I ) = -S
END IF
*
70 CONTINUE
*
* If eigenvectors are desired, then apply saved rotations.
*
IF( ICOMPZ.GT.0 ) THEN
MM = M - L + 1
OPS = OPS + 6*N*( MM-1 )
CALL SLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ),
$ Z( 1, L ), LDZ )
END IF
*
OPS = OPS + 1
D( L ) = D( L ) - P
E( L ) = G
GO TO 40
*
* Eigenvalue found.
*
80 CONTINUE
D( L ) = P
*
L = L + 1
IF( L.LE.LEND )
$ GO TO 40
GO TO 140
*
ELSE
*
* QR Iteration
*
* Look for small superdiagonal element.
*
90 CONTINUE
IF( L.NE.LEND ) THEN
LENDP1 = LEND + 1
DO 100 M = L, LENDP1, -1
OPS = OPS + 4
TST = ABS( E( M-1 ) )**2
IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+
$ SAFMIN )GO TO 110
100 CONTINUE
END IF
*
M = LEND
*
110 CONTINUE
IF( M.GT.LEND )
$ E( M-1 ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 130
*
* If remaining matrix is 2-by-2, use SLAE2 or SLAEV2
* to compute its eigensystem.
*
IF( M.EQ.L-1 ) THEN
IF( ICOMPZ.GT.0 ) THEN
OPS = OPS + 22
CALL SLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S )
WORK( M ) = C
WORK( N-1+M ) = S
OPS = OPS + 6*N
CALL SLASR( 'R', 'V', 'F', N, 2, WORK( M ),
$ WORK( N-1+M ), Z( 1, L-1 ), LDZ )
ELSE
OPS = OPS + 15
CALL SLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 )
END IF
D( L-1 ) = RT1
D( L ) = RT2
E( L-1 ) = ZERO
L = L - 2
IF( L.GE.LEND )
$ GO TO 90
GO TO 140
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 140
JTOT = JTOT + 1
*
* Form shift.
*
OPS = OPS + 12
G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) )
R = SLAPY2( G, ONE )
G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) )
*
S = ONE
C = ONE
P = ZERO
*
* Inner loop
*
LM1 = L - 1
OPS = OPS + 18*( L-M )
DO 120 I = M, LM1
F = S*E( I )
B = C*E( I )
CALL SLARTG( G, F, C, S, R )
IF( I.NE.M )
$ E( I-1 ) = R
G = D( I ) - P
R = ( D( I+1 )-G )*S + TWO*C*B
P = S*R
D( I ) = G + P
G = C*R - B
*
* If eigenvectors are desired, then save rotations.
*
IF( ICOMPZ.GT.0 ) THEN
WORK( I ) = C
WORK( N-1+I ) = S
END IF
*
120 CONTINUE
*
* If eigenvectors are desired, then apply saved rotations.
*
IF( ICOMPZ.GT.0 ) THEN
MM = L - M + 1
OPS = OPS + 6*N*( MM-1 )
CALL SLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ),
$ Z( 1, M ), LDZ )
END IF
*
OPS = OPS + 1
D( L ) = D( L ) - P
E( LM1 ) = G
GO TO 90
*
* Eigenvalue found.
*
130 CONTINUE
D( L ) = P
*
L = L - 1
IF( L.GE.LEND )
$ GO TO 90
GO TO 140
*
END IF
*
* Undo scaling if necessary
*
140 CONTINUE
IF( ISCALE.EQ.1 ) THEN
OPS = OPS + 2*( LENDSV-LSV ) + 1
CALL SLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
CALL SLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ),
$ N, INFO )
ELSE IF( ISCALE.EQ.2 ) THEN
OPS = OPS + 2*( LENDSV-LSV ) + 1
CALL SLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
CALL SLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ),
$ N, INFO )
END IF
*
* Check for no convergence to an eigenvalue after a total
* of N*MAXIT iterations.
*
IF( JTOT.LT.NMAXIT )
$ GO TO 10
DO 150 I = 1, N - 1
IF( E( I ).NE.ZERO )
$ INFO = INFO + 1
150 CONTINUE
GO TO 190
*
* Order eigenvalues and eigenvectors.
*
160 CONTINUE
IF( ICOMPZ.EQ.0 ) THEN
*
* Use Quick Sort
*
CALL SLASRT( 'I', N, D, INFO )
*
ELSE
*
* Use Selection Sort to minimize swaps of eigenvectors
*
DO 180 II = 2, N
I = II - 1
K = I
P = D( I )
DO 170 J = II, N
IF( D( J ).LT.P ) THEN
K = J
P = D( J )
END IF
170 CONTINUE
IF( K.NE.I ) THEN
D( K ) = D( I )
D( I ) = P
CALL SSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
END IF
180 CONTINUE
END IF
*
190 CONTINUE
RETURN
*
* End of SSTEQR
*
END
SUBROUTINE SSTERF( N, D, E, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER INFO, N
* ..
* .. Array Arguments ..
REAL D( * ), E( * )
* ..
* Common block to return operation count and iteration count
* ITCNT is initialized to 0, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SSTERF computes all eigenvalues of a symmetric tridiagonal matrix
* using the Pal-Walker-Kahan variant of the QL or QR algorithm.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) REAL array, dimension (N)
* On entry, the n diagonal elements of the tridiagonal matrix.
* On exit, if INFO = 0, the eigenvalues in ascending order.
*
* E (input/output) REAL array, dimension (N-1)
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix.
* On exit, E has been destroyed.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: the algorithm failed to find all of the eigenvalues in
* a total of 30*N iterations; if INFO = i, then i
* elements of E have not converged to zero.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO, THREE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ THREE = 3.0E0 )
INTEGER MAXIT
PARAMETER ( MAXIT = 30 )
* ..
* .. Local Scalars ..
INTEGER I, ISCALE, JTOT, L, L1, LEND, LENDSV, LSV, M,
$ NMAXIT
REAL ALPHA, ANORM, BB, C, EPS, EPS2, GAMMA, OLDC,
$ OLDGAM, P, R, RT1, RT2, RTE, S, SAFMAX, SAFMIN,
$ SIGMA, SSFMAX, SSFMIN
* ..
* .. External Functions ..
REAL SLAMCH, SLANST, SLAPY2
EXTERNAL SLAMCH, SLANST, SLAPY2
* ..
* .. External Subroutines ..
EXTERNAL SLAE2, SLASCL, SLASRT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
* Quick return if possible
*
ITCNT = 0
IF( N.LT.0 ) THEN
INFO = -1
CALL XERBLA( 'SSTERF', -INFO )
RETURN
END IF
IF( N.LE.1 )
$ RETURN
*
* Determine the unit roundoff for this environment.
*
OPS = OPS + 6
EPS = SLAMCH( 'E' )
EPS2 = EPS**2
SAFMIN = SLAMCH( 'S' )
SAFMAX = ONE / SAFMIN
SSFMAX = SQRT( SAFMAX ) / THREE
SSFMIN = SQRT( SAFMIN ) / EPS2
*
* Compute the eigenvalues of the tridiagonal matrix.
*
NMAXIT = N*MAXIT
SIGMA = ZERO
JTOT = 0
*
* Determine where the matrix splits and choose QL or QR iteration
* for each block, according to whether top or bottom diagonal
* element is smaller.
*
L1 = 1
*
10 CONTINUE
IF( L1.GT.N )
$ GO TO 170
IF( L1.GT.1 )
$ E( L1-1 ) = ZERO
DO 20 M = L1, N - 1
OPS = OPS + 4
IF( ABS( E( M ) ).LE.( SQRT( ABS( D( M ) ) )*
$ SQRT( ABS( D( M+1 ) ) ) )*EPS ) THEN
E( M ) = ZERO
GO TO 30
END IF
20 CONTINUE
M = N
*
30 CONTINUE
L = L1
LSV = L
LEND = M
LENDSV = LEND
L1 = M + 1
IF( LEND.EQ.L )
$ GO TO 10
*
* Scale submatrix in rows and columns L to LEND
*
OPS = OPS + 2*( LEND-L+1 )
ANORM = SLANST( 'I', LEND-L+1, D( L ), E( L ) )
ISCALE = 0
IF( ANORM.GT.SSFMAX ) THEN
ISCALE = 1
OPS = OPS + 2*( LEND-L ) + 1
CALL SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
$ INFO )
ELSE IF( ANORM.LT.SSFMIN ) THEN
ISCALE = 2
OPS = OPS + 2*( LEND-L ) + 1
CALL SLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL SLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N,
$ INFO )
END IF
*
OPS = OPS + 2*( LEND-L )
DO 40 I = L, LEND - 1
E( I ) = E( I )**2
40 CONTINUE
*
* Choose between QL and QR iteration
*
IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
LEND = LSV
L = LENDSV
END IF
*
IF( LEND.GE.L ) THEN
*
* QL Iteration
*
* Look for small subdiagonal element.
*
50 CONTINUE
IF( L.NE.LEND ) THEN
DO 60 M = L, LEND - 1
OPS = OPS + 3
IF( ABS( E( M ) ).LE.EPS2*ABS( D( M )*D( M+1 ) ) )
$ GO TO 70
60 CONTINUE
END IF
M = LEND
*
70 CONTINUE
IF( M.LT.LEND )
$ E( M ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 90
*
* If remaining matrix is 2 by 2, use SLAE2 to compute its
* eigenvalues.
*
IF( M.EQ.L+1 ) THEN
OPS = OPS + 16
RTE = SQRT( E( L ) )
CALL SLAE2( D( L ), RTE, D( L+1 ), RT1, RT2 )
D( L ) = RT1
D( L+1 ) = RT2
E( L ) = ZERO
L = L + 2
IF( L.LE.LEND )
$ GO TO 50
GO TO 150
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 150
JTOT = JTOT + 1
*
* Form shift.
*
OPS = OPS + 14
RTE = SQRT( E( L ) )
SIGMA = ( D( L+1 )-P ) / ( TWO*RTE )
R = SLAPY2( SIGMA, ONE )
SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) )
*
C = ONE
S = ZERO
GAMMA = D( M ) - SIGMA
P = GAMMA*GAMMA
*
* Inner loop
*
OPS = OPS + 12*( M-L )
DO 80 I = M - 1, L, -1
BB = E( I )
R = P + BB
IF( I.NE.M-1 )
$ E( I+1 ) = S*R
OLDC = C
C = P / R
S = BB / R
OLDGAM = GAMMA
ALPHA = D( I )
GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM
D( I+1 ) = OLDGAM + ( ALPHA-GAMMA )
IF( C.NE.ZERO ) THEN
P = ( GAMMA*GAMMA ) / C
ELSE
P = OLDC*BB
END IF
80 CONTINUE
*
OPS = OPS + 2
E( L ) = S*P
D( L ) = SIGMA + GAMMA
GO TO 50
*
* Eigenvalue found.
*
90 CONTINUE
D( L ) = P
*
L = L + 1
IF( L.LE.LEND )
$ GO TO 50
GO TO 150
*
ELSE
*
* QR Iteration
*
* Look for small superdiagonal element.
*
100 CONTINUE
DO 110 M = L, LEND + 1, -1
OPS = OPS + 3
IF( ABS( E( M-1 ) ).LE.EPS2*ABS( D( M )*D( M-1 ) ) )
$ GO TO 120
110 CONTINUE
M = LEND
*
120 CONTINUE
IF( M.GT.LEND )
$ E( M-1 ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 140
*
* If remaining matrix is 2 by 2, use SLAE2 to compute its
* eigenvalues.
*
IF( M.EQ.L-1 ) THEN
OPS = OPS + 16
RTE = SQRT( E( L-1 ) )
CALL SLAE2( D( L ), RTE, D( L-1 ), RT1, RT2 )
D( L ) = RT1
D( L-1 ) = RT2
E( L-1 ) = ZERO
L = L - 2
IF( L.GE.LEND )
$ GO TO 100
GO TO 150
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 150
JTOT = JTOT + 1
*
* Form shift.
*
OPS = OPS + 14
RTE = SQRT( E( L-1 ) )
SIGMA = ( D( L-1 )-P ) / ( TWO*RTE )
R = SLAPY2( SIGMA, ONE )
SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) )
*
C = ONE
S = ZERO
GAMMA = D( M ) - SIGMA
P = GAMMA*GAMMA
*
* Inner loop
*
OPS = OPS + 12*( L-M )
DO 130 I = M, L - 1
BB = E( I )
R = P + BB
IF( I.NE.M )
$ E( I-1 ) = S*R
OLDC = C
C = P / R
S = BB / R
OLDGAM = GAMMA
ALPHA = D( I+1 )
GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM
D( I ) = OLDGAM + ( ALPHA-GAMMA )
IF( C.NE.ZERO ) THEN
P = ( GAMMA*GAMMA ) / C
ELSE
P = OLDC*BB
END IF
130 CONTINUE
*
OPS = OPS + 2
E( L-1 ) = S*P
D( L ) = SIGMA + GAMMA
GO TO 100
*
* Eigenvalue found.
*
140 CONTINUE
D( L ) = P
*
L = L - 1
IF( L.GE.LEND )
$ GO TO 100
GO TO 150
*
END IF
*
* Undo scaling if necessary
*
150 CONTINUE
IF( ISCALE.EQ.1 ) THEN
OPS = OPS + LENDSV - LSV + 1
CALL SLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
END IF
IF( ISCALE.EQ.2 ) THEN
OPS = OPS + LENDSV - LSV + 1
CALL SLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
END IF
*
* Check for no convergence to an eigenvalue after a total
* of N*MAXIT iterations.
*
IF( JTOT.LT.NMAXIT )
$ GO TO 10
DO 160 I = 1, N - 1
IF( E( I ).NE.ZERO )
$ INFO = INFO + 1
160 CONTINUE
GO TO 180
*
* Sort eigenvalues in increasing order.
*
170 CONTINUE
CALL SLASRT( 'I', N, D, INFO )
*
180 CONTINUE
RETURN
*
* End of SSTERF
*
END
SUBROUTINE STGEVC( SIDE, HOWMNY, SELECT, N, A, LDA, B, LDB, VL,
$ LDVL, VR, LDVR, MM, M, WORK, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER HOWMNY, SIDE
INTEGER INFO, LDA, LDB, LDVL, LDVR, M, MM, N
* ..
* .. Array Arguments ..
LOGICAL SELECT( * )
REAL A( LDA, * ), B( LDB, * ), VL( LDVL, * ),
$ VR( LDVR, * ), WORK( * )
* ..
*
* ---------------------- Begin Timing Code -------------------------
* Common block to return operation count and iteration count
* ITCNT is initialized to 0, OPS is only incremented
* OPST is used to accumulate small contributions to OPS
* to avoid roundoff error
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
* ----------------------- End Timing Code --------------------------
*
*
* Purpose
* =======
*
* STGEVC computes some or all of the right and/or left generalized
* eigenvectors of a pair of real upper triangular matrices (A,B).
*
* The right generalized eigenvector x and the left generalized
* eigenvector y of (A,B) corresponding to a generalized eigenvalue
* w are defined by:
*
* (A - wB) * x = 0 and y**H * (A - wB) = 0
*
* where y**H denotes the conjugate tranpose of y.
*
* If an eigenvalue w is determined by zero diagonal elements of both A
* and B, a unit vector is returned as the corresponding eigenvector.
*
* If all eigenvectors are requested, the routine may either return
* the matrices X and/or Y of right or left eigenvectors of (A,B), or
* the products Z*X and/or Q*Y, where Z and Q are input orthogonal
* matrices. If (A,B) was obtained from the generalized real-Schur
* factorization of an original pair of matrices
* (A0,B0) = (Q*A*Z**H,Q*B*Z**H),
* then Z*X and Q*Y are the matrices of right or left eigenvectors of
* A.
*
* A must be block upper triangular, with 1-by-1 and 2-by-2 diagonal
* blocks. Corresponding to each 2-by-2 diagonal block is a complex
* conjugate pair of eigenvalues and eigenvectors; only one
* eigenvector of the pair is computed, namely the one corresponding
* to the eigenvalue with positive imaginary part.
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* = 'R': compute right eigenvectors only;
* = 'L': compute left eigenvectors only;
* = 'B': compute both right and left eigenvectors.
*
* HOWMNY (input) CHARACTER*1
* = 'A': compute all right and/or left eigenvectors;
* = 'B': compute all right and/or left eigenvectors, and
* backtransform them using the input matrices supplied
* in VR and/or VL;
* = 'S': compute selected right and/or left eigenvectors,
* specified by the logical array SELECT.
*
* SELECT (input) LOGICAL array, dimension (N)
* If HOWMNY='S', SELECT specifies the eigenvectors to be
* computed.
* If HOWMNY='A' or 'B', SELECT is not referenced.
* To select the real eigenvector corresponding to the real
* eigenvalue w(j), SELECT(j) must be set to .TRUE. To select
* the complex eigenvector corresponding to a complex conjugate
* pair w(j) and w(j+1), either SELECT(j) or SELECT(j+1) must
* be set to .TRUE..
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The upper quasi-triangular matrix A.
*
* LDA (input) INTEGER
* The leading dimension of array A. LDA >= max(1,N).
*
* B (input) REAL array, dimension (LDB,N)
* The upper triangular matrix B. If A has a 2-by-2 diagonal
* block, then the corresponding 2-by-2 block of B must be
* diagonal with positive elements.
*
* LDB (input) INTEGER
* The leading dimension of array B. LDB >= max(1,N).
*
* VL (input/output) REAL array, dimension (LDVL,MM)
* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
* contain an N-by-N matrix Q (usually the orthogonal matrix Q
* of left Schur vectors returned by SHGEQZ).
* On exit, if SIDE = 'L' or 'B', VL contains:
* if HOWMNY = 'A', the matrix Y of left eigenvectors of (A,B);
* if HOWMNY = 'B', the matrix Q*Y;
* if HOWMNY = 'S', the left eigenvectors of (A,B) specified by
* SELECT, stored consecutively in the columns of
* VL, in the same order as their eigenvalues.
* If SIDE = 'R', VL is not referenced.
*
* A complex eigenvector corresponding to a complex eigenvalue
* is stored in two consecutive columns, the first holding the
* real part, and the second the imaginary part.
*
* LDVL (input) INTEGER
* The leading dimension of array VL.
* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
*
* VR (input/output) REAL array, dimension (LDVR,MM)
* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
* contain an N-by-N matrix Q (usually the orthogonal matrix Z
* of right Schur vectors returned by SHGEQZ).
* On exit, if SIDE = 'R' or 'B', VR contains:
* if HOWMNY = 'A', the matrix X of right eigenvectors of (A,B);
* if HOWMNY = 'B', the matrix Z*X;
* if HOWMNY = 'S', the right eigenvectors of (A,B) specified by
* SELECT, stored consecutively in the columns of
* VR, in the same order as their eigenvalues.
* If SIDE = 'L', VR is not referenced.
*
* A complex eigenvector corresponding to a complex eigenvalue
* is stored in two consecutive columns, the first holding the
* real part and the second the imaginary part.
*
* LDVR (input) INTEGER
* The leading dimension of the array VR.
* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
*
* MM (input) INTEGER
* The number of columns in the arrays VL and/or VR. MM >= M.
*
* M (output) INTEGER
* The number of columns in the arrays VL and/or VR actually
* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M
* is set to N. Each selected real eigenvector occupies one
* column and each selected complex eigenvector occupies two
* columns.
*
* WORK (workspace) REAL array, dimension (6*N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: the 2-by-2 block (INFO:INFO+1) does not have a complex
* eigenvalue.
*
* Further Details
* ===============
*
* Allocation of workspace:
* ---------- -- ---------
*
* WORK( j ) = 1-norm of j-th column of A, above the diagonal
* WORK( N+j ) = 1-norm of j-th column of B, above the diagonal
* WORK( 2*N+1:3*N ) = real part of eigenvector
* WORK( 3*N+1:4*N ) = imaginary part of eigenvector
* WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector
* WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector
*
* Rowwise vs. columnwise solution methods:
* ------- -- ---------- -------- -------
*
* Finding a generalized eigenvector consists basically of solving the
* singular triangular system
*
* (A - w B) x = 0 (for right) or: (A - w B)**H y = 0 (for left)
*
* Consider finding the i-th right eigenvector (assume all eigenvalues
* are real). The equation to be solved is:
* n i
* 0 = sum C(j,k) v(k) = sum C(j,k) v(k) for j = i,. . .,1
* k=j k=j
*
* where C = (A - w B) (The components v(i+1:n) are 0.)
*
* The "rowwise" method is:
*
* (1) v(i) := 1
* for j = i-1,. . .,1:
* i
* (2) compute s = - sum C(j,k) v(k) and
* k=j+1
*
* (3) v(j) := s / C(j,j)
*
* Step 2 is sometimes called the "dot product" step, since it is an
* inner product between the j-th row and the portion of the eigenvector
* that has been computed so far.
*
* The "columnwise" method consists basically in doing the sums
* for all the rows in parallel. As each v(j) is computed, the
* contribution of v(j) times the j-th column of C is added to the
* partial sums. Since FORTRAN arrays are stored columnwise, this has
* the advantage that at each step, the elements of C that are accessed
* are adjacent to one another, whereas with the rowwise method, the
* elements accessed at a step are spaced LDA (and LDB) words apart.
*
* When finding left eigenvectors, the matrix in question is the
* transpose of the one in storage, so the rowwise method then
* actually accesses columns of A and B at each step, and so is the
* preferred method.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, SAFETY
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0,
$ SAFETY = 1.0E+2 )
* ..
* .. Local Scalars ..
LOGICAL COMPL, COMPR, IL2BY2, ILABAD, ILALL, ILBACK,
$ ILBBAD, ILCOMP, ILCPLX, LSA, LSB
INTEGER I, IBEG, IEIG, IEND, IHWMNY, IINFO, IM, IN2BY2,
$ ISIDE, J, JA, JC, JE, JR, JW, NA, NW
REAL ACOEF, ACOEFA, ANORM, ASCALE, BCOEFA, BCOEFI,
$ BCOEFR, BIG, BIGNUM, BNORM, BSCALE, CIM2A,
$ CIM2B, CIMAGA, CIMAGB, CRE2A, CRE2B, CREALA,
$ CREALB, DMIN, OPSSCA, OPST, SAFMIN, SALFAR,
$ SBETA, SCALE, SMALL, TEMP, TEMP2, TEMP2I,
$ TEMP2R, ULP, XMAX, XSCALE
* ..
* .. Local Arrays ..
REAL BDIAG( 2 ), SUM( 2, 2 ), SUMA( 2, 2 ),
$ SUMB( 2, 2 )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH
EXTERNAL LSAME, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SGEMV, SLABAD, SLACPY, SLAG2, SLALN2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL
* ..
* .. Executable Statements ..
*
* Decode and Test the input parameters
*
IF( LSAME( HOWMNY, 'A' ) ) THEN
IHWMNY = 1
ILALL = .TRUE.
ILBACK = .FALSE.
ELSE IF( LSAME( HOWMNY, 'S' ) ) THEN
IHWMNY = 2
ILALL = .FALSE.
ILBACK = .FALSE.
ELSE IF( LSAME( HOWMNY, 'B' ) .OR. LSAME( HOWMNY, 'T' ) ) THEN
IHWMNY = 3
ILALL = .TRUE.
ILBACK = .TRUE.
ELSE
IHWMNY = -1
ILALL = .TRUE.
END IF
*
IF( LSAME( SIDE, 'R' ) ) THEN
ISIDE = 1
COMPL = .FALSE.
COMPR = .TRUE.
ELSE IF( LSAME( SIDE, 'L' ) ) THEN
ISIDE = 2
COMPL = .TRUE.
COMPR = .FALSE.
ELSE IF( LSAME( SIDE, 'B' ) ) THEN
ISIDE = 3
COMPL = .TRUE.
COMPR = .TRUE.
ELSE
ISIDE = -1
END IF
*
INFO = 0
IF( ISIDE.LT.0 ) THEN
INFO = -1
ELSE IF( IHWMNY.LT.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STGEVC', -INFO )
RETURN
END IF
*
* Count the number of eigenvectors to be computed
*
IF( .NOT.ILALL ) THEN
IM = 0
ILCPLX = .FALSE.
DO 10 J = 1, N
IF( ILCPLX ) THEN
ILCPLX = .FALSE.
GO TO 10
END IF
IF( J.LT.N ) THEN
IF( A( J+1, J ).NE.ZERO )
$ ILCPLX = .TRUE.
END IF
IF( ILCPLX ) THEN
IF( SELECT( J ) .OR. SELECT( J+1 ) )
$ IM = IM + 2
ELSE
IF( SELECT( J ) )
$ IM = IM + 1
END IF
10 CONTINUE
ELSE
IM = N
END IF
*
* Check 2-by-2 diagonal blocks of A, B
*
ILABAD = .FALSE.
ILBBAD = .FALSE.
DO 20 J = 1, N - 1
IF( A( J+1, J ).NE.ZERO ) THEN
IF( B( J, J ).EQ.ZERO .OR. B( J+1, J+1 ).EQ.ZERO .OR.
$ B( J, J+1 ).NE.ZERO )ILBBAD = .TRUE.
IF( J.LT.N-1 ) THEN
IF( A( J+2, J+1 ).NE.ZERO )
$ ILABAD = .TRUE.
END IF
END IF
20 CONTINUE
*
IF( ILABAD ) THEN
INFO = -5
ELSE IF( ILBBAD ) THEN
INFO = -7
ELSE IF( COMPL .AND. LDVL.LT.N .OR. LDVL.LT.1 ) THEN
INFO = -10
ELSE IF( COMPR .AND. LDVR.LT.N .OR. LDVR.LT.1 ) THEN
INFO = -12
ELSE IF( MM.LT.IM ) THEN
INFO = -13
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STGEVC', -INFO )
RETURN
END IF
*
* Quick return if possible
*
M = IM
IF( N.EQ.0 )
$ RETURN
*
* Machine Constants
*
SAFMIN = SLAMCH( 'Safe minimum' )
BIG = ONE / SAFMIN
CALL SLABAD( SAFMIN, BIG )
ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
SMALL = SAFMIN*N / ULP
BIG = ONE / SMALL
BIGNUM = ONE / ( SAFMIN*N )
*
* Compute the 1-norm of each column of the strictly upper triangular
* part (i.e., excluding all elements belonging to the diagonal
* blocks) of A and B to check for possible overflow in the
* triangular solver.
*
ANORM = ABS( A( 1, 1 ) )
IF( N.GT.1 )
$ ANORM = ANORM + ABS( A( 2, 1 ) )
BNORM = ABS( B( 1, 1 ) )
WORK( 1 ) = ZERO
WORK( N+1 ) = ZERO
*
DO 50 J = 2, N
TEMP = ZERO
TEMP2 = ZERO
IF( A( J, J-1 ).EQ.ZERO ) THEN
IEND = J - 1
ELSE
IEND = J - 2
END IF
DO 30 I = 1, IEND
TEMP = TEMP + ABS( A( I, J ) )
TEMP2 = TEMP2 + ABS( B( I, J ) )
30 CONTINUE
WORK( J ) = TEMP
WORK( N+J ) = TEMP2
DO 40 I = IEND + 1, MIN( J+1, N )
TEMP = TEMP + ABS( A( I, J ) )
TEMP2 = TEMP2 + ABS( B( I, J ) )
40 CONTINUE
ANORM = MAX( ANORM, TEMP )
BNORM = MAX( BNORM, TEMP2 )
50 CONTINUE
*
ASCALE = ONE / MAX( ANORM, SAFMIN )
BSCALE = ONE / MAX( BNORM, SAFMIN )
*
* ---------------------- Begin Timing Code -------------------------
OPS = OPS + REAL( N**2+3*N+6 )
* ----------------------- End Timing Code --------------------------
*
* Left eigenvectors
*
IF( COMPL ) THEN
IEIG = 0
*
* Main loop over eigenvalues
*
ILCPLX = .FALSE.
DO 220 JE = 1, N
*
* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or
* (b) this would be the second of a complex pair.
* Check for complex eigenvalue, so as to be sure of which
* entry(-ies) of SELECT to look at.
*
IF( ILCPLX ) THEN
ILCPLX = .FALSE.
GO TO 220
END IF
NW = 1
IF( JE.LT.N ) THEN
IF( A( JE+1, JE ).NE.ZERO ) THEN
ILCPLX = .TRUE.
NW = 2
END IF
END IF
IF( ILALL ) THEN
ILCOMP = .TRUE.
ELSE IF( ILCPLX ) THEN
ILCOMP = SELECT( JE ) .OR. SELECT( JE+1 )
ELSE
ILCOMP = SELECT( JE )
END IF
IF( .NOT.ILCOMP )
$ GO TO 220
*
* Decide if (a) singular pencil, (b) real eigenvalue, or
* (c) complex eigenvalue.
*
IF( .NOT.ILCPLX ) THEN
IF( ABS( A( JE, JE ) ).LE.SAFMIN .AND.
$ ABS( B( JE, JE ) ).LE.SAFMIN ) THEN
*
* Singular matrix pencil -- returns unit eigenvector
*
IEIG = IEIG + 1
DO 60 JR = 1, N
VL( JR, IEIG ) = ZERO
60 CONTINUE
VL( IEIG, IEIG ) = ONE
GO TO 220
END IF
END IF
*
* Clear vector
*
DO 70 JR = 1, NW*N
WORK( 2*N+JR ) = ZERO
70 CONTINUE
* T
* Compute coefficients in ( a A - b B ) y = 0
* a is ACOEF
* b is BCOEFR + i*BCOEFI
*
IF( .NOT.ILCPLX ) THEN
*
* Real eigenvalue
*
TEMP = ONE / MAX( ABS( A( JE, JE ) )*ASCALE,
$ ABS( B( JE, JE ) )*BSCALE, SAFMIN )
SALFAR = ( TEMP*A( JE, JE ) )*ASCALE
SBETA = ( TEMP*B( JE, JE ) )*BSCALE
ACOEF = SBETA*ASCALE
BCOEFR = SALFAR*BSCALE
BCOEFI = ZERO
*
* Scale to avoid underflow
*
SCALE = ONE
LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEF ).LT.SMALL
LSB = ABS( SALFAR ).GE.SAFMIN .AND. ABS( BCOEFR ).LT.
$ SMALL
IF( LSA )
$ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG )
IF( LSB )
$ SCALE = MAX( SCALE, ( SMALL / ABS( SALFAR ) )*
$ MIN( BNORM, BIG ) )
IF( LSA .OR. LSB ) THEN
SCALE = MIN( SCALE, ONE /
$ ( SAFMIN*MAX( ONE, ABS( ACOEF ),
$ ABS( BCOEFR ) ) ) )
IF( LSA ) THEN
ACOEF = ASCALE*( SCALE*SBETA )
ELSE
ACOEF = SCALE*ACOEF
END IF
IF( LSB ) THEN
BCOEFR = BSCALE*( SCALE*SALFAR )
ELSE
BCOEFR = SCALE*BCOEFR
END IF
END IF
ACOEFA = ABS( ACOEF )
BCOEFA = ABS( BCOEFR )
*
* First component is 1
*
WORK( 2*N+JE ) = ONE
XMAX = ONE
ELSE
*
* Complex eigenvalue
*
CALL SLAG2( A( JE, JE ), LDA, B( JE, JE ), LDB,
$ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2,
$ BCOEFI )
BCOEFI = -BCOEFI
IF( BCOEFI.EQ.ZERO ) THEN
INFO = JE
RETURN
END IF
*
* Scale to avoid over/underflow
*
ACOEFA = ABS( ACOEF )
BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
SCALE = ONE
IF( ACOEFA*ULP.LT.SAFMIN .AND. ACOEFA.GE.SAFMIN )
$ SCALE = ( SAFMIN / ULP ) / ACOEFA
IF( BCOEFA*ULP.LT.SAFMIN .AND. BCOEFA.GE.SAFMIN )
$ SCALE = MAX( SCALE, ( SAFMIN / ULP ) / BCOEFA )
IF( SAFMIN*ACOEFA.GT.ASCALE )
$ SCALE = ASCALE / ( SAFMIN*ACOEFA )
IF( SAFMIN*BCOEFA.GT.BSCALE )
$ SCALE = MIN( SCALE, BSCALE / ( SAFMIN*BCOEFA ) )
IF( SCALE.NE.ONE ) THEN
ACOEF = SCALE*ACOEF
ACOEFA = ABS( ACOEF )
BCOEFR = SCALE*BCOEFR
BCOEFI = SCALE*BCOEFI
BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
END IF
*
* Compute first two components of eigenvector
*
TEMP = ACOEF*A( JE+1, JE )
TEMP2R = ACOEF*A( JE, JE ) - BCOEFR*B( JE, JE )
TEMP2I = -BCOEFI*B( JE, JE )
IF( ABS( TEMP ).GT.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN
WORK( 2*N+JE ) = ONE
WORK( 3*N+JE ) = ZERO
WORK( 2*N+JE+1 ) = -TEMP2R / TEMP
WORK( 3*N+JE+1 ) = -TEMP2I / TEMP
ELSE
WORK( 2*N+JE+1 ) = ONE
WORK( 3*N+JE+1 ) = ZERO
TEMP = ACOEF*A( JE, JE+1 )
WORK( 2*N+JE ) = ( BCOEFR*B( JE+1, JE+1 )-ACOEF*
$ A( JE+1, JE+1 ) ) / TEMP
WORK( 3*N+JE ) = BCOEFI*B( JE+1, JE+1 ) / TEMP
END IF
XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ),
$ ABS( WORK( 2*N+JE+1 ) )+ABS( WORK( 3*N+JE+1 ) ) )
END IF
*
DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN )
*
* T
* Triangular solve of (a A - b B) y = 0
*
* T
* (rowwise in (a A - b B) , or columnwise in (a A - b B) )
*
IL2BY2 = .FALSE.
* ------------------- Begin Timing Code ----------------------
OPST = ZERO
IN2BY2 = 0
* -------------------- End Timing Code -----------------------
*
DO 160 J = JE + NW, N
* ------------------- Begin Timing Code -------------------
OPSSCA = REAL( NW*( J-JE )+1 )
* -------------------- End Timing Code --------------------
IF( IL2BY2 ) THEN
IL2BY2 = .FALSE.
GO TO 160
END IF
*
NA = 1
BDIAG( 1 ) = B( J, J )
IF( J.LT.N ) THEN
IF( A( J+1, J ).NE.ZERO ) THEN
IL2BY2 = .TRUE.
BDIAG( 2 ) = B( J+1, J+1 )
NA = 2
* ---------------- Begin Timing Code ----------------
IN2BY2 = IN2BY2 + 1
* ----------------- End Timing Code -----------------
END IF
END IF
*
* Check whether scaling is necessary for dot products
*
XSCALE = ONE / MAX( ONE, XMAX )
TEMP = MAX( WORK( J ), WORK( N+J ),
$ ACOEFA*WORK( J )+BCOEFA*WORK( N+J ) )
IF( IL2BY2 )
$ TEMP = MAX( TEMP, WORK( J+1 ), WORK( N+J+1 ),
$ ACOEFA*WORK( J+1 )+BCOEFA*WORK( N+J+1 ) )
IF( TEMP.GT.BIGNUM*XSCALE ) THEN
DO 90 JW = 0, NW - 1
DO 80 JR = JE, J - 1
WORK( ( JW+2 )*N+JR ) = XSCALE*
$ WORK( ( JW+2 )*N+JR )
80 CONTINUE
90 CONTINUE
XMAX = XMAX*XSCALE
* ------------------ Begin Timing Code -----------------
OPST = OPST + OPSSCA
* ------------------- End Timing Code ------------------
END IF
*
* Compute dot products
*
* j-1
* SUM = sum conjg( a*A(k,j) - b*B(k,j) )*x(k)
* k=je
*
* To reduce the op count, this is done as
*
* _ j-1 _ j-1
* a*conjg( sum A(k,j)*x(k) ) - b*conjg( sum B(k,j)*x(k) )
* k=je k=je
*
* which may cause underflow problems if A or B are close
* to underflow. (E.g., less than SMALL.)
*
*
* A series of compiler directives to defeat vectorization
* for the next loop
*
*$PL$ CMCHAR=' '
CDIR$ NEXTSCALAR
C$DIR SCALAR
CDIR$ NEXT SCALAR
CVD$L NOVECTOR
CDEC$ NOVECTOR
CVD$ NOVECTOR
*VDIR NOVECTOR
*VOCL LOOP,SCALAR
CIBM PREFER SCALAR
*$PL$ CMCHAR='*'
*
DO 120 JW = 1, NW
*
*$PL$ CMCHAR=' '
CDIR$ NEXTSCALAR
C$DIR SCALAR
CDIR$ NEXT SCALAR
CVD$L NOVECTOR
CDEC$ NOVECTOR
CVD$ NOVECTOR
*VDIR NOVECTOR
*VOCL LOOP,SCALAR
CIBM PREFER SCALAR
*$PL$ CMCHAR='*'
*
DO 110 JA = 1, NA
SUMA( JA, JW ) = ZERO
SUMB( JA, JW ) = ZERO
*
DO 100 JR = JE, J - 1
SUMA( JA, JW ) = SUMA( JA, JW ) +
$ A( JR, J+JA-1 )*
$ WORK( ( JW+1 )*N+JR )
SUMB( JA, JW ) = SUMB( JA, JW ) +
$ B( JR, J+JA-1 )*
$ WORK( ( JW+1 )*N+JR )
100 CONTINUE
110 CONTINUE
120 CONTINUE
*
*$PL$ CMCHAR=' '
CDIR$ NEXTSCALAR
C$DIR SCALAR
CDIR$ NEXT SCALAR
CVD$L NOVECTOR
CDEC$ NOVECTOR
CVD$ NOVECTOR
*VDIR NOVECTOR
*VOCL LOOP,SCALAR
CIBM PREFER SCALAR
*$PL$ CMCHAR='*'
*
DO 130 JA = 1, NA
IF( ILCPLX ) THEN
SUM( JA, 1 ) = -ACOEF*SUMA( JA, 1 ) +
$ BCOEFR*SUMB( JA, 1 ) -
$ BCOEFI*SUMB( JA, 2 )
SUM( JA, 2 ) = -ACOEF*SUMA( JA, 2 ) +
$ BCOEFR*SUMB( JA, 2 ) +
$ BCOEFI*SUMB( JA, 1 )
ELSE
SUM( JA, 1 ) = -ACOEF*SUMA( JA, 1 ) +
$ BCOEFR*SUMB( JA, 1 )
END IF
130 CONTINUE
*
* T
* Solve ( a A - b B ) y = SUM(,)
* with scaling and perturbation of the denominator
*
CALL SLALN2( .TRUE., NA, NW, DMIN, ACOEF, A( J, J ), LDA,
$ BDIAG( 1 ), BDIAG( 2 ), SUM, 2, BCOEFR,
$ BCOEFI, WORK( 2*N+J ), N, SCALE, TEMP,
$ IINFO )
IF( SCALE.LT.ONE ) THEN
DO 150 JW = 0, NW - 1
DO 140 JR = JE, J - 1
WORK( ( JW+2 )*N+JR ) = SCALE*
$ WORK( ( JW+2 )*N+JR )
140 CONTINUE
150 CONTINUE
XMAX = SCALE*XMAX
* ------------------ Begin Timing Code -----------------
OPST = OPST + OPSSCA
* ------------------- End Timing Code ------------------
END IF
XMAX = MAX( XMAX, TEMP )
160 CONTINUE
*
* Copy eigenvector to VL, back transforming if
* HOWMNY='B'.
*
IEIG = IEIG + 1
IF( ILBACK ) THEN
DO 170 JW = 0, NW - 1
CALL SGEMV( 'N', N, N+1-JE, ONE, VL( 1, JE ), LDVL,
$ WORK( ( JW+2 )*N+JE ), 1, ZERO,
$ WORK( ( JW+4 )*N+1 ), 1 )
170 CONTINUE
CALL SLACPY( ' ', N, NW, WORK( 4*N+1 ), N, VL( 1, JE ),
$ LDVL )
IBEG = 1
ELSE
CALL SLACPY( ' ', N, NW, WORK( 2*N+1 ), N, VL( 1, IEIG ),
$ LDVL )
IBEG = JE
END IF
*
* Scale eigenvector
*
XMAX = ZERO
IF( ILCPLX ) THEN
DO 180 J = IBEG, N
XMAX = MAX( XMAX, ABS( VL( J, IEIG ) )+
$ ABS( VL( J, IEIG+1 ) ) )
180 CONTINUE
ELSE
DO 190 J = IBEG, N
XMAX = MAX( XMAX, ABS( VL( J, IEIG ) ) )
190 CONTINUE
END IF
*
IF( XMAX.GT.SAFMIN ) THEN
XSCALE = ONE / XMAX
*
DO 210 JW = 0, NW - 1
DO 200 JR = IBEG, N
VL( JR, IEIG+JW ) = XSCALE*VL( JR, IEIG+JW )
200 CONTINUE
210 CONTINUE
END IF
IEIG = IEIG + NW - 1
*
* ------------------- Begin Timing Code ----------------------
* Opcounts for each eigenvector
*
* Real Complex
* Initialization 8--16 71--87
*
* Dot Prod (per iter) 4*NA*(J-JE) + 2 8*NA*(J-JE) + 2
* + 6*NA + scaling + 13*NA + scaling
* Solve (per iter) NA*(5 + 7*(NA-1)) NA*(17 + 17*(NA-1))
* + scaling + scaling
*
* Back xform 2*N*(N+1-JE) - N 4*N*(N+1-JE) - 2*N
* Scaling (w/back x.) N 3*N
* Scaling (w/o back) N - (JE-1) 3*N - 3*(JE-1)
*
IF( .NOT.ILCPLX ) THEN
OPST = OPST + REAL( 2*( N-JE )*( N+1-JE )+13*( N-JE )+8*
$ IN2BY2+12 )
IF( ILBACK ) THEN
OPST = OPST + REAL( 2*N*( N+1-JE ) )
ELSE
OPST = OPST + REAL( N+1-JE )
END IF
ELSE
OPST = OPST + REAL( 32*( N-1-JE )+4*( N-JE )*( N+1-JE )+
$ 24*IN2BY2+71 )
IF( ILBACK ) THEN
OPST = OPST + REAL( 4*N*( N+1-JE )+N )
ELSE
OPST = OPST + REAL( 3*( N+1-JE ) )
END IF
END IF
OPS = OPS + OPST
*
* -------------------- End Timing Code -----------------------
*
220 CONTINUE
END IF
*
* Right eigenvectors
*
IF( COMPR ) THEN
IEIG = IM + 1
*
* Main loop over eigenvalues
*
ILCPLX = .FALSE.
DO 500 JE = N, 1, -1
*
* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or
* (b) this would be the second of a complex pair.
* Check for complex eigenvalue, so as to be sure of which
* entry(-ies) of SELECT to look at -- if complex, SELECT(JE)
* or SELECT(JE-1).
* If this is a complex pair, the 2-by-2 diagonal block
* corresponding to the eigenvalue is in rows/columns JE-1:JE
*
IF( ILCPLX ) THEN
ILCPLX = .FALSE.
GO TO 500
END IF
NW = 1
IF( JE.GT.1 ) THEN
IF( A( JE, JE-1 ).NE.ZERO ) THEN
ILCPLX = .TRUE.
NW = 2
END IF
END IF
IF( ILALL ) THEN
ILCOMP = .TRUE.
ELSE IF( ILCPLX ) THEN
ILCOMP = SELECT( JE ) .OR. SELECT( JE-1 )
ELSE
ILCOMP = SELECT( JE )
END IF
IF( .NOT.ILCOMP )
$ GO TO 500
*
* Decide if (a) singular pencil, (b) real eigenvalue, or
* (c) complex eigenvalue.
*
IF( .NOT.ILCPLX ) THEN
IF( ABS( A( JE, JE ) ).LE.SAFMIN .AND.
$ ABS( B( JE, JE ) ).LE.SAFMIN ) THEN
*
* Singular matrix pencil -- returns unit eigenvector
*
IEIG = IEIG - 1
DO 230 JR = 1, N
VR( JR, IEIG ) = ZERO
230 CONTINUE
VR( IEIG, IEIG ) = ONE
GO TO 500
END IF
END IF
*
* Clear vector
*
DO 250 JW = 0, NW - 1
DO 240 JR = 1, N
WORK( ( JW+2 )*N+JR ) = ZERO
240 CONTINUE
250 CONTINUE
*
* Compute coefficients in ( a A - b B ) x = 0
* a is ACOEF
* b is BCOEFR + i*BCOEFI
*
IF( .NOT.ILCPLX ) THEN
*
* Real eigenvalue
*
TEMP = ONE / MAX( ABS( A( JE, JE ) )*ASCALE,
$ ABS( B( JE, JE ) )*BSCALE, SAFMIN )
SALFAR = ( TEMP*A( JE, JE ) )*ASCALE
SBETA = ( TEMP*B( JE, JE ) )*BSCALE
ACOEF = SBETA*ASCALE
BCOEFR = SALFAR*BSCALE
BCOEFI = ZERO
*
* Scale to avoid underflow
*
SCALE = ONE
LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEF ).LT.SMALL
LSB = ABS( SALFAR ).GE.SAFMIN .AND. ABS( BCOEFR ).LT.
$ SMALL
IF( LSA )
$ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG )
IF( LSB )
$ SCALE = MAX( SCALE, ( SMALL / ABS( SALFAR ) )*
$ MIN( BNORM, BIG ) )
IF( LSA .OR. LSB ) THEN
SCALE = MIN( SCALE, ONE /
$ ( SAFMIN*MAX( ONE, ABS( ACOEF ),
$ ABS( BCOEFR ) ) ) )
IF( LSA ) THEN
ACOEF = ASCALE*( SCALE*SBETA )
ELSE
ACOEF = SCALE*ACOEF
END IF
IF( LSB ) THEN
BCOEFR = BSCALE*( SCALE*SALFAR )
ELSE
BCOEFR = SCALE*BCOEFR
END IF
END IF
ACOEFA = ABS( ACOEF )
BCOEFA = ABS( BCOEFR )
*
* First component is 1
*
WORK( 2*N+JE ) = ONE
XMAX = ONE
*
* Compute contribution from column JE of A and B to sum
* (See "Further Details", above.)
*
DO 260 JR = 1, JE - 1
WORK( 2*N+JR ) = BCOEFR*B( JR, JE ) -
$ ACOEF*A( JR, JE )
260 CONTINUE
ELSE
*
* Complex eigenvalue
*
CALL SLAG2( A( JE-1, JE-1 ), LDA, B( JE-1, JE-1 ), LDB,
$ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2,
$ BCOEFI )
IF( BCOEFI.EQ.ZERO ) THEN
INFO = JE - 1
RETURN
END IF
*
* Scale to avoid over/underflow
*
ACOEFA = ABS( ACOEF )
BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
SCALE = ONE
IF( ACOEFA*ULP.LT.SAFMIN .AND. ACOEFA.GE.SAFMIN )
$ SCALE = ( SAFMIN / ULP ) / ACOEFA
IF( BCOEFA*ULP.LT.SAFMIN .AND. BCOEFA.GE.SAFMIN )
$ SCALE = MAX( SCALE, ( SAFMIN / ULP ) / BCOEFA )
IF( SAFMIN*ACOEFA.GT.ASCALE )
$ SCALE = ASCALE / ( SAFMIN*ACOEFA )
IF( SAFMIN*BCOEFA.GT.BSCALE )
$ SCALE = MIN( SCALE, BSCALE / ( SAFMIN*BCOEFA ) )
IF( SCALE.NE.ONE ) THEN
ACOEF = SCALE*ACOEF
ACOEFA = ABS( ACOEF )
BCOEFR = SCALE*BCOEFR
BCOEFI = SCALE*BCOEFI
BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
END IF
*
* Compute first two components of eigenvector
* and contribution to sums
*
TEMP = ACOEF*A( JE, JE-1 )
TEMP2R = ACOEF*A( JE, JE ) - BCOEFR*B( JE, JE )
TEMP2I = -BCOEFI*B( JE, JE )
IF( ABS( TEMP ).GE.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN
WORK( 2*N+JE ) = ONE
WORK( 3*N+JE ) = ZERO
WORK( 2*N+JE-1 ) = -TEMP2R / TEMP
WORK( 3*N+JE-1 ) = -TEMP2I / TEMP
ELSE
WORK( 2*N+JE-1 ) = ONE
WORK( 3*N+JE-1 ) = ZERO
TEMP = ACOEF*A( JE-1, JE )
WORK( 2*N+JE ) = ( BCOEFR*B( JE-1, JE-1 )-ACOEF*
$ A( JE-1, JE-1 ) ) / TEMP
WORK( 3*N+JE ) = BCOEFI*B( JE-1, JE-1 ) / TEMP
END IF
*
XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ),
$ ABS( WORK( 2*N+JE-1 ) )+ABS( WORK( 3*N+JE-1 ) ) )
*
* Compute contribution from columns JE and JE-1
* of A and B to the sums.
*
CREALA = ACOEF*WORK( 2*N+JE-1 )
CIMAGA = ACOEF*WORK( 3*N+JE-1 )
CREALB = BCOEFR*WORK( 2*N+JE-1 ) -
$ BCOEFI*WORK( 3*N+JE-1 )
CIMAGB = BCOEFI*WORK( 2*N+JE-1 ) +
$ BCOEFR*WORK( 3*N+JE-1 )
CRE2A = ACOEF*WORK( 2*N+JE )
CIM2A = ACOEF*WORK( 3*N+JE )
CRE2B = BCOEFR*WORK( 2*N+JE ) - BCOEFI*WORK( 3*N+JE )
CIM2B = BCOEFI*WORK( 2*N+JE ) + BCOEFR*WORK( 3*N+JE )
DO 270 JR = 1, JE - 2
WORK( 2*N+JR ) = -CREALA*A( JR, JE-1 ) +
$ CREALB*B( JR, JE-1 ) -
$ CRE2A*A( JR, JE ) + CRE2B*B( JR, JE )
WORK( 3*N+JR ) = -CIMAGA*A( JR, JE-1 ) +
$ CIMAGB*B( JR, JE-1 ) -
$ CIM2A*A( JR, JE ) + CIM2B*B( JR, JE )
270 CONTINUE
END IF
*
DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN )
*
* Columnwise triangular solve of (a A - b B) x = 0
*
IL2BY2 = .FALSE.
* ------------------- Begin Timing Code ----------------------
OPST = ZERO
IN2BY2 = 0
* -------------------- End Timing Code -----------------------
DO 370 J = JE - NW, 1, -1
* ------------------- Begin Timing Code -------------------
OPSSCA = REAL( NW*JE+1 )
* -------------------- End Timing Code --------------------
*
* If a 2-by-2 block, is in position j-1:j, wait until
* next iteration to process it (when it will be j:j+1)
*
IF( .NOT.IL2BY2 .AND. J.GT.1 ) THEN
IF( A( J, J-1 ).NE.ZERO ) THEN
IL2BY2 = .TRUE.
* -------------- Begin Timing Code -----------------
IN2BY2 = IN2BY2 + 1
* --------------- End Timing Code -------------------
GO TO 370
END IF
END IF
BDIAG( 1 ) = B( J, J )
IF( IL2BY2 ) THEN
NA = 2
BDIAG( 2 ) = B( J+1, J+1 )
ELSE
NA = 1
END IF
*
* Compute x(j) (and x(j+1), if 2-by-2 block)
*
CALL SLALN2( .FALSE., NA, NW, DMIN, ACOEF, A( J, J ),
$ LDA, BDIAG( 1 ), BDIAG( 2 ), WORK( 2*N+J ),
$ N, BCOEFR, BCOEFI, SUM, 2, SCALE, TEMP,
$ IINFO )
IF( SCALE.LT.ONE ) THEN
*
DO 290 JW = 0, NW - 1
DO 280 JR = 1, JE
WORK( ( JW+2 )*N+JR ) = SCALE*
$ WORK( ( JW+2 )*N+JR )
280 CONTINUE
290 CONTINUE
END IF
XMAX = MAX( SCALE*XMAX, TEMP )
* ------------------ Begin Timing Code -----------------
OPST = OPST + OPSSCA
* ------------------- End Timing Code ------------------
*
DO 310 JW = 1, NW
DO 300 JA = 1, NA
WORK( ( JW+1 )*N+J+JA-1 ) = SUM( JA, JW )
300 CONTINUE
310 CONTINUE
*
* w = w + x(j)*(a A(*,j) - b B(*,j) ) with scaling
*
IF( J.GT.1 ) THEN
*
* Check whether scaling is necessary for sum.
*
XSCALE = ONE / MAX( ONE, XMAX )
TEMP = ACOEFA*WORK( J ) + BCOEFA*WORK( N+J )
IF( IL2BY2 )
$ TEMP = MAX( TEMP, ACOEFA*WORK( J+1 )+BCOEFA*
$ WORK( N+J+1 ) )
TEMP = MAX( TEMP, ACOEFA, BCOEFA )
IF( TEMP.GT.BIGNUM*XSCALE ) THEN
*
DO 330 JW = 0, NW - 1
DO 320 JR = 1, JE
WORK( ( JW+2 )*N+JR ) = XSCALE*
$ WORK( ( JW+2 )*N+JR )
320 CONTINUE
330 CONTINUE
XMAX = XMAX*XSCALE
* ----------------- Begin Timing Code ---------------
OPST = OPST + OPSSCA
* ------------------ End Timing Code ----------------
END IF
*
* Compute the contributions of the off-diagonals of
* column j (and j+1, if 2-by-2 block) of A and B to the
* sums.
*
*
DO 360 JA = 1, NA
IF( ILCPLX ) THEN
CREALA = ACOEF*WORK( 2*N+J+JA-1 )
CIMAGA = ACOEF*WORK( 3*N+J+JA-1 )
CREALB = BCOEFR*WORK( 2*N+J+JA-1 ) -
$ BCOEFI*WORK( 3*N+J+JA-1 )
CIMAGB = BCOEFI*WORK( 2*N+J+JA-1 ) +
$ BCOEFR*WORK( 3*N+J+JA-1 )
DO 340 JR = 1, J - 1
WORK( 2*N+JR ) = WORK( 2*N+JR ) -
$ CREALA*A( JR, J+JA-1 ) +
$ CREALB*B( JR, J+JA-1 )
WORK( 3*N+JR ) = WORK( 3*N+JR ) -
$ CIMAGA*A( JR, J+JA-1 ) +
$ CIMAGB*B( JR, J+JA-1 )
340 CONTINUE
ELSE
CREALA = ACOEF*WORK( 2*N+J+JA-1 )
CREALB = BCOEFR*WORK( 2*N+J+JA-1 )
DO 350 JR = 1, J - 1
WORK( 2*N+JR ) = WORK( 2*N+JR ) -
$ CREALA*A( JR, J+JA-1 ) +
$ CREALB*B( JR, J+JA-1 )
350 CONTINUE
END IF
360 CONTINUE
END IF
*
IL2BY2 = .FALSE.
370 CONTINUE
*
* Copy eigenvector to VR, back transforming if
* HOWMNY='B'.
*
IEIG = IEIG - NW
IF( ILBACK ) THEN
*
DO 410 JW = 0, NW - 1
DO 380 JR = 1, N
WORK( ( JW+4 )*N+JR ) = WORK( ( JW+2 )*N+1 )*
$ VR( JR, 1 )
380 CONTINUE
*
* A series of compiler directives to defeat
* vectorization for the next loop
*
*
DO 400 JC = 2, JE
DO 390 JR = 1, N
WORK( ( JW+4 )*N+JR ) = WORK( ( JW+4 )*N+JR ) +
$ WORK( ( JW+2 )*N+JC )*VR( JR, JC )
390 CONTINUE
400 CONTINUE
410 CONTINUE
*
DO 430 JW = 0, NW - 1
DO 420 JR = 1, N
VR( JR, IEIG+JW ) = WORK( ( JW+4 )*N+JR )
420 CONTINUE
430 CONTINUE
*
IEND = N
ELSE
DO 450 JW = 0, NW - 1
DO 440 JR = 1, N
VR( JR, IEIG+JW ) = WORK( ( JW+2 )*N+JR )
440 CONTINUE
450 CONTINUE
*
IEND = JE
END IF
*
* Scale eigenvector
*
XMAX = ZERO
IF( ILCPLX ) THEN
DO 460 J = 1, IEND
XMAX = MAX( XMAX, ABS( VR( J, IEIG ) )+
$ ABS( VR( J, IEIG+1 ) ) )
460 CONTINUE
ELSE
DO 470 J = 1, IEND
XMAX = MAX( XMAX, ABS( VR( J, IEIG ) ) )
470 CONTINUE
END IF
*
IF( XMAX.GT.SAFMIN ) THEN
XSCALE = ONE / XMAX
DO 490 JW = 0, NW - 1
DO 480 JR = 1, IEND
VR( JR, IEIG+JW ) = XSCALE*VR( JR, IEIG+JW )
480 CONTINUE
490 CONTINUE
END IF
*
* ------------------- Begin Timing Code ----------------------
* Opcounts for each eigenvector
*
* Real Complex
* Initialization 8--16 + 3*(JE-1) 71--87+16+14*(JE-2)
*
* Solve (per iter) NA*(5 + 7*(NA-1)) NA*(17 + 17*(NA-1))
* + scaling + scaling
* column add (per iter)
* 2 + 5*NA 2 + 11*NA
* + 4*NA*(J-1) + 8*NA*(J-1)
* + scaling + scaling
* iteration: J=JE-1,...,1 J=JE-2,...,1
*
* Back xform 2*N*JE - N 4*N*JE - 2*N
* Scaling (w/back x.) N 3*N
* Scaling (w/o back) JE 3*JE
*
IF( .NOT.ILCPLX ) THEN
OPST = OPST + REAL( ( 2*JE+11 )*( JE-1 )+12+8*IN2BY2 )
IF( ILBACK ) THEN
OPST = OPST + REAL( 2*N*JE )
ELSE
OPST = OPST + REAL( JE )
END IF
ELSE
OPST = OPST + REAL( ( 4*JE+32 )*( JE-2 )+95+24*IN2BY2 )
IF( ILBACK ) THEN
OPST = OPST + REAL( 4*N*JE+N )
ELSE
OPST = OPST + REAL( 3*JE )
END IF
END IF
OPS = OPS + OPST
*
* -------------------- End Timing Code -----------------------
*
500 CONTINUE
END IF
*
RETURN
*
* End of STGEVC
*
END
SUBROUTINE STREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
$ LDVR, MM, M, WORK, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER HOWMNY, SIDE
INTEGER INFO, LDT, LDVL, LDVR, M, MM, N
* ..
* .. Array Arguments ..
LOGICAL SELECT( * )
REAL T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
$ WORK( * )
* ..
* Common block to return operation count.
* OPS is only incremented, OPST is used to accumulate small
* contributions to OPS to avoid roundoff error
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* STREVC computes some or all of the right and/or left eigenvectors of
* a real upper quasi-triangular matrix T.
*
* The right eigenvector x and the left eigenvector y of T corresponding
* to an eigenvalue w are defined by:
*
* T*x = w*x, y'*T = w*y'
*
* where y' denotes the conjugate transpose of the vector y.
*
* If all eigenvectors are requested, the routine may either return the
* matrices X and/or Y of right or left eigenvectors of T, or the
* products Q*X and/or Q*Y, where Q is an input orthogonal
* matrix. If T was obtained from the real-Schur factorization of an
* original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of
* right or left eigenvectors of A.
*
* T must be in Schur canonical form (as returned by SHSEQR), that is,
* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
* 2-by-2 diagonal block has its diagonal elements equal and its
* off-diagonal elements of opposite sign. Corresponding to each 2-by-2
* diagonal block is a complex conjugate pair of eigenvalues and
* eigenvectors; only one eigenvector of the pair is computed, namely
* the one corresponding to the eigenvalue with positive imaginary part.
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* = 'R': compute right eigenvectors only;
* = 'L': compute left eigenvectors only;
* = 'B': compute both right and left eigenvectors.
*
* HOWMNY (input) CHARACTER*1
* = 'A': compute all right and/or left eigenvectors;
* = 'B': compute all right and/or left eigenvectors,
* and backtransform them using the input matrices
* supplied in VR and/or VL;
* = 'S': compute selected right and/or left eigenvectors,
* specified by the logical array SELECT.
*
* SELECT (input/output) LOGICAL array, dimension (N)
* If HOWMNY = 'S', SELECT specifies the eigenvectors to be
* computed.
* If HOWMNY = 'A' or 'B', SELECT is not referenced.
* To select the real eigenvector corresponding to a real
* eigenvalue w(j), SELECT(j) must be set to .TRUE.. To select
* the complex eigenvector corresponding to a complex conjugate
* pair w(j) and w(j+1), either SELECT(j) or SELECT(j+1) must be
* set to .TRUE.; then on exit SELECT(j) is .TRUE. and
* SELECT(j+1) is .FALSE..
*
* N (input) INTEGER
* The order of the matrix T. N >= 0.
*
* T (input) REAL array, dimension (LDT,N)
* The upper quasi-triangular matrix T in Schur canonical form.
*
* LDT (input) INTEGER
* The leading dimension of the array T. LDT >= max(1,N).
*
* VL (input/output) REAL array, dimension (LDVL,MM)
* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
* contain an N-by-N matrix Q (usually the orthogonal matrix Q
* of Schur vectors returned by SHSEQR).
* On exit, if SIDE = 'L' or 'B', VL contains:
* if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
* VL has the same quasi-lower triangular form
* as T'. If T(i,i) is a real eigenvalue, then
* the i-th column VL(i) of VL is its
* corresponding eigenvector. If T(i:i+1,i:i+1)
* is a 2-by-2 block whose eigenvalues are
* complex-conjugate eigenvalues of T, then
* VL(i)+sqrt(-1)*VL(i+1) is the complex
* eigenvector corresponding to the eigenvalue
* with positive real part.
* if HOWMNY = 'B', the matrix Q*Y;
* if HOWMNY = 'S', the left eigenvectors of T specified by
* SELECT, stored consecutively in the columns
* of VL, in the same order as their
* eigenvalues.
* A complex eigenvector corresponding to a complex eigenvalue
* is stored in two consecutive columns, the first holding the
* real part, and the second the imaginary part.
* If SIDE = 'R', VL is not referenced.
*
* LDVL (input) INTEGER
* The leading dimension of the array VL. LDVL >= max(1,N) if
* SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
*
* VR (input/output) REAL array, dimension (LDVR,MM)
* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
* contain an N-by-N matrix Q (usually the orthogonal matrix Q
* of Schur vectors returned by SHSEQR).
* On exit, if SIDE = 'R' or 'B', VR contains:
* if HOWMNY = 'A', the matrix X of right eigenvectors of T;
* VR has the same quasi-upper triangular form
* as T. If T(i,i) is a real eigenvalue, then
* the i-th column VR(i) of VR is its
* corresponding eigenvector. If T(i:i+1,i:i+1)
* is a 2-by-2 block whose eigenvalues are
* complex-conjugate eigenvalues of T, then
* VR(i)+sqrt(-1)*VR(i+1) is the complex
* eigenvector corresponding to the eigenvalue
* with positive real part.
* if HOWMNY = 'B', the matrix Q*X;
* if HOWMNY = 'S', the right eigenvectors of T specified by
* SELECT, stored consecutively in the columns
* of VR, in the same order as their
* eigenvalues.
* A complex eigenvector corresponding to a complex eigenvalue
* is stored in two consecutive columns, the first holding the
* real part and the second the imaginary part.
* If SIDE = 'L', VR is not referenced.
*
* LDVR (input) INTEGER
* The leading dimension of the array VR. LDVR >= max(1,N) if
* SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
*
* MM (input) INTEGER
* The number of columns in the arrays VL and/or VR. MM >= M.
*
* M (output) INTEGER
* The number of columns in the arrays VL and/or VR actually
* used to store the eigenvectors.
* If HOWMNY = 'A' or 'B', M is set to N.
* Each selected real eigenvector occupies one column and each
* selected complex eigenvector occupies two columns.
*
* WORK (workspace) REAL array, dimension (3*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Further Details
* ===============
*
* The algorithm used in this program is basically backward (forward)
* substitution, with scaling to make the the code robust against
* possible overflow.
*
* Each eigenvector is normalized so that the element of largest
* magnitude has magnitude 1; here the magnitude of a complex number
* (x,y) is taken to be |x| + |y|.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL ALLV, BOTHV, LEFTV, OVER, PAIR, RIGHTV, SOMEV
INTEGER I, IERR, II, IP, IS, J, J1, J2, JNXT, K, KI, N2
REAL BETA, BIGNUM, EMAX, OPST, OVFL, REC, REMAX,
$ SCALE, SMIN, SMLNUM, ULP, UNFL, VCRIT, VMAX,
$ WI, WR, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SDOT, SLAMCH
EXTERNAL LSAME, ISAMAX, SDOT, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, SGEMV, SLABAD, SLALN2, SSCAL,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Local Arrays ..
REAL X( 2, 2 )
* ..
* .. Executable Statements ..
*
* Decode and test the input parameters
*
BOTHV = LSAME( SIDE, 'B' )
RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV
LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV
*
ALLV = LSAME( HOWMNY, 'A' )
OVER = LSAME( HOWMNY, 'B' )
SOMEV = LSAME( HOWMNY, 'S' )
*
INFO = 0
IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
INFO = -1
ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN
INFO = -8
ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN
INFO = -10
ELSE
*
* Set M to the number of columns required to store the selected
* eigenvectors, standardize the array SELECT if necessary, and
* test MM.
*
IF( SOMEV ) THEN
M = 0
PAIR = .FALSE.
DO 10 J = 1, N
IF( PAIR ) THEN
PAIR = .FALSE.
SELECT( J ) = .FALSE.
ELSE
IF( J.LT.N ) THEN
IF( T( J+1, J ).EQ.ZERO ) THEN
IF( SELECT( J ) )
$ M = M + 1
ELSE
PAIR = .TRUE.
IF( SELECT( J ) .OR. SELECT( J+1 ) ) THEN
SELECT( J ) = .TRUE.
M = M + 2
END IF
END IF
ELSE
IF( SELECT( N ) )
$ M = M + 1
END IF
END IF
10 CONTINUE
ELSE
M = N
END IF
*
IF( MM.LT.M ) THEN
INFO = -11
END IF
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'STREVC', -INFO )
RETURN
END IF
*
* Quick return if possible.
*
IF( N.EQ.0 )
$ RETURN
***
* Initialize
OPST = 0
***
*
* Set the constants to control overflow.
*
UNFL = SLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
CALL SLABAD( UNFL, OVFL )
ULP = SLAMCH( 'Precision' )
SMLNUM = UNFL*( N / ULP )
BIGNUM = ( ONE-ULP ) / SMLNUM
*
* Compute 1-norm of each column of strictly upper triangular
* part of T to control overflow in triangular solver.
*
WORK( 1 ) = ZERO
DO 30 J = 2, N
WORK( J ) = ZERO
DO 20 I = 1, J - 1
WORK( J ) = WORK( J ) + ABS( T( I, J ) )
20 CONTINUE
30 CONTINUE
***
OPS = OPS + N*( N-1 ) / 2
***
*
* Index IP is used to specify the real or complex eigenvalue:
* IP = 0, real eigenvalue,
* 1, first of conjugate complex pair: (wr,wi)
* -1, second of conjugate complex pair: (wr,wi)
*
N2 = 2*N
*
IF( RIGHTV ) THEN
*
* Compute right eigenvectors.
*
IP = 0
IS = M
DO 140 KI = N, 1, -1
*
IF( IP.EQ.1 )
$ GO TO 130
IF( KI.EQ.1 )
$ GO TO 40
IF( T( KI, KI-1 ).EQ.ZERO )
$ GO TO 40
IP = -1
*
40 CONTINUE
IF( SOMEV ) THEN
IF( IP.EQ.0 ) THEN
IF( .NOT.SELECT( KI ) )
$ GO TO 130
ELSE
IF( .NOT.SELECT( KI-1 ) )
$ GO TO 130
END IF
END IF
*
* Compute the KI-th eigenvalue (WR,WI).
*
WR = T( KI, KI )
WI = ZERO
IF( IP.NE.0 )
$ WI = SQRT( ABS( T( KI, KI-1 ) ) )*
$ SQRT( ABS( T( KI-1, KI ) ) )
SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM )
*
IF( IP.EQ.0 ) THEN
*
* Real right eigenvector
*
WORK( KI+N ) = ONE
*
* Form right-hand side
*
DO 50 K = 1, KI - 1
WORK( K+N ) = -T( K, KI )
50 CONTINUE
*
* Solve the upper quasi-triangular system:
* (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK.
*
JNXT = KI - 1
DO 60 J = KI - 1, 1, -1
IF( J.GT.JNXT )
$ GO TO 60
J1 = J
J2 = J
JNXT = J - 1
IF( J.GT.1 ) THEN
IF( T( J, J-1 ).NE.ZERO ) THEN
J1 = J - 1
JNXT = J - 2
END IF
END IF
*
IF( J1.EQ.J2 ) THEN
*
* 1-by-1 diagonal block
*
CALL SLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ),
$ LDT, ONE, ONE, WORK( J+N ), N, WR,
$ ZERO, X, 2, SCALE, XNORM, IERR )
*
* Scale X(1,1) to avoid overflow when updating
* the right-hand side.
*
IF( XNORM.GT.ONE ) THEN
IF( WORK( J ).GT.BIGNUM / XNORM ) THEN
X( 1, 1 ) = X( 1, 1 ) / XNORM
SCALE = SCALE / XNORM
END IF
END IF
*
* Scale if necessary
*
IF( SCALE.NE.ONE )
$ CALL SSCAL( KI, SCALE, WORK( 1+N ), 1 )
WORK( J+N ) = X( 1, 1 )
*
* Update right-hand side
*
CALL SAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1,
$ WORK( 1+N ), 1 )
***
* Increment op count, ignoring the possible scaling
OPST = OPST + ( 2*( J-1 )+6 )
***
*
ELSE
*
* 2-by-2 diagonal block
*
CALL SLALN2( .FALSE., 2, 1, SMIN, ONE,
$ T( J-1, J-1 ), LDT, ONE, ONE,
$ WORK( J-1+N ), N, WR, ZERO, X, 2,
$ SCALE, XNORM, IERR )
*
* Scale X(1,1) and X(2,1) to avoid overflow when
* updating the right-hand side.
*
IF( XNORM.GT.ONE ) THEN
BETA = MAX( WORK( J-1 ), WORK( J ) )
IF( BETA.GT.BIGNUM / XNORM ) THEN
X( 1, 1 ) = X( 1, 1 ) / XNORM
X( 2, 1 ) = X( 2, 1 ) / XNORM
SCALE = SCALE / XNORM
END IF
END IF
*
* Scale if necessary
*
IF( SCALE.NE.ONE )
$ CALL SSCAL( KI, SCALE, WORK( 1+N ), 1 )
WORK( J-1+N ) = X( 1, 1 )
WORK( J+N ) = X( 2, 1 )
*
* Update right-hand side
*
CALL SAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1,
$ WORK( 1+N ), 1 )
CALL SAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1,
$ WORK( 1+N ), 1 )
***
* Increment op count, ignoring the possible scaling
OPST = OPST + ( 4*( J-2 )+24 )
***
END IF
60 CONTINUE
*
* Copy the vector x or Q*x to VR and normalize.
*
IF( .NOT.OVER ) THEN
CALL SCOPY( KI, WORK( 1+N ), 1, VR( 1, IS ), 1 )
*
II = ISAMAX( KI, VR( 1, IS ), 1 )
REMAX = ONE / ABS( VR( II, IS ) )
CALL SSCAL( KI, REMAX, VR( 1, IS ), 1 )
***
OPST = OPST + ( 2*KI+1 )
***
*
DO 70 K = KI + 1, N
VR( K, IS ) = ZERO
70 CONTINUE
ELSE
IF( KI.GT.1 )
$ CALL SGEMV( 'N', N, KI-1, ONE, VR, LDVR,
$ WORK( 1+N ), 1, WORK( KI+N ),
$ VR( 1, KI ), 1 )
*
II = ISAMAX( N, VR( 1, KI ), 1 )
REMAX = ONE / ABS( VR( II, KI ) )
CALL SSCAL( N, REMAX, VR( 1, KI ), 1 )
***
OPS = OPS + ( 2*N*KI+1 )
***
END IF
*
ELSE
*
* Complex right eigenvector.
*
* Initial solve
* [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]*X = 0.
* [ (T(KI,KI-1) T(KI,KI) ) ]
*
IF( ABS( T( KI-1, KI ) ).GE.ABS( T( KI, KI-1 ) ) ) THEN
WORK( KI-1+N ) = ONE
WORK( KI+N2 ) = WI / T( KI-1, KI )
ELSE
WORK( KI-1+N ) = -WI / T( KI, KI-1 )
WORK( KI+N2 ) = ONE
END IF
WORK( KI+N ) = ZERO
WORK( KI-1+N2 ) = ZERO
*
* Form right-hand side
*
DO 80 K = 1, KI - 2
WORK( K+N ) = -WORK( KI-1+N )*T( K, KI-1 )
WORK( K+N2 ) = -WORK( KI+N2 )*T( K, KI )
80 CONTINUE
***
OPST = OPST + 2*( KI-2 )
***
*
* Solve upper quasi-triangular system:
* (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2)
*
JNXT = KI - 2
DO 90 J = KI - 2, 1, -1
IF( J.GT.JNXT )
$ GO TO 90
J1 = J
J2 = J
JNXT = J - 1
IF( J.GT.1 ) THEN
IF( T( J, J-1 ).NE.ZERO ) THEN
J1 = J - 1
JNXT = J - 2
END IF
END IF
*
IF( J1.EQ.J2 ) THEN
*
* 1-by-1 diagonal block
*
CALL SLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ),
$ LDT, ONE, ONE, WORK( J+N ), N, WR, WI,
$ X, 2, SCALE, XNORM, IERR )
*
* Scale X(1,1) and X(1,2) to avoid overflow when
* updating the right-hand side.
*
IF( XNORM.GT.ONE ) THEN
IF( WORK( J ).GT.BIGNUM / XNORM ) THEN
X( 1, 1 ) = X( 1, 1 ) / XNORM
X( 1, 2 ) = X( 1, 2 ) / XNORM
SCALE = SCALE / XNORM
END IF
END IF
*
* Scale if necessary
*
IF( SCALE.NE.ONE ) THEN
CALL SSCAL( KI, SCALE, WORK( 1+N ), 1 )
CALL SSCAL( KI, SCALE, WORK( 1+N2 ), 1 )
END IF
WORK( J+N ) = X( 1, 1 )
WORK( J+N2 ) = X( 1, 2 )
*
* Update the right-hand side
*
CALL SAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1,
$ WORK( 1+N ), 1 )
CALL SAXPY( J-1, -X( 1, 2 ), T( 1, J ), 1,
$ WORK( 1+N2 ), 1 )
***
* Increment op count, ignoring the possible scaling
OPST = OPST + ( 4*( J-1 )+24 )
***
*
ELSE
*
* 2-by-2 diagonal block
*
CALL SLALN2( .FALSE., 2, 2, SMIN, ONE,
$ T( J-1, J-1 ), LDT, ONE, ONE,
$ WORK( J-1+N ), N, WR, WI, X, 2, SCALE,
$ XNORM, IERR )
*
* Scale X to avoid overflow when updating
* the right-hand side.
*
IF( XNORM.GT.ONE ) THEN
BETA = MAX( WORK( J-1 ), WORK( J ) )
IF( BETA.GT.BIGNUM / XNORM ) THEN
REC = ONE / XNORM
X( 1, 1 ) = X( 1, 1 )*REC
X( 1, 2 ) = X( 1, 2 )*REC
X( 2, 1 ) = X( 2, 1 )*REC
X( 2, 2 ) = X( 2, 2 )*REC
SCALE = SCALE*REC
END IF
END IF
*
* Scale if necessary
*
IF( SCALE.NE.ONE ) THEN
CALL SSCAL( KI, SCALE, WORK( 1+N ), 1 )
CALL SSCAL( KI, SCALE, WORK( 1+N2 ), 1 )
END IF
WORK( J-1+N ) = X( 1, 1 )
WORK( J+N ) = X( 2, 1 )
WORK( J-1+N2 ) = X( 1, 2 )
WORK( J+N2 ) = X( 2, 2 )
*
* Update the right-hand side
*
CALL SAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1,
$ WORK( 1+N ), 1 )
CALL SAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1,
$ WORK( 1+N ), 1 )
CALL SAXPY( J-2, -X( 1, 2 ), T( 1, J-1 ), 1,
$ WORK( 1+N2 ), 1 )
CALL SAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1,
$ WORK( 1+N2 ), 1 )
***
* Increment op count, ignoring the possible scaling
OPST = OPST + ( 8*( J-2 )+64 )
***
END IF
90 CONTINUE
*
* Copy the vector x or Q*x to VR and normalize.
*
IF( .NOT.OVER ) THEN
CALL SCOPY( KI, WORK( 1+N ), 1, VR( 1, IS-1 ), 1 )
CALL SCOPY( KI, WORK( 1+N2 ), 1, VR( 1, IS ), 1 )
*
EMAX = ZERO
DO 100 K = 1, KI
EMAX = MAX( EMAX, ABS( VR( K, IS-1 ) )+
$ ABS( VR( K, IS ) ) )
100 CONTINUE
*
REMAX = ONE / EMAX
CALL SSCAL( KI, REMAX, VR( 1, IS-1 ), 1 )
CALL SSCAL( KI, REMAX, VR( 1, IS ), 1 )
***
OPST = OPST + ( 4*KI+1 )
***
*
DO 110 K = KI + 1, N
VR( K, IS-1 ) = ZERO
VR( K, IS ) = ZERO
110 CONTINUE
*
ELSE
*
IF( KI.GT.2 ) THEN
CALL SGEMV( 'N', N, KI-2, ONE, VR, LDVR,
$ WORK( 1+N ), 1, WORK( KI-1+N ),
$ VR( 1, KI-1 ), 1 )
CALL SGEMV( 'N', N, KI-2, ONE, VR, LDVR,
$ WORK( 1+N2 ), 1, WORK( KI+N2 ),
$ VR( 1, KI ), 1 )
ELSE
CALL SSCAL( N, WORK( KI-1+N ), VR( 1, KI-1 ), 1 )
CALL SSCAL( N, WORK( KI+N2 ), VR( 1, KI ), 1 )
END IF
*
EMAX = ZERO
DO 120 K = 1, N
EMAX = MAX( EMAX, ABS( VR( K, KI-1 ) )+
$ ABS( VR( K, KI ) ) )
120 CONTINUE
REMAX = ONE / EMAX
CALL SSCAL( N, REMAX, VR( 1, KI-1 ), 1 )
CALL SSCAL( N, REMAX, VR( 1, KI ), 1 )
***
OPS = OPS + ( 4*N*( KI-2 )+6*N+1 )
***
END IF
END IF
*
IS = IS - 1
IF( IP.NE.0 )
$ IS = IS - 1
130 CONTINUE
IF( IP.EQ.1 )
$ IP = 0
IF( IP.EQ.-1 )
$ IP = 1
140 CONTINUE
END IF
*
IF( LEFTV ) THEN
*
* Compute left eigenvectors.
*
IP = 0
IS = 1
DO 260 KI = 1, N
*
IF( IP.EQ.-1 )
$ GO TO 250
IF( KI.EQ.N )
$ GO TO 150
IF( T( KI+1, KI ).EQ.ZERO )
$ GO TO 150
IP = 1
*
150 CONTINUE
IF( SOMEV ) THEN
IF( .NOT.SELECT( KI ) )
$ GO TO 250
END IF
*
* Compute the KI-th eigenvalue (WR,WI).
*
WR = T( KI, KI )
WI = ZERO
IF( IP.NE.0 )
$ WI = SQRT( ABS( T( KI, KI+1 ) ) )*
$ SQRT( ABS( T( KI+1, KI ) ) )
SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM )
*
IF( IP.EQ.0 ) THEN
*
* Real left eigenvector.
*
WORK( KI+N ) = ONE
*
* Form right-hand side
*
DO 160 K = KI + 1, N
WORK( K+N ) = -T( KI, K )
160 CONTINUE
*
* Solve the quasi-triangular system:
* (T(KI+1:N,KI+1:N) - WR)'*X = SCALE*WORK
*
VMAX = ONE
VCRIT = BIGNUM
*
JNXT = KI + 1
DO 170 J = KI + 1, N
IF( J.LT.JNXT )
$ GO TO 170
J1 = J
J2 = J
JNXT = J + 1
IF( J.LT.N ) THEN
IF( T( J+1, J ).NE.ZERO ) THEN
J2 = J + 1
JNXT = J + 2
END IF
END IF
*
IF( J1.EQ.J2 ) THEN
*
* 1-by-1 diagonal block
*
* Scale if necessary to avoid overflow when forming
* the right-hand side.
*
IF( WORK( J ).GT.VCRIT ) THEN
REC = ONE / VMAX
CALL SSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
VMAX = ONE
VCRIT = BIGNUM
END IF
*
WORK( J+N ) = WORK( J+N ) -
$ SDOT( J-KI-1, T( KI+1, J ), 1,
$ WORK( KI+1+N ), 1 )
*
* Solve (T(J,J)-WR)'*X = WORK
*
CALL SLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ),
$ LDT, ONE, ONE, WORK( J+N ), N, WR,
$ ZERO, X, 2, SCALE, XNORM, IERR )
*
* Scale if necessary
*
IF( SCALE.NE.ONE )
$ CALL SSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
WORK( J+N ) = X( 1, 1 )
VMAX = MAX( ABS( WORK( J+N ) ), VMAX )
VCRIT = BIGNUM / VMAX
***
* Increment op count, ignoring the possible scaling
OPST = OPST + ( 2*( J-KI-1 )+6 )
***
*
ELSE
*
* 2-by-2 diagonal block
*
* Scale if necessary to avoid overflow when forming
* the right-hand side.
*
BETA = MAX( WORK( J ), WORK( J+1 ) )
IF( BETA.GT.VCRIT ) THEN
REC = ONE / VMAX
CALL SSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
VMAX = ONE
VCRIT = BIGNUM
END IF
*
WORK( J+N ) = WORK( J+N ) -
$ SDOT( J-KI-1, T( KI+1, J ), 1,
$ WORK( KI+1+N ), 1 )
*
WORK( J+1+N ) = WORK( J+1+N ) -
$ SDOT( J-KI-1, T( KI+1, J+1 ), 1,
$ WORK( KI+1+N ), 1 )
*
* Solve
* [T(J,J)-WR T(J,J+1) ]'* X = SCALE*( WORK1 )
* [T(J+1,J) T(J+1,J+1)-WR] ( WORK2 )
*
CALL SLALN2( .TRUE., 2, 1, SMIN, ONE, T( J, J ),
$ LDT, ONE, ONE, WORK( J+N ), N, WR,
$ ZERO, X, 2, SCALE, XNORM, IERR )
*
* Scale if necessary
*
IF( SCALE.NE.ONE )
$ CALL SSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
WORK( J+N ) = X( 1, 1 )
WORK( J+1+N ) = X( 2, 1 )
*
VMAX = MAX( ABS( WORK( J+N ) ),
$ ABS( WORK( J+1+N ) ), VMAX )
VCRIT = BIGNUM / VMAX
***
* Increment op count, ignoring the possible scaling
OPST = OPST + ( 4*( J-KI-1 )+24 )
***
*
END IF
170 CONTINUE
*
* Copy the vector x or Q*x to VL and normalize.
*
IF( .NOT.OVER ) THEN
CALL SCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 )
*
II = ISAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1
REMAX = ONE / ABS( VL( II, IS ) )
CALL SSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 )
***
OPST = OPST + ( 2*( N-KI+1 )+1 )
***
*
DO 180 K = 1, KI - 1
VL( K, IS ) = ZERO
180 CONTINUE
*
ELSE
*
IF( KI.LT.N )
$ CALL SGEMV( 'N', N, N-KI, ONE, VL( 1, KI+1 ), LDVL,
$ WORK( KI+1+N ), 1, WORK( KI+N ),
$ VL( 1, KI ), 1 )
*
II = ISAMAX( N, VL( 1, KI ), 1 )
REMAX = ONE / ABS( VL( II, KI ) )
CALL SSCAL( N, REMAX, VL( 1, KI ), 1 )
***
OPS = OPS + ( 2*N*( N-KI+1 )+1 )
***
*
END IF
*
ELSE
*
* Complex left eigenvector.
*
* Initial solve:
* ((T(KI,KI) T(KI,KI+1) )' - (WR - I* WI))*X = 0.
* ((T(KI+1,KI) T(KI+1,KI+1)) )
*
IF( ABS( T( KI, KI+1 ) ).GE.ABS( T( KI+1, KI ) ) ) THEN
WORK( KI+N ) = WI / T( KI, KI+1 )
WORK( KI+1+N2 ) = ONE
ELSE
WORK( KI+N ) = ONE
WORK( KI+1+N2 ) = -WI / T( KI+1, KI )
END IF
WORK( KI+1+N ) = ZERO
WORK( KI+N2 ) = ZERO
*
* Form right-hand side
*
DO 190 K = KI + 2, N
WORK( K+N ) = -WORK( KI+N )*T( KI, K )
WORK( K+N2 ) = -WORK( KI+1+N2 )*T( KI+1, K )
190 CONTINUE
***
OPST = OPST + 2*( N-KI-1 )
***
*
* Solve complex quasi-triangular system:
* ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2
*
VMAX = ONE
VCRIT = BIGNUM
*
JNXT = KI + 2
DO 200 J = KI + 2, N
IF( J.LT.JNXT )
$ GO TO 200
J1 = J
J2 = J
JNXT = J + 1
IF( J.LT.N ) THEN
IF( T( J+1, J ).NE.ZERO ) THEN
J2 = J + 1
JNXT = J + 2
END IF
END IF
*
IF( J1.EQ.J2 ) THEN
*
* 1-by-1 diagonal block
*
* Scale if necessary to avoid overflow when
* forming the right-hand side elements.
*
IF( WORK( J ).GT.VCRIT ) THEN
REC = ONE / VMAX
CALL SSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
CALL SSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 )
VMAX = ONE
VCRIT = BIGNUM
END IF
*
WORK( J+N ) = WORK( J+N ) -
$ SDOT( J-KI-2, T( KI+2, J ), 1,
$ WORK( KI+2+N ), 1 )
WORK( J+N2 ) = WORK( J+N2 ) -
$ SDOT( J-KI-2, T( KI+2, J ), 1,
$ WORK( KI+2+N2 ), 1 )
*
* Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2
*
CALL SLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ),
$ LDT, ONE, ONE, WORK( J+N ), N, WR,
$ -WI, X, 2, SCALE, XNORM, IERR )
*
* Scale if necessary
*
IF( SCALE.NE.ONE ) THEN
CALL SSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
CALL SSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 )
END IF
WORK( J+N ) = X( 1, 1 )
WORK( J+N2 ) = X( 1, 2 )
VMAX = MAX( ABS( WORK( J+N ) ),
$ ABS( WORK( J+N2 ) ), VMAX )
VCRIT = BIGNUM / VMAX
***
* Increment op count, ignoring the possible scaling
OPST = OPST + ( 4*( J-KI-2 )+24 )
***
*
ELSE
*
* 2-by-2 diagonal block
*
* Scale if necessary to avoid overflow when forming
* the right-hand side elements.
*
BETA = MAX( WORK( J ), WORK( J+1 ) )
IF( BETA.GT.VCRIT ) THEN
REC = ONE / VMAX
CALL SSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
CALL SSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 )
VMAX = ONE
VCRIT = BIGNUM
END IF
*
WORK( J+N ) = WORK( J+N ) -
$ SDOT( J-KI-2, T( KI+2, J ), 1,
$ WORK( KI+2+N ), 1 )
*
WORK( J+N2 ) = WORK( J+N2 ) -
$ SDOT( J-KI-2, T( KI+2, J ), 1,
$ WORK( KI+2+N2 ), 1 )
*
WORK( J+1+N ) = WORK( J+1+N ) -
$ SDOT( J-KI-2, T( KI+2, J+1 ), 1,
$ WORK( KI+2+N ), 1 )
*
WORK( J+1+N2 ) = WORK( J+1+N2 ) -
$ SDOT( J-KI-2, T( KI+2, J+1 ), 1,
$ WORK( KI+2+N2 ), 1 )
*
* Solve 2-by-2 complex linear equation
* ([T(j,j) T(j,j+1) ]'-(wr-i*wi)*I)*X = SCALE*B
* ([T(j+1,j) T(j+1,j+1)] )
*
CALL SLALN2( .TRUE., 2, 2, SMIN, ONE, T( J, J ),
$ LDT, ONE, ONE, WORK( J+N ), N, WR,
$ -WI, X, 2, SCALE, XNORM, IERR )
*
* Scale if necessary
*
IF( SCALE.NE.ONE ) THEN
CALL SSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
CALL SSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 )
END IF
WORK( J+N ) = X( 1, 1 )
WORK( J+N2 ) = X( 1, 2 )
WORK( J+1+N ) = X( 2, 1 )
WORK( J+1+N2 ) = X( 2, 2 )
VMAX = MAX( ABS( X( 1, 1 ) ), ABS( X( 1, 2 ) ),
$ ABS( X( 2, 1 ) ), ABS( X( 2, 2 ) ), VMAX )
VCRIT = BIGNUM / VMAX
***
* Increment op count, ignoring the possible scaling
OPST = OPST + ( 8*( J-KI-2 )+64 )
***
*
END IF
200 CONTINUE
*
* Copy the vector x or Q*x to VL and normalize.
*
210 CONTINUE
IF( .NOT.OVER ) THEN
CALL SCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 )
CALL SCOPY( N-KI+1, WORK( KI+N2 ), 1, VL( KI, IS+1 ),
$ 1 )
*
EMAX = ZERO
DO 220 K = KI, N
EMAX = MAX( EMAX, ABS( VL( K, IS ) )+
$ ABS( VL( K, IS+1 ) ) )
220 CONTINUE
REMAX = ONE / EMAX
CALL SSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 )
CALL SSCAL( N-KI+1, REMAX, VL( KI, IS+1 ), 1 )
***
OPST = OPST + ( 4*( N-KI+1 )+1 )
***
*
DO 230 K = 1, KI - 1
VL( K, IS ) = ZERO
VL( K, IS+1 ) = ZERO
230 CONTINUE
ELSE
IF( KI.LT.N-1 ) THEN
CALL SGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ),
$ LDVL, WORK( KI+2+N ), 1, WORK( KI+N ),
$ VL( 1, KI ), 1 )
CALL SGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ),
$ LDVL, WORK( KI+2+N2 ), 1,
$ WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 )
ELSE
CALL SSCAL( N, WORK( KI+N ), VL( 1, KI ), 1 )
CALL SSCAL( N, WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 )
END IF
*
EMAX = ZERO
DO 240 K = 1, N
EMAX = MAX( EMAX, ABS( VL( K, KI ) )+
$ ABS( VL( K, KI+1 ) ) )
240 CONTINUE
REMAX = ONE / EMAX
CALL SSCAL( N, REMAX, VL( 1, KI ), 1 )
CALL SSCAL( N, REMAX, VL( 1, KI+1 ), 1 )
***
OPS = OPS + ( 4*N*( N-KI-1 )+6*N+1 )
***
*
END IF
*
END IF
*
IS = IS + 1
IF( IP.NE.0 )
$ IS = IS + 1
250 CONTINUE
IF( IP.EQ.-1 )
$ IP = 0
IF( IP.EQ.1 )
$ IP = -1
*
260 CONTINUE
*
END IF
***
* Compute final op count
OPS = OPS + OPST
***
*
RETURN
*
* End of STREVC
*
END
REAL FUNCTION SOPBL3( SUBNAM, M, N, K )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
INTEGER K, M, N
* ..
*
* Purpose
* =======
*
* SOPBL3 computes an approximation of the number of floating point
* operations used by a subroutine SUBNAM with the given values
* of the parameters M, N, and K.
*
* This version counts operations for the Level 3 BLAS.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* M (input) INTEGER
* N (input) INTEGER
* K (input) INTEGER
* M, N, and K contain parameter values used by the Level 3
* BLAS. The output matrix is always M x N or N x N if
* symmetric, but K has different uses in different
* contexts. For example, in the matrix-matrix multiply
* routine, we have
* C = A * B
* where C is M x N, A is M x K, and B is K x N.
* In xSYMM, xTRMM, and xTRSM, K indicates whether the matrix
* A is applied on the left or right. If K <= 0, the matrix
* is applied on the left, if K > 0, on the right.
*
* =====================================================================
*
* .. Local Scalars ..
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 C3
REAL ADDS, EK, EM, EN, MULTS
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR.
$ .NOT.( LSAME( SUBNAM, 'S' ) .OR. LSAME( SUBNAM, 'D' ) .OR.
$ LSAME( SUBNAM, 'C' ) .OR. LSAME( SUBNAM, 'Z' ) ) ) THEN
SOPBL3 = 0
RETURN
END IF
*
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
MULTS = 0
ADDS = 0
EM = M
EN = N
EK = K
*
* ----------------------
* Matrix-matrix products
* assume beta = 1
* ----------------------
*
IF( LSAMEN( 3, C3, 'MM ' ) ) THEN
*
IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
MULTS = EM*EK*EN
ADDS = EM*EK*EN
*
ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) ) THEN
*
* IF K <= 0, assume A multiplies B on the left.
*
IF( K.LE.0 ) THEN
MULTS = EM*EM*EN
ADDS = EM*EM*EN
ELSE
MULTS = EM*EN*EN
ADDS = EM*EN*EN
END IF
*
ELSE IF( LSAMEN( 2, C2, 'TR' ) ) THEN
*
IF( K.LE.0 ) THEN
MULTS = EN*EM*( EM+1. ) / 2.
ADDS = EN*EM*( EM-1. ) / 2.
ELSE
MULTS = EM*EN*( EN+1. ) / 2.
ADDS = EM*EN*( EN-1. ) / 2.
END IF
*
END IF
*
* ------------------------------------------------
* Rank-K update of a symmetric or Hermitian matrix
* ------------------------------------------------
*
ELSE IF( LSAMEN( 3, C3, 'RK ' ) ) THEN
*
IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) ) THEN
*
MULTS = EK*EM*( EM+1. ) / 2.
ADDS = EK*EM*( EM+1. ) / 2.
END IF
*
* ------------------------------------------------
* Rank-2K update of a symmetric or Hermitian matrix
* ------------------------------------------------
*
ELSE IF( LSAMEN( 3, C3, 'R2K' ) ) THEN
*
IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) ) THEN
*
MULTS = EK*EM*EM
ADDS = EK*EM*EM + EM
END IF
*
* -----------------------------------------
* Solving system with many right hand sides
* -----------------------------------------
*
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'TRSM ' ) ) THEN
*
IF( K.LE.0 ) THEN
MULTS = EN*EM*( EM+1. ) / 2.
ADDS = EN*EM*( EM-1. ) / 2.
ELSE
MULTS = EM*EN*( EN+1. ) / 2.
ADDS = EM*EN*( EN-1. ) / 2.
END IF
*
END IF
*
* ------------------------------------------------
* Compute the total number of operations.
* For real and double precision routines, count
* 1 for each multiply and 1 for each add.
* For complex and complex*16 routines, count
* 6 for each multiply and 2 for each add.
* ------------------------------------------------
*
IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN
*
SOPBL3 = MULTS + ADDS
*
ELSE
*
SOPBL3 = 6*MULTS + 2*ADDS
*
END IF
*
RETURN
*
* End of SOPBL3
*
END
REAL FUNCTION SOPLA( SUBNAM, M, N, KL, KU, NB )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
INTEGER KL, KU, M, N, NB
* ..
*
* Purpose
* =======
*
* SOPLA computes an approximation of the number of floating point
* operations used by the subroutine SUBNAM with the given values
* of the parameters M, N, KL, KU, and NB.
*
* This version counts operations for the LAPACK subroutines.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* M (input) INTEGER
* The number of rows of the coefficient matrix. M >= 0.
*
* N (input) INTEGER
* The number of columns of the coefficient matrix.
* For solve routine when the matrix is square,
* N is the number of right hand sides. N >= 0.
*
* KL (input) INTEGER
* The lower band width of the coefficient matrix.
* If needed, 0 <= KL <= M-1.
* For xGEQRS, KL is the number of right hand sides.
*
* KU (input) INTEGER
* The upper band width of the coefficient matrix.
* If needed, 0 <= KU <= N-1.
*
* NB (input) INTEGER
* The block size. If needed, NB >= 1.
*
* Notes
* =====
*
* In the comments below, the association is given between arguments
* in the requested subroutine and local arguments. For example,
*
* xGETRS: N, NRHS => M, N
*
* means that arguments N and NRHS in SGETRS are passed to arguments
* M and N in this procedure.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL SORD, CORZ
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 C3
INTEGER I
REAL ADDFAC, ADDS, EK, EM, EN, EMN, MULFAC, MULTS,
$ WL, WU
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* --------------------------------------------------------
* Initialize SOPLA to 0 and do a quick return if possible.
* --------------------------------------------------------
*
SOPLA = 0
MULTS = 0
ADDS = 0
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
SORD = LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' )
CORZ = LSAME( C1, 'C' ) .OR. LSAME( C1, 'Z' )
IF( M.LE.0 .OR. .NOT.( SORD .OR. CORZ ) )
$ RETURN
*
* ---------------------------------------------------------
* If the coefficient matrix is real, count each add as 1
* operation and each multiply as 1 operation.
* If the coefficient matrix is complex, count each add as 2
* operations and each multiply as 6 operations.
* ---------------------------------------------------------
*
IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN
ADDFAC = 1
MULFAC = 1
ELSE
ADDFAC = 2
MULFAC = 6
END IF
EM = M
EN = N
EK = KL
*
* ---------------------------------
* GE: GEneral rectangular matrices
* ---------------------------------
*
IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
* xGETRF: M, N => M, N
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
EMN = MIN( M, N )
ADDS = EMN*( EM*EN - ( EM+EN )*( EMN+1. )/2. +
$ ( EMN+1. )*( 2.*EMN+1. )/6. )
MULTS = ADDS + EMN*( EM - ( EMN+1. )/2. )
*
* xGETRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*EM*EM
ADDS = EN*( EM*( EM-1. ) )
*
* xGETRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 5./6.+EM*( 1./2.+EM*( 2./3. ) ) )
ADDS = EM*( 5./6.+EM*( -3./2.+EM*( 2./3. ) ) )
*
* xGEQRF or xGEQLF: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'QRF' ) .OR. LSAMEN( 3, C3, 'QR2' )
$ .OR. LSAMEN( 3, C3, 'QLF' ) .OR. LSAMEN( 3, C3, 'QL2' ) )
$ THEN
IF( M.GE.N ) THEN
MULTS = EN*( ( ( 23./6. )+EM+EN/2. )+EN*( EM-EN/3. ) )
ADDS = EN*( ( 5./6. )+EN*( 1./2.+( EM-EN/3. ) ) )
ELSE
MULTS = EM*( ( ( 23./6. )+2.*EN-EM/2. )+EM*( EN-EM/3. ) )
ADDS = EM*( ( 5./6. )+EN-EM/2.+EM*( EN-EM/3. ) )
END IF
*
* xGERQF or xGELQF: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'RQF' ) .OR. LSAMEN( 3, C3, 'RQ2' )
$ .OR. LSAMEN( 3, C3, 'LQF' ) .OR. LSAMEN( 3, C3, 'LQ2' ) )
$ THEN
IF( M.GE.N ) THEN
MULTS = EN*( ( ( 29./6. )+EM+EN/2. )+EN*( EM-EN/3. ) )
ADDS = EN*( ( 5./6. )+EM+EN*( -1./2.+( EM-EN/3. ) ) )
ELSE
MULTS = EM*( ( ( 29./6. )+2.*EN-EM/2. )+EM*( EN-EM/3. ) )
ADDS = EM*( ( 5./6. )+EM/2.+EM*( EN-EM/3. ) )
END IF
*
* xGEQPF: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'QPF' ) ) THEN
EMN = MIN( M, N )
MULTS = 2*EN*EN + EMN*( 3*EM + 5*EN + 2*EM*EN -
$ ( EMN+1 )*( 4+EN+EM - ( 2*EMN+1 ) / 3 ) )
ADDS = EN*EN + EMN*( 2*EM + EN + 2*EM*EN -
$ ( EMN+1 )*( 2+EN+EM - ( 2*EMN+1 ) / 3 ) )
*
* xGEQRS or xGERQS: M, N, NRHS => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'QRS' ) .OR. LSAMEN( 3, C3, 'RQS' ) )
$ THEN
MULTS = EK*( EN*( 2.-EK ) +EM*( 2.*EN + (EM+1.)/2. ) )
ADDS = EK*( EN*( 1.-EK ) + EM*( 2.*EN + (EM-1.)/2. ) )
*
* xGELQS or xGEQLS: M, N, NRHS => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'LQS' ) .OR. LSAMEN( 3, C3, 'QLS' ) )
$ THEN
MULTS = EK*( EM*( 2.-EK ) +EN*( 2.*EM + (EN+1.)/2. ) )
ADDS = EK*( EM*( 1.-EK ) + EN*( 2.*EM + (EN-1.)/2. ) )
*
* xGEBRD: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'BRD' ) ) THEN
IF( M.GE.N ) THEN
MULTS = EN*( 20./3.+EN*( 2.+( 2.*EM-( 2./3. )*EN ) ) )
ADDS = EN*( 5./3.+( EN-EM )+EN*( 2.*EM-( 2./3. )*EN ) )
ELSE
MULTS = EM*( 20./3.+EM*( 2.+( 2.*EN-( 2./3. )*EM ) ) )
ADDS = EM*( 5./3.+( EM-EN )+EM*( 2.*EN-( 2./3. )*EM ) )
END IF
*
* xGEHRD: N => M
*
ELSE IF( LSAMEN( 3, C3, 'HRD' ) ) THEN
IF( M.EQ.1 ) THEN
MULTS = 0.
ADDS = 0.
ELSE
MULTS = -13. + EM*( -7./6.+EM*( 0.5+EM*( 5./3. ) ) )
ADDS = -8. + EM*( -2./3.+EM*( -1.+EM*( 5./3. ) ) )
END IF
*
END IF
*
* ----------------------------
* GB: General Banded matrices
* ----------------------------
* Note: The operation count is overestimated because
* it is assumed that the factor U fills in to the maximum
* extent, i.e., that its bandwidth goes from KU to KL + KU.
*
ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
*
* xGBTRF: M, N, KL, KU => M, N, KL, KU
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
DO 10 I = MIN( M, N ), 1, -1
WL = MAX( 0, MIN( KL, M-I ) )
WU = MAX( 0, MIN( KL+KU, N-I ) )
MULTS = MULTS + WL*( 1.+WU )
ADDS = ADDS + WL*WU
10 CONTINUE
*
* xGBTRS: N, NRHS, KL, KU => M, N, KL, KU
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
WL = MAX( 0, MIN( KL, M-1 ) )
WU = MAX( 0, MIN( KL+KU, M-1 ) )
MULTS = EN*( EM*( WL+1.+WU )-0.5*
$ ( WL*( WL+1. )+WU*( WU+1. ) ) )
ADDS = EN*( EM*( WL+WU )-0.5*( WL*( WL+1. )+WU*( WU+1. ) ) )
*
END IF
*
* --------------------------------------
* PO: POsitive definite matrices
* PP: Positive definite Packed matrices
* --------------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'PP' ) ) THEN
*
* xPOTRF: N => M
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = EM*( 1./3.+EM*( 1./2.+EM*( 1./6. ) ) )
ADDS = ( 1./6. )*EM*( -1.+EM*EM )
*
* xPOTRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*( EM*( EM+1. ) )
ADDS = EN*( EM*( EM-1. ) )
*
* xPOTRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 2./3.+EM*( 1.+EM*( 1./3. ) ) )
ADDS = EM*( 1./6.+EM*( -1./2.+EM*( 1./3. ) ) )
*
END IF
*
* ------------------------------------
* PB: Positive definite Band matrices
* ------------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN
*
* xPBTRF: N, K => M, KL
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = EK*( -2./3.+EK*( -1.+EK*( -1./3. ) ) ) +
$ EM*( 1.+EK*( 3./2.+EK*( 1./2. ) ) )
ADDS = EK*( -1./6.+EK*( -1./2.+EK*( -1./3. ) ) ) +
$ EM*( EK/2.*( 1.+EK ) )
*
* xPBTRS: N, NRHS, K => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*( ( 2*EM-EK )*( EK+1. ) )
ADDS = EN*( EK*( 2*EM-( EK+1. ) ) )
*
END IF
*
* --------------------------------------------------------
* SY: SYmmetric indefinite matrices
* SP: Symmetric indefinite Packed matrices
* HE: HErmitian indefinite matrices (complex only)
* HP: Hermitian indefinite Packed matrices (complex only)
* --------------------------------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHP' ) ) THEN
*
* xSYTRF: N => M
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = EM*( 10./3.+EM*( 1./2.+EM*( 1./6. ) ) )
ADDS = EM / 6.*( -1.+EM*EM )
*
* xSYTRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*EM*EM
ADDS = EN*( EM*( EM-1. ) )
*
* xSYTRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 2./3.+EM*EM*( 1./3. ) )
ADDS = EM*( -1./3.+EM*EM*( 1./3. ) )
*
* xSYTRD, xSYTD2: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRD' ) .OR. LSAMEN( 3, C3, 'TD2' ) )
$ THEN
IF( M.EQ.1 ) THEN
MULTS = 0.
ADDS = 0.
ELSE
MULTS = -15. + EM*( -1./6.+EM*( 5./2.+EM*( 2./3. ) ) )
ADDS = -4. + EM*( -8./3.+EM*( 1.+EM*( 2./3. ) ) )
END IF
END IF
*
* -------------------
* Triangular matrices
* -------------------
*
ELSE IF( LSAMEN( 2, C2, 'TR' ) .OR. LSAMEN( 2, C2, 'TP' ) ) THEN
*
* xTRTRS: N, NRHS => M, N
*
IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*EM*( EM+1. ) / 2.
ADDS = EN*EM*( EM-1. ) / 2.
*
* xTRTRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 1./3.+EM*( 1./2.+EM*( 1./6. ) ) )
ADDS = EM*( 1./3.+EM*( -1./2.+EM*( 1./6. ) ) )
*
END IF
*
ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
*
* xTBTRS: N, NRHS, K => M, N, KL
*
IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*( EM*( EM+1. ) / 2. -
$ ( EM-EK-1. )*( EM-EK ) / 2. )
ADDS = EN*( EM*( EM-1. ) / 2. -
$ ( EM-EK-1. )*( EM-EK ) / 2. )
END IF
*
* --------------------
* Trapezoidal matrices
* --------------------
*
ELSE IF( LSAMEN( 2, C2, 'TZ' ) ) THEN
*
* xTZRQF: M, N => M, N
*
IF( LSAMEN( 3, C3, 'RQF' ) ) THEN
EMN = MIN( M, N )
MULTS = 3*EM*( EN-EM+1 ) +
$ ( 2*EN-2*EM+3 )*( EM*EM - EMN*( EMN+1 )/2 )
ADDS = ( EN-EM+1 )*( EM + 2*EM*EM-EMN*( EMN+1 ) )
END IF
*
* -------------------
* Orthogonal matrices
* -------------------
*
ELSE IF( ( SORD .AND. LSAMEN( 2, C2, 'OR' ) ) .OR.
$ ( CORZ .AND. LSAMEN( 2, C2, 'UN' ) ) ) THEN
*
* -MQR, -MLQ, -MQL, or -MRQ: M, N, K, SIDE => M, N, KL, KU
* where KU<= 0 indicates SIDE = 'L'
* and KU> 0 indicates SIDE = 'R'
*
IF( LSAMEN( 3, C3, 'MQR' ) .OR. LSAMEN( 3, C3, 'MLQ' ) .OR.
$ LSAMEN( 3, C3, 'MQL' ) .OR. LSAMEN( 3, C3, 'MRQ' ) ) THEN
IF( KU.LE.0 ) THEN
MULTS = EK*EN*( 2.*EM + 2. - EK )
ADDS = EK*EN*( 2.*EM + 1. - EK )
ELSE
MULTS = EK*( EM*( 2.*EN - EK )+ ( EM+EN+( 1.-EK )/2. ) )
ADDS = EK*EM*( 2.*EN + 1. - EK )
END IF
*
* -GQR or -GQL: M, N, K => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'GQR' ) .OR. LSAMEN( 3, C3, 'GQL' ) )
$ THEN
MULTS = EK*( -5./3. + ( 2.*EN - EK ) +
$ ( 2.*EM*EN + EK*( ( 2./3. )*EK - EM - EN ) ) )
ADDS = EK*( 1./3. + ( EN - EM ) +
$ ( 2.*EM*EN + EK*( ( 2./3. )*EK - EM - EN ) ) )
*
* -GLQ or -GRQ: M, N, K => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'GLQ' ) .OR. LSAMEN( 3, C3, 'GRQ' ) )
$ THEN
MULTS = EK*( -2./3. + ( EM + EN - EK ) +
$ ( 2.*EM*EN + EK*( ( 2./3. )*EK - EM - EN ) ) )
ADDS = EK*( 1./3. + ( EM - EN ) +
$ ( 2.*EM*EN + EK*( ( 2./3. )*EK - EM - EN ) ) )
*
END IF
*
END IF
*
SOPLA = MULFAC*MULTS + ADDFAC*ADDS
*
RETURN
*
* End of SOPLA
*
END
REAL FUNCTION SOPLA2( SUBNAM, OPTS, M, N, K, L, NB )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
CHARACTER*( * ) OPTS
INTEGER K, L, M, N, NB
* ..
*
* Purpose
* =======
*
* SOPLA2 computes an approximation of the number of floating point
* operations used by the subroutine SUBNAM with character options
* OPTS and parameters M, N, K, L, and NB.
*
* This version counts operations for the LAPACK subroutines that
* call other LAPACK routines.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* OPTS (input) CHRACTER*(*)
* A string of character options to subroutine SUBNAM.
*
* M (input) INTEGER
* The number of rows of the coefficient matrix.
*
* N (input) INTEGER
* The number of columns of the coefficient matrix.
*
* K (input) INTEGER
* A third problem dimension, if needed.
*
* L (input) INTEGER
* A fourth problem dimension, if needed.
*
* NB (input) INTEGER
* The block size. If needed, NB >= 1.
*
* Notes
* =====
*
* In the comments below, the association is given between arguments
* in the requested subroutine and local arguments. For example,
*
* xORMBR: VECT // SIDE // TRANS, M, N, K => OPTS, M, N, K
*
* means that the character string VECT // SIDE // TRANS is passed to
* the argument OPTS, and the integer parameters M, N, and K are passed
* to the arguments M, N, and K,
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL CORZ, SORD
CHARACTER C1, SIDE, UPLO, VECT
CHARACTER*2 C2
CHARACTER*3 C3
CHARACTER*6 SUB2
INTEGER IHI, ILO, ISIDE, MI, NI, NQ
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
REAL SOPLA
EXTERNAL LSAME, LSAMEN, SOPLA
* ..
* .. Executable Statements ..
*
* ---------------------------------------------------------
* Initialize SOPLA2 to 0 and do a quick return if possible.
* ---------------------------------------------------------
*
SOPLA2 = 0
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
SORD = LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' )
CORZ = LSAME( C1, 'C' ) .OR. LSAME( C1, 'Z' )
IF( M.LE.0 .OR. .NOT.( SORD .OR. CORZ ) )
$ RETURN
*
* -------------------
* Orthogonal matrices
* -------------------
*
IF( ( SORD .AND. LSAMEN( 2, C2, 'OR' ) ) .OR.
$ ( CORZ .AND. LSAMEN( 2, C2, 'UN' ) ) ) THEN
*
IF( LSAMEN( 3, C3, 'GBR' ) ) THEN
*
* -GBR: VECT, M, N, K => OPTS, M, N, K
*
VECT = OPTS( 1: 1 )
IF( LSAME( VECT, 'Q' ) ) THEN
SUB2 = SUBNAM( 1: 3 ) // 'GQR'
IF( M.GE.K ) THEN
SOPLA2 = SOPLA( SUB2, M, N, K, 0, NB )
ELSE
SOPLA2 = SOPLA( SUB2, M-1, M-1, M-1, 0, NB )
END IF
ELSE
SUB2 = SUBNAM( 1: 3 ) // 'GLQ'
IF( K.LT.N ) THEN
SOPLA2 = SOPLA( SUB2, M, N, K, 0, NB )
ELSE
SOPLA2 = SOPLA( SUB2, N-1, N-1, N-1, 0, NB )
END IF
END IF
*
ELSE IF( LSAMEN( 3, C3, 'MBR' ) ) THEN
*
* -MBR: VECT // SIDE // TRANS, M, N, K => OPTS, M, N, K
*
VECT = OPTS( 1: 1 )
SIDE = OPTS( 2: 2 )
IF( LSAME( SIDE, 'L' ) ) THEN
NQ = M
ISIDE = 0
ELSE
NQ = N
ISIDE = 1
END IF
IF( LSAME( VECT, 'Q' ) ) THEN
SUB2 = SUBNAM( 1: 3 ) // 'MQR'
IF( NQ.GE.K ) THEN
SOPLA2 = SOPLA( SUB2, M, N, K, ISIDE, NB )
ELSE IF( ISIDE.EQ.0 ) THEN
SOPLA2 = SOPLA( SUB2, M-1, N, NQ-1, ISIDE, NB )
ELSE
SOPLA2 = SOPLA( SUB2, M, N-1, NQ-1, ISIDE, NB )
END IF
ELSE
SUB2 = SUBNAM( 1: 3 ) // 'MLQ'
IF( NQ.GT.K ) THEN
SOPLA2 = SOPLA( SUB2, M, N, K, ISIDE, NB )
ELSE IF( ISIDE.EQ.0 ) THEN
SOPLA2 = SOPLA( SUB2, M-1, N, NQ-1, ISIDE, NB )
ELSE
SOPLA2 = SOPLA( SUB2, M, N-1, NQ-1, ISIDE, NB )
END IF
END IF
*
ELSE IF( LSAMEN( 3, C3, 'GHR' ) ) THEN
*
* -GHR: N, ILO, IHI => M, N, K
*
ILO = N
IHI = K
SUB2 = SUBNAM( 1: 3 ) // 'GQR'
SOPLA2 = SOPLA( SUB2, IHI-ILO, IHI-ILO, IHI-ILO, 0, NB )
*
ELSE IF( LSAMEN( 3, C3, 'MHR' ) ) THEN
*
* -MHR: SIDE // TRANS, M, N, ILO, IHI => OPTS, M, N, K, L
*
SIDE = OPTS( 1: 1 )
ILO = K
IHI = L
IF( LSAME( SIDE, 'L' ) ) THEN
MI = IHI - ILO
NI = N
ISIDE = -1
ELSE
MI = M
NI = IHI - ILO
ISIDE = 1
END IF
SUB2 = SUBNAM( 1: 3 ) // 'MQR'
SOPLA2 = SOPLA( SUB2, MI, NI, IHI-ILO, ISIDE, NB )
*
ELSE IF( LSAMEN( 3, C3, 'GTR' ) ) THEN
*
* -GTR: UPLO, N => OPTS, M
*
UPLO = OPTS( 1: 1 )
IF( LSAME( UPLO, 'U' ) ) THEN
SUB2 = SUBNAM( 1: 3 ) // 'GQL'
SOPLA2 = SOPLA( SUB2, M-1, M-1, M-1, 0, NB )
ELSE
SUB2 = SUBNAM( 1: 3 ) // 'GQR'
SOPLA2 = SOPLA( SUB2, M-1, M-1, M-1, 0, NB )
END IF
*
ELSE IF( LSAMEN( 3, C3, 'MTR' ) ) THEN
*
* -MTR: SIDE // UPLO // TRANS, M, N => OPTS, M, N
*
SIDE = OPTS( 1: 1 )
UPLO = OPTS( 2: 2 )
IF( LSAME( SIDE, 'L' ) ) THEN
MI = M - 1
NI = N
NQ = M
ISIDE = -1
ELSE
MI = M
NI = N - 1
NQ = N
ISIDE = 1
END IF
*
IF( LSAME( UPLO, 'U' ) ) THEN
SUB2 = SUBNAM( 1: 3 ) // 'MQL'
SOPLA2 = SOPLA( SUB2, MI, NI, NQ-1, ISIDE, NB )
ELSE
SUB2 = SUBNAM( 1: 3 ) // 'MQR'
SOPLA2 = SOPLA( SUB2, MI, NI, NQ-1, ISIDE, NB )
END IF
*
END IF
END IF
*
RETURN
*
* End of SOPLA2
*
END
INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3,
$ N4 )
*
* -- LAPACK auxiliary routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER*( * ) NAME, OPTS
INTEGER ISPEC, N1, N2, N3, N4
* ..
*
* Purpose
* =======
*
* ILAENV returns problem-dependent parameters for the local
* environment. See ISPEC for a description of the parameters.
*
* In this version, the problem-dependent parameters are contained in
* the integer array IPARMS in the common block CLAENV and the value
* with index ISPEC is copied to ILAENV. This version of ILAENV is
* to be used in conjunction with XLAENV in TESTING and TIMING.
*
* 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
* = 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 and QZ methods
* for nonsymmetric eigenvalue problems.
* = 9: maximum size of the subproblems at the bottom of the
* computation tree in the divide-and-conquer algorithm
* =10: ieee NaN arithmetic can be trusted not to trap
* =11: infinity arithmetic can be trusted not to trap
*
* Other specifications (up to 100) can be added later.
*
* NAME (input) CHARACTER*(*)
* The name of the calling subroutine.
*
* 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.
*
* (ILAENV) (output) INTEGER
* >= 0: the value of the parameter specified by ISPEC
* < 0: if ILAENV = -k, the k-th argument had an illegal value.
*
* 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 )
*
* =====================================================================
*
* .. Intrinsic Functions ..
INTRINSIC INT, MIN, REAL
* ..
* .. External Functions ..
INTEGER IEEECK
EXTERNAL IEEECK
* ..
* .. Arrays in Common ..
INTEGER IPARMS( 100 )
* ..
* .. Common blocks ..
COMMON / CLAENV / IPARMS
* ..
* .. Save statement ..
SAVE / CLAENV /
* ..
* .. Executable Statements ..
*
IF( ISPEC.GE.1 .AND. ISPEC.LE.5 ) THEN
*
* Return a value from the common block.
*
ILAENV = IPARMS( ISPEC )
*
ELSE IF( ISPEC.EQ.6 ) THEN
*
* Compute SVD crossover point.
*
ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 )
*
ELSE IF( ISPEC.GE.7 .AND. ISPEC.LE.9 ) THEN
*
* Return a value from the common block.
*
ILAENV = IPARMS( ISPEC )
*
ELSE IF( ISPEC.EQ.10 ) THEN
*
* IEEE NaN arithmetic can be trusted not to trap
*
ILAENV = 1
IF( ILAENV.EQ.1 ) THEN
ILAENV = IEEECK( 0, 0.0, 1.0 )
END IF
*
ELSE IF( ISPEC.EQ.11 ) THEN
*
* Infinity arithmetic can be trusted not to trap
*
ILAENV = 1
IF( ILAENV.EQ.1 ) THEN
ILAENV = IEEECK( 1, 0.0, 1.0 )
END IF
*
ELSE
*
* Invalid value for ISPEC
*
ILAENV = -1
END IF
*
RETURN
*
* End of ILAENV
*
END
SUBROUTINE XLAENV( ISPEC, NVALUE )
*
* -- LAPACK auxiliary routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER ISPEC, NVALUE
* ..
*
* Purpose
* =======
*
* XLAENV sets certain machine- and problem-dependent quantities
* which will later be retrieved by ILAENV.
*
* Arguments
* =========
*
* ISPEC (input) INTEGER
* Specifies the parameter to be set in the COMMON array IPARMS.
* = 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
* = 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: another crossover point, for the multishift QR and QZ
* methods for nonsymmetric eigenvalue problems.
* = 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
*
* NVALUE (input) INTEGER
* The value of the parameter specified by ISPEC.
*
* =====================================================================
*
* .. Arrays in Common ..
INTEGER IPARMS( 100 )
* ..
* .. Common blocks ..
COMMON / CLAENV / IPARMS
* ..
* .. Save statement ..
SAVE / CLAENV /
* ..
* .. Executable Statements ..
*
IF( ISPEC.GE.1 .AND. ISPEC.LE.9 ) THEN
IPARMS( ISPEC ) = NVALUE
END IF
*
RETURN
*
* End of XLAENV
*
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/seig/sneptim.in 0000644 0001750 0001750 00000001215 10616163244 023766 0 ustar osallou osallou NEP: Data file for timing Nonsymmetric Eigenvalue Problem routines
4 Number of values of N
10 20 30 40 Values of N (dimension)
4 Number of values of parameters
1 1 1 1 Values of NB (blocksize)
2 4 6 2 Values of NS (number of shifts)
12 12 12 50 Values of MAXB (multishift crossover pt)
81 81 81 81 Values of LDA (leading dimension)
0.05 Minimum time in seconds
4 Number of matrix types
1 3 4 6
SHS T T T T T T T T T T T T
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/seig/ssvdtim.in 0000644 0001750 0001750 00000001125 10616163244 024000 0 ustar osallou osallou SVD: Data file for timing Singular Value Decomposition routines
7 Number of values of M and N
10 10 20 20 20 40 40 Values of M (row dimension)
10 20 10 20 40 20 40 Values of N (column dimension)
1 Number of values of parameters
1 Values of NB (blocksize)
81 Values of LDA (leading dimension)
0.05 Minimum time in seconds
4 Number of matrix types
1 2 3 4
SBD T T T T T T T T T T T T T T T T T T
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/seig/input_files_large/ 0000755 0001750 0001750 00000000000 11734055026 025453 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/seig/input_files_large/SNEPTIM.in 0000644 0001750 0001750 00000001215 10616163244 027121 0 ustar osallou osallou NEP: Data file for timing Nonsymmetric Eigenvalue Problem routines
4 Number of values of N
50 100 200 300 Values of N (dimension)
4 Number of values of parameters
1 16 32 48 Values of NB (blocksize)
4 6 8 12 Values of NS (number of shifts)
40 40 40 40 Values of MAXB (multishift crossover pt)
301 301 301 301 Values of LDA (leading dimension)
0.0 Minimum time in seconds
4 Number of matrix types
1 3 4 6
SHS T T T T T T T T T T T T
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/seig/input_files_large/SSVDTIM.in 0000644 0001750 0001750 00000001125 10616163244 027133 0 ustar osallou osallou SVD: Data file for timing Singular Value Decomposition routines
7 Number of values of M and N
50 50 100 100 100 200 200 Values of M (row dimension)
50 100 50 100 200 100 200 Values of N (column dimension)
1 Number of values of parameters
1 Values of NB (blocksize)
201 Values of LDA (leading dimension)
0.0 Minimum time in seconds
4 Number of matrix types
1 2 3 4
SBD T T T T T T T T T T T T T T T T T T
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/seig/input_files_large/SSEPTIM.in 0000644 0001750 0001750 00000001015 10616163244 027124 0 ustar osallou osallou SEP: Data file for timing Symmetric Eigenvalue Problem routines
5 Number of values of N
50 100 200 300 400 Values of N (dimension)
5 Number of values of parameters
1 16 32 48 64 Values of NB (blocksize)
401 401 401 401 401 Values of LDA (leading dimension)
0.0 Minimum time in seconds
4 Number of matrix types
SST T T T T T T T T T T T T T T T T T T T T T T T
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/seig/input_files_large/SGEPTIM.in 0000644 0001750 0001750 00000001424 10616163244 027114 0 ustar osallou osallou GEP: Data file for timing Generalized Nonsymmetric Eigenvalue Problem
4 Number of values of N
50 100 150 200 Values of N (dimension)
4 Number of parameter values
10 10 10 10 Values of NB (blocksize)
2 2 4 4 Values of NS (no. of shifts)
200 2 4 4 Values of MAXB (multishift crossover pt)
200 200 200 10 Values of MINNB (minimum blocksize)
200 200 200 10 Values of MINBLK (minimum blocksize)
201 201 201 201 Values of LDA (leading dimension)
0.0 Minimum time in seconds
5 Number of matrix types
SHG T T T T T T T T T T T T T T T T T T
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/slin/ 0000755 0001750 0001750 00000000000 11734055026 021776 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/slin/linsrc/ 0000755 0001750 0001750 00000000000 11734055026 023270 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/slin/linsrc/Makefile 0000644 0001750 0001750 00000000766 10616163245 024742 0 ustar osallou osallou .SUFFIXES: .f .java
ROOT=../../../..
include $(ROOT)/make.def
SBLAS=$(ROOT)/$(SBLAS_IDX)
SLAPACK=$(ROOT)/$(SLAPACK_IDX)
F2JFLAGS=-c .:$(ROOT)/$(SBLAS_OBJ):$(ROOT)/$(ERR_OBJ):$(ROOT)/$(SLAPACK_OBJ) -p $(SLINSRC_PACKAGE) -o $(OUTDIR)
tester: $(SBLAS) $(SLAPACK) $(OUTDIR)/Slinsrc.f2j
$(OUTDIR)/Slinsrc.f2j: slinsrc.f
$(F2J) $(F2JFLAGS) $< > /dev/null
$(SBLAS):
cd $(ROOT)/$(SBLAS_DIR); $(MAKE)
$(SLAPACK):
cd $(ROOT)/$(SLAPACK_DIR); $(MAKE)
clean:
/bin/rm -rf *.java *.class *.f2j $(OUTDIR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/slin/linsrc/slinsrc.f 0000644 0001750 0001750 00000546273 10616163245 025136 0 ustar osallou osallou SUBROUTINE SGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND,
$ RANK, WORK, LWORK, IWORK, INFO )
*
* -- LAPACK driver routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
REAL RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL A( LDA, * ), B( LDB, * ), S( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGELSD computes the minimum-norm solution to a real linear least
* squares problem:
* minimize 2-norm(| b - A*x |)
* using the singular value decomposition (SVD) of A. A is an M-by-N
* matrix which may be rank-deficient.
*
* Several right hand side vectors b and solution vectors x can be
* handled in a single call; they are stored as the columns of the
* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
* matrix X.
*
* The problem is solved in three steps:
* (1) Reduce the coefficient matrix A to bidiagonal form with
* Householder transformations, reducing the original problem
* into a "bidiagonal least squares problem" (BLS)
* (2) Solve the BLS using a divide and conquer approach.
* (3) Apply back all the Householder tranformations to solve
* the original least squares problem.
*
* The effective rank of A is determined by treating as zero those
* singular values which are less than RCOND times the largest singular
* value.
*
* The divide and conquer algorithm makes very mild assumptions about
* floating point arithmetic. It will work on machines with a guard
* digit in add/subtract, or on those binary machines without guard
* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
* Cray-2. It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of A. M >= 0.
*
* N (input) INTEGER
* The number of columns of A. N >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrices B and X. NRHS >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, A has been destroyed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the M-by-NRHS right hand side matrix B.
* On exit, B is overwritten by the N-by-NRHS solution
* matrix X. If m >= n and RANK = n, the residual
* sum-of-squares for the solution in the i-th column is given
* by the sum of squares of elements n+1:m in that column.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,max(M,N)).
*
* S (output) REAL array, dimension (min(M,N))
* The singular values of A in decreasing order.
* The condition number of A in the 2-norm = S(1)/S(min(m,n)).
*
* RCOND (input) REAL
* RCOND is used to determine the effective rank of A.
* Singular values S(i) <= RCOND*S(1) are treated as zero.
* If RCOND < 0, machine precision is used instead.
*
* RANK (output) INTEGER
* The effective rank of A, i.e., the number of singular values
* which are greater than RCOND*S(1).
*
* WORK (workspace/output) REAL array, dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK. LWORK must be at least 1.
* The exact minimum amount of workspace needed depends on M,
* N and NRHS. As long as LWORK is at least
* 12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2,
* if M is greater than or equal to N or
* 12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2,
* if M is less than N, the code will execute correctly.
* SMLSIZ is returned by ILAENV and is equal to the maximum
* size of the subproblems at the bottom of the computation
* tree (usually about 25), and
* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )
* For good performance, LWORK should generally be larger.
*
* 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.
*
* IWORK (workspace) INTEGER array, dimension (LIWORK)
* LIWORK >= 3 * MINMN * NLVL + 11 * MINMN,
* where MINMN = MIN( M,N ).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: the algorithm for computing the SVD failed to converge;
* if INFO = i, i off-diagonal elements of an intermediate
* bidiagonal form did not converge to zero.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Ren-Cang Li, Computer Science Division, University of
* California at Berkeley, USA
* Osni Marques, LBNL/NERSC, USA
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER IASCL, IBSCL, IE, IL, ITAU, ITAUP, ITAUQ,
$ LDWORK, MAXMN, MAXWRK, MINMN, MINWRK, MM,
$ MNTHR, NLVL, NWORK, SMLSIZ, WLALSD
REAL ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM
* ..
* .. External Subroutines ..
EXTERNAL SGEBRD, SGELQF, SGEQRF, SLABAD, SLACPY, SLALSD,
$ SLASCL, SLASET, SORMBR, SORMLQ, SORMQR, XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
REAL SLAMCH, SLANGE
EXTERNAL SLAMCH, SLANGE, ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL, INT, LOG, MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments.
*
INFO = 0
MINMN = MIN( M, N )
MAXMN = MAX( M, N )
MNTHR = ILAENV( 6, 'SGELSD', ' ', M, N, NRHS, -1 )
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) 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, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN
INFO = -7
END IF
*
SMLSIZ = ILAENV( 9, 'SGELSD', ' ', 0, 0, 0, 0 )
*
* Compute workspace.
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.)
*
MINWRK = 1
MINMN = MAX( 1, MINMN )
NLVL = MAX( INT( LOG( REAL( MINMN ) / REAL( SMLSIZ+1 ) ) /
$ LOG( TWO ) ) + 1, 0 )
*
IF( INFO.EQ.0 ) THEN
MAXWRK = 0
MM = M
IF( M.GE.N .AND. M.GE.MNTHR ) THEN
*
* Path 1a - overdetermined, with many more rows than columns.
*
MM = N
MAXWRK = MAX( MAXWRK, N+N*ILAENV( 1, 'SGEQRF', ' ', M, N,
$ -1, -1 ) )
MAXWRK = MAX( MAXWRK, N+NRHS*
$ ILAENV( 1, 'SORMQR', 'LT', M, NRHS, N, -1 ) )
END IF
IF( M.GE.N ) THEN
*
* Path 1 - overdetermined or exactly determined.
*
MAXWRK = MAX( MAXWRK, 3*N+( MM+N )*
$ ILAENV( 1, 'SGEBRD', ' ', MM, N, -1, -1 ) )
MAXWRK = MAX( MAXWRK, 3*N+NRHS*
$ ILAENV( 1, 'SORMBR', 'QLT', MM, NRHS, N, -1 ) )
MAXWRK = MAX( MAXWRK, 3*N+( N-1 )*
$ ILAENV( 1, 'SORMBR', 'PLN', N, NRHS, N, -1 ) )
WLALSD = 9*N+2*N*SMLSIZ+8*N*NLVL+N*NRHS+(SMLSIZ+1)**2
MAXWRK = MAX( MAXWRK, 3*N+WLALSD )
MINWRK = MAX( 3*N+MM, 3*N+NRHS, 3*N+WLALSD )
END IF
IF( N.GT.M ) THEN
WLALSD = 9*M+2*M*SMLSIZ+8*M*NLVL+M*NRHS+(SMLSIZ+1)**2
IF( N.GE.MNTHR ) THEN
*
* Path 2a - underdetermined, with many more columns
* than rows.
*
MAXWRK = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
MAXWRK = MAX( MAXWRK, M*M+4*M+2*M*
$ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
MAXWRK = MAX( MAXWRK, M*M+4*M+NRHS*
$ ILAENV( 1, 'SORMBR', 'QLT', M, NRHS, M, -1 ) )
MAXWRK = MAX( MAXWRK, M*M+4*M+( M-1 )*
$ ILAENV( 1, 'SORMBR', 'PLN', M, NRHS, M, -1 ) )
IF( NRHS.GT.1 ) THEN
MAXWRK = MAX( MAXWRK, M*M+M+M*NRHS )
ELSE
MAXWRK = MAX( MAXWRK, M*M+2*M )
END IF
MAXWRK = MAX( MAXWRK, M+NRHS*
$ ILAENV( 1, 'SORMLQ', 'LT', N, NRHS, M, -1 ) )
MAXWRK = MAX( MAXWRK, M*M+4*M+WLALSD )
ELSE
*
* Path 2 - remaining underdetermined cases.
*
MAXWRK = 3*M + ( N+M )*ILAENV( 1, 'SGEBRD', ' ', M, N,
$ -1, -1 )
MAXWRK = MAX( MAXWRK, 3*M+NRHS*
$ ILAENV( 1, 'SORMBR', 'QLT', M, NRHS, N, -1 ) )
MAXWRK = MAX( MAXWRK, 3*M+M*
$ ILAENV( 1, 'SORMBR', 'PLN', N, NRHS, M, -1 ) )
MAXWRK = MAX( MAXWRK, 3*M+WLALSD )
END IF
MINWRK = MAX( 3*M+NRHS, 3*M+M, 3*M+WLALSD )
END IF
MINWRK = MIN( MINWRK, MAXWRK )
WORK( 1 ) = MAXWRK
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGELSD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
GO TO 10
END IF
*
* Quick return if possible.
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
RANK = 0
RETURN
END IF
*
* Get machine parameters.
*
EPS = SLAMCH( 'P' )
SFMIN = SLAMCH( 'S' )
SMLNUM = SFMIN / EPS
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
*
* Scale A if max entry outside range [SMLNUM,BIGNUM].
*
ANRM = SLANGE( 'M', M, N, A, LDA, WORK )
IASCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM.
*
CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
IASCL = 1
ELSE IF( ANRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM.
*
CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
IASCL = 2
ELSE IF( ANRM.EQ.ZERO ) THEN
*
* Matrix all zero. Return zero solution.
*
CALL SLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
CALL SLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 )
RANK = 0
GO TO 10
END IF
*
* Scale B if max entry outside range [SMLNUM,BIGNUM].
*
BNRM = SLANGE( 'M', M, NRHS, B, LDB, WORK )
IBSCL = 0
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM.
*
CALL SLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
IBSCL = 1
ELSE IF( BNRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM.
*
CALL SLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
IBSCL = 2
END IF
*
* If M < N make sure certain entries of B are zero.
*
IF( M.LT.N )
$ CALL SLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB )
*
* Overdetermined case.
*
IF( M.GE.N ) THEN
*
* Path 1 - overdetermined or exactly determined.
*
MM = M
IF( M.GE.MNTHR ) THEN
*
* Path 1a - overdetermined, with many more rows than columns.
*
MM = N
ITAU = 1
NWORK = ITAU + N
*
* Compute A=Q*R.
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, INFO )
*
* Multiply B by transpose(Q).
* (Workspace: need N+NRHS, prefer N+NRHS*NB)
*
CALL SORMQR( 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAU ), B,
$ LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
* Zero out below R.
*
IF( N.GT.1 ) THEN
CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
END IF
END IF
*
IE = 1
ITAUQ = IE + N
ITAUP = ITAUQ + N
NWORK = ITAUP + N
*
* Bidiagonalize R in A.
* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB)
*
CALL SGEBRD( MM, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ INFO )
*
* Multiply B by transpose of left bidiagonalizing vectors of R.
* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB)
*
CALL SORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, WORK( ITAUQ ),
$ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
* Solve the bidiagonal least squares problem.
*
CALL SLALSD( 'U', SMLSIZ, N, NRHS, S, WORK( IE ), B, LDB,
$ RCOND, RANK, WORK( NWORK ), IWORK, INFO )
IF( INFO.NE.0 ) THEN
GO TO 10
END IF
*
* Multiply B by right bidiagonalizing vectors of R.
*
CALL SORMBR( 'P', 'L', 'N', N, NRHS, N, A, LDA, WORK( ITAUP ),
$ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+
$ MAX( M, 2*M-4, NRHS, N-3*M ) ) THEN
*
* Path 2a - underdetermined, with many more columns than rows
* and sufficient workspace for an efficient algorithm.
*
LDWORK = M
IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ),
$ M*LDA+M+M*NRHS ) )LDWORK = LDA
ITAU = 1
NWORK = M + 1
*
* Compute A=L*Q.
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, INFO )
IL = NWORK
*
* Copy L to WORK(IL), zeroing out above its diagonal.
*
CALL SLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK )
CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( IL+LDWORK ),
$ LDWORK )
IE = IL + LDWORK*M
ITAUQ = IE + M
ITAUP = ITAUQ + M
NWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IL).
* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB)
*
CALL SGEBRD( M, M, WORK( IL ), LDWORK, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
$ LWORK-NWORK+1, INFO )
*
* Multiply B by transpose of left bidiagonalizing vectors of L.
* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB)
*
CALL SORMBR( 'Q', 'L', 'T', M, NRHS, M, WORK( IL ), LDWORK,
$ WORK( ITAUQ ), B, LDB, WORK( NWORK ),
$ LWORK-NWORK+1, INFO )
*
* Solve the bidiagonal least squares problem.
*
CALL SLALSD( 'U', SMLSIZ, M, NRHS, S, WORK( IE ), B, LDB,
$ RCOND, RANK, WORK( NWORK ), IWORK, INFO )
IF( INFO.NE.0 ) THEN
GO TO 10
END IF
*
* Multiply B by right bidiagonalizing vectors of L.
*
CALL SORMBR( 'P', 'L', 'N', M, NRHS, M, WORK( IL ), LDWORK,
$ WORK( ITAUP ), B, LDB, WORK( NWORK ),
$ LWORK-NWORK+1, INFO )
*
* Zero out below first M rows of B.
*
CALL SLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB )
NWORK = ITAU + M
*
* Multiply transpose(Q) by B.
* (Workspace: need M+NRHS, prefer M+NRHS*NB)
*
CALL SORMLQ( 'L', 'T', N, NRHS, M, A, LDA, WORK( ITAU ), B,
$ LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
ELSE
*
* Path 2 - remaining underdetermined cases.
*
IE = 1
ITAUQ = IE + M
ITAUP = ITAUQ + M
NWORK = ITAUP + M
*
* Bidiagonalize A.
* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
*
CALL SGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ INFO )
*
* Multiply B by transpose of left bidiagonalizing vectors.
* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB)
*
CALL SORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAUQ ),
$ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
* Solve the bidiagonal least squares problem.
*
CALL SLALSD( 'L', SMLSIZ, M, NRHS, S, WORK( IE ), B, LDB,
$ RCOND, RANK, WORK( NWORK ), IWORK, INFO )
IF( INFO.NE.0 ) THEN
GO TO 10
END IF
*
* Multiply B by right bidiagonalizing vectors of A.
*
CALL SORMBR( 'P', 'L', 'N', N, NRHS, M, A, LDA, WORK( ITAUP ),
$ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
END IF
*
* Undo scaling.
*
IF( IASCL.EQ.1 ) THEN
CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
$ INFO )
ELSE IF( IASCL.EQ.2 ) THEN
CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
$ INFO )
END IF
IF( IBSCL.EQ.1 ) THEN
CALL SLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
ELSE IF( IBSCL.EQ.2 ) THEN
CALL SLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
END IF
*
10 CONTINUE
WORK( 1 ) = MAXWRK
RETURN
*
* End of SGELSD
*
END
SUBROUTINE SGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK,
$ INFO )
*
* -- LAPACK driver routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), WORK( * )
* ..
* Common block to return operation count.
* .. Common blocks ..
COMMON / LSTIME / OPCNT, TIMNG
* ..
* .. Arrays in Common ..
REAL OPCNT( 6 ), TIMNG( 6 )
* ..
*
* Purpose
* =======
*
* SGELS solves overdetermined or underdetermined real linear systems
* involving an M-by-N matrix A, or its transpose, using a QR or LQ
* factorization of A. It is assumed that A has full rank.
*
* The following options are provided:
*
* 1. If TRANS = 'N' and m >= n: find the least squares solution of
* an overdetermined system, i.e., solve the least squares problem
* minimize || B - A*X ||.
*
* 2. If TRANS = 'N' and m < n: find the minimum norm solution of
* an underdetermined system A * X = B.
*
* 3. If TRANS = 'T' and m >= n: find the minimum norm solution of
* an undetermined system A**T * X = B.
*
* 4. If TRANS = 'T' and m < n: find the least squares solution of
* an overdetermined system, i.e., solve the least squares problem
* minimize || B - A**T * X ||.
*
* Several right hand side vectors b and solution vectors x can be
* handled in a single call; they are stored as the columns of the
* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
* matrix X.
*
* Arguments
* =========
*
* TRANS (input) CHARACTER
* = 'N': the linear system involves A;
* = 'T': the linear system involves A**T.
*
* 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.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of
* columns of the matrices B and X. NRHS >=0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit,
* if M >= N, A is overwritten by details of its QR
* factorization as returned by SGEQRF;
* if M < N, A is overwritten by details of its LQ
* factorization as returned by SGELQF.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the matrix B of right hand side vectors, stored
* columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS
* if TRANS = 'T'.
* On exit, B is overwritten by the solution vectors, stored
* columnwise:
* if TRANS = 'N' and m >= n, rows 1 to n of B contain the least
* squares solution vectors; the residual sum of squares for the
* solution in each column is given by the sum of squares of
* elements N+1 to M in that column;
* if TRANS = 'N' and m < n, rows 1 to N of B contain the
* minimum norm solution vectors;
* if TRANS = 'T' and m >= n, rows 1 to M of B contain the
* minimum norm solution vectors;
* if TRANS = 'T' and m < n, rows 1 to M of B contain the
* least squares solution vectors; the residual sum of squares
* for the solution in each column is given by the sum of
* squares of elements M+1 to N in that column.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= MAX(1,M,N).
*
* WORK (workspace/output) REAL array, dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* LWORK >= max( 1, MN + max( MN, NRHS ) ).
* For optimal performance,
* LWORK >= max( 1, MN + max( MN, NRHS )*NB ).
* where MN = min(M,N) and NB is the optimum block size.
*
* 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 ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, TPSD
INTEGER BROW, GELQF, GELS, GEQRF, I, IASCL, IBSCL, J,
$ MN, NB, ORMLQ, ORMQR, SCLLEN, TRSM, WSIZE
REAL ANRM, BIGNUM, BNRM, SMLNUM, T1, T2
* ..
* .. Local Arrays ..
REAL RWORK( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
REAL SECOND, SLAMCH, SLANGE, SOPBL3,
$ SOPLA
EXTERNAL SECOND, SLAMCH, SLANGE, SOPBL3,
$ SOPLA, ILAENV, LSAME
* ..
* .. External Subroutines ..
EXTERNAL SGELQF, SGEQRF, SLABAD, SLASCL, SLASET, SORMLQ,
$ SORMQR, STRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL, MAX, MIN
* ..
* .. Data statements ..
DATA GELQF / 2 /, GELS / 1 /, GEQRF / 2 /,
$ ORMLQ / 3 /, ORMQR / 3 /, TRSM / 4 /
* ..
* .. Executable Statements ..
*
* Test the input arguments.
*
INFO = 0
MN = MIN( M, N )
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.( LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'T' ) ) ) THEN
INFO = -1
ELSE IF( M.LT.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -6
ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
INFO = -8
ELSE IF( LWORK.LT.MAX( 1, MN + MAX( MN, NRHS ) ) .AND.
$ .NOT.LQUERY ) THEN
INFO = -10
END IF
*
* Figure out optimal block size
*
IF( INFO.EQ.0 .OR. INFO.EQ.-10 ) THEN
*
TPSD = .TRUE.
IF( LSAME( TRANS, 'N' ) )
$ TPSD = .FALSE.
*
IF( M.GE.N ) THEN
NB = ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
IF( TPSD ) THEN
NB = MAX( NB, ILAENV( 1, 'SORMQR', 'LN', M, NRHS, N,
$ -1 ) )
ELSE
NB = MAX( NB, ILAENV( 1, 'SORMQR', 'LT', M, NRHS, N,
$ -1 ) )
END IF
ELSE
NB = ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
IF( TPSD ) THEN
NB = MAX( NB, ILAENV( 1, 'SORMLQ', 'LT', N, NRHS, M,
$ -1 ) )
ELSE
NB = MAX( NB, ILAENV( 1, 'SORMLQ', 'LN', N, NRHS, M,
$ -1 ) )
END IF
END IF
*
WSIZE = MAX( 1, MN + MAX( MN, NRHS )*NB )
WORK( 1 ) = REAL( WSIZE )
*
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGELS ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( MIN( M, N, NRHS ).EQ.0 ) THEN
CALL SLASET( 'Full', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
RETURN
END IF
*
* Get machine parameters
*
OPCNT( GELS ) = OPCNT( GELS ) + REAL( 2 )
SMLNUM = SLAMCH( 'S' ) / SLAMCH( 'P' )
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
*
* Scale A, B if max element outside range [SMLNUM,BIGNUM]
*
ANRM = SLANGE( 'M', M, N, A, LDA, RWORK )
IASCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
OPCNT( GELS ) = OPCNT( GELS ) + REAL( M*N )
CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
IASCL = 1
ELSE IF( ANRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
OPCNT( GELS ) = OPCNT( GELS ) + REAL( M*N )
CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
IASCL = 2
ELSE IF( ANRM.EQ.ZERO ) THEN
*
* Matrix all zero. Return zero solution.
*
CALL SLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
GO TO 50
END IF
*
BROW = M
IF( TPSD )
$ BROW = N
BNRM = SLANGE( 'M', BROW, NRHS, B, LDB, RWORK )
IBSCL = 0
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
OPCNT( GELS ) = OPCNT( GELS ) + REAL( BROW*NRHS )
CALL SLASCL( 'G', 0, 0, BNRM, SMLNUM, BROW, NRHS, B, LDB,
$ INFO )
IBSCL = 1
ELSE IF( BNRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
OPCNT( GELS ) = OPCNT( GELS ) + REAL( BROW*NRHS )
CALL SLASCL( 'G', 0, 0, BNRM, BIGNUM, BROW, NRHS, B, LDB,
$ INFO )
IBSCL = 2
END IF
*
IF( M.GE.N ) THEN
*
* compute QR factorization of A
*
NB = ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
OPCNT( GEQRF ) = OPCNT( GEQRF ) +
$ SOPLA( 'SGEQRF', M, N, 0, 0, NB )
T1 = SECOND( )
CALL SGEQRF( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ), LWORK-MN,
$ INFO )
T2 = SECOND( )
TIMNG( GEQRF ) = TIMNG( GEQRF ) + ( T2-T1 )
*
* workspace at least N, optimally N*NB
*
IF( .NOT.TPSD ) THEN
*
* Least-Squares Problem min || A * X - B ||
*
* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS)
*
NB = ILAENV( 1, 'SORMQR', 'LT', M, NRHS, N, -1 )
OPCNT( ORMQR ) = OPCNT( ORMQR ) +
$ SOPLA( 'SORMQR', M, NRHS, N, 0, NB )
T1 = SECOND( )
CALL SORMQR( 'Left', 'Transpose', M, NRHS, N, A, LDA,
$ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
$ INFO )
T2 = SECOND( )
TIMNG( ORMQR ) = TIMNG( ORMQR ) + ( T2-T1 )
*
* workspace at least NRHS, optimally NRHS*NB
*
* B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS)
*
OPCNT( TRSM ) = OPCNT( TRSM ) +
$ SOPBL3( 'STRSM ', N, NRHS, 0 )
T1 = SECOND( )
CALL STRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N,
$ NRHS, ONE, A, LDA, B, LDB )
T2 = SECOND( )
TIMNG( TRSM ) = TIMNG( TRSM ) + ( T2-T1 )
*
SCLLEN = N
*
ELSE
*
* Overdetermined system of equations A' * X = B
*
* B(1:N,1:NRHS) := inv(R') * B(1:N,1:NRHS)
*
OPCNT( TRSM ) = OPCNT( TRSM ) +
$ SOPBL3( 'STRSM ', N, NRHS, 0 )
T1 = SECOND( )
CALL STRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N,
$ NRHS, ONE, A, LDA, B, LDB )
T2 = SECOND( )
TIMNG( TRSM ) = TIMNG( TRSM ) + ( T2-T1 )
*
* B(N+1:M,1:NRHS) = ZERO
*
DO 20 J = 1, NRHS
DO 10 I = N + 1, M
B( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
*
* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS)
*
NB = ILAENV( 1, 'SORMQR', 'LN', M, NRHS, N, -1 )
OPCNT( ORMQR ) = OPCNT( ORMQR ) +
$ SOPLA( 'SORMQR', M, NRHS, N, 0, NB )
T1 = SECOND( )
CALL SORMQR( 'Left', 'No transpose', M, NRHS, N, A, LDA,
$ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
$ INFO )
T2 = SECOND( )
TIMNG( ORMQR ) = TIMNG( ORMQR ) + ( T2-T1 )
*
* workspace at least NRHS, optimally NRHS*NB
*
SCLLEN = M
*
END IF
*
ELSE
*
* Compute LQ factorization of A
*
NB = ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
OPCNT( GELQF ) = OPCNT( GELQF ) +
$ SOPLA( 'SGELQF', M, N, 0, 0, NB )
T1 = SECOND( )
CALL SGELQF( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ), LWORK-MN,
$ INFO )
T2 = SECOND( )
TIMNG( GELQF ) = TIMNG( GELQF ) + ( T2-T1 )
*
* workspace at least M, optimally M*NB.
*
IF( .NOT.TPSD ) THEN
*
* underdetermined system of equations A * X = B
*
* B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS)
*
OPCNT( TRSM ) = OPCNT( TRSM ) +
$ SOPBL3( 'STRSM ', M, NRHS, 0 )
T1 = SECOND( )
CALL STRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', M,
$ NRHS, ONE, A, LDA, B, LDB )
T2 = SECOND( )
TIMNG( TRSM ) = TIMNG( TRSM ) + ( T2-T1 )
*
* B(M+1:N,1:NRHS) = 0
*
DO 40 J = 1, NRHS
DO 30 I = M + 1, N
B( I, J ) = ZERO
30 CONTINUE
40 CONTINUE
*
* B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS)
*
NB = ILAENV( 1, 'SORMLQ', 'LT', N, NRHS, M, -1 )
OPCNT( ORMLQ ) = OPCNT( ORMLQ ) +
$ SOPLA( 'SORMLQ', N, NRHS, M, 0, NB )
T1 = SECOND( )
CALL SORMLQ( 'Left', 'Transpose', N, NRHS, M, A, LDA,
$ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
$ INFO )
T2 = SECOND( )
TIMNG( ORMLQ ) = TIMNG( ORMLQ ) + ( T2-T1 )
*
* workspace at least NRHS, optimally NRHS*NB
*
SCLLEN = N
*
ELSE
*
* overdetermined system min || A' * X - B ||
*
* B(1:N,1:NRHS) := Q * B(1:N,1:NRHS)
*
NB = ILAENV( 1, 'SORMLQ', 'LN', N, NRHS, M, -1 )
OPCNT( ORMLQ ) = OPCNT( ORMLQ ) +
$ SOPLA( 'SORMLQ', N, NRHS, M, 0, NB )
T1 = SECOND( )
CALL SORMLQ( 'Left', 'No transpose', N, NRHS, M, A, LDA,
$ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
$ INFO )
T2 = SECOND( )
TIMNG( ORMLQ ) = TIMNG( ORMLQ ) + ( T2-T1 )
*
* workspace at least NRHS, optimally NRHS*NB
*
* B(1:M,1:NRHS) := inv(L') * B(1:M,1:NRHS)
*
OPCNT( TRSM ) = OPCNT( TRSM ) +
$ SOPBL3( 'STRSM ', M, NRHS, 0 )
T1 = SECOND( )
CALL STRSM( 'Left', 'Lower', 'Transpose', 'Non-unit', M,
$ NRHS, ONE, A, LDA, B, LDB )
T2 = SECOND( )
TIMNG( TRSM ) = TIMNG( TRSM ) + ( T2-T1 )
*
SCLLEN = M
*
END IF
*
END IF
*
* Undo scaling
*
IF( IASCL.EQ.1 ) THEN
OPCNT( GELS ) = OPCNT( GELS ) + REAL( SCLLEN*NRHS )
CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, SCLLEN, NRHS, B, LDB,
$ INFO )
ELSE IF( IASCL.EQ.2 ) THEN
OPCNT( GELS ) = OPCNT( GELS ) + REAL( SCLLEN*NRHS )
CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, SCLLEN, NRHS, B, LDB,
$ INFO )
END IF
IF( IBSCL.EQ.1 ) THEN
OPCNT( GELS ) = OPCNT( GELS ) + REAL( SCLLEN*NRHS )
CALL SLASCL( 'G', 0, 0, SMLNUM, BNRM, SCLLEN, NRHS, B, LDB,
$ INFO )
ELSE IF( IBSCL.EQ.2 ) THEN
OPCNT( GELS ) = OPCNT( GELS ) + REAL( SCLLEN*NRHS )
CALL SLASCL( 'G', 0, 0, BIGNUM, BNRM, SCLLEN, NRHS, B, LDB,
$ INFO )
END IF
*
50 CONTINUE
WORK( 1 ) = REAL( WSIZE )
*
RETURN
*
* End of SGELS
*
END
SUBROUTINE SGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK,
$ WORK, LWORK, INFO )
*
* -- LAPACK driver routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
REAL RCOND
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), S( * ), WORK( * )
* ..
* Common blocks to return operation counts and timings
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
COMMON / LSTIME / OPCNT, TIMNG
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
* .. Arrays in Common ..
REAL OPCNT( 6 ), TIMNG( 6 )
* ..
*
* Purpose
* =======
*
* SGELSS computes the minimum norm solution to a real linear least
* squares problem:
*
* Minimize 2-norm(| b - A*x |).
*
* using the singular value decomposition (SVD) of A. A is an M-by-N
* matrix which may be rank-deficient.
*
* Several right hand side vectors b and solution vectors x can be
* handled in a single call; they are stored as the columns of the
* M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix
* X.
*
* The effective rank of A is determined by treating as zero those
* singular values which are less than RCOND times the largest singular
* value.
*
* 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.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrices B and X. NRHS >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, the first min(m,n) rows of A are overwritten with
* its right singular vectors, stored rowwise.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the M-by-NRHS right hand side matrix B.
* On exit, B is overwritten by the N-by-NRHS solution
* matrix X. If m >= n and RANK = n, the residual
* sum-of-squares for the solution in the i-th column is given
* by the sum of squares of elements n+1:m in that column.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,max(M,N)).
*
* S (output) REAL array, dimension (min(M,N))
* The singular values of A in decreasing order.
* The condition number of A in the 2-norm = S(1)/S(min(m,n)).
*
* RCOND (input) REAL
* RCOND is used to determine the effective rank of A.
* Singular values S(i) <= RCOND*S(1) are treated as zero.
* If RCOND < 0, machine precision is used instead.
*
* RANK (output) INTEGER
* The effective rank of A, i.e., the number of singular values
* which are greater than RCOND*S(1).
*
* WORK (workspace/output) REAL array, dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK. LWORK >= 1, and also:
* LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS )
* For good performance, LWORK should generally be larger.
*
* 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.
* > 0: the algorithm for computing the SVD failed to converge;
* if INFO = i, i off-diagonal elements of an intermediate
* bidiagonal form did not converge to zero.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER BDSPAC, BDSQR, BL, CHUNK, GEBRD, GELQF, GELSS,
$ GEMM, GEMV, GEQRF, I, IASCL, IBSCL, IE, IL,
$ ITAU, ITAUP, ITAUQ, IWORK, LDWORK, MAXMN,
$ MAXWRK, MINMN, MINWRK, MM, MNTHR, NB,
$ ORGBR, ORMBR, ORMLQ, ORMQR
REAL ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM, THR,
$ T1, T2
* ..
* .. Local Arrays ..
REAL VDUM( 1 )
* ..
* .. External Subroutines ..
EXTERNAL SBDSQR, SCOPY, SGEBRD, SGELQF, SGEMM, SGEMV,
$ SGEQRF, SLABAD, SLACPY, SLASCL, SLASET, SORGBR,
$ SORMBR, SORMLQ, SORMQR, SRSCL, XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
REAL SECOND, SLAMCH, SLANGE, SOPBL2,
$ SOPBL3, SOPLA, SOPLA2
EXTERNAL SECOND, SLAMCH, SLANGE, SOPBL2,
$ SOPBL3, SOPLA, SOPLA2, ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL, MAX, MIN
* ..
* .. Data statements ..
DATA BDSQR / 5 /, GEBRD / 3 /, GELQF / 2 /,
$ GELSS / 1 /, GEMM / 6 /, GEMV / 6 /,
$ GEQRF / 2 /, ORGBR / 4 /, ORMBR / 4 /,
$ ORMLQ / 6 /, ORMQR / 2 /
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
MINMN = MIN( M, N )
MAXMN = MAX( M, N )
MNTHR = ILAENV( 6, 'SGELSS', ' ', M, N, NRHS, -1 )
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) 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, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN
INFO = -7
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.)
*
MINWRK = 1
IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN
MAXWRK = 0
MM = M
IF( M.GE.N .AND. M.GE.MNTHR ) THEN
*
* Path 1a - overdetermined, with many more rows than columns
*
MM = N
MAXWRK = MAX( MAXWRK, N+N*ILAENV( 1, 'SGEQRF', ' ', M, N,
$ -1, -1 ) )
MAXWRK = MAX( MAXWRK, N+NRHS*
$ ILAENV( 1, 'SORMQR', 'LT', M, NRHS, N, -1 ) )
END IF
IF( M.GE.N ) THEN
*
* Path 1 - overdetermined or exactly determined
*
* Compute workspace needed for SBDSQR
*
BDSPAC = MAX( 1, 5*N )
MAXWRK = MAX( MAXWRK, 3*N+( MM+N )*
$ ILAENV( 1, 'SGEBRD', ' ', MM, N, -1, -1 ) )
MAXWRK = MAX( MAXWRK, 3*N+NRHS*
$ ILAENV( 1, 'SORMBR', 'QLT', MM, NRHS, N, -1 ) )
MAXWRK = MAX( MAXWRK, 3*N+( N-1 )*
$ ILAENV( 1, 'SORGBR', 'P', N, N, N, -1 ) )
MAXWRK = MAX( MAXWRK, BDSPAC )
MAXWRK = MAX( MAXWRK, N*NRHS )
MINWRK = MAX( 3*N+MM, 3*N+NRHS, BDSPAC )
MAXWRK = MAX( MINWRK, MAXWRK )
END IF
IF( N.GT.M ) THEN
*
* Compute workspace needed for SBDSQR
*
BDSPAC = MAX( 1, 5*M )
MINWRK = MAX( 3*M+NRHS, 3*M+N, BDSPAC )
IF( N.GE.MNTHR ) THEN
*
* Path 2a - underdetermined, with many more columns
* than rows
*
MAXWRK = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
MAXWRK = MAX( MAXWRK, M*M+4*M+2*M*
$ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
MAXWRK = MAX( MAXWRK, M*M+4*M+NRHS*
$ ILAENV( 1, 'SORMBR', 'QLT', M, NRHS, M, -1 ) )
MAXWRK = MAX( MAXWRK, M*M+4*M+( M-1 )*
$ ILAENV( 1, 'SORGBR', 'P', M, M, M, -1 ) )
MAXWRK = MAX( MAXWRK, M*M+M+BDSPAC )
IF( NRHS.GT.1 ) THEN
MAXWRK = MAX( MAXWRK, M*M+M+M*NRHS )
ELSE
MAXWRK = MAX( MAXWRK, M*M+2*M )
END IF
MAXWRK = MAX( MAXWRK, M+NRHS*
$ ILAENV( 1, 'SORMLQ', 'LT', N, NRHS, M, -1 ) )
ELSE
*
* Path 2 - underdetermined
*
MAXWRK = 3*M + ( N+M )*ILAENV( 1, 'SGEBRD', ' ', M, N,
$ -1, -1 )
MAXWRK = MAX( MAXWRK, 3*M+NRHS*
$ ILAENV( 1, 'SORMBR', 'QLT', M, NRHS, M, -1 ) )
MAXWRK = MAX( MAXWRK, 3*M+M*
$ ILAENV( 1, 'SORGBR', 'P', M, N, M, -1 ) )
MAXWRK = MAX( MAXWRK, BDSPAC )
MAXWRK = MAX( MAXWRK, N*NRHS )
END IF
END IF
MAXWRK = MAX( MINWRK, MAXWRK )
WORK( 1 ) = MAXWRK
END IF
*
MINWRK = MAX( MINWRK, 1 )
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY )
$ INFO = -12
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGELSS', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
RANK = 0
RETURN
END IF
*
* Get machine parameters
*
EPS = SLAMCH( 'P' )
SFMIN = SLAMCH( 'S' )
OPCNT( GELSS ) = OPCNT( GELSS ) + REAL( 2 )
SMLNUM = SFMIN / EPS
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = SLANGE( 'M', M, N, A, LDA, WORK )
IASCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
OPCNT( GELSS ) = OPCNT( GELSS ) + REAL( M*N )
CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
IASCL = 1
ELSE IF( ANRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
OPCNT( GELSS ) = OPCNT( GELSS ) + REAL( M*N )
CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
IASCL = 2
ELSE IF( ANRM.EQ.ZERO ) THEN
*
* Matrix all zero. Return zero solution.
*
CALL SLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
CALL SLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 )
RANK = 0
GO TO 70
END IF
*
* Scale B if max element outside range [SMLNUM,BIGNUM]
*
BNRM = SLANGE( 'M', M, NRHS, B, LDB, WORK )
IBSCL = 0
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
OPCNT( GELSS ) = OPCNT( GELSS ) + REAL( M*NRHS )
CALL SLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
IBSCL = 1
ELSE IF( BNRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
OPCNT( GELSS ) = OPCNT( GELSS ) + REAL( M*NRHS )
CALL SLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
IBSCL = 2
END IF
*
* Overdetermined case
*
IF( M.GE.N ) THEN
*
* Path 1 - overdetermined or exactly determined
*
MM = M
IF( M.GE.MNTHR ) THEN
*
* Path 1a - overdetermined, with many more rows than columns
*
MM = N
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need 2*N, prefer N+N*NB)
*
NB = ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
OPCNT( GEQRF ) = OPCNT( GEQRF ) +
$ SOPLA( 'SGEQRF', M, N, 0, 0, NB )
T1 = SECOND( )
CALL SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
$ LWORK-IWORK+1, INFO )
T2 = SECOND( )
TIMNG( GEQRF ) = TIMNG( GEQRF ) + ( T2-T1 )
*
* Multiply B by transpose(Q)
* (Workspace: need N+NRHS, prefer N+NRHS*NB)
*
NB = ILAENV( 1, 'SORMQR', 'LT', M, NRHS, N, -1 )
OPCNT( ORMQR ) = OPCNT( ORMQR ) +
$ SOPLA( 'SORMQR', M, NRHS, N, 0, NB )
T1 = SECOND( )
CALL SORMQR( 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAU ), B,
$ LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
T2 = SECOND( )
TIMNG( ORMQR ) = TIMNG( ORMQR ) + ( T2-T1 )
*
* Zero out below R
*
IF( N.GT.1 )
$ CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
END IF
*
IE = 1
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in A
* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB)
*
NB = ILAENV( 1, 'SGEBRD', ' ', MM, N, -1, -1 )
OPCNT( GEBRD ) = OPCNT( GEBRD ) +
$ SOPLA( 'SGEBRD', MM, N, 0, 0, NB )
T1 = SECOND( )
CALL SGEBRD( MM, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
$ INFO )
T2 = SECOND( )
TIMNG( GEBRD ) = TIMNG( GEBRD ) + ( T2-T1 )
*
* Multiply B by transpose of left bidiagonalizing vectors of R
* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB)
*
NB = ILAENV( 1, 'SORMBR', 'QLT', MM, NRHS, N, -1 )
OPCNT( ORMBR ) = OPCNT( ORMBR ) +
$ SOPLA2( 'SORMBR', 'QLT', MM, NRHS, N, 0, NB )
T1 = SECOND( )
CALL SORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, WORK( ITAUQ ),
$ B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
T2 = SECOND( )
TIMNG( ORMBR ) = TIMNG( ORMBR ) + ( T2-T1 )
*
* Generate right bidiagonalizing vectors of R in A
* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
*
NB = ILAENV( 1, 'SORGBR', 'P', N, N, N, -1 )
OPCNT( ORGBR ) = OPCNT( ORGBR ) +
$ SOPLA2( 'SORGBR', 'P', N, N, N, 0, NB )
T1 = SECOND( )
CALL SORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, INFO )
T2 = SECOND( )
TIMNG( ORGBR ) = TIMNG( ORGBR ) + ( T2-T1 )
IWORK = IE + N
*
* Perform bidiagonal QR iteration
* multiply B by transpose of left singular vectors
* compute right singular vectors in A
* (Workspace: need BDSPAC)
*
OPS = 0
T1 = SECOND( )
CALL SBDSQR( 'U', N, N, 0, NRHS, S, WORK( IE ), A, LDA, VDUM,
$ 1, B, LDB, WORK( IWORK ), INFO )
T2 = SECOND( )
TIMNG( BDSQR ) = TIMNG( BDSQR ) + ( T2-T1 )
OPCNT( BDSQR ) = OPCNT( BDSQR ) + OPS
IF( INFO.NE.0 )
$ GO TO 70
*
* Multiply B by reciprocals of singular values
*
OPCNT( GELSS ) = OPCNT( GELSS ) + REAL( 1 )
THR = MAX( RCOND*S( 1 ), SFMIN )
IF( RCOND.LT.ZERO ) THEN
OPCNT( GELSS ) = OPCNT( GELSS ) + REAL( 1 )
THR = MAX( EPS*S( 1 ), SFMIN )
END IF
RANK = 0
DO 10 I = 1, N
IF( S( I ).GT.THR ) THEN
OPCNT( GELSS ) = OPCNT( GELSS ) + REAL( NRHS + 3 )
CALL SRSCL( NRHS, S( I ), B( I, 1 ), LDB )
RANK = RANK + 1
ELSE
CALL SLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
END IF
10 CONTINUE
*
* Multiply B by right singular vectors
* (Workspace: need N, prefer N*NRHS)
*
IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN
OPCNT( GEMM ) = OPCNT( GEMM ) +
$ SOPBL3( 'SGEMM ', N, NRHS, N )
T1 = SECOND( )
CALL SGEMM( 'T', 'N', N, NRHS, N, ONE, A, LDA, B, LDB, ZERO,
$ WORK, LDB )
T2 = SECOND( )
TIMNG( GEMM ) = TIMNG( GEMM ) + ( T2-T1 )
CALL SLACPY( 'G', N, NRHS, WORK, LDB, B, LDB )
ELSE IF( NRHS.GT.1 ) THEN
CHUNK = LWORK / N
DO 20 I = 1, NRHS, CHUNK
BL = MIN( NRHS-I+1, CHUNK )
OPCNT( GEMM ) = OPCNT( GEMM ) +
$ SOPBL3( 'SGEMM ', N, BL, N )
T1 = SECOND( )
CALL SGEMM( 'T', 'N', N, BL, N, ONE, A, LDA, B( 1, I ),
$ LDB, ZERO, WORK, N )
T2 = SECOND( )
TIMNG( GEMM ) = TIMNG( GEMM ) + ( T2-T1 )
CALL SLACPY( 'G', N, BL, WORK, N, B( 1, I ), LDB )
20 CONTINUE
ELSE
OPCNT( GEMV ) = OPCNT( GEMV ) +
$ SOPBL2( 'SGEMV ', N, N, 0, 0 )
T1 = SECOND( )
CALL SGEMV( 'T', N, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 )
T2 = SECOND( )
TIMNG( GEMV ) = TIMNG( GEMV ) + ( T2-T1 )
CALL SCOPY( N, WORK, 1, B, 1 )
END IF
*
ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+
$ MAX( M, 2*M-4, NRHS, N-3*M ) ) THEN
*
* Path 2a - underdetermined, with many more columns than rows
* and sufficient workspace for an efficient algorithm
*
LDWORK = M
IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ),
$ M*LDA+M+M*NRHS ) )LDWORK = LDA
ITAU = 1
IWORK = M + 1
*
* Compute A=L*Q
* (Workspace: need 2*M, prefer M+M*NB)
*
NB = ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
OPCNT( GELQF ) = OPCNT( GELQF ) +
$ SOPLA( 'SGELQF', M, N, 0, 0, NB )
T1 = SECOND( )
CALL SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
$ LWORK-IWORK+1, INFO )
T2 = SECOND( )
TIMNG( GELQF ) = TIMNG( GELQF ) + ( T2-T1 )
IL = IWORK
*
* Copy L to WORK(IL), zeroing out above it
*
CALL SLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK )
CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( IL+LDWORK ),
$ LDWORK )
IE = IL + LDWORK*M
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IL)
* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB)
*
NB = ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 )
OPCNT( GEBRD ) = OPCNT( GEBRD ) +
$ SOPLA( 'SGEBRD', M, M, 0, 0, NB )
T1 = SECOND( )
CALL SGEBRD( M, M, WORK( IL ), LDWORK, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, INFO )
T2 = SECOND( )
TIMNG( GEBRD ) = TIMNG( GEBRD ) + ( T2-T1 )
*
* Multiply B by transpose of left bidiagonalizing vectors of L
* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB)
*
NB = ILAENV( 1, 'SORMBR', 'QLT', M, NRHS, M, -1 )
OPCNT( ORMBR ) = OPCNT( ORMBR ) +
$ SOPLA2( 'SORMBR', 'QLT', M, NRHS, M, 0, NB )
T1 = SECOND( )
CALL SORMBR( 'Q', 'L', 'T', M, NRHS, M, WORK( IL ), LDWORK,
$ WORK( ITAUQ ), B, LDB, WORK( IWORK ),
$ LWORK-IWORK+1, INFO )
T2 = SECOND( )
TIMNG( ORMBR ) = TIMNG( ORMBR ) + ( T2-T1 )
*
* Generate right bidiagonalizing vectors of R in WORK(IL)
* (Workspace: need M*M+5*M-1, prefer M*M+4*M+(M-1)*NB)
*
NB = ILAENV( 1, 'SORGBR', 'P', M, M, M, -1 )
OPCNT( ORGBR ) = OPCNT( ORGBR ) +
$ SOPLA2( 'SORGBR', 'P', M, M, M, 0, NB )
T1 = SECOND( )
CALL SORGBR( 'P', M, M, M, WORK( IL ), LDWORK, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, INFO )
T2 = SECOND( )
TIMNG( ORGBR ) = TIMNG( ORGBR ) + ( T2-T1 )
IWORK = IE + M
*
* Perform bidiagonal QR iteration,
* computing right singular vectors of L in WORK(IL) and
* multiplying B by transpose of left singular vectors
* (Workspace: need M*M+M+BDSPAC)
*
OPS = 0
T1 = SECOND( )
CALL SBDSQR( 'U', M, M, 0, NRHS, S, WORK( IE ), WORK( IL ),
$ LDWORK, A, LDA, B, LDB, WORK( IWORK ), INFO )
T2 = SECOND( )
TIMNG( BDSQR ) = TIMNG( BDSQR ) + ( T2-T1 )
OPCNT( BDSQR ) = OPCNT( BDSQR ) + OPS
IF( INFO.NE.0 )
$ GO TO 70
*
* Multiply B by reciprocals of singular values
*
OPCNT( GELSS ) = OPCNT( GELSS ) + REAL( 1 )
THR = MAX( RCOND*S( 1 ), SFMIN )
IF( RCOND.LT.ZERO ) THEN
OPCNT( GELSS ) = OPCNT( GELSS ) + REAL( 1 )
THR = MAX( EPS*S( 1 ), SFMIN )
END IF
RANK = 0
DO 30 I = 1, M
IF( S( I ).GT.THR ) THEN
OPCNT( GELSS ) = OPCNT( GELSS ) + REAL( NRHS + 3 )
CALL SRSCL( NRHS, S( I ), B( I, 1 ), LDB )
RANK = RANK + 1
ELSE
CALL SLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
END IF
30 CONTINUE
IWORK = IE
*
* Multiply B by right singular vectors of L in WORK(IL)
* (Workspace: need M*M+2*M, prefer M*M+M+M*NRHS)
*
IF( LWORK.GE.LDB*NRHS+IWORK-1 .AND. NRHS.GT.1 ) THEN
OPCNT( GEMM ) = OPCNT( GEMM ) +
$ SOPBL3( 'SGEMM ', M, NRHS, M )
T1 = SECOND( )
CALL SGEMM( 'T', 'N', M, NRHS, M, ONE, WORK( IL ), LDWORK,
$ B, LDB, ZERO, WORK( IWORK ), LDB )
T2 = SECOND( )
TIMNG( GEMM ) = TIMNG( GEMM ) + ( T2-T1 )
CALL SLACPY( 'G', M, NRHS, WORK( IWORK ), LDB, B, LDB )
ELSE IF( NRHS.GT.1 ) THEN
CHUNK = ( LWORK-IWORK+1 ) / M
DO 40 I = 1, NRHS, CHUNK
BL = MIN( NRHS-I+1, CHUNK )
OPCNT( GEMM ) = OPCNT( GEMM ) +
$ SOPBL3( 'SGEMM ', M, BL, M )
T1 = SECOND( )
CALL SGEMM( 'T', 'N', M, BL, M, ONE, WORK( IL ), LDWORK,
$ B( 1, I ), LDB, ZERO, WORK( IWORK ), N )
T2 = SECOND( )
TIMNG( GEMM ) = TIMNG( GEMM ) + ( T2-T1 )
CALL SLACPY( 'G', M, BL, WORK( IWORK ), N, B( 1, I ),
$ LDB )
40 CONTINUE
ELSE
OPCNT( GEMV ) = OPCNT( GEMV ) +
$ SOPBL2( 'SGEMV ', M, M, 0, 0 )
T1 = SECOND( )
CALL SGEMV( 'T', M, M, ONE, WORK( IL ), LDWORK, B( 1, 1 ),
$ 1, ZERO, WORK( IWORK ), 1 )
T2 = SECOND( )
TIMNG( GEMV ) = TIMNG( GEMV ) + ( T2-T1 )
CALL SCOPY( M, WORK( IWORK ), 1, B( 1, 1 ), 1 )
END IF
*
* Zero out below first M rows of B
*
CALL SLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB )
IWORK = ITAU + M
*
* Multiply transpose(Q) by B
* (Workspace: need M+NRHS, prefer M+NRHS*NB)
*
NB = ILAENV( 1, 'SORMLQ', 'LT', N, NRHS, M, -1 )
OPCNT( ORMLQ ) = OPCNT( ORMLQ ) +
$ SOPLA( 'SORMLQ', N, NRHS, M, 0, NB )
T1 = SECOND( )
CALL SORMLQ( 'L', 'T', N, NRHS, M, A, LDA, WORK( ITAU ), B,
$ LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
T2 = SECOND( )
TIMNG( ORMLQ ) = TIMNG( ORMLQ ) + ( T2-T1 )
*
ELSE
*
* Path 2 - remaining underdetermined cases
*
IE = 1
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize A
* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
*
NB = ILAENV( 1, 'SGEBRD', ' ', M, N, -1, -1 )
OPCNT( GEBRD ) = OPCNT( GEBRD ) +
$ SOPLA( 'SGEBRD', M, N, 0, 0, NB )
T1 = SECOND( )
CALL SGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
$ INFO )
T2 = SECOND( )
TIMNG( GEBRD ) = TIMNG( GEBRD ) + ( T2-T1 )
*
* Multiply B by transpose of left bidiagonalizing vectors
* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB)
*
NB = ILAENV( 1, 'SORMBR', 'QLT', M, NRHS, N, -1 )
OPCNT( ORMBR ) = OPCNT( ORMBR ) +
$ SOPLA2( 'SORMBR', 'QLT', M, NRHS, N, 0, NB )
T1 = SECOND( )
CALL SORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAUQ ),
$ B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
T2 = SECOND( )
TIMNG( ORMBR ) = TIMNG( ORMBR ) + ( T2-T1 )
*
* Generate right bidiagonalizing vectors in A
* (Workspace: need 4*M, prefer 3*M+M*NB)
*
NB = ILAENV( 1, 'SORGBR', 'P', M, N, M, -1 )
OPCNT( ORGBR ) = OPCNT( ORGBR ) +
$ SOPLA2( 'SORGBR', 'P', M, N, M, 0, NB )
T1 = SECOND( )
CALL SORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, INFO )
T2 = SECOND( )
TIMNG( ORGBR ) = TIMNG( ORGBR ) + ( T2-T1 )
IWORK = IE + M
*
* Perform bidiagonal QR iteration,
* computing right singular vectors of A in A and
* multiplying B by transpose of left singular vectors
* (Workspace: need BDSPAC)
*
OPS = 0
T1 = SECOND( )
CALL SBDSQR( 'L', M, N, 0, NRHS, S, WORK( IE ), A, LDA, VDUM,
$ 1, B, LDB, WORK( IWORK ), INFO )
T2 = SECOND( )
TIMNG( BDSQR ) = TIMNG( BDSQR ) + ( T2-T1 )
OPCNT( BDSQR ) = OPCNT( BDSQR ) + OPS
IF( INFO.NE.0 )
$ GO TO 70
*
* Multiply B by reciprocals of singular values
*
OPCNT( GELSS ) = OPCNT( GELSS ) + REAL( 1 )
THR = MAX( RCOND*S( 1 ), SFMIN )
IF( RCOND.LT.ZERO ) THEN
OPCNT( GELSS ) = OPCNT( GELSS ) + REAL( 1 )
THR = MAX( EPS*S( 1 ), SFMIN )
END IF
RANK = 0
DO 50 I = 1, M
IF( S( I ).GT.THR ) THEN
OPCNT( GELSS ) = OPCNT( GELSS ) + REAL( NRHS + 3 )
CALL SRSCL( NRHS, S( I ), B( I, 1 ), LDB )
RANK = RANK + 1
ELSE
CALL SLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
END IF
50 CONTINUE
*
* Multiply B by right singular vectors of A
* (Workspace: need N, prefer N*NRHS)
*
IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN
OPCNT( GEMM ) = OPCNT( GEMM ) +
$ SOPBL3( 'SGEMM ', N, NRHS, M )
T1 = SECOND( )
CALL SGEMM( 'T', 'N', N, NRHS, M, ONE, A, LDA, B, LDB, ZERO,
$ WORK, LDB )
T2 = SECOND( )
TIMNG( GEMM ) = TIMNG( GEMM ) + ( T2-T1 )
CALL SLACPY( 'F', N, NRHS, WORK, LDB, B, LDB )
ELSE IF( NRHS.GT.1 ) THEN
CHUNK = LWORK / N
DO 60 I = 1, NRHS, CHUNK
BL = MIN( NRHS-I+1, CHUNK )
OPCNT( GEMM ) = OPCNT( GEMM ) +
$ SOPBL3( 'SGEMM ', N, BL, M )
T1 = SECOND( )
CALL SGEMM( 'T', 'N', N, BL, M, ONE, A, LDA, B( 1, I ),
$ LDB, ZERO, WORK, N )
T2 = SECOND( )
TIMNG( GEMM ) = TIMNG( GEMM ) + ( T2-T1 )
CALL SLACPY( 'F', N, BL, WORK, N, B( 1, I ), LDB )
60 CONTINUE
ELSE
OPCNT( GEMV ) = OPCNT( GEMV ) +
$ SOPBL2( 'SGEMV ', M, N, 0, 0 )
T1 = SECOND( )
CALL SGEMV( 'T', M, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 )
T2 = SECOND( )
TIMNG( GEMV ) = TIMNG( GEMV ) + ( T2-T1 )
CALL SCOPY( N, WORK, 1, B, 1 )
END IF
END IF
*
* Undo scaling
*
IF( IASCL.EQ.1 ) THEN
OPCNT( GELSS ) = OPCNT( GELSS ) + REAL( N*NRHS + MINMN )
CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
$ INFO )
ELSE IF( IASCL.EQ.2 ) THEN
OPCNT( GELSS ) = OPCNT( GELSS ) + REAL( N*NRHS + MINMN )
CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
$ INFO )
END IF
IF( IBSCL.EQ.1 ) THEN
OPCNT( GELSS ) = OPCNT( GELSS ) + REAL( N*NRHS )
CALL SLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
ELSE IF( IBSCL.EQ.2 ) THEN
OPCNT( GELSS ) = OPCNT( GELSS ) + REAL( N*NRHS )
CALL SLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
END IF
*
70 CONTINUE
WORK( 1 ) = MAXWRK
RETURN
*
* End of SGELSS
*
END
SUBROUTINE SGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK,
$ WORK, INFO )
*
* -- LAPACK driver routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, M, N, NRHS, RANK
REAL RCOND
* ..
* .. Array Arguments ..
INTEGER JPVT( * )
REAL A( LDA, * ), B( LDB, * ), WORK( * )
* ..
* Common blocks to return operation counts and timings
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
COMMON / LSTIME / OPCNT, TIMNG
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
* .. Arrays in Common ..
REAL OPCNT( 6 ), TIMNG( 6 )
* ..
*
* Purpose
* =======
*
* SGELSX computes the minimum-norm solution to a real linear least
* squares problem:
* minimize || A * X - B ||
* using a complete orthogonal factorization of A. A is an M-by-N
* matrix which may be rank-deficient.
*
* Several right hand side vectors b and solution vectors x can be
* handled in a single call; they are stored as the columns of the
* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
* matrix X.
*
* The routine first computes a QR factorization with column pivoting:
* A * P = Q * [ R11 R12 ]
* [ 0 R22 ]
* with R11 defined as the largest leading submatrix whose estimated
* condition number is less than 1/RCOND. The order of R11, RANK,
* is the effective rank of A.
*
* Then, R22 is considered to be negligible, and R12 is annihilated
* by orthogonal transformations from the right, arriving at the
* complete orthogonal factorization:
* A * P = Q * [ T11 0 ] * Z
* [ 0 0 ]
* The minimum-norm solution is then
* X = P * Z' [ inv(T11)*Q1'*B ]
* [ 0 ]
* where Q1 consists of the first RANK columns of Q.
*
* 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.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of
* columns of matrices B and X. NRHS >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, A has been overwritten by details of its
* complete orthogonal factorization.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the M-by-NRHS right hand side matrix B.
* On exit, the N-by-NRHS solution matrix X.
* If m >= n and RANK = n, the residual sum-of-squares for
* the solution in the i-th column is given by the sum of
* squares of elements N+1:M in that column.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,M,N).
*
* JPVT (input/output) INTEGER array, dimension (N)
* On entry, if JPVT(i) .ne. 0, the i-th column of A is an
* initial column, otherwise it is a free column. Before
* the QR factorization of A, all initial columns are
* permuted to the leading positions; only the remaining
* free columns are moved as a result of column pivoting
* during the factorization.
* On exit, if JPVT(i) = k, then the i-th column of A*P
* was the k-th column of A.
*
* RCOND (input) REAL
* RCOND is used to determine the effective rank of A, which
* is defined as the order of the largest leading triangular
* submatrix R11 in the QR factorization with pivoting of A,
* whose estimated condition number < 1/RCOND.
*
* RANK (output) INTEGER
* The effective rank of A, i.e., the order of the submatrix
* R11. This is the same as the order of the submatrix T11
* in the complete orthogonal factorization of A.
*
* WORK (workspace) REAL array, dimension
* (max( min(M,N)+3*N, 2*min(M,N)+NRHS )),
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
INTEGER IMAX, IMIN
PARAMETER ( IMAX = 1, IMIN = 2 )
REAL ZERO, ONE, DONE, NTDONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, DONE = ZERO,
$ NTDONE = ONE )
* ..
* .. Local Scalars ..
INTEGER GELSX, GEQPF, I, IASCL, IBSCL, ISMAX, ISMIN,
$ J, K, LATZM, MN, ORM2R, TRSM, TZRQF
REAL ANRM, BIGNUM, BNRM, C1, C2, S1, S2, SMAX,
$ SMAXPR, SMIN, SMINPR, SMLNUM, T1, T2,
$ TIM1, TIM2
* ..
* .. External Functions ..
REAL SECOND, SLAMCH, SLANGE, SOPBL3,
$ SOPLA
EXTERNAL SECOND, SLAMCH, SLANGE, SOPBL3,
$ SOPLA
* ..
* .. External Subroutines ..
EXTERNAL SGEQPF, SLABAD, SLAIC1, SLASCL, SLASET, SLATZM,
$ SORM2R, STRSM, STZRQF, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL, ABS, MAX, MIN
* ..
* .. Data statements ..
DATA GELSX / 1 /, GEQPF / 2 /, LATZM / 6 /,
$ ORM2R / 4 /, TRSM / 5 /, TZRQF / 3 /
* ..
* .. Executable Statements ..
*
MN = MIN( M, N )
ISMIN = MN + 1
ISMAX = 2*MN + 1
*
* Test the input arguments.
*
INFO = 0
IF( M.LT.0 ) 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, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
INFO = -7
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGELSX', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( MIN( M, N, NRHS ).EQ.0 ) THEN
RANK = 0
RETURN
END IF
*
* Get machine parameters
*
OPCNT( GELSX ) = OPCNT( GELSX ) + REAL( 2 )
SMLNUM = SLAMCH( 'S' ) / SLAMCH( 'P' )
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
*
* Scale A, B if max elements outside range [SMLNUM,BIGNUM]
*
ANRM = SLANGE( 'M', M, N, A, LDA, WORK )
IASCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
OPCNT( GELSX ) = OPCNT( GELSX ) + REAL( M*N )
CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
IASCL = 1
ELSE IF( ANRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
OPCNT( GELSX ) = OPCNT( GELSX ) + REAL( M*N )
CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
IASCL = 2
ELSE IF( ANRM.EQ.ZERO ) THEN
*
* Matrix all zero. Return zero solution.
*
CALL SLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
RANK = 0
GO TO 100
END IF
*
BNRM = SLANGE( 'M', M, NRHS, B, LDB, WORK )
IBSCL = 0
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
OPCNT( GELSX ) = OPCNT( GELSX ) + REAL( M*NRHS )
CALL SLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
IBSCL = 1
ELSE IF( BNRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
OPCNT( GELSX ) = OPCNT( GELSX ) + REAL( M*NRHS )
CALL SLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
IBSCL = 2
END IF
*
* Compute QR factorization with column pivoting of A:
* A * P = Q * R
*
OPCNT( GEQPF ) = OPCNT( GEQPF ) +
$ SOPLA( 'SGEQPF', M, N, 0, 0, 0 )
TIM1 = SECOND( )
CALL SGEQPF( M, N, A, LDA, JPVT, WORK( 1 ), WORK( MN+1 ), INFO )
TIM2 = SECOND( )
TIMNG( GEQPF ) = TIMNG( GEQPF ) + ( TIM2-TIM1 )
*
* workspace 3*N. Details of Householder rotations stored
* in WORK(1:MN).
*
* Determine RANK using incremental condition estimation
*
WORK( ISMIN ) = ONE
WORK( ISMAX ) = ONE
SMAX = ABS( A( 1, 1 ) )
SMIN = SMAX
IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN
RANK = 0
CALL SLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
GO TO 100
ELSE
RANK = 1
END IF
*
10 CONTINUE
IF( RANK.LT.MN ) THEN
I = RANK + 1
OPS = 0
CALL SLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ),
$ A( I, I ), SMINPR, S1, C1 )
CALL SLAIC1( IMAX, RANK, WORK( ISMAX ), SMAX, A( 1, I ),
$ A( I, I ), SMAXPR, S2, C2 )
OPCNT( GELSX ) = OPCNT( GELSX ) + OPS + REAL( 1 )
*
IF( SMAXPR*RCOND.LE.SMINPR ) THEN
OPCNT( GELSX ) = OPCNT( GELSX ) + REAL( RANK*2 )
DO 20 I = 1, RANK
WORK( ISMIN+I-1 ) = S1*WORK( ISMIN+I-1 )
WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 )
20 CONTINUE
WORK( ISMIN+RANK ) = C1
WORK( ISMAX+RANK ) = C2
SMIN = SMINPR
SMAX = SMAXPR
RANK = RANK + 1
GO TO 10
END IF
END IF
*
* Logically partition R = [ R11 R12 ]
* [ 0 R22 ]
* where R11 = R(1:RANK,1:RANK)
*
* [R11,R12] = [ T11, 0 ] * Y
*
IF( RANK.LT.N ) THEN
OPCNT( TZRQF ) = OPCNT( TZRQF ) +
$ SOPLA( 'STZRQF', RANK, N, 0, 0, 0 )
TIM1 = SECOND( )
CALL STZRQF( RANK, N, A, LDA, WORK( MN+1 ), INFO )
TIM2 = SECOND( )
TIMNG( TZRQF ) = TIMNG( TZRQF ) + ( TIM2-TIM1 )
END IF
*
* Details of Householder rotations stored in WORK(MN+1:2*MN)
*
* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS)
*
OPCNT( ORM2R ) = OPCNT( ORM2R ) +
$ SOPLA( 'SORMQR', M, NRHS, MN, 0, 0 )
TIM1 = SECOND( )
CALL SORM2R( 'Left', 'Transpose', M, NRHS, MN, A, LDA, WORK( 1 ),
$ B, LDB, WORK( 2*MN+1 ), INFO )
TIM2 = SECOND( )
TIMNG( ORM2R ) = TIMNG( ORM2R ) + ( TIM2-TIM1 )
*
* workspace NRHS
*
* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS)
*
OPCNT( TRSM ) = OPCNT( TRSM ) +
$ SOPBL3( 'STRSM ', RANK, NRHS, 0 )
TIM1 = SECOND( )
CALL STRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK,
$ NRHS, ONE, A, LDA, B, LDB )
TIM2 = SECOND( )
TIMNG( TRSM ) = TIMNG( TRSM ) + ( TIM2-TIM1 )
*
DO 40 I = RANK + 1, N
DO 30 J = 1, NRHS
B( I, J ) = ZERO
30 CONTINUE
40 CONTINUE
*
* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS)
*
IF( RANK.LT.N ) THEN
OPCNT( LATZM ) = OPCNT( LATZM ) +
$ REAL( 2*( (N-RANK)*NRHS + NRHS + (N-RANK)*NRHS )*RANK )
TIM1 = SECOND( )
DO 50 I = 1, RANK
CALL SLATZM( 'Left', N-RANK+1, NRHS, A( I, RANK+1 ), LDA,
$ WORK( MN+I ), B( I, 1 ), B( RANK+1, 1 ), LDB,
$ WORK( 2*MN+1 ) )
50 CONTINUE
TIM2 = SECOND( )
TIMNG( LATZM ) = TIMNG( LATZM ) + ( TIM2-TIM1 )
END IF
*
* workspace NRHS
*
* B(1:N,1:NRHS) := P * B(1:N,1:NRHS)
*
DO 90 J = 1, NRHS
DO 60 I = 1, N
WORK( 2*MN+I ) = NTDONE
60 CONTINUE
DO 80 I = 1, N
IF( WORK( 2*MN+I ).EQ.NTDONE ) THEN
IF( JPVT( I ).NE.I ) THEN
K = I
T1 = B( K, J )
T2 = B( JPVT( K ), J )
70 CONTINUE
B( JPVT( K ), J ) = T1
WORK( 2*MN+K ) = DONE
T1 = T2
K = JPVT( K )
T2 = B( JPVT( K ), J )
IF( JPVT( K ).NE.I )
$ GO TO 70
B( I, J ) = T1
WORK( 2*MN+K ) = DONE
END IF
END IF
80 CONTINUE
90 CONTINUE
*
* Undo scaling
*
IF( IASCL.EQ.1 ) THEN
OPCNT( GELSX ) = OPCNT( GELSX ) + REAL( N*NRHS + RANK*RANK )
CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
CALL SLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA,
$ INFO )
ELSE IF( IASCL.EQ.2 ) THEN
OPCNT( GELSX ) = OPCNT( GELSX ) + REAL( N*NRHS + RANK*RANK )
CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
CALL SLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA,
$ INFO )
END IF
IF( IBSCL.EQ.1 ) THEN
OPCNT( GELSX ) = OPCNT( GELSX ) + REAL( N*NRHS )
CALL SLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
ELSE IF( IBSCL.EQ.2 ) THEN
OPCNT( GELSX ) = OPCNT( GELSX ) + REAL( N*NRHS )
CALL SLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
END IF
*
100 CONTINUE
*
RETURN
*
* End of SGELSX
*
END
SUBROUTINE SGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK,
$ WORK, LWORK, INFO )
*
* -- LAPACK driver routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
REAL RCOND
* ..
* .. Array Arguments ..
INTEGER JPVT( * )
REAL A( LDA, * ), B( LDB, * ), WORK( * )
* ..
* Common block to return operation counts and timings
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
COMMON / LSTIME / OPCNT, TIMNG
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
* .. Arrays in Common ..
REAL OPCNT( 6 ), TIMNG( 6 )
* ..
*
* Purpose
* =======
*
* SGELSY computes the minimum-norm solution to a real linear least
* squares problem:
* min || A * X - B ||
* using a complete orthogonal factorization of A. A is an M-by-N
* matrix which may be rank-deficient.
*
* Several right hand side vectors b and solution vectors x can be
* handled in a single call; they are stored as the columns of the
* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
* matrix X.
*
* The routine first computes a QR factorization with column pivoting:
* A * P = Q * [ R11 R12 ]
* [ 0 R22 ]
* with R11 defined as the largest leading submatrix whose estimated
* condition number is less than 1/RCOND. The order of R11, RANK,
* is the effective rank of A.
*
* Then, R22 is considered to be negligible, and R12 is annihilated
* by orthogonal transformations from the right, arriving at the
* complete orthogonal factorization:
* A * P = Q * [ T11 0 ] * Z
* [ 0 0 ]
* The minimum-norm solution is then
* X = P * Z' [ inv(T11)*Q1'*B ]
* [ 0 ]
* where Q1 consists of the first RANK columns of Q.
*
* This routine is basically identical to the original xGELSX except
* three differences:
* o The call to the subroutine xGEQPF has been substituted by the
* the call to the subroutine xGEQP3. This subroutine is a Blas-3
* version of the QR factorization with column pivoting.
* o Matrix B (the right hand side) is updated with Blas-3.
* o The permutation of matrix B (the right hand side) is faster and
* more simple.
*
* 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.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of
* columns of matrices B and X. NRHS >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, A has been overwritten by details of its
* complete orthogonal factorization.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the M-by-NRHS right hand side matrix B.
* On exit, the N-by-NRHS solution matrix X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,M,N).
*
* JPVT (input/output) INTEGER array, dimension (N)
* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
* to the front of AP, otherwise column i is a free column.
* On exit, if JPVT(i) = k, then the i-th column of AP
* was the k-th column of A.
*
* RCOND (input) REAL
* RCOND is used to determine the effective rank of A, which
* is defined as the order of the largest leading triangular
* submatrix R11 in the QR factorization with pivoting of A,
* whose estimated condition number < 1/RCOND.
*
* RANK (output) INTEGER
* The effective rank of A, i.e., the order of the submatrix
* R11. This is the same as the order of the submatrix T11
* in the complete orthogonal factorization of A.
*
* WORK (workspace/output) REAL array, dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* The unblocked strategy requires that:
* LWORK >= MAX( MN+3*N+1, 2*MN+NRHS ),
* where MN = min( M, N ).
* The block algorithm requires that:
* LWORK >= MAX( MN+2*N+NB*(N+1), 2*MN+NB*NRHS ),
* where NB is an upper bound on the blocksize returned
* by ILAENV for the routines SGEQP3, STZRZF, STZRQF, SORMQR,
* and SORMRZ.
*
* 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
* ===============
*
* Based on contributions by
* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
* E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
*
* =====================================================================
*
* .. Parameters ..
INTEGER IMAX, IMIN
PARAMETER ( IMAX = 1, IMIN = 2 )
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER GELSY, GEQP3, I, IASCL, IBSCL, ISMAX, ISMIN,
$ J, LWKOPT, MN, NB, NB1, NB2, NB3, NB4, ORMQR,
$ ORMRZ, TRSM, TZRZF
REAL ANRM, BIGNUM, BNRM, C1, C2, S1, S2, SMAX,
$ SMAXPR, SMIN, SMINPR, SMLNUM, T1, T2, WSIZE
* ..
* .. External Functions ..
INTEGER ILAENV
REAL SECOND, SLAMCH, SLANGE, SOPBL3,
$ SOPLA
EXTERNAL SECOND, SLAMCH, SLANGE, SOPBL3,
$ SOPLA, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEQP3, SLABAD, SLAIC1, SLASCL, SLASET,
$ SORMQR, SORMRZ, STRSM, STZRZF, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, REAL, MAX, MIN
* ..
* .. Data statements ..
DATA GELSY / 1 /, GEQP3 / 2 /, ORMQR / 4 /,
$ ORMRZ / 6 /, TRSM / 5 /, TZRZF / 3 /
* ..
* .. Executable Statements ..
*
MN = MIN( M, N )
ISMIN = MN + 1
ISMAX = 2*MN + 1
*
* Test the input arguments.
*
INFO = 0
NB1 = ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
NB2 = ILAENV( 1, 'SGERQF', ' ', M, N, -1, -1 )
NB3 = ILAENV( 1, 'SORMQR', ' ', M, N, NRHS, -1 )
NB4 = ILAENV( 1, 'SORMRQ', ' ', M, N, NRHS, -1 )
NB = MAX( NB1, NB2, NB3, NB4 )
LWKOPT = MAX( 1, MN+2*N+NB*(N+1), 2*MN+NB*NRHS )
WORK( 1 ) = REAL( LWKOPT )
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) 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, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
INFO = -7
ELSE IF( LWORK.LT.MAX( 1, MN+3*N+1, 2*MN+NRHS ) .AND.
$ .NOT.LQUERY ) THEN
INFO = -12
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGELSY', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( MIN( M, N, NRHS ).EQ.0 ) THEN
RANK = 0
RETURN
END IF
*
* Get machine parameters
*
OPCNT( GELSY ) = OPCNT( GELSY ) + REAL( 2 )
SMLNUM = SLAMCH( 'S' ) / SLAMCH( 'P' )
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
*
* Scale A, B if max entries outside range [SMLNUM,BIGNUM]
*
ANRM = SLANGE( 'M', M, N, A, LDA, WORK )
IASCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
OPCNT( GELSY ) = OPCNT( GELSY ) + REAL( M*N )
CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
IASCL = 1
ELSE IF( ANRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
OPCNT( GELSY ) = OPCNT( GELSY ) + REAL( M*N )
CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
IASCL = 2
ELSE IF( ANRM.EQ.ZERO ) THEN
*
* Matrix all zero. Return zero solution.
*
CALL SLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
RANK = 0
GO TO 70
END IF
*
BNRM = SLANGE( 'M', M, NRHS, B, LDB, WORK )
IBSCL = 0
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
OPCNT( GELSY ) = OPCNT( GELSY ) + REAL( M*NRHS )
CALL SLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
IBSCL = 1
ELSE IF( BNRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
OPCNT( GELSY ) = OPCNT( GELSY ) + REAL( M*NRHS )
CALL SLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
IBSCL = 2
END IF
*
* Compute QR factorization with column pivoting of A:
* A * P = Q * R
*
OPCNT( GEQP3 ) = OPCNT( GEQP3 ) + SOPLA( 'SGEQPF', M, N, 0, 0, 0 )
T1 = SECOND( )
CALL SGEQP3( M, N, A, LDA, JPVT, WORK( 1 ), WORK( MN+1 ),
$ LWORK-MN, INFO )
T2 = SECOND( )
TIMNG( GEQP3 ) = TIMNG( GEQP3 ) + ( T2-T1 )
WSIZE = MN + WORK( MN+1 )
*
* workspace: MN+2*N+NB*(N+1).
* Details of Householder rotations stored in WORK(1:MN).
*
* Determine RANK using incremental condition estimation
*
WORK( ISMIN ) = ONE
WORK( ISMAX ) = ONE
SMAX = ABS( A( 1, 1 ) )
SMIN = SMAX
IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN
RANK = 0
CALL SLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
GO TO 70
ELSE
RANK = 1
END IF
*
10 CONTINUE
IF( RANK.LT.MN ) THEN
I = RANK + 1
OPS = 0
CALL SLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ),
$ A( I, I ), SMINPR, S1, C1 )
CALL SLAIC1( IMAX, RANK, WORK( ISMAX ), SMAX, A( 1, I ),
$ A( I, I ), SMAXPR, S2, C2 )
OPCNT( GELSY ) = OPCNT( GELSY ) + OPS + REAL( 1 )
*
IF( SMAXPR*RCOND.LE.SMINPR ) THEN
OPCNT( GELSY ) = OPCNT( GELSY ) + REAL( RANK*2 )
DO 20 I = 1, RANK
WORK( ISMIN+I-1 ) = S1*WORK( ISMIN+I-1 )
WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 )
20 CONTINUE
WORK( ISMIN+RANK ) = C1
WORK( ISMAX+RANK ) = C2
SMIN = SMINPR
SMAX = SMAXPR
RANK = RANK + 1
GO TO 10
END IF
END IF
*
* workspace: 3*MN.
*
* Logically partition R = [ R11 R12 ]
* [ 0 R22 ]
* where R11 = R(1:RANK,1:RANK)
*
* [R11,R12] = [ T11, 0 ] * Y
*
IF( RANK.LT.N ) THEN
OPCNT( TZRZF ) = OPCNT( TZRZF ) +
$ SOPLA( 'STZRQF', RANK, N, 0, 0, 0 )
T1 = SECOND( )
CALL STZRZF( RANK, N, A, LDA, WORK( MN+1 ), WORK( 2*MN+1 ),
$ LWORK-2*MN, INFO )
T2 = SECOND( )
TIMNG( TZRZF ) = TIMNG( TZRZF ) + ( T2-T1 )
END IF
*
* workspace: 2*MN.
* Details of Householder rotations stored in WORK(MN+1:2*MN)
*
* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS)
*
OPCNT( ORMQR ) = OPCNT( ORMQR ) +
$ SOPLA( 'SORMQR', M, NRHS, MN, 0, 0 )
T1 = SECOND( )
CALL SORMQR( 'Left', 'Transpose', M, NRHS, MN, A, LDA, WORK( 1 ),
$ B, LDB, WORK( 2*MN+1 ), LWORK-2*MN, INFO )
T2 = SECOND( )
TIMNG( ORMQR ) = TIMNG( ORMQR ) + ( T2-T1 )
WSIZE = MAX( WSIZE, 2*MN+WORK( 2*MN+1 ) )
*
* workspace: 2*MN+NB*NRHS.
*
* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS)
*
OPCNT( TRSM ) = OPCNT( TRSM ) +
$ SOPBL3( 'STRSM ', RANK, NRHS, 0 )
T1 = SECOND( )
CALL STRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK,
$ NRHS, ONE, A, LDA, B, LDB )
T2 = SECOND( )
TIMNG( TRSM ) = TIMNG( TRSM ) + ( T2-T1 )
*
DO 40 J = 1, NRHS
DO 30 I = RANK + 1, N
B( I, J ) = ZERO
30 CONTINUE
40 CONTINUE
*
* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS)
*
IF( RANK.LT.N ) THEN
NB = ILAENV( 1, 'SORMRQ', 'LT', N, NRHS, RANK, -1 )
OPCNT( ORMRZ ) = OPCNT( ORMRZ ) +
$ SOPLA( 'SORMRQ', N, NRHS, RANK, 0, NB )
T1 = SECOND( )
CALL SORMRZ( 'Left', 'Transpose', N, NRHS, RANK, N-RANK, A,
$ LDA, WORK( MN+1 ), B, LDB, WORK( 2*MN+1 ),
$ LWORK-2*MN, INFO )
T2 = SECOND( )
TIMNG( ORMRZ ) = TIMNG( ORMRZ ) + ( T2-T1 )
END IF
*
* workspace: 2*MN+NRHS.
*
* B(1:N,1:NRHS) := P * B(1:N,1:NRHS)
*
DO 60 J = 1, NRHS
DO 50 I = 1, N
WORK( JPVT( I ) ) = B( I, J )
50 CONTINUE
CALL SCOPY( N, WORK( 1 ), 1, B( 1, J ), 1 )
60 CONTINUE
*
* workspace: N.
*
* Undo scaling
*
IF( IASCL.EQ.1 ) THEN
OPCNT( GELSY ) = OPCNT( GELSY ) + REAL( N*NRHS + RANK*RANK )
CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
CALL SLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA,
$ INFO )
ELSE IF( IASCL.EQ.2 ) THEN
OPCNT( GELSY ) = OPCNT( GELSY ) + REAL( N*NRHS + RANK*RANK )
CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
CALL SLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA,
$ INFO )
END IF
IF( IBSCL.EQ.1 ) THEN
OPCNT( GELSY ) = OPCNT( GELSY ) + REAL( N*NRHS )
CALL SLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
ELSE IF( IBSCL.EQ.2 ) THEN
OPCNT( GELSY ) = OPCNT( GELSY ) + REAL( N*NRHS )
CALL SLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
END IF
*
70 CONTINUE
WORK( 1 ) = REAL( LWKOPT )
*
RETURN
*
* End of SGELSY
*
END
SUBROUTINE SLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER J, JOB
REAL C, GAMMA, S, SEST, SESTPR
* ..
* .. Array Arguments ..
REAL W( J ), X( J )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLAIC1 applies one step of incremental condition estimation in
* its simplest version:
*
* Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j
* lower triangular matrix L, such that
* twonorm(L*x) = sest
* Then SLAIC1 computes sestpr, s, c such that
* the vector
* [ s*x ]
* xhat = [ c ]
* is an approximate singular vector of
* [ L 0 ]
* Lhat = [ w' gamma ]
* in the sense that
* twonorm(Lhat*xhat) = sestpr.
*
* Depending on JOB, an estimate for the largest or smallest singular
* value is computed.
*
* Note that [s c]' and sestpr**2 is an eigenpair of the system
*
* diag(sest*sest, 0) + [alpha gamma] * [ alpha ]
* [ gamma ]
*
* where alpha = x'*w.
*
* Arguments
* =========
*
* JOB (input) INTEGER
* = 1: an estimate for the largest singular value is computed.
* = 2: an estimate for the smallest singular value is computed.
*
* J (input) INTEGER
* Length of X and W
*
* X (input) REAL array, dimension (J)
* The j-vector x.
*
* SEST (input) REAL
* Estimated singular value of j by j matrix L
*
* W (input) REAL array, dimension (J)
* The j-vector w.
*
* GAMMA (input) REAL
* The diagonal element gamma.
*
* SESTPR (output) REAL
* Estimated singular value of (j+1) by (j+1) matrix Lhat.
*
* S (output) REAL
* Sine needed in forming xhat.
*
* C (output) REAL
* Cosine needed in forming xhat.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 )
REAL HALF, FOUR
PARAMETER ( HALF = 0.5E0, FOUR = 4.0E0 )
* ..
* .. Local Scalars ..
REAL ABSALP, ABSEST, ABSGAM, ALPHA, B, COSINE, EPS,
$ NORMA, S1, S2, SINE, T, TEST, TMP, ZETA1, ZETA2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SIGN, SQRT
* ..
* .. External Functions ..
REAL SDOT, SLAMCH
EXTERNAL SDOT, SLAMCH
* ..
* .. Executable Statements ..
*
EPS = SLAMCH( 'Epsilon' )
ALPHA = SDOT( J, X, 1, W, 1 )
*
ABSALP = ABS( ALPHA )
ABSGAM = ABS( GAMMA )
ABSEST = ABS( SEST )
*
IF( JOB.EQ.1 ) THEN
*
* Estimating largest singular value
*
* special cases
*
IF( SEST.EQ.ZERO ) THEN
S1 = MAX( ABSGAM, ABSALP )
IF( S1.EQ.ZERO ) THEN
S = ZERO
C = ONE
SESTPR = ZERO
ELSE
OPS = OPS + 9
S = ALPHA / S1
C = GAMMA / S1
TMP = SQRT( S*S+C*C )
S = S / TMP
C = C / TMP
SESTPR = S1*TMP
END IF
RETURN
ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN
OPS = OPS + 7
S = ONE
C = ZERO
TMP = MAX( ABSEST, ABSALP )
S1 = ABSEST / TMP
S2 = ABSALP / TMP
SESTPR = TMP*SQRT( S1*S1+S2*S2 )
RETURN
ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN
S1 = ABSGAM
S2 = ABSEST
IF( S1.LE.S2 ) THEN
S = ONE
C = ZERO
SESTPR = S2
ELSE
S = ZERO
C = ONE
SESTPR = S1
END IF
RETURN
ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN
S1 = ABSGAM
S2 = ABSALP
IF( S1.LE.S2 ) THEN
OPS = OPS + 8
TMP = S1 / S2
S = SQRT( ONE+TMP*TMP )
SESTPR = S2*S
C = ( GAMMA / S2 ) / S
S = SIGN( ONE, ALPHA ) / S
ELSE
OPS = OPS + 8
TMP = S2 / S1
C = SQRT( ONE+TMP*TMP )
SESTPR = S1*C
S = ( ALPHA / S1 ) / C
C = SIGN( ONE, GAMMA ) / C
END IF
RETURN
ELSE
*
* normal case
*
OPS = OPS + 8
ZETA1 = ALPHA / ABSEST
ZETA2 = GAMMA / ABSEST
*
B = ( ONE-ZETA1*ZETA1-ZETA2*ZETA2 )*HALF
C = ZETA1*ZETA1
IF( B.GT.ZERO ) THEN
OPS = OPS + 5
T = C / ( B+SQRT( B*B+C ) )
ELSE
OPS = OPS + 4
T = SQRT( B*B+C ) - B
END IF
*
OPS = OPS + 12
SINE = -ZETA1 / T
COSINE = -ZETA2 / ( ONE+T )
TMP = SQRT( SINE*SINE+COSINE*COSINE )
S = SINE / TMP
C = COSINE / TMP
SESTPR = SQRT( T+ONE )*ABSEST
RETURN
END IF
*
ELSE IF( JOB.EQ.2 ) THEN
*
* Estimating smallest singular value
*
* special cases
*
IF( SEST.EQ.ZERO ) THEN
SESTPR = ZERO
IF( MAX( ABSGAM, ABSALP ).EQ.ZERO ) THEN
SINE = ONE
COSINE = ZERO
ELSE
SINE = -GAMMA
COSINE = ALPHA
END IF
OPS = OPS + 7
S1 = MAX( ABS( SINE ), ABS( COSINE ) )
S = SINE / S1
C = COSINE / S1
TMP = SQRT( S*S+C*C )
S = S / TMP
C = C / TMP
RETURN
ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN
S = ZERO
C = ONE
SESTPR = ABSGAM
RETURN
ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN
S1 = ABSGAM
S2 = ABSEST
IF( S1.LE.S2 ) THEN
S = ZERO
C = ONE
SESTPR = S1
ELSE
S = ONE
C = ZERO
SESTPR = S2
END IF
RETURN
ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN
S1 = ABSGAM
S2 = ABSALP
IF( S1.LE.S2 ) THEN
OPS = OPS + 9
TMP = S1 / S2
C = SQRT( ONE+TMP*TMP )
SESTPR = ABSEST*( TMP / C )
S = -( GAMMA / S2 ) / C
C = SIGN( ONE, ALPHA ) / C
ELSE
OPS = OPS + 8
TMP = S2 / S1
S = SQRT( ONE+TMP*TMP )
SESTPR = ABSEST / S
C = ( ALPHA / S1 ) / S
S = -SIGN( ONE, GAMMA ) / S
END IF
RETURN
ELSE
*
* normal case
*
OPS = OPS + 14
ZETA1 = ALPHA / ABSEST
ZETA2 = GAMMA / ABSEST
*
NORMA = MAX( ONE+ZETA1*ZETA1+ABS( ZETA1*ZETA2 ),
$ ABS( ZETA1*ZETA2 )+ZETA2*ZETA2 )
*
* See if root is closer to zero or to ONE
*
TEST = ONE + TWO*( ZETA1-ZETA2 )*( ZETA1+ZETA2 )
IF( TEST.GE.ZERO ) THEN
*
* root is close to zero, compute directly
*
OPS = OPS + 20
B = ( ZETA1*ZETA1+ZETA2*ZETA2+ONE )*HALF
C = ZETA2*ZETA2
T = C / ( B+SQRT( ABS( B*B-C ) ) )
SINE = ZETA1 / ( ONE-T )
COSINE = -ZETA2 / T
SESTPR = SQRT( T+FOUR*EPS*EPS*NORMA )*ABSEST
ELSE
*
* root is closer to ONE, shift by that amount
*
OPS = OPS + 6
B = ( ZETA2*ZETA2+ZETA1*ZETA1-ONE )*HALF
C = ZETA1*ZETA1
IF( B.GE.ZERO ) THEN
OPS = OPS + 5
T = -C / ( B+SQRT( B*B+C ) )
ELSE
OPS = OPS + 4
T = B - SQRT( B*B+C )
END IF
OPS = OPS + 10
SINE = -ZETA1 / T
COSINE = -ZETA2 / ( ONE+T )
SESTPR = SQRT( ONE+T+FOUR*EPS*EPS*NORMA )*ABSEST
END IF
OPS = OPS + 6
TMP = SQRT( SINE*SINE+COSINE*COSINE )
S = SINE / TMP
C = COSINE / TMP
RETURN
*
END IF
END IF
RETURN
*
* End of SLAIC1
*
END
SUBROUTINE SLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX,
$ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM,
$ POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO )
*
* -- LAPACK routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* December 22, 1999
*
* .. Scalar Arguments ..
INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL,
$ LDGNUM, NL, NR, NRHS, SQRE
REAL C, S
* ..
* .. Array Arguments ..
INTEGER GIVCOL( LDGCOL, * ), PERM( * )
REAL B( LDB, * ), BX( LDBX, * ), DIFL( * ),
$ DIFR( LDGNUM, * ), GIVNUM( LDGNUM, * ),
$ POLES( LDGNUM, * ), WORK( * ), Z( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLALS0 applies back the multiplying factors of either the left or the
* right singular vector matrix of a diagonal matrix appended by a row
* to the right hand side matrix B in solving the least squares problem
* using the divide-and-conquer SVD approach.
*
* For the left singular vector matrix, three types of orthogonal
* matrices are involved:
*
* (1L) Givens rotations: the number of such rotations is GIVPTR; the
* pairs of columns/rows they were applied to are stored in GIVCOL;
* and the C- and S-values of these rotations are stored in GIVNUM.
*
* (2L) Permutation. The (NL+1)-st row of B is to be moved to the first
* row, and for J=2:N, PERM(J)-th row of B is to be moved to the
* J-th row.
*
* (3L) The left singular vector matrix of the remaining matrix.
*
* For the right singular vector matrix, four types of orthogonal
* matrices are involved:
*
* (1R) The right singular vector matrix of the remaining matrix.
*
* (2R) If SQRE = 1, one extra Givens rotation to generate the right
* null space.
*
* (3R) The inverse transformation of (2L).
*
* (4R) The inverse transformation of (1L).
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* Specifies whether singular vectors are to be computed in
* factored form:
* = 0: Left singular vector matrix.
* = 1: Right singular vector matrix.
*
* NL (input) INTEGER
* The row dimension of the upper block. NL >= 1.
*
* NR (input) INTEGER
* The row dimension of the lower block. NR >= 1.
*
* SQRE (input) INTEGER
* = 0: the lower block is an NR-by-NR square matrix.
* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
*
* The bidiagonal matrix has row dimension N = NL + NR + 1,
* and column dimension M = N + SQRE.
*
* NRHS (input) INTEGER
* The number of columns of B and BX. NRHS must be at least 1.
*
* B (input/output) REAL array, dimension ( LDB, NRHS )
* On input, B contains the right hand sides of the least
* squares problem in rows 1 through M. On output, B contains
* the solution X in rows 1 through N.
*
* LDB (input) INTEGER
* The leading dimension of B. LDB must be at least
* max(1,MAX( M, N ) ).
*
* BX (workspace) REAL array, dimension ( LDBX, NRHS )
*
* LDBX (input) INTEGER
* The leading dimension of BX.
*
* PERM (input) INTEGER array, dimension ( N )
* The permutations (from deflation and sorting) applied
* to the two blocks.
*
* GIVPTR (input) INTEGER
* The number of Givens rotations which took place in this
* subproblem.
*
* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )
* Each pair of numbers indicates a pair of rows/columns
* involved in a Givens rotation.
*
* LDGCOL (input) INTEGER
* The leading dimension of GIVCOL, must be at least N.
*
* GIVNUM (input) REAL array, dimension ( LDGNUM, 2 )
* Each number indicates the C or S value used in the
* corresponding Givens rotation.
*
* LDGNUM (input) INTEGER
* The leading dimension of arrays DIFR, POLES and
* GIVNUM, must be at least K.
*
* POLES (input) REAL array, dimension ( LDGNUM, 2 )
* On entry, POLES(1:K, 1) contains the new singular
* values obtained from solving the secular equation, and
* POLES(1:K, 2) is an array containing the poles in the secular
* equation.
*
* DIFL (input) REAL array, dimension ( K ).
* On entry, DIFL(I) is the distance between I-th updated
* (undeflated) singular value and the I-th (undeflated) old
* singular value.
*
* DIFR (input) REAL array, dimension ( LDGNUM, 2 ).
* On entry, DIFR(I, 1) contains the distances between I-th
* updated (undeflated) singular value and the I+1-th
* (undeflated) old singular value. And DIFR(I, 2) is the
* normalizing factor for the I-th right singular vector.
*
* Z (input) REAL array, dimension ( K )
* Contain the components of the deflation-adjusted updating row
* vector.
*
* K (input) INTEGER
* Contains the dimension of the non-deflated matrix,
* This is the order of the related secular equation. 1 <= K <=N.
*
* C (input) REAL
* C contains garbage if SQRE =0 and the C-value of a Givens
* rotation related to the right null space if SQRE = 1.
*
* S (input) REAL
* S contains garbage if SQRE =0 and the S-value of a Givens
* rotation related to the right null space if SQRE = 1.
*
* WORK (workspace) REAL array, dimension ( K )
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO, NEGONE
PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0, NEGONE = -1.0E0 )
* ..
* .. Local Scalars ..
INTEGER I, J, M, N, NLP1
REAL DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, TEMP
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMV, SLACPY, SLASCL, SROT, SSCAL,
$ XERBLA
* ..
* .. External Functions ..
REAL SLAMC3, SNRM2, SOPBL2
EXTERNAL SLAMC3, SNRM2, SOPBL2
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
INFO = -1
ELSE IF( NL.LT.1 ) THEN
INFO = -2
ELSE IF( NR.LT.1 ) THEN
INFO = -3
ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
INFO = -4
END IF
*
N = NL + NR + 1
*
IF( NRHS.LT.1 ) THEN
INFO = -5
ELSE IF( LDB.LT.N ) THEN
INFO = -7
ELSE IF( LDBX.LT.N ) THEN
INFO = -9
ELSE IF( GIVPTR.LT.0 ) THEN
INFO = -11
ELSE IF( LDGCOL.LT.N ) THEN
INFO = -13
ELSE IF( LDGNUM.LT.N ) THEN
INFO = -15
ELSE IF( K.LT.1 ) THEN
INFO = -20
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLALS0', -INFO )
RETURN
END IF
*
M = N + SQRE
NLP1 = NL + 1
*
IF( ICOMPQ.EQ.0 ) THEN
*
* Apply back orthogonal transformations from the left.
*
* Step (1L): apply back the Givens rotations performed.
*
OPS = OPS + REAL( 6*NRHS*GIVPTR )
DO 10 I = 1, GIVPTR
CALL SROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB,
$ B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ),
$ GIVNUM( I, 1 ) )
10 CONTINUE
*
* Step (2L): permute rows of B.
*
CALL SCOPY( NRHS, B( NLP1, 1 ), LDB, BX( 1, 1 ), LDBX )
DO 20 I = 2, N
CALL SCOPY( NRHS, B( PERM( I ), 1 ), LDB, BX( I, 1 ), LDBX )
20 CONTINUE
*
* Step (3L): apply the inverse of the left singular vector
* matrix to BX.
*
IF( K.EQ.1 ) THEN
CALL SCOPY( NRHS, BX, LDBX, B, LDB )
IF( Z( 1 ).LT.ZERO ) THEN
OPS = OPS + REAL( NRHS )
CALL SSCAL( NRHS, NEGONE, B, LDB )
END IF
ELSE
DO 50 J = 1, K
DIFLJ = DIFL( J )
DJ = POLES( J, 1 )
DSIGJ = -POLES( J, 2 )
IF( J.LT.K ) THEN
DIFRJ = -DIFR( J, 1 )
DSIGJP = -POLES( J+1, 2 )
END IF
IF( ( Z( J ).EQ.ZERO ) .OR. ( POLES( J, 2 ).EQ.ZERO ) )
$ THEN
WORK( J ) = ZERO
ELSE
OPS = OPS + REAL( 4 )
WORK( J ) = -POLES( J, 2 )*Z( J ) / DIFLJ /
$ ( POLES( J, 2 )+DJ )
END IF
DO 30 I = 1, J - 1
IF( ( Z( I ).EQ.ZERO ) .OR.
$ ( POLES( I, 2 ).EQ.ZERO ) ) THEN
WORK( I ) = ZERO
ELSE
OPS = OPS + REAL( 6 )
WORK( I ) = POLES( I, 2 )*Z( I ) /
$ ( SLAMC3( POLES( I, 2 ), DSIGJ )-
$ DIFLJ ) / ( POLES( I, 2 )+DJ )
END IF
30 CONTINUE
DO 40 I = J + 1, K
IF( ( Z( I ).EQ.ZERO ) .OR.
$ ( POLES( I, 2 ).EQ.ZERO ) ) THEN
WORK( I ) = ZERO
ELSE
OPS = OPS + REAL( 6 )
WORK( I ) = POLES( I, 2 )*Z( I ) /
$ ( SLAMC3( POLES( I, 2 ), DSIGJP )+
$ DIFRJ ) / ( POLES( I, 2 )+DJ )
END IF
40 CONTINUE
WORK( 1 ) = NEGONE
OPS = OPS + 2*K + NRHS +
$ SOPBL2( 'SGEMV ', K, NRHS, 0, 0 )
TEMP = SNRM2( K, WORK, 1 )
CALL SGEMV( 'T', K, NRHS, ONE, BX, LDBX, WORK, 1, ZERO,
$ B( J, 1 ), LDB )
CALL SLASCL( 'G', 0, 0, TEMP, ONE, 1, NRHS, B( J, 1 ),
$ LDB, INFO )
50 CONTINUE
END IF
*
* Move the deflated rows of BX to B also.
*
IF( K.LT.MAX( M, N ) )
$ CALL SLACPY( 'A', N-K, NRHS, BX( K+1, 1 ), LDBX,
$ B( K+1, 1 ), LDB )
ELSE
*
* Apply back the right orthogonal transformations.
*
* Step (1R): apply back the new right singular vector matrix
* to B.
*
IF( K.EQ.1 ) THEN
CALL SCOPY( NRHS, B, LDB, BX, LDBX )
ELSE
DO 80 J = 1, K
DSIGJ = POLES( J, 2 )
IF( Z( J ).EQ.ZERO ) THEN
WORK( J ) = ZERO
ELSE
OPS = OPS + REAL( 4 )
WORK( J ) = -Z( J ) / DIFL( J ) /
$ ( DSIGJ+POLES( J, 1 ) ) / DIFR( J, 2 )
END IF
DO 60 I = 1, J - 1
IF( Z( J ).EQ.ZERO ) THEN
WORK( I ) = ZERO
ELSE
OPS = OPS + REAL( 6 )
WORK( I ) = Z( J ) / ( SLAMC3( DSIGJ, -POLES( I+1,
$ 2 ) )-DIFR( I, 1 ) ) /
$ ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )
END IF
60 CONTINUE
DO 70 I = J + 1, K
IF( Z( J ).EQ.ZERO ) THEN
WORK( I ) = ZERO
ELSE
OPS = OPS + REAL( 6 )
WORK( I ) = Z( J ) / ( SLAMC3( DSIGJ, -POLES( I,
$ 2 ) )-DIFL( I ) ) /
$ ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )
END IF
70 CONTINUE
OPS = OPS + SOPBL2( 'SGEMV ', K, NRHS, 0, 0 )
CALL SGEMV( 'T', K, NRHS, ONE, B, LDB, WORK, 1, ZERO,
$ BX( J, 1 ), LDBX )
80 CONTINUE
END IF
*
* Step (2R): if SQRE = 1, apply back the rotation that is
* related to the right null space of the subproblem.
*
IF( SQRE.EQ.1 ) THEN
OPS = OPS + REAL( 6*NRHS )
CALL SCOPY( NRHS, B( M, 1 ), LDB, BX( M, 1 ), LDBX )
CALL SROT( NRHS, BX( 1, 1 ), LDBX, BX( M, 1 ), LDBX, C, S )
END IF
IF( K.LT.MAX( M, N ) )
$ CALL SLACPY( 'A', N-K, NRHS, B( K+1, 1 ), LDB,
$ BX( K+1, 1 ), LDBX )
*
* Step (3R): permute rows of B.
*
CALL SCOPY( NRHS, BX( 1, 1 ), LDBX, B( NLP1, 1 ), LDB )
IF( SQRE.EQ.1 ) THEN
CALL SCOPY( NRHS, BX( M, 1 ), LDBX, B( M, 1 ), LDB )
END IF
DO 90 I = 2, N
CALL SCOPY( NRHS, BX( I, 1 ), LDBX, B( PERM( I ), 1 ), LDB )
90 CONTINUE
*
* Step (4R): apply back the Givens rotations performed.
*
OPS = OPS + REAL( 6*NRHS*GIVPTR )
DO 100 I = GIVPTR, 1, -1
CALL SROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB,
$ B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ),
$ -GIVNUM( I, 1 ) )
100 CONTINUE
END IF
*
RETURN
*
* End of SLALS0
*
END
SUBROUTINE SLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U,
$ LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR,
$ GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK,
$ IWORK, INFO )
*
* -- LAPACK routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS,
$ SMLSIZ
* ..
* .. Array Arguments ..
INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ),
$ K( * ), PERM( LDGCOL, * )
REAL B( LDB, * ), BX( LDBX, * ), C( * ),
$ DIFL( LDU, * ), DIFR( LDU, * ),
$ GIVNUM( LDU, * ), POLES( LDU, * ), S( * ),
$ U( LDU, * ), VT( LDU, * ), WORK( * ),
$ Z( LDU, * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLALSA is an itermediate step in solving the least squares problem
* by computing the SVD of the coefficient matrix in compact form (The
* singular vectors are computed as products of simple orthorgonal
* matrices.).
*
* If ICOMPQ = 0, SLALSA applies the inverse of the left singular vector
* matrix of an upper bidiagonal matrix to the right hand side; and if
* ICOMPQ = 1, SLALSA applies the right singular vector matrix to the
* right hand side. The singular vector matrices were generated in
* compact form by SLALSA.
*
* Arguments
* =========
*
*
* ICOMPQ (input) INTEGER
* Specifies whether the left or the right singular vector
* matrix is involved.
* = 0: Left singular vector matrix
* = 1: Right singular vector matrix
*
* SMLSIZ (input) INTEGER
* The maximum size of the subproblems at the bottom of the
* computation tree.
*
* N (input) INTEGER
* The row and column dimensions of the upper bidiagonal matrix.
*
* NRHS (input) INTEGER
* The number of columns of B and BX. NRHS must be at least 1.
*
* B (input) REAL array, dimension ( LDB, NRHS )
* On input, B contains the right hand sides of the least
* squares problem in rows 1 through M. On output, B contains
* the solution X in rows 1 through N.
*
* LDB (input) INTEGER
* The leading dimension of B in the calling subprogram.
* LDB must be at least max(1,MAX( M, N ) ).
*
* BX (output) REAL array, dimension ( LDBX, NRHS )
* On exit, the result of applying the left or right singular
* vector matrix to B.
*
* LDBX (input) INTEGER
* The leading dimension of BX.
*
* U (input) REAL array, dimension ( LDU, SMLSIZ ).
* On entry, U contains the left singular vector matrices of all
* subproblems at the bottom level.
*
* LDU (input) INTEGER, LDU = > N.
* The leading dimension of arrays U, VT, DIFL, DIFR,
* POLES, GIVNUM, and Z.
*
* VT (input) REAL array, dimension ( LDU, SMLSIZ+1 ).
* On entry, VT' contains the right singular vector matrices of
* all subproblems at the bottom level.
*
* K (input) INTEGER array, dimension ( N ).
*
* DIFL (input) REAL array, dimension ( LDU, NLVL ).
* where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.
*
* DIFR (input) REAL array, dimension ( LDU, 2 * NLVL ).
* On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record
* distances between singular values on the I-th level and
* singular values on the (I -1)-th level, and DIFR(*, 2 * I)
* record the normalizing factors of the right singular vectors
* matrices of subproblems on I-th level.
*
* Z (input) REAL array, dimension ( LDU, NLVL ).
* On entry, Z(1, I) contains the components of the deflation-
* adjusted updating row vector for subproblems on the I-th
* level.
*
* POLES (input) REAL array, dimension ( LDU, 2 * NLVL ).
* On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old
* singular values involved in the secular equations on the I-th
* level.
*
* GIVPTR (input) INTEGER array, dimension ( N ).
* On entry, GIVPTR( I ) records the number of Givens
* rotations performed on the I-th problem on the computation
* tree.
*
* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ).
* On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the
* locations of Givens rotations performed on the I-th level on
* the computation tree.
*
* LDGCOL (input) INTEGER, LDGCOL = > N.
* The leading dimension of arrays GIVCOL and PERM.
*
* PERM (input) INTEGER array, dimension ( LDGCOL, NLVL ).
* On entry, PERM(*, I) records permutations done on the I-th
* level of the computation tree.
*
* GIVNUM (input) REAL array, dimension ( LDU, 2 * NLVL ).
* On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-
* values of Givens rotations performed on the I-th level on the
* computation tree.
*
* C (input) REAL array, dimension ( N ).
* On entry, if the I-th subproblem is not square,
* C( I ) contains the C-value of a Givens rotation related to
* the right null space of the I-th subproblem.
*
* S (input) REAL array, dimension ( N ).
* On entry, if the I-th subproblem is not square,
* S( I ) contains the S-value of a Givens rotation related to
* the right null space of the I-th subproblem.
*
* WORK (workspace) REAL array.
* The dimension must be at least N.
*
* IWORK (workspace) INTEGER array.
* The dimension must be at least 3 * N
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
INTEGER I, I1, IC, IM1, INODE, J, LF, LL, LVL, LVL2,
$ ND, NDB1, NDIML, NDIMR, NL, NLF, NLP1, NLVL,
$ NR, NRF, NRP1, SQRE
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMM, SLALS0, SLASDT, XERBLA
* ..
* .. External Functions ..
REAL SOPBL3
EXTERNAL SOPBL3
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
INFO = -1
ELSE IF( SMLSIZ.LT.3 ) THEN
INFO = -2
ELSE IF( N.LT.SMLSIZ ) THEN
INFO = -3
ELSE IF( NRHS.LT.1 ) THEN
INFO = -4
ELSE IF( LDB.LT.N ) THEN
INFO = -6
ELSE IF( LDBX.LT.N ) THEN
INFO = -8
ELSE IF( LDU.LT.N ) THEN
INFO = -10
ELSE IF( LDGCOL.LT.N ) THEN
INFO = -19
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLALSA', -INFO )
RETURN
END IF
*
* Book-keeping and setting up the computation tree.
*
INODE = 1
NDIML = INODE + N
NDIMR = NDIML + N
*
CALL SLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ),
$ IWORK( NDIMR ), SMLSIZ )
*
* The following code applies back the left singular vector factors.
* For applying back the right singular vector factors, go to 50.
*
IF( ICOMPQ.EQ.1 ) THEN
GO TO 50
END IF
*
* The nodes on the bottom level of the tree were solved by SLASDQ.
* The corresponding left and right singular vector matrices are in
* explicit form. First apply back the left singular vector matrices.
*
NDB1 = ( ND+1 ) / 2
DO 10 I = NDB1, ND
*
* IC : center row of each node
* NL : number of rows of left subproblem
* NR : number of rows of right subproblem
* NLF: starting row of the left subproblem
* NRF: starting row of the right subproblem
*
I1 = I - 1
IC = IWORK( INODE+I1 )
NL = IWORK( NDIML+I1 )
NR = IWORK( NDIMR+I1 )
NLF = IC - NL
NRF = IC + 1
OPS = OPS + SOPBL3( 'SGEMM ', NL, NRHS, NL )
OPS = OPS + SOPBL3( 'SGEMM ', NR, NRHS, NR )
CALL SGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU,
$ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX )
CALL SGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU,
$ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX )
10 CONTINUE
*
* Next copy the rows of B that correspond to unchanged rows
* in the bidiagonal matrix to BX.
*
DO 20 I = 1, ND
IC = IWORK( INODE+I-1 )
CALL SCOPY( NRHS, B( IC, 1 ), LDB, BX( IC, 1 ), LDBX )
20 CONTINUE
*
* Finally go through the left singular vector matrices of all
* the other subproblems bottom-up on the tree.
*
J = 2**NLVL
SQRE = 0
*
DO 40 LVL = NLVL, 1, -1
LVL2 = 2*LVL - 1
*
* find the first node LF and last node LL on
* the current level LVL
*
IF( LVL.EQ.1 ) THEN
LF = 1
LL = 1
ELSE
LF = 2**( LVL-1 )
LL = 2*LF - 1
END IF
DO 30 I = LF, LL
IM1 = I - 1
IC = IWORK( INODE+IM1 )
NL = IWORK( NDIML+IM1 )
NR = IWORK( NDIMR+IM1 )
NLF = IC - NL
NRF = IC + 1
J = J - 1
CALL SLALS0( ICOMPQ, NL, NR, SQRE, NRHS, BX( NLF, 1 ), LDBX,
$ B( NLF, 1 ), LDB, PERM( NLF, LVL ),
$ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
$ GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ),
$ DIFL( NLF, LVL ), DIFR( NLF, LVL2 ),
$ Z( NLF, LVL ), K( J ), C( J ), S( J ), WORK,
$ INFO )
30 CONTINUE
40 CONTINUE
GO TO 90
*
* ICOMPQ = 1: applying back the right singular vector factors.
*
50 CONTINUE
*
* First now go through the right singular vector matrices of all
* the tree nodes top-down.
*
J = 0
DO 70 LVL = 1, NLVL
LVL2 = 2*LVL - 1
*
* Find the first node LF and last node LL on
* the current level LVL.
*
IF( LVL.EQ.1 ) THEN
LF = 1
LL = 1
ELSE
LF = 2**( LVL-1 )
LL = 2*LF - 1
END IF
DO 60 I = LL, LF, -1
IM1 = I - 1
IC = IWORK( INODE+IM1 )
NL = IWORK( NDIML+IM1 )
NR = IWORK( NDIMR+IM1 )
NLF = IC - NL
NRF = IC + 1
IF( I.EQ.LL ) THEN
SQRE = 0
ELSE
SQRE = 1
END IF
J = J + 1
CALL SLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B( NLF, 1 ), LDB,
$ BX( NLF, 1 ), LDBX, PERM( NLF, LVL ),
$ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
$ GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ),
$ DIFL( NLF, LVL ), DIFR( NLF, LVL2 ),
$ Z( NLF, LVL ), K( J ), C( J ), S( J ), WORK,
$ INFO )
60 CONTINUE
70 CONTINUE
*
* The nodes on the bottom level of the tree were solved by SLASDQ.
* The corresponding right singular vector matrices are in explicit
* form. Apply them back.
*
NDB1 = ( ND+1 ) / 2
DO 80 I = NDB1, ND
I1 = I - 1
IC = IWORK( INODE+I1 )
NL = IWORK( NDIML+I1 )
NR = IWORK( NDIMR+I1 )
NLP1 = NL + 1
IF( I.EQ.ND ) THEN
NRP1 = NR
ELSE
NRP1 = NR + 1
END IF
NLF = IC - NL
NRF = IC + 1
OPS = OPS + SOPBL3( 'SGEMM ', NLP1, NRHS, NLP1 )
OPS = OPS + SOPBL3( 'SGEMM ', NRP1, NRHS, NRP1 )
CALL SGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU,
$ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX )
CALL SGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU,
$ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX )
80 CONTINUE
*
90 CONTINUE
*
RETURN
*
* End of SLALSA
*
END
SUBROUTINE SLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND,
$ RANK, WORK, IWORK, INFO )
*
* -- LAPACK routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDB, N, NRHS, RANK, SMLSIZ
REAL RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL B( LDB, * ), D( * ), E( * ), WORK( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
REAL ITCNT, OPS
* ..
*
* Purpose
* =======
*
* SLALSD uses the singular value decomposition of A to solve the least
* squares problem of finding X to minimize the Euclidean norm of each
* column of A*X-B, where A is N-by-N upper bidiagonal, and X and B
* are N-by-NRHS. The solution X overwrites B.
*
* The singular values of A smaller than RCOND times the largest
* singular value are treated as zero in solving the least squares
* problem; in this case a minimum norm solution is returned.
* The actual singular values are returned in D in ascending order.
*
* This code makes very mild assumptions about floating point
* arithmetic. It will work on machines with a guard digit in
* add/subtract, or on those binary machines without guard digits
* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
* It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': D and E define an upper bidiagonal matrix.
* = 'L': D and E define a lower bidiagonal matrix.
*
* SMLSIZ (input) INTEGER
* The maximum size of the subproblems at the bottom of the
* computation tree.
*
* N (input) INTEGER
* The dimension of the bidiagonal matrix. N >= 0.
*
* NRHS (input) INTEGER
* The number of columns of B. NRHS must be at least 1.
*
* D (input/output) REAL array, dimension (N)
* On entry D contains the main diagonal of the bidiagonal
* matrix. On exit, if INFO = 0, D contains its singular values.
*
* E (input) REAL array, dimension (N-1)
* Contains the super-diagonal entries of the bidiagonal matrix.
* On exit, E has been destroyed.
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On input, B contains the right hand sides of the least
* squares problem. On output, B contains the solution X.
*
* LDB (input) INTEGER
* The leading dimension of B in the calling subprogram.
* LDB must be at least max(1,N).
*
* RCOND (input) REAL
* The singular values of A less than or equal to RCOND times
* the largest singular value are treated as zero in solving
* the least squares problem. If RCOND is negative,
* machine precision is used instead.
* For example, if diag(S)*X=B were the least squares problem,
* where diag(S) is a diagonal matrix of singular values, the
* solution would be X(i) = B(i) / S(i) if S(i) is greater than
* RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to
* RCOND*max(S).
*
* RANK (output) INTEGER
* The number of singular values of A greater than RCOND times
* the largest singular value.
*
* WORK (workspace) REAL array, dimension at least
* (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2),
* where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1).
*
* IWORK (workspace) INTEGER array, dimension at least
* (3 * N * NLVL + 11 * N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: The algorithm failed to compute an singular value while
* working on the submatrix lying in rows and columns
* INFO/(N+1) through MOD(INFO,N+1).
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 )
* ..
* .. Local Scalars ..
INTEGER BX, BXST, C, DIFL, DIFR, GIVCOL, GIVNUM,
$ GIVPTR, I, ICMPQ1, ICMPQ2, IWK, J, K, NLVL,
$ NM1, NSIZE, NSUB, NWORK, PERM, POLES, S, SIZEI,
$ SMLSZP, SQRE, ST, ST1, U, VT, Z
REAL CS, EPS, ORGNRM, R, SN, TOL
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMM, SLACPY, SLALSA, SLARTG, SLASCL,
$ SLASDA, SLASDQ, SLASET, SLASRT, SROT, XERBLA
* ..
* .. External Functions ..
INTEGER ISAMAX
REAL SLAMCH, SLANST, SOPBL3
EXTERNAL ISAMAX, SLAMCH, SLANST, SOPBL3
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL, ABS, INT, LOG, SIGN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.1 ) THEN
INFO = -4
ELSE IF( ( LDB.LT.1 ) .OR. ( LDB.LT.N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLALSD', -INFO )
RETURN
END IF
*
EPS = SLAMCH( 'Epsilon' )
*
* Set up the tolerance.
*
IF( ( RCOND.LE.ZERO ) .OR. ( RCOND.GE.ONE ) ) THEN
RCOND = EPS
END IF
*
RANK = 0
*
* Quick return if possible.
*
IF( N.EQ.0 ) THEN
RETURN
ELSE IF( N.EQ.1 ) THEN
IF( D( 1 ).EQ.ZERO ) THEN
CALL SLASET( 'A', 1, NRHS, ZERO, ZERO, B, LDB )
ELSE
RANK = 1
OPS = OPS + REAL( 2*NRHS )
CALL SLASCL( 'G', 0, 0, D( 1 ), ONE, 1, NRHS, B, LDB, INFO )
D( 1 ) = ABS( D( 1 ) )
END IF
RETURN
END IF
*
* Rotate the matrix if it is lower bidiagonal.
*
IF( UPLO.EQ.'L' ) THEN
OPS = OPS + REAL( 6*( N-1 ) )
DO 10 I = 1, N - 1
CALL SLARTG( D( I ), E( I ), CS, SN, R )
D( I ) = R
E( I ) = SN*D( I+1 )
D( I+1 ) = CS*D( I+1 )
IF( NRHS.EQ.1 ) THEN
OPS = OPS + REAL( 6 )
CALL SROT( 1, B( I, 1 ), 1, B( I+1, 1 ), 1, CS, SN )
ELSE
WORK( I*2-1 ) = CS
WORK( I*2 ) = SN
END IF
10 CONTINUE
IF( NRHS.GT.1 ) THEN
OPS = OPS + REAL( 6*( N-1 )*NRHS )
DO 30 I = 1, NRHS
DO 20 J = 1, N - 1
CS = WORK( J*2-1 )
SN = WORK( J*2 )
CALL SROT( 1, B( J, I ), 1, B( J+1, I ), 1, CS, SN )
20 CONTINUE
30 CONTINUE
END IF
END IF
*
* Scale.
*
NM1 = N - 1
ORGNRM = SLANST( 'M', N, D, E )
IF( ORGNRM.EQ.ZERO ) THEN
CALL SLASET( 'A', N, NRHS, ZERO, ZERO, B, LDB )
RETURN
END IF
*
OPS = OPS + REAL( N + NM1 )
CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, INFO )
*
* If N is smaller than the minimum divide size SMLSIZ, then solve
* the problem with another solver.
*
IF( N.LE.SMLSIZ ) THEN
NWORK = 1 + N*N
CALL SLASET( 'A', N, N, ZERO, ONE, WORK, N )
CALL SLASDQ( 'U', 0, N, N, 0, NRHS, D, E, WORK, N, WORK, N, B,
$ LDB, WORK( NWORK ), INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
OPS = OPS + REAL( 1 )
TOL = RCOND*ABS( D( ISAMAX( N, D, 1 ) ) )
DO 40 I = 1, N
IF( D( I ).LE.TOL ) THEN
CALL SLASET( 'A', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
ELSE
OPS = OPS + REAL( NRHS )
CALL SLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS, B( I, 1 ),
$ LDB, INFO )
RANK = RANK + 1
END IF
40 CONTINUE
OPS = OPS + SOPBL3( 'SGEMM ', N, NRHS, N )
CALL SGEMM( 'T', 'N', N, NRHS, N, ONE, WORK, N, B, LDB, ZERO,
$ WORK( NWORK ), N )
CALL SLACPY( 'A', N, NRHS, WORK( NWORK ), N, B, LDB )
*
* Unscale.
*
OPS = OPS + REAL( N + N*NRHS )
CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
CALL SLASRT( 'D', N, D, INFO )
CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO )
*
RETURN
END IF
*
* Book-keeping and setting up some constants.
*
NLVL = INT( LOG( REAL( N ) / REAL( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1
*
SMLSZP = SMLSIZ + 1
*
U = 1
VT = 1 + SMLSIZ*N
DIFL = VT + SMLSZP*N
DIFR = DIFL + NLVL*N
Z = DIFR + NLVL*N*2
C = Z + NLVL*N
S = C + N
POLES = S + N
GIVNUM = POLES + 2*NLVL*N
BX = GIVNUM + 2*NLVL*N
NWORK = BX + N*NRHS
*
SIZEI = 1 + N
K = SIZEI + N
GIVPTR = K + N
PERM = GIVPTR + N
GIVCOL = PERM + NLVL*N
IWK = GIVCOL + NLVL*N*2
*
ST = 1
SQRE = 0
ICMPQ1 = 1
ICMPQ2 = 0
NSUB = 0
*
DO 50 I = 1, N
IF( ABS( D( I ) ).LT.EPS ) THEN
D( I ) = SIGN( EPS, D( I ) )
END IF
50 CONTINUE
*
DO 60 I = 1, NM1
IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN
NSUB = NSUB + 1
IWORK( NSUB ) = ST
*
* Subproblem found. First determine its size and then
* apply divide and conquer on it.
*
IF( I.LT.NM1 ) THEN
*
* A subproblem with E(I) small for I < NM1.
*
NSIZE = I - ST + 1
IWORK( SIZEI+NSUB-1 ) = NSIZE
ELSE IF( ABS( E( I ) ).GE.EPS ) THEN
*
* A subproblem with E(NM1) not too small but I = NM1.
*
NSIZE = N - ST + 1
IWORK( SIZEI+NSUB-1 ) = NSIZE
ELSE
*
* A subproblem with E(NM1) small. This implies an
* 1-by-1 subproblem at D(N), which is not solved
* explicitly.
*
NSIZE = I - ST + 1
IWORK( SIZEI+NSUB-1 ) = NSIZE
NSUB = NSUB + 1
IWORK( NSUB ) = N
IWORK( SIZEI+NSUB-1 ) = 1
CALL SCOPY( NRHS, B( N, 1 ), LDB, WORK( BX+NM1 ), N )
END IF
ST1 = ST - 1
IF( NSIZE.EQ.1 ) THEN
*
* This is a 1-by-1 subproblem and is not solved
* explicitly.
*
CALL SCOPY( NRHS, B( ST, 1 ), LDB, WORK( BX+ST1 ), N )
ELSE IF( NSIZE.LE.SMLSIZ ) THEN
*
* This is a small subproblem and is solved by SLASDQ.
*
CALL SLASET( 'A', NSIZE, NSIZE, ZERO, ONE,
$ WORK( VT+ST1 ), N )
CALL SLASDQ( 'U', 0, NSIZE, NSIZE, 0, NRHS, D( ST ),
$ E( ST ), WORK( VT+ST1 ), N, WORK( NWORK ),
$ N, B( ST, 1 ), LDB, WORK( NWORK ), INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
CALL SLACPY( 'A', NSIZE, NRHS, B( ST, 1 ), LDB,
$ WORK( BX+ST1 ), N )
ELSE
*
* A large problem. Solve it using divide and conquer.
*
CALL SLASDA( ICMPQ1, SMLSIZ, NSIZE, SQRE, D( ST ),
$ E( ST ), WORK( U+ST1 ), N, WORK( VT+ST1 ),
$ IWORK( K+ST1 ), WORK( DIFL+ST1 ),
$ WORK( DIFR+ST1 ), WORK( Z+ST1 ),
$ WORK( POLES+ST1 ), IWORK( GIVPTR+ST1 ),
$ IWORK( GIVCOL+ST1 ), N, IWORK( PERM+ST1 ),
$ WORK( GIVNUM+ST1 ), WORK( C+ST1 ),
$ WORK( S+ST1 ), WORK( NWORK ), IWORK( IWK ),
$ INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
BXST = BX + ST1
CALL SLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, B( ST, 1 ),
$ LDB, WORK( BXST ), N, WORK( U+ST1 ), N,
$ WORK( VT+ST1 ), IWORK( K+ST1 ),
$ WORK( DIFL+ST1 ), WORK( DIFR+ST1 ),
$ WORK( Z+ST1 ), WORK( POLES+ST1 ),
$ IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N,
$ IWORK( PERM+ST1 ), WORK( GIVNUM+ST1 ),
$ WORK( C+ST1 ), WORK( S+ST1 ), WORK( NWORK ),
$ IWORK( IWK ), INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
END IF
ST = I + 1
END IF
60 CONTINUE
*
* Apply the singular values and treat the tiny ones as zero.
*
TOL = RCOND*ABS( D( ISAMAX( N, D, 1 ) ) )
*
DO 70 I = 1, N
*
* Some of the elements in D can be negative because 1-by-1
* subproblems were not solved explicitly.
*
IF( ABS( D( I ) ).LE.TOL ) THEN
CALL SLASET( 'A', 1, NRHS, ZERO, ZERO, WORK( BX+I-1 ), N )
ELSE
RANK = RANK + 1
OPS = OPS + REAL( NRHS )
CALL SLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS,
$ WORK( BX+I-1 ), N, INFO )
END IF
D( I ) = ABS( D( I ) )
70 CONTINUE
*
* Now apply back the right singular vectors.
*
ICMPQ2 = 1
DO 80 I = 1, NSUB
ST = IWORK( I )
ST1 = ST - 1
NSIZE = IWORK( SIZEI+I-1 )
BXST = BX + ST1
IF( NSIZE.EQ.1 ) THEN
CALL SCOPY( NRHS, WORK( BXST ), N, B( ST, 1 ), LDB )
ELSE IF( NSIZE.LE.SMLSIZ ) THEN
OPS = OPS + SOPBL3( 'SGEMM ', NSIZE, NRHS, NSIZE )
CALL SGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
$ WORK( VT+ST1 ), N, WORK( BXST ), N, ZERO,
$ B( ST, 1 ), LDB )
ELSE
CALL SLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, WORK( BXST ), N,
$ B( ST, 1 ), LDB, WORK( U+ST1 ), N,
$ WORK( VT+ST1 ), IWORK( K+ST1 ),
$ WORK( DIFL+ST1 ), WORK( DIFR+ST1 ),
$ WORK( Z+ST1 ), WORK( POLES+ST1 ),
$ IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N,
$ IWORK( PERM+ST1 ), WORK( GIVNUM+ST1 ),
$ WORK( C+ST1 ), WORK( S+ST1 ), WORK( NWORK ),
$ IWORK( IWK ), INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
END IF
80 CONTINUE
*
* Unscale and sort the singular values.
*
OPS = OPS + REAL( N + N*NRHS )
CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
CALL SLASRT( 'D', N, D, INFO )
CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO )
*
RETURN
*
* End of SLALSD
*
END
REAL FUNCTION SOPLA2( SUBNAM, OPTS, M, N, K, L, NB )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
CHARACTER*( * ) OPTS
INTEGER K, L, M, N, NB
* ..
*
* Purpose
* =======
*
* SOPLA2 computes an approximation of the number of floating point
* operations used by the subroutine SUBNAM with character options
* OPTS and parameters M, N, K, L, and NB.
*
* This version counts operations for the LAPACK subroutines that
* call other LAPACK routines.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* OPTS (input) CHRACTER*(*)
* A string of character options to subroutine SUBNAM.
*
* M (input) INTEGER
* The number of rows of the coefficient matrix.
*
* N (input) INTEGER
* The number of columns of the coefficient matrix.
*
* K (input) INTEGER
* A third problem dimension, if needed.
*
* L (input) INTEGER
* A fourth problem dimension, if needed.
*
* NB (input) INTEGER
* The block size. If needed, NB >= 1.
*
* Notes
* =====
*
* In the comments below, the association is given between arguments
* in the requested subroutine and local arguments. For example,
*
* xORMBR: VECT // SIDE // TRANS, M, N, K => OPTS, M, N, K
*
* means that the character string VECT // SIDE // TRANS is passed to
* the argument OPTS, and the integer parameters M, N, and K are passed
* to the arguments M, N, and K,
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL CORZ, SORD
CHARACTER C1, SIDE, UPLO, VECT
CHARACTER*2 C2
CHARACTER*3 C3
CHARACTER*6 SUB2
INTEGER IHI, ILO, ISIDE, MI, NI, NQ
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
REAL SOPLA
EXTERNAL LSAME, LSAMEN, SOPLA
* ..
* .. Executable Statements ..
*
* ---------------------------------------------------------
* Initialize SOPLA2 to 0 and do a quick return if possible.
* ---------------------------------------------------------
*
SOPLA2 = 0
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
SORD = LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' )
CORZ = LSAME( C1, 'C' ) .OR. LSAME( C1, 'Z' )
IF( M.LE.0 .OR. .NOT.( SORD .OR. CORZ ) )
$ RETURN
*
* -------------------
* Orthogonal matrices
* -------------------
*
IF( ( SORD .AND. LSAMEN( 2, C2, 'OR' ) ) .OR.
$ ( CORZ .AND. LSAMEN( 2, C2, 'UN' ) ) ) THEN
*
IF( LSAMEN( 3, C3, 'GBR' ) ) THEN
*
* -GBR: VECT, M, N, K => OPTS, M, N, K
*
VECT = OPTS( 1: 1 )
IF( LSAME( VECT, 'Q' ) ) THEN
SUB2 = SUBNAM( 1: 3 ) // 'GQR'
IF( M.GE.K ) THEN
SOPLA2 = SOPLA( SUB2, M, N, K, 0, NB )
ELSE
SOPLA2 = SOPLA( SUB2, M-1, M-1, M-1, 0, NB )
END IF
ELSE
SUB2 = SUBNAM( 1: 3 ) // 'GLQ'
IF( K.LT.N ) THEN
SOPLA2 = SOPLA( SUB2, M, N, K, 0, NB )
ELSE
SOPLA2 = SOPLA( SUB2, N-1, N-1, N-1, 0, NB )
END IF
END IF
*
ELSE IF( LSAMEN( 3, C3, 'MBR' ) ) THEN
*
* -MBR: VECT // SIDE // TRANS, M, N, K => OPTS, M, N, K
*
VECT = OPTS( 1: 1 )
SIDE = OPTS( 2: 2 )
IF( LSAME( SIDE, 'L' ) ) THEN
NQ = M
ISIDE = 0
ELSE
NQ = N
ISIDE = 1
END IF
IF( LSAME( VECT, 'Q' ) ) THEN
SUB2 = SUBNAM( 1: 3 ) // 'MQR'
IF( NQ.GE.K ) THEN
SOPLA2 = SOPLA( SUB2, M, N, K, ISIDE, NB )
ELSE IF( ISIDE.EQ.0 ) THEN
SOPLA2 = SOPLA( SUB2, M-1, N, NQ-1, ISIDE, NB )
ELSE
SOPLA2 = SOPLA( SUB2, M, N-1, NQ-1, ISIDE, NB )
END IF
ELSE
SUB2 = SUBNAM( 1: 3 ) // 'MLQ'
IF( NQ.GT.K ) THEN
SOPLA2 = SOPLA( SUB2, M, N, K, ISIDE, NB )
ELSE IF( ISIDE.EQ.0 ) THEN
SOPLA2 = SOPLA( SUB2, M-1, N, NQ-1, ISIDE, NB )
ELSE
SOPLA2 = SOPLA( SUB2, M, N-1, NQ-1, ISIDE, NB )
END IF
END IF
*
ELSE IF( LSAMEN( 3, C3, 'GHR' ) ) THEN
*
* -GHR: N, ILO, IHI => M, N, K
*
ILO = N
IHI = K
SUB2 = SUBNAM( 1: 3 ) // 'GQR'
SOPLA2 = SOPLA( SUB2, IHI-ILO, IHI-ILO, IHI-ILO, 0, NB )
*
ELSE IF( LSAMEN( 3, C3, 'MHR' ) ) THEN
*
* -MHR: SIDE // TRANS, M, N, ILO, IHI => OPTS, M, N, K, L
*
SIDE = OPTS( 1: 1 )
ILO = K
IHI = L
IF( LSAME( SIDE, 'L' ) ) THEN
MI = IHI - ILO
NI = N
ISIDE = -1
ELSE
MI = M
NI = IHI - ILO
ISIDE = 1
END IF
SUB2 = SUBNAM( 1: 3 ) // 'MQR'
SOPLA2 = SOPLA( SUB2, MI, NI, IHI-ILO, ISIDE, NB )
*
ELSE IF( LSAMEN( 3, C3, 'GTR' ) ) THEN
*
* -GTR: UPLO, N => OPTS, M
*
UPLO = OPTS( 1: 1 )
IF( LSAME( UPLO, 'U' ) ) THEN
SUB2 = SUBNAM( 1: 3 ) // 'GQL'
SOPLA2 = SOPLA( SUB2, M-1, M-1, M-1, 0, NB )
ELSE
SUB2 = SUBNAM( 1: 3 ) // 'GQR'
SOPLA2 = SOPLA( SUB2, M-1, M-1, M-1, 0, NB )
END IF
*
ELSE IF( LSAMEN( 3, C3, 'MTR' ) ) THEN
*
* -MTR: SIDE // UPLO // TRANS, M, N => OPTS, M, N
*
SIDE = OPTS( 1: 1 )
UPLO = OPTS( 2: 2 )
IF( LSAME( SIDE, 'L' ) ) THEN
MI = M - 1
NI = N
NQ = M
ISIDE = -1
ELSE
MI = M
NI = N - 1
NQ = N
ISIDE = 1
END IF
*
IF( LSAME( UPLO, 'U' ) ) THEN
SUB2 = SUBNAM( 1: 3 ) // 'MQL'
SOPLA2 = SOPLA( SUB2, MI, NI, NQ-1, ISIDE, NB )
ELSE
SUB2 = SUBNAM( 1: 3 ) // 'MQR'
SOPLA2 = SOPLA( SUB2, MI, NI, NQ-1, ISIDE, NB )
END IF
*
END IF
END IF
*
RETURN
*
* End of SOPLA2
*
END
REAL FUNCTION SOPLA( SUBNAM, M, N, KL, KU, NB )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
INTEGER KL, KU, M, N, NB
* ..
*
* Purpose
* =======
*
* SOPLA computes an approximation of the number of floating point
* operations used by the subroutine SUBNAM with the given values
* of the parameters M, N, KL, KU, and NB.
*
* This version counts operations for the LAPACK subroutines.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* M (input) INTEGER
* The number of rows of the coefficient matrix. M >= 0.
*
* N (input) INTEGER
* The number of columns of the coefficient matrix.
* For solve routine when the matrix is square,
* N is the number of right hand sides. N >= 0.
*
* KL (input) INTEGER
* The lower band width of the coefficient matrix.
* If needed, 0 <= KL <= M-1.
* For xGEQRS, KL is the number of right hand sides.
*
* KU (input) INTEGER
* The upper band width of the coefficient matrix.
* If needed, 0 <= KU <= N-1.
*
* NB (input) INTEGER
* The block size. If needed, NB >= 1.
*
* Notes
* =====
*
* In the comments below, the association is given between arguments
* in the requested subroutine and local arguments. For example,
*
* xGETRS: N, NRHS => M, N
*
* means that arguments N and NRHS in SGETRS are passed to arguments
* M and N in this procedure.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL CORZ, SORD
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 C3
INTEGER I
REAL ADDFAC, ADDS, EK, EM, EMN, EN, MULFAC, MULTS,
$ WL, WU
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* --------------------------------------------------------
* Initialize SOPLA to 0 and do a quick return if possible.
* --------------------------------------------------------
*
SOPLA = 0
MULTS = 0
ADDS = 0
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
SORD = LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' )
CORZ = LSAME( C1, 'C' ) .OR. LSAME( C1, 'Z' )
IF( M.LE.0 .OR. .NOT.( SORD .OR. CORZ ) )
$ RETURN
*
* ---------------------------------------------------------
* If the coefficient matrix is real, count each add as 1
* operation and each multiply as 1 operation.
* If the coefficient matrix is complex, count each add as 2
* operations and each multiply as 6 operations.
* ---------------------------------------------------------
*
IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN
ADDFAC = 1
MULFAC = 1
ELSE
ADDFAC = 2
MULFAC = 6
END IF
EM = M
EN = N
EK = KL
*
* ---------------------------------
* GE: GEneral rectangular matrices
* ---------------------------------
*
IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
* xGETRF: M, N => M, N
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
EMN = MIN( M, N )
ADDS = EMN*( EM*EN-( EM+EN )*( EMN+1. ) / 2.+( EMN+1. )*
$ ( 2.*EMN+1. ) / 6. )
MULTS = ADDS + EMN*( EM-( EMN+1. ) / 2. )
*
* xGETRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*EM*EM
ADDS = EN*( EM*( EM-1. ) )
*
* xGETRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 5. / 6.+EM*( 1. / 2.+EM*( 2. / 3. ) ) )
ADDS = EM*( 5. / 6.+EM*( -3. / 2.+EM*( 2. / 3. ) ) )
*
* xGEQRF or xGEQLF: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'QRF' ) .OR.
$ LSAMEN( 3, C3, 'QR2' ) .OR.
$ LSAMEN( 3, C3, 'QLF' ) .OR. LSAMEN( 3, C3, 'QL2' ) )
$ THEN
IF( M.GE.N ) THEN
MULTS = EN*( ( ( 23. / 6. )+EM+EN / 2. )+EN*
$ ( EM-EN / 3. ) )
ADDS = EN*( ( 5. / 6. )+EN*( 1. / 2.+( EM-EN / 3. ) ) )
ELSE
MULTS = EM*( ( ( 23. / 6. )+2.*EN-EM / 2. )+EM*
$ ( EN-EM / 3. ) )
ADDS = EM*( ( 5. / 6. )+EN-EM / 2.+EM*( EN-EM / 3. ) )
END IF
*
* xGERQF or xGELQF: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'RQF' ) .OR.
$ LSAMEN( 3, C3, 'RQ2' ) .OR.
$ LSAMEN( 3, C3, 'LQF' ) .OR. LSAMEN( 3, C3, 'LQ2' ) )
$ THEN
IF( M.GE.N ) THEN
MULTS = EN*( ( ( 29. / 6. )+EM+EN / 2. )+EN*
$ ( EM-EN / 3. ) )
ADDS = EN*( ( 5. / 6. )+EM+EN*
$ ( -1. / 2.+( EM-EN / 3. ) ) )
ELSE
MULTS = EM*( ( ( 29. / 6. )+2.*EN-EM / 2. )+EM*
$ ( EN-EM / 3. ) )
ADDS = EM*( ( 5. / 6. )+EM / 2.+EM*( EN-EM / 3. ) )
END IF
*
* xGEQPF: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'QPF' ) ) THEN
EMN = MIN( M, N )
MULTS = 2*EN*EN + EMN*( 3*EM+5*EN+2*EM*EN-( EMN+1 )*
$ ( 4+EN+EM-( 2*EMN+1 ) / 3 ) )
ADDS = EN*EN + EMN*( 2*EM+EN+2*EM*EN-( EMN+1 )*
$ ( 2+EN+EM-( 2*EMN+1 ) / 3 ) )
*
* xGEQRS or xGERQS: M, N, NRHS => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'QRS' ) .OR. LSAMEN( 3, C3, 'RQS' ) )
$ THEN
MULTS = EK*( EN*( 2.-EK )+EM*( 2.*EN+( EM+1. ) / 2. ) )
ADDS = EK*( EN*( 1.-EK )+EM*( 2.*EN+( EM-1. ) / 2. ) )
*
* xGELQS or xGEQLS: M, N, NRHS => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'LQS' ) .OR. LSAMEN( 3, C3, 'QLS' ) )
$ THEN
MULTS = EK*( EM*( 2.-EK )+EN*( 2.*EM+( EN+1. ) / 2. ) )
ADDS = EK*( EM*( 1.-EK )+EN*( 2.*EM+( EN-1. ) / 2. ) )
*
* xGEBRD: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'BRD' ) ) THEN
IF( M.GE.N ) THEN
MULTS = EN*( 20. / 3.+EN*( 2.+( 2.*EM-( 2. / 3. )*
$ EN ) ) )
ADDS = EN*( 5. / 3.+( EN-EM )+EN*
$ ( 2.*EM-( 2. / 3. )*EN ) )
ELSE
MULTS = EM*( 20. / 3.+EM*( 2.+( 2.*EN-( 2. / 3. )*
$ EM ) ) )
ADDS = EM*( 5. / 3.+( EM-EN )+EM*
$ ( 2.*EN-( 2. / 3. )*EM ) )
END IF
*
* xGEHRD: N => M
*
ELSE IF( LSAMEN( 3, C3, 'HRD' ) ) THEN
IF( M.EQ.1 ) THEN
MULTS = 0.
ADDS = 0.
ELSE
MULTS = -13. + EM*( -7. / 6.+EM*( 0.5+EM*( 5. / 3. ) ) )
ADDS = -8. + EM*( -2. / 3.+EM*( -1.+EM*( 5. / 3. ) ) )
END IF
*
END IF
*
* ----------------------------
* GB: General Banded matrices
* ----------------------------
* Note: The operation count is overestimated because
* it is assumed that the factor U fills in to the maximum
* extent, i.e., that its bandwidth goes from KU to KL + KU.
*
ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
*
* xGBTRF: M, N, KL, KU => M, N, KL, KU
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
DO 10 I = MIN( M, N ), 1, -1
WL = MAX( 0, MIN( KL, M-I ) )
WU = MAX( 0, MIN( KL+KU, N-I ) )
MULTS = MULTS + WL*( 1.+WU )
ADDS = ADDS + WL*WU
10 CONTINUE
*
* xGBTRS: N, NRHS, KL, KU => M, N, KL, KU
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
WL = MAX( 0, MIN( KL, M-1 ) )
WU = MAX( 0, MIN( KL+KU, M-1 ) )
MULTS = EN*( EM*( WL+1.+WU )-0.5*
$ ( WL*( WL+1. )+WU*( WU+1. ) ) )
ADDS = EN*( EM*( WL+WU )-0.5*( WL*( WL+1. )+WU*( WU+1. ) ) )
*
END IF
*
* --------------------------------------
* PO: POsitive definite matrices
* PP: Positive definite Packed matrices
* --------------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'PP' ) ) THEN
*
* xPOTRF: N => M
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = EM*( 1. / 3.+EM*( 1. / 2.+EM*( 1. / 6. ) ) )
ADDS = ( 1. / 6. )*EM*( -1.+EM*EM )
*
* xPOTRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*( EM*( EM+1. ) )
ADDS = EN*( EM*( EM-1. ) )
*
* xPOTRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 2. / 3.+EM*( 1.+EM*( 1. / 3. ) ) )
ADDS = EM*( 1. / 6.+EM*( -1. / 2.+EM*( 1. / 3. ) ) )
*
END IF
*
* ------------------------------------
* PB: Positive definite Band matrices
* ------------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN
*
* xPBTRF: N, K => M, KL
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = EK*( -2. / 3.+EK*( -1.+EK*( -1. / 3. ) ) ) +
$ EM*( 1.+EK*( 3. / 2.+EK*( 1. / 2. ) ) )
ADDS = EK*( -1. / 6.+EK*( -1. / 2.+EK*( -1. / 3. ) ) ) +
$ EM*( EK / 2.*( 1.+EK ) )
*
* xPBTRS: N, NRHS, K => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*( ( 2*EM-EK )*( EK+1. ) )
ADDS = EN*( EK*( 2*EM-( EK+1. ) ) )
*
END IF
*
* ----------------------------------
* PT: Positive definite Tridiagonal
* ----------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'PT' ) ) THEN
*
* xPTTRF: N => M
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = 2*( EM-1 )
ADDS = EM - 1
*
* xPTTRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*( 3*EM-2 )
ADDS = EN*( 2*( EM-1 ) )
*
* xPTSV: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
MULTS = 2*( EM-1 ) + EN*( 3*EM-2 )
ADDS = EM - 1 + EN*( 2*( EM-1 ) )
END IF
*
* --------------------------------------------------------
* SY: SYmmetric indefinite matrices
* SP: Symmetric indefinite Packed matrices
* HE: HErmitian indefinite matrices (complex only)
* HP: Hermitian indefinite Packed matrices (complex only)
* --------------------------------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHP' ) ) THEN
*
* xSYTRF: N => M
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = EM*( 10. / 3.+EM*( 1. / 2.+EM*( 1. / 6. ) ) )
ADDS = EM / 6.*( -1.+EM*EM )
*
* xSYTRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*EM*EM
ADDS = EN*( EM*( EM-1. ) )
*
* xSYTRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 2. / 3.+EM*EM*( 1. / 3. ) )
ADDS = EM*( -1. / 3.+EM*EM*( 1. / 3. ) )
*
* xSYTRD, xSYTD2: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRD' ) .OR. LSAMEN( 3, C3, 'TD2' ) )
$ THEN
IF( M.EQ.1 ) THEN
MULTS = 0.
ADDS = 0.
ELSE
MULTS = -15. + EM*( -1. / 6.+EM*
$ ( 5. / 2.+EM*( 2. / 3. ) ) )
ADDS = -4. + EM*( -8. / 3.+EM*( 1.+EM*( 2. / 3. ) ) )
END IF
END IF
*
* -------------------
* Triangular matrices
* -------------------
*
ELSE IF( LSAMEN( 2, C2, 'TR' ) .OR. LSAMEN( 2, C2, 'TP' ) ) THEN
*
* xTRTRS: N, NRHS => M, N
*
IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*EM*( EM+1. ) / 2.
ADDS = EN*EM*( EM-1. ) / 2.
*
* xTRTRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 1. / 3.+EM*( 1. / 2.+EM*( 1. / 6. ) ) )
ADDS = EM*( 1. / 3.+EM*( -1. / 2.+EM*( 1. / 6. ) ) )
*
END IF
*
ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
*
* xTBTRS: N, NRHS, K => M, N, KL
*
IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*( EM*( EM+1. ) / 2.-( EM-EK-1. )*( EM-EK ) / 2. )
ADDS = EN*( EM*( EM-1. ) / 2.-( EM-EK-1. )*( EM-EK ) / 2. )
END IF
*
* --------------------
* Trapezoidal matrices
* --------------------
*
ELSE IF( LSAMEN( 2, C2, 'TZ' ) ) THEN
*
* xTZRQF: M, N => M, N
*
IF( LSAMEN( 3, C3, 'RQF' ) ) THEN
EMN = MIN( M, N )
MULTS = 3*EM*( EN-EM+1 ) + ( 2*EN-2*EM+3 )*
$ ( EM*EM-EMN*( EMN+1 ) / 2 )
ADDS = ( EN-EM+1 )*( EM+2*EM*EM-EMN*( EMN+1 ) )
END IF
*
* -------------------
* Orthogonal matrices
* -------------------
*
ELSE IF( ( SORD .AND. LSAMEN( 2, C2, 'OR' ) ) .OR.
$ ( CORZ .AND. LSAMEN( 2, C2, 'UN' ) ) ) THEN
*
* -MQR, -MLQ, -MQL, or -MRQ: M, N, K, SIDE => M, N, KL, KU
* where KU<= 0 indicates SIDE = 'L'
* and KU> 0 indicates SIDE = 'R'
*
IF( LSAMEN( 3, C3, 'MQR' ) .OR. LSAMEN( 3, C3, 'MLQ' ) .OR.
$ LSAMEN( 3, C3, 'MQL' ) .OR. LSAMEN( 3, C3, 'MRQ' ) ) THEN
IF( KU.LE.0 ) THEN
MULTS = EK*EN*( 2.*EM+2.-EK )
ADDS = EK*EN*( 2.*EM+1.-EK )
ELSE
MULTS = EK*( EM*( 2.*EN-EK )+( EM+EN+( 1.-EK ) / 2. ) )
ADDS = EK*EM*( 2.*EN+1.-EK )
END IF
*
* -GQR or -GQL: M, N, K => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'GQR' ) .OR. LSAMEN( 3, C3, 'GQL' ) )
$ THEN
MULTS = EK*( -5. / 3.+( 2.*EN-EK )+
$ ( 2.*EM*EN+EK*( ( 2. / 3. )*EK-EM-EN ) ) )
ADDS = EK*( 1. / 3.+( EN-EM )+
$ ( 2.*EM*EN+EK*( ( 2. / 3. )*EK-EM-EN ) ) )
*
* -GLQ or -GRQ: M, N, K => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'GLQ' ) .OR. LSAMEN( 3, C3, 'GRQ' ) )
$ THEN
MULTS = EK*( -2. / 3.+( EM+EN-EK )+
$ ( 2.*EM*EN+EK*( ( 2. / 3. )*EK-EM-EN ) ) )
ADDS = EK*( 1. / 3.+( EM-EN )+
$ ( 2.*EM*EN+EK*( ( 2. / 3. )*EK-EM-EN ) ) )
*
END IF
*
END IF
*
SOPLA = MULFAC*MULTS + ADDFAC*ADDS
*
RETURN
*
* End of SOPLA
*
END
REAL FUNCTION SOPBL2( SUBNAM, M, N, KKL, KKU )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
INTEGER KKL, KKU, M, N
* ..
*
* Purpose
* =======
*
* SOPBL2 computes an approximation of the number of floating point
* operations used by a subroutine SUBNAM with the given values
* of the parameters M, N, KL, and KU.
*
* This version counts operations for the Level 2 BLAS.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* M (input) INTEGER
* The number of rows of the coefficient matrix. M >= 0.
*
* N (input) INTEGER
* The number of columns of the coefficient matrix.
* If the matrix is square (such as in a solve routine) then
* N is the number of right hand sides. N >= 0.
*
* KKL (input) INTEGER
* The lower band width of the coefficient matrix.
* KL is set to max( 0, min( M-1, KKL ) ).
*
* KKU (input) INTEGER
* The upper band width of the coefficient matrix.
* KU is set to max( 0, min( N-1, KKU ) ).
*
* =====================================================================
*
* .. Local Scalars ..
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 C3
REAL ADDS, EK, EM, EN, KL, KU, MULTS
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR.
$ .NOT.( LSAME( SUBNAM, 'S' ) .OR. LSAME( SUBNAM, 'D' ) .OR.
$ LSAME( SUBNAM, 'C' ) .OR. LSAME( SUBNAM, 'Z' ) ) ) THEN
SOPBL2 = 0
RETURN
END IF
*
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
MULTS = 0
ADDS = 0
KL = MAX( 0, MIN( M-1, KKL ) )
KU = MAX( 0, MIN( N-1, KKU ) )
EM = M
EN = N
EK = KL
*
* -------------------------------
* Matrix-vector multiply routines
* -------------------------------
*
IF( LSAMEN( 3, C3, 'MV ' ) ) THEN
*
IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
MULTS = EM*( EN+1. )
ADDS = EM*EN
*
* Assume M <= N + KL and KL < M
* N <= M + KU and KU < N
* so that the zero sections are triangles.
*
ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
*
MULTS = EM*( EN+1. ) - ( EM-1.-KL )*( EM-KL ) / 2. -
$ ( EN-1.-KU )*( EN-KU ) / 2.
ADDS = EM*( EN+1. ) - ( EM-1.-KL )*( EM-KL ) / 2. -
$ ( EN-1.-KU )*( EN-KU ) / 2.
*
ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHP' ) ) THEN
*
MULTS = EM*( EM+1. )
ADDS = EM*EM
*
ELSE IF( LSAMEN( 2, C2, 'SB' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHB' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHB' ) ) THEN
*
MULTS = EM*( EM+1. ) - ( EM-1.-EK )*( EM-EK )
ADDS = EM*EM - ( EM-1.-EK )*( EM-EK )
*
ELSE IF( LSAMEN( 2, C2, 'TR' ) .OR. LSAMEN( 2, C2, 'TP' ) )
$ THEN
*
MULTS = EM*( EM+1. ) / 2.
ADDS = ( EM-1. )*EM / 2.
*
ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
*
MULTS = EM*( EM+1. ) / 2. - ( EM-EK-1. )*( EM-EK ) / 2.
ADDS = ( EM-1. )*EM / 2. - ( EM-EK-1. )*( EM-EK ) / 2.
*
END IF
*
* ---------------------
* Matrix solve routines
* ---------------------
*
ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
*
IF( LSAMEN( 2, C2, 'TR' ) .OR. LSAMEN( 2, C2, 'TP' ) ) THEN
*
MULTS = EM*( EM+1. ) / 2.
ADDS = ( EM-1. )*EM / 2.
*
ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
*
MULTS = EM*( EM+1. ) / 2. - ( EM-EK-1. )*( EM-EK ) / 2.
ADDS = ( EM-1. )*EM / 2. - ( EM-EK-1. )*( EM-EK ) / 2.
*
END IF
*
* ----------------
* Rank-one updates
* ----------------
*
ELSE IF( LSAMEN( 3, C3, 'R ' ) ) THEN
*
IF( LSAMEN( 3, SUBNAM, 'SGE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'DGE' ) ) THEN
*
MULTS = EM*EN + MIN( EM, EN )
ADDS = EM*EN
*
ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHP' ) ) THEN
*
MULTS = EM*( EM+1. ) / 2. + EM
ADDS = EM*( EM+1. ) / 2.
*
END IF
*
ELSE IF( LSAMEN( 3, C3, 'RC ' ) .OR. LSAMEN( 3, C3, 'RU ' ) ) THEN
*
IF( LSAMEN( 3, SUBNAM, 'CGE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZGE' ) ) THEN
*
MULTS = EM*EN + MIN( EM, EN )
ADDS = EM*EN
*
END IF
*
* ----------------
* Rank-two updates
* ----------------
*
ELSE IF( LSAMEN( 3, C3, 'R2 ' ) ) THEN
IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHP' ) ) THEN
*
MULTS = EM*( EM+1. ) + 2.*EM
ADDS = EM*( EM+1. )
*
END IF
END IF
*
* ------------------------------------------------
* Compute the total number of operations.
* For real and double precision routines, count
* 1 for each multiply and 1 for each add.
* For complex and complex*16 routines, count
* 6 for each multiply and 2 for each add.
* ------------------------------------------------
*
IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN
*
SOPBL2 = MULTS + ADDS
*
ELSE
*
SOPBL2 = 6*MULTS + 2*ADDS
*
END IF
*
RETURN
*
* End of SOPBL2
*
END
REAL FUNCTION SOPBL3( SUBNAM, M, N, K )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
INTEGER K, M, N
* ..
*
* Purpose
* =======
*
* SOPBL3 computes an approximation of the number of floating point
* operations used by a subroutine SUBNAM with the given values
* of the parameters M, N, and K.
*
* This version counts operations for the Level 3 BLAS.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* M (input) INTEGER
* N (input) INTEGER
* K (input) INTEGER
* M, N, and K contain parameter values used by the Level 3
* BLAS. The output matrix is always M x N or N x N if
* symmetric, but K has different uses in different
* contexts. For example, in the matrix-matrix multiply
* routine, we have
* C = A * B
* where C is M x N, A is M x K, and B is K x N.
* In xSYMM, xTRMM, and xTRSM, K indicates whether the matrix
* A is applied on the left or right. If K <= 0, the matrix
* is applied on the left, if K > 0, on the right.
*
* =====================================================================
*
* .. Local Scalars ..
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 C3
REAL ADDS, EK, EM, EN, MULTS
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR.
$ .NOT.( LSAME( SUBNAM, 'S' ) .OR. LSAME( SUBNAM, 'D' ) .OR.
$ LSAME( SUBNAM, 'C' ) .OR. LSAME( SUBNAM, 'Z' ) ) ) THEN
SOPBL3 = 0
RETURN
END IF
*
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
MULTS = 0
ADDS = 0
EM = M
EN = N
EK = K
*
* ----------------------
* Matrix-matrix products
* assume beta = 1
* ----------------------
*
IF( LSAMEN( 3, C3, 'MM ' ) ) THEN
*
IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
MULTS = EM*EK*EN
ADDS = EM*EK*EN
*
ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) ) THEN
*
* IF K <= 0, assume A multiplies B on the left.
*
IF( K.LE.0 ) THEN
MULTS = EM*EM*EN
ADDS = EM*EM*EN
ELSE
MULTS = EM*EN*EN
ADDS = EM*EN*EN
END IF
*
ELSE IF( LSAMEN( 2, C2, 'TR' ) ) THEN
*
IF( K.LE.0 ) THEN
MULTS = EN*EM*( EM+1. ) / 2.
ADDS = EN*EM*( EM-1. ) / 2.
ELSE
MULTS = EM*EN*( EN+1. ) / 2.
ADDS = EM*EN*( EN-1. ) / 2.
END IF
*
END IF
*
* ------------------------------------------------
* Rank-K update of a symmetric or Hermitian matrix
* ------------------------------------------------
*
ELSE IF( LSAMEN( 3, C3, 'RK ' ) ) THEN
*
IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) ) THEN
*
MULTS = EK*EM*( EM+1. ) / 2.
ADDS = EK*EM*( EM+1. ) / 2.
END IF
*
* ------------------------------------------------
* Rank-2K update of a symmetric or Hermitian matrix
* ------------------------------------------------
*
ELSE IF( LSAMEN( 3, C3, 'R2K' ) ) THEN
*
IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) ) THEN
*
MULTS = EK*EM*EM
ADDS = EK*EM*EM + EM
END IF
*
* -----------------------------------------
* Solving system with many right hand sides
* -----------------------------------------
*
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'TRSM ' ) ) THEN
*
IF( K.LE.0 ) THEN
MULTS = EN*EM*( EM+1. ) / 2.
ADDS = EN*EM*( EM-1. ) / 2.
ELSE
MULTS = EM*EN*( EN+1. ) / 2.
ADDS = EM*EN*( EN-1. ) / 2.
END IF
*
END IF
*
* ------------------------------------------------
* Compute the total number of operations.
* For real and double precision routines, count
* 1 for each multiply and 1 for each add.
* For complex and complex*16 routines, count
* 6 for each multiply and 2 for each add.
* ------------------------------------------------
*
IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN
*
SOPBL3 = MULTS + ADDS
*
ELSE
*
SOPBL3 = 6*MULTS + 2*ADDS
*
END IF
*
RETURN
*
* End of SOPBL3
*
END
INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3,
$ N4 )
*
* -- LAPACK auxiliary routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER*( * ) NAME, OPTS
INTEGER ISPEC, N1, N2, N3, N4
* ..
*
* Purpose
* =======
*
* ILAENV returns problem-dependent parameters for the local
* environment. See ISPEC for a description of the parameters.
*
* In this version, the problem-dependent parameters are contained in
* the integer array IPARMS in the common block CLAENV and the value
* with index ISPEC is copied to ILAENV. This version of ILAENV is
* to be used in conjunction with XLAENV in TESTING and TIMING.
*
* 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
* = 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 and QZ methods
* for nonsymmetric eigenvalue problems.
* = 9: maximum size of the subproblems at the bottom of the
* computation tree in the divide-and-conquer algorithm
* =10: ieee NaN arithmetic can be trusted not to trap
* =11: infinity arithmetic can be trusted not to trap
*
* Other specifications (up to 100) can be added later.
*
* NAME (input) CHARACTER*(*)
* The name of the calling subroutine.
*
* 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.
*
* (ILAENV) (output) INTEGER
* >= 0: the value of the parameter specified by ISPEC
* < 0: if ILAENV = -k, the k-th argument had an illegal value.
*
* 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 )
*
* =====================================================================
*
* .. Intrinsic Functions ..
INTRINSIC INT, MIN, REAL
* ..
* .. External Functions ..
INTEGER IEEECK
EXTERNAL IEEECK
* ..
* .. Arrays in Common ..
INTEGER IPARMS( 100 )
* ..
* .. Common blocks ..
COMMON / CLAENV / IPARMS
* ..
* .. Save statement ..
SAVE / CLAENV /
* ..
* .. Executable Statements ..
*
IF( ISPEC.GE.1 .AND. ISPEC.LE.5 ) THEN
*
* Return a value from the common block.
*
ILAENV = IPARMS( ISPEC )
*
ELSE IF( ISPEC.EQ.6 ) THEN
*
* Compute SVD crossover point.
*
ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 )
*
ELSE IF( ISPEC.GE.7 .AND. ISPEC.LE.9 ) THEN
*
* Return a value from the common block.
*
ILAENV = IPARMS( ISPEC )
*
ELSE IF( ISPEC.EQ.10 ) THEN
*
* IEEE NaN arithmetic can be trusted not to trap
*
ILAENV = 1
IF( ILAENV.EQ.1 ) THEN
ILAENV = IEEECK( 0, 0.0, 1.0 )
END IF
*
ELSE IF( ISPEC.EQ.11 ) THEN
*
* Infinity arithmetic can be trusted not to trap
*
ILAENV = 1
IF( ILAENV.EQ.1 ) THEN
ILAENV = IEEECK( 1, 0.0, 1.0 )
END IF
*
ELSE
*
* Invalid value for ISPEC
*
ILAENV = -1
END IF
*
RETURN
*
* End of ILAENV
*
END
SUBROUTINE XLAENV( ISPEC, NVALUE )
*
* -- LAPACK auxiliary routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER ISPEC, NVALUE
* ..
*
* Purpose
* =======
*
* XLAENV sets certain machine- and problem-dependent quantities
* which will later be retrieved by ILAENV.
*
* Arguments
* =========
*
* ISPEC (input) INTEGER
* Specifies the parameter to be set in the COMMON array IPARMS.
* = 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
* = 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: another crossover point, for the multishift QR and QZ
* methods for nonsymmetric eigenvalue problems.
* = 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
*
* NVALUE (input) INTEGER
* The value of the parameter specified by ISPEC.
*
* =====================================================================
*
* .. Arrays in Common ..
INTEGER IPARMS( 100 )
* ..
* .. Common blocks ..
COMMON / CLAENV / IPARMS
* ..
* .. Save statement ..
SAVE / CLAENV /
* ..
* .. Executable Statements ..
*
IF( ISPEC.GE.1 .AND. ISPEC.LE.9 ) THEN
IPARMS( ISPEC ) = NVALUE
END IF
*
RETURN
*
* End of XLAENV
*
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/slin/lsamen.f 0000644 0001750 0001750 00000003756 10616163244 023437 0 ustar osallou osallou LOGICAL FUNCTION LSAMEN( N, CA, CB )
*
* -- LAPACK auxiliary routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* Commented out arg check for java translation. This is a hack
* to get the timers running since the LEN() intrinsic doesn't
* work correctly in f2j'd code. 6/21/01 Keith
*
* .. Scalar Arguments ..
CHARACTER*( * ) CA, CB
INTEGER N
* ..
*
* Purpose
* =======
*
* LSAMEN tests if the first N letters of CA are the same as the
* first N letters of CB, regardless of case.
* LSAMEN returns .TRUE. if CA and CB are equivalent except for case
* and .FALSE. otherwise. LSAMEN also returns .FALSE. if LEN( CA )
* or LEN( CB ) is less than N.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of characters in CA and CB to be compared.
*
* CA (input) CHARACTER*(*)
* CB (input) CHARACTER*(*)
* CA and CB specify two character strings of length at least N.
* Only the first N characters of each string will be accessed.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC LEN
* ..
* .. Executable Statements ..
*
LSAMEN = .FALSE.
*
* Commented out arg check for java translation. --Keith
*
* IF( LEN( CA ).LT.N .OR. LEN( CB ).LT.N )
* $ GO TO 20
*
N = MIN( LEN(CA), LEN(CB) )
*
* Do for each character in the two strings.
*
DO 10 I = 1, N
*
* Test if the characters are equal using LSAME.
*
IF( .NOT.LSAME( CA( I: I ), CB( I: I ) ) )
$ GO TO 20
*
10 CONTINUE
LSAMEN = .TRUE.
*
20 CONTINUE
RETURN
*
* End of LSAMEN
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/slin/sblasc.in 0000644 0001750 0001750 00000001144 10616163245 023576 0 ustar osallou osallou BLAS timing, REAL data, N small
5 Number of values of M
10 20 40 60 80 Values of M
2 Number of values of N
2 16 Values of N
5 Number of values of K
10 20 40 60 80 Values of K
1 Number of values of INCX
1 Values of INCX
1 Number of values of LDA
81 Values of LDA
0.05 Minimum time in seconds
none Do not time the sample BLAS
SGEMM
SSYMM
STRMM
STRSM
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/slin/Makefile 0000644 0001750 0001750 00000003072 10616442122 023433 0 ustar osallou osallou .PHONY: DUMMY util
.SUFFIXES: .f .java
ROOT=../../..
include $(ROOT)/make.def
BLAS=$(ROOT)/$(BLAS_IDX)
LAPACK=$(ROOT)/$(LAPACK_IDX)
SMATGEN=$(ROOT)/$(SMATGEN_IDX)
XERBLAFLAGS= -c .:$(ROOT)/$(BLAS_OBJ) -p $(ERR_PACKAGE)
F2JFLAGS=-c .:$(OUTDIR):linsrc/$(OUTDIR):$(ROOT)/$(BLAS_OBJ):$(ROOT)/$(ERR_OBJ):$(ROOT)/$(LAPACK_OBJ):$(ROOT)/$(SMATGEN_OBJ) -p $(SLINTIME_PACKAGE) -o $(OUTDIR)
TIMER_CLASSPATH=-cp .:./obj:$(ROOT)/$(ERR_OBJ):linsrc/$(OUTDIR):$(ROOT)/$(SMATGEN_OBJ):$(ROOT)/$(BLAS_OBJ):$(ROOT)/$(LAPACK_OBJ):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
timer: $(BLAS) $(LAPACK) $(SMATGEN) linsrc/$(OUTDIR)/Slinsrc.f2j $(OUTDIR)/Slintime.f2j util
/bin/rm -f $(SLINTIME_JAR)
cd linsrc/$(OUTDIR); $(JAR) cvf ../../$(SLINTIME_JAR) `find . -name "*.class"`
cd $(OUTDIR); $(JAR) uvf ../$(SLINTIME_JAR) `find . -name "*.class"`
linsrc/$(OUTDIR)/Slinsrc.f2j: linsrc/slinsrc.f
cd linsrc;$(MAKE)
$(OUTDIR)/Slintime.f2j: $(OUTDIR)/Lsamen.f2j slintime.f
$(F2J) $(F2JFLAGS) slintime.f > /dev/null
$(OUTDIR)/Lsamen.f2j: lsamen.f
$(F2J) $(F2JFLAGS) $< > /dev/null
$(BLAS):
cd $(ROOT)/$(BLAS_DIR); $(MAKE)
$(LAPACK):
cd $(ROOT)/$(LAPACK_DIR); $(MAKE)
$(SMATGEN):
cd $(ROOT)/$(SMATGEN_DIR); $(MAKE)
util:
cd $(ROOT)/$(UTIL_DIR); $(MAKE)
runtimer: small
small: timer s*.in
large: timer input_files_large/S*.in
*.in: DUMMY
java $(MORE_MEM_FLAG) $(TIMER_CLASSPATH) $(SLINTIME_PACKAGE).Stimaa < $@
input_files_large/*.in: DUMMY
java $(MORE_MEM_FLAG) $(TIMER_CLASSPATH) $(SLINTIME_PACKAGE).Stimaa < $@
clean:
cd linsrc;$(MAKE) clean
/bin/rm -rf *.java *.class *.f2j $(OUTDIR) $(SLINTIME_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/slin/slintime.f 0000644 0001750 0001750 00001747534 10616163245 024017 0 ustar osallou osallou SUBROUTINE ATIMCK( ICHK, SUBNAM, NN, NVAL, NLDA, LDAVAL, NOUT,
$ INFO )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
INTEGER ICHK, INFO, NLDA, NN, NOUT
* ..
* .. Array Arguments ..
INTEGER LDAVAL( * ), NVAL( * )
* ..
*
* Purpose
* =======
*
* ATIMCK checks the input values of M, N, or K and LDA to determine
* if they are valid for type TYPE. The tests to be performed are
* specified in the option variable ICHK.
*
* On exit, INFO contains a count of the number of pairs (N,LDA) that
* were invalid.
*
* Arguments
* =========
*
* ICHK (input) INTEGER
* Specifies the type of comparison
* = 1: M <= LDA
* = 2: N <= LDA
* = 3: K <= LDA
* = 4: N*(N+1)/2 <= LA
* = 0 or other value: Determined from name passed in SUBNAM
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine or path for which the input
* values are to be tested.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension( NN )
* The values of the matrix size N.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension( NLDA )
* The values of the leading dimension of the array A.
*
* NOUT (input) INTEGER
* The unit number for output.
*
* INFO (output) INTEGER
* The number of pairs (N, LDA) that were invalid.
*
* =====================================================================
*
* .. Local Scalars ..
CHARACTER*2 TYPE
INTEGER I, J, LDA, N
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. Executable Statements ..
*
TYPE = SUBNAM( 2: 3 )
INFO = 0
*
* M, N, or K must be less than or equal to LDA.
*
IF( ICHK.EQ.1 .OR. ICHK.EQ.2 .OR. ICHK.EQ.3 ) THEN
DO 20 J = 1, NLDA
LDA = LDAVAL( J )
DO 10 I = 1, NN
IF( NVAL( I ).GT.LDA ) THEN
INFO = INFO + 1
IF( NOUT.GT.0 ) THEN
IF( ICHK.EQ.1 ) THEN
WRITE( NOUT, FMT = 9999 )SUBNAM, NVAL( I ), LDA
ELSE IF( ICHK.EQ.2 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM, NVAL( I ), LDA
ELSE
WRITE( NOUT, FMT = 9997 )SUBNAM, NVAL( I ), LDA
END IF
END IF
END IF
10 CONTINUE
20 CONTINUE
*
* IF TYPE = 'PP', 'SP', or 'HP',
* then N*(N+1)/2 must be less than or equal to LA = LDAVAL(1).
*
ELSE IF( ICHK.EQ.4 ) THEN
LDA = LDAVAL( 1 )
DO 30 I = 1, NN
N = NVAL( I )
IF( N*( N+1 ) / 2.GT.LDA ) THEN
INFO = INFO + 1
IF( NOUT.GT.0 )
$ WRITE( NOUT, FMT = 9996 )SUBNAM, N, LDA
END IF
30 CONTINUE
*
* IF TYPE = 'GB', then K must satisfy
* 2*K+1 <= LDA, if SUBNAM = 'xGBMV'
* 3*K+1 <= LDA, otherwise.
*
ELSE IF( LSAMEN( 2, TYPE, 'GB' ) ) THEN
IF( LSAMEN( 3, SUBNAM( 4: 6 ), 'MV ' ) ) THEN
DO 50 J = 1, NLDA
LDA = LDAVAL( J )
DO 40 I = 1, NN
IF( 2*NVAL( I )+1.GT.LDA ) THEN
INFO = INFO + 1
IF( NOUT.GT.0 )
$ WRITE( NOUT, FMT = 9994 )SUBNAM, NVAL( I ),
$ LDA, 2*NVAL( I ) + 1
END IF
40 CONTINUE
50 CONTINUE
ELSE
DO 70 J = 1, NLDA
LDA = LDAVAL( J )
DO 60 I = 1, NN
IF( 3*NVAL( I )+1.GT.LDA ) THEN
INFO = INFO + 1
IF( NOUT.GT.0 )
$ WRITE( NOUT, FMT = 9995 )SUBNAM, NVAL( I ),
$ LDA, 3*NVAL( I ) + 1
END IF
60 CONTINUE
70 CONTINUE
END IF
*
* IF TYPE = 'PB' or 'TB', then K must satisfy
* K+1 <= LDA.
*
ELSE IF( LSAMEN( 2, TYPE, 'PB' ) .OR. LSAMEN( 2, TYPE, 'TB' ) )
$ THEN
DO 90 J = 1, NLDA
LDA = LDAVAL( J )
DO 80 I = 1, NN
IF( NVAL( I )+1.GT.LDA ) THEN
INFO = INFO + 1
IF( NOUT.GT.0 )
$ WRITE( NOUT, FMT = 9993 )SUBNAM, NVAL( I ), LDA
END IF
80 CONTINUE
90 CONTINUE
*
* IF TYPE = 'SB' or 'HB', then K must satisfy
* K+1 <= LDA, if SUBNAM = 'xxxMV '
*
ELSE IF( LSAMEN( 2, TYPE, 'SB' ) .OR. LSAMEN( 2, TYPE, 'HB' ) )
$ THEN
IF( LSAMEN( 3, SUBNAM( 4: 6 ), 'MV ' ) ) THEN
DO 110 J = 1, NLDA
LDA = LDAVAL( J )
DO 100 I = 1, NN
IF( NVAL( I )+1.GT.LDA ) THEN
INFO = INFO + 1
IF( NOUT.GT.0 )
$ WRITE( NOUT, FMT = 9992 )SUBNAM, NVAL( I ), LDA
END IF
100 CONTINUE
110 CONTINUE
END IF
*
END IF
9999 FORMAT( ' *** Error for ', A6, ': M > LDA for M =', I6,
$ ', LDA =', I7 )
9998 FORMAT( ' *** Error for ', A6, ': N > LDA for N =', I6,
$ ', LDA =', I7 )
9997 FORMAT( ' *** Error for ', A6, ': K > LDA for K =', I6,
$ ', LDA =', I7 )
9996 FORMAT( ' *** Error for ', A6, ': N*(N+1)/2 > LA for N =', I6,
$ ', LA =', I7 )
9995 FORMAT( ' *** Error for ', A6, ': 3*K+1 > LDA for K =', I6,
$ ', LDA =', I7, / ' --> Increase LDA to at least ', I7 )
9994 FORMAT( ' *** Error for ', A6, ': 2*K+1 > LDA for K =', I6,
$ ', LDA =', I7, / ' --> Increase LDA to at least ', I7 )
9993 FORMAT( ' *** Error for ', A6, ': K+1 > LDA for K =', I6, ', LD',
$ 'A =', I7 )
9992 FORMAT( ' *** Error for ', A6, ': 2*K+2 > LDA for K =', I6, ', ',
$ 'LDA =', I7 )
*
RETURN
*
* End of ATIMCK
*
END
SUBROUTINE ATIMIN( PATH, LINE, NSUBS, NAMES, TIMSUB, NOUT, INFO )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
CHARACTER*( * ) PATH
INTEGER INFO, NOUT, NSUBS
* ..
* .. Array Arguments ..
LOGICAL TIMSUB( * )
CHARACTER*( * ) NAMES( * )
* ..
*
* Purpose
* =======
*
* ATIMIN interprets the input line for the timing routines.
* The LOGICAL array TIMSUB returns .true. for each routine to be
* timed and .false. for the routines which are not to be timed.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*(*)
* The LAPACK path name of the calling routine. The path name
* may be at most 6 characters long. If LINE(1:LEN(PATH)) is
* the same as PATH, then the input line is searched for NSUBS
* non-blank characters, otherwise, the input line is assumed to
* specify a single subroutine name.
*
* LINE (input) CHARACTER*80
* The input line to be evaluated. The path or subroutine name
* must begin in column 1 and the part of the line after the
* name is used to indicate the routines to be timed.
* See below for further details.
*
* NSUBS (input) INTEGER
* The number of subroutines in the LAPACK path name of the
* calling routine.
*
* NAMES (input) CHARACTER*(*) array, dimension (NSUBS)
* The names of the subroutines in the LAPACK path name of the
* calling routine.
*
* TIMSUB (output) LOGICAL array, dimension (NSUBS)
* For each I from 1 to NSUBS, TIMSUB( I ) is set to .true. if
* the subroutine NAMES( I ) is to be timed; otherwise,
* TIMSUB( I ) is set to .false.
*
* NOUT (input) INTEGER
* The unit number on which error messages will be printed.
*
* INFO (output) INTEGER
* The return status of this routine.
* = -1: Unrecognized path or subroutine name
* = 0: Normal return
* = 1: Name was recognized, but no timing requested
*
* Further Details
* ======= =======
*
* An input line begins with a subroutine or path name, optionally
* followed by one or more non-blank characters indicating the specific
* routines to be timed.
*
* If the character string in PATH appears at the beginning of LINE,
* up to NSUBS routines may be timed. If LINE is blank after the path
* name, all the routines in the path will be timed. If LINE is not
* blank after the path name, the rest of the line is searched
* for NSUBS nonblank characters, and if the i-th such character is
* 't' or 'T', then the i-th subroutine in this path will be timed.
* For example, the input line
* SGE T T T T
* requests timing of the first 4 subroutines in the SGE path.
*
* If the character string in PATH does not appear at the beginning of
* LINE, then LINE is assumed to begin with a subroutine name. The name
* is assumed to end in column 6 or in column i if column i+1 is blank
* and i+1 <= 6. If LINE is completely blank after the subroutine name,
* the routine will be timed. If LINE is not blank after the subroutine
* name, then the subroutine will be timed if the first non-blank after
* the name is 't' or 'T'.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL REQ
CHARACTER*6 CNAME
INTEGER I, ISTART, ISTOP, ISUB, LCNAME, LNAMES, LPATH
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Intrinsic Functions ..
INTRINSIC LEN, MIN
* ..
* .. Executable Statements ..
*
*
* Initialize
*
INFO = 0
LCNAME = 1
DO 10 I = 2, 6
IF( LINE( I: I ).EQ.' ' )
$ GO TO 20
LCNAME = I
10 CONTINUE
20 CONTINUE
LPATH = MIN( LCNAME+1, LEN( PATH ) )
LNAMES = MIN( LCNAME+1, LEN( NAMES( 1 ) ) )
CNAME = LINE( 1: LCNAME )
*
DO 30 I = 1, NSUBS
TIMSUB( I ) = .FALSE.
30 CONTINUE
ISTOP = 0
*
* Check for a valid path or subroutine name.
*
IF( LCNAME.LE.LEN( PATH ) .AND. LSAMEN( LPATH, CNAME, PATH ) )
$ THEN
ISTART = 1
ISTOP = NSUBS
ELSE IF( LCNAME.LE.LEN( NAMES( 1 ) ) ) THEN
DO 40 I = 1, NSUBS
IF( LSAMEN( LNAMES, CNAME, NAMES( I ) ) ) THEN
ISTART = I
ISTOP = I
END IF
40 CONTINUE
END IF
*
IF( ISTOP.EQ.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
9999 FORMAT( 1X, A, ': Unrecognized path or subroutine name', / )
INFO = -1
GO TO 110
END IF
*
* Search the rest of the input line for 1 or NSUBS nonblank
* characters, where 'T' or 't' means 'Time this routine'.
*
ISUB = ISTART
DO 50 I = LCNAME + 1, 80
IF( LINE( I: I ).NE.' ' ) THEN
TIMSUB( ISUB ) = LSAME( LINE( I: I ), 'T' )
ISUB = ISUB + 1
IF( ISUB.GT.ISTOP )
$ GO TO 60
END IF
50 CONTINUE
60 CONTINUE
*
* If no characters appear after the routine or path name, then
* time the routine or all the routines in the path.
*
IF( ISUB.EQ.ISTART ) THEN
DO 70 I = ISTART, ISTOP
TIMSUB( I ) = .TRUE.
70 CONTINUE
ELSE
*
* Test to see if any timing was requested.
*
REQ = .FALSE.
DO 80 I = ISTART, ISUB - 1
REQ = REQ .OR. TIMSUB( I )
80 CONTINUE
IF( .NOT.REQ ) THEN
WRITE( NOUT, FMT = 9998 )CNAME
9998 FORMAT( 1X, A, ' was not timed', / )
INFO = 1
GO TO 110
END IF
90 CONTINUE
*
* If fewer than NSUBS characters are specified for a path name,
* the rest are assumed to be 'F'.
*
DO 100 I = ISUB, ISTOP
TIMSUB( I ) = .FALSE.
100 CONTINUE
END IF
110 CONTINUE
RETURN
*
* End of ATIMIN
*
END
SUBROUTINE ORTHES(NM,N,LOW,IGH,A,ORT)
C
INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
REAL A(NM,N),ORT(IGH)
REAL F,G,H,SCALE
C
C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTHES,
C NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
C
C GIVEN A REAL GENERAL MATRIX, THIS SUBROUTINE
C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
C ORTHOGONAL SIMILARITY TRANSFORMATIONS.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRIX.
C
C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED,
C SET LOW=1, IGH=N.
C
C A CONTAINS THE INPUT MATRIX.
C
C ON OUTPUT
C
C A CONTAINS THE HESSENBERG MATRIX. INFORMATION ABOUT
C THE ORTHOGONAL TRANSFORMATIONS USED IN THE REDUCTION
C IS STORED IN THE REMAINING TRIANGLE UNDER THE
C HESSENBERG MATRIX.
C
C ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS.
C ONLY ELEMENTS LOW THROUGH IGH ARE USED.
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
C
LA = IGH - 1
KP1 = LOW + 1
IF (LA .LT. KP1) GO TO 200
C
DO 180 M = KP1, LA
H = 0.0E0
ORT(M) = 0.0E0
SCALE = 0.0E0
C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
DO 90 I = M, IGH
90 SCALE = SCALE + ABS(A(I,M-1))
C
IF (SCALE .EQ. 0.0E0) GO TO 180
MP = M + IGH
C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
DO 100 II = M, IGH
I = MP - II
ORT(I) = A(I,M-1) / SCALE
H = H + ORT(I) * ORT(I)
100 CONTINUE
C
G = -SIGN(SQRT(H),ORT(M))
H = H - ORT(M) * G
ORT(M) = ORT(M) - G
C .......... FORM (I-(U*UT)/H) * A ..........
DO 130 J = M, N
F = 0.0E0
C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
DO 110 II = M, IGH
I = MP - II
F = F + ORT(I) * A(I,J)
110 CONTINUE
C
F = F / H
C
DO 120 I = M, IGH
120 A(I,J) = A(I,J) - F * ORT(I)
C
130 CONTINUE
C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
DO 160 I = 1, IGH
F = 0.0E0
C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
DO 140 JJ = M, IGH
J = MP - JJ
F = F + ORT(J) * A(I,J)
140 CONTINUE
C
F = F / H
C
DO 150 J = M, IGH
150 A(I,J) = A(I,J) - F * ORT(J)
C
160 CONTINUE
C
ORT(M) = SCALE * ORT(M)
A(M,M-1) = SCALE * G
180 CONTINUE
C
200 RETURN
END
SUBROUTINE TRED1(NM,N,A,D,E,E2)
C
INTEGER I,J,K,L,N,II,NM,JP1
REAL A(NM,N),D(N),E(N),E2(N)
REAL F,G,H,SCALE
C
C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED1,
C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C
C THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX
C TO A SYMMETRIC TRIDIAGONAL MATRIX USING
C ORTHOGONAL SIMILARITY TRANSFORMATIONS.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRIX.
C
C A CONTAINS THE REAL SYMMETRIC INPUT MATRIX. ONLY THE
C LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED.
C
C ON OUTPUT
C
C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS-
C FORMATIONS USED IN THE REDUCTION IN ITS STRICT LOWER
C TRIANGLE. THE FULL UPPER TRIANGLE OF A IS UNALTERED.
C
C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX.
C
C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO.
C
C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
C
DO 100 I = 1, N
D(I) = A(N,I)
A(N,I) = A(I,I)
100 CONTINUE
C .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........
DO 300 II = 1, N
I = N + 1 - II
L = I - 1
H = 0.0E0
SCALE = 0.0E0
IF (L .LT. 1) GO TO 130
C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) ..........
DO 120 K = 1, L
120 SCALE = SCALE + ABS(D(K))
C
IF (SCALE .NE. 0.0E0) GO TO 140
C
DO 125 J = 1, L
D(J) = A(L,J)
A(L,J) = A(I,J)
A(I,J) = 0.0E0
125 CONTINUE
C
130 E(I) = 0.0E0
E2(I) = 0.0E0
GO TO 300
C
140 DO 150 K = 1, L
D(K) = D(K) / SCALE
H = H + D(K) * D(K)
150 CONTINUE
C
E2(I) = SCALE * SCALE * H
F = D(L)
G = -SIGN(SQRT(H),F)
E(I) = SCALE * G
H = H - F * G
D(L) = F - G
IF (L .EQ. 1) GO TO 285
C .......... FORM A*U ..........
DO 170 J = 1, L
170 E(J) = 0.0E0
C
DO 240 J = 1, L
F = D(J)
G = E(J) + A(J,J) * F
JP1 = J + 1
IF (L .LT. JP1) GO TO 220
C
DO 200 K = JP1, L
G = G + A(K,J) * D(K)
E(K) = E(K) + A(K,J) * F
200 CONTINUE
C
220 E(J) = G
240 CONTINUE
C .......... FORM P ..........
F = 0.0E0
C
DO 245 J = 1, L
E(J) = E(J) / H
F = F + E(J) * D(J)
245 CONTINUE
C
H = F / (H + H)
C .......... FORM Q ..........
DO 250 J = 1, L
250 E(J) = E(J) - H * D(J)
C .......... FORM REDUCED A ..........
DO 280 J = 1, L
F = D(J)
G = E(J)
C
DO 260 K = J, L
260 A(K,J) = A(K,J) - F * E(K) - G * D(K)
C
280 CONTINUE
C
285 DO 290 J = 1, L
F = D(J)
D(J) = A(L,J)
A(L,J) = A(I,J)
A(I,J) = F * SCALE
290 CONTINUE
C
300 CONTINUE
C
RETURN
END
SUBROUTINE SLAORD( JOB, N, X, INCX )
*
* -- LAPACK auxiliary routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
CHARACTER JOB
INTEGER INCX, N
* ..
* .. Array Arguments ..
REAL X( * )
* ..
*
* Purpose
* =======
*
* SLAORD sorts the elements of a vector x in increasing or decreasing
* order.
*
* Arguments
* =========
*
* JOB (input) CHARACTER
* = 'I': Sort in increasing order
* = 'D': Sort in decreasing order
*
* N (input) INTEGER
* The length of the vector X.
*
* X (input/output) REAL array, dimension
* (1+(N-1)*INCX)
* On entry, the vector of length n to be sorted.
* On exit, the vector x is sorted in the prescribed order.
*
* INCX (input) INTEGER
* The spacing between successive elements of X. INCX >= 0.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, INC, IX, IXNEXT
REAL TEMP
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
INC = ABS( INCX )
IF( LSAME( JOB, 'I' ) ) THEN
*
* Sort in increasing order
*
DO 20 I = 2, N
IX = 1 + ( I-1 )*INC
10 CONTINUE
IF( IX.EQ.1 )
$ GO TO 20
IXNEXT = IX - INC
IF( X( IX ).GT.X( IXNEXT ) ) THEN
GO TO 20
ELSE
TEMP = X( IX )
X( IX ) = X( IXNEXT )
X( IXNEXT ) = TEMP
END IF
IX = IXNEXT
GO TO 10
20 CONTINUE
*
ELSE IF( LSAME( JOB, 'D' ) ) THEN
*
* Sort in decreasing order
*
DO 40 I = 2, N
IX = 1 + ( I-1 )*INC
30 CONTINUE
IF( IX.EQ.1 )
$ GO TO 40
IXNEXT = IX - INC
IF( X( IX ).LT.X( IXNEXT ) ) THEN
GO TO 40
ELSE
TEMP = X( IX )
X( IX ) = X( IXNEXT )
X( IXNEXT ) = TEMP
END IF
IX = IXNEXT
GO TO 30
40 CONTINUE
END IF
RETURN
*
* End of SLAORD
*
END
SUBROUTINE SGEFA(A,LDA,N,IPVT,INFO)
INTEGER LDA,N,IPVT(*),INFO
REAL A(LDA,*)
C
C SGEFA FACTORS A REAL MATRIX BY GAUSSIAN ELIMINATION.
C
C SGEFA IS USUALLY CALLED BY SGECO, BUT IT CAN BE CALLED
C DIRECTLY WITH A SAVING IN TIME IF RCOND IS NOT NEEDED.
C (TIME FOR SGECO) = (1 + 9/N)*(TIME FOR SGEFA) .
C
C ON ENTRY
C
C A REAL(LDA, N)
C THE MATRIX TO BE FACTORED.
C
C LDA INTEGER
C THE LEADING DIMENSION OF THE ARRAY A .
C
C N INTEGER
C THE ORDER OF THE MATRIX A .
C
C ON RETURN
C
C A AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
C WHICH WERE USED TO OBTAIN IT.
C THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE
C L IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR.
C
C IPVT INTEGER(N)
C AN INTEGER VECTOR OF PIVOT INDICES.
C
C INFO INTEGER
C = 0 NORMAL VALUE.
C = K IF U(K,K) .EQ. 0.0 . THIS IS NOT AN ERROR
C CONDITION FOR THIS SUBROUTINE, BUT IT DOES
C INDICATE THAT SGESL OR SGEDI WILL DIVIDE BY ZERO
C IF CALLED. USE RCOND IN SGECO FOR A RELIABLE
C INDICATION OF SINGULARITY.
C
C LINPACK. THIS VERSION DATED 08/14/78 .
C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C SUBROUTINES AND FUNCTIONS
C
C BLAS SAXPY,SSCAL,ISAMAX
C
C INTERNAL VARIABLES
C
REAL T
INTEGER ISAMAX,J,K,KP1,L,NM1
C
C
C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
C
INFO = 0
NM1 = N - 1
IF (NM1 .LT. 1) GO TO 70
DO 60 K = 1, NM1
KP1 = K + 1
C
C FIND L = PIVOT INDEX
C
L = ISAMAX(N-K+1,A(K,K),1) + K - 1
IPVT(K) = L
C
C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
C
IF (A(L,K) .EQ. 0.0E0) GO TO 40
C
C INTERCHANGE IF NECESSARY
C
IF (L .EQ. K) GO TO 10
T = A(L,K)
A(L,K) = A(K,K)
A(K,K) = T
10 CONTINUE
C
C COMPUTE MULTIPLIERS
C
T = -1.0E0/A(K,K)
CALL SSCAL(N-K,T,A(K+1,K),1)
C
C ROW ELIMINATION WITH COLUMN INDEXING
C
DO 30 J = KP1, N
T = A(L,J)
IF (L .EQ. K) GO TO 20
A(L,J) = A(K,J)
A(K,J) = T
20 CONTINUE
CALL SAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1)
30 CONTINUE
GO TO 50
40 CONTINUE
INFO = K
50 CONTINUE
60 CONTINUE
70 CONTINUE
IPVT(N) = N
IF (A(N,N) .EQ. 0.0E0) INFO = N
RETURN
END
SUBROUTINE SPOFA(A,LDA,N,INFO)
INTEGER LDA,N,INFO
REAL A(LDA,*)
C
C SPOFA FACTORS A REAL SYMMETRIC POSITIVE DEFINITE MATRIX.
C
C SPOFA IS USUALLY CALLED BY SPOCO, BUT IT CAN BE CALLED
C DIRECTLY WITH A SAVING IN TIME IF RCOND IS NOT NEEDED.
C (TIME FOR SPOCO) = (1 + 18/N)*(TIME FOR SPOFA) .
C
C ON ENTRY
C
C A REAL(LDA, N)
C THE SYMMETRIC MATRIX TO BE FACTORED. ONLY THE
C DIAGONAL AND UPPER TRIANGLE ARE USED.
C
C LDA INTEGER
C THE LEADING DIMENSION OF THE ARRAY A .
C
C N INTEGER
C THE ORDER OF THE MATRIX A .
C
C ON RETURN
C
C A AN UPPER TRIANGULAR MATRIX R SO THAT A = TRANS(R)*R
C WHERE TRANS(R) IS THE TRANSPOSE.
C THE STRICT LOWER TRIANGLE IS UNALTERED.
C IF INFO .NE. 0 , THE FACTORIZATION IS NOT COMPLETE.
C
C INFO INTEGER
C = 0 FOR NORMAL RETURN.
C = K SIGNALS AN ERROR CONDITION. THE LEADING MINOR
C OF ORDER K IS NOT POSITIVE DEFINITE.
C
C LINPACK. THIS VERSION DATED 08/14/78 .
C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C SUBROUTINES AND FUNCTIONS
C
C BLAS SDOT
C FORTRAN SQRT
C
C INTERNAL VARIABLES
C
REAL SDOT,T
REAL S
INTEGER J,JM1,K
C BEGIN BLOCK WITH ...EXITS TO 40
C
C
DO 30 J = 1, N
INFO = J
S = 0.0E0
JM1 = J - 1
IF (JM1 .LT. 1) GO TO 20
DO 10 K = 1, JM1
T = A(K,J) - SDOT(K-1,A(1,K),1,A(1,J),1)
T = T/A(K,K)
A(K,J) = T
S = S + T*T
10 CONTINUE
20 CONTINUE
S = A(J,J) - S
C ......EXIT
IF (S .LE. 0.0E0) GO TO 40
A(J,J) = SQRT(S)
30 CONTINUE
INFO = 0
40 CONTINUE
RETURN
END
SUBROUTINE SQRDC(X,LDX,N,P,QRAUX,JPVT,WORK,JOB)
INTEGER LDX,N,P,JOB
INTEGER JPVT(*)
REAL X(LDX,*),QRAUX(*),WORK(*)
C
C SQRDC USES HOUSEHOLDER TRANSFORMATIONS TO COMPUTE THE QR
C FACTORIZATION OF AN N BY P MATRIX X. COLUMN PIVOTING
C BASED ON THE 2-NORMS OF THE REDUCED COLUMNS MAY BE
C PERFORMED AT THE USERS OPTION.
C
C ON ENTRY
C
C X REAL(LDX,P), WHERE LDX .GE. N.
C X CONTAINS THE MATRIX WHOSE DECOMPOSITION IS TO BE
C COMPUTED.
C
C LDX INTEGER.
C LDX IS THE LEADING DIMENSION OF THE ARRAY X.
C
C N INTEGER.
C N IS THE NUMBER OF ROWS OF THE MATRIX X.
C
C P INTEGER.
C P IS THE NUMBER OF COLUMNS OF THE MATRIX X.
C
C JPVT INTEGER(P).
C JPVT CONTAINS INTEGERS THAT CONTROL THE SELECTION
C OF THE PIVOT COLUMNS. THE K-TH COLUMN X(K) OF X
C IS PLACED IN ONE OF THREE CLASSES ACCORDING TO THE
C VALUE OF JPVT(K).
C
C IF JPVT(K) .GT. 0, THEN X(K) IS AN INITIAL
C COLUMN.
C
C IF JPVT(K) .EQ. 0, THEN X(K) IS A FREE COLUMN.
C
C IF JPVT(K) .LT. 0, THEN X(K) IS A FINAL COLUMN.
C
C BEFORE THE DECOMPOSITION IS COMPUTED, INITIAL COLUMNS
C ARE MOVED TO THE BEGINNING OF THE ARRAY X AND FINAL
C COLUMNS TO THE END. BOTH INITIAL AND FINAL COLUMNS
C ARE FROZEN IN PLACE DURING THE COMPUTATION AND ONLY
C FREE COLUMNS ARE MOVED. AT THE K-TH STAGE OF THE
C REDUCTION, IF X(K) IS OCCUPIED BY A FREE COLUMN
C IT IS INTERCHANGED WITH THE FREE COLUMN OF LARGEST
C REDUCED NORM. JPVT IS NOT REFERENCED IF
C JOB .EQ. 0.
C
C WORK REAL(P).
C WORK IS A WORK ARRAY. WORK IS NOT REFERENCED IF
C JOB .EQ. 0.
C
C JOB INTEGER.
C JOB IS AN INTEGER THAT INITIATES COLUMN PIVOTING.
C IF JOB .EQ. 0, NO PIVOTING IS DONE.
C IF JOB .NE. 0, PIVOTING IS DONE.
C
C ON RETURN
C
C X X CONTAINS IN ITS UPPER TRIANGLE THE UPPER
C TRIANGULAR MATRIX R OF THE QR FACTORIZATION.
C BELOW ITS DIAGONAL X CONTAINS INFORMATION FROM
C WHICH THE ORTHOGONAL PART OF THE DECOMPOSITION
C CAN BE RECOVERED. NOTE THAT IF PIVOTING HAS
C BEEN REQUESTED, THE DECOMPOSITION IS NOT THAT
C OF THE ORIGINAL MATRIX X BUT THAT OF X
C WITH ITS COLUMNS PERMUTED AS DESCRIBED BY JPVT.
C
C QRAUX REAL(P).
C QRAUX CONTAINS FURTHER INFORMATION REQUIRED TO RECOVER
C THE ORTHOGONAL PART OF THE DECOMPOSITION.
C
C JPVT JPVT(K) CONTAINS THE INDEX OF THE COLUMN OF THE
C ORIGINAL MATRIX THAT HAS BEEN INTERCHANGED INTO
C THE K-TH COLUMN, IF PIVOTING WAS REQUESTED.
C
C LINPACK. THIS VERSION DATED 08/14/78 .
C G.W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB.
C
C SQRDC USES THE FOLLOWING FUNCTIONS AND SUBPROGRAMS.
C
C BLAS SAXPY,SDOT,SSCAL,SSWAP,SNRM2
C FORTRAN ABS,AMAX1,MIN0,SQRT
C
C INTERNAL VARIABLES
C
INTEGER J,JJ,JP,L,LP1,LUP,MAXJ,PL,PU
REAL MAXNRM,SNRM2,TT
REAL SDOT,NRMXL,T
LOGICAL NEGJ,SWAPJ
C
C
PL = 1
PU = 0
IF (JOB .EQ. 0) GO TO 60
C
C PIVOTING HAS BEEN REQUESTED. REARRANGE THE COLUMNS
C ACCORDING TO JPVT.
C
DO 20 J = 1, P
SWAPJ = JPVT(J) .GT. 0
NEGJ = JPVT(J) .LT. 0
JPVT(J) = J
IF (NEGJ) JPVT(J) = -J
IF (.NOT.SWAPJ) GO TO 10
IF (J .NE. PL) CALL SSWAP(N,X(1,PL),1,X(1,J),1)
JPVT(J) = JPVT(PL)
JPVT(PL) = J
PL = PL + 1
10 CONTINUE
20 CONTINUE
PU = P
DO 50 JJ = 1, P
J = P - JJ + 1
IF (JPVT(J) .GE. 0) GO TO 40
JPVT(J) = -JPVT(J)
IF (J .EQ. PU) GO TO 30
CALL SSWAP(N,X(1,PU),1,X(1,J),1)
JP = JPVT(PU)
JPVT(PU) = JPVT(J)
JPVT(J) = JP
30 CONTINUE
PU = PU - 1
40 CONTINUE
50 CONTINUE
60 CONTINUE
C
C COMPUTE THE NORMS OF THE FREE COLUMNS.
C
IF (PU .LT. PL) GO TO 80
DO 70 J = PL, PU
QRAUX(J) = SNRM2(N,X(1,J),1)
WORK(J) = QRAUX(J)
70 CONTINUE
80 CONTINUE
C
C PERFORM THE HOUSEHOLDER REDUCTION OF X.
C
LUP = MIN0(N,P)
DO 200 L = 1, LUP
IF (L .LT. PL .OR. L .GE. PU) GO TO 120
C
C LOCATE THE COLUMN OF LARGEST NORM AND BRING IT
C INTO THE PIVOT POSITION.
C
MAXNRM = 0.0E0
MAXJ = L
DO 100 J = L, PU
IF (QRAUX(J) .LE. MAXNRM) GO TO 90
MAXNRM = QRAUX(J)
MAXJ = J
90 CONTINUE
100 CONTINUE
IF (MAXJ .EQ. L) GO TO 110
CALL SSWAP(N,X(1,L),1,X(1,MAXJ),1)
QRAUX(MAXJ) = QRAUX(L)
WORK(MAXJ) = WORK(L)
JP = JPVT(MAXJ)
JPVT(MAXJ) = JPVT(L)
JPVT(L) = JP
110 CONTINUE
120 CONTINUE
QRAUX(L) = 0.0E0
IF (L .EQ. N) GO TO 190
C
C COMPUTE THE HOUSEHOLDER TRANSFORMATION FOR COLUMN L.
C
NRMXL = SNRM2(N-L+1,X(L,L),1)
IF (NRMXL .EQ. 0.0E0) GO TO 180
IF (X(L,L) .NE. 0.0E0) NRMXL = SIGN(NRMXL,X(L,L))
CALL SSCAL(N-L+1,1.0E0/NRMXL,X(L,L),1)
X(L,L) = 1.0E0 + X(L,L)
C
C APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS,
C UPDATING THE NORMS.
C
LP1 = L + 1
IF (P .LT. LP1) GO TO 170
DO 160 J = LP1, P
T = -SDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L)
CALL SAXPY(N-L+1,T,X(L,L),1,X(L,J),1)
IF (J .LT. PL .OR. J .GT. PU) GO TO 150
IF (QRAUX(J) .EQ. 0.0E0) GO TO 150
TT = 1.0E0 - (ABS(X(L,J))/QRAUX(J))**2
TT = AMAX1(TT,0.0E0)
T = TT
TT = 1.0E0 + 0.05E0*TT*(QRAUX(J)/WORK(J))**2
IF (TT .EQ. 1.0E0) GO TO 130
QRAUX(J) = QRAUX(J)*SQRT(T)
GO TO 140
130 CONTINUE
QRAUX(J) = SNRM2(N-L,X(L+1,J),1)
WORK(J) = QRAUX(J)
140 CONTINUE
150 CONTINUE
160 CONTINUE
170 CONTINUE
C
C SAVE THE TRANSFORMATION.
C
QRAUX(L) = X(L,L)
X(L,L) = -NRMXL
180 CONTINUE
190 CONTINUE
200 CONTINUE
RETURN
END
SUBROUTINE SGTSL(N,C,D,E,B,INFO)
INTEGER N,INFO
REAL C(*),D(*),E(*),B(*)
C
C SGTSL GIVEN A GENERAL TRIDIAGONAL MATRIX AND A RIGHT HAND
C SIDE WILL FIND THE SOLUTION.
C
C ON ENTRY
C
C N INTEGER
C IS THE ORDER OF THE TRIDIAGONAL MATRIX.
C
C C REAL(N)
C IS THE SUBDIAGONAL OF THE TRIDIAGONAL MATRIX.
C C(2) THROUGH C(N) SHOULD CONTAIN THE SUBDIAGONAL.
C ON OUTPUT C IS DESTROYED.
C
C D REAL(N)
C IS THE DIAGONAL OF THE TRIDIAGONAL MATRIX.
C ON OUTPUT D IS DESTROYED.
C
C E REAL(N)
C IS THE SUPERDIAGONAL OF THE TRIDIAGONAL MATRIX.
C E(1) THROUGH E(N-1) SHOULD CONTAIN THE SUPERDIAGONAL.
C ON OUTPUT E IS DESTROYED.
C
C B REAL(N)
C IS THE RIGHT HAND SIDE VECTOR.
C
C ON RETURN
C
C B IS THE SOLUTION VECTOR.
C
C INFO INTEGER
C = 0 NORMAL VALUE.
C = K IF THE K-TH ELEMENT OF THE DIAGONAL BECOMES
C EXACTLY ZERO. THE SUBROUTINE RETURNS WHEN
C THIS IS DETECTED.
C
C LINPACK. THIS VERSION DATED 08/14/78 .
C JACK DONGARRA, ARGONNE NATIONAL LABORATORY.
C
C NO EXTERNALS
C FORTRAN ABS
C
C INTERNAL VARIABLES
C
INTEGER K,KB,KP1,NM1,NM2
REAL T
C BEGIN BLOCK PERMITTING ...EXITS TO 100
C
INFO = 0
C(1) = D(1)
NM1 = N - 1
IF (NM1 .LT. 1) GO TO 40
D(1) = E(1)
E(1) = 0.0E0
E(N) = 0.0E0
C
DO 30 K = 1, NM1
KP1 = K + 1
C
C FIND THE LARGEST OF THE TWO ROWS
C
IF (ABS(C(KP1)) .LT. ABS(C(K))) GO TO 10
C
C INTERCHANGE ROW
C
T = C(KP1)
C(KP1) = C(K)
C(K) = T
T = D(KP1)
D(KP1) = D(K)
D(K) = T
T = E(KP1)
E(KP1) = E(K)
E(K) = T
T = B(KP1)
B(KP1) = B(K)
B(K) = T
10 CONTINUE
C
C ZERO ELEMENTS
C
IF (C(K) .NE. 0.0E0) GO TO 20
INFO = K
C ............EXIT
GO TO 100
20 CONTINUE
T = -C(KP1)/C(K)
C(KP1) = D(KP1) + T*D(K)
D(KP1) = E(KP1) + T*E(K)
E(KP1) = 0.0E0
B(KP1) = B(KP1) + T*B(K)
30 CONTINUE
40 CONTINUE
IF (C(N) .NE. 0.0E0) GO TO 50
INFO = N
GO TO 90
50 CONTINUE
C
C BACK SOLVE
C
NM2 = N - 2
B(N) = B(N)/C(N)
IF (N .EQ. 1) GO TO 80
B(NM1) = (B(NM1) - D(NM1)*B(N))/C(NM1)
IF (NM2 .LT. 1) GO TO 70
DO 60 KB = 1, NM2
K = NM2 - KB + 1
B(K) = (B(K) - D(K)*B(K+1) - E(K)*B(K+2))/C(K)
60 CONTINUE
70 CONTINUE
80 CONTINUE
90 CONTINUE
100 CONTINUE
C
RETURN
END
SUBROUTINE SPTSL(N,D,E,B)
INTEGER N
REAL D(*),E(*),B(*)
C
C SPTSL GIVEN A POSITIVE DEFINITE TRIDIAGONAL MATRIX AND A RIGHT
C HAND SIDE WILL FIND THE SOLUTION.
C
C ON ENTRY
C
C N INTEGER
C IS THE ORDER OF THE TRIDIAGONAL MATRIX.
C
C D REAL(N)
C IS THE DIAGONAL OF THE TRIDIAGONAL MATRIX.
C ON OUTPUT D IS DESTROYED.
C
C E REAL(N)
C IS THE OFFDIAGONAL OF THE TRIDIAGONAL MATRIX.
C E(1) THROUGH E(N-1) SHOULD CONTAIN THE
C OFFDIAGONAL.
C
C B REAL(N)
C IS THE RIGHT HAND SIDE VECTOR.
C
C ON RETURN
C
C B CONTAINS THE SOULTION.
C
C LINPACK. THIS VERSION DATED 08/14/78 .
C JACK DONGARRA, ARGONNE NATIONAL LABORATORY.
C
C NO EXTERNALS
C FORTRAN MOD
C
C INTERNAL VARIABLES
C
INTEGER K,KBM1,KE,KF,KP1,NM1,NM1D2
REAL T1,T2
C
C CHECK FOR 1 X 1 CASE
C
IF (N .NE. 1) GO TO 10
B(1) = B(1)/D(1)
GO TO 70
10 CONTINUE
NM1 = N - 1
NM1D2 = NM1/2
IF (N .EQ. 2) GO TO 30
KBM1 = N - 1
C
C ZERO TOP HALF OF SUBDIAGONAL AND BOTTOM HALF OF
C SUPERDIAGONAL
C
DO 20 K = 1, NM1D2
T1 = E(K)/D(K)
D(K+1) = D(K+1) - T1*E(K)
B(K+1) = B(K+1) - T1*B(K)
T2 = E(KBM1)/D(KBM1+1)
D(KBM1) = D(KBM1) - T2*E(KBM1)
B(KBM1) = B(KBM1) - T2*B(KBM1+1)
KBM1 = KBM1 - 1
20 CONTINUE
30 CONTINUE
KP1 = NM1D2 + 1
C
C CLEAN UP FOR POSSIBLE 2 X 2 BLOCK AT CENTER
C
IF (MOD(N,2) .NE. 0) GO TO 40
T1 = E(KP1)/D(KP1)
D(KP1+1) = D(KP1+1) - T1*E(KP1)
B(KP1+1) = B(KP1+1) - T1*B(KP1)
KP1 = KP1 + 1
40 CONTINUE
C
C BACK SOLVE STARTING AT THE CENTER, GOING TOWARDS THE TOP
C AND BOTTOM
C
B(KP1) = B(KP1)/D(KP1)
IF (N .EQ. 2) GO TO 60
K = KP1 - 1
KE = KP1 + NM1D2 - 1
DO 50 KF = KP1, KE
B(K) = (B(K) - E(K)*B(K+1))/D(K)
B(KF+1) = (B(KF+1) - E(KF)*B(KF))/D(KF+1)
K = K - 1
50 CONTINUE
60 CONTINUE
IF (MOD(N,2) .EQ. 0) B(1) = (B(1) - E(1)*B(2))/D(1)
70 CONTINUE
RETURN
END
REAL FUNCTION SMFLOP( OPS, TIME, INFO )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
INTEGER INFO
REAL OPS, TIME
* ..
*
* Purpose
* =======
*
* SMFLOP computes the megaflop rate given the number of operations
* and time in seconds. This is basically just a divide operation,
* but care is taken not to divide by zero.
*
* Arguments
* =========
*
* OPS (input) REAL
* The number of floating point operations.
* performed by the timed routine.
*
* TIME (input) REAL
* The total time in seconds.
*
* INFO (input) INTEGER
* The return code from the timed routine. If INFO is not 0,
* then SMFLOP returns a negative value, indicating an error.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, REAL
* ..
* .. Executable Statements ..
*
IF( TIME.LE.ZERO ) THEN
SMFLOP = ZERO
ELSE
SMFLOP = OPS / ( 1.0E6*TIME )
END IF
IF( INFO.NE.0 )
$ SMFLOP = -ABS( REAL( INFO ) )
RETURN
*
* End of SMFLOP
*
END
REAL FUNCTION SOPAUX( SUBNAM, M, N, KL, KU, NB )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
INTEGER KL, KU, M, N, NB
* ..
*
* Purpose
* =======
*
* SOPAUX computes an approximation of the number of floating point
* operations used by the subroutine SUBNAM with the given values
* of the parameters M, N, KL, KU, and NB.
*
* This version counts operations for the LAPACK auxiliary routines.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* M (input) INTEGER
* The number of rows of the coefficient matrix. M >= 0.
*
* N (input) INTEGER
* The number of columns of the coefficient matrix.
* If the matrix is square (such as in a solve routine) then
* N is the number of right hand sides. N >= 0.
*
* KL (input) INTEGER
* The lower band width of the coefficient matrix.
* If needed, 0 <= KL <= M-1.
*
* KU (input) INTEGER
* The upper band width of the coefficient matrix.
* If needed, 0 <= KU <= N-1.
*
* NB (input) INTEGER
* The block size. If needed, NB >= 1.
*
* =====================================================================
*
* .. Local Scalars ..
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 C3
REAL ADDFAC, ADDS, EK, EM, EN, ENB, MULFAC, MULTS
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Executable Statements ..
*
SOPAUX = 0
MULTS = 0
ADDS = 0
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
IF( M.LE.0 .OR.
$ .NOT.( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) .OR.
$ LSAME( C1, 'C' ) .OR. LSAME( C1, 'Z' ) ) ) THEN
RETURN
END IF
IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN
MULFAC = 1
ADDFAC = 1
ELSE
MULFAC = 6
ADDFAC = 2
END IF
EM = M
EN = N
ENB = NB
*
IF( LSAMEN( 2, C2, 'LA' ) ) THEN
*
* xLAULM: N => M
*
IF( LSAMEN( 3, C3, 'ULM' ) .OR. LSAMEN( 3, C3, 'UL2' ) ) THEN
MULTS = ( 1./3. )*EM*( -1.+EM*EM )
ADDS = EM*( 1./6.+EM*( -1./2.+EM*( 1./3. ) ) )
*
* xLAUUM: N => M
*
ELSE IF( LSAMEN( 3, C3, 'UUM' ) .OR. LSAMEN( 3, C3, 'UU2' ) )
$ THEN
MULTS = EM*( 1./3.+EM*( 1./2.+EM*( 1./6. ) ) )
ADDS = ( 1./6. )*EM*( -1.+EM*EM )
*
* xLACON: N => M
*
ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN
MULTS = 3.*EM + 3.
ADDS = 4.*EM - 3.
*
* xLARF: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'RF ' ) ) THEN
MULTS = 2.*EM*EN + EN
ADDS = 2.*EM*EN
*
* xLARFB: M, N, SIDE, NB => M, N, KL, NB
* where KL <= 0 indicates SIDE = 'L'
* and KL > 0 indicates SIDE = 'R'
*
ELSE IF( LSAMEN( 3, C3, 'RFB' ) ) THEN
*
* KL <= 0: Code requiring local array
*
IF( KL.LE.0 ) THEN
MULTS = EN*ENB*( 2.*EM+( ENB+1. )/2. )
ADDS = EN*ENB*( 2.*EM+( ENB-1. )/2. )
*
* KL > 0: Code not requiring local array
*
ELSE
MULTS = EN*ENB*( 2.*EM+( -ENB/2.+5./2. ) )
ADDS = EN*ENB*( 2.*EM+( -ENB/2.-1./2. ) )
END IF
*
* xLARFG: N => M
*
ELSE IF( LSAMEN( 3, C3, 'RFG' ) ) THEN
MULTS = 2.*EM + 4.
ADDS = EM + 1.
*
* xLARFT: M, NB => M, N
*
ELSE IF( LSAMEN( 3, C3, 'RFT' ) ) THEN
MULTS = EN*( ( -5./6.+EN*( 1.+EN*( -1./6. ) ) )+( EM/2. )*
$ ( EN-1. ) )
ADDS = EN*( ( 1./6. )*( 1.-EN*EN )+( EM/2. )*( EN-1. ) )
*
* xLATRD: N, K => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRD' ) ) THEN
EK = N
MULTS = EK*( ( 25./6.-EK*( 3./2.+( 5./3. )*EK ) )+EM*
$ ( 2.+2.*EK+EM ) )
ADDS = EK*( ( -1./3.-( 5./3. )*EK*EK )+EM*( -1.+2.*EK+EM ) )
END IF
*
END IF
*
SOPAUX = MULFAC*MULTS + ADDFAC*ADDS
*
RETURN
*
* End of SOPAUX
*
END
REAL FUNCTION SOPBL2( SUBNAM, M, N, KKL, KKU )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
INTEGER KKL, KKU, M, N
* ..
*
* Purpose
* =======
*
* SOPBL2 computes an approximation of the number of floating point
* operations used by a subroutine SUBNAM with the given values
* of the parameters M, N, KL, and KU.
*
* This version counts operations for the Level 2 BLAS.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* M (input) INTEGER
* The number of rows of the coefficient matrix. M >= 0.
*
* N (input) INTEGER
* The number of columns of the coefficient matrix.
* If the matrix is square (such as in a solve routine) then
* N is the number of right hand sides. N >= 0.
*
* KKL (input) INTEGER
* The lower band width of the coefficient matrix.
* KL is set to max( 0, min( M-1, KKL ) ).
*
* KKU (input) INTEGER
* The upper band width of the coefficient matrix.
* KU is set to max( 0, min( N-1, KKU ) ).
*
* =====================================================================
*
* .. Local Scalars ..
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 C3
REAL ADDS, EK, EM, EN, KL, KU, MULTS
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR.
$ .NOT.( LSAME( SUBNAM, 'S' ) .OR. LSAME( SUBNAM, 'D' ) .OR.
$ LSAME( SUBNAM, 'C' ) .OR. LSAME( SUBNAM, 'Z' ) ) ) THEN
SOPBL2 = 0
RETURN
END IF
*
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
MULTS = 0
ADDS = 0
KL = MAX( 0, MIN( M-1, KKL ) )
KU = MAX( 0, MIN( N-1, KKU ) )
EM = M
EN = N
EK = KL
*
* -------------------------------
* Matrix-vector multiply routines
* -------------------------------
*
IF( LSAMEN( 3, C3, 'MV ' ) ) THEN
*
IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
MULTS = EM*( EN+1. )
ADDS = EM*EN
*
* Assume M <= N + KL and KL < M
* N <= M + KU and KU < N
* so that the zero sections are triangles.
*
ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
*
MULTS = EM*( EN+1. ) - ( EM-1.-KL )*( EM-KL ) / 2. -
$ ( EN-1.-KU )*( EN-KU ) / 2.
ADDS = EM*( EN+1. ) - ( EM-1.-KL )*( EM-KL ) / 2. -
$ ( EN-1.-KU )*( EN-KU ) / 2.
*
ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHP' ) ) THEN
*
MULTS = EM*( EM+1. )
ADDS = EM*EM
*
ELSE IF( LSAMEN( 2, C2, 'SB' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHB' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHB' ) ) THEN
*
MULTS = EM*( EM+1. ) - ( EM-1.-EK )*( EM-EK )
ADDS = EM*EM - ( EM-1.-EK )*( EM-EK )
*
ELSE IF( LSAMEN( 2, C2, 'TR' ) .OR. LSAMEN( 2, C2, 'TP' ) )
$ THEN
*
MULTS = EM*( EM+1. ) / 2.
ADDS = ( EM-1. )*EM / 2.
*
ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
*
MULTS = EM*( EM+1. ) / 2. - ( EM-EK-1. )*( EM-EK ) / 2.
ADDS = ( EM-1. )*EM / 2. - ( EM-EK-1. )*( EM-EK ) / 2.
*
END IF
*
* ---------------------
* Matrix solve routines
* ---------------------
*
ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
*
IF( LSAMEN( 2, C2, 'TR' ) .OR. LSAMEN( 2, C2, 'TP' ) ) THEN
*
MULTS = EM*( EM+1. ) / 2.
ADDS = ( EM-1. )*EM / 2.
*
ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
*
MULTS = EM*( EM+1. ) / 2. - ( EM-EK-1. )*( EM-EK ) / 2.
ADDS = ( EM-1. )*EM / 2. - ( EM-EK-1. )*( EM-EK ) / 2.
*
END IF
*
* ----------------
* Rank-one updates
* ----------------
*
ELSE IF( LSAMEN( 3, C3, 'R ' ) ) THEN
*
IF( LSAMEN( 3, SUBNAM, 'SGE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'DGE' ) ) THEN
*
MULTS = EM*EN + MIN( EM, EN )
ADDS = EM*EN
*
ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHP' ) ) THEN
*
MULTS = EM*( EM+1. ) / 2. + EM
ADDS = EM*( EM+1. ) / 2.
*
END IF
*
ELSE IF( LSAMEN( 3, C3, 'RC ' ) .OR. LSAMEN( 3, C3, 'RU ' ) ) THEN
*
IF( LSAMEN( 3, SUBNAM, 'CGE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZGE' ) ) THEN
*
MULTS = EM*EN + MIN( EM, EN )
ADDS = EM*EN
*
END IF
*
* ----------------
* Rank-two updates
* ----------------
*
ELSE IF( LSAMEN( 3, C3, 'R2 ' ) ) THEN
IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHP' ) ) THEN
*
MULTS = EM*( EM+1. ) + 2.*EM
ADDS = EM*( EM+1. )
*
END IF
END IF
*
* ------------------------------------------------
* Compute the total number of operations.
* For real and double precision routines, count
* 1 for each multiply and 1 for each add.
* For complex and complex*16 routines, count
* 6 for each multiply and 2 for each add.
* ------------------------------------------------
*
IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN
*
SOPBL2 = MULTS + ADDS
*
ELSE
*
SOPBL2 = 6*MULTS + 2*ADDS
*
END IF
*
RETURN
*
* End of SOPBL2
*
END
REAL FUNCTION SOPBL3( SUBNAM, M, N, K )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
INTEGER K, M, N
* ..
*
* Purpose
* =======
*
* SOPBL3 computes an approximation of the number of floating point
* operations used by a subroutine SUBNAM with the given values
* of the parameters M, N, and K.
*
* This version counts operations for the Level 3 BLAS.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* M (input) INTEGER
* N (input) INTEGER
* K (input) INTEGER
* M, N, and K contain parameter values used by the Level 3
* BLAS. The output matrix is always M x N or N x N if
* symmetric, but K has different uses in different
* contexts. For example, in the matrix-matrix multiply
* routine, we have
* C = A * B
* where C is M x N, A is M x K, and B is K x N.
* In xSYMM, xTRMM, and xTRSM, K indicates whether the matrix
* A is applied on the left or right. If K <= 0, the matrix
* is applied on the left, if K > 0, on the right.
*
* =====================================================================
*
* .. Local Scalars ..
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 C3
REAL ADDS, EK, EM, EN, MULTS
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR.
$ .NOT.( LSAME( SUBNAM, 'S' ) .OR. LSAME( SUBNAM, 'D' ) .OR.
$ LSAME( SUBNAM, 'C' ) .OR. LSAME( SUBNAM, 'Z' ) ) ) THEN
SOPBL3 = 0
RETURN
END IF
*
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
MULTS = 0
ADDS = 0
EM = M
EN = N
EK = K
*
* ----------------------
* Matrix-matrix products
* assume beta = 1
* ----------------------
*
IF( LSAMEN( 3, C3, 'MM ' ) ) THEN
*
IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
MULTS = EM*EK*EN
ADDS = EM*EK*EN
*
ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) ) THEN
*
* IF K <= 0, assume A multiplies B on the left.
*
IF( K.LE.0 ) THEN
MULTS = EM*EM*EN
ADDS = EM*EM*EN
ELSE
MULTS = EM*EN*EN
ADDS = EM*EN*EN
END IF
*
ELSE IF( LSAMEN( 2, C2, 'TR' ) ) THEN
*
IF( K.LE.0 ) THEN
MULTS = EN*EM*( EM+1. ) / 2.
ADDS = EN*EM*( EM-1. ) / 2.
ELSE
MULTS = EM*EN*( EN+1. ) / 2.
ADDS = EM*EN*( EN-1. ) / 2.
END IF
*
END IF
*
* ------------------------------------------------
* Rank-K update of a symmetric or Hermitian matrix
* ------------------------------------------------
*
ELSE IF( LSAMEN( 3, C3, 'RK ' ) ) THEN
*
IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) ) THEN
*
MULTS = EK*EM*( EM+1. ) / 2.
ADDS = EK*EM*( EM+1. ) / 2.
END IF
*
* ------------------------------------------------
* Rank-2K update of a symmetric or Hermitian matrix
* ------------------------------------------------
*
ELSE IF( LSAMEN( 3, C3, 'R2K' ) ) THEN
*
IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) ) THEN
*
MULTS = EK*EM*EM
ADDS = EK*EM*EM + EM
END IF
*
* -----------------------------------------
* Solving system with many right hand sides
* -----------------------------------------
*
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'TRSM ' ) ) THEN
*
IF( K.LE.0 ) THEN
MULTS = EN*EM*( EM+1. ) / 2.
ADDS = EN*EM*( EM-1. ) / 2.
ELSE
MULTS = EM*EN*( EN+1. ) / 2.
ADDS = EM*EN*( EN-1. ) / 2.
END IF
*
END IF
*
* ------------------------------------------------
* Compute the total number of operations.
* For real and double precision routines, count
* 1 for each multiply and 1 for each add.
* For complex and complex*16 routines, count
* 6 for each multiply and 2 for each add.
* ------------------------------------------------
*
IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN
*
SOPBL3 = MULTS + ADDS
*
ELSE
*
SOPBL3 = 6*MULTS + 2*ADDS
*
END IF
*
RETURN
*
* End of SOPBL3
*
END
REAL FUNCTION SOPGB( SUBNAM, M, N, KL, KU, IPIV )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
INTEGER KL, KU, M, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
* ..
*
* Purpose
* =======
*
* SOPGB counts operations for the LU factorization of a band matrix
* xGBTRF.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* M (input) INTEGER
* The number of rows of the coefficient matrix. M >= 0.
*
* N (input) INTEGER
* The number of columns of the coefficient matrix. N >= 0.
*
* KL (input) INTEGER
* The number of subdiagonals of the matrix. KL >= 0.
*
* KU (input) INTEGER
* The number of superdiagonals of the matrix. KU >= 0.
*
* IPIV (input) INTEGER array, dimension (min(M,N))
* The vector of pivot indices from SGBTRF or CGBTRF.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL CORZ, SORD
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 C3
INTEGER I, J, JP, JU, KM
REAL ADDFAC, ADDS, MULFAC, MULTS
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
SOPGB = 0
MULTS = 0
ADDS = 0
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
SORD = LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' )
CORZ = LSAME( C1, 'C' ) .OR. LSAME( C1, 'Z' )
IF( .NOT.( SORD .OR. CORZ ) )
$ RETURN
IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN
ADDFAC = 1
MULFAC = 1
ELSE
ADDFAC = 2
MULFAC = 6
END IF
*
* --------------------------
* GB: General Band matrices
* --------------------------
*
IF( LSAMEN( 2, C2, 'GB' ) ) THEN
*
* xGBTRF: M, N, KL, KU => M, N, KL, KU
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
JU = 1
DO 10 J = 1, MIN( M, N )
KM = MIN( KL, M-J )
JP = IPIV( J )
JU = MAX( JU, MIN( JP+KU, N ) )
IF( KM.GT.0 ) THEN
MULTS = MULTS + KM*( 1+JU-J )
ADDS = ADDS + KM*( JU-J )
END IF
10 CONTINUE
END IF
*
* ---------------------------------
* GT: General Tridiagonal matrices
* ---------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'GT' ) ) THEN
*
* xGTTRF: N => M
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = 2*( M-1 )
ADDS = M - 1
DO 20 I = 1, M - 2
IF( IPIV( I ).NE.I )
$ MULTS = MULTS + 1
20 CONTINUE
*
* xGTTRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = 4*N*( M-1 )
ADDS = 3*N*( M-1 )
*
* xGTSV: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
MULTS = ( 4*N+2 )*( M-1 )
ADDS = ( 3*N+1 )*( M-1 )
DO 30 I = 1, M - 2
IF( IPIV( I ).NE.I )
$ MULTS = MULTS + 1
30 CONTINUE
END IF
END IF
*
SOPGB = MULFAC*MULTS + ADDFAC*ADDS
RETURN
*
* End of SOPGB
*
END
REAL FUNCTION SOPLA( SUBNAM, M, N, KL, KU, NB )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
INTEGER KL, KU, M, N, NB
* ..
*
* Purpose
* =======
*
* SOPLA computes an approximation of the number of floating point
* operations used by the subroutine SUBNAM with the given values
* of the parameters M, N, KL, KU, and NB.
*
* This version counts operations for the LAPACK subroutines.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* M (input) INTEGER
* The number of rows of the coefficient matrix. M >= 0.
*
* N (input) INTEGER
* The number of columns of the coefficient matrix.
* For solve routine when the matrix is square,
* N is the number of right hand sides. N >= 0.
*
* KL (input) INTEGER
* The lower band width of the coefficient matrix.
* If needed, 0 <= KL <= M-1.
* For xGEQRS, KL is the number of right hand sides.
*
* KU (input) INTEGER
* The upper band width of the coefficient matrix.
* If needed, 0 <= KU <= N-1.
*
* NB (input) INTEGER
* The block size. If needed, NB >= 1.
*
* Notes
* =====
*
* In the comments below, the association is given between arguments
* in the requested subroutine and local arguments. For example,
*
* xGETRS: N, NRHS => M, N
*
* means that arguments N and NRHS in SGETRS are passed to arguments
* M and N in this procedure.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL CORZ, SORD
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 C3
INTEGER I
REAL ADDFAC, ADDS, EK, EM, EMN, EN, MULFAC, MULTS,
$ WL, WU
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* --------------------------------------------------------
* Initialize SOPLA to 0 and do a quick return if possible.
* --------------------------------------------------------
*
SOPLA = 0
MULTS = 0
ADDS = 0
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
SORD = LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' )
CORZ = LSAME( C1, 'C' ) .OR. LSAME( C1, 'Z' )
IF( M.LE.0 .OR. .NOT.( SORD .OR. CORZ ) )
$ RETURN
*
* ---------------------------------------------------------
* If the coefficient matrix is real, count each add as 1
* operation and each multiply as 1 operation.
* If the coefficient matrix is complex, count each add as 2
* operations and each multiply as 6 operations.
* ---------------------------------------------------------
*
IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN
ADDFAC = 1
MULFAC = 1
ELSE
ADDFAC = 2
MULFAC = 6
END IF
EM = M
EN = N
EK = KL
*
* ---------------------------------
* GE: GEneral rectangular matrices
* ---------------------------------
*
IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
* xGETRF: M, N => M, N
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
EMN = MIN( M, N )
ADDS = EMN*( EM*EN-( EM+EN )*( EMN+1. ) / 2.+( EMN+1. )*
$ ( 2.*EMN+1. ) / 6. )
MULTS = ADDS + EMN*( EM-( EMN+1. ) / 2. )
*
* xGETRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*EM*EM
ADDS = EN*( EM*( EM-1. ) )
*
* xGETRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 5. / 6.+EM*( 1. / 2.+EM*( 2. / 3. ) ) )
ADDS = EM*( 5. / 6.+EM*( -3. / 2.+EM*( 2. / 3. ) ) )
*
* xGEQRF or xGEQLF: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'QRF' ) .OR.
$ LSAMEN( 3, C3, 'QR2' ) .OR.
$ LSAMEN( 3, C3, 'QLF' ) .OR. LSAMEN( 3, C3, 'QL2' ) )
$ THEN
IF( M.GE.N ) THEN
MULTS = EN*( ( ( 23. / 6. )+EM+EN / 2. )+EN*
$ ( EM-EN / 3. ) )
ADDS = EN*( ( 5. / 6. )+EN*( 1. / 2.+( EM-EN / 3. ) ) )
ELSE
MULTS = EM*( ( ( 23. / 6. )+2.*EN-EM / 2. )+EM*
$ ( EN-EM / 3. ) )
ADDS = EM*( ( 5. / 6. )+EN-EM / 2.+EM*( EN-EM / 3. ) )
END IF
*
* xGERQF or xGELQF: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'RQF' ) .OR.
$ LSAMEN( 3, C3, 'RQ2' ) .OR.
$ LSAMEN( 3, C3, 'LQF' ) .OR. LSAMEN( 3, C3, 'LQ2' ) )
$ THEN
IF( M.GE.N ) THEN
MULTS = EN*( ( ( 29. / 6. )+EM+EN / 2. )+EN*
$ ( EM-EN / 3. ) )
ADDS = EN*( ( 5. / 6. )+EM+EN*
$ ( -1. / 2.+( EM-EN / 3. ) ) )
ELSE
MULTS = EM*( ( ( 29. / 6. )+2.*EN-EM / 2. )+EM*
$ ( EN-EM / 3. ) )
ADDS = EM*( ( 5. / 6. )+EM / 2.+EM*( EN-EM / 3. ) )
END IF
*
* xGEQPF: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'QPF' ) ) THEN
EMN = MIN( M, N )
MULTS = 2*EN*EN + EMN*( 3*EM+5*EN+2*EM*EN-( EMN+1 )*
$ ( 4+EN+EM-( 2*EMN+1 ) / 3 ) )
ADDS = EN*EN + EMN*( 2*EM+EN+2*EM*EN-( EMN+1 )*
$ ( 2+EN+EM-( 2*EMN+1 ) / 3 ) )
*
* xGEQRS or xGERQS: M, N, NRHS => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'QRS' ) .OR. LSAMEN( 3, C3, 'RQS' ) )
$ THEN
MULTS = EK*( EN*( 2.-EK )+EM*( 2.*EN+( EM+1. ) / 2. ) )
ADDS = EK*( EN*( 1.-EK )+EM*( 2.*EN+( EM-1. ) / 2. ) )
*
* xGELQS or xGEQLS: M, N, NRHS => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'LQS' ) .OR. LSAMEN( 3, C3, 'QLS' ) )
$ THEN
MULTS = EK*( EM*( 2.-EK )+EN*( 2.*EM+( EN+1. ) / 2. ) )
ADDS = EK*( EM*( 1.-EK )+EN*( 2.*EM+( EN-1. ) / 2. ) )
*
* xGEBRD: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'BRD' ) ) THEN
IF( M.GE.N ) THEN
MULTS = EN*( 20. / 3.+EN*( 2.+( 2.*EM-( 2. / 3. )*
$ EN ) ) )
ADDS = EN*( 5. / 3.+( EN-EM )+EN*
$ ( 2.*EM-( 2. / 3. )*EN ) )
ELSE
MULTS = EM*( 20. / 3.+EM*( 2.+( 2.*EN-( 2. / 3. )*
$ EM ) ) )
ADDS = EM*( 5. / 3.+( EM-EN )+EM*
$ ( 2.*EN-( 2. / 3. )*EM ) )
END IF
*
* xGEHRD: N => M
*
ELSE IF( LSAMEN( 3, C3, 'HRD' ) ) THEN
IF( M.EQ.1 ) THEN
MULTS = 0.
ADDS = 0.
ELSE
MULTS = -13. + EM*( -7. / 6.+EM*( 0.5+EM*( 5. / 3. ) ) )
ADDS = -8. + EM*( -2. / 3.+EM*( -1.+EM*( 5. / 3. ) ) )
END IF
*
END IF
*
* ----------------------------
* GB: General Banded matrices
* ----------------------------
* Note: The operation count is overestimated because
* it is assumed that the factor U fills in to the maximum
* extent, i.e., that its bandwidth goes from KU to KL + KU.
*
ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
*
* xGBTRF: M, N, KL, KU => M, N, KL, KU
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
DO 10 I = MIN( M, N ), 1, -1
WL = MAX( 0, MIN( KL, M-I ) )
WU = MAX( 0, MIN( KL+KU, N-I ) )
MULTS = MULTS + WL*( 1.+WU )
ADDS = ADDS + WL*WU
10 CONTINUE
*
* xGBTRS: N, NRHS, KL, KU => M, N, KL, KU
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
WL = MAX( 0, MIN( KL, M-1 ) )
WU = MAX( 0, MIN( KL+KU, M-1 ) )
MULTS = EN*( EM*( WL+1.+WU )-0.5*
$ ( WL*( WL+1. )+WU*( WU+1. ) ) )
ADDS = EN*( EM*( WL+WU )-0.5*( WL*( WL+1. )+WU*( WU+1. ) ) )
*
END IF
*
* --------------------------------------
* PO: POsitive definite matrices
* PP: Positive definite Packed matrices
* --------------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'PP' ) ) THEN
*
* xPOTRF: N => M
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = EM*( 1. / 3.+EM*( 1. / 2.+EM*( 1. / 6. ) ) )
ADDS = ( 1. / 6. )*EM*( -1.+EM*EM )
*
* xPOTRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*( EM*( EM+1. ) )
ADDS = EN*( EM*( EM-1. ) )
*
* xPOTRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 2. / 3.+EM*( 1.+EM*( 1. / 3. ) ) )
ADDS = EM*( 1. / 6.+EM*( -1. / 2.+EM*( 1. / 3. ) ) )
*
END IF
*
* ------------------------------------
* PB: Positive definite Band matrices
* ------------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN
*
* xPBTRF: N, K => M, KL
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = EK*( -2. / 3.+EK*( -1.+EK*( -1. / 3. ) ) ) +
$ EM*( 1.+EK*( 3. / 2.+EK*( 1. / 2. ) ) )
ADDS = EK*( -1. / 6.+EK*( -1. / 2.+EK*( -1. / 3. ) ) ) +
$ EM*( EK / 2.*( 1.+EK ) )
*
* xPBTRS: N, NRHS, K => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*( ( 2*EM-EK )*( EK+1. ) )
ADDS = EN*( EK*( 2*EM-( EK+1. ) ) )
*
END IF
*
* ----------------------------------
* PT: Positive definite Tridiagonal
* ----------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'PT' ) ) THEN
*
* xPTTRF: N => M
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = 2*( EM-1 )
ADDS = EM - 1
*
* xPTTRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*( 3*EM-2 )
ADDS = EN*( 2*( EM-1 ) )
*
* xPTSV: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
MULTS = 2*( EM-1 ) + EN*( 3*EM-2 )
ADDS = EM - 1 + EN*( 2*( EM-1 ) )
END IF
*
* --------------------------------------------------------
* SY: SYmmetric indefinite matrices
* SP: Symmetric indefinite Packed matrices
* HE: HErmitian indefinite matrices (complex only)
* HP: Hermitian indefinite Packed matrices (complex only)
* --------------------------------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHP' ) ) THEN
*
* xSYTRF: N => M
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = EM*( 10. / 3.+EM*( 1. / 2.+EM*( 1. / 6. ) ) )
ADDS = EM / 6.*( -1.+EM*EM )
*
* xSYTRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*EM*EM
ADDS = EN*( EM*( EM-1. ) )
*
* xSYTRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 2. / 3.+EM*EM*( 1. / 3. ) )
ADDS = EM*( -1. / 3.+EM*EM*( 1. / 3. ) )
*
* xSYTRD, xSYTD2: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRD' ) .OR. LSAMEN( 3, C3, 'TD2' ) )
$ THEN
IF( M.EQ.1 ) THEN
MULTS = 0.
ADDS = 0.
ELSE
MULTS = -15. + EM*( -1. / 6.+EM*
$ ( 5. / 2.+EM*( 2. / 3. ) ) )
ADDS = -4. + EM*( -8. / 3.+EM*( 1.+EM*( 2. / 3. ) ) )
END IF
END IF
*
* -------------------
* Triangular matrices
* -------------------
*
ELSE IF( LSAMEN( 2, C2, 'TR' ) .OR. LSAMEN( 2, C2, 'TP' ) ) THEN
*
* xTRTRS: N, NRHS => M, N
*
IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*EM*( EM+1. ) / 2.
ADDS = EN*EM*( EM-1. ) / 2.
*
* xTRTRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 1. / 3.+EM*( 1. / 2.+EM*( 1. / 6. ) ) )
ADDS = EM*( 1. / 3.+EM*( -1. / 2.+EM*( 1. / 6. ) ) )
*
END IF
*
ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
*
* xTBTRS: N, NRHS, K => M, N, KL
*
IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*( EM*( EM+1. ) / 2.-( EM-EK-1. )*( EM-EK ) / 2. )
ADDS = EN*( EM*( EM-1. ) / 2.-( EM-EK-1. )*( EM-EK ) / 2. )
END IF
*
* --------------------
* Trapezoidal matrices
* --------------------
*
ELSE IF( LSAMEN( 2, C2, 'TZ' ) ) THEN
*
* xTZRQF: M, N => M, N
*
IF( LSAMEN( 3, C3, 'RQF' ) ) THEN
EMN = MIN( M, N )
MULTS = 3*EM*( EN-EM+1 ) + ( 2*EN-2*EM+3 )*
$ ( EM*EM-EMN*( EMN+1 ) / 2 )
ADDS = ( EN-EM+1 )*( EM+2*EM*EM-EMN*( EMN+1 ) )
END IF
*
* -------------------
* Orthogonal matrices
* -------------------
*
ELSE IF( ( SORD .AND. LSAMEN( 2, C2, 'OR' ) ) .OR.
$ ( CORZ .AND. LSAMEN( 2, C2, 'UN' ) ) ) THEN
*
* -MQR, -MLQ, -MQL, or -MRQ: M, N, K, SIDE => M, N, KL, KU
* where KU<= 0 indicates SIDE = 'L'
* and KU> 0 indicates SIDE = 'R'
*
IF( LSAMEN( 3, C3, 'MQR' ) .OR. LSAMEN( 3, C3, 'MLQ' ) .OR.
$ LSAMEN( 3, C3, 'MQL' ) .OR. LSAMEN( 3, C3, 'MRQ' ) ) THEN
IF( KU.LE.0 ) THEN
MULTS = EK*EN*( 2.*EM+2.-EK )
ADDS = EK*EN*( 2.*EM+1.-EK )
ELSE
MULTS = EK*( EM*( 2.*EN-EK )+( EM+EN+( 1.-EK ) / 2. ) )
ADDS = EK*EM*( 2.*EN+1.-EK )
END IF
*
* -GQR or -GQL: M, N, K => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'GQR' ) .OR. LSAMEN( 3, C3, 'GQL' ) )
$ THEN
MULTS = EK*( -5. / 3.+( 2.*EN-EK )+
$ ( 2.*EM*EN+EK*( ( 2. / 3. )*EK-EM-EN ) ) )
ADDS = EK*( 1. / 3.+( EN-EM )+
$ ( 2.*EM*EN+EK*( ( 2. / 3. )*EK-EM-EN ) ) )
*
* -GLQ or -GRQ: M, N, K => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'GLQ' ) .OR. LSAMEN( 3, C3, 'GRQ' ) )
$ THEN
MULTS = EK*( -2. / 3.+( EM+EN-EK )+
$ ( 2.*EM*EN+EK*( ( 2. / 3. )*EK-EM-EN ) ) )
ADDS = EK*( 1. / 3.+( EM-EN )+
$ ( 2.*EM*EN+EK*( ( 2. / 3. )*EK-EM-EN ) ) )
*
END IF
*
END IF
*
SOPLA = MULFAC*MULTS + ADDFAC*ADDS
*
RETURN
*
* End of SOPLA
*
END
SUBROUTINE SPRTB2( LAB1, LAB2, LAB3, NN, NVAL, NLDA, RESLTS, LDR1,
$ LDR2, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*( * ) LAB1, LAB2, LAB3
INTEGER LDR1, LDR2, NLDA, NN, NOUT
* ..
* .. Array Arguments ..
INTEGER NVAL( NN )
REAL RESLTS( LDR1, LDR2, * )
* ..
*
* Purpose
* =======
*
* SPRTB2 prints a table of timing data for the solve routines.
* There are 4 rows to each table, corresponding to
* NRHS = 1, 2, N/2, and N, or NRHS = 1, 2, K/2, K for the
* band routines.
*
* Arguments
* =========
*
* LAB1 (input) CHARACTER*(*)
* The label for the rows.
*
* LAB2 (input) CHARACTER*(*)
* The label for the columns.
*
* LAB3 CHARACTER*(*)
* The name of the variable used in the row headers (usually
* N or K).
*
* NN (input) INTEGER
* The number of values of NVAL, and also the number of columns
* of the table.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of LAB2 used for the data in each column.
*
* NLDA (input) INTEGER
* The number of values of LDA, hence the number of rows for
* each value of NRHS.
*
* RESLTS (input) REAL array, dimension (LDR1, LDR2, NLDA)
* The timing results for each value of N, K, and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= 4.
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max( 1, NN ).
*
* NOUT (input) INTEGER
* The unit number on which the table is to be printed.
* NOUT >= 0.
*
* =====================================================================
*
* .. Local Scalars ..
CHARACTER*6 COLLAB
INTEGER I, IC, INB, J, K, LNB
* ..
* .. Intrinsic Functions ..
INTRINSIC LEN, MAX
* ..
* .. Executable Statements ..
*
IF( NOUT.LE.0 )
$ RETURN
WRITE( NOUT, FMT = 9999 )LAB2, ( NVAL( I ), I = 1, NN )
WRITE( NOUT, FMT = 9998 )LAB1
*
* Find the first and last non-blank characters in LAB3.
*
INB = 0
DO 10 I = 1, LEN( LAB3 )
IF( INB.EQ.0 .AND. LAB3( I: I ).NE.' ' )
$ INB = I
IF( LAB3( I: I ).NE.' ' )
$ LNB = I
10 CONTINUE
IF( INB.EQ.0 ) THEN
INB = 1
LNB = 1
END IF
*
DO 50 I = 1, 4
IF( I.EQ.1 ) THEN
COLLAB = ' 1'
ELSE IF( I.EQ.2 ) THEN
COLLAB = ' 2'
ELSE IF( I.EQ.3 ) THEN
COLLAB = ' /2'
DO 20 J = LNB, MAX( INB, LNB-3 ), -1
IC = 4 - ( LNB-J )
COLLAB( IC: IC ) = LAB3( J: J )
20 CONTINUE
ELSE IF( I.EQ.4 ) THEN
COLLAB = ' '
DO 30 J = LNB, MAX( INB, LNB-5 ), -1
IC = 6 - ( LNB-J )
COLLAB( IC: IC ) = LAB3( J: J )
30 CONTINUE
END IF
WRITE( NOUT, FMT = 9997 )COLLAB,
$ ( RESLTS( I, J, 1 ), J = 1, NN )
DO 40 K = 2, NLDA
WRITE( NOUT, FMT = 9996 )( RESLTS( I, J, K ), J = 1, NN )
40 CONTINUE
IF( NLDA.GT.1 )
$ WRITE( NOUT, FMT = * )
50 CONTINUE
IF( NLDA.EQ.1 )
$ WRITE( NOUT, FMT = * )
*
9999 FORMAT( 6X, A4, I6, 11I8 )
9998 FORMAT( 3X, A4 )
9997 FORMAT( 1X, A6, 1X, 12F8.1 )
9996 FORMAT( 8X, 12F8.1 )
*
RETURN
*
* End of SPRTB2
*
END
SUBROUTINE SPRTB3( LAB1, LAB2, NK, KVAL, LVAL, NN, NVAL, NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*( * ) LAB1, LAB2
INTEGER LDR1, LDR2, NK, NLDA, NN, NOUT
* ..
* .. Array Arguments ..
INTEGER KVAL( NK ), LVAL( NK ), NVAL( NN )
REAL RESLTS( LDR1, LDR2, * )
* ..
*
* Purpose
* =======
*
* SPRTB3 prints a table of timing data for the timing programs.
* The table has NK block rows and NN columns, with NLDA
* individual rows in each block row. Each block row depends on two
* parameters K and L, specified as an ordered pair in the arrays KVAL
* and LVAL.
*
* Arguments
* =========
*
* LAB1 (input) CHARACTER*(*)
* The label for the rows.
*
* LAB2 (input) CHARACTER*(*)
* The label for the columns.
*
* NK (input) INTEGER
* The number of values of KVAL, and also the number of block
* rows of the table.
*
* KVAL (input) INTEGER array, dimension (NK)
* The values of the parameter K. Each block row depends on
* the pair of parameters (K, L).
*
* LVAL (input) INTEGER array, dimension (NK)
* The values of the parameter L. Each block row depends on
* the pair of parameters (K, L).
*
* NN (input) INTEGER
* The number of values of NVAL, and also the number of columns
* of the table.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of N used for the data in each column.
*
* NLDA (input) INTEGER
* The number of values of LDA, hence the number of rows for
* each value of KVAL.
*
* RESLTS (input) REAL array, dimension (LDR1, LDR2, NLDA)
* The timing results for each value of N, K, and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NK).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NN).
*
* NOUT (input) INTEGER
* The unit number on which the table is to be printed.
* NOUT >= 0.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J, K
* ..
* .. Executable Statements ..
*
IF( NOUT.LE.0 )
$ RETURN
WRITE( NOUT, FMT = 9999 )LAB2, ( NVAL( I ), I = 1, NN )
WRITE( NOUT, FMT = 9998 )LAB1
*
DO 20 I = 1, NK
IF( LAB1.EQ.' ' ) THEN
WRITE( NOUT, FMT = 9996 )( RESLTS( 1, J, 1 ), J = 1, NN )
ELSE
WRITE( NOUT, FMT = 9997 )KVAL( I ), LVAL( I ),
$ ( RESLTS( I, J, 1 ), J = 1, NN )
END IF
DO 10 K = 2, NLDA
WRITE( NOUT, FMT = 9996 )( RESLTS( I, J, K ), J = 1, NN )
10 CONTINUE
IF( NLDA.GT.1 )
$ WRITE( NOUT, FMT = * )
20 CONTINUE
IF( NLDA.EQ.1 )
$ WRITE( NOUT, FMT = * )
RETURN
*
9999 FORMAT( 10X, A4, I7, 11I8 )
9998 FORMAT( 1X, A11 )
9997 FORMAT( 1X, '(', I4, ',', I4, ') ', 12F8.1 )
9996 FORMAT( 13X, 12F8.1 )
*
* End of SPRTB3
*
END
SUBROUTINE SPRTB4( LAB1, LABM, LABN, NK, KVAL, LVAL, NM, MVAL,
$ NVAL, NLDA, RESLTS, LDR1, LDR2, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*( * ) LAB1, LABM, LABN
INTEGER LDR1, LDR2, NK, NLDA, NM, NOUT
* ..
* .. Array Arguments ..
INTEGER KVAL( NK ), LVAL( NK ), MVAL( NM ), NVAL( NM )
REAL RESLTS( LDR1, LDR2, * )
* ..
*
* Purpose
* =======
*
* SPRTB4 prints a table of timing data for the timing programs.
* The table has NK block rows and NM columns, with NLDA
* individual rows in each block row. Each block row depends on two
* parameters K and L, specified as an ordered pair in the arrays KVAL
* and LVAL, and each column depends on two parameters M and N,
* specified as an ordered pair in the arrays MVAL and NVAL.
*
* Arguments
* =========
*
* LAB1 (input) CHARACTER*(*)
* The label for the rows.
*
* LABM (input) CHARACTER*(*)
* The first label for the columns.
*
* LABN (input) CHARACTER*(*)
* The second label for the columns.
*
* NK (input) INTEGER
* The number of values of KVAL and LVAL, and also the number of
* block rows of the table. Each block row depends on the pair
* of parameters (K,L).
*
* KVAL (input) INTEGER array, dimension (NK)
* The values of the parameter K.
*
* LVAL (input) INTEGER array, dimension (NK)
* The values of the parameter L.
*
* NM (input) INTEGER
* The number of values of MVAL and NVAL, and also the number of
* columns of the table. Each column depends on the pair of
* parameters (M,N).
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the parameter M.
*
* NVAL (input) INTEGER array, dimension (NM)
* The values of the parameter N.
*
* NLDA (input) INTEGER
* The number of values of LDA, hence the number of rows for
* each pair of values (K,L).
*
* RESLTS (input) REAL array, dimension (LDR1, LDR2, NLDA)
* The timing results for each value of (M,N), (K,L), and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NK).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NM).
*
* NOUT (input) INTEGER
* The unit number on which the table is to be printed.
* NOUT >= 0.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J, K
* ..
* .. Executable Statements ..
*
IF( NOUT.LE.0 )
$ RETURN
WRITE( NOUT, FMT = 9999 )LABM, ( MVAL( I ), I = 1, NM )
WRITE( NOUT, FMT = 9999 )LABN, ( NVAL( I ), I = 1, NM )
WRITE( NOUT, FMT = 9998 )LAB1
*
DO 20 I = 1, NK
IF( LAB1.EQ.' ' ) THEN
WRITE( NOUT, FMT = 9996 )( RESLTS( 1, J, 1 ), J = 1, NM )
ELSE
WRITE( NOUT, FMT = 9997 )KVAL( I ), LVAL( I ),
$ ( RESLTS( I, J, 1 ), J = 1, NM )
END IF
DO 10 K = 2, NLDA
WRITE( NOUT, FMT = 9996 )( RESLTS( I, J, K ), J = 1, NM )
10 CONTINUE
IF( NLDA.GT.1 )
$ WRITE( NOUT, FMT = * )
20 CONTINUE
IF( NLDA.EQ.1 )
$ WRITE( NOUT, FMT = * )
RETURN
*
9999 FORMAT( 10X, A4, I7, 11I8 )
9998 FORMAT( 1X, A11 )
9997 FORMAT( 1X, '(', I4, ',', I4, ') ', 12F8.1 )
9996 FORMAT( 13X, 12F8.1 )
*
* End of SPRTB4
*
END
SUBROUTINE SPRTB5( LAB1, LABM, LABN, NK, KVAL, NM, MVAL, NVAL,
$ NLDA, RESLTS, LDR1, LDR2, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*( * ) LAB1, LABM, LABN
INTEGER LDR1, LDR2, NK, NLDA, NM, NOUT
* ..
* .. Array Arguments ..
INTEGER KVAL( NK ), MVAL( NM ), NVAL( NM )
REAL RESLTS( LDR1, LDR2, * )
* ..
*
* Purpose
* =======
*
* SPRTB5 prints a table of timing data for the timing programs.
* The table has NK block rows and NM columns, with NLDA
* individual rows in each block row. Each column depends on two
* parameters M and N, specified as an ordered pair in the arrays MVAL
* and NVAL.
*
* Arguments
* =========
*
* LAB1 (input) CHARACTER*(*)
* The label for the rows.
*
* LABM (input) CHARACTER*(*)
* The first label for the columns.
*
* LABN (input) CHARACTER*(*)
* The second label for the columns.
*
* NK (input) INTEGER
* The number of values of KVAL, and also the number of block
* rows of the table.
*
* KVAL (input) INTEGER array, dimension (NK)
* The values of LAB1 used for the data in each block row.
*
* NM (input) INTEGER
* The number of values of MVAL and NVAL, and also the number of
* columns of the table. Each column depends on the pair of
* parameters (M,N).
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the parameter M.
*
* NVAL (input) INTEGER array, dimension (NM)
* The values of the parameter N.
*
* NLDA (input) INTEGER
* The number of values of LDA, hence the number of rows for
* each value of KVAL.
*
* RESLTS (input) REAL array, dimension (LDR1, LDR2, NLDA)
* The timing results for each value of N, K, and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NK).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NM).
*
* NOUT (input) INTEGER
* The unit number on which the table is to be printed.
* NOUT >= 0.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J, K
* ..
* .. Executable Statements ..
*
IF( NOUT.LE.0 )
$ RETURN
WRITE( NOUT, FMT = 9999 )LABM, ( MVAL( I ), I = 1, NM )
WRITE( NOUT, FMT = 9999 )LABN, ( NVAL( I ), I = 1, NM )
WRITE( NOUT, FMT = 9998 )LAB1
*
DO 20 I = 1, NK
IF( LAB1.EQ.' ' ) THEN
WRITE( NOUT, FMT = 9996 )( RESLTS( 1, J, 1 ), J = 1, NM )
ELSE
WRITE( NOUT, FMT = 9997 )KVAL( I ),
$ ( RESLTS( I, J, 1 ), J = 1, NM )
END IF
DO 10 K = 2, NLDA
WRITE( NOUT, FMT = 9996 )( RESLTS( I, J, K ), J = 1, NM )
10 CONTINUE
IF( NLDA.GT.1 )
$ WRITE( NOUT, FMT = * )
20 CONTINUE
IF( NLDA.EQ.1 )
$ WRITE( NOUT, FMT = * )
RETURN
*
9999 FORMAT( 6X, A4, I6, 11I8 )
9998 FORMAT( 3X, A4 )
9997 FORMAT( 1X, I6, 1X, 12F8.1 )
9996 FORMAT( 8X, 12F8.1 )
*
* End of SPRTB5
*
END
SUBROUTINE SPRTBL( LAB1, LAB2, NK, KVAL, NN, NVAL, NLDA, RESLTS,
$ LDR1, LDR2, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*( * ) LAB1, LAB2
INTEGER LDR1, LDR2, NK, NLDA, NN, NOUT
* ..
* .. Array Arguments ..
INTEGER KVAL( NK ), NVAL( NN )
REAL RESLTS( LDR1, LDR2, * )
* ..
*
* Purpose
* =======
*
* SPRTBL prints a table of timing data for the timing programs.
* The table has NK block rows and NN columns, with NLDA
* individual rows in each block row.
*
* Arguments
* =========
*
* LAB1 (input) CHARACTER*(*)
* The label for the rows.
*
* LAB2 (input) CHARACTER*(*)
* The label for the columns.
*
* NK (input) INTEGER
* The number of values of KVAL, and also the number of block
* rows of the table.
*
* KVAL (input) INTEGER array, dimension (NK)
* The values of LAB1 used for the data in each block row.
*
* NN (input) INTEGER
* The number of values of NVAL, and also the number of columns
* of the table.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of LAB2 used for the data in each column.
*
* NLDA (input) INTEGER
* The number of values of LDA, hence the number of rows for
* each value of KVAL.
*
* RESLTS (input) REAL array, dimension (LDR1, LDR2, NLDA)
* The timing results for each value of N, K, and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max( 1, NK ).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max( 1, NN ).
*
* NOUT (input) INTEGER
* The unit number on which the table is to be printed.
* NOUT >= 0.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J, K
* ..
* .. Executable Statements ..
*
IF( NOUT.LE.0 )
$ RETURN
WRITE( NOUT, FMT = 9999 )LAB2, ( NVAL( I ), I = 1, NN )
WRITE( NOUT, FMT = 9998 )LAB1
*
DO 20 I = 1, NK
IF( LAB1.EQ.' ' ) THEN
WRITE( NOUT, FMT = 9996 )( RESLTS( 1, J, 1 ), J = 1, NN )
ELSE
WRITE( NOUT, FMT = 9997 )KVAL( I ),
$ ( RESLTS( I, J, 1 ), J = 1, NN )
END IF
DO 10 K = 2, NLDA
WRITE( NOUT, FMT = 9996 )( RESLTS( I, J, K ), J = 1, NN )
10 CONTINUE
IF( NLDA.GT.1 )
$ WRITE( NOUT, FMT = * )
20 CONTINUE
IF( NLDA.EQ.1 )
$ WRITE( NOUT, FMT = * )
RETURN
*
9999 FORMAT( 6X, A4, I6, 11I8 )
9998 FORMAT( 3X, A4 )
9997 FORMAT( 1X, I6, 1X, 12F8.1 )
9996 FORMAT( 8X, 12F8.1 )
*
* End of SPRTBL
*
END
SUBROUTINE SPRTLS( ISUB, SUBNAM, NDATA, NM, MVAL, NN, NVAL,
$ NNS, NSVAL, NNB, NBVAL, NXVAL, NLDA, LDAVAL,
$ MTYPE, RSLTS, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
INTEGER ISUB, MTYPE, NDATA, NLDA, NM, NN, NNB,
$ NNS, NOUT
* ..
* .. Array Arguments ..
INTEGER LDAVAL( * ), MVAL( * ), NBVAL( * ),
$ NSVAL( * ), NVAL( * ), NXVAL( * )
REAL RSLTS( 6, 6, * )
* ..
*
* Purpose
* =======
*
* SPRTLS prints a table of timing data for the least squares routines.
*
* Arguments
* =========
*
* ISUB (input) INTEGER
* Subroutine index.
*
* SUBNAM (input) CHARACTER*6
* Subroutine name.
*
* NDATA (input) INTEGER
* Number of components for subroutine SUBNAM.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* MTYPE (input) INTEGER
* Number of matrix types.
*
* RSLTS (workspace) REAL array
* dimension( 6, 6, number of runs )
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER ICASE, IDATA, ILDA, IM, IN, INB, INS,
$ ITYPE, LDA, M, N, NB, NRHS, NX
* ..
* .. Executable Statements ..
*
ICASE = 1
*
DO 70 IM = 1, NM
M = MVAL( IM )
DO 60 IN = 1, NN
N = NVAL( IN )
DO 50 INS = 1, NNS
NRHS = NSVAL( INS )
DO 40 ILDA = 1, NLDA
LDA = MAX( 1, LDAVAL( ILDA ) )
IF( ISUB.EQ.2 ) THEN
WRITE( NOUT, FMT = 9999 ) M, N, NRHS, LDA
WRITE( NOUT, FMT = 9998 ) SUBNAM, ( IDATA,
$ IDATA = 1, NDATA-1 )
DO 10 ITYPE = 1, MTYPE
WRITE( NOUT, FMT = 9997 ) ITYPE,
$ ( RSLTS( IDATA, ITYPE, ICASE ),
$ IDATA = 1, NDATA )
10 CONTINUE
ICASE = ICASE + 1
ELSE
DO 30 INB = 1, NNB
NB = NBVAL( INB )
NX = NXVAL( INB )
WRITE( NOUT, FMT = 9996 ) M, N, NRHS, LDA,
$ NB, NX
WRITE( NOUT, FMT = 9998 ) SUBNAM, ( IDATA,
$ IDATA = 1, NDATA-1 )
DO 20 ITYPE = 1, MTYPE
WRITE( NOUT, FMT = 9997 ) ITYPE,
$ ( RSLTS( IDATA, ITYPE, ICASE ),
$ IDATA = 1, NDATA )
20 CONTINUE
ICASE = ICASE + 1
30 CONTINUE
END IF
40 CONTINUE
50 CONTINUE
60 CONTINUE
70 CONTINUE
*
9999 FORMAT( / ' M = ', I5, ', N = ', I5, ', NRHS = ', I5,
$ ', LDA = ', I5 )
9998 FORMAT( / ' TYPE ', 4X, A6, 1X, 8( 4X, 'comp.', I2, : ) )
9997 FORMAT( I5, 2X, 1P, 6G11.2 )
9996 FORMAT( / ' M = ', I5, ', N = ', I5, ', NRHS = ', I5,
$ ', LDA = ', I5, ', NB = ', I3, ', NX = ', I3 )
RETURN
*
* End of SPRTLS
*
END
SUBROUTINE SQRT13( SCALE, M, N, A, LDA, NORMA, ISEED )
*
* -- LAPACK test routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
INTEGER LDA, M, N, SCALE
REAL NORMA
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
REAL A( LDA, * )
* ..
*
* Purpose
* =======
*
* SQRT13 generates a full-rank matrix that may be scaled to have large
* or small norm.
*
* Arguments
* =========
*
* SCALE (input) INTEGER
* SCALE = 1: normally scaled matrix
* SCALE = 2: matrix scaled up
* SCALE = 3: matrix scaled down
*
* M (input) INTEGER
* The number of rows of the matrix A.
*
* N (input) INTEGER
* The number of columns of A.
*
* A (output) REAL array, dimension (LDA,N)
* The M-by-N matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A.
*
* NORMA (output) REAL
* The one-norm of A.
*
* ISEED (input/output) integer array, dimension (4)
* Seed for random number generator
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E0 )
* ..
* .. Local Scalars ..
INTEGER INFO, J
REAL BIGNUM, SMLNUM
* ..
* .. External Functions ..
REAL SASUM, SLAMCH, SLANGE
EXTERNAL SASUM, SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SLABAD, SLARNV, SLASCL
* ..
* .. Intrinsic Functions ..
INTRINSIC SIGN
* ..
* .. Local Arrays ..
REAL DUMMY( 1 )
* ..
* .. Executable Statements ..
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
* benign matrix
*
DO 10 J = 1, N
CALL SLARNV( 2, ISEED, M, A( 1, J ) )
IF( J.LE.M ) THEN
A( J, J ) = A( J, J ) + SIGN( SASUM( M, A( 1, J ), 1 ),
$ A( J, J ) )
END IF
10 CONTINUE
*
* scaled versions
*
IF( SCALE.NE.1 ) THEN
NORMA = SLANGE( 'Max', M, N, A, LDA, DUMMY )
SMLNUM = SLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
SMLNUM = SMLNUM / SLAMCH( 'Epsilon' )
BIGNUM = ONE / SMLNUM
*
IF( SCALE.EQ.2 ) THEN
*
* matrix scaled up
*
CALL SLASCL( 'General', 0, 0, NORMA, BIGNUM, M, N, A, LDA,
$ INFO )
ELSE IF( SCALE.EQ.3 ) THEN
*
* matrix scaled down
*
CALL SLASCL( 'General', 0, 0, NORMA, SMLNUM, M, N, A, LDA,
$ INFO )
END IF
END IF
*
NORMA = SLANGE( 'One-norm', M, N, A, LDA, DUMMY )
RETURN
*
* End of SQRT13
*
END
SUBROUTINE SQRT15( SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S,
$ RANK, NORMA, NORMB, ISEED, WORK, LWORK )
*
* -- LAPACK test routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
INTEGER LDA, LDB, LWORK, M, N, NRHS, RANK, RKSEL, SCALE
REAL NORMA, NORMB
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
REAL A( LDA, * ), B( LDB, * ), S( * ), WORK( LWORK )
* ..
*
* Purpose
* =======
*
* SQRT15 generates a matrix with full or deficient rank and of various
* norms.
*
* Arguments
* =========
*
* SCALE (input) INTEGER
* SCALE = 1: normally scaled matrix
* SCALE = 2: matrix scaled up
* SCALE = 3: matrix scaled down
*
* RKSEL (input) INTEGER
* RKSEL = 1: full rank matrix
* RKSEL = 2: rank-deficient matrix
*
* M (input) INTEGER
* The number of rows of the matrix A.
*
* N (input) INTEGER
* The number of columns of A.
*
* NRHS (input) INTEGER
* The number of columns of B.
*
* A (output) REAL array, dimension (LDA,N)
* The M-by-N matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A.
*
* B (output) REAL array, dimension (LDB, NRHS)
* A matrix that is in the range space of matrix A.
*
* LDB (input) INTEGER
* The leading dimension of the array B.
*
* S (output) REAL array, dimension MIN(M,N)
* Singular values of A.
*
* RANK (output) INTEGER
* number of nonzero singular values of A.
*
* NORMA (output) REAL
* one-norm of A.
*
* NORMB (output) REAL
* one-norm of B.
*
* ISEED (input/output) integer array, dimension (4)
* seed for random number generator.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* length of work space required.
* LWORK >= MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M)
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO, SVMIN
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ SVMIN = 0.1E0 )
* ..
* .. Local Scalars ..
INTEGER INFO, J, MN
REAL BIGNUM, EPS, SMLNUM, TEMP
* ..
* .. Local Arrays ..
REAL DUMMY( 1 )
* ..
* .. External Functions ..
REAL SASUM, SLAMCH, SLANGE, SLARND, SNRM2
EXTERNAL SASUM, SLAMCH, SLANGE, SLARND, SNRM2
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SLAORD, SLARF, SLARNV, SLAROR, SLASCL,
$ SLASET, SSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
MN = MIN( M, N )
IF( LWORK.LT.MAX( M+MN, MN*NRHS, 2*N+M ) ) THEN
CALL XERBLA( 'SQRT15', 16 )
RETURN
END IF
*
SMLNUM = SLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
EPS = SLAMCH( 'Epsilon' )
SMLNUM = ( SMLNUM / EPS ) / EPS
BIGNUM = ONE / SMLNUM
*
* Determine rank and (unscaled) singular values
*
IF( RKSEL.EQ.1 ) THEN
RANK = MN
ELSE IF( RKSEL.EQ.2 ) THEN
RANK = ( 3*MN ) / 4
DO 10 J = RANK + 1, MN
S( J ) = ZERO
10 CONTINUE
ELSE
CALL XERBLA( 'SQRT15', 2 )
END IF
*
IF( RANK.GT.0 ) THEN
*
* Nontrivial case
*
S( 1 ) = ONE
DO 30 J = 2, RANK
20 CONTINUE
TEMP = SLARND( 1, ISEED )
IF( TEMP.GT.SVMIN ) THEN
S( J ) = ABS( TEMP )
ELSE
GO TO 20
END IF
30 CONTINUE
CALL SLAORD( 'Decreasing', RANK, S, 1 )
*
* Generate 'rank' columns of a random orthogonal matrix in A
*
CALL SLARNV( 2, ISEED, M, WORK )
CALL SSCAL( M, ONE / SNRM2( M, WORK, 1 ), WORK, 1 )
CALL SLASET( 'Full', M, RANK, ZERO, ONE, A, LDA )
CALL SLARF( 'Left', M, RANK, WORK, 1, TWO, A, LDA,
$ WORK( M+1 ) )
*
* workspace used: m+mn
*
* Generate consistent rhs in the range space of A
*
CALL SLARNV( 2, ISEED, RANK*NRHS, WORK )
CALL SGEMM( 'No transpose', 'No transpose', M, NRHS, RANK, ONE,
$ A, LDA, WORK, RANK, ZERO, B, LDB )
*
* work space used: <= mn *nrhs
*
* generate (unscaled) matrix A
*
DO 40 J = 1, RANK
CALL SSCAL( M, S( J ), A( 1, J ), 1 )
40 CONTINUE
IF( RANK.LT.N )
$ CALL SLASET( 'Full', M, N-RANK, ZERO, ZERO, A( 1, RANK+1 ),
$ LDA )
CALL SLAROR( 'Right', 'No initialization', M, N, A, LDA, ISEED,
$ WORK, INFO )
*
ELSE
*
* work space used 2*n+m
*
* Generate null matrix and rhs
*
DO 50 J = 1, MN
S( J ) = ZERO
50 CONTINUE
CALL SLASET( 'Full', M, N, ZERO, ZERO, A, LDA )
CALL SLASET( 'Full', M, NRHS, ZERO, ZERO, B, LDB )
*
END IF
*
* Scale the matrix
*
IF( SCALE.NE.1 ) THEN
NORMA = SLANGE( 'Max', M, N, A, LDA, DUMMY )
IF( NORMA.NE.ZERO ) THEN
IF( SCALE.EQ.2 ) THEN
*
* matrix scaled up
*
CALL SLASCL( 'General', 0, 0, NORMA, BIGNUM, M, N, A,
$ LDA, INFO )
CALL SLASCL( 'General', 0, 0, NORMA, BIGNUM, MN, 1, S,
$ MN, INFO )
CALL SLASCL( 'General', 0, 0, NORMA, BIGNUM, M, NRHS, B,
$ LDB, INFO )
ELSE IF( SCALE.EQ.3 ) THEN
*
* matrix scaled down
*
CALL SLASCL( 'General', 0, 0, NORMA, SMLNUM, M, N, A,
$ LDA, INFO )
CALL SLASCL( 'General', 0, 0, NORMA, SMLNUM, MN, 1, S,
$ MN, INFO )
CALL SLASCL( 'General', 0, 0, NORMA, SMLNUM, M, NRHS, B,
$ LDB, INFO )
ELSE
CALL XERBLA( 'SQRT15', 1 )
RETURN
END IF
END IF
END IF
*
NORMA = SASUM( MN, S, 1 )
NORMB = SLANGE( 'One-norm', M, NRHS, B, LDB, DUMMY )
*
RETURN
*
* End of SQRT15
*
END
PROGRAM STIMAA
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* Purpose
* =======
*
* STIMAA is the timing program for the REAL LAPACK
* routines. This program collects performance data for the factor,
* solve, and inverse routines used in solving systems of linear
* equations, and also for the orthogonal factorization and reduction
* routines used in solving least squares problems and matrix eigenvalue
* problems.
*
* The subprograms call a REAL function SECOND with no
* arguments which is assumed to return the central-processor time in
* seconds from some fixed starting time.
*
* The program is driven by a short data file, which specifies values
* for the matrix dimensions M, N and K, for the blocking parameters
* NB and NX, and for the leading array dimension LDA. A minimum time
* for each subroutine is included for timing small problems or for
* obtaining results on a machine with an inaccurate SECOND function.
*
* The matrix dimensions M, N, and K correspond to the three dimensions
* m, n, and k in the Level 3 BLAS. When timing the LAPACK routines for
* square matrices, M and N correspond to the matrix dimensions m and n,
* and K is the number of right-hand sides (nrhs) for the solves. When
* timing the LAPACK routines for band matrices, M is the matrix order
* m, N is the half-bandwidth (kl, ku, or kd in the LAPACK notation),
* and K is again the number of right-hand sides.
*
* The first 13 records of the data file are read using list-directed
* input. The first line of input is printed as the first line of
* output and can be used to identify different sets of results. To
* assist with debugging an input file, the values are printed out as
* they are read in.
*
* The following records are read using the format (A). For these
* records, the first 6 characters are reserved for the path or
* subroutine name. If a path name is used, the characters after the
* path name indicate the routines in the path to be timed, where
* 'T' or 't' means 'Time this routine'. If the line is blank after the
* path name, all routines in the path are timed. If fewer characters
* appear than routines in a path, the remaining characters are assumed
* to be 'F'. For example, the following 3 lines are equivalent ways of
* requesting timing of SGETRF:
* SGE T F F
* SGE T
* SGETRF
*
* An annotated example of a data file can be obtained by deleting the
* first 3 characters from the following 30 lines:
* LAPACK timing, REAL square matrices
* 5 Number of values of M
* 100 200 300 400 500 Values of M (row dimension)
* 5 Number of values of N
* 100 200 300 400 500 Values of N (column dimension)
* 2 Number of values of K
* 100 400 Values of K
* 5 Number of values of NB
* 1 16 32 48 64 Values of NB (blocksize)
* 0 48 128 128 128 Values of NX (crossover point)
* 2 Number of values of LDA
* 512 513 Values of LDA (leading dimension)
* 0.0 Minimum time in seconds
* SGE T T T
* SPO T T T
* SPP T T T
* SSY T T T
* SSP T T T
* STR T T
* STP T T
* SQR T T F
* SLQ T T F
* SQL T T F
* SRQ T T F
* SQP T
* SHR T T F F
* STD T T F F
* SBR T F F
* SLS T T T T T T
*
* The routines are timed for all combinations of applicable values of
* M, N, K, NB, NX, and LDA, and for all combinations of options such as
* UPLO and TRANS. For Level 2 BLAS timings, values of NB are used for
* INCX. Certain subroutines, such as the QR factorization, treat the
* values of M and N as ordered pairs and operate on M x N matrices.
*
* Internal Parameters
* ===================
*
* NMAX INTEGER
* The maximum value of M or N for square matrices.
*
* LDAMAX INTEGER
* The maximum value of LDA.
*
* NMAXB INTEGER
* The maximum value of N for band matrices.
*
* MAXVAL INTEGER
* The maximum number of values that can be read in for M, N,
* K, NB, or NX.
*
* MXNLDA INTEGER
* The maximum number of values that can be read in for LDA.
*
* NIN INTEGER
* The unit number for input. Currently set to 5 (std input).
*
* NOUT INTEGER
* The unit number for output. Currently set to 6 (std output).
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX, LDAMAX, NMAXB
PARAMETER ( NMAX = 512, LDAMAX = NMAX+20, NMAXB = 5000 )
INTEGER LA
PARAMETER ( LA = NMAX*LDAMAX )
INTEGER MAXVAL, MXNLDA
PARAMETER ( MAXVAL = 12, MXNLDA = 4 )
INTEGER MAXPRM
PARAMETER ( MAXPRM = MXNLDA*(MAXVAL+1) )
INTEGER MAXSZS
PARAMETER ( MAXSZS = MAXVAL*MAXVAL*MAXVAL )
INTEGER NIN, NOUT
PARAMETER ( NIN = 5, NOUT = 6 )
* ..
* .. Local Scalars ..
LOGICAL BLAS, LDAMOK, LDANOK, LDAOK, MOK, NOK, NXNBOK
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 C3
CHARACTER*80 LINE
INTEGER I, I2, J2, L, LDR1, LDR2, LDR3, MAXK, MAXLDA,
$ MAXM, MAXN, MAXNB, MKMAX, NEED, NK, NLDA, NM,
$ NN, NNB
REAL S1, S2, TIMMIN
* ..
* .. Local Arrays ..
INTEGER IWORK( 3*NMAXB ), KVAL( MAXVAL ),
$ LDAVAL( MXNLDA ), MVAL( MAXVAL ),
$ NBVAL( MAXVAL ), NVAL( MAXVAL ),
$ NXVAL( MAXVAL )
REAL A( LA, 3 ), B( LA, 3 ), D( 2*NMAX, 2 ),
$ FLPTBL( 6*6*MAXSZS*MAXPRM*5 ),
$ OPCTBL( 6*6*MAXSZS*MAXPRM*5 ),
$ RESLTS( MAXVAL, MAXVAL, 2*MXNLDA, 4*MAXVAL ),
$ S( NMAX*2 ), TIMTBL( 6*6*MAXSZS*MAXPRM*5 ),
$ WORK( NMAX, NMAX+MAXVAL+30 )
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
REAL SECOND
EXTERNAL LSAME, LSAMEN, SECOND
* ..
* .. External Subroutines ..
EXTERNAL STIMB2, STIMB3, STIMBR, STIMGB, STIMGE, STIMGT,
$ STIMHR, STIMLQ, STIMLS, STIMMM, STIMMV, STIMPB,
$ STIMPO, STIMPP, STIMPT, STIMQ3, STIMQL, STIMQP,
$ STIMQR, STIMRQ, STIMSP, STIMSY, STIMTB, STIMTD,
$ STIMTP, STIMTR
* ..
* .. Scalars in Common ..
INTEGER NB, NEISPK, NPROC, NSHIFT
* ..
* .. Common blocks ..
COMMON / CENVIR / NB, NPROC, NSHIFT, NEISPK
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
S1 = SECOND( )
LDR1 = MAXVAL
LDR2 = MAXVAL
LDR3 = 2*MXNLDA
WRITE( NOUT, FMT = 9983 )
*
* Read the first line. The first four characters must be 'BLAS'
* for the BLAS data file format to be used. Otherwise, the LAPACK
* data file format is assumed.
*
READ( NIN, FMT = '( A80 )' )LINE
BLAS = LSAMEN( 4, LINE, 'BLAS' )
*
* Find the last non-blank and print the first line of input as the
* first line of output.
*
DO 10 L = 80, 1, -1
IF( LINE( L: L ).NE.' ' )
$ GO TO 20
10 CONTINUE
L = 1
20 CONTINUE
WRITE( NOUT, FMT = '( 1X, A, / )' )LINE( 1: L )
WRITE( NOUT, FMT = 9992 )
*
* Read in NM and the values for M.
*
READ( NIN, FMT = * )NM
IF( NM.GT.MAXVAL ) THEN
WRITE( NOUT, FMT = 9999 )'M', 'NM', MAXVAL
NM = MAXVAL
END IF
READ( NIN, FMT = * )( MVAL( I ), I = 1, NM )
WRITE( NOUT, FMT = 9991 )'M: ', ( MVAL( I ), I = 1, NM )
*
* Check that M <= NMAXB for all values of M.
*
MOK = .TRUE.
MAXM = 0
DO 30 I = 1, NM
MAXM = MAX( MVAL( I ), MAXM )
IF( MVAL( I ).GT.NMAXB ) THEN
WRITE( NOUT, FMT = 9997 )'M', MVAL( I ), NMAXB
MOK = .FALSE.
END IF
30 CONTINUE
IF( .NOT.MOK )
$ WRITE( NOUT, FMT = * )
*
* Read in NN and the values for N.
*
READ( NIN, FMT = * )NN
IF( NN.GT.MAXVAL ) THEN
WRITE( NOUT, FMT = 9999 )'N', 'NN', MAXVAL
NN = MAXVAL
END IF
READ( NIN, FMT = * )( NVAL( I ), I = 1, NN )
WRITE( NOUT, FMT = 9991 )'N: ', ( NVAL( I ), I = 1, NN )
*
* Check that N <= NMAXB for all values of N.
*
NOK = .TRUE.
MAXN = 0
DO 40 I = 1, NN
MAXN = MAX( NVAL( I ), MAXN )
IF( NVAL( I ).GT.NMAXB ) THEN
WRITE( NOUT, FMT = 9997 )'N', NVAL( I ), NMAXB
NOK = .FALSE.
END IF
40 CONTINUE
IF( .NOT.NOK )
$ WRITE( NOUT, FMT = * )
*
* Read in NK and the values for K.
*
READ( NIN, FMT = * )NK
IF( NK.GT.MAXVAL ) THEN
WRITE( NOUT, FMT = 9999 )'K', 'NK', MAXVAL
NK = MAXVAL
END IF
READ( NIN, FMT = * )( KVAL( I ), I = 1, NK )
WRITE( NOUT, FMT = 9991 )'K: ', ( KVAL( I ), I = 1, NK )
*
* Find the maximum value of K (= NRHS).
*
MAXK = 0
DO 50 I = 1, NK
MAXK = MAX( KVAL( I ), MAXK )
50 CONTINUE
MKMAX = MAXM*MAX( 2, MAXK )
*
* Read in NNB and the values for NB. For the BLAS input files,
* NBVAL is used to store values for INCX and INCY.
*
READ( NIN, FMT = * )NNB
IF( NNB.GT.MAXVAL ) THEN
WRITE( NOUT, FMT = 9999 )'NB', 'NNB', MAXVAL
NNB = MAXVAL
END IF
READ( NIN, FMT = * )( NBVAL( I ), I = 1, NNB )
*
* Find the maximum value of NB.
*
MAXNB = 0
DO 60 I = 1, NNB
MAXNB = MAX( NBVAL( I ), MAXNB )
60 CONTINUE
*
IF( BLAS ) THEN
WRITE( NOUT, FMT = 9991 )'INCX: ', ( NBVAL( I ), I = 1, NNB )
DO 70 I = 1, NNB
NXVAL( I ) = 0
70 CONTINUE
ELSE
*
* LAPACK data files: Read in the values for NX.
*
READ( NIN, FMT = * )( NXVAL( I ), I = 1, NNB )
*
WRITE( NOUT, FMT = 9991 )'NB: ', ( NBVAL( I ), I = 1, NNB )
WRITE( NOUT, FMT = 9991 )'NX: ', ( NXVAL( I ), I = 1, NNB )
END IF
*
* Read in NLDA and the values for LDA.
*
READ( NIN, FMT = * )NLDA
IF( NLDA.GT.MXNLDA ) THEN
WRITE( NOUT, FMT = 9999 )'LDA', 'NLDA', MXNLDA
NLDA = MXNLDA
END IF
READ( NIN, FMT = * )( LDAVAL( I ), I = 1, NLDA )
WRITE( NOUT, FMT = 9991 )'LDA: ', ( LDAVAL( I ), I = 1, NLDA )
*
* Check that LDA >= 1 for all values of LDA.
*
LDAOK = .TRUE.
MAXLDA = 0
DO 80 I = 1, NLDA
MAXLDA = MAX( LDAVAL( I ), MAXLDA )
IF( LDAVAL( I ).LE.0 ) THEN
WRITE( NOUT, FMT = 9998 )LDAVAL( I )
LDAOK = .FALSE.
END IF
80 CONTINUE
IF( .NOT.LDAOK )
$ WRITE( NOUT, FMT = * )
*
* Check that MAXLDA*MAXN <= LA (for the dense routines).
*
LDANOK = .TRUE.
NEED = MAXLDA*MAXN
IF( NEED.GT.LA ) THEN
WRITE( NOUT, FMT = 9995 )MAXLDA, MAXN, NEED
LDANOK = .FALSE.
END IF
*
* Check that MAXLDA*MAXM + MAXM*MAXK <= 3*LA (for band routines).
*
LDAMOK = .TRUE.
NEED = MAXLDA*MAXM + MAXM*MAXK
IF( NEED.GT.3*LA ) THEN
NEED = ( NEED+2 ) / 3
WRITE( NOUT, FMT = 9994 )MAXLDA, MAXM, MAXK, NEED
LDAMOK = .FALSE.
END IF
*
* Check that MAXN*MAXNB (or MAXN*INCX) <= LA.
*
NXNBOK = .TRUE.
NEED = MAXN*MAXNB
IF( NEED.GT.LA ) THEN
WRITE( NOUT, FMT = 9996 )MAXN, MAXNB, NEED
NXNBOK = .FALSE.
END IF
*
IF( .NOT.( MOK .AND. NOK .AND. LDAOK .AND. LDANOK .AND. NXNBOK ) )
$ THEN
WRITE( NOUT, FMT = 9984 )
GO TO 110
END IF
IF( .NOT.LDAMOK )
$ WRITE( NOUT, FMT = * )
*
* Read the minimum time to time a subroutine.
*
WRITE( NOUT, FMT = * )
READ( NIN, FMT = * )TIMMIN
WRITE( NOUT, FMT = 9993 )TIMMIN
WRITE( NOUT, FMT = * )
*
* Read the first input line.
*
READ( NIN, FMT = '(A)', END = 100 )LINE
*
* If the first record is the special signal 'NONE', then get the
* next line but don't time SGEMV and SGEMM.
*
IF( LSAMEN( 4, LINE, 'NONE' ) ) THEN
READ( NIN, FMT = '(A)', END = 100 )LINE
ELSE
WRITE( NOUT, FMT = 9990 )
*
* If the first record is the special signal 'BAND', then time
* the band routine SGBMV and SGEMM with N = K.
*
IF( LSAMEN( 4, LINE, 'BAND' ) ) THEN
IF( LDAMOK ) THEN
IF( MKMAX.GT.LA ) THEN
I2 = 2*LA - MKMAX + 1
J2 = 2
ELSE
I2 = LA - MKMAX + 1
J2 = 3
END IF
CALL STIMMV( 'SGBMV ', NM, MVAL, NN, NVAL, NLDA, LDAVAL,
$ TIMMIN, A( 1, 1 ), MKMAX / 2, A( I2, J2 ),
$ A( LA-MKMAX / 2+1, 3 ), RESLTS, LDR1, LDR2,
$ NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )'SGBMV '
END IF
CALL STIMMM( 'SGEMM ', 'K', NN, NVAL, NLDA, LDAVAL, TIMMIN,
$ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), RESLTS, LDR1,
$ LDR2, NOUT )
READ( NIN, FMT = '(A)', END = 100 )LINE
*
ELSE
*
* Otherwise time SGEMV and SGEMM.
*
CALL STIMMV( 'SGEMV ', NN, NVAL, NNB, NBVAL, NLDA, LDAVAL,
$ TIMMIN, A( 1, 1 ), LA, A( 1, 2 ), A( 1, 3 ),
$ RESLTS, LDR1, LDR2, NOUT )
CALL STIMMM( 'SGEMM ', 'N', NN, NVAL, NLDA, LDAVAL, TIMMIN,
$ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), RESLTS, LDR1,
$ LDR2, NOUT )
END IF
END IF
*
* Call the appropriate timing routine for each input line.
*
WRITE( NOUT, FMT = 9988 )
90 CONTINUE
C1 = LINE( 1: 1 )
C2 = LINE( 2: 3 )
C3 = LINE( 4: 6 )
*
* Check first character for correct precision.
*
IF( .NOT.LSAME( C1, 'Single precision' ) ) THEN
WRITE( NOUT, FMT = 9987 )LINE( 1: 6 )
*
ELSE IF( LSAMEN( 2, C2, 'B2' ) .OR. LSAMEN( 3, C3, 'MV ' ) .OR.
$ LSAMEN( 3, C3, 'SV ' ) .OR. LSAMEN( 3, C3, 'R ' ) .OR.
$ LSAMEN( 3, C3, 'RC ' ) .OR. LSAMEN( 3, C3, 'RU ' ) .OR.
$ LSAMEN( 3, C3, 'R2 ' ) ) THEN
*
* Level 2 BLAS
*
CALL STIMB2( LINE, NM, MVAL, NN, NVAL, NK, KVAL, NNB, NBVAL,
$ NLDA, LDAVAL, LA, TIMMIN, A( 1, 1 ), A( 1, 2 ),
$ A( 1, 3 ), RESLTS, LDR1, LDR2, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'B3' ) .OR. LSAMEN( 3, C3, 'MM ' ) .OR.
$ LSAMEN( 3, C3, 'SM ' ) .OR. LSAMEN( 3, C3, 'RK ' ) .OR.
$ LSAMEN( 3, C3, 'R2K' ) ) THEN
*
* Level 3 BLAS
*
CALL STIMB3( LINE, NM, MVAL, NN, NVAL, NK, KVAL, NLDA, LDAVAL,
$ TIMMIN, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), RESLTS,
$ LDR1, LDR2, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'QR' ) .OR. LSAMEN( 2, C3, 'QR' ) .OR.
$ LSAMEN( 2, C3( 2: 3 ), 'QR' ) ) THEN
*
* QR routines
*
CALL STIMQR( LINE, NN, MVAL, NVAL, NK, KVAL, NNB, NBVAL, NXVAL,
$ NLDA, LDAVAL, TIMMIN, A( 1, 1 ), D, A( 1, 2 ),
$ A( 1, 3 ), RESLTS, LDR1, LDR2, LDR3, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'LQ' ) .OR. LSAMEN( 2, C3, 'LQ' ) .OR.
$ LSAMEN( 2, C3( 2: 3 ), 'LQ' ) ) THEN
*
* LQ routines
*
CALL STIMLQ( LINE, NN, MVAL, NVAL, NK, KVAL, NNB, NBVAL, NXVAL,
$ NLDA, LDAVAL, TIMMIN, A( 1, 1 ), D, A( 1, 2 ),
$ A( 1, 3 ), RESLTS, LDR1, LDR2, LDR3, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'QL' ) .OR. LSAMEN( 2, C3, 'QL' ) .OR.
$ LSAMEN( 2, C3( 2: 3 ), 'QL' ) ) THEN
*
* QL routines
*
CALL STIMQL( LINE, NN, MVAL, NVAL, NK, KVAL, NNB, NBVAL, NXVAL,
$ NLDA, LDAVAL, TIMMIN, A( 1, 1 ), D, A( 1, 2 ),
$ A( 1, 3 ), RESLTS, LDR1, LDR2, LDR3, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'RQ' ) .OR. LSAMEN( 2, C3, 'RQ' ) .OR.
$ LSAMEN( 2, C3( 2: 3 ), 'RQ' ) ) THEN
*
* RQ routines
*
CALL STIMRQ( LINE, NN, MVAL, NVAL, NK, KVAL, NNB, NBVAL, NXVAL,
$ NLDA, LDAVAL, TIMMIN, A( 1, 1 ), D, A( 1, 2 ),
$ A( 1, 3 ), RESLTS, LDR1, LDR2, LDR3, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'QP' ) .OR. LSAMEN( 3, C3, 'QPF' ) ) THEN
*
* QR with column pivoting
*
CALL STIMQP( LINE, NM, MVAL, NVAL, NLDA, LDAVAL, TIMMIN,
$ A( 1, 1 ), A( 1, 2 ), D( 1, 1 ), A( 1, 3 ), IWORK,
$ RESLTS, LDR1, LDR2, NOUT )
*
* Blas-3 QR with column pivoting
*
CALL STIMQ3( LINE, NM, MVAL, NVAL, NNB, NBVAL, NXVAL, NLDA,
$ LDAVAL, TIMMIN, A( 1, 1 ), A( 1, 2 ), D( 1, 1 ),
$ A( 1, 3 ), IWORK, RESLTS, LDR1, LDR2, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'HR' ) .OR. LSAMEN( 3, C3, 'HRD' ) .OR.
$ LSAMEN( 2, C3( 2: 3 ), 'HR' ) ) THEN
*
* Reduction to Hessenberg form
*
CALL STIMHR( LINE, NN, NVAL, NK, KVAL, NNB, NBVAL, NXVAL, NLDA,
$ LDAVAL, TIMMIN, A( 1, 1 ), D, A( 1, 2 ),
$ A( 1, 3 ), RESLTS, LDR1, LDR2, LDR3, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'TD' ) .OR. LSAMEN( 3, C3, 'TRD' ) .OR.
$ LSAMEN( 2, C3( 2: 3 ), 'TR' ) ) THEN
*
* Reduction to tridiagonal form
*
CALL STIMTD( LINE, NN, NVAL, NK, KVAL, NNB, NBVAL, NXVAL, NLDA,
$ LDAVAL, TIMMIN, A( 1, 1 ), A( 1, 2 ), D( 1, 1 ),
$ D( 1, 2 ), A( 1, 3 ), RESLTS, LDR1, LDR2, LDR3,
$ NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'BR' ) .OR. LSAMEN( 3, C3, 'BRD' ) .OR.
$ LSAMEN( 2, C3( 2: 3 ), 'BR' ) ) THEN
*
* Reduction to bidiagonal form
*
CALL STIMBR( LINE, NN, MVAL, NVAL, NK, KVAL, NNB, NBVAL, NXVAL,
$ NLDA, LDAVAL, TIMMIN, A( 1, 1 ), A( 1, 2 ),
$ D( 1, 1 ), D( 1, 2 ), A( 1, 3 ), RESLTS, LDR1,
$ LDR2, LDR3, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
* Routines for general matrices
*
CALL STIMGE( LINE, NN, NVAL, NK, KVAL, NNB, NBVAL, NLDA,
$ LDAVAL, TIMMIN, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
$ IWORK, RESLTS, LDR1, LDR2, LDR3, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
*
* General band matrices
*
IF( LDAMOK ) THEN
CALL STIMGB( LINE, NM, MVAL, NN, NVAL, NK, KVAL, NNB, NBVAL,
$ NLDA, LDAVAL, TIMMIN, A( 1, 1 ),
$ A( LA-MKMAX+1, 3 ), IWORK, RESLTS, LDR1, LDR2,
$ LDR3, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )LINE( 1: 6 )
END IF
*
ELSE IF( LSAMEN( 2, C2, 'GT' ) ) THEN
*
* Routines for general tridiagonal matrices
*
CALL STIMGT( LINE, NN, NVAL, NK, KVAL, NLDA, LDAVAL, TIMMIN,
$ A( 1, 1 ), A( 1, 2 ), IWORK, RESLTS, LDR1, LDR2,
$ LDR3, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'PO' ) ) THEN
*
* Positive definite matrices
*
CALL STIMPO( LINE, NN, NVAL, NK, KVAL, NNB, NBVAL, NLDA,
$ LDAVAL, TIMMIN, A( 1, 1 ), A( 1, 2 ), IWORK,
$ RESLTS, LDR1, LDR2, LDR3, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'PP' ) ) THEN
*
* Positive definite packed matrices
*
CALL STIMPP( LINE, NN, NVAL, NK, KVAL, LA, TIMMIN, A( 1, 1 ),
$ A( 1, 2 ), IWORK, RESLTS, LDR1, LDR2, LDR3, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN
*
* Positive definite banded matrices
*
IF( LDAMOK ) THEN
IF( MKMAX.GT.LA ) THEN
J2 = 2
I2 = 2*LA - MKMAX + 1
ELSE
J2 = 3
I2 = LA - MKMAX + 1
END IF
CALL STIMPB( LINE, NM, MVAL, NN, NVAL, NK, KVAL, NNB, NBVAL,
$ NLDA, LDAVAL, TIMMIN, A( 1, 1 ), A( I2, J2 ),
$ IWORK, RESLTS, LDR1, LDR2, LDR3, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )LINE( 1: 6 )
END IF
*
ELSE IF( LSAMEN( 2, C2, 'PT' ) ) THEN
*
* Routines for positive definite tridiagonal matrices
*
CALL STIMPT( LINE, NN, NVAL, NK, KVAL, NLDA, LDAVAL, TIMMIN,
$ A( 1, 1 ), A( 1, 2 ), RESLTS, LDR1, LDR2, LDR3,
$ NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'SY' ) ) THEN
*
* Symmetric indefinite matrices
*
CALL STIMSY( LINE, NN, NVAL, NK, KVAL, NNB, NBVAL, NLDA,
$ LDAVAL, TIMMIN, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
$ IWORK, RESLTS, LDR1, LDR2, LDR3, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
* Symmetric indefinite packed matrices
*
CALL STIMSP( LINE, NN, NVAL, NK, KVAL, LA, TIMMIN, A( 1, 1 ),
$ A( 1, 2 ), A( 1, 3 ), IWORK, RESLTS, LDR1, LDR2,
$ LDR3, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'TR' ) ) THEN
*
* Triangular matrices
*
CALL STIMTR( LINE, NN, NVAL, NK, KVAL, NNB, NBVAL, NLDA,
$ LDAVAL, TIMMIN, A( 1, 1 ), A( 1, 2 ), RESLTS,
$ LDR1, LDR2, LDR3, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'TP' ) ) THEN
*
* Triangular packed matrices
*
CALL STIMTP( LINE, NN, NVAL, NK, KVAL, LA, TIMMIN, A( 1, 1 ),
$ A( 1, 2 ), RESLTS, LDR1, LDR2, LDR3, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
*
* Triangular band matrices
*
IF( LDAMOK ) THEN
IF( MKMAX.GT.LA ) THEN
J2 = 2
I2 = 2*LA - MKMAX + 1
ELSE
J2 = 3
I2 = LA - MKMAX + 1
END IF
CALL STIMTB( LINE, NM, MVAL, NN, NVAL, NK, KVAL, NLDA,
$ LDAVAL, TIMMIN, A( 1, 1 ), A( I2, J2 ), RESLTS,
$ LDR1, LDR2, LDR3, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )LINE( 1: 6 )
END IF
*
ELSE IF( LSAMEN( 2, C2, 'LS' ) ) THEN
*
* Least squares drivers
*
CALL STIMLS( LINE, NM, MVAL, NN, NVAL, NK, KVAL, NNB, NBVAL,
$ NXVAL, NLDA, LDAVAL, TIMMIN, A( 1, 1 ), A( 1, 2 ),
$ B( 1, 1 ), B( 1, 2 ), S, S( NMAX+1 ), OPCTBL,
$ TIMTBL, FLPTBL, WORK, IWORK, NOUT )
*
ELSE
*
WRITE( NOUT, FMT = 9987 )LINE( 1: 6 )
END IF
*
* Read the next line of the input file.
*
READ( NIN, FMT = '(A)', END = 100 )LINE
GO TO 90
*
* Branch to this line when the last record is read.
*
100 CONTINUE
S2 = SECOND( )
WRITE( NOUT, FMT = 9986 )
WRITE( NOUT, FMT = 9985 )S2 - S1
110 CONTINUE
*
9999 FORMAT( ' Too many values of ', A, ' using ', A, ' = ', I2 )
9998 FORMAT( ' *** LDA = ', I7, ' is too small, must have ',
$ 'LDA > 0.' )
9997 FORMAT( ' *** ', A1, ' = ', I7, ' is too big: ',
$ 'maximum allowed is', I7 )
9996 FORMAT( ' *** N*NB is too big for N =', I6, ', NB =', I6,
$ / ' --> Increase LA to at least ', I8 )
9995 FORMAT( ' *** LDA*N is too big for the dense routines ', '(LDA =',
$ I6, ', N =', I6, ')', / ' --> Increase LA to at least ',
$ I8 )
9994 FORMAT( ' *** (LDA+K)*M is too big for the band routines ',
$ '(LDA=', I6, ', M=', I6, ', K=', I6, ')',
$ / ' --> Increase LA to at least ', I8 )
9993 FORMAT( ' The minimum time a subroutine will be timed = ', F6.3,
$ ' seconds' )
9992 FORMAT( ' The following parameter values will be used:' )
9991 FORMAT( 4X, A7, 1X, 10I6, / 12X, 10I6 )
9990 FORMAT( / ' ------------------------------',
$ / ' >>>>> Sample BLAS <<<<<',
$ / ' ------------------------------' )
9989 FORMAT( 1X, A6, ' not timed due to input errors', / )
9988 FORMAT( / ' ------------------------------',
$ / ' >>>>> Timing data <<<<<',
$ / ' ------------------------------' )
9987 FORMAT( 1X, A6, ': Unrecognized path or subroutine name', / )
9986 FORMAT( ' End of tests' )
9985 FORMAT( ' Total time used = ', F12.2, ' seconds' )
9984 FORMAT( / ' Tests not done due to input errors' )
9983 FORMAT( ' LAPACK VERSION 3.0, released June 30, 1999 ', / )
*
* End of STIMAA
*
END
SUBROUTINE STIMB2( LINE, NM, MVAL, NN, NVAL, NK, KVAL, NINC,
$ INCVAL, NLDA, LDAVAL, LA, TIMMIN, A, X, Y,
$ RESLTS, LDR1, LDR2, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*( * ) LINE
INTEGER LA, LDR1, LDR2, NINC, NK, NLDA, NM, NN, NOUT
REAL TIMMIN
* ..
* .. Array Arguments ..
INTEGER INCVAL( * ), KVAL( * ), LDAVAL( * ), MVAL( * ),
$ NVAL( * )
REAL A( * ), RESLTS( LDR1, LDR2, * ), X( * ), Y( * )
* ..
*
* Purpose
* =======
*
* STIMB2 times the BLAS 2 routines.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NK (input) INTEGER
* The number of values of K contained in the vector KVAL.
*
* KVAL (input) INTEGER array, dimension (NK)
* The values of the band width K.
*
* NINC (input) INTEGER
* The number of values of INCX contained in the vector INCVAL.
*
* INCVAL (input) INTEGER array, dimension (NINC)
* The values of INCX, the increment between successive values
* of the vector X.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* LA (input) INTEGER
* The size of the array A.
*
* TIMMIN (input) REAL
* The minimum time a subroutine will be timed.
*
* A (workspace) REAL array, dimension (LA)
*
* X (workspace) REAL array, dimension (NMAX*INCMAX)
* where NMAX and INCMAX are the maximum values permitted
* for N and INCX.
*
* Y (workspace) REAL array, dimension (NMAX*INCMAX)
* where NMAX and INCMAX are the maximum values permitted
* for N and INCX.
*
* RESLTS (output) REAL array, dimension (LDR1,LDR2,p),
* where p = NLDA*NINC.
* The timing results for each subroutine over the relevant
* values of M, N, K, INCX, and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NM,NK).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NN).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 16 )
INTEGER NTRANS, NUPLOS
PARAMETER ( NTRANS = 2, NUPLOS = 2 )
REAL ALPHA, BETA
PARAMETER ( ALPHA = 1.0E0, BETA = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL IXANDY
CHARACTER TRANSA, UPLO
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, I3, IC, ICL, IINC, IK, ILDA, IM, IMAT, IN,
$ INCX, INFO, ISUB, ITA, IUPLO, J, K, LDA, M, N,
$ NX, NY
REAL OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER TRANS( NTRANS ), UPLOS( NUPLOS )
CHARACTER*6 NAMES( NSUBS )
INTEGER LAVAL( 1 )
* ..
* .. External Functions ..
REAL SECOND, SMFLOP, SOPBL2
EXTERNAL SECOND, SMFLOP, SOPBL2
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, SGBMV, SGEMV, SGER, SPRTBL,
$ SSBMV, SSPMV, SSPR, SSPR2, SSYMV, SSYR, SSYR2,
$ STBMV, STBSV, STIMMG, STPMV, STPSV, STRMV,
$ STRSV
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. Data statements ..
DATA TRANS / 'N', 'T' /
DATA UPLOS / 'U', 'L' /
DATA NAMES / 'SGEMV ', 'SGBMV ', 'SSYMV ', 'SSBMV ',
$ 'SSPMV ', 'STRMV ', 'STBMV ', 'STPMV ',
$ 'STRSV ', 'STBSV ', 'STPSV ', 'SGER ',
$ 'SSYR ', 'SSPR ', 'SSYR2 ', 'SSPR2 ' /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'B2'
CALL ATIMIN( PATH, LINE, NSUBS, NAMES, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 1070
*
* Time each routine
*
DO 1060 ISUB = 1, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 1060
*
* Check the input values. The conditions are
* M <= LDA for general storage
* K <= LDA for banded storage
* N*(N+1)/2 <= LA for packed storage
*
CNAME = NAMES( ISUB )
IF( CNAME( 2: 3 ).EQ.'GE' ) THEN
CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO )
ELSE IF( CNAME( 3: 3 ).EQ.'B' ) THEN
CALL ATIMCK( 0, CNAME, NK, KVAL, NLDA, LDAVAL, NOUT, INFO )
ELSE IF( CNAME( 3: 3 ).EQ.'P' ) THEN
LAVAL( 1 ) = LA
CALL ATIMCK( 4, CNAME, NN, NVAL, 1, LAVAL, NOUT, INFO )
ELSE
CALL ATIMCK( 2, CNAME, NN, NVAL, NLDA, LDAVAL, NOUT, INFO )
END IF
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 1060
END IF
*
* Print header.
*
WRITE( NOUT, FMT = 9998 )CNAME
IXANDY = ISUB.LE.5 .OR. ISUB.EQ.12 .OR. ISUB.EQ.15 .OR.
$ ISUB.EQ.16
IF( CNAME( 3: 3 ).NE.'P' ) THEN
IF( NLDA*NINC.EQ.1 ) THEN
IF( IXANDY ) THEN
WRITE( NOUT, FMT = 9997 )LDAVAL( 1 ), INCVAL( 1 )
ELSE
WRITE( NOUT, FMT = 9996 )LDAVAL( 1 ), INCVAL( 1 )
END IF
ELSE
DO 20 I = 1, NLDA
DO 10 J = 1, NINC
IF( IXANDY ) THEN
WRITE( NOUT, FMT = 9993 )( I-1 )*NINC + J,
$ LDAVAL( I ), INCVAL( J )
ELSE
WRITE( NOUT, FMT = 9992 )( I-1 )*NINC + J,
$ LDAVAL( I ), INCVAL( J )
END IF
10 CONTINUE
20 CONTINUE
END IF
ELSE
IF( NINC.EQ.1 ) THEN
IF( IXANDY ) THEN
WRITE( NOUT, FMT = 9995 )INCVAL( 1 )
ELSE
WRITE( NOUT, FMT = 9994 )INCVAL( 1 )
END IF
ELSE
DO 30 J = 1, NINC
IF( IXANDY ) THEN
WRITE( NOUT, FMT = 9991 )J, INCVAL( J )
ELSE
WRITE( NOUT, FMT = 9990 )J, INCVAL( J )
END IF
30 CONTINUE
END IF
END IF
*
* Time SGEMV
*
IF( CNAME.EQ.'SGEMV ' ) THEN
DO 100 ITA = 1, NTRANS
TRANSA = TRANS( ITA )
I3 = 0
DO 90 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 80 IINC = 1, NINC
INCX = INCVAL( IINC )
I3 = I3 + 1
DO 70 IM = 1, NM
M = MVAL( IM )
DO 60 IN = 1, NN
N = NVAL( IN )
IF( TRANSA.EQ.'N' ) THEN
NX = N
NY = M
ELSE
NX = M
NY = N
END IF
CALL STIMMG( 1, M, N, A, LDA, 0, 0 )
CALL STIMMG( 0, 1, NX, X, INCX, 0, 0 )
CALL STIMMG( 0, 1, NY, Y, INCX, 0, 0 )
IC = 0
S1 = SECOND( )
40 CONTINUE
CALL SGEMV( TRANSA, M, N, ALPHA, A, LDA, X,
$ INCX, BETA, Y, INCX )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, 1, NY, Y, INCX, 0, 0 )
GO TO 40
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
50 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, 1, NY, Y, INCX, 0, 0 )
GO TO 50
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPBL2( CNAME, M, N, 0, 0 )
RESLTS( IM, IN, I3 ) = SMFLOP( OPS, TIME, 0 )
60 CONTINUE
70 CONTINUE
80 CONTINUE
90 CONTINUE
WRITE( NOUT, FMT = 9989 )TRANSA
CALL SPRTBL( 'M', 'N', NM, MVAL, NN, NVAL, NINC*NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
100 CONTINUE
*
ELSE IF( CNAME.EQ.'SGBMV ' ) THEN
*
* Time SGBMV
*
DO 170 ITA = 1, NTRANS
TRANSA = TRANS( ITA )
I3 = 0
DO 160 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 150 IINC = 1, NINC
INCX = INCVAL( IINC )
I3 = I3 + 1
DO 140 IK = 1, NK
K = KVAL( IK )
DO 130 IN = 1, NN
N = NVAL( IN )
M = N
CALL STIMMG( -2, M, N, A, LDA, K, K )
CALL STIMMG( 0, 1, N, X, INCX, 0, 0 )
CALL STIMMG( 0, 1, M, Y, INCX, 0, 0 )
IC = 0
S1 = SECOND( )
110 CONTINUE
CALL SGBMV( TRANSA, M, N, K, K, ALPHA, A,
$ LDA, X, INCX, BETA, Y, INCX )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, 1, M, Y, INCX, 0, 0 )
GO TO 110
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
120 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, 1, M, Y, INCX, 0, 0 )
GO TO 120
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPBL2( CNAME, M, N, K, K )
RESLTS( IK, IN, I3 ) = SMFLOP( OPS, TIME, 0 )
130 CONTINUE
140 CONTINUE
150 CONTINUE
160 CONTINUE
WRITE( NOUT, FMT = 9988 )TRANSA
CALL SPRTBL( 'K', 'N', NK, KVAL, NN, NVAL, NINC*NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
170 CONTINUE
*
ELSE IF( CNAME.EQ.'SSYMV ' ) THEN
*
* Time SSYMV
*
DO 230 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IMAT = 6
IF( UPLO.EQ.'L' )
$ IMAT = -6
I3 = 0
DO 220 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 210 IINC = 1, NINC
INCX = INCVAL( IINC )
I3 = I3 + 1
DO 200 IN = 1, NN
N = NVAL( IN )
CALL STIMMG( IMAT, N, N, A, LDA, 0, 0 )
CALL STIMMG( 0, 1, N, X, INCX, 0, 0 )
CALL STIMMG( 0, 1, N, Y, INCX, 0, 0 )
IC = 0
S1 = SECOND( )
180 CONTINUE
CALL SSYMV( UPLO, N, ALPHA, A, LDA, X, INCX,
$ BETA, Y, INCX )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, 1, N, Y, INCX, 0, 0 )
GO TO 180
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
190 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, 1, N, Y, INCX, 0, 0 )
GO TO 190
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPBL2( CNAME, N, N, 0, 0 )
RESLTS( 1, IN, I3 ) = SMFLOP( OPS, TIME, 0 )
200 CONTINUE
210 CONTINUE
220 CONTINUE
WRITE( NOUT, FMT = 9986 )CNAME, UPLO
CALL SPRTBL( ' ', 'N', 1, NVAL, NN, NVAL, NINC*NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
230 CONTINUE
*
ELSE IF( CNAME.EQ.'SSBMV ' ) THEN
*
* Time SSBMV
*
DO 300 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IMAT = 8
IF( UPLO.EQ.'L' )
$ IMAT = -8
I3 = 0
DO 290 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 280 IINC = 1, NINC
INCX = INCVAL( IINC )
I3 = I3 + 1
DO 270 IK = 1, NK
K = KVAL( IK )
DO 260 IN = 1, NN
N = NVAL( IN )
CALL STIMMG( IMAT, N, N, A, LDA, K, K )
CALL STIMMG( 0, 1, N, X, INCX, 0, 0 )
CALL STIMMG( 0, 1, N, Y, INCX, 0, 0 )
IC = 0
S1 = SECOND( )
240 CONTINUE
CALL SSBMV( UPLO, N, K, ALPHA, A, LDA, X,
$ INCX, BETA, Y, INCX )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, 1, N, Y, INCX, 0, 0 )
GO TO 240
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
250 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, 1, N, Y, INCX, 0, 0 )
GO TO 250
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPBL2( CNAME, N, N, K, K )
RESLTS( IK, IN, I3 ) = SMFLOP( OPS, TIME, 0 )
260 CONTINUE
270 CONTINUE
280 CONTINUE
290 CONTINUE
WRITE( NOUT, FMT = 9986 )CNAME, UPLO
CALL SPRTBL( 'K', 'N', NK, KVAL, NN, NVAL, NINC*NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
300 CONTINUE
*
ELSE IF( CNAME.EQ.'SSPMV ' ) THEN
*
* Time SSPMV
*
DO 350 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IMAT = 7
IF( UPLO.EQ.'L' )
$ IMAT = -7
ILDA = 1
LDA = LDAVAL( ILDA )
DO 340 IINC = 1, NINC
INCX = INCVAL( IINC )
DO 330 IN = 1, NN
N = NVAL( IN )
CALL STIMMG( IMAT, N, N, A, N*( N+1 ) / 2, 0, 0 )
CALL STIMMG( 0, 1, N, X, INCX, 0, 0 )
CALL STIMMG( 0, 1, N, Y, INCX, 0, 0 )
IC = 0
S1 = SECOND( )
310 CONTINUE
CALL SSPMV( UPLO, N, ALPHA, A, X, INCX, BETA, Y,
$ INCX )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, 1, N, Y, INCX, 0, 0 )
GO TO 310
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
320 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, 1, N, Y, INCX, 0, 0 )
GO TO 320
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPBL2( CNAME, N, N, 0, 0 )
RESLTS( 1, IN, IINC ) = SMFLOP( OPS, TIME, 0 )
330 CONTINUE
340 CONTINUE
WRITE( NOUT, FMT = 9986 )CNAME, UPLO
CALL SPRTBL( ' ', 'N', 1, NVAL, NN, NVAL, NINC, RESLTS,
$ LDR1, LDR2, NOUT )
350 CONTINUE
*
ELSE IF( CNAME.EQ.'STRMV ' ) THEN
*
* Time STRMV
*
DO 420 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IMAT = 9
IF( UPLO.EQ.'L' )
$ IMAT = -9
DO 410 ITA = 1, NTRANS
TRANSA = TRANS( ITA )
I3 = 0
DO 400 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 390 IINC = 1, NINC
INCX = INCVAL( IINC )
I3 = I3 + 1
DO 380 IN = 1, NN
N = NVAL( IN )
CALL STIMMG( IMAT, N, N, A, LDA, 0, 0 )
CALL STIMMG( 0, 1, N, X, INCX, 0, 0 )
IC = 0
S1 = SECOND( )
360 CONTINUE
CALL STRMV( UPLO, TRANSA, 'Non-unit', N, A,
$ LDA, X, INCX )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, 1, N, X, INCX, 0, 0 )
GO TO 360
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
370 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, 1, N, X, INCX, 0, 0 )
GO TO 370
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPBL2( CNAME, N, N, 0, 0 )
RESLTS( 1, IN, I3 ) = SMFLOP( OPS, TIME, 0 )
380 CONTINUE
390 CONTINUE
400 CONTINUE
WRITE( NOUT, FMT = 9987 )CNAME, UPLO, TRANSA
CALL SPRTBL( ' ', 'N', 1, NVAL, NN, NVAL, NINC*NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
410 CONTINUE
420 CONTINUE
*
ELSE IF( CNAME.EQ.'STRSV ' ) THEN
*
* Time STRSV
*
DO 490 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IMAT = 9
IF( UPLO.EQ.'L' )
$ IMAT = -9
DO 480 ITA = 1, NTRANS
TRANSA = TRANS( ITA )
I3 = 0
DO 470 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 460 IINC = 1, NINC
INCX = INCVAL( IINC )
I3 = I3 + 1
DO 450 IN = 1, NN
N = NVAL( IN )
CALL STIMMG( IMAT, N, N, A, LDA, 0, 0 )
CALL STIMMG( 0, 1, N, X, INCX, 0, 0 )
IC = 0
S1 = SECOND( )
430 CONTINUE
CALL STRSV( UPLO, TRANSA, 'Non-unit', N, A,
$ LDA, X, INCX )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, 1, N, X, INCX, 0, 0 )
GO TO 430
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
440 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, 1, N, X, INCX, 0, 0 )
GO TO 440
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPBL2( CNAME, N, N, 0, 0 )
RESLTS( 1, IN, I3 ) = SMFLOP( OPS, TIME, 0 )
450 CONTINUE
460 CONTINUE
470 CONTINUE
WRITE( NOUT, FMT = 9987 )CNAME, UPLO, TRANSA
CALL SPRTBL( ' ', 'N', 1, NVAL, NN, NVAL, NINC*NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
480 CONTINUE
490 CONTINUE
*
ELSE IF( CNAME.EQ.'STBMV ' ) THEN
*
* Time STBMV
*
DO 570 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IMAT = 11
IF( UPLO.EQ.'L' )
$ IMAT = -11
DO 560 ITA = 1, NTRANS
TRANSA = TRANS( ITA )
I3 = 0
DO 550 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 540 IINC = 1, NINC
INCX = INCVAL( IINC )
I3 = I3 + 1
DO 530 IK = 1, NK
K = KVAL( IK )
DO 520 IN = 1, NN
N = NVAL( IN )
CALL STIMMG( IMAT, N, N, A, LDA, K, K )
CALL STIMMG( 0, 1, N, X, INCX, 0, 0 )
IC = 0
S1 = SECOND( )
500 CONTINUE
CALL STBMV( UPLO, TRANSA, 'Non-unit', N,
$ K, A, LDA, X, INCX )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, 1, N, X, INCX, 0, 0 )
GO TO 500
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
510 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, 1, N, X, INCX, 0, 0 )
GO TO 510
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPBL2( CNAME, N, N, K, K )
RESLTS( IK, IN, I3 ) = SMFLOP( OPS, TIME,
$ 0 )
520 CONTINUE
530 CONTINUE
540 CONTINUE
550 CONTINUE
WRITE( NOUT, FMT = 9987 )CNAME, UPLO, TRANSA
CALL SPRTBL( 'K', 'N', NK, KVAL, NN, NVAL, NINC*NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
560 CONTINUE
570 CONTINUE
*
ELSE IF( CNAME.EQ.'STBSV ' ) THEN
*
* Time STBSV
*
DO 650 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IMAT = 11
IF( UPLO.EQ.'L' )
$ IMAT = -11
DO 640 ITA = 1, NTRANS
TRANSA = TRANS( ITA )
I3 = 0
DO 630 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 620 IINC = 1, NINC
INCX = INCVAL( IINC )
I3 = I3 + 1
DO 610 IK = 1, NK
K = KVAL( IK )
DO 600 IN = 1, NN
N = NVAL( IN )
CALL STIMMG( IMAT, N, N, A, LDA, K, K )
CALL STIMMG( 0, 1, N, X, INCX, 0, 0 )
IC = 0
S1 = SECOND( )
580 CONTINUE
CALL STBSV( UPLO, TRANSA, 'Non-unit', N,
$ K, A, LDA, X, INCX )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, 1, N, X, INCX, 0, 0 )
GO TO 580
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
590 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, 1, N, X, INCX, 0, 0 )
GO TO 590
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPBL2( CNAME, N, N, K, K )
RESLTS( IK, IN, I3 ) = SMFLOP( OPS, TIME,
$ 0 )
600 CONTINUE
610 CONTINUE
620 CONTINUE
630 CONTINUE
WRITE( NOUT, FMT = 9987 )CNAME, UPLO, TRANSA
CALL SPRTBL( 'K', 'N', NK, KVAL, NN, NVAL, NINC*NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
640 CONTINUE
650 CONTINUE
*
ELSE IF( CNAME.EQ.'STPMV ' ) THEN
*
* Time STPMV
*
DO 710 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IMAT = 10
IF( UPLO.EQ.'L' )
$ IMAT = -10
DO 700 ITA = 1, NTRANS
TRANSA = TRANS( ITA )
ILDA = 1
LDA = LDAVAL( ILDA )
DO 690 IINC = 1, NINC
INCX = INCVAL( IINC )
DO 680 IN = 1, NN
N = NVAL( IN )
CALL STIMMG( IMAT, N, N, A, N*( N+1 ) / 2, 0,
$ 0 )
CALL STIMMG( 0, 1, N, X, INCX, 0, 0 )
IC = 0
S1 = SECOND( )
660 CONTINUE
CALL STPMV( UPLO, TRANSA, 'Non-unit', N, A, X,
$ INCX )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, 1, N, X, INCX, 0, 0 )
GO TO 660
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
670 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, 1, N, X, INCX, 0, 0 )
GO TO 670
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPBL2( CNAME, N, N, 0, 0 )
RESLTS( 1, IN, IINC ) = SMFLOP( OPS, TIME, 0 )
680 CONTINUE
690 CONTINUE
WRITE( NOUT, FMT = 9987 )CNAME, UPLO, TRANSA
CALL SPRTBL( ' ', 'N', 1, NVAL, NN, NVAL, NINC,
$ RESLTS, LDR1, LDR2, NOUT )
700 CONTINUE
710 CONTINUE
*
ELSE IF( CNAME.EQ.'STPSV ' ) THEN
*
* Time STPSV
*
DO 770 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IMAT = 10
IF( UPLO.EQ.'L' )
$ IMAT = -10
DO 760 ITA = 1, NTRANS
TRANSA = TRANS( ITA )
ILDA = 1
LDA = LDAVAL( ILDA )
DO 750 IINC = 1, NINC
INCX = INCVAL( IINC )
DO 740 IN = 1, NN
N = NVAL( IN )
CALL STIMMG( IMAT, N, N, A, N*( N+1 ) / 2, 0,
$ 0 )
CALL STIMMG( 0, 1, N, X, INCX, 0, 0 )
IC = 0
S1 = SECOND( )
720 CONTINUE
CALL STPSV( UPLO, TRANSA, 'Non-unit', N, A, X,
$ INCX )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, 1, N, X, INCX, 0, 0 )
GO TO 720
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
730 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, 1, N, X, INCX, 0, 0 )
GO TO 730
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPBL2( CNAME, N, N, 0, 0 )
RESLTS( 1, IN, IINC ) = SMFLOP( OPS, TIME, 0 )
740 CONTINUE
750 CONTINUE
WRITE( NOUT, FMT = 9987 )CNAME, UPLO, TRANSA
CALL SPRTBL( ' ', 'N', 1, NVAL, NN, NVAL, NINC,
$ RESLTS, LDR1, LDR2, NOUT )
760 CONTINUE
770 CONTINUE
*
ELSE IF( CNAME.EQ.'SGER ' ) THEN
*
* Time SGER
*
I3 = 0
DO 830 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 820 IINC = 1, NINC
INCX = INCVAL( IINC )
I3 = I3 + 1
DO 810 IM = 1, NM
M = MVAL( IM )
DO 800 IN = 1, NN
N = NVAL( IN )
CALL STIMMG( 0, 1, M, X, INCX, 0, 0 )
CALL STIMMG( 0, 1, N, Y, INCX, 0, 0 )
CALL STIMMG( 1, M, N, A, LDA, 0, 0 )
IC = 0
S1 = SECOND( )
780 CONTINUE
CALL SGER( M, N, ALPHA, X, INCX, Y, INCX, A,
$ LDA )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 1, M, N, A, LDA, 0, 0 )
GO TO 780
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
790 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 1, M, N, A, LDA, 0, 0 )
GO TO 790
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPBL2( CNAME, M, N, 0, 0 )
RESLTS( IM, IN, I3 ) = SMFLOP( OPS, TIME, 0 )
800 CONTINUE
810 CONTINUE
820 CONTINUE
830 CONTINUE
WRITE( NOUT, FMT = 9985 )
CALL SPRTBL( 'M', 'N', NM, MVAL, NN, NVAL, NINC*NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
*
ELSE IF( CNAME.EQ.'SSYR ' ) THEN
*
* Time SSYR
*
DO 890 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IMAT = 6
IF( UPLO.EQ.'L' )
$ IMAT = -6
I3 = 0
DO 880 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 870 IINC = 1, NINC
INCX = INCVAL( IINC )
I3 = I3 + 1
DO 860 IN = 1, NN
N = NVAL( IN )
CALL STIMMG( 0, 1, N, X, INCX, 0, 0 )
CALL STIMMG( 0, 1, N, Y, INCX, 0, 0 )
CALL STIMMG( IMAT, N, N, A, LDA, 0, 0 )
IC = 0
S1 = SECOND( )
840 CONTINUE
CALL SSYR( UPLO, N, ALPHA, X, INCX, A, LDA )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( IMAT, N, N, A, LDA, 0, 0 )
GO TO 840
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
850 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( IMAT, N, N, A, LDA, 0, 0 )
GO TO 850
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPBL2( CNAME, N, N, 0, 0 )
RESLTS( 1, IN, I3 ) = SMFLOP( OPS, TIME, 0 )
860 CONTINUE
870 CONTINUE
880 CONTINUE
WRITE( NOUT, FMT = 9986 )CNAME, UPLO
CALL SPRTBL( ' ', 'N', 1, NVAL, NN, NVAL, NINC*NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
890 CONTINUE
*
ELSE IF( CNAME.EQ.'SSYR2 ' ) THEN
*
* Time SSYR2
*
DO 950 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IMAT = 6
IF( UPLO.EQ.'L' )
$ IMAT = -6
I3 = 0
DO 940 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 930 IINC = 1, NINC
INCX = INCVAL( IINC )
I3 = I3 + 1
DO 920 IN = 1, NN
N = NVAL( IN )
CALL STIMMG( 0, 1, N, X, INCX, 0, 0 )
CALL STIMMG( 0, 1, N, Y, INCX, 0, 0 )
CALL STIMMG( IMAT, N, N, A, LDA, 0, 0 )
IC = 0
S1 = SECOND( )
900 CONTINUE
CALL SSYR2( UPLO, N, ALPHA, X, INCX, Y, INCX, A,
$ LDA )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( IMAT, N, N, A, LDA, 0, 0 )
GO TO 900
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
910 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( IMAT, N, N, A, LDA, 0, 0 )
GO TO 910
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPBL2( CNAME, N, N, 0, 0 )
RESLTS( 1, IN, I3 ) = SMFLOP( OPS, TIME, 0 )
920 CONTINUE
930 CONTINUE
940 CONTINUE
WRITE( NOUT, FMT = 9986 )CNAME, UPLO
CALL SPRTBL( ' ', 'N', 1, NVAL, NN, NVAL, NINC*NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
950 CONTINUE
*
ELSE IF( CNAME.EQ.'SSPR ' ) THEN
*
* Time SSPR
*
DO 1000 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IMAT = 7
IF( UPLO.EQ.'L' )
$ IMAT = -7
ILDA = 1
LDA = LDAVAL( ILDA )
DO 990 IINC = 1, NINC
INCX = INCVAL( IINC )
DO 980 IN = 1, NN
N = NVAL( IN )
CALL STIMMG( 0, 1, N, X, INCX, 0, 0 )
CALL STIMMG( 0, 1, N, Y, INCX, 0, 0 )
CALL STIMMG( IMAT, N, N, A, N*( N+1 ) / 2, 0, 0 )
IC = 0
S1 = SECOND( )
960 CONTINUE
CALL SSPR( UPLO, N, ALPHA, X, INCX, A )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( IMAT, N, N, A, N*( N+1 ) / 2, 0,
$ 0 )
GO TO 960
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
970 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( IMAT, N, N, A, N*( N+1 ) / 2, 0,
$ 0 )
GO TO 970
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPBL2( CNAME, N, N, 0, 0 )
RESLTS( 1, IN, IINC ) = SMFLOP( OPS, TIME, 0 )
980 CONTINUE
990 CONTINUE
WRITE( NOUT, FMT = 9986 )CNAME, UPLO
CALL SPRTBL( ' ', 'N', 1, NVAL, NN, NVAL, NINC, RESLTS,
$ LDR1, LDR2, NOUT )
1000 CONTINUE
*
ELSE IF( CNAME.EQ.'SSPR2 ' ) THEN
*
* Time SSPR2
*
DO 1050 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IMAT = 7
IF( UPLO.EQ.'L' )
$ IMAT = -7
ILDA = 1
LDA = LDAVAL( ILDA )
DO 1040 IINC = 1, NINC
INCX = INCVAL( IINC )
DO 1030 IN = 1, NN
N = NVAL( IN )
CALL STIMMG( 0, 1, N, X, INCX, 0, 0 )
CALL STIMMG( 0, 1, N, Y, INCX, 0, 0 )
CALL STIMMG( IMAT, N, N, A, N*( N+1 ) / 2, 0, 0 )
IC = 0
S1 = SECOND( )
1010 CONTINUE
CALL SSPR2( UPLO, N, ALPHA, X, INCX, Y, INCX, A )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( IMAT, N, N, A, N*( N+1 ) / 2, 0,
$ 0 )
GO TO 1010
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
1020 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( IMAT, N, N, A, N*( N+1 ) / 2, 0,
$ 0 )
GO TO 1020
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPBL2( CNAME, N, N, 0, 0 )
RESLTS( 1, IN, IINC ) = SMFLOP( OPS, TIME, 0 )
1030 CONTINUE
1040 CONTINUE
WRITE( NOUT, FMT = 9986 )CNAME, UPLO
CALL SPRTBL( ' ', 'N', 1, NVAL, NN, NVAL, NINC, RESLTS,
$ LDR1, LDR2, NOUT )
1050 CONTINUE
END IF
WRITE( NOUT, FMT = 9984 )
1060 CONTINUE
1070 CONTINUE
*
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'with LDA = ', I5, ' and INCX = INCY = ', I5 )
9996 FORMAT( 5X, 'with LDA = ', I5, ' and INCX = ', I5 )
9995 FORMAT( 5X, 'with INCX = INCY = ', I5 )
9994 FORMAT( 5X, 'with INCX = ', I5 )
9993 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5,
$ ' and INCX = INCY = ', I5 )
9992 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5, ' and INCX = ', I5 )
9991 FORMAT( 5X, 'line ', I2, ' with INCX = INCY = ', I5 )
9990 FORMAT( 5X, 'line ', I2, ' with INCX = ', I5 )
9989 FORMAT( / 1X, 'SGEMV with TRANS = ''', A1, '''', / )
9988 FORMAT( / 1X, 'SGBMV with TRANS = ''', A1,
$ ''', M = N and KL = K', 'U ', '= K', / )
9987 FORMAT( / 1X, A6, ' with UPLO = ''', A1, ''', TRANS = ''', A1,
$ '''', / )
9986 FORMAT( / 1X, A6, ' with UPLO = ''', A1, '''', / )
9985 FORMAT( / 1X, 'SGER', / )
9984 FORMAT( / / / / / )
RETURN
*
* End of STIMB2
*
END
SUBROUTINE STIMB3( LINE, NM, MVAL, NN, NVAL, NK, KVAL, NLDA,
$ LDAVAL, TIMMIN, A, B, C, RESLTS, LDR1, LDR2,
$ NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*( * ) LINE
INTEGER LDR1, LDR2, NK, NLDA, NM, NN, NOUT
REAL TIMMIN
* ..
* .. Array Arguments ..
INTEGER KVAL( * ), LDAVAL( * ), MVAL( * ), NVAL( * )
REAL A( * ), B( * ), C( * ), RESLTS( LDR1, LDR2, * )
* ..
*
* Purpose
* =======
*
* STIMB3 times the Level 3 BLAS routines.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NK (input) INTEGER
* The number of values of K contained in the vector KVAL.
*
* KVAL (input) INTEGER array, dimension (NK)
* The values of K. K is used as the intermediate matrix
* dimension for SGEMM (the product of an M x K matrix and a
* K x N matrix) and as the dimension of the rank-K update in
* SSYRK and SSYR2K.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) REAL
* The minimum time a subroutine will be timed.
*
* A (workspace) REAL array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values permitted
* for LDA and N.
*
* B (workspace) REAL array, dimension (LDAMAX*NMAX)
*
* C (workspace) REAL array, dimension (LDAMAX*NMAX)
*
* RESLTS (output) REAL array, dimension (LDR1,LDR2,NLDA)
* The timing results for each subroutine over the relevant
* values of M, N, K, and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NM,NK).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NN).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 6 )
INTEGER NTRANS, NSIDES, NUPLOS
PARAMETER ( NTRANS = 2, NSIDES = 2, NUPLOS = 2 )
REAL ALPHA, BETA
PARAMETER ( ALPHA = 1.0E0, BETA = 1.0E0 )
* ..
* .. Local Scalars ..
CHARACTER SIDE, TRANSA, TRANSB, UPLO
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, IC, ICL, IK, ILDA, IM, IMAT, IN, INFO,
$ ISIDE, ISUB, ITA, ITB, IUPLO, K, LDA, M, N
REAL OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER SIDES( NSIDES ), TRANS( NTRANS ),
$ UPLOS( NUPLOS )
CHARACTER*6 NAMES( NSUBS )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SECOND, SMFLOP, SOPBL3
EXTERNAL LSAME, SECOND, SMFLOP, SOPBL3
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, SGEMM, SPRTBL, SSYMM, SSYR2K,
$ SSYRK, STIMMG, STRMM, STRSM
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. Data statements ..
DATA NAMES / 'SGEMM ', 'SSYMM ', 'SSYRK ', 'SSYR2K',
$ 'STRMM ', 'STRSM ' /
DATA TRANS / 'N', 'T' /
DATA SIDES / 'L', 'R' /
DATA UPLOS / 'U', 'L' /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'B3'
CALL ATIMIN( PATH, LINE, NSUBS, NAMES, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 480
*
* Check that M <= LDA.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 480
END IF
*
* Time each routine.
*
DO 470 ISUB = 1, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 470
*
* Print header.
*
CNAME = NAMES( ISUB )
WRITE( NOUT, FMT = 9998 )CNAME
IF( NLDA.EQ.1 ) THEN
WRITE( NOUT, FMT = 9997 )LDAVAL( 1 )
ELSE
DO 10 I = 1, NLDA
WRITE( NOUT, FMT = 9996 )I, LDAVAL( I )
10 CONTINUE
END IF
*
* Time SGEMM
*
IF( CNAME.EQ.'SGEMM ' ) THEN
DO 90 ITA = 1, NTRANS
TRANSA = TRANS( ITA )
DO 80 ITB = 1, NTRANS
TRANSB = TRANS( ITB )
DO 70 IK = 1, NK
K = KVAL( IK )
DO 60 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 50 IM = 1, NM
M = MVAL( IM )
DO 40 IN = 1, NN
N = NVAL( IN )
IF( TRANSA.EQ.'N' ) THEN
CALL STIMMG( 1, M, K, A, LDA, 0, 0 )
ELSE
CALL STIMMG( 1, K, M, A, LDA, 0, 0 )
END IF
IF( TRANSB.EQ.'N' ) THEN
CALL STIMMG( 0, K, N, B, LDA, 0, 0 )
ELSE
CALL STIMMG( 0, N, K, B, LDA, 0, 0 )
END IF
CALL STIMMG( 1, M, N, C, LDA, 0, 0 )
IC = 0
S1 = SECOND( )
20 CONTINUE
CALL SGEMM( TRANSA, TRANSB, M, N, K,
$ ALPHA, A, LDA, B, LDA, BETA,
$ C, LDA )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 1, M, N, C, LDA, 0, 0 )
GO TO 20
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
30 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 1, M, N, C, LDA, 0, 0 )
GO TO 30
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPBL3( CNAME, M, N, K )
RESLTS( IM, IN, ILDA ) = SMFLOP( OPS,
$ TIME, 0 )
40 CONTINUE
50 CONTINUE
60 CONTINUE
IF( IK.EQ.1 )
$ WRITE( NOUT, FMT = 9995 )TRANSA, TRANSB
WRITE( NOUT, FMT = 9994 )KVAL( IK )
CALL SPRTBL( 'M', 'N', NM, MVAL, NN, NVAL, NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
70 CONTINUE
80 CONTINUE
90 CONTINUE
*
ELSE IF( CNAME.EQ.'SSYMM ' ) THEN
*
* Time SSYMM
*
DO 160 ISIDE = 1, NSIDES
SIDE = SIDES( ISIDE )
DO 150 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IF( LSAME( UPLO, 'U' ) ) THEN
IMAT = 6
ELSE
IMAT = -6
END IF
DO 140 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 130 IM = 1, NM
M = MVAL( IM )
DO 120 IN = 1, NN
N = NVAL( IN )
IF( ISIDE.EQ.1 ) THEN
CALL STIMMG( IMAT, M, M, A, LDA, 0, 0 )
CALL STIMMG( 0, M, N, B, LDA, 0, 0 )
ELSE
CALL STIMMG( 0, M, N, B, LDA, 0, 0 )
CALL STIMMG( IMAT, N, N, A, LDA, 0, 0 )
END IF
CALL STIMMG( 1, M, N, C, LDA, 0, 0 )
IC = 0
S1 = SECOND( )
100 CONTINUE
CALL SSYMM( SIDE, UPLO, M, N, ALPHA, A, LDA,
$ B, LDA, BETA, C, LDA )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 1, M, N, C, LDA, 0, 0 )
GO TO 100
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
110 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 1, M, N, C, LDA, 0, 0 )
GO TO 110
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPBL3( CNAME, M, N, ISIDE-1 )
RESLTS( IM, IN, ILDA ) = SMFLOP( OPS, TIME,
$ 0 )
120 CONTINUE
130 CONTINUE
140 CONTINUE
WRITE( NOUT, FMT = 9993 )SIDE, UPLO
CALL SPRTBL( 'M', 'N', NM, MVAL, NN, NVAL, NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
150 CONTINUE
160 CONTINUE
*
ELSE IF( CNAME.EQ.'SSYRK ' ) THEN
*
* Time SSYRK
*
DO 230 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IF( LSAME( UPLO, 'U' ) ) THEN
IMAT = 6
ELSE
IMAT = -6
END IF
DO 220 ITA = 1, NTRANS
TRANSA = TRANS( ITA )
DO 210 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 200 IK = 1, NK
K = KVAL( IK )
IF( TRANSA.EQ.'N' ) THEN
CALL STIMMG( 1, N, K, A, LDA, 0, 0 )
ELSE
CALL STIMMG( 1, K, N, A, LDA, 0, 0 )
END IF
DO 190 IN = 1, NN
N = NVAL( IN )
CALL STIMMG( IMAT, N, N, C, LDA, 0, 0 )
IC = 0
S1 = SECOND( )
170 CONTINUE
CALL SSYRK( UPLO, TRANSA, N, K, ALPHA, A,
$ LDA, BETA, C, LDA )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( IMAT, N, N, C, LDA, 0, 0 )
GO TO 170
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
180 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( IMAT, N, N, C, LDA, 0, 0 )
GO TO 180
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPBL3( CNAME, N, N, K )
RESLTS( IK, IN, ILDA ) = SMFLOP( OPS, TIME,
$ 0 )
190 CONTINUE
200 CONTINUE
210 CONTINUE
WRITE( NOUT, FMT = 9992 )CNAME, UPLO, TRANSA
CALL SPRTBL( 'K', 'N', NK, KVAL, NN, NVAL, NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
220 CONTINUE
230 CONTINUE
*
ELSE IF( CNAME.EQ.'SSYR2K' ) THEN
*
* Time SSYR2K
*
DO 300 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IF( LSAME( UPLO, 'U' ) ) THEN
IMAT = 6
ELSE
IMAT = -6
END IF
DO 290 ITB = 1, NTRANS
TRANSB = TRANS( ITB )
DO 280 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 270 IK = 1, NK
K = KVAL( IK )
IF( TRANSB.EQ.'N' ) THEN
CALL STIMMG( 1, N, K, A, LDA, 0, 0 )
CALL STIMMG( 0, N, K, B, LDA, 0, 0 )
ELSE
CALL STIMMG( 1, K, N, A, LDA, 0, 0 )
CALL STIMMG( 0, K, N, B, LDA, 0, 0 )
END IF
DO 260 IN = 1, NN
N = NVAL( IN )
CALL STIMMG( IMAT, N, N, C, LDA, 0, 0 )
IC = 0
S1 = SECOND( )
240 CONTINUE
CALL SSYR2K( UPLO, TRANSB, N, K, ALPHA, A,
$ LDA, B, LDA, BETA, C, LDA )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( IMAT, N, N, C, LDA, 0, 0 )
GO TO 240
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
250 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( IMAT, N, N, C, LDA, 0, 0 )
GO TO 250
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPBL3( CNAME, N, N, K )
RESLTS( IK, IN, ILDA ) = SMFLOP( OPS, TIME,
$ 0 )
260 CONTINUE
270 CONTINUE
280 CONTINUE
WRITE( NOUT, FMT = 9992 )CNAME, UPLO, TRANSB
CALL SPRTBL( 'K', 'N', NK, KVAL, NN, NVAL, NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
290 CONTINUE
300 CONTINUE
*
ELSE IF( CNAME.EQ.'STRMM ' ) THEN
*
* Time STRMM
*
DO 380 ISIDE = 1, NSIDES
SIDE = SIDES( ISIDE )
DO 370 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IF( LSAME( UPLO, 'U' ) ) THEN
IMAT = 9
ELSE
IMAT = -9
END IF
DO 360 ITA = 1, NTRANS
TRANSA = TRANS( ITA )
DO 350 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 340 IM = 1, NM
M = MVAL( IM )
DO 330 IN = 1, NN
N = NVAL( IN )
IF( ISIDE.EQ.1 ) THEN
CALL STIMMG( IMAT, M, M, A, LDA, 0, 0 )
ELSE
CALL STIMMG( IMAT, N, N, A, LDA, 0, 0 )
END IF
CALL STIMMG( 0, M, N, B, LDA, 0, 0 )
IC = 0
S1 = SECOND( )
310 CONTINUE
CALL STRMM( SIDE, UPLO, TRANSA,
$ 'Non-unit', M, N, ALPHA, A,
$ LDA, B, LDA )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, M, N, B, LDA, 0, 0 )
GO TO 310
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
320 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, M, N, B, LDA, 0, 0 )
GO TO 320
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPBL3( CNAME, M, N, ISIDE-1 )
RESLTS( IM, IN, ILDA ) = SMFLOP( OPS,
$ TIME, 0 )
330 CONTINUE
340 CONTINUE
350 CONTINUE
WRITE( NOUT, FMT = 9991 )CNAME, SIDE, UPLO, TRANSA
CALL SPRTBL( 'M', 'N', NM, MVAL, NN, NVAL, NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
360 CONTINUE
370 CONTINUE
380 CONTINUE
*
ELSE IF( CNAME.EQ.'STRSM ' ) THEN
*
* Time STRSM
*
DO 460 ISIDE = 1, NSIDES
SIDE = SIDES( ISIDE )
DO 450 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IF( LSAME( UPLO, 'U' ) ) THEN
IMAT = 9
ELSE
IMAT = -9
END IF
DO 440 ITA = 1, NTRANS
TRANSA = TRANS( ITA )
DO 430 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 420 IM = 1, NM
M = MVAL( IM )
DO 410 IN = 1, NN
N = NVAL( IN )
IF( ISIDE.EQ.1 ) THEN
CALL STIMMG( IMAT, M, M, A, LDA, 0, 0 )
ELSE
CALL STIMMG( IMAT, N, N, A, LDA, 0, 0 )
END IF
CALL STIMMG( 0, M, N, B, LDA, 0, 0 )
IC = 0
S1 = SECOND( )
390 CONTINUE
CALL STRSM( SIDE, UPLO, TRANSA,
$ 'Non-unit', M, N, ALPHA, A,
$ LDA, B, LDA )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, M, N, B, LDA, 0, 0 )
GO TO 390
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
400 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, M, N, B, LDA, 0, 0 )
GO TO 400
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPBL3( CNAME, M, N, ISIDE-1 )
RESLTS( IM, IN, ILDA ) = SMFLOP( OPS,
$ TIME, 0 )
410 CONTINUE
420 CONTINUE
430 CONTINUE
WRITE( NOUT, FMT = 9991 )CNAME, SIDE, UPLO, TRANSA
CALL SPRTBL( 'M', 'N', NM, MVAL, NN, NVAL, NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
440 CONTINUE
450 CONTINUE
460 CONTINUE
END IF
WRITE( NOUT, FMT = 9990 )
470 CONTINUE
480 CONTINUE
*
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'with LDA = ', I5 )
9996 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
9995 FORMAT( / 1X, 'SGEMM with TRANSA = ''', A1, ''', TRANSB = ''',
$ A1, '''' )
9994 FORMAT( / 1X, 'K = ', I4, / )
9993 FORMAT( / 1X, 'SSYMM with SIDE = ''', A1, ''', UPLO = ''', A1,
$ '''', / )
9992 FORMAT( / 1X, A6, ' with UPLO = ''', A1, ''', TRANS = ''', A1,
$ '''', / )
9991 FORMAT( / 1X, A6, ' with SIDE = ''', A1, ''', UPLO = ''', A1,
$ ''',', ' TRANS = ''', A1, '''', / )
9990 FORMAT( / / / / / )
RETURN
*
* End of STIMB3
*
END
SUBROUTINE STIMBR( LINE, NM, MVAL, NVAL, NK, KVAL, NNB, NBVAL,
$ NXVAL, NLDA, LDAVAL, TIMMIN, A, B, D, TAU,
$ WORK, RESLTS, LDR1, LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NK, NLDA, NM, NNB, NOUT
REAL TIMMIN
* ..
* .. Array Arguments ..
INTEGER KVAL( * ), LDAVAL( * ), MVAL( * ), NBVAL( * ),
$ NVAL( * ), NXVAL( * )
REAL A( * ), B( * ), D( * ),
$ RESLTS( LDR1, LDR2, LDR3, * ), TAU( * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* STIMBR times SGEBRD, SORGBR, and SORMBR.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M and N contained in the vectors
* MVAL and NVAL. The matrix sizes are used in pairs (M,N).
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NVAL (input) INTEGER array, dimension (NM)
* The values of the matrix column dimension N.
*
* NK (input) INTEGER
* The number of values of K contained in the vector KVAL.
*
* KVAL (input) INTEGER array, dimension (NK)
* The values of the matrix dimension K.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) REAL
* The minimum time a subroutine will be timed.
*
* A (workspace) REAL array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values of LDA and N.
*
* B (workspace) REAL array, dimension (LDAMAX*NMAX)
*
* D (workspace) REAL array, dimension
* (2*max(min(M,N))-1)
*
* TAU (workspace) REAL array, dimension
* (2*max(min(M,N)))
*
* WORK (workspace) REAL array, dimension (LDAMAX*NBMAX)
* where NBMAX is the maximum value of NB.
*
* RESLTS (output) REAL array, dimension (LDR1,LDR2,LDR3,6)
* The timing results for each subroutine over the relevant
* values of (M,N), (NB,NX), and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NM).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* Internal Parameters
* ===================
*
* MODE INTEGER
* The matrix type. MODE = 3 is a geometric distribution of
* eigenvalues. See CLATMS for further details.
*
* COND REAL
* The condition number of the matrix. The singular values are
* set to values from DMAX to DMAX/COND.
*
* DMAX REAL
* The magnitude of the largest singular value.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 3 )
INTEGER MODE
REAL COND, DMAX
PARAMETER ( MODE = 3, COND = 100.0E0, DMAX = 1.0E0 )
* ..
* .. Local Scalars ..
CHARACTER LABK, LABM, LABN, SIDE, TRANS, VECT
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, I3, I4, IC, ICL, IK, ILDA, IM, INB, INFO,
$ INFO2, ISIDE, ISUB, ITOFF, ITRAN, IVECT, K, K1,
$ LDA, LW, M, M1, MINMN, N, N1, NB, NQ, NX
REAL OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER SIDES( 2 ), TRANSS( 2 ), VECTS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER ISEED( 4 ), RESEED( 4 )
* ..
* .. External Functions ..
REAL SECOND, SMFLOP, SOPLA
EXTERNAL SECOND, SMFLOP, SOPLA
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, ICOPY, SGEBRD, SLACPY, SLATMS,
$ SORGBR, SORMBR, SPRTB4, SPRTB5, STIMMG, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Data statements ..
DATA SUBNAM / 'SGEBRD', 'SORGBR', 'SORMBR' / ,
$ SIDES / 'L', 'R' / , VECTS / 'Q', 'P' / ,
$ TRANSS / 'N', 'T' /
DATA ISEED / 0, 0, 0, 1 /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'BR'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 220
*
* Check that M <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 220
END IF
*
* Check that N <= LDA and K <= LDA for SORMBR
*
IF( TIMSUB( 3 ) ) THEN
CALL ATIMCK( 2, CNAME, NM, NVAL, NLDA, LDAVAL, NOUT, INFO )
CALL ATIMCK( 3, CNAME, NK, KVAL, NLDA, LDAVAL, NOUT, INFO2 )
IF( INFO.GT.0 .OR. INFO2.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )SUBNAM( 3 )
TIMSUB( 3 ) = .FALSE.
END IF
END IF
*
* Do for each pair of values (M,N):
*
DO 140 IM = 1, NM
M = MVAL( IM )
N = NVAL( IM )
MINMN = MIN( M, N )
CALL ICOPY( 4, ISEED, 1, RESEED, 1 )
*
* Do for each value of LDA:
*
DO 130 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
*
* Do for each pair of values (NB, NX) in NBVAL and NXVAL.
*
DO 120 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
LW = MAX( M+N, MAX( 1, NB )*( M+N ) )
*
* Generate a test matrix of size M by N.
*
CALL ICOPY( 4, RESEED, 1, ISEED, 1 )
CALL SLATMS( M, N, 'Uniform', ISEED, 'Nonsym', TAU, MODE,
$ COND, DMAX, M, N, 'No packing', B, LDA,
$ WORK, INFO )
*
IF( TIMSUB( 1 ) ) THEN
*
* SGEBRD: Block reduction to bidiagonal form
*
CALL SLACPY( 'Full', M, N, B, LDA, A, LDA )
IC = 0
S1 = SECOND( )
10 CONTINUE
CALL SGEBRD( M, N, A, LDA, D, D( MINMN ), TAU,
$ TAU( MINMN+1 ), WORK, LW, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL SLACPY( 'Full', M, N, B, LDA, A, LDA )
GO TO 10
END IF
*
* Subtract the time used in SLACPY.
*
ICL = 1
S1 = SECOND( )
20 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL SLACPY( 'Full', M, N, A, LDA, B, LDA )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SGEBRD', M, N, 0, 0, NB )
RESLTS( INB, IM, ILDA, 1 ) = SMFLOP( OPS, TIME, INFO )
ELSE
*
* If SGEBRD was not timed, generate a matrix and reduce
* it using SGEBRD anyway so that the orthogonal
* transformations may be used in timing the other
* routines.
*
CALL SLACPY( 'Full', M, N, B, LDA, A, LDA )
CALL SGEBRD( M, N, A, LDA, D, D( MINMN ), TAU,
$ TAU( MINMN+1 ), WORK, LW, INFO )
*
END IF
*
IF( TIMSUB( 2 ) ) THEN
*
* SORGBR: Generate one of the orthogonal matrices Q or
* P' from the reduction to bidiagonal form
* A = Q * B * P'.
*
DO 50 IVECT = 1, 2
IF( IVECT.EQ.1 ) THEN
VECT = 'Q'
M1 = M
N1 = MIN( M, N )
K1 = N
ELSE
VECT = 'P'
M1 = MIN( M, N )
N1 = N
K1 = M
END IF
I3 = ( IVECT-1 )*NLDA
LW = MAX( 1, MAX( 1, NB )*MIN( M, N ) )
CALL SLACPY( 'Full', M, N, A, LDA, B, LDA )
IC = 0
S1 = SECOND( )
30 CONTINUE
CALL SORGBR( VECT, M1, N1, K1, B, LDA, TAU, WORK,
$ LW, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL SLACPY( 'Full', M, N, A, LDA, B, LDA )
GO TO 30
END IF
*
* Subtract the time used in SLACPY.
*
ICL = 1
S1 = SECOND( )
40 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL SLACPY( 'Full', M, N, A, LDA, B, LDA )
GO TO 40
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
*
* Op count for SORGBR:
*
IF( IVECT.EQ.1 ) THEN
IF( M1.GE.K1 ) THEN
OPS = SOPLA( 'SORGQR', M1, N1, K1, -1, NB )
ELSE
OPS = SOPLA( 'SORGQR', M1-1, M1-1, M1-1, -1,
$ NB )
END IF
ELSE
IF( K1.LT.N1 ) THEN
OPS = SOPLA( 'SORGLQ', M1, N1, K1, -1, NB )
ELSE
OPS = SOPLA( 'SORGLQ', N1-1, N1-1, N1-1, -1,
$ NB )
END IF
END IF
*
RESLTS( INB, IM, I3+ILDA, 2 ) = SMFLOP( OPS, TIME,
$ INFO )
50 CONTINUE
END IF
*
IF( TIMSUB( 3 ) ) THEN
*
* SORMBR: Multiply an m by n matrix B by one of the
* orthogonal matrices Q or P' from the reduction to
* bidiagonal form A = Q * B * P'.
*
DO 110 IVECT = 1, 2
IF( IVECT.EQ.1 ) THEN
VECT = 'Q'
K1 = N
NQ = M
ELSE
VECT = 'P'
K1 = M
NQ = N
END IF
I3 = ( IVECT-1 )*NLDA
I4 = 2
DO 100 ISIDE = 1, 2
SIDE = SIDES( ISIDE )
DO 90 IK = 1, NK
K = KVAL( IK )
IF( ISIDE.EQ.1 ) THEN
M1 = NQ
N1 = K
LW = MAX( 1, MAX( 1, NB )*N1 )
ELSE
M1 = K
N1 = NQ
LW = MAX( 1, MAX( 1, NB )*M1 )
END IF
ITOFF = 0
DO 80 ITRAN = 1, 2
TRANS = TRANSS( ITRAN )
CALL STIMMG( 0, M1, N1, B, LDA, 0, 0 )
IC = 0
S1 = SECOND( )
60 CONTINUE
CALL SORMBR( VECT, SIDE, TRANS, M1, N1,
$ K1, A, LDA, TAU, B, LDA,
$ WORK, LW, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, M1, N1, B, LDA, 0, 0 )
GO TO 60
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
70 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, M1, N1, B, LDA, 0, 0 )
GO TO 70
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
IF( IVECT.EQ.1 ) THEN
*
* Op count for SORMBR, VECT = 'Q':
*
IF( NQ.GE.K1 ) THEN
OPS = SOPLA( 'SORMQR', M1, N1, K1,
$ ISIDE-1, NB )
ELSE IF( ISIDE.EQ.1 ) THEN
OPS = SOPLA( 'SORMQR', M1-1, N1,
$ NQ-1, ISIDE-1, NB )
ELSE
OPS = SOPLA( 'SORMQR', M1, N1-1,
$ NQ-1, ISIDE-1, NB )
END IF
ELSE
*
* Op count for SORMBR, VECT = 'P':
*
IF( NQ.GT.K1 ) THEN
OPS = SOPLA( 'SORMLQ', M1, N1, K1,
$ ISIDE-1, NB )
ELSE IF( ISIDE.EQ.1 ) THEN
OPS = SOPLA( 'SORMLQ', M1-1, N1,
$ NQ-1, ISIDE-1, NB )
ELSE
OPS = SOPLA( 'SORMLQ', M1, N1-1,
$ NQ-1, ISIDE-1, NB )
END IF
END IF
*
RESLTS( INB, IM, I3+ILDA,
$ I4+ITOFF+IK ) = SMFLOP( OPS, TIME,
$ INFO )
ITOFF = NK
80 CONTINUE
90 CONTINUE
I4 = 2*NK + 2
100 CONTINUE
110 CONTINUE
END IF
120 CONTINUE
130 CONTINUE
140 CONTINUE
*
* Print a table of results for each timed routine.
*
DO 210 ISUB = 1, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 210
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 150 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
150 CONTINUE
END IF
IF( ISUB.EQ.1 ) THEN
WRITE( NOUT, FMT = * )
CALL SPRTB4( '( NB, NX)', 'M', 'N', NNB, NBVAL, NXVAL, NM,
$ MVAL, NVAL, NLDA, RESLTS( 1, 1, 1, ISUB ),
$ LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.2 ) THEN
DO 160 IVECT = 1, 2
I3 = ( IVECT-1 )*NLDA + 1
IF( IVECT.EQ.1 ) THEN
LABK = 'N'
LABM = 'M'
LABN = 'K'
ELSE
LABK = 'M'
LABM = 'K'
LABN = 'N'
END IF
WRITE( NOUT, FMT = 9996 )SUBNAM( ISUB ), VECTS( IVECT ),
$ LABK, LABM, LABN
CALL SPRTB4( '( NB, NX)', LABM, LABN, NNB, NBVAL,
$ NXVAL, NM, MVAL, NVAL, NLDA,
$ RESLTS( 1, 1, I3, ISUB ), LDR1, LDR2, NOUT )
160 CONTINUE
ELSE IF( ISUB.EQ.3 ) THEN
DO 200 IVECT = 1, 2
I3 = ( IVECT-1 )*NLDA + 1
I4 = 3
DO 190 ISIDE = 1, 2
IF( ISIDE.EQ.1 ) THEN
IF( IVECT.EQ.1 ) THEN
LABM = 'M'
LABN = 'K'
ELSE
LABM = 'K'
LABN = 'M'
END IF
LABK = 'N'
ELSE
IF( IVECT.EQ.1 ) THEN
LABM = 'N'
LABN = 'K'
ELSE
LABM = 'K'
LABN = 'N'
END IF
LABK = 'M'
END IF
DO 180 ITRAN = 1, 2
DO 170 IK = 1, NK
WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ),
$ VECTS( IVECT ), SIDES( ISIDE ),
$ TRANSS( ITRAN ), LABK, KVAL( IK )
CALL SPRTB5( 'NB', LABM, LABN, NNB, NBVAL, NM,
$ MVAL, NVAL, NLDA,
$ RESLTS( 1, 1, I3, I4 ), LDR1, LDR2,
$ NOUT )
I4 = I4 + 1
170 CONTINUE
180 CONTINUE
190 CONTINUE
200 CONTINUE
END IF
210 CONTINUE
220 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
9996 FORMAT( / 5X, A6, ' with VECT = ''', A1, ''', ', A1, ' = MIN(',
$ A1, ',', A1, ')', / )
9995 FORMAT( / 5X, A6, ' with VECT = ''', A1, ''', SIDE = ''', A1,
$ ''', TRANS = ''', A1, ''', ', A1, ' =', I6, / )
RETURN
*
* End of STIMBR
*
END
SUBROUTINE STIMGB( LINE, NM, MVAL, NK, KVAL, NNS, NSVAL, NNB,
$ NBVAL, NLDA, LDAVAL, TIMMIN, A, B, IWORK,
$ RESLTS, LDR1, LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NK, NLDA, NM, NNB, NNS, NOUT
REAL TIMMIN
* ..
* .. Array Arguments ..
INTEGER IWORK( * ), KVAL( * ), LDAVAL( * ), MVAL( * ),
$ NBVAL( * ), NSVAL( * )
REAL A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * )
* ..
*
* Purpose
* =======
*
* STIMGB times SGBTRF and -TRS.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix size M.
*
* NK (input) INTEGER
* The number of values of K contained in the vector KVAL.
*
* KVAL (input) INTEGER array, dimension (NK)
* The values of the band width K.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* NNB (input) INTEGER
* The number of values of NB contained in the vector NBVAL.
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) REAL
* The minimum time a subroutine will be timed.
*
* A (workspace) REAL array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values permitted
* for LDA and N.
*
* B (workspace) REAL array, dimension (LDAMAX*NMAX)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* RESLTS (output) REAL array, dimension
* (LDR1,LDR2,LDR3,NSUBS)
* The timing results for each subroutine over the relevant
* values of N, K, NB, and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(4,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NK).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 2 )
* ..
* .. Local Scalars ..
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, IC, ICL, IK, ILDA, IM, INB, INFO, ISUB, K,
$ KL, KU, LDA, LDB, M, N, NB, NRHS
REAL OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER*6 SUBNAM( NSUBS )
* ..
* .. External Functions ..
REAL SECOND, SMFLOP, SOPGB, SOPLA
EXTERNAL SECOND, SMFLOP, SOPGB, SOPLA
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, SGBTRF, SGBTRS, SPRTBL, STIMMG,
$ XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Data statements ..
DATA SUBNAM / 'SGBTRF', 'SGBTRS' /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'GB'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 120
*
* Check that 3*K+1 <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 0, CNAME, NK, KVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 120
END IF
*
* Do for each value of the matrix size M:
*
DO 110 IM = 1, NM
M = MVAL( IM )
N = M
*
* Do for each value of LDA:
*
DO 80 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
*
* Do for each value of the band width K:
*
DO 70 IK = 1, NK
K = KVAL( IK )
KL = MAX( 0, MIN( K, M-1 ) )
KU = MAX( 0, MIN( K, N-1 ) )
*
* Time SGBTRF
*
IF( TIMSUB( 1 ) ) THEN
*
* Do for each value of NB in NBVAL. Only SGBTRF is
* timed in this loop since the other routines are
* independent of NB.
*
DO 30 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
IC = 0
CALL STIMMG( 2, M, N, A, LDA, KL, KU )
S1 = SECOND( )
10 CONTINUE
CALL SGBTRF( M, N, KL, KU, A, LDA, IWORK, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 2, M, N, A, LDA, KL, KU )
GO TO 10
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
20 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 2, M, N, A, LDA, KL, KU )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPGB( 'SGBTRF', M, N, KL, KU, IWORK )
RESLTS( INB, IK, ILDA, 1 ) = SMFLOP( OPS, TIME,
$ INFO )
30 CONTINUE
ELSE
IC = 0
CALL STIMMG( 2, M, N, A, LDA, KL, KU )
END IF
*
* Generate another matrix and factor it using SGBTRF so
* that the factored form can be used in timing the other
* routines.
*
NB = 1
CALL XLAENV( 1, NB )
IF( IC.NE.1 )
$ CALL SGBTRF( M, N, KL, KU, A, LDA, IWORK, INFO )
*
* Time SGBTRS
*
IF( TIMSUB( 2 ) ) THEN
DO 60 I = 1, NNS
NRHS = NSVAL( I )
LDB = N
IC = 0
CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 )
S1 = SECOND( )
40 CONTINUE
CALL SGBTRS( 'No transpose', N, KL, KU, NRHS, A,
$ LDA, IWORK, B, LDB, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 40
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
50 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 50
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SGBTRS', N, NRHS, KL, KU, 0 )
RESLTS( I, IK, ILDA, 2 ) = SMFLOP( OPS, TIME,
$ INFO )
60 CONTINUE
END IF
70 CONTINUE
80 CONTINUE
*
* Print a table of results for each routine
*
DO 100 ISUB = 1, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 100
*
* Print header for routine names.
*
IF( IM.EQ.1 .OR. CNAME.EQ.'SGB ' ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.EQ.1 ) THEN
WRITE( NOUT, FMT = 9997 )LDAVAL( 1 )
ELSE
DO 90 I = 1, NLDA
WRITE( NOUT, FMT = 9996 )I, LDAVAL( I )
90 CONTINUE
END IF
END IF
*
WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ), N
IF( ISUB.EQ.1 ) THEN
CALL SPRTBL( 'NB', 'K', NNB, NBVAL, NK, KVAL, NLDA,
$ RESLTS( 1, 1, 1, 1 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.2 ) THEN
CALL SPRTBL( 'NRHS', 'K', NNS, NSVAL, NK, KVAL, NLDA,
$ RESLTS( 1, 1, 1, 2 ), LDR1, LDR2, NOUT )
END IF
100 CONTINUE
110 CONTINUE
120 CONTINUE
*
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'with LDA = ', I5 )
9996 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
9995 FORMAT( / 5X, A6, ' with M =', I6, / )
*
RETURN
*
* End of STIMGB
*
END
SUBROUTINE STIMGE( LINE, NM, MVAL, NNS, NSVAL, NNB, NBVAL, NLDA,
$ LDAVAL, TIMMIN, A, B, WORK, IWORK, RESLTS,
$ LDR1, LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NLDA, NM, NNB, NNS, NOUT
REAL TIMMIN
* ..
* .. Array Arguments ..
INTEGER IWORK( * ), LDAVAL( * ), MVAL( * ), NBVAL( * ),
$ NSVAL( * )
REAL A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* STIMGE times SGETRF, -TRS, and -TRI.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix size M.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* NNB (input) INTEGER
* The number of values of NB contained in the vector NBVAL.
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) REAL
* The minimum time a subroutine will be timed.
*
* A (workspace) REAL array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values permitted
* for LDA and N.
*
* B (workspace) REAL array, dimension (LDAMAX*NMAX)
*
* WORK (workspace) REAL array, dimension (LDAMAX*NBMAX)
* where NBMAX is the maximum value of the block size NB.
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* RESLTS (output) REAL array, dimension
* (LDR1,LDR2,LDR3,NSUBS)
* The timing results for each subroutine over the relevant
* values of N and NB.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(4,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NM).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 3 )
* ..
* .. Local Scalars ..
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, IC, ICL, ILDA, IM, INB, INFO, ISUB, LDA,
$ LDB, M, N, NB, NRHS
REAL OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER*6 SUBNAM( NSUBS )
* ..
* .. External Functions ..
REAL SECOND, SMFLOP, SOPLA
EXTERNAL SECOND, SMFLOP, SOPLA
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, SGETRF, SGETRI, SGETRS, SLACPY,
$ SPRTBL, STIMMG, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. Data statements ..
DATA SUBNAM / 'SGETRF', 'SGETRS', 'SGETRI' /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'GE'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 130
*
* Check that N <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 2, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 130
END IF
*
* Do for each value of M:
*
DO 100 IM = 1, NM
*
M = MVAL( IM )
N = M
*
* Do for each value of LDA:
*
DO 90 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
*
* Do for each value of NB in NBVAL. Only the blocked
* routines are timed in this loop since the other routines
* are independent of NB.
*
DO 50 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
*
* Time SGETRF
*
IF( TIMSUB( 1 ) ) THEN
CALL STIMMG( 1, M, N, A, LDA, 0, 0 )
IC = 0
S1 = SECOND( )
10 CONTINUE
CALL SGETRF( M, N, A, LDA, IWORK, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 1, M, N, A, LDA, 0, 0 )
GO TO 10
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
20 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 1, M, N, A, LDA, 0, 0 )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SGETRF', M, N, 0, 0, NB )
RESLTS( INB, IM, ILDA, 1 ) = SMFLOP( OPS, TIME, INFO )
*
ELSE
IC = 0
CALL STIMMG( 1, M, N, A, LDA, 0, 0 )
END IF
*
* Generate another matrix and factor it using SGETRF so
* that the factored form can be used in timing the other
* routines.
*
IF( IC.NE.1 )
$ CALL SGETRF( M, N, A, LDA, IWORK, INFO )
*
* Time SGETRI
*
IF( TIMSUB( 3 ) ) THEN
CALL SLACPY( 'Full', M, M, A, LDA, B, LDA )
IC = 0
S1 = SECOND( )
30 CONTINUE
CALL SGETRI( M, B, LDA, IWORK, WORK, LDA*NB, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL SLACPY( 'Full', M, M, A, LDA, B, LDA )
GO TO 30
END IF
*
* Subtract the time used in SLACPY.
*
ICL = 1
S1 = SECOND( )
40 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL SLACPY( 'Full', M, M, A, LDA, B, LDA )
GO TO 40
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SGETRI', M, M, 0, 0, NB )
RESLTS( INB, IM, ILDA, 3 ) = SMFLOP( OPS, TIME, INFO )
END IF
50 CONTINUE
*
* Time SGETRS
*
IF( TIMSUB( 2 ) ) THEN
DO 80 I = 1, NNS
NRHS = NSVAL( I )
LDB = LDA
CALL STIMMG( 0, M, NRHS, B, LDB, 0, 0 )
IC = 0
S1 = SECOND( )
60 CONTINUE
CALL SGETRS( 'No transpose', M, NRHS, A, LDA, IWORK,
$ B, LDB, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, M, NRHS, B, LDB, 0, 0 )
GO TO 60
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
70 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, M, NRHS, B, LDB, 0, 0 )
GO TO 70
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SGETRS', M, NRHS, 0, 0, 0 )
RESLTS( I, IM, ILDA, 2 ) = SMFLOP( OPS, TIME, INFO )
80 CONTINUE
END IF
90 CONTINUE
100 CONTINUE
*
* Print a table of results for each timed routine.
*
DO 120 ISUB = 1, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 120
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 110 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
110 CONTINUE
END IF
WRITE( NOUT, FMT = * )
IF( ISUB.EQ.1 ) THEN
CALL SPRTBL( 'NB', 'N', NNB, NBVAL, NM, MVAL, NLDA, RESLTS,
$ LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.2 ) THEN
CALL SPRTBL( 'NRHS', 'N', NNS, NSVAL, NM, MVAL, NLDA,
$ RESLTS( 1, 1, 1, 2 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.3 ) THEN
CALL SPRTBL( 'NB', 'N', NNB, NBVAL, NM, MVAL, NLDA,
$ RESLTS( 1, 1, 1, 3 ), LDR1, LDR2, NOUT )
END IF
120 CONTINUE
*
130 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
RETURN
*
* End of STIMGE
*
END
SUBROUTINE STIMGT( LINE, NM, MVAL, NNS, NSVAL, NLDA, LDAVAL,
$ TIMMIN, A, B, IWORK, RESLTS, LDR1, LDR2, LDR3,
$ NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NLDA, NM, NNS, NOUT
REAL TIMMIN
* ..
* .. Array Arguments ..
INTEGER IWORK( * ), LDAVAL( * ), MVAL( * ), NSVAL( * )
REAL A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * )
* ..
*
* Purpose
* =======
*
* STIMGT times SGTTRF, -TRS, -SV, and -SL.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix size M.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) REAL
* The minimum time a subroutine will be timed.
*
* A (workspace) REAL array, dimension (NMAX*4)
* where NMAX is the maximum value permitted for N.
*
* B (workspace) REAL array, dimension (LDAMAX*NMAX)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* RESLTS (output) REAL array, dimension
* (LDR1,LDR2,LDR3,NSUBS+1)
* The timing results for each subroutine over the relevant
* values of N.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= 1.
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NM).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 4 )
* ..
* .. Local Scalars ..
CHARACTER TRANS
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, IC, ICL, ILDA, IM, INFO, ISUB, ITRAN, LDB,
$ M, N, NRHS
REAL OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER TRANSS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER LAVAL( 1 )
* ..
* .. External Functions ..
REAL SECOND, SMFLOP, SOPGB
EXTERNAL SECOND, SMFLOP, SOPGB
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, SGTSL, SGTSV, SGTTRF, SGTTRS,
$ SPRTBL, STIMMG
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, REAL
* ..
* .. Data statements ..
DATA SUBNAM / 'SGTTRF', 'SGTTRS', 'SGTSV ',
$ 'SGTSL ' /
DATA TRANSS / 'N', 'T' /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'GT'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 180
*
* Check that N <= LDA for the input values.
*
DO 10 ISUB = 2, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 10
CNAME = SUBNAM( ISUB )
CALL ATIMCK( 2, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9998 )CNAME
TIMSUB( ISUB ) = .FALSE.
END IF
10 CONTINUE
*
* Do for each value of M:
*
DO 150 IM = 1, NM
*
M = MVAL( IM )
N = MAX( M, 1 )
*
* Time SGTTRF
*
IF( TIMSUB( 1 ) ) THEN
CALL STIMMG( 12, M, M, A, 3*N, 0, 0 )
IC = 0
S1 = SECOND( )
20 CONTINUE
CALL SGTTRF( M, A, A( N ), A( 2*N ), A( 3*N-2 ), IWORK,
$ INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 12, M, M, A, 3*N, 0, 0 )
GO TO 20
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
30 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 12, M, M, A, 3*N, 0, 0 )
GO TO 30
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPGB( 'SGTTRF', M, M, 1, 1, IWORK )
RESLTS( 1, IM, 1, 1 ) = SMFLOP( OPS, TIME, INFO )
*
ELSE IF( TIMSUB( 2 ) ) THEN
CALL STIMMG( 12, M, M, A, 3*N, 0, 0 )
END IF
*
* Generate another matrix and factor it using SGTTRF so
* that the factored form can be used in timing the other
* routines.
*
IF( IC.NE.1 )
$ CALL SGTTRF( M, A, A( N ), A( 2*N ), A( 3*N-2 ), IWORK,
$ INFO )
*
* Time SGTTRS
*
IF( TIMSUB( 2 ) ) THEN
DO 80 ITRAN = 1, 2
TRANS = TRANSS( ITRAN )
DO 70 ILDA = 1, NLDA
LDB = LDAVAL( ILDA )
DO 60 I = 1, NNS
NRHS = NSVAL( I )
CALL STIMMG( 0, M, NRHS, B, LDB, 0, 0 )
IC = 0
S1 = SECOND( )
40 CONTINUE
CALL SGTTRS( TRANS, M, NRHS, A, A( N ), A( 2*N ),
$ A( 3*N-2 ), IWORK, B, LDB, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, M, NRHS, B, LDB, 0, 0 )
GO TO 40
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
50 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, M, NRHS, B, LDB, 0, 0 )
GO TO 50
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPGB( 'SGTTRS', M, NRHS, 0, 0, IWORK )
IF( ITRAN.EQ.1 ) THEN
RESLTS( I, IM, ILDA, 2 ) = SMFLOP( OPS, TIME,
$ INFO )
ELSE
RESLTS( I, IM, ILDA, 5 ) = SMFLOP( OPS, TIME,
$ INFO )
END IF
60 CONTINUE
70 CONTINUE
80 CONTINUE
END IF
*
IF( TIMSUB( 3 ) ) THEN
DO 120 ILDA = 1, NLDA
LDB = LDAVAL( ILDA )
DO 110 I = 1, NNS
NRHS = NSVAL( I )
CALL STIMMG( 12, M, M, A, 3*N, 0, 0 )
CALL STIMMG( 0, M, NRHS, B, LDB, 0, 0 )
IC = 0
S1 = SECOND( )
90 CONTINUE
CALL SGTSV( M, NRHS, A, A( N ), A( 2*N ), B, LDB,
$ INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 12, M, M, A, 3*N, 0, 0 )
CALL STIMMG( 0, M, NRHS, B, LDB, 0, 0 )
GO TO 90
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
100 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 12, M, M, A, 3*N, 0, 0 )
CALL STIMMG( 0, M, NRHS, B, LDB, 0, 0 )
GO TO 100
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPGB( 'SGTSV ', M, NRHS, 0, 0, IWORK )
RESLTS( I, IM, ILDA, 3 ) = SMFLOP( OPS, TIME, INFO )
110 CONTINUE
120 CONTINUE
END IF
*
IF( TIMSUB( 4 ) ) THEN
CALL STIMMG( 12, M, M, A, 3*N, 0, 0 )
CALL STIMMG( 0, M, 1, B, N, 0, 0 )
IC = 0
S1 = SECOND( )
130 CONTINUE
CALL SGTSL( M, A, A( N ), A( 2*N ), B, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 12, M, M, A, 3*N, 0, 0 )
CALL STIMMG( 0, M, 1, B, LDB, 0, 0 )
GO TO 130
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
140 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 12, M, M, A, 3*N, 0, 0 )
CALL STIMMG( 0, M, 1, B, LDB, 0, 0 )
GO TO 140
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPGB( 'SGTSV ', M, 1, 0, 0, IWORK )
RESLTS( 1, IM, 1, 4 ) = SMFLOP( OPS, TIME, INFO )
END IF
150 CONTINUE
*
* Print a table of results for each timed routine.
*
DO 170 ISUB = 1, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 170
WRITE( NOUT, FMT = 9997 )SUBNAM( ISUB )
IF( NLDA.GT.1 .AND. ( TIMSUB( 2 ) .OR. TIMSUB( 3 ) ) ) THEN
DO 160 I = 1, NLDA
WRITE( NOUT, FMT = 9996 )I, LDAVAL( I )
160 CONTINUE
END IF
WRITE( NOUT, FMT = * )
IF( ISUB.EQ.1 ) THEN
CALL SPRTBL( ' ', 'N', 1, LAVAL, NM, MVAL, 1, RESLTS, LDR1,
$ LDR2, NOUT )
ELSE IF( ISUB.EQ.2 ) THEN
WRITE( NOUT, FMT = 9999 )'N'
9999 FORMAT( ' SGTTRS with TRANS = ''', A1, '''', / )
CALL SPRTBL( 'NRHS', 'N', NNS, NSVAL, NM, MVAL, NLDA,
$ RESLTS( 1, 1, 1, 2 ), LDR1, LDR2, NOUT )
WRITE( NOUT, FMT = 9999 )'T'
CALL SPRTBL( 'NRHS', 'N', NNS, NSVAL, NM, MVAL, NLDA,
$ RESLTS( 1, 1, 1, 5 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.3 ) THEN
CALL SPRTBL( 'NRHS', 'N', NNS, NSVAL, NM, MVAL, NLDA,
$ RESLTS( 1, 1, 1, 3 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.4 ) THEN
CALL SPRTBL( ' ', 'N', 1, LAVAL, NM, MVAL, 1,
$ RESLTS( 1, 1, 1, 4 ), LDR1, LDR2, NOUT )
END IF
170 CONTINUE
*
180 CONTINUE
9998 FORMAT( 1X, A6, ' timing run not attempted', / )
9997 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9996 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
RETURN
*
* End of STIMGT
*
END
SUBROUTINE STIMHR( LINE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
$ NLDA, LDAVAL, TIMMIN, A, TAU, B, WORK, RESLTS,
$ LDR1, LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NLDA, NM, NN, NNB, NOUT
REAL TIMMIN
* ..
* .. Array Arguments ..
INTEGER LDAVAL( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
$ NXVAL( * )
REAL A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * ),
$ TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* STIMHR times the LAPACK routines SGEHRD, SORGHR, and SORMHR and the
* EISPACK routine ORTHES.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix size M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) REAL
* The minimum time a subroutine will be timed.
*
* A (workspace) REAL array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values of LDA and N.
*
* TAU (workspace) REAL array, dimension (min(M,N))
*
* B (workspace) REAL array, dimension (LDAMAX*NMAX)
*
* WORK (workspace) REAL array, dimension (LDAMAX*NBMAX)
* where NBMAX is the maximum value of NB.
*
* RESLTS (workspace) REAL array, dimension
* (LDR1,LDR2,LDR3,4*NN+3)
* The timing results for each subroutine over the relevant
* values of M, (NB,NX), LDA, and N.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NM).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* Internal Parameters
* ===================
*
* MODE INTEGER
* The matrix type. MODE = 3 is a geometric distribution of
* eigenvalues. See CLATMS for further details.
*
* COND REAL
* The condition number of the matrix. The singular values are
* set to values from DMAX to DMAX/COND.
*
* DMAX REAL
* The magnitude of the largest singular value.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 4 )
INTEGER MODE
REAL COND, DMAX
PARAMETER ( MODE = 3, COND = 100.0E0, DMAX = 1.0E0 )
* ..
* .. Local Scalars ..
CHARACTER LAB1, LAB2, SIDE, TRANS
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, I4, IC, ICL, IHI, ILDA, ILO, IM, IN, INB,
$ INFO, ISIDE, ISUB, ITOFF, ITRAN, LDA, LW, M,
$ M1, N, N1, NB, NX
REAL OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER SIDES( 2 ), TRANSS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER ISEED( 4 ), RESEED( 4 )
* ..
* .. External Functions ..
REAL SECOND, SMFLOP, SOPLA
EXTERNAL SECOND, SMFLOP, SOPLA
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, ICOPY, ORTHES, SGEHRD, SLACPY,
$ SLATMS, SORGHR, SORMHR, SPRTB3, SPRTBL, STIMMG,
$ XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, REAL
* ..
* .. Data statements ..
DATA SUBNAM / 'SGEHRD', 'ORTHES', 'SORGHR',
$ 'SORMHR' /
DATA SIDES / 'L', 'R' / , TRANSS / 'N', 'T' /
DATA ISEED / 0, 0, 0, 1 /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'HR'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 210
*
* Check that N <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 2, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 210
END IF
*
* Check that K <= LDA for SORMHR
*
IF( TIMSUB( 4 ) ) THEN
CALL ATIMCK( 3, CNAME, NN, NVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )SUBNAM( 4 )
TIMSUB( 4 ) = .FALSE.
END IF
END IF
*
* Do for each value of M:
*
DO 140 IM = 1, NM
M = MVAL( IM )
ILO = 1
IHI = M
CALL ICOPY( 4, ISEED, 1, RESEED, 1 )
*
* Do for each value of LDA:
*
DO 130 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
*
* Do for each pair of values (NB, NX) in NBVAL and NXVAL.
*
DO 120 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
LW = MAX( 1, M*MAX( 1, NB ) )
*
* Generate a test matrix of size M by M.
*
CALL ICOPY( 4, RESEED, 1, ISEED, 1 )
CALL SLATMS( M, M, 'Uniform', ISEED, 'Nonsym', TAU, MODE,
$ COND, DMAX, M, M, 'No packing', B, LDA,
$ WORK, INFO )
*
IF( TIMSUB( 2 ) .AND. INB.EQ.1 ) THEN
*
* ORTHES: Eispack reduction using orthogonal
* transformations.
*
CALL SLACPY( 'Full', M, M, B, LDA, A, LDA )
IC = 0
S1 = SECOND( )
10 CONTINUE
CALL ORTHES( LDA, M, 1, IHI, A, TAU )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL SLACPY( 'Full', M, M, B, LDA, A, LDA )
GO TO 10
END IF
*
* Subtract the time used in SLACPY.
*
ICL = 1
S1 = SECOND( )
20 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL SLACPY( 'Full', M, M, B, LDA, A, LDA )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SGEHRD', M, ILO, IHI, 0, NB )
RESLTS( INB, IM, ILDA, 2 ) = SMFLOP( OPS, TIME, INFO )
END IF
*
IF( TIMSUB( 1 ) ) THEN
*
* SGEHRD: Reduction to Hesenberg form
*
CALL SLACPY( 'Full', M, M, B, LDA, A, LDA )
IC = 0
S1 = SECOND( )
30 CONTINUE
CALL SGEHRD( M, ILO, IHI, A, LDA, TAU, WORK, LW,
$ INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL SLACPY( 'Full', M, M, B, LDA, A, LDA )
GO TO 30
END IF
*
* Subtract the time used in SLACPY.
*
ICL = 1
S1 = SECOND( )
40 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL SLACPY( 'Full', M, M, A, LDA, B, LDA )
GO TO 40
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SGEHRD', M, ILO, IHI, 0, NB )
RESLTS( INB, IM, ILDA, 1 ) = SMFLOP( OPS, TIME, INFO )
ELSE
*
* If SGEHRD was not timed, generate a matrix and factor
* it using SGEHRD anyway so that the factored form of
* the matrix can be used in timing the other routines.
*
CALL SLACPY( 'Full', M, M, B, LDA, A, LDA )
CALL SGEHRD( M, ILO, IHI, A, LDA, TAU, WORK, LW,
$ INFO )
END IF
*
IF( TIMSUB( 3 ) ) THEN
*
* SORGHR: Generate the orthogonal matrix Q from the
* reduction to Hessenberg form A = Q*H*Q'
*
CALL SLACPY( 'Full', M, M, A, LDA, B, LDA )
IC = 0
S1 = SECOND( )
50 CONTINUE
CALL SORGHR( M, ILO, IHI, B, LDA, TAU, WORK, LW,
$ INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL SLACPY( 'Full', M, M, A, LDA, B, LDA )
GO TO 50
END IF
*
* Subtract the time used in SLACPY.
*
ICL = 1
S1 = SECOND( )
60 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL SLACPY( 'Full', M, M, A, LDA, B, LDA )
GO TO 60
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
*
* Op count for SORGHR: same as
* SORGQR( IHI-ILO, IHI-ILO, IHI-ILO, ... )
*
OPS = SOPLA( 'SORGQR', IHI-ILO, IHI-ILO, IHI-ILO, 0,
$ NB )
RESLTS( INB, IM, ILDA, 3 ) = SMFLOP( OPS, TIME, INFO )
END IF
*
IF( TIMSUB( 4 ) ) THEN
*
* SORMHR: Multiply by Q stored as a product of
* elementary transformations
*
I4 = 3
DO 110 ISIDE = 1, 2
SIDE = SIDES( ISIDE )
DO 100 IN = 1, NN
N = NVAL( IN )
LW = MAX( 1, MAX( 1, NB )*N )
IF( ISIDE.EQ.1 ) THEN
M1 = M
N1 = N
ELSE
M1 = N
N1 = M
END IF
ITOFF = 0
DO 90 ITRAN = 1, 2
TRANS = TRANSS( ITRAN )
CALL STIMMG( 0, M1, N1, B, LDA, 0, 0 )
IC = 0
S1 = SECOND( )
70 CONTINUE
CALL SORMHR( SIDE, TRANS, M1, N1, ILO, IHI,
$ A, LDA, TAU, B, LDA, WORK, LW,
$ INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, M1, N1, B, LDA, 0, 0 )
GO TO 70
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
80 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, M1, N1, B, LDA, 0, 0 )
GO TO 80
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
*
* Op count for SORMHR, SIDE='L': same as
* SORMQR( 'L', TRANS, IHI-ILO, N, IHI-ILO, ...)
*
* Op count for SORMHR, SIDE='R': same as
* SORMQR( 'R', TRANS, M, IHI-ILO, IHI-ILO, ...)
*
IF( ISIDE.EQ.1 ) THEN
OPS = SOPLA( 'SORMQR', IHI-ILO, N1,
$ IHI-ILO, -1, NB )
ELSE
OPS = SOPLA( 'SORMQR', M1, IHI-ILO,
$ IHI-ILO, 1, NB )
END IF
*
RESLTS( INB, IM, ILDA,
$ I4+ITOFF+IN ) = SMFLOP( OPS, TIME, INFO )
ITOFF = NN
90 CONTINUE
100 CONTINUE
I4 = I4 + 2*NN
110 CONTINUE
END IF
*
120 CONTINUE
130 CONTINUE
140 CONTINUE
*
* Print tables of results for SGEHRD, ORTHES, and SORGHR
*
DO 160 ISUB = 1, NSUBS - 1
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 160
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 150 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
150 CONTINUE
END IF
WRITE( NOUT, FMT = 9995 )
IF( ISUB.EQ.2 ) THEN
CALL SPRTB3( ' ', 'N', 1, NBVAL, NXVAL, NM, MVAL, NLDA,
$ RESLTS( 1, 1, 1, ISUB ), LDR1, LDR2, NOUT )
ELSE
CALL SPRTB3( '( NB, NX)', 'N', NNB, NBVAL, NXVAL, NM,
$ MVAL, NLDA, RESLTS( 1, 1, 1, ISUB ), LDR1,
$ LDR2, NOUT )
END IF
160 CONTINUE
*
* Print tables of results for SORMHR
*
ISUB = 4
IF( TIMSUB( ISUB ) ) THEN
I4 = 3
DO 200 ISIDE = 1, 2
IF( ISIDE.EQ.1 ) THEN
LAB1 = 'M'
LAB2 = 'N'
IF( NLDA.GT.1 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
DO 170 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
170 CONTINUE
WRITE( NOUT, FMT = 9994 )
END IF
ELSE
LAB1 = 'N'
LAB2 = 'M'
END IF
DO 190 ITRAN = 1, 2
DO 180 IN = 1, NN
WRITE( NOUT, FMT = 9996 )SUBNAM( ISUB ),
$ SIDES( ISIDE ), TRANSS( ITRAN ), LAB2, NVAL( IN )
CALL SPRTBL( 'NB', LAB1, NNB, NBVAL, NM, MVAL, NLDA,
$ RESLTS( 1, 1, 1, I4+IN ), LDR1, LDR2,
$ NOUT )
180 CONTINUE
I4 = I4 + NN
190 CONTINUE
200 CONTINUE
END IF
210 CONTINUE
*
* Print a table of results for each timed routine.
*
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops *** ' )
9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
9996 FORMAT( / 5X, A6, ' with SIDE = ''', A1, ''', TRANS = ''', A1,
$ ''', ', A1, ' =', I6, / )
9995 FORMAT( / 5X, 'ILO = 1, IHI = N', / )
9994 FORMAT( / 5X, 'ILO = 1, IHI = M if SIDE = ''L''', / 5X,
$ ' = N if SIDE = ''R''' )
RETURN
*
* End of STIMHR
*
END
SUBROUTINE STIMLQ( LINE, NM, MVAL, NVAL, NK, KVAL, NNB, NBVAL,
$ NXVAL, NLDA, LDAVAL, TIMMIN, A, TAU, B, WORK,
$ RESLTS, LDR1, LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NK, NLDA, NM, NNB, NOUT
REAL TIMMIN
* ..
* .. Array Arguments ..
INTEGER KVAL( * ), LDAVAL( * ), MVAL( * ), NBVAL( * ),
$ NVAL( * ), NXVAL( * )
REAL A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * ),
$ TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* STIMLQ times the LAPACK routines to perform the LQ factorization of
* a REAL general matrix.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M and N contained in the vectors
* MVAL and NVAL. The matrix sizes are used in pairs (M,N).
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NVAL (input) INTEGER array, dimension (NM)
* The values of the matrix column dimension N.
*
* NK (input) INTEGER
* The number of values of K in the vector KVAL.
*
* KVAL (input) INTEGER array, dimension (NK)
* The values of the matrix dimension K, used in SORMLQ.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) REAL
* The minimum time a subroutine will be timed.
*
* A (workspace) REAL array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values of LDA and N.
*
* TAU (workspace) REAL array, dimension (min(M,N))
*
* B (workspace) REAL array, dimension (LDAMAX*NMAX)
*
* WORK (workspace) REAL array, dimension (LDAMAX*NBMAX)
* where NBMAX is the maximum value of NB.
*
* RESLTS (workspace) REAL array, dimension
* (LDR1,LDR2,LDR3,2*NK)
* The timing results for each subroutine over the relevant
* values of (M,N), (NB,NX), and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NM).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* Internal Parameters
* ===================
*
* MODE INTEGER
* The matrix type. MODE = 3 is a geometric distribution of
* eigenvalues. See SLATMS for further details.
*
* COND REAL
* The condition number of the matrix. The singular values are
* set to values from DMAX to DMAX/COND.
*
* DMAX REAL
* The magnitude of the largest singular value.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 3 )
INTEGER MODE
REAL COND, DMAX
PARAMETER ( MODE = 3, COND = 100.0E0, DMAX = 1.0E0 )
* ..
* .. Local Scalars ..
CHARACTER LABM, SIDE, TRANS
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, I4, IC, ICL, IK, ILDA, IM, IMX, INB, INFO,
$ ISIDE, ISUB, ITOFF, ITRAN, K, K1, LDA, LW, M,
$ M1, MINMN, N, N1, NB, NX
REAL OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER SIDES( 2 ), TRANSS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER ISEED( 4 ), MUSE( 12 ), NUSE( 12 ), RESEED( 4 )
* ..
* .. External Functions ..
REAL SECOND, SMFLOP, SOPLA
EXTERNAL SECOND, SMFLOP, SOPLA
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, ICOPY, SGELQF, SLACPY, SLATMS,
$ SORGLQ, SORMLQ, SPRTB4, SPRTB5, STIMMG, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Data statements ..
DATA SUBNAM / 'SGELQF', 'SORGLQ', 'SORMLQ' /
DATA SIDES / 'L', 'R' / , TRANSS / 'N', 'T' /
DATA ISEED / 0, 0, 0, 1 /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'LQ'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 230
*
* Check that M <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 230
END IF
*
* Do for each pair of values (M,N):
*
DO 70 IM = 1, NM
M = MVAL( IM )
N = NVAL( IM )
MINMN = MIN( M, N )
CALL ICOPY( 4, ISEED, 1, RESEED, 1 )
*
* Do for each value of LDA:
*
DO 60 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
*
* Do for each pair of values (NB, NX) in NBVAL and NXVAL.
*
DO 50 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
LW = MAX( 1, M*MAX( 1, NB ) )
*
* Generate a test matrix of size M by N.
*
CALL ICOPY( 4, RESEED, 1, ISEED, 1 )
CALL SLATMS( M, N, 'Uniform', ISEED, 'Nonsym', TAU, MODE,
$ COND, DMAX, M, N, 'No packing', B, LDA,
$ WORK, INFO )
*
IF( TIMSUB( 1 ) ) THEN
*
* SGELQF: LQ factorization
*
CALL SLACPY( 'Full', M, N, B, LDA, A, LDA )
IC = 0
S1 = SECOND( )
10 CONTINUE
CALL SGELQF( M, N, A, LDA, TAU, WORK, LW, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL SLACPY( 'Full', M, N, B, LDA, A, LDA )
GO TO 10
END IF
*
* Subtract the time used in SLACPY.
*
ICL = 1
S1 = SECOND( )
20 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL SLACPY( 'Full', M, N, A, LDA, B, LDA )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SGELQF', M, N, 0, 0, NB )
RESLTS( INB, IM, ILDA, 1 ) = SMFLOP( OPS, TIME, INFO )
ELSE
*
* If SGELQF was not timed, generate a matrix and factor
* it using SGELQF anyway so that the factored form of
* the matrix can be used in timing the other routines.
*
CALL SLACPY( 'Full', M, N, B, LDA, A, LDA )
CALL SGELQF( M, N, A, LDA, TAU, WORK, LW, INFO )
END IF
*
IF( TIMSUB( 2 ) ) THEN
*
* SORGLQ: Generate orthogonal matrix Q from the LQ
* factorization
*
CALL SLACPY( 'Full', MINMN, N, A, LDA, B, LDA )
IC = 0
S1 = SECOND( )
30 CONTINUE
CALL SORGLQ( MINMN, N, MINMN, B, LDA, TAU, WORK, LW,
$ INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL SLACPY( 'Full', MINMN, N, A, LDA, B, LDA )
GO TO 30
END IF
*
* Subtract the time used in SLACPY.
*
ICL = 1
S1 = SECOND( )
40 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL SLACPY( 'Full', MINMN, N, A, LDA, B, LDA )
GO TO 40
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SORGLQ', MINMN, N, MINMN, 0, NB )
RESLTS( INB, IM, ILDA, 2 ) = SMFLOP( OPS, TIME, INFO )
END IF
*
50 CONTINUE
60 CONTINUE
70 CONTINUE
*
* Print tables of results
*
DO 90 ISUB = 1, NSUBS - 1
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 90
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 80 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
80 CONTINUE
END IF
WRITE( NOUT, FMT = * )
IF( ISUB.EQ.2 )
$ WRITE( NOUT, FMT = 9996 )
CALL SPRTB4( '( NB, NX)', 'M', 'N', NNB, NBVAL, NXVAL, NM,
$ MVAL, NVAL, NLDA, RESLTS( 1, 1, 1, ISUB ), LDR1,
$ LDR2, NOUT )
90 CONTINUE
*
* Time SORMLQ separately. Here the starting matrix is M by N, and
* K is the free dimension of the matrix multiplied by Q.
*
IF( TIMSUB( 3 ) ) THEN
*
* Check that K <= LDA for the input values.
*
CALL ATIMCK( 3, CNAME, NK, KVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )SUBNAM( 3 )
GO TO 230
END IF
*
* Use only the pairs (M,N) where M <= N.
*
IMX = 0
DO 100 IM = 1, NM
IF( MVAL( IM ).LE.NVAL( IM ) ) THEN
IMX = IMX + 1
MUSE( IMX ) = MVAL( IM )
NUSE( IMX ) = NVAL( IM )
END IF
100 CONTINUE
*
* SORMLQ: Multiply by Q stored as a product of elementary
* transformations
*
* Do for each pair of values (M,N):
*
DO 180 IM = 1, IMX
M = MUSE( IM )
N = NUSE( IM )
*
* Do for each value of LDA:
*
DO 170 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
*
* Generate an M by N matrix and form its LQ decomposition.
*
CALL SLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', TAU,
$ MODE, COND, DMAX, M, N, 'No packing', A,
$ LDA, WORK, INFO )
LW = MAX( 1, M*MAX( 1, NB ) )
CALL SGELQF( M, N, A, LDA, TAU, WORK, LW, INFO )
*
* Do first for SIDE = 'L', then for SIDE = 'R'
*
I4 = 0
DO 160 ISIDE = 1, 2
SIDE = SIDES( ISIDE )
*
* Do for each pair of values (NB, NX) in NBVAL and
* NXVAL.
*
DO 150 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
*
* Do for each value of K in KVAL
*
DO 140 IK = 1, NK
K = KVAL( IK )
*
* Sort out which variable is which
*
IF( ISIDE.EQ.1 ) THEN
K1 = M
M1 = N
N1 = K
LW = MAX( 1, N1*MAX( 1, NB ) )
ELSE
K1 = M
N1 = N
M1 = K
LW = MAX( 1, M1*MAX( 1, NB ) )
END IF
*
* Do first for TRANS = 'N', then for TRANS = 'T'
*
ITOFF = 0
DO 130 ITRAN = 1, 2
TRANS = TRANSS( ITRAN )
CALL STIMMG( 0, M1, N1, B, LDA, 0, 0 )
IC = 0
S1 = SECOND( )
110 CONTINUE
CALL SORMLQ( SIDE, TRANS, M1, N1, K1, A, LDA,
$ TAU, B, LDA, WORK, LW, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, M1, N1, B, LDA, 0, 0 )
GO TO 110
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
120 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, M1, N1, B, LDA, 0, 0 )
GO TO 120
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SORMLQ', M1, N1, K1, ISIDE-1,
$ NB )
RESLTS( INB, IM, ILDA,
$ I4+ITOFF+IK ) = SMFLOP( OPS, TIME, INFO )
ITOFF = NK
130 CONTINUE
140 CONTINUE
150 CONTINUE
I4 = 2*NK
160 CONTINUE
170 CONTINUE
180 CONTINUE
*
* Print tables of results
*
ISUB = 3
I4 = 1
IF( IMX.GE.1 ) THEN
DO 220 ISIDE = 1, 2
SIDE = SIDES( ISIDE )
IF( ISIDE.EQ.1 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 190 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
190 CONTINUE
END IF
END IF
DO 210 ITRAN = 1, 2
TRANS = TRANSS( ITRAN )
DO 200 IK = 1, NK
IF( ISIDE.EQ.1 ) THEN
N = KVAL( IK )
WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ), SIDE,
$ TRANS, 'N', N
LABM = 'M'
ELSE
M = KVAL( IK )
WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ), SIDE,
$ TRANS, 'M', M
LABM = 'N'
END IF
CALL SPRTB5( 'NB', 'K', LABM, NNB, NBVAL, IMX,
$ MUSE, NUSE, NLDA,
$ RESLTS( 1, 1, 1, I4 ), LDR1, LDR2,
$ NOUT )
I4 = I4 + 1
200 CONTINUE
210 CONTINUE
220 CONTINUE
ELSE
WRITE( NOUT, FMT = 9994 )SUBNAM( ISUB )
END IF
END IF
230 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
9996 FORMAT( 5X, 'K = min(M,N)', / )
9995 FORMAT( / 5X, A6, ' with SIDE = ''', A1, ''', TRANS = ''', A1,
$ ''', ', A1, ' =', I6, / )
9994 FORMAT( ' *** No pairs (M,N) found with M <= N: ', A6,
$ ' not timed' )
RETURN
*
* End of STIMLQ
*
END
SUBROUTINE STIMLS( LINE, NM, MVAL, NN, NVAL, NNS, NSVAL,
$ NNB, NBVAL, NXVAL, NLDA, LDAVAL, TIMMIN,
$ A, COPYA, B, COPYB, S, COPYS, OPCTBL,
$ TIMTBL, FLPTBL, WORK, IWORK, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* December 22, 1999
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER NLDA, NM, NN, NNB, NNS, NOUT
REAL TIMMIN
* ..
* .. Array Arguments ..
INTEGER IWORK( * ), LDAVAL( * ), MVAL( * ), NBVAL( * ),
$ NSVAL( * ), NVAL( * ), NXVAL( * )
REAL A( * ), B( * ), COPYA( * ), COPYB( * ),
$ COPYS( * ), S( * ), WORK( * )
REAL FLPTBL( 6, 6, NM*NN*NNS*NLDA*(NNB+1), * ),
$ OPCTBL( 6, 6, NM*NN*NNS*NLDA*(NNB+1), * ),
$ TIMTBL( 6, 6, NM*NN*NNS*NLDA*(NNB+1), * )
* ..
* .. Common blocks ..
COMMON / LSTIME / OPCNT, TIMNG
* ..
* .. Arrays in Common ..
REAL OPCNT( 6 ), TIMNG( 6 )
* ..
*
* Purpose
* =======
*
* STIMLS times the least squares driver routines SGELS, SGELSS, SGELSX,
* SGELSY and SGELSD.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) REAL
* The minimum time a subroutine will be timed.
*
* A (workspace) REAL array, dimension (MMAX*NMAX)
* where MMAX is the maximum value of M in MVAL and NMAX is the
* maximum value of N in NVAL.
*
* COPYA (workspace) REAL array, dimension (MMAX*NMAX)
*
* B (workspace) REAL array, dimension (MMAX*NSMAX)
* where MMAX is the maximum value of M in MVAL and NSMAX is the
* maximum value of NRHS in NSVAL.
*
* COPYB (workspace) REAL array, dimension (MMAX*NSMAX)
*
* S (workspace) REAL array, dimension
* (min(MMAX,NMAX))
*
* COPYS (workspace) REAL array, dimension
* (min(MMAX,NMAX))
*
* OPCTBL (workspace) REAL array, dimension
* (6,6,(NNB+1)*NLDA,NM*NN*NNS,5)
*
* TIMTBL (workspace) REAL array, dimension
* (6,6,(NNB+1)*NLDA,NM*NN*NNS,5)
*
* FLPTBL (workspace) REAL array, dimension
* (6,6,(NNB+1)*NLDA,NM*NN*NNS,5)
*
* WORK (workspace) REAL array,
* dimension (MMAX*NMAX + 4*NMAX + MMAX).
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER MTYPE, NSUBS
PARAMETER ( MTYPE = 6, NSUBS = 5 )
INTEGER SMLSIZ
PARAMETER ( SMLSIZ = 25 )
REAL ONE, TWO, ZERO
PARAMETER ( ONE = 1.0E0, TWO = 2.0E0, ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
CHARACTER TRANS
CHARACTER*3 PATH
INTEGER CRANK, I, ILDA, IM, IN, INB, INFO, INS, IRANK,
$ ISCALE, ISUB, ITBL, ITRAN, ITYPE, LDA, LDB,
$ LDWORK, LWLSY, LWORK, M, MNMIN, N, NB,
$ NCLS, NCLSD, NCLSS, NCLSX, NCLSY,
$ NCALL, NCOLS, NLVL, NRHS, NROWS, RANK
REAL EPS, NORMA, NORMB, RCOND, S1, S2, TIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER ISEED( 4 ), ISEEDY( 4 ), NDATA( NSUBS )
* ..
* .. External Functions ..
REAL SECOND, SASUM, SLAMCH, SMFLOP
EXTERNAL SECOND, SASUM, SLAMCH, SMFLOP
* ..
* .. External Subroutines ..
EXTERNAL SGELS, SGELSD, SGELSS, SGELSX, SGELSY,
$ SGEMM, SLACPY, SLARNV, SLASET, SPRTLS,
$ SQRT13, SQRT15, SSCAL, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC LOG, REAL, MAX, MIN, SQRT
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, IOUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, IOUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA SUBNAM / 'SGELS ', 'SGELSX', 'SGELSY',
$ 'SGELSS', 'SGELSD' /
DATA ISEEDY / 1988, 1989, 1990, 1991 /
DATA NDATA / 4, 6, 6, 6, 5 /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'LS'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 230
*
* Initialize constants and the random number seed.
*
NCLS = 0
NCLSD = 0
NCLSS = 0
NCLSX = 0
NCLSY = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
EPS = SLAMCH( 'Epsilon' )
*
* Threshold for rank estimation
*
RCOND = SQRT( EPS ) - ( SQRT( EPS )-EPS ) / 2
*
INFOT = 0
CALL XLAENV( 2, 2 )
CALL XLAENV( 9, SMLSIZ )
*
DO 200 IM = 1, NM
M = MVAL( IM )
*
DO 190 IN = 1, NN
N = NVAL( IN )
MNMIN = MIN( M, N )
*
DO 180 INS = 1, NNS
NRHS = NSVAL( INS )
NLVL = MAX( INT( LOG( MAX( ONE, REAL( MNMIN ) ) /
$ REAL( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1, 0 )
LWORK = MAX( 1, ( M+NRHS )*( N+2 ), ( N+NRHS )*( M+2 ),
$ M*N+4*MNMIN+MAX( M, N ), 12*MNMIN+2*MNMIN*SMLSIZ+
$ 8*MNMIN*NLVL+MNMIN*NRHS+(SMLSIZ+1)**2 )
*
DO 170 ILDA = 1, NLDA
LDA = MAX( 1, LDAVAL( ILDA ) )
LDB = MAX( 1, LDAVAL( ILDA ), M, N )
*
DO 160 IRANK = 1, 2
*
DO 150 ISCALE = 1, 3
*
IF( IRANK.EQ.1 .AND. TIMSUB( 1 ) ) THEN
*
* Time SGELS
*
* Generate a matrix of scaling type ISCALE
*
CALL SQRT13( ISCALE, M, N, COPYA, LDA,
$ NORMA, ISEED )
DO 50 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
CALL XLAENV( 3, NXVAL( INB ) )
*
DO 40 ITRAN = 1, 2
ITYPE = ( ITRAN-1 )*3 + ISCALE
IF( ITRAN.EQ.1 ) THEN
TRANS = 'N'
NROWS = M
NCOLS = N
ELSE
TRANS = 'T'
NROWS = N
NCOLS = M
END IF
LDWORK = MAX( 1, NCOLS )
*
* Set up a consistent rhs
*
IF( NCOLS.GT.0 ) THEN
CALL SLARNV( 2, ISEED, NCOLS*NRHS,
$ WORK )
CALL SSCAL( NCOLS*NRHS,
$ ONE / REAL( NCOLS ),
$ WORK, 1 )
END IF
CALL SGEMM( TRANS, 'No transpose',
$ NROWS, NRHS, NCOLS, ONE,
$ COPYA, LDA, WORK, LDWORK,
$ ZERO, B, LDB )
CALL SLACPY( 'Full', NROWS, NRHS, B,
$ LDB, COPYB, LDB )
*
* Solve LS or overdetermined system
*
NCALL = 0
TIME = ZERO
CALL SLASET( 'Full', NDATA( 1 ), 1,
$ ZERO, ZERO, OPCNT,
$ NDATA( 1 ) )
CALL SLASET( 'Full', NDATA( 1 ), 1,
$ ZERO, ZERO, TIMNG,
$ NDATA( 1 ) )
20 CONTINUE
IF( M.GT.0 .AND. N.GT.0 ) THEN
CALL SLACPY( 'Full', M, N, COPYA, LDA,
$ A, LDA )
CALL SLACPY( 'Full', NROWS, NRHS,
$ COPYB, LDB, B, LDB )
END IF
SRNAMT = 'SGELS '
NCALL = NCALL + 1
S1 = SECOND( )
CALL SGELS( TRANS, M, N, NRHS, A, LDA,
$ B, LDB, WORK, LWORK, INFO )
S2 = SECOND( )
TIME = TIME + ( S2-S1 )
IF( INFO.EQ.0 .AND. TIME.LT.TIMMIN )
$ GO TO 20
TIMNG( 1 ) = TIME
OPCNT( 1 ) = SASUM( NDATA( 1 ), OPCNT,
$ 1 )
CALL SSCAL( NDATA( 1 ), ONE /
$ REAL( NCALL ), OPCNT, 1 )
CALL SSCAL( NDATA( 1 ), ONE /
$ REAL( NCALL ), TIMNG, 1 )
CALL SCOPY( NDATA( 1 ), OPCNT, 1,
$ OPCTBL( 1, ITYPE, NCLS+INB,
$ 1 ), 1 )
CALL SCOPY( NDATA( 1 ), TIMNG, 1,
$ TIMTBL( 1, ITYPE, NCLS+INB,
$ 1 ), 1 )
DO 30 I = 1, NDATA( 1 )
FLPTBL( I, ITYPE, NCLS+INB, 1 ) =
$ SMFLOP( OPCNT( I ), TIMNG( I ),
$ INFO )
30 CONTINUE
40 CONTINUE
50 CONTINUE
*
END IF
*
* Generate a matrix of scaling type ISCALE and
* rank type IRANK.
*
ITYPE = ( IRANK-1 )*3 + ISCALE
CALL SQRT15( ISCALE, IRANK, M, N, NRHS, COPYA,
$ LDA, COPYB, LDB, COPYS, RANK,
$ NORMA, NORMB, ISEED, WORK, LWORK )
*
IF( TIMSUB( 2 ) ) THEN
*
* Time SGELSX
*
* workspace used:
* MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M)
*
LDWORK = MAX( 1, M )
*
* SGELSX: Compute the minimum-norm
* solution X to min( norm( A * X - B ) )
* using a complete orthogonal factorization.
*
NCALL = 0
TIME = ZERO
CALL SLASET( 'Full', NDATA( 2 ), 1, ZERO, ZERO,
$ OPCNT, NDATA( 2 ) )
CALL SLASET( 'Full', NDATA( 2 ), 1, ZERO, ZERO,
$ TIMNG, NDATA( 2 ) )
60 CONTINUE
CALL SLACPY( 'Full', M, N, COPYA, LDA,
$ A, LDA )
CALL SLACPY( 'Full', M, NRHS, COPYB, LDB,
$ B, LDB )
SRNAMT = 'SGELSX'
NCALL = NCALL + 1
S1 = SECOND( )
CALL SGELSX( M, N, NRHS, A, LDA, B, LDB, IWORK,
$ RCOND, CRANK, WORK, INFO )
S2 = SECOND( )
TIME = TIME + ( S2-S1 )
IF( INFO.EQ.0 .AND. TIME.LT.TIMMIN )
$ GO TO 60
TIMNG( 1 ) = TIME
OPCNT( 1 ) = SASUM( NDATA( 2 ), OPCNT, 1 )
CALL SSCAL( NDATA( 2 ), ONE / REAL( NCALL ),
$ OPCNT, 1 )
CALL SSCAL( NDATA( 2 ), ONE / REAL( NCALL ),
$ TIMNG, 1 )
CALL SCOPY( NDATA( 2 ), OPCNT, 1, OPCTBL( 1,
$ ITYPE, NCLSX+1, 2 ), 1 )
CALL SCOPY( NDATA( 2 ), TIMNG, 1, TIMTBL( 1,
$ ITYPE, NCLSX+1, 2 ), 1 )
DO 70 I = 1, NDATA( 2 )
FLPTBL( I, ITYPE, NCLSX+1, 2 ) =
$ SMFLOP( OPCNT( I ), TIMNG( I ), INFO )
70 CONTINUE
*
END IF
*
* Loop for timing different block sizes.
*
DO 140 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
CALL XLAENV( 3, NXVAL( INB ) )
*
IF( TIMSUB( 3 ) ) THEN
*
* Time SGELSY
*
* SGELSY: Compute the minimum-norm solution X
* to min( norm( A * X - B ) ) using the
* rank-revealing orthogonal factorization.
*
* Set LWLSY to the adequate value.
*
LWLSY = MAX( 1, MNMIN+2*N+NB*( N+1 ),
$ 2*MNMIN+NB*NRHS )
*
NCALL = 0
TIME = ZERO
CALL SLASET( 'Full', NDATA( 3 ), 1, ZERO,
$ ZERO, OPCNT, NDATA( 3 ) )
CALL SLASET( 'Full', NDATA( 3 ), 1, ZERO,
$ ZERO, TIMNG, NDATA( 3 ) )
80 CONTINUE
CALL SLACPY( 'Full', M, N, COPYA, LDA,
$ A, LDA )
CALL SLACPY( 'Full', M, NRHS, COPYB, LDB,
$ B, LDB )
SRNAMT = 'SGELSY'
NCALL = NCALL + 1
S1 = SECOND( )
CALL SGELSY( M, N, NRHS, A, LDA, B, LDB,
$ IWORK, RCOND, CRANK, WORK, LWLSY,
$ INFO )
S2 = SECOND( )
TIME = TIME + ( S2-S1 )
IF( INFO.EQ.0 .AND. TIME.LT.TIMMIN )
$ GO TO 80
TIMNG( 1 ) = TIME
OPCNT( 1 ) = SASUM( NDATA( 3 ), OPCNT, 1 )
CALL SSCAL( NDATA( 3 ), ONE / REAL( NCALL ),
$ OPCNT, 1 )
CALL SSCAL( NDATA( 3 ), ONE / REAL( NCALL ),
$ TIMNG, 1 )
CALL SCOPY( NDATA( 3 ), OPCNT, 1, OPCTBL( 1,
$ ITYPE, NCLSY+INB, 3 ), 1 )
CALL SCOPY( NDATA( 3 ), TIMNG, 1, TIMTBL( 1,
$ ITYPE, NCLSY+INB, 3 ), 1 )
DO 90 I = 1, NDATA( 3 )
FLPTBL( I, ITYPE, NCLSY+INB, 3 ) =
$ SMFLOP( OPCNT( I ), TIMNG( I ), INFO )
90 CONTINUE
*
END IF
*
IF( TIMSUB( 4 ) ) THEN
*
* Time SGELSS
*
* SGELSS: Compute the minimum-norm solution X
* to min( norm( A * X - B ) ) using the SVD.
*
NCALL = 0
TIME = ZERO
CALL SLASET( 'Full', NDATA( 4 ), 1, ZERO,
$ ZERO, OPCNT, NDATA( 4 ) )
CALL SLASET( 'Full', NDATA( 4 ), 1, ZERO,
$ ZERO, TIMNG, NDATA( 4 ) )
100 CONTINUE
CALL SLACPY( 'Full', M, N, COPYA, LDA,
$ A, LDA )
CALL SLACPY( 'Full', M, NRHS, COPYB, LDB,
$ B, LDB )
SRNAMT = 'SGELSS'
NCALL = NCALL + 1
S1 = SECOND( )
CALL SGELSS( M, N, NRHS, A, LDA, B, LDB,
$ S, RCOND, CRANK, WORK, LWORK,
$ INFO )
S2 = SECOND( )
TIME = TIME + ( S2-S1 )
IF( INFO.EQ.0 .AND. TIME.LT.TIMMIN )
$ GO TO 100
TIMNG( 1 ) = TIME
OPCNT( 1 ) = SASUM( NDATA( 4 ), OPCNT, 1 )
CALL SSCAL( NDATA( 4 ), ONE / REAL( NCALL ),
$ OPCNT, 1 )
CALL SSCAL( NDATA( 4 ), ONE / REAL( NCALL ),
$ TIMNG, 1 )
CALL SCOPY( NDATA( 4 ), OPCNT, 1, OPCTBL( 1,
$ ITYPE, NCLSS+INB, 4 ), 1 )
CALL SCOPY( NDATA( 4 ), TIMNG, 1, TIMTBL( 1,
$ ITYPE, NCLSS+INB, 4 ), 1 )
DO 110 I = 1, NDATA( 4 )
FLPTBL( I, ITYPE, NCLSS+INB, 4 ) =
$ SMFLOP( OPCNT( I ), TIMNG( I ), INFO )
110 CONTINUE
*
END IF
*
IF( TIMSUB( 5 ) ) THEN
*
* Time SGELSD
*
* SGELSD: Compute the minimum-norm solution X
* to min( norm( A * X - B ) ) using a
* divide-and-conquer SVD.
*
NCALL = 0
TIME = ZERO
CALL SLASET( 'Full', NDATA( 5 ), 1, ZERO,
$ ZERO, OPCNT, NDATA( 5 ) )
CALL SLASET( 'Full', NDATA( 5 ), 1, ZERO,
$ ZERO, TIMNG, NDATA( 5 ) )
120 CONTINUE
CALL SLACPY( 'Full', M, N, COPYA, LDA,
$ A, LDA )
CALL SLACPY( 'Full', M, NRHS, COPYB, LDB,
$ B, LDB )
SRNAMT = 'SGELSD'
NCALL = NCALL + 1
S1 = SECOND( )
CALL SGELSD( M, N, NRHS, A, LDA, B, LDB, S,
$ RCOND, CRANK, WORK, LWORK,
$ IWORK, INFO )
S2 = SECOND( )
TIME = TIME + ( S2-S1 )
IF( INFO.EQ.0 .AND. TIME.LT.TIMMIN )
$ GO TO 120
TIMNG( 1 ) = TIME
OPCNT( 1 ) = SASUM( NDATA( 5 ), OPCNT, 1 )
CALL SSCAL( NDATA( 5 ), ONE / REAL( NCALL ),
$ OPCNT, 1 )
CALL SSCAL( NDATA( 5 ), ONE / REAL( NCALL ),
$ TIMNG, 1 )
CALL SCOPY( NDATA( 5 ), OPCNT, 1, OPCTBL( 1,
$ ITYPE, NCLSD+INB, 5 ), 1 )
CALL SCOPY( NDATA( 5 ), TIMNG, 1, TIMTBL( 1,
$ ITYPE, NCLSD+INB, 5 ), 1 )
DO 130 I = 1, NDATA( 5 )
FLPTBL( I, ITYPE, NCLSD+INB, 5 ) =
$ SMFLOP( OPCNT( I ), TIMNG( I ), INFO )
130 CONTINUE
*
END IF
*
140 CONTINUE
150 CONTINUE
160 CONTINUE
NCLS = NCLS + NNB
NCLSY = NCLSY + NNB
NCLSS = NCLSS + NNB
NCLSD = NCLSD + NNB
170 CONTINUE
NCLSX = NCLSX + 1
180 CONTINUE
190 CONTINUE
200 CONTINUE
*
* Print a summary of the results.
*
DO 220 ISUB = 1, NSUBS
IF( TIMSUB( ISUB ) ) THEN
WRITE( NOUT, FMT = 9999 ) SUBNAM( ISUB )
IF( ISUB.EQ.1 ) THEN
WRITE( NOUT, FMT = 9998 )
ELSE IF( ISUB.EQ.2 ) THEN
WRITE( NOUT, FMT = 9997 )
ELSE IF( ISUB.EQ.3 ) THEN
WRITE( NOUT, FMT = 9996 )
ELSE IF( ISUB.EQ.4 ) THEN
WRITE( NOUT, FMT = 9995 )
ELSE IF( ISUB.EQ.5 ) THEN
WRITE( NOUT, FMT = 9994 )
END IF
DO 210 ITBL = 1, 3
IF( ITBL.EQ.1 ) THEN
WRITE( NOUT, FMT = 9993 )
CALL SPRTLS( ISUB, SUBNAM( ISUB ), NDATA( ISUB ),
$ NM, MVAL, NN, NVAL, NNS, NSVAL, NNB,
$ NBVAL, NXVAL, NLDA, LDAVAL, MTYPE,
$ TIMTBL( 1, 1, 1, ISUB ), NOUT )
ELSE IF( ITBL.EQ.2 ) THEN
WRITE( NOUT, FMT = 9992 )
CALL SPRTLS( ISUB, SUBNAM( ISUB ), NDATA( ISUB ),
$ NM, MVAL, NN, NVAL, NNS, NSVAL, NNB,
$ NBVAL, NXVAL, NLDA, LDAVAL, MTYPE,
$ OPCTBL( 1, 1, 1, ISUB ), NOUT )
ELSE IF( ITBL.EQ.3 ) THEN
WRITE( NOUT, FMT = 9991 )
CALL SPRTLS( ISUB, SUBNAM( ISUB ), NDATA( ISUB ),
$ NM, MVAL, NN, NVAL, NNS, NSVAL, NNB,
$ NBVAL, NXVAL, NLDA, LDAVAL, MTYPE,
$ FLPTBL( 1, 1, 1, ISUB ), NOUT )
END IF
210 CONTINUE
END IF
220 CONTINUE
*
230 CONTINUE
9999 FORMAT( / / / ' ****** Results for ', A, ' ******' )
9998 FORMAT( / ' SGELS : overall performance',
$ / ' comp. 1 : if M>=N, SGEQRF, QR factorization',
$ / ' if M< N, SGELQF, QR factorization',
$ / ' comp. 2 : if M>=N, SORMQR, multiplication by',
$ ' reflectors',
$ / ' if M< N, SORMLQ, multiplication by',
$ ' reflectors',
$ / ' comp. 3 : STRSM, solution of the triangular',
$ ' system' /,
$ / ' Types 4 to 6 are the transpose',
$ ' of types 1 to 3' )
9997 FORMAT( / ' SGELSX : overall performance',
$ / ' comp. 1 : SGEQPF, QR factorization with column',
$ ' pivoting',
$ / ' comp. 2 : if RANK>N, SGEQRF, QR factorization',
$ / ' SORMQR, multiplication by',
$ ' reflectors',
$ / ' if N>>M, SGELQF, QL factorization',
$ / ' comp. 2 : SGEBRD, reduction to bidiagonal form',
$ / ' comp. 3 : SORMBR, multiplication by left',
$ ' bidiagonalizing vectors',
$ / ' SORGBR, generation of right',
$ ' bidiagonalizing vectors',
$ / ' comp. 4 : SBDSQR, singular value decomposition',
$ ' of the bidiagonal matrix',
$ / ' comp. 5 : multiplication by right bidiagonalizing',
$ ' vectors',
$ / ' (SGEMM or SGEMV, and SORMLQ if N>>M)' )
9994 FORMAT( / ' SGELSD: overall performance',
$ / ' comp. 1 : if M>>N, SGEQRF, QR factorization',
$ / ' SORMQR, multiplication by',
$ ' reflectors',
$ / ' if N>>M, SGELQF, QL factorization',
$ / ' comp. 2 : SGEBRD, reduction to bidiagonal form',
$ / ' comp. 3 : SORMBR, multiplication by left ',
$ ' bidiagonalizing vectors',
$ / ' multiplication by right',
$ ' bidiagonalizing vectors',
$ / ' comp. 4 : SLALSD, singular value decomposition',
$ ' of the bidiagonal matrix' )
9993 FORMAT( / / ' *** Time in seconds *** ' )
9992 FORMAT( / / ' *** Number of floating-point operations *** ' )
9991 FORMAT( / / ' *** Speed in megaflops *** ' )
RETURN
*
* End of STIMLS
*
END
SUBROUTINE STIMMG( IFLAG, M, N, A, LDA, KL, KU )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
INTEGER IFLAG, KL, KU, LDA, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * )
* ..
*
* Purpose
* =======
*
* STIMMG generates a real test matrix whose type is given by IFLAG.
* All the matrices are Toeplitz (constant along a diagonal), with
* random elements on each diagonal.
*
* Arguments
* =========
*
* IFLAG (input) INTEGER
* The type of matrix to be generated.
* = 0 or 1: General matrix
* = 2 or -2: General banded matrix
* = 3 or -3: Symmetric positive definite matrix
* = 4 or -4: Symmetric positive definite packed
* = 5 or -5: Symmetric positive definite banded
* = 6 or -6: Symmetric indefinite matrix
* = 7 or -7: Symmetric indefinite packed
* = 8 or -8: Symmetric indefinite banded
* = 9 or -9: Triangular
* = 10 or -10: Triangular packed
* = 11 or -11: Triangular banded
* = 12: General tridiagonal
* = 13 or -13: Positive definite tridiagonal
* For symmetric or triangular matrices, IFLAG > 0 indicates
* upper triangular storage and IFLAG < 0 indicates lower
* triangular storage.
*
* M (input) INTEGER
* The number of rows of the matrix to be generated.
*
* N (input) INTEGER
* The number of columns of the matrix to be generated.
*
* A (output) REAL array, dimension (LDA,N)
* The generated matrix.
*
* If the absolute value of IFLAG is 1, 3, or 6, the leading
* M x N (or N x N) subblock is used to store the matrix.
* If the matrix is symmetric, only the upper or lower triangle
* of this block is referenced.
*
* If the absolute value of IFLAG is 4 or 7, the matrix is
* symmetric and packed storage is used for the upper or lower
* triangle. The triangular matrix is stored columnwise as a
* inear array, and the array A is treated as a vector of
* length LDA. LDA must be set to at least N*(N+1)/2.
*
* If the absolute value of IFLAG is 2 or 5, the matrix is
* returned in band format. The columns of the matrix are
* specified in the columns of A and the diagonals of the
* matrix are specified in the rows of A, with the leading
* diagonal in row
* KL + KU + 1, if IFLAG = 2
* KU + 1, if IFLAG = 5 or -2
* 1, if IFLAG = -5
* If IFLAG = 2, the first KL rows are not used to leave room
* for pivoting in SGBTRF.
*
* LDA (input) INTEGER
* The leading dimension of A. If the generated matrix is
* packed, LDA >= N*(N+1)/2, otherwise LDA >= max(1,M).
*
* KL (input) INTEGER
* The number of subdiagonals if IFLAG = 2, 5, or -5.
*
* KU (input) INTEGER
* The number of superdiagonals if IFLAG = 2, 5, or -5.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J, JJ, JN, K, MJ, MU
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 )
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN, REAL, SIGN
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLARNV
* ..
* .. Data statements ..
DATA ISEED / 0, 0, 0, 1 /
* ..
* .. Executable Statements ..
*
IF( M.LE.0 .OR. N.LE.0 ) THEN
RETURN
*
ELSE IF( IFLAG.EQ.0 .OR. IFLAG.EQ.1 ) THEN
*
* General matrix
*
* Set first column and row to random values.
*
CALL SLARNV( 2, ISEED, M, A( 1, 1 ) )
DO 10 J = 2, N, M
MJ = MIN( M, N-J+1 )
CALL SLARNV( 2, ISEED, MJ, A( 1, J ) )
IF( MJ.GT.1 )
$ CALL SCOPY( MJ-1, A( 2, J ), 1, A( 1, J+1 ), LDA )
10 CONTINUE
*
* Fill in the rest of the matrix.
*
DO 30 J = 2, N
DO 20 I = 2, M
A( I, J ) = A( I-1, J-1 )
20 CONTINUE
30 CONTINUE
*
ELSE IF( IFLAG.EQ.2 .OR. IFLAG.EQ.-2 ) THEN
*
* General band matrix
*
IF( IFLAG.EQ.2 ) THEN
K = KL + KU + 1
ELSE
K = KU + 1
END IF
CALL SLARNV( 2, ISEED, MIN( M, KL+1 ), A( K, 1 ) )
MU = MIN( N-1, KU )
CALL SLARNV( 2, ISEED, MU+1, A( K-MU, N ) )
DO 40 J = 2, N - 1
MU = MIN( J-1, KU )
CALL SCOPY( MU, A( K-MU, N ), 1, A( K-MU, J ), 1 )
CALL SCOPY( MIN( M-J+1, KL+1 ), A( K, 1 ), 1, A( K, J ), 1 )
40 CONTINUE
*
ELSE IF( IFLAG.EQ.3 ) THEN
*
* Symmetric positive definite, upper triangle
*
CALL SLARNV( 2, ISEED, N-1, A( 1, N ) )
A( N, N ) = REAL( N )
DO 50 J = N - 1, 1, -1
CALL SCOPY( J, A( N-J+1, N ), 1, A( 1, J ), 1 )
50 CONTINUE
*
ELSE IF( IFLAG.EQ.-3 ) THEN
*
* Symmetric positive definite, lower triangle
*
A( 1, 1 ) = REAL( N )
IF( N.GT.1 )
$ CALL SLARNV( 2, ISEED, N-1, A( 2, 1 ) )
DO 60 J = 2, N
CALL SCOPY( N-J+1, A( 1, 1 ), 1, A( J, J ), 1 )
60 CONTINUE
*
ELSE IF( IFLAG.EQ.4 ) THEN
*
* Symmetric positive definite packed, upper triangle
*
JN = ( N-1 )*N / 2 + 1
CALL SLARNV( 2, ISEED, N-1, A( JN, 1 ) )
A( JN+N-1, 1 ) = REAL( N )
JJ = JN
DO 70 J = N - 1, 1, -1
JJ = JJ - J
JN = JN + 1
CALL SCOPY( J, A( JN, 1 ), 1, A( JJ, 1 ), 1 )
70 CONTINUE
*
ELSE IF( IFLAG.EQ.-4 ) THEN
*
* Symmetric positive definite packed, lower triangle
*
A( 1, 1 ) = REAL( N )
IF( N.GT.1 )
$ CALL SLARNV( 2, ISEED, N-1, A( 2, 1 ) )
JJ = N + 1
DO 80 J = 2, N
CALL SCOPY( N-J+1, A( 1, 1 ), 1, A( JJ, 1 ), 1 )
JJ = JJ + N - J + 1
80 CONTINUE
*
ELSE IF( IFLAG.EQ.5 ) THEN
*
* Symmetric positive definite banded, upper triangle
*
K = KL
MU = MIN( N-1, K )
CALL SLARNV( 2, ISEED, MU, A( K+1-MU, N ) )
A( K+1, N ) = REAL( N )
DO 90 J = N - 1, 1, -1
MU = MIN( J, K+1 )
CALL SCOPY( MU, A( K+2-MU, N ), 1, A( K+2-MU, J ), 1 )
90 CONTINUE
*
ELSE IF( IFLAG.EQ.-5 ) THEN
*
* Symmetric positive definite banded, lower triangle
*
K = KL
A( 1, 1 ) = REAL( N )
CALL SLARNV( 2, ISEED, MIN( N-1, K ), A( 2, 1 ) )
DO 100 J = 2, N
CALL SCOPY( MIN( N-J+1, K+1 ), A( 1, 1 ), 1, A( 1, J ), 1 )
100 CONTINUE
*
ELSE IF( IFLAG.EQ.6 ) THEN
*
* Symmetric indefinite, upper triangle
*
CALL SLARNV( 2, ISEED, N, A( 1, N ) )
DO 110 J = N - 1, 1, -1
CALL SCOPY( J, A( N-J+1, N ), 1, A( 1, J ), 1 )
110 CONTINUE
*
ELSE IF( IFLAG.EQ.-6 ) THEN
*
* Symmetric indefinite, lower triangle
*
CALL SLARNV( 2, ISEED, N, A( 1, 1 ) )
DO 120 J = 2, N
CALL SCOPY( N-J+1, A( 1, 1 ), 1, A( J, J ), 1 )
120 CONTINUE
*
ELSE IF( IFLAG.EQ.7 ) THEN
*
* Symmetric indefinite packed, upper triangle
*
JN = ( N-1 )*N / 2 + 1
CALL SLARNV( 2, ISEED, N, A( JN, 1 ) )
JJ = JN
DO 130 J = N - 1, 1, -1
JJ = JJ - J
JN = JN + 1
CALL SCOPY( J, A( JN, 1 ), 1, A( JJ, 1 ), 1 )
130 CONTINUE
*
ELSE IF( IFLAG.EQ.-7 ) THEN
*
* Symmetric indefinite packed, lower triangle
*
CALL SLARNV( 2, ISEED, N, A( 1, 1 ) )
JJ = N + 1
DO 140 J = 2, N
CALL SCOPY( N-J+1, A( 1, 1 ), 1, A( JJ, 1 ), 1 )
JJ = JJ + N - J + 1
140 CONTINUE
*
ELSE IF( IFLAG.EQ.8 ) THEN
*
* Symmetric indefinite banded, upper triangle
*
K = KL
MU = MIN( N, K+1 )
CALL SLARNV( 2, ISEED, MU, A( K+2-MU, N ) )
DO 150 J = N - 1, 1, -1
MU = MIN( J, K+1 )
CALL SCOPY( MU, A( K+2-MU, N ), 1, A( K+2-MU, J ), 1 )
150 CONTINUE
*
ELSE IF( IFLAG.EQ.-8 ) THEN
*
* Symmetric indefinite banded, lower triangle
*
K = KL
CALL SLARNV( 2, ISEED, MIN( N, K+1 ), A( 1, 1 ) )
DO 160 J = 2, N
CALL SCOPY( MIN( N-J+1, K+1 ), A( 1, 1 ), 1, A( 1, J ), 1 )
160 CONTINUE
*
ELSE IF( IFLAG.EQ.9 ) THEN
*
* Upper triangular
*
CALL SLARNV( 2, ISEED, N, A( 1, N ) )
A( N, N ) = SIGN( REAL( N ), A( N, N ) )
DO 170 J = N - 1, 1, -1
CALL SCOPY( J, A( N-J+1, N ), 1, A( 1, J ), 1 )
170 CONTINUE
*
ELSE IF( IFLAG.EQ.-9 ) THEN
*
* Lower triangular
*
CALL SLARNV( 2, ISEED, N, A( 1, 1 ) )
A( 1, 1 ) = SIGN( REAL( N ), A( 1, 1 ) )
DO 180 J = 2, N
CALL SCOPY( N-J+1, A( 1, 1 ), 1, A( J, J ), 1 )
180 CONTINUE
*
ELSE IF( IFLAG.EQ.10 ) THEN
*
* Upper triangular packed
*
JN = ( N-1 )*N / 2 + 1
CALL SLARNV( 2, ISEED, N, A( JN, 1 ) )
A( JN+N-1, 1 ) = SIGN( REAL( N ), A( JN+N-1, 1 ) )
JJ = JN
DO 190 J = N - 1, 1, -1
JJ = JJ - J
JN = JN + 1
CALL SCOPY( J, A( JN, 1 ), 1, A( JJ, 1 ), 1 )
190 CONTINUE
*
ELSE IF( IFLAG.EQ.-10 ) THEN
*
* Lower triangular packed
*
CALL SLARNV( 2, ISEED, N, A( 1, 1 ) )
A( 1, 1 ) = SIGN( REAL( N ), A( 1, 1 ) )
JJ = N + 1
DO 200 J = 2, N
CALL SCOPY( N-J+1, A( 1, 1 ), 1, A( JJ, 1 ), 1 )
JJ = JJ + N - J + 1
200 CONTINUE
*
ELSE IF( IFLAG.EQ.11 ) THEN
*
* Upper triangular banded
*
K = KL
MU = MIN( N, K+1 )
CALL SLARNV( 2, ISEED, MU, A( K+2-MU, N ) )
A( K+1, N ) = SIGN( REAL( K+1 ), A( K+1, N ) )
DO 210 J = N - 1, 1, -1
MU = MIN( J, K+1 )
CALL SCOPY( MU, A( K+2-MU, N ), 1, A( K+2-MU, J ), 1 )
210 CONTINUE
*
ELSE IF( IFLAG.EQ.-11 ) THEN
*
* Lower triangular banded
*
K = KL
CALL SLARNV( 2, ISEED, MIN( N, K+1 ), A( 1, 1 ) )
A( 1, 1 ) = SIGN( REAL( K+1 ), A( 1, 1 ) )
DO 220 J = 2, N
CALL SCOPY( MIN( N-J+1, K+1 ), A( 1, 1 ), 1, A( 1, J ), 1 )
220 CONTINUE
*
ELSE IF( IFLAG.EQ.12 ) THEN
*
* General tridiagonal
*
CALL SLARNV( 2, ISEED, 3*N-2, A )
*
ELSE IF( IFLAG.EQ.13 .OR. IFLAG.EQ.-13 ) THEN
*
* Positive definite tridiagonal
*
DO 230 J = 1, N
A( J, 1 ) = 2.0
230 CONTINUE
CALL SLARNV( 2, ISEED, N-1, A( N+1, 1 ) )
END IF
*
RETURN
*
* End of STIMMG
*
END
SUBROUTINE STIMMM( VNAME, LAB2, NN, NVAL, NLDA, LDAVAL, TIMMIN, A,
$ B, C, RESLTS, LDR1, LDR2, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*( * ) LAB2, VNAME
INTEGER LDR1, LDR2, NLDA, NN, NOUT
REAL TIMMIN
* ..
* .. Array Arguments ..
INTEGER LDAVAL( * ), NVAL( * )
REAL A( * ), B( * ), C( * ), RESLTS( LDR1, LDR2, * )
* ..
*
* Purpose
* =======
*
* STIMMM times SGEMM.
*
* Arguments
* =========
*
* VNAME (input) CHARACTER*(*)
* The name of the Level 3 BLAS routine to be timed.
*
* LAB2 (input) CHARACTER*(*)
* The name of the variable given in NVAL.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) REAL
* The minimum time a subroutine will be timed.
*
* A (workspace) REAL array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values permitted
* for LDA and N.
*
* B (workspace) REAL array, dimension (LDAMAX*NMAX)
*
* C (workspace) REAL array, dimension (LDAMAX*NMAX)
*
* RESLTS (output) REAL array, dimension (LDR1,LDR2,NLDA)
* The timing results for each subroutine over the relevant
* values of N and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= 1.
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NN).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
REAL ONE
PARAMETER ( NSUBS = 1, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
CHARACTER*6 CNAME
INTEGER I, IC, ICL, ILDA, IN, INFO, ISUB, LDA, N
REAL OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER IDUMMY( 1 )
* ..
* .. External Functions ..
LOGICAL LSAMEN
REAL SECOND, SMFLOP, SOPBL3
EXTERNAL LSAMEN, SECOND, SMFLOP, SOPBL3
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, SGEMM, SPRTBL, STIMMG
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. Data statements ..
DATA SUBNAM / 'SGEMM ' /
* ..
* .. Executable Statements ..
*
CNAME = VNAME
DO 10 ISUB = 1, NSUBS
TIMSUB( ISUB ) = LSAMEN( 6, CNAME, SUBNAM( ISUB ) )
IF( TIMSUB( ISUB ) )
$ GO TO 20
10 CONTINUE
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 80
20 CONTINUE
*
* Check that N <= LDA for the input values.
*
CALL ATIMCK( 2, CNAME, NN, NVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9998 )CNAME
GO TO 80
END IF
*
DO 60 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 50 IN = 1, NN
N = NVAL( IN )
*
* Time SGEMM
*
CALL STIMMG( 1, N, N, A, LDA, 0, 0 )
CALL STIMMG( 0, N, N, B, LDA, 0, 0 )
CALL STIMMG( 1, N, N, C, LDA, 0, 0 )
IC = 0
S1 = SECOND( )
30 CONTINUE
CALL SGEMM( 'No transpose', 'No transpose', N, N, N, ONE, A,
$ LDA, B, LDA, ONE, C, LDA )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 1, N, N, C, LDA, 0, 0 )
GO TO 30
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
40 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 1, N, N, C, LDA, 0, 0 )
GO TO 40
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPBL3( 'SGEMM ', N, N, N )
RESLTS( 1, IN, ILDA ) = SMFLOP( OPS, TIME, 0 )
50 CONTINUE
60 CONTINUE
*
* Print the table of results on unit NOUT.
*
WRITE( NOUT, FMT = 9997 )VNAME
IF( NLDA.EQ.1 ) THEN
WRITE( NOUT, FMT = 9996 )LDAVAL( 1 )
ELSE
DO 70 I = 1, NLDA
WRITE( NOUT, FMT = 9995 )I, LDAVAL( I )
70 CONTINUE
END IF
WRITE( NOUT, FMT = * )
CALL SPRTBL( ' ', LAB2, 1, IDUMMY, NN, NVAL, NLDA, RESLTS, LDR1,
$ LDR2, NOUT )
*
80 CONTINUE
RETURN
9999 FORMAT( 1X, A6, ': Unrecognized path or subroutine name', / )
9998 FORMAT( 1X, A6, ' timing run not attempted', / )
9997 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9996 FORMAT( 5X, 'with LDA = ', I5 )
9995 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
*
* End of STIMMM
*
END
SUBROUTINE STIMMV( VNAME, NN, NVAL, NK, KVAL, NLDA, LDAVAL,
$ TIMMIN, A, LB, B, C, RESLTS, LDR1, LDR2, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*( * ) VNAME
INTEGER LB, LDR1, LDR2, NK, NLDA, NN, NOUT
REAL TIMMIN
* ..
* .. Array Arguments ..
INTEGER KVAL( * ), LDAVAL( * ), NVAL( * )
REAL A( * ), B( * ), C( * ), RESLTS( LDR1, LDR2, * )
* ..
*
* Purpose
* =======
*
* STIMMV times individual BLAS 2 routines.
*
* Arguments
* =========
*
* VNAME (input) CHARACTER*(*)
* The name of the Level 2 BLAS routine to be timed.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* NK (input) INTEGER
* The number of values of K contained in the vector KVAL.
*
* KVAL (input) INTEGER array, dimension (NK)
* The values of the bandwidth K.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) REAL
* The minimum time a subroutine will be timed.
*
* A (workspace) REAL array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values permitted
* for LDA and N.
*
* LB (input) INTEGER
* The length of B and C, needed when timing SGBMV. If timing
* SGEMV, LB >= LDAMAX*NMAX.
*
* B (workspace) REAL array, dimension (LB)
*
* C (workspace) REAL array, dimension (LB)
*
* RESLTS (output) REAL array, dimension (LDR1,LDR2,NLDA)
* The timing results for each subroutine over the relevant
* values of N and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NK).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NN).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
REAL ONE
PARAMETER ( NSUBS = 2, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
CHARACTER LAB1, LAB2
CHARACTER*6 CNAME
INTEGER I, IB, IC, ICL, IK, ILDA, IN, INFO, ISUB, K,
$ KL, KU, LDA, LDB, N, NRHS
REAL OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER*6 SUBNAM( NSUBS )
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
REAL SECOND, SMFLOP, SOPBL2
EXTERNAL LSAME, LSAMEN, SECOND, SMFLOP, SOPBL2
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, SGBMV, SGEMV, SPRTBL, STIMMG
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Data statements ..
DATA SUBNAM / 'SGEMV ', 'SGBMV ' /
* ..
* .. Executable Statements ..
*
CNAME = VNAME
DO 10 ISUB = 1, NSUBS
TIMSUB( ISUB ) = LSAMEN( 6, CNAME, SUBNAM( ISUB ) )
IF( TIMSUB( ISUB ) )
$ GO TO 20
10 CONTINUE
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 150
20 CONTINUE
*
* Check that N or K <= LDA for the input values.
*
IF( LSAME( CNAME( 3: 3 ), 'B' ) ) THEN
CALL ATIMCK( 0, CNAME, NK, KVAL, NLDA, LDAVAL, NOUT, INFO )
LAB1 = 'M'
LAB2 = 'K'
ELSE
CALL ATIMCK( 2, CNAME, NN, NVAL, NLDA, LDAVAL, NOUT, INFO )
LAB1 = ' '
LAB2 = 'N'
END IF
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9998 )CNAME
GO TO 150
END IF
*
* Print the table header on unit NOUT.
*
WRITE( NOUT, FMT = 9997 )VNAME
IF( NLDA.EQ.1 ) THEN
WRITE( NOUT, FMT = 9996 )LDAVAL( 1 )
ELSE
DO 30 I = 1, NLDA
WRITE( NOUT, FMT = 9995 )I, LDAVAL( I )
30 CONTINUE
END IF
WRITE( NOUT, FMT = * )
*
* Time SGEMV
*
IF( TIMSUB( 1 ) ) THEN
DO 80 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 70 IN = 1, NN
N = NVAL( IN )
NRHS = N
LDB = LDA
CALL STIMMG( 1, N, N, A, LDA, 0, 0 )
CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 )
CALL STIMMG( 1, N, NRHS, C, LDB, 0, 0 )
IC = 0
S1 = SECOND( )
40 CONTINUE
IB = 1
DO 50 I = 1, NRHS
CALL SGEMV( 'No transpose', N, N, ONE, A, LDA,
$ B( IB ), 1, ONE, C( IB ), 1 )
IB = IB + LDB
50 CONTINUE
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 1, N, NRHS, C, LDB, 0, 0 )
GO TO 40
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
60 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 1, N, NRHS, C, LDB, 0, 0 )
GO TO 60
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = NRHS*SOPBL2( 'SGEMV ', N, N, 0, 0 )
RESLTS( 1, IN, ILDA ) = SMFLOP( OPS, TIME, 0 )
70 CONTINUE
80 CONTINUE
*
CALL SPRTBL( LAB1, LAB2, 1, NVAL, NN, NVAL, NLDA, RESLTS, LDR1,
$ LDR2, NOUT )
*
ELSE IF( TIMSUB( 2 ) ) THEN
*
* Time SGBMV
*
DO 140 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 130 IN = 1, NN
N = NVAL( IN )
DO 120 IK = 1, NK
K = MIN( N-1, MAX( 0, KVAL( IK ) ) )
KL = K
KU = K
LDB = N
CALL STIMMG( 2, N, N, A, LDA, KL, KU )
NRHS = MIN( K, LB / LDB )
CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 )
CALL STIMMG( 1, N, NRHS, C, LDB, 0, 0 )
IC = 0
S1 = SECOND( )
90 CONTINUE
IB = 1
DO 100 I = 1, NRHS
CALL SGBMV( 'No transpose', N, N, KL, KU, ONE,
$ A( KU+1 ), LDA, B( IB ), 1, ONE,
$ C( IB ), 1 )
IB = IB + LDB
100 CONTINUE
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 1, N, NRHS, C, LDB, 0, 0 )
GO TO 90
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
110 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 1, N, NRHS, C, LDB, 0, 0 )
GO TO 110
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = NRHS*SOPBL2( 'SGBMV ', N, N, KL, KU )
RESLTS( IN, IK, ILDA ) = SMFLOP( OPS, TIME, 0 )
120 CONTINUE
130 CONTINUE
140 CONTINUE
*
CALL SPRTBL( LAB1, LAB2, NN, NVAL, NK, KVAL, NLDA, RESLTS,
$ LDR1, LDR2, NOUT )
END IF
*
150 CONTINUE
9999 FORMAT( 1X, A6, ': Unrecognized path or subroutine name', / )
9998 FORMAT( 1X, A6, ' timing run not attempted', / )
9997 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9996 FORMAT( 5X, 'with LDA = ', I5 )
9995 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
RETURN
*
* End of STIMMV
*
END
SUBROUTINE STIMPB( LINE, NN, NVAL, NK, KVAL, NNS, NSVAL, NNB,
$ NBVAL, NLDA, LDAVAL, TIMMIN, A, B, IWORK,
$ RESLTS, LDR1, LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NK, NLDA, NN, NNB, NNS, NOUT
REAL TIMMIN
* ..
* .. Array Arguments ..
INTEGER IWORK( * ), KVAL( * ), LDAVAL( * ), NBVAL( * ),
$ NSVAL( * ), NVAL( * )
REAL A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * )
* ..
*
* Purpose
* =======
*
* STIMPB times SPBTRF and -TRS.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix size N.
*
* NK (input) INTEGER
* The number of values of K contained in the vector KVAL.
*
* KVAL (input) INTEGER array, dimension (NK)
* The values of the band width K.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* NNB (input) INTEGER
* The number of values of NB contained in the vector NBVAL.
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) REAL
* The minimum time a subroutine will be timed.
*
* A (workspace) REAL array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values permitted
* for LDA and N.
*
* B (workspace) REAL array, dimension (LDAMAX*NMAX)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* RESLTS (output) REAL array, dimension
* (LDR1,LDR2,LDR3,NSUBS)
* The timing results for each subroutine over the relevant
* values of N, K, NB, and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(4,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NK).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,2*NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 2 )
* ..
* .. Local Scalars ..
CHARACTER UPLO
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, I3, IC, ICL, IK, ILDA, IN, INB, INFO, ISUB,
$ IUPLO, K, LDA, LDB, MAT, N, NB, NRHS
REAL OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER UPLOS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SECOND, SMFLOP, SOPLA
EXTERNAL LSAME, SECOND, SMFLOP, SOPLA
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, SPBTRF, SPBTRS, SPRTBL, STIMMG,
$ XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Data statements ..
DATA UPLOS / 'U', 'L' /
DATA SUBNAM / 'SPBTRF', 'SPBTRS' /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'PB'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 140
*
* Check that K+1 <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 0, CNAME, NK, KVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 140
END IF
*
* Do for each value of the matrix size N:
*
DO 130 IN = 1, NN
N = NVAL( IN )
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 90 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
IF( LSAME( UPLO, 'U' ) ) THEN
MAT = 5
ELSE
MAT = -5
END IF
*
* Do for each value of LDA:
*
DO 80 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
I3 = ( IUPLO-1 )*NLDA + ILDA
*
* Do for each value of the band width K:
*
DO 70 IK = 1, NK
K = KVAL( IK )
K = MAX( 0, MIN( K, N-1 ) )
*
* Time SPBTRF
*
IF( TIMSUB( 1 ) ) THEN
*
* Do for each value of NB in NBVAL. Only SPBTRF is
* timed in this loop since the other routines are
* independent of NB.
*
DO 30 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
CALL STIMMG( MAT, N, N, A, LDA, K, K )
IC = 0
S1 = SECOND( )
10 CONTINUE
CALL SPBTRF( UPLO, N, K, A, LDA, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( MAT, N, N, A, LDA, K, K )
GO TO 10
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
20 CONTINUE
CALL STIMMG( MAT, N, N, A, LDA, K, K )
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC )
$ GO TO 20
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SPBTRF', N, N, K, K, NB )
RESLTS( INB, IK, I3, 1 ) = SMFLOP( OPS, TIME,
$ INFO )
30 CONTINUE
ELSE
IC = 0
CALL STIMMG( MAT, N, N, A, LDA, K, K )
END IF
*
* Generate another matrix and factor it using SPBTRF so
* that the factored form can be used in timing the other
* routines.
*
NB = 1
CALL XLAENV( 1, NB )
IF( IC.NE.1 )
$ CALL SPBTRF( UPLO, N, K, A, LDA, INFO )
*
* Time SPBTRS
*
IF( TIMSUB( 2 ) ) THEN
DO 60 I = 1, NNS
NRHS = NSVAL( I )
LDB = N
CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 )
IC = 0
S1 = SECOND( )
40 CONTINUE
CALL SPBTRS( UPLO, N, K, NRHS, A, LDA, B, LDB,
$ INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 40
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
50 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 50
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SPBTRS', N, NRHS, K, K, 0 )
RESLTS( I, IK, I3, 2 ) = SMFLOP( OPS, TIME,
$ INFO )
60 CONTINUE
END IF
70 CONTINUE
80 CONTINUE
90 CONTINUE
*
* Print tables of results for each timed routine.
*
DO 120 ISUB = 1, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 120
*
* Print header for routine names.
*
IF( IN.EQ.1 .OR. CNAME.EQ.'SPB ' ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 100 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
100 CONTINUE
END IF
END IF
WRITE( NOUT, FMT = * )
DO 110 IUPLO = 1, 2
WRITE( NOUT, FMT = 9996 )SUBNAM( ISUB ), N,
$ UPLOS( IUPLO )
I3 = ( IUPLO-1 )*NLDA + 1
IF( ISUB.EQ.1 ) THEN
CALL SPRTBL( 'NB', 'K', NNB, NBVAL, NK, KVAL, NLDA,
$ RESLTS( 1, 1, I3, 1 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.2 ) THEN
CALL SPRTBL( 'NRHS', 'K', NNS, NSVAL, NK, KVAL, NLDA,
$ RESLTS( 1, 1, I3, 2 ), LDR1, LDR2, NOUT )
END IF
110 CONTINUE
120 CONTINUE
130 CONTINUE
*
140 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
9996 FORMAT( 5X, A6, ' with M =', I6, ', UPLO = ''', A1, '''', / )
RETURN
*
* End of STIMPB
*
END
SUBROUTINE STIMPO( LINE, NN, NVAL, NNS, NSVAL, NNB, NBVAL, NLDA,
$ LDAVAL, TIMMIN, A, B, IWORK, RESLTS, LDR1,
$ LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NLDA, NN, NNB, NNS, NOUT
REAL TIMMIN
* ..
* .. Array Arguments ..
INTEGER IWORK( * ), LDAVAL( * ), NBVAL( * ),
$ NSVAL( * ), NVAL( * )
REAL A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * )
* ..
*
* Purpose
* =======
*
* STIMPO times SPOTRF, -TRS, and -TRI.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix size N.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* NNB (input) INTEGER
* The number of values of NB contained in the vector NBVAL.
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) REAL
* The minimum time a subroutine will be timed.
*
* A (workspace) REAL array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values permitted
* for LDA and N.
*
* B (workspace) REAL array, dimension (LDAMAX*NMAX)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* RESLTS (output) REAL array, dimension
* (LDR1,LDR2,LDR3,NSUBS)
* The timing results for each subroutine over the relevant
* values of N, NB, and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(4,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NN).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,2*NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 3 )
* ..
* .. Local Scalars ..
CHARACTER UPLO
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, I3, IC, ICL, ILDA, IN, INB, INFO, ISUB,
$ IUPLO, LDA, LDB, MAT, N, NB, NRHS
REAL OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER UPLOS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SECOND, SMFLOP, SOPLA
EXTERNAL LSAME, SECOND, SMFLOP, SOPLA
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, SLACPY, SPOTRF, SPOTRI, SPOTRS,
$ SPRTBL, STIMMG, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. Data statements ..
DATA UPLOS / 'U', 'L' /
DATA SUBNAM / 'SPOTRF', 'SPOTRS', 'SPOTRI' /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'PO'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 150
*
* Check that N <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 2, CNAME, NN, NVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 150
END IF
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 110 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
IF( LSAME( UPLO, 'U' ) ) THEN
MAT = 3
ELSE
MAT = -3
END IF
*
* Do for each value of N in NVAL.
*
DO 100 IN = 1, NN
N = NVAL( IN )
*
* Do for each value of LDA:
*
DO 90 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
I3 = ( IUPLO-1 )*NLDA + ILDA
*
* Do for each value of NB in NBVAL. Only the blocked
* routines are timed in this loop since the other routines
* are independent of NB.
*
DO 50 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
*
* Time SPOTRF
*
IF( TIMSUB( 1 ) ) THEN
CALL STIMMG( MAT, N, N, A, LDA, 0, 0 )
IC = 0
S1 = SECOND( )
10 CONTINUE
CALL SPOTRF( UPLO, N, A, LDA, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( MAT, N, N, A, LDA, 0, 0 )
GO TO 10
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
20 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( MAT, N, N, A, LDA, 0, 0 )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SPOTRF', N, N, 0, 0, NB )
RESLTS( INB, IN, I3, 1 ) = SMFLOP( OPS, TIME,
$ INFO )
*
ELSE
IC = 0
CALL STIMMG( MAT, N, N, A, LDA, 0, 0 )
END IF
*
* Generate another matrix and factor it using SPOTRF so
* that the factored form can be used in timing the other
* routines.
*
IF( IC.NE.1 )
$ CALL SPOTRF( UPLO, N, A, LDA, INFO )
*
* Time SPOTRI
*
IF( TIMSUB( 3 ) ) THEN
CALL SLACPY( UPLO, N, N, A, LDA, B, LDA )
IC = 0
S1 = SECOND( )
30 CONTINUE
CALL SPOTRI( UPLO, N, B, LDA, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL SLACPY( UPLO, N, N, A, LDA, B, LDA )
GO TO 30
END IF
*
* Subtract the time used in SLACPY.
*
ICL = 1
S1 = SECOND( )
40 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL SLACPY( UPLO, N, N, A, LDA, B, LDA )
GO TO 40
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SPOTRI', N, N, 0, 0, NB )
RESLTS( INB, IN, I3, 3 ) = SMFLOP( OPS, TIME,
$ INFO )
END IF
50 CONTINUE
*
* Time SPOTRS
*
IF( TIMSUB( 2 ) ) THEN
DO 80 I = 1, NNS
NRHS = NSVAL( I )
LDB = LDA
CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 )
IC = 0
S1 = SECOND( )
60 CONTINUE
CALL SPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 60
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
70 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 70
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SPOTRS', N, NRHS, 0, 0, 0 )
RESLTS( I, IN, I3, 2 ) = SMFLOP( OPS, TIME, INFO )
80 CONTINUE
END IF
90 CONTINUE
100 CONTINUE
110 CONTINUE
*
* Print tables of results for each timed routine.
*
DO 140 ISUB = 1, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 140
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 120 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
120 CONTINUE
END IF
WRITE( NOUT, FMT = * )
DO 130 IUPLO = 1, 2
WRITE( NOUT, FMT = 9996 )SUBNAM( ISUB ), UPLOS( IUPLO )
I3 = ( IUPLO-1 )*NLDA + 1
IF( ISUB.EQ.1 ) THEN
CALL SPRTBL( 'NB', 'N', NNB, NBVAL, NN, NVAL, NLDA,
$ RESLTS( 1, 1, I3, 1 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.2 ) THEN
CALL SPRTBL( 'NRHS', 'N', NNS, NSVAL, NN, NVAL, NLDA,
$ RESLTS( 1, 1, I3, 2 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.3 ) THEN
CALL SPRTBL( 'NB', 'N', NNB, NBVAL, NN, NVAL, NLDA,
$ RESLTS( 1, 1, I3, 3 ), LDR1, LDR2, NOUT )
END IF
130 CONTINUE
140 CONTINUE
*
150 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
9996 FORMAT( 5X, A6, ' with UPLO = ''', A1, '''', / )
RETURN
*
* End of STIMPO
*
END
SUBROUTINE STIMPP( LINE, NN, NVAL, NNS, NSVAL, LA, TIMMIN, A, B,
$ IWORK, RESLTS, LDR1, LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LA, LDR1, LDR2, LDR3, NN, NNS, NOUT
REAL TIMMIN
* ..
* .. Array Arguments ..
INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
REAL A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * )
* ..
*
* Purpose
* =======
*
* STIMPP times SPPTRF, -TRS, and -TRI.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix size N.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* LA (input) INTEGER
* The size of the arrays A, B, and C.
*
* TIMMIN (input) REAL
* The minimum time a subroutine will be timed.
*
* A (workspace) REAL array, dimension (LA)
*
* B (workspace) REAL array, dimension (LA)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
* where NMAX is the maximum value of N permitted.
*
* RESLTS (output) REAL array, dimension
* (LDR1,LDR2,LDR3,NSUBS)
* The timing results for each subroutine over the relevant
* values of N.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(4,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NN).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= 2.
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 3 )
* ..
* .. Local Scalars ..
CHARACTER UPLO
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, IC, ICL, IN, INFO, ISUB, IUPLO, LDA, LDB,
$ MAT, N, NRHS
REAL OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER UPLOS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER LAVAL( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SECOND, SMFLOP, SOPLA
EXTERNAL LSAME, SECOND, SMFLOP, SOPLA
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, SCOPY, SPPTRF, SPPTRI, SPPTRS,
$ SPRTBL, STIMMG
* ..
* .. Intrinsic Functions ..
INTRINSIC MOD, REAL
* ..
* .. Data statements ..
DATA UPLOS / 'U', 'L' /
DATA SUBNAM / 'SPPTRF', 'SPPTRS', 'SPPTRI' /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'PP'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 120
*
* Check that N*(N+1)/2 <= LA for the input values.
*
CNAME = LINE( 1: 6 )
LAVAL( 1 ) = LA
CALL ATIMCK( 4, CNAME, NN, NVAL, 1, LAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 120
END IF
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 90 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
IF( LSAME( UPLO, 'U' ) ) THEN
MAT = 4
ELSE
MAT = -4
END IF
*
* Do for each value of N in NVAL.
*
DO 80 IN = 1, NN
N = NVAL( IN )
LDA = N*( N+1 ) / 2
*
* Time SPPTRF
*
IF( TIMSUB( 1 ) ) THEN
CALL STIMMG( MAT, N, N, A, LDA, 0, 0 )
IC = 0
S1 = SECOND( )
10 CONTINUE
CALL SPPTRF( UPLO, N, A, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( MAT, N, N, A, LDA, 0, 0 )
GO TO 10
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
20 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( MAT, N, N, A, LDA, 0, 0 )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SPPTRF', N, N, 0, 0, 0 )
RESLTS( 1, IN, IUPLO, 1 ) = SMFLOP( OPS, TIME, INFO )
*
ELSE
IC = 0
CALL STIMMG( MAT, N, N, A, LDA, 0, 0 )
END IF
*
* Generate another matrix and factor it using SPPTRF so
* that the factored form can be used in timing the other
* routines.
*
IF( IC.NE.1 )
$ CALL SPPTRF( UPLO, N, A, INFO )
*
* Time SPPTRI
*
IF( TIMSUB( 3 ) ) THEN
CALL SCOPY( LDA, A, 1, B, 1 )
IC = 0
S1 = SECOND( )
30 CONTINUE
CALL SPPTRI( UPLO, N, B, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL SCOPY( LDA, A, 1, B, 1 )
GO TO 30
END IF
*
* Subtract the time used in SLACPY.
*
ICL = 1
S1 = SECOND( )
40 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL SCOPY( LDA, A, 1, B, 1 )
GO TO 40
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SPPTRI', N, N, 0, 0, 0 )
RESLTS( 1, IN, IUPLO, 3 ) = SMFLOP( OPS, TIME, INFO )
END IF
*
* Time SPPTRS
*
IF( TIMSUB( 2 ) ) THEN
DO 70 I = 1, NNS
NRHS = NSVAL( I )
LDB = N
IF( MOD( LDB, 2 ).EQ.0 )
$ LDB = LDB + 1
CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 )
IC = 0
S1 = SECOND( )
50 CONTINUE
CALL SPPTRS( UPLO, N, NRHS, A, B, LDB, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 50
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
60 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 60
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SPPTRS', N, NRHS, 0, 0, 0 )
RESLTS( I, IN, IUPLO, 2 ) = SMFLOP( OPS, TIME, INFO )
70 CONTINUE
END IF
80 CONTINUE
90 CONTINUE
*
* Print tables of results for each timed routine.
*
DO 110 ISUB = 1, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 110
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
DO 100 IUPLO = 1, 2
WRITE( NOUT, FMT = 9997 )SUBNAM( ISUB ), UPLOS( IUPLO )
IF( ISUB.EQ.1 ) THEN
CALL SPRTBL( ' ', 'N', 1, LAVAL, NN, NVAL, 1,
$ RESLTS( 1, 1, IUPLO, 1 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.2 ) THEN
CALL SPRTBL( 'NRHS', 'N', NNS, NSVAL, NN, NVAL, 1,
$ RESLTS( 1, 1, IUPLO, 2 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.3 ) THEN
CALL SPRTBL( ' ', 'N', 1, LAVAL, NN, NVAL, 1,
$ RESLTS( 1, 1, IUPLO, 3 ), LDR1, LDR2, NOUT )
END IF
100 CONTINUE
110 CONTINUE
120 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***', / )
9997 FORMAT( 5X, A6, ' with UPLO = ''', A1, '''', / )
RETURN
*
* End of STIMPP
*
END
SUBROUTINE STIMPT( LINE, NM, MVAL, NNS, NSVAL, NLDA, LDAVAL,
$ TIMMIN, A, B, RESLTS, LDR1, LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NLDA, NM, NNS, NOUT
REAL TIMMIN
* ..
* .. Array Arguments ..
INTEGER LDAVAL( * ), MVAL( * ), NSVAL( * )
REAL A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * )
* ..
*
* Purpose
* =======
*
* STIMPT times SPTTRF, -TRS, -SV, and -SL.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix size M.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) REAL
* The minimum time a subroutine will be timed.
*
* A (workspace) REAL array, dimension (NMAX*2)
* where NMAX is the maximum value permitted for N.
*
* B (workspace) REAL array, dimension (LDAMAX*NMAX)
*
* RESLTS (output) REAL array, dimension
* (LDR1,LDR2,LDR3,NSUBS)
* The timing results for each subroutine over the relevant
* values of N.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= 1.
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NM).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 4 )
* ..
* .. Local Scalars ..
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, IC, ICL, ILDA, IM, INFO, ISUB, LDB, M, N,
$ NRHS
REAL OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER LAVAL( 1 )
* ..
* .. External Functions ..
REAL SECOND, SMFLOP, SOPLA
EXTERNAL SECOND, SMFLOP, SOPLA
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, SPRTBL, SPTSL, SPTSV, SPTTRF,
$ SPTTRS, STIMMG
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, REAL
* ..
* .. Data statements ..
DATA SUBNAM / 'SPTTRF', 'SPTTRS', 'SPTSV ',
$ 'SPTSL ' /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'PT'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 170
*
* Check that N <= LDA for the input values.
*
DO 10 ISUB = 2, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 10
CNAME = SUBNAM( ISUB )
CALL ATIMCK( 2, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
TIMSUB( ISUB ) = .FALSE.
END IF
10 CONTINUE
*
* Do for each value of M:
*
DO 140 IM = 1, NM
*
M = MVAL( IM )
N = MAX( M, 1 )
*
* Time SPTTRF
*
IF( TIMSUB( 1 ) ) THEN
CALL STIMMG( 13, M, M, A, 2*N, 0, 0 )
IC = 0
S1 = SECOND( )
20 CONTINUE
CALL SPTTRF( M, A, A( N+1 ), INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 13, M, M, A, 2*N, 0, 0 )
GO TO 20
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
30 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 13, M, M, A, 2*N, 0, 0 )
GO TO 30
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SPTTRF', M, 0, 0, 0, 0 )
RESLTS( 1, IM, 1, 1 ) = SMFLOP( OPS, TIME, INFO )
*
ELSE
IC = 0
CALL STIMMG( 13, M, M, A, 2*N, 0, 0 )
END IF
*
* Generate another matrix and factor it using SPTTRF so
* that the factored form can be used in timing the other
* routines.
*
IF( IC.NE.1 )
$ CALL SPTTRF( M, A, A( N+1 ), INFO )
*
* Time SPTTRS
*
IF( TIMSUB( 2 ) ) THEN
DO 70 ILDA = 1, NLDA
LDB = LDAVAL( ILDA )
DO 60 I = 1, NNS
NRHS = NSVAL( I )
CALL STIMMG( 0, M, NRHS, B, LDB, 0, 0 )
IC = 0
S1 = SECOND( )
40 CONTINUE
CALL SPTTRS( M, NRHS, A, A( N+1 ), B, LDB, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, M, NRHS, B, LDB, 0, 0 )
GO TO 40
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
50 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, M, NRHS, B, LDB, 0, 0 )
GO TO 50
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SPTTRS', M, NRHS, 0, 0, 0 )
RESLTS( I, IM, ILDA, 2 ) = SMFLOP( OPS, TIME, INFO )
60 CONTINUE
70 CONTINUE
END IF
*
IF( TIMSUB( 3 ) ) THEN
DO 110 ILDA = 1, NLDA
LDB = LDAVAL( ILDA )
DO 100 I = 1, NNS
NRHS = NSVAL( I )
CALL STIMMG( 13, M, M, A, 2*N, 0, 0 )
CALL STIMMG( 0, M, NRHS, B, LDB, 0, 0 )
IC = 0
S1 = SECOND( )
80 CONTINUE
CALL SPTSV( M, NRHS, A, A( N+1 ), B, LDB, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 13, M, M, A, 2*N, 0, 0 )
CALL STIMMG( 0, M, NRHS, B, LDB, 0, 0 )
GO TO 80
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
90 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 13, M, M, A, 2*N, 0, 0 )
CALL STIMMG( 0, M, NRHS, B, LDB, 0, 0 )
GO TO 90
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SPTSV ', M, NRHS, 0, 0, 0 )
RESLTS( I, IM, ILDA, 3 ) = SMFLOP( OPS, TIME, INFO )
100 CONTINUE
110 CONTINUE
END IF
*
IF( TIMSUB( 4 ) ) THEN
CALL STIMMG( 13, M, M, A, 2*N, 0, 0 )
CALL STIMMG( 0, M, 1, B, N, 0, 0 )
IC = 0
S1 = SECOND( )
120 CONTINUE
CALL SPTSL( M, A, A( N+1 ), B )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 13, M, M, A, 2*N, 0, 0 )
CALL STIMMG( 0, M, 1, B, N, 0, 0 )
GO TO 120
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
130 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 13, M, M, A, 2*N, 0, 0 )
CALL STIMMG( 0, M, 1, B, N, 0, 0 )
GO TO 130
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SPTSV ', M, 1, 0, 0, 0 )
RESLTS( 1, IM, 1, 4 ) = SMFLOP( OPS, TIME, INFO )
END IF
140 CONTINUE
*
* Print a table of results for each timed routine.
*
DO 160 ISUB = 1, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 160
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 .AND. ( TIMSUB( 2 ) .OR. TIMSUB( 3 ) ) ) THEN
DO 150 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
150 CONTINUE
END IF
WRITE( NOUT, FMT = * )
IF( ISUB.EQ.1 ) THEN
CALL SPRTBL( ' ', 'N', 1, LAVAL, NM, MVAL, 1, RESLTS, LDR1,
$ LDR2, NOUT )
ELSE IF( ISUB.EQ.2 ) THEN
CALL SPRTBL( 'NRHS', 'N', NNS, NSVAL, NM, MVAL, NLDA,
$ RESLTS( 1, 1, 1, 2 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.3 ) THEN
CALL SPRTBL( 'NRHS', 'N', NNS, NSVAL, NM, MVAL, NLDA,
$ RESLTS( 1, 1, 1, 3 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.4 ) THEN
CALL SPRTBL( ' ', 'N', 1, LAVAL, NM, MVAL, 1,
$ RESLTS( 1, 1, 1, 4 ), LDR1, LDR2, NOUT )
END IF
160 CONTINUE
*
170 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
RETURN
*
* End of STIMPT
*
END
SUBROUTINE STIMQ3( LINE, NM, MVAL, NVAL, NNB, NBVAL, NXVAL, NLDA,
$ LDAVAL, TIMMIN, A, COPYA, TAU, WORK, IWORK,
$ RESLTS, LDR1, LDR2, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* December 22, 1999
*
* Rewritten to time qp3 code.
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, NLDA, NM, NNB, NOUT
REAL TIMMIN
* ..
* .. Array Arguments ..
INTEGER IWORK( * ), LDAVAL( * ), MVAL( * ), NBVAL( * ),
$ NVAL( * ), NXVAL( * )
REAL A( * ), COPYA( * ), RESLTS( LDR1, LDR2, * ),
$ TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* STIMQ3 times the routines to perform the Rank-Revealing QR
* factorization of a REAL general matrix.
*
* Two matrix types may be used for timing. The number of types is
* set in the parameter NMODE and the matrix types are set in the vector
* MODES, using the following key:
* 2. BREAK1 D(1:N-1)=1 and D(N)=1.0/COND in SLATMS
* 3. GEOM D(I)=COND**(-(I-1)/(N-1)) in SLATMS
* These numbers are chosen to correspond with the matrix types in the
* test code.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M and N contained in the vectors
* MVAL and NVAL. The matrix sizes are used in pairs (M,N).
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NVAL (input) INTEGER array, dimension (NM)
* The values of the matrix column dimension N.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) REAL
* The minimum time a subroutine will be timed.
*
* A (workspace) REAL array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values of LDA and N.
*
* COPYA (workspace) REAL array, dimension (LDAMAX*NMAX)
*
* TAU (workspace) REAL array, dimension (MINMN)
*
* WORK (workspace) REAL array, dimension (3*NMAX)
*
* IWORK (workspace) INTEGER array, dimension (2*NMAX)
*
* RESLTS (workspace) REAL array, dimension
* (LDR1,LDR2,NLDA)
* The timing results for each subroutine over the relevant
* values of MODE, (M,N), and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NM).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NM).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
*
*
INTEGER NSUBS, NMODE
PARAMETER ( NSUBS = 1, NMODE = 2 )
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, IC, ICL, ILDA, IM, IMODE, INB, INFO, LDA,
$ LW, M, MINMN, MODE, N, NB, NX
REAL COND, DMAX, OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER ISEED( 4 ), MODES( NMODE )
* ..
* .. External Functions ..
REAL SECOND, SLAMCH, SMFLOP, SOPLA
EXTERNAL SECOND, SLAMCH, SMFLOP, SOPLA
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, ICOPY, SGEQP3, SLACPY, SLATMS,
$ SPRTB4, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Data statements ..
DATA SUBNAM / 'SGEQP3' /
DATA MODES / 2, 3 /
DATA ISEED / 0, 0, 0, 1 /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'QP'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( .NOT.TIMSUB( 1 ) .OR. INFO.NE.0 )
$ GO TO 90
*
* Check that M <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9996 )CNAME
GO TO 90
END IF
*
* Set the condition number and scaling factor for the matrices
* to be generated.
*
DMAX = ONE
COND = ONE / SLAMCH( 'Precision' )
*
* Do for each type of matrix:
*
DO 80 IMODE = 1, NMODE
MODE = MODES( IMODE )
*
*
* *****************
* * Timing xGEQP3 *
* *****************
*
* Do for each value of LDA:
*
DO 60 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
*
* Do for each pair of values (M,N):
*
DO 50 IM = 1, NM
M = MVAL( IM )
N = NVAL( IM )
MINMN = MIN( M, N )
*
* Generate a test matrix of size m by n using the
* singular value distribution indicated by MODE.
*
CALL SLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', TAU,
$ MODE, COND, DMAX, M, N, 'No packing', COPYA,
$ LDA, WORK, INFO )
*
* Do for each pair of values (NB,NX) in NBVAL and NXVAL:
*
DO 40 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
*
*
* SGEQP3
*
LW = MAX( 1, 2*N+( N+1 )*NB )
DO 10 I = 1, N
IWORK( N+I ) = 0
10 CONTINUE
*
CALL SLACPY( 'All', M, N, COPYA, LDA, A, LDA )
CALL ICOPY( N, IWORK( N+1 ), 1, IWORK, 1 )
IC = 0
S1 = SECOND( )
20 CONTINUE
CALL SGEQP3( M, N, A, LDA, IWORK, TAU, WORK, LW,
$ INFO )
S2 = SECOND( )
*
IF( INFO.NE.0 ) THEN
WRITE( *, FMT = * )'>>>Warning: INFO returned by ',
$ 'SGEQPX is:', INFO
INFO = 0
END IF
*
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL SLACPY( 'All', M, N, COPYA, LDA, A, LDA )
CALL ICOPY( N, IWORK( N+1 ), 1, IWORK, 1 )
GO TO 20
END IF
*
* Subtract the time used in SLACPY.
*
ICL = 1
S1 = SECOND( )
30 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL SLACPY( 'All', M, N, COPYA, LDA, A, LDA )
CALL ICOPY( N, IWORK( N+1 ), 1, IWORK, 1 )
GO TO 30
END IF
*
* The number of flops of xGEQP3 is approximately the
* the number of flops of xGEQPF.
*
TIME = ( TIME-UNTIME ) / REAL( IC )
*
OPS = SOPLA( 'SGEQPF', M, N, 0, 0, NB )
RESLTS( INB, IM, ILDA ) = SMFLOP( OPS, TIME, INFO )
*
40 CONTINUE
50 CONTINUE
60 CONTINUE
*
* Print the results for each matrix type.
*
WRITE( NOUT, FMT = 9999 )SUBNAM( 1 )
WRITE( NOUT, FMT = 9998 )IMODE
DO 70 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
70 CONTINUE
WRITE( NOUT, FMT = * )
CALL SPRTB4( '( NB, NX)', 'M', 'N', NNB, NBVAL, NXVAL, NM,
$ MVAL, NVAL, NLDA, RESLTS( 1, 1, 1 ), LDR1, LDR2,
$ NOUT )
*
80 CONTINUE
*
9999 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9998 FORMAT( 5X, 'type of matrix:', I4 )
9997 FORMAT( 5X, 'line ', I4, ' with LDA = ', I4 )
9996 FORMAT( 1X, A6, ' timing run not attempted', / )
*
90 CONTINUE
RETURN
*
* End of STIMQ3
*
END
SUBROUTINE STIMQL( LINE, NM, MVAL, NVAL, NK, KVAL, NNB, NBVAL,
$ NXVAL, NLDA, LDAVAL, TIMMIN, A, TAU, B, WORK,
$ RESLTS, LDR1, LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NK, NLDA, NM, NNB, NOUT
REAL TIMMIN
* ..
* .. Array Arguments ..
INTEGER KVAL( * ), LDAVAL( * ), MVAL( * ), NBVAL( * ),
$ NVAL( * ), NXVAL( * )
REAL A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * ),
$ TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* STIMQL times the LAPACK routines to perform the QL factorization of
* a REAL general matrix.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M and N contained in the vectors
* MVAL and NVAL. The matrix sizes are used in pairs (M,N).
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NVAL (input) INTEGER array, dimension (NM)
* The values of the matrix column dimension N.
*
* NK (input) INTEGER
* The number of values of K in the vector KVAL.
*
* KVAL (input) INTEGER array, dimension (NK)
* The values of the matrix dimension K, used in SORMQL.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) REAL
* The minimum time a subroutine will be timed.
*
* A (workspace) REAL array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values of LDA and N.
*
* TAU (workspace) REAL array, dimension (min(M,N))
*
* B (workspace) REAL array, dimension (LDAMAX*NMAX)
*
* WORK (workspace) REAL array, dimension (LDAMAX*NBMAX)
* where NBMAX is the maximum value of NB.
*
* RESLTS (workspace) REAL array, dimension
* (LDR1,LDR2,LDR3,2*NK)
* The timing results for each subroutine over the relevant
* values of (M,N), (NB,NX), and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NM).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* Internal Parameters
* ===================
*
* MODE INTEGER
* The matrix type. MODE = 3 is a geometric distribution of
* eigenvalues. See SLATMS for further details.
*
* COND REAL
* The condition number of the matrix. The singular values are
* set to values from DMAX to DMAX/COND.
*
* DMAX REAL
* The magnitude of the largest singular value.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 3 )
INTEGER MODE
REAL COND, DMAX
PARAMETER ( MODE = 3, COND = 100.0E0, DMAX = 1.0E0 )
* ..
* .. Local Scalars ..
CHARACTER LABM, SIDE, TRANS
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, I4, IC, ICL, IK, ILDA, IM, IMX, INB, INFO,
$ ISIDE, ISUB, ITOFF, ITRAN, K, K1, LDA, LW, M,
$ M1, MINMN, N, N1, NB, NX
REAL OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER SIDES( 2 ), TRANSS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER ISEED( 4 ), MUSE( 12 ), NUSE( 12 ), RESEED( 4 )
* ..
* .. External Functions ..
REAL SECOND, SMFLOP, SOPLA
EXTERNAL SECOND, SMFLOP, SOPLA
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, ICOPY, SGEQLF, SLACPY, SLATMS,
$ SORGQL, SORMQL, SPRTB4, SPRTB5, STIMMG, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Data statements ..
DATA SUBNAM / 'SGEQLF', 'SORGQL', 'SORMQL' /
DATA SIDES / 'L', 'R' / , TRANSS / 'N', 'T' /
DATA ISEED / 0, 0, 0, 1 /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'QL'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 230
*
* Check that M <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 230
END IF
*
* Do for each pair of values (M,N):
*
DO 70 IM = 1, NM
M = MVAL( IM )
N = NVAL( IM )
MINMN = MIN( M, N )
CALL ICOPY( 4, ISEED, 1, RESEED, 1 )
*
* Do for each value of LDA:
*
DO 60 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
*
* Do for each pair of values (NB, NX) in NBVAL and NXVAL.
*
DO 50 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
LW = MAX( 1, N*MAX( 1, NB ) )
*
* Generate a test matrix of size M by N.
*
CALL ICOPY( 4, RESEED, 1, ISEED, 1 )
CALL SLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', TAU,
$ MODE, COND, DMAX, M, N, 'No packing', B,
$ LDA, WORK, INFO )
*
IF( TIMSUB( 1 ) ) THEN
*
* SGEQLF: QL factorization
*
CALL SLACPY( 'Full', M, N, B, LDA, A, LDA )
IC = 0
S1 = SECOND( )
10 CONTINUE
CALL SGEQLF( M, N, A, LDA, TAU, WORK, LW, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL SLACPY( 'Full', M, N, B, LDA, A, LDA )
GO TO 10
END IF
*
* Subtract the time used in SLACPY.
*
ICL = 1
S1 = SECOND( )
20 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL SLACPY( 'Full', M, N, A, LDA, B, LDA )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SGEQLF', M, N, 0, 0, NB )
RESLTS( INB, IM, ILDA, 1 ) = SMFLOP( OPS, TIME, INFO )
ELSE
*
* If SGEQLF was not timed, generate a matrix and factor
* it using SGEQLF anyway so that the factored form of
* the matrix can be used in timing the other routines.
*
CALL SLACPY( 'Full', M, N, B, LDA, A, LDA )
CALL SGEQLF( M, N, A, LDA, TAU, WORK, LW, INFO )
END IF
*
IF( TIMSUB( 2 ) ) THEN
*
* SORGQL: Generate orthogonal matrix Q from the QL
* factorization
*
CALL SLACPY( 'Full', M, MINMN, A, LDA, B, LDA )
IC = 0
S1 = SECOND( )
30 CONTINUE
CALL SORGQL( M, MINMN, MINMN, B, LDA, TAU, WORK, LW,
$ INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL SLACPY( 'Full', M, MINMN, A, LDA, B, LDA )
GO TO 30
END IF
*
* Subtract the time used in SLACPY.
*
ICL = 1
S1 = SECOND( )
40 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL SLACPY( 'Full', M, MINMN, A, LDA, B, LDA )
GO TO 40
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SORGQL', M, MINMN, MINMN, 0, NB )
RESLTS( INB, IM, ILDA, 2 ) = SMFLOP( OPS, TIME, INFO )
END IF
*
50 CONTINUE
60 CONTINUE
70 CONTINUE
*
* Print tables of results
*
DO 90 ISUB = 1, NSUBS - 1
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 90
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 80 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
80 CONTINUE
END IF
WRITE( NOUT, FMT = * )
IF( ISUB.EQ.2 )
$ WRITE( NOUT, FMT = 9996 )
CALL SPRTB4( '( NB, NX)', 'M', 'N', NNB, NBVAL, NXVAL, NM,
$ MVAL, NVAL, NLDA, RESLTS( 1, 1, 1, ISUB ), LDR1,
$ LDR2, NOUT )
90 CONTINUE
*
* Time SORMQL separately. Here the starting matrix is M by N, and
* K is the free dimension of the matrix multiplied by Q.
*
IF( TIMSUB( 3 ) ) THEN
*
* Check that K <= LDA for the input values.
*
CALL ATIMCK( 3, CNAME, NK, KVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )SUBNAM( 3 )
GO TO 230
END IF
*
* Use only the pairs (M,N) where M >= N.
*
IMX = 0
DO 100 IM = 1, NM
IF( MVAL( IM ).GE.NVAL( IM ) ) THEN
IMX = IMX + 1
MUSE( IMX ) = MVAL( IM )
NUSE( IMX ) = NVAL( IM )
END IF
100 CONTINUE
*
* SORMQL: Multiply by Q stored as a product of elementary
* transformations
*
* Do for each pair of values (M,N):
*
DO 180 IM = 1, IMX
M = MUSE( IM )
N = NUSE( IM )
*
* Do for each value of LDA:
*
DO 170 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
*
* Generate an M by N matrix and form its QL decomposition.
*
CALL SLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', TAU,
$ MODE, COND, DMAX, M, N, 'No packing', A,
$ LDA, WORK, INFO )
LW = MAX( 1, N*MAX( 1, NB ) )
CALL SGEQLF( M, N, A, LDA, TAU, WORK, LW, INFO )
*
* Do first for SIDE = 'L', then for SIDE = 'R'
*
I4 = 0
DO 160 ISIDE = 1, 2
SIDE = SIDES( ISIDE )
*
* Do for each pair of values (NB, NX) in NBVAL and
* NXVAL.
*
DO 150 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
*
* Do for each value of K in KVAL
*
DO 140 IK = 1, NK
K = KVAL( IK )
*
* Sort out which variable is which
*
IF( ISIDE.EQ.1 ) THEN
M1 = M
K1 = N
N1 = K
LW = MAX( 1, N1*MAX( 1, NB ) )
ELSE
N1 = M
K1 = N
M1 = K
LW = MAX( 1, M1*MAX( 1, NB ) )
END IF
*
* Do first for TRANS = 'N', then for TRANS = 'T'
*
ITOFF = 0
DO 130 ITRAN = 1, 2
TRANS = TRANSS( ITRAN )
CALL STIMMG( 0, M1, N1, B, LDA, 0, 0 )
IC = 0
S1 = SECOND( )
110 CONTINUE
CALL SORMQL( SIDE, TRANS, M1, N1, K1, A, LDA,
$ TAU, B, LDA, WORK, LW, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, M1, N1, B, LDA, 0, 0 )
GO TO 110
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
120 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, M1, N1, B, LDA, 0, 0 )
GO TO 120
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SORMQL', M1, N1, K1, ISIDE-1,
$ NB )
RESLTS( INB, IM, ILDA,
$ I4+ITOFF+IK ) = SMFLOP( OPS, TIME, INFO )
ITOFF = NK
130 CONTINUE
140 CONTINUE
150 CONTINUE
I4 = 2*NK
160 CONTINUE
170 CONTINUE
180 CONTINUE
*
* Print tables of results
*
ISUB = 3
I4 = 1
IF( IMX.GE.1 ) THEN
DO 220 ISIDE = 1, 2
SIDE = SIDES( ISIDE )
IF( ISIDE.EQ.1 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 190 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
190 CONTINUE
END IF
END IF
DO 210 ITRAN = 1, 2
TRANS = TRANSS( ITRAN )
DO 200 IK = 1, NK
IF( ISIDE.EQ.1 ) THEN
N = KVAL( IK )
WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ), SIDE,
$ TRANS, 'N', N
LABM = 'M'
ELSE
M = KVAL( IK )
WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ), SIDE,
$ TRANS, 'M', M
LABM = 'N'
END IF
CALL SPRTB5( 'NB', LABM, 'K', NNB, NBVAL, IMX,
$ MUSE, NUSE, NLDA,
$ RESLTS( 1, 1, 1, I4 ), LDR1, LDR2,
$ NOUT )
I4 = I4 + 1
200 CONTINUE
210 CONTINUE
220 CONTINUE
ELSE
WRITE( NOUT, FMT = 9994 )SUBNAM( ISUB )
END IF
END IF
230 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
9996 FORMAT( 5X, 'K = min(M,N)', / )
9995 FORMAT( / 5X, A6, ' with SIDE = ''', A1, ''', TRANS = ''', A1,
$ ''', ', A1, ' =', I6, / )
9994 FORMAT( ' *** No pairs (M,N) found with M >= N: ', A6,
$ ' not timed' )
RETURN
*
* End of STIMQL
*
END
SUBROUTINE STIMQP( LINE, NM, MVAL, NVAL, NLDA, LDAVAL, TIMMIN, A,
$ COPYA, TAU, WORK, IWORK, RESLTS, LDR1, LDR2,
$ NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, NLDA, NM, NOUT
REAL TIMMIN
* ..
* .. Array Arguments ..
INTEGER IWORK( * ), LDAVAL( * ), MVAL( * ), NVAL( * )
REAL A( * ), COPYA( * ), RESLTS( LDR1, LDR2, * ),
$ TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* STIMQP times the LAPACK routines to perform the QR factorization with
* column pivoting of a REAL general matrix.
*
* Two matrix types may be used for timing. The number of types is
* set in the parameter NMODE and the matrix types are set in the vector
* MODES, using the following key:
* 2. BREAK1 D(1:N-1)=1 and D(N)=1.0/COND in SLATMS
* 3. GEOM D(I)=COND**(-(I-1)/(N-1)) in SLATMS
* These numbers are chosen to correspond with the matrix types in the
* test code.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M and N contained in the vectors
* MVAL and NVAL. The matrix sizes are used in pairs (M,N).
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NVAL (input) INTEGER array, dimension (NM)
* The values of the matrix column dimension N.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) REAL
* The minimum time a subroutine will be timed.
*
* A (workspace) REAL array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values of LDA and N.
*
* COPYA (workspace) REAL array, dimension (LDAMAX*NMAX)
*
* TAU (workspace) REAL array, dimension (min(M,N))
*
* WORK (workspace) REAL array, dimension (3*NMAX)
*
* IWORK (workspace) INTEGER array, dimension (2*NMAX)
*
* RESLTS (workspace) REAL array, dimension
* (LDR1,LDR2,NLDA)
* The timing results for each subroutine over the relevant
* values of MODE, (M,N), and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NM).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NM).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS, NMODE
PARAMETER ( NSUBS = 1, NMODE = 2 )
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, IC, ICL, ILDA, IM, IMODE, INFO, LDA, M,
$ MINMN, MODE, N
REAL COND, DMAX, OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER ISEED( 4 ), MODES( NMODE )
* ..
* .. External Functions ..
REAL SECOND, SLAMCH, SMFLOP, SOPLA
EXTERNAL SECOND, SLAMCH, SMFLOP, SOPLA
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, ICOPY, SGEQPF, SLACPY, SLATMS,
$ SPRTB5
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN, REAL
* ..
* .. Data statements ..
DATA SUBNAM / 'SGEQPF' /
DATA MODES / 2, 3 /
DATA ISEED / 0, 0, 0, 1 /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'QP'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( .NOT.TIMSUB( 1 ) .OR. INFO.NE.0 )
$ GO TO 80
*
* Check that M <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 80
END IF
*
* Set the condition number and scaling factor for the matrices
* to be generated.
*
DMAX = ONE
COND = ONE / SLAMCH( 'Precision' )
*
* Do for each pair of values (M,N):
*
DO 60 IM = 1, NM
M = MVAL( IM )
N = NVAL( IM )
MINMN = MIN( M, N )
*
* Do for each value of LDA:
*
DO 50 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 40 IMODE = 1, NMODE
MODE = MODES( IMODE )
*
* Generate a test matrix of size m by n using the
* singular value distribution indicated by MODE.
*
DO 10 I = 1, N
IWORK( N+I ) = 0
10 CONTINUE
CALL SLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', TAU,
$ MODE, COND, DMAX, M, N, 'No packing', COPYA,
$ LDA, WORK, INFO )
*
* SGEQPF: QR factorization with column pivoting
*
CALL SLACPY( 'All', M, N, COPYA, LDA, A, LDA )
CALL ICOPY( N, IWORK( N+1 ), 1, IWORK, 1 )
IC = 0
S1 = SECOND( )
20 CONTINUE
CALL SGEQPF( M, N, A, LDA, IWORK, TAU, WORK, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL SLACPY( 'All', M, N, COPYA, LDA, A, LDA )
CALL ICOPY( N, IWORK( N+1 ), 1, IWORK, 1 )
GO TO 20
END IF
*
* Subtract the time used in SLACPY and ICOPY.
*
ICL = 1
S1 = SECOND( )
30 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL SLACPY( 'All', M, N, COPYA, LDA, A, LDA )
CALL ICOPY( N, IWORK( N+1 ), 1, IWORK, 1 )
GO TO 30
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SGEQPF', M, N, 0, 0, 1 )
RESLTS( IMODE, IM, ILDA ) = SMFLOP( OPS, TIME, INFO )
*
40 CONTINUE
50 CONTINUE
60 CONTINUE
*
* Print tables of results
*
WRITE( NOUT, FMT = 9998 )SUBNAM( 1 )
IF( NLDA.GT.1 ) THEN
DO 70 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
70 CONTINUE
END IF
WRITE( NOUT, FMT = * )
CALL SPRTB5( 'Type', 'M', 'N', NMODE, MODES, NM, MVAL, NVAL, NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
80 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
RETURN
*
* End of STIMQP
*
END
SUBROUTINE STIMQR( LINE, NM, MVAL, NVAL, NK, KVAL, NNB, NBVAL,
$ NXVAL, NLDA, LDAVAL, TIMMIN, A, TAU, B, WORK,
$ RESLTS, LDR1, LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NK, NLDA, NM, NNB, NOUT
REAL TIMMIN
* ..
* .. Array Arguments ..
INTEGER KVAL( * ), LDAVAL( * ), MVAL( * ), NBVAL( * ),
$ NVAL( * ), NXVAL( * )
REAL A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * ),
$ TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* STIMQR times the LAPACK routines to perform the QR factorization of
* a REAL general matrix.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M and N contained in the vectors
* MVAL and NVAL. The matrix sizes are used in pairs (M,N).
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NVAL (input) INTEGER array, dimension (NM)
* The values of the matrix column dimension N.
*
* NK (input) INTEGER
* The number of values of K in the vector KVAL.
*
* KVAL (input) INTEGER array, dimension (NK)
* The values of the matrix dimension K, used in SORMQR.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) REAL
* The minimum time a subroutine will be timed.
*
* A (workspace) REAL array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values of LDA and N.
*
* TAU (workspace) REAL array, dimension (min(M,N))
*
* B (workspace) REAL array, dimension (LDAMAX*NMAX)
*
* WORK (workspace) REAL array, dimension (LDAMAX*NBMAX)
* where NBMAX is the maximum value of NB.
*
* RESLTS (workspace) REAL array, dimension
* (LDR1,LDR2,LDR3,2*NK)
* The timing results for each subroutine over the relevant
* values of (M,N), (NB,NX), and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NM).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* Internal Parameters
* ===================
*
* MODE INTEGER
* The matrix type. MODE = 3 is a geometric distribution of
* eigenvalues. See SLATMS for further details.
*
* COND REAL
* The condition number of the matrix. The singular values are
* set to values from DMAX to DMAX/COND.
*
* DMAX REAL
* The magnitude of the largest singular value.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 3 )
INTEGER MODE
REAL COND, DMAX
PARAMETER ( MODE = 3, COND = 100.0E0, DMAX = 1.0E0 )
* ..
* .. Local Scalars ..
CHARACTER LABM, SIDE, TRANS
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, I4, IC, ICL, IK, ILDA, IM, IMX, INB, INFO,
$ ISIDE, ISUB, ITOFF, ITRAN, K, K1, LDA, LW, M,
$ M1, MINMN, N, N1, NB, NX
REAL OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER SIDES( 2 ), TRANSS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER ISEED( 4 ), MUSE( 12 ), NUSE( 12 ), RESEED( 4 )
* ..
* .. External Functions ..
REAL SECOND, SMFLOP, SOPLA
EXTERNAL SECOND, SMFLOP, SOPLA
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, ICOPY, SGEQRF, SLACPY, SLATMS,
$ SORGQR, SORMQR, SPRTB4, SPRTB5, STIMMG, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Data statements ..
DATA SUBNAM / 'SGEQRF', 'SORGQR', 'SORMQR' /
DATA SIDES / 'L', 'R' / , TRANSS / 'N', 'T' /
DATA ISEED / 0, 0, 0, 1 /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'QR'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 230
*
* Check that M <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 230
END IF
*
* Do for each pair of values (M,N):
*
DO 70 IM = 1, NM
M = MVAL( IM )
N = NVAL( IM )
MINMN = MIN( M, N )
CALL ICOPY( 4, ISEED, 1, RESEED, 1 )
*
* Do for each value of LDA:
*
DO 60 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
*
* Do for each pair of values (NB, NX) in NBVAL and NXVAL.
*
DO 50 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
LW = MAX( 1, N*MAX( 1, NB ) )
*
* Generate a test matrix of size M by N.
*
CALL ICOPY( 4, RESEED, 1, ISEED, 1 )
CALL SLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', TAU,
$ MODE, COND, DMAX, M, N, 'No packing', B,
$ LDA, WORK, INFO )
*
IF( TIMSUB( 1 ) ) THEN
*
* SGEQRF: QR factorization
*
CALL SLACPY( 'Full', M, N, B, LDA, A, LDA )
IC = 0
S1 = SECOND( )
10 CONTINUE
CALL SGEQRF( M, N, A, LDA, TAU, WORK, LW, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL SLACPY( 'Full', M, N, B, LDA, A, LDA )
GO TO 10
END IF
*
* Subtract the time used in SLACPY.
*
ICL = 1
S1 = SECOND( )
20 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL SLACPY( 'Full', M, N, A, LDA, B, LDA )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SGEQRF', M, N, 0, 0, NB )
RESLTS( INB, IM, ILDA, 1 ) = SMFLOP( OPS, TIME, INFO )
ELSE
*
* If SGEQRF was not timed, generate a matrix and factor
* it using SGEQRF anyway so that the factored form of
* the matrix can be used in timing the other routines.
*
CALL SLACPY( 'Full', M, N, B, LDA, A, LDA )
CALL SGEQRF( M, N, A, LDA, TAU, WORK, LW, INFO )
END IF
*
IF( TIMSUB( 2 ) ) THEN
*
* SORGQR: Generate orthogonal matrix Q from the QR
* factorization
*
CALL SLACPY( 'Full', M, MINMN, A, LDA, B, LDA )
IC = 0
S1 = SECOND( )
30 CONTINUE
CALL SORGQR( M, MINMN, MINMN, B, LDA, TAU, WORK, LW,
$ INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL SLACPY( 'Full', M, MINMN, A, LDA, B, LDA )
GO TO 30
END IF
*
* Subtract the time used in SLACPY.
*
ICL = 1
S1 = SECOND( )
40 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL SLACPY( 'Full', M, MINMN, A, LDA, B, LDA )
GO TO 40
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SORGQR', M, MINMN, MINMN, 0, NB )
RESLTS( INB, IM, ILDA, 2 ) = SMFLOP( OPS, TIME, INFO )
END IF
*
50 CONTINUE
60 CONTINUE
70 CONTINUE
*
* Print tables of results
*
DO 90 ISUB = 1, NSUBS - 1
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 90
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 80 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
80 CONTINUE
END IF
WRITE( NOUT, FMT = * )
IF( ISUB.EQ.2 )
$ WRITE( NOUT, FMT = 9996 )
CALL SPRTB4( '( NB, NX)', 'M', 'N', NNB, NBVAL, NXVAL, NM,
$ MVAL, NVAL, NLDA, RESLTS( 1, 1, 1, ISUB ), LDR1,
$ LDR2, NOUT )
90 CONTINUE
*
* Time SORMQR separately. Here the starting matrix is M by N, and
* K is the free dimension of the matrix multiplied by Q.
*
IF( TIMSUB( 3 ) ) THEN
*
* Check that K <= LDA for the input values.
*
CALL ATIMCK( 3, CNAME, NK, KVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )SUBNAM( 3 )
GO TO 230
END IF
*
* Use only the pairs (M,N) where M >= N.
*
IMX = 0
DO 100 IM = 1, NM
IF( MVAL( IM ).GE.NVAL( IM ) ) THEN
IMX = IMX + 1
MUSE( IMX ) = MVAL( IM )
NUSE( IMX ) = NVAL( IM )
END IF
100 CONTINUE
*
* SORMQR: Multiply by Q stored as a product of elementary
* transformations
*
* Do for each pair of values (M,N):
*
DO 180 IM = 1, IMX
M = MUSE( IM )
N = NUSE( IM )
*
* Do for each value of LDA:
*
DO 170 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
*
* Generate an M by N matrix and form its QR decomposition.
*
CALL SLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', TAU,
$ MODE, COND, DMAX, M, N, 'No packing', A,
$ LDA, WORK, INFO )
LW = MAX( 1, N*MAX( 1, NB ) )
CALL SGEQRF( M, N, A, LDA, TAU, WORK, LW, INFO )
*
* Do first for SIDE = 'L', then for SIDE = 'R'
*
I4 = 0
DO 160 ISIDE = 1, 2
SIDE = SIDES( ISIDE )
*
* Do for each pair of values (NB, NX) in NBVAL and
* NXVAL.
*
DO 150 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
*
* Do for each value of K in KVAL
*
DO 140 IK = 1, NK
K = KVAL( IK )
*
* Sort out which variable is which
*
IF( ISIDE.EQ.1 ) THEN
M1 = M
K1 = N
N1 = K
LW = MAX( 1, N1*MAX( 1, NB ) )
ELSE
N1 = M
K1 = N
M1 = K
LW = MAX( 1, M1*MAX( 1, NB ) )
END IF
*
* Do first for TRANS = 'N', then for TRANS = 'T'
*
ITOFF = 0
DO 130 ITRAN = 1, 2
TRANS = TRANSS( ITRAN )
CALL STIMMG( 0, M1, N1, B, LDA, 0, 0 )
IC = 0
S1 = SECOND( )
110 CONTINUE
CALL SORMQR( SIDE, TRANS, M1, N1, K1, A, LDA,
$ TAU, B, LDA, WORK, LW, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, M1, N1, B, LDA, 0, 0 )
GO TO 110
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
120 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, M1, N1, B, LDA, 0, 0 )
GO TO 120
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SORMQR', M1, N1, K1, ISIDE-1,
$ NB )
RESLTS( INB, IM, ILDA,
$ I4+ITOFF+IK ) = SMFLOP( OPS, TIME, INFO )
ITOFF = NK
130 CONTINUE
140 CONTINUE
150 CONTINUE
I4 = 2*NK
160 CONTINUE
170 CONTINUE
180 CONTINUE
*
* Print tables of results
*
ISUB = 3
I4 = 1
IF( IMX.GE.1 ) THEN
DO 220 ISIDE = 1, 2
SIDE = SIDES( ISIDE )
IF( ISIDE.EQ.1 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 190 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
190 CONTINUE
END IF
END IF
DO 210 ITRAN = 1, 2
TRANS = TRANSS( ITRAN )
DO 200 IK = 1, NK
IF( ISIDE.EQ.1 ) THEN
N = KVAL( IK )
WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ), SIDE,
$ TRANS, 'N', N
LABM = 'M'
ELSE
M = KVAL( IK )
WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ), SIDE,
$ TRANS, 'M', M
LABM = 'N'
END IF
CALL SPRTB5( 'NB', LABM, 'K', NNB, NBVAL, IMX,
$ MUSE, NUSE, NLDA,
$ RESLTS( 1, 1, 1, I4 ), LDR1, LDR2,
$ NOUT )
I4 = I4 + 1
200 CONTINUE
210 CONTINUE
220 CONTINUE
ELSE
WRITE( NOUT, FMT = 9994 )SUBNAM( ISUB )
END IF
END IF
230 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
9996 FORMAT( 5X, 'K = min(M,N)', / )
9995 FORMAT( / 5X, A6, ' with SIDE = ''', A1, ''', TRANS = ''', A1,
$ ''', ', A1, ' =', I6, / )
9994 FORMAT( ' *** No pairs (M,N) found with M >= N: ', A6,
$ ' not timed' )
RETURN
*
* End of STIMQR
*
END
SUBROUTINE STIMRQ( LINE, NM, MVAL, NVAL, NK, KVAL, NNB, NBVAL,
$ NXVAL, NLDA, LDAVAL, TIMMIN, A, TAU, B, WORK,
$ RESLTS, LDR1, LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NK, NLDA, NM, NNB, NOUT
REAL TIMMIN
* ..
* .. Array Arguments ..
INTEGER KVAL( * ), LDAVAL( * ), MVAL( * ), NBVAL( * ),
$ NVAL( * ), NXVAL( * )
REAL A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * ),
$ TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* STIMRQ times the LAPACK routines to perform the RQ factorization of
* a REAL general matrix.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M and N contained in the vectors
* MVAL and NVAL. The matrix sizes are used in pairs (M,N).
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NVAL (input) INTEGER array, dimension (NM)
* The values of the matrix column dimension N.
*
* NK (input) INTEGER
* The number of values of K in the vector KVAL.
*
* KVAL (input) INTEGER array, dimension (NK)
* The values of the matrix dimension K, used in SORMRQ.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) REAL
* The minimum time a subroutine will be timed.
*
* A (workspace) REAL array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values of LDA and N.
*
* TAU (workspace) REAL array, dimension (min(M,N))
*
* B (workspace) REAL array, dimension (LDAMAX*NMAX)
*
* WORK (workspace) REAL array, dimension (LDAMAX*NBMAX)
* where NBMAX is the maximum value of NB.
*
* RESLTS (workspace) REAL array, dimension
* (LDR1,LDR2,LDR3,2*NK)
* The timing results for each subroutine over the relevant
* values of (M,N), (NB,NX), and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NM).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* Internal Parameters
* ===================
*
* MODE INTEGER
* The matrix type. MODE = 3 is a geometric distribution of
* eigenvalues. See SLATMS for further details.
*
* COND REAL
* The condition number of the matrix. The singular values are
* set to values from DMAX to DMAX/COND.
*
* DMAX REAL
* The magnitude of the largest singular value.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 3 )
INTEGER MODE
REAL COND, DMAX
PARAMETER ( MODE = 3, COND = 100.0E0, DMAX = 1.0E0 )
* ..
* .. Local Scalars ..
CHARACTER LABM, SIDE, TRANS
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, I4, IC, ICL, IK, ILDA, IM, IMX, INB, INFO,
$ ISIDE, ISUB, ITOFF, ITRAN, K, K1, LDA, LW, M,
$ M1, MINMN, N, N1, NB, NX
REAL OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER SIDES( 2 ), TRANSS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER ISEED( 4 ), MUSE( 12 ), NUSE( 12 ), RESEED( 4 )
* ..
* .. External Functions ..
REAL SECOND, SMFLOP, SOPLA
EXTERNAL SECOND, SMFLOP, SOPLA
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, ICOPY, SGERQF, SLACPY, SLATMS,
$ SORGRQ, SORMRQ, SPRTB4, SPRTB5, STIMMG, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Data statements ..
DATA SUBNAM / 'SGERQF', 'SORGRQ', 'SORMRQ' /
DATA SIDES / 'L', 'R' / , TRANSS / 'N', 'T' /
DATA ISEED / 0, 0, 0, 1 /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'RQ'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 230
*
* Check that M <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 230
END IF
*
* Do for each pair of values (M,N):
*
DO 70 IM = 1, NM
M = MVAL( IM )
N = NVAL( IM )
MINMN = MIN( M, N )
CALL ICOPY( 4, ISEED, 1, RESEED, 1 )
*
* Do for each value of LDA:
*
DO 60 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
*
* Do for each pair of values (NB, NX) in NBVAL and NXVAL.
*
DO 50 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
LW = MAX( 1, M*MAX( 1, NB ) )
*
* Generate a test matrix of size M by N.
*
CALL ICOPY( 4, RESEED, 1, ISEED, 1 )
CALL SLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', TAU,
$ MODE, COND, DMAX, M, N, 'No packing', B,
$ LDA, WORK, INFO )
*
IF( TIMSUB( 1 ) ) THEN
*
* SGERQF: RQ factorization
*
CALL SLACPY( 'Full', M, N, B, LDA, A, LDA )
IC = 0
S1 = SECOND( )
10 CONTINUE
CALL SGERQF( M, N, A, LDA, TAU, WORK, LW, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL SLACPY( 'Full', M, N, B, LDA, A, LDA )
GO TO 10
END IF
*
* Subtract the time used in SLACPY.
*
ICL = 1
S1 = SECOND( )
20 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL SLACPY( 'Full', M, N, A, LDA, B, LDA )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SGERQF', M, N, 0, 0, NB )
RESLTS( INB, IM, ILDA, 1 ) = SMFLOP( OPS, TIME, INFO )
ELSE
*
* If SGERQF was not timed, generate a matrix and factor
* it using SGERQF anyway so that the factored form of
* the matrix can be used in timing the other routines.
*
CALL SLACPY( 'Full', M, N, B, LDA, A, LDA )
CALL SGERQF( M, N, A, LDA, TAU, WORK, LW, INFO )
END IF
*
IF( TIMSUB( 2 ) ) THEN
*
* SORGRQ: Generate orthogonal matrix Q from the RQ
* factorization
*
CALL SLACPY( 'Full', MINMN, N, A, LDA, B, LDA )
IC = 0
S1 = SECOND( )
30 CONTINUE
CALL SORGRQ( MINMN, N, MINMN, B, LDA, TAU, WORK, LW,
$ INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL SLACPY( 'Full', MINMN, N, A, LDA, B, LDA )
GO TO 30
END IF
*
* Subtract the time used in SLACPY.
*
ICL = 1
S1 = SECOND( )
40 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL SLACPY( 'Full', MINMN, N, A, LDA, B, LDA )
GO TO 40
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SORGRQ', MINMN, N, MINMN, 0, NB )
RESLTS( INB, IM, ILDA, 2 ) = SMFLOP( OPS, TIME, INFO )
END IF
*
50 CONTINUE
60 CONTINUE
70 CONTINUE
*
* Print tables of results
*
DO 90 ISUB = 1, NSUBS - 1
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 90
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 80 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
80 CONTINUE
END IF
WRITE( NOUT, FMT = * )
IF( ISUB.EQ.2 )
$ WRITE( NOUT, FMT = 9996 )
CALL SPRTB4( '( NB, NX)', 'M', 'N', NNB, NBVAL, NXVAL, NM,
$ MVAL, NVAL, NLDA, RESLTS( 1, 1, 1, ISUB ), LDR1,
$ LDR2, NOUT )
90 CONTINUE
*
* Time SORMRQ separately. Here the starting matrix is M by N, and
* K is the free dimension of the matrix multiplied by Q.
*
IF( TIMSUB( 3 ) ) THEN
*
* Check that K <= LDA for the input values.
*
CALL ATIMCK( 3, CNAME, NK, KVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )SUBNAM( 3 )
GO TO 230
END IF
*
* Use only the pairs (M,N) where M <= N.
*
IMX = 0
DO 100 IM = 1, NM
IF( MVAL( IM ).LE.NVAL( IM ) ) THEN
IMX = IMX + 1
MUSE( IMX ) = MVAL( IM )
NUSE( IMX ) = NVAL( IM )
END IF
100 CONTINUE
*
* SORMRQ: Multiply by Q stored as a product of elementary
* transformations
*
* Do for each pair of values (M,N):
*
DO 180 IM = 1, IMX
M = MUSE( IM )
N = NUSE( IM )
*
* Do for each value of LDA:
*
DO 170 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
*
* Generate an M by N matrix and form its RQ decomposition.
*
CALL SLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', TAU,
$ MODE, COND, DMAX, M, N, 'No packing', A,
$ LDA, WORK, INFO )
LW = MAX( 1, M*MAX( 1, NB ) )
CALL SGERQF( M, N, A, LDA, TAU, WORK, LW, INFO )
*
* Do first for SIDE = 'L', then for SIDE = 'R'
*
I4 = 0
DO 160 ISIDE = 1, 2
SIDE = SIDES( ISIDE )
*
* Do for each pair of values (NB, NX) in NBVAL and
* NXVAL.
*
DO 150 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
*
* Do for each value of K in KVAL
*
DO 140 IK = 1, NK
K = KVAL( IK )
*
* Sort out which variable is which
*
IF( ISIDE.EQ.1 ) THEN
K1 = M
M1 = N
N1 = K
LW = MAX( 1, N1*MAX( 1, NB ) )
ELSE
K1 = M
N1 = N
M1 = K
LW = MAX( 1, M1*MAX( 1, NB ) )
END IF
*
* Do first for TRANS = 'N', then for TRANS = 'T'
*
ITOFF = 0
DO 130 ITRAN = 1, 2
TRANS = TRANSS( ITRAN )
CALL STIMMG( 0, M1, N1, B, LDA, 0, 0 )
IC = 0
S1 = SECOND( )
110 CONTINUE
CALL SORMRQ( SIDE, TRANS, M1, N1, K1, A, LDA,
$ TAU, B, LDA, WORK, LW, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, M1, N1, B, LDA, 0, 0 )
GO TO 110
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
120 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, M1, N1, B, LDA, 0, 0 )
GO TO 120
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SORMRQ', M1, N1, K1, ISIDE-1,
$ NB )
RESLTS( INB, IM, ILDA,
$ I4+ITOFF+IK ) = SMFLOP( OPS, TIME, INFO )
ITOFF = NK
130 CONTINUE
140 CONTINUE
150 CONTINUE
I4 = 2*NK
160 CONTINUE
170 CONTINUE
180 CONTINUE
*
* Print tables of results
*
ISUB = 3
I4 = 1
IF( IMX.GE.1 ) THEN
DO 220 ISIDE = 1, 2
SIDE = SIDES( ISIDE )
IF( ISIDE.EQ.1 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 190 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
190 CONTINUE
END IF
END IF
DO 210 ITRAN = 1, 2
TRANS = TRANSS( ITRAN )
DO 200 IK = 1, NK
IF( ISIDE.EQ.1 ) THEN
N = KVAL( IK )
WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ), SIDE,
$ TRANS, 'N', N
LABM = 'M'
ELSE
M = KVAL( IK )
WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ), SIDE,
$ TRANS, 'M', M
LABM = 'N'
END IF
CALL SPRTB5( 'NB', 'K', LABM, NNB, NBVAL, IMX,
$ MUSE, NUSE, NLDA,
$ RESLTS( 1, 1, 1, I4 ), LDR1, LDR2,
$ NOUT )
I4 = I4 + 1
200 CONTINUE
210 CONTINUE
220 CONTINUE
ELSE
WRITE( NOUT, FMT = 9994 )SUBNAM( ISUB )
END IF
END IF
230 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
9996 FORMAT( 5X, 'K = min(M,N)', / )
9995 FORMAT( / 5X, A6, ' with SIDE = ''', A1, ''', TRANS = ''', A1,
$ ''', ', A1, ' =', I6, / )
9994 FORMAT( ' *** No pairs (M,N) found with M <= N: ', A6,
$ ' not timed' )
RETURN
*
* End of STIMRQ
*
END
SUBROUTINE STIMSP( LINE, NN, NVAL, NNS, NSVAL, LA, TIMMIN, A, B,
$ WORK, IWORK, RESLTS, LDR1, LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LA, LDR1, LDR2, LDR3, NN, NNS, NOUT
REAL TIMMIN
* ..
* .. Array Arguments ..
INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
REAL A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* STIMSP times SSPTRF, -TRS, and -TRI.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix size N.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* LA (input) INTEGER
* The size of the arrays A, B, and C.
*
* TIMMIN (input) REAL
* The minimum time a subroutine will be timed.
*
* A (workspace) REAL array, dimension (LA)
*
* B (workspace) REAL array, dimension (LA)
*
* WORK (workspace) REAL array, dimension (NMAX)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
* where NMAX is the maximum value of N permitted.
*
* RESLTS (output) REAL array, dimension
* (LDR1,LDR2,LDR3,NSUBS)
* The timing results for each subroutine over the relevant
* values of N.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(4,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NN).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= 2.
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 3 )
* ..
* .. Local Scalars ..
CHARACTER UPLO
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, IC, ICL, IN, INFO, ISUB, IUPLO, LDA, LDB,
$ MAT, N, NRHS
REAL OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER UPLOS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER LAVAL( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SECOND, SMFLOP, SOPLA
EXTERNAL LSAME, SECOND, SMFLOP, SOPLA
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, SCOPY, SPRTBL, SSPTRF, SSPTRI,
$ SSPTRS, STIMMG
* ..
* .. Intrinsic Functions ..
INTRINSIC MOD, REAL
* ..
* .. Data statements ..
DATA UPLOS / 'U', 'L' /
DATA SUBNAM / 'SSPTRF', 'SSPTRS', 'SSPTRI' /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'SP'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 120
*
* Check that N*(N+1)/2 <= LA for the input values.
*
CNAME = LINE( 1: 6 )
LAVAL( 1 ) = LA
CALL ATIMCK( 4, CNAME, NN, NVAL, 1, LAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 120
END IF
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 90 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
IF( LSAME( UPLO, 'U' ) ) THEN
MAT = 7
ELSE
MAT = -7
END IF
*
* Do for each value of N in NVAL.
*
DO 80 IN = 1, NN
N = NVAL( IN )
LDA = N*( N+1 ) / 2
*
* Time SSPTRF
*
IF( TIMSUB( 1 ) ) THEN
CALL STIMMG( MAT, N, N, A, LDA, 0, 0 )
IC = 0
S1 = SECOND( )
10 CONTINUE
CALL SSPTRF( UPLO, N, A, IWORK, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( MAT, N, N, A, LDA, 0, 0 )
GO TO 10
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
20 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( MAT, N, N, A, LDA, 0, 0 )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SSPTRF', N, N, 0, 0, 0 )
RESLTS( 1, IN, IUPLO, 1 ) = SMFLOP( OPS, TIME, INFO )
*
ELSE
IC = 0
CALL STIMMG( MAT, N, N, A, LDA, 0, 0 )
END IF
*
* Generate another matrix and factor it using SSPTRF so
* that the factored form can be used in timing the other
* routines.
*
IF( IC.NE.1 )
$ CALL SSPTRF( UPLO, N, A, IWORK, INFO )
*
* Time SSPTRI
*
IF( TIMSUB( 3 ) ) THEN
CALL SCOPY( LDA, A, 1, B, 1 )
IC = 0
S1 = SECOND( )
30 CONTINUE
CALL SSPTRI( UPLO, N, B, IWORK, WORK, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL SCOPY( LDA, A, 1, B, 1 )
GO TO 30
END IF
*
* Subtract the time used in SCOPY.
*
ICL = 1
S1 = SECOND( )
40 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL SCOPY( LDA, A, 1, B, 1 )
GO TO 40
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SSPTRI', N, N, 0, 0, 0 )
RESLTS( 1, IN, IUPLO, 3 ) = SMFLOP( OPS, TIME, INFO )
END IF
*
* Time SSPTRS
*
IF( TIMSUB( 2 ) ) THEN
DO 70 I = 1, NNS
NRHS = NSVAL( I )
LDB = N
IF( MOD( LDB, 2 ).EQ.0 )
$ LDB = LDB + 1
CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 )
IC = 0
S1 = SECOND( )
50 CONTINUE
CALL SSPTRS( UPLO, N, NRHS, A, IWORK, B, LDB, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 50
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
60 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 60
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SSPTRS', N, NRHS, 0, 0, 0 )
RESLTS( I, IN, IUPLO, 2 ) = SMFLOP( OPS, TIME, INFO )
70 CONTINUE
END IF
80 CONTINUE
90 CONTINUE
*
* Print tables of results for each timed routine.
*
DO 110 ISUB = 1, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 110
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
DO 100 IUPLO = 1, 2
WRITE( NOUT, FMT = 9997 )SUBNAM( ISUB ), UPLOS( IUPLO )
IF( ISUB.EQ.1 ) THEN
CALL SPRTBL( ' ', 'N', 1, LAVAL, NN, NVAL, 1,
$ RESLTS( 1, 1, IUPLO, 1 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.2 ) THEN
CALL SPRTBL( 'NRHS', 'N', NNS, NSVAL, NN, NVAL, 1,
$ RESLTS( 1, 1, IUPLO, 2 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.3 ) THEN
CALL SPRTBL( ' ', 'N', 1, LAVAL, NN, NVAL, 1,
$ RESLTS( 1, 1, IUPLO, 3 ), LDR1, LDR2, NOUT )
END IF
100 CONTINUE
110 CONTINUE
120 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***', / )
9997 FORMAT( 5X, A6, ' with UPLO = ''', A1, '''', / )
RETURN
*
* End of STIMSP
*
END
SUBROUTINE STIMSY( LINE, NN, NVAL, NNS, NSVAL, NNB, NBVAL, NLDA,
$ LDAVAL, TIMMIN, A, B, WORK, IWORK, RESLTS,
$ LDR1, LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NLDA, NN, NNB, NNS, NOUT
REAL TIMMIN
* ..
* .. Array Arguments ..
INTEGER IWORK( * ), LDAVAL( * ), NBVAL( * ),
$ NSVAL( * ), NVAL( * )
REAL A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* STIMSY times SSYTRF, -TRS, and -TRI.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix size N.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* NNB (input) INTEGER
* The number of values of NB contained in the vector NBVAL.
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) REAL
* The minimum time a subroutine will be timed.
*
* A (workspace) REAL array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values permitted
* for LDA and N.
*
* B (workspace) REAL array, dimension (LDAMAX*NMAX)
*
* WORK (workspace) REAL array, dimension (NMAX)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* RESLTS (output) REAL array, dimension
* (LDR1,LDR2,LDR3,NSUBS)
* The timing results for each subroutine over the relevant
* values of N, NB, and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(4,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NN).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,2*NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 3 )
* ..
* .. Local Scalars ..
CHARACTER UPLO
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, I3, IC, ICL, ILDA, IN, INB, INFO, ISUB,
$ IUPLO, LDA, LDB, LWORK, MAT, N, NB, NRHS
REAL OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER UPLOS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SECOND, SMFLOP, SOPLA
EXTERNAL LSAME, SECOND, SMFLOP, SOPLA
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, SLACPY, SPRTBL, SSYTRF, SSYTRI,
$ SSYTRS, STIMMG, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, REAL
* ..
* .. Data statements ..
DATA UPLOS / 'U', 'L' /
DATA SUBNAM / 'SSYTRF', 'SSYTRS', 'SSYTRI' /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'SY'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 150
*
* Check that N <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 2, CNAME, NN, NVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 150
END IF
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 110 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
IF( LSAME( UPLO, 'U' ) ) THEN
MAT = 6
ELSE
MAT = -6
END IF
*
* Do for each value of N in NVAL.
*
DO 100 IN = 1, NN
N = NVAL( IN )
*
* Do for each value of LDA:
*
DO 90 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
I3 = ( IUPLO-1 )*NLDA + ILDA
*
* Do for each value of NB in NBVAL. Only the blocked
* routines are timed in this loop since the other routines
* are independent of NB.
*
IF( TIMSUB( 1 ) ) THEN
*
* Time SSYTRF
*
DO 30 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
LWORK = MAX( 2*N, NB*N )
CALL STIMMG( MAT, N, N, A, LDA, 0, 0 )
IC = 0
S1 = SECOND( )
10 CONTINUE
CALL SSYTRF( UPLO, N, A, LDA, IWORK, B, LWORK,
$ INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( MAT, N, N, A, LDA, 0, 0 )
GO TO 10
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
20 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( MAT, N, N, B, LDA, 0, 0 )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SSYTRF', N, N, 0, 0, NB )
RESLTS( INB, IN, I3, 1 ) = SMFLOP( OPS, TIME,
$ INFO )
*
30 CONTINUE
ELSE
*
* If SSYTRF was not timed, generate a matrix and
* factor it using SSYTRF anyway so that the factored
* form of the matrix can be used in timing the other
* routines.
*
CALL STIMMG( MAT, N, N, A, LDA, 0, 0 )
NB = 1
CALL XLAENV( 1, NB )
CALL SSYTRF( UPLO, N, A, LDA, IWORK, B, LWORK, INFO )
END IF
*
* Time SSYTRI
*
IF( TIMSUB( 3 ) ) THEN
CALL SLACPY( UPLO, N, N, A, LDA, B, LDA )
IC = 0
S1 = SECOND( )
40 CONTINUE
CALL SSYTRI( UPLO, N, B, LDA, IWORK, WORK, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL SLACPY( UPLO, N, N, A, LDA, B, LDA )
GO TO 40
END IF
*
* Subtract the time used in SLACPY.
*
ICL = 1
S1 = SECOND( )
50 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL SLACPY( UPLO, N, N, A, LDA, B, LDA )
GO TO 50
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SSYTRI', N, N, 0, 0, 0 )
RESLTS( 1, IN, I3, 3 ) = SMFLOP( OPS, TIME, INFO )
END IF
*
* Time SSYTRS
*
IF( TIMSUB( 2 ) ) THEN
DO 80 I = 1, NNS
NRHS = NSVAL( I )
LDB = LDA
CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 )
IC = 0
S1 = SECOND( )
60 CONTINUE
CALL SSYTRS( UPLO, N, NRHS, A, LDA, IWORK, B, LDB,
$ INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 60
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
70 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 70
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SSYTRS', N, NRHS, 0, 0, 0 )
RESLTS( I, IN, I3, 2 ) = SMFLOP( OPS, TIME, INFO )
80 CONTINUE
END IF
90 CONTINUE
100 CONTINUE
110 CONTINUE
*
* Print tables of results for each timed routine.
*
DO 140 ISUB = 1, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 140
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 120 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
120 CONTINUE
END IF
WRITE( NOUT, FMT = * )
DO 130 IUPLO = 1, 2
WRITE( NOUT, FMT = 9996 )SUBNAM( ISUB ), UPLOS( IUPLO )
I3 = ( IUPLO-1 )*NLDA + 1
IF( ISUB.EQ.1 ) THEN
CALL SPRTBL( 'NB', 'N', NNB, NBVAL, NN, NVAL, NLDA,
$ RESLTS( 1, 1, I3, 1 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.2 ) THEN
CALL SPRTBL( 'NRHS', 'N', NNS, NSVAL, NN, NVAL, NLDA,
$ RESLTS( 1, 1, I3, 2 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.3 ) THEN
CALL SPRTBL( ' ', 'N', 1, NBVAL, NN, NVAL, NLDA,
$ RESLTS( 1, 1, I3, 3 ), LDR1, LDR2, NOUT )
END IF
130 CONTINUE
140 CONTINUE
*
150 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted' )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
9996 FORMAT( 5X, A6, ' with UPLO = ''', A1, '''', / )
RETURN
*
* End of STIMSY
*
END
SUBROUTINE STIMTB( LINE, NN, NVAL, NK, KVAL, NNS, NSVAL, NLDA,
$ LDAVAL, TIMMIN, A, B, RESLTS, LDR1, LDR2, LDR3,
$ NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NK, NLDA, NN, NNS, NOUT
REAL TIMMIN
* ..
* .. Array Arguments ..
INTEGER KVAL( * ), LDAVAL( * ), NSVAL( * ), NVAL( * )
REAL A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * )
* ..
*
* Purpose
* =======
*
* STIMTB times STBTRS.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix size N.
*
* NK (input) INTEGER
* The number of values of K contained in the vector KVAL.
*
* KVAL (input) INTEGER array, dimension (NK)
* The values of the band width K.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) REAL
* The minimum time a subroutine will be timed.
*
* A (workspace) REAL array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values permitted
* for LDA and N.
*
* B (workspace) REAL array, dimension (LDAMAX*NMAX)
*
* RESLTS (output) REAL array, dimension
* (LDR1,LDR2,LDR3,NSUBS)
* The timing results for each subroutine over the relevant
* values of N, NB, and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NN).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,2*NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 1 )
* ..
* .. Local Scalars ..
CHARACTER UPLO
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, I3, IC, ICL, IK, ILDA, IN, INFO, ISUB,
$ IUPLO, K, LDA, LDB, MAT, N, NRHS
REAL OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER UPLOS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SECOND, SMFLOP, SOPLA
EXTERNAL LSAME, SECOND, SMFLOP, SOPLA
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, SPRTBL, STBTRS, STIMMG
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Data statements ..
DATA SUBNAM / 'STBTRS' /
DATA UPLOS / 'U', 'L' /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'TB'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 110
*
* Check that K+1 <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 0, CNAME, NK, KVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 110
END IF
*
* Do for each value of N:
*
DO 100 IN = 1, NN
N = NVAL( IN )
LDB = N
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 60 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
IF( LSAME( UPLO, 'U' ) ) THEN
MAT = 11
ELSE
MAT = -11
END IF
*
* Do for each value of LDA:
*
DO 50 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
I3 = ( IUPLO-1 )*NLDA + ILDA
*
* Do for each value of the band width K:
*
DO 40 IK = 1, NK
K = KVAL( IK )
K = MAX( 0, MIN( K, N-1 ) )
*
* Time STBTRS
*
IF( TIMSUB( 1 ) ) THEN
CALL STIMMG( MAT, N, N, A, LDA, K, K )
DO 30 I = 1, NNS
NRHS = NSVAL( I )
CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 )
IC = 0
S1 = SECOND( )
10 CONTINUE
CALL STBTRS( UPLO, 'No transpose', 'Non-unit',
$ N, K, NRHS, A, LDA, B, LDB, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 10
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
20 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'STBTRS', N, NRHS, K, K, 0 )
RESLTS( I, IK, I3, 1 ) = SMFLOP( OPS, TIME,
$ INFO )
30 CONTINUE
END IF
40 CONTINUE
50 CONTINUE
60 CONTINUE
*
* Print a table of results.
*
DO 90 ISUB = 1, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 90
*
* Print header for routine names.
*
IF( IN.EQ.1 .OR. CNAME.EQ.'STB ' ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.EQ.1 ) THEN
WRITE( NOUT, FMT = 9997 )LDAVAL( 1 )
ELSE
DO 70 I = 1, NLDA
WRITE( NOUT, FMT = 9996 )I, LDAVAL( I )
70 CONTINUE
END IF
END IF
*
DO 80 IUPLO = 1, 2
WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ), N,
$ UPLOS( IUPLO )
I3 = ( IUPLO-1 )*NLDA + 1
IF( ISUB.EQ.1 ) THEN
CALL SPRTBL( 'NRHS', 'K', NNS, NSVAL, NK, KVAL, NLDA,
$ RESLTS( 1, 1, I3, 1 ), LDR1, LDR2, NOUT )
END IF
80 CONTINUE
90 CONTINUE
100 CONTINUE
*
110 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'with LDA = ', I5 )
9996 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
9995 FORMAT( / 5X, A6, ' with M =', I6, ', UPLO = ''', A1, '''', / )
RETURN
*
* End of STIMTB
*
END
SUBROUTINE STIMTD( LINE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
$ NLDA, LDAVAL, TIMMIN, A, B, D, TAU, WORK,
$ RESLTS, LDR1, LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NLDA, NM, NN, NNB, NOUT
REAL TIMMIN
* ..
* .. Array Arguments ..
INTEGER LDAVAL( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
$ NXVAL( * )
REAL A( * ), B( * ), D( * ),
$ RESLTS( LDR1, LDR2, LDR3, * ), TAU( * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* STIMTD times the LAPACK routines SSYTRD, SORGTR, and SORMTR and the
* EISPACK routine TRED1.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix size M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) REAL
* The minimum time a subroutine will be timed.
*
* A (workspace) REAL array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values of LDA and N.
*
* B (workspace) REAL array, dimension (LDAMAX*NMAX)
*
* D (workspace) REAL array, dimension (2*NMAX-1)
*
* TAU (workspace) REAL array, dimension (NMAX)
*
* WORK (workspace) REAL array, dimension (NMAX*NBMAX)
* where NBMAX is the maximum value of NB.
*
* RESLTS (workspace) REAL array, dimension
* (LDR1,LDR2,LDR3,4*NN+3)
* The timing results for each subroutine over the relevant
* values of M, (NB,NX), LDA, and N.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NM).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,2*NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* Internal Parameters
* ===================
*
* MODE INTEGER
* The matrix type. MODE = 3 is a geometric distribution of
* eigenvalues. See SLATMS for further details.
*
* COND REAL
* The condition number of the matrix. The singular values are
* set to values from DMAX to DMAX/COND.
*
* DMAX REAL
* The magnitude of the largest singular value.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 4 )
INTEGER MODE
REAL COND, DMAX
PARAMETER ( MODE = 3, COND = 100.0E0, DMAX = 1.0E0 )
* ..
* .. Local Scalars ..
CHARACTER LAB1, LAB2, SIDE, TRANS, UPLO
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, I3, I4, IC, ICL, ILDA, IM, IN, INB, INFO,
$ ISIDE, ISUB, ITOFF, ITRAN, IUPLO, LDA, LW, M,
$ M1, N, N1, NB, NX
REAL OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER SIDES( 2 ), TRANSS( 2 ), UPLOS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER ISEED( 4 ), RESEED( 4 )
* ..
* .. External Functions ..
REAL SECOND, SMFLOP, SOPLA
EXTERNAL SECOND, SMFLOP, SOPLA
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, ICOPY, SLACPY, SLATMS, SORGTR,
$ SORMTR, SPRTB3, SPRTBL, SSYTRD, STIMMG, TRED1,
$ XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, REAL
* ..
* .. Data statements ..
DATA SUBNAM / 'SSYTRD', 'TRED1', 'SORGTR',
$ 'SORMTR' /
DATA SIDES / 'L', 'R' / , TRANSS / 'N', 'T' / ,
$ UPLOS / 'U', 'L' /
DATA ISEED / 0, 0, 0, 1 /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'TD'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 240
*
* Check that M <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 2, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 240
END IF
*
* Check that K <= LDA for SORMTR
*
IF( TIMSUB( 4 ) ) THEN
CALL ATIMCK( 3, CNAME, NN, NVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )SUBNAM( 4 )
TIMSUB( 4 ) = .FALSE.
END IF
END IF
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 150 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
*
* Do for each value of M:
*
DO 140 IM = 1, NM
M = MVAL( IM )
CALL ICOPY( 4, ISEED, 1, RESEED, 1 )
*
* Do for each value of LDA:
*
DO 130 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
I3 = ( IUPLO-1 )*NLDA + ILDA
*
* Do for each pair of values (NB, NX) in NBVAL and NXVAL.
*
DO 120 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
LW = MAX( 1, M*MAX( 1, NB ) )
*
* Generate a test matrix of order M.
*
CALL ICOPY( 4, RESEED, 1, ISEED, 1 )
CALL SLATMS( M, M, 'Uniform', ISEED, 'Symmetric', TAU,
$ MODE, COND, DMAX, M, M, 'No packing', B,
$ LDA, WORK, INFO )
*
IF( TIMSUB( 2 ) .AND. INB.EQ.1 .AND. IUPLO.EQ.2 ) THEN
*
* TRED1: Eispack reduction using orthogonal
* transformations.
*
CALL SLACPY( UPLO, M, M, B, LDA, A, LDA )
IC = 0
S1 = SECOND( )
10 CONTINUE
CALL TRED1( LDA, M, A, D, D( M+1 ), D( M+1 ) )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL SLACPY( UPLO, M, M, B, LDA, A, LDA )
GO TO 10
END IF
*
* Subtract the time used in SLACPY.
*
ICL = 1
S1 = SECOND( )
20 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL SLACPY( UPLO, M, M, B, LDA, A, LDA )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SSYTRD', M, M, -1, -1, NB )
RESLTS( INB, IM, ILDA, 2 ) = SMFLOP( OPS, TIME,
$ INFO )
END IF
*
IF( TIMSUB( 1 ) ) THEN
*
* SSYTRD: Reduction to tridiagonal form
*
CALL SLACPY( UPLO, M, M, B, LDA, A, LDA )
IC = 0
S1 = SECOND( )
30 CONTINUE
CALL SSYTRD( UPLO, M, A, LDA, D, D( M+1 ), TAU,
$ WORK, LW, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL SLACPY( UPLO, M, M, B, LDA, A, LDA )
GO TO 30
END IF
*
* Subtract the time used in SLACPY.
*
ICL = 1
S1 = SECOND( )
40 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL SLACPY( UPLO, M, M, A, LDA, B, LDA )
GO TO 40
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'SSYTRD', M, M, -1, -1, NB )
RESLTS( INB, IM, I3, 1 ) = SMFLOP( OPS, TIME,
$ INFO )
ELSE
*
* If SSYTRD was not timed, generate a matrix and
* factor it using SSYTRD anyway so that the factored
* form of the matrix can be used in timing the other
* routines.
*
CALL SLACPY( UPLO, M, M, B, LDA, A, LDA )
CALL SSYTRD( UPLO, M, A, LDA, D, D( M+1 ), TAU,
$ WORK, LW, INFO )
END IF
*
IF( TIMSUB( 3 ) ) THEN
*
* SORGTR: Generate the orthogonal matrix Q from the
* reduction to Hessenberg form A = Q*H*Q'
*
CALL SLACPY( UPLO, M, M, A, LDA, B, LDA )
IC = 0
S1 = SECOND( )
50 CONTINUE
CALL SORGTR( UPLO, M, B, LDA, TAU, WORK, LW, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL SLACPY( UPLO, M, M, A, LDA, B, LDA )
GO TO 50
END IF
*
* Subtract the time used in SLACPY.
*
ICL = 1
S1 = SECOND( )
60 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL SLACPY( UPLO, M, M, A, LDA, B, LDA )
GO TO 60
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
*
* Op count for SORGTR: same as
* SORGQR( N-1, N-1, N-1, ... )
*
OPS = SOPLA( 'SORGQR', M-1, M-1, M-1, -1, NB )
RESLTS( INB, IM, I3, 3 ) = SMFLOP( OPS, TIME,
$ INFO )
END IF
*
IF( TIMSUB( 4 ) ) THEN
*
* SORMTR: Multiply by Q stored as a product of
* elementary transformations
*
I4 = 3
DO 110 ISIDE = 1, 2
SIDE = SIDES( ISIDE )
DO 100 IN = 1, NN
N = NVAL( IN )
LW = MAX( 1, MAX( 1, NB )*N )
IF( ISIDE.EQ.1 ) THEN
M1 = M
N1 = N
ELSE
M1 = N
N1 = M
END IF
ITOFF = 0
DO 90 ITRAN = 1, 2
TRANS = TRANSS( ITRAN )
CALL STIMMG( 0, M1, N1, B, LDA, 0, 0 )
IC = 0
S1 = SECOND( )
70 CONTINUE
CALL SORMTR( SIDE, UPLO, TRANS, M1, N1, A,
$ LDA, TAU, B, LDA, WORK, LW,
$ INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, M1, N1, B, LDA, 0, 0 )
GO TO 70
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
80 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, M1, N1, B, LDA, 0, 0 )
GO TO 80
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
*
* Op count for SORMTR, SIDE='L': same as
* SORMQR( 'L', TRANS, M-1, N, M-1, ...)
*
* Op count for SORMTR, SIDE='R': same as
* SORMQR( 'R', TRANS, M, N-1, N-1, ...)
*
IF( ISIDE.EQ.1 ) THEN
OPS = SOPLA( 'SORMQR', M1-1, N1, M1-1,
$ -1, NB )
ELSE
OPS = SOPLA( 'SORMQR', M1, N1-1, N1-1,
$ 1, NB )
END IF
*
RESLTS( INB, IM, I3,
$ I4+ITOFF+IN ) = SMFLOP( OPS, TIME,
$ INFO )
ITOFF = NN
90 CONTINUE
100 CONTINUE
I4 = I4 + 2*NN
110 CONTINUE
END IF
*
120 CONTINUE
130 CONTINUE
140 CONTINUE
150 CONTINUE
*
* Print tables of results for SSYTRD, TRED1, and SORGTR
*
DO 180 ISUB = 1, NSUBS - 1
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 180
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 160 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
160 CONTINUE
END IF
IF( ISUB.EQ.2 ) THEN
WRITE( NOUT, FMT = * )
CALL SPRTB3( ' ', 'N', 1, NBVAL, NXVAL, NM, MVAL, NLDA,
$ RESLTS( 1, 1, 1, ISUB ), LDR1, LDR2, NOUT )
ELSE
I3 = 1
DO 170 IUPLO = 1, 2
WRITE( NOUT, FMT = 9996 )SUBNAM( ISUB ), UPLOS( IUPLO )
CALL SPRTB3( '( NB, NX)', 'N', NNB, NBVAL, NXVAL, NM,
$ MVAL, NLDA, RESLTS( 1, 1, I3, ISUB ), LDR1,
$ LDR2, NOUT )
I3 = I3 + NLDA
170 CONTINUE
END IF
180 CONTINUE
*
* Print tables of results for SORMTR
*
ISUB = 4
IF( TIMSUB( ISUB ) ) THEN
I4 = 3
DO 230 ISIDE = 1, 2
IF( ISIDE.EQ.1 ) THEN
LAB1 = 'M'
LAB2 = 'N'
IF( NLDA.GT.1 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
DO 190 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
190 CONTINUE
END IF
ELSE
LAB1 = 'N'
LAB2 = 'M'
END IF
DO 220 ITRAN = 1, 2
DO 210 IN = 1, NN
I3 = 1
DO 200 IUPLO = 1, 2
WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ),
$ SIDES( ISIDE ), UPLOS( IUPLO ), TRANSS( ITRAN ),
$ LAB2, NVAL( IN )
CALL SPRTBL( 'NB', LAB1, NNB, NBVAL, NM, MVAL,
$ NLDA, RESLTS( 1, 1, I3, I4+IN ), LDR1,
$ LDR2, NOUT )
I3 = I3 + NLDA
200 CONTINUE
210 CONTINUE
I4 = I4 + NN
220 CONTINUE
230 CONTINUE
END IF
240 CONTINUE
*
* Print a table of results for each timed routine.
*
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops *** ' )
9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
9996 FORMAT( / 5X, A6, ' with UPLO = ''', A1, '''', / )
9995 FORMAT( / 5X, A6, ' with SIDE = ''', A1, ''', UPLO = ''', A1,
$ ''', TRANS = ''', A1, ''', ', A1, ' =', I6, / )
RETURN
*
* End of STIMTD
*
END
SUBROUTINE STIMTP( LINE, NN, NVAL, NNS, NSVAL, LA, TIMMIN, A, B,
$ RESLTS, LDR1, LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LA, LDR1, LDR2, LDR3, NN, NNS, NOUT
REAL TIMMIN
* ..
* .. Array Arguments ..
INTEGER NSVAL( * ), NVAL( * )
REAL A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * )
* ..
*
* Purpose
* =======
*
* STIMTP times STPTRI and -TRS.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix size N.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* LA (input) INTEGER
* The size of the arrays A and B.
*
* TIMMIN (input) REAL
* The minimum time a subroutine will be timed.
*
* A (workspace) REAL array, dimension (LA)
*
* B (workspace) REAL array, dimension (NMAX*NMAX)
* where NMAX is the maximum value of N in NVAL.
*
* RESLTS (output) REAL array, dimension
* (LDR1,LDR2,LDR3,NSUBS)
* The timing results for each subroutine over the relevant
* values of N.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= 1.
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NN).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= 2.
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 2 )
* ..
* .. Local Scalars ..
CHARACTER UPLO
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, IC, ICL, IN, INFO, ISUB, IUPLO, LDA, LDB,
$ MAT, N, NRHS
REAL OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER UPLOS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER IDUMMY( 1 ), LAVAL( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SECOND, SMFLOP, SOPLA
EXTERNAL LSAME, SECOND, SMFLOP, SOPLA
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, SPRTBL, STIMMG, STPTRI, STPTRS
* ..
* .. Intrinsic Functions ..
INTRINSIC MOD, REAL
* ..
* .. Data statements ..
DATA SUBNAM / 'STPTRI', 'STPTRS' /
DATA UPLOS / 'U', 'L' /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'TP'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 100
*
* Check that N*(N+1)/2 <= LA for the input values.
*
CNAME = LINE( 1: 6 )
LAVAL( 1 ) = LA
CALL ATIMCK( 4, CNAME, NN, NVAL, 1, LAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 100
END IF
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 70 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
IF( LSAME( UPLO, 'U' ) ) THEN
MAT = 10
ELSE
MAT = -10
END IF
*
* Do for each value of N:
*
DO 60 IN = 1, NN
N = NVAL( IN )
LDA = N*( N+1 ) / 2
LDB = N
IF( MOD( N, 2 ).EQ.0 )
$ LDB = LDB + 1
*
* Time STPTRI
*
IF( TIMSUB( 1 ) ) THEN
CALL STIMMG( MAT, N, N, A, LDA, 0, 0 )
IC = 0
S1 = SECOND( )
10 CONTINUE
CALL STPTRI( UPLO, 'Non-unit', N, A, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( MAT, N, N, A, LDA, 0, 0 )
GO TO 10
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
20 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( MAT, N, N, A, LDA, 0, 0 )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'STPTRI', N, N, 0, 0, 0 )
RESLTS( 1, IN, IUPLO, 1 ) = SMFLOP( OPS, TIME, INFO )
ELSE
*
* Generate a triangular matrix A.
*
CALL STIMMG( MAT, N, N, A, LDA, 0, 0 )
END IF
*
* Time STPTRS
*
IF( TIMSUB( 2 ) ) THEN
DO 50 I = 1, NNS
NRHS = NSVAL( I )
CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 )
IC = 0
S1 = SECOND( )
30 CONTINUE
CALL STPTRS( UPLO, 'No transpose', 'Non-unit', N,
$ NRHS, A, B, LDB, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 30
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
40 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 40
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'STPTRS', N, NRHS, 0, 0, 0 )
RESLTS( I, IN, IUPLO, 2 ) = SMFLOP( OPS, TIME, INFO )
50 CONTINUE
END IF
60 CONTINUE
70 CONTINUE
*
* Print a table of results.
*
DO 90 ISUB = 1, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 90
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
DO 80 IUPLO = 1, 2
WRITE( NOUT, FMT = 9997 )SUBNAM( ISUB ), UPLOS( IUPLO )
IF( ISUB.EQ.1 ) THEN
CALL SPRTBL( ' ', 'N', 1, IDUMMY, NN, NVAL, 1,
$ RESLTS( 1, 1, IUPLO, 1 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.2 ) THEN
CALL SPRTBL( 'NRHS', 'N', NNS, NSVAL, NN, NVAL, 1,
$ RESLTS( 1, 1, IUPLO, 2 ), LDR1, LDR2, NOUT )
END IF
80 CONTINUE
90 CONTINUE
*
100 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***', / )
9997 FORMAT( 5X, A6, ' with UPLO = ''', A1, '''', / )
RETURN
*
* End of STIMTP
*
END
SUBROUTINE STIMTR( LINE, NN, NVAL, NNS, NSVAL, NNB, NBVAL, NLDA,
$ LDAVAL, TIMMIN, A, B, RESLTS, LDR1, LDR2, LDR3,
$ NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NLDA, NN, NNB, NNS, NOUT
REAL TIMMIN
* ..
* .. Array Arguments ..
INTEGER LDAVAL( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
REAL A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * )
* ..
*
* Purpose
* =======
*
* STIMTR times STRTRI and -TRS.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix size N.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* NNB (input) INTEGER
* The number of values of NB contained in the vector NBVAL.
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) REAL
* The minimum time a subroutine will be timed.
*
* A (workspace) REAL array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values permitted
* for LDA and N.
*
* B (workspace) REAL array, dimension (LDAMAX*NMAX)
*
* RESLTS (output) REAL array, dimension
* (LDR1,LDR2,LDR3,NSUBS)
* The timing results for each subroutine over the relevant
* values of N, NB, and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NN).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,2*NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 2 )
* ..
* .. Local Scalars ..
CHARACTER UPLO
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, I3, IC, ICL, ILDA, IN, INB, INFO, ISUB,
$ IUPLO, LDA, LDB, MAT, N, NB, NRHS
REAL OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER UPLOS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SECOND, SMFLOP, SOPLA
EXTERNAL LSAME, SECOND, SMFLOP, SOPLA
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, SPRTBL, STIMMG, STRTRI, STRTRS,
$ XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. Data statements ..
DATA SUBNAM / 'STRTRI', 'STRTRS' /
DATA UPLOS / 'U', 'L' /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'TR'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 130
*
* Check that N <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 2, CNAME, NN, NVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 130
END IF
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 90 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
IF( LSAME( UPLO, 'U' ) ) THEN
MAT = 9
ELSE
MAT = -9
END IF
*
* Do for each value of N:
*
DO 80 IN = 1, NN
N = NVAL( IN )
*
* Do for each value of LDA:
*
DO 70 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
I3 = ( IUPLO-1 )*NLDA + ILDA
*
* Do for each value of NB in NBVAL. Only the blocked
* routines are timed in this loop since the other routines
* are independent of NB.
*
IF( TIMSUB( 1 ) ) THEN
DO 30 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
*
* Time STRTRI
*
CALL STIMMG( MAT, N, N, A, LDA, 0, 0 )
IC = 0
S1 = SECOND( )
10 CONTINUE
CALL STRTRI( UPLO, 'Non-unit', N, A, LDA, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( MAT, N, N, A, LDA, 0, 0 )
GO TO 10
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
20 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( MAT, N, N, A, LDA, 0, 0 )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'STRTRI', N, N, 0, 0, NB )
RESLTS( INB, IN, I3, 1 ) = SMFLOP( OPS, TIME,
$ INFO )
30 CONTINUE
ELSE
*
* Generate a triangular matrix A.
*
CALL STIMMG( MAT, N, N, A, LDA, 0, 0 )
END IF
*
* Time STRTRS
*
IF( TIMSUB( 2 ) ) THEN
DO 60 I = 1, NNS
NRHS = NSVAL( I )
LDB = LDA
CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 )
IC = 0
S1 = SECOND( )
40 CONTINUE
CALL STRTRS( UPLO, 'No transpose', 'Non-unit', N,
$ NRHS, A, LDA, B, LDB, INFO )
S2 = SECOND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 40
END IF
*
* Subtract the time used in STIMMG.
*
ICL = 1
S1 = SECOND( )
50 CONTINUE
S2 = SECOND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL STIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 50
END IF
*
TIME = ( TIME-UNTIME ) / REAL( IC )
OPS = SOPLA( 'STRTRS', N, NRHS, 0, 0, 0 )
RESLTS( I, IN, I3, 2 ) = SMFLOP( OPS, TIME, INFO )
60 CONTINUE
END IF
70 CONTINUE
80 CONTINUE
90 CONTINUE
*
* Print a table of results.
*
DO 120 ISUB = 1, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 120
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 100 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
100 CONTINUE
END IF
WRITE( NOUT, FMT = * )
DO 110 IUPLO = 1, 2
WRITE( NOUT, FMT = 9996 )SUBNAM( ISUB ), UPLOS( IUPLO )
I3 = ( IUPLO-1 )*NLDA + 1
IF( ISUB.EQ.1 ) THEN
CALL SPRTBL( 'NB', 'N', NNB, NBVAL, NN, NVAL, NLDA,
$ RESLTS( 1, 1, I3, 1 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.2 ) THEN
CALL SPRTBL( 'NRHS', 'N', NNS, NSVAL, NN, NVAL, NLDA,
$ RESLTS( 1, 1, I3, 2 ), LDR1, LDR2, NOUT )
END IF
110 CONTINUE
120 CONTINUE
*
130 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
9996 FORMAT( 5X, A6, ' with UPLO = ''', A1, '''', / )
RETURN
*
* End of STIMTR
*
END
SUBROUTINE ICOPY( N, SX, INCX, SY, INCY )
*
* -- LAPACK auxiliary test routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
INTEGER INCX, INCY, N
* ..
* .. Array Arguments ..
INTEGER SX( * ), SY( * )
* ..
*
* Purpose
* =======
*
* ICOPY copies an integer vector x to an integer vector y.
* Uses unrolled loops for increments equal to 1.
*
* Arguments
* =========
*
* N (input) INTEGER
* The length of the vectors SX and SY.
*
* SX (input) INTEGER array, dimension (1+(N-1)*abs(INCX))
* The vector X.
*
* INCX (input) INTEGER
* The spacing between consecutive elements of SX.
*
* SY (output) INTEGER array, dimension (1+(N-1)*abs(INCY))
* The vector Y.
*
* INCY (input) INTEGER
* The spacing between consecutive elements of SY.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, IX, IY, M, MP1
* ..
* .. Intrinsic Functions ..
INTRINSIC MOD
* ..
* .. Executable Statements ..
*
IF( N.LE.0 )
$ RETURN
IF( INCX.EQ.1 .AND. INCY.EQ.1 )
$ GO TO 20
*
* 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 10 I = 1, N
SY( IY ) = SX( IX )
IX = IX + INCX
IY = IY + INCY
10 CONTINUE
RETURN
*
* Code for both increments equal to 1
*
* Clean-up loop
*
20 CONTINUE
M = MOD( N, 7 )
IF( M.EQ.0 )
$ GO TO 40
DO 30 I = 1, M
SY( I ) = SX( I )
30 CONTINUE
IF( N.LT.7 )
$ RETURN
40 CONTINUE
MP1 = M + 1
DO 50 I = MP1, N, 7
SY( I ) = SX( I )
SY( I+1 ) = SX( I+1 )
SY( I+2 ) = SX( I+2 )
SY( I+3 ) = SX( I+3 )
SY( I+4 ) = SX( I+4 )
SY( I+5 ) = SX( I+5 )
SY( I+6 ) = SX( I+6 )
50 CONTINUE
RETURN
*
* End of ICOPY
*
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/slin/sband.in 0000644 0001750 0001750 00000001434 10616163245 023420 0 ustar osallou osallou LAPACK timing, REAL band matrices
1 Number of values of M
200 Values of M (row dimension)
5 Number of values of K
10 20 30 40 50 Values of K (bandwidth)
4 Number of values of NRHS
1 2 4 8 Values of NRHS
2 Number of values of NB
1 8 Values of NB (blocksize)
0 8 Values of NX (crossover point)
1 Number of values of LDA
152 Values of LDA (leading dimension)
0.05 Minimum time in seconds
BAND Time sample banded BLAS
SGB
SPB
STB
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/slin/stime.in 0000644 0001750 0001750 00000001654 10616163245 023456 0 ustar osallou osallou LAPACK timing, REAL square matrices
5 Number of values of M
10 20 40 60 80 Values of M (row dimension)
5 Number of values of N
10 20 40 60 80 Values of N (column dimension)
2 Number of values of K
20 80 Values of K
2 Number of values of NB
1 8 Values of NB (blocksize)
0 8 Values of NX (crossover point)
1 Number of values of LDA
81 Values of LDA (leading dimension)
0.05 Minimum time in seconds
SGE T T T
SPO T T T
SPP T T T
SSY T T T
SSP T T T
STR T T
STP T T
SQR T T T
SLQ T T T
SQL T T T
SRQ T T T
SQP T
SHR T T T T
STD T T T T
SBR T T T
SLS T T T T T T
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/slin/stime2.in 0000644 0001750 0001750 00000001456 10616163245 023540 0 ustar osallou osallou LAPACK timing, REAL rectangular matrices
7 Number of values of M
20 40 20 40 80 40 80 Values of M (row dimension)
7 Number of values of N
20 20 40 40 40 80 80 Values of N (column dimension)
2 Number of values of K
20 80 Values of K
2 Number of values of NB
1 8 Values of NB (blocksize)
0 8 Values of NX (crossover point)
1 Number of values of LDA
81 Values of LDA (leading dimension)
0.05 Minimum time in seconds
none
SQR T T T
SLQ T T T
SQL T T T
SRQ T T T
SQP T
SBR T T F
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/slin/sblasa.in 0000644 0001750 0001750 00000001125 10616163245 023573 0 ustar osallou osallou BLAS timing, REAL data, K small
5 Number of values of M
10 20 40 60 80 Values of M
5 Number of values of N
10 20 40 60 80 Values of N
2 Number of values of K
2 16 Values of K
1 Number of values of INCX
1 Values of INCX
1 Number of values of LDA
81 Values of LDA
0.05 Minimum time in seconds
none Do not time the sample BLAS
SB2
SB3
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/slin/input_files_large/ 0000755 0001750 0001750 00000000000 11734055026 025471 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/slin/input_files_large/SBLASA.in 0000644 0001750 0001750 00000001125 10616163245 026766 0 ustar osallou osallou BLAS timing, REAL data, K small
6 Number of values of M
50 100 200 300 400 500 Values of M
6 Number of values of N
50 100 200 300 400 500 Values of N
5 Number of values of K
2 16 32 48 64 Values of K
1 Number of values of INCX
1 Values of INCX
1 Number of values of LDA
513 Values of LDA
0.0 Minimum time in seconds
none Do not time the sample BLAS
SB2
SB3
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/slin/input_files_large/SBLASB.in 0000644 0001750 0001750 00000001144 10616163245 026770 0 ustar osallou osallou BLAS timing, REAL data, M small
5 Number of values of M
2 16 32 48 64 Values of M
6 Number of values of N
50 100 200 300 400 500 Values of N
6 Number of values of K
50 100 200 300 400 500 Values of K
1 Number of values of INCX
1 Values of INCX
1 Number of values of LDA
513 Values of LDA
0.0 Minimum time in seconds
none Do not time the sample BLAS
SGEMM
SSYMM
STRMM
STRSM
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/slin/input_files_large/SBLASC.in 0000644 0001750 0001750 00000001144 10616163245 026771 0 ustar osallou osallou BLAS timing, REAL data, N small
6 Number of values of M
50 100 200 300 400 500 Values of M
5 Number of values of N
2 16 32 48 64 Values of N
6 Number of values of K
50 100 200 300 400 500 Values of K
1 Number of values of INCX
1 Values of INCX
1 Number of values of LDA
513 Values of LDA
0.0 Minimum time in seconds
none Do not time the sample BLAS
SGEMM
SSYMM
STRMM
STRSM
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/slin/input_files_large/SBAND.in 0000644 0001750 0001750 00000001434 10616163245 026653 0 ustar osallou osallou LAPACK timing, REAL band matrices
1 Number of values of M
1000 Values of M (row dimension)
5 Number of values of K
25 50 100 150 200 Values of K (bandwidth)
4 Number of values of NRHS
1 2 16 100 Values of NRHS
5 Number of values of NB
1 16 32 48 64 Values of NB (blocksize)
0 48 128 128 128 Values of NX (crossover point)
1 Number of values of LDA
602 Values of LDA (leading dimension)
0.0 Minimum time in seconds
BAND Time sample banded BLAS
SGB
SPB
STB
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/slin/input_files_large/STIME.in 0000644 0001750 0001750 00000001706 10616163245 026707 0 ustar osallou osallou LAPACK timing, REAL square matrices
6 Number of values of M
50 100 200 300 400 500 Values of M (row dimension)
6 Number of values of N
50 100 200 300 400 500 Values of N (column dimension)
4 Number of values of K
1 2 16 100 Values of K
5 Number of values of NB
1 16 32 48 64 Values of NB (blocksize)
0 48 128 128 128 Values of NX (crossover point)
1 Number of values of LDA
513 Values of LDA (leading dimension)
0.0 Minimum time in seconds
SGE T T T
SGT T T T
SPO T T T
SPP T T T
SPT T T T
SSY T T T
SSP T T T
STR T T
STP T T
SQR T T T
SLQ T T T
SQL T T T
SRQ T T T
SQP T
SHR T T T T
STD T T T T
SBR T T T
SLS T T T T T T
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/slin/input_files_large/STIME2.in 0000644 0001750 0001750 00000001456 10616163245 026773 0 ustar osallou osallou LAPACK timing, REAL rectangular matrices
7 Number of values of M
100 200 100 200 400 200 400 Values of M (row dimension)
7 Number of values of N
100 100 200 200 200 400 400 Values of N (column dimension)
4 Number of values of K
1 2 16 100 Values of K
5 Number of values of NB
1 16 32 48 64 Values of NB (blocksize)
0 48 128 128 128 Values of NX (crossover point)
1 Number of values of LDA
401 Values of LDA (leading dimension)
0.0 Minimum time in seconds
none
SQR T T T
SLQ T T T
SQL T T T
SRQ T T T
SQP T
SBR T T F
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/slin/sblasb.in 0000644 0001750 0001750 00000001144 10616163245 023575 0 ustar osallou osallou BLAS timing, REAL data, M small
2 Number of values of M
2 16 Values of M
5 Number of values of N
10 20 40 60 80 Values of N
5 Number of values of K
10 20 40 60 80 Values of K
1 Number of values of INCX
1 Values of INCX
1 Number of values of LDA
81 Values of LDA
0.05 Minimum time in seconds
none Do not time the sample BLAS
SGEMM
SSYMM
STRMM
STRSM
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/lin/ 0000755 0001750 0001750 00000000000 11734055026 021613 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/lin/dblasc.in 0000644 0001750 0001750 00000001160 10616163243 023370 0 ustar osallou osallou BLAS timing, DOUBLE PRECISION data, N small
5 Number of values of M
10 20 40 60 80 Values of M
2 Number of values of N
2 16 Values of N
5 Number of values of K
10 20 40 60 80 Values of K
1 Number of values of INCX
1 Values of INCX
1 Number of values of LDA
81 Values of LDA
0.05 Minimum time in seconds
none Do not time the sample BLAS
DGEMM
DSYMM
DTRMM
DTRSM
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/lin/dblasb.in 0000644 0001750 0001750 00000001160 10616163243 023367 0 ustar osallou osallou BLAS timing, DOUBLE PRECISION data, M small
2 Number of values of M
2 16 Values of M
5 Number of values of N
10 20 40 60 80 Values of N
5 Number of values of K
10 20 40 60 80 Values of K
1 Number of values of INCX
1 Values of INCX
1 Number of values of LDA
81 Values of LDA
0.05 Minimum time in seconds
none Do not time the sample BLAS
DGEMM
DSYMM
DTRMM
DTRSM
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/lin/linsrc/ 0000755 0001750 0001750 00000000000 11734055026 023105 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/lin/linsrc/linsrc.f 0000644 0001750 0001750 00000572033 10616163244 024560 0 ustar osallou osallou SUBROUTINE DGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK,
$ INFO )
*
* -- LAPACK driver routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * )
* ..
* Common block to return operation count.
* .. Common blocks ..
COMMON / LSTIME / OPCNT, TIMNG
* ..
* .. Arrays in Common ..
DOUBLE PRECISION OPCNT( 6 ), TIMNG( 6 )
* ..
*
* Purpose
* =======
*
* DGELS solves overdetermined or underdetermined real linear systems
* involving an M-by-N matrix A, or its transpose, using a QR or LQ
* factorization of A. It is assumed that A has full rank.
*
* The following options are provided:
*
* 1. If TRANS = 'N' and m >= n: find the least squares solution of
* an overdetermined system, i.e., solve the least squares problem
* minimize || B - A*X ||.
*
* 2. If TRANS = 'N' and m < n: find the minimum norm solution of
* an underdetermined system A * X = B.
*
* 3. If TRANS = 'T' and m >= n: find the minimum norm solution of
* an undetermined system A**T * X = B.
*
* 4. If TRANS = 'T' and m < n: find the least squares solution of
* an overdetermined system, i.e., solve the least squares problem
* minimize || B - A**T * X ||.
*
* Several right hand side vectors b and solution vectors x can be
* handled in a single call; they are stored as the columns of the
* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
* matrix X.
*
* Arguments
* =========
*
* TRANS (input) CHARACTER
* = 'N': the linear system involves A;
* = 'T': the linear system involves A**T.
*
* 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.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of
* columns of the matrices B and X. NRHS >=0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit,
* if M >= N, A is overwritten by details of its QR
* factorization as returned by DGEQRF;
* if M < N, A is overwritten by details of its LQ
* factorization as returned by DGELQF.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the matrix B of right hand side vectors, stored
* columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS
* if TRANS = 'T'.
* On exit, B is overwritten by the solution vectors, stored
* columnwise:
* if TRANS = 'N' and m >= n, rows 1 to n of B contain the least
* squares solution vectors; the residual sum of squares for the
* solution in each column is given by the sum of squares of
* elements N+1 to M in that column;
* if TRANS = 'N' and m < n, rows 1 to N of B contain the
* minimum norm solution vectors;
* if TRANS = 'T' and m >= n, rows 1 to M of B contain the
* minimum norm solution vectors;
* if TRANS = 'T' and m < n, rows 1 to M of B contain the
* least squares solution vectors; the residual sum of squares
* for the solution in each column is given by the sum of
* squares of elements M+1 to N in that column.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= MAX(1,M,N).
*
* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* LWORK >= max( 1, MN + max( MN, NRHS ) ).
* For optimal performance,
* LWORK >= max( 1, MN + max( MN, NRHS )*NB ).
* where MN = min(M,N) and NB is the optimum block size.
*
* 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 ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, TPSD
INTEGER BROW, GELQF, GELS, GEQRF, I, IASCL, IBSCL, J,
$ MN, NB, ORMLQ, ORMQR, SCLLEN, TRSM, WSIZE
DOUBLE PRECISION ANRM, BIGNUM, BNRM, SMLNUM, T1, T2
* ..
* .. Local Arrays ..
DOUBLE PRECISION RWORK( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANGE, DOPBL3, DOPLA, DSECND
EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE, DOPBL3, DOPLA,
$ DSECND
* ..
* .. External Subroutines ..
EXTERNAL DGELQF, DGEQRF, DLABAD, DLASCL, DLASET, DORMLQ,
$ DORMQR, DTRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Data statements ..
DATA GELQF / 2 / , GELS / 1 / , GEQRF / 2 / ,
$ ORMLQ / 3 / , ORMQR / 3 / , TRSM / 4 /
* ..
* .. Executable Statements ..
*
* Test the input arguments.
*
INFO = 0
MN = MIN( M, N )
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.( LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'T' ) ) ) THEN
INFO = -1
ELSE IF( M.LT.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -6
ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
INFO = -8
ELSE IF( LWORK.LT.MAX( 1, MN+MAX( MN, NRHS ) ) .AND. .NOT.LQUERY )
$ THEN
INFO = -10
END IF
*
* Figure out optimal block size
*
IF( INFO.EQ.0 .OR. INFO.EQ.-10 ) THEN
*
TPSD = .TRUE.
IF( LSAME( TRANS, 'N' ) )
$ TPSD = .FALSE.
*
IF( M.GE.N ) THEN
NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
IF( TPSD ) THEN
NB = MAX( NB, ILAENV( 1, 'DORMQR', 'LN', M, NRHS, N,
$ -1 ) )
ELSE
NB = MAX( NB, ILAENV( 1, 'DORMQR', 'LT', M, NRHS, N,
$ -1 ) )
END IF
ELSE
NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
IF( TPSD ) THEN
NB = MAX( NB, ILAENV( 1, 'DORMLQ', 'LT', N, NRHS, M,
$ -1 ) )
ELSE
NB = MAX( NB, ILAENV( 1, 'DORMLQ', 'LN', N, NRHS, M,
$ -1 ) )
END IF
END IF
*
WSIZE = MAX( 1, MN+MAX( MN, NRHS )*NB )
WORK( 1 ) = DBLE( WSIZE )
*
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGELS ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( MIN( M, N, NRHS ).EQ.0 ) THEN
CALL DLASET( 'Full', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
RETURN
END IF
*
* Get machine parameters
*
OPCNT( GELS ) = OPCNT( GELS ) + DBLE( 2 )
SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' )
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
*
* Scale A, B if max element outside range [SMLNUM,BIGNUM]
*
ANRM = DLANGE( 'M', M, N, A, LDA, RWORK )
IASCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
OPCNT( GELS ) = OPCNT( GELS ) + DBLE( M*N )
CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
IASCL = 1
ELSE IF( ANRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
OPCNT( GELS ) = OPCNT( GELS ) + DBLE( M*N )
CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
IASCL = 2
ELSE IF( ANRM.EQ.ZERO ) THEN
*
* Matrix all zero. Return zero solution.
*
CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
GO TO 50
END IF
*
BROW = M
IF( TPSD )
$ BROW = N
BNRM = DLANGE( 'M', BROW, NRHS, B, LDB, RWORK )
IBSCL = 0
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
OPCNT( GELS ) = OPCNT( GELS ) + DBLE( BROW*NRHS )
CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, BROW, NRHS, B, LDB,
$ INFO )
IBSCL = 1
ELSE IF( BNRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
OPCNT( GELS ) = OPCNT( GELS ) + DBLE( BROW*NRHS )
CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, BROW, NRHS, B, LDB,
$ INFO )
IBSCL = 2
END IF
*
IF( M.GE.N ) THEN
*
* compute QR factorization of A
*
NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
OPCNT( GEQRF ) = OPCNT( GEQRF ) +
$ DOPLA( 'DGEQRF', M, N, 0, 0, NB )
T1 = DSECND( )
CALL DGEQRF( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ), LWORK-MN,
$ INFO )
T2 = DSECND( )
TIMNG( GEQRF ) = TIMNG( GEQRF ) + ( T2-T1 )
*
* workspace at least N, optimally N*NB
*
IF( .NOT.TPSD ) THEN
*
* Least-Squares Problem min || A * X - B ||
*
* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS)
*
NB = ILAENV( 1, 'DORMQR', 'LT', M, NRHS, N, -1 )
OPCNT( ORMQR ) = OPCNT( ORMQR ) +
$ DOPLA( 'DORMQR', M, NRHS, N, 0, NB )
T1 = DSECND( )
CALL DORMQR( 'Left', 'Transpose', M, NRHS, N, A, LDA,
$ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
$ INFO )
T2 = DSECND( )
TIMNG( ORMQR ) = TIMNG( ORMQR ) + ( T2-T1 )
*
* workspace at least NRHS, optimally NRHS*NB
*
* B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS)
*
OPCNT( TRSM ) = OPCNT( TRSM ) +
$ DOPBL3( 'DTRSM ', N, NRHS, 0 )
T1 = DSECND( )
CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N,
$ NRHS, ONE, A, LDA, B, LDB )
T2 = DSECND( )
TIMNG( TRSM ) = TIMNG( TRSM ) + ( T2-T1 )
*
SCLLEN = N
*
ELSE
*
* Overdetermined system of equations A' * X = B
*
* B(1:N,1:NRHS) := inv(R') * B(1:N,1:NRHS)
*
OPCNT( TRSM ) = OPCNT( TRSM ) +
$ DOPBL3( 'DTRSM ', N, NRHS, 0 )
T1 = DSECND( )
CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N,
$ NRHS, ONE, A, LDA, B, LDB )
T2 = DSECND( )
TIMNG( TRSM ) = TIMNG( TRSM ) + ( T2-T1 )
*
* B(N+1:M,1:NRHS) = ZERO
*
DO 20 J = 1, NRHS
DO 10 I = N + 1, M
B( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
*
* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS)
*
NB = ILAENV( 1, 'DORMQR', 'LN', M, NRHS, N, -1 )
OPCNT( ORMQR ) = OPCNT( ORMQR ) +
$ DOPLA( 'DORMQR', M, NRHS, N, 0, NB )
T1 = DSECND( )
CALL DORMQR( 'Left', 'No transpose', M, NRHS, N, A, LDA,
$ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
$ INFO )
T2 = DSECND( )
TIMNG( ORMQR ) = TIMNG( ORMQR ) + ( T2-T1 )
*
* workspace at least NRHS, optimally NRHS*NB
*
SCLLEN = M
*
END IF
*
ELSE
*
* Compute LQ factorization of A
*
NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
OPCNT( GELQF ) = OPCNT( GELQF ) +
$ DOPLA( 'DGELQF', M, N, 0, 0, NB )
T1 = DSECND( )
CALL DGELQF( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ), LWORK-MN,
$ INFO )
T2 = DSECND( )
TIMNG( GELQF ) = TIMNG( GELQF ) + ( T2-T1 )
*
* workspace at least M, optimally M*NB.
*
IF( .NOT.TPSD ) THEN
*
* underdetermined system of equations A * X = B
*
* B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS)
*
OPCNT( TRSM ) = OPCNT( TRSM ) +
$ DOPBL3( 'DTRSM ', M, NRHS, 0 )
T1 = DSECND( )
CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', M,
$ NRHS, ONE, A, LDA, B, LDB )
T2 = DSECND( )
TIMNG( TRSM ) = TIMNG( TRSM ) + ( T2-T1 )
*
* B(M+1:N,1:NRHS) = 0
*
DO 40 J = 1, NRHS
DO 30 I = M + 1, N
B( I, J ) = ZERO
30 CONTINUE
40 CONTINUE
*
* B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS)
*
NB = ILAENV( 1, 'DORMLQ', 'LT', N, NRHS, M, -1 )
OPCNT( ORMLQ ) = OPCNT( ORMLQ ) +
$ DOPLA( 'DORMLQ', N, NRHS, M, 0, NB )
T1 = DSECND( )
CALL DORMLQ( 'Left', 'Transpose', N, NRHS, M, A, LDA,
$ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
$ INFO )
T2 = DSECND( )
TIMNG( ORMLQ ) = TIMNG( ORMLQ ) + ( T2-T1 )
*
* workspace at least NRHS, optimally NRHS*NB
*
SCLLEN = N
*
ELSE
*
* overdetermined system min || A' * X - B ||
*
* B(1:N,1:NRHS) := Q * B(1:N,1:NRHS)
*
NB = ILAENV( 1, 'DORMLQ', 'LN', N, NRHS, M, -1 )
OPCNT( ORMLQ ) = OPCNT( ORMLQ ) +
$ DOPLA( 'DORMLQ', N, NRHS, M, 0, NB )
T1 = DSECND( )
CALL DORMLQ( 'Left', 'No transpose', N, NRHS, M, A, LDA,
$ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
$ INFO )
T2 = DSECND( )
TIMNG( ORMLQ ) = TIMNG( ORMLQ ) + ( T2-T1 )
*
* workspace at least NRHS, optimally NRHS*NB
*
* B(1:M,1:NRHS) := inv(L') * B(1:M,1:NRHS)
*
OPCNT( TRSM ) = OPCNT( TRSM ) +
$ DOPBL3( 'DTRSM ', M, NRHS, 0 )
T1 = DSECND( )
CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Non-unit', M,
$ NRHS, ONE, A, LDA, B, LDB )
T2 = DSECND( )
TIMNG( TRSM ) = TIMNG( TRSM ) + ( T2-T1 )
*
SCLLEN = M
*
END IF
*
END IF
*
* Undo scaling
*
IF( IASCL.EQ.1 ) THEN
OPCNT( GELS ) = OPCNT( GELS ) + DBLE( SCLLEN*NRHS )
CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, SCLLEN, NRHS, B, LDB,
$ INFO )
ELSE IF( IASCL.EQ.2 ) THEN
OPCNT( GELS ) = OPCNT( GELS ) + DBLE( SCLLEN*NRHS )
CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, SCLLEN, NRHS, B, LDB,
$ INFO )
END IF
IF( IBSCL.EQ.1 ) THEN
OPCNT( GELS ) = OPCNT( GELS ) + DBLE( SCLLEN*NRHS )
CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, SCLLEN, NRHS, B, LDB,
$ INFO )
ELSE IF( IBSCL.EQ.2 ) THEN
OPCNT( GELS ) = OPCNT( GELS ) + DBLE( SCLLEN*NRHS )
CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, SCLLEN, NRHS, B, LDB,
$ INFO )
END IF
*
50 CONTINUE
WORK( 1 ) = DBLE( WSIZE )
*
RETURN
*
* End of DGELS
*
END
SUBROUTINE DGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK,
$ WORK, LWORK, IWORK, INFO )
*
* -- LAPACK driver routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGELSD computes the minimum-norm solution to a real linear least
* squares problem:
* minimize 2-norm(| b - A*x |)
* using the singular value decomposition (SVD) of A. A is an M-by-N
* matrix which may be rank-deficient.
*
* Several right hand side vectors b and solution vectors x can be
* handled in a single call; they are stored as the columns of the
* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
* matrix X.
*
* The problem is solved in three steps:
* (1) Reduce the coefficient matrix A to bidiagonal form with
* Householder transformations, reducing the original problem
* into a "bidiagonal least squares problem" (BLS)
* (2) Solve the BLS using a divide and conquer approach.
* (3) Apply back all the Householder tranformations to solve
* the original least squares problem.
*
* The effective rank of A is determined by treating as zero those
* singular values which are less than RCOND times the largest singular
* value.
*
* The divide and conquer algorithm makes very mild assumptions about
* floating point arithmetic. It will work on machines with a guard
* digit in add/subtract, or on those binary machines without guard
* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
* Cray-2. It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of A. M >= 0.
*
* N (input) INTEGER
* The number of columns of A. N >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrices B and X. NRHS >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, A has been destroyed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the M-by-NRHS right hand side matrix B.
* On exit, B is overwritten by the N-by-NRHS solution
* matrix X. If m >= n and RANK = n, the residual
* sum-of-squares for the solution in the i-th column is given
* by the sum of squares of elements n+1:m in that column.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,max(M,N)).
*
* S (output) DOUBLE PRECISION array, dimension (min(M,N))
* The singular values of A in decreasing order.
* The condition number of A in the 2-norm = S(1)/S(min(m,n)).
*
* RCOND (input) DOUBLE PRECISION
* RCOND is used to determine the effective rank of A.
* Singular values S(i) <= RCOND*S(1) are treated as zero.
* If RCOND < 0, machine precision is used instead.
*
* RANK (output) INTEGER
* The effective rank of A, i.e., the number of singular values
* which are greater than RCOND*S(1).
*
* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK. LWORK must be at least 1.
* The exact minimum amount of workspace needed depends on M,
* N and NRHS. As long as LWORK is at least
* 12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2,
* if M is greater than or equal to N or
* 12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2,
* if M is less than N, the code will execute correctly.
* SMLSIZ is returned by ILAENV and is equal to the maximum
* size of the subproblems at the bottom of the computation
* tree (usually about 25), and
* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )
* For good performance, LWORK should generally be larger.
*
* 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.
*
* IWORK (workspace) INTEGER array, dimension (LIWORK)
* LIWORK >= 3 * MINMN * NLVL + 11 * MINMN,
* where MINMN = MIN( M,N ).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: the algorithm for computing the SVD failed to converge;
* if INFO = i, i off-diagonal elements of an intermediate
* bidiagonal form did not converge to zero.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Ren-Cang Li, Computer Science Division, University of
* California at Berkeley, USA
* Osni Marques, LBNL/NERSC, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER IASCL, IBSCL, IE, IL, ITAU, ITAUP, ITAUQ,
$ LDWORK, MAXMN, MAXWRK, MINMN, MINWRK, MM,
$ MNTHR, NLVL, NWORK, SMLSIZ, WLALSD
DOUBLE PRECISION ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM
* ..
* .. External Subroutines ..
EXTERNAL DGEBRD, DGELQF, DGEQRF, DLABAD, DLACPY, DLALSD,
$ DLASCL, DLASET, DORMBR, DORMLQ, DORMQR, XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL ILAENV, DLAMCH, DLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, INT, LOG, MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments.
*
INFO = 0
MINMN = MIN( M, N )
MAXMN = MAX( M, N )
MNTHR = ILAENV( 6, 'DGELSD', ' ', M, N, NRHS, -1 )
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) 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, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN
INFO = -7
END IF
*
SMLSIZ = ILAENV( 9, 'DGELSD', ' ', 0, 0, 0, 0 )
*
* Compute workspace.
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.)
*
MINWRK = 1
MINMN = MAX( 1, MINMN )
NLVL = MAX( INT( LOG( DBLE( MINMN ) / DBLE( SMLSIZ+1 ) ) /
$ LOG( TWO ) )+ 1, 0 )
*
IF( INFO.EQ.0 ) THEN
MAXWRK = 0
MM = M
IF( M.GE.N .AND. M.GE.MNTHR ) THEN
*
* Path 1a - overdetermined, with many more rows than columns.
*
MM = N
MAXWRK = MAX( MAXWRK, N+N*ILAENV( 1, 'DGEQRF', ' ', M, N,
$ -1, -1 ) )
MAXWRK = MAX( MAXWRK, N+NRHS*
$ ILAENV( 1, 'DORMQR', 'LT', M, NRHS, N, -1 ) )
END IF
IF( M.GE.N ) THEN
*
* Path 1 - overdetermined or exactly determined.
*
MAXWRK = MAX( MAXWRK, 3*N+( MM+N )*
$ ILAENV( 1, 'DGEBRD', ' ', MM, N, -1, -1 ) )
MAXWRK = MAX( MAXWRK, 3*N+NRHS*
$ ILAENV( 1, 'DORMBR', 'QLT', MM, NRHS, N, -1 ) )
MAXWRK = MAX( MAXWRK, 3*N+( N-1 )*
$ ILAENV( 1, 'DORMBR', 'PLN', N, NRHS, N, -1 ) )
WLALSD = 9*N+2*N*SMLSIZ+8*N*NLVL+N*NRHS+(SMLSIZ+1)**2
MAXWRK = MAX( MAXWRK, 3*N+WLALSD )
MINWRK = MAX( 3*N+MM, 3*N+NRHS, 3*N+WLALSD )
END IF
IF( N.GT.M ) THEN
WLALSD = 9*M+2*M*SMLSIZ+8*M*NLVL+M*NRHS+(SMLSIZ+1)**2
IF( N.GE.MNTHR ) THEN
*
* Path 2a - underdetermined, with many more columns
* than rows.
*
MAXWRK = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
MAXWRK = MAX( MAXWRK, M*M+4*M+2*M*
$ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
MAXWRK = MAX( MAXWRK, M*M+4*M+NRHS*
$ ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, M, -1 ) )
MAXWRK = MAX( MAXWRK, M*M+4*M+( M-1 )*
$ ILAENV( 1, 'DORMBR', 'PLN', M, NRHS, M, -1 ) )
IF( NRHS.GT.1 ) THEN
MAXWRK = MAX( MAXWRK, M*M+M+M*NRHS )
ELSE
MAXWRK = MAX( MAXWRK, M*M+2*M )
END IF
MAXWRK = MAX( MAXWRK, M+NRHS*
$ ILAENV( 1, 'DORMLQ', 'LT', N, NRHS, M, -1 ) )
MAXWRK = MAX( MAXWRK, M*M+4*M+WLALSD )
ELSE
*
* Path 2 - remaining underdetermined cases.
*
MAXWRK = 3*M + ( N+M )*ILAENV( 1, 'DGEBRD', ' ', M, N,
$ -1, -1 )
MAXWRK = MAX( MAXWRK, 3*M+NRHS*
$ ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, N, -1 ) )
MAXWRK = MAX( MAXWRK, 3*M+M*
$ ILAENV( 1, 'DORMBR', 'PLN', N, NRHS, M, -1 ) )
MAXWRK = MAX( MAXWRK, 3*M+WLALSD )
END IF
MINWRK = MAX( 3*M+NRHS, 3*M+M, 3*M+WLALSD )
END IF
MINWRK = MIN( MINWRK, MAXWRK )
WORK( 1 ) = MAXWRK
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGELSD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
GO TO 10
END IF
*
* Quick return if possible.
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
RANK = 0
RETURN
END IF
*
* Get machine parameters.
*
EPS = DLAMCH( 'P' )
SFMIN = DLAMCH( 'S' )
SMLNUM = SFMIN / EPS
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
*
* Scale A if max entry outside range [SMLNUM,BIGNUM].
*
ANRM = DLANGE( 'M', M, N, A, LDA, WORK )
IASCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM.
*
CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
IASCL = 1
ELSE IF( ANRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM.
*
CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
IASCL = 2
ELSE IF( ANRM.EQ.ZERO ) THEN
*
* Matrix all zero. Return zero solution.
*
CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
CALL DLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 )
RANK = 0
GO TO 10
END IF
*
* Scale B if max entry outside range [SMLNUM,BIGNUM].
*
BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK )
IBSCL = 0
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM.
*
CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
IBSCL = 1
ELSE IF( BNRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM.
*
CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
IBSCL = 2
END IF
*
* If M < N make sure certain entries of B are zero.
*
IF( M.LT.N )
$ CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB )
*
* Overdetermined case.
*
IF( M.GE.N ) THEN
*
* Path 1 - overdetermined or exactly determined.
*
MM = M
IF( M.GE.MNTHR ) THEN
*
* Path 1a - overdetermined, with many more rows than columns.
*
MM = N
ITAU = 1
NWORK = ITAU + N
*
* Compute A=Q*R.
* (Workspace: need 2*N, prefer N+N*NB)
*
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, INFO )
*
* Multiply B by transpose(Q).
* (Workspace: need N+NRHS, prefer N+NRHS*NB)
*
CALL DORMQR( 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAU ), B,
$ LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
* Zero out below R.
*
IF( N.GT.1 ) THEN
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
END IF
END IF
*
IE = 1
ITAUQ = IE + N
ITAUP = ITAUQ + N
NWORK = ITAUP + N
*
* Bidiagonalize R in A.
* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB)
*
CALL DGEBRD( MM, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ INFO )
*
* Multiply B by transpose of left bidiagonalizing vectors of R.
* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB)
*
CALL DORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, WORK( ITAUQ ),
$ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
* Solve the bidiagonal least squares problem.
*
CALL DLALSD( 'U', SMLSIZ, N, NRHS, S, WORK( IE ), B, LDB,
$ RCOND, RANK, WORK( NWORK ), IWORK, INFO )
IF( INFO.NE.0 ) THEN
GO TO 10
END IF
*
* Multiply B by right bidiagonalizing vectors of R.
*
CALL DORMBR( 'P', 'L', 'N', N, NRHS, N, A, LDA, WORK( ITAUP ),
$ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+
$ MAX( M, 2*M-4, NRHS, N-3*M ) ) THEN
*
* Path 2a - underdetermined, with many more columns than rows
* and sufficient workspace for an efficient algorithm.
*
LDWORK = M
IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ),
$ M*LDA+M+M*NRHS ) )LDWORK = LDA
ITAU = 1
NWORK = M + 1
*
* Compute A=L*Q.
* (Workspace: need 2*M, prefer M+M*NB)
*
CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, INFO )
IL = NWORK
*
* Copy L to WORK(IL), zeroing out above its diagonal.
*
CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK )
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( IL+LDWORK ),
$ LDWORK )
IE = IL + LDWORK*M
ITAUQ = IE + M
ITAUP = ITAUQ + M
NWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IL).
* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB)
*
CALL DGEBRD( M, M, WORK( IL ), LDWORK, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
$ LWORK-NWORK+1, INFO )
*
* Multiply B by transpose of left bidiagonalizing vectors of L.
* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB)
*
CALL DORMBR( 'Q', 'L', 'T', M, NRHS, M, WORK( IL ), LDWORK,
$ WORK( ITAUQ ), B, LDB, WORK( NWORK ),
$ LWORK-NWORK+1, INFO )
*
* Solve the bidiagonal least squares problem.
*
CALL DLALSD( 'U', SMLSIZ, M, NRHS, S, WORK( IE ), B, LDB,
$ RCOND, RANK, WORK( NWORK ), IWORK, INFO )
IF( INFO.NE.0 ) THEN
GO TO 10
END IF
*
* Multiply B by right bidiagonalizing vectors of L.
*
CALL DORMBR( 'P', 'L', 'N', M, NRHS, M, WORK( IL ), LDWORK,
$ WORK( ITAUP ), B, LDB, WORK( NWORK ),
$ LWORK-NWORK+1, INFO )
*
* Zero out below first M rows of B.
*
CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB )
NWORK = ITAU + M
*
* Multiply transpose(Q) by B.
* (Workspace: need M+NRHS, prefer M+NRHS*NB)
*
CALL DORMLQ( 'L', 'T', N, NRHS, M, A, LDA, WORK( ITAU ), B,
$ LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
ELSE
*
* Path 2 - remaining underdetermined cases.
*
IE = 1
ITAUQ = IE + M
ITAUP = ITAUQ + M
NWORK = ITAUP + M
*
* Bidiagonalize A.
* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
*
CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ INFO )
*
* Multiply B by transpose of left bidiagonalizing vectors.
* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB)
*
CALL DORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAUQ ),
$ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
* Solve the bidiagonal least squares problem.
*
CALL DLALSD( 'L', SMLSIZ, M, NRHS, S, WORK( IE ), B, LDB,
$ RCOND, RANK, WORK( NWORK ), IWORK, INFO )
IF( INFO.NE.0 ) THEN
GO TO 10
END IF
*
* Multiply B by right bidiagonalizing vectors of A.
*
CALL DORMBR( 'P', 'L', 'N', N, NRHS, M, A, LDA, WORK( ITAUP ),
$ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
END IF
*
* Undo scaling.
*
IF( IASCL.EQ.1 ) THEN
CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
$ INFO )
ELSE IF( IASCL.EQ.2 ) THEN
CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
$ INFO )
END IF
IF( IBSCL.EQ.1 ) THEN
CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
ELSE IF( IBSCL.EQ.2 ) THEN
CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
END IF
*
10 CONTINUE
WORK( 1 ) = MAXWRK
RETURN
*
* End of DGELSD
*
END
SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK,
$ WORK, LWORK, INFO )
*
* -- LAPACK driver routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * )
* ..
* Common blocks to return operation counts and timings
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
COMMON / LSTIME / OPCNT, TIMNG
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
* .. Arrays in Common ..
DOUBLE PRECISION OPCNT( 6 ), TIMNG( 6 )
* ..
*
* Purpose
* =======
*
* DGELSS computes the minimum norm solution to a real linear least
* squares problem:
*
* Minimize 2-norm(| b - A*x |).
*
* using the singular value decomposition (SVD) of A. A is an M-by-N
* matrix which may be rank-deficient.
*
* Several right hand side vectors b and solution vectors x can be
* handled in a single call; they are stored as the columns of the
* M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix
* X.
*
* The effective rank of A is determined by treating as zero those
* singular values which are less than RCOND times the largest singular
* value.
*
* 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.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrices B and X. NRHS >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, the first min(m,n) rows of A are overwritten with
* its right singular vectors, stored rowwise.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the M-by-NRHS right hand side matrix B.
* On exit, B is overwritten by the N-by-NRHS solution
* matrix X. If m >= n and RANK = n, the residual
* sum-of-squares for the solution in the i-th column is given
* by the sum of squares of elements n+1:m in that column.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,max(M,N)).
*
* S (output) DOUBLE PRECISION array, dimension (min(M,N))
* The singular values of A in decreasing order.
* The condition number of A in the 2-norm = S(1)/S(min(m,n)).
*
* RCOND (input) DOUBLE PRECISION
* RCOND is used to determine the effective rank of A.
* Singular values S(i) <= RCOND*S(1) are treated as zero.
* If RCOND < 0, machine precision is used instead.
*
* RANK (output) INTEGER
* The effective rank of A, i.e., the number of singular values
* which are greater than RCOND*S(1).
*
* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK. LWORK >= 1, and also:
* LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS )
* For good performance, LWORK should generally be larger.
*
* 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.
* > 0: the algorithm for computing the SVD failed to converge;
* if INFO = i, i off-diagonal elements of an intermediate
* bidiagonal form did not converge to zero.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER BDSPAC, BDSQR, BL, CHUNK, GEBRD, GELQF, GELSS,
$ GEMM, GEMV, GEQRF, I, IASCL, IBSCL, IE, IL,
$ ITAU, ITAUP, ITAUQ, IWORK, LDWORK, MAXMN,
$ MAXWRK, MINMN, MINWRK, MM, MNTHR, NB, ORGBR,
$ ORMBR, ORMLQ, ORMQR
DOUBLE PRECISION ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM, T1, T2,
$ THR
* ..
* .. Local Arrays ..
DOUBLE PRECISION VDUM( 1 )
* ..
* .. External Subroutines ..
EXTERNAL DBDSQR, DCOPY, DGEBRD, DGELQF, DGEMM, DGEMV,
$ DGEQRF, DLABAD, DLACPY, DLASCL, DLASET, DORGBR,
$ DORMBR, DORMLQ, DORMQR, DRSCL, XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANGE, DOPBL2, DOPBL3, DOPLA, DSECND,
$ DOPLA2
EXTERNAL ILAENV, DLAMCH, DLANGE, DOPBL2, DOPBL3, DOPLA,
$ DSECND, DOPLA2
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Data statements ..
DATA BDSQR / 5 / , GEBRD / 3 / , GELQF / 2 / ,
$ GELSS / 1 / , GEMM / 6 / , GEMV / 6 / ,
$ GEQRF / 2 / , ORGBR / 4 / , ORMBR / 4 / ,
$ ORMLQ / 6 / , ORMQR / 2 /
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
MINMN = MIN( M, N )
MAXMN = MAX( M, N )
MNTHR = ILAENV( 6, 'DGELSS', ' ', M, N, NRHS, -1 )
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) 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, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN
INFO = -7
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.)
*
MINWRK = 1
IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN
MAXWRK = 0
MM = M
IF( M.GE.N .AND. M.GE.MNTHR ) THEN
*
* Path 1a - overdetermined, with many more rows than columns
*
MM = N
MAXWRK = MAX( MAXWRK, N+N*ILAENV( 1, 'DGEQRF', ' ', M, N,
$ -1, -1 ) )
MAXWRK = MAX( MAXWRK, N+NRHS*
$ ILAENV( 1, 'DORMQR', 'LT', M, NRHS, N, -1 ) )
END IF
IF( M.GE.N ) THEN
*
* Path 1 - overdetermined or exactly determined
*
* Compute workspace needed for DBDSQR
*
BDSPAC = MAX( 1, 5*N )
MAXWRK = MAX( MAXWRK, 3*N+( MM+N )*
$ ILAENV( 1, 'DGEBRD', ' ', MM, N, -1, -1 ) )
MAXWRK = MAX( MAXWRK, 3*N+NRHS*
$ ILAENV( 1, 'DORMBR', 'QLT', MM, NRHS, N, -1 ) )
MAXWRK = MAX( MAXWRK, 3*N+( N-1 )*
$ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
MAXWRK = MAX( MAXWRK, BDSPAC )
MAXWRK = MAX( MAXWRK, N*NRHS )
MINWRK = MAX( 3*N+MM, 3*N+NRHS, BDSPAC )
MAXWRK = MAX( MINWRK, MAXWRK )
END IF
IF( N.GT.M ) THEN
*
* Compute workspace needed for DBDSQR
*
BDSPAC = MAX( 1, 5*M )
MINWRK = MAX( 3*M+NRHS, 3*M+N, BDSPAC )
IF( N.GE.MNTHR ) THEN
*
* Path 2a - underdetermined, with many more columns
* than rows
*
MAXWRK = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
MAXWRK = MAX( MAXWRK, M*M+4*M+2*M*
$ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
MAXWRK = MAX( MAXWRK, M*M+4*M+NRHS*
$ ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, M, -1 ) )
MAXWRK = MAX( MAXWRK, M*M+4*M+( M-1 )*
$ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
MAXWRK = MAX( MAXWRK, M*M+M+BDSPAC )
IF( NRHS.GT.1 ) THEN
MAXWRK = MAX( MAXWRK, M*M+M+M*NRHS )
ELSE
MAXWRK = MAX( MAXWRK, M*M+2*M )
END IF
MAXWRK = MAX( MAXWRK, M+NRHS*
$ ILAENV( 1, 'DORMLQ', 'LT', N, NRHS, M, -1 ) )
ELSE
*
* Path 2 - underdetermined
*
MAXWRK = 3*M + ( N+M )*ILAENV( 1, 'DGEBRD', ' ', M, N,
$ -1, -1 )
MAXWRK = MAX( MAXWRK, 3*M+NRHS*
$ ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, M, -1 ) )
MAXWRK = MAX( MAXWRK, 3*M+M*
$ ILAENV( 1, 'DORGBR', 'P', M, N, M, -1 ) )
MAXWRK = MAX( MAXWRK, BDSPAC )
MAXWRK = MAX( MAXWRK, N*NRHS )
END IF
END IF
MAXWRK = MAX( MINWRK, MAXWRK )
WORK( 1 ) = MAXWRK
END IF
*
MINWRK = MAX( MINWRK, 1 )
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY )
$ INFO = -12
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGELSS', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
RANK = 0
RETURN
END IF
*
* Get machine parameters
*
EPS = DLAMCH( 'P' )
SFMIN = DLAMCH( 'S' )
OPCNT( GELSS ) = OPCNT( GELSS ) + DBLE( 2 )
SMLNUM = SFMIN / EPS
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = DLANGE( 'M', M, N, A, LDA, WORK )
IASCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
OPCNT( GELSS ) = OPCNT( GELSS ) + DBLE( M*N )
CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
IASCL = 1
ELSE IF( ANRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
OPCNT( GELSS ) = OPCNT( GELSS ) + DBLE( M*N )
CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
IASCL = 2
ELSE IF( ANRM.EQ.ZERO ) THEN
*
* Matrix all zero. Return zero solution.
*
CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
CALL DLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 )
RANK = 0
GO TO 70
END IF
*
* Scale B if max element outside range [SMLNUM,BIGNUM]
*
BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK )
IBSCL = 0
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
OPCNT( GELSS ) = OPCNT( GELSS ) + DBLE( M*NRHS )
CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
IBSCL = 1
ELSE IF( BNRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
OPCNT( GELSS ) = OPCNT( GELSS ) + DBLE( M*NRHS )
CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
IBSCL = 2
END IF
*
* Overdetermined case
*
IF( M.GE.N ) THEN
*
* Path 1 - overdetermined or exactly determined
*
MM = M
IF( M.GE.MNTHR ) THEN
*
* Path 1a - overdetermined, with many more rows than columns
*
MM = N
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need 2*N, prefer N+N*NB)
*
NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
OPCNT( GEQRF ) = OPCNT( GEQRF ) +
$ DOPLA( 'DGEQRF', M, N, 0, 0, NB )
T1 = DSECND( )
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
$ LWORK-IWORK+1, INFO )
T2 = DSECND( )
TIMNG( GEQRF ) = TIMNG( GEQRF ) + ( T2-T1 )
*
* Multiply B by transpose(Q)
* (Workspace: need N+NRHS, prefer N+NRHS*NB)
*
NB = ILAENV( 1, 'DORMQR', 'LT', M, NRHS, N, -1 )
OPCNT( ORMQR ) = OPCNT( ORMQR ) +
$ DOPLA( 'DORMQR', M, NRHS, N, 0, NB )
T1 = DSECND( )
CALL DORMQR( 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAU ), B,
$ LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
T2 = DSECND( )
TIMNG( ORMQR ) = TIMNG( ORMQR ) + ( T2-T1 )
*
* Zero out below R
*
IF( N.GT.1 )
$ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
END IF
*
IE = 1
ITAUQ = IE + N
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in A
* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB)
*
NB = ILAENV( 1, 'DGEBRD', ' ', MM, N, -1, -1 )
OPCNT( GEBRD ) = OPCNT( GEBRD ) +
$ DOPLA( 'DGEBRD', MM, N, 0, 0, NB )
T1 = DSECND( )
CALL DGEBRD( MM, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
$ INFO )
T2 = DSECND( )
TIMNG( GEBRD ) = TIMNG( GEBRD ) + ( T2-T1 )
*
* Multiply B by transpose of left bidiagonalizing vectors of R
* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB)
*
NB = ILAENV( 1, 'DORMBR', 'QLT', MM, NRHS, N, -1 )
OPCNT( ORMBR ) = OPCNT( ORMBR ) +
$ DOPLA2( 'DORMBR', 'QLT', MM, NRHS, N, 0, NB )
T1 = DSECND( )
CALL DORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, WORK( ITAUQ ),
$ B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
T2 = DSECND( )
TIMNG( ORMBR ) = TIMNG( ORMBR ) + ( T2-T1 )
*
* Generate right bidiagonalizing vectors of R in A
* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
*
NB = ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 )
OPCNT( ORGBR ) = OPCNT( ORGBR ) +
$ DOPLA2( 'DORGBR', 'P', N, N, N, 0, NB )
T1 = DSECND( )
CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, INFO )
T2 = DSECND( )
TIMNG( ORGBR ) = TIMNG( ORGBR ) + ( T2-T1 )
IWORK = IE + N
*
* Perform bidiagonal QR iteration
* multiply B by transpose of left singular vectors
* compute right singular vectors in A
* (Workspace: need BDSPAC)
*
OPS = 0
T1 = DSECND( )
CALL DBDSQR( 'U', N, N, 0, NRHS, S, WORK( IE ), A, LDA, VDUM,
$ 1, B, LDB, WORK( IWORK ), INFO )
T2 = DSECND( )
TIMNG( BDSQR ) = TIMNG( BDSQR ) + ( T2-T1 )
OPCNT( BDSQR ) = OPCNT( BDSQR ) + OPS
IF( INFO.NE.0 )
$ GO TO 70
*
* Multiply B by reciprocals of singular values
*
OPCNT( GELSS ) = OPCNT( GELSS ) + DBLE( 1 )
THR = MAX( RCOND*S( 1 ), SFMIN )
IF( RCOND.LT.ZERO ) THEN
OPCNT( GELSS ) = OPCNT( GELSS ) + DBLE( 1 )
THR = MAX( EPS*S( 1 ), SFMIN )
END IF
RANK = 0
DO 10 I = 1, N
IF( S( I ).GT.THR ) THEN
OPCNT( GELSS ) = OPCNT( GELSS ) + DBLE( NRHS+3 )
CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB )
RANK = RANK + 1
ELSE
CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
END IF
10 CONTINUE
*
* Multiply B by right singular vectors
* (Workspace: need N, prefer N*NRHS)
*
IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN
OPCNT( GEMM ) = OPCNT( GEMM ) +
$ DOPBL3( 'DGEMM ', N, NRHS, N )
T1 = DSECND( )
CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, A, LDA, B, LDB, ZERO,
$ WORK, LDB )
T2 = DSECND( )
TIMNG( GEMM ) = TIMNG( GEMM ) + ( T2-T1 )
CALL DLACPY( 'G', N, NRHS, WORK, LDB, B, LDB )
ELSE IF( NRHS.GT.1 ) THEN
CHUNK = LWORK / N
DO 20 I = 1, NRHS, CHUNK
BL = MIN( NRHS-I+1, CHUNK )
OPCNT( GEMM ) = OPCNT( GEMM ) +
$ DOPBL3( 'DGEMM ', N, BL, N )
T1 = DSECND( )
CALL DGEMM( 'T', 'N', N, BL, N, ONE, A, LDA, B( 1, I ),
$ LDB, ZERO, WORK, N )
T2 = DSECND( )
TIMNG( GEMM ) = TIMNG( GEMM ) + ( T2-T1 )
CALL DLACPY( 'G', N, BL, WORK, N, B( 1, I ), LDB )
20 CONTINUE
ELSE
OPCNT( GEMV ) = OPCNT( GEMV ) +
$ DOPBL2( 'DGEMV ', N, N, 0, 0 )
T1 = DSECND( )
CALL DGEMV( 'T', N, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 )
T2 = DSECND( )
TIMNG( GEMV ) = TIMNG( GEMV ) + ( T2-T1 )
CALL DCOPY( N, WORK, 1, B, 1 )
END IF
*
ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+
$ MAX( M, 2*M-4, NRHS, N-3*M ) ) THEN
*
* Path 2a - underdetermined, with many more columns than rows
* and sufficient workspace for an efficient algorithm
*
LDWORK = M
IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ),
$ M*LDA+M+M*NRHS ) )LDWORK = LDA
ITAU = 1
IWORK = M + 1
*
* Compute A=L*Q
* (Workspace: need 2*M, prefer M+M*NB)
*
NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
OPCNT( GELQF ) = OPCNT( GELQF ) +
$ DOPLA( 'DGELQF', M, N, 0, 0, NB )
T1 = DSECND( )
CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
$ LWORK-IWORK+1, INFO )
T2 = DSECND( )
TIMNG( GELQF ) = TIMNG( GELQF ) + ( T2-T1 )
IL = IWORK
*
* Copy L to WORK(IL), zeroing out above it
*
CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK )
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( IL+LDWORK ),
$ LDWORK )
IE = IL + LDWORK*M
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IL)
* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB)
*
NB = ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 )
OPCNT( GEBRD ) = OPCNT( GEBRD ) +
$ DOPLA( 'DGEBRD', M, M, 0, 0, NB )
T1 = DSECND( )
CALL DGEBRD( M, M, WORK( IL ), LDWORK, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, INFO )
T2 = DSECND( )
TIMNG( GEBRD ) = TIMNG( GEBRD ) + ( T2-T1 )
*
* Multiply B by transpose of left bidiagonalizing vectors of L
* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB)
*
NB = ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, M, -1 )
OPCNT( ORMBR ) = OPCNT( ORMBR ) +
$ DOPLA2( 'DORMBR', 'QLT', M, NRHS, M, 0, NB )
T1 = DSECND( )
CALL DORMBR( 'Q', 'L', 'T', M, NRHS, M, WORK( IL ), LDWORK,
$ WORK( ITAUQ ), B, LDB, WORK( IWORK ),
$ LWORK-IWORK+1, INFO )
T2 = DSECND( )
TIMNG( ORMBR ) = TIMNG( ORMBR ) + ( T2-T1 )
*
* Generate right bidiagonalizing vectors of R in WORK(IL)
* (Workspace: need M*M+5*M-1, prefer M*M+4*M+(M-1)*NB)
*
NB = ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 )
OPCNT( ORGBR ) = OPCNT( ORGBR ) +
$ DOPLA2( 'DORGBR', 'P', M, M, M, 0, NB )
T1 = DSECND( )
CALL DORGBR( 'P', M, M, M, WORK( IL ), LDWORK, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, INFO )
T2 = DSECND( )
TIMNG( ORGBR ) = TIMNG( ORGBR ) + ( T2-T1 )
IWORK = IE + M
*
* Perform bidiagonal QR iteration,
* computing right singular vectors of L in WORK(IL) and
* multiplying B by transpose of left singular vectors
* (Workspace: need M*M+M+BDSPAC)
*
OPS = 0
T1 = DSECND( )
CALL DBDSQR( 'U', M, M, 0, NRHS, S, WORK( IE ), WORK( IL ),
$ LDWORK, A, LDA, B, LDB, WORK( IWORK ), INFO )
T2 = DSECND( )
TIMNG( BDSQR ) = TIMNG( BDSQR ) + ( T2-T1 )
OPCNT( BDSQR ) = OPCNT( BDSQR ) + OPS
IF( INFO.NE.0 )
$ GO TO 70
*
* Multiply B by reciprocals of singular values
*
OPCNT( GELSS ) = OPCNT( GELSS ) + DBLE( 1 )
THR = MAX( RCOND*S( 1 ), SFMIN )
IF( RCOND.LT.ZERO ) THEN
OPCNT( GELSS ) = OPCNT( GELSS ) + DBLE( 1 )
THR = MAX( EPS*S( 1 ), SFMIN )
END IF
RANK = 0
DO 30 I = 1, M
IF( S( I ).GT.THR ) THEN
OPCNT( GELSS ) = OPCNT( GELSS ) + DBLE( NRHS+3 )
CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB )
RANK = RANK + 1
ELSE
CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
END IF
30 CONTINUE
IWORK = IE
*
* Multiply B by right singular vectors of L in WORK(IL)
* (Workspace: need M*M+2*M, prefer M*M+M+M*NRHS)
*
IF( LWORK.GE.LDB*NRHS+IWORK-1 .AND. NRHS.GT.1 ) THEN
OPCNT( GEMM ) = OPCNT( GEMM ) +
$ DOPBL3( 'DGEMM ', M, NRHS, M )
T1 = DSECND( )
CALL DGEMM( 'T', 'N', M, NRHS, M, ONE, WORK( IL ), LDWORK,
$ B, LDB, ZERO, WORK( IWORK ), LDB )
T2 = DSECND( )
TIMNG( GEMM ) = TIMNG( GEMM ) + ( T2-T1 )
CALL DLACPY( 'G', M, NRHS, WORK( IWORK ), LDB, B, LDB )
ELSE IF( NRHS.GT.1 ) THEN
CHUNK = ( LWORK-IWORK+1 ) / M
DO 40 I = 1, NRHS, CHUNK
BL = MIN( NRHS-I+1, CHUNK )
OPCNT( GEMM ) = OPCNT( GEMM ) +
$ DOPBL3( 'DGEMM ', M, BL, M )
T1 = DSECND( )
CALL DGEMM( 'T', 'N', M, BL, M, ONE, WORK( IL ), LDWORK,
$ B( 1, I ), LDB, ZERO, WORK( IWORK ), N )
T2 = DSECND( )
TIMNG( GEMM ) = TIMNG( GEMM ) + ( T2-T1 )
CALL DLACPY( 'G', M, BL, WORK( IWORK ), N, B( 1, I ),
$ LDB )
40 CONTINUE
ELSE
OPCNT( GEMV ) = OPCNT( GEMV ) +
$ DOPBL2( 'DGEMV ', M, M, 0, 0 )
T1 = DSECND( )
CALL DGEMV( 'T', M, M, ONE, WORK( IL ), LDWORK, B( 1, 1 ),
$ 1, ZERO, WORK( IWORK ), 1 )
T2 = DSECND( )
TIMNG( GEMV ) = TIMNG( GEMV ) + ( T2-T1 )
CALL DCOPY( M, WORK( IWORK ), 1, B( 1, 1 ), 1 )
END IF
*
* Zero out below first M rows of B
*
CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB )
IWORK = ITAU + M
*
* Multiply transpose(Q) by B
* (Workspace: need M+NRHS, prefer M+NRHS*NB)
*
NB = ILAENV( 1, 'DORMLQ', 'LT', N, NRHS, M, -1 )
OPCNT( ORMLQ ) = OPCNT( ORMLQ ) +
$ DOPLA( 'DORMLQ', N, NRHS, M, 0, NB )
T1 = DSECND( )
CALL DORMLQ( 'L', 'T', N, NRHS, M, A, LDA, WORK( ITAU ), B,
$ LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
T2 = DSECND( )
TIMNG( ORMLQ ) = TIMNG( ORMLQ ) + ( T2-T1 )
*
ELSE
*
* Path 2 - remaining underdetermined cases
*
IE = 1
ITAUQ = IE + M
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize A
* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
*
NB = ILAENV( 1, 'DGEBRD', ' ', M, N, -1, -1 )
OPCNT( GEBRD ) = OPCNT( GEBRD ) +
$ DOPLA( 'DGEBRD', M, N, 0, 0, NB )
T1 = DSECND( )
CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
$ INFO )
T2 = DSECND( )
TIMNG( GEBRD ) = TIMNG( GEBRD ) + ( T2-T1 )
*
* Multiply B by transpose of left bidiagonalizing vectors
* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB)
*
NB = ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, N, -1 )
OPCNT( ORMBR ) = OPCNT( ORMBR ) +
$ DOPLA2( 'DORMBR', 'QLT', M, NRHS, N, 0, NB )
T1 = DSECND( )
CALL DORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAUQ ),
$ B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
T2 = DSECND( )
TIMNG( ORMBR ) = TIMNG( ORMBR ) + ( T2-T1 )
*
* Generate right bidiagonalizing vectors in A
* (Workspace: need 4*M, prefer 3*M+M*NB)
*
NB = ILAENV( 1, 'DORGBR', 'P', M, N, M, -1 )
OPCNT( ORGBR ) = OPCNT( ORGBR ) +
$ DOPLA2( 'DORGBR', 'P', M, N, M, 0, NB )
T1 = DSECND( )
CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, INFO )
T2 = DSECND( )
TIMNG( ORGBR ) = TIMNG( ORGBR ) + ( T2-T1 )
IWORK = IE + M
*
* Perform bidiagonal QR iteration,
* computing right singular vectors of A in A and
* multiplying B by transpose of left singular vectors
* (Workspace: need BDSPAC)
*
OPS = 0
T1 = DSECND( )
CALL DBDSQR( 'L', M, N, 0, NRHS, S, WORK( IE ), A, LDA, VDUM,
$ 1, B, LDB, WORK( IWORK ), INFO )
T2 = DSECND( )
TIMNG( BDSQR ) = TIMNG( BDSQR ) + ( T2-T1 )
OPCNT( BDSQR ) = OPCNT( BDSQR ) + OPS
IF( INFO.NE.0 )
$ GO TO 70
*
* Multiply B by reciprocals of singular values
*
OPCNT( GELSS ) = OPCNT( GELSS ) + DBLE( 1 )
THR = MAX( RCOND*S( 1 ), SFMIN )
IF( RCOND.LT.ZERO ) THEN
OPCNT( GELSS ) = OPCNT( GELSS ) + DBLE( 1 )
THR = MAX( EPS*S( 1 ), SFMIN )
END IF
RANK = 0
DO 50 I = 1, M
IF( S( I ).GT.THR ) THEN
OPCNT( GELSS ) = OPCNT( GELSS ) + DBLE( NRHS+3 )
CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB )
RANK = RANK + 1
ELSE
CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
END IF
50 CONTINUE
*
* Multiply B by right singular vectors of A
* (Workspace: need N, prefer N*NRHS)
*
IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN
OPCNT( GEMM ) = OPCNT( GEMM ) +
$ DOPBL3( 'DGEMM ', N, NRHS, M )
T1 = DSECND( )
CALL DGEMM( 'T', 'N', N, NRHS, M, ONE, A, LDA, B, LDB, ZERO,
$ WORK, LDB )
T2 = DSECND( )
TIMNG( GEMM ) = TIMNG( GEMM ) + ( T2-T1 )
CALL DLACPY( 'F', N, NRHS, WORK, LDB, B, LDB )
ELSE IF( NRHS.GT.1 ) THEN
CHUNK = LWORK / N
DO 60 I = 1, NRHS, CHUNK
BL = MIN( NRHS-I+1, CHUNK )
OPCNT( GEMM ) = OPCNT( GEMM ) +
$ DOPBL3( 'DGEMM ', N, BL, M )
T1 = DSECND( )
CALL DGEMM( 'T', 'N', N, BL, M, ONE, A, LDA, B( 1, I ),
$ LDB, ZERO, WORK, N )
T2 = DSECND( )
TIMNG( GEMM ) = TIMNG( GEMM ) + ( T2-T1 )
CALL DLACPY( 'F', N, BL, WORK, N, B( 1, I ), LDB )
60 CONTINUE
ELSE
OPCNT( GEMV ) = OPCNT( GEMV ) +
$ DOPBL2( 'DGEMV ', M, N, 0, 0 )
T1 = DSECND( )
CALL DGEMV( 'T', M, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 )
T2 = DSECND( )
TIMNG( GEMV ) = TIMNG( GEMV ) + ( T2-T1 )
CALL DCOPY( N, WORK, 1, B, 1 )
END IF
END IF
*
* Undo scaling
*
IF( IASCL.EQ.1 ) THEN
OPCNT( GELSS ) = OPCNT( GELSS ) + DBLE( N*NRHS+MINMN )
CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
$ INFO )
ELSE IF( IASCL.EQ.2 ) THEN
OPCNT( GELSS ) = OPCNT( GELSS ) + DBLE( N*NRHS+MINMN )
CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
$ INFO )
END IF
IF( IBSCL.EQ.1 ) THEN
OPCNT( GELSS ) = OPCNT( GELSS ) + DBLE( N*NRHS )
CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
ELSE IF( IBSCL.EQ.2 ) THEN
OPCNT( GELSS ) = OPCNT( GELSS ) + DBLE( N*NRHS )
CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
END IF
*
70 CONTINUE
WORK( 1 ) = MAXWRK
RETURN
*
* End of DGELSS
*
END
SUBROUTINE DGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK,
$ WORK, INFO )
*
* -- LAPACK driver routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, M, N, NRHS, RANK
DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
INTEGER JPVT( * )
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * )
* ..
* Common blocks to return operation counts and timings
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
COMMON / LSTIME / OPCNT, TIMNG
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
* .. Arrays in Common ..
DOUBLE PRECISION OPCNT( 6 ), TIMNG( 6 )
* ..
*
* Purpose
* =======
*
* DGELSX computes the minimum-norm solution to a real linear least
* squares problem:
* minimize || A * X - B ||
* using a complete orthogonal factorization of A. A is an M-by-N
* matrix which may be rank-deficient.
*
* Several right hand side vectors b and solution vectors x can be
* handled in a single call; they are stored as the columns of the
* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
* matrix X.
*
* The routine first computes a QR factorization with column pivoting:
* A * P = Q * [ R11 R12 ]
* [ 0 R22 ]
* with R11 defined as the largest leading submatrix whose estimated
* condition number is less than 1/RCOND. The order of R11, RANK,
* is the effective rank of A.
*
* Then, R22 is considered to be negligible, and R12 is annihilated
* by orthogonal transformations from the right, arriving at the
* complete orthogonal factorization:
* A * P = Q * [ T11 0 ] * Z
* [ 0 0 ]
* The minimum-norm solution is then
* X = P * Z' [ inv(T11)*Q1'*B ]
* [ 0 ]
* where Q1 consists of the first RANK columns of Q.
*
* 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.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of
* columns of matrices B and X. NRHS >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, A has been overwritten by details of its
* complete orthogonal factorization.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the M-by-NRHS right hand side matrix B.
* On exit, the N-by-NRHS solution matrix X.
* If m >= n and RANK = n, the residual sum-of-squares for
* the solution in the i-th column is given by the sum of
* squares of elements N+1:M in that column.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,M,N).
*
* JPVT (input/output) INTEGER array, dimension (N)
* On entry, if JPVT(i) .ne. 0, the i-th column of A is an
* initial column, otherwise it is a free column. Before
* the QR factorization of A, all initial columns are
* permuted to the leading positions; only the remaining
* free columns are moved as a result of column pivoting
* during the factorization.
* On exit, if JPVT(i) = k, then the i-th column of A*P
* was the k-th column of A.
*
* RCOND (input) DOUBLE PRECISION
* RCOND is used to determine the effective rank of A, which
* is defined as the order of the largest leading triangular
* submatrix R11 in the QR factorization with pivoting of A,
* whose estimated condition number < 1/RCOND.
*
* RANK (output) INTEGER
* The effective rank of A, i.e., the order of the submatrix
* R11. This is the same as the order of the submatrix T11
* in the complete orthogonal factorization of A.
*
* WORK (workspace) DOUBLE PRECISION array, dimension
* (max( min(M,N)+3*N, 2*min(M,N)+NRHS )),
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
INTEGER IMAX, IMIN
PARAMETER ( IMAX = 1, IMIN = 2 )
DOUBLE PRECISION ZERO, ONE, DONE, NTDONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, DONE = ZERO,
$ NTDONE = ONE )
* ..
* .. Local Scalars ..
INTEGER GELSX, GEQPF, I, IASCL, IBSCL, ISMAX, ISMIN, J,
$ K, LATZM, MN, ORM2R, TRSM, TZRQF
DOUBLE PRECISION ANRM, BIGNUM, BNRM, C1, C2, S1, S2, SMAX,
$ SMAXPR, SMIN, SMINPR, SMLNUM, T1, T2, TIM1,
$ TIM2
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE, DOPBL3, DOPLA, DSECND
EXTERNAL DLAMCH, DLANGE, DOPBL3, DOPLA, DSECND
* ..
* .. External Subroutines ..
EXTERNAL DGEQPF, DLABAD, DLAIC1, DLASCL, DLASET, DLATZM,
$ DORM2R, DTRSM, DTZRQF, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN
* ..
* .. Data statements ..
DATA GELSX / 1 / , GEQPF / 2 / , LATZM / 6 / ,
$ ORM2R / 4 / , TRSM / 5 / , TZRQF / 3 /
* ..
* .. Executable Statements ..
*
MN = MIN( M, N )
ISMIN = MN + 1
ISMAX = 2*MN + 1
*
* Test the input arguments.
*
INFO = 0
IF( M.LT.0 ) 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, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
INFO = -7
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGELSX', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( MIN( M, N, NRHS ).EQ.0 ) THEN
RANK = 0
RETURN
END IF
*
* Get machine parameters
*
OPCNT( GELSX ) = OPCNT( GELSX ) + DBLE( 2 )
SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' )
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
*
* Scale A, B if max elements outside range [SMLNUM,BIGNUM]
*
ANRM = DLANGE( 'M', M, N, A, LDA, WORK )
IASCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
OPCNT( GELSX ) = OPCNT( GELSX ) + DBLE( M*N )
CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
IASCL = 1
ELSE IF( ANRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
OPCNT( GELSX ) = OPCNT( GELSX ) + DBLE( M*N )
CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
IASCL = 2
ELSE IF( ANRM.EQ.ZERO ) THEN
*
* Matrix all zero. Return zero solution.
*
CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
RANK = 0
GO TO 100
END IF
*
BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK )
IBSCL = 0
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
OPCNT( GELSX ) = OPCNT( GELSX ) + DBLE( M*NRHS )
CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
IBSCL = 1
ELSE IF( BNRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
OPCNT( GELSX ) = OPCNT( GELSX ) + DBLE( M*NRHS )
CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
IBSCL = 2
END IF
*
* Compute QR factorization with column pivoting of A:
* A * P = Q * R
*
OPCNT( GEQPF ) = OPCNT( GEQPF ) + DOPLA( 'DGEQPF', M, N, 0, 0, 0 )
TIM1 = DSECND( )
CALL DGEQPF( M, N, A, LDA, JPVT, WORK( 1 ), WORK( MN+1 ), INFO )
TIM2 = DSECND( )
TIMNG( GEQPF ) = TIMNG( GEQPF ) + ( TIM2-TIM1 )
*
* workspace 3*N. Details of Householder rotations stored
* in WORK(1:MN).
*
* Determine RANK using incremental condition estimation
*
WORK( ISMIN ) = ONE
WORK( ISMAX ) = ONE
SMAX = ABS( A( 1, 1 ) )
SMIN = SMAX
IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN
RANK = 0
CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
GO TO 100
ELSE
RANK = 1
END IF
*
10 CONTINUE
IF( RANK.LT.MN ) THEN
I = RANK + 1
OPS = 0
CALL DLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ),
$ A( I, I ), SMINPR, S1, C1 )
CALL DLAIC1( IMAX, RANK, WORK( ISMAX ), SMAX, A( 1, I ),
$ A( I, I ), SMAXPR, S2, C2 )
OPCNT( GELSX ) = OPCNT( GELSX ) + OPS + DBLE( 1 )
*
IF( SMAXPR*RCOND.LE.SMINPR ) THEN
OPCNT( GELSX ) = OPCNT( GELSX ) + DBLE( RANK*2 )
DO 20 I = 1, RANK
WORK( ISMIN+I-1 ) = S1*WORK( ISMIN+I-1 )
WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 )
20 CONTINUE
WORK( ISMIN+RANK ) = C1
WORK( ISMAX+RANK ) = C2
SMIN = SMINPR
SMAX = SMAXPR
RANK = RANK + 1
GO TO 10
END IF
END IF
*
* Logically partition R = [ R11 R12 ]
* [ 0 R22 ]
* where R11 = R(1:RANK,1:RANK)
*
* [R11,R12] = [ T11, 0 ] * Y
*
IF( RANK.LT.N ) THEN
OPCNT( TZRQF ) = OPCNT( TZRQF ) +
$ DOPLA( 'DTZRQF', RANK, N, 0, 0, 0 )
TIM1 = DSECND( )
CALL DTZRQF( RANK, N, A, LDA, WORK( MN+1 ), INFO )
TIM2 = DSECND( )
TIMNG( TZRQF ) = TIMNG( TZRQF ) + ( TIM2-TIM1 )
END IF
*
* Details of Householder rotations stored in WORK(MN+1:2*MN)
*
* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS)
*
OPCNT( ORM2R ) = OPCNT( ORM2R ) +
$ DOPLA( 'DORMQR', M, NRHS, MN, 0, 0 )
TIM1 = DSECND( )
CALL DORM2R( 'Left', 'Transpose', M, NRHS, MN, A, LDA, WORK( 1 ),
$ B, LDB, WORK( 2*MN+1 ), INFO )
TIM2 = DSECND( )
TIMNG( ORM2R ) = TIMNG( ORM2R ) + ( TIM2-TIM1 )
*
* workspace NRHS
*
* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS)
*
OPCNT( TRSM ) = OPCNT( TRSM ) + DOPBL3( 'DTRSM ', RANK, NRHS, 0 )
TIM1 = DSECND( )
CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK,
$ NRHS, ONE, A, LDA, B, LDB )
TIM2 = DSECND( )
TIMNG( TRSM ) = TIMNG( TRSM ) + ( TIM2-TIM1 )
*
DO 40 I = RANK + 1, N
DO 30 J = 1, NRHS
B( I, J ) = ZERO
30 CONTINUE
40 CONTINUE
*
* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS)
*
IF( RANK.LT.N ) THEN
OPCNT( LATZM ) = OPCNT( LATZM ) +
$ DBLE( 2*( ( N-RANK )*NRHS+NRHS+( N-RANK )*
$ NRHS )*RANK )
TIM1 = DSECND( )
DO 50 I = 1, RANK
CALL DLATZM( 'Left', N-RANK+1, NRHS, A( I, RANK+1 ), LDA,
$ WORK( MN+I ), B( I, 1 ), B( RANK+1, 1 ), LDB,
$ WORK( 2*MN+1 ) )
50 CONTINUE
TIM2 = DSECND( )
TIMNG( LATZM ) = TIMNG( LATZM ) + ( TIM2-TIM1 )
END IF
*
* workspace NRHS
*
* B(1:N,1:NRHS) := P * B(1:N,1:NRHS)
*
DO 90 J = 1, NRHS
DO 60 I = 1, N
WORK( 2*MN+I ) = NTDONE
60 CONTINUE
DO 80 I = 1, N
IF( WORK( 2*MN+I ).EQ.NTDONE ) THEN
IF( JPVT( I ).NE.I ) THEN
K = I
T1 = B( K, J )
T2 = B( JPVT( K ), J )
70 CONTINUE
B( JPVT( K ), J ) = T1
WORK( 2*MN+K ) = DONE
T1 = T2
K = JPVT( K )
T2 = B( JPVT( K ), J )
IF( JPVT( K ).NE.I )
$ GO TO 70
B( I, J ) = T1
WORK( 2*MN+K ) = DONE
END IF
END IF
80 CONTINUE
90 CONTINUE
*
* Undo scaling
*
IF( IASCL.EQ.1 ) THEN
OPCNT( GELSX ) = OPCNT( GELSX ) + DBLE( N*NRHS+RANK*RANK )
CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
CALL DLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA,
$ INFO )
ELSE IF( IASCL.EQ.2 ) THEN
OPCNT( GELSX ) = OPCNT( GELSX ) + DBLE( N*NRHS+RANK*RANK )
CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
CALL DLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA,
$ INFO )
END IF
IF( IBSCL.EQ.1 ) THEN
OPCNT( GELSX ) = OPCNT( GELSX ) + DBLE( N*NRHS )
CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
ELSE IF( IBSCL.EQ.2 ) THEN
OPCNT( GELSX ) = OPCNT( GELSX ) + DBLE( N*NRHS )
CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
END IF
*
100 CONTINUE
*
RETURN
*
* End of DGELSX
*
END
SUBROUTINE DGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK,
$ WORK, LWORK, INFO )
*
* -- LAPACK driver routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
INTEGER JPVT( * )
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * )
* ..
* Common block to return operation counts and timings
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
COMMON / LSTIME / OPCNT, TIMNG
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
* .. Arrays in Common ..
DOUBLE PRECISION OPCNT( 6 ), TIMNG( 6 )
* ..
*
* Purpose
* =======
*
* DGELSY computes the minimum-norm solution to a real linear least
* squares problem:
* min || A * X - B ||
* using a complete orthogonal factorization of A. A is an M-by-N
* matrix which may be rank-deficient.
*
* Several right hand side vectors b and solution vectors x can be
* handled in a single call; they are stored as the columns of the
* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
* matrix X.
*
* The routine first computes a QR factorization with column pivoting:
* A * P = Q * [ R11 R12 ]
* [ 0 R22 ]
* with R11 defined as the largest leading submatrix whose estimated
* condition number is less than 1/RCOND. The order of R11, RANK,
* is the effective rank of A.
*
* Then, R22 is considered to be negligible, and R12 is annihilated
* by orthogonal transformations from the right, arriving at the
* complete orthogonal factorization:
* A * P = Q * [ T11 0 ] * Z
* [ 0 0 ]
* The minimum-norm solution is then
* X = P * Z' [ inv(T11)*Q1'*B ]
* [ 0 ]
* where Q1 consists of the first RANK columns of Q.
*
* This routine is basically identical to the original xGELSX except
* three differences:
* o The call to the subroutine xGEQPF has been substituted by the
* the call to the subroutine xGEQP3. This subroutine is a Blas-3
* version of the QR factorization with column pivoting.
* o Matrix B (the right hand side) is updated with Blas-3.
* o The permutation of matrix B (the right hand side) is faster and
* more simple.
*
* 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.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of
* columns of matrices B and X. NRHS >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit, A has been overwritten by details of its
* complete orthogonal factorization.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the M-by-NRHS right hand side matrix B.
* On exit, the N-by-NRHS solution matrix X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,M,N).
*
* JPVT (input/output) INTEGER array, dimension (N)
* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
* to the front of AP, otherwise column i is a free column.
* On exit, if JPVT(i) = k, then the i-th column of AP
* was the k-th column of A.
*
* RCOND (input) DOUBLE PRECISION
* RCOND is used to determine the effective rank of A, which
* is defined as the order of the largest leading triangular
* submatrix R11 in the QR factorization with pivoting of A,
* whose estimated condition number < 1/RCOND.
*
* RANK (output) INTEGER
* The effective rank of A, i.e., the order of the submatrix
* R11. This is the same as the order of the submatrix T11
* in the complete orthogonal factorization of A.
*
* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* The unblocked strategy requires that:
* LWORK >= MAX( MN+3*N+1, 2*MN+NRHS ),
* where MN = min( M, N ).
* The block algorithm requires that:
* LWORK >= MAX( MN+2*N+NB*(N+1), 2*MN+NB*NRHS ),
* where NB is an upper bound on the blocksize returned
* by ILAENV for the routines DGEQP3, DTZRZF, STZRQF, DORMQR,
* and DORMRZ.
*
* 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
* ===============
*
* Based on contributions by
* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
* E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
*
* =====================================================================
*
* .. Parameters ..
INTEGER IMAX, IMIN
PARAMETER ( IMAX = 1, IMIN = 2 )
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER GELSY, GEQP3, I, IASCL, IBSCL, ISMAX, ISMIN, J,
$ LWKOPT, MN, NB, NB1, NB2, NB3, NB4, ORMQR,
$ ORMRZ, TRSM, TZRZF
DOUBLE PRECISION ANRM, BIGNUM, BNRM, C1, C2, S1, S2, SMAX,
$ SMAXPR, SMIN, SMINPR, SMLNUM, T1, T2, WSIZE
* ..
* .. External Functions ..
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANGE, DOPBL3, DOPLA, DSECND
EXTERNAL ILAENV, DLAMCH, DLANGE, DOPBL3, DOPLA, DSECND
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEQP3, DLABAD, DLAIC1, DLASCL, DLASET,
$ DORMQR, DORMRZ, DTRSM, DTZRZF, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN
* ..
* .. Data statements ..
DATA GELSY / 1 / , GEQP3 / 2 / , ORMQR / 4 / ,
$ ORMRZ / 6 / , TRSM / 5 / , TZRZF / 3 /
* ..
* .. Executable Statements ..
*
MN = MIN( M, N )
ISMIN = MN + 1
ISMAX = 2*MN + 1
*
* Test the input arguments.
*
INFO = 0
NB1 = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
NB2 = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 )
NB3 = ILAENV( 1, 'DORMQR', ' ', M, N, NRHS, -1 )
NB4 = ILAENV( 1, 'DORMRQ', ' ', M, N, NRHS, -1 )
NB = MAX( NB1, NB2, NB3, NB4 )
LWKOPT = MAX( 1, MN+2*N+NB*( N+1 ), 2*MN+NB*NRHS )
WORK( 1 ) = DBLE( LWKOPT )
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) 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, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
INFO = -7
ELSE IF( LWORK.LT.MAX( 1, MN+3*N+1, 2*MN+NRHS ) .AND. .NOT.
$ LQUERY ) THEN
INFO = -12
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGELSY', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( MIN( M, N, NRHS ).EQ.0 ) THEN
RANK = 0
RETURN
END IF
*
* Get machine parameters
*
OPCNT( GELSY ) = OPCNT( GELSY ) + DBLE( 2 )
SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' )
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
*
* Scale A, B if max entries outside range [SMLNUM,BIGNUM]
*
ANRM = DLANGE( 'M', M, N, A, LDA, WORK )
IASCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
OPCNT( GELSY ) = OPCNT( GELSY ) + DBLE( M*N )
CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
IASCL = 1
ELSE IF( ANRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
OPCNT( GELSY ) = OPCNT( GELSY ) + DBLE( M*N )
CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
IASCL = 2
ELSE IF( ANRM.EQ.ZERO ) THEN
*
* Matrix all zero. Return zero solution.
*
CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
RANK = 0
GO TO 70
END IF
*
BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK )
IBSCL = 0
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
OPCNT( GELSY ) = OPCNT( GELSY ) + DBLE( M*NRHS )
CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
IBSCL = 1
ELSE IF( BNRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
OPCNT( GELSY ) = OPCNT( GELSY ) + DBLE( M*NRHS )
CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
IBSCL = 2
END IF
*
* Compute QR factorization with column pivoting of A:
* A * P = Q * R
*
OPCNT( GEQP3 ) = OPCNT( GEQP3 ) + DOPLA( 'DGEQPF', M, N, 0, 0, 0 )
T1 = DSECND( )
CALL DGEQP3( M, N, A, LDA, JPVT, WORK( 1 ), WORK( MN+1 ),
$ LWORK-MN, INFO )
T2 = DSECND( )
TIMNG( GEQP3 ) = TIMNG( GEQP3 ) + ( T2-T1 )
WSIZE = MN + WORK( MN+1 )
*
* workspace: MN+2*N+NB*(N+1).
* Details of Householder rotations stored in WORK(1:MN).
*
* Determine RANK using incremental condition estimation
*
WORK( ISMIN ) = ONE
WORK( ISMAX ) = ONE
SMAX = ABS( A( 1, 1 ) )
SMIN = SMAX
IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN
RANK = 0
CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
GO TO 70
ELSE
RANK = 1
END IF
*
10 CONTINUE
IF( RANK.LT.MN ) THEN
I = RANK + 1
OPS = 0
CALL DLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ),
$ A( I, I ), SMINPR, S1, C1 )
CALL DLAIC1( IMAX, RANK, WORK( ISMAX ), SMAX, A( 1, I ),
$ A( I, I ), SMAXPR, S2, C2 )
OPCNT( GELSY ) = OPCNT( GELSY ) + OPS + DBLE( 1 )
*
IF( SMAXPR*RCOND.LE.SMINPR ) THEN
OPCNT( GELSY ) = OPCNT( GELSY ) + DBLE( RANK*2 )
DO 20 I = 1, RANK
WORK( ISMIN+I-1 ) = S1*WORK( ISMIN+I-1 )
WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 )
20 CONTINUE
WORK( ISMIN+RANK ) = C1
WORK( ISMAX+RANK ) = C2
SMIN = SMINPR
SMAX = SMAXPR
RANK = RANK + 1
GO TO 10
END IF
END IF
*
* workspace: 3*MN.
*
* Logically partition R = [ R11 R12 ]
* [ 0 R22 ]
* where R11 = R(1:RANK,1:RANK)
*
* [R11,R12] = [ T11, 0 ] * Y
*
IF( RANK.LT.N ) THEN
OPCNT( TZRZF ) = OPCNT( TZRZF ) +
$ DOPLA( 'DTZRQF', RANK, N, 0, 0, 0 )
T1 = DSECND( )
CALL DTZRZF( RANK, N, A, LDA, WORK( MN+1 ), WORK( 2*MN+1 ),
$ LWORK-2*MN, INFO )
T2 = DSECND( )
TIMNG( TZRZF ) = TIMNG( TZRZF ) + ( T2-T1 )
END IF
*
* workspace: 2*MN.
* Details of Householder rotations stored in WORK(MN+1:2*MN)
*
* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS)
*
OPCNT( ORMQR ) = OPCNT( ORMQR ) +
$ DOPLA( 'DORMQR', M, NRHS, MN, 0, 0 )
T1 = DSECND( )
CALL DORMQR( 'Left', 'Transpose', M, NRHS, MN, A, LDA, WORK( 1 ),
$ B, LDB, WORK( 2*MN+1 ), LWORK-2*MN, INFO )
T2 = DSECND( )
TIMNG( ORMQR ) = TIMNG( ORMQR ) + ( T2-T1 )
WSIZE = MAX( WSIZE, 2*MN+WORK( 2*MN+1 ) )
*
* workspace: 2*MN+NB*NRHS.
*
* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS)
*
OPCNT( TRSM ) = OPCNT( TRSM ) + DOPBL3( 'DTRSM ', RANK, NRHS, 0 )
T1 = DSECND( )
CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK,
$ NRHS, ONE, A, LDA, B, LDB )
T2 = DSECND( )
TIMNG( TRSM ) = TIMNG( TRSM ) + ( T2-T1 )
*
DO 40 J = 1, NRHS
DO 30 I = RANK + 1, N
B( I, J ) = ZERO
30 CONTINUE
40 CONTINUE
*
* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS)
*
IF( RANK.LT.N ) THEN
NB = ILAENV( 1, 'DORMRQ', 'LT', N, NRHS, RANK, -1 )
OPCNT( ORMRZ ) = OPCNT( ORMRZ ) +
$ DOPLA( 'DORMRQ', N, NRHS, RANK, 0, NB )
T1 = DSECND( )
CALL DORMRZ( 'Left', 'Transpose', N, NRHS, RANK, N-RANK, A,
$ LDA, WORK( MN+1 ), B, LDB, WORK( 2*MN+1 ),
$ LWORK-2*MN, INFO )
T2 = DSECND( )
TIMNG( ORMRZ ) = TIMNG( ORMRZ ) + ( T2-T1 )
END IF
*
* workspace: 2*MN+NRHS.
*
* B(1:N,1:NRHS) := P * B(1:N,1:NRHS)
*
DO 60 J = 1, NRHS
DO 50 I = 1, N
WORK( JPVT( I ) ) = B( I, J )
50 CONTINUE
CALL DCOPY( N, WORK( 1 ), 1, B( 1, J ), 1 )
60 CONTINUE
*
* workspace: N.
*
* Undo scaling
*
IF( IASCL.EQ.1 ) THEN
OPCNT( GELSY ) = OPCNT( GELSY ) + DBLE( N*NRHS+RANK*RANK )
CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
CALL DLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA,
$ INFO )
ELSE IF( IASCL.EQ.2 ) THEN
OPCNT( GELSY ) = OPCNT( GELSY ) + DBLE( N*NRHS+RANK*RANK )
CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
CALL DLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA,
$ INFO )
END IF
IF( IBSCL.EQ.1 ) THEN
OPCNT( GELSY ) = OPCNT( GELSY ) + DBLE( N*NRHS )
CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
ELSE IF( IBSCL.EQ.2 ) THEN
OPCNT( GELSY ) = OPCNT( GELSY ) + DBLE( N*NRHS )
CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
END IF
*
70 CONTINUE
WORK( 1 ) = DBLE( LWKOPT )
*
RETURN
*
* End of DGELSY
*
END
SUBROUTINE DLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER J, JOB
DOUBLE PRECISION C, GAMMA, S, SEST, SESTPR
* ..
* .. Array Arguments ..
DOUBLE PRECISION W( J ), X( J )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLAIC1 applies one step of incremental condition estimation in
* its simplest version:
*
* Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j
* lower triangular matrix L, such that
* twonorm(L*x) = sest
* Then DLAIC1 computes sestpr, s, c such that
* the vector
* [ s*x ]
* xhat = [ c ]
* is an approximate singular vector of
* [ L 0 ]
* Lhat = [ w' gamma ]
* in the sense that
* twonorm(Lhat*xhat) = sestpr.
*
* Depending on JOB, an estimate for the largest or smallest singular
* value is computed.
*
* Note that [s c]' and sestpr**2 is an eigenpair of the system
*
* diag(sest*sest, 0) + [alpha gamma] * [ alpha ]
* [ gamma ]
*
* where alpha = x'*w.
*
* Arguments
* =========
*
* JOB (input) INTEGER
* = 1: an estimate for the largest singular value is computed.
* = 2: an estimate for the smallest singular value is computed.
*
* J (input) INTEGER
* Length of X and W
*
* X (input) DOUBLE PRECISION array, dimension (J)
* The j-vector x.
*
* SEST (input) DOUBLE PRECISION
* Estimated singular value of j by j matrix L
*
* W (input) DOUBLE PRECISION array, dimension (J)
* The j-vector w.
*
* GAMMA (input) DOUBLE PRECISION
* The diagonal element gamma.
*
* SESTPR (output) DOUBLE PRECISION
* Estimated singular value of (j+1) by (j+1) matrix Lhat.
*
* S (output) DOUBLE PRECISION
* Sine needed in forming xhat.
*
* C (output) DOUBLE PRECISION
* Cosine needed in forming xhat.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
DOUBLE PRECISION HALF, FOUR
PARAMETER ( HALF = 0.5D0, FOUR = 4.0D0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION ABSALP, ABSEST, ABSGAM, ALPHA, B, COSINE, EPS,
$ NORMA, S1, S2, SINE, T, TEST, TMP, ZETA1, ZETA2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SIGN, SQRT
* ..
* .. External Functions ..
DOUBLE PRECISION DDOT, DLAMCH
EXTERNAL DDOT, DLAMCH
* ..
* .. Executable Statements ..
*
EPS = DLAMCH( 'Epsilon' )
ALPHA = DDOT( J, X, 1, W, 1 )
*
ABSALP = ABS( ALPHA )
ABSGAM = ABS( GAMMA )
ABSEST = ABS( SEST )
*
IF( JOB.EQ.1 ) THEN
*
* Estimating largest singular value
*
* special cases
*
IF( SEST.EQ.ZERO ) THEN
S1 = MAX( ABSGAM, ABSALP )
IF( S1.EQ.ZERO ) THEN
S = ZERO
C = ONE
SESTPR = ZERO
ELSE
OPS = OPS + 9
S = ALPHA / S1
C = GAMMA / S1
TMP = SQRT( S*S+C*C )
S = S / TMP
C = C / TMP
SESTPR = S1*TMP
END IF
RETURN
ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN
OPS = OPS + 7
S = ONE
C = ZERO
TMP = MAX( ABSEST, ABSALP )
S1 = ABSEST / TMP
S2 = ABSALP / TMP
SESTPR = TMP*SQRT( S1*S1+S2*S2 )
RETURN
ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN
S1 = ABSGAM
S2 = ABSEST
IF( S1.LE.S2 ) THEN
S = ONE
C = ZERO
SESTPR = S2
ELSE
S = ZERO
C = ONE
SESTPR = S1
END IF
RETURN
ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN
S1 = ABSGAM
S2 = ABSALP
IF( S1.LE.S2 ) THEN
OPS = OPS + 8
TMP = S1 / S2
S = SQRT( ONE+TMP*TMP )
SESTPR = S2*S
C = ( GAMMA / S2 ) / S
S = SIGN( ONE, ALPHA ) / S
ELSE
OPS = OPS + 8
TMP = S2 / S1
C = SQRT( ONE+TMP*TMP )
SESTPR = S1*C
S = ( ALPHA / S1 ) / C
C = SIGN( ONE, GAMMA ) / C
END IF
RETURN
ELSE
*
* normal case
*
OPS = OPS + 8
ZETA1 = ALPHA / ABSEST
ZETA2 = GAMMA / ABSEST
*
B = ( ONE-ZETA1*ZETA1-ZETA2*ZETA2 )*HALF
C = ZETA1*ZETA1
IF( B.GT.ZERO ) THEN
OPS = OPS + 5
T = C / ( B+SQRT( B*B+C ) )
ELSE
OPS = OPS + 4
T = SQRT( B*B+C ) - B
END IF
*
OPS = OPS + 12
SINE = -ZETA1 / T
COSINE = -ZETA2 / ( ONE+T )
TMP = SQRT( SINE*SINE+COSINE*COSINE )
S = SINE / TMP
C = COSINE / TMP
SESTPR = SQRT( T+ONE )*ABSEST
RETURN
END IF
*
ELSE IF( JOB.EQ.2 ) THEN
*
* Estimating smallest singular value
*
* special cases
*
IF( SEST.EQ.ZERO ) THEN
SESTPR = ZERO
IF( MAX( ABSGAM, ABSALP ).EQ.ZERO ) THEN
SINE = ONE
COSINE = ZERO
ELSE
SINE = -GAMMA
COSINE = ALPHA
END IF
OPS = OPS + 7
S1 = MAX( ABS( SINE ), ABS( COSINE ) )
S = SINE / S1
C = COSINE / S1
TMP = SQRT( S*S+C*C )
S = S / TMP
C = C / TMP
RETURN
ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN
S = ZERO
C = ONE
SESTPR = ABSGAM
RETURN
ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN
S1 = ABSGAM
S2 = ABSEST
IF( S1.LE.S2 ) THEN
S = ZERO
C = ONE
SESTPR = S1
ELSE
S = ONE
C = ZERO
SESTPR = S2
END IF
RETURN
ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN
S1 = ABSGAM
S2 = ABSALP
IF( S1.LE.S2 ) THEN
OPS = OPS + 9
TMP = S1 / S2
C = SQRT( ONE+TMP*TMP )
SESTPR = ABSEST*( TMP / C )
S = -( GAMMA / S2 ) / C
C = SIGN( ONE, ALPHA ) / C
ELSE
OPS = OPS + 8
TMP = S2 / S1
S = SQRT( ONE+TMP*TMP )
SESTPR = ABSEST / S
C = ( ALPHA / S1 ) / S
S = -SIGN( ONE, GAMMA ) / S
END IF
RETURN
ELSE
*
* normal case
*
OPS = OPS + 14
ZETA1 = ALPHA / ABSEST
ZETA2 = GAMMA / ABSEST
*
NORMA = MAX( ONE+ZETA1*ZETA1+ABS( ZETA1*ZETA2 ),
$ ABS( ZETA1*ZETA2 )+ZETA2*ZETA2 )
*
* See if root is closer to zero or to ONE
*
TEST = ONE + TWO*( ZETA1-ZETA2 )*( ZETA1+ZETA2 )
IF( TEST.GE.ZERO ) THEN
*
* root is close to zero, compute directly
*
OPS = OPS + 20
B = ( ZETA1*ZETA1+ZETA2*ZETA2+ONE )*HALF
C = ZETA2*ZETA2
T = C / ( B+SQRT( ABS( B*B-C ) ) )
SINE = ZETA1 / ( ONE-T )
COSINE = -ZETA2 / T
SESTPR = SQRT( T+FOUR*EPS*EPS*NORMA )*ABSEST
ELSE
*
* root is closer to ONE, shift by that amount
*
OPS = OPS + 6
B = ( ZETA2*ZETA2+ZETA1*ZETA1-ONE )*HALF
C = ZETA1*ZETA1
IF( B.GE.ZERO ) THEN
OPS = OPS + 5
T = -C / ( B+SQRT( B*B+C ) )
ELSE
OPS = OPS + 4
T = B - SQRT( B*B+C )
END IF
OPS = OPS + 10
SINE = -ZETA1 / T
COSINE = -ZETA2 / ( ONE+T )
SESTPR = SQRT( ONE+T+FOUR*EPS*EPS*NORMA )*ABSEST
END IF
OPS = OPS + 6
TMP = SQRT( SINE*SINE+COSINE*COSINE )
S = SINE / TMP
C = COSINE / TMP
RETURN
*
END IF
END IF
RETURN
*
* End of DLAIC1
*
END
SUBROUTINE DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX,
$ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM,
$ POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO )
*
* -- LAPACK routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* December 22, 1999
*
* .. Scalar Arguments ..
INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL,
$ LDGNUM, NL, NR, NRHS, SQRE
DOUBLE PRECISION C, S
* ..
* .. Array Arguments ..
INTEGER GIVCOL( LDGCOL, * ), PERM( * )
DOUBLE PRECISION B( LDB, * ), BX( LDBX, * ), DIFL( * ),
$ DIFR( LDGNUM, * ), GIVNUM( LDGNUM, * ),
$ POLES( LDGNUM, * ), WORK( * ), Z( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLALS0 applies back the multiplying factors of either the left or the
* right singular vector matrix of a diagonal matrix appended by a row
* to the right hand side matrix B in solving the least squares problem
* using the divide-and-conquer SVD approach.
*
* For the left singular vector matrix, three types of orthogonal
* matrices are involved:
*
* (1L) Givens rotations: the number of such rotations is GIVPTR; the
* pairs of columns/rows they were applied to are stored in GIVCOL;
* and the C- and S-values of these rotations are stored in GIVNUM.
*
* (2L) Permutation. The (NL+1)-st row of B is to be moved to the first
* row, and for J=2:N, PERM(J)-th row of B is to be moved to the
* J-th row.
*
* (3L) The left singular vector matrix of the remaining matrix.
*
* For the right singular vector matrix, four types of orthogonal
* matrices are involved:
*
* (1R) The right singular vector matrix of the remaining matrix.
*
* (2R) If SQRE = 1, one extra Givens rotation to generate the right
* null space.
*
* (3R) The inverse transformation of (2L).
*
* (4R) The inverse transformation of (1L).
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* Specifies whether singular vectors are to be computed in
* factored form:
* = 0: Left singular vector matrix.
* = 1: Right singular vector matrix.
*
* NL (input) INTEGER
* The row dimension of the upper block. NL >= 1.
*
* NR (input) INTEGER
* The row dimension of the lower block. NR >= 1.
*
* SQRE (input) INTEGER
* = 0: the lower block is an NR-by-NR square matrix.
* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
*
* The bidiagonal matrix has row dimension N = NL + NR + 1,
* and column dimension M = N + SQRE.
*
* NRHS (input) INTEGER
* The number of columns of B and BX. NRHS must be at least 1.
*
* B (input/output) DOUBLE PRECISION array, dimension ( LDB, NRHS )
* On input, B contains the right hand sides of the least
* squares problem in rows 1 through M. On output, B contains
* the solution X in rows 1 through N.
*
* LDB (input) INTEGER
* The leading dimension of B. LDB must be at least
* max(1,MAX( M, N ) ).
*
* BX (workspace) DOUBLE PRECISION array, dimension ( LDBX, NRHS )
*
* LDBX (input) INTEGER
* The leading dimension of BX.
*
* PERM (input) INTEGER array, dimension ( N )
* The permutations (from deflation and sorting) applied
* to the two blocks.
*
* GIVPTR (input) INTEGER
* The number of Givens rotations which took place in this
* subproblem.
*
* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )
* Each pair of numbers indicates a pair of rows/columns
* involved in a Givens rotation.
*
* LDGCOL (input) INTEGER
* The leading dimension of GIVCOL, must be at least N.
*
* GIVNUM (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
* Each number indicates the C or S value used in the
* corresponding Givens rotation.
*
* LDGNUM (input) INTEGER
* The leading dimension of arrays DIFR, POLES and
* GIVNUM, must be at least K.
*
* POLES (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
* On entry, POLES(1:K, 1) contains the new singular
* values obtained from solving the secular equation, and
* POLES(1:K, 2) is an array containing the poles in the secular
* equation.
*
* DIFL (input) DOUBLE PRECISION array, dimension ( K ).
* On entry, DIFL(I) is the distance between I-th updated
* (undeflated) singular value and the I-th (undeflated) old
* singular value.
*
* DIFR (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ).
* On entry, DIFR(I, 1) contains the distances between I-th
* updated (undeflated) singular value and the I+1-th
* (undeflated) old singular value. And DIFR(I, 2) is the
* normalizing factor for the I-th right singular vector.
*
* Z (input) DOUBLE PRECISION array, dimension ( K )
* Contain the components of the deflation-adjusted updating row
* vector.
*
* K (input) INTEGER
* Contains the dimension of the non-deflated matrix,
* This is the order of the related secular equation. 1 <= K <=N.
*
* C (input) DOUBLE PRECISION
* C contains garbage if SQRE =0 and the C-value of a Givens
* rotation related to the right null space if SQRE = 1.
*
* S (input) DOUBLE PRECISION
* S contains garbage if SQRE =0 and the S-value of a Givens
* rotation related to the right null space if SQRE = 1.
*
* WORK (workspace) DOUBLE PRECISION array, dimension ( K )
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO, NEGONE
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, NEGONE = -1.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, J, M, N, NLP1
DOUBLE PRECISION DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, TEMP
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMV, DLACPY, DLASCL, DROT, DSCAL,
$ XERBLA
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMC3, DNRM2, DOPBL2
EXTERNAL DLAMC3, DNRM2, DOPBL2
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
INFO = -1
ELSE IF( NL.LT.1 ) THEN
INFO = -2
ELSE IF( NR.LT.1 ) THEN
INFO = -3
ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
INFO = -4
END IF
*
N = NL + NR + 1
*
IF( NRHS.LT.1 ) THEN
INFO = -5
ELSE IF( LDB.LT.N ) THEN
INFO = -7
ELSE IF( LDBX.LT.N ) THEN
INFO = -9
ELSE IF( GIVPTR.LT.0 ) THEN
INFO = -11
ELSE IF( LDGCOL.LT.N ) THEN
INFO = -13
ELSE IF( LDGNUM.LT.N ) THEN
INFO = -15
ELSE IF( K.LT.1 ) THEN
INFO = -20
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLALS0', -INFO )
RETURN
END IF
*
M = N + SQRE
NLP1 = NL + 1
*
IF( ICOMPQ.EQ.0 ) THEN
*
* Apply back orthogonal transformations from the left.
*
* Step (1L): apply back the Givens rotations performed.
*
OPS = OPS + DBLE( 6*NRHS*GIVPTR )
DO 10 I = 1, GIVPTR
CALL DROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB,
$ B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ),
$ GIVNUM( I, 1 ) )
10 CONTINUE
*
* Step (2L): permute rows of B.
*
CALL DCOPY( NRHS, B( NLP1, 1 ), LDB, BX( 1, 1 ), LDBX )
DO 20 I = 2, N
CALL DCOPY( NRHS, B( PERM( I ), 1 ), LDB, BX( I, 1 ), LDBX )
20 CONTINUE
*
* Step (3L): apply the inverse of the left singular vector
* matrix to BX.
*
IF( K.EQ.1 ) THEN
CALL DCOPY( NRHS, BX, LDBX, B, LDB )
IF( Z( 1 ).LT.ZERO ) THEN
OPS = OPS + DBLE( NRHS )
CALL DSCAL( NRHS, NEGONE, B, LDB )
END IF
ELSE
DO 50 J = 1, K
DIFLJ = DIFL( J )
DJ = POLES( J, 1 )
DSIGJ = -POLES( J, 2 )
IF( J.LT.K ) THEN
DIFRJ = -DIFR( J, 1 )
DSIGJP = -POLES( J+1, 2 )
END IF
IF( ( Z( J ).EQ.ZERO ) .OR. ( POLES( J, 2 ).EQ.ZERO ) )
$ THEN
WORK( J ) = ZERO
ELSE
OPS = OPS + DBLE( 4 )
WORK( J ) = -POLES( J, 2 )*Z( J ) / DIFLJ /
$ ( POLES( J, 2 )+DJ )
END IF
DO 30 I = 1, J - 1
IF( ( Z( I ).EQ.ZERO ) .OR.
$ ( POLES( I, 2 ).EQ.ZERO ) ) THEN
WORK( I ) = ZERO
ELSE
OPS = OPS + DBLE( 6 )
WORK( I ) = POLES( I, 2 )*Z( I ) /
$ ( DLAMC3( POLES( I, 2 ), DSIGJ )-
$ DIFLJ ) / ( POLES( I, 2 )+DJ )
END IF
30 CONTINUE
DO 40 I = J + 1, K
IF( ( Z( I ).EQ.ZERO ) .OR.
$ ( POLES( I, 2 ).EQ.ZERO ) ) THEN
WORK( I ) = ZERO
ELSE
OPS = OPS + DBLE( 6 )
WORK( I ) = POLES( I, 2 )*Z( I ) /
$ ( DLAMC3( POLES( I, 2 ), DSIGJP )+
$ DIFRJ ) / ( POLES( I, 2 )+DJ )
END IF
40 CONTINUE
WORK( 1 ) = NEGONE
OPS = OPS + 2*K + NRHS +
$ DOPBL2( 'DGEMV ', K, NRHS, 0, 0 )
TEMP = DNRM2( K, WORK, 1 )
CALL DGEMV( 'T', K, NRHS, ONE, BX, LDBX, WORK, 1, ZERO,
$ B( J, 1 ), LDB )
CALL DLASCL( 'G', 0, 0, TEMP, ONE, 1, NRHS, B( J, 1 ),
$ LDB, INFO )
50 CONTINUE
END IF
*
* Move the deflated rows of BX to B also.
*
IF( K.LT.MAX( M, N ) )
$ CALL DLACPY( 'A', N-K, NRHS, BX( K+1, 1 ), LDBX,
$ B( K+1, 1 ), LDB )
ELSE
*
* Apply back the right orthogonal transformations.
*
* Step (1R): apply back the new right singular vector matrix
* to B.
*
IF( K.EQ.1 ) THEN
CALL DCOPY( NRHS, B, LDB, BX, LDBX )
ELSE
DO 80 J = 1, K
DSIGJ = POLES( J, 2 )
IF( Z( J ).EQ.ZERO ) THEN
WORK( J ) = ZERO
ELSE
OPS = OPS + DBLE( 4 )
WORK( J ) = -Z( J ) / DIFL( J ) /
$ ( DSIGJ+POLES( J, 1 ) ) / DIFR( J, 2 )
END IF
DO 60 I = 1, J - 1
IF( Z( J ).EQ.ZERO ) THEN
WORK( I ) = ZERO
ELSE
OPS = OPS + DBLE( 6 )
WORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I+1,
$ 2 ) )-DIFR( I, 1 ) ) /
$ ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )
END IF
60 CONTINUE
DO 70 I = J + 1, K
IF( Z( J ).EQ.ZERO ) THEN
WORK( I ) = ZERO
ELSE
OPS = OPS + DBLE( 6 )
WORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I,
$ 2 ) )-DIFL( I ) ) /
$ ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )
END IF
70 CONTINUE
OPS = OPS + DOPBL2( 'DGEMV ', K, NRHS, 0, 0 )
CALL DGEMV( 'T', K, NRHS, ONE, B, LDB, WORK, 1, ZERO,
$ BX( J, 1 ), LDBX )
80 CONTINUE
END IF
*
* Step (2R): if SQRE = 1, apply back the rotation that is
* related to the right null space of the subproblem.
*
IF( SQRE.EQ.1 ) THEN
OPS = OPS + DBLE( 6*NRHS )
CALL DCOPY( NRHS, B( M, 1 ), LDB, BX( M, 1 ), LDBX )
CALL DROT( NRHS, BX( 1, 1 ), LDBX, BX( M, 1 ), LDBX, C, S )
END IF
IF( K.LT.MAX( M, N ) )
$ CALL DLACPY( 'A', N-K, NRHS, B( K+1, 1 ), LDB,
$ BX( K+1, 1 ), LDBX )
*
* Step (3R): permute rows of B.
*
CALL DCOPY( NRHS, BX( 1, 1 ), LDBX, B( NLP1, 1 ), LDB )
IF( SQRE.EQ.1 ) THEN
CALL DCOPY( NRHS, BX( M, 1 ), LDBX, B( M, 1 ), LDB )
END IF
DO 90 I = 2, N
CALL DCOPY( NRHS, BX( I, 1 ), LDBX, B( PERM( I ), 1 ), LDB )
90 CONTINUE
*
* Step (4R): apply back the Givens rotations performed.
*
OPS = OPS + DBLE( 6*NRHS*GIVPTR )
DO 100 I = GIVPTR, 1, -1
CALL DROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB,
$ B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ),
$ -GIVNUM( I, 1 ) )
100 CONTINUE
END IF
*
RETURN
*
* End of DLALS0
*
END
SUBROUTINE DLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U,
$ LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR,
$ GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK,
$ IWORK, INFO )
*
* -- LAPACK routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS,
$ SMLSIZ
* ..
* .. Array Arguments ..
INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ),
$ K( * ), PERM( LDGCOL, * )
DOUBLE PRECISION B( LDB, * ), BX( LDBX, * ), C( * ),
$ DIFL( LDU, * ), DIFR( LDU, * ),
$ GIVNUM( LDU, * ), POLES( LDU, * ), S( * ),
$ U( LDU, * ), VT( LDU, * ), WORK( * ),
$ Z( LDU, * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLALSA is an itermediate step in solving the least squares problem
* by computing the SVD of the coefficient matrix in compact form (The
* singular vectors are computed as products of simple orthorgonal
* matrices.).
*
* If ICOMPQ = 0, DLALSA applies the inverse of the left singular vector
* matrix of an upper bidiagonal matrix to the right hand side; and if
* ICOMPQ = 1, DLALSA applies the right singular vector matrix to the
* right hand side. The singular vector matrices were generated in
* compact form by DLALSA.
*
* Arguments
* =========
*
*
* ICOMPQ (input) INTEGER
* Specifies whether the left or the right singular vector
* matrix is involved.
* = 0: Left singular vector matrix
* = 1: Right singular vector matrix
*
* SMLSIZ (input) INTEGER
* The maximum size of the subproblems at the bottom of the
* computation tree.
*
* N (input) INTEGER
* The row and column dimensions of the upper bidiagonal matrix.
*
* NRHS (input) INTEGER
* The number of columns of B and BX. NRHS must be at least 1.
*
* B (input) DOUBLE PRECISION array, dimension ( LDB, NRHS )
* On input, B contains the right hand sides of the least
* squares problem in rows 1 through M. On output, B contains
* the solution X in rows 1 through N.
*
* LDB (input) INTEGER
* The leading dimension of B in the calling subprogram.
* LDB must be at least max(1,MAX( M, N ) ).
*
* BX (output) DOUBLE PRECISION array, dimension ( LDBX, NRHS )
* On exit, the result of applying the left or right singular
* vector matrix to B.
*
* LDBX (input) INTEGER
* The leading dimension of BX.
*
* U (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ).
* On entry, U contains the left singular vector matrices of all
* subproblems at the bottom level.
*
* LDU (input) INTEGER, LDU = > N.
* The leading dimension of arrays U, VT, DIFL, DIFR,
* POLES, GIVNUM, and Z.
*
* VT (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ).
* On entry, VT' contains the right singular vector matrices of
* all subproblems at the bottom level.
*
* K (input) INTEGER array, dimension ( N ).
*
* DIFL (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).
* where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.
*
* DIFR (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
* On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record
* distances between singular values on the I-th level and
* singular values on the (I -1)-th level, and DIFR(*, 2 * I)
* record the normalizing factors of the right singular vectors
* matrices of subproblems on I-th level.
*
* Z (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).
* On entry, Z(1, I) contains the components of the deflation-
* adjusted updating row vector for subproblems on the I-th
* level.
*
* POLES (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
* On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old
* singular values involved in the secular equations on the I-th
* level.
*
* GIVPTR (input) INTEGER array, dimension ( N ).
* On entry, GIVPTR( I ) records the number of Givens
* rotations performed on the I-th problem on the computation
* tree.
*
* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ).
* On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the
* locations of Givens rotations performed on the I-th level on
* the computation tree.
*
* LDGCOL (input) INTEGER, LDGCOL = > N.
* The leading dimension of arrays GIVCOL and PERM.
*
* PERM (input) INTEGER array, dimension ( LDGCOL, NLVL ).
* On entry, PERM(*, I) records permutations done on the I-th
* level of the computation tree.
*
* GIVNUM (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
* On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-
* values of Givens rotations performed on the I-th level on the
* computation tree.
*
* C (input) DOUBLE PRECISION array, dimension ( N ).
* On entry, if the I-th subproblem is not square,
* C( I ) contains the C-value of a Givens rotation related to
* the right null space of the I-th subproblem.
*
* S (input) DOUBLE PRECISION array, dimension ( N ).
* On entry, if the I-th subproblem is not square,
* S( I ) contains the S-value of a Givens rotation related to
* the right null space of the I-th subproblem.
*
* WORK (workspace) DOUBLE PRECISION array.
* The dimension must be at least N.
*
* IWORK (workspace) INTEGER array.
* The dimension must be at least 3 * N
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, I1, IC, IM1, INODE, J, LF, LL, LVL, LVL2,
$ ND, NDB1, NDIML, NDIMR, NL, NLF, NLP1, NLVL,
$ NR, NRF, NRP1, SQRE
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMM, DLALS0, DLASDT, XERBLA
* ..
* .. External Functions ..
DOUBLE PRECISION DOPBL3
EXTERNAL DOPBL3
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
INFO = -1
ELSE IF( SMLSIZ.LT.3 ) THEN
INFO = -2
ELSE IF( N.LT.SMLSIZ ) THEN
INFO = -3
ELSE IF( NRHS.LT.1 ) THEN
INFO = -4
ELSE IF( LDB.LT.N ) THEN
INFO = -6
ELSE IF( LDBX.LT.N ) THEN
INFO = -8
ELSE IF( LDU.LT.N ) THEN
INFO = -10
ELSE IF( LDGCOL.LT.N ) THEN
INFO = -19
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLALSA', -INFO )
RETURN
END IF
*
* Book-keeping and setting up the computation tree.
*
INODE = 1
NDIML = INODE + N
NDIMR = NDIML + N
*
CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ),
$ IWORK( NDIMR ), SMLSIZ )
*
* The following code applies back the left singular vector factors.
* For applying back the right singular vector factors, go to 50.
*
IF( ICOMPQ.EQ.1 ) THEN
GO TO 50
END IF
*
* The nodes on the bottom level of the tree were solved by DLASDQ.
* The corresponding left and right singular vector matrices are in
* explicit form. First apply back the left singular vector matrices.
*
NDB1 = ( ND+1 ) / 2
DO 10 I = NDB1, ND
*
* IC : center row of each node
* NL : number of rows of left subproblem
* NR : number of rows of right subproblem
* NLF: starting row of the left subproblem
* NRF: starting row of the right subproblem
*
I1 = I - 1
IC = IWORK( INODE+I1 )
NL = IWORK( NDIML+I1 )
NR = IWORK( NDIMR+I1 )
NLF = IC - NL
NRF = IC + 1
OPS = OPS + DOPBL3( 'DGEMM ', NL, NRHS, NL )
OPS = OPS + DOPBL3( 'DGEMM ', NR, NRHS, NR )
CALL DGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU,
$ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX )
CALL DGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU,
$ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX )
10 CONTINUE
*
* Next copy the rows of B that correspond to unchanged rows
* in the bidiagonal matrix to BX.
*
DO 20 I = 1, ND
IC = IWORK( INODE+I-1 )
CALL DCOPY( NRHS, B( IC, 1 ), LDB, BX( IC, 1 ), LDBX )
20 CONTINUE
*
* Finally go through the left singular vector matrices of all
* the other subproblems bottom-up on the tree.
*
J = 2**NLVL
SQRE = 0
*
DO 40 LVL = NLVL, 1, -1
LVL2 = 2*LVL - 1
*
* find the first node LF and last node LL on
* the current level LVL
*
IF( LVL.EQ.1 ) THEN
LF = 1
LL = 1
ELSE
LF = 2**( LVL-1 )
LL = 2*LF - 1
END IF
DO 30 I = LF, LL
IM1 = I - 1
IC = IWORK( INODE+IM1 )
NL = IWORK( NDIML+IM1 )
NR = IWORK( NDIMR+IM1 )
NLF = IC - NL
NRF = IC + 1
J = J - 1
CALL DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, BX( NLF, 1 ), LDBX,
$ B( NLF, 1 ), LDB, PERM( NLF, LVL ),
$ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
$ GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ),
$ DIFL( NLF, LVL ), DIFR( NLF, LVL2 ),
$ Z( NLF, LVL ), K( J ), C( J ), S( J ), WORK,
$ INFO )
30 CONTINUE
40 CONTINUE
GO TO 90
*
* ICOMPQ = 1: applying back the right singular vector factors.
*
50 CONTINUE
*
* First now go through the right singular vector matrices of all
* the tree nodes top-down.
*
J = 0
DO 70 LVL = 1, NLVL
LVL2 = 2*LVL - 1
*
* Find the first node LF and last node LL on
* the current level LVL.
*
IF( LVL.EQ.1 ) THEN
LF = 1
LL = 1
ELSE
LF = 2**( LVL-1 )
LL = 2*LF - 1
END IF
DO 60 I = LL, LF, -1
IM1 = I - 1
IC = IWORK( INODE+IM1 )
NL = IWORK( NDIML+IM1 )
NR = IWORK( NDIMR+IM1 )
NLF = IC - NL
NRF = IC + 1
IF( I.EQ.LL ) THEN
SQRE = 0
ELSE
SQRE = 1
END IF
J = J + 1
CALL DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B( NLF, 1 ), LDB,
$ BX( NLF, 1 ), LDBX, PERM( NLF, LVL ),
$ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
$ GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ),
$ DIFL( NLF, LVL ), DIFR( NLF, LVL2 ),
$ Z( NLF, LVL ), K( J ), C( J ), S( J ), WORK,
$ INFO )
60 CONTINUE
70 CONTINUE
*
* The nodes on the bottom level of the tree were solved by DLASDQ.
* The corresponding right singular vector matrices are in explicit
* form. Apply them back.
*
NDB1 = ( ND+1 ) / 2
DO 80 I = NDB1, ND
I1 = I - 1
IC = IWORK( INODE+I1 )
NL = IWORK( NDIML+I1 )
NR = IWORK( NDIMR+I1 )
NLP1 = NL + 1
IF( I.EQ.ND ) THEN
NRP1 = NR
ELSE
NRP1 = NR + 1
END IF
NLF = IC - NL
NRF = IC + 1
OPS = OPS + DOPBL3( 'DGEMM ', NLP1, NRHS, NLP1 )
OPS = OPS + DOPBL3( 'DGEMM ', NRP1, NRHS, NRP1 )
CALL DGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU,
$ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX )
CALL DGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU,
$ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX )
80 CONTINUE
*
90 CONTINUE
*
RETURN
*
* End of DLALSA
*
END
SUBROUTINE DLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND,
$ RANK, WORK, IWORK, INFO )
*
* -- LAPACK routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDB, N, NRHS, RANK, SMLSIZ
DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION B( LDB, * ), D( * ), E( * ), WORK( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLALSD uses the singular value decomposition of A to solve the least
* squares problem of finding X to minimize the Euclidean norm of each
* column of A*X-B, where A is N-by-N upper bidiagonal, and X and B
* are N-by-NRHS. The solution X overwrites B.
*
* The singular values of A smaller than RCOND times the largest
* singular value are treated as zero in solving the least squares
* problem; in this case a minimum norm solution is returned.
* The actual singular values are returned in D in ascending order.
*
* This code makes very mild assumptions about floating point
* arithmetic. It will work on machines with a guard digit in
* add/subtract, or on those binary machines without guard digits
* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
* It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': D and E define an upper bidiagonal matrix.
* = 'L': D and E define a lower bidiagonal matrix.
*
* SMLSIZ (input) INTEGER
* The maximum size of the subproblems at the bottom of the
* computation tree.
*
* N (input) INTEGER
* The dimension of the bidiagonal matrix. N >= 0.
*
* NRHS (input) INTEGER
* The number of columns of B. NRHS must be at least 1.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry D contains the main diagonal of the bidiagonal
* matrix. On exit, if INFO = 0, D contains its singular values.
*
* E (input) DOUBLE PRECISION array, dimension (N-1)
* Contains the super-diagonal entries of the bidiagonal matrix.
* On exit, E has been destroyed.
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On input, B contains the right hand sides of the least
* squares problem. On output, B contains the solution X.
*
* LDB (input) INTEGER
* The leading dimension of B in the calling subprogram.
* LDB must be at least max(1,N).
*
* RCOND (input) DOUBLE PRECISION
* The singular values of A less than or equal to RCOND times
* the largest singular value are treated as zero in solving
* the least squares problem. If RCOND is negative,
* machine precision is used instead.
* For example, if diag(S)*X=B were the least squares problem,
* where diag(S) is a diagonal matrix of singular values, the
* solution would be X(i) = B(i) / S(i) if S(i) is greater than
* RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to
* RCOND*max(S).
*
* RANK (output) INTEGER
* The number of singular values of A greater than RCOND times
* the largest singular value.
*
* WORK (workspace) DOUBLE PRECISION array, dimension at least
* (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2),
* where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1).
*
* IWORK (workspace) INTEGER array, dimension at least
* (3*N*NLVL + 11*N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: The algorithm failed to compute an singular value while
* working on the submatrix lying in rows and columns
* INFO/(N+1) through MOD(INFO,N+1).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
* ..
* .. Local Scalars ..
INTEGER BX, BXST, C, DIFL, DIFR, GIVCOL, GIVNUM,
$ GIVPTR, I, ICMPQ1, ICMPQ2, IWK, J, K, NLVL,
$ NM1, NSIZE, NSUB, NWORK, PERM, POLES, S, SIZEI,
$ SMLSZP, SQRE, ST, ST1, U, VT, Z
DOUBLE PRECISION CS, EPS, ORGNRM, R, SN, TOL
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMM, DLACPY, DLALSA, DLARTG, DLASCL,
$ DLASDA, DLASDQ, DLASET, DLASRT, DROT, XERBLA
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH, DLANST, DOPBL3
EXTERNAL IDAMAX, DLAMCH, DLANST, DOPBL3
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, ABS, INT, LOG, SIGN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.1 ) THEN
INFO = -4
ELSE IF( ( LDB.LT.1 ) .OR. ( LDB.LT.N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLALSD', -INFO )
RETURN
END IF
*
EPS = DLAMCH( 'Epsilon' )
*
* Set up the tolerance.
*
IF( ( RCOND.LE.ZERO ) .OR. ( RCOND.GE.ONE ) ) THEN
RCOND = EPS
END IF
*
RANK = 0
*
* Quick return if possible.
*
IF( N.EQ.0 ) THEN
RETURN
ELSE IF( N.EQ.1 ) THEN
IF( D( 1 ).EQ.ZERO ) THEN
CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, B, LDB )
ELSE
RANK = 1
OPS = OPS + DBLE( 2*NRHS )
CALL DLASCL( 'G', 0, 0, D( 1 ), ONE, 1, NRHS, B, LDB, INFO )
D( 1 ) = ABS( D( 1 ) )
END IF
RETURN
END IF
*
* Rotate the matrix if it is lower bidiagonal.
*
IF( UPLO.EQ.'L' ) THEN
OPS = OPS + DBLE( 6*( N-1 ) )
DO 10 I = 1, N - 1
CALL DLARTG( D( I ), E( I ), CS, SN, R )
D( I ) = R
E( I ) = SN*D( I+1 )
D( I+1 ) = CS*D( I+1 )
IF( NRHS.EQ.1 ) THEN
OPS = OPS + DBLE( 6 )
CALL DROT( 1, B( I, 1 ), 1, B( I+1, 1 ), 1, CS, SN )
ELSE
WORK( I*2-1 ) = CS
WORK( I*2 ) = SN
END IF
10 CONTINUE
IF( NRHS.GT.1 ) THEN
OPS = OPS + DBLE( 6*( N-1 )*NRHS )
DO 30 I = 1, NRHS
DO 20 J = 1, N - 1
CS = WORK( J*2-1 )
SN = WORK( J*2 )
CALL DROT( 1, B( J, I ), 1, B( J+1, I ), 1, CS, SN )
20 CONTINUE
30 CONTINUE
END IF
END IF
*
* Scale.
*
NM1 = N - 1
ORGNRM = DLANST( 'M', N, D, E )
IF( ORGNRM.EQ.ZERO ) THEN
CALL DLASET( 'A', N, NRHS, ZERO, ZERO, B, LDB )
RETURN
END IF
*
OPS = OPS + DBLE( N + NM1 )
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, INFO )
*
* If N is smaller than the minimum divide size SMLSIZ, then solve
* the problem with another solver.
*
IF( N.LE.SMLSIZ ) THEN
NWORK = 1 + N*N
CALL DLASET( 'A', N, N, ZERO, ONE, WORK, N )
CALL DLASDQ( 'U', 0, N, N, 0, NRHS, D, E, WORK, N, WORK, N, B,
$ LDB, WORK( NWORK ), INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
OPS = OPS + DBLE( 1 )
TOL = RCOND*ABS( D( IDAMAX( N, D, 1 ) ) )
DO 40 I = 1, N
IF( D( I ).LE.TOL ) THEN
CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
ELSE
OPS = OPS + DBLE( NRHS )
CALL DLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS, B( I, 1 ),
$ LDB, INFO )
RANK = RANK + 1
END IF
40 CONTINUE
OPS = OPS + DOPBL3( 'DGEMM ', N, NRHS, N )
CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, WORK, N, B, LDB, ZERO,
$ WORK( NWORK ), N )
CALL DLACPY( 'A', N, NRHS, WORK( NWORK ), N, B, LDB )
*
* Unscale.
*
OPS = OPS + DBLE( N + N*NRHS )
CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
CALL DLASRT( 'D', N, D, INFO )
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO )
*
RETURN
END IF
*
* Book-keeping and setting up some constants.
*
NLVL = INT( LOG( DBLE( N ) / DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1
*
SMLSZP = SMLSIZ + 1
*
U = 1
VT = 1 + SMLSIZ*N
DIFL = VT + SMLSZP*N
DIFR = DIFL + NLVL*N
Z = DIFR + NLVL*N*2
C = Z + NLVL*N
S = C + N
POLES = S + N
GIVNUM = POLES + 2*NLVL*N
BX = GIVNUM + 2*NLVL*N
NWORK = BX + N*NRHS
*
SIZEI = 1 + N
K = SIZEI + N
GIVPTR = K + N
PERM = GIVPTR + N
GIVCOL = PERM + NLVL*N
IWK = GIVCOL + NLVL*N*2
*
ST = 1
SQRE = 0
ICMPQ1 = 1
ICMPQ2 = 0
NSUB = 0
*
DO 50 I = 1, N
IF( ABS( D( I ) ).LT.EPS ) THEN
D( I ) = SIGN( EPS, D( I ) )
END IF
50 CONTINUE
*
DO 60 I = 1, NM1
IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN
NSUB = NSUB + 1
IWORK( NSUB ) = ST
*
* Subproblem found. First determine its size and then
* apply divide and conquer on it.
*
IF( I.LT.NM1 ) THEN
*
* A subproblem with E(I) small for I < NM1.
*
NSIZE = I - ST + 1
IWORK( SIZEI+NSUB-1 ) = NSIZE
ELSE IF( ABS( E( I ) ).GE.EPS ) THEN
*
* A subproblem with E(NM1) not too small but I = NM1.
*
NSIZE = N - ST + 1
IWORK( SIZEI+NSUB-1 ) = NSIZE
ELSE
*
* A subproblem with E(NM1) small. This implies an
* 1-by-1 subproblem at D(N), which is not solved
* explicitly.
*
NSIZE = I - ST + 1
IWORK( SIZEI+NSUB-1 ) = NSIZE
NSUB = NSUB + 1
IWORK( NSUB ) = N
IWORK( SIZEI+NSUB-1 ) = 1
CALL DCOPY( NRHS, B( N, 1 ), LDB, WORK( BX+NM1 ), N )
END IF
ST1 = ST - 1
IF( NSIZE.EQ.1 ) THEN
*
* This is a 1-by-1 subproblem and is not solved
* explicitly.
*
CALL DCOPY( NRHS, B( ST, 1 ), LDB, WORK( BX+ST1 ), N )
ELSE IF( NSIZE.LE.SMLSIZ ) THEN
*
* This is a small subproblem and is solved by DLASDQ.
*
CALL DLASET( 'A', NSIZE, NSIZE, ZERO, ONE,
$ WORK( VT+ST1 ), N )
CALL DLASDQ( 'U', 0, NSIZE, NSIZE, 0, NRHS, D( ST ),
$ E( ST ), WORK( VT+ST1 ), N, WORK( NWORK ),
$ N, B( ST, 1 ), LDB, WORK( NWORK ), INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
CALL DLACPY( 'A', NSIZE, NRHS, B( ST, 1 ), LDB,
$ WORK( BX+ST1 ), N )
ELSE
*
* A large problem. Solve it using divide and conquer.
*
CALL DLASDA( ICMPQ1, SMLSIZ, NSIZE, SQRE, D( ST ),
$ E( ST ), WORK( U+ST1 ), N, WORK( VT+ST1 ),
$ IWORK( K+ST1 ), WORK( DIFL+ST1 ),
$ WORK( DIFR+ST1 ), WORK( Z+ST1 ),
$ WORK( POLES+ST1 ), IWORK( GIVPTR+ST1 ),
$ IWORK( GIVCOL+ST1 ), N, IWORK( PERM+ST1 ),
$ WORK( GIVNUM+ST1 ), WORK( C+ST1 ),
$ WORK( S+ST1 ), WORK( NWORK ), IWORK( IWK ),
$ INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
BXST = BX + ST1
CALL DLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, B( ST, 1 ),
$ LDB, WORK( BXST ), N, WORK( U+ST1 ), N,
$ WORK( VT+ST1 ), IWORK( K+ST1 ),
$ WORK( DIFL+ST1 ), WORK( DIFR+ST1 ),
$ WORK( Z+ST1 ), WORK( POLES+ST1 ),
$ IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N,
$ IWORK( PERM+ST1 ), WORK( GIVNUM+ST1 ),
$ WORK( C+ST1 ), WORK( S+ST1 ), WORK( NWORK ),
$ IWORK( IWK ), INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
END IF
ST = I + 1
END IF
60 CONTINUE
*
* Apply the singular values and treat the tiny ones as zero.
*
TOL = RCOND*ABS( D( IDAMAX( N, D, 1 ) ) )
*
DO 70 I = 1, N
*
* Some of the elements in D can be negative because 1-by-1
* subproblems were not solved explicitly.
*
IF( ABS( D( I ) ).LE.TOL ) THEN
CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, WORK( BX+I-1 ), N )
ELSE
RANK = RANK + 1
OPS = OPS + DBLE( NRHS )
CALL DLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS,
$ WORK( BX+I-1 ), N, INFO )
END IF
D( I ) = ABS( D( I ) )
70 CONTINUE
*
* Now apply back the right singular vectors.
*
ICMPQ2 = 1
DO 80 I = 1, NSUB
ST = IWORK( I )
ST1 = ST - 1
NSIZE = IWORK( SIZEI+I-1 )
BXST = BX + ST1
IF( NSIZE.EQ.1 ) THEN
CALL DCOPY( NRHS, WORK( BXST ), N, B( ST, 1 ), LDB )
ELSE IF( NSIZE.LE.SMLSIZ ) THEN
OPS = OPS + DOPBL3( 'DGEMM ', NSIZE, NRHS, NSIZE )
CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
$ WORK( VT+ST1 ), N, WORK( BXST ), N, ZERO,
$ B( ST, 1 ), LDB )
ELSE
CALL DLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, WORK( BXST ), N,
$ B( ST, 1 ), LDB, WORK( U+ST1 ), N,
$ WORK( VT+ST1 ), IWORK( K+ST1 ),
$ WORK( DIFL+ST1 ), WORK( DIFR+ST1 ),
$ WORK( Z+ST1 ), WORK( POLES+ST1 ),
$ IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N,
$ IWORK( PERM+ST1 ), WORK( GIVNUM+ST1 ),
$ WORK( C+ST1 ), WORK( S+ST1 ), WORK( NWORK ),
$ IWORK( IWK ), INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
END IF
80 CONTINUE
*
* Unscale and sort the singular values.
*
OPS = OPS + DBLE( N + N*NRHS )
CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
CALL DLASRT( 'D', N, D, INFO )
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO )
*
RETURN
*
* End of DLALSD
*
END
DOUBLE PRECISION FUNCTION DOPLA( SUBNAM, M, N, KL, KU, NB )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
INTEGER KL, KU, M, N, NB
* ..
*
* Purpose
* =======
*
* DOPLA computes an approximation of the number of floating point
* operations used by the subroutine SUBNAM with the given values
* of the parameters M, N, KL, KU, and NB.
*
* This version counts operations for the LAPACK subroutines.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* M (input) INTEGER
* The number of rows of the coefficient matrix. M >= 0.
*
* N (input) INTEGER
* The number of columns of the coefficient matrix.
* For solve routine when the matrix is square,
* N is the number of right hand sides. N >= 0.
*
* KL (input) INTEGER
* The lower band width of the coefficient matrix.
* If needed, 0 <= KL <= M-1.
* For xGEQRS, KL is the number of right hand sides.
*
* KU (input) INTEGER
* The upper band width of the coefficient matrix.
* If needed, 0 <= KU <= N-1.
*
* NB (input) INTEGER
* The block size. If needed, NB >= 1.
*
* Notes
* =====
*
* In the comments below, the association is given between arguments
* in the requested subroutine and local arguments. For example,
*
* xGETRS: N, NRHS => M, N
*
* means that arguments N and NRHS in DGETRS are passed to arguments
* M and N in this procedure.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL CORZ, SORD
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 C3
INTEGER I
DOUBLE PRECISION ADDFAC, ADDS, EK, EM, EMN, EN, MULFAC, MULTS,
$ WL, WU
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* --------------------------------------------------------
* Initialize DOPLA to 0 and do a quick return if possible.
* --------------------------------------------------------
*
DOPLA = 0
MULTS = 0
ADDS = 0
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
SORD = LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' )
CORZ = LSAME( C1, 'C' ) .OR. LSAME( C1, 'Z' )
IF( M.LE.0 .OR. .NOT.( SORD .OR. CORZ ) )
$ RETURN
*
* ---------------------------------------------------------
* If the coefficient matrix is real, count each add as 1
* operation and each multiply as 1 operation.
* If the coefficient matrix is complex, count each add as 2
* operations and each multiply as 6 operations.
* ---------------------------------------------------------
*
IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN
ADDFAC = 1
MULFAC = 1
ELSE
ADDFAC = 2
MULFAC = 6
END IF
EM = M
EN = N
EK = KL
*
* ---------------------------------
* GE: GEneral rectangular matrices
* ---------------------------------
*
IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
* xGETRF: M, N => M, N
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
EMN = MIN( M, N )
ADDS = EMN*( EM*EN-( EM+EN )*( EMN+1.D0 ) / 2.D0+
$ ( EMN+1.D0 )*( 2.D0*EMN+1.D0 ) / 6.D0 )
MULTS = ADDS + EMN*( EM-( EMN+1.D0 ) / 2.D0 )
*
* xGETRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*EM*EM
ADDS = EN*( EM*( EM-1.D0 ) )
*
* xGETRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 5.D0 / 6.D0+EM*( 1.D0 / 2.D0+EM*( 2.D0 /
$ 3.D0 ) ) )
ADDS = EM*( 5.D0 / 6.D0+EM*( -3.D0 / 2.D0+EM*( 2.D0 /
$ 3.D0 ) ) )
*
* xGEQRF or xGEQLF: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'QRF' ) .OR.
$ LSAMEN( 3, C3, 'QR2' ) .OR.
$ LSAMEN( 3, C3, 'QLF' ) .OR. LSAMEN( 3, C3, 'QL2' ) )
$ THEN
IF( M.GE.N ) THEN
MULTS = EN*( ( ( 23.D0 / 6.D0 )+EM+EN / 2.D0 )+EN*
$ ( EM-EN / 3.D0 ) )
ADDS = EN*( ( 5.D0 / 6.D0 )+EN*
$ ( 1.D0 / 2.D0+( EM-EN / 3.D0 ) ) )
ELSE
MULTS = EM*( ( ( 23.D0 / 6.D0 )+2.D0*EN-EM / 2.D0 )+EM*
$ ( EN-EM / 3.D0 ) )
ADDS = EM*( ( 5.D0 / 6.D0 )+EN-EM / 2.D0+EM*
$ ( EN-EM / 3.D0 ) )
END IF
*
* xGERQF or xGELQF: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'RQF' ) .OR.
$ LSAMEN( 3, C3, 'RQ2' ) .OR.
$ LSAMEN( 3, C3, 'LQF' ) .OR. LSAMEN( 3, C3, 'LQ2' ) )
$ THEN
IF( M.GE.N ) THEN
MULTS = EN*( ( ( 29.D0 / 6.D0 )+EM+EN / 2.D0 )+EN*
$ ( EM-EN / 3.D0 ) )
ADDS = EN*( ( 5.D0 / 6.D0 )+EM+EN*
$ ( -1.D0 / 2.D0+( EM-EN / 3.D0 ) ) )
ELSE
MULTS = EM*( ( ( 29.D0 / 6.D0 )+2.D0*EN-EM / 2.D0 )+EM*
$ ( EN-EM / 3.D0 ) )
ADDS = EM*( ( 5.D0 / 6.D0 )+EM / 2.D0+EM*
$ ( EN-EM / 3.D0 ) )
END IF
*
* xGEQPF: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'QPF' ) ) THEN
EMN = MIN( M, N )
MULTS = 2*EN*EN + EMN*( 3*EM+5*EN+2*EM*EN-( EMN+1 )*
$ ( 4+EN+EM-( 2*EMN+1 ) / 3 ) )
ADDS = EN*EN + EMN*( 2*EM+EN+2*EM*EN-( EMN+1 )*
$ ( 2+EN+EM-( 2*EMN+1 ) / 3 ) )
*
* xGEQRS or xGERQS: M, N, NRHS => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'QRS' ) .OR. LSAMEN( 3, C3, 'RQS' ) )
$ THEN
MULTS = EK*( EN*( 2.D0-EK )+EM*
$ ( 2.D0*EN+( EM+1.D0 ) / 2.D0 ) )
ADDS = EK*( EN*( 1.D0-EK )+EM*
$ ( 2.D0*EN+( EM-1.D0 ) / 2.D0 ) )
*
* xGELQS or xGEQLS: M, N, NRHS => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'LQS' ) .OR. LSAMEN( 3, C3, 'QLS' ) )
$ THEN
MULTS = EK*( EM*( 2.D0-EK )+EN*
$ ( 2.D0*EM+( EN+1.D0 ) / 2.D0 ) )
ADDS = EK*( EM*( 1.D0-EK )+EN*
$ ( 2.D0*EM+( EN-1.D0 ) / 2.D0 ) )
*
* xGEBRD: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'BRD' ) ) THEN
IF( M.GE.N ) THEN
MULTS = EN*( 20.D0 / 3.D0+EN*
$ ( 2.D0+( 2.D0*EM-( 2.D0 / 3.D0 )*EN ) ) )
ADDS = EN*( 5.D0 / 3.D0+( EN-EM )+EN*
$ ( 2.D0*EM-( 2.D0 / 3.D0 )*EN ) )
ELSE
MULTS = EM*( 20.D0 / 3.D0+EM*
$ ( 2.D0+( 2.D0*EN-( 2.D0 / 3.D0 )*EM ) ) )
ADDS = EM*( 5.D0 / 3.D0+( EM-EN )+EM*
$ ( 2.D0*EN-( 2.D0 / 3.D0 )*EM ) )
END IF
*
* xGEHRD: N => M
*
ELSE IF( LSAMEN( 3, C3, 'HRD' ) ) THEN
IF( M.EQ.1 ) THEN
MULTS = 0.D0
ADDS = 0.D0
ELSE
MULTS = -13.D0 + EM*( -7.D0 / 6.D0+EM*
$ ( 0.5D0+EM*( 5.D0 / 3.D0 ) ) )
ADDS = -8.D0 + EM*( -2.D0 / 3.D0+EM*
$ ( -1.D0+EM*( 5.D0 / 3.D0 ) ) )
END IF
*
END IF
*
* ----------------------------
* GB: General Banded matrices
* ----------------------------
* Note: The operation count is overestimated because
* it is assumed that the factor U fills in to the maximum
* extent, i.e., that its bandwidth goes from KU to KL + KU.
*
ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
*
* xGBTRF: M, N, KL, KU => M, N, KL, KU
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
DO 10 I = MIN( M, N ), 1, -1
WL = MAX( 0, MIN( KL, M-I ) )
WU = MAX( 0, MIN( KL+KU, N-I ) )
MULTS = MULTS + WL*( 1.D0+WU )
ADDS = ADDS + WL*WU
10 CONTINUE
*
* xGBTRS: N, NRHS, KL, KU => M, N, KL, KU
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
WL = MAX( 0, MIN( KL, M-1 ) )
WU = MAX( 0, MIN( KL+KU, M-1 ) )
MULTS = EN*( EM*( WL+1.D0+WU )-0.5D0*
$ ( WL*( WL+1.D0 )+WU*( WU+1.D0 ) ) )
ADDS = EN*( EM*( WL+WU )-0.5D0*
$ ( WL*( WL+1.D0 )+WU*( WU+1.D0 ) ) )
*
END IF
*
* --------------------------------------
* PO: POsitive definite matrices
* PP: Positive definite Packed matrices
* --------------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'PP' ) ) THEN
*
* xPOTRF: N => M
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = EM*( 1.D0 / 3.D0+EM*( 1.D0 / 2.D0+EM*( 1.D0 /
$ 6.D0 ) ) )
ADDS = ( 1.D0 / 6.D0 )*EM*( -1.D0+EM*EM )
*
* xPOTRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*( EM*( EM+1.D0 ) )
ADDS = EN*( EM*( EM-1.D0 ) )
*
* xPOTRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 2.D0 / 3.D0+EM*( 1.D0+EM*( 1.D0 / 3.D0 ) ) )
ADDS = EM*( 1.D0 / 6.D0+EM*( -1.D0 / 2.D0+EM*( 1.D0 /
$ 3.D0 ) ) )
*
END IF
*
* ------------------------------------
* PB: Positive definite Band matrices
* ------------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN
*
* xPBTRF: N, K => M, KL
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = EK*( -2.D0 / 3.D0+EK*( -1.D0+EK*( -1.D0 / 3.D0 ) ) )
$ + EM*( 1.D0+EK*( 3.D0 / 2.D0+EK*( 1.D0 / 2.D0 ) ) )
ADDS = EK*( -1.D0 / 6.D0+EK*( -1.D0 / 2.D0+EK*( -1.D0 /
$ 3.D0 ) ) ) + EM*( EK / 2.D0*( 1.D0+EK ) )
*
* xPBTRS: N, NRHS, K => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*( ( 2*EM-EK )*( EK+1.D0 ) )
ADDS = EN*( EK*( 2*EM-( EK+1.D0 ) ) )
*
END IF
*
* ----------------------------------
* PT: Positive definite Tridiagonal
* ----------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'PT' ) ) THEN
*
* xPTTRF: N => M
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = 2*( EM-1 )
ADDS = EM - 1
*
* xPTTRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*( 3*EM-2 )
ADDS = EN*( 2*( EM-1 ) )
*
* xPTSV: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
MULTS = 2*( EM-1 ) + EN*( 3*EM-2 )
ADDS = EM - 1 + EN*( 2*( EM-1 ) )
END IF
*
* --------------------------------------------------------
* SY: SYmmetric indefinite matrices
* SP: Symmetric indefinite Packed matrices
* HE: HErmitian indefinite matrices (complex only)
* HP: Hermitian indefinite Packed matrices (complex only)
* --------------------------------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHP' ) ) THEN
*
* xSYTRF: N => M
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = EM*( 10.D0 / 3.D0+EM*
$ ( 1.D0 / 2.D0+EM*( 1.D0 / 6.D0 ) ) )
ADDS = EM / 6.D0*( -1.D0+EM*EM )
*
* xSYTRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*EM*EM
ADDS = EN*( EM*( EM-1.D0 ) )
*
* xSYTRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 2.D0 / 3.D0+EM*EM*( 1.D0 / 3.D0 ) )
ADDS = EM*( -1.D0 / 3.D0+EM*EM*( 1.D0 / 3.D0 ) )
*
* xSYTRD, xSYTD2: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRD' ) .OR. LSAMEN( 3, C3, 'TD2' ) )
$ THEN
IF( M.EQ.1 ) THEN
MULTS = 0.D0
ADDS = 0.D0
ELSE
MULTS = -15.D0 + EM*( -1.D0 / 6.D0+EM*
$ ( 5.D0 / 2.D0+EM*( 2.D0 / 3.D0 ) ) )
ADDS = -4.D0 + EM*( -8.D0 / 3.D0+EM*
$ ( 1.D0+EM*( 2.D0 / 3.D0 ) ) )
END IF
END IF
*
* -------------------
* Triangular matrices
* -------------------
*
ELSE IF( LSAMEN( 2, C2, 'TR' ) .OR. LSAMEN( 2, C2, 'TP' ) ) THEN
*
* xTRTRS: N, NRHS => M, N
*
IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*EM*( EM+1.D0 ) / 2.D0
ADDS = EN*EM*( EM-1.D0 ) / 2.D0
*
* xTRTRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 1.D0 / 3.D0+EM*( 1.D0 / 2.D0+EM*( 1.D0 /
$ 6.D0 ) ) )
ADDS = EM*( 1.D0 / 3.D0+EM*( -1.D0 / 2.D0+EM*( 1.D0 /
$ 6.D0 ) ) )
*
END IF
*
ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
*
* xTBTRS: N, NRHS, K => M, N, KL
*
IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*( EM*( EM+1.D0 ) / 2.D0-( EM-EK-1.D0 )*
$ ( EM-EK ) / 2.D0 )
ADDS = EN*( EM*( EM-1.D0 ) / 2.D0-( EM-EK-1.D0 )*( EM-EK ) /
$ 2.D0 )
END IF
*
* --------------------
* Trapezoidal matrices
* --------------------
*
ELSE IF( LSAMEN( 2, C2, 'TZ' ) ) THEN
*
* xTZRQF: M, N => M, N
*
IF( LSAMEN( 3, C3, 'RQF' ) ) THEN
EMN = MIN( M, N )
MULTS = 3*EM*( EN-EM+1 ) + ( 2*EN-2*EM+3 )*
$ ( EM*EM-EMN*( EMN+1 ) / 2 )
ADDS = ( EN-EM+1 )*( EM+2*EM*EM-EMN*( EMN+1 ) )
END IF
*
* -------------------
* Orthogonal matrices
* -------------------
*
ELSE IF( ( SORD .AND. LSAMEN( 2, C2, 'OR' ) ) .OR.
$ ( CORZ .AND. LSAMEN( 2, C2, 'UN' ) ) ) THEN
*
* -MQR, -MLQ, -MQL, or -MRQ: M, N, K, SIDE => M, N, KL, KU
* where KU<= 0 indicates SIDE = 'L'
* and KU> 0 indicates SIDE = 'R'
*
IF( LSAMEN( 3, C3, 'MQR' ) .OR. LSAMEN( 3, C3, 'MLQ' ) .OR.
$ LSAMEN( 3, C3, 'MQL' ) .OR. LSAMEN( 3, C3, 'MRQ' ) ) THEN
IF( KU.LE.0 ) THEN
MULTS = EK*EN*( 2.D0*EM+2.D0-EK )
ADDS = EK*EN*( 2.D0*EM+1.D0-EK )
ELSE
MULTS = EK*( EM*( 2.D0*EN-EK )+
$ ( EM+EN+( 1.D0-EK ) / 2.D0 ) )
ADDS = EK*EM*( 2.D0*EN+1.D0-EK )
END IF
*
* -GQR or -GQL: M, N, K => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'GQR' ) .OR. LSAMEN( 3, C3, 'GQL' ) )
$ THEN
MULTS = EK*( -5.D0 / 3.D0+( 2.D0*EN-EK )+
$ ( 2.D0*EM*EN+EK*( ( 2.D0 / 3.D0 )*EK-EM-EN ) ) )
ADDS = EK*( 1.D0 / 3.D0+( EN-EM )+
$ ( 2.D0*EM*EN+EK*( ( 2.D0 / 3.D0 )*EK-EM-EN ) ) )
*
* -GLQ or -GRQ: M, N, K => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'GLQ' ) .OR. LSAMEN( 3, C3, 'GRQ' ) )
$ THEN
MULTS = EK*( -2.D0 / 3.D0+( EM+EN-EK )+
$ ( 2.D0*EM*EN+EK*( ( 2.D0 / 3.D0 )*EK-EM-EN ) ) )
ADDS = EK*( 1.D0 / 3.D0+( EM-EN )+
$ ( 2.D0*EM*EN+EK*( ( 2.D0 / 3.D0 )*EK-EM-EN ) ) )
*
END IF
*
END IF
*
DOPLA = MULFAC*MULTS + ADDFAC*ADDS
*
RETURN
*
* End of DOPLA
*
END
DOUBLE PRECISION FUNCTION DOPLA2( SUBNAM, OPTS, M, N, K, L, NB )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
CHARACTER*( * ) OPTS
INTEGER K, L, M, N, NB
* ..
*
* Purpose
* =======
*
* DOPLA2 computes an approximation of the number of floating point
* operations used by the subroutine SUBNAM with character options
* OPTS and parameters M, N, K, L, and NB.
*
* This version counts operations for the LAPACK subroutines that
* call other LAPACK routines.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* OPTS (input) CHRACTER*(*)
* A string of character options to subroutine SUBNAM.
*
* M (input) INTEGER
* The number of rows of the coefficient matrix.
*
* N (input) INTEGER
* The number of columns of the coefficient matrix.
*
* K (input) INTEGER
* A third problem dimension, if needed.
*
* L (input) INTEGER
* A fourth problem dimension, if needed.
*
* NB (input) INTEGER
* The block size. If needed, NB >= 1.
*
* Notes
* =====
*
* In the comments below, the association is given between arguments
* in the requested subroutine and local arguments. For example,
*
* xORMBR: VECT // SIDE // TRANS, M, N, K => OPTS, M, N, K
*
* means that the character string VECT // SIDE // TRANS is passed to
* the argument OPTS, and the integer parameters M, N, and K are passed
* to the arguments M, N, and K,
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL CORZ, SORD
CHARACTER C1, SIDE, UPLO, VECT
CHARACTER*2 C2
CHARACTER*3 C3
CHARACTER*6 SUB2
INTEGER IHI, ILO, ISIDE, MI, NI, NQ
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
DOUBLE PRECISION DOPLA
EXTERNAL LSAME, LSAMEN, DOPLA
* ..
* .. Executable Statements ..
*
* ---------------------------------------------------------
* Initialize DOPLA2 to 0 and do a quick return if possible.
* ---------------------------------------------------------
*
DOPLA2 = 0
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
SORD = LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' )
CORZ = LSAME( C1, 'C' ) .OR. LSAME( C1, 'Z' )
IF( M.LE.0 .OR. .NOT.( SORD .OR. CORZ ) )
$ RETURN
*
* -------------------
* Orthogonal matrices
* -------------------
*
IF( ( SORD .AND. LSAMEN( 2, C2, 'OR' ) ) .OR.
$ ( CORZ .AND. LSAMEN( 2, C2, 'UN' ) ) ) THEN
*
IF( LSAMEN( 3, C3, 'GBR' ) ) THEN
*
* -GBR: VECT, M, N, K => OPTS, M, N, K
*
VECT = OPTS( 1: 1 )
IF( LSAME( VECT, 'Q' ) ) THEN
SUB2 = SUBNAM( 1: 3 ) // 'GQR'
IF( M.GE.K ) THEN
DOPLA2 = DOPLA( SUB2, M, N, K, 0, NB )
ELSE
DOPLA2 = DOPLA( SUB2, M-1, M-1, M-1, 0, NB )
END IF
ELSE
SUB2 = SUBNAM( 1: 3 ) // 'GLQ'
IF( K.LT.N ) THEN
DOPLA2 = DOPLA( SUB2, M, N, K, 0, NB )
ELSE
DOPLA2 = DOPLA( SUB2, N-1, N-1, N-1, 0, NB )
END IF
END IF
*
ELSE IF( LSAMEN( 3, C3, 'MBR' ) ) THEN
*
* -MBR: VECT // SIDE // TRANS, M, N, K => OPTS, M, N, K
*
VECT = OPTS( 1: 1 )
SIDE = OPTS( 2: 2 )
IF( LSAME( SIDE, 'L' ) ) THEN
NQ = M
ISIDE = 0
ELSE
NQ = N
ISIDE = 1
END IF
IF( LSAME( VECT, 'Q' ) ) THEN
SUB2 = SUBNAM( 1: 3 ) // 'MQR'
IF( NQ.GE.K ) THEN
DOPLA2 = DOPLA( SUB2, M, N, K, ISIDE, NB )
ELSE IF( ISIDE.EQ.0 ) THEN
DOPLA2 = DOPLA( SUB2, M-1, N, NQ-1, ISIDE, NB )
ELSE
DOPLA2 = DOPLA( SUB2, M, N-1, NQ-1, ISIDE, NB )
END IF
ELSE
SUB2 = SUBNAM( 1: 3 ) // 'MLQ'
IF( NQ.GT.K ) THEN
DOPLA2 = DOPLA( SUB2, M, N, K, ISIDE, NB )
ELSE IF( ISIDE.EQ.0 ) THEN
DOPLA2 = DOPLA( SUB2, M-1, N, NQ-1, ISIDE, NB )
ELSE
DOPLA2 = DOPLA( SUB2, M, N-1, NQ-1, ISIDE, NB )
END IF
END IF
*
ELSE IF( LSAMEN( 3, C3, 'GHR' ) ) THEN
*
* -GHR: N, ILO, IHI => M, N, K
*
ILO = N
IHI = K
SUB2 = SUBNAM( 1: 3 ) // 'GQR'
DOPLA2 = DOPLA( SUB2, IHI-ILO, IHI-ILO, IHI-ILO, 0, NB )
*
ELSE IF( LSAMEN( 3, C3, 'MHR' ) ) THEN
*
* -MHR: SIDE // TRANS, M, N, ILO, IHI => OPTS, M, N, K, L
*
SIDE = OPTS( 1: 1 )
ILO = K
IHI = L
IF( LSAME( SIDE, 'L' ) ) THEN
MI = IHI - ILO
NI = N
ISIDE = -1
ELSE
MI = M
NI = IHI - ILO
ISIDE = 1
END IF
SUB2 = SUBNAM( 1: 3 ) // 'MQR'
DOPLA2 = DOPLA( SUB2, MI, NI, IHI-ILO, ISIDE, NB )
*
ELSE IF( LSAMEN( 3, C3, 'GTR' ) ) THEN
*
* -GTR: UPLO, N => OPTS, M
*
UPLO = OPTS( 1: 1 )
IF( LSAME( UPLO, 'U' ) ) THEN
SUB2 = SUBNAM( 1: 3 ) // 'GQL'
DOPLA2 = DOPLA( SUB2, M-1, M-1, M-1, 0, NB )
ELSE
SUB2 = SUBNAM( 1: 3 ) // 'GQR'
DOPLA2 = DOPLA( SUB2, M-1, M-1, M-1, 0, NB )
END IF
*
ELSE IF( LSAMEN( 3, C3, 'MTR' ) ) THEN
*
* -MTR: SIDE // UPLO // TRANS, M, N => OPTS, M, N
*
SIDE = OPTS( 1: 1 )
UPLO = OPTS( 2: 2 )
IF( LSAME( SIDE, 'L' ) ) THEN
MI = M - 1
NI = N
NQ = M
ISIDE = -1
ELSE
MI = M
NI = N - 1
NQ = N
ISIDE = 1
END IF
*
IF( LSAME( UPLO, 'U' ) ) THEN
SUB2 = SUBNAM( 1: 3 ) // 'MQL'
DOPLA2 = DOPLA( SUB2, MI, NI, NQ-1, ISIDE, NB )
ELSE
SUB2 = SUBNAM( 1: 3 ) // 'MQR'
DOPLA2 = DOPLA( SUB2, MI, NI, NQ-1, ISIDE, NB )
END IF
*
END IF
END IF
*
RETURN
*
* End of DOPLA2
*
END
DOUBLE PRECISION FUNCTION DOPAUX( SUBNAM, M, N, KL, KU, NB )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
INTEGER KL, KU, M, N, NB
* ..
*
* Purpose
* =======
*
* DOPAUX computes an approximation of the number of floating point
* operations used by the subroutine SUBNAM with the given values
* of the parameters M, N, KL, KU, and NB.
*
* This version counts operations for the LAPACK auxiliary routines.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* M (input) INTEGER
* The number of rows of the coefficient matrix. M >= 0.
*
* N (input) INTEGER
* The number of columns of the coefficient matrix.
* If the matrix is square (such as in a solve routine) then
* N is the number of right hand sides. N >= 0.
*
* KL (input) INTEGER
* The lower band width of the coefficient matrix.
* If needed, 0 <= KL <= M-1.
*
* KU (input) INTEGER
* The upper band width of the coefficient matrix.
* If needed, 0 <= KU <= N-1.
*
* NB (input) INTEGER
* The block size. If needed, NB >= 1.
*
* =====================================================================
*
* .. Local Scalars ..
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 C3
DOUBLE PRECISION ADDFAC, ADDS, EK, EM, EN, ENB, MULFAC, MULTS
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Executable Statements ..
*
DOPAUX = 0
MULTS = 0
ADDS = 0
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
IF( M.LE.0 .OR. .NOT.( LSAME( C1, 'S' ) .OR. LSAME( C1,
$ 'D' ) .OR. LSAME( C1, 'C' ) .OR. LSAME( C1, 'Z' ) ) ) THEN
RETURN
END IF
IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN
MULFAC = 1
ADDFAC = 1
ELSE
MULFAC = 6
ADDFAC = 2
END IF
EM = M
EN = N
ENB = NB
*
IF( LSAMEN( 2, C2, 'LA' ) ) THEN
*
* xLAULM: N => M
*
IF( LSAMEN( 3, C3, 'ULM' ) .OR. LSAMEN( 3, C3, 'UL2' ) ) THEN
MULTS = ( 1.D0 / 3.D0 )*EM*( -1.D0+EM*EM )
ADDS = EM*( 1.D0 / 6.D0+EM*( -1.D0 / 2.D0+EM*( 1.D0 /
$ 3.D0 ) ) )
*
* xLAUUM: N => M
*
ELSE IF( LSAMEN( 3, C3, 'UUM' ) .OR. LSAMEN( 3, C3, 'UU2' ) )
$ THEN
MULTS = EM*( 1.D0 / 3.D0+EM*( 1.D0 / 2.D0+EM*( 1.D0 /
$ 6.D0 ) ) )
ADDS = ( 1.D0 / 6.D0 )*EM*( -1.D0+EM*EM )
*
* xLACON: N => M
*
ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN
MULTS = 3.D0*EM + 3.D0
ADDS = 4.D0*EM - 3.D0
*
* xLARF: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'RF ' ) ) THEN
MULTS = 2.D0*EM*EN + EN
ADDS = 2.D0*EM*EN
*
* xLARFB: M, N, SIDE, NB => M, N, KL, NB
* where KL <= 0 indicates SIDE = 'L'
* and KL > 0 indicates SIDE = 'R'
*
ELSE IF( LSAMEN( 3, C3, 'RFB' ) ) THEN
*
* KL <= 0: Code requiring local array
*
IF( KL.LE.0 ) THEN
MULTS = EN*ENB*( 2.D0*EM+( ENB+1.D0 ) / 2.D0 )
ADDS = EN*ENB*( 2.D0*EM+( ENB-1.D0 ) / 2.D0 )
*
* KL > 0: Code not requiring local array
*
ELSE
MULTS = EN*ENB*( 2.D0*EM+( -ENB / 2.D0+5.D0 / 2.D0 ) )
ADDS = EN*ENB*( 2.D0*EM+( -ENB / 2.D0-1.D0 / 2.D0 ) )
END IF
*
* xLARFG: N => M
*
ELSE IF( LSAMEN( 3, C3, 'RFG' ) ) THEN
MULTS = 2.D0*EM + 4.D0
ADDS = EM + 1.D0
*
* xLARFT: M, NB => M, N
*
ELSE IF( LSAMEN( 3, C3, 'RFT' ) ) THEN
MULTS = EN*( ( -5.D0 / 6.D0+EN*( 1.D0+EN*( -1.D0 /
$ 6.D0 ) ) )+( EM / 2.D0 )*( EN-1.D0 ) )
ADDS = EN*( ( 1.D0 / 6.D0 )*( 1.D0-EN*EN )+( EM / 2.D0 )*
$ ( EN-1.D0 ) )
*
* xLATRD: N, K => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRD' ) ) THEN
EK = N
MULTS = EK*( ( 25.D0 / 6.D0-EK*( 3.D0 / 2.D0+( 5.D0 /
$ 3.D0 )*EK ) )+EM*( 2.D0+2.D0*EK+EM ) )
ADDS = EK*( ( -1.D0 / 3.D0-( 5.D0 / 3.D0 )*EK*EK )+EM*
$ ( -1.D0+2.D0*EK+EM ) )
END IF
*
END IF
*
DOPAUX = MULFAC*MULTS + ADDFAC*ADDS
*
RETURN
*
* End of DOPAUX
*
END
DOUBLE PRECISION FUNCTION DOPBL2( SUBNAM, M, N, KKL, KKU )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
INTEGER KKL, KKU, M, N
* ..
*
* Purpose
* =======
*
* DOPBL2 computes an approximation of the number of floating point
* operations used by a subroutine SUBNAM with the given values
* of the parameters M, N, KL, and KU.
*
* This version counts operations for the Level 2 BLAS.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* M (input) INTEGER
* The number of rows of the coefficient matrix. M >= 0.
*
* N (input) INTEGER
* The number of columns of the coefficient matrix.
* If the matrix is square (such as in a solve routine) then
* N is the number of right hand sides. N >= 0.
*
* KKL (input) INTEGER
* The lower band width of the coefficient matrix.
* KL is set to max( 0, min( M-1, KKL ) ).
*
* KKU (input) INTEGER
* The upper band width of the coefficient matrix.
* KU is set to max( 0, min( N-1, KKU ) ).
*
* =====================================================================
*
* .. Local Scalars ..
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 C3
DOUBLE PRECISION ADDS, EK, EM, EN, KL, KU, MULTS
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR. .NOT.( LSAME( SUBNAM, 'S' ) .OR. LSAME( SUBNAM,
$ 'D' ) .OR. LSAME( SUBNAM, 'C' ) .OR. LSAME( SUBNAM, 'Z' ) ) )
$ THEN
DOPBL2 = 0
RETURN
END IF
*
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
MULTS = 0
ADDS = 0
KL = MAX( 0, MIN( M-1, KKL ) )
KU = MAX( 0, MIN( N-1, KKU ) )
EM = M
EN = N
EK = KL
*
* -------------------------------
* Matrix-vector multiply routines
* -------------------------------
*
IF( LSAMEN( 3, C3, 'MV ' ) ) THEN
*
IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
MULTS = EM*( EN+1.D0 )
ADDS = EM*EN
*
* Assume M <= N + KL and KL < M
* N <= M + KU and KU < N
* so that the zero sections are triangles.
*
ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
*
MULTS = EM*( EN+1.D0 ) - ( EM-1.D0-KL )*( EM-KL ) / 2.D0 -
$ ( EN-1.D0-KU )*( EN-KU ) / 2.D0
ADDS = EM*( EN+1.D0 ) - ( EM-1.D0-KL )*( EM-KL ) / 2.D0 -
$ ( EN-1.D0-KU )*( EN-KU ) / 2.D0
*
ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHP' ) ) THEN
*
MULTS = EM*( EM+1.D0 )
ADDS = EM*EM
*
ELSE IF( LSAMEN( 2, C2, 'SB' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHB' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHB' ) ) THEN
*
MULTS = EM*( EM+1.D0 ) - ( EM-1.D0-EK )*( EM-EK )
ADDS = EM*EM - ( EM-1.D0-EK )*( EM-EK )
*
ELSE IF( LSAMEN( 2, C2, 'TR' ) .OR. LSAMEN( 2, C2, 'TP' ) )
$ THEN
*
MULTS = EM*( EM+1.D0 ) / 2.D0
ADDS = ( EM-1.D0 )*EM / 2.D0
*
ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
*
MULTS = EM*( EM+1.D0 ) / 2.D0 -
$ ( EM-EK-1.D0 )*( EM-EK ) / 2.D0
ADDS = ( EM-1.D0 )*EM / 2.D0 -
$ ( EM-EK-1.D0 )*( EM-EK ) / 2.D0
*
END IF
*
* ---------------------
* Matrix solve routines
* ---------------------
*
ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
*
IF( LSAMEN( 2, C2, 'TR' ) .OR. LSAMEN( 2, C2, 'TP' ) ) THEN
*
MULTS = EM*( EM+1.D0 ) / 2.D0
ADDS = ( EM-1.D0 )*EM / 2.D0
*
ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
*
MULTS = EM*( EM+1.D0 ) / 2.D0 -
$ ( EM-EK-1.D0 )*( EM-EK ) / 2.D0
ADDS = ( EM-1.D0 )*EM / 2.D0 -
$ ( EM-EK-1.D0 )*( EM-EK ) / 2.D0
*
END IF
*
* ----------------
* Rank-one updates
* ----------------
*
ELSE IF( LSAMEN( 3, C3, 'R ' ) ) THEN
*
IF( LSAMEN( 3, SUBNAM, 'SGE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'DGE' ) ) THEN
*
MULTS = EM*EN + MIN( EM, EN )
ADDS = EM*EN
*
ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHP' ) ) THEN
*
MULTS = EM*( EM+1.D0 ) / 2.D0 + EM
ADDS = EM*( EM+1.D0 ) / 2.D0
*
END IF
*
ELSE IF( LSAMEN( 3, C3, 'RC ' ) .OR. LSAMEN( 3, C3, 'RU ' ) ) THEN
*
IF( LSAMEN( 3, SUBNAM, 'CGE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZGE' ) ) THEN
*
MULTS = EM*EN + MIN( EM, EN )
ADDS = EM*EN
*
END IF
*
* ----------------
* Rank-two updates
* ----------------
*
ELSE IF( LSAMEN( 3, C3, 'R2 ' ) ) THEN
IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHP' ) ) THEN
*
MULTS = EM*( EM+1.D0 ) + 2.D0*EM
ADDS = EM*( EM+1.D0 )
*
END IF
END IF
*
* ------------------------------------------------
* Compute the total number of operations.
* For real and double precision routines, count
* 1 for each multiply and 1 for each add.
* For complex and complex*16 routines, count
* 6 for each multiply and 2 for each add.
* ------------------------------------------------
*
IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN
*
DOPBL2 = MULTS + ADDS
*
ELSE
*
DOPBL2 = 6*MULTS + 2*ADDS
*
END IF
*
RETURN
*
* End of DOPBL2
*
END
DOUBLE PRECISION FUNCTION DOPBL3( SUBNAM, M, N, K )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
INTEGER K, M, N
* ..
*
* Purpose
* =======
*
* DOPBL3 computes an approximation of the number of floating point
* operations used by a subroutine SUBNAM with the given values
* of the parameters M, N, and K.
*
* This version counts operations for the Level 3 BLAS.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* M (input) INTEGER
* N (input) INTEGER
* K (input) INTEGER
* M, N, and K contain parameter values used by the Level 3
* BLAS. The output matrix is always M x N or N x N if
* symmetric, but K has different uses in different
* contexts. For example, in the matrix-matrix multiply
* routine, we have
* C = A * B
* where C is M x N, A is M x K, and B is K x N.
* In xSYMM, xTRMM, and xTRSM, K indicates whether the matrix
* A is applied on the left or right. If K <= 0, the matrix
* is applied on the left, if K > 0, on the right.
*
* =====================================================================
*
* .. Local Scalars ..
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 C3
DOUBLE PRECISION ADDS, EK, EM, EN, MULTS
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR. .NOT.( LSAME( SUBNAM, 'S' ) .OR. LSAME( SUBNAM,
$ 'D' ) .OR. LSAME( SUBNAM, 'C' ) .OR. LSAME( SUBNAM, 'Z' ) ) )
$ THEN
DOPBL3 = 0
RETURN
END IF
*
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
MULTS = 0
ADDS = 0
EM = M
EN = N
EK = K
*
* ----------------------
* Matrix-matrix products
* assume beta = 1
* ----------------------
*
IF( LSAMEN( 3, C3, 'MM ' ) ) THEN
*
IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
MULTS = EM*EK*EN
ADDS = EM*EK*EN
*
ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) ) THEN
*
* IF K <= 0, assume A multiplies B on the left.
*
IF( K.LE.0 ) THEN
MULTS = EM*EM*EN
ADDS = EM*EM*EN
ELSE
MULTS = EM*EN*EN
ADDS = EM*EN*EN
END IF
*
ELSE IF( LSAMEN( 2, C2, 'TR' ) ) THEN
*
IF( K.LE.0 ) THEN
MULTS = EN*EM*( EM+1.D0 ) / 2.D0
ADDS = EN*EM*( EM-1.D0 ) / 2.D0
ELSE
MULTS = EM*EN*( EN+1.D0 ) / 2.D0
ADDS = EM*EN*( EN-1.D0 ) / 2.D0
END IF
*
END IF
*
* ------------------------------------------------
* Rank-K update of a symmetric or Hermitian matrix
* ------------------------------------------------
*
ELSE IF( LSAMEN( 3, C3, 'RK ' ) ) THEN
*
IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) ) THEN
*
MULTS = EK*EM*( EM+1.D0 ) / 2.D0
ADDS = EK*EM*( EM+1.D0 ) / 2.D0
END IF
*
* ------------------------------------------------
* Rank-2K update of a symmetric or Hermitian matrix
* ------------------------------------------------
*
ELSE IF( LSAMEN( 3, C3, 'R2K' ) ) THEN
*
IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) ) THEN
*
MULTS = EK*EM*EM
ADDS = EK*EM*EM + EM
END IF
*
* -----------------------------------------
* Solving system with many right hand sides
* -----------------------------------------
*
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'TRSM ' ) ) THEN
*
IF( K.LE.0 ) THEN
MULTS = EN*EM*( EM+1.D0 ) / 2.D0
ADDS = EN*EM*( EM-1.D0 ) / 2.D0
ELSE
MULTS = EM*EN*( EN+1.D0 ) / 2.D0
ADDS = EM*EN*( EN-1.D0 ) / 2.D0
END IF
*
END IF
*
* ------------------------------------------------
* Compute the total number of operations.
* For real and double precision routines, count
* 1 for each multiply and 1 for each add.
* For complex and complex*16 routines, count
* 6 for each multiply and 2 for each add.
* ------------------------------------------------
*
IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN
*
DOPBL3 = MULTS + ADDS
*
ELSE
*
DOPBL3 = 6*MULTS + 2*ADDS
*
END IF
*
RETURN
*
* End of DOPBL3
*
END
DOUBLE PRECISION FUNCTION DOPGB( SUBNAM, M, N, KL, KU, IPIV )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
INTEGER KL, KU, M, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
* ..
*
* Purpose
* =======
*
* DOPGB counts operations for the LU factorization of a band matrix
* xGBTRF.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* M (input) INTEGER
* The number of rows of the coefficient matrix. M >= 0.
*
* N (input) INTEGER
* The number of columns of the coefficient matrix. N >= 0.
*
* KL (input) INTEGER
* The number of subdiagonals of the matrix. KL >= 0.
*
* KU (input) INTEGER
* The number of superdiagonals of the matrix. KU >= 0.
*
* IPIV (input) INTEGER array, dimension (min(M,N))
* The vector of pivot indices from DGBTRF or ZGBTRF.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL CORZ, SORD
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 C3
INTEGER I, J, JP, JU, KM
DOUBLE PRECISION ADDFAC, ADDS, MULFAC, MULTS
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
DOPGB = 0
MULTS = 0
ADDS = 0
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
SORD = LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' )
CORZ = LSAME( C1, 'C' ) .OR. LSAME( C1, 'Z' )
IF( .NOT.( SORD .OR. CORZ ) )
$ RETURN
IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN
ADDFAC = 1
MULFAC = 1
ELSE
ADDFAC = 2
MULFAC = 6
END IF
*
* --------------------------
* GB: General Band matrices
* --------------------------
*
IF( LSAMEN( 2, C2, 'GB' ) ) THEN
*
* xGBTRF: M, N, KL, KU => M, N, KL, KU
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
JU = 1
DO 10 J = 1, MIN( M, N )
KM = MIN( KL, M-J )
JP = IPIV( J )
JU = MAX( JU, MIN( JP+KU, N ) )
IF( KM.GT.0 ) THEN
MULTS = MULTS + KM*( 1+JU-J )
ADDS = ADDS + KM*( JU-J )
END IF
10 CONTINUE
END IF
*
* ---------------------------------
* GT: General Tridiagonal matrices
* ---------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'GT' ) ) THEN
*
* xGTTRF: N => M
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = 2*( M-1 )
ADDS = M - 1
DO 20 I = 1, M - 2
IF( IPIV( I ).NE.I )
$ MULTS = MULTS + 1
20 CONTINUE
*
* xGTTRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = 4*N*( M-1 )
ADDS = 3*N*( M-1 )
*
* xGTSV: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
MULTS = ( 4*N+2 )*( M-1 )
ADDS = ( 3*N+1 )*( M-1 )
DO 30 I = 1, M - 2
IF( IPIV( I ).NE.I )
$ MULTS = MULTS + 1
30 CONTINUE
END IF
END IF
*
DOPGB = MULFAC*MULTS + ADDFAC*ADDS
RETURN
*
* End of DOPGB
*
END
INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3,
$ N4 )
*
* -- LAPACK auxiliary routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER*( * ) NAME, OPTS
INTEGER ISPEC, N1, N2, N3, N4
* ..
*
* Purpose
* =======
*
* ILAENV returns problem-dependent parameters for the local
* environment. See ISPEC for a description of the parameters.
*
* In this version, the problem-dependent parameters are contained in
* the integer array IPARMS in the common block CLAENV and the value
* with index ISPEC is copied to ILAENV. This version of ILAENV is
* to be used in conjunction with XLAENV in TESTING and TIMING.
*
* 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
* = 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 and QZ methods
* for nonsymmetric eigenvalue problems.
* = 9: maximum size of the subproblems at the bottom of the
* computation tree in the divide-and-conquer algorithm
* =10: ieee NaN arithmetic can be trusted not to trap
* =11: infinity arithmetic can be trusted not to trap
*
* Other specifications (up to 100) can be added later.
*
* NAME (input) CHARACTER*(*)
* The name of the calling subroutine.
*
* 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.
*
* (ILAENV) (output) INTEGER
* >= 0: the value of the parameter specified by ISPEC
* < 0: if ILAENV = -k, the k-th argument had an illegal value.
*
* 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 )
*
* =====================================================================
*
* .. Intrinsic Functions ..
INTRINSIC INT, MIN, REAL
* ..
* .. External Functions ..
INTEGER IEEECK
EXTERNAL IEEECK
* ..
* .. Arrays in Common ..
INTEGER IPARMS( 100 )
* ..
* .. Common blocks ..
COMMON / CLAENV / IPARMS
* ..
* .. Save statement ..
SAVE / CLAENV /
* ..
* .. Executable Statements ..
*
IF( ISPEC.GE.1 .AND. ISPEC.LE.5 ) THEN
*
* Return a value from the common block.
*
ILAENV = IPARMS( ISPEC )
*
ELSE IF( ISPEC.EQ.6 ) THEN
*
* Compute SVD crossover point.
*
ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 )
*
ELSE IF( ISPEC.GE.7 .AND. ISPEC.LE.9 ) THEN
*
* Return a value from the common block.
*
ILAENV = IPARMS( ISPEC )
*
ELSE IF( ISPEC.EQ.10 ) THEN
*
* IEEE NaN arithmetic can be trusted not to trap
*
ILAENV = 1
IF( ILAENV.EQ.1 ) THEN
ILAENV = IEEECK( 0, 0.0, 1.0 )
END IF
*
ELSE IF( ISPEC.EQ.11 ) THEN
*
* Infinity arithmetic can be trusted not to trap
*
ILAENV = 1
IF( ILAENV.EQ.1 ) THEN
ILAENV = IEEECK( 1, 0.0, 1.0 )
END IF
*
ELSE
*
* Invalid value for ISPEC
*
ILAENV = -1
END IF
*
RETURN
*
* End of ILAENV
*
END
SUBROUTINE XLAENV( ISPEC, NVALUE )
*
* -- LAPACK auxiliary routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER ISPEC, NVALUE
* ..
*
* Purpose
* =======
*
* XLAENV sets certain machine- and problem-dependent quantities
* which will later be retrieved by ILAENV.
*
* Arguments
* =========
*
* ISPEC (input) INTEGER
* Specifies the parameter to be set in the COMMON array IPARMS.
* = 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
* = 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: another crossover point, for the multishift QR and QZ
* methods for nonsymmetric eigenvalue problems.
* = 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
*
* NVALUE (input) INTEGER
* The value of the parameter specified by ISPEC.
*
* =====================================================================
*
* .. Arrays in Common ..
INTEGER IPARMS( 100 )
* ..
* .. Common blocks ..
COMMON / CLAENV / IPARMS
* ..
* .. Save statement ..
SAVE / CLAENV /
* ..
* .. Executable Statements ..
*
IF( ISPEC.GE.1 .AND. ISPEC.LE.9 ) THEN
IPARMS( ISPEC ) = NVALUE
END IF
*
RETURN
*
* End of XLAENV
*
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/lin/linsrc/Makefile 0000644 0001750 0001750 00000000746 10616163244 024554 0 ustar osallou osallou .SUFFIXES: .f .java
ROOT=../../../..
include $(ROOT)/make.def
BLAS=$(ROOT)/$(BLAS_IDX)
LAPACK=$(ROOT)/$(LAPACK_IDX)
F2JFLAGS=-c .:$(ROOT)/$(BLAS_OBJ):$(ROOT)/$(ERR_OBJ):$(ROOT)/$(LAPACK_OBJ) -p $(LINSRC_PACKAGE) -o $(OUTDIR)
tester: $(BLAS) $(LAPACK) $(OUTDIR)/Linsrc.f2j
$(OUTDIR)/Linsrc.f2j: linsrc.f
$(F2J) $(F2JFLAGS) $< > /dev/null
$(BLAS):
cd $(ROOT)/$(BLAS_DIR); $(MAKE)
$(LAPACK):
cd $(ROOT)/$(LAPACK_DIR); $(MAKE)
clean:
/bin/rm -rf *.java *.class *.f2j $(OUTDIR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/lin/lintime.f 0000644 0001750 0001750 00001761463 10616163243 023444 0 ustar osallou osallou SUBROUTINE ATIMCK( ICHK, SUBNAM, NN, NVAL, NLDA, LDAVAL, NOUT,
$ INFO )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
INTEGER ICHK, INFO, NLDA, NN, NOUT
* ..
* .. Array Arguments ..
INTEGER LDAVAL( * ), NVAL( * )
* ..
*
* Purpose
* =======
*
* ATIMCK checks the input values of M, N, or K and LDA to determine
* if they are valid for type TYPE. The tests to be performed are
* specified in the option variable ICHK.
*
* On exit, INFO contains a count of the number of pairs (N,LDA) that
* were invalid.
*
* Arguments
* =========
*
* ICHK (input) INTEGER
* Specifies the type of comparison
* = 1: M <= LDA
* = 2: N <= LDA
* = 3: K <= LDA
* = 4: N*(N+1)/2 <= LA
* = 0 or other value: Determined from name passed in SUBNAM
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine or path for which the input
* values are to be tested.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension( NN )
* The values of the matrix size N.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension( NLDA )
* The values of the leading dimension of the array A.
*
* NOUT (input) INTEGER
* The unit number for output.
*
* INFO (output) INTEGER
* The number of pairs (N, LDA) that were invalid.
*
* =====================================================================
*
* .. Local Scalars ..
CHARACTER*2 TYPE
INTEGER I, J, LDA, N
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. Executable Statements ..
*
TYPE = SUBNAM( 2: 3 )
INFO = 0
*
* M, N, or K must be less than or equal to LDA.
*
IF( ICHK.EQ.1 .OR. ICHK.EQ.2 .OR. ICHK.EQ.3 ) THEN
DO 20 J = 1, NLDA
LDA = LDAVAL( J )
DO 10 I = 1, NN
IF( NVAL( I ).GT.LDA ) THEN
INFO = INFO + 1
IF( NOUT.GT.0 ) THEN
IF( ICHK.EQ.1 ) THEN
WRITE( NOUT, FMT = 9999 )SUBNAM, NVAL( I ), LDA
ELSE IF( ICHK.EQ.2 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM, NVAL( I ), LDA
ELSE
WRITE( NOUT, FMT = 9997 )SUBNAM, NVAL( I ), LDA
END IF
END IF
END IF
10 CONTINUE
20 CONTINUE
*
* IF TYPE = 'PP', 'SP', or 'HP',
* then N*(N+1)/2 must be less than or equal to LA = LDAVAL(1).
*
ELSE IF( ICHK.EQ.4 ) THEN
LDA = LDAVAL( 1 )
DO 30 I = 1, NN
N = NVAL( I )
IF( N*( N+1 ) / 2.GT.LDA ) THEN
INFO = INFO + 1
IF( NOUT.GT.0 )
$ WRITE( NOUT, FMT = 9996 )SUBNAM, N, LDA
END IF
30 CONTINUE
*
* IF TYPE = 'GB', then K must satisfy
* 2*K+1 <= LDA, if SUBNAM = 'xGBMV'
* 3*K+1 <= LDA, otherwise.
*
ELSE IF( LSAMEN( 2, TYPE, 'GB' ) ) THEN
IF( LSAMEN( 3, SUBNAM( 4: 6 ), 'MV ' ) ) THEN
DO 50 J = 1, NLDA
LDA = LDAVAL( J )
DO 40 I = 1, NN
IF( 2*NVAL( I )+1.GT.LDA ) THEN
INFO = INFO + 1
IF( NOUT.GT.0 )
$ WRITE( NOUT, FMT = 9994 )SUBNAM, NVAL( I ),
$ LDA, 2*NVAL( I ) + 1
END IF
40 CONTINUE
50 CONTINUE
ELSE
DO 70 J = 1, NLDA
LDA = LDAVAL( J )
DO 60 I = 1, NN
IF( 3*NVAL( I )+1.GT.LDA ) THEN
INFO = INFO + 1
IF( NOUT.GT.0 )
$ WRITE( NOUT, FMT = 9995 )SUBNAM, NVAL( I ),
$ LDA, 3*NVAL( I ) + 1
END IF
60 CONTINUE
70 CONTINUE
END IF
*
* IF TYPE = 'PB' or 'TB', then K must satisfy
* K+1 <= LDA.
*
ELSE IF( LSAMEN( 2, TYPE, 'PB' ) .OR. LSAMEN( 2, TYPE, 'TB' ) )
$ THEN
DO 90 J = 1, NLDA
LDA = LDAVAL( J )
DO 80 I = 1, NN
IF( NVAL( I )+1.GT.LDA ) THEN
INFO = INFO + 1
IF( NOUT.GT.0 )
$ WRITE( NOUT, FMT = 9993 )SUBNAM, NVAL( I ), LDA
END IF
80 CONTINUE
90 CONTINUE
*
* IF TYPE = 'SB' or 'HB', then K must satisfy
* K+1 <= LDA, if SUBNAM = 'xxxMV '
*
ELSE IF( LSAMEN( 2, TYPE, 'SB' ) .OR. LSAMEN( 2, TYPE, 'HB' ) )
$ THEN
IF( LSAMEN( 3, SUBNAM( 4: 6 ), 'MV ' ) ) THEN
DO 110 J = 1, NLDA
LDA = LDAVAL( J )
DO 100 I = 1, NN
IF( NVAL( I )+1.GT.LDA ) THEN
INFO = INFO + 1
IF( NOUT.GT.0 )
$ WRITE( NOUT, FMT = 9992 )SUBNAM, NVAL( I ), LDA
END IF
100 CONTINUE
110 CONTINUE
END IF
*
END IF
9999 FORMAT( ' *** Error for ', A6, ': M > LDA for M =', I6,
$ ', LDA =', I7 )
9998 FORMAT( ' *** Error for ', A6, ': N > LDA for N =', I6,
$ ', LDA =', I7 )
9997 FORMAT( ' *** Error for ', A6, ': K > LDA for K =', I6,
$ ', LDA =', I7 )
9996 FORMAT( ' *** Error for ', A6, ': N*(N+1)/2 > LA for N =', I6,
$ ', LA =', I7 )
9995 FORMAT( ' *** Error for ', A6, ': 3*K+1 > LDA for K =', I6,
$ ', LDA =', I7, / ' --> Increase LDA to at least ', I7 )
9994 FORMAT( ' *** Error for ', A6, ': 2*K+1 > LDA for K =', I6,
$ ', LDA =', I7, / ' --> Increase LDA to at least ', I7 )
9993 FORMAT( ' *** Error for ', A6, ': K+1 > LDA for K =', I6, ', LD',
$ 'A =', I7 )
9992 FORMAT( ' *** Error for ', A6, ': 2*K+2 > LDA for K =', I6, ', ',
$ 'LDA =', I7 )
*
RETURN
*
* End of ATIMCK
*
END
SUBROUTINE ATIMIN( PATH, LINE, NSUBS, NAMES, TIMSUB, NOUT, INFO )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
CHARACTER*( * ) PATH
INTEGER INFO, NOUT, NSUBS
* ..
* .. Array Arguments ..
LOGICAL TIMSUB( * )
CHARACTER*( * ) NAMES( * )
* ..
*
* Purpose
* =======
*
* ATIMIN interprets the input line for the timing routines.
* The LOGICAL array TIMSUB returns .true. for each routine to be
* timed and .false. for the routines which are not to be timed.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*(*)
* The LAPACK path name of the calling routine. The path name
* may be at most 6 characters long. If LINE(1:LEN(PATH)) is
* the same as PATH, then the input line is searched for NSUBS
* non-blank characters, otherwise, the input line is assumed to
* specify a single subroutine name.
*
* LINE (input) CHARACTER*80
* The input line to be evaluated. The path or subroutine name
* must begin in column 1 and the part of the line after the
* name is used to indicate the routines to be timed.
* See below for further details.
*
* NSUBS (input) INTEGER
* The number of subroutines in the LAPACK path name of the
* calling routine.
*
* NAMES (input) CHARACTER*(*) array, dimension (NSUBS)
* The names of the subroutines in the LAPACK path name of the
* calling routine.
*
* TIMSUB (output) LOGICAL array, dimension (NSUBS)
* For each I from 1 to NSUBS, TIMSUB( I ) is set to .true. if
* the subroutine NAMES( I ) is to be timed; otherwise,
* TIMSUB( I ) is set to .false.
*
* NOUT (input) INTEGER
* The unit number on which error messages will be printed.
*
* INFO (output) INTEGER
* The return status of this routine.
* = -1: Unrecognized path or subroutine name
* = 0: Normal return
* = 1: Name was recognized, but no timing requested
*
* Further Details
* ======= =======
*
* An input line begins with a subroutine or path name, optionally
* followed by one or more non-blank characters indicating the specific
* routines to be timed.
*
* If the character string in PATH appears at the beginning of LINE,
* up to NSUBS routines may be timed. If LINE is blank after the path
* name, all the routines in the path will be timed. If LINE is not
* blank after the path name, the rest of the line is searched
* for NSUBS nonblank characters, and if the i-th such character is
* 't' or 'T', then the i-th subroutine in this path will be timed.
* For example, the input line
* SGE T T T T
* requests timing of the first 4 subroutines in the SGE path.
*
* If the character string in PATH does not appear at the beginning of
* LINE, then LINE is assumed to begin with a subroutine name. The name
* is assumed to end in column 6 or in column i if column i+1 is blank
* and i+1 <= 6. If LINE is completely blank after the subroutine name,
* the routine will be timed. If LINE is not blank after the subroutine
* name, then the subroutine will be timed if the first non-blank after
* the name is 't' or 'T'.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL REQ
CHARACTER*6 CNAME
INTEGER I, ISTART, ISTOP, ISUB, LCNAME, LNAMES, LPATH
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Intrinsic Functions ..
INTRINSIC LEN, MIN
* ..
* .. Executable Statements ..
*
*
* Initialize
*
INFO = 0
LCNAME = 1
DO 10 I = 2, 6
IF( LINE( I: I ).EQ.' ' )
$ GO TO 20
LCNAME = I
10 CONTINUE
20 CONTINUE
LPATH = MIN( LCNAME+1, LEN( PATH ) )
LNAMES = MIN( LCNAME+1, LEN( NAMES( 1 ) ) )
CNAME = LINE( 1: LCNAME )
*
DO 30 I = 1, NSUBS
TIMSUB( I ) = .FALSE.
30 CONTINUE
ISTOP = 0
*
* Check for a valid path or subroutine name.
*
IF( LCNAME.LE.LEN( PATH ) .AND. LSAMEN( LPATH, CNAME, PATH ) )
$ THEN
ISTART = 1
ISTOP = NSUBS
ELSE IF( LCNAME.LE.LEN( NAMES( 1 ) ) ) THEN
DO 40 I = 1, NSUBS
IF( LSAMEN( LNAMES, CNAME, NAMES( I ) ) ) THEN
ISTART = I
ISTOP = I
END IF
40 CONTINUE
END IF
*
IF( ISTOP.EQ.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
9999 FORMAT( 1X, A, ': Unrecognized path or subroutine name', / )
INFO = -1
GO TO 110
END IF
*
* Search the rest of the input line for 1 or NSUBS nonblank
* characters, where 'T' or 't' means 'Time this routine'.
*
ISUB = ISTART
DO 50 I = LCNAME + 1, 80
IF( LINE( I: I ).NE.' ' ) THEN
TIMSUB( ISUB ) = LSAME( LINE( I: I ), 'T' )
ISUB = ISUB + 1
IF( ISUB.GT.ISTOP )
$ GO TO 60
END IF
50 CONTINUE
60 CONTINUE
*
* If no characters appear after the routine or path name, then
* time the routine or all the routines in the path.
*
IF( ISUB.EQ.ISTART ) THEN
DO 70 I = ISTART, ISTOP
TIMSUB( I ) = .TRUE.
70 CONTINUE
ELSE
*
* Test to see if any timing was requested.
*
REQ = .FALSE.
DO 80 I = ISTART, ISUB - 1
REQ = REQ .OR. TIMSUB( I )
80 CONTINUE
IF( .NOT.REQ ) THEN
WRITE( NOUT, FMT = 9998 )CNAME
9998 FORMAT( 1X, A, ' was not timed', / )
INFO = 1
GO TO 110
END IF
90 CONTINUE
*
* If fewer than NSUBS characters are specified for a path name,
* the rest are assumed to be 'F'.
*
DO 100 I = ISUB, ISTOP
TIMSUB( I ) = .FALSE.
100 CONTINUE
END IF
110 CONTINUE
RETURN
*
* End of ATIMIN
*
END
SUBROUTINE ORTHES(NM,N,LOW,IGH,A,ORT)
C
INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
DOUBLE PRECISION A(NM,N),ORT(IGH)
DOUBLE PRECISION F,G,H,SCALE
C
C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTHES,
C NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
C
C GIVEN A REAL GENERAL MATRIX, THIS SUBROUTINE
C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
C ORTHOGONAL SIMILARITY TRANSFORMATIONS.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRIX.
C
C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED,
C SET LOW=1, IGH=N.
C
C A CONTAINS THE INPUT MATRIX.
C
C ON OUTPUT
C
C A CONTAINS THE HESSENBERG MATRIX. INFORMATION ABOUT
C THE ORTHOGONAL TRANSFORMATIONS USED IN THE REDUCTION
C IS STORED IN THE REMAINING TRIANGLE UNDER THE
C HESSENBERG MATRIX.
C
C ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS.
C ONLY ELEMENTS LOW THROUGH IGH ARE USED.
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
C
LA = IGH - 1
KP1 = LOW + 1
IF (LA .LT. KP1) GO TO 200
C
DO 180 M = KP1, LA
H = 0.0D0
ORT(M) = 0.0D0
SCALE = 0.0D0
C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
DO 90 I = M, IGH
90 SCALE = SCALE + DABS(A(I,M-1))
C
IF (SCALE .EQ. 0.0D0) GO TO 180
MP = M + IGH
C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
DO 100 II = M, IGH
I = MP - II
ORT(I) = A(I,M-1) / SCALE
H = H + ORT(I) * ORT(I)
100 CONTINUE
C
G = -DSIGN(DSQRT(H),ORT(M))
H = H - ORT(M) * G
ORT(M) = ORT(M) - G
C .......... FORM (I-(U*UT)/H) * A ..........
DO 130 J = M, N
F = 0.0D0
C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
DO 110 II = M, IGH
I = MP - II
F = F + ORT(I) * A(I,J)
110 CONTINUE
C
F = F / H
C
DO 120 I = M, IGH
120 A(I,J) = A(I,J) - F * ORT(I)
C
130 CONTINUE
C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
DO 160 I = 1, IGH
F = 0.0D0
C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
DO 140 JJ = M, IGH
J = MP - JJ
F = F + ORT(J) * A(I,J)
140 CONTINUE
C
F = F / H
C
DO 150 J = M, IGH
150 A(I,J) = A(I,J) - F * ORT(J)
C
160 CONTINUE
C
ORT(M) = SCALE * ORT(M)
A(M,M-1) = SCALE * G
180 CONTINUE
C
200 RETURN
END
SUBROUTINE TRED1(NM,N,A,D,E,E2)
C
INTEGER I,J,K,L,N,II,NM,JP1
DOUBLE PRECISION A(NM,N),D(N),E(N),E2(N)
DOUBLE PRECISION F,G,H,SCALE
C
C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED1,
C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C
C THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX
C TO A SYMMETRIC TRIDIAGONAL MATRIX USING
C ORTHOGONAL SIMILARITY TRANSFORMATIONS.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRIX.
C
C A CONTAINS THE REAL SYMMETRIC INPUT MATRIX. ONLY THE
C LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED.
C
C ON OUTPUT
C
C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS-
C FORMATIONS USED IN THE REDUCTION IN ITS STRICT LOWER
C TRIANGLE. THE FULL UPPER TRIANGLE OF A IS UNALTERED.
C
C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX.
C
C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO.
C
C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
C
DO 100 I = 1, N
D(I) = A(N,I)
A(N,I) = A(I,I)
100 CONTINUE
C .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........
DO 300 II = 1, N
I = N + 1 - II
L = I - 1
H = 0.0D0
SCALE = 0.0D0
IF (L .LT. 1) GO TO 130
C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) ..........
DO 120 K = 1, L
120 SCALE = SCALE + DABS(D(K))
C
IF (SCALE .NE. 0.0D0) GO TO 140
C
DO 125 J = 1, L
D(J) = A(L,J)
A(L,J) = A(I,J)
A(I,J) = 0.0D0
125 CONTINUE
C
130 E(I) = 0.0D0
E2(I) = 0.0D0
GO TO 300
C
140 DO 150 K = 1, L
D(K) = D(K) / SCALE
H = H + D(K) * D(K)
150 CONTINUE
C
E2(I) = SCALE * SCALE * H
F = D(L)
G = -DSIGN(DSQRT(H),F)
E(I) = SCALE * G
H = H - F * G
D(L) = F - G
IF (L .EQ. 1) GO TO 285
C .......... FORM A*U ..........
DO 170 J = 1, L
170 E(J) = 0.0D0
C
DO 240 J = 1, L
F = D(J)
G = E(J) + A(J,J) * F
JP1 = J + 1
IF (L .LT. JP1) GO TO 220
C
DO 200 K = JP1, L
G = G + A(K,J) * D(K)
E(K) = E(K) + A(K,J) * F
200 CONTINUE
C
220 E(J) = G
240 CONTINUE
C .......... FORM P ..........
F = 0.0D0
C
DO 245 J = 1, L
E(J) = E(J) / H
F = F + E(J) * D(J)
245 CONTINUE
C
H = F / (H + H)
C .......... FORM Q ..........
DO 250 J = 1, L
250 E(J) = E(J) - H * D(J)
C .......... FORM REDUCED A ..........
DO 280 J = 1, L
F = D(J)
G = E(J)
C
DO 260 K = J, L
260 A(K,J) = A(K,J) - F * E(K) - G * D(K)
C
280 CONTINUE
C
285 DO 290 J = 1, L
F = D(J)
D(J) = A(L,J)
A(L,J) = A(I,J)
A(I,J) = F * SCALE
290 CONTINUE
C
300 CONTINUE
C
RETURN
END
SUBROUTINE DLAORD( JOB, N, X, INCX )
*
* -- LAPACK auxiliary routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
CHARACTER JOB
INTEGER INCX, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION X( * )
* ..
*
* Purpose
* =======
*
* DLAORD sorts the elements of a vector x in increasing or decreasing
* order.
*
* Arguments
* =========
*
* JOB (input) CHARACTER
* = 'I': Sort in increasing order
* = 'D': Sort in decreasing order
*
* N (input) INTEGER
* The length of the vector X.
*
* X (input/output) DOUBLE PRECISION array, dimension
* (1+(N-1)*INCX)
* On entry, the vector of length n to be sorted.
* On exit, the vector x is sorted in the prescribed order.
*
* INCX (input) INTEGER
* The spacing between successive elements of X. INCX >= 0.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, INC, IX, IXNEXT
DOUBLE PRECISION TEMP
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
INC = ABS( INCX )
IF( LSAME( JOB, 'I' ) ) THEN
*
* Sort in increasing order
*
DO 20 I = 2, N
IX = 1 + ( I-1 )*INC
10 CONTINUE
IF( IX.EQ.1 )
$ GO TO 20
IXNEXT = IX - INC
IF( X( IX ).GT.X( IXNEXT ) ) THEN
GO TO 20
ELSE
TEMP = X( IX )
X( IX ) = X( IXNEXT )
X( IXNEXT ) = TEMP
END IF
IX = IXNEXT
GO TO 10
20 CONTINUE
*
ELSE IF( LSAME( JOB, 'D' ) ) THEN
*
* Sort in decreasing order
*
DO 40 I = 2, N
IX = 1 + ( I-1 )*INC
30 CONTINUE
IF( IX.EQ.1 )
$ GO TO 40
IXNEXT = IX - INC
IF( X( IX ).LT.X( IXNEXT ) ) THEN
GO TO 40
ELSE
TEMP = X( IX )
X( IX ) = X( IXNEXT )
X( IXNEXT ) = TEMP
END IF
IX = IXNEXT
GO TO 30
40 CONTINUE
END IF
RETURN
*
* End of DLAORD
*
END
SUBROUTINE DGEFA(A,LDA,N,IPVT,INFO)
INTEGER LDA,N,IPVT(*),INFO
DOUBLE PRECISION A(LDA,*)
C
C DGEFA FACTORS A DOUBLE PRECISION MATRIX BY GAUSSIAN ELIMINATION.
C
C DGEFA IS USUALLY CALLED BY DGECO, BUT IT CAN BE CALLED
C DIRECTLY WITH A SAVING IN TIME IF RCOND IS NOT NEEDED.
C (TIME FOR DGECO) = (1 + 9/N)*(TIME FOR DGEFA) .
C
C ON ENTRY
C
C A DOUBLE PRECISION(LDA, N)
C THE MATRIX TO BE FACTORED.
C
C LDA INTEGER
C THE LEADING DIMENSION OF THE ARRAY A .
C
C N INTEGER
C THE ORDER OF THE MATRIX A .
C
C ON RETURN
C
C A AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
C WHICH WERE USED TO OBTAIN IT.
C THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE
C L IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR.
C
C IPVT INTEGER(N)
C AN INTEGER VECTOR OF PIVOT INDICES.
C
C INFO INTEGER
C = 0 NORMAL VALUE.
C = K IF U(K,K) .EQ. 0.0 . THIS IS NOT AN ERROR
C CONDITION FOR THIS SUBROUTINE, BUT IT DOES
C INDICATE THAT DGESL OR DGEDI WILL DIVIDE BY ZERO
C IF CALLED. USE RCOND IN DGECO FOR A RELIABLE
C INDICATION OF SINGULARITY.
C
C LINPACK. THIS VERSION DATED 08/14/78 .
C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C SUBROUTINES AND FUNCTIONS
C
C BLAS DAXPY,DSCAL,IDAMAX
C
C INTERNAL VARIABLES
C
DOUBLE PRECISION T
INTEGER IDAMAX,J,K,KP1,L,NM1
EXTERNAL IDAMAX
C
C
C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
C
INFO = 0
NM1 = N - 1
IF (NM1 .LT. 1) GO TO 70
DO 60 K = 1, NM1
KP1 = K + 1
C
C FIND L = PIVOT INDEX
C
L = IDAMAX(N-K+1,A(K,K),1) + K - 1
IPVT(K) = L
C
C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
C
IF (A(L,K) .EQ. 0.0D0) GO TO 40
C
C INTERCHANGE IF NECESSARY
C
IF (L .EQ. K) GO TO 10
T = A(L,K)
A(L,K) = A(K,K)
A(K,K) = T
10 CONTINUE
C
C COMPUTE MULTIPLIERS
C
T = -1.0D0/A(K,K)
CALL DSCAL(N-K,T,A(K+1,K),1)
C
C ROW ELIMINATION WITH COLUMN INDEXING
C
DO 30 J = KP1, N
T = A(L,J)
IF (L .EQ. K) GO TO 20
A(L,J) = A(K,J)
A(K,J) = T
20 CONTINUE
CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1)
30 CONTINUE
GO TO 50
40 CONTINUE
INFO = K
50 CONTINUE
60 CONTINUE
70 CONTINUE
IPVT(N) = N
IF (A(N,N) .EQ. 0.0D0) INFO = N
RETURN
END
SUBROUTINE DPOFA(A,LDA,N,INFO)
INTEGER LDA,N,INFO
DOUBLE PRECISION A(LDA,*)
C
C DPOFA FACTORS A DOUBLE PRECISION SYMMETRIC POSITIVE DEFINITE
C MATRIX.
C
C DPOFA IS USUALLY CALLED BY DPOCO, BUT IT CAN BE CALLED
C DIRECTLY WITH A SAVING IN TIME IF RCOND IS NOT NEEDED.
C (TIME FOR DPOCO) = (1 + 18/N)*(TIME FOR DPOFA) .
C
C ON ENTRY
C
C A DOUBLE PRECISION(LDA, N)
C THE SYMMETRIC MATRIX TO BE FACTORED. ONLY THE
C DIAGONAL AND UPPER TRIANGLE ARE USED.
C
C LDA INTEGER
C THE LEADING DIMENSION OF THE ARRAY A .
C
C N INTEGER
C THE ORDER OF THE MATRIX A .
C
C ON RETURN
C
C A AN UPPER TRIANGULAR MATRIX R SO THAT A = TRANS(R)*R
C WHERE TRANS(R) IS THE TRANSPOSE.
C THE STRICT LOWER TRIANGLE IS UNALTERED.
C IF INFO .NE. 0 , THE FACTORIZATION IS NOT COMPLETE.
C
C INFO INTEGER
C = 0 FOR NORMAL RETURN.
C = K SIGNALS AN ERROR CONDITION. THE LEADING MINOR
C OF ORDER K IS NOT POSITIVE DEFINITE.
C
C LINPACK. THIS VERSION DATED 08/14/78 .
C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C SUBROUTINES AND FUNCTIONS
C
C BLAS DDOT
C FORTRAN DSQRT
C
C INTERNAL VARIABLES
C
DOUBLE PRECISION DDOT,T
DOUBLE PRECISION S
INTEGER J,JM1,K
EXTERNAL DDOT
C BEGIN BLOCK WITH ...EXITS TO 40
C
C
DO 30 J = 1, N
INFO = J
S = 0.0D0
JM1 = J - 1
IF (JM1 .LT. 1) GO TO 20
DO 10 K = 1, JM1
T = A(K,J) - DDOT(K-1,A(1,K),1,A(1,J),1)
T = T/A(K,K)
A(K,J) = T
S = S + T*T
10 CONTINUE
20 CONTINUE
S = A(J,J) - S
C ......EXIT
IF (S .LE. 0.0D0) GO TO 40
A(J,J) = DSQRT(S)
30 CONTINUE
INFO = 0
40 CONTINUE
RETURN
END
SUBROUTINE DQRDC(X,LDX,N,P,QRAUX,JPVT,WORK,JOB)
INTEGER LDX,N,P,JOB
INTEGER JPVT(*)
DOUBLE PRECISION X(LDX,*),QRAUX(*),WORK(*)
C
C DQRDC USES HOUSEHOLDER TRANSFORMATIONS TO COMPUTE THE QR
C FACTORIZATION OF AN N BY P MATRIX X. COLUMN PIVOTING
C BASED ON THE 2-NORMS OF THE REDUCED COLUMNS MAY BE
C PERFORMED AT THE USERS OPTION.
C
C ON ENTRY
C
C X DOUBLE PRECISION(LDX,P), WHERE LDX .GE. N.
C X CONTAINS THE MATRIX WHOSE DECOMPOSITION IS TO BE
C COMPUTED.
C
C LDX INTEGER.
C LDX IS THE LEADING DIMENSION OF THE ARRAY X.
C
C N INTEGER.
C N IS THE NUMBER OF ROWS OF THE MATRIX X.
C
C P INTEGER.
C P IS THE NUMBER OF COLUMNS OF THE MATRIX X.
C
C JPVT INTEGER(P).
C JPVT CONTAINS INTEGERS THAT CONTROL THE SELECTION
C OF THE PIVOT COLUMNS. THE K-TH COLUMN X(K) OF X
C IS PLACED IN ONE OF THREE CLASSES ACCORDING TO THE
C VALUE OF JPVT(K).
C
C IF JPVT(K) .GT. 0, THEN X(K) IS AN INITIAL
C COLUMN.
C
C IF JPVT(K) .EQ. 0, THEN X(K) IS A FREE COLUMN.
C
C IF JPVT(K) .LT. 0, THEN X(K) IS A FINAL COLUMN.
C
C BEFORE THE DECOMPOSITION IS COMPUTED, INITIAL COLUMNS
C ARE MOVED TO THE BEGINNING OF THE ARRAY X AND FINAL
C COLUMNS TO THE END. BOTH INITIAL AND FINAL COLUMNS
C ARE FROZEN IN PLACE DURING THE COMPUTATION AND ONLY
C FREE COLUMNS ARE MOVED. AT THE K-TH STAGE OF THE
C REDUCTION, IF X(K) IS OCCUPIED BY A FREE COLUMN
C IT IS INTERCHANGED WITH THE FREE COLUMN OF LARGEST
C REDUCED NORM. JPVT IS NOT REFERENCED IF
C JOB .EQ. 0.
C
C WORK DOUBLE PRECISION(P).
C WORK IS A WORK ARRAY. WORK IS NOT REFERENCED IF
C JOB .EQ. 0.
C
C JOB INTEGER.
C JOB IS AN INTEGER THAT INITIATES COLUMN PIVOTING.
C IF JOB .EQ. 0, NO PIVOTING IS DONE.
C IF JOB .NE. 0, PIVOTING IS DONE.
C
C ON RETURN
C
C X X CONTAINS IN ITS UPPER TRIANGLE THE UPPER
C TRIANGULAR MATRIX R OF THE QR FACTORIZATION.
C BELOW ITS DIAGONAL X CONTAINS INFORMATION FROM
C WHICH THE ORTHOGONAL PART OF THE DECOMPOSITION
C CAN BE RECOVERED. NOTE THAT IF PIVOTING HAS
C BEEN REQUESTED, THE DECOMPOSITION IS NOT THAT
C OF THE ORIGINAL MATRIX X BUT THAT OF X
C WITH ITS COLUMNS PERMUTED AS DESCRIBED BY JPVT.
C
C QRAUX DOUBLE PRECISION(P).
C QRAUX CONTAINS FURTHER INFORMATION REQUIRED TO RECOVER
C THE ORTHOGONAL PART OF THE DECOMPOSITION.
C
C JPVT JPVT(K) CONTAINS THE INDEX OF THE COLUMN OF THE
C ORIGINAL MATRIX THAT HAS BEEN INTERCHANGED INTO
C THE K-TH COLUMN, IF PIVOTING WAS REQUESTED.
C
C LINPACK. THIS VERSION DATED 08/14/78 .
C G.W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB.
C
C DQRDC USES THE FOLLOWING FUNCTIONS AND SUBPROGRAMS.
C
C BLAS DAXPY,DDOT,DSCAL,DSWAP,DNRM2
C FORTRAN DABS,DMAX1,MIN0,DSQRT
C
C INTERNAL VARIABLES
C
INTEGER J,JJ,JP,L,LP1,LUP,MAXJ,PL,PU
DOUBLE PRECISION MAXNRM,DNRM2,TT
DOUBLE PRECISION DDOT,NRMXL,T
LOGICAL NEGJ,SWAPJ
EXTERNAL DAXPY, DDOT, DSCAL, DSWAP, DNRM2
C
C
PL = 1
PU = 0
IF (JOB .EQ. 0) GO TO 60
C
C PIVOTING HAS BEEN REQUESTED. REARRANGE THE COLUMNS
C ACCORDING TO JPVT.
C
DO 20 J = 1, P
SWAPJ = JPVT(J) .GT. 0
NEGJ = JPVT(J) .LT. 0
JPVT(J) = J
IF (NEGJ) JPVT(J) = -J
IF (.NOT.SWAPJ) GO TO 10
IF (J .NE. PL) CALL DSWAP(N,X(1,PL),1,X(1,J),1)
JPVT(J) = JPVT(PL)
JPVT(PL) = J
PL = PL + 1
10 CONTINUE
20 CONTINUE
PU = P
DO 50 JJ = 1, P
J = P - JJ + 1
IF (JPVT(J) .GE. 0) GO TO 40
JPVT(J) = -JPVT(J)
IF (J .EQ. PU) GO TO 30
CALL DSWAP(N,X(1,PU),1,X(1,J),1)
JP = JPVT(PU)
JPVT(PU) = JPVT(J)
JPVT(J) = JP
30 CONTINUE
PU = PU - 1
40 CONTINUE
50 CONTINUE
60 CONTINUE
C
C COMPUTE THE NORMS OF THE FREE COLUMNS.
C
IF (PU .LT. PL) GO TO 80
DO 70 J = PL, PU
QRAUX(J) = DNRM2(N,X(1,J),1)
WORK(J) = QRAUX(J)
70 CONTINUE
80 CONTINUE
C
C PERFORM THE HOUSEHOLDER REDUCTION OF X.
C
LUP = MIN0(N,P)
DO 200 L = 1, LUP
IF (L .LT. PL .OR. L .GE. PU) GO TO 120
C
C LOCATE THE COLUMN OF LARGEST NORM AND BRING IT
C INTO THE PIVOT POSITION.
C
MAXNRM = 0.0D0
MAXJ = L
DO 100 J = L, PU
IF (QRAUX(J) .LE. MAXNRM) GO TO 90
MAXNRM = QRAUX(J)
MAXJ = J
90 CONTINUE
100 CONTINUE
IF (MAXJ .EQ. L) GO TO 110
CALL DSWAP(N,X(1,L),1,X(1,MAXJ),1)
QRAUX(MAXJ) = QRAUX(L)
WORK(MAXJ) = WORK(L)
JP = JPVT(MAXJ)
JPVT(MAXJ) = JPVT(L)
JPVT(L) = JP
110 CONTINUE
120 CONTINUE
QRAUX(L) = 0.0D0
IF (L .EQ. N) GO TO 190
C
C COMPUTE THE HOUSEHOLDER TRANSFORMATION FOR COLUMN L.
C
NRMXL = DNRM2(N-L+1,X(L,L),1)
IF (NRMXL .EQ. 0.0D0) GO TO 180
IF (X(L,L) .NE. 0.0D0) NRMXL = DSIGN(NRMXL,X(L,L))
CALL DSCAL(N-L+1,1.0D0/NRMXL,X(L,L),1)
X(L,L) = 1.0D0 + X(L,L)
C
C APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS,
C UPDATING THE NORMS.
C
LP1 = L + 1
IF (P .LT. LP1) GO TO 170
DO 160 J = LP1, P
T = -DDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L)
CALL DAXPY(N-L+1,T,X(L,L),1,X(L,J),1)
IF (J .LT. PL .OR. J .GT. PU) GO TO 150
IF (QRAUX(J) .EQ. 0.0D0) GO TO 150
TT = 1.0D0 - (DABS(X(L,J))/QRAUX(J))**2
TT = DMAX1(TT,0.0D0)
T = TT
TT = 1.0D0 + 0.05D0*TT*(QRAUX(J)/WORK(J))**2
IF (TT .EQ. 1.0D0) GO TO 130
QRAUX(J) = QRAUX(J)*DSQRT(T)
GO TO 140
130 CONTINUE
QRAUX(J) = DNRM2(N-L,X(L+1,J),1)
WORK(J) = QRAUX(J)
140 CONTINUE
150 CONTINUE
160 CONTINUE
170 CONTINUE
C
C SAVE THE TRANSFORMATION.
C
QRAUX(L) = X(L,L)
X(L,L) = -NRMXL
180 CONTINUE
190 CONTINUE
200 CONTINUE
RETURN
END
SUBROUTINE DGTSL(N,C,D,E,B,INFO)
INTEGER N,INFO
DOUBLE PRECISION C(*),D(*),E(*),B(*)
C
C DGTSL GIVEN A GENERAL TRIDIAGONAL MATRIX AND A RIGHT HAND
C SIDE WILL FIND THE SOLUTION.
C
C ON ENTRY
C
C N INTEGER
C IS THE ORDER OF THE TRIDIAGONAL MATRIX.
C
C C DOUBLE PRECISION(N)
C IS THE SUBDIAGONAL OF THE TRIDIAGONAL MATRIX.
C C(2) THROUGH C(N) SHOULD CONTAIN THE SUBDIAGONAL.
C ON OUTPUT C IS DESTROYED.
C
C D DOUBLE PRECISION(N)
C IS THE DIAGONAL OF THE TRIDIAGONAL MATRIX.
C ON OUTPUT D IS DESTROYED.
C
C E DOUBLE PRECISION(N)
C IS THE SUPERDIAGONAL OF THE TRIDIAGONAL MATRIX.
C E(1) THROUGH E(N-1) SHOULD CONTAIN THE SUPERDIAGONAL.
C ON OUTPUT E IS DESTROYED.
C
C B DOUBLE PRECISION(N)
C IS THE RIGHT HAND SIDE VECTOR.
C
C ON RETURN
C
C B IS THE SOLUTION VECTOR.
C
C INFO INTEGER
C = 0 NORMAL VALUE.
C = K IF THE K-TH ELEMENT OF THE DIAGONAL BECOMES
C EXACTLY ZERO. THE SUBROUTINE RETURNS WHEN
C THIS IS DETECTED.
C
C LINPACK. THIS VERSION DATED 08/14/78 .
C JACK DONGARRA, ARGONNE NATIONAL LABORATORY.
C
C NO EXTERNALS
C FORTRAN DABS
C
C INTERNAL VARIABLES
C
INTEGER K,KB,KP1,NM1,NM2
DOUBLE PRECISION T
C BEGIN BLOCK PERMITTING ...EXITS TO 100
C
INFO = 0
C(1) = D(1)
NM1 = N - 1
IF (NM1 .LT. 1) GO TO 40
D(1) = E(1)
E(1) = 0.0D0
E(N) = 0.0D0
C
DO 30 K = 1, NM1
KP1 = K + 1
C
C FIND THE LARGEST OF THE TWO ROWS
C
IF (DABS(C(KP1)) .LT. DABS(C(K))) GO TO 10
C
C INTERCHANGE ROW
C
T = C(KP1)
C(KP1) = C(K)
C(K) = T
T = D(KP1)
D(KP1) = D(K)
D(K) = T
T = E(KP1)
E(KP1) = E(K)
E(K) = T
T = B(KP1)
B(KP1) = B(K)
B(K) = T
10 CONTINUE
C
C ZERO ELEMENTS
C
IF (C(K) .NE. 0.0D0) GO TO 20
INFO = K
C ............EXIT
GO TO 100
20 CONTINUE
T = -C(KP1)/C(K)
C(KP1) = D(KP1) + T*D(K)
D(KP1) = E(KP1) + T*E(K)
E(KP1) = 0.0D0
B(KP1) = B(KP1) + T*B(K)
30 CONTINUE
40 CONTINUE
IF (C(N) .NE. 0.0D0) GO TO 50
INFO = N
GO TO 90
50 CONTINUE
C
C BACK SOLVE
C
NM2 = N - 2
B(N) = B(N)/C(N)
IF (N .EQ. 1) GO TO 80
B(NM1) = (B(NM1) - D(NM1)*B(N))/C(NM1)
IF (NM2 .LT. 1) GO TO 70
DO 60 KB = 1, NM2
K = NM2 - KB + 1
B(K) = (B(K) - D(K)*B(K+1) - E(K)*B(K+2))/C(K)
60 CONTINUE
70 CONTINUE
80 CONTINUE
90 CONTINUE
100 CONTINUE
C
RETURN
END
SUBROUTINE DPTSL(N,D,E,B)
INTEGER N
DOUBLE PRECISION D(*),E(*),B(*)
C
C DPTSL GIVEN A POSITIVE DEFINITE TRIDIAGONAL MATRIX AND A RIGHT
C HAND SIDE WILL FIND THE SOLUTION.
C
C ON ENTRY
C
C N INTEGER
C IS THE ORDER OF THE TRIDIAGONAL MATRIX.
C
C D DOUBLE PRECISION(N)
C IS THE DIAGONAL OF THE TRIDIAGONAL MATRIX.
C ON OUTPUT D IS DESTROYED.
C
C E DOUBLE PRECISION(N)
C IS THE OFFDIAGONAL OF THE TRIDIAGONAL MATRIX.
C E(1) THROUGH E(N-1) SHOULD CONTAIN THE
C OFFDIAGONAL.
C
C B DOUBLE PRECISION(N)
C IS THE RIGHT HAND SIDE VECTOR.
C
C ON RETURN
C
C B CONTAINS THE SOULTION.
C
C LINPACK. THIS VERSION DATED 08/14/78 .
C JACK DONGARRA, ARGONNE NATIONAL LABORATORY.
C
C NO EXTERNALS
C FORTRAN MOD
C
C INTERNAL VARIABLES
C
INTEGER K,KBM1,KE,KF,KP1,NM1,NM1D2
DOUBLE PRECISION T1,T2
C
C CHECK FOR 1 X 1 CASE
C
IF (N .NE. 1) GO TO 10
B(1) = B(1)/D(1)
GO TO 70
10 CONTINUE
NM1 = N - 1
NM1D2 = NM1/2
IF (N .EQ. 2) GO TO 30
KBM1 = N - 1
C
C ZERO TOP HALF OF SUBDIAGONAL AND BOTTOM HALF OF
C SUPERDIAGONAL
C
DO 20 K = 1, NM1D2
T1 = E(K)/D(K)
D(K+1) = D(K+1) - T1*E(K)
B(K+1) = B(K+1) - T1*B(K)
T2 = E(KBM1)/D(KBM1+1)
D(KBM1) = D(KBM1) - T2*E(KBM1)
B(KBM1) = B(KBM1) - T2*B(KBM1+1)
KBM1 = KBM1 - 1
20 CONTINUE
30 CONTINUE
KP1 = NM1D2 + 1
C
C CLEAN UP FOR POSSIBLE 2 X 2 BLOCK AT CENTER
C
IF (MOD(N,2) .NE. 0) GO TO 40
T1 = E(KP1)/D(KP1)
D(KP1+1) = D(KP1+1) - T1*E(KP1)
B(KP1+1) = B(KP1+1) - T1*B(KP1)
KP1 = KP1 + 1
40 CONTINUE
C
C BACK SOLVE STARTING AT THE CENTER, GOING TOWARDS THE TOP
C AND BOTTOM
C
B(KP1) = B(KP1)/D(KP1)
IF (N .EQ. 2) GO TO 60
K = KP1 - 1
KE = KP1 + NM1D2 - 1
DO 50 KF = KP1, KE
B(K) = (B(K) - E(K)*B(K+1))/D(K)
B(KF+1) = (B(KF+1) - E(KF)*B(KF))/D(KF+1)
K = K - 1
50 CONTINUE
60 CONTINUE
IF (MOD(N,2) .EQ. 0) B(1) = (B(1) - E(1)*B(2))/D(1)
70 CONTINUE
RETURN
END
DOUBLE PRECISION FUNCTION DMFLOP( OPS, TIME, INFO )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
INTEGER INFO
DOUBLE PRECISION OPS, TIME
* ..
*
* Purpose
* =======
*
* DMFLOP computes the megaflop rate given the number of operations
* and time in seconds. This is basically just a divide operation,
* but care is taken not to divide by zero.
*
* Arguments
* =========
*
* OPS (input) DOUBLE PRECISION
* The number of floating point operations.
* performed by the timed routine.
*
* TIME (input) DOUBLE PRECISION
* The total time in seconds.
*
* INFO (input) INTEGER
* The return code from the timed routine. If INFO is not 0,
* then DMFLOP returns a negative value, indicating an error.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE
* ..
* .. Executable Statements ..
*
IF( TIME.LE.ZERO ) THEN
DMFLOP = ZERO
ELSE
DMFLOP = OPS / ( 1.0D6*TIME )
END IF
IF( INFO.NE.0 )
$ DMFLOP = -ABS( DBLE( INFO ) )
RETURN
*
* End of DMFLOP
*
END
DOUBLE PRECISION FUNCTION DOPAUX( SUBNAM, M, N, KL, KU, NB )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
INTEGER KL, KU, M, N, NB
* ..
*
* Purpose
* =======
*
* DOPAUX computes an approximation of the number of floating point
* operations used by the subroutine SUBNAM with the given values
* of the parameters M, N, KL, KU, and NB.
*
* This version counts operations for the LAPACK auxiliary routines.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* M (input) INTEGER
* The number of rows of the coefficient matrix. M >= 0.
*
* N (input) INTEGER
* The number of columns of the coefficient matrix.
* If the matrix is square (such as in a solve routine) then
* N is the number of right hand sides. N >= 0.
*
* KL (input) INTEGER
* The lower band width of the coefficient matrix.
* If needed, 0 <= KL <= M-1.
*
* KU (input) INTEGER
* The upper band width of the coefficient matrix.
* If needed, 0 <= KU <= N-1.
*
* NB (input) INTEGER
* The block size. If needed, NB >= 1.
*
* =====================================================================
*
* .. Local Scalars ..
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 C3
DOUBLE PRECISION ADDFAC, ADDS, EK, EM, EN, ENB, MULFAC, MULTS
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Executable Statements ..
*
DOPAUX = 0
MULTS = 0
ADDS = 0
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
IF( M.LE.0 .OR. .NOT.( LSAME( C1, 'S' ) .OR. LSAME( C1,
$ 'D' ) .OR. LSAME( C1, 'C' ) .OR. LSAME( C1, 'Z' ) ) ) THEN
RETURN
END IF
IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN
MULFAC = 1
ADDFAC = 1
ELSE
MULFAC = 6
ADDFAC = 2
END IF
EM = M
EN = N
ENB = NB
*
IF( LSAMEN( 2, C2, 'LA' ) ) THEN
*
* xLAULM: N => M
*
IF( LSAMEN( 3, C3, 'ULM' ) .OR. LSAMEN( 3, C3, 'UL2' ) ) THEN
MULTS = ( 1.D0 / 3.D0 )*EM*( -1.D0+EM*EM )
ADDS = EM*( 1.D0 / 6.D0+EM*( -1.D0 / 2.D0+EM*( 1.D0 /
$ 3.D0 ) ) )
*
* xLAUUM: N => M
*
ELSE IF( LSAMEN( 3, C3, 'UUM' ) .OR. LSAMEN( 3, C3, 'UU2' ) )
$ THEN
MULTS = EM*( 1.D0 / 3.D0+EM*( 1.D0 / 2.D0+EM*( 1.D0 /
$ 6.D0 ) ) )
ADDS = ( 1.D0 / 6.D0 )*EM*( -1.D0+EM*EM )
*
* xLACON: N => M
*
ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN
MULTS = 3.D0*EM + 3.D0
ADDS = 4.D0*EM - 3.D0
*
* xLARF: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'RF ' ) ) THEN
MULTS = 2.D0*EM*EN + EN
ADDS = 2.D0*EM*EN
*
* xLARFB: M, N, SIDE, NB => M, N, KL, NB
* where KL <= 0 indicates SIDE = 'L'
* and KL > 0 indicates SIDE = 'R'
*
ELSE IF( LSAMEN( 3, C3, 'RFB' ) ) THEN
*
* KL <= 0: Code requiring local array
*
IF( KL.LE.0 ) THEN
MULTS = EN*ENB*( 2.D0*EM+( ENB+1.D0 ) / 2.D0 )
ADDS = EN*ENB*( 2.D0*EM+( ENB-1.D0 ) / 2.D0 )
*
* KL > 0: Code not requiring local array
*
ELSE
MULTS = EN*ENB*( 2.D0*EM+( -ENB / 2.D0+5.D0 / 2.D0 ) )
ADDS = EN*ENB*( 2.D0*EM+( -ENB / 2.D0-1.D0 / 2.D0 ) )
END IF
*
* xLARFG: N => M
*
ELSE IF( LSAMEN( 3, C3, 'RFG' ) ) THEN
MULTS = 2.D0*EM + 4.D0
ADDS = EM + 1.D0
*
* xLARFT: M, NB => M, N
*
ELSE IF( LSAMEN( 3, C3, 'RFT' ) ) THEN
MULTS = EN*( ( -5.D0 / 6.D0+EN*( 1.D0+EN*( -1.D0 /
$ 6.D0 ) ) )+( EM / 2.D0 )*( EN-1.D0 ) )
ADDS = EN*( ( 1.D0 / 6.D0 )*( 1.D0-EN*EN )+( EM / 2.D0 )*
$ ( EN-1.D0 ) )
*
* xLATRD: N, K => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRD' ) ) THEN
EK = N
MULTS = EK*( ( 25.D0 / 6.D0-EK*( 3.D0 / 2.D0+( 5.D0 /
$ 3.D0 )*EK ) )+EM*( 2.D0+2.D0*EK+EM ) )
ADDS = EK*( ( -1.D0 / 3.D0-( 5.D0 / 3.D0 )*EK*EK )+EM*
$ ( -1.D0+2.D0*EK+EM ) )
END IF
*
END IF
*
DOPAUX = MULFAC*MULTS + ADDFAC*ADDS
*
RETURN
*
* End of DOPAUX
*
END
DOUBLE PRECISION FUNCTION DOPBL2( SUBNAM, M, N, KKL, KKU )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
INTEGER KKL, KKU, M, N
* ..
*
* Purpose
* =======
*
* DOPBL2 computes an approximation of the number of floating point
* operations used by a subroutine SUBNAM with the given values
* of the parameters M, N, KL, and KU.
*
* This version counts operations for the Level 2 BLAS.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* M (input) INTEGER
* The number of rows of the coefficient matrix. M >= 0.
*
* N (input) INTEGER
* The number of columns of the coefficient matrix.
* If the matrix is square (such as in a solve routine) then
* N is the number of right hand sides. N >= 0.
*
* KKL (input) INTEGER
* The lower band width of the coefficient matrix.
* KL is set to max( 0, min( M-1, KKL ) ).
*
* KKU (input) INTEGER
* The upper band width of the coefficient matrix.
* KU is set to max( 0, min( N-1, KKU ) ).
*
* =====================================================================
*
* .. Local Scalars ..
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 C3
DOUBLE PRECISION ADDS, EK, EM, EN, KL, KU, MULTS
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR. .NOT.( LSAME( SUBNAM, 'S' ) .OR. LSAME( SUBNAM,
$ 'D' ) .OR. LSAME( SUBNAM, 'C' ) .OR. LSAME( SUBNAM, 'Z' ) ) )
$ THEN
DOPBL2 = 0
RETURN
END IF
*
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
MULTS = 0
ADDS = 0
KL = MAX( 0, MIN( M-1, KKL ) )
KU = MAX( 0, MIN( N-1, KKU ) )
EM = M
EN = N
EK = KL
*
* -------------------------------
* Matrix-vector multiply routines
* -------------------------------
*
IF( LSAMEN( 3, C3, 'MV ' ) ) THEN
*
IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
MULTS = EM*( EN+1.D0 )
ADDS = EM*EN
*
* Assume M <= N + KL and KL < M
* N <= M + KU and KU < N
* so that the zero sections are triangles.
*
ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
*
MULTS = EM*( EN+1.D0 ) - ( EM-1.D0-KL )*( EM-KL ) / 2.D0 -
$ ( EN-1.D0-KU )*( EN-KU ) / 2.D0
ADDS = EM*( EN+1.D0 ) - ( EM-1.D0-KL )*( EM-KL ) / 2.D0 -
$ ( EN-1.D0-KU )*( EN-KU ) / 2.D0
*
ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHP' ) ) THEN
*
MULTS = EM*( EM+1.D0 )
ADDS = EM*EM
*
ELSE IF( LSAMEN( 2, C2, 'SB' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHB' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHB' ) ) THEN
*
MULTS = EM*( EM+1.D0 ) - ( EM-1.D0-EK )*( EM-EK )
ADDS = EM*EM - ( EM-1.D0-EK )*( EM-EK )
*
ELSE IF( LSAMEN( 2, C2, 'TR' ) .OR. LSAMEN( 2, C2, 'TP' ) )
$ THEN
*
MULTS = EM*( EM+1.D0 ) / 2.D0
ADDS = ( EM-1.D0 )*EM / 2.D0
*
ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
*
MULTS = EM*( EM+1.D0 ) / 2.D0 -
$ ( EM-EK-1.D0 )*( EM-EK ) / 2.D0
ADDS = ( EM-1.D0 )*EM / 2.D0 -
$ ( EM-EK-1.D0 )*( EM-EK ) / 2.D0
*
END IF
*
* ---------------------
* Matrix solve routines
* ---------------------
*
ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
*
IF( LSAMEN( 2, C2, 'TR' ) .OR. LSAMEN( 2, C2, 'TP' ) ) THEN
*
MULTS = EM*( EM+1.D0 ) / 2.D0
ADDS = ( EM-1.D0 )*EM / 2.D0
*
ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
*
MULTS = EM*( EM+1.D0 ) / 2.D0 -
$ ( EM-EK-1.D0 )*( EM-EK ) / 2.D0
ADDS = ( EM-1.D0 )*EM / 2.D0 -
$ ( EM-EK-1.D0 )*( EM-EK ) / 2.D0
*
END IF
*
* ----------------
* Rank-one updates
* ----------------
*
ELSE IF( LSAMEN( 3, C3, 'R ' ) ) THEN
*
IF( LSAMEN( 3, SUBNAM, 'SGE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'DGE' ) ) THEN
*
MULTS = EM*EN + MIN( EM, EN )
ADDS = EM*EN
*
ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHP' ) ) THEN
*
MULTS = EM*( EM+1.D0 ) / 2.D0 + EM
ADDS = EM*( EM+1.D0 ) / 2.D0
*
END IF
*
ELSE IF( LSAMEN( 3, C3, 'RC ' ) .OR. LSAMEN( 3, C3, 'RU ' ) ) THEN
*
IF( LSAMEN( 3, SUBNAM, 'CGE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZGE' ) ) THEN
*
MULTS = EM*EN + MIN( EM, EN )
ADDS = EM*EN
*
END IF
*
* ----------------
* Rank-two updates
* ----------------
*
ELSE IF( LSAMEN( 3, C3, 'R2 ' ) ) THEN
IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHP' ) ) THEN
*
MULTS = EM*( EM+1.D0 ) + 2.D0*EM
ADDS = EM*( EM+1.D0 )
*
END IF
END IF
*
* ------------------------------------------------
* Compute the total number of operations.
* For real and double precision routines, count
* 1 for each multiply and 1 for each add.
* For complex and complex*16 routines, count
* 6 for each multiply and 2 for each add.
* ------------------------------------------------
*
IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN
*
DOPBL2 = MULTS + ADDS
*
ELSE
*
DOPBL2 = 6*MULTS + 2*ADDS
*
END IF
*
RETURN
*
* End of DOPBL2
*
END
DOUBLE PRECISION FUNCTION DOPBL3( SUBNAM, M, N, K )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
INTEGER K, M, N
* ..
*
* Purpose
* =======
*
* DOPBL3 computes an approximation of the number of floating point
* operations used by a subroutine SUBNAM with the given values
* of the parameters M, N, and K.
*
* This version counts operations for the Level 3 BLAS.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* M (input) INTEGER
* N (input) INTEGER
* K (input) INTEGER
* M, N, and K contain parameter values used by the Level 3
* BLAS. The output matrix is always M x N or N x N if
* symmetric, but K has different uses in different
* contexts. For example, in the matrix-matrix multiply
* routine, we have
* C = A * B
* where C is M x N, A is M x K, and B is K x N.
* In xSYMM, xTRMM, and xTRSM, K indicates whether the matrix
* A is applied on the left or right. If K <= 0, the matrix
* is applied on the left, if K > 0, on the right.
*
* =====================================================================
*
* .. Local Scalars ..
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 C3
DOUBLE PRECISION ADDS, EK, EM, EN, MULTS
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR. .NOT.( LSAME( SUBNAM, 'S' ) .OR. LSAME( SUBNAM,
$ 'D' ) .OR. LSAME( SUBNAM, 'C' ) .OR. LSAME( SUBNAM, 'Z' ) ) )
$ THEN
DOPBL3 = 0
RETURN
END IF
*
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
MULTS = 0
ADDS = 0
EM = M
EN = N
EK = K
*
* ----------------------
* Matrix-matrix products
* assume beta = 1
* ----------------------
*
IF( LSAMEN( 3, C3, 'MM ' ) ) THEN
*
IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
MULTS = EM*EK*EN
ADDS = EM*EK*EN
*
ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) ) THEN
*
* IF K <= 0, assume A multiplies B on the left.
*
IF( K.LE.0 ) THEN
MULTS = EM*EM*EN
ADDS = EM*EM*EN
ELSE
MULTS = EM*EN*EN
ADDS = EM*EN*EN
END IF
*
ELSE IF( LSAMEN( 2, C2, 'TR' ) ) THEN
*
IF( K.LE.0 ) THEN
MULTS = EN*EM*( EM+1.D0 ) / 2.D0
ADDS = EN*EM*( EM-1.D0 ) / 2.D0
ELSE
MULTS = EM*EN*( EN+1.D0 ) / 2.D0
ADDS = EM*EN*( EN-1.D0 ) / 2.D0
END IF
*
END IF
*
* ------------------------------------------------
* Rank-K update of a symmetric or Hermitian matrix
* ------------------------------------------------
*
ELSE IF( LSAMEN( 3, C3, 'RK ' ) ) THEN
*
IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) ) THEN
*
MULTS = EK*EM*( EM+1.D0 ) / 2.D0
ADDS = EK*EM*( EM+1.D0 ) / 2.D0
END IF
*
* ------------------------------------------------
* Rank-2K update of a symmetric or Hermitian matrix
* ------------------------------------------------
*
ELSE IF( LSAMEN( 3, C3, 'R2K' ) ) THEN
*
IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) ) THEN
*
MULTS = EK*EM*EM
ADDS = EK*EM*EM + EM
END IF
*
* -----------------------------------------
* Solving system with many right hand sides
* -----------------------------------------
*
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'TRSM ' ) ) THEN
*
IF( K.LE.0 ) THEN
MULTS = EN*EM*( EM+1.D0 ) / 2.D0
ADDS = EN*EM*( EM-1.D0 ) / 2.D0
ELSE
MULTS = EM*EN*( EN+1.D0 ) / 2.D0
ADDS = EM*EN*( EN-1.D0 ) / 2.D0
END IF
*
END IF
*
* ------------------------------------------------
* Compute the total number of operations.
* For real and double precision routines, count
* 1 for each multiply and 1 for each add.
* For complex and complex*16 routines, count
* 6 for each multiply and 2 for each add.
* ------------------------------------------------
*
IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN
*
DOPBL3 = MULTS + ADDS
*
ELSE
*
DOPBL3 = 6*MULTS + 2*ADDS
*
END IF
*
RETURN
*
* End of DOPBL3
*
END
DOUBLE PRECISION FUNCTION DOPGB( SUBNAM, M, N, KL, KU, IPIV )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
INTEGER KL, KU, M, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
* ..
*
* Purpose
* =======
*
* DOPGB counts operations for the LU factorization of a band matrix
* xGBTRF.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* M (input) INTEGER
* The number of rows of the coefficient matrix. M >= 0.
*
* N (input) INTEGER
* The number of columns of the coefficient matrix. N >= 0.
*
* KL (input) INTEGER
* The number of subdiagonals of the matrix. KL >= 0.
*
* KU (input) INTEGER
* The number of superdiagonals of the matrix. KU >= 0.
*
* IPIV (input) INTEGER array, dimension (min(M,N))
* The vector of pivot indices from DGBTRF or ZGBTRF.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL CORZ, SORD
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 C3
INTEGER I, J, JP, JU, KM
DOUBLE PRECISION ADDFAC, ADDS, MULFAC, MULTS
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
DOPGB = 0
MULTS = 0
ADDS = 0
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
SORD = LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' )
CORZ = LSAME( C1, 'C' ) .OR. LSAME( C1, 'Z' )
IF( .NOT.( SORD .OR. CORZ ) )
$ RETURN
IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN
ADDFAC = 1
MULFAC = 1
ELSE
ADDFAC = 2
MULFAC = 6
END IF
*
* --------------------------
* GB: General Band matrices
* --------------------------
*
IF( LSAMEN( 2, C2, 'GB' ) ) THEN
*
* xGBTRF: M, N, KL, KU => M, N, KL, KU
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
JU = 1
DO 10 J = 1, MIN( M, N )
KM = MIN( KL, M-J )
JP = IPIV( J )
JU = MAX( JU, MIN( JP+KU, N ) )
IF( KM.GT.0 ) THEN
MULTS = MULTS + KM*( 1+JU-J )
ADDS = ADDS + KM*( JU-J )
END IF
10 CONTINUE
END IF
*
* ---------------------------------
* GT: General Tridiagonal matrices
* ---------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'GT' ) ) THEN
*
* xGTTRF: N => M
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = 2*( M-1 )
ADDS = M - 1
DO 20 I = 1, M - 2
IF( IPIV( I ).NE.I )
$ MULTS = MULTS + 1
20 CONTINUE
*
* xGTTRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = 4*N*( M-1 )
ADDS = 3*N*( M-1 )
*
* xGTSV: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
MULTS = ( 4*N+2 )*( M-1 )
ADDS = ( 3*N+1 )*( M-1 )
DO 30 I = 1, M - 2
IF( IPIV( I ).NE.I )
$ MULTS = MULTS + 1
30 CONTINUE
END IF
END IF
*
DOPGB = MULFAC*MULTS + ADDFAC*ADDS
RETURN
*
* End of DOPGB
*
END
DOUBLE PRECISION FUNCTION DOPLA( SUBNAM, M, N, KL, KU, NB )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
INTEGER KL, KU, M, N, NB
* ..
*
* Purpose
* =======
*
* DOPLA computes an approximation of the number of floating point
* operations used by the subroutine SUBNAM with the given values
* of the parameters M, N, KL, KU, and NB.
*
* This version counts operations for the LAPACK subroutines.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* M (input) INTEGER
* The number of rows of the coefficient matrix. M >= 0.
*
* N (input) INTEGER
* The number of columns of the coefficient matrix.
* For solve routine when the matrix is square,
* N is the number of right hand sides. N >= 0.
*
* KL (input) INTEGER
* The lower band width of the coefficient matrix.
* If needed, 0 <= KL <= M-1.
* For xGEQRS, KL is the number of right hand sides.
*
* KU (input) INTEGER
* The upper band width of the coefficient matrix.
* If needed, 0 <= KU <= N-1.
*
* NB (input) INTEGER
* The block size. If needed, NB >= 1.
*
* Notes
* =====
*
* In the comments below, the association is given between arguments
* in the requested subroutine and local arguments. For example,
*
* xGETRS: N, NRHS => M, N
*
* means that arguments N and NRHS in DGETRS are passed to arguments
* M and N in this procedure.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL CORZ, SORD
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 C3
INTEGER I
DOUBLE PRECISION ADDFAC, ADDS, EK, EM, EMN, EN, MULFAC, MULTS,
$ WL, WU
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* --------------------------------------------------------
* Initialize DOPLA to 0 and do a quick return if possible.
* --------------------------------------------------------
*
DOPLA = 0
MULTS = 0
ADDS = 0
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
SORD = LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' )
CORZ = LSAME( C1, 'C' ) .OR. LSAME( C1, 'Z' )
IF( M.LE.0 .OR. .NOT.( SORD .OR. CORZ ) )
$ RETURN
*
* ---------------------------------------------------------
* If the coefficient matrix is real, count each add as 1
* operation and each multiply as 1 operation.
* If the coefficient matrix is complex, count each add as 2
* operations and each multiply as 6 operations.
* ---------------------------------------------------------
*
IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN
ADDFAC = 1
MULFAC = 1
ELSE
ADDFAC = 2
MULFAC = 6
END IF
EM = M
EN = N
EK = KL
*
* ---------------------------------
* GE: GEneral rectangular matrices
* ---------------------------------
*
IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
* xGETRF: M, N => M, N
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
EMN = MIN( M, N )
ADDS = EMN*( EM*EN-( EM+EN )*( EMN+1.D0 ) / 2.D0+
$ ( EMN+1.D0 )*( 2.D0*EMN+1.D0 ) / 6.D0 )
MULTS = ADDS + EMN*( EM-( EMN+1.D0 ) / 2.D0 )
*
* xGETRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*EM*EM
ADDS = EN*( EM*( EM-1.D0 ) )
*
* xGETRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 5.D0 / 6.D0+EM*( 1.D0 / 2.D0+EM*( 2.D0 /
$ 3.D0 ) ) )
ADDS = EM*( 5.D0 / 6.D0+EM*( -3.D0 / 2.D0+EM*( 2.D0 /
$ 3.D0 ) ) )
*
* xGEQRF or xGEQLF: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'QRF' ) .OR.
$ LSAMEN( 3, C3, 'QR2' ) .OR.
$ LSAMEN( 3, C3, 'QLF' ) .OR. LSAMEN( 3, C3, 'QL2' ) )
$ THEN
IF( M.GE.N ) THEN
MULTS = EN*( ( ( 23.D0 / 6.D0 )+EM+EN / 2.D0 )+EN*
$ ( EM-EN / 3.D0 ) )
ADDS = EN*( ( 5.D0 / 6.D0 )+EN*
$ ( 1.D0 / 2.D0+( EM-EN / 3.D0 ) ) )
ELSE
MULTS = EM*( ( ( 23.D0 / 6.D0 )+2.D0*EN-EM / 2.D0 )+EM*
$ ( EN-EM / 3.D0 ) )
ADDS = EM*( ( 5.D0 / 6.D0 )+EN-EM / 2.D0+EM*
$ ( EN-EM / 3.D0 ) )
END IF
*
* xGERQF or xGELQF: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'RQF' ) .OR.
$ LSAMEN( 3, C3, 'RQ2' ) .OR.
$ LSAMEN( 3, C3, 'LQF' ) .OR. LSAMEN( 3, C3, 'LQ2' ) )
$ THEN
IF( M.GE.N ) THEN
MULTS = EN*( ( ( 29.D0 / 6.D0 )+EM+EN / 2.D0 )+EN*
$ ( EM-EN / 3.D0 ) )
ADDS = EN*( ( 5.D0 / 6.D0 )+EM+EN*
$ ( -1.D0 / 2.D0+( EM-EN / 3.D0 ) ) )
ELSE
MULTS = EM*( ( ( 29.D0 / 6.D0 )+2.D0*EN-EM / 2.D0 )+EM*
$ ( EN-EM / 3.D0 ) )
ADDS = EM*( ( 5.D0 / 6.D0 )+EM / 2.D0+EM*
$ ( EN-EM / 3.D0 ) )
END IF
*
* xGEQPF: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'QPF' ) ) THEN
EMN = MIN( M, N )
MULTS = 2*EN*EN + EMN*( 3*EM+5*EN+2*EM*EN-( EMN+1 )*
$ ( 4+EN+EM-( 2*EMN+1 ) / 3 ) )
ADDS = EN*EN + EMN*( 2*EM+EN+2*EM*EN-( EMN+1 )*
$ ( 2+EN+EM-( 2*EMN+1 ) / 3 ) )
*
* xGEQRS or xGERQS: M, N, NRHS => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'QRS' ) .OR. LSAMEN( 3, C3, 'RQS' ) )
$ THEN
MULTS = EK*( EN*( 2.D0-EK )+EM*
$ ( 2.D0*EN+( EM+1.D0 ) / 2.D0 ) )
ADDS = EK*( EN*( 1.D0-EK )+EM*
$ ( 2.D0*EN+( EM-1.D0 ) / 2.D0 ) )
*
* xGELQS or xGEQLS: M, N, NRHS => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'LQS' ) .OR. LSAMEN( 3, C3, 'QLS' ) )
$ THEN
MULTS = EK*( EM*( 2.D0-EK )+EN*
$ ( 2.D0*EM+( EN+1.D0 ) / 2.D0 ) )
ADDS = EK*( EM*( 1.D0-EK )+EN*
$ ( 2.D0*EM+( EN-1.D0 ) / 2.D0 ) )
*
* xGEBRD: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'BRD' ) ) THEN
IF( M.GE.N ) THEN
MULTS = EN*( 20.D0 / 3.D0+EN*
$ ( 2.D0+( 2.D0*EM-( 2.D0 / 3.D0 )*EN ) ) )
ADDS = EN*( 5.D0 / 3.D0+( EN-EM )+EN*
$ ( 2.D0*EM-( 2.D0 / 3.D0 )*EN ) )
ELSE
MULTS = EM*( 20.D0 / 3.D0+EM*
$ ( 2.D0+( 2.D0*EN-( 2.D0 / 3.D0 )*EM ) ) )
ADDS = EM*( 5.D0 / 3.D0+( EM-EN )+EM*
$ ( 2.D0*EN-( 2.D0 / 3.D0 )*EM ) )
END IF
*
* xGEHRD: N => M
*
ELSE IF( LSAMEN( 3, C3, 'HRD' ) ) THEN
IF( M.EQ.1 ) THEN
MULTS = 0.D0
ADDS = 0.D0
ELSE
MULTS = -13.D0 + EM*( -7.D0 / 6.D0+EM*
$ ( 0.5D0+EM*( 5.D0 / 3.D0 ) ) )
ADDS = -8.D0 + EM*( -2.D0 / 3.D0+EM*
$ ( -1.D0+EM*( 5.D0 / 3.D0 ) ) )
END IF
*
END IF
*
* ----------------------------
* GB: General Banded matrices
* ----------------------------
* Note: The operation count is overestimated because
* it is assumed that the factor U fills in to the maximum
* extent, i.e., that its bandwidth goes from KU to KL + KU.
*
ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
*
* xGBTRF: M, N, KL, KU => M, N, KL, KU
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
DO 10 I = MIN( M, N ), 1, -1
WL = MAX( 0, MIN( KL, M-I ) )
WU = MAX( 0, MIN( KL+KU, N-I ) )
MULTS = MULTS + WL*( 1.D0+WU )
ADDS = ADDS + WL*WU
10 CONTINUE
*
* xGBTRS: N, NRHS, KL, KU => M, N, KL, KU
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
WL = MAX( 0, MIN( KL, M-1 ) )
WU = MAX( 0, MIN( KL+KU, M-1 ) )
MULTS = EN*( EM*( WL+1.D0+WU )-0.5D0*
$ ( WL*( WL+1.D0 )+WU*( WU+1.D0 ) ) )
ADDS = EN*( EM*( WL+WU )-0.5D0*
$ ( WL*( WL+1.D0 )+WU*( WU+1.D0 ) ) )
*
END IF
*
* --------------------------------------
* PO: POsitive definite matrices
* PP: Positive definite Packed matrices
* --------------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'PP' ) ) THEN
*
* xPOTRF: N => M
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = EM*( 1.D0 / 3.D0+EM*( 1.D0 / 2.D0+EM*( 1.D0 /
$ 6.D0 ) ) )
ADDS = ( 1.D0 / 6.D0 )*EM*( -1.D0+EM*EM )
*
* xPOTRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*( EM*( EM+1.D0 ) )
ADDS = EN*( EM*( EM-1.D0 ) )
*
* xPOTRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 2.D0 / 3.D0+EM*( 1.D0+EM*( 1.D0 / 3.D0 ) ) )
ADDS = EM*( 1.D0 / 6.D0+EM*( -1.D0 / 2.D0+EM*( 1.D0 /
$ 3.D0 ) ) )
*
END IF
*
* ------------------------------------
* PB: Positive definite Band matrices
* ------------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN
*
* xPBTRF: N, K => M, KL
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = EK*( -2.D0 / 3.D0+EK*( -1.D0+EK*( -1.D0 / 3.D0 ) ) )
$ + EM*( 1.D0+EK*( 3.D0 / 2.D0+EK*( 1.D0 / 2.D0 ) ) )
ADDS = EK*( -1.D0 / 6.D0+EK*( -1.D0 / 2.D0+EK*( -1.D0 /
$ 3.D0 ) ) ) + EM*( EK / 2.D0*( 1.D0+EK ) )
*
* xPBTRS: N, NRHS, K => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*( ( 2*EM-EK )*( EK+1.D0 ) )
ADDS = EN*( EK*( 2*EM-( EK+1.D0 ) ) )
*
END IF
*
* ----------------------------------
* PT: Positive definite Tridiagonal
* ----------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'PT' ) ) THEN
*
* xPTTRF: N => M
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = 2*( EM-1 )
ADDS = EM - 1
*
* xPTTRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*( 3*EM-2 )
ADDS = EN*( 2*( EM-1 ) )
*
* xPTSV: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
MULTS = 2*( EM-1 ) + EN*( 3*EM-2 )
ADDS = EM - 1 + EN*( 2*( EM-1 ) )
END IF
*
* --------------------------------------------------------
* SY: SYmmetric indefinite matrices
* SP: Symmetric indefinite Packed matrices
* HE: HErmitian indefinite matrices (complex only)
* HP: Hermitian indefinite Packed matrices (complex only)
* --------------------------------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHP' ) ) THEN
*
* xSYTRF: N => M
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = EM*( 10.D0 / 3.D0+EM*
$ ( 1.D0 / 2.D0+EM*( 1.D0 / 6.D0 ) ) )
ADDS = EM / 6.D0*( -1.D0+EM*EM )
*
* xSYTRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*EM*EM
ADDS = EN*( EM*( EM-1.D0 ) )
*
* xSYTRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 2.D0 / 3.D0+EM*EM*( 1.D0 / 3.D0 ) )
ADDS = EM*( -1.D0 / 3.D0+EM*EM*( 1.D0 / 3.D0 ) )
*
* xSYTRD, xSYTD2: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRD' ) .OR. LSAMEN( 3, C3, 'TD2' ) )
$ THEN
IF( M.EQ.1 ) THEN
MULTS = 0.D0
ADDS = 0.D0
ELSE
MULTS = -15.D0 + EM*( -1.D0 / 6.D0+EM*
$ ( 5.D0 / 2.D0+EM*( 2.D0 / 3.D0 ) ) )
ADDS = -4.D0 + EM*( -8.D0 / 3.D0+EM*
$ ( 1.D0+EM*( 2.D0 / 3.D0 ) ) )
END IF
END IF
*
* -------------------
* Triangular matrices
* -------------------
*
ELSE IF( LSAMEN( 2, C2, 'TR' ) .OR. LSAMEN( 2, C2, 'TP' ) ) THEN
*
* xTRTRS: N, NRHS => M, N
*
IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*EM*( EM+1.D0 ) / 2.D0
ADDS = EN*EM*( EM-1.D0 ) / 2.D0
*
* xTRTRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 1.D0 / 3.D0+EM*( 1.D0 / 2.D0+EM*( 1.D0 /
$ 6.D0 ) ) )
ADDS = EM*( 1.D0 / 3.D0+EM*( -1.D0 / 2.D0+EM*( 1.D0 /
$ 6.D0 ) ) )
*
END IF
*
ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
*
* xTBTRS: N, NRHS, K => M, N, KL
*
IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*( EM*( EM+1.D0 ) / 2.D0-( EM-EK-1.D0 )*
$ ( EM-EK ) / 2.D0 )
ADDS = EN*( EM*( EM-1.D0 ) / 2.D0-( EM-EK-1.D0 )*( EM-EK ) /
$ 2.D0 )
END IF
*
* --------------------
* Trapezoidal matrices
* --------------------
*
ELSE IF( LSAMEN( 2, C2, 'TZ' ) ) THEN
*
* xTZRQF: M, N => M, N
*
IF( LSAMEN( 3, C3, 'RQF' ) ) THEN
EMN = MIN( M, N )
MULTS = 3*EM*( EN-EM+1 ) + ( 2*EN-2*EM+3 )*
$ ( EM*EM-EMN*( EMN+1 ) / 2 )
ADDS = ( EN-EM+1 )*( EM+2*EM*EM-EMN*( EMN+1 ) )
END IF
*
* -------------------
* Orthogonal matrices
* -------------------
*
ELSE IF( ( SORD .AND. LSAMEN( 2, C2, 'OR' ) ) .OR.
$ ( CORZ .AND. LSAMEN( 2, C2, 'UN' ) ) ) THEN
*
* -MQR, -MLQ, -MQL, or -MRQ: M, N, K, SIDE => M, N, KL, KU
* where KU<= 0 indicates SIDE = 'L'
* and KU> 0 indicates SIDE = 'R'
*
IF( LSAMEN( 3, C3, 'MQR' ) .OR. LSAMEN( 3, C3, 'MLQ' ) .OR.
$ LSAMEN( 3, C3, 'MQL' ) .OR. LSAMEN( 3, C3, 'MRQ' ) ) THEN
IF( KU.LE.0 ) THEN
MULTS = EK*EN*( 2.D0*EM+2.D0-EK )
ADDS = EK*EN*( 2.D0*EM+1.D0-EK )
ELSE
MULTS = EK*( EM*( 2.D0*EN-EK )+
$ ( EM+EN+( 1.D0-EK ) / 2.D0 ) )
ADDS = EK*EM*( 2.D0*EN+1.D0-EK )
END IF
*
* -GQR or -GQL: M, N, K => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'GQR' ) .OR. LSAMEN( 3, C3, 'GQL' ) )
$ THEN
MULTS = EK*( -5.D0 / 3.D0+( 2.D0*EN-EK )+
$ ( 2.D0*EM*EN+EK*( ( 2.D0 / 3.D0 )*EK-EM-EN ) ) )
ADDS = EK*( 1.D0 / 3.D0+( EN-EM )+
$ ( 2.D0*EM*EN+EK*( ( 2.D0 / 3.D0 )*EK-EM-EN ) ) )
*
* -GLQ or -GRQ: M, N, K => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'GLQ' ) .OR. LSAMEN( 3, C3, 'GRQ' ) )
$ THEN
MULTS = EK*( -2.D0 / 3.D0+( EM+EN-EK )+
$ ( 2.D0*EM*EN+EK*( ( 2.D0 / 3.D0 )*EK-EM-EN ) ) )
ADDS = EK*( 1.D0 / 3.D0+( EM-EN )+
$ ( 2.D0*EM*EN+EK*( ( 2.D0 / 3.D0 )*EK-EM-EN ) ) )
*
END IF
*
END IF
*
DOPLA = MULFAC*MULTS + ADDFAC*ADDS
*
RETURN
*
* End of DOPLA
*
END
SUBROUTINE DPRTB2( LAB1, LAB2, LAB3, NN, NVAL, NLDA, RESLTS, LDR1,
$ LDR2, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*( * ) LAB1, LAB2, LAB3
INTEGER LDR1, LDR2, NLDA, NN, NOUT
* ..
* .. Array Arguments ..
INTEGER NVAL( NN )
DOUBLE PRECISION RESLTS( LDR1, LDR2, * )
* ..
*
* Purpose
* =======
*
* DPRTB2 prints a table of timing data for the solve routines.
* There are 4 rows to each table, corresponding to
* NRHS = 1, 2, N/2, and N, or NRHS = 1, 2, K/2, K for the
* band routines.
*
* Arguments
* =========
*
* LAB1 (input) CHARACTER*(*)
* The label for the rows.
*
* LAB2 (input) CHARACTER*(*)
* The label for the columns.
*
* LAB3 CHARACTER*(*)
* The name of the variable used in the row headers (usually
* N or K).
*
* NN (input) INTEGER
* The number of values of NVAL, and also the number of columns
* of the table.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of LAB2 used for the data in each column.
*
* NLDA (input) INTEGER
* The number of values of LDA, hence the number of rows for
* each value of NRHS.
*
* RESLTS (input) DOUBLE PRECISION array, dimension (LDR1, LDR2, NLDA)
* The timing results for each value of N, K, and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= 4.
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max( 1, NN ).
*
* NOUT (input) INTEGER
* The unit number on which the table is to be printed.
* NOUT >= 0.
*
* =====================================================================
*
* .. Local Scalars ..
CHARACTER*6 COLLAB
INTEGER I, IC, INB, J, K, LNB
* ..
* .. Intrinsic Functions ..
INTRINSIC LEN, MAX
* ..
* .. Executable Statements ..
*
IF( NOUT.LE.0 )
$ RETURN
WRITE( NOUT, FMT = 9999 )LAB2, ( NVAL( I ), I = 1, NN )
WRITE( NOUT, FMT = 9998 )LAB1
*
* Find the first and last non-blank characters in LAB3.
*
INB = 0
DO 10 I = 1, LEN( LAB3 )
IF( INB.EQ.0 .AND. LAB3( I: I ).NE.' ' )
$ INB = I
IF( LAB3( I: I ).NE.' ' )
$ LNB = I
10 CONTINUE
IF( INB.EQ.0 ) THEN
INB = 1
LNB = 1
END IF
*
DO 50 I = 1, 4
IF( I.EQ.1 ) THEN
COLLAB = ' 1'
ELSE IF( I.EQ.2 ) THEN
COLLAB = ' 2'
ELSE IF( I.EQ.3 ) THEN
COLLAB = ' /2'
DO 20 J = LNB, MAX( INB, LNB-3 ), -1
IC = 4 - ( LNB-J )
COLLAB( IC: IC ) = LAB3( J: J )
20 CONTINUE
ELSE IF( I.EQ.4 ) THEN
COLLAB = ' '
DO 30 J = LNB, MAX( INB, LNB-5 ), -1
IC = 6 - ( LNB-J )
COLLAB( IC: IC ) = LAB3( J: J )
30 CONTINUE
END IF
WRITE( NOUT, FMT = 9997 )COLLAB,
$ ( RESLTS( I, J, 1 ), J = 1, NN )
DO 40 K = 2, NLDA
WRITE( NOUT, FMT = 9996 )( RESLTS( I, J, K ), J = 1, NN )
40 CONTINUE
IF( NLDA.GT.1 )
$ WRITE( NOUT, FMT = * )
50 CONTINUE
IF( NLDA.EQ.1 )
$ WRITE( NOUT, FMT = * )
*
9999 FORMAT( 6X, A4, I6, 11I8 )
9998 FORMAT( 3X, A4 )
9997 FORMAT( 1X, A6, 1X, 12F8.1 )
9996 FORMAT( 8X, 12F8.1 )
*
RETURN
*
* End of DPRTB2
*
END
SUBROUTINE DPRTB3( LAB1, LAB2, NK, KVAL, LVAL, NN, NVAL, NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*( * ) LAB1, LAB2
INTEGER LDR1, LDR2, NK, NLDA, NN, NOUT
* ..
* .. Array Arguments ..
INTEGER KVAL( NK ), LVAL( NK ), NVAL( NN )
DOUBLE PRECISION RESLTS( LDR1, LDR2, * )
* ..
*
* Purpose
* =======
*
* DPRTB3 prints a table of timing data for the timing programs.
* The table has NK block rows and NN columns, with NLDA
* individual rows in each block row. Each block row depends on two
* parameters K and L, specified as an ordered pair in the arrays KVAL
* and LVAL.
*
* Arguments
* =========
*
* LAB1 (input) CHARACTER*(*)
* The label for the rows.
*
* LAB2 (input) CHARACTER*(*)
* The label for the columns.
*
* NK (input) INTEGER
* The number of values of KVAL, and also the number of block
* rows of the table.
*
* KVAL (input) INTEGER array, dimension (NK)
* The values of the parameter K. Each block row depends on
* the pair of parameters (K, L).
*
* LVAL (input) INTEGER array, dimension (NK)
* The values of the parameter L. Each block row depends on
* the pair of parameters (K, L).
*
* NN (input) INTEGER
* The number of values of NVAL, and also the number of columns
* of the table.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of N used for the data in each column.
*
* NLDA (input) INTEGER
* The number of values of LDA, hence the number of rows for
* each value of KVAL.
*
* RESLTS (input) DOUBLE PRECISION array, dimension (LDR1, LDR2, NLDA)
* The timing results for each value of N, K, and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NK).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NN).
*
* NOUT (input) INTEGER
* The unit number on which the table is to be printed.
* NOUT >= 0.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J, K
* ..
* .. Executable Statements ..
*
IF( NOUT.LE.0 )
$ RETURN
WRITE( NOUT, FMT = 9999 )LAB2, ( NVAL( I ), I = 1, NN )
WRITE( NOUT, FMT = 9998 )LAB1
*
DO 20 I = 1, NK
IF( LAB1.EQ.' ' ) THEN
WRITE( NOUT, FMT = 9996 )( RESLTS( 1, J, 1 ), J = 1, NN )
ELSE
WRITE( NOUT, FMT = 9997 )KVAL( I ), LVAL( I ),
$ ( RESLTS( I, J, 1 ), J = 1, NN )
END IF
DO 10 K = 2, NLDA
WRITE( NOUT, FMT = 9996 )( RESLTS( I, J, K ), J = 1, NN )
10 CONTINUE
IF( NLDA.GT.1 )
$ WRITE( NOUT, FMT = * )
20 CONTINUE
IF( NLDA.EQ.1 )
$ WRITE( NOUT, FMT = * )
RETURN
*
9999 FORMAT( 10X, A4, I7, 11I8 )
9998 FORMAT( 1X, A11 )
9997 FORMAT( 1X, '(', I4, ',', I4, ') ', 12F8.1 )
9996 FORMAT( 13X, 12F8.1 )
*
* End of DPRTB3
*
END
SUBROUTINE DPRTB4( LAB1, LABM, LABN, NK, KVAL, LVAL, NM, MVAL,
$ NVAL, NLDA, RESLTS, LDR1, LDR2, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*( * ) LAB1, LABM, LABN
INTEGER LDR1, LDR2, NK, NLDA, NM, NOUT
* ..
* .. Array Arguments ..
INTEGER KVAL( NK ), LVAL( NK ), MVAL( NM ), NVAL( NM )
DOUBLE PRECISION RESLTS( LDR1, LDR2, * )
* ..
*
* Purpose
* =======
*
* DPRTB4 prints a table of timing data for the timing programs.
* The table has NK block rows and NM columns, with NLDA
* individual rows in each block row. Each block row depends on two
* parameters K and L, specified as an ordered pair in the arrays KVAL
* and LVAL, and each column depends on two parameters M and N,
* specified as an ordered pair in the arrays MVAL and NVAL.
*
* Arguments
* =========
*
* LAB1 (input) CHARACTER*(*)
* The label for the rows.
*
* LABM (input) CHARACTER*(*)
* The first label for the columns.
*
* LABN (input) CHARACTER*(*)
* The second label for the columns.
*
* NK (input) INTEGER
* The number of values of KVAL and LVAL, and also the number of
* block rows of the table. Each block row depends on the pair
* of parameters (K,L).
*
* KVAL (input) INTEGER array, dimension (NK)
* The values of the parameter K.
*
* LVAL (input) INTEGER array, dimension (NK)
* The values of the parameter L.
*
* NM (input) INTEGER
* The number of values of MVAL and NVAL, and also the number of
* columns of the table. Each column depends on the pair of
* parameters (M,N).
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the parameter M.
*
* NVAL (input) INTEGER array, dimension (NM)
* The values of the parameter N.
*
* NLDA (input) INTEGER
* The number of values of LDA, hence the number of rows for
* each pair of values (K,L).
*
* RESLTS (input) DOUBLE PRECISION array, dimension (LDR1, LDR2, NLDA)
* The timing results for each value of (M,N), (K,L), and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NK).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NM).
*
* NOUT (input) INTEGER
* The unit number on which the table is to be printed.
* NOUT >= 0.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J, K
* ..
* .. Executable Statements ..
*
IF( NOUT.LE.0 )
$ RETURN
WRITE( NOUT, FMT = 9999 )LABM, ( MVAL( I ), I = 1, NM )
WRITE( NOUT, FMT = 9999 )LABN, ( NVAL( I ), I = 1, NM )
WRITE( NOUT, FMT = 9998 )LAB1
*
DO 20 I = 1, NK
IF( LAB1.EQ.' ' ) THEN
WRITE( NOUT, FMT = 9996 )( RESLTS( 1, J, 1 ), J = 1, NM )
ELSE
WRITE( NOUT, FMT = 9997 )KVAL( I ), LVAL( I ),
$ ( RESLTS( I, J, 1 ), J = 1, NM )
END IF
DO 10 K = 2, NLDA
WRITE( NOUT, FMT = 9996 )( RESLTS( I, J, K ), J = 1, NM )
10 CONTINUE
IF( NLDA.GT.1 )
$ WRITE( NOUT, FMT = * )
20 CONTINUE
IF( NLDA.EQ.1 )
$ WRITE( NOUT, FMT = * )
RETURN
*
9999 FORMAT( 10X, A4, I7, 11I8 )
9998 FORMAT( 1X, A11 )
9997 FORMAT( 1X, '(', I4, ',', I4, ') ', 12F8.1 )
9996 FORMAT( 13X, 12F8.1 )
*
* End of DPRTB4
*
END
SUBROUTINE DPRTB5( LAB1, LABM, LABN, NK, KVAL, NM, MVAL, NVAL,
$ NLDA, RESLTS, LDR1, LDR2, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*( * ) LAB1, LABM, LABN
INTEGER LDR1, LDR2, NK, NLDA, NM, NOUT
* ..
* .. Array Arguments ..
INTEGER KVAL( NK ), MVAL( NM ), NVAL( NM )
DOUBLE PRECISION RESLTS( LDR1, LDR2, * )
* ..
*
* Purpose
* =======
*
* DPRTB5 prints a table of timing data for the timing programs.
* The table has NK block rows and NM columns, with NLDA
* individual rows in each block row. Each column depends on two
* parameters M and N, specified as an ordered pair in the arrays MVAL
* and NVAL.
*
* Arguments
* =========
*
* LAB1 (input) CHARACTER*(*)
* The label for the rows.
*
* LABM (input) CHARACTER*(*)
* The first label for the columns.
*
* LABN (input) CHARACTER*(*)
* The second label for the columns.
*
* NK (input) INTEGER
* The number of values of KVAL, and also the number of block
* rows of the table.
*
* KVAL (input) INTEGER array, dimension (NK)
* The values of LAB1 used for the data in each block row.
*
* NM (input) INTEGER
* The number of values of MVAL and NVAL, and also the number of
* columns of the table. Each column depends on the pair of
* parameters (M,N).
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the parameter M.
*
* NVAL (input) INTEGER array, dimension (NM)
* The values of the parameter N.
*
* NLDA (input) INTEGER
* The number of values of LDA, hence the number of rows for
* each value of KVAL.
*
* RESLTS (input) DOUBLE PRECISION array, dimension (LDR1, LDR2, NLDA)
* The timing results for each value of N, K, and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NK).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NM).
*
* NOUT (input) INTEGER
* The unit number on which the table is to be printed.
* NOUT >= 0.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J, K
* ..
* .. Executable Statements ..
*
IF( NOUT.LE.0 )
$ RETURN
WRITE( NOUT, FMT = 9999 )LABM, ( MVAL( I ), I = 1, NM )
WRITE( NOUT, FMT = 9999 )LABN, ( NVAL( I ), I = 1, NM )
WRITE( NOUT, FMT = 9998 )LAB1
*
DO 20 I = 1, NK
IF( LAB1.EQ.' ' ) THEN
WRITE( NOUT, FMT = 9996 )( RESLTS( 1, J, 1 ), J = 1, NM )
ELSE
WRITE( NOUT, FMT = 9997 )KVAL( I ),
$ ( RESLTS( I, J, 1 ), J = 1, NM )
END IF
DO 10 K = 2, NLDA
WRITE( NOUT, FMT = 9996 )( RESLTS( I, J, K ), J = 1, NM )
10 CONTINUE
IF( NLDA.GT.1 )
$ WRITE( NOUT, FMT = * )
20 CONTINUE
IF( NLDA.EQ.1 )
$ WRITE( NOUT, FMT = * )
RETURN
*
9999 FORMAT( 6X, A4, I6, 11I8 )
9998 FORMAT( 3X, A4 )
9997 FORMAT( 1X, I6, 1X, 12F8.1 )
9996 FORMAT( 8X, 12F8.1 )
*
* End of DPRTB5
*
END
SUBROUTINE DPRTBL( LAB1, LAB2, NK, KVAL, NN, NVAL, NLDA, RESLTS,
$ LDR1, LDR2, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*( * ) LAB1, LAB2
INTEGER LDR1, LDR2, NK, NLDA, NN, NOUT
* ..
* .. Array Arguments ..
INTEGER KVAL( NK ), NVAL( NN )
DOUBLE PRECISION RESLTS( LDR1, LDR2, * )
* ..
*
* Purpose
* =======
*
* DPRTBL prints a table of timing data for the timing programs.
* The table has NK block rows and NN columns, with NLDA
* individual rows in each block row.
*
* Arguments
* =========
*
* LAB1 (input) CHARACTER*(*)
* The label for the rows.
*
* LAB2 (input) CHARACTER*(*)
* The label for the columns.
*
* NK (input) INTEGER
* The number of values of KVAL, and also the number of block
* rows of the table.
*
* KVAL (input) INTEGER array, dimension (NK)
* The values of LAB1 used for the data in each block row.
*
* NN (input) INTEGER
* The number of values of NVAL, and also the number of columns
* of the table.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of LAB2 used for the data in each column.
*
* NLDA (input) INTEGER
* The number of values of LDA, hence the number of rows for
* each value of KVAL.
*
* RESLTS (input) DOUBLE PRECISION array, dimension (LDR1, LDR2, NLDA)
* The timing results for each value of N, K, and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max( 1, NK ).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max( 1, NN ).
*
* NOUT (input) INTEGER
* The unit number on which the table is to be printed.
* NOUT >= 0.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J, K
* ..
* .. Executable Statements ..
*
IF( NOUT.LE.0 )
$ RETURN
WRITE( NOUT, FMT = 9999 )LAB2, ( NVAL( I ), I = 1, NN )
WRITE( NOUT, FMT = 9998 )LAB1
*
DO 20 I = 1, NK
IF( LAB1.EQ.' ' ) THEN
WRITE( NOUT, FMT = 9996 )( RESLTS( 1, J, 1 ), J = 1, NN )
ELSE
WRITE( NOUT, FMT = 9997 )KVAL( I ),
$ ( RESLTS( I, J, 1 ), J = 1, NN )
END IF
DO 10 K = 2, NLDA
WRITE( NOUT, FMT = 9996 )( RESLTS( I, J, K ), J = 1, NN )
10 CONTINUE
IF( NLDA.GT.1 )
$ WRITE( NOUT, FMT = * )
20 CONTINUE
IF( NLDA.EQ.1 )
$ WRITE( NOUT, FMT = * )
RETURN
*
9999 FORMAT( 6X, A4, I6, 11I8 )
9998 FORMAT( 3X, A4 )
9997 FORMAT( 1X, I6, 1X, 12F8.1 )
9996 FORMAT( 8X, 12F8.1 )
*
* End of DPRTBL
*
END
SUBROUTINE DPRTLS( ISUB, SUBNAM, NDATA, NM, MVAL, NN, NVAL,
$ NNS, NSVAL, NNB, NBVAL, NXVAL, NLDA, LDAVAL,
$ MTYPE, RSLTS, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
INTEGER ISUB, MTYPE, NDATA, NLDA, NM, NN, NNB,
$ NNS, NOUT
* ..
* .. Array Arguments ..
INTEGER LDAVAL( * ), MVAL( * ), NBVAL( * ),
$ NSVAL( * ), NVAL( * ), NXVAL( * )
DOUBLE PRECISION RSLTS( 6, 6, * )
* ..
*
* Purpose
* =======
*
* DPRTLS prints a table of timing data for the least squares routines.
*
* Arguments
* =========
*
* ISUB (input) INTEGER
* Subroutine index.
*
* SUBNAM (input) CHARACTER*6
* Subroutine name.
*
* NDATA (input) INTEGER
* Number of components for subroutine SUBNAM.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* MTYPE (input) INTEGER
* Number of matrix types.
*
* RSLTS (workspace) DOUBLE PRECISION array
* dimension( 6, 6, number of runs )
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER ICASE, IDATA, ILDA, IM, IN, INB, INS,
$ ITYPE, LDA, M, N, NB, NRHS, NX
* ..
* .. Executable Statements ..
*
ICASE = 1
*
DO 70 IM = 1, NM
M = MVAL( IM )
DO 60 IN = 1, NN
N = NVAL( IN )
DO 50 INS = 1, NNS
NRHS = NSVAL( INS )
DO 40 ILDA = 1, NLDA
LDA = MAX( 1, LDAVAL( ILDA ) )
IF( ISUB.EQ.2 ) THEN
WRITE( NOUT, FMT = 9999 ) M, N, NRHS, LDA
WRITE( NOUT, FMT = 9998 ) SUBNAM, ( IDATA,
$ IDATA = 1, NDATA-1 )
DO 10 ITYPE = 1, MTYPE
WRITE( NOUT, FMT = 9997 ) ITYPE,
$ ( RSLTS( IDATA, ITYPE, ICASE ),
$ IDATA = 1, NDATA )
10 CONTINUE
ICASE = ICASE + 1
ELSE
DO 30 INB = 1, NNB
NB = NBVAL( INB )
NX = NXVAL( INB )
WRITE( NOUT, FMT = 9996 ) M, N, NRHS, LDA,
$ NB, NX
WRITE( NOUT, FMT = 9998 ) SUBNAM, ( IDATA,
$ IDATA = 1, NDATA-1 )
DO 20 ITYPE = 1, MTYPE
WRITE( NOUT, FMT = 9997 ) ITYPE,
$ ( RSLTS( IDATA, ITYPE, ICASE ),
$ IDATA = 1, NDATA )
20 CONTINUE
ICASE = ICASE + 1
30 CONTINUE
END IF
40 CONTINUE
50 CONTINUE
60 CONTINUE
70 CONTINUE
*
9999 FORMAT( / ' M = ', I5, ', N = ', I5, ', NRHS = ', I5,
$ ', LDA = ', I5 )
9998 FORMAT( / ' TYPE ', 4X, A6, 1X, 8( 4X, 'comp.', I2, : ) )
9997 FORMAT( I5, 2X, 1P, 6G11.2 )
9996 FORMAT( / ' M = ', I5, ', N = ', I5, ', NRHS = ', I5,
$ ', LDA = ', I5, ', NB = ', I3, ', NX = ', I3 )
RETURN
*
* End of DPRTLS
*
END
SUBROUTINE DQRT13( SCALE, M, N, A, LDA, NORMA, ISEED )
*
* -- LAPACK test routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
INTEGER LDA, M, N, SCALE
DOUBLE PRECISION NORMA
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
DOUBLE PRECISION A( LDA, * )
* ..
*
* Purpose
* =======
*
* DQRT13 generates a full-rank matrix that may be scaled to have large
* or small norm.
*
* Arguments
* =========
*
* SCALE (input) INTEGER
* SCALE = 1: normally scaled matrix
* SCALE = 2: matrix scaled up
* SCALE = 3: matrix scaled down
*
* M (input) INTEGER
* The number of rows of the matrix A.
*
* N (input) INTEGER
* The number of columns of A.
*
* A (output) DOUBLE PRECISION array, dimension (LDA,N)
* The M-by-N matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A.
*
* NORMA (output) DOUBLE PRECISION
* The one-norm of A.
*
* ISEED (input/output) integer array, dimension (4)
* Seed for random number generator
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
* ..
* .. Local Scalars ..
INTEGER INFO, J
DOUBLE PRECISION BIGNUM, SMLNUM
* ..
* .. External Functions ..
DOUBLE PRECISION DASUM, DLAMCH, DLANGE
EXTERNAL DASUM, DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DLABAD, DLARNV, DLASCL
* ..
* .. Intrinsic Functions ..
INTRINSIC SIGN
* ..
* .. Local Arrays ..
DOUBLE PRECISION DUMMY( 1 )
* ..
* .. Executable Statements ..
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
* benign matrix
*
DO 10 J = 1, N
CALL DLARNV( 2, ISEED, M, A( 1, J ) )
IF( J.LE.M ) THEN
A( J, J ) = A( J, J ) + SIGN( DASUM( M, A( 1, J ), 1 ),
$ A( J, J ) )
END IF
10 CONTINUE
*
* scaled versions
*
IF( SCALE.NE.1 ) THEN
NORMA = DLANGE( 'Max', M, N, A, LDA, DUMMY )
SMLNUM = DLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
SMLNUM = SMLNUM / DLAMCH( 'Epsilon' )
BIGNUM = ONE / SMLNUM
*
IF( SCALE.EQ.2 ) THEN
*
* matrix scaled up
*
CALL DLASCL( 'General', 0, 0, NORMA, BIGNUM, M, N, A, LDA,
$ INFO )
ELSE IF( SCALE.EQ.3 ) THEN
*
* matrix scaled down
*
CALL DLASCL( 'General', 0, 0, NORMA, SMLNUM, M, N, A, LDA,
$ INFO )
END IF
END IF
*
NORMA = DLANGE( 'One-norm', M, N, A, LDA, DUMMY )
RETURN
*
* End of DQRT13
*
END
SUBROUTINE DQRT15( SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S,
$ RANK, NORMA, NORMB, ISEED, WORK, LWORK )
*
* -- LAPACK test routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
INTEGER LDA, LDB, LWORK, M, N, NRHS, RANK, RKSEL, SCALE
DOUBLE PRECISION NORMA, NORMB
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( LWORK )
* ..
*
* Purpose
* =======
*
* DQRT15 generates a matrix with full or deficient rank and of various
* norms.
*
* Arguments
* =========
*
* SCALE (input) INTEGER
* SCALE = 1: normally scaled matrix
* SCALE = 2: matrix scaled up
* SCALE = 3: matrix scaled down
*
* RKSEL (input) INTEGER
* RKSEL = 1: full rank matrix
* RKSEL = 2: rank-deficient matrix
*
* M (input) INTEGER
* The number of rows of the matrix A.
*
* N (input) INTEGER
* The number of columns of A.
*
* NRHS (input) INTEGER
* The number of columns of B.
*
* A (output) DOUBLE PRECISION array, dimension (LDA,N)
* The M-by-N matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A.
*
* B (output) DOUBLE PRECISION array, dimension (LDB, NRHS)
* A matrix that is in the range space of matrix A.
*
* LDB (input) INTEGER
* The leading dimension of the array B.
*
* S (output) DOUBLE PRECISION array, dimension MIN(M,N)
* Singular values of A.
*
* RANK (output) INTEGER
* number of nonzero singular values of A.
*
* NORMA (output) DOUBLE PRECISION
* one-norm of A.
*
* NORMB (output) DOUBLE PRECISION
* one-norm of B.
*
* ISEED (input/output) integer array, dimension (4)
* seed for random number generator.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* length of work space required.
* LWORK >= MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M)
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, SVMIN
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ SVMIN = 0.1D0 )
* ..
* .. Local Scalars ..
INTEGER INFO, J, MN
DOUBLE PRECISION BIGNUM, EPS, SMLNUM, TEMP
* ..
* .. Local Arrays ..
DOUBLE PRECISION DUMMY( 1 )
* ..
* .. External Functions ..
DOUBLE PRECISION DASUM, DLAMCH, DLANGE, DLARND, DNRM2
EXTERNAL DASUM, DLAMCH, DLANGE, DLARND, DNRM2
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLAORD, DLARF, DLARNV, DLAROR, DLASCL,
$ DLASET, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
MN = MIN( M, N )
IF( LWORK.LT.MAX( M+MN, MN*NRHS, 2*N+M ) ) THEN
CALL XERBLA( 'DQRT15', 16 )
RETURN
END IF
*
SMLNUM = DLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
EPS = DLAMCH( 'Epsilon' )
SMLNUM = ( SMLNUM / EPS ) / EPS
BIGNUM = ONE / SMLNUM
*
* Determine rank and (unscaled) singular values
*
IF( RKSEL.EQ.1 ) THEN
RANK = MN
ELSE IF( RKSEL.EQ.2 ) THEN
RANK = ( 3*MN ) / 4
DO 10 J = RANK + 1, MN
S( J ) = ZERO
10 CONTINUE
ELSE
CALL XERBLA( 'DQRT15', 2 )
END IF
*
IF( RANK.GT.0 ) THEN
*
* Nontrivial case
*
S( 1 ) = ONE
DO 30 J = 2, RANK
20 CONTINUE
TEMP = DLARND( 1, ISEED )
IF( TEMP.GT.SVMIN ) THEN
S( J ) = ABS( TEMP )
ELSE
GO TO 20
END IF
30 CONTINUE
CALL DLAORD( 'Decreasing', RANK, S, 1 )
*
* Generate 'rank' columns of a random orthogonal matrix in A
*
CALL DLARNV( 2, ISEED, M, WORK )
CALL DSCAL( M, ONE / DNRM2( M, WORK, 1 ), WORK, 1 )
CALL DLASET( 'Full', M, RANK, ZERO, ONE, A, LDA )
CALL DLARF( 'Left', M, RANK, WORK, 1, TWO, A, LDA,
$ WORK( M+1 ) )
*
* workspace used: m+mn
*
* Generate consistent rhs in the range space of A
*
CALL DLARNV( 2, ISEED, RANK*NRHS, WORK )
CALL DGEMM( 'No transpose', 'No transpose', M, NRHS, RANK, ONE,
$ A, LDA, WORK, RANK, ZERO, B, LDB )
*
* work space used: <= mn *nrhs
*
* generate (unscaled) matrix A
*
DO 40 J = 1, RANK
CALL DSCAL( M, S( J ), A( 1, J ), 1 )
40 CONTINUE
IF( RANK.LT.N )
$ CALL DLASET( 'Full', M, N-RANK, ZERO, ZERO, A( 1, RANK+1 ),
$ LDA )
CALL DLAROR( 'Right', 'No initialization', M, N, A, LDA, ISEED,
$ WORK, INFO )
*
ELSE
*
* work space used 2*n+m
*
* Generate null matrix and rhs
*
DO 50 J = 1, MN
S( J ) = ZERO
50 CONTINUE
CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA )
CALL DLASET( 'Full', M, NRHS, ZERO, ZERO, B, LDB )
*
END IF
*
* Scale the matrix
*
IF( SCALE.NE.1 ) THEN
NORMA = DLANGE( 'Max', M, N, A, LDA, DUMMY )
IF( NORMA.NE.ZERO ) THEN
IF( SCALE.EQ.2 ) THEN
*
* matrix scaled up
*
CALL DLASCL( 'General', 0, 0, NORMA, BIGNUM, M, N, A,
$ LDA, INFO )
CALL DLASCL( 'General', 0, 0, NORMA, BIGNUM, MN, 1, S,
$ MN, INFO )
CALL DLASCL( 'General', 0, 0, NORMA, BIGNUM, M, NRHS, B,
$ LDB, INFO )
ELSE IF( SCALE.EQ.3 ) THEN
*
* matrix scaled down
*
CALL DLASCL( 'General', 0, 0, NORMA, SMLNUM, M, N, A,
$ LDA, INFO )
CALL DLASCL( 'General', 0, 0, NORMA, SMLNUM, MN, 1, S,
$ MN, INFO )
CALL DLASCL( 'General', 0, 0, NORMA, SMLNUM, M, NRHS, B,
$ LDB, INFO )
ELSE
CALL XERBLA( 'DQRT15', 1 )
RETURN
END IF
END IF
END IF
*
NORMA = DASUM( MN, S, 1 )
NORMB = DLANGE( 'One-norm', M, NRHS, B, LDB, DUMMY )
*
RETURN
*
* End of DQRT15
*
END
PROGRAM DTIMAA
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* Purpose
* =======
*
* DTIMAA is the timing program for the DOUBLE PRECISION LAPACK
* routines. This program collects performance data for the factor,
* solve, and inverse routines used in solving systems of linear
* equations, and also for the orthogonal factorization and reduction
* routines used in solving least squares problems and matrix eigenvalue
* problems.
*
* The subprograms call a DOUBLE PRECISION function DSECND with no
* arguments which is assumed to return the central-processor time in
* seconds from some fixed starting time.
*
* The program is driven by a short data file, which specifies values
* for the matrix dimensions M, N and K, for the blocking parameters
* NB and NX, and for the leading array dimension LDA. A minimum time
* for each subroutine is included for timing small problems or for
* obtaining results on a machine with an inaccurate DSECND function.
*
* The matrix dimensions M, N, and K correspond to the three dimensions
* m, n, and k in the Level 3 BLAS. When timing the LAPACK routines for
* square matrices, M and N correspond to the matrix dimensions m and n,
* and K is the number of right-hand sides (nrhs) for the solves. When
* timing the LAPACK routines for band matrices, M is the matrix order
* m, N is the half-bandwidth (kl, ku, or kd in the LAPACK notation),
* and K is again the number of right-hand sides.
*
* The first 13 records of the data file are read using list-directed
* input. The first line of input is printed as the first line of
* output and can be used to identify different sets of results. To
* assist with debugging an input file, the values are printed out as
* they are read in.
*
* The following records are read using the format (A). For these
* records, the first 6 characters are reserved for the path or
* subroutine name. If a path name is used, the characters after the
* path name indicate the routines in the path to be timed, where
* 'T' or 't' means 'Time this routine'. If the line is blank after the
* path name, all routines in the path are timed. If fewer characters
* appear than routines in a path, the remaining characters are assumed
* to be 'F'. For example, the following 3 lines are equivalent ways of
* requesting timing of DGETRF:
* DGE T F F
* DGE T
* DGETRF
*
* An annotated example of a data file can be obtained by deleting the
* first 3 characters from the following 30 lines:
* LAPACK timing, DOUBLE PRECISION square matrices
* 5 Number of values of M
* 100 200 300 400 500 Values of M (row dimension)
* 5 Number of values of N
* 100 200 300 400 500 Values of N (column dimension)
* 2 Number of values of K
* 100 400 Values of K
* 5 Number of values of NB
* 1 16 32 48 64 Values of NB (blocksize)
* 0 48 128 128 128 Values of NX (crossover point)
* 2 Number of values of LDA
* 512 513 Values of LDA (leading dimension)
* 0.0 Minimum time in seconds
* DGE T T T
* DPO T T T
* DPP T T T
* DSY T T T
* DSP T T T
* DTR T T
* DTP T T
* DQR T T F
* DLQ T T F
* DQL T T F
* DRQ T T F
* DQP T
* DHR T T F F
* DTD T T F F
* DBR T F F
* DLS T T T T T T
*
* The routines are timed for all combinations of applicable values of
* M, N, K, NB, NX, and LDA, and for all combinations of options such as
* UPLO and TRANS. For Level 2 BLAS timings, values of NB are used for
* INCX. Certain subroutines, such as the QR factorization, treat the
* values of M and N as ordered pairs and operate on M x N matrices.
*
* Internal Parameters
* ===================
*
* NMAX INTEGER
* The maximum value of M or N for square matrices.
*
* LDAMAX INTEGER
* The maximum value of LDA.
*
* NMAXB INTEGER
* The maximum value of N for band matrices.
*
* MAXVAL INTEGER
* The maximum number of values that can be read in for M, N,
* K, NB, or NX.
*
* MXNLDA INTEGER
* The maximum number of values that can be read in for LDA.
*
* NIN INTEGER
* The unit number for input. Currently set to 5 (std input).
*
* NOUT INTEGER
* The unit number for output. Currently set to 6 (std output).
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX, LDAMAX, NMAXB
PARAMETER ( NMAX = 512, LDAMAX = NMAX+20, NMAXB = 5000 )
INTEGER LA
PARAMETER ( LA = NMAX*LDAMAX )
INTEGER MAXVAL, MXNLDA
PARAMETER ( MAXVAL = 12, MXNLDA = 4 )
INTEGER MAXPRM
PARAMETER ( MAXPRM = MXNLDA*(MAXVAL+1) )
INTEGER MAXSZS
PARAMETER ( MAXSZS = MAXVAL*MAXVAL*MAXVAL )
INTEGER NIN, NOUT
PARAMETER ( NIN = 5, NOUT = 6 )
* ..
* .. Local Scalars ..
LOGICAL BLAS, LDAMOK, LDANOK, LDAOK, MOK, NOK, NXNBOK
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 C3
CHARACTER*80 LINE
INTEGER I, I2, J2, L, LDR1, LDR2, LDR3, MAXK, MAXLDA,
$ MAXM, MAXN, MAXNB, MKMAX, NEED, NK, NLDA, NM,
$ NN, NNB
DOUBLE PRECISION S1, S2, TIMMIN
* ..
* .. Local Arrays ..
INTEGER IWORK( 3*NMAXB ), KVAL( MAXVAL ),
$ LDAVAL( MXNLDA ), MVAL( MAXVAL ),
$ NBVAL( MAXVAL ), NVAL( MAXVAL ),
$ NXVAL( MAXVAL )
DOUBLE PRECISION A( LA, 4 ), D( 2*NMAX, 2 ),
$ FLPTBL( 6*6*MAXSZS*MAXPRM*5 ),
$ OPCTBL( 6*6*MAXSZS*MAXPRM*5 ),
$ RESLTS( MAXVAL, MAXVAL, 2*MXNLDA, 4*MAXVAL ),
$ S( NMAX*2 ), TIMTBL( 6*6*MAXSZS*MAXPRM*5 ),
$ WORK( NMAX, NMAX+MAXVAL+30 )
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
DOUBLE PRECISION DSECND
EXTERNAL LSAME, LSAMEN, DSECND
* ..
* .. External Subroutines ..
EXTERNAL DTIMB2, DTIMB3, DTIMBR, DTIMGB, DTIMGE, DTIMGT,
$ DTIMHR, DTIMLQ, DTIMLS, DTIMMM, DTIMMV, DTIMPB,
$ DTIMPO, DTIMPP, DTIMPT, DTIMQ3, DTIMQL, DTIMQP,
$ DTIMQR, DTIMRQ, DTIMSP, DTIMSY, DTIMTB, DTIMTD,
$ DTIMTP, DTIMTR
* ..
* .. Scalars in Common ..
INTEGER NB, NEISPK, NPROC, NSHIFT
* ..
* .. Common blocks ..
COMMON / CENVIR / NB, NPROC, NSHIFT, NEISPK
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
S1 = DSECND( )
LDR1 = MAXVAL
LDR2 = MAXVAL
LDR3 = 2*MXNLDA
WRITE( NOUT, FMT = 9983 )
*
* Read the first line. The first four characters must be 'BLAS'
* for the BLAS data file format to be used. Otherwise, the LAPACK
* data file format is assumed.
*
READ( NIN, FMT = '( A80 )' )LINE
BLAS = LSAMEN( 4, LINE, 'BLAS' )
*
* Find the last non-blank and print the first line of input as the
* first line of output.
*
DO 10 L = 80, 1, -1
IF( LINE( L: L ).NE.' ' )
$ GO TO 20
10 CONTINUE
L = 1
20 CONTINUE
WRITE( NOUT, FMT = '( 1X, A, / )' )LINE( 1: L )
WRITE( NOUT, FMT = 9992 )
*
* Read in NM and the values for M.
*
READ( NIN, FMT = * )NM
IF( NM.GT.MAXVAL ) THEN
WRITE( NOUT, FMT = 9999 )'M', 'NM', MAXVAL
NM = MAXVAL
END IF
READ( NIN, FMT = * )( MVAL( I ), I = 1, NM )
WRITE( NOUT, FMT = 9991 )'M: ', ( MVAL( I ), I = 1, NM )
*
* Check that M <= NMAXB for all values of M.
*
MOK = .TRUE.
MAXM = 0
DO 30 I = 1, NM
MAXM = MAX( MVAL( I ), MAXM )
IF( MVAL( I ).GT.NMAXB ) THEN
WRITE( NOUT, FMT = 9997 )'M', MVAL( I ), NMAXB
MOK = .FALSE.
END IF
30 CONTINUE
IF( .NOT.MOK )
$ WRITE( NOUT, FMT = * )
*
* Read in NN and the values for N.
*
READ( NIN, FMT = * )NN
IF( NN.GT.MAXVAL ) THEN
WRITE( NOUT, FMT = 9999 )'N', 'NN', MAXVAL
NN = MAXVAL
END IF
READ( NIN, FMT = * )( NVAL( I ), I = 1, NN )
WRITE( NOUT, FMT = 9991 )'N: ', ( NVAL( I ), I = 1, NN )
*
* Check that N <= NMAXB for all values of N.
*
NOK = .TRUE.
MAXN = 0
DO 40 I = 1, NN
MAXN = MAX( NVAL( I ), MAXN )
IF( NVAL( I ).GT.NMAXB ) THEN
WRITE( NOUT, FMT = 9997 )'N', NVAL( I ), NMAXB
NOK = .FALSE.
END IF
40 CONTINUE
IF( .NOT.NOK )
$ WRITE( NOUT, FMT = * )
*
* Read in NK and the values for K.
*
READ( NIN, FMT = * )NK
IF( NK.GT.MAXVAL ) THEN
WRITE( NOUT, FMT = 9999 )'K', 'NK', MAXVAL
NK = MAXVAL
END IF
READ( NIN, FMT = * )( KVAL( I ), I = 1, NK )
WRITE( NOUT, FMT = 9991 )'K: ', ( KVAL( I ), I = 1, NK )
*
* Find the maximum value of K (= NRHS).
*
MAXK = 0
DO 50 I = 1, NK
MAXK = MAX( KVAL( I ), MAXK )
50 CONTINUE
MKMAX = MAXM*MAX( 2, MAXK )
*
* Read in NNB and the values for NB. For the BLAS input files,
* NBVAL is used to store values for INCX and INCY.
*
READ( NIN, FMT = * )NNB
IF( NNB.GT.MAXVAL ) THEN
WRITE( NOUT, FMT = 9999 )'NB', 'NNB', MAXVAL
NNB = MAXVAL
END IF
READ( NIN, FMT = * )( NBVAL( I ), I = 1, NNB )
*
* Find the maximum value of NB.
*
MAXNB = 0
DO 60 I = 1, NNB
MAXNB = MAX( NBVAL( I ), MAXNB )
60 CONTINUE
*
IF( BLAS ) THEN
WRITE( NOUT, FMT = 9991 )'INCX: ', ( NBVAL( I ), I = 1, NNB )
DO 70 I = 1, NNB
NXVAL( I ) = 0
70 CONTINUE
ELSE
*
* LAPACK data files: Read in the values for NX.
*
READ( NIN, FMT = * )( NXVAL( I ), I = 1, NNB )
*
WRITE( NOUT, FMT = 9991 )'NB: ', ( NBVAL( I ), I = 1, NNB )
WRITE( NOUT, FMT = 9991 )'NX: ', ( NXVAL( I ), I = 1, NNB )
END IF
*
* Read in NLDA and the values for LDA.
*
READ( NIN, FMT = * )NLDA
IF( NLDA.GT.MXNLDA ) THEN
WRITE( NOUT, FMT = 9999 )'LDA', 'NLDA', MXNLDA
NLDA = MXNLDA
END IF
READ( NIN, FMT = * )( LDAVAL( I ), I = 1, NLDA )
WRITE( NOUT, FMT = 9991 )'LDA: ', ( LDAVAL( I ), I = 1, NLDA )
*
* Check that LDA >= 1 for all values of LDA.
*
LDAOK = .TRUE.
MAXLDA = 0
DO 80 I = 1, NLDA
MAXLDA = MAX( LDAVAL( I ), MAXLDA )
IF( LDAVAL( I ).LE.0 ) THEN
WRITE( NOUT, FMT = 9998 )LDAVAL( I )
LDAOK = .FALSE.
END IF
80 CONTINUE
IF( .NOT.LDAOK )
$ WRITE( NOUT, FMT = * )
*
* Check that MAXLDA*MAXN <= LA (for the dense routines).
*
LDANOK = .TRUE.
NEED = MAXLDA*MAXN
IF( NEED.GT.LA ) THEN
WRITE( NOUT, FMT = 9995 )MAXLDA, MAXN, NEED
LDANOK = .FALSE.
END IF
*
* Check that MAXLDA*MAXM + MAXM*MAXK <= 3*LA (for band routines).
*
LDAMOK = .TRUE.
NEED = MAXLDA*MAXM + MAXM*MAXK
IF( NEED.GT.3*LA ) THEN
NEED = ( NEED+2 ) / 3
WRITE( NOUT, FMT = 9994 )MAXLDA, MAXM, MAXK, NEED
LDAMOK = .FALSE.
END IF
*
* Check that MAXN*MAXNB (or MAXN*INCX) <= LA.
*
NXNBOK = .TRUE.
NEED = MAXN*MAXNB
IF( NEED.GT.LA ) THEN
WRITE( NOUT, FMT = 9996 )MAXN, MAXNB, NEED
NXNBOK = .FALSE.
END IF
*
IF( .NOT.( MOK .AND. NOK .AND. LDAOK .AND. LDANOK .AND. NXNBOK ) )
$ THEN
WRITE( NOUT, FMT = 9984 )
GO TO 110
END IF
IF( .NOT.LDAMOK )
$ WRITE( NOUT, FMT = * )
*
* Read the minimum time to time a subroutine.
*
WRITE( NOUT, FMT = * )
READ( NIN, FMT = * )TIMMIN
WRITE( NOUT, FMT = 9993 )TIMMIN
WRITE( NOUT, FMT = * )
*
* Read the first input line.
*
READ( NIN, FMT = '(A)', END = 100 )LINE
*
* If the first record is the special signal 'NONE', then get the
* next line but don't time DGEMV and SGEMM.
*
IF( LSAMEN( 4, LINE, 'NONE' ) ) THEN
READ( NIN, FMT = '(A)', END = 100 )LINE
ELSE
WRITE( NOUT, FMT = 9990 )
*
* If the first record is the special signal 'BAND', then time
* the band routine DGBMV and DGEMM with N = K.
*
IF( LSAMEN( 4, LINE, 'BAND' ) ) THEN
IF( LDAMOK ) THEN
IF( MKMAX.GT.LA ) THEN
I2 = 2*LA - MKMAX + 1
J2 = 2
ELSE
I2 = LA - MKMAX + 1
J2 = 3
END IF
CALL DTIMMV( 'DGBMV ', NM, MVAL, NN, NVAL, NLDA, LDAVAL,
$ TIMMIN, A( 1, 1 ), MKMAX / 2, A( I2, J2 ),
$ A( LA-MKMAX / 2+1, 3 ), RESLTS, LDR1, LDR2,
$ NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )'DGBMV '
END IF
CALL DTIMMM( 'DGEMM ', 'K', NN, NVAL, NLDA, LDAVAL, TIMMIN,
$ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), RESLTS, LDR1,
$ LDR2, NOUT )
READ( NIN, FMT = '(A)', END = 100 )LINE
*
ELSE
*
* Otherwise time DGEMV and SGEMM.
*
CALL DTIMMV( 'DGEMV ', NN, NVAL, NNB, NBVAL, NLDA, LDAVAL,
$ TIMMIN, A( 1, 1 ), LA, A( 1, 2 ), A( 1, 3 ),
$ RESLTS, LDR1, LDR2, NOUT )
CALL DTIMMM( 'DGEMM ', 'N', NN, NVAL, NLDA, LDAVAL, TIMMIN,
$ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), RESLTS, LDR1,
$ LDR2, NOUT )
END IF
END IF
*
* Call the appropriate timing routine for each input line.
*
WRITE( NOUT, FMT = 9988 )
90 CONTINUE
C1 = LINE( 1: 1 )
C2 = LINE( 2: 3 )
C3 = LINE( 4: 6 )
*
* Check first character for correct precision.
*
IF( .NOT.LSAME( C1, 'Double precision' ) ) THEN
WRITE( NOUT, FMT = 9987 )LINE( 1: 6 )
*
ELSE IF( LSAMEN( 2, C2, 'B2' ) .OR. LSAMEN( 3, C3, 'MV ' ) .OR.
$ LSAMEN( 3, C3, 'SV ' ) .OR. LSAMEN( 3, C3, 'R ' ) .OR.
$ LSAMEN( 3, C3, 'RC ' ) .OR. LSAMEN( 3, C3, 'RU ' ) .OR.
$ LSAMEN( 3, C3, 'R2 ' ) ) THEN
*
* Level 2 BLAS
*
CALL DTIMB2( LINE, NM, MVAL, NN, NVAL, NK, KVAL, NNB, NBVAL,
$ NLDA, LDAVAL, LA, TIMMIN, A( 1, 1 ), A( 1, 2 ),
$ A( 1, 3 ), RESLTS, LDR1, LDR2, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'B3' ) .OR. LSAMEN( 3, C3, 'MM ' ) .OR.
$ LSAMEN( 3, C3, 'SM ' ) .OR. LSAMEN( 3, C3, 'RK ' ) .OR.
$ LSAMEN( 3, C3, 'R2K' ) ) THEN
*
* Level 3 BLAS
*
CALL DTIMB3( LINE, NM, MVAL, NN, NVAL, NK, KVAL, NLDA, LDAVAL,
$ TIMMIN, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), RESLTS,
$ LDR1, LDR2, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'QR' ) .OR. LSAMEN( 2, C3, 'QR' ) .OR.
$ LSAMEN( 2, C3( 2: 3 ), 'QR' ) ) THEN
*
* QR routines
*
CALL DTIMQR( LINE, NN, MVAL, NVAL, NK, KVAL, NNB, NBVAL, NXVAL,
$ NLDA, LDAVAL, TIMMIN, A( 1, 1 ), D, A( 1, 2 ),
$ A( 1, 3 ), RESLTS, LDR1, LDR2, LDR3, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'LQ' ) .OR. LSAMEN( 2, C3, 'LQ' ) .OR.
$ LSAMEN( 2, C3( 2: 3 ), 'LQ' ) ) THEN
*
* LQ routines
*
CALL DTIMLQ( LINE, NN, MVAL, NVAL, NK, KVAL, NNB, NBVAL, NXVAL,
$ NLDA, LDAVAL, TIMMIN, A( 1, 1 ), D, A( 1, 2 ),
$ A( 1, 3 ), RESLTS, LDR1, LDR2, LDR3, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'QL' ) .OR. LSAMEN( 2, C3, 'QL' ) .OR.
$ LSAMEN( 2, C3( 2: 3 ), 'QL' ) ) THEN
*
* QL routines
*
CALL DTIMQL( LINE, NN, MVAL, NVAL, NK, KVAL, NNB, NBVAL, NXVAL,
$ NLDA, LDAVAL, TIMMIN, A( 1, 1 ), D, A( 1, 2 ),
$ A( 1, 3 ), RESLTS, LDR1, LDR2, LDR3, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'RQ' ) .OR. LSAMEN( 2, C3, 'RQ' ) .OR.
$ LSAMEN( 2, C3( 2: 3 ), 'RQ' ) ) THEN
*
* RQ routines
*
CALL DTIMRQ( LINE, NN, MVAL, NVAL, NK, KVAL, NNB, NBVAL, NXVAL,
$ NLDA, LDAVAL, TIMMIN, A( 1, 1 ), D, A( 1, 2 ),
$ A( 1, 3 ), RESLTS, LDR1, LDR2, LDR3, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'QP' ) .OR. LSAMEN( 3, C3, 'QPF' ) ) THEN
*
* QR with column pivoting
*
CALL DTIMQP( LINE, NM, MVAL, NVAL, NLDA, LDAVAL, TIMMIN,
$ A( 1, 1 ), A( 1, 2 ), D( 1, 1 ), A( 1, 3 ), IWORK,
$ RESLTS, LDR1, LDR2, NOUT )
*
* Blas-3 QR with column pivoting
*
CALL DTIMQ3( LINE, NM, MVAL, NVAL, NNB, NBVAL, NXVAL, NLDA,
$ LDAVAL, TIMMIN, A( 1, 1 ), A( 1, 2 ), D( 1, 1 ),
$ A( 1, 3 ), IWORK, RESLTS, LDR1, LDR2, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'HR' ) .OR. LSAMEN( 3, C3, 'HRD' ) .OR.
$ LSAMEN( 2, C3( 2: 3 ), 'HR' ) ) THEN
*
* Reduction to Hessenberg form
*
CALL DTIMHR( LINE, NN, NVAL, NK, KVAL, NNB, NBVAL, NXVAL, NLDA,
$ LDAVAL, TIMMIN, A( 1, 1 ), D, A( 1, 2 ),
$ A( 1, 3 ), RESLTS, LDR1, LDR2, LDR3, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'TD' ) .OR. LSAMEN( 3, C3, 'TRD' ) .OR.
$ LSAMEN( 2, C3( 2: 3 ), 'TR' ) ) THEN
*
* Reduction to tridiagonal form
*
CALL DTIMTD( LINE, NN, NVAL, NK, KVAL, NNB, NBVAL, NXVAL, NLDA,
$ LDAVAL, TIMMIN, A( 1, 1 ), A( 1, 2 ), D( 1, 1 ),
$ D( 1, 2 ), A( 1, 3 ), RESLTS, LDR1, LDR2, LDR3,
$ NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'BR' ) .OR. LSAMEN( 3, C3, 'BRD' ) .OR.
$ LSAMEN( 2, C3( 2: 3 ), 'BR' ) ) THEN
*
* Reduction to bidiagonal form
*
CALL DTIMBR( LINE, NN, MVAL, NVAL, NK, KVAL, NNB, NBVAL, NXVAL,
$ NLDA, LDAVAL, TIMMIN, A( 1, 1 ), A( 1, 2 ),
$ D( 1, 1 ), D( 1, 2 ), A( 1, 3 ), RESLTS, LDR1,
$ LDR2, LDR3, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
* Routines for general matrices
*
CALL DTIMGE( LINE, NN, NVAL, NK, KVAL, NNB, NBVAL, NLDA,
$ LDAVAL, TIMMIN, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
$ IWORK, RESLTS, LDR1, LDR2, LDR3, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
*
* General band matrices
*
IF( LDAMOK ) THEN
CALL DTIMGB( LINE, NM, MVAL, NN, NVAL, NK, KVAL, NNB, NBVAL,
$ NLDA, LDAVAL, TIMMIN, A( 1, 1 ),
$ A( LA-MKMAX+1, 3 ), IWORK, RESLTS, LDR1, LDR2,
$ LDR3, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )LINE( 1: 6 )
END IF
*
ELSE IF( LSAMEN( 2, C2, 'GT' ) ) THEN
*
* Routines for general tridiagonal matrices
*
CALL DTIMGT( LINE, NN, NVAL, NK, KVAL, NLDA, LDAVAL, TIMMIN,
$ A( 1, 1 ), A( 1, 2 ), IWORK, RESLTS, LDR1, LDR2,
$ LDR3, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'PO' ) ) THEN
*
* Positive definite matrices
*
CALL DTIMPO( LINE, NN, NVAL, NK, KVAL, NNB, NBVAL, NLDA,
$ LDAVAL, TIMMIN, A( 1, 1 ), A( 1, 2 ), IWORK,
$ RESLTS, LDR1, LDR2, LDR3, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'PP' ) ) THEN
*
* Positive definite packed matrices
*
CALL DTIMPP( LINE, NN, NVAL, NK, KVAL, LA, TIMMIN, A( 1, 1 ),
$ A( 1, 2 ), IWORK, RESLTS, LDR1, LDR2, LDR3, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN
*
* Positive definite banded matrices
*
IF( LDAMOK ) THEN
IF( MKMAX.GT.LA ) THEN
J2 = 2
I2 = 2*LA - MKMAX + 1
ELSE
J2 = 3
I2 = LA - MKMAX + 1
END IF
CALL DTIMPB( LINE, NM, MVAL, NN, NVAL, NK, KVAL, NNB, NBVAL,
$ NLDA, LDAVAL, TIMMIN, A( 1, 1 ), A( I2, J2 ),
$ IWORK, RESLTS, LDR1, LDR2, LDR3, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )LINE( 1: 6 )
END IF
*
ELSE IF( LSAMEN( 2, C2, 'PT' ) ) THEN
*
* Routines for positive definite tridiagonal matrices
*
CALL DTIMPT( LINE, NN, NVAL, NK, KVAL, NLDA, LDAVAL, TIMMIN,
$ A( 1, 1 ), A( 1, 2 ), RESLTS, LDR1, LDR2, LDR3,
$ NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'SY' ) ) THEN
*
* Symmetric indefinite matrices
*
CALL DTIMSY( LINE, NN, NVAL, NK, KVAL, NNB, NBVAL, NLDA,
$ LDAVAL, TIMMIN, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
$ IWORK, RESLTS, LDR1, LDR2, LDR3, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
* Symmetric indefinite packed matrices
*
CALL DTIMSP( LINE, NN, NVAL, NK, KVAL, LA, TIMMIN, A( 1, 1 ),
$ A( 1, 2 ), A( 1, 3 ), IWORK, RESLTS, LDR1, LDR2,
$ LDR3, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'TR' ) ) THEN
*
* Triangular matrices
*
CALL DTIMTR( LINE, NN, NVAL, NK, KVAL, NNB, NBVAL, NLDA,
$ LDAVAL, TIMMIN, A( 1, 1 ), A( 1, 2 ), RESLTS,
$ LDR1, LDR2, LDR3, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'TP' ) ) THEN
*
* Triangular packed matrices
*
CALL DTIMTP( LINE, NN, NVAL, NK, KVAL, LA, TIMMIN, A( 1, 1 ),
$ A( 1, 2 ), RESLTS, LDR1, LDR2, LDR3, NOUT )
*
ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
*
* Triangular band matrices
*
IF( LDAMOK ) THEN
IF( MKMAX.GT.LA ) THEN
J2 = 2
I2 = 2*LA - MKMAX + 1
ELSE
J2 = 3
I2 = LA - MKMAX + 1
END IF
CALL DTIMTB( LINE, NM, MVAL, NN, NVAL, NK, KVAL, NLDA,
$ LDAVAL, TIMMIN, A( 1, 1 ), A( I2, J2 ), RESLTS,
$ LDR1, LDR2, LDR3, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )LINE( 1: 6 )
END IF
*
ELSE IF( LSAMEN( 2, C2, 'LS' ) ) THEN
*
* Least squares drivers
*
CALL DTIMLS( LINE, NM, MVAL, NN, NVAL, NK, KVAL, NNB, NBVAL,
$ NXVAL, NLDA, LDAVAL, TIMMIN, A( 1, 1 ), A( 1, 2 ),
$ A( 1, 3 ), A( 1, 4 ), S, S( NMAX+1 ), OPCTBL,
$ TIMTBL, FLPTBL, WORK, IWORK, NOUT )
*
ELSE
*
WRITE( NOUT, FMT = 9987 )LINE( 1: 6 )
END IF
*
* Read the next line of the input file.
*
READ( NIN, FMT = '(A)', END = 100 )LINE
GO TO 90
*
* Branch to this line when the last record is read.
*
100 CONTINUE
S2 = DSECND( )
WRITE( NOUT, FMT = 9986 )
WRITE( NOUT, FMT = 9985 )S2 - S1
110 CONTINUE
*
9999 FORMAT( ' Too many values of ', A, ' using ', A, ' = ', I2 )
9998 FORMAT( ' *** LDA = ', I7, ' is too small, must have ',
$ 'LDA > 0.' )
9997 FORMAT( ' *** ', A1, ' = ', I7, ' is too big: ',
$ 'maximum allowed is', I7 )
9996 FORMAT( ' *** N*NB is too big for N =', I6, ', NB =', I6,
$ / ' --> Increase LA to at least ', I8 )
9995 FORMAT( ' *** LDA*N is too big for the dense routines ', '(LDA =',
$ I6, ', N =', I6, ')', / ' --> Increase LA to at least ',
$ I8 )
9994 FORMAT( ' *** (LDA+K)*M is too big for the band routines ',
$ '(LDA=', I6, ', M=', I6, ', K=', I6, ')',
$ / ' --> Increase LA to at least ', I8 )
9993 FORMAT( ' The minimum time a subroutine will be timed = ', F6.3,
$ ' seconds' )
9992 FORMAT( ' The following parameter values will be used:' )
9991 FORMAT( 4X, A7, 1X, 10I6, / 12X, 10I6 )
9990 FORMAT( / ' ------------------------------',
$ / ' >>>>> Sample BLAS <<<<<',
$ / ' ------------------------------' )
9989 FORMAT( 1X, A6, ' not timed due to input errors', / )
9988 FORMAT( / ' ------------------------------',
$ / ' >>>>> Timing data <<<<<',
$ / ' ------------------------------' )
9987 FORMAT( 1X, A6, ': Unrecognized path or subroutine name', / )
9986 FORMAT( ' End of tests' )
9985 FORMAT( ' Total time used = ', F12.2, ' seconds' )
9984 FORMAT( / ' Tests not done due to input errors' )
9983 FORMAT( ' LAPACK VERSION 3.0, released June 30, 1999 ', / )
*
* End of DTIMAA
*
END
SUBROUTINE DTIMB2( LINE, NM, MVAL, NN, NVAL, NK, KVAL, NINC,
$ INCVAL, NLDA, LDAVAL, LA, TIMMIN, A, X, Y,
$ RESLTS, LDR1, LDR2, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*( * ) LINE
INTEGER LA, LDR1, LDR2, NINC, NK, NLDA, NM, NN, NOUT
DOUBLE PRECISION TIMMIN
* ..
* .. Array Arguments ..
INTEGER INCVAL( * ), KVAL( * ), LDAVAL( * ), MVAL( * ),
$ NVAL( * )
DOUBLE PRECISION A( * ), RESLTS( LDR1, LDR2, * ), X( * ), Y( * )
* ..
*
* Purpose
* =======
*
* DTIMB2 times the BLAS 2 routines.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NK (input) INTEGER
* The number of values of K contained in the vector KVAL.
*
* KVAL (input) INTEGER array, dimension (NK)
* The values of the band width K.
*
* NINC (input) INTEGER
* The number of values of INCX contained in the vector INCVAL.
*
* INCVAL (input) INTEGER array, dimension (NINC)
* The values of INCX, the increment between successive values
* of the vector X.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* LA (input) INTEGER
* The size of the array A.
*
* TIMMIN (input) DOUBLE PRECISION
* The minimum time a subroutine will be timed.
*
* A (workspace) DOUBLE PRECISION array, dimension (LA)
*
* X (workspace) DOUBLE PRECISION array, dimension (NMAX*INCMAX)
* where NMAX and INCMAX are the maximum values permitted
* for N and INCX.
*
* Y (workspace) DOUBLE PRECISION array, dimension (NMAX*INCMAX)
* where NMAX and INCMAX are the maximum values permitted
* for N and INCX.
*
* RESLTS (output) DOUBLE PRECISION array, dimension (LDR1,LDR2,p),
* where p = NLDA*NINC.
* The timing results for each subroutine over the relevant
* values of M, N, K, INCX, and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NM,NK).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NN).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 16 )
INTEGER NTRANS, NUPLOS
PARAMETER ( NTRANS = 2, NUPLOS = 2 )
DOUBLE PRECISION ALPHA, BETA
PARAMETER ( ALPHA = 1.0D0, BETA = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL IXANDY
CHARACTER TRANSA, UPLO
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, I3, IC, ICL, IINC, IK, ILDA, IM, IMAT, IN,
$ INCX, INFO, ISUB, ITA, IUPLO, J, K, LDA, M, N,
$ NX, NY
DOUBLE PRECISION OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER TRANS( NTRANS ), UPLOS( NUPLOS )
CHARACTER*6 NAMES( NSUBS )
INTEGER LAVAL( 1 )
* ..
* .. External Functions ..
DOUBLE PRECISION DMFLOP, DOPBL2, DSECND
EXTERNAL DMFLOP, DOPBL2, DSECND
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, DGBMV, DGEMV, DGER, DPRTBL,
$ DSBMV, DSPMV, DSPR, DSPR2, DSYMV, DSYR, DSYR2,
$ DTBMV, DTBSV, DTIMMG, DTPMV, DTPSV, DTRMV,
$ DTRSV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Data statements ..
DATA TRANS / 'N', 'T' /
DATA UPLOS / 'U', 'L' /
DATA NAMES / 'DGEMV ', 'DGBMV ', 'DSYMV ', 'DSBMV ',
$ 'DSPMV ', 'DTRMV ', 'DTBMV ', 'DTPMV ',
$ 'DTRSV ', 'DTBSV ', 'DTPSV ', 'DGER ',
$ 'DSYR ', 'DSPR ', 'DSYR2 ', 'DSPR2 ' /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'B2'
CALL ATIMIN( PATH, LINE, NSUBS, NAMES, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 1070
*
* Time each routine
*
DO 1060 ISUB = 1, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 1060
*
* Check the input values. The conditions are
* M <= LDA for general storage
* K <= LDA for banded storage
* N*(N+1)/2 <= LA for packed storage
*
CNAME = NAMES( ISUB )
IF( CNAME( 2: 3 ).EQ.'GE' ) THEN
CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO )
ELSE IF( CNAME( 3: 3 ).EQ.'B' ) THEN
CALL ATIMCK( 0, CNAME, NK, KVAL, NLDA, LDAVAL, NOUT, INFO )
ELSE IF( CNAME( 3: 3 ).EQ.'P' ) THEN
LAVAL( 1 ) = LA
CALL ATIMCK( 4, CNAME, NN, NVAL, 1, LAVAL, NOUT, INFO )
ELSE
CALL ATIMCK( 2, CNAME, NN, NVAL, NLDA, LDAVAL, NOUT, INFO )
END IF
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 1060
END IF
*
* Print header.
*
WRITE( NOUT, FMT = 9998 )CNAME
IXANDY = ISUB.LE.5 .OR. ISUB.EQ.12 .OR. ISUB.EQ.15 .OR.
$ ISUB.EQ.16
IF( CNAME( 3: 3 ).NE.'P' ) THEN
IF( NLDA*NINC.EQ.1 ) THEN
IF( IXANDY ) THEN
WRITE( NOUT, FMT = 9997 )LDAVAL( 1 ), INCVAL( 1 )
ELSE
WRITE( NOUT, FMT = 9996 )LDAVAL( 1 ), INCVAL( 1 )
END IF
ELSE
DO 20 I = 1, NLDA
DO 10 J = 1, NINC
IF( IXANDY ) THEN
WRITE( NOUT, FMT = 9993 )( I-1 )*NINC + J,
$ LDAVAL( I ), INCVAL( J )
ELSE
WRITE( NOUT, FMT = 9992 )( I-1 )*NINC + J,
$ LDAVAL( I ), INCVAL( J )
END IF
10 CONTINUE
20 CONTINUE
END IF
ELSE
IF( NINC.EQ.1 ) THEN
IF( IXANDY ) THEN
WRITE( NOUT, FMT = 9995 )INCVAL( 1 )
ELSE
WRITE( NOUT, FMT = 9994 )INCVAL( 1 )
END IF
ELSE
DO 30 J = 1, NINC
IF( IXANDY ) THEN
WRITE( NOUT, FMT = 9991 )J, INCVAL( J )
ELSE
WRITE( NOUT, FMT = 9990 )J, INCVAL( J )
END IF
30 CONTINUE
END IF
END IF
*
* Time DGEMV
*
IF( CNAME.EQ.'DGEMV ' ) THEN
DO 100 ITA = 1, NTRANS
TRANSA = TRANS( ITA )
I3 = 0
DO 90 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 80 IINC = 1, NINC
INCX = INCVAL( IINC )
I3 = I3 + 1
DO 70 IM = 1, NM
M = MVAL( IM )
DO 60 IN = 1, NN
N = NVAL( IN )
IF( TRANSA.EQ.'N' ) THEN
NX = N
NY = M
ELSE
NX = M
NY = N
END IF
CALL DTIMMG( 1, M, N, A, LDA, 0, 0 )
CALL DTIMMG( 0, 1, NX, X, INCX, 0, 0 )
CALL DTIMMG( 0, 1, NY, Y, INCX, 0, 0 )
IC = 0
S1 = DSECND( )
40 CONTINUE
CALL DGEMV( TRANSA, M, N, ALPHA, A, LDA, X,
$ INCX, BETA, Y, INCX )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, 1, NY, Y, INCX, 0, 0 )
GO TO 40
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
50 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, 1, NY, Y, INCX, 0, 0 )
GO TO 50
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPBL2( CNAME, M, N, 0, 0 )
RESLTS( IM, IN, I3 ) = DMFLOP( OPS, TIME, 0 )
60 CONTINUE
70 CONTINUE
80 CONTINUE
90 CONTINUE
WRITE( NOUT, FMT = 9989 )TRANSA
CALL DPRTBL( 'M', 'N', NM, MVAL, NN, NVAL, NINC*NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
100 CONTINUE
*
ELSE IF( CNAME.EQ.'DGBMV ' ) THEN
*
* Time DGBMV
*
DO 170 ITA = 1, NTRANS
TRANSA = TRANS( ITA )
I3 = 0
DO 160 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 150 IINC = 1, NINC
INCX = INCVAL( IINC )
I3 = I3 + 1
DO 140 IK = 1, NK
K = KVAL( IK )
DO 130 IN = 1, NN
N = NVAL( IN )
M = N
CALL DTIMMG( -2, M, N, A, LDA, K, K )
CALL DTIMMG( 0, 1, N, X, INCX, 0, 0 )
CALL DTIMMG( 0, 1, M, Y, INCX, 0, 0 )
IC = 0
S1 = DSECND( )
110 CONTINUE
CALL DGBMV( TRANSA, M, N, K, K, ALPHA, A,
$ LDA, X, INCX, BETA, Y, INCX )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, 1, M, Y, INCX, 0, 0 )
GO TO 110
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
120 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, 1, M, Y, INCX, 0, 0 )
GO TO 120
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPBL2( CNAME, M, N, K, K )
RESLTS( IK, IN, I3 ) = DMFLOP( OPS, TIME, 0 )
130 CONTINUE
140 CONTINUE
150 CONTINUE
160 CONTINUE
WRITE( NOUT, FMT = 9988 )TRANSA
CALL DPRTBL( 'K', 'N', NK, KVAL, NN, NVAL, NINC*NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
170 CONTINUE
*
ELSE IF( CNAME.EQ.'DSYMV ' ) THEN
*
* Time DSYMV
*
DO 230 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IMAT = 6
IF( UPLO.EQ.'L' )
$ IMAT = -6
I3 = 0
DO 220 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 210 IINC = 1, NINC
INCX = INCVAL( IINC )
I3 = I3 + 1
DO 200 IN = 1, NN
N = NVAL( IN )
CALL DTIMMG( IMAT, N, N, A, LDA, 0, 0 )
CALL DTIMMG( 0, 1, N, X, INCX, 0, 0 )
CALL DTIMMG( 0, 1, N, Y, INCX, 0, 0 )
IC = 0
S1 = DSECND( )
180 CONTINUE
CALL DSYMV( UPLO, N, ALPHA, A, LDA, X, INCX,
$ BETA, Y, INCX )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, 1, N, Y, INCX, 0, 0 )
GO TO 180
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
190 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, 1, N, Y, INCX, 0, 0 )
GO TO 190
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPBL2( CNAME, N, N, 0, 0 )
RESLTS( 1, IN, I3 ) = DMFLOP( OPS, TIME, 0 )
200 CONTINUE
210 CONTINUE
220 CONTINUE
WRITE( NOUT, FMT = 9986 )CNAME, UPLO
CALL DPRTBL( ' ', 'N', 1, NVAL, NN, NVAL, NINC*NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
230 CONTINUE
*
ELSE IF( CNAME.EQ.'DSBMV ' ) THEN
*
* Time DSBMV
*
DO 300 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IMAT = 8
IF( UPLO.EQ.'L' )
$ IMAT = -8
I3 = 0
DO 290 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 280 IINC = 1, NINC
INCX = INCVAL( IINC )
I3 = I3 + 1
DO 270 IK = 1, NK
K = KVAL( IK )
DO 260 IN = 1, NN
N = NVAL( IN )
CALL DTIMMG( IMAT, N, N, A, LDA, K, K )
CALL DTIMMG( 0, 1, N, X, INCX, 0, 0 )
CALL DTIMMG( 0, 1, N, Y, INCX, 0, 0 )
IC = 0
S1 = DSECND( )
240 CONTINUE
CALL DSBMV( UPLO, N, K, ALPHA, A, LDA, X,
$ INCX, BETA, Y, INCX )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, 1, N, Y, INCX, 0, 0 )
GO TO 240
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
250 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, 1, N, Y, INCX, 0, 0 )
GO TO 250
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPBL2( CNAME, N, N, K, K )
RESLTS( IK, IN, I3 ) = DMFLOP( OPS, TIME, 0 )
260 CONTINUE
270 CONTINUE
280 CONTINUE
290 CONTINUE
WRITE( NOUT, FMT = 9986 )CNAME, UPLO
CALL DPRTBL( 'K', 'N', NK, KVAL, NN, NVAL, NINC*NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
300 CONTINUE
*
ELSE IF( CNAME.EQ.'DSPMV ' ) THEN
*
* Time DSPMV
*
DO 350 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IMAT = 7
IF( UPLO.EQ.'L' )
$ IMAT = -7
ILDA = 1
LDA = LDAVAL( ILDA )
DO 340 IINC = 1, NINC
INCX = INCVAL( IINC )
DO 330 IN = 1, NN
N = NVAL( IN )
CALL DTIMMG( IMAT, N, N, A, N*( N+1 ) / 2, 0, 0 )
CALL DTIMMG( 0, 1, N, X, INCX, 0, 0 )
CALL DTIMMG( 0, 1, N, Y, INCX, 0, 0 )
IC = 0
S1 = DSECND( )
310 CONTINUE
CALL DSPMV( UPLO, N, ALPHA, A, X, INCX, BETA, Y,
$ INCX )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, 1, N, Y, INCX, 0, 0 )
GO TO 310
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
320 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, 1, N, Y, INCX, 0, 0 )
GO TO 320
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPBL2( CNAME, N, N, 0, 0 )
RESLTS( 1, IN, IINC ) = DMFLOP( OPS, TIME, 0 )
330 CONTINUE
340 CONTINUE
WRITE( NOUT, FMT = 9986 )CNAME, UPLO
CALL DPRTBL( ' ', 'N', 1, NVAL, NN, NVAL, NINC, RESLTS,
$ LDR1, LDR2, NOUT )
350 CONTINUE
*
ELSE IF( CNAME.EQ.'DTRMV ' ) THEN
*
* Time DTRMV
*
DO 420 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IMAT = 9
IF( UPLO.EQ.'L' )
$ IMAT = -9
DO 410 ITA = 1, NTRANS
TRANSA = TRANS( ITA )
I3 = 0
DO 400 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 390 IINC = 1, NINC
INCX = INCVAL( IINC )
I3 = I3 + 1
DO 380 IN = 1, NN
N = NVAL( IN )
CALL DTIMMG( IMAT, N, N, A, LDA, 0, 0 )
CALL DTIMMG( 0, 1, N, X, INCX, 0, 0 )
IC = 0
S1 = DSECND( )
360 CONTINUE
CALL DTRMV( UPLO, TRANSA, 'Non-unit', N, A,
$ LDA, X, INCX )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, 1, N, X, INCX, 0, 0 )
GO TO 360
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
370 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, 1, N, X, INCX, 0, 0 )
GO TO 370
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPBL2( CNAME, N, N, 0, 0 )
RESLTS( 1, IN, I3 ) = DMFLOP( OPS, TIME, 0 )
380 CONTINUE
390 CONTINUE
400 CONTINUE
WRITE( NOUT, FMT = 9987 )CNAME, UPLO, TRANSA
CALL DPRTBL( ' ', 'N', 1, NVAL, NN, NVAL, NINC*NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
410 CONTINUE
420 CONTINUE
*
ELSE IF( CNAME.EQ.'DTRSV ' ) THEN
*
* Time DTRSV
*
DO 490 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IMAT = 9
IF( UPLO.EQ.'L' )
$ IMAT = -9
DO 480 ITA = 1, NTRANS
TRANSA = TRANS( ITA )
I3 = 0
DO 470 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 460 IINC = 1, NINC
INCX = INCVAL( IINC )
I3 = I3 + 1
DO 450 IN = 1, NN
N = NVAL( IN )
CALL DTIMMG( IMAT, N, N, A, LDA, 0, 0 )
CALL DTIMMG( 0, 1, N, X, INCX, 0, 0 )
IC = 0
S1 = DSECND( )
430 CONTINUE
CALL DTRSV( UPLO, TRANSA, 'Non-unit', N, A,
$ LDA, X, INCX )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, 1, N, X, INCX, 0, 0 )
GO TO 430
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
440 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, 1, N, X, INCX, 0, 0 )
GO TO 440
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPBL2( CNAME, N, N, 0, 0 )
RESLTS( 1, IN, I3 ) = DMFLOP( OPS, TIME, 0 )
450 CONTINUE
460 CONTINUE
470 CONTINUE
WRITE( NOUT, FMT = 9987 )CNAME, UPLO, TRANSA
CALL DPRTBL( ' ', 'N', 1, NVAL, NN, NVAL, NINC*NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
480 CONTINUE
490 CONTINUE
*
ELSE IF( CNAME.EQ.'DTBMV ' ) THEN
*
* Time DTBMV
*
DO 570 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IMAT = 11
IF( UPLO.EQ.'L' )
$ IMAT = -11
DO 560 ITA = 1, NTRANS
TRANSA = TRANS( ITA )
I3 = 0
DO 550 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 540 IINC = 1, NINC
INCX = INCVAL( IINC )
I3 = I3 + 1
DO 530 IK = 1, NK
K = KVAL( IK )
DO 520 IN = 1, NN
N = NVAL( IN )
CALL DTIMMG( IMAT, N, N, A, LDA, K, K )
CALL DTIMMG( 0, 1, N, X, INCX, 0, 0 )
IC = 0
S1 = DSECND( )
500 CONTINUE
CALL DTBMV( UPLO, TRANSA, 'Non-unit', N,
$ K, A, LDA, X, INCX )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, 1, N, X, INCX, 0, 0 )
GO TO 500
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
510 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, 1, N, X, INCX, 0, 0 )
GO TO 510
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPBL2( CNAME, N, N, K, K )
RESLTS( IK, IN, I3 ) = DMFLOP( OPS, TIME,
$ 0 )
520 CONTINUE
530 CONTINUE
540 CONTINUE
550 CONTINUE
WRITE( NOUT, FMT = 9987 )CNAME, UPLO, TRANSA
CALL DPRTBL( 'K', 'N', NK, KVAL, NN, NVAL, NINC*NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
560 CONTINUE
570 CONTINUE
*
ELSE IF( CNAME.EQ.'DTBSV ' ) THEN
*
* Time DTBSV
*
DO 650 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IMAT = 11
IF( UPLO.EQ.'L' )
$ IMAT = -11
DO 640 ITA = 1, NTRANS
TRANSA = TRANS( ITA )
I3 = 0
DO 630 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 620 IINC = 1, NINC
INCX = INCVAL( IINC )
I3 = I3 + 1
DO 610 IK = 1, NK
K = KVAL( IK )
DO 600 IN = 1, NN
N = NVAL( IN )
CALL DTIMMG( IMAT, N, N, A, LDA, K, K )
CALL DTIMMG( 0, 1, N, X, INCX, 0, 0 )
IC = 0
S1 = DSECND( )
580 CONTINUE
CALL DTBSV( UPLO, TRANSA, 'Non-unit', N,
$ K, A, LDA, X, INCX )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, 1, N, X, INCX, 0, 0 )
GO TO 580
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
590 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, 1, N, X, INCX, 0, 0 )
GO TO 590
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPBL2( CNAME, N, N, K, K )
RESLTS( IK, IN, I3 ) = DMFLOP( OPS, TIME,
$ 0 )
600 CONTINUE
610 CONTINUE
620 CONTINUE
630 CONTINUE
WRITE( NOUT, FMT = 9987 )CNAME, UPLO, TRANSA
CALL DPRTBL( 'K', 'N', NK, KVAL, NN, NVAL, NINC*NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
640 CONTINUE
650 CONTINUE
*
ELSE IF( CNAME.EQ.'DTPMV ' ) THEN
*
* Time DTPMV
*
DO 710 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IMAT = 10
IF( UPLO.EQ.'L' )
$ IMAT = -10
DO 700 ITA = 1, NTRANS
TRANSA = TRANS( ITA )
ILDA = 1
LDA = LDAVAL( ILDA )
DO 690 IINC = 1, NINC
INCX = INCVAL( IINC )
DO 680 IN = 1, NN
N = NVAL( IN )
CALL DTIMMG( IMAT, N, N, A, N*( N+1 ) / 2, 0,
$ 0 )
CALL DTIMMG( 0, 1, N, X, INCX, 0, 0 )
IC = 0
S1 = DSECND( )
660 CONTINUE
CALL DTPMV( UPLO, TRANSA, 'Non-unit', N, A, X,
$ INCX )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, 1, N, X, INCX, 0, 0 )
GO TO 660
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
670 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, 1, N, X, INCX, 0, 0 )
GO TO 670
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPBL2( CNAME, N, N, 0, 0 )
RESLTS( 1, IN, IINC ) = DMFLOP( OPS, TIME, 0 )
680 CONTINUE
690 CONTINUE
WRITE( NOUT, FMT = 9987 )CNAME, UPLO, TRANSA
CALL DPRTBL( ' ', 'N', 1, NVAL, NN, NVAL, NINC,
$ RESLTS, LDR1, LDR2, NOUT )
700 CONTINUE
710 CONTINUE
*
ELSE IF( CNAME.EQ.'DTPSV ' ) THEN
*
* Time DTPSV
*
DO 770 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IMAT = 10
IF( UPLO.EQ.'L' )
$ IMAT = -10
DO 760 ITA = 1, NTRANS
TRANSA = TRANS( ITA )
ILDA = 1
LDA = LDAVAL( ILDA )
DO 750 IINC = 1, NINC
INCX = INCVAL( IINC )
DO 740 IN = 1, NN
N = NVAL( IN )
CALL DTIMMG( IMAT, N, N, A, N*( N+1 ) / 2, 0,
$ 0 )
CALL DTIMMG( 0, 1, N, X, INCX, 0, 0 )
IC = 0
S1 = DSECND( )
720 CONTINUE
CALL DTPSV( UPLO, TRANSA, 'Non-unit', N, A, X,
$ INCX )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, 1, N, X, INCX, 0, 0 )
GO TO 720
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
730 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, 1, N, X, INCX, 0, 0 )
GO TO 730
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPBL2( CNAME, N, N, 0, 0 )
RESLTS( 1, IN, IINC ) = DMFLOP( OPS, TIME, 0 )
740 CONTINUE
750 CONTINUE
WRITE( NOUT, FMT = 9987 )CNAME, UPLO, TRANSA
CALL DPRTBL( ' ', 'N', 1, NVAL, NN, NVAL, NINC,
$ RESLTS, LDR1, LDR2, NOUT )
760 CONTINUE
770 CONTINUE
*
ELSE IF( CNAME.EQ.'DGER ' ) THEN
*
* Time DGER
*
I3 = 0
DO 830 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 820 IINC = 1, NINC
INCX = INCVAL( IINC )
I3 = I3 + 1
DO 810 IM = 1, NM
M = MVAL( IM )
DO 800 IN = 1, NN
N = NVAL( IN )
CALL DTIMMG( 0, 1, M, X, INCX, 0, 0 )
CALL DTIMMG( 0, 1, N, Y, INCX, 0, 0 )
CALL DTIMMG( 1, M, N, A, LDA, 0, 0 )
IC = 0
S1 = DSECND( )
780 CONTINUE
CALL DGER( M, N, ALPHA, X, INCX, Y, INCX, A,
$ LDA )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 1, M, N, A, LDA, 0, 0 )
GO TO 780
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
790 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 1, M, N, A, LDA, 0, 0 )
GO TO 790
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPBL2( CNAME, M, N, 0, 0 )
RESLTS( IM, IN, I3 ) = DMFLOP( OPS, TIME, 0 )
800 CONTINUE
810 CONTINUE
820 CONTINUE
830 CONTINUE
WRITE( NOUT, FMT = 9985 )
CALL DPRTBL( 'M', 'N', NM, MVAL, NN, NVAL, NINC*NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
*
ELSE IF( CNAME.EQ.'DSYR ' ) THEN
*
* Time DSYR
*
DO 890 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IMAT = 6
IF( UPLO.EQ.'L' )
$ IMAT = -6
I3 = 0
DO 880 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 870 IINC = 1, NINC
INCX = INCVAL( IINC )
I3 = I3 + 1
DO 860 IN = 1, NN
N = NVAL( IN )
CALL DTIMMG( 0, 1, N, X, INCX, 0, 0 )
CALL DTIMMG( 0, 1, N, Y, INCX, 0, 0 )
CALL DTIMMG( IMAT, N, N, A, LDA, 0, 0 )
IC = 0
S1 = DSECND( )
840 CONTINUE
CALL DSYR( UPLO, N, ALPHA, X, INCX, A, LDA )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( IMAT, N, N, A, LDA, 0, 0 )
GO TO 840
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
850 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( IMAT, N, N, A, LDA, 0, 0 )
GO TO 850
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPBL2( CNAME, N, N, 0, 0 )
RESLTS( 1, IN, I3 ) = DMFLOP( OPS, TIME, 0 )
860 CONTINUE
870 CONTINUE
880 CONTINUE
WRITE( NOUT, FMT = 9986 )CNAME, UPLO
CALL DPRTBL( ' ', 'N', 1, NVAL, NN, NVAL, NINC*NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
890 CONTINUE
*
ELSE IF( CNAME.EQ.'DSYR2 ' ) THEN
*
* Time DSYR2
*
DO 950 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IMAT = 6
IF( UPLO.EQ.'L' )
$ IMAT = -6
I3 = 0
DO 940 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 930 IINC = 1, NINC
INCX = INCVAL( IINC )
I3 = I3 + 1
DO 920 IN = 1, NN
N = NVAL( IN )
CALL DTIMMG( 0, 1, N, X, INCX, 0, 0 )
CALL DTIMMG( 0, 1, N, Y, INCX, 0, 0 )
CALL DTIMMG( IMAT, N, N, A, LDA, 0, 0 )
IC = 0
S1 = DSECND( )
900 CONTINUE
CALL DSYR2( UPLO, N, ALPHA, X, INCX, Y, INCX, A,
$ LDA )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( IMAT, N, N, A, LDA, 0, 0 )
GO TO 900
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
910 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( IMAT, N, N, A, LDA, 0, 0 )
GO TO 910
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPBL2( CNAME, N, N, 0, 0 )
RESLTS( 1, IN, I3 ) = DMFLOP( OPS, TIME, 0 )
920 CONTINUE
930 CONTINUE
940 CONTINUE
WRITE( NOUT, FMT = 9986 )CNAME, UPLO
CALL DPRTBL( ' ', 'N', 1, NVAL, NN, NVAL, NINC*NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
950 CONTINUE
*
ELSE IF( CNAME.EQ.'DSPR ' ) THEN
*
* Time DSPR
*
DO 1000 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IMAT = 7
IF( UPLO.EQ.'L' )
$ IMAT = -7
ILDA = 1
LDA = LDAVAL( ILDA )
DO 990 IINC = 1, NINC
INCX = INCVAL( IINC )
DO 980 IN = 1, NN
N = NVAL( IN )
CALL DTIMMG( 0, 1, N, X, INCX, 0, 0 )
CALL DTIMMG( 0, 1, N, Y, INCX, 0, 0 )
CALL DTIMMG( IMAT, N, N, A, N*( N+1 ) / 2, 0, 0 )
IC = 0
S1 = DSECND( )
960 CONTINUE
CALL DSPR( UPLO, N, ALPHA, X, INCX, A )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( IMAT, N, N, A, N*( N+1 ) / 2, 0,
$ 0 )
GO TO 960
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
970 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( IMAT, N, N, A, N*( N+1 ) / 2, 0,
$ 0 )
GO TO 970
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPBL2( CNAME, N, N, 0, 0 )
RESLTS( 1, IN, IINC ) = DMFLOP( OPS, TIME, 0 )
980 CONTINUE
990 CONTINUE
WRITE( NOUT, FMT = 9986 )CNAME, UPLO
CALL DPRTBL( ' ', 'N', 1, NVAL, NN, NVAL, NINC, RESLTS,
$ LDR1, LDR2, NOUT )
1000 CONTINUE
*
ELSE IF( CNAME.EQ.'DSPR2 ' ) THEN
*
* Time DSPR2
*
DO 1050 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IMAT = 7
IF( UPLO.EQ.'L' )
$ IMAT = -7
ILDA = 1
LDA = LDAVAL( ILDA )
DO 1040 IINC = 1, NINC
INCX = INCVAL( IINC )
DO 1030 IN = 1, NN
N = NVAL( IN )
CALL DTIMMG( 0, 1, N, X, INCX, 0, 0 )
CALL DTIMMG( 0, 1, N, Y, INCX, 0, 0 )
CALL DTIMMG( IMAT, N, N, A, N*( N+1 ) / 2, 0, 0 )
IC = 0
S1 = DSECND( )
1010 CONTINUE
CALL DSPR2( UPLO, N, ALPHA, X, INCX, Y, INCX, A )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( IMAT, N, N, A, N*( N+1 ) / 2, 0,
$ 0 )
GO TO 1010
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
1020 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( IMAT, N, N, A, N*( N+1 ) / 2, 0,
$ 0 )
GO TO 1020
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPBL2( CNAME, N, N, 0, 0 )
RESLTS( 1, IN, IINC ) = DMFLOP( OPS, TIME, 0 )
1030 CONTINUE
1040 CONTINUE
WRITE( NOUT, FMT = 9986 )CNAME, UPLO
CALL DPRTBL( ' ', 'N', 1, NVAL, NN, NVAL, NINC, RESLTS,
$ LDR1, LDR2, NOUT )
1050 CONTINUE
END IF
WRITE( NOUT, FMT = 9984 )
1060 CONTINUE
1070 CONTINUE
*
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'with LDA = ', I5, ' and INCX = INCY = ', I5 )
9996 FORMAT( 5X, 'with LDA = ', I5, ' and INCX = ', I5 )
9995 FORMAT( 5X, 'with INCX = INCY = ', I5 )
9994 FORMAT( 5X, 'with INCX = ', I5 )
9993 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5,
$ ' and INCX = INCY = ', I5 )
9992 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5, ' and INCX = ', I5 )
9991 FORMAT( 5X, 'line ', I2, ' with INCX = INCY = ', I5 )
9990 FORMAT( 5X, 'line ', I2, ' with INCX = ', I5 )
9989 FORMAT( / 1X, 'DGEMV with TRANS = ''', A1, '''', / )
9988 FORMAT( / 1X, 'DGBMV with TRANS = ''', A1,
$ ''', M = N and KL = K', 'U ', '= K', / )
9987 FORMAT( / 1X, A6, ' with UPLO = ''', A1, ''', TRANS = ''', A1,
$ '''', / )
9986 FORMAT( / 1X, A6, ' with UPLO = ''', A1, '''', / )
9985 FORMAT( / 1X, 'DGER', / )
9984 FORMAT( / / / / / )
RETURN
*
* End of DTIMB2
*
END
SUBROUTINE DTIMB3( LINE, NM, MVAL, NN, NVAL, NK, KVAL, NLDA,
$ LDAVAL, TIMMIN, A, B, C, RESLTS, LDR1, LDR2,
$ NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*( * ) LINE
INTEGER LDR1, LDR2, NK, NLDA, NM, NN, NOUT
DOUBLE PRECISION TIMMIN
* ..
* .. Array Arguments ..
INTEGER KVAL( * ), LDAVAL( * ), MVAL( * ), NVAL( * )
DOUBLE PRECISION A( * ), B( * ), C( * ), RESLTS( LDR1, LDR2, * )
* ..
*
* Purpose
* =======
*
* DTIMB3 times the Level 3 BLAS routines.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NK (input) INTEGER
* The number of values of K contained in the vector KVAL.
*
* KVAL (input) INTEGER array, dimension (NK)
* The values of K. K is used as the intermediate matrix
* dimension for DGEMM (the product of an M x K matrix and a
* K x N matrix) and as the dimension of the rank-K update in
* DSYRK and SSYR2K.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) DOUBLE PRECISION
* The minimum time a subroutine will be timed.
*
* A (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values permitted
* for LDA and N.
*
* B (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
*
* C (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
*
* RESLTS (output) DOUBLE PRECISION array, dimension (LDR1,LDR2,NLDA)
* The timing results for each subroutine over the relevant
* values of M, N, K, and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NM,NK).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NN).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 6 )
INTEGER NTRANS, NSIDES, NUPLOS
PARAMETER ( NTRANS = 2, NSIDES = 2, NUPLOS = 2 )
DOUBLE PRECISION ALPHA, BETA
PARAMETER ( ALPHA = 1.0D0, BETA = 1.0D0 )
* ..
* .. Local Scalars ..
CHARACTER SIDE, TRANSA, TRANSB, UPLO
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, IC, ICL, IK, ILDA, IM, IMAT, IN, INFO,
$ ISIDE, ISUB, ITA, ITB, IUPLO, K, LDA, M, N
DOUBLE PRECISION OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER SIDES( NSIDES ), TRANS( NTRANS ),
$ UPLOS( NUPLOS )
CHARACTER*6 NAMES( NSUBS )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DMFLOP, DOPBL3, DSECND
EXTERNAL LSAME, DMFLOP, DOPBL3, DSECND
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, DGEMM, DPRTBL, DSYMM, DSYR2K,
$ DSYRK, DTIMMG, DTRMM, DTRSM
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Data statements ..
DATA NAMES / 'DGEMM ', 'DSYMM ', 'DSYRK ', 'DSYR2K',
$ 'DTRMM ', 'DTRSM ' /
DATA TRANS / 'N', 'T' /
DATA SIDES / 'L', 'R' /
DATA UPLOS / 'U', 'L' /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'B3'
CALL ATIMIN( PATH, LINE, NSUBS, NAMES, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 480
*
* Check that M <= LDA.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 480
END IF
*
* Time each routine.
*
DO 470 ISUB = 1, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 470
*
* Print header.
*
CNAME = NAMES( ISUB )
WRITE( NOUT, FMT = 9998 )CNAME
IF( NLDA.EQ.1 ) THEN
WRITE( NOUT, FMT = 9997 )LDAVAL( 1 )
ELSE
DO 10 I = 1, NLDA
WRITE( NOUT, FMT = 9996 )I, LDAVAL( I )
10 CONTINUE
END IF
*
* Time DGEMM
*
IF( CNAME.EQ.'DGEMM ' ) THEN
DO 90 ITA = 1, NTRANS
TRANSA = TRANS( ITA )
DO 80 ITB = 1, NTRANS
TRANSB = TRANS( ITB )
DO 70 IK = 1, NK
K = KVAL( IK )
DO 60 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 50 IM = 1, NM
M = MVAL( IM )
DO 40 IN = 1, NN
N = NVAL( IN )
IF( TRANSA.EQ.'N' ) THEN
CALL DTIMMG( 1, M, K, A, LDA, 0, 0 )
ELSE
CALL DTIMMG( 1, K, M, A, LDA, 0, 0 )
END IF
IF( TRANSB.EQ.'N' ) THEN
CALL DTIMMG( 0, K, N, B, LDA, 0, 0 )
ELSE
CALL DTIMMG( 0, N, K, B, LDA, 0, 0 )
END IF
CALL DTIMMG( 1, M, N, C, LDA, 0, 0 )
IC = 0
S1 = DSECND( )
20 CONTINUE
CALL DGEMM( TRANSA, TRANSB, M, N, K,
$ ALPHA, A, LDA, B, LDA, BETA,
$ C, LDA )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 1, M, N, C, LDA, 0, 0 )
GO TO 20
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
30 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 1, M, N, C, LDA, 0, 0 )
GO TO 30
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPBL3( CNAME, M, N, K )
RESLTS( IM, IN, ILDA ) = DMFLOP( OPS,
$ TIME, 0 )
40 CONTINUE
50 CONTINUE
60 CONTINUE
IF( IK.EQ.1 )
$ WRITE( NOUT, FMT = 9995 )TRANSA, TRANSB
WRITE( NOUT, FMT = 9994 )KVAL( IK )
CALL DPRTBL( 'M', 'N', NM, MVAL, NN, NVAL, NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
70 CONTINUE
80 CONTINUE
90 CONTINUE
*
ELSE IF( CNAME.EQ.'DSYMM ' ) THEN
*
* Time DSYMM
*
DO 160 ISIDE = 1, NSIDES
SIDE = SIDES( ISIDE )
DO 150 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IF( LSAME( UPLO, 'U' ) ) THEN
IMAT = 6
ELSE
IMAT = -6
END IF
DO 140 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 130 IM = 1, NM
M = MVAL( IM )
DO 120 IN = 1, NN
N = NVAL( IN )
IF( ISIDE.EQ.1 ) THEN
CALL DTIMMG( IMAT, M, M, A, LDA, 0, 0 )
CALL DTIMMG( 0, M, N, B, LDA, 0, 0 )
ELSE
CALL DTIMMG( 0, M, N, B, LDA, 0, 0 )
CALL DTIMMG( IMAT, N, N, A, LDA, 0, 0 )
END IF
CALL DTIMMG( 1, M, N, C, LDA, 0, 0 )
IC = 0
S1 = DSECND( )
100 CONTINUE
CALL DSYMM( SIDE, UPLO, M, N, ALPHA, A, LDA,
$ B, LDA, BETA, C, LDA )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 1, M, N, C, LDA, 0, 0 )
GO TO 100
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
110 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 1, M, N, C, LDA, 0, 0 )
GO TO 110
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPBL3( CNAME, M, N, ISIDE-1 )
RESLTS( IM, IN, ILDA ) = DMFLOP( OPS, TIME,
$ 0 )
120 CONTINUE
130 CONTINUE
140 CONTINUE
WRITE( NOUT, FMT = 9993 )SIDE, UPLO
CALL DPRTBL( 'M', 'N', NM, MVAL, NN, NVAL, NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
150 CONTINUE
160 CONTINUE
*
ELSE IF( CNAME.EQ.'DSYRK ' ) THEN
*
* Time DSYRK
*
DO 230 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IF( LSAME( UPLO, 'U' ) ) THEN
IMAT = 6
ELSE
IMAT = -6
END IF
DO 220 ITA = 1, NTRANS
TRANSA = TRANS( ITA )
DO 210 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 200 IK = 1, NK
K = KVAL( IK )
IF( TRANSA.EQ.'N' ) THEN
CALL DTIMMG( 1, N, K, A, LDA, 0, 0 )
ELSE
CALL DTIMMG( 1, K, N, A, LDA, 0, 0 )
END IF
DO 190 IN = 1, NN
N = NVAL( IN )
CALL DTIMMG( IMAT, N, N, C, LDA, 0, 0 )
IC = 0
S1 = DSECND( )
170 CONTINUE
CALL DSYRK( UPLO, TRANSA, N, K, ALPHA, A,
$ LDA, BETA, C, LDA )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( IMAT, N, N, C, LDA, 0, 0 )
GO TO 170
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
180 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( IMAT, N, N, C, LDA, 0, 0 )
GO TO 180
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPBL3( CNAME, N, N, K )
RESLTS( IK, IN, ILDA ) = DMFLOP( OPS, TIME,
$ 0 )
190 CONTINUE
200 CONTINUE
210 CONTINUE
WRITE( NOUT, FMT = 9992 )CNAME, UPLO, TRANSA
CALL DPRTBL( 'K', 'N', NK, KVAL, NN, NVAL, NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
220 CONTINUE
230 CONTINUE
*
ELSE IF( CNAME.EQ.'DSYR2K' ) THEN
*
* Time DSYR2K
*
DO 300 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IF( LSAME( UPLO, 'U' ) ) THEN
IMAT = 6
ELSE
IMAT = -6
END IF
DO 290 ITB = 1, NTRANS
TRANSB = TRANS( ITB )
DO 280 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 270 IK = 1, NK
K = KVAL( IK )
IF( TRANSB.EQ.'N' ) THEN
CALL DTIMMG( 1, N, K, A, LDA, 0, 0 )
CALL DTIMMG( 0, N, K, B, LDA, 0, 0 )
ELSE
CALL DTIMMG( 1, K, N, A, LDA, 0, 0 )
CALL DTIMMG( 0, K, N, B, LDA, 0, 0 )
END IF
DO 260 IN = 1, NN
N = NVAL( IN )
CALL DTIMMG( IMAT, N, N, C, LDA, 0, 0 )
IC = 0
S1 = DSECND( )
240 CONTINUE
CALL DSYR2K( UPLO, TRANSB, N, K, ALPHA, A,
$ LDA, B, LDA, BETA, C, LDA )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( IMAT, N, N, C, LDA, 0, 0 )
GO TO 240
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
250 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( IMAT, N, N, C, LDA, 0, 0 )
GO TO 250
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPBL3( CNAME, N, N, K )
RESLTS( IK, IN, ILDA ) = DMFLOP( OPS, TIME,
$ 0 )
260 CONTINUE
270 CONTINUE
280 CONTINUE
WRITE( NOUT, FMT = 9992 )CNAME, UPLO, TRANSB
CALL DPRTBL( 'K', 'N', NK, KVAL, NN, NVAL, NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
290 CONTINUE
300 CONTINUE
*
ELSE IF( CNAME.EQ.'DTRMM ' ) THEN
*
* Time DTRMM
*
DO 380 ISIDE = 1, NSIDES
SIDE = SIDES( ISIDE )
DO 370 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IF( LSAME( UPLO, 'U' ) ) THEN
IMAT = 9
ELSE
IMAT = -9
END IF
DO 360 ITA = 1, NTRANS
TRANSA = TRANS( ITA )
DO 350 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 340 IM = 1, NM
M = MVAL( IM )
DO 330 IN = 1, NN
N = NVAL( IN )
IF( ISIDE.EQ.1 ) THEN
CALL DTIMMG( IMAT, M, M, A, LDA, 0, 0 )
ELSE
CALL DTIMMG( IMAT, N, N, A, LDA, 0, 0 )
END IF
CALL DTIMMG( 0, M, N, B, LDA, 0, 0 )
IC = 0
S1 = DSECND( )
310 CONTINUE
CALL DTRMM( SIDE, UPLO, TRANSA,
$ 'Non-unit', M, N, ALPHA, A,
$ LDA, B, LDA )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, M, N, B, LDA, 0, 0 )
GO TO 310
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
320 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, M, N, B, LDA, 0, 0 )
GO TO 320
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPBL3( CNAME, M, N, ISIDE-1 )
RESLTS( IM, IN, ILDA ) = DMFLOP( OPS,
$ TIME, 0 )
330 CONTINUE
340 CONTINUE
350 CONTINUE
WRITE( NOUT, FMT = 9991 )CNAME, SIDE, UPLO, TRANSA
CALL DPRTBL( 'M', 'N', NM, MVAL, NN, NVAL, NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
360 CONTINUE
370 CONTINUE
380 CONTINUE
*
ELSE IF( CNAME.EQ.'DTRSM ' ) THEN
*
* Time DTRSM
*
DO 460 ISIDE = 1, NSIDES
SIDE = SIDES( ISIDE )
DO 450 IUPLO = 1, NUPLOS
UPLO = UPLOS( IUPLO )
IF( LSAME( UPLO, 'U' ) ) THEN
IMAT = 9
ELSE
IMAT = -9
END IF
DO 440 ITA = 1, NTRANS
TRANSA = TRANS( ITA )
DO 430 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 420 IM = 1, NM
M = MVAL( IM )
DO 410 IN = 1, NN
N = NVAL( IN )
IF( ISIDE.EQ.1 ) THEN
CALL DTIMMG( IMAT, M, M, A, LDA, 0, 0 )
ELSE
CALL DTIMMG( IMAT, N, N, A, LDA, 0, 0 )
END IF
CALL DTIMMG( 0, M, N, B, LDA, 0, 0 )
IC = 0
S1 = DSECND( )
390 CONTINUE
CALL DTRSM( SIDE, UPLO, TRANSA,
$ 'Non-unit', M, N, ALPHA, A,
$ LDA, B, LDA )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, M, N, B, LDA, 0, 0 )
GO TO 390
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
400 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, M, N, B, LDA, 0, 0 )
GO TO 400
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPBL3( CNAME, M, N, ISIDE-1 )
RESLTS( IM, IN, ILDA ) = DMFLOP( OPS,
$ TIME, 0 )
410 CONTINUE
420 CONTINUE
430 CONTINUE
WRITE( NOUT, FMT = 9991 )CNAME, SIDE, UPLO, TRANSA
CALL DPRTBL( 'M', 'N', NM, MVAL, NN, NVAL, NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
440 CONTINUE
450 CONTINUE
460 CONTINUE
END IF
WRITE( NOUT, FMT = 9990 )
470 CONTINUE
480 CONTINUE
*
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'with LDA = ', I5 )
9996 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
9995 FORMAT( / 1X, 'DGEMM with TRANSA = ''', A1, ''', TRANSB = ''',
$ A1, '''' )
9994 FORMAT( / 1X, 'K = ', I4, / )
9993 FORMAT( / 1X, 'DSYMM with SIDE = ''', A1, ''', UPLO = ''', A1,
$ '''', / )
9992 FORMAT( / 1X, A6, ' with UPLO = ''', A1, ''', TRANS = ''', A1,
$ '''', / )
9991 FORMAT( / 1X, A6, ' with SIDE = ''', A1, ''', UPLO = ''', A1,
$ ''',', ' TRANS = ''', A1, '''', / )
9990 FORMAT( / / / / / )
RETURN
*
* End of DTIMB3
*
END
SUBROUTINE DTIMBR( LINE, NM, MVAL, NVAL, NK, KVAL, NNB, NBVAL,
$ NXVAL, NLDA, LDAVAL, TIMMIN, A, B, D, TAU,
$ WORK, RESLTS, LDR1, LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NK, NLDA, NM, NNB, NOUT
DOUBLE PRECISION TIMMIN
* ..
* .. Array Arguments ..
INTEGER KVAL( * ), LDAVAL( * ), MVAL( * ), NBVAL( * ),
$ NVAL( * ), NXVAL( * )
DOUBLE PRECISION A( * ), B( * ), D( * ),
$ RESLTS( LDR1, LDR2, LDR3, * ), TAU( * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* DTIMBR times DGEBRD, DORGBR, and DORMBR.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M and N contained in the vectors
* MVAL and NVAL. The matrix sizes are used in pairs (M,N).
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NVAL (input) INTEGER array, dimension (NM)
* The values of the matrix column dimension N.
*
* NK (input) INTEGER
* The number of values of K contained in the vector KVAL.
*
* KVAL (input) INTEGER array, dimension (NK)
* The values of the matrix dimension K.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) DOUBLE PRECISION
* The minimum time a subroutine will be timed.
*
* A (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values of LDA and N.
*
* B (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
*
* D (workspace) DOUBLE PRECISION array, dimension
* (2*max(min(M,N))-1)
*
* TAU (workspace) DOUBLE PRECISION array, dimension
* (2*max(min(M,N)))
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NBMAX)
* where NBMAX is the maximum value of NB.
*
* RESLTS (output) DOUBLE PRECISION array, dimension (LDR1,LDR2,LDR3,6)
* The timing results for each subroutine over the relevant
* values of (M,N), (NB,NX), and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NM).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* Internal Parameters
* ===================
*
* MODE INTEGER
* The matrix type. MODE = 3 is a geometric distribution of
* eigenvalues. See ZLATMS for further details.
*
* COND DOUBLE PRECISION
* The condition number of the matrix. The singular values are
* set to values from DMAX to DMAX/COND.
*
* DMAX DOUBLE PRECISION
* The magnitude of the largest singular value.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 3 )
INTEGER MODE
DOUBLE PRECISION COND, DMAX
PARAMETER ( MODE = 3, COND = 100.0D0, DMAX = 1.0D0 )
* ..
* .. Local Scalars ..
CHARACTER LABK, LABM, LABN, SIDE, TRANS, VECT
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, I3, I4, IC, ICL, IK, ILDA, IM, INB, INFO,
$ INFO2, ISIDE, ISUB, ITOFF, ITRAN, IVECT, K, K1,
$ LDA, LW, M, M1, MINMN, N, N1, NB, NQ, NX
DOUBLE PRECISION OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER SIDES( 2 ), TRANSS( 2 ), VECTS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER ISEED( 4 ), RESEED( 4 )
* ..
* .. External Functions ..
DOUBLE PRECISION DMFLOP, DOPLA, DSECND
EXTERNAL DMFLOP, DOPLA, DSECND
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, DGEBRD, DLACPY, DLATMS, DORGBR,
$ DORMBR, DPRTB4, DPRTB5, DTIMMG, ICOPY, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Data statements ..
DATA SUBNAM / 'DGEBRD', 'DORGBR', 'DORMBR' / ,
$ SIDES / 'L', 'R' / , VECTS / 'Q', 'P' / ,
$ TRANSS / 'N', 'T' /
DATA ISEED / 0, 0, 0, 1 /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'BR'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 220
*
* Check that M <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 220
END IF
*
* Check that N <= LDA and K <= LDA for DORMBR
*
IF( TIMSUB( 3 ) ) THEN
CALL ATIMCK( 2, CNAME, NM, NVAL, NLDA, LDAVAL, NOUT, INFO )
CALL ATIMCK( 3, CNAME, NK, KVAL, NLDA, LDAVAL, NOUT, INFO2 )
IF( INFO.GT.0 .OR. INFO2.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )SUBNAM( 3 )
TIMSUB( 3 ) = .FALSE.
END IF
END IF
*
* Do for each pair of values (M,N):
*
DO 140 IM = 1, NM
M = MVAL( IM )
N = NVAL( IM )
MINMN = MIN( M, N )
CALL ICOPY( 4, ISEED, 1, RESEED, 1 )
*
* Do for each value of LDA:
*
DO 130 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
*
* Do for each pair of values (NB, NX) in NBVAL and NXVAL.
*
DO 120 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
LW = MAX( M+N, MAX( 1, NB )*( M+N ) )
*
* Generate a test matrix of size M by N.
*
CALL ICOPY( 4, RESEED, 1, ISEED, 1 )
CALL DLATMS( M, N, 'Uniform', ISEED, 'Nonsym', TAU, MODE,
$ COND, DMAX, M, N, 'No packing', B, LDA,
$ WORK, INFO )
*
IF( TIMSUB( 1 ) ) THEN
*
* DGEBRD: Block reduction to bidiagonal form
*
CALL DLACPY( 'Full', M, N, B, LDA, A, LDA )
IC = 0
S1 = DSECND( )
10 CONTINUE
CALL DGEBRD( M, N, A, LDA, D, D( MINMN ), TAU,
$ TAU( MINMN+1 ), WORK, LW, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DLACPY( 'Full', M, N, B, LDA, A, LDA )
GO TO 10
END IF
*
* Subtract the time used in DLACPY.
*
ICL = 1
S1 = DSECND( )
20 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DLACPY( 'Full', M, N, A, LDA, B, LDA )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DGEBRD', M, N, 0, 0, NB )
RESLTS( INB, IM, ILDA, 1 ) = DMFLOP( OPS, TIME, INFO )
ELSE
*
* If DGEBRD was not timed, generate a matrix and reduce
* it using DGEBRD anyway so that the orthogonal
* transformations may be used in timing the other
* routines.
*
CALL DLACPY( 'Full', M, N, B, LDA, A, LDA )
CALL DGEBRD( M, N, A, LDA, D, D( MINMN ), TAU,
$ TAU( MINMN+1 ), WORK, LW, INFO )
*
END IF
*
IF( TIMSUB( 2 ) ) THEN
*
* DORGBR: Generate one of the orthogonal matrices Q or
* P' from the reduction to bidiagonal form
* A = Q * B * P'.
*
DO 50 IVECT = 1, 2
IF( IVECT.EQ.1 ) THEN
VECT = 'Q'
M1 = M
N1 = MIN( M, N )
K1 = N
ELSE
VECT = 'P'
M1 = MIN( M, N )
N1 = N
K1 = M
END IF
I3 = ( IVECT-1 )*NLDA
LW = MAX( 1, MAX( 1, NB )*MIN( M, N ) )
CALL DLACPY( 'Full', M, N, A, LDA, B, LDA )
IC = 0
S1 = DSECND( )
30 CONTINUE
CALL DORGBR( VECT, M1, N1, K1, B, LDA, TAU, WORK,
$ LW, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DLACPY( 'Full', M, N, A, LDA, B, LDA )
GO TO 30
END IF
*
* Subtract the time used in DLACPY.
*
ICL = 1
S1 = DSECND( )
40 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DLACPY( 'Full', M, N, A, LDA, B, LDA )
GO TO 40
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
*
* Op count for DORGBR:
*
IF( IVECT.EQ.1 ) THEN
IF( M1.GE.K1 ) THEN
OPS = DOPLA( 'DORGQR', M1, N1, K1, -1, NB )
ELSE
OPS = DOPLA( 'DORGQR', M1-1, M1-1, M1-1, -1,
$ NB )
END IF
ELSE
IF( K1.LT.N1 ) THEN
OPS = DOPLA( 'DORGLQ', M1, N1, K1, -1, NB )
ELSE
OPS = DOPLA( 'DORGLQ', N1-1, N1-1, N1-1, -1,
$ NB )
END IF
END IF
*
RESLTS( INB, IM, I3+ILDA, 2 ) = DMFLOP( OPS, TIME,
$ INFO )
50 CONTINUE
END IF
*
IF( TIMSUB( 3 ) ) THEN
*
* DORMBR: Multiply an m by n matrix B by one of the
* orthogonal matrices Q or P' from the reduction to
* bidiagonal form A = Q * B * P'.
*
DO 110 IVECT = 1, 2
IF( IVECT.EQ.1 ) THEN
VECT = 'Q'
K1 = N
NQ = M
ELSE
VECT = 'P'
K1 = M
NQ = N
END IF
I3 = ( IVECT-1 )*NLDA
I4 = 2
DO 100 ISIDE = 1, 2
SIDE = SIDES( ISIDE )
DO 90 IK = 1, NK
K = KVAL( IK )
IF( ISIDE.EQ.1 ) THEN
M1 = NQ
N1 = K
LW = MAX( 1, MAX( 1, NB )*N1 )
ELSE
M1 = K
N1 = NQ
LW = MAX( 1, MAX( 1, NB )*M1 )
END IF
ITOFF = 0
DO 80 ITRAN = 1, 2
TRANS = TRANSS( ITRAN )
CALL DTIMMG( 0, M1, N1, B, LDA, 0, 0 )
IC = 0
S1 = DSECND( )
60 CONTINUE
CALL DORMBR( VECT, SIDE, TRANS, M1, N1,
$ K1, A, LDA, TAU, B, LDA,
$ WORK, LW, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, M1, N1, B, LDA, 0, 0 )
GO TO 60
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
70 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, M1, N1, B, LDA, 0, 0 )
GO TO 70
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
IF( IVECT.EQ.1 ) THEN
*
* Op count for DORMBR, VECT = 'Q':
*
IF( NQ.GE.K1 ) THEN
OPS = DOPLA( 'DORMQR', M1, N1, K1,
$ ISIDE-1, NB )
ELSE IF( ISIDE.EQ.1 ) THEN
OPS = DOPLA( 'DORMQR', M1-1, N1,
$ NQ-1, ISIDE-1, NB )
ELSE
OPS = DOPLA( 'DORMQR', M1, N1-1,
$ NQ-1, ISIDE-1, NB )
END IF
ELSE
*
* Op count for DORMBR, VECT = 'P':
*
IF( NQ.GT.K1 ) THEN
OPS = DOPLA( 'DORMLQ', M1, N1, K1,
$ ISIDE-1, NB )
ELSE IF( ISIDE.EQ.1 ) THEN
OPS = DOPLA( 'DORMLQ', M1-1, N1,
$ NQ-1, ISIDE-1, NB )
ELSE
OPS = DOPLA( 'DORMLQ', M1, N1-1,
$ NQ-1, ISIDE-1, NB )
END IF
END IF
*
RESLTS( INB, IM, I3+ILDA,
$ I4+ITOFF+IK ) = DMFLOP( OPS, TIME,
$ INFO )
ITOFF = NK
80 CONTINUE
90 CONTINUE
I4 = 2*NK + 2
100 CONTINUE
110 CONTINUE
END IF
120 CONTINUE
130 CONTINUE
140 CONTINUE
*
* Print a table of results for each timed routine.
*
DO 210 ISUB = 1, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 210
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 150 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
150 CONTINUE
END IF
IF( ISUB.EQ.1 ) THEN
WRITE( NOUT, FMT = * )
CALL DPRTB4( '( NB, NX)', 'M', 'N', NNB, NBVAL, NXVAL, NM,
$ MVAL, NVAL, NLDA, RESLTS( 1, 1, 1, ISUB ),
$ LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.2 ) THEN
DO 160 IVECT = 1, 2
I3 = ( IVECT-1 )*NLDA + 1
IF( IVECT.EQ.1 ) THEN
LABK = 'N'
LABM = 'M'
LABN = 'K'
ELSE
LABK = 'M'
LABM = 'K'
LABN = 'N'
END IF
WRITE( NOUT, FMT = 9996 )SUBNAM( ISUB ), VECTS( IVECT ),
$ LABK, LABM, LABN
CALL DPRTB4( '( NB, NX)', LABM, LABN, NNB, NBVAL,
$ NXVAL, NM, MVAL, NVAL, NLDA,
$ RESLTS( 1, 1, I3, ISUB ), LDR1, LDR2, NOUT )
160 CONTINUE
ELSE IF( ISUB.EQ.3 ) THEN
DO 200 IVECT = 1, 2
I3 = ( IVECT-1 )*NLDA + 1
I4 = 3
DO 190 ISIDE = 1, 2
IF( ISIDE.EQ.1 ) THEN
IF( IVECT.EQ.1 ) THEN
LABM = 'M'
LABN = 'K'
ELSE
LABM = 'K'
LABN = 'M'
END IF
LABK = 'N'
ELSE
IF( IVECT.EQ.1 ) THEN
LABM = 'N'
LABN = 'K'
ELSE
LABM = 'K'
LABN = 'N'
END IF
LABK = 'M'
END IF
DO 180 ITRAN = 1, 2
DO 170 IK = 1, NK
WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ),
$ VECTS( IVECT ), SIDES( ISIDE ),
$ TRANSS( ITRAN ), LABK, KVAL( IK )
CALL DPRTB5( 'NB', LABM, LABN, NNB, NBVAL, NM,
$ MVAL, NVAL, NLDA,
$ RESLTS( 1, 1, I3, I4 ), LDR1, LDR2,
$ NOUT )
I4 = I4 + 1
170 CONTINUE
180 CONTINUE
190 CONTINUE
200 CONTINUE
END IF
210 CONTINUE
220 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
9996 FORMAT( / 5X, A6, ' with VECT = ''', A1, ''', ', A1, ' = MIN(',
$ A1, ',', A1, ')', / )
9995 FORMAT( / 5X, A6, ' with VECT = ''', A1, ''', SIDE = ''', A1,
$ ''', TRANS = ''', A1, ''', ', A1, ' =', I6, / )
RETURN
*
* End of DTIMBR
*
END
SUBROUTINE DTIMGB( LINE, NM, MVAL, NK, KVAL, NNS, NSVAL, NNB,
$ NBVAL, NLDA, LDAVAL, TIMMIN, A, B, IWORK,
$ RESLTS, LDR1, LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NK, NLDA, NM, NNB, NNS, NOUT
DOUBLE PRECISION TIMMIN
* ..
* .. Array Arguments ..
INTEGER IWORK( * ), KVAL( * ), LDAVAL( * ), MVAL( * ),
$ NBVAL( * ), NSVAL( * )
DOUBLE PRECISION A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * )
* ..
*
* Purpose
* =======
*
* DTIMGB times DGBTRF and -TRS.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix size M.
*
* NK (input) INTEGER
* The number of values of K contained in the vector KVAL.
*
* KVAL (input) INTEGER array, dimension (NK)
* The values of the band width K.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* NNB (input) INTEGER
* The number of values of NB contained in the vector NBVAL.
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) DOUBLE PRECISION
* The minimum time a subroutine will be timed.
*
* A (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values permitted
* for LDA and N.
*
* B (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* RESLTS (output) DOUBLE PRECISION array, dimension
* (LDR1,LDR2,LDR3,NSUBS)
* The timing results for each subroutine over the relevant
* values of N, K, NB, and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(4,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NK).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 2 )
* ..
* .. Local Scalars ..
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, IC, ICL, IK, ILDA, IM, INB, INFO, ISUB, K,
$ KL, KU, LDA, LDB, M, N, NB, NRHS
DOUBLE PRECISION OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER*6 SUBNAM( NSUBS )
* ..
* .. External Functions ..
DOUBLE PRECISION DMFLOP, DOPLA, DSECND, DOPGB
EXTERNAL DMFLOP, DOPLA, DSECND, DOPGB
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, DGBTRF, DGBTRS, DPRTBL, DTIMMG,
$ XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Data statements ..
DATA SUBNAM / 'DGBTRF', 'DGBTRS' /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'GB'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 120
*
* Check that 3*K+1 <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 0, CNAME, NK, KVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 120
END IF
*
* Do for each value of the matrix size M:
*
DO 110 IM = 1, NM
M = MVAL( IM )
N = M
*
* Do for each value of LDA:
*
DO 80 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
*
* Do for each value of the band width K:
*
DO 70 IK = 1, NK
K = KVAL( IK )
KL = MAX( 0, MIN( K, M-1 ) )
KU = MAX( 0, MIN( K, N-1 ) )
*
* Time DGBTRF
*
IF( TIMSUB( 1 ) ) THEN
*
* Do for each value of NB in NBVAL. Only DGBTRF is
* timed in this loop since the other routines are
* independent of NB.
*
DO 30 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
IC = 0
CALL DTIMMG( 2, M, N, A, LDA, KL, KU )
S1 = DSECND( )
10 CONTINUE
CALL DGBTRF( M, N, KL, KU, A, LDA, IWORK, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 2, M, N, A, LDA, KL, KU )
GO TO 10
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
20 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 2, M, N, A, LDA, KL, KU )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPGB( 'DGBTRF', M, N, KL, KU, IWORK )
RESLTS( INB, IK, ILDA, 1 ) = DMFLOP( OPS, TIME,
$ INFO )
30 CONTINUE
ELSE
IC = 0
CALL DTIMMG( 2, M, N, A, LDA, KL, KU )
END IF
*
* Generate another matrix and factor it using DGBTRF so
* that the factored form can be used in timing the other
* routines.
*
NB = 1
CALL XLAENV( 1, NB )
IF( IC.NE.1 )
$ CALL DGBTRF( M, N, KL, KU, A, LDA, IWORK, INFO )
*
* Time DGBTRS
*
IF( TIMSUB( 2 ) ) THEN
DO 60 I = 1, NNS
NRHS = NSVAL( I )
LDB = N
IC = 0
CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 )
S1 = DSECND( )
40 CONTINUE
CALL DGBTRS( 'No transpose', N, KL, KU, NRHS, A,
$ LDA, IWORK, B, LDB, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 40
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
50 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 50
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DGBTRS', N, NRHS, KL, KU, 0 )
RESLTS( I, IK, ILDA, 2 ) = DMFLOP( OPS, TIME,
$ INFO )
60 CONTINUE
END IF
70 CONTINUE
80 CONTINUE
*
* Print a table of results for each routine
*
DO 100 ISUB = 1, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 100
*
* Print header for routine names.
*
IF( IM.EQ.1 .OR. CNAME.EQ.'DGB ' ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.EQ.1 ) THEN
WRITE( NOUT, FMT = 9997 )LDAVAL( 1 )
ELSE
DO 90 I = 1, NLDA
WRITE( NOUT, FMT = 9996 )I, LDAVAL( I )
90 CONTINUE
END IF
END IF
*
WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ), N
IF( ISUB.EQ.1 ) THEN
CALL DPRTBL( 'NB', 'K', NNB, NBVAL, NK, KVAL, NLDA,
$ RESLTS( 1, 1, 1, 1 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.2 ) THEN
CALL DPRTBL( 'NRHS', 'K', NNS, NSVAL, NK, KVAL, NLDA,
$ RESLTS( 1, 1, 1, 2 ), LDR1, LDR2, NOUT )
END IF
100 CONTINUE
110 CONTINUE
120 CONTINUE
*
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'with LDA = ', I5 )
9996 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
9995 FORMAT( / 5X, A6, ' with M =', I6, / )
*
RETURN
*
* End of DTIMGB
*
END
SUBROUTINE DTIMGE( LINE, NM, MVAL, NNS, NSVAL, NNB, NBVAL, NLDA,
$ LDAVAL, TIMMIN, A, B, WORK, IWORK, RESLTS,
$ LDR1, LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NLDA, NM, NNB, NNS, NOUT
DOUBLE PRECISION TIMMIN
* ..
* .. Array Arguments ..
INTEGER IWORK( * ), LDAVAL( * ), MVAL( * ), NBVAL( * ),
$ NSVAL( * )
DOUBLE PRECISION A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* DTIMGE times DGETRF, -TRS, and -TRI.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix size M.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* NNB (input) INTEGER
* The number of values of NB contained in the vector NBVAL.
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) DOUBLE PRECISION
* The minimum time a subroutine will be timed.
*
* A (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values permitted
* for LDA and N.
*
* B (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NBMAX)
* where NBMAX is the maximum value of the block size NB.
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* RESLTS (output) DOUBLE PRECISION array, dimension
* (LDR1,LDR2,LDR3,NSUBS)
* The timing results for each subroutine over the relevant
* values of N and NB.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(4,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NM).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 3 )
* ..
* .. Local Scalars ..
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, IC, ICL, ILDA, IM, INB, INFO, ISUB, LDA,
$ LDB, M, N, NB, NRHS
DOUBLE PRECISION OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER*6 SUBNAM( NSUBS )
* ..
* .. External Functions ..
DOUBLE PRECISION DMFLOP, DOPLA, DSECND
EXTERNAL DMFLOP, DOPLA, DSECND
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, DGETRF, DGETRI, DGETRS, DLACPY,
$ DPRTBL, DTIMMG, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Data statements ..
DATA SUBNAM / 'DGETRF', 'DGETRS', 'DGETRI' /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'GE'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 130
*
* Check that N <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 2, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 130
END IF
*
* Do for each value of M:
*
DO 100 IM = 1, NM
*
M = MVAL( IM )
N = M
*
* Do for each value of LDA:
*
DO 90 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
*
* Do for each value of NB in NBVAL. Only the blocked
* routines are timed in this loop since the other routines
* are independent of NB.
*
DO 50 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
*
* Time DGETRF
*
IF( TIMSUB( 1 ) ) THEN
CALL DTIMMG( 1, M, N, A, LDA, 0, 0 )
IC = 0
S1 = DSECND( )
10 CONTINUE
CALL DGETRF( M, N, A, LDA, IWORK, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 1, M, N, A, LDA, 0, 0 )
GO TO 10
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
20 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 1, M, N, A, LDA, 0, 0 )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DGETRF', M, N, 0, 0, NB )
RESLTS( INB, IM, ILDA, 1 ) = DMFLOP( OPS, TIME, INFO )
*
ELSE
IC = 0
CALL DTIMMG( 1, M, N, A, LDA, 0, 0 )
END IF
*
* Generate another matrix and factor it using DGETRF so
* that the factored form can be used in timing the other
* routines.
*
IF( IC.NE.1 )
$ CALL DGETRF( M, N, A, LDA, IWORK, INFO )
*
* Time DGETRI
*
IF( TIMSUB( 3 ) ) THEN
CALL DLACPY( 'Full', M, M, A, LDA, B, LDA )
IC = 0
S1 = DSECND( )
30 CONTINUE
CALL DGETRI( M, B, LDA, IWORK, WORK, LDA*NB, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DLACPY( 'Full', M, M, A, LDA, B, LDA )
GO TO 30
END IF
*
* Subtract the time used in DLACPY.
*
ICL = 1
S1 = DSECND( )
40 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DLACPY( 'Full', M, M, A, LDA, B, LDA )
GO TO 40
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DGETRI', M, M, 0, 0, NB )
RESLTS( INB, IM, ILDA, 3 ) = DMFLOP( OPS, TIME, INFO )
END IF
50 CONTINUE
*
* Time DGETRS
*
IF( TIMSUB( 2 ) ) THEN
DO 80 I = 1, NNS
NRHS = NSVAL( I )
LDB = LDA
CALL DTIMMG( 0, M, NRHS, B, LDB, 0, 0 )
IC = 0
S1 = DSECND( )
60 CONTINUE
CALL DGETRS( 'No transpose', M, NRHS, A, LDA, IWORK,
$ B, LDB, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, M, NRHS, B, LDB, 0, 0 )
GO TO 60
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
70 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, M, NRHS, B, LDB, 0, 0 )
GO TO 70
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DGETRS', M, NRHS, 0, 0, 0 )
RESLTS( I, IM, ILDA, 2 ) = DMFLOP( OPS, TIME, INFO )
80 CONTINUE
END IF
90 CONTINUE
100 CONTINUE
*
* Print a table of results for each timed routine.
*
DO 120 ISUB = 1, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 120
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 110 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
110 CONTINUE
END IF
WRITE( NOUT, FMT = * )
IF( ISUB.EQ.1 ) THEN
CALL DPRTBL( 'NB', 'N', NNB, NBVAL, NM, MVAL, NLDA, RESLTS,
$ LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.2 ) THEN
CALL DPRTBL( 'NRHS', 'N', NNS, NSVAL, NM, MVAL, NLDA,
$ RESLTS( 1, 1, 1, 2 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.3 ) THEN
CALL DPRTBL( 'NB', 'N', NNB, NBVAL, NM, MVAL, NLDA,
$ RESLTS( 1, 1, 1, 3 ), LDR1, LDR2, NOUT )
END IF
120 CONTINUE
*
130 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
RETURN
*
* End of DTIMGE
*
END
SUBROUTINE DTIMGT( LINE, NM, MVAL, NNS, NSVAL, NLDA, LDAVAL,
$ TIMMIN, A, B, IWORK, RESLTS, LDR1, LDR2, LDR3,
$ NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NLDA, NM, NNS, NOUT
DOUBLE PRECISION TIMMIN
* ..
* .. Array Arguments ..
INTEGER IWORK( * ), LDAVAL( * ), MVAL( * ), NSVAL( * )
DOUBLE PRECISION A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * )
* ..
*
* Purpose
* =======
*
* DTIMGT times DGTTRF, -TRS, -SV, and -SL.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix size M.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) DOUBLE PRECISION
* The minimum time a subroutine will be timed.
*
* A (workspace) DOUBLE PRECISION array, dimension (NMAX*4)
* where NMAX is the maximum value permitted for N.
*
* B (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* RESLTS (output) DOUBLE PRECISION array, dimension
* (LDR1,LDR2,LDR3,NSUBS+1)
* The timing results for each subroutine over the relevant
* values of N.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= 1.
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NM).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 4 )
* ..
* .. Local Scalars ..
CHARACTER TRANS
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, IC, ICL, ILDA, IM, INFO, ISUB, ITRAN, LDB,
$ M, N, NRHS
DOUBLE PRECISION OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER TRANSS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER LAVAL( 1 )
* ..
* .. External Functions ..
DOUBLE PRECISION DMFLOP, DSECND, DOPGB
EXTERNAL DMFLOP, DSECND, DOPGB
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, DGTSL, DGTSV, DGTTRF, DGTTRS,
$ DPRTBL, DTIMMG
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX
* ..
* .. Data statements ..
DATA SUBNAM / 'DGTTRF', 'DGTTRS', 'DGTSV ',
$ 'DGTSL ' /
DATA TRANSS / 'N', 'T' /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'GT'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 180
*
* Check that N <= LDA for the input values.
*
DO 10 ISUB = 2, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 10
CNAME = SUBNAM( ISUB )
CALL ATIMCK( 2, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9998 )CNAME
TIMSUB( ISUB ) = .FALSE.
END IF
10 CONTINUE
*
* Do for each value of M:
*
DO 150 IM = 1, NM
*
M = MVAL( IM )
N = MAX( M, 1 )
*
* Time DGTTRF
*
IF( TIMSUB( 1 ) ) THEN
CALL DTIMMG( 12, M, M, A, 3*N, 0, 0 )
IC = 0
S1 = DSECND( )
20 CONTINUE
CALL DGTTRF( M, A, A( N ), A( 2*N ), A( 3*N-2 ), IWORK,
$ INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 12, M, M, A, 3*N, 0, 0 )
GO TO 20
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
30 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 12, M, M, A, 3*N, 0, 0 )
GO TO 30
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPGB( 'DGTTRF', M, M, 1, 1, IWORK )
RESLTS( 1, IM, 1, 1 ) = DMFLOP( OPS, TIME, INFO )
*
ELSE IF( TIMSUB( 2 ) ) THEN
CALL DTIMMG( 12, M, M, A, 3*N, 0, 0 )
END IF
*
* Generate another matrix and factor it using DGTTRF so
* that the factored form can be used in timing the other
* routines.
*
IF( IC.NE.1 )
$ CALL DGTTRF( M, A, A( N ), A( 2*N ), A( 3*N-2 ), IWORK,
$ INFO )
*
* Time DGTTRS
*
IF( TIMSUB( 2 ) ) THEN
DO 80 ITRAN = 1, 2
TRANS = TRANSS( ITRAN )
DO 70 ILDA = 1, NLDA
LDB = LDAVAL( ILDA )
DO 60 I = 1, NNS
NRHS = NSVAL( I )
CALL DTIMMG( 0, M, NRHS, B, LDB, 0, 0 )
IC = 0
S1 = DSECND( )
40 CONTINUE
CALL DGTTRS( TRANS, M, NRHS, A, A( N ), A( 2*N ),
$ A( 3*N-2 ), IWORK, B, LDB, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, M, NRHS, B, LDB, 0, 0 )
GO TO 40
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
50 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, M, NRHS, B, LDB, 0, 0 )
GO TO 50
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPGB( 'DGTTRS', M, NRHS, 0, 0, IWORK )
IF( ITRAN.EQ.1 ) THEN
RESLTS( I, IM, ILDA, 2 ) = DMFLOP( OPS, TIME,
$ INFO )
ELSE
RESLTS( I, IM, ILDA, 5 ) = DMFLOP( OPS, TIME,
$ INFO )
END IF
60 CONTINUE
70 CONTINUE
80 CONTINUE
END IF
*
IF( TIMSUB( 3 ) ) THEN
DO 120 ILDA = 1, NLDA
LDB = LDAVAL( ILDA )
DO 110 I = 1, NNS
NRHS = NSVAL( I )
CALL DTIMMG( 12, M, M, A, 3*N, 0, 0 )
CALL DTIMMG( 0, M, NRHS, B, LDB, 0, 0 )
IC = 0
S1 = DSECND( )
90 CONTINUE
CALL DGTSV( M, NRHS, A, A( N ), A( 2*N ), B, LDB,
$ INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 12, M, M, A, 3*N, 0, 0 )
CALL DTIMMG( 0, M, NRHS, B, LDB, 0, 0 )
GO TO 90
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
100 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 12, M, M, A, 3*N, 0, 0 )
CALL DTIMMG( 0, M, NRHS, B, LDB, 0, 0 )
GO TO 100
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPGB( 'DGTSV ', M, NRHS, 0, 0, IWORK )
RESLTS( I, IM, ILDA, 3 ) = DMFLOP( OPS, TIME, INFO )
110 CONTINUE
120 CONTINUE
END IF
*
IF( TIMSUB( 4 ) ) THEN
CALL DTIMMG( 12, M, M, A, 3*N, 0, 0 )
CALL DTIMMG( 0, M, 1, B, N, 0, 0 )
IC = 0
S1 = DSECND( )
130 CONTINUE
CALL DGTSL( M, A, A( N ), A( 2*N ), B, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 12, M, M, A, 3*N, 0, 0 )
CALL DTIMMG( 0, M, 1, B, LDB, 0, 0 )
GO TO 130
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
140 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 12, M, M, A, 3*N, 0, 0 )
CALL DTIMMG( 0, M, 1, B, LDB, 0, 0 )
GO TO 140
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPGB( 'DGTSV ', M, 1, 0, 0, IWORK )
RESLTS( 1, IM, 1, 4 ) = DMFLOP( OPS, TIME, INFO )
END IF
150 CONTINUE
*
* Print a table of results for each timed routine.
*
DO 170 ISUB = 1, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 170
WRITE( NOUT, FMT = 9997 )SUBNAM( ISUB )
IF( NLDA.GT.1 .AND. ( TIMSUB( 2 ) .OR. TIMSUB( 3 ) ) ) THEN
DO 160 I = 1, NLDA
WRITE( NOUT, FMT = 9996 )I, LDAVAL( I )
160 CONTINUE
END IF
WRITE( NOUT, FMT = * )
IF( ISUB.EQ.1 ) THEN
CALL DPRTBL( ' ', 'N', 1, LAVAL, NM, MVAL, 1, RESLTS, LDR1,
$ LDR2, NOUT )
ELSE IF( ISUB.EQ.2 ) THEN
WRITE( NOUT, FMT = 9999 )'N'
9999 FORMAT( ' DGTTRS with TRANS = ''', A1, '''', / )
CALL DPRTBL( 'NRHS', 'N', NNS, NSVAL, NM, MVAL, NLDA,
$ RESLTS( 1, 1, 1, 2 ), LDR1, LDR2, NOUT )
WRITE( NOUT, FMT = 9999 )'T'
CALL DPRTBL( 'NRHS', 'N', NNS, NSVAL, NM, MVAL, NLDA,
$ RESLTS( 1, 1, 1, 5 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.3 ) THEN
CALL DPRTBL( 'NRHS', 'N', NNS, NSVAL, NM, MVAL, NLDA,
$ RESLTS( 1, 1, 1, 3 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.4 ) THEN
CALL DPRTBL( ' ', 'N', 1, LAVAL, NM, MVAL, 1,
$ RESLTS( 1, 1, 1, 4 ), LDR1, LDR2, NOUT )
END IF
170 CONTINUE
*
180 CONTINUE
9998 FORMAT( 1X, A6, ' timing run not attempted', / )
9997 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9996 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
RETURN
*
* End of DTIMGT
*
END
SUBROUTINE DTIMHR( LINE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
$ NLDA, LDAVAL, TIMMIN, A, TAU, B, WORK, RESLTS,
$ LDR1, LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NLDA, NM, NN, NNB, NOUT
DOUBLE PRECISION TIMMIN
* ..
* .. Array Arguments ..
INTEGER LDAVAL( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
$ NXVAL( * )
DOUBLE PRECISION A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * ),
$ TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DTIMHR times the LAPACK routines DGEHRD, DORGHR, and DORMHR and the
* EISPACK routine ORTHES.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix size M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) DOUBLE PRECISION
* The minimum time a subroutine will be timed.
*
* A (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values of LDA and N.
*
* TAU (workspace) DOUBLE PRECISION array, dimension (min(M,N))
*
* B (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NBMAX)
* where NBMAX is the maximum value of NB.
*
* RESLTS (workspace) DOUBLE PRECISION array, dimension
* (LDR1,LDR2,LDR3,4*NN+3)
* The timing results for each subroutine over the relevant
* values of M, (NB,NX), LDA, and N.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NM).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* Internal Parameters
* ===================
*
* MODE INTEGER
* The matrix type. MODE = 3 is a geometric distribution of
* eigenvalues. See ZLATMS for further details.
*
* COND DOUBLE PRECISION
* The condition number of the matrix. The singular values are
* set to values from DMAX to DMAX/COND.
*
* DMAX DOUBLE PRECISION
* The magnitude of the largest singular value.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 4 )
INTEGER MODE
DOUBLE PRECISION COND, DMAX
PARAMETER ( MODE = 3, COND = 100.0D0, DMAX = 1.0D0 )
* ..
* .. Local Scalars ..
CHARACTER LAB1, LAB2, SIDE, TRANS
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, I4, IC, ICL, IHI, ILDA, ILO, IM, IN, INB,
$ INFO, ISIDE, ISUB, ITOFF, ITRAN, LDA, LW, M,
$ M1, N, N1, NB, NX
DOUBLE PRECISION OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER SIDES( 2 ), TRANSS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER ISEED( 4 ), RESEED( 4 )
* ..
* .. External Functions ..
DOUBLE PRECISION DMFLOP, DOPLA, DSECND
EXTERNAL DMFLOP, DOPLA, DSECND
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, DGEHRD, DLACPY, DLATMS, DORGHR,
$ DORMHR, DPRTB3, DPRTBL, DTIMMG, ICOPY, ORTHES,
$ XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX
* ..
* .. Data statements ..
DATA SUBNAM / 'DGEHRD', 'ORTHES', 'DORGHR',
$ 'DORMHR' /
DATA SIDES / 'L', 'R' / , TRANSS / 'N', 'T' /
DATA ISEED / 0, 0, 0, 1 /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'HR'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 210
*
* Check that N <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 2, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 210
END IF
*
* Check that K <= LDA for DORMHR
*
IF( TIMSUB( 4 ) ) THEN
CALL ATIMCK( 3, CNAME, NN, NVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )SUBNAM( 4 )
TIMSUB( 4 ) = .FALSE.
END IF
END IF
*
* Do for each value of M:
*
DO 140 IM = 1, NM
M = MVAL( IM )
ILO = 1
IHI = M
CALL ICOPY( 4, ISEED, 1, RESEED, 1 )
*
* Do for each value of LDA:
*
DO 130 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
*
* Do for each pair of values (NB, NX) in NBVAL and NXVAL.
*
DO 120 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
LW = MAX( 1, M*MAX( 1, NB ) )
*
* Generate a test matrix of size M by M.
*
CALL ICOPY( 4, RESEED, 1, ISEED, 1 )
CALL DLATMS( M, M, 'Uniform', ISEED, 'Nonsym', TAU, MODE,
$ COND, DMAX, M, M, 'No packing', B, LDA,
$ WORK, INFO )
*
IF( TIMSUB( 2 ) .AND. INB.EQ.1 ) THEN
*
* ORTHES: Eispack reduction using orthogonal
* transformations.
*
CALL DLACPY( 'Full', M, M, B, LDA, A, LDA )
IC = 0
S1 = DSECND( )
10 CONTINUE
CALL ORTHES( LDA, M, 1, IHI, A, TAU )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DLACPY( 'Full', M, M, B, LDA, A, LDA )
GO TO 10
END IF
*
* Subtract the time used in DLACPY.
*
ICL = 1
S1 = DSECND( )
20 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DLACPY( 'Full', M, M, B, LDA, A, LDA )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DGEHRD', M, ILO, IHI, 0, NB )
RESLTS( INB, IM, ILDA, 2 ) = DMFLOP( OPS, TIME, INFO )
END IF
*
IF( TIMSUB( 1 ) ) THEN
*
* DGEHRD: Reduction to Hesenberg form
*
CALL DLACPY( 'Full', M, M, B, LDA, A, LDA )
IC = 0
S1 = DSECND( )
30 CONTINUE
CALL DGEHRD( M, ILO, IHI, A, LDA, TAU, WORK, LW,
$ INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DLACPY( 'Full', M, M, B, LDA, A, LDA )
GO TO 30
END IF
*
* Subtract the time used in DLACPY.
*
ICL = 1
S1 = DSECND( )
40 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DLACPY( 'Full', M, M, A, LDA, B, LDA )
GO TO 40
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DGEHRD', M, ILO, IHI, 0, NB )
RESLTS( INB, IM, ILDA, 1 ) = DMFLOP( OPS, TIME, INFO )
ELSE
*
* If DGEHRD was not timed, generate a matrix and factor
* it using DGEHRD anyway so that the factored form of
* the matrix can be used in timing the other routines.
*
CALL DLACPY( 'Full', M, M, B, LDA, A, LDA )
CALL DGEHRD( M, ILO, IHI, A, LDA, TAU, WORK, LW,
$ INFO )
END IF
*
IF( TIMSUB( 3 ) ) THEN
*
* DORGHR: Generate the orthogonal matrix Q from the
* reduction to Hessenberg form A = Q*H*Q'
*
CALL DLACPY( 'Full', M, M, A, LDA, B, LDA )
IC = 0
S1 = DSECND( )
50 CONTINUE
CALL DORGHR( M, ILO, IHI, B, LDA, TAU, WORK, LW,
$ INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DLACPY( 'Full', M, M, A, LDA, B, LDA )
GO TO 50
END IF
*
* Subtract the time used in DLACPY.
*
ICL = 1
S1 = DSECND( )
60 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DLACPY( 'Full', M, M, A, LDA, B, LDA )
GO TO 60
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
*
* Op count for DORGHR: same as
* DORGQR( IHI-ILO, IHI-ILO, IHI-ILO, ... )
*
OPS = DOPLA( 'DORGQR', IHI-ILO, IHI-ILO, IHI-ILO, 0,
$ NB )
RESLTS( INB, IM, ILDA, 3 ) = DMFLOP( OPS, TIME, INFO )
END IF
*
IF( TIMSUB( 4 ) ) THEN
*
* DORMHR: Multiply by Q stored as a product of
* elementary transformations
*
I4 = 3
DO 110 ISIDE = 1, 2
SIDE = SIDES( ISIDE )
DO 100 IN = 1, NN
N = NVAL( IN )
LW = MAX( 1, MAX( 1, NB )*N )
IF( ISIDE.EQ.1 ) THEN
M1 = M
N1 = N
ELSE
M1 = N
N1 = M
END IF
ITOFF = 0
DO 90 ITRAN = 1, 2
TRANS = TRANSS( ITRAN )
CALL DTIMMG( 0, M1, N1, B, LDA, 0, 0 )
IC = 0
S1 = DSECND( )
70 CONTINUE
CALL DORMHR( SIDE, TRANS, M1, N1, ILO, IHI,
$ A, LDA, TAU, B, LDA, WORK, LW,
$ INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, M1, N1, B, LDA, 0, 0 )
GO TO 70
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
80 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, M1, N1, B, LDA, 0, 0 )
GO TO 80
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
*
* Op count for DORMHR, SIDE='L': same as
* DORMQR( 'L', TRANS, IHI-ILO, N, IHI-ILO, ...)
*
* Op count for DORMHR, SIDE='R': same as
* DORMQR( 'R', TRANS, M, IHI-ILO, IHI-ILO, ...)
*
IF( ISIDE.EQ.1 ) THEN
OPS = DOPLA( 'DORMQR', IHI-ILO, N1,
$ IHI-ILO, -1, NB )
ELSE
OPS = DOPLA( 'DORMQR', M1, IHI-ILO,
$ IHI-ILO, 1, NB )
END IF
*
RESLTS( INB, IM, ILDA,
$ I4+ITOFF+IN ) = DMFLOP( OPS, TIME, INFO )
ITOFF = NN
90 CONTINUE
100 CONTINUE
I4 = I4 + 2*NN
110 CONTINUE
END IF
*
120 CONTINUE
130 CONTINUE
140 CONTINUE
*
* Print tables of results for DGEHRD, ORTHES, and DORGHR
*
DO 160 ISUB = 1, NSUBS - 1
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 160
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 150 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
150 CONTINUE
END IF
WRITE( NOUT, FMT = 9995 )
IF( ISUB.EQ.2 ) THEN
CALL DPRTB3( ' ', 'N', 1, NBVAL, NXVAL, NM, MVAL, NLDA,
$ RESLTS( 1, 1, 1, ISUB ), LDR1, LDR2, NOUT )
ELSE
CALL DPRTB3( '( NB, NX)', 'N', NNB, NBVAL, NXVAL, NM,
$ MVAL, NLDA, RESLTS( 1, 1, 1, ISUB ), LDR1,
$ LDR2, NOUT )
END IF
160 CONTINUE
*
* Print tables of results for DORMHR
*
ISUB = 4
IF( TIMSUB( ISUB ) ) THEN
I4 = 3
DO 200 ISIDE = 1, 2
IF( ISIDE.EQ.1 ) THEN
LAB1 = 'M'
LAB2 = 'N'
IF( NLDA.GT.1 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
DO 170 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
170 CONTINUE
WRITE( NOUT, FMT = 9994 )
END IF
ELSE
LAB1 = 'N'
LAB2 = 'M'
END IF
DO 190 ITRAN = 1, 2
DO 180 IN = 1, NN
WRITE( NOUT, FMT = 9996 )SUBNAM( ISUB ),
$ SIDES( ISIDE ), TRANSS( ITRAN ), LAB2, NVAL( IN )
CALL DPRTBL( 'NB', LAB1, NNB, NBVAL, NM, MVAL, NLDA,
$ RESLTS( 1, 1, 1, I4+IN ), LDR1, LDR2,
$ NOUT )
180 CONTINUE
I4 = I4 + NN
190 CONTINUE
200 CONTINUE
END IF
210 CONTINUE
*
* Print a table of results for each timed routine.
*
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops *** ' )
9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
9996 FORMAT( / 5X, A6, ' with SIDE = ''', A1, ''', TRANS = ''', A1,
$ ''', ', A1, ' =', I6, / )
9995 FORMAT( / 5X, 'ILO = 1, IHI = N', / )
9994 FORMAT( / 5X, 'ILO = 1, IHI = M if SIDE = ''L''', / 5X,
$ ' = N if SIDE = ''R''' )
RETURN
*
* End of DTIMHR
*
END
SUBROUTINE DTIMLQ( LINE, NM, MVAL, NVAL, NK, KVAL, NNB, NBVAL,
$ NXVAL, NLDA, LDAVAL, TIMMIN, A, TAU, B, WORK,
$ RESLTS, LDR1, LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NK, NLDA, NM, NNB, NOUT
DOUBLE PRECISION TIMMIN
* ..
* .. Array Arguments ..
INTEGER KVAL( * ), LDAVAL( * ), MVAL( * ), NBVAL( * ),
$ NVAL( * ), NXVAL( * )
DOUBLE PRECISION A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * ),
$ TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DTIMLQ times the LAPACK routines to perform the LQ factorization of
* a DOUBLE PRECISION general matrix.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M and N contained in the vectors
* MVAL and NVAL. The matrix sizes are used in pairs (M,N).
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NVAL (input) INTEGER array, dimension (NM)
* The values of the matrix column dimension N.
*
* NK (input) INTEGER
* The number of values of K in the vector KVAL.
*
* KVAL (input) INTEGER array, dimension (NK)
* The values of the matrix dimension K, used in DORMLQ.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) DOUBLE PRECISION
* The minimum time a subroutine will be timed.
*
* A (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values of LDA and N.
*
* TAU (workspace) DOUBLE PRECISION array, dimension (min(M,N))
*
* B (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NBMAX)
* where NBMAX is the maximum value of NB.
*
* RESLTS (workspace) DOUBLE PRECISION array, dimension
* (LDR1,LDR2,LDR3,2*NK)
* The timing results for each subroutine over the relevant
* values of (M,N), (NB,NX), and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NM).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* Internal Parameters
* ===================
*
* MODE INTEGER
* The matrix type. MODE = 3 is a geometric distribution of
* eigenvalues. See DLATMS for further details.
*
* COND DOUBLE PRECISION
* The condition number of the matrix. The singular values are
* set to values from DMAX to DMAX/COND.
*
* DMAX DOUBLE PRECISION
* The magnitude of the largest singular value.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 3 )
INTEGER MODE
DOUBLE PRECISION COND, DMAX
PARAMETER ( MODE = 3, COND = 100.0D0, DMAX = 1.0D0 )
* ..
* .. Local Scalars ..
CHARACTER LABM, SIDE, TRANS
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, I4, IC, ICL, IK, ILDA, IM, IMX, INB, INFO,
$ ISIDE, ISUB, ITOFF, ITRAN, K, K1, LDA, LW, M,
$ M1, MINMN, N, N1, NB, NX
DOUBLE PRECISION OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER SIDES( 2 ), TRANSS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER ISEED( 4 ), MUSE( 12 ), NUSE( 12 ), RESEED( 4 )
* ..
* .. External Functions ..
DOUBLE PRECISION DMFLOP, DOPLA, DSECND
EXTERNAL DMFLOP, DOPLA, DSECND
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, DGELQF, DLACPY, DLATMS, DORGLQ,
$ DORMLQ, DPRTB4, DPRTB5, DTIMMG, ICOPY, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Data statements ..
DATA SUBNAM / 'DGELQF', 'DORGLQ', 'DORMLQ' /
DATA SIDES / 'L', 'R' / , TRANSS / 'N', 'T' /
DATA ISEED / 0, 0, 0, 1 /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'LQ'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 230
*
* Check that M <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 230
END IF
*
* Do for each pair of values (M,N):
*
DO 70 IM = 1, NM
M = MVAL( IM )
N = NVAL( IM )
MINMN = MIN( M, N )
CALL ICOPY( 4, ISEED, 1, RESEED, 1 )
*
* Do for each value of LDA:
*
DO 60 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
*
* Do for each pair of values (NB, NX) in NBVAL and NXVAL.
*
DO 50 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
LW = MAX( 1, M*MAX( 1, NB ) )
*
* Generate a test matrix of size M by N.
*
CALL ICOPY( 4, RESEED, 1, ISEED, 1 )
CALL DLATMS( M, N, 'Uniform', ISEED, 'Nonsym', TAU, MODE,
$ COND, DMAX, M, N, 'No packing', B, LDA,
$ WORK, INFO )
*
IF( TIMSUB( 1 ) ) THEN
*
* DGELQF: LQ factorization
*
CALL DLACPY( 'Full', M, N, B, LDA, A, LDA )
IC = 0
S1 = DSECND( )
10 CONTINUE
CALL DGELQF( M, N, A, LDA, TAU, WORK, LW, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DLACPY( 'Full', M, N, B, LDA, A, LDA )
GO TO 10
END IF
*
* Subtract the time used in DLACPY.
*
ICL = 1
S1 = DSECND( )
20 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DLACPY( 'Full', M, N, A, LDA, B, LDA )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DGELQF', M, N, 0, 0, NB )
RESLTS( INB, IM, ILDA, 1 ) = DMFLOP( OPS, TIME, INFO )
ELSE
*
* If DGELQF was not timed, generate a matrix and factor
* it using DGELQF anyway so that the factored form of
* the matrix can be used in timing the other routines.
*
CALL DLACPY( 'Full', M, N, B, LDA, A, LDA )
CALL DGELQF( M, N, A, LDA, TAU, WORK, LW, INFO )
END IF
*
IF( TIMSUB( 2 ) ) THEN
*
* DORGLQ: Generate orthogonal matrix Q from the LQ
* factorization
*
CALL DLACPY( 'Full', MINMN, N, A, LDA, B, LDA )
IC = 0
S1 = DSECND( )
30 CONTINUE
CALL DORGLQ( MINMN, N, MINMN, B, LDA, TAU, WORK, LW,
$ INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DLACPY( 'Full', MINMN, N, A, LDA, B, LDA )
GO TO 30
END IF
*
* Subtract the time used in DLACPY.
*
ICL = 1
S1 = DSECND( )
40 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DLACPY( 'Full', MINMN, N, A, LDA, B, LDA )
GO TO 40
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DORGLQ', MINMN, N, MINMN, 0, NB )
RESLTS( INB, IM, ILDA, 2 ) = DMFLOP( OPS, TIME, INFO )
END IF
*
50 CONTINUE
60 CONTINUE
70 CONTINUE
*
* Print tables of results
*
DO 90 ISUB = 1, NSUBS - 1
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 90
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 80 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
80 CONTINUE
END IF
WRITE( NOUT, FMT = * )
IF( ISUB.EQ.2 )
$ WRITE( NOUT, FMT = 9996 )
CALL DPRTB4( '( NB, NX)', 'M', 'N', NNB, NBVAL, NXVAL, NM,
$ MVAL, NVAL, NLDA, RESLTS( 1, 1, 1, ISUB ), LDR1,
$ LDR2, NOUT )
90 CONTINUE
*
* Time DORMLQ separately. Here the starting matrix is M by N, and
* K is the free dimension of the matrix multiplied by Q.
*
IF( TIMSUB( 3 ) ) THEN
*
* Check that K <= LDA for the input values.
*
CALL ATIMCK( 3, CNAME, NK, KVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )SUBNAM( 3 )
GO TO 230
END IF
*
* Use only the pairs (M,N) where M <= N.
*
IMX = 0
DO 100 IM = 1, NM
IF( MVAL( IM ).LE.NVAL( IM ) ) THEN
IMX = IMX + 1
MUSE( IMX ) = MVAL( IM )
NUSE( IMX ) = NVAL( IM )
END IF
100 CONTINUE
*
* DORMLQ: Multiply by Q stored as a product of elementary
* transformations
*
* Do for each pair of values (M,N):
*
DO 180 IM = 1, IMX
M = MUSE( IM )
N = NUSE( IM )
*
* Do for each value of LDA:
*
DO 170 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
*
* Generate an M by N matrix and form its LQ decomposition.
*
CALL DLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', TAU,
$ MODE, COND, DMAX, M, N, 'No packing', A,
$ LDA, WORK, INFO )
LW = MAX( 1, M*MAX( 1, NB ) )
CALL DGELQF( M, N, A, LDA, TAU, WORK, LW, INFO )
*
* Do first for SIDE = 'L', then for SIDE = 'R'
*
I4 = 0
DO 160 ISIDE = 1, 2
SIDE = SIDES( ISIDE )
*
* Do for each pair of values (NB, NX) in NBVAL and
* NXVAL.
*
DO 150 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
*
* Do for each value of K in KVAL
*
DO 140 IK = 1, NK
K = KVAL( IK )
*
* Sort out which variable is which
*
IF( ISIDE.EQ.1 ) THEN
K1 = M
M1 = N
N1 = K
LW = MAX( 1, N1*MAX( 1, NB ) )
ELSE
K1 = M
N1 = N
M1 = K
LW = MAX( 1, M1*MAX( 1, NB ) )
END IF
*
* Do first for TRANS = 'N', then for TRANS = 'T'
*
ITOFF = 0
DO 130 ITRAN = 1, 2
TRANS = TRANSS( ITRAN )
CALL DTIMMG( 0, M1, N1, B, LDA, 0, 0 )
IC = 0
S1 = DSECND( )
110 CONTINUE
CALL DORMLQ( SIDE, TRANS, M1, N1, K1, A, LDA,
$ TAU, B, LDA, WORK, LW, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, M1, N1, B, LDA, 0, 0 )
GO TO 110
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
120 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, M1, N1, B, LDA, 0, 0 )
GO TO 120
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DORMLQ', M1, N1, K1, ISIDE-1,
$ NB )
RESLTS( INB, IM, ILDA,
$ I4+ITOFF+IK ) = DMFLOP( OPS, TIME, INFO )
ITOFF = NK
130 CONTINUE
140 CONTINUE
150 CONTINUE
I4 = 2*NK
160 CONTINUE
170 CONTINUE
180 CONTINUE
*
* Print tables of results
*
ISUB = 3
I4 = 1
IF( IMX.GE.1 ) THEN
DO 220 ISIDE = 1, 2
SIDE = SIDES( ISIDE )
IF( ISIDE.EQ.1 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 190 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
190 CONTINUE
END IF
END IF
DO 210 ITRAN = 1, 2
TRANS = TRANSS( ITRAN )
DO 200 IK = 1, NK
IF( ISIDE.EQ.1 ) THEN
N = KVAL( IK )
WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ), SIDE,
$ TRANS, 'N', N
LABM = 'M'
ELSE
M = KVAL( IK )
WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ), SIDE,
$ TRANS, 'M', M
LABM = 'N'
END IF
CALL DPRTB5( 'NB', 'K', LABM, NNB, NBVAL, IMX,
$ MUSE, NUSE, NLDA,
$ RESLTS( 1, 1, 1, I4 ), LDR1, LDR2,
$ NOUT )
I4 = I4 + 1
200 CONTINUE
210 CONTINUE
220 CONTINUE
ELSE
WRITE( NOUT, FMT = 9994 )SUBNAM( ISUB )
END IF
END IF
230 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
9996 FORMAT( 5X, 'K = min(M,N)', / )
9995 FORMAT( / 5X, A6, ' with SIDE = ''', A1, ''', TRANS = ''', A1,
$ ''', ', A1, ' =', I6, / )
9994 FORMAT( ' *** No pairs (M,N) found with M <= N: ', A6,
$ ' not timed' )
RETURN
*
* End of DTIMLQ
*
END
SUBROUTINE DTIMLS( LINE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB,
$ NBVAL, NXVAL, NLDA, LDAVAL, TIMMIN, A, COPYA,
$ B, COPYB, S, COPYS, OPCTBL, TIMTBL, FLPTBL,
$ WORK, IWORK, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* December 22, 1999
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER NLDA, NM, NN, NNB, NNS, NOUT
DOUBLE PRECISION TIMMIN
* ..
* .. Array Arguments ..
INTEGER IWORK( * ), LDAVAL( * ), MVAL( * ), NBVAL( * ),
$ NSVAL( * ), NVAL( * ), NXVAL( * )
DOUBLE PRECISION A( * ), B( * ), COPYA( * ), COPYB( * ),
$ COPYS( * ), FLPTBL( 6, 6,
$ NM*NN*NNS*NLDA*( NNB+1 ), * ),
$ OPCTBL( 6, 6, NM*NN*NNS*NLDA*( NNB+1 ), * ),
$ S( * ), TIMTBL( 6, 6, NM*NN*NNS*NLDA*( NNB+1 ),
$ * ), WORK( * )
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, IOUNIT, OK, LERR
COMMON / LSTIME / OPCNT, TIMNG
COMMON / SRNAMC / SRNAMT
* ..
* .. Arrays in Common ..
DOUBLE PRECISION OPCNT( 6 ), TIMNG( 6 )
* ..
*
* Purpose
* =======
*
* DTIMLS times the least squares driver routines DGELS, SGELSS, SGELSX,
* DGELSY and SGELSD.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) DOUBLE PRECISION
* The minimum time a subroutine will be timed.
*
* A (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX)
* where MMAX is the maximum value of M in MVAL and NMAX is the
* maximum value of N in NVAL.
*
* COPYA (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX)
*
* B (workspace) DOUBLE PRECISION array, dimension (MMAX*NSMAX)
* where MMAX is the maximum value of M in MVAL and NSMAX is the
* maximum value of NRHS in NSVAL.
*
* COPYB (workspace) DOUBLE PRECISION array, dimension (MMAX*NSMAX)
*
* S (workspace) DOUBLE PRECISION array, dimension
* (min(MMAX,NMAX))
*
* COPYS (workspace) DOUBLE PRECISION array, dimension
* (min(MMAX,NMAX))
*
* OPZTBL (workspace) DOUBLE PRECISION array, dimension
* (6,6,(NNB+1)*NLDA,NM*NN*NNS,5)
*
* TIMTBL (workspace) DOUBLE PRECISION array, dimension
* (6,6,(NNB+1)*NLDA,NM*NN*NNS,5)
*
* FLPTBL (workspace) DOUBLE PRECISION array, dimension
* (6,6,(NNB+1)*NLDA,NM*NN*NNS,5)
*
* WORK (workspace) DOUBLE PRECISION array,
* dimension (MMAX*NMAX + 4*NMAX + MMAX).
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER MTYPE, NSUBS
PARAMETER ( MTYPE = 6, NSUBS = 5 )
INTEGER SMLSIZ
PARAMETER ( SMLSIZ = 25 )
DOUBLE PRECISION ONE, TWO, ZERO
PARAMETER ( ONE = 1.0D0, TWO = 2.0D0, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
CHARACTER TRANS
CHARACTER*3 PATH
INTEGER CRANK, I, ILDA, IM, IN, INB, INFO, INS, IRANK,
$ ISCALE, ISUB, ITBL, ITRAN, ITYPE, LDA, LDB,
$ LDWORK, LWLSY, LWORK, M, MNMIN, N, NB, NCALL,
$ NCLS, NCLSD, NCLSS, NCLSX, NCLSY, NCOLS, NLVL,
$ NRHS, NROWS, RANK
DOUBLE PRECISION EPS, NORMA, NORMB, RCOND, S1, S2, TIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER ISEED( 4 ), ISEEDY( 4 ), NDATA( NSUBS )
* ..
* .. External Functions ..
DOUBLE PRECISION DASUM, DLAMCH, DMFLOP, DSECND
EXTERNAL DASUM, DLAMCH, DMFLOP, DSECND
* ..
* .. External Subroutines ..
EXTERNAL ATIMIN, DCOPY, DGELS, DGELSD, DGELSS, DGELSX,
$ DGELSY, DGEMM, DLACPY, DLARNV, DLASET, DQRT13,
$ DQRT15, DSCAL, DPRTLS, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, LOG, MAX, MIN, SQRT
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, IOUNIT
* ..
* .. Common blocks ..
* ..
* .. Data statements ..
DATA SUBNAM / 'DGELS ', 'DGELSX', 'DGELSY',
$ 'DGELSS', 'DGELSD' /
DATA ISEEDY / 1988, 1989, 1990, 1991 /
DATA NDATA / 4, 6, 6, 6, 5 /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'LS'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 230
*
* Initialize constants and the random number seed.
*
NCLS = 0
NCLSD = 0
NCLSS = 0
NCLSX = 0
NCLSY = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
EPS = DLAMCH( 'Epsilon' )
*
* Threshold for rank estimation
*
RCOND = SQRT( EPS ) - ( SQRT( EPS )-EPS ) / 2
*
INFOT = 0
CALL XLAENV( 2, 2 )
CALL XLAENV( 9, SMLSIZ )
*
DO 200 IM = 1, NM
M = MVAL( IM )
*
DO 190 IN = 1, NN
N = NVAL( IN )
MNMIN = MIN( M, N )
*
DO 180 INS = 1, NNS
NRHS = NSVAL( INS )
NLVL = MAX( INT( LOG( MAX( ONE, DBLE( MNMIN ) ) /
$ DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1, 0 )
LWORK = MAX( 1, ( M+NRHS )*( N+2 ), ( N+NRHS )*( M+2 ),
$ M*N+4*MNMIN+MAX( M, N ), 12*MNMIN+2*MNMIN*SMLSIZ+
$ 8*MNMIN*NLVL+MNMIN*NRHS+(SMLSIZ+1)**2 )
*
DO 170 ILDA = 1, NLDA
LDA = MAX( 1, LDAVAL( ILDA ) )
LDB = MAX( 1, LDAVAL( ILDA ), M, N )
*
DO 160 IRANK = 1, 2
*
DO 150 ISCALE = 1, 3
*
IF( IRANK.EQ.1 .AND. TIMSUB( 1 ) ) THEN
*
* Time DGELS
*
* Generate a matrix of scaling type ISCALE
*
CALL DQRT13( ISCALE, M, N, COPYA, LDA, NORMA,
$ ISEED )
DO 50 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
CALL XLAENV( 3, NXVAL( INB ) )
*
DO 40 ITRAN = 1, 2
ITYPE = ( ITRAN-1 )*3 + ISCALE
IF( ITRAN.EQ.1 ) THEN
TRANS = 'N'
NROWS = M
NCOLS = N
ELSE
TRANS = 'T'
NROWS = N
NCOLS = M
END IF
LDWORK = MAX( 1, NCOLS )
*
* Set up a consistent rhs
*
IF( NCOLS.GT.0 ) THEN
CALL DLARNV( 2, ISEED, NCOLS*NRHS,
$ WORK )
CALL DSCAL( NCOLS*NRHS,
$ ONE / DBLE( NCOLS ),
$ WORK, 1 )
END IF
CALL DGEMM( TRANS, 'No transpose',
$ NROWS, NRHS, NCOLS, ONE,
$ COPYA, LDA, WORK, LDWORK,
$ ZERO, B, LDB )
CALL DLACPY( 'Full', NROWS, NRHS, B,
$ LDB, COPYB, LDB )
*
* Solve LS or overdetermined system
*
NCALL = 0
TIME = ZERO
CALL DLASET( 'Full', NDATA( 1 ), 1,
$ ZERO, ZERO, OPCNT,
$ NDATA( 1 ) )
CALL DLASET( 'Full', NDATA( 1 ), 1,
$ ZERO, ZERO, TIMNG,
$ NDATA( 1 ) )
20 CONTINUE
IF( M.GT.0 .AND. N.GT.0 ) THEN
CALL DLACPY( 'Full', M, N, COPYA,
$ LDA, A, LDA )
CALL DLACPY( 'Full', NROWS, NRHS,
$ COPYB, LDB, B, LDB )
END IF
SRNAMT = 'DGELS '
NCALL = NCALL + 1
S1 = DSECND( )
CALL DGELS( TRANS, M, N, NRHS, A, LDA,
$ B, LDB, WORK, LWORK, INFO )
S2 = DSECND( )
TIME = TIME + ( S2-S1 )
IF( INFO.EQ.0 .AND. TIME.LT.TIMMIN )
$ GO TO 20
TIMNG( 1 ) = TIME
OPCNT( 1 ) = DASUM( NDATA( 1 ), OPCNT,
$ 1 )
CALL DSCAL( NDATA( 1 ),
$ ONE / DBLE( NCALL ), OPCNT,
$ 1 )
CALL DSCAL( NDATA( 1 ),
$ ONE / DBLE( NCALL ), TIMNG,
$ 1 )
CALL DCOPY( NDATA( 1 ), OPCNT, 1,
$ OPCTBL( 1, ITYPE, NCLS+INB,
$ 1 ), 1 )
CALL DCOPY( NDATA( 1 ), TIMNG, 1,
$ TIMTBL( 1, ITYPE, NCLS+INB,
$ 1 ), 1 )
DO 30 I = 1, NDATA( 1 )
FLPTBL( I, ITYPE, NCLS+INB,
$ 1 ) = DMFLOP( OPCNT( I ),
$ TIMNG( I ), INFO )
30 CONTINUE
40 CONTINUE
50 CONTINUE
*
END IF
*
* Generate a matrix of scaling type ISCALE and
* rank type IRANK.
*
ITYPE = ( IRANK-1 )*3 + ISCALE
CALL DQRT15( ISCALE, IRANK, M, N, NRHS, COPYA,
$ LDA, COPYB, LDB, COPYS, RANK,
$ NORMA, NORMB, ISEED, WORK, LWORK )
*
IF( TIMSUB( 2 ) ) THEN
*
* Time DGELSX
*
* workspace used:
* MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M)
*
LDWORK = MAX( 1, M )
*
* DGELSX: Compute the minimum-norm
* solution X to min( norm( A * X - B ) )
* using a complete orthogonal factorization.
*
NCALL = 0
TIME = ZERO
CALL DLASET( 'Full', NDATA( 2 ), 1, ZERO,
$ ZERO, OPCNT, NDATA( 2 ) )
CALL DLASET( 'Full', NDATA( 2 ), 1, ZERO,
$ ZERO, TIMNG, NDATA( 2 ) )
60 CONTINUE
CALL DLACPY( 'Full', M, N, COPYA, LDA, A,
$ LDA )
CALL DLACPY( 'Full', M, NRHS, COPYB, LDB, B,
$ LDB )
SRNAMT = 'DGELSX'
NCALL = NCALL + 1
S1 = DSECND( )
CALL DGELSX( M, N, NRHS, A, LDA, B, LDB,
$ IWORK, RCOND, CRANK, WORK,
$ INFO )
S2 = DSECND( )
TIME = TIME + ( S2-S1 )
IF( INFO.EQ.0 .AND. TIME.LT.TIMMIN )
$ GO TO 60
TIMNG( 1 ) = TIME
OPCNT( 1 ) = DASUM( NDATA( 2 ), OPCNT, 1 )
CALL DSCAL( NDATA( 2 ), ONE / DBLE( NCALL ),
$ OPCNT, 1 )
CALL DSCAL( NDATA( 2 ), ONE / DBLE( NCALL ),
$ TIMNG, 1 )
CALL DCOPY( NDATA( 2 ), OPCNT, 1,
$ OPCTBL( 1, ITYPE, NCLSX+1, 2 ),
$ 1 )
CALL DCOPY( NDATA( 2 ), TIMNG, 1,
$ TIMTBL( 1, ITYPE, NCLSX+1, 2 ),
$ 1 )
DO 70 I = 1, NDATA( 2 )
FLPTBL( I, ITYPE, NCLSX+1,
$ 2 ) = DMFLOP( OPCNT( I ), TIMNG( I ),
$ INFO )
70 CONTINUE
*
END IF
*
* Loop for timing different block sizes.
*
DO 140 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
CALL XLAENV( 3, NXVAL( INB ) )
*
IF( TIMSUB( 3 ) ) THEN
*
* Time DGELSY
*
* DGELSY: Compute the minimum-norm solution X
* to min( norm( A * X - B ) ) using the
* rank-revealing orthogonal factorization.
*
* Set LWLSY to the adequate value.
*
LWLSY = MAX( 1, MNMIN+2*N+NB*( N+1 ),
$ 2*MNMIN+NB*NRHS )
*
NCALL = 0
TIME = ZERO
CALL DLASET( 'Full', NDATA( 3 ), 1, ZERO,
$ ZERO, OPCNT, NDATA( 3 ) )
CALL DLASET( 'Full', NDATA( 3 ), 1, ZERO,
$ ZERO, TIMNG, NDATA( 3 ) )
80 CONTINUE
CALL DLACPY( 'Full', M, N, COPYA, LDA, A,
$ LDA )
CALL DLACPY( 'Full', M, NRHS, COPYB, LDB,
$ B, LDB )
SRNAMT = 'DGELSY'
NCALL = NCALL + 1
S1 = DSECND( )
CALL DGELSY( M, N, NRHS, A, LDA, B, LDB,
$ IWORK, RCOND, CRANK, WORK,
$ LWLSY, INFO )
S2 = DSECND( )
TIME = TIME + ( S2-S1 )
IF( INFO.EQ.0 .AND. TIME.LT.TIMMIN )
$ GO TO 80
TIMNG( 1 ) = TIME
OPCNT( 1 ) = DASUM( NDATA( 3 ), OPCNT, 1 )
CALL DSCAL( NDATA( 3 ),
$ ONE / DBLE( NCALL ), OPCNT,
$ 1 )
CALL DSCAL( NDATA( 3 ),
$ ONE / DBLE( NCALL ), TIMNG,
$ 1 )
CALL DCOPY( NDATA( 3 ), OPCNT, 1,
$ OPCTBL( 1, ITYPE, NCLSY+INB,
$ 3 ), 1 )
CALL DCOPY( NDATA( 3 ), TIMNG, 1,
$ TIMTBL( 1, ITYPE, NCLSY+INB,
$ 3 ), 1 )
DO 90 I = 1, NDATA( 3 )
FLPTBL( I, ITYPE, NCLSY+INB,
$ 3 ) = DMFLOP( OPCNT( I ),
$ TIMNG( I ), INFO )
90 CONTINUE
*
END IF
*
IF( TIMSUB( 4 ) ) THEN
*
* Time DGELSS
*
* DGELSS: Compute the minimum-norm solution X
* to min( norm( A * X - B ) ) using the SVD.
*
NCALL = 0
TIME = ZERO
CALL DLASET( 'Full', NDATA( 4 ), 1, ZERO,
$ ZERO, OPCNT, NDATA( 4 ) )
CALL DLASET( 'Full', NDATA( 4 ), 1, ZERO,
$ ZERO, TIMNG, NDATA( 4 ) )
100 CONTINUE
CALL DLACPY( 'Full', M, N, COPYA, LDA, A,
$ LDA )
CALL DLACPY( 'Full', M, NRHS, COPYB, LDB,
$ B, LDB )
SRNAMT = 'DGELSS'
NCALL = NCALL + 1
S1 = DSECND( )
CALL DGELSS( M, N, NRHS, A, LDA, B, LDB,
$ S, RCOND, CRANK, WORK, LWORK,
$ INFO )
S2 = DSECND( )
TIME = TIME + ( S2-S1 )
IF( INFO.EQ.0 .AND. TIME.LT.TIMMIN )
$ GO TO 100
TIMNG( 1 ) = TIME
OPCNT( 1 ) = DASUM( NDATA( 4 ), OPCNT, 1 )
CALL DSCAL( NDATA( 4 ),
$ ONE / DBLE( NCALL ), OPCNT,
$ 1 )
CALL DSCAL( NDATA( 4 ),
$ ONE / DBLE( NCALL ), TIMNG,
$ 1 )
CALL DCOPY( NDATA( 4 ), OPCNT, 1,
$ OPCTBL( 1, ITYPE, NCLSS+INB,
$ 4 ), 1 )
CALL DCOPY( NDATA( 4 ), TIMNG, 1,
$ TIMTBL( 1, ITYPE, NCLSS+INB,
$ 4 ), 1 )
DO 110 I = 1, NDATA( 4 )
FLPTBL( I, ITYPE, NCLSS+INB,
$ 4 ) = DMFLOP( OPCNT( I ),
$ TIMNG( I ), INFO )
110 CONTINUE
*
END IF
*
IF( TIMSUB( 5 ) ) THEN
*
* Time DGELSD
*
* DGELSD: Compute the minimum-norm solution X
* to min( norm( A * X - B ) ) using a
* divide-and-conquer SVD.
*
NCALL = 0
TIME = ZERO
CALL DLASET( 'Full', NDATA( 5 ), 1, ZERO,
$ ZERO, OPCNT, NDATA( 5 ) )
CALL DLASET( 'Full', NDATA( 5 ), 1, ZERO,
$ ZERO, TIMNG, NDATA( 5 ) )
120 CONTINUE
CALL DLACPY( 'Full', M, N, COPYA, LDA, A,
$ LDA )
CALL DLACPY( 'Full', M, NRHS, COPYB, LDB,
$ B, LDB )
SRNAMT = 'DGELSD'
NCALL = NCALL + 1
S1 = DSECND( )
CALL DGELSD( M, N, NRHS, A, LDA, B, LDB,
$ S, RCOND, CRANK, WORK, LWORK,
$ IWORK, INFO )
S2 = DSECND( )
TIME = TIME + ( S2-S1 )
IF( INFO.EQ.0 .AND. TIME.LT.TIMMIN )
$ GO TO 120
TIMNG( 1 ) = TIME
OPCNT( 1 ) = DASUM( NDATA( 5 ), OPCNT, 1 )
CALL DSCAL( NDATA( 5 ),
$ ONE / DBLE( NCALL ), OPCNT,
$ 1 )
CALL DSCAL( NDATA( 5 ),
$ ONE / DBLE( NCALL ), TIMNG,
$ 1 )
CALL DCOPY( NDATA( 5 ), OPCNT, 1,
$ OPCTBL( 1, ITYPE, NCLSD+INB,
$ 5 ), 1 )
CALL DCOPY( NDATA( 5 ), TIMNG, 1,
$ TIMTBL( 1, ITYPE, NCLSD+INB,
$ 5 ), 1 )
DO 130 I = 1, NDATA( 5 )
FLPTBL( I, ITYPE, NCLSD+INB,
$ 5 ) = DMFLOP( OPCNT( I ),
$ TIMNG( I ), INFO )
130 CONTINUE
*
END IF
*
140 CONTINUE
150 CONTINUE
160 CONTINUE
NCLS = NCLS + NNB
NCLSY = NCLSY + NNB
NCLSS = NCLSS + NNB
NCLSD = NCLSD + NNB
170 CONTINUE
NCLSX = NCLSX + 1
180 CONTINUE
190 CONTINUE
200 CONTINUE
*
* Print a summary of the results.
*
DO 220 ISUB = 1, NSUBS
IF( TIMSUB( ISUB ) ) THEN
WRITE( NOUT, FMT = 9999 )SUBNAM( ISUB )
IF( ISUB.EQ.1 ) THEN
WRITE( NOUT, FMT = 9998 )
ELSE IF( ISUB.EQ.2 ) THEN
WRITE( NOUT, FMT = 9997 )
ELSE IF( ISUB.EQ.3 ) THEN
WRITE( NOUT, FMT = 9996 )
ELSE IF( ISUB.EQ.4 ) THEN
WRITE( NOUT, FMT = 9995 )
ELSE IF( ISUB.EQ.5 ) THEN
WRITE( NOUT, FMT = 9994 )
END IF
DO 210 ITBL = 1, 3
IF( ITBL.EQ.1 ) THEN
WRITE( NOUT, FMT = 9993 )
CALL DPRTLS( ISUB, SUBNAM( ISUB ), NDATA( ISUB ), NM,
$ MVAL, NN, NVAL, NNS, NSVAL, NNB, NBVAL,
$ NXVAL, NLDA, LDAVAL, MTYPE,
$ TIMTBL( 1, 1, 1, ISUB ), NOUT )
ELSE IF( ITBL.EQ.2 ) THEN
WRITE( NOUT, FMT = 9992 )
CALL DPRTLS( ISUB, SUBNAM( ISUB ), NDATA( ISUB ), NM,
$ MVAL, NN, NVAL, NNS, NSVAL, NNB, NBVAL,
$ NXVAL, NLDA, LDAVAL, MTYPE,
$ OPCTBL( 1, 1, 1, ISUB ), NOUT )
ELSE IF( ITBL.EQ.3 ) THEN
WRITE( NOUT, FMT = 9991 )
CALL DPRTLS( ISUB, SUBNAM( ISUB ), NDATA( ISUB ), NM,
$ MVAL, NN, NVAL, NNS, NSVAL, NNB, NBVAL,
$ NXVAL, NLDA, LDAVAL, MTYPE,
$ FLPTBL( 1, 1, 1, ISUB ), NOUT )
END IF
210 CONTINUE
END IF
220 CONTINUE
*
230 CONTINUE
9999 FORMAT( / / / ' ****** Results for ', A, ' ******' )
9998 FORMAT( / ' DGELS : overall performance',
$ / ' comp. 1 : if M>=N, DGEQRF, QR factorization',
$ / ' if M< N, DGELQF, QR factorization',
$ / ' comp. 2 : if M>=N, DORMQR, multiplication by',
$ ' reflectors', /
$ ' if M< N, DORMLQ, multiplication by',
$ ' reflectors', /
$ ' comp. 3 : DTRSM, solution of the triangular', ' system',
$ / / ' Types 4 to 6 are the transpose', ' of types 1 to 3' )
9997 FORMAT( / ' DGELSX : overall performance',
$ / ' comp. 1 : DGEQPF, QR factorization with column',
$ ' pivoting', / ' comp. 2 : if RANK>N, DGEQRF, QR factorization',
$ / ' DORMQR, multiplication by',
$ ' reflectors', /
$ ' if N>>M, DGELQF, QL factorization',
$ / ' comp. 2 : DGEBRD, reduction to bidiagonal form',
$ / ' comp. 3 : DORMBR, multiplication by left',
$ ' bidiagonalizing vectors', /
$ ' DORGBR, generation of right',
$ ' bidiagonalizing vectors', /
$ ' comp. 4 : DBDSQR, singular value decomposition',
$ ' of the bidiagonal matrix',
$ / ' comp. 5 : multiplication by right bidiagonalizing',
$ ' vectors', /
$ ' (DGEMM or SGEMV, and DORMLQ if N>>M)' )
9994 FORMAT( / ' DGELSD: overall performance',
$ / ' comp. 1 : if M>>N, DGEQRF, QR factorization',
$ / ' DORMQR, multiplication by',
$ ' reflectors', /
$ ' if N>>M, DGELQF, QL factorization',
$ / ' comp. 2 : DGEBRD, reduction to bidiagonal form',
$ / ' comp. 3 : DORMBR, multiplication by left ',
$ ' bidiagonalizing vectors', /
$ ' multiplication by right',
$ ' bidiagonalizing vectors', /
$ ' comp. 4 : DLALSD, singular value decomposition',
$ ' of the bidiagonal matrix' )
9993 FORMAT( / / ' *** Time in seconds *** ' )
9992 FORMAT( / / ' *** Number of floating-point operations *** ' )
9991 FORMAT( / / ' *** Speed in megaflops *** ' )
RETURN
*
* End of DTIMLS
*
END
SUBROUTINE DTIMMG( IFLAG, M, N, A, LDA, KL, KU )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
INTEGER IFLAG, KL, KU, LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
* ..
*
* Purpose
* =======
*
* DTIMMG generates a real test matrix whose type is given by IFLAG.
* All the matrices are Toeplitz (constant along a diagonal), with
* random elements on each diagonal.
*
* Arguments
* =========
*
* IFLAG (input) INTEGER
* The type of matrix to be generated.
* = 0 or 1: General matrix
* = 2 or -2: General banded matrix
* = 3 or -3: Symmetric positive definite matrix
* = 4 or -4: Symmetric positive definite packed
* = 5 or -5: Symmetric positive definite banded
* = 6 or -6: Symmetric indefinite matrix
* = 7 or -7: Symmetric indefinite packed
* = 8 or -8: Symmetric indefinite banded
* = 9 or -9: Triangular
* = 10 or -10: Triangular packed
* = 11 or -11: Triangular banded
* = 12: General tridiagonal
* = 13 or -13: Positive definite tridiagonal
* For symmetric or triangular matrices, IFLAG > 0 indicates
* upper triangular storage and IFLAG < 0 indicates lower
* triangular storage.
*
* M (input) INTEGER
* The number of rows of the matrix to be generated.
*
* N (input) INTEGER
* The number of columns of the matrix to be generated.
*
* A (output) DOUBLE PRECISION array, dimension (LDA,N)
* The generated matrix.
*
* If the absolute value of IFLAG is 1, 3, or 6, the leading
* M x N (or N x N) subblock is used to store the matrix.
* If the matrix is symmetric, only the upper or lower triangle
* of this block is referenced.
*
* If the absolute value of IFLAG is 4 or 7, the matrix is
* symmetric and packed storage is used for the upper or lower
* triangle. The triangular matrix is stored columnwise as a
* inear array, and the array A is treated as a vector of
* length LDA. LDA must be set to at least N*(N+1)/2.
*
* If the absolute value of IFLAG is 2 or 5, the matrix is
* returned in band format. The columns of the matrix are
* specified in the columns of A and the diagonals of the
* matrix are specified in the rows of A, with the leading
* diagonal in row
* KL + KU + 1, if IFLAG = 2
* KU + 1, if IFLAG = 5 or -2
* 1, if IFLAG = -5
* If IFLAG = 2, the first KL rows are not used to leave room
* for pivoting in DGBTRF.
*
* LDA (input) INTEGER
* The leading dimension of A. If the generated matrix is
* packed, LDA >= N*(N+1)/2, otherwise LDA >= max(1,M).
*
* KL (input) INTEGER
* The number of subdiagonals if IFLAG = 2, 5, or -5.
*
* KU (input) INTEGER
* The number of superdiagonals if IFLAG = 2, 5, or -5.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J, JJ, JN, K, MJ, MU
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 )
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MIN, SIGN
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLARNV
* ..
* .. Data statements ..
DATA ISEED / 0, 0, 0, 1 /
* ..
* .. Executable Statements ..
*
IF( M.LE.0 .OR. N.LE.0 ) THEN
RETURN
*
ELSE IF( IFLAG.EQ.0 .OR. IFLAG.EQ.1 ) THEN
*
* General matrix
*
* Set first column and row to random values.
*
CALL DLARNV( 2, ISEED, M, A( 1, 1 ) )
DO 10 J = 2, N, M
MJ = MIN( M, N-J+1 )
CALL DLARNV( 2, ISEED, MJ, A( 1, J ) )
IF( MJ.GT.1 )
$ CALL DCOPY( MJ-1, A( 2, J ), 1, A( 1, J+1 ), LDA )
10 CONTINUE
*
* Fill in the rest of the matrix.
*
DO 30 J = 2, N
DO 20 I = 2, M
A( I, J ) = A( I-1, J-1 )
20 CONTINUE
30 CONTINUE
*
ELSE IF( IFLAG.EQ.2 .OR. IFLAG.EQ.-2 ) THEN
*
* General band matrix
*
IF( IFLAG.EQ.2 ) THEN
K = KL + KU + 1
ELSE
K = KU + 1
END IF
CALL DLARNV( 2, ISEED, MIN( M, KL+1 ), A( K, 1 ) )
MU = MIN( N-1, KU )
CALL DLARNV( 2, ISEED, MU+1, A( K-MU, N ) )
DO 40 J = 2, N - 1
MU = MIN( J-1, KU )
CALL DCOPY( MU, A( K-MU, N ), 1, A( K-MU, J ), 1 )
CALL DCOPY( MIN( M-J+1, KL+1 ), A( K, 1 ), 1, A( K, J ), 1 )
40 CONTINUE
*
ELSE IF( IFLAG.EQ.3 ) THEN
*
* Symmetric positive definite, upper triangle
*
CALL DLARNV( 2, ISEED, N-1, A( 1, N ) )
A( N, N ) = DBLE( N )
DO 50 J = N - 1, 1, -1
CALL DCOPY( J, A( N-J+1, N ), 1, A( 1, J ), 1 )
50 CONTINUE
*
ELSE IF( IFLAG.EQ.-3 ) THEN
*
* Symmetric positive definite, lower triangle
*
A( 1, 1 ) = DBLE( N )
IF( N.GT.1 )
$ CALL DLARNV( 2, ISEED, N-1, A( 2, 1 ) )
DO 60 J = 2, N
CALL DCOPY( N-J+1, A( 1, 1 ), 1, A( J, J ), 1 )
60 CONTINUE
*
ELSE IF( IFLAG.EQ.4 ) THEN
*
* Symmetric positive definite packed, upper triangle
*
JN = ( N-1 )*N / 2 + 1
CALL DLARNV( 2, ISEED, N-1, A( JN, 1 ) )
A( JN+N-1, 1 ) = DBLE( N )
JJ = JN
DO 70 J = N - 1, 1, -1
JJ = JJ - J
JN = JN + 1
CALL DCOPY( J, A( JN, 1 ), 1, A( JJ, 1 ), 1 )
70 CONTINUE
*
ELSE IF( IFLAG.EQ.-4 ) THEN
*
* Symmetric positive definite packed, lower triangle
*
A( 1, 1 ) = DBLE( N )
IF( N.GT.1 )
$ CALL DLARNV( 2, ISEED, N-1, A( 2, 1 ) )
JJ = N + 1
DO 80 J = 2, N
CALL DCOPY( N-J+1, A( 1, 1 ), 1, A( JJ, 1 ), 1 )
JJ = JJ + N - J + 1
80 CONTINUE
*
ELSE IF( IFLAG.EQ.5 ) THEN
*
* Symmetric positive definite banded, upper triangle
*
K = KL
MU = MIN( N-1, K )
CALL DLARNV( 2, ISEED, MU, A( K+1-MU, N ) )
A( K+1, N ) = DBLE( N )
DO 90 J = N - 1, 1, -1
MU = MIN( J, K+1 )
CALL DCOPY( MU, A( K+2-MU, N ), 1, A( K+2-MU, J ), 1 )
90 CONTINUE
*
ELSE IF( IFLAG.EQ.-5 ) THEN
*
* Symmetric positive definite banded, lower triangle
*
K = KL
A( 1, 1 ) = DBLE( N )
CALL DLARNV( 2, ISEED, MIN( N-1, K ), A( 2, 1 ) )
DO 100 J = 2, N
CALL DCOPY( MIN( N-J+1, K+1 ), A( 1, 1 ), 1, A( 1, J ), 1 )
100 CONTINUE
*
ELSE IF( IFLAG.EQ.6 ) THEN
*
* Symmetric indefinite, upper triangle
*
CALL DLARNV( 2, ISEED, N, A( 1, N ) )
DO 110 J = N - 1, 1, -1
CALL DCOPY( J, A( N-J+1, N ), 1, A( 1, J ), 1 )
110 CONTINUE
*
ELSE IF( IFLAG.EQ.-6 ) THEN
*
* Symmetric indefinite, lower triangle
*
CALL DLARNV( 2, ISEED, N, A( 1, 1 ) )
DO 120 J = 2, N
CALL DCOPY( N-J+1, A( 1, 1 ), 1, A( J, J ), 1 )
120 CONTINUE
*
ELSE IF( IFLAG.EQ.7 ) THEN
*
* Symmetric indefinite packed, upper triangle
*
JN = ( N-1 )*N / 2 + 1
CALL DLARNV( 2, ISEED, N, A( JN, 1 ) )
JJ = JN
DO 130 J = N - 1, 1, -1
JJ = JJ - J
JN = JN + 1
CALL DCOPY( J, A( JN, 1 ), 1, A( JJ, 1 ), 1 )
130 CONTINUE
*
ELSE IF( IFLAG.EQ.-7 ) THEN
*
* Symmetric indefinite packed, lower triangle
*
CALL DLARNV( 2, ISEED, N, A( 1, 1 ) )
JJ = N + 1
DO 140 J = 2, N
CALL DCOPY( N-J+1, A( 1, 1 ), 1, A( JJ, 1 ), 1 )
JJ = JJ + N - J + 1
140 CONTINUE
*
ELSE IF( IFLAG.EQ.8 ) THEN
*
* Symmetric indefinite banded, upper triangle
*
K = KL
MU = MIN( N, K+1 )
CALL DLARNV( 2, ISEED, MU, A( K+2-MU, N ) )
DO 150 J = N - 1, 1, -1
MU = MIN( J, K+1 )
CALL DCOPY( MU, A( K+2-MU, N ), 1, A( K+2-MU, J ), 1 )
150 CONTINUE
*
ELSE IF( IFLAG.EQ.-8 ) THEN
*
* Symmetric indefinite banded, lower triangle
*
K = KL
CALL DLARNV( 2, ISEED, MIN( N, K+1 ), A( 1, 1 ) )
DO 160 J = 2, N
CALL DCOPY( MIN( N-J+1, K+1 ), A( 1, 1 ), 1, A( 1, J ), 1 )
160 CONTINUE
*
ELSE IF( IFLAG.EQ.9 ) THEN
*
* Upper triangular
*
CALL DLARNV( 2, ISEED, N, A( 1, N ) )
A( N, N ) = SIGN( DBLE( N ), A( N, N ) )
DO 170 J = N - 1, 1, -1
CALL DCOPY( J, A( N-J+1, N ), 1, A( 1, J ), 1 )
170 CONTINUE
*
ELSE IF( IFLAG.EQ.-9 ) THEN
*
* Lower triangular
*
CALL DLARNV( 2, ISEED, N, A( 1, 1 ) )
A( 1, 1 ) = SIGN( DBLE( N ), A( 1, 1 ) )
DO 180 J = 2, N
CALL DCOPY( N-J+1, A( 1, 1 ), 1, A( J, J ), 1 )
180 CONTINUE
*
ELSE IF( IFLAG.EQ.10 ) THEN
*
* Upper triangular packed
*
JN = ( N-1 )*N / 2 + 1
CALL DLARNV( 2, ISEED, N, A( JN, 1 ) )
A( JN+N-1, 1 ) = SIGN( DBLE( N ), A( JN+N-1, 1 ) )
JJ = JN
DO 190 J = N - 1, 1, -1
JJ = JJ - J
JN = JN + 1
CALL DCOPY( J, A( JN, 1 ), 1, A( JJ, 1 ), 1 )
190 CONTINUE
*
ELSE IF( IFLAG.EQ.-10 ) THEN
*
* Lower triangular packed
*
CALL DLARNV( 2, ISEED, N, A( 1, 1 ) )
A( 1, 1 ) = SIGN( DBLE( N ), A( 1, 1 ) )
JJ = N + 1
DO 200 J = 2, N
CALL DCOPY( N-J+1, A( 1, 1 ), 1, A( JJ, 1 ), 1 )
JJ = JJ + N - J + 1
200 CONTINUE
*
ELSE IF( IFLAG.EQ.11 ) THEN
*
* Upper triangular banded
*
K = KL
MU = MIN( N, K+1 )
CALL DLARNV( 2, ISEED, MU, A( K+2-MU, N ) )
A( K+1, N ) = SIGN( DBLE( K+1 ), A( K+1, N ) )
DO 210 J = N - 1, 1, -1
MU = MIN( J, K+1 )
CALL DCOPY( MU, A( K+2-MU, N ), 1, A( K+2-MU, J ), 1 )
210 CONTINUE
*
ELSE IF( IFLAG.EQ.-11 ) THEN
*
* Lower triangular banded
*
K = KL
CALL DLARNV( 2, ISEED, MIN( N, K+1 ), A( 1, 1 ) )
A( 1, 1 ) = SIGN( DBLE( K+1 ), A( 1, 1 ) )
DO 220 J = 2, N
CALL DCOPY( MIN( N-J+1, K+1 ), A( 1, 1 ), 1, A( 1, J ), 1 )
220 CONTINUE
*
ELSE IF( IFLAG.EQ.12 ) THEN
*
* General tridiagonal
*
CALL DLARNV( 2, ISEED, 3*N-2, A )
*
ELSE IF( IFLAG.EQ.13 .OR. IFLAG.EQ.-13 ) THEN
*
* Positive definite tridiagonal
*
DO 230 J = 1, N
A( J, 1 ) = 2.0D0
230 CONTINUE
CALL DLARNV( 2, ISEED, N-1, A( N+1, 1 ) )
END IF
*
RETURN
*
* End of DTIMMG
*
END
SUBROUTINE DTIMMM( VNAME, LAB2, NN, NVAL, NLDA, LDAVAL, TIMMIN, A,
$ B, C, RESLTS, LDR1, LDR2, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*( * ) LAB2, VNAME
INTEGER LDR1, LDR2, NLDA, NN, NOUT
DOUBLE PRECISION TIMMIN
* ..
* .. Array Arguments ..
INTEGER LDAVAL( * ), NVAL( * )
DOUBLE PRECISION A( * ), B( * ), C( * ), RESLTS( LDR1, LDR2, * )
* ..
*
* Purpose
* =======
*
* DTIMMM times DGEMM.
*
* Arguments
* =========
*
* VNAME (input) CHARACTER*(*)
* The name of the Level 3 BLAS routine to be timed.
*
* LAB2 (input) CHARACTER*(*)
* The name of the variable given in NVAL.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) DOUBLE PRECISION
* The minimum time a subroutine will be timed.
*
* A (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values permitted
* for LDA and N.
*
* B (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
*
* C (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
*
* RESLTS (output) DOUBLE PRECISION array, dimension (LDR1,LDR2,NLDA)
* The timing results for each subroutine over the relevant
* values of N and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= 1.
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NN).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
DOUBLE PRECISION ONE
PARAMETER ( NSUBS = 1, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
CHARACTER*6 CNAME
INTEGER I, IC, ICL, ILDA, IN, INFO, ISUB, LDA, N
DOUBLE PRECISION OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER IDUMMY( 1 )
* ..
* .. External Functions ..
LOGICAL LSAMEN
DOUBLE PRECISION DMFLOP, DOPBL3, DSECND
EXTERNAL LSAMEN, DMFLOP, DOPBL3, DSECND
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, DGEMM, DPRTBL, DTIMMG
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Data statements ..
DATA SUBNAM / 'DGEMM ' /
* ..
* .. Executable Statements ..
*
CNAME = VNAME
DO 10 ISUB = 1, NSUBS
TIMSUB( ISUB ) = LSAMEN( 6, CNAME, SUBNAM( ISUB ) )
IF( TIMSUB( ISUB ) )
$ GO TO 20
10 CONTINUE
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 80
20 CONTINUE
*
* Check that N <= LDA for the input values.
*
CALL ATIMCK( 2, CNAME, NN, NVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9998 )CNAME
GO TO 80
END IF
*
DO 60 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 50 IN = 1, NN
N = NVAL( IN )
*
* Time DGEMM
*
CALL DTIMMG( 1, N, N, A, LDA, 0, 0 )
CALL DTIMMG( 0, N, N, B, LDA, 0, 0 )
CALL DTIMMG( 1, N, N, C, LDA, 0, 0 )
IC = 0
S1 = DSECND( )
30 CONTINUE
CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, A,
$ LDA, B, LDA, ONE, C, LDA )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 1, N, N, C, LDA, 0, 0 )
GO TO 30
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
40 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 1, N, N, C, LDA, 0, 0 )
GO TO 40
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPBL3( 'DGEMM ', N, N, N )
RESLTS( 1, IN, ILDA ) = DMFLOP( OPS, TIME, 0 )
50 CONTINUE
60 CONTINUE
*
* Print the table of results on unit NOUT.
*
WRITE( NOUT, FMT = 9997 )VNAME
IF( NLDA.EQ.1 ) THEN
WRITE( NOUT, FMT = 9996 )LDAVAL( 1 )
ELSE
DO 70 I = 1, NLDA
WRITE( NOUT, FMT = 9995 )I, LDAVAL( I )
70 CONTINUE
END IF
WRITE( NOUT, FMT = * )
CALL DPRTBL( ' ', LAB2, 1, IDUMMY, NN, NVAL, NLDA, RESLTS, LDR1,
$ LDR2, NOUT )
*
80 CONTINUE
RETURN
9999 FORMAT( 1X, A6, ': Unrecognized path or subroutine name', / )
9998 FORMAT( 1X, A6, ' timing run not attempted', / )
9997 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9996 FORMAT( 5X, 'with LDA = ', I5 )
9995 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
*
* End of DTIMMM
*
END
SUBROUTINE DTIMMV( VNAME, NN, NVAL, NK, KVAL, NLDA, LDAVAL,
$ TIMMIN, A, LB, B, C, RESLTS, LDR1, LDR2, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*( * ) VNAME
INTEGER LB, LDR1, LDR2, NK, NLDA, NN, NOUT
DOUBLE PRECISION TIMMIN
* ..
* .. Array Arguments ..
INTEGER KVAL( * ), LDAVAL( * ), NVAL( * )
DOUBLE PRECISION A( * ), B( * ), C( * ), RESLTS( LDR1, LDR2, * )
* ..
*
* Purpose
* =======
*
* DTIMMV times individual BLAS 2 routines.
*
* Arguments
* =========
*
* VNAME (input) CHARACTER*(*)
* The name of the Level 2 BLAS routine to be timed.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* NK (input) INTEGER
* The number of values of K contained in the vector KVAL.
*
* KVAL (input) INTEGER array, dimension (NK)
* The values of the bandwidth K.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) DOUBLE PRECISION
* The minimum time a subroutine will be timed.
*
* A (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values permitted
* for LDA and N.
*
* LB (input) INTEGER
* The length of B and C, needed when timing DGBMV. If timing
* DGEMV, LB >= LDAMAX*NMAX.
*
* B (workspace) DOUBLE PRECISION array, dimension (LB)
*
* C (workspace) DOUBLE PRECISION array, dimension (LB)
*
* RESLTS (output) DOUBLE PRECISION array, dimension (LDR1,LDR2,NLDA)
* The timing results for each subroutine over the relevant
* values of N and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NK).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NN).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
DOUBLE PRECISION ONE
PARAMETER ( NSUBS = 2, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
CHARACTER LAB1, LAB2
CHARACTER*6 CNAME
INTEGER I, IB, IC, ICL, IK, ILDA, IN, INFO, ISUB, K,
$ KL, KU, LDA, LDB, N, NRHS
DOUBLE PRECISION OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER*6 SUBNAM( NSUBS )
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
DOUBLE PRECISION DMFLOP, DOPBL2, DSECND
EXTERNAL LSAME, LSAMEN, DMFLOP, DOPBL2, DSECND
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, DGBMV, DGEMV, DPRTBL, DTIMMG
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Data statements ..
DATA SUBNAM / 'DGEMV ', 'DGBMV ' /
* ..
* .. Executable Statements ..
*
CNAME = VNAME
DO 10 ISUB = 1, NSUBS
TIMSUB( ISUB ) = LSAMEN( 6, CNAME, SUBNAM( ISUB ) )
IF( TIMSUB( ISUB ) )
$ GO TO 20
10 CONTINUE
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 150
20 CONTINUE
*
* Check that N or K <= LDA for the input values.
*
IF( LSAME( CNAME( 3: 3 ), 'B' ) ) THEN
CALL ATIMCK( 0, CNAME, NK, KVAL, NLDA, LDAVAL, NOUT, INFO )
LAB1 = 'M'
LAB2 = 'K'
ELSE
CALL ATIMCK( 2, CNAME, NN, NVAL, NLDA, LDAVAL, NOUT, INFO )
LAB1 = ' '
LAB2 = 'N'
END IF
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9998 )CNAME
GO TO 150
END IF
*
* Print the table header on unit NOUT.
*
WRITE( NOUT, FMT = 9997 )VNAME
IF( NLDA.EQ.1 ) THEN
WRITE( NOUT, FMT = 9996 )LDAVAL( 1 )
ELSE
DO 30 I = 1, NLDA
WRITE( NOUT, FMT = 9995 )I, LDAVAL( I )
30 CONTINUE
END IF
WRITE( NOUT, FMT = * )
*
* Time DGEMV
*
IF( TIMSUB( 1 ) ) THEN
DO 80 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 70 IN = 1, NN
N = NVAL( IN )
NRHS = N
LDB = LDA
CALL DTIMMG( 1, N, N, A, LDA, 0, 0 )
CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 )
CALL DTIMMG( 1, N, NRHS, C, LDB, 0, 0 )
IC = 0
S1 = DSECND( )
40 CONTINUE
IB = 1
DO 50 I = 1, NRHS
CALL DGEMV( 'No transpose', N, N, ONE, A, LDA,
$ B( IB ), 1, ONE, C( IB ), 1 )
IB = IB + LDB
50 CONTINUE
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 1, N, NRHS, C, LDB, 0, 0 )
GO TO 40
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
60 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 1, N, NRHS, C, LDB, 0, 0 )
GO TO 60
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = NRHS*DOPBL2( 'DGEMV ', N, N, 0, 0 )
RESLTS( 1, IN, ILDA ) = DMFLOP( OPS, TIME, 0 )
70 CONTINUE
80 CONTINUE
*
CALL DPRTBL( LAB1, LAB2, 1, NVAL, NN, NVAL, NLDA, RESLTS, LDR1,
$ LDR2, NOUT )
*
ELSE IF( TIMSUB( 2 ) ) THEN
*
* Time DGBMV
*
DO 140 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 130 IN = 1, NN
N = NVAL( IN )
DO 120 IK = 1, NK
K = MIN( N-1, MAX( 0, KVAL( IK ) ) )
KL = K
KU = K
LDB = N
CALL DTIMMG( 2, N, N, A, LDA, KL, KU )
NRHS = MIN( K, LB / LDB )
CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 )
CALL DTIMMG( 1, N, NRHS, C, LDB, 0, 0 )
IC = 0
S1 = DSECND( )
90 CONTINUE
IB = 1
DO 100 I = 1, NRHS
CALL DGBMV( 'No transpose', N, N, KL, KU, ONE,
$ A( KU+1 ), LDA, B( IB ), 1, ONE,
$ C( IB ), 1 )
IB = IB + LDB
100 CONTINUE
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 1, N, NRHS, C, LDB, 0, 0 )
GO TO 90
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
110 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 1, N, NRHS, C, LDB, 0, 0 )
GO TO 110
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = NRHS*DOPBL2( 'DGBMV ', N, N, KL, KU )
RESLTS( IN, IK, ILDA ) = DMFLOP( OPS, TIME, 0 )
120 CONTINUE
130 CONTINUE
140 CONTINUE
*
CALL DPRTBL( LAB1, LAB2, NN, NVAL, NK, KVAL, NLDA, RESLTS,
$ LDR1, LDR2, NOUT )
END IF
*
150 CONTINUE
9999 FORMAT( 1X, A6, ': Unrecognized path or subroutine name', / )
9998 FORMAT( 1X, A6, ' timing run not attempted', / )
9997 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9996 FORMAT( 5X, 'with LDA = ', I5 )
9995 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
RETURN
*
* End of DTIMMV
*
END
SUBROUTINE DTIMPB( LINE, NN, NVAL, NK, KVAL, NNS, NSVAL, NNB,
$ NBVAL, NLDA, LDAVAL, TIMMIN, A, B, IWORK,
$ RESLTS, LDR1, LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NK, NLDA, NN, NNB, NNS, NOUT
DOUBLE PRECISION TIMMIN
* ..
* .. Array Arguments ..
INTEGER IWORK( * ), KVAL( * ), LDAVAL( * ), NBVAL( * ),
$ NSVAL( * ), NVAL( * )
DOUBLE PRECISION A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * )
* ..
*
* Purpose
* =======
*
* DTIMPB times DPBTRF and -TRS.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix size N.
*
* NK (input) INTEGER
* The number of values of K contained in the vector KVAL.
*
* KVAL (input) INTEGER array, dimension (NK)
* The values of the band width K.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* NNB (input) INTEGER
* The number of values of NB contained in the vector NBVAL.
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) DOUBLE PRECISION
* The minimum time a subroutine will be timed.
*
* A (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values permitted
* for LDA and N.
*
* B (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* RESLTS (output) DOUBLE PRECISION array, dimension
* (LDR1,LDR2,LDR3,NSUBS)
* The timing results for each subroutine over the relevant
* values of N, K, NB, and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(4,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NK).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,2*NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 2 )
* ..
* .. Local Scalars ..
CHARACTER UPLO
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, I3, IC, ICL, IK, ILDA, IN, INB, INFO, ISUB,
$ IUPLO, K, LDA, LDB, MAT, N, NB, NRHS
DOUBLE PRECISION OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER UPLOS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DMFLOP, DOPLA, DSECND
EXTERNAL LSAME, DMFLOP, DOPLA, DSECND
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, DPBTRF, DPBTRS, DPRTBL, DTIMMG,
$ XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Data statements ..
DATA UPLOS / 'U', 'L' /
DATA SUBNAM / 'DPBTRF', 'DPBTRS' /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'PB'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 140
*
* Check that K+1 <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 0, CNAME, NK, KVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 140
END IF
*
* Do for each value of the matrix size N:
*
DO 130 IN = 1, NN
N = NVAL( IN )
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 90 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
IF( LSAME( UPLO, 'U' ) ) THEN
MAT = 5
ELSE
MAT = -5
END IF
*
* Do for each value of LDA:
*
DO 80 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
I3 = ( IUPLO-1 )*NLDA + ILDA
*
* Do for each value of the band width K:
*
DO 70 IK = 1, NK
K = KVAL( IK )
K = MAX( 0, MIN( K, N-1 ) )
*
* Time DPBTRF
*
IF( TIMSUB( 1 ) ) THEN
*
* Do for each value of NB in NBVAL. Only DPBTRF is
* timed in this loop since the other routines are
* independent of NB.
*
DO 30 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
CALL DTIMMG( MAT, N, N, A, LDA, K, K )
IC = 0
S1 = DSECND( )
10 CONTINUE
CALL DPBTRF( UPLO, N, K, A, LDA, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( MAT, N, N, A, LDA, K, K )
GO TO 10
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
20 CONTINUE
CALL DTIMMG( MAT, N, N, A, LDA, K, K )
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC )
$ GO TO 20
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DPBTRF', N, N, K, K, NB )
RESLTS( INB, IK, I3, 1 ) = DMFLOP( OPS, TIME,
$ INFO )
30 CONTINUE
ELSE
IC = 0
CALL DTIMMG( MAT, N, N, A, LDA, K, K )
END IF
*
* Generate another matrix and factor it using DPBTRF so
* that the factored form can be used in timing the other
* routines.
*
NB = 1
CALL XLAENV( 1, NB )
IF( IC.NE.1 )
$ CALL DPBTRF( UPLO, N, K, A, LDA, INFO )
*
* Time DPBTRS
*
IF( TIMSUB( 2 ) ) THEN
DO 60 I = 1, NNS
NRHS = NSVAL( I )
LDB = N
CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 )
IC = 0
S1 = DSECND( )
40 CONTINUE
CALL DPBTRS( UPLO, N, K, NRHS, A, LDA, B, LDB,
$ INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 40
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
50 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 50
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DPBTRS', N, NRHS, K, K, 0 )
RESLTS( I, IK, I3, 2 ) = DMFLOP( OPS, TIME,
$ INFO )
60 CONTINUE
END IF
70 CONTINUE
80 CONTINUE
90 CONTINUE
*
* Print tables of results for each timed routine.
*
DO 120 ISUB = 1, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 120
*
* Print header for routine names.
*
IF( IN.EQ.1 .OR. CNAME.EQ.'DPB ' ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 100 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
100 CONTINUE
END IF
END IF
WRITE( NOUT, FMT = * )
DO 110 IUPLO = 1, 2
WRITE( NOUT, FMT = 9996 )SUBNAM( ISUB ), N,
$ UPLOS( IUPLO )
I3 = ( IUPLO-1 )*NLDA + 1
IF( ISUB.EQ.1 ) THEN
CALL DPRTBL( 'NB', 'K', NNB, NBVAL, NK, KVAL, NLDA,
$ RESLTS( 1, 1, I3, 1 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.2 ) THEN
CALL DPRTBL( 'NRHS', 'K', NNS, NSVAL, NK, KVAL, NLDA,
$ RESLTS( 1, 1, I3, 2 ), LDR1, LDR2, NOUT )
END IF
110 CONTINUE
120 CONTINUE
130 CONTINUE
*
140 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
9996 FORMAT( 5X, A6, ' with M =', I6, ', UPLO = ''', A1, '''', / )
RETURN
*
* End of DTIMPB
*
END
SUBROUTINE DTIMPO( LINE, NN, NVAL, NNS, NSVAL, NNB, NBVAL, NLDA,
$ LDAVAL, TIMMIN, A, B, IWORK, RESLTS, LDR1,
$ LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NLDA, NN, NNB, NNS, NOUT
DOUBLE PRECISION TIMMIN
* ..
* .. Array Arguments ..
INTEGER IWORK( * ), LDAVAL( * ), NBVAL( * ),
$ NSVAL( * ), NVAL( * )
DOUBLE PRECISION A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * )
* ..
*
* Purpose
* =======
*
* DTIMPO times DPOTRF, -TRS, and -TRI.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix size N.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* NNB (input) INTEGER
* The number of values of NB contained in the vector NBVAL.
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) DOUBLE PRECISION
* The minimum time a subroutine will be timed.
*
* A (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values permitted
* for LDA and N.
*
* B (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* RESLTS (output) DOUBLE PRECISION array, dimension
* (LDR1,LDR2,LDR3,NSUBS)
* The timing results for each subroutine over the relevant
* values of N, NB, and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(4,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NN).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,2*NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 3 )
* ..
* .. Local Scalars ..
CHARACTER UPLO
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, I3, IC, ICL, ILDA, IN, INB, INFO, ISUB,
$ IUPLO, LDA, LDB, MAT, N, NB, NRHS
DOUBLE PRECISION OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER UPLOS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DMFLOP, DOPLA, DSECND
EXTERNAL LSAME, DMFLOP, DOPLA, DSECND
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, DLACPY, DPOTRF, DPOTRI, DPOTRS,
$ DPRTBL, DTIMMG, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Data statements ..
DATA UPLOS / 'U', 'L' /
DATA SUBNAM / 'DPOTRF', 'DPOTRS', 'DPOTRI' /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'PO'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 150
*
* Check that N <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 2, CNAME, NN, NVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 150
END IF
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 110 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
IF( LSAME( UPLO, 'U' ) ) THEN
MAT = 3
ELSE
MAT = -3
END IF
*
* Do for each value of N in NVAL.
*
DO 100 IN = 1, NN
N = NVAL( IN )
*
* Do for each value of LDA:
*
DO 90 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
I3 = ( IUPLO-1 )*NLDA + ILDA
*
* Do for each value of NB in NBVAL. Only the blocked
* routines are timed in this loop since the other routines
* are independent of NB.
*
DO 50 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
*
* Time DPOTRF
*
IF( TIMSUB( 1 ) ) THEN
CALL DTIMMG( MAT, N, N, A, LDA, 0, 0 )
IC = 0
S1 = DSECND( )
10 CONTINUE
CALL DPOTRF( UPLO, N, A, LDA, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( MAT, N, N, A, LDA, 0, 0 )
GO TO 10
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
20 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( MAT, N, N, A, LDA, 0, 0 )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DPOTRF', N, N, 0, 0, NB )
RESLTS( INB, IN, I3, 1 ) = DMFLOP( OPS, TIME,
$ INFO )
*
ELSE
IC = 0
CALL DTIMMG( MAT, N, N, A, LDA, 0, 0 )
END IF
*
* Generate another matrix and factor it using DPOTRF so
* that the factored form can be used in timing the other
* routines.
*
IF( IC.NE.1 )
$ CALL DPOTRF( UPLO, N, A, LDA, INFO )
*
* Time DPOTRI
*
IF( TIMSUB( 3 ) ) THEN
CALL DLACPY( UPLO, N, N, A, LDA, B, LDA )
IC = 0
S1 = DSECND( )
30 CONTINUE
CALL DPOTRI( UPLO, N, B, LDA, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DLACPY( UPLO, N, N, A, LDA, B, LDA )
GO TO 30
END IF
*
* Subtract the time used in DLACPY.
*
ICL = 1
S1 = DSECND( )
40 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DLACPY( UPLO, N, N, A, LDA, B, LDA )
GO TO 40
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DPOTRI', N, N, 0, 0, NB )
RESLTS( INB, IN, I3, 3 ) = DMFLOP( OPS, TIME,
$ INFO )
END IF
50 CONTINUE
*
* Time DPOTRS
*
IF( TIMSUB( 2 ) ) THEN
DO 80 I = 1, NNS
NRHS = NSVAL( I )
LDB = LDA
CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 )
IC = 0
S1 = DSECND( )
60 CONTINUE
CALL DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 60
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
70 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 70
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DPOTRS', N, NRHS, 0, 0, 0 )
RESLTS( I, IN, I3, 2 ) = DMFLOP( OPS, TIME, INFO )
80 CONTINUE
END IF
90 CONTINUE
100 CONTINUE
110 CONTINUE
*
* Print tables of results for each timed routine.
*
DO 140 ISUB = 1, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 140
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 120 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
120 CONTINUE
END IF
WRITE( NOUT, FMT = * )
DO 130 IUPLO = 1, 2
WRITE( NOUT, FMT = 9996 )SUBNAM( ISUB ), UPLOS( IUPLO )
I3 = ( IUPLO-1 )*NLDA + 1
IF( ISUB.EQ.1 ) THEN
CALL DPRTBL( 'NB', 'N', NNB, NBVAL, NN, NVAL, NLDA,
$ RESLTS( 1, 1, I3, 1 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.2 ) THEN
CALL DPRTBL( 'NRHS', 'N', NNS, NSVAL, NN, NVAL, NLDA,
$ RESLTS( 1, 1, I3, 2 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.3 ) THEN
CALL DPRTBL( 'NB', 'N', NNB, NBVAL, NN, NVAL, NLDA,
$ RESLTS( 1, 1, I3, 3 ), LDR1, LDR2, NOUT )
END IF
130 CONTINUE
140 CONTINUE
*
150 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
9996 FORMAT( 5X, A6, ' with UPLO = ''', A1, '''', / )
RETURN
*
* End of DTIMPO
*
END
SUBROUTINE DTIMPP( LINE, NN, NVAL, NNS, NSVAL, LA, TIMMIN, A, B,
$ IWORK, RESLTS, LDR1, LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LA, LDR1, LDR2, LDR3, NN, NNS, NOUT
DOUBLE PRECISION TIMMIN
* ..
* .. Array Arguments ..
INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
DOUBLE PRECISION A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * )
* ..
*
* Purpose
* =======
*
* DTIMPP times DPPTRF, -TRS, and -TRI.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix size N.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* LA (input) INTEGER
* The size of the arrays A, B, and C.
*
* TIMMIN (input) DOUBLE PRECISION
* The minimum time a subroutine will be timed.
*
* A (workspace) DOUBLE PRECISION array, dimension (LA)
*
* B (workspace) DOUBLE PRECISION array, dimension (LA)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
* where NMAX is the maximum value of N permitted.
*
* RESLTS (output) DOUBLE PRECISION array, dimension
* (LDR1,LDR2,LDR3,NSUBS)
* The timing results for each subroutine over the relevant
* values of N.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(4,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NN).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= 2.
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 3 )
* ..
* .. Local Scalars ..
CHARACTER UPLO
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, IC, ICL, IN, INFO, ISUB, IUPLO, LDA, LDB,
$ MAT, N, NRHS
DOUBLE PRECISION OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER UPLOS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER LAVAL( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DMFLOP, DOPLA, DSECND
EXTERNAL LSAME, DMFLOP, DOPLA, DSECND
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, DCOPY, DPPTRF, DPPTRI, DPPTRS,
$ DPRTBL, DTIMMG
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MOD
* ..
* .. Data statements ..
DATA UPLOS / 'U', 'L' /
DATA SUBNAM / 'DPPTRF', 'DPPTRS', 'DPPTRI' /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'PP'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 120
*
* Check that N*(N+1)/2 <= LA for the input values.
*
CNAME = LINE( 1: 6 )
LAVAL( 1 ) = LA
CALL ATIMCK( 4, CNAME, NN, NVAL, 1, LAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 120
END IF
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 90 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
IF( LSAME( UPLO, 'U' ) ) THEN
MAT = 4
ELSE
MAT = -4
END IF
*
* Do for each value of N in NVAL.
*
DO 80 IN = 1, NN
N = NVAL( IN )
LDA = N*( N+1 ) / 2
*
* Time DPPTRF
*
IF( TIMSUB( 1 ) ) THEN
CALL DTIMMG( MAT, N, N, A, LDA, 0, 0 )
IC = 0
S1 = DSECND( )
10 CONTINUE
CALL DPPTRF( UPLO, N, A, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( MAT, N, N, A, LDA, 0, 0 )
GO TO 10
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
20 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( MAT, N, N, A, LDA, 0, 0 )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DPPTRF', N, N, 0, 0, 0 )
RESLTS( 1, IN, IUPLO, 1 ) = DMFLOP( OPS, TIME, INFO )
*
ELSE
IC = 0
CALL DTIMMG( MAT, N, N, A, LDA, 0, 0 )
END IF
*
* Generate another matrix and factor it using DPPTRF so
* that the factored form can be used in timing the other
* routines.
*
IF( IC.NE.1 )
$ CALL DPPTRF( UPLO, N, A, INFO )
*
* Time DPPTRI
*
IF( TIMSUB( 3 ) ) THEN
CALL DCOPY( LDA, A, 1, B, 1 )
IC = 0
S1 = DSECND( )
30 CONTINUE
CALL DPPTRI( UPLO, N, B, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DCOPY( LDA, A, 1, B, 1 )
GO TO 30
END IF
*
* Subtract the time used in DLACPY.
*
ICL = 1
S1 = DSECND( )
40 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DCOPY( LDA, A, 1, B, 1 )
GO TO 40
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DPPTRI', N, N, 0, 0, 0 )
RESLTS( 1, IN, IUPLO, 3 ) = DMFLOP( OPS, TIME, INFO )
END IF
*
* Time DPPTRS
*
IF( TIMSUB( 2 ) ) THEN
DO 70 I = 1, NNS
NRHS = NSVAL( I )
LDB = N
IF( MOD( LDB, 2 ).EQ.0 )
$ LDB = LDB + 1
CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 )
IC = 0
S1 = DSECND( )
50 CONTINUE
CALL DPPTRS( UPLO, N, NRHS, A, B, LDB, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 50
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
60 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 60
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DPPTRS', N, NRHS, 0, 0, 0 )
RESLTS( I, IN, IUPLO, 2 ) = DMFLOP( OPS, TIME, INFO )
70 CONTINUE
END IF
80 CONTINUE
90 CONTINUE
*
* Print tables of results for each timed routine.
*
DO 110 ISUB = 1, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 110
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
DO 100 IUPLO = 1, 2
WRITE( NOUT, FMT = 9997 )SUBNAM( ISUB ), UPLOS( IUPLO )
IF( ISUB.EQ.1 ) THEN
CALL DPRTBL( ' ', 'N', 1, LAVAL, NN, NVAL, 1,
$ RESLTS( 1, 1, IUPLO, 1 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.2 ) THEN
CALL DPRTBL( 'NRHS', 'N', NNS, NSVAL, NN, NVAL, 1,
$ RESLTS( 1, 1, IUPLO, 2 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.3 ) THEN
CALL DPRTBL( ' ', 'N', 1, LAVAL, NN, NVAL, 1,
$ RESLTS( 1, 1, IUPLO, 3 ), LDR1, LDR2, NOUT )
END IF
100 CONTINUE
110 CONTINUE
120 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***', / )
9997 FORMAT( 5X, A6, ' with UPLO = ''', A1, '''', / )
RETURN
*
* End of DTIMPP
*
END
SUBROUTINE DTIMPT( LINE, NM, MVAL, NNS, NSVAL, NLDA, LDAVAL,
$ TIMMIN, A, B, RESLTS, LDR1, LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NLDA, NM, NNS, NOUT
DOUBLE PRECISION TIMMIN
* ..
* .. Array Arguments ..
INTEGER LDAVAL( * ), MVAL( * ), NSVAL( * )
DOUBLE PRECISION A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * )
* ..
*
* Purpose
* =======
*
* DTIMPT times DPTTRF, -TRS, -SV, and -SL.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix size M.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) DOUBLE PRECISION
* The minimum time a subroutine will be timed.
*
* A (workspace) DOUBLE PRECISION array, dimension (NMAX*2)
* where NMAX is the maximum value permitted for N.
*
* B (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
*
* RESLTS (output) DOUBLE PRECISION array, dimension
* (LDR1,LDR2,LDR3,NSUBS)
* The timing results for each subroutine over the relevant
* values of N.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= 1.
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NM).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 4 )
* ..
* .. Local Scalars ..
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, IC, ICL, ILDA, IM, INFO, ISUB, LDB, M, N,
$ NRHS
DOUBLE PRECISION OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER LAVAL( 1 )
* ..
* .. External Functions ..
DOUBLE PRECISION DMFLOP, DOPLA, DSECND
EXTERNAL DMFLOP, DOPLA, DSECND
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, DPRTBL, DPTSV, DPTTRF, DPTTRS,
$ DTIMMG, DPTSL
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX
* ..
* .. Data statements ..
DATA SUBNAM / 'DPTTRF', 'DPTTRS', 'DPTSV ',
$ 'DPTSL ' /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'PT'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 170
*
* Check that N <= LDA for the input values.
*
DO 10 ISUB = 2, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 10
CNAME = SUBNAM( ISUB )
CALL ATIMCK( 2, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
TIMSUB( ISUB ) = .FALSE.
END IF
10 CONTINUE
*
* Do for each value of M:
*
DO 140 IM = 1, NM
*
M = MVAL( IM )
N = MAX( M, 1 )
*
* Time DPTTRF
*
IF( TIMSUB( 1 ) ) THEN
CALL DTIMMG( 13, M, M, A, 2*N, 0, 0 )
IC = 0
S1 = DSECND( )
20 CONTINUE
CALL DPTTRF( M, A, A( N+1 ), INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 13, M, M, A, 2*N, 0, 0 )
GO TO 20
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
30 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 13, M, M, A, 2*N, 0, 0 )
GO TO 30
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DPTTRF', M, 0, 0, 0, 0 )
RESLTS( 1, IM, 1, 1 ) = DMFLOP( OPS, TIME, INFO )
*
ELSE
IC = 0
CALL DTIMMG( 13, M, M, A, 2*N, 0, 0 )
END IF
*
* Generate another matrix and factor it using DPTTRF so
* that the factored form can be used in timing the other
* routines.
*
IF( IC.NE.1 )
$ CALL DPTTRF( M, A, A( N+1 ), INFO )
*
* Time DPTTRS
*
IF( TIMSUB( 2 ) ) THEN
DO 70 ILDA = 1, NLDA
LDB = LDAVAL( ILDA )
DO 60 I = 1, NNS
NRHS = NSVAL( I )
CALL DTIMMG( 0, M, NRHS, B, LDB, 0, 0 )
IC = 0
S1 = DSECND( )
40 CONTINUE
CALL DPTTRS( M, NRHS, A, A( N+1 ), B, LDB, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, M, NRHS, B, LDB, 0, 0 )
GO TO 40
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
50 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, M, NRHS, B, LDB, 0, 0 )
GO TO 50
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DPTTRS', M, NRHS, 0, 0, 0 )
RESLTS( I, IM, ILDA, 2 ) = DMFLOP( OPS, TIME, INFO )
60 CONTINUE
70 CONTINUE
END IF
*
IF( TIMSUB( 3 ) ) THEN
DO 110 ILDA = 1, NLDA
LDB = LDAVAL( ILDA )
DO 100 I = 1, NNS
NRHS = NSVAL( I )
CALL DTIMMG( 13, M, M, A, 2*N, 0, 0 )
CALL DTIMMG( 0, M, NRHS, B, LDB, 0, 0 )
IC = 0
S1 = DSECND( )
80 CONTINUE
CALL DPTSV( M, NRHS, A, A( N+1 ), B, LDB, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 13, M, M, A, 2*N, 0, 0 )
CALL DTIMMG( 0, M, NRHS, B, LDB, 0, 0 )
GO TO 80
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
90 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 13, M, M, A, 2*N, 0, 0 )
CALL DTIMMG( 0, M, NRHS, B, LDB, 0, 0 )
GO TO 90
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DPTSV ', M, NRHS, 0, 0, 0 )
RESLTS( I, IM, ILDA, 3 ) = DMFLOP( OPS, TIME, INFO )
100 CONTINUE
110 CONTINUE
END IF
*
IF( TIMSUB( 4 ) ) THEN
CALL DTIMMG( 13, M, M, A, 2*N, 0, 0 )
CALL DTIMMG( 0, M, 1, B, N, 0, 0 )
IC = 0
S1 = DSECND( )
120 CONTINUE
CALL DPTSL( M, A, A( N+1 ), B )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 13, M, M, A, 2*N, 0, 0 )
CALL DTIMMG( 0, M, 1, B, N, 0, 0 )
GO TO 120
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
130 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 13, M, M, A, 2*N, 0, 0 )
CALL DTIMMG( 0, M, 1, B, N, 0, 0 )
GO TO 130
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DPTSV ', M, 1, 0, 0, 0 )
RESLTS( 1, IM, 1, 4 ) = DMFLOP( OPS, TIME, INFO )
END IF
140 CONTINUE
*
* Print a table of results for each timed routine.
*
DO 160 ISUB = 1, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 160
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 .AND. ( TIMSUB( 2 ) .OR. TIMSUB( 3 ) ) ) THEN
DO 150 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
150 CONTINUE
END IF
WRITE( NOUT, FMT = * )
IF( ISUB.EQ.1 ) THEN
CALL DPRTBL( ' ', 'N', 1, LAVAL, NM, MVAL, 1, RESLTS, LDR1,
$ LDR2, NOUT )
ELSE IF( ISUB.EQ.2 ) THEN
CALL DPRTBL( 'NRHS', 'N', NNS, NSVAL, NM, MVAL, NLDA,
$ RESLTS( 1, 1, 1, 2 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.3 ) THEN
CALL DPRTBL( 'NRHS', 'N', NNS, NSVAL, NM, MVAL, NLDA,
$ RESLTS( 1, 1, 1, 3 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.4 ) THEN
CALL DPRTBL( ' ', 'N', 1, LAVAL, NM, MVAL, 1,
$ RESLTS( 1, 1, 1, 4 ), LDR1, LDR2, NOUT )
END IF
160 CONTINUE
*
170 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
RETURN
*
* End of DTIMPT
*
END
SUBROUTINE DTIMQ3( LINE, NM, MVAL, NVAL, NNB, NBVAL, NXVAL, NLDA,
$ LDAVAL, TIMMIN, A, COPYA, TAU, WORK, IWORK,
$ RESLTS, LDR1, LDR2, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* December 22, 1999
*
* Rewritten to time qp3 code.
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, NLDA, NM, NNB, NOUT
DOUBLE PRECISION TIMMIN
* ..
* .. Array Arguments ..
INTEGER IWORK( * ), LDAVAL( * ), MVAL( * ), NBVAL( * ),
$ NVAL( * ), NXVAL( * )
DOUBLE PRECISION A( * ), COPYA( * ), RESLTS( LDR1, LDR2, * ),
$ TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DTIMQ3 times the routines to perform the Rank-Revealing QR
* factorization of a DOUBLE PRECISION general matrix.
*
* Two matrix types may be used for timing. The number of types is
* set in the parameter NMODE and the matrix types are set in the vector
* MODES, using the following key:
* 2. BREAK1 D(1:N-1)=1 and D(N)=1.0/COND in DLATMS
* 3. GEOM D(I)=COND**(-(I-1)/(N-1)) in DLATMS
* These numbers are chosen to correspond with the matrix types in the
* test code.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M and N contained in the vectors
* MVAL and NVAL. The matrix sizes are used in pairs (M,N).
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NVAL (input) INTEGER array, dimension (NM)
* The values of the matrix column dimension N.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) DOUBLE PRECISION
* The minimum time a subroutine will be timed.
*
* A (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values of LDA and N.
*
* COPYA (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
*
* TAU (workspace) DOUBLE PRECISION array, dimension (MINMN)
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*NMAX)
*
* IWORK (workspace) INTEGER array, dimension (2*NMAX)
*
* RESLTS (workspace) DOUBLE PRECISION array, dimension
* (LDR1,LDR2,NLDA)
* The timing results for each subroutine over the relevant
* values of MODE, (M,N), and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NM).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NM).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
*
*
INTEGER NSUBS, NMODE
PARAMETER ( NSUBS = 1, NMODE = 2 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, IC, ICL, ILDA, IM, IMODE, INB, INFO, LDA,
$ LW, M, MINMN, MODE, N, NB, NX
DOUBLE PRECISION COND, DMAX, OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER ISEED( 4 ), MODES( NMODE )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DMFLOP, DOPLA, DSECND
EXTERNAL DLAMCH, DMFLOP, DOPLA, DSECND
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, DGEQP3, DLACPY, DLATMS, DPRTB4,
$ ICOPY, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Data statements ..
DATA SUBNAM / 'DGEQP3' /
DATA MODES / 2, 3 /
DATA ISEED / 0, 0, 0, 1 /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'QP'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( .NOT.TIMSUB( 1 ) .OR. INFO.NE.0 )
$ GO TO 90
*
* Check that M <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9996 )CNAME
GO TO 90
END IF
*
* Set the condition number and scaling factor for the matrices
* to be generated.
*
DMAX = ONE
COND = ONE / DLAMCH( 'Precision' )
*
* Do for each type of matrix:
*
DO 80 IMODE = 1, NMODE
MODE = MODES( IMODE )
*
*
* *****************
* * Timing xGEQP3 *
* *****************
*
* Do for each value of LDA:
*
DO 60 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
*
* Do for each pair of values (M,N):
*
DO 50 IM = 1, NM
M = MVAL( IM )
N = NVAL( IM )
MINMN = MIN( M, N )
*
* Generate a test matrix of size m by n using the
* singular value distribution indicated by MODE.
*
CALL DLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', TAU,
$ MODE, COND, DMAX, M, N, 'No packing', COPYA,
$ LDA, WORK, INFO )
*
* Do for each pair of values (NB,NX) in NBVAL and NXVAL:
*
DO 40 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
*
*
* DGEQP3
*
LW = MAX( 1, 2*N+( N+1 )*NB )
DO 10 I = 1, N
IWORK( N+I ) = 0
10 CONTINUE
*
CALL DLACPY( 'All', M, N, COPYA, LDA, A, LDA )
CALL ICOPY( N, IWORK( N+1 ), 1, IWORK, 1 )
IC = 0
S1 = DSECND( )
20 CONTINUE
CALL DGEQP3( M, N, A, LDA, IWORK, TAU, WORK, LW,
$ INFO )
S2 = DSECND( )
*
IF( INFO.NE.0 ) THEN
WRITE( *, FMT = * )'>>>Warning: INFO returned by ',
$ 'DGEQPX is:', INFO
INFO = 0
END IF
*
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DLACPY( 'All', M, N, COPYA, LDA, A, LDA )
CALL ICOPY( N, IWORK( N+1 ), 1, IWORK, 1 )
GO TO 20
END IF
*
* Subtract the time used in DLACPY.
*
ICL = 1
S1 = DSECND( )
30 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DLACPY( 'All', M, N, COPYA, LDA, A, LDA )
CALL ICOPY( N, IWORK( N+1 ), 1, IWORK, 1 )
GO TO 30
END IF
*
* The number of flops of xGEQP3 is approximately the
* the number of flops of xGEQPF.
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
*
OPS = DOPLA( 'DGEQPF', M, N, 0, 0, NB )
RESLTS( INB, IM, ILDA ) = DMFLOP( OPS, TIME, INFO )
*
40 CONTINUE
50 CONTINUE
60 CONTINUE
*
* Print the results for each matrix type.
*
WRITE( NOUT, FMT = 9999 )SUBNAM( 1 )
WRITE( NOUT, FMT = 9998 )IMODE
DO 70 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
70 CONTINUE
WRITE( NOUT, FMT = * )
CALL DPRTB4( '( NB, NX)', 'M', 'N', NNB, NBVAL, NXVAL, NM,
$ MVAL, NVAL, NLDA, RESLTS( 1, 1, 1 ), LDR1, LDR2,
$ NOUT )
*
80 CONTINUE
*
9999 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9998 FORMAT( 5X, 'type of matrix:', I4 )
9997 FORMAT( 5X, 'line ', I4, ' with LDA = ', I4 )
9996 FORMAT( 1X, A6, ' timing run not attempted', / )
*
90 CONTINUE
RETURN
*
* End of DTIMQ3
*
END
SUBROUTINE DTIMQL( LINE, NM, MVAL, NVAL, NK, KVAL, NNB, NBVAL,
$ NXVAL, NLDA, LDAVAL, TIMMIN, A, TAU, B, WORK,
$ RESLTS, LDR1, LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NK, NLDA, NM, NNB, NOUT
DOUBLE PRECISION TIMMIN
* ..
* .. Array Arguments ..
INTEGER KVAL( * ), LDAVAL( * ), MVAL( * ), NBVAL( * ),
$ NVAL( * ), NXVAL( * )
DOUBLE PRECISION A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * ),
$ TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DTIMQL times the LAPACK routines to perform the QL factorization of
* a DOUBLE PRECISION general matrix.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M and N contained in the vectors
* MVAL and NVAL. The matrix sizes are used in pairs (M,N).
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NVAL (input) INTEGER array, dimension (NM)
* The values of the matrix column dimension N.
*
* NK (input) INTEGER
* The number of values of K in the vector KVAL.
*
* KVAL (input) INTEGER array, dimension (NK)
* The values of the matrix dimension K, used in DORMQL.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) DOUBLE PRECISION
* The minimum time a subroutine will be timed.
*
* A (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values of LDA and N.
*
* TAU (workspace) DOUBLE PRECISION array, dimension (min(M,N))
*
* B (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NBMAX)
* where NBMAX is the maximum value of NB.
*
* RESLTS (workspace) DOUBLE PRECISION array, dimension
* (LDR1,LDR2,LDR3,2*NK)
* The timing results for each subroutine over the relevant
* values of (M,N), (NB,NX), and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NM).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* Internal Parameters
* ===================
*
* MODE INTEGER
* The matrix type. MODE = 3 is a geometric distribution of
* eigenvalues. See DLATMS for further details.
*
* COND DOUBLE PRECISION
* The condition number of the matrix. The singular values are
* set to values from DMAX to DMAX/COND.
*
* DMAX DOUBLE PRECISION
* The magnitude of the largest singular value.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 3 )
INTEGER MODE
DOUBLE PRECISION COND, DMAX
PARAMETER ( MODE = 3, COND = 100.0D0, DMAX = 1.0D0 )
* ..
* .. Local Scalars ..
CHARACTER LABM, SIDE, TRANS
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, I4, IC, ICL, IK, ILDA, IM, IMX, INB, INFO,
$ ISIDE, ISUB, ITOFF, ITRAN, K, K1, LDA, LW, M,
$ M1, MINMN, N, N1, NB, NX
DOUBLE PRECISION OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER SIDES( 2 ), TRANSS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER ISEED( 4 ), MUSE( 12 ), NUSE( 12 ), RESEED( 4 )
* ..
* .. External Functions ..
DOUBLE PRECISION DMFLOP, DOPLA, DSECND
EXTERNAL DMFLOP, DOPLA, DSECND
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, DGEQLF, DLACPY, DLATMS, DORGQL,
$ DORMQL, DPRTB4, DPRTB5, DTIMMG, ICOPY, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Data statements ..
DATA SUBNAM / 'DGEQLF', 'DORGQL', 'DORMQL' /
DATA SIDES / 'L', 'R' / , TRANSS / 'N', 'T' /
DATA ISEED / 0, 0, 0, 1 /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'QL'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 230
*
* Check that M <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 230
END IF
*
* Do for each pair of values (M,N):
*
DO 70 IM = 1, NM
M = MVAL( IM )
N = NVAL( IM )
MINMN = MIN( M, N )
CALL ICOPY( 4, ISEED, 1, RESEED, 1 )
*
* Do for each value of LDA:
*
DO 60 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
*
* Do for each pair of values (NB, NX) in NBVAL and NXVAL.
*
DO 50 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
LW = MAX( 1, N*MAX( 1, NB ) )
*
* Generate a test matrix of size M by N.
*
CALL ICOPY( 4, RESEED, 1, ISEED, 1 )
CALL DLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', TAU,
$ MODE, COND, DMAX, M, N, 'No packing', B,
$ LDA, WORK, INFO )
*
IF( TIMSUB( 1 ) ) THEN
*
* DGEQLF: QL factorization
*
CALL DLACPY( 'Full', M, N, B, LDA, A, LDA )
IC = 0
S1 = DSECND( )
10 CONTINUE
CALL DGEQLF( M, N, A, LDA, TAU, WORK, LW, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DLACPY( 'Full', M, N, B, LDA, A, LDA )
GO TO 10
END IF
*
* Subtract the time used in DLACPY.
*
ICL = 1
S1 = DSECND( )
20 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DLACPY( 'Full', M, N, A, LDA, B, LDA )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DGEQLF', M, N, 0, 0, NB )
RESLTS( INB, IM, ILDA, 1 ) = DMFLOP( OPS, TIME, INFO )
ELSE
*
* If DGEQLF was not timed, generate a matrix and factor
* it using DGEQLF anyway so that the factored form of
* the matrix can be used in timing the other routines.
*
CALL DLACPY( 'Full', M, N, B, LDA, A, LDA )
CALL DGEQLF( M, N, A, LDA, TAU, WORK, LW, INFO )
END IF
*
IF( TIMSUB( 2 ) ) THEN
*
* DORGQL: Generate orthogonal matrix Q from the QL
* factorization
*
CALL DLACPY( 'Full', M, MINMN, A, LDA, B, LDA )
IC = 0
S1 = DSECND( )
30 CONTINUE
CALL DORGQL( M, MINMN, MINMN, B, LDA, TAU, WORK, LW,
$ INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DLACPY( 'Full', M, MINMN, A, LDA, B, LDA )
GO TO 30
END IF
*
* Subtract the time used in DLACPY.
*
ICL = 1
S1 = DSECND( )
40 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DLACPY( 'Full', M, MINMN, A, LDA, B, LDA )
GO TO 40
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DORGQL', M, MINMN, MINMN, 0, NB )
RESLTS( INB, IM, ILDA, 2 ) = DMFLOP( OPS, TIME, INFO )
END IF
*
50 CONTINUE
60 CONTINUE
70 CONTINUE
*
* Print tables of results
*
DO 90 ISUB = 1, NSUBS - 1
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 90
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 80 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
80 CONTINUE
END IF
WRITE( NOUT, FMT = * )
IF( ISUB.EQ.2 )
$ WRITE( NOUT, FMT = 9996 )
CALL DPRTB4( '( NB, NX)', 'M', 'N', NNB, NBVAL, NXVAL, NM,
$ MVAL, NVAL, NLDA, RESLTS( 1, 1, 1, ISUB ), LDR1,
$ LDR2, NOUT )
90 CONTINUE
*
* Time DORMQL separately. Here the starting matrix is M by N, and
* K is the free dimension of the matrix multiplied by Q.
*
IF( TIMSUB( 3 ) ) THEN
*
* Check that K <= LDA for the input values.
*
CALL ATIMCK( 3, CNAME, NK, KVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )SUBNAM( 3 )
GO TO 230
END IF
*
* Use only the pairs (M,N) where M >= N.
*
IMX = 0
DO 100 IM = 1, NM
IF( MVAL( IM ).GE.NVAL( IM ) ) THEN
IMX = IMX + 1
MUSE( IMX ) = MVAL( IM )
NUSE( IMX ) = NVAL( IM )
END IF
100 CONTINUE
*
* DORMQL: Multiply by Q stored as a product of elementary
* transformations
*
* Do for each pair of values (M,N):
*
DO 180 IM = 1, IMX
M = MUSE( IM )
N = NUSE( IM )
*
* Do for each value of LDA:
*
DO 170 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
*
* Generate an M by N matrix and form its QL decomposition.
*
CALL DLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', TAU,
$ MODE, COND, DMAX, M, N, 'No packing', A,
$ LDA, WORK, INFO )
LW = MAX( 1, N*MAX( 1, NB ) )
CALL DGEQLF( M, N, A, LDA, TAU, WORK, LW, INFO )
*
* Do first for SIDE = 'L', then for SIDE = 'R'
*
I4 = 0
DO 160 ISIDE = 1, 2
SIDE = SIDES( ISIDE )
*
* Do for each pair of values (NB, NX) in NBVAL and
* NXVAL.
*
DO 150 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
*
* Do for each value of K in KVAL
*
DO 140 IK = 1, NK
K = KVAL( IK )
*
* Sort out which variable is which
*
IF( ISIDE.EQ.1 ) THEN
M1 = M
K1 = N
N1 = K
LW = MAX( 1, N1*MAX( 1, NB ) )
ELSE
N1 = M
K1 = N
M1 = K
LW = MAX( 1, M1*MAX( 1, NB ) )
END IF
*
* Do first for TRANS = 'N', then for TRANS = 'T'
*
ITOFF = 0
DO 130 ITRAN = 1, 2
TRANS = TRANSS( ITRAN )
CALL DTIMMG( 0, M1, N1, B, LDA, 0, 0 )
IC = 0
S1 = DSECND( )
110 CONTINUE
CALL DORMQL( SIDE, TRANS, M1, N1, K1, A, LDA,
$ TAU, B, LDA, WORK, LW, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, M1, N1, B, LDA, 0, 0 )
GO TO 110
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
120 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, M1, N1, B, LDA, 0, 0 )
GO TO 120
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DORMQL', M1, N1, K1, ISIDE-1,
$ NB )
RESLTS( INB, IM, ILDA,
$ I4+ITOFF+IK ) = DMFLOP( OPS, TIME, INFO )
ITOFF = NK
130 CONTINUE
140 CONTINUE
150 CONTINUE
I4 = 2*NK
160 CONTINUE
170 CONTINUE
180 CONTINUE
*
* Print tables of results
*
ISUB = 3
I4 = 1
IF( IMX.GE.1 ) THEN
DO 220 ISIDE = 1, 2
SIDE = SIDES( ISIDE )
IF( ISIDE.EQ.1 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 190 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
190 CONTINUE
END IF
END IF
DO 210 ITRAN = 1, 2
TRANS = TRANSS( ITRAN )
DO 200 IK = 1, NK
IF( ISIDE.EQ.1 ) THEN
N = KVAL( IK )
WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ), SIDE,
$ TRANS, 'N', N
LABM = 'M'
ELSE
M = KVAL( IK )
WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ), SIDE,
$ TRANS, 'M', M
LABM = 'N'
END IF
CALL DPRTB5( 'NB', LABM, 'K', NNB, NBVAL, IMX,
$ MUSE, NUSE, NLDA,
$ RESLTS( 1, 1, 1, I4 ), LDR1, LDR2,
$ NOUT )
I4 = I4 + 1
200 CONTINUE
210 CONTINUE
220 CONTINUE
ELSE
WRITE( NOUT, FMT = 9994 )SUBNAM( ISUB )
END IF
END IF
230 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
9996 FORMAT( 5X, 'K = min(M,N)', / )
9995 FORMAT( / 5X, A6, ' with SIDE = ''', A1, ''', TRANS = ''', A1,
$ ''', ', A1, ' =', I6, / )
9994 FORMAT( ' *** No pairs (M,N) found with M >= N: ', A6,
$ ' not timed' )
RETURN
*
* End of DTIMQL
*
END
SUBROUTINE DTIMQP( LINE, NM, MVAL, NVAL, NLDA, LDAVAL, TIMMIN, A,
$ COPYA, TAU, WORK, IWORK, RESLTS, LDR1, LDR2,
$ NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, NLDA, NM, NOUT
DOUBLE PRECISION TIMMIN
* ..
* .. Array Arguments ..
INTEGER IWORK( * ), LDAVAL( * ), MVAL( * ), NVAL( * )
DOUBLE PRECISION A( * ), COPYA( * ), RESLTS( LDR1, LDR2, * ),
$ TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DTIMQP times the LAPACK routines to perform the QR factorization with
* column pivoting of a DOUBLE PRECISION general matrix.
*
* Two matrix types may be used for timing. The number of types is
* set in the parameter NMODE and the matrix types are set in the vector
* MODES, using the following key:
* 2. BREAK1 D(1:N-1)=1 and D(N)=1.0/COND in DLATMS
* 3. GEOM D(I)=COND**(-(I-1)/(N-1)) in DLATMS
* These numbers are chosen to correspond with the matrix types in the
* test code.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M and N contained in the vectors
* MVAL and NVAL. The matrix sizes are used in pairs (M,N).
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NVAL (input) INTEGER array, dimension (NM)
* The values of the matrix column dimension N.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) DOUBLE PRECISION
* The minimum time a subroutine will be timed.
*
* A (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values of LDA and N.
*
* COPYA (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
*
* TAU (workspace) DOUBLE PRECISION array, dimension (min(M,N))
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*NMAX)
*
* IWORK (workspace) INTEGER array, dimension (2*NMAX)
*
* RESLTS (workspace) DOUBLE PRECISION array, dimension
* (LDR1,LDR2,NLDA)
* The timing results for each subroutine over the relevant
* values of MODE, (M,N), and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NM).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NM).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS, NMODE
PARAMETER ( NSUBS = 1, NMODE = 2 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, IC, ICL, ILDA, IM, IMODE, INFO, LDA, M,
$ MINMN, MODE, N
DOUBLE PRECISION COND, DMAX, OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER ISEED( 4 ), MODES( NMODE )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DMFLOP, DOPLA, DSECND
EXTERNAL DLAMCH, DMFLOP, DOPLA, DSECND
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, DGEQPF, DLACPY, DLATMS, DPRTB5,
$ ICOPY
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MIN
* ..
* .. Data statements ..
DATA SUBNAM / 'DGEQPF' /
DATA MODES / 2, 3 /
DATA ISEED / 0, 0, 0, 1 /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'QP'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( .NOT.TIMSUB( 1 ) .OR. INFO.NE.0 )
$ GO TO 80
*
* Check that M <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 80
END IF
*
* Set the condition number and scaling factor for the matrices
* to be generated.
*
DMAX = ONE
COND = ONE / DLAMCH( 'Precision' )
*
* Do for each pair of values (M,N):
*
DO 60 IM = 1, NM
M = MVAL( IM )
N = NVAL( IM )
MINMN = MIN( M, N )
*
* Do for each value of LDA:
*
DO 50 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
DO 40 IMODE = 1, NMODE
MODE = MODES( IMODE )
*
* Generate a test matrix of size m by n using the
* singular value distribution indicated by MODE.
*
DO 10 I = 1, N
IWORK( N+I ) = 0
10 CONTINUE
CALL DLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', TAU,
$ MODE, COND, DMAX, M, N, 'No packing', COPYA,
$ LDA, WORK, INFO )
*
* DGEQPF: QR factorization with column pivoting
*
CALL DLACPY( 'All', M, N, COPYA, LDA, A, LDA )
CALL ICOPY( N, IWORK( N+1 ), 1, IWORK, 1 )
IC = 0
S1 = DSECND( )
20 CONTINUE
CALL DGEQPF( M, N, A, LDA, IWORK, TAU, WORK, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DLACPY( 'All', M, N, COPYA, LDA, A, LDA )
CALL ICOPY( N, IWORK( N+1 ), 1, IWORK, 1 )
GO TO 20
END IF
*
* Subtract the time used in DLACPY and ICOPY.
*
ICL = 1
S1 = DSECND( )
30 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DLACPY( 'All', M, N, COPYA, LDA, A, LDA )
CALL ICOPY( N, IWORK( N+1 ), 1, IWORK, 1 )
GO TO 30
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DGEQPF', M, N, 0, 0, 1 )
RESLTS( IMODE, IM, ILDA ) = DMFLOP( OPS, TIME, INFO )
*
40 CONTINUE
50 CONTINUE
60 CONTINUE
*
* Print tables of results
*
WRITE( NOUT, FMT = 9998 )SUBNAM( 1 )
IF( NLDA.GT.1 ) THEN
DO 70 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
70 CONTINUE
END IF
WRITE( NOUT, FMT = * )
CALL DPRTB5( 'Type', 'M', 'N', NMODE, MODES, NM, MVAL, NVAL, NLDA,
$ RESLTS, LDR1, LDR2, NOUT )
80 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
RETURN
*
* End of DTIMQP
*
END
SUBROUTINE DTIMQR( LINE, NM, MVAL, NVAL, NK, KVAL, NNB, NBVAL,
$ NXVAL, NLDA, LDAVAL, TIMMIN, A, TAU, B, WORK,
$ RESLTS, LDR1, LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NK, NLDA, NM, NNB, NOUT
DOUBLE PRECISION TIMMIN
* ..
* .. Array Arguments ..
INTEGER KVAL( * ), LDAVAL( * ), MVAL( * ), NBVAL( * ),
$ NVAL( * ), NXVAL( * )
DOUBLE PRECISION A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * ),
$ TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DTIMQR times the LAPACK routines to perform the QR factorization of
* a DOUBLE PRECISION general matrix.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M and N contained in the vectors
* MVAL and NVAL. The matrix sizes are used in pairs (M,N).
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NVAL (input) INTEGER array, dimension (NM)
* The values of the matrix column dimension N.
*
* NK (input) INTEGER
* The number of values of K in the vector KVAL.
*
* KVAL (input) INTEGER array, dimension (NK)
* The values of the matrix dimension K, used in DORMQR.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) DOUBLE PRECISION
* The minimum time a subroutine will be timed.
*
* A (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values of LDA and N.
*
* TAU (workspace) DOUBLE PRECISION array, dimension (min(M,N))
*
* B (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NBMAX)
* where NBMAX is the maximum value of NB.
*
* RESLTS (workspace) DOUBLE PRECISION array, dimension
* (LDR1,LDR2,LDR3,2*NK)
* The timing results for each subroutine over the relevant
* values of (M,N), (NB,NX), and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NM).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* Internal Parameters
* ===================
*
* MODE INTEGER
* The matrix type. MODE = 3 is a geometric distribution of
* eigenvalues. See DLATMS for further details.
*
* COND DOUBLE PRECISION
* The condition number of the matrix. The singular values are
* set to values from DMAX to DMAX/COND.
*
* DMAX DOUBLE PRECISION
* The magnitude of the largest singular value.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 3 )
INTEGER MODE
DOUBLE PRECISION COND, DMAX
PARAMETER ( MODE = 3, COND = 100.0D0, DMAX = 1.0D0 )
* ..
* .. Local Scalars ..
CHARACTER LABM, SIDE, TRANS
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, I4, IC, ICL, IK, ILDA, IM, IMX, INB, INFO,
$ ISIDE, ISUB, ITOFF, ITRAN, K, K1, LDA, LW, M,
$ M1, MINMN, N, N1, NB, NX
DOUBLE PRECISION OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER SIDES( 2 ), TRANSS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER ISEED( 4 ), MUSE( 12 ), NUSE( 12 ), RESEED( 4 )
* ..
* .. External Functions ..
DOUBLE PRECISION DMFLOP, DOPLA, DSECND
EXTERNAL DMFLOP, DOPLA, DSECND
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, DGEQRF, DLACPY, DLATMS, DORGQR,
$ DORMQR, DPRTB4, DPRTB5, DTIMMG, ICOPY, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Data statements ..
DATA SUBNAM / 'DGEQRF', 'DORGQR', 'DORMQR' /
DATA SIDES / 'L', 'R' / , TRANSS / 'N', 'T' /
DATA ISEED / 0, 0, 0, 1 /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'QR'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 230
*
* Check that M <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 230
END IF
*
* Do for each pair of values (M,N):
*
DO 70 IM = 1, NM
M = MVAL( IM )
N = NVAL( IM )
MINMN = MIN( M, N )
CALL ICOPY( 4, ISEED, 1, RESEED, 1 )
*
* Do for each value of LDA:
*
DO 60 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
*
* Do for each pair of values (NB, NX) in NBVAL and NXVAL.
*
DO 50 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
LW = MAX( 1, N*MAX( 1, NB ) )
*
* Generate a test matrix of size M by N.
*
CALL ICOPY( 4, RESEED, 1, ISEED, 1 )
CALL DLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', TAU,
$ MODE, COND, DMAX, M, N, 'No packing', B,
$ LDA, WORK, INFO )
*
IF( TIMSUB( 1 ) ) THEN
*
* DGEQRF: QR factorization
*
CALL DLACPY( 'Full', M, N, B, LDA, A, LDA )
IC = 0
S1 = DSECND( )
10 CONTINUE
CALL DGEQRF( M, N, A, LDA, TAU, WORK, LW, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DLACPY( 'Full', M, N, B, LDA, A, LDA )
GO TO 10
END IF
*
* Subtract the time used in DLACPY.
*
ICL = 1
S1 = DSECND( )
20 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DLACPY( 'Full', M, N, A, LDA, B, LDA )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DGEQRF', M, N, 0, 0, NB )
RESLTS( INB, IM, ILDA, 1 ) = DMFLOP( OPS, TIME, INFO )
ELSE
*
* If DGEQRF was not timed, generate a matrix and factor
* it using DGEQRF anyway so that the factored form of
* the matrix can be used in timing the other routines.
*
CALL DLACPY( 'Full', M, N, B, LDA, A, LDA )
CALL DGEQRF( M, N, A, LDA, TAU, WORK, LW, INFO )
END IF
*
IF( TIMSUB( 2 ) ) THEN
*
* DORGQR: Generate orthogonal matrix Q from the QR
* factorization
*
CALL DLACPY( 'Full', M, MINMN, A, LDA, B, LDA )
IC = 0
S1 = DSECND( )
30 CONTINUE
CALL DORGQR( M, MINMN, MINMN, B, LDA, TAU, WORK, LW,
$ INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DLACPY( 'Full', M, MINMN, A, LDA, B, LDA )
GO TO 30
END IF
*
* Subtract the time used in DLACPY.
*
ICL = 1
S1 = DSECND( )
40 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DLACPY( 'Full', M, MINMN, A, LDA, B, LDA )
GO TO 40
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DORGQR', M, MINMN, MINMN, 0, NB )
RESLTS( INB, IM, ILDA, 2 ) = DMFLOP( OPS, TIME, INFO )
END IF
*
50 CONTINUE
60 CONTINUE
70 CONTINUE
*
* Print tables of results
*
DO 90 ISUB = 1, NSUBS - 1
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 90
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 80 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
80 CONTINUE
END IF
WRITE( NOUT, FMT = * )
IF( ISUB.EQ.2 )
$ WRITE( NOUT, FMT = 9996 )
CALL DPRTB4( '( NB, NX)', 'M', 'N', NNB, NBVAL, NXVAL, NM,
$ MVAL, NVAL, NLDA, RESLTS( 1, 1, 1, ISUB ), LDR1,
$ LDR2, NOUT )
90 CONTINUE
*
* Time DORMQR separately. Here the starting matrix is M by N, and
* K is the free dimension of the matrix multiplied by Q.
*
IF( TIMSUB( 3 ) ) THEN
*
* Check that K <= LDA for the input values.
*
CALL ATIMCK( 3, CNAME, NK, KVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )SUBNAM( 3 )
GO TO 230
END IF
*
* Use only the pairs (M,N) where M >= N.
*
IMX = 0
DO 100 IM = 1, NM
IF( MVAL( IM ).GE.NVAL( IM ) ) THEN
IMX = IMX + 1
MUSE( IMX ) = MVAL( IM )
NUSE( IMX ) = NVAL( IM )
END IF
100 CONTINUE
*
* DORMQR: Multiply by Q stored as a product of elementary
* transformations
*
* Do for each pair of values (M,N):
*
DO 180 IM = 1, IMX
M = MUSE( IM )
N = NUSE( IM )
*
* Do for each value of LDA:
*
DO 170 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
*
* Generate an M by N matrix and form its QR decomposition.
*
CALL DLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', TAU,
$ MODE, COND, DMAX, M, N, 'No packing', A,
$ LDA, WORK, INFO )
LW = MAX( 1, N*MAX( 1, NB ) )
CALL DGEQRF( M, N, A, LDA, TAU, WORK, LW, INFO )
*
* Do first for SIDE = 'L', then for SIDE = 'R'
*
I4 = 0
DO 160 ISIDE = 1, 2
SIDE = SIDES( ISIDE )
*
* Do for each pair of values (NB, NX) in NBVAL and
* NXVAL.
*
DO 150 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
*
* Do for each value of K in KVAL
*
DO 140 IK = 1, NK
K = KVAL( IK )
*
* Sort out which variable is which
*
IF( ISIDE.EQ.1 ) THEN
M1 = M
K1 = N
N1 = K
LW = MAX( 1, N1*MAX( 1, NB ) )
ELSE
N1 = M
K1 = N
M1 = K
LW = MAX( 1, M1*MAX( 1, NB ) )
END IF
*
* Do first for TRANS = 'N', then for TRANS = 'T'
*
ITOFF = 0
DO 130 ITRAN = 1, 2
TRANS = TRANSS( ITRAN )
CALL DTIMMG( 0, M1, N1, B, LDA, 0, 0 )
IC = 0
S1 = DSECND( )
110 CONTINUE
CALL DORMQR( SIDE, TRANS, M1, N1, K1, A, LDA,
$ TAU, B, LDA, WORK, LW, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, M1, N1, B, LDA, 0, 0 )
GO TO 110
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
120 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, M1, N1, B, LDA, 0, 0 )
GO TO 120
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DORMQR', M1, N1, K1, ISIDE-1,
$ NB )
RESLTS( INB, IM, ILDA,
$ I4+ITOFF+IK ) = DMFLOP( OPS, TIME, INFO )
ITOFF = NK
130 CONTINUE
140 CONTINUE
150 CONTINUE
I4 = 2*NK
160 CONTINUE
170 CONTINUE
180 CONTINUE
*
* Print tables of results
*
ISUB = 3
I4 = 1
IF( IMX.GE.1 ) THEN
DO 220 ISIDE = 1, 2
SIDE = SIDES( ISIDE )
IF( ISIDE.EQ.1 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 190 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
190 CONTINUE
END IF
END IF
DO 210 ITRAN = 1, 2
TRANS = TRANSS( ITRAN )
DO 200 IK = 1, NK
IF( ISIDE.EQ.1 ) THEN
N = KVAL( IK )
WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ), SIDE,
$ TRANS, 'N', N
LABM = 'M'
ELSE
M = KVAL( IK )
WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ), SIDE,
$ TRANS, 'M', M
LABM = 'N'
END IF
CALL DPRTB5( 'NB', LABM, 'K', NNB, NBVAL, IMX,
$ MUSE, NUSE, NLDA,
$ RESLTS( 1, 1, 1, I4 ), LDR1, LDR2,
$ NOUT )
I4 = I4 + 1
200 CONTINUE
210 CONTINUE
220 CONTINUE
ELSE
WRITE( NOUT, FMT = 9994 )SUBNAM( ISUB )
END IF
END IF
230 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
9996 FORMAT( 5X, 'K = min(M,N)', / )
9995 FORMAT( / 5X, A6, ' with SIDE = ''', A1, ''', TRANS = ''', A1,
$ ''', ', A1, ' =', I6, / )
9994 FORMAT( ' *** No pairs (M,N) found with M >= N: ', A6,
$ ' not timed' )
RETURN
*
* End of DTIMQR
*
END
SUBROUTINE DTIMRQ( LINE, NM, MVAL, NVAL, NK, KVAL, NNB, NBVAL,
$ NXVAL, NLDA, LDAVAL, TIMMIN, A, TAU, B, WORK,
$ RESLTS, LDR1, LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NK, NLDA, NM, NNB, NOUT
DOUBLE PRECISION TIMMIN
* ..
* .. Array Arguments ..
INTEGER KVAL( * ), LDAVAL( * ), MVAL( * ), NBVAL( * ),
$ NVAL( * ), NXVAL( * )
DOUBLE PRECISION A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * ),
$ TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DTIMRQ times the LAPACK routines to perform the RQ factorization of
* a DOUBLE PRECISION general matrix.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M and N contained in the vectors
* MVAL and NVAL. The matrix sizes are used in pairs (M,N).
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NVAL (input) INTEGER array, dimension (NM)
* The values of the matrix column dimension N.
*
* NK (input) INTEGER
* The number of values of K in the vector KVAL.
*
* KVAL (input) INTEGER array, dimension (NK)
* The values of the matrix dimension K, used in DORMRQ.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) DOUBLE PRECISION
* The minimum time a subroutine will be timed.
*
* A (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values of LDA and N.
*
* TAU (workspace) DOUBLE PRECISION array, dimension (min(M,N))
*
* B (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NBMAX)
* where NBMAX is the maximum value of NB.
*
* RESLTS (workspace) DOUBLE PRECISION array, dimension
* (LDR1,LDR2,LDR3,2*NK)
* The timing results for each subroutine over the relevant
* values of (M,N), (NB,NX), and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NM).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* Internal Parameters
* ===================
*
* MODE INTEGER
* The matrix type. MODE = 3 is a geometric distribution of
* eigenvalues. See DLATMS for further details.
*
* COND DOUBLE PRECISION
* The condition number of the matrix. The singular values are
* set to values from DMAX to DMAX/COND.
*
* DMAX DOUBLE PRECISION
* The magnitude of the largest singular value.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 3 )
INTEGER MODE
DOUBLE PRECISION COND, DMAX
PARAMETER ( MODE = 3, COND = 100.0D0, DMAX = 1.0D0 )
* ..
* .. Local Scalars ..
CHARACTER LABM, SIDE, TRANS
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, I4, IC, ICL, IK, ILDA, IM, IMX, INB, INFO,
$ ISIDE, ISUB, ITOFF, ITRAN, K, K1, LDA, LW, M,
$ M1, MINMN, N, N1, NB, NX
DOUBLE PRECISION OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER SIDES( 2 ), TRANSS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER ISEED( 4 ), MUSE( 12 ), NUSE( 12 ), RESEED( 4 )
* ..
* .. External Functions ..
DOUBLE PRECISION DMFLOP, DOPLA, DSECND
EXTERNAL DMFLOP, DOPLA, DSECND
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, DGERQF, DLACPY, DLATMS, DORGRQ,
$ DORMRQ, DPRTB4, DPRTB5, DTIMMG, ICOPY, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Data statements ..
DATA SUBNAM / 'DGERQF', 'DORGRQ', 'DORMRQ' /
DATA SIDES / 'L', 'R' / , TRANSS / 'N', 'T' /
DATA ISEED / 0, 0, 0, 1 /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'RQ'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 230
*
* Check that M <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 230
END IF
*
* Do for each pair of values (M,N):
*
DO 70 IM = 1, NM
M = MVAL( IM )
N = NVAL( IM )
MINMN = MIN( M, N )
CALL ICOPY( 4, ISEED, 1, RESEED, 1 )
*
* Do for each value of LDA:
*
DO 60 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
*
* Do for each pair of values (NB, NX) in NBVAL and NXVAL.
*
DO 50 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
LW = MAX( 1, M*MAX( 1, NB ) )
*
* Generate a test matrix of size M by N.
*
CALL ICOPY( 4, RESEED, 1, ISEED, 1 )
CALL DLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', TAU,
$ MODE, COND, DMAX, M, N, 'No packing', B,
$ LDA, WORK, INFO )
*
IF( TIMSUB( 1 ) ) THEN
*
* DGERQF: RQ factorization
*
CALL DLACPY( 'Full', M, N, B, LDA, A, LDA )
IC = 0
S1 = DSECND( )
10 CONTINUE
CALL DGERQF( M, N, A, LDA, TAU, WORK, LW, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DLACPY( 'Full', M, N, B, LDA, A, LDA )
GO TO 10
END IF
*
* Subtract the time used in DLACPY.
*
ICL = 1
S1 = DSECND( )
20 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DLACPY( 'Full', M, N, A, LDA, B, LDA )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DGERQF', M, N, 0, 0, NB )
RESLTS( INB, IM, ILDA, 1 ) = DMFLOP( OPS, TIME, INFO )
ELSE
*
* If DGERQF was not timed, generate a matrix and factor
* it using DGERQF anyway so that the factored form of
* the matrix can be used in timing the other routines.
*
CALL DLACPY( 'Full', M, N, B, LDA, A, LDA )
CALL DGERQF( M, N, A, LDA, TAU, WORK, LW, INFO )
END IF
*
IF( TIMSUB( 2 ) ) THEN
*
* DORGRQ: Generate orthogonal matrix Q from the RQ
* factorization
*
CALL DLACPY( 'Full', MINMN, N, A, LDA, B, LDA )
IC = 0
S1 = DSECND( )
30 CONTINUE
CALL DORGRQ( MINMN, N, MINMN, B, LDA, TAU, WORK, LW,
$ INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DLACPY( 'Full', MINMN, N, A, LDA, B, LDA )
GO TO 30
END IF
*
* Subtract the time used in DLACPY.
*
ICL = 1
S1 = DSECND( )
40 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DLACPY( 'Full', MINMN, N, A, LDA, B, LDA )
GO TO 40
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DORGRQ', MINMN, N, MINMN, 0, NB )
RESLTS( INB, IM, ILDA, 2 ) = DMFLOP( OPS, TIME, INFO )
END IF
*
50 CONTINUE
60 CONTINUE
70 CONTINUE
*
* Print tables of results
*
DO 90 ISUB = 1, NSUBS - 1
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 90
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 80 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
80 CONTINUE
END IF
WRITE( NOUT, FMT = * )
IF( ISUB.EQ.2 )
$ WRITE( NOUT, FMT = 9996 )
CALL DPRTB4( '( NB, NX)', 'M', 'N', NNB, NBVAL, NXVAL, NM,
$ MVAL, NVAL, NLDA, RESLTS( 1, 1, 1, ISUB ), LDR1,
$ LDR2, NOUT )
90 CONTINUE
*
* Time DORMRQ separately. Here the starting matrix is M by N, and
* K is the free dimension of the matrix multiplied by Q.
*
IF( TIMSUB( 3 ) ) THEN
*
* Check that K <= LDA for the input values.
*
CALL ATIMCK( 3, CNAME, NK, KVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )SUBNAM( 3 )
GO TO 230
END IF
*
* Use only the pairs (M,N) where M <= N.
*
IMX = 0
DO 100 IM = 1, NM
IF( MVAL( IM ).LE.NVAL( IM ) ) THEN
IMX = IMX + 1
MUSE( IMX ) = MVAL( IM )
NUSE( IMX ) = NVAL( IM )
END IF
100 CONTINUE
*
* DORMRQ: Multiply by Q stored as a product of elementary
* transformations
*
* Do for each pair of values (M,N):
*
DO 180 IM = 1, IMX
M = MUSE( IM )
N = NUSE( IM )
*
* Do for each value of LDA:
*
DO 170 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
*
* Generate an M by N matrix and form its RQ decomposition.
*
CALL DLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', TAU,
$ MODE, COND, DMAX, M, N, 'No packing', A,
$ LDA, WORK, INFO )
LW = MAX( 1, M*MAX( 1, NB ) )
CALL DGERQF( M, N, A, LDA, TAU, WORK, LW, INFO )
*
* Do first for SIDE = 'L', then for SIDE = 'R'
*
I4 = 0
DO 160 ISIDE = 1, 2
SIDE = SIDES( ISIDE )
*
* Do for each pair of values (NB, NX) in NBVAL and
* NXVAL.
*
DO 150 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
*
* Do for each value of K in KVAL
*
DO 140 IK = 1, NK
K = KVAL( IK )
*
* Sort out which variable is which
*
IF( ISIDE.EQ.1 ) THEN
K1 = M
M1 = N
N1 = K
LW = MAX( 1, N1*MAX( 1, NB ) )
ELSE
K1 = M
N1 = N
M1 = K
LW = MAX( 1, M1*MAX( 1, NB ) )
END IF
*
* Do first for TRANS = 'N', then for TRANS = 'T'
*
ITOFF = 0
DO 130 ITRAN = 1, 2
TRANS = TRANSS( ITRAN )
CALL DTIMMG( 0, M1, N1, B, LDA, 0, 0 )
IC = 0
S1 = DSECND( )
110 CONTINUE
CALL DORMRQ( SIDE, TRANS, M1, N1, K1, A, LDA,
$ TAU, B, LDA, WORK, LW, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, M1, N1, B, LDA, 0, 0 )
GO TO 110
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
120 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, M1, N1, B, LDA, 0, 0 )
GO TO 120
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DORMRQ', M1, N1, K1, ISIDE-1,
$ NB )
RESLTS( INB, IM, ILDA,
$ I4+ITOFF+IK ) = DMFLOP( OPS, TIME, INFO )
ITOFF = NK
130 CONTINUE
140 CONTINUE
150 CONTINUE
I4 = 2*NK
160 CONTINUE
170 CONTINUE
180 CONTINUE
*
* Print tables of results
*
ISUB = 3
I4 = 1
IF( IMX.GE.1 ) THEN
DO 220 ISIDE = 1, 2
SIDE = SIDES( ISIDE )
IF( ISIDE.EQ.1 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 190 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
190 CONTINUE
END IF
END IF
DO 210 ITRAN = 1, 2
TRANS = TRANSS( ITRAN )
DO 200 IK = 1, NK
IF( ISIDE.EQ.1 ) THEN
N = KVAL( IK )
WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ), SIDE,
$ TRANS, 'N', N
LABM = 'M'
ELSE
M = KVAL( IK )
WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ), SIDE,
$ TRANS, 'M', M
LABM = 'N'
END IF
CALL DPRTB5( 'NB', 'K', LABM, NNB, NBVAL, IMX,
$ MUSE, NUSE, NLDA,
$ RESLTS( 1, 1, 1, I4 ), LDR1, LDR2,
$ NOUT )
I4 = I4 + 1
200 CONTINUE
210 CONTINUE
220 CONTINUE
ELSE
WRITE( NOUT, FMT = 9994 )SUBNAM( ISUB )
END IF
END IF
230 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
9996 FORMAT( 5X, 'K = min(M,N)', / )
9995 FORMAT( / 5X, A6, ' with SIDE = ''', A1, ''', TRANS = ''', A1,
$ ''', ', A1, ' =', I6, / )
9994 FORMAT( ' *** No pairs (M,N) found with M <= N: ', A6,
$ ' not timed' )
RETURN
*
* End of DTIMRQ
*
END
SUBROUTINE DTIMSP( LINE, NN, NVAL, NNS, NSVAL, LA, TIMMIN, A, B,
$ WORK, IWORK, RESLTS, LDR1, LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LA, LDR1, LDR2, LDR3, NN, NNS, NOUT
DOUBLE PRECISION TIMMIN
* ..
* .. Array Arguments ..
INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
DOUBLE PRECISION A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* DTIMSP times DSPTRF, -TRS, and -TRI.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix size N.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* LA (input) INTEGER
* The size of the arrays A, B, and C.
*
* TIMMIN (input) DOUBLE PRECISION
* The minimum time a subroutine will be timed.
*
* A (workspace) DOUBLE PRECISION array, dimension (LA)
*
* B (workspace) DOUBLE PRECISION array, dimension (LA)
*
* WORK (workspace) DOUBLE PRECISION array, dimension (NMAX)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
* where NMAX is the maximum value of N permitted.
*
* RESLTS (output) DOUBLE PRECISION array, dimension
* (LDR1,LDR2,LDR3,NSUBS)
* The timing results for each subroutine over the relevant
* values of N.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(4,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NN).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= 2.
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 3 )
* ..
* .. Local Scalars ..
CHARACTER UPLO
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, IC, ICL, IN, INFO, ISUB, IUPLO, LDA, LDB,
$ MAT, N, NRHS
DOUBLE PRECISION OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER UPLOS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER LAVAL( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DMFLOP, DOPLA, DSECND
EXTERNAL LSAME, DMFLOP, DOPLA, DSECND
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, DCOPY, DPRTBL, DSPTRF, DSPTRI,
$ DSPTRS, DTIMMG
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MOD
* ..
* .. Data statements ..
DATA UPLOS / 'U', 'L' /
DATA SUBNAM / 'DSPTRF', 'DSPTRS', 'DSPTRI' /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'SP'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 120
*
* Check that N*(N+1)/2 <= LA for the input values.
*
CNAME = LINE( 1: 6 )
LAVAL( 1 ) = LA
CALL ATIMCK( 4, CNAME, NN, NVAL, 1, LAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 120
END IF
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 90 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
IF( LSAME( UPLO, 'U' ) ) THEN
MAT = 7
ELSE
MAT = -7
END IF
*
* Do for each value of N in NVAL.
*
DO 80 IN = 1, NN
N = NVAL( IN )
LDA = N*( N+1 ) / 2
*
* Time DSPTRF
*
IF( TIMSUB( 1 ) ) THEN
CALL DTIMMG( MAT, N, N, A, LDA, 0, 0 )
IC = 0
S1 = DSECND( )
10 CONTINUE
CALL DSPTRF( UPLO, N, A, IWORK, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( MAT, N, N, A, LDA, 0, 0 )
GO TO 10
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
20 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( MAT, N, N, A, LDA, 0, 0 )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DSPTRF', N, N, 0, 0, 0 )
RESLTS( 1, IN, IUPLO, 1 ) = DMFLOP( OPS, TIME, INFO )
*
ELSE
IC = 0
CALL DTIMMG( MAT, N, N, A, LDA, 0, 0 )
END IF
*
* Generate another matrix and factor it using DSPTRF so
* that the factored form can be used in timing the other
* routines.
*
IF( IC.NE.1 )
$ CALL DSPTRF( UPLO, N, A, IWORK, INFO )
*
* Time DSPTRI
*
IF( TIMSUB( 3 ) ) THEN
CALL DCOPY( LDA, A, 1, B, 1 )
IC = 0
S1 = DSECND( )
30 CONTINUE
CALL DSPTRI( UPLO, N, B, IWORK, WORK, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DCOPY( LDA, A, 1, B, 1 )
GO TO 30
END IF
*
* Subtract the time used in DCOPY.
*
ICL = 1
S1 = DSECND( )
40 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DCOPY( LDA, A, 1, B, 1 )
GO TO 40
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DSPTRI', N, N, 0, 0, 0 )
RESLTS( 1, IN, IUPLO, 3 ) = DMFLOP( OPS, TIME, INFO )
END IF
*
* Time DSPTRS
*
IF( TIMSUB( 2 ) ) THEN
DO 70 I = 1, NNS
NRHS = NSVAL( I )
LDB = N
IF( MOD( LDB, 2 ).EQ.0 )
$ LDB = LDB + 1
CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 )
IC = 0
S1 = DSECND( )
50 CONTINUE
CALL DSPTRS( UPLO, N, NRHS, A, IWORK, B, LDB, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 50
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
60 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 60
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DSPTRS', N, NRHS, 0, 0, 0 )
RESLTS( I, IN, IUPLO, 2 ) = DMFLOP( OPS, TIME, INFO )
70 CONTINUE
END IF
80 CONTINUE
90 CONTINUE
*
* Print tables of results for each timed routine.
*
DO 110 ISUB = 1, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 110
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
DO 100 IUPLO = 1, 2
WRITE( NOUT, FMT = 9997 )SUBNAM( ISUB ), UPLOS( IUPLO )
IF( ISUB.EQ.1 ) THEN
CALL DPRTBL( ' ', 'N', 1, LAVAL, NN, NVAL, 1,
$ RESLTS( 1, 1, IUPLO, 1 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.2 ) THEN
CALL DPRTBL( 'NRHS', 'N', NNS, NSVAL, NN, NVAL, 1,
$ RESLTS( 1, 1, IUPLO, 2 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.3 ) THEN
CALL DPRTBL( ' ', 'N', 1, LAVAL, NN, NVAL, 1,
$ RESLTS( 1, 1, IUPLO, 3 ), LDR1, LDR2, NOUT )
END IF
100 CONTINUE
110 CONTINUE
120 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***', / )
9997 FORMAT( 5X, A6, ' with UPLO = ''', A1, '''', / )
RETURN
*
* End of DTIMSP
*
END
SUBROUTINE DTIMSY( LINE, NN, NVAL, NNS, NSVAL, NNB, NBVAL, NLDA,
$ LDAVAL, TIMMIN, A, B, WORK, IWORK, RESLTS,
$ LDR1, LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NLDA, NN, NNB, NNS, NOUT
DOUBLE PRECISION TIMMIN
* ..
* .. Array Arguments ..
INTEGER IWORK( * ), LDAVAL( * ), NBVAL( * ),
$ NSVAL( * ), NVAL( * )
DOUBLE PRECISION A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* DTIMSY times DSYTRF, -TRS, and -TRI.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix size N.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* NNB (input) INTEGER
* The number of values of NB contained in the vector NBVAL.
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) DOUBLE PRECISION
* The minimum time a subroutine will be timed.
*
* A (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values permitted
* for LDA and N.
*
* B (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension (NMAX)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* RESLTS (output) DOUBLE PRECISION array, dimension
* (LDR1,LDR2,LDR3,NSUBS)
* The timing results for each subroutine over the relevant
* values of N, NB, and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(4,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NN).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,2*NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 3 )
* ..
* .. Local Scalars ..
CHARACTER UPLO
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, I3, IC, ICL, ILDA, IN, INB, INFO, ISUB,
$ IUPLO, LDA, LDB, LWORK, MAT, N, NB, NRHS
DOUBLE PRECISION OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER UPLOS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DMFLOP, DOPLA, DSECND
EXTERNAL LSAME, DMFLOP, DOPLA, DSECND
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, DLACPY, DPRTBL, DSYTRF, DSYTRI,
$ DSYTRS, DTIMMG, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX
* ..
* .. Data statements ..
DATA UPLOS / 'U', 'L' /
DATA SUBNAM / 'DSYTRF', 'DSYTRS', 'DSYTRI' /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'SY'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 150
*
* Check that N <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 2, CNAME, NN, NVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 150
END IF
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 110 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
IF( LSAME( UPLO, 'U' ) ) THEN
MAT = 6
ELSE
MAT = -6
END IF
*
* Do for each value of N in NVAL.
*
DO 100 IN = 1, NN
N = NVAL( IN )
*
* Do for each value of LDA:
*
DO 90 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
I3 = ( IUPLO-1 )*NLDA + ILDA
*
* Do for each value of NB in NBVAL. Only the blocked
* routines are timed in this loop since the other routines
* are independent of NB.
*
IF( TIMSUB( 1 ) ) THEN
*
* Time DSYTRF
*
DO 30 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
LWORK = MAX( 2*N, NB*N )
CALL DTIMMG( MAT, N, N, A, LDA, 0, 0 )
IC = 0
S1 = DSECND( )
10 CONTINUE
CALL DSYTRF( UPLO, N, A, LDA, IWORK, B, LWORK,
$ INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( MAT, N, N, A, LDA, 0, 0 )
GO TO 10
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
20 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( MAT, N, N, B, LDA, 0, 0 )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DSYTRF', N, N, 0, 0, NB )
RESLTS( INB, IN, I3, 1 ) = DMFLOP( OPS, TIME,
$ INFO )
*
30 CONTINUE
ELSE
*
* If DSYTRF was not timed, generate a matrix and
* factor it using DSYTRF anyway so that the factored
* form of the matrix can be used in timing the other
* routines.
*
CALL DTIMMG( MAT, N, N, A, LDA, 0, 0 )
NB = 1
CALL XLAENV( 1, NB )
CALL DSYTRF( UPLO, N, A, LDA, IWORK, B, LWORK, INFO )
END IF
*
* Time DSYTRI
*
IF( TIMSUB( 3 ) ) THEN
CALL DLACPY( UPLO, N, N, A, LDA, B, LDA )
IC = 0
S1 = DSECND( )
40 CONTINUE
CALL DSYTRI( UPLO, N, B, LDA, IWORK, WORK, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DLACPY( UPLO, N, N, A, LDA, B, LDA )
GO TO 40
END IF
*
* Subtract the time used in DLACPY.
*
ICL = 1
S1 = DSECND( )
50 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DLACPY( UPLO, N, N, A, LDA, B, LDA )
GO TO 50
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DSYTRI', N, N, 0, 0, 0 )
RESLTS( 1, IN, I3, 3 ) = DMFLOP( OPS, TIME, INFO )
END IF
*
* Time DSYTRS
*
IF( TIMSUB( 2 ) ) THEN
DO 80 I = 1, NNS
NRHS = NSVAL( I )
LDB = LDA
CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 )
IC = 0
S1 = DSECND( )
60 CONTINUE
CALL DSYTRS( UPLO, N, NRHS, A, LDA, IWORK, B, LDB,
$ INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 60
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
70 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 70
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DSYTRS', N, NRHS, 0, 0, 0 )
RESLTS( I, IN, I3, 2 ) = DMFLOP( OPS, TIME, INFO )
80 CONTINUE
END IF
90 CONTINUE
100 CONTINUE
110 CONTINUE
*
* Print tables of results for each timed routine.
*
DO 140 ISUB = 1, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 140
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 120 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
120 CONTINUE
END IF
WRITE( NOUT, FMT = * )
DO 130 IUPLO = 1, 2
WRITE( NOUT, FMT = 9996 )SUBNAM( ISUB ), UPLOS( IUPLO )
I3 = ( IUPLO-1 )*NLDA + 1
IF( ISUB.EQ.1 ) THEN
CALL DPRTBL( 'NB', 'N', NNB, NBVAL, NN, NVAL, NLDA,
$ RESLTS( 1, 1, I3, 1 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.2 ) THEN
CALL DPRTBL( 'NRHS', 'N', NNS, NSVAL, NN, NVAL, NLDA,
$ RESLTS( 1, 1, I3, 2 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.3 ) THEN
CALL DPRTBL( ' ', 'N', 1, NBVAL, NN, NVAL, NLDA,
$ RESLTS( 1, 1, I3, 3 ), LDR1, LDR2, NOUT )
END IF
130 CONTINUE
140 CONTINUE
*
150 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted' )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
9996 FORMAT( 5X, A6, ' with UPLO = ''', A1, '''', / )
RETURN
*
* End of DTIMSY
*
END
SUBROUTINE DTIMTB( LINE, NN, NVAL, NK, KVAL, NNS, NSVAL, NLDA,
$ LDAVAL, TIMMIN, A, B, RESLTS, LDR1, LDR2, LDR3,
$ NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NK, NLDA, NN, NNS, NOUT
DOUBLE PRECISION TIMMIN
* ..
* .. Array Arguments ..
INTEGER KVAL( * ), LDAVAL( * ), NSVAL( * ), NVAL( * )
DOUBLE PRECISION A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * )
* ..
*
* Purpose
* =======
*
* DTIMTB times DTBTRS.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix size N.
*
* NK (input) INTEGER
* The number of values of K contained in the vector KVAL.
*
* KVAL (input) INTEGER array, dimension (NK)
* The values of the band width K.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) DOUBLE PRECISION
* The minimum time a subroutine will be timed.
*
* A (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values permitted
* for LDA and N.
*
* B (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
*
* RESLTS (output) DOUBLE PRECISION array, dimension
* (LDR1,LDR2,LDR3,NSUBS)
* The timing results for each subroutine over the relevant
* values of N, NB, and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NN).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,2*NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 1 )
* ..
* .. Local Scalars ..
CHARACTER UPLO
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, I3, IC, ICL, IK, ILDA, IN, INFO, ISUB,
$ IUPLO, K, LDA, LDB, MAT, N, NRHS
DOUBLE PRECISION OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER UPLOS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DMFLOP, DOPLA, DSECND
EXTERNAL LSAME, DMFLOP, DOPLA, DSECND
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, DPRTBL, DTBTRS, DTIMMG
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Data statements ..
DATA SUBNAM / 'DTBTRS' /
DATA UPLOS / 'U', 'L' /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'TB'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 110
*
* Check that K+1 <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 0, CNAME, NK, KVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 110
END IF
*
* Do for each value of N:
*
DO 100 IN = 1, NN
N = NVAL( IN )
LDB = N
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 60 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
IF( LSAME( UPLO, 'U' ) ) THEN
MAT = 11
ELSE
MAT = -11
END IF
*
* Do for each value of LDA:
*
DO 50 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
I3 = ( IUPLO-1 )*NLDA + ILDA
*
* Do for each value of the band width K:
*
DO 40 IK = 1, NK
K = KVAL( IK )
K = MAX( 0, MIN( K, N-1 ) )
*
* Time DTBTRS
*
IF( TIMSUB( 1 ) ) THEN
CALL DTIMMG( MAT, N, N, A, LDA, K, K )
DO 30 I = 1, NNS
NRHS = NSVAL( I )
CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 )
IC = 0
S1 = DSECND( )
10 CONTINUE
CALL DTBTRS( UPLO, 'No transpose', 'Non-unit',
$ N, K, NRHS, A, LDA, B, LDB, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 10
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
20 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DTBTRS', N, NRHS, K, K, 0 )
RESLTS( I, IK, I3, 1 ) = DMFLOP( OPS, TIME,
$ INFO )
30 CONTINUE
END IF
40 CONTINUE
50 CONTINUE
60 CONTINUE
*
* Print a table of results.
*
DO 90 ISUB = 1, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 90
*
* Print header for routine names.
*
IF( IN.EQ.1 .OR. CNAME.EQ.'DTB ' ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.EQ.1 ) THEN
WRITE( NOUT, FMT = 9997 )LDAVAL( 1 )
ELSE
DO 70 I = 1, NLDA
WRITE( NOUT, FMT = 9996 )I, LDAVAL( I )
70 CONTINUE
END IF
END IF
*
DO 80 IUPLO = 1, 2
WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ), N,
$ UPLOS( IUPLO )
I3 = ( IUPLO-1 )*NLDA + 1
IF( ISUB.EQ.1 ) THEN
CALL DPRTBL( 'NRHS', 'K', NNS, NSVAL, NK, KVAL, NLDA,
$ RESLTS( 1, 1, I3, 1 ), LDR1, LDR2, NOUT )
END IF
80 CONTINUE
90 CONTINUE
100 CONTINUE
*
110 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'with LDA = ', I5 )
9996 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
9995 FORMAT( / 5X, A6, ' with M =', I6, ', UPLO = ''', A1, '''', / )
RETURN
*
* End of DTIMTB
*
END
SUBROUTINE DTIMTD( LINE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
$ NLDA, LDAVAL, TIMMIN, A, B, D, TAU, WORK,
$ RESLTS, LDR1, LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NLDA, NM, NN, NNB, NOUT
DOUBLE PRECISION TIMMIN
* ..
* .. Array Arguments ..
INTEGER LDAVAL( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
$ NXVAL( * )
DOUBLE PRECISION A( * ), B( * ), D( * ),
$ RESLTS( LDR1, LDR2, LDR3, * ), TAU( * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* DTIMTD times the LAPACK routines DSYTRD, DORGTR, and DORMTR and the
* EISPACK routine TRED1.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix size M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) DOUBLE PRECISION
* The minimum time a subroutine will be timed.
*
* A (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values of LDA and N.
*
* B (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
*
* D (workspace) DOUBLE PRECISION array, dimension (2*NMAX-1)
*
* TAU (workspace) DOUBLE PRECISION array, dimension (NMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*NBMAX)
* where NBMAX is the maximum value of NB.
*
* RESLTS (workspace) DOUBLE PRECISION array, dimension
* (LDR1,LDR2,LDR3,4*NN+3)
* The timing results for each subroutine over the relevant
* values of M, (NB,NX), LDA, and N.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NM).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,2*NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* Internal Parameters
* ===================
*
* MODE INTEGER
* The matrix type. MODE = 3 is a geometric distribution of
* eigenvalues. See DLATMS for further details.
*
* COND DOUBLE PRECISION
* The condition number of the matrix. The singular values are
* set to values from DMAX to DMAX/COND.
*
* DMAX DOUBLE PRECISION
* The magnitude of the largest singular value.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 4 )
INTEGER MODE
DOUBLE PRECISION COND, DMAX
PARAMETER ( MODE = 3, COND = 100.0D0, DMAX = 1.0D0 )
* ..
* .. Local Scalars ..
CHARACTER LAB1, LAB2, SIDE, TRANS, UPLO
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, I3, I4, IC, ICL, ILDA, IM, IN, INB, INFO,
$ ISIDE, ISUB, ITOFF, ITRAN, IUPLO, LDA, LW, M,
$ M1, N, N1, NB, NX
DOUBLE PRECISION OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER SIDES( 2 ), TRANSS( 2 ), UPLOS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER ISEED( 4 ), RESEED( 4 )
* ..
* .. External Functions ..
DOUBLE PRECISION DMFLOP, DOPLA, DSECND
EXTERNAL DMFLOP, DOPLA, DSECND
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, DLACPY, DLATMS, DORGTR, DORMTR,
$ DPRTB3, DPRTBL, DSYTRD, DTIMMG, ICOPY, TRED1,
$ XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX
* ..
* .. Data statements ..
DATA SUBNAM / 'DSYTRD', 'TRED1', 'DORGTR',
$ 'DORMTR' /
DATA SIDES / 'L', 'R' / , TRANSS / 'N', 'T' / ,
$ UPLOS / 'U', 'L' /
DATA ISEED / 0, 0, 0, 1 /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'TD'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 240
*
* Check that M <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 2, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 240
END IF
*
* Check that K <= LDA for DORMTR
*
IF( TIMSUB( 4 ) ) THEN
CALL ATIMCK( 3, CNAME, NN, NVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )SUBNAM( 4 )
TIMSUB( 4 ) = .FALSE.
END IF
END IF
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 150 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
*
* Do for each value of M:
*
DO 140 IM = 1, NM
M = MVAL( IM )
CALL ICOPY( 4, ISEED, 1, RESEED, 1 )
*
* Do for each value of LDA:
*
DO 130 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
I3 = ( IUPLO-1 )*NLDA + ILDA
*
* Do for each pair of values (NB, NX) in NBVAL and NXVAL.
*
DO 120 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
LW = MAX( 1, M*MAX( 1, NB ) )
*
* Generate a test matrix of order M.
*
CALL ICOPY( 4, RESEED, 1, ISEED, 1 )
CALL DLATMS( M, M, 'Uniform', ISEED, 'Symmetric', TAU,
$ MODE, COND, DMAX, M, M, 'No packing', B,
$ LDA, WORK, INFO )
*
IF( TIMSUB( 2 ) .AND. INB.EQ.1 .AND. IUPLO.EQ.2 ) THEN
*
* TRED1: Eispack reduction using orthogonal
* transformations.
*
CALL DLACPY( UPLO, M, M, B, LDA, A, LDA )
IC = 0
S1 = DSECND( )
10 CONTINUE
CALL TRED1( LDA, M, A, D, D( M+1 ), D( M+1 ) )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DLACPY( UPLO, M, M, B, LDA, A, LDA )
GO TO 10
END IF
*
* Subtract the time used in DLACPY.
*
ICL = 1
S1 = DSECND( )
20 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DLACPY( UPLO, M, M, B, LDA, A, LDA )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DSYTRD', M, M, -1, -1, NB )
RESLTS( INB, IM, ILDA, 2 ) = DMFLOP( OPS, TIME,
$ INFO )
END IF
*
IF( TIMSUB( 1 ) ) THEN
*
* DSYTRD: Reduction to tridiagonal form
*
CALL DLACPY( UPLO, M, M, B, LDA, A, LDA )
IC = 0
S1 = DSECND( )
30 CONTINUE
CALL DSYTRD( UPLO, M, A, LDA, D, D( M+1 ), TAU,
$ WORK, LW, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DLACPY( UPLO, M, M, B, LDA, A, LDA )
GO TO 30
END IF
*
* Subtract the time used in DLACPY.
*
ICL = 1
S1 = DSECND( )
40 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DLACPY( UPLO, M, M, A, LDA, B, LDA )
GO TO 40
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DSYTRD', M, M, -1, -1, NB )
RESLTS( INB, IM, I3, 1 ) = DMFLOP( OPS, TIME,
$ INFO )
ELSE
*
* If DSYTRD was not timed, generate a matrix and
* factor it using DSYTRD anyway so that the factored
* form of the matrix can be used in timing the other
* routines.
*
CALL DLACPY( UPLO, M, M, B, LDA, A, LDA )
CALL DSYTRD( UPLO, M, A, LDA, D, D( M+1 ), TAU,
$ WORK, LW, INFO )
END IF
*
IF( TIMSUB( 3 ) ) THEN
*
* DORGTR: Generate the orthogonal matrix Q from the
* reduction to Hessenberg form A = Q*H*Q'
*
CALL DLACPY( UPLO, M, M, A, LDA, B, LDA )
IC = 0
S1 = DSECND( )
50 CONTINUE
CALL DORGTR( UPLO, M, B, LDA, TAU, WORK, LW, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DLACPY( UPLO, M, M, A, LDA, B, LDA )
GO TO 50
END IF
*
* Subtract the time used in DLACPY.
*
ICL = 1
S1 = DSECND( )
60 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DLACPY( UPLO, M, M, A, LDA, B, LDA )
GO TO 60
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
*
* Op count for DORGTR: same as
* DORGQR( N-1, N-1, N-1, ... )
*
OPS = DOPLA( 'DORGQR', M-1, M-1, M-1, -1, NB )
RESLTS( INB, IM, I3, 3 ) = DMFLOP( OPS, TIME,
$ INFO )
END IF
*
IF( TIMSUB( 4 ) ) THEN
*
* DORMTR: Multiply by Q stored as a product of
* elementary transformations
*
I4 = 3
DO 110 ISIDE = 1, 2
SIDE = SIDES( ISIDE )
DO 100 IN = 1, NN
N = NVAL( IN )
LW = MAX( 1, MAX( 1, NB )*N )
IF( ISIDE.EQ.1 ) THEN
M1 = M
N1 = N
ELSE
M1 = N
N1 = M
END IF
ITOFF = 0
DO 90 ITRAN = 1, 2
TRANS = TRANSS( ITRAN )
CALL DTIMMG( 0, M1, N1, B, LDA, 0, 0 )
IC = 0
S1 = DSECND( )
70 CONTINUE
CALL DORMTR( SIDE, UPLO, TRANS, M1, N1, A,
$ LDA, TAU, B, LDA, WORK, LW,
$ INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, M1, N1, B, LDA, 0, 0 )
GO TO 70
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
80 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, M1, N1, B, LDA, 0, 0 )
GO TO 80
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
*
* Op count for DORMTR, SIDE='L': same as
* DORMQR( 'L', TRANS, M-1, N, M-1, ...)
*
* Op count for DORMTR, SIDE='R': same as
* DORMQR( 'R', TRANS, M, N-1, N-1, ...)
*
IF( ISIDE.EQ.1 ) THEN
OPS = DOPLA( 'DORMQR', M1-1, N1, M1-1,
$ -1, NB )
ELSE
OPS = DOPLA( 'DORMQR', M1, N1-1, N1-1,
$ 1, NB )
END IF
*
RESLTS( INB, IM, I3,
$ I4+ITOFF+IN ) = DMFLOP( OPS, TIME,
$ INFO )
ITOFF = NN
90 CONTINUE
100 CONTINUE
I4 = I4 + 2*NN
110 CONTINUE
END IF
*
120 CONTINUE
130 CONTINUE
140 CONTINUE
150 CONTINUE
*
* Print tables of results for DSYTRD, TRED1, and DORGTR
*
DO 180 ISUB = 1, NSUBS - 1
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 180
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 160 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
160 CONTINUE
END IF
IF( ISUB.EQ.2 ) THEN
WRITE( NOUT, FMT = * )
CALL DPRTB3( ' ', 'N', 1, NBVAL, NXVAL, NM, MVAL, NLDA,
$ RESLTS( 1, 1, 1, ISUB ), LDR1, LDR2, NOUT )
ELSE
I3 = 1
DO 170 IUPLO = 1, 2
WRITE( NOUT, FMT = 9996 )SUBNAM( ISUB ), UPLOS( IUPLO )
CALL DPRTB3( '( NB, NX)', 'N', NNB, NBVAL, NXVAL, NM,
$ MVAL, NLDA, RESLTS( 1, 1, I3, ISUB ), LDR1,
$ LDR2, NOUT )
I3 = I3 + NLDA
170 CONTINUE
END IF
180 CONTINUE
*
* Print tables of results for DORMTR
*
ISUB = 4
IF( TIMSUB( ISUB ) ) THEN
I4 = 3
DO 230 ISIDE = 1, 2
IF( ISIDE.EQ.1 ) THEN
LAB1 = 'M'
LAB2 = 'N'
IF( NLDA.GT.1 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
DO 190 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
190 CONTINUE
END IF
ELSE
LAB1 = 'N'
LAB2 = 'M'
END IF
DO 220 ITRAN = 1, 2
DO 210 IN = 1, NN
I3 = 1
DO 200 IUPLO = 1, 2
WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ),
$ SIDES( ISIDE ), UPLOS( IUPLO ), TRANSS( ITRAN ),
$ LAB2, NVAL( IN )
CALL DPRTBL( 'NB', LAB1, NNB, NBVAL, NM, MVAL,
$ NLDA, RESLTS( 1, 1, I3, I4+IN ), LDR1,
$ LDR2, NOUT )
I3 = I3 + NLDA
200 CONTINUE
210 CONTINUE
I4 = I4 + NN
220 CONTINUE
230 CONTINUE
END IF
240 CONTINUE
*
* Print a table of results for each timed routine.
*
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops *** ' )
9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
9996 FORMAT( / 5X, A6, ' with UPLO = ''', A1, '''', / )
9995 FORMAT( / 5X, A6, ' with SIDE = ''', A1, ''', UPLO = ''', A1,
$ ''', TRANS = ''', A1, ''', ', A1, ' =', I6, / )
RETURN
*
* End of DTIMTD
*
END
SUBROUTINE DTIMTP( LINE, NN, NVAL, NNS, NSVAL, LA, TIMMIN, A, B,
$ RESLTS, LDR1, LDR2, LDR3, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LA, LDR1, LDR2, LDR3, NN, NNS, NOUT
DOUBLE PRECISION TIMMIN
* ..
* .. Array Arguments ..
INTEGER NSVAL( * ), NVAL( * )
DOUBLE PRECISION A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * )
* ..
*
* Purpose
* =======
*
* DTIMTP times DTPTRI and -TRS.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix size N.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* LA (input) INTEGER
* The size of the arrays A and B.
*
* TIMMIN (input) DOUBLE PRECISION
* The minimum time a subroutine will be timed.
*
* A (workspace) DOUBLE PRECISION array, dimension (LA)
*
* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
* where NMAX is the maximum value of N in NVAL.
*
* RESLTS (output) DOUBLE PRECISION array, dimension
* (LDR1,LDR2,LDR3,NSUBS)
* The timing results for each subroutine over the relevant
* values of N.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= 1.
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NN).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= 2.
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 2 )
* ..
* .. Local Scalars ..
CHARACTER UPLO
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, IC, ICL, IN, INFO, ISUB, IUPLO, LDA, LDB,
$ MAT, N, NRHS
DOUBLE PRECISION OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER UPLOS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
INTEGER IDUMMY( 1 ), LAVAL( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DMFLOP, DOPLA, DSECND
EXTERNAL LSAME, DMFLOP, DOPLA, DSECND
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, DPRTBL, DTIMMG, DTPTRI, DTPTRS
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MOD
* ..
* .. Data statements ..
DATA SUBNAM / 'DTPTRI', 'DTPTRS' /
DATA UPLOS / 'U', 'L' /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'TP'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 100
*
* Check that N*(N+1)/2 <= LA for the input values.
*
CNAME = LINE( 1: 6 )
LAVAL( 1 ) = LA
CALL ATIMCK( 4, CNAME, NN, NVAL, 1, LAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 100
END IF
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 70 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
IF( LSAME( UPLO, 'U' ) ) THEN
MAT = 10
ELSE
MAT = -10
END IF
*
* Do for each value of N:
*
DO 60 IN = 1, NN
N = NVAL( IN )
LDA = N*( N+1 ) / 2
LDB = N
IF( MOD( N, 2 ).EQ.0 )
$ LDB = LDB + 1
*
* Time DTPTRI
*
IF( TIMSUB( 1 ) ) THEN
CALL DTIMMG( MAT, N, N, A, LDA, 0, 0 )
IC = 0
S1 = DSECND( )
10 CONTINUE
CALL DTPTRI( UPLO, 'Non-unit', N, A, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( MAT, N, N, A, LDA, 0, 0 )
GO TO 10
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
20 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( MAT, N, N, A, LDA, 0, 0 )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DTPTRI', N, N, 0, 0, 0 )
RESLTS( 1, IN, IUPLO, 1 ) = DMFLOP( OPS, TIME, INFO )
ELSE
*
* Generate a triangular matrix A.
*
CALL DTIMMG( MAT, N, N, A, LDA, 0, 0 )
END IF
*
* Time DTPTRS
*
IF( TIMSUB( 2 ) ) THEN
DO 50 I = 1, NNS
NRHS = NSVAL( I )
CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 )
IC = 0
S1 = DSECND( )
30 CONTINUE
CALL DTPTRS( UPLO, 'No transpose', 'Non-unit', N,
$ NRHS, A, B, LDB, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 30
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
40 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 40
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DTPTRS', N, NRHS, 0, 0, 0 )
RESLTS( I, IN, IUPLO, 2 ) = DMFLOP( OPS, TIME, INFO )
50 CONTINUE
END IF
60 CONTINUE
70 CONTINUE
*
* Print a table of results.
*
DO 90 ISUB = 1, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 90
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
DO 80 IUPLO = 1, 2
WRITE( NOUT, FMT = 9997 )SUBNAM( ISUB ), UPLOS( IUPLO )
IF( ISUB.EQ.1 ) THEN
CALL DPRTBL( ' ', 'N', 1, IDUMMY, NN, NVAL, 1,
$ RESLTS( 1, 1, IUPLO, 1 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.2 ) THEN
CALL DPRTBL( 'NRHS', 'N', NNS, NSVAL, NN, NVAL, 1,
$ RESLTS( 1, 1, IUPLO, 2 ), LDR1, LDR2, NOUT )
END IF
80 CONTINUE
90 CONTINUE
*
100 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***', / )
9997 FORMAT( 5X, A6, ' with UPLO = ''', A1, '''', / )
RETURN
*
* End of DTIMTP
*
END
SUBROUTINE DTIMTR( LINE, NN, NVAL, NNS, NSVAL, NNB, NBVAL, NLDA,
$ LDAVAL, TIMMIN, A, B, RESLTS, LDR1, LDR2, LDR3,
$ NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER LDR1, LDR2, LDR3, NLDA, NN, NNB, NNS, NOUT
DOUBLE PRECISION TIMMIN
* ..
* .. Array Arguments ..
INTEGER LDAVAL( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
DOUBLE PRECISION A( * ), B( * ), RESLTS( LDR1, LDR2, LDR3, * )
* ..
*
* Purpose
* =======
*
* DTIMTR times DTRTRI and -TRS.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line that requested this routine. The first six
* characters contain either the name of a subroutine or a
* generic path name. The remaining characters may be used to
* specify the individual routines to be timed. See ATIMIN for
* a full description of the format of the input line.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix size N.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* NNB (input) INTEGER
* The number of values of NB contained in the vector NBVAL.
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NLDA (input) INTEGER
* The number of values of LDA contained in the vector LDAVAL.
*
* LDAVAL (input) INTEGER array, dimension (NLDA)
* The values of the leading dimension of the array A.
*
* TIMMIN (input) DOUBLE PRECISION
* The minimum time a subroutine will be timed.
*
* A (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
* where LDAMAX and NMAX are the maximum values permitted
* for LDA and N.
*
* B (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
*
* RESLTS (output) DOUBLE PRECISION array, dimension
* (LDR1,LDR2,LDR3,NSUBS)
* The timing results for each subroutine over the relevant
* values of N, NB, and LDA.
*
* LDR1 (input) INTEGER
* The first dimension of RESLTS. LDR1 >= max(1,NNB).
*
* LDR2 (input) INTEGER
* The second dimension of RESLTS. LDR2 >= max(1,NN).
*
* LDR3 (input) INTEGER
* The third dimension of RESLTS. LDR3 >= max(1,2*NLDA).
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NSUBS
PARAMETER ( NSUBS = 2 )
* ..
* .. Local Scalars ..
CHARACTER UPLO
CHARACTER*3 PATH
CHARACTER*6 CNAME
INTEGER I, I3, IC, ICL, ILDA, IN, INB, INFO, ISUB,
$ IUPLO, LDA, LDB, MAT, N, NB, NRHS
DOUBLE PRECISION OPS, S1, S2, TIME, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER UPLOS( 2 )
CHARACTER*6 SUBNAM( NSUBS )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DMFLOP, DOPLA, DSECND
EXTERNAL LSAME, DMFLOP, DOPLA, DSECND
* ..
* .. External Subroutines ..
EXTERNAL ATIMCK, ATIMIN, DPRTBL, DTIMMG, DTRTRI, DTRTRS,
$ XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Data statements ..
DATA SUBNAM / 'DTRTRI', 'DTRTRS' /
DATA UPLOS / 'U', 'L' /
* ..
* .. Executable Statements ..
*
* Extract the timing request from the input line.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'TR'
CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ GO TO 130
*
* Check that N <= LDA for the input values.
*
CNAME = LINE( 1: 6 )
CALL ATIMCK( 2, CNAME, NN, NVAL, NLDA, LDAVAL, NOUT, INFO )
IF( INFO.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
GO TO 130
END IF
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 90 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
IF( LSAME( UPLO, 'U' ) ) THEN
MAT = 9
ELSE
MAT = -9
END IF
*
* Do for each value of N:
*
DO 80 IN = 1, NN
N = NVAL( IN )
*
* Do for each value of LDA:
*
DO 70 ILDA = 1, NLDA
LDA = LDAVAL( ILDA )
I3 = ( IUPLO-1 )*NLDA + ILDA
*
* Do for each value of NB in NBVAL. Only the blocked
* routines are timed in this loop since the other routines
* are independent of NB.
*
IF( TIMSUB( 1 ) ) THEN
DO 30 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
*
* Time DTRTRI
*
CALL DTIMMG( MAT, N, N, A, LDA, 0, 0 )
IC = 0
S1 = DSECND( )
10 CONTINUE
CALL DTRTRI( UPLO, 'Non-unit', N, A, LDA, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( MAT, N, N, A, LDA, 0, 0 )
GO TO 10
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
20 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( MAT, N, N, A, LDA, 0, 0 )
GO TO 20
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DTRTRI', N, N, 0, 0, NB )
RESLTS( INB, IN, I3, 1 ) = DMFLOP( OPS, TIME,
$ INFO )
30 CONTINUE
ELSE
*
* Generate a triangular matrix A.
*
CALL DTIMMG( MAT, N, N, A, LDA, 0, 0 )
END IF
*
* Time DTRTRS
*
IF( TIMSUB( 2 ) ) THEN
DO 60 I = 1, NNS
NRHS = NSVAL( I )
LDB = LDA
CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 )
IC = 0
S1 = DSECND( )
40 CONTINUE
CALL DTRTRS( UPLO, 'No transpose', 'Non-unit', N,
$ NRHS, A, LDA, B, LDB, INFO )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN ) THEN
CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 40
END IF
*
* Subtract the time used in DTIMMG.
*
ICL = 1
S1 = DSECND( )
50 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
ICL = ICL + 1
IF( ICL.LE.IC ) THEN
CALL DTIMMG( 0, N, NRHS, B, LDB, 0, 0 )
GO TO 50
END IF
*
TIME = ( TIME-UNTIME ) / DBLE( IC )
OPS = DOPLA( 'DTRTRS', N, NRHS, 0, 0, 0 )
RESLTS( I, IN, I3, 2 ) = DMFLOP( OPS, TIME, INFO )
60 CONTINUE
END IF
70 CONTINUE
80 CONTINUE
90 CONTINUE
*
* Print a table of results.
*
DO 120 ISUB = 1, NSUBS
IF( .NOT.TIMSUB( ISUB ) )
$ GO TO 120
WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
IF( NLDA.GT.1 ) THEN
DO 100 I = 1, NLDA
WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
100 CONTINUE
END IF
WRITE( NOUT, FMT = * )
DO 110 IUPLO = 1, 2
WRITE( NOUT, FMT = 9996 )SUBNAM( ISUB ), UPLOS( IUPLO )
I3 = ( IUPLO-1 )*NLDA + 1
IF( ISUB.EQ.1 ) THEN
CALL DPRTBL( 'NB', 'N', NNB, NBVAL, NN, NVAL, NLDA,
$ RESLTS( 1, 1, I3, 1 ), LDR1, LDR2, NOUT )
ELSE IF( ISUB.EQ.2 ) THEN
CALL DPRTBL( 'NRHS', 'N', NNS, NSVAL, NN, NVAL, NLDA,
$ RESLTS( 1, 1, I3, 2 ), LDR1, LDR2, NOUT )
END IF
110 CONTINUE
120 CONTINUE
*
130 CONTINUE
9999 FORMAT( 1X, A6, ' timing run not attempted', / )
9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
9996 FORMAT( 5X, A6, ' with UPLO = ''', A1, '''', / )
RETURN
*
* End of DTIMTR
*
END
SUBROUTINE ICOPY( N, SX, INCX, SY, INCY )
*
* -- LAPACK auxiliary test routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
INTEGER INCX, INCY, N
* ..
* .. Array Arguments ..
INTEGER SX( * ), SY( * )
* ..
*
* Purpose
* =======
*
* ICOPY copies an integer vector x to an integer vector y.
* Uses unrolled loops for increments equal to 1.
*
* Arguments
* =========
*
* N (input) INTEGER
* The length of the vectors SX and SY.
*
* SX (input) INTEGER array, dimension (1+(N-1)*abs(INCX))
* The vector X.
*
* INCX (input) INTEGER
* The spacing between consecutive elements of SX.
*
* SY (output) INTEGER array, dimension (1+(N-1)*abs(INCY))
* The vector Y.
*
* INCY (input) INTEGER
* The spacing between consecutive elements of SY.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, IX, IY, M, MP1
* ..
* .. Intrinsic Functions ..
INTRINSIC MOD
* ..
* .. Executable Statements ..
*
IF( N.LE.0 )
$ RETURN
IF( INCX.EQ.1 .AND. INCY.EQ.1 )
$ GO TO 20
*
* 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 10 I = 1, N
SY( IY ) = SX( IX )
IX = IX + INCX
IY = IY + INCY
10 CONTINUE
RETURN
*
* Code for both increments equal to 1
*
* Clean-up loop
*
20 CONTINUE
M = MOD( N, 7 )
IF( M.EQ.0 )
$ GO TO 40
DO 30 I = 1, M
SY( I ) = SX( I )
30 CONTINUE
IF( N.LT.7 )
$ RETURN
40 CONTINUE
MP1 = M + 1
DO 50 I = MP1, N, 7
SY( I ) = SX( I )
SY( I+1 ) = SX( I+1 )
SY( I+2 ) = SX( I+2 )
SY( I+3 ) = SX( I+3 )
SY( I+4 ) = SX( I+4 )
SY( I+5 ) = SX( I+5 )
SY( I+6 ) = SX( I+6 )
50 CONTINUE
RETURN
*
* End of ICOPY
*
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/lin/lsamen.f 0000644 0001750 0001750 00000003756 10616163243 023253 0 ustar osallou osallou LOGICAL FUNCTION LSAMEN( N, CA, CB )
*
* -- LAPACK auxiliary routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* Commented out arg check for java translation. This is a hack
* to get the timers running since the LEN() intrinsic doesn't
* work correctly in f2j'd code. 6/21/01 Keith
*
* .. Scalar Arguments ..
CHARACTER*( * ) CA, CB
INTEGER N
* ..
*
* Purpose
* =======
*
* LSAMEN tests if the first N letters of CA are the same as the
* first N letters of CB, regardless of case.
* LSAMEN returns .TRUE. if CA and CB are equivalent except for case
* and .FALSE. otherwise. LSAMEN also returns .FALSE. if LEN( CA )
* or LEN( CB ) is less than N.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of characters in CA and CB to be compared.
*
* CA (input) CHARACTER*(*)
* CB (input) CHARACTER*(*)
* CA and CB specify two character strings of length at least N.
* Only the first N characters of each string will be accessed.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC LEN
* ..
* .. Executable Statements ..
*
LSAMEN = .FALSE.
*
* Commented out arg check for java translation. --Keith
*
* IF( LEN( CA ).LT.N .OR. LEN( CB ).LT.N )
* $ GO TO 20
*
N = MIN( LEN(CA), LEN(CB) )
*
* Do for each character in the two strings.
*
DO 10 I = 1, N
*
* Test if the characters are equal using LSAME.
*
IF( .NOT.LSAME( CA( I: I ), CB( I: I ) ) )
$ GO TO 20
*
10 CONTINUE
LSAMEN = .TRUE.
*
20 CONTINUE
RETURN
*
* End of LSAMEN
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/lin/Makefile 0000644 0001750 0001750 00000003043 10616163243 023252 0 ustar osallou osallou .PHONY: DUMMY util
.SUFFIXES: .f .java
ROOT=../../..
include $(ROOT)/make.def
BLAS=$(ROOT)/$(BLAS_IDX)
LAPACK=$(ROOT)/$(LAPACK_IDX)
MATGEN=$(ROOT)/$(MATGEN_IDX)
XERBLAFLAGS= -c .:$(ROOT)/$(BLAS_OBJ) -p $(ERR_PACKAGE)
F2JFLAGS=-c .:$(OUTDIR):linsrc/$(OUTDIR):$(ROOT)/$(BLAS_OBJ):$(ROOT)/$(ERR_OBJ):$(ROOT)/$(LAPACK_OBJ):$(ROOT)/$(MATGEN_OBJ) -p $(LINTIME_PACKAGE) -o $(OUTDIR)
TIMER_CLASSPATH=-cp .:./obj:$(ROOT)/$(ERR_OBJ):linsrc/$(OUTDIR):$(ROOT)/$(MATGEN_OBJ):$(ROOT)/$(BLAS_OBJ):$(ROOT)/$(LAPACK_OBJ):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
timer: $(BLAS) $(LAPACK) $(MATGEN) linsrc/$(OUTDIR)/Linsrc.f2j $(OUTDIR)/Lintime.f2j util
/bin/rm -f $(LINTIME_JAR)
cd linsrc/$(OUTDIR); $(JAR) cvf ../../$(LINTIME_JAR) `find . -name "*.class"`
cd $(OUTDIR); $(JAR) uvf ../$(LINTIME_JAR) `find . -name "*.class"`
linsrc/$(OUTDIR)/Linsrc.f2j: linsrc/linsrc.f
cd linsrc;$(MAKE)
$(OUTDIR)/Lintime.f2j: $(OUTDIR)/Lsamen.f2j lintime.f
$(F2J) $(F2JFLAGS) lintime.f > /dev/null
$(OUTDIR)/Lsamen.f2j: lsamen.f
$(F2J) $(F2JFLAGS) $< > /dev/null
$(BLAS):
cd $(ROOT)/$(BLAS_DIR); $(MAKE)
$(LAPACK):
cd $(ROOT)/$(LAPACK_DIR); $(MAKE)
$(MATGEN):
cd $(ROOT)/$(MATGEN_DIR); $(MAKE)
util:
cd $(ROOT)/$(UTIL_DIR); $(MAKE)
runtimer: small
small: timer d*.in
large: timer input_files_large/D*.in
*.in: DUMMY
java $(MORE_MEM_FLAG) $(TIMER_CLASSPATH) $(LINTIME_PACKAGE).Dtimaa < $@
input_files_large/*.in: DUMMY
java $(MORE_MEM_FLAG) $(TIMER_CLASSPATH) $(LINTIME_PACKAGE).Dtimaa < $@
clean:
cd linsrc;$(MAKE) clean
/bin/rm -rf *.java *.class *.f2j $(OUTDIR) $(LINTIME_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/lin/dband.in 0000644 0001750 0001750 00000001450 10616163243 023212 0 ustar osallou osallou LAPACK timing, DOUBLE PRECISION band matrices
1 Number of values of M
200 Values of M (row dimension)
5 Number of values of K
10 20 30 40 50 Values of K (bandwidth)
4 Number of values of NRHS
1 2 4 8 Values of NRHS
2 Number of values of NB
1 8 Values of NB (blocksize)
0 8 Values of NX (crossover point)
1 Number of values of LDA
152 Values of LDA (leading dimension)
0.05 Minimum time in seconds
BAND Time sample banded BLAS
DGB
DPB
DTB
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/lin/dtime.in 0000644 0001750 0001750 00000001670 10616163243 023250 0 ustar osallou osallou LAPACK timing, DOUBLE PRECISION square matrices
5 Number of values of M
10 20 40 60 80 Values of M (row dimension)
5 Number of values of N
10 20 40 60 80 Values of N (column dimension)
2 Number of values of K
20 80 Values of K
2 Number of values of NB
1 8 Values of NB (blocksize)
0 8 Values of NX (crossover point)
1 Number of values of LDA
81 Values of LDA (leading dimension)
0.05 Minimum time in seconds
DGE T T T
DPO T T T
DPP T T T
DSY T T T
DSP T T T
DTR T T
DTP T T
DQR T T T
DLQ T T T
DQL T T T
DRQ T T T
DQP T
DHR T T T T
DTD T T T T
DBR T T T
DLS T T T T T T
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/lin/dtime2.in 0000644 0001750 0001750 00000001472 10616163243 023332 0 ustar osallou osallou LAPACK timing, DOUBLE PRECISION rectangular matrices
7 Number of values of M
20 40 20 40 80 40 80 Values of M (row dimension)
7 Number of values of N
20 20 40 40 40 80 80 Values of N (column dimension)
2 Number of values of K
20 80 Values of K
2 Number of values of NB
1 8 Values of NB (blocksize)
0 8 Values of NX (crossover point)
1 Number of values of LDA
81 Values of LDA (leading dimension)
0.05 Minimum time in seconds
none
DQR T T T
DLQ T T T
DQL T T T
DRQ T T T
DQP T
DBR T T F
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/lin/dblasa.in 0000644 0001750 0001750 00000001141 10616163243 023365 0 ustar osallou osallou BLAS timing, DOUBLE PRECISION data, K small
5 Number of values of M
10 20 40 60 80 Values of M
5 Number of values of N
10 20 40 60 80 Values of N
2 Number of values of K
2 16 Values of K
1 Number of values of INCX
1 Values of INCX
1 Number of values of LDA
81 Values of LDA
0.05 Minimum time in seconds
none Do not time the sample BLAS
DB2
DB3
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/lin/input_files_large/ 0000755 0001750 0001750 00000000000 11734055026 025306 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/lin/input_files_large/DBAND.in 0000644 0001750 0001750 00000001450 10616163243 026445 0 ustar osallou osallou LAPACK timing, DOUBLE PRECISION band matrices
1 Number of values of M
1000 Values of M (row dimension)
5 Number of values of K
25 50 100 150 200 Values of K (bandwidth)
4 Number of values of NRHS
1 2 16 100 Values of NRHS
5 Number of values of NB
1 16 32 48 64 Values of NB (blocksize)
0 48 128 128 128 Values of NX (crossover point)
1 Number of values of LDA
602 Values of LDA (leading dimension)
0.0 Minimum time in seconds
BAND Time sample banded BLAS
DGB
DPB
DTB
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/lin/input_files_large/DTIME.in 0000644 0001750 0001750 00000001722 10616163244 026502 0 ustar osallou osallou LAPACK timing, DOUBLE PRECISION square matrices
6 Number of values of M
50 100 200 300 400 500 Values of M (row dimension)
6 Number of values of N
50 100 200 300 400 500 Values of N (column dimension)
4 Number of values of K
1 2 16 100 Values of K
5 Number of values of NB
1 16 32 48 64 Values of NB (blocksize)
0 48 128 128 128 Values of NX (crossover point)
1 Number of values of LDA
513 Values of LDA (leading dimension)
0.0 Minimum time in seconds
DGE T T T
DGT T T T
DPO T T T
DPP T T T
DPT T T T
DSY T T T
DSP T T T
DTR T T
DTP T T
DQR T T T
DLQ T T T
DQL T T T
DRQ T T T
DQP T
DHR T T T T
DTD T T T T
DBR T T T
DLS T T T T T T
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/lin/input_files_large/DBLASA.in 0000644 0001750 0001750 00000001141 10616163243 026560 0 ustar osallou osallou BLAS timing, DOUBLE PRECISION data, K small
6 Number of values of M
50 100 200 300 400 500 Values of M
6 Number of values of N
50 100 200 300 400 500 Values of N
5 Number of values of K
2 16 32 48 64 Values of K
1 Number of values of INCX
1 Values of INCX
1 Number of values of LDA
513 Values of LDA
0.0 Minimum time in seconds
none Do not time the sample BLAS
DB2
DB3
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/lin/input_files_large/DTIME2.in 0000644 0001750 0001750 00000001472 10616163244 026566 0 ustar osallou osallou LAPACK timing, DOUBLE PRECISION rectangular matrices
7 Number of values of M
100 200 100 200 400 200 400 Values of M (row dimension)
7 Number of values of N
100 100 200 200 200 400 400 Values of N (column dimension)
4 Number of values of K
1 2 16 100 Values of K
5 Number of values of NB
1 16 32 48 64 Values of NB (blocksize)
0 48 128 128 128 Values of NX (crossover point)
1 Number of values of LDA
401 Values of LDA (leading dimension)
0.0 Minimum time in seconds
none
DQR T T T
DLQ T T T
DQL T T T
DRQ T T T
DQP T
DBR T T F
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/lin/input_files_large/DBLASB.in 0000644 0001750 0001750 00000001160 10616163244 026563 0 ustar osallou osallou BLAS timing, DOUBLE PRECISION data, M small
5 Number of values of M
2 16 32 48 64 Values of M
6 Number of values of N
50 100 200 300 400 500 Values of N
6 Number of values of K
50 100 200 300 400 500 Values of K
1 Number of values of INCX
1 Values of INCX
1 Number of values of LDA
513 Values of LDA
0.0 Minimum time in seconds
none Do not time the sample BLAS
DGEMM
DSYMM
DTRMM
DTRSM
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/lin/input_files_large/DBLASC.in 0000644 0001750 0001750 00000001160 10616163244 026564 0 ustar osallou osallou BLAS timing, DOUBLE PRECISION data, N small
6 Number of values of M
50 100 200 300 400 500 Values of M
5 Number of values of N
2 16 32 48 64 Values of N
6 Number of values of K
50 100 200 300 400 500 Values of K
1 Number of values of INCX
1 Values of INCX
1 Number of values of LDA
513 Values of LDA
0.0 Minimum time in seconds
none Do not time the sample BLAS
DGEMM
DSYMM
DTRMM
DTRSM
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/eig/ 0000755 0001750 0001750 00000000000 11734055026 021575 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/eig/dsvdtim.in 0000644 0001750 0001750 00000001124 10616163242 023573 0 ustar osallou osallou SVD: Data file for timing Singular Value Decomposition routines
7 Number of values of M and N
10 10 20 20 20 40 40 Values of M (row dimension)
10 20 10 20 40 20 40 Values of N (column dimension)
1 Number of values of parameters
1 Values of NB (blocksize)
81 Values of LDA (leading dimension)
0.05 Minimum time in seconds
4 Number of matrix types
1 2 3 4
DBD T T T T T T T T T T T T T T T T T T
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/eig/Makefile 0000644 0001750 0001750 00000002632 10616163242 023236 0 ustar osallou osallou .PHONY: DUMMY util
.SUFFIXES: .f .java
ROOT=../../..
include $(ROOT)/make.def
BLAS=$(ROOT)/$(BLAS_IDX)
LAPACK=$(ROOT)/$(LAPACK_IDX)
MATGEN=$(ROOT)/$(MATGEN_IDX)
XERBLAFLAGS= -c .:$(ROOT)/$(BLAS_OBJ) -p $(ERR_PACKAGE)
F2JFLAGS=-c .:eigsrc/$(OUTDIR):$(ROOT)/$(BLAS_OBJ):$(ROOT)/$(LAPACK_OBJ):$(ROOT)/$(MATGEN_OBJ) -p $(EIGTIME_PACKAGE) -o $(OUTDIR)
TIMER_CLASSPATH=-cp .:./obj:eigsrc/$(OUTDIR):$(ROOT)/$(MATGEN_OBJ):$(ROOT)/$(BLAS_OBJ):$(ROOT)/$(LAPACK_OBJ):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
timer: $(BLAS) $(LAPACK) $(MATGEN) eigsrc/$(OUTDIR)/Eigsrc.f2j $(OUTDIR)/Eigtime.f2j util
/bin/rm -f $(EIGTIME_JAR)
cd eigsrc/$(OUTDIR); $(JAR) cvf ../../$(EIGTIME_JAR) `find . -name "*.class"`
cd $(OUTDIR); $(JAR) uvf ../$(EIGTIME_JAR) `find . -name "*.class"`
eigsrc/$(OUTDIR)/Eigsrc.f2j: eigsrc/eigsrc.f
cd eigsrc;$(MAKE)
$(OUTDIR)/Eigtime.f2j: eigtime.f
$(F2J) $(F2JFLAGS) eigtime.f > /dev/null
$(BLAS):
cd $(ROOT)/$(BLAS_DIR); $(MAKE)
$(LAPACK):
cd $(ROOT)/$(LAPACK_DIR); $(MAKE)
$(MATGEN):
cd $(ROOT)/$(MATGEN_DIR); $(MAKE)
util:
cd $(ROOT)/$(UTIL_DIR); $(MAKE)
runtimer: small
small: timer d*.in
large: timer input_files_large/D*.in
*.in: DUMMY
java $(MORE_MEM_FLAG) $(TIMER_CLASSPATH) $(EIGTIME_PACKAGE).Dtimee < $@
input_files_large/*.in: DUMMY
java $(MORE_MEM_FLAG) $(TIMER_CLASSPATH) $(EIGTIME_PACKAGE).Dtimee < $@
clean:
cd eigsrc;$(MAKE) clean
/bin/rm -rf *.java *.class *.f2j $(OUTDIR) $(EIGTIME_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/eig/dseptim.in 0000644 0001750 0001750 00000001015 10616163242 023565 0 ustar osallou osallou SEP: Data file for timing Symmetric Eigenvalue Problem routines
5 Number of values of N
10 20 40 60 80 Values of N (dimension)
2 Number of values of parameters
1 16 Values of NB (blocksize)
81 81 Values of LDA (leading dimension)
0.05 Minimum time in seconds
4 Number of matrix types
DST T T T T T T T T T T T T T T T T T T T T T T T
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/eig/dneptim.in 0000644 0001750 0001750 00000001215 10616163242 023562 0 ustar osallou osallou NEP: Data file for timing Nonsymmetric Eigenvalue Problem routines
4 Number of values of N
10 20 30 40 Values of N (dimension)
4 Number of values of parameters
1 1 1 1 Values of NB (blocksize)
2 4 6 2 Values of NS (number of shifts)
12 12 12 50 Values of MAXB (multishift crossover pt)
81 81 81 81 Values of LDA (leading dimension)
0.05 Minimum time in seconds
4 Number of matrix types
1 3 4 6
DHS T T T T T T T T T T T T
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/eig/eigsrc/ 0000755 0001750 0001750 00000000000 11734055026 023051 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/eig/eigsrc/Makefile 0000644 0001750 0001750 00000000746 10616163243 024517 0 ustar osallou osallou .SUFFIXES: .f .java
ROOT=../../../..
include $(ROOT)/make.def
BLAS=$(ROOT)/$(BLAS_IDX)
LAPACK=$(ROOT)/$(LAPACK_IDX)
F2JFLAGS=-c .:$(ROOT)/$(BLAS_OBJ):$(ROOT)/$(ERR_OBJ):$(ROOT)/$(LAPACK_OBJ) -p $(EIGSRC_PACKAGE) -o $(OUTDIR)
tester: $(BLAS) $(LAPACK) $(OUTDIR)/Eigsrc.f2j
$(OUTDIR)/Eigsrc.f2j: eigsrc.f
$(F2J) $(F2JFLAGS) $< > /dev/null
$(BLAS):
cd $(ROOT)/$(BLAS_DIR); $(MAKE)
$(LAPACK):
cd $(ROOT)/$(LAPACK_DIR); $(MAKE)
clean:
/bin/rm -rf *.java *.class *.f2j $(OUTDIR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/eig/eigsrc/eigsrc.f 0000644 0001750 0001750 00003117732 10616163243 024511 0 ustar osallou osallou SUBROUTINE DBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ,
$ WORK, IWORK, INFO )
*
* -- LAPACK routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
CHARACTER COMPQ, UPLO
INTEGER INFO, LDU, LDVT, N
* ..
* .. Array Arguments ..
INTEGER IQ( * ), IWORK( * )
DOUBLE PRECISION D( * ), E( * ), Q( * ), U( LDU, * ),
$ VT( LDVT, * ), WORK( * )
* ..
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DBDSDC computes the singular value decomposition (SVD) of a real
* N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT,
* using a divide and conquer method, where S is a diagonal matrix
* with non-negative diagonal elements (the singular values of B), and
* U and VT are orthogonal matrices of left and right singular vectors,
* respectively. DBDSDC can be used to compute all singular values,
* and optionally, singular vectors or singular vectors in compact form.
*
* This code makes very mild assumptions about floating point
* arithmetic. It will work on machines with a guard digit in
* add/subtract, or on those binary machines without guard digits
* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
* It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none. See DLASD3 for details.
*
* The code currently call DLASDQ if singular values only are desired.
* However, it can be slightly modified to compute singular values
* using the divide and conquer method.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': B is upper bidiagonal.
* = 'L': B is lower bidiagonal.
*
* COMPQ (input) CHARACTER*1
* Specifies whether singular vectors are to be computed
* as follows:
* = 'N': Compute singular values only;
* = 'P': Compute singular values and compute singular
* vectors in compact form;
* = 'I': Compute singular values and singular vectors.
*
* N (input) INTEGER
* The order of the matrix B. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the n diagonal elements of the bidiagonal matrix B.
* On exit, if INFO=0, the singular values of B.
*
* E (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the elements of E contain the offdiagonal
* elements of the bidiagonal matrix whose SVD is desired.
* On exit, E has been destroyed.
*
* U (output) DOUBLE PRECISION array, dimension (LDU,N)
* If COMPQ = 'I', then:
* On exit, if INFO = 0, U contains the left singular vectors
* of the bidiagonal matrix.
* For other values of COMPQ, U is not referenced.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= 1.
* If singular vectors are desired, then LDU >= max( 1, N ).
*
* VT (output) DOUBLE PRECISION array, dimension (LDVT,N)
* If COMPQ = 'I', then:
* On exit, if INFO = 0, VT' contains the right singular
* vectors of the bidiagonal matrix.
* For other values of COMPQ, VT is not referenced.
*
* LDVT (input) INTEGER
* The leading dimension of the array VT. LDVT >= 1.
* If singular vectors are desired, then LDVT >= max( 1, N ).
*
* Q (output) DOUBLE PRECISION array, dimension (LDQ)
* If COMPQ = 'P', then:
* On exit, if INFO = 0, Q and IQ contain the left
* and right singular vectors in a compact form,
* requiring O(N log N) space instead of 2*N**2.
* In particular, Q contains all the DOUBLE PRECISION data in
* LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))
* words of memory, where SMLSIZ is returned by ILAENV and
* is equal to the maximum size of the subproblems at the
* bottom of the computation tree (usually about 25).
* For other values of COMPQ, Q is not referenced.
*
* IQ (output) INTEGER array, dimension (LDIQ)
* If COMPQ = 'P', then:
* On exit, if INFO = 0, Q and IQ contain the left
* and right singular vectors in a compact form,
* requiring O(N log N) space instead of 2*N**2.
* In particular, IQ contains all INTEGER data in
* LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))
* words of memory, where SMLSIZ is returned by ILAENV and
* is equal to the maximum size of the subproblems at the
* bottom of the computation tree (usually about 25).
* For other values of COMPQ, IQ is not referenced.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
* If COMPQ = 'N' then LWORK >= (4 * N).
* If COMPQ = 'P' then LWORK >= (6 * N).
* If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N).
*
* IWORK (workspace) INTEGER array, dimension (7*N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: The algorithm failed to compute an singular value.
* The update process of divide and conquer failed.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
* ..
* .. Local Scalars ..
INTEGER DIFL, DIFR, GIVCOL, GIVNUM, GIVPTR, I, IC,
$ ICOMPQ, IERR, II, IS, IU, IUPLO, IVT, J, K, KK,
$ MLVL, NM1, NSIZE, PERM, POLES, QSTART, SMLSIZ,
$ SMLSZP, SQRE, START, WSTART, Z
DOUBLE PRECISION CS, EPS, ORGNRM, P, R, SN
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANST
EXTERNAL LSAME, ILAENV, DLAMCH, DLANST
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLARTG, DLASCL, DLASD0, DLASDA, DLASDQ,
$ DLASET, DLASR, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, INT, LOG, SIGN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IUPLO = 0
IF( LSAME( UPLO, 'U' ) )
$ IUPLO = 1
IF( LSAME( UPLO, 'L' ) )
$ IUPLO = 2
IF( LSAME( COMPQ, 'N' ) ) THEN
ICOMPQ = 0
ELSE IF( LSAME( COMPQ, 'P' ) ) THEN
ICOMPQ = 1
ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
ICOMPQ = 2
ELSE
ICOMPQ = -1
END IF
IF( IUPLO.EQ.0 ) THEN
INFO = -1
ELSE IF( ICOMPQ.LT.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ( LDU.LT.1 ) .OR. ( ( ICOMPQ.EQ.2 ) .AND. ( LDU.LT.
$ N ) ) ) THEN
INFO = -7
ELSE IF( ( LDVT.LT.1 ) .OR. ( ( ICOMPQ.EQ.2 ) .AND. ( LDVT.LT.
$ N ) ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DBDSDC', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
SMLSIZ = ILAENV( 9, 'DBDSDC', ' ', 0, 0, 0, 0 )
IF( N.EQ.1 ) THEN
IF( ICOMPQ.EQ.1 ) THEN
Q( 1 ) = SIGN( ONE, D( 1 ) )
Q( 1+SMLSIZ*N ) = ONE
ELSE IF( ICOMPQ.EQ.2 ) THEN
U( 1, 1 ) = SIGN( ONE, D( 1 ) )
VT( 1, 1 ) = ONE
END IF
D( 1 ) = ABS( D( 1 ) )
RETURN
END IF
NM1 = N - 1
*
* If matrix lower bidiagonal, rotate to be upper bidiagonal
* by applying Givens rotations on the left
*
WSTART = 1
QSTART = 3
IF( ICOMPQ.EQ.1 ) THEN
CALL DCOPY( N, D, 1, Q( 1 ), 1 )
CALL DCOPY( N-1, E, 1, Q( N+1 ), 1 )
END IF
IF( IUPLO.EQ.2 ) THEN
QSTART = 5
WSTART = 2*N - 1
OPS = OPS + DBLE( 8*( N-1 ) )
DO 10 I = 1, N - 1
CALL DLARTG( D( I ), E( I ), CS, SN, R )
D( I ) = R
E( I ) = SN*D( I+1 )
D( I+1 ) = CS*D( I+1 )
IF( ICOMPQ.EQ.1 ) THEN
Q( I+2*N ) = CS
Q( I+3*N ) = SN
ELSE IF( ICOMPQ.EQ.2 ) THEN
WORK( I ) = CS
WORK( NM1+I ) = -SN
END IF
10 CONTINUE
END IF
*
* If ICOMPQ = 0, use DLASDQ to compute the singular values.
*
IF( ICOMPQ.EQ.0 ) THEN
CALL DLASDQ( 'U', 0, N, 0, 0, 0, D, E, VT, LDVT, U, LDU, U,
$ LDU, WORK( WSTART ), INFO )
GO TO 40
END IF
*
* If N is smaller than the minimum divide size SMLSIZ, then solve
* the problem with another solver.
*
IF( N.LE.SMLSIZ ) THEN
IF( ICOMPQ.EQ.2 ) THEN
CALL DLASET( 'A', N, N, ZERO, ONE, U, LDU )
CALL DLASET( 'A', N, N, ZERO, ONE, VT, LDVT )
CALL DLASDQ( 'U', 0, N, N, N, 0, D, E, VT, LDVT, U, LDU, U,
$ LDU, WORK( WSTART ), INFO )
ELSE IF( ICOMPQ.EQ.1 ) THEN
IU = 1
IVT = IU + N
CALL DLASET( 'A', N, N, ZERO, ONE, Q( IU+( QSTART-1 )*N ),
$ N )
CALL DLASET( 'A', N, N, ZERO, ONE, Q( IVT+( QSTART-1 )*N ),
$ N )
CALL DLASDQ( 'U', 0, N, N, N, 0, D, E,
$ Q( IVT+( QSTART-1 )*N ), N,
$ Q( IU+( QSTART-1 )*N ), N,
$ Q( IU+( QSTART-1 )*N ), N, WORK( WSTART ),
$ INFO )
END IF
GO TO 40
END IF
*
IF( ICOMPQ.EQ.2 ) THEN
CALL DLASET( 'A', N, N, ZERO, ONE, U, LDU )
CALL DLASET( 'A', N, N, ZERO, ONE, VT, LDVT )
END IF
*
* Scale.
*
ORGNRM = DLANST( 'M', N, D, E )
IF( ORGNRM.EQ.ZERO )
$ RETURN
OPS = OPS + DBLE( N+NM1 )
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, IERR )
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, IERR )
*
EPS = DLAMCH( 'Epsilon' )
*
MLVL = INT( LOG( DBLE( N ) / DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1
SMLSZP = SMLSIZ + 1
*
IF( ICOMPQ.EQ.1 ) THEN
IU = 1
IVT = 1 + SMLSIZ
DIFL = IVT + SMLSZP
DIFR = DIFL + MLVL
Z = DIFR + MLVL*2
IC = Z + MLVL
IS = IC + 1
POLES = IS + 1
GIVNUM = POLES + 2*MLVL
*
K = 1
GIVPTR = 2
PERM = 3
GIVCOL = PERM + MLVL
END IF
*
DO 20 I = 1, N
IF( ABS( D( I ) ).LT.EPS ) THEN
D( I ) = SIGN( EPS, D( I ) )
END IF
20 CONTINUE
*
START = 1
SQRE = 0
*
DO 30 I = 1, NM1
IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN
*
* Subproblem found. First determine its size and then
* apply divide and conquer on it.
*
IF( I.LT.NM1 ) THEN
*
* A subproblem with E(I) small for I < NM1.
*
NSIZE = I - START + 1
ELSE IF( ABS( E( I ) ).GE.EPS ) THEN
*
* A subproblem with E(NM1) not too small but I = NM1.
*
NSIZE = N - START + 1
ELSE
*
* A subproblem with E(NM1) small. This implies an
* 1-by-1 subproblem at D(N). Solve this 1-by-1 problem
* first.
*
NSIZE = I - START + 1
IF( ICOMPQ.EQ.2 ) THEN
U( N, N ) = SIGN( ONE, D( N ) )
VT( N, N ) = ONE
ELSE IF( ICOMPQ.EQ.1 ) THEN
Q( N+( QSTART-1 )*N ) = SIGN( ONE, D( N ) )
Q( N+( SMLSIZ+QSTART-1 )*N ) = ONE
END IF
D( N ) = ABS( D( N ) )
END IF
IF( ICOMPQ.EQ.2 ) THEN
CALL DLASD0( NSIZE, SQRE, D( START ), E( START ),
$ U( START, START ), LDU, VT( START, START ),
$ LDVT, SMLSIZ, IWORK, WORK( WSTART ), INFO )
ELSE
CALL DLASDA( ICOMPQ, SMLSIZ, NSIZE, SQRE, D( START ),
$ E( START ), Q( START+( IU+QSTART-2 )*N ), N,
$ Q( START+( IVT+QSTART-2 )*N ),
$ IQ( START+K*N ), Q( START+( DIFL+QSTART-2 )*
$ N ), Q( START+( DIFR+QSTART-2 )*N ),
$ Q( START+( Z+QSTART-2 )*N ),
$ Q( START+( POLES+QSTART-2 )*N ),
$ IQ( START+GIVPTR*N ), IQ( START+GIVCOL*N ),
$ N, IQ( START+PERM*N ),
$ Q( START+( GIVNUM+QSTART-2 )*N ),
$ Q( START+( IC+QSTART-2 )*N ),
$ Q( START+( IS+QSTART-2 )*N ),
$ WORK( WSTART ), IWORK, INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
END IF
START = I + 1
END IF
30 CONTINUE
*
* Unscale
*
OPS = OPS + DBLE( N )
CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, IERR )
40 CONTINUE
*
* Use Selection Sort to minimize swaps of singular vectors
*
DO 60 II = 2, N
I = II - 1
KK = I
P = D( I )
DO 50 J = II, N
IF( D( J ).GT.P ) THEN
KK = J
P = D( J )
END IF
50 CONTINUE
IF( KK.NE.I ) THEN
D( KK ) = D( I )
D( I ) = P
IF( ICOMPQ.EQ.1 ) THEN
IQ( I ) = KK
ELSE IF( ICOMPQ.EQ.2 ) THEN
CALL DSWAP( N, U( 1, I ), 1, U( 1, KK ), 1 )
CALL DSWAP( N, VT( I, 1 ), LDVT, VT( KK, 1 ), LDVT )
END IF
ELSE IF( ICOMPQ.EQ.1 ) THEN
IQ( I ) = I
END IF
60 CONTINUE
*
* If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO
*
IF( ICOMPQ.EQ.1 ) THEN
IF( IUPLO.EQ.1 ) THEN
IQ( N ) = 1
ELSE
IQ( N ) = 0
END IF
END IF
*
* If B is lower bidiagonal, update U by those Givens rotations
* which rotated B to be upper bidiagonal
*
IF( ( IUPLO.EQ.2 ) .AND. ( ICOMPQ.EQ.2 ) ) THEN
OPS = OPS + DBLE( 6*( N-1 )*N )
CALL DLASR( 'L', 'V', 'B', N, N, WORK( 1 ), WORK( N ), U, LDU )
END IF
*
RETURN
*
* End of DBDSDC
*
END
SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U,
$ LDU, C, LDC, WORK, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU
* ..
* .. Array Arguments ..
DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ),
$ VT( LDVT, * ), WORK( * )
* ..
* Common block to return operation count and iteration count
* ITCNT is initialized to 0, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DBDSQR computes the singular value decomposition (SVD) of a real
* N-by-N (upper or lower) bidiagonal matrix B: B = Q * S * P' (P'
* denotes the transpose of P), where S is a diagonal matrix with
* non-negative diagonal elements (the singular values of B), and Q
* and P are orthogonal matrices.
*
* The routine computes S, and optionally computes U * Q, P' * VT,
* or Q' * C, for given real input matrices U, VT, and C.
*
* See "Computing Small Singular Values of Bidiagonal Matrices With
* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,
* no. 5, pp. 873-912, Sept 1990) and
* "Accurate singular values and differential qd algorithms," by
* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics
* Department, University of California at Berkeley, July 1992
* for a detailed description of the algorithm.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': B is upper bidiagonal;
* = 'L': B is lower bidiagonal.
*
* N (input) INTEGER
* The order of the matrix B. N >= 0.
*
* NCVT (input) INTEGER
* The number of columns of the matrix VT. NCVT >= 0.
*
* NRU (input) INTEGER
* The number of rows of the matrix U. NRU >= 0.
*
* NCC (input) INTEGER
* The number of columns of the matrix C. NCC >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the n diagonal elements of the bidiagonal matrix B.
* On exit, if INFO=0, the singular values of B in decreasing
* order.
*
* E (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the elements of E contain the
* offdiagonal elements of the bidiagonal matrix whose SVD
* is desired. On normal exit (INFO = 0), E is destroyed.
* If the algorithm does not converge (INFO > 0), D and E
* will contain the diagonal and superdiagonal elements of a
* bidiagonal matrix orthogonally equivalent to the one given
* as input. E(N) is used for workspace.
*
* VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT)
* On entry, an N-by-NCVT matrix VT.
* On exit, VT is overwritten by P' * VT.
* VT is not referenced if NCVT = 0.
*
* LDVT (input) INTEGER
* The leading dimension of the array VT.
* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.
*
* U (input/output) DOUBLE PRECISION array, dimension (LDU, N)
* On entry, an NRU-by-N matrix U.
* On exit, U is overwritten by U * Q.
* U is not referenced if NRU = 0.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= max(1,NRU).
*
* C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC)
* On entry, an N-by-NCC matrix C.
* On exit, C is overwritten by Q' * C.
* C is not referenced if NCC = 0.
*
* LDC (input) INTEGER
* The leading dimension of the array C.
* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: If INFO = -i, the i-th argument had an illegal value
* > 0: the algorithm did not converge; D and E contain the
* elements of a bidiagonal matrix which is orthogonally
* similar to the input matrix B; if INFO = i, i
* elements of E have not converged to zero.
*
* Internal Parameters
* ===================
*
* TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8)))
* TOLMUL controls the convergence criterion of the QR loop.
* If it is positive, TOLMUL*EPS is the desired relative
* precision in the computed singular values.
* If it is negative, abs(TOLMUL*EPS*sigma_max) is the
* desired absolute accuracy in the computed singular
* values (corresponds to relative accuracy
* abs(TOLMUL*EPS) in the largest singular value.
* abs(TOLMUL) should be between 1 and 1/EPS, and preferably
* between 10 (for fast convergence) and .1/EPS
* (for there to be some accuracy in the results).
* Default is to lose at either one eighth or 2 of the
* available decimal digits in each computed singular value
* (whichever is smaller).
*
* MAXITR INTEGER, default = 6
* MAXITR controls the maximum number of passes of the
* algorithm through its inner loop. The algorithms stops
* (and so fails to converge) if the number of passes
* through the inner loop exceeds MAXITR*N**2.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION NEGONE
PARAMETER ( NEGONE = -1.0D0 )
DOUBLE PRECISION HNDRTH
PARAMETER ( HNDRTH = 0.01D0 )
DOUBLE PRECISION TEN
PARAMETER ( TEN = 10.0D0 )
DOUBLE PRECISION HNDRD
PARAMETER ( HNDRD = 100.0D0 )
DOUBLE PRECISION MEIGTH
PARAMETER ( MEIGTH = -0.125D0 )
INTEGER MAXITR
PARAMETER ( MAXITR = 6 )
* ..
* .. Local Scalars ..
LOGICAL LOWER, ROTATE
INTEGER I, IDIR, ISUB, ITER, J, LL, LLL, M, MAXIT, NM1,
$ NM12, NM13, OLDLL, OLDM
DOUBLE PRECISION ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU,
$ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL,
$ SINR, SLL, SMAX, SMIN, SMINL, SMINLO, SMINOA,
$ SN, THRESH, TOL, TOLMUL, UNFL
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DLARTG, DLAS2, DLASQ1, DLASR, DLASV2, DROT,
$ DSCAL, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
LOWER = LSAME( UPLO, 'L' )
IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LOWER ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NCVT.LT.0 ) THEN
INFO = -3
ELSE IF( NRU.LT.0 ) THEN
INFO = -4
ELSE IF( NCC.LT.0 ) THEN
INFO = -5
ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR.
$ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN
INFO = -9
ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN
INFO = -11
ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR.
$ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN
INFO = -13
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DBDSQR', -INFO )
RETURN
END IF
IF( N.EQ.0 )
$ RETURN
IF( N.EQ.1 )
$ GO TO 160
*
* ROTATE is true if any singular vectors desired, false otherwise
*
ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 )
*
* If no singular vectors desired, use qd algorithm
*
IF( .NOT.ROTATE ) THEN
CALL DLASQ1( N, D, E, WORK, INFO )
RETURN
END IF
*
NM1 = N - 1
NM12 = NM1 + NM1
NM13 = NM12 + NM1
IDIR = 0
*
* Get machine constants
*
EPS = DLAMCH( 'Epsilon' )
UNFL = DLAMCH( 'Safe minimum' )
*
* If matrix lower bidiagonal, rotate to be upper bidiagonal
* by applying Givens rotations on the left
*
IF( LOWER ) THEN
OPS = OPS + DBLE( N-1 )*( 8+6*( NRU+NCC ) )
DO 10 I = 1, N - 1
CALL DLARTG( D( I ), E( I ), CS, SN, R )
D( I ) = R
E( I ) = SN*D( I+1 )
D( I+1 ) = CS*D( I+1 )
WORK( I ) = CS
WORK( NM1+I ) = SN
10 CONTINUE
*
* Update singular vectors if desired
*
IF( NRU.GT.0 )
$ CALL DLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ), WORK( N ), U,
$ LDU )
IF( NCC.GT.0 )
$ CALL DLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ), WORK( N ), C,
$ LDC )
END IF
*
* Compute singular values to relative accuracy TOL
* (By setting TOL to be negative, algorithm will compute
* singular values to absolute accuracy ABS(TOL)*norm(input matrix))
*
OPS = OPS + 4
TOLMUL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) )
TOL = TOLMUL*EPS
*
* Compute approximate maximum, minimum singular values
*
SMAX = ZERO
DO 20 I = 1, N
SMAX = MAX( SMAX, ABS( D( I ) ) )
20 CONTINUE
DO 30 I = 1, N - 1
SMAX = MAX( SMAX, ABS( E( I ) ) )
30 CONTINUE
SMINL = ZERO
IF( TOL.GE.ZERO ) THEN
*
* Relative accuracy desired
*
SMINOA = ABS( D( 1 ) )
IF( SMINOA.EQ.ZERO )
$ GO TO 50
MU = SMINOA
OPS = OPS + 3*N - 1
DO 40 I = 2, N
MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) )
SMINOA = MIN( SMINOA, MU )
IF( SMINOA.EQ.ZERO )
$ GO TO 50
40 CONTINUE
50 CONTINUE
SMINOA = SMINOA / SQRT( DBLE( N ) )
THRESH = MAX( TOL*SMINOA, MAXITR*N*N*UNFL )
ELSE
*
* Absolute accuracy desired
*
THRESH = MAX( ABS( TOL )*SMAX, MAXITR*N*N*UNFL )
END IF
*
* Prepare for main iteration loop for the singular values
* (MAXIT is the maximum number of passes through the inner
* loop permitted before nonconvergence signalled.)
*
MAXIT = MAXITR*N*N
ITER = 0
OLDLL = -1
OLDM = -1
*
* M points to last element of unconverged part of matrix
*
M = N
*
* Begin main iteration loop
*
60 CONTINUE
*
* Check for convergence or exceeding iteration count
*
IF( M.LE.1 )
$ GO TO 160
IF( ITER.GT.MAXIT )
$ GO TO 200
*
* Find diagonal block of matrix to work on
*
IF( TOL.LT.ZERO .AND. ABS( D( M ) ).LE.THRESH )
$ D( M ) = ZERO
SMAX = ABS( D( M ) )
SMIN = SMAX
DO 70 LLL = 1, M - 1
LL = M - LLL
ABSS = ABS( D( LL ) )
ABSE = ABS( E( LL ) )
IF( TOL.LT.ZERO .AND. ABSS.LE.THRESH )
$ D( LL ) = ZERO
IF( ABSE.LE.THRESH )
$ GO TO 80
SMIN = MIN( SMIN, ABSS )
SMAX = MAX( SMAX, ABSS, ABSE )
70 CONTINUE
LL = 0
GO TO 90
80 CONTINUE
E( LL ) = ZERO
*
* Matrix splits since E(LL) = 0
*
IF( LL.EQ.M-1 ) THEN
*
* Convergence of bottom singular value, return to top of loop
*
M = M - 1
GO TO 60
END IF
90 CONTINUE
LL = LL + 1
*
* E(LL) through E(M-1) are nonzero, E(LL-1) is zero
*
IF( LL.EQ.M-1 ) THEN
*
* 2 by 2 block, handle separately
*
OPS = OPS + 37 + 6*( NCVT+NRU+NCC )
CALL DLASV2( D( M-1 ), E( M-1 ), D( M ), SIGMN, SIGMX, SINR,
$ COSR, SINL, COSL )
D( M-1 ) = SIGMX
E( M-1 ) = ZERO
D( M ) = SIGMN
*
* Compute singular vectors, if desired
*
IF( NCVT.GT.0 )
$ CALL DROT( NCVT, VT( M-1, 1 ), LDVT, VT( M, 1 ), LDVT, COSR,
$ SINR )
IF( NRU.GT.0 )
$ CALL DROT( NRU, U( 1, M-1 ), 1, U( 1, M ), 1, COSL, SINL )
IF( NCC.GT.0 )
$ CALL DROT( NCC, C( M-1, 1 ), LDC, C( M, 1 ), LDC, COSL,
$ SINL )
M = M - 2
GO TO 60
END IF
*
* If working on new submatrix, choose shift direction
* (from larger end diagonal element towards smaller)
*
IF( LL.GT.OLDM .OR. M.LT.OLDLL ) THEN
IF( ABS( D( LL ) ).GE.ABS( D( M ) ) ) THEN
*
* Chase bulge from top (big end) to bottom (small end)
*
IDIR = 1
ELSE
*
* Chase bulge from bottom (big end) to top (small end)
*
IDIR = 2
END IF
END IF
*
* Apply convergence tests
*
IF( IDIR.EQ.1 ) THEN
*
* Run convergence test in forward direction
* First apply standard test to bottom of matrix
*
OPS = OPS + 1
IF( ABS( E( M-1 ) ).LE.ABS( TOL )*ABS( D( M ) ) .OR.
$ ( TOL.LT.ZERO .AND. ABS( E( M-1 ) ).LE.THRESH ) ) THEN
E( M-1 ) = ZERO
GO TO 60
END IF
*
IF( TOL.GE.ZERO ) THEN
*
* If relative accuracy desired,
* apply convergence criterion forward
*
MU = ABS( D( LL ) )
SMINL = MU
DO 100 LLL = LL, M - 1
IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
E( LLL ) = ZERO
GO TO 60
END IF
SMINLO = SMINL
OPS = OPS + 4
MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
SMINL = MIN( SMINL, MU )
100 CONTINUE
END IF
*
ELSE
*
* Run convergence test in backward direction
* First apply standard test to top of matrix
*
OPS = OPS + 1
IF( ABS( E( LL ) ).LE.ABS( TOL )*ABS( D( LL ) ) .OR.
$ ( TOL.LT.ZERO .AND. ABS( E( LL ) ).LE.THRESH ) ) THEN
E( LL ) = ZERO
GO TO 60
END IF
*
IF( TOL.GE.ZERO ) THEN
*
* If relative accuracy desired,
* apply convergence criterion backward
*
MU = ABS( D( M ) )
SMINL = MU
DO 110 LLL = M - 1, LL, -1
IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
E( LLL ) = ZERO
GO TO 60
END IF
SMINLO = SMINL
OPS = OPS + 4
MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
SMINL = MIN( SMINL, MU )
110 CONTINUE
END IF
END IF
OLDLL = LL
OLDM = M
*
* Compute shift. First, test if shifting would ruin relative
* accuracy, and if so set the shift to zero.
*
OPS = OPS + 4
IF( TOL.GE.ZERO .AND. N*TOL*( SMINL / SMAX ).LE.
$ MAX( EPS, HNDRTH*TOL ) ) THEN
*
* Use a zero shift to avoid loss of relative accuracy
*
SHIFT = ZERO
ELSE
*
* Compute the shift from 2-by-2 block at end of matrix
*
OPS = OPS + 20
IF( IDIR.EQ.1 ) THEN
SLL = ABS( D( LL ) )
CALL DLAS2( D( M-1 ), E( M-1 ), D( M ), SHIFT, R )
ELSE
SLL = ABS( D( M ) )
CALL DLAS2( D( LL ), E( LL ), D( LL+1 ), SHIFT, R )
END IF
*
* Test if shift negligible, and if so set to zero
*
IF( SLL.GT.ZERO ) THEN
IF( ( SHIFT / SLL )**2.LT.EPS )
$ SHIFT = ZERO
END IF
END IF
*
* Increment iteration count
*
ITER = ITER + M - LL
*
* If SHIFT = 0, do simplified QR iteration
*
IF( SHIFT.EQ.ZERO ) THEN
OPS = OPS + 2 + DBLE( M-LL )*( 20+6*( NCVT+NRU+NCC ) )
IF( IDIR.EQ.1 ) THEN
*
* Chase bulge from top to bottom
* Save cosines and sines for later singular vector updates
*
CS = ONE
OLDCS = ONE
DO 120 I = LL, M - 1
CALL DLARTG( D( I )*CS, E( I ), CS, SN, R )
IF( I.GT.LL )
$ E( I-1 ) = OLDSN*R
CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) )
WORK( I-LL+1 ) = CS
WORK( I-LL+1+NM1 ) = SN
WORK( I-LL+1+NM12 ) = OLDCS
WORK( I-LL+1+NM13 ) = OLDSN
120 CONTINUE
H = D( M )*CS
D( M ) = H*OLDCS
E( M-1 ) = H*OLDSN
*
* Update singular vectors
*
IF( NCVT.GT.0 )
$ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ),
$ WORK( N ), VT( LL, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL DLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ),
$ WORK( NM13+1 ), U( 1, LL ), LDU )
IF( NCC.GT.0 )
$ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ),
$ WORK( NM13+1 ), C( LL, 1 ), LDC )
*
* Test convergence
*
IF( ABS( E( M-1 ) ).LE.THRESH )
$ E( M-1 ) = ZERO
*
ELSE
*
* Chase bulge from bottom to top
* Save cosines and sines for later singular vector updates
*
CS = ONE
OLDCS = ONE
DO 130 I = M, LL + 1, -1
CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R )
IF( I.LT.M )
$ E( I ) = OLDSN*R
CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) )
WORK( I-LL ) = CS
WORK( I-LL+NM1 ) = -SN
WORK( I-LL+NM12 ) = OLDCS
WORK( I-LL+NM13 ) = -OLDSN
130 CONTINUE
H = D( LL )*CS
D( LL ) = H*OLDCS
E( LL ) = H*OLDSN
*
* Update singular vectors
*
IF( NCVT.GT.0 )
$ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ),
$ WORK( NM13+1 ), VT( LL, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL DLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ),
$ WORK( N ), U( 1, LL ), LDU )
IF( NCC.GT.0 )
$ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ),
$ WORK( N ), C( LL, 1 ), LDC )
*
* Test convergence
*
IF( ABS( E( LL ) ).LE.THRESH )
$ E( LL ) = ZERO
END IF
ELSE
*
* Use nonzero shift
*
OPS = OPS + 2 + ( M-LL )*( 32+6*( NCVT+NRU+NCC ) )
IF( IDIR.EQ.1 ) THEN
*
* Chase bulge from top to bottom
* Save cosines and sines for later singular vector updates
*
F = ( ABS( D( LL ) )-SHIFT )*
$ ( SIGN( ONE, D( LL ) )+SHIFT / D( LL ) )
G = E( LL )
DO 140 I = LL, M - 1
CALL DLARTG( F, G, COSR, SINR, R )
IF( I.GT.LL )
$ E( I-1 ) = R
F = COSR*D( I ) + SINR*E( I )
E( I ) = COSR*E( I ) - SINR*D( I )
G = SINR*D( I+1 )
D( I+1 ) = COSR*D( I+1 )
CALL DLARTG( F, G, COSL, SINL, R )
D( I ) = R
F = COSL*E( I ) + SINL*D( I+1 )
D( I+1 ) = COSL*D( I+1 ) - SINL*E( I )
IF( I.LT.M-1 ) THEN
G = SINL*E( I+1 )
E( I+1 ) = COSL*E( I+1 )
END IF
WORK( I-LL+1 ) = COSR
WORK( I-LL+1+NM1 ) = SINR
WORK( I-LL+1+NM12 ) = COSL
WORK( I-LL+1+NM13 ) = SINL
140 CONTINUE
E( M-1 ) = F
*
* Update singular vectors
*
IF( NCVT.GT.0 )
$ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ),
$ WORK( N ), VT( LL, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL DLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ),
$ WORK( NM13+1 ), U( 1, LL ), LDU )
IF( NCC.GT.0 )
$ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ),
$ WORK( NM13+1 ), C( LL, 1 ), LDC )
*
* Test convergence
*
IF( ABS( E( M-1 ) ).LE.THRESH )
$ E( M-1 ) = ZERO
*
ELSE
*
* Chase bulge from bottom to top
* Save cosines and sines for later singular vector updates
*
F = ( ABS( D( M ) )-SHIFT )*( SIGN( ONE, D( M ) )+SHIFT /
$ D( M ) )
G = E( M-1 )
DO 150 I = M, LL + 1, -1
CALL DLARTG( F, G, COSR, SINR, R )
IF( I.LT.M )
$ E( I ) = R
F = COSR*D( I ) + SINR*E( I-1 )
E( I-1 ) = COSR*E( I-1 ) - SINR*D( I )
G = SINR*D( I-1 )
D( I-1 ) = COSR*D( I-1 )
CALL DLARTG( F, G, COSL, SINL, R )
D( I ) = R
F = COSL*E( I-1 ) + SINL*D( I-1 )
D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 )
IF( I.GT.LL+1 ) THEN
G = SINL*E( I-2 )
E( I-2 ) = COSL*E( I-2 )
END IF
WORK( I-LL ) = COSR
WORK( I-LL+NM1 ) = -SINR
WORK( I-LL+NM12 ) = COSL
WORK( I-LL+NM13 ) = -SINL
150 CONTINUE
E( LL ) = F
*
* Test convergence
*
IF( ABS( E( LL ) ).LE.THRESH )
$ E( LL ) = ZERO
*
* Update singular vectors if desired
*
IF( NCVT.GT.0 )
$ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ),
$ WORK( NM13+1 ), VT( LL, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL DLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ),
$ WORK( N ), U( 1, LL ), LDU )
IF( NCC.GT.0 )
$ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ),
$ WORK( N ), C( LL, 1 ), LDC )
END IF
END IF
*
* QR iteration finished, go back and check convergence
*
GO TO 60
*
* All singular values converged, so make them positive
*
160 CONTINUE
DO 170 I = 1, N
IF( D( I ).LT.ZERO ) THEN
D( I ) = -D( I )
*
* Change sign of singular vectors, if desired
*
OPS = OPS + NCVT
IF( NCVT.GT.0 )
$ CALL DSCAL( NCVT, NEGONE, VT( I, 1 ), LDVT )
END IF
170 CONTINUE
*
* Sort the singular values into decreasing order (insertion sort on
* singular values, but only one transposition per singular vector)
*
DO 190 I = 1, N - 1
*
* Scan for smallest D(I)
*
ISUB = 1
SMIN = D( 1 )
DO 180 J = 2, N + 1 - I
IF( D( J ).LE.SMIN ) THEN
ISUB = J
SMIN = D( J )
END IF
180 CONTINUE
IF( ISUB.NE.N+1-I ) THEN
*
* Swap singular values and vectors
*
D( ISUB ) = D( N+1-I )
D( N+1-I ) = SMIN
IF( NCVT.GT.0 )
$ CALL DSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ),
$ LDVT )
IF( NRU.GT.0 )
$ CALL DSWAP( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 )
IF( NCC.GT.0 )
$ CALL DSWAP( NCC, C( ISUB, 1 ), LDC, C( N+1-I, 1 ), LDC )
END IF
190 CONTINUE
GO TO 220
*
* Maximum number of iterations exceeded, failure to converge
*
200 CONTINUE
INFO = 0
DO 210 I = 1, N - 1
IF( E( I ).NE.ZERO )
$ INFO = INFO + 1
210 CONTINUE
220 CONTINUE
RETURN
*
* End of DBDSQR
*
END
SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK,
$ LWORK, IWORK, INFO )
*
* -- LAPACK driver routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
CHARACTER JOBZ
INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ),
$ VT( LDVT, * ), WORK( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DGESDD computes the singular value decomposition (SVD) of a real
* M-by-N matrix A, optionally computing the left and right singular
* vectors. If singular vectors are desired, it uses a
* divide-and-conquer algorithm.
*
* The SVD is written
*
* A = U * SIGMA * transpose(V)
*
* where SIGMA is an M-by-N matrix which is zero except for its
* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and
* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA
* are the singular values of A; they are real and non-negative, and
* are returned in descending order. The first min(m,n) columns of
* U and V are the left and right singular vectors of A.
*
* Note that the routine returns VT = V**T, not V.
*
* The divide and conquer algorithm makes very mild assumptions about
* floating point arithmetic. It will work on machines with a guard
* digit in add/subtract, or on those binary machines without guard
* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
* Cray-2. It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* Specifies options for computing all or part of the matrix U:
* = 'A': all M columns of U and all N rows of V**T are
* returned in the arrays U and VT;
* = 'S': the first min(M,N) columns of U and the first
* min(M,N) rows of V**T are returned in the arrays U
* and VT;
* = 'O': If M >= N, the first N columns of U are overwritten
* on the array A and all rows of V**T are returned in
* the array VT;
* otherwise, all columns of U are returned in the
* array U and the first M rows of V**T are overwritten
* in the array VT;
* = 'N': no columns of U or rows of V**T are computed.
*
* M (input) INTEGER
* The number of rows of the input matrix A. M >= 0.
*
* N (input) INTEGER
* The number of columns of the input matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
* On exit,
* if JOBZ = 'O', A is overwritten with the first N columns
* of U (the left singular vectors, stored
* columnwise) if M >= N;
* A is overwritten with the first M rows
* of V**T (the right singular vectors, stored
* rowwise) otherwise.
* if JOBZ .ne. 'O', the contents of A are destroyed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* S (output) DOUBLE PRECISION array, dimension (min(M,N))
* The singular values of A, sorted so that S(i) >= S(i+1).
*
* U (output) DOUBLE PRECISION array, dimension (LDU,UCOL)
* UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;
* UCOL = min(M,N) if JOBZ = 'S'.
* If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M
* orthogonal matrix U;
* if JOBZ = 'S', U contains the first min(M,N) columns of U
* (the left singular vectors, stored columnwise);
* if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= 1; if
* JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.
*
* VT (output) DOUBLE PRECISION array, dimension (LDVT,N)
* If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the
* N-by-N orthogonal matrix V**T;
* if JOBZ = 'S', VT contains the first min(M,N) rows of
* V**T (the right singular vectors, stored rowwise);
* if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.
*
* LDVT (input) INTEGER
* The leading dimension of the array VT. LDVT >= 1; if
* JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;
* if JOBZ = 'S', LDVT >= min(M,N).
*
* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK;
*
* LWORK (input) INTEGER
* The dimension of the array WORK. LWORK >= 1.
* If JOBZ = 'N',
* LWORK >= 3*min(M,N) + max(max(M,N),6*min(M,N)).
* If JOBZ = 'O',
* LWORK >= 3*min(M,N)*min(M,N) +
* max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)).
* If JOBZ = 'S' or 'A'
* LWORK >= 3*min(M,N)*min(M,N) +
* max(max(M,N),4*min(M,N)*min(M,N)+4*min(M,N)).
* For good performance, LWORK should generally be larger.
* If LWORK < 0 but other input arguments are legal, WORK(1)
* returns the optimal LWORK.
*
* IWORK (workspace) INTEGER array, dimension (8*min(M,N))
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: DBDSDC did not converge, updating process failed.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, WNTQA, WNTQAS, WNTQN, WNTQO, WNTQS
INTEGER BDSPAC, BLK, CHUNK, I, IE, IERR, IL,
$ IR, ISCL, ITAU, ITAUP, ITAUQ, IU, IVT, LDWKVT,
$ LDWRKL, LDWRKR, LDWRKU, MAXWRK, MINMN, MINWRK,
$ MNTHR, NB, NWORK, WRKBL
DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM
* ..
* .. Local Arrays ..
INTEGER IDUM( 1 )
DOUBLE PRECISION DUM( 1 )
* ..
* .. External Subroutines ..
EXTERNAL DBDSDC, DGEBRD, DGELQF, DGEMM, DGEQRF, DLACPY,
$ DLASCL, DLASET, DORGBR, DORGLQ, DORGQR, DORMBR,
$ XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANGE, DOPBL3, DOPLA, DOPLA2
EXTERNAL DLAMCH, DLANGE, DOPBL3, DOPLA, DOPLA2, ILAENV,
$ LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, INT, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
MINMN = MIN( M, N )
MNTHR = INT( MINMN*11.0D0 / 6.0D0 )
WNTQA = LSAME( JOBZ, 'A' )
WNTQS = LSAME( JOBZ, 'S' )
WNTQAS = WNTQA .OR. WNTQS
WNTQO = LSAME( JOBZ, 'O' )
WNTQN = LSAME( JOBZ, 'N' )
MINWRK = 1
MAXWRK = 1
LQUERY = ( LWORK.EQ.-1 )
*
IF( .NOT.( WNTQA .OR. WNTQS .OR. WNTQO .OR. WNTQN ) ) 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 = -5
ELSE IF( LDU.LT.1 .OR. ( WNTQAS .AND. LDU.LT.M ) .OR.
$ ( WNTQO .AND. M.LT.N .AND. LDU.LT.M ) ) THEN
INFO = -8
ELSE IF( LDVT.LT.1 .OR. ( WNTQA .AND. LDVT.LT.N ) .OR.
$ ( WNTQS .AND. LDVT.LT.MINMN ) .OR.
$ ( WNTQO .AND. M.GE.N .AND. LDVT.LT.N ) ) THEN
INFO = -10
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.)
*
IF( INFO.EQ.0 .AND. M.GT.0 .AND. N.GT.0 ) THEN
IF( M.GE.N ) THEN
*
* Compute space needed for DBDSDC
*
IF( WNTQN ) THEN
BDSPAC = 7*N
ELSE
BDSPAC = 3*N*N + 4*N
END IF
IF( M.GE.MNTHR ) THEN
IF( WNTQN ) THEN
*
* Path 1 (M much larger than N, JOBZ='N')
*
WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1,
$ -1 )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
MAXWRK = MAX( WRKBL, BDSPAC+N )
MINWRK = BDSPAC + N
ELSE IF( WNTQO ) THEN
*
* Path 2 (M much larger than N, JOBZ='O')
*
WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
$ N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'DORMBR', 'QLN', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*N )
MAXWRK = WRKBL + 2*N*N
MINWRK = BDSPAC + 2*N*N + 3*N
ELSE IF( WNTQS ) THEN
*
* Path 3 (M much larger than N, JOBZ='S')
*
WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
$ N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'DORMBR', 'QLN', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*N )
MAXWRK = WRKBL + N*N
MINWRK = BDSPAC + N*N + 3*N
ELSE IF( WNTQA ) THEN
*
* Path 4 (M much larger than N, JOBZ='A')
*
WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M,
$ M, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+2*N*
$ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'DORMBR', 'QLN', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*N )
MAXWRK = WRKBL + N*N
MINWRK = BDSPAC + N*N + 3*N
END IF
ELSE
*
* Path 5 (M at least N, but not much larger)
*
WRKBL = 3*N + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N, -1,
$ -1 )
IF( WNTQN ) THEN
MAXWRK = MAX( WRKBL, BDSPAC+3*N )
MINWRK = 3*N + MAX( M, BDSPAC )
ELSE IF( WNTQO ) THEN
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'DORMBR', 'QLN', M, N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*N )
MAXWRK = WRKBL + M*N
MINWRK = 3*N + MAX( M, N*N+BDSPAC )
ELSE IF( WNTQS ) THEN
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'DORMBR', 'QLN', M, N, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
MAXWRK = MAX( WRKBL, BDSPAC+3*N )
MINWRK = 3*N + MAX( M, BDSPAC )
ELSE IF( WNTQA ) THEN
WRKBL = MAX( WRKBL, 3*N+M*
$ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) )
WRKBL = MAX( WRKBL, 3*N+N*
$ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
MAXWRK = MAX( MAXWRK, BDSPAC+3*N )
MINWRK = 3*N + MAX( M, BDSPAC )
END IF
END IF
ELSE
*
* Compute space needed for DBDSDC
*
IF( WNTQN ) THEN
BDSPAC = 7*M
ELSE
BDSPAC = 3*M*M + 4*M
END IF
IF( N.GE.MNTHR ) THEN
IF( WNTQN ) THEN
*
* Path 1t (N much larger than M, JOBZ='N')
*
WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1,
$ -1 )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
MAXWRK = MAX( WRKBL, BDSPAC+M )
MINWRK = BDSPAC + M
ELSE IF( WNTQO ) THEN
*
* Path 2t (N much larger than M, JOBZ='O')
*
WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
$ N, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*M )
MAXWRK = WRKBL + 2*M*M
MINWRK = BDSPAC + 2*M*M + 3*M
ELSE IF( WNTQS ) THEN
*
* Path 3t (N much larger than M, JOBZ='S')
*
WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
$ N, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*M )
MAXWRK = WRKBL + M*M
MINWRK = BDSPAC + M*M + 3*M
ELSE IF( WNTQA ) THEN
*
* Path 4t (N much larger than M, JOBZ='A')
*
WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N,
$ N, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+2*M*
$ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*M )
MAXWRK = WRKBL + M*M
MINWRK = BDSPAC + M*M + 3*M
END IF
ELSE
*
* Path 5t (N greater than M, but not much larger)
*
WRKBL = 3*M + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N, -1,
$ -1 )
IF( WNTQN ) THEN
MAXWRK = MAX( WRKBL, BDSPAC+3*M )
MINWRK = 3*M + MAX( N, BDSPAC )
ELSE IF( WNTQO ) THEN
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'DORMBR', 'PRT', M, N, M, -1 ) )
WRKBL = MAX( WRKBL, BDSPAC+3*M )
MAXWRK = WRKBL + M*N
MINWRK = 3*M + MAX( N, M*M+BDSPAC )
ELSE IF( WNTQS ) THEN
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'DORMBR', 'PRT', M, N, M, -1 ) )
MAXWRK = MAX( WRKBL, BDSPAC+3*M )
MINWRK = 3*M + MAX( N, BDSPAC )
ELSE IF( WNTQA ) THEN
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) )
WRKBL = MAX( WRKBL, 3*M+M*
$ ILAENV( 1, 'DORMBR', 'PRT', N, N, M, -1 ) )
MAXWRK = MAX( WRKBL, BDSPAC+3*M )
MINWRK = 3*M + MAX( N, BDSPAC )
END IF
END IF
END IF
WORK( 1 ) = MAXWRK
END IF
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGESDD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
IF( LWORK.GE.1 )
$ WORK( 1 ) = ONE
RETURN
END IF
*
* Get machine constants
*
EPS = DLAMCH( 'P' )
SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS
BIGNUM = ONE / SMLNUM
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = DLANGE( 'M', M, N, A, LDA, DUM )
ISCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
ISCL = 1
OPS = OPS + DBLE( M*N )
CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR )
ELSE IF( ANRM.GT.BIGNUM ) THEN
ISCL = 1
OPS = OPS + DBLE( M*N )
CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR )
END IF
*
IF( M.GE.N ) THEN
*
* A has at least as many rows as columns. If A has sufficiently
* more rows than columns, first reduce using the QR
* decomposition (if sufficient workspace available)
*
IF( M.GE.MNTHR ) THEN
*
IF( WNTQN ) THEN
*
* Path 1 (M much larger than N, JOBZ='N')
* No singular vectors to be computed
*
ITAU = 1
NWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need 2*N, prefer N+N*NB)
*
NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
OPS = OPS + DOPLA( 'DGEQRF', M, N, 0, 0, NB )
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Zero out below R
*
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
IE = 1
ITAUQ = IE + N
ITAUP = ITAUQ + N
NWORK = ITAUP + N
*
* Bidiagonalize R in A
* (Workspace: need 4*N, prefer 3*N+2*N*NB)
*
NB = ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 )
OPS = OPS + DOPLA( 'DGEBRD', N, N, 0, 0, NB )
CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
NWORK = IE + N
*
* Perform bidiagonal SVD, computing singular values only
* (Workspace: need N+BDSPAC)
*
CALL DBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1,
$ DUM, IDUM, WORK( NWORK ), IWORK, INFO )
*
ELSE IF( WNTQO ) THEN
*
* Path 2 (M much larger than N, JOBZ = 'O')
* N left singular vectors to be overwritten on A and
* N right singular vectors to be computed in VT
*
IR = 1
*
* WORK(IR) is LDWRKR by N
*
IF( LWORK.GE.LDA*N+N*N+3*N+BDSPAC ) THEN
LDWRKR = LDA
ELSE
LDWRKR = ( LWORK-N*N-3*N-BDSPAC ) / N
END IF
ITAU = IR + LDWRKR*N
NWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
OPS = OPS + DOPLA( 'DGEQRF', M, N, 0, 0, NB )
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Copy R to WORK(IR), zeroing out below it
*
CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ),
$ LDWRKR )
*
* Generate Q in A
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
NB = ILAENV( 1, 'DORGQR', ' ', M, N, N, -1 )
OPS = OPS + DOPLA( 'DORGQR', M, N, N, 0, NB )
CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
NWORK = ITAUP + N
*
* Bidiagonalize R in VT, copying result to WORK(IR)
* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
*
NB = ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 )
OPS = OPS + DOPLA( 'DGEBRD', N, N, 0, 0, NB )
CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* WORK(IU) is N by N
*
IU = NWORK
NWORK = IU + N*N
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in WORK(IU) and computing right
* singular vectors of bidiagonal matrix in VT
* (Workspace: need N+N*N+BDSPAC)
*
CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N,
$ VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Overwrite WORK(IU) by left singular vectors of R
* and VT by right singular vectors of R
* (Workspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB)
*
NB = ILAENV( 1, 'DORMBR', 'QLN', N, N, N, -1 )
OPS = OPS + DOPLA2( 'DORMBR', 'QLN', N, N, N, 0, NB )
CALL DORMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IU ), N, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
NB = ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 )
OPS = OPS + DOPLA2( 'DORMBR', 'PRT', N, N, N, 0, NB )
CALL DORMBR( 'P', 'R', 'T', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Multiply Q in A by left singular vectors of R in
* WORK(IU), storing result in WORK(IR) and copying to A
* (Workspace: need 2*N*N, prefer N*N+M*N)
*
DO 10 I = 1, M, LDWRKR
CHUNK = MIN( M-I+1, LDWRKR )
OPS = OPS + DOPBL3( 'DGEMM ', CHUNK, N, N )
CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
$ LDA, WORK( IU ), N, ZERO, WORK( IR ),
$ LDWRKR )
CALL DLACPY( 'F', CHUNK, N, WORK( IR ), LDWRKR,
$ A( I, 1 ), LDA )
10 CONTINUE
*
ELSE IF( WNTQS ) THEN
*
* Path 3 (M much larger than N, JOBZ='S')
* N left singular vectors to be computed in U and
* N right singular vectors to be computed in VT
*
IR = 1
*
* WORK(IR) is N by N
*
LDWRKR = N
ITAU = IR + LDWRKR*N
NWORK = ITAU + N
*
* Compute A=Q*R
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
OPS = OPS + DOPLA( 'DGEQRF', M, N, 0, 0, NB )
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Copy R to WORK(IR), zeroing out below it
*
CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ),
$ LDWRKR )
*
* Generate Q in A
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
NB = ILAENV( 1, 'DORGQR', ' ', M, N, N, -1 )
OPS = OPS + DOPLA( 'DORGQR', M, N, N, 0, NB )
CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
NWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IR)
* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
*
NB = MAX( 1, ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
OPS = OPS + DOPLA( 'DGEBRD', N, N, 0, 0, NB )
CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagoal matrix in U and computing right singular
* vectors of bidiagonal matrix in VT
* (Workspace: need N+BDSPAC)
*
CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT,
$ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Overwrite U by left singular vectors of R and VT
* by right singular vectors of R
* (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB)
*
NB = ILAENV( 1, 'DORMBR', 'QLN', N, N, N, -1 )
OPS = OPS + DOPLA2( 'DORMBR', 'QLN', N, N, N, 0, NB )
CALL DORMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
NB = ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 )
OPS = OPS + DOPLA2( 'DORMBR', 'PRT', N, N, N, 0, NB )
CALL DORMBR( 'P', 'R', 'T', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Multiply Q in A by left singular vectors of R in
* WORK(IR), storing result in U
* (Workspace: need N*N)
*
CALL DLACPY( 'F', N, N, U, LDU, WORK( IR ), LDWRKR )
OPS = OPS + DOPBL3( 'DGEMM ', M, N, N )
CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA, WORK( IR ),
$ LDWRKR, ZERO, U, LDU )
*
ELSE IF( WNTQA ) THEN
*
* Path 4 (M much larger than N, JOBZ='A')
* M left singular vectors to be computed in U and
* N right singular vectors to be computed in VT
*
IU = 1
*
* WORK(IU) is N by N
*
LDWRKU = N
ITAU = IU + LDWRKU*N
NWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
OPS = OPS + DOPLA( 'DGEQRF', M, N, 0, 0, NB )
CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
NB = ILAENV( 1, 'DORGQR', ' ', M, M, N, -1 )
OPS = OPS + DOPLA( 'DORGQR', M, M, N, 0, NB )
CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Produce R in A, zeroing out other entries
*
CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
IE = ITAU
ITAUQ = IE + N
ITAUP = ITAUQ + N
NWORK = ITAUP + N
*
* Bidiagonalize R in A
* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
*
NB = ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 )
OPS = OPS + DOPLA( 'DGEBRD', N, N, 0, 0, NB )
CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in WORK(IU) and computing right
* singular vectors of bidiagonal matrix in VT
* (Workspace: need N+N*N+BDSPAC)
*
CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N,
$ VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Overwrite WORK(IU) by left singular vectors of R and VT
* by right singular vectors of R
* (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB)
*
NB = ILAENV( 1, 'DORMBR', 'QLN', N, N, N, -1 )
OPS = OPS + DOPLA2( 'DORMBR', 'QLN', N, N, N, 0, NB )
CALL DORMBR( 'Q', 'L', 'N', N, N, N, A, LDA,
$ WORK( ITAUQ ), WORK( IU ), LDWRKU,
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
NB = ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 )
OPS = OPS + DOPLA2( 'DORMBR', 'PRT', N, N, N, 0, NB )
CALL DORMBR( 'P', 'R', 'T', N, N, N, A, LDA,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Multiply Q in U by left singular vectors of R in
* WORK(IU), storing result in A
* (Workspace: need N*N)
*
OPS = OPS + DOPBL3( 'DGEMM ', M, N, N )
CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU, WORK( IU ),
$ LDWRKU, ZERO, A, LDA )
*
* Copy left singular vectors of A from A to U
*
CALL DLACPY( 'F', M, N, A, LDA, U, LDU )
*
END IF
*
ELSE
*
* M .LT. MNTHR
*
* Path 5 (M at least N, but not much larger)
* Reduce to bidiagonal form without QR decomposition
*
IE = 1
ITAUQ = IE + N
ITAUP = ITAUQ + N
NWORK = ITAUP + N
*
* Bidiagonalize A
* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB)
*
NB = MAX( 1, ILAENV( 1, 'DGEBRD', ' ', M, N, -1, -1 ) )
OPS = OPS + DOPLA( 'DGEBRD', M, N, 0, 0, NB )
CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
IF( WNTQN ) THEN
*
* Perform bidiagonal SVD, only computing singular values
* (Workspace: need N+BDSPAC)
*
CALL DBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1,
$ DUM, IDUM, WORK( NWORK ), IWORK, INFO )
ELSE IF( WNTQO ) THEN
IU = NWORK
IF( LWORK.GE.M*N+3*N+BDSPAC ) THEN
*
* WORK( IU ) is M by N
*
LDWRKU = M
NWORK = IU + LDWRKU*N
CALL DLASET( 'F', M, N, ZERO, ZERO, WORK( IU ),
$ LDWRKU )
ELSE
*
* WORK( IU ) is N by N
*
LDWRKU = N
NWORK = IU + LDWRKU*N
*
* WORK(IR) is LDWRKR by N
*
IR = NWORK
LDWRKR = ( LWORK-N*N-3*N ) / N
END IF
NWORK = IU + LDWRKU*N
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in WORK(IU) and computing right
* singular vectors of bidiagonal matrix in VT
* (Workspace: need N+N*N+BDSPAC)
*
CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ),
$ LDWRKU, VT, LDVT, DUM, IDUM, WORK( NWORK ),
$ IWORK, INFO )
*
* Overwrite VT by right singular vectors of A
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
NB = ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 )
OPS = OPS + DOPLA2( 'DORMBR', 'PRT', N, N, N, 0, NB )
CALL DORMBR( 'P', 'R', 'T', N, N, N, A, LDA,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
IF( LWORK.GE.M*N+3*N+BDSPAC ) THEN
*
* Overwrite WORK(IU) by left singular vectors of A
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
NB = ILAENV( 1, 'DORMBR', 'QLN', M, N, N, -1 )
OPS = OPS + DOPLA2( 'DORMBR', 'QLN', M, N, N, 0, NB )
CALL DORMBR( 'Q', 'L', 'N', M, N, N, A, LDA,
$ WORK( ITAUQ ), WORK( IU ), LDWRKU,
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Copy left singular vectors of A from WORK(IU) to A
*
CALL DLACPY( 'F', M, N, WORK( IU ), LDWRKU, A, LDA )
ELSE
*
* Generate Q in A
* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
*
NB = ILAENV( 1, 'DORGBR', 'Q', M, N, N, -1 )
OPS = OPS + DOPLA2( 'DORGBR', 'Q', M, N, N, 0, NB )
CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Multiply Q in A by left singular vectors of
* bidiagonal matrix in WORK(IU), storing result in
* WORK(IR) and copying to A
* (Workspace: need 2*N*N, prefer N*N+M*N)
*
DO 20 I = 1, M, LDWRKR
CHUNK = MIN( M-I+1, LDWRKR )
OPS = OPS + DOPBL3( 'DGEMM ', CHUNK, N, N )
CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
$ LDA, WORK( IU ), LDWRKU, ZERO,
$ WORK( IR ), LDWRKR )
CALL DLACPY( 'F', CHUNK, N, WORK( IR ), LDWRKR,
$ A( I, 1 ), LDA )
20 CONTINUE
END IF
*
ELSE IF( WNTQS ) THEN
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U and computing right singular
* vectors of bidiagonal matrix in VT
* (Workspace: need N+BDSPAC)
*
CALL DLASET( 'F', M, N, ZERO, ZERO, U, LDU )
CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT,
$ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Overwrite U by left singular vectors of A and VT
* by right singular vectors of A
* (Workspace: need 3*N, prefer 2*N+N*NB)
*
NB = ILAENV( 1, 'DORMBR', 'QLN', M, N, N, -1 )
OPS = OPS + DOPLA2( 'DORMBR', 'QLN', M, N, N, 0, NB )
CALL DORMBR( 'Q', 'L', 'N', M, N, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
NB = ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 )
OPS = OPS + DOPLA2( 'DORMBR', 'PRT', N, N, N, 0, NB )
CALL DORMBR( 'P', 'R', 'T', N, N, N, A, LDA,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
ELSE IF( WNTQA ) THEN
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U and computing right singular
* vectors of bidiagonal matrix in VT
* (Workspace: need N+BDSPAC)
*
CALL DLASET( 'F', M, M, ZERO, ZERO, U, LDU )
CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT,
$ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Set the right corner of U to identity matrix
*
CALL DLASET( 'F', M-N, M-N, ZERO, ONE, U( N+1, N+1 ),
$ LDU )
*
* Overwrite U by left singular vectors of A and VT
* by right singular vectors of A
* (Workspace: need N*N+2*N+M, prefer N*N+2*N+M*NB)
*
NB = ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 )
OPS = OPS + DOPLA2( 'DORMBR', 'QLN', M, M, N, 0, NB )
CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
NB = ILAENV( 1, 'DORMBR', 'PRT', N, N, M, -1 )
OPS = OPS + DOPLA2( 'DORMBR', 'PRT', N, N, M, 0, NB )
CALL DORMBR( 'P', 'R', 'T', N, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
END IF
*
END IF
*
ELSE
*
* A has more columns than rows. If A has sufficiently more
* columns than rows, first reduce using the LQ decomposition (if
* sufficient workspace available)
*
IF( N.GE.MNTHR ) THEN
*
IF( WNTQN ) THEN
*
* Path 1t (N much larger than M, JOBZ='N')
* No singular vectors to be computed
*
ITAU = 1
NWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need 2*M, prefer M+M*NB)
*
NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
OPS = OPS + DOPLA( 'DGELQF', M, N, 0, 0, NB )
CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Zero out above L
*
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA )
IE = 1
ITAUQ = IE + M
ITAUP = ITAUQ + M
NWORK = ITAUP + M
*
* Bidiagonalize L in A
* (Workspace: need 4*M, prefer 3*M+2*M*NB)
*
NB = ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 )
OPS = OPS + DOPLA( 'DGEBRD', M, M, 0, 0, NB )
CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
NWORK = IE + M
*
* Perform bidiagonal SVD, computing singular values only
* (Workspace: need M+BDSPAC)
*
CALL DBDSDC( 'U', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1,
$ DUM, IDUM, WORK( NWORK ), IWORK, INFO )
*
ELSE IF( WNTQO ) THEN
*
* Path 2t (N much larger than M, JOBZ='O')
* M right singular vectors to be overwritten on A and
* M left singular vectors to be computed in U
*
IVT = 1
*
* IVT is M by M
*
IL = IVT + M*M
IF( LWORK.GE.M*N+M*M+3*M+BDSPAC ) THEN
*
* WORK(IL) is M by N
*
LDWRKL = M
CHUNK = N
ELSE
LDWRKL = M
CHUNK = ( LWORK-M*M ) / M
END IF
ITAU = IL + LDWRKL*M
NWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
OPS = OPS + DOPLA( 'DGELQF', M, N, 0, 0, NB )
CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Copy L to WORK(IL), zeroing about above it
*
CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL )
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
$ WORK( IL+LDWRKL ), LDWRKL )
*
* Generate Q in A
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
NB = ILAENV( 1, 'DORGLQ', ' ', M, N, M, -1 )
OPS = OPS + DOPLA( 'DORGLQ', M, N, M, 0, NB )
CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
NWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IL)
* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
*
NB = ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 )
OPS = OPS + DOPLA( 'DGEBRD', M, M, 0, 0, NB )
CALL DGEBRD( M, M, WORK( IL ), LDWRKL, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U, and computing right singular
* vectors of bidiagonal matrix in WORK(IVT)
* (Workspace: need M+M*M+BDSPAC)
*
CALL DBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU,
$ WORK( IVT ), M, DUM, IDUM, WORK( NWORK ),
$ IWORK, INFO )
*
* Overwrite U by left singular vectors of L and WORK(IVT)
* by right singular vectors of L
* (Workspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB)
*
NB = ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 )
OPS = OPS + DOPLA2( 'DORMBR', 'QLN', M, M, M, 0, NB )
CALL DORMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
NB = ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 )
OPS = OPS + DOPLA2( 'DORMBR', 'PRT', M, M, M, 0, NB )
CALL DORMBR( 'P', 'R', 'T', M, M, M, WORK( IL ), LDWRKL,
$ WORK( ITAUP ), WORK( IVT ), M,
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Multiply right singular vectors of L in WORK(IVT) by Q
* in A, storing result in WORK(IL) and copying to A
* (Workspace: need 2*M*M, prefer M*M+M*N)
*
DO 30 I = 1, N, CHUNK
BLK = MIN( N-I+1, CHUNK )
OPS = OPS + DOPBL3( 'DGEMM ', M, BLK, M )
CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IVT ), M,
$ A( 1, I ), LDA, ZERO, WORK( IL ), LDWRKL )
CALL DLACPY( 'F', M, BLK, WORK( IL ), LDWRKL,
$ A( 1, I ), LDA )
30 CONTINUE
*
ELSE IF( WNTQS ) THEN
*
* Path 3t (N much larger than M, JOBZ='S')
* M right singular vectors to be computed in VT and
* M left singular vectors to be computed in U
*
IL = 1
*
* WORK(IL) is M by M
*
LDWRKL = M
ITAU = IL + LDWRKL*M
NWORK = ITAU + M
*
* Compute A=L*Q
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
OPS = OPS + DOPLA( 'DGELQF', M, N, 0, 0, NB )
CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Copy L to WORK(IL), zeroing out above it
*
CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL )
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
$ WORK( IL+LDWRKL ), LDWRKL )
*
* Generate Q in A
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
NB = ILAENV( 1, 'DORGLQ', ' ', M, N, M, -1 )
OPS = OPS + DOPLA( 'DORGLQ', M, N, M, 0, NB )
CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
NWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IU), copying result to U
* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
*
NB = MAX( 1, ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
OPS = OPS + DOPLA( 'DGEBRD', M, M, 0, 0, NB )
CALL DGEBRD( M, M, WORK( IL ), LDWRKL, S, WORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U and computing right singular
* vectors of bidiagonal matrix in VT
* (Workspace: need M+BDSPAC)
*
CALL DBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, VT,
$ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Overwrite U by left singular vectors of L and VT
* by right singular vectors of L
* (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB)
*
NB = ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 )
OPS = OPS + DOPLA2( 'DORMBR', 'QLN', M, M, M, 0, NB )
CALL DORMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
NB = ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 )
OPS = OPS + DOPLA2( 'DORMBR', 'PRT', M, M, M, 0, NB )
CALL DORMBR( 'P', 'R', 'T', M, M, M, WORK( IL ), LDWRKL,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Multiply right singular vectors of L in WORK(IL) by
* Q in A, storing result in VT
* (Workspace: need M*M)
*
CALL DLACPY( 'F', M, M, VT, LDVT, WORK( IL ), LDWRKL )
OPS = OPS + DOPBL3( 'DGEMM ', M, N, M )
CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IL ), LDWRKL,
$ A, LDA, ZERO, VT, LDVT )
*
ELSE IF( WNTQA ) THEN
*
* Path 4t (N much larger than M, JOBZ='A')
* N right singular vectors to be computed in VT and
* M left singular vectors to be computed in U
*
IVT = 1
*
* WORK(IVT) is M by M
*
LDWKVT = M
ITAU = IVT + LDWKVT*M
NWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
OPS = OPS + DOPLA( 'DGELQF', M, N, 0, 0, NB )
CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
NB = ILAENV( 1, 'DORGLQ', ' ', N, N, M, -1 )
OPS = OPS + DOPLA( 'DORGLQ', N, N, M, 0, NB )
CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Produce L in A, zeroing out other entries
*
CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA )
IE = ITAU
ITAUQ = IE + M
ITAUP = ITAUQ + M
NWORK = ITAUP + M
*
* Bidiagonalize L in A
* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
*
NB = ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 )
OPS = OPS + DOPLA( 'DGEBRD', M, M, 0, 0, NB )
CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U and computing right singular
* vectors of bidiagonal matrix in WORK(IVT)
* (Workspace: need M+M*M+BDSPAC)
*
CALL DBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU,
$ WORK( IVT ), LDWKVT, DUM, IDUM,
$ WORK( NWORK ), IWORK, INFO )
*
* Overwrite U by left singular vectors of L and WORK(IVT)
* by right singular vectors of L
* (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB)
*
NB = ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 )
OPS = OPS + DOPLA2( 'DORMBR', 'QLN', M, M, M, 0, NB )
CALL DORMBR( 'Q', 'L', 'N', M, M, M, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
NB = ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 )
OPS = OPS + DOPLA2( 'DORMBR', 'PRT', M, M, M, 0, NB )
CALL DORMBR( 'P', 'R', 'T', M, M, M, A, LDA,
$ WORK( ITAUP ), WORK( IVT ), LDWKVT,
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Multiply right singular vectors of L in WORK(IVT) by
* Q in VT, storing result in A
* (Workspace: need M*M)
*
OPS = OPS + DOPBL3( 'DGEMM ', M, N, M )
CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IVT ), LDWKVT,
$ VT, LDVT, ZERO, A, LDA )
*
* Copy right singular vectors of A from A to VT
*
CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT )
*
END IF
*
ELSE
*
* N .LT. MNTHR
*
* Path 5t (N greater than M, but not much larger)
* Reduce to bidiagonal form without LQ decomposition
*
IE = 1
ITAUQ = IE + M
ITAUP = ITAUQ + M
NWORK = ITAUP + M
*
* Bidiagonalize A
* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
*
NB = MAX( 1, ILAENV( 1, 'DGEBRD', ' ', M, N, -1, -1 ) )
OPS = OPS + DOPLA( 'DGEBRD', M, N, 0, 0, NB )
CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
IF( WNTQN ) THEN
*
* Perform bidiagonal SVD, only computing singular values
* (Workspace: need M+BDSPAC)
*
CALL DBDSDC( 'L', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1,
$ DUM, IDUM, WORK( NWORK ), IWORK, INFO )
ELSE IF( WNTQO ) THEN
LDWKVT = M
IVT = NWORK
IF( LWORK.GE.M*N+3*M+BDSPAC ) THEN
*
* WORK( IVT ) is M by N
*
CALL DLASET( 'F', M, N, ZERO, ZERO, WORK( IVT ),
$ LDWKVT )
NWORK = IVT + LDWKVT*N
ELSE
*
* WORK( IVT ) is M by M
*
NWORK = IVT + LDWKVT*M
IL = NWORK
*
* WORK(IL) is M by CHUNK
*
CHUNK = ( LWORK-M*M-3*M ) / M
END IF
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U and computing right singular
* vectors of bidiagonal matrix in WORK(IVT)
* (Workspace: need M*M+BDSPAC)
*
CALL DBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU,
$ WORK( IVT ), LDWKVT, DUM, IDUM,
$ WORK( NWORK ), IWORK, INFO )
*
* Overwrite U by left singular vectors of A
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
NB = ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 )
OPS = OPS + DOPLA2( 'DORMBR', 'QLN', M, M, N, 0, NB )
CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
IF( LWORK.GE.M*N+3*M+BDSPAC ) THEN
*
* Overwrite WORK(IVT) by left singular vectors of A
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
NB = ILAENV( 1, 'DORMBR', 'PRT', M, N, M, -1 )
OPS = OPS + DOPLA2( 'DORMBR', 'PRT', M, N, M, 0, NB )
CALL DORMBR( 'P', 'R', 'T', M, N, M, A, LDA,
$ WORK( ITAUP ), WORK( IVT ), LDWKVT,
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Copy right singular vectors of A from WORK(IVT) to A
*
CALL DLACPY( 'F', M, N, WORK( IVT ), LDWKVT, A, LDA )
ELSE
*
* Generate P**T in A
* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
*
NB = ILAENV( 1, 'DORGBR', 'P', M, N, M, -1 )
OPS = OPS + DOPLA2( 'DORGBR', 'P', M, N, M, 0, NB )
CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Multiply Q in A by right singular vectors of
* bidiagonal matrix in WORK(IVT), storing result in
* WORK(IL) and copying to A
* (Workspace: need 2*M*M, prefer M*M+M*N)
*
DO 40 I = 1, N, CHUNK
BLK = MIN( N-I+1, CHUNK )
OPS = OPS + DOPBL3( 'DGEMM ', M, BLK, M )
CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IVT ),
$ LDWKVT, A( 1, I ), LDA, ZERO,
$ WORK( IL ), M )
CALL DLACPY( 'F', M, BLK, WORK( IL ), M, A( 1, I ),
$ LDA )
40 CONTINUE
END IF
ELSE IF( WNTQS ) THEN
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U and computing right singular
* vectors of bidiagonal matrix in VT
* (Workspace: need M+BDSPAC)
*
CALL DLASET( 'F', M, N, ZERO, ZERO, VT, LDVT )
CALL DBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT,
$ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Overwrite U by left singular vectors of A and VT
* by right singular vectors of A
* (Workspace: need 3*M, prefer 2*M+M*NB)
*
NB = ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 )
OPS = OPS + DOPLA2( 'DORMBR', 'QLN', M, M, N, 0, NB )
CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
NB = ILAENV( 1, 'DORMBR', 'PRT', M, N, M, -1 )
OPS = OPS + DOPLA2( 'DORMBR', 'PRT', M, N, M, 0, NB )
CALL DORMBR( 'P', 'R', 'T', M, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
ELSE IF( WNTQA ) THEN
*
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in U and computing right singular
* vectors of bidiagonal matrix in VT
* (Workspace: need M+BDSPAC)
*
CALL DLASET( 'F', N, N, ZERO, ZERO, VT, LDVT )
CALL DBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT,
$ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
$ INFO )
*
* Set the right corner of VT to identity matrix
*
CALL DLASET( 'F', N-M, N-M, ZERO, ONE, VT( M+1, M+1 ),
$ LDVT )
*
* Overwrite U by left singular vectors of A and VT
* by right singular vectors of A
* (Workspace: need 2*M+N, prefer 2*M+N*NB)
*
NB = ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 )
OPS = OPS + DOPLA2( 'DORMBR', 'QLN', M, M, N, 0, NB )
CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
NB = ILAENV( 1, 'DORMBR', 'PRT', N, N, M, -1 )
OPS = OPS + DOPLA2( 'DORMBR', 'PRT', N, N, M, 0, NB )
CALL DORMBR( 'P', 'R', 'T', N, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
END IF
*
END IF
*
END IF
*
* Undo scaling if necessary
*
IF( ISCL.EQ.1 ) THEN
IF( ANRM.GT.BIGNUM ) THEN
OPS = OPS + DBLE( MINMN )
CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
$ IERR )
END IF
IF( ANRM.LT.SMLNUM ) THEN
OPS = OPS + DBLE( MINMN )
CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
$ IERR )
END IF
END IF
*
* Return optimal workspace in WORK(1)
*
WORK( 1 ) = DBLE( MAXWRK )
*
RETURN
*
* End of DGESDD
*
END
SUBROUTINE DGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q,
$ LDQ, Z, LDZ, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
CHARACTER COMPQ, COMPZ
INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
$ Z( LDZ, * )
* ..
* ---------------------- Begin Timing Code -------------------------
* Common block to return operation count and iteration count
* ITCNT is initialized to 0, OPS is only incremented
* OPST is used to accumulate small contributions to OPS
* to avoid roundoff error
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
* ----------------------- End Timing Code --------------------------
*
*
* Purpose
* =======
*
* DGGHRD reduces a pair of real matrices (A,B) to generalized upper
* Hessenberg form using orthogonal transformations, where A is a
* general matrix and B is upper triangular: Q' * A * Z = H and
* Q' * B * Z = T, where H is upper Hessenberg, T is upper triangular,
* and Q and Z are orthogonal, and ' means transpose.
*
* The orthogonal matrices Q and Z are determined as products of Givens
* rotations. They may either be formed explicitly, or they may be
* postmultiplied into input matrices Q1 and Z1, so that
*
* Q1 * A * Z1' = (Q1*Q) * H * (Z1*Z)'
* Q1 * B * Z1' = (Q1*Q) * T * (Z1*Z)'
*
* Arguments
* =========
*
* COMPQ (input) CHARACTER*1
* = 'N': do not compute Q;
* = 'I': Q is initialized to the unit matrix, and the
* orthogonal matrix Q is returned;
* = 'V': Q must contain an orthogonal matrix Q1 on entry,
* and the product Q1*Q is returned.
*
* COMPZ (input) CHARACTER*1
* = 'N': do not compute Z;
* = 'I': Z is initialized to the unit matrix, and the
* orthogonal matrix Z is returned;
* = 'V': Z must contain an orthogonal matrix Z1 on entry,
* and the product Z1*Z is returned.
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* It is assumed that A is already upper triangular in rows and
* columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally set
* by a previous call to DGGBAL; otherwise they should be set
* to 1 and N respectively.
* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
* On entry, the N-by-N general matrix to be reduced.
* On exit, the upper triangle and the first subdiagonal of A
* are overwritten with the upper Hessenberg matrix H, and the
* rest is set to zero.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
* On entry, the N-by-N upper triangular matrix B.
* On exit, the upper triangular matrix T = Q' B Z. The
* elements below the diagonal are set to zero.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
* If COMPQ='N': Q is not referenced.
* If COMPQ='I': on entry, Q need not be set, and on exit it
* contains the orthogonal matrix Q, where Q'
* is the product of the Givens transformations
* which are applied to A and B on the left.
* If COMPQ='V': on entry, Q must contain an orthogonal matrix
* Q1, and on exit this is overwritten by Q1*Q.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q.
* LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.
*
* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
* If COMPZ='N': Z is not referenced.
* If COMPZ='I': on entry, Z need not be set, and on exit it
* contains the orthogonal matrix Z, which is
* the product of the Givens transformations
* which are applied to A and B on the right.
* If COMPZ='V': on entry, Z must contain an orthogonal matrix
* Z1, and on exit this is overwritten by Z1*Z.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z.
* LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* This routine reduces A to Hessenberg and B to triangular form by
* an unblocked reduction, as described in _Matrix_Computations_,
* by Golub and Van Loan (Johns Hopkins Press.)
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL ILQ, ILZ
INTEGER ICOMPQ, ICOMPZ, JCOL, JROW
DOUBLE PRECISION C, S, TEMP
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DLARTG, DLASET, DROT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX
* ..
* .. Executable Statements ..
*
* Decode COMPQ
*
IF( LSAME( COMPQ, 'N' ) ) THEN
ILQ = .FALSE.
ICOMPQ = 1
ELSE IF( LSAME( COMPQ, 'V' ) ) THEN
ILQ = .TRUE.
ICOMPQ = 2
ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
ILQ = .TRUE.
ICOMPQ = 3
ELSE
ICOMPQ = 0
END IF
*
* Decode COMPZ
*
IF( LSAME( COMPZ, 'N' ) ) THEN
ILZ = .FALSE.
ICOMPZ = 1
ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
ILZ = .TRUE.
ICOMPZ = 2
ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
ILZ = .TRUE.
ICOMPZ = 3
ELSE
ICOMPZ = 0
END IF
*
* Test the input parameters.
*
INFO = 0
IF( ICOMPQ.LE.0 ) THEN
INFO = -1
ELSE IF( ICOMPZ.LE.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ILO.LT.1 ) THEN
INFO = -4
ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN
INFO = -11
ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN
INFO = -13
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGGHRD', -INFO )
RETURN
END IF
*
* Initialize Q and Z if desired.
*
IF( ICOMPQ.EQ.3 )
$ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
IF( ICOMPZ.EQ.3 )
$ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
*
* Quick return if possible
*
IF( N.LE.1 )
$ RETURN
*
* Zero out lower triangle of B
*
DO 20 JCOL = 1, N - 1
DO 10 JROW = JCOL + 1, N
B( JROW, JCOL ) = ZERO
10 CONTINUE
20 CONTINUE
*
* Reduce A and B
*
DO 40 JCOL = ILO, IHI - 2
*
DO 30 JROW = IHI, JCOL + 2, -1
*
* Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL)
*
TEMP = A( JROW-1, JCOL )
CALL DLARTG( TEMP, A( JROW, JCOL ), C, S,
$ A( JROW-1, JCOL ) )
A( JROW, JCOL ) = ZERO
CALL DROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA,
$ A( JROW, JCOL+1 ), LDA, C, S )
CALL DROT( N+2-JROW, B( JROW-1, JROW-1 ), LDB,
$ B( JROW, JROW-1 ), LDB, C, S )
IF( ILQ )
$ CALL DROT( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, C, S )
*
* Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1)
*
TEMP = B( JROW, JROW )
CALL DLARTG( TEMP, B( JROW, JROW-1 ), C, S,
$ B( JROW, JROW ) )
B( JROW, JROW-1 ) = ZERO
CALL DROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, C, S )
CALL DROT( JROW-1, B( 1, JROW ), 1, B( 1, JROW-1 ), 1, C,
$ S )
IF( ILZ )
$ CALL DROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, C, S )
30 CONTINUE
40 CONTINUE
*
* ---------------------- Begin Timing Code -------------------------
* Operation count: factor
* * number of calls to DLARTG TEMP *7
* * total number of rows/cols
* rotated in A and B TEMP*[6n + 2(ihi-ilo) + 5]/6 *6
* * rows rotated in Q TEMP*n/2 *6
* * rows rotated in Z TEMP*n/2 *6
*
TEMP = DBLE( IHI-ILO )*DBLE( IHI-ILO-1 )
JROW = 6*N + 2*( IHI-ILO ) + 12
IF( ILQ )
$ JROW = JROW + 3*N
IF( ILZ )
$ JROW = JROW + 3*N
OPS = OPS + DBLE( JROW )*TEMP
ITCNT = ZERO
*
* ----------------------- End Timing Code --------------------------
*
RETURN
*
* End of DGGHRD
*
END
SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB,
$ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK,
$ LWORK, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER COMPQ, COMPZ, JOB
INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, LWORK, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
$ B( LDB, * ), BETA( * ), Q( LDQ, * ), WORK( * ),
$ Z( LDZ, * )
* ..
* ---------------------- Begin Timing Code -------------------------
* Common block to return operation count and iteration count
* ITCNT is initialized to 0, OPS is only incremented
* OPST is used to accumulate small contributions to OPS
* to avoid roundoff error
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
* ----------------------- End Timing Code --------------------------
*
* Purpose
* =======
*
* DHGEQZ implements a single-/double-shift version of the QZ method for
* finding the generalized eigenvalues
*
* w(j)=(ALPHAR(j) + i*ALPHAI(j))/BETAR(j) of the equation
*
* det( A - w(i) B ) = 0
*
* In addition, the pair A,B may be reduced to generalized Schur form:
* B is upper triangular, and A is block upper triangular, where the
* diagonal blocks are either 1-by-1 or 2-by-2, the 2-by-2 blocks having
* complex generalized eigenvalues (see the description of the argument
* JOB.)
*
* If JOB='S', then the pair (A,B) is simultaneously reduced to Schur
* form by applying one orthogonal tranformation (usually called Q) on
* the left and another (usually called Z) on the right. The 2-by-2
* upper-triangular diagonal blocks of B corresponding to 2-by-2 blocks
* of A will be reduced to positive diagonal matrices. (I.e.,
* if A(j+1,j) is non-zero, then B(j+1,j)=B(j,j+1)=0 and B(j,j) and
* B(j+1,j+1) will be positive.)
*
* If JOB='E', then at each iteration, the same transformations
* are computed, but they are only applied to those parts of A and B
* which are needed to compute ALPHAR, ALPHAI, and BETAR.
*
* If JOB='S' and COMPQ and COMPZ are 'V' or 'I', then the orthogonal
* transformations used to reduce (A,B) are accumulated into the arrays
* Q and Z s.t.:
*
* Q(in) A(in) Z(in)* = Q(out) A(out) Z(out)*
* Q(in) B(in) Z(in)* = Q(out) B(out) Z(out)*
*
* Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix
* Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973),
* pp. 241--256.
*
* Arguments
* =========
*
* JOB (input) CHARACTER*1
* = 'E': compute only ALPHAR, ALPHAI, and BETA. A and B will
* not necessarily be put into generalized Schur form.
* = 'S': put A and B into generalized Schur form, as well
* as computing ALPHAR, ALPHAI, and BETA.
*
* COMPQ (input) CHARACTER*1
* = 'N': do not modify Q.
* = 'V': multiply the array Q on the right by the transpose of
* the orthogonal tranformation that is applied to the
* left side of A and B to reduce them to Schur form.
* = 'I': like COMPQ='V', except that Q will be initialized to
* the identity first.
*
* COMPZ (input) CHARACTER*1
* = 'N': do not modify Z.
* = 'V': multiply the array Z on the right by the orthogonal
* tranformation that is applied to the right side of
* A and B to reduce them to Schur form.
* = 'I': like COMPZ='V', except that Z will be initialized to
* the identity first.
*
* N (input) INTEGER
* The order of the matrices A, B, Q, and Z. N >= 0.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* It is assumed that A is already upper triangular in rows and
* columns 1:ILO-1 and IHI+1:N.
* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
* On entry, the N-by-N upper Hessenberg matrix A. Elements
* below the subdiagonal must be zero.
* If JOB='S', then on exit A and B will have been
* simultaneously reduced to generalized Schur form.
* If JOB='E', then on exit A will have been destroyed.
* The diagonal blocks will be correct, but the off-diagonal
* portion will be meaningless.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max( 1, N ).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
* On entry, the N-by-N upper triangular matrix B. Elements
* below the diagonal must be zero. 2-by-2 blocks in B
* corresponding to 2-by-2 blocks in A will be reduced to
* positive diagonal form. (I.e., if A(j+1,j) is non-zero,
* then B(j+1,j)=B(j,j+1)=0 and B(j,j) and B(j+1,j+1) will be
* positive.)
* If JOB='S', then on exit A and B will have been
* simultaneously reduced to Schur form.
* If JOB='E', then on exit B will have been destroyed.
* Elements corresponding to diagonal blocks of A will be
* correct, but the off-diagonal portion will be meaningless.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max( 1, N ).
*
* ALPHAR (output) DOUBLE PRECISION array, dimension (N)
* ALPHAR(1:N) will be set to real parts of the diagonal
* elements of A that would result from reducing A and B to
* Schur form and then further reducing them both to triangular
* form using unitary transformations s.t. the diagonal of B
* was non-negative real. Thus, if A(j,j) is in a 1-by-1 block
* (i.e., A(j+1,j)=A(j,j+1)=0), then ALPHAR(j)=A(j,j).
* Note that the (real or complex) values
* (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the
* generalized eigenvalues of the matrix pencil A - wB.
*
* ALPHAI (output) DOUBLE PRECISION array, dimension (N)
* ALPHAI(1:N) will be set to imaginary parts of the diagonal
* elements of A that would result from reducing A and B to
* Schur form and then further reducing them both to triangular
* form using unitary transformations s.t. the diagonal of B
* was non-negative real. Thus, if A(j,j) is in a 1-by-1 block
* (i.e., A(j+1,j)=A(j,j+1)=0), then ALPHAR(j)=0.
* Note that the (real or complex) values
* (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the
* generalized eigenvalues of the matrix pencil A - wB.
*
* BETA (output) DOUBLE PRECISION array, dimension (N)
* BETA(1:N) will be set to the (real) diagonal elements of B
* that would result from reducing A and B to Schur form and
* then further reducing them both to triangular form using
* unitary transformations s.t. the diagonal of B was
* non-negative real. Thus, if A(j,j) is in a 1-by-1 block
* (i.e., A(j+1,j)=A(j,j+1)=0), then BETA(j)=B(j,j).
* Note that the (real or complex) values
* (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the
* generalized eigenvalues of the matrix pencil A - wB.
* (Note that BETA(1:N) will always be non-negative, and no
* BETAI is necessary.)
*
* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
* If COMPQ='N', then Q will not be referenced.
* If COMPQ='V' or 'I', then the transpose of the orthogonal
* transformations which are applied to A and B on the left
* will be applied to the array Q on the right.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= 1.
* If COMPQ='V' or 'I', then LDQ >= N.
*
* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
* If COMPZ='N', then Z will not be referenced.
* If COMPZ='V' or 'I', then the orthogonal transformations
* which are applied to A and B on the right will be applied
* to the array Z on the right.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1.
* If COMPZ='V' or 'I', then LDZ >= N.
*
* WORK (workspace/output) DOUBLE PRECISION array, dimension (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).
*
* 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
* = 1,...,N: the QZ iteration did not converge. (A,B) is not
* in Schur form, but ALPHAR(i), ALPHAI(i), and
* BETA(i), i=INFO+1,...,N should be correct.
* = N+1,...,2*N: the shift calculation failed. (A,B) is not
* in Schur form, but ALPHAR(i), ALPHAI(i), and
* BETA(i), i=INFO-N+1,...,N should be correct.
* > 2*N: various "impossible" errors.
*
* Further Details
* ===============
*
* Iteration counters:
*
* JITER -- counts iterations.
* IITER -- counts iterations run since ILAST was last
* changed. This is therefore reset only when a 1-by-1 or
* 2-by-2 block deflates off the bottom.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION HALF, ZERO, ONE, SAFETY
PARAMETER ( HALF = 0.5D+0, ZERO = 0.0D+0, ONE = 1.0D+0,
$ SAFETY = 1.0D+2 )
* ..
* .. Local Scalars ..
LOGICAL ILAZR2, ILAZRO, ILPIVT, ILQ, ILSCHR, ILZ,
$ LQUERY
INTEGER ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST,
$ ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER,
$ JR, MAXIT, NQ, NZ
DOUBLE PRECISION A11, A12, A1I, A1R, A21, A22, A2I, A2R, AD11,
$ AD11L, AD12, AD12L, AD21, AD21L, AD22, AD22L,
$ AD32L, AN, ANORM, ASCALE, ATOL, B11, B1A, B1I,
$ B1R, B22, B2A, B2I, B2R, BN, BNORM, BSCALE,
$ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL,
$ CQ, CR, CZ, ESHIFT, OPST, S, S1, S1INV, S2,
$ SAFMAX, SAFMIN, SCALE, SL, SQI, SQR, SR, SZI,
$ SZR, T, TAU, TEMP, TEMP2, TEMPI, TEMPR, U1,
$ U12, U12L, U2, ULP, VS, W11, W12, W21, W22,
$ WABS, WI, WR, WR2
* ..
* .. Local Arrays ..
DOUBLE PRECISION V( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANHS, DLAPY2, DLAPY3
EXTERNAL LSAME, DLAMCH, DLANHS, DLAPY2, DLAPY3
* ..
* .. External Subroutines ..
EXTERNAL DLAG2, DLARFG, DLARTG, DLASET, DLASV2, DROT,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Decode JOB, COMPQ, COMPZ
*
IF( LSAME( JOB, 'E' ) ) THEN
ILSCHR = .FALSE.
ISCHUR = 1
ELSE IF( LSAME( JOB, 'S' ) ) THEN
ILSCHR = .TRUE.
ISCHUR = 2
ELSE
ISCHUR = 0
END IF
*
IF( LSAME( COMPQ, 'N' ) ) THEN
ILQ = .FALSE.
ICOMPQ = 1
NQ = 0
ELSE IF( LSAME( COMPQ, 'V' ) ) THEN
ILQ = .TRUE.
ICOMPQ = 2
NQ = N
ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
ILQ = .TRUE.
ICOMPQ = 3
NQ = N
ELSE
ICOMPQ = 0
END IF
*
IF( LSAME( COMPZ, 'N' ) ) THEN
ILZ = .FALSE.
ICOMPZ = 1
NZ = 0
ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
ILZ = .TRUE.
ICOMPZ = 2
NZ = N
ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
ILZ = .TRUE.
ICOMPZ = 3
NZ = N
ELSE
ICOMPZ = 0
END IF
*
* Check Argument Values
*
INFO = 0
WORK( 1 ) = MAX( 1, N )
LQUERY = ( LWORK.EQ.-1 )
IF( ISCHUR.EQ.0 ) THEN
INFO = -1
ELSE IF( ICOMPQ.EQ.0 ) THEN
INFO = -2
ELSE IF( ICOMPZ.EQ.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( ILO.LT.1 ) THEN
INFO = -5
ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
INFO = -6
ELSE IF( LDA.LT.N ) THEN
INFO = -8
ELSE IF( LDB.LT.N ) THEN
INFO = -10
ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN
INFO = -15
ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN
INFO = -17
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -19
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DHGEQZ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 ) THEN
WORK( 1 ) = DBLE( 1 )
* --------------------- Begin Timing Code -----------------------
ITCNT = ZERO
* ---------------------- End Timing Code ------------------------
RETURN
END IF
*
* Initialize Q and Z
*
IF( ICOMPQ.EQ.3 )
$ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
IF( ICOMPZ.EQ.3 )
$ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
*
* Machine Constants
*
IN = IHI + 1 - ILO
SAFMIN = DLAMCH( 'S' )
SAFMAX = ONE / SAFMIN
ULP = DLAMCH( 'E' )*DLAMCH( 'B' )
ANORM = DLANHS( 'F', IN, A( ILO, ILO ), LDA, WORK )
BNORM = DLANHS( 'F', IN, B( ILO, ILO ), LDB, WORK )
ATOL = MAX( SAFMIN, ULP*ANORM )
BTOL = MAX( SAFMIN, ULP*BNORM )
ASCALE = ONE / MAX( SAFMIN, ANORM )
BSCALE = ONE / MAX( SAFMIN, BNORM )
*
* Set Eigenvalues IHI+1:N
*
DO 30 J = IHI + 1, N
IF( B( J, J ).LT.ZERO ) THEN
IF( ILSCHR ) THEN
DO 10 JR = 1, J
A( JR, J ) = -A( JR, J )
B( JR, J ) = -B( JR, J )
10 CONTINUE
ELSE
A( J, J ) = -A( J, J )
B( J, J ) = -B( J, J )
END IF
IF( ILZ ) THEN
DO 20 JR = 1, N
Z( JR, J ) = -Z( JR, J )
20 CONTINUE
END IF
END IF
ALPHAR( J ) = A( J, J )
ALPHAI( J ) = ZERO
BETA( J ) = B( J, J )
30 CONTINUE
*
* ---------------------- Begin Timing Code -------------------------
* Count ops for norms, etc.
OPST = ZERO
OPS = OPS + DBLE( 2*N**2+6*N )
* ----------------------- End Timing Code --------------------------
*
*
* If IHI < ILO, skip QZ steps
*
IF( IHI.LT.ILO )
$ GO TO 380
*
* MAIN QZ ITERATION LOOP
*
* Initialize dynamic indices
*
* Eigenvalues ILAST+1:N have been found.
* Column operations modify rows IFRSTM:whatever.
* Row operations modify columns whatever:ILASTM.
*
* If only eigenvalues are being computed, then
* IFRSTM is the row of the last splitting row above row ILAST;
* this is always at least ILO.
* IITER counts iterations since the last eigenvalue was found,
* to tell when to use an extraordinary shift.
* MAXIT is the maximum number of QZ sweeps allowed.
*
ILAST = IHI
IF( ILSCHR ) THEN
IFRSTM = 1
ILASTM = N
ELSE
IFRSTM = ILO
ILASTM = IHI
END IF
IITER = 0
ESHIFT = ZERO
MAXIT = 30*( IHI-ILO+1 )
*
DO 360 JITER = 1, MAXIT
*
* Split the matrix if possible.
*
* Two tests:
* 1: A(j,j-1)=0 or j=ILO
* 2: B(j,j)=0
*
IF( ILAST.EQ.ILO ) THEN
*
* Special case: j=ILAST
*
GO TO 80
ELSE
IF( ABS( A( ILAST, ILAST-1 ) ).LE.ATOL ) THEN
A( ILAST, ILAST-1 ) = ZERO
GO TO 80
END IF
END IF
*
IF( ABS( B( ILAST, ILAST ) ).LE.BTOL ) THEN
B( ILAST, ILAST ) = ZERO
GO TO 70
END IF
*
* General case: j unfl )
* __
* (sA - wB) ( CZ -SZ )
* ( SZ CZ )
*
C11R = S1*A11 - WR*B11
C11I = -WI*B11
C12 = S1*A12
C21 = S1*A21
C22R = S1*A22 - WR*B22
C22I = -WI*B22
*
IF( ABS( C11R )+ABS( C11I )+ABS( C12 ).GT.ABS( C21 )+
$ ABS( C22R )+ABS( C22I ) ) THEN
T = DLAPY3( C12, C11R, C11I )
CZ = C12 / T
SZR = -C11R / T
SZI = -C11I / T
ELSE
CZ = DLAPY2( C22R, C22I )
IF( CZ.LE.SAFMIN ) THEN
CZ = ZERO
SZR = ONE
SZI = ZERO
ELSE
TEMPR = C22R / CZ
TEMPI = C22I / CZ
T = DLAPY2( CZ, C21 )
CZ = CZ / T
SZR = -C21*TEMPR / T
SZI = C21*TEMPI / T
END IF
END IF
*
* Compute Givens rotation on left
*
* ( CQ SQ )
* ( __ ) A or B
* ( -SQ CQ )
*
AN = ABS( A11 ) + ABS( A12 ) + ABS( A21 ) + ABS( A22 )
BN = ABS( B11 ) + ABS( B22 )
WABS = ABS( WR ) + ABS( WI )
IF( S1*AN.GT.WABS*BN ) THEN
CQ = CZ*B11
SQR = SZR*B22
SQI = -SZI*B22
ELSE
A1R = CZ*A11 + SZR*A12
A1I = SZI*A12
A2R = CZ*A21 + SZR*A22
A2I = SZI*A22
CQ = DLAPY2( A1R, A1I )
IF( CQ.LE.SAFMIN ) THEN
CQ = ZERO
SQR = ONE
SQI = ZERO
ELSE
TEMPR = A1R / CQ
TEMPI = A1I / CQ
SQR = TEMPR*A2R + TEMPI*A2I
SQI = TEMPI*A2R - TEMPR*A2I
END IF
END IF
T = DLAPY3( CQ, SQR, SQI )
CQ = CQ / T
SQR = SQR / T
SQI = SQI / T
*
* Compute diagonal elements of QBZ
*
TEMPR = SQR*SZR - SQI*SZI
TEMPI = SQR*SZI + SQI*SZR
B1R = CQ*CZ*B11 + TEMPR*B22
B1I = TEMPI*B22
B1A = DLAPY2( B1R, B1I )
B2R = CQ*CZ*B22 + TEMPR*B11
B2I = -TEMPI*B11
B2A = DLAPY2( B2R, B2I )
*
* Normalize so beta > 0, and Im( alpha1 ) > 0
*
BETA( ILAST-1 ) = B1A
BETA( ILAST ) = B2A
ALPHAR( ILAST-1 ) = ( WR*B1A )*S1INV
ALPHAI( ILAST-1 ) = ( WI*B1A )*S1INV
ALPHAR( ILAST ) = ( WR*B2A )*S1INV
ALPHAI( ILAST ) = -( WI*B2A )*S1INV
*
* ------------------- Begin Timing Code ----------------------
OPST = OPST + DBLE( 93 )
* -------------------- End Timing Code -----------------------
*
* Step 3: Go to next block -- exit if finished.
*
ILAST = IFIRST - 1
IF( ILAST.LT.ILO )
$ GO TO 380
*
* Reset counters
*
IITER = 0
ESHIFT = ZERO
IF( .NOT.ILSCHR ) THEN
ILASTM = ILAST
IF( IFRSTM.GT.ILAST )
$ IFRSTM = ILO
END IF
GO TO 350
ELSE
*
* Usual case: 3x3 or larger block, using Francis implicit
* double-shift
*
* 2
* Eigenvalue equation is w - c w + d = 0,
*
* -1 2 -1
* so compute 1st column of (A B ) - c A B + d
* using the formula in QZIT (from EISPACK)
*
* We assume that the block is at least 3x3
*
AD11 = ( ASCALE*A( ILAST-1, ILAST-1 ) ) /
$ ( BSCALE*B( ILAST-1, ILAST-1 ) )
AD21 = ( ASCALE*A( ILAST, ILAST-1 ) ) /
$ ( BSCALE*B( ILAST-1, ILAST-1 ) )
AD12 = ( ASCALE*A( ILAST-1, ILAST ) ) /
$ ( BSCALE*B( ILAST, ILAST ) )
AD22 = ( ASCALE*A( ILAST, ILAST ) ) /
$ ( BSCALE*B( ILAST, ILAST ) )
U12 = B( ILAST-1, ILAST ) / B( ILAST, ILAST )
AD11L = ( ASCALE*A( IFIRST, IFIRST ) ) /
$ ( BSCALE*B( IFIRST, IFIRST ) )
AD21L = ( ASCALE*A( IFIRST+1, IFIRST ) ) /
$ ( BSCALE*B( IFIRST, IFIRST ) )
AD12L = ( ASCALE*A( IFIRST, IFIRST+1 ) ) /
$ ( BSCALE*B( IFIRST+1, IFIRST+1 ) )
AD22L = ( ASCALE*A( IFIRST+1, IFIRST+1 ) ) /
$ ( BSCALE*B( IFIRST+1, IFIRST+1 ) )
AD32L = ( ASCALE*A( IFIRST+2, IFIRST+1 ) ) /
$ ( BSCALE*B( IFIRST+1, IFIRST+1 ) )
U12L = B( IFIRST, IFIRST+1 ) / B( IFIRST+1, IFIRST+1 )
*
V( 1 ) = ( AD11-AD11L )*( AD22-AD11L ) - AD12*AD21 +
$ AD21*U12*AD11L + ( AD12L-AD11L*U12L )*AD21L
V( 2 ) = ( ( AD22L-AD11L )-AD21L*U12L-( AD11-AD11L )-
$ ( AD22-AD11L )+AD21*U12 )*AD21L
V( 3 ) = AD32L*AD21L
*
ISTART = IFIRST
*
CALL DLARFG( 3, V( 1 ), V( 2 ), 1, TAU )
V( 1 ) = ONE
*
* Sweep
*
DO 290 J = ISTART, ILAST - 2
*
* All but last elements: use 3x3 Householder transforms.
*
* Zero (j-1)st column of A
*
IF( J.GT.ISTART ) THEN
V( 1 ) = A( J, J-1 )
V( 2 ) = A( J+1, J-1 )
V( 3 ) = A( J+2, J-1 )
*
CALL DLARFG( 3, A( J, J-1 ), V( 2 ), 1, TAU )
V( 1 ) = ONE
A( J+1, J-1 ) = ZERO
A( J+2, J-1 ) = ZERO
END IF
*
DO 230 JC = J, ILASTM
TEMP = TAU*( A( J, JC )+V( 2 )*A( J+1, JC )+V( 3 )*
$ A( J+2, JC ) )
A( J, JC ) = A( J, JC ) - TEMP
A( J+1, JC ) = A( J+1, JC ) - TEMP*V( 2 )
A( J+2, JC ) = A( J+2, JC ) - TEMP*V( 3 )
TEMP2 = TAU*( B( J, JC )+V( 2 )*B( J+1, JC )+V( 3 )*
$ B( J+2, JC ) )
B( J, JC ) = B( J, JC ) - TEMP2
B( J+1, JC ) = B( J+1, JC ) - TEMP2*V( 2 )
B( J+2, JC ) = B( J+2, JC ) - TEMP2*V( 3 )
230 CONTINUE
IF( ILQ ) THEN
DO 240 JR = 1, N
TEMP = TAU*( Q( JR, J )+V( 2 )*Q( JR, J+1 )+V( 3 )*
$ Q( JR, J+2 ) )
Q( JR, J ) = Q( JR, J ) - TEMP
Q( JR, J+1 ) = Q( JR, J+1 ) - TEMP*V( 2 )
Q( JR, J+2 ) = Q( JR, J+2 ) - TEMP*V( 3 )
240 CONTINUE
END IF
*
* Zero j-th column of B (see DLAGBC for details)
*
* Swap rows to pivot
*
ILPIVT = .FALSE.
TEMP = MAX( ABS( B( J+1, J+1 ) ), ABS( B( J+1, J+2 ) ) )
TEMP2 = MAX( ABS( B( J+2, J+1 ) ), ABS( B( J+2, J+2 ) ) )
IF( MAX( TEMP, TEMP2 ).LT.SAFMIN ) THEN
SCALE = ZERO
U1 = ONE
U2 = ZERO
GO TO 250
ELSE IF( TEMP.GE.TEMP2 ) THEN
W11 = B( J+1, J+1 )
W21 = B( J+2, J+1 )
W12 = B( J+1, J+2 )
W22 = B( J+2, J+2 )
U1 = B( J+1, J )
U2 = B( J+2, J )
ELSE
W21 = B( J+1, J+1 )
W11 = B( J+2, J+1 )
W22 = B( J+1, J+2 )
W12 = B( J+2, J+2 )
U2 = B( J+1, J )
U1 = B( J+2, J )
END IF
*
* Swap columns if nec.
*
IF( ABS( W12 ).GT.ABS( W11 ) ) THEN
ILPIVT = .TRUE.
TEMP = W12
TEMP2 = W22
W12 = W11
W22 = W21
W11 = TEMP
W21 = TEMP2
END IF
*
* LU-factor
*
TEMP = W21 / W11
U2 = U2 - TEMP*U1
W22 = W22 - TEMP*W12
W21 = ZERO
*
* Compute SCALE
*
SCALE = ONE
IF( ABS( W22 ).LT.SAFMIN ) THEN
SCALE = ZERO
U2 = ONE
U1 = -W12 / W11
GO TO 250
END IF
IF( ABS( W22 ).LT.ABS( U2 ) )
$ SCALE = ABS( W22 / U2 )
IF( ABS( W11 ).LT.ABS( U1 ) )
$ SCALE = MIN( SCALE, ABS( W11 / U1 ) )
*
* Solve
*
U2 = ( SCALE*U2 ) / W22
U1 = ( SCALE*U1-W12*U2 ) / W11
*
250 CONTINUE
IF( ILPIVT ) THEN
TEMP = U2
U2 = U1
U1 = TEMP
END IF
*
* Compute Householder Vector
*
T = SQRT( SCALE**2+U1**2+U2**2 )
TAU = ONE + SCALE / T
VS = -ONE / ( SCALE+T )
V( 1 ) = ONE
V( 2 ) = VS*U1
V( 3 ) = VS*U2
*
* Apply transformations from the right.
*
DO 260 JR = IFRSTM, MIN( J+3, ILAST )
TEMP = TAU*( A( JR, J )+V( 2 )*A( JR, J+1 )+V( 3 )*
$ A( JR, J+2 ) )
A( JR, J ) = A( JR, J ) - TEMP
A( JR, J+1 ) = A( JR, J+1 ) - TEMP*V( 2 )
A( JR, J+2 ) = A( JR, J+2 ) - TEMP*V( 3 )
260 CONTINUE
DO 270 JR = IFRSTM, J + 2
TEMP = TAU*( B( JR, J )+V( 2 )*B( JR, J+1 )+V( 3 )*
$ B( JR, J+2 ) )
B( JR, J ) = B( JR, J ) - TEMP
B( JR, J+1 ) = B( JR, J+1 ) - TEMP*V( 2 )
B( JR, J+2 ) = B( JR, J+2 ) - TEMP*V( 3 )
270 CONTINUE
IF( ILZ ) THEN
DO 280 JR = 1, N
TEMP = TAU*( Z( JR, J )+V( 2 )*Z( JR, J+1 )+V( 3 )*
$ Z( JR, J+2 ) )
Z( JR, J ) = Z( JR, J ) - TEMP
Z( JR, J+1 ) = Z( JR, J+1 ) - TEMP*V( 2 )
Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 )
280 CONTINUE
END IF
B( J+1, J ) = ZERO
B( J+2, J ) = ZERO
290 CONTINUE
*
* Last elements: Use Givens rotations
*
* Rotations from the left
*
J = ILAST - 1
TEMP = A( J, J-1 )
CALL DLARTG( TEMP, A( J+1, J-1 ), C, S, A( J, J-1 ) )
A( J+1, J-1 ) = ZERO
*
DO 300 JC = J, ILASTM
TEMP = C*A( J, JC ) + S*A( J+1, JC )
A( J+1, JC ) = -S*A( J, JC ) + C*A( J+1, JC )
A( J, JC ) = TEMP
TEMP2 = C*B( J, JC ) + S*B( J+1, JC )
B( J+1, JC ) = -S*B( J, JC ) + C*B( J+1, JC )
B( J, JC ) = TEMP2
300 CONTINUE
IF( ILQ ) THEN
DO 310 JR = 1, N
TEMP = C*Q( JR, J ) + S*Q( JR, J+1 )
Q( JR, J+1 ) = -S*Q( JR, J ) + C*Q( JR, J+1 )
Q( JR, J ) = TEMP
310 CONTINUE
END IF
*
* Rotations from the right.
*
TEMP = B( J+1, J+1 )
CALL DLARTG( TEMP, B( J+1, J ), C, S, B( J+1, J+1 ) )
B( J+1, J ) = ZERO
*
DO 320 JR = IFRSTM, ILAST
TEMP = C*A( JR, J+1 ) + S*A( JR, J )
A( JR, J ) = -S*A( JR, J+1 ) + C*A( JR, J )
A( JR, J+1 ) = TEMP
320 CONTINUE
DO 330 JR = IFRSTM, ILAST - 1
TEMP = C*B( JR, J+1 ) + S*B( JR, J )
B( JR, J ) = -S*B( JR, J+1 ) + C*B( JR, J )
B( JR, J+1 ) = TEMP
330 CONTINUE
IF( ILZ ) THEN
DO 340 JR = 1, N
TEMP = C*Z( JR, J+1 ) + S*Z( JR, J )
Z( JR, J ) = -S*Z( JR, J+1 ) + C*Z( JR, J )
Z( JR, J+1 ) = TEMP
340 CONTINUE
END IF
*
* ------------------- Begin Timing Code ----------------------
OPST = OPST + ( DBLE( 14+30-10+52+12*( ILASTM-IFRSTM )+6*
$ ( NQ+NZ ) )+DBLE( ILAST-1-ISTART )*
$ DBLE( 14+24+90+20*( ILASTM-IFRSTM )+10*( NQ+NZ ) ) )
* -------------------- End Timing Code -----------------------
*
* End of Double-Shift code
*
END IF
*
GO TO 350
*
* End of iteration loop
*
350 CONTINUE
* --------------------- Begin Timing Code -----------------------
OPS = OPS + OPST
OPST = ZERO
* ---------------------- End Timing Code ------------------------
*
*
360 CONTINUE
*
* Drop-through = non-convergence
*
370 CONTINUE
* ---------------------- Begin Timing Code -------------------------
OPS = OPS + OPST
OPST = ZERO
* ----------------------- End Timing Code --------------------------
*
INFO = ILAST
GO TO 420
*
* Successful completion of all QZ steps
*
380 CONTINUE
*
* Set Eigenvalues 1:ILO-1
*
DO 410 J = 1, ILO - 1
IF( B( J, J ).LT.ZERO ) THEN
IF( ILSCHR ) THEN
DO 390 JR = 1, J
A( JR, J ) = -A( JR, J )
B( JR, J ) = -B( JR, J )
390 CONTINUE
ELSE
A( J, J ) = -A( J, J )
B( J, J ) = -B( J, J )
END IF
IF( ILZ ) THEN
DO 400 JR = 1, N
Z( JR, J ) = -Z( JR, J )
400 CONTINUE
END IF
END IF
ALPHAR( J ) = A( J, J )
ALPHAI( J ) = ZERO
BETA( J ) = B( J, J )
410 CONTINUE
*
* Normal Termination
*
INFO = 0
*
* Exit (other than argument error) -- return optimal workspace size
*
420 CONTINUE
*
* ---------------------- Begin Timing Code -------------------------
OPS = OPS + OPST
OPST = ZERO
ITCNT = JITER
* ----------------------- End Timing Code --------------------------
*
WORK( 1 ) = DBLE( N )
RETURN
*
* End of DHGEQZ
*
END
SUBROUTINE DHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI,
$ VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL,
$ IFAILR, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
CHARACTER EIGSRC, INITV, SIDE
INTEGER INFO, LDH, LDVL, LDVR, M, MM, N
* ..
* .. Array Arguments ..
LOGICAL SELECT( * )
INTEGER IFAILL( * ), IFAILR( * )
DOUBLE PRECISION H( LDH, * ), VL( LDVL, * ), VR( LDVR, * ),
$ WI( * ), WORK( * ), WR( * )
* ..
* Common block to return operation count.
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DHSEIN uses inverse iteration to find specified right and/or left
* eigenvectors of a real upper Hessenberg matrix H.
*
* The right eigenvector x and the left eigenvector y of the matrix H
* corresponding to an eigenvalue w are defined by:
*
* H * x = w * x, y**h * H = w * y**h
*
* where y**h denotes the conjugate transpose of the vector y.
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* = 'R': compute right eigenvectors only;
* = 'L': compute left eigenvectors only;
* = 'B': compute both right and left eigenvectors.
*
* EIGSRC (input) CHARACTER*1
* Specifies the source of eigenvalues supplied in (WR,WI):
* = 'Q': the eigenvalues were found using DHSEQR; thus, if
* H has zero subdiagonal elements, and so is
* block-triangular, then the j-th eigenvalue can be
* assumed to be an eigenvalue of the block containing
* the j-th row/column. This property allows DHSEIN to
* perform inverse iteration on just one diagonal block.
* = 'N': no assumptions are made on the correspondence
* between eigenvalues and diagonal blocks. In this
* case, DHSEIN must always perform inverse iteration
* using the whole matrix H.
*
* INITV (input) CHARACTER*1
* = 'N': no initial vectors are supplied;
* = 'U': user-supplied initial vectors are stored in the arrays
* VL and/or VR.
*
* SELECT (input/output) LOGICAL array, dimension(N)
* Specifies the eigenvectors to be computed. To select the
* real eigenvector corresponding to a real eigenvalue WR(j),
* SELECT(j) must be set to .TRUE.. To select the complex
* eigenvector corresponding to a complex eigenvalue
* (WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)),
* either SELECT(j) or SELECT(j+1) or both must be set to
* .TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is
* .FALSE..
*
* N (input) INTEGER
* The order of the matrix H. N >= 0.
*
* H (input) DOUBLE PRECISION array, dimension (LDH,N)
* The upper Hessenberg matrix H.
*
* LDH (input) INTEGER
* The leading dimension of the array H. LDH >= max(1,N).
*
* WR (input/output) DOUBLE PRECISION array, dimension (N)
* WI (input) DOUBLE PRECISION array, dimension (N)
* On entry, the real and imaginary parts of the eigenvalues of
* H; a complex conjugate pair of eigenvalues must be stored in
* consecutive elements of WR and WI.
* On exit, WR may have been altered since close eigenvalues
* are perturbed slightly in searching for independent
* eigenvectors.
*
* VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)
* On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must
* contain starting vectors for the inverse iteration for the
* left eigenvectors; the starting vector for each eigenvector
* must be in the same column(s) in which the eigenvector will
* be stored.
* On exit, if SIDE = 'L' or 'B', the left eigenvectors
* specified by SELECT will be stored consecutively in the
* columns of VL, in the same order as their eigenvalues. A
* complex eigenvector corresponding to a complex eigenvalue is
* stored in two consecutive columns, the first holding the real
* part and the second the imaginary part.
* If SIDE = 'R', VL is not referenced.
*
* LDVL (input) INTEGER
* The leading dimension of the array VL.
* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
*
* VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)
* On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must
* contain starting vectors for the inverse iteration for the
* right eigenvectors; the starting vector for each eigenvector
* must be in the same column(s) in which the eigenvector will
* be stored.
* On exit, if SIDE = 'R' or 'B', the right eigenvectors
* specified by SELECT will be stored consecutively in the
* columns of VR, in the same order as their eigenvalues. A
* complex eigenvector corresponding to a complex eigenvalue is
* stored in two consecutive columns, the first holding the real
* part and the second the imaginary part.
* If SIDE = 'L', VR is not referenced.
*
* LDVR (input) INTEGER
* The leading dimension of the array VR.
* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
*
* MM (input) INTEGER
* The number of columns in the arrays VL and/or VR. MM >= M.
*
* M (output) INTEGER
* The number of columns in the arrays VL and/or VR required to
* store the eigenvectors; each selected real eigenvector
* occupies one column and each selected complex eigenvector
* occupies two columns.
*
* WORK (workspace) DOUBLE PRECISION array, dimension ((N+2)*N)
*
* IFAILL (output) INTEGER array, dimension (MM)
* If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left
* eigenvector in the i-th column of VL (corresponding to the
* eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the
* eigenvector converged satisfactorily. If the i-th and (i+1)th
* columns of VL hold a complex eigenvector, then IFAILL(i) and
* IFAILL(i+1) are set to the same value.
* If SIDE = 'R', IFAILL is not referenced.
*
* IFAILR (output) INTEGER array, dimension (MM)
* If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right
* eigenvector in the i-th column of VR (corresponding to the
* eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the
* eigenvector converged satisfactorily. If the i-th and (i+1)th
* columns of VR hold a complex eigenvector, then IFAILR(i) and
* IFAILR(i+1) are set to the same value.
* If SIDE = 'L', IFAILR is not referenced.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, i is the number of eigenvectors which
* failed to converge; see IFAILL and IFAILR for further
* details.
*
* Further Details
* ===============
*
* Each eigenvector is normalized so that the element of largest
* magnitude has magnitude 1; here the magnitude of a complex number
* (x,y) is taken to be |x|+|y|.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL BOTHV, FROMQR, LEFTV, NOINIT, PAIR, RIGHTV
INTEGER I, IINFO, K, KL, KLN, KR, KSI, KSR, LDWORK
DOUBLE PRECISION BIGNUM, EPS3, HNORM, OPST, SMLNUM, ULP, UNFL,
$ WKI, WKR
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANHS
EXTERNAL LSAME, DLAMCH, DLANHS
* ..
* .. External Subroutines ..
EXTERNAL DLAEIN, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Decode and test the input parameters.
*
BOTHV = LSAME( SIDE, 'B' )
RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV
LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV
*
FROMQR = LSAME( EIGSRC, 'Q' )
*
NOINIT = LSAME( INITV, 'N' )
*
* Set M to the number of columns required to store the selected
* eigenvectors, and standardize the array SELECT.
*
M = 0
PAIR = .FALSE.
DO 10 K = 1, N
IF( PAIR ) THEN
PAIR = .FALSE.
SELECT( K ) = .FALSE.
ELSE
IF( WI( K ).EQ.ZERO ) THEN
IF( SELECT( K ) )
$ M = M + 1
ELSE
PAIR = .TRUE.
IF( SELECT( K ) .OR. SELECT( K+1 ) ) THEN
SELECT( K ) = .TRUE.
M = M + 2
END IF
END IF
END IF
10 CONTINUE
*
INFO = 0
IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
INFO = -1
ELSE IF( .NOT.FROMQR .AND. .NOT.LSAME( EIGSRC, 'N' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOINIT .AND. .NOT.LSAME( INITV, 'U' ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN
INFO = -11
ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN
INFO = -13
ELSE IF( MM.LT.M ) THEN
INFO = -14
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DHSEIN', -INFO )
RETURN
END IF
***
* Initialize
OPST = 0
***
*
* Quick return if possible.
*
IF( N.EQ.0 )
$ RETURN
*
* Set machine-dependent constants.
*
UNFL = DLAMCH( 'Safe minimum' )
ULP = DLAMCH( 'Precision' )
SMLNUM = UNFL*( N / ULP )
BIGNUM = ( ONE-ULP ) / SMLNUM
*
LDWORK = N + 1
*
KL = 1
KLN = 0
IF( FROMQR ) THEN
KR = 0
ELSE
KR = N
END IF
KSR = 1
*
DO 120 K = 1, N
IF( SELECT( K ) ) THEN
*
* Compute eigenvector(s) corresponding to W(K).
*
IF( FROMQR ) THEN
*
* If affiliation of eigenvalues is known, check whether
* the matrix splits.
*
* Determine KL and KR such that 1 <= KL <= K <= KR <= N
* and H(KL,KL-1) and H(KR+1,KR) are zero (or KL = 1 or
* KR = N).
*
* Then inverse iteration can be performed with the
* submatrix H(KL:N,KL:N) for a left eigenvector, and with
* the submatrix H(1:KR,1:KR) for a right eigenvector.
*
DO 20 I = K, KL + 1, -1
IF( H( I, I-1 ).EQ.ZERO )
$ GO TO 30
20 CONTINUE
30 CONTINUE
KL = I
IF( K.GT.KR ) THEN
DO 40 I = K, N - 1
IF( H( I+1, I ).EQ.ZERO )
$ GO TO 50
40 CONTINUE
50 CONTINUE
KR = I
END IF
END IF
*
IF( KL.NE.KLN ) THEN
KLN = KL
*
* Compute infinity-norm of submatrix H(KL:KR,KL:KR) if it
* has not ben computed before.
*
HNORM = DLANHS( 'I', KR-KL+1, H( KL, KL ), LDH, WORK )
***
* Increment opcount for computing the norm of matrix
OPS = OPS + N*( N+1 ) / 2
***
IF( HNORM.GT.ZERO ) THEN
EPS3 = HNORM*ULP
ELSE
EPS3 = SMLNUM
END IF
END IF
*
* Perturb eigenvalue if it is close to any previous
* selected eigenvalues affiliated to the submatrix
* H(KL:KR,KL:KR). Close roots are modified by EPS3.
*
WKR = WR( K )
WKI = WI( K )
60 CONTINUE
DO 70 I = K - 1, KL, -1
IF( SELECT( I ) .AND. ABS( WR( I )-WKR )+
$ ABS( WI( I )-WKI ).LT.EPS3 ) THEN
WKR = WKR + EPS3
GO TO 60
END IF
70 CONTINUE
WR( K ) = WKR
***
* Increment opcount for loop 70
OPST = OPST + 2*( K-KL )
**
*
PAIR = WKI.NE.ZERO
IF( PAIR ) THEN
KSI = KSR + 1
ELSE
KSI = KSR
END IF
IF( LEFTV ) THEN
*
* Compute left eigenvector.
*
CALL DLAEIN( .FALSE., NOINIT, N-KL+1, H( KL, KL ), LDH,
$ WKR, WKI, VL( KL, KSR ), VL( KL, KSI ),
$ WORK, LDWORK, WORK( N*N+N+1 ), EPS3, SMLNUM,
$ BIGNUM, IINFO )
IF( IINFO.GT.0 ) THEN
IF( PAIR ) THEN
INFO = INFO + 2
ELSE
INFO = INFO + 1
END IF
IFAILL( KSR ) = K
IFAILL( KSI ) = K
ELSE
IFAILL( KSR ) = 0
IFAILL( KSI ) = 0
END IF
DO 80 I = 1, KL - 1
VL( I, KSR ) = ZERO
80 CONTINUE
IF( PAIR ) THEN
DO 90 I = 1, KL - 1
VL( I, KSI ) = ZERO
90 CONTINUE
END IF
END IF
IF( RIGHTV ) THEN
*
* Compute right eigenvector.
*
CALL DLAEIN( .TRUE., NOINIT, KR, H, LDH, WKR, WKI,
$ VR( 1, KSR ), VR( 1, KSI ), WORK, LDWORK,
$ WORK( N*N+N+1 ), EPS3, SMLNUM, BIGNUM,
$ IINFO )
IF( IINFO.GT.0 ) THEN
IF( PAIR ) THEN
INFO = INFO + 2
ELSE
INFO = INFO + 1
END IF
IFAILR( KSR ) = K
IFAILR( KSI ) = K
ELSE
IFAILR( KSR ) = 0
IFAILR( KSI ) = 0
END IF
DO 100 I = KR + 1, N
VR( I, KSR ) = ZERO
100 CONTINUE
IF( PAIR ) THEN
DO 110 I = KR + 1, N
VR( I, KSI ) = ZERO
110 CONTINUE
END IF
END IF
*
IF( PAIR ) THEN
KSR = KSR + 2
ELSE
KSR = KSR + 1
END IF
END IF
120 CONTINUE
*
***
* Compute final op count
OPS = OPS + OPST
***
RETURN
*
* End of DHSEIN
*
END
SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z,
$ LDZ, WORK, LWORK, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER COMPZ, JOB
INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ),
$ Z( LDZ, * )
* ..
* Common block to return operation count.
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DHSEQR computes the eigenvalues of a real upper Hessenberg matrix H
* and, optionally, the matrices T and Z from the Schur decomposition
* H = Z T Z**T, where T is an upper quasi-triangular matrix (the Schur
* form), and Z is the orthogonal matrix of Schur vectors.
*
* Optionally Z may be postmultiplied into an input orthogonal matrix Q,
* so that this routine can give the Schur factorization of a matrix A
* which has been reduced to the Hessenberg form H by the orthogonal
* matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.
*
* Arguments
* =========
*
* JOB (input) CHARACTER*1
* = 'E': compute eigenvalues only;
* = 'S': compute eigenvalues and the Schur form T.
*
* COMPZ (input) CHARACTER*1
* = 'N': no Schur vectors are computed;
* = 'I': Z is initialized to the unit matrix and the matrix Z
* of Schur vectors of H is returned;
* = 'V': Z must contain an orthogonal matrix Q on entry, and
* the product Q*Z is returned.
*
* N (input) INTEGER
* The order of the matrix H. N >= 0.
*
* 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. ILO and IHI are normally
* set by a previous call to DGEBAL, and then passed to SGEHRD
* when the matrix output by DGEBAL is reduced to Hessenberg
* form. Otherwise ILO and IHI should be set to 1 and N
* respectively.
* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
*
* H (input/output) DOUBLE PRECISION array, dimension (LDH,N)
* On entry, the upper Hessenberg matrix H.
* On exit, if JOB = 'S', H contains the upper quasi-triangular
* matrix T from the Schur decomposition (the Schur form);
* 2-by-2 diagonal blocks (corresponding to complex conjugate
* pairs of eigenvalues) are returned in standard form, with
* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. If JOB = 'E',
* the contents of H are unspecified on exit.
*
* LDH (input) INTEGER
* The leading dimension of the array H. LDH >= max(1,N).
*
* WR (output) DOUBLE PRECISION array, dimension (N)
* WI (output) DOUBLE PRECISION array, dimension (N)
* The real and imaginary parts, respectively, of the computed
* eigenvalues. If two eigenvalues are computed as a complex
* conjugate pair, they are stored in consecutive elements of
* WR and WI, say the i-th and (i+1)th, with WI(i) > 0 and
* WI(i+1) < 0. If JOB = 'S', the eigenvalues are stored in the
* same order as on the diagonal of the Schur form returned in
* H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2
* diagonal block, WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and
* WI(i+1) = -WI(i).
*
* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
* If COMPZ = 'N': Z is not referenced.
* If COMPZ = 'I': on entry, Z need not be set, and on exit, Z
* contains the orthogonal matrix Z of the Schur vectors of H.
* If COMPZ = 'V': on entry Z must contain an N-by-N matrix Q,
* which is assumed to be equal to the unit matrix except for
* the submatrix Z(ILO:IHI,ILO:IHI); on exit Z contains Q*Z.
* Normally Q is the orthogonal matrix generated by DORGHR after
* the call to DGEHRD which formed the Hessenberg matrix H.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z.
* LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise.
*
* WORK (workspace/output) DOUBLE PRECISION array, dimension (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).
*
* 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
* > 0: if INFO = i, DHSEQR failed to compute all of the
* eigenvalues in a total of 30*(IHI-ILO+1) iterations;
* elements 1:ilo-1 and i+1:n of WR and WI contain those
* eigenvalues which have been successfully computed.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
DOUBLE PRECISION CONST
PARAMETER ( CONST = 1.5D+0 )
INTEGER NSMAX, LDS
PARAMETER ( NSMAX = 15, LDS = NSMAX )
* ..
* .. Local Scalars ..
LOGICAL INITZ, LQUERY, WANTT, WANTZ
INTEGER I, I1, I2, IERR, II, ITEMP, ITN, ITS, J, K, L,
$ MAXB, NH, NR, NS, NV
DOUBLE PRECISION ABSW, OPST, OVFL, SMLNUM, TAU, TEMP, TST1, ULP,
$ UNFL
* ..
* .. Local Arrays ..
DOUBLE PRECISION S( LDS, NSMAX ), V( NSMAX+1 ), VV( NSMAX+1 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX, ILAENV
DOUBLE PRECISION DLAMCH, DLANHS, DLAPY2
EXTERNAL LSAME, IDAMAX, ILAENV, DLAMCH, DLANHS, DLAPY2
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMV, DLABAD, DLACPY, DLAHQR, DLARFG,
$ DLARFX, DLASET, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Decode and test the input parameters
*
WANTT = LSAME( JOB, 'S' )
INITZ = LSAME( COMPZ, 'I' )
WANTZ = INITZ .OR. LSAME( COMPZ, 'V' )
*
INFO = 0
WORK( 1 ) = MAX( 1, N )
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN
INFO = -1
ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
INFO = -5
ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDZ.LT.1 .OR. WANTZ .AND. LDZ.LT.MAX( 1, N ) ) THEN
INFO = -11
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DHSEQR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
***
* Initialize
OPST = 0
***
*
* Initialize Z, if necessary
*
IF( INITZ )
$ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
*
* Store the eigenvalues isolated by DGEBAL.
*
DO 10 I = 1, ILO - 1
WR( I ) = H( I, I )
WI( I ) = ZERO
10 CONTINUE
DO 20 I = IHI + 1, N
WR( I ) = H( I, I )
WI( I ) = ZERO
20 CONTINUE
*
* Quick return if possible.
*
IF( N.EQ.0 )
$ RETURN
IF( ILO.EQ.IHI ) THEN
WR( ILO ) = H( ILO, ILO )
WI( ILO ) = ZERO
RETURN
END IF
*
* Set rows and columns ILO to IHI to zero below the first
* subdiagonal.
*
DO 40 J = ILO, IHI - 2
DO 30 I = J + 2, N
H( I, J ) = ZERO
30 CONTINUE
40 CONTINUE
NH = IHI - ILO + 1
*
* Determine the order of the multi-shift QR algorithm to be used.
*
NS = ILAENV( 4, 'DHSEQR', JOB // COMPZ, N, ILO, IHI, -1 )
MAXB = ILAENV( 8, 'DHSEQR', JOB // COMPZ, N, ILO, IHI, -1 )
IF( NS.LE.2 .OR. NS.GT.NH .OR. MAXB.GE.NH ) THEN
*
* Use the standard double-shift algorithm
*
CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO,
$ IHI, Z, LDZ, INFO )
RETURN
END IF
MAXB = MAX( 3, MAXB )
NS = MIN( NS, MAXB, NSMAX )
*
* Now 2 < NS <= MAXB < NH.
*
* Set machine-dependent constants for the stopping criterion.
* If norm(H) <= sqrt(OVFL), overflow should not occur.
*
UNFL = DLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
CALL DLABAD( UNFL, OVFL )
ULP = DLAMCH( 'Precision' )
SMLNUM = UNFL*( NH / ULP )
*
* I1 and I2 are the indices of the first row and last column of H
* to which transformations must be applied. If eigenvalues only are
* being computed, I1 and I2 are set inside the main loop.
*
IF( WANTT ) THEN
I1 = 1
I2 = N
END IF
*
* ITN is the total number of multiple-shift QR iterations allowed.
*
ITN = 30*NH
*
* The main loop begins here. I is the loop index and decreases from
* IHI to ILO in steps of at most MAXB. Each iteration of the loop
* works with the active submatrix in rows and columns L to I.
* Eigenvalues I+1 to IHI have already converged. Either L = ILO or
* H(L,L-1) is negligible so that the matrix splits.
*
I = IHI
50 CONTINUE
L = ILO
IF( I.LT.ILO )
$ GO TO 170
*
* Perform multiple-shift QR iterations on rows and columns ILO to I
* until a submatrix of order at most MAXB splits off at the bottom
* because a subdiagonal element has become negligible.
*
DO 150 ITS = 0, ITN
*
* Look for a single small subdiagonal element.
*
DO 60 K = I, L + 1, -1
TST1 = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) )
IF( TST1.EQ.ZERO ) THEN
TST1 = DLANHS( '1', I-L+1, H( L, L ), LDH, WORK )
***
* Increment op count
OPS = OPS + ( I-L+1 )*( I-L+2 ) / 2
***
END IF
IF( ABS( H( K, K-1 ) ).LE.MAX( ULP*TST1, SMLNUM ) )
$ GO TO 70
60 CONTINUE
70 CONTINUE
L = K
***
* Increment op count
OPST = OPST + 3*( I-L+1 )
***
IF( L.GT.ILO ) THEN
*
* H(L,L-1) is negligible.
*
H( L, L-1 ) = ZERO
END IF
*
* Exit from loop if a submatrix of order <= MAXB has split off.
*
IF( L.GE.I-MAXB+1 )
$ GO TO 160
*
* Now the active submatrix is in rows and columns L to I. If
* eigenvalues only are being computed, only the active submatrix
* need be transformed.
*
IF( .NOT.WANTT ) THEN
I1 = L
I2 = I
END IF
*
IF( ITS.EQ.20 .OR. ITS.EQ.30 ) THEN
*
* Exceptional shifts.
*
DO 80 II = I - NS + 1, I
WR( II ) = CONST*( ABS( H( II, II-1 ) )+
$ ABS( H( II, II ) ) )
WI( II ) = ZERO
80 CONTINUE
***
* Increment op count
OPST = OPST + 2*NS
***
ELSE
*
* Use eigenvalues of trailing submatrix of order NS as shifts.
*
CALL DLACPY( 'Full', NS, NS, H( I-NS+1, I-NS+1 ), LDH, S,
$ LDS )
CALL DLAHQR( .FALSE., .FALSE., NS, 1, NS, S, LDS,
$ WR( I-NS+1 ), WI( I-NS+1 ), 1, NS, Z, LDZ,
$ IERR )
IF( IERR.GT.0 ) THEN
*
* If DLAHQR failed to compute all NS eigenvalues, use the
* unconverged diagonal elements as the remaining shifts.
*
DO 90 II = 1, IERR
WR( I-NS+II ) = S( II, II )
WI( I-NS+II ) = ZERO
90 CONTINUE
END IF
END IF
*
* Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns))
* where G is the Hessenberg submatrix H(L:I,L:I) and w is
* the vector of shifts (stored in WR and WI). The result is
* stored in the local array V.
*
V( 1 ) = ONE
DO 100 II = 2, NS + 1
V( II ) = ZERO
100 CONTINUE
NV = 1
DO 120 J = I - NS + 1, I
IF( WI( J ).GE.ZERO ) THEN
IF( WI( J ).EQ.ZERO ) THEN
*
* real shift
*
CALL DCOPY( NV+1, V, 1, VV, 1 )
CALL DGEMV( 'No transpose', NV+1, NV, ONE, H( L, L ),
$ LDH, VV, 1, -WR( J ), V, 1 )
NV = NV + 1
***
* Increment op count
OPST = OPST + 2*NV*( NV+1 ) + NV + 1
***
ELSE IF( WI( J ).GT.ZERO ) THEN
*
* complex conjugate pair of shifts
*
CALL DCOPY( NV+1, V, 1, VV, 1 )
CALL DGEMV( 'No transpose', NV+1, NV, ONE, H( L, L ),
$ LDH, V, 1, -TWO*WR( J ), VV, 1 )
ITEMP = IDAMAX( NV+1, VV, 1 )
TEMP = ONE / MAX( ABS( VV( ITEMP ) ), SMLNUM )
CALL DSCAL( NV+1, TEMP, VV, 1 )
ABSW = DLAPY2( WR( J ), WI( J ) )
TEMP = ( TEMP*ABSW )*ABSW
CALL DGEMV( 'No transpose', NV+2, NV+1, ONE,
$ H( L, L ), LDH, VV, 1, TEMP, V, 1 )
NV = NV + 2
***
* Increment op count
OPST = OPST + 4*( NV+1 )**2 + 4*NV + 9
***
END IF
*
* Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero,
* reset it to the unit vector.
*
ITEMP = IDAMAX( NV, V, 1 )
***
* Increment op count
OPST = OPST + NV
***
TEMP = ABS( V( ITEMP ) )
IF( TEMP.EQ.ZERO ) THEN
V( 1 ) = ONE
DO 110 II = 2, NV
V( II ) = ZERO
110 CONTINUE
ELSE
TEMP = MAX( TEMP, SMLNUM )
CALL DSCAL( NV, ONE / TEMP, V, 1 )
***
* Increment op count
OPST = OPST + NV
***
END IF
END IF
120 CONTINUE
*
* Multiple-shift QR step
*
DO 140 K = L, I - 1
*
* The first iteration of this loop determines a reflection G
* from the vector V and applies it from left and right to H,
* thus creating a nonzero bulge below the subdiagonal.
*
* Each subsequent iteration determines a reflection G to
* restore the Hessenberg form in the (K-1)th column, and thus
* chases the bulge one step toward the bottom of the active
* submatrix. NR is the order of G.
*
NR = MIN( NS+1, I-K+1 )
IF( K.GT.L )
$ CALL DCOPY( NR, H( K, K-1 ), 1, V, 1 )
CALL DLARFG( NR, V( 1 ), V( 2 ), 1, TAU )
***
* Increment op count
OPST = OPST + 3*NR + 9
***
IF( K.GT.L ) THEN
H( K, K-1 ) = V( 1 )
DO 130 II = K + 1, I
H( II, K-1 ) = ZERO
130 CONTINUE
END IF
V( 1 ) = ONE
*
* Apply G from the left to transform the rows of the matrix in
* columns K to I2.
*
CALL DLARFX( 'Left', NR, I2-K+1, V, TAU, H( K, K ), LDH,
$ WORK )
*
* Apply G from the right to transform the columns of the
* matrix in rows I1 to min(K+NR,I).
*
CALL DLARFX( 'Right', MIN( K+NR, I )-I1+1, NR, V, TAU,
$ H( I1, K ), LDH, WORK )
***
* Increment op count
OPS = OPS + ( 4*NR-2 )*( I2-I1+2+MIN( NR, I-K ) )
***
*
IF( WANTZ ) THEN
*
* Accumulate transformations in the matrix Z
*
CALL DLARFX( 'Right', NH, NR, V, TAU, Z( ILO, K ), LDZ,
$ WORK )
***
* Increment op count
OPS = OPS + ( 4*NR-2 )*NH
***
END IF
140 CONTINUE
*
150 CONTINUE
*
* Failure to converge in remaining number of iterations
*
INFO = I
RETURN
*
160 CONTINUE
*
* A submatrix of order <= MAXB in rows and columns L to I has split
* off. Use the double-shift QR algorithm to handle it.
*
CALL DLAHQR( WANTT, WANTZ, N, L, I, H, LDH, WR, WI, ILO, IHI, Z,
$ LDZ, INFO )
IF( INFO.GT.0 )
$ RETURN
*
* Decrement number of remaining iterations, and return to start of
* the main loop with a new value of I.
*
ITN = ITN - ITS
I = L - 1
GO TO 50
*
170 CONTINUE
***
* Compute final op count
OPS = OPS + OPST
***
WORK( 1 ) = MAX( 1, N )
RETURN
*
* End of DHSEQR
*
END
SUBROUTINE DLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL,
$ RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT,
$ NAB, WORK, IWORK, INFO )
*
* -- LAPACK auxiliary routine (instrum. to count ops. version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER IJOB, INFO, MINP, MMAX, MOUT, N, NBMIN, NITMAX
DOUBLE PRECISION ABSTOL, PIVMIN, RELTOL
* ..
* .. Array Arguments ..
INTEGER IWORK( * ), NAB( MMAX, * ), NVAL( * )
DOUBLE PRECISION AB( MMAX, * ), C( * ), D( * ), E( * ), E2( * ),
$ WORK( * )
* ..
* Common block to return operation count and iteration count
* ITCNT and OPS are only incremented (not initialized)
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*-----------------------------------------------------------------------
*
* Purpose
* =======
*
* DLAEBZ contains the iteration loops which compute and use the
* function N(w), which is the count of eigenvalues of a symmetric
* tridiagonal matrix T less than or equal to its argument w. It
* performs a choice of two types of loops:
*
* IJOB=1, followed by
* IJOB=2: It takes as input a list of intervals and returns a list of
* sufficiently small intervals whose union contains the same
* eigenvalues as the union of the original intervals.
* The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP.
* The output interval (AB(j,1),AB(j,2)] will contain
* eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT.
*
* IJOB=3: It performs a binary search in each input interval
* (AB(j,1),AB(j,2)] for a point w(j) such that
* N(w(j))=NVAL(j), and uses C(j) as the starting point of
* the search. If such a w(j) is found, then on output
* AB(j,1)=AB(j,2)=w. If no such w(j) is found, then on output
* (AB(j,1),AB(j,2)] will be a small interval containing the
* point where N(w) jumps through NVAL(j), unless that point
* lies outside the initial interval.
*
* Note that the intervals are in all cases half-open intervals,
* i.e., of the form (a,b] , which includes b but not a .
*
* To avoid underflow, the matrix should be scaled so that its largest
* element is no greater than overflow**(1/2) * underflow**(1/4)
* in absolute value. To assure the most accurate computation
* of small eigenvalues, the matrix should be scaled to be
* not much smaller than that, either.
*
* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
* Matrix", Report CS41, Computer Science Dept., Stanford
* University, July 21, 1966
*
* Note: the arguments are, in general, *not* checked for unreasonable
* values.
*
* Arguments
* =========
*
* IJOB (input) INTEGER
* Specifies what is to be done:
* = 1: Compute NAB for the initial intervals.
* = 2: Perform bisection iteration to find eigenvalues of T.
* = 3: Perform bisection iteration to invert N(w), i.e.,
* to find a point which has a specified number of
* eigenvalues of T to its left.
* Other values will cause DLAEBZ to return with INFO=-1.
*
* NITMAX (input) INTEGER
* The maximum number of "levels" of bisection to be
* performed, i.e., an interval of width W will not be made
* smaller than 2^(-NITMAX) * W. If not all intervals
* have converged after NITMAX iterations, then INFO is set
* to the number of non-converged intervals.
*
* N (input) INTEGER
* The dimension n of the tridiagonal matrix T. It must be at
* least 1.
*
* MMAX (input) INTEGER
* The maximum number of intervals. If more than MMAX intervals
* are generated, then DLAEBZ will quit with INFO=MMAX+1.
*
* MINP (input) INTEGER
* The initial number of intervals. It may not be greater than
* MMAX.
*
* NBMIN (input) INTEGER
* The smallest number of intervals that should be processed
* using a vector loop. If zero, then only the scalar loop
* will be used.
*
* ABSTOL (input) DOUBLE PRECISION
* The minimum (absolute) width of an interval. When an
* interval is narrower than ABSTOL, or than RELTOL times the
* larger (in magnitude) endpoint, then it is considered to be
* sufficiently small, i.e., converged. This must be at least
* zero.
*
* RELTOL (input) DOUBLE PRECISION
* The minimum relative width of an interval. When an interval
* is narrower than ABSTOL, or than RELTOL times the larger (in
* magnitude) endpoint, then it is considered to be
* sufficiently small, i.e., converged. Note: this should
* always be at least radix*machine epsilon.
*
* PIVMIN (input) DOUBLE PRECISION
* The minimum absolute value of a "pivot" in the Sturm
* sequence loop. This *must* be at least max |e(j)**2| *
* safe_min and at least safe_min, where safe_min is at least
* the smallest number that can divide one without overflow.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The diagonal elements of the tridiagonal matrix T.
*
* E (input) DOUBLE PRECISION array, dimension (N)
* The offdiagonal elements of the tridiagonal matrix T in
* positions 1 through N-1. E(N) is arbitrary.
*
* E2 (input) DOUBLE PRECISION array, dimension (N)
* The squares of the offdiagonal elements of the tridiagonal
* matrix T. E2(N) is ignored.
*
* NVAL (input/output) INTEGER array, dimension (MINP)
* If IJOB=1 or 2, not referenced.
* If IJOB=3, the desired values of N(w). The elements of NVAL
* will be reordered to correspond with the intervals in AB.
* Thus, NVAL(j) on output will not, in general be the same as
* NVAL(j) on input, but it will correspond with the interval
* (AB(j,1),AB(j,2)] on output.
*
* AB (input/output) DOUBLE PRECISION array, dimension (MMAX,2)
* The endpoints of the intervals. AB(j,1) is a(j), the left
* endpoint of the j-th interval, and AB(j,2) is b(j), the
* right endpoint of the j-th interval. The input intervals
* will, in general, be modified, split, and reordered by the
* calculation.
*
* C (input/output) DOUBLE PRECISION array, dimension (MMAX)
* If IJOB=1, ignored.
* If IJOB=2, workspace.
* If IJOB=3, then on input C(j) should be initialized to the
* first search point in the binary search.
*
* MOUT (output) INTEGER
* If IJOB=1, the number of eigenvalues in the intervals.
* If IJOB=2 or 3, the number of intervals output.
* If IJOB=3, MOUT will equal MINP.
*
* NAB (input/output) INTEGER array, dimension (MMAX,2)
* If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)).
* If IJOB=2, then on input, NAB(i,j) should be set. It must
* satisfy the condition:
* N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)),
* which means that in interval i only eigenvalues
* NAB(i,1)+1,...,NAB(i,2) will be considered. Usually,
* NAB(i,j)=N(AB(i,j)), from a previous call to DLAEBZ with
* IJOB=1.
* On output, NAB(i,j) will contain
* max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of
* the input interval that the output interval
* (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the
* the input values of NAB(k,1) and NAB(k,2).
* If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)),
* unless N(w) > NVAL(i) for all search points w , in which
* case NAB(i,1) will not be modified, i.e., the output
* value will be the same as the input value (modulo
* reorderings -- see NVAL and AB), or unless N(w) < NVAL(i)
* for all search points w , in which case NAB(i,2) will
* not be modified. Normally, NAB should be set to some
* distinctive value(s) before DLAEBZ is called.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (MMAX)
* Workspace.
*
* IWORK (workspace) INTEGER array, dimension (MMAX)
* Workspace.
*
* INFO (output) INTEGER
* = 0: All intervals converged.
* = 1--MMAX: The last INFO intervals did not converge.
* = MMAX+1: More than MMAX intervals were generated.
*
* Further Details
* ===============
*
* This routine is intended to be called only by other LAPACK
* routines, thus the interface is less user-friendly. It is intended
* for two purposes:
*
* (a) finding eigenvalues. In this case, DLAEBZ should have one or
* more initial intervals set up in AB, and DLAEBZ should be called
* with IJOB=1. This sets up NAB, and also counts the eigenvalues.
* Intervals with no eigenvalues would usually be thrown out at
* this point. Also, if not all the eigenvalues in an interval i
* are desired, NAB(i,1) can be increased or NAB(i,2) decreased.
* For example, set NAB(i,1)=NAB(i,2)-1 to get the largest
* eigenvalue. DLAEBZ is then called with IJOB=2 and MMAX
* no smaller than the value of MOUT returned by the call with
* IJOB=1. After this (IJOB=2) call, eigenvalues NAB(i,1)+1
* through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the
* tolerance specified by ABSTOL and RELTOL.
*
* (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l).
* In this case, start with a Gershgorin interval (a,b). Set up
* AB to contain 2 search intervals, both initially (a,b). One
* NVAL element should contain f-1 and the other should contain l
* , while C should contain a and b, resp. NAB(i,1) should be -1
* and NAB(i,2) should be N+1, to flag an error if the desired
* interval does not lie in (a,b). DLAEBZ is then called with
* IJOB=3. On exit, if w(f-1) < w(f), then one of the intervals --
* j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while
* if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r
* >= 0, then the interval will have N(AB(j,1))=NAB(j,1)=f-k and
* N(AB(j,2))=NAB(j,2)=f+r. The cases w(l) < w(l+1) and
* w(l-r)=...=w(l+k) are handled similarly.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, TWO, HALF
PARAMETER ( ZERO = 0.0D0, TWO = 2.0D0,
$ HALF = 1.0D0 / TWO )
* ..
* .. Local Scalars ..
INTEGER ITMP1, ITMP2, J, JI, JIT, JP, KF, KFNEW, KL,
$ KLNEW
DOUBLE PRECISION TMP1, TMP2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Check for Errors
*
INFO = 0
IF( IJOB.LT.1 .OR. IJOB.GT.3 ) THEN
INFO = -1
RETURN
END IF
*
* Initialize NAB
*
IF( IJOB.EQ.1 ) THEN
*
* Compute the number of eigenvalues in the initial intervals.
*
MOUT = 0
*DIR$ NOVECTOR
DO 30 JI = 1, MINP
DO 20 JP = 1, 2
TMP1 = D( 1 ) - AB( JI, JP )
IF( ABS( TMP1 ).LT.PIVMIN )
$ TMP1 = -PIVMIN
NAB( JI, JP ) = 0
IF( TMP1.LE.ZERO )
$ NAB( JI, JP ) = 1
*
DO 10 J = 2, N
TMP1 = D( J ) - E2( J-1 ) / TMP1 - AB( JI, JP )
IF( ABS( TMP1 ).LT.PIVMIN )
$ TMP1 = -PIVMIN
IF( TMP1.LE.ZERO )
$ NAB( JI, JP ) = NAB( JI, JP ) + 1
10 CONTINUE
20 CONTINUE
MOUT = MOUT + NAB( JI, 2 ) - NAB( JI, 1 )
30 CONTINUE
*
* Increment opcount for determining the number of eigenvalues
* in the initial intervals.
*
OPS = OPS + MINP*2*( N-1 )*3
RETURN
END IF
*
* Initialize for loop
*
* KF and KL have the following meaning:
* Intervals 1,...,KF-1 have converged.
* Intervals KF,...,KL still need to be refined.
*
KF = 1
KL = MINP
*
* If IJOB=2, initialize C.
* If IJOB=3, use the user-supplied starting point.
*
IF( IJOB.EQ.2 ) THEN
DO 40 JI = 1, MINP
C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) )
40 CONTINUE
*
* Increment opcount for initializing C.
*
OPS = OPS + MINP*2
END IF
*
* Iteration loop
*
DO 130 JIT = 1, NITMAX
*
* Loop over intervals
*
IF( KL-KF+1.GE.NBMIN .AND. NBMIN.GT.0 ) THEN
*
* Begin of Parallel Version of the loop
*
DO 60 JI = KF, KL
*
* Compute N(c), the number of eigenvalues less than c
*
WORK( JI ) = D( 1 ) - C( JI )
IWORK( JI ) = 0
IF( WORK( JI ).LE.PIVMIN ) THEN
IWORK( JI ) = 1
WORK( JI ) = MIN( WORK( JI ), -PIVMIN )
END IF
*
DO 50 J = 2, N
WORK( JI ) = D( J ) - E2( J-1 ) / WORK( JI ) - C( JI )
IF( WORK( JI ).LE.PIVMIN ) THEN
IWORK( JI ) = IWORK( JI ) + 1
WORK( JI ) = MIN( WORK( JI ), -PIVMIN )
END IF
50 CONTINUE
60 CONTINUE
*
* Increment iteration counter.
*
ITCNT = ITCNT + KL - KF + 1
*
* Increment opcount for evaluating Sturm sequences on
* each interval.
*
OPS = OPS + ( KL-KF+1 )*( N-1 )*3
*
IF( IJOB.LE.2 ) THEN
*
* IJOB=2: Choose all intervals containing eigenvalues.
*
KLNEW = KL
DO 70 JI = KF, KL
*
* Insure that N(w) is monotone
*
IWORK( JI ) = MIN( NAB( JI, 2 ),
$ MAX( NAB( JI, 1 ), IWORK( JI ) ) )
*
* Update the Queue -- add intervals if both halves
* contain eigenvalues.
*
IF( IWORK( JI ).EQ.NAB( JI, 2 ) ) THEN
*
* No eigenvalue in the upper interval:
* just use the lower interval.
*
AB( JI, 2 ) = C( JI )
*
ELSE IF( IWORK( JI ).EQ.NAB( JI, 1 ) ) THEN
*
* No eigenvalue in the lower interval:
* just use the upper interval.
*
AB( JI, 1 ) = C( JI )
ELSE
KLNEW = KLNEW + 1
IF( KLNEW.LE.MMAX ) THEN
*
* Eigenvalue in both intervals -- add upper to
* queue.
*
AB( KLNEW, 2 ) = AB( JI, 2 )
NAB( KLNEW, 2 ) = NAB( JI, 2 )
AB( KLNEW, 1 ) = C( JI )
NAB( KLNEW, 1 ) = IWORK( JI )
AB( JI, 2 ) = C( JI )
NAB( JI, 2 ) = IWORK( JI )
ELSE
INFO = MMAX + 1
END IF
END IF
70 CONTINUE
IF( INFO.NE.0 )
$ RETURN
KL = KLNEW
ELSE
*
* IJOB=3: Binary search. Keep only the interval containing
* w s.t. N(w) = NVAL
*
DO 80 JI = KF, KL
IF( IWORK( JI ).LE.NVAL( JI ) ) THEN
AB( JI, 1 ) = C( JI )
NAB( JI, 1 ) = IWORK( JI )
END IF
IF( IWORK( JI ).GE.NVAL( JI ) ) THEN
AB( JI, 2 ) = C( JI )
NAB( JI, 2 ) = IWORK( JI )
END IF
80 CONTINUE
END IF
*
ELSE
*
* End of Parallel Version of the loop
*
* Begin of Serial Version of the loop
*
KLNEW = KL
DO 100 JI = KF, KL
*
* Compute N(w), the number of eigenvalues less than w
*
TMP1 = C( JI )
TMP2 = D( 1 ) - TMP1
ITMP1 = 0
IF( TMP2.LE.PIVMIN ) THEN
ITMP1 = 1
TMP2 = MIN( TMP2, -PIVMIN )
END IF
*
* A series of compiler directives to defeat vectorization
* for the next loop
*
*$PL$ CMCHAR=' '
CDIR$ NEXTSCALAR
C$DIR SCALAR
CDIR$ NEXT SCALAR
CVD$L NOVECTOR
CDEC$ NOVECTOR
CVD$ NOVECTOR
*VDIR NOVECTOR
*VOCL LOOP,SCALAR
CIBM PREFER SCALAR
*$PL$ CMCHAR='*'
*
DO 90 J = 2, N
TMP2 = D( J ) - E2( J-1 ) / TMP2 - TMP1
IF( TMP2.LE.PIVMIN ) THEN
ITMP1 = ITMP1 + 1
TMP2 = MIN( TMP2, -PIVMIN )
END IF
90 CONTINUE
*
IF( IJOB.LE.2 ) THEN
*
* IJOB=2: Choose all intervals containing eigenvalues.
*
* Insure that N(w) is monotone
*
ITMP1 = MIN( NAB( JI, 2 ),
$ MAX( NAB( JI, 1 ), ITMP1 ) )
*
* Update the Queue -- add intervals if both halves
* contain eigenvalues.
*
IF( ITMP1.EQ.NAB( JI, 2 ) ) THEN
*
* No eigenvalue in the upper interval:
* just use the lower interval.
*
AB( JI, 2 ) = TMP1
*
ELSE IF( ITMP1.EQ.NAB( JI, 1 ) ) THEN
*
* No eigenvalue in the lower interval:
* just use the upper interval.
*
AB( JI, 1 ) = TMP1
ELSE IF( KLNEW.LT.MMAX ) THEN
*
* Eigenvalue in both intervals -- add upper to queue.
*
KLNEW = KLNEW + 1
AB( KLNEW, 2 ) = AB( JI, 2 )
NAB( KLNEW, 2 ) = NAB( JI, 2 )
AB( KLNEW, 1 ) = TMP1
NAB( KLNEW, 1 ) = ITMP1
AB( JI, 2 ) = TMP1
NAB( JI, 2 ) = ITMP1
ELSE
INFO = MMAX + 1
RETURN
END IF
ELSE
*
* IJOB=3: Binary search. Keep only the interval
* containing w s.t. N(w) = NVAL
*
IF( ITMP1.LE.NVAL( JI ) ) THEN
AB( JI, 1 ) = TMP1
NAB( JI, 1 ) = ITMP1
END IF
IF( ITMP1.GE.NVAL( JI ) ) THEN
AB( JI, 2 ) = TMP1
NAB( JI, 2 ) = ITMP1
END IF
END IF
100 CONTINUE
*
* Increment iteration counter.
*
ITCNT = ITCNT + KL - KF + 1
*
* Increment opcount for evaluating Sturm sequences on
* each interval.
*
OPS = OPS + ( KL-KF+1 )*( N-1 )*3
KL = KLNEW
*
* End of Serial Version of the loop
*
END IF
*
* Check for convergence
*
KFNEW = KF
DO 110 JI = KF, KL
TMP1 = ABS( AB( JI, 2 )-AB( JI, 1 ) )
TMP2 = MAX( ABS( AB( JI, 2 ) ), ABS( AB( JI, 1 ) ) )
IF( TMP1.LT.MAX( ABSTOL, PIVMIN, RELTOL*TMP2 ) .OR.
$ NAB( JI, 1 ).GE.NAB( JI, 2 ) ) THEN
*
* Converged -- Swap with position KFNEW,
* then increment KFNEW
*
IF( JI.GT.KFNEW ) THEN
TMP1 = AB( JI, 1 )
TMP2 = AB( JI, 2 )
ITMP1 = NAB( JI, 1 )
ITMP2 = NAB( JI, 2 )
AB( JI, 1 ) = AB( KFNEW, 1 )
AB( JI, 2 ) = AB( KFNEW, 2 )
NAB( JI, 1 ) = NAB( KFNEW, 1 )
NAB( JI, 2 ) = NAB( KFNEW, 2 )
AB( KFNEW, 1 ) = TMP1
AB( KFNEW, 2 ) = TMP2
NAB( KFNEW, 1 ) = ITMP1
NAB( KFNEW, 2 ) = ITMP2
IF( IJOB.EQ.3 ) THEN
ITMP1 = NVAL( JI )
NVAL( JI ) = NVAL( KFNEW )
NVAL( KFNEW ) = ITMP1
END IF
END IF
KFNEW = KFNEW + 1
END IF
110 CONTINUE
KF = KFNEW
*
* Choose Midpoints
*
DO 120 JI = KF, KL
C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) )
120 CONTINUE
*
* Increment opcount for convergence check and choosing midpoints.
*
OPS = OPS + ( KL-KF+1 )*4
*
* If no more intervals to refine, quit.
*
IF( KF.GT.KL )
$ GO TO 140
130 CONTINUE
*
* Converged
*
140 CONTINUE
INFO = MAX( KL+1-KF, 0 )
MOUT = KL
*
RETURN
*
* End of DLAEBZ
*
END
SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS,
$ WORK, IWORK, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ),
$ WORK( * )
* ..
* Common block to return operation count and iteration count
* ITCNT is unchanged, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLAED0 computes all eigenvalues and corresponding eigenvectors of a
* symmetric tridiagonal matrix using the divide and conquer method.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* = 0: Compute eigenvalues only.
* = 1: Compute eigenvectors of original dense symmetric matrix
* also. On entry, Q contains the orthogonal matrix used
* to reduce the original matrix to tridiagonal form.
* = 2: Compute eigenvalues and eigenvectors of tridiagonal
* matrix.
*
* QSIZ (input) INTEGER
* The dimension of the orthogonal matrix used to reduce
* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the main diagonal of the tridiagonal matrix.
* On exit, its eigenvalues.
*
* E (input) DOUBLE PRECISION array, dimension (N-1)
* The off-diagonal elements of the tridiagonal matrix.
* On exit, E has been destroyed.
*
* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
* On entry, Q must contain an N-by-N orthogonal matrix.
* If ICOMPQ = 0 Q is not referenced.
* If ICOMPQ = 1 On entry, Q is a subset of the columns of the
* orthogonal matrix used to reduce the full
* matrix to tridiagonal form corresponding to
* the subset of the full matrix which is being
* decomposed at this time.
* If ICOMPQ = 2 On entry, Q will be the identity matrix.
* On exit, Q contains the eigenvectors of the
* tridiagonal matrix.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. If eigenvectors are
* desired, then LDQ >= max(1,N). In any case, LDQ >= 1.
*
* QSTORE (workspace) DOUBLE PRECISION array, dimension (LDQS, N)
* Referenced only when ICOMPQ = 1. Used to store parts of
* the eigenvector matrix when the updating matrix multiplies
* take place.
*
* LDQS (input) INTEGER
* The leading dimension of the array QSTORE. If ICOMPQ = 1,
* then LDQS >= max(1,N). In any case, LDQS >= 1.
*
* WORK (workspace) DOUBLE PRECISION array,
* If ICOMPQ = 0 or 1, the dimension of WORK must be at least
* 1 + 3*N + 2*N*lg N + 2*N**2
* ( lg( N ) = smallest integer k
* such that 2^k >= N )
* If ICOMPQ = 2, the dimension of WORK must be at least
* 4*N + N**2.
*
* IWORK (workspace) INTEGER array,
* If ICOMPQ = 0 or 1, the dimension of IWORK must be at least
* 6 + 6*N + 5*N*lg N.
* ( lg( N ) = smallest integer k
* such that 2^k >= N )
* If ICOMPQ = 2, the dimension of IWORK must be at least
* 3 + 5*N.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: The algorithm failed to compute an eigenvalue while
* working on the submatrix lying in rows and columns
* INFO/(N+1) through mod(INFO,N+1).
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.D0, ONE = 1.D0, TWO = 2.D0 )
* ..
* .. Local Scalars ..
INTEGER CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM,
$ IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM,
$ J, K, LGN, MATSIZ, MSD2, SMLSIZ, SMM1, SPM1,
$ SPM2, SUBMAT, SUBPBS, TLVLS
DOUBLE PRECISION TEMP
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMM, DLACPY, DLAED1, DLAED7, DSTEQR,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, INT, LOG, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.2 ) THEN
INFO = -1
ELSE IF( ( ICOMPQ.EQ.1 ) .AND. ( QSIZ.LT.MAX( 0, N ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDQS.LT.MAX( 1, N ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAED0', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
SMLSIZ = ILAENV( 9, 'DLAED0', ' ', 0, 0, 0, 0 )
*
* Determine the size and placement of the submatrices, and save in
* the leading elements of IWORK.
*
IWORK( 1 ) = N
SUBPBS = 1
TLVLS = 0
10 CONTINUE
IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN
DO 20 J = SUBPBS, 1, -1
IWORK( 2*J ) = ( IWORK( J )+1 ) / 2
IWORK( 2*J-1 ) = IWORK( J ) / 2
20 CONTINUE
TLVLS = TLVLS + 1
SUBPBS = 2*SUBPBS
GO TO 10
END IF
DO 30 J = 2, SUBPBS
IWORK( J ) = IWORK( J ) + IWORK( J-1 )
30 CONTINUE
*
* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1
* using rank-1 modifications (cuts).
*
SPM1 = SUBPBS - 1
OPS = OPS + 2*SPM1
DO 40 I = 1, SPM1
SUBMAT = IWORK( I ) + 1
SMM1 = SUBMAT - 1
D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) )
D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) )
40 CONTINUE
*
INDXQ = 4*N + 3
IF( ICOMPQ.NE.2 ) THEN
*
* Set up workspaces for eigenvalues only/accumulate new vectors
* routine
*
OPS = OPS + 3
TEMP = LOG( DBLE( N ) ) / LOG( TWO )
LGN = INT( TEMP )
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IPRMPT = INDXQ + N + 1
IPERM = IPRMPT + N*LGN
IQPTR = IPERM + N*LGN
IGIVPT = IQPTR + N + 2
IGIVCL = IGIVPT + N*LGN
*
IGIVNM = 1
IQ = IGIVNM + 2*N*LGN
IWREM = IQ + N**2 + 1
*
* Initialize pointers
*
DO 50 I = 0, SUBPBS
IWORK( IPRMPT+I ) = 1
IWORK( IGIVPT+I ) = 1
50 CONTINUE
IWORK( IQPTR ) = 1
END IF
*
* Solve each submatrix eigenproblem at the bottom of the divide and
* conquer tree.
*
CURR = 0
DO 70 I = 0, SPM1
IF( I.EQ.0 ) THEN
SUBMAT = 1
MATSIZ = IWORK( 1 )
ELSE
SUBMAT = IWORK( I ) + 1
MATSIZ = IWORK( I+1 ) - IWORK( I )
END IF
IF( ICOMPQ.EQ.2 ) THEN
CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
$ Q( SUBMAT, SUBMAT ), LDQ, WORK, INFO )
IF( INFO.NE.0 )
$ GO TO 130
ELSE
CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
$ WORK( IQ-1+IWORK( IQPTR+CURR ) ), MATSIZ, WORK,
$ INFO )
IF( INFO.NE.0 )
$ GO TO 130
IF( ICOMPQ.EQ.1 ) THEN
OPS = OPS + 2*DBLE( QSIZ )*MATSIZ*MATSIZ
CALL DGEMM( 'N', 'N', QSIZ, MATSIZ, MATSIZ, ONE,
$ Q( 1, SUBMAT ), LDQ, WORK( IQ-1+IWORK( IQPTR+
$ CURR ) ), MATSIZ, ZERO, QSTORE( 1, SUBMAT ),
$ LDQS )
END IF
IWORK( IQPTR+CURR+1 ) = IWORK( IQPTR+CURR ) + MATSIZ**2
CURR = CURR + 1
END IF
K = 1
DO 60 J = SUBMAT, IWORK( I+1 )
IWORK( INDXQ+J ) = K
K = K + 1
60 CONTINUE
70 CONTINUE
*
* Successively merge eigensystems of adjacent submatrices
* into eigensystem for the corresponding larger matrix.
*
* while ( SUBPBS > 1 )
*
CURLVL = 1
80 CONTINUE
IF( SUBPBS.GT.1 ) THEN
SPM2 = SUBPBS - 2
DO 90 I = 0, SPM2, 2
IF( I.EQ.0 ) THEN
SUBMAT = 1
MATSIZ = IWORK( 2 )
MSD2 = IWORK( 1 )
CURPRB = 0
ELSE
SUBMAT = IWORK( I ) + 1
MATSIZ = IWORK( I+2 ) - IWORK( I )
MSD2 = MATSIZ / 2
CURPRB = CURPRB + 1
END IF
*
* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2)
* into an eigensystem of size MATSIZ.
* DLAED1 is used only for the full eigensystem of a tridiagonal
* matrix.
* DLAED7 handles the cases in which eigenvalues only or eigenvalues
* and eigenvectors of a full symmetric matrix (which was reduced to
* tridiagonal form) are desired.
*
IF( ICOMPQ.EQ.2 ) THEN
CALL DLAED1( MATSIZ, D( SUBMAT ), Q( SUBMAT, SUBMAT ),
$ LDQ, IWORK( INDXQ+SUBMAT ),
$ E( SUBMAT+MSD2-1 ), MSD2, WORK,
$ IWORK( SUBPBS+1 ), INFO )
ELSE
CALL DLAED7( ICOMPQ, MATSIZ, QSIZ, TLVLS, CURLVL, CURPRB,
$ D( SUBMAT ), QSTORE( 1, SUBMAT ), LDQS,
$ IWORK( INDXQ+SUBMAT ), E( SUBMAT+MSD2-1 ),
$ MSD2, WORK( IQ ), IWORK( IQPTR ),
$ IWORK( IPRMPT ), IWORK( IPERM ),
$ IWORK( IGIVPT ), IWORK( IGIVCL ),
$ WORK( IGIVNM ), WORK( IWREM ),
$ IWORK( SUBPBS+1 ), INFO )
END IF
IF( INFO.NE.0 )
$ GO TO 130
IWORK( I / 2+1 ) = IWORK( I+2 )
90 CONTINUE
SUBPBS = SUBPBS / 2
CURLVL = CURLVL + 1
GO TO 80
END IF
*
* end while
*
* Re-merge the eigenvalues/vectors which were deflated at the final
* merge step.
*
IF( ICOMPQ.EQ.1 ) THEN
DO 100 I = 1, N
J = IWORK( INDXQ+I )
WORK( I ) = D( J )
CALL DCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 )
100 CONTINUE
CALL DCOPY( N, WORK, 1, D, 1 )
ELSE IF( ICOMPQ.EQ.2 ) THEN
DO 110 I = 1, N
J = IWORK( INDXQ+I )
WORK( I ) = D( J )
CALL DCOPY( N, Q( 1, J ), 1, WORK( N*I+1 ), 1 )
110 CONTINUE
CALL DCOPY( N, WORK, 1, D, 1 )
CALL DLACPY( 'A', N, N, WORK( N+1 ), N, Q, LDQ )
ELSE
DO 120 I = 1, N
J = IWORK( INDXQ+I )
WORK( I ) = D( J )
120 CONTINUE
CALL DCOPY( N, WORK, 1, D, 1 )
END IF
GO TO 140
*
130 CONTINUE
INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1
*
140 CONTINUE
RETURN
*
* End of DLAED0
*
END
SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK,
$ INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER CUTPNT, INFO, LDQ, N
DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
INTEGER INDXQ( * ), IWORK( * )
DOUBLE PRECISION D( * ), Q( LDQ, * ), WORK( * )
* ..
* Common block to return operation count and iteration count
* ITCNT is unchanged, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLAED1 computes the updated eigensystem of a diagonal
* matrix after modification by a rank-one symmetric matrix. This
* routine is used only for the eigenproblem which requires all
* eigenvalues and eigenvectors of a tridiagonal matrix. DLAED7 handles
* the case in which eigenvalues only or eigenvalues and eigenvectors
* of a full symmetric matrix (which was reduced to tridiagonal form)
* are desired.
*
* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)
*
* where Z = Q'u, u is a vector of length N with ones in the
* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
*
* The eigenvectors of the original matrix are stored in Q, and the
* eigenvalues are in D. The algorithm consists of three stages:
*
* The first stage consists of deflating the size of the problem
* when there are multiple eigenvalues or if there is a zero in
* the Z vector. For each such occurence the dimension of the
* secular equation problem is reduced by one. This stage is
* performed by the routine DLAED2.
*
* The second stage consists of calculating the updated
* eigenvalues. This is done by finding the roots of the secular
* equation via the routine DLAED4 (as called by DLAED3).
* This routine also calculates the eigenvectors of the current
* problem.
*
* The final stage consists of computing the updated eigenvectors
* directly using the updated eigenvalues. The eigenvectors for
* the current problem are multiplied with the eigenvectors from
* the overall problem.
*
* Arguments
* =========
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the eigenvalues of the rank-1-perturbed matrix.
* On exit, the eigenvalues of the repaired matrix.
*
* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
* On entry, the eigenvectors of the rank-1-perturbed matrix.
* On exit, the eigenvectors of the repaired tridiagonal matrix.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* INDXQ (input/output) INTEGER array, dimension (N)
* On entry, the permutation which separately sorts the two
* subproblems in D into ascending order.
* On exit, the permutation which will reintegrate the
* subproblems back into sorted order,
* i.e. D( INDXQ( I = 1, N ) ) will be in ascending order.
*
* RHO (input) DOUBLE PRECISION
* The subdiagonal entry used to create the rank-1 modification.
*
* CUTPNT (input) INTEGER
* The location of the last eigenvalue in the leading sub-matrix.
* min(1,N) <= CUTPNT <= N/2.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (4*N + N**2)
*
* IWORK (workspace) INTEGER array, dimension (4*N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an eigenvalue did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
* Modified by Francoise Tisseur, University of Tennessee.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER COLTYP, I, IDLMDA, INDX, INDXC, INDXP, IQ2, IS,
$ IW, IZ, K, N1, N2, ZPP1
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLAED2, DLAED3, DLAMRG, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( MIN( 1, N / 2 ).GT.CUTPNT .OR. ( N / 2 ).LT.CUTPNT ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAED1', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* The following values are integer pointers which indicate
* the portion of the workspace
* used by a particular array in DLAED2 and DLAED3.
*
IZ = 1
IDLMDA = IZ + N
IW = IDLMDA + N
IQ2 = IW + N
*
INDX = 1
INDXC = INDX + N
COLTYP = INDXC + N
INDXP = COLTYP + N
*
*
* Form the z-vector which consists of the last row of Q_1 and the
* first row of Q_2.
*
CALL DCOPY( CUTPNT, Q( CUTPNT, 1 ), LDQ, WORK( IZ ), 1 )
ZPP1 = CUTPNT + 1
CALL DCOPY( N-CUTPNT, Q( ZPP1, ZPP1 ), LDQ, WORK( IZ+CUTPNT ), 1 )
*
* Deflate eigenvalues.
*
CALL DLAED2( K, N, CUTPNT, D, Q, LDQ, INDXQ, RHO, WORK( IZ ),
$ WORK( IDLMDA ), WORK( IW ), WORK( IQ2 ),
$ IWORK( INDX ), IWORK( INDXC ), IWORK( INDXP ),
$ IWORK( COLTYP ), INFO )
*
IF( INFO.NE.0 )
$ GO TO 20
*
* Solve Secular Equation.
*
IF( K.NE.0 ) THEN
IS = ( IWORK( COLTYP )+IWORK( COLTYP+1 ) )*CUTPNT +
$ ( IWORK( COLTYP+1 )+IWORK( COLTYP+2 ) )*( N-CUTPNT ) + IQ2
CALL DLAED3( K, N, CUTPNT, D, Q, LDQ, RHO, WORK( IDLMDA ),
$ WORK( IQ2 ), IWORK( INDXC ), IWORK( COLTYP ),
$ WORK( IW ), WORK( IS ), INFO )
IF( INFO.NE.0 )
$ GO TO 20
*
* Prepare the INDXQ sorting permutation.
*
N1 = K
N2 = N - K
CALL DLAMRG( N1, N2, D, 1, -1, INDXQ )
ELSE
DO 10 I = 1, N
INDXQ( I ) = I
10 CONTINUE
END IF
*
20 CONTINUE
RETURN
*
* End of DLAED1
*
END
SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W,
$ Q2, INDX, INDXC, INDXP, COLTYP, INFO )
*
* -- LAPACK routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDQ, N, N1
DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
INTEGER COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ),
$ INDXQ( * )
DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
$ W( * ), Z( * )
* ..
* Common block to return operation count and iteration count
* ITCNT is unchanged, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLAED2 merges the two sets of eigenvalues together into a single
* sorted set. Then it tries to deflate the size of the problem.
* There are two ways in which deflation can occur: when two or more
* eigenvalues are close together or if there is a tiny entry in the
* Z vector. For each such occurrence the order of the related secular
* equation problem is reduced by one.
*
* Arguments
* =========
*
* K (output) INTEGER
* The number of non-deflated eigenvalues, and the order of the
* related secular equation. 0 <= K <=N.
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* N1 (input) INTEGER
* The location of the last eigenvalue in the leading sub-matrix.
* min(1,N) <= N1 <= N/2.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, D contains the eigenvalues of the two submatrices to
* be combined.
* On exit, D contains the trailing (N-K) updated eigenvalues
* (those which were deflated) sorted into increasing order.
*
* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
* On entry, Q contains the eigenvectors of two submatrices in
* the two square blocks with corners at (1,1), (N1,N1)
* and (N1+1, N1+1), (N,N).
* On exit, Q contains the trailing (N-K) updated eigenvectors
* (those which were deflated) in its last N-K columns.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* INDXQ (input/output) INTEGER array, dimension (N)
* The permutation which separately sorts the two sub-problems
* in D into ascending order. Note that elements in the second
* half of this permutation must first have N1 added to their
* values. Destroyed on exit.
*
* RHO (input/output) DOUBLE PRECISION
* On entry, the off-diagonal element associated with the rank-1
* cut which originally split the two submatrices which are now
* being recombined.
* On exit, RHO has been modified to the value required by
* DLAED3.
*
* Z (input) DOUBLE PRECISION array, dimension (N)
* On entry, Z contains the updating vector (the last
* row of the first sub-eigenvector matrix and the first row of
* the second sub-eigenvector matrix).
* On exit, the contents of Z have been destroyed by the updating
* process.
*
* DLAMDA (output) DOUBLE PRECISION array, dimension (N)
* A copy of the first K eigenvalues which will be used by
* DLAED3 to form the secular equation.
*
* W (output) DOUBLE PRECISION array, dimension (N)
* The first k values of the final deflation-altered z-vector
* which will be passed to DLAED3.
*
* Q2 (output) DOUBLE PRECISION array, dimension (N1**2+(N-N1)**2)
* A copy of the first K eigenvectors which will be used by
* DLAED3 in a matrix multiply (DGEMM) to solve for the new
* eigenvectors.
*
* INDX (workspace) INTEGER array, dimension (N)
* The permutation used to sort the contents of DLAMDA into
* ascending order.
*
* INDXC (output) INTEGER array, dimension (N)
* The permutation used to arrange the columns of the deflated
* Q matrix into three groups: the first group contains non-zero
* elements only at and above N1, the second contains
* non-zero elements only below N1, and the third is dense.
*
* INDXP (workspace) INTEGER array, dimension (N)
* The permutation used to place deflated values of D at the end
* of the array. INDXP(1:K) points to the nondeflated D-values
* and INDXP(K+1:N) points to the deflated eigenvalues.
*
* COLTYP (workspace/output) INTEGER array, dimension (N)
* During execution, a label which will indicate which of the
* following types a column in the Q2 matrix is:
* 1 : non-zero in the upper half only;
* 2 : dense;
* 3 : non-zero in the lower half only;
* 4 : deflated.
* On exit, COLTYP(i) is the number of columns of type i,
* for i=1 to 4 only.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
* Modified by Francoise Tisseur, University of Tennessee.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT
PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0,
$ TWO = 2.0D0, EIGHT = 8.0D0 )
* ..
* .. Local Arrays ..
INTEGER CTOT( 4 ), PSM( 4 )
* ..
* .. Local Scalars ..
INTEGER CT, I, IMAX, IQ1, IQ2, J, JMAX, JS, K2, N1P1,
$ N2, NJ, PJ
DOUBLE PRECISION C, EPS, S, T, TAU, TOL
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH, DLAPY2
EXTERNAL IDAMAX, DLAMCH, DLAPY2
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLACPY, DLAMRG, DROT, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( MIN( 1, ( N / 2 ) ).GT.N1 .OR. ( N / 2 ).LT.N1 ) THEN
INFO = -3
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAED2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
N2 = N - N1
N1P1 = N1 + 1
*
IF( RHO.LT.ZERO ) THEN
OPS = OPS + N2
CALL DSCAL( N2, MONE, Z( N1P1 ), 1 )
END IF
*
* Normalize z so that norm(z) = 1. Since z is the concatenation of
* two normalized vectors, norm2(z) = sqrt(2).
*
OPS = OPS + N + 3
T = ONE / SQRT( TWO )
CALL DSCAL( N, T, Z, 1 )
*
* RHO = ABS( norm(z)**2 * RHO )
*
RHO = ABS( TWO*RHO )
*
* Sort the eigenvalues into increasing order
*
DO 10 I = N1P1, N
INDXQ( I ) = INDXQ( I ) + N1
10 CONTINUE
*
* re-integrate the deflated parts from the last pass
*
DO 20 I = 1, N
DLAMDA( I ) = D( INDXQ( I ) )
20 CONTINUE
CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDXC )
DO 30 I = 1, N
INDX( I ) = INDXQ( INDXC( I ) )
30 CONTINUE
*
* Calculate the allowable deflation tolerance
*
IMAX = IDAMAX( N, Z, 1 )
JMAX = IDAMAX( N, D, 1 )
EPS = DLAMCH( 'Epsilon' )
OPS = OPS + 2
TOL = EIGHT*EPS*MAX( ABS( D( JMAX ) ), ABS( Z( IMAX ) ) )
*
* If the rank-1 modifier is small enough, no more needs to be done
* except to reorganize Q so that its columns correspond with the
* elements in D.
*
OPS = OPS + 1
IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN
K = 0
IQ2 = 1
DO 40 J = 1, N
I = INDX( J )
CALL DCOPY( N, Q( 1, I ), 1, Q2( IQ2 ), 1 )
DLAMDA( J ) = D( I )
IQ2 = IQ2 + N
40 CONTINUE
CALL DLACPY( 'A', N, N, Q2, N, Q, LDQ )
CALL DCOPY( N, DLAMDA, 1, D, 1 )
GO TO 190
END IF
*
* If there are multiple eigenvalues then the problem deflates. Here
* the number of equal eigenvalues are found. As each equal
* eigenvalue is found, an elementary reflector is computed to rotate
* the corresponding eigensubspace so that the corresponding
* components of Z are zero in this new basis.
*
DO 50 I = 1, N1
COLTYP( I ) = 1
50 CONTINUE
DO 60 I = N1P1, N
COLTYP( I ) = 3
60 CONTINUE
*
*
K = 0
K2 = N + 1
DO 70 J = 1, N
NJ = INDX( J )
OPS = OPS + 1
IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
COLTYP( NJ ) = 4
INDXP( K2 ) = NJ
IF( J.EQ.N )
$ GO TO 100
ELSE
PJ = NJ
GO TO 80
END IF
70 CONTINUE
80 CONTINUE
J = J + 1
NJ = INDX( J )
IF( J.GT.N )
$ GO TO 100
OPS = OPS + 1
IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
COLTYP( NJ ) = 4
INDXP( K2 ) = NJ
ELSE
*
* Check if eigenvalues are close enough to allow deflation.
*
S = Z( PJ )
C = Z( NJ )
*
* Find sqrt(a**2+b**2) without overflow or
* destructive underflow.
*
OPS = OPS + 10
TAU = DLAPY2( C, S )
T = D( NJ ) - D( PJ )
C = C / TAU
S = -S / TAU
IF( ABS( T*C*S ).LE.TOL ) THEN
*
* Deflation is possible.
*
Z( NJ ) = TAU
Z( PJ ) = ZERO
IF( COLTYP( NJ ).NE.COLTYP( PJ ) )
$ COLTYP( NJ ) = 2
COLTYP( PJ ) = 4
OPS = OPS + 6*N
CALL DROT( N, Q( 1, PJ ), 1, Q( 1, NJ ), 1, C, S )
OPS = OPS + 10
T = D( PJ )*C**2 + D( NJ )*S**2
D( NJ ) = D( PJ )*S**2 + D( NJ )*C**2
D( PJ ) = T
K2 = K2 - 1
I = 1
90 CONTINUE
IF( K2+I.LE.N ) THEN
IF( D( PJ ).LT.D( INDXP( K2+I ) ) ) THEN
INDXP( K2+I-1 ) = INDXP( K2+I )
INDXP( K2+I ) = PJ
I = I + 1
GO TO 90
ELSE
INDXP( K2+I-1 ) = PJ
END IF
ELSE
INDXP( K2+I-1 ) = PJ
END IF
PJ = NJ
ELSE
K = K + 1
DLAMDA( K ) = D( PJ )
W( K ) = Z( PJ )
INDXP( K ) = PJ
PJ = NJ
END IF
END IF
GO TO 80
100 CONTINUE
*
* Record the last eigenvalue.
*
K = K + 1
DLAMDA( K ) = D( PJ )
W( K ) = Z( PJ )
INDXP( K ) = PJ
*
* Count up the total number of the various types of columns, then
* form a permutation which positions the four column types into
* four uniform groups (although one or more of these groups may be
* empty).
*
DO 110 J = 1, 4
CTOT( J ) = 0
110 CONTINUE
DO 120 J = 1, N
CT = COLTYP( J )
CTOT( CT ) = CTOT( CT ) + 1
120 CONTINUE
*
* PSM(*) = Position in SubMatrix (of types 1 through 4)
*
PSM( 1 ) = 1
PSM( 2 ) = 1 + CTOT( 1 )
PSM( 3 ) = PSM( 2 ) + CTOT( 2 )
PSM( 4 ) = PSM( 3 ) + CTOT( 3 )
K = N - CTOT( 4 )
*
* Fill out the INDXC array so that the permutation which it induces
* will place all type-1 columns first, all type-2 columns next,
* then all type-3's, and finally all type-4's.
*
DO 130 J = 1, N
JS = INDXP( J )
CT = COLTYP( JS )
INDX( PSM( CT ) ) = JS
INDXC( PSM( CT ) ) = J
PSM( CT ) = PSM( CT ) + 1
130 CONTINUE
*
* Sort the eigenvalues and corresponding eigenvectors into DLAMDA
* and Q2 respectively. The eigenvalues/vectors which were not
* deflated go into the first K slots of DLAMDA and Q2 respectively,
* while those which were deflated go into the last N - K slots.
*
I = 1
IQ1 = 1
IQ2 = 1 + ( CTOT( 1 )+CTOT( 2 ) )*N1
DO 140 J = 1, CTOT( 1 )
JS = INDX( I )
CALL DCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 )
Z( I ) = D( JS )
I = I + 1
IQ1 = IQ1 + N1
140 CONTINUE
*
DO 150 J = 1, CTOT( 2 )
JS = INDX( I )
CALL DCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 )
CALL DCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 )
Z( I ) = D( JS )
I = I + 1
IQ1 = IQ1 + N1
IQ2 = IQ2 + N2
150 CONTINUE
*
DO 160 J = 1, CTOT( 3 )
JS = INDX( I )
CALL DCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 )
Z( I ) = D( JS )
I = I + 1
IQ2 = IQ2 + N2
160 CONTINUE
*
IQ1 = IQ2
DO 170 J = 1, CTOT( 4 )
JS = INDX( I )
CALL DCOPY( N, Q( 1, JS ), 1, Q2( IQ2 ), 1 )
IQ2 = IQ2 + N
Z( I ) = D( JS )
I = I + 1
170 CONTINUE
*
* The deflated eigenvalues and their corresponding vectors go back
* into the last N - K slots of D and Q respectively.
*
CALL DLACPY( 'A', N, CTOT( 4 ), Q2( IQ1 ), N, Q( 1, K+1 ), LDQ )
CALL DCOPY( N-K, Z( K+1 ), 1, D( K+1 ), 1 )
*
* Copy CTOT into COLTYP for referencing in DLAED3.
*
DO 180 J = 1, 4
COLTYP( J ) = CTOT( J )
180 CONTINUE
*
190 CONTINUE
RETURN
*
* End of DLAED2
*
END
SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX,
$ CTOT, W, S, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
* Courant Institute, NAG Ltd., and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDQ, N, N1
DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
INTEGER CTOT( * ), INDX( * )
DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
$ S( * ), W( * )
* ..
* Common block to return operation count and iteration count
* ITCNT is unchanged, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLAED3 finds the roots of the secular equation, as defined by the
* values in D, W, and RHO, between 1 and K. It makes the
* appropriate calls to DLAED4 and then updates the eigenvectors by
* multiplying the matrix of eigenvectors of the pair of eigensystems
* being combined by the matrix of eigenvectors of the K-by-K system
* which is solved here.
*
* This code makes very mild assumptions about floating point
* arithmetic. It will work on machines with a guard digit in
* add/subtract, or on those binary machines without guard digits
* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
* It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Arguments
* =========
*
* K (input) INTEGER
* The number of terms in the rational function to be solved by
* DLAED4. K >= 0.
*
* N (input) INTEGER
* The number of rows and columns in the Q matrix.
* N >= K (deflation may result in N>K).
*
* N1 (input) INTEGER
* The location of the last eigenvalue in the leading submatrix.
* min(1,N) <= N1 <= N/2.
*
* D (output) DOUBLE PRECISION array, dimension (N)
* D(I) contains the updated eigenvalues for
* 1 <= I <= K.
*
* Q (output) DOUBLE PRECISION array, dimension (LDQ,N)
* Initially the first K columns are used as workspace.
* On output the columns 1 to K contain
* the updated eigenvectors.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* RHO (input) DOUBLE PRECISION
* The value of the parameter in the rank one update equation.
* RHO >= 0 required.
*
* DLAMDA (input/output) DOUBLE PRECISION array, dimension (K)
* The first K elements of this array contain the old roots
* of the deflated updating problem. These are the poles
* of the secular equation. May be changed on output by
* having lowest order bit set to zero on Cray X-MP, Cray Y-MP,
* Cray-2, or Cray C-90, as described above.
*
* Q2 (input) DOUBLE PRECISION array, dimension (LDQ2, N)
* The first K columns of this matrix contain the non-deflated
* eigenvectors for the split problem.
*
* INDX (input) INTEGER array, dimension (N)
* The permutation used to arrange the columns of the deflated
* Q matrix into three groups (see DLAED2).
* The rows of the eigenvectors found by DLAED4 must be likewise
* permuted before the matrix multiply can take place.
*
* CTOT (input) INTEGER array, dimension (4)
* A count of the total number of the various types of columns
* in Q, as described in INDX. The fourth column type is any
* column which has been deflated.
*
* W (input/output) DOUBLE PRECISION array, dimension (K)
* The first K elements of this array contain the components
* of the deflation-adjusted updating vector. Destroyed on
* output.
*
* S (workspace) DOUBLE PRECISION array, dimension (N1 + 1)*K
* Will contain the eigenvectors of the repaired matrix which
* will be multiplied by the previously accumulated eigenvectors
* to update the system.
*
* LDS (input) INTEGER
* The leading dimension of S. LDS >= max(1,K).
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an eigenvalue did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
* Modified by Francoise Tisseur, University of Tennessee.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, II, IQ2, J, N12, N2, N23
DOUBLE PRECISION TEMP
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMC3, DNRM2
EXTERNAL DLAMC3, DNRM2
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMM, DLACPY, DLAED4, DLASET, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( K.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.K ) THEN
INFO = -2
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAED3', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( K.EQ.0 )
$ RETURN
*
* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
* be computed with high relative accuracy (barring over/underflow).
* This is a problem on machines without a guard digit in
* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
* which on any of these machines zeros out the bottommost
* bit of DLAMDA(I) if it is 1; this makes the subsequent
* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
* occurs. On binary machines with a guard digit (almost all
* machines) it does not change DLAMDA(I) at all. On hexadecimal
* and decimal machines with a guard digit, it slightly
* changes the bottommost bits of DLAMDA(I). It does not account
* for hexadecimal or decimal machines without guard digits
* (we know of none). We use a subroutine call to compute
* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating
* this code.
*
OPS = OPS + 2*N
DO 10 I = 1, K
DLAMDA( I ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I )
10 CONTINUE
*
DO 20 J = 1, K
CALL DLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO )
*
* If the zero finder fails, the computation is terminated.
*
IF( INFO.NE.0 )
$ GO TO 120
20 CONTINUE
*
IF( K.EQ.1 )
$ GO TO 110
IF( K.EQ.2 ) THEN
DO 30 J = 1, K
W( 1 ) = Q( 1, J )
W( 2 ) = Q( 2, J )
II = INDX( 1 )
Q( 1, J ) = W( II )
II = INDX( 2 )
Q( 2, J ) = W( II )
30 CONTINUE
GO TO 110
END IF
*
* Compute updated W.
*
CALL DCOPY( K, W, 1, S, 1 )
*
* Initialize W(I) = Q(I,I)
*
CALL DCOPY( K, Q, LDQ+1, W, 1 )
OPS = OPS + 3*K*( K-1 )
DO 60 J = 1, K
DO 40 I = 1, J - 1
W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
40 CONTINUE
DO 50 I = J + 1, K
W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
50 CONTINUE
60 CONTINUE
OPS = OPS + K
DO 70 I = 1, K
W( I ) = SIGN( SQRT( -W( I ) ), S( I ) )
70 CONTINUE
*
* Compute eigenvectors of the modified rank-1 modification.
*
OPS = OPS + 4*K*K
DO 100 J = 1, K
DO 80 I = 1, K
S( I ) = W( I ) / Q( I, J )
80 CONTINUE
TEMP = DNRM2( K, S, 1 )
DO 90 I = 1, K
II = INDX( I )
Q( I, J ) = S( II ) / TEMP
90 CONTINUE
100 CONTINUE
*
* Compute the updated eigenvectors.
*
110 CONTINUE
*
N2 = N - N1
N12 = CTOT( 1 ) + CTOT( 2 )
N23 = CTOT( 2 ) + CTOT( 3 )
*
CALL DLACPY( 'A', N23, K, Q( CTOT( 1 )+1, 1 ), LDQ, S, N23 )
IQ2 = N1*N12 + 1
IF( N23.NE.0 ) THEN
OPS = OPS + 2*DBLE( N2 )*K*N23
CALL DGEMM( 'N', 'N', N2, K, N23, ONE, Q2( IQ2 ), N2, S, N23,
$ ZERO, Q( N1+1, 1 ), LDQ )
ELSE
CALL DLASET( 'A', N2, K, ZERO, ZERO, Q( N1+1, 1 ), LDQ )
END IF
*
CALL DLACPY( 'A', N12, K, Q, LDQ, S, N12 )
IF( N12.NE.0 ) THEN
OPS = OPS + 2*DBLE( N1 )*K*N12
CALL DGEMM( 'N', 'N', N1, K, N12, ONE, Q2, N1, S, N12, ZERO, Q,
$ LDQ )
ELSE
CALL DLASET( 'A', N1, K, ZERO, ZERO, Q( 1, 1 ), LDQ )
END IF
*
*
120 CONTINUE
RETURN
*
* End of DLAED3
*
END
SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
* Courant Institute, NAG Ltd., and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER I, INFO, N
DOUBLE PRECISION DLAM, RHO
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), DELTA( * ), Z( * )
* ..
* Common block to return operation count and iteration count
* ITCNT is unchanged, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* This subroutine computes the I-th updated eigenvalue of a symmetric
* rank-one modification to a diagonal matrix whose elements are
* given in the array d, and that
*
* D(i) < D(j) for i < j
*
* and that RHO > 0. This is arranged by the calling routine, and is
* no loss in generality. The rank-one modified system is thus
*
* diag( D ) + RHO * Z * Z_transpose.
*
* where we assume the Euclidean norm of Z is 1.
*
* The method consists of approximating the rational functions in the
* secular equation by simpler interpolating rational functions.
*
* Arguments
* =========
*
* N (input) INTEGER
* The length of all arrays.
*
* I (input) INTEGER
* The index of the eigenvalue to be computed. 1 <= I <= N.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The original eigenvalues. It is assumed that they are in
* order, D(I) < D(J) for I < J.
*
* Z (input) DOUBLE PRECISION array, dimension (N)
* The components of the updating vector.
*
* DELTA (output) DOUBLE PRECISION array, dimension (N)
* If N .ne. 1, DELTA contains (D(j) - lambda_I) in its j-th
* component. If N = 1, then DELTA(1) = 1. The vector DELTA
* contains the information necessary to construct the
* eigenvectors.
*
* RHO (input) DOUBLE PRECISION
* The scalar in the symmetric updating formula.
*
* DLAM (output) DOUBLE PRECISION
* The computed lambda_I, the I-th updated eigenvalue.
*
* INFO (output) INTEGER
* = 0: successful exit
* > 0: if INFO = 1, the updating process failed.
*
* Internal Parameters
* ===================
*
* Logical variable ORGATI (origin-at-i?) is used for distinguishing
* whether D(i) or D(i+1) is treated as the origin.
*
* ORGATI = .true. origin at i
* ORGATI = .false. origin at i+1
*
* Logical variable SWTCH3 (switch-for-3-poles?) is for noting
* if we are working with THREE poles!
*
* MAXIT is the maximum number of iterations allowed for each
* eigenvalue.
*
* Further Details
* ===============
*
* Based on contributions by
* Ren-Cang Li, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXIT
PARAMETER ( MAXIT = 20 )
DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0,
$ TEN = 10.0D0 )
* ..
* .. Local Scalars ..
LOGICAL ORGATI, SWTCH, SWTCH3
INTEGER II, IIM1, IIP1, IP1, ITER, J, NITER
DOUBLE PRECISION A, B, C, DEL, DPHI, DPSI, DW, EPS, ERRETM, ETA,
$ PHI, PREW, PSI, RHOINV, TAU, TEMP, TEMP1, W
* ..
* .. Local Arrays ..
DOUBLE PRECISION ZZ( 3 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DLAED5, DLAED6
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SQRT
* ..
* .. Executable Statements ..
*
* Since this routine is called in an inner loop, we do no argument
* checking.
*
* Quick return for N=1 and 2.
*
INFO = 0
IF( N.EQ.1 ) THEN
*
* Presumably, I=1 upon entry
*
OPS = OPS + 3
DLAM = D( 1 ) + RHO*Z( 1 )*Z( 1 )
DELTA( 1 ) = ONE
RETURN
END IF
IF( N.EQ.2 ) THEN
CALL DLAED5( I, D, Z, DELTA, RHO, DLAM )
RETURN
END IF
*
* Compute machine epsilon
*
EPS = DLAMCH( 'Epsilon' )
OPS = OPS + 1
RHOINV = ONE / RHO
*
* The case I = N
*
IF( I.EQ.N ) THEN
*
* Initialize some basic variables
*
II = N - 1
NITER = 1
*
* Calculate initial guess
*
OPS = OPS + 5*N + 1
TEMP = RHO / TWO
*
* If ||Z||_2 is not one, then TEMP should be set to
* RHO * ||Z||_2^2 / TWO
*
DO 10 J = 1, N
DELTA( J ) = ( D( J )-D( I ) ) - TEMP
10 CONTINUE
*
PSI = ZERO
DO 20 J = 1, N - 2
PSI = PSI + Z( J )*Z( J ) / DELTA( J )
20 CONTINUE
*
C = RHOINV + PSI
W = C + Z( II )*Z( II ) / DELTA( II ) +
$ Z( N )*Z( N ) / DELTA( N )
*
IF( W.LE.ZERO ) THEN
OPS = OPS + 7
TEMP = Z( N-1 )*Z( N-1 ) / ( D( N )-D( N-1 )+RHO ) +
$ Z( N )*Z( N ) / RHO
IF( C.LE.TEMP ) THEN
TAU = RHO
ELSE
OPS = OPS + 14
DEL = D( N ) - D( N-1 )
A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
B = Z( N )*Z( N )*DEL
IF( A.LT.ZERO ) THEN
TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
ELSE
TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
END IF
END IF
*
* It can be proved that
* D(N)+RHO/2 <= LAMBDA(N) < D(N)+TAU <= D(N)+RHO
*
ELSE
OPS = OPS + 16
DEL = D( N ) - D( N-1 )
A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
B = Z( N )*Z( N )*DEL
IF( A.LT.ZERO ) THEN
TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
ELSE
TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
END IF
*
* It can be proved that
* D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2
*
END IF
*
OPS = OPS + 2*N + 6*II + 14
DO 30 J = 1, N
DELTA( J ) = ( D( J )-D( I ) ) - TAU
30 CONTINUE
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 40 J = 1, II
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
40 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
TEMP = Z( N ) / DELTA( N )
PHI = Z( N )*TEMP
DPHI = TEMP*TEMP
ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
$ ABS( TAU )*( DPSI+DPHI )
*
W = RHOINV + PHI + PSI
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
OPS = OPS + 1
DLAM = D( I ) + TAU
GO TO 250
END IF
*
* Calculate the new step
*
OPS = OPS + 12
NITER = NITER + 1
C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI
A = ( DELTA( N-1 )+DELTA( N ) )*W -
$ DELTA( N-1 )*DELTA( N )*( DPSI+DPHI )
B = DELTA( N-1 )*DELTA( N )*W
IF( C.LT.ZERO )
$ C = ABS( C )
IF( C.EQ.ZERO ) THEN
* ETA = B/A
OPS = OPS + 1
ETA = RHO - TAU
ELSE IF( A.GE.ZERO ) THEN
OPS = OPS + 8
ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
OPS = OPS + 8
ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
OPS = OPS + N + 6*II + 16
IF( W*ETA.GT.ZERO ) THEN
OPS = OPS + 2
ETA = -W / ( DPSI+DPHI )
END IF
TEMP = TAU + ETA
IF( TEMP.GT.RHO ) THEN
OPS = OPS + 1
ETA = RHO - TAU
END IF
DO 50 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
50 CONTINUE
*
TAU = TAU + ETA
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 60 J = 1, II
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
60 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
TEMP = Z( N ) / DELTA( N )
PHI = Z( N )*TEMP
DPHI = TEMP*TEMP
ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
$ ABS( TAU )*( DPSI+DPHI )
*
W = RHOINV + PHI + PSI
*
* Main loop to update the values of the array DELTA
*
ITER = NITER + 1
*
DO 90 NITER = ITER, MAXIT
*
* Test for convergence
*
OPS = OPS + 1
IF( ABS( W ).LE.EPS*ERRETM ) THEN
OPS = OPS + 1
DLAM = D( I ) + TAU
GO TO 250
END IF
*
* Calculate the new step
*
OPS = OPS + 36 + N + 6*II
C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI
A = ( DELTA( N-1 )+DELTA( N ) )*W -
$ DELTA( N-1 )*DELTA( N )*( DPSI+DPHI )
B = DELTA( N-1 )*DELTA( N )*W
IF( A.GE.ZERO ) THEN
ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
IF( W*ETA.GT.ZERO )
$ ETA = -W / ( DPSI+DPHI )
TEMP = TAU + ETA
IF( TEMP.LE.ZERO )
$ ETA = ETA / TWO
DO 70 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
70 CONTINUE
*
TAU = TAU + ETA
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 80 J = 1, II
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
80 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
TEMP = Z( N ) / DELTA( N )
PHI = Z( N )*TEMP
DPHI = TEMP*TEMP
ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
$ ABS( TAU )*( DPSI+DPHI )
*
W = RHOINV + PHI + PSI
90 CONTINUE
*
* Return with INFO = 1, NITER = MAXIT and not converged
*
INFO = 1
OPS = OPS + 1
DLAM = D( I ) + TAU
GO TO 250
*
* End for the case I = N
*
ELSE
*
* The case for I < N
*
NITER = 1
IP1 = I + 1
*
* Calculate initial guess
*
TEMP = ( D( IP1 )-D( I ) ) / TWO
DO 100 J = 1, N
DELTA( J ) = ( D( J )-D( I ) ) - TEMP
100 CONTINUE
*
PSI = ZERO
DO 110 J = 1, I - 1
PSI = PSI + Z( J )*Z( J ) / DELTA( J )
110 CONTINUE
*
PHI = ZERO
DO 120 J = N, I + 2, -1
PHI = PHI + Z( J )*Z( J ) / DELTA( J )
120 CONTINUE
C = RHOINV + PSI + PHI
W = C + Z( I )*Z( I ) / DELTA( I ) +
$ Z( IP1 )*Z( IP1 ) / DELTA( IP1 )
*
IF( W.GT.ZERO ) THEN
*
* d(i)< the ith eigenvalue < (d(i)+d(i+1))/2
*
* We choose d(i) as origin.
*
ORGATI = .TRUE.
DEL = D( IP1 ) - D( I )
A = C*DEL + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 )
B = Z( I )*Z( I )*DEL
IF( A.GT.ZERO ) THEN
TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
ELSE
TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
END IF
ELSE
*
* (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1)
*
* We choose d(i+1) as origin.
*
ORGATI = .FALSE.
DEL = D( IP1 ) - D( I )
A = C*DEL - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 )
B = Z( IP1 )*Z( IP1 )*DEL
IF( A.LT.ZERO ) THEN
TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) )
ELSE
TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C )
END IF
END IF
*
IF( ORGATI ) THEN
DO 130 J = 1, N
DELTA( J ) = ( D( J )-D( I ) ) - TAU
130 CONTINUE
ELSE
DO 140 J = 1, N
DELTA( J ) = ( D( J )-D( IP1 ) ) - TAU
140 CONTINUE
END IF
IF( ORGATI ) THEN
II = I
ELSE
II = I + 1
END IF
IIM1 = II - 1
IIP1 = II + 1
OPS = OPS + 13*N + 6*( IIM1-IIP1 ) + 45
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 150 J = 1, IIM1
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
150 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
DPHI = ZERO
PHI = ZERO
DO 160 J = N, IIP1, -1
TEMP = Z( J ) / DELTA( J )
PHI = PHI + Z( J )*TEMP
DPHI = DPHI + TEMP*TEMP
ERRETM = ERRETM + PHI
160 CONTINUE
*
W = RHOINV + PHI + PSI
*
* W is the value of the secular function with
* its ii-th element removed.
*
SWTCH3 = .FALSE.
IF( ORGATI ) THEN
IF( W.LT.ZERO )
$ SWTCH3 = .TRUE.
ELSE
IF( W.GT.ZERO )
$ SWTCH3 = .TRUE.
END IF
IF( II.EQ.1 .OR. II.EQ.N )
$ SWTCH3 = .FALSE.
*
TEMP = Z( II ) / DELTA( II )
DW = DPSI + DPHI + TEMP*TEMP
TEMP = Z( II )*TEMP
W = W + TEMP
ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
$ THREE*ABS( TEMP ) + ABS( TAU )*DW
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
IF( ORGATI ) THEN
DLAM = D( I ) + TAU
ELSE
DLAM = D( IP1 ) + TAU
END IF
GO TO 250
END IF
*
* Calculate the new step
*
OPS = OPS + 14
NITER = NITER + 1
IF( .NOT.SWTCH3 ) THEN
IF( ORGATI ) THEN
C = W - DELTA( IP1 )*DW - ( D( I )-D( IP1 ) )*
$ ( Z( I ) / DELTA( I ) )**2
ELSE
C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )*
$ ( Z( IP1 ) / DELTA( IP1 ) )**2
END IF
A = ( DELTA( I )+DELTA( IP1 ) )*W -
$ DELTA( I )*DELTA( IP1 )*DW
B = DELTA( I )*DELTA( IP1 )*W
IF( C.EQ.ZERO ) THEN
IF( A.EQ.ZERO ) THEN
OPS = OPS + 5
IF( ORGATI ) THEN
A = Z( I )*Z( I ) + DELTA( IP1 )*DELTA( IP1 )*
$ ( DPSI+DPHI )
ELSE
A = Z( IP1 )*Z( IP1 ) + DELTA( I )*DELTA( I )*
$ ( DPSI+DPHI )
END IF
END IF
ETA = B / A
ELSE IF( A.LE.ZERO ) THEN
OPS = OPS + 8
ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
OPS = OPS + 8
ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
ELSE
*
* Interpolation using THREE most relevant poles
*
OPS = OPS + 15
TEMP = RHOINV + PSI + PHI
IF( ORGATI ) THEN
TEMP1 = Z( IIM1 ) / DELTA( IIM1 )
TEMP1 = TEMP1*TEMP1
C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) -
$ ( D( IIM1 )-D( IIP1 ) )*TEMP1
ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*
$ ( ( DPSI-TEMP1 )+DPHI )
ELSE
TEMP1 = Z( IIP1 ) / DELTA( IIP1 )
TEMP1 = TEMP1*TEMP1
C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) -
$ ( D( IIP1 )-D( IIM1 ) )*TEMP1
ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*
$ ( DPSI+( DPHI-TEMP1 ) )
ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
END IF
ZZ( 2 ) = Z( II )*Z( II )
CALL DLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA,
$ INFO )
IF( INFO.NE.0 )
$ GO TO 250
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
OPS = OPS + 18 + 7*N + 6*( IIM1-IIP1 )
IF( W*ETA.GE.ZERO ) THEN
OPS = OPS + 1
ETA = -W / DW
END IF
TEMP = TAU + ETA
DEL = ( D( IP1 )-D( I ) ) / TWO
IF( ORGATI ) THEN
IF( TEMP.GE.DEL ) THEN
OPS = OPS + 1
ETA = DEL - TAU
END IF
IF( TEMP.LE.ZERO ) THEN
OPS = OPS + 1
ETA = ETA / TWO
END IF
ELSE
IF( TEMP.LE.-DEL ) THEN
OPS = OPS + 1
ETA = -DEL - TAU
END IF
IF( TEMP.GE.ZERO ) THEN
OPS = OPS + 1
ETA = ETA / TWO
END IF
END IF
*
PREW = W
*
170 CONTINUE
DO 180 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
180 CONTINUE
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 190 J = 1, IIM1
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
190 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
DPHI = ZERO
PHI = ZERO
DO 200 J = N, IIP1, -1
TEMP = Z( J ) / DELTA( J )
PHI = PHI + Z( J )*TEMP
DPHI = DPHI + TEMP*TEMP
ERRETM = ERRETM + PHI
200 CONTINUE
*
TEMP = Z( II ) / DELTA( II )
DW = DPSI + DPHI + TEMP*TEMP
TEMP = Z( II )*TEMP
W = RHOINV + PHI + PSI + TEMP
ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
$ THREE*ABS( TEMP ) + ABS( TAU+ETA )*DW
*
SWTCH = .FALSE.
IF( ORGATI ) THEN
IF( -W.GT.ABS( PREW ) / TEN )
$ SWTCH = .TRUE.
ELSE
IF( W.GT.ABS( PREW ) / TEN )
$ SWTCH = .TRUE.
END IF
*
TAU = TAU + ETA
*
* Main loop to update the values of the array DELTA
*
ITER = NITER + 1
*
DO 240 NITER = ITER, MAXIT
*
* Test for convergence
*
OPS = OPS + 1
IF( ABS( W ).LE.EPS*ERRETM ) THEN
OPS = OPS + 1
IF( ORGATI ) THEN
DLAM = D( I ) + TAU
ELSE
DLAM = D( IP1 ) + TAU
END IF
GO TO 250
END IF
*
* Calculate the new step
*
IF( .NOT.SWTCH3 ) THEN
OPS = OPS + 14
IF( .NOT.SWTCH ) THEN
IF( ORGATI ) THEN
C = W - DELTA( IP1 )*DW -
$ ( D( I )-D( IP1 ) )*( Z( I ) / DELTA( I ) )**2
ELSE
C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )*
$ ( Z( IP1 ) / DELTA( IP1 ) )**2
END IF
ELSE
TEMP = Z( II ) / DELTA( II )
IF( ORGATI ) THEN
DPSI = DPSI + TEMP*TEMP
ELSE
DPHI = DPHI + TEMP*TEMP
END IF
C = W - DELTA( I )*DPSI - DELTA( IP1 )*DPHI
END IF
A = ( DELTA( I )+DELTA( IP1 ) )*W -
$ DELTA( I )*DELTA( IP1 )*DW
B = DELTA( I )*DELTA( IP1 )*W
IF( C.EQ.ZERO ) THEN
IF( A.EQ.ZERO ) THEN
OPS = OPS + 5
IF( .NOT.SWTCH ) THEN
IF( ORGATI ) THEN
A = Z( I )*Z( I ) + DELTA( IP1 )*
$ DELTA( IP1 )*( DPSI+DPHI )
ELSE
A = Z( IP1 )*Z( IP1 ) +
$ DELTA( I )*DELTA( I )*( DPSI+DPHI )
END IF
ELSE
A = DELTA( I )*DELTA( I )*DPSI +
$ DELTA( IP1 )*DELTA( IP1 )*DPHI
END IF
END IF
OPS = OPS + 1
ETA = B / A
ELSE IF( A.LE.ZERO ) THEN
OPS = OPS + 8
ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
OPS = OPS + 8
ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
ELSE
*
* Interpolation using THREE most relevant poles
*
OPS = OPS + 2
TEMP = RHOINV + PSI + PHI
IF( SWTCH ) THEN
OPS = OPS + 10
C = TEMP - DELTA( IIM1 )*DPSI - DELTA( IIP1 )*DPHI
ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*DPSI
ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*DPHI
ELSE
OPS = OPS + 14
IF( ORGATI ) THEN
TEMP1 = Z( IIM1 ) / DELTA( IIM1 )
TEMP1 = TEMP1*TEMP1
C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) -
$ ( D( IIM1 )-D( IIP1 ) )*TEMP1
ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*
$ ( ( DPSI-TEMP1 )+DPHI )
ELSE
TEMP1 = Z( IIP1 ) / DELTA( IIP1 )
TEMP1 = TEMP1*TEMP1
C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) -
$ ( D( IIP1 )-D( IIM1 ) )*TEMP1
ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*
$ ( DPSI+( DPHI-TEMP1 ) )
ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
END IF
END IF
CALL DLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA,
$ INFO )
IF( INFO.NE.0 )
$ GO TO 250
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
OPS = OPS + 7*N + 6*( IIM1-IIP1 ) + 18
IF( W*ETA.GE.ZERO ) THEN
OPS = OPS + 1
ETA = -W / DW
END IF
TEMP = TAU + ETA
DEL = ( D( IP1 )-D( I ) ) / TWO
IF( ORGATI ) THEN
IF( TEMP.GE.DEL ) THEN
ETA = DEL - TAU
OPS = OPS + 1
END IF
IF( TEMP.LE.ZERO ) THEN
ETA = ETA / TWO
OPS = OPS + 1
END IF
ELSE
IF( TEMP.LE.-DEL ) THEN
ETA = -DEL - TAU
OPS = OPS + 1
END IF
IF( TEMP.GE.ZERO ) THEN
ETA = ETA / TWO
OPS = OPS + 1
END IF
END IF
*
DO 210 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
210 CONTINUE
*
TAU = TAU + ETA
PREW = W
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 220 J = 1, IIM1
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
220 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
DPHI = ZERO
PHI = ZERO
DO 230 J = N, IIP1, -1
TEMP = Z( J ) / DELTA( J )
PHI = PHI + Z( J )*TEMP
DPHI = DPHI + TEMP*TEMP
ERRETM = ERRETM + PHI
230 CONTINUE
*
TEMP = Z( II ) / DELTA( II )
DW = DPSI + DPHI + TEMP*TEMP
TEMP = Z( II )*TEMP
W = RHOINV + PHI + PSI + TEMP
ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
$ THREE*ABS( TEMP ) + ABS( TAU )*DW
IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN )
$ SWTCH = .NOT.SWTCH
*
240 CONTINUE
*
* Return with INFO = 1, NITER = MAXIT and not converged
*
INFO = 1
OPS = OPS + 1
IF( ORGATI ) THEN
DLAM = D( I ) + TAU
ELSE
DLAM = D( IP1 ) + TAU
END IF
*
END IF
*
250 CONTINUE
RETURN
*
* End of DLAED4
*
END
SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
* Courant Institute, NAG Ltd., and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
INTEGER I
DOUBLE PRECISION DLAM, RHO
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( 2 ), DELTA( 2 ), Z( 2 )
* ..
* Common block to return operation count and iteration count
* ITCNT is unchanged, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* This subroutine computes the I-th eigenvalue of a symmetric rank-one
* modification of a 2-by-2 diagonal matrix
*
* diag( D ) + RHO * Z * transpose(Z) .
*
* The diagonal elements in the array D are assumed to satisfy
*
* D(i) < D(j) for i < j .
*
* We also assume RHO > 0 and that the Euclidean norm of the vector
* Z is one.
*
* Arguments
* =========
*
* I (input) INTEGER
* The index of the eigenvalue to be computed. I = 1 or I = 2.
*
* D (input) DOUBLE PRECISION array, dimension (2)
* The original eigenvalues. We assume D(1) < D(2).
*
* Z (input) DOUBLE PRECISION array, dimension (2)
* The components of the updating vector.
*
* DELTA (output) DOUBLE PRECISION array, dimension (2)
* The vector DELTA contains the information necessary
* to construct the eigenvectors.
*
* RHO (input) DOUBLE PRECISION
* The scalar in the symmetric updating formula.
*
* DLAM (output) DOUBLE PRECISION
* The computed lambda_I, the I-th updated eigenvalue.
*
* Further Details
* ===============
*
* Based on contributions by
* Ren-Cang Li, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, FOUR
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ FOUR = 4.0D0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION B, C, DEL, TAU, TEMP, W
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SQRT
* ..
* .. Executable Statements ..
*
DEL = D( 2 ) - D( 1 )
IF( I.EQ.1 ) THEN
W = ONE + TWO*RHO*( Z( 2 )*Z( 2 )-Z( 1 )*Z( 1 ) ) / DEL
IF( W.GT.ZERO ) THEN
OPS = OPS + 33
B = DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
C = RHO*Z( 1 )*Z( 1 )*DEL
*
* B > ZERO, always
*
TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) )
DLAM = D( 1 ) + TAU
DELTA( 1 ) = -Z( 1 ) / TAU
DELTA( 2 ) = Z( 2 ) / ( DEL-TAU )
ELSE
OPS = OPS + 31
B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
C = RHO*Z( 2 )*Z( 2 )*DEL
IF( B.GT.ZERO ) THEN
TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) )
ELSE
TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO
END IF
DLAM = D( 2 ) + TAU
DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
DELTA( 2 ) = -Z( 2 ) / TAU
END IF
TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
DELTA( 1 ) = DELTA( 1 ) / TEMP
DELTA( 2 ) = DELTA( 2 ) / TEMP
ELSE
*
* Now I=2
*
OPS = OPS + 24
B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
C = RHO*Z( 2 )*Z( 2 )*DEL
IF( B.GT.ZERO ) THEN
TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO
ELSE
TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) )
END IF
DLAM = D( 2 ) + TAU
DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
DELTA( 2 ) = -Z( 2 ) / TAU
TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
DELTA( 1 ) = DELTA( 1 ) / TEMP
DELTA( 2 ) = DELTA( 2 ) / TEMP
END IF
RETURN
*
* End OF DLAED5
*
END
SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
* Courant Institute, NAG Ltd., and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
LOGICAL ORGATI
INTEGER INFO, KNITER
DOUBLE PRECISION FINIT, RHO, TAU
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( 3 ), Z( 3 )
* ..
* Common block to return operation count and iteration count
* ITCNT is unchanged, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLAED6 computes the positive or negative root (closest to the origin)
* of
* z(1) z(2) z(3)
* f(x) = rho + --------- + ---------- + ---------
* d(1)-x d(2)-x d(3)-x
*
* It is assumed that
*
* if ORGATI = .true. the root is between d(2) and d(3);
* otherwise it is between d(1) and d(2)
*
* This routine will be called by DLAED4 when necessary. In most cases,
* the root sought is the smallest in magnitude, though it might not be
* in some extremely rare situations.
*
* Arguments
* =========
*
* KNITER (input) INTEGER
* Refer to DLAED4 for its significance.
*
* ORGATI (input) LOGICAL
* If ORGATI is true, the needed root is between d(2) and
* d(3); otherwise it is between d(1) and d(2). See
* DLAED4 for further details.
*
* RHO (input) DOUBLE PRECISION
* Refer to the equation f(x) above.
*
* D (input) DOUBLE PRECISION array, dimension (3)
* D satisfies d(1) < d(2) < d(3).
*
* Z (input) DOUBLE PRECISION array, dimension (3)
* Each of the elements in z must be positive.
*
* FINIT (input) DOUBLE PRECISION
* The value of f at 0. It is more accurate than the one
* evaluated inside this routine (if someone wants to do
* so).
*
* TAU (output) DOUBLE PRECISION
* The root of the equation f(x).
*
* INFO (output) INTEGER
* = 0: successful exit
* > 0: if INFO = 1, failure to converge
*
* Further Details
* ===============
*
* Based on contributions by
* Ren-Cang Li, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXIT
PARAMETER ( MAXIT = 20 )
DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Local Arrays ..
DOUBLE PRECISION DSCALE( 3 ), ZSCALE( 3 )
* ..
* .. Local Scalars ..
LOGICAL FIRST, SCALE
INTEGER I, ITER, NITER
DOUBLE PRECISION A, B, BASE, C, DDF, DF, EPS, ERRETM, ETA, F,
$ FC, SCLFAC, SCLINV, SMALL1, SMALL2, SMINV1,
$ SMINV2, TEMP, TEMP1, TEMP2, TEMP3, TEMP4
* ..
* .. Save statement ..
SAVE FIRST, SMALL1, SMINV1, SMALL2, SMINV2, EPS
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT
* ..
* .. Data statements ..
DATA FIRST / .TRUE. /
* ..
* .. Executable Statements ..
*
INFO = 0
*
NITER = 1
TAU = ZERO
IF( KNITER.EQ.2 ) THEN
IF( ORGATI ) THEN
TEMP = ( D( 3 )-D( 2 ) ) / TWO
C = RHO + Z( 1 ) / ( ( D( 1 )-D( 2 ) )-TEMP )
A = C*( D( 2 )+D( 3 ) ) + Z( 2 ) + Z( 3 )
B = C*D( 2 )*D( 3 ) + Z( 2 )*D( 3 ) + Z( 3 )*D( 2 )
ELSE
TEMP = ( D( 1 )-D( 2 ) ) / TWO
C = RHO + Z( 3 ) / ( ( D( 3 )-D( 2 ) )-TEMP )
A = C*( D( 1 )+D( 2 ) ) + Z( 1 ) + Z( 2 )
B = C*D( 1 )*D( 2 ) + Z( 1 )*D( 2 ) + Z( 2 )*D( 1 )
END IF
TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) )
A = A / TEMP
B = B / TEMP
C = C / TEMP
OPS = OPS + 19
IF( C.EQ.ZERO ) THEN
TAU = B / A
OPS = OPS + 1
ELSE IF( A.LE.ZERO ) THEN
OPS = OPS + 8
TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
OPS = OPS + 8
TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
OPS = OPS + 9
TEMP = RHO + Z( 1 ) / ( D( 1 )-TAU ) +
$ Z( 2 ) / ( D( 2 )-TAU ) + Z( 3 ) / ( D( 3 )-TAU )
IF( ABS( FINIT ).LE.ABS( TEMP ) )
$ TAU = ZERO
END IF
*
* On first call to routine, get machine parameters for
* possible scaling to avoid overflow
*
IF( FIRST ) THEN
EPS = DLAMCH( 'Epsilon' )
BASE = DLAMCH( 'Base' )
SMALL1 = BASE**( INT( LOG( DLAMCH( 'SafMin' ) ) / LOG( BASE ) /
$ THREE ) )
SMINV1 = ONE / SMALL1
SMALL2 = SMALL1*SMALL1
SMINV2 = SMINV1*SMINV1
FIRST = .FALSE.
END IF
*
* Determine if scaling of inputs necessary to avoid overflow
* when computing 1/TEMP**3
*
OPS = OPS + 2
IF( ORGATI ) THEN
TEMP = MIN( ABS( D( 2 )-TAU ), ABS( D( 3 )-TAU ) )
ELSE
TEMP = MIN( ABS( D( 1 )-TAU ), ABS( D( 2 )-TAU ) )
END IF
SCALE = .FALSE.
IF( TEMP.LE.SMALL1 ) THEN
SCALE = .TRUE.
IF( TEMP.LE.SMALL2 ) THEN
*
* Scale up by power of radix nearest 1/SAFMIN**(2/3)
*
SCLFAC = SMINV2
SCLINV = SMALL2
ELSE
*
* Scale up by power of radix nearest 1/SAFMIN**(1/3)
*
SCLFAC = SMINV1
SCLINV = SMALL1
END IF
*
* Scaling up safe because D, Z, TAU scaled elsewhere to be O(1)
*
OPS = OPS + 7
DO 10 I = 1, 3
DSCALE( I ) = D( I )*SCLFAC
ZSCALE( I ) = Z( I )*SCLFAC
10 CONTINUE
TAU = TAU*SCLFAC
ELSE
*
* Copy D and Z to DSCALE and ZSCALE
*
DO 20 I = 1, 3
DSCALE( I ) = D( I )
ZSCALE( I ) = Z( I )
20 CONTINUE
END IF
*
FC = ZERO
DF = ZERO
DDF = ZERO
OPS = OPS + 11
DO 30 I = 1, 3
TEMP = ONE / ( DSCALE( I )-TAU )
TEMP1 = ZSCALE( I )*TEMP
TEMP2 = TEMP1*TEMP
TEMP3 = TEMP2*TEMP
FC = FC + TEMP1 / DSCALE( I )
DF = DF + TEMP2
DDF = DDF + TEMP3
30 CONTINUE
F = FINIT + TAU*FC
*
IF( ABS( F ).LE.ZERO )
$ GO TO 60
*
* Iteration begins
*
* It is not hard to see that
*
* 1) Iterations will go up monotonically
* if FINIT < 0;
*
* 2) Iterations will go down monotonically
* if FINIT > 0.
*
ITER = NITER + 1
*
DO 50 NITER = ITER, MAXIT
*
OPS = OPS + 18
IF( ORGATI ) THEN
TEMP1 = DSCALE( 2 ) - TAU
TEMP2 = DSCALE( 3 ) - TAU
ELSE
TEMP1 = DSCALE( 1 ) - TAU
TEMP2 = DSCALE( 2 ) - TAU
END IF
A = ( TEMP1+TEMP2 )*F - TEMP1*TEMP2*DF
B = TEMP1*TEMP2*F
C = F - ( TEMP1+TEMP2 )*DF + TEMP1*TEMP2*DDF
TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) )
A = A / TEMP
B = B / TEMP
C = C / TEMP
IF( C.EQ.ZERO ) THEN
OPS = OPS + 1
ETA = B / A
ELSE IF( A.LE.ZERO ) THEN
OPS = OPS + 8
ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
OPS = OPS + 8
ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
IF( F*ETA.GE.ZERO ) THEN
OPS = OPS + 1
ETA = -F / DF
END IF
*
OPS = OPS + 1
TEMP = ETA + TAU
IF( ORGATI ) THEN
IF( ETA.GT.ZERO .AND. TEMP.GE.DSCALE( 3 ) ) THEN
OPS = OPS + 2
ETA = ( DSCALE( 3 )-TAU ) / TWO
END IF
IF( ETA.LT.ZERO .AND. TEMP.LE.DSCALE( 2 ) ) THEN
OPS = OPS + 2
ETA = ( DSCALE( 2 )-TAU ) / TWO
END IF
ELSE
IF( ETA.GT.ZERO .AND. TEMP.GE.DSCALE( 2 ) ) THEN
OPS = OPS + 2
ETA = ( DSCALE( 2 )-TAU ) / TWO
END IF
IF( ETA.LT.ZERO .AND. TEMP.LE.DSCALE( 1 ) ) THEN
OPS = OPS + 2
ETA = ( DSCALE( 1 )-TAU ) / TWO
END IF
END IF
OPS = OPS + 1
TAU = TAU + ETA
*
FC = ZERO
ERRETM = ZERO
DF = ZERO
DDF = ZERO
OPS = OPS + 37
DO 40 I = 1, 3
TEMP = ONE / ( DSCALE( I )-TAU )
TEMP1 = ZSCALE( I )*TEMP
TEMP2 = TEMP1*TEMP
TEMP3 = TEMP2*TEMP
TEMP4 = TEMP1 / DSCALE( I )
FC = FC + TEMP4
ERRETM = ERRETM + ABS( TEMP4 )
DF = DF + TEMP2
DDF = DDF + TEMP3
40 CONTINUE
F = FINIT + TAU*FC
ERRETM = EIGHT*( ABS( FINIT )+ABS( TAU )*ERRETM ) +
$ ABS( TAU )*DF
IF( ABS( F ).LE.EPS*ERRETM )
$ GO TO 60
50 CONTINUE
INFO = 1
60 CONTINUE
*
* Undo scaling
*
IF( SCALE ) THEN
OPS = OPS + 1
TAU = TAU*SCLINV
END IF
RETURN
*
* End of DLAED6
*
END
SUBROUTINE DLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q,
$ LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR,
$ PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK,
$ INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
INTEGER CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N,
$ QSIZ, TLVLS
DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),
$ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )
DOUBLE PRECISION D( * ), GIVNUM( 2, * ), Q( LDQ, * ),
$ QSTORE( * ), WORK( * )
* ..
* Common block to return operation count and iteration count
* ITCNT is unchanged, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLAED7 computes the updated eigensystem of a diagonal
* matrix after modification by a rank-one symmetric matrix. This
* routine is used only for the eigenproblem which requires all
* eigenvalues and optionally eigenvectors of a dense symmetric matrix
* that has been reduced to tridiagonal form. DLAED1 handles
* the case in which all eigenvalues and eigenvectors of a symmetric
* tridiagonal matrix are desired.
*
* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)
*
* where Z = Q'u, u is a vector of length N with ones in the
* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
*
* The eigenvectors of the original matrix are stored in Q, and the
* eigenvalues are in D. The algorithm consists of three stages:
*
* The first stage consists of deflating the size of the problem
* when there are multiple eigenvalues or if there is a zero in
* the Z vector. For each such occurence the dimension of the
* secular equation problem is reduced by one. This stage is
* performed by the routine DLAED8.
*
* The second stage consists of calculating the updated
* eigenvalues. This is done by finding the roots of the secular
* equation via the routine DLAED4 (as called by DLAED9).
* This routine also calculates the eigenvectors of the current
* problem.
*
* The final stage consists of computing the updated eigenvectors
* directly using the updated eigenvalues. The eigenvectors for
* the current problem are multiplied with the eigenvectors from
* the overall problem.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* = 0: Compute eigenvalues only.
* = 1: Compute eigenvectors of original dense symmetric matrix
* also. On entry, Q contains the orthogonal matrix used
* to reduce the original matrix to tridiagonal form.
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* QSIZ (input) INTEGER
* The dimension of the orthogonal matrix used to reduce
* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.
*
* TLVLS (input) INTEGER
* The total number of merging levels in the overall divide and
* conquer tree.
*
* CURLVL (input) INTEGER
* The current level in the overall merge routine,
* 0 <= CURLVL <= TLVLS.
*
* CURPBM (input) INTEGER
* The current problem in the current level in the overall
* merge routine (counting from upper left to lower right).
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the eigenvalues of the rank-1-perturbed matrix.
* On exit, the eigenvalues of the repaired matrix.
*
* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
* On entry, the eigenvectors of the rank-1-perturbed matrix.
* On exit, the eigenvectors of the repaired tridiagonal matrix.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* INDXQ (output) INTEGER array, dimension (N)
* The permutation which will reintegrate the subproblem just
* solved back into sorted order, i.e., D( INDXQ( I = 1, N ) )
* will be in ascending order.
*
* RHO (input) DOUBLE PRECISION
* The subdiagonal element used to create the rank-1
* modification.
*
* CUTPNT (input) INTEGER
* Contains the location of the last eigenvalue in the leading
* sub-matrix. min(1,N) <= CUTPNT <= N.
*
* QSTORE (input/output) DOUBLE PRECISION array, dimension (N**2+1)
* Stores eigenvectors of submatrices encountered during
* divide and conquer, packed together. QPTR points to
* beginning of the submatrices.
*
* QPTR (input/output) INTEGER array, dimension (N+2)
* List of indices pointing to beginning of submatrices stored
* in QSTORE. The submatrices are numbered starting at the
* bottom left of the divide and conquer tree, from left to
* right and bottom to top.
*
* PRMPTR (input) INTEGER array, dimension (N lg N)
* Contains a list of pointers which indicate where in PERM a
* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)
* indicates the size of the permutation and also the size of
* the full, non-deflated problem.
*
* PERM (input) INTEGER array, dimension (N lg N)
* Contains the permutations (from deflation and sorting) to be
* applied to each eigenblock.
*
* GIVPTR (input) INTEGER array, dimension (N lg N)
* Contains a list of pointers which indicate where in GIVCOL a
* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)
* indicates the number of Givens rotations.
*
* GIVCOL (input) INTEGER array, dimension (2, N lg N)
* Each pair of numbers indicates a pair of columns to take place
* in a Givens rotation.
*
* GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N)
* Each number indicates the S value to be used in the
* corresponding Givens rotation.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N+QSIZ*N)
*
* IWORK (workspace) INTEGER array, dimension (4*N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an eigenvalue did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER COLTYP, CURR, I, IDLMDA, INDX, INDXC, INDXP,
$ IQ2, IS, IW, IZ, K, LDQ2, N1, N2, PTR
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLAED8, DLAED9, DLAEDA, DLAMRG, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN
INFO = -4
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( MIN( 1, N ).GT.CUTPNT .OR. N.LT.CUTPNT ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAED7', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* The following values are for bookkeeping purposes only. They are
* integer pointers which indicate the portion of the workspace
* used by a particular array in DLAED8 and DLAED9.
*
IF( ICOMPQ.EQ.1 ) THEN
LDQ2 = QSIZ
ELSE
LDQ2 = N
END IF
*
IZ = 1
IDLMDA = IZ + N
IW = IDLMDA + N
IQ2 = IW + N
IS = IQ2 + N*LDQ2
*
INDX = 1
INDXC = INDX + N
COLTYP = INDXC + N
INDXP = COLTYP + N
*
* Form the z-vector which consists of the last row of Q_1 and the
* first row of Q_2.
*
PTR = 1 + 2**TLVLS
DO 10 I = 1, CURLVL - 1
PTR = PTR + 2**( TLVLS-I )
10 CONTINUE
CURR = PTR + CURPBM
CALL DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,
$ GIVCOL, GIVNUM, QSTORE, QPTR, WORK( IZ ),
$ WORK( IZ+N ), INFO )
*
* When solving the final problem, we no longer need the stored data,
* so we will overwrite the data from this level onto the previously
* used storage space.
*
IF( CURLVL.EQ.TLVLS ) THEN
QPTR( CURR ) = 1
PRMPTR( CURR ) = 1
GIVPTR( CURR ) = 1
END IF
*
* Sort and Deflate eigenvalues.
*
CALL DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, CUTPNT,
$ WORK( IZ ), WORK( IDLMDA ), WORK( IQ2 ), LDQ2,
$ WORK( IW ), PERM( PRMPTR( CURR ) ), GIVPTR( CURR+1 ),
$ GIVCOL( 1, GIVPTR( CURR ) ),
$ GIVNUM( 1, GIVPTR( CURR ) ), IWORK( INDXP ),
$ IWORK( INDX ), INFO )
PRMPTR( CURR+1 ) = PRMPTR( CURR ) + N
GIVPTR( CURR+1 ) = GIVPTR( CURR+1 ) + GIVPTR( CURR )
*
* Solve Secular Equation.
*
IF( K.NE.0 ) THEN
CALL DLAED9( K, 1, K, N, D, WORK( IS ), K, RHO, WORK( IDLMDA ),
$ WORK( IW ), QSTORE( QPTR( CURR ) ), K, INFO )
IF( INFO.NE.0 )
$ GO TO 30
IF( ICOMPQ.EQ.1 ) THEN
OPS = OPS + 2*DBLE( QSIZ )*K*K
CALL DGEMM( 'N', 'N', QSIZ, K, K, ONE, WORK( IQ2 ), LDQ2,
$ QSTORE( QPTR( CURR ) ), K, ZERO, Q, LDQ )
END IF
QPTR( CURR+1 ) = QPTR( CURR ) + K**2
*
* Prepare the INDXQ sorting permutation.
*
N1 = K
N2 = N - K
CALL DLAMRG( N1, N2, D, 1, -1, INDXQ )
ELSE
QPTR( CURR+1 ) = QPTR( CURR )
DO 20 I = 1, N
INDXQ( I ) = I
20 CONTINUE
END IF
*
30 CONTINUE
RETURN
*
* End of DLAED7
*
END
SUBROUTINE DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO,
$ CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR,
$ GIVCOL, GIVNUM, INDXP, INDX, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
* Courant Institute, NAG Ltd., and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
INTEGER CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N,
$ QSIZ
DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ),
$ INDXQ( * ), PERM( * )
DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ),
$ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * )
* ..
* Common block to return operation count and iteration count
* ITCNT is unchanged, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLAED8 merges the two sets of eigenvalues together into a single
* sorted set. Then it tries to deflate the size of the problem.
* There are two ways in which deflation can occur: when two or more
* eigenvalues are close together or if there is a tiny element in the
* Z vector. For each such occurrence the order of the related secular
* equation problem is reduced by one.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* = 0: Compute eigenvalues only.
* = 1: Compute eigenvectors of original dense symmetric matrix
* also. On entry, Q contains the orthogonal matrix used
* to reduce the original matrix to tridiagonal form.
*
* K (output) INTEGER
* The number of non-deflated eigenvalues, and the order of the
* related secular equation.
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* QSIZ (input) INTEGER
* The dimension of the orthogonal matrix used to reduce
* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the eigenvalues of the two submatrices to be
* combined. On exit, the trailing (N-K) updated eigenvalues
* (those which were deflated) sorted into increasing order.
*
* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
* If ICOMPQ = 0, Q is not referenced. Otherwise,
* on entry, Q contains the eigenvectors of the partially solved
* system which has been previously updated in matrix
* multiplies with other partially solved eigensystems.
* On exit, Q contains the trailing (N-K) updated eigenvectors
* (those which were deflated) in its last N-K columns.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* INDXQ (input) INTEGER array, dimension (N)
* The permutation which separately sorts the two sub-problems
* in D into ascending order. Note that elements in the second
* half of this permutation must first have CUTPNT added to
* their values in order to be accurate.
*
* RHO (input/output) DOUBLE PRECISION
* On entry, the off-diagonal element associated with the rank-1
* cut which originally split the two submatrices which are now
* being recombined.
* On exit, RHO has been modified to the value required by
* DLAED3.
*
* CUTPNT (input) INTEGER
* The location of the last eigenvalue in the leading
* sub-matrix. min(1,N) <= CUTPNT <= N.
*
* Z (input) DOUBLE PRECISION array, dimension (N)
* On entry, Z contains the updating vector (the last row of
* the first sub-eigenvector matrix and the first row of the
* second sub-eigenvector matrix).
* On exit, the contents of Z are destroyed by the updating
* process.
*
* DLAMDA (output) DOUBLE PRECISION array, dimension (N)
* A copy of the first K eigenvalues which will be used by
* DLAED3 to form the secular equation.
*
* Q2 (output) DOUBLE PRECISION array, dimension (LDQ2,N)
* If ICOMPQ = 0, Q2 is not referenced. Otherwise,
* a copy of the first K eigenvectors which will be used by
* DLAED7 in a matrix multiply (DGEMM) to update the new
* eigenvectors.
*
* LDQ2 (input) INTEGER
* The leading dimension of the array Q2. LDQ2 >= max(1,N).
*
* W (output) DOUBLE PRECISION array, dimension (N)
* The first k values of the final deflation-altered z-vector and
* will be passed to DLAED3.
*
* PERM (output) INTEGER array, dimension (N)
* The permutations (from deflation and sorting) to be applied
* to each eigenblock.
*
* GIVPTR (output) INTEGER
* The number of Givens rotations which took place in this
* subproblem.
*
* GIVCOL (output) INTEGER array, dimension (2, N)
* Each pair of numbers indicates a pair of columns to take place
* in a Givens rotation.
*
* GIVNUM (output) DOUBLE PRECISION array, dimension (2, N)
* Each number indicates the S value to be used in the
* corresponding Givens rotation.
*
* INDXP (workspace) INTEGER array, dimension (N)
* The permutation used to place deflated values of D at the end
* of the array. INDXP(1:K) points to the nondeflated D-values
* and INDXP(K+1:N) points to the deflated eigenvalues.
*
* INDX (workspace) INTEGER array, dimension (N)
* The permutation used to sort the contents of D into ascending
* order.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT
PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0,
$ TWO = 2.0D0, EIGHT = 8.0D0 )
* ..
* .. Local Scalars ..
*
INTEGER I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2
DOUBLE PRECISION C, EPS, S, T, TAU, TOL
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH, DLAPY2
EXTERNAL IDAMAX, DLAMCH, DLAPY2
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLACPY, DLAMRG, DROT, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN
INFO = -4
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN
INFO = -10
ELSE IF( LDQ2.LT.MAX( 1, N ) ) THEN
INFO = -14
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAED8', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
N1 = CUTPNT
N2 = N - N1
N1P1 = N1 + 1
*
IF( RHO.LT.ZERO ) THEN
OPS = OPS + N2
CALL DSCAL( N2, MONE, Z( N1P1 ), 1 )
END IF
*
* Normalize z so that norm(z) = 1
*
OPS = OPS + N + 6
T = ONE / SQRT( TWO )
DO 10 J = 1, N
INDX( J ) = J
10 CONTINUE
CALL DSCAL( N, T, Z, 1 )
RHO = ABS( TWO*RHO )
*
* Sort the eigenvalues into increasing order
*
DO 20 I = CUTPNT + 1, N
INDXQ( I ) = INDXQ( I ) + CUTPNT
20 CONTINUE
DO 30 I = 1, N
DLAMDA( I ) = D( INDXQ( I ) )
W( I ) = Z( INDXQ( I ) )
30 CONTINUE
I = 1
J = CUTPNT + 1
CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDX )
DO 40 I = 1, N
D( I ) = DLAMDA( INDX( I ) )
Z( I ) = W( INDX( I ) )
40 CONTINUE
*
* Calculate the allowable deflation tolerence
*
IMAX = IDAMAX( N, Z, 1 )
JMAX = IDAMAX( N, D, 1 )
EPS = DLAMCH( 'Epsilon' )
TOL = EIGHT*EPS*ABS( D( JMAX ) )
*
* If the rank-1 modifier is small enough, no more needs to be done
* except to reorganize Q so that its columns correspond with the
* elements in D.
*
IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN
K = 0
IF( ICOMPQ.EQ.0 ) THEN
DO 50 J = 1, N
PERM( J ) = INDXQ( INDX( J ) )
50 CONTINUE
ELSE
DO 60 J = 1, N
PERM( J ) = INDXQ( INDX( J ) )
CALL DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
60 CONTINUE
CALL DLACPY( 'A', QSIZ, N, Q2( 1, 1 ), LDQ2, Q( 1, 1 ),
$ LDQ )
END IF
RETURN
END IF
*
* If there are multiple eigenvalues then the problem deflates. Here
* the number of equal eigenvalues are found. As each equal
* eigenvalue is found, an elementary reflector is computed to rotate
* the corresponding eigensubspace so that the corresponding
* components of Z are zero in this new basis.
*
K = 0
GIVPTR = 0
K2 = N + 1
DO 70 J = 1, N
OPS = OPS + 1
IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
INDXP( K2 ) = J
IF( J.EQ.N )
$ GO TO 110
ELSE
JLAM = J
GO TO 80
END IF
70 CONTINUE
80 CONTINUE
J = J + 1
IF( J.GT.N )
$ GO TO 100
OPS = OPS + 1
IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
INDXP( K2 ) = J
ELSE
*
* Check if eigenvalues are close enough to allow deflation.
*
S = Z( JLAM )
C = Z( J )
*
* Find sqrt(a**2+b**2) without overflow or
* destructive underflow.
*
OPS = OPS + 10
TAU = DLAPY2( C, S )
T = D( J ) - D( JLAM )
C = C / TAU
S = -S / TAU
IF( ABS( T*C*S ).LE.TOL ) THEN
*
* Deflation is possible.
*
Z( J ) = TAU
Z( JLAM ) = ZERO
*
* Record the appropriate Givens rotation
*
GIVPTR = GIVPTR + 1
GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) )
GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) )
GIVNUM( 1, GIVPTR ) = C
GIVNUM( 2, GIVPTR ) = S
IF( ICOMPQ.EQ.1 ) THEN
OPS = OPS + 6*QSIZ
CALL DROT( QSIZ, Q( 1, INDXQ( INDX( JLAM ) ) ), 1,
$ Q( 1, INDXQ( INDX( J ) ) ), 1, C, S )
END IF
OPS = OPS + 10
T = D( JLAM )*C*C + D( J )*S*S
D( J ) = D( JLAM )*S*S + D( J )*C*C
D( JLAM ) = T
K2 = K2 - 1
I = 1
90 CONTINUE
IF( K2+I.LE.N ) THEN
IF( D( JLAM ).LT.D( INDXP( K2+I ) ) ) THEN
INDXP( K2+I-1 ) = INDXP( K2+I )
INDXP( K2+I ) = JLAM
I = I + 1
GO TO 90
ELSE
INDXP( K2+I-1 ) = JLAM
END IF
ELSE
INDXP( K2+I-1 ) = JLAM
END IF
JLAM = J
ELSE
K = K + 1
W( K ) = Z( JLAM )
DLAMDA( K ) = D( JLAM )
INDXP( K ) = JLAM
JLAM = J
END IF
END IF
GO TO 80
100 CONTINUE
*
* Record the last eigenvalue.
*
K = K + 1
W( K ) = Z( JLAM )
DLAMDA( K ) = D( JLAM )
INDXP( K ) = JLAM
*
110 CONTINUE
*
* Sort the eigenvalues and corresponding eigenvectors into DLAMDA
* and Q2 respectively. The eigenvalues/vectors which were not
* deflated go into the first K slots of DLAMDA and Q2 respectively,
* while those which were deflated go into the last N - K slots.
*
IF( ICOMPQ.EQ.0 ) THEN
DO 120 J = 1, N
JP = INDXP( J )
DLAMDA( J ) = D( JP )
PERM( J ) = INDXQ( INDX( JP ) )
120 CONTINUE
ELSE
DO 130 J = 1, N
JP = INDXP( J )
DLAMDA( J ) = D( JP )
PERM( J ) = INDXQ( INDX( JP ) )
CALL DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
130 CONTINUE
END IF
*
* The deflated eigenvalues and their corresponding vectors go back
* into the last N - K slots of D and Q respectively.
*
IF( K.LT.N ) THEN
IF( ICOMPQ.EQ.0 ) THEN
CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )
ELSE
CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )
CALL DLACPY( 'A', QSIZ, N-K, Q2( 1, K+1 ), LDQ2,
$ Q( 1, K+1 ), LDQ )
END IF
END IF
*
RETURN
*
* End of DLAED8
*
END
SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W,
$ S, LDS, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
* Courant Institute, NAG Ltd., and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N
DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ),
$ W( * )
* ..
* Common block to return operation count and iteration count
* ITCNT is unchanged, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLAED9 finds the roots of the secular equation, as defined by the
* values in D, Z, and RHO, between KSTART and KSTOP. It makes the
* appropriate calls to DLAED4 and then stores the new matrix of
* eigenvectors for use in calculating the next level of Z vectors.
*
* Arguments
* =========
*
* K (input) INTEGER
* The number of terms in the rational function to be solved by
* DLAED4. K >= 0.
*
* KSTART (input) INTEGER
* KSTOP (input) INTEGER
* The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP
* are to be computed. 1 <= KSTART <= KSTOP <= K.
*
* N (input) INTEGER
* The number of rows and columns in the Q matrix.
* N >= K (delation may result in N > K).
*
* D (output) DOUBLE PRECISION array, dimension (N)
* D(I) contains the updated eigenvalues
* for KSTART <= I <= KSTOP.
*
* Q (workspace) DOUBLE PRECISION array, dimension (LDQ,N)
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max( 1, N ).
*
* RHO (input) DOUBLE PRECISION
* The value of the parameter in the rank one update equation.
* RHO >= 0 required.
*
* DLAMDA (input) DOUBLE PRECISION array, dimension (K)
* The first K elements of this array contain the old roots
* of the deflated updating problem. These are the poles
* of the secular equation.
*
* W (input) DOUBLE PRECISION array, dimension (K)
* The first K elements of this array contain the components
* of the deflation-adjusted updating vector.
*
* S (output) DOUBLE PRECISION array, dimension (LDS, K)
* Will contain the eigenvectors of the repaired matrix which
* will be stored for subsequent Z vector calculation and
* multiplied by the previously accumulated eigenvectors
* to update the system.
*
* LDS (input) INTEGER
* The leading dimension of S. LDS >= max( 1, K ).
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an eigenvalue did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION TEMP
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMC3, DNRM2
EXTERNAL DLAMC3, DNRM2
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLAED4, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( K.LT.0 ) THEN
INFO = -1
ELSE IF( KSTART.LT.1 .OR. KSTART.GT.MAX( 1, K ) ) THEN
INFO = -2
ELSE IF( MAX( 1, KSTOP ).LT.KSTART .OR. KSTOP.GT.MAX( 1, K ) )
$ THEN
INFO = -3
ELSE IF( N.LT.K ) THEN
INFO = -4
ELSE IF( LDQ.LT.MAX( 1, K ) ) THEN
INFO = -7
ELSE IF( LDS.LT.MAX( 1, K ) ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAED9', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( K.EQ.0 )
$ RETURN
*
* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
* be computed with high relative accuracy (barring over/underflow).
* This is a problem on machines without a guard digit in
* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
* which on any of these machines zeros out the bottommost
* bit of DLAMDA(I) if it is 1; this makes the subsequent
* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
* occurs. On binary machines with a guard digit (almost all
* machines) it does not change DLAMDA(I) at all. On hexadecimal
* and decimal machines with a guard digit, it slightly
* changes the bottommost bits of DLAMDA(I). It does not account
* for hexadecimal or decimal machines without guard digits
* (we know of none). We use a subroutine call to compute
* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating
* this code.
*
OPS = OPS + 2*N
DO 10 I = 1, N
DLAMDA( I ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I )
10 CONTINUE
*
DO 20 J = KSTART, KSTOP
CALL DLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO )
*
* If the zero finder fails, the computation is terminated.
*
IF( INFO.NE.0 )
$ GO TO 120
20 CONTINUE
*
IF( K.EQ.1 .OR. K.EQ.2 ) THEN
DO 40 I = 1, K
DO 30 J = 1, K
S( J, I ) = Q( J, I )
30 CONTINUE
40 CONTINUE
GO TO 120
END IF
*
* Compute updated W.
*
CALL DCOPY( K, W, 1, S, 1 )
*
* Initialize W(I) = Q(I,I)
*
CALL DCOPY( K, Q, LDQ+1, W, 1 )
OPS = OPS + 3*K*( K-1 ) + K
DO 70 J = 1, K
DO 50 I = 1, J - 1
W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
50 CONTINUE
DO 60 I = J + 1, K
W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
60 CONTINUE
70 CONTINUE
DO 80 I = 1, K
W( I ) = SIGN( SQRT( -W( I ) ), S( I, 1 ) )
80 CONTINUE
*
* Compute eigenvectors of the modified rank-1 modification.
*
OPS = OPS + 4*K*K
DO 110 J = 1, K
DO 90 I = 1, K
Q( I, J ) = W( I ) / Q( I, J )
90 CONTINUE
TEMP = DNRM2( K, Q( 1, J ), 1 )
DO 100 I = 1, K
S( I, J ) = Q( I, J ) / TEMP
100 CONTINUE
110 CONTINUE
*
120 CONTINUE
RETURN
*
* End of DLAED9
*
END
SUBROUTINE DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,
$ GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
INTEGER CURLVL, CURPBM, INFO, N, TLVLS
* ..
* .. Array Arguments ..
INTEGER GIVCOL( 2, * ), GIVPTR( * ), PERM( * ),
$ PRMPTR( * ), QPTR( * )
DOUBLE PRECISION GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * )
* ..
* Common block to return operation count and iteration count
* ITCNT is unchanged, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLAEDA computes the Z vector corresponding to the merge step in the
* CURLVLth step of the merge process with TLVLS steps for the CURPBMth
* problem.
*
* Arguments
* =========
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* TLVLS (input) INTEGER
* The total number of merging levels in the overall divide and
* conquer tree.
*
* CURLVL (input) INTEGER
* The current level in the overall merge routine,
* 0 <= curlvl <= tlvls.
*
* CURPBM (input) INTEGER
* The current problem in the current level in the overall
* merge routine (counting from upper left to lower right).
*
* PRMPTR (input) INTEGER array, dimension (N lg N)
* Contains a list of pointers which indicate where in PERM a
* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)
* indicates the size of the permutation and incidentally the
* size of the full, non-deflated problem.
*
* PERM (input) INTEGER array, dimension (N lg N)
* Contains the permutations (from deflation and sorting) to be
* applied to each eigenblock.
*
* GIVPTR (input) INTEGER array, dimension (N lg N)
* Contains a list of pointers which indicate where in GIVCOL a
* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)
* indicates the number of Givens rotations.
*
* GIVCOL (input) INTEGER array, dimension (2, N lg N)
* Each pair of numbers indicates a pair of columns to take place
* in a Givens rotation.
*
* GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N)
* Each number indicates the S value to be used in the
* corresponding Givens rotation.
*
* Q (input) DOUBLE PRECISION array, dimension (N**2)
* Contains the square eigenblocks from previous levels, the
* starting positions for blocks are given by QPTR.
*
* QPTR (input) INTEGER array, dimension (N+2)
* Contains a list of pointers which indicate where in Q an
* eigenblock is stored. SQRT( QPTR(i+1) - QPTR(i) ) indicates
* the size of the block.
*
* Z (output) DOUBLE PRECISION array, dimension (N)
* On output this vector contains the updating vector (the last
* row of the first sub-eigenvector matrix and the first row of
* the second sub-eigenvector matrix).
*
* ZTEMP (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
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
INTEGER BSIZ1, BSIZ2, CURR, I, K, MID, PSIZ1, PSIZ2,
$ PTR, ZPTR1
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMV, DROT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, INT, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( N.LT.0 ) THEN
INFO = -1
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAEDA', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Determine location of first number in second half.
*
MID = N / 2 + 1
*
* Gather last/first rows of appropriate eigenblocks into center of Z
*
PTR = 1
*
* Determine location of lowest level subproblem in the full storage
* scheme
*
CURR = PTR + CURPBM*2**CURLVL + 2**( CURLVL-1 ) - 1
*
* Determine size of these matrices. We add HALF to the value of
* the SQRT in case the machine underestimates one of these square
* roots.
*
OPS = OPS + 8
BSIZ1 = INT( HALF+SQRT( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) )
BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+1 ) ) ) )
DO 10 K = 1, MID - BSIZ1 - 1
Z( K ) = ZERO
10 CONTINUE
CALL DCOPY( BSIZ1, Q( QPTR( CURR )+BSIZ1-1 ), BSIZ1,
$ Z( MID-BSIZ1 ), 1 )
CALL DCOPY( BSIZ2, Q( QPTR( CURR+1 ) ), BSIZ2, Z( MID ), 1 )
DO 20 K = MID + BSIZ2, N
Z( K ) = ZERO
20 CONTINUE
*
* Loop thru remaining levels 1 -> CURLVL applying the Givens
* rotations and permutation and then multiplying the center matrices
* against the current Z.
*
PTR = 2**TLVLS + 1
DO 70 K = 1, CURLVL - 1
CURR = PTR + CURPBM*2**( CURLVL-K ) + 2**( CURLVL-K-1 ) - 1
PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR )
PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 )
ZPTR1 = MID - PSIZ1
*
* Apply Givens at CURR and CURR+1
*
OPS = OPS + 6*( GIVPTR( CURR+2 )-GIVPTR( CURR ) )
DO 30 I = GIVPTR( CURR ), GIVPTR( CURR+1 ) - 1
CALL DROT( 1, Z( ZPTR1+GIVCOL( 1, I )-1 ), 1,
$ Z( ZPTR1+GIVCOL( 2, I )-1 ), 1, GIVNUM( 1, I ),
$ GIVNUM( 2, I ) )
30 CONTINUE
DO 40 I = GIVPTR( CURR+1 ), GIVPTR( CURR+2 ) - 1
CALL DROT( 1, Z( MID-1+GIVCOL( 1, I ) ), 1,
$ Z( MID-1+GIVCOL( 2, I ) ), 1, GIVNUM( 1, I ),
$ GIVNUM( 2, I ) )
40 CONTINUE
PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR )
PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 )
DO 50 I = 0, PSIZ1 - 1
ZTEMP( I+1 ) = Z( ZPTR1+PERM( PRMPTR( CURR )+I )-1 )
50 CONTINUE
DO 60 I = 0, PSIZ2 - 1
ZTEMP( PSIZ1+I+1 ) = Z( MID+PERM( PRMPTR( CURR+1 )+I )-1 )
60 CONTINUE
*
* Multiply Blocks at CURR and CURR+1
*
* Determine size of these matrices. We add HALF to the value of
* the SQRT in case the machine underestimates one of these
* square roots.
*
OPS = OPS + 8
BSIZ1 = INT( HALF+SQRT( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) )
BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+
$ 1 ) ) ) )
IF( BSIZ1.GT.0 ) THEN
OPS = OPS + 2*BSIZ1*BSIZ1
CALL DGEMV( 'T', BSIZ1, BSIZ1, ONE, Q( QPTR( CURR ) ),
$ BSIZ1, ZTEMP( 1 ), 1, ZERO, Z( ZPTR1 ), 1 )
END IF
CALL DCOPY( PSIZ1-BSIZ1, ZTEMP( BSIZ1+1 ), 1, Z( ZPTR1+BSIZ1 ),
$ 1 )
IF( BSIZ2.GT.0 ) THEN
OPS = OPS + 2*BSIZ2*BSIZ2
CALL DGEMV( 'T', BSIZ2, BSIZ2, ONE, Q( QPTR( CURR+1 ) ),
$ BSIZ2, ZTEMP( PSIZ1+1 ), 1, ZERO, Z( MID ), 1 )
END IF
CALL DCOPY( PSIZ2-BSIZ2, ZTEMP( PSIZ1+BSIZ2+1 ), 1,
$ Z( MID+BSIZ2 ), 1 )
*
PTR = PTR + 2**( TLVLS-K )
70 CONTINUE
*
RETURN
*
* End of DLAEDA
*
END
SUBROUTINE DLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B,
$ LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO )
*
* -- LAPACK auxiliary routine (instrumented to count operations) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
LOGICAL NOINIT, RIGHTV
INTEGER INFO, LDB, LDH, N
DOUBLE PRECISION BIGNUM, EPS3, SMLNUM, WI, WR
* ..
* .. Array Arguments ..
DOUBLE PRECISION B( LDB, * ), H( LDH, * ), VI( * ), VR( * ),
$ WORK( * )
* ..
* Common block to return operation count.
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLAEIN uses inverse iteration to find a right or left eigenvector
* corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg
* matrix H.
*
* Arguments
* =========
*
* RIGHTV (input) LOGICAL
* = .TRUE. : compute right eigenvector;
* = .FALSE.: compute left eigenvector.
*
* NOINIT (input) LOGICAL
* = .TRUE. : no initial vector supplied in (VR,VI).
* = .FALSE.: initial vector supplied in (VR,VI).
*
* N (input) INTEGER
* The order of the matrix H. N >= 0.
*
* H (input) DOUBLE PRECISION array, dimension (LDH,N)
* The upper Hessenberg matrix H.
*
* LDH (input) INTEGER
* The leading dimension of the array H. LDH >= max(1,N).
*
* WR (input) DOUBLE PRECISION
* WI (input) DOUBLE PRECISION
* The real and imaginary parts of the eigenvalue of H whose
* corresponding right or left eigenvector is to be computed.
*
* VR (input/output) DOUBLE PRECISION array, dimension (N)
* VI (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain
* a real starting vector for inverse iteration using the real
* eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI
* must contain the real and imaginary parts of a complex
* starting vector for inverse iteration using the complex
* eigenvalue (WR,WI); otherwise VR and VI need not be set.
* On exit, if WI = 0.0 (real eigenvalue), VR contains the
* computed real eigenvector; if WI.ne.0.0 (complex eigenvalue),
* VR and VI contain the real and imaginary parts of the
* computed complex eigenvector. The eigenvector is normalized
* so that the component of largest magnitude has magnitude 1;
* here the magnitude of a complex number (x,y) is taken to be
* |x| + |y|.
* VI is not referenced if WI = 0.0.
*
* B (workspace) DOUBLE PRECISION array, dimension (LDB,N)
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= N+1.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* EPS3 (input) DOUBLE PRECISION
* A small machine-dependent value which is used to perturb
* close eigenvalues, and to replace zero pivots.
*
* SMLNUM (input) DOUBLE PRECISION
* A machine-dependent value close to the underflow threshold.
*
* BIGNUM (input) DOUBLE PRECISION
* A machine-dependent value close to the overflow threshold.
*
* INFO (output) INTEGER
* = 0: successful exit
* = 1: inverse iteration did not converge; VR is set to the
* last iterate, and so is VI if WI.ne.0.0.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TENTH
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TENTH = 1.0D-1 )
* ..
* .. Local Scalars ..
CHARACTER NORMIN, TRANS
INTEGER I, I1, I2, I3, IERR, ITS, J
DOUBLE PRECISION ABSBII, ABSBJJ, EI, EJ, GROWTO, NORM, NRMSML,
$ OPST, REC, ROOTN, SCALE, TEMP, VCRIT, VMAX,
$ VNORM, W, W1, X, XI, XR, Y
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DASUM, DLAPY2, DNRM2
EXTERNAL IDAMAX, DASUM, DLAPY2, DNRM2
* ..
* .. External Subroutines ..
EXTERNAL DLADIV, DLATRS, DSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
***
* Initialize
OPST = 0
***
*
* GROWTO is the threshold used in the acceptance test for an
* eigenvector.
*
ROOTN = SQRT( DBLE( N ) )
GROWTO = TENTH / ROOTN
NRMSML = MAX( ONE, EPS3*ROOTN )*SMLNUM
***
* Increment op count for computing ROOTN, GROWTO and NRMSML
OPST = OPST + 4
***
*
* Form B = H - (WR,WI)*I (except that the subdiagonal elements and
* the imaginary parts of the diagonal elements are not stored).
*
DO 20 J = 1, N
DO 10 I = 1, J - 1
B( I, J ) = H( I, J )
10 CONTINUE
B( J, J ) = H( J, J ) - WR
20 CONTINUE
***
OPST = OPST + N
***
*
IF( WI.EQ.ZERO ) THEN
*
* Real eigenvalue.
*
IF( NOINIT ) THEN
*
* Set initial vector.
*
DO 30 I = 1, N
VR( I ) = EPS3
30 CONTINUE
ELSE
*
* Scale supplied initial vector.
*
VNORM = DNRM2( N, VR, 1 )
CALL DSCAL( N, ( EPS3*ROOTN ) / MAX( VNORM, NRMSML ), VR,
$ 1 )
***
OPST = OPST + ( 3*N+2 )
***
END IF
*
IF( RIGHTV ) THEN
*
* LU decomposition with partial pivoting of B, replacing zero
* pivots by EPS3.
*
DO 60 I = 1, N - 1
EI = H( I+1, I )
IF( ABS( B( I, I ) ).LT.ABS( EI ) ) THEN
*
* Interchange rows and eliminate.
*
X = B( I, I ) / EI
B( I, I ) = EI
DO 40 J = I + 1, N
TEMP = B( I+1, J )
B( I+1, J ) = B( I, J ) - X*TEMP
B( I, J ) = TEMP
40 CONTINUE
ELSE
*
* Eliminate without interchange.
*
IF( B( I, I ).EQ.ZERO )
$ B( I, I ) = EPS3
X = EI / B( I, I )
IF( X.NE.ZERO ) THEN
DO 50 J = I + 1, N
B( I+1, J ) = B( I+1, J ) - X*B( I, J )
50 CONTINUE
END IF
END IF
60 CONTINUE
IF( B( N, N ).EQ.ZERO )
$ B( N, N ) = EPS3
***
* Increment op count for LU decomposition
OPS = OPS + ( N-1 )*( N+1 )
***
*
TRANS = 'N'
*
ELSE
*
* UL decomposition with partial pivoting of B, replacing zero
* pivots by EPS3.
*
DO 90 J = N, 2, -1
EJ = H( J, J-1 )
IF( ABS( B( J, J ) ).LT.ABS( EJ ) ) THEN
*
* Interchange columns and eliminate.
*
X = B( J, J ) / EJ
B( J, J ) = EJ
DO 70 I = 1, J - 1
TEMP = B( I, J-1 )
B( I, J-1 ) = B( I, J ) - X*TEMP
B( I, J ) = TEMP
70 CONTINUE
ELSE
*
* Eliminate without interchange.
*
IF( B( J, J ).EQ.ZERO )
$ B( J, J ) = EPS3
X = EJ / B( J, J )
IF( X.NE.ZERO ) THEN
DO 80 I = 1, J - 1
B( I, J-1 ) = B( I, J-1 ) - X*B( I, J )
80 CONTINUE
END IF
END IF
90 CONTINUE
IF( B( 1, 1 ).EQ.ZERO )
$ B( 1, 1 ) = EPS3
***
* Increment op count for UL decomposition
OPS = OPS + ( N-1 )*( N+1 )
***
*
TRANS = 'T'
*
END IF
*
NORMIN = 'N'
DO 110 ITS = 1, N
*
* Solve U*x = scale*v for a right eigenvector
* or U'*x = scale*v for a left eigenvector,
* overwriting x on v.
*
CALL DLATRS( 'Upper', TRANS, 'Nonunit', NORMIN, N, B, LDB,
$ VR, SCALE, WORK, IERR )
***
* Increment opcount for triangular solver, assuming that
* ops DLATRS = ops DTRSV, with no scaling in DLATRS.
OPS = OPS + N*N
***
NORMIN = 'Y'
*
* Test for sufficient growth in the norm of v.
*
VNORM = DASUM( N, VR, 1 )
***
OPST = OPST + N
***
IF( VNORM.GE.GROWTO*SCALE )
$ GO TO 120
*
* Choose new orthogonal starting vector and try again.
*
TEMP = EPS3 / ( ROOTN+ONE )
VR( 1 ) = EPS3
DO 100 I = 2, N
VR( I ) = TEMP
100 CONTINUE
VR( N-ITS+1 ) = VR( N-ITS+1 ) - EPS3*ROOTN
***
OPST = OPST + 4
***
110 CONTINUE
*
* Failure to find eigenvector in N iterations.
*
INFO = 1
*
120 CONTINUE
*
* Normalize eigenvector.
*
I = IDAMAX( N, VR, 1 )
CALL DSCAL( N, ONE / ABS( VR( I ) ), VR, 1 )
***
OPST = OPST + ( 2*N+1 )
***
ELSE
*
* Complex eigenvalue.
*
IF( NOINIT ) THEN
*
* Set initial vector.
*
DO 130 I = 1, N
VR( I ) = EPS3
VI( I ) = ZERO
130 CONTINUE
ELSE
*
* Scale supplied initial vector.
*
NORM = DLAPY2( DNRM2( N, VR, 1 ), DNRM2( N, VI, 1 ) )
REC = ( EPS3*ROOTN ) / MAX( NORM, NRMSML )
CALL DSCAL( N, REC, VR, 1 )
CALL DSCAL( N, REC, VI, 1 )
***
OPST = OPST + ( 6*N+5 )
***
END IF
*
IF( RIGHTV ) THEN
*
* LU decomposition with partial pivoting of B, replacing zero
* pivots by EPS3.
*
* The imaginary part of the (i,j)-th element of U is stored in
* B(j+1,i).
*
B( 2, 1 ) = -WI
DO 140 I = 2, N
B( I+1, 1 ) = ZERO
140 CONTINUE
*
DO 170 I = 1, N - 1
ABSBII = DLAPY2( B( I, I ), B( I+1, I ) )
EI = H( I+1, I )
IF( ABSBII.LT.ABS( EI ) ) THEN
*
* Interchange rows and eliminate.
*
XR = B( I, I ) / EI
XI = B( I+1, I ) / EI
B( I, I ) = EI
B( I+1, I ) = ZERO
DO 150 J = I + 1, N
TEMP = B( I+1, J )
B( I+1, J ) = B( I, J ) - XR*TEMP
B( J+1, I+1 ) = B( J+1, I ) - XI*TEMP
B( I, J ) = TEMP
B( J+1, I ) = ZERO
150 CONTINUE
B( I+2, I ) = -WI
B( I+1, I+1 ) = B( I+1, I+1 ) - XI*WI
B( I+2, I+1 ) = B( I+2, I+1 ) + XR*WI
***
OPST = OPST + ( 4*( N-I )+6 )
***
ELSE
*
* Eliminate without interchanging rows.
*
IF( ABSBII.EQ.ZERO ) THEN
B( I, I ) = EPS3
B( I+1, I ) = ZERO
ABSBII = EPS3
END IF
EI = ( EI / ABSBII ) / ABSBII
XR = B( I, I )*EI
XI = -B( I+1, I )*EI
DO 160 J = I + 1, N
B( I+1, J ) = B( I+1, J ) - XR*B( I, J ) +
$ XI*B( J+1, I )
B( J+1, I+1 ) = -XR*B( J+1, I ) - XI*B( I, J )
160 CONTINUE
B( I+2, I+1 ) = B( I+2, I+1 ) - WI
***
OPST = OPST + ( 7*( N-I )+4 )
***
END IF
*
* Compute 1-norm of offdiagonal elements of i-th row.
*
WORK( I ) = DASUM( N-I, B( I, I+1 ), LDB ) +
$ DASUM( N-I, B( I+2, I ), 1 )
***
OPST = OPST + ( 2*( N-I )+4 )
***
170 CONTINUE
IF( B( N, N ).EQ.ZERO .AND. B( N+1, N ).EQ.ZERO )
$ B( N, N ) = EPS3
WORK( N ) = ZERO
*
I1 = N
I2 = 1
I3 = -1
ELSE
*
* UL decomposition with partial pivoting of conjg(B),
* replacing zero pivots by EPS3.
*
* The imaginary part of the (i,j)-th element of U is stored in
* B(j+1,i).
*
B( N+1, N ) = WI
DO 180 J = 1, N - 1
B( N+1, J ) = ZERO
180 CONTINUE
*
DO 210 J = N, 2, -1
EJ = H( J, J-1 )
ABSBJJ = DLAPY2( B( J, J ), B( J+1, J ) )
IF( ABSBJJ.LT.ABS( EJ ) ) THEN
*
* Interchange columns and eliminate
*
XR = B( J, J ) / EJ
XI = B( J+1, J ) / EJ
B( J, J ) = EJ
B( J+1, J ) = ZERO
DO 190 I = 1, J - 1
TEMP = B( I, J-1 )
B( I, J-1 ) = B( I, J ) - XR*TEMP
B( J, I ) = B( J+1, I ) - XI*TEMP
B( I, J ) = TEMP
B( J+1, I ) = ZERO
190 CONTINUE
B( J+1, J-1 ) = WI
B( J-1, J-1 ) = B( J-1, J-1 ) + XI*WI
B( J, J-1 ) = B( J, J-1 ) - XR*WI
***
OPST = OPST + ( 4*( J-1 )+6 )
***
ELSE
*
* Eliminate without interchange.
*
IF( ABSBJJ.EQ.ZERO ) THEN
B( J, J ) = EPS3
B( J+1, J ) = ZERO
ABSBJJ = EPS3
END IF
EJ = ( EJ / ABSBJJ ) / ABSBJJ
XR = B( J, J )*EJ
XI = -B( J+1, J )*EJ
DO 200 I = 1, J - 1
B( I, J-1 ) = B( I, J-1 ) - XR*B( I, J ) +
$ XI*B( J+1, I )
B( J, I ) = -XR*B( J+1, I ) - XI*B( I, J )
200 CONTINUE
B( J, J-1 ) = B( J, J-1 ) + WI
***
OPST = OPST + ( 7*( J-1 )+4 )
***
END IF
*
* Compute 1-norm of offdiagonal elements of j-th column.
*
WORK( J ) = DASUM( J-1, B( 1, J ), 1 ) +
$ DASUM( J-1, B( J+1, 1 ), LDB )
***
OPST = OPST + ( 2*( J-1 )+4 )
***
210 CONTINUE
IF( B( 1, 1 ).EQ.ZERO .AND. B( 2, 1 ).EQ.ZERO )
$ B( 1, 1 ) = EPS3
WORK( 1 ) = ZERO
*
I1 = 1
I2 = N
I3 = 1
END IF
*
DO 270 ITS = 1, N
SCALE = ONE
VMAX = ONE
VCRIT = BIGNUM
*
* Solve U*(xr,xi) = scale*(vr,vi) for a right eigenvector,
* or U'*(xr,xi) = scale*(vr,vi) for a left eigenvector,
* overwriting (xr,xi) on (vr,vi).
*
DO 250 I = I1, I2, I3
*
IF( WORK( I ).GT.VCRIT ) THEN
REC = ONE / VMAX
CALL DSCAL( N, REC, VR, 1 )
CALL DSCAL( N, REC, VI, 1 )
SCALE = SCALE*REC
VMAX = ONE
VCRIT = BIGNUM
END IF
*
XR = VR( I )
XI = VI( I )
IF( RIGHTV ) THEN
DO 220 J = I + 1, N
XR = XR - B( I, J )*VR( J ) + B( J+1, I )*VI( J )
XI = XI - B( I, J )*VI( J ) - B( J+1, I )*VR( J )
220 CONTINUE
ELSE
DO 230 J = 1, I - 1
XR = XR - B( J, I )*VR( J ) + B( I+1, J )*VI( J )
XI = XI - B( J, I )*VI( J ) - B( I+1, J )*VR( J )
230 CONTINUE
END IF
*
W = ABS( B( I, I ) ) + ABS( B( I+1, I ) )
IF( W.GT.SMLNUM ) THEN
IF( W.LT.ONE ) THEN
W1 = ABS( XR ) + ABS( XI )
IF( W1.GT.W*BIGNUM ) THEN
REC = ONE / W1
CALL DSCAL( N, REC, VR, 1 )
CALL DSCAL( N, REC, VI, 1 )
XR = VR( I )
XI = VI( I )
SCALE = SCALE*REC
VMAX = VMAX*REC
END IF
END IF
*
* Divide by diagonal element of B.
*
CALL DLADIV( XR, XI, B( I, I ), B( I+1, I ), VR( I ),
$ VI( I ) )
VMAX = MAX( ABS( VR( I ) )+ABS( VI( I ) ), VMAX )
VCRIT = BIGNUM / VMAX
***
OPST = OPST + 9
***
ELSE
DO 240 J = 1, N
VR( J ) = ZERO
VI( J ) = ZERO
240 CONTINUE
VR( I ) = ONE
VI( I ) = ONE
SCALE = ZERO
VMAX = ONE
VCRIT = BIGNUM
END IF
250 CONTINUE
***
* Increment op count for loop 260, assuming no scaling
OPS = OPS + 4*N*( N-1 )
***
*
* Test for sufficient growth in the norm of (VR,VI).
*
VNORM = DASUM( N, VR, 1 ) + DASUM( N, VI, 1 )
***
OPST = OPST + 2*N
***
IF( VNORM.GE.GROWTO*SCALE )
$ GO TO 280
*
* Choose a new orthogonal starting vector and try again.
*
Y = EPS3 / ( ROOTN+ONE )
VR( 1 ) = EPS3
VI( 1 ) = ZERO
*
DO 260 I = 2, N
VR( I ) = Y
VI( I ) = ZERO
260 CONTINUE
VR( N-ITS+1 ) = VR( N-ITS+1 ) - EPS3*ROOTN
***
OPST = OPST + 4
***
270 CONTINUE
*
* Failure to find eigenvector in N iterations
*
INFO = 1
*
280 CONTINUE
*
* Normalize eigenvector.
*
VNORM = ZERO
DO 290 I = 1, N
VNORM = MAX( VNORM, ABS( VR( I ) )+ABS( VI( I ) ) )
290 CONTINUE
CALL DSCAL( N, ONE / VNORM, VR, 1 )
CALL DSCAL( N, ONE / VNORM, VI, 1 )
***
OPST = OPST + ( 4*N+1 )
***
*
END IF
*
***
* Compute final op count
OPS = OPS + OPST
***
RETURN
*
* End of DLAEIN
*
END
SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
$ ILOZ, IHIZ, Z, LDZ, INFO )
*
* -- LAPACK auxiliary routine (instrum. to count ops. version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
LOGICAL WANTT, WANTZ
INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * )
* ..
* Common block to return operation count.
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLAHQR is an auxiliary routine called by DHSEQR to update the
* eigenvalues and Schur decomposition already computed by DHSEQR, by
* dealing with the Hessenberg submatrix in rows and columns ILO to IHI.
*
* Arguments
* =========
*
* WANTT (input) LOGICAL
* = .TRUE. : the full Schur form T is required;
* = .FALSE.: only eigenvalues are required.
*
* WANTZ (input) LOGICAL
* = .TRUE. : the matrix of Schur vectors Z is required;
* = .FALSE.: Schur vectors are not required.
*
* N (input) INTEGER
* The order of the matrix H. N >= 0.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* It is assumed that H is already upper quasi-triangular in
* rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless
* ILO = 1). DLAHQR works primarily with the Hessenberg
* submatrix in rows and columns ILO to IHI, but applies
* transformations to all of H if WANTT is .TRUE..
* 1 <= ILO <= max(1,IHI); IHI <= N.
*
* H (input/output) DOUBLE PRECISION array, dimension (LDH,N)
* On entry, the upper Hessenberg matrix H.
* On exit, if WANTT is .TRUE., H is upper quasi-triangular in
* rows and columns ILO:IHI, with any 2-by-2 diagonal blocks in
* standard form. If WANTT is .FALSE., the contents of H are
* unspecified on exit.
*
* LDH (input) INTEGER
* The leading dimension of the array H. LDH >= max(1,N).
*
* WR (output) DOUBLE PRECISION array, dimension (N)
* WI (output) DOUBLE PRECISION array, dimension (N)
* The real and imaginary parts, respectively, of the computed
* eigenvalues ILO to IHI are stored in the corresponding
* elements of WR and WI. If two eigenvalues are computed as a
* complex conjugate pair, they are stored in consecutive
* elements of WR and WI, say the i-th and (i+1)th, with
* WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the
* eigenvalues are stored in the same order as on the diagonal
* of the Schur form returned in H, with WR(i) = H(i,i), and, if
* H(i:i+1,i:i+1) is a 2-by-2 diagonal block,
* WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i).
*
* ILOZ (input) INTEGER
* IHIZ (input) INTEGER
* Specify the rows of Z to which transformations must be
* applied if WANTZ is .TRUE..
* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
*
* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
* If WANTZ is .TRUE., on entry Z must contain the current
* matrix Z of transformations accumulated by DHSEQR, and on
* exit Z has been updated; transformations are applied only to
* the submatrix Z(ILOZ:IHIZ,ILO:IHI).
* If WANTZ is .FALSE., Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* > 0: DLAHQR failed to compute all the eigenvalues ILO to IHI
* in a total of 30*(IHI-ILO+1) iterations; if INFO = i,
* elements i+1:ihi of WR and WI contain those eigenvalues
* which have been successfully computed.
*
* Further Details
* ===============
*
* 2-96 Based on modifications by
* David Day, Sandia National Laboratory, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, HALF
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D0 )
DOUBLE PRECISION DAT1, DAT2
PARAMETER ( DAT1 = 0.75D+0, DAT2 = -0.4375D+0 )
* ..
* .. Local Scalars ..
INTEGER I, I1, I2, ITN, ITS, J, K, L, M, NH, NR, NZ
DOUBLE PRECISION AVE, CS, DISC, H00, H10, H11, H12, H21, H22,
$ H33, H33S, H43H34, H44, H44S, OPST, OVFL, S,
$ SMLNUM, SN, SUM, T1, T2, T3, TST1, ULP, UNFL,
$ V1, V2, V3
* ..
* .. Local Arrays ..
DOUBLE PRECISION V( 3 ), WORK( 1 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANHS
EXTERNAL DLAMCH, DLANHS
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLABAD, DLANV2, DLARFG, DROT
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SIGN, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
***
* Initialize
OPST = 0
***
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
IF( ILO.EQ.IHI ) THEN
WR( ILO ) = H( ILO, ILO )
WI( ILO ) = ZERO
RETURN
END IF
*
NH = IHI - ILO + 1
NZ = IHIZ - ILOZ + 1
*
* Set machine-dependent constants for the stopping criterion.
* If norm(H) <= sqrt(OVFL), overflow should not occur.
*
UNFL = DLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
CALL DLABAD( UNFL, OVFL )
ULP = DLAMCH( 'Precision' )
SMLNUM = UNFL*( NH / ULP )
*
* I1 and I2 are the indices of the first row and last column of H
* to which transformations must be applied. If eigenvalues only are
* being computed, I1 and I2 are set inside the main loop.
*
IF( WANTT ) THEN
I1 = 1
I2 = N
END IF
*
* ITN is the total number of QR iterations allowed.
*
ITN = 30*NH
*
* The main loop begins here. I is the loop index and decreases from
* IHI to ILO in steps of 1 or 2. Each iteration of the loop works
* with the active submatrix in rows and columns L to I.
* Eigenvalues I+1 to IHI have already converged. Either L = ILO or
* H(L,L-1) is negligible so that the matrix splits.
*
I = IHI
10 CONTINUE
L = ILO
IF( I.LT.ILO )
$ GO TO 150
*
* Perform QR iterations on rows and columns ILO to I until a
* submatrix of order 1 or 2 splits off at the bottom because a
* subdiagonal element has become negligible.
*
DO 130 ITS = 0, ITN
*
* Look for a single small subdiagonal element.
*
DO 20 K = I, L + 1, -1
TST1 = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) )
IF( TST1.EQ.ZERO ) THEN
TST1 = DLANHS( '1', I-L+1, H( L, L ), LDH, WORK )
***
* Increment op count
OPS = OPS + ( I-L+1 )*( I-L+2 ) / 2
***
END IF
IF( ABS( H( K, K-1 ) ).LE.MAX( ULP*TST1, SMLNUM ) )
$ GO TO 30
20 CONTINUE
30 CONTINUE
L = K
***
* Increment op count
OPST = OPST + 3*( I-L+1 )
***
IF( L.GT.ILO ) THEN
*
* H(L,L-1) is negligible
*
H( L, L-1 ) = ZERO
END IF
*
* Exit from loop if a submatrix of order 1 or 2 has split off.
*
IF( L.GE.I-1 )
$ GO TO 140
*
* Now the active submatrix is in rows and columns L to I. If
* eigenvalues only are being computed, only the active submatrix
* need be transformed.
*
IF( .NOT.WANTT ) THEN
I1 = L
I2 = I
END IF
*
IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN
*
* Exceptional shift.
*
S = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) )
H44 = DAT1*S + H( I, I )
H33 = H44
H43H34 = DAT2*S*S
***
* Increment op count
OPST = OPST + 5
***
ELSE
*
* Prepare to use Francis' double shift
* (i.e. 2nd degree generalized Rayleigh quotient)
*
H44 = H( I, I )
H33 = H( I-1, I-1 )
H43H34 = H( I, I-1 )*H( I-1, I )
S = H( I-1, I-2 )*H( I-1, I-2 )
DISC = ( H33-H44 )*HALF
DISC = DISC*DISC + H43H34
***
* Increment op count
OPST = OPST + 6
***
IF( DISC.GT.ZERO ) THEN
*
* Real roots: use Wilkinson's shift twice
*
DISC = SQRT( DISC )
AVE = HALF*( H33+H44 )
***
* Increment op count
OPST = OPST + 2
***
IF( ABS( H33 )-ABS( H44 ).GT.ZERO ) THEN
H33 = H33*H44 - H43H34
H44 = H33 / ( SIGN( DISC, AVE )+AVE )
***
* Increment op count
OPST = OPST + 4
***
ELSE
H44 = SIGN( DISC, AVE ) + AVE
***
* Increment op count
OPST = OPST + 1
***
END IF
H33 = H44
H43H34 = ZERO
END IF
END IF
*
* Look for two consecutive small subdiagonal elements.
*
DO 40 M = I - 2, L, -1
*
* Determine the effect of starting the double-shift QR
* iteration at row M, and see if this would make H(M,M-1)
* negligible.
*
H11 = H( M, M )
H22 = H( M+1, M+1 )
H21 = H( M+1, M )
H12 = H( M, M+1 )
H44S = H44 - H11
H33S = H33 - H11
V1 = ( H33S*H44S-H43H34 ) / H21 + H12
V2 = H22 - H11 - H33S - H44S
V3 = H( M+2, M+1 )
S = ABS( V1 ) + ABS( V2 ) + ABS( V3 )
V1 = V1 / S
V2 = V2 / S
V3 = V3 / S
V( 1 ) = V1
V( 2 ) = V2
V( 3 ) = V3
IF( M.EQ.L )
$ GO TO 50
H00 = H( M-1, M-1 )
H10 = H( M, M-1 )
TST1 = ABS( V1 )*( ABS( H00 )+ABS( H11 )+ABS( H22 ) )
IF( ABS( H10 )*( ABS( V2 )+ABS( V3 ) ).LE.ULP*TST1 )
$ GO TO 50
40 CONTINUE
50 CONTINUE
***
* Increment op count
OPST = OPST + 20*( I-M-1 )
***
*
* Double-shift QR step
*
DO 120 K = M, I - 1
*
* The first iteration of this loop determines a reflection G
* from the vector V and applies it from left and right to H,
* thus creating a nonzero bulge below the subdiagonal.
*
* Each subsequent iteration determines a reflection G to
* restore the Hessenberg form in the (K-1)th column, and thus
* chases the bulge one step toward the bottom of the active
* submatrix. NR is the order of G.
*
NR = MIN( 3, I-K+1 )
IF( K.GT.M )
$ CALL DCOPY( NR, H( K, K-1 ), 1, V, 1 )
CALL DLARFG( NR, V( 1 ), V( 2 ), 1, T1 )
***
* Increment op count
OPST = OPST + 3*NR + 9
***
IF( K.GT.M ) THEN
H( K, K-1 ) = V( 1 )
H( K+1, K-1 ) = ZERO
IF( K.LT.I-1 )
$ H( K+2, K-1 ) = ZERO
ELSE IF( M.GT.L ) THEN
H( K, K-1 ) = -H( K, K-1 )
END IF
V2 = V( 2 )
T2 = T1*V2
IF( NR.EQ.3 ) THEN
V3 = V( 3 )
T3 = T1*V3
*
* Apply G from the left to transform the rows of the matrix
* in columns K to I2.
*
DO 60 J = K, I2
SUM = H( K, J ) + V2*H( K+1, J ) + V3*H( K+2, J )
H( K, J ) = H( K, J ) - SUM*T1
H( K+1, J ) = H( K+1, J ) - SUM*T2
H( K+2, J ) = H( K+2, J ) - SUM*T3
60 CONTINUE
*
* Apply G from the right to transform the columns of the
* matrix in rows I1 to min(K+3,I).
*
DO 70 J = I1, MIN( K+3, I )
SUM = H( J, K ) + V2*H( J, K+1 ) + V3*H( J, K+2 )
H( J, K ) = H( J, K ) - SUM*T1
H( J, K+1 ) = H( J, K+1 ) - SUM*T2
H( J, K+2 ) = H( J, K+2 ) - SUM*T3
70 CONTINUE
***
* Increment op count
OPS = OPS + 10*( I2-I1+2+MIN( 3, I-K ) )
***
*
IF( WANTZ ) THEN
*
* Accumulate transformations in the matrix Z
*
DO 80 J = ILOZ, IHIZ
SUM = Z( J, K ) + V2*Z( J, K+1 ) + V3*Z( J, K+2 )
Z( J, K ) = Z( J, K ) - SUM*T1
Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2
Z( J, K+2 ) = Z( J, K+2 ) - SUM*T3
80 CONTINUE
***
* Increment op count
OPS = OPS + 10*NZ
***
END IF
ELSE IF( NR.EQ.2 ) THEN
*
* Apply G from the left to transform the rows of the matrix
* in columns K to I2.
*
DO 90 J = K, I2
SUM = H( K, J ) + V2*H( K+1, J )
H( K, J ) = H( K, J ) - SUM*T1
H( K+1, J ) = H( K+1, J ) - SUM*T2
90 CONTINUE
*
* Apply G from the right to transform the columns of the
* matrix in rows I1 to min(K+3,I).
*
DO 100 J = I1, I
SUM = H( J, K ) + V2*H( J, K+1 )
H( J, K ) = H( J, K ) - SUM*T1
H( J, K+1 ) = H( J, K+1 ) - SUM*T2
100 CONTINUE
***
* Increment op count
OPS = OPS + 6*( I2-I1+3 )
***
*
IF( WANTZ ) THEN
*
* Accumulate transformations in the matrix Z
*
DO 110 J = ILOZ, IHIZ
SUM = Z( J, K ) + V2*Z( J, K+1 )
Z( J, K ) = Z( J, K ) - SUM*T1
Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2
110 CONTINUE
***
* Increment op count
OPS = OPS + 6*NZ
***
END IF
END IF
120 CONTINUE
*
130 CONTINUE
*
* Failure to converge in remaining number of iterations
*
INFO = I
RETURN
*
140 CONTINUE
*
IF( L.EQ.I ) THEN
*
* H(I,I-1) is negligible: one eigenvalue has converged.
*
WR( I ) = H( I, I )
WI( I ) = ZERO
ELSE IF( L.EQ.I-1 ) THEN
*
* H(I-1,I-2) is negligible: a pair of eigenvalues have converged.
*
* Transform the 2-by-2 submatrix to standard Schur form,
* and compute and store the eigenvalues.
*
CALL DLANV2( H( I-1, I-1 ), H( I-1, I ), H( I, I-1 ),
$ H( I, I ), WR( I-1 ), WI( I-1 ), WR( I ), WI( I ),
$ CS, SN )
*
IF( WANTT ) THEN
*
* Apply the transformation to the rest of H.
*
IF( I2.GT.I )
$ CALL DROT( I2-I, H( I-1, I+1 ), LDH, H( I, I+1 ), LDH,
$ CS, SN )
CALL DROT( I-I1-1, H( I1, I-1 ), 1, H( I1, I ), 1, CS, SN )
***
* Increment op count
OPS = OPS + 6*( I2-I1-1 )
***
END IF
IF( WANTZ ) THEN
*
* Apply the transformation to Z.
*
CALL DROT( NZ, Z( ILOZ, I-1 ), 1, Z( ILOZ, I ), 1, CS, SN )
***
* Increment op count
OPS = OPS + 6*NZ
***
END IF
END IF
*
* Decrement number of remaining iterations, and return to start of
* the main loop with new value of I.
*
ITN = ITN - ITS
I = L - 1
GO TO 10
*
150 CONTINUE
***
* Compute final op count
OPS = OPS + OPST
***
RETURN
*
* End of DLAHQR
*
END
SUBROUTINE DLAR1V( N, B1, BN, SIGMA, D, L, LD, LLD, GERSCH, Z,
$ ZTZ, MINGMA, R, ISUPPZ, WORK )
*
* -- LAPACK auxiliary routine (instru to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER B1, BN, N, R
DOUBLE PRECISION MINGMA, SIGMA, ZTZ
* ..
* .. Array Arguments ..
INTEGER ISUPPZ( * )
DOUBLE PRECISION D( * ), GERSCH( * ), L( * ), LD( * ), LLD( * ),
$ WORK( * ), Z( * )
* ..
* Common block to return operation count
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLAR1V computes the (scaled) r-th column of the inverse of
* the sumbmatrix in rows B1 through BN of the tridiagonal matrix
* L D L^T - sigma I. The following steps accomplish this computation :
* (a) Stationary qd transform, L D L^T - sigma I = L(+) D(+) L(+)^T,
* (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T,
* (c) Computation of the diagonal elements of the inverse of
* L D L^T - sigma I by combining the above transforms, and choosing
* r as the index where the diagonal of the inverse is (one of the)
* largest in magnitude.
* (d) Computation of the (scaled) r-th column of the inverse using the
* twisted factorization obtained by combining the top part of the
* the stationary and the bottom part of the progressive transform.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix L D L^T.
*
* B1 (input) INTEGER
* First index of the submatrix of L D L^T.
*
* BN (input) INTEGER
* Last index of the submatrix of L D L^T.
*
* SIGMA (input) DOUBLE PRECISION
* The shift. Initially, when R = 0, SIGMA should be a good
* approximation to an eigenvalue of L D L^T.
*
* L (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) subdiagonal elements of the unit bidiagonal matrix
* L, in elements 1 to N-1.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the diagonal matrix D.
*
* LD (input) DOUBLE PRECISION array, dimension (N-1)
* The n-1 elements L(i)*D(i).
*
* LLD (input) DOUBLE PRECISION array, dimension (N-1)
* The n-1 elements L(i)*L(i)*D(i).
*
* GERSCH (input) DOUBLE PRECISION array, dimension (2*N)
* The n Gerschgorin intervals. These are used to restrict
* the initial search for R, when R is input as 0.
*
* Z (output) DOUBLE PRECISION array, dimension (N)
* The (scaled) r-th column of the inverse. Z(R) is returned
* to be 1.
*
* ZTZ (output) DOUBLE PRECISION
* The square of the norm of Z.
*
* MINGMA (output) DOUBLE PRECISION
* The reciprocal of the largest (in magnitude) diagonal
* element of the inverse of L D L^T - sigma I.
*
* R (input/output) INTEGER
* Initially, R should be input to be 0 and is then output as
* the index where the diagonal element of the inverse is
* largest in magnitude. In later iterations, this same value
* of R should be input.
*
* ISUPPZ (output) INTEGER array, dimension (2)
* The support of the vector in Z, i.e., the vector Z is
* nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
*
* Further Details
* ===============
*
* Based on contributions by
* Inderjit Dhillon, IBM Almaden, USA
* Osni Marques, LBNL/NERSC, USA
*
* =====================================================================
*
* .. Parameters ..
INTEGER BLKSIZ
PARAMETER ( BLKSIZ = 32 )
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL SAWNAN
INTEGER FROM, I, INDP, INDS, INDUMN, J, R1, R2, TO
DOUBLE PRECISION DMINUS, DPLUS, EPS, S, TMP
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
EPS = DLAMCH( 'Precision' )
IF( R.EQ.0 ) THEN
*
* Eliminate the top and bottom indices from the possible values
* of R where the desired eigenvector is largest in magnitude.
*
R1 = B1
DO 10 I = B1, BN
IF( SIGMA.GE.GERSCH( 2*I-1 ) .OR. SIGMA.LE.GERSCH( 2*I ) )
$ THEN
R1 = I
GO TO 20
END IF
10 CONTINUE
20 CONTINUE
R2 = BN
DO 30 I = BN, B1, -1
IF( SIGMA.GE.GERSCH( 2*I-1 ) .OR. SIGMA.LE.GERSCH( 2*I ) )
$ THEN
R2 = I
GO TO 40
END IF
30 CONTINUE
40 CONTINUE
ELSE
R1 = R
R2 = R
END IF
*
INDUMN = N
INDS = 2*N + 1
INDP = 3*N + 1
SAWNAN = .FALSE.
*
* Compute the stationary transform (using the differential form)
* untill the index R2
*
IF( B1.EQ.1 ) THEN
WORK( INDS ) = ZERO
ELSE
WORK( INDS ) = LLD( B1-1 )
END IF
OPS = OPS + DBLE( 1 )
S = WORK( INDS ) - SIGMA
DO 50 I = B1, R2 - 1
OPS = OPS + DBLE( 5 )
DPLUS = D( I ) + S
WORK( I ) = LD( I ) / DPLUS
WORK( INDS+I ) = S*WORK( I )*L( I )
S = WORK( INDS+I ) - SIGMA
50 CONTINUE
*
IF( .NOT.( S.GT.ZERO .OR. S.LT.ONE ) ) THEN
*
* Run a slower version of the above loop if a NaN is detected
*
SAWNAN = .TRUE.
J = B1 + 1
60 CONTINUE
IF( WORK( INDS+J ).GT.ZERO .OR. WORK( INDS+J ).LT.ONE ) THEN
J = J + 1
GO TO 60
END IF
WORK( INDS+J ) = LLD( J )
S = WORK( INDS+J ) - SIGMA
DO 70 I = J + 1, R2 - 1
OPS = OPS + DBLE( 3 )
DPLUS = D( I ) + S
WORK( I ) = LD( I ) / DPLUS
IF( WORK( I ).EQ.ZERO ) THEN
WORK( INDS+I ) = LLD( I )
ELSE
OPS = OPS + DBLE( 2 )
WORK( INDS+I ) = S*WORK( I )*L( I )
END IF
S = WORK( INDS+I ) - SIGMA
70 CONTINUE
END IF
OPS = OPS + DBLE( 1 )
WORK( INDP+BN-1 ) = D( BN ) - SIGMA
DO 80 I = BN - 1, R1, -1
OPS = OPS + DBLE( 5 )
DMINUS = LLD( I ) + WORK( INDP+I )
TMP = D( I ) / DMINUS
WORK( INDUMN+I ) = L( I )*TMP
WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - SIGMA
80 CONTINUE
TMP = WORK( INDP+R1-1 )
IF( .NOT.( TMP.GT.ZERO .OR. TMP.LT.ONE ) ) THEN
*
* Run a slower version of the above loop if a NaN is detected
*
SAWNAN = .TRUE.
J = BN - 3
90 CONTINUE
IF( WORK( INDP+J ).GT.ZERO .OR. WORK( INDP+J ).LT.ONE ) THEN
J = J - 1
GO TO 90
END IF
OPS = OPS + DBLE( 1 )
WORK( INDP+J ) = D( J+1 ) - SIGMA
DO 100 I = J, R1, -1
OPS = OPS + DBLE( 3 )
DMINUS = LLD( I ) + WORK( INDP+I )
TMP = D( I ) / DMINUS
WORK( INDUMN+I ) = L( I )*TMP
IF( TMP.EQ.ZERO ) THEN
OPS = OPS + DBLE( 1 )
WORK( INDP+I-1 ) = D( I ) - SIGMA
ELSE
OPS = OPS + DBLE( 2 )
WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - SIGMA
END IF
100 CONTINUE
END IF
*
* Find the index (from R1 to R2) of the largest (in magnitude)
* diagonal element of the inverse
*
MINGMA = WORK( INDS+R1-1 ) + WORK( INDP+R1-1 )
IF( MINGMA.EQ.ZERO )
$ MINGMA = EPS*WORK( INDS+R1-1 )
R = R1
DO 110 I = R1, R2 - 1
OPS = OPS + DBLE( 1 )
TMP = WORK( INDS+I ) + WORK( INDP+I )
IF( TMP.EQ.ZERO ) THEN
OPS = OPS + DBLE( 1 )
TMP = EPS*WORK( INDS+I )
END IF
IF( ABS( TMP ).LT.ABS( MINGMA ) ) THEN
MINGMA = TMP
R = I + 1
END IF
110 CONTINUE
*
* Compute the (scaled) r-th column of the inverse
*
ISUPPZ( 1 ) = B1
ISUPPZ( 2 ) = BN
Z( R ) = ONE
ZTZ = ONE
IF( .NOT.SAWNAN ) THEN
FROM = R - 1
TO = MAX( R-BLKSIZ, B1 )
120 CONTINUE
IF( FROM.GE.B1 ) THEN
DO 130 I = FROM, TO, -1
OPS = OPS + DBLE( 3 )
Z( I ) = -( WORK( I )*Z( I+1 ) )
ZTZ = ZTZ + Z( I )*Z( I )
130 CONTINUE
IF( ABS( Z( TO ) ).LE.EPS .AND. ABS( Z( TO+1 ) ).LE.EPS )
$ THEN
ISUPPZ( 1 ) = TO + 2
ELSE
FROM = TO - 1
TO = MAX( TO-BLKSIZ, B1 )
GO TO 120
END IF
END IF
FROM = R + 1
TO = MIN( R+BLKSIZ, BN )
140 CONTINUE
IF( FROM.LE.BN ) THEN
DO 150 I = FROM, TO
OPS = OPS + DBLE( 3 )
Z( I ) = -( WORK( INDUMN+I-1 )*Z( I-1 ) )
ZTZ = ZTZ + Z( I )*Z( I )
150 CONTINUE
IF( ABS( Z( TO ) ).LE.EPS .AND. ABS( Z( TO-1 ) ).LE.EPS )
$ THEN
ISUPPZ( 2 ) = TO - 2
ELSE
FROM = TO + 1
TO = MIN( TO+BLKSIZ, BN )
GO TO 140
END IF
END IF
ELSE
DO 160 I = R - 1, B1, -1
IF( Z( I+1 ).EQ.ZERO ) THEN
OPS = OPS + DBLE( 2 )
Z( I ) = -( LD( I+1 ) / LD( I ) )*Z( I+2 )
ELSE IF( ABS( Z( I+1 ) ).LE.EPS .AND. ABS( Z( I+2 ) ).LE.
$ EPS ) THEN
ISUPPZ( 1 ) = I + 3
GO TO 170
ELSE
OPS = OPS + DBLE( 1 )
Z( I ) = -( WORK( I )*Z( I+1 ) )
END IF
OPS = OPS + DBLE( 2 )
ZTZ = ZTZ + Z( I )*Z( I )
160 CONTINUE
170 CONTINUE
DO 180 I = R, BN - 1
IF( Z( I ).EQ.ZERO ) THEN
OPS = OPS + DBLE( 2 )
Z( I+1 ) = -( LD( I-1 ) / LD( I ) )*Z( I-1 )
ELSE IF( ABS( Z( I ) ).LE.EPS .AND. ABS( Z( I-1 ) ).LE.EPS )
$ THEN
ISUPPZ( 2 ) = I - 2
GO TO 190
ELSE
OPS = OPS + DBLE( 1 )
Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) )
END IF
OPS = OPS + DBLE( 2 )
ZTZ = ZTZ + Z( I+1 )*Z( I+1 )
180 CONTINUE
190 CONTINUE
END IF
DO 200 I = B1, ISUPPZ( 1 ) - 3
Z( I ) = ZERO
200 CONTINUE
DO 210 I = ISUPPZ( 2 ) + 3, BN
Z( I ) = ZERO
210 CONTINUE
*
RETURN
*
* End of DLAR1V
*
END
SUBROUTINE DLARRB( N, D, L, LD, LLD, IFIRST, ILAST, SIGMA, RELTOL,
$ W, WGAP, WERR, WORK, IWORK, INFO )
*
* -- LAPACK auxiliary routine (instru to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER IFIRST, ILAST, INFO, N
DOUBLE PRECISION RELTOL, SIGMA
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION D( * ), L( * ), LD( * ), LLD( * ), W( * ),
$ WERR( * ), WGAP( * ), WORK( * )
* ..
* Common block to return operation count
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* Given the relatively robust representation(RRR) L D L^T, DLARRB
* does ``limited'' bisection to locate the eigenvalues of L D L^T,
* W( IFIRST ) thru' W( ILAST ), to more accuracy. Intervals
* [left, right] are maintained by storing their mid-points and
* semi-widths in the arrays W and WERR respectively.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the diagonal matrix D.
*
* L (input) DOUBLE PRECISION array, dimension (N-1)
* The n-1 subdiagonal elements of the unit bidiagonal matrix L.
*
* LD (input) DOUBLE PRECISION array, dimension (N-1)
* The n-1 elements L(i)*D(i).
*
* LLD (input) DOUBLE PRECISION array, dimension (N-1)
* The n-1 elements L(i)*L(i)*D(i).
*
* IFIRST (input) INTEGER
* The index of the first eigenvalue in the cluster.
*
* ILAST (input) INTEGER
* The index of the last eigenvalue in the cluster.
*
* SIGMA (input) DOUBLE PRECISION
* The shift used to form L D L^T (see DLARRF).
*
* RELTOL (input) DOUBLE PRECISION
* The relative tolerance.
*
* W (input/output) DOUBLE PRECISION array, dimension (N)
* On input, W( IFIRST ) thru' W( ILAST ) are estimates of the
* corresponding eigenvalues of L D L^T.
* On output, these estimates are ``refined''.
*
* WGAP (input/output) DOUBLE PRECISION array, dimension (N)
* The gaps between the eigenvalues of L D L^T. Very small
* gaps are changed on output.
*
* WERR (input/output) DOUBLE PRECISION array, dimension (N)
* On input, WERR( IFIRST ) thru' WERR( ILAST ) are the errors
* in the estimates W( IFIRST ) thru' W( ILAST ).
* On output, these are the ``refined'' errors.
*
*****Reminder to Inder --- WORK is never used in this subroutine *****
* WORK (input) DOUBLE PRECISION array, dimension (???)
* Workspace.
*
* IWORK (input) INTEGER array, dimension (2*N)
* Workspace.
*
*****Reminder to Inder --- INFO is never set in this subroutine ******
* INFO (output) INTEGER
* Error flag.
*
* Further Details
* ===============
*
* Based on contributions by
* Inderjit Dhillon, IBM Almaden, USA
* Osni Marques, LBNL/NERSC, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, TWO, HALF
PARAMETER ( ZERO = 0.0D0, TWO = 2.0D0, HALF = 0.5D0 )
* ..
* .. Local Scalars ..
INTEGER CNT, I, I1, I2, INITI1, INITI2, J, K, NCNVRG,
$ NEIG, NINT, NRIGHT, OLNINT
DOUBLE PRECISION DELTA, EPS, GAP, LEFT, MID, PERT, RIGHT, S,
$ THRESH, TMP, WIDTH
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
EPS = DLAMCH( 'Precision' )
I1 = IFIRST
I2 = IFIRST
NEIG = ILAST - IFIRST + 1
NCNVRG = 0
THRESH = RELTOL
DO 10 I = IFIRST, ILAST
OPS = OPS + DBLE( 3 )
IWORK( I ) = 0
PERT = EPS*( ABS( SIGMA )+ABS( W( I ) ) )
WERR( I ) = WERR( I ) + PERT
IF( WGAP( I ).LT.PERT )
$ WGAP( I ) = PERT
10 CONTINUE
DO 20 I = I1, ILAST
IF( I.EQ.1 ) THEN
GAP = WGAP( I )
ELSE IF( I.EQ.N ) THEN
GAP = WGAP( I-1 )
ELSE
GAP = MIN( WGAP( I-1 ), WGAP( I ) )
END IF
OPS = OPS + DBLE( 1 )
IF( WERR( I ).LT.THRESH*GAP ) THEN
NCNVRG = NCNVRG + 1
IWORK( I ) = 1
IF( I1.EQ.I )
$ I1 = I1 + 1
ELSE
I2 = I
END IF
20 CONTINUE
*
* Initialize the unconverged intervals.
*
I = I1
NINT = 0
RIGHT = ZERO
30 CONTINUE
IF( I.LE.I2 ) THEN
IF( IWORK( I ).EQ.0 ) THEN
DELTA = EPS
OPS = OPS + DBLE( 1 )
LEFT = W( I ) - WERR( I )
*
* Do while( CNT(LEFT).GT.I-1 )
*
40 CONTINUE
IF( I.GT.I1 .AND. LEFT.LE.RIGHT ) THEN
LEFT = RIGHT
CNT = I - 1
ELSE
S = -LEFT
CNT = 0
DO 50 J = 1, N - 1
OPS = OPS + DBLE( 5 )
TMP = D( J ) + S
S = S*( LD( J ) / TMP )*L( J ) - LEFT
IF( TMP.LT.ZERO )
$ CNT = CNT + 1
50 CONTINUE
TMP = D( N ) + S
IF( TMP.LT.ZERO )
$ CNT = CNT + 1
IF( CNT.GT.I-1 ) THEN
OPS = OPS + DBLE( 4 )
DELTA = TWO*DELTA
LEFT = LEFT - ( ABS( SIGMA )+ABS( LEFT ) )*DELTA
GO TO 40
END IF
END IF
OPS = OPS + DBLE( 1 )
DELTA = EPS
RIGHT = W( I ) + WERR( I )
*
* Do while( CNT(RIGHT).LT.I )
*
60 CONTINUE
S = -RIGHT
CNT = 0
OPS = OPS + DBLE( 5*( N-1 )+1 )
DO 70 J = 1, N - 1
TMP = D( J ) + S
S = S*( LD( J ) / TMP )*L( J ) - RIGHT
IF( TMP.LT.ZERO )
$ CNT = CNT + 1
70 CONTINUE
TMP = D( N ) + S
IF( TMP.LT.ZERO )
$ CNT = CNT + 1
IF( CNT.LT.I ) THEN
OPS = OPS + DBLE( 4 )
DELTA = TWO*DELTA
RIGHT = RIGHT + ( ABS( SIGMA )+ABS( RIGHT ) )*DELTA
GO TO 60
END IF
WERR( I ) = LEFT
W( I ) = RIGHT
IWORK( N+I ) = CNT
NINT = NINT + 1
I = CNT + 1
ELSE
I = I + 1
END IF
GO TO 30
END IF
*
* While( NCNVRG.LT.NEIG )
*
INITI1 = I1
INITI2 = I2
80 CONTINUE
IF( NCNVRG.LT.NEIG ) THEN
OLNINT = NINT
I = I1
DO 100 K = 1, OLNINT
NRIGHT = IWORK( N+I )
IF( IWORK( I ).EQ.0 ) THEN
OPS = OPS + DBLE( 2 )
MID = HALF*( WERR( I )+W( I ) )
S = -MID
CNT = 0
OPS = OPS + DBLE( 5*( N-1 )+1 )
DO 90 J = 1, N - 1
TMP = D( J ) + S
S = S*( LD( J ) / TMP )*L( J ) - MID
IF( TMP.LT.ZERO )
$ CNT = CNT + 1
90 CONTINUE
TMP = D( N ) + S
IF( TMP.LT.ZERO )
$ CNT = CNT + 1
CNT = MAX( I-1, MIN( NRIGHT, CNT ) )
IF( I.EQ.NRIGHT ) THEN
IF( I.EQ.IFIRST ) THEN
OPS = OPS + DBLE( 1 )
GAP = WERR( I+1 ) - W( I )
ELSE IF( I.EQ.ILAST ) THEN
OPS = OPS + DBLE( 1 )
GAP = WERR( I ) - W( I-1 )
ELSE
OPS = OPS + DBLE( 2 )
GAP = MIN( WERR( I+1 )-W( I ), WERR( I )-W( I-1 ) )
END IF
OPS = OPS + DBLE( 2 )
WIDTH = W( I ) - MID
IF( WIDTH.LT.THRESH*GAP ) THEN
NCNVRG = NCNVRG + 1
IWORK( I ) = 1
IF( I1.EQ.I ) THEN
I1 = I1 + 1
NINT = NINT - 1
END IF
END IF
END IF
IF( IWORK( I ).EQ.0 )
$ I2 = K
IF( CNT.EQ.I-1 ) THEN
WERR( I ) = MID
ELSE IF( CNT.EQ.NRIGHT ) THEN
W( I ) = MID
ELSE
IWORK( N+I ) = CNT
NINT = NINT + 1
WERR( CNT+1 ) = MID
W( CNT+1 ) = W( I )
W( I ) = MID
I = CNT + 1
IWORK( N+I ) = NRIGHT
END IF
END IF
I = NRIGHT + 1
100 CONTINUE
NINT = NINT - OLNINT + I2
GO TO 80
END IF
DO 110 I = INITI1, INITI2
OPS = OPS + DBLE( 3 )
W( I ) = HALF*( WERR( I )+W( I ) )
WERR( I ) = W( I ) - WERR( I )
110 CONTINUE
*
RETURN
*
* End of DLARRB
*
END
SUBROUTINE DLARRE( N, D, E, TOL, NSPLIT, ISPLIT, M, W, WOFF,
$ GERSCH, WORK, INFO )
*
* -- LAPACK auxiliary routine (instru to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER INFO, M, N, NSPLIT
DOUBLE PRECISION TOL
* ..
* .. Array Arguments ..
INTEGER ISPLIT( * )
DOUBLE PRECISION D( * ), E( * ), GERSCH( * ), W( * ), WOFF( * ),
$ WORK( * )
* ..
* Common block to return operation count
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* Given the tridiagonal matrix T, DLARRE sets "small" off-diagonal
* elements to zero, and for each unreduced block T_i, it finds
* (i) the numbers sigma_i
* (ii) the base T_i - sigma_i I = L_i D_i L_i^T representations and
* (iii) eigenvalues of each L_i D_i L_i^T.
* The representations and eigenvalues found are then used by
* DSTEGR to compute the eigenvectors of a symmetric tridiagonal
* matrix. Currently, the base representations are limited to being
* positive or negative definite, and the eigenvalues of the definite
* matrices are found by the dqds algorithm (subroutine DLASQ2). As
* an added benefit, DLARRE also outputs the n Gerschgorin
* intervals for each L_i D_i L_i^T.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the n diagonal elements of the tridiagonal
* matrix T.
* On exit, the n diagonal elements of the diagonal
* matrices D_i.
*
* E (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix T; E(N) need not be set.
* On exit, the subdiagonal elements of the unit bidiagonal
* matrices L_i.
*
* TOL (input) DOUBLE PRECISION
* The threshold for splitting. If on input |E(i)| < TOL, then
* the matrix T is split into smaller blocks.
*
* NSPLIT (input) INTEGER
* The number of blocks T splits into. 1 <= NSPLIT <= N.
*
* ISPLIT (output) INTEGER array, dimension (2*N)
* The splitting points, at which T breaks up into submatrices.
* The first submatrix consists of rows/columns 1 to ISPLIT(1),
* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
* etc., and the NSPLIT-th consists of rows/columns
* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
*
* M (output) INTEGER
* The total number of eigenvalues (of all the L_i D_i L_i^T)
* found.
*
* W (output) DOUBLE PRECISION array, dimension (N)
* The first M elements contain the eigenvalues. The
* eigenvalues of each of the blocks, L_i D_i L_i^T, are
* sorted in ascending order.
*
* WOFF (output) DOUBLE PRECISION array, dimension (N)
* The NSPLIT base points sigma_i.
*
* GERSCH (output) DOUBLE PRECISION array, dimension (2*N)
* The n Gerschgorin intervals.
*
* WORK (input) DOUBLE PRECISION array, dimension (4*N???)
* Workspace.
*
* INFO (output) INTEGER
* Output error code from DLASQ2
*
* Further Details
* ===============
*
* Based on contributions by
* Inderjit Dhillon, IBM Almaden, USA
* Osni Marques, LBNL/NERSC, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, FOUR, FOURTH
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ FOUR = 4.0D0, FOURTH = ONE / FOUR )
* ..
* .. Local Scalars ..
INTEGER CNT, I, IBEGIN, IEND, IN, J, JBLK, MAXCNT
DOUBLE PRECISION DELTA, EPS, GL, GU, NRM, OFFD, S, SGNDEF,
$ SIGMA, TAU, TMP1, WIDTH
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLASQ2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
EPS = DLAMCH( 'Precision' )
*
* Compute Splitting Points
*
NSPLIT = 1
DO 10 I = 1, N - 1
IF( ABS( E( I ) ).LE.TOL ) THEN
ISPLIT( NSPLIT ) = I
NSPLIT = NSPLIT + 1
END IF
10 CONTINUE
ISPLIT( NSPLIT ) = N
*
IBEGIN = 1
DO 170 JBLK = 1, NSPLIT
IEND = ISPLIT( JBLK )
IF( IBEGIN.EQ.IEND ) THEN
W( IBEGIN ) = D( IBEGIN )
WOFF( JBLK ) = ZERO
IBEGIN = IEND + 1
GO TO 170
END IF
IN = IEND - IBEGIN + 1
*
* Form the n Gerschgorin intervals
*
OPS = OPS + DBLE( 4 )
GL = D( IBEGIN ) - ABS( E( IBEGIN ) )
GU = D( IBEGIN ) + ABS( E( IBEGIN ) )
GERSCH( 2*IBEGIN-1 ) = GL
GERSCH( 2*IBEGIN ) = GU
GERSCH( 2*IEND-1 ) = D( IEND ) - ABS( E( IEND-1 ) )
GERSCH( 2*IEND ) = D( IEND ) + ABS( E( IEND-1 ) )
GL = MIN( GERSCH( 2*IEND-1 ), GL )
GU = MAX( GERSCH( 2*IEND ), GU )
DO 20 I = IBEGIN + 1, IEND - 1
OPS = OPS + DBLE( 3 )
OFFD = ABS( E( I-1 ) ) + ABS( E( I ) )
GERSCH( 2*I-1 ) = D( I ) - OFFD
GL = MIN( GERSCH( 2*I-1 ), GL )
GERSCH( 2*I ) = D( I ) + OFFD
GU = MAX( GERSCH( 2*I ), GU )
20 CONTINUE
NRM = MAX( ABS( GL ), ABS( GU ) )
*
* Find the number SIGMA where the base representation
* T - sigma I = L D L^T is to be formed.
*
WIDTH = GU - GL
DO 30 I = IBEGIN, IEND - 1
OPS = OPS + DBLE( 1 )
WORK( I ) = E( I )*E( I )
30 CONTINUE
OPS = OPS + DBLE( 6 )
DO 50 J = 1, 2
IF( J.EQ.1 ) THEN
TAU = GL + FOURTH*WIDTH
ELSE
TAU = GU - FOURTH*WIDTH
END IF
TMP1 = D( IBEGIN ) - TAU
IF( TMP1.LT.ZERO ) THEN
CNT = 1
ELSE
CNT = 0
END IF
DO 40 I = IBEGIN + 1, IEND
OPS = OPS + DBLE( 3 )
TMP1 = D( I ) - TAU - WORK( I-1 ) / TMP1
IF( TMP1.LT.ZERO )
$ CNT = CNT + 1
40 CONTINUE
IF( CNT.EQ.0 ) THEN
GL = TAU
ELSE IF( CNT.EQ.IN ) THEN
GU = TAU
END IF
IF( J.EQ.1 ) THEN
MAXCNT = CNT
SIGMA = GL
SGNDEF = ONE
ELSE
IF( IN-CNT.GT.MAXCNT ) THEN
SIGMA = GU
SGNDEF = -ONE
END IF
END IF
50 CONTINUE
*
* Find the base L D L^T representation
*
OPS = OPS + DBLE( 1 )
WORK( 3*IN ) = ONE
DELTA = EPS
TAU = SGNDEF*NRM
60 CONTINUE
OPS = OPS + DBLE( 3+5*( IN-1 ) )
SIGMA = SIGMA - DELTA*TAU
WORK( 1 ) = D( IBEGIN ) - SIGMA
J = IBEGIN
DO 70 I = 1, IN - 1
WORK( 2*IN+I ) = ONE / WORK( 2*I-1 )
TMP1 = E( J )*WORK( 2*IN+I )
WORK( 2*I+1 ) = ( D( J+1 )-SIGMA ) - TMP1*E( J )
WORK( 2*I ) = TMP1
J = J + 1
70 CONTINUE
OPS = OPS + DBLE( IN )
DO 80 I = IN, 1, -1
TMP1 = SGNDEF*WORK( 2*I-1 )
IF( TMP1.LT.ZERO .OR. WORK( 2*IN+I ).EQ.ZERO .OR. .NOT.
$ ( TMP1.GT.ZERO .OR. TMP1.LT.ONE ) ) THEN
OPS = OPS + DBLE( 1 )
DELTA = TWO*DELTA
GO TO 60
END IF
J = J - 1
80 CONTINUE
*
OPS = OPS + DBLE( IN-1 )
J = IBEGIN
D( IBEGIN ) = WORK( 1 )
WORK( 1 ) = ABS( WORK( 1 ) )
DO 90 I = 1, IN - 1
TMP1 = E( J )
E( J ) = WORK( 2*I )
WORK( 2*I ) = ABS( TMP1*WORK( 2*I ) )
J = J + 1
D( J ) = WORK( 2*I+1 )
WORK( 2*I+1 ) = ABS( WORK( 2*I+1 ) )
90 CONTINUE
*
CALL DLASQ2( IN, WORK, INFO )
*
OPS = OPS + DBLE( 2 )
TAU = SGNDEF*WORK( IN )
WORK( 3*IN ) = ONE
DELTA = TWO*EPS
100 CONTINUE
OPS = OPS + DBLE( 2 )
TAU = TAU*( ONE-DELTA )
*
OPS = OPS + DBLE( 9*( IN-1 )+1 )
S = -TAU
J = IBEGIN
DO 110 I = 1, IN - 1
WORK( I ) = D( J ) + S
WORK( 2*IN+I ) = ONE / WORK( I )
* WORK( N+I ) = ( E( I ) * D( I ) ) / WORK( I )
WORK( IN+I ) = ( E( J )*D( J ) )*WORK( 2*IN+I )
S = S*WORK( IN+I )*E( J ) - TAU
J = J + 1
110 CONTINUE
WORK( IN ) = D( IEND ) + S
*
* Checking to see if all the diagonal elements of the new
* L D L^T representation have the same sign
*
OPS = OPS + DBLE( IN+1 )
DO 120 I = IN, 1, -1
TMP1 = SGNDEF*WORK( I )
IF( TMP1.LT.ZERO .OR. WORK( 2*IN+I ).EQ.ZERO .OR. .NOT.
$ ( TMP1.GT.ZERO .OR. TMP1.LT.ONE ) ) THEN
OPS = OPS + DBLE( 1 )
DELTA = TWO*DELTA
GO TO 100
END IF
120 CONTINUE
*
SIGMA = SIGMA + TAU
CALL DCOPY( IN, WORK, 1, D( IBEGIN ), 1 )
CALL DCOPY( IN-1, WORK( IN+1 ), 1, E( IBEGIN ), 1 )
WOFF( JBLK ) = SIGMA
*
* Update the n Gerschgorin intervals
*
OPS = OPS + DBLE( 2 )
DO 130 I = IBEGIN, IEND
GERSCH( 2*I-1 ) = GERSCH( 2*I-1 ) - SIGMA
GERSCH( 2*I ) = GERSCH( 2*I ) - SIGMA
130 CONTINUE
*
* Compute the eigenvalues of L D L^T.
*
J = IBEGIN
OPS = OPS + DBLE( 2*( IN-1 ) )
DO 140 I = 1, IN - 1
WORK( 2*I-1 ) = ABS( D( J ) )
WORK( 2*I ) = E( J )*E( J )*WORK( 2*I-1 )
J = J + 1
140 CONTINUE
WORK( 2*IN-1 ) = ABS( D( IEND ) )
*
CALL DLASQ2( IN, WORK, INFO )
*
J = IBEGIN
IF( SGNDEF.GT.ZERO ) THEN
DO 150 I = 1, IN
W( J ) = WORK( IN-I+1 )
J = J + 1
150 CONTINUE
ELSE
DO 160 I = 1, IN
W( J ) = -WORK( I )
J = J + 1
160 CONTINUE
END IF
IBEGIN = IEND + 1
170 CONTINUE
M = N
*
RETURN
*
* End of DLARRE
*
END
SUBROUTINE DLARRF( N, D, L, LD, LLD, IFIRST, ILAST, W, DPLUS,
$ LPLUS, WORK, IWORK, INFO )
*
* -- LAPACK auxiliary routine (instru to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER IFIRST, ILAST, INFO, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION D( * ), DPLUS( * ), L( * ), LD( * ), LLD( * ),
$ LPLUS( * ), W( * ), WORK( * )
* ..
* Common block to return operation count
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* Given the initial representation L D L^T and its cluster of close
* eigenvalues (in a relative measure), W( IFIRST ), W( IFIRST+1 ), ...
* W( ILAST ), DLARRF finds a new relatively robust representation
* L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the
* eigenvalues of L(+) D(+) L(+)^T is relatively isolated.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the diagonal matrix D.
*
* L (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) subdiagonal elements of the unit bidiagonal
* matrix L.
*
* LD (input) DOUBLE PRECISION array, dimension (N-1)
* The n-1 elements L(i)*D(i).
*
* LLD (input) DOUBLE PRECISION array, dimension (N-1)
* The n-1 elements L(i)*L(i)*D(i).
*
* IFIRST (input) INTEGER
* The index of the first eigenvalue in the cluster.
*
* ILAST (input) INTEGER
* The index of the last eigenvalue in the cluster.
*
* W (input/output) DOUBLE PRECISION array, dimension (N)
* On input, the eigenvalues of L D L^T in ascending order.
* W( IFIRST ) through W( ILAST ) form the cluster of relatively
* close eigenalues.
* On output, W( IFIRST ) thru' W( ILAST ) are estimates of the
* corresponding eigenvalues of L(+) D(+) L(+)^T.
*
* SIGMA (input) DOUBLE PRECISION
* The shift used to form L(+) D(+) L(+)^T.
*
* DPLUS (output) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the diagonal matrix D(+).
*
* LPLUS (output) DOUBLE PRECISION array, dimension (N)
* The first (n-1) elements of LPLUS contain the subdiagonal
* elements of the unit bidiagonal matrix L(+). LPLUS( N ) is
* set to SIGMA.
*
* WORK (input) DOUBLE PRECISION array, dimension (???)
* Workspace.
*
* Further Details
* ===============
*
* Based on contributions by
* Inderjit Dhillon, IBM Almaden, USA
* Osni Marques, LBNL/NERSC, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, TWO
PARAMETER ( ZERO = 0.0D0, TWO = 2.0D0 )
* ..
* .. Local Scalars ..
INTEGER I
DOUBLE PRECISION DELTA, EPS, S, SIGMA
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE
* ..
* .. Executable Statements ..
*
INFO = 0
EPS = DLAMCH( 'Precision' )
IF( IFIRST.EQ.1 ) THEN
SIGMA = W( IFIRST )
ELSE IF( ILAST.EQ.N ) THEN
SIGMA = W( ILAST )
ELSE
INFO = 1
RETURN
END IF
*
* Compute the new relatively robust representation (RRR)
*
OPS = OPS + DBLE( 3 )
DELTA = TWO*EPS
10 CONTINUE
IF( IFIRST.EQ.1 ) THEN
SIGMA = SIGMA - ABS( SIGMA )*DELTA
ELSE
SIGMA = SIGMA + ABS( SIGMA )*DELTA
END IF
S = -SIGMA
OPS = OPS + DBLE( 5*( N-1 )+1 )
DO 20 I = 1, N - 1
DPLUS( I ) = D( I ) + S
LPLUS( I ) = LD( I ) / DPLUS( I )
S = S*LPLUS( I )*L( I ) - SIGMA
20 CONTINUE
DPLUS( N ) = D( N ) + S
IF( IFIRST.EQ.1 ) THEN
DO 30 I = 1, N
IF( DPLUS( I ).LT.ZERO ) THEN
OPS = OPS + DBLE( 1 )
DELTA = TWO*DELTA
GO TO 10
END IF
30 CONTINUE
ELSE
DO 40 I = 1, N
IF( DPLUS( I ).GT.ZERO ) THEN
OPS = OPS + DBLE( 1 )
DELTA = TWO*DELTA
GO TO 10
END IF
40 CONTINUE
END IF
DO 50 I = IFIRST, ILAST
OPS = OPS + DBLE( 1 )
W( I ) = W( I ) - SIGMA
50 CONTINUE
LPLUS( N ) = SIGMA
*
RETURN
*
* End of DLARRF
*
END
SUBROUTINE DLARRV( N, D, L, ISPLIT, M, W, IBLOCK, GERSCH, TOL, Z,
$ LDZ, ISUPPZ, WORK, IWORK, INFO )
*
* -- LAPACK auxiliary routine (instru to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER INFO, LDZ, M, N
DOUBLE PRECISION TOL
* ..
* .. Array Arguments ..
INTEGER IBLOCK( * ), ISPLIT( * ), ISUPPZ( * ),
$ IWORK( * )
DOUBLE PRECISION D( * ), GERSCH( * ), L( * ), W( * ), WORK( * ),
$ Z( LDZ, * )
* ..
* Common block to return operation count
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLARRV computes the eigenvectors of the tridiagonal matrix
* T = L D L^T given L, D and the eigenvalues of L D L^T.
* The input eigenvalues should have high relative accuracy with
* respect to the entries of L and D. The desired accuracy of the
* output can be specified by the input parameter TOL.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the n diagonal elements of the diagonal matrix D.
* On exit, D may be overwritten.
*
* L (input/output) DOUBLE PRECISION array, dimension (N-1)
* On entry, the (n-1) subdiagonal elements of the unit
* bidiagonal matrix L in elements 1 to N-1 of L. L(N) need
* not be set. On exit, L is overwritten.
*
* ISPLIT (input) INTEGER array, dimension (N)
* The splitting points, at which T breaks up into submatrices.
* The first submatrix consists of rows/columns 1 to
* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
* through ISPLIT( 2 ), etc.
*
* TOL (input) DOUBLE PRECISION
* The absolute error tolerance for the
* eigenvalues/eigenvectors.
* Errors in the input eigenvalues must be bounded by TOL.
* The eigenvectors output have residual norms
* bounded by TOL, and the dot products between different
* eigenvectors are bounded by TOL. TOL must be at least
* N*EPS*|T|, where EPS is the machine precision and |T| is
* the 1-norm of the tridiagonal matrix.
*
* M (input) INTEGER
* The total number of eigenvalues found. 0 <= M <= N.
* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*
* W (input) DOUBLE PRECISION array, dimension (N)
* The first M elements of W contain the eigenvalues for
* which eigenvectors are to be computed. The eigenvalues
* should be grouped by split-off block and ordered from
* smallest to largest within the block ( The output array
* W from DLARRE is expected here ).
* Errors in W must be bounded by TOL (see above).
*
* IBLOCK (input) INTEGER array, dimension (N)
* The submatrix indices associated with the corresponding
* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to
* the first submatrix from the top, =2 if W(i) belongs to
* the second submatrix, etc.
*
* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
* contain the orthonormal eigenvectors of the matrix T
* corresponding to the selected eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* If JOBZ = 'N', then Z is not referenced.
* Note: the user must ensure that at least max(1,M) columns are
* supplied in the array Z; if RANGE = 'V', the exact value of M
* is not known in advance and an upper bound must be used.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
* The support of the eigenvectors in Z, i.e., the indices
* indicating the nonzero elements in Z. The i-th eigenvector
* is nonzero only in elements ISUPPZ( 2*i-1 ) through
* ISUPPZ( 2*i ).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (13*N)
*
* IWORK (workspace) INTEGER array, dimension (6*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = 1, internal error in DLARRB
* if INFO = 2, internal error in DSTEIN
*
* Further Details
* ===============
*
* Based on contributions by
* Inderjit Dhillon, IBM Almaden, USA
* Osni Marques, LBNL/NERSC, USA
* Ken Stanley, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
INTEGER MGSSIZ
PARAMETER ( MGSSIZ = 20 )
DOUBLE PRECISION ZERO, ONE, FOUR
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, FOUR = 4.0D0 )
* ..
* .. Local Scalars ..
LOGICAL MGSCLS
INTEGER I, IBEGIN, IEND, IINDC1, IINDC2, IINDR, IINDWK,
$ IINFO, IM, IN, INDERR, INDGAP, INDLD, INDLLD,
$ INDWRK, ITER, ITMP1, ITMP2, J, JBLK, K, KTOT,
$ LSBDPT, MAXITR, NCLUS, NDEPTH, NDONE, NEWCLS,
$ NEWFRS, NEWFTT, NEWLST, NEWSIZ, NSPLIT, OLDCLS,
$ OLDFST, OLDIEN, OLDLST, OLDNCL, P, Q
DOUBLE PRECISION EPS, GAP, LAMBDA, MGSTOL, MINGMA, MINRGP,
$ NRMINV, RELGAP, RELTOL, RESID, RQCORR, SIGMA,
$ TMP1, ZTZ
* ..
* .. External Functions ..
DOUBLE PRECISION DDOT, DLAMCH, DNRM2
EXTERNAL DDOT, DLAMCH, DNRM2
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DLAR1V, DLARRB, DLARRF, DLASET,
$ DSCAL, DSTEIN
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN, SQRT
* ..
* .. Local Arrays ..
INTEGER TEMP( 1 )
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INDERR = N + 1
INDLD = 2*N
INDLLD = 3*N
INDGAP = 4*N
INDWRK = 5*N + 1
*
IINDR = N
IINDC1 = 2*N
IINDC2 = 3*N
IINDWK = 4*N + 1
*
EPS = DLAMCH( 'Precision' )
*
DO 10 I = 1, 2*N
IWORK( I ) = 0
10 CONTINUE
OPS = OPS + DBLE( M+1 )
DO 20 I = 1, M
WORK( INDERR+I-1 ) = EPS*ABS( W( I ) )
20 CONTINUE
CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ )
MGSTOL = 5.0D0*EPS
*
NSPLIT = IBLOCK( M )
IBEGIN = 1
DO 170 JBLK = 1, NSPLIT
IEND = ISPLIT( JBLK )
*
* Find the eigenvectors of the submatrix indexed IBEGIN
* through IEND.
*
IF( IBEGIN.EQ.IEND ) THEN
Z( IBEGIN, IBEGIN ) = ONE
ISUPPZ( 2*IBEGIN-1 ) = IBEGIN
ISUPPZ( 2*IBEGIN ) = IBEGIN
IBEGIN = IEND + 1
GO TO 170
END IF
OLDIEN = IBEGIN - 1
IN = IEND - OLDIEN
OPS = OPS + DBLE( 1 )
RELTOL = MIN( 1.0D-2, ONE / DBLE( IN ) )
IM = IN
CALL DCOPY( IM, W( IBEGIN ), 1, WORK, 1 )
OPS = OPS + DBLE( IN-1 )
DO 30 I = 1, IN - 1
WORK( INDGAP+I ) = WORK( I+1 ) - WORK( I )
30 CONTINUE
WORK( INDGAP+IN ) = MAX( ABS( WORK( IN ) ), EPS )
NDONE = 0
*
NDEPTH = 0
LSBDPT = 1
NCLUS = 1
IWORK( IINDC1+1 ) = 1
IWORK( IINDC1+2 ) = IN
*
* While( NDONE.LT.IM ) do
*
40 CONTINUE
IF( NDONE.LT.IM ) THEN
OLDNCL = NCLUS
NCLUS = 0
LSBDPT = 1 - LSBDPT
DO 150 I = 1, OLDNCL
IF( LSBDPT.EQ.0 ) THEN
OLDCLS = IINDC1
NEWCLS = IINDC2
ELSE
OLDCLS = IINDC2
NEWCLS = IINDC1
END IF
*
* If NDEPTH > 1, retrieve the relatively robust
* representation (RRR) and perform limited bisection
* (if necessary) to get approximate eigenvalues.
*
J = OLDCLS + 2*I
OLDFST = IWORK( J-1 )
OLDLST = IWORK( J )
IF( NDEPTH.GT.0 ) THEN
J = OLDIEN + OLDFST
CALL DCOPY( IN, Z( IBEGIN, J ), 1, D( IBEGIN ), 1 )
CALL DCOPY( IN, Z( IBEGIN, J+1 ), 1, L( IBEGIN ), 1 )
SIGMA = L( IEND )
END IF
K = IBEGIN
OPS = OPS + DBLE( 2*( IN-1 ) )
DO 50 J = 1, IN - 1
WORK( INDLD+J ) = D( K )*L( K )
WORK( INDLLD+J ) = WORK( INDLD+J )*L( K )
K = K + 1
50 CONTINUE
IF( NDEPTH.GT.0 ) THEN
CALL DLARRB( IN, D( IBEGIN ), L( IBEGIN ),
$ WORK( INDLD+1 ), WORK( INDLLD+1 ),
$ OLDFST, OLDLST, SIGMA, RELTOL, WORK,
$ WORK( INDGAP+1 ), WORK( INDERR ),
$ WORK( INDWRK ), IWORK( IINDWK ), IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 1
RETURN
END IF
END IF
*
* Classify eigenvalues of the current representation (RRR)
* as (i) isolated, (ii) loosely clustered or (iii) tightly
* clustered
*
NEWFRS = OLDFST
DO 140 J = OLDFST, OLDLST
OPS = OPS + DBLE( 1 )
IF( J.EQ.OLDLST .OR. WORK( INDGAP+J ).GE.RELTOL*
$ ABS( WORK( J ) ) ) THEN
NEWLST = J
ELSE
*
* continue (to the next loop)
*
OPS = OPS + DBLE( 1 )
RELGAP = WORK( INDGAP+J ) / ABS( WORK( J ) )
IF( J.EQ.NEWFRS ) THEN
MINRGP = RELGAP
ELSE
MINRGP = MIN( MINRGP, RELGAP )
END IF
GO TO 140
END IF
NEWSIZ = NEWLST - NEWFRS + 1
MAXITR = 10
NEWFTT = OLDIEN + NEWFRS
IF( NEWSIZ.GT.1 ) THEN
MGSCLS = NEWSIZ.LE.MGSSIZ .AND. MINRGP.GE.MGSTOL
IF( .NOT.MGSCLS ) THEN
CALL DLARRF( IN, D( IBEGIN ), L( IBEGIN ),
$ WORK( INDLD+1 ), WORK( INDLLD+1 ),
$ NEWFRS, NEWLST, WORK,
$ Z( IBEGIN, NEWFTT ),
$ Z( IBEGIN, NEWFTT+1 ),
$ WORK( INDWRK ), IWORK( IINDWK ),
$ INFO )
IF( INFO.EQ.0 ) THEN
NCLUS = NCLUS + 1
K = NEWCLS + 2*NCLUS
IWORK( K-1 ) = NEWFRS
IWORK( K ) = NEWLST
ELSE
INFO = 0
IF( MINRGP.GE.MGSTOL ) THEN
MGSCLS = .TRUE.
ELSE
*
* Call DSTEIN to process this tight cluster.
* This happens only if MINRGP <= MGSTOL
* and DLARRF returns INFO = 1. The latter
* means that a new RRR to "break" the
* cluster could not be found.
*
WORK( INDWRK ) = D( IBEGIN )
OPS = OPS + DBLE( IN-1 )
DO 60 K = 1, IN - 1
WORK( INDWRK+K ) = D( IBEGIN+K ) +
$ WORK( INDLLD+K )
60 CONTINUE
DO 70 K = 1, NEWSIZ
IWORK( IINDWK+K-1 ) = 1
70 CONTINUE
DO 80 K = NEWFRS, NEWLST
ISUPPZ( 2*( IBEGIN+K )-3 ) = 1
ISUPPZ( 2*( IBEGIN+K )-2 ) = IN
80 CONTINUE
TEMP( 1 ) = IN
CALL DSTEIN( IN, WORK( INDWRK ),
$ WORK( INDLD+1 ), NEWSIZ,
$ WORK( NEWFRS ),
$ IWORK( IINDWK ), TEMP( 1 ),
$ Z( IBEGIN, NEWFTT ), LDZ,
$ WORK( INDWRK+IN ),
$ IWORK( IINDWK+IN ),
$ IWORK( IINDWK+2*IN ), IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 2
RETURN
END IF
NDONE = NDONE + NEWSIZ
END IF
END IF
END IF
ELSE
MGSCLS = .FALSE.
END IF
IF( NEWSIZ.EQ.1 .OR. MGSCLS ) THEN
KTOT = NEWFTT
DO 100 K = NEWFRS, NEWLST
ITER = 0
90 CONTINUE
LAMBDA = WORK( K )
CALL DLAR1V( IN, 1, IN, LAMBDA, D( IBEGIN ),
$ L( IBEGIN ), WORK( INDLD+1 ),
$ WORK( INDLLD+1 ),
$ GERSCH( 2*OLDIEN+1 ),
$ Z( IBEGIN, KTOT ), ZTZ, MINGMA,
$ IWORK( IINDR+KTOT ),
$ ISUPPZ( 2*KTOT-1 ),
$ WORK( INDWRK ) )
OPS = OPS + DBLE( 4 )
TMP1 = ONE / ZTZ
NRMINV = SQRT( TMP1 )
RESID = ABS( MINGMA )*NRMINV
RQCORR = MINGMA*TMP1
IF( K.EQ.IN ) THEN
GAP = WORK( INDGAP+K-1 )
ELSE IF( K.EQ.1 ) THEN
GAP = WORK( INDGAP+K )
ELSE
GAP = MIN( WORK( INDGAP+K-1 ),
$ WORK( INDGAP+K ) )
END IF
ITER = ITER + 1
OPS = OPS + DBLE( 3 )
IF( RESID.GT.TOL*GAP .AND. ABS( RQCORR ).GT.
$ FOUR*EPS*ABS( LAMBDA ) ) THEN
OPS = OPS + DBLE( 1 )
WORK( K ) = LAMBDA + RQCORR
IF( ITER.LT.MAXITR ) THEN
GO TO 90
END IF
END IF
IWORK( KTOT ) = 1
IF( NEWSIZ.EQ.1 )
$ NDONE = NDONE + 1
OPS = OPS + DBLE( IN )
CALL DSCAL( IN, NRMINV, Z( IBEGIN, KTOT ), 1 )
KTOT = KTOT + 1
100 CONTINUE
IF( NEWSIZ.GT.1 ) THEN
ITMP1 = ISUPPZ( 2*NEWFTT-1 )
ITMP2 = ISUPPZ( 2*NEWFTT )
KTOT = OLDIEN + NEWLST
DO 120 P = NEWFTT + 1, KTOT
DO 110 Q = NEWFTT, P - 1
OPS = OPS + DBLE( 4*IN )
TMP1 = -DDOT( IN, Z( IBEGIN, P ), 1,
$ Z( IBEGIN, Q ), 1 )
CALL DAXPY( IN, TMP1, Z( IBEGIN, Q ), 1,
$ Z( IBEGIN, P ), 1 )
110 CONTINUE
OPS = OPS + DBLE( 3*IN+1 )
TMP1 = ONE / DNRM2( IN, Z( IBEGIN, P ), 1 )
CALL DSCAL( IN, TMP1, Z( IBEGIN, P ), 1 )
ITMP1 = MIN( ITMP1, ISUPPZ( 2*P-1 ) )
ITMP2 = MAX( ITMP2, ISUPPZ( 2*P ) )
120 CONTINUE
DO 130 P = NEWFTT, KTOT
ISUPPZ( 2*P-1 ) = ITMP1
ISUPPZ( 2*P ) = ITMP2
130 CONTINUE
NDONE = NDONE + NEWSIZ
END IF
END IF
NEWFRS = J + 1
140 CONTINUE
150 CONTINUE
NDEPTH = NDEPTH + 1
GO TO 40
END IF
J = 2*IBEGIN
DO 160 I = IBEGIN, IEND
ISUPPZ( J-1 ) = ISUPPZ( J-1 ) + OLDIEN
ISUPPZ( J ) = ISUPPZ( J ) + OLDIEN
J = J + 2
160 CONTINUE
IBEGIN = IEND + 1
170 CONTINUE
*
RETURN
*
* End of DLARRV
*
END
SUBROUTINE DLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK,
$ WORK, INFO )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER INFO, LDU, LDVT, N, SMLSIZ, SQRE
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION D( * ), E( * ), U( LDU, * ), VT( LDVT, * ),
$ WORK( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* Using a divide and conquer approach, DLASD0 computes the singular
* value decomposition (SVD) of a real upper bidiagonal N-by-M
* matrix B with diagonal D and offdiagonal E, where M = N + SQRE.
* The algorithm computes orthogonal matrices U and VT such that
* B = U * S * VT. The singular values S are overwritten on D.
*
* A related subroutine, DLASDA, computes only the singular values,
* and optionally, the singular vectors in compact form.
*
* Arguments
* =========
*
* N (input) INTEGER
* On entry, the row dimension of the upper bidiagonal matrix.
* This is also the dimension of the main diagonal array D.
*
* SQRE (input) INTEGER
* Specifies the column dimension of the bidiagonal matrix.
* = 0: The bidiagonal matrix has column dimension M = N;
* = 1: The bidiagonal matrix has column dimension M = N+1;
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry D contains the main diagonal of the bidiagonal
* matrix.
* On exit D, if INFO = 0, contains its singular values.
*
* E (input) DOUBLE PRECISION array, dimension (M-1)
* Contains the subdiagonal entries of the bidiagonal matrix.
* On exit, E has been destroyed.
*
* U (output) DOUBLE PRECISION array, dimension at least (LDQ, N)
* On exit, U contains the left singular vectors.
*
* LDU (input) INTEGER
* On entry, leading dimension of U.
*
* VT (output) DOUBLE PRECISION array, dimension at least (LDVT, M)
* On exit, VT' contains the right singular vectors.
*
* LDVT (input) INTEGER
* On entry, leading dimension of VT.
*
* SMLSIZ (input) INTEGER
* On entry, maximum size of the subproblems at the
* bottom of the computation tree.
*
* IWORK INTEGER work array.
* Dimension must be at least (8 * N)
*
* WORK DOUBLE PRECISION work array.
* Dimension must be at least (3 * M**2 + 2 * M)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an singular value did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, I1, IC, IDXQ, IDXQC, IM1, INODE, ITEMP, IWK,
$ J, LF, LL, LVL, M, NCC, ND, NDB1, NDIML, NDIMR,
$ NL, NLF, NLP1, NLVL, NR, NRF, NRP1, SQREI
DOUBLE PRECISION ALPHA, BETA
* ..
* .. External Subroutines ..
EXTERNAL DLASD1, DLASDQ, DLASDT, XERBLA
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
INFO = -2
END IF
*
M = N + SQRE
*
IF( LDU.LT.N ) THEN
INFO = -6
ELSE IF( LDVT.LT.M ) THEN
INFO = -8
ELSE IF( SMLSIZ.LT.3 ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLASD0', -INFO )
RETURN
END IF
*
* If the input matrix is too small, call DLASDQ to find the SVD.
*
IF( N.LE.SMLSIZ ) THEN
CALL DLASDQ( 'U', SQRE, N, M, N, 0, D, E, VT, LDVT, U, LDU, U,
$ LDU, WORK, INFO )
RETURN
END IF
*
* Set up the computation tree.
*
INODE = 1
NDIML = INODE + N
NDIMR = NDIML + N
IDXQ = NDIMR + N
IWK = IDXQ + N
CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ),
$ IWORK( NDIMR ), SMLSIZ )
*
* For the nodes on bottom level of the tree, solve
* their subproblems by DLASDQ.
*
NDB1 = ( ND+1 ) / 2
NCC = 0
DO 30 I = NDB1, ND
*
* IC : center row of each node
* NL : number of rows of left subproblem
* NR : number of rows of right subproblem
* NLF: starting row of the left subproblem
* NRF: starting row of the right subproblem
*
I1 = I - 1
IC = IWORK( INODE+I1 )
NL = IWORK( NDIML+I1 )
NLP1 = NL + 1
NR = IWORK( NDIMR+I1 )
NRP1 = NR + 1
NLF = IC - NL
NRF = IC + 1
SQREI = 1
CALL DLASDQ( 'U', SQREI, NL, NLP1, NL, NCC, D( NLF ), E( NLF ),
$ VT( NLF, NLF ), LDVT, U( NLF, NLF ), LDU,
$ U( NLF, NLF ), LDU, WORK, INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
ITEMP = IDXQ + NLF - 2
DO 10 J = 1, NL
IWORK( ITEMP+J ) = J
10 CONTINUE
IF( I.EQ.ND ) THEN
SQREI = SQRE
ELSE
SQREI = 1
END IF
NRP1 = NR + SQREI
CALL DLASDQ( 'U', SQREI, NR, NRP1, NR, NCC, D( NRF ), E( NRF ),
$ VT( NRF, NRF ), LDVT, U( NRF, NRF ), LDU,
$ U( NRF, NRF ), LDU, WORK, INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
ITEMP = IDXQ + IC
DO 20 J = 1, NR
IWORK( ITEMP+J-1 ) = J
20 CONTINUE
30 CONTINUE
*
* Now conquer each subproblem bottom-up.
*
DO 50 LVL = NLVL, 1, -1
*
* Find the first node LF and last node LL on the
* current level LVL.
*
IF( LVL.EQ.1 ) THEN
LF = 1
LL = 1
ELSE
LF = 2**( LVL-1 )
LL = 2*LF - 1
END IF
DO 40 I = LF, LL
IM1 = I - 1
IC = IWORK( INODE+IM1 )
NL = IWORK( NDIML+IM1 )
NR = IWORK( NDIMR+IM1 )
NLF = IC - NL
IF( ( SQRE.EQ.0 ) .AND. ( I.EQ.LL ) ) THEN
SQREI = SQRE
ELSE
SQREI = 1
END IF
IDXQC = IDXQ + NLF - 1
ALPHA = D( IC )
BETA = E( IC )
CALL DLASD1( NL, NR, SQREI, D( NLF ), ALPHA, BETA,
$ U( NLF, NLF ), LDU, VT( NLF, NLF ), LDVT,
$ IWORK( IDXQC ), IWORK( IWK ), WORK, INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
40 CONTINUE
50 CONTINUE
*
RETURN
*
* End of DLASD0
*
END
SUBROUTINE DLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT,
$ IDXQ, IWORK, WORK, INFO )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER INFO, LDU, LDVT, NL, NR, SQRE
DOUBLE PRECISION ALPHA, BETA
* ..
* .. Array Arguments ..
INTEGER IDXQ( * ), IWORK( * )
DOUBLE PRECISION D( * ), U( LDU, * ), VT( LDVT, * ), WORK( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B,
* where N = NL + NR + 1 and M = N + SQRE. DLASD1 is called from DLASD0.
*
* A related subroutine DLASD7 handles the case in which the singular
* values (and the singular vectors in factored form) are desired.
*
* DLASD1 computes the SVD as follows:
*
* ( D1(in) 0 0 0 )
* B = U(in) * ( Z1' a Z2' b ) * VT(in)
* ( 0 0 D2(in) 0 )
*
* = U(out) * ( D(out) 0) * VT(out)
*
* where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M
* with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros
* elsewhere; and the entry b is empty if SQRE = 0.
*
* The left singular vectors of the original matrix are stored in U, and
* the transpose of the right singular vectors are stored in VT, and the
* singular values are in D. The algorithm consists of three stages:
*
* The first stage consists of deflating the size of the problem
* when there are multiple singular values or when there are zeros in
* the Z vector. For each such occurence the dimension of the
* secular equation problem is reduced by one. This stage is
* performed by the routine DLASD2.
*
* The second stage consists of calculating the updated
* singular values. This is done by finding the square roots of the
* roots of the secular equation via the routine DLASD4 (as called
* by DLASD3). This routine also calculates the singular vectors of
* the current problem.
*
* The final stage consists of computing the updated singular vectors
* directly using the updated singular values. The singular vectors
* for the current problem are multiplied with the singular vectors
* from the overall problem.
*
* Arguments
* =========
*
* NL (input) INTEGER
* The row dimension of the upper block. NL >= 1.
*
* NR (input) INTEGER
* The row dimension of the lower block. NR >= 1.
*
* SQRE (input) INTEGER
* = 0: the lower block is an NR-by-NR square matrix.
* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
*
* The bidiagonal matrix has row dimension N = NL + NR + 1,
* and column dimension M = N + SQRE.
*
* D (input/output) DOUBLE PRECISION array,
* dimension (N = NL+NR+1).
* On entry D(1:NL,1:NL) contains the singular values of the
* upper block; and D(NL+2:N) contains the singular values of
* the lower block. On exit D(1:N) contains the singular values
* of the modified matrix.
*
* ALPHA (input) DOUBLE PRECISION
* Contains the diagonal element associated with the added row.
*
* BETA (input) DOUBLE PRECISION
* Contains the off-diagonal element associated with the added
* row.
*
* U (input/output) DOUBLE PRECISION array, dimension(LDU,N)
* On entry U(1:NL, 1:NL) contains the left singular vectors of
* the upper block; U(NL+2:N, NL+2:N) contains the left singular
* vectors of the lower block. On exit U contains the left
* singular vectors of the bidiagonal matrix.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= max( 1, N ).
*
* VT (input/output) DOUBLE PRECISION array, dimension(LDVT,M)
* where M = N + SQRE.
* On entry VT(1:NL+1, 1:NL+1)' contains the right singular
* vectors of the upper block; VT(NL+2:M, NL+2:M)' contains
* the right singular vectors of the lower block. On exit
* VT' contains the right singular vectors of the
* bidiagonal matrix.
*
* LDVT (input) INTEGER
* The leading dimension of the array VT. LDVT >= max( 1, M ).
*
* IDXQ (output) INTEGER array, dimension(N)
* This contains the permutation which will reintegrate the
* subproblem just solved back into sorted order, i.e.
* D( IDXQ( I = 1, N ) ) will be in ascending order.
*
* IWORK (workspace) INTEGER array, dimension( 4 * N )
*
* WORK (workspace) DOUBLE PRECISION array, dimension( 3*M**2 + 2*M )
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an singular value did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
*
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER COLTYP, I, IDX, IDXC, IDXP, IQ, ISIGMA, IU2,
$ IVT2, IZ, K, LDQ, LDU2, LDVT2, M, N, N1, N2
DOUBLE PRECISION ORGNRM
* ..
* .. External Subroutines ..
EXTERNAL DLAMRG, DLASCL, DLASD2, DLASD3, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, ABS, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( NL.LT.1 ) THEN
INFO = -1
ELSE IF( NR.LT.1 ) THEN
INFO = -2
ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
INFO = -3
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLASD1', -INFO )
RETURN
END IF
*
N = NL + NR + 1
M = N + SQRE
*
* The following values are for bookkeeping purposes only. They are
* integer pointers which indicate the portion of the workspace
* used by a particular array in DLASD2 and DLASD3.
*
LDU2 = N
LDVT2 = M
*
IZ = 1
ISIGMA = IZ + M
IU2 = ISIGMA + N
IVT2 = IU2 + LDU2*N
IQ = IVT2 + LDVT2*M
*
IDX = 1
IDXC = IDX + N
COLTYP = IDXC + N
IDXP = COLTYP + N
*
* Scale.
*
ORGNRM = MAX( ABS( ALPHA ), ABS( BETA ) )
D( NL+1 ) = ZERO
DO 10 I = 1, N
IF( ABS( D( I ) ).GT.ORGNRM ) THEN
ORGNRM = ABS( D( I ) )
END IF
10 CONTINUE
OPS = OPS + DBLE( N + 2 )
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
ALPHA = ALPHA / ORGNRM
BETA = BETA / ORGNRM
*
* Deflate singular values.
*
CALL DLASD2( NL, NR, SQRE, K, D, WORK( IZ ), ALPHA, BETA, U, LDU,
$ VT, LDVT, WORK( ISIGMA ), WORK( IU2 ), LDU2,
$ WORK( IVT2 ), LDVT2, IWORK( IDXP ), IWORK( IDX ),
$ IWORK( IDXC ), IDXQ, IWORK( COLTYP ), INFO )
*
* Solve Secular Equation and update singular vectors.
*
LDQ = K
CALL DLASD3( NL, NR, SQRE, K, D, WORK( IQ ), LDQ, WORK( ISIGMA ),
$ U, LDU, WORK( IU2 ), LDU2, VT, LDVT, WORK( IVT2 ),
$ LDVT2, IWORK( IDXC ), IWORK( COLTYP ), WORK( IZ ),
$ INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
*
* Unscale.
*
OPS = OPS + DBLE( N )
CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
*
* Prepare the IDXQ sorting permutation.
*
N1 = K
N2 = N - K
CALL DLAMRG( N1, N2, D, 1, -1, IDXQ )
*
RETURN
*
* End of DLASD1
*
END
SUBROUTINE DLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT,
$ LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX,
$ IDXC, IDXQ, COLTYP, INFO )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
* Courant Institute, NAG Ltd., and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDU, LDU2, LDVT, LDVT2, NL, NR, SQRE
DOUBLE PRECISION ALPHA, BETA
* ..
* .. Array Arguments ..
INTEGER COLTYP( * ), IDX( * ), IDXC( * ), IDXP( * ),
$ IDXQ( * )
DOUBLE PRECISION D( * ), DSIGMA( * ), U( LDU, * ),
$ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ),
$ Z( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLASD2 merges the two sets of singular values together into a single
* sorted set. Then it tries to deflate the size of the problem.
* There are two ways in which deflation can occur: when two or more
* singular values are close together or if there is a tiny entry in the
* Z vector. For each such occurrence the order of the related secular
* equation problem is reduced by one.
*
* DLASD2 is called from DLASD1.
*
* Arguments
* =========
*
* NL (input) INTEGER
* The row dimension of the upper block. NL >= 1.
*
* NR (input) INTEGER
* The row dimension of the lower block. NR >= 1.
*
* SQRE (input) INTEGER
* = 0: the lower block is an NR-by-NR square matrix.
* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
*
* The bidiagonal matrix has N = NL + NR + 1 rows and
* M = N + SQRE >= N columns.
*
* K (output) INTEGER
* Contains the dimension of the non-deflated matrix,
* This is the order of the related secular equation. 1 <= K <=N.
*
* D (input/output) DOUBLE PRECISION array, dimension(N)
* On entry D contains the singular values of the two submatrices
* to be combined. On exit D contains the trailing (N-K) updated
* singular values (those which were deflated) sorted into
* increasing order.
*
* ALPHA (input) DOUBLE PRECISION
* Contains the diagonal element associated with the added row.
*
* BETA (input) DOUBLE PRECISION
* Contains the off-diagonal element associated with the added
* row.
*
* U (input/output) DOUBLE PRECISION array, dimension(LDU,N)
* On entry U contains the left singular vectors of two
* submatrices in the two square blocks with corners at (1,1),
* (NL, NL), and (NL+2, NL+2), (N,N).
* On exit U contains the trailing (N-K) updated left singular
* vectors (those which were deflated) in its last N-K columns.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= N.
*
* Z (output) DOUBLE PRECISION array, dimension(N)
* On exit Z contains the updating row vector in the secular
* equation.
*
* DSIGMA (output) DOUBLE PRECISION array, dimension (N)
* Contains a copy of the diagonal elements (K-1 singular values
* and one zero) in the secular equation.
*
* U2 (output) DOUBLE PRECISION array, dimension(LDU2,N)
* Contains a copy of the first K-1 left singular vectors which
* will be used by DLASD3 in a matrix multiply (DGEMM) to solve
* for the new left singular vectors. U2 is arranged into four
* blocks. The first block contains a column with 1 at NL+1 and
* zero everywhere else; the second block contains non-zero
* entries only at and above NL; the third contains non-zero
* entries only below NL+1; and the fourth is dense.
*
* LDU2 (input) INTEGER
* The leading dimension of the array U2. LDU2 >= N.
*
* VT (input/output) DOUBLE PRECISION array, dimension(LDVT,M)
* On entry VT' contains the right singular vectors of two
* submatrices in the two square blocks with corners at (1,1),
* (NL+1, NL+1), and (NL+2, NL+2), (M,M).
* On exit VT' contains the trailing (N-K) updated right singular
* vectors (those which were deflated) in its last N-K columns.
* In case SQRE =1, the last row of VT spans the right null
* space.
*
* LDVT (input) INTEGER
* The leading dimension of the array VT. LDVT >= M.
*
* VT2 (output) DOUBLE PRECISION array, dimension(LDVT2,N)
* VT2' contains a copy of the first K right singular vectors
* which will be used by DLASD3 in a matrix multiply (DGEMM) to
* solve for the new right singular vectors. VT2 is arranged into
* three blocks. The first block contains a row that corresponds
* to the special 0 diagonal element in SIGMA; the second block
* contains non-zeros only at and before NL +1; the third block
* contains non-zeros only at and after NL +2.
*
* LDVT2 (input) INTEGER
* The leading dimension of the array VT2. LDVT2 >= M.
*
* IDXP (workspace) INTEGER array, dimension(N)
* This will contain the permutation used to place deflated
* values of D at the end of the array. On output IDXP(2:K)
* points to the nondeflated D-values and IDXP(K+1:N)
* points to the deflated singular values.
*
* IDX (workspace) INTEGER array, dimension(N)
* This will contain the permutation used to sort the contents of
* D into ascending order.
*
* IDXC (output) INTEGER array, dimension(N)
* This will contain the permutation used to arrange the columns
* of the deflated U matrix into three groups: the first group
* contains non-zero entries only at and above NL, the second
* contains non-zero entries only below NL+2, and the third is
* dense.
*
* COLTYP (workspace/output) INTEGER array, dimension(N)
* As workspace, this will contain a label which will indicate
* which of the following types a column in the U2 matrix or a
* row in the VT2 matrix is:
* 1 : non-zero in the upper half only
* 2 : non-zero in the lower half only
* 3 : dense
* 4 : deflated
*
* On exit, it is an array of dimension 4, with COLTYP(I) being
* the dimension of the I-th type columns.
*
* IDXQ (input) INTEGER array, dimension(N)
* This contains the permutation which separately sorts the two
* sub-problems in D into ascending order. Note that entries in
* the first hlaf of this permutation must first be moved one
* position backward; and entries in the second half
* must first have NL+1 added to their values.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, EIGHT
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ EIGHT = 8.0D0 )
* ..
* .. Local Arrays ..
INTEGER CTOT( 4 ), PSM( 4 )
* ..
* .. Local Scalars ..
INTEGER CT, I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M,
$ N, NLP1, NLP2
DOUBLE PRECISION C, EPS, HLFTOL, S, TAU, TOL, Z1
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLAPY2
EXTERNAL DLAMCH, DLAPY2
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLACPY, DLAMRG, DLASET, DROT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, ABS, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( NL.LT.1 ) THEN
INFO = -1
ELSE IF( NR.LT.1 ) THEN
INFO = -2
ELSE IF( ( SQRE.NE.1 ) .AND. ( SQRE.NE.0 ) ) THEN
INFO = -3
END IF
*
N = NL + NR + 1
M = N + SQRE
*
IF( LDU.LT.N ) THEN
INFO = -10
ELSE IF( LDVT.LT.M ) THEN
INFO = -12
ELSE IF( LDU2.LT.N ) THEN
INFO = -15
ELSE IF( LDVT2.LT.M ) THEN
INFO = -17
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLASD2', -INFO )
RETURN
END IF
*
NLP1 = NL + 1
NLP2 = NL + 2
*
* Generate the first part of the vector Z; and move the singular
* values in the first part of D one position backward.
*
OPS = OPS + DBLE( 1 + NL )
Z1 = ALPHA*VT( NLP1, NLP1 )
Z( 1 ) = Z1
DO 10 I = NL, 1, -1
Z( I+1 ) = ALPHA*VT( I, NLP1 )
D( I+1 ) = D( I )
IDXQ( I+1 ) = IDXQ( I ) + 1
10 CONTINUE
*
* Generate the second part of the vector Z.
*
OPS = OPS + DBLE( M-NLP2+1 )
DO 20 I = NLP2, M
Z( I ) = BETA*VT( I, NLP2 )
20 CONTINUE
*
* Initialize some reference arrays.
*
DO 30 I = 2, NLP1
COLTYP( I ) = 1
30 CONTINUE
DO 40 I = NLP2, N
COLTYP( I ) = 2
40 CONTINUE
*
* Sort the singular values into increasing order
*
DO 50 I = NLP2, N
IDXQ( I ) = IDXQ( I ) + NLP1
50 CONTINUE
*
* DSIGMA, IDXC, IDXC, and the first column of U2
* are used as storage space.
*
DO 60 I = 2, N
DSIGMA( I ) = D( IDXQ( I ) )
U2( I, 1 ) = Z( IDXQ( I ) )
IDXC( I ) = COLTYP( IDXQ( I ) )
60 CONTINUE
*
CALL DLAMRG( NL, NR, DSIGMA( 2 ), 1, 1, IDX( 2 ) )
*
DO 70 I = 2, N
IDXI = 1 + IDX( I )
D( I ) = DSIGMA( IDXI )
Z( I ) = U2( IDXI, 1 )
COLTYP( I ) = IDXC( IDXI )
70 CONTINUE
*
* Calculate the allowable deflation tolerance
*
OPS = OPS + DBLE( 2 )
EPS = DLAMCH( 'Epsilon' )
TOL = MAX( ABS( ALPHA ), ABS( BETA ) )
TOL = EIGHT*EPS*MAX( ABS( D( N ) ), TOL )
*
* There are 2 kinds of deflation -- first a value in the z-vector
* is small, second two (or more) singular values are very close
* together (their difference is small).
*
* If the value in the z-vector is small, we simply permute the
* array so that the corresponding singular value is moved to the
* end.
*
* If two values in the D-vector are close, we perform a two-sided
* rotation designed to make one of the corresponding z-vector
* entries zero, and then permute the array so that the deflated
* singular value is moved to the end.
*
* If there are multiple singular values then the problem deflates.
* Here the number of equal singular values are found. As each equal
* singular value is found, an elementary reflector is computed to
* rotate the corresponding singular subspace so that the
* corresponding components of Z are zero in this new basis.
*
K = 1
K2 = N + 1
DO 80 J = 2, N
IF( ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
IDXP( K2 ) = J
COLTYP( J ) = 4
IF( J.EQ.N )
$ GO TO 120
ELSE
JPREV = J
GO TO 90
END IF
80 CONTINUE
90 CONTINUE
J = JPREV
100 CONTINUE
J = J + 1
IF( J.GT.N )
$ GO TO 110
IF( ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
IDXP( K2 ) = J
COLTYP( J ) = 4
ELSE
*
* Check if singular values are close enough to allow deflation.
*
OPS = OPS + DBLE( 1 )
IF( ABS( D( J )-D( JPREV ) ).LE.TOL ) THEN
*
* Deflation is possible.
*
S = Z( JPREV )
C = Z( J )
*
* Find sqrt(a**2+b**2) without overflow or
* destructive underflow.
*
OPS = OPS + DBLE( 7 )
TAU = DLAPY2( C, S )
C = C / TAU
S = -S / TAU
Z( J ) = TAU
Z( JPREV ) = ZERO
*
* Apply back the Givens rotation to the left and right
* singular vector matrices.
*
IDXJP = IDXQ( IDX( JPREV )+1 )
IDXJ = IDXQ( IDX( J )+1 )
IF( IDXJP.LE.NLP1 ) THEN
IDXJP = IDXJP - 1
END IF
IF( IDXJ.LE.NLP1 ) THEN
IDXJ = IDXJ - 1
END IF
OPS = OPS + DBLE( 12 )
CALL DROT( N, U( 1, IDXJP ), 1, U( 1, IDXJ ), 1, C, S )
CALL DROT( M, VT( IDXJP, 1 ), LDVT, VT( IDXJ, 1 ), LDVT, C,
$ S )
IF( COLTYP( J ).NE.COLTYP( JPREV ) ) THEN
COLTYP( J ) = 3
END IF
COLTYP( JPREV ) = 4
K2 = K2 - 1
IDXP( K2 ) = JPREV
JPREV = J
ELSE
K = K + 1
U2( K, 1 ) = Z( JPREV )
DSIGMA( K ) = D( JPREV )
IDXP( K ) = JPREV
JPREV = J
END IF
END IF
GO TO 100
110 CONTINUE
*
* Record the last singular value.
*
K = K + 1
U2( K, 1 ) = Z( JPREV )
DSIGMA( K ) = D( JPREV )
IDXP( K ) = JPREV
*
120 CONTINUE
*
* Count up the total number of the various types of columns, then
* form a permutation which positions the four column types into
* four groups of uniform structure (although one or more of these
* groups may be empty).
*
DO 130 J = 1, 4
CTOT( J ) = 0
130 CONTINUE
DO 140 J = 2, N
CT = COLTYP( J )
CTOT( CT ) = CTOT( CT ) + 1
140 CONTINUE
*
* PSM(*) = Position in SubMatrix (of types 1 through 4)
*
PSM( 1 ) = 2
PSM( 2 ) = 2 + CTOT( 1 )
PSM( 3 ) = PSM( 2 ) + CTOT( 2 )
PSM( 4 ) = PSM( 3 ) + CTOT( 3 )
*
* Fill out the IDXC array so that the permutation which it induces
* will place all type-1 columns first, all type-2 columns next,
* then all type-3's, and finally all type-4's, starting from the
* second column. This applies similarly to the rows of VT.
*
DO 150 J = 2, N
JP = IDXP( J )
CT = COLTYP( JP )
IDXC( PSM( CT ) ) = J
PSM( CT ) = PSM( CT ) + 1
150 CONTINUE
*
* Sort the singular values and corresponding singular vectors into
* DSIGMA, U2, and VT2 respectively. The singular values/vectors
* which were not deflated go into the first K slots of DSIGMA, U2,
* and VT2 respectively, while those which were deflated go into the
* last N - K slots, except that the first column/row will be treated
* separately.
*
DO 160 J = 2, N
JP = IDXP( J )
DSIGMA( J ) = D( JP )
IDXJ = IDXQ( IDX( IDXP( IDXC( J ) ) )+1 )
IF( IDXJ.LE.NLP1 ) THEN
IDXJ = IDXJ - 1
END IF
CALL DCOPY( N, U( 1, IDXJ ), 1, U2( 1, J ), 1 )
CALL DCOPY( M, VT( IDXJ, 1 ), LDVT, VT2( J, 1 ), LDVT2 )
160 CONTINUE
*
* Determine DSIGMA(1), DSIGMA(2) and Z(1)
*
OPS = OPS + DBLE( 1 )
DSIGMA( 1 ) = ZERO
HLFTOL = TOL / TWO
IF( ABS( DSIGMA( 2 ) ).LE.HLFTOL )
$ DSIGMA( 2 ) = HLFTOL
IF( M.GT.N ) THEN
OPS = OPS + DBLE( 5 )
Z( 1 ) = DLAPY2( Z1, Z( M ) )
IF( Z( 1 ).LE.TOL ) THEN
C = ONE
S = ZERO
Z( 1 ) = TOL
ELSE
OPS = OPS + DBLE( 2 )
C = Z1 / Z( 1 )
S = Z( M ) / Z( 1 )
END IF
ELSE
IF( ABS( Z1 ).LE.TOL ) THEN
Z( 1 ) = TOL
ELSE
Z( 1 ) = Z1
END IF
END IF
*
* Move the rest of the updating row to Z.
*
CALL DCOPY( K-1, U2( 2, 1 ), 1, Z( 2 ), 1 )
*
* Determine the first column of U2, the first row of VT2 and the
* last row of VT.
*
CALL DLASET( 'A', N, 1, ZERO, ZERO, U2, LDU2 )
U2( NLP1, 1 ) = ONE
IF( M.GT.N ) THEN
OPS = OPS + DBLE( NLP1*2 )
DO 170 I = 1, NLP1
VT( M, I ) = -S*VT( NLP1, I )
VT2( 1, I ) = C*VT( NLP1, I )
170 CONTINUE
OPS = OPS + DBLE( (M-NLP2+1)*2 )
DO 180 I = NLP2, M
VT2( 1, I ) = S*VT( M, I )
VT( M, I ) = C*VT( M, I )
180 CONTINUE
ELSE
CALL DCOPY( M, VT( NLP1, 1 ), LDVT, VT2( 1, 1 ), LDVT2 )
END IF
IF( M.GT.N ) THEN
CALL DCOPY( M, VT( M, 1 ), LDVT, VT2( M, 1 ), LDVT2 )
END IF
*
* The deflated singular values and their corresponding vectors go
* into the back of D, U, and V respectively.
*
IF( N.GT.K ) THEN
CALL DCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 )
CALL DLACPY( 'A', N, N-K, U2( 1, K+1 ), LDU2, U( 1, K+1 ),
$ LDU )
CALL DLACPY( 'A', N-K, M, VT2( K+1, 1 ), LDVT2, VT( K+1, 1 ),
$ LDVT )
END IF
*
* Copy CTOT into COLTYP for referencing in DLASD3.
*
DO 190 J = 1, 4
COLTYP( J ) = CTOT( J )
190 CONTINUE
*
RETURN
*
* End of DLASD2
*
END
SUBROUTINE DLASD3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2,
$ LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z,
$ INFO )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
* Courant Institute, NAG Ltd., and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDQ, LDU, LDU2, LDVT, LDVT2, NL, NR,
$ SQRE
* ..
* .. Array Arguments ..
INTEGER CTOT( * ), IDXC( * )
DOUBLE PRECISION D( * ), DSIGMA( * ), Q( LDQ, * ), U( LDU, * ),
$ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ),
$ Z( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLASD3 finds all the square roots of the roots of the secular
* equation, as defined by the values in D and Z. It makes the
* appropriate calls to DLASD4 and then updates the singular
* vectors by matrix multiplication.
*
* This code makes very mild assumptions about floating point
* arithmetic. It will work on machines with a guard digit in
* add/subtract, or on those binary machines without guard digits
* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
* It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* DLASD3 is called from DLASD1.
*
* Arguments
* =========
*
* NL (input) INTEGER
* The row dimension of the upper block. NL >= 1.
*
* NR (input) INTEGER
* The row dimension of the lower block. NR >= 1.
*
* SQRE (input) INTEGER
* = 0: the lower block is an NR-by-NR square matrix.
* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
*
* The bidiagonal matrix has N = NL + NR + 1 rows and
* M = N + SQRE >= N columns.
*
* K (input) INTEGER
* The size of the secular equation, 1 =< K = < N.
*
* D (output) DOUBLE PRECISION array, dimension(K)
* On exit the square roots of the roots of the secular equation,
* in ascending order.
*
* Q (workspace) DOUBLE PRECISION array,
* dimension at least (LDQ,K).
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= K.
*
* DSIGMA (input) DOUBLE PRECISION array, dimension(K)
* The first K elements of this array contain the old roots
* of the deflated updating problem. These are the poles
* of the secular equation.
*
* U (input) DOUBLE PRECISION array, dimension (LDU, N)
* The last N - K columns of this matrix contain the deflated
* left singular vectors.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= N.
*
* U2 (input) DOUBLE PRECISION array, dimension (LDU2, N)
* The first K columns of this matrix contain the non-deflated
* left singular vectors for the split problem.
*
* LDU2 (input) INTEGER
* The leading dimension of the array U2. LDU2 >= N.
*
* VT (input) DOUBLE PRECISION array, dimension (LDVT, M)
* The last M - K columns of VT' contain the deflated
* right singular vectors.
*
* LDVT (input) INTEGER
* The leading dimension of the array VT. LDVT >= N.
*
* VT2 (input) DOUBLE PRECISION array, dimension (LDVT2, N)
* The first K columns of VT2' contain the non-deflated
* right singular vectors for the split problem.
*
* LDVT2 (input) INTEGER
* The leading dimension of the array VT2. LDVT2 >= N.
*
* IDXC (input) INTEGER array, dimension ( N )
* The permutation used to arrange the columns of U (and rows of
* VT) into three groups: the first group contains non-zero
* entries only at and above (or before) NL +1; the second
* contains non-zero entries only at and below (or after) NL+2;
* and the third is dense. The first column of U and the row of
* VT are treated separately, however.
*
* The rows of the singular vectors found by DLASD4
* must be likewise permuted before the matrix multiplies can
* take place.
*
* CTOT (input) INTEGER array, dimension ( 4 )
* A count of the total number of the various types of columns
* in U (or rows in VT), as described in IDXC. The fourth column
* type is any column which has been deflated.
*
* Z (input) DOUBLE PRECISION array, dimension (K)
* The first K elements of this array contain the components
* of the deflation-adjusted updating row vector.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an singular value did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO, NEGONE
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, NEGONE = -1.0D0 )
* ..
* .. Local Scalars ..
INTEGER CTEMP, I, J, JC, KTEMP, M, N, NLP1, NLP2, NRP1
DOUBLE PRECISION RHO, TEMP
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMC3, DNRM2, DOPBL3
EXTERNAL DLAMC3, DNRM2, DOPBL3
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMM, DLACPY, DLASCL, DLASD4, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, ABS, MAX, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( NL.LT.1 ) THEN
INFO = -1
ELSE IF( NR.LT.1 ) THEN
INFO = -2
ELSE IF( ( SQRE.NE.1 ) .AND. ( SQRE.NE.0 ) ) THEN
INFO = -3
END IF
*
N = NL + NR + 1
M = N + SQRE
NLP1 = NL + 1
NLP2 = NL + 2
*
IF( ( K.LT.1 ) .OR. ( K.GT.N ) ) THEN
INFO = -4
ELSE IF( LDQ.LT.K ) THEN
INFO = -7
ELSE IF( LDU.LT.N ) THEN
INFO = -10
ELSE IF( LDU2.LT.N ) THEN
INFO = -12
ELSE IF( LDVT.LT.M ) THEN
INFO = -14
ELSE IF( LDVT2.LT.M ) THEN
INFO = -16
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLASD3', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( K.EQ.1 ) THEN
D( 1 ) = ABS( Z( 1 ) )
CALL DCOPY( M, VT2( 1, 1 ), LDVT2, VT( 1, 1 ), LDVT )
IF( Z( 1 ).GT.ZERO ) THEN
CALL DCOPY( N, U2( 1, 1 ), 1, U( 1, 1 ), 1 )
ELSE
DO 10 I = 1, N
U( I, 1 ) = -U2( I, 1 )
10 CONTINUE
END IF
RETURN
END IF
*
* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can
* be computed with high relative accuracy (barring over/underflow).
* This is a problem on machines without a guard digit in
* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I),
* which on any of these machines zeros out the bottommost
* bit of DSIGMA(I) if it is 1; this makes the subsequent
* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation
* occurs. On binary machines with a guard digit (almost all
* machines) it does not change DSIGMA(I) at all. On hexadecimal
* and decimal machines with a guard digit, it slightly
* changes the bottommost bits of DSIGMA(I). It does not account
* for hexadecimal or decimal machines without guard digits
* (we know of none). We use a subroutine call to compute
* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating
* this code.
*
DO 20 I = 1, K
DSIGMA( I ) = DLAMC3( DSIGMA( I ), DSIGMA( I ) ) - DSIGMA( I )
20 CONTINUE
*
* Keep a copy of Z.
*
CALL DCOPY( K, Z, 1, Q, 1 )
*
* Normalize Z.
*
OPS = OPS + DBLE( K*3 + 1)
RHO = DNRM2( K, Z, 1 )
CALL DLASCL( 'G', 0, 0, RHO, ONE, K, 1, Z, K, INFO )
RHO = RHO*RHO
*
* Find the new singular values.
*
DO 30 J = 1, K
CALL DLASD4( K, J, DSIGMA, Z, U( 1, J ), RHO, D( J ),
$ VT( 1, J ), INFO )
*
* If the zero finder fails, the computation is terminated.
*
IF( INFO.NE.0 ) THEN
RETURN
END IF
30 CONTINUE
*
* Compute updated Z.
*
OPS = OPS + DBLE( K*2 )
DO 60 I = 1, K
Z( I ) = U( I, K )*VT( I, K )
OPS = OPS + DBLE( (I-1)*6 )
DO 40 J = 1, I - 1
Z( I ) = Z( I )*( U( I, J )*VT( I, J ) /
$ ( DSIGMA( I )-DSIGMA( J ) ) /
$ ( DSIGMA( I )+DSIGMA( J ) ) )
40 CONTINUE
OPS = OPS + DBLE( (K-I)*6 )
DO 50 J = I, K - 1
Z( I ) = Z( I )*( U( I, J )*VT( I, J ) /
$ ( DSIGMA( I )-DSIGMA( J+1 ) ) /
$ ( DSIGMA( I )+DSIGMA( J+1 ) ) )
50 CONTINUE
Z( I ) = SIGN( SQRT( ABS( Z( I ) ) ), Q( I, 1 ) )
60 CONTINUE
*
* Compute left singular vectors of the modified diagonal matrix,
* and store related information for the right singular vectors.
*
OPS = OPS + DBLE( K*(3+K*2) + MAX(0,(K-1)*4) )
DO 90 I = 1, K
VT( 1, I ) = Z( 1 ) / U( 1, I ) / VT( 1, I )
U( 1, I ) = NEGONE
DO 70 J = 2, K
VT( J, I ) = Z( J ) / U( J, I ) / VT( J, I )
U( J, I ) = DSIGMA( J )*VT( J, I )
70 CONTINUE
TEMP = DNRM2( K, U( 1, I ), 1 )
Q( 1, I ) = U( 1, I ) / TEMP
DO 80 J = 2, K
JC = IDXC( J )
Q( J, I ) = U( JC, I ) / TEMP
80 CONTINUE
90 CONTINUE
*
* Update the left singular vector matrix.
*
IF( K.EQ.2 ) THEN
OPS = OPS + DOPBL3( 'DGEMM ', N, K, K )
CALL DGEMM( 'N', 'N', N, K, K, ONE, U2, LDU2, Q, LDQ, ZERO, U,
$ LDU )
GO TO 100
END IF
IF( CTOT( 1 ).GT.0 ) THEN
OPS = OPS + DOPBL3( 'DGEMM ', NL, K, CTOT( 1 ) )
CALL DGEMM( 'N', 'N', NL, K, CTOT( 1 ), ONE, U2( 1, 2 ), LDU2,
$ Q( 2, 1 ), LDQ, ZERO, U( 1, 1 ), LDU )
IF( CTOT( 3 ).GT.0 ) THEN
KTEMP = 2 + CTOT( 1 ) + CTOT( 2 )
OPS = OPS + DOPBL3( 'DGEMM ', NL, K, CTOT( 3 ) )
CALL DGEMM( 'N', 'N', NL, K, CTOT( 3 ), ONE, U2( 1, KTEMP ),
$ LDU2, Q( KTEMP, 1 ), LDQ, ONE, U( 1, 1 ), LDU )
END IF
ELSE IF( CTOT( 3 ).GT.0 ) THEN
KTEMP = 2 + CTOT( 1 ) + CTOT( 2 )
OPS = OPS + DOPBL3( 'DGEMM ', NL, K, CTOT( 3 ) )
CALL DGEMM( 'N', 'N', NL, K, CTOT( 3 ), ONE, U2( 1, KTEMP ),
$ LDU2, Q( KTEMP, 1 ), LDQ, ZERO, U( 1, 1 ), LDU )
ELSE
CALL DLACPY( 'F', NL, K, U2, LDU2, U, LDU )
END IF
CALL DCOPY( K, Q( 1, 1 ), LDQ, U( NLP1, 1 ), LDU )
KTEMP = 2 + CTOT( 1 )
CTEMP = CTOT( 2 ) + CTOT( 3 )
OPS = OPS + DOPBL3( 'DGEMM ', NR, K, CTEMP )
CALL DGEMM( 'N', 'N', NR, K, CTEMP, ONE, U2( NLP2, KTEMP ), LDU2,
$ Q( KTEMP, 1 ), LDQ, ZERO, U( NLP2, 1 ), LDU )
*
* Generate the right singular vectors.
*
100 CONTINUE
OPS = OPS + DBLE( K*(K*2+1) + MAX(0,K-1) )
DO 120 I = 1, K
TEMP = DNRM2( K, VT( 1, I ), 1 )
Q( I, 1 ) = VT( 1, I ) / TEMP
DO 110 J = 2, K
JC = IDXC( J )
Q( I, J ) = VT( JC, I ) / TEMP
110 CONTINUE
120 CONTINUE
*
* Update the right singular vector matrix.
*
IF( K.EQ.2 ) THEN
OPS = OPS + DOPBL3( 'DGEMM ', K, M, K )
CALL DGEMM( 'N', 'N', K, M, K, ONE, Q, LDQ, VT2, LDVT2, ZERO,
$ VT, LDVT )
RETURN
END IF
KTEMP = 1 + CTOT( 1 )
OPS = OPS + DOPBL3( 'DGEMM ', K, NLP1, KTEMP )
CALL DGEMM( 'N', 'N', K, NLP1, KTEMP, ONE, Q( 1, 1 ), LDQ,
$ VT2( 1, 1 ), LDVT2, ZERO, VT( 1, 1 ), LDVT )
KTEMP = 2 + CTOT( 1 ) + CTOT( 2 )
OPS = OPS + DOPBL3( 'DGEMM ', K, NLP1, CTOT( 3 ) )
IF( KTEMP.LE.LDVT2 )
$ CALL DGEMM( 'N', 'N', K, NLP1, CTOT( 3 ), ONE, Q( 1, KTEMP ),
$ LDQ, VT2( KTEMP, 1 ), LDVT2, ONE, VT( 1, 1 ),
$ LDVT )
*
KTEMP = CTOT( 1 ) + 1
NRP1 = NR + SQRE
IF( KTEMP.GT.1 ) THEN
DO 130 I = 1, K
Q( I, KTEMP ) = Q( I, 1 )
130 CONTINUE
DO 140 I = NLP2, M
VT2( KTEMP, I ) = VT2( 1, I )
140 CONTINUE
END IF
CTEMP = 1 + CTOT( 2 ) + CTOT( 3 )
OPS = OPS + DOPBL3( 'DGEMM ', K, NRP1, CTEMP )
CALL DGEMM( 'N', 'N', K, NRP1, CTEMP, ONE, Q( 1, KTEMP ), LDQ,
$ VT2( KTEMP, NLP2 ), LDVT2, ZERO, VT( 1, NLP2 ), LDVT )
*
RETURN
*
* End of DLASD3
*
END
SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
* Courant Institute, NAG Ltd., and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
INTEGER I, INFO, N
DOUBLE PRECISION RHO, SIGMA
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), DELTA( * ), WORK( * ), Z( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* This subroutine computes the square root of the I-th updated
* eigenvalue of a positive symmetric rank-one modification to
* a positive diagonal matrix whose entries are given as the squares
* of the corresponding entries in the array d, and that
*
* 0 <= D(i) < D(j) for i < j
*
* and that RHO > 0. This is arranged by the calling routine, and is
* no loss in generality. The rank-one modified system is thus
*
* diag( D ) * diag( D ) + RHO * Z * Z_transpose.
*
* where we assume the Euclidean norm of Z is 1.
*
* The method consists of approximating the rational functions in the
* secular equation by simpler interpolating rational functions.
*
* Arguments
* =========
*
* N (input) INTEGER
* The length of all arrays.
*
* I (input) INTEGER
* The index of the eigenvalue to be computed. 1 <= I <= N.
*
* D (input) DOUBLE PRECISION array, dimension ( N )
* The original eigenvalues. It is assumed that they are in
* order, 0 <= D(I) < D(J) for I < J.
*
* Z (input) DOUBLE PRECISION array, dimension ( N )
* The components of the updating vector.
*
* DELTA (output) DOUBLE PRECISION array, dimension ( N )
* If N .ne. 1, DELTA contains (D(j) - sigma_I) in its j-th
* component. If N = 1, then DELTA(1) = 1. The vector DELTA
* contains the information necessary to construct the
* (singular) eigenvectors.
*
* RHO (input) DOUBLE PRECISION
* The scalar in the symmetric updating formula.
*
* SIGMA (output) DOUBLE PRECISION
* The computed lambda_I, the I-th updated eigenvalue.
*
* WORK (workspace) DOUBLE PRECISION array, dimension ( N )
* If N .ne. 1, WORK contains (D(j) + sigma_I) in its j-th
* component. If N = 1, then WORK( 1 ) = 1.
*
* INFO (output) INTEGER
* = 0: successful exit
* > 0: if INFO = 1, the updating process failed.
*
* Internal Parameters
* ===================
*
* Logical variable ORGATI (origin-at-i?) is used for distinguishing
* whether D(i) or D(i+1) is treated as the origin.
*
* ORGATI = .true. origin at i
* ORGATI = .false. origin at i+1
*
* Logical variable SWTCH3 (switch-for-3-poles?) is for noting
* if we are working with THREE poles!
*
* MAXIT is the maximum number of iterations allowed for each
* eigenvalue.
*
* Further Details
* ===============
*
* Based on contributions by
* Ren-Cang Li, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXIT
PARAMETER ( MAXIT = 20 )
DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0,
$ TEN = 10.0D0 )
* ..
* .. Local Scalars ..
LOGICAL ORGATI, SWTCH, SWTCH3
INTEGER II, IIM1, IIP1, IP1, ITER, J, NITER
DOUBLE PRECISION A, B, C, DELSQ, DELSQ2, DPHI, DPSI, DTIIM,
$ DTIIP, DTIPSQ, DTISQ, DTNSQ, DTNSQ1, DW, EPS,
$ ERRETM, ETA, PHI, PREW, PSI, RHOINV, SG2LB,
$ SG2UB, TAU, TEMP, TEMP1, TEMP2, W
* ..
* .. Local Arrays ..
DOUBLE PRECISION DD( 3 ), ZZ( 3 )
* ..
* .. External Subroutines ..
EXTERNAL DLAED6, DLASD5
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Since this routine is called in an inner loop, we do no argument
* checking.
*
* Quick return for N=1 and 2.
*
INFO = 0
IF( N.EQ.1 ) THEN
*
* Presumably, I=1 upon entry
*
OPS = OPS + DBLE( 5 )
SIGMA = SQRT( D( 1 )*D( 1 )+RHO*Z( 1 )*Z( 1 ) )
DELTA( 1 ) = ONE
WORK( 1 ) = ONE
RETURN
END IF
IF( N.EQ.2 ) THEN
CALL DLASD5( I, D, Z, DELTA, RHO, SIGMA, WORK )
RETURN
END IF
*
* Compute machine epsilon
*
EPS = DLAMCH( 'Epsilon' )
OPS = OPS + DBLE( 1 )
RHOINV = ONE / RHO
*
* The case I = N
*
IF( I.EQ.N ) THEN
*
* Initialize some basic variables
*
II = N - 1
NITER = 1
*
* Calculate initial guess
*
OPS = OPS + DBLE( 1 )
TEMP = RHO / TWO
*
* If ||Z||_2 is not one, then TEMP should be set to
* RHO * ||Z||_2^2 / TWO
*
OPS = OPS + DBLE( 5 + 4*N )
TEMP1 = TEMP / ( D( N )+SQRT( D( N )*D( N )+TEMP ) )
DO 10 J = 1, N
WORK( J ) = D( J ) + D( N ) + TEMP1
DELTA( J ) = ( D( J )-D( N ) ) - TEMP1
10 CONTINUE
*
PSI = ZERO
OPS = OPS + DBLE( 4*( N-2 ) )
DO 20 J = 1, N - 2
PSI = PSI + Z( J )*Z( J ) / ( DELTA( J )*WORK( J ) )
20 CONTINUE
*
OPS = OPS + DBLE( 9 )
C = RHOINV + PSI
W = C + Z( II )*Z( II ) / ( DELTA( II )*WORK( II ) ) +
$ Z( N )*Z( N ) / ( DELTA( N )*WORK( N ) )
*
IF( W.LE.ZERO ) THEN
OPS = OPS + DBLE( 14 )
TEMP1 = SQRT( D( N )*D( N )+RHO )
TEMP = Z( N-1 )*Z( N-1 ) / ( ( D( N-1 )+TEMP1 )*
$ ( D( N )-D( N-1 )+RHO / ( D( N )+TEMP1 ) ) ) +
$ Z( N )*Z( N ) / RHO
*
* The following TAU is to approximate
* SIGMA_n^2 - D( N )*D( N )
*
IF( C.LE.TEMP ) THEN
TAU = RHO
ELSE
OPS = OPS + DBLE( 10 )
DELSQ = ( D( N )-D( N-1 ) )*( D( N )+D( N-1 ) )
A = -C*DELSQ + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
B = Z( N )*Z( N )*DELSQ
IF( A.LT.ZERO ) THEN
OPS = OPS + DBLE( 8 )
TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
ELSE
OPS = OPS + DBLE( 8 )
TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
END IF
END IF
*
* It can be proved that
* D(N)^2+RHO/2 <= SIGMA_n^2 < D(N)^2+TAU <= D(N)^2+RHO
*
ELSE
OPS = OPS + DBLE( 10 )
DELSQ = ( D( N )-D( N-1 ) )*( D( N )+D( N-1 ) )
A = -C*DELSQ + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
B = Z( N )*Z( N )*DELSQ
*
* The following TAU is to approximate
* SIGMA_n^2 - D( N )*D( N )
*
IF( A.LT.ZERO ) THEN
OPS = OPS + DBLE( 8 )
TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
ELSE
OPS = OPS + DBLE( 8 )
TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
END IF
*
* It can be proved that
* D(N)^2 < D(N)^2+TAU < SIGMA(N)^2 < D(N)^2+RHO/2
*
END IF
*
* The following ETA is to approximate SIGMA_n - D( N )
*
OPS = OPS + DBLE( 5 )
ETA = TAU / ( D( N )+SQRT( D( N )*D( N )+TAU ) )
*
OPS = OPS + DBLE( 1 + 4*N )
SIGMA = D( N ) + ETA
DO 30 J = 1, N
DELTA( J ) = ( D( J )-D( I ) ) - ETA
WORK( J ) = D( J ) + D( I ) + ETA
30 CONTINUE
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
OPS = OPS + DBLE( II*7 )
DO 40 J = 1, II
TEMP = Z( J ) / ( DELTA( J )*WORK( J ) )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
40 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
OPS = OPS + DBLE( 14 )
TEMP = Z( N ) / ( DELTA( N )*WORK( N ) )
PHI = Z( N )*TEMP
DPHI = TEMP*TEMP
ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
$ ABS( TAU )*( DPSI+DPHI )
*
W = RHOINV + PHI + PSI
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
GO TO 240
END IF
*
* Calculate the new step
*
NITER = NITER + 1
OPS = OPS + DBLE( 14 )
DTNSQ1 = WORK( N-1 )*DELTA( N-1 )
DTNSQ = WORK( N )*DELTA( N )
C = W - DTNSQ1*DPSI - DTNSQ*DPHI
A = ( DTNSQ+DTNSQ1 )*W - DTNSQ*DTNSQ1*( DPSI+DPHI )
B = DTNSQ*DTNSQ1*W
IF( C.LT.ZERO )
$ C = ABS( C )
IF( C.EQ.ZERO ) THEN
OPS = OPS + DBLE( 2 )
ETA = RHO - SIGMA*SIGMA
ELSE IF( A.GE.ZERO ) THEN
OPS = OPS + DBLE( 8 )
ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
OPS = OPS + DBLE( 8 )
ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
OPS = OPS + DBLE( 1 )
IF( W*ETA.GT.ZERO ) THEN
OPS = OPS + DBLE( 2 )
ETA = -W / ( DPSI+DPHI )
END IF
TEMP = ETA - DTNSQ
IF( TEMP.GT.RHO ) THEN
OPS = OPS + DBLE( 1 )
ETA = RHO + DTNSQ
END IF
*
OPS = OPS + DBLE( 6 + 2*N + 1 )
TAU = TAU + ETA
ETA = ETA / ( SIGMA+SQRT( ETA+SIGMA*SIGMA ) )
DO 50 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
WORK( J ) = WORK( J ) + ETA
50 CONTINUE
*
SIGMA = SIGMA + ETA
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
OPS = OPS + DBLE( 7*II )
DO 60 J = 1, II
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
60 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
OPS = OPS + DBLE( 14 )
TEMP = Z( N ) / ( WORK( N )*DELTA( N ) )
PHI = Z( N )*TEMP
DPHI = TEMP*TEMP
ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
$ ABS( TAU )*( DPSI+DPHI )
*
W = RHOINV + PHI + PSI
*
* Main loop to update the values of the array DELTA
*
ITER = NITER + 1
*
DO 90 NITER = ITER, MAXIT
*
* Test for convergence
*
OPS = OPS + DBLE( 1 )
IF( ABS( W ).LE.EPS*ERRETM ) THEN
GO TO 240
END IF
*
* Calculate the new step
*
OPS = OPS + DBLE( 22 )
DTNSQ1 = WORK( N-1 )*DELTA( N-1 )
DTNSQ = WORK( N )*DELTA( N )
C = W - DTNSQ1*DPSI - DTNSQ*DPHI
A = ( DTNSQ+DTNSQ1 )*W - DTNSQ1*DTNSQ*( DPSI+DPHI )
B = DTNSQ1*DTNSQ*W
IF( A.GE.ZERO ) THEN
ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
OPS = OPS + DBLE( 2 )
IF( W*ETA.GT.ZERO ) THEN
OPS = OPS + DBLE( 2 )
ETA = -W / ( DPSI+DPHI )
END IF
TEMP = ETA - DTNSQ
IF( TEMP.LE.ZERO ) THEN
OPS = OPS + DBLE( 1 )
ETA = ETA / TWO
END IF
*
OPS = OPS + DBLE( 6 + 2*N + 1 )
TAU = TAU + ETA
ETA = ETA / ( SIGMA+SQRT( ETA+SIGMA*SIGMA ) )
DO 70 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
WORK( J ) = WORK( J ) + ETA
70 CONTINUE
*
SIGMA = SIGMA + ETA
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
OPS = OPS + DBLE( 7*II )
DO 80 J = 1, II
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
80 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
OPS = OPS + DBLE( 14 )
TEMP = Z( N ) / ( WORK( N )*DELTA( N ) )
PHI = Z( N )*TEMP
DPHI = TEMP*TEMP
ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
$ ABS( TAU )*( DPSI+DPHI )
*
W = RHOINV + PHI + PSI
90 CONTINUE
*
* Return with INFO = 1, NITER = MAXIT and not converged
*
INFO = 1
GO TO 240
*
* End for the case I = N
*
ELSE
*
* The case for I < N
*
NITER = 1
IP1 = I + 1
*
* Calculate initial guess
*
OPS = OPS + DBLE( 9 + 4*N )
DELSQ = ( D( IP1 )-D( I ) )*( D( IP1 )+D( I ) )
DELSQ2 = DELSQ / TWO
TEMP = DELSQ2 / ( D( I )+SQRT( D( I )*D( I )+DELSQ2 ) )
DO 100 J = 1, N
WORK( J ) = D( J ) + D( I ) + TEMP
DELTA( J ) = ( D( J )-D( I ) ) - TEMP
100 CONTINUE
*
PSI = ZERO
OPS = OPS + DBLE( 4*( I-1 ) )
DO 110 J = 1, I - 1
PSI = PSI + Z( J )*Z( J ) / ( WORK( J )*DELTA( J ) )
110 CONTINUE
*
PHI = ZERO
OPS = OPS + DBLE( 4*( N-I-1 ) + 10 )
DO 120 J = N, I + 2, -1
PHI = PHI + Z( J )*Z( J ) / ( WORK( J )*DELTA( J ) )
120 CONTINUE
C = RHOINV + PSI + PHI
W = C + Z( I )*Z( I ) / ( WORK( I )*DELTA( I ) ) +
$ Z( IP1 )*Z( IP1 ) / ( WORK( IP1 )*DELTA( IP1 ) )
*
IF( W.GT.ZERO ) THEN
*
* d(i)^2 < the ith sigma^2 < (d(i)^2+d(i+1)^2)/2
*
* We choose d(i) as origin.
*
OPS = OPS + DBLE( 20 )
ORGATI = .TRUE.
SG2LB = ZERO
SG2UB = DELSQ2
A = C*DELSQ + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 )
B = Z( I )*Z( I )*DELSQ
IF( A.GT.ZERO ) THEN
TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
ELSE
TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
END IF
*
* TAU now is an estimation of SIGMA^2 - D( I )^2. The
* following, however, is the corresponding estimation of
* SIGMA - D( I ).
*
ETA = TAU / ( D( I )+SQRT( D( I )*D( I )+TAU ) )
ELSE
*
* (d(i)^2+d(i+1)^2)/2 <= the ith sigma^2 < d(i+1)^2/2
*
* We choose d(i+1) as origin.
*
OPS = OPS + DBLE( 20 )
ORGATI = .FALSE.
SG2LB = -DELSQ2
SG2UB = ZERO
A = C*DELSQ - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 )
B = Z( IP1 )*Z( IP1 )*DELSQ
IF( A.LT.ZERO ) THEN
TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) )
ELSE
TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C )
END IF
*
* TAU now is an estimation of SIGMA^2 - D( IP1 )^2. The
* following, however, is the corresponding estimation of
* SIGMA - D( IP1 ).
*
ETA = TAU / ( D( IP1 )+SQRT( ABS( D( IP1 )*D( IP1 )+
$ TAU ) ) )
END IF
*
OPS = OPS + DBLE( 1 + 4*N )
IF( ORGATI ) THEN
II = I
SIGMA = D( I ) + ETA
DO 130 J = 1, N
WORK( J ) = D( J ) + D( I ) + ETA
DELTA( J ) = ( D( J )-D( I ) ) - ETA
130 CONTINUE
ELSE
II = I + 1
SIGMA = D( IP1 ) + ETA
DO 140 J = 1, N
WORK( J ) = D( J ) + D( IP1 ) + ETA
DELTA( J ) = ( D( J )-D( IP1 ) ) - ETA
140 CONTINUE
END IF
IIM1 = II - 1
IIP1 = II + 1
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
OPS = OPS + DBLE( 7*IIM1 )
DO 150 J = 1, IIM1
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
150 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
DPHI = ZERO
PHI = ZERO
OPS = OPS + DBLE( 7*( N-IIP1+1 ) + 2 )
DO 160 J = N, IIP1, -1
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PHI = PHI + Z( J )*TEMP
DPHI = DPHI + TEMP*TEMP
ERRETM = ERRETM + PHI
160 CONTINUE
*
W = RHOINV + PHI + PSI
*
* W is the value of the secular function with
* its ii-th element removed.
*
SWTCH3 = .FALSE.
IF( ORGATI ) THEN
IF( W.LT.ZERO )
$ SWTCH3 = .TRUE.
ELSE
IF( W.GT.ZERO )
$ SWTCH3 = .TRUE.
END IF
IF( II.EQ.1 .OR. II.EQ.N )
$ SWTCH3 = .FALSE.
*
OPS = OPS + DBLE( 17 )
TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
DW = DPSI + DPHI + TEMP*TEMP
TEMP = Z( II )*TEMP
W = W + TEMP
ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
$ THREE*ABS( TEMP ) + ABS( TAU )*DW
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
GO TO 240
END IF
*
IF( W.LE.ZERO ) THEN
SG2LB = MAX( SG2LB, TAU )
ELSE
SG2UB = MIN( SG2UB, TAU )
END IF
*
* Calculate the new step
*
NITER = NITER + 1
IF( .NOT.SWTCH3 ) THEN
OPS = OPS + DBLE( 15 )
DTIPSQ = WORK( IP1 )*DELTA( IP1 )
DTISQ = WORK( I )*DELTA( I )
IF( ORGATI ) THEN
C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2
ELSE
C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2
END IF
A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW
B = DTIPSQ*DTISQ*W
IF( C.EQ.ZERO ) THEN
IF( A.EQ.ZERO ) THEN
OPS = OPS + DBLE( 5 )
IF( ORGATI ) THEN
A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ*( DPSI+DPHI )
ELSE
A = Z( IP1 )*Z( IP1 ) + DTISQ*DTISQ*( DPSI+DPHI )
END IF
END IF
OPS = OPS + DBLE( 1 )
ETA = B / A
ELSE IF( A.LE.ZERO ) THEN
OPS = OPS + DBLE( 8 )
ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
OPS = OPS + DBLE( 8 )
ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
ELSE
*
* Interpolation using THREE most relevant poles
*
OPS = OPS + DBLE( 15 )
DTIIM = WORK( IIM1 )*DELTA( IIM1 )
DTIIP = WORK( IIP1 )*DELTA( IIP1 )
TEMP = RHOINV + PSI + PHI
IF( ORGATI ) THEN
TEMP1 = Z( IIM1 ) / DTIIM
TEMP1 = TEMP1*TEMP1
C = ( TEMP - DTIIP*( DPSI+DPHI ) ) -
$ ( D( IIM1 )-D( IIP1 ) )*( D( IIM1 )+D( IIP1 ) )*TEMP1
ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
IF( DPSI.LT.TEMP1 ) THEN
OPS = OPS + DBLE( 2 )
ZZ( 3 ) = DTIIP*DTIIP*DPHI
ELSE
OPS = OPS + DBLE( 4 )
ZZ( 3 ) = DTIIP*DTIIP*( ( DPSI-TEMP1 )+DPHI )
END IF
ELSE
TEMP1 = Z( IIP1 ) / DTIIP
TEMP1 = TEMP1*TEMP1
C = ( TEMP - DTIIM*( DPSI+DPHI ) ) -
$ ( D( IIP1 )-D( IIM1 ) )*( D( IIM1 )+D( IIP1 ) )*TEMP1
IF( DPHI.LT.TEMP1 ) THEN
OPS = OPS + DBLE( 2 )
ZZ( 1 ) = DTIIM*DTIIM*DPSI
ELSE
OPS = OPS + DBLE( 4 )
ZZ( 1 ) = DTIIM*DTIIM*( DPSI+( DPHI-TEMP1 ) )
END IF
ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
END IF
OPS = OPS + DBLE( 2 )
ZZ( 2 ) = Z( II )*Z( II )
DD( 1 ) = DTIIM
DD( 2 ) = DELTA( II )*WORK( II )
DD( 3 ) = DTIIP
CALL DLAED6( NITER, ORGATI, C, DD, ZZ, W, ETA, INFO )
IF( INFO.NE.0 )
$ GO TO 240
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
OPS = OPS + DBLE( 1 )
IF( W*ETA.GE.ZERO ) THEN
OPS = OPS + DBLE( 1 )
ETA = -W / DW
END IF
OPS = OPS + DBLE( 8 )
IF( ORGATI ) THEN
TEMP1 = WORK( I )*DELTA( I )
TEMP = ETA - TEMP1
ELSE
TEMP1 = WORK( IP1 )*DELTA( IP1 )
TEMP = ETA - TEMP1
END IF
IF( TEMP.GT.SG2UB .OR. TEMP.LT.SG2LB ) THEN
OPS = OPS + DBLE( 2 )
IF( W.LT.ZERO ) THEN
ETA = ( SG2UB-TAU ) / TWO
ELSE
ETA = ( SG2LB-TAU ) / TWO
END IF
END IF
*
TAU = TAU + ETA
ETA = ETA / ( SIGMA+SQRT( SIGMA*SIGMA+ETA ) )
*
PREW = W
*
OPS = OPS + DBLE( 1 + 2*N )
SIGMA = SIGMA + ETA
DO 170 J = 1, N
WORK( J ) = WORK( J ) + ETA
DELTA( J ) = DELTA( J ) - ETA
170 CONTINUE
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
OPS = OPS + DBLE( 7*IIM1 )
DO 180 J = 1, IIM1
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
180 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
DPHI = ZERO
PHI = ZERO
OPS = OPS + DBLE( 7*(N-IIM1+1) )
DO 190 J = N, IIP1, -1
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PHI = PHI + Z( J )*TEMP
DPHI = DPHI + TEMP*TEMP
ERRETM = ERRETM + PHI
190 CONTINUE
*
OPS = OPS + DBLE( 19 )
TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
DW = DPSI + DPHI + TEMP*TEMP
TEMP = Z( II )*TEMP
W = RHOINV + PHI + PSI + TEMP
ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
$ THREE*ABS( TEMP ) + ABS( TAU )*DW
*
IF( W.LE.ZERO ) THEN
SG2LB = MAX( SG2LB, TAU )
ELSE
SG2UB = MIN( SG2UB, TAU )
END IF
*
SWTCH = .FALSE.
IF( ORGATI ) THEN
IF( -W.GT.ABS( PREW ) / TEN )
$ SWTCH = .TRUE.
ELSE
IF( W.GT.ABS( PREW ) / TEN )
$ SWTCH = .TRUE.
END IF
*
* Main loop to update the values of the array DELTA and WORK
*
ITER = NITER + 1
*
DO 230 NITER = ITER, MAXIT
*
* Test for convergence
*
OPS = OPS + DBLE( 1 )
IF( ABS( W ).LE.EPS*ERRETM ) THEN
GO TO 240
END IF
*
* Calculate the new step
*
IF( .NOT.SWTCH3 ) THEN
OPS = OPS + DBLE( 2 )
DTIPSQ = WORK( IP1 )*DELTA( IP1 )
DTISQ = WORK( I )*DELTA( I )
IF( .NOT.SWTCH ) THEN
OPS = OPS + DBLE( 6 )
IF( ORGATI ) THEN
C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2
ELSE
C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2
END IF
ELSE
OPS = OPS + DBLE( 8 )
TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
IF( ORGATI ) THEN
DPSI = DPSI + TEMP*TEMP
ELSE
DPHI = DPHI + TEMP*TEMP
END IF
C = W - DTISQ*DPSI - DTIPSQ*DPHI
END IF
OPS = OPS + DBLE( 7 )
A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW
B = DTIPSQ*DTISQ*W
IF( C.EQ.ZERO ) THEN
IF( A.EQ.ZERO ) THEN
OPS = OPS + DBLE( 5 )
IF( .NOT.SWTCH ) THEN
IF( ORGATI ) THEN
A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ*
$ ( DPSI+DPHI )
ELSE
A = Z( IP1 )*Z( IP1 ) +
$ DTISQ*DTISQ*( DPSI+DPHI )
END IF
ELSE
A = DTISQ*DTISQ*DPSI + DTIPSQ*DTIPSQ*DPHI
END IF
END IF
OPS = OPS + DBLE( 1 )
ETA = B / A
ELSE IF( A.LE.ZERO ) THEN
OPS = OPS + DBLE( 8 )
ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
OPS = OPS + DBLE( 8 )
ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
ELSE
*
* Interpolation using THREE most relevant poles
*
OPS = OPS + DBLE( 4 )
DTIIM = WORK( IIM1 )*DELTA( IIM1 )
DTIIP = WORK( IIP1 )*DELTA( IIP1 )
TEMP = RHOINV + PSI + PHI
IF( SWTCH ) THEN
OPS = OPS + DBLE( 8 )
C = TEMP - DTIIM*DPSI - DTIIP*DPHI
ZZ( 1 ) = DTIIM*DTIIM*DPSI
ZZ( 3 ) = DTIIP*DTIIP*DPHI
ELSE
IF( ORGATI ) THEN
OPS = OPS + DBLE( 11 )
TEMP1 = Z( IIM1 ) / DTIIM
TEMP1 = TEMP1*TEMP1
TEMP2 = ( D( IIM1 )-D( IIP1 ) )*
$ ( D( IIM1 )+D( IIP1 ) )*TEMP1
C = TEMP - DTIIP*( DPSI+DPHI ) - TEMP2
ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
IF( DPSI.LT.TEMP1 ) THEN
OPS = OPS + DBLE( 2 )
ZZ( 3 ) = DTIIP*DTIIP*DPHI
ELSE
OPS = OPS + DBLE( 4 )
ZZ( 3 ) = DTIIP*DTIIP*( ( DPSI-TEMP1 )+DPHI )
END IF
ELSE
OPS = OPS + DBLE( 10 )
TEMP1 = Z( IIP1 ) / DTIIP
TEMP1 = TEMP1*TEMP1
TEMP2 = ( D( IIP1 )-D( IIM1 ) )*
$ ( D( IIM1 )+D( IIP1 ) )*TEMP1
C = TEMP - DTIIM*( DPSI+DPHI ) - TEMP2
IF( DPHI.LT.TEMP1 ) THEN
OPS = OPS + DBLE( 2 )
ZZ( 1 ) = DTIIM*DTIIM*DPSI
ELSE
OPS = OPS + DBLE( 4 )
ZZ( 1 ) = DTIIM*DTIIM*( DPSI+( DPHI-TEMP1 ) )
END IF
OPS = OPS + DBLE( 1 )
ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
END IF
END IF
OPS = OPS + DBLE( 1 )
DD( 1 ) = DTIIM
DD( 2 ) = DELTA( II )*WORK( II )
DD( 3 ) = DTIIP
CALL DLAED6( NITER, ORGATI, C, DD, ZZ, W, ETA, INFO )
IF( INFO.NE.0 )
$ GO TO 240
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
OPS = OPS + DBLE( 1 )
IF( W*ETA.GE.ZERO ) THEN
OPS = OPS + DBLE( 1 )
ETA = -W / DW
END IF
OPS = OPS + DBLE( 2 )
IF( ORGATI ) THEN
TEMP1 = WORK( I )*DELTA( I )
TEMP = ETA - TEMP1
ELSE
TEMP1 = WORK( IP1 )*DELTA( IP1 )
TEMP = ETA - TEMP1
END IF
IF( TEMP.GT.SG2UB .OR. TEMP.LT.SG2LB ) THEN
OPS = OPS + DBLE( 2 )
IF( W.LT.ZERO ) THEN
ETA = ( SG2UB-TAU ) / TWO
ELSE
ETA = ( SG2LB-TAU ) / TWO
END IF
END IF
*
OPS = OPS + DBLE( 6 )
TAU = TAU + ETA
ETA = ETA / ( SIGMA+SQRT( SIGMA*SIGMA+ETA ) )
*
OPS = OPS + DBLE( 1 + 2*N )
SIGMA = SIGMA + ETA
DO 200 J = 1, N
WORK( J ) = WORK( J ) + ETA
DELTA( J ) = DELTA( J ) - ETA
200 CONTINUE
*
PREW = W
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
OPS = OPS + DBLE( 7*IIM1 )
DO 210 J = 1, IIM1
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
210 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
DPHI = ZERO
PHI = ZERO
OPS = OPS + DBLE( 7*( IIM1-N+1 ) )
DO 220 J = N, IIP1, -1
TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
PHI = PHI + Z( J )*TEMP
DPHI = DPHI + TEMP*TEMP
ERRETM = ERRETM + PHI
220 CONTINUE
*
OPS = OPS + DBLE( 19 )
TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
DW = DPSI + DPHI + TEMP*TEMP
TEMP = Z( II )*TEMP
W = RHOINV + PHI + PSI + TEMP
ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
$ THREE*ABS( TEMP ) + ABS( TAU )*DW
IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN )
$ SWTCH = .NOT.SWTCH
*
IF( W.LE.ZERO ) THEN
SG2LB = MAX( SG2LB, TAU )
ELSE
SG2UB = MIN( SG2UB, TAU )
END IF
*
230 CONTINUE
*
* Return with INFO = 1, NITER = MAXIT and not converged
*
INFO = 1
*
END IF
*
240 CONTINUE
RETURN
*
* End of DLASD4
*
END
SUBROUTINE DLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
* Courant Institute, NAG Ltd., and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER I
DOUBLE PRECISION DSIGMA, RHO
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( 2 ), DELTA( 2 ), WORK( 2 ), Z( 2 )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* This subroutine computes the square root of the I-th eigenvalue
* of a positive symmetric rank-one modification of a 2-by-2 diagonal
* matrix
*
* diag( D ) * diag( D ) + RHO * Z * transpose(Z) .
*
* The diagonal entries in the array D are assumed to satisfy
*
* 0 <= D(i) < D(j) for i < j .
*
* We also assume RHO > 0 and that the Euclidean norm of the vector
* Z is one.
*
* Arguments
* =========
*
* I (input) INTEGER
* The index of the eigenvalue to be computed. I = 1 or I = 2.
*
* D (input) DOUBLE PRECISION array, dimension ( 2 )
* The original eigenvalues. We assume 0 <= D(1) < D(2).
*
* Z (input) DOUBLE PRECISION array, dimension ( 2 )
* The components of the updating vector.
*
* DELTA (output) DOUBLE PRECISION array, dimension ( 2 )
* Contains (D(j) - lambda_I) in its j-th component.
* The vector DELTA contains the information necessary
* to construct the eigenvectors.
*
* RHO (input) DOUBLE PRECISION
* The scalar in the symmetric updating formula.
*
* DSIGMA (output) DOUBLE PRECISION
* The computed lambda_I, the I-th updated eigenvalue.
*
* WORK (workspace) DOUBLE PRECISION array, dimension ( 2 )
* WORK contains (D(j) + sigma_I) in its j-th component.
*
* Further Details
* ===============
*
* Based on contributions by
* Ren-Cang Li, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ THREE = 3.0D0, FOUR = 4.0D0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION B, C, DEL, DELSQ, TAU, W
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, ABS, SQRT
* ..
* .. Executable Statements ..
*
OPS = OPS + DBLE( 3 )
DEL = D( 2 ) - D( 1 )
DELSQ = DEL*( D( 2 )+D( 1 ) )
IF( I.EQ.1 ) THEN
OPS = OPS + DBLE( 13 )
W = ONE + FOUR*RHO*( Z( 2 )*Z( 2 ) / ( D( 1 )+THREE*D( 2 ) )-
$ Z( 1 )*Z( 1 ) / ( THREE*D( 1 )+D( 2 ) ) ) / DEL
IF( W.GT.ZERO ) THEN
OPS = OPS + DBLE( 8 )
B = DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
C = RHO*Z( 1 )*Z( 1 )*DELSQ
*
* B > ZERO, always
*
* The following TAU is DSIGMA * DSIGMA - D( 1 ) * D( 1 )
*
OPS = OPS + DBLE( 7 )
TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) )
*
* The following TAU is DSIGMA - D( 1 )
*
OPS = OPS + DBLE( 14 )
TAU = TAU / ( D( 1 )+SQRT( D( 1 )*D( 1 )+TAU ) )
DSIGMA = D( 1 ) + TAU
DELTA( 1 ) = -TAU
DELTA( 2 ) = DEL - TAU
WORK( 1 ) = TWO*D( 1 ) + TAU
WORK( 2 ) = ( D( 1 )+TAU ) + D( 2 )
* DELTA( 1 ) = -Z( 1 ) / TAU
* DELTA( 2 ) = Z( 2 ) / ( DEL-TAU )
ELSE
OPS = OPS + DBLE( 8 )
B = -DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
C = RHO*Z( 2 )*Z( 2 )*DELSQ
*
* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 )
*
IF( B.GT.ZERO ) THEN
OPS = OPS + DBLE( 7 )
TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) )
ELSE
OPS = OPS + DBLE( 6 )
TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO
END IF
*
* The following TAU is DSIGMA - D( 2 )
*
OPS = OPS + DBLE( 14 )
TAU = TAU / ( D( 2 )+SQRT( ABS( D( 2 )*D( 2 )+TAU ) ) )
DSIGMA = D( 2 ) + TAU
DELTA( 1 ) = -( DEL+TAU )
DELTA( 2 ) = -TAU
WORK( 1 ) = D( 1 ) + TAU + D( 2 )
WORK( 2 ) = TWO*D( 2 ) + TAU
* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
* DELTA( 2 ) = -Z( 2 ) / TAU
END IF
OPS = OPS + DBLE( 6 )
* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
* DELTA( 1 ) = DELTA( 1 ) / TEMP
* DELTA( 2 ) = DELTA( 2 ) / TEMP
ELSE
*
* Now I=2
*
OPS = OPS + DBLE( 8 )
B = -DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
C = RHO*Z( 2 )*Z( 2 )*DELSQ
*
* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 )
*
IF( B.GT.ZERO ) THEN
OPS = OPS + DBLE( 6 )
TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO
ELSE
OPS = OPS + DBLE( 7 )
TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) )
END IF
*
* The following TAU is DSIGMA - D( 2 )
*
OPS = OPS + DBLE( 20 )
TAU = TAU / ( D( 2 )+SQRT( D( 2 )*D( 2 )+TAU ) )
DSIGMA = D( 2 ) + TAU
DELTA( 1 ) = -( DEL+TAU )
DELTA( 2 ) = -TAU
WORK( 1 ) = D( 1 ) + TAU + D( 2 )
WORK( 2 ) = TWO*D( 2 ) + TAU
* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
* DELTA( 2 ) = -Z( 2 ) / TAU
* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
* DELTA( 1 ) = DELTA( 1 ) / TEMP
* DELTA( 2 ) = DELTA( 2 ) / TEMP
END IF
RETURN
*
* End of DLASD5
*
END
SUBROUTINE DLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA,
$ IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM,
$ LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK,
$ IWORK, INFO )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL,
$ NR, SQRE
DOUBLE PRECISION ALPHA, BETA, C, S
* ..
* .. Array Arguments ..
INTEGER GIVCOL( LDGCOL, * ), IDXQ( * ), IWORK( * ),
$ PERM( * )
DOUBLE PRECISION D( * ), DIFL( * ), DIFR( * ),
$ GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ),
$ VF( * ), VL( * ), WORK( * ), Z( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLASD6 computes the SVD of an updated upper bidiagonal matrix B
* obtained by merging two smaller ones by appending a row. This
* routine is used only for the problem which requires all singular
* values and optionally singular vector matrices in factored form.
* B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE.
* A related subroutine, DLASD1, handles the case in which all singular
* values and singular vectors of the bidiagonal matrix are desired.
*
* DLASD6 computes the SVD as follows:
*
* ( D1(in) 0 0 0 )
* B = U(in) * ( Z1' a Z2' b ) * VT(in)
* ( 0 0 D2(in) 0 )
*
* = U(out) * ( D(out) 0) * VT(out)
*
* where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M
* with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros
* elsewhere; and the entry b is empty if SQRE = 0.
*
* The singular values of B can be computed using D1, D2, the first
* components of all the right singular vectors of the lower block, and
* the last components of all the right singular vectors of the upper
* block. These components are stored and updated in VF and VL,
* respectively, in DLASD6. Hence U and VT are not explicitly
* referenced.
*
* The singular values are stored in D. The algorithm consists of two
* stages:
*
* The first stage consists of deflating the size of the problem
* when there are multiple singular values or if there is a zero
* in the Z vector. For each such occurence the dimension of the
* secular equation problem is reduced by one. This stage is
* performed by the routine DLASD7.
*
* The second stage consists of calculating the updated
* singular values. This is done by finding the roots of the
* secular equation via the routine DLASD4 (as called by DLASD8).
* This routine also updates VF and VL and computes the distances
* between the updated singular values and the old singular
* values.
*
* DLASD6 is called from DLASDA.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* Specifies whether singular vectors are to be computed in
* factored form:
* = 0: Compute singular values only.
* = 1: Compute singular vectors in factored form as well.
*
* NL (input) INTEGER
* The row dimension of the upper block. NL >= 1.
*
* NR (input) INTEGER
* The row dimension of the lower block. NR >= 1.
*
* SQRE (input) INTEGER
* = 0: the lower block is an NR-by-NR square matrix.
* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
*
* The bidiagonal matrix has row dimension N = NL + NR + 1,
* and column dimension M = N + SQRE.
*
* D (input/output) DOUBLE PRECISION array, dimension ( NL+NR+1 ).
* On entry D(1:NL,1:NL) contains the singular values of the
* upper block, and D(NL+2:N) contains the singular values
* of the lower block. On exit D(1:N) contains the singular
* values of the modified matrix.
*
* VF (input/output) DOUBLE PRECISION array, dimension ( M )
* On entry, VF(1:NL+1) contains the first components of all
* right singular vectors of the upper block; and VF(NL+2:M)
* contains the first components of all right singular vectors
* of the lower block. On exit, VF contains the first components
* of all right singular vectors of the bidiagonal matrix.
*
* VL (input/output) DOUBLE PRECISION array, dimension ( M )
* On entry, VL(1:NL+1) contains the last components of all
* right singular vectors of the upper block; and VL(NL+2:M)
* contains the last components of all right singular vectors of
* the lower block. On exit, VL contains the last components of
* all right singular vectors of the bidiagonal matrix.
*
* ALPHA (input) DOUBLE PRECISION
* Contains the diagonal element associated with the added row.
*
* BETA (input) DOUBLE PRECISION
* Contains the off-diagonal element associated with the added
* row.
*
* IDXQ (output) INTEGER array, dimension ( N )
* This contains the permutation which will reintegrate the
* subproblem just solved back into sorted order, i.e.
* D( IDXQ( I = 1, N ) ) will be in ascending order.
*
* PERM (output) INTEGER array, dimension ( N )
* The permutations (from deflation and sorting) to be applied
* to each block. Not referenced if ICOMPQ = 0.
*
* GIVPTR (output) INTEGER
* The number of Givens rotations which took place in this
* subproblem. Not referenced if ICOMPQ = 0.
*
* GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )
* Each pair of numbers indicates a pair of columns to take place
* in a Givens rotation. Not referenced if ICOMPQ = 0.
*
* LDGCOL (input) INTEGER
* leading dimension of GIVCOL, must be at least N.
*
* GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
* Each number indicates the C or S value to be used in the
* corresponding Givens rotation. Not referenced if ICOMPQ = 0.
*
* LDGNUM (input) INTEGER
* The leading dimension of GIVNUM and POLES, must be at least N.
*
* POLES (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
* On exit, POLES(1,*) is an array containing the new singular
* values obtained from solving the secular equation, and
* POLES(2,*) is an array containing the poles in the secular
* equation. Not referenced if ICOMPQ = 0.
*
* DIFL (output) DOUBLE PRECISION array, dimension ( N )
* On exit, DIFL(I) is the distance between I-th updated
* (undeflated) singular value and the I-th (undeflated) old
* singular value.
*
* DIFR (output) DOUBLE PRECISION array,
* dimension ( LDGNUM, 2 ) if ICOMPQ = 1 and
* dimension ( N ) if ICOMPQ = 0.
* On exit, DIFR(I, 1) is the distance between I-th updated
* (undeflated) singular value and the I+1-th (undeflated) old
* singular value.
*
* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the
* normalizing factors for the right singular vector matrix.
*
* See DLASD8 for details on DIFL and DIFR.
*
* Z (output) DOUBLE PRECISION array, dimension ( M )
* The first elements of this array contain the components
* of the deflation-adjusted updating row vector.
*
* K (output) INTEGER
* Contains the dimension of the non-deflated matrix,
* This is the order of the related secular equation. 1 <= K <=N.
*
* C (output) DOUBLE PRECISION
* C contains garbage if SQRE =0 and the C-value of a Givens
* rotation related to the right null space if SQRE = 1.
*
* S (output) DOUBLE PRECISION
* S contains garbage if SQRE =0 and the S-value of a Givens
* rotation related to the right null space if SQRE = 1.
*
* WORK (workspace) DOUBLE PRECISION array, dimension ( 4 * M )
*
* IWORK (workspace) INTEGER array, dimension ( 3 * N )
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an singular value did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, IDX, IDXC, IDXP, ISIGMA, IVFW, IVLW, IW, M,
$ N, N1, N2
DOUBLE PRECISION ORGNRM
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLAMRG, DLASCL, DLASD7, DLASD8, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, ABS, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
N = NL + NR + 1
M = N + SQRE
*
IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
INFO = -1
ELSE IF( NL.LT.1 ) THEN
INFO = -2
ELSE IF( NR.LT.1 ) THEN
INFO = -3
ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
INFO = -4
ELSE IF( LDGCOL.LT.N ) THEN
INFO = -14
ELSE IF( LDGNUM.LT.N ) THEN
INFO = -16
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLASD6', -INFO )
RETURN
END IF
*
* The following values are for bookkeeping purposes only. They are
* integer pointers which indicate the portion of the workspace
* used by a particular array in DLASD7 and DLASD8.
*
ISIGMA = 1
IW = ISIGMA + N
IVFW = IW + M
IVLW = IVFW + M
*
IDX = 1
IDXC = IDX + N
IDXP = IDXC + N
*
* Scale.
*
ORGNRM = MAX( ABS( ALPHA ), ABS( BETA ) )
D( NL+1 ) = ZERO
DO 10 I = 1, N
IF( ABS( D( I ) ).GT.ORGNRM ) THEN
ORGNRM = ABS( D( I ) )
END IF
10 CONTINUE
OPS = OPS + DBLE( N + 2 )
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
ALPHA = ALPHA / ORGNRM
BETA = BETA / ORGNRM
*
* Sort and Deflate singular values.
*
CALL DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, WORK( IW ), VF,
$ WORK( IVFW ), VL, WORK( IVLW ), ALPHA, BETA,
$ WORK( ISIGMA ), IWORK( IDX ), IWORK( IDXP ), IDXQ,
$ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, C, S,
$ INFO )
*
* Solve Secular Equation, compute DIFL, DIFR, and update VF, VL.
*
CALL DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDGNUM,
$ WORK( ISIGMA ), WORK( IW ), INFO )
*
* Save the poles if ICOMPQ = 1.
*
IF( ICOMPQ.EQ.1 ) THEN
CALL DCOPY( K, D, 1, POLES( 1, 1 ), 1 )
CALL DCOPY( K, WORK( ISIGMA ), 1, POLES( 1, 2 ), 1 )
END IF
*
* Unscale.
*
OPS = OPS + DBLE( N )
CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
*
* Prepare the IDXQ sorting permutation.
*
N1 = K
N2 = N - K
CALL DLAMRG( N1, N2, D, 1, -1, IDXQ )
*
RETURN
*
* End of DLASD6
*
END
SUBROUTINE DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL,
$ VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ,
$ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM,
$ C, S, INFO )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
* Courant Institute, NAG Ltd., and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL,
$ NR, SQRE
DOUBLE PRECISION ALPHA, BETA, C, S
* ..
* .. Array Arguments ..
INTEGER GIVCOL( LDGCOL, * ), IDX( * ), IDXP( * ),
$ IDXQ( * ), PERM( * )
DOUBLE PRECISION D( * ), DSIGMA( * ), GIVNUM( LDGNUM, * ),
$ VF( * ), VFW( * ), VL( * ), VLW( * ), Z( * ),
$ ZW( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLASD7 merges the two sets of singular values together into a single
* sorted set. Then it tries to deflate the size of the problem. There
* are two ways in which deflation can occur: when two or more singular
* values are close together or if there is a tiny entry in the Z
* vector. For each such occurrence the order of the related
* secular equation problem is reduced by one.
*
* DLASD7 is called from DLASD6.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* Specifies whether singular vectors are to be computed
* in compact form, as follows:
* = 0: Compute singular values only.
* = 1: Compute singular vectors of upper
* bidiagonal matrix in compact form.
*
* NL (input) INTEGER
* The row dimension of the upper block. NL >= 1.
*
* NR (input) INTEGER
* The row dimension of the lower block. NR >= 1.
*
* SQRE (input) INTEGER
* = 0: the lower block is an NR-by-NR square matrix.
* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
*
* The bidiagonal matrix has
* N = NL + NR + 1 rows and
* M = N + SQRE >= N columns.
*
* K (output) INTEGER
* Contains the dimension of the non-deflated matrix, this is
* the order of the related secular equation. 1 <= K <=N.
*
* D (input/output) DOUBLE PRECISION array, dimension ( N )
* On entry D contains the singular values of the two submatrices
* to be combined. On exit D contains the trailing (N-K) updated
* singular values (those which were deflated) sorted into
* increasing order.
*
* Z (output) DOUBLE PRECISION array, dimension ( M )
* On exit Z contains the updating row vector in the secular
* equation.
*
* ZW (workspace) DOUBLE PRECISION array, dimension ( M )
* Workspace for Z.
*
* VF (input/output) DOUBLE PRECISION array, dimension ( M )
* On entry, VF(1:NL+1) contains the first components of all
* right singular vectors of the upper block; and VF(NL+2:M)
* contains the first components of all right singular vectors
* of the lower block. On exit, VF contains the first components
* of all right singular vectors of the bidiagonal matrix.
*
* VFW (workspace) DOUBLE PRECISION array, dimension ( M )
* Workspace for VF.
*
* VL (input/output) DOUBLE PRECISION array, dimension ( M )
* On entry, VL(1:NL+1) contains the last components of all
* right singular vectors of the upper block; and VL(NL+2:M)
* contains the last components of all right singular vectors
* of the lower block. On exit, VL contains the last components
* of all right singular vectors of the bidiagonal matrix.
*
* VLW (workspace) DOUBLE PRECISION array, dimension ( M )
* Workspace for VL.
*
* ALPHA (input) DOUBLE PRECISION
* Contains the diagonal element associated with the added row.
*
* BETA (input) DOUBLE PRECISION
* Contains the off-diagonal element associated with the added
* row.
*
* DSIGMA (output) DOUBLE PRECISION array, dimension ( N )
* Contains a copy of the diagonal elements (K-1 singular values
* and one zero) in the secular equation.
*
* IDX (workspace) INTEGER array, dimension ( N )
* This will contain the permutation used to sort the contents of
* D into ascending order.
*
* IDXP (workspace) INTEGER array, dimension ( N )
* This will contain the permutation used to place deflated
* values of D at the end of the array. On output IDXP(2:K)
* points to the nondeflated D-values and IDXP(K+1:N)
* points to the deflated singular values.
*
* IDXQ (input) INTEGER array, dimension ( N )
* This contains the permutation which separately sorts the two
* sub-problems in D into ascending order. Note that entries in
* the first half of this permutation must first be moved one
* position backward; and entries in the second half
* must first have NL+1 added to their values.
*
* PERM (output) INTEGER array, dimension ( N )
* The permutations (from deflation and sorting) to be applied
* to each singular block. Not referenced if ICOMPQ = 0.
*
* GIVPTR (output) INTEGER
* The number of Givens rotations which took place in this
* subproblem. Not referenced if ICOMPQ = 0.
*
* GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )
* Each pair of numbers indicates a pair of columns to take place
* in a Givens rotation. Not referenced if ICOMPQ = 0.
*
* LDGCOL (input) INTEGER
* The leading dimension of GIVCOL, must be at least N.
*
* GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
* Each number indicates the C or S value to be used in the
* corresponding Givens rotation. Not referenced if ICOMPQ = 0.
*
* LDGNUM (input) INTEGER
* The leading dimension of GIVNUM, must be at least N.
*
* C (output) DOUBLE PRECISION
* C contains garbage if SQRE =0 and the C-value of a Givens
* rotation related to the right null space if SQRE = 1.
*
* S (output) DOUBLE PRECISION
* S contains garbage if SQRE =0 and the S-value of a Givens
* rotation related to the right null space if SQRE = 1.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, EIGHT
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ EIGHT = 8.0D0 )
* ..
* .. Local Scalars ..
*
INTEGER I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M, N,
$ NLP1, NLP2
DOUBLE PRECISION EPS, HLFTOL, TAU, TOL, Z1
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLAMRG, DROT, XERBLA
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLAPY2
EXTERNAL DLAMCH, DLAPY2
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, ABS, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
N = NL + NR + 1
M = N + SQRE
*
IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
INFO = -1
ELSE IF( NL.LT.1 ) THEN
INFO = -2
ELSE IF( NR.LT.1 ) THEN
INFO = -3
ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
INFO = -4
ELSE IF( LDGCOL.LT.N ) THEN
INFO = -22
ELSE IF( LDGNUM.LT.N ) THEN
INFO = -24
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLASD7', -INFO )
RETURN
END IF
*
NLP1 = NL + 1
NLP2 = NL + 2
IF( ICOMPQ.EQ.1 ) THEN
GIVPTR = 0
END IF
*
* Generate the first part of the vector Z and move the singular
* values in the first part of D one position backward.
*
OPS = OPS + DBLE( 1 + NL )
Z1 = ALPHA*VL( NLP1 )
VL( NLP1 ) = ZERO
TAU = VF( NLP1 )
DO 10 I = NL, 1, -1
Z( I+1 ) = ALPHA*VL( I )
VL( I ) = ZERO
VF( I+1 ) = VF( I )
D( I+1 ) = D( I )
IDXQ( I+1 ) = IDXQ( I ) + 1
10 CONTINUE
VF( 1 ) = TAU
*
* Generate the second part of the vector Z.
*
OPS = OPS + DBLE( ( M-NLP2+1 ) )
DO 20 I = NLP2, M
Z( I ) = BETA*VF( I )
VF( I ) = ZERO
20 CONTINUE
*
* Sort the singular values into increasing order
*
DO 30 I = NLP2, N
IDXQ( I ) = IDXQ( I ) + NLP1
30 CONTINUE
*
* DSIGMA, IDXC, IDXC, and ZW are used as storage space.
*
DO 40 I = 2, N
DSIGMA( I ) = D( IDXQ( I ) )
ZW( I ) = Z( IDXQ( I ) )
VFW( I ) = VF( IDXQ( I ) )
VLW( I ) = VL( IDXQ( I ) )
40 CONTINUE
*
CALL DLAMRG( NL, NR, DSIGMA( 2 ), 1, 1, IDX( 2 ) )
*
DO 50 I = 2, N
IDXI = 1 + IDX( I )
D( I ) = DSIGMA( IDXI )
Z( I ) = ZW( IDXI )
VF( I ) = VFW( IDXI )
VL( I ) = VLW( IDXI )
50 CONTINUE
*
* Calculate the allowable deflation tolerence
*
OPS = OPS + DBLE( 3 )
EPS = DLAMCH( 'Epsilon' )
TOL = MAX( ABS( ALPHA ), ABS( BETA ) )
TOL = EIGHT*EIGHT*EPS*MAX( ABS( D( N ) ), TOL )
*
* There are 2 kinds of deflation -- first a value in the z-vector
* is small, second two (or more) singular values are very close
* together (their difference is small).
*
* If the value in the z-vector is small, we simply permute the
* array so that the corresponding singular value is moved to the
* end.
*
* If two values in the D-vector are close, we perform a two-sided
* rotation designed to make one of the corresponding z-vector
* entries zero, and then permute the array so that the deflated
* singular value is moved to the end.
*
* If there are multiple singular values then the problem deflates.
* Here the number of equal singular values are found. As each equal
* singular value is found, an elementary reflector is computed to
* rotate the corresponding singular subspace so that the
* corresponding components of Z are zero in this new basis.
*
K = 1
K2 = N + 1
DO 60 J = 2, N
IF( ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
IDXP( K2 ) = J
IF( J.EQ.N )
$ GO TO 100
ELSE
JPREV = J
GO TO 70
END IF
60 CONTINUE
70 CONTINUE
J = JPREV
80 CONTINUE
J = J + 1
IF( J.GT.N )
$ GO TO 90
IF( ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
IDXP( K2 ) = J
ELSE
*
* Check if singular values are close enough to allow deflation.
*
OPS = OPS + DBLE( 1 )
IF( ABS( D( J )-D( JPREV ) ).LE.TOL ) THEN
*
* Deflation is possible.
*
S = Z( JPREV )
C = Z( J )
*
* Find sqrt(a**2+b**2) without overflow or
* destructive underflow.
*
OPS = OPS + DBLE( 7 )
TAU = DLAPY2( C, S )
Z( J ) = TAU
Z( JPREV ) = ZERO
C = C / TAU
S = -S / TAU
*
* Record the appropriate Givens rotation
*
IF( ICOMPQ.EQ.1 ) THEN
GIVPTR = GIVPTR + 1
IDXJP = IDXQ( IDX( JPREV )+1 )
IDXJ = IDXQ( IDX( J )+1 )
IF( IDXJP.LE.NLP1 ) THEN
IDXJP = IDXJP - 1
END IF
IF( IDXJ.LE.NLP1 ) THEN
IDXJ = IDXJ - 1
END IF
GIVCOL( GIVPTR, 2 ) = IDXJP
GIVCOL( GIVPTR, 1 ) = IDXJ
GIVNUM( GIVPTR, 2 ) = C
GIVNUM( GIVPTR, 1 ) = S
END IF
OPS = OPS + DBLE( 12 )
CALL DROT( 1, VF( JPREV ), 1, VF( J ), 1, C, S )
CALL DROT( 1, VL( JPREV ), 1, VL( J ), 1, C, S )
K2 = K2 - 1
IDXP( K2 ) = JPREV
JPREV = J
ELSE
K = K + 1
ZW( K ) = Z( JPREV )
DSIGMA( K ) = D( JPREV )
IDXP( K ) = JPREV
JPREV = J
END IF
END IF
GO TO 80
90 CONTINUE
*
* Record the last singular value.
*
K = K + 1
ZW( K ) = Z( JPREV )
DSIGMA( K ) = D( JPREV )
IDXP( K ) = JPREV
*
100 CONTINUE
*
* Sort the singular values into DSIGMA. The singular values which
* were not deflated go into the first K slots of DSIGMA, except
* that DSIGMA(1) is treated separately.
*
DO 110 J = 2, N
JP = IDXP( J )
DSIGMA( J ) = D( JP )
VFW( J ) = VF( JP )
VLW( J ) = VL( JP )
110 CONTINUE
IF( ICOMPQ.EQ.1 ) THEN
DO 120 J = 2, N
JP = IDXP( J )
PERM( J ) = IDXQ( IDX( JP )+1 )
IF( PERM( J ).LE.NLP1 ) THEN
PERM( J ) = PERM( J ) - 1
END IF
120 CONTINUE
END IF
*
* The deflated singular values go back into the last N - K slots of
* D.
*
CALL DCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 )
*
* Determine DSIGMA(1), DSIGMA(2), Z(1), VF(1), VL(1), VF(M), and
* VL(M).
*
OPS = OPS + DBLE( 1 )
DSIGMA( 1 ) = ZERO
HLFTOL = TOL / TWO
IF( ABS( DSIGMA( 2 ) ).LE.HLFTOL )
$ DSIGMA( 2 ) = HLFTOL
IF( M.GT.N ) THEN
OPS = OPS + DBLE( 5 )
Z( 1 ) = DLAPY2( Z1, Z( M ) )
IF( Z( 1 ).LE.TOL ) THEN
C = ONE
S = ZERO
Z( 1 ) = TOL
ELSE
OPS = OPS + DBLE( 2 )
C = Z1 / Z( 1 )
S = -Z( M ) / Z( 1 )
END IF
OPS = OPS + DBLE( 12 )
CALL DROT( 1, VF( M ), 1, VF( 1 ), 1, C, S )
CALL DROT( 1, VL( M ), 1, VL( 1 ), 1, C, S )
ELSE
IF( ABS( Z1 ).LE.TOL ) THEN
Z( 1 ) = TOL
ELSE
Z( 1 ) = Z1
END IF
END IF
*
* Restore Z, VF, and VL.
*
CALL DCOPY( K-1, ZW( 2 ), 1, Z( 2 ), 1 )
CALL DCOPY( N-1, VFW( 2 ), 1, VF( 2 ), 1 )
CALL DCOPY( N-1, VLW( 2 ), 1, VL( 2 ), 1 )
*
RETURN
*
* End of DLASD7
*
END
SUBROUTINE DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR,
$ DSIGMA, WORK, INFO )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
* Courant Institute, NAG Ltd., and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER ICOMPQ, INFO, K, LDDIFR
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), DIFL( * ), DIFR( LDDIFR, * ),
$ DSIGMA( * ), VF( * ), VL( * ), WORK( * ),
$ Z( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLASD8 finds the square roots of the roots of the secular equation,
* as defined by the values in DSIGMA and Z. It makes the appropriate
* calls to DLASD4, and stores, for each element in D, the distance
* to its two nearest poles (elements in DSIGMA). It also updates
* the arrays VF and VL, the first and last components of all the
* right singular vectors of the original bidiagonal matrix.
*
* DLASD8 is called from DLASD6.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* Specifies whether singular vectors are to be computed in
* factored form in the calling routine:
* = 0: Compute singular values only.
* = 1: Compute singular vectors in factored form as well.
*
* K (input) INTEGER
* The number of terms in the rational function to be solved
* by DLASD4. K >= 1.
*
* D (output) DOUBLE PRECISION array, dimension ( K )
* On output, D contains the updated singular values.
*
* Z (input) DOUBLE PRECISION array, dimension ( K )
* The first K elements of this array contain the components
* of the deflation-adjusted updating row vector.
*
* VF (input/output) DOUBLE PRECISION array, dimension ( K )
* On entry, VF contains information passed through DBEDE8.
* On exit, VF contains the first K components of the first
* components of all right singular vectors of the bidiagonal
* matrix.
*
* VL (input/output) DOUBLE PRECISION array, dimension ( K )
* On entry, VL contains information passed through DBEDE8.
* On exit, VL contains the first K components of the last
* components of all right singular vectors of the bidiagonal
* matrix.
*
* DIFL (output) DOUBLE PRECISION array, dimension ( K )
* On exit, DIFL(I) = D(I) - DSIGMA(I).
*
* DIFR (output) DOUBLE PRECISION array,
* dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and
* dimension ( K ) if ICOMPQ = 0.
* On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not
* defined and will not be referenced.
*
* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the
* normalizing factors for the right singular vector matrix.
*
* LDDIFR (input) INTEGER
* The leading dimension of DIFR, must be at least K.
*
* DSIGMA (input) DOUBLE PRECISION array, dimension ( K )
* The first K elements of this array contain the old roots
* of the deflated updating problem. These are the poles
* of the secular equation.
*
* WORK (workspace) DOUBLE PRECISION array, dimension at least 3 * K
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an singular value did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, IWK1, IWK2, IWK2I, IWK3, IWK3I, J
DOUBLE PRECISION DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, RHO, TEMP
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLASCL, DLASD4, DLASET, XERBLA
* ..
* .. External Functions ..
DOUBLE PRECISION DDOT, DLAMC3, DNRM2
EXTERNAL DDOT, DLAMC3, DNRM2
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, ABS, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
INFO = -1
ELSE IF( K.LT.1 ) THEN
INFO = -2
ELSE IF( LDDIFR.LT.K ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLASD8', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( K.EQ.1 ) THEN
D( 1 ) = ABS( Z( 1 ) )
DIFL( 1 ) = D( 1 )
IF( ICOMPQ.EQ.1 ) THEN
DIFL( 2 ) = ONE
DIFR( 1, 2 ) = ONE
END IF
RETURN
END IF
*
* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can
* be computed with high relative accuracy (barring over/underflow).
* This is a problem on machines without a guard digit in
* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I),
* which on any of these machines zeros out the bottommost
* bit of DSIGMA(I) if it is 1; this makes the subsequent
* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation
* occurs. On binary machines with a guard digit (almost all
* machines) it does not change DSIGMA(I) at all. On hexadecimal
* and decimal machines with a guard digit, it slightly
* changes the bottommost bits of DSIGMA(I). It does not account
* for hexadecimal or decimal machines without guard digits
* (we know of none). We use a subroutine call to compute
* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating
* this code.
*
OPS = OPS + DBLE( 2*K )
DO 10 I = 1, K
DSIGMA( I ) = DLAMC3( DSIGMA( I ), DSIGMA( I ) ) - DSIGMA( I )
10 CONTINUE
*
* Book keeping.
*
IWK1 = 1
IWK2 = IWK1 + K
IWK3 = IWK2 + K
IWK2I = IWK2 - 1
IWK3I = IWK3 - 1
*
* Normalize Z.
*
OPS = OPS + DBLE( 3*K + 1 )
RHO = DNRM2( K, Z, 1 )
CALL DLASCL( 'G', 0, 0, RHO, ONE, K, 1, Z, K, INFO )
RHO = RHO*RHO
*
* Initialize WORK(IWK3).
*
CALL DLASET( 'A', K, 1, ONE, ONE, WORK( IWK3 ), K )
*
* Compute the updated singular values, the arrays DIFL, DIFR,
* and the updated Z.
*
DO 40 J = 1, K
CALL DLASD4( K, J, DSIGMA, Z, WORK( IWK1 ), RHO, D( J ),
$ WORK( IWK2 ), INFO )
*
* If the root finder fails, the computation is terminated.
*
IF( INFO.NE.0 ) THEN
RETURN
END IF
OPS = OPS + DBLE( 2 )
WORK( IWK3I+J ) = WORK( IWK3I+J )*WORK( J )*WORK( IWK2I+J )
DIFL( J ) = -WORK( J )
DIFR( J, 1 ) = -WORK( J+1 )
OPS = OPS + DBLE( 6*( J - 1 ) )
DO 20 I = 1, J - 1
WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )*
$ WORK( IWK2I+I ) / ( DSIGMA( I )-
$ DSIGMA( J ) ) / ( DSIGMA( I )+
$ DSIGMA( J ) )
20 CONTINUE
OPS = OPS + DBLE( 6*( K-J ) )
DO 30 I = J + 1, K
WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )*
$ WORK( IWK2I+I ) / ( DSIGMA( I )-
$ DSIGMA( J ) ) / ( DSIGMA( I )+
$ DSIGMA( J ) )
30 CONTINUE
40 CONTINUE
*
* Compute updated Z.
*
OPS = OPS + DBLE( K )
DO 50 I = 1, K
Z( I ) = SIGN( SQRT( ABS( WORK( IWK3I+I ) ) ), Z( I ) )
50 CONTINUE
*
* Update VF and VL.
*
DO 80 J = 1, K
DIFLJ = DIFL( J )
DJ = D( J )
DSIGJ = -DSIGMA( J )
IF( J.LT.K ) THEN
DIFRJ = -DIFR( J, 1 )
DSIGJP = -DSIGMA( J+1 )
END IF
OPS = OPS + DBLE( 3 )
WORK( J ) = -Z( J ) / DIFLJ / ( DSIGMA( J )+DJ )
OPS = OPS + DBLE( 5*( J-1 ) )
DO 60 I = 1, J - 1
WORK( I ) = Z( I ) / ( DLAMC3( DSIGMA( I ), DSIGJ )-DIFLJ )
$ / ( DSIGMA( I )+DJ )
60 CONTINUE
OPS = OPS + DBLE( 5*( K-J ) )
DO 70 I = J + 1, K
WORK( I ) = Z( I ) / ( DLAMC3( DSIGMA( I ), DSIGJP )+DIFRJ )
$ / ( DSIGMA( I )+DJ )
70 CONTINUE
OPS = OPS + DBLE( 6*K )
TEMP = DNRM2( K, WORK, 1 )
WORK( IWK2I+J ) = DDOT( K, WORK, 1, VF, 1 ) / TEMP
WORK( IWK3I+J ) = DDOT( K, WORK, 1, VL, 1 ) / TEMP
IF( ICOMPQ.EQ.1 ) THEN
DIFR( J, 2 ) = TEMP
END IF
80 CONTINUE
*
CALL DCOPY( K, WORK( IWK2 ), 1, VF, 1 )
CALL DCOPY( K, WORK( IWK3 ), 1, VL, 1 )
*
RETURN
*
* End of DLASD8
*
END
SUBROUTINE DLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K,
$ DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL,
$ PERM, GIVNUM, C, S, WORK, IWORK, INFO )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER ICOMPQ, INFO, LDGCOL, LDU, N, SMLSIZ, SQRE
* ..
* .. Array Arguments ..
INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ),
$ K( * ), PERM( LDGCOL, * )
DOUBLE PRECISION C( * ), D( * ), DIFL( LDU, * ), DIFR( LDU, * ),
$ E( * ), GIVNUM( LDU, * ), POLES( LDU, * ),
$ S( * ), U( LDU, * ), VT( LDU, * ), WORK( * ),
$ Z( LDU, * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* Using a divide and conquer approach, DLASDA computes the singular
* value decomposition (SVD) of a real upper bidiagonal N-by-M matrix
* B with diagonal D and offdiagonal E, where M = N + SQRE. The
* algorithm computes the singular values in the SVD B = U * S * VT.
* The orthogonal matrices U and VT are optionally computed in
* compact form.
*
* A related subroutine, DLASD0, computes the singular values and
* the singular vectors in explicit form.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* Specifies whether singular vectors are to be computed
* in compact form, as follows
* = 0: Compute singular values only.
* = 1: Compute singular vectors of upper bidiagonal
* matrix in compact form.
*
* SMLSIZ (input) INTEGER
* The maximum size of the subproblems at the bottom of the
* computation tree.
*
* N (input) INTEGER
* The row dimension of the upper bidiagonal matrix. This is
* also the dimension of the main diagonal array D.
*
* SQRE (input) INTEGER
* Specifies the column dimension of the bidiagonal matrix.
* = 0: The bidiagonal matrix has column dimension M = N;
* = 1: The bidiagonal matrix has column dimension M = N + 1.
*
* D (input/output) DOUBLE PRECISION array, dimension ( N )
* On entry D contains the main diagonal of the bidiagonal
* matrix. On exit D, if INFO = 0, contains its singular values.
*
* E (input) DOUBLE PRECISION array, dimension ( M-1 )
* Contains the subdiagonal entries of the bidiagonal matrix.
* On exit, E has been destroyed.
*
* U (output) DOUBLE PRECISION array,
* dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced
* if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left
* singular vector matrices of all subproblems at the bottom
* level.
*
* LDU (input) INTEGER, LDU = > N.
* The leading dimension of arrays U, VT, DIFL, DIFR, POLES,
* GIVNUM, and Z.
*
* VT (output) DOUBLE PRECISION array,
* dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced
* if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT' contains the right
* singular vector matrices of all subproblems at the bottom
* level.
*
* K (output) INTEGER array,
* dimension ( N ) if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0.
* If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th
* secular equation on the computation tree.
*
* DIFL (output) DOUBLE PRECISION array, dimension ( LDU, NLVL ),
* where NLVL = floor(log_2 (N/SMLSIZ))).
*
* DIFR (output) DOUBLE PRECISION array,
* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and
* dimension ( N ) if ICOMPQ = 0.
* If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1)
* record distances between singular values on the I-th
* level and singular values on the (I -1)-th level, and
* DIFR(1:N, 2 * I ) contains the normalizing factors for
* the right singular vector matrix. See DLASD8 for details.
*
* Z (output) DOUBLE PRECISION array,
* dimension ( LDU, NLVL ) if ICOMPQ = 1 and
* dimension ( N ) if ICOMPQ = 0.
* The first K elements of Z(1, I) contain the components of
* the deflation-adjusted updating row vector for subproblems
* on the I-th level.
*
* POLES (output) DOUBLE PRECISION array,
* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced
* if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and
* POLES(1, 2*I) contain the new and old singular values
* involved in the secular equations on the I-th level.
*
* GIVPTR (output) INTEGER array,
* dimension ( N ) if ICOMPQ = 1, and not referenced if
* ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records
* the number of Givens rotations performed on the I-th
* problem on the computation tree.
*
* GIVCOL (output) INTEGER array,
* dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not
* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,
* GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations
* of Givens rotations performed on the I-th level on the
* computation tree.
*
* LDGCOL (input) INTEGER, LDGCOL = > N.
* The leading dimension of arrays GIVCOL and PERM.
*
* PERM (output) INTEGER array,
* dimension ( LDGCOL, NLVL ) if ICOMPQ = 1, and not referenced
* if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records
* permutations done on the I-th level of the computation tree.
*
* GIVNUM (output) DOUBLE PRECISION array,
* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not
* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,
* GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S-
* values of Givens rotations performed on the I-th level on
* the computation tree.
*
* C (output) DOUBLE PRECISION array,
* dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0.
* If ICOMPQ = 1 and the I-th subproblem is not square, on exit,
* C( I ) contains the C-value of a Givens rotation related to
* the right null space of the I-th subproblem.
*
* S (output) DOUBLE PRECISION array, dimension ( N ) if
* ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1
* and the I-th subproblem is not square, on exit, S( I )
* contains the S-value of a Givens rotation related to
* the right null space of the I-th subproblem.
*
* WORK (workspace) DOUBLE PRECISION array
* If ICOMPQ = 0 its dimension must be at least
* (2 * N + max(4 * N, (SMLSIZ + 4)*(SMLSIZ + 1))).
* and if ICOMPQ = 1, dimension must be at least (6 * N).
*
* IWORK (workspace) INTEGER array.
* Dimension must be at least (7 * N).
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an singular value did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, I1, IC, IDXQ, IDXQI, IM1, INODE, ITEMP, IWK,
$ J, LF, LL, LVL, LVL2, M, NCC, ND, NDB1, NDIML,
$ NDIMR, NL, NLF, NLP1, NLVL, NR, NRF, NRP1, NRU,
$ NWORK1, NWORK2, SMLSZP, SQREI, VF, VFI, VL, VLI
DOUBLE PRECISION ALPHA, BETA
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLASD6, DLASDQ, DLASDT, DLASET, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
INFO = -1
ELSE IF( SMLSIZ.LT.3 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
INFO = -4
ELSE IF( LDU.LT.( N+SQRE ) ) THEN
INFO = -8
ELSE IF( LDGCOL.LT.N ) THEN
INFO = -17
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLASDA', -INFO )
RETURN
END IF
*
M = N + SQRE
*
* If the input matrix is too small, call DLASDQ to find the SVD.
*
IF( N.LE.SMLSIZ ) THEN
IF( ICOMPQ.EQ.0 ) THEN
CALL DLASDQ( 'U', SQRE, N, 0, 0, 0, D, E, VT, LDU, U, LDU,
$ U, LDU, WORK, INFO )
ELSE
CALL DLASDQ( 'U', SQRE, N, M, N, 0, D, E, VT, LDU, U, LDU,
$ U, LDU, WORK, INFO )
END IF
RETURN
END IF
*
* Book-keeping and set up the computation tree.
*
INODE = 1
NDIML = INODE + N
NDIMR = NDIML + N
IDXQ = NDIMR + N
IWK = IDXQ + N
*
NCC = 0
NRU = 0
*
SMLSZP = SMLSIZ + 1
VF = 1
VL = VF + M
NWORK1 = VL + M
NWORK2 = NWORK1 + SMLSZP*SMLSZP
*
CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ),
$ IWORK( NDIMR ), SMLSIZ )
*
* for the nodes on bottom level of the tree, solve
* their subproblems by DLASDQ.
*
OPS = OPS + DBLE( 1 )
NDB1 = ( ND+1 ) / 2
DO 30 I = NDB1, ND
*
* IC : center row of each node
* NL : number of rows of left subproblem
* NR : number of rows of right subproblem
* NLF: starting row of the left subproblem
* NRF: starting row of the right subproblem
*
I1 = I - 1
IC = IWORK( INODE+I1 )
NL = IWORK( NDIML+I1 )
NLP1 = NL + 1
NR = IWORK( NDIMR+I1 )
NLF = IC - NL
NRF = IC + 1
IDXQI = IDXQ + NLF - 2
VFI = VF + NLF - 1
VLI = VL + NLF - 1
SQREI = 1
IF( ICOMPQ.EQ.0 ) THEN
CALL DLASET( 'A', NLP1, NLP1, ZERO, ONE, WORK( NWORK1 ),
$ SMLSZP )
CALL DLASDQ( 'U', SQREI, NL, NLP1, NRU, NCC, D( NLF ),
$ E( NLF ), WORK( NWORK1 ), SMLSZP,
$ WORK( NWORK2 ), NL, WORK( NWORK2 ), NL,
$ WORK( NWORK2 ), INFO )
ITEMP = NWORK1 + NL*SMLSZP
CALL DCOPY( NLP1, WORK( NWORK1 ), 1, WORK( VFI ), 1 )
CALL DCOPY( NLP1, WORK( ITEMP ), 1, WORK( VLI ), 1 )
ELSE
CALL DLASET( 'A', NL, NL, ZERO, ONE, U( NLF, 1 ), LDU )
CALL DLASET( 'A', NLP1, NLP1, ZERO, ONE, VT( NLF, 1 ), LDU )
CALL DLASDQ( 'U', SQREI, NL, NLP1, NL, NCC, D( NLF ),
$ E( NLF ), VT( NLF, 1 ), LDU, U( NLF, 1 ), LDU,
$ U( NLF, 1 ), LDU, WORK( NWORK1 ), INFO )
CALL DCOPY( NLP1, VT( NLF, 1 ), 1, WORK( VFI ), 1 )
CALL DCOPY( NLP1, VT( NLF, NLP1 ), 1, WORK( VLI ), 1 )
END IF
IF( INFO.NE.0 ) THEN
RETURN
END IF
DO 10 J = 1, NL
IWORK( IDXQI+J ) = J
10 CONTINUE
IF( ( I.EQ.ND ) .AND. ( SQRE.EQ.0 ) ) THEN
SQREI = 0
ELSE
SQREI = 1
END IF
IDXQI = IDXQI + NLP1
VFI = VFI + NLP1
VLI = VLI + NLP1
NRP1 = NR + SQREI
IF( ICOMPQ.EQ.0 ) THEN
CALL DLASET( 'A', NRP1, NRP1, ZERO, ONE, WORK( NWORK1 ),
$ SMLSZP )
CALL DLASDQ( 'U', SQREI, NR, NRP1, NRU, NCC, D( NRF ),
$ E( NRF ), WORK( NWORK1 ), SMLSZP,
$ WORK( NWORK2 ), NR, WORK( NWORK2 ), NR,
$ WORK( NWORK2 ), INFO )
ITEMP = NWORK1 + ( NRP1-1 )*SMLSZP
CALL DCOPY( NRP1, WORK( NWORK1 ), 1, WORK( VFI ), 1 )
CALL DCOPY( NRP1, WORK( ITEMP ), 1, WORK( VLI ), 1 )
ELSE
CALL DLASET( 'A', NR, NR, ZERO, ONE, U( NRF, 1 ), LDU )
CALL DLASET( 'A', NRP1, NRP1, ZERO, ONE, VT( NRF, 1 ), LDU )
CALL DLASDQ( 'U', SQREI, NR, NRP1, NR, NCC, D( NRF ),
$ E( NRF ), VT( NRF, 1 ), LDU, U( NRF, 1 ), LDU,
$ U( NRF, 1 ), LDU, WORK( NWORK1 ), INFO )
CALL DCOPY( NRP1, VT( NRF, 1 ), 1, WORK( VFI ), 1 )
CALL DCOPY( NRP1, VT( NRF, NRP1 ), 1, WORK( VLI ), 1 )
END IF
IF( INFO.NE.0 ) THEN
RETURN
END IF
DO 20 J = 1, NR
IWORK( IDXQI+J ) = J
20 CONTINUE
30 CONTINUE
*
* Now conquer each subproblem bottom-up.
*
J = 2**NLVL
DO 50 LVL = NLVL, 1, -1
LVL2 = LVL*2 - 1
*
* Find the first node LF and last node LL on
* the current level LVL.
*
IF( LVL.EQ.1 ) THEN
LF = 1
LL = 1
ELSE
LF = 2**( LVL-1 )
LL = 2*LF - 1
END IF
DO 40 I = LF, LL
IM1 = I - 1
IC = IWORK( INODE+IM1 )
NL = IWORK( NDIML+IM1 )
NR = IWORK( NDIMR+IM1 )
NLF = IC - NL
NRF = IC + 1
IF( I.EQ.LL ) THEN
SQREI = SQRE
ELSE
SQREI = 1
END IF
VFI = VF + NLF - 1
VLI = VL + NLF - 1
IDXQI = IDXQ + NLF - 1
ALPHA = D( IC )
BETA = E( IC )
IF( ICOMPQ.EQ.0 ) THEN
CALL DLASD6( ICOMPQ, NL, NR, SQREI, D( NLF ),
$ WORK( VFI ), WORK( VLI ), ALPHA, BETA,
$ IWORK( IDXQI ), PERM, GIVPTR( 1 ), GIVCOL,
$ LDGCOL, GIVNUM, LDU, POLES, DIFL, DIFR, Z,
$ K( 1 ), C( 1 ), S( 1 ), WORK( NWORK1 ),
$ IWORK( IWK ), INFO )
ELSE
J = J - 1
CALL DLASD6( ICOMPQ, NL, NR, SQREI, D( NLF ),
$ WORK( VFI ), WORK( VLI ), ALPHA, BETA,
$ IWORK( IDXQI ), PERM( NLF, LVL ),
$ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
$ GIVNUM( NLF, LVL2 ), LDU,
$ POLES( NLF, LVL2 ), DIFL( NLF, LVL ),
$ DIFR( NLF, LVL2 ), Z( NLF, LVL ), K( J ),
$ C( J ), S( J ), WORK( NWORK1 ),
$ IWORK( IWK ), INFO )
END IF
IF( INFO.NE.0 ) THEN
RETURN
END IF
40 CONTINUE
50 CONTINUE
*
RETURN
*
* End of DLASDA
*
END
SUBROUTINE DLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT,
$ U, LDU, C, LDC, WORK, INFO )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU, SQRE
* ..
* .. Array Arguments ..
DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ),
$ VT( LDVT, * ), WORK( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLASDQ computes the singular value decomposition (SVD) of a real
* (upper or lower) bidiagonal matrix with diagonal D and offdiagonal
* E, accumulating the transformations if desired. Letting B denote
* the input bidiagonal matrix, the algorithm computes orthogonal
* matrices Q and P such that B = Q * S * P' (P' denotes the transpose
* of P). The singular values S are overwritten on D.
*
* The input matrix U is changed to U * Q if desired.
* The input matrix VT is changed to P' * VT if desired.
* The input matrix C is changed to Q' * C if desired.
*
* See "Computing Small Singular Values of Bidiagonal Matrices With
* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
* LAPACK Working Note #3, for a detailed description of the algorithm.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* On entry, UPLO specifies whether the input bidiagonal matrix
* is upper or lower bidiagonal, and wether it is square are
* not.
* UPLO = 'U' or 'u' B is upper bidiagonal.
* UPLO = 'L' or 'l' B is lower bidiagonal.
*
* SQRE (input) INTEGER
* = 0: then the input matrix is N-by-N.
* = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and
* (N+1)-by-N if UPLU = 'L'.
*
* The bidiagonal matrix has
* N = NL + NR + 1 rows and
* M = N + SQRE >= N columns.
*
* N (input) INTEGER
* On entry, N specifies the number of rows and columns
* in the matrix. N must be at least 0.
*
* NCVT (input) INTEGER
* On entry, NCVT specifies the number of columns of
* the matrix VT. NCVT must be at least 0.
*
* NRU (input) INTEGER
* On entry, NRU specifies the number of rows of
* the matrix U. NRU must be at least 0.
*
* NCC (input) INTEGER
* On entry, NCC specifies the number of columns of
* the matrix C. NCC must be at least 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, D contains the diagonal entries of the
* bidiagonal matrix whose SVD is desired. On normal exit,
* D contains the singular values in ascending order.
*
* E (input/output) DOUBLE PRECISION array.
* dimension is (N-1) if SQRE = 0 and N if SQRE = 1.
* On entry, the entries of E contain the offdiagonal entries
* of the bidiagonal matrix whose SVD is desired. On normal
* exit, E will contain 0. If the algorithm does not converge,
* D and E will contain the diagonal and superdiagonal entries
* of a bidiagonal matrix orthogonally equivalent to the one
* given as input.
*
* VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT)
* On entry, contains a matrix which on exit has been
* premultiplied by P', dimension N-by-NCVT if SQRE = 0
* and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0).
*
* LDVT (input) INTEGER
* On entry, LDVT specifies the leading dimension of VT as
* declared in the calling (sub) program. LDVT must be at
* least 1. If NCVT is nonzero LDVT must also be at least N.
*
* U (input/output) DOUBLE PRECISION array, dimension (LDU, N)
* On entry, contains a matrix which on exit has been
* postmultiplied by Q, dimension NRU-by-N if SQRE = 0
* and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0).
*
* LDU (input) INTEGER
* On entry, LDU specifies the leading dimension of U as
* declared in the calling (sub) program. LDU must be at
* least max( 1, NRU ) .
*
* C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC)
* On entry, contains an N-by-NCC matrix which on exit
* has been premultiplied by Q' dimension N-by-NCC if SQRE = 0
* and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0).
*
* LDC (input) INTEGER
* On entry, LDC specifies the leading dimension of C as
* declared in the calling (sub) program. LDC must be at
* least 1. If NCC is nonzero, LDC must also be at least N.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (MAX( 1, 4*N ))
* Workspace. Only referenced if one of NCVT, NRU, or NCC is
* nonzero, and if N is at least 2.
*
* INFO (output) INTEGER
* On exit, a value of 0 indicates a successful exit.
* If INFO < 0, argument number -INFO is illegal.
* If INFO > 0, the algorithm did not converge, and INFO
* specifies how many superdiagonals did not converge.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
LOGICAL ROTATE
INTEGER I, ISUB, IUPLO, J, NP1, SQRE1
DOUBLE PRECISION CS, R, SMIN, SN
* ..
* .. External Subroutines ..
EXTERNAL DBDSQR, DLARTG, DLASR, DSWAP, XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IUPLO = 0
IF( LSAME( UPLO, 'U' ) )
$ IUPLO = 1
IF( LSAME( UPLO, 'L' ) )
$ IUPLO = 2
IF( IUPLO.EQ.0 ) THEN
INFO = -1
ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NCVT.LT.0 ) THEN
INFO = -4
ELSE IF( NRU.LT.0 ) THEN
INFO = -5
ELSE IF( NCC.LT.0 ) THEN
INFO = -6
ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR.
$ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN
INFO = -10
ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN
INFO = -12
ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR.
$ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN
INFO = -14
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DBDSQR', -INFO )
RETURN
END IF
IF( N.EQ.0 )
$ RETURN
*
* ROTATE is true if any singular vectors desired, false otherwise
*
ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 )
NP1 = N + 1
SQRE1 = SQRE
*
* If matrix non-square upper bidiagonal, rotate to be lower
* bidiagonal. The rotations are on the right.
*
IF( ( IUPLO.EQ.1 ) .AND. ( SQRE1.EQ.1 ) ) THEN
OPS = OPS + DBLE( 8*( N-1 ) )
DO 10 I = 1, N - 1
CALL DLARTG( D( I ), E( I ), CS, SN, R )
D( I ) = R
E( I ) = SN*D( I+1 )
D( I+1 ) = CS*D( I+1 )
IF( ROTATE ) THEN
WORK( I ) = CS
WORK( N+I ) = SN
END IF
10 CONTINUE
OPS = OPS + DBLE( 6 )
CALL DLARTG( D( N ), E( N ), CS, SN, R )
D( N ) = R
E( N ) = ZERO
IF( ROTATE ) THEN
WORK( N ) = CS
WORK( N+N ) = SN
END IF
IUPLO = 2
SQRE1 = 0
*
* Update singular vectors if desired.
*
IF( NCVT.GT.0 ) THEN
OPS = OPS + DBLE( 6*( NP1-1 )*NCVT )
CALL DLASR( 'L', 'V', 'F', NP1, NCVT, WORK( 1 ),
$ WORK( NP1 ), VT, LDVT )
END IF
END IF
*
* If matrix lower bidiagonal, rotate to be upper bidiagonal
* by applying Givens rotations on the left.
*
IF( IUPLO.EQ.2 ) THEN
OPS = OPS + DBLE( 8*( N-1 ) )
DO 20 I = 1, N - 1
CALL DLARTG( D( I ), E( I ), CS, SN, R )
D( I ) = R
E( I ) = SN*D( I+1 )
D( I+1 ) = CS*D( I+1 )
IF( ROTATE ) THEN
WORK( I ) = CS
WORK( N+I ) = SN
END IF
20 CONTINUE
*
* If matrix (N+1)-by-N lower bidiagonal, one additional
* rotation is needed.
*
IF( SQRE1.EQ.1 ) THEN
OPS = OPS + DBLE( 6 )
CALL DLARTG( D( N ), E( N ), CS, SN, R )
D( N ) = R
IF( ROTATE ) THEN
WORK( N ) = CS
WORK( N+N ) = SN
END IF
END IF
*
* Update singular vectors if desired.
*
IF( NRU.GT.0 ) THEN
IF( SQRE1.EQ.0 ) THEN
OPS = OPS + DBLE( 6*( N-1 )*NRU )
CALL DLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ),
$ WORK( NP1 ), U, LDU )
ELSE
OPS = OPS + DBLE( 6*N*NRU )
CALL DLASR( 'R', 'V', 'F', NRU, NP1, WORK( 1 ),
$ WORK( NP1 ), U, LDU )
END IF
END IF
IF( NCC.GT.0 ) THEN
IF( SQRE1.EQ.0 ) THEN
OPS = OPS + DBLE( 6*( N-1 )*NCC )
CALL DLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ),
$ WORK( NP1 ), C, LDC )
ELSE
OPS = OPS + DBLE( 6*N*NCC )
CALL DLASR( 'L', 'V', 'F', NP1, NCC, WORK( 1 ),
$ WORK( NP1 ), C, LDC )
END IF
END IF
END IF
*
* Call DBDSQR to compute the SVD of the reduced real
* N-by-N upper bidiagonal matrix.
*
CALL DBDSQR( 'U', N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C,
$ LDC, WORK, INFO )
*
* Sort the singular values into ascending order (insertion sort on
* singular values, but only one transposition per singular vector)
*
DO 40 I = 1, N
*
* Scan for smallest D(I).
*
ISUB = I
SMIN = D( I )
DO 30 J = I + 1, N
IF( D( J ).LT.SMIN ) THEN
ISUB = J
SMIN = D( J )
END IF
30 CONTINUE
IF( ISUB.NE.I ) THEN
*
* Swap singular values and vectors.
*
D( ISUB ) = D( I )
D( I ) = SMIN
IF( NCVT.GT.0 )
$ CALL DSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( I, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL DSWAP( NRU, U( 1, ISUB ), 1, U( 1, I ), 1 )
IF( NCC.GT.0 )
$ CALL DSWAP( NCC, C( ISUB, 1 ), LDC, C( I, 1 ), LDC )
END IF
40 CONTINUE
*
RETURN
*
* End of DLASDQ
*
END
SUBROUTINE DLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB )
*
* -- LAPACK auxiliary routine (instrum to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER LVL, MSUB, N, ND
* ..
* .. Array Arguments ..
INTEGER INODE( * ), NDIML( * ), NDIMR( * )
* ..
* Common block to return operation count
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLASDT creates a tree of subproblems for bidiagonal divide and
* conquer.
*
* Arguments
* =========
*
* N (input) INTEGER
* On entry, the number of diagonal elements of the
* bidiagonal matrix.
*
* LVL (output) INTEGER
* On exit, the number of levels on the computation tree.
*
* ND (output) INTEGER
* On exit, the number of nodes on the tree.
*
* INODE (output) INTEGER array, dimension ( N )
* On exit, centers of subproblems.
*
* NDIML (output) INTEGER array, dimension ( N )
* On exit, row dimensions of left children.
*
* NDIMR (output) INTEGER array, dimension ( N )
* On exit, row dimensions of right children.
*
* MSUB (input) INTEGER.
* On entry, the maximum row dimension each subproblem at the
* bottom of the tree can be of.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, IL, IR, LLST, MAXN, NCRNT, NLVL
DOUBLE PRECISION TEMP
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, INT, LOG, MAX
* ..
* .. Executable Statements ..
*
* Find the number of levels on the tree.
*
OPS = OPS + DBLE( 2 )
MAXN = MAX( 1, N )
TEMP = LOG( DBLE( MAXN ) / DBLE( MSUB+1 ) ) / LOG( TWO )
LVL = INT( TEMP ) + 1
*
I = N / 2
INODE( 1 ) = I + 1
NDIML( 1 ) = I
NDIMR( 1 ) = N - I - 1
IL = 0
IR = 1
LLST = 1
DO 20 NLVL = 1, LVL - 1
*
* Constructing the tree at (NLVL+1)-st level. The number of
* nodes created on this level is LLST * 2.
*
DO 10 I = 0, LLST - 1
IL = IL + 2
IR = IR + 2
NCRNT = LLST + I
NDIML( IL ) = NDIML( NCRNT ) / 2
NDIMR( IL ) = NDIML( NCRNT ) - NDIML( IL ) - 1
INODE( IL ) = INODE( NCRNT ) - NDIMR( IL ) - 1
NDIML( IR ) = NDIMR( NCRNT ) / 2
NDIMR( IR ) = NDIMR( NCRNT ) - NDIML( IR ) - 1
INODE( IR ) = INODE( NCRNT ) + NDIML( IR ) + 1
10 CONTINUE
LLST = LLST*2
20 CONTINUE
ND = LLST*2 - 1
*
RETURN
*
* End of DLASDT
*
END
SUBROUTINE DLASQ1( N, D, E, WORK, INFO )
*
* -- LAPACK routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
INTEGER INFO, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * ), WORK( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLASQ1 computes the singular values of a real N-by-N bidiagonal
* matrix with diagonal D and off-diagonal E. The singular values
* are computed to high relative accuracy, in the absence of
* denormalization, underflow and overflow. The algorithm was first
* presented in
*
* "Accurate singular values and differential qd algorithms" by K. V.
* Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230,
* 1994,
*
* and the present implementation is described in "An implementation of
* the dqds Algorithm (Positive Case)", LAPACK Working Note.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of rows and columns in the matrix. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, D contains the diagonal elements of the
* bidiagonal matrix whose SVD is desired. On normal exit,
* D contains the singular values in decreasing order.
*
* E (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, elements E(1:N-1) contain the off-diagonal elements
* of the bidiagonal matrix whose SVD is desired.
* On exit, E is overwritten.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: the algorithm failed
* = 1, a split was marked by a positive value in E
* = 2, current block of Z not diagonalized after 30*N
* iterations (in inner while loop)
* = 3, termination criterion of outer while loop not met
* (program created more than N unreduced blocks)
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, IINFO
DOUBLE PRECISION EPS, SCALE, SAFMIN, SIGMN, SIGMX
* ..
* .. External Subroutines ..
EXTERNAL DLAS2, DLASQ2, DLASRT, XERBLA
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -2
CALL XERBLA( 'DLASQ1', -INFO )
RETURN
ELSE IF( N.EQ.0 ) THEN
RETURN
ELSE IF( N.EQ.1 ) THEN
D( 1 ) = ABS( D( 1 ) )
RETURN
ELSE IF( N.EQ.2 ) THEN
CALL DLAS2( D( 1 ), E( 1 ), D( 2 ), SIGMN, SIGMX )
D( 1 ) = SIGMX
D( 2 ) = SIGMN
RETURN
END IF
*
* Estimate the largest singular value.
*
SIGMX = ZERO
DO 10 I = 1, N - 1
D( I ) = ABS( D( I ) )
SIGMX = MAX( SIGMX, ABS( E( I ) ) )
10 CONTINUE
D( N ) = ABS( D( N ) )
*
* Early return if SIGMX is zero (matrix is already diagonal).
*
IF( SIGMX.EQ.ZERO ) THEN
CALL DLASRT( 'D', N, D, IINFO )
RETURN
END IF
*
DO 20 I = 1, N
SIGMX = MAX( SIGMX, D( I ) )
20 CONTINUE
*
* Copy D and E into WORK (in the Z format) and scale (squaring the
* input data makes scaling by a power of the radix pointless).
*
OPS = OPS + DBLE( 1 + 2*N )
EPS = DLAMCH( 'Precision' )
SAFMIN = DLAMCH( 'Safe minimum' )
SCALE = SQRT( EPS / SAFMIN )
CALL DCOPY( N, D, 1, WORK( 1 ), 2 )
CALL DCOPY( N-1, E, 1, WORK( 2 ), 2 )
CALL DLASCL( 'G', 0, 0, SIGMX, SCALE, 2*N-1, 1, WORK, 2*N-1,
$ IINFO )
*
* Compute the q's and e's.
*
OPS = OPS + DBLE( 2*N-1 )
DO 30 I = 1, 2*N - 1
WORK( I ) = WORK( I )**2
30 CONTINUE
WORK( 2*N ) = ZERO
*
CALL DLASQ2( N, WORK, INFO )
*
IF( INFO.EQ.0 ) THEN
OPS = OPS + DBLE( 2*N )
DO 40 I = 1, N
D( I ) = SQRT( WORK( I ) )
40 CONTINUE
CALL DLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, D, N, IINFO )
END IF
*
RETURN
*
* End of DLASQ1
*
END
SUBROUTINE DLASQ2( N, Z, INFO )
*
* -- LAPACK routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
INTEGER INFO, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION Z( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLASQ2 computes all the eigenvalues of the symmetric positive
* definite tridiagonal matrix associated with the qd array Z to high
* relative accuracy are computed to high relative accuracy, in the
* absence of denormalization, underflow and overflow.
*
* To see the relation of Z to the tridiagonal matrix, let L be a
* unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and
* let U be an upper bidiagonal matrix with 1's above and diagonal
* Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the
* symmetric tridiagonal to which it is similar.
*
* Note : DLASQ2 defines a logical variable, IEEE, which is true
* on machines which follow ieee-754 floating-point standard in their
* handling of infinities and NaNs, and false otherwise. This variable
* is passed to DLASQ3.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of rows and columns in the matrix. N >= 0.
*
* Z (workspace) DOUBLE PRECISION array, dimension ( 4*N )
* On entry Z holds the qd array. On exit, entries 1 to N hold
* the eigenvalues in decreasing order, Z( 2*N+1 ) holds the
* trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If
* N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 )
* holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of
* shifts that failed.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if the i-th argument is a scalar and had an illegal
* value, then INFO = -i, if the i-th argument is an
* array and the j-entry had an illegal value, then
* INFO = -(i*100+j)
* > 0: the algorithm failed
* = 1, a split was marked by a positive value in E
* = 2, current block of Z not diagonalized after 30*N
* iterations (in inner while loop)
* = 3, termination criterion of outer while loop not met
* (program created more than N unreduced blocks)
*
* Further Details
* ===============
* Local Variables: I0:N0 defines a current unreduced segment of Z.
* The shifts are accumulated in SIGMA. Iteration count is in ITER.
* Ping-pong is controlled by PP (alternates between 0 and 1).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION CBIAS
PARAMETER ( CBIAS = 1.50D0 )
DOUBLE PRECISION ZERO, HALF, ONE, TWO, FOUR, HUNDRD
PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0,
$ TWO = 2.0D0, FOUR = 4.0D0, HUNDRD = 100.0D0 )
* ..
* .. Local Scalars ..
LOGICAL IEEE
INTEGER I0, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, K,
$ N0, NBIG, NDIV, NFAIL, PP, SPLT
DOUBLE PRECISION D, DESIG, DMIN, E, EMAX, EMIN, EPS, OLDEMN,
$ QMAX, QMIN, S, SAFMIN, SIGMA, T, TEMP, TOL,
$ TOL2, TRACE, ZMAX
* ..
* .. External Subroutines ..
EXTERNAL DLASQ3, DLASRT, XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH, ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input arguments.
* (in case DLASQ2 is not called by DLASQ1)
*
OPS = OPS + DBLE( 2 )
INFO = 0
EPS = DLAMCH( 'Precision' )
SAFMIN = DLAMCH( 'Safe minimum' )
TOL = EPS*HUNDRD
TOL2 = TOL**2
*
IF( N.LT.0 ) THEN
INFO = -1
CALL XERBLA( 'DLASQ2', 1 )
RETURN
ELSE IF( N.EQ.0 ) THEN
RETURN
ELSE IF( N.EQ.1 ) THEN
*
* 1-by-1 case.
*
IF( Z( 1 ).LT.ZERO ) THEN
INFO = -201
CALL XERBLA( 'DLASQ2', 2 )
END IF
RETURN
ELSE IF( N.EQ.2 ) THEN
*
* 2-by-2 case.
*
IF( Z( 2 ).LT.ZERO .OR. Z( 3 ).LT.ZERO ) THEN
INFO = -2
CALL XERBLA( 'DLASQ2', 2 )
RETURN
ELSE IF( Z( 3 ).GT.Z( 1 ) ) THEN
D = Z( 3 )
Z( 3 ) = Z( 1 )
Z( 1 ) = D
END IF
OPS = OPS + DBLE( 4 )
Z( 5 ) = Z( 1 ) + Z( 2 ) + Z( 3 )
IF( Z( 2 ).GT.Z( 3 )*TOL2 ) THEN
OPS = OPS + DBLE( 16 )
T = HALF*( ( Z( 1 )-Z( 3 ) )+Z( 2 ) )
S = Z( 3 )*( Z( 2 ) / T )
IF( S.LE.T ) THEN
S = Z( 3 )*( Z( 2 ) / ( T*( ONE+SQRT( ONE+S / T ) ) ) )
ELSE
S = Z( 3 )*( Z( 2 ) / ( T+SQRT( T )*SQRT( T+S ) ) )
END IF
T = Z( 1 ) + ( S+Z( 2 ) )
Z( 3 ) = Z( 3 )*( Z( 1 ) / T )
Z( 1 ) = T
END IF
Z( 2 ) = Z( 3 )
Z( 6 ) = Z( 2 ) + Z( 1 )
RETURN
END IF
*
* Check for negative data and compute sums of q's and e's.
*
Z( 2*N ) = ZERO
EMIN = Z( 2 )
QMAX = ZERO
ZMAX = ZERO
D = ZERO
E = ZERO
*
OPS = OPS + DBLE( 2*N )
DO 10 K = 1, 2*( N-1 ), 2
IF( Z( K ).LT.ZERO ) THEN
INFO = -( 200+K )
CALL XERBLA( 'DLASQ2', 2 )
RETURN
ELSE IF( Z( K+1 ).LT.ZERO ) THEN
INFO = -( 200+K+1 )
CALL XERBLA( 'DLASQ2', 2 )
RETURN
END IF
D = D + Z( K )
E = E + Z( K+1 )
QMAX = MAX( QMAX, Z( K ) )
EMIN = MIN( EMIN, Z( K+1 ) )
ZMAX = MAX( QMAX, ZMAX, Z( K+1 ) )
10 CONTINUE
IF( Z( 2*N-1 ).LT.ZERO ) THEN
INFO = -( 200+2*N-1 )
CALL XERBLA( 'DLASQ2', 2 )
RETURN
END IF
D = D + Z( 2*N-1 )
QMAX = MAX( QMAX, Z( 2*N-1 ) )
ZMAX = MAX( QMAX, ZMAX )
*
* Check for diagonality.
*
IF( E.EQ.ZERO ) THEN
DO 20 K = 2, N
Z( K ) = Z( 2*K-1 )
20 CONTINUE
CALL DLASRT( 'D', N, Z, IINFO )
Z( 2*N-1 ) = D
RETURN
END IF
*
TRACE = D + E
*
* Check for zero data.
*
IF( TRACE.EQ.ZERO ) THEN
Z( 2*N-1 ) = ZERO
RETURN
END IF
*
* Check whether the machine is IEEE conformable.
*
IEEE = ILAENV( 10, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 .AND.
$ ILAENV( 11, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1
*
* Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...).
*
DO 30 K = 2*N, 2, -2
Z( 2*K ) = ZERO
Z( 2*K-1 ) = Z( K )
Z( 2*K-2 ) = ZERO
Z( 2*K-3 ) = Z( K-1 )
30 CONTINUE
*
I0 = 1
N0 = N
*
* Reverse the qd-array, if warranted.
*
OPS = OPS + DBLE( 1 )
IF( CBIAS*Z( 4*I0-3 ).LT.Z( 4*N0-3 ) ) THEN
IPN4 = 4*( I0+N0 )
DO 40 I4 = 4*I0, 2*( I0+N0-1 ), 4
TEMP = Z( I4-3 )
Z( I4-3 ) = Z( IPN4-I4-3 )
Z( IPN4-I4-3 ) = TEMP
TEMP = Z( I4-1 )
Z( I4-1 ) = Z( IPN4-I4-5 )
Z( IPN4-I4-5 ) = TEMP
40 CONTINUE
END IF
*
* Initial split checking via dqd and Li's test.
*
PP = 0
*
DO 80 K = 1, 2
*
OPS = OPS + DBLE( N0-I0 )
D = Z( 4*N0+PP-3 )
DO 50 I4 = 4*( N0-1 ) + PP, 4*I0 + PP, -4
IF( Z( I4-1 ).LE.TOL2*D ) THEN
Z( I4-1 ) = -ZERO
D = Z( I4-3 )
ELSE
OPS = OPS + DBLE( 3 )
D = Z( I4-3 )*( D / ( D+Z( I4-1 ) ) )
END IF
50 CONTINUE
*
* dqd maps Z to ZZ plus Li's test.
*
OPS = OPS + DBLE( N0-I0 )
EMIN = Z( 4*I0+PP+1 )
D = Z( 4*I0+PP-3 )
DO 60 I4 = 4*I0 + PP, 4*( N0-1 ) + PP, 4
Z( I4-2*PP-2 ) = D + Z( I4-1 )
IF( Z( I4-1 ).LE.TOL2*D ) THEN
Z( I4-1 ) = -ZERO
Z( I4-2*PP-2 ) = D
Z( I4-2*PP ) = ZERO
D = Z( I4+1 )
ELSE IF( SAFMIN*Z( I4+1 ).LT.Z( I4-2*PP-2 ) .AND.
$ SAFMIN*Z( I4-2*PP-2 ).LT.Z( I4+1 ) ) THEN
OPS = OPS + DBLE( 5 )
TEMP = Z( I4+1 ) / Z( I4-2*PP-2 )
Z( I4-2*PP ) = Z( I4-1 )*TEMP
D = D*TEMP
ELSE
OPS = OPS + DBLE( 5 )
Z( I4-2*PP ) = Z( I4+1 )*( Z( I4-1 ) / Z( I4-2*PP-2 ) )
D = Z( I4+1 )*( D / Z( I4-2*PP-2 ) )
END IF
EMIN = MIN( EMIN, Z( I4-2*PP ) )
60 CONTINUE
Z( 4*N0-PP-2 ) = D
*
* Now find qmax.
*
QMAX = Z( 4*I0-PP-2 )
DO 70 I4 = 4*I0 - PP + 2, 4*N0 - PP - 2, 4
QMAX = MAX( QMAX, Z( I4 ) )
70 CONTINUE
*
* Prepare for the next iteration on K.
*
PP = 1 - PP
80 CONTINUE
*
ITER = 2
NFAIL = 0
NDIV = 2*( N0-I0 )
*
DO 140 IWHILA = 1, N + 1
IF( N0.LT.1 )
$ GO TO 150
*
* While array unfinished do
*
* E(N0) holds the value of SIGMA when submatrix in I0:N0
* splits from the rest of the array, but is negated.
*
DESIG = ZERO
IF( N0.EQ.N ) THEN
SIGMA = ZERO
ELSE
SIGMA = -Z( 4*N0-1 )
END IF
IF( SIGMA.LT.ZERO ) THEN
INFO = 1
RETURN
END IF
*
* Find last unreduced submatrix's top index I0, find QMAX and
* EMIN. Find Gershgorin-type bound if Q's much greater than E's.
*
EMAX = ZERO
IF( N0.GT.I0 ) THEN
EMIN = ABS( Z( 4*N0-5 ) )
ELSE
EMIN = ZERO
END IF
QMIN = Z( 4*N0-3 )
QMAX = QMIN
DO 90 I4 = 4*N0, 8, -4
IF( Z( I4-5 ).LE.ZERO )
$ GO TO 100
OPS = OPS + DBLE( 2 )
IF( QMIN.GE.FOUR*EMAX ) THEN
QMIN = MIN( QMIN, Z( I4-3 ) )
EMAX = MAX( EMAX, Z( I4-5 ) )
END IF
QMAX = MAX( QMAX, Z( I4-7 )+Z( I4-5 ) )
EMIN = MIN( EMIN, Z( I4-5 ) )
90 CONTINUE
I4 = 4
*
100 CONTINUE
I0 = I4 / 4
*
* Store EMIN for passing to DLASQ3.
*
Z( 4*N0-1 ) = EMIN
*
* Put -(initial shift) into DMIN.
*
OPS = OPS + DBLE( 5 )
DMIN = -MAX( ZERO, QMIN-TWO*SQRT( QMIN )*SQRT( EMAX ) )
*
* Now I0:N0 is unreduced. PP = 0 for ping, PP = 1 for pong.
*
PP = 0
*
NBIG = 30*( N0-I0+1 )
DO 120 IWHILB = 1, NBIG
IF( I0.GT.N0 )
$ GO TO 130
*
* While submatrix unfinished take a good dqds step.
*
CALL DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL,
$ ITER, NDIV, IEEE )
*
PP = 1 - PP
*
* When EMIN is very small check for splits.
*
IF( PP.EQ.0 .AND. N0-I0.GE.3 ) THEN
OPS = OPS + DBLE( 2 )
IF( Z( 4*N0 ).LE.TOL2*QMAX .OR.
$ Z( 4*N0-1 ).LE.TOL2*SIGMA ) THEN
SPLT = I0 - 1
QMAX = Z( 4*I0-3 )
EMIN = Z( 4*I0-1 )
OLDEMN = Z( 4*I0 )
DO 110 I4 = 4*I0, 4*( N0-3 ), 4
OPS = OPS + DBLE( 1 )
IF( Z( I4 ).LE.TOL2*Z( I4-3 ) .OR.
$ Z( I4-1 ).LE.TOL2*SIGMA ) THEN
Z( I4-1 ) = -SIGMA
SPLT = I4 / 4
QMAX = ZERO
EMIN = Z( I4+3 )
OLDEMN = Z( I4+4 )
ELSE
QMAX = MAX( QMAX, Z( I4+1 ) )
EMIN = MIN( EMIN, Z( I4-1 ) )
OLDEMN = MIN( OLDEMN, Z( I4 ) )
END IF
110 CONTINUE
Z( 4*N0-1 ) = EMIN
Z( 4*N0 ) = OLDEMN
I0 = SPLT + 1
END IF
END IF
*
120 CONTINUE
*
INFO = 2
RETURN
*
* end IWHILB
*
130 CONTINUE
*
140 CONTINUE
*
INFO = 3
RETURN
*
* end IWHILA
*
150 CONTINUE
*
* Move q's to the front.
*
DO 160 K = 2, N
Z( K ) = Z( 4*K-3 )
160 CONTINUE
*
* Sort and compute sum of eigenvalues.
*
CALL DLASRT( 'D', N, Z, IINFO )
*
E = ZERO
DO 170 K = N, 1, -1
E = E + Z( K )
170 CONTINUE
*
* Store trace, sum(eigenvalues) and information on performance.
*
Z( 2*N+1 ) = TRACE
Z( 2*N+2 ) = E
Z( 2*N+3 ) = DBLE( ITER )
Z( 2*N+4 ) = DBLE( NDIV ) / DBLE( N**2 )
Z( 2*N+5 ) = HUNDRD*NFAIL / DBLE( ITER )
RETURN
*
* End of DLASQ2
*
END
SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL,
$ ITER, NDIV, IEEE )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* May 17, 2000
*
* .. Scalar Arguments ..
LOGICAL IEEE
INTEGER I0, ITER, N0, NDIV, NFAIL, PP
DOUBLE PRECISION DESIG, DMIN, QMAX, SIGMA
* ..
* .. Array Arguments ..
DOUBLE PRECISION Z( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLASQ3 checks for deflation, computes a shift (TAU) and calls dqds.
* In case of failure it changes shifts, and tries again until output
* is positive.
*
* Arguments
* =========
*
* I0 (input) INTEGER
* First index.
*
* N0 (input) INTEGER
* Last index.
*
* Z (input) DOUBLE PRECISION array, dimension ( 4*N )
* Z holds the qd array.
*
* PP (input) INTEGER
* PP=0 for ping, PP=1 for pong.
*
* DMIN (output) DOUBLE PRECISION
* Minimum value of d.
*
* SIGMA (output) DOUBLE PRECISION
* Sum of shifts used in current segment.
*
* DESIG (input/output) DOUBLE PRECISION
* Lower order part of SIGMA
*
* QMAX (input) DOUBLE PRECISION
* Maximum value of q.
*
* NFAIL (output) INTEGER
* Number of times shift was too big.
*
* ITER (output) INTEGER
* Number of iterations.
*
* NDIV (output) INTEGER
* Number of divisions.
*
* TTYPE (output) INTEGER
* Shift type.
*
* IEEE (input) LOGICAL
* Flag for IEEE or non IEEE arithmetic (passed to DLASQ5).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION CBIAS
PARAMETER ( CBIAS = 1.50D0 )
DOUBLE PRECISION ZERO, QURTR, HALF, ONE, TWO, HUNDRD
PARAMETER ( ZERO = 0.0D0, QURTR = 0.250D0, HALF = 0.5D0,
$ ONE = 1.0D0, TWO = 2.0D0, HUNDRD = 100.0D0 )
* ..
* .. Local Scalars ..
INTEGER IPN4, J4, N0IN, NN, TTYPE
DOUBLE PRECISION DMIN1, DMIN2, DN, DN1, DN2, EPS, S, SAFMIN, T,
$ TAU, TEMP, TOL, TOL2
* ..
* .. External Subroutines ..
EXTERNAL DLASQ4, DLASQ5, DLASQ6
* ..
* .. External Function ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MIN, SQRT
* ..
* .. Save statement ..
SAVE TTYPE
SAVE DMIN1, DMIN2, DN, DN1, DN2, TAU
* ..
* .. Data statement ..
DATA TTYPE / 0 /
DATA DMIN1 / ZERO /, DMIN2 / ZERO /, DN / ZERO /,
$ DN1 / ZERO /, DN2 / ZERO /, TAU / ZERO /
* ..
* .. Executable Statements ..
*
OPS = OPS + DBLE( 2 )
N0IN = N0
EPS = DLAMCH( 'Precision' )
SAFMIN = DLAMCH( 'Safe minimum' )
TOL = EPS*HUNDRD
TOL2 = TOL**2
*
* Check for deflation.
*
10 CONTINUE
*
IF( N0.LT.I0 )
$ RETURN
IF( N0.EQ.I0 )
$ GO TO 20
NN = 4*N0 + PP
IF( N0.EQ.( I0+1 ) )
$ GO TO 40
*
* Check whether E(N0-1) is negligible, 1 eigenvalue.
*
OPS = OPS + DBLE( 3 )
IF( Z( NN-5 ).GT.TOL2*( SIGMA+Z( NN-3 ) ) .AND.
$ Z( NN-2*PP-4 ).GT.TOL2*Z( NN-7 ) )
$ GO TO 30
*
20 CONTINUE
*
OPS = OPS + DBLE( 1 )
Z( 4*N0-3 ) = Z( 4*N0+PP-3 ) + SIGMA
N0 = N0 - 1
GO TO 10
*
* Check whether E(N0-2) is negligible, 2 eigenvalues.
*
30 CONTINUE
*
OPS = OPS + DBLE( 2 )
IF( Z( NN-9 ).GT.TOL2*SIGMA .AND.
$ Z( NN-2*PP-8 ).GT.TOL2*Z( NN-11 ) )
$ GO TO 50
*
40 CONTINUE
*
IF( Z( NN-3 ).GT.Z( NN-7 ) ) THEN
S = Z( NN-3 )
Z( NN-3 ) = Z( NN-7 )
Z( NN-7 ) = S
END IF
OPS = OPS + DBLE( 3 )
IF( Z( NN-5 ).GT.Z( NN-3 )*TOL2 ) THEN
OPS = OPS + DBLE( 5 )
T = HALF*( ( Z( NN-7 )-Z( NN-3 ) )+Z( NN-5 ) )
S = Z( NN-3 )*( Z( NN-5 ) / T )
IF( S.LE.T ) THEN
OPS = OPS + DBLE( 7 )
S = Z( NN-3 )*( Z( NN-5 ) /
$ ( T*( ONE+SQRT( ONE+S / T ) ) ) )
ELSE
OPS = OPS + DBLE( 6 )
S = Z( NN-3 )*( Z( NN-5 ) / ( T+SQRT( T )*SQRT( T+S ) ) )
END IF
OPS = OPS + DBLE( 4 )
T = Z( NN-7 ) + ( S+Z( NN-5 ) )
Z( NN-3 ) = Z( NN-3 )*( Z( NN-7 ) / T )
Z( NN-7 ) = T
END IF
Z( 4*N0-7 ) = Z( NN-7 ) + SIGMA
Z( 4*N0-3 ) = Z( NN-3 ) + SIGMA
N0 = N0 - 2
GO TO 10
*
50 CONTINUE
*
* Reverse the qd-array, if warranted.
*
IF( DMIN.LE.ZERO .OR. N0.LT.N0IN ) THEN
OPS = OPS + DBLE( 1 )
IF( CBIAS*Z( 4*I0+PP-3 ).LT.Z( 4*N0+PP-3 ) ) THEN
IPN4 = 4*( I0+N0 )
DO 60 J4 = 4*I0, 2*( I0+N0-1 ), 4
TEMP = Z( J4-3 )
Z( J4-3 ) = Z( IPN4-J4-3 )
Z( IPN4-J4-3 ) = TEMP
TEMP = Z( J4-2 )
Z( J4-2 ) = Z( IPN4-J4-2 )
Z( IPN4-J4-2 ) = TEMP
TEMP = Z( J4-1 )
Z( J4-1 ) = Z( IPN4-J4-5 )
Z( IPN4-J4-5 ) = TEMP
TEMP = Z( J4 )
Z( J4 ) = Z( IPN4-J4-4 )
Z( IPN4-J4-4 ) = TEMP
60 CONTINUE
IF( N0-I0.LE.4 ) THEN
Z( 4*N0+PP-1 ) = Z( 4*I0+PP-1 )
Z( 4*N0-PP ) = Z( 4*I0-PP )
END IF
DMIN2 = MIN( DMIN2, Z( 4*N0+PP-1 ) )
Z( 4*N0+PP-1 ) = MIN( Z( 4*N0+PP-1 ), Z( 4*I0+PP-1 ),
$ Z( 4*I0+PP+3 ) )
Z( 4*N0-PP ) = MIN( Z( 4*N0-PP ), Z( 4*I0-PP ),
$ Z( 4*I0-PP+4 ) )
QMAX = MAX( QMAX, Z( 4*I0+PP-3 ), Z( 4*I0+PP+1 ) )
DMIN = -ZERO
END IF
END IF
*
70 CONTINUE
*
IF( DMIN.LT.ZERO .OR. SAFMIN*QMAX.LT.MIN( Z( 4*N0+PP-1 ),
$ Z( 4*N0+PP-9 ), DMIN2+Z( 4*N0-PP ) ) ) THEN
*
* Choose a shift.
*
CALL DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1,
$ DN2, TAU, TTYPE )
*
* Call dqds until DMIN > 0.
*
80 CONTINUE
*
CALL DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN,
$ DN1, DN2, IEEE )
*
NDIV = NDIV + ( N0-I0+2 )
ITER = ITER + 1
*
* Check status.
*
IF( DMIN.GE.ZERO .AND. DMIN1.GT.ZERO ) THEN
*
* Success.
*
GO TO 100
*
ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND.
$ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND.
$ ABS( DN ).LT.TOL*SIGMA ) THEN
*
* Convergence hidden by negative DN.
*
OPS = OPS + DBLE( 2 )
Z( 4*( N0-1 )-PP+2 ) = ZERO
DMIN = ZERO
GO TO 100
ELSE IF( DMIN.LT.ZERO ) THEN
*
* TAU too big. Select new TAU and try again.
*
NFAIL = NFAIL + 1
IF( TTYPE.LT.-22 ) THEN
*
* Failed twice. Play it safe.
*
TAU = ZERO
ELSE IF( DMIN1.GT.ZERO ) THEN
*
* Late failure. Gives excellent shift.
*
OPS = OPS + DBLE( 4 )
TAU = ( TAU+DMIN )*( ONE-TWO*EPS )
TTYPE = TTYPE - 11
ELSE
*
* Early failure. Divide by 4.
*
OPS = OPS + DBLE( 1 )
TAU = QURTR*TAU
TTYPE = TTYPE - 12
END IF
GO TO 80
ELSE IF( DMIN.NE.DMIN ) THEN
*
* NaN.
*
TAU = ZERO
GO TO 80
ELSE
*
* Possible underflow. Play it safe.
*
GO TO 90
END IF
END IF
*
* Risk of underflow.
*
90 CONTINUE
CALL DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 )
NDIV = NDIV + ( N0-I0+2 )
ITER = ITER + 1
TAU = ZERO
*
100 CONTINUE
OPS = OPS + DBLE( 4 )
IF( TAU.LT.SIGMA ) THEN
DESIG = DESIG + TAU
T = SIGMA + DESIG
DESIG = DESIG - ( T-SIGMA )
ELSE
T = SIGMA + TAU
DESIG = SIGMA - ( T-TAU ) + DESIG
END IF
SIGMA = T
*
RETURN
*
* End of DLASQ3
*
END
SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN,
$ DN1, DN2, TAU, TTYPE )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* May 17, 2000
*
* .. Scalar Arguments ..
INTEGER I0, N0, N0IN, PP, TTYPE
DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, TAU
* ..
* .. Array Arguments ..
DOUBLE PRECISION Z( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLASQ4 computes an approximation TAU to the smallest eigenvalue
* using values of d from the previous transform.
*
* I0 (input) INTEGER
* First index.
*
* N0 (input) INTEGER
* Last index.
*
* Z (input) DOUBLE PRECISION array, dimension ( 4*N )
* Z holds the qd array.
*
* PP (input) INTEGER
* PP=0 for ping, PP=1 for pong.
*
* NOIN (input) INTEGER
* The value of N0 at start of EIGTEST.
*
* DMIN (input) DOUBLE PRECISION
* Minimum value of d.
*
* DMIN1 (input) DOUBLE PRECISION
* Minimum value of d, excluding D( N0 ).
*
* DMIN2 (input) DOUBLE PRECISION
* Minimum value of d, excluding D( N0 ) and D( N0-1 ).
*
* DN (input) DOUBLE PRECISION
* d(N)
*
* DN1 (input) DOUBLE PRECISION
* d(N-1)
*
* DN2 (input) DOUBLE PRECISION
* d(N-2)
*
* TAU (output) DOUBLE PRECISION
* This is the shift.
*
* TTYPE (output) INTEGER
* Shift type.
*
* Further Details
* ===============
* CNST1 = 9/16
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION CNST1, CNST2, CNST3
PARAMETER ( CNST1 = 0.5630D0, CNST2 = 1.010D0,
$ CNST3 = 1.050D0 )
DOUBLE PRECISION QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD
PARAMETER ( QURTR = 0.250D0, THIRD = 0.3330D0,
$ HALF = 0.50D0, ZERO = 0.0D0, ONE = 1.0D0,
$ TWO = 2.0D0, HUNDRD = 100.0D0 )
* ..
* .. Local Scalars ..
INTEGER I4, NN, NP
DOUBLE PRECISION A2, B1, B2, G, GAM, GAP1, GAP2, S
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN, SQRT
* ..
* .. Save statement ..
SAVE G
* ..
* .. Data statement ..
DATA G / ZERO /
* ..
* .. Executable Statements ..
*
* A negative DMIN forces the shift to take that absolute value
* TTYPE records the type of shift.
*
IF( DMIN.LE.ZERO ) THEN
TAU = -DMIN
TTYPE = -1
RETURN
END IF
*
NN = 4*N0 + PP
IF( N0IN.EQ.N0 ) THEN
*
* No eigenvalues deflated.
*
IF( DMIN.EQ.DN .OR. DMIN.EQ.DN1 ) THEN
*
OPS = OPS + DBLE( 7 )
B1 = SQRT( Z( NN-3 ) )*SQRT( Z( NN-5 ) )
B2 = SQRT( Z( NN-7 ) )*SQRT( Z( NN-9 ) )
A2 = Z( NN-7 ) + Z( NN-5 )
*
* Cases 2 and 3.
*
IF( DMIN.EQ.DN .AND. DMIN1.EQ.DN1 ) THEN
OPS = OPS + DBLE( 3 )
GAP2 = DMIN2 - A2 - DMIN2*QURTR
IF( GAP2.GT.ZERO .AND. GAP2.GT.B2 ) THEN
OPS = OPS + DBLE( 4 )
GAP1 = A2 - DN - ( B2 / GAP2 )*B2
ELSE
OPS = OPS + DBLE( 3 )
GAP1 = A2 - DN - ( B1+B2 )
END IF
IF( GAP1.GT.ZERO .AND. GAP1.GT.B1 ) THEN
OPS = OPS + DBLE( 4 )
S = MAX( DN-( B1 / GAP1 )*B1, HALF*DMIN )
TTYPE = -2
ELSE
OPS = OPS + DBLE( 2 )
S = ZERO
IF( DN.GT.B1 )
$ S = DN - B1
IF( A2.GT.( B1+B2 ) )
$ S = MIN( S, A2-( B1+B2 ) )
S = MAX( S, THIRD*DMIN )
TTYPE = -3
END IF
ELSE
*
* Case 4.
*
TTYPE = -4
OPS = OPS + DBLE( 1 )
S = QURTR*DMIN
IF( DMIN.EQ.DN ) THEN
OPS = OPS + DBLE( 1 )
GAM = DN
A2 = ZERO
IF( Z( NN-5 ) .GT. Z( NN-7 ) )
$ RETURN
B2 = Z( NN-5 ) / Z( NN-7 )
NP = NN - 9
ELSE
OPS = OPS + DBLE( 2 )
NP = NN - 2*PP
B2 = Z( NP-2 )
GAM = DN1
IF( Z( NP-4 ) .GT. Z( NP-2 ) )
$ RETURN
A2 = Z( NP-4 ) / Z( NP-2 )
IF( Z( NN-9 ) .GT. Z( NN-11 ) )
$ RETURN
B2 = Z( NN-9 ) / Z( NN-11 )
NP = NN - 13
END IF
*
* Approximate contribution to norm squared from I < NN-1.
*
A2 = A2 + B2
DO 10 I4 = NP, 4*I0 - 1 + PP, -4
OPS = OPS + DBLE( 5 )
IF( B2.EQ.ZERO )
$ GO TO 20
B1 = B2
IF( Z( I4 ) .GT. Z( I4-2 ) )
$ RETURN
B2 = B2*( Z( I4 ) / Z( I4-2 ) )
A2 = A2 + B2
IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 )
$ GO TO 20
10 CONTINUE
20 CONTINUE
OPS = OPS + DBLE( 1 )
A2 = CNST3*A2
*
* Rayleigh quotient residual bound.
*
OPS = OPS + DBLE( 5 )
IF( A2.LT.CNST1 )
$ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 )
END IF
ELSE IF( DMIN.EQ.DN2 ) THEN
*
* Case 5.
*
TTYPE = -5
OPS = OPS + DBLE( 1 )
S = QURTR*DMIN
*
* Compute contribution to norm squared from I > NN-2.
*
OPS = OPS + DBLE( 4 )
NP = NN - 2*PP
B1 = Z( NP-2 )
B2 = Z( NP-6 )
GAM = DN2
IF( Z( NP-8 ).GT.B2 .OR. Z( NP-4 ).GT.B1 )
$ RETURN
A2 = ( Z( NP-8 ) / B2 )*( ONE+Z( NP-4 ) / B1 )
*
* Approximate contribution to norm squared from I < NN-2.
*
IF( N0-I0.GT.2 ) THEN
OPS = OPS + DBLE( 3 )
B2 = Z( NN-13 ) / Z( NN-15 )
A2 = A2 + B2
DO 30 I4 = NN - 17, 4*I0 - 1 + PP, -4
OPS = OPS + DBLE( 5 )
IF( B2.EQ.ZERO )
$ GO TO 40
B1 = B2
IF( Z( I4 ) .GT. Z( I4-2 ) )
$ RETURN
B2 = B2*( Z( I4 ) / Z( I4-2 ) )
A2 = A2 + B2
IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 )
$ GO TO 40
30 CONTINUE
40 CONTINUE
A2 = CNST3*A2
END IF
*
OPS = OPS + DBLE( 5 )
IF( A2.LT.CNST1 )
$ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 )
ELSE
*
* Case 6, no information to guide us.
*
IF( TTYPE.EQ.-6 ) THEN
OPS = OPS + DBLE( 3 )
G = G + THIRD*( ONE-G )
ELSE IF( TTYPE.EQ.-18 ) THEN
OPS = OPS + DBLE( 1 )
G = QURTR*THIRD
ELSE
G = QURTR
END IF
OPS = OPS + DBLE( 1 )
S = G*DMIN
TTYPE = -6
END IF
*
ELSE IF( N0IN.EQ.( N0+1 ) ) THEN
*
* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN.
*
IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN
*
* Cases 7 and 8.
*
TTYPE = -7
OPS = OPS + DBLE( 2 )
S = THIRD*DMIN1
IF( Z( NN-5 ).GT.Z( NN-7 ) )
$ RETURN
B1 = Z( NN-5 ) / Z( NN-7 )
B2 = B1
IF( B2.EQ.ZERO )
$ GO TO 60
DO 50 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4
OPS = OPS + DBLE( 4 )
A2 = B1
IF( Z( I4 ).GT.Z( I4-2 ) )
$ RETURN
B1 = B1*( Z( I4 ) / Z( I4-2 ) )
B2 = B2 + B1
IF( HUNDRD*MAX( B1, A2 ).LT.B2 )
$ GO TO 60
50 CONTINUE
60 CONTINUE
OPS = OPS + DBLE( 8 )
B2 = SQRT( CNST3*B2 )
A2 = DMIN1 / ( ONE+B2**2 )
GAP2 = HALF*DMIN2 - A2
IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN
OPS = OPS + DBLE( 7 )
S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) )
ELSE
OPS = OPS + DBLE( 4 )
S = MAX( S, A2*( ONE-CNST2*B2 ) )
TTYPE = -8
END IF
ELSE
*
* Case 9.
*
OPS = OPS + DBLE( 2 )
S = QURTR*DMIN1
IF( DMIN1.EQ.DN1 )
$ S = HALF*DMIN1
TTYPE = -9
END IF
*
ELSE IF( N0IN.EQ.( N0+2 ) ) THEN
*
* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN.
*
* Cases 10 and 11.
*
OPS = OPS + DBLE( 1 )
IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN
TTYPE = -10
OPS = OPS + DBLE( 1 )
S = THIRD*DMIN2
IF( Z( NN-5 ).GT.Z( NN-7 ) )
$ RETURN
B1 = Z( NN-5 ) / Z( NN-7 )
B2 = B1
IF( B2.EQ.ZERO )
$ GO TO 80
DO 70 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4
OPS = OPS + DBLE( 4 )
IF( Z( I4 ).GT.Z( I4-2 ) )
$ RETURN
B1 = B1*( Z( I4 ) / Z( I4-2 ) )
B2 = B2 + B1
IF( HUNDRD*B1.LT.B2 )
$ GO TO 80
70 CONTINUE
80 CONTINUE
OPS = OPS + DBLE( 12 )
B2 = SQRT( CNST3*B2 )
A2 = DMIN2 / ( ONE+B2**2 )
GAP2 = Z( NN-7 ) + Z( NN-9 ) -
$ SQRT( Z( NN-11 ) )*SQRT( Z( NN-9 ) ) - A2
IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN
OPS = OPS + DBLE( 7 )
S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) )
ELSE
OPS = OPS + DBLE( 4 )
S = MAX( S, A2*( ONE-CNST2*B2 ) )
END IF
ELSE
OPS = OPS + DBLE( 1 )
S = QURTR*DMIN2
TTYPE = -11
END IF
ELSE IF( N0IN.GT.( N0+2 ) ) THEN
*
* Case 12, more than two eigenvalues deflated. No information.
*
S = ZERO
TTYPE = -12
END IF
*
TAU = S
RETURN
*
* End of DLASQ4
*
END
SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN,
$ DNM1, DNM2, IEEE )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* May 17, 2000
*
* .. Scalar Arguments ..
LOGICAL IEEE
INTEGER I0, N0, PP
DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU
* ..
* .. Array Arguments ..
DOUBLE PRECISION Z( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLASQ5 computes one dqds transform in ping-pong form, one
* version for IEEE machines another for non IEEE machines.
*
* Arguments
* =========
*
* I0 (input) INTEGER
* First index.
*
* N0 (input) INTEGER
* Last index.
*
* Z (input) DOUBLE PRECISION array, dimension ( 4*N )
* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid
* an extra argument.
*
* PP (input) INTEGER
* PP=0 for ping, PP=1 for pong.
*
* TAU (input) DOUBLE PRECISION
* This is the shift.
*
* DMIN (output) DOUBLE PRECISION
* Minimum value of d.
*
* DMIN1 (output) DOUBLE PRECISION
* Minimum value of d, excluding D( N0 ).
*
* DMIN2 (output) DOUBLE PRECISION
* Minimum value of d, excluding D( N0 ) and D( N0-1 ).
*
* DN (output) DOUBLE PRECISION
* d(N0), the last value of d.
*
* DNM1 (output) DOUBLE PRECISION
* d(N0-1).
*
* DNM2 (output) DOUBLE PRECISION
* d(N0-2).
*
* IEEE (input) LOGICAL
* Flag for IEEE or non IEEE arithmetic.
*
* =====================================================================
*
* .. Parameter ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER J4, J4P2
DOUBLE PRECISION D, EMIN, TEMP
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MIN
* ..
* .. Executable Statements ..
*
IF( ( N0-I0-1 ).LE.0 )
$ RETURN
*
OPS = OPS + DBLE( 1 )
J4 = 4*I0 + PP - 3
EMIN = Z( J4+4 )
D = Z( J4 ) - TAU
DMIN = D
DMIN1 = -Z( J4 )
*
IF( IEEE ) THEN
*
* Code for IEEE arithmetic.
*
IF( PP.EQ.0 ) THEN
DO 10 J4 = 4*I0, 4*( N0-3 ), 4
OPS = OPS + DBLE( 5 )
Z( J4-2 ) = D + Z( J4-1 )
TEMP = Z( J4+1 ) / Z( J4-2 )
D = D*TEMP - TAU
DMIN = MIN( DMIN, D )
Z( J4 ) = Z( J4-1 )*TEMP
EMIN = MIN( Z( J4 ), EMIN )
10 CONTINUE
ELSE
DO 20 J4 = 4*I0, 4*( N0-3 ), 4
OPS = OPS + DBLE( 5 )
Z( J4-3 ) = D + Z( J4 )
TEMP = Z( J4+2 ) / Z( J4-3 )
D = D*TEMP - TAU
DMIN = MIN( DMIN, D )
Z( J4-1 ) = Z( J4 )*TEMP
EMIN = MIN( Z( J4-1 ), EMIN )
20 CONTINUE
END IF
*
* Unroll last two steps.
*
OPS = OPS + DBLE( 6 )
DNM2 = D
DMIN2 = DMIN
J4 = 4*( N0-2 ) - PP
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM2 + Z( J4P2 )
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU
DMIN = MIN( DMIN, DNM1 )
*
OPS = OPS + DBLE( 6 )
DMIN1 = DMIN
J4 = J4 + 4
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM1 + Z( J4P2 )
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU
DMIN = MIN( DMIN, DN )
*
ELSE
*
* Code for non IEEE arithmetic.
*
IF( PP.EQ.0 ) THEN
DO 30 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-2 ) = D + Z( J4-1 )
IF( D.LT.ZERO ) THEN
RETURN
ELSE
OPS = OPS + DBLE( 5 )
Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) )
D = Z( J4+1 )*( D / Z( J4-2 ) ) - TAU
END IF
DMIN = MIN( DMIN, D )
EMIN = MIN( EMIN, Z( J4 ) )
30 CONTINUE
ELSE
DO 40 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-3 ) = D + Z( J4 )
IF( D.LT.ZERO ) THEN
RETURN
ELSE
OPS = OPS + DBLE( 5 )
Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) )
D = Z( J4+2 )*( D / Z( J4-3 ) ) - TAU
END IF
DMIN = MIN( DMIN, D )
EMIN = MIN( EMIN, Z( J4-1 ) )
40 CONTINUE
END IF
*
* Unroll last two steps.
*
OPS = OPS + DBLE( 1 )
DNM2 = D
DMIN2 = DMIN
J4 = 4*( N0-2 ) - PP
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM2 + Z( J4P2 )
IF( DNM2.LT.ZERO ) THEN
RETURN
ELSE
OPS = OPS + DBLE( 5 )
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU
END IF
DMIN = MIN( DMIN, DNM1 )
*
OPS = OPS + DBLE( 1 )
DMIN1 = DMIN
J4 = J4 + 4
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM1 + Z( J4P2 )
IF( DNM1.LT.ZERO ) THEN
RETURN
ELSE
OPS = OPS + DBLE( 5 )
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU
END IF
DMIN = MIN( DMIN, DN )
*
END IF
*
Z( J4+2 ) = DN
Z( 4*N0-PP ) = EMIN
RETURN
*
* End of DLASQ5
*
END
SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN,
$ DNM1, DNM2 )
*
* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
INTEGER I0, N0, PP
DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2
* ..
* .. Array Arguments ..
DOUBLE PRECISION Z( * )
* ..
* .. Common block to return operation count ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DLASQ6 computes one dqd (shift equal to zero) transform in
* ping-pong form, with protection against underflow and overflow.
*
* Arguments
* =========
*
* I0 (input) INTEGER
* First index.
*
* N0 (input) INTEGER
* Last index.
*
* Z (input) DOUBLE PRECISION array, dimension ( 4*N )
* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid
* an extra argument.
*
* PP (input) INTEGER
* PP=0 for ping, PP=1 for pong.
*
* DMIN (output) DOUBLE PRECISION
* Minimum value of d.
*
* DMIN1 (output) DOUBLE PRECISION
* Minimum value of d, excluding D( N0 ).
*
* DMIN2 (output) DOUBLE PRECISION
* Minimum value of d, excluding D( N0 ) and D( N0-1 ).
*
* DN (output) DOUBLE PRECISION
* d(N0), the last value of d.
*
* DNM1 (output) DOUBLE PRECISION
* d(N0-1).
*
* DNM2 (output) DOUBLE PRECISION
* d(N0-2).
*
* =====================================================================
*
* .. Parameter ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER J4, J4P2
DOUBLE PRECISION D, EMIN, SAFMIN, TEMP
* ..
* .. External Function ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MIN
* ..
* .. Executable Statements ..
*
IF( ( N0-I0-1 ).LE.0 )
$ RETURN
*
SAFMIN = DLAMCH( 'Safe minimum' )
J4 = 4*I0 + PP - 3
EMIN = Z( J4+4 )
D = Z( J4 )
DMIN = D
*
IF( PP.EQ.0 ) THEN
DO 10 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-2 ) = D + Z( J4-1 )
IF( Z( J4-2 ).EQ.ZERO ) THEN
Z( J4 ) = ZERO
D = Z( J4+1 )
DMIN = D
EMIN = ZERO
ELSE IF( SAFMIN*Z( J4+1 ).LT.Z( J4-2 ) .AND.
$ SAFMIN*Z( J4-2 ).LT.Z( J4+1 ) ) THEN
OPS = OPS + DBLE( 2 )
TEMP = Z( J4+1 ) / Z( J4-2 )
Z( J4 ) = Z( J4-1 )*TEMP
D = D*TEMP
ELSE
OPS = OPS + DBLE( 4 )
Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) )
D = Z( J4+1 )*( D / Z( J4-2 ) )
END IF
DMIN = MIN( DMIN, D )
EMIN = MIN( EMIN, Z( J4 ) )
10 CONTINUE
ELSE
DO 20 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-3 ) = D + Z( J4 )
IF( Z( J4-3 ).EQ.ZERO ) THEN
Z( J4-1 ) = ZERO
D = Z( J4+2 )
DMIN = D
EMIN = ZERO
ELSE IF( SAFMIN*Z( J4+2 ).LT.Z( J4-3 ) .AND.
$ SAFMIN*Z( J4-3 ).LT.Z( J4+2 ) ) THEN
OPS = OPS + DBLE( 2 )
TEMP = Z( J4+2 ) / Z( J4-3 )
Z( J4-1 ) = Z( J4 )*TEMP
D = D*TEMP
ELSE
OPS = OPS + DBLE( 4 )
Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) )
D = Z( J4+2 )*( D / Z( J4-3 ) )
END IF
DMIN = MIN( DMIN, D )
EMIN = MIN( EMIN, Z( J4-1 ) )
20 CONTINUE
END IF
*
* Unroll last two steps.
*
OPS = OPS + DBLE( 1 )
DNM2 = D
DMIN2 = DMIN
J4 = 4*( N0-2 ) - PP
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM2 + Z( J4P2 )
IF( Z( J4-2 ).EQ.ZERO ) THEN
Z( J4 ) = ZERO
DNM1 = Z( J4P2+2 )
DMIN = DNM1
EMIN = ZERO
ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND.
$ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN
OPS = OPS + DBLE( 3 )
TEMP = Z( J4P2+2 ) / Z( J4-2 )
Z( J4 ) = Z( J4P2 )*TEMP
DNM1 = DNM2*TEMP
ELSE
OPS = OPS + DBLE( 4 )
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) )
END IF
DMIN = MIN( DMIN, DNM1 )
*
OPS = OPS + DBLE( 1 )
DMIN1 = DMIN
J4 = J4 + 4
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM1 + Z( J4P2 )
IF( Z( J4-2 ).EQ.ZERO ) THEN
Z( J4 ) = ZERO
DN = Z( J4P2+2 )
DMIN = DN
EMIN = ZERO
ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND.
$ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN
OPS = OPS + DBLE( 3 )
TEMP = Z( J4P2+2 ) / Z( J4-2 )
Z( J4 ) = Z( J4P2 )*TEMP
DN = DNM1*TEMP
ELSE
OPS = OPS + DBLE( 4 )
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) )
END IF
DMIN = MIN( DMIN, DN )
*
Z( J4+2 ) = DN
Z( 4*N0-PP ) = EMIN
RETURN
*
* End of DLASQ6
*
END
SUBROUTINE DPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1999
*
* .. Scalar Arguments ..
CHARACTER COMPZ
INTEGER INFO, LDZ, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * )
* ..
* Common block to return operation count and iteration count
* ITCNT is initialized to 0, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DPTEQR computes all eigenvalues and, optionally, eigenvectors of a
* symmetric positive definite tridiagonal matrix by first factoring the
* matrix using DPTTRF, and then calling DBDSQR to compute the singular
* values of the bidiagonal factor.
*
* This routine computes the eigenvalues of the positive definite
* tridiagonal matrix to high relative accuracy. This means that if the
* eigenvalues range over many orders of magnitude in size, then the
* small eigenvalues and corresponding eigenvectors will be computed
* more accurately than, for example, with the standard QR method.
*
* The eigenvectors of a full or band symmetric positive definite matrix
* can also be found if DSYTRD, DSPTRD, or DSBTRD has been used to
* reduce this matrix to tridiagonal form. (The reduction to tridiagonal
* form, however, may preclude the possibility of obtaining high
* relative accuracy in the small eigenvalues of the original matrix, if
* these eigenvalues range over many orders of magnitude.)
*
* Arguments
* =========
*
* COMPZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only.
* = 'V': Compute eigenvectors of original symmetric
* matrix also. Array Z contains the orthogonal
* matrix used to reduce the original matrix to
* tridiagonal form.
* = 'I': Compute eigenvectors of tridiagonal matrix also.
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the n diagonal elements of the tridiagonal
* matrix.
* On normal exit, D contains the eigenvalues, in descending
* order.
*
* E (input/output) DOUBLE PRECISION array, dimension (N-1)
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix.
* On exit, E has been destroyed.
*
* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
* On entry, if COMPZ = 'V', the orthogonal matrix used in the
* reduction to tridiagonal form.
* On exit, if COMPZ = 'V', the orthonormal eigenvectors of the
* original symmetric matrix;
* if COMPZ = 'I', the orthonormal eigenvectors of the
* tridiagonal matrix.
* If INFO > 0 on exit, Z contains the eigenvectors associated
* with only the stored eigenvalues.
* If COMPZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* COMPZ = 'V' or 'I', LDZ >= max(1,N).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = i, and i is:
* <= N the Cholesky factorization of the matrix could
* not be performed because the i-th principal minor
* was not positive definite.
* > N the SVD algorithm failed to converge;
* if INFO = N+i, i off-diagonal elements of the
* bidiagonal factor did not converge to zero.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DBDSQR, DLASET, DPTTRF, XERBLA
* ..
* .. Local Arrays ..
DOUBLE PRECISION C( 1, 1 ), VT( 1, 1 )
* ..
* .. Local Scalars ..
INTEGER I, ICOMPZ, NRU
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( LSAME( COMPZ, 'N' ) ) THEN
ICOMPZ = 0
ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
ICOMPZ = 1
ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
ICOMPZ = 2
ELSE
ICOMPZ = -1
END IF
IF( ICOMPZ.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
$ N ) ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPTEQR', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( ICOMPZ.GT.0 )
$ Z( 1, 1 ) = ONE
RETURN
END IF
IF( ICOMPZ.EQ.2 )
$ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
*
* Call DPTTRF to factor the matrix.
*
OPS = OPS + 5*N - 4
CALL DPTTRF( N, D, E, INFO )
IF( INFO.NE.0 )
$ RETURN
DO 10 I = 1, N
D( I ) = SQRT( D( I ) )
10 CONTINUE
DO 20 I = 1, N - 1
E( I ) = E( I )*D( I )
20 CONTINUE
*
* Call DBDSQR to compute the singular values/vectors of the
* bidiagonal factor.
*
IF( ICOMPZ.GT.0 ) THEN
NRU = N
ELSE
NRU = 0
END IF
CALL DBDSQR( 'Lower', N, 0, NRU, 0, D, E, VT, 1, Z, LDZ, C, 1,
$ WORK, INFO )
*
* Square the singular values.
*
IF( INFO.EQ.0 ) THEN
OPS = OPS + N
DO 30 I = 1, N
D( I ) = D( I )*D( I )
30 CONTINUE
ELSE
INFO = N + INFO
END IF
*
RETURN
*
* End of DPTEQR
*
END
SUBROUTINE DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E,
$ M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK,
$ INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER ORDER, RANGE
INTEGER IL, INFO, IU, M, N, NSPLIT
DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * )
DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * )
* ..
* Common block to return operation count and iteration count
* ITCNT is initialized to 0, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DSTEBZ computes the eigenvalues of a symmetric tridiagonal
* matrix T. The user may ask for all eigenvalues, all eigenvalues
* in the half-open interval (VL, VU], or the IL-th through IU-th
* eigenvalues.
*
* To avoid overflow, the matrix must be scaled so that its
* largest element is no greater than overflow**(1/2) *
* underflow**(1/4) in absolute value, and for greatest
* accuracy, it should not be much smaller than that.
*
* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
* Matrix", Report CS41, Computer Science Dept., Stanford
* University, July 21, 1966.
*
* Arguments
* =========
*
* RANGE (input) CHARACTER
* = 'A': ("All") all eigenvalues will be found.
* = 'V': ("Value") all eigenvalues in the half-open interval
* (VL, VU] will be found.
* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
* entire matrix) will be found.
*
* ORDER (input) CHARACTER
* = 'B': ("By Block") the eigenvalues will be grouped by
* split-off block (see IBLOCK, ISPLIT) and
* ordered from smallest to largest within
* the block.
* = 'E': ("Entire matrix")
* the eigenvalues for the entire matrix
* will be ordered from smallest to
* largest.
*
* N (input) INTEGER
* The order of the tridiagonal matrix T. N >= 0.
*
* VL (input) DOUBLE PRECISION
* VU (input) DOUBLE PRECISION
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. Eigenvalues less than or equal
* to VL, or greater than VU, will not be returned. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* ABSTOL (input) DOUBLE PRECISION
* The absolute tolerance for the eigenvalues. An eigenvalue
* (or cluster) is considered to be located if it has been
* determined to lie in an interval whose width is ABSTOL or
* less. If ABSTOL is less than or equal to zero, then ULP*|T|
* will be used, where |T| means the 1-norm of T.
*
* Eigenvalues will be computed most accurately when ABSTOL is
* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the tridiagonal matrix T.
*
* E (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) off-diagonal elements of the tridiagonal matrix T.
*
* M (output) INTEGER
* The actual number of eigenvalues found. 0 <= M <= N.
* (See also the description of INFO=2,3.)
*
* NSPLIT (output) INTEGER
* The number of diagonal blocks in the matrix T.
* 1 <= NSPLIT <= N.
*
* W (output) DOUBLE PRECISION array, dimension (N)
* On exit, the first M elements of W will contain the
* eigenvalues. (DSTEBZ may use the remaining N-M elements as
* workspace.)
*
* IBLOCK (output) INTEGER array, dimension (N)
* At each row/column j where E(j) is zero or small, the
* matrix T is considered to split into a block diagonal
* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which
* block (from 1 to the number of blocks) the eigenvalue W(i)
* belongs. (DSTEBZ may use the remaining N-M elements as
* workspace.)
*
* ISPLIT (output) INTEGER array, dimension (N)
* The splitting points, at which T breaks up into submatrices.
* The first submatrix consists of rows/columns 1 to ISPLIT(1),
* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
* etc., and the NSPLIT-th consists of rows/columns
* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
* (Only the first NSPLIT elements will actually be used, but
* since the user cannot know a priori what value NSPLIT will
* have, N words must be reserved for ISPLIT.)
*
* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
*
* IWORK (workspace) INTEGER array, dimension (3*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: some or all of the eigenvalues failed to converge or
* were not computed:
* =1 or 3: Bisection failed to converge for some
* eigenvalues; these eigenvalues are flagged by a
* negative block number. The effect is that the
* eigenvalues may not be as accurate as the
* absolute and relative tolerances. This is
* generally caused by unexpectedly inaccurate
* arithmetic.
* =2 or 3: RANGE='I' only: Not all of the eigenvalues
* IL:IU were found.
* Effect: M < IU+1-IL
* Cause: non-monotonic arithmetic, causing the
* Sturm sequence to be non-monotonic.
* Cure: recalculate, using RANGE='A', and pick
* out eigenvalues IL:IU. In some cases,
* increasing the PARAMETER "FUDGE" may
* make things work.
* = 4: RANGE='I', and the Gershgorin interval
* initially used was too small. No eigenvalues
* were computed.
* Probable cause: your machine has sloppy
* floating-point arithmetic.
* Cure: Increase the PARAMETER "FUDGE",
* recompile, and try again.
*
* Internal Parameters
* ===================
*
* RELFAC DOUBLE PRECISION, default = 2.0e0
* The relative tolerance. An interval (a,b] lies within
* "relative tolerance" if b-a < RELFAC*ulp*max(|a|,|b|),
* where "ulp" is the machine precision (distance from 1 to
* the next larger floating point number.)
*
* FUDGE DOUBLE PRECISION, default = 2
* A "fudge factor" to widen the Gershgorin intervals. Ideally,
* a value of 1 should work, but on machines with sloppy
* arithmetic, this needs to be larger. The default for
* publicly released versions should be large enough to handle
* the worst machine around. Note that this has no effect
* on accuracy of the solution.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, HALF
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ HALF = 1.0D0 / TWO )
DOUBLE PRECISION FUDGE, RELFAC
PARAMETER ( FUDGE = 2.0D0, RELFAC = 2.0D0 )
* ..
* .. Local Scalars ..
LOGICAL NCNVRG, TOOFEW
INTEGER IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO,
$ IM, IN, IOFF, IORDER, IOUT, IRANGE, ITMAX,
$ ITMP1, IW, IWOFF, J, JB, JDISC, JE, NB, NWL,
$ NWU
DOUBLE PRECISION ATOLI, BNORM, GL, GU, PIVMIN, RTOLI, SAFEMN,
$ TMP1, TMP2, TNORM, ULP, WKILL, WL, WLU, WU, WUL
* ..
* .. Local Arrays ..
INTEGER IDUMMA( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, ILAENV, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DLAEBZ, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Decode RANGE
*
IF( LSAME( RANGE, 'A' ) ) THEN
IRANGE = 1
ELSE IF( LSAME( RANGE, 'V' ) ) THEN
IRANGE = 2
ELSE IF( LSAME( RANGE, 'I' ) ) THEN
IRANGE = 3
ELSE
IRANGE = 0
END IF
*
* Decode ORDER
*
IF( LSAME( ORDER, 'B' ) ) THEN
IORDER = 2
ELSE IF( LSAME( ORDER, 'E' ) ) THEN
IORDER = 1
ELSE
IORDER = 0
END IF
*
* Check for Errors
*
IF( IRANGE.LE.0 ) THEN
INFO = -1
ELSE IF( IORDER.LE.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( IRANGE.EQ.2 ) THEN
IF( VL.GE.VU )
$ INFO = -5
ELSE IF( IRANGE.EQ.3 .AND. ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) )
$ THEN
INFO = -6
ELSE IF( IRANGE.EQ.3 .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) )
$ THEN
INFO = -7
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSTEBZ', -INFO )
RETURN
END IF
*
* Initialize error flags
*
INFO = 0
NCNVRG = .FALSE.
TOOFEW = .FALSE.
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 )
$ RETURN
*
* Simplifications:
*
IF( IRANGE.EQ.3 .AND. IL.EQ.1 .AND. IU.EQ.N )
$ IRANGE = 1
*
* Get machine constants
* NB is the minimum vector length for vector bisection, or 0
* if only scalar is to be done.
*
SAFEMN = DLAMCH( 'S' )
ULP = DLAMCH( 'P' )
OPS = OPS + 1
RTOLI = ULP*RELFAC
NB = ILAENV( 1, 'DSTEBZ', ' ', N, -1, -1, -1 )
IF( NB.LE.1 )
$ NB = 0
*
* Special Case when N=1
*
IF( N.EQ.1 ) THEN
NSPLIT = 1
ISPLIT( 1 ) = 1
IF( IRANGE.EQ.2 .AND. ( VL.GE.D( 1 ) .OR. VU.LT.D( 1 ) ) ) THEN
M = 0
ELSE
W( 1 ) = D( 1 )
IBLOCK( 1 ) = 1
M = 1
END IF
RETURN
END IF
*
* Compute Splitting Points
*
NSPLIT = 1
WORK( N ) = ZERO
PIVMIN = ONE
*
OPS = OPS + ( N-1 )*5 + 1
*DIR$ NOVECTOR
DO 10 J = 2, N
TMP1 = E( J-1 )**2
IF( ABS( D( J )*D( J-1 ) )*ULP**2+SAFEMN.GT.TMP1 ) THEN
ISPLIT( NSPLIT ) = J - 1
NSPLIT = NSPLIT + 1
WORK( J-1 ) = ZERO
ELSE
WORK( J-1 ) = TMP1
PIVMIN = MAX( PIVMIN, TMP1 )
END IF
10 CONTINUE
ISPLIT( NSPLIT ) = N
PIVMIN = PIVMIN*SAFEMN
*
* Compute Interval and ATOLI
*
IF( IRANGE.EQ.3 ) THEN
*
* RANGE='I': Compute the interval containing eigenvalues
* IL through IU.
*
* Compute Gershgorin interval for entire (split) matrix
* and use it as the initial interval
*
GU = D( 1 )
GL = D( 1 )
TMP1 = ZERO
*
OPS = OPS + 5*( N-1 ) + 23
DO 20 J = 1, N - 1
TMP2 = SQRT( WORK( J ) )
GU = MAX( GU, D( J )+TMP1+TMP2 )
GL = MIN( GL, D( J )-TMP1-TMP2 )
TMP1 = TMP2
20 CONTINUE
*
GU = MAX( GU, D( N )+TMP1 )
GL = MIN( GL, D( N )-TMP1 )
TNORM = MAX( ABS( GL ), ABS( GU ) )
GL = GL - FUDGE*TNORM*ULP*N - FUDGE*TWO*PIVMIN
GU = GU + FUDGE*TNORM*ULP*N + FUDGE*PIVMIN
*
* Compute Iteration parameters
*
ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) /
$ LOG( TWO ) ) + 2
IF( ABSTOL.LE.ZERO ) THEN
ATOLI = ULP*TNORM
ELSE
ATOLI = ABSTOL
END IF
*
WORK( N+1 ) = GL
WORK( N+2 ) = GL
WORK( N+3 ) = GU
WORK( N+4 ) = GU
WORK( N+5 ) = GL
WORK( N+6 ) = GU
IWORK( 1 ) = -1
IWORK( 2 ) = -1
IWORK( 3 ) = N + 1
IWORK( 4 ) = N + 1
IWORK( 5 ) = IL - 1
IWORK( 6 ) = IU
*
CALL DLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN, D, E,
$ WORK, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT,
$ IWORK, W, IBLOCK, IINFO )
*
IF( IWORK( 6 ).EQ.IU ) THEN
WL = WORK( N+1 )
WLU = WORK( N+3 )
NWL = IWORK( 1 )
WU = WORK( N+4 )
WUL = WORK( N+2 )
NWU = IWORK( 4 )
ELSE
WL = WORK( N+2 )
WLU = WORK( N+4 )
NWL = IWORK( 2 )
WU = WORK( N+3 )
WUL = WORK( N+1 )
NWU = IWORK( 3 )
END IF
*
IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN
INFO = 4
RETURN
END IF
ELSE
*
* RANGE='A' or 'V' -- Set ATOLI
*
OPS = OPS + 3 + 2*( N-2 )
TNORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ),
$ ABS( D( N ) )+ABS( E( N-1 ) ) )
*
DO 30 J = 2, N - 1
TNORM = MAX( TNORM, ABS( D( J ) )+ABS( E( J-1 ) )+
$ ABS( E( J ) ) )
30 CONTINUE
*
IF( ABSTOL.LE.ZERO ) THEN
ATOLI = ULP*TNORM
ELSE
ATOLI = ABSTOL
END IF
*
IF( IRANGE.EQ.2 ) THEN
WL = VL
WU = VU
ELSE
WL = ZERO
WU = ZERO
END IF
END IF
*
* Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU.
* NWL accumulates the number of eigenvalues .le. WL,
* NWU accumulates the number of eigenvalues .le. WU
*
M = 0
IEND = 0
INFO = 0
NWL = 0
NWU = 0
*
DO 70 JB = 1, NSPLIT
IOFF = IEND
IBEGIN = IOFF + 1
IEND = ISPLIT( JB )
IN = IEND - IOFF
*
IF( IN.EQ.1 ) THEN
*
* Special Case -- IN=1
*
OPS = OPS + 4
IF( IRANGE.EQ.1 .OR. WL.GE.D( IBEGIN )-PIVMIN )
$ NWL = NWL + 1
IF( IRANGE.EQ.1 .OR. WU.GE.D( IBEGIN )-PIVMIN )
$ NWU = NWU + 1
IF( IRANGE.EQ.1 .OR. ( WL.LT.D( IBEGIN )-PIVMIN .AND. WU.GE.
$ D( IBEGIN )-PIVMIN ) ) THEN
M = M + 1
W( M ) = D( IBEGIN )
IBLOCK( M ) = JB
END IF
ELSE
*
* General Case -- IN > 1
*
* Compute Gershgorin Interval
* and use it as the initial interval
*
GU = D( IBEGIN )
GL = D( IBEGIN )
TMP1 = ZERO
*
OPS = OPS + 4*( IEND-IBEGIN ) + 13
DO 40 J = IBEGIN, IEND - 1
TMP2 = ABS( E( J ) )
GU = MAX( GU, D( J )+TMP1+TMP2 )
GL = MIN( GL, D( J )-TMP1-TMP2 )
TMP1 = TMP2
40 CONTINUE
*
GU = MAX( GU, D( IEND )+TMP1 )
GL = MIN( GL, D( IEND )-TMP1 )
BNORM = MAX( ABS( GL ), ABS( GU ) )
GL = GL - FUDGE*BNORM*ULP*IN - FUDGE*PIVMIN
GU = GU + FUDGE*BNORM*ULP*IN + FUDGE*PIVMIN
*
* Compute ATOLI for the current submatrix
*
IF( ABSTOL.LE.ZERO ) THEN
ATOLI = ULP*MAX( ABS( GL ), ABS( GU ) )
ELSE
ATOLI = ABSTOL
END IF
*
IF( IRANGE.GT.1 ) THEN
IF( GU.LT.WL ) THEN
NWL = NWL + IN
NWU = NWU + IN
GO TO 70
END IF
GL = MAX( GL, WL )
GU = MIN( GU, WU )
IF( GL.GE.GU )
$ GO TO 70
END IF
*
* Set Up Initial Interval
*
WORK( N+1 ) = GL
WORK( N+IN+1 ) = GU
CALL DLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
$ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ),
$ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM,
$ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
*
NWL = NWL + IWORK( 1 )
NWU = NWU + IWORK( IN+1 )
IWOFF = M - IWORK( 1 )
*
* Compute Eigenvalues
*
OPS = OPS + 8
ITMAX = INT( ( LOG( GU-GL+PIVMIN )-LOG( PIVMIN ) ) /
$ LOG( TWO ) ) + 2
CALL DLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
$ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ),
$ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT,
$ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
*
* Copy Eigenvalues Into W and IBLOCK
* Use -JB for block number for unconverged eigenvalues.
*
OPS = OPS + 2*IOUT
DO 60 J = 1, IOUT
TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) )
*
* Flag non-convergence.
*
IF( J.GT.IOUT-IINFO ) THEN
NCNVRG = .TRUE.
IB = -JB
ELSE
IB = JB
END IF
DO 50 JE = IWORK( J ) + 1 + IWOFF,
$ IWORK( J+IN ) + IWOFF
W( JE ) = TMP1
IBLOCK( JE ) = IB
50 CONTINUE
60 CONTINUE
*
M = M + IM
END IF
70 CONTINUE
*
* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU
* If NWL+1 < IL or NWU > IU, discard extra eigenvalues.
*
IF( IRANGE.EQ.3 ) THEN
IM = 0
IDISCL = IL - 1 - NWL
IDISCU = NWU - IU
*
IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
DO 80 JE = 1, M
IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN
IDISCL = IDISCL - 1
ELSE IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN
IDISCU = IDISCU - 1
ELSE
IM = IM + 1
W( IM ) = W( JE )
IBLOCK( IM ) = IBLOCK( JE )
END IF
80 CONTINUE
M = IM
END IF
IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
*
* Code to deal with effects of bad arithmetic:
* Some low eigenvalues to be discarded are not in (WL,WLU],
* or high eigenvalues to be discarded are not in (WUL,WU]
* so just kill off the smallest IDISCL/largest IDISCU
* eigenvalues, by simply finding the smallest/largest
* eigenvalue(s).
*
* (If N(w) is monotone non-decreasing, this should never
* happen.)
*
IF( IDISCL.GT.0 ) THEN
WKILL = WU
DO 100 JDISC = 1, IDISCL
IW = 0
DO 90 JE = 1, M
IF( IBLOCK( JE ).NE.0 .AND.
$ ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN
IW = JE
WKILL = W( JE )
END IF
90 CONTINUE
IBLOCK( IW ) = 0
100 CONTINUE
END IF
IF( IDISCU.GT.0 ) THEN
*
WKILL = WL
DO 120 JDISC = 1, IDISCU
IW = 0
DO 110 JE = 1, M
IF( IBLOCK( JE ).NE.0 .AND.
$ ( W( JE ).GT.WKILL .OR. IW.EQ.0 ) ) THEN
IW = JE
WKILL = W( JE )
END IF
110 CONTINUE
IBLOCK( IW ) = 0
120 CONTINUE
END IF
IM = 0
DO 130 JE = 1, M
IF( IBLOCK( JE ).NE.0 ) THEN
IM = IM + 1
W( IM ) = W( JE )
IBLOCK( IM ) = IBLOCK( JE )
END IF
130 CONTINUE
M = IM
END IF
IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN
TOOFEW = .TRUE.
END IF
END IF
*
* If ORDER='B', do nothing -- the eigenvalues are already sorted
* by block.
* If ORDER='E', sort the eigenvalues from smallest to largest
*
IF( IORDER.EQ.1 .AND. NSPLIT.GT.1 ) THEN
DO 150 JE = 1, M - 1
IE = 0
TMP1 = W( JE )
DO 140 J = JE + 1, M
IF( W( J ).LT.TMP1 ) THEN
IE = J
TMP1 = W( J )
END IF
140 CONTINUE
*
IF( IE.NE.0 ) THEN
ITMP1 = IBLOCK( IE )
W( IE ) = W( JE )
IBLOCK( IE ) = IBLOCK( JE )
W( JE ) = TMP1
IBLOCK( JE ) = ITMP1
END IF
150 CONTINUE
END IF
*
INFO = 0
IF( NCNVRG )
$ INFO = INFO + 1
IF( TOOFEW )
$ INFO = INFO + 2
RETURN
*
* End of DSTEBZ
*
END
SUBROUTINE DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK,
$ LIWORK, INFO )
*
* -- LAPACK driver routine (instrum. to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER COMPZ
INTEGER INFO, LDZ, LIWORK, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * )
* ..
* Common block to return operation count and iteration count
* ITCNT is initialized to 0, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DSTEDC computes all eigenvalues and, optionally, eigenvectors of a
* symmetric tridiagonal matrix using the divide and conquer method.
* The eigenvectors of a full or band real symmetric matrix can also be
* found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this
* matrix to tridiagonal form.
*
* This code makes very mild assumptions about floating point
* arithmetic. It will work on machines with a guard digit in
* add/subtract, or on those binary machines without guard digits
* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
* It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none. See DLAED3 for details.
*
* Arguments
* =========
*
* COMPZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only.
* = 'I': Compute eigenvectors of tridiagonal matrix also.
* = 'V': Compute eigenvectors of original dense symmetric
* matrix also. On entry, Z contains the orthogonal
* matrix used to reduce the original matrix to
* tridiagonal form.
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the diagonal elements of the tridiagonal matrix.
* On exit, if INFO = 0, the eigenvalues in ascending order.
*
* E (input/output) DOUBLE PRECISION array, dimension (N-1)
* On entry, the subdiagonal elements of the tridiagonal matrix.
* On exit, E has been destroyed.
*
* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
* On entry, if COMPZ = 'V', then Z contains the orthogonal
* matrix used in the reduction to tridiagonal form.
* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
* orthonormal eigenvectors of the original symmetric matrix,
* and if COMPZ = 'I', Z contains the orthonormal eigenvectors
* of the symmetric tridiagonal matrix.
* If COMPZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1.
* If eigenvectors are desired, then LDZ >= max(1,N).
*
* WORK (workspace/output) DOUBLE PRECISION array,
* dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* If COMPZ = 'N' or N <= 1 then LWORK must be at least 1.
* If COMPZ = 'V' and N > 1 then LWORK must be at least
* ( 1 + 3*N + 2*N*lg N + 3*N**2 ),
* where lg( N ) = smallest integer k such
* that 2**k >= N.
* If COMPZ = 'I' and N > 1 then LWORK must be at least
* ( 1 + 4*N + N**2 ).
*
* 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.
*
* IWORK (workspace/output) INTEGER array, dimension (LIWORK)
* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK.
* If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1.
* If COMPZ = 'V' and N > 1 then LIWORK must be at least
* ( 6 + 6*N + 5*N*lg N ).
* If COMPZ = 'I' and N > 1 then LIWORK must be at least
* ( 3 + 5*N ).
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal size of the IWORK array,
* returns this value as the first entry of the IWORK array, and
* no error message related to LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: The algorithm failed to compute an eigenvalue while
* working on the submatrix lying in rows and columns
* INFO/(N+1) through mod(INFO,N+1).
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
* Modified by Francoise Tisseur, University of Tennessee.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER DTRTRW, END, I, ICOMPZ, II, J, K, LGN, LIWMIN,
$ LWMIN, M, SMLSIZ, START, STOREZ
DOUBLE PRECISION EPS, ORGNRM, P, TINY
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANST
EXTERNAL LSAME, ILAENV, DLAMCH, DLANST
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLACPY, DLAED0, DLASCL, DLASET, DLASRT,
$ DSTEQR, DSTERF, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, INT, LOG, MAX, MOD, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
IF( LSAME( COMPZ, 'N' ) ) THEN
ICOMPZ = 0
ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
ICOMPZ = 1
ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
ICOMPZ = 2
ELSE
ICOMPZ = -1
END IF
IF( N.LE.1 .OR. ICOMPZ.LE.0 ) THEN
LIWMIN = 1
LWMIN = 1
ELSE
LGN = INT( LOG( DBLE( N ) ) / LOG( TWO ) )
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IF( ICOMPZ.EQ.1 ) THEN
LWMIN = 1 + 3*N + 2*N*LGN + 3*N**2
LIWMIN = 6 + 6*N + 5*N*LGN
ELSE IF( ICOMPZ.EQ.2 ) THEN
LWMIN = 1 + 4*N + N**2
LIWMIN = 3 + 5*N
END IF
END IF
IF( ICOMPZ.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
$ N ) ) ) THEN
INFO = -6
ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -8
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -10
END IF
*
IF( INFO.EQ.0 ) THEN
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSTEDC', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
ITCNT = 0
IF( N.EQ.0 )
$ RETURN
IF( N.EQ.1 ) THEN
IF( ICOMPZ.NE.0 )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
SMLSIZ = ILAENV( 9, 'DSTEDC', ' ', 0, 0, 0, 0 )
*
* If the following conditional clause is removed, then the routine
* will use the Divide and Conquer routine to compute only the
* eigenvalues, which requires (3N + 3N**2) real workspace and
* (2 + 5N + 2N lg(N)) integer workspace.
* Since on many architectures DSTERF is much faster than any other
* algorithm for finding eigenvalues only, it is used here
* as the default.
*
* If COMPZ = 'N', use DSTERF to compute the eigenvalues.
*
IF( ICOMPZ.EQ.0 ) THEN
CALL DSTERF( N, D, E, INFO )
RETURN
END IF
*
* If N is smaller than the minimum divide size (SMLSIZ+1), then
* solve the problem with another solver.
*
IF( N.LE.SMLSIZ ) THEN
IF( ICOMPZ.EQ.0 ) THEN
CALL DSTERF( N, D, E, INFO )
RETURN
ELSE IF( ICOMPZ.EQ.2 ) THEN
CALL DSTEQR( 'I', N, D, E, Z, LDZ, WORK, INFO )
RETURN
ELSE
CALL DSTEQR( 'V', N, D, E, Z, LDZ, WORK, INFO )
RETURN
END IF
END IF
*
* If COMPZ = 'V', the Z matrix must be stored elsewhere for later
* use.
*
IF( ICOMPZ.EQ.1 ) THEN
STOREZ = 1 + N*N
ELSE
STOREZ = 1
END IF
*
IF( ICOMPZ.EQ.2 ) THEN
CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
END IF
*
* Scale.
*
ORGNRM = DLANST( 'M', N, D, E )
IF( ORGNRM.EQ.ZERO )
$ RETURN
*
EPS = DLAMCH( 'Epsilon' )
*
START = 1
*
* while ( START <= N )
*
10 CONTINUE
IF( START.LE.N ) THEN
*
* Let END be the position of the next subdiagonal entry such that
* E( END ) <= TINY or END = N if no such subdiagonal exists. The
* matrix identified by the elements between START and END
* constitutes an independent sub-problem.
*
END = START
20 CONTINUE
IF( END.LT.N ) THEN
OPS = OPS + 4
TINY = EPS*SQRT( ABS( D( END ) ) )*SQRT( ABS( D( END+1 ) ) )
IF( ABS( E( END ) ).GT.TINY ) THEN
END = END + 1
GO TO 20
END IF
END IF
*
* (Sub) Problem determined. Compute its size and solve it.
*
M = END - START + 1
IF( M.EQ.1 ) THEN
START = END + 1
GO TO 10
END IF
IF( M.GT.SMLSIZ ) THEN
INFO = SMLSIZ
*
* Scale.
*
ORGNRM = DLANST( 'M', M, D( START ), E( START ) )
OPS = OPS + 2*M - 1
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ), M,
$ INFO )
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1, E( START ),
$ M-1, INFO )
*
IF( ICOMPZ.EQ.1 ) THEN
DTRTRW = 1
ELSE
DTRTRW = START
END IF
CALL DLAED0( ICOMPZ, N, M, D( START ), E( START ),
$ Z( DTRTRW, START ), LDZ, WORK( 1 ), N,
$ WORK( STOREZ ), IWORK, INFO )
IF( INFO.NE.0 ) THEN
INFO = ( INFO / ( M+1 )+START-1 )*( N+1 ) +
$ MOD( INFO, ( M+1 ) ) + START - 1
RETURN
END IF
*
* Scale back.
*
OPS = OPS + M
CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ), M,
$ INFO )
*
ELSE
IF( ICOMPZ.EQ.1 ) THEN
*
* Since QR won't update a Z matrix which is larger than the
* length of D, we must solve the sub-problem in a workspace and
* then multiply back into Z.
*
CALL DSTEQR( 'I', M, D( START ), E( START ), WORK, M,
$ WORK( M*M+1 ), INFO )
CALL DLACPY( 'A', N, M, Z( 1, START ), LDZ,
$ WORK( STOREZ ), N )
OPS = OPS + 2*DBLE( N )*M*M
CALL DGEMM( 'N', 'N', N, M, M, ONE, WORK( STOREZ ), LDZ,
$ WORK, M, ZERO, Z( 1, START ), LDZ )
ELSE IF( ICOMPZ.EQ.2 ) THEN
CALL DSTEQR( 'I', M, D( START ), E( START ),
$ Z( START, START ), LDZ, WORK, INFO )
ELSE
CALL DSTERF( M, D( START ), E( START ), INFO )
END IF
IF( INFO.NE.0 ) THEN
INFO = START*( N+1 ) + END
RETURN
END IF
END IF
*
START = END + 1
GO TO 10
END IF
*
* endwhile
*
* If the problem split any number of times, then the eigenvalues
* will not be properly ordered. Here we permute the eigenvalues
* (and the associated eigenvectors) into ascending order.
*
IF( M.NE.N ) THEN
IF( ICOMPZ.EQ.0 ) THEN
*
* Use Quick Sort
*
CALL DLASRT( 'I', N, D, INFO )
*
ELSE
*
* Use Selection Sort to minimize swaps of eigenvectors
*
DO 40 II = 2, N
I = II - 1
K = I
P = D( I )
DO 30 J = II, N
IF( D( J ).LT.P ) THEN
K = J
P = D( J )
END IF
30 CONTINUE
IF( K.NE.I ) THEN
D( K ) = D( I )
D( I ) = P
CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
END IF
40 CONTINUE
END IF
END IF
*
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
RETURN
*
* End of DSTEDC
*
END
SUBROUTINE DSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL,
$ M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK,
$ LIWORK, INFO )
*
* -- LAPACK computational routine (instru to count ops, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE
INTEGER IL, INFO, IU, LDZ, LIWORK, LWORK, M, N
DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER ISUPPZ( * ), IWORK( * )
DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
* Common block to return operation count
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DSTEGR computes eigenvalues by the dqds algorithm, while
* orthogonal eigenvectors are computed from various "good" L D L^T
* representations (also known as Relatively Robust Representations).
* Gram-Schmidt orthogonalization is avoided as far as possible. More
* specifically, the various steps of the algorithm are as follows.
* For the i-th unreduced block of T,
* (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T
* is a relatively robust representation,
* (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high
* relative accuracy by the dqds algorithm,
* (c) If there is a cluster of close eigenvalues, "choose" sigma_i
* close to the cluster, and go to step (a),
* (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T,
* compute the corresponding eigenvector by forming a
* rank-revealing twisted factorization.
* The desired accuracy of the output can be specified by the input
* parameter ABSTOL.
*
* For more details, see "A new O(n^2) algorithm for the symmetric
* tridiagonal eigenvalue/eigenvector problem", by Inderjit Dhillon,
* Computer Science Division Technical Report No. UCB/CSD-97-971,
* UC Berkeley, May 1997.
*
* Note 1 : Currently DSTEGR is only set up to find ALL the n
* eigenvalues and eigenvectors of T in O(n^2) time
* Note 2 : Currently the routine DSTEIN is called when an appropriate
* sigma_i cannot be chosen in step (c) above. DSTEIN invokes modified
* Gram-Schmidt when eigenvalues are close.
* Note 3 : DSTEGR works only on machines which follow ieee-754
* floating-point standard in their handling of infinities and NaNs.
* Normal execution of DSTEGR may create NaNs and infinities and hence
* may abort due to a floating point exception in environments which
* do not conform to the ieee standard.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* RANGE (input) CHARACTER*1
* = 'A': all eigenvalues will be found.
* = 'V': all eigenvalues in the half-open interval (VL,VU]
* will be found.
* = 'I': the IL-th through IU-th eigenvalues will be found.
********** Only RANGE = 'A' is currently supported *********************
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the n diagonal elements of the tridiagonal matrix
* T. On exit, D is overwritten.
*
* E (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix T in elements 1 to N-1 of E; E(N) need not be set.
* On exit, E is overwritten.
*
* VL (input) DOUBLE PRECISION
* VU (input) DOUBLE PRECISION
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* ABSTOL (input) DOUBLE PRECISION
* The absolute error tolerance for the
* eigenvalues/eigenvectors. IF JOBZ = 'V', the eigenvalues and
* eigenvectors output have residual norms bounded by ABSTOL,
* and the dot products between different eigenvectors are
* bounded by ABSTOL. If ABSTOL is less than N*EPS*|T|, then
* N*EPS*|T| will be used in its place, where EPS is the
* machine precision and |T| is the 1-norm of the tridiagonal
* matrix. The eigenvalues are computed to an accuracy of
* EPS*|T| irrespective of ABSTOL. If high relative accuracy
* is important, set ABSTOL to DLAMCH( 'Safe minimum' ).
* See Barlow and Demmel "Computing Accurate Eigensystems of
* Scaled Diagonally Dominant Matrices", LAPACK Working Note #7
* for a discussion of which matrices define their eigenvalues
* to high relative accuracy.
*
* M (output) INTEGER
* The total number of eigenvalues found. 0 <= M <= N.
* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*
* W (output) DOUBLE PRECISION array, dimension (N)
* The first M elements contain the selected eigenvalues in
* ascending order.
*
* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
* contain the orthonormal eigenvectors of the matrix T
* corresponding to the selected eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* If JOBZ = 'N', then Z is not referenced.
* Note: the user must ensure that at least max(1,M) columns are
* supplied in the array Z; if RANGE = 'V', the exact value of M
* is not known in advance and an upper bound must be used.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
* The support of the eigenvectors in Z, i.e., the indices
* indicating the nonzero elements in Z. The i-th eigenvector
* is nonzero only in elements ISUPPZ( 2*i-1 ) through
* ISUPPZ( 2*i ).
*
* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns the optimal
* (and minimal) LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK. LWORK >= max(1,18*N)
*
* 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.
*
* IWORK (workspace/output) INTEGER array, dimension (LIWORK)
* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK. LIWORK >= max(1,10*N)
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal size of the IWORK array,
* returns this value as the first entry of the IWORK array, and
* no error message related to LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = 1, internal error in DLARRE,
* if INFO = 2, internal error in DLARRV.
*
* Further Details
* ===============
*
* Based on contributions by
* Inderjit Dhillon, IBM Almaden, USA
* Osni Marques, LBNL/NERSC, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, LQUERY, VALEIG, WANTZ
INTEGER I, IBEGIN, IEND, IINDBL, IINDWK, IINFO, IINSPL,
$ INDGRS, INDWOF, INDWRK, ITMP, J, JJ, LIWMIN,
$ LWMIN, NSPLIT
DOUBLE PRECISION BIGNUM, EPS, RMAX, RMIN, SAFMIN, SCALE, SMLNUM,
$ THRESH, TMP, TNRM, TOL
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANST
EXTERNAL LSAME, DLAMCH, DLANST
* ..
* .. External Subroutines ..
EXTERNAL DLARRE, DLARRV, DLASET, DSCAL, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
*
LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LIWORK.EQ.-1 ) )
LWMIN = 18*N
LIWMIN = 10*N
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
INFO = -2
*
* The following two lines need to be removed once the
* RANGE = 'V' and RANGE = 'I' options are provided.
*
ELSE IF( VALEIG .OR. INDEIG ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( VALEIG .AND. N.GT.0 .AND. VU.LE.VL ) THEN
INFO = -7
ELSE IF( INDEIG .AND. IL.LT.1 ) THEN
INFO = -8
* The following change should be made in DSTEVX also, otherwise
* IL can be specified as N+1 and IU as N.
* ELSE IF( INDEIG .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) THEN
ELSE IF( INDEIG .AND. ( IU.LT.IL .OR. IU.GT.N ) ) THEN
INFO = -9
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -14
ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -17
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -19
END IF
IF( INFO.EQ.0 ) THEN
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSTEGR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( ALLEIG .OR. INDEIG ) THEN
M = 1
W( 1 ) = D( 1 )
ELSE
IF( VL.LT.D( 1 ) .AND. VU.GE.D( 1 ) ) THEN
M = 1
W( 1 ) = D( 1 )
END IF
END IF
IF( WANTZ )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
OPS = OPS + DBLE( 7 )
SAFMIN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
*
* Scale matrix to allowable range, if necessary.
*
SCALE = ONE
TNRM = DLANST( 'M', N, D, E )
IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
OPS = OPS + DBLE( 1 )
SCALE = RMIN / TNRM
ELSE IF( TNRM.GT.RMAX ) THEN
OPS = OPS + DBLE( 1 )
SCALE = RMAX / TNRM
END IF
IF( SCALE.NE.ONE ) THEN
OPS = OPS + DBLE( 2*N )
CALL DSCAL( N, SCALE, D, 1 )
CALL DSCAL( N-1, SCALE, E, 1 )
TNRM = TNRM*SCALE
END IF
INDGRS = 1
INDWOF = 2*N + 1
INDWRK = 3*N + 1
*
IINSPL = 1
IINDBL = N + 1
IINDWK = 2*N + 1
*
CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ )
*
* Compute the desired eigenvalues of the tridiagonal after splitting
* into smaller subblocks if the corresponding of-diagonal elements
* are small
*
OPS = OPS + DBLE( 1 )
THRESH = EPS*TNRM
CALL DLARRE( N, D, E, THRESH, NSPLIT, IWORK( IINSPL ), M, W,
$ WORK( INDWOF ), WORK( INDGRS ), WORK( INDWRK ),
$ IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 1
RETURN
END IF
*
IF( WANTZ ) THEN
*
* Compute the desired eigenvectors corresponding to the computed
* eigenvalues
*
OPS = OPS + DBLE( 1 )
TOL = MAX( ABSTOL, DBLE( N )*THRESH )
IBEGIN = 1
DO 20 I = 1, NSPLIT
IEND = IWORK( IINSPL+I-1 )
DO 10 J = IBEGIN, IEND
IWORK( IINDBL+J-1 ) = I
10 CONTINUE
IBEGIN = IEND + 1
20 CONTINUE
*
CALL DLARRV( N, D, E, IWORK( IINSPL ), M, W, IWORK( IINDBL ),
$ WORK( INDGRS ), TOL, Z, LDZ, ISUPPZ,
$ WORK( INDWRK ), IWORK( IINDWK ), IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 2
RETURN
END IF
*
END IF
*
IBEGIN = 1
DO 40 I = 1, NSPLIT
IEND = IWORK( IINSPL+I-1 )
DO 30 J = IBEGIN, IEND
OPS = OPS + DBLE( 1 )
W( J ) = W( J ) + WORK( INDWOF+I-1 )
30 CONTINUE
IBEGIN = IEND + 1
40 CONTINUE
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( SCALE.NE.ONE ) THEN
CALL DSCAL( M, ONE / SCALE, W, 1 )
END IF
*
* If eigenvalues are not in order, then sort them, along with
* eigenvectors.
*
IF( NSPLIT.GT.1 ) THEN
DO 60 J = 1, M - 1
I = 0
TMP = W( J )
DO 50 JJ = J + 1, M
IF( W( JJ ).LT.TMP ) THEN
I = JJ
TMP = W( JJ )
END IF
50 CONTINUE
IF( I.NE.0 ) THEN
W( I ) = W( J )
W( J ) = TMP
IF( WANTZ ) THEN
CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
ITMP = ISUPPZ( 2*I-1 )
ISUPPZ( 2*I-1 ) = ISUPPZ( 2*J-1 )
ISUPPZ( 2*J-1 ) = ITMP
ITMP = ISUPPZ( 2*I )
ISUPPZ( 2*I ) = ISUPPZ( 2*J )
ISUPPZ( 2*J ) = ITMP
END IF
END IF
60 CONTINUE
END IF
*
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
RETURN
*
* End of DSTEGR
*
END
SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK,
$ IWORK, IFAIL, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
INTEGER INFO, LDZ, M, N
* ..
* .. Array Arguments ..
INTEGER IBLOCK( * ), IFAIL( * ), ISPLIT( * ),
$ IWORK( * )
DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
* Common block to return operation count and iteration count
* ITCNT is initialized to 0, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DSTEIN computes the eigenvectors of a real symmetric tridiagonal
* matrix T corresponding to specified eigenvalues, using inverse
* iteration.
*
* The maximum number of iterations allowed for each eigenvector is
* specified by an internal parameter MAXITS (currently set to 5).
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the tridiagonal matrix T.
*
* E (input) DOUBLE PRECISION array, dimension (N)
* The (n-1) subdiagonal elements of the tridiagonal matrix
* T, in elements 1 to N-1. E(N) need not be set.
*
* M (input) INTEGER
* The number of eigenvectors to be found. 0 <= M <= N.
*
* W (input) DOUBLE PRECISION array, dimension (N)
* The first M elements of W contain the eigenvalues for
* which eigenvectors are to be computed. The eigenvalues
* should be grouped by split-off block and ordered from
* smallest to largest within the block. ( The output array
* W from DSTEBZ with ORDER = 'B' is expected here. )
*
* IBLOCK (input) INTEGER array, dimension (N)
* The submatrix indices associated with the corresponding
* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to
* the first submatrix from the top, =2 if W(i) belongs to
* the second submatrix, etc. ( The output array IBLOCK
* from DSTEBZ is expected here. )
*
* ISPLIT (input) INTEGER array, dimension (N)
* The splitting points, at which T breaks up into submatrices.
* The first submatrix consists of rows/columns 1 to
* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
* through ISPLIT( 2 ), etc.
* ( The output array ISPLIT from DSTEBZ is expected here. )
*
* Z (output) DOUBLE PRECISION array, dimension (LDZ, M)
* The computed eigenvectors. The eigenvector associated
* with the eigenvalue W(i) is stored in the i-th column of
* Z. Any vector which fails to converge is set to its current
* iterate after MAXITS iterations.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= max(1,N).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (5*N)
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* IFAIL (output) INTEGER array, dimension (M)
* On normal exit, all elements of IFAIL are zero.
* If one or more eigenvectors fail to converge after
* MAXITS iterations, then their indices are stored in
* array IFAIL.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, then i eigenvectors failed to converge
* in MAXITS iterations. Their indices are stored in
* array IFAIL.
*
* Internal Parameters
* ===================
*
* MAXITS INTEGER, default = 5
* The maximum number of iterations performed.
*
* EXTRA INTEGER, default = 2
* The number of iterations performed after norm growth
* criterion is satisfied, should be at least 1.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TEN, ODM3, ODM1
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1,
$ ODM3 = 1.0D-3, ODM1 = 1.0D-1 )
INTEGER MAXITS, EXTRA
PARAMETER ( MAXITS = 5, EXTRA = 2 )
* ..
* .. Local Scalars ..
INTEGER B1, BLKSIZ, BN, GPIND, I, IINFO, INDRV1,
$ INDRV2, INDRV3, INDRV4, INDRV5, ITS, J, J1,
$ JBLK, JMAX, NBLK, NRMCHK
DOUBLE PRECISION DTPCRT, EPS, EPS1, NRM, ONENRM, ORTOL, PERTOL,
$ SCL, SEP, TOL, XJ, XJM, ZTR
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 )
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DASUM, DDOT, DLAMCH, DNRM2
EXTERNAL IDAMAX, DASUM, DDOT, DLAMCH, DNRM2
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DLAGTF, DLAGTS, DLARNV, DSCAL,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
DO 10 I = 1, M
IFAIL( I ) = 0
10 CONTINUE
*
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( M.LT.0 .OR. M.GT.N ) THEN
INFO = -4
ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE
DO 20 J = 2, M
IF( IBLOCK( J ).LT.IBLOCK( J-1 ) ) THEN
INFO = -6
GO TO 30
END IF
IF( IBLOCK( J ).EQ.IBLOCK( J-1 ) .AND. W( J ).LT.W( J-1 ) )
$ THEN
INFO = -5
GO TO 30
END IF
20 CONTINUE
30 CONTINUE
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSTEIN', -INFO )
RETURN
END IF
*
* Initialize iteration count.
*
ITCNT = 0
*
* Quick return if possible
*
IF( N.EQ.0 .OR. M.EQ.0 ) THEN
RETURN
ELSE IF( N.EQ.1 ) THEN
Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
EPS = DLAMCH( 'Precision' )
*
* Initialize seed for random number generator DLARNV.
*
DO 40 I = 1, 4
ISEED( I ) = 1
40 CONTINUE
*
* Initialize pointers.
*
INDRV1 = 0
INDRV2 = INDRV1 + N
INDRV3 = INDRV2 + N
INDRV4 = INDRV3 + N
INDRV5 = INDRV4 + N
*
* Compute eigenvectors of matrix blocks.
*
J1 = 1
DO 160 NBLK = 1, IBLOCK( M )
*
* Find starting and ending indices of block nblk.
*
IF( NBLK.EQ.1 ) THEN
B1 = 1
ELSE
B1 = ISPLIT( NBLK-1 ) + 1
END IF
BN = ISPLIT( NBLK )
BLKSIZ = BN - B1 + 1
IF( BLKSIZ.EQ.1 )
$ GO TO 60
GPIND = B1
*
* Compute reorthogonalization criterion and stopping criterion.
*
ONENRM = ABS( D( B1 ) ) + ABS( E( B1 ) )
ONENRM = MAX( ONENRM, ABS( D( BN ) )+ABS( E( BN-1 ) ) )
DO 50 I = B1 + 1, BN - 1
ONENRM = MAX( ONENRM, ABS( D( I ) )+ABS( E( I-1 ) )+
$ ABS( E( I ) ) )
50 CONTINUE
ORTOL = ODM3*ONENRM
*
DTPCRT = SQRT( ODM1 / BLKSIZ )
*
* Increment opcount for computing criteria.
*
OPS = OPS + ( BN-B1 )*2 + 3
*
* Loop through eigenvalues of block nblk.
*
60 CONTINUE
JBLK = 0
DO 150 J = J1, M
IF( IBLOCK( J ).NE.NBLK ) THEN
J1 = J
GO TO 160
END IF
JBLK = JBLK + 1
XJ = W( J )
*
* Skip all the work if the block size is one.
*
IF( BLKSIZ.EQ.1 ) THEN
WORK( INDRV1+1 ) = ONE
GO TO 120
END IF
*
* If eigenvalues j and j-1 are too close, add a relatively
* small perturbation.
*
IF( JBLK.GT.1 ) THEN
EPS1 = ABS( EPS*XJ )
PERTOL = TEN*EPS1
SEP = XJ - XJM
IF( SEP.LT.PERTOL )
$ XJ = XJM + PERTOL
END IF
*
ITS = 0
NRMCHK = 0
*
* Get random starting vector.
*
CALL DLARNV( 2, ISEED, BLKSIZ, WORK( INDRV1+1 ) )
*
* Increment opcount for getting random starting vector.
* ( DLARND(2,.) requires 9 flops. )
*
OPS = OPS + BLKSIZ*9
*
* Copy the matrix T so it won't be destroyed in factorization.
*
CALL DCOPY( BLKSIZ, D( B1 ), 1, WORK( INDRV4+1 ), 1 )
CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV2+2 ), 1 )
CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV3+1 ), 1 )
*
* Compute LU factors with partial pivoting ( PT = LU )
*
TOL = ZERO
CALL DLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, WORK( INDRV2+2 ),
$ WORK( INDRV3+1 ), TOL, WORK( INDRV5+1 ), IWORK,
$ IINFO )
*
* Increment opcount for computing LU factors.
* ( DLAGTF(BLKSIZ,...) requires about 8*BLKSIZ flops. )
*
OPS = OPS + 8*BLKSIZ
*
* Update iteration count.
*
70 CONTINUE
ITS = ITS + 1
IF( ITS.GT.MAXITS )
$ GO TO 100
*
* Normalize and scale the righthand side vector Pb.
*
SCL = BLKSIZ*ONENRM*MAX( EPS,
$ ABS( WORK( INDRV4+BLKSIZ ) ) ) /
$ DASUM( BLKSIZ, WORK( INDRV1+1 ), 1 )
CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 )
*
* Solve the system LU = Pb.
*
CALL DLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), WORK( INDRV2+2 ),
$ WORK( INDRV3+1 ), WORK( INDRV5+1 ), IWORK,
$ WORK( INDRV1+1 ), TOL, IINFO )
*
* Increment opcount for scaling and solving linear system.
* ( DLAGTS(-1,BLKSIZ,...) requires about 8*BLKSIZ flops. )
*
OPS = OPS + 3 + 10*BLKSIZ
*
* Reorthogonalize by modified Gram-Schmidt if eigenvalues are
* close enough.
*
IF( JBLK.EQ.1 )
$ GO TO 90
IF( ABS( XJ-XJM ).GT.ORTOL )
$ GPIND = J
IF( GPIND.NE.J ) THEN
DO 80 I = GPIND, J - 1
ZTR = -DDOT( BLKSIZ, WORK( INDRV1+1 ), 1, Z( B1, I ),
$ 1 )
CALL DAXPY( BLKSIZ, ZTR, Z( B1, I ), 1,
$ WORK( INDRV1+1 ), 1 )
80 CONTINUE
*
* Increment opcount for reorthogonalizing.
*
OPS = OPS + ( J-GPIND )*BLKSIZ*4
*
END IF
*
* Check the infinity norm of the iterate.
*
90 CONTINUE
JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 )
NRM = ABS( WORK( INDRV1+JMAX ) )
*
* Continue for additional iterations after norm reaches
* stopping criterion.
*
IF( NRM.LT.DTPCRT )
$ GO TO 70
NRMCHK = NRMCHK + 1
IF( NRMCHK.LT.EXTRA+1 )
$ GO TO 70
*
GO TO 110
*
* If stopping criterion was not satisfied, update info and
* store eigenvector number in array ifail.
*
100 CONTINUE
INFO = INFO + 1
IFAIL( INFO ) = J
*
* Accept iterate as jth eigenvector.
*
110 CONTINUE
SCL = ONE / DNRM2( BLKSIZ, WORK( INDRV1+1 ), 1 )
JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 )
IF( WORK( INDRV1+JMAX ).LT.ZERO )
$ SCL = -SCL
CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 )
*
* Increment opcount for scaling.
*
OPS = OPS + 3*BLKSIZ
*
120 CONTINUE
DO 130 I = 1, N
Z( I, J ) = ZERO
130 CONTINUE
DO 140 I = 1, BLKSIZ
Z( B1+I-1, J ) = WORK( INDRV1+I )
140 CONTINUE
*
* Save the shift to check eigenvalue spacing at next
* iteration.
*
XJM = XJ
*
150 CONTINUE
160 CONTINUE
*
RETURN
*
* End of DSTEIN
*
END
SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
CHARACTER COMPZ
INTEGER INFO, LDZ, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * )
* ..
* Common block to return operation count and iteration count
* ITCNT is initialized to 0, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DSTEQR computes all eigenvalues and, optionally, eigenvectors of a
* symmetric tridiagonal matrix using the implicit QL or QR method.
* The eigenvectors of a full or band symmetric matrix can also be found
* if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to
* tridiagonal form.
*
* Arguments
* =========
*
* COMPZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only.
* = 'V': Compute eigenvalues and eigenvectors of the original
* symmetric matrix. On entry, Z must contain the
* orthogonal matrix used to reduce the original matrix
* to tridiagonal form.
* = 'I': Compute eigenvalues and eigenvectors of the
* tridiagonal matrix. Z is initialized to the identity
* matrix.
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the diagonal elements of the tridiagonal matrix.
* On exit, if INFO = 0, the eigenvalues in ascending order.
*
* E (input/output) DOUBLE PRECISION array, dimension (N-1)
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix.
* On exit, E has been destroyed.
*
* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
* On entry, if COMPZ = 'V', then Z contains the orthogonal
* matrix used in the reduction to tridiagonal form.
* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
* orthonormal eigenvectors of the original symmetric matrix,
* and if COMPZ = 'I', Z contains the orthonormal eigenvectors
* of the symmetric tridiagonal matrix.
* If COMPZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* eigenvectors are desired, then LDZ >= max(1,N).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))
* If COMPZ = 'N', then WORK is not referenced.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: the algorithm has failed to find all the eigenvalues in
* a total of 30*N iterations; if INFO = i, then i
* elements of E have not converged to zero; on exit, D
* and E contain the elements of a symmetric tridiagonal
* matrix which is orthogonally similar to the original
* matrix.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, THREE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ THREE = 3.0D0 )
INTEGER MAXIT
PARAMETER ( MAXIT = 30 )
* ..
* .. Local Scalars ..
INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND,
$ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1,
$ NM1, NMAXIT
DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2,
$ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANST, DLAPY2
EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2
* ..
* .. External Subroutines ..
EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASET, DLASR,
$ DLASRT, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( LSAME( COMPZ, 'N' ) ) THEN
ICOMPZ = 0
ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
ICOMPZ = 1
ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
ICOMPZ = 2
ELSE
ICOMPZ = -1
END IF
IF( ICOMPZ.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
$ N ) ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSTEQR', -INFO )
RETURN
END IF
*
* Quick return if possible
*
ITCNT = 0
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( ICOMPZ.EQ.2 )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Determine the unit roundoff and over/underflow thresholds.
*
OPS = OPS + 6
EPS = DLAMCH( 'E' )
EPS2 = EPS**2
SAFMIN = DLAMCH( 'S' )
SAFMAX = ONE / SAFMIN
SSFMAX = SQRT( SAFMAX ) / THREE
SSFMIN = SQRT( SAFMIN ) / EPS2
*
* Compute the eigenvalues and eigenvectors of the tridiagonal
* matrix.
*
IF( ICOMPZ.EQ.2 )
$ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
*
NMAXIT = N*MAXIT
JTOT = 0
*
* Determine where the matrix splits and choose QL or QR iteration
* for each block, according to whether top or bottom diagonal
* element is smaller.
*
L1 = 1
NM1 = N - 1
*
10 CONTINUE
IF( L1.GT.N )
$ GO TO 160
IF( L1.GT.1 )
$ E( L1-1 ) = ZERO
IF( L1.LE.NM1 ) THEN
DO 20 M = L1, NM1
TST = ABS( E( M ) )
IF( TST.EQ.ZERO )
$ GO TO 30
OPS = OPS + 4
IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+
$ 1 ) ) ) )*EPS ) THEN
E( M ) = ZERO
GO TO 30
END IF
20 CONTINUE
END IF
M = N
*
30 CONTINUE
L = L1
LSV = L
LEND = M
LENDSV = LEND
L1 = M + 1
IF( LEND.EQ.L )
$ GO TO 10
*
* Scale submatrix in rows and columns L to LEND
*
OPS = OPS + 2*( LEND-L+1 )
ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) )
ISCALE = 0
IF( ANORM.EQ.ZERO )
$ GO TO 10
IF( ANORM.GT.SSFMAX ) THEN
ISCALE = 1
OPS = OPS + 2*( LEND-L ) + 1
CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
$ INFO )
ELSE IF( ANORM.LT.SSFMIN ) THEN
ISCALE = 2
OPS = OPS + 2*( LEND-L ) + 1
CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N,
$ INFO )
END IF
*
* Choose between QL and QR iteration
*
IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
LEND = LSV
L = LENDSV
END IF
*
IF( LEND.GT.L ) THEN
*
* QL Iteration
*
* Look for small subdiagonal element.
*
40 CONTINUE
IF( L.NE.LEND ) THEN
LENDM1 = LEND - 1
DO 50 M = L, LENDM1
TST = ABS( E( M ) )**2
OPS = OPS + 4
IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+
$ SAFMIN )GO TO 60
50 CONTINUE
END IF
*
M = LEND
*
60 CONTINUE
IF( M.LT.LEND )
$ E( M ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 80
*
* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
* to compute its eigensystem.
*
IF( M.EQ.L+1 ) THEN
IF( ICOMPZ.GT.0 ) THEN
OPS = OPS + 22
CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S )
WORK( L ) = C
WORK( N-1+L ) = S
OPS = OPS + 6*N
CALL DLASR( 'R', 'V', 'B', N, 2, WORK( L ),
$ WORK( N-1+L ), Z( 1, L ), LDZ )
ELSE
OPS = OPS + 15
CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 )
END IF
D( L ) = RT1
D( L+1 ) = RT2
E( L ) = ZERO
L = L + 2
IF( L.LE.LEND )
$ GO TO 40
GO TO 140
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 140
JTOT = JTOT + 1
*
* Form shift.
*
OPS = OPS + 12
G = ( D( L+1 )-P ) / ( TWO*E( L ) )
R = DLAPY2( G, ONE )
G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) )
*
S = ONE
C = ONE
P = ZERO
*
* Inner loop
*
MM1 = M - 1
OPS = OPS + 18*( M-L )
DO 70 I = MM1, L, -1
F = S*E( I )
B = C*E( I )
CALL DLARTG( G, F, C, S, R )
IF( I.NE.M-1 )
$ E( I+1 ) = R
G = D( I+1 ) - P
R = ( D( I )-G )*S + TWO*C*B
P = S*R
D( I+1 ) = G + P
G = C*R - B
*
* If eigenvectors are desired, then save rotations.
*
IF( ICOMPZ.GT.0 ) THEN
WORK( I ) = C
WORK( N-1+I ) = -S
END IF
*
70 CONTINUE
*
* If eigenvectors are desired, then apply saved rotations.
*
IF( ICOMPZ.GT.0 ) THEN
MM = M - L + 1
OPS = OPS + 6*N*( MM-1 )
CALL DLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ),
$ Z( 1, L ), LDZ )
END IF
*
OPS = OPS + 1
D( L ) = D( L ) - P
E( L ) = G
GO TO 40
*
* Eigenvalue found.
*
80 CONTINUE
D( L ) = P
*
L = L + 1
IF( L.LE.LEND )
$ GO TO 40
GO TO 140
*
ELSE
*
* QR Iteration
*
* Look for small superdiagonal element.
*
90 CONTINUE
IF( L.NE.LEND ) THEN
LENDP1 = LEND + 1
DO 100 M = L, LENDP1, -1
OPS = OPS + 4
TST = ABS( E( M-1 ) )**2
IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+
$ SAFMIN )GO TO 110
100 CONTINUE
END IF
*
M = LEND
*
110 CONTINUE
IF( M.GT.LEND )
$ E( M-1 ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 130
*
* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
* to compute its eigensystem.
*
IF( M.EQ.L-1 ) THEN
IF( ICOMPZ.GT.0 ) THEN
OPS = OPS + 22
CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S )
WORK( M ) = C
WORK( N-1+M ) = S
OPS = OPS + 6*N
CALL DLASR( 'R', 'V', 'F', N, 2, WORK( M ),
$ WORK( N-1+M ), Z( 1, L-1 ), LDZ )
ELSE
OPS = OPS + 15
CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 )
END IF
D( L-1 ) = RT1
D( L ) = RT2
E( L-1 ) = ZERO
L = L - 2
IF( L.GE.LEND )
$ GO TO 90
GO TO 140
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 140
JTOT = JTOT + 1
*
* Form shift.
*
OPS = OPS + 12
G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) )
R = DLAPY2( G, ONE )
G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) )
*
S = ONE
C = ONE
P = ZERO
*
* Inner loop
*
LM1 = L - 1
OPS = OPS + 18*( L-M )
DO 120 I = M, LM1
F = S*E( I )
B = C*E( I )
CALL DLARTG( G, F, C, S, R )
IF( I.NE.M )
$ E( I-1 ) = R
G = D( I ) - P
R = ( D( I+1 )-G )*S + TWO*C*B
P = S*R
D( I ) = G + P
G = C*R - B
*
* If eigenvectors are desired, then save rotations.
*
IF( ICOMPZ.GT.0 ) THEN
WORK( I ) = C
WORK( N-1+I ) = S
END IF
*
120 CONTINUE
*
* If eigenvectors are desired, then apply saved rotations.
*
IF( ICOMPZ.GT.0 ) THEN
MM = L - M + 1
OPS = OPS + 6*N*( MM-1 )
CALL DLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ),
$ Z( 1, M ), LDZ )
END IF
*
OPS = OPS + 1
D( L ) = D( L ) - P
E( LM1 ) = G
GO TO 90
*
* Eigenvalue found.
*
130 CONTINUE
D( L ) = P
*
L = L - 1
IF( L.GE.LEND )
$ GO TO 90
GO TO 140
*
END IF
*
* Undo scaling if necessary
*
140 CONTINUE
IF( ISCALE.EQ.1 ) THEN
OPS = OPS + 2*( LENDSV-LSV ) + 1
CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ),
$ N, INFO )
ELSE IF( ISCALE.EQ.2 ) THEN
OPS = OPS + 2*( LENDSV-LSV ) + 1
CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ),
$ N, INFO )
END IF
*
* Check for no convergence to an eigenvalue after a total
* of N*MAXIT iterations.
*
IF( JTOT.LT.NMAXIT )
$ GO TO 10
DO 150 I = 1, N - 1
IF( E( I ).NE.ZERO )
$ INFO = INFO + 1
150 CONTINUE
GO TO 190
*
* Order eigenvalues and eigenvectors.
*
160 CONTINUE
IF( ICOMPZ.EQ.0 ) THEN
*
* Use Quick Sort
*
CALL DLASRT( 'I', N, D, INFO )
*
ELSE
*
* Use Selection Sort to minimize swaps of eigenvectors
*
DO 180 II = 2, N
I = II - 1
K = I
P = D( I )
DO 170 J = II, N
IF( D( J ).LT.P ) THEN
K = J
P = D( J )
END IF
170 CONTINUE
IF( K.NE.I ) THEN
D( K ) = D( I )
D( I ) = P
CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
END IF
180 CONTINUE
END IF
*
190 CONTINUE
RETURN
*
* End of DSTEQR
*
END
SUBROUTINE DSTERF( N, D, E, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER INFO, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * )
* ..
* Common block to return operation count and iteration count
* ITCNT is initialized to 0, OPS is only incremented
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DSTERF computes all eigenvalues of a symmetric tridiagonal matrix
* using the Pal-Walker-Kahan variant of the QL or QR algorithm.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the n diagonal elements of the tridiagonal matrix.
* On exit, if INFO = 0, the eigenvalues in ascending order.
*
* E (input/output) DOUBLE PRECISION array, dimension (N-1)
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix.
* On exit, E has been destroyed.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: the algorithm failed to find all of the eigenvalues in
* a total of 30*N iterations; if INFO = i, then i
* elements of E have not converged to zero.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, THREE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ THREE = 3.0D0 )
INTEGER MAXIT
PARAMETER ( MAXIT = 30 )
* ..
* .. Local Scalars ..
INTEGER I, ISCALE, JTOT, L, L1, LEND, LENDSV, LSV, M,
$ NMAXIT
DOUBLE PRECISION ALPHA, ANORM, BB, C, EPS, EPS2, GAMMA, OLDC,
$ OLDGAM, P, R, RT1, RT2, RTE, S, SAFMAX, SAFMIN,
$ SIGMA, SSFMAX, SSFMIN
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANST, DLAPY2
EXTERNAL DLAMCH, DLANST, DLAPY2
* ..
* .. External Subroutines ..
EXTERNAL DLAE2, DLASCL, DLASRT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
* Quick return if possible
*
ITCNT = 0
IF( N.LT.0 ) THEN
INFO = -1
CALL XERBLA( 'DSTERF', -INFO )
RETURN
END IF
IF( N.LE.1 )
$ RETURN
*
* Determine the unit roundoff for this environment.
*
OPS = OPS + 6
EPS = DLAMCH( 'E' )
EPS2 = EPS**2
SAFMIN = DLAMCH( 'S' )
SAFMAX = ONE / SAFMIN
SSFMAX = SQRT( SAFMAX ) / THREE
SSFMIN = SQRT( SAFMIN ) / EPS2
*
* Compute the eigenvalues of the tridiagonal matrix.
*
NMAXIT = N*MAXIT
SIGMA = ZERO
JTOT = 0
*
* Determine where the matrix splits and choose QL or QR iteration
* for each block, according to whether top or bottom diagonal
* element is smaller.
*
L1 = 1
*
10 CONTINUE
IF( L1.GT.N )
$ GO TO 170
IF( L1.GT.1 )
$ E( L1-1 ) = ZERO
DO 20 M = L1, N - 1
OPS = OPS + 4
IF( ABS( E( M ) ).LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+
$ 1 ) ) ) )*EPS ) THEN
E( M ) = ZERO
GO TO 30
END IF
20 CONTINUE
M = N
*
30 CONTINUE
L = L1
LSV = L
LEND = M
LENDSV = LEND
L1 = M + 1
IF( LEND.EQ.L )
$ GO TO 10
*
* Scale submatrix in rows and columns L to LEND
*
OPS = OPS + 2*( LEND-L+1 )
ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) )
ISCALE = 0
IF( ANORM.GT.SSFMAX ) THEN
ISCALE = 1
OPS = OPS + 2*( LEND-L ) + 1
CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
$ INFO )
ELSE IF( ANORM.LT.SSFMIN ) THEN
ISCALE = 2
OPS = OPS + 2*( LEND-L ) + 1
CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N,
$ INFO )
END IF
*
OPS = OPS + 2*( LEND-L )
DO 40 I = L, LEND - 1
E( I ) = E( I )**2
40 CONTINUE
*
* Choose between QL and QR iteration
*
IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
LEND = LSV
L = LENDSV
END IF
*
IF( LEND.GE.L ) THEN
*
* QL Iteration
*
* Look for small subdiagonal element.
*
50 CONTINUE
IF( L.NE.LEND ) THEN
DO 60 M = L, LEND - 1
OPS = OPS + 3
IF( ABS( E( M ) ).LE.EPS2*ABS( D( M )*D( M+1 ) ) )
$ GO TO 70
60 CONTINUE
END IF
M = LEND
*
70 CONTINUE
IF( M.LT.LEND )
$ E( M ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 90
*
* If remaining matrix is 2 by 2, use DLAE2 to compute its
* eigenvalues.
*
IF( M.EQ.L+1 ) THEN
OPS = OPS + 16
RTE = SQRT( E( L ) )
CALL DLAE2( D( L ), RTE, D( L+1 ), RT1, RT2 )
D( L ) = RT1
D( L+1 ) = RT2
E( L ) = ZERO
L = L + 2
IF( L.LE.LEND )
$ GO TO 50
GO TO 150
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 150
JTOT = JTOT + 1
*
* Form shift.
*
OPS = OPS + 14
RTE = SQRT( E( L ) )
SIGMA = ( D( L+1 )-P ) / ( TWO*RTE )
R = DLAPY2( SIGMA, ONE )
SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) )
*
C = ONE
S = ZERO
GAMMA = D( M ) - SIGMA
P = GAMMA*GAMMA
*
* Inner loop
*
OPS = OPS + 12*( M-L )
DO 80 I = M - 1, L, -1
BB = E( I )
R = P + BB
IF( I.NE.M-1 )
$ E( I+1 ) = S*R
OLDC = C
C = P / R
S = BB / R
OLDGAM = GAMMA
ALPHA = D( I )
GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM
D( I+1 ) = OLDGAM + ( ALPHA-GAMMA )
IF( C.NE.ZERO ) THEN
P = ( GAMMA*GAMMA ) / C
ELSE
P = OLDC*BB
END IF
80 CONTINUE
*
OPS = OPS + 2
E( L ) = S*P
D( L ) = SIGMA + GAMMA
GO TO 50
*
* Eigenvalue found.
*
90 CONTINUE
D( L ) = P
*
L = L + 1
IF( L.LE.LEND )
$ GO TO 50
GO TO 150
*
ELSE
*
* QR Iteration
*
* Look for small superdiagonal element.
*
100 CONTINUE
DO 110 M = L, LEND + 1, -1
OPS = OPS + 3
IF( ABS( E( M-1 ) ).LE.EPS2*ABS( D( M )*D( M-1 ) ) )
$ GO TO 120
110 CONTINUE
M = LEND
*
120 CONTINUE
IF( M.GT.LEND )
$ E( M-1 ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 140
*
* If remaining matrix is 2 by 2, use DLAE2 to compute its
* eigenvalues.
*
IF( M.EQ.L-1 ) THEN
OPS = OPS + 16
RTE = SQRT( E( L-1 ) )
CALL DLAE2( D( L ), RTE, D( L-1 ), RT1, RT2 )
D( L ) = RT1
D( L-1 ) = RT2
E( L-1 ) = ZERO
L = L - 2
IF( L.GE.LEND )
$ GO TO 100
GO TO 150
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 150
JTOT = JTOT + 1
*
* Form shift.
*
OPS = OPS + 14
RTE = SQRT( E( L-1 ) )
SIGMA = ( D( L-1 )-P ) / ( TWO*RTE )
R = DLAPY2( SIGMA, ONE )
SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) )
*
C = ONE
S = ZERO
GAMMA = D( M ) - SIGMA
P = GAMMA*GAMMA
*
* Inner loop
*
OPS = OPS + 12*( L-M )
DO 130 I = M, L - 1
BB = E( I )
R = P + BB
IF( I.NE.M )
$ E( I-1 ) = S*R
OLDC = C
C = P / R
S = BB / R
OLDGAM = GAMMA
ALPHA = D( I+1 )
GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM
D( I ) = OLDGAM + ( ALPHA-GAMMA )
IF( C.NE.ZERO ) THEN
P = ( GAMMA*GAMMA ) / C
ELSE
P = OLDC*BB
END IF
130 CONTINUE
*
OPS = OPS + 2
E( L-1 ) = S*P
D( L ) = SIGMA + GAMMA
GO TO 100
*
* Eigenvalue found.
*
140 CONTINUE
D( L ) = P
*
L = L - 1
IF( L.GE.LEND )
$ GO TO 100
GO TO 150
*
END IF
*
* Undo scaling if necessary
*
150 CONTINUE
IF( ISCALE.EQ.1 ) THEN
OPS = OPS + LENDSV - LSV + 1
CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
END IF
IF( ISCALE.EQ.2 ) THEN
OPS = OPS + LENDSV - LSV + 1
CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
END IF
*
* Check for no convergence to an eigenvalue after a total
* of N*MAXIT iterations.
*
IF( JTOT.LT.NMAXIT )
$ GO TO 10
DO 160 I = 1, N - 1
IF( E( I ).NE.ZERO )
$ INFO = INFO + 1
160 CONTINUE
GO TO 180
*
* Sort eigenvalues in increasing order.
*
170 CONTINUE
CALL DLASRT( 'I', N, D, INFO )
*
180 CONTINUE
RETURN
*
* End of DSTERF
*
END
SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, A, LDA, B, LDB, VL,
$ LDVL, VR, LDVR, MM, M, WORK, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER HOWMNY, SIDE
INTEGER INFO, LDA, LDB, LDVL, LDVR, M, MM, N
* ..
* .. Array Arguments ..
LOGICAL SELECT( * )
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), VL( LDVL, * ),
$ VR( LDVR, * ), WORK( * )
* ..
*
* ---------------------- Begin Timing Code -------------------------
* Common block to return operation count and iteration count
* ITCNT is initialized to 0, OPS is only incremented
* OPST is used to accumulate small contributions to OPS
* to avoid roundoff error
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
* ----------------------- End Timing Code --------------------------
*
*
* Purpose
* =======
*
* DTGEVC computes some or all of the right and/or left generalized
* eigenvectors of a pair of real upper triangular matrices (A,B).
*
* The right generalized eigenvector x and the left generalized
* eigenvector y of (A,B) corresponding to a generalized eigenvalue
* w are defined by:
*
* (A - wB) * x = 0 and y**H * (A - wB) = 0
*
* where y**H denotes the conjugate tranpose of y.
*
* If an eigenvalue w is determined by zero diagonal elements of both A
* and B, a unit vector is returned as the corresponding eigenvector.
*
* If all eigenvectors are requested, the routine may either return
* the matrices X and/or Y of right or left eigenvectors of (A,B), or
* the products Z*X and/or Q*Y, where Z and Q are input orthogonal
* matrices. If (A,B) was obtained from the generalized real-Schur
* factorization of an original pair of matrices
* (A0,B0) = (Q*A*Z**H,Q*B*Z**H),
* then Z*X and Q*Y are the matrices of right or left eigenvectors of
* A.
*
* A must be block upper triangular, with 1-by-1 and 2-by-2 diagonal
* blocks. Corresponding to each 2-by-2 diagonal block is a complex
* conjugate pair of eigenvalues and eigenvectors; only one
* eigenvector of the pair is computed, namely the one corresponding
* to the eigenvalue with positive imaginary part.
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* = 'R': compute right eigenvectors only;
* = 'L': compute left eigenvectors only;
* = 'B': compute both right and left eigenvectors.
*
* HOWMNY (input) CHARACTER*1
* = 'A': compute all right and/or left eigenvectors;
* = 'B': compute all right and/or left eigenvectors, and
* backtransform them using the input matrices supplied
* in VR and/or VL;
* = 'S': compute selected right and/or left eigenvectors,
* specified by the logical array SELECT.
*
* SELECT (input) LOGICAL array, dimension (N)
* If HOWMNY='S', SELECT specifies the eigenvectors to be
* computed.
* If HOWMNY='A' or 'B', SELECT is not referenced.
* To select the real eigenvector corresponding to the real
* eigenvalue w(j), SELECT(j) must be set to .TRUE. To select
* the complex eigenvector corresponding to a complex conjugate
* pair w(j) and w(j+1), either SELECT(j) or SELECT(j+1) must
* be set to .TRUE..
*
* N (input) INTEGER
* The order of the matrices A and B. N >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The upper quasi-triangular matrix A.
*
* LDA (input) INTEGER
* The leading dimension of array A. LDA >= max(1,N).
*
* B (input) DOUBLE PRECISION array, dimension (LDB,N)
* The upper triangular matrix B. If A has a 2-by-2 diagonal
* block, then the corresponding 2-by-2 block of B must be
* diagonal with positive elements.
*
* LDB (input) INTEGER
* The leading dimension of array B. LDB >= max(1,N).
*
* VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)
* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
* contain an N-by-N matrix Q (usually the orthogonal matrix Q
* of left Schur vectors returned by DHGEQZ).
* On exit, if SIDE = 'L' or 'B', VL contains:
* if HOWMNY = 'A', the matrix Y of left eigenvectors of (A,B);
* if HOWMNY = 'B', the matrix Q*Y;
* if HOWMNY = 'S', the left eigenvectors of (A,B) specified by
* SELECT, stored consecutively in the columns of
* VL, in the same order as their eigenvalues.
* If SIDE = 'R', VL is not referenced.
*
* A complex eigenvector corresponding to a complex eigenvalue
* is stored in two consecutive columns, the first holding the
* real part, and the second the imaginary part.
*
* LDVL (input) INTEGER
* The leading dimension of array VL.
* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
*
* VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)
* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
* contain an N-by-N matrix Q (usually the orthogonal matrix Z
* of right Schur vectors returned by DHGEQZ).
* On exit, if SIDE = 'R' or 'B', VR contains:
* if HOWMNY = 'A', the matrix X of right eigenvectors of (A,B);
* if HOWMNY = 'B', the matrix Z*X;
* if HOWMNY = 'S', the right eigenvectors of (A,B) specified by
* SELECT, stored consecutively in the columns of
* VR, in the same order as their eigenvalues.
* If SIDE = 'L', VR is not referenced.
*
* A complex eigenvector corresponding to a complex eigenvalue
* is stored in two consecutive columns, the first holding the
* real part and the second the imaginary part.
*
* LDVR (input) INTEGER
* The leading dimension of the array VR.
* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
*
* MM (input) INTEGER
* The number of columns in the arrays VL and/or VR. MM >= M.
*
* M (output) INTEGER
* The number of columns in the arrays VL and/or VR actually
* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M
* is set to N. Each selected real eigenvector occupies one
* column and each selected complex eigenvector occupies two
* columns.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (6*N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: the 2-by-2 block (INFO:INFO+1) does not have a complex
* eigenvalue.
*
* Further Details
* ===============
*
* Allocation of workspace:
* ---------- -- ---------
*
* WORK( j ) = 1-norm of j-th column of A, above the diagonal
* WORK( N+j ) = 1-norm of j-th column of B, above the diagonal
* WORK( 2*N+1:3*N ) = real part of eigenvector
* WORK( 3*N+1:4*N ) = imaginary part of eigenvector
* WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector
* WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector
*
* Rowwise vs. columnwise solution methods:
* ------- -- ---------- -------- -------
*
* Finding a generalized eigenvector consists basically of solving the
* singular triangular system
*
* (A - w B) x = 0 (for right) or: (A - w B)**H y = 0 (for left)
*
* Consider finding the i-th right eigenvector (assume all eigenvalues
* are real). The equation to be solved is:
* n i
* 0 = sum C(j,k) v(k) = sum C(j,k) v(k) for j = i,. . .,1
* k=j k=j
*
* where C = (A - w B) (The components v(i+1:n) are 0.)
*
* The "rowwise" method is:
*
* (1) v(i) := 1
* for j = i-1,. . .,1:
* i
* (2) compute s = - sum C(j,k) v(k) and
* k=j+1
*
* (3) v(j) := s / C(j,j)
*
* Step 2 is sometimes called the "dot product" step, since it is an
* inner product between the j-th row and the portion of the eigenvector
* that has been computed so far.
*
* The "columnwise" method consists basically in doing the sums
* for all the rows in parallel. As each v(j) is computed, the
* contribution of v(j) times the j-th column of C is added to the
* partial sums. Since FORTRAN arrays are stored columnwise, this has
* the advantage that at each step, the elements of C that are accessed
* are adjacent to one another, whereas with the rowwise method, the
* elements accessed at a step are spaced LDA (and LDB) words apart.
*
* When finding left eigenvectors, the matrix in question is the
* transpose of the one in storage, so the rowwise method then
* actually accesses columns of A and B at each step, and so is the
* preferred method.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, SAFETY
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0,
$ SAFETY = 1.0D+2 )
* ..
* .. Local Scalars ..
LOGICAL COMPL, COMPR, IL2BY2, ILABAD, ILALL, ILBACK,
$ ILBBAD, ILCOMP, ILCPLX, LSA, LSB
INTEGER I, IBEG, IEIG, IEND, IHWMNY, IINFO, IM, IN2BY2,
$ ISIDE, J, JA, JC, JE, JR, JW, NA, NW
DOUBLE PRECISION ACOEF, ACOEFA, ANORM, ASCALE, BCOEFA, BCOEFI,
$ BCOEFR, BIG, BIGNUM, BNORM, BSCALE, CIM2A,
$ CIM2B, CIMAGA, CIMAGB, CRE2A, CRE2B, CREALA,
$ CREALB, DMIN, OPSSCA, OPST, SAFMIN, SALFAR,
$ SBETA, SCALE, SMALL, TEMP, TEMP2, TEMP2I,
$ TEMP2R, ULP, XMAX, XSCALE
* ..
* .. Local Arrays ..
DOUBLE PRECISION BDIAG( 2 ), SUM( 2, 2 ), SUMA( 2, 2 ),
$ SUMB( 2, 2 )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DGEMV, DLABAD, DLACPY, DLAG2, DLALN2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
* Decode and Test the input parameters
*
IF( LSAME( HOWMNY, 'A' ) ) THEN
IHWMNY = 1
ILALL = .TRUE.
ILBACK = .FALSE.
ELSE IF( LSAME( HOWMNY, 'S' ) ) THEN
IHWMNY = 2
ILALL = .FALSE.
ILBACK = .FALSE.
ELSE IF( LSAME( HOWMNY, 'B' ) .OR. LSAME( HOWMNY, 'T' ) ) THEN
IHWMNY = 3
ILALL = .TRUE.
ILBACK = .TRUE.
ELSE
IHWMNY = -1
ILALL = .TRUE.
END IF
*
IF( LSAME( SIDE, 'R' ) ) THEN
ISIDE = 1
COMPL = .FALSE.
COMPR = .TRUE.
ELSE IF( LSAME( SIDE, 'L' ) ) THEN
ISIDE = 2
COMPL = .TRUE.
COMPR = .FALSE.
ELSE IF( LSAME( SIDE, 'B' ) ) THEN
ISIDE = 3
COMPL = .TRUE.
COMPR = .TRUE.
ELSE
ISIDE = -1
END IF
*
INFO = 0
IF( ISIDE.LT.0 ) THEN
INFO = -1
ELSE IF( IHWMNY.LT.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTGEVC', -INFO )
RETURN
END IF
*
* Count the number of eigenvectors to be computed
*
IF( .NOT.ILALL ) THEN
IM = 0
ILCPLX = .FALSE.
DO 10 J = 1, N
IF( ILCPLX ) THEN
ILCPLX = .FALSE.
GO TO 10
END IF
IF( J.LT.N ) THEN
IF( A( J+1, J ).NE.ZERO )
$ ILCPLX = .TRUE.
END IF
IF( ILCPLX ) THEN
IF( SELECT( J ) .OR. SELECT( J+1 ) )
$ IM = IM + 2
ELSE
IF( SELECT( J ) )
$ IM = IM + 1
END IF
10 CONTINUE
ELSE
IM = N
END IF
*
* Check 2-by-2 diagonal blocks of A, B
*
ILABAD = .FALSE.
ILBBAD = .FALSE.
DO 20 J = 1, N - 1
IF( A( J+1, J ).NE.ZERO ) THEN
IF( B( J, J ).EQ.ZERO .OR. B( J+1, J+1 ).EQ.ZERO .OR.
$ B( J, J+1 ).NE.ZERO )ILBBAD = .TRUE.
IF( J.LT.N-1 ) THEN
IF( A( J+2, J+1 ).NE.ZERO )
$ ILABAD = .TRUE.
END IF
END IF
20 CONTINUE
*
IF( ILABAD ) THEN
INFO = -5
ELSE IF( ILBBAD ) THEN
INFO = -7
ELSE IF( COMPL .AND. LDVL.LT.N .OR. LDVL.LT.1 ) THEN
INFO = -10
ELSE IF( COMPR .AND. LDVR.LT.N .OR. LDVR.LT.1 ) THEN
INFO = -12
ELSE IF( MM.LT.IM ) THEN
INFO = -13
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTGEVC', -INFO )
RETURN
END IF
*
* Quick return if possible
*
M = IM
IF( N.EQ.0 )
$ RETURN
*
* Machine Constants
*
SAFMIN = DLAMCH( 'Safe minimum' )
BIG = ONE / SAFMIN
CALL DLABAD( SAFMIN, BIG )
ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
SMALL = SAFMIN*N / ULP
BIG = ONE / SMALL
BIGNUM = ONE / ( SAFMIN*N )
*
* Compute the 1-norm of each column of the strictly upper triangular
* part (i.e., excluding all elements belonging to the diagonal
* blocks) of A and B to check for possible overflow in the
* triangular solver.
*
ANORM = ABS( A( 1, 1 ) )
IF( N.GT.1 )
$ ANORM = ANORM + ABS( A( 2, 1 ) )
BNORM = ABS( B( 1, 1 ) )
WORK( 1 ) = ZERO
WORK( N+1 ) = ZERO
*
DO 50 J = 2, N
TEMP = ZERO
TEMP2 = ZERO
IF( A( J, J-1 ).EQ.ZERO ) THEN
IEND = J - 1
ELSE
IEND = J - 2
END IF
DO 30 I = 1, IEND
TEMP = TEMP + ABS( A( I, J ) )
TEMP2 = TEMP2 + ABS( B( I, J ) )
30 CONTINUE
WORK( J ) = TEMP
WORK( N+J ) = TEMP2
DO 40 I = IEND + 1, MIN( J+1, N )
TEMP = TEMP + ABS( A( I, J ) )
TEMP2 = TEMP2 + ABS( B( I, J ) )
40 CONTINUE
ANORM = MAX( ANORM, TEMP )
BNORM = MAX( BNORM, TEMP2 )
50 CONTINUE
*
ASCALE = ONE / MAX( ANORM, SAFMIN )
BSCALE = ONE / MAX( BNORM, SAFMIN )
*
* ---------------------- Begin Timing Code -------------------------
OPS = OPS + DBLE( N**2+3*N+6 )
* ----------------------- End Timing Code --------------------------
*
* Left eigenvectors
*
IF( COMPL ) THEN
IEIG = 0
*
* Main loop over eigenvalues
*
ILCPLX = .FALSE.
DO 220 JE = 1, N
*
* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or
* (b) this would be the second of a complex pair.
* Check for complex eigenvalue, so as to be sure of which
* entry(-ies) of SELECT to look at.
*
IF( ILCPLX ) THEN
ILCPLX = .FALSE.
GO TO 220
END IF
NW = 1
IF( JE.LT.N ) THEN
IF( A( JE+1, JE ).NE.ZERO ) THEN
ILCPLX = .TRUE.
NW = 2
END IF
END IF
IF( ILALL ) THEN
ILCOMP = .TRUE.
ELSE IF( ILCPLX ) THEN
ILCOMP = SELECT( JE ) .OR. SELECT( JE+1 )
ELSE
ILCOMP = SELECT( JE )
END IF
IF( .NOT.ILCOMP )
$ GO TO 220
*
* Decide if (a) singular pencil, (b) real eigenvalue, or
* (c) complex eigenvalue.
*
IF( .NOT.ILCPLX ) THEN
IF( ABS( A( JE, JE ) ).LE.SAFMIN .AND.
$ ABS( B( JE, JE ) ).LE.SAFMIN ) THEN
*
* Singular matrix pencil -- returns unit eigenvector
*
IEIG = IEIG + 1
DO 60 JR = 1, N
VL( JR, IEIG ) = ZERO
60 CONTINUE
VL( IEIG, IEIG ) = ONE
GO TO 220
END IF
END IF
*
* Clear vector
*
DO 70 JR = 1, NW*N
WORK( 2*N+JR ) = ZERO
70 CONTINUE
* T
* Compute coefficients in ( a A - b B ) y = 0
* a is ACOEF
* b is BCOEFR + i*BCOEFI
*
IF( .NOT.ILCPLX ) THEN
*
* Real eigenvalue
*
TEMP = ONE / MAX( ABS( A( JE, JE ) )*ASCALE,
$ ABS( B( JE, JE ) )*BSCALE, SAFMIN )
SALFAR = ( TEMP*A( JE, JE ) )*ASCALE
SBETA = ( TEMP*B( JE, JE ) )*BSCALE
ACOEF = SBETA*ASCALE
BCOEFR = SALFAR*BSCALE
BCOEFI = ZERO
*
* Scale to avoid underflow
*
SCALE = ONE
LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEF ).LT.SMALL
LSB = ABS( SALFAR ).GE.SAFMIN .AND. ABS( BCOEFR ).LT.
$ SMALL
IF( LSA )
$ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG )
IF( LSB )
$ SCALE = MAX( SCALE, ( SMALL / ABS( SALFAR ) )*
$ MIN( BNORM, BIG ) )
IF( LSA .OR. LSB ) THEN
SCALE = MIN( SCALE, ONE /
$ ( SAFMIN*MAX( ONE, ABS( ACOEF ),
$ ABS( BCOEFR ) ) ) )
IF( LSA ) THEN
ACOEF = ASCALE*( SCALE*SBETA )
ELSE
ACOEF = SCALE*ACOEF
END IF
IF( LSB ) THEN
BCOEFR = BSCALE*( SCALE*SALFAR )
ELSE
BCOEFR = SCALE*BCOEFR
END IF
END IF
ACOEFA = ABS( ACOEF )
BCOEFA = ABS( BCOEFR )
*
* First component is 1
*
WORK( 2*N+JE ) = ONE
XMAX = ONE
ELSE
*
* Complex eigenvalue
*
CALL DLAG2( A( JE, JE ), LDA, B( JE, JE ), LDB,
$ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2,
$ BCOEFI )
BCOEFI = -BCOEFI
IF( BCOEFI.EQ.ZERO ) THEN
INFO = JE
RETURN
END IF
*
* Scale to avoid over/underflow
*
ACOEFA = ABS( ACOEF )
BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
SCALE = ONE
IF( ACOEFA*ULP.LT.SAFMIN .AND. ACOEFA.GE.SAFMIN )
$ SCALE = ( SAFMIN / ULP ) / ACOEFA
IF( BCOEFA*ULP.LT.SAFMIN .AND. BCOEFA.GE.SAFMIN )
$ SCALE = MAX( SCALE, ( SAFMIN / ULP ) / BCOEFA )
IF( SAFMIN*ACOEFA.GT.ASCALE )
$ SCALE = ASCALE / ( SAFMIN*ACOEFA )
IF( SAFMIN*BCOEFA.GT.BSCALE )
$ SCALE = MIN( SCALE, BSCALE / ( SAFMIN*BCOEFA ) )
IF( SCALE.NE.ONE ) THEN
ACOEF = SCALE*ACOEF
ACOEFA = ABS( ACOEF )
BCOEFR = SCALE*BCOEFR
BCOEFI = SCALE*BCOEFI
BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
END IF
*
* Compute first two components of eigenvector
*
TEMP = ACOEF*A( JE+1, JE )
TEMP2R = ACOEF*A( JE, JE ) - BCOEFR*B( JE, JE )
TEMP2I = -BCOEFI*B( JE, JE )
IF( ABS( TEMP ).GT.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN
WORK( 2*N+JE ) = ONE
WORK( 3*N+JE ) = ZERO
WORK( 2*N+JE+1 ) = -TEMP2R / TEMP
WORK( 3*N+JE+1 ) = -TEMP2I / TEMP
ELSE
WORK( 2*N+JE+1 ) = ONE
WORK( 3*N+JE+1 ) = ZERO
TEMP = ACOEF*A( JE, JE+1 )
WORK( 2*N+JE ) = ( BCOEFR*B( JE+1, JE+1 )-ACOEF*
$ A( JE+1, JE+1 ) ) / TEMP
WORK( 3*N+JE ) = BCOEFI*B( JE+1, JE+1 ) / TEMP
END IF
XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ),
$ ABS( WORK( 2*N+JE+1 ) )+ABS( WORK( 3*N+JE+1 ) ) )
END IF
*
DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN )
*
* T
* Triangular solve of (a A - b B) y = 0
*
* T
* (rowwise in (a A - b B) , or columnwise in (a A - b B) )
*
IL2BY2 = .FALSE.
* ------------------- Begin Timing Code ----------------------
OPST = ZERO
IN2BY2 = 0
* -------------------- End Timing Code -----------------------
*
DO 160 J = JE + NW, N
* ------------------- Begin Timing Code -------------------
OPSSCA = DBLE( NW*( J-JE )+1 )
* -------------------- End Timing Code --------------------
IF( IL2BY2 ) THEN
IL2BY2 = .FALSE.
GO TO 160
END IF
*
NA = 1
BDIAG( 1 ) = B( J, J )
IF( J.LT.N ) THEN
IF( A( J+1, J ).NE.ZERO ) THEN
IL2BY2 = .TRUE.
BDIAG( 2 ) = B( J+1, J+1 )
NA = 2
* ---------------- Begin Timing Code ----------------
IN2BY2 = IN2BY2 + 1
* ----------------- End Timing Code -----------------
END IF
END IF
*
* Check whether scaling is necessary for dot products
*
XSCALE = ONE / MAX( ONE, XMAX )
TEMP = MAX( WORK( J ), WORK( N+J ),
$ ACOEFA*WORK( J )+BCOEFA*WORK( N+J ) )
IF( IL2BY2 )
$ TEMP = MAX( TEMP, WORK( J+1 ), WORK( N+J+1 ),
$ ACOEFA*WORK( J+1 )+BCOEFA*WORK( N+J+1 ) )
IF( TEMP.GT.BIGNUM*XSCALE ) THEN
DO 90 JW = 0, NW - 1
DO 80 JR = JE, J - 1
WORK( ( JW+2 )*N+JR ) = XSCALE*
$ WORK( ( JW+2 )*N+JR )
80 CONTINUE
90 CONTINUE
XMAX = XMAX*XSCALE
* ------------------ Begin Timing Code -----------------
OPST = OPST + OPSSCA
* ------------------- End Timing Code ------------------
END IF
*
* Compute dot products
*
* j-1
* SUM = sum conjg( a*A(k,j) - b*B(k,j) )*x(k)
* k=je
*
* To reduce the op count, this is done as
*
* _ j-1 _ j-1
* a*conjg( sum A(k,j)*x(k) ) - b*conjg( sum B(k,j)*x(k) )
* k=je k=je
*
* which may cause underflow problems if A or B are close
* to underflow. (E.g., less than SMALL.)
*
*
* A series of compiler directives to defeat vectorization
* for the next loop
*
*$PL$ CMCHAR=' '
CDIR$ NEXTSCALAR
C$DIR SCALAR
CDIR$ NEXT SCALAR
CVD$L NOVECTOR
CDEC$ NOVECTOR
CVD$ NOVECTOR
*VDIR NOVECTOR
*VOCL LOOP,SCALAR
CIBM PREFER SCALAR
*$PL$ CMCHAR='*'
*
DO 120 JW = 1, NW
*
*$PL$ CMCHAR=' '
CDIR$ NEXTSCALAR
C$DIR SCALAR
CDIR$ NEXT SCALAR
CVD$L NOVECTOR
CDEC$ NOVECTOR
CVD$ NOVECTOR
*VDIR NOVECTOR
*VOCL LOOP,SCALAR
CIBM PREFER SCALAR
*$PL$ CMCHAR='*'
*
DO 110 JA = 1, NA
SUMA( JA, JW ) = ZERO
SUMB( JA, JW ) = ZERO
*
DO 100 JR = JE, J - 1
SUMA( JA, JW ) = SUMA( JA, JW ) +
$ A( JR, J+JA-1 )*
$ WORK( ( JW+1 )*N+JR )
SUMB( JA, JW ) = SUMB( JA, JW ) +
$ B( JR, J+JA-1 )*
$ WORK( ( JW+1 )*N+JR )
100 CONTINUE
110 CONTINUE
120 CONTINUE
*
*$PL$ CMCHAR=' '
CDIR$ NEXTSCALAR
C$DIR SCALAR
CDIR$ NEXT SCALAR
CVD$L NOVECTOR
CDEC$ NOVECTOR
CVD$ NOVECTOR
*VDIR NOVECTOR
*VOCL LOOP,SCALAR
CIBM PREFER SCALAR
*$PL$ CMCHAR='*'
*
DO 130 JA = 1, NA
IF( ILCPLX ) THEN
SUM( JA, 1 ) = -ACOEF*SUMA( JA, 1 ) +
$ BCOEFR*SUMB( JA, 1 ) -
$ BCOEFI*SUMB( JA, 2 )
SUM( JA, 2 ) = -ACOEF*SUMA( JA, 2 ) +
$ BCOEFR*SUMB( JA, 2 ) +
$ BCOEFI*SUMB( JA, 1 )
ELSE
SUM( JA, 1 ) = -ACOEF*SUMA( JA, 1 ) +
$ BCOEFR*SUMB( JA, 1 )
END IF
130 CONTINUE
*
* T
* Solve ( a A - b B ) y = SUM(,)
* with scaling and perturbation of the denominator
*
CALL DLALN2( .TRUE., NA, NW, DMIN, ACOEF, A( J, J ), LDA,
$ BDIAG( 1 ), BDIAG( 2 ), SUM, 2, BCOEFR,
$ BCOEFI, WORK( 2*N+J ), N, SCALE, TEMP,
$ IINFO )
IF( SCALE.LT.ONE ) THEN
DO 150 JW = 0, NW - 1
DO 140 JR = JE, J - 1
WORK( ( JW+2 )*N+JR ) = SCALE*
$ WORK( ( JW+2 )*N+JR )
140 CONTINUE
150 CONTINUE
XMAX = SCALE*XMAX
* ------------------ Begin Timing Code -----------------
OPST = OPST + OPSSCA
* ------------------- End Timing Code ------------------
END IF
XMAX = MAX( XMAX, TEMP )
160 CONTINUE
*
* Copy eigenvector to VL, back transforming if
* HOWMNY='B'.
*
IEIG = IEIG + 1
IF( ILBACK ) THEN
DO 170 JW = 0, NW - 1
CALL DGEMV( 'N', N, N+1-JE, ONE, VL( 1, JE ), LDVL,
$ WORK( ( JW+2 )*N+JE ), 1, ZERO,
$ WORK( ( JW+4 )*N+1 ), 1 )
170 CONTINUE
CALL DLACPY( ' ', N, NW, WORK( 4*N+1 ), N, VL( 1, JE ),
$ LDVL )
IBEG = 1
ELSE
CALL DLACPY( ' ', N, NW, WORK( 2*N+1 ), N, VL( 1, IEIG ),
$ LDVL )
IBEG = JE
END IF
*
* Scale eigenvector
*
XMAX = ZERO
IF( ILCPLX ) THEN
DO 180 J = IBEG, N
XMAX = MAX( XMAX, ABS( VL( J, IEIG ) )+
$ ABS( VL( J, IEIG+1 ) ) )
180 CONTINUE
ELSE
DO 190 J = IBEG, N
XMAX = MAX( XMAX, ABS( VL( J, IEIG ) ) )
190 CONTINUE
END IF
*
IF( XMAX.GT.SAFMIN ) THEN
XSCALE = ONE / XMAX
*
DO 210 JW = 0, NW - 1
DO 200 JR = IBEG, N
VL( JR, IEIG+JW ) = XSCALE*VL( JR, IEIG+JW )
200 CONTINUE
210 CONTINUE
END IF
IEIG = IEIG + NW - 1
*
* ------------------- Begin Timing Code ----------------------
* Opcounts for each eigenvector
*
* Real Complex
* Initialization 8--16 71--87
*
* Dot Prod (per iter) 4*NA*(J-JE) + 2 8*NA*(J-JE) + 2
* + 6*NA + scaling + 13*NA + scaling
* Solve (per iter) NA*(5 + 7*(NA-1)) NA*(17 + 17*(NA-1))
* + scaling + scaling
*
* Back xform 2*N*(N+1-JE) - N 4*N*(N+1-JE) - 2*N
* Scaling (w/back x.) N 3*N
* Scaling (w/o back) N - (JE-1) 3*N - 3*(JE-1)
*
IF( .NOT.ILCPLX ) THEN
OPST = OPST + DBLE( 2*( N-JE )*( N+1-JE )+13*( N-JE )+8*
$ IN2BY2+12 )
IF( ILBACK ) THEN
OPST = OPST + DBLE( 2*N*( N+1-JE ) )
ELSE
OPST = OPST + DBLE( N+1-JE )
END IF
ELSE
OPST = OPST + DBLE( 32*( N-1-JE )+4*( N-JE )*( N+1-JE )+
$ 24*IN2BY2+71 )
IF( ILBACK ) THEN
OPST = OPST + DBLE( 4*N*( N+1-JE )+N )
ELSE
OPST = OPST + DBLE( 3*( N+1-JE ) )
END IF
END IF
OPS = OPS + OPST
*
* -------------------- End Timing Code -----------------------
*
220 CONTINUE
END IF
*
* Right eigenvectors
*
IF( COMPR ) THEN
IEIG = IM + 1
*
* Main loop over eigenvalues
*
ILCPLX = .FALSE.
DO 500 JE = N, 1, -1
*
* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or
* (b) this would be the second of a complex pair.
* Check for complex eigenvalue, so as to be sure of which
* entry(-ies) of SELECT to look at -- if complex, SELECT(JE)
* or SELECT(JE-1).
* If this is a complex pair, the 2-by-2 diagonal block
* corresponding to the eigenvalue is in rows/columns JE-1:JE
*
IF( ILCPLX ) THEN
ILCPLX = .FALSE.
GO TO 500
END IF
NW = 1
IF( JE.GT.1 ) THEN
IF( A( JE, JE-1 ).NE.ZERO ) THEN
ILCPLX = .TRUE.
NW = 2
END IF
END IF
IF( ILALL ) THEN
ILCOMP = .TRUE.
ELSE IF( ILCPLX ) THEN
ILCOMP = SELECT( JE ) .OR. SELECT( JE-1 )
ELSE
ILCOMP = SELECT( JE )
END IF
IF( .NOT.ILCOMP )
$ GO TO 500
*
* Decide if (a) singular pencil, (b) real eigenvalue, or
* (c) complex eigenvalue.
*
IF( .NOT.ILCPLX ) THEN
IF( ABS( A( JE, JE ) ).LE.SAFMIN .AND.
$ ABS( B( JE, JE ) ).LE.SAFMIN ) THEN
*
* Singular matrix pencil -- returns unit eigenvector
*
IEIG = IEIG - 1
DO 230 JR = 1, N
VR( JR, IEIG ) = ZERO
230 CONTINUE
VR( IEIG, IEIG ) = ONE
GO TO 500
END IF
END IF
*
* Clear vector
*
DO 250 JW = 0, NW - 1
DO 240 JR = 1, N
WORK( ( JW+2 )*N+JR ) = ZERO
240 CONTINUE
250 CONTINUE
*
* Compute coefficients in ( a A - b B ) x = 0
* a is ACOEF
* b is BCOEFR + i*BCOEFI
*
IF( .NOT.ILCPLX ) THEN
*
* Real eigenvalue
*
TEMP = ONE / MAX( ABS( A( JE, JE ) )*ASCALE,
$ ABS( B( JE, JE ) )*BSCALE, SAFMIN )
SALFAR = ( TEMP*A( JE, JE ) )*ASCALE
SBETA = ( TEMP*B( JE, JE ) )*BSCALE
ACOEF = SBETA*ASCALE
BCOEFR = SALFAR*BSCALE
BCOEFI = ZERO
*
* Scale to avoid underflow
*
SCALE = ONE
LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEF ).LT.SMALL
LSB = ABS( SALFAR ).GE.SAFMIN .AND. ABS( BCOEFR ).LT.
$ SMALL
IF( LSA )
$ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG )
IF( LSB )
$ SCALE = MAX( SCALE, ( SMALL / ABS( SALFAR ) )*
$ MIN( BNORM, BIG ) )
IF( LSA .OR. LSB ) THEN
SCALE = MIN( SCALE, ONE /
$ ( SAFMIN*MAX( ONE, ABS( ACOEF ),
$ ABS( BCOEFR ) ) ) )
IF( LSA ) THEN
ACOEF = ASCALE*( SCALE*SBETA )
ELSE
ACOEF = SCALE*ACOEF
END IF
IF( LSB ) THEN
BCOEFR = BSCALE*( SCALE*SALFAR )
ELSE
BCOEFR = SCALE*BCOEFR
END IF
END IF
ACOEFA = ABS( ACOEF )
BCOEFA = ABS( BCOEFR )
*
* First component is 1
*
WORK( 2*N+JE ) = ONE
XMAX = ONE
*
* Compute contribution from column JE of A and B to sum
* (See "Further Details", above.)
*
DO 260 JR = 1, JE - 1
WORK( 2*N+JR ) = BCOEFR*B( JR, JE ) -
$ ACOEF*A( JR, JE )
260 CONTINUE
ELSE
*
* Complex eigenvalue
*
CALL DLAG2( A( JE-1, JE-1 ), LDA, B( JE-1, JE-1 ), LDB,
$ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2,
$ BCOEFI )
IF( BCOEFI.EQ.ZERO ) THEN
INFO = JE - 1
RETURN
END IF
*
* Scale to avoid over/underflow
*
ACOEFA = ABS( ACOEF )
BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
SCALE = ONE
IF( ACOEFA*ULP.LT.SAFMIN .AND. ACOEFA.GE.SAFMIN )
$ SCALE = ( SAFMIN / ULP ) / ACOEFA
IF( BCOEFA*ULP.LT.SAFMIN .AND. BCOEFA.GE.SAFMIN )
$ SCALE = MAX( SCALE, ( SAFMIN / ULP ) / BCOEFA )
IF( SAFMIN*ACOEFA.GT.ASCALE )
$ SCALE = ASCALE / ( SAFMIN*ACOEFA )
IF( SAFMIN*BCOEFA.GT.BSCALE )
$ SCALE = MIN( SCALE, BSCALE / ( SAFMIN*BCOEFA ) )
IF( SCALE.NE.ONE ) THEN
ACOEF = SCALE*ACOEF
ACOEFA = ABS( ACOEF )
BCOEFR = SCALE*BCOEFR
BCOEFI = SCALE*BCOEFI
BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
END IF
*
* Compute first two components of eigenvector
* and contribution to sums
*
TEMP = ACOEF*A( JE, JE-1 )
TEMP2R = ACOEF*A( JE, JE ) - BCOEFR*B( JE, JE )
TEMP2I = -BCOEFI*B( JE, JE )
IF( ABS( TEMP ).GE.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN
WORK( 2*N+JE ) = ONE
WORK( 3*N+JE ) = ZERO
WORK( 2*N+JE-1 ) = -TEMP2R / TEMP
WORK( 3*N+JE-1 ) = -TEMP2I / TEMP
ELSE
WORK( 2*N+JE-1 ) = ONE
WORK( 3*N+JE-1 ) = ZERO
TEMP = ACOEF*A( JE-1, JE )
WORK( 2*N+JE ) = ( BCOEFR*B( JE-1, JE-1 )-ACOEF*
$ A( JE-1, JE-1 ) ) / TEMP
WORK( 3*N+JE ) = BCOEFI*B( JE-1, JE-1 ) / TEMP
END IF
*
XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ),
$ ABS( WORK( 2*N+JE-1 ) )+ABS( WORK( 3*N+JE-1 ) ) )
*
* Compute contribution from columns JE and JE-1
* of A and B to the sums.
*
CREALA = ACOEF*WORK( 2*N+JE-1 )
CIMAGA = ACOEF*WORK( 3*N+JE-1 )
CREALB = BCOEFR*WORK( 2*N+JE-1 ) -
$ BCOEFI*WORK( 3*N+JE-1 )
CIMAGB = BCOEFI*WORK( 2*N+JE-1 ) +
$ BCOEFR*WORK( 3*N+JE-1 )
CRE2A = ACOEF*WORK( 2*N+JE )
CIM2A = ACOEF*WORK( 3*N+JE )
CRE2B = BCOEFR*WORK( 2*N+JE ) - BCOEFI*WORK( 3*N+JE )
CIM2B = BCOEFI*WORK( 2*N+JE ) + BCOEFR*WORK( 3*N+JE )
DO 270 JR = 1, JE - 2
WORK( 2*N+JR ) = -CREALA*A( JR, JE-1 ) +
$ CREALB*B( JR, JE-1 ) -
$ CRE2A*A( JR, JE ) + CRE2B*B( JR, JE )
WORK( 3*N+JR ) = -CIMAGA*A( JR, JE-1 ) +
$ CIMAGB*B( JR, JE-1 ) -
$ CIM2A*A( JR, JE ) + CIM2B*B( JR, JE )
270 CONTINUE
END IF
*
DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN )
*
* Columnwise triangular solve of (a A - b B) x = 0
*
IL2BY2 = .FALSE.
* ------------------- Begin Timing Code ----------------------
OPST = ZERO
IN2BY2 = 0
* -------------------- End Timing Code -----------------------
DO 370 J = JE - NW, 1, -1
* ------------------- Begin Timing Code -------------------
OPSSCA = DBLE( NW*JE+1 )
* -------------------- End Timing Code --------------------
*
* If a 2-by-2 block, is in position j-1:j, wait until
* next iteration to process it (when it will be j:j+1)
*
IF( .NOT.IL2BY2 .AND. J.GT.1 ) THEN
IF( A( J, J-1 ).NE.ZERO ) THEN
IL2BY2 = .TRUE.
* -------------- Begin Timing Code -----------------
IN2BY2 = IN2BY2 + 1
* --------------- End Timing Code -------------------
GO TO 370
END IF
END IF
BDIAG( 1 ) = B( J, J )
IF( IL2BY2 ) THEN
NA = 2
BDIAG( 2 ) = B( J+1, J+1 )
ELSE
NA = 1
END IF
*
* Compute x(j) (and x(j+1), if 2-by-2 block)
*
CALL DLALN2( .FALSE., NA, NW, DMIN, ACOEF, A( J, J ),
$ LDA, BDIAG( 1 ), BDIAG( 2 ), WORK( 2*N+J ),
$ N, BCOEFR, BCOEFI, SUM, 2, SCALE, TEMP,
$ IINFO )
IF( SCALE.LT.ONE ) THEN
*
DO 290 JW = 0, NW - 1
DO 280 JR = 1, JE
WORK( ( JW+2 )*N+JR ) = SCALE*
$ WORK( ( JW+2 )*N+JR )
280 CONTINUE
290 CONTINUE
END IF
XMAX = MAX( SCALE*XMAX, TEMP )
* ------------------ Begin Timing Code -----------------
OPST = OPST + OPSSCA
* ------------------- End Timing Code ------------------
*
DO 310 JW = 1, NW
DO 300 JA = 1, NA
WORK( ( JW+1 )*N+J+JA-1 ) = SUM( JA, JW )
300 CONTINUE
310 CONTINUE
*
* w = w + x(j)*(a A(*,j) - b B(*,j) ) with scaling
*
IF( J.GT.1 ) THEN
*
* Check whether scaling is necessary for sum.
*
XSCALE = ONE / MAX( ONE, XMAX )
TEMP = ACOEFA*WORK( J ) + BCOEFA*WORK( N+J )
IF( IL2BY2 )
$ TEMP = MAX( TEMP, ACOEFA*WORK( J+1 )+BCOEFA*
$ WORK( N+J+1 ) )
TEMP = MAX( TEMP, ACOEFA, BCOEFA )
IF( TEMP.GT.BIGNUM*XSCALE ) THEN
*
DO 330 JW = 0, NW - 1
DO 320 JR = 1, JE
WORK( ( JW+2 )*N+JR ) = XSCALE*
$ WORK( ( JW+2 )*N+JR )
320 CONTINUE
330 CONTINUE
XMAX = XMAX*XSCALE
* ----------------- Begin Timing Code ---------------
OPST = OPST + OPSSCA
* ------------------ End Timing Code ----------------
END IF
*
* Compute the contributions of the off-diagonals of
* column j (and j+1, if 2-by-2 block) of A and B to the
* sums.
*
*
DO 360 JA = 1, NA
IF( ILCPLX ) THEN
CREALA = ACOEF*WORK( 2*N+J+JA-1 )
CIMAGA = ACOEF*WORK( 3*N+J+JA-1 )
CREALB = BCOEFR*WORK( 2*N+J+JA-1 ) -
$ BCOEFI*WORK( 3*N+J+JA-1 )
CIMAGB = BCOEFI*WORK( 2*N+J+JA-1 ) +
$ BCOEFR*WORK( 3*N+J+JA-1 )
DO 340 JR = 1, J - 1
WORK( 2*N+JR ) = WORK( 2*N+JR ) -
$ CREALA*A( JR, J+JA-1 ) +
$ CREALB*B( JR, J+JA-1 )
WORK( 3*N+JR ) = WORK( 3*N+JR ) -
$ CIMAGA*A( JR, J+JA-1 ) +
$ CIMAGB*B( JR, J+JA-1 )
340 CONTINUE
ELSE
CREALA = ACOEF*WORK( 2*N+J+JA-1 )
CREALB = BCOEFR*WORK( 2*N+J+JA-1 )
DO 350 JR = 1, J - 1
WORK( 2*N+JR ) = WORK( 2*N+JR ) -
$ CREALA*A( JR, J+JA-1 ) +
$ CREALB*B( JR, J+JA-1 )
350 CONTINUE
END IF
360 CONTINUE
END IF
*
IL2BY2 = .FALSE.
370 CONTINUE
*
* Copy eigenvector to VR, back transforming if
* HOWMNY='B'.
*
IEIG = IEIG - NW
IF( ILBACK ) THEN
*
DO 410 JW = 0, NW - 1
DO 380 JR = 1, N
WORK( ( JW+4 )*N+JR ) = WORK( ( JW+2 )*N+1 )*
$ VR( JR, 1 )
380 CONTINUE
*
* A series of compiler directives to defeat
* vectorization for the next loop
*
*
DO 400 JC = 2, JE
DO 390 JR = 1, N
WORK( ( JW+4 )*N+JR ) = WORK( ( JW+4 )*N+JR ) +
$ WORK( ( JW+2 )*N+JC )*VR( JR, JC )
390 CONTINUE
400 CONTINUE
410 CONTINUE
*
DO 430 JW = 0, NW - 1
DO 420 JR = 1, N
VR( JR, IEIG+JW ) = WORK( ( JW+4 )*N+JR )
420 CONTINUE
430 CONTINUE
*
IEND = N
ELSE
DO 450 JW = 0, NW - 1
DO 440 JR = 1, N
VR( JR, IEIG+JW ) = WORK( ( JW+2 )*N+JR )
440 CONTINUE
450 CONTINUE
*
IEND = JE
END IF
*
* Scale eigenvector
*
XMAX = ZERO
IF( ILCPLX ) THEN
DO 460 J = 1, IEND
XMAX = MAX( XMAX, ABS( VR( J, IEIG ) )+
$ ABS( VR( J, IEIG+1 ) ) )
460 CONTINUE
ELSE
DO 470 J = 1, IEND
XMAX = MAX( XMAX, ABS( VR( J, IEIG ) ) )
470 CONTINUE
END IF
*
IF( XMAX.GT.SAFMIN ) THEN
XSCALE = ONE / XMAX
DO 490 JW = 0, NW - 1
DO 480 JR = 1, IEND
VR( JR, IEIG+JW ) = XSCALE*VR( JR, IEIG+JW )
480 CONTINUE
490 CONTINUE
END IF
*
* ------------------- Begin Timing Code ----------------------
* Opcounts for each eigenvector
*
* Real Complex
* Initialization 8--16 + 3*(JE-1) 71--87+16+14*(JE-2)
*
* Solve (per iter) NA*(5 + 7*(NA-1)) NA*(17 + 17*(NA-1))
* + scaling + scaling
* column add (per iter)
* 2 + 5*NA 2 + 11*NA
* + 4*NA*(J-1) + 8*NA*(J-1)
* + scaling + scaling
* iteration: J=JE-1,...,1 J=JE-2,...,1
*
* Back xform 2*N*JE - N 4*N*JE - 2*N
* Scaling (w/back x.) N 3*N
* Scaling (w/o back) JE 3*JE
*
IF( .NOT.ILCPLX ) THEN
OPST = OPST + DBLE( ( 2*JE+11 )*( JE-1 )+12+8*IN2BY2 )
IF( ILBACK ) THEN
OPST = OPST + DBLE( 2*N*JE )
ELSE
OPST = OPST + DBLE( JE )
END IF
ELSE
OPST = OPST + DBLE( ( 4*JE+32 )*( JE-2 )+95+24*IN2BY2 )
IF( ILBACK ) THEN
OPST = OPST + DBLE( 4*N*JE+N )
ELSE
OPST = OPST + DBLE( 3*JE )
END IF
END IF
OPS = OPS + OPST
*
* -------------------- End Timing Code -----------------------
*
500 CONTINUE
END IF
*
RETURN
*
* End of DTGEVC
*
END
SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
$ LDVR, MM, M, WORK, INFO )
*
* -- LAPACK routine (instrumented to count operations, version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER HOWMNY, SIDE
INTEGER INFO, LDT, LDVL, LDVR, M, MM, N
* ..
* .. Array Arguments ..
LOGICAL SELECT( * )
DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
$ WORK( * )
* ..
* Common block to return operation count.
* OPS is only incremented, OPST is used to accumulate small
* contributions to OPS to avoid roundoff error
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
*
* Purpose
* =======
*
* DTREVC computes some or all of the right and/or left eigenvectors of
* a real upper quasi-triangular matrix T.
*
* The right eigenvector x and the left eigenvector y of T corresponding
* to an eigenvalue w are defined by:
*
* T*x = w*x, y'*T = w*y'
*
* where y' denotes the conjugate transpose of the vector y.
*
* If all eigenvectors are requested, the routine may either return the
* matrices X and/or Y of right or left eigenvectors of T, or the
* products Q*X and/or Q*Y, where Q is an input orthogonal
* matrix. If T was obtained from the real-Schur factorization of an
* original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of
* right or left eigenvectors of A.
*
* T must be in Schur canonical form (as returned by DHSEQR), that is,
* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
* 2-by-2 diagonal block has its diagonal elements equal and its
* off-diagonal elements of opposite sign. Corresponding to each 2-by-2
* diagonal block is a complex conjugate pair of eigenvalues and
* eigenvectors; only one eigenvector of the pair is computed, namely
* the one corresponding to the eigenvalue with positive imaginary part.
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* = 'R': compute right eigenvectors only;
* = 'L': compute left eigenvectors only;
* = 'B': compute both right and left eigenvectors.
*
* HOWMNY (input) CHARACTER*1
* = 'A': compute all right and/or left eigenvectors;
* = 'B': compute all right and/or left eigenvectors,
* and backtransform them using the input matrices
* supplied in VR and/or VL;
* = 'S': compute selected right and/or left eigenvectors,
* specified by the logical array SELECT.
*
* SELECT (input/output) LOGICAL array, dimension (N)
* If HOWMNY = 'S', SELECT specifies the eigenvectors to be
* computed.
* If HOWMNY = 'A' or 'B', SELECT is not referenced.
* To select the real eigenvector corresponding to a real
* eigenvalue w(j), SELECT(j) must be set to .TRUE.. To select
* the complex eigenvector corresponding to a complex conjugate
* pair w(j) and w(j+1), either SELECT(j) or SELECT(j+1) must be
* set to .TRUE.; then on exit SELECT(j) is .TRUE. and
* SELECT(j+1) is .FALSE..
*
* N (input) INTEGER
* The order of the matrix T. N >= 0.
*
* T (input) DOUBLE PRECISION array, dimension (LDT,N)
* The upper quasi-triangular matrix T in Schur canonical form.
*
* LDT (input) INTEGER
* The leading dimension of the array T. LDT >= max(1,N).
*
* VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)
* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
* contain an N-by-N matrix Q (usually the orthogonal matrix Q
* of Schur vectors returned by DHSEQR).
* On exit, if SIDE = 'L' or 'B', VL contains:
* if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
* VL has the same quasi-lower triangular form
* as T'. If T(i,i) is a real eigenvalue, then
* the i-th column VL(i) of VL is its
* corresponding eigenvector. If T(i:i+1,i:i+1)
* is a 2-by-2 block whose eigenvalues are
* complex-conjugate eigenvalues of T, then
* VL(i)+sqrt(-1)*VL(i+1) is the complex
* eigenvector corresponding to the eigenvalue
* with positive real part.
* if HOWMNY = 'B', the matrix Q*Y;
* if HOWMNY = 'S', the left eigenvectors of T specified by
* SELECT, stored consecutively in the columns
* of VL, in the same order as their
* eigenvalues.
* A complex eigenvector corresponding to a complex eigenvalue
* is stored in two consecutive columns, the first holding the
* real part, and the second the imaginary part.
* If SIDE = 'R', VL is not referenced.
*
* LDVL (input) INTEGER
* The leading dimension of the array VL. LDVL >= max(1,N) if
* SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
*
* VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)
* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
* contain an N-by-N matrix Q (usually the orthogonal matrix Q
* of Schur vectors returned by DHSEQR).
* On exit, if SIDE = 'R' or 'B', VR contains:
* if HOWMNY = 'A', the matrix X of right eigenvectors of T;
* VR has the same quasi-upper triangular form
* as T. If T(i,i) is a real eigenvalue, then
* the i-th column VR(i) of VR is its
* corresponding eigenvector. If T(i:i+1,i:i+1)
* is a 2-by-2 block whose eigenvalues are
* complex-conjugate eigenvalues of T, then
* VR(i)+sqrt(-1)*VR(i+1) is the complex
* eigenvector corresponding to the eigenvalue
* with positive real part.
* if HOWMNY = 'B', the matrix Q*X;
* if HOWMNY = 'S', the right eigenvectors of T specified by
* SELECT, stored consecutively in the columns
* of VR, in the same order as their
* eigenvalues.
* A complex eigenvector corresponding to a complex eigenvalue
* is stored in two consecutive columns, the first holding the
* real part and the second the imaginary part.
* If SIDE = 'L', VR is not referenced.
*
* LDVR (input) INTEGER
* The leading dimension of the array VR. LDVR >= max(1,N) if
* SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
*
* MM (input) INTEGER
* The number of columns in the arrays VL and/or VR. MM >= M.
*
* M (output) INTEGER
* The number of columns in the arrays VL and/or VR actually
* used to store the eigenvectors.
* If HOWMNY = 'A' or 'B', M is set to N.
* Each selected real eigenvector occupies one column and each
* selected complex eigenvector occupies two columns.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Further Details
* ===============
*
* The algorithm used in this program is basically backward (forward)
* substitution, with scaling to make the the code robust against
* possible overflow.
*
* Each eigenvector is normalized so that the element of largest
* magnitude has magnitude 1; here the magnitude of a complex number
* (x,y) is taken to be |x| + |y|.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL ALLV, BOTHV, LEFTV, OVER, PAIR, RIGHTV, SOMEV
INTEGER I, IERR, II, IP, IS, J, J1, J2, JNXT, K, KI, N2
DOUBLE PRECISION BETA, BIGNUM, EMAX, OPST, OVFL, REC, REMAX,
$ SCALE, SMIN, SMLNUM, ULP, UNFL, VCRIT, VMAX,
$ WI, WR, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DDOT, DLAMCH
EXTERNAL LSAME, IDAMAX, DDOT, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DGEMV, DLABAD, DLALN2, DSCAL,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Local Arrays ..
DOUBLE PRECISION X( 2, 2 )
* ..
* .. Executable Statements ..
*
* Decode and test the input parameters
*
BOTHV = LSAME( SIDE, 'B' )
RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV
LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV
*
ALLV = LSAME( HOWMNY, 'A' )
OVER = LSAME( HOWMNY, 'B' )
SOMEV = LSAME( HOWMNY, 'S' )
*
INFO = 0
IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
INFO = -1
ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN
INFO = -8
ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN
INFO = -10
ELSE
*
* Set M to the number of columns required to store the selected
* eigenvectors, standardize the array SELECT if necessary, and
* test MM.
*
IF( SOMEV ) THEN
M = 0
PAIR = .FALSE.
DO 10 J = 1, N
IF( PAIR ) THEN
PAIR = .FALSE.
SELECT( J ) = .FALSE.
ELSE
IF( J.LT.N ) THEN
IF( T( J+1, J ).EQ.ZERO ) THEN
IF( SELECT( J ) )
$ M = M + 1
ELSE
PAIR = .TRUE.
IF( SELECT( J ) .OR. SELECT( J+1 ) ) THEN
SELECT( J ) = .TRUE.
M = M + 2
END IF
END IF
ELSE
IF( SELECT( N ) )
$ M = M + 1
END IF
END IF
10 CONTINUE
ELSE
M = N
END IF
*
IF( MM.LT.M ) THEN
INFO = -11
END IF
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTREVC', -INFO )
RETURN
END IF
*
* Quick return if possible.
*
IF( N.EQ.0 )
$ RETURN
***
* Initialize
OPST = 0
***
*
* Set the constants to control overflow.
*
UNFL = DLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
CALL DLABAD( UNFL, OVFL )
ULP = DLAMCH( 'Precision' )
SMLNUM = UNFL*( N / ULP )
BIGNUM = ( ONE-ULP ) / SMLNUM
*
* Compute 1-norm of each column of strictly upper triangular
* part of T to control overflow in triangular solver.
*
WORK( 1 ) = ZERO
DO 30 J = 2, N
WORK( J ) = ZERO
DO 20 I = 1, J - 1
WORK( J ) = WORK( J ) + ABS( T( I, J ) )
20 CONTINUE
30 CONTINUE
***
OPS = OPS + N*( N-1 ) / 2
***
*
* Index IP is used to specify the real or complex eigenvalue:
* IP = 0, real eigenvalue,
* 1, first of conjugate complex pair: (wr,wi)
* -1, second of conjugate complex pair: (wr,wi)
*
N2 = 2*N
*
IF( RIGHTV ) THEN
*
* Compute right eigenvectors.
*
IP = 0
IS = M
DO 140 KI = N, 1, -1
*
IF( IP.EQ.1 )
$ GO TO 130
IF( KI.EQ.1 )
$ GO TO 40
IF( T( KI, KI-1 ).EQ.ZERO )
$ GO TO 40
IP = -1
*
40 CONTINUE
IF( SOMEV ) THEN
IF( IP.EQ.0 ) THEN
IF( .NOT.SELECT( KI ) )
$ GO TO 130
ELSE
IF( .NOT.SELECT( KI-1 ) )
$ GO TO 130
END IF
END IF
*
* Compute the KI-th eigenvalue (WR,WI).
*
WR = T( KI, KI )
WI = ZERO
IF( IP.NE.0 )
$ WI = SQRT( ABS( T( KI, KI-1 ) ) )*
$ SQRT( ABS( T( KI-1, KI ) ) )
SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM )
*
IF( IP.EQ.0 ) THEN
*
* Real right eigenvector
*
WORK( KI+N ) = ONE
*
* Form right-hand side
*
DO 50 K = 1, KI - 1
WORK( K+N ) = -T( K, KI )
50 CONTINUE
*
* Solve the upper quasi-triangular system:
* (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK.
*
JNXT = KI - 1
DO 60 J = KI - 1, 1, -1
IF( J.GT.JNXT )
$ GO TO 60
J1 = J
J2 = J
JNXT = J - 1
IF( J.GT.1 ) THEN
IF( T( J, J-1 ).NE.ZERO ) THEN
J1 = J - 1
JNXT = J - 2
END IF
END IF
*
IF( J1.EQ.J2 ) THEN
*
* 1-by-1 diagonal block
*
CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ),
$ LDT, ONE, ONE, WORK( J+N ), N, WR,
$ ZERO, X, 2, SCALE, XNORM, IERR )
*
* Scale X(1,1) to avoid overflow when updating
* the right-hand side.
*
IF( XNORM.GT.ONE ) THEN
IF( WORK( J ).GT.BIGNUM / XNORM ) THEN
X( 1, 1 ) = X( 1, 1 ) / XNORM
SCALE = SCALE / XNORM
END IF
END IF
*
* Scale if necessary
*
IF( SCALE.NE.ONE )
$ CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 )
WORK( J+N ) = X( 1, 1 )
*
* Update right-hand side
*
CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1,
$ WORK( 1+N ), 1 )
***
* Increment op count, ignoring the possible scaling
OPST = OPST + ( 2*( J-1 )+6 )
***
*
ELSE
*
* 2-by-2 diagonal block
*
CALL DLALN2( .FALSE., 2, 1, SMIN, ONE,
$ T( J-1, J-1 ), LDT, ONE, ONE,
$ WORK( J-1+N ), N, WR, ZERO, X, 2,
$ SCALE, XNORM, IERR )
*
* Scale X(1,1) and X(2,1) to avoid overflow when
* updating the right-hand side.
*
IF( XNORM.GT.ONE ) THEN
BETA = MAX( WORK( J-1 ), WORK( J ) )
IF( BETA.GT.BIGNUM / XNORM ) THEN
X( 1, 1 ) = X( 1, 1 ) / XNORM
X( 2, 1 ) = X( 2, 1 ) / XNORM
SCALE = SCALE / XNORM
END IF
END IF
*
* Scale if necessary
*
IF( SCALE.NE.ONE )
$ CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 )
WORK( J-1+N ) = X( 1, 1 )
WORK( J+N ) = X( 2, 1 )
*
* Update right-hand side
*
CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1,
$ WORK( 1+N ), 1 )
CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1,
$ WORK( 1+N ), 1 )
***
* Increment op count, ignoring the possible scaling
OPST = OPST + ( 4*( J-2 )+24 )
***
END IF
60 CONTINUE
*
* Copy the vector x or Q*x to VR and normalize.
*
IF( .NOT.OVER ) THEN
CALL DCOPY( KI, WORK( 1+N ), 1, VR( 1, IS ), 1 )
*
II = IDAMAX( KI, VR( 1, IS ), 1 )
REMAX = ONE / ABS( VR( II, IS ) )
CALL DSCAL( KI, REMAX, VR( 1, IS ), 1 )
***
OPST = OPST + ( 2*KI+1 )
***
*
DO 70 K = KI + 1, N
VR( K, IS ) = ZERO
70 CONTINUE
ELSE
IF( KI.GT.1 )
$ CALL DGEMV( 'N', N, KI-1, ONE, VR, LDVR,
$ WORK( 1+N ), 1, WORK( KI+N ),
$ VR( 1, KI ), 1 )
*
II = IDAMAX( N, VR( 1, KI ), 1 )
REMAX = ONE / ABS( VR( II, KI ) )
CALL DSCAL( N, REMAX, VR( 1, KI ), 1 )
***
OPS = OPS + ( 2*N*KI+1 )
***
END IF
*
ELSE
*
* Complex right eigenvector.
*
* Initial solve
* [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]*X = 0.
* [ (T(KI,KI-1) T(KI,KI) ) ]
*
IF( ABS( T( KI-1, KI ) ).GE.ABS( T( KI, KI-1 ) ) ) THEN
WORK( KI-1+N ) = ONE
WORK( KI+N2 ) = WI / T( KI-1, KI )
ELSE
WORK( KI-1+N ) = -WI / T( KI, KI-1 )
WORK( KI+N2 ) = ONE
END IF
WORK( KI+N ) = ZERO
WORK( KI-1+N2 ) = ZERO
*
* Form right-hand side
*
DO 80 K = 1, KI - 2
WORK( K+N ) = -WORK( KI-1+N )*T( K, KI-1 )
WORK( K+N2 ) = -WORK( KI+N2 )*T( K, KI )
80 CONTINUE
***
OPST = OPST + 2*( KI-2 )
***
*
* Solve upper quasi-triangular system:
* (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2)
*
JNXT = KI - 2
DO 90 J = KI - 2, 1, -1
IF( J.GT.JNXT )
$ GO TO 90
J1 = J
J2 = J
JNXT = J - 1
IF( J.GT.1 ) THEN
IF( T( J, J-1 ).NE.ZERO ) THEN
J1 = J - 1
JNXT = J - 2
END IF
END IF
*
IF( J1.EQ.J2 ) THEN
*
* 1-by-1 diagonal block
*
CALL DLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ),
$ LDT, ONE, ONE, WORK( J+N ), N, WR, WI,
$ X, 2, SCALE, XNORM, IERR )
*
* Scale X(1,1) and X(1,2) to avoid overflow when
* updating the right-hand side.
*
IF( XNORM.GT.ONE ) THEN
IF( WORK( J ).GT.BIGNUM / XNORM ) THEN
X( 1, 1 ) = X( 1, 1 ) / XNORM
X( 1, 2 ) = X( 1, 2 ) / XNORM
SCALE = SCALE / XNORM
END IF
END IF
*
* Scale if necessary
*
IF( SCALE.NE.ONE ) THEN
CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 )
CALL DSCAL( KI, SCALE, WORK( 1+N2 ), 1 )
END IF
WORK( J+N ) = X( 1, 1 )
WORK( J+N2 ) = X( 1, 2 )
*
* Update the right-hand side
*
CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1,
$ WORK( 1+N ), 1 )
CALL DAXPY( J-1, -X( 1, 2 ), T( 1, J ), 1,
$ WORK( 1+N2 ), 1 )
***
* Increment op count, ignoring the possible scaling
OPST = OPST + ( 4*( J-1 )+24 )
***
*
ELSE
*
* 2-by-2 diagonal block
*
CALL DLALN2( .FALSE., 2, 2, SMIN, ONE,
$ T( J-1, J-1 ), LDT, ONE, ONE,
$ WORK( J-1+N ), N, WR, WI, X, 2, SCALE,
$ XNORM, IERR )
*
* Scale X to avoid overflow when updating
* the right-hand side.
*
IF( XNORM.GT.ONE ) THEN
BETA = MAX( WORK( J-1 ), WORK( J ) )
IF( BETA.GT.BIGNUM / XNORM ) THEN
REC = ONE / XNORM
X( 1, 1 ) = X( 1, 1 )*REC
X( 1, 2 ) = X( 1, 2 )*REC
X( 2, 1 ) = X( 2, 1 )*REC
X( 2, 2 ) = X( 2, 2 )*REC
SCALE = SCALE*REC
END IF
END IF
*
* Scale if necessary
*
IF( SCALE.NE.ONE ) THEN
CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 )
CALL DSCAL( KI, SCALE, WORK( 1+N2 ), 1 )
END IF
WORK( J-1+N ) = X( 1, 1 )
WORK( J+N ) = X( 2, 1 )
WORK( J-1+N2 ) = X( 1, 2 )
WORK( J+N2 ) = X( 2, 2 )
*
* Update the right-hand side
*
CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1,
$ WORK( 1+N ), 1 )
CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1,
$ WORK( 1+N ), 1 )
CALL DAXPY( J-2, -X( 1, 2 ), T( 1, J-1 ), 1,
$ WORK( 1+N2 ), 1 )
CALL DAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1,
$ WORK( 1+N2 ), 1 )
***
* Increment op count, ignoring the possible scaling
OPST = OPST + ( 8*( J-2 )+64 )
***
END IF
90 CONTINUE
*
* Copy the vector x or Q*x to VR and normalize.
*
IF( .NOT.OVER ) THEN
CALL DCOPY( KI, WORK( 1+N ), 1, VR( 1, IS-1 ), 1 )
CALL DCOPY( KI, WORK( 1+N2 ), 1, VR( 1, IS ), 1 )
*
EMAX = ZERO
DO 100 K = 1, KI
EMAX = MAX( EMAX, ABS( VR( K, IS-1 ) )+
$ ABS( VR( K, IS ) ) )
100 CONTINUE
*
REMAX = ONE / EMAX
CALL DSCAL( KI, REMAX, VR( 1, IS-1 ), 1 )
CALL DSCAL( KI, REMAX, VR( 1, IS ), 1 )
***
OPST = OPST + ( 4*KI+1 )
***
*
DO 110 K = KI + 1, N
VR( K, IS-1 ) = ZERO
VR( K, IS ) = ZERO
110 CONTINUE
*
ELSE
*
IF( KI.GT.2 ) THEN
CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR,
$ WORK( 1+N ), 1, WORK( KI-1+N ),
$ VR( 1, KI-1 ), 1 )
CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR,
$ WORK( 1+N2 ), 1, WORK( KI+N2 ),
$ VR( 1, KI ), 1 )
ELSE
CALL DSCAL( N, WORK( KI-1+N ), VR( 1, KI-1 ), 1 )
CALL DSCAL( N, WORK( KI+N2 ), VR( 1, KI ), 1 )
END IF
*
EMAX = ZERO
DO 120 K = 1, N
EMAX = MAX( EMAX, ABS( VR( K, KI-1 ) )+
$ ABS( VR( K, KI ) ) )
120 CONTINUE
REMAX = ONE / EMAX
CALL DSCAL( N, REMAX, VR( 1, KI-1 ), 1 )
CALL DSCAL( N, REMAX, VR( 1, KI ), 1 )
***
OPS = OPS + ( 4*N*( KI-2 )+6*N+1 )
***
END IF
END IF
*
IS = IS - 1
IF( IP.NE.0 )
$ IS = IS - 1
130 CONTINUE
IF( IP.EQ.1 )
$ IP = 0
IF( IP.EQ.-1 )
$ IP = 1
140 CONTINUE
END IF
*
IF( LEFTV ) THEN
*
* Compute left eigenvectors.
*
IP = 0
IS = 1
DO 260 KI = 1, N
*
IF( IP.EQ.-1 )
$ GO TO 250
IF( KI.EQ.N )
$ GO TO 150
IF( T( KI+1, KI ).EQ.ZERO )
$ GO TO 150
IP = 1
*
150 CONTINUE
IF( SOMEV ) THEN
IF( .NOT.SELECT( KI ) )
$ GO TO 250
END IF
*
* Compute the KI-th eigenvalue (WR,WI).
*
WR = T( KI, KI )
WI = ZERO
IF( IP.NE.0 )
$ WI = SQRT( ABS( T( KI, KI+1 ) ) )*
$ SQRT( ABS( T( KI+1, KI ) ) )
SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM )
*
IF( IP.EQ.0 ) THEN
*
* Real left eigenvector.
*
WORK( KI+N ) = ONE
*
* Form right-hand side
*
DO 160 K = KI + 1, N
WORK( K+N ) = -T( KI, K )
160 CONTINUE
*
* Solve the quasi-triangular system:
* (T(KI+1:N,KI+1:N) - WR)'*X = SCALE*WORK
*
VMAX = ONE
VCRIT = BIGNUM
*
JNXT = KI + 1
DO 170 J = KI + 1, N
IF( J.LT.JNXT )
$ GO TO 170
J1 = J
J2 = J
JNXT = J + 1
IF( J.LT.N ) THEN
IF( T( J+1, J ).NE.ZERO ) THEN
J2 = J + 1
JNXT = J + 2
END IF
END IF
*
IF( J1.EQ.J2 ) THEN
*
* 1-by-1 diagonal block
*
* Scale if necessary to avoid overflow when forming
* the right-hand side.
*
IF( WORK( J ).GT.VCRIT ) THEN
REC = ONE / VMAX
CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
VMAX = ONE
VCRIT = BIGNUM
END IF
*
WORK( J+N ) = WORK( J+N ) -
$ DDOT( J-KI-1, T( KI+1, J ), 1,
$ WORK( KI+1+N ), 1 )
*
* Solve (T(J,J)-WR)'*X = WORK
*
CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ),
$ LDT, ONE, ONE, WORK( J+N ), N, WR,
$ ZERO, X, 2, SCALE, XNORM, IERR )
*
* Scale if necessary
*
IF( SCALE.NE.ONE )
$ CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
WORK( J+N ) = X( 1, 1 )
VMAX = MAX( ABS( WORK( J+N ) ), VMAX )
VCRIT = BIGNUM / VMAX
***
* Increment op count, ignoring the possible scaling
OPST = OPST + ( 2*( J-KI-1 )+6 )
***
*
ELSE
*
* 2-by-2 diagonal block
*
* Scale if necessary to avoid overflow when forming
* the right-hand side.
*
BETA = MAX( WORK( J ), WORK( J+1 ) )
IF( BETA.GT.VCRIT ) THEN
REC = ONE / VMAX
CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
VMAX = ONE
VCRIT = BIGNUM
END IF
*
WORK( J+N ) = WORK( J+N ) -
$ DDOT( J-KI-1, T( KI+1, J ), 1,
$ WORK( KI+1+N ), 1 )
*
WORK( J+1+N ) = WORK( J+1+N ) -
$ DDOT( J-KI-1, T( KI+1, J+1 ), 1,
$ WORK( KI+1+N ), 1 )
*
* Solve
* [T(J,J)-WR T(J,J+1) ]'* X = SCALE*( WORK1 )
* [T(J+1,J) T(J+1,J+1)-WR] ( WORK2 )
*
CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, T( J, J ),
$ LDT, ONE, ONE, WORK( J+N ), N, WR,
$ ZERO, X, 2, SCALE, XNORM, IERR )
*
* Scale if necessary
*
IF( SCALE.NE.ONE )
$ CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
WORK( J+N ) = X( 1, 1 )
WORK( J+1+N ) = X( 2, 1 )
*
VMAX = MAX( ABS( WORK( J+N ) ),
$ ABS( WORK( J+1+N ) ), VMAX )
VCRIT = BIGNUM / VMAX
***
* Increment op count, ignoring the possible scaling
OPST = OPST + ( 4*( J-KI-1 )+24 )
***
*
END IF
170 CONTINUE
*
* Copy the vector x or Q*x to VL and normalize.
*
IF( .NOT.OVER ) THEN
CALL DCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 )
*
II = IDAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1
REMAX = ONE / ABS( VL( II, IS ) )
CALL DSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 )
***
OPST = OPST + ( 2*( N-KI+1 )+1 )
***
*
DO 180 K = 1, KI - 1
VL( K, IS ) = ZERO
180 CONTINUE
*
ELSE
*
IF( KI.LT.N )
$ CALL DGEMV( 'N', N, N-KI, ONE, VL( 1, KI+1 ), LDVL,
$ WORK( KI+1+N ), 1, WORK( KI+N ),
$ VL( 1, KI ), 1 )
*
II = IDAMAX( N, VL( 1, KI ), 1 )
REMAX = ONE / ABS( VL( II, KI ) )
CALL DSCAL( N, REMAX, VL( 1, KI ), 1 )
***
OPS = OPS + ( 2*N*( N-KI+1 )+1 )
***
*
END IF
*
ELSE
*
* Complex left eigenvector.
*
* Initial solve:
* ((T(KI,KI) T(KI,KI+1) )' - (WR - I* WI))*X = 0.
* ((T(KI+1,KI) T(KI+1,KI+1)) )
*
IF( ABS( T( KI, KI+1 ) ).GE.ABS( T( KI+1, KI ) ) ) THEN
WORK( KI+N ) = WI / T( KI, KI+1 )
WORK( KI+1+N2 ) = ONE
ELSE
WORK( KI+N ) = ONE
WORK( KI+1+N2 ) = -WI / T( KI+1, KI )
END IF
WORK( KI+1+N ) = ZERO
WORK( KI+N2 ) = ZERO
*
* Form right-hand side
*
DO 190 K = KI + 2, N
WORK( K+N ) = -WORK( KI+N )*T( KI, K )
WORK( K+N2 ) = -WORK( KI+1+N2 )*T( KI+1, K )
190 CONTINUE
***
OPST = OPST + 2*( N-KI-1 )
***
*
* Solve complex quasi-triangular system:
* ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2
*
VMAX = ONE
VCRIT = BIGNUM
*
JNXT = KI + 2
DO 200 J = KI + 2, N
IF( J.LT.JNXT )
$ GO TO 200
J1 = J
J2 = J
JNXT = J + 1
IF( J.LT.N ) THEN
IF( T( J+1, J ).NE.ZERO ) THEN
J2 = J + 1
JNXT = J + 2
END IF
END IF
*
IF( J1.EQ.J2 ) THEN
*
* 1-by-1 diagonal block
*
* Scale if necessary to avoid overflow when
* forming the right-hand side elements.
*
IF( WORK( J ).GT.VCRIT ) THEN
REC = ONE / VMAX
CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
CALL DSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 )
VMAX = ONE
VCRIT = BIGNUM
END IF
*
WORK( J+N ) = WORK( J+N ) -
$ DDOT( J-KI-2, T( KI+2, J ), 1,
$ WORK( KI+2+N ), 1 )
WORK( J+N2 ) = WORK( J+N2 ) -
$ DDOT( J-KI-2, T( KI+2, J ), 1,
$ WORK( KI+2+N2 ), 1 )
*
* Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2
*
CALL DLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ),
$ LDT, ONE, ONE, WORK( J+N ), N, WR,
$ -WI, X, 2, SCALE, XNORM, IERR )
*
* Scale if necessary
*
IF( SCALE.NE.ONE ) THEN
CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
CALL DSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 )
END IF
WORK( J+N ) = X( 1, 1 )
WORK( J+N2 ) = X( 1, 2 )
VMAX = MAX( ABS( WORK( J+N ) ),
$ ABS( WORK( J+N2 ) ), VMAX )
VCRIT = BIGNUM / VMAX
***
* Increment op count, ignoring the possible scaling
OPST = OPST + ( 4*( J-KI-2 )+24 )
***
*
ELSE
*
* 2-by-2 diagonal block
*
* Scale if necessary to avoid overflow when forming
* the right-hand side elements.
*
BETA = MAX( WORK( J ), WORK( J+1 ) )
IF( BETA.GT.VCRIT ) THEN
REC = ONE / VMAX
CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
CALL DSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 )
VMAX = ONE
VCRIT = BIGNUM
END IF
*
WORK( J+N ) = WORK( J+N ) -
$ DDOT( J-KI-2, T( KI+2, J ), 1,
$ WORK( KI+2+N ), 1 )
*
WORK( J+N2 ) = WORK( J+N2 ) -
$ DDOT( J-KI-2, T( KI+2, J ), 1,
$ WORK( KI+2+N2 ), 1 )
*
WORK( J+1+N ) = WORK( J+1+N ) -
$ DDOT( J-KI-2, T( KI+2, J+1 ), 1,
$ WORK( KI+2+N ), 1 )
*
WORK( J+1+N2 ) = WORK( J+1+N2 ) -
$ DDOT( J-KI-2, T( KI+2, J+1 ), 1,
$ WORK( KI+2+N2 ), 1 )
*
* Solve 2-by-2 complex linear equation
* ([T(j,j) T(j,j+1) ]'-(wr-i*wi)*I)*X = SCALE*B
* ([T(j+1,j) T(j+1,j+1)] )
*
CALL DLALN2( .TRUE., 2, 2, SMIN, ONE, T( J, J ),
$ LDT, ONE, ONE, WORK( J+N ), N, WR,
$ -WI, X, 2, SCALE, XNORM, IERR )
*
* Scale if necessary
*
IF( SCALE.NE.ONE ) THEN
CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
CALL DSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 )
END IF
WORK( J+N ) = X( 1, 1 )
WORK( J+N2 ) = X( 1, 2 )
WORK( J+1+N ) = X( 2, 1 )
WORK( J+1+N2 ) = X( 2, 2 )
VMAX = MAX( ABS( X( 1, 1 ) ), ABS( X( 1, 2 ) ),
$ ABS( X( 2, 1 ) ), ABS( X( 2, 2 ) ), VMAX )
VCRIT = BIGNUM / VMAX
***
* Increment op count, ignoring the possible scaling
OPST = OPST + ( 8*( J-KI-2 )+64 )
***
*
END IF
200 CONTINUE
*
* Copy the vector x or Q*x to VL and normalize.
*
210 CONTINUE
IF( .NOT.OVER ) THEN
CALL DCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 )
CALL DCOPY( N-KI+1, WORK( KI+N2 ), 1, VL( KI, IS+1 ),
$ 1 )
*
EMAX = ZERO
DO 220 K = KI, N
EMAX = MAX( EMAX, ABS( VL( K, IS ) )+
$ ABS( VL( K, IS+1 ) ) )
220 CONTINUE
REMAX = ONE / EMAX
CALL DSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 )
CALL DSCAL( N-KI+1, REMAX, VL( KI, IS+1 ), 1 )
***
OPST = OPST + ( 4*( N-KI+1 )+1 )
***
*
DO 230 K = 1, KI - 1
VL( K, IS ) = ZERO
VL( K, IS+1 ) = ZERO
230 CONTINUE
ELSE
IF( KI.LT.N-1 ) THEN
CALL DGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ),
$ LDVL, WORK( KI+2+N ), 1, WORK( KI+N ),
$ VL( 1, KI ), 1 )
CALL DGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ),
$ LDVL, WORK( KI+2+N2 ), 1,
$ WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 )
ELSE
CALL DSCAL( N, WORK( KI+N ), VL( 1, KI ), 1 )
CALL DSCAL( N, WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 )
END IF
*
EMAX = ZERO
DO 240 K = 1, N
EMAX = MAX( EMAX, ABS( VL( K, KI ) )+
$ ABS( VL( K, KI+1 ) ) )
240 CONTINUE
REMAX = ONE / EMAX
CALL DSCAL( N, REMAX, VL( 1, KI ), 1 )
CALL DSCAL( N, REMAX, VL( 1, KI+1 ), 1 )
***
OPS = OPS + ( 4*N*( N-KI-1 )+6*N+1 )
***
*
END IF
*
END IF
*
IS = IS + 1
IF( IP.NE.0 )
$ IS = IS + 1
250 CONTINUE
IF( IP.EQ.-1 )
$ IP = 0
IF( IP.EQ.1 )
$ IP = -1
*
260 CONTINUE
*
END IF
***
* Compute final op count
OPS = OPS + OPST
***
*
RETURN
*
* End of DTREVC
*
END
DOUBLE PRECISION FUNCTION DOPBL3( SUBNAM, M, N, K )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
INTEGER K, M, N
* ..
*
* Purpose
* =======
*
* DOPBL3 computes an approximation of the number of floating point
* operations used by a subroutine SUBNAM with the given values
* of the parameters M, N, and K.
*
* This version counts operations for the Level 3 BLAS.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* M (input) INTEGER
* N (input) INTEGER
* K (input) INTEGER
* M, N, and K contain parameter values used by the Level 3
* BLAS. The output matrix is always M x N or N x N if
* symmetric, but K has different uses in different
* contexts. For example, in the matrix-matrix multiply
* routine, we have
* C = A * B
* where C is M x N, A is M x K, and B is K x N.
* In xSYMM, xTRMM, and xTRSM, K indicates whether the matrix
* A is applied on the left or right. If K <= 0, the matrix
* is applied on the left, if K > 0, on the right.
*
* =====================================================================
*
* .. Local Scalars ..
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 C3
DOUBLE PRECISION ADDS, EK, EM, EN, MULTS
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR. .NOT.( LSAME( SUBNAM, 'S' ) .OR. LSAME( SUBNAM,
$ 'D' ) .OR. LSAME( SUBNAM, 'C' ) .OR. LSAME( SUBNAM, 'Z' ) ) )
$ THEN
DOPBL3 = 0
RETURN
END IF
*
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
MULTS = 0
ADDS = 0
EM = M
EN = N
EK = K
*
* ----------------------
* Matrix-matrix products
* assume beta = 1
* ----------------------
*
IF( LSAMEN( 3, C3, 'MM ' ) ) THEN
*
IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
MULTS = EM*EK*EN
ADDS = EM*EK*EN
*
ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) ) THEN
*
* IF K <= 0, assume A multiplies B on the left.
*
IF( K.LE.0 ) THEN
MULTS = EM*EM*EN
ADDS = EM*EM*EN
ELSE
MULTS = EM*EN*EN
ADDS = EM*EN*EN
END IF
*
ELSE IF( LSAMEN( 2, C2, 'TR' ) ) THEN
*
IF( K.LE.0 ) THEN
MULTS = EN*EM*( EM+1.D0 ) / 2.D0
ADDS = EN*EM*( EM-1.D0 ) / 2.D0
ELSE
MULTS = EM*EN*( EN+1.D0 ) / 2.D0
ADDS = EM*EN*( EN-1.D0 ) / 2.D0
END IF
*
END IF
*
* ------------------------------------------------
* Rank-K update of a symmetric or Hermitian matrix
* ------------------------------------------------
*
ELSE IF( LSAMEN( 3, C3, 'RK ' ) ) THEN
*
IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) ) THEN
*
MULTS = EK*EM*( EM+1.D0 ) / 2.D0
ADDS = EK*EM*( EM+1.D0 ) / 2.D0
END IF
*
* ------------------------------------------------
* Rank-2K update of a symmetric or Hermitian matrix
* ------------------------------------------------
*
ELSE IF( LSAMEN( 3, C3, 'R2K' ) ) THEN
*
IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) ) THEN
*
MULTS = EK*EM*EM
ADDS = EK*EM*EM + EM
END IF
*
* -----------------------------------------
* Solving system with many right hand sides
* -----------------------------------------
*
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'TRSM ' ) ) THEN
*
IF( K.LE.0 ) THEN
MULTS = EN*EM*( EM+1.D0 ) / 2.D0
ADDS = EN*EM*( EM-1.D0 ) / 2.D0
ELSE
MULTS = EM*EN*( EN+1.D0 ) / 2.D0
ADDS = EM*EN*( EN-1.D0 ) / 2.D0
END IF
*
END IF
*
* ------------------------------------------------
* Compute the total number of operations.
* For real and double precision routines, count
* 1 for each multiply and 1 for each add.
* For complex and complex*16 routines, count
* 6 for each multiply and 2 for each add.
* ------------------------------------------------
*
IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN
*
DOPBL3 = MULTS + ADDS
*
ELSE
*
DOPBL3 = 6*MULTS + 2*ADDS
*
END IF
*
RETURN
*
* End of DOPBL3
*
END
DOUBLE PRECISION FUNCTION DOPLA( SUBNAM, M, N, KL, KU, NB )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
INTEGER KL, KU, M, N, NB
* ..
*
* Purpose
* =======
*
* DOPLA computes an approximation of the number of floating point
* operations used by the subroutine SUBNAM with the given values
* of the parameters M, N, KL, KU, and NB.
*
* This version counts operations for the LAPACK subroutines.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* M (input) INTEGER
* The number of rows of the coefficient matrix. M >= 0.
*
* N (input) INTEGER
* The number of columns of the coefficient matrix.
* For solve routine when the matrix is square,
* N is the number of right hand sides. N >= 0.
*
* KL (input) INTEGER
* The lower band width of the coefficient matrix.
* If needed, 0 <= KL <= M-1.
* For xGEQRS, KL is the number of right hand sides.
*
* KU (input) INTEGER
* The upper band width of the coefficient matrix.
* If needed, 0 <= KU <= N-1.
*
* NB (input) INTEGER
* The block size. If needed, NB >= 1.
*
* Notes
* =====
*
* In the comments below, the association is given between arguments
* in the requested subroutine and local arguments. For example,
*
* xGETRS: N, NRHS => M, N
*
* means that arguments N and NRHS in DGETRS are passed to arguments
* M and N in this procedure.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL CORZ, SORD
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 C3
INTEGER I
DOUBLE PRECISION ADDFAC, ADDS, EK, EM, EMN, EN, MULFAC, MULTS,
$ WL, WU
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* --------------------------------------------------------
* Initialize DOPLA to 0 and do a quick return if possible.
* --------------------------------------------------------
*
DOPLA = 0
MULTS = 0
ADDS = 0
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
SORD = LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' )
CORZ = LSAME( C1, 'C' ) .OR. LSAME( C1, 'Z' )
IF( M.LE.0 .OR. .NOT.( SORD .OR. CORZ ) )
$ RETURN
*
* ---------------------------------------------------------
* If the coefficient matrix is real, count each add as 1
* operation and each multiply as 1 operation.
* If the coefficient matrix is complex, count each add as 2
* operations and each multiply as 6 operations.
* ---------------------------------------------------------
*
IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN
ADDFAC = 1
MULFAC = 1
ELSE
ADDFAC = 2
MULFAC = 6
END IF
EM = M
EN = N
EK = KL
*
* ---------------------------------
* GE: GEneral rectangular matrices
* ---------------------------------
*
IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
* xGETRF: M, N => M, N
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
EMN = MIN( M, N )
ADDS = EMN*( EM*EN-( EM+EN )*( EMN+1.D0 ) / 2.D0+
$ ( EMN+1.D0 )*( 2.D0*EMN+1.D0 ) / 6.D0 )
MULTS = ADDS + EMN*( EM-( EMN+1.D0 ) / 2.D0 )
*
* xGETRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*EM*EM
ADDS = EN*( EM*( EM-1.D0 ) )
*
* xGETRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 5.D0 / 6.D0+EM*( 1.D0 / 2.D0+EM*( 2.D0 /
$ 3.D0 ) ) )
ADDS = EM*( 5.D0 / 6.D0+EM*( -3.D0 / 2.D0+EM*( 2.D0 /
$ 3.D0 ) ) )
*
* xGEQRF or xGEQLF: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'QRF' ) .OR.
$ LSAMEN( 3, C3, 'QR2' ) .OR.
$ LSAMEN( 3, C3, 'QLF' ) .OR. LSAMEN( 3, C3, 'QL2' ) )
$ THEN
IF( M.GE.N ) THEN
MULTS = EN*( ( ( 23.D0 / 6.D0 )+EM+EN / 2.D0 )+EN*
$ ( EM-EN / 3.D0 ) )
ADDS = EN*( ( 5.D0 / 6.D0 )+EN*
$ ( 1.D0 / 2.D0+( EM-EN / 3.D0 ) ) )
ELSE
MULTS = EM*( ( ( 23.D0 / 6.D0 )+2.D0*EN-EM / 2.D0 )+EM*
$ ( EN-EM / 3.D0 ) )
ADDS = EM*( ( 5.D0 / 6.D0 )+EN-EM / 2.D0+EM*
$ ( EN-EM / 3.D0 ) )
END IF
*
* xGERQF or xGELQF: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'RQF' ) .OR.
$ LSAMEN( 3, C3, 'RQ2' ) .OR.
$ LSAMEN( 3, C3, 'LQF' ) .OR. LSAMEN( 3, C3, 'LQ2' ) )
$ THEN
IF( M.GE.N ) THEN
MULTS = EN*( ( ( 29.D0 / 6.D0 )+EM+EN / 2.D0 )+EN*
$ ( EM-EN / 3.D0 ) )
ADDS = EN*( ( 5.D0 / 6.D0 )+EM+EN*
$ ( -1.D0 / 2.D0+( EM-EN / 3.D0 ) ) )
ELSE
MULTS = EM*( ( ( 29.D0 / 6.D0 )+2.D0*EN-EM / 2.D0 )+EM*
$ ( EN-EM / 3.D0 ) )
ADDS = EM*( ( 5.D0 / 6.D0 )+EM / 2.D0+EM*
$ ( EN-EM / 3.D0 ) )
END IF
*
* xGEQPF: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'QPF' ) ) THEN
EMN = MIN( M, N )
MULTS = 2*EN*EN + EMN*( 3*EM+5*EN+2*EM*EN-( EMN+1 )*
$ ( 4+EN+EM-( 2*EMN+1 ) / 3 ) )
ADDS = EN*EN + EMN*( 2*EM+EN+2*EM*EN-( EMN+1 )*
$ ( 2+EN+EM-( 2*EMN+1 ) / 3 ) )
*
* xGEQRS or xGERQS: M, N, NRHS => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'QRS' ) .OR. LSAMEN( 3, C3, 'RQS' ) )
$ THEN
MULTS = EK*( EN*( 2.D0-EK )+EM*
$ ( 2.D0*EN+( EM+1.D0 ) / 2.D0 ) )
ADDS = EK*( EN*( 1.D0-EK )+EM*
$ ( 2.D0*EN+( EM-1.D0 ) / 2.D0 ) )
*
* xGELQS or xGEQLS: M, N, NRHS => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'LQS' ) .OR. LSAMEN( 3, C3, 'QLS' ) )
$ THEN
MULTS = EK*( EM*( 2.D0-EK )+EN*
$ ( 2.D0*EM+( EN+1.D0 ) / 2.D0 ) )
ADDS = EK*( EM*( 1.D0-EK )+EN*
$ ( 2.D0*EM+( EN-1.D0 ) / 2.D0 ) )
*
* xGEBRD: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'BRD' ) ) THEN
IF( M.GE.N ) THEN
MULTS = EN*( 20.D0 / 3.D0+EN*
$ ( 2.D0+( 2.D0*EM-( 2.D0 / 3.D0 )*EN ) ) )
ADDS = EN*( 5.D0 / 3.D0+( EN-EM )+EN*
$ ( 2.D0*EM-( 2.D0 / 3.D0 )*EN ) )
ELSE
MULTS = EM*( 20.D0 / 3.D0+EM*
$ ( 2.D0+( 2.D0*EN-( 2.D0 / 3.D0 )*EM ) ) )
ADDS = EM*( 5.D0 / 3.D0+( EM-EN )+EM*
$ ( 2.D0*EN-( 2.D0 / 3.D0 )*EM ) )
END IF
*
* xGEHRD: N => M
*
ELSE IF( LSAMEN( 3, C3, 'HRD' ) ) THEN
IF( M.EQ.1 ) THEN
MULTS = 0.D0
ADDS = 0.D0
ELSE
MULTS = -13.D0 + EM*( -7.D0 / 6.D0+EM*
$ ( 0.5D0+EM*( 5.D0 / 3.D0 ) ) )
ADDS = -8.D0 + EM*( -2.D0 / 3.D0+EM*
$ ( -1.D0+EM*( 5.D0 / 3.D0 ) ) )
END IF
*
END IF
*
* ----------------------------
* GB: General Banded matrices
* ----------------------------
* Note: The operation count is overestimated because
* it is assumed that the factor U fills in to the maximum
* extent, i.e., that its bandwidth goes from KU to KL + KU.
*
ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
*
* xGBTRF: M, N, KL, KU => M, N, KL, KU
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
DO 10 I = MIN( M, N ), 1, -1
WL = MAX( 0, MIN( KL, M-I ) )
WU = MAX( 0, MIN( KL+KU, N-I ) )
MULTS = MULTS + WL*( 1.D0+WU )
ADDS = ADDS + WL*WU
10 CONTINUE
*
* xGBTRS: N, NRHS, KL, KU => M, N, KL, KU
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
WL = MAX( 0, MIN( KL, M-1 ) )
WU = MAX( 0, MIN( KL+KU, M-1 ) )
MULTS = EN*( EM*( WL+1.D0+WU )-0.5D0*
$ ( WL*( WL+1.D0 )+WU*( WU+1.D0 ) ) )
ADDS = EN*( EM*( WL+WU )-0.5D0*
$ ( WL*( WL+1.D0 )+WU*( WU+1.D0 ) ) )
*
END IF
*
* --------------------------------------
* PO: POsitive definite matrices
* PP: Positive definite Packed matrices
* --------------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'PP' ) ) THEN
*
* xPOTRF: N => M
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = EM*( 1.D0 / 3.D0+EM*( 1.D0 / 2.D0+EM*( 1.D0 /
$ 6.D0 ) ) )
ADDS = ( 1.D0 / 6.D0 )*EM*( -1.D0+EM*EM )
*
* xPOTRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*( EM*( EM+1.D0 ) )
ADDS = EN*( EM*( EM-1.D0 ) )
*
* xPOTRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 2.D0 / 3.D0+EM*( 1.D0+EM*( 1.D0 / 3.D0 ) ) )
ADDS = EM*( 1.D0 / 6.D0+EM*( -1.D0 / 2.D0+EM*( 1.D0 /
$ 3.D0 ) ) )
*
END IF
*
* ------------------------------------
* PB: Positive definite Band matrices
* ------------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN
*
* xPBTRF: N, K => M, KL
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = EK*( -2.D0 / 3.D0+EK*( -1.D0+EK*( -1.D0 / 3.D0 ) ) )
$ + EM*( 1.D0+EK*( 3.D0 / 2.D0+EK*( 1.D0 / 2.D0 ) ) )
ADDS = EK*( -1.D0 / 6.D0+EK*( -1.D0 / 2.D0+EK*( -1.D0 /
$ 3.D0 ) ) ) + EM*( EK / 2.D0*( 1.D0+EK ) )
*
* xPBTRS: N, NRHS, K => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*( ( 2*EM-EK )*( EK+1.D0 ) )
ADDS = EN*( EK*( 2*EM-( EK+1.D0 ) ) )
*
END IF
*
* --------------------------------------------------------
* SY: SYmmetric indefinite matrices
* SP: Symmetric indefinite Packed matrices
* HE: HErmitian indefinite matrices (complex only)
* HP: Hermitian indefinite Packed matrices (complex only)
* --------------------------------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHP' ) ) THEN
*
* xSYTRF: N => M
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = EM*( 10.D0 / 3.D0+EM*
$ ( 1.D0 / 2.D0+EM*( 1.D0 / 6.D0 ) ) )
ADDS = EM / 6.D0*( -1.D0+EM*EM )
*
* xSYTRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*EM*EM
ADDS = EN*( EM*( EM-1.D0 ) )
*
* xSYTRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 2.D0 / 3.D0+EM*EM*( 1.D0 / 3.D0 ) )
ADDS = EM*( -1.D0 / 3.D0+EM*EM*( 1.D0 / 3.D0 ) )
*
* xSYTRD, xSYTD2: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRD' ) .OR. LSAMEN( 3, C3, 'TD2' ) )
$ THEN
IF( M.EQ.1 ) THEN
MULTS = 0.D0
ADDS = 0.D0
ELSE
MULTS = -15.D0 + EM*( -1.D0 / 6.D0+EM*
$ ( 5.D0 / 2.D0+EM*( 2.D0 / 3.D0 ) ) )
ADDS = -4.D0 + EM*( -8.D0 / 3.D0+EM*
$ ( 1.D0+EM*( 2.D0 / 3.D0 ) ) )
END IF
END IF
*
* -------------------
* Triangular matrices
* -------------------
*
ELSE IF( LSAMEN( 2, C2, 'TR' ) .OR. LSAMEN( 2, C2, 'TP' ) ) THEN
*
* xTRTRS: N, NRHS => M, N
*
IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*EM*( EM+1.D0 ) / 2.D0
ADDS = EN*EM*( EM-1.D0 ) / 2.D0
*
* xTRTRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 1.D0 / 3.D0+EM*( 1.D0 / 2.D0+EM*( 1.D0 /
$ 6.D0 ) ) )
ADDS = EM*( 1.D0 / 3.D0+EM*( -1.D0 / 2.D0+EM*( 1.D0 /
$ 6.D0 ) ) )
*
END IF
*
ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
*
* xTBTRS: N, NRHS, K => M, N, KL
*
IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*( EM*( EM+1.D0 ) / 2.D0-( EM-EK-1.D0 )*
$ ( EM-EK ) / 2.D0 )
ADDS = EN*( EM*( EM-1.D0 ) / 2.D0-( EM-EK-1.D0 )*( EM-EK ) /
$ 2.D0 )
END IF
*
* --------------------
* Trapezoidal matrices
* --------------------
*
ELSE IF( LSAMEN( 2, C2, 'TZ' ) ) THEN
*
* xTZRQF: M, N => M, N
*
IF( LSAMEN( 3, C3, 'RQF' ) ) THEN
EMN = MIN( M, N )
MULTS = 3*EM*( EN-EM+1 ) + ( 2*EN-2*EM+3 )*
$ ( EM*EM-EMN*( EMN+1 ) / 2 )
ADDS = ( EN-EM+1 )*( EM+2*EM*EM-EMN*( EMN+1 ) )
END IF
*
* -------------------
* Orthogonal matrices
* -------------------
*
ELSE IF( ( SORD .AND. LSAMEN( 2, C2, 'OR' ) ) .OR.
$ ( CORZ .AND. LSAMEN( 2, C2, 'UN' ) ) ) THEN
*
* -MQR, -MLQ, -MQL, or -MRQ: M, N, K, SIDE => M, N, KL, KU
* where KU<= 0 indicates SIDE = 'L'
* and KU> 0 indicates SIDE = 'R'
*
IF( LSAMEN( 3, C3, 'MQR' ) .OR. LSAMEN( 3, C3, 'MLQ' ) .OR.
$ LSAMEN( 3, C3, 'MQL' ) .OR. LSAMEN( 3, C3, 'MRQ' ) ) THEN
IF( KU.LE.0 ) THEN
MULTS = EK*EN*( 2.D0*EM+2.D0-EK )
ADDS = EK*EN*( 2.D0*EM+1.D0-EK )
ELSE
MULTS = EK*( EM*( 2.D0*EN-EK )+
$ ( EM+EN+( 1.D0-EK ) / 2.D0 ) )
ADDS = EK*EM*( 2.D0*EN+1.D0-EK )
END IF
*
* -GQR or -GQL: M, N, K => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'GQR' ) .OR. LSAMEN( 3, C3, 'GQL' ) )
$ THEN
MULTS = EK*( -5.D0 / 3.D0+( 2.D0*EN-EK )+
$ ( 2.D0*EM*EN+EK*( ( 2.D0 / 3.D0 )*EK-EM-EN ) ) )
ADDS = EK*( 1.D0 / 3.D0+( EN-EM )+
$ ( 2.D0*EM*EN+EK*( ( 2.D0 / 3.D0 )*EK-EM-EN ) ) )
*
* -GLQ or -GRQ: M, N, K => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'GLQ' ) .OR. LSAMEN( 3, C3, 'GRQ' ) )
$ THEN
MULTS = EK*( -2.D0 / 3.D0+( EM+EN-EK )+
$ ( 2.D0*EM*EN+EK*( ( 2.D0 / 3.D0 )*EK-EM-EN ) ) )
ADDS = EK*( 1.D0 / 3.D0+( EM-EN )+
$ ( 2.D0*EM*EN+EK*( ( 2.D0 / 3.D0 )*EK-EM-EN ) ) )
*
END IF
*
END IF
*
DOPLA = MULFAC*MULTS + ADDFAC*ADDS
*
RETURN
*
* End of DOPLA
*
END
DOUBLE PRECISION FUNCTION DOPLA2( SUBNAM, OPTS, M, N, K, L, NB )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
CHARACTER*( * ) OPTS
INTEGER K, L, M, N, NB
* ..
*
* Purpose
* =======
*
* DOPLA2 computes an approximation of the number of floating point
* operations used by the subroutine SUBNAM with character options
* OPTS and parameters M, N, K, L, and NB.
*
* This version counts operations for the LAPACK subroutines that
* call other LAPACK routines.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* OPTS (input) CHRACTER*(*)
* A string of character options to subroutine SUBNAM.
*
* M (input) INTEGER
* The number of rows of the coefficient matrix.
*
* N (input) INTEGER
* The number of columns of the coefficient matrix.
*
* K (input) INTEGER
* A third problem dimension, if needed.
*
* L (input) INTEGER
* A fourth problem dimension, if needed.
*
* NB (input) INTEGER
* The block size. If needed, NB >= 1.
*
* Notes
* =====
*
* In the comments below, the association is given between arguments
* in the requested subroutine and local arguments. For example,
*
* xORMBR: VECT // SIDE // TRANS, M, N, K => OPTS, M, N, K
*
* means that the character string VECT // SIDE // TRANS is passed to
* the argument OPTS, and the integer parameters M, N, and K are passed
* to the arguments M, N, and K,
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL CORZ, SORD
CHARACTER C1, SIDE, UPLO, VECT
CHARACTER*2 C2
CHARACTER*3 C3
CHARACTER*6 SUB2
INTEGER IHI, ILO, ISIDE, MI, NI, NQ
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
DOUBLE PRECISION DOPLA
EXTERNAL LSAME, LSAMEN, DOPLA
* ..
* .. Executable Statements ..
*
* ---------------------------------------------------------
* Initialize DOPLA2 to 0 and do a quick return if possible.
* ---------------------------------------------------------
*
DOPLA2 = 0
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
SORD = LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' )
CORZ = LSAME( C1, 'C' ) .OR. LSAME( C1, 'Z' )
IF( M.LE.0 .OR. .NOT.( SORD .OR. CORZ ) )
$ RETURN
*
* -------------------
* Orthogonal matrices
* -------------------
*
IF( ( SORD .AND. LSAMEN( 2, C2, 'OR' ) ) .OR.
$ ( CORZ .AND. LSAMEN( 2, C2, 'UN' ) ) ) THEN
*
IF( LSAMEN( 3, C3, 'GBR' ) ) THEN
*
* -GBR: VECT, M, N, K => OPTS, M, N, K
*
VECT = OPTS( 1: 1 )
IF( LSAME( VECT, 'Q' ) ) THEN
SUB2 = SUBNAM( 1: 3 ) // 'GQR'
IF( M.GE.K ) THEN
DOPLA2 = DOPLA( SUB2, M, N, K, 0, NB )
ELSE
DOPLA2 = DOPLA( SUB2, M-1, M-1, M-1, 0, NB )
END IF
ELSE
SUB2 = SUBNAM( 1: 3 ) // 'GLQ'
IF( K.LT.N ) THEN
DOPLA2 = DOPLA( SUB2, M, N, K, 0, NB )
ELSE
DOPLA2 = DOPLA( SUB2, N-1, N-1, N-1, 0, NB )
END IF
END IF
*
ELSE IF( LSAMEN( 3, C3, 'MBR' ) ) THEN
*
* -MBR: VECT // SIDE // TRANS, M, N, K => OPTS, M, N, K
*
VECT = OPTS( 1: 1 )
SIDE = OPTS( 2: 2 )
IF( LSAME( SIDE, 'L' ) ) THEN
NQ = M
ISIDE = 0
ELSE
NQ = N
ISIDE = 1
END IF
IF( LSAME( VECT, 'Q' ) ) THEN
SUB2 = SUBNAM( 1: 3 ) // 'MQR'
IF( NQ.GE.K ) THEN
DOPLA2 = DOPLA( SUB2, M, N, K, ISIDE, NB )
ELSE IF( ISIDE.EQ.0 ) THEN
DOPLA2 = DOPLA( SUB2, M-1, N, NQ-1, ISIDE, NB )
ELSE
DOPLA2 = DOPLA( SUB2, M, N-1, NQ-1, ISIDE, NB )
END IF
ELSE
SUB2 = SUBNAM( 1: 3 ) // 'MLQ'
IF( NQ.GT.K ) THEN
DOPLA2 = DOPLA( SUB2, M, N, K, ISIDE, NB )
ELSE IF( ISIDE.EQ.0 ) THEN
DOPLA2 = DOPLA( SUB2, M-1, N, NQ-1, ISIDE, NB )
ELSE
DOPLA2 = DOPLA( SUB2, M, N-1, NQ-1, ISIDE, NB )
END IF
END IF
*
ELSE IF( LSAMEN( 3, C3, 'GHR' ) ) THEN
*
* -GHR: N, ILO, IHI => M, N, K
*
ILO = N
IHI = K
SUB2 = SUBNAM( 1: 3 ) // 'GQR'
DOPLA2 = DOPLA( SUB2, IHI-ILO, IHI-ILO, IHI-ILO, 0, NB )
*
ELSE IF( LSAMEN( 3, C3, 'MHR' ) ) THEN
*
* -MHR: SIDE // TRANS, M, N, ILO, IHI => OPTS, M, N, K, L
*
SIDE = OPTS( 1: 1 )
ILO = K
IHI = L
IF( LSAME( SIDE, 'L' ) ) THEN
MI = IHI - ILO
NI = N
ISIDE = -1
ELSE
MI = M
NI = IHI - ILO
ISIDE = 1
END IF
SUB2 = SUBNAM( 1: 3 ) // 'MQR'
DOPLA2 = DOPLA( SUB2, MI, NI, IHI-ILO, ISIDE, NB )
*
ELSE IF( LSAMEN( 3, C3, 'GTR' ) ) THEN
*
* -GTR: UPLO, N => OPTS, M
*
UPLO = OPTS( 1: 1 )
IF( LSAME( UPLO, 'U' ) ) THEN
SUB2 = SUBNAM( 1: 3 ) // 'GQL'
DOPLA2 = DOPLA( SUB2, M-1, M-1, M-1, 0, NB )
ELSE
SUB2 = SUBNAM( 1: 3 ) // 'GQR'
DOPLA2 = DOPLA( SUB2, M-1, M-1, M-1, 0, NB )
END IF
*
ELSE IF( LSAMEN( 3, C3, 'MTR' ) ) THEN
*
* -MTR: SIDE // UPLO // TRANS, M, N => OPTS, M, N
*
SIDE = OPTS( 1: 1 )
UPLO = OPTS( 2: 2 )
IF( LSAME( SIDE, 'L' ) ) THEN
MI = M - 1
NI = N
NQ = M
ISIDE = -1
ELSE
MI = M
NI = N - 1
NQ = N
ISIDE = 1
END IF
*
IF( LSAME( UPLO, 'U' ) ) THEN
SUB2 = SUBNAM( 1: 3 ) // 'MQL'
DOPLA2 = DOPLA( SUB2, MI, NI, NQ-1, ISIDE, NB )
ELSE
SUB2 = SUBNAM( 1: 3 ) // 'MQR'
DOPLA2 = DOPLA( SUB2, MI, NI, NQ-1, ISIDE, NB )
END IF
*
END IF
END IF
*
RETURN
*
* End of DOPLA2
*
END
INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3,
$ N4 )
*
* -- LAPACK auxiliary routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER*( * ) NAME, OPTS
INTEGER ISPEC, N1, N2, N3, N4
* ..
*
* Purpose
* =======
*
* ILAENV returns problem-dependent parameters for the local
* environment. See ISPEC for a description of the parameters.
*
* In this version, the problem-dependent parameters are contained in
* the integer array IPARMS in the common block CLAENV and the value
* with index ISPEC is copied to ILAENV. This version of ILAENV is
* to be used in conjunction with XLAENV in TESTING and TIMING.
*
* 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
* = 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 and QZ methods
* for nonsymmetric eigenvalue problems.
* = 9: maximum size of the subproblems at the bottom of the
* computation tree in the divide-and-conquer algorithm
* =10: ieee NaN arithmetic can be trusted not to trap
* =11: infinity arithmetic can be trusted not to trap
*
* Other specifications (up to 100) can be added later.
*
* NAME (input) CHARACTER*(*)
* The name of the calling subroutine.
*
* 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.
*
* (ILAENV) (output) INTEGER
* >= 0: the value of the parameter specified by ISPEC
* < 0: if ILAENV = -k, the k-th argument had an illegal value.
*
* 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 )
*
* =====================================================================
*
* .. Intrinsic Functions ..
INTRINSIC INT, MIN, REAL
* ..
* .. External Functions ..
INTEGER IEEECK
EXTERNAL IEEECK
* ..
* .. Arrays in Common ..
INTEGER IPARMS( 100 )
* ..
* .. Common blocks ..
COMMON / CLAENV / IPARMS
* ..
* .. Save statement ..
SAVE / CLAENV /
* ..
* .. Executable Statements ..
*
IF( ISPEC.GE.1 .AND. ISPEC.LE.5 ) THEN
*
* Return a value from the common block.
*
ILAENV = IPARMS( ISPEC )
*
ELSE IF( ISPEC.EQ.6 ) THEN
*
* Compute SVD crossover point.
*
ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 )
*
ELSE IF( ISPEC.GE.7 .AND. ISPEC.LE.9 ) THEN
*
* Return a value from the common block.
*
ILAENV = IPARMS( ISPEC )
*
ELSE IF( ISPEC.EQ.10 ) THEN
*
* IEEE NaN arithmetic can be trusted not to trap
*
ILAENV = 1
IF( ILAENV.EQ.1 ) THEN
ILAENV = IEEECK( 0, 0.0, 1.0 )
END IF
*
ELSE IF( ISPEC.EQ.11 ) THEN
*
* Infinity arithmetic can be trusted not to trap
*
ILAENV = 1
IF( ILAENV.EQ.1 ) THEN
ILAENV = IEEECK( 1, 0.0, 1.0 )
END IF
*
ELSE
*
* Invalid value for ISPEC
*
ILAENV = -1
END IF
*
RETURN
*
* End of ILAENV
*
END
SUBROUTINE XLAENV( ISPEC, NVALUE )
*
* -- LAPACK auxiliary routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
INTEGER ISPEC, NVALUE
* ..
*
* Purpose
* =======
*
* XLAENV sets certain machine- and problem-dependent quantities
* which will later be retrieved by ILAENV.
*
* Arguments
* =========
*
* ISPEC (input) INTEGER
* Specifies the parameter to be set in the COMMON array IPARMS.
* = 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
* = 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: another crossover point, for the multishift QR and QZ
* methods for nonsymmetric eigenvalue problems.
* = 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
*
* NVALUE (input) INTEGER
* The value of the parameter specified by ISPEC.
*
* =====================================================================
*
* .. Arrays in Common ..
INTEGER IPARMS( 100 )
* ..
* .. Common blocks ..
COMMON / CLAENV / IPARMS
* ..
* .. Save statement ..
SAVE / CLAENV /
* ..
* .. Executable Statements ..
*
IF( ISPEC.GE.1 .AND. ISPEC.LE.9 ) THEN
IPARMS( ISPEC ) = NVALUE
END IF
*
RETURN
*
* End of XLAENV
*
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/eig/eigtime.f 0000644 0001750 0001750 00001742603 10616163243 023403 0 ustar osallou osallou SUBROUTINE ATIMIN( PATH, LINE, NSUBS, NAMES, TIMSUB, NOUT, INFO )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
CHARACTER*( * ) PATH
INTEGER INFO, NOUT, NSUBS
* ..
* .. Array Arguments ..
LOGICAL TIMSUB( * )
CHARACTER*( * ) NAMES( * )
* ..
*
* Purpose
* =======
*
* ATIMIN interprets the input line for the timing routines.
* The LOGICAL array TIMSUB returns .true. for each routine to be
* timed and .false. for the routines which are not to be timed.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*(*)
* The LAPACK path name of the calling routine. The path name
* may be at most 6 characters long. If LINE(1:LEN(PATH)) is
* the same as PATH, then the input line is searched for NSUBS
* non-blank characters, otherwise, the input line is assumed to
* specify a single subroutine name.
*
* LINE (input) CHARACTER*80
* The input line to be evaluated. The path or subroutine name
* must begin in column 1 and the part of the line after the
* name is used to indicate the routines to be timed.
* See below for further details.
*
* NSUBS (input) INTEGER
* The number of subroutines in the LAPACK path name of the
* calling routine.
*
* NAMES (input) CHARACTER*(*) array, dimension (NSUBS)
* The names of the subroutines in the LAPACK path name of the
* calling routine.
*
* TIMSUB (output) LOGICAL array, dimension (NSUBS)
* For each I from 1 to NSUBS, TIMSUB( I ) is set to .true. if
* the subroutine NAMES( I ) is to be timed; otherwise,
* TIMSUB( I ) is set to .false.
*
* NOUT (input) INTEGER
* The unit number on which error messages will be printed.
*
* INFO (output) INTEGER
* The return status of this routine.
* = -1: Unrecognized path or subroutine name
* = 0: Normal return
* = 1: Name was recognized, but no timing requested
*
* Further Details
* ======= =======
*
* An input line begins with a subroutine or path name, optionally
* followed by one or more non-blank characters indicating the specific
* routines to be timed.
*
* If the character string in PATH appears at the beginning of LINE,
* up to NSUBS routines may be timed. If LINE is blank after the path
* name, all the routines in the path will be timed. If LINE is not
* blank after the path name, the rest of the line is searched
* for NSUBS nonblank characters, and if the i-th such character is
* 't' or 'T', then the i-th subroutine in this path will be timed.
* For example, the input line
* SGE T T T T
* requests timing of the first 4 subroutines in the SGE path.
*
* If the character string in PATH does not appear at the beginning of
* LINE, then LINE is assumed to begin with a subroutine name. The name
* is assumed to end in column 6 or in column i if column i+1 is blank
* and i+1 <= 6. If LINE is completely blank after the subroutine name,
* the routine will be timed. If LINE is not blank after the subroutine
* name, then the subroutine will be timed if the first non-blank after
* the name is 't' or 'T'.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL REQ
CHARACTER*6 CNAME
INTEGER I, ISTART, ISTOP, ISUB, LCNAME, LNAMES, LPATH
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Intrinsic Functions ..
INTRINSIC LEN, MIN
* ..
* .. Executable Statements ..
*
*
* Initialize
*
INFO = 0
LCNAME = 1
DO 10 I = 2, 6
IF( LINE( I: I ).EQ.' ' )
$ GO TO 20
LCNAME = I
10 CONTINUE
20 CONTINUE
LPATH = MIN( LCNAME+1, LEN( PATH ) )
LNAMES = MIN( LCNAME+1, LEN( NAMES( 1 ) ) )
CNAME = LINE( 1: LCNAME )
*
DO 30 I = 1, NSUBS
TIMSUB( I ) = .FALSE.
30 CONTINUE
ISTOP = 0
*
* Check for a valid path or subroutine name.
*
IF( LCNAME.LE.LEN( PATH ) .AND. LSAMEN( LPATH, CNAME, PATH ) )
$ THEN
ISTART = 1
ISTOP = NSUBS
ELSE IF( LCNAME.LE.LEN( NAMES( 1 ) ) ) THEN
DO 40 I = 1, NSUBS
IF( LSAMEN( LNAMES, CNAME, NAMES( I ) ) ) THEN
ISTART = I
ISTOP = I
END IF
40 CONTINUE
END IF
*
IF( ISTOP.EQ.0 ) THEN
WRITE( NOUT, FMT = 9999 )CNAME
9999 FORMAT( 1X, A, ': Unrecognized path or subroutine name', / )
INFO = -1
GO TO 110
END IF
*
* Search the rest of the input line for 1 or NSUBS nonblank
* characters, where 'T' or 't' means 'Time this routine'.
*
ISUB = ISTART
DO 50 I = LCNAME + 1, 80
IF( LINE( I: I ).NE.' ' ) THEN
TIMSUB( ISUB ) = LSAME( LINE( I: I ), 'T' )
ISUB = ISUB + 1
IF( ISUB.GT.ISTOP )
$ GO TO 60
END IF
50 CONTINUE
60 CONTINUE
*
* If no characters appear after the routine or path name, then
* time the routine or all the routines in the path.
*
IF( ISUB.EQ.ISTART ) THEN
DO 70 I = ISTART, ISTOP
TIMSUB( I ) = .TRUE.
70 CONTINUE
ELSE
*
* Test to see if any timing was requested.
*
REQ = .FALSE.
DO 80 I = ISTART, ISUB - 1
REQ = REQ .OR. TIMSUB( I )
80 CONTINUE
IF( .NOT.REQ ) THEN
WRITE( NOUT, FMT = 9998 )CNAME
9998 FORMAT( 1X, A, ' was not timed', / )
INFO = 1
GO TO 110
END IF
90 CONTINUE
*
* If fewer than NSUBS characters are specified for a path name,
* the rest are assumed to be 'F'.
*
DO 100 I = ISUB, ISTOP
TIMSUB( I ) = .FALSE.
100 CONTINUE
END IF
110 CONTINUE
RETURN
*
* End of ATIMIN
*
END
SUBROUTINE CDIV(AR,AI,BR,BI,CR,CI)
DOUBLE PRECISION AR,AI,BR,BI,CR,CI
C
C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
C
DOUBLE PRECISION S,ARS,AIS,BRS,BIS
S = DABS(BR) + DABS(BI)
ARS = AR/S
AIS = AI/S
BRS = BR/S
BIS = BI/S
S = BRS**2 + BIS**2
CR = (ARS*BRS + AIS*BIS)/S
CI = (AIS*BRS - ARS*BIS)/S
RETURN
END
DOUBLE PRECISION FUNCTION EPSLON (X)
DOUBLE PRECISION X
C
C ESTIMATE UNIT ROUNDOFF IN QUANTITIES OF SIZE X.
C
DOUBLE PRECISION A,B,C,EPS
C
C THIS PROGRAM SHOULD FUNCTION PROPERLY ON ALL SYSTEMS
C SATISFYING THE FOLLOWING TWO ASSUMPTIONS,
C 1. THE BASE USED IN REPRESENTING FLOATING POINT
C NUMBERS IS NOT A POWER OF THREE.
C 2. THE QUANTITY A IN STATEMENT 10 IS REPRESENTED TO
C THE ACCURACY USED IN FLOATING POINT VARIABLES
C THAT ARE STORED IN MEMORY.
C THE STATEMENT NUMBER 10 AND THE GO TO 10 ARE INTENDED TO
C FORCE OPTIMIZING COMPILERS TO GENERATE CODE SATISFYING
C ASSUMPTION 2.
C UNDER THESE ASSUMPTIONS, IT SHOULD BE TRUE THAT,
C A IS NOT EXACTLY EQUAL TO FOUR-THIRDS,
C B HAS A ZERO FOR ITS LAST BIT OR DIGIT,
C C IS NOT EXACTLY EQUAL TO ONE,
C EPS MEASURES THE SEPARATION OF 1.0 FROM
C THE NEXT LARGER FLOATING POINT NUMBER.
C THE DEVELOPERS OF EISPACK WOULD APPRECIATE BEING INFORMED
C ABOUT ANY SYSTEMS WHERE THESE ASSUMPTIONS DO NOT HOLD.
C
C THIS VERSION DATED 4/6/83.
C
A = 4.0D0/3.0D0
10 B = A - 1.0D0
C = B + B + B
EPS = DABS(C-1.0D0)
IF (EPS .EQ. 0.0D0) GO TO 10
EPSLON = EPS*DABS(X)
RETURN
END
SUBROUTINE HQR(NM,N,LOW,IGH,H,WR,WI,IERR)
C
INTEGER I,J,K,L,M,N,EN,LL,MM,NA,NM,IGH,ITN,ITS,LOW,MP2,ENM2,IERR
DOUBLE PRECISION H(NM,N),WR(N),WI(N)
DOUBLE PRECISION P,Q,R,S,T,W,X,Y,ZZ,NORM,TST1,TST2
LOGICAL NOTLAS
*
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT
* ITCNT IS INITIALIZED TO 0, OPS IS ONLY INCREMENTED
* OPST IS USED TO ACCUMULATE SMALL CONTRIBUTIONS TO OPS
* TO AVOID ROUNDOFF ERROR
* .. COMMON BLOCKS ..
COMMON /LATIME/ OPS, ITCNT
* ..
* .. SCALARS IN COMMON ..
DOUBLE PRECISION OPS, ITCNT, OPST
* ..
C
C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR,
C NUM. MATH. 14, 219-231(1970) BY MARTIN, PETERS, AND WILKINSON.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 359-371(1971).
C
C THIS SUBROUTINE FINDS THE EIGENVALUES OF A REAL
C UPPER HESSENBERG MATRIX BY THE QR METHOD.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRIX.
C
C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED,
C SET LOW=1, IGH=N.
C
C H CONTAINS THE UPPER HESSENBERG MATRIX. INFORMATION ABOUT
C THE TRANSFORMATIONS USED IN THE REDUCTION TO HESSENBERG
C FORM BY ELMHES OR ORTHES, IF PERFORMED, IS STORED
C IN THE REMAINING TRIANGLE UNDER THE HESSENBERG MATRIX.
C
C ON OUTPUT
C
C H HAS BEEN DESTROYED. THEREFORE, IT MUST BE SAVED
C BEFORE CALLING HQR IF SUBSEQUENT CALCULATION AND
C BACK TRANSFORMATION OF EIGENVECTORS IS TO BE PERFORMED.
C
C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
C RESPECTIVELY, OF THE EIGENVALUES. THE EIGENVALUES
C ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS
C OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE
C HAVING THE POSITIVE IMAGINARY PART FIRST. IF AN
C ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
C FOR INDICES IERR+1,...,N.
C
C IERR IS SET TO
C ZERO FOR NORMAL RETURN,
C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C MODIFIED ON 11/1/89; ADJUSTING INDICES OF LOOPS
C 200, 210, 230, AND 240 TO INCREASE PERFORMANCE. JACK DONGARRA
C
C ------------------------------------------------------------------
C
*
EXTERNAL DLAMCH
DOUBLE PRECISION DLAMCH, UNFL,OVFL,ULP,SMLNUM,SMALL
IF (N.LE.0) RETURN
*
*
* INITIALIZE
ITCNT = 0
OPST = 0
IERR = 0
K = 1
C .......... STORE ROOTS ISOLATED BY BALANC
C AND COMPUTE MATRIX NORM ..........
DO 50 I = 1, N
K = I
IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50
WR(I) = H(I,I)
WI(I) = 0.0D0
50 CONTINUE
*
* INCREMENT OPCOUNT FOR COMPUTING MATRIX NORM
OPS = OPS + (IGH-LOW+1)*(IGH-LOW+2)/2
*
* COMPUTE THE 1-NORM OF MATRIX H
*
NORM = 0.0D0
DO 5 J = LOW, IGH
S = 0.0D0
DO 4 I = LOW, MIN(IGH,J+1)
S = S + DABS(H(I,J))
4 CONTINUE
NORM = MAX(NORM, S)
5 CONTINUE
*
UNFL = DLAMCH( 'SAFE MINIMUM' )
OVFL = DLAMCH( 'OVERFLOW' )
ULP = DLAMCH( 'EPSILON' )*DLAMCH( 'BASE' )
SMLNUM = MAX( UNFL*( N / ULP ), N / ( ULP*OVFL ) )
SMALL = MAX( SMLNUM, ULP*NORM )
C
EN = IGH
T = 0.0D0
ITN = 30*N
C .......... SEARCH FOR NEXT EIGENVALUES ..........
60 IF (EN .LT. LOW) GO TO 1001
ITS = 0
NA = EN - 1
ENM2 = NA - 1
C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
* REPLACE SPLITTING CRITERION WITH NEW ONE AS IN LAPACK
*
70 DO 80 LL = LOW, EN
L = EN + LOW - LL
IF (L .EQ. LOW) GO TO 100
S = DABS(H(L-1,L-1)) + DABS(H(L,L))
IF (S .EQ. 0.0D0) S = NORM
IF (DABS(H(L,L-1)) .LE. MAX(ULP*S,SMALL)) GO TO 100
80 CONTINUE
C .......... FORM SHIFT ..........
100 CONTINUE
*
* INCREMENT OP COUNT FOR CONVERGENCE TEST
OPS = OPS + 2*(EN-L+1)
X = H(EN,EN)
IF (L .EQ. EN) GO TO 270
Y = H(NA,NA)
W = H(EN,NA) * H(NA,EN)
IF (L .EQ. NA) GO TO 280
IF (ITN .EQ. 0) GO TO 1000
IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130
C .......... FORM EXCEPTIONAL SHIFT ..........
*
* INCREMENT OP COUNT FOR FORMING EXCEPTIONAL SHIFT
OPS = OPS + (EN-LOW+6)
T = T + X
C
DO 120 I = LOW, EN
120 H(I,I) = H(I,I) - X
C
S = DABS(H(EN,NA)) + DABS(H(NA,ENM2))
X = 0.75D0 * S
Y = X
W = -0.4375D0 * S * S
130 ITS = ITS + 1
ITN = ITN - 1
*
* UPDATE ITERATION NUMBER
ITCNT = 30*N - ITN
C .......... LOOK FOR TWO CONSECUTIVE SMALL
C SUB-DIAGONAL ELEMENTS.
C FOR M=EN-2 STEP -1 UNTIL L DO -- ..........
* REPLACE SPLITTING CRITERION WITH NEW ONE AS IN LAPACK
DO 140 MM = L, ENM2
M = ENM2 + L - MM
ZZ = H(M,M)
R = X - ZZ
S = Y - ZZ
P = (R * S - W) / H(M+1,M) + H(M,M+1)
Q = H(M+1,M+1) - ZZ - R - S
R = H(M+2,M+1)
S = DABS(P) + DABS(Q) + DABS(R)
P = P / S
Q = Q / S
R = R / S
IF (M .EQ. L) GO TO 150
TST1 = DABS(P)*(DABS(H(M-1,M-1)) + DABS(ZZ) + DABS(H(M+1,M+1)))
TST2 = DABS(H(M,M-1))*(DABS(Q) + DABS(R))
IF ( TST2 .LE. MAX(ULP*TST1,SMALL) ) GO TO 150
140 CONTINUE
C
150 CONTINUE
*
* INCREMENT OPCOUNT FOR LOOP 140
OPST = OPST + 20*(ENM2-M+1)
MP2 = M + 2
C
DO 160 I = MP2, EN
H(I,I-2) = 0.0D0
IF (I .EQ. MP2) GO TO 160
H(I,I-3) = 0.0D0
160 CONTINUE
C .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND
C COLUMNS M TO EN ..........
*
* INCREMENT OPCOUNT FOR LOOP 260
OPST = OPST + 18*(NA-M+1)
DO 260 K = M, NA
NOTLAS = K .NE. NA
IF (K .EQ. M) GO TO 170
P = H(K,K-1)
Q = H(K+1,K-1)
R = 0.0D0
IF (NOTLAS) R = H(K+2,K-1)
X = DABS(P) + DABS(Q) + DABS(R)
IF (X .EQ. 0.0D0) GO TO 260
P = P / X
Q = Q / X
R = R / X
170 S = DSIGN(DSQRT(P*P+Q*Q+R*R),P)
IF (K .EQ. M) GO TO 180
H(K,K-1) = -S * X
GO TO 190
180 IF (L .NE. M) H(K,K-1) = -H(K,K-1)
190 P = P + S
X = P / S
Y = Q / S
ZZ = R / S
Q = Q / P
R = R / P
IF (NOTLAS) GO TO 225
C .......... ROW MODIFICATION ..........
*
* INCREMENT OPCOUNT
OPS = OPS + 6*(EN-K+1)
DO 200 J = K, EN
P = H(K,J) + Q * H(K+1,J)
H(K,J) = H(K,J) - P * X
H(K+1,J) = H(K+1,J) - P * Y
200 CONTINUE
C
J = MIN0(EN,K+3)
C .......... COLUMN MODIFICATION ..........
*
* INCREMENT OPCOUNT
OPS = OPS + 6*(J-L+1)
DO 210 I = L, J
P = X * H(I,K) + Y * H(I,K+1)
H(I,K) = H(I,K) - P
H(I,K+1) = H(I,K+1) - P * Q
210 CONTINUE
GO TO 255
225 CONTINUE
C .......... ROW MODIFICATION ..........
*
* INCREMENT OPCOUNT
OPS = OPS + 10*(EN-K+1)
DO 230 J = K, EN
P = H(K,J) + Q * H(K+1,J) + R * H(K+2,J)
H(K,J) = H(K,J) - P * X
H(K+1,J) = H(K+1,J) - P * Y
H(K+2,J) = H(K+2,J) - P * ZZ
230 CONTINUE
C
J = MIN0(EN,K+3)
C .......... COLUMN MODIFICATION ..........
*
* INCREMENT OPCOUNT
OPS = OPS + 10*(J-L+1)
DO 240 I = L, J
P = X * H(I,K) + Y * H(I,K+1) + ZZ * H(I,K+2)
H(I,K) = H(I,K) - P
H(I,K+1) = H(I,K+1) - P * Q
H(I,K+2) = H(I,K+2) - P * R
240 CONTINUE
255 CONTINUE
C
260 CONTINUE
C
GO TO 70
C .......... ONE ROOT FOUND ..........
270 WR(EN) = X + T
WI(EN) = 0.0D0
EN = NA
GO TO 60
C .......... TWO ROOTS FOUND ..........
280 P = (Y - X) / 2.0D0
Q = P * P + W
ZZ = DSQRT(DABS(Q))
X = X + T
*
* INCREMENT OP COUNT FOR FINDING TWO ROOTS.
OPST = OPST + 8
IF (Q .LT. 0.0D0) GO TO 320
C .......... REAL PAIR ..........
ZZ = P + DSIGN(ZZ,P)
WR(NA) = X + ZZ
WR(EN) = WR(NA)
IF (ZZ .NE. 0.0D0) WR(EN) = X - W / ZZ
WI(NA) = 0.0D0
WI(EN) = 0.0D0
GO TO 330
C .......... COMPLEX PAIR ..........
320 WR(NA) = X + P
WR(EN) = X + P
WI(NA) = ZZ
WI(EN) = -ZZ
330 EN = ENM2
GO TO 60
C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
C CONVERGED AFTER 30*N ITERATIONS ..........
1000 IERR = EN
1001 CONTINUE
*
* COMPUTE FINAL OP COUNT
OPS = OPS + OPST
RETURN
END
SUBROUTINE HQR2(NM,N,LOW,IGH,H,WR,WI,Z,IERR)
C
INTEGER I,J,K,L,M,N,EN,II,JJ,LL,MM,NA,NM,NN,
X IGH,ITN,ITS,LOW,MP2,ENM2,IERR
DOUBLE PRECISION H(NM,N),WR(N),WI(N),Z(NM,N)
DOUBLE PRECISION P,Q,R,S,T,W,X,Y,RA,SA,VI,VR,ZZ,NORM,TST1,TST2
LOGICAL NOTLAS
*
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT
* ITCNT IS INITIALIZED TO 0, OPS IS ONLY INCREMENTED
* OPST IS USED TO ACCUMULATE SMALL CONTRIBUTIONS TO OPS
* TO AVOID ROUNDOFF ERROR
* .. COMMON BLOCKS ..
COMMON /LATIME/ OPS, ITCNT
* ..
* .. SCALARS IN COMMON ..
DOUBLE PRECISION OPS, ITCNT, OPST
* ..
C
C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR2,
C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
C
C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
C OF A REAL UPPER HESSENBERG MATRIX BY THE QR METHOD. THE
C EIGENVECTORS OF A REAL GENERAL MATRIX CAN ALSO BE FOUND
C IF ELMHES AND ELTRAN OR ORTHES AND ORTRAN HAVE
C BEEN USED TO REDUCE THIS GENERAL MATRIX TO HESSENBERG FORM
C AND TO ACCUMULATE THE SIMILARITY TRANSFORMATIONS.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRIX.
C
C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED,
C SET LOW=1, IGH=N.
C
C H CONTAINS THE UPPER HESSENBERG MATRIX.
C
C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED BY ELTRAN
C AFTER THE REDUCTION BY ELMHES, OR BY ORTRAN AFTER THE
C REDUCTION BY ORTHES, IF PERFORMED. IF THE EIGENVECTORS
C OF THE HESSENBERG MATRIX ARE DESIRED, Z MUST CONTAIN THE
C IDENTITY MATRIX.
C
C ON OUTPUT
C
C H HAS BEEN DESTROYED.
C
C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
C RESPECTIVELY, OF THE EIGENVALUES. THE EIGENVALUES
C ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS
C OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE
C HAVING THE POSITIVE IMAGINARY PART FIRST. IF AN
C ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
C FOR INDICES IERR+1,...,N.
C
C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS.
C IF THE I-TH EIGENVALUE IS REAL, THE I-TH COLUMN OF Z
C CONTAINS ITS EIGENVECTOR. IF THE I-TH EIGENVALUE IS COMPLEX
C WITH POSITIVE IMAGINARY PART, THE I-TH AND (I+1)-TH
C COLUMNS OF Z CONTAIN THE REAL AND IMAGINARY PARTS OF ITS
C EIGENVECTOR. THE EIGENVECTORS ARE UNNORMALIZED. IF AN
C ERROR EXIT IS MADE, NONE OF THE EIGENVECTORS HAS BEEN FOUND.
C
C IERR IS SET TO
C ZERO FOR NORMAL RETURN,
C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
C
C CALLS CDIV FOR COMPLEX DIVISION.
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
*
EXTERNAL DLAMCH
DOUBLE PRECISION DLAMCH, UNFL,OVFL,ULP,SMLNUM,SMALL
IF (N.LE.0) RETURN
*
* INITIALIZE
*
ITCNT = 0
OPST = 0
C
IERR = 0
K = 1
C .......... STORE ROOTS ISOLATED BY BALANC
C AND COMPUTE MATRIX NORM ..........
DO 50 I = 1, N
IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50
WR(I) = H(I,I)
WI(I) = 0.0D0
50 CONTINUE
* INCREMENT OPCOUNT FOR COMPUTING MATRIX NORM
OPS = OPS + (IGH-LOW+1)*(IGH-LOW+2)/2
*
* COMPUTE THE 1-NORM OF MATRIX H
*
NORM = 0.0D0
DO 5 J = LOW, IGH
S = 0.0D0
DO 4 I = LOW, MIN(IGH,J+1)
S = S + DABS(H(I,J))
4 CONTINUE
NORM = MAX(NORM, S)
5 CONTINUE
C
UNFL = DLAMCH( 'SAFE MINIMUM' )
OVFL = DLAMCH( 'OVERFLOW' )
ULP = DLAMCH( 'EPSILON' )*DLAMCH( 'BASE' )
SMLNUM = MAX( UNFL*( N / ULP ), N / ( ULP*OVFL ) )
SMALL = MAX( SMLNUM, MIN( ( NORM*SMLNUM )*NORM, ULP*NORM ) )
C
EN = IGH
T = 0.0D0
ITN = 30*N
C .......... SEARCH FOR NEXT EIGENVALUES ..........
60 IF (EN .LT. LOW) GO TO 340
ITS = 0
NA = EN - 1
ENM2 = NA - 1
C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
* REPLACE SPLITTING CRITERION WITH NEW ONE AS IN LAPACK
*
70 DO 80 LL = LOW, EN
L = EN + LOW - LL
IF (L .EQ. LOW) GO TO 100
S = DABS(H(L-1,L-1)) + DABS(H(L,L))
IF (S .EQ. 0.0D0) S = NORM
IF ( ABS(H(L,L-1)) .LE. MAX(ULP*S,SMALL) ) GO TO 100
80 CONTINUE
C .......... FORM SHIFT ..........
100 CONTINUE
*
* INCREMENT OP COUNT FOR CONVERGENCE TEST
OPS = OPS + 2*(EN-L+1)
X = H(EN,EN)
IF (L .EQ. EN) GO TO 270
Y = H(NA,NA)
W = H(EN,NA) * H(NA,EN)
IF (L .EQ. NA) GO TO 280
IF (ITN .EQ. 0) GO TO 1000
IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130
C .......... FORM EXCEPTIONAL SHIFT ..........
*
* INCREMENT OP COUNT
OPS = OPS + (EN-LOW+6)
T = T + X
C
DO 120 I = LOW, EN
120 H(I,I) = H(I,I) - X
C
S = DABS(H(EN,NA)) + DABS(H(NA,ENM2))
X = 0.75D0 * S
Y = X
W = -0.4375D0 * S * S
130 ITS = ITS + 1
ITN = ITN - 1
*
* UPDATE ITERATION NUMBER
ITCNT = 30*N - ITN
C .......... LOOK FOR TWO CONSECUTIVE SMALL
C SUB-DIAGONAL ELEMENTS.
C FOR M=EN-2 STEP -1 UNTIL L DO -- ..........
DO 140 MM = L, ENM2
M = ENM2 + L - MM
ZZ = H(M,M)
R = X - ZZ
S = Y - ZZ
P = (R * S - W) / H(M+1,M) + H(M,M+1)
Q = H(M+1,M+1) - ZZ - R - S
R = H(M+2,M+1)
S = DABS(P) + DABS(Q) + DABS(R)
P = P / S
Q = Q / S
R = R / S
IF (M .EQ. L) GO TO 150
TST1 = DABS(P)*(DABS(H(M-1,M-1)) + DABS(ZZ) + DABS(H(M+1,M+1)))
TST2 = DABS(H(M,M-1))*(DABS(Q) + DABS(R))
IF ( TST2 .LE. MAX(ULP*TST1,SMALL) ) GO TO 150
140 CONTINUE
C
150 CONTINUE
*
* INCREMENT OPCOUNT FOR LOOP 140
OPST = OPST + 20*(ENM2-M+1)
MP2 = M + 2
C
DO 160 I = MP2, EN
H(I,I-2) = 0.0D0
IF (I .EQ. MP2) GO TO 160
H(I,I-3) = 0.0D0
160 CONTINUE
C .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND
C COLUMNS M TO EN ..........
*
* INCREMENT OPCOUNT FOR LOOP 260
OPST = OPST + 18*(NA-M+1)
DO 260 K = M, NA
NOTLAS = K .NE. NA
IF (K .EQ. M) GO TO 170
P = H(K,K-1)
Q = H(K+1,K-1)
R = 0.0D0
IF (NOTLAS) R = H(K+2,K-1)
X = DABS(P) + DABS(Q) + DABS(R)
IF (X .EQ. 0.0D0) GO TO 260
P = P / X
Q = Q / X
R = R / X
170 S = DSIGN(DSQRT(P*P+Q*Q+R*R),P)
IF (K .EQ. M) GO TO 180
H(K,K-1) = -S * X
GO TO 190
180 IF (L .NE. M) H(K,K-1) = -H(K,K-1)
190 P = P + S
X = P / S
Y = Q / S
ZZ = R / S
Q = Q / P
R = R / P
IF (NOTLAS) GO TO 225
C .......... ROW MODIFICATION ..........
*
* INCREMENT OP COUNT FOR LOOP 200
OPS = OPS + 6*(N-K+1)
DO 200 J = K, N
P = H(K,J) + Q * H(K+1,J)
H(K,J) = H(K,J) - P * X
H(K+1,J) = H(K+1,J) - P * Y
200 CONTINUE
C
J = MIN0(EN,K+3)
C .......... COLUMN MODIFICATION ..........
*
* INCREMENT OPCOUNT FOR LOOP 210
OPS = OPS + 6*J
DO 210 I = 1, J
P = X * H(I,K) + Y * H(I,K+1)
H(I,K) = H(I,K) - P
H(I,K+1) = H(I,K+1) - P * Q
210 CONTINUE
C .......... ACCUMULATE TRANSFORMATIONS ..........
*
* INCREMENT OPCOUNT FOR LOOP 220
OPS = OPS + 6*(IGH-LOW + 1)
DO 220 I = LOW, IGH
P = X * Z(I,K) + Y * Z(I,K+1)
Z(I,K) = Z(I,K) - P
Z(I,K+1) = Z(I,K+1) - P * Q
220 CONTINUE
GO TO 255
225 CONTINUE
C .......... ROW MODIFICATION ..........
*
* INCREMENT OPCOUNT FOR LOOP 230
OPS = OPS + 10*(N-K+1)
DO 230 J = K, N
P = H(K,J) + Q * H(K+1,J) + R * H(K+2,J)
H(K,J) = H(K,J) - P * X
H(K+1,J) = H(K+1,J) - P * Y
H(K+2,J) = H(K+2,J) - P * ZZ
230 CONTINUE
C
J = MIN0(EN,K+3)
C .......... COLUMN MODIFICATION ..........
*
* INCREMENT OPCOUNT FOR LOOP 240
OPS = OPS + 10*J
DO 240 I = 1, J
P = X * H(I,K) + Y * H(I,K+1) + ZZ * H(I,K+2)
H(I,K) = H(I,K) - P
H(I,K+1) = H(I,K+1) - P * Q
H(I,K+2) = H(I,K+2) - P * R
240 CONTINUE
C .......... ACCUMULATE TRANSFORMATIONS ..........
*
* INCREMENT OPCOUNT FOR LOOP 250
OPS = OPS + 10*(IGH-LOW+1)
DO 250 I = LOW, IGH
P = X * Z(I,K) + Y * Z(I,K+1) + ZZ * Z(I,K+2)
Z(I,K) = Z(I,K) - P
Z(I,K+1) = Z(I,K+1) - P * Q
Z(I,K+2) = Z(I,K+2) - P * R
250 CONTINUE
255 CONTINUE
C
260 CONTINUE
C
GO TO 70
C .......... ONE ROOT FOUND ..........
270 H(EN,EN) = X + T
WR(EN) = H(EN,EN)
WI(EN) = 0.0D0
EN = NA
GO TO 60
C .......... TWO ROOTS FOUND ..........
280 P = (Y - X) / 2.0D0
Q = P * P + W
ZZ = DSQRT(DABS(Q))
H(EN,EN) = X + T
X = H(EN,EN)
H(NA,NA) = Y + T
IF (Q .LT. 0.0D0) GO TO 320
C .......... REAL PAIR ..........
ZZ = P + DSIGN(ZZ,P)
WR(NA) = X + ZZ
WR(EN) = WR(NA)
IF (ZZ .NE. 0.0D0) WR(EN) = X - W / ZZ
WI(NA) = 0.0D0
WI(EN) = 0.0D0
X = H(EN,NA)
S = DABS(X) + DABS(ZZ)
P = X / S
Q = ZZ / S
R = DSQRT(P*P+Q*Q)
P = P / R
Q = Q / R
*
* INCREMENT OP COUNT FOR FINDING TWO ROOTS.
OPST = OPST + 18
*
* INCREMENT OP COUNT FOR MODIFICATION AND ACCUMULATION
* IN LOOP 290, 300, 310
OPS = OPS + 6*(N-NA+1) + 6*EN + 6*(IGH-LOW+1)
C .......... ROW MODIFICATION ..........
DO 290 J = NA, N
ZZ = H(NA,J)
H(NA,J) = Q * ZZ + P * H(EN,J)
H(EN,J) = Q * H(EN,J) - P * ZZ
290 CONTINUE
C .......... COLUMN MODIFICATION ..........
DO 300 I = 1, EN
ZZ = H(I,NA)
H(I,NA) = Q * ZZ + P * H(I,EN)
H(I,EN) = Q * H(I,EN) - P * ZZ
300 CONTINUE
C .......... ACCUMULATE TRANSFORMATIONS ..........
DO 310 I = LOW, IGH
ZZ = Z(I,NA)
Z(I,NA) = Q * ZZ + P * Z(I,EN)
Z(I,EN) = Q * Z(I,EN) - P * ZZ
310 CONTINUE
C
GO TO 330
C .......... COMPLEX PAIR ..........
320 WR(NA) = X + P
WR(EN) = X + P
WI(NA) = ZZ
WI(EN) = -ZZ
*
* INCREMENT OP COUNT FOR FINDING COMPLEX PAIR.
OPST = OPST + 9
330 EN = ENM2
GO TO 60
C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
C VECTORS OF UPPER TRIANGULAR FORM ..........
340 IF (NORM .EQ. 0.0D0) GO TO 1001
C .......... FOR EN=N STEP -1 UNTIL 1 DO -- ..........
DO 800 NN = 1, N
EN = N + 1 - NN
P = WR(EN)
Q = WI(EN)
NA = EN - 1
IF (Q) 710, 600, 800
C .......... REAL VECTOR ..........
600 M = EN
H(EN,EN) = 1.0D0
IF (NA .EQ. 0) GO TO 800
C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
DO 700 II = 1, NA
I = EN - II
W = H(I,I) - P
R = 0.0D0
C
*
* INCREMENT OP COUNT FOR LOOP 610
OPST = OPST + 2*(EN - M+1)
DO 610 J = M, EN
610 R = R + H(I,J) * H(J,EN)
C
IF (WI(I) .GE. 0.0D0) GO TO 630
ZZ = W
S = R
GO TO 700
630 M = I
IF (WI(I) .NE. 0.0D0) GO TO 640
T = W
IF (T .NE. 0.0D0) GO TO 635
TST1 = NORM
T = TST1
632 T = 0.01D0 * T
TST2 = NORM + T
IF (TST2 .GT. TST1) GO TO 632
635 H(I,EN) = -R / T
GO TO 680
C .......... SOLVE REAL EQUATIONS ..........
640 X = H(I,I+1)
Y = H(I+1,I)
Q = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I)
T = (X * S - ZZ * R) / Q
*
* INCREMENT OP COUNT FOR SOLVING REAL EQUATION.
OPST = OPST + 13
H(I,EN) = T
IF (DABS(X) .LE. DABS(ZZ)) GO TO 650
H(I+1,EN) = (-R - W * T) / X
GO TO 680
650 H(I+1,EN) = (-S - Y * T) / ZZ
C
C .......... OVERFLOW CONTROL ..........
680 T = DABS(H(I,EN))
IF (T .EQ. 0.0D0) GO TO 700
TST1 = T
TST2 = TST1 + 1.0D0/TST1
IF (TST2 .GT. TST1) GO TO 700
*
* INCREMENT OP COUNT.
OPST = OPST + (EN-I+1)
DO 690 J = I, EN
H(J,EN) = H(J,EN)/T
690 CONTINUE
C
700 CONTINUE
C .......... END REAL VECTOR ..........
GO TO 800
C .......... COMPLEX VECTOR ..........
710 M = NA
C .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT
C EIGENVECTOR MATRIX IS TRIANGULAR ..........
IF (DABS(H(EN,NA)) .LE. DABS(H(NA,EN))) GO TO 720
H(NA,NA) = Q / H(EN,NA)
H(NA,EN) = -(H(EN,EN) - P) / H(EN,NA)
*
* INCREMENT OP COUNT.
OPST = OPST + 3
GO TO 730
720 CALL CDIV(0.0D0,-H(NA,EN),H(NA,NA)-P,Q,H(NA,NA),H(NA,EN))
*
* INCREMENT OP COUNT IF (ABS(H(EN,NA)) .LE. ABS(H(NA,EN)))
OPST = OPST + 16
730 H(EN,NA) = 0.0D0
H(EN,EN) = 1.0D0
ENM2 = NA - 1
IF (ENM2 .EQ. 0) GO TO 800
C .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- ..........
DO 795 II = 1, ENM2
I = NA - II
W = H(I,I) - P
RA = 0.0D0
SA = 0.0D0
C
*
* INCREMENT OP COUNT FOR LOOP 760
OPST = OPST + 4*(EN-M+1)
DO 760 J = M, EN
RA = RA + H(I,J) * H(J,NA)
SA = SA + H(I,J) * H(J,EN)
760 CONTINUE
C
IF (WI(I) .GE. 0.0D0) GO TO 770
ZZ = W
R = RA
S = SA
GO TO 795
770 M = I
IF (WI(I) .NE. 0.0D0) GO TO 780
CALL CDIV(-RA,-SA,W,Q,H(I,NA),H(I,EN))
*
* INCREMENT OP COUNT FOR CDIV
OPST = OPST + 16
GO TO 790
C .......... SOLVE COMPLEX EQUATIONS ..........
780 X = H(I,I+1)
Y = H(I+1,I)
VR = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I) - Q * Q
VI = (WR(I) - P) * 2.0D0 * Q
*
* INCREMENT OPCOUNT (AVERAGE) FOR SOLVING COMPLEX EQUATIONS
OPST = OPST + 42
IF (VR .NE. 0.0D0 .OR. VI .NE. 0.0D0) GO TO 784
TST1 = NORM * (DABS(W) + DABS(Q) + DABS(X)
X + DABS(Y) + DABS(ZZ))
VR = TST1
783 VR = 0.01D0 * VR
TST2 = TST1 + VR
IF (TST2 .GT. TST1) GO TO 783
784 CALL CDIV(X*R-ZZ*RA+Q*SA,X*S-ZZ*SA-Q*RA,VR,VI,
X H(I,NA),H(I,EN))
IF (DABS(X) .LE. DABS(ZZ) + DABS(Q)) GO TO 785
H(I+1,NA) = (-RA - W * H(I,NA) + Q * H(I,EN)) / X
H(I+1,EN) = (-SA - W * H(I,EN) - Q * H(I,NA)) / X
GO TO 790
785 CALL CDIV(-R-Y*H(I,NA),-S-Y*H(I,EN),ZZ,Q,
X H(I+1,NA),H(I+1,EN))
C
C .......... OVERFLOW CONTROL ..........
790 T = DMAX1(DABS(H(I,NA)), DABS(H(I,EN)))
IF (T .EQ. 0.0D0) GO TO 795
TST1 = T
TST2 = TST1 + 1.0D0/TST1
IF (TST2 .GT. TST1) GO TO 795
*
* INCREMENT OP COUNT.
OPST = OPST + 2*(EN-I+1)
DO 792 J = I, EN
H(J,NA) = H(J,NA)/T
H(J,EN) = H(J,EN)/T
792 CONTINUE
C
795 CONTINUE
C .......... END COMPLEX VECTOR ..........
800 CONTINUE
C .......... END BACK SUBSTITUTION.
C VECTORS OF ISOLATED ROOTS ..........
DO 840 I = 1, N
IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840
C
DO 820 J = I, N
820 Z(I,J) = H(I,J)
C
840 CONTINUE
C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
C VECTORS OF ORIGINAL FULL MATRIX.
C FOR J=N STEP -1 UNTIL LOW DO -- ..........
DO 880 JJ = LOW, N
J = N + LOW - JJ
M = MIN0(J,IGH)
C
*
* INCREMENT OP COUNT.
OPS = OPS + 2*(IGH-LOW+1)*(M-LOW+1)
DO 880 I = LOW, IGH
ZZ = 0.0D0
C
DO 860 K = LOW, M
860 ZZ = ZZ + Z(I,K) * H(K,J)
C
Z(I,J) = ZZ
880 CONTINUE
C
GO TO 1001
C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
C CONVERGED AFTER 30*N ITERATIONS ..........
1000 IERR = EN
1001 CONTINUE
*
* COMPUTE FINAL OP COUNT
OPS = OPS + OPST
RETURN
END
SUBROUTINE IMTQL1(N,D,E,IERR)
*
* EISPACK ROUTINE
* MODIFIED FOR COMPARISON WITH LAPACK ROUTINES.
*
* CONVERGENCE TEST WAS MODIFIED TO BE THE SAME AS IN DSTEQR.
*
C
INTEGER I,J,L,M,N,II,MML,IERR
DOUBLE PRECISION D(N),E(N)
DOUBLE PRECISION B,C,F,G,P,R,S,TST1,TST2,PYTHAG
DOUBLE PRECISION EPS, TST
DOUBLE PRECISION DLAMCH
external pythag, dlamch
*
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT
* ITCNT IS INITIALIZED TO 0, OPS IS ONLY INCREMENTED
* OPST IS USED TO ACCUMULATE CONTRIBUTIONS TO OPS FROM
* FUNCTION PYTHAG. IT IS PASSED TO AND FROM PYTHAG
* THROUGH COMMON BLOCK PYTHOP.
* .. COMMON BLOCKS ..
COMMON / LATIME / OPS, ITCNT
COMMON / PYTHOP / OPST
*
* .. SCALARS IN COMMON ..
DOUBLE PRECISION ITCNT, OPS, OPST
* ..
C
C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE IMTQL1,
C NUM. MATH. 12, 377-383(1968) BY MARTIN AND WILKINSON,
C AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971).
C
C THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC
C TRIDIAGONAL MATRIX BY THE IMPLICIT QL METHOD.
C
C ON INPUT
C
C N IS THE ORDER OF THE MATRIX.
C
C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
C
C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY.
C
C ON OUTPUT
C
C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN
C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND
C ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE
C THE SMALLEST EIGENVALUES.
C
C E HAS BEEN DESTROYED.
C
C IERR IS SET TO
C ZERO FOR NORMAL RETURN,
C J IF THE J-TH EIGENVALUE HAS NOT BEEN
C DETERMINED AFTER 40 ITERATIONS.
C
C CALLS PYTHAG FOR SQRT(A*A + B*B) .
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
C
IERR = 0
IF (N .EQ. 1) GO TO 1001
*
* INITIALIZE ITERATION COUNT AND OPST
ITCNT = 0
OPST = 0
*
* DETERMINE THE UNIT ROUNDOFF FOR THIS ENVIRONMENT.
*
EPS = DLAMCH( 'EPSILON' )
C
DO 100 I = 2, N
100 E(I-1) = E(I)
C
E(N) = 0.0D0
C
DO 290 L = 1, N
J = 0
C .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT ..........
105 DO 110 M = L, N
IF (M .EQ. N) GO TO 120
TST = ABS( E(M) )
IF( TST .LE. EPS * ( ABS(D(M)) + ABS(D(M+1)) ) ) GO TO 120
* TST1 = ABS(D(M)) + ABS(D(M+1))
* TST2 = TST1 + ABS(E(M))
* IF (TST2 .EQ. TST1) GO TO 120
110 CONTINUE
C
120 P = D(L)
*
* INCREMENT OPCOUNT FOR FINDING SMALL SUBDIAGONAL ELEMENT.
OPS = OPS + 2*( MIN(M,N-1)-L+1 )
IF (M .EQ. L) GO TO 215
IF (J .EQ. 40) GO TO 1000
J = J + 1
C .......... FORM SHIFT ..........
G = (D(L+1) - P) / (2.0D0 * E(L))
R = PYTHAG(G,1.0D0)
G = D(M) - P + E(L) / (G + DSIGN(R,G))
*
* INCREMENT OPCOUNT FOR FORMING SHIFT.
OPS = OPS + 7
S = 1.0D0
C = 1.0D0
P = 0.0D0
MML = M - L
C .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
DO 200 II = 1, MML
I = M - II
F = S * E(I)
B = C * E(I)
R = PYTHAG(F,G)
E(I+1) = R
IF (R .EQ. 0.0D0) GO TO 210
S = F / R
C = G / R
G = D(I+1) - P
R = (D(I) - G) * S + 2.0D0 * C * B
P = S * R
D(I+1) = G + P
G = C * R - B
200 CONTINUE
C
D(L) = D(L) - P
E(L) = G
E(M) = 0.0D0
*
* INCREMENT OPCOUNT FOR INNER LOOP.
OPS = OPS + MML*14 + 1
*
* INCREMENT ITERATION COUNTER
ITCNT = ITCNT + 1
GO TO 105
C .......... RECOVER FROM UNDERFLOW ..........
210 D(I+1) = D(I+1) - P
E(M) = 0.0D0
*
* INCREMENT OPCOUNT FOR INNER LOOP, WHEN UNDERFLOW OCCURS.
OPS = OPS + 2+(II-1)*14 + 1
GO TO 105
C .......... ORDER EIGENVALUES ..........
215 IF (L .EQ. 1) GO TO 250
C .......... FOR I=L STEP -1 UNTIL 2 DO -- ..........
DO 230 II = 2, L
I = L + 2 - II
IF (P .GE. D(I-1)) GO TO 270
D(I) = D(I-1)
230 CONTINUE
C
250 I = 1
270 D(I) = P
290 CONTINUE
C
GO TO 1001
C .......... SET ERROR -- NO CONVERGENCE TO AN
C EIGENVALUE AFTER 40 ITERATIONS ..........
1000 IERR = L
1001 CONTINUE
*
* COMPUTE FINAL OP COUNT
OPS = OPS + OPST
RETURN
END
SUBROUTINE IMTQL2(NM,N,D,E,Z,IERR)
*
* EISPACK ROUTINE. MODIFIED FOR COMPARISON WITH LAPACK.
*
* CONVERGENCE TEST WAS MODIFIED TO BE THE SAME AS IN DSTEQR.
*
C
INTEGER I,J,K,L,M,N,II,NM,MML,IERR
DOUBLE PRECISION D(N),E(N),Z(NM,N)
DOUBLE PRECISION B,C,F,G,P,R,S,TST1,TST2,PYTHAG
DOUBLE PRECISION EPS, TST
DOUBLE PRECISION DLAMCH
external pythag, dlamch
*
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT
* ITCNT IS INITIALIZED TO 0, OPS IS ONLY INCREMENTED
* OPST IS USED TO ACCUMULATE CONTRIBUTIONS TO OPS FROM
* FUNCTION PYTHAG. IT IS PASSED TO AND FROM PYTHAG
* THROUGH COMMON BLOCK PYTHOP.
* .. COMMON BLOCKS ..
COMMON / LATIME / OPS, ITCNT
COMMON / PYTHOP / OPST
* ..
* .. SCALARS IN COMMON ..
DOUBLE PRECISION ITCNT, OPS, OPST
* ..
C
C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE IMTQL2,
C NUM. MATH. 12, 377-383(1968) BY MARTIN AND WILKINSON,
C AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971).
C
C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
C OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE IMPLICIT QL METHOD.
C THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO
C BE FOUND IF TRED2 HAS BEEN USED TO REDUCE THIS
C FULL MATRIX TO TRIDIAGONAL FORM.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRIX.
C
C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
C
C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY.
C
C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
C REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS
C OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN
C THE IDENTITY MATRIX.
C
C ON OUTPUT
C
C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN
C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT
C UNORDERED FOR INDICES 1,2,...,IERR-1.
C
C E HAS BEEN DESTROYED.
C
C Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC
C TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE,
C Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED
C EIGENVALUES.
C
C IERR IS SET TO
C ZERO FOR NORMAL RETURN,
C J IF THE J-TH EIGENVALUE HAS NOT BEEN
C DETERMINED AFTER 40 ITERATIONS.
C
C CALLS PYTHAG FOR SQRT(A*A + B*B) .
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
C
IERR = 0
IF (N .EQ. 1) GO TO 1001
*
* INITIALIZE ITERATION COUNT AND OPST
ITCNT = 0
OPST = 0
*
* DETERMINE UNIT ROUNDOFF FOR THIS MACHINE.
EPS = DLAMCH( 'EPSILON' )
C
DO 100 I = 2, N
100 E(I-1) = E(I)
C
E(N) = 0.0D0
C
DO 240 L = 1, N
J = 0
C .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT ..........
105 DO 110 M = L, N
IF (M .EQ. N) GO TO 120
* TST1 = ABS(D(M)) + ABS(D(M+1))
* TST2 = TST1 + ABS(E(M))
* IF (TST2 .EQ. TST1) GO TO 120
TST = ABS( E(M) )
IF( TST .LE. EPS * ( ABS(D(M)) + ABS(D(M+1)) ) ) GO TO 120
110 CONTINUE
C
120 P = D(L)
*
* INCREMENT OPCOUNT FOR FINDING SMALL SUBDIAGONAL ELEMENT.
OPS = OPS + 2*( MIN(M,N)-L+1 )
IF (M .EQ. L) GO TO 240
IF (J .EQ. 40) GO TO 1000
J = J + 1
C .......... FORM SHIFT ..........
G = (D(L+1) - P) / (2.0D0 * E(L))
R = PYTHAG(G,1.0D0)
G = D(M) - P + E(L) / (G + DSIGN(R,G))
*
* INCREMENT OPCOUNT FOR FORMING SHIFT.
OPS = OPS + 7
S = 1.0D0
C = 1.0D0
P = 0.0D0
MML = M - L
C .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
DO 200 II = 1, MML
I = M - II
F = S * E(I)
B = C * E(I)
R = PYTHAG(F,G)
E(I+1) = R
IF (R .EQ. 0.0D0) GO TO 210
S = F / R
C = G / R
G = D(I+1) - P
R = (D(I) - G) * S + 2.0D0 * C * B
P = S * R
D(I+1) = G + P
G = C * R - B
C .......... FORM VECTOR ..........
DO 180 K = 1, N
F = Z(K,I+1)
Z(K,I+1) = S * Z(K,I) + C * F
Z(K,I) = C * Z(K,I) - S * F
180 CONTINUE
C
200 CONTINUE
C
D(L) = D(L) - P
E(L) = G
E(M) = 0.0D0
*
* INCREMENT OPCOUNT FOR INNER LOOP.
OPS = OPS + MML*( 14+6*N ) + 1
*
* INCREMENT ITERATION COUNTER
ITCNT = ITCNT + 1
GO TO 105
C .......... RECOVER FROM UNDERFLOW ..........
210 D(I+1) = D(I+1) - P
E(M) = 0.0D0
*
* INCREMENT OPCOUNT FOR INNER LOOP, WHEN UNDERFLOW OCCURS.
OPS = OPS + 2+(II-1)*(14+6*N) + 1
GO TO 105
240 CONTINUE
C .......... ORDER EIGENVALUES AND EIGENVECTORS ..........
DO 300 II = 2, N
I = II - 1
K = I
P = D(I)
C
DO 260 J = II, N
IF (D(J) .GE. P) GO TO 260
K = J
P = D(J)
260 CONTINUE
C
IF (K .EQ. I) GO TO 300
D(K) = D(I)
D(I) = P
C
DO 280 J = 1, N
P = Z(J,I)
Z(J,I) = Z(J,K)
Z(J,K) = P
280 CONTINUE
C
300 CONTINUE
C
GO TO 1001
C .......... SET ERROR -- NO CONVERGENCE TO AN
C EIGENVALUE AFTER 40 ITERATIONS ..........
1000 IERR = L
1001 CONTINUE
*
* COMPUTE FINAL OP COUNT
OPS = OPS + OPST
RETURN
END
SUBROUTINE INVIT(NM,N,A,WR,WI,SELECT,MM,M,Z,IERR,RM1,RV1,RV2)
C
INTEGER I,J,K,L,M,N,S,II,IP,MM,MP,NM,NS,N1,UK,IP1,ITS,KM1,IERR
DOUBLE PRECISION A(NM,N),WR(N),WI(N),Z(NM,MM),RM1(N,N),
X RV1(N),RV2(N)
DOUBLE PRECISION T,W,X,Y,EPS3,NORM,NORMV,GROWTO,ILAMBD,
X PYTHAG,RLAMBD,UKROOT
LOGICAL SELECT(N)
external pythag, dlamch
*
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT
* ITCNT IS INITIALIZED TO 0, OPS IS ONLY INCREMENTED
* OPST IS USED TO ACCUMULATE SMALL CONTRIBUTIONS TO OPS
* TO AVOID ROUNDOFF ERROR
* .. COMMON BLOCKS ..
COMMON /LATIME/ OPS, ITCNT
* ..
* .. SCALARS IN COMMON ..
DOUBLE PRECISION OPS, ITCNT, OPST
* ..
C
C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE INVIT
C BY PETERS AND WILKINSON.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971).
C
C THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A REAL UPPER
C HESSENBERG MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES,
C USING INVERSE ITERATION.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRIX.
C
C A CONTAINS THE HESSENBERG MATRIX.
C
C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, RESPECTIVELY,
C OF THE EIGENVALUES OF THE MATRIX. THE EIGENVALUES MUST BE
C STORED IN A MANNER IDENTICAL TO THAT OF SUBROUTINE HQR,
C WHICH RECOGNIZES POSSIBLE SPLITTING OF THE MATRIX.
C
C SELECT SPECIFIES THE EIGENVECTORS TO BE FOUND. THE
C EIGENVECTOR CORRESPONDING TO THE J-TH EIGENVALUE IS
C SPECIFIED BY SETTING SELECT(J) TO .TRUE..
C
C MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF
C COLUMNS REQUIRED TO STORE THE EIGENVECTORS TO BE FOUND.
C NOTE THAT TWO COLUMNS ARE REQUIRED TO STORE THE
C EIGENVECTOR CORRESPONDING TO A COMPLEX EIGENVALUE.
C
C ON OUTPUT
C
C A AND WI ARE UNALTERED.
C
C WR MAY HAVE BEEN ALTERED SINCE CLOSE EIGENVALUES ARE PERTURBED
C SLIGHTLY IN SEARCHING FOR INDEPENDENT EIGENVECTORS.
C
C SELECT MAY HAVE BEEN ALTERED. IF THE ELEMENTS CORRESPONDING
C TO A PAIR OF CONJUGATE COMPLEX EIGENVALUES WERE EACH
C INITIALLY SET TO .TRUE., THE PROGRAM RESETS THE SECOND OF
C THE TWO ELEMENTS TO .FALSE..
C
C M IS THE NUMBER OF COLUMNS ACTUALLY USED TO STORE
C THE EIGENVECTORS.
C
C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS.
C IF THE NEXT SELECTED EIGENVALUE IS REAL, THE NEXT COLUMN
C OF Z CONTAINS ITS EIGENVECTOR. IF THE EIGENVALUE IS
C COMPLEX, THE NEXT TWO COLUMNS OF Z CONTAIN THE REAL AND
C IMAGINARY PARTS OF ITS EIGENVECTOR. THE EIGENVECTORS ARE
C NORMALIZED SO THAT THE COMPONENT OF LARGEST MAGNITUDE IS 1.
C ANY VECTOR WHICH FAILS THE ACCEPTANCE TEST IS SET TO ZERO.
C
C IERR IS SET TO
C ZERO FOR NORMAL RETURN,
C -(2*N+1) IF MORE THAN MM COLUMNS OF Z ARE NECESSARY
C TO STORE THE EIGENVECTORS CORRESPONDING TO
C THE SPECIFIED EIGENVALUES.
C -K IF THE ITERATION CORRESPONDING TO THE K-TH
C VALUE FAILS,
C -(N+K) IF BOTH ERROR SITUATIONS OCCUR.
C
C RM1, RV1, AND RV2 ARE TEMPORARY STORAGE ARRAYS. NOTE THAT RM1
C IS SQUARE OF DIMENSION N BY N AND, AUGMENTED BY TWO COLUMNS
C OF Z, IS THE TRANSPOSE OF THE CORRESPONDING ALGOL B ARRAY.
C
C THE ALGOL PROCEDURE GUESSVEC APPEARS IN INVIT IN LINE.
C
C CALLS CDIV FOR COMPLEX DIVISION.
C CALLS PYTHAG FOR SQRT(A*A + B*B) .
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
*
* GET ULP FROM DLAMCH FOR NEW SMALL PERTURBATION AS IN LAPACK
EXTERNAL DLAMCH
DOUBLE PRECISION DLAMCH, ULP
IF (N.LE.0) RETURN
ULP = DLAMCH( 'EPSILON' )
C
*
* INITIALIZE
OPST = 0
IERR = 0
UK = 0
S = 1
C .......... IP = 0, REAL EIGENVALUE
C 1, FIRST OF CONJUGATE COMPLEX PAIR
C -1, SECOND OF CONJUGATE COMPLEX PAIR ..........
IP = 0
N1 = N - 1
C
DO 980 K = 1, N
IF (WI(K) .EQ. 0.0D0 .OR. IP .LT. 0) GO TO 100
IP = 1
IF (SELECT(K) .AND. SELECT(K+1)) SELECT(K+1) = .FALSE.
100 IF (.NOT. SELECT(K)) GO TO 960
IF (WI(K) .NE. 0.0D0) S = S + 1
IF (S .GT. MM) GO TO 1000
IF (UK .GE. K) GO TO 200
C .......... CHECK FOR POSSIBLE SPLITTING ..........
DO 120 UK = K, N
IF (UK .EQ. N) GO TO 140
IF (A(UK+1,UK) .EQ. 0.0D0) GO TO 140
120 CONTINUE
C .......... COMPUTE INFINITY NORM OF LEADING UK BY UK
C (HESSENBERG) MATRIX ..........
140 NORM = 0.0D0
MP = 1
C
*
* INCREMENT OPCOUNT FOR COMPUTING MATRIX NORM
OPS = OPS + UK*(UK-1)/2
DO 180 I = 1, UK
X = 0.0D0
C
DO 160 J = MP, UK
160 X = X + DABS(A(I,J))
C
IF (X .GT. NORM) NORM = X
MP = I
180 CONTINUE
C .......... EPS3 REPLACES ZERO PIVOT IN DECOMPOSITION
C AND CLOSE ROOTS ARE MODIFIED BY EPS3 ..........
IF (NORM .EQ. 0.0D0) NORM = 1.0D0
* EPS3 = EPSLON(NORM)
*
* INCREMENT OPCOUNT
OPST = OPST + 3
EPS3 = NORM*ULP
C .......... GROWTO IS THE CRITERION FOR THE GROWTH ..........
UKROOT = UK
UKROOT = DSQRT(UKROOT)
GROWTO = 0.1D0 / UKROOT
200 RLAMBD = WR(K)
ILAMBD = WI(K)
IF (K .EQ. 1) GO TO 280
KM1 = K - 1
GO TO 240
C .......... PERTURB EIGENVALUE IF IT IS CLOSE
C TO ANY PREVIOUS EIGENVALUE ..........
220 RLAMBD = RLAMBD + EPS3
C .......... FOR I=K-1 STEP -1 UNTIL 1 DO -- ..........
240 DO 260 II = 1, KM1
I = K - II
IF (SELECT(I) .AND. DABS(WR(I)-RLAMBD) .LT. EPS3 .AND.
X DABS(WI(I)-ILAMBD) .LT. EPS3) GO TO 220
260 CONTINUE
*
* INCREMENT OPCOUNT FOR LOOP 260 (ASSUME THAT ALL EIGENVALUES
* ARE DIFFERENT)
OPST = OPST + 2*(K-1)
C
WR(K) = RLAMBD
C .......... PERTURB CONJUGATE EIGENVALUE TO MATCH ..........
IP1 = K + IP
WR(IP1) = RLAMBD
C .......... FORM UPPER HESSENBERG A-RLAMBD*I (TRANSPOSED)
C AND INITIAL REAL VECTOR ..........
280 MP = 1
C
*
* INCREMENT OP COUNT FOR LOOP 320
OPS = OPS + UK
DO 320 I = 1, UK
C
DO 300 J = MP, UK
300 RM1(J,I) = A(I,J)
C
RM1(I,I) = RM1(I,I) - RLAMBD
MP = I
RV1(I) = EPS3
320 CONTINUE
C
ITS = 0
IF (ILAMBD .NE. 0.0D0) GO TO 520
C .......... REAL EIGENVALUE.
C TRIANGULAR DECOMPOSITION WITH INTERCHANGES,
C REPLACING ZERO PIVOTS BY EPS3 ..........
IF (UK .EQ. 1) GO TO 420
C
*
* INCREMENT OPCOUNT LU DECOMPOSITION
OPS = OPS + (UK-1)*(UK+2)
DO 400 I = 2, UK
MP = I - 1
IF (DABS(RM1(MP,I)) .LE. DABS(RM1(MP,MP))) GO TO 360
C
DO 340 J = MP, UK
Y = RM1(J,I)
RM1(J,I) = RM1(J,MP)
RM1(J,MP) = Y
340 CONTINUE
C
360 IF (RM1(MP,MP) .EQ. 0.0D0) RM1(MP,MP) = EPS3
X = RM1(MP,I) / RM1(MP,MP)
IF (X .EQ. 0.0D0) GO TO 400
C
DO 380 J = I, UK
380 RM1(J,I) = RM1(J,I) - X * RM1(J,MP)
C
400 CONTINUE
C
420 IF (RM1(UK,UK) .EQ. 0.0D0) RM1(UK,UK) = EPS3
C .......... BACK SUBSTITUTION FOR REAL VECTOR
C FOR I=UK STEP -1 UNTIL 1 DO -- ..........
440 DO 500 II = 1, UK
I = UK + 1 - II
Y = RV1(I)
IF (I .EQ. UK) GO TO 480
IP1 = I + 1
C
DO 460 J = IP1, UK
460 Y = Y - RM1(J,I) * RV1(J)
C
480 RV1(I) = Y / RM1(I,I)
500 CONTINUE
*
* INCREMENT OP COUNT FOR BACK SUBSTITUTION LOOP 500
OPS = OPS + UK*(UK+1)
C
GO TO 740
C .......... COMPLEX EIGENVALUE.
C TRIANGULAR DECOMPOSITION WITH INTERCHANGES,
C REPLACING ZERO PIVOTS BY EPS3. STORE IMAGINARY
C PARTS IN UPPER TRIANGLE STARTING AT (1,3) ..........
520 NS = N - S
Z(1,S-1) = -ILAMBD
Z(1,S) = 0.0D0
IF (N .EQ. 2) GO TO 550
RM1(1,3) = -ILAMBD
Z(1,S-1) = 0.0D0
IF (N .EQ. 3) GO TO 550
C
DO 540 I = 4, N
540 RM1(1,I) = 0.0D0
C
550 DO 640 I = 2, UK
MP = I - 1
W = RM1(MP,I)
IF (I .LT. N) T = RM1(MP,I+1)
IF (I .EQ. N) T = Z(MP,S-1)
X = RM1(MP,MP) * RM1(MP,MP) + T * T
IF (W * W .LE. X) GO TO 580
X = RM1(MP,MP) / W
Y = T / W
RM1(MP,MP) = W
IF (I .LT. N) RM1(MP,I+1) = 0.0D0
IF (I .EQ. N) Z(MP,S-1) = 0.0D0
C
*
* INCREMENT OPCOUNT FOR LOOP 560
OPS = OPS + 4*(UK-I+1)
DO 560 J = I, UK
W = RM1(J,I)
RM1(J,I) = RM1(J,MP) - X * W
RM1(J,MP) = W
IF (J .LT. N1) GO TO 555
L = J - NS
Z(I,L) = Z(MP,L) - Y * W
Z(MP,L) = 0.0D0
GO TO 560
555 RM1(I,J+2) = RM1(MP,J+2) - Y * W
RM1(MP,J+2) = 0.0D0
560 CONTINUE
C
RM1(I,I) = RM1(I,I) - Y * ILAMBD
IF (I .LT. N1) GO TO 570
L = I - NS
Z(MP,L) = -ILAMBD
Z(I,L) = Z(I,L) + X * ILAMBD
GO TO 640
570 RM1(MP,I+2) = -ILAMBD
RM1(I,I+2) = RM1(I,I+2) + X * ILAMBD
GO TO 640
580 IF (X .NE. 0.0D0) GO TO 600
RM1(MP,MP) = EPS3
IF (I .LT. N) RM1(MP,I+1) = 0.0D0
IF (I .EQ. N) Z(MP,S-1) = 0.0D0
T = 0.0D0
X = EPS3 * EPS3
600 W = W / X
X = RM1(MP,MP) * W
Y = -T * W
C
*
* INCREMENT OPCOUNT FOR LOOP 620
OPS = OPS + 6*(UK-I+1)
DO 620 J = I, UK
IF (J .LT. N1) GO TO 610
L = J - NS
T = Z(MP,L)
Z(I,L) = -X * T - Y * RM1(J,MP)
GO TO 615
610 T = RM1(MP,J+2)
RM1(I,J+2) = -X * T - Y * RM1(J,MP)
615 RM1(J,I) = RM1(J,I) - X * RM1(J,MP) + Y * T
620 CONTINUE
C
IF (I .LT. N1) GO TO 630
L = I - NS
Z(I,L) = Z(I,L) - ILAMBD
GO TO 640
630 RM1(I,I+2) = RM1(I,I+2) - ILAMBD
640 CONTINUE
*
* INCREMENT OP COUNT (AVERAGE) FOR COMPUTING
* THE SCALARS IN LOOP 640
OPS = OPS + 10*(UK -1)
C
IF (UK .LT. N1) GO TO 650
L = UK - NS
T = Z(UK,L)
GO TO 655
650 T = RM1(UK,UK+2)
655 IF (RM1(UK,UK) .EQ. 0.0D0 .AND. T .EQ. 0.0D0) RM1(UK,UK) = EPS3
C .......... BACK SUBSTITUTION FOR COMPLEX VECTOR
C FOR I=UK STEP -1 UNTIL 1 DO -- ..........
660 DO 720 II = 1, UK
I = UK + 1 - II
X = RV1(I)
Y = 0.0D0
IF (I .EQ. UK) GO TO 700
IP1 = I + 1
C
DO 680 J = IP1, UK
IF (J .LT. N1) GO TO 670
L = J - NS
T = Z(I,L)
GO TO 675
670 T = RM1(I,J+2)
675 X = X - RM1(J,I) * RV1(J) + T * RV2(J)
Y = Y - RM1(J,I) * RV2(J) - T * RV1(J)
680 CONTINUE
C
700 IF (I .LT. N1) GO TO 710
L = I - NS
T = Z(I,L)
GO TO 715
710 T = RM1(I,I+2)
715 CALL CDIV(X,Y,RM1(I,I),T,RV1(I),RV2(I))
720 CONTINUE
*
* INCREMENT OP COUNT FOR LOOP 720.
OPS = OPS + 4*UK*(UK+3)
C .......... ACCEPTANCE TEST FOR REAL OR COMPLEX
C EIGENVECTOR AND NORMALIZATION ..........
740 ITS = ITS + 1
NORM = 0.0D0
NORMV = 0.0D0
C
DO 780 I = 1, UK
IF (ILAMBD .EQ. 0.0D0) X = DABS(RV1(I))
IF (ILAMBD .NE. 0.0D0) X = PYTHAG(RV1(I),RV2(I))
IF (NORMV .GE. X) GO TO 760
NORMV = X
J = I
760 NORM = NORM + X
780 CONTINUE
*
* INCREMENT OP COUNT ACCEPTANCE TEST
IF (ILAMBD .EQ. 0.0D0) OPS = OPS + UK
IF (ILAMBD .NE. 0.0D0) OPS = OPS + 16*UK
C
IF (NORM .LT. GROWTO) GO TO 840
C .......... ACCEPT VECTOR ..........
X = RV1(J)
IF (ILAMBD .EQ. 0.0D0) X = 1.0D0 / X
IF (ILAMBD .NE. 0.0D0) Y = RV2(J)
C
*
* INCREMENT OPCOUNT FOR LOOP 820
IF (ILAMBD .EQ. 0.0D0) OPS = OPS + UK
IF (ILAMBD .NE. 0.0D0) OPS = OPS + 16*UK
DO 820 I = 1, UK
IF (ILAMBD .NE. 0.0D0) GO TO 800
Z(I,S) = RV1(I) * X
GO TO 820
800 CALL CDIV(RV1(I),RV2(I),X,Y,Z(I,S-1),Z(I,S))
820 CONTINUE
C
IF (UK .EQ. N) GO TO 940
J = UK + 1
GO TO 900
C .......... IN-LINE PROCEDURE FOR CHOOSING
C A NEW STARTING VECTOR ..........
840 IF (ITS .GE. UK) GO TO 880
X = UKROOT
Y = EPS3 / (X + 1.0D0)
RV1(1) = EPS3
C
DO 860 I = 2, UK
860 RV1(I) = Y
C
J = UK - ITS + 1
RV1(J) = RV1(J) - EPS3 * X
IF (ILAMBD .EQ. 0.0D0) GO TO 440
GO TO 660
C .......... SET ERROR -- UNACCEPTED EIGENVECTOR ..........
880 J = 1
IERR = -K
C .......... SET REMAINING VECTOR COMPONENTS TO ZERO ..........
900 DO 920 I = J, N
Z(I,S) = 0.0D0
IF (ILAMBD .NE. 0.0D0) Z(I,S-1) = 0.0D0
920 CONTINUE
C
940 S = S + 1
960 IF (IP .EQ. (-1)) IP = 0
IF (IP .EQ. 1) IP = -1
980 CONTINUE
C
GO TO 1001
C .......... SET ERROR -- UNDERESTIMATE OF EIGENVECTOR
C SPACE REQUIRED ..........
1000 IF (IERR .NE. 0) IERR = IERR - N
IF (IERR .EQ. 0) IERR = -(2 * N + 1)
1001 M = S - 1 - IABS(IP)
*
* COMPUTE FINAL OP COUNT
OPS = OPS + OPST
RETURN
END
SUBROUTINE ORTHES(NM,N,LOW,IGH,A,ORT)
C
INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
DOUBLE PRECISION A(NM,N),ORT(IGH)
DOUBLE PRECISION F,G,H,SCALE
*
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT
* ITCNT IS INITIALIZED TO 0, OPS IS ONLY INCREMENTED
* OPST IS USED TO ACCUMULATE SMALL CONTRIBUTIONS TO OPS
* TO AVOID ROUNDOFF ERROR
* .. COMMON BLOCKS ..
COMMON /LATIME/ OPS, ITCNT
* ..
* .. SCALARS IN COMMON ..
DOUBLE PRECISION OPS, ITCNT, OPST
* ..
C
C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTHES,
C NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
C
C GIVEN A REAL GENERAL MATRIX, THIS SUBROUTINE
C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
C ORTHOGONAL SIMILARITY TRANSFORMATIONS.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRIX.
C
C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED,
C SET LOW=1, IGH=N.
C
C A CONTAINS THE INPUT MATRIX.
C
C ON OUTPUT
C
C A CONTAINS THE HESSENBERG MATRIX. INFORMATION ABOUT
C THE ORTHOGONAL TRANSFORMATIONS USED IN THE REDUCTION
C IS STORED IN THE REMAINING TRIANGLE UNDER THE
C HESSENBERG MATRIX.
C
C ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS.
C ONLY ELEMENTS LOW THROUGH IGH ARE USED.
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
C
IF (N.LE.0) RETURN
LA = IGH - 1
KP1 = LOW + 1
IF (LA .LT. KP1) GO TO 200
C
*
* INCREMENT OP COUNR FOR COMPUTING G,H,ORT(M),.. IN LOOP 180
OPS = OPS + 6*(LA - KP1 + 1)
DO 180 M = KP1, LA
H = 0.0D0
ORT(M) = 0.0D0
SCALE = 0.0D0
C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
*
* INCREMENT OP COUNT FOR LOOP 90
OPS = OPS + (IGH-M +1)
DO 90 I = M, IGH
90 SCALE = SCALE + DABS(A(I,M-1))
C
IF (SCALE .EQ. 0.0D0) GO TO 180
MP = M + IGH
C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
*
* INCREMENT OP COUNT FOR LOOP 100
OPS = OPS + 3*(IGH-M+1)
DO 100 II = M, IGH
I = MP - II
ORT(I) = A(I,M-1) / SCALE
H = H + ORT(I) * ORT(I)
100 CONTINUE
C
G = -DSIGN(DSQRT(H),ORT(M))
H = H - ORT(M) * G
ORT(M) = ORT(M) - G
C .......... FORM (I-(U*UT)/H) * A ..........
*
* INCREMENT OP COUNT FOR LOOP 130 AND 160
OPS = OPS + (N-M+1+IGH)*(4*(IGH-M+1) + 1)
DO 130 J = M, N
F = 0.0D0
C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
DO 110 II = M, IGH
I = MP - II
F = F + ORT(I) * A(I,J)
110 CONTINUE
C
F = F / H
C
DO 120 I = M, IGH
120 A(I,J) = A(I,J) - F * ORT(I)
C
130 CONTINUE
C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
DO 160 I = 1, IGH
F = 0.0D0
C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
DO 140 JJ = M, IGH
J = MP - JJ
F = F + ORT(J) * A(I,J)
140 CONTINUE
C
F = F / H
C
DO 150 J = M, IGH
150 A(I,J) = A(I,J) - F * ORT(J)
C
160 CONTINUE
C
ORT(M) = SCALE * ORT(M)
A(M,M-1) = SCALE * G
180 CONTINUE
C
200 RETURN
END
DOUBLE PRECISION FUNCTION PYTHAG(A,B)
DOUBLE PRECISION A,B
C
C FINDS SQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
C
*
* COMMON BLOCK TO RETURN OPERATION COUNT
* OPST IS ONLY INCREMENTED HERE
* .. COMMON BLOCKS ..
COMMON / PYTHOP / OPST
* ..
* .. SCALARS IN COMMON
DOUBLE PRECISION OPST
* ..
DOUBLE PRECISION P,R,S,T,U
P = DMAX1(DABS(A),DABS(B))
IF (P .EQ. 0.0D0) GO TO 20
R = (DMIN1(DABS(A),DABS(B))/P)**2
*
* INCREMENT OPST
OPST = OPST + 2
10 CONTINUE
T = 4.0D0 + R
IF (T .EQ. 4.0D0) GO TO 20
S = R/T
U = 1.0D0 + 2.0D0*S
P = U*P
R = (S/U)**2 * R
*
* INCREMENT OPST
OPST = OPST + 8
GO TO 10
20 PYTHAG = P
RETURN
END
SUBROUTINE TQLRAT(N,D,E2,IERR)
*
* EISPACK ROUTINE.
* MODIFIED FOR COMPARISON WITH LAPACK ROUTINES.
*
* CONVERGENCE TEST WAS MODIFIED TO BE THE SAME AS IN DSTEQR.
*
C
INTEGER I,J,L,M,N,II,L1,MML,IERR
DOUBLE PRECISION D(N),E2(N)
DOUBLE PRECISION B,C,F,G,H,P,R,S,T,EPSLON,PYTHAG
DOUBLE PRECISION EPS, TST
DOUBLE PRECISION DLAMCH
external pythag, dlamch, epslon
*
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT
* ITCNT IS INITIALIZED TO 0, OPS IS ONLY INCREMENTED
* OPST IS USED TO ACCUMULATE CONTRIBUTIONS TO OPS FROM
* FUNCTION PYTHAG. IT IS PASSED TO AND FROM PYTHAG
* THROUGH COMMON BLOCK PYTHOP.
* .. COMMON BLOCKS ..
COMMON / LATIME / OPS, ITCNT
COMMON / PYTHOP / OPST
* ..
* .. SCALARS IN COMMON ..
DOUBLE PRECISION ITCNT, OPS, OPST
* ..
C
C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQLRAT,
C ALGORITHM 464, COMM. ACM 16, 689(1973) BY REINSCH.
C
C THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC
C TRIDIAGONAL MATRIX BY THE RATIONAL QL METHOD.
C
C ON INPUT
C
C N IS THE ORDER OF THE MATRIX.
C
C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
C
C E2 CONTAINS THE SQUARES OF THE SUBDIAGONAL ELEMENTS OF THE
C INPUT MATRIX IN ITS LAST N-1 POSITIONS. E2(1) IS ARBITRARY.
C
C ON OUTPUT
C
C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN
C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND
C ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE
C THE SMALLEST EIGENVALUES.
C
C E2 HAS BEEN DESTROYED.
C
C IERR IS SET TO
C ZERO FOR NORMAL RETURN,
C J IF THE J-TH EIGENVALUE HAS NOT BEEN
C DETERMINED AFTER 30 ITERATIONS.
C
C CALLS PYTHAG FOR SQRT(A*A + B*B) .
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
C
IERR = 0
IF (N .EQ. 1) GO TO 1001
*
* INITIALIZE ITERATION COUNT AND OPST
ITCNT = 0
OPST = 0
*
* DETERMINE THE UNIT ROUNDOFF FOR THIS ENVIRONMENT.
*
EPS = DLAMCH( 'EPSILON' )
C
DO 100 I = 2, N
100 E2(I-1) = E2(I)
C
F = 0.0D0
T = 0.0D0
E2(N) = 0.0D0
C
DO 290 L = 1, N
J = 0
H = DABS(D(L)) + DSQRT(E2(L))
IF (T .GT. H) GO TO 105
T = H
B = EPSLON(T)
C = B * B
*
* INCREMENT OPCOUNT FOR THIS SECTION.
* (FUNCTION EPSLON IS COUNTED AS 6 FLOPS. THIS IS THE MINIMUM
* NUMBER REQUIRED, BUT COUNTING THEM EXACTLY WOULD AFFECT
* THE TIMING.)
OPS = OPS + 9
C .......... LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT ..........
105 DO 110 M = L, N
IF( M .EQ. N ) GO TO 120
TST = SQRT( ABS( E2(M) ) )
IF( TST .LE. EPS * ( ABS(D(M)) + ABS(D(M+1)) ) ) GO TO 120
* IF (E2(M) .LE. C) GO TO 120
C .......... E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
C THROUGH THE BOTTOM OF THE LOOP ..........
110 CONTINUE
C
120 CONTINUE
*
* INCREMENT OPCOUNT FOR FINDING SMALL SUBDIAGONAL ELEMENT.
OPS = OPS + 3*( MIN(M,N-1)-L+1 )
IF (M .EQ. L) GO TO 210
130 IF (J .EQ. 30) GO TO 1000
J = J + 1
C .......... FORM SHIFT ..........
L1 = L + 1
S = DSQRT(E2(L))
G = D(L)
P = (D(L1) - G) / (2.0D0 * S)
R = PYTHAG(P,1.0D0)
D(L) = S / (P + DSIGN(R,P))
H = G - D(L)
C
DO 140 I = L1, N
140 D(I) = D(I) - H
C
F = F + H
*
* INCREMENT OPCOUNT FOR FORMING SHIFT AND SUBTRACTING.
OPS = OPS + 8 + (I-L1+1)
C .......... RATIONAL QL TRANSFORMATION ..........
G = D(M)
IF (G .EQ. 0.0D0) G = B
H = G
S = 0.0D0
MML = M - L
C .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
DO 200 II = 1, MML
I = M - II
P = G * H
R = P + E2(I)
E2(I+1) = S * R
S = E2(I) / R
D(I+1) = H + S * (H + D(I))
G = D(I) - E2(I) / G
IF (G .EQ. 0.0D0) G = B
H = G * P / R
200 CONTINUE
C
E2(L) = S * G
D(L) = H
*
* INCREMENT OPCOUNT FOR INNER LOOP.
OPS = OPS + MML*11 + 1
*
* INCREMENT ITERATION COUNTER
ITCNT = ITCNT + 1
C .......... GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST ..........
IF (H .EQ. 0.0D0) GO TO 210
IF (DABS(E2(L)) .LE. DABS(C/H)) GO TO 210
E2(L) = H * E2(L)
IF (E2(L) .NE. 0.0D0) GO TO 130
210 P = D(L) + F
C .......... ORDER EIGENVALUES ..........
IF (L .EQ. 1) GO TO 250
C .......... FOR I=L STEP -1 UNTIL 2 DO -- ..........
DO 230 II = 2, L
I = L + 2 - II
IF (P .GE. D(I-1)) GO TO 270
D(I) = D(I-1)
230 CONTINUE
C
250 I = 1
270 D(I) = P
290 CONTINUE
C
GO TO 1001
C .......... SET ERROR -- NO CONVERGENCE TO AN
C EIGENVALUE AFTER 30 ITERATIONS ..........
1000 IERR = L
1001 CONTINUE
*
* COMPUTE FINAL OP COUNT
OPS = OPS + OPST
RETURN
END
SUBROUTINE TRED1(NM,N,A,D,E,E2)
C
INTEGER I,J,K,L,N,II,NM,JP1
DOUBLE PRECISION A(NM,N),D(N),E(N),E2(N)
DOUBLE PRECISION F,G,H,SCALE
*
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT.
* ITCNT IS INITIALIZED TO 0, OPS IS ONLY INCREMENTED.
* .. COMMON BLOCKS ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. SCALARS IN COMMON ..
DOUBLE PRECISION ITCNT, OPS
* ..
C
C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED1,
C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C
C THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX
C TO A SYMMETRIC TRIDIAGONAL MATRIX USING
C ORTHOGONAL SIMILARITY TRANSFORMATIONS.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRIX.
C
C A CONTAINS THE REAL SYMMETRIC INPUT MATRIX. ONLY THE
C LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED.
C
C ON OUTPUT
C
C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS-
C FORMATIONS USED IN THE REDUCTION IN ITS STRICT LOWER
C TRIANGLE. THE FULL UPPER TRIANGLE OF A IS UNALTERED.
C
C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX.
C
C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO.
C
C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
C
*
OPS = OPS + MAX( 0.0D0, (4.0D0/3.0D0)*DBLE(N)**3 +
$ 12.0D0*DBLE(N)**2 +
$ (11.0D0/3.0D0)*N - 22 )
*
DO 100 I = 1, N
D(I) = A(N,I)
A(N,I) = A(I,I)
100 CONTINUE
C .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........
DO 300 II = 1, N
I = N + 1 - II
L = I - 1
H = 0.0D0
SCALE = 0.0D0
IF (L .LT. 1) GO TO 130
C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) ..........
DO 120 K = 1, L
120 SCALE = SCALE + DABS(D(K))
C
IF (SCALE .NE. 0.0D0) GO TO 140
C
DO 125 J = 1, L
D(J) = A(L,J)
A(L,J) = A(I,J)
A(I,J) = 0.0D0
125 CONTINUE
C
130 E(I) = 0.0D0
E2(I) = 0.0D0
GO TO 300
C
140 DO 150 K = 1, L
D(K) = D(K) / SCALE
H = H + D(K) * D(K)
150 CONTINUE
C
E2(I) = SCALE * SCALE * H
F = D(L)
G = -DSIGN(DSQRT(H),F)
E(I) = SCALE * G
H = H - F * G
D(L) = F - G
IF (L .EQ. 1) GO TO 285
C .......... FORM A*U ..........
DO 170 J = 1, L
170 E(J) = 0.0D0
C
DO 240 J = 1, L
F = D(J)
G = E(J) + A(J,J) * F
JP1 = J + 1
IF (L .LT. JP1) GO TO 220
C
DO 200 K = JP1, L
G = G + A(K,J) * D(K)
E(K) = E(K) + A(K,J) * F
200 CONTINUE
C
220 E(J) = G
240 CONTINUE
C .......... FORM P ..........
F = 0.0D0
C
DO 245 J = 1, L
E(J) = E(J) / H
F = F + E(J) * D(J)
245 CONTINUE
C
H = F / (H + H)
C .......... FORM Q ..........
DO 250 J = 1, L
250 E(J) = E(J) - H * D(J)
C .......... FORM REDUCED A ..........
DO 280 J = 1, L
F = D(J)
G = E(J)
C
DO 260 K = J, L
260 A(K,J) = A(K,J) - F * E(K) - G * D(K)
C
280 CONTINUE
C
285 DO 290 J = 1, L
F = D(J)
D(J) = A(L,J)
A(L,J) = A(I,J)
A(I,J) = F * SCALE
290 CONTINUE
C
300 CONTINUE
C
RETURN
END
SUBROUTINE BISECT(N,EPS1,D,E,E2,LB,UB,MM,M,W,IND,IERR,RV4,RV5)
*
* EISPACK ROUTINE.
* MODIFIED FOR COMPARISON WITH LAPACK ROUTINES.
*
* CONVERGENCE TEST WAS MODIFIED TO BE THE SAME AS IN DSTEBZ.
*
C
INTEGER I,J,K,L,M,N,P,Q,R,S,II,MM,M1,M2,TAG,IERR,ISTURM
DOUBLE PRECISION D(N),E(N),E2(N),W(MM),RV4(N),RV5(N)
DOUBLE PRECISION U,V,LB,T1,T2,UB,XU,X0,X1,EPS1,TST1,TST2,EPSLON
INTEGER IND(MM)
external epslon
*
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT
* ITCNT IS INITIALIZED TO 0, OPS IS ONLY INCREMENTED
* .. COMMON BLOCKS ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. SCALARS IN COMMON ..
DOUBLE PRECISION ITCNT, OPS
* ..
C
C THIS SUBROUTINE IS A TRANSLATION OF THE BISECTION TECHNIQUE
C IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971).
C
C THIS SUBROUTINE FINDS THOSE EIGENVALUES OF A TRIDIAGONAL
C SYMMETRIC MATRIX WHICH LIE IN A SPECIFIED INTERVAL,
C USING BISECTION.
C
C ON INPUT
C
C N IS THE ORDER OF THE MATRIX.
C
C EPS1 IS AN ABSOLUTE ERROR TOLERANCE FOR THE COMPUTED
C EIGENVALUES. IF THE INPUT EPS1 IS NON-POSITIVE,
C IT IS RESET FOR EACH SUBMATRIX TO A DEFAULT VALUE,
C NAMELY, MINUS THE PRODUCT OF THE RELATIVE MACHINE
C PRECISION AND THE 1-NORM OF THE SUBMATRIX.
C
C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
C
C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY.
C
C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
C E2(1) IS ARBITRARY.
C
C LB AND UB DEFINE THE INTERVAL TO BE SEARCHED FOR EIGENVALUES.
C IF LB IS NOT LESS THAN UB, NO EIGENVALUES WILL BE FOUND.
C
C MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF
C EIGENVALUES IN THE INTERVAL. WARNING. IF MORE THAN
C MM EIGENVALUES ARE DETERMINED TO LIE IN THE INTERVAL,
C AN ERROR RETURN IS MADE WITH NO EIGENVALUES FOUND.
C
C ON OUTPUT
C
C EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS
C (LAST) DEFAULT VALUE.
C
C D AND E ARE UNALTERED.
C
C ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED
C AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE
C MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES.
C E2(1) IS ALSO SET TO ZERO.
C
C M IS THE NUMBER OF EIGENVALUES DETERMINED TO LIE IN (LB,UB).
C
C W CONTAINS THE M EIGENVALUES IN ASCENDING ORDER.
C
C IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES
C ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W --
C 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM
C THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC..
C
C IERR IS SET TO
C ZERO FOR NORMAL RETURN,
C 3*N+1 IF M EXCEEDS MM.
C
C RV4 AND RV5 ARE TEMPORARY STORAGE ARRAYS.
C
C THE ALGOL PROCEDURE STURMCNT CONTAINED IN TRISTURM
C APPEARS IN BISECT IN-LINE.
C
C NOTE THAT SUBROUTINE TQL1 OR IMTQL1 IS GENERALLY FASTER THAN
C BISECT, IF MORE THAN N/4 EIGENVALUES ARE TO BE FOUND.
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
C
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION RELFAC
PARAMETER ( RELFAC = 2.0D0 )
DOUBLE PRECISION ATOLI, RTOLI, SAFEMN, TMP1, TMP2, TNORM, ULP
DOUBLE PRECISION DLAMCH, PIVMIN
EXTERNAL DLAMCH
* INITIALIZE ITERATION COUNT.
ITCNT = 0
SAFEMN = DLAMCH( 'S' )
ULP = DLAMCH( 'E' )*DLAMCH( 'B' )
RTOLI = ULP*RELFAC
IERR = 0
TAG = 0
T1 = LB
T2 = UB
C .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES ..........
DO 40 I = 1, N
IF (I .EQ. 1) GO TO 20
CCC TST1 = DABS(D(I)) + DABS(D(I-1))
CCC TST2 = TST1 + DABS(E(I))
CCC IF (TST2 .GT. TST1) GO TO 40
TMP1 = E( I )**2
IF( ABS( D(I)*D(I-1) )*ULP**2+SAFEMN.LE.TMP1 )
$ GO TO 40
20 E2(I) = 0.0D0
40 CONTINUE
* INCREMENT OPCOUNT FOR DETERMINING IF MATRIX SPLITS.
OPS = OPS + 5*( N-1 )
C
C COMPUTE QUANTITIES NEEDED FOR CONVERGENCE TEST.
TMP1 = D( 1 ) - ABS( E( 2 ) )
TMP2 = D( 1 ) + ABS( E( 2 ) )
PIVMIN = ONE
DO 41 I = 2, N - 1
TMP1 = MIN( TMP1, D( I )-ABS( E( I ) )-ABS( E( I+1 ) ) )
TMP2 = MAX( TMP2, D( I )+ABS( E( I ) )+ABS( E( I+1 ) ) )
PIVMIN = MAX( PIVMIN, E( I )**2 )
41 CONTINUE
TMP1 = MIN( TMP1, D( N )-ABS( E( N ) ) )
TMP2 = MAX( TMP2, D( N )+ABS( E( N ) ) )
PIVMIN = MAX( PIVMIN, E( N )**2 )
PIVMIN = PIVMIN*SAFEMN
TNORM = MAX( ABS(TMP1), ABS(TMP2) )
ATOLI = ULP*TNORM
* INCREMENT OPCOUNT FOR COMPUTING THESE QUANTITIES.
OPS = OPS + 4*( N-1 )
C
C .......... DETERMINE THE NUMBER OF EIGENVALUES
C IN THE INTERVAL ..........
P = 1
Q = N
X1 = UB
ISTURM = 1
GO TO 320
60 M = S
X1 = LB
ISTURM = 2
GO TO 320
80 M = M - S
IF (M .GT. MM) GO TO 980
Q = 0
R = 0
C .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING
C INTERVAL BY THE GERSCHGORIN BOUNDS ..........
100 IF (R .EQ. M) GO TO 1001
TAG = TAG + 1
P = Q + 1
XU = D(P)
X0 = D(P)
U = 0.0D0
C
DO 120 Q = P, N
X1 = U
U = 0.0D0
V = 0.0D0
IF (Q .EQ. N) GO TO 110
U = DABS(E(Q+1))
V = E2(Q+1)
110 XU = DMIN1(D(Q)-(X1+U),XU)
X0 = DMAX1(D(Q)+(X1+U),X0)
IF (V .EQ. 0.0D0) GO TO 140
120 CONTINUE
* INCREMENT OPCOUNT FOR REFINING INTERVAL.
OPS = OPS + ( N-P+1 )*2
C
140 X1 = EPSLON(DMAX1(DABS(XU),DABS(X0)))
IF (EPS1 .LE. 0.0D0) EPS1 = -X1
IF (P .NE. Q) GO TO 180
C .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL ..........
IF (T1 .GT. D(P) .OR. D(P) .GE. T2) GO TO 940
M1 = P
M2 = P
RV5(P) = D(P)
GO TO 900
180 X1 = X1 * (Q - P + 1)
LB = DMAX1(T1,XU-X1)
UB = DMIN1(T2,X0+X1)
X1 = LB
ISTURM = 3
GO TO 320
200 M1 = S + 1
X1 = UB
ISTURM = 4
GO TO 320
220 M2 = S
IF (M1 .GT. M2) GO TO 940
C .......... FIND ROOTS BY BISECTION ..........
X0 = UB
ISTURM = 5
C
DO 240 I = M1, M2
RV5(I) = UB
RV4(I) = LB
240 CONTINUE
C .......... LOOP FOR K-TH EIGENVALUE
C FOR K=M2 STEP -1 UNTIL M1 DO --
C (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) ..........
K = M2
250 XU = LB
C .......... FOR I=K STEP -1 UNTIL M1 DO -- ..........
DO 260 II = M1, K
I = M1 + K - II
IF (XU .GE. RV4(I)) GO TO 260
XU = RV4(I)
GO TO 280
260 CONTINUE
C
280 IF (X0 .GT. RV5(K)) X0 = RV5(K)
C .......... NEXT BISECTION STEP ..........
300 X1 = (XU + X0) * 0.5D0
CCC IF ((X0 - XU) .LE. DABS(EPS1)) GO TO 420
CCC TST1 = 2.0D0 * (DABS(XU) + DABS(X0))
CCC TST2 = TST1 + (X0 - XU)
CCC IF (TST2 .EQ. TST1) GO TO 420
TMP1 = ABS( X0 - XU )
TMP2 = MAX( ABS( X0 ), ABS( XU ) )
IF( TMP1.LT.MAX( ATOLI, PIVMIN, RTOLI*TMP2 ) )
$ GO TO 420
C .......... IN-LINE PROCEDURE FOR STURM SEQUENCE ..........
320 S = P - 1
U = 1.0D0
C
DO 340 I = P, Q
IF (U .NE. 0.0D0) GO TO 325
V = DABS(E(I)) / EPSLON(1.0D0)
IF (E2(I) .EQ. 0.0D0) V = 0.0D0
GO TO 330
325 V = E2(I) / U
330 U = D(I) - X1 - V
IF (U .LT. 0.0D0) S = S + 1
340 CONTINUE
* INCREMENT OPCOUNT FOR STURM SEQUENCE.
OPS = OPS + ( Q-P+1 )*3
* INCREMENT ITERATION COUNTER.
ITCNT = ITCNT + 1
C
GO TO (60,80,200,220,360), ISTURM
C .......... REFINE INTERVALS ..........
360 IF (S .GE. K) GO TO 400
XU = X1
IF (S .GE. M1) GO TO 380
RV4(M1) = X1
GO TO 300
380 RV4(S+1) = X1
IF (RV5(S) .GT. X1) RV5(S) = X1
GO TO 300
400 X0 = X1
GO TO 300
C .......... K-TH EIGENVALUE FOUND ..........
420 RV5(K) = X1
K = K - 1
IF (K .GE. M1) GO TO 250
C .......... ORDER EIGENVALUES TAGGED WITH THEIR
C SUBMATRIX ASSOCIATIONS ..........
900 S = R
R = R + M2 - M1 + 1
J = 1
K = M1
C
DO 920 L = 1, R
IF (J .GT. S) GO TO 910
IF (K .GT. M2) GO TO 940
IF (RV5(K) .GE. W(L)) GO TO 915
C
DO 905 II = J, S
I = L + S - II
W(I+1) = W(I)
IND(I+1) = IND(I)
905 CONTINUE
C
910 W(L) = RV5(K)
IND(L) = TAG
K = K + 1
GO TO 920
915 J = J + 1
920 CONTINUE
C
940 IF (Q .LT. N) GO TO 100
GO TO 1001
C .......... SET ERROR -- UNDERESTIMATE OF NUMBER OF
C EIGENVALUES IN INTERVAL ..........
980 IERR = 3 * N + 1
1001 LB = T1
UB = T2
RETURN
END
SUBROUTINE TINVIT(NM,N,D,E,E2,M,W,IND,Z,
X IERR,RV1,RV2,RV3,RV4,RV6)
*
* EISPACK ROUTINE.
*
* CONVERGENCE TEST WAS NOT MODIFIED, SINCE IT SHOULD GIVE
* APPROXIMATELY THE SAME LEVEL OF ACCURACY AS LAPACK ROUTINE,
* ALTHOUGH THE EIGENVECTORS MAY NOT BE AS CLOSE TO ORTHOGONAL.
*
C
INTEGER I,J,M,N,P,Q,R,S,II,IP,JJ,NM,ITS,TAG,IERR,GROUP
DOUBLE PRECISION D(N),E(N),E2(N),W(M),Z(NM,M),
X RV1(N),RV2(N),RV3(N),RV4(N),RV6(N)
DOUBLE PRECISION U,V,UK,XU,X0,X1,EPS2,EPS3,EPS4,NORM,ORDER,EPSLON,
X PYTHAG
INTEGER IND(M)
external pythag, dlamch, epslon
*
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT
* ITCNT IS INITIALIZED TO 0, OPS IS ONLY INCREMENTED
* .. COMMON BLOCKS ..
COMMON / LATIME / OPS, ITCNT
COMMON / PYTHOP / OPST
* ..
* .. SCALARS IN COMMON ..
DOUBLE PRECISION ITCNT, OPS, OPST
* ..
C
C THIS SUBROUTINE IS A TRANSLATION OF THE INVERSE ITERATION TECH-
C NIQUE IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971).
C
C THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A TRIDIAGONAL
C SYMMETRIC MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES,
C USING INVERSE ITERATION.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRIX.
C
C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
C
C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY.
C
C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E,
C WITH ZEROS CORRESPONDING TO NEGLIGIBLE ELEMENTS OF E.
C E(I) IS CONSIDERED NEGLIGIBLE IF IT IS NOT LARGER THAN
C THE PRODUCT OF THE RELATIVE MACHINE PRECISION AND THE SUM
C OF THE MAGNITUDES OF D(I) AND D(I-1). E2(1) MUST CONTAIN
C 0.0D0 IF THE EIGENVALUES ARE IN ASCENDING ORDER, OR 2.0D0
C IF THE EIGENVALUES ARE IN DESCENDING ORDER. IF BISECT,
C TRIDIB, OR IMTQLV HAS BEEN USED TO FIND THE EIGENVALUES,
C THEIR OUTPUT E2 ARRAY IS EXACTLY WHAT IS EXPECTED HERE.
C
C M IS THE NUMBER OF SPECIFIED EIGENVALUES.
C
C W CONTAINS THE M EIGENVALUES IN ASCENDING OR DESCENDING ORDER.
C
C IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES
C ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W --
C 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM
C THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC.
C
C ON OUTPUT
C
C ALL INPUT ARRAYS ARE UNALTERED.
C
C Z CONTAINS THE ASSOCIATED SET OF ORTHONORMAL EIGENVECTORS.
C ANY VECTOR WHICH FAILS TO CONVERGE IS SET TO ZERO.
C
C IERR IS SET TO
C ZERO FOR NORMAL RETURN,
C -R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH
C EIGENVALUE FAILS TO CONVERGE IN 5 ITERATIONS.
C
C RV1, RV2, RV3, RV4, AND RV6 ARE TEMPORARY STORAGE ARRAYS.
C
C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
C
* INITIALIZE ITERATION COUNT.
ITCNT = 0
IERR = 0
IF (M .EQ. 0) GO TO 1001
TAG = 0
ORDER = 1.0D0 - E2(1)
Q = 0
C .......... ESTABLISH AND PROCESS NEXT SUBMATRIX ..........
100 P = Q + 1
C
DO 120 Q = P, N
IF (Q .EQ. N) GO TO 140
IF (E2(Q+1) .EQ. 0.0D0) GO TO 140
120 CONTINUE
C .......... FIND VECTORS BY INVERSE ITERATION ..........
140 TAG = TAG + 1
S = 0
C
DO 920 R = 1, M
IF (IND(R) .NE. TAG) GO TO 920
ITS = 1
X1 = W(R)
IF (S .NE. 0) GO TO 510
C .......... CHECK FOR ISOLATED ROOT ..........
XU = 1.0D0
IF (P .NE. Q) GO TO 490
RV6(P) = 1.0D0
GO TO 870
490 NORM = DABS(D(P))
IP = P + 1
C
DO 500 I = IP, Q
500 NORM = DMAX1(NORM, DABS(D(I))+DABS(E(I)))
C .......... EPS2 IS THE CRITERION FOR GROUPING,
C EPS3 REPLACES ZERO PIVOTS AND EQUAL
C ROOTS ARE MODIFIED BY EPS3,
C EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW ..........
EPS2 = 1.0D-3 * NORM
EPS3 = EPSLON(NORM)
UK = Q - P + 1
EPS4 = UK * EPS3
UK = EPS4 / DSQRT(UK)
* INCREMENT OPCOUNT FOR COMPUTING CRITERIA.
OPS = OPS + ( Q-IP+4 )
S = P
505 GROUP = 0
GO TO 520
C .......... LOOK FOR CLOSE OR COINCIDENT ROOTS ..........
510 IF (DABS(X1-X0) .GE. EPS2) GO TO 505
GROUP = GROUP + 1
IF (ORDER * (X1 - X0) .LE. 0.0D0) X1 = X0 + ORDER * EPS3
C .......... ELIMINATION WITH INTERCHANGES AND
C INITIALIZATION OF VECTOR ..........
520 V = 0.0D0
C
DO 580 I = P, Q
RV6(I) = UK
IF (I .EQ. P) GO TO 560
IF (DABS(E(I)) .LT. DABS(U)) GO TO 540
C .......... WARNING -- A DIVIDE CHECK MAY OCCUR HERE IF
C E2 ARRAY HAS NOT BEEN SPECIFIED CORRECTLY ..........
XU = U / E(I)
RV4(I) = XU
RV1(I-1) = E(I)
RV2(I-1) = D(I) - X1
RV3(I-1) = 0.0D0
IF (I .NE. Q) RV3(I-1) = E(I+1)
U = V - XU * RV2(I-1)
V = -XU * RV3(I-1)
GO TO 580
540 XU = E(I) / U
RV4(I) = XU
RV1(I-1) = U
RV2(I-1) = V
RV3(I-1) = 0.0D0
560 U = D(I) - X1 - XU * V
IF (I .NE. Q) V = E(I+1)
580 CONTINUE
* INCREMENT OPCOUNT FOR ELIMINATION.
OPS = OPS + ( Q-P+1 )*5
C
IF (U .EQ. 0.0D0) U = EPS3
RV1(Q) = U
RV2(Q) = 0.0D0
RV3(Q) = 0.0D0
C .......... BACK SUBSTITUTION
C FOR I=Q STEP -1 UNTIL P DO -- ..........
600 DO 620 II = P, Q
I = P + Q - II
RV6(I) = (RV6(I) - U * RV2(I) - V * RV3(I)) / RV1(I)
V = U
U = RV6(I)
620 CONTINUE
* INCREMENT OPCOUNT FOR BACK SUBSTITUTION.
OPS = OPS + ( Q-P+1 )*5
C .......... ORTHOGONALIZE WITH RESPECT TO PREVIOUS
C MEMBERS OF GROUP ..........
IF (GROUP .EQ. 0) GO TO 700
J = R
C
DO 680 JJ = 1, GROUP
630 J = J - 1
IF (IND(J) .NE. TAG) GO TO 630
XU = 0.0D0
C
DO 640 I = P, Q
640 XU = XU + RV6(I) * Z(I,J)
C
DO 660 I = P, Q
660 RV6(I) = RV6(I) - XU * Z(I,J)
C
* INCREMENT OPCOUNT FOR ORTHOGONALIZING.
OPS = OPS + ( Q-P+1 )*4
680 CONTINUE
C
700 NORM = 0.0D0
C
DO 720 I = P, Q
720 NORM = NORM + DABS(RV6(I))
* INCREMENT OPCOUNT FOR COMPUTING NORM.
OPS = OPS + ( Q-P+1 )
C
IF (NORM .GE. 1.0D0) GO TO 840
C .......... FORWARD SUBSTITUTION ..........
IF (ITS .EQ. 5) GO TO 830
IF (NORM .NE. 0.0D0) GO TO 740
RV6(S) = EPS4
S = S + 1
IF (S .GT. Q) S = P
GO TO 780
740 XU = EPS4 / NORM
C
DO 760 I = P, Q
760 RV6(I) = RV6(I) * XU
C .......... ELIMINATION OPERATIONS ON NEXT VECTOR
C ITERATE ..........
780 DO 820 I = IP, Q
U = RV6(I)
C .......... IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE
C WAS PERFORMED EARLIER IN THE
C TRIANGULARIZATION PROCESS ..........
IF (RV1(I-1) .NE. E(I)) GO TO 800
U = RV6(I-1)
RV6(I-1) = RV6(I)
800 RV6(I) = U - RV4(I) * RV6(I-1)
820 CONTINUE
* INCREMENT OPCOUNT FOR FORWARD SUBSTITUTION.
OPS = OPS + ( Q-P+1 ) + ( Q-IP+1 )*2
C
ITS = ITS + 1
* INCREMENT ITERATION COUNTER.
ITCNT = ITCNT + 1
GO TO 600
C .......... SET ERROR -- NON-CONVERGED EIGENVECTOR ..........
830 IERR = -R
XU = 0.0D0
GO TO 870
C .......... NORMALIZE SO THAT SUM OF SQUARES IS
C 1 AND EXPAND TO FULL ORDER ..........
840 U = 0.0D0
C
DO 860 I = P, Q
860 U = PYTHAG(U,RV6(I))
C
XU = 1.0D0 / U
C
870 DO 880 I = 1, N
880 Z(I,R) = 0.0D0
C
DO 900 I = P, Q
900 Z(I,R) = RV6(I) * XU
* INCREMENT OPCOUNT FOR NORMALIZING.
OPS = OPS + ( Q-P+1 )
C
X0 = X1
920 CONTINUE
C
IF (Q .LT. N) GO TO 100
* INCREMENT OPCOUNT FOR USE OF FUNCTION PYTHAG.
OPS = OPS + OPST
1001 RETURN
END
SUBROUTINE TRIDIB(N,EPS1,D,E,E2,LB,UB,M11,M,W,IND,IERR,RV4,RV5)
*
* EISPACK ROUTINE.
* MODIFIED FOR COMPARISON WITH LAPACK ROUTINES.
*
* CONVERGENCE TEST WAS MODIFIED TO BE THE SAME AS IN DSTEBZ.
*
C
INTEGER I,J,K,L,M,N,P,Q,R,S,II,M1,M2,M11,M22,TAG,IERR,ISTURM
DOUBLE PRECISION D(N),E(N),E2(N),W(M),RV4(N),RV5(N)
DOUBLE PRECISION U,V,LB,T1,T2,UB,XU,X0,X1,EPS1,TST1,TST2,EPSLON
INTEGER IND(M)
external epslon
*
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT
* ITCNT IS INITIALIZED TO 0, OPS IS ONLY INCREMENTED
* .. COMMON BLOCKS ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. SCALARS IN COMMON ..
DOUBLE PRECISION ITCNT, OPS
* ..
C
C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BISECT,
C NUM. MATH. 9, 386-393(1967) BY BARTH, MARTIN, AND WILKINSON.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 249-256(1971).
C
C THIS SUBROUTINE FINDS THOSE EIGENVALUES OF A TRIDIAGONAL
C SYMMETRIC MATRIX BETWEEN SPECIFIED BOUNDARY INDICES,
C USING BISECTION.
C
C ON INPUT
C
C N IS THE ORDER OF THE MATRIX.
C
C EPS1 IS AN ABSOLUTE ERROR TOLERANCE FOR THE COMPUTED
C EIGENVALUES. IF THE INPUT EPS1 IS NON-POSITIVE,
C IT IS RESET FOR EACH SUBMATRIX TO A DEFAULT VALUE,
C NAMELY, MINUS THE PRODUCT OF THE RELATIVE MACHINE
C PRECISION AND THE 1-NORM OF THE SUBMATRIX.
C
C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
C
C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY.
C
C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
C E2(1) IS ARBITRARY.
C
C M11 SPECIFIES THE LOWER BOUNDARY INDEX FOR THE DESIRED
C EIGENVALUES.
C
C M SPECIFIES THE NUMBER OF EIGENVALUES DESIRED. THE UPPER
C BOUNDARY INDEX M22 IS THEN OBTAINED AS M22=M11+M-1.
C
C ON OUTPUT
C
C EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS
C (LAST) DEFAULT VALUE.
C
C D AND E ARE UNALTERED.
C
C ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED
C AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE
C MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES.
C E2(1) IS ALSO SET TO ZERO.
C
C LB AND UB DEFINE AN INTERVAL CONTAINING EXACTLY THE DESIRED
C EIGENVALUES.
C
C W CONTAINS, IN ITS FIRST M POSITIONS, THE EIGENVALUES
C BETWEEN INDICES M11 AND M22 IN ASCENDING ORDER.
C
C IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES
C ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W --
C 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM
C THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC..
C
C IERR IS SET TO
C ZERO FOR NORMAL RETURN,
C 3*N+1 IF MULTIPLE EIGENVALUES AT INDEX M11 MAKE
C UNIQUE SELECTION IMPOSSIBLE,
C 3*N+2 IF MULTIPLE EIGENVALUES AT INDEX M22 MAKE
C UNIQUE SELECTION IMPOSSIBLE.
C
C RV4 AND RV5 ARE TEMPORARY STORAGE ARRAYS.
C
C NOTE THAT SUBROUTINE TQL1, IMTQL1, OR TQLRAT IS GENERALLY FASTER
C THAN TRIDIB, IF MORE THAN N/4 EIGENVALUES ARE TO BE FOUND.
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
C
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION RELFAC
PARAMETER ( RELFAC = 2.0D0 )
DOUBLE PRECISION ATOLI, RTOLI, SAFEMN, TMP1, TMP2, TNORM, ULP
DOUBLE PRECISION DLAMCH, PIVMIN
EXTERNAL DLAMCH
* INITIALIZE ITERATION COUNT.
ITCNT = 0
SAFEMN = DLAMCH( 'S' )
ULP = DLAMCH( 'E' )*DLAMCH( 'B' )
RTOLI = ULP*RELFAC
IERR = 0
TAG = 0
XU = D(1)
X0 = D(1)
U = 0.0D0
C .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES AND DETERMINE AN
C INTERVAL CONTAINING ALL THE EIGENVALUES ..........
PIVMIN = ONE
DO 40 I = 1, N
X1 = U
U = 0.0D0
IF (I .NE. N) U = DABS(E(I+1))
XU = DMIN1(D(I)-(X1+U),XU)
X0 = DMAX1(D(I)+(X1+U),X0)
IF (I .EQ. 1) GO TO 20
CCC TST1 = DABS(D(I)) + DABS(D(I-1))
CCC TST2 = TST1 + DABS(E(I))
CCC IF (TST2 .GT. TST1) GO TO 40
TMP1 = E( I )**2
IF( ABS( D(I)*D(I-1) )*ULP**2+SAFEMN.LE.TMP1 ) THEN
PIVMIN = MAX( PIVMIN, TMP1 )
GO TO 40
END IF
20 E2(I) = 0.0D0
40 CONTINUE
PIVMIN = PIVMIN*SAFEMN
TNORM = MAX( ABS( XU ), ABS( X0 ) )
ATOLI = ULP*TNORM
* INCREMENT OPCOUNT FOR DETERMINING IF MATRIX SPLITS.
OPS = OPS + 9*( N-1 )
C
X1 = N
X1 = X1 * EPSLON(DMAX1(DABS(XU),DABS(X0)))
XU = XU - X1
T1 = XU
X0 = X0 + X1
T2 = X0
C .......... DETERMINE AN INTERVAL CONTAINING EXACTLY
C THE DESIRED EIGENVALUES ..........
P = 1
Q = N
M1 = M11 - 1
IF (M1 .EQ. 0) GO TO 75
ISTURM = 1
50 V = X1
X1 = XU + (X0 - XU) * 0.5D0
IF (X1 .EQ. V) GO TO 980
GO TO 320
60 IF (S - M1) 65, 73, 70
65 XU = X1
GO TO 50
70 X0 = X1
GO TO 50
73 XU = X1
T1 = X1
75 M22 = M1 + M
IF (M22 .EQ. N) GO TO 90
X0 = T2
ISTURM = 2
GO TO 50
80 IF (S - M22) 65, 85, 70
85 T2 = X1
90 Q = 0
R = 0
C .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING
C INTERVAL BY THE GERSCHGORIN BOUNDS ..........
100 IF (R .EQ. M) GO TO 1001
TAG = TAG + 1
P = Q + 1
XU = D(P)
X0 = D(P)
U = 0.0D0
C
DO 120 Q = P, N
X1 = U
U = 0.0D0
V = 0.0D0
IF (Q .EQ. N) GO TO 110
U = DABS(E(Q+1))
V = E2(Q+1)
110 XU = DMIN1(D(Q)-(X1+U),XU)
X0 = DMAX1(D(Q)+(X1+U),X0)
IF (V .EQ. 0.0D0) GO TO 140
120 CONTINUE
* INCREMENT OPCOUNT FOR REFINING INTERVAL.
OPS = OPS + ( N-P+1 )*2
C
140 X1 = EPSLON(DMAX1(DABS(XU),DABS(X0)))
IF (EPS1 .LE. 0.0D0) EPS1 = -X1
IF (P .NE. Q) GO TO 180
C .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL ..........
IF (T1 .GT. D(P) .OR. D(P) .GE. T2) GO TO 940
M1 = P
M2 = P
RV5(P) = D(P)
GO TO 900
180 X1 = X1 * (Q - P + 1)
LB = DMAX1(T1,XU-X1)
UB = DMIN1(T2,X0+X1)
X1 = LB
ISTURM = 3
GO TO 320
200 M1 = S + 1
X1 = UB
ISTURM = 4
GO TO 320
220 M2 = S
IF (M1 .GT. M2) GO TO 940
C .......... FIND ROOTS BY BISECTION ..........
X0 = UB
ISTURM = 5
C
DO 240 I = M1, M2
RV5(I) = UB
RV4(I) = LB
240 CONTINUE
C .......... LOOP FOR K-TH EIGENVALUE
C FOR K=M2 STEP -1 UNTIL M1 DO --
C (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) ..........
K = M2
250 XU = LB
C .......... FOR I=K STEP -1 UNTIL M1 DO -- ..........
DO 260 II = M1, K
I = M1 + K - II
IF (XU .GE. RV4(I)) GO TO 260
XU = RV4(I)
GO TO 280
260 CONTINUE
C
280 IF (X0 .GT. RV5(K)) X0 = RV5(K)
C .......... NEXT BISECTION STEP ..........
300 X1 = (XU + X0) * 0.5D0
CCC IF ((X0 - XU) .LE. DABS(EPS1)) GO TO 420
CCC TST1 = 2.0D0 * (DABS(XU) + DABS(X0))
CCC TST2 = TST1 + (X0 - XU)
CCC IF (TST2 .EQ. TST1) GO TO 420
TMP1 = ABS( X0 - XU )
TMP2 = MAX( ABS( X0 ), ABS( XU ) )
IF( TMP1.LT.MAX( ATOLI, PIVMIN, RTOLI*TMP2 ) )
$ GO TO 420
C .......... IN-LINE PROCEDURE FOR STURM SEQUENCE ..........
320 S = P - 1
U = 1.0D0
C
DO 340 I = P, Q
IF (U .NE. 0.0D0) GO TO 325
V = DABS(E(I)) / EPSLON(1.0D0)
IF (E2(I) .EQ. 0.0D0) V = 0.0D0
GO TO 330
325 V = E2(I) / U
330 U = D(I) - X1 - V
IF (U .LT. 0.0D0) S = S + 1
340 CONTINUE
* INCREMENT OPCOUNT FOR STURM SEQUENCE.
OPS = OPS + ( Q-P+1 )*3
* INCREMENT ITERATION COUNTER.
ITCNT = ITCNT + 1
C
GO TO (60,80,200,220,360), ISTURM
C .......... REFINE INTERVALS ..........
360 IF (S .GE. K) GO TO 400
XU = X1
IF (S .GE. M1) GO TO 380
RV4(M1) = X1
GO TO 300
380 RV4(S+1) = X1
IF (RV5(S) .GT. X1) RV5(S) = X1
GO TO 300
400 X0 = X1
GO TO 300
C .......... K-TH EIGENVALUE FOUND ..........
420 RV5(K) = X1
K = K - 1
IF (K .GE. M1) GO TO 250
C .......... ORDER EIGENVALUES TAGGED WITH THEIR
C SUBMATRIX ASSOCIATIONS ..........
900 S = R
R = R + M2 - M1 + 1
J = 1
K = M1
C
DO 920 L = 1, R
IF (J .GT. S) GO TO 910
IF (K .GT. M2) GO TO 940
IF (RV5(K) .GE. W(L)) GO TO 915
C
DO 905 II = J, S
I = L + S - II
W(I+1) = W(I)
IND(I+1) = IND(I)
905 CONTINUE
C
910 W(L) = RV5(K)
IND(L) = TAG
K = K + 1
GO TO 920
915 J = J + 1
920 CONTINUE
C
940 IF (Q .LT. N) GO TO 100
GO TO 1001
C .......... SET ERROR -- INTERVAL CANNOT BE FOUND CONTAINING
C EXACTLY THE DESIRED EIGENVALUES ..........
980 IERR = 3 * N + ISTURM
1001 LB = T1
UB = T2
RETURN
END
SUBROUTINE DSVDC(X,LDX,N,P,S,E,U,LDU,V,LDV,WORK,JOB,INFO)
INTEGER LDX,N,P,LDU,LDV,JOB,INFO
DOUBLE PRECISION X(LDX,*),S(*),E(*),U(LDU,*),V(LDV,*),WORK(*)
*
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT
* ITCNT IS INITIALIZED TO 0, IOPS IS ONLY INCREMENTED
* IOPST IS USED TO ACCUMULATE SMALL CONTRIBUTIONS TO IOPS
* TO AVOID ROUNDOFF ERROR
* .. COMMON BLOCKS ..
COMMON /LATIME/ IOPS, ITCNT
* ..
* .. SCALARS IN COMMON ..
DOUBLE PRECISION IOPS, ITCNT, IOPST
* ..
C
C
C DSVDC IS A SUBROUTINE TO REDUCE A DOUBLE PRECISION NXP MATRIX X
C BY ORTHOGONAL TRANSFORMATIONS U AND V TO DIAGONAL FORM. THE
C DIAGONAL ELEMENTS S(I) ARE THE SINGULAR VALUES OF X. THE
C COLUMNS OF U ARE THE CORRESPONDING LEFT SINGULAR VECTORS,
C AND THE COLUMNS OF V THE RIGHT SINGULAR VECTORS.
C
C ON ENTRY
C
C X DOUBLE PRECISION(LDX,P), WHERE LDX.GE.N.
C X CONTAINS THE MATRIX WHOSE SINGULAR VALUE
C DECOMPOSITION IS TO BE COMPUTED. X IS
C DESTROYED BY DSVDC.
C
C LDX INTEGER.
C LDX IS THE LEADING DIMENSION OF THE ARRAY X.
C
C N INTEGER.
C N IS THE NUMBER OF ROWS OF THE MATRIX X.
C
C P INTEGER.
C P IS THE NUMBER OF COLUMNS OF THE MATRIX X.
C
C LDU INTEGER.
C LDU IS THE LEADING DIMENSION OF THE ARRAY U.
C (SEE BELOW).
C
C LDV INTEGER.
C LDV IS THE LEADING DIMENSION OF THE ARRAY V.
C (SEE BELOW).
C
C WORK DOUBLE PRECISION(N).
C WORK IS A SCRATCH ARRAY.
C
C JOB INTEGER.
C JOB CONTROLS THE COMPUTATION OF THE SINGULAR
C VECTORS. IT HAS THE DECIMAL EXPANSION AB
C WITH THE FOLLOWING MEANING
C
C A.EQ.0 DO NOT COMPUTE THE LEFT SINGULAR
C VECTORS.
C A.EQ.1 RETURN THE N LEFT SINGULAR VECTORS
C IN U.
C A.GE.2 RETURN THE FIRST MIN(N,P) SINGULAR
C VECTORS IN U.
C B.EQ.0 DO NOT COMPUTE THE RIGHT SINGULAR
C VECTORS.
C B.EQ.1 RETURN THE RIGHT SINGULAR VECTORS
C IN V.
C
C ON RETURN
C
C S DOUBLE PRECISION(MM), WHERE MM=MIN(N+1,P).
C THE FIRST MIN(N,P) ENTRIES OF S CONTAIN THE
C SINGULAR VALUES OF X ARRANGED IN DESCENDING
C ORDER OF MAGNITUDE.
C
C E DOUBLE PRECISION(P),
C E ORDINARILY CONTAINS ZEROS. HOWEVER SEE THE
C DISCUSSION OF INFO FOR EXCEPTIONS.
C
C U DOUBLE PRECISION(LDU,K), WHERE LDU.GE.N. IF
C JOBA.EQ.1 THEN K.EQ.N, IF JOBA.GE.2
C THEN K.EQ.MIN(N,P).
C U CONTAINS THE MATRIX OF LEFT SINGULAR VECTORS.
C U IS NOT REFERENCED IF JOBA.EQ.0. IF N.LE.P
C OR IF JOBA.EQ.2, THEN U MAY BE IDENTIFIED WITH X
C IN THE SUBROUTINE CALL.
C
C V DOUBLE PRECISION(LDV,P), WHERE LDV.GE.P.
C V CONTAINS THE MATRIX OF RIGHT SINGULAR VECTORS.
C V IS NOT REFERENCED IF JOB.EQ.0. IF P.LE.N,
C THEN V MAY BE IDENTIFIED WITH X IN THE
C SUBROUTINE CALL.
C
C INFO INTEGER.
C THE SINGULAR VALUES (AND THEIR CORRESPONDING
C SINGULAR VECTORS) S(INFO+1),S(INFO+2),...,S(M)
C ARE CORRECT (HERE M=MIN(N,P)). THUS IF
C INFO.EQ.0, ALL THE SINGULAR VALUES AND THEIR
C VECTORS ARE CORRECT. IN ANY EVENT, THE MATRIX
C B = TRANS(U)*X*V IS THE BIDIAGONAL MATRIX
C WITH THE ELEMENTS OF S ON ITS DIAGONAL AND THE
C ELEMENTS OF E ON ITS SUPER-DIAGONAL (TRANS(U)
C IS THE TRANSPOSE OF U). THUS THE SINGULAR
C VALUES OF X AND B ARE THE SAME.
C
C LINPACK. THIS VERSION DATED 08/14/78 .
C CORRECTION MADE TO SHIFT 2/84.
C G.W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB.
C
C DSVDC USES THE FOLLOWING FUNCTIONS AND SUBPROGRAMS.
C
C EXTERNAL DROT
C BLAS DAXPY,DDOT,DSCAL,DSWAP,DNRM2,DROTG
C FORTRAN DABS,DMAX1,MAX0,MIN0,MOD,DSQRT
C
C INTERNAL VARIABLES
C
INTEGER I,ITER,J,JOBU,K,KASE,KK,L,LL,LLS,LM1,LP1,LS,LU,M,MAXIT,
* MM,MM1,MP1,NCT,NCTP1,NCU,NRT,NRTP1
DOUBLE PRECISION DDOT,T
DOUBLE PRECISION B,C,CS,EL,EMM1,F,G,DNRM2,SCALE,SHIFT,SL,SM,SN,
* SMM1,T1,TEST
* DOUBLE PRECISION ZTEST,R
LOGICAL WANTU,WANTV
*
* GET EPS FROM DLAMCH FOR NEW STOPPING CRITERION
EXTERNAL DLAMCH, dnrm2, ddot
DOUBLE PRECISION DLAMCH, EPS
IF (N.LE.0 .OR. P.LE.0) RETURN
EPS = DLAMCH( 'EPSILON' )
*
C
C
C SET THE MAXIMUM NUMBER OF ITERATIONS.
C
MAXIT = 50
C
C DETERMINE WHAT IS TO BE COMPUTED.
C
WANTU = .FALSE.
WANTV = .FALSE.
JOBU = MOD(JOB,100)/10
NCU = N
IF (JOBU .GT. 1) NCU = MIN0(N,P)
IF (JOBU .NE. 0) WANTU = .TRUE.
IF (MOD(JOB,10) .NE. 0) WANTV = .TRUE.
C
C REDUCE X TO BIDIAGONAL FORM, STORING THE DIAGONAL ELEMENTS
C IN S AND THE SUPER-DIAGONAL ELEMENTS IN E.
C
*
* INITIALIZE OP COUNT
IOPST = 0
INFO = 0
NCT = MIN0(N-1,P)
NRT = MAX0(0,MIN0(P-2,N))
LU = MAX0(NCT,NRT)
IF (LU .LT. 1) GO TO 170
DO 160 L = 1, LU
LP1 = L + 1
IF (L .GT. NCT) GO TO 20
C
C COMPUTE THE TRANSFORMATION FOR THE L-TH COLUMN AND
C PLACE THE L-TH DIAGONAL IN S(L).
C
*
* INCREMENT OP COUNT
IOPS = IOPS + (2*(N-L+1)+1)
S(L) = DNRM2(N-L+1,X(L,L),1)
IF (S(L) .EQ. 0.0D0) GO TO 10
IF (X(L,L) .NE. 0.0D0) S(L) = DSIGN(S(L),X(L,L))
*
* INCREMENT OP COUNT
IOPS = IOPS + (N-L+3)
CALL DSCAL(N-L+1,1.0D0/S(L),X(L,L),1)
X(L,L) = 1.0D0 + X(L,L)
10 CONTINUE
S(L) = -S(L)
20 CONTINUE
IF (P .LT. LP1) GO TO 50
DO 40 J = LP1, P
IF (L .GT. NCT) GO TO 30
IF (S(L) .EQ. 0.0D0) GO TO 30
C
C APPLY THE TRANSFORMATION.
C
*
* INCREMENT OP COUNT
IOPS = IOPS + (4*(N-L)+5)
T = -DDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L)
CALL DAXPY(N-L+1,T,X(L,L),1,X(L,J),1)
30 CONTINUE
C
C PLACE THE L-TH ROW OF X INTO E FOR THE
C SUBSEQUENT CALCULATION OF THE ROW TRANSFORMATION.
C
E(J) = X(L,J)
40 CONTINUE
50 CONTINUE
IF (.NOT.WANTU .OR. L .GT. NCT) GO TO 70
C
C PLACE THE TRANSFORMATION IN U FOR SUBSEQUENT BACK
C MULTIPLICATION.
C
DO 60 I = L, N
U(I,L) = X(I,L)
60 CONTINUE
70 CONTINUE
IF (L .GT. NRT) GO TO 150
C
C COMPUTE THE L-TH ROW TRANSFORMATION AND PLACE THE
C L-TH SUPER-DIAGONAL IN E(L).
C
*
* INCREMENT OP COUNT
IOPS = IOPS + (2*(P-L)+1)
E(L) = DNRM2(P-L,E(LP1),1)
IF (E(L) .EQ. 0.0D0) GO TO 80
IF (E(LP1) .NE. 0.0D0) E(L) = DSIGN(E(L),E(LP1))
*
* INCREMENT OP COUNT
IOPS = IOPS + (P-L+2)
CALL DSCAL(P-L,1.0D0/E(L),E(LP1),1)
E(LP1) = 1.0D0 + E(LP1)
80 CONTINUE
E(L) = -E(L)
IF (LP1 .GT. N .OR. E(L) .EQ. 0.0D0) GO TO 120
C
C APPLY THE TRANSFORMATION.
C
DO 90 I = LP1, N
WORK(I) = 0.0D0
90 CONTINUE
*
* INCREMENT OP COUNT
IOPS = IOPS + DBLE(4*(N-L)+1)*(P-L)
DO 100 J = LP1, P
CALL DAXPY(N-L,E(J),X(LP1,J),1,WORK(LP1),1)
100 CONTINUE
DO 110 J = LP1, P
CALL DAXPY(N-L,-E(J)/E(LP1),WORK(LP1),1,X(LP1,J),1)
110 CONTINUE
120 CONTINUE
IF (.NOT.WANTV) GO TO 140
C
C PLACE THE TRANSFORMATION IN V FOR SUBSEQUENT
C BACK MULTIPLICATION.
C
DO 130 I = LP1, P
V(I,L) = E(I)
130 CONTINUE
140 CONTINUE
150 CONTINUE
160 CONTINUE
170 CONTINUE
C
C SET UP THE FINAL BIDIAGONAL MATRIX OR ORDER M.
C
M = MIN0(P,N+1)
NCTP1 = NCT + 1
NRTP1 = NRT + 1
IF (NCT .LT. P) S(NCTP1) = X(NCTP1,NCTP1)
IF (N .LT. M) S(M) = 0.0D0
IF (NRTP1 .LT. M) E(NRTP1) = X(NRTP1,M)
E(M) = 0.0D0
C
C IF REQUIRED, GENERATE U.
C
IF (.NOT.WANTU) GO TO 300
IF (NCU .LT. NCTP1) GO TO 200
DO 190 J = NCTP1, NCU
DO 180 I = 1, N
U(I,J) = 0.0D0
180 CONTINUE
U(J,J) = 1.0D0
190 CONTINUE
200 CONTINUE
IF (NCT .LT. 1) GO TO 290
DO 280 LL = 1, NCT
L = NCT - LL + 1
IF (S(L) .EQ. 0.0D0) GO TO 250
LP1 = L + 1
IF (NCU .LT. LP1) GO TO 220
*
* INCREMENT OP COUNT
IOPS = IOPS + (DBLE(4*(N-L)+5)*(NCU-L)+(N-L+2))
DO 210 J = LP1, NCU
T = -DDOT(N-L+1,U(L,L),1,U(L,J),1)/U(L,L)
CALL DAXPY(N-L+1,T,U(L,L),1,U(L,J),1)
210 CONTINUE
220 CONTINUE
CALL DSCAL(N-L+1,-1.0D0,U(L,L),1)
U(L,L) = 1.0D0 + U(L,L)
LM1 = L - 1
IF (LM1 .LT. 1) GO TO 240
DO 230 I = 1, LM1
U(I,L) = 0.0D0
230 CONTINUE
240 CONTINUE
GO TO 270
250 CONTINUE
DO 260 I = 1, N
U(I,L) = 0.0D0
260 CONTINUE
U(L,L) = 1.0D0
270 CONTINUE
280 CONTINUE
290 CONTINUE
300 CONTINUE
C
C IF IT IS REQUIRED, GENERATE V.
C
IF (.NOT.WANTV) GO TO 350
DO 340 LL = 1, P
L = P - LL + 1
LP1 = L + 1
IF (L .GT. NRT) GO TO 320
IF (E(L) .EQ. 0.0D0) GO TO 320
*
* INCREMENT OP COUNT
IOPS = IOPS + DBLE(4*(P-L)+1)*(P-L)
DO 310 J = LP1, P
T = -DDOT(P-L,V(LP1,L),1,V(LP1,J),1)/V(LP1,L)
CALL DAXPY(P-L,T,V(LP1,L),1,V(LP1,J),1)
310 CONTINUE
320 CONTINUE
DO 330 I = 1, P
V(I,L) = 0.0D0
330 CONTINUE
V(L,L) = 1.0D0
340 CONTINUE
350 CONTINUE
C
C MAIN ITERATION LOOP FOR THE SINGULAR VALUES.
C
MM = M
*
* INITIALIZE ITERATION COUNTER
ITCNT = 0
ITER = 0
360 CONTINUE
C
C QUIT IF ALL THE SINGULAR VALUES HAVE BEEN FOUND.
C
C ...EXIT
IF (M .EQ. 0) GO TO 620
C
C IF TOO MANY ITERATIONS HAVE BEEN PERFORMED, SET
C FLAG AND RETURN.
C
*
* UPDATE ITERATION COUNTER
ITCNT = ITER
IF (ITER .LT. MAXIT) GO TO 370
INFO = M
C ......EXIT
GO TO 620
370 CONTINUE
C
C THIS SECTION OF THE PROGRAM INSPECTS FOR
C NEGLIGIBLE ELEMENTS IN THE S AND E ARRAYS. ON
C COMPLETION THE VARIABLES KASE AND L ARE SET AS FOLLOWS.
C
C KASE = 1 IF S(M) AND E(L-1) ARE NEGLIGIBLE AND L.LT.M
C KASE = 2 IF S(L) IS NEGLIGIBLE AND L.LT.M
C KASE = 3 IF E(L-1) IS NEGLIGIBLE, L.LT.M, AND
C S(L), ..., S(M) ARE NOT NEGLIGIBLE (QR STEP).
C KASE = 4 IF E(M-1) IS NEGLIGIBLE (CONVERGENCE).
C
DO 390 LL = 1, M
L = M - LL
C ...EXIT
IF (L .EQ. 0) GO TO 400
*
* INCREMENT OP COUNT
IOPST = IOPST + 2
TEST = DABS(S(L)) + DABS(S(L+1))
*
* REPLACE STOPPING CRITERION WITH NEW ONE AS IN LAPACK
*
* ZTEST = TEST + DABS(E(L))
* IF (ZTEST .NE. TEST) GO TO 380
IF (DABS(E(L)) .GT. EPS * TEST) GOTO 380
*
E(L) = 0.0D0
C ......EXIT
GO TO 400
380 CONTINUE
390 CONTINUE
400 CONTINUE
IF (L .NE. M - 1) GO TO 410
KASE = 4
GO TO 480
410 CONTINUE
LP1 = L + 1
MP1 = M + 1
DO 430 LLS = LP1, MP1
LS = M - LLS + LP1
C ...EXIT
IF (LS .EQ. L) GO TO 440
TEST = 0.0D0
*
* INCREMENT OP COUNT
IOPST = IOPST + 3
IF (LS .NE. M) TEST = TEST + DABS(E(LS))
IF (LS .NE. L + 1) TEST = TEST + DABS(E(LS-1))
*
* REPLACE STOPPING CRITERION WITH NEW ONE AS IN LAPACK
*
* ZTEST = TEST + DABS(S(LS))
* IF (ZTEST .NE. TEST) GO TO 420
IF (DABS(S(LS)) .GT. EPS * TEST) GOTO 420
*
S(LS) = 0.0D0
C ......EXIT
GO TO 440
420 CONTINUE
430 CONTINUE
440 CONTINUE
IF (LS .NE. L) GO TO 450
KASE = 3
GO TO 470
450 CONTINUE
IF (LS .NE. M) GO TO 460
KASE = 1
GO TO 470
460 CONTINUE
KASE = 2
L = LS
470 CONTINUE
480 CONTINUE
L = L + 1
C
C PERFORM THE TASK INDICATED BY KASE.
C
GO TO (490,520,540,570), KASE
C
C DEFLATE NEGLIGIBLE S(M).
C
490 CONTINUE
MM1 = M - 1
F = E(M-1)
E(M-1) = 0.0D0
*
* INCREMENT OP COUNT
IOPS = IOPS + ((MM1-L+1)*13 - 2)
IF (WANTV) IOPS = IOPS + DBLE(MM1-L+1)*6*P
DO 510 KK = L, MM1
K = MM1 - KK + L
T1 = S(K)
CALL DROTG(T1,F,CS,SN)
S(K) = T1
IF (K .EQ. L) GO TO 500
F = -SN*E(K-1)
E(K-1) = CS*E(K-1)
500 CONTINUE
IF (WANTV) CALL DROT(P,V(1,K),1,V(1,M),1,CS,SN)
510 CONTINUE
GO TO 610
C
C SPLIT AT NEGLIGIBLE S(L).
C
520 CONTINUE
F = E(L-1)
E(L-1) = 0.0D0
*
* INCREMENT OP COUNT
IOPS = IOPS + (M-L+1)*13
IF (WANTU) IOPS = IOPS + DBLE(M-L+1)*6*N
DO 530 K = L, M
T1 = S(K)
CALL DROTG(T1,F,CS,SN)
S(K) = T1
F = -SN*E(K)
E(K) = CS*E(K)
IF (WANTU) CALL DROT(N,U(1,K),1,U(1,L-1),1,CS,SN)
530 CONTINUE
GO TO 610
C
C PERFORM ONE QR STEP.
C
540 CONTINUE
C
C CALCULATE THE SHIFT.
C
*
* INCREMENT OP COUNT
IOPST = IOPST + 23
SCALE = DMAX1(DABS(S(M)),DABS(S(M-1)),DABS(E(M-1)),
* DABS(S(L)),DABS(E(L)))
SM = S(M)/SCALE
SMM1 = S(M-1)/SCALE
EMM1 = E(M-1)/SCALE
SL = S(L)/SCALE
EL = E(L)/SCALE
B = ((SMM1 + SM)*(SMM1 - SM) + EMM1**2)/2.0D0
C = (SM*EMM1)**2
SHIFT = 0.0D0
IF (B .EQ. 0.0D0 .AND. C .EQ. 0.0D0) GO TO 550
SHIFT = DSQRT(B**2+C)
IF (B .LT. 0.0D0) SHIFT = -SHIFT
SHIFT = C/(B + SHIFT)
550 CONTINUE
F = (SL + SM)*(SL - SM) + SHIFT
G = SL*EL
C
C CHASE ZEROS.
C
MM1 = M - 1
*
* INCREMENT OP COUNT
IOPS = IOPS + (MM1-L+1)*38
IF (WANTV) IOPS = IOPS+DBLE(MM1-L+1)*6*P
IF (WANTU) IOPS = IOPS+DBLE(MAX((MIN(MM1,N-1)-L+1),0))*6*N
DO 560 K = L, MM1
CALL DROTG(F,G,CS,SN)
IF (K .NE. L) E(K-1) = F
F = CS*S(K) + SN*E(K)
E(K) = CS*E(K) - SN*S(K)
G = SN*S(K+1)
S(K+1) = CS*S(K+1)
IF (WANTV) CALL DROT(P,V(1,K),1,V(1,K+1),1,CS,SN)
CALL DROTG(F,G,CS,SN)
S(K) = F
F = CS*E(K) + SN*S(K+1)
S(K+1) = -SN*E(K) + CS*S(K+1)
G = SN*E(K+1)
E(K+1) = CS*E(K+1)
IF (WANTU .AND. K .LT. N)
* CALL DROT(N,U(1,K),1,U(1,K+1),1,CS,SN)
560 CONTINUE
E(M-1) = F
ITER = ITER + 1
GO TO 610
C
C CONVERGENCE.
C
570 CONTINUE
C
C MAKE THE SINGULAR VALUE POSITIVE.
C
IF (S(L) .GE. 0.0D0) GO TO 580
S(L) = -S(L)
*
* INCREMENT OP COUNT
IF (WANTV) IOPS = IOPS + P
IF (WANTV) CALL DSCAL(P,-1.0D0,V(1,L),1)
580 CONTINUE
C
C ORDER THE SINGULAR VALUE.
C
590 IF (L .EQ. MM) GO TO 600
C ...EXIT
IF (S(L) .GE. S(L+1)) GO TO 600
T = S(L)
S(L) = S(L+1)
S(L+1) = T
IF (WANTV .AND. L .LT. P)
* CALL DSWAP(P,V(1,L),1,V(1,L+1),1)
IF (WANTU .AND. L .LT. N)
* CALL DSWAP(N,U(1,L),1,U(1,L+1),1)
L = L + 1
GO TO 590
600 CONTINUE
ITER = 0
M = M - 1
610 CONTINUE
GO TO 360
620 CONTINUE
*
* COMPUTE FINAL OPCOUNT
IOPS = IOPS + IOPST
RETURN
END
SUBROUTINE QZHES(NM,N,A,B,MATZ,Z)
C
INTEGER I,J,K,L,N,LB,L1,NM,NK1,NM1,NM2
DOUBLE PRECISION A(NM,N),B(NM,N),Z(NM,N)
DOUBLE PRECISION R,S,T,U1,U2,V1,V2,RHO
LOGICAL MATZ
*
* ---------------------- BEGIN TIMING CODE -------------------------
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT
* ITCNT IS INITIALIZED TO 0, OPS IS ONLY INCREMENTED
* OPST IS USED TO ACCUMULATE SMALL CONTRIBUTIONS TO OPS
* TO AVOID ROUNDOFF ERROR
* .. COMMON BLOCKS ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. SCALARS IN COMMON ..
DOUBLE PRECISION ITCNT, OPS
* ..
* ----------------------- END TIMING CODE --------------------------
*
C
C THIS SUBROUTINE IS THE FIRST STEP OF THE QZ ALGORITHM
C FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS,
C SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART.
C
C THIS SUBROUTINE ACCEPTS A PAIR OF REAL GENERAL MATRICES AND
C REDUCES ONE OF THEM TO UPPER HESSENBERG FORM AND THE OTHER
C TO UPPER TRIANGULAR FORM USING ORTHOGONAL TRANSFORMATIONS.
C IT IS USUALLY FOLLOWED BY QZIT, QZVAL AND, POSSIBLY, QZVEC.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRICES.
C
C A CONTAINS A REAL GENERAL MATRIX.
C
C B CONTAINS A REAL GENERAL MATRIX.
C
C MATZ SHOULD BE SET TO .TRUE. IF THE RIGHT HAND TRANSFORMATIONS
C ARE TO BE ACCUMULATED FOR LATER USE IN COMPUTING
C EIGENVECTORS, AND TO .FALSE. OTHERWISE.
C
C ON OUTPUT
C
C A HAS BEEN REDUCED TO UPPER HESSENBERG FORM. THE ELEMENTS
C BELOW THE FIRST SUBDIAGONAL HAVE BEEN SET TO ZERO.
C
C B HAS BEEN REDUCED TO UPPER TRIANGULAR FORM. THE ELEMENTS
C BELOW THE MAIN DIAGONAL HAVE BEEN SET TO ZERO.
C
C Z CONTAINS THE PRODUCT OF THE RIGHT HAND TRANSFORMATIONS IF
C MATZ HAS BEEN SET TO .TRUE. OTHERWISE, Z IS NOT REFERENCED.
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
C
C .......... INITIALIZE Z ..........
IF (.NOT. MATZ) GO TO 10
C
DO 3 J = 1, N
C
DO 2 I = 1, N
Z(I,J) = 0.0D0
2 CONTINUE
C
Z(J,J) = 1.0D0
3 CONTINUE
C .......... REDUCE B TO UPPER TRIANGULAR FORM ..........
10 IF (N .LE. 1) GO TO 170
NM1 = N - 1
C
DO 100 L = 1, NM1
L1 = L + 1
S = 0.0D0
C
DO 20 I = L1, N
S = S + DABS(B(I,L))
20 CONTINUE
C
IF (S .EQ. 0.0D0) GO TO 100
S = S + DABS(B(L,L))
R = 0.0D0
C
DO 25 I = L, N
B(I,L) = B(I,L) / S
R = R + B(I,L)**2
25 CONTINUE
C
R = DSIGN(DSQRT(R),B(L,L))
B(L,L) = B(L,L) + R
RHO = R * B(L,L)
C
DO 50 J = L1, N
T = 0.0D0
C
DO 30 I = L, N
T = T + B(I,L) * B(I,J)
30 CONTINUE
C
T = -T / RHO
C
DO 40 I = L, N
B(I,J) = B(I,J) + T * B(I,L)
40 CONTINUE
C
50 CONTINUE
C
DO 80 J = 1, N
T = 0.0D0
C
DO 60 I = L, N
T = T + B(I,L) * A(I,J)
60 CONTINUE
C
T = -T / RHO
C
DO 70 I = L, N
A(I,J) = A(I,J) + T * B(I,L)
70 CONTINUE
C
80 CONTINUE
C
B(L,L) = -S * R
C
DO 90 I = L1, N
B(I,L) = 0.0D0
90 CONTINUE
C
100 CONTINUE
*
* ---------------------- BEGIN TIMING CODE -------------------------
OPS = OPS + DBLE( 8*N**2 + 17*N + 24 )*DBLE( N-1 ) / 3.0D0
* ----------------------- END TIMING CODE --------------------------
*
C .......... REDUCE A TO UPPER HESSENBERG FORM, WHILE
C KEEPING B TRIANGULAR ..........
IF (N .EQ. 2) GO TO 170
NM2 = N - 2
C
DO 160 K = 1, NM2
NK1 = NM1 - K
C .......... FOR L=N-1 STEP -1 UNTIL K+1 DO -- ..........
DO 150 LB = 1, NK1
L = N - LB
L1 = L + 1
C .......... ZERO A(L+1,K) ..........
S = DABS(A(L,K)) + DABS(A(L1,K))
IF (S .EQ. 0.0D0) GO TO 150
U1 = A(L,K) / S
U2 = A(L1,K) / S
R = DSIGN(DSQRT(U1*U1+U2*U2),U1)
V1 = -(U1 + R) / R
V2 = -U2 / R
U2 = V2 / V1
C
DO 110 J = K, N
T = A(L,J) + U2 * A(L1,J)
A(L,J) = A(L,J) + T * V1
A(L1,J) = A(L1,J) + T * V2
110 CONTINUE
C
A(L1,K) = 0.0D0
C
DO 120 J = L, N
T = B(L,J) + U2 * B(L1,J)
B(L,J) = B(L,J) + T * V1
B(L1,J) = B(L1,J) + T * V2
120 CONTINUE
C .......... ZERO B(L+1,L) ..........
S = DABS(B(L1,L1)) + DABS(B(L1,L))
IF (S .EQ. 0.0D0) GO TO 150
U1 = B(L1,L1) / S
U2 = B(L1,L) / S
R = DSIGN(DSQRT(U1*U1+U2*U2),U1)
V1 = -(U1 + R) / R
V2 = -U2 / R
U2 = V2 / V1
C
DO 130 I = 1, L1
T = B(I,L1) + U2 * B(I,L)
B(I,L1) = B(I,L1) + T * V1
B(I,L) = B(I,L) + T * V2
130 CONTINUE
C
B(L1,L) = 0.0D0
C
DO 140 I = 1, N
T = A(I,L1) + U2 * A(I,L)
A(I,L1) = A(I,L1) + T * V1
A(I,L) = A(I,L) + T * V2
140 CONTINUE
C
IF (.NOT. MATZ) GO TO 150
C
DO 145 I = 1, N
T = Z(I,L1) + U2 * Z(I,L)
Z(I,L1) = Z(I,L1) + T * V1
Z(I,L) = Z(I,L) + T * V2
145 CONTINUE
C
150 CONTINUE
C
160 CONTINUE
C
*
* ---------------------- BEGIN TIMING CODE -------------------------
IF( MATZ ) THEN
OPS = OPS + DBLE( 11*N + 20 )*DBLE( N-1 )*DBLE( N-2 )
ELSE
OPS = OPS + DBLE( 8*N + 20 )*DBLE( N-1 )*DBLE( N-2 )
END IF
* ----------------------- END TIMING CODE --------------------------
*
170 RETURN
END
SUBROUTINE QZIT(NM,N,A,B,EPS1,MATZ,Z,IERR)
C
INTEGER I,J,K,L,N,EN,K1,K2,LD,LL,L1,NA,NM,ISH,ITN,ITS,KM1,LM1,
X ENM2,IERR,LOR1,ENORN
DOUBLE PRECISION A(NM,N),B(NM,N),Z(NM,N)
DOUBLE PRECISION R,S,T,A1,A2,A3,EP,SH,U1,U2,U3,V1,V2,V3,ANI,A11,
X A12,A21,A22,A33,A34,A43,A44,BNI,B11,B12,B22,B33,B34,
X B44,EPSA,EPSB,EPS1,ANORM,BNORM,EPSLON
LOGICAL MATZ,NOTLAS
external epslon
*
* ---------------------- BEGIN TIMING CODE -------------------------
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT
* ITCNT IS INITIALIZED TO 0, OPS IS ONLY INCREMENTED
* OPST IS USED TO ACCUMULATE SMALL CONTRIBUTIONS TO OPS
* TO AVOID ROUNDOFF ERROR
* .. COMMON BLOCKS ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. SCALARS IN COMMON ..
DOUBLE PRECISION ITCNT, OPS
* ..
DOUBLE PRECISION OPST
* ----------------------- END TIMING CODE --------------------------
*
C
C THIS SUBROUTINE IS THE SECOND STEP OF THE QZ ALGORITHM
C FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS,
C SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART,
C AS MODIFIED IN TECHNICAL NOTE NASA TN D-7305(1973) BY WARD.
C
C THIS SUBROUTINE ACCEPTS A PAIR OF REAL MATRICES, ONE OF THEM
C IN UPPER HESSENBERG FORM AND THE OTHER IN UPPER TRIANGULAR FORM.
C IT REDUCES THE HESSENBERG MATRIX TO QUASI-TRIANGULAR FORM USING
C ORTHOGONAL TRANSFORMATIONS WHILE MAINTAINING THE TRIANGULAR FORM
C OF THE OTHER MATRIX. IT IS USUALLY PRECEDED BY QZHES AND
C FOLLOWED BY QZVAL AND, POSSIBLY, QZVEC.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRICES.
C
C A CONTAINS A REAL UPPER HESSENBERG MATRIX.
C
C B CONTAINS A REAL UPPER TRIANGULAR MATRIX.
C
C EPS1 IS A TOLERANCE USED TO DETERMINE NEGLIGIBLE ELEMENTS.
C EPS1 = 0.0 (OR NEGATIVE) MAY BE INPUT, IN WHICH CASE AN
C ELEMENT WILL BE NEGLECTED ONLY IF IT IS LESS THAN ROUNDOFF
C ERROR TIMES THE NORM OF ITS MATRIX. IF THE INPUT EPS1 IS
C POSITIVE, THEN AN ELEMENT WILL BE CONSIDERED NEGLIGIBLE
C IF IT IS LESS THAN EPS1 TIMES THE NORM OF ITS MATRIX. A
C POSITIVE VALUE OF EPS1 MAY RESULT IN FASTER EXECUTION,
C BUT LESS ACCURATE RESULTS.
C
C MATZ SHOULD BE SET TO .TRUE. IF THE RIGHT HAND TRANSFORMATIONS
C ARE TO BE ACCUMULATED FOR LATER USE IN COMPUTING
C EIGENVECTORS, AND TO .FALSE. OTHERWISE.
C
C Z CONTAINS, IF MATZ HAS BEEN SET TO .TRUE., THE
C TRANSFORMATION MATRIX PRODUCED IN THE REDUCTION
C BY QZHES, IF PERFORMED, OR ELSE THE IDENTITY MATRIX.
C IF MATZ HAS BEEN SET TO .FALSE., Z IS NOT REFERENCED.
C
C ON OUTPUT
C
C A HAS BEEN REDUCED TO QUASI-TRIANGULAR FORM. THE ELEMENTS
C BELOW THE FIRST SUBDIAGONAL ARE STILL ZERO AND NO TWO
C CONSECUTIVE SUBDIAGONAL ELEMENTS ARE NONZERO.
C
C B IS STILL IN UPPER TRIANGULAR FORM, ALTHOUGH ITS ELEMENTS
C HAVE BEEN ALTERED. THE LOCATION B(N,1) IS USED TO STORE
C EPS1 TIMES THE NORM OF B FOR LATER USE BY QZVAL AND QZVEC.
C
C Z CONTAINS THE PRODUCT OF THE RIGHT HAND TRANSFORMATIONS
C (FOR BOTH STEPS) IF MATZ HAS BEEN SET TO .TRUE..
C
C IERR IS SET TO
C ZERO FOR NORMAL RETURN,
C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
C
IERR = 0
C .......... COMPUTE EPSA,EPSB ..........
ANORM = 0.0D0
BNORM = 0.0D0
C
DO 30 I = 1, N
ANI = 0.0D0
IF (I .NE. 1) ANI = DABS(A(I,I-1))
BNI = 0.0D0
C
DO 20 J = I, N
ANI = ANI + DABS(A(I,J))
BNI = BNI + DABS(B(I,J))
20 CONTINUE
C
IF (ANI .GT. ANORM) ANORM = ANI
IF (BNI .GT. BNORM) BNORM = BNI
30 CONTINUE
*
* ---------------------- BEGIN TIMING CODE -------------------------
OPS = OPS + DBLE( N*( N+1 ) )
OPST = 0.0D0
ITCNT = 0
* ----------------------- END TIMING CODE --------------------------
*
C
IF (ANORM .EQ. 0.0D0) ANORM = 1.0D0
IF (BNORM .EQ. 0.0D0) BNORM = 1.0D0
EP = EPS1
IF (EP .GT. 0.0D0) GO TO 50
C .......... USE ROUNDOFF LEVEL IF EPS1 IS ZERO ..........
EP = EPSLON(1.0D0)
50 EPSA = EP * ANORM
EPSB = EP * BNORM
C .......... REDUCE A TO QUASI-TRIANGULAR FORM, WHILE
C KEEPING B TRIANGULAR ..........
LOR1 = 1
ENORN = N
EN = N
ITN = 30*N
C .......... BEGIN QZ STEP ..........
60 IF (EN .LE. 2) GO TO 1001
IF (.NOT. MATZ) ENORN = EN
ITS = 0
NA = EN - 1
ENM2 = NA - 1
70 ISH = 2
*
* ---------------------- BEGIN TIMING CODE -------------------------
OPS = OPS + OPST
OPST = 0.0D0
ITCNT = ITCNT + 1
* ----------------------- END TIMING CODE --------------------------
*
C .......... CHECK FOR CONVERGENCE OR REDUCIBILITY.
C FOR L=EN STEP -1 UNTIL 1 DO -- ..........
DO 80 LL = 1, EN
LM1 = EN - LL
L = LM1 + 1
IF (L .EQ. 1) GO TO 95
IF (DABS(A(L,LM1)) .LE. EPSA) GO TO 90
80 CONTINUE
C
90 A(L,LM1) = 0.0D0
IF (L .LT. NA) GO TO 95
C .......... 1-BY-1 OR 2-BY-2 BLOCK ISOLATED ..........
EN = LM1
GO TO 60
C .......... CHECK FOR SMALL TOP OF B ..........
95 LD = L
100 L1 = L + 1
B11 = B(L,L)
IF (DABS(B11) .GT. EPSB) GO TO 120
B(L,L) = 0.0D0
S = DABS(A(L,L)) + DABS(A(L1,L))
U1 = A(L,L) / S
U2 = A(L1,L) / S
R = DSIGN(DSQRT(U1*U1+U2*U2),U1)
V1 = -(U1 + R) / R
V2 = -U2 / R
U2 = V2 / V1
C
DO 110 J = L, ENORN
T = A(L,J) + U2 * A(L1,J)
A(L,J) = A(L,J) + T * V1
A(L1,J) = A(L1,J) + T * V2
T = B(L,J) + U2 * B(L1,J)
B(L,J) = B(L,J) + T * V1
B(L1,J) = B(L1,J) + T * V2
110 CONTINUE
C
* ---------------------- BEGIN TIMING CODE -------------------------
OPST = OPST + DBLE( 12*( ENORN+1-L ) + 11 )
* ----------------------- END TIMING CODE --------------------------
IF (L .NE. 1) A(L,LM1) = -A(L,LM1)
LM1 = L
L = L1
GO TO 90
120 A11 = A(L,L) / B11
A21 = A(L1,L) / B11
IF (ISH .EQ. 1) GO TO 140
C .......... ITERATION STRATEGY ..........
IF (ITN .EQ. 0) GO TO 1000
IF (ITS .EQ. 10) GO TO 155
C .......... DETERMINE TYPE OF SHIFT ..........
B22 = B(L1,L1)
IF (DABS(B22) .LT. EPSB) B22 = EPSB
B33 = B(NA,NA)
IF (DABS(B33) .LT. EPSB) B33 = EPSB
B44 = B(EN,EN)
IF (DABS(B44) .LT. EPSB) B44 = EPSB
A33 = A(NA,NA) / B33
A34 = A(NA,EN) / B44
A43 = A(EN,NA) / B33
A44 = A(EN,EN) / B44
B34 = B(NA,EN) / B44
T = 0.5D0 * (A43 * B34 - A33 - A44)
R = T * T + A34 * A43 - A33 * A44
* ---------------------- BEGIN TIMING CODE -------------------------
OPST = OPST + DBLE( 16 )
* ----------------------- END TIMING CODE --------------------------
IF (R .LT. 0.0D0) GO TO 150
C .......... DETERMINE SINGLE SHIFT ZEROTH COLUMN OF A ..........
ISH = 1
R = DSQRT(R)
SH = -T + R
S = -T - R
IF (DABS(S-A44) .LT. DABS(SH-A44)) SH = S
C .......... LOOK FOR TWO CONSECUTIVE SMALL
C SUB-DIAGONAL ELEMENTS OF A.
C FOR L=EN-2 STEP -1 UNTIL LD DO -- ..........
DO 130 LL = LD, ENM2
L = ENM2 + LD - LL
IF (L .EQ. LD) GO TO 140
LM1 = L - 1
L1 = L + 1
T = A(L,L)
IF (DABS(B(L,L)) .GT. EPSB) T = T - SH * B(L,L)
* --------------------- BEGIN TIMING CODE -----------------------
IF (DABS(A(L,LM1)) .LE. DABS(T/A(L1,L)) * EPSA) THEN
OPST = OPST + DBLE( 5 + 4*( LL+1-LD ) )
GO TO 100
END IF
* ---------------------- END TIMING CODE ------------------------
130 CONTINUE
* ---------------------- BEGIN TIMING CODE -------------------------
OPST = OPST + DBLE( 5 + 4*( ENM2+1-LD ) )
* ----------------------- END TIMING CODE --------------------------
C
140 A1 = A11 - SH
A2 = A21
IF (L .NE. LD) A(L,LM1) = -A(L,LM1)
GO TO 160
C .......... DETERMINE DOUBLE SHIFT ZEROTH COLUMN OF A ..........
150 A12 = A(L,L1) / B22
A22 = A(L1,L1) / B22
B12 = B(L,L1) / B22
A1 = ((A33 - A11) * (A44 - A11) - A34 * A43 + A43 * B34 * A11)
X / A21 + A12 - A11 * B12
A2 = (A22 - A11) - A21 * B12 - (A33 - A11) - (A44 - A11)
X + A43 * B34
A3 = A(L1+1,L1) / B22
* ---------------------- BEGIN TIMING CODE -------------------------
OPST = OPST + DBLE( 25 )
* ----------------------- END TIMING CODE --------------------------
GO TO 160
C .......... AD HOC SHIFT ..........
155 A1 = 0.0D0
A2 = 1.0D0
A3 = 1.1605D0
160 ITS = ITS + 1
ITN = ITN - 1
IF (.NOT. MATZ) LOR1 = LD
C .......... MAIN LOOP ..........
DO 260 K = L, NA
NOTLAS = K .NE. NA .AND. ISH .EQ. 2
K1 = K + 1
K2 = K + 2
KM1 = MAX0(K-1,L)
LL = MIN0(EN,K1+ISH)
IF (NOTLAS) GO TO 190
C .......... ZERO A(K+1,K-1) ..........
IF (K .EQ. L) GO TO 170
A1 = A(K,KM1)
A2 = A(K1,KM1)
170 S = DABS(A1) + DABS(A2)
IF (S .EQ. 0.0D0) GO TO 70
U1 = A1 / S
U2 = A2 / S
R = DSIGN(DSQRT(U1*U1+U2*U2),U1)
V1 = -(U1 + R) / R
V2 = -U2 / R
U2 = V2 / V1
C
DO 180 J = KM1, ENORN
T = A(K,J) + U2 * A(K1,J)
A(K,J) = A(K,J) + T * V1
A(K1,J) = A(K1,J) + T * V2
T = B(K,J) + U2 * B(K1,J)
B(K,J) = B(K,J) + T * V1
B(K1,J) = B(K1,J) + T * V2
180 CONTINUE
C
* --------------------- BEGIN TIMING CODE -----------------------
OPST = OPST + DBLE( 11 + 12*( ENORN+1-KM1 ) )
* ---------------------- END TIMING CODE ------------------------
IF (K .NE. L) A(K1,KM1) = 0.0D0
GO TO 240
C .......... ZERO A(K+1,K-1) AND A(K+2,K-1) ..........
190 IF (K .EQ. L) GO TO 200
A1 = A(K,KM1)
A2 = A(K1,KM1)
A3 = A(K2,KM1)
200 S = DABS(A1) + DABS(A2) + DABS(A3)
IF (S .EQ. 0.0D0) GO TO 260
U1 = A1 / S
U2 = A2 / S
U3 = A3 / S
R = DSIGN(DSQRT(U1*U1+U2*U2+U3*U3),U1)
V1 = -(U1 + R) / R
V2 = -U2 / R
V3 = -U3 / R
U2 = V2 / V1
U3 = V3 / V1
C
DO 210 J = KM1, ENORN
T = A(K,J) + U2 * A(K1,J) + U3 * A(K2,J)
A(K,J) = A(K,J) + T * V1
A(K1,J) = A(K1,J) + T * V2
A(K2,J) = A(K2,J) + T * V3
T = B(K,J) + U2 * B(K1,J) + U3 * B(K2,J)
B(K,J) = B(K,J) + T * V1
B(K1,J) = B(K1,J) + T * V2
B(K2,J) = B(K2,J) + T * V3
210 CONTINUE
* --------------------- BEGIN TIMING CODE -----------------------
OPST = OPST + DBLE( 17 + 20*( ENORN+1-KM1 ) )
* ---------------------- END TIMING CODE ------------------------
C
IF (K .EQ. L) GO TO 220
A(K1,KM1) = 0.0D0
A(K2,KM1) = 0.0D0
C .......... ZERO B(K+2,K+1) AND B(K+2,K) ..........
220 S = DABS(B(K2,K2)) + DABS(B(K2,K1)) + DABS(B(K2,K))
IF (S .EQ. 0.0D0) GO TO 240
U1 = B(K2,K2) / S
U2 = B(K2,K1) / S
U3 = B(K2,K) / S
R = DSIGN(DSQRT(U1*U1+U2*U2+U3*U3),U1)
V1 = -(U1 + R) / R
V2 = -U2 / R
V3 = -U3 / R
U2 = V2 / V1
U3 = V3 / V1
C
DO 230 I = LOR1, LL
T = A(I,K2) + U2 * A(I,K1) + U3 * A(I,K)
A(I,K2) = A(I,K2) + T * V1
A(I,K1) = A(I,K1) + T * V2
A(I,K) = A(I,K) + T * V3
T = B(I,K2) + U2 * B(I,K1) + U3 * B(I,K)
B(I,K2) = B(I,K2) + T * V1
B(I,K1) = B(I,K1) + T * V2
B(I,K) = B(I,K) + T * V3
230 CONTINUE
* --------------------- BEGIN TIMING CODE -----------------------
OPST = OPST + DBLE( 17 + 20*( LL+1-LOR1 ) )
* ---------------------- END TIMING CODE ------------------------
C
B(K2,K) = 0.0D0
B(K2,K1) = 0.0D0
IF (.NOT. MATZ) GO TO 240
C
DO 235 I = 1, N
T = Z(I,K2) + U2 * Z(I,K1) + U3 * Z(I,K)
Z(I,K2) = Z(I,K2) + T * V1
Z(I,K1) = Z(I,K1) + T * V2
Z(I,K) = Z(I,K) + T * V3
235 CONTINUE
* --------------------- BEGIN TIMING CODE -----------------------
OPST = OPST + DBLE( 10*N )
* ---------------------- END TIMING CODE ------------------------
C .......... ZERO B(K+1,K) ..........
240 S = DABS(B(K1,K1)) + DABS(B(K1,K))
IF (S .EQ. 0.0D0) GO TO 260
U1 = B(K1,K1) / S
U2 = B(K1,K) / S
R = DSIGN(DSQRT(U1*U1+U2*U2),U1)
V1 = -(U1 + R) / R
V2 = -U2 / R
U2 = V2 / V1
C
DO 250 I = LOR1, LL
T = A(I,K1) + U2 * A(I,K)
A(I,K1) = A(I,K1) + T * V1
A(I,K) = A(I,K) + T * V2
T = B(I,K1) + U2 * B(I,K)
B(I,K1) = B(I,K1) + T * V1
B(I,K) = B(I,K) + T * V2
250 CONTINUE
* --------------------- BEGIN TIMING CODE -----------------------
OPST = OPST + DBLE( 11 + 12*( LL+1-LOR1 ) )
* ---------------------- END TIMING CODE ------------------------
C
B(K1,K) = 0.0D0
IF (.NOT. MATZ) GO TO 260
C
DO 255 I = 1, N
T = Z(I,K1) + U2 * Z(I,K)
Z(I,K1) = Z(I,K1) + T * V1
Z(I,K) = Z(I,K) + T * V2
255 CONTINUE
* --------------------- BEGIN TIMING CODE -----------------------
OPST = OPST + DBLE( 6*N )
* ---------------------- END TIMING CODE ------------------------
C
260 CONTINUE
C .......... END QZ STEP ..........
GO TO 70
C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
C CONVERGED AFTER 30*N ITERATIONS ..........
1000 IERR = EN
C .......... SAVE EPSB FOR USE BY QZVAL AND QZVEC ..........
1001 IF (N .GT. 1) B(N,1) = EPSB
*
* ---------------------- BEGIN TIMING CODE -------------------------
OPS = OPS + OPST
OPST = 0.0D0
* ----------------------- END TIMING CODE --------------------------
*
RETURN
END
SUBROUTINE QZVAL(NM,N,A,B,ALFR,ALFI,BETA,MATZ,Z)
C
INTEGER I,J,N,EN,NA,NM,NN,ISW
DOUBLE PRECISION A(NM,N),B(NM,N),ALFR(N),ALFI(N),BETA(N),Z(NM,N)
DOUBLE PRECISION C,D,E,R,S,T,AN,A1,A2,BN,CQ,CZ,DI,DR,EI,TI,TR,U1,
X U2,V1,V2,A1I,A11,A12,A2I,A21,A22,B11,B12,B22,SQI,SQR,
X SSI,SSR,SZI,SZR,A11I,A11R,A12I,A12R,A22I,A22R,EPSB
LOGICAL MATZ
*
* ---------------------- BEGIN TIMING CODE -------------------------
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT
* ITCNT IS INITIALIZED TO 0, OPS IS ONLY INCREMENTED
* OPST IS USED TO ACCUMULATE SMALL CONTRIBUTIONS TO OPS
* TO AVOID ROUNDOFF ERROR
* .. COMMON BLOCKS ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. SCALARS IN COMMON ..
DOUBLE PRECISION ITCNT, OPS
* ..
DOUBLE PRECISION OPST, OPST2
* ----------------------- END TIMING CODE --------------------------
*
C
C THIS SUBROUTINE IS THE THIRD STEP OF THE QZ ALGORITHM
C FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS,
C SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART.
C
C THIS SUBROUTINE ACCEPTS A PAIR OF REAL MATRICES, ONE OF THEM
C IN QUASI-TRIANGULAR FORM AND THE OTHER IN UPPER TRIANGULAR FORM.
C IT REDUCES THE QUASI-TRIANGULAR MATRIX FURTHER, SO THAT ANY
C REMAINING 2-BY-2 BLOCKS CORRESPOND TO PAIRS OF COMPLEX
C EIGENVALUES, AND RETURNS QUANTITIES WHOSE RATIOS GIVE THE
C GENERALIZED EIGENVALUES. IT IS USUALLY PRECEDED BY QZHES
C AND QZIT AND MAY BE FOLLOWED BY QZVEC.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRICES.
C
C A CONTAINS A REAL UPPER QUASI-TRIANGULAR MATRIX.
C
C B CONTAINS A REAL UPPER TRIANGULAR MATRIX. IN ADDITION,
C LOCATION B(N,1) CONTAINS THE TOLERANCE QUANTITY (EPSB)
C COMPUTED AND SAVED IN QZIT.
C
C MATZ SHOULD BE SET TO .TRUE. IF THE RIGHT HAND TRANSFORMATIONS
C ARE TO BE ACCUMULATED FOR LATER USE IN COMPUTING
C EIGENVECTORS, AND TO .FALSE. OTHERWISE.
C
C Z CONTAINS, IF MATZ HAS BEEN SET TO .TRUE., THE
C TRANSFORMATION MATRIX PRODUCED IN THE REDUCTIONS BY QZHES
C AND QZIT, IF PERFORMED, OR ELSE THE IDENTITY MATRIX.
C IF MATZ HAS BEEN SET TO .FALSE., Z IS NOT REFERENCED.
C
C ON OUTPUT
C
C A HAS BEEN REDUCED FURTHER TO A QUASI-TRIANGULAR MATRIX
C IN WHICH ALL NONZERO SUBDIAGONAL ELEMENTS CORRESPOND TO
C PAIRS OF COMPLEX EIGENVALUES.
C
C B IS STILL IN UPPER TRIANGULAR FORM, ALTHOUGH ITS ELEMENTS
C HAVE BEEN ALTERED. B(N,1) IS UNALTERED.
C
C ALFR AND ALFI CONTAIN THE REAL AND IMAGINARY PARTS OF THE
C DIAGONAL ELEMENTS OF THE TRIANGULAR MATRIX THAT WOULD BE
C OBTAINED IF A WERE REDUCED COMPLETELY TO TRIANGULAR FORM
C BY UNITARY TRANSFORMATIONS. NON-ZERO VALUES OF ALFI OCCUR
C IN PAIRS, THE FIRST MEMBER POSITIVE AND THE SECOND NEGATIVE.
C
C BETA CONTAINS THE DIAGONAL ELEMENTS OF THE CORRESPONDING B,
C NORMALIZED TO BE REAL AND NON-NEGATIVE. THE GENERALIZED
C EIGENVALUES ARE THEN THE RATIOS ((ALFR+I*ALFI)/BETA).
C
C Z CONTAINS THE PRODUCT OF THE RIGHT HAND TRANSFORMATIONS
C (FOR ALL THREE STEPS) IF MATZ HAS BEEN SET TO .TRUE.
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
C
EPSB = B(N,1)
ISW = 1
C .......... FIND EIGENVALUES OF QUASI-TRIANGULAR MATRICES.
C FOR EN=N STEP -1 UNTIL 1 DO -- ..........
*
* ---------------------- BEGIN TIMING CODE -------------------------
OPST = 0.0D0
OPST2 = 0.0D0
* ----------------------- END TIMING CODE --------------------------
*
DO 510 NN = 1, N
*
* --------------------- BEGIN TIMING CODE -----------------------
OPST = OPST + OPST2
OPST2 = 0.0D0
* ---------------------- END TIMING CODE ------------------------
*
EN = N + 1 - NN
NA = EN - 1
IF (ISW .EQ. 2) GO TO 505
IF (EN .EQ. 1) GO TO 410
IF (A(EN,NA) .NE. 0.0D0) GO TO 420
C .......... 1-BY-1 BLOCK, ONE REAL ROOT ..........
410 ALFR(EN) = A(EN,EN)
IF (B(EN,EN) .LT. 0.0D0) ALFR(EN) = -ALFR(EN)
BETA(EN) = DABS(B(EN,EN))
ALFI(EN) = 0.0D0
GO TO 510
C .......... 2-BY-2 BLOCK ..........
420 IF (DABS(B(NA,NA)) .LE. EPSB) GO TO 455
IF (DABS(B(EN,EN)) .GT. EPSB) GO TO 430
A1 = A(EN,EN)
A2 = A(EN,NA)
BN = 0.0D0
GO TO 435
430 AN = DABS(A(NA,NA)) + DABS(A(NA,EN)) + DABS(A(EN,NA))
X + DABS(A(EN,EN))
BN = DABS(B(NA,NA)) + DABS(B(NA,EN)) + DABS(B(EN,EN))
A11 = A(NA,NA) / AN
A12 = A(NA,EN) / AN
A21 = A(EN,NA) / AN
A22 = A(EN,EN) / AN
B11 = B(NA,NA) / BN
B12 = B(NA,EN) / BN
B22 = B(EN,EN) / BN
E = A11 / B11
EI = A22 / B22
S = A21 / (B11 * B22)
T = (A22 - E * B22) / B22
IF (DABS(E) .LE. DABS(EI)) GO TO 431
E = EI
T = (A11 - E * B11) / B11
431 C = 0.5D0 * (T - S * B12)
D = C * C + S * (A12 - E * B12)
* --------------------- BEGIN TIMING CODE -----------------------
OPST2 = OPST2 + DBLE( 28 )
* ---------------------- END TIMING CODE ------------------------
IF (D .LT. 0.0D0) GO TO 480
C .......... TWO REAL ROOTS.
C ZERO BOTH A(EN,NA) AND B(EN,NA) ..........
E = E + (C + DSIGN(DSQRT(D),C))
A11 = A11 - E * B11
A12 = A12 - E * B12
A22 = A22 - E * B22
* --------------------- BEGIN TIMING CODE -----------------------
OPST2 = OPST2 + DBLE( 11 )
* ---------------------- END TIMING CODE ------------------------
IF (DABS(A11) + DABS(A12) .LT.
X DABS(A21) + DABS(A22)) GO TO 432
A1 = A12
A2 = A11
GO TO 435
432 A1 = A22
A2 = A21
C .......... CHOOSE AND APPLY REAL Z ..........
435 S = DABS(A1) + DABS(A2)
U1 = A1 / S
U2 = A2 / S
R = DSIGN(DSQRT(U1*U1+U2*U2),U1)
V1 = -(U1 + R) / R
V2 = -U2 / R
U2 = V2 / V1
C
DO 440 I = 1, EN
T = A(I,EN) + U2 * A(I,NA)
A(I,EN) = A(I,EN) + T * V1
A(I,NA) = A(I,NA) + T * V2
T = B(I,EN) + U2 * B(I,NA)
B(I,EN) = B(I,EN) + T * V1
B(I,NA) = B(I,NA) + T * V2
440 CONTINUE
* --------------------- BEGIN TIMING CODE -----------------------
OPST2 = OPST2 + DBLE( 11 + 12*EN )
* ---------------------- END TIMING CODE ------------------------
C
IF (.NOT. MATZ) GO TO 450
C
DO 445 I = 1, N
T = Z(I,EN) + U2 * Z(I,NA)
Z(I,EN) = Z(I,EN) + T * V1
Z(I,NA) = Z(I,NA) + T * V2
445 CONTINUE
* --------------------- BEGIN TIMING CODE -----------------------
OPST2 = OPST2 + DBLE( 6*N )
* ---------------------- END TIMING CODE ------------------------
C
450 IF (BN .EQ. 0.0D0) GO TO 475
IF (AN .LT. DABS(E) * BN) GO TO 455
A1 = B(NA,NA)
A2 = B(EN,NA)
GO TO 460
455 A1 = A(NA,NA)
A2 = A(EN,NA)
C .......... CHOOSE AND APPLY REAL Q ..........
460 S = DABS(A1) + DABS(A2)
IF (S .EQ. 0.0D0) GO TO 475
U1 = A1 / S
U2 = A2 / S
R = DSIGN(DSQRT(U1*U1+U2*U2),U1)
V1 = -(U1 + R) / R
V2 = -U2 / R
U2 = V2 / V1
C
DO 470 J = NA, N
T = A(NA,J) + U2 * A(EN,J)
A(NA,J) = A(NA,J) + T * V1
A(EN,J) = A(EN,J) + T * V2
T = B(NA,J) + U2 * B(EN,J)
B(NA,J) = B(NA,J) + T * V1
B(EN,J) = B(EN,J) + T * V2
470 CONTINUE
* --------------------- BEGIN TIMING CODE -----------------------
OPST2 = OPST2 + DBLE( 11 + 12*( N+1-NA ) )
* ---------------------- END TIMING CODE ------------------------
C
475 A(EN,NA) = 0.0D0
B(EN,NA) = 0.0D0
ALFR(NA) = A(NA,NA)
ALFR(EN) = A(EN,EN)
IF (B(NA,NA) .LT. 0.0D0) ALFR(NA) = -ALFR(NA)
IF (B(EN,EN) .LT. 0.0D0) ALFR(EN) = -ALFR(EN)
BETA(NA) = DABS(B(NA,NA))
BETA(EN) = DABS(B(EN,EN))
ALFI(EN) = 0.0D0
ALFI(NA) = 0.0D0
GO TO 505
C .......... TWO COMPLEX ROOTS ..........
480 E = E + C
EI = DSQRT(-D)
A11R = A11 - E * B11
A11I = EI * B11
A12R = A12 - E * B12
A12I = EI * B12
A22R = A22 - E * B22
A22I = EI * B22
IF (DABS(A11R) + DABS(A11I) + DABS(A12R) + DABS(A12I) .LT.
X DABS(A21) + DABS(A22R) + DABS(A22I)) GO TO 482
A1 = A12R
A1I = A12I
A2 = -A11R
A2I = -A11I
GO TO 485
482 A1 = A22R
A1I = A22I
A2 = -A21
A2I = 0.0D0
C .......... CHOOSE COMPLEX Z ..........
485 CZ = DSQRT(A1*A1+A1I*A1I)
IF (CZ .EQ. 0.0D0) GO TO 487
SZR = (A1 * A2 + A1I * A2I) / CZ
SZI = (A1 * A2I - A1I * A2) / CZ
R = DSQRT(CZ*CZ+SZR*SZR+SZI*SZI)
CZ = CZ / R
SZR = SZR / R
SZI = SZI / R
GO TO 490
487 SZR = 1.0D0
SZI = 0.0D0
490 IF (AN .LT. (DABS(E) + EI) * BN) GO TO 492
A1 = CZ * B11 + SZR * B12
A1I = SZI * B12
A2 = SZR * B22
A2I = SZI * B22
GO TO 495
492 A1 = CZ * A11 + SZR * A12
A1I = SZI * A12
A2 = CZ * A21 + SZR * A22
A2I = SZI * A22
C .......... CHOOSE COMPLEX Q ..........
495 CQ = DSQRT(A1*A1+A1I*A1I)
IF (CQ .EQ. 0.0D0) GO TO 497
SQR = (A1 * A2 + A1I * A2I) / CQ
SQI = (A1 * A2I - A1I * A2) / CQ
R = DSQRT(CQ*CQ+SQR*SQR+SQI*SQI)
CQ = CQ / R
SQR = SQR / R
SQI = SQI / R
GO TO 500
497 SQR = 1.0D0
SQI = 0.0D0
C .......... COMPUTE DIAGONAL ELEMENTS THAT WOULD RESULT
C IF TRANSFORMATIONS WERE APPLIED ..........
500 SSR = SQR * SZR + SQI * SZI
SSI = SQR * SZI - SQI * SZR
I = 1
TR = CQ * CZ * A11 + CQ * SZR * A12 + SQR * CZ * A21
X + SSR * A22
TI = CQ * SZI * A12 - SQI * CZ * A21 + SSI * A22
DR = CQ * CZ * B11 + CQ * SZR * B12 + SSR * B22
DI = CQ * SZI * B12 + SSI * B22
GO TO 503
502 I = 2
TR = SSR * A11 - SQR * CZ * A12 - CQ * SZR * A21
X + CQ * CZ * A22
TI = -SSI * A11 - SQI * CZ * A12 + CQ * SZI * A21
DR = SSR * B11 - SQR * CZ * B12 + CQ * CZ * B22
DI = -SSI * B11 - SQI * CZ * B12
503 T = TI * DR - TR * DI
J = NA
IF (T .LT. 0.0D0) J = EN
R = DSQRT(DR*DR+DI*DI)
BETA(J) = BN * R
ALFR(J) = AN * (TR * DR + TI * DI) / R
ALFI(J) = AN * T / R
IF (I .EQ. 1) GO TO 502
* --------------------- BEGIN TIMING CODE -----------------------
OPST2 = OPST2 + DBLE( 151 )
* ---------------------- END TIMING CODE ------------------------
505 ISW = 3 - ISW
510 CONTINUE
*
* ---------------------- BEGIN TIMING CODE -------------------------
OPS = OPS + ( OPST + OPST2 )
* ----------------------- END TIMING CODE --------------------------
*
B(N,1) = EPSB
C
RETURN
END
SUBROUTINE QZVEC(NM,N,A,B,ALFR,ALFI,BETA,Z)
C
INTEGER I,J,K,M,N,EN,II,JJ,NA,NM,NN,ISW,ENM2
DOUBLE PRECISION A(NM,N),B(NM,N),ALFR(N),ALFI(N),BETA(N),Z(NM,N)
DOUBLE PRECISION D,Q,R,S,T,W,X,Y,DI,DR,RA,RR,SA,TI,TR,T1,T2,W1,X1,
X ZZ,Z1,ALFM,ALMI,ALMR,BETM,EPSB
*
* ---------------------- BEGIN TIMING CODE -------------------------
* COMMON BLOCK TO RETURN OPERATION COUNT AND ITERATION COUNT
* ITCNT IS INITIALIZED TO 0, OPS IS ONLY INCREMENTED
* OPST IS USED TO ACCUMULATE SMALL CONTRIBUTIONS TO OPS
* TO AVOID ROUNDOFF ERROR
* .. COMMON BLOCKS ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. SCALARS IN COMMON ..
DOUBLE PRECISION ITCNT, OPS
* ..
INTEGER IN2BY2
* ----------------------- END TIMING CODE --------------------------
*
C
C THIS SUBROUTINE IS THE OPTIONAL FOURTH STEP OF THE QZ ALGORITHM
C FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS,
C SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART.
C
C THIS SUBROUTINE ACCEPTS A PAIR OF REAL MATRICES, ONE OF THEM IN
C QUASI-TRIANGULAR FORM (IN WHICH EACH 2-BY-2 BLOCK CORRESPONDS TO
C A PAIR OF COMPLEX EIGENVALUES) AND THE OTHER IN UPPER TRIANGULAR
C FORM. IT COMPUTES THE EIGENVECTORS OF THE TRIANGULAR PROBLEM AND
C TRANSFORMS THE RESULTS BACK TO THE ORIGINAL COORDINATE SYSTEM.
C IT IS USUALLY PRECEDED BY QZHES, QZIT, AND QZVAL.
C
C ON INPUT
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRICES.
C
C A CONTAINS A REAL UPPER QUASI-TRIANGULAR MATRIX.
C
C B CONTAINS A REAL UPPER TRIANGULAR MATRIX. IN ADDITION,
C LOCATION B(N,1) CONTAINS THE TOLERANCE QUANTITY (EPSB)
C COMPUTED AND SAVED IN QZIT.
C
C ALFR, ALFI, AND BETA ARE VECTORS WITH COMPONENTS WHOSE
C RATIOS ((ALFR+I*ALFI)/BETA) ARE THE GENERALIZED
C EIGENVALUES. THEY ARE USUALLY OBTAINED FROM QZVAL.
C
C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
C REDUCTIONS BY QZHES, QZIT, AND QZVAL, IF PERFORMED.
C IF THE EIGENVECTORS OF THE TRIANGULAR PROBLEM ARE
C DESIRED, Z MUST CONTAIN THE IDENTITY MATRIX.
C
C ON OUTPUT
C
C A IS UNALTERED. ITS SUBDIAGONAL ELEMENTS PROVIDE INFORMATION
C ABOUT THE STORAGE OF THE COMPLEX EIGENVECTORS.
C
C B HAS BEEN DESTROYED.
C
C ALFR, ALFI, AND BETA ARE UNALTERED.
C
C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS.
C IF ALFI(I) .EQ. 0.0, THE I-TH EIGENVALUE IS REAL AND
C THE I-TH COLUMN OF Z CONTAINS ITS EIGENVECTOR.
C IF ALFI(I) .NE. 0.0, THE I-TH EIGENVALUE IS COMPLEX.
C IF ALFI(I) .GT. 0.0, THE EIGENVALUE IS THE FIRST OF
C A COMPLEX PAIR AND THE I-TH AND (I+1)-TH COLUMNS
C OF Z CONTAIN ITS EIGENVECTOR.
C IF ALFI(I) .LT. 0.0, THE EIGENVALUE IS THE SECOND OF
C A COMPLEX PAIR AND THE (I-1)-TH AND I-TH COLUMNS
C OF Z CONTAIN THE CONJUGATE OF ITS EIGENVECTOR.
C EACH EIGENVECTOR IS NORMALIZED SO THAT THE MODULUS
C OF ITS LARGEST COMPONENT IS 1.0 .
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION DATED AUGUST 1983.
C
C ------------------------------------------------------------------
C
EPSB = B(N,1)
ISW = 1
C .......... FOR EN=N STEP -1 UNTIL 1 DO -- ..........
DO 800 NN = 1, N
* --------------------- BEGIN TIMING CODE -----------------------
IN2BY2 = 0
* ---------------------- END TIMING CODE ------------------------
EN = N + 1 - NN
NA = EN - 1
IF (ISW .EQ. 2) GO TO 795
IF (ALFI(EN) .NE. 0.0D0) GO TO 710
C .......... REAL VECTOR ..........
M = EN
B(EN,EN) = 1.0D0
IF (NA .EQ. 0) GO TO 800
ALFM = ALFR(M)
BETM = BETA(M)
C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
DO 700 II = 1, NA
I = EN - II
W = BETM * A(I,I) - ALFM * B(I,I)
R = 0.0D0
C
DO 610 J = M, EN
610 R = R + (BETM * A(I,J) - ALFM * B(I,J)) * B(J,EN)
C
IF (I .EQ. 1 .OR. ISW .EQ. 2) GO TO 630
IF (BETM * A(I,I-1) .EQ. 0.0D0) GO TO 630
ZZ = W
S = R
GO TO 690
630 M = I
IF (ISW .EQ. 2) GO TO 640
C .......... REAL 1-BY-1 BLOCK ..........
T = W
IF (W .EQ. 0.0D0) T = EPSB
B(I,EN) = -R / T
GO TO 700
C .......... REAL 2-BY-2 BLOCK ..........
640 X = BETM * A(I,I+1) - ALFM * B(I,I+1)
Y = BETM * A(I+1,I)
Q = W * ZZ - X * Y
T = (X * S - ZZ * R) / Q
B(I,EN) = T
* ------------------- BEGIN TIMING CODE ----------------------
IN2BY2 = IN2BY2 + 1
* -------------------- END TIMING CODE -----------------------
IF (DABS(X) .LE. DABS(ZZ)) GO TO 650
B(I+1,EN) = (-R - W * T) / X
GO TO 690
650 B(I+1,EN) = (-S - Y * T) / ZZ
690 ISW = 3 - ISW
700 CONTINUE
C .......... END REAL VECTOR ..........
* --------------------- BEGIN TIMING CODE -----------------------
OPS = OPS + ( 5.0D0/2.0D0 )*DBLE( ( EN+2 )*( EN-1 ) + IN2BY2 )
* ---------------------- END TIMING CODE ------------------------
GO TO 800
C .......... COMPLEX VECTOR ..........
710 M = NA
ALMR = ALFR(M)
ALMI = ALFI(M)
BETM = BETA(M)
C .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT
C EIGENVECTOR MATRIX IS TRIANGULAR ..........
Y = BETM * A(EN,NA)
B(NA,NA) = -ALMI * B(EN,EN) / Y
B(NA,EN) = (ALMR * B(EN,EN) - BETM * A(EN,EN)) / Y
B(EN,NA) = 0.0D0
B(EN,EN) = 1.0D0
ENM2 = NA - 1
IF (ENM2 .EQ. 0) GO TO 795
C .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- ..........
DO 790 II = 1, ENM2
I = NA - II
W = BETM * A(I,I) - ALMR * B(I,I)
W1 = -ALMI * B(I,I)
RA = 0.0D0
SA = 0.0D0
C
DO 760 J = M, EN
X = BETM * A(I,J) - ALMR * B(I,J)
X1 = -ALMI * B(I,J)
RA = RA + X * B(J,NA) - X1 * B(J,EN)
SA = SA + X * B(J,EN) + X1 * B(J,NA)
760 CONTINUE
C
IF (I .EQ. 1 .OR. ISW .EQ. 2) GO TO 770
IF (BETM * A(I,I-1) .EQ. 0.0D0) GO TO 770
ZZ = W
Z1 = W1
R = RA
S = SA
ISW = 2
GO TO 790
770 M = I
IF (ISW .EQ. 2) GO TO 780
C .......... COMPLEX 1-BY-1 BLOCK ..........
TR = -RA
TI = -SA
773 DR = W
DI = W1
C .......... COMPLEX DIVIDE (T1,T2) = (TR,TI) / (DR,DI) ..........
775 IF (DABS(DI) .GT. DABS(DR)) GO TO 777
RR = DI / DR
D = DR + DI * RR
T1 = (TR + TI * RR) / D
T2 = (TI - TR * RR) / D
GO TO (787,782), ISW
777 RR = DR / DI
D = DR * RR + DI
T1 = (TR * RR + TI) / D
T2 = (TI * RR - TR) / D
GO TO (787,782), ISW
C .......... COMPLEX 2-BY-2 BLOCK ..........
780 X = BETM * A(I,I+1) - ALMR * B(I,I+1)
X1 = -ALMI * B(I,I+1)
Y = BETM * A(I+1,I)
TR = Y * RA - W * R + W1 * S
TI = Y * SA - W * S - W1 * R
DR = W * ZZ - W1 * Z1 - X * Y
DI = W * Z1 + W1 * ZZ - X1 * Y
* ------------------- BEGIN TIMING CODE ----------------------
IN2BY2 = IN2BY2 + 1
* -------------------- END TIMING CODE -----------------------
IF (DR .EQ. 0.0D0 .AND. DI .EQ. 0.0D0) DR = EPSB
GO TO 775
782 B(I+1,NA) = T1
B(I+1,EN) = T2
ISW = 1
IF (DABS(Y) .GT. DABS(W) + DABS(W1)) GO TO 785
TR = -RA - X * B(I+1,NA) + X1 * B(I+1,EN)
TI = -SA - X * B(I+1,EN) - X1 * B(I+1,NA)
GO TO 773
785 T1 = (-R - ZZ * B(I+1,NA) + Z1 * B(I+1,EN)) / Y
T2 = (-S - ZZ * B(I+1,EN) - Z1 * B(I+1,NA)) / Y
787 B(I,NA) = T1
B(I,EN) = T2
790 CONTINUE
* --------------------- BEGIN TIMING CODE -----------------------
OPS = OPS + DBLE( ( 6*EN-7 )*( EN-2 ) + 31*IN2BY2 )
* ---------------------- END TIMING CODE ------------------------
C .......... END COMPLEX VECTOR ..........
795 ISW = 3 - ISW
800 CONTINUE
C .......... END BACK SUBSTITUTION.
C TRANSFORM TO ORIGINAL COORDINATE SYSTEM.
C FOR J=N STEP -1 UNTIL 1 DO -- ..........
DO 880 JJ = 1, N
J = N + 1 - JJ
C
DO 880 I = 1, N
ZZ = 0.0D0
C
DO 860 K = 1, J
860 ZZ = ZZ + Z(I,K) * B(K,J)
C
Z(I,J) = ZZ
880 CONTINUE
* ----------------------- BEGIN TIMING CODE ------------------------
OPS = OPS + DBLE( N**2 )*DBLE( N+1 )
* ------------------------ END TIMING CODE -------------------------
C .......... NORMALIZE SO THAT MODULUS OF LARGEST
C COMPONENT OF EACH VECTOR IS 1.
C (ISW IS 1 INITIALLY FROM BEFORE) ..........
* ------------------------ BEGIN TIMING CODE -----------------------
IN2BY2 = 0
* ------------------------- END TIMING CODE ------------------------
DO 950 J = 1, N
D = 0.0D0
IF (ISW .EQ. 2) GO TO 920
IF (ALFI(J) .NE. 0.0D0) GO TO 945
C
DO 890 I = 1, N
IF (DABS(Z(I,J)) .GT. D) D = DABS(Z(I,J))
890 CONTINUE
C
DO 900 I = 1, N
900 Z(I,J) = Z(I,J) / D
C
GO TO 950
C
920 DO 930 I = 1, N
R = DABS(Z(I,J-1)) + DABS(Z(I,J))
IF (R .NE. 0.0D0) R = R * DSQRT((Z(I,J-1)/R)**2
X +(Z(I,J)/R)**2)
IF (R .GT. D) D = R
930 CONTINUE
C
DO 940 I = 1, N
Z(I,J-1) = Z(I,J-1) / D
Z(I,J) = Z(I,J) / D
940 CONTINUE
* ---------------------- BEGIN TIMING CODE ----------------------
IN2BY2 = IN2BY2 + 1
* ----------------------- END TIMING CODE -----------------------
C
945 ISW = 3 - ISW
950 CONTINUE
* ------------------------ BEGIN TIMING CODE -----------------------
OPS = OPS + DBLE( N*( N + 5*IN2BY2 ) )
* ------------------------- END TIMING CODE ------------------------
C
RETURN
END
SUBROUTINE DLAQZH( ILQ, ILZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ,
$ Z, LDZ, WORK, INFO )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
LOGICAL ILQ, ILZ
INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
$ WORK( N ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* This calls the LAPACK routines to perform the function of
* QZHES. It is similar in function to DGGHRD, except that
* B is not assumed to be upper-triangular.
*
* It reduces a pair of matrices (A,B) to a Hessenberg-triangular
* pair (H,T). More specifically, it computes orthogonal matrices
* Q and Z, an (upper) Hessenberg matrix H, and an upper triangular
* matrix T such that:
*
* A = Q H Z' and B = Q T Z'
*
*
* Arguments
* =========
*
* ILQ (input) LOGICAL
* = .FALSE. do not compute Q.
* = .TRUE. compute Q.
*
* ILZ (input) LOGICAL
* = .FALSE. do not compute Z.
* = .TRUE. compute Z.
*
* N (input) INTEGER
* The number of rows and columns in the matrices A, B, Q, and
* Z. N must be at least 0.
*
* ILO (input) INTEGER
* Columns 1 through ILO-1 of A and B are assumed to be in
* upper triangular form already, and will not be modified.
* ILO must be at least 1.
*
* IHI (input) INTEGER
* Rows IHI+1 through N of A and B are assumed to be in upper
* triangular form already, and will not be touched. IHI may
* not be greater than N.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
* On entry, the first of the pair of N x N general matrices to
* be reduced.
* On exit, the upper triangle and the first subdiagonal of A
* are overwritten with the Hessenberg matrix H, and the rest
* is set to zero.
*
* LDA (input) INTEGER
* The leading dimension of A as declared in the calling
* program. LDA must be at least max ( 1, N ) .
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
* On entry, the second of the pair of N x N general matrices to
* be reduced.
* On exit, the transformed matrix T = Q' B Z, which is upper
* triangular.
*
* LDB (input) INTEGER
* The leading dimension of B as declared in the calling
* program. LDB must be at least max ( 1, N ) .
*
* Q (output) DOUBLE PRECISION array, dimension (LDQ,N)
* If ILQ = .TRUE., Q will contain the orthogonal matrix Q.
* (See "Purpose", above.)
* Will not be referenced if ILQ = .FALSE.
*
* LDQ (input) INTEGER
* The leading dimension of the matrix Q. LDQ must be at
* least 1 and at least N.
*
* Z (output) DOUBLE PRECISION array, dimension (LDZ,N)
* If ILZ = .TRUE., Z will contain the orthogonal matrix Z.
* (See "Purpose", above.)
* May be referenced even if ILZ = .FALSE.
*
* LDZ (input) INTEGER
* The leading dimension of the matrix Z. LDZ must be at
* least 1 and at least N.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (N)
* Workspace.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: errors that usually indicate LAPACK problems:
* = 2: error return from DGEQRF;
* = 3: error return from DORMQR;
* = 4: error return from DORGQR;
* = 5: error return from DGGHRD.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
CHARACTER COMPQ, COMPZ
INTEGER ICOLS, IINFO, IROWS
* ..
* .. External Subroutines ..
EXTERNAL DGEQRF, DGGHRD, DLACPY, DLASET, DORGQR, DORMQR
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Reduce B to triangular form, and initialize Q and/or Z
*
IROWS = IHI + 1 - ILO
ICOLS = N + 1 - ILO
CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK, Z, N*LDZ,
$ IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 2
GO TO 10
END IF
*
CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
$ WORK, A( ILO, ILO ), LDA, Z, N*LDZ, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 3
GO TO 10
END IF
*
IF( ILQ ) THEN
CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
$ Q( ILO+1, ILO ), LDQ )
CALL DORGQR( IROWS, IROWS, IROWS, Q( ILO, ILO ), LDQ, WORK, Z,
$ N*LDZ, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 4
GO TO 10
END IF
END IF
*
* Reduce to generalized Hessenberg form
*
IF( ILQ ) THEN
COMPQ = 'V'
ELSE
COMPQ = 'N'
END IF
*
IF( ILZ ) THEN
COMPZ = 'I'
ELSE
COMPZ = 'N'
END IF
*
CALL DGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z,
$ LDZ, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 5
GO TO 10
END IF
*
* End
*
10 CONTINUE
*
RETURN
*
* End of DLAQZH
*
END
SUBROUTINE DLATM4( ITYPE, N, NZ1, NZ2, ISIGN, AMAGN, RCOND,
$ TRIANG, IDIST, ISEED, A, LDA )
*
* -- LAPACK auxiliary test routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
INTEGER IDIST, ISIGN, ITYPE, LDA, N, NZ1, NZ2
DOUBLE PRECISION AMAGN, RCOND, TRIANG
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
DOUBLE PRECISION A( LDA, * )
* ..
*
* Purpose
* =======
*
* DLATM4 generates basic square matrices, which may later be
* multiplied by others in order to produce test matrices. It is
* intended mainly to be used to test the generalized eigenvalue
* routines.
*
* It first generates the diagonal and (possibly) subdiagonal,
* according to the value of ITYPE, NZ1, NZ2, ISIGN, AMAGN, and RCOND.
* It then fills in the upper triangle with random numbers, if TRIANG is
* non-zero.
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* The "type" of matrix on the diagonal and sub-diagonal.
* If ITYPE < 0, then type abs(ITYPE) is generated and then
* swapped end for end (A(I,J) := A'(N-J,N-I).) See also
* the description of AMAGN and ISIGN.
*
* Special types:
* = 0: the zero matrix.
* = 1: the identity.
* = 2: a transposed Jordan block.
* = 3: If N is odd, then a k+1 x k+1 transposed Jordan block
* followed by a k x k identity block, where k=(N-1)/2.
* If N is even, then k=(N-2)/2, and a zero diagonal entry
* is tacked onto the end.
*
* Diagonal types. The diagonal consists of NZ1 zeros, then
* k=N-NZ1-NZ2 nonzeros. The subdiagonal is zero. ITYPE
* specifies the nonzero diagonal entries as follows:
* = 4: 1, ..., k
* = 5: 1, RCOND, ..., RCOND
* = 6: 1, ..., 1, RCOND
* = 7: 1, a, a^2, ..., a^(k-1)=RCOND
* = 8: 1, 1-d, 1-2*d, ..., 1-(k-1)*d=RCOND
* = 9: random numbers chosen from (RCOND,1)
* = 10: random numbers with distribution IDIST (see DLARND.)
*
* N (input) INTEGER
* The order of the matrix.
*
* NZ1 (input) INTEGER
* If abs(ITYPE) > 3, then the first NZ1 diagonal entries will
* be zero.
*
* NZ2 (input) INTEGER
* If abs(ITYPE) > 3, then the last NZ2 diagonal entries will
* be zero.
*
* ISIGN (input) INTEGER
* = 0: The sign of the diagonal and subdiagonal entries will
* be left unchanged.
* = 1: The diagonal and subdiagonal entries will have their
* sign changed at random.
* = 2: If ITYPE is 2 or 3, then the same as ISIGN=1.
* Otherwise, with probability 0.5, odd-even pairs of
* diagonal entries A(2*j-1,2*j-1), A(2*j,2*j) will be
* converted to a 2x2 block by pre- and post-multiplying
* by distinct random orthogonal rotations. The remaining
* diagonal entries will have their sign changed at random.
*
* AMAGN (input) DOUBLE PRECISION
* The diagonal and subdiagonal entries will be multiplied by
* AMAGN.
*
* RCOND (input) DOUBLE PRECISION
* If abs(ITYPE) > 4, then the smallest diagonal entry will be
* entry will be RCOND. RCOND must be between 0 and 1.
*
* TRIANG (input) DOUBLE PRECISION
* The entries above the diagonal will be random numbers with
* magnitude bounded by TRIANG (i.e., random numbers multiplied
* by TRIANG.)
*
* IDIST (input) INTEGER
* Specifies the type of distribution to be used to generate a
* random matrix.
* = 1: UNIFORM( 0, 1 )
* = 2: UNIFORM( -1, 1 )
* = 3: NORMAL ( 0, 1 )
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The values of ISEED are changed on exit, and can
* be used in the next call to DLATM4 to continue the same
* random number sequence.
* Note: ISEED(4) should be odd, for the random number generator
* used at present.
*
* A (output) DOUBLE PRECISION array, dimension (LDA, N)
* Array to be computed.
*
* LDA (input) INTEGER
* Leading dimension of A. Must be at least 1 and at least N.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
DOUBLE PRECISION HALF
PARAMETER ( HALF = ONE / TWO )
* ..
* .. Local Scalars ..
INTEGER I, IOFF, ISDB, ISDE, JC, JD, JR, K, KBEG, KEND,
$ KLEN
DOUBLE PRECISION ALPHA, CL, CR, SAFMIN, SL, SR, SV1, SV2, TEMP
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLARAN, DLARND
EXTERNAL DLAMCH, DLARAN, DLARND
* ..
* .. External Subroutines ..
EXTERNAL DLASET
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, EXP, LOG, MAX, MIN, MOD, SQRT
* ..
* .. Executable Statements ..
*
IF( N.LE.0 )
$ RETURN
CALL DLASET( 'Full', N, N, ZERO, ZERO, A, LDA )
*
* Insure a correct ISEED
*
IF( MOD( ISEED( 4 ), 2 ).NE.1 )
$ ISEED( 4 ) = ISEED( 4 ) + 1
*
* Compute diagonal and subdiagonal according to ITYPE, NZ1, NZ2,
* and RCOND
*
IF( ITYPE.NE.0 ) THEN
IF( ABS( ITYPE ).GE.4 ) THEN
KBEG = MAX( 1, MIN( N, NZ1+1 ) )
KEND = MAX( KBEG, MIN( N, N-NZ2 ) )
KLEN = KEND + 1 - KBEG
ELSE
KBEG = 1
KEND = N
KLEN = N
END IF
ISDB = 1
ISDE = 0
GO TO ( 10, 30, 50, 80, 100, 120, 140, 160,
$ 180, 200 )ABS( ITYPE )
*
* |ITYPE| = 1: Identity
*
10 CONTINUE
DO 20 JD = 1, N
A( JD, JD ) = ONE
20 CONTINUE
GO TO 220
*
* |ITYPE| = 2: Transposed Jordan block
*
30 CONTINUE
DO 40 JD = 1, N - 1
A( JD+1, JD ) = ONE
40 CONTINUE
ISDB = 1
ISDE = N - 1
GO TO 220
*
* |ITYPE| = 3: Transposed Jordan block, followed by the identity.
*
50 CONTINUE
K = ( N-1 ) / 2
DO 60 JD = 1, K
A( JD+1, JD ) = ONE
60 CONTINUE
ISDB = 1
ISDE = K
DO 70 JD = K + 2, 2*K + 1
A( JD, JD ) = ONE
70 CONTINUE
GO TO 220
*
* |ITYPE| = 4: 1,...,k
*
80 CONTINUE
DO 90 JD = KBEG, KEND
A( JD, JD ) = DBLE( JD-NZ1 )
90 CONTINUE
GO TO 220
*
* |ITYPE| = 5: One large D value:
*
100 CONTINUE
DO 110 JD = KBEG + 1, KEND
A( JD, JD ) = RCOND
110 CONTINUE
A( KBEG, KBEG ) = ONE
GO TO 220
*
* |ITYPE| = 6: One small D value:
*
120 CONTINUE
DO 130 JD = KBEG, KEND - 1
A( JD, JD ) = ONE
130 CONTINUE
A( KEND, KEND ) = RCOND
GO TO 220
*
* |ITYPE| = 7: Exponentially distributed D values:
*
140 CONTINUE
A( KBEG, KBEG ) = ONE
IF( KLEN.GT.1 ) THEN
ALPHA = RCOND**( ONE / DBLE( KLEN-1 ) )
DO 150 I = 2, KLEN
A( NZ1+I, NZ1+I ) = ALPHA**( I-1 )
150 CONTINUE
END IF
GO TO 220
*
* |ITYPE| = 8: Arithmetically distributed D values:
*
160 CONTINUE
A( KBEG, KBEG ) = ONE
IF( KLEN.GT.1 ) THEN
ALPHA = ( ONE-RCOND ) / DBLE( KLEN-1 )
DO 170 I = 2, KLEN
A( NZ1+I, NZ1+I ) = DBLE( KLEN-I )*ALPHA + RCOND
170 CONTINUE
END IF
GO TO 220
*
* |ITYPE| = 9: Randomly distributed D values on ( RCOND, 1):
*
180 CONTINUE
ALPHA = LOG( RCOND )
DO 190 JD = KBEG, KEND
A( JD, JD ) = EXP( ALPHA*DLARAN( ISEED ) )
190 CONTINUE
GO TO 220
*
* |ITYPE| = 10: Randomly distributed D values from DIST
*
200 CONTINUE
DO 210 JD = KBEG, KEND
A( JD, JD ) = DLARND( IDIST, ISEED )
210 CONTINUE
*
220 CONTINUE
*
* Scale by AMAGN
*
DO 230 JD = KBEG, KEND
A( JD, JD ) = AMAGN*DBLE( A( JD, JD ) )
230 CONTINUE
DO 240 JD = ISDB, ISDE
A( JD+1, JD ) = AMAGN*DBLE( A( JD+1, JD ) )
240 CONTINUE
*
* If ISIGN = 1 or 2, assign random signs to diagonal and
* subdiagonal
*
IF( ISIGN.GT.0 ) THEN
DO 250 JD = KBEG, KEND
IF( DBLE( A( JD, JD ) ).NE.ZERO ) THEN
IF( DLARAN( ISEED ).GT.HALF )
$ A( JD, JD ) = -A( JD, JD )
END IF
250 CONTINUE
DO 260 JD = ISDB, ISDE
IF( DBLE( A( JD+1, JD ) ).NE.ZERO ) THEN
IF( DLARAN( ISEED ).GT.HALF )
$ A( JD+1, JD ) = -A( JD+1, JD )
END IF
260 CONTINUE
END IF
*
* Reverse if ITYPE < 0
*
IF( ITYPE.LT.0 ) THEN
DO 270 JD = KBEG, ( KBEG+KEND-1 ) / 2
TEMP = A( JD, JD )
A( JD, JD ) = A( KBEG+KEND-JD, KBEG+KEND-JD )
A( KBEG+KEND-JD, KBEG+KEND-JD ) = TEMP
270 CONTINUE
DO 280 JD = 1, ( N-1 ) / 2
TEMP = A( JD+1, JD )
A( JD+1, JD ) = A( N+1-JD, N-JD )
A( N+1-JD, N-JD ) = TEMP
280 CONTINUE
END IF
*
* If ISIGN = 2, and no subdiagonals already, then apply
* random rotations to make 2x2 blocks.
*
IF( ISIGN.EQ.2 .AND. ITYPE.NE.2 .AND. ITYPE.NE.3 ) THEN
SAFMIN = DLAMCH( 'S' )
DO 290 JD = KBEG, KEND - 1, 2
IF( DLARAN( ISEED ).GT.HALF ) THEN
*
* Rotation on left.
*
CL = TWO*DLARAN( ISEED ) - ONE
SL = TWO*DLARAN( ISEED ) - ONE
TEMP = ONE / MAX( SAFMIN, SQRT( CL**2+SL**2 ) )
CL = CL*TEMP
SL = SL*TEMP
*
* Rotation on right.
*
CR = TWO*DLARAN( ISEED ) - ONE
SR = TWO*DLARAN( ISEED ) - ONE
TEMP = ONE / MAX( SAFMIN, SQRT( CR**2+SR**2 ) )
CR = CR*TEMP
SR = SR*TEMP
*
* Apply
*
SV1 = A( JD, JD )
SV2 = A( JD+1, JD+1 )
A( JD, JD ) = CL*CR*SV1 + SL*SR*SV2
A( JD+1, JD ) = -SL*CR*SV1 + CL*SR*SV2
A( JD, JD+1 ) = -CL*SR*SV1 + SL*CR*SV2
A( JD+1, JD+1 ) = SL*SR*SV1 + CL*CR*SV2
END IF
290 CONTINUE
END IF
*
END IF
*
* Fill in upper triangle (except for 2x2 blocks)
*
IF( TRIANG.NE.ZERO ) THEN
IF( ISIGN.NE.2 .OR. ITYPE.EQ.2 .OR. ITYPE.EQ.3 ) THEN
IOFF = 1
ELSE
IOFF = 2
DO 300 JR = 1, N - 1
IF( A( JR+1, JR ).EQ.ZERO )
$ A( JR, JR+1 ) = TRIANG*DLARND( IDIST, ISEED )
300 CONTINUE
END IF
*
DO 320 JC = 2, N
DO 310 JR = 1, JC - IOFF
A( JR, JC ) = TRIANG*DLARND( IDIST, ISEED )
310 CONTINUE
320 CONTINUE
END IF
*
RETURN
*
* End of DLATM4
*
END
DOUBLE PRECISION FUNCTION DMFLOP( OPS, TIME, INFO )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
INTEGER INFO
DOUBLE PRECISION OPS, TIME
* ..
*
* Purpose
* =======
*
* DMFLOP computes the megaflop rate given the number of operations
* and time in seconds. This is basically just a divide operation,
* but care is taken not to divide by zero.
*
* Arguments
* =========
*
* OPS - DOUBLE PRECISION
* On entry, OPS is the number of floating point operations
* performed by the timed routine.
*
* TIME - DOUBLE PRECISION
* On entry, TIME is the total time in seconds used by the
* timed routine.
*
* INFO - INTEGER
* On entry, INFO specifies the return code from the timed
* routine. If INFO is not 0, then DMFLOP returns a negative
* value, indicating an error.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE
* ..
* .. Executable Statements ..
*
IF( TIME.LE.ZERO ) THEN
DMFLOP = ZERO
ELSE
DMFLOP = OPS / ( 1.0D6*TIME )
END IF
IF( INFO.NE.0 )
$ DMFLOP = -ABS( DBLE( INFO ) )
RETURN
*
* End of DMFLOP
*
END
DOUBLE PRECISION FUNCTION DOPBL3( SUBNAM, M, N, K )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
INTEGER K, M, N
* ..
*
* Purpose
* =======
*
* DOPBL3 computes an approximation of the number of floating point
* operations used by a subroutine SUBNAM with the given values
* of the parameters M, N, and K.
*
* This version counts operations for the Level 3 BLAS.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* M (input) INTEGER
* N (input) INTEGER
* K (input) INTEGER
* M, N, and K contain parameter values used by the Level 3
* BLAS. The output matrix is always M x N or N x N if
* symmetric, but K has different uses in different
* contexts. For example, in the matrix-matrix multiply
* routine, we have
* C = A * B
* where C is M x N, A is M x K, and B is K x N.
* In xSYMM, xTRMM, and xTRSM, K indicates whether the matrix
* A is applied on the left or right. If K <= 0, the matrix
* is applied on the left, if K > 0, on the right.
*
* =====================================================================
*
* .. Local Scalars ..
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 C3
DOUBLE PRECISION ADDS, EK, EM, EN, MULTS
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR. .NOT.( LSAME( SUBNAM, 'S' ) .OR. LSAME( SUBNAM,
$ 'D' ) .OR. LSAME( SUBNAM, 'C' ) .OR. LSAME( SUBNAM, 'Z' ) ) )
$ THEN
DOPBL3 = 0
RETURN
END IF
*
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
MULTS = 0
ADDS = 0
EM = M
EN = N
EK = K
*
* ----------------------
* Matrix-matrix products
* assume beta = 1
* ----------------------
*
IF( LSAMEN( 3, C3, 'MM ' ) ) THEN
*
IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
MULTS = EM*EK*EN
ADDS = EM*EK*EN
*
ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR.
$ LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) ) THEN
*
* IF K <= 0, assume A multiplies B on the left.
*
IF( K.LE.0 ) THEN
MULTS = EM*EM*EN
ADDS = EM*EM*EN
ELSE
MULTS = EM*EN*EN
ADDS = EM*EN*EN
END IF
*
ELSE IF( LSAMEN( 2, C2, 'TR' ) ) THEN
*
IF( K.LE.0 ) THEN
MULTS = EN*EM*( EM+1.D0 ) / 2.D0
ADDS = EN*EM*( EM-1.D0 ) / 2.D0
ELSE
MULTS = EM*EN*( EN+1.D0 ) / 2.D0
ADDS = EM*EN*( EN-1.D0 ) / 2.D0
END IF
*
END IF
*
* ------------------------------------------------
* Rank-K update of a symmetric or Hermitian matrix
* ------------------------------------------------
*
ELSE IF( LSAMEN( 3, C3, 'RK ' ) ) THEN
*
IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) ) THEN
*
MULTS = EK*EM*( EM+1.D0 ) / 2.D0
ADDS = EK*EM*( EM+1.D0 ) / 2.D0
END IF
*
* ------------------------------------------------
* Rank-2K update of a symmetric or Hermitian matrix
* ------------------------------------------------
*
ELSE IF( LSAMEN( 3, C3, 'R2K' ) ) THEN
*
IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 3, SUBNAM, 'CHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) ) THEN
*
MULTS = EK*EM*EM
ADDS = EK*EM*EM + EM
END IF
*
* -----------------------------------------
* Solving system with many right hand sides
* -----------------------------------------
*
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'TRSM ' ) ) THEN
*
IF( K.LE.0 ) THEN
MULTS = EN*EM*( EM+1.D0 ) / 2.D0
ADDS = EN*EM*( EM-1.D0 ) / 2.D0
ELSE
MULTS = EM*EN*( EN+1.D0 ) / 2.D0
ADDS = EM*EN*( EN-1.D0 ) / 2.D0
END IF
*
END IF
*
* ------------------------------------------------
* Compute the total number of operations.
* For real and double precision routines, count
* 1 for each multiply and 1 for each add.
* For complex and complex*16 routines, count
* 6 for each multiply and 2 for each add.
* ------------------------------------------------
*
IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN
*
DOPBL3 = MULTS + ADDS
*
ELSE
*
DOPBL3 = 6*MULTS + 2*ADDS
*
END IF
*
RETURN
*
* End of DOPBL3
*
END
DOUBLE PRECISION FUNCTION DOPLA( SUBNAM, M, N, KL, KU, NB )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
INTEGER KL, KU, M, N, NB
* ..
*
* Purpose
* =======
*
* DOPLA computes an approximation of the number of floating point
* operations used by the subroutine SUBNAM with the given values
* of the parameters M, N, KL, KU, and NB.
*
* This version counts operations for the LAPACK subroutines.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* M (input) INTEGER
* The number of rows of the coefficient matrix. M >= 0.
*
* N (input) INTEGER
* The number of columns of the coefficient matrix.
* For solve routine when the matrix is square,
* N is the number of right hand sides. N >= 0.
*
* KL (input) INTEGER
* The lower band width of the coefficient matrix.
* If needed, 0 <= KL <= M-1.
* For xGEQRS, KL is the number of right hand sides.
*
* KU (input) INTEGER
* The upper band width of the coefficient matrix.
* If needed, 0 <= KU <= N-1.
*
* NB (input) INTEGER
* The block size. If needed, NB >= 1.
*
* Notes
* =====
*
* In the comments below, the association is given between arguments
* in the requested subroutine and local arguments. For example,
*
* xGETRS: N, NRHS => M, N
*
* means that arguments N and NRHS in DGETRS are passed to arguments
* M and N in this procedure.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL CORZ, SORD
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 C3
INTEGER I
DOUBLE PRECISION ADDFAC, ADDS, EK, EM, EMN, EN, MULFAC, MULTS,
$ WL, WU
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* --------------------------------------------------------
* Initialize DOPLA to 0 and do a quick return if possible.
* --------------------------------------------------------
*
DOPLA = 0
MULTS = 0
ADDS = 0
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
SORD = LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' )
CORZ = LSAME( C1, 'C' ) .OR. LSAME( C1, 'Z' )
IF( M.LE.0 .OR. .NOT.( SORD .OR. CORZ ) )
$ RETURN
*
* ---------------------------------------------------------
* If the coefficient matrix is real, count each add as 1
* operation and each multiply as 1 operation.
* If the coefficient matrix is complex, count each add as 2
* operations and each multiply as 6 operations.
* ---------------------------------------------------------
*
IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' ) ) THEN
ADDFAC = 1
MULFAC = 1
ELSE
ADDFAC = 2
MULFAC = 6
END IF
EM = M
EN = N
EK = KL
*
* ---------------------------------
* GE: GEneral rectangular matrices
* ---------------------------------
*
IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
* xGETRF: M, N => M, N
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
EMN = MIN( M, N )
ADDS = EMN*( EM*EN-( EM+EN )*( EMN+1.D0 ) / 2.D0+
$ ( EMN+1.D0 )*( 2.D0*EMN+1.D0 ) / 6.D0 )
MULTS = ADDS + EMN*( EM-( EMN+1.D0 ) / 2.D0 )
*
* xGETRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*EM*EM
ADDS = EN*( EM*( EM-1.D0 ) )
*
* xGETRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 5.D0 / 6.D0+EM*( 1.D0 / 2.D0+EM*( 2.D0 /
$ 3.D0 ) ) )
ADDS = EM*( 5.D0 / 6.D0+EM*( -3.D0 / 2.D0+EM*( 2.D0 /
$ 3.D0 ) ) )
*
* xGEQRF or xGEQLF: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'QRF' ) .OR.
$ LSAMEN( 3, C3, 'QR2' ) .OR.
$ LSAMEN( 3, C3, 'QLF' ) .OR. LSAMEN( 3, C3, 'QL2' ) )
$ THEN
IF( M.GE.N ) THEN
MULTS = EN*( ( ( 23.D0 / 6.D0 )+EM+EN / 2.D0 )+EN*
$ ( EM-EN / 3.D0 ) )
ADDS = EN*( ( 5.D0 / 6.D0 )+EN*
$ ( 1.D0 / 2.D0+( EM-EN / 3.D0 ) ) )
ELSE
MULTS = EM*( ( ( 23.D0 / 6.D0 )+2.D0*EN-EM / 2.D0 )+EM*
$ ( EN-EM / 3.D0 ) )
ADDS = EM*( ( 5.D0 / 6.D0 )+EN-EM / 2.D0+EM*
$ ( EN-EM / 3.D0 ) )
END IF
*
* xGERQF or xGELQF: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'RQF' ) .OR.
$ LSAMEN( 3, C3, 'RQ2' ) .OR.
$ LSAMEN( 3, C3, 'LQF' ) .OR. LSAMEN( 3, C3, 'LQ2' ) )
$ THEN
IF( M.GE.N ) THEN
MULTS = EN*( ( ( 29.D0 / 6.D0 )+EM+EN / 2.D0 )+EN*
$ ( EM-EN / 3.D0 ) )
ADDS = EN*( ( 5.D0 / 6.D0 )+EM+EN*
$ ( -1.D0 / 2.D0+( EM-EN / 3.D0 ) ) )
ELSE
MULTS = EM*( ( ( 29.D0 / 6.D0 )+2.D0*EN-EM / 2.D0 )+EM*
$ ( EN-EM / 3.D0 ) )
ADDS = EM*( ( 5.D0 / 6.D0 )+EM / 2.D0+EM*
$ ( EN-EM / 3.D0 ) )
END IF
*
* xGEQPF: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'QPF' ) ) THEN
EMN = MIN( M, N )
MULTS = 2*EN*EN + EMN*( 3*EM+5*EN+2*EM*EN-( EMN+1 )*
$ ( 4+EN+EM-( 2*EMN+1 ) / 3 ) )
ADDS = EN*EN + EMN*( 2*EM+EN+2*EM*EN-( EMN+1 )*
$ ( 2+EN+EM-( 2*EMN+1 ) / 3 ) )
*
* xGEQRS or xGERQS: M, N, NRHS => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'QRS' ) .OR. LSAMEN( 3, C3, 'RQS' ) )
$ THEN
MULTS = EK*( EN*( 2.D0-EK )+EM*
$ ( 2.D0*EN+( EM+1.D0 ) / 2.D0 ) )
ADDS = EK*( EN*( 1.D0-EK )+EM*
$ ( 2.D0*EN+( EM-1.D0 ) / 2.D0 ) )
*
* xGELQS or xGEQLS: M, N, NRHS => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'LQS' ) .OR. LSAMEN( 3, C3, 'QLS' ) )
$ THEN
MULTS = EK*( EM*( 2.D0-EK )+EN*
$ ( 2.D0*EM+( EN+1.D0 ) / 2.D0 ) )
ADDS = EK*( EM*( 1.D0-EK )+EN*
$ ( 2.D0*EM+( EN-1.D0 ) / 2.D0 ) )
*
* xGEBRD: M, N => M, N
*
ELSE IF( LSAMEN( 3, C3, 'BRD' ) ) THEN
IF( M.GE.N ) THEN
MULTS = EN*( 20.D0 / 3.D0+EN*
$ ( 2.D0+( 2.D0*EM-( 2.D0 / 3.D0 )*EN ) ) )
ADDS = EN*( 5.D0 / 3.D0+( EN-EM )+EN*
$ ( 2.D0*EM-( 2.D0 / 3.D0 )*EN ) )
ELSE
MULTS = EM*( 20.D0 / 3.D0+EM*
$ ( 2.D0+( 2.D0*EN-( 2.D0 / 3.D0 )*EM ) ) )
ADDS = EM*( 5.D0 / 3.D0+( EM-EN )+EM*
$ ( 2.D0*EN-( 2.D0 / 3.D0 )*EM ) )
END IF
*
* xGEHRD: N => M
*
ELSE IF( LSAMEN( 3, C3, 'HRD' ) ) THEN
IF( M.EQ.1 ) THEN
MULTS = 0.D0
ADDS = 0.D0
ELSE
MULTS = -13.D0 + EM*( -7.D0 / 6.D0+EM*
$ ( 0.5D0+EM*( 5.D0 / 3.D0 ) ) )
ADDS = -8.D0 + EM*( -2.D0 / 3.D0+EM*
$ ( -1.D0+EM*( 5.D0 / 3.D0 ) ) )
END IF
*
END IF
*
* ----------------------------
* GB: General Banded matrices
* ----------------------------
* Note: The operation count is overestimated because
* it is assumed that the factor U fills in to the maximum
* extent, i.e., that its bandwidth goes from KU to KL + KU.
*
ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
*
* xGBTRF: M, N, KL, KU => M, N, KL, KU
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
DO 10 I = MIN( M, N ), 1, -1
WL = MAX( 0, MIN( KL, M-I ) )
WU = MAX( 0, MIN( KL+KU, N-I ) )
MULTS = MULTS + WL*( 1.D0+WU )
ADDS = ADDS + WL*WU
10 CONTINUE
*
* xGBTRS: N, NRHS, KL, KU => M, N, KL, KU
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
WL = MAX( 0, MIN( KL, M-1 ) )
WU = MAX( 0, MIN( KL+KU, M-1 ) )
MULTS = EN*( EM*( WL+1.D0+WU )-0.5D0*
$ ( WL*( WL+1.D0 )+WU*( WU+1.D0 ) ) )
ADDS = EN*( EM*( WL+WU )-0.5D0*
$ ( WL*( WL+1.D0 )+WU*( WU+1.D0 ) ) )
*
END IF
*
* --------------------------------------
* PO: POsitive definite matrices
* PP: Positive definite Packed matrices
* --------------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'PP' ) ) THEN
*
* xPOTRF: N => M
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = EM*( 1.D0 / 3.D0+EM*( 1.D0 / 2.D0+EM*( 1.D0 /
$ 6.D0 ) ) )
ADDS = ( 1.D0 / 6.D0 )*EM*( -1.D0+EM*EM )
*
* xPOTRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*( EM*( EM+1.D0 ) )
ADDS = EN*( EM*( EM-1.D0 ) )
*
* xPOTRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 2.D0 / 3.D0+EM*( 1.D0+EM*( 1.D0 / 3.D0 ) ) )
ADDS = EM*( 1.D0 / 6.D0+EM*( -1.D0 / 2.D0+EM*( 1.D0 /
$ 3.D0 ) ) )
*
END IF
*
* ------------------------------------
* PB: Positive definite Band matrices
* ------------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN
*
* xPBTRF: N, K => M, KL
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = EK*( -2.D0 / 3.D0+EK*( -1.D0+EK*( -1.D0 / 3.D0 ) ) )
$ + EM*( 1.D0+EK*( 3.D0 / 2.D0+EK*( 1.D0 / 2.D0 ) ) )
ADDS = EK*( -1.D0 / 6.D0+EK*( -1.D0 / 2.D0+EK*( -1.D0 /
$ 3.D0 ) ) ) + EM*( EK / 2.D0*( 1.D0+EK ) )
*
* xPBTRS: N, NRHS, K => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*( ( 2*EM-EK )*( EK+1.D0 ) )
ADDS = EN*( EK*( 2*EM-( EK+1.D0 ) ) )
*
END IF
*
* --------------------------------------------------------
* SY: SYmmetric indefinite matrices
* SP: Symmetric indefinite Packed matrices
* HE: HErmitian indefinite matrices (complex only)
* HP: Hermitian indefinite Packed matrices (complex only)
* --------------------------------------------------------
*
ELSE IF( LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHE' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHP' ) .OR.
$ LSAMEN( 3, SUBNAM, 'ZHP' ) ) THEN
*
* xSYTRF: N => M
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
MULTS = EM*( 10.D0 / 3.D0+EM*
$ ( 1.D0 / 2.D0+EM*( 1.D0 / 6.D0 ) ) )
ADDS = EM / 6.D0*( -1.D0+EM*EM )
*
* xSYTRS: N, NRHS => M, N
*
ELSE IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*EM*EM
ADDS = EN*( EM*( EM-1.D0 ) )
*
* xSYTRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 2.D0 / 3.D0+EM*EM*( 1.D0 / 3.D0 ) )
ADDS = EM*( -1.D0 / 3.D0+EM*EM*( 1.D0 / 3.D0 ) )
*
* xSYTRD, xSYTD2: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRD' ) .OR. LSAMEN( 3, C3, 'TD2' ) )
$ THEN
IF( M.EQ.1 ) THEN
MULTS = 0.D0
ADDS = 0.D0
ELSE
MULTS = -15.D0 + EM*( -1.D0 / 6.D0+EM*
$ ( 5.D0 / 2.D0+EM*( 2.D0 / 3.D0 ) ) )
ADDS = -4.D0 + EM*( -8.D0 / 3.D0+EM*
$ ( 1.D0+EM*( 2.D0 / 3.D0 ) ) )
END IF
END IF
*
* -------------------
* Triangular matrices
* -------------------
*
ELSE IF( LSAMEN( 2, C2, 'TR' ) .OR. LSAMEN( 2, C2, 'TP' ) ) THEN
*
* xTRTRS: N, NRHS => M, N
*
IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*EM*( EM+1.D0 ) / 2.D0
ADDS = EN*EM*( EM-1.D0 ) / 2.D0
*
* xTRTRI: N => M
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
MULTS = EM*( 1.D0 / 3.D0+EM*( 1.D0 / 2.D0+EM*( 1.D0 /
$ 6.D0 ) ) )
ADDS = EM*( 1.D0 / 3.D0+EM*( -1.D0 / 2.D0+EM*( 1.D0 /
$ 6.D0 ) ) )
*
END IF
*
ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
*
* xTBTRS: N, NRHS, K => M, N, KL
*
IF( LSAMEN( 3, C3, 'TRS' ) ) THEN
MULTS = EN*( EM*( EM+1.D0 ) / 2.D0-( EM-EK-1.D0 )*
$ ( EM-EK ) / 2.D0 )
ADDS = EN*( EM*( EM-1.D0 ) / 2.D0-( EM-EK-1.D0 )*( EM-EK ) /
$ 2.D0 )
END IF
*
* --------------------
* Trapezoidal matrices
* --------------------
*
ELSE IF( LSAMEN( 2, C2, 'TZ' ) ) THEN
*
* xTZRQF: M, N => M, N
*
IF( LSAMEN( 3, C3, 'RQF' ) ) THEN
EMN = MIN( M, N )
MULTS = 3*EM*( EN-EM+1 ) + ( 2*EN-2*EM+3 )*
$ ( EM*EM-EMN*( EMN+1 ) / 2 )
ADDS = ( EN-EM+1 )*( EM+2*EM*EM-EMN*( EMN+1 ) )
END IF
*
* -------------------
* Orthogonal matrices
* -------------------
*
ELSE IF( ( SORD .AND. LSAMEN( 2, C2, 'OR' ) ) .OR.
$ ( CORZ .AND. LSAMEN( 2, C2, 'UN' ) ) ) THEN
*
* -MQR, -MLQ, -MQL, or -MRQ: M, N, K, SIDE => M, N, KL, KU
* where KU<= 0 indicates SIDE = 'L'
* and KU> 0 indicates SIDE = 'R'
*
IF( LSAMEN( 3, C3, 'MQR' ) .OR. LSAMEN( 3, C3, 'MLQ' ) .OR.
$ LSAMEN( 3, C3, 'MQL' ) .OR. LSAMEN( 3, C3, 'MRQ' ) ) THEN
IF( KU.LE.0 ) THEN
MULTS = EK*EN*( 2.D0*EM+2.D0-EK )
ADDS = EK*EN*( 2.D0*EM+1.D0-EK )
ELSE
MULTS = EK*( EM*( 2.D0*EN-EK )+
$ ( EM+EN+( 1.D0-EK ) / 2.D0 ) )
ADDS = EK*EM*( 2.D0*EN+1.D0-EK )
END IF
*
* -GQR or -GQL: M, N, K => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'GQR' ) .OR. LSAMEN( 3, C3, 'GQL' ) )
$ THEN
MULTS = EK*( -5.D0 / 3.D0+( 2.D0*EN-EK )+
$ ( 2.D0*EM*EN+EK*( ( 2.D0 / 3.D0 )*EK-EM-EN ) ) )
ADDS = EK*( 1.D0 / 3.D0+( EN-EM )+
$ ( 2.D0*EM*EN+EK*( ( 2.D0 / 3.D0 )*EK-EM-EN ) ) )
*
* -GLQ or -GRQ: M, N, K => M, N, KL
*
ELSE IF( LSAMEN( 3, C3, 'GLQ' ) .OR. LSAMEN( 3, C3, 'GRQ' ) )
$ THEN
MULTS = EK*( -2.D0 / 3.D0+( EM+EN-EK )+
$ ( 2.D0*EM*EN+EK*( ( 2.D0 / 3.D0 )*EK-EM-EN ) ) )
ADDS = EK*( 1.D0 / 3.D0+( EM-EN )+
$ ( 2.D0*EM*EN+EK*( ( 2.D0 / 3.D0 )*EK-EM-EN ) ) )
*
END IF
*
END IF
*
DOPLA = MULFAC*MULTS + ADDFAC*ADDS
*
RETURN
*
* End of DOPLA
*
END
DOUBLE PRECISION FUNCTION DOPLA2( SUBNAM, OPTS, M, N, K, L, NB )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
CHARACTER*6 SUBNAM
CHARACTER*( * ) OPTS
INTEGER K, L, M, N, NB
* ..
*
* Purpose
* =======
*
* DOPLA2 computes an approximation of the number of floating point
* operations used by the subroutine SUBNAM with character options
* OPTS and parameters M, N, K, L, and NB.
*
* This version counts operations for the LAPACK subroutines that
* call other LAPACK routines.
*
* Arguments
* =========
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine.
*
* OPTS (input) CHRACTER*(*)
* A string of character options to subroutine SUBNAM.
*
* M (input) INTEGER
* The number of rows of the coefficient matrix.
*
* N (input) INTEGER
* The number of columns of the coefficient matrix.
*
* K (input) INTEGER
* A third problem dimension, if needed.
*
* L (input) INTEGER
* A fourth problem dimension, if needed.
*
* NB (input) INTEGER
* The block size. If needed, NB >= 1.
*
* Notes
* =====
*
* In the comments below, the association is given between arguments
* in the requested subroutine and local arguments. For example,
*
* xORMBR: VECT // SIDE // TRANS, M, N, K => OPTS, M, N, K
*
* means that the character string VECT // SIDE // TRANS is passed to
* the argument OPTS, and the integer parameters M, N, and K are passed
* to the arguments M, N, and K,
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL CORZ, SORD
CHARACTER C1, SIDE, UPLO, VECT
CHARACTER*2 C2
CHARACTER*3 C3
CHARACTER*6 SUB2
INTEGER IHI, ILO, ISIDE, MI, NI, NQ
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
DOUBLE PRECISION DOPLA
EXTERNAL LSAME, LSAMEN, DOPLA
* ..
* .. Executable Statements ..
*
* ---------------------------------------------------------
* Initialize DOPLA2 to 0 and do a quick return if possible.
* ---------------------------------------------------------
*
DOPLA2 = 0
C1 = SUBNAM( 1: 1 )
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
SORD = LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' )
CORZ = LSAME( C1, 'C' ) .OR. LSAME( C1, 'Z' )
IF( M.LE.0 .OR. .NOT.( SORD .OR. CORZ ) )
$ RETURN
*
* -------------------
* Orthogonal matrices
* -------------------
*
IF( ( SORD .AND. LSAMEN( 2, C2, 'OR' ) ) .OR.
$ ( CORZ .AND. LSAMEN( 2, C2, 'UN' ) ) ) THEN
*
IF( LSAMEN( 3, C3, 'GBR' ) ) THEN
*
* -GBR: VECT, M, N, K => OPTS, M, N, K
*
VECT = OPTS( 1: 1 )
IF( LSAME( VECT, 'Q' ) ) THEN
SUB2 = SUBNAM( 1: 3 ) // 'GQR'
IF( M.GE.K ) THEN
DOPLA2 = DOPLA( SUB2, M, N, K, 0, NB )
ELSE
DOPLA2 = DOPLA( SUB2, M-1, M-1, M-1, 0, NB )
END IF
ELSE
SUB2 = SUBNAM( 1: 3 ) // 'GLQ'
IF( K.LT.N ) THEN
DOPLA2 = DOPLA( SUB2, M, N, K, 0, NB )
ELSE
DOPLA2 = DOPLA( SUB2, N-1, N-1, N-1, 0, NB )
END IF
END IF
*
ELSE IF( LSAMEN( 3, C3, 'MBR' ) ) THEN
*
* -MBR: VECT // SIDE // TRANS, M, N, K => OPTS, M, N, K
*
VECT = OPTS( 1: 1 )
SIDE = OPTS( 2: 2 )
IF( LSAME( SIDE, 'L' ) ) THEN
NQ = M
ISIDE = 0
ELSE
NQ = N
ISIDE = 1
END IF
IF( LSAME( VECT, 'Q' ) ) THEN
SUB2 = SUBNAM( 1: 3 ) // 'MQR'
IF( NQ.GE.K ) THEN
DOPLA2 = DOPLA( SUB2, M, N, K, ISIDE, NB )
ELSE IF( ISIDE.EQ.0 ) THEN
DOPLA2 = DOPLA( SUB2, M-1, N, NQ-1, ISIDE, NB )
ELSE
DOPLA2 = DOPLA( SUB2, M, N-1, NQ-1, ISIDE, NB )
END IF
ELSE
SUB2 = SUBNAM( 1: 3 ) // 'MLQ'
IF( NQ.GT.K ) THEN
DOPLA2 = DOPLA( SUB2, M, N, K, ISIDE, NB )
ELSE IF( ISIDE.EQ.0 ) THEN
DOPLA2 = DOPLA( SUB2, M-1, N, NQ-1, ISIDE, NB )
ELSE
DOPLA2 = DOPLA( SUB2, M, N-1, NQ-1, ISIDE, NB )
END IF
END IF
*
ELSE IF( LSAMEN( 3, C3, 'GHR' ) ) THEN
*
* -GHR: N, ILO, IHI => M, N, K
*
ILO = N
IHI = K
SUB2 = SUBNAM( 1: 3 ) // 'GQR'
DOPLA2 = DOPLA( SUB2, IHI-ILO, IHI-ILO, IHI-ILO, 0, NB )
*
ELSE IF( LSAMEN( 3, C3, 'MHR' ) ) THEN
*
* -MHR: SIDE // TRANS, M, N, ILO, IHI => OPTS, M, N, K, L
*
SIDE = OPTS( 1: 1 )
ILO = K
IHI = L
IF( LSAME( SIDE, 'L' ) ) THEN
MI = IHI - ILO
NI = N
ISIDE = -1
ELSE
MI = M
NI = IHI - ILO
ISIDE = 1
END IF
SUB2 = SUBNAM( 1: 3 ) // 'MQR'
DOPLA2 = DOPLA( SUB2, MI, NI, IHI-ILO, ISIDE, NB )
*
ELSE IF( LSAMEN( 3, C3, 'GTR' ) ) THEN
*
* -GTR: UPLO, N => OPTS, M
*
UPLO = OPTS( 1: 1 )
IF( LSAME( UPLO, 'U' ) ) THEN
SUB2 = SUBNAM( 1: 3 ) // 'GQL'
DOPLA2 = DOPLA( SUB2, M-1, M-1, M-1, 0, NB )
ELSE
SUB2 = SUBNAM( 1: 3 ) // 'GQR'
DOPLA2 = DOPLA( SUB2, M-1, M-1, M-1, 0, NB )
END IF
*
ELSE IF( LSAMEN( 3, C3, 'MTR' ) ) THEN
*
* -MTR: SIDE // UPLO // TRANS, M, N => OPTS, M, N
*
SIDE = OPTS( 1: 1 )
UPLO = OPTS( 2: 2 )
IF( LSAME( SIDE, 'L' ) ) THEN
MI = M - 1
NI = N
NQ = M
ISIDE = -1
ELSE
MI = M
NI = N - 1
NQ = N
ISIDE = 1
END IF
*
IF( LSAME( UPLO, 'U' ) ) THEN
SUB2 = SUBNAM( 1: 3 ) // 'MQL'
DOPLA2 = DOPLA( SUB2, MI, NI, NQ-1, ISIDE, NB )
ELSE
SUB2 = SUBNAM( 1: 3 ) // 'MQR'
DOPLA2 = DOPLA( SUB2, MI, NI, NQ-1, ISIDE, NB )
END IF
*
END IF
END IF
*
RETURN
*
* End of DOPLA2
*
END
SUBROUTINE DPRTBE( SUBNAM, NTYPES, DOTYPE, NSIZES, NN, INPARM,
$ PNAMES, NPARMS, NP1, NP2, NP3, NP4, OPS, LDO1,
$ LDO2, TIMES, LDT1, LDT2, RWORK, LLWORK, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
CHARACTER*( * ) SUBNAM
INTEGER INPARM, LDO1, LDO2, LDT1, LDT2, NOUT, NPARMS,
$ NSIZES, NTYPES
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( NTYPES ), LLWORK( NPARMS )
CHARACTER*( * ) PNAMES( * )
INTEGER NN( NSIZES ), NP1( * ), NP2( * ), NP3( * ),
$ NP4( * )
DOUBLE PRECISION OPS( LDO1, LDO2, * ), RWORK( * ),
$ TIMES( LDT1, LDT2, * )
* ..
*
* Purpose
* =======
*
* DPRTBE prints out timing information for the eigenvalue routines.
* The table has NTYPES block rows and NSIZES columns, with NPARMS
* individual rows in each block row. There are INPARM quantities
* which depend on rows (currently, INPARM <= 4).
*
* Arguments (none are modified)
* =========
*
* SUBNAM - CHARACTER*(*)
* The label for the output.
*
* NTYPES - INTEGER
* The number of values of DOTYPE, and also the
* number of sets of rows of the table.
*
* DOTYPE - LOGICAL array of dimension( NTYPES )
* If DOTYPE(j) is .TRUE., then block row j (which includes
* data from RESLTS( i, j, k ), for all i and k) will be
* printed. If DOTYPE(j) is .FALSE., then block row j will
* not be printed.
*
* NSIZES - INTEGER
* The number of values of NN, and also the
* number of columns of the table.
*
* NN - INTEGER array of dimension( NSIZES )
* The values of N used to label each column.
*
* INPARM - INTEGER
* The number of different parameters which are functions of
* the row number. At the moment, INPARM <= 4.
*
* PNAMES - CHARACTER*(*) array of dimension( INPARM )
* The label for the columns.
*
* NPARMS - INTEGER
* The number of values for each "parameter", i.e., the
* number of rows for each value of DOTYPE.
*
* NP1 - INTEGER array of dimension( NPARMS )
* The first quantity which depends on row number.
*
* NP2 - INTEGER array of dimension( NPARMS )
* The second quantity which depends on row number.
*
* NP3 - INTEGER array of dimension( NPARMS )
* The third quantity which depends on row number.
*
* NP4 - INTEGER array of dimension( NPARMS )
* The fourth quantity which depends on row number.
*
* OPS - DOUBLE PRECISION array of dimension( LDT1, LDT2, NSIZES )
* The operation counts. The first index indicates the row,
* the second index indicates the block row, and the last
* indicates the column.
*
* LDO1 - INTEGER
* The first dimension of OPS. It must be at least
* min( 1, NPARMS ).
*
* LDO2 - INTEGER
* The second dimension of OPS. It must be at least
* min( 1, NTYPES ).
*
* TIMES - DOUBLE PRECISION array of dimension( LDT1, LDT2, NSIZES )
* The times (in seconds). The first index indicates the row,
* the second index indicates the block row, and the last
* indicates the column.
*
* LDT1 - INTEGER
* The first dimension of RESLTS. It must be at least
* min( 1, NPARMS ).
*
* LDT2 - INTEGER
* The second dimension of RESLTS. It must be at least
* min( 1, NTYPES ).
*
* RWORK - DOUBLE PRECISION array of dimension( NSIZES*NTYPES*NPARMS )
* Real workspace.
* Modified.
*
* LLWORK - LOGICAL array of dimension( NPARMS )
* Logical workspace. It is used to turn on or off specific
* lines in the output. If LLWORK(i) is .TRUE., then row i
* (which includes data from OPS(i,j,k) or TIMES(i,j,k) for
* all j and k) will be printed. If LLWORK(i) is
* .FALSE., then row i will not be printed.
* Modified.
*
* NOUT - INTEGER
* The output unit number on which the table
* is to be printed. If NOUT <= 0, no output is printed.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LTEMP
INTEGER I, IINFO, ILINE, ILINES, IPAR, J, JP, JS, JT
* ..
* .. External Functions ..
DOUBLE PRECISION DMFLOP
EXTERNAL DMFLOP
* ..
* .. External Subroutines ..
EXTERNAL DPRTBS
* ..
* .. Executable Statements ..
*
*
* First line
*
WRITE( NOUT, FMT = 9999 )SUBNAM
*
* Set up which lines are to be printed.
*
LLWORK( 1 ) = .TRUE.
ILINES = 1
DO 20 IPAR = 2, NPARMS
LLWORK( IPAR ) = .TRUE.
DO 10 J = 1, IPAR - 1
LTEMP = .FALSE.
IF( INPARM.GE.1 .AND. NP1( J ).NE.NP1( IPAR ) )
$ LTEMP = .TRUE.
IF( INPARM.GE.2 .AND. NP2( J ).NE.NP2( IPAR ) )
$ LTEMP = .TRUE.
IF( INPARM.GE.3 .AND. NP3( J ).NE.NP3( IPAR ) )
$ LTEMP = .TRUE.
IF( INPARM.GE.4 .AND. NP4( J ).NE.NP4( IPAR ) )
$ LTEMP = .TRUE.
IF( .NOT.LTEMP )
$ LLWORK( IPAR ) = .FALSE.
10 CONTINUE
IF( LLWORK( IPAR ) )
$ ILINES = ILINES + 1
20 CONTINUE
IF( ILINES.EQ.1 ) THEN
IF( INPARM.EQ.1 ) THEN
WRITE( NOUT, FMT = 9995 )PNAMES( 1 ), NP1( 1 )
ELSE IF( INPARM.EQ.2 ) THEN
WRITE( NOUT, FMT = 9995 )PNAMES( 1 ), NP1( 1 ),
$ PNAMES( 2 ), NP2( 1 )
ELSE IF( INPARM.EQ.3 ) THEN
WRITE( NOUT, FMT = 9995 )PNAMES( 1 ), NP1( 1 ),
$ PNAMES( 2 ), NP2( 1 ), PNAMES( 3 ), NP3( 1 )
ELSE IF( INPARM.EQ.4 ) THEN
WRITE( NOUT, FMT = 9995 )PNAMES( 1 ), NP1( 1 ),
$ PNAMES( 2 ), NP2( 1 ), PNAMES( 3 ), NP3( 1 ),
$ PNAMES( 4 ), NP4( 1 )
END IF
ELSE
ILINE = 0
DO 30 J = 1, NPARMS
IF( LLWORK( J ) ) THEN
ILINE = ILINE + 1
IF( INPARM.EQ.1 ) THEN
WRITE( NOUT, FMT = 9994 )ILINE, PNAMES( 1 ), NP1( J )
ELSE IF( INPARM.EQ.2 ) THEN
WRITE( NOUT, FMT = 9994 )ILINE, PNAMES( 1 ),
$ NP1( J ), PNAMES( 2 ), NP2( J )
ELSE IF( INPARM.EQ.3 ) THEN
WRITE( NOUT, FMT = 9994 )ILINE, PNAMES( 1 ),
$ NP1( J ), PNAMES( 2 ), NP2( J ), PNAMES( 3 ),
$ NP3( J )
ELSE IF( INPARM.EQ.4 ) THEN
WRITE( NOUT, FMT = 9994 )ILINE, PNAMES( 1 ),
$ NP1( J ), PNAMES( 2 ), NP2( J ), PNAMES( 3 ),
$ NP3( J ), PNAMES( 4 ), NP4( J )
END IF
END IF
30 CONTINUE
END IF
*
* Execution Times
*
WRITE( NOUT, FMT = 9996 )
CALL DPRTBS( 'Type', 'N ', NTYPES, DOTYPE, NSIZES, NN, NPARMS,
$ LLWORK, TIMES, LDT1, LDT2, NOUT )
*
* Operation Counts
*
WRITE( NOUT, FMT = 9997 )
CALL DPRTBS( 'Type', 'N ', NTYPES, DOTYPE, NSIZES, NN, NPARMS,
$ LLWORK, OPS, LDO1, LDO2, NOUT )
*
* Megaflop Rates
*
IINFO = 0
DO 60 JS = 1, NSIZES
DO 50 JT = 1, NTYPES
IF( DOTYPE( JT ) ) THEN
DO 40 JP = 1, NPARMS
I = JP + NPARMS*( JT-1+NTYPES*( JS-1 ) )
RWORK( I ) = DMFLOP( OPS( JP, JT, JS ),
$ TIMES( JP, JT, JS ), IINFO )
40 CONTINUE
END IF
50 CONTINUE
60 CONTINUE
*
WRITE( NOUT, FMT = 9998 )
CALL DPRTBS( 'Type', 'N ', NTYPES, DOTYPE, NSIZES, NN, NPARMS,
$ LLWORK, RWORK, NPARMS, NTYPES, NOUT )
*
9999 FORMAT( / / / ' ****** Results for ', A, ' ******' )
9998 FORMAT( / ' *** Speed in megaflops ***' )
9997 FORMAT( / ' *** Number of floating-point operations ***' )
9996 FORMAT( / ' *** Time in seconds ***' )
9995 FORMAT( 5X, : 'with ', A, '=', I5, 3( : ', ', A, '=', I5 ) )
9994 FORMAT( 5X, : 'line ', I2, ' with ', A, '=', I5,
$ 3( : ', ', A, '=', I5 ) )
RETURN
*
* End of DPRTBE
*
END
SUBROUTINE DPRTBG( SUBNAM, NTYPES, DOTYPE, NSIZES, NN, INPARM,
$ PNAMES, NPARMS, NP1, NP2, NP3, NP4, NP5, NP6,
$ OPS, LDO1, LDO2, TIMES, LDT1, LDT2, RWORK,
$ LLWORK, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
CHARACTER*( * ) SUBNAM
INTEGER INPARM, LDO1, LDO2, LDT1, LDT2, NOUT, NPARMS,
$ NSIZES, NTYPES
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( NTYPES ), LLWORK( NPARMS )
CHARACTER*( * ) PNAMES( * )
INTEGER NN( NSIZES ), NP1( * ), NP2( * ), NP3( * ),
$ NP4( * ), NP5( * ), NP6( * )
DOUBLE PRECISION OPS( LDO1, LDO2, * ), RWORK( * ),
$ TIMES( LDT1, LDT2, * )
* ..
*
* Purpose
* =======
*
* DPRTBG prints out timing information for the eigenvalue routines.
* The table has NTYPES block rows and NSIZES columns, with NPARMS
* individual rows in each block row. There are INPARM quantities
* which depend on rows (currently, INPARM <= 4).
*
* Arguments (none are modified)
* =========
*
* SUBNAM - CHARACTER*(*)
* The label for the output.
*
* NTYPES - INTEGER
* The number of values of DOTYPE, and also the
* number of sets of rows of the table.
*
* DOTYPE - LOGICAL array of dimension( NTYPES )
* If DOTYPE(j) is .TRUE., then block row j (which includes
* data from RESLTS( i, j, k ), for all i and k) will be
* printed. If DOTYPE(j) is .FALSE., then block row j will
* not be printed.
*
* NSIZES - INTEGER
* The number of values of NN, and also the
* number of columns of the table.
*
* NN - INTEGER array of dimension( NSIZES )
* The values of N used to label each column.
*
* INPARM - INTEGER
* The number of different parameters which are functions of
* the row number. At the moment, INPARM <= 4.
*
* PNAMES - CHARACTER*(*) array of dimension( INPARM )
* The label for the columns.
*
* NPARMS - INTEGER
* The number of values for each "parameter", i.e., the
* number of rows for each value of DOTYPE.
*
* NP1 - INTEGER array of dimension( NPARMS )
* The first quantity which depends on row number.
*
* NP2 - INTEGER array of dimension( NPARMS )
* The second quantity which depends on row number.
*
* NP3 - INTEGER array of dimension( NPARMS )
* The third quantity which depends on row number.
*
* NP4 - INTEGER array of dimension( NPARMS )
* The fourth quantity which depends on row number.
*
* NP5 - INTEGER array of dimension( NPARMS )
* The fifth quantity which depends on row number.
*
* NP6 - INTEGER array of dimension( NPARMS )
* The sixth quantity which depends on row number.
*
* OPS - DOUBLE PRECISION array of dimension( LDT1, LDT2, NSIZES )
* The operation counts. The first index indicates the row,
* the second index indicates the block row, and the last
* indicates the column.
*
* LDO1 - INTEGER
* The first dimension of OPS. It must be at least
* min( 1, NPARMS ).
*
* LDO2 - INTEGER
* The second dimension of OPS. It must be at least
* min( 1, NTYPES ).
*
* TIMES - DOUBLE PRECISION array of dimension( LDT1, LDT2, NSIZES )
* The times (in seconds). The first index indicates the row,
* the second index indicates the block row, and the last
* indicates the column.
*
* LDT1 - INTEGER
* The first dimension of RESLTS. It must be at least
* min( 1, NPARMS ).
*
* LDT2 - INTEGER
* The second dimension of RESLTS. It must be at least
* min( 1, NTYPES ).
*
* RWORK - DOUBLE PRECISION array of dimension( NSIZES*NTYPES*NPARMS )
* Real workspace.
* Modified.
*
* LLWORK - LOGICAL array of dimension( NPARMS )
* Logical workspace. It is used to turn on or off specific
* lines in the output. If LLWORK(i) is .TRUE., then row i
* (which includes data from OPS(i,j,k) or TIMES(i,j,k) for
* all j and k) will be printed. If LLWORK(i) is
* .FALSE., then row i will not be printed.
* Modified.
*
* NOUT - INTEGER
* The output unit number on which the table
* is to be printed. If NOUT <= 0, no output is printed.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LTEMP
CHARACTER*40 FRMATA, FRMATI
INTEGER I, IINFO, ILINE, ILINES, IPADA, IPADI, IPAR, J,
$ JP, JS, JT
* ..
* .. External Functions ..
DOUBLE PRECISION DMFLOP
EXTERNAL DMFLOP
* ..
* .. External Subroutines ..
EXTERNAL DPRTBS
* ..
* .. Intrinsic Functions ..
INTRINSIC LEN, MAX, MIN
* ..
* .. Executable Statements ..
*
*
* First line
*
WRITE( NOUT, FMT = 9999 )SUBNAM
*
* Set up which lines are to be printed.
*
LLWORK( 1 ) = .TRUE.
ILINES = 1
DO 20 IPAR = 2, NPARMS
LLWORK( IPAR ) = .TRUE.
DO 10 J = 1, IPAR - 1
LTEMP = .FALSE.
IF( INPARM.GE.1 .AND. NP1( J ).NE.NP1( IPAR ) )
$ LTEMP = .TRUE.
IF( INPARM.GE.2 .AND. NP2( J ).NE.NP2( IPAR ) )
$ LTEMP = .TRUE.
IF( INPARM.GE.3 .AND. NP3( J ).NE.NP3( IPAR ) )
$ LTEMP = .TRUE.
IF( INPARM.GE.4 .AND. NP4( J ).NE.NP4( IPAR ) )
$ LTEMP = .TRUE.
IF( INPARM.GE.5 .AND. NP5( J ).NE.NP5( IPAR ) )
$ LTEMP = .TRUE.
IF( INPARM.GE.6 .AND. NP6( J ).NE.NP6( IPAR ) )
$ LTEMP = .TRUE.
IF( .NOT.LTEMP )
$ LLWORK( IPAR ) = .FALSE.
10 CONTINUE
IF( LLWORK( IPAR ) )
$ ILINES = ILINES + 1
20 CONTINUE
IF( ILINES.EQ.1 ) THEN
IF( INPARM.EQ.1 ) THEN
WRITE( NOUT, FMT = 9995 )PNAMES( 1 ), NP1( 1 )
ELSE IF( INPARM.EQ.2 ) THEN
WRITE( NOUT, FMT = 9995 )PNAMES( 1 ), NP1( 1 ),
$ PNAMES( 2 ), NP2( 1 )
ELSE IF( INPARM.EQ.3 ) THEN
WRITE( NOUT, FMT = 9995 )PNAMES( 1 ), NP1( 1 ),
$ PNAMES( 2 ), NP2( 1 ), PNAMES( 3 ), NP3( 1 )
ELSE IF( INPARM.EQ.4 ) THEN
WRITE( NOUT, FMT = 9995 )PNAMES( 1 ), NP1( 1 ),
$ PNAMES( 2 ), NP2( 1 ), PNAMES( 3 ), NP3( 1 ),
$ PNAMES( 4 ), NP4( 1 )
ELSE IF( INPARM.EQ.5 ) THEN
WRITE( NOUT, FMT = 9995 )PNAMES( 1 ), NP1( 1 ),
$ PNAMES( 2 ), NP2( 1 ), PNAMES( 3 ), NP3( 1 ),
$ PNAMES( 4 ), NP4( 1 ), PNAMES( 5 ), NP5( 1 )
ELSE IF( INPARM.EQ.6 ) THEN
WRITE( NOUT, FMT = 9995 )PNAMES( 1 ), NP1( 1 ),
$ PNAMES( 2 ), NP2( 1 ), PNAMES( 3 ), NP3( 1 ),
$ PNAMES( 4 ), NP4( 1 ), PNAMES( 5 ), NP5( 1 ),
$ PNAMES( 6 ), NP6( 1 )
END IF
ELSE
ILINE = 0
*
* Compute output format statement.
*
IPADI = MAX( LEN( PNAMES( 1 ) )-3, 1 )
WRITE( FRMATI, FMT = 9993 )IPADI
IPADA = 5 + IPADI - LEN( PNAMES( 1 ) )
WRITE( FRMATA, FMT = 9994 )IPADA
WRITE( NOUT, FMT = FRMATA )( PNAMES( J ), J = 1,
$ MIN( 6, INPARM ) )
DO 30 J = 1, NPARMS
IF( LLWORK( J ) ) THEN
ILINE = ILINE + 1
IF( INPARM.EQ.1 ) THEN
WRITE( NOUT, FMT = FRMATI )ILINE, NP1( J )
ELSE IF( INPARM.EQ.2 ) THEN
WRITE( NOUT, FMT = FRMATI )ILINE, NP1( J ), NP2( J )
ELSE IF( INPARM.EQ.3 ) THEN
WRITE( NOUT, FMT = FRMATI )ILINE, NP1( J ), NP2( J ),
$ NP3( J )
ELSE IF( INPARM.EQ.4 ) THEN
WRITE( NOUT, FMT = FRMATI )ILINE, NP1( J ), NP2( J ),
$ NP3( J ), NP4( J )
ELSE IF( INPARM.EQ.5 ) THEN
WRITE( NOUT, FMT = FRMATI )ILINE, NP1( J ), NP2( J ),
$ NP3( J ), NP4( J ), NP5( J )
ELSE IF( INPARM.EQ.6 ) THEN
WRITE( NOUT, FMT = FRMATI )ILINE, NP1( J ), NP2( J ),
$ NP3( J ), NP4( J ), NP5( J ), NP6( J )
END IF
END IF
30 CONTINUE
END IF
*
* Execution Times
*
WRITE( NOUT, FMT = 9996 )
CALL DPRTBS( 'Type', 'N ', NTYPES, DOTYPE, NSIZES, NN, NPARMS,
$ LLWORK, TIMES, LDT1, LDT2, NOUT )
*
* Operation Counts
*
WRITE( NOUT, FMT = 9997 )
CALL DPRTBS( 'Type', 'N ', NTYPES, DOTYPE, NSIZES, NN, NPARMS,
$ LLWORK, OPS, LDO1, LDO2, NOUT )
*
* Megaflop Rates
*
IINFO = 0
DO 60 JS = 1, NSIZES
DO 50 JT = 1, NTYPES
IF( DOTYPE( JT ) ) THEN
DO 40 JP = 1, NPARMS
I = JP + NPARMS*( JT-1+NTYPES*( JS-1 ) )
RWORK( I ) = DMFLOP( OPS( JP, JT, JS ),
$ TIMES( JP, JT, JS ), IINFO )
40 CONTINUE
END IF
50 CONTINUE
60 CONTINUE
*
WRITE( NOUT, FMT = 9998 )
CALL DPRTBS( 'Type', 'N ', NTYPES, DOTYPE, NSIZES, NN, NPARMS,
$ LLWORK, RWORK, NPARMS, NTYPES, NOUT )
*
9999 FORMAT( / / / ' ****** Results for ', A, ' ******' )
9998 FORMAT( / ' *** Speed in megaflops ***' )
9997 FORMAT( / ' *** Number of floating-point operations ***' )
9996 FORMAT( / ' *** Time in seconds ***' )
9995 FORMAT( 5X, : 'with ', 4( A, '=', I5, : ', ' ), / 10X,
$ 2( A, '=', I5, : ', ' ) )
*
* Format statements for generating format statements.
* 9981 generates a string 21+2+11=34 characters long.
* 9980 generates a string 16+2+12=30 characters long.
*
9994 FORMAT( '( 5X, : ''line '' , 6( ', I2, 'X, A, : ) )' )
9993 FORMAT( '( 5X, : I5 , 6( ', I2, 'X, I5, : ) )' )
RETURN
*
* End of DPRTBG
*
END
SUBROUTINE DPRTBR( LAB1, LAB2, NTYPES, DOTYPE, NSIZES, MM, NN,
$ NPARMS, DOLINE, RESLTS, LDR1, LDR2, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
CHARACTER*( * ) LAB1, LAB2
INTEGER LDR1, LDR2, NOUT, NPARMS, NSIZES, NTYPES
* ..
* .. Array Arguments ..
LOGICAL DOLINE( NPARMS ), DOTYPE( NTYPES )
INTEGER MM( NSIZES ), NN( NSIZES )
DOUBLE PRECISION RESLTS( LDR1, LDR2, * )
* ..
*
* Purpose
* =======
*
* DPRTBR prints a table of timing data for the timing programs.
* The table has NTYPES block rows and NSIZES columns, with NPARMS
* individual rows in each block row.
*
* Arguments (none are modified)
* =========
*
* LAB1 - CHARACTER*(*)
* The label for the rows.
*
* LAB2 - CHARACTER*(*)
* The label for the columns.
*
* NTYPES - INTEGER
* The number of values of DOTYPE, and also the
* number of sets of rows of the table.
*
* DOTYPE - LOGICAL array of dimension( NTYPES )
* If DOTYPE(j) is .TRUE., then block row j (which includes
* data from RESLTS( i, j, k ), for all i and k) will be
* printed. If DOTYPE(j) is .FALSE., then block row j will
* not be printed.
*
* NSIZES - INTEGER
* The number of values of NN, and also the
* number of columns of the table.
*
* MM - INTEGER array of dimension( NSIZES )
* The values of M used to label each column.
*
* NN - INTEGER array of dimension( NSIZES )
* The values of N used to label each column.
*
* NPARMS - INTEGER
* The number of values of LDA, hence the
* number of rows for each value of DOTYPE.
*
* DOLINE - LOGICAL array of dimension( NPARMS )
* If DOLINE(i) is .TRUE., then row i (which includes data
* from RESLTS( i, j, k ) for all j and k) will be printed.
* If DOLINE(i) is .FALSE., then row i will not be printed.
*
* RESLTS - DOUBLE PRECISION array of dimension( LDR1, LDR2, NSIZES )
* The timing results. The first index indicates the row,
* the second index indicates the block row, and the last
* indicates the column.
*
* LDR1 - INTEGER
* The first dimension of RESLTS. It must be at least
* min( 1, NPARMS ).
*
* LDR2 - INTEGER
* The second dimension of RESLTS. It must be at least
* min( 1, NTYPES ).
*
* NOUT - INTEGER
* The output unit number on which the table
* is to be printed. If NOUT <= 0, no output is printed.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, ILINE, J, K
* ..
* .. Executable Statements ..
*
IF( NOUT.LE.0 )
$ RETURN
IF( NPARMS.LE.0 )
$ RETURN
WRITE( NOUT, FMT = 9999 )LAB2,
$ ( MM( I ), NN( I ), I = 1, NSIZES )
WRITE( NOUT, FMT = 9998 )LAB1
*
DO 20 J = 1, NTYPES
ILINE = 0
IF( DOTYPE( J ) ) THEN
DO 10 I = 1, NPARMS
IF( DOLINE( I ) ) THEN
ILINE = ILINE + 1
IF( ILINE.LE.1 ) THEN
WRITE( NOUT, FMT = 9997 )J,
$ ( RESLTS( I, J, K ), K = 1, NSIZES )
ELSE
WRITE( NOUT, FMT = 9996 )( RESLTS( I, J, K ),
$ K = 1, NSIZES )
END IF
END IF
10 CONTINUE
IF( ILINE.GT.1 .AND. J.LT.NTYPES )
$ WRITE( NOUT, FMT = * )
END IF
20 CONTINUE
RETURN
*
9999 FORMAT( 7X, A4, ( 12( '(', I4, ',', I4, ')', : ) ) )
9998 FORMAT( 3X, A4 )
9997 FORMAT( 3X, I4, 4X, 1P, ( 12( 3X, G8.2 ) ) )
9996 FORMAT( 11X, 1P, ( 12( 3X, G8.2 ) ) )
*
* End of DPRTBR
*
END
SUBROUTINE DPRTBS( LAB1, LAB2, NTYPES, DOTYPE, NSIZES, NN, NPARMS,
$ DOLINE, RESLTS, LDR1, LDR2, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
CHARACTER*( * ) LAB1, LAB2
INTEGER LDR1, LDR2, NOUT, NPARMS, NSIZES, NTYPES
* ..
* .. Array Arguments ..
LOGICAL DOLINE( NPARMS ), DOTYPE( NTYPES )
INTEGER NN( NSIZES )
DOUBLE PRECISION RESLTS( LDR1, LDR2, * )
* ..
*
* Purpose
* =======
*
* DPRTBS prints a table of timing data for the timing programs.
* The table has NTYPES block rows and NSIZES columns, with NPARMS
* individual rows in each block row.
*
* Arguments (none are modified)
* =========
*
* LAB1 - CHARACTER*(*)
* The label for the rows.
*
* LAB2 - CHARACTER*(*)
* The label for the columns.
*
* NTYPES - INTEGER
* The number of values of DOTYPE, and also the
* number of sets of rows of the table.
*
* DOTYPE - LOGICAL array of dimension( NTYPES )
* If DOTYPE(j) is .TRUE., then block row j (which includes
* data from RESLTS( i, j, k ), for all i and k) will be
* printed. If DOTYPE(j) is .FALSE., then block row j will
* not be printed.
*
* NSIZES - INTEGER
* The number of values of NN, and also the
* number of columns of the table.
*
* NN - INTEGER array of dimension( NSIZES )
* The values of N used to label each column.
*
* NPARMS - INTEGER
* The number of values of LDA, hence the
* number of rows for each value of DOTYPE.
*
* DOLINE - LOGICAL array of dimension( NPARMS )
* If DOLINE(i) is .TRUE., then row i (which includes data
* from RESLTS( i, j, k ) for all j and k) will be printed.
* If DOLINE(i) is .FALSE., then row i will not be printed.
*
* RESLTS - DOUBLE PRECISION array of dimension( LDR1, LDR2, NSIZES )
* The timing results. The first index indicates the row,
* the second index indicates the block row, and the last
* indicates the column.
*
* LDR1 - INTEGER
* The first dimension of RESLTS. It must be at least
* min( 1, NPARMS ).
*
* LDR2 - INTEGER
* The second dimension of RESLTS. It must be at least
* min( 1, NTYPES ).
*
* NOUT - INTEGER
* The output unit number on which the table
* is to be printed. If NOUT <= 0, no output is printed.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, ILINE, J, K
* ..
* .. Executable Statements ..
*
IF( NOUT.LE.0 )
$ RETURN
IF( NPARMS.LE.0 )
$ RETURN
WRITE( NOUT, FMT = 9999 )LAB2, ( NN( I ), I = 1, NSIZES )
WRITE( NOUT, FMT = 9998 )LAB1
*
DO 20 J = 1, NTYPES
ILINE = 0
IF( DOTYPE( J ) ) THEN
DO 10 I = 1, NPARMS
IF( DOLINE( I ) ) THEN
ILINE = ILINE + 1
IF( ILINE.LE.1 ) THEN
WRITE( NOUT, FMT = 9997 )J,
$ ( RESLTS( I, J, K ), K = 1, NSIZES )
ELSE
WRITE( NOUT, FMT = 9996 )( RESLTS( I, J, K ),
$ K = 1, NSIZES )
END IF
END IF
10 CONTINUE
IF( ILINE.GT.1 .AND. J.LT.NTYPES )
$ WRITE( NOUT, FMT = * )
END IF
20 CONTINUE
RETURN
*
9999 FORMAT( 6X, A4, I6, 11I9 )
9998 FORMAT( 3X, A4 )
9997 FORMAT( 3X, I4, 4X, 1P, 12( 1X, G8.2 ) )
9996 FORMAT( 11X, 1P, 12( 1X, G8.2 ) )
*
* End of DPRTBS
*
END
SUBROUTINE DPRTBV( SUBNAM, NTYPES, DOTYPE, NSIZES, MM, NN, INPARM,
$ PNAMES, NPARMS, NP1, NP2, OPS, LDO1, LDO2,
$ TIMES, LDT1, LDT2, RWORK, LLWORK, NOUT )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
CHARACTER*( * ) SUBNAM
INTEGER INPARM, LDO1, LDO2, LDT1, LDT2, NOUT, NPARMS,
$ NSIZES, NTYPES
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( NTYPES ), LLWORK( NPARMS )
CHARACTER*( * ) PNAMES( * )
INTEGER MM( NSIZES ), NN( NSIZES ), NP1( * ), NP2( * )
DOUBLE PRECISION OPS( LDO1, LDO2, * ), RWORK( * ),
$ TIMES( LDT1, LDT2, * )
* ..
*
* Purpose
* =======
*
* DPRTBV prints out timing information for the eigenvalue routines.
* The table has NTYPES block rows and NSIZES columns, with NPARMS
* individual rows in each block row. There are INPARM quantities
* which depend on rows (currently, INPARM <= 4).
*
* Arguments (none are modified)
* =========
*
* SUBNAM - CHARACTER*(*)
* The label for the output.
*
* NTYPES - INTEGER
* The number of values of DOTYPE, and also the
* number of sets of rows of the table.
*
* DOTYPE - LOGICAL array of dimension( NTYPES )
* If DOTYPE(j) is .TRUE., then block row j (which includes
* data from RESLTS( i, j, k ), for all i and k) will be
* printed. If DOTYPE(j) is .FALSE., then block row j will
* not be printed.
*
* NSIZES - INTEGER
* The number of values of NN, and also the
* number of columns of the table.
*
* MM - INTEGER array of dimension( NSIZES )
* The values of M used to label each column.
*
* NN - INTEGER array of dimension( NSIZES )
* The values of N used to label each column.
*
* INPARM - INTEGER
* The number of different parameters which are functions of
* the row number. At the moment, INPARM <= 4.
*
* PNAMES - CHARACTER*(*) array of dimension( INPARM )
* The label for the columns.
*
* NPARMS - INTEGER
* The number of values for each "parameter", i.e., the
* number of rows for each value of DOTYPE.
*
* NP1 - INTEGER array of dimension( NPARMS )
* The first quantity which depends on row number.
*
* NP2 - INTEGER array of dimension( NPARMS )
* The second quantity which depends on row number.
*
* OPS - DOUBLE PRECISION array of dimension( LDT1, LDT2, NSIZES )
* The operation counts. The first index indicates the row,
* the second index indicates the block row, and the last
* indicates the column.
*
* LDO1 - INTEGER
* The first dimension of OPS. It must be at least
* min( 1, NPARMS ).
*
* LDO2 - INTEGER
* The second dimension of OPS. It must be at least
* min( 1, NTYPES ).
*
* TIMES - DOUBLE PRECISION array of dimension( LDT1, LDT2, NSIZES )
* The times (in seconds). The first index indicates the row,
* the second index indicates the block row, and the last
* indicates the column.
*
* LDT1 - INTEGER
* The first dimension of RESLTS. It must be at least
* min( 1, NPARMS ).
*
* LDT2 - INTEGER
* The second dimension of RESLTS. It must be at least
* min( 1, NTYPES ).
*
* RWORK - DOUBLE PRECISION array of dimension( NSIZES*NTYPES*NPARMS )
* Real workspace.
* Modified.
*
* LLWORK - LOGICAL array of dimension( NPARMS )
* Logical workspace. It is used to turn on or off specific
* lines in the output. If LLWORK(i) is .TRUE., then row i
* (which includes data from OPS(i,j,k) or TIMES(i,j,k) for
* all j and k) will be printed. If LLWORK(i) is
* .FALSE., then row i will not be printed.
* Modified.
*
* NOUT - INTEGER
* The output unit number on which the table
* is to be printed. If NOUT <= 0, no output is printed.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LTEMP
INTEGER I, IINFO, ILINE, ILINES, IPAR, J, JP, JS, JT
* ..
* .. External Functions ..
DOUBLE PRECISION DMFLOP
EXTERNAL DMFLOP
* ..
* .. External Subroutines ..
EXTERNAL DPRTBR
* ..
* .. Executable Statements ..
*
*
* First line
*
WRITE( NOUT, FMT = 9999 )SUBNAM
*
* Set up which lines are to be printed.
*
LLWORK( 1 ) = .TRUE.
ILINES = 1
DO 20 IPAR = 2, NPARMS
LLWORK( IPAR ) = .TRUE.
DO 10 J = 1, IPAR - 1
LTEMP = .FALSE.
IF( INPARM.GE.1 .AND. NP1( J ).NE.NP1( IPAR ) )
$ LTEMP = .TRUE.
IF( INPARM.GE.2 .AND. NP2( J ).NE.NP2( IPAR ) )
$ LTEMP = .TRUE.
IF( .NOT.LTEMP )
$ LLWORK( IPAR ) = .FALSE.
10 CONTINUE
IF( LLWORK( IPAR ) )
$ ILINES = ILINES + 1
20 CONTINUE
IF( ILINES.EQ.1 ) THEN
IF( INPARM.EQ.1 ) THEN
WRITE( NOUT, FMT = 9995 )PNAMES( 1 ), NP1( 1 )
ELSE IF( INPARM.EQ.2 ) THEN
WRITE( NOUT, FMT = 9995 )PNAMES( 1 ), NP1( 1 ),
$ PNAMES( 2 ), NP2( 1 )
END IF
ELSE
ILINE = 0
DO 30 J = 1, NPARMS
IF( LLWORK( J ) ) THEN
ILINE = ILINE + 1
IF( INPARM.EQ.1 ) THEN
WRITE( NOUT, FMT = 9994 )ILINE, PNAMES( 1 ), NP1( J )
ELSE IF( INPARM.EQ.2 ) THEN
WRITE( NOUT, FMT = 9994 )ILINE, PNAMES( 1 ),
$ NP1( J ), PNAMES( 2 ), NP2( J )
END IF
END IF
30 CONTINUE
END IF
*
* Execution Times
*
WRITE( NOUT, FMT = 9996 )
CALL DPRTBR( 'Type', 'M,N ', NTYPES, DOTYPE, NSIZES, MM, NN,
$ NPARMS, LLWORK, TIMES, LDT1, LDT2, NOUT )
*
* Operation Counts
*
WRITE( NOUT, FMT = 9997 )
CALL DPRTBR( 'Type', 'M,N ', NTYPES, DOTYPE, NSIZES, MM, NN,
$ NPARMS, LLWORK, OPS, LDO1, LDO2, NOUT )
*
* Megaflop Rates
*
IINFO = 0
DO 60 JS = 1, NSIZES
DO 50 JT = 1, NTYPES
IF( DOTYPE( JT ) ) THEN
DO 40 JP = 1, NPARMS
I = JP + NPARMS*( JT-1+NTYPES*( JS-1 ) )
RWORK( I ) = DMFLOP( OPS( JP, JT, JS ),
$ TIMES( JP, JT, JS ), IINFO )
40 CONTINUE
END IF
50 CONTINUE
60 CONTINUE
*
WRITE( NOUT, FMT = 9998 )
CALL DPRTBR( 'Type', 'M,N ', NTYPES, DOTYPE, NSIZES, MM, NN,
$ NPARMS, LLWORK, RWORK, NPARMS, NTYPES, NOUT )
*
9999 FORMAT( / / / ' ****** Results for ', A, ' ******' )
9998 FORMAT( / ' *** Speed in megaflops ***' )
9997 FORMAT( / ' *** Number of floating-point operations ***' )
9996 FORMAT( / ' *** Time in seconds ***' )
9995 FORMAT( 5X, : 'with ', A, '=', I5, 3( : ', ', A, '=', I5 ) )
9994 FORMAT( 5X, : 'line ', I2, ' with ', A, '=', I5,
$ 3( : ', ', A, '=', I5 ) )
RETURN
*
* End of DPRTBV
*
END
SUBROUTINE DTIM21( LINE, NSIZES, NN, NTYPES, DOTYPE, NPARMS, NNB,
$ NSHFTS, MAXBS, LDAS, TIMMIN, NOUT, ISEED, A, H,
$ Z, W, WORK, LWORK, LLWORK, IWORK, TIMES, LDT1,
$ LDT2, LDT3, OPCNTS, LDO1, LDO2, LDO3, INFO )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER INFO, LDO1, LDO2, LDO3, LDT1, LDT2, LDT3,
$ LWORK, NOUT, NPARMS, NSIZES, NTYPES
DOUBLE PRECISION TIMMIN
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * ), LLWORK( * )
INTEGER ISEED( * ), IWORK( * ), LDAS( * ), MAXBS( * ),
$ NN( * ), NNB( * ), NSHFTS( * )
DOUBLE PRECISION A( * ), H( * ), OPCNTS( LDO1, LDO2, LDO3, * ),
$ TIMES( LDT1, LDT2, LDT3, * ), W( * ),
$ WORK( * ), Z( * )
* ..
*
* Purpose
* =======
*
* DTIM21 times the LAPACK routines for the DOUBLE PRECISION
* non-symmetric eigenvalue problem.
*
* For each N value in NN(1:NSIZES) and .TRUE. value in
* DOTYPE(1:NTYPES), a matrix will be generated and used to test the
* selected routines. Thus, NSIZES*(number of .TRUE. values in
* DOTYPE) matrices will be generated.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* On entry, LINE contains the input line which requested
* this routine. This line may contain a subroutine name,
* such as DGEHRD, indicating that only routine SGEHRD will
* be timed, or it may contain a generic name, such as DHS.
* In this case, the rest of the line is scanned for the
* first 12 non-blank characters, corresponding to the twelve
* combinations of subroutine and options:
* LAPACK:
* 1: DGEHRD
* 2: DHSEQR(JOB='E')
* 3: DHSEQR(JOB='S')
* 4: DHSEQR(JOB='I')
* 5: DTREVC(JOB='L')
* 6: DTREVC(JOB='R')
* 7: DHSEIN(JOB='L')
* 8: DHSEIN(JOB='R')
* EISPACK:
* 9: ORTHES (compare with DGEHRD)
* 10: HQR (compare w/ DHSEQR -- JOB='E')
* 11: HQR2 (compare w/ DHSEQR(JOB='I') plus DTREVC(JOB='R'))
* 12: INVIT (compare with DHSEIN)
* If a character is 'T' or 't', the corresponding routine in
* this path is timed. If the entire line is blank, all the
* routines in the path are timed.
*
* NSIZES (input) INTEGER
* The number of values of N contained in the vector NN.
*
* NN (input) INTEGER array, dimension( NSIZES )
* The values of the matrix size N to be tested. For each
* N value in the array NN, and each .TRUE. value in DOTYPE,
* a matrix A will be generated and used to test the routines.
*
* NTYPES (input) INTEGER
* The number of types in DOTYPE. Only the first MAXTYP
* elements will be examined. Exception: if NSIZES=1 and
* NTYPES=MAXTYP+1, and DOTYPE=MAXTYP*f,t, then the input
* value of A will be used.
*
* DOTYPE (input) LOGICAL
* If DOTYPE(j) is .TRUE., then a matrix of type j will be
* generated. The matrix A has the form X**(-1) T X, where
* X is orthogonal (for j=1--4) or has condition sqrt(ULP)
* (for j=5--8), and T has random O(1) entries in the upper
* triangle and:
* (j=1,5) evenly spaced entries 1, ..., ULP with random signs
* (j=2,6) geometrically spaced entries 1, ..., ULP with random
* signs
* (j=3,7) "clustered" entries 1, ULP,..., ULP with random
* signs
* (j=4,8) real or complex conjugate paired eigenvalues
* randomly chosen from ( ULP, 1 )
* on the diagonal.
*
* NPARMS (input) INTEGER
* The number of values in each of the arrays NNB, NSHFTS,
* MAXBS, and LDAS. For each matrix A generated according to
* NN and DOTYPE, tests will be run with (NB,NSHIFT,MAXB,LDA)=
* (NNB(1), NSHFTS(1), MAXBS(1), LDAS(1)),...,
* (NNB(NPARMS), NSHFTS(NPARMS), MAXBS(NPARMS), LDAS(NPARMS))
*
* NNB (input) INTEGER array, dimension( NPARMS )
* The values of the blocksize ("NB") to be tested.
*
* NSHFTS (input) INTEGER array, dimension( NPARMS )
* The values of the number of shifts ("NSHIFT") to be tested.
*
* MAXBS (input) INTEGER array, dimension( NPARMS )
* The values of "MAXB", the size of largest submatrix to be
* processed by DLAHQR (EISPACK method), to be tested.
*
* LDAS (input) INTEGER array, dimension( NPARMS )
* The values of LDA, the leading dimension of all matrices,
* to be tested.
*
* TIMMIN (input) DOUBLE PRECISION
* The minimum time a subroutine will be timed.
*
* NOUT (input) INTEGER
* If NOUT > 0 then NOUT specifies the unit number
* on which the output will be printed. If NOUT <= 0, no
* output is printed.
*
* ISEED (input/output) INTEGER array, dimension( 4 )
* The random seed used by the random number generator, used
* by the test matrix generator. It is used and updated on
* each call to DTIM21
*
* A (workspace) DOUBLE PRECISION array,
* dimension( max(NN)*max(LDAS) )
* (a) During the testing of DGEHRD, the original matrix to
* be tested.
* (b) Later, the Schur form of the original matrix.
*
* H (workspace) DOUBLE PRECISION array,
* dimension( max(NN)*max(LDAS) )
* The Hessenberg form of the original matrix.
*
* Z (workspace) DOUBLE PRECISION array,
* dimension( max(NN)*max(LDAS) )
* Various output arrays: from DGEHRD and DHSEQR, the
* orthogonal reduction matrices; from DTREVC and DHSEIN,
* the eigenvector matrices.
*
* W (workspace) DOUBLE PRECISION array,
* dimension( 2*max(LDAS) )
* Treated as an LDA x 2 matrix whose 1st column holds WR, the
* real parts of the eigenvalues, and whose 2nd column holds
* WI, the imaginary parts of the eigenvalues of A.
*
* WORK (workspace) DOUBLE PRECISION array, dimension( LWORK )
*
* LWORK (input) INTEGER
* Number of elements in WORK. It must be at least
* (a) max(NN)*( 3*max(NNB) + 2 )
* (b) max(NN)*( max(NNB+NSHFTS) + 1 )
* (c) max(NSHFTS)*( max(NSHFTS) + max(NN) )
* (d) max(MAXBS)*( max(MAXBS) + max(NN) )
* (e) ( max(NN) + 2 )**2 + max(NN)
* (f) NSIZES*NTYPES*NPARMS
*
* LLWORK (workspace) LOGICAL array, dimension( max( max(NN), NPARMS ))
*
* IWORK (workspace) INTEGER array, dimension( 2*max(NN) )
* Workspace needed for parameters IFAILL and IFAILR in call
* to DHSEIN.
*
* TIMES (output) DOUBLE PRECISION array,
* dimension (LDT1,LDT2,LDT3,NSUBS)
* TIMES(i,j,k,l) will be set to the run time (in seconds) for
* subroutine l, with N=NN(k), matrix type j, and LDA=LDAS(i),
* MAXB=MAXBS(i), NBLOCK=NNB(i), and NSHIFT=NSHFTS(i).
*
* LDT1 (input) INTEGER
* The first dimension of TIMES. LDT1 >= min( 1, NPARMS ).
*
* LDT2 (input) INTEGER
* The second dimension of TIMES. LDT2 >= min( 1, NTYPES ).
*
* LDT3 (input) INTEGER
* The third dimension of TIMES. LDT3 >= min( 1, NSIZES ).
*
* OPCNTS (output) DOUBLE PRECISION array,
* dimension (LDO1,LDO2,LDO3,NSUBS)
* OPCNTS(i,j,k,l) will be set to the number of floating-point
* operations executed by subroutine l, with N=NN(k), matrix
* type j, and LDA=LDAS(i), MAXB=MAXBS(i), NBLOCK=NNB(i), and
* NSHIFT=NSHFTS(i).
*
* LDO1 (input) INTEGER
* The first dimension of OPCNTS. LDO1 >= min( 1, NPARMS ).
*
* LDO2 (input) INTEGER
* The second dimension of OPCNTS. LDO2 >= min( 1, NTYPES ).
*
* LDO3 (input) INTEGER
* The third dimension of OPCNTS. LDO3 >= min( 1, NSIZES ).
*
* INFO (output) INTEGER
* Error flag. It will be set to zero if no error occurred.
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXTYP, NSUBS
PARAMETER ( MAXTYP = 8, NSUBS = 12 )
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL RUNHQR, RUNHRD, RUNORT, RUNQRE, RUNQRS
INTEGER IC, ICONDS, IINFO, IMODE, IN, IPAR, ISUB,
$ ITEMP, ITYPE, J, J1, J2, J3, J4, JC, JR, LASTL,
$ LASTNL, LDA, LDAMIN, LDH, LDT, LDW, MAXB,
$ MBMAX, MTYPES, N, NB, NBMAX, NMAX, NSBMAX,
$ NSHIFT, NSMAX
DOUBLE PRECISION CONDS, RTULP, RTULPI, S1, S2, TIME, ULP,
$ ULPINV, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER ADUMMA( 1 )
CHARACTER*4 PNAMES( 4 )
CHARACTER*9 SUBNAM( NSUBS )
INTEGER INPARM( NSUBS ), IOLDSD( 4 ), KCONDS( MAXTYP ),
$ KMODE( MAXTYP )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DOPLA, DSECND
EXTERNAL DLAMCH, DOPLA, DSECND
* ..
* .. External Subroutines ..
EXTERNAL ATIMIN, DGEHRD, DHSEIN, DHSEQR, DLACPY, DLASET,
$ DLATME, DPRTBE, DTREVC, HQR, HQR2, INVIT,
$ ORTHES, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN, SQRT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Data statements ..
DATA SUBNAM / 'DGEHRD', 'DHSEQR(E)', 'DHSEQR(S)',
$ 'DHSEQR(V)', 'DTREVC(L)', 'DTREVC(R)',
$ 'DHSEIN(L)', 'DHSEIN(R)', 'ORTHES', 'HQR',
$ 'HQR2', 'INVIT' /
DATA INPARM / 2, 4, 4, 4, 1, 1, 1, 1, 1, 1, 1, 1 /
DATA PNAMES / 'LDA', 'NB', 'NS', 'MAXB' /
DATA KMODE / 4, 3, 1, 5, 4, 3, 1, 5 /
DATA KCONDS / 4*1, 4*2 /
* ..
* .. Executable Statements ..
*
* Quick Return
*
INFO = 0
IF( NSIZES.LE.0 .OR. NTYPES.LE.0 .OR. NPARMS.LE.0 )
$ RETURN
*
* Extract the timing request from the input line.
*
CALL ATIMIN( 'DHS', LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ RETURN
*
* Compute Maximum Values
*
NMAX = 0
DO 10 J1 = 1, NSIZES
NMAX = MAX( NMAX, NN( J1 ) )
10 CONTINUE
*
LDAMIN = 2*MAX( 1, NMAX )
NBMAX = 0
NSMAX = 0
MBMAX = 0
NSBMAX = 0
DO 20 J1 = 1, NPARMS
LDAMIN = MIN( LDAMIN, LDAS( J1 ) )
NBMAX = MAX( NBMAX, NNB( J1 ) )
NSMAX = MAX( NSMAX, NSHFTS( J1 ) )
MBMAX = MAX( MBMAX, MAXBS( J1 ) )
NSBMAX = MAX( NSBMAX, NNB( J1 )+NSHFTS( J1 ) )
20 CONTINUE
*
* Check that N <= LDA for the input values.
*
IF( NMAX.GT.LDAMIN ) THEN
INFO = -10
WRITE( NOUT, FMT = 9999 )LINE( 1: 6 )
9999 FORMAT( 1X, A, ' timing run not attempted -- N > LDA', / )
RETURN
END IF
*
* Check LWORK
*
IF( LWORK.LT.MAX( NMAX*MAX( 3*NBMAX+2, NSBMAX+1 ),
$ NSMAX*( NSMAX+NMAX ), MBMAX*( MBMAX+NMAX ),
$ ( NMAX+1 )*( NMAX+4 ), NSIZES*NTYPES*NPARMS ) ) THEN
INFO = -19
WRITE( NOUT, FMT = 9998 )LINE( 1: 6 )
9998 FORMAT( 1X, A, ' timing run not attempted -- LWORK too small.',
$ / )
RETURN
END IF
*
* Check to see whether DGEHRD or DHSEQR must be run.
*
* RUNQRE -- if DHSEQR must be run to get eigenvalues.
* RUNQRS -- if DHSEQR must be run to get Schur form.
* RUNHRD -- if DGEHRD must be run.
*
RUNQRS = .FALSE.
RUNQRE = .FALSE.
RUNHRD = .FALSE.
IF( TIMSUB( 5 ) .OR. TIMSUB( 6 ) )
$ RUNQRS = .TRUE.
IF( ( TIMSUB( 7 ) .OR. TIMSUB( 8 ) ) )
$ RUNQRE = .TRUE.
IF( TIMSUB( 2 ) .OR. TIMSUB( 3 ) .OR. TIMSUB( 4 ) .OR. RUNQRS .OR.
$ RUNQRE )RUNHRD = .TRUE.
IF( TIMSUB( 3 ) .OR. TIMSUB( 4 ) .OR. RUNQRS )
$ RUNQRE = .FALSE.
IF( TIMSUB( 4 ) )
$ RUNQRS = .FALSE.
*
* Check to see whether ORTHES or HQR must be run.
*
* RUNHQR -- if HQR must be run to get eigenvalues.
* RUNORT -- if ORTHES must be run.
*
RUNHQR = .FALSE.
RUNORT = .FALSE.
IF( TIMSUB( 12 ) )
$ RUNHQR = .TRUE.
IF( TIMSUB( 10 ) .OR. TIMSUB( 11 ) .OR. RUNHQR )
$ RUNORT = .TRUE.
IF( TIMSUB( 10 ) .OR. TIMSUB( 11 ) )
$ RUNHQR = .FALSE.
IF( TIMSUB( 9 ) )
$ RUNORT = .FALSE.
*
* Various Constants
*
ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
ULPINV = ONE / ULP
RTULP = SQRT( ULP )
RTULPI = ONE / RTULP
*
* Zero out OPCNTS, TIMES
*
DO 60 J4 = 1, NSUBS
DO 50 J3 = 1, NSIZES
DO 40 J2 = 1, NTYPES
DO 30 J1 = 1, NPARMS
OPCNTS( J1, J2, J3, J4 ) = ZERO
TIMES( J1, J2, J3, J4 ) = ZERO
30 CONTINUE
40 CONTINUE
50 CONTINUE
60 CONTINUE
*
* Do for each value of N:
*
DO 620 IN = 1, NSIZES
*
N = NN( IN )
*
* Do for each .TRUE. value in DOTYPE:
*
MTYPES = MIN( MAXTYP, NTYPES )
IF( NTYPES.EQ.MAXTYP+1 .AND. NSIZES.EQ.1 )
$ MTYPES = NTYPES
DO 610 ITYPE = 1, MTYPES
IF( .NOT.DOTYPE( ITYPE ) )
$ GO TO 610
*
* Save random number seed for error messages
*
DO 70 J = 1, 4
IOLDSD( J ) = ISEED( J )
70 CONTINUE
*
*-----------------------------------------------------------------------
*
* Time the LAPACK Routines
*
* Generate A
*
IF( ITYPE.LE.MAXTYP ) THEN
IMODE = KMODE( ITYPE )
ICONDS = KCONDS( ITYPE )
IF( ICONDS.EQ.1 ) THEN
CONDS = ONE
ELSE
CONDS = RTULPI
END IF
ADUMMA( 1 ) = ' '
CALL DLATME( N, 'S', ISEED, WORK, IMODE, ULPINV, ONE,
$ ADUMMA, 'T', 'T', 'T', WORK( N+1 ), 4,
$ CONDS, N, N, ONE, A, N, WORK( 2*N+1 ),
$ IINFO )
END IF
*
* Time DGEHRD for each pair NNB(j), LDAS(j)
*
IF( TIMSUB( 1 ) ) THEN
DO 110 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
*
* If this combination of (NB,LDA) has occurred before,
* just use that value.
*
LASTNL = 0
DO 80 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) .AND. NB.EQ.
$ MIN( N, NNB( J ) ) )LASTNL = J
80 CONTINUE
*
IF( LASTNL.EQ.0 ) THEN
CALL XLAENV( 1, NB )
CALL XLAENV( 2, 2 )
CALL XLAENV( 3, NB )
*
* Time DGEHRD
*
IC = 0
OPS = ZERO
S1 = DSECND( )
90 CONTINUE
CALL DLACPY( 'Full', N, N, A, N, H, LDA )
*
CALL DGEHRD( N, 1, N, H, LDA, WORK, WORK( N+1 ),
$ LWORK-N, IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 1 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 610
END IF
*
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 90
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 100 J = 1, IC
CALL DLACPY( 'Full', N, N, A, N, Z, LDA )
100 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 1 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 1 ) = DOPLA( 'DGEHRD', N,
$ 1, N, 0, NB )
ELSE
OPCNTS( IPAR, ITYPE, IN, 1 ) = OPCNTS( LASTNL,
$ ITYPE, IN, 1 )
TIMES( IPAR, ITYPE, IN, 1 ) = TIMES( LASTNL, ITYPE,
$ IN, 1 )
END IF
110 CONTINUE
LDH = LDA
ELSE
IF( RUNHRD ) THEN
CALL DLACPY( 'Full', N, N, A, N, H, N )
*
CALL DGEHRD( N, 1, N, H, N, WORK, WORK( N+1 ),
$ LWORK-N, IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 1 ), IINFO, N,
$ ITYPE, 0, IOLDSD
INFO = ABS( IINFO )
GO TO 610
END IF
LDH = N
END IF
END IF
*
* Time DHSEQR with JOB='E' for each 4-tuple
* NNB(j), NSHFTS(j), MAXBS(j), LDAS(j)
*
IF( TIMSUB( 2 ) ) THEN
DO 140 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = 1
NSHIFT = NSHFTS( IPAR )
MAXB = MAXBS( IPAR )
CALL XLAENV( 4, NSHIFT )
CALL XLAENV( 8, MAXB )
*
* Time DHSEQR with JOB='E'
*
IC = 0
OPS = ZERO
S1 = DSECND( )
120 CONTINUE
CALL DLACPY( 'Full', N, N, H, LDH, A, LDA )
*
CALL DHSEQR( 'E', 'N', N, 1, N, A, LDA, W, W( LDA+1 ),
$ Z, LDA, WORK, LWORK, IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 2 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 610
END IF
*
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 120
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 130 J = 1, IC
CALL DLACPY( 'Full', N, N, H, LDH, Z, LDA )
130 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 2 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 2 ) = OPS / DBLE( IC )
140 CONTINUE
LDT = 0
LDW = LDA
ELSE
IF( RUNQRE ) THEN
CALL DLACPY( 'Full', N, N, H, LDH, A, N )
*
CALL DHSEQR( 'E', 'N', N, 1, N, A, N, W, W( N+1 ), Z,
$ N, WORK, LWORK, IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 2 ), IINFO, N,
$ ITYPE, 0, IOLDSD
INFO = ABS( IINFO )
GO TO 610
END IF
LDT = 0
LDW = N
END IF
END IF
*
* Time DHSEQR with JOB='S' for each 4-tuple
* NNB(j), NSHFTS(j), MAXBS(j), LDAS(j)
*
IF( TIMSUB( 3 ) ) THEN
DO 170 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NSHIFT = NSHFTS( IPAR )
MAXB = MAXBS( IPAR )
NB = 1
CALL XLAENV( 4, NSHIFT )
CALL XLAENV( 8, MAXB )
*
* Time DHSEQR with JOB='S'
*
IC = 0
OPS = ZERO
S1 = DSECND( )
150 CONTINUE
CALL DLACPY( 'Full', N, N, H, LDH, A, LDA )
*
CALL DHSEQR( 'S', 'N', N, 1, N, A, LDA, W, W( LDA+1 ),
$ Z, LDA, WORK, LWORK, IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 3 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 610
END IF
*
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 150
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 160 J = 1, IC
CALL DLACPY( 'Full', N, N, H, LDH, Z, LDA )
160 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 3 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 3 ) = OPS / DBLE( IC )
170 CONTINUE
LDT = LDA
LDW = LDA
ELSE
IF( RUNQRS ) THEN
CALL DLACPY( 'Full', N, N, H, LDH, A, N )
*
CALL DHSEQR( 'S', 'N', N, 1, N, A, N, W, W( N+1 ), Z,
$ N, WORK, LWORK, IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 3 ), IINFO, N,
$ ITYPE, 0, IOLDSD
INFO = ABS( IINFO )
GO TO 610
END IF
LDT = N
LDW = N
END IF
END IF
*
* Time DHSEQR with JOB='I' for each 4-tuple
* NNB(j), NSHFTS(j), MAXBS(j), LDAS(j)
*
IF( TIMSUB( 4 ) ) THEN
DO 200 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NSHIFT = NSHFTS( IPAR )
MAXB = MAXBS( IPAR )
NB = 1
CALL XLAENV( 4, NSHIFT )
CALL XLAENV( 8, MAXB )
*
* Time DHSEQR with JOB='I'
*
IC = 0
OPS = ZERO
S1 = DSECND( )
180 CONTINUE
CALL DLACPY( 'Full', N, N, H, LDH, A, LDA )
*
CALL DHSEQR( 'S', 'I', N, 1, N, A, LDA, W, W( LDA+1 ),
$ Z, LDA, WORK, LWORK, IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 4 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 610
END IF
*
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 180
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 190 J = 1, IC
CALL DLACPY( 'Full', N, N, H, LDH, Z, LDA )
190 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 4 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 4 ) = OPS / DBLE( IC )
200 CONTINUE
LDT = LDA
LDW = LDA
END IF
*
* Time DTREVC and DHSEIN with various values of LDA
*
* Select All Eigenvectors
*
DO 210 J = 1, N
LLWORK( J ) = .TRUE.
210 CONTINUE
*
DO 370 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 220 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
220 CONTINUE
*
* Time DTREVC
*
IF( ( TIMSUB( 5 ) .OR. TIMSUB( 6 ) ) .AND. LASTL.EQ.0 )
$ THEN
*
* Copy T (which is in A) if necessary to get right LDA.
*
IF( LDA.GT.LDT ) THEN
DO 240 JC = N, 1, -1
DO 230 JR = N, 1, -1
A( JR+( JC-1 )*LDA ) = A( JR+( JC-1 )*LDT )
230 CONTINUE
240 CONTINUE
ELSE IF( LDA.LT.LDT ) THEN
DO 260 JC = 1, N
DO 250 JR = 1, N
A( JR+( JC-1 )*LDA ) = A( JR+( JC-1 )*LDT )
250 CONTINUE
260 CONTINUE
END IF
LDT = LDA
*
* Time DTREVC for Left Eigenvectors
*
IF( TIMSUB( 5 ) ) THEN
IC = 0
OPS = ZERO
S1 = DSECND( )
270 CONTINUE
*
CALL DTREVC( 'L', 'A', LLWORK, N, A, LDA, Z, LDA,
$ Z, LDA, N, ITEMP, WORK, IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 5 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 610
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 270
*
TIMES( IPAR, ITYPE, IN, 5 ) = TIME / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 5 ) = OPS / DBLE( IC )
END IF
*
* Time DTREVC for Right Eigenvectors
*
IF( TIMSUB( 6 ) ) THEN
IC = 0
OPS = ZERO
S1 = DSECND( )
280 CONTINUE
CALL DTREVC( 'R', 'A', LLWORK, N, A, LDA, Z, LDA,
$ Z, LDA, N, ITEMP, WORK, IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 6 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 610
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 280
*
TIMES( IPAR, ITYPE, IN, 6 ) = TIME / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 6 ) = OPS / DBLE( IC )
END IF
ELSE
IF( TIMSUB( 5 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 5 ) = OPCNTS( LASTL,
$ ITYPE, IN, 5 )
TIMES( IPAR, ITYPE, IN, 5 ) = TIMES( LASTL, ITYPE,
$ IN, 5 )
END IF
IF( TIMSUB( 6 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 6 ) = OPCNTS( LASTL,
$ ITYPE, IN, 6 )
TIMES( IPAR, ITYPE, IN, 6 ) = TIMES( LASTL, ITYPE,
$ IN, 6 )
END IF
END IF
*
* Time DHSEIN
*
IF( ( TIMSUB( 7 ) .OR. TIMSUB( 8 ) ) .AND. LASTL.EQ.0 )
$ THEN
*
* Copy H if necessary to get right LDA.
*
IF( LDA.GT.LDH ) THEN
DO 300 JC = N, 1, -1
DO 290 JR = N, 1, -1
H( JR+( JC-1 )*LDA ) = H( JR+( JC-1 )*LDH )
290 CONTINUE
W( JC+LDA ) = W( JC+LDH )
300 CONTINUE
ELSE IF( LDA.LT.LDH ) THEN
DO 320 JC = 1, N
DO 310 JR = 1, N
H( JR+( JC-1 )*LDA ) = H( JR+( JC-1 )*LDH )
310 CONTINUE
W( JC+LDA ) = W( JC+LDH )
320 CONTINUE
END IF
LDH = LDA
*
* Copy W if necessary to get right LDA.
*
IF( LDA.GT.LDW ) THEN
DO 330 J = N, 1, -1
W( J+LDA ) = W( J+LDW )
330 CONTINUE
ELSE IF( LDA.LT.LDW ) THEN
DO 340 J = 1, N
W( J+LDA ) = W( J+LDW )
340 CONTINUE
END IF
LDW = LDA
*
* Time DHSEIN for Left Eigenvectors
*
IF( TIMSUB( 7 ) ) THEN
IC = 0
OPS = ZERO
S1 = DSECND( )
350 CONTINUE
*
CALL DHSEIN( 'L', 'Q', 'N', LLWORK, N, H, LDA, W,
$ W( LDA+1 ), Z, LDA, Z, LDA, N, ITEMP,
$ WORK, IWORK, IWORK( N+1 ), IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 7 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 610
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 350
*
TIMES( IPAR, ITYPE, IN, 7 ) = TIME / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 7 ) = OPS / DBLE( IC )
END IF
*
* Time DHSEIN for Right Eigenvectors
*
IF( TIMSUB( 8 ) ) THEN
IC = 0
OPS = ZERO
S1 = DSECND( )
360 CONTINUE
*
CALL DHSEIN( 'R', 'Q', 'N', LLWORK, N, H, LDA, W,
$ W( LDA+1 ), Z, LDA, Z, LDA, N, ITEMP,
$ WORK, IWORK, IWORK( N+1 ), IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 8 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 610
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 360
*
TIMES( IPAR, ITYPE, IN, 8 ) = TIME / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 8 ) = OPS / DBLE( IC )
END IF
ELSE
IF( TIMSUB( 7 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 7 ) = OPCNTS( LASTL,
$ ITYPE, IN, 7 )
TIMES( IPAR, ITYPE, IN, 7 ) = TIMES( LASTL, ITYPE,
$ IN, 7 )
END IF
IF( TIMSUB( 8 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 8 ) = OPCNTS( LASTL,
$ ITYPE, IN, 8 )
TIMES( IPAR, ITYPE, IN, 8 ) = TIMES( LASTL, ITYPE,
$ IN, 8 )
END IF
END IF
370 CONTINUE
*
*-----------------------------------------------------------------------
*
* Time the EISPACK Routines
*
* Restore random number seed
*
DO 380 J = 1, 4
ISEED( J ) = IOLDSD( J )
380 CONTINUE
*
* Re-generate A
*
IF( ITYPE.LE.MAXTYP ) THEN
IMODE = KMODE( ITYPE )
IF( ICONDS.EQ.1 ) THEN
CONDS = ONE
ELSE
CONDS = RTULPI
END IF
CALL DLATME( N, 'S', ISEED, WORK, IMODE, ULPINV, ONE,
$ ADUMMA, 'T', 'T', 'T', WORK( N+1 ), 4,
$ CONDS, N, N, ONE, A, N, WORK( 2*N+1 ),
$ IINFO )
END IF
*
* Time ORTHES for each LDAS(j)
*
IF( TIMSUB( 9 ) ) THEN
DO 420 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 390 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
390 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time ORTHES
*
IC = 0
OPS = ZERO
S1 = DSECND( )
*
400 CONTINUE
CALL DLACPY( 'Full', N, N, A, N, H, LDA )
*
CALL ORTHES( LDA, N, 1, N, H, WORK )
*
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 400
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 410 J = 1, IC
CALL DLACPY( 'Full', N, N, A, N, Z, LDA )
410 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
* OPS1 = ( 20*N**3 - 3*N**2 - 23*N ) / 6 - 17
*
TIMES( IPAR, ITYPE, IN, 9 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 9 ) = OPS / DBLE( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 9 ) = OPCNTS( LASTL,
$ ITYPE, IN, 9 )
TIMES( IPAR, ITYPE, IN, 9 ) = TIMES( LASTL, ITYPE,
$ IN, 9 )
END IF
LDH = LDA
420 CONTINUE
ELSE
IF( RUNORT ) THEN
CALL DLACPY( 'Full', N, N, A, N, H, N )
*
CALL ORTHES( N, N, 1, N, H, WORK )
*
LDH = N
END IF
END IF
*
* Time HQR for each LDAS(j)
*
IF( TIMSUB( 10 ) ) THEN
DO 460 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 430 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
430 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time HQR
*
IC = 0
OPS = ZERO
S1 = DSECND( )
440 CONTINUE
CALL DLACPY( 'Full', N, N, H, LDH, A, LDA )
*
CALL HQR( LDA, N, 1, N, A, W, W( LDA+1 ), IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 10 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 610
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 440
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 450 J = 1, IC
CALL DLACPY( 'Full', N, N, H, LDH, Z, LDA )
450 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 10 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 10 ) = OPS / DBLE( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 10 ) = OPCNTS( LASTL,
$ ITYPE, IN, 10 )
TIMES( IPAR, ITYPE, IN, 10 ) = TIMES( LASTL, ITYPE,
$ IN, 10 )
END IF
LDW = LDA
460 CONTINUE
ELSE
IF( RUNHQR ) THEN
CALL DLACPY( 'Full', N, N, A, N, H, N )
*
CALL HQR( N, N, 1, N, A, W, W( N+1 ), IINFO )
*
LDW = N
END IF
END IF
*
* Time HQR2 for each LDAS(j)
*
IF( TIMSUB( 11 ) ) THEN
DO 500 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 470 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
470 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time HQR2
*
IC = 0
OPS = ZERO
S1 = DSECND( )
480 CONTINUE
CALL DLACPY( 'Full', N, N, H, LDH, A, LDA )
CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDA )
*
CALL HQR2( LDA, N, 1, N, A, W, W( LDA+1 ), Z,
$ IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 11 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 610
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 480
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 490 J = 1, IC
CALL DLACPY( 'Full', N, N, H, LDH, Z, LDA )
490 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 11 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 11 ) = OPS / DBLE( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 11 ) = OPCNTS( LASTL,
$ ITYPE, IN, 11 )
TIMES( IPAR, ITYPE, IN, 11 ) = TIMES( LASTL, ITYPE,
$ IN, 11 )
END IF
LDW = LDA
500 CONTINUE
END IF
*
* Time INVIT for each LDAS(j)
*
* Select All Eigenvectors
*
DO 510 J = 1, N
LLWORK( J ) = .TRUE.
510 CONTINUE
*
IF( TIMSUB( 12 ) ) THEN
DO 600 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 520 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
520 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Copy H if necessary to get right LDA.
*
IF( LDA.GT.LDH ) THEN
DO 540 JC = N, 1, -1
DO 530 JR = N, 1, -1
H( JR+( JC-1 )*LDA ) = H( JR+( JC-1 )*
$ LDH )
530 CONTINUE
540 CONTINUE
ELSE IF( LDA.LT.LDH ) THEN
DO 560 JC = 1, N
DO 550 JR = 1, N
H( JR+( JC-1 )*LDA ) = H( JR+( JC-1 )*
$ LDH )
550 CONTINUE
560 CONTINUE
END IF
LDH = LDA
*
* Copy W if necessary to get right LDA.
*
IF( LDA.GT.LDW ) THEN
DO 570 J = N, 1, -1
W( J+LDA ) = W( J+LDW )
570 CONTINUE
ELSE IF( LDA.LT.LDW ) THEN
DO 580 J = 1, N
W( J+LDA ) = W( J+LDW )
580 CONTINUE
END IF
LDW = LDA
*
* Time INVIT for right eigenvectors.
*
IC = 0
OPS = ZERO
S1 = DSECND( )
590 CONTINUE
*
CALL INVIT( LDA, N, H, W, W( LDA+1 ), LLWORK, N,
$ ITEMP, Z, IINFO, WORK( 2*N+1 ), WORK,
$ WORK( N+1 ) )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 12 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 610
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 590
*
* TIME = TIME / DOUBLE PRECISION( IC )
* OPS1 = OPS / DOUBLE PRECISION( IC )
* OPCNTS( IPAR, ITYPE, IN, 12 ) = OPS1
* TIMES( IPAR, ITYPE, IN, 12 ) = DMFLOP( OPS1, TIME,
* $ IINFO )
*
TIMES( IPAR, ITYPE, IN, 12 ) = TIME / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 12 ) = OPS / DBLE( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 12 ) = OPCNTS( LASTL,
$ ITYPE, IN, 12 )
TIMES( IPAR, ITYPE, IN, 12 ) = TIMES( LASTL, ITYPE,
$ IN, 12 )
END IF
600 CONTINUE
END IF
*
610 CONTINUE
620 CONTINUE
*
*-----------------------------------------------------------------------
*
* Print a table of results for each timed routine.
*
ISUB = 1
IF( TIMSUB( ISUB ) ) THEN
CALL DPRTBE( SUBNAM( ISUB ), MTYPES, DOTYPE, NSIZES, NN,
$ INPARM( ISUB ), PNAMES, NPARMS, LDAS, NNB, NSHFTS,
$ MAXBS, OPCNTS( 1, 1, 1, ISUB ), LDO1, LDO2,
$ TIMES( 1, 1, 1, ISUB ), LDT1, LDT2, WORK, LLWORK,
$ NOUT )
END IF
*
DO 630 IN = 1, NPARMS
NNB( IN ) = 1
630 CONTINUE
*
DO 640 ISUB = 2, NSUBS
IF( TIMSUB( ISUB ) ) THEN
CALL DPRTBE( SUBNAM( ISUB ), MTYPES, DOTYPE, NSIZES, NN,
$ INPARM( ISUB ), PNAMES, NPARMS, LDAS, NNB,
$ NSHFTS, MAXBS, OPCNTS( 1, 1, 1, ISUB ), LDO1,
$ LDO2, TIMES( 1, 1, 1, ISUB ), LDT1, LDT2, WORK,
$ LLWORK, NOUT )
END IF
640 CONTINUE
*
RETURN
*
* End of DTIM21
*
9997 FORMAT( ' DTIM21: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', ITYPE=', I6, ', IPAR=', I6, ', ISEED=(',
$ 3( I5, ',' ), I5, ')' )
*
END
SUBROUTINE DTIM22( LINE, NSIZES, NN, NTYPES, DOTYPE, NPARMS, NNB,
$ LDAS, TIMMIN, NOUT, ISEED, A, D, E, E2, Z, Z1,
$ WORK, LWORK, LLWORK, IWORK, TIMES, LDT1, LDT2,
$ LDT3, OPCNTS, LDO1, LDO2, LDO3, INFO )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 20, 2000
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER INFO, LDO1, LDO2, LDO3, LDT1, LDT2, LDT3,
$ LWORK, NOUT, NPARMS, NSIZES, NTYPES
DOUBLE PRECISION TIMMIN
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * ), LLWORK( * )
INTEGER ISEED( * ), IWORK( * ), LDAS( * ), NN( * ),
$ NNB( * )
DOUBLE PRECISION A( * ), D( * ), E( * ), E2( * ),
$ OPCNTS( LDO1, LDO2, LDO3, * ),
$ TIMES( LDT1, LDT2, LDT3, * ), WORK( * ),
$ Z( * ), Z1( * )
* ..
*
* Purpose
* =======
*
* DTIM22 times the LAPACK routines for the real symmetric
* eigenvalue problem.
*
* For each N value in NN(1:NSIZES) and .TRUE. value in
* DOTYPE(1:NTYPES), a matrix will be generated and used to test the
* selected routines. Thus, NSIZES*(number of .TRUE. values in
* DOTYPE) matrices will be generated.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* On entry, LINE contains the input line which requested
* this routine. This line may contain a subroutine name,
* such as DSYTRD, indicating that only routine SSYTRD will
* be timed, or it may contain a generic name, such as DST.
* In this case, the rest of the line is scanned for the
* first 23 non-blank characters, corresponding to the eight
* combinations of subroutine and options:
* LAPACK:
* 1: DSYTRD
* 2: DORGTR
* 3: DORMTR
* 4: DSTEQR(VECT='N')
* 5: DSTEQR(VECT='V')
* 6: DSTERF
* 7: DPTEQR(VECT='N')
* 8: DPTEQR(VECT='V')
* 9: DSTEBZ(RANGE='I')
* 10: DSTEBZ(RANGE='V')
* 11: DSTEIN
* 12: DSTEDC(COMPQ='N')
* 13: DSTEDC(COMPQ='I')
* 14: DSTEDC(COMPQ='V')
* 15: DSTEGR(COMPQ='N')
* 16: DSTEGR(COMPQ='V')
* EISPACK:
* 17: TRED1 (compare with DSYTRD)
* 18: IMTQL1 (compare w/ DSTEQR -- VECT='N')
* 19: IMTQL2 (compare w/ DSTEQR -- VECT='V')
* 20: TQLRAT (compare with DSTERF)
* 21: TRIDIB (compare with DSTEBZ -- RANGE='I')
* 22: BISECT (compare with DSTEBZ -- RANGE='V')
* 23: TINVIT (compare with DSTEIN)
* If a character is 'T' or 't', the corresponding routine in
* this path is timed. If the entire line is blank, all the
* routines in the path are timed.
*
* NSIZES (input) INTEGER
* The number of values of N contained in the vector NN.
*
* NN (input) INTEGER array, dimension( NSIZES )
* The values of the matrix size N to be tested. For each
* N value in the array NN, and each .TRUE. value in DOTYPE,
* a matrix A will be generated and used to test the routines.
*
* NTYPES (input) INTEGER
* The number of types in DOTYPE. Only the first MAXTYP
* elements will be examined. Exception: if NSIZES=1 and
* NTYPES=MAXTYP+1, and DOTYPE=MAXTYP*f,t, then the input
* value of A will be used.
*
* DOTYPE (input) LOGICAL
* If DOTYPE(j) is .TRUE., then a matrix of type j will be
* generated. The matrix A has the form X**(-1) D X, where
* X is orthogonal and D is diagonal with:
* (j=1) evenly spaced entries 1, ..., ULP with random signs.
* (j=2) geometrically spaced entries 1, ..., ULP with random
* signs.
* (j=3) "clustered" entries 1, ULP,..., ULP with random
* signs.
* (j=4) entries randomly chosen from ( ULP, 1 ).
*
* NPARMS (input) INTEGER
* The number of values in each of the arrays NNB and LDAS.
* For each matrix A generated according to NN and DOTYPE,
* tests will be run with (NB,LDA)=
* (NNB(1),LDAS(1)),...,(NNB(NPARMS), LDAS(NPARMS))
*
* NNB (input) INTEGER array, dimension( NPARMS )
* The values of the blocksize ("NB") to be tested.
*
* LDAS (input) INTEGER array, dimension( NPARMS )
* The values of LDA, the leading dimension of all matrices,
* to be tested.
*
* TIMMIN (input) DOUBLE PRECISION
* The minimum time a subroutine will be timed.
*
* NOUT (input) INTEGER
* If NOUT > 0 then NOUT specifies the unit number
* on which the output will be printed. If NOUT <= 0, no
* output is printed.
*
* ISEED (input/output) INTEGER array, dimension( 4 )
* The random seed used by the random number generator, used
* by the test matrix generator. It is used and updated on
* each call to DTIM22
*
* A (workspace) DOUBLE PRECISION array,
* dimension( max(NN)*max(LDAS) )
* The original matrix to be tested.
*
* D (workspace) DOUBLE PRECISION array,
* dimension( max(NN) )
* The diagonal of the tridiagonal generated by DSYTRD/TRED1.
*
* E (workspace) DOUBLE PRECISION array,
* dimension( max(NN) )
* The off-diagonal of the tridiagonal generated by
* DSYTRD/TRED1.
*
* E2 (workspace) DOUBLE PRECISION array,
* dimension( max(NN) )
* The square of the off-diagonal of the tridiagonal generated
* by TRED1. (Used by TQLRAT.)
*
* Z (workspace) DOUBLE PRECISION array,
* dimension( max(NN)*max(LDAS) )
* Various output arrays.
*
* WORK (workspace) DOUBLE PRECISION array, dimension( LWORK )
*
* LWORK (input) INTEGER
* Number of elements in WORK. It must be at least
* (a) max( (NNB + 2 )*LDAS )
* (b) max( 5*LDAS )
* (c) NSIZES*NTYPES*NPARMS
* (d) 2*LDAS + 1 + 3*maxNN + 2*maxNN*log2(maxNN) + 3*maxNN**2
* where maxNN = maximum matrix dimension in NN
* log2(x) = smallest integer power of 2 .ge. x
*
* LLWORK (workspace) LOGICAL array of dimension( NPARMS ),
*
* IWORK (workspace) INTEGER array of dimension
* 6 + 6*maxNN + 5*maxNN*log2(maxNN)
*
* TIMES (output) DOUBLE PRECISION array,
* dimension (LDT1,LDT2,LDT3,NSUBS)
* TIMES(i,j,k,l) will be set to the run time (in seconds) for
* subroutine l, with N=NN(k), matrix type j, and LDA=LDAS(i),
* NBLOCK=NNB(i).
*
* LDT1 (input) INTEGER
* The first dimension of TIMES. LDT1 >= min( 1, NPARMS ).
*
* LDT2 (input) INTEGER
* The second dimension of TIMES. LDT2 >= min( 1, NTYPES ).
*
* LDT3 (input) INTEGER
* The third dimension of TIMES. LDT3 >= min( 1, NSIZES ).
*
* OPCNTS (output) DOUBLE PRECISION array,
* dimension (LDO1,LDO2,LDO3,NSUBS)
* OPCNTS(i,j,k,l) will be set to the number of floating-point
* operations executed by subroutine l, with N=NN(k), matrix
* type j, and LDA=LDAS(i), NBLOCK=NNB(i).
*
* LDO1 (input) INTEGER
* The first dimension of OPCNTS. LDO1 >= min( 1, NPARMS ).
*
* LDO2 (input) INTEGER
* The second dimension of OPCNTS. LDO2 >= min( 1, NTYPES ).
*
* LDO3 (input) INTEGER
* The third dimension of OPCNTS. LDO3 >= min( 1, NSIZES ).
*
* INFO (output) INTEGER
* Error flag. It will be set to zero if no error occurred.
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXTYP, NSUBS
PARAMETER ( MAXTYP = 4, NSUBS = 23 )
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
* ..
* .. Local Scalars ..
LOGICAL RUNTR1, RUNTRD
CHARACTER UPLO
INTEGER I, IC, IINFO, IL, ILWORK, IMODE, IN, INFSOK,
$ IPAR, ISUB, ITYPE, IU, J, J1, J2, J3, J4,
$ LASTL, LDA, LGN, LIWEDC, LIWEVR, LWEDC, LWEVR,
$ M, M11, MM, MMM, MTYPES, N, NANSOK, NB, NSPLIT
DOUBLE PRECISION ABSTOL, EPS1, RLB, RUB, S1, S2, TIME, ULP,
$ ULPINV, UNTIME, VL, VU
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER*4 PNAMES( 4 )
CHARACTER*9 SUBNAM( NSUBS )
INTEGER IDUMMA( 1 ), INPARM( NSUBS ), IOLDSD( 4 ),
$ KMODE( MAXTYP )
* ..
* .. External Functions ..
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DOPLA, DSECND, DOPLA2
EXTERNAL DLAMCH, DOPLA, DSECND, DOPLA2, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL ATIMIN, BISECT, DCOPY, DLACPY, DLASET, DLATMS,
$ DORGTR, DORMTR, DPRTBE, DPTEQR, DSTEBZ, DSTEDC,
$ DSTEGR, DSTEIN, DSTEQR, DSTERF, DSYTRD, IMTQL1,
$ IMTQL2, TINVIT, TQLRAT, TRED1, TRIDIB, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, INT, LOG, MAX, MIN
* ..
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
* .. Data statements ..
DATA SUBNAM / 'DSYTRD', 'DORGTR', 'DORMTR',
$ 'DSTEQR(N)', 'DSTEQR(V)', 'DSTERF',
$ 'DPTEQR(N)', 'DPTEQR(V)', 'DSTEBZ(I)',
$ 'DSTEBZ(V)', 'DSTEIN', 'DSTEDC(N)',
$ 'DSTEDC(I)', 'DSTEDC(V)', 'DSTEGR(N)',
$ 'DSTEGR(V)', 'TRED1', 'IMTQL1', 'IMTQL2',
$ 'TQLRAT', 'TRIDIB', 'BISECT', 'TINVIT' /
DATA INPARM / 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
$ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 /
DATA PNAMES / 'LDA', 'NB', 'bad1', 'bad2' /
DATA KMODE / 4, 3, 1, 5 /
* ..
* .. Executable Statements ..
*
*
* Extract the timing request from the input line.
*
CALL ATIMIN( 'DST', LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
*
* Disable timing of DSTEGR if we're non-IEEE-754 compliant.
*
NANSOK = ILAENV( 10, 'DSTEGR', ' ', 0, 0, 0, 0 )
INFSOK = ILAENV( 11, 'DSTEGR', ' ', 0, 0, 0, 0 )
IF( NANSOK.NE.1 .OR. INFSOK.NE.1 ) THEN
TIMSUB(15) = .FALSE.
TIMSUB(16) = .FALSE.
END IF
*
IF( INFO.NE.0 )
$ RETURN
*
* Check that N <= LDA for the input values.
*
DO 20 J2 = 1, NSIZES
DO 10 J1 = 1, NPARMS
IF( NN( J2 ).GT.LDAS( J1 ) ) THEN
INFO = -8
WRITE( NOUT, FMT = 9999 )LINE( 1: 6 )
9999 FORMAT( 1X, A, ' timing run not attempted -- N > LDA',
$ / )
RETURN
END IF
10 CONTINUE
20 CONTINUE
*
* Check LWORK
*
ILWORK = NSIZES*NPARMS*NTYPES
DO 30 J1 = 1, NPARMS
ILWORK = MAX( ILWORK, 5*LDAS( J1 ),
$ ( NNB( J1 )+2 )*LDAS( J1 ) )
30 CONTINUE
IF( ILWORK.GT.LWORK ) THEN
INFO = -18
WRITE( NOUT, FMT = 9998 )LINE( 1: 6 )
9998 FORMAT( 1X, A, ' timing run not attempted -- LWORK too small.',
$ / )
RETURN
END IF
*
* Check to see whether DSYTRD must be run.
*
* RUNTRD -- if DSYTRD must be run.
*
RUNTRD = .FALSE.
IF( TIMSUB( 4 ) .OR. TIMSUB( 5 ) .OR. TIMSUB( 6 ) .OR.
$ TIMSUB( 7 ) .OR. TIMSUB( 8 ) .OR. TIMSUB( 9 ) .OR.
$ TIMSUB( 10 ) .OR. TIMSUB( 11 ) .OR. TIMSUB( 12 ) .OR.
$ TIMSUB( 13 ) .OR. TIMSUB( 14 ) .OR. TIMSUB( 15 ) .OR.
$ TIMSUB( 16 ) )RUNTRD = .TRUE.
*
* Check to see whether TRED1 must be run.
*
* RUNTR1 -- if TRED1 must be run.
*
RUNTR1 = .FALSE.
IF( TIMSUB( 17 ) .OR. TIMSUB( 18 ) .OR. TIMSUB( 19 ) .OR.
$ TIMSUB( 20 ) .OR. TIMSUB( 21 ) .OR. TIMSUB( 22 ) .OR.
$ TIMSUB( 23 ) )RUNTR1 = .TRUE.
*
* Various Constants
*
ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
ULPINV = ONE / ULP
CALL XLAENV( 9, 25 )
*
* Zero out OPCNTS, TIMES
*
DO 70 J4 = 1, NSUBS
DO 60 J3 = 1, NSIZES
DO 50 J2 = 1, NTYPES
DO 40 J1 = 1, NPARMS
OPCNTS( J1, J2, J3, J4 ) = ZERO
TIMES( J1, J2, J3, J4 ) = ZERO
40 CONTINUE
50 CONTINUE
60 CONTINUE
70 CONTINUE
*
* Do for each value of N:
*
DO 940 IN = 1, NSIZES
*
N = NN( IN )
IF( N.GT.0 ) THEN
LGN = INT( LOG( DBLE( N ) ) / LOG( TWO ) )
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
LWEDC = 1 + 4*N + 2*N*LGN + 3*N**2
LIWEDC = 6 + 6*N + 5*N*LGN
LWEVR = 18*N
LIWEVR = 10*N
ELSE
LWEDC = 8
LIWEDC = 12
LWEVR = 1
LIWEVR = 1
END IF
*
* Do for each .TRUE. value in DOTYPE:
*
MTYPES = MIN( MAXTYP, NTYPES )
IF( NTYPES.EQ.MAXTYP+1 .AND. NSIZES.EQ.1 )
$ MTYPES = NTYPES
DO 930 ITYPE = 1, MTYPES
IF( .NOT.DOTYPE( ITYPE ) )
$ GO TO 930
*
* Save random number seed for error messages
*
DO 80 J = 1, 4
IOLDSD( J ) = ISEED( J )
80 CONTINUE
*
*-----------------------------------------------------------------------
*
* Time the LAPACK Routines
*
* Generate A
*
UPLO = 'L'
IF( ITYPE.LE.MAXTYP ) THEN
IMODE = KMODE( ITYPE )
CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, ULPINV,
$ ONE, N, N, UPLO, A, N, WORK( N+1 ), IINFO )
END IF
*
* Time DSYTRD for each pair NNB(j), LDAS(j)
*
IF( TIMSUB( 1 ) ) THEN
DO 110 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
CALL XLAENV( 1, NB )
CALL XLAENV( 2, 2 )
CALL XLAENV( 3, NB )
*
* Time DSYTRD
*
IC = 0
OPS = ZERO
S1 = DSECND( )
90 CONTINUE
CALL DLACPY( UPLO, N, N, A, N, Z, LDA )
CALL DSYTRD( UPLO, N, Z, LDA, D, E, WORK, WORK( N+1 ),
$ LWORK-N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 1 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 590
END IF
*
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 90
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 100 J = 1, IC
CALL DLACPY( UPLO, N, N, A, N, Z, LDA )
100 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 1 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 1 ) = DOPLA( 'DSYTRD', N, 0,
$ 0, 0, NB )
110 CONTINUE
ELSE
IF( RUNTRD ) THEN
CALL DLACPY( UPLO, N, N, A, N, Z, N )
CALL DSYTRD( UPLO, N, Z, N, D, E, WORK, WORK( N+1 ),
$ LWORK-N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 1 ), IINFO, N,
$ ITYPE, 0, IOLDSD
INFO = ABS( IINFO )
GO TO 590
END IF
END IF
END IF
*
* Time DORGTR for each pair NNB(j), LDAS(j)
*
IF( TIMSUB( 2 ) ) THEN
DO 140 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
CALL XLAENV( 1, NB )
CALL XLAENV( 2, 2 )
CALL XLAENV( 3, NB )
*
* Time DORGTR
*
CALL DLACPY( UPLO, N, N, A, N, Z, LDA )
CALL DSYTRD( UPLO, N, Z, LDA, D, E, WORK, WORK( N+1 ),
$ LWORK-N, IINFO )
IC = 0
OPS = ZERO
S1 = DSECND( )
120 CONTINUE
CALL DLACPY( 'F', N, N, Z, LDA, Z1, LDA )
CALL DORGTR( UPLO, N, Z1, LDA, WORK, WORK( N+1 ),
$ LWORK-N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 2 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 590
END IF
*
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 120
*
* Subtract the time used in DLACPY
*
S1 = DSECND( )
DO 130 J = 1, IC
CALL DLACPY( 'F', N, N, Z, LDA, Z1, LDA )
130 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 2 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 2 ) = DOPLA2( 'DORGTR', UPLO,
$ N, N, N, 0, NB )
140 CONTINUE
END IF
*
* Time DORMTR for each pair NNB(j), LDAS(j)
*
IF( TIMSUB( 3 ) ) THEN
DO 170 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
CALL XLAENV( 1, NB )
CALL XLAENV( 2, 2 )
CALL XLAENV( 3, NB )
*
* Time DORMTR
*
CALL DLACPY( UPLO, N, N, A, N, Z, LDA )
CALL DSYTRD( UPLO, N, Z, LDA, D, E, WORK, WORK( N+1 ),
$ LWORK-N, IINFO )
IC = 0
OPS = ZERO
S1 = DSECND( )
150 CONTINUE
CALL DCOPY( N, D, 1, WORK( LDA+1 ), 1 )
CALL DCOPY( N-1, E, 1, WORK( 2*LDA+1 ), 1 )
CALL DSTEDC( 'N', N, WORK( LDA+1 ), WORK( 2*LDA+1 ),
$ Z1, LDA, WORK( 3*LDA+1 ), LWEDC, IWORK,
$ LIWEDC, IINFO )
CALL DORMTR( 'L', UPLO, 'N', N, N, Z, LDA, WORK, Z1,
$ LDA, WORK( N+1 ), LWORK-N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 3 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 590
END IF
*
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 150
*
* Subtract the time used in DCOPY and DSTEDC
*
S1 = DSECND( )
DO 160 J = 1, IC
CALL DCOPY( N, D, 1, WORK( LDA+1 ), 1 )
CALL DCOPY( N-1, E, 1, WORK( 2*LDA+1 ), 1 )
CALL DSTEDC( 'N', N, WORK( LDA+1 ),
$ WORK( 2*LDA+1 ), Z1, LDA,
$ WORK( 3*LDA+1 ), LWEDC, IWORK, LIWEDC,
$ IINFO )
160 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 3 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 3 ) = DOPLA2( 'DORMTR',
$ UPLO//UPLO, N, N, N, 0, NB )
170 CONTINUE
END IF
*
* Time DSTEQR, SSTERF, DPTEQR, SSTEBZ, SSTEIN, SSTEDC, SSTERV
* for each distinct LDA=LDAS(j)
*
IF( TIMSUB( 4 ) .OR. TIMSUB( 5 ) .OR. TIMSUB( 6 ) .OR.
$ TIMSUB( 7 ) .OR. TIMSUB( 8 ) .OR. TIMSUB( 9 ) .OR.
$ TIMSUB( 10 ) .OR. TIMSUB( 11 ) .OR. TIMSUB( 12 ) .OR.
$ TIMSUB( 13 ) .OR. TIMSUB( 14 ) .OR. TIMSUB( 15 ) .OR.
$ TIMSUB( 16 ) ) THEN
DO 580 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 180 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
180 CONTINUE
IF( LASTL.EQ.0 ) THEN
*
* Time DSTEQR with VECT='N'
*
IF( TIMSUB( 4 ) ) THEN
IC = 0
OPS = ZERO
S1 = DSECND( )
190 CONTINUE
CALL DCOPY( N, D, 1, WORK, 1 )
CALL DCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
CALL DSTEQR( 'N', N, WORK, WORK( LDA+1 ), Z,
$ LDA, WORK( 2*LDA+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 4 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 190
*
* Subtract the time used in DCOPY.
*
S1 = DSECND( )
DO 200 J = 1, IC
CALL DCOPY( N, D, 1, WORK, 1 )
CALL DCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
200 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 4 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 4 ) = OPS / DBLE( IC )
END IF
*
* Time DSTEQR with VECT='V'
*
210 CONTINUE
IF( TIMSUB( 5 ) ) THEN
IC = 0
OPS = ZERO
S1 = DSECND( )
220 CONTINUE
CALL DCOPY( N, D, 1, WORK, 1 )
CALL DCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
CALL DLASET( 'Full', LDA, N, ONE, TWO, Z, LDA )
CALL DSTEQR( 'V', N, WORK, WORK( LDA+1 ), Z,
$ LDA, WORK( 2*LDA+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 5 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 240
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 220
*
* Subtract the time used in DCOPY.
*
S1 = DSECND( )
DO 230 J = 1, IC
CALL DLASET( 'Full', LDA, N, ONE, TWO, Z,
$ LDA )
CALL DCOPY( N, D, 1, WORK, 1 )
CALL DCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
230 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 5 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 5 ) = OPS / DBLE( IC )
END IF
*
* Time DSTERF
*
240 CONTINUE
IF( TIMSUB( 6 ) ) THEN
IC = 0
OPS = ZERO
S1 = DSECND( )
250 CONTINUE
CALL DCOPY( N, D, 1, WORK, 1 )
CALL DCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
CALL DSTERF( N, WORK, WORK( LDA+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 6 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 270
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 250
*
* Subtract the time used in DCOPY.
*
S1 = DSECND( )
DO 260 J = 1, IC
CALL DCOPY( N, D, 1, WORK, 1 )
CALL DCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
260 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 6 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 6 ) = OPS / DBLE( IC )
END IF
*
* Time DPTEQR with VECT='N'
*
270 CONTINUE
IF( TIMSUB( 7 ) ) THEN
*
* Modify the tridiagonal matrix to make it
* positive definite.
E2( 1 ) = ABS( D( 1 ) ) + ABS( E( 1 ) )
DO 280 I = 2, N - 1
E2( I ) = ABS( D( I ) ) + ABS( E( I ) ) +
$ ABS( E( I-1 ) )
280 CONTINUE
E2( N ) = ABS( D( N ) ) + ABS( E( N-1 ) )
IC = 0
OPS = ZERO
S1 = DSECND( )
290 CONTINUE
CALL DCOPY( N, E2, 1, WORK, 1 )
CALL DCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
CALL DPTEQR( 'N', N, WORK, WORK( LDA+1 ), Z,
$ LDA, WORK( 2*LDA+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 7 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 310
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 290
*
* Subtract the time used in DCOPY.
*
S1 = DSECND( )
DO 300 J = 1, IC
CALL DCOPY( N, D, 1, WORK, 1 )
CALL DCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
300 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 7 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 7 ) = OPS / DBLE( IC )
END IF
*
* Time DPTEQR with VECT='V'
*
310 CONTINUE
IF( TIMSUB( 8 ) ) THEN
*
* Modify the tridiagonal matrix to make it
* positive definite.
E2( 1 ) = ABS( D( 1 ) ) + ABS( E( 1 ) )
DO 320 I = 2, N - 1
E2( I ) = ABS( D( I ) ) + ABS( E( I ) ) +
$ ABS( E( I-1 ) )
320 CONTINUE
E2( N ) = ABS( D( N ) ) + ABS( E( N-1 ) )
IC = 0
OPS = ZERO
S1 = DSECND( )
330 CONTINUE
CALL DCOPY( N, E2, 1, WORK, 1 )
CALL DCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
CALL DPTEQR( 'V', N, WORK, WORK( LDA+1 ), Z,
$ LDA, WORK( 2*LDA+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 8 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 350
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 330
*
* Subtract the time used in DCOPY.
*
S1 = DSECND( )
DO 340 J = 1, IC
CALL DCOPY( N, D, 1, WORK, 1 )
CALL DCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
340 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 8 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 8 ) = OPS / DBLE( IC )
END IF
*
* Time DSTEBZ(I)
*
350 CONTINUE
IF( TIMSUB( 9 ) ) THEN
IL = 1
IU = N
ABSTOL = ZERO
IC = 0
OPS = ZERO
S1 = DSECND( )
360 CONTINUE
CALL DSTEBZ( 'I', 'B', N, VL, VU, IL, IU,
$ ABSTOL, D, E, MM, NSPLIT, WORK,
$ IWORK, IWORK( LDA+1 ),
$ WORK( 2*LDA+1 ), IWORK( 2*LDA+1 ),
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 9 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 370
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 360
UNTIME = ZERO
*
TIMES( IPAR, ITYPE, IN, 9 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 9 ) = OPS / DBLE( IC )
END IF
*
* Time DSTEBZ(V)
*
370 CONTINUE
IF( TIMSUB( 10 ) ) THEN
IF( N.EQ.1 ) THEN
VL = D( 1 ) - ABS( D( 1 ) )
VU = D( 1 ) + ABS( D( 1 ) )
ELSE
VL = D( 1 ) - ABS( E( 1 ) )
VU = D( 1 ) + ABS( E( 1 ) )
DO 380 I = 2, N - 1
VL = MIN( VL, D( I )-ABS( E( I ) )-
$ ABS( E( I-1 ) ) )
VU = MAX( VU, D( I )+ABS( E( I ) )+
$ ABS( E( I-1 ) ) )
380 CONTINUE
VL = MIN( VL, D( N )-ABS( E( N-1 ) ) )
VU = MAX( VU, D( N )+ABS( E( N-1 ) ) )
END IF
ABSTOL = ZERO
IC = 0
OPS = ZERO
S1 = DSECND( )
390 CONTINUE
CALL DSTEBZ( 'V', 'B', N, VL, VU, IL, IU,
$ ABSTOL, D, E, MM, NSPLIT, WORK,
$ IWORK, IWORK( LDA+1 ),
$ WORK( 2*LDA+1 ), IWORK( 2*LDA+1 ),
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 10 ),
$ IINFO, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 400
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 390
UNTIME = ZERO
*
TIMES( IPAR, ITYPE, IN, 10 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 10 ) = OPS / DBLE( IC )
END IF
*
* Time DSTEIN
*
400 CONTINUE
IF( TIMSUB( 11 ) ) THEN
IC = 0
OPS = ZERO
S1 = DSECND( )
410 CONTINUE
CALL DSTEIN( N, D, E, MM, WORK, IWORK,
$ IWORK( LDA+1 ), Z, LDA,
$ WORK( LDA+1 ), IWORK( 2*LDA+1 ),
$ IWORK( 3*LDA+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 11 ),
$ IINFO, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 420
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 410
UNTIME = ZERO
*
TIMES( IPAR, ITYPE, IN, 11 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 11 ) = OPS / DBLE( IC )
END IF
*
* Time DSTEDC with COMPQ='N'
*
420 CONTINUE
IF( TIMSUB( 12 ) ) THEN
IC = 0
OPS = ZERO
S1 = DSECND( )
430 CONTINUE
CALL DCOPY( N, D, 1, WORK, 1 )
CALL DCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
CALL DSTEDC( 'N', N, WORK, WORK( LDA+1 ), Z,
$ LDA, WORK( 2*LDA+1 ), LWEDC, IWORK,
$ LIWEDC, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 12 ),
$ IINFO, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 450
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 430
*
* Subtract the time used in DCOPY.
*
S1 = DSECND( )
DO 440 J = 1, IC
CALL DCOPY( N, D, 1, WORK, 1 )
CALL DCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
440 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 12 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 12 ) = OPS / DBLE( IC )
END IF
*
* Time DSTEDC with COMPQ='I'
*
450 CONTINUE
IF( TIMSUB( 13 ) ) THEN
IC = 0
OPS = ZERO
S1 = DSECND( )
460 CONTINUE
CALL DCOPY( N, D, 1, WORK, 1 )
CALL DCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
CALL DLASET( 'Full', LDA, N, ONE, TWO, Z, LDA )
CALL DSTEDC( 'I', N, WORK, WORK( LDA+1 ), Z,
$ LDA, WORK( 2*LDA+1 ), LWEDC, IWORK,
$ LIWEDC, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 13 ),
$ IINFO, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 480
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 460
*
* Subtract the time used in DCOPY.
*
S1 = DSECND( )
DO 470 J = 1, IC
CALL DLASET( 'Full', LDA, N, ONE, TWO, Z,
$ LDA )
CALL DCOPY( N, D, 1, WORK, 1 )
CALL DCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
470 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 13 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 13 ) = OPS / DBLE( IC )
END IF
480 CONTINUE
*
* Time DSTEDC with COMPQ='V'
*
IF( TIMSUB( 14 ) ) THEN
IC = 0
OPS = ZERO
S1 = DSECND( )
490 CONTINUE
CALL DCOPY( N, D, 1, WORK, 1 )
CALL DCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
CALL DLASET( 'Full', LDA, N, ONE, TWO, Z, LDA )
CALL DSTEDC( 'V', N, WORK, WORK( LDA+1 ), Z,
$ LDA, WORK( 2*LDA+1 ), LWEDC, IWORK,
$ LIWEDC, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 14 ),
$ IINFO, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 510
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 490
*
* Subtract the time used in DCOPY.
*
S1 = DSECND( )
DO 500 J = 1, IC
CALL DLASET( 'Full', LDA, N, ONE, TWO, Z,
$ LDA )
CALL DCOPY( N, D, 1, WORK, 1 )
CALL DCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
500 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 14 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 14 ) = OPS / DBLE( IC )
END IF
510 CONTINUE
*
* Time DSTEGR with COMPQ='N'
*
IF( TIMSUB( 15 ) ) THEN
ABSTOL = ZERO
VL = ZERO
VU = ZERO
IL = 1
IU = N
IC = 0
OPS = ZERO
S1 = DSECND( )
520 CONTINUE
CALL DCOPY( N, D, 1, WORK, 1 )
CALL DCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
CALL DSTEGR( 'N', 'A', N, WORK, WORK( LDA+1 ),
$ VL, VU, IL, IU, ABSTOL, M,
$ WORK( 2*LDA+1 ), Z, LDA, IWORK,
$ WORK( 3*LDA+1 ), LWEVR,
$ IWORK( 2*LDA+1 ), LIWEVR, INFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 15 ),
$ IINFO, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 540
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 520
*
* Subtract the time used in DCOPY.
*
S1 = DSECND( )
DO 530 J = 1, IC
CALL DLASET( 'Full', LDA, N, ONE, TWO, Z,
$ LDA )
CALL DCOPY( N, D, 1, WORK, 1 )
CALL DCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
530 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 15 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 15 ) = OPS / DBLE( IC )
END IF
540 CONTINUE
*
* Time DSTEGR with COMPQ='V'
*
IF( TIMSUB( 16 ) ) THEN
ABSTOL = ZERO
VL = ZERO
VU = ZERO
IL = 1
IU = N
IC = 0
OPS = ZERO
S1 = DSECND( )
550 CONTINUE
CALL DCOPY( N, D, 1, WORK, 1 )
CALL DCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
CALL DSTEGR( 'V', 'A', N, WORK, WORK( LDA+1 ),
$ VL, VU, IL, IU, ABSTOL, M,
$ WORK( 2*LDA+1 ), Z, LDA, IWORK,
$ WORK( 3*LDA+1 ), LWEVR,
$ IWORK( 2*LDA+1 ), LIWEVR, INFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 16 ),
$ IINFO, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 570
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 550
*
* Subtract the time used in DCOPY.
*
S1 = DSECND( )
DO 560 J = 1, IC
CALL DLASET( 'Full', LDA, N, ONE, TWO, Z,
$ LDA )
CALL DCOPY( N, D, 1, WORK, 1 )
CALL DCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
560 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 16 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 16 ) = OPS / DBLE( IC )
END IF
570 CONTINUE
*
ELSE
IF( TIMSUB( 4 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 4 ) = OPCNTS( LASTL,
$ ITYPE, IN, 4 )
TIMES( IPAR, ITYPE, IN, 4 ) = TIMES( LASTL,
$ ITYPE, IN, 4 )
END IF
IF( TIMSUB( 5 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 5 ) = OPCNTS( LASTL,
$ ITYPE, IN, 5 )
TIMES( IPAR, ITYPE, IN, 5 ) = TIMES( LASTL,
$ ITYPE, IN, 5 )
END IF
IF( TIMSUB( 6 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 6 ) = OPCNTS( LASTL,
$ ITYPE, IN, 6 )
TIMES( IPAR, ITYPE, IN, 6 ) = TIMES( LASTL,
$ ITYPE, IN, 6 )
END IF
IF( TIMSUB( 7 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 7 ) = OPCNTS( LASTL,
$ ITYPE, IN, 7 )
TIMES( IPAR, ITYPE, IN, 7 ) = TIMES( LASTL,
$ ITYPE, IN, 7 )
END IF
IF( TIMSUB( 8 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 8 ) = OPCNTS( LASTL,
$ ITYPE, IN, 8 )
TIMES( IPAR, ITYPE, IN, 8 ) = TIMES( LASTL,
$ ITYPE, IN, 8 )
END IF
IF( TIMSUB( 9 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 9 ) = OPCNTS( LASTL,
$ ITYPE, IN, 9 )
TIMES( IPAR, ITYPE, IN, 9 ) = TIMES( LASTL,
$ ITYPE, IN, 9 )
END IF
IF( TIMSUB( 10 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 10 ) = OPCNTS( LASTL,
$ ITYPE, IN, 10 )
TIMES( IPAR, ITYPE, IN, 10 ) = TIMES( LASTL,
$ ITYPE, IN, 10 )
END IF
IF( TIMSUB( 11 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 11 ) = OPCNTS( LASTL,
$ ITYPE, IN, 11 )
TIMES( IPAR, ITYPE, IN, 11 ) = TIMES( LASTL,
$ ITYPE, IN, 11 )
END IF
IF( TIMSUB( 12 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 12 ) = OPCNTS( LASTL,
$ ITYPE, IN, 12 )
TIMES( IPAR, ITYPE, IN, 12 ) = TIMES( LASTL,
$ ITYPE, IN, 12 )
END IF
IF( TIMSUB( 13 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 13 ) = OPCNTS( LASTL,
$ ITYPE, IN, 13 )
TIMES( IPAR, ITYPE, IN, 13 ) = TIMES( LASTL,
$ ITYPE, IN, 13 )
END IF
IF( TIMSUB( 14 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 14 ) = OPCNTS( LASTL,
$ ITYPE, IN, 14 )
TIMES( IPAR, ITYPE, IN, 14 ) = TIMES( LASTL,
$ ITYPE, IN, 14 )
END IF
IF( TIMSUB( 15 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 15 ) = OPCNTS( LASTL,
$ ITYPE, IN, 15 )
TIMES( IPAR, ITYPE, IN, 15 ) = TIMES( LASTL,
$ ITYPE, IN, 15 )
END IF
IF( TIMSUB( 16 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 16 ) = OPCNTS( LASTL,
$ ITYPE, IN, 16 )
TIMES( IPAR, ITYPE, IN, 16 ) = TIMES( LASTL,
$ ITYPE, IN, 16 )
END IF
END IF
580 CONTINUE
END IF
590 CONTINUE
*
*-----------------------------------------------------------------------
*
* Time the EISPACK Routines
*
* Skip routines if N <= 0 (EISPACK requirement)
*
IF( N.LE.0 )
$ GO TO 930
*
* Time TRED1 for each LDAS(j)
*
IF( TIMSUB( 17 ) ) THEN
DO 630 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 600 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
600 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time TRED1
*
IC = 0
OPS = ZERO
S1 = DSECND( )
610 CONTINUE
CALL DLACPY( 'L', N, N, A, N, Z, LDA )
CALL TRED1( LDA, N, Z, D, E, E2 )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 610
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 620 J = 1, IC
CALL DLACPY( 'L', N, N, A, N, Z, LDA )
620 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 17 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 17 ) = OPS / DBLE( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 17 ) = OPCNTS( LASTL,
$ ITYPE, IN, 17 )
TIMES( IPAR, ITYPE, IN, 17 ) = TIMES( LASTL, ITYPE,
$ IN, 17 )
END IF
630 CONTINUE
ELSE
IF( RUNTR1 ) THEN
CALL DLACPY( 'L', N, N, A, N, Z, LDA )
CALL TRED1( LDA, N, Z, D, E, E2 )
END IF
END IF
*
* Time IMTQL1 for each LDAS(j)
*
IF( TIMSUB( 18 ) ) THEN
DO 670 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 640 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
640 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time IMTQL1
*
IC = 0
OPS = ZERO
S1 = DSECND( )
650 CONTINUE
CALL DCOPY( N, D, 1, WORK, 1 )
CALL DCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
CALL IMTQL1( N, WORK, WORK( LDA+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 18 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 680
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 650
*
* Subtract the time used in DCOPY.
*
S1 = DSECND( )
DO 660 J = 1, IC
CALL DCOPY( N, D, 1, WORK, 1 )
CALL DCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
660 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 18 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 18 ) = OPS / DBLE( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 18 ) = OPCNTS( LASTL,
$ ITYPE, IN, 18 )
TIMES( IPAR, ITYPE, IN, 18 ) = TIMES( LASTL, ITYPE,
$ IN, 18 )
END IF
670 CONTINUE
END IF
*
* Time IMTQL2 for each LDAS(j)
*
680 CONTINUE
IF( TIMSUB( 19 ) ) THEN
DO 720 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 690 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
690 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time IMTQL2
*
IC = 0
OPS = ZERO
S1 = DSECND( )
700 CONTINUE
CALL DCOPY( N, D, 1, WORK, 1 )
CALL DCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
CALL DLASET( 'Full', N, N, ONE, TWO, Z, LDA )
CALL IMTQL2( LDA, N, WORK, WORK( LDA+1 ), Z,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 19 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 730
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 700
*
* Subtract the time used in DCOPY.
*
S1 = DSECND( )
DO 710 J = 1, IC
CALL DCOPY( N, D, 1, WORK, 1 )
CALL DCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
CALL DLASET( 'Full', N, N, ONE, TWO, Z, LDA )
710 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 19 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 19 ) = OPS / DBLE( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 19 ) = OPCNTS( LASTL,
$ ITYPE, IN, 19 )
TIMES( IPAR, ITYPE, IN, 19 ) = TIMES( LASTL, ITYPE,
$ IN, 19 )
END IF
720 CONTINUE
END IF
*
* Time TQLRAT for each LDAS(j)
*
730 CONTINUE
IF( TIMSUB( 20 ) ) THEN
DO 770 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 740 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
740 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time TQLRAT
*
IC = 0
OPS = ZERO
S1 = DSECND( )
750 CONTINUE
CALL DCOPY( N, D, 1, WORK, 1 )
CALL DCOPY( N-1, E2, 1, WORK( LDA+1 ), 1 )
CALL TQLRAT( N, WORK, WORK( LDA+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 20 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 780
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 750
*
* Subtract the time used in DCOPY.
*
S1 = DSECND( )
DO 760 J = 1, IC
CALL DCOPY( N, D, 1, WORK, 1 )
CALL DCOPY( N-1, E2, 1, WORK( LDA+1 ), 1 )
760 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 20 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 20 ) = OPS / DBLE( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 20 ) = OPCNTS( LASTL,
$ ITYPE, IN, 20 )
TIMES( IPAR, ITYPE, IN, 20 ) = TIMES( LASTL, ITYPE,
$ IN, 20 )
END IF
770 CONTINUE
END IF
*
* Time TRIDIB for each LDAS(j)
*
780 CONTINUE
IF( TIMSUB( 21 ) ) THEN
DO 820 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 790 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
790 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time TRIDIB
*
IC = 0
OPS = ZERO
EPS1 = ZERO
RLB = ZERO
RUB = ZERO
M11 = 1
MM = N
S1 = DSECND( )
800 CONTINUE
CALL DCOPY( N, D, 1, WORK, 1 )
CALL DCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
CALL DCOPY( N-1, E2, 1, WORK( 2*LDA+1 ), 1 )
CALL TRIDIB( N, EPS1, WORK( 1 ), WORK( LDA+1 ),
$ WORK( 2*LDA+1 ), RLB, RUB, M11, MM,
$ WORK( 3*LDA+1 ), IWORK, IINFO,
$ WORK( 4*LDA+1 ), WORK( 5*LDA+1 ) )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 21 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 830
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 800
*
* Subtract the time used in DCOPY.
*
S1 = DSECND( )
DO 810 J = 1, IC
CALL DCOPY( N, D, 1, WORK, 1 )
CALL DCOPY( N-1, E, 1, WORK( LDA+1 ), 1 )
CALL DCOPY( N-1, E2, 1, WORK( 2*LDA+1 ), 1 )
810 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 21 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 21 ) = OPS / DBLE( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 21 ) = OPCNTS( LASTL,
$ ITYPE, IN, 21 )
TIMES( IPAR, ITYPE, IN, 21 ) = TIMES( LASTL, ITYPE,
$ IN, 21 )
END IF
820 CONTINUE
END IF
*
* Time BISECT for each LDAS(j)
*
830 CONTINUE
IF( TIMSUB( 22 ) ) THEN
DO 880 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 840 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
840 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time BISECT
*
VL = D( 1 ) - ABS( E( 2 ) )
VU = D( 1 ) + ABS( E( 2 ) )
DO 850 I = 2, N - 1
VL = MIN( VL, D( I )-ABS( E( I+1 ) )-
$ ABS( E( I ) ) )
VU = MAX( VU, D( I )+ABS( E( I+1 ) )+
$ ABS( E( I ) ) )
850 CONTINUE
VL = MIN( VL, D( N )-ABS( E( N ) ) )
VU = MAX( VU, D( N )+ABS( E( N ) ) )
IC = 0
OPS = ZERO
EPS1 = ZERO
MM = N
MMM = 0
S1 = DSECND( )
860 CONTINUE
CALL DCOPY( N, D, 1, WORK, 1 )
CALL DCOPY( N, E, 1, WORK( LDA+1 ), 1 )
CALL DCOPY( N, E2, 1, WORK( 2*LDA+1 ), 1 )
CALL BISECT( N, EPS1, WORK( 1 ), WORK( LDA+1 ),
$ WORK( 2*LDA+1 ), VL, VU, MM, MMM,
$ WORK( 3*LDA+1 ), IWORK, IINFO,
$ WORK( 4*LDA+1 ), WORK( 5*LDA+1 ) )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 22 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 890
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 860
*
* Subtract the time used in DCOPY.
*
S1 = DSECND( )
DO 870 J = 1, IC
CALL DCOPY( N, D, 1, WORK, 1 )
CALL DCOPY( N, E, 1, WORK( LDA+1 ), 1 )
CALL DCOPY( N, E2, 1, WORK( 2*LDA+1 ), 1 )
870 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 22 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 22 ) = OPS / DBLE( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 22 ) = OPCNTS( LASTL,
$ ITYPE, IN, 22 )
TIMES( IPAR, ITYPE, IN, 22 ) = TIMES( LASTL, ITYPE,
$ IN, 22 )
END IF
880 CONTINUE
END IF
*
* Time TINVIT for each LDAS(j)
*
890 CONTINUE
IF( TIMSUB( 23 ) ) THEN
CALL DCOPY( N, WORK( 3*LDA+1 ), 1, WORK( 1 ), 1 )
DO 920 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 900 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
900 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time TINVIT
*
IC = 0
OPS = ZERO
S1 = DSECND( )
910 CONTINUE
CALL TINVIT( LDA, N, D, E, E2, MMM, WORK, IWORK, Z,
$ IINFO, WORK( LDA+1 ), WORK( 2*LDA+1 ),
$ WORK( 3*LDA+1 ), WORK( 4*LDA+1 ),
$ WORK( 5*LDA+1 ) )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 23 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 930
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 910
UNTIME = ZERO
*
TIMES( IPAR, ITYPE, IN, 23 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 23 ) = OPS / DBLE( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 23 ) = OPCNTS( LASTL,
$ ITYPE, IN, 23 )
TIMES( IPAR, ITYPE, IN, 23 ) = TIMES( LASTL, ITYPE,
$ IN, 23 )
END IF
920 CONTINUE
END IF
*
930 CONTINUE
940 CONTINUE
*
*-----------------------------------------------------------------------
*
* Print a table of results for each timed routine.
*
DO 950 ISUB = 1, NSUBS
IF( TIMSUB( ISUB ) ) THEN
CALL DPRTBE( SUBNAM( ISUB ), MTYPES, DOTYPE, NSIZES, NN,
$ INPARM( ISUB ), PNAMES, NPARMS, LDAS, NNB,
$ IDUMMA, IDUMMA, OPCNTS( 1, 1, 1, ISUB ), LDO1,
$ LDO2, TIMES( 1, 1, 1, ISUB ), LDT1, LDT2, WORK,
$ LLWORK, NOUT )
END IF
950 CONTINUE
*
9997 FORMAT( ' DTIM22: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', ITYPE=', I6, ', IPAR=', I6, ', ISEED=(',
$ 3( I5, ',' ), I5, ')' )
*
RETURN
*
* End of DTIM22
*
END
SUBROUTINE DTIM26( LINE, NSIZES, NN, MM, NTYPES, DOTYPE, NPARMS,
$ NNB, LDAS, TIMMIN, NOUT, ISEED, A, H, U, VT, D,
$ E, TAUP, TAUQ, WORK, LWORK, IWORK, LLWORK,
$ TIMES, LDT1, LDT2, LDT3, OPCNTS, LDO1, LDO2,
$ LDO3, INFO )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER INFO, LDO1, LDO2, LDO3, LDT1, LDT2, LDT3,
$ LWORK, NOUT, NPARMS, NSIZES, NTYPES
DOUBLE PRECISION TIMMIN
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * ), LLWORK( * )
INTEGER ISEED( * ), IWORK( * ), LDAS( * ), MM( * ),
$ NN( * ), NNB( * )
DOUBLE PRECISION A( * ), D( * ), E( * ), H( * ),
$ OPCNTS( LDO1, LDO2, LDO3, * ), TAUP( * ),
$ TAUQ( * ), TIMES( LDT1, LDT2, LDT3, * ),
$ U( * ), VT( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DTIM26 times the LAPACK routines for the DOUBLE PRECISION
* singular value decomposition.
*
* For each N value in NN(1:NSIZES), M value in MM(1:NSIZES),
* and .TRUE. value in DOTYPE(1:NTYPES), a matrix will be generated
* and used to test the selected routines. Thus, NSIZES*(number of
* .TRUE. values in DOTYPE) matrices will be generated.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* On entry, LINE contains the input line which requested
* this routine. This line may contain a subroutine name,
* such as DGEBRD, indicating that only routine SGEBRD will
* be timed, or it may contain a generic name, such as DBD.
* In this case, the rest of the line is scanned for the
* first 11 non-blank characters, corresponding to the eleven
* combinations of subroutine and options:
* LAPACK:
* 1: DGEBRD
* (labeled DGEBRD in the output)
* 2: DBDSQR (singular values only)
* (labeled DBDSQR in the output)
* 3: DBDSQR (singular values and left singular vectors;
* assume original matrix M by N)
* (labeled DBDSQR(L) in the output)
* 4: DBDSQR (singular values and right singular vectors;
* assume original matrix M by N)
* (labeled DBDSQR(R) in the output)
* 5: DBDSQR (singular values and left and right singular
* vectors; assume original matrix M by N)
* (labeled DBDSQR(B) in the output)
* 6: DBDSQR (singular value and multiply square MIN(M,N)
* matrix by transpose of left singular vectors)
* (labeled DBDSQR(V) in the output)
* 7: DGEBRD+DBDSQR (singular values only)
* (labeled LAPSVD in the output)
* 8: DGEBRD+DORGBR+DBDSQR(L) (singular values and min(M,N)
* left singular vectors)
* (labeled LAPSVD(l) in the output)
* 9: DGEBRD+DORGBR+DBDSQR(L) (singular values and M left
* singular vectors)
* (labeled LAPSVD(L) in the output)
* 10: DGEBRD+DORGBR+DBDSQR(R) (singular values and N right
* singular vectors)
* (labeled LAPSVD(R) in the output)
* 11: DGEBRD+DORGBR+DBDSQR(B) (singular values and min(M,N)
* left singular vectors and N
* right singular vectors)
* (labeled LAPSVD(B) in the output)
* 12: DBDSDC (singular values and left and right singular
* vectors; assume original matrix min(M,N) by
* min(M,N))
* (labeled DBDSDC(B) in the output)
* 13: DGESDD (singular values and min(M,N) left singular
* vectors and N right singular vectors if M>=N,
* singular values and M left singular vectors
* and min(M,N) right singular vectors otherwise.)
* (labeled DGESDD(B) in the output)
* LINPACK:
* 14: DSVDC (singular values only) (comparable to 7 above)
* (labeled LINSVD in the output)
* 15: DSVDC (singular values and min(M,N) left singular
* vectors) (comparable to 8 above)
* (labeled LINSVD(l) in the output)
* 16: DSVDC (singular values and M left singular vectors)
* (comparable to 9 above)
* (labeled LINSVD(L) in the output)
* 17: DSVDC (singular values and N right singular vectors)
* (comparable to 10 above)
* (labeled LINSVD(R) in the output)
* 18: DSVDC (singular values and min(M,N) left singular
* vectors and N right singular vectors)
* (comparable to 11 above)
* (labeled LINSVD(B) in the output)
*
* If a character is 'T' or 't', the corresponding routine in
* this path is timed. If the entire line is blank, all the
* routines in the path are timed.
*
* NSIZES (input) INTEGER
* The number of values of N contained in the vector NN.
*
* NN (input) INTEGER array, dimension( NSIZES )
* The numbers of columns of the matrices to be tested. For
* each N value in the array NN, and each .TRUE. value in
* DOTYPE, a matrix A will be generated and used to test the
* routines.
*
* MM (input) INTEGER array, dimension( NSIZES )
* The numbers of rows of the matrices to be tested. For
* each M value in the array MM, and each .TRUE. value in
* DOTYPE, a matrix A will be generated and used to test the
* routines.
*
* NTYPES (input) INTEGER
* The number of types in DOTYPE. Only the first MAXTYP
* elements will be examined. Exception: if NSIZES=1 and
* NTYPES=MAXTYP+1, and DOTYPE=MAXTYP*f,t, then the input
* value of A will be used.
*
* DOTYPE (input) LOGICAL
* If DOTYPE(j) is .TRUE., then a matrix of type j will be
* generated as follows:
* j=1: A = U*D*V where U and V are random orthogonal
* matrices and D has evenly spaced entries 1,...,ULP
* with random signs on the diagonal
* j=2: A = U*D*V where U and V are random orthogonal
* matrices and D has geometrically spaced entries
* 1,...,ULP with random signs on the diagonal
* j=3: A = U*D*V where U and V are random orthogonal
* matrices and D has "clustered" entries
* 1,ULP,...,ULP with random signs on the diagonal
* j=4: A contains uniform random numbers from [-1,1]
* j=5: A is a special nearly bidiagonal matrix, where the
* upper bidiagonal entries are exp(-2*r*log(ULP))
* and the nonbidiagonal entries are r*ULP, where r
* is a uniform random number from [0,1]
*
* NPARMS (input) INTEGER
* The number of values in each of the arrays NNB and LDAS.
* For each matrix A generated according to NN, MM and DOTYPE,
* tests will be run with (NB,,LDA)= (NNB(1), LDAS(1)),...,
* (NNB(NPARMS), LDAS(NPARMS)).
*
* NNB (input) INTEGER array, dimension( NPARMS )
* The values of the blocksize ("NB") to be tested.
*
* LDAS (input) INTEGER array, dimension( NPARMS )
* The values of LDA, the leading dimension of all matrices,
* to be tested.
*
* TIMMIN (input) DOUBLE PRECISION
* The minimum time a subroutine will be timed.
*
* NOUT (input) INTEGER
* If NOUT > 0 then NOUT specifies the unit number
* on which the output will be printed. If NOUT <= 0, no
* output is printed.
*
* ISEED (input/output) INTEGER array, dimension( 4 )
* The random seed used by the random number generator, used
* by the test matrix generator. It is used and updated on
* each call to DTIM26.
*
* A (workspace) DOUBLE PRECISION array,
* dimension( max(NN)*max(LDAS))
* During the testing of DGEBRD, the original dense matrix.
*
* H (workspace) DOUBLE PRECISION array,
* dimension( max(NN)*max(LDAS))
* The Householder vectors used to reduce A to bidiagonal
* form (as returned by DGEBD2.)
*
* U (workspace) DOUBLE PRECISION array,
* dimension( max(NN,MM)*max(LDAS) )
* The left singular vectors of the original matrix.
*
* VT (workspace) DOUBLE PRECISION array,
* dimension( max(NN,MM)*max(LDAS) )
* The right singular vectors of the original matrix.
*
* D (workspace) DOUBLE PRECISION array, dimension( max(NN,MM) )
* Diagonal entries of bidiagonal matrix to which A
* is reduced.
*
* E (workspace) DOUBLE PRECISION array, dimension( max(NN,MM) )
* Offdiagonal entries of bidiagonal matrix to which A
* is reduced.
*
* TAUP (workspace) DOUBLE PRECISION array, dimension( max(NN,MM) )
* The coefficients for the Householder transformations
* applied on the right to reduce A to bidiagonal form.
*
* TAUQ (workspace) DOUBLE PRECISION array, dimension( max(NN,MM) )
* The coefficients for the Householder transformations
* applied on the left to reduce A to bidiagonal form.
*
* WORK (workspace) DOUBLE PRECISION array, dimension( LWORK )
*
* LWORK (input) INTEGER
* Number of elements in WORK. Must be at least
* MAX(6*MIN(M,N),3*MAX(M,N),NSIZES*NPARMS*NTYPES)
*
* IWORK (workspace) INTEGER array, dimension at least 8*min(M,N).
*
* LLWORK (workspace) LOGICAL array, dimension( NPARMS ),
*
* TIMES (output) DOUBLE PRECISION array,
* dimension (LDT1,LDT2,LDT3,NSUBS)
* TIMES(i,j,k,l) will be set to the run time (in seconds) for
* subroutine/path l, with N=NN(k), M=MM(k), matrix type j,
* LDA=LDAS(i), and NBLOCK=NNB(i).
*
* LDT1 (input) INTEGER
* The first dimension of TIMES. LDT1 >= min( 1, NPARMS ).
*
* LDT2 (input) INTEGER
* The second dimension of TIMES. LDT2 >= min( 1, NTYPES ).
*
* LDT3 (input) INTEGER
* The third dimension of TIMES. LDT3 >= min( 1, NSIZES ).
*
* OPCNTS (output) DOUBLE PRECISION array,
* dimension (LDO1,LDO2,LDO3,NSUBS)
* OPCNTS(i,j,k,l) will be set to the number of floating-point
* operations executed by subroutine/path l, with N=NN(k),
* M=MM(k), matrix type j, LDA=LDAS(i), and NBLOCK=NNB(i).
*
* LDO1 (input) INTEGER
* The first dimension of OPCNTS. LDO1 >= min( 1, NPARMS ).
*
* LDO2 (input) INTEGER
* The second dimension of OPCNTS. LDO2 >= min( 1, NTYPES ).
*
* LDO3 (input) INTEGER
* The third dimension of OPCNTS. LDO3 >= min( 1, NSIZES ).
*
* INFO (output) INTEGER
* Error flag. It will be set to zero if no error occurred.
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXTYP, NSUBS
PARAMETER ( MAXTYP = 5, NSUBS = 18 )
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
* ..
* .. Local Scalars ..
LOGICAL RUNBRD, TRNBRD
CHARACTER UPLO
INTEGER IC, IINFO, IMODE, IN, IPAR, ISUB, ITYPE, J, J1,
$ J2, J3, J4, KU, KVT, LASTNL, LDA, LDH, M,
$ MINMN, MTYPES, N, NB
DOUBLE PRECISION CONDS, ESUM, S1, S2, TIME, ULP, ULPINV, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER*4 PNAMES( 2 )
CHARACTER*9 SUBNAM( NSUBS )
INTEGER INPARM( NSUBS ), IOLDSD( 4 ), JDUM( 1 ),
$ KMODE( 3 )
DOUBLE PRECISION DUM( 1 )
* ..
* .. External Functions ..
DOUBLE PRECISION DASUM, DLAMCH, DLARND, DOPLA, DSECND, DOPLA2
EXTERNAL DASUM, DLAMCH, DLARND, DOPLA, DSECND, DOPLA2
* ..
* .. External Subroutines ..
EXTERNAL ATIMIN, DBDSDC, DBDSQR, DCOPY, DGEBRD, DGESDD,
$ DLACPY, DLASET, DLATMR, DLATMS, DORGBR, DPRTBV,
$ DSVDC, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, EXP, LOG, MAX, MIN
* ..
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
* .. Data statements ..
DATA SUBNAM / 'DGEBRD', 'DBDSQR', 'DBDSQR(L)',
$ 'DBDSQR(R)', 'DBDSQR(B)', 'DBDSQR(V)',
$ 'LAPSVD', 'LAPSVD(l)', 'LAPSVD(L)',
$ 'LAPSVD(R)', 'LAPSVD(B)', 'DBDSDC(B)',
$ 'DGESDD(B)', 'LINSVD', 'LINSVD(l)',
$ 'LINSVD(L)', 'LINSVD(R)', 'LINSVD(B)' /
DATA INPARM / 2, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 1, 2,
$ 1, 1, 1, 1, 1 /
DATA PNAMES / 'LDA', 'NB' /
DATA KMODE / 4, 3, 1 /
* ..
* .. Executable Statements ..
*
*
* Extract the timing request from the input line.
*
CALL ATIMIN( 'DBD', LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ RETURN
*
* Check LWORK and
* Check that N <= LDA and M <= LDA for the input values.
*
DO 20 J2 = 1, NSIZES
IF( LWORK.LT.MAX( 6*MIN( MM( J2 ), NN( J2 ) ), 3*MAX( MM( J2 ),
$ NN( J2 ) ), NSIZES*NPARMS*NTYPES ) ) THEN
INFO = -22
WRITE( NOUT, FMT = 9999 )LINE( 1: 6 )
RETURN
END IF
DO 10 J1 = 1, NPARMS
IF( MAX( NN( J2 ), MM( J2 ) ).GT.LDAS( J1 ) ) THEN
INFO = -9
WRITE( NOUT, FMT = 9999 )LINE( 1: 6 )
9999 FORMAT( 1X, A, ' timing run not attempted', / )
RETURN
END IF
10 CONTINUE
20 CONTINUE
*
* Check to see whether DGEBRD must be run.
*
* RUNBRD -- if DGEBRD must be run without timing.
* TRNBRD -- if DGEBRD must be run with timing.
*
RUNBRD = .FALSE.
TRNBRD = .FALSE.
IF( TIMSUB( 2 ) .OR. TIMSUB( 3 ) .OR. TIMSUB( 4 ) .OR.
$ TIMSUB( 5 ) .OR. TIMSUB( 6 ) )RUNBRD = .TRUE.
IF( TIMSUB( 1 ) )
$ RUNBRD = .FALSE.
IF( TIMSUB( 7 ) .OR. TIMSUB( 8 ) .OR. TIMSUB( 9 ) .OR.
$ TIMSUB( 10 ) .OR. TIMSUB( 11 ) )TRNBRD = .TRUE.
*
* Various Constants
*
ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
ULPINV = ONE / ULP
CALL XLAENV( 9, 25 )
*
* Zero out OPCNTS, TIMES
*
DO 60 J4 = 1, NSUBS
DO 50 J3 = 1, NSIZES
DO 40 J2 = 1, NTYPES
DO 30 J1 = 1, NPARMS
OPCNTS( J1, J2, J3, J4 ) = ZERO
TIMES( J1, J2, J3, J4 ) = ZERO
30 CONTINUE
40 CONTINUE
50 CONTINUE
60 CONTINUE
*
* Do for each value of N:
*
DO 750 IN = 1, NSIZES
*
N = NN( IN )
M = MM( IN )
MINMN = MIN( M, N )
IF( M.GE.N ) THEN
UPLO = 'U'
KU = MINMN
KVT = MAX( MINMN-1, 0 )
ELSE
UPLO = 'L'
KU = MAX( MINMN-1, 0 )
KVT = MINMN
END IF
*
* Do for each .TRUE. value in DOTYPE:
*
MTYPES = MIN( MAXTYP, NTYPES )
IF( NTYPES.EQ.MAXTYP+1 .AND. NSIZES.EQ.1 )
$ MTYPES = NTYPES
DO 740 ITYPE = 1, MTYPES
IF( .NOT.DOTYPE( ITYPE ) )
$ GO TO 740
*
* Save random number seed for error messages
*
DO 70 J = 1, 4
IOLDSD( J ) = ISEED( J )
70 CONTINUE
*
*-----------------------------------------------------------------------
*
* Time the LAPACK Routines
*
* Generate A
*
IF( ITYPE.LE.MAXTYP ) THEN
IF( ITYPE.GE.1 .AND. ITYPE.LE.3 ) THEN
IMODE = KMODE( ITYPE )
CALL DLATMS( M, N, 'U', ISEED, 'N', D, IMODE, ULPINV,
$ ONE, M, N, 'N', A, M, WORK, INFO )
ELSE IF( ITYPE.GE.4 .AND. ITYPE.LE.5 ) THEN
IF( ITYPE.EQ.4 )
$ CONDS = -ONE
IF( ITYPE.EQ.5 )
$ CONDS = ULP
CALL DLATMR( M, N, 'S', ISEED, 'N', D, 6, ZERO, ONE,
$ 'T', 'N', D, 0, ONE, D, 0, ONE, 'N',
$ JDUM, M, N, ZERO, CONDS, 'N', A, M, JDUM,
$ INFO )
IF( ITYPE.EQ.5 ) THEN
CONDS = -TWO*LOG( ULP )
DO 80 J = 1, ( MINMN-1 )*M + MINMN, M + 1
A( J ) = EXP( CONDS*DLARND( 1, ISEED ) )
80 CONTINUE
IF( M.GE.N ) THEN
DO 90 J = M + 1, ( MINMN-1 )*M + MINMN - 1,
$ M + 1
A( J ) = EXP( CONDS*DLARND( 1, ISEED ) )
90 CONTINUE
ELSE
DO 100 J = 2, ( MINMN-2 )*M + MINMN, M + 1
A( J ) = EXP( CONDS*DLARND( 1, ISEED ) )
100 CONTINUE
END IF
END IF
END IF
END IF
*
* Time DGEBRD for each pair NNB(j), LDAS(j)
*
IF( TIMSUB( 1 ) .OR. TRNBRD ) THEN
DO 130 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
CALL XLAENV( 1, NB )
CALL XLAENV( 2, 2 )
CALL XLAENV( 3, NB )
*
* Time DGEBRD
*
IC = 0
OPS = ZERO
S1 = DSECND( )
110 CONTINUE
CALL DLACPY( 'Full', M, N, A, M, H, LDA )
CALL DGEBRD( M, N, H, LDA, D, E, TAUQ, TAUP, WORK,
$ LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 1 ), IINFO, M, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
*
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 110
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 120 J = 1, IC
CALL DLACPY( 'Full', M, N, A, M, U, LDA )
120 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 1 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 1 ) = DOPLA( 'DGEBRD', M, N,
$ 0, 0, NB )
130 CONTINUE
LDH = LDA
ELSE
IF( RUNBRD ) THEN
CALL DLACPY( 'Full', M, N, A, M, H, M )
CALL DGEBRD( M, N, H, M, D, E, TAUQ, TAUP, WORK,
$ LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 1 ), IINFO, M, N,
$ ITYPE, 0, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
LDH = M
END IF
END IF
*
* Time DBDSQR (singular values only) for each pair
* NNB(j), LDAS(j)
*
IF( TIMSUB( 2 ) .OR. TIMSUB( 7 ) ) THEN
DO 170 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
*
* If this value of LDA has been used before, just
* use that value
*
LASTNL = 0
DO 140 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTNL = J
140 CONTINUE
*
IF( LASTNL.EQ.0 ) THEN
*
* Time DBDSQR (singular values only)
*
IC = 0
OPS = ZERO
S1 = DSECND( )
150 CONTINUE
CALL DCOPY( MINMN, D, 1, WORK, 1 )
CALL DCOPY( MINMN-1, E, 1, WORK( MINMN+1 ), 1 )
CALL DBDSQR( UPLO, MINMN, 0, 0, 0, WORK,
$ WORK( MINMN+1 ), VT, LDA, U, LDA, U,
$ LDA, WORK( 2*MINMN+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 2 ), IINFO, M,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 150
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 160 J = 1, IC
CALL DCOPY( MINMN, D, 1, WORK, 1 )
CALL DCOPY( MINMN-1, E, 1, WORK( MINMN+1 ), 1 )
160 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 2 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 2 ) = OPS / DBLE( IC )
*
ELSE
*
TIMES( IPAR, ITYPE, IN, 2 ) = TIMES( LASTNL, ITYPE,
$ IN, 2 )
OPCNTS( IPAR, ITYPE, IN, 2 ) = OPCNTS( LASTNL,
$ ITYPE, IN, 2 )
END IF
170 CONTINUE
END IF
*
* Time DBDSQR (singular values and left singular vectors,
* assume original matrix square) for each pair NNB(j), LDAS(j)
*
IF( TIMSUB( 3 ) .OR. TIMSUB( 8 ) .OR. TIMSUB( 9 ) ) THEN
DO 210 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
*
* If this value of LDA has been used before, just
* use that value
*
LASTNL = 0
DO 180 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTNL = J
180 CONTINUE
*
IF( LASTNL.EQ.0 ) THEN
*
* Time DBDSQR (singular values and left singular
* vectors, assume original matrix square)
*
IC = 0
OPS = ZERO
S1 = DSECND( )
190 CONTINUE
CALL DLASET( 'Full', M, MINMN, ONE, TWO, U, LDA )
CALL DCOPY( MINMN, D, 1, WORK, 1 )
CALL DCOPY( MINMN-1, E, 1, WORK( MINMN+1 ), 1 )
CALL DBDSQR( UPLO, MINMN, 0, M, 0, WORK,
$ WORK( MINMN+1 ), VT, LDA, U, LDA, U,
$ LDA, WORK( 2*MINMN+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 3 ), IINFO, M,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 190
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 200 J = 1, IC
CALL DLASET( 'Full', M, MINMN, ONE, TWO, U,
$ LDA )
CALL DCOPY( MINMN, D, 1, WORK, 1 )
CALL DCOPY( MINMN-1, E, 1, WORK( MINMN+1 ), 1 )
200 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 3 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 3 ) = OPS / DBLE( IC )
*
ELSE
*
TIMES( IPAR, ITYPE, IN, 3 ) = TIMES( LASTNL, ITYPE,
$ IN, 3 )
OPCNTS( IPAR, ITYPE, IN, 3 ) = OPCNTS( LASTNL,
$ ITYPE, IN, 3 )
END IF
210 CONTINUE
END IF
*
* Time DBDSQR (singular values and right singular vectors,
* assume original matrix square) for each pair NNB(j), LDAS(j)
*
IF( TIMSUB( 4 ) .OR. TIMSUB( 10 ) ) THEN
DO 250 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
*
* If this value of LDA has been used before, just
* use that value
*
LASTNL = 0
DO 220 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTNL = J
220 CONTINUE
*
IF( LASTNL.EQ.0 ) THEN
*
* Time DBDSQR (singular values and right singular
* vectors, assume original matrix square)
*
IC = 0
OPS = ZERO
S1 = DSECND( )
230 CONTINUE
CALL DLASET( 'Full', MINMN, N, ONE, TWO, VT, LDA )
CALL DCOPY( MINMN, D, 1, WORK, 1 )
CALL DCOPY( MINMN-1, E, 1, WORK( MINMN+1 ), 1 )
CALL DBDSQR( UPLO, MINMN, N, 0, 0, WORK,
$ WORK( MINMN+1 ), VT, LDA, U, LDA, U,
$ LDA, WORK( 2*MINMN+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 4 ), IINFO, M,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 230
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 240 J = 1, IC
CALL DLASET( 'Full', MINMN, N, ONE, TWO, VT,
$ LDA )
CALL DCOPY( MINMN, D, 1, WORK, 1 )
CALL DCOPY( MINMN-1, E, 1, WORK( MINMN+1 ), 1 )
240 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 4 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 4 ) = OPS / DBLE( IC )
*
ELSE
*
TIMES( IPAR, ITYPE, IN, 4 ) = TIMES( LASTNL, ITYPE,
$ IN, 4 )
OPCNTS( IPAR, ITYPE, IN, 4 ) = OPCNTS( LASTNL,
$ ITYPE, IN, 4 )
END IF
250 CONTINUE
END IF
*
* Time DBDSQR (singular values and left and right singular
* vectors,assume original matrix square) for each pair
* NNB(j), LDAS(j)
*
IF( TIMSUB( 5 ) .OR. TIMSUB( 11 ) ) THEN
DO 290 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
*
* If this value of LDA has been used before, just
* use that value
*
LASTNL = 0
DO 260 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTNL = J
260 CONTINUE
*
IF( LASTNL.EQ.0 ) THEN
*
* Time DBDSQR (singular values and left and right
* singular vectors, assume original matrix square)
*
IC = 0
OPS = ZERO
S1 = DSECND( )
270 CONTINUE
CALL DLASET( 'Full', MINMN, N, ONE, TWO, VT, LDA )
CALL DLASET( 'Full', M, MINMN, ONE, TWO, U, LDA )
CALL DCOPY( MINMN, D, 1, WORK, 1 )
CALL DCOPY( MINMN-1, E, 1, WORK( MINMN+1 ), 1 )
CALL DBDSQR( UPLO, MINMN, N, M, 0, WORK,
$ WORK( MINMN+1 ), VT, LDA, U, LDA, U,
$ LDA, WORK( 2*MINMN+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 5 ), IINFO, M,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 270
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 280 J = 1, IC
CALL DLASET( 'Full', MINMN, N, ONE, TWO, VT,
$ LDA )
CALL DLASET( 'Full', M, MINMN, ONE, TWO, U,
$ LDA )
CALL DCOPY( MINMN, D, 1, WORK, 1 )
CALL DCOPY( MINMN-1, E, 1, WORK( MINMN+1 ), 1 )
280 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 5 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 5 ) = OPS / DBLE( IC )
*
ELSE
*
TIMES( IPAR, ITYPE, IN, 5 ) = TIMES( LASTNL, ITYPE,
$ IN, 5 )
OPCNTS( IPAR, ITYPE, IN, 5 ) = OPCNTS( LASTNL,
$ ITYPE, IN, 5 )
END IF
290 CONTINUE
END IF
*
* Time DBDSQR (singular values and multiply square matrix
* by transpose of left singular vectors) for each pair
* NNB(j), LDAS(j)
*
IF( TIMSUB( 6 ) ) THEN
DO 330 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
*
* If this value of LDA has been used before, just
* use that value
*
LASTNL = 0
DO 300 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTNL = J
300 CONTINUE
*
IF( LASTNL.EQ.0 ) THEN
*
* Time DBDSQR (singular values and multiply square
* matrix by transpose of left singular vectors)
*
IC = 0
OPS = ZERO
S1 = DSECND( )
310 CONTINUE
CALL DLASET( 'Full', MINMN, MINMN, ONE, TWO, U,
$ LDA )
CALL DCOPY( MINMN, D, 1, WORK, 1 )
CALL DCOPY( MINMN-1, E, 1, WORK( MINMN+1 ), 1 )
CALL DBDSQR( UPLO, MINMN, 0, 0, MINMN, WORK,
$ WORK( MINMN+1 ), VT, LDA, U, LDA, U,
$ LDA, WORK( 2*MINMN+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 6 ), IINFO, M,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 310
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 320 J = 1, IC
CALL DLASET( 'Full', MINMN, MINMN, ONE, TWO, U,
$ LDA )
CALL DCOPY( MINMN, D, 1, WORK, 1 )
CALL DCOPY( MINMN-1, E, 1, WORK( MINMN+1 ), 1 )
320 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 6 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 6 ) = OPS / DBLE( IC )
*
ELSE
*
TIMES( IPAR, ITYPE, IN, 6 ) = TIMES( LASTNL, ITYPE,
$ IN, 6 )
OPCNTS( IPAR, ITYPE, IN, 6 ) = OPCNTS( LASTNL,
$ ITYPE, IN, 6 )
END IF
330 CONTINUE
END IF
*
* Time DGEBRD+DBDSQR (singular values only) for each pair
* NNB(j), LDAS(j)
* Use previously computed timings for DGEBRD & DBDSQR
*
IF( TIMSUB( 7 ) ) THEN
DO 340 IPAR = 1, NPARMS
TIMES( IPAR, ITYPE, IN, 7 ) = TIMES( IPAR, ITYPE, IN,
$ 1 ) + TIMES( IPAR, ITYPE, IN, 2 )
OPCNTS( IPAR, ITYPE, IN, 7 ) = OPCNTS( IPAR, ITYPE,
$ IN, 1 ) + OPCNTS( IPAR, ITYPE, IN, 2 )
340 CONTINUE
END IF
*
* Time DGEBRD+DORGBR+DBDSQR (singular values and min(M,N)
* left singular vectors) for each pair NNB(j), LDAS(j)
*
* Use previously computed timings for DGEBRD & DBDSQR
*
IF( TIMSUB( 8 ) ) THEN
DO 370 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
CALL XLAENV( 1, NB )
CALL XLAENV( 2, 2 )
CALL XLAENV( 3, NB )
*
* Time DGEBRD+DORGBR+DBDSQR (singular values and
* min(M,N) left singular vectors)
*
IC = 0
OPS = ZERO
S1 = DSECND( )
350 CONTINUE
CALL DLACPY( 'L', M, MINMN, H, LDH, U, LDA )
CALL DORGBR( 'Q', M, MINMN, KU, U, LDA, TAUQ, WORK,
$ LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 8 ), IINFO, M, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 350
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 360 J = 1, IC
CALL DLACPY( 'L', M, MINMN, H, LDH, U, LDA )
360 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 8 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC ) + TIMES( IPAR, ITYPE, IN, 1 ) +
$ TIMES( IPAR, ITYPE, IN, 3 )
OPCNTS( IPAR, ITYPE, IN, 8 ) = DOPLA2( 'DORGBR', 'Q',
$ M, MINMN, KU, 0, NB ) + OPCNTS( IPAR, ITYPE, IN,
$ 1 ) + OPCNTS( IPAR, ITYPE, IN, 3 )
370 CONTINUE
END IF
*
* Time DGEBRD+DORGBR+DBDSQR (singular values and M
* left singular vectors) for each pair NNB(j), LDAS(j)
*
* Use previously computed timings for DGEBRD & DBDSQR
*
IF( TIMSUB( 9 ) ) THEN
DO 400 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
CALL XLAENV( 1, NB )
CALL XLAENV( 2, 2 )
CALL XLAENV( 3, NB )
*
* Time DGEBRD+DORGBR+DBDSQR (singular values and
* M left singular vectors)
*
IC = 0
OPS = ZERO
S1 = DSECND( )
380 CONTINUE
CALL DLACPY( 'L', M, MINMN, H, LDH, U, LDA )
CALL DORGBR( 'Q', M, M, KU, U, LDA, TAUQ, WORK, LWORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 9 ), IINFO, M, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 380
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 390 J = 1, IC
CALL DLACPY( 'L', M, MINMN, H, LDH, U, LDA )
390 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 9 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC ) + TIMES( IPAR, ITYPE, IN, 1 ) +
$ TIMES( IPAR, ITYPE, IN, 3 )
OPCNTS( IPAR, ITYPE, IN, 9 ) = DOPLA2( 'DORGBR', 'Q',
$ M, M, KU, 0, NB ) + OPCNTS( IPAR, ITYPE, IN, 1 ) +
$ OPCNTS( IPAR, ITYPE, IN, 3 )
400 CONTINUE
END IF
*
* Time DGEBRD+DORGBR+DBDSQR (singular values and N
* right singular vectors) for each pair NNB(j), LDAS(j)
*
* Use previously computed timings for DGEBRD & DBDSQR
*
IF( TIMSUB( 10 ) ) THEN
DO 430 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
CALL XLAENV( 1, NB )
CALL XLAENV( 2, 2 )
CALL XLAENV( 3, NB )
*
* Time DGEBRD+DORGBR+DBDSQR (singular values and
* N right singular vectors)
*
IC = 0
OPS = ZERO
S1 = DSECND( )
410 CONTINUE
CALL DLACPY( 'U', MINMN, N, H, LDH, VT, LDA )
CALL DORGBR( 'P', N, N, KVT, VT, LDA, TAUP, WORK,
$ LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 10 ), IINFO, M,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 410
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 420 J = 1, IC
CALL DLACPY( 'U', MINMN, N, H, LDH, VT, LDA )
420 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 10 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC ) + TIMES( IPAR, ITYPE, IN, 1 ) +
$ TIMES( IPAR, ITYPE, IN, 4 )
OPCNTS( IPAR, ITYPE, IN, 10 ) = DOPLA2( 'DORGBR', 'P',
$ N, N, KVT, 0, NB ) + OPCNTS( IPAR, ITYPE, IN, 1 ) +
$ OPCNTS( IPAR, ITYPE, IN, 4 )
430 CONTINUE
END IF
*
* Time DGEBRD+DORGBR+DBDSQR (singular values and min(M,N) left
* singular vectors and N right singular vectors) for each pair
* NNB(j), LDAS(j)
*
* Use previously computed timings for DGEBRD & DBDSQR
*
IF( TIMSUB( 11 ) ) THEN
DO 460 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
CALL XLAENV( 1, NB )
CALL XLAENV( 2, 2 )
CALL XLAENV( 3, NB )
*
* Time DGEBRD+DORGBR+DBDSQR (singular values and
* min(M,N) left singular vectors and N right singular
* vectors)
*
IC = 0
OPS = ZERO
S1 = DSECND( )
440 CONTINUE
CALL DLACPY( 'L', M, MINMN, H, LDH, U, LDA )
CALL DORGBR( 'Q', M, MINMN, KU, U, LDA, TAUQ, WORK,
$ LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 11 ), IINFO, M,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
CALL DLACPY( 'U', MINMN, N, H, LDH, VT, LDA )
CALL DORGBR( 'P', N, N, KVT, VT, LDA, TAUP, WORK,
$ LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 11 ), IINFO, M,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 440
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 450 J = 1, IC
CALL DLACPY( 'L', MINMN, MINMN, H, LDH, VT, LDA )
450 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 11 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC ) + TIMES( IPAR, ITYPE, IN, 1 ) +
$ TIMES( IPAR, ITYPE, IN, 5 )
OPCNTS( IPAR, ITYPE, IN, 11 ) = DOPLA2( 'DORGBR', 'Q',
$ M, MINMN, KU, 0, NB ) + DOPLA2( 'DORGBR', 'P', N,
$ N, KVT, 0, NB ) + OPCNTS( IPAR, ITYPE, IN, 1 ) +
$ OPCNTS( IPAR, ITYPE, IN, 5 )
460 CONTINUE
END IF
*
* Time DBDSDC (singular values and left and right singular
* vectors,assume original matrix square) for each pair
* NNB(j), LDAS(j)
*
IF( TIMSUB( 12 ) ) THEN
ESUM = DASUM( MINMN-1, E, 1 )
IF( ESUM.EQ.ZERO ) THEN
CALL DLACPY( 'Full', M, N, A, M, H, M )
CALL DGEBRD( M, N, H, M, D, E, TAUQ, TAUP, WORK,
$ LWORK, IINFO )
END IF
DO 500 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
*
* If this value of LDA has been used before, just
* use that value
*
LASTNL = 0
DO 470 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTNL = J
470 CONTINUE
*
IF( LASTNL.EQ.0 ) THEN
*
* Time DBDSDC (singular values and left and right
* singular vectors, assume original matrix square).
*
IC = 0
OPS = ZERO
S1 = DSECND( )
480 CONTINUE
CALL DCOPY( MINMN, D, 1, WORK, 1 )
CALL DCOPY( MINMN-1, E, 1, WORK( MINMN+1 ), 1 )
CALL DBDSDC( UPLO, 'I', MINMN, WORK,
$ WORK( MINMN+1 ), U, LDA, VT, LDA, DUM,
$ JDUM, WORK( 2*MINMN+1 ), IWORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 12 ), IINFO,
$ M, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 480
*
* Subtract the time used in DCOPY.
*
S1 = DSECND( )
DO 490 J = 1, IC
CALL DCOPY( MINMN, D, 1, WORK, 1 )
CALL DCOPY( MINMN-1, E, 1, WORK( MINMN+1 ), 1 )
490 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 12 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 12 ) = OPS / DBLE( IC )
*
ELSE
*
TIMES( IPAR, ITYPE, IN, 12 ) = TIMES( LASTNL,
$ ITYPE, IN, 12 )
OPCNTS( IPAR, ITYPE, IN, 12 ) = OPCNTS( LASTNL,
$ ITYPE, IN, 12 )
END IF
500 CONTINUE
END IF
*
* Time DGESDD( singular values and min(M,N) left singular
* vectors and N right singular vectors when M>=N,
* singular values and M left singular vectors and min(M,N)
* right singular vectors otherwise) for each pair
* NNB(j), LDAS(j)
*
IF( TIMSUB( 13 ) ) THEN
DO 530 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = MIN( N, NNB( IPAR ) )
CALL XLAENV( 1, NB )
CALL XLAENV( 2, 2 )
CALL XLAENV( 3, NB )
*
* Time DGESDD(singular values and min(M,N) left singular
* vectors and N right singular vectors when M>=N;
* singular values and M left singular vectors and
* min(M,N) right singular vectors)
*
IC = 0
OPS = ZERO
S1 = DSECND( )
510 CONTINUE
CALL DLACPY( 'Full', M, N, A, M, H, LDA )
CALL DGESDD( 'S', M, N, H, LDA, WORK, U, LDA, VT, LDA,
$ WORK( MINMN+1 ), LWORK-MINMN, IWORK,
$ IINFO )
S2 = DSECND( )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 13 ), IINFO, M,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 510
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 520 J = 1, IC
CALL DLACPY( 'Full', M, N, A, M, H, LDA )
520 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 13 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 13 ) = OPS / DBLE( IC )
530 CONTINUE
END IF
*
* Time DSVDC (singular values only) for each pair
* NNB(j), LDAS(j)
*
IF( TIMSUB( 14 ) ) THEN
DO 570 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has been used before, just
* use that value
*
LASTNL = 0
DO 540 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTNL = J
540 CONTINUE
*
IF( LASTNL.EQ.0 ) THEN
*
* Time DSVDC (singular values only)
*
IC = 0
OPS = ZERO
S1 = DSECND( )
550 CONTINUE
CALL DLACPY( 'Full', M, N, A, M, H, LDA )
CALL DSVDC( H, LDA, M, N, D, E, U, LDA, VT, LDA,
$ WORK, 0, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 14 ), IINFO,
$ M, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 550
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 560 J = 1, IC
CALL DLACPY( 'Full', M, N, A, M, H, LDA )
560 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 14 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 14 ) = OPS / DBLE( IC )
*
ELSE
*
TIMES( IPAR, ITYPE, IN, 14 ) = TIMES( LASTNL,
$ ITYPE, IN, 14 )
OPCNTS( IPAR, ITYPE, IN, 14 ) = OPCNTS( LASTNL,
$ ITYPE, IN, 14 )
END IF
570 CONTINUE
END IF
*
* Time DSVDC (singular values and min(M,N) left singular
* vectors) for each pair NNB(j), LDAS(j)
*
IF( TIMSUB( 15 ) ) THEN
DO 610 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has been used before, just
* use that value
*
LASTNL = 0
DO 580 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTNL = J
580 CONTINUE
*
IF( LASTNL.EQ.0 ) THEN
*
* Time DSVDC (singular values and min(M,N) left
* singular vectors)
*
IC = 0
OPS = ZERO
S1 = DSECND( )
590 CONTINUE
CALL DLACPY( 'Full', M, N, A, M, H, LDA )
CALL DSVDC( H, LDA, M, N, D, E, U, LDA, VT, LDA,
$ WORK, 20, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 15 ), IINFO,
$ M, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 590
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 600 J = 1, IC
CALL DLACPY( 'Full', M, N, A, M, H, LDA )
600 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 15 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 15 ) = OPS / DBLE( IC )
*
ELSE
*
TIMES( IPAR, ITYPE, IN, 15 ) = TIMES( LASTNL,
$ ITYPE, IN, 15 )
OPCNTS( IPAR, ITYPE, IN, 15 ) = OPCNTS( LASTNL,
$ ITYPE, IN, 15 )
END IF
610 CONTINUE
END IF
*
* Time DSVDC (singular values and M left singular
* vectors) for each pair NNB(j), LDAS(j)
*
IF( TIMSUB( 16 ) ) THEN
DO 650 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has been used before, just
* use that value
*
LASTNL = 0
DO 620 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTNL = J
620 CONTINUE
*
IF( LASTNL.EQ.0 ) THEN
*
* Time DSVDC (singular values and M left singular
* vectors)
*
IC = 0
OPS = ZERO
S1 = DSECND( )
630 CONTINUE
CALL DLACPY( 'Full', M, N, A, M, H, LDA )
CALL DSVDC( H, LDA, M, N, D, E, U, LDA, VT, LDA,
$ WORK, 10, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 16 ), IINFO,
$ M, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 630
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 640 J = 1, IC
CALL DLACPY( 'Full', M, N, A, M, H, LDA )
640 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 16 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 16 ) = OPS / DBLE( IC )
*
ELSE
*
TIMES( IPAR, ITYPE, IN, 16 ) = TIMES( LASTNL,
$ ITYPE, IN, 16 )
OPCNTS( IPAR, ITYPE, IN, 16 ) = OPCNTS( LASTNL,
$ ITYPE, IN, 16 )
END IF
650 CONTINUE
END IF
*
* Time DSVDC (singular values and N right singular
* vectors) for each pair NNB(j), LDAS(j)
*
IF( TIMSUB( 17 ) ) THEN
DO 690 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has been used before, just
* use that value
*
LASTNL = 0
DO 660 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTNL = J
660 CONTINUE
*
IF( LASTNL.EQ.0 ) THEN
*
* Time DSVDC (singular values and N right singular
* vectors)
*
IC = 0
OPS = ZERO
S1 = DSECND( )
670 CONTINUE
CALL DLACPY( 'Full', M, N, A, M, H, LDA )
CALL DSVDC( H, LDA, M, N, D, E, U, LDA, VT, LDA,
$ WORK, 1, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 17 ), IINFO,
$ M, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 670
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 680 J = 1, IC
CALL DLACPY( 'Full', M, N, A, M, H, LDA )
680 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 17 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 17 ) = OPS / DBLE( IC )
*
ELSE
*
TIMES( IPAR, ITYPE, IN, 17 ) = TIMES( LASTNL,
$ ITYPE, IN, 17 )
OPCNTS( IPAR, ITYPE, IN, 17 ) = OPCNTS( LASTNL,
$ ITYPE, IN, 17 )
END IF
690 CONTINUE
END IF
*
* Time DSVDC (singular values and min(M,N) left singular
* vectors and N right singular vectors) for each pair
* NNB(j), LDAS(j)
*
IF( TIMSUB( 18 ) ) THEN
DO 730 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
*
* If this value of LDA has been used before, just
* use that value
*
LASTNL = 0
DO 700 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTNL = J
700 CONTINUE
*
IF( LASTNL.EQ.0 ) THEN
*
* Time DSVDC (singular values and min(M,N) left
* singular vectors and N right singular vectors)
*
IC = 0
OPS = ZERO
S1 = DSECND( )
710 CONTINUE
CALL DLACPY( 'Full', M, N, A, M, H, LDA )
CALL DSVDC( H, LDA, M, N, D, E, U, LDA, VT, LDA,
$ WORK, 21, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )SUBNAM( 18 ), IINFO,
$ M, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 740
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 710
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 720 J = 1, IC
CALL DLACPY( 'Full', M, N, A, M, H, LDA )
720 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 18 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 18 ) = OPS / DBLE( IC )
*
ELSE
*
TIMES( IPAR, ITYPE, IN, 18 ) = TIMES( LASTNL,
$ ITYPE, IN, 18 )
OPCNTS( IPAR, ITYPE, IN, 18 ) = OPCNTS( LASTNL,
$ ITYPE, IN, 18 )
END IF
730 CONTINUE
END IF
*
740 CONTINUE
750 CONTINUE
*
*-----------------------------------------------------------------------
*
* Print a table of results for each timed routine.
*
DO 760 ISUB = 1, NSUBS
IF( TIMSUB( ISUB ) ) THEN
CALL DPRTBV( SUBNAM( ISUB ), NTYPES, DOTYPE, NSIZES, MM, NN,
$ INPARM( ISUB ), PNAMES, NPARMS, LDAS, NNB,
$ OPCNTS( 1, 1, 1, ISUB ), LDO1, LDO2,
$ TIMES( 1, 1, 1, ISUB ), LDT1, LDT2, WORK,
$ LLWORK, NOUT )
END IF
760 CONTINUE
*
RETURN
*
* End of DTIM26
*
9998 FORMAT( ' DTIM26: ', A, ' returned INFO=', I6, '.', / 9X, 'M=',
$ I6, ', N=', I6, ', ITYPE=', I6, ', IPAR=', I6, ', ',
$ ' ISEED=(', 4( I5, ',' ), I5, ')' )
*
END
SUBROUTINE DTIM51( LINE, NSIZES, NN, NTYPES, DOTYPE, NPARMS, NNB,
$ NSHFTS, NEISPS, MINNBS, MINBKS, LDAS, TIMMIN,
$ NOUT, ISEED, A, B, H, T, Q, Z, W, WORK, LWORK,
$ LLWORK, TIMES, LDT1, LDT2, LDT3, OPCNTS, LDO1,
$ LDO2, LDO3, INFO )
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
CHARACTER*80 LINE
INTEGER INFO, LDO1, LDO2, LDO3, LDT1, LDT2, LDT3,
$ LWORK, NOUT, NPARMS, NSIZES, NTYPES
DOUBLE PRECISION TIMMIN
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * ), LLWORK( * )
INTEGER ISEED( * ), LDAS( * ), MINBKS( * ),
$ MINNBS( * ), NEISPS( * ), NN( * ), NNB( * ),
$ NSHFTS( * )
DOUBLE PRECISION A( * ), B( * ), H( * ),
$ OPCNTS( LDO1, LDO2, LDO3, * ), Q( * ), T( * ),
$ TIMES( LDT1, LDT2, LDT3, * ), W( * ),
$ WORK( * ), Z( * )
* ..
*
* Purpose
* =======
*
* DTIM51 times the LAPACK routines for the real non-symmetric
* generalized eigenvalue problem A x = w B x.
*
* For each N value in NN(1:NSIZES) and .TRUE. value in
* DOTYPE(1:NTYPES), a pair of matrices will be generated and used to
* test the selected routines. Thus, NSIZES*(number of .TRUE. values
* in DOTYPE) matrices will be generated.
*
* Arguments
* =========
*
* LINE (input) CHARACTER*80
* The input line which requested this routine. This line may
* contain a subroutine name, such as DGGHRD, indicating that
* only routine DGGHRD will be timed, or it may contain a
* generic name, such as DHG. In this case, the rest of the
* line is scanned for the first 18 non-blank characters,
* corresponding to the eighteen combinations of subroutine and
* options:
* LAPACK: Table Heading:
* 1: DGGHRD(no Q, no Z) (+DGEQRF, etc.) 'SGGHRD(N)'
* 2: DGGHRD(Q only) (+DGEQRF, etc.) 'SGGHRD(Q)'
* 3: DGGHRD(Z only) (+DGEQRF, etc.) 'SGGHRD(Z)'
* 4: DGGHRD(Q and Z) (+DGEQRF, etc.) 'SGGHRD(Q,Z)'
* 5: DHGEQZ(Eigenvalues only) 'SHGEQZ(E)'
* 6: DHGEQZ(Schur form only) 'SHGEQZ(S)'
* 7: DHGEQZ(Schur form and Q) 'SHGEQZ(Q)'
* 8: DHGEQZ(Schur form and Z) 'SHGEQZ(Z)'
* 9: DHGEQZ(Schur form, Q and Z) 'SHGEQZ(Q,Z)'
* 10: DTGEVC(SIDE='L', HOWMNY='A') 'STGEVC(L,A)'
* 11: DTGEVC(SIDE='L', HOWMNY='B') 'STGEVC(L,B)'
* 12: DTGEVC(SIDE='R', HOWMNY='A') 'STGEVC(R,A)'
* 13: DTGEVC(SIDE='R', HOWMNY='B') 'STGEVC(R,B)'
* EISPACK: Compare w/: Table Heading:
* 14: QZHES w/ matz=.false. 1 'QZHES(F)'
* 15: QZHES w/ matz=.true. 3 'QZHES(T)'
* 16: QZIT and QZVAL w/ matz=.false. 5 'QZIT(F)'
* 17: QZIT and QZVAL w/ matz=.true. 8 'QZIT(T)'
* 18: QZVEC 13 'QZVEC'
* If a character is 'T' or 't', the corresponding routine in
* this path is timed. If the entire line is blank, all the
* routines in the path are timed.
*
* Note that since QZHES does more than DGGHRD, the
* "DGGHRD" timing also includes the time for the calls
* to DGEQRF, DORMQR, and (if Q is computed) DORGQR
* which are necessary to get the same functionality
* as QZHES.
*
* NSIZES (input) INTEGER
* The number of values of N contained in the vector NN.
*
* NN (input) INTEGER array, dimension (NSIZES)
* The values of the matrix size N to be tested. For each
* N value in the array NN, and each .TRUE. value in DOTYPE,
* a matrix A will be generated and used to test the routines.
*
* NTYPES (input) INTEGER
* The number of types in DOTYPE. Only the first MAXTYP
* elements will be examined. Exception: if NSIZES=1 and
* NTYPES=MAXTYP+1, and DOTYPE=MAXTYP*f,t, then the input
* value of A will be used.
*
* DOTYPE (input) LOGICAL
* If DOTYPE(j) is .TRUE., then a pair of matrices (A,B) of
* type j will be generated. A and B have the form U T1 V
* and U T2 V , resp., where U and V are orthogonal, T1 is
* block upper triangular (with 1x1 and 2x2 diagonal blocks),
* and T2 is upper triangular. T2 has random O(1) entries in
* the strict upper triangle and ( 0, 1, 0, 1, 1, ..., 1, 0 )
* on the diagonal, while T1 has random O(1) entries in the
* strict (block) upper triangle, its block diagonal will have
* the singular values:
* (j=1) 0, 0, 1, 1, ULP,..., ULP, 0.
* (j=2) 0, 0, 1, 1, 1-d, 1-2*d, ..., 1-(N-5)*d=ULP, 0.
*
* 2 N-5
* (j=3) 0, 0, 1, 1, a, a , ..., a =ULP, 0.
* (j=4) 0, 0, 1, r1, r2, ..., r(N-4), 0, where r1, etc.
* are random numbers in (ULP,1).
*
* NPARMS (input) INTEGER
* The number of values in each of the arrays NNB, NSHFTS,
* NEISPS, and LDAS. For each matrix A generated according to
* NN and DOTYPE, tests will be run with (NB,NSHIFT,NEISP,LDA)=
* (NNB(1), NSHFTS(1), NEISPS(1), LDAS(1)),...,
* (NNB(NPARMS), NSHFTS(NPARMS), NEISPS(NPARMS), LDAS(NPARMS))
*
* NNB (input) INTEGER array, dimension (NPARMS)
* The values of the blocksize ("NB") to be tested. They must
* be at least 1. Currently, this is only used by DGEQRF,
* etc., in the timing of DGGHRD.
*
* NSHFTS (input) INTEGER array, dimension (NPARMS)
* The values of the number of shifts ("NSHIFT") to be tested.
* (Currently not used.)
*
* NEISPS (input) INTEGER array, dimension (NPARMS)
* The values of "NEISP", the size of largest submatrix to be
* processed by DLAEQZ (EISPACK method), to be tested.
* (Currently not used.)
*
* MINNBS (input) INTEGER array, dimension (NPARMS)
* The values of "MINNB", the minimum size of a product of
* transformations which may be applied as a blocked
* transformation, to be tested. (Currently not used.)
*
* MINBKS (input) INTEGER array, dimension (NPARMS)
* The values of "MINBK", the minimum number of rows/columns
* to be updated with a blocked transformation, to be tested.
* (Currently not used.)
*
* LDAS (input) INTEGER array, dimension (NPARMS)
* The values of LDA, the leading dimension of all matrices,
* to be tested.
*
* TIMMIN (input) DOUBLE PRECISION
* The minimum time a subroutine will be timed.
*
* NOUT (input) INTEGER
* If NOUT > 0 then NOUT specifies the unit number
* on which the output will be printed. If NOUT <= 0, no
* output is printed.
*
* ISEED (input/output) INTEGER array, dimension (4)
* The random seed used by the random number generator, used
* by the test matrix generator. It is used and updated on
* each call to DTIM51
*
* A (workspace) DOUBLE PRECISION array, dimension
* (max(NN)*max(LDAS))
* (a) During the testing of DGGHRD, "A", the original
* left-hand-side matrix to be tested.
* (b) Later, "S", the Schur form of the original "A" matrix.
*
* B (workspace) DOUBLE PRECISION array, dimension
* (max(NN)*max(LDAS))
* (a) During the testing of DGGHRD, "B", the original
* right-hand-side matrix to be tested.
* (b) Later, "P", the Schur form of the original "B" matrix.
*
* H (workspace) DOUBLE PRECISION array, dimension
* (max(NN)*max(LDAS))
* (a) During the testing of DGGHRD and DHGEQZ, "H", the
* Hessenberg form of the original "A" matrix.
* (b) During the testing of DTGEVC, "L", the matrix of left
* eigenvectors.
*
* T (workspace) DOUBLE PRECISION array, dimension
* (max(NN)*max(LDAS))
* (a) During the testing of DGGHRD and DHGEQZ, "T", the
* triangular form of the original "B" matrix.
* (b) During the testing of DTGEVC, "R", the matrix of right
* eigenvectors.
*
* Q (workspace) DOUBLE PRECISION array, dimension
* (max(NN)*max(LDAS))
* The orthogonal matrix on the left generated by DGGHRD. If
* DHGEQZ computes only Q or Z, then that matrix is stored here.
* If both Q and Z are computed, the Q matrix goes here.
*
* Z (workspace) DOUBLE PRECISION array, dimension
* (max(NN)*max(LDAS))
* The orthogonal matrix on the right generated by DGGHRD.
* If DHGEQZ computes both Q and Z, the Z matrix is stored here.
* Also used as scratch space for timing the DLACPY calls.
*
* W (workspace) DOUBLE PRECISION array, dimension (3*max(LDAS))
* Treated as an LDA x 3 matrix whose 1st and 2nd columns hold
* ALPHAR and ALPHAI, the real and imaginary parts of the
* diagonal entries of "S" that would result from reducing "S"
* and "P" simultaneously to triangular form), and whose 3rd
* column holds BETA, the diagonal entries of "P" that would so
* result.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* Number of elements in WORK. It must be at least
* (a) 6*max(NN)
* (b) NSIZES*NTYPES*NPARMS
*
* LLWORK (workspace) LOGICAL array, dimension (max( max(NN), NPARMS ))
*
* TIMES (output) DOUBLE PRECISION array, dimension
* (LDT1,LDT2,LDT3,NSUBS)
* TIMES(i,j,k,l) will be set to the run time (in seconds) for
* subroutine l, with N=NN(k), matrix type j, and LDA=LDAS(i),
* NEISP=NEISPS(i), NBLOCK=NNB(i), NSHIFT=NSHFTS(i),
* MINNB=MINNBS(i), and MINBLK=MINBKS(i).
*
* LDT1 (input) INTEGER
* The first dimension of TIMES. LDT1 >= min( 1, NPARMS ).
*
* LDT2 (input) INTEGER
* The second dimension of TIMES. LDT2 >= min( 1, NTYPES ).
*
* LDT3 (input) INTEGER
* The third dimension of TIMES. LDT3 >= min( 1, NSIZES ).
*
* OPCNTS (output) DOUBLE PRECISION array, dimension
* (LDO1,LDO2,LDO3,NSUBS)
* OPCNTS(i,j,k,l) will be set to the number of floating-point
* operations executed by subroutine l, with N=NN(k), matrix
* type j, and LDA=LDAS(i), NEISP=NEISPS(i), NBLOCK=NNB(i),
* NSHIFT=NSHFTS(i), MINNB=MINNBS(i), and MINBLK=MINBKS(i).
*
* LDO1 (input) INTEGER
* The first dimension of OPCNTS. LDO1 >= min( 1, NPARMS ).
*
* LDO2 (input) INTEGER
* The second dimension of OPCNTS. LDO2 >= min( 1, NTYPES ).
*
* LDO3 (input) INTEGER
* The third dimension of OPCNTS. LDO3 >= min( 1, NSIZES ).
*
* INFO (output) INTEGER
* Error flag. It will be set to zero if no error occurred.
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXTYP, NSUBS
PARAMETER ( MAXTYP = 4, NSUBS = 18 )
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL RUNEQ, RUNES, RUNHES, RUNHRD, RUNQZ
INTEGER IC, IINFO, IN, IPAR, ISUB, ITEMP, ITYPE, J, J1,
$ J2, J3, J4, JC, JR, LASTL, LDA, LDAMIN, LDH,
$ LDQ, LDS, LDW, MINBLK, MINNB, MTYPES, N, N1,
$ NB, NBSMAX, NEISP, NMAX, NSHIFT
DOUBLE PRECISION S1, S2, TIME, ULP, UNTIME
* ..
* .. Local Arrays ..
LOGICAL TIMSUB( NSUBS )
CHARACTER*6 PNAMES( 6 )
CHARACTER*11 SUBNAM( NSUBS )
INTEGER INPARM( NSUBS ), IOLDSD( 4 ), KATYPE( MAXTYP )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLARND, DOPLA, DSECND
EXTERNAL DLAMCH, DLARND, DOPLA, DSECND
* ..
* .. External Subroutines ..
EXTERNAL ATIMIN, DHGEQZ, DLACPY, DLAQZH, DLARFG, DLASET,
$ DLATM4, DORM2R, DPRTBG, DTGEVC, QZHES, QZIT,
$ QZVAL, QZVEC, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN, SIGN
* ..
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
* .. Data statements ..
DATA SUBNAM / 'DGGHRD(N)', 'DGGHRD(Q)', 'DGGHRD(Z)',
$ 'DGGHRD(Q,Z)', 'DHGEQZ(E)', 'DHGEQZ(S)',
$ 'DHGEQZ(Q)', 'DHGEQZ(Z)', 'DHGEQZ(Q,Z)',
$ 'DTGEVC(L,A)', 'DTGEVC(L,B)', 'DTGEVC(R,A)',
$ 'DTGEVC(R,B)', 'QZHES(F)', 'QZHES(T)',
$ 'QZIT(F)', 'QZIT(T)', 'QZVEC' /
DATA INPARM / 4*2, 5*1, 4*1, 5*1 /
DATA PNAMES / ' LDA', ' NB', ' NS',
$ ' NEISP', ' MINNB', 'MINBLK' /
DATA KATYPE / 5, 8, 7, 9 /
* ..
* .. Executable Statements ..
*
* Quick Return
*
INFO = 0
IF( NSIZES.LE.0 .OR. NTYPES.LE.0 .OR. NPARMS.LE.0 )
$ RETURN
*
* Extract the timing request from the input line.
*
CALL ATIMIN( 'DHG', LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
IF( INFO.NE.0 )
$ RETURN
*
* Compute Maximum Values
*
NMAX = 0
DO 10 J1 = 1, NSIZES
NMAX = MAX( NMAX, NN( J1 ) )
10 CONTINUE
*
LDAMIN = 2*MAX( 1, NMAX )
NBSMAX = 0
DO 20 J1 = 1, NPARMS
LDAMIN = MIN( LDAMIN, LDAS( J1 ) )
NBSMAX = MAX( NBSMAX, NNB( J1 )+NSHFTS( J1 ) )
20 CONTINUE
*
* Check that N <= LDA for the input values.
*
IF( NMAX.GT.LDAMIN ) THEN
INFO = -12
WRITE( NOUT, FMT = 9999 )LINE( 1: 6 )
9999 FORMAT( 1X, A, ' timing run not attempted -- N > LDA', / )
RETURN
END IF
*
* Check LWORK
*
IF( LWORK.LT.MAX( ( NBSMAX+1 )*( 2*NBSMAX+NMAX+1 ), 6*NMAX,
$ NSIZES*NTYPES*NPARMS ) ) THEN
INFO = -24
WRITE( NOUT, FMT = 9998 )LINE( 1: 6 )
9998 FORMAT( 1X, A, ' timing run not attempted -- LWORK too small.',
$ / )
RETURN
END IF
*
* Check to see whether DGGHRD or DHGEQZ must be run.
* RUNHRD -- if DGGHRD must be run.
* RUNES -- if DHGEQZ must be run to get Schur form.
* RUNEQ -- if DHGEQZ must be run to get Schur form and Q.
*
RUNHRD = .FALSE.
RUNES = .FALSE.
RUNEQ = .FALSE.
*
IF( TIMSUB( 10 ) .OR. TIMSUB( 12 ) )
$ RUNES = .TRUE.
IF( TIMSUB( 11 ) .OR. TIMSUB( 13 ) )
$ RUNEQ = .TRUE.
IF( TIMSUB( 5 ) .OR. TIMSUB( 6 ) .OR. TIMSUB( 7 ) .OR.
$ TIMSUB( 8 ) .OR. TIMSUB( 9 ) .OR. RUNES .OR. RUNEQ )
$ RUNHRD = .TRUE.
*
IF( TIMSUB( 6 ) .OR. TIMSUB( 7 ) .OR. TIMSUB( 8 ) .OR.
$ TIMSUB( 9 ) .OR. RUNEQ )RUNES = .FALSE.
IF( TIMSUB( 7 ) .OR. TIMSUB( 8 ) .OR. TIMSUB( 9 ) )
$ RUNEQ = .FALSE.
IF( TIMSUB( 1 ) .OR. TIMSUB( 2 ) .OR. TIMSUB( 3 ) .OR.
$ TIMSUB( 4 ) )RUNHRD = .FALSE.
*
* Check to see whether QZHES or QZIT must be run.
*
* RUNHES -- if QZHES must be run.
* RUNQZ -- if QZIT and QZVAL must be run (w/ MATZ=.TRUE.).
*
RUNHES = .FALSE.
RUNQZ = .FALSE.
*
IF( TIMSUB( 18 ) )
$ RUNQZ = .TRUE.
IF( TIMSUB( 16 ) .OR. TIMSUB( 17 ) .OR. RUNQZ )
$ RUNHES = .TRUE.
IF( TIMSUB( 17 ) )
$ RUNQZ = .FALSE.
IF( TIMSUB( 14 ) .OR. TIMSUB( 15 ) )
$ RUNHES = .FALSE.
*
* Various Constants
*
ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
*
* Zero out OPCNTS, TIMES
*
DO 60 J4 = 1, NSUBS
DO 50 J3 = 1, NSIZES
DO 40 J2 = 1, NTYPES
DO 30 J1 = 1, NPARMS
OPCNTS( J1, J2, J3, J4 ) = ZERO
TIMES( J1, J2, J3, J4 ) = ZERO
30 CONTINUE
40 CONTINUE
50 CONTINUE
60 CONTINUE
*
* Do for each value of N:
*
DO 930 IN = 1, NSIZES
*
N = NN( IN )
N1 = MAX( 1, N )
*
* Do for each .TRUE. value in DOTYPE:
*
MTYPES = MIN( MAXTYP, NTYPES )
IF( NTYPES.EQ.MAXTYP+1 .AND. NSIZES.EQ.1 )
$ MTYPES = NTYPES
DO 920 ITYPE = 1, MTYPES
IF( .NOT.DOTYPE( ITYPE ) )
$ GO TO 920
*
* Save random number seed for error messages
*
DO 70 J = 1, 4
IOLDSD( J ) = ISEED( J )
70 CONTINUE
*
* Time the LAPACK Routines
*
* Generate A and B
*
IF( ITYPE.LE.MAXTYP ) THEN
*
* Generate A (w/o rotation)
*
CALL DLATM4( KATYPE( ITYPE ), N, 3, 1, 2, ONE, ULP, ONE,
$ 2, ISEED, A, N1 )
IF( 3.LE.N )
$ A( 3+2*N1 ) = ONE
*
* Generate B (w/o rotation)
*
CALL DLATM4( 8, N, 3, 1, 0, ONE, ONE, ONE, 2, ISEED, B,
$ N1 )
IF( 2.LE.N )
$ B( 2+N1 ) = ONE
*
IF( N.GT.0 ) THEN
*
* Include rotations
*
* Generate U, V as Householder transformations times
* a diagonal matrix.
*
DO 90 JC = 1, N - 1
IC = ( JC-1 )*N1
DO 80 JR = JC, N
Q( JR+IC ) = DLARND( 3, ISEED )
Z( JR+IC ) = DLARND( 3, ISEED )
80 CONTINUE
CALL DLARFG( N+1-JC, Q( JC+IC ), Q( JC+1+IC ), 1,
$ WORK( JC ) )
WORK( 2*N+JC ) = SIGN( ONE, Q( JC+IC ) )
Q( JC+IC ) = ONE
CALL DLARFG( N+1-JC, Z( JC+IC ), Z( JC+1+IC ), 1,
$ WORK( N+JC ) )
WORK( 3*N+JC ) = SIGN( ONE, Z( JC+IC ) )
Z( JC+IC ) = ONE
90 CONTINUE
IC = ( N-1 )*N1
Q( N+IC ) = ONE
WORK( N ) = ZERO
WORK( 3*N ) = SIGN( ONE, DLARND( 2, ISEED ) )
Z( N+IC ) = ONE
WORK( 2*N ) = ZERO
WORK( 4*N ) = SIGN( ONE, DLARND( 2, ISEED ) )
*
* Apply the diagonal matrices
*
DO 110 JC = 1, N
DO 100 JR = 1, N
A( JR+IC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
$ A( JR+IC )
B( JR+IC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
$ B( JR+IC )
100 CONTINUE
110 CONTINUE
CALL DORM2R( 'L', 'N', N, N, N-1, Q, N1, WORK, A, N1,
$ WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 120
CALL DORM2R( 'R', 'T', N, N, N-1, Z, N1, WORK( N+1 ),
$ A, N1, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 120
CALL DORM2R( 'L', 'N', N, N, N-1, Q, N1, WORK, B, N1,
$ WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 120
CALL DORM2R( 'R', 'T', N, N, N-1, Z, N1, WORK( N+1 ),
$ B, N1, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 120
END IF
120 CONTINUE
END IF
*
* . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
*
* Time DGGHRD
*
* Time DGEQRF+DGGHRD('N','N',...) for each pair
* (LDAS(j),NNB(j))
*
IF( TIMSUB( 1 ) ) THEN
DO 160 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = NNB( IPAR )
IF( LDA.LT.N1 ) THEN
TIMES( IPAR, ITYPE, IN, 1 ) = ZERO
OPCNTS( IPAR, ITYPE, IN, 1 ) = ZERO
GO TO 160
END IF
*
* If this value of (NB,LDA) has occurred before,
* just use that value.
*
LASTL = 0
DO 130 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) .AND. NB.EQ.NNB( J ) )
$ LASTL = J
130 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time DGGHRD, computing neither Q nor Z
* (Actually, time DGEQRF + DORMQR + DGGHRD.)
*
CALL XLAENV( 1, NB )
IC = 0
OPS = ZERO
S1 = DSECND( )
140 CONTINUE
CALL DLACPY( 'Full', N, N, A, N1, H, LDA )
CALL DLACPY( 'Full', N, N, B, N1, T, LDA )
CALL DLAQZH( .FALSE., .FALSE., N, 1, N, H, LDA, T,
$ LDA, Q, LDA, Z, LDA, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 1 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
*
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 140
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 150 J = 1, IC
CALL DLACPY( 'Full', N, N, A, N1, Z, LDA )
CALL DLACPY( 'Full', N, N, B, N1, Z, LDA )
150 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 1 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 1 ) = OPS / DBLE( IC ) +
$ DOPLA( 'DGEQRF', N, N, 0, 0, NB ) +
$ DOPLA( 'DORMQR', N, N, 0, 0, NB )
LDH = LDA
ELSE
OPCNTS( IPAR, ITYPE, IN, 1 ) = OPCNTS( LASTL,
$ ITYPE, IN, 1 )
TIMES( IPAR, ITYPE, IN, 1 ) = TIMES( LASTL, ITYPE,
$ IN, 1 )
END IF
160 CONTINUE
ELSE IF( RUNHRD ) THEN
CALL DLACPY( 'Full', N, N, A, N1, H, N1 )
CALL DLACPY( 'Full', N, N, B, N1, T, N1 )
CALL DLAQZH( .FALSE., .FALSE., N, 1, N, H, N1, T, N1, Q,
$ N1, Z, N1, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 1 ), IINFO, N,
$ ITYPE, 0, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
LDH = N
END IF
*
* Time DGGHRD('I','N',...) for each pair (LDAS(j),NNB(j))
*
IF( TIMSUB( 2 ) ) THEN
DO 200 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = NNB( IPAR )
IF( LDA.LT.N1 ) THEN
TIMES( IPAR, ITYPE, IN, 2 ) = ZERO
OPCNTS( IPAR, ITYPE, IN, 2 ) = ZERO
GO TO 200
END IF
*
* If this value of (NB,LDA) has occurred before,
* just use that value.
*
LASTL = 0
DO 170 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) .AND. NB.EQ.NNB( J ) )
$ LASTL = J
170 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time DGGHRD, computing Q but not Z
* (Actually, DGEQRF + DORMQR + DORGQR + DGGHRD.)
*
CALL XLAENV( 1, NB )
IC = 0
OPS = ZERO
S1 = DSECND( )
180 CONTINUE
CALL DLACPY( 'Full', N, N, A, N1, H, LDA )
CALL DLACPY( 'Full', N, N, B, N1, T, LDA )
CALL DLAQZH( .TRUE., .FALSE., N, 1, N, H, LDA, T,
$ LDA, Q, LDA, Z, LDA, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 2 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
*
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 180
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 190 J = 1, IC
CALL DLACPY( 'Full', N, N, A, N1, Z, LDA )
CALL DLACPY( 'Full', N, N, B, N1, Z, LDA )
190 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 2 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 2 ) = OPS / DBLE( IC ) +
$ DOPLA( 'DGEQRF', N, N, 0, 0, NB ) +
$ DOPLA( 'DORMQR', N, N, 0, 0, NB ) +
$ DOPLA( 'DORGQR', N, N, 0, 0, NB )
LDH = LDA
ELSE
OPCNTS( IPAR, ITYPE, IN, 2 ) = OPCNTS( LASTL,
$ ITYPE, IN, 2 )
TIMES( IPAR, ITYPE, IN, 2 ) = TIMES( LASTL, ITYPE,
$ IN, 2 )
END IF
200 CONTINUE
END IF
*
* Time DGGHRD('N','I',...) for each pair (LDAS(j),NNB(j))
*
IF( TIMSUB( 3 ) ) THEN
DO 240 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = NNB( IPAR )
IF( LDA.LT.N1 ) THEN
TIMES( IPAR, ITYPE, IN, 3 ) = ZERO
OPCNTS( IPAR, ITYPE, IN, 3 ) = ZERO
GO TO 240
END IF
*
* If this value of (NB,LDA) has occurred before,
* just use that value.
*
LASTL = 0
DO 210 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) .AND. NB.EQ.NNB( J ) )
$ LASTL = J
210 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time DGGHRD, computing Z but not Q
* (Actually, DGEQRF + DORMQR + DGGHRD.)
*
CALL XLAENV( 1, NB )
IC = 0
OPS = ZERO
S1 = DSECND( )
220 CONTINUE
CALL DLACPY( 'Full', N, N, A, N1, H, LDA )
CALL DLACPY( 'Full', N, N, B, N1, T, LDA )
CALL DLAQZH( .FALSE., .TRUE., N, 1, N, H, LDA, T,
$ LDA, Q, LDA, Z, LDA, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 3 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
*
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 220
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 230 J = 1, IC
CALL DLACPY( 'Full', N, N, A, N1, Z, LDA )
CALL DLACPY( 'Full', N, N, B, N1, Z, LDA )
230 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 3 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 3 ) = OPS / DBLE( IC ) +
$ DOPLA( 'DGEQRF', N, N, 0, 0, NB ) +
$ DOPLA( 'DORMQR', N, N, 0, 0, NB )
LDH = LDA
ELSE
OPCNTS( IPAR, ITYPE, IN, 3 ) = OPCNTS( LASTL,
$ ITYPE, IN, 3 )
TIMES( IPAR, ITYPE, IN, 3 ) = TIMES( LASTL, ITYPE,
$ IN, 3 )
END IF
240 CONTINUE
END IF
*
* Time DGGHRD('I','I',...) for each pair (LDAS(j),NNB(j))
*
IF( TIMSUB( 4 ) ) THEN
DO 280 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
NB = NNB( IPAR )
IF( LDA.LT.N1 ) THEN
TIMES( IPAR, ITYPE, IN, 4 ) = ZERO
OPCNTS( IPAR, ITYPE, IN, 4 ) = ZERO
GO TO 280
END IF
*
* If this value of (NB,LDA) has occurred before,
* just use that value.
*
LASTL = 0
DO 250 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) .AND. NB.EQ.NNB( J ) )
$ LASTL = J
250 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time DGGHRD, computing Q and Z
* (Actually, DGEQRF + DORMQR + DORGQR + DGGHRD.)
*
CALL XLAENV( 1, NB )
IC = 0
OPS = ZERO
S1 = DSECND( )
260 CONTINUE
CALL DLACPY( 'Full', N, N, A, N1, H, LDA )
CALL DLACPY( 'Full', N, N, B, N1, T, LDA )
CALL DLAQZH( .TRUE., .TRUE., N, 1, N, H, LDA, T,
$ LDA, Q, LDA, Z, LDA, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 4 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
*
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 260
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 270 J = 1, IC
CALL DLACPY( 'Full', N, N, A, N1, Z, LDA )
CALL DLACPY( 'Full', N, N, B, N1, Z, LDA )
270 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 4 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 4 ) = OPS / DBLE( IC ) +
$ DOPLA( 'DGEQRF', N, N, 0, 0, NB ) +
$ DOPLA( 'DORMQR', N, N, 0, 0, NB ) +
$ DOPLA( 'DORGQR', N, N, 0, 0, NB )
LDH = LDA
ELSE
OPCNTS( IPAR, ITYPE, IN, 4 ) = OPCNTS( LASTL,
$ ITYPE, IN, 4 )
TIMES( IPAR, ITYPE, IN, 4 ) = TIMES( LASTL, ITYPE,
$ IN, 4 )
END IF
280 CONTINUE
END IF
*
* . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
*
* Time DHGEQZ
*
* Time DHGEQZ with JOB='E' for each value of LDAS(j)
*
IF( TIMSUB( 5 ) ) THEN
DO 320 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
IF( LDA.LT.N1 ) THEN
TIMES( IPAR, ITYPE, IN, 5 ) = ZERO
OPCNTS( IPAR, ITYPE, IN, 5 ) = ZERO
GO TO 320
END IF
*
* If this value of LDA has occurred before,
* just use that value.
*
LASTL = 0
DO 290 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
290 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time DHGEQZ with JOB='E'
*
IC = 0
OPS = ZERO
S1 = DSECND( )
300 CONTINUE
CALL DLACPY( 'Full', N, N, H, LDH, A, LDA )
CALL DLACPY( 'Full', N, N, T, LDH, B, LDA )
CALL DHGEQZ( 'E', 'N', 'N', N, 1, N, A, LDA, B,
$ LDA, W, W( LDA+1 ), W( 2*LDA+1 ), Q,
$ LDA, Z, LDA, WORK, LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 5 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 300
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 310 J = 1, IC
CALL DLACPY( 'Full', N, N, H, LDH, Z, LDA )
CALL DLACPY( 'Full', N, N, T, LDH, Z, LDA )
310 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 5 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 5 ) = OPS / DBLE( IC )
LDS = 0
LDQ = 0
ELSE
OPCNTS( IPAR, ITYPE, IN, 5 ) = OPCNTS( LASTL,
$ ITYPE, IN, 5 )
TIMES( IPAR, ITYPE, IN, 5 ) = TIMES( LASTL, ITYPE,
$ IN, 5 )
END IF
320 CONTINUE
END IF
*
* Time DHGEQZ with JOB='S', COMPQ=COMPZ='N' for each value
* of LDAS(j)
*
IF( TIMSUB( 6 ) ) THEN
DO 360 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
IF( LDA.LT.N1 ) THEN
TIMES( IPAR, ITYPE, IN, 6 ) = ZERO
OPCNTS( IPAR, ITYPE, IN, 6 ) = ZERO
GO TO 360
END IF
*
* If this value of LDA has occurred before,
* just use that value.
*
LASTL = 0
DO 330 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
330 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time DHGEQZ with JOB='S', COMPQ=COMPZ='N'
*
IC = 0
OPS = ZERO
S1 = DSECND( )
340 CONTINUE
CALL DLACPY( 'Full', N, N, H, LDH, A, LDA )
CALL DLACPY( 'Full', N, N, T, LDH, B, LDA )
CALL DHGEQZ( 'S', 'N', 'N', N, 1, N, A, LDA, B,
$ LDA, W, W( LDA+1 ), W( 2*LDA+1 ), Q,
$ LDA, Z, LDA, WORK, LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 6 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 340
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 350 J = 1, IC
CALL DLACPY( 'Full', N, N, H, LDH, Z, LDA )
CALL DLACPY( 'Full', N, N, T, LDH, Z, LDA )
350 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 6 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 6 ) = OPS / DBLE( IC )
LDS = LDA
LDQ = 0
ELSE
OPCNTS( IPAR, ITYPE, IN, 6 ) = OPCNTS( LASTL,
$ ITYPE, IN, 6 )
TIMES( IPAR, ITYPE, IN, 6 ) = TIMES( LASTL, ITYPE,
$ IN, 6 )
END IF
360 CONTINUE
ELSE IF( RUNES ) THEN
CALL DLACPY( 'Full', N, N, H, LDH, A, N1 )
CALL DLACPY( 'Full', N, N, T, LDH, B, N1 )
CALL DHGEQZ( 'S', 'N', 'N', N, 1, N, A, N1, B, N1, W,
$ W( N1+1 ), W( 2*N1+1 ), Q, N1, Z, N1, WORK,
$ LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 6 ), IINFO, N,
$ ITYPE, 0, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
LDS = N1
LDQ = 0
END IF
*
* Time DHGEQZ with JOB='S', COMPQ='I', COMPZ='N' for each
* value of LDAS(j)
*
IF( TIMSUB( 7 ) ) THEN
DO 400 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
IF( LDA.LT.N1 ) THEN
TIMES( IPAR, ITYPE, IN, 7 ) = ZERO
OPCNTS( IPAR, ITYPE, IN, 7 ) = ZERO
GO TO 400
END IF
*
* If this value of LDA has occurred before,
* just use that value.
*
LASTL = 0
DO 370 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
370 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time DHGEQZ with JOB='S', COMPQ='I', COMPZ='N'
*
IC = 0
OPS = ZERO
S1 = DSECND( )
380 CONTINUE
CALL DLACPY( 'Full', N, N, H, LDH, A, LDA )
CALL DLACPY( 'Full', N, N, T, LDH, B, LDA )
CALL DHGEQZ( 'S', 'I', 'N', N, 1, N, A, LDA, B,
$ LDA, W, W( LDA+1 ), W( 2*LDA+1 ), Q,
$ LDA, Z, LDA, WORK, LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 7 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 380
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 390 J = 1, IC
CALL DLACPY( 'Full', N, N, H, LDH, Z, LDA )
CALL DLACPY( 'Full', N, N, T, LDH, Z, LDA )
390 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 7 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 7 ) = OPS / DBLE( IC )
LDS = LDA
LDQ = LDA
ELSE
OPCNTS( IPAR, ITYPE, IN, 7 ) = OPCNTS( LASTL,
$ ITYPE, IN, 7 )
TIMES( IPAR, ITYPE, IN, 7 ) = TIMES( LASTL, ITYPE,
$ IN, 7 )
END IF
400 CONTINUE
ELSE IF( RUNEQ ) THEN
CALL DLACPY( 'Full', N, N, H, LDH, A, N1 )
CALL DLACPY( 'Full', N, N, T, LDH, B, N1 )
CALL DHGEQZ( 'S', 'I', 'N', N, 1, N, A, N1, B, N1, W,
$ W( N1+1 ), W( 2*N1+1 ), Q, N1, Z, N1, WORK,
$ LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 7 ), IINFO, N,
$ ITYPE, 0, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
LDS = N1
LDQ = N1
END IF
*
* Time DHGEQZ with JOB='S', COMPQ='N', COMPZ='I' for each
* value of LDAS(j)
*
IF( TIMSUB( 8 ) ) THEN
DO 440 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
IF( LDA.LT.N1 ) THEN
TIMES( IPAR, ITYPE, IN, 8 ) = ZERO
OPCNTS( IPAR, ITYPE, IN, 8 ) = ZERO
GO TO 440
END IF
*
* If this value of LDA has occurred before,
* just use that value.
*
LASTL = 0
DO 410 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
410 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
NB = MIN( N, NNB( IPAR ) )
NSHIFT = NSHFTS( IPAR )
NEISP = NEISPS( IPAR )
MINNB = MINNBS( IPAR )
MINBLK = MINBKS( IPAR )
*
* Time DHGEQZ with JOB='S', COMPQ='N', COMPZ='I'
* (Note that the "Z" matrix is stored in the array Q)
*
IC = 0
OPS = ZERO
S1 = DSECND( )
420 CONTINUE
CALL DLACPY( 'Full', N, N, H, LDH, A, LDA )
CALL DLACPY( 'Full', N, N, T, LDH, B, LDA )
CALL DHGEQZ( 'S', 'N', 'I', N, 1, N, A, LDA, B,
$ LDA, W, W( LDA+1 ), W( 2*LDA+1 ), Z,
$ LDA, Q, LDA, WORK, LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 8 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 420
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 430 J = 1, IC
CALL DLACPY( 'Full', N, N, H, LDH, Z, LDA )
CALL DLACPY( 'Full', N, N, T, LDH, Z, LDA )
430 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 8 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 8 ) = OPS / DBLE( IC )
LDS = LDA
LDQ = LDA
ELSE
OPCNTS( IPAR, ITYPE, IN, 8 ) = OPCNTS( LASTL,
$ ITYPE, IN, 8 )
TIMES( IPAR, ITYPE, IN, 8 ) = TIMES( LASTL, ITYPE,
$ IN, 8 )
END IF
440 CONTINUE
END IF
*
* Time DHGEQZ with JOB='S', COMPQ='I', COMPZ='I' for each
* value of LDAS(j)
*
IF( TIMSUB( 9 ) ) THEN
DO 480 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
IF( LDA.LT.N1 ) THEN
TIMES( IPAR, ITYPE, IN, 9 ) = ZERO
OPCNTS( IPAR, ITYPE, IN, 9 ) = ZERO
GO TO 480
END IF
*
* If this value of LDA has occurred before,
* just use that value.
*
LASTL = 0
DO 450 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
450 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time DHGEQZ with JOB='S', COMPQ='I', COMPZ='I'
*
IC = 0
OPS = ZERO
S1 = DSECND( )
460 CONTINUE
CALL DLACPY( 'Full', N, N, H, LDH, A, LDA )
CALL DLACPY( 'Full', N, N, T, LDH, B, LDA )
CALL DHGEQZ( 'S', 'I', 'I', N, 1, N, A, LDA, B,
$ LDA, W, W( LDA+1 ), W( 2*LDA+1 ), Q,
$ LDA, Z, LDA, WORK, LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 9 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 460
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 470 J = 1, IC
CALL DLACPY( 'Full', N, N, H, LDH, Z, LDA )
CALL DLACPY( 'Full', N, N, T, LDH, Z, LDA )
470 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 9 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 9 ) = OPS / DBLE( IC )
LDS = LDA
LDQ = LDA
ELSE
OPCNTS( IPAR, ITYPE, IN, 9 ) = OPCNTS( LASTL,
$ ITYPE, IN, 9 )
TIMES( IPAR, ITYPE, IN, 9 ) = TIMES( LASTL, ITYPE,
$ IN, 9 )
END IF
480 CONTINUE
END IF
*
* . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
*
* Time DTGEVC
*
IF( TIMSUB( 10 ) .OR. TIMSUB( 11 ) .OR. TIMSUB( 12 ) .OR.
$ TIMSUB( 13 ) ) THEN
DO 610 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
IF( LDA.LT.N1 ) THEN
DO 490 J = 10, 13
IF( TIMSUB( J ) ) THEN
TIMES( IPAR, ITYPE, IN, J ) = ZERO
OPCNTS( IPAR, ITYPE, IN, J ) = ZERO
END IF
490 CONTINUE
GO TO 610
END IF
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 500 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
500 CONTINUE
*
* Time DTGEVC if this is a new value of LDA
*
IF( LASTL.EQ.0 ) THEN
*
* Copy S (which is in A) and P (which is in B)
* if necessary to get right LDA.
*
IF( LDA.GT.LDS ) THEN
DO 520 JC = N, 1, -1
DO 510 JR = N, 1, -1
A( JR+( JC-1 )*LDA ) = A( JR+( JC-1 )*
$ LDS )
B( JR+( JC-1 )*LDA ) = B( JR+( JC-1 )*
$ LDS )
510 CONTINUE
520 CONTINUE
ELSE IF( LDA.LT.LDS ) THEN
DO 540 JC = 1, N
DO 530 JR = 1, N
A( JR+( JC-1 )*LDA ) = A( JR+( JC-1 )*
$ LDS )
B( JR+( JC-1 )*LDA ) = B( JR+( JC-1 )*
$ LDS )
530 CONTINUE
540 CONTINUE
END IF
LDS = LDA
*
* Time DTGEVC for Left Eigenvectors only,
* without back transforming
*
IF( TIMSUB( 10 ) ) THEN
IC = 0
OPS = ZERO
S1 = DSECND( )
550 CONTINUE
CALL DTGEVC( 'L', 'A', LLWORK, N, A, LDA, B,
$ LDA, H, LDA, T, LDA, N, ITEMP,
$ WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 10 ),
$ IINFO, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 550
*
TIMES( IPAR, ITYPE, IN, 10 ) = TIME / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 10 ) = OPS / DBLE( IC )
END IF
*
* Time DTGEVC for Left Eigenvectors only,
* with back transforming
*
IF( TIMSUB( 11 ) ) THEN
IC = 0
OPS = ZERO
S1 = DSECND( )
560 CONTINUE
CALL DLACPY( 'Full', N, N, Q, LDQ, H, LDA )
CALL DTGEVC( 'L', 'B', LLWORK, N, A, LDA, B,
$ LDA, H, LDA, T, LDA, N, ITEMP,
$ WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 11 ),
$ IINFO, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 560
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 570 J = 1, IC
CALL DLACPY( 'Full', N, N, Q, LDQ, H, LDA )
570 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 11 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 11 ) = OPS / DBLE( IC )
END IF
*
* Time DTGEVC for Right Eigenvectors only,
* without back transforming
*
IF( TIMSUB( 12 ) ) THEN
IC = 0
OPS = ZERO
S1 = DSECND( )
580 CONTINUE
CALL DTGEVC( 'R', 'A', LLWORK, N, A, LDA, B,
$ LDA, H, LDA, T, LDA, N, ITEMP,
$ WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 12 ),
$ IINFO, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 580
*
TIMES( IPAR, ITYPE, IN, 12 ) = TIME / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 12 ) = OPS / DBLE( IC )
END IF
*
* Time DTGEVC for Right Eigenvectors only,
* with back transforming
*
IF( TIMSUB( 13 ) ) THEN
IC = 0
OPS = ZERO
S1 = DSECND( )
590 CONTINUE
CALL DLACPY( 'Full', N, N, Q, LDQ, T, LDA )
CALL DTGEVC( 'R', 'B', LLWORK, N, A, LDA, B,
$ LDA, H, LDA, T, LDA, N, ITEMP,
$ WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 13 ),
$ IINFO, N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 590
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 600 J = 1, IC
CALL DLACPY( 'Full', N, N, Q, LDQ, T, LDA )
600 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 13 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 13 ) = OPS / DBLE( IC )
END IF
*
ELSE
*
* If this LDA has previously appeared, use the
* previously computed value(s).
*
IF( TIMSUB( 10 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 10 ) = OPCNTS( LASTL,
$ ITYPE, IN, 10 )
TIMES( IPAR, ITYPE, IN, 10 ) = TIMES( LASTL,
$ ITYPE, IN, 10 )
END IF
IF( TIMSUB( 11 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 11 ) = OPCNTS( LASTL,
$ ITYPE, IN, 11 )
TIMES( IPAR, ITYPE, IN, 11 ) = TIMES( LASTL,
$ ITYPE, IN, 11 )
END IF
IF( TIMSUB( 12 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 12 ) = OPCNTS( LASTL,
$ ITYPE, IN, 12 )
TIMES( IPAR, ITYPE, IN, 12 ) = TIMES( LASTL,
$ ITYPE, IN, 12 )
END IF
IF( TIMSUB( 13 ) ) THEN
OPCNTS( IPAR, ITYPE, IN, 13 ) = OPCNTS( LASTL,
$ ITYPE, IN, 13 )
TIMES( IPAR, ITYPE, IN, 13 ) = TIMES( LASTL,
$ ITYPE, IN, 13 )
END IF
END IF
610 CONTINUE
END IF
*
* Time the EISPACK Routines
*
* Restore random number seed
*
DO 620 J = 1, 4
ISEED( J ) = IOLDSD( J )
620 CONTINUE
*
* Re-generate A
*
IF( ITYPE.LE.MAXTYP ) THEN
*
* Generate A (w/o rotation)
*
CALL DLATM4( KATYPE( ITYPE ), N, 3, 1, 2, ONE, ULP, ONE,
$ 2, ISEED, A, N1 )
IF( 3.LE.N )
$ A( 3+2*N1 ) = ONE
*
* Generate B (w/o rotation)
*
CALL DLATM4( 8, N, 3, 1, 0, ONE, ONE, ONE, 2, ISEED, B,
$ N1 )
IF( 2.LE.N )
$ B( 2+N1 ) = ONE
*
IF( N.GT.0 ) THEN
*
* Include rotations
*
* Generate U, V as Householder transformations times
* a diagonal matrix.
*
DO 640 JC = 1, N - 1
IC = ( JC-1 )*N1
DO 630 JR = JC, N
Q( JR+IC ) = DLARND( 3, ISEED )
Z( JR+IC ) = DLARND( 3, ISEED )
630 CONTINUE
CALL DLARFG( N+1-JC, Q( JC+IC ), Q( JC+1+IC ), 1,
$ WORK( JC ) )
WORK( 2*N+JC ) = SIGN( ONE, Q( JC+IC ) )
Q( JC+IC ) = ONE
CALL DLARFG( N+1-JC, Z( JC+IC ), Z( JC+1+IC ), 1,
$ WORK( N+JC ) )
WORK( 3*N+JC ) = SIGN( ONE, Z( JC+IC ) )
Z( JC+IC ) = ONE
640 CONTINUE
IC = ( N-1 )*N1
Q( N+IC ) = ONE
WORK( N ) = ZERO
WORK( 3*N ) = SIGN( ONE, DLARND( 2, ISEED ) )
Z( N+IC ) = ONE
WORK( 2*N ) = ZERO
WORK( 4*N ) = SIGN( ONE, DLARND( 2, ISEED ) )
*
* Apply the diagonal matrices
*
DO 660 JC = 1, N
DO 650 JR = 1, N
A( JR+IC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
$ A( JR+IC )
B( JR+IC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
$ B( JR+IC )
650 CONTINUE
660 CONTINUE
CALL DORM2R( 'L', 'N', N, N, N-1, Q, N1, WORK, A, N1,
$ WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 670
CALL DORM2R( 'R', 'T', N, N, N-1, Z, N1, WORK( N+1 ),
$ A, N1, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 670
CALL DORM2R( 'L', 'N', N, N, N-1, Q, N1, WORK, B, N1,
$ WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 670
CALL DORM2R( 'R', 'T', N, N, N-1, Z, N1, WORK( N+1 ),
$ B, N1, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 670
END IF
670 CONTINUE
END IF
*
* Time QZHES w/ MATZ=.FALSE. for each LDAS(j)
*
IF( TIMSUB( 14 ) ) THEN
DO 710 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
IF( LDA.LT.N1 ) THEN
TIMES( IPAR, ITYPE, IN, 14 ) = ZERO
OPCNTS( IPAR, ITYPE, IN, 14 ) = ZERO
GO TO 710
END IF
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 680 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
680 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time QZHES( ...,.FALSE.,..)
*
IC = 0
OPS = ZERO
S1 = DSECND( )
690 CONTINUE
CALL DLACPY( 'Full', N, N, A, N1, H, LDA )
CALL DLACPY( 'Full', N, N, B, N1, T, LDA )
CALL QZHES( LDA, N, H, T, .FALSE., Q )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 690
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 700 J = 1, IC
CALL DLACPY( 'Full', N, N, A, N1, Z, LDA )
CALL DLACPY( 'Full', N, N, B, N1, Z, LDA )
700 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 14 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 14 ) = OPS / DBLE( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 14 ) = OPCNTS( LASTL,
$ ITYPE, IN, 14 )
TIMES( IPAR, ITYPE, IN, 14 ) = TIMES( LASTL, ITYPE,
$ IN, 14 )
END IF
LDH = LDA
710 CONTINUE
ELSE IF( RUNHES ) THEN
CALL DLACPY( 'Full', N, N, A, N1, H, N1 )
CALL DLACPY( 'Full', N, N, B, N1, T, N1 )
CALL QZHES( N1, N, H, T, .FALSE., Q )
LDH = N1
END IF
*
* Time QZHES w/ MATZ=.TRUE. for each LDAS(j)
*
IF( TIMSUB( 15 ) ) THEN
DO 750 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
IF( LDA.LT.N1 ) THEN
TIMES( IPAR, ITYPE, IN, 15 ) = ZERO
OPCNTS( IPAR, ITYPE, IN, 15 ) = ZERO
GO TO 750
END IF
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 720 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
720 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time QZHES( ...,.TRUE.,..)
*
IC = 0
OPS = ZERO
S1 = DSECND( )
730 CONTINUE
CALL DLACPY( 'Full', N, N, A, N1, H, LDA )
CALL DLACPY( 'Full', N, N, B, N1, T, LDA )
CALL QZHES( LDA, N, H, T, .TRUE., Q )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 730
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 740 J = 1, IC
CALL DLACPY( 'Full', N, N, A, N1, Z, LDA )
CALL DLACPY( 'Full', N, N, B, N1, Z, LDA )
740 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 15 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 15 ) = OPS / DBLE( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 15 ) = OPCNTS( LASTL,
$ ITYPE, IN, 15 )
TIMES( IPAR, ITYPE, IN, 15 ) = TIMES( LASTL, ITYPE,
$ IN, 15 )
END IF
LDH = LDA
750 CONTINUE
END IF
*
* Time QZIT and QZVAL w/ MATZ=.FALSE. for each LDAS(j)
*
IF( TIMSUB( 16 ) ) THEN
DO 790 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
IF( LDA.LT.N1 ) THEN
TIMES( IPAR, ITYPE, IN, 16 ) = ZERO
OPCNTS( IPAR, ITYPE, IN, 16 ) = ZERO
GO TO 790
END IF
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 760 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
760 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time QZIT and QZVAL with MATZ=.FALSE.
*
IC = 0
OPS = ZERO
S1 = DSECND( )
770 CONTINUE
CALL DLACPY( 'Full', N, N, H, LDH, A, LDA )
CALL DLACPY( 'Full', N, N, T, LDH, B, LDA )
CALL QZIT( LDA, N, A, B, ZERO, .FALSE., Q, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 16 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
*
CALL QZVAL( LDA, N, A, B, W, W( LDA+1 ),
$ W( 2*LDA+1 ), .FALSE., Q )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 770
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 780 J = 1, IC
CALL DLACPY( 'Full', N, N, H, LDH, Z, LDA )
CALL DLACPY( 'Full', N, N, T, LDH, Z, LDA )
780 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 16 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 16 ) = OPS / DBLE( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 16 ) = OPCNTS( LASTL,
$ ITYPE, IN, 16 )
TIMES( IPAR, ITYPE, IN, 16 ) = TIMES( LASTL, ITYPE,
$ IN, 16 )
END IF
LDS = 0
790 CONTINUE
END IF
*
* Time QZIT and QZVAL w/ MATZ=.TRUE. for each LDAS(j)
*
IF( TIMSUB( 17 ) ) THEN
DO 830 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
IF( LDA.LT.N1 ) THEN
TIMES( IPAR, ITYPE, IN, 17 ) = ZERO
OPCNTS( IPAR, ITYPE, IN, 17 ) = ZERO
GO TO 830
END IF
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 800 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
800 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Time QZIT and QZVAL with MATZ=.TRUE.
*
IC = 0
OPS = ZERO
S1 = DSECND( )
810 CONTINUE
CALL DLACPY( 'Full', N, N, H, LDH, A, LDA )
CALL DLACPY( 'Full', N, N, T, LDH, B, LDA )
CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDA )
CALL QZIT( LDA, N, A, B, ZERO, .TRUE., Q, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 17 ), IINFO,
$ N, ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
*
CALL QZVAL( LDA, N, A, B, W, W( LDA+1 ),
$ W( 2*LDA+1 ), .TRUE., Q )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 810
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 820 J = 1, IC
CALL DLACPY( 'Full', N, N, H, LDH, Z, LDA )
CALL DLACPY( 'Full', N, N, T, LDH, Z, LDA )
CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDA )
820 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 17 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 17 ) = OPS / DBLE( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 17 ) = OPCNTS( LASTL,
$ ITYPE, IN, 17 )
TIMES( IPAR, ITYPE, IN, 17 ) = TIMES( LASTL, ITYPE,
$ IN, 17 )
END IF
LDS = LDA
LDW = LDA
830 CONTINUE
ELSE IF( RUNQZ ) THEN
CALL DLACPY( 'Full', N, N, H, LDH, A, N1 )
CALL DLACPY( 'Full', N, N, T, LDH, B, N1 )
CALL DLASET( 'Full', N, N, ZERO, ONE, Q, N1 )
CALL QZIT( N1, N, A, B, ZERO, .TRUE., Q, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9997 )SUBNAM( 17 ), IINFO, N,
$ ITYPE, IPAR, IOLDSD
INFO = ABS( IINFO )
GO TO 920
END IF
*
CALL QZVAL( N1, N, A, B, W, W( N1+1 ), W( 2*N1+1 ),
$ .TRUE., Q )
LDS = N1
LDW = N1
END IF
*
* Time QZVEC for each LDAS(j)
*
IF( TIMSUB( 18 ) ) THEN
DO 910 IPAR = 1, NPARMS
LDA = LDAS( IPAR )
IF( LDA.LT.N1 ) THEN
TIMES( IPAR, ITYPE, IN, 18 ) = ZERO
OPCNTS( IPAR, ITYPE, IN, 18 ) = ZERO
GO TO 910
END IF
*
* If this value of LDA has come up before, just use
* the value previously computed.
*
LASTL = 0
DO 840 J = 1, IPAR - 1
IF( LDA.EQ.LDAS( J ) )
$ LASTL = J
840 CONTINUE
*
IF( LASTL.EQ.0 ) THEN
*
* Copy W if necessary to get right LDA.
*
IF( LDA.GT.LDW ) THEN
DO 860 JC = 3, 1, -1
DO 850 JR = N, 1, -1
W( JR+( JC-1 )*LDA ) = W( JR+( JC-1 )*
$ LDW )
850 CONTINUE
860 CONTINUE
ELSE IF( LDA.LT.LDW ) THEN
DO 880 JC = 1, 3
DO 870 JR = 1, N
W( JR+( JC-1 )*LDA ) = W( JR+( JC-1 )*
$ LDW )
870 CONTINUE
880 CONTINUE
END IF
LDW = LDA
*
* Time QZVEC
*
IC = 0
OPS = ZERO
S1 = DSECND( )
890 CONTINUE
CALL DLACPY( 'Full', N, N, A, LDS, H, LDA )
CALL DLACPY( 'Full', N, N, B, LDS, T, LDA )
CALL DLACPY( 'Full', N, N, Q, LDS, Z, LDA )
CALL QZVEC( LDA, N, H, T, W, W( LDA+1 ),
$ W( 2*LDA+1 ), Z )
S2 = DSECND( )
TIME = S2 - S1
IC = IC + 1
IF( TIME.LT.TIMMIN )
$ GO TO 890
*
* Subtract the time used in DLACPY.
*
S1 = DSECND( )
DO 900 J = 1, IC
CALL DLACPY( 'Full', N, N, A, LDS, Z, LDA )
CALL DLACPY( 'Full', N, N, B, LDS, Z, LDA )
CALL DLACPY( 'Full', N, N, Q, LDS, Z, LDA )
900 CONTINUE
S2 = DSECND( )
UNTIME = S2 - S1
*
TIMES( IPAR, ITYPE, IN, 18 ) = MAX( TIME-UNTIME,
$ ZERO ) / DBLE( IC )
OPCNTS( IPAR, ITYPE, IN, 18 ) = OPS / DBLE( IC )
ELSE
OPCNTS( IPAR, ITYPE, IN, 18 ) = OPCNTS( LASTL,
$ ITYPE, IN, 18 )
TIMES( IPAR, ITYPE, IN, 18 ) = TIMES( LASTL, ITYPE,
$ IN, 18 )
END IF
910 CONTINUE
END IF
*
920 CONTINUE
930 CONTINUE
*
* Print a table of results for each timed routine.
*
DO 940 ISUB = 1, NSUBS
IF( TIMSUB( ISUB ) ) THEN
CALL DPRTBG( SUBNAM( ISUB ), MTYPES, DOTYPE, NSIZES, NN,
$ INPARM( ISUB ), PNAMES, NPARMS, LDAS, NNB,
$ NSHFTS, NEISPS, MINNBS, MINBKS,
$ OPCNTS( 1, 1, 1, ISUB ), LDO1, LDO2,
$ TIMES( 1, 1, 1, ISUB ), LDT1, LDT2, WORK,
$ LLWORK, NOUT )
END IF
940 CONTINUE
*
RETURN
*
* End of DTIM51
*
9997 FORMAT( ' DTIM51: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', ITYPE=', I6, ', IPAR=', I6, ', ISEED=(',
$ 3( I5, ',' ), I5, ')' )
*
END
PROGRAM DTIMEE
*
* -- LAPACK timing routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* June 30, 1999
*
* Purpose
* =======
*
* DTIMEE is the main timing program for the DOUBLE PRECISION matrix
* eigenvalue routines in LAPACK.
*
* There are four sets of routines that can be timed:
*
* NEP (Nonsymmetric Eigenvalue Problem):
* Includes DGEHRD, DHSEQR, DTREVC, and DHSEIN
*
* SEP (Symmetric Eigenvalue Problem):
* Includes DSYTRD, DORGTR, DORMTR, DSTEQR, DSTERF, DPTEQR, DSTEBZ,
* DSTEIN, and DSTEDC
*
* SVD (Singular Value Decomposition):
* Includes DGEBRD, DBDSQR, DORGBR, DBDSDC and DGESDD
*
* GEP (Generalized nonsymmetric Eigenvalue Problem):
* Includes DGGHRD, DHGEQZ, and DTGEVC
*
* Each test path has a different input file. The first line of the
* input file should contain the characters NEP, SEP, SVD, or GEP in
* columns 1-3. The number of remaining lines depends on what is found
* on the first line.
*
*-----------------------------------------------------------------------
*
* NEP input file:
*
* line 2: NN, INTEGER
* Number of values of N.
*
* line 3: NVAL, INTEGER array, dimension (NN)
* The values for the matrix dimension N.
*
* line 4: NPARM, INTEGER
* Number of values of the parameters NB, NS, MAXB, and LDA.
*
* line 5: NBVAL, INTEGER array, dimension (NPARM)
* The values for the blocksize NB.
*
* line 6: NSVAL, INTEGER array, dimension (NPARM)
* The values for the number of shifts.
*
* line 7: MXBVAL, INTEGER array, dimension (NPARM)
* The values for MAXB, used in determining whether multishift
* will be used.
*
* line 8: LDAVAL, INTEGER array, dimension (NPARM)
* The values for the leading dimension LDA.
*
* line 9: TIMMIN, DOUBLE PRECISION
* The minimum time (in seconds) that a subroutine will be
* timed. If TIMMIN is zero, each routine should be timed only
* once.
*
* line 10: NTYPES, INTEGER
* The number of matrix types to be used in the timing run.
* If NTYPES >= MAXTYP, all the types are used.
*
* If 0 < NTYPES < MAXTYP, then line 11 specifies NTYPES integer
* values, which are the numbers of the matrix types to be used.
*
* The remaining lines specify a path name and the specific routines to
* be timed. For the nonsymmetric eigenvalue problem, the path name is
* 'DHS'. A line to request all the routines in this path has the form
* DHS T T T T T T T T T T T T
* where the first 3 characters specify the path name, and up to MAXTYP
* nonblank characters may appear in columns 4-80. If the k-th such
* character is 'T' or 't', the k-th routine will be timed. If at least
* one but fewer than 12 nonblank characters are specified, the
* remaining routines will not be timed. If columns 4-80 are blank, all
* the routines will be timed, so the input line
* DHS
* is equivalent to the line above.
*
*-----------------------------------------------------------------------
*
* SEP input file:
*
* line 2: NN, INTEGER
* Number of values of N.
*
* line 3: NVAL, INTEGER array, dimension (NN)
* The values for the matrix dimension N.
*
* line 4: NPARM, INTEGER
* Number of values of the parameters NB and LDA.
*
* line 5: NBVAL, INTEGER array, dimension (NPARM)
* The values for the blocksize NB.
*
* line 6: LDAVAL, INTEGER array, dimension (NPARM)
* The values for the leading dimension LDA.
*
* line 7: TIMMIN, DOUBLE PRECISION
* The minimum time (in seconds) that a subroutine will be
* timed. If TIMMIN is zero, each routine should be timed only
* once.
*
* line 8: NTYPES, INTEGER
* The number of matrix types to be used in the timing run.
* If NTYPES >= MAXTYP, all the types are used.
*
* If 0 < NTYPES < MAXTYP, then line 9 specifies NTYPES integer
* values, which are the numbers of the matrix types to be used.
*
* The remaining lines specify a path name and the specific routines to
* be timed as for the NEP input file. For the symmetric eigenvalue
* problem, the path name is 'DST' and up to 8 routines may be timed.
*
*-----------------------------------------------------------------------
*
* SVD input file:
*
* line 2: NN, INTEGER
* Number of values of M and N.
*
* line 3: MVAL, INTEGER array, dimension (NN)
* The values for the matrix dimension M.
*
* line 4: NVAL, INTEGER array, dimension (NN)
* The values for the matrix dimension N.
*
* line 5: NPARM, INTEGER
* Number of values of the parameters NB and LDA.
*
* line 6: NBVAL, INTEGER array, dimension (NPARM)
* The values for the blocksize NB.
*
* line 7: LDAVAL, INTEGER array, dimension (NPARM)
* The values for the leading dimension LDA.
*
* line 8: TIMMIN, DOUBLE PRECISION
* The minimum time (in seconds) that a subroutine will be
* timed. If TIMMIN is zero, each routine should be timed only
* once.
*
* line 9: NTYPES, INTEGER
* The number of matrix types to be used in the timing run.
* If NTYPES >= MAXTYP, all the types are used.
*
* If 0 < NTYPES < MAXTYP, then line 10 specifies NTYPES integer
* values, which are the numbers of the matrix types to be used.
*
* The remaining lines specify a path name and the specific routines to
* be timed as for the NEP input file. For the singular value
* decomposition the path name is 'DBD' and up to 16 routines may be
* timed.
*
*-----------------------------------------------------------------------
*
* GEP input file:
*
* line 2: NN, INTEGER
* Number of values of N.
*
* line 3: NVAL, INTEGER array, dimension (NN)
* The values for the matrix dimension N.
*
* line 4: NPARM, INTEGER
* Number of values of the parameters NB, NS, MAXB, and LDA.
*
* line 5: NBVAL, INTEGER array, dimension (NPARM)
* The values for the blocksize NB.
*
* line 6: NSVAL, INTEGER array, dimension (NPARM)
* The values for the number of shifts.
*
* line 7: NEIVAL, INTEGER array, dimension (NPARM)
* The values for NEISP, used in determining whether multishift
* will be used.
*
* line 8: NBMVAL, INTEGER array, dimension (NPARM)
* The values for MINNB, used in determining minimum blocksize.
*
* line 9: NBKVAL, INTEGER array, dimension (NPARM)
* The values for MINBLK, also used in determining minimum
* blocksize.
*
* line 10: LDAVAL, INTEGER array, dimension (NPARM)
* The values for the leading dimension LDA.
*
* line 11: TIMMIN, DOUBLE PRECISION
* The minimum time (in seconds) that a subroutine will be
* timed. If TIMMIN is zero, each routine should be timed only
* once.
*
* line 12: NTYPES, INTEGER
* The number of matrix types to be used in the timing run.
* If NTYPES >= MAXTYP, all the types are used.
*
* If 0 < NTYPES < MAXTYP, then line 13 specifies NTYPES integer
* values, which are the numbers of the matrix types to be used.
*
* The remaining lines specify a path name and the specific routines to
* be timed. For the nonsymmetric eigenvalue problem, the path name is
* 'DHG'. A line to request all the routines in this path has the form
* DHG T T T T T T T T T T T T T T T T T T
* where the first 3 characters specify the path name, and up to MAXTYP
* nonblank characters may appear in columns 4-80. If the k-th such
* character is 'T' or 't', the k-th routine will be timed. If at least
* one but fewer than 18 nonblank characters are specified, the
* remaining routines will not be timed. If columns 4-80 are blank, all
* the routines will be timed, so the input line
* DHG
* is equivalent to the line above.
*
*=======================================================================
*
* The workspace requirements in terms of square matrices for the
* different test paths are as follows:
*
* NEP: 3 N**2 + N*(3*NB+2)
* SEP: 2 N**2 + N*(2*N) + N
* SVD: 4 N**2 + MAX( 6*N, MAXIN*MAXPRM*MAXT )
* GEP: 6 N**2 + 3*N
*
* MAXN is currently set to 400,
* LG2MXN = ceiling of log-base-2 of MAXN = 9, and LDAMAX = 420.
* The real work space needed is LWORK = MAX( MAXN*(4*MAXN+2),
* 2*LDAMAX+1+3*MAXN+2*MAXN*LG2MXN+3*MAXN**2 ), and the integer
* workspace needed is LIWRK2 = 6 + 6*MAXN + 5*MAXN*LG2MXN.
* For SVD, we assume NRHS may be as big
* as N. The parameter NEED is set to 4 to allow for 4 NxN matrices
* for SVD.
*
* .. Parameters ..
INTEGER MAXN, LDAMAX, LG2MXN
PARAMETER ( MAXN = 400, LDAMAX = 420, LG2MXN = 9 )
INTEGER NEED
PARAMETER ( NEED = 6 )
INTEGER LIWRK2
PARAMETER ( LIWRK2 = 6+6*MAXN+5*MAXN*LG2MXN )
INTEGER LWORK
PARAMETER ( LWORK = 2*LDAMAX+1+3*MAXN+2*MAXN*LG2MXN+
$ 4*MAXN**2 )
INTEGER MAXIN, MAXPRM, MAXT, MAXSUB
PARAMETER ( MAXIN = 12, MAXPRM = 10, MAXT = 10,
$ MAXSUB = 25 )
INTEGER NIN, NOUT
PARAMETER ( NIN = 5, NOUT = 6 )
* ..
* .. Local Scalars ..
LOGICAL FATAL, GEP, NEP, SEP, SVD
CHARACTER*3 C3, PATH
CHARACTER*6 VNAME
CHARACTER*80 LINE
INTEGER I, INFO, MAXTYP, NN, NPARMS, NTYPES
DOUBLE PRECISION S1, S2, TIMMIN
* ..
* .. Local Arrays ..
LOGICAL DOTYPE( MAXT ), LOGWRK( MAXN )
INTEGER ISEED( 4 ), IWORK( MAXT ), IWORK2( LIWRK2 ),
$ LDAVAL( MAXPRM ), MVAL( MAXIN ),
$ MXBVAL( MAXPRM ), MXTYPE( 4 ),
$ NBKVAL( MAXPRM ), NBMVAL( MAXPRM ),
$ NBVAL( MAXPRM ), NSVAL( MAXPRM ), NVAL( MAXIN )
DOUBLE PRECISION A( LDAMAX*MAXN, NEED ), D( MAXN, 4 ),
$ OPCNTS( MAXPRM, MAXT, MAXIN, MAXSUB ),
$ RESULT( MAXPRM, MAXT, MAXIN, MAXSUB ),
$ WORK( LWORK )
* ..
* .. External Functions ..
LOGICAL LSAMEN
DOUBLE PRECISION DSECND
EXTERNAL LSAMEN, DSECND
* ..
* .. External Subroutines ..
EXTERNAL DTIM21, DTIM22, DTIM26, DTIM51
* ..
* .. Scalars in Common ..
DOUBLE PRECISION ITCNT, OPS
* ..
* .. Arrays in Common ..
INTEGER IPARMS( 100 )
* ..
* .. Common blocks ..
COMMON / LATIME / OPS, ITCNT
COMMON / CLAENV / IPARMS
* ..
* .. Save statement ..
SAVE / CLAENV /
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Data statements ..
DATA ISEED / 0, 0, 0, 1 /
DATA MXTYPE / 8, 4, 5, 4 /
* ..
* .. Executable Statements ..
*
S1 = DSECND( )
FATAL = .FALSE.
NEP = .FALSE.
SEP = .FALSE.
SVD = .FALSE.
GEP = .FALSE.
*
* Read the 3-character test path
*
READ( NIN, FMT = '(A3)', END = 160 )PATH
NEP = LSAMEN( 3, PATH, 'NEP' ) .OR. LSAMEN( 3, PATH, 'DHS' )
SEP = LSAMEN( 3, PATH, 'SEP' ) .OR. LSAMEN( 3, PATH, 'DST' )
SVD = LSAMEN( 3, PATH, 'SVD' ) .OR. LSAMEN( 3, PATH, 'DBD' )
GEP = LSAMEN( 3, PATH, 'GEP' ) .OR. LSAMEN( 3, PATH, 'DHG' )
*
* Report values of parameters as they are read.
*
IF( NEP ) THEN
WRITE( NOUT, FMT = 9993 )
ELSE IF( SEP ) THEN
WRITE( NOUT, FMT = 9992 )
ELSE IF( SVD ) THEN
WRITE( NOUT, FMT = 9991 )
ELSE IF( GEP ) THEN
WRITE( NOUT, FMT = 9990 )
ELSE
WRITE( NOUT, FMT = 9996 )PATH
STOP
END IF
WRITE( NOUT, FMT = 9985 )
WRITE( NOUT, FMT = 9989 )
*
* Read the number of values of M and N.
*
READ( NIN, FMT = * )NN
IF( NN.LT.1 ) THEN
WRITE( NOUT, FMT = 9995 )'NN ', NN, 1
NN = 0
FATAL = .TRUE.
ELSE IF( NN.GT.MAXIN ) THEN
WRITE( NOUT, FMT = 9994 )'NN ', NN, MAXIN
NN = 0
FATAL = .TRUE.
END IF
*
* Read the values of M
*
READ( NIN, FMT = * )( MVAL( I ), I = 1, NN )
IF( SVD ) THEN
VNAME = ' M'
ELSE
VNAME = ' N'
END IF
DO 10 I = 1, NN
IF( MVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9995 )VNAME, MVAL( I ), 0
FATAL = .TRUE.
ELSE IF( MVAL( I ).GT.MAXN ) THEN
WRITE( NOUT, FMT = 9994 )VNAME, MVAL( I ), MAXN
FATAL = .TRUE.
END IF
10 CONTINUE
*
* Read the values of N
*
IF( SVD ) THEN
WRITE( NOUT, FMT = 9988 )'M ', ( MVAL( I ), I = 1, NN )
READ( NIN, FMT = * )( NVAL( I ), I = 1, NN )
DO 20 I = 1, NN
IF( NVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9995 )'N ', NVAL( I ), 0
FATAL = .TRUE.
ELSE IF( NVAL( I ).GT.MAXN ) THEN
WRITE( NOUT, FMT = 9994 )'N ', NVAL( I ), MAXN
FATAL = .TRUE.
END IF
20 CONTINUE
ELSE
DO 30 I = 1, NN
NVAL( I ) = MVAL( I )
30 CONTINUE
END IF
WRITE( NOUT, FMT = 9988 )'N ', ( NVAL( I ), I = 1, NN )
*
* Read the number of parameter values.
*
READ( NIN, FMT = * )NPARMS
IF( NPARMS.LT.1 ) THEN
WRITE( NOUT, FMT = 9995 )'NPARMS', NPARMS, 1
NPARMS = 0
FATAL = .TRUE.
ELSE IF( NPARMS.GT.MAXIN ) THEN
WRITE( NOUT, FMT = 9994 )'NPARMS', NPARMS, MAXIN
NPARMS = 0
FATAL = .TRUE.
END IF
*
* Read the values of NB
*
READ( NIN, FMT = * )( NBVAL( I ), I = 1, NPARMS )
DO 40 I = 1, NPARMS
IF( NBVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9995 )'NB ', NBVAL( I ), 0
FATAL = .TRUE.
END IF
40 CONTINUE
WRITE( NOUT, FMT = 9988 )'NB ', ( NBVAL( I ), I = 1, NPARMS )
*
IF( NEP .OR. GEP ) THEN
*
* Read the values of NSHIFT
*
READ( NIN, FMT = * )( NSVAL( I ), I = 1, NPARMS )
DO 50 I = 1, NPARMS
IF( NSVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9995 )'NS ', NSVAL( I ), 0
FATAL = .TRUE.
END IF
50 CONTINUE
WRITE( NOUT, FMT = 9988 )'NS ', ( NSVAL( I ), I = 1, NPARMS )
*
* Read the values of MAXB
*
READ( NIN, FMT = * )( MXBVAL( I ), I = 1, NPARMS )
DO 60 I = 1, NPARMS
IF( MXBVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9995 )'MAXB', MXBVAL( I ), 0
FATAL = .TRUE.
END IF
60 CONTINUE
WRITE( NOUT, FMT = 9988 )'MAXB',
$ ( MXBVAL( I ), I = 1, NPARMS )
ELSE
DO 70 I = 1, NPARMS
NSVAL( I ) = 1
MXBVAL( I ) = 1
70 CONTINUE
END IF
*
IF( GEP ) THEN
*
* Read the values of NBMIN
*
READ( NIN, FMT = * )( NBMVAL( I ), I = 1, NPARMS )
DO 80 I = 1, NPARMS
IF( NBMVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9995 )'NBMIN', NBMVAL( I ), 0
FATAL = .TRUE.
END IF
80 CONTINUE
WRITE( NOUT, FMT = 9988 )'NBMIN',
$ ( NBMVAL( I ), I = 1, NPARMS )
*
* Read the values of MINBLK
*
READ( NIN, FMT = * )( NBKVAL( I ), I = 1, NPARMS )
DO 90 I = 1, NPARMS
IF( NBKVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9995 )'MINBLK', NBKVAL( I ), 0
FATAL = .TRUE.
END IF
90 CONTINUE
WRITE( NOUT, FMT = 9988 )'MINBLK',
$ ( NBKVAL( I ), I = 1, NPARMS )
ELSE
DO 100 I = 1, NPARMS
NBMVAL( I ) = MAXN + 1
NBKVAL( I ) = MAXN + 1
100 CONTINUE
END IF
*
* Read the values of LDA
*
READ( NIN, FMT = * )( LDAVAL( I ), I = 1, NPARMS )
DO 110 I = 1, NPARMS
IF( LDAVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9995 )'LDA ', LDAVAL( I ), 0
FATAL = .TRUE.
ELSE IF( LDAVAL( I ).GT.LDAMAX ) THEN
WRITE( NOUT, FMT = 9994 )'LDA ', LDAVAL( I ), LDAMAX
FATAL = .TRUE.
END IF
110 CONTINUE
WRITE( NOUT, FMT = 9988 )'LDA ', ( LDAVAL( I ), I = 1, NPARMS )
*
* Read the minimum time a subroutine will be timed.
*
READ( NIN, FMT = * )TIMMIN
WRITE( NOUT, FMT = 9987 )TIMMIN
*
* Read the number of matrix types to use in timing.
*
READ( NIN, FMT = * )NTYPES
IF( NTYPES.LT.0 ) THEN
WRITE( NOUT, FMT = 9995 )'NTYPES', NTYPES, 0
FATAL = .TRUE.
NTYPES = 0
END IF
*
* Read the matrix types.
*
IF( NEP ) THEN
MAXTYP = MXTYPE( 1 )
ELSE IF( SEP ) THEN
MAXTYP = MXTYPE( 2 )
ELSE IF( SVD ) THEN
MAXTYP = MXTYPE( 3 )
ELSE
MAXTYP = MXTYPE( 4 )
END IF
IF( NTYPES.LT.MAXTYP ) THEN
READ( NIN, FMT = * )( IWORK( I ), I = 1, NTYPES )
DO 120 I = 1, MAXTYP
DOTYPE( I ) = .FALSE.
120 CONTINUE
DO 130 I = 1, NTYPES
IF( IWORK( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9995 )'TYPE', IWORK( I ), 0
FATAL = .TRUE.
ELSE IF( IWORK( I ).GT.MAXTYP ) THEN
WRITE( NOUT, FMT = 9994 )'TYPE', IWORK( I ), MAXTYP
FATAL = .TRUE.
ELSE
DOTYPE( IWORK( I ) ) = .TRUE.
END IF
130 CONTINUE
ELSE
NTYPES = MAXTYP
DO 140 I = 1, MAXT
DOTYPE( I ) = .TRUE.
140 CONTINUE
END IF
*
IF( FATAL ) THEN
WRITE( NOUT, FMT = 9999 )
9999 FORMAT( / ' Execution not attempted due to input errors' )
STOP
END IF
*
* Read the input lines indicating the test path and the routines
* to be timed. The first three characters indicate the test path.
*
150 CONTINUE
READ( NIN, FMT = '(A80)', END = 160 )LINE
C3 = LINE( 1: 3 )
*
* -------------------------------------
* NEP: Nonsymmetric Eigenvalue Problem
* -------------------------------------
*
IF( LSAMEN( 3, C3, 'DHS' ) .OR. LSAMEN( 3, C3, 'NEP' ) ) THEN
CALL DTIM21( LINE, NN, NVAL, MAXTYP, DOTYPE, NPARMS, NBVAL,
$ NSVAL, MXBVAL, LDAVAL, TIMMIN, NOUT, ISEED,
$ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), D( 1, 1 ), WORK,
$ LWORK, LOGWRK, IWORK2, RESULT, MAXPRM, MAXT,
$ MAXIN, OPCNTS, MAXPRM, MAXT, MAXIN, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9986 )'DTIM21', INFO
*
* ----------------------------------
* SEP: Symmetric Eigenvalue Problem
* ----------------------------------
*
ELSE IF( LSAMEN( 3, C3, 'DST' ) .OR. LSAMEN( 3, C3, 'SEP' ) ) THEN
CALL DTIM22( LINE, NN, NVAL, MAXTYP, DOTYPE, NPARMS, NBVAL,
$ LDAVAL, TIMMIN, NOUT, ISEED, A( 1, 1 ), D( 1, 1 ),
$ D( 1, 2 ), D( 1, 3 ), A( 1, 2 ), A( 1, 3 ), WORK,
$ LWORK, LOGWRK, IWORK2, RESULT, MAXPRM, MAXT,
$ MAXIN, OPCNTS, MAXPRM, MAXT, MAXIN, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9986 )'DTIM22', INFO
*
* ----------------------------------
* SVD: Singular Value Decomposition
* ----------------------------------
*
ELSE IF( LSAMEN( 3, C3, 'DBD' ) .OR. LSAMEN( 3, C3, 'SVD' ) ) THEN
CALL DTIM26( LINE, NN, NVAL, MVAL, MAXTYP, DOTYPE, NPARMS,
$ NBVAL, LDAVAL, TIMMIN, NOUT, ISEED, A( 1, 1 ),
$ A( 1, 2 ), A( 1, 3 ), A( 1, 4 ), D( 1, 1 ),
$ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), WORK, LWORK,
$ IWORK2, LOGWRK, RESULT, MAXPRM, MAXT, MAXIN,
$ OPCNTS, MAXPRM, MAXT, MAXIN, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9986 )'DTIM26', INFO
*
* -------------------------------------------------
* GEP: Generalized Nonsymmetric Eigenvalue Problem
* -------------------------------------------------
*
ELSE IF( LSAMEN( 3, C3, 'DHG' ) .OR. LSAMEN( 3, C3, 'GEP' ) ) THEN
CALL DTIM51( LINE, NN, NVAL, MAXTYP, DOTYPE, NPARMS, NBVAL,
$ NSVAL, MXBVAL, NBMVAL, NBKVAL, LDAVAL, TIMMIN,
$ NOUT, ISEED, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
$ A( 1, 4 ), A( 1, 5 ), A( 1, 6 ), D( 1, 1 ), WORK,
$ LWORK, LOGWRK, RESULT, MAXPRM, MAXT, MAXIN,
$ OPCNTS, MAXPRM, MAXT, MAXIN, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9986 )'DTIM51', INFO
ELSE
WRITE( NOUT, FMT = * )
WRITE( NOUT, FMT = * )
WRITE( NOUT, FMT = 9996 )C3
END IF
GO TO 150
160 CONTINUE
WRITE( NOUT, FMT = 9998 )
9998 FORMAT( / / ' End of timing run' )
S2 = DSECND( )
WRITE( NOUT, FMT = 9997 )S2 - S1
*
9997 FORMAT( ' Total time used = ', F12.2, ' seconds', / )
9996 FORMAT( 1X, A3, ': Unrecognized path name' )
9995 FORMAT( ' *** Invalid input value: ', A6, '=', I6, '; must be >=',
$ I6 )
9994 FORMAT( ' *** Invalid input value: ', A6, '=', I6, '; must be <=',
$ I6 )
9993 FORMAT( ' Timing the Nonsymmetric Eigenvalue Problem routines',
$ / ' DGEHRD, DHSEQR, DTREVC, and DHSEIN' )
9992 FORMAT( ' Timing the Symmetric Eigenvalue Problem routines',
$ / ' DSYTRD, DSTEQR, and DSTERF' )
9991 FORMAT( ' Timing the Singular Value Decomposition routines',
$ / ' DGEBRD, DBDSQR, DORGBR, DBDSDC and DGESDD' )
9990 FORMAT( ' Timing the Generalized Eigenvalue Problem routines',
$ / ' DGGHRD, DHGEQZ, and DTGEVC ' )
9989 FORMAT( / ' The following parameter values will be used:' )
9988 FORMAT( ' Values of ', A5, ': ', 10I6, / 19X, 10I6 )
9987 FORMAT( / ' Minimum time a subroutine will be timed = ', F8.2,
$ ' seconds', / )
9986 FORMAT( ' *** Error code from ', A6, ' = ', I4 )
9985 FORMAT( / ' LAPACK VERSION 3.0, released June 30, 1999 ' )
*
* End of DTIMEE
*
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/eig/input_files_large/ 0000755 0001750 0001750 00000000000 11734055026 025270 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/eig/input_files_large/DGEPTIM.in 0000644 0001750 0001750 00000001424 10616163243 026711 0 ustar osallou osallou GEP: Data file for timing Generalized Nonsymmetric Eigenvalue Problem
4 Number of values of N
50 100 150 200 Values of N (dimension)
4 Number of parameter values
10 10 10 10 Values of NB (blocksize)
2 2 4 4 Values of NS (no. of shifts)
200 2 4 4 Values of MAXB (multishift crossover pt)
200 200 200 10 Values of MINNB (minimum blocksize)
200 200 200 10 Values of MINBLK (minimum blocksize)
201 201 201 201 Values of LDA (leading dimension)
0.0 Minimum time in seconds
5 Number of matrix types
DHG T T T T T T T T T T T T T T T T T T
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/eig/input_files_large/DSVDTIM.in 0000644 0001750 0001750 00000001125 10616163243 026730 0 ustar osallou osallou SVD: Data file for timing Singular Value Decomposition routines
7 Number of values of M and N
50 50 100 100 100 200 200 Values of M (row dimension)
50 100 50 100 200 100 200 Values of N (column dimension)
1 Number of values of parameters
1 Values of NB (blocksize)
201 Values of LDA (leading dimension)
0.0 Minimum time in seconds
4 Number of matrix types
1 2 3 4
DBD T T T T T T T T T T T T T T T T T T
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/eig/input_files_large/DNEPTIM.in 0000644 0001750 0001750 00000001215 10616163243 026716 0 ustar osallou osallou NEP: Data file for timing Nonsymmetric Eigenvalue Problem routines
4 Number of values of N
50 100 200 300 Values of N (dimension)
4 Number of values of parameters
1 16 32 48 Values of NB (blocksize)
4 6 8 12 Values of NS (number of shifts)
40 40 40 40 Values of MAXB (multishift crossover pt)
301 301 301 301 Values of LDA (leading dimension)
0.0 Minimum time in seconds
4 Number of matrix types
1 3 4 6
DHS T T T T T T T T T T T T
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/eig/input_files_large/DSEPTIM.in 0000644 0001750 0001750 00000001015 10616163243 026721 0 ustar osallou osallou SEP: Data file for timing Symmetric Eigenvalue Problem routines
5 Number of values of N
50 100 200 300 400 Values of N (dimension)
5 Number of values of parameters
1 16 32 48 64 Values of NB (blocksize)
401 401 401 401 401 Values of LDA (leading dimension)
0.0 Minimum time in seconds
4 Number of matrix types
DST T T T T T T T T T T T T T T T T T T T T T T T
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/timing/eig/dgeptim.in 0000644 0001750 0001750 00000001424 10616163242 023555 0 ustar osallou osallou GEP: Data file for timing Generalized Nonsymmetric Eigenvalue Problem
4 Number of values of N
10 20 30 40 Values of N (dimension)
4 Number of parameter values
10 10 10 10 Values of NB (blocksize)
2 2 4 4 Values of NS (no. of shifts)
100 2 4 4 Values of MAXB (multishift crossover pt)
100 100 100 10 Values of MINNB (minimum blocksize)
100 100 100 10 Values of MINBLK (minimum blocksize)
81 81 81 81 Values of LDA (leading dimension)
0.05 Minimum time in seconds
5 Number of matrix types
DHG T T T T T T T T T T T T T T T T T T
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/Makefile 0000644 0001750 0001750 00000001324 10616442116 021200 0 ustar osallou osallou .PHONY: lib all testers err blas lapack util
ROOT=..
include $(ROOT)/make.def
lib: util err blas lapack
javasrc:
$(MAKE) -f Makefile_javasrc
all: lib testers
testers: err blas lapack
cd $(ROOT)/$(TESTING_DIR);$(MAKE)
timers: err blas lapack
cd $(ROOT)/$(TIMING_DIR);$(MAKE)
err:
cd $(ROOT)/$(ERR_DIR);$(MAKE)
blas: util err
cd $(ROOT)/$(BLAS_DIR);$(MAKE)
lapack: util err
cd $(ROOT)/$(LAPACK_DIR);$(MAKE)
util:
cd $(ROOT)/$(UTIL_DIR);$(MAKE)
clean:
cd $(ROOT)/$(ERR_DIR);$(MAKE) clean
cd $(ROOT)/$(BLAS_DIR);$(MAKE) clean
cd $(ROOT)/$(LAPACK_DIR);$(MAKE) clean
cd $(ROOT)/$(TESTING_DIR);$(MAKE) clean
cd $(ROOT)/$(TIMING_DIR);$(MAKE) clean
cd $(ROOT)/$(UTIL_DIR);$(MAKE) clean
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/blas/ 0000755 0001750 0001750 00000000000 11734055017 020463 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/blas/blas.f 0000644 0001750 0001750 00001515500 10616442116 021560 0 ustar osallou osallou DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX)
* .. Scalar Arguments ..
INTEGER INCX,N
* ..
* .. Array Arguments ..
DOUBLE PRECISION DX(*)
* ..
*
* Purpose
* =======
*
* takes the sum of the absolute values.
* 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) GO TO 20
*
* code for increment not equal to 1
*
NINCX = N*INCX
DO 10 I = 1,NINCX,INCX
DTEMP = DTEMP + DABS(DX(I))
10 CONTINUE
DASUM = DTEMP
RETURN
*
* code for increment equal to 1
*
*
* clean-up loop
*
20 M = MOD(N,6)
IF (M.EQ.0) GO TO 40
DO 30 I = 1,M
DTEMP = DTEMP + DABS(DX(I))
30 CONTINUE
IF (N.LT.6) GO TO 60
40 MP1 = M + 1
DO 50 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))
50 CONTINUE
60 DASUM = DTEMP
RETURN
END
SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY)
* .. Scalar Arguments ..
DOUBLE PRECISION DA
INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
DOUBLE PRECISION DX(*),DY(*)
* ..
*
* Purpose
* =======
*
* constant times a vector plus a vector.
* uses unrolled loops for increments equal to one.
* 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) GO TO 20
*
* 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 10 I = 1,N
DY(IY) = DY(IY) + DA*DX(IX)
IX = IX + INCX
IY = IY + INCY
10 CONTINUE
RETURN
*
* code for both increments equal to 1
*
*
* clean-up loop
*
20 M = MOD(N,4)
IF (M.EQ.0) GO TO 40
DO 30 I = 1,M
DY(I) = DY(I) + DA*DX(I)
30 CONTINUE
IF (N.LT.4) RETURN
40 MP1 = M + 1
DO 50 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)
50 CONTINUE
RETURN
END
SUBROUTINE DCOPY(N,DX,INCX,DY,INCY)
* .. Scalar Arguments ..
INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
DOUBLE PRECISION DX(*),DY(*)
* ..
*
* Purpose
* =======
*
* copies a vector, x, to a vector, y.
* uses unrolled loops for increments equal to one.
* 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) GO TO 20
*
* 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 10 I = 1,N
DY(IY) = DX(IX)
IX = IX + INCX
IY = IY + INCY
10 CONTINUE
RETURN
*
* code for both increments equal to 1
*
*
* clean-up loop
*
20 M = MOD(N,7)
IF (M.EQ.0) GO TO 40
DO 30 I = 1,M
DY(I) = DX(I)
30 CONTINUE
IF (N.LT.7) RETURN
40 MP1 = M + 1
DO 50 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)
50 CONTINUE
RETURN
END
DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)
* .. Scalar Arguments ..
INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
DOUBLE PRECISION DX(*),DY(*)
* ..
*
* Purpose
* =======
*
* forms the dot product of two vectors.
* uses unrolled loops for increments equal to one.
* 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) GO TO 20
*
* 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 10 I = 1,N
DTEMP = DTEMP + DX(IX)*DY(IY)
IX = IX + INCX
IY = IY + INCY
10 CONTINUE
DDOT = DTEMP
RETURN
*
* code for both increments equal to 1
*
*
* clean-up loop
*
20 M = MOD(N,5)
IF (M.EQ.0) GO TO 40
DO 30 I = 1,M
DTEMP = DTEMP + DX(I)*DY(I)
30 CONTINUE
IF (N.LT.5) GO TO 60
40 MP1 = M + 1
DO 50 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)
50 CONTINUE
60 DDOT = DTEMP
RETURN
END
SUBROUTINE DGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA,BETA
INTEGER INCX,INCY,KL,KU,LDA,M,N
CHARACTER TRANS
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),X(*),Y(*)
* ..
*
* Purpose
* =======
*
* DGBMV performs one of the matrix-vector operations
*
* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y,
*
* where alpha and beta are scalars, x and y are vectors and A is an
* m by n band matrix, with kl sub-diagonals and ku super-diagonals.
*
* Arguments
* ==========
*
* TRANS - 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'*x + beta*y.
*
* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y.
*
* Unchanged on exit.
*
* M - INTEGER.
* On entry, M specifies the number of rows of the matrix A.
* M must be at least zero.
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the number of columns of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* KL - INTEGER.
* On entry, KL specifies the number of sub-diagonals of the
* matrix A. KL must satisfy 0 .le. KL.
* Unchanged on exit.
*
* KU - INTEGER.
* On entry, KU specifies the number of super-diagonals of the
* matrix A. KU must satisfy 0 .le. KU.
* Unchanged on exit.
*
* ALPHA - DOUBLE PRECISION.
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
* Before entry, the leading ( kl + ku + 1 ) by n part of the
* array A must contain the matrix of coefficients, supplied
* column by column, with the leading diagonal of the matrix in
* row ( ku + 1 ) of the array, the first super-diagonal
* starting at position 2 in row ku, the first sub-diagonal
* starting at position 1 in row ( ku + 2 ), and so on.
* Elements in the array A that do not correspond to elements
* in the band matrix (such as the top left ku by ku triangle)
* are not referenced.
* The following program segment will transfer a band matrix
* from conventional full matrix storage to band storage:
*
* DO 20, J = 1, N
* K = KU + 1 - J
* DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL )
* A( K + I, J ) = matrix( I, J )
* 10 CONTINUE
* 20 CONTINUE
*
* Unchanged on exit.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. LDA must be at least
* ( kl + ku + 1 ).
* Unchanged on exit.
*
* X - DOUBLE PRECISION array of 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.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
* BETA - DOUBLE PRECISION.
* On entry, BETA specifies the scalar beta. When BETA is
* supplied as zero then Y need not be set on input.
* Unchanged on exit.
*
* Y - DOUBLE PRECISION array of DIMENSION at least
* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
* and at least
* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
* Before entry, the incremented array Y must contain the
* vector y. On exit, Y is overwritten by the updated vector y.
*
* INCY - INTEGER.
* On entry, INCY specifies the increment for the elements of
* Y. INCY must not be zero.
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- 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,K,KUP1,KX,KY,LENX,LENY
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX,MIN
* ..
*
* 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 (KL.LT.0) THEN
INFO = 4
ELSE IF (KU.LT.0) THEN
INFO = 5
ELSE IF (LDA.LT. (KL+KU+1)) THEN
INFO = 8
ELSE IF (INCX.EQ.0) THEN
INFO = 10
ELSE IF (INCY.EQ.0) THEN
INFO = 13
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('DGBMV ',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 the band part of 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
KUP1 = KU + 1
IF (LSAME(TRANS,'N')) THEN
*
* Form y := alpha*A*x + y.
*
JX = KX
IF (INCY.EQ.1) THEN
DO 60 J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = ALPHA*X(JX)
K = KUP1 - J
DO 50 I = MAX(1,J-KU),MIN(M,J+KL)
Y(I) = Y(I) + TEMP*A(K+I,J)
50 CONTINUE
END IF
JX = JX + INCX
60 CONTINUE
ELSE
DO 80 J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = ALPHA*X(JX)
IY = KY
K = KUP1 - J
DO 70 I = MAX(1,J-KU),MIN(M,J+KL)
Y(IY) = Y(IY) + TEMP*A(K+I,J)
IY = IY + INCY
70 CONTINUE
END IF
JX = JX + INCX
IF (J.GT.KU) KY = KY + INCY
80 CONTINUE
END IF
ELSE
*
* Form y := alpha*A'*x + y.
*
JY = KY
IF (INCX.EQ.1) THEN
DO 100 J = 1,N
TEMP = ZERO
K = KUP1 - J
DO 90 I = MAX(1,J-KU),MIN(M,J+KL)
TEMP = TEMP + A(K+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
K = KUP1 - J
DO 110 I = MAX(1,J-KU),MIN(M,J+KL)
TEMP = TEMP + A(K+I,J)*X(IX)
IX = IX + INCX
110 CONTINUE
Y(JY) = Y(JY) + ALPHA*TEMP
JY = JY + INCY
IF (J.GT.KU) KX = KX + INCX
120 CONTINUE
END IF
END IF
*
RETURN
*
* End of DGBMV .
*
END
SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
* .. 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,*)
* ..
*
* Purpose
* =======
*
* DGEMM performs one of the matrix-matrix operations
*
* C := alpha*op( A )*op( B ) + beta*C,
*
* where op( X ) is one of
*
* op( X ) = X or op( X ) = X',
*
* alpha and beta are scalars, and A, B and C are matrices, with op( A )
* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix.
*
* Arguments
* ==========
*
* TRANSA - 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'.
*
* TRANSA = 'C' or 'c', op( A ) = A'.
*
* Unchanged on exit.
*
* TRANSB - CHARACTER*1.
* On entry, TRANSB specifies the form of op( B ) to be used in
* the matrix multiplication as follows:
*
* TRANSB = 'N' or 'n', op( B ) = B.
*
* TRANSB = 'T' or 't', op( B ) = B'.
*
* TRANSB = 'C' or 'c', op( B ) = B'.
*
* Unchanged on exit.
*
* M - INTEGER.
* On entry, M specifies the number of rows of the matrix
* op( A ) and of the matrix C. M must be at least zero.
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the number of columns of the matrix
* op( B ) and the number of columns of the matrix C. N must be
* at least zero.
* Unchanged on exit.
*
* K - INTEGER.
* On entry, K specifies the number of columns of the matrix
* op( A ) and the number of rows of the matrix op( B ). K must
* be at least zero.
* Unchanged on exit.
*
* ALPHA - DOUBLE PRECISION.
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
* k when TRANSA = 'N' or 'n', and is m otherwise.
* Before entry with TRANSA = 'N' or 'n', the leading m by k
* part of the array A must contain the matrix A, otherwise
* the leading k by m part of the array A must contain the
* matrix A.
* Unchanged on exit.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. When TRANSA = 'N' or 'n' then
* LDA must be at least max( 1, m ), otherwise LDA must be at
* least max( 1, k ).
* Unchanged on exit.
*
* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
* n when TRANSB = 'N' or 'n', and is k otherwise.
* Before entry with TRANSB = 'N' or 'n', the leading k by n
* part of the array B must contain the matrix B, otherwise
* the leading n by k part of the array B must contain the
* matrix B.
* Unchanged on exit.
*
* LDB - INTEGER.
* On entry, LDB specifies the first dimension of B as declared
* in the calling (sub) program. When TRANSB = 'N' or 'n' then
* LDB must be at least max( 1, k ), otherwise LDB must be at
* least max( 1, n ).
* Unchanged on exit.
*
* BETA - DOUBLE PRECISION.
* On entry, BETA specifies the scalar beta. When BETA is
* supplied as zero then C need not be set on input.
* Unchanged on exit.
*
* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
* Before entry, the leading m by n part of the array C must
* contain the matrix C, except when beta is zero, in which
* case C need not be set on entry.
* On exit, the array C is overwritten by the m by n matrix
* ( alpha*op( A )*op( B ) + beta*C ).
*
* LDC - INTEGER.
* On entry, LDC specifies the first dimension of C as declared
* in the calling (sub) program. LDC must be at least
* max( 1, m ).
* Unchanged on exit.
*
*
* 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,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
IF (B(L,J).NE.ZERO) THEN
TEMP = ALPHA*B(L,J)
DO 70 I = 1,M
C(I,J) = C(I,J) + TEMP*A(I,L)
70 CONTINUE
END IF
80 CONTINUE
90 CONTINUE
ELSE
*
* Form C := alpha*A'*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' + 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
IF (B(J,L).NE.ZERO) THEN
TEMP = ALPHA*B(J,L)
DO 150 I = 1,M
C(I,J) = C(I,J) + TEMP*A(I,L)
150 CONTINUE
END IF
160 CONTINUE
170 CONTINUE
ELSE
*
* Form C := alpha*A'*B' + 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)
* .. 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'*x + beta*y,
*
* where alpha and beta are scalars, x and y are vectors and A is an
* m by n matrix.
*
* Arguments
* ==========
*
* TRANS - 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'*x + beta*y.
*
* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y.
*
* Unchanged on exit.
*
* M - INTEGER.
* On entry, M specifies the number of rows of the matrix A.
* M must be at least zero.
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the number of columns of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* ALPHA - DOUBLE PRECISION.
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
* Before entry, the leading m by n part of the array A must
* contain the matrix of coefficients.
* Unchanged on exit.
*
* LDA - 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 ).
* Unchanged on exit.
*
* X - DOUBLE PRECISION array of 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.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
* BETA - DOUBLE PRECISION.
* On entry, BETA specifies the scalar beta. When BETA is
* supplied as zero then Y need not be set on input.
* Unchanged on exit.
*
* Y - DOUBLE PRECISION array of 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 - INTEGER.
* On entry, INCY specifies the increment for the elements of
* Y. INCY must not be zero.
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- 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
IF (X(JX).NE.ZERO) THEN
TEMP = ALPHA*X(JX)
DO 50 I = 1,M
Y(I) = Y(I) + TEMP*A(I,J)
50 CONTINUE
END IF
JX = JX + INCX
60 CONTINUE
ELSE
DO 80 J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = ALPHA*X(JX)
IY = KY
DO 70 I = 1,M
Y(IY) = Y(IY) + TEMP*A(I,J)
IY = IY + INCY
70 CONTINUE
END IF
JX = JX + INCX
80 CONTINUE
END IF
ELSE
*
* Form y := alpha*A'*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)
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA
INTEGER INCX,INCY,LDA,M,N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),X(*),Y(*)
* ..
*
* Purpose
* =======
*
* DGER performs the rank 1 operation
*
* A := alpha*x*y' + A,
*
* where alpha is a scalar, x is an m element vector, y is an n element
* vector and A is an m by n matrix.
*
* Arguments
* ==========
*
* M - INTEGER.
* On entry, M specifies the number of rows of the matrix A.
* M must be at least zero.
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the number of columns of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* ALPHA - DOUBLE PRECISION.
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* X - DOUBLE PRECISION array of dimension at least
* ( 1 + ( m - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the m
* element vector x.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
* Y - DOUBLE PRECISION array of dimension at least
* ( 1 + ( n - 1 )*abs( INCY ) ).
* Before entry, the incremented array Y must contain the n
* element vector y.
* Unchanged on exit.
*
* INCY - INTEGER.
* On entry, INCY specifies the increment for the elements of
* Y. INCY must not be zero.
* Unchanged on exit.
*
* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
* Before entry, the leading m by n part of the array A must
* contain the matrix of coefficients. On exit, A is
* overwritten by the updated matrix.
*
* LDA - 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 ).
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- 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 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)
* .. 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 )
*
*
* -- 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 DROT(N,DX,INCX,DY,INCY,C,S)
* .. Scalar Arguments ..
DOUBLE PRECISION C,S
INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
DOUBLE PRECISION DX(*),DY(*)
* ..
*
* Purpose
* =======
*
* applies a plane rotation.
* 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
* ..
IF (N.LE.0) RETURN
IF (INCX.EQ.1 .AND. INCY.EQ.1) GO TO 20
*
* 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 10 I = 1,N
DTEMP = C*DX(IX) + S*DY(IY)
DY(IY) = C*DY(IY) - S*DX(IX)
DX(IX) = DTEMP
IX = IX + INCX
IY = IY + INCY
10 CONTINUE
RETURN
*
* code for both increments equal to 1
*
20 DO 30 I = 1,N
DTEMP = C*DX(I) + S*DY(I)
DY(I) = C*DY(I) - S*DX(I)
DX(I) = DTEMP
30 CONTINUE
RETURN
END
SUBROUTINE DROTG(DA,DB,C,S)
* .. Scalar Arguments ..
DOUBLE PRECISION C,DA,DB,S
* ..
*
* Purpose
* =======
*
* construct givens plane rotation.
* jack dongarra, linpack, 3/11/78.
*
*
* .. Local Scalars ..
DOUBLE PRECISION R,ROE,SCALE,Z
* ..
* .. Intrinsic Functions ..
INTRINSIC DABS,DSIGN,DSQRT
* ..
ROE = DB
IF (DABS(DA).GT.DABS(DB)) ROE = DA
SCALE = DABS(DA) + DABS(DB)
IF (SCALE.NE.0.0d0) GO TO 10
C = 1.0d0
S = 0.0d0
R = 0.0d0
Z = 0.0d0
GO TO 20
10 R = SCALE*DSQRT((DA/SCALE)**2+ (DB/SCALE)**2)
R = DSIGN(1.0d0,ROE)*R
C = DA/R
S = DB/R
Z = 1.0d0
IF (DABS(DA).GT.DABS(DB)) Z = S
IF (DABS(DB).GE.DABS(DA) .AND. C.NE.0.0d0) Z = 1.0d0/C
20 DA = R
DB = Z
RETURN
END
SUBROUTINE DROTM(N,DX,INCX,DY,INCY,DPARAM)
* .. Scalar Arguments ..
INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
DOUBLE PRECISION DPARAM(5),DX(1),DY(1)
* ..
*
* Purpose
* =======
*
* APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX
*
* (DX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN
* (DY**T)
*
* DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE
* LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY.
* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
*
* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0
*
* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0)
* H=( ) ( ) ( ) ( )
* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0).
* SEE DROTMG FOR A DESCRIPTION OF DATA STORAGE IN DPARAM.
*
* Arguments
* =========
*
* N (input) INTEGER
* number of elements in input vector(s)
*
* DX (input/output) DOUBLE PRECISION array, dimension N
* double precision vector with 5 elements
*
* INCX (input) INTEGER
* storage spacing between elements of DX
*
* DY (input/output) DOUBLE PRECISION array, dimension N
* double precision vector with N elements
*
* INCY (input) INTEGER
* storage spacing between elements of DY
*
* DPARAM (input/output) DOUBLE PRECISION array, dimension 5
* DPARAM(1)=DFLAG
* DPARAM(2)=DH11
* DPARAM(3)=DH21
* DPARAM(4)=DH12
* DPARAM(5)=DH22
*
* =====================================================================
*
* .. Local Scalars ..
DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22,TWO,W,Z,ZERO
INTEGER I,KX,KY,NSTEPS
* ..
* .. Data statements ..
DATA ZERO,TWO/0.D0,2.D0/
* ..
*
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
*
NSTEPS = N*INCX
IF (DFLAG) 50,10,30
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
*
IF (DFLAG) 120,80,100
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
SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM)
* .. Scalar Arguments ..
DOUBLE PRECISION DD1,DD2,DX1,DY1
* ..
* .. Array Arguments ..
DOUBLE PRECISION DPARAM(5)
* ..
*
* Purpose
* =======
*
* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
* THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)*
* DY2)**T.
* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
*
* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0
*
* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0)
* H=( ) ( ) ( ) ( )
* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0).
* LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22
* RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE
* VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.)
*
* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
* OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
*
*
* Arguments
* =========
*
* DD1 (input/output) DOUBLE PRECISION
*
* DD2 (input/output) DOUBLE PRECISION
*
* DX1 (input/output) DOUBLE PRECISION
*
* DY1 (input) DOUBLE PRECISION
*
* DPARAM (input/output) DOUBLE PRECISION array, dimension 5
* DPARAM(1)=DFLAG
* DPARAM(2)=DH11
* DPARAM(3)=DH21
* DPARAM(4)=DH12
* DPARAM(5)=DH22
*
* =====================================================================
*
* .. Local Scalars ..
DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22,DP1,DP2,DQ1,DQ2,DTEMP,
+ DU,GAM,GAMSQ,ONE,RGAMSQ,TWO,ZERO
INTEGER IGO
* ..
* .. Intrinsic Functions ..
INTRINSIC DABS
* ..
* .. Data statements ..
*
DATA ZERO,ONE,TWO/0.D0,1.D0,2.D0/
DATA GAM,GAMSQ,RGAMSQ/4096.D0,16777216.D0,5.9604645D-8/
* ..
IF (.NOT.DD1.LT.ZERO) GO TO 10
* GO ZERO-H-D-AND-DX1..
GO TO 60
10 CONTINUE
* CASE-DD1-NONNEGATIVE
DP2 = DD2*DY1
IF (.NOT.DP2.EQ.ZERO) GO TO 20
DFLAG = -TWO
GO TO 260
* REGULAR-CASE..
20 CONTINUE
DP1 = DD1*DX1
DQ2 = DP2*DY1
DQ1 = DP1*DX1
*
IF (.NOT.DABS(DQ1).GT.DABS(DQ2)) GO TO 40
DH21 = -DY1/DX1
DH12 = DP2/DP1
*
DU = ONE - DH12*DH21
*
IF (.NOT.DU.LE.ZERO) GO TO 30
* GO ZERO-H-D-AND-DX1..
GO TO 60
30 CONTINUE
DFLAG = ZERO
DD1 = DD1/DU
DD2 = DD2/DU
DX1 = DX1*DU
* GO SCALE-CHECK..
GO TO 100
40 CONTINUE
IF (.NOT.DQ2.LT.ZERO) GO TO 50
* 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
* GO SCALE-CHECK
GO TO 100
* PROCEDURE..ZERO-H-D-AND-DX1..
60 CONTINUE
DFLAG = -ONE
DH11 = ZERO
DH12 = ZERO
DH21 = ZERO
DH22 = ZERO
*
DD1 = ZERO
DD2 = ZERO
DX1 = ZERO
* RETURN..
GO TO 220
* PROCEDURE..FIX-H..
70 CONTINUE
IF (.NOT.DFLAG.GE.ZERO) GO TO 90
*
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
GO TO IGO(120,150,180,210)
* PROCEDURE..SCALE-CHECK
100 CONTINUE
110 CONTINUE
IF (.NOT.DD1.LE.RGAMSQ) GO TO 130
IF (DD1.EQ.ZERO) GO TO 160
ASSIGN 120 TO IGO
* 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
ASSIGN 150 TO IGO
* 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.DABS(DD2).LE.RGAMSQ) GO TO 190
IF (DD2.EQ.ZERO) GO TO 220
ASSIGN 180 TO IGO
* 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.DABS(DD2).GE.GAMSQ) GO TO 220
ASSIGN 210 TO IGO
* FIX-H..
GO TO 70
210 CONTINUE
DD2 = DD2/GAM**2
DH21 = DH21*GAM
DH22 = DH22*GAM
GO TO 200
220 CONTINUE
IF (DFLAG) 250,230,240
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
SUBROUTINE DSBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA,BETA
INTEGER INCX,INCY,K,LDA,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),X(*),Y(*)
* ..
*
* Purpose
* =======
*
* DSBMV performs the matrix-vector operation
*
* y := alpha*A*x + beta*y,
*
* where alpha and beta are scalars, x and y are n element vectors and
* A is an n by n symmetric band matrix, with k super-diagonals.
*
* Arguments
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the band matrix A is being supplied as
* follows:
*
* UPLO = 'U' or 'u' The upper triangular part of A is
* being supplied.
*
* UPLO = 'L' or 'l' The lower triangular part of A is
* being supplied.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* K - INTEGER.
* On entry, K specifies the number of super-diagonals of the
* matrix A. K must satisfy 0 .le. K.
* Unchanged on exit.
*
* ALPHA - DOUBLE PRECISION.
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
* by n part of the array A must contain the upper triangular
* band part of the symmetric matrix, supplied column by
* column, with the leading diagonal of the matrix in row
* ( k + 1 ) of the array, the first super-diagonal starting at
* position 2 in row k, and so on. The top left k by k triangle
* of the array A is not referenced.
* The following program segment will transfer the upper
* triangular part of a symmetric band matrix from conventional
* full matrix storage to band storage:
*
* DO 20, J = 1, N
* M = K + 1 - J
* DO 10, I = MAX( 1, J - K ), J
* A( M + I, J ) = matrix( I, J )
* 10 CONTINUE
* 20 CONTINUE
*
* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
* by n part of the array A must contain the lower triangular
* band part of the symmetric matrix, supplied column by
* column, with the leading diagonal of the matrix in row 1 of
* the array, the first sub-diagonal starting at position 1 in
* row 2, and so on. The bottom right k by k triangle of the
* array A is not referenced.
* The following program segment will transfer the lower
* triangular part of a symmetric band matrix from conventional
* full matrix storage to band storage:
*
* DO 20, J = 1, N
* M = 1 - J
* DO 10, I = J, MIN( N, J + K )
* A( M + I, J ) = matrix( I, J )
* 10 CONTINUE
* 20 CONTINUE
*
* Unchanged on exit.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. LDA must be at least
* ( k + 1 ).
* Unchanged on exit.
*
* X - DOUBLE PRECISION array of DIMENSION at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the
* vector x.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
* BETA - DOUBLE PRECISION.
* On entry, BETA specifies the scalar beta.
* Unchanged on exit.
*
* Y - DOUBLE PRECISION array of DIMENSION at least
* ( 1 + ( n - 1 )*abs( INCY ) ).
* Before entry, the incremented array Y must contain the
* vector y. On exit, Y is overwritten by the updated vector y.
*
* INCY - INTEGER.
* On entry, INCY specifies the increment for the elements of
* Y. INCY must not be zero.
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- 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 TEMP1,TEMP2
INTEGER I,INFO,IX,IY,J,JX,JY,KPLUS1,KX,KY,L
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX,MIN
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
INFO = 1
ELSE IF (N.LT.0) THEN
INFO = 2
ELSE IF (K.LT.0) THEN
INFO = 3
ELSE IF (LDA.LT. (K+1)) 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('DSBMV ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
*
* Set up the start points in X and Y.
*
IF (INCX.GT.0) THEN
KX = 1
ELSE
KX = 1 - (N-1)*INCX
END IF
IF (INCY.GT.0) THEN
KY = 1
ELSE
KY = 1 - (N-1)*INCY
END IF
*
* Start the operations. In this version the elements of the array 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,N
Y(I) = ZERO
10 CONTINUE
ELSE
DO 20 I = 1,N
Y(I) = BETA*Y(I)
20 CONTINUE
END IF
ELSE
IY = KY
IF (BETA.EQ.ZERO) THEN
DO 30 I = 1,N
Y(IY) = ZERO
IY = IY + INCY
30 CONTINUE
ELSE
DO 40 I = 1,N
Y(IY) = BETA*Y(IY)
IY = IY + INCY
40 CONTINUE
END IF
END IF
END IF
IF (ALPHA.EQ.ZERO) RETURN
IF (LSAME(UPLO,'U')) THEN
*
* Form y when upper triangle of A is stored.
*
KPLUS1 = K + 1
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 60 J = 1,N
TEMP1 = ALPHA*X(J)
TEMP2 = ZERO
L = KPLUS1 - J
DO 50 I = MAX(1,J-K),J - 1
Y(I) = Y(I) + TEMP1*A(L+I,J)
TEMP2 = TEMP2 + A(L+I,J)*X(I)
50 CONTINUE
Y(J) = Y(J) + TEMP1*A(KPLUS1,J) + ALPHA*TEMP2
60 CONTINUE
ELSE
JX = KX
JY = KY
DO 80 J = 1,N
TEMP1 = ALPHA*X(JX)
TEMP2 = ZERO
IX = KX
IY = KY
L = KPLUS1 - J
DO 70 I = MAX(1,J-K),J - 1
Y(IY) = Y(IY) + TEMP1*A(L+I,J)
TEMP2 = TEMP2 + A(L+I,J)*X(IX)
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
Y(JY) = Y(JY) + TEMP1*A(KPLUS1,J) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
IF (J.GT.K) THEN
KX = KX + INCX
KY = KY + INCY
END IF
80 CONTINUE
END IF
ELSE
*
* Form y when lower triangle of A is stored.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 100 J = 1,N
TEMP1 = ALPHA*X(J)
TEMP2 = ZERO
Y(J) = Y(J) + TEMP1*A(1,J)
L = 1 - J
DO 90 I = J + 1,MIN(N,J+K)
Y(I) = Y(I) + TEMP1*A(L+I,J)
TEMP2 = TEMP2 + A(L+I,J)*X(I)
90 CONTINUE
Y(J) = Y(J) + ALPHA*TEMP2
100 CONTINUE
ELSE
JX = KX
JY = KY
DO 120 J = 1,N
TEMP1 = ALPHA*X(JX)
TEMP2 = ZERO
Y(JY) = Y(JY) + TEMP1*A(1,J)
L = 1 - J
IX = JX
IY = JY
DO 110 I = J + 1,MIN(N,J+K)
IX = IX + INCX
IY = IY + INCY
Y(IY) = Y(IY) + TEMP1*A(L+I,J)
TEMP2 = TEMP2 + A(L+I,J)*X(IX)
110 CONTINUE
Y(JY) = Y(JY) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
120 CONTINUE
END IF
END IF
*
RETURN
*
* End of DSBMV .
*
END
SUBROUTINE DSCAL(N,DA,DX,INCX)
* .. Scalar Arguments ..
DOUBLE PRECISION DA
INTEGER INCX,N
* ..
* .. Array Arguments ..
DOUBLE PRECISION DX(*)
* ..
*
* Purpose
* =======
**
* scales a vector by a constant.
* uses unrolled loops for increment equal to one.
* 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) GO TO 20
*
* code for increment not equal to 1
*
NINCX = N*INCX
DO 10 I = 1,NINCX,INCX
DX(I) = DA*DX(I)
10 CONTINUE
RETURN
*
* code for increment equal to 1
*
*
* clean-up loop
*
20 M = MOD(N,5)
IF (M.EQ.0) GO TO 40
DO 30 I = 1,M
DX(I) = DA*DX(I)
30 CONTINUE
IF (N.LT.5) RETURN
40 MP1 = M + 1
DO 50 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)
50 CONTINUE
RETURN
END
SUBROUTINE DSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY)
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA,BETA
INTEGER INCX,INCY,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP(*),X(*),Y(*)
* ..
*
* Purpose
* =======
*
* DSPMV performs the matrix-vector operation
*
* y := alpha*A*x + beta*y,
*
* where alpha and beta are scalars, x and y are n element vectors and
* A is an n by n symmetric matrix, supplied in packed form.
*
* Arguments
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the matrix A is supplied in the packed
* array AP as follows:
*
* UPLO = 'U' or 'u' The upper triangular part of A is
* supplied in AP.
*
* UPLO = 'L' or 'l' The lower triangular part of A is
* supplied in AP.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* ALPHA - DOUBLE PRECISION.
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* AP - DOUBLE PRECISION array of DIMENSION at least
* ( ( n*( n + 1 ) )/2 ).
* Before entry with UPLO = 'U' or 'u', the array AP must
* contain the upper triangular part of the symmetric matrix
* packed sequentially, column by column, so that AP( 1 )
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
* and a( 2, 2 ) respectively, and so on.
* Before entry with UPLO = 'L' or 'l', the array AP must
* contain the lower triangular part of the symmetric matrix
* packed sequentially, column by column, so that AP( 1 )
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
* and a( 3, 1 ) respectively, and so on.
* Unchanged on exit.
*
* X - DOUBLE PRECISION array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
* BETA - DOUBLE PRECISION.
* On entry, BETA specifies the scalar beta. When BETA is
* supplied as zero then Y need not be set on input.
* Unchanged on exit.
*
* Y - DOUBLE PRECISION array of dimension at least
* ( 1 + ( n - 1 )*abs( INCY ) ).
* Before entry, the incremented array Y must contain the n
* element vector y. On exit, Y is overwritten by the updated
* vector y.
*
* INCY - INTEGER.
* On entry, INCY specifies the increment for the elements of
* Y. INCY must not be zero.
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- 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 TEMP1,TEMP2
INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
INFO = 1
ELSE IF (N.LT.0) THEN
INFO = 2
ELSE IF (INCX.EQ.0) THEN
INFO = 6
ELSE IF (INCY.EQ.0) THEN
INFO = 9
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('DSPMV ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
*
* Set up the start points in X and Y.
*
IF (INCX.GT.0) THEN
KX = 1
ELSE
KX = 1 - (N-1)*INCX
END IF
IF (INCY.GT.0) THEN
KY = 1
ELSE
KY = 1 - (N-1)*INCY
END IF
*
* Start the operations. In this version the elements of the array AP
* are accessed sequentially with one pass through AP.
*
* First form y := beta*y.
*
IF (BETA.NE.ONE) THEN
IF (INCY.EQ.1) THEN
IF (BETA.EQ.ZERO) THEN
DO 10 I = 1,N
Y(I) = ZERO
10 CONTINUE
ELSE
DO 20 I = 1,N
Y(I) = BETA*Y(I)
20 CONTINUE
END IF
ELSE
IY = KY
IF (BETA.EQ.ZERO) THEN
DO 30 I = 1,N
Y(IY) = ZERO
IY = IY + INCY
30 CONTINUE
ELSE
DO 40 I = 1,N
Y(IY) = BETA*Y(IY)
IY = IY + INCY
40 CONTINUE
END IF
END IF
END IF
IF (ALPHA.EQ.ZERO) RETURN
KK = 1
IF (LSAME(UPLO,'U')) THEN
*
* Form y when AP contains the upper triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 60 J = 1,N
TEMP1 = ALPHA*X(J)
TEMP2 = ZERO
K = KK
DO 50 I = 1,J - 1
Y(I) = Y(I) + TEMP1*AP(K)
TEMP2 = TEMP2 + AP(K)*X(I)
K = K + 1
50 CONTINUE
Y(J) = Y(J) + TEMP1*AP(KK+J-1) + ALPHA*TEMP2
KK = KK + J
60 CONTINUE
ELSE
JX = KX
JY = KY
DO 80 J = 1,N
TEMP1 = ALPHA*X(JX)
TEMP2 = ZERO
IX = KX
IY = KY
DO 70 K = KK,KK + J - 2
Y(IY) = Y(IY) + TEMP1*AP(K)
TEMP2 = TEMP2 + AP(K)*X(IX)
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
Y(JY) = Y(JY) + TEMP1*AP(KK+J-1) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
KK = KK + J
80 CONTINUE
END IF
ELSE
*
* Form y when AP contains the lower triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 100 J = 1,N
TEMP1 = ALPHA*X(J)
TEMP2 = ZERO
Y(J) = Y(J) + TEMP1*AP(KK)
K = KK + 1
DO 90 I = J + 1,N
Y(I) = Y(I) + TEMP1*AP(K)
TEMP2 = TEMP2 + AP(K)*X(I)
K = K + 1
90 CONTINUE
Y(J) = Y(J) + ALPHA*TEMP2
KK = KK + (N-J+1)
100 CONTINUE
ELSE
JX = KX
JY = KY
DO 120 J = 1,N
TEMP1 = ALPHA*X(JX)
TEMP2 = ZERO
Y(JY) = Y(JY) + TEMP1*AP(KK)
IX = JX
IY = JY
DO 110 K = KK + 1,KK + N - J
IX = IX + INCX
IY = IY + INCY
Y(IY) = Y(IY) + TEMP1*AP(K)
TEMP2 = TEMP2 + AP(K)*X(IX)
110 CONTINUE
Y(JY) = Y(JY) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
KK = KK + (N-J+1)
120 CONTINUE
END IF
END IF
*
RETURN
*
* End of DSPMV .
*
END
SUBROUTINE DSPR(UPLO,N,ALPHA,X,INCX,AP)
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA
INTEGER INCX,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP(*),X(*)
* ..
*
* Purpose
* =======
*
* DSPR performs the symmetric rank 1 operation
*
* A := alpha*x*x' + A,
*
* where alpha is a real scalar, x is an n element vector and A is an
* n by n symmetric matrix, supplied in packed form.
*
* Arguments
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the matrix A is supplied in the packed
* array AP as follows:
*
* UPLO = 'U' or 'u' The upper triangular part of A is
* supplied in AP.
*
* UPLO = 'L' or 'l' The lower triangular part of A is
* supplied in AP.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* ALPHA - DOUBLE PRECISION.
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* X - DOUBLE PRECISION array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
* AP - DOUBLE PRECISION array of DIMENSION at least
* ( ( n*( n + 1 ) )/2 ).
* Before entry with UPLO = 'U' or 'u', the array AP must
* contain the upper triangular part of the symmetric matrix
* packed sequentially, column by column, so that AP( 1 )
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
* and a( 2, 2 ) respectively, and so on. On exit, the array
* AP is overwritten by the upper triangular part of the
* updated matrix.
* Before entry with UPLO = 'L' or 'l', the array AP must
* contain the lower triangular part of the symmetric matrix
* packed sequentially, column by column, so that AP( 1 )
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
* and a( 3, 1 ) respectively, and so on. On exit, the array
* AP is overwritten by the lower triangular part of the
* updated matrix.
*
*
* Level 2 Blas routine.
*
* -- 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 ZERO
PARAMETER (ZERO=0.0D+0)
* ..
* .. Local Scalars ..
DOUBLE PRECISION TEMP
INTEGER I,INFO,IX,J,JX,K,KK,KX
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
INFO = 1
ELSE IF (N.LT.0) THEN
INFO = 2
ELSE IF (INCX.EQ.0) THEN
INFO = 5
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('DSPR ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
*
* Set the start point in X if the increment is not unity.
*
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 the array AP
* are accessed sequentially with one pass through AP.
*
KK = 1
IF (LSAME(UPLO,'U')) THEN
*
* Form A when upper triangle is stored in AP.
*
IF (INCX.EQ.1) THEN
DO 20 J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = ALPHA*X(J)
K = KK
DO 10 I = 1,J
AP(K) = AP(K) + X(I)*TEMP
K = K + 1
10 CONTINUE
END IF
KK = KK + J
20 CONTINUE
ELSE
JX = KX
DO 40 J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = ALPHA*X(JX)
IX = KX
DO 30 K = KK,KK + J - 1
AP(K) = AP(K) + X(IX)*TEMP
IX = IX + INCX
30 CONTINUE
END IF
JX = JX + INCX
KK = KK + J
40 CONTINUE
END IF
ELSE
*
* Form A when lower triangle is stored in AP.
*
IF (INCX.EQ.1) THEN
DO 60 J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = ALPHA*X(J)
K = KK
DO 50 I = J,N
AP(K) = AP(K) + X(I)*TEMP
K = K + 1
50 CONTINUE
END IF
KK = KK + N - J + 1
60 CONTINUE
ELSE
JX = KX
DO 80 J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = ALPHA*X(JX)
IX = JX
DO 70 K = KK,KK + N - J
AP(K) = AP(K) + X(IX)*TEMP
IX = IX + INCX
70 CONTINUE
END IF
JX = JX + INCX
KK = KK + N - J + 1
80 CONTINUE
END IF
END IF
*
RETURN
*
* End of DSPR .
*
END
SUBROUTINE DSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP)
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA
INTEGER INCX,INCY,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP(*),X(*),Y(*)
* ..
*
* Purpose
* =======
*
* DSPR2 performs the symmetric rank 2 operation
*
* A := alpha*x*y' + alpha*y*x' + A,
*
* where alpha is a scalar, x and y are n element vectors and A is an
* n by n symmetric matrix, supplied in packed form.
*
* Arguments
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the matrix A is supplied in the packed
* array AP as follows:
*
* UPLO = 'U' or 'u' The upper triangular part of A is
* supplied in AP.
*
* UPLO = 'L' or 'l' The lower triangular part of A is
* supplied in AP.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* ALPHA - DOUBLE PRECISION.
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* X - DOUBLE PRECISION array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
* Y - DOUBLE PRECISION array of dimension at least
* ( 1 + ( n - 1 )*abs( INCY ) ).
* Before entry, the incremented array Y must contain the n
* element vector y.
* Unchanged on exit.
*
* INCY - INTEGER.
* On entry, INCY specifies the increment for the elements of
* Y. INCY must not be zero.
* Unchanged on exit.
*
* AP - DOUBLE PRECISION array of DIMENSION at least
* ( ( n*( n + 1 ) )/2 ).
* Before entry with UPLO = 'U' or 'u', the array AP must
* contain the upper triangular part of the symmetric matrix
* packed sequentially, column by column, so that AP( 1 )
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
* and a( 2, 2 ) respectively, and so on. On exit, the array
* AP is overwritten by the upper triangular part of the
* updated matrix.
* Before entry with UPLO = 'L' or 'l', the array AP must
* contain the lower triangular part of the symmetric matrix
* packed sequentially, column by column, so that AP( 1 )
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
* and a( 3, 1 ) respectively, and so on. On exit, the array
* AP is overwritten by the lower triangular part of the
* updated matrix.
*
*
* Level 2 Blas routine.
*
* -- 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 ZERO
PARAMETER (ZERO=0.0D+0)
* ..
* .. Local Scalars ..
DOUBLE PRECISION TEMP1,TEMP2
INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) 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
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('DSPR2 ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
*
* Set up the start points in X and Y if the increments are not both
* unity.
*
IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN
IF (INCX.GT.0) THEN
KX = 1
ELSE
KX = 1 - (N-1)*INCX
END IF
IF (INCY.GT.0) THEN
KY = 1
ELSE
KY = 1 - (N-1)*INCY
END IF
JX = KX
JY = KY
END IF
*
* Start the operations. In this version the elements of the array AP
* are accessed sequentially with one pass through AP.
*
KK = 1
IF (LSAME(UPLO,'U')) THEN
*
* Form A when upper triangle is stored in AP.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 20 J = 1,N
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
TEMP1 = ALPHA*Y(J)
TEMP2 = ALPHA*X(J)
K = KK
DO 10 I = 1,J
AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2
K = K + 1
10 CONTINUE
END IF
KK = KK + J
20 CONTINUE
ELSE
DO 40 J = 1,N
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
TEMP1 = ALPHA*Y(JY)
TEMP2 = ALPHA*X(JX)
IX = KX
IY = KY
DO 30 K = KK,KK + J - 1
AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2
IX = IX + INCX
IY = IY + INCY
30 CONTINUE
END IF
JX = JX + INCX
JY = JY + INCY
KK = KK + J
40 CONTINUE
END IF
ELSE
*
* Form A when lower triangle is stored in AP.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 60 J = 1,N
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
TEMP1 = ALPHA*Y(J)
TEMP2 = ALPHA*X(J)
K = KK
DO 50 I = J,N
AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2
K = K + 1
50 CONTINUE
END IF
KK = KK + N - J + 1
60 CONTINUE
ELSE
DO 80 J = 1,N
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
TEMP1 = ALPHA*Y(JY)
TEMP2 = ALPHA*X(JX)
IX = JX
IY = JY
DO 70 K = KK,KK + N - J
AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
END IF
JX = JX + INCX
JY = JY + INCY
KK = KK + N - J + 1
80 CONTINUE
END IF
END IF
*
RETURN
*
* End of DSPR2 .
*
END
SUBROUTINE DSWAP(N,DX,INCX,DY,INCY)
* .. Scalar Arguments ..
INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
DOUBLE PRECISION DX(*),DY(*)
* ..
*
* Purpose
* =======
*
* interchanges two vectors.
* uses unrolled loops for increments equal one.
* 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) GO TO 20
*
* 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 10 I = 1,N
DTEMP = DX(IX)
DX(IX) = DY(IY)
DY(IY) = DTEMP
IX = IX + INCX
IY = IY + INCY
10 CONTINUE
RETURN
*
* code for both increments equal to 1
*
*
* clean-up loop
*
20 M = MOD(N,3)
IF (M.EQ.0) GO TO 40
DO 30 I = 1,M
DTEMP = DX(I)
DX(I) = DY(I)
DY(I) = DTEMP
30 CONTINUE
IF (N.LT.3) RETURN
40 MP1 = M + 1
DO 50 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
50 CONTINUE
RETURN
END
SUBROUTINE DSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA,BETA
INTEGER LDA,LDB,LDC,M,N
CHARACTER SIDE,UPLO
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
* Purpose
* =======
*
* DSYMM performs one of the matrix-matrix operations
*
* C := alpha*A*B + beta*C,
*
* or
*
* C := alpha*B*A + beta*C,
*
* where alpha and beta are scalars, A is a symmetric matrix and B and
* C are m by n matrices.
*
* Arguments
* ==========
*
* SIDE - CHARACTER*1.
* On entry, SIDE specifies whether the symmetric matrix A
* appears on the left or right in the operation as follows:
*
* SIDE = 'L' or 'l' C := alpha*A*B + beta*C,
*
* SIDE = 'R' or 'r' C := alpha*B*A + beta*C,
*
* Unchanged on exit.
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the symmetric matrix A is to be
* referenced as follows:
*
* UPLO = 'U' or 'u' Only the upper triangular part of the
* symmetric matrix is to be referenced.
*
* UPLO = 'L' or 'l' Only the lower triangular part of the
* symmetric matrix is to be referenced.
*
* Unchanged on exit.
*
* M - INTEGER.
* On entry, M specifies the number of rows of the matrix C.
* M must be at least zero.
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the number of columns of the matrix C.
* N must be at least zero.
* Unchanged on exit.
*
* ALPHA - DOUBLE PRECISION.
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
* m when SIDE = 'L' or 'l' and is n otherwise.
* Before entry with SIDE = 'L' or 'l', the m by m part of
* the array A must contain the symmetric matrix, such that
* when UPLO = 'U' or 'u', the leading m by m upper triangular
* part of the array A must contain the upper triangular part
* of the symmetric matrix and the strictly lower triangular
* part of A is not referenced, and when UPLO = 'L' or 'l',
* the leading m by m lower triangular part of the array A
* must contain the lower triangular part of the symmetric
* matrix and the strictly upper triangular part of A is not
* referenced.
* Before entry with SIDE = 'R' or 'r', the n by n part of
* the array A must contain the symmetric matrix, such that
* when UPLO = 'U' or 'u', the leading n by n upper triangular
* part of the array A must contain the upper triangular part
* of the symmetric matrix and the strictly lower triangular
* part of A is not referenced, and when UPLO = 'L' or 'l',
* the leading n by n lower triangular part of the array A
* must contain the lower triangular part of the symmetric
* matrix and the strictly upper triangular part of A is not
* referenced.
* Unchanged on exit.
*
* LDA - 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 ), otherwise LDA must be at
* least max( 1, n ).
* Unchanged on exit.
*
* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ).
* Before entry, the leading m by n part of the array B must
* contain the matrix B.
* Unchanged on exit.
*
* LDB - 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 ).
* Unchanged on exit.
*
* BETA - DOUBLE PRECISION.
* On entry, BETA specifies the scalar beta. When BETA is
* supplied as zero then C need not be set on input.
* Unchanged on exit.
*
* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
* Before entry, the leading m by n part of the array C must
* contain the matrix C, except when beta is zero, in which
* case C need not be set on entry.
* On exit, the array C is overwritten by the m by n updated
* matrix.
*
* LDC - INTEGER.
* On entry, LDC specifies the first dimension of C as declared
* in the calling (sub) program. LDC must be at least
* max( 1, m ).
* Unchanged on exit.
*
*
* 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 TEMP1,TEMP2
INTEGER I,INFO,J,K,NROWA
LOGICAL UPPER
* ..
* .. Parameters ..
DOUBLE PRECISION ONE,ZERO
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
* ..
*
* Set NROWA as the number of rows of A.
*
IF (LSAME(SIDE,'L')) THEN
NROWA = M
ELSE
NROWA = N
END IF
UPPER = LSAME(UPLO,'U')
*
* Test the input parameters.
*
INFO = 0
IF ((.NOT.LSAME(SIDE,'L')) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
INFO = 1
ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
INFO = 2
ELSE IF (M.LT.0) THEN
INFO = 3
ELSE IF (N.LT.0) THEN
INFO = 4
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
INFO = 7
ELSE IF (LDB.LT.MAX(1,M)) THEN
INFO = 9
ELSE IF (LDC.LT.MAX(1,M)) THEN
INFO = 12
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('DSYMM ',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
*
* And when 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 (LSAME(SIDE,'L')) THEN
*
* Form C := alpha*A*B + beta*C.
*
IF (UPPER) THEN
DO 70 J = 1,N
DO 60 I = 1,M
TEMP1 = ALPHA*B(I,J)
TEMP2 = ZERO
DO 50 K = 1,I - 1
C(K,J) = C(K,J) + TEMP1*A(K,I)
TEMP2 = TEMP2 + B(K,J)*A(K,I)
50 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = TEMP1*A(I,I) + ALPHA*TEMP2
ELSE
C(I,J) = BETA*C(I,J) + TEMP1*A(I,I) +
+ ALPHA*TEMP2
END IF
60 CONTINUE
70 CONTINUE
ELSE
DO 100 J = 1,N
DO 90 I = M,1,-1
TEMP1 = ALPHA*B(I,J)
TEMP2 = ZERO
DO 80 K = I + 1,M
C(K,J) = C(K,J) + TEMP1*A(K,I)
TEMP2 = TEMP2 + B(K,J)*A(K,I)
80 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = TEMP1*A(I,I) + ALPHA*TEMP2
ELSE
C(I,J) = BETA*C(I,J) + TEMP1*A(I,I) +
+ ALPHA*TEMP2
END IF
90 CONTINUE
100 CONTINUE
END IF
ELSE
*
* Form C := alpha*B*A + beta*C.
*
DO 170 J = 1,N
TEMP1 = ALPHA*A(J,J)
IF (BETA.EQ.ZERO) THEN
DO 110 I = 1,M
C(I,J) = TEMP1*B(I,J)
110 CONTINUE
ELSE
DO 120 I = 1,M
C(I,J) = BETA*C(I,J) + TEMP1*B(I,J)
120 CONTINUE
END IF
DO 140 K = 1,J - 1
IF (UPPER) THEN
TEMP1 = ALPHA*A(K,J)
ELSE
TEMP1 = ALPHA*A(J,K)
END IF
DO 130 I = 1,M
C(I,J) = C(I,J) + TEMP1*B(I,K)
130 CONTINUE
140 CONTINUE
DO 160 K = J + 1,N
IF (UPPER) THEN
TEMP1 = ALPHA*A(J,K)
ELSE
TEMP1 = ALPHA*A(K,J)
END IF
DO 150 I = 1,M
C(I,J) = C(I,J) + TEMP1*B(I,K)
150 CONTINUE
160 CONTINUE
170 CONTINUE
END IF
*
RETURN
*
* End of DSYMM .
*
END
SUBROUTINE DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA,BETA
INTEGER INCX,INCY,LDA,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),X(*),Y(*)
* ..
*
* Purpose
* =======
*
* DSYMV performs the matrix-vector operation
*
* y := alpha*A*x + beta*y,
*
* where alpha and beta are scalars, x and y are n element vectors and
* A is an n by n symmetric matrix.
*
* Arguments
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the array A is to be referenced as
* follows:
*
* UPLO = 'U' or 'u' Only the upper triangular part of A
* is to be referenced.
*
* UPLO = 'L' or 'l' Only the lower triangular part of A
* is to be referenced.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* ALPHA - DOUBLE PRECISION.
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U' or 'u', the leading n by n
* upper triangular part of the array A must contain the upper
* triangular part of the symmetric matrix and the strictly
* lower triangular part of A is not referenced.
* Before entry with UPLO = 'L' or 'l', the leading n by n
* lower triangular part of the array A must contain the lower
* triangular part of the symmetric matrix and the strictly
* upper triangular part of A is not referenced.
* Unchanged on exit.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. LDA must be at least
* max( 1, n ).
* Unchanged on exit.
*
* X - DOUBLE PRECISION array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
* BETA - DOUBLE PRECISION.
* On entry, BETA specifies the scalar beta. When BETA is
* supplied as zero then Y need not be set on input.
* Unchanged on exit.
*
* Y - DOUBLE PRECISION array of dimension at least
* ( 1 + ( n - 1 )*abs( INCY ) ).
* Before entry, the incremented array Y must contain the n
* element vector y. On exit, Y is overwritten by the updated
* vector y.
*
* INCY - INTEGER.
* On entry, INCY specifies the increment for the elements of
* Y. INCY must not be zero.
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- 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 TEMP1,TEMP2
INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY
* ..
* .. 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 (N.LT.0) THEN
INFO = 2
ELSE IF (LDA.LT.MAX(1,N)) THEN
INFO = 5
ELSE IF (INCX.EQ.0) THEN
INFO = 7
ELSE IF (INCY.EQ.0) THEN
INFO = 10
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('DSYMV ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
*
* Set up the start points in X and Y.
*
IF (INCX.GT.0) THEN
KX = 1
ELSE
KX = 1 - (N-1)*INCX
END IF
IF (INCY.GT.0) THEN
KY = 1
ELSE
KY = 1 - (N-1)*INCY
END IF
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through the triangular part
* of 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,N
Y(I) = ZERO
10 CONTINUE
ELSE
DO 20 I = 1,N
Y(I) = BETA*Y(I)
20 CONTINUE
END IF
ELSE
IY = KY
IF (BETA.EQ.ZERO) THEN
DO 30 I = 1,N
Y(IY) = ZERO
IY = IY + INCY
30 CONTINUE
ELSE
DO 40 I = 1,N
Y(IY) = BETA*Y(IY)
IY = IY + INCY
40 CONTINUE
END IF
END IF
END IF
IF (ALPHA.EQ.ZERO) RETURN
IF (LSAME(UPLO,'U')) THEN
*
* Form y when A is stored in upper triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 60 J = 1,N
TEMP1 = ALPHA*X(J)
TEMP2 = ZERO
DO 50 I = 1,J - 1
Y(I) = Y(I) + TEMP1*A(I,J)
TEMP2 = TEMP2 + A(I,J)*X(I)
50 CONTINUE
Y(J) = Y(J) + TEMP1*A(J,J) + ALPHA*TEMP2
60 CONTINUE
ELSE
JX = KX
JY = KY
DO 80 J = 1,N
TEMP1 = ALPHA*X(JX)
TEMP2 = ZERO
IX = KX
IY = KY
DO 70 I = 1,J - 1
Y(IY) = Y(IY) + TEMP1*A(I,J)
TEMP2 = TEMP2 + A(I,J)*X(IX)
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
Y(JY) = Y(JY) + TEMP1*A(J,J) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
80 CONTINUE
END IF
ELSE
*
* Form y when A is stored in lower triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 100 J = 1,N
TEMP1 = ALPHA*X(J)
TEMP2 = ZERO
Y(J) = Y(J) + TEMP1*A(J,J)
DO 90 I = J + 1,N
Y(I) = Y(I) + TEMP1*A(I,J)
TEMP2 = TEMP2 + A(I,J)*X(I)
90 CONTINUE
Y(J) = Y(J) + ALPHA*TEMP2
100 CONTINUE
ELSE
JX = KX
JY = KY
DO 120 J = 1,N
TEMP1 = ALPHA*X(JX)
TEMP2 = ZERO
Y(JY) = Y(JY) + TEMP1*A(J,J)
IX = JX
IY = JY
DO 110 I = J + 1,N
IX = IX + INCX
IY = IY + INCY
Y(IY) = Y(IY) + TEMP1*A(I,J)
TEMP2 = TEMP2 + A(I,J)*X(IX)
110 CONTINUE
Y(JY) = Y(JY) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
120 CONTINUE
END IF
END IF
*
RETURN
*
* End of DSYMV .
*
END
SUBROUTINE DSYR(UPLO,N,ALPHA,X,INCX,A,LDA)
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA
INTEGER INCX,LDA,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),X(*)
* ..
*
* Purpose
* =======
*
* DSYR performs the symmetric rank 1 operation
*
* A := alpha*x*x' + A,
*
* where alpha is a real scalar, x is an n element vector and A is an
* n by n symmetric matrix.
*
* Arguments
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the array A is to be referenced as
* follows:
*
* UPLO = 'U' or 'u' Only the upper triangular part of A
* is to be referenced.
*
* UPLO = 'L' or 'l' Only the lower triangular part of A
* is to be referenced.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* ALPHA - DOUBLE PRECISION.
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* X - DOUBLE PRECISION array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U' or 'u', the leading n by n
* upper triangular part of the array A must contain the upper
* triangular part of the symmetric matrix and the strictly
* lower triangular part of A is not referenced. On exit, the
* upper triangular part of the array A is overwritten by the
* upper triangular part of the updated matrix.
* Before entry with UPLO = 'L' or 'l', the leading n by n
* lower triangular part of the array A must contain the lower
* triangular part of the symmetric matrix and the strictly
* upper triangular part of A is not referenced. On exit, the
* lower triangular part of the array A is overwritten by the
* lower triangular part of the updated matrix.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. LDA must be at least
* max( 1, n ).
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- 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 ZERO
PARAMETER (ZERO=0.0D+0)
* ..
* .. Local Scalars ..
DOUBLE PRECISION TEMP
INTEGER I,INFO,IX,J,JX,KX
* ..
* .. 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 (N.LT.0) THEN
INFO = 2
ELSE IF (INCX.EQ.0) THEN
INFO = 5
ELSE IF (LDA.LT.MAX(1,N)) THEN
INFO = 7
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('DSYR ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
*
* Set the start point in X if the increment is not unity.
*
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 the triangular part
* of A.
*
IF (LSAME(UPLO,'U')) THEN
*
* Form A when A is stored in upper triangle.
*
IF (INCX.EQ.1) THEN
DO 20 J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = ALPHA*X(J)
DO 10 I = 1,J
A(I,J) = A(I,J) + X(I)*TEMP
10 CONTINUE
END IF
20 CONTINUE
ELSE
JX = KX
DO 40 J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = ALPHA*X(JX)
IX = KX
DO 30 I = 1,J
A(I,J) = A(I,J) + X(IX)*TEMP
IX = IX + INCX
30 CONTINUE
END IF
JX = JX + INCX
40 CONTINUE
END IF
ELSE
*
* Form A when A is stored in lower triangle.
*
IF (INCX.EQ.1) THEN
DO 60 J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = ALPHA*X(J)
DO 50 I = J,N
A(I,J) = A(I,J) + X(I)*TEMP
50 CONTINUE
END IF
60 CONTINUE
ELSE
JX = KX
DO 80 J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = ALPHA*X(JX)
IX = JX
DO 70 I = J,N
A(I,J) = A(I,J) + X(IX)*TEMP
IX = IX + INCX
70 CONTINUE
END IF
JX = JX + INCX
80 CONTINUE
END IF
END IF
*
RETURN
*
* End of DSYR .
*
END
SUBROUTINE DSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA)
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA
INTEGER INCX,INCY,LDA,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),X(*),Y(*)
* ..
*
* Purpose
* =======
*
* DSYR2 performs the symmetric rank 2 operation
*
* A := alpha*x*y' + alpha*y*x' + A,
*
* where alpha is a scalar, x and y are n element vectors and A is an n
* by n symmetric matrix.
*
* Arguments
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the array A is to be referenced as
* follows:
*
* UPLO = 'U' or 'u' Only the upper triangular part of A
* is to be referenced.
*
* UPLO = 'L' or 'l' Only the lower triangular part of A
* is to be referenced.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* ALPHA - DOUBLE PRECISION.
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* X - DOUBLE PRECISION array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
* Y - DOUBLE PRECISION array of dimension at least
* ( 1 + ( n - 1 )*abs( INCY ) ).
* Before entry, the incremented array Y must contain the n
* element vector y.
* Unchanged on exit.
*
* INCY - INTEGER.
* On entry, INCY specifies the increment for the elements of
* Y. INCY must not be zero.
* Unchanged on exit.
*
* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U' or 'u', the leading n by n
* upper triangular part of the array A must contain the upper
* triangular part of the symmetric matrix and the strictly
* lower triangular part of A is not referenced. On exit, the
* upper triangular part of the array A is overwritten by the
* upper triangular part of the updated matrix.
* Before entry with UPLO = 'L' or 'l', the leading n by n
* lower triangular part of the array A must contain the lower
* triangular part of the symmetric matrix and the strictly
* upper triangular part of A is not referenced. On exit, the
* lower triangular part of the array A is overwritten by the
* lower triangular part of the updated matrix.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. LDA must be at least
* max( 1, n ).
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- 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 ZERO
PARAMETER (ZERO=0.0D+0)
* ..
* .. Local Scalars ..
DOUBLE PRECISION TEMP1,TEMP2
INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY
* ..
* .. 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 (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,N)) THEN
INFO = 9
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('DSYR2 ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
*
* Set up the start points in X and Y if the increments are not both
* unity.
*
IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN
IF (INCX.GT.0) THEN
KX = 1
ELSE
KX = 1 - (N-1)*INCX
END IF
IF (INCY.GT.0) THEN
KY = 1
ELSE
KY = 1 - (N-1)*INCY
END IF
JX = KX
JY = KY
END IF
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through the triangular part
* of A.
*
IF (LSAME(UPLO,'U')) THEN
*
* Form A when A is stored in the upper triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 20 J = 1,N
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
TEMP1 = ALPHA*Y(J)
TEMP2 = ALPHA*X(J)
DO 10 I = 1,J
A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
10 CONTINUE
END IF
20 CONTINUE
ELSE
DO 40 J = 1,N
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
TEMP1 = ALPHA*Y(JY)
TEMP2 = ALPHA*X(JX)
IX = KX
IY = KY
DO 30 I = 1,J
A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
IX = IX + INCX
IY = IY + INCY
30 CONTINUE
END IF
JX = JX + INCX
JY = JY + INCY
40 CONTINUE
END IF
ELSE
*
* Form A when A is stored in the lower triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 60 J = 1,N
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
TEMP1 = ALPHA*Y(J)
TEMP2 = ALPHA*X(J)
DO 50 I = J,N
A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
50 CONTINUE
END IF
60 CONTINUE
ELSE
DO 80 J = 1,N
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
TEMP1 = ALPHA*Y(JY)
TEMP2 = ALPHA*X(JX)
IX = JX
IY = JY
DO 70 I = J,N
A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
END IF
JX = JX + INCX
JY = JY + INCY
80 CONTINUE
END IF
END IF
*
RETURN
*
* End of DSYR2 .
*
END
SUBROUTINE DSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA,BETA
INTEGER K,LDA,LDB,LDC,N
CHARACTER TRANS,UPLO
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
* Purpose
* =======
*
* DSYR2K performs one of the symmetric rank 2k operations
*
* C := alpha*A*B' + alpha*B*A' + beta*C,
*
* or
*
* C := alpha*A'*B + alpha*B'*A + beta*C,
*
* where alpha and beta are scalars, C is an n by n symmetric matrix
* and A and B are n by k matrices in the first case and k by n
* matrices in the second case.
*
* Arguments
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the array C is to be referenced as
* follows:
*
* UPLO = 'U' or 'u' Only the upper triangular part of C
* is to be referenced.
*
* UPLO = 'L' or 'l' Only the lower triangular part of C
* is to be referenced.
*
* Unchanged on exit.
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the operation to be performed as
* follows:
*
* TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' +
* beta*C.
*
* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A +
* beta*C.
*
* TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A +
* beta*C.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix C. N must be
* at least zero.
* Unchanged on exit.
*
* K - INTEGER.
* On entry with TRANS = 'N' or 'n', K specifies the number
* of columns of the matrices A and B, and on entry with
* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number
* of rows of the matrices A and B. K must be at least zero.
* Unchanged on exit.
*
* ALPHA - DOUBLE PRECISION.
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
* k when TRANS = 'N' or 'n', and is n otherwise.
* Before entry with TRANS = 'N' or 'n', the leading n by k
* part of the array A must contain the matrix A, otherwise
* the leading k by n part of the array A must contain the
* matrix A.
* Unchanged on exit.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. When TRANS = 'N' or 'n'
* then LDA must be at least max( 1, n ), otherwise LDA must
* be at least max( 1, k ).
* Unchanged on exit.
*
* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
* k when TRANS = 'N' or 'n', and is n otherwise.
* Before entry with TRANS = 'N' or 'n', the leading n by k
* part of the array B must contain the matrix B, otherwise
* the leading k by n part of the array B must contain the
* matrix B.
* Unchanged on exit.
*
* LDB - INTEGER.
* On entry, LDB specifies the first dimension of B as declared
* in the calling (sub) program. When TRANS = 'N' or 'n'
* then LDB must be at least max( 1, n ), otherwise LDB must
* be at least max( 1, k ).
* Unchanged on exit.
*
* BETA - DOUBLE PRECISION.
* On entry, BETA specifies the scalar beta.
* Unchanged on exit.
*
* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
* Before entry with UPLO = 'U' or 'u', the leading n by n
* upper triangular part of the array C must contain the upper
* triangular part of the symmetric matrix and the strictly
* lower triangular part of C is not referenced. On exit, the
* upper triangular part of the array C is overwritten by the
* upper triangular part of the updated matrix.
* Before entry with UPLO = 'L' or 'l', the leading n by n
* lower triangular part of the array C must contain the lower
* triangular part of the symmetric matrix and the strictly
* upper triangular part of C is not referenced. On exit, the
* lower triangular part of the array C is overwritten by the
* lower triangular part of the updated matrix.
*
* LDC - INTEGER.
* On entry, LDC specifies the first dimension of C as declared
* in the calling (sub) program. LDC must be at least
* max( 1, n ).
* Unchanged on exit.
*
*
* 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 TEMP1,TEMP2
INTEGER I,INFO,J,L,NROWA
LOGICAL UPPER
* ..
* .. Parameters ..
DOUBLE PRECISION ONE,ZERO
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
* ..
*
* Test the input parameters.
*
IF (LSAME(TRANS,'N')) THEN
NROWA = N
ELSE
NROWA = K
END IF
UPPER = LSAME(UPLO,'U')
*
INFO = 0
IF ((.NOT.UPPER) .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 (N.LT.0) THEN
INFO = 3
ELSE IF (K.LT.0) THEN
INFO = 4
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
INFO = 7
ELSE IF (LDB.LT.MAX(1,NROWA)) THEN
INFO = 9
ELSE IF (LDC.LT.MAX(1,N)) THEN
INFO = 12
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('DSYR2K',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR.
+ (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
*
* And when alpha.eq.zero.
*
IF (ALPHA.EQ.ZERO) THEN
IF (UPPER) THEN
IF (BETA.EQ.ZERO) THEN
DO 20 J = 1,N
DO 10 I = 1,J
C(I,J) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1,N
DO 30 I = 1,J
C(I,J) = BETA*C(I,J)
30 CONTINUE
40 CONTINUE
END IF
ELSE
IF (BETA.EQ.ZERO) THEN
DO 60 J = 1,N
DO 50 I = J,N
C(I,J) = ZERO
50 CONTINUE
60 CONTINUE
ELSE
DO 80 J = 1,N
DO 70 I = J,N
C(I,J) = BETA*C(I,J)
70 CONTINUE
80 CONTINUE
END IF
END IF
RETURN
END IF
*
* Start the operations.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form C := alpha*A*B' + alpha*B*A' + C.
*
IF (UPPER) THEN
DO 130 J = 1,N
IF (BETA.EQ.ZERO) THEN
DO 90 I = 1,J
C(I,J) = ZERO
90 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
DO 100 I = 1,J
C(I,J) = BETA*C(I,J)
100 CONTINUE
END IF
DO 120 L = 1,K
IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
TEMP1 = ALPHA*B(J,L)
TEMP2 = ALPHA*A(J,L)
DO 110 I = 1,J
C(I,J) = C(I,J) + A(I,L)*TEMP1 +
+ B(I,L)*TEMP2
110 CONTINUE
END IF
120 CONTINUE
130 CONTINUE
ELSE
DO 180 J = 1,N
IF (BETA.EQ.ZERO) THEN
DO 140 I = J,N
C(I,J) = ZERO
140 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
DO 150 I = J,N
C(I,J) = BETA*C(I,J)
150 CONTINUE
END IF
DO 170 L = 1,K
IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
TEMP1 = ALPHA*B(J,L)
TEMP2 = ALPHA*A(J,L)
DO 160 I = J,N
C(I,J) = C(I,J) + A(I,L)*TEMP1 +
+ B(I,L)*TEMP2
160 CONTINUE
END IF
170 CONTINUE
180 CONTINUE
END IF
ELSE
*
* Form C := alpha*A'*B + alpha*B'*A + C.
*
IF (UPPER) THEN
DO 210 J = 1,N
DO 200 I = 1,J
TEMP1 = ZERO
TEMP2 = ZERO
DO 190 L = 1,K
TEMP1 = TEMP1 + A(L,I)*B(L,J)
TEMP2 = TEMP2 + B(L,I)*A(L,J)
190 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2
ELSE
C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
+ ALPHA*TEMP2
END IF
200 CONTINUE
210 CONTINUE
ELSE
DO 240 J = 1,N
DO 230 I = J,N
TEMP1 = ZERO
TEMP2 = ZERO
DO 220 L = 1,K
TEMP1 = TEMP1 + A(L,I)*B(L,J)
TEMP2 = TEMP2 + B(L,I)*A(L,J)
220 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2
ELSE
C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
+ ALPHA*TEMP2
END IF
230 CONTINUE
240 CONTINUE
END IF
END IF
*
RETURN
*
* End of DSYR2K.
*
END
SUBROUTINE DSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA,BETA
INTEGER K,LDA,LDC,N
CHARACTER TRANS,UPLO
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),C(LDC,*)
* ..
*
* Purpose
* =======
*
* DSYRK performs one of the symmetric rank k operations
*
* C := alpha*A*A' + beta*C,
*
* or
*
* C := alpha*A'*A + beta*C,
*
* where alpha and beta are scalars, C is an n by n symmetric matrix
* and A is an n by k matrix in the first case and a k by n matrix
* in the second case.
*
* Arguments
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the array C is to be referenced as
* follows:
*
* UPLO = 'U' or 'u' Only the upper triangular part of C
* is to be referenced.
*
* UPLO = 'L' or 'l' Only the lower triangular part of C
* is to be referenced.
*
* Unchanged on exit.
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the operation to be performed as
* follows:
*
* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C.
*
* TRANS = 'T' or 't' C := alpha*A'*A + beta*C.
*
* TRANS = 'C' or 'c' C := alpha*A'*A + beta*C.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix C. N must be
* at least zero.
* Unchanged on exit.
*
* K - INTEGER.
* On entry with TRANS = 'N' or 'n', K specifies the number
* of columns of the matrix A, and on entry with
* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number
* of rows of the matrix A. K must be at least zero.
* Unchanged on exit.
*
* ALPHA - DOUBLE PRECISION.
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
* k when TRANS = 'N' or 'n', and is n otherwise.
* Before entry with TRANS = 'N' or 'n', the leading n by k
* part of the array A must contain the matrix A, otherwise
* the leading k by n part of the array A must contain the
* matrix A.
* Unchanged on exit.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. When TRANS = 'N' or 'n'
* then LDA must be at least max( 1, n ), otherwise LDA must
* be at least max( 1, k ).
* Unchanged on exit.
*
* BETA - DOUBLE PRECISION.
* On entry, BETA specifies the scalar beta.
* Unchanged on exit.
*
* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
* Before entry with UPLO = 'U' or 'u', the leading n by n
* upper triangular part of the array C must contain the upper
* triangular part of the symmetric matrix and the strictly
* lower triangular part of C is not referenced. On exit, the
* upper triangular part of the array C is overwritten by the
* upper triangular part of the updated matrix.
* Before entry with UPLO = 'L' or 'l', the leading n by n
* lower triangular part of the array C must contain the lower
* triangular part of the symmetric matrix and the strictly
* upper triangular part of C is not referenced. On exit, the
* lower triangular part of the array C is overwritten by the
* lower triangular part of the updated matrix.
*
* LDC - INTEGER.
* On entry, LDC specifies the first dimension of C as declared
* in the calling (sub) program. LDC must be at least
* max( 1, n ).
* Unchanged on exit.
*
*
* 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,L,NROWA
LOGICAL UPPER
* ..
* .. Parameters ..
DOUBLE PRECISION ONE,ZERO
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
* ..
*
* Test the input parameters.
*
IF (LSAME(TRANS,'N')) THEN
NROWA = N
ELSE
NROWA = K
END IF
UPPER = LSAME(UPLO,'U')
*
INFO = 0
IF ((.NOT.UPPER) .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 (N.LT.0) THEN
INFO = 3
ELSE IF (K.LT.0) THEN
INFO = 4
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
INFO = 7
ELSE IF (LDC.LT.MAX(1,N)) THEN
INFO = 10
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('DSYRK ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR.
+ (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
*
* And when alpha.eq.zero.
*
IF (ALPHA.EQ.ZERO) THEN
IF (UPPER) THEN
IF (BETA.EQ.ZERO) THEN
DO 20 J = 1,N
DO 10 I = 1,J
C(I,J) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1,N
DO 30 I = 1,J
C(I,J) = BETA*C(I,J)
30 CONTINUE
40 CONTINUE
END IF
ELSE
IF (BETA.EQ.ZERO) THEN
DO 60 J = 1,N
DO 50 I = J,N
C(I,J) = ZERO
50 CONTINUE
60 CONTINUE
ELSE
DO 80 J = 1,N
DO 70 I = J,N
C(I,J) = BETA*C(I,J)
70 CONTINUE
80 CONTINUE
END IF
END IF
RETURN
END IF
*
* Start the operations.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form C := alpha*A*A' + beta*C.
*
IF (UPPER) THEN
DO 130 J = 1,N
IF (BETA.EQ.ZERO) THEN
DO 90 I = 1,J
C(I,J) = ZERO
90 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
DO 100 I = 1,J
C(I,J) = BETA*C(I,J)
100 CONTINUE
END IF
DO 120 L = 1,K
IF (A(J,L).NE.ZERO) THEN
TEMP = ALPHA*A(J,L)
DO 110 I = 1,J
C(I,J) = C(I,J) + TEMP*A(I,L)
110 CONTINUE
END IF
120 CONTINUE
130 CONTINUE
ELSE
DO 180 J = 1,N
IF (BETA.EQ.ZERO) THEN
DO 140 I = J,N
C(I,J) = ZERO
140 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
DO 150 I = J,N
C(I,J) = BETA*C(I,J)
150 CONTINUE
END IF
DO 170 L = 1,K
IF (A(J,L).NE.ZERO) THEN
TEMP = ALPHA*A(J,L)
DO 160 I = J,N
C(I,J) = C(I,J) + TEMP*A(I,L)
160 CONTINUE
END IF
170 CONTINUE
180 CONTINUE
END IF
ELSE
*
* Form C := alpha*A'*A + beta*C.
*
IF (UPPER) THEN
DO 210 J = 1,N
DO 200 I = 1,J
TEMP = ZERO
DO 190 L = 1,K
TEMP = TEMP + A(L,I)*A(L,J)
190 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP
ELSE
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
END IF
200 CONTINUE
210 CONTINUE
ELSE
DO 240 J = 1,N
DO 230 I = J,N
TEMP = ZERO
DO 220 L = 1,K
TEMP = TEMP + A(L,I)*A(L,J)
220 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP
ELSE
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
END IF
230 CONTINUE
240 CONTINUE
END IF
END IF
*
RETURN
*
* End of DSYRK .
*
END
SUBROUTINE DTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
* .. Scalar Arguments ..
INTEGER INCX,K,LDA,N
CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),X(*)
* ..
*
* Purpose
* =======
*
* DTBMV performs one of the matrix-vector operations
*
* x := A*x, or x := A'*x,
*
* where x is an n element vector and A is an n by n unit, or non-unit,
* upper or lower triangular band matrix, with ( k + 1 ) diagonals.
*
* Arguments
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the matrix 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.
*
* Unchanged on exit.
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the operation to be performed as
* follows:
*
* TRANS = 'N' or 'n' x := A*x.
*
* TRANS = 'T' or 't' x := A'*x.
*
* TRANS = 'C' or 'c' x := A'*x.
*
* Unchanged on exit.
*
* DIAG - 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.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* K - INTEGER.
* On entry with UPLO = 'U' or 'u', K specifies the number of
* super-diagonals of the matrix A.
* On entry with UPLO = 'L' or 'l', K specifies the number of
* sub-diagonals of the matrix A.
* K must satisfy 0 .le. K.
* Unchanged on exit.
*
* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
* by n part of the array A must contain the upper triangular
* band part of the matrix of coefficients, supplied column by
* column, with the leading diagonal of the matrix in row
* ( k + 1 ) of the array, the first super-diagonal starting at
* position 2 in row k, and so on. The top left k by k triangle
* of the array A is not referenced.
* The following program segment will transfer an upper
* triangular band matrix from conventional full matrix storage
* to band storage:
*
* DO 20, J = 1, N
* M = K + 1 - J
* DO 10, I = MAX( 1, J - K ), J
* A( M + I, J ) = matrix( I, J )
* 10 CONTINUE
* 20 CONTINUE
*
* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
* by n part of the array A must contain the lower triangular
* band part of the matrix of coefficients, supplied column by
* column, with the leading diagonal of the matrix in row 1 of
* the array, the first sub-diagonal starting at position 1 in
* row 2, and so on. The bottom right k by k triangle of the
* array A is not referenced.
* The following program segment will transfer a lower
* triangular band matrix from conventional full matrix storage
* to band storage:
*
* DO 20, J = 1, N
* M = 1 - J
* DO 10, I = J, MIN( N, J + K )
* A( M + I, J ) = matrix( I, J )
* 10 CONTINUE
* 20 CONTINUE
*
* Note that when DIAG = 'U' or 'u' the elements of the array A
* corresponding to the diagonal elements of the matrix are not
* referenced, but are assumed to be unity.
* Unchanged on exit.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. LDA must be at least
* ( k + 1 ).
* Unchanged on exit.
*
* X - DOUBLE PRECISION array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x. On exit, X is overwritten with the
* tranformed vector x.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- 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 ZERO
PARAMETER (ZERO=0.0D+0)
* ..
* .. Local Scalars ..
DOUBLE PRECISION TEMP
INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L
LOGICAL NOUNIT
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX,MIN
* ..
*
* 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 (K.LT.0) THEN
INFO = 5
ELSE IF (LDA.LT. (K+1)) THEN
INFO = 7
ELSE IF (INCX.EQ.0) THEN
INFO = 9
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('DTBMV ',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
KPLUS1 = K + 1
IF (INCX.EQ.1) THEN
DO 20 J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = X(J)
L = KPLUS1 - J
DO 10 I = MAX(1,J-K),J - 1
X(I) = X(I) + TEMP*A(L+I,J)
10 CONTINUE
IF (NOUNIT) X(J) = X(J)*A(KPLUS1,J)
END IF
20 CONTINUE
ELSE
JX = KX
DO 40 J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = X(JX)
IX = KX
L = KPLUS1 - J
DO 30 I = MAX(1,J-K),J - 1
X(IX) = X(IX) + TEMP*A(L+I,J)
IX = IX + INCX
30 CONTINUE
IF (NOUNIT) X(JX) = X(JX)*A(KPLUS1,J)
END IF
JX = JX + INCX
IF (J.GT.K) KX = KX + 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)
L = 1 - J
DO 50 I = MIN(N,J+K),J + 1,-1
X(I) = X(I) + TEMP*A(L+I,J)
50 CONTINUE
IF (NOUNIT) X(J) = X(J)*A(1,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
L = 1 - J
DO 70 I = MIN(N,J+K),J + 1,-1
X(IX) = X(IX) + TEMP*A(L+I,J)
IX = IX - INCX
70 CONTINUE
IF (NOUNIT) X(JX) = X(JX)*A(1,J)
END IF
JX = JX - INCX
IF ((N-J).GE.K) KX = KX - INCX
80 CONTINUE
END IF
END IF
ELSE
*
* Form x := A'*x.
*
IF (LSAME(UPLO,'U')) THEN
KPLUS1 = K + 1
IF (INCX.EQ.1) THEN
DO 100 J = N,1,-1
TEMP = X(J)
L = KPLUS1 - J
IF (NOUNIT) TEMP = TEMP*A(KPLUS1,J)
DO 90 I = J - 1,MAX(1,J-K),-1
TEMP = TEMP + A(L+I,J)*X(I)
90 CONTINUE
X(J) = TEMP
100 CONTINUE
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 120 J = N,1,-1
TEMP = X(JX)
KX = KX - INCX
IX = KX
L = KPLUS1 - J
IF (NOUNIT) TEMP = TEMP*A(KPLUS1,J)
DO 110 I = J - 1,MAX(1,J-K),-1
TEMP = TEMP + A(L+I,J)*X(IX)
IX = IX - INCX
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)
L = 1 - J
IF (NOUNIT) TEMP = TEMP*A(1,J)
DO 130 I = J + 1,MIN(N,J+K)
TEMP = TEMP + A(L+I,J)*X(I)
130 CONTINUE
X(J) = TEMP
140 CONTINUE
ELSE
JX = KX
DO 160 J = 1,N
TEMP = X(JX)
KX = KX + INCX
IX = KX
L = 1 - J
IF (NOUNIT) TEMP = TEMP*A(1,J)
DO 150 I = J + 1,MIN(N,J+K)
TEMP = TEMP + A(L+I,J)*X(IX)
IX = IX + INCX
150 CONTINUE
X(JX) = TEMP
JX = JX + INCX
160 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of DTBMV .
*
END
SUBROUTINE DTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
* .. Scalar Arguments ..
INTEGER INCX,K,LDA,N
CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),X(*)
* ..
*
* Purpose
* =======
*
* DTBSV solves one of the systems of equations
*
* A*x = b, or A'*x = b,
*
* where b and x are n element vectors and A is an n by n unit, or
* non-unit, upper or lower triangular band matrix, with ( k + 1 )
* diagonals.
*
* No test for singularity or near-singularity is included in this
* routine. Such tests must be performed before calling this routine.
*
* Arguments
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the matrix 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.
*
* Unchanged on exit.
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the equations to be solved as
* follows:
*
* TRANS = 'N' or 'n' A*x = b.
*
* TRANS = 'T' or 't' A'*x = b.
*
* TRANS = 'C' or 'c' A'*x = b.
*
* Unchanged on exit.
*
* DIAG - 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.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* K - INTEGER.
* On entry with UPLO = 'U' or 'u', K specifies the number of
* super-diagonals of the matrix A.
* On entry with UPLO = 'L' or 'l', K specifies the number of
* sub-diagonals of the matrix A.
* K must satisfy 0 .le. K.
* Unchanged on exit.
*
* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
* by n part of the array A must contain the upper triangular
* band part of the matrix of coefficients, supplied column by
* column, with the leading diagonal of the matrix in row
* ( k + 1 ) of the array, the first super-diagonal starting at
* position 2 in row k, and so on. The top left k by k triangle
* of the array A is not referenced.
* The following program segment will transfer an upper
* triangular band matrix from conventional full matrix storage
* to band storage:
*
* DO 20, J = 1, N
* M = K + 1 - J
* DO 10, I = MAX( 1, J - K ), J
* A( M + I, J ) = matrix( I, J )
* 10 CONTINUE
* 20 CONTINUE
*
* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
* by n part of the array A must contain the lower triangular
* band part of the matrix of coefficients, supplied column by
* column, with the leading diagonal of the matrix in row 1 of
* the array, the first sub-diagonal starting at position 1 in
* row 2, and so on. The bottom right k by k triangle of the
* array A is not referenced.
* The following program segment will transfer a lower
* triangular band matrix from conventional full matrix storage
* to band storage:
*
* DO 20, J = 1, N
* M = 1 - J
* DO 10, I = J, MIN( N, J + K )
* A( M + I, J ) = matrix( I, J )
* 10 CONTINUE
* 20 CONTINUE
*
* Note that when DIAG = 'U' or 'u' the elements of the array A
* corresponding to the diagonal elements of the matrix are not
* referenced, but are assumed to be unity.
* Unchanged on exit.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. LDA must be at least
* ( k + 1 ).
* Unchanged on exit.
*
* X - DOUBLE PRECISION array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element right-hand side vector b. On exit, X is overwritten
* with the solution vector x.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- 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 ZERO
PARAMETER (ZERO=0.0D+0)
* ..
* .. Local Scalars ..
DOUBLE PRECISION TEMP
INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L
LOGICAL NOUNIT
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX,MIN
* ..
*
* 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 (K.LT.0) THEN
INFO = 5
ELSE IF (LDA.LT. (K+1)) THEN
INFO = 7
ELSE IF (INCX.EQ.0) THEN
INFO = 9
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('DTBSV ',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 by sequentially with one pass through A.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form x := inv( A )*x.
*
IF (LSAME(UPLO,'U')) THEN
KPLUS1 = K + 1
IF (INCX.EQ.1) THEN
DO 20 J = N,1,-1
IF (X(J).NE.ZERO) THEN
L = KPLUS1 - J
IF (NOUNIT) X(J) = X(J)/A(KPLUS1,J)
TEMP = X(J)
DO 10 I = J - 1,MAX(1,J-K),-1
X(I) = X(I) - TEMP*A(L+I,J)
10 CONTINUE
END IF
20 CONTINUE
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 40 J = N,1,-1
KX = KX - INCX
IF (X(JX).NE.ZERO) THEN
IX = KX
L = KPLUS1 - J
IF (NOUNIT) X(JX) = X(JX)/A(KPLUS1,J)
TEMP = X(JX)
DO 30 I = J - 1,MAX(1,J-K),-1
X(IX) = X(IX) - TEMP*A(L+I,J)
IX = IX - INCX
30 CONTINUE
END IF
JX = JX - INCX
40 CONTINUE
END IF
ELSE
IF (INCX.EQ.1) THEN
DO 60 J = 1,N
IF (X(J).NE.ZERO) THEN
L = 1 - J
IF (NOUNIT) X(J) = X(J)/A(1,J)
TEMP = X(J)
DO 50 I = J + 1,MIN(N,J+K)
X(I) = X(I) - TEMP*A(L+I,J)
50 CONTINUE
END IF
60 CONTINUE
ELSE
JX = KX
DO 80 J = 1,N
KX = KX + INCX
IF (X(JX).NE.ZERO) THEN
IX = KX
L = 1 - J
IF (NOUNIT) X(JX) = X(JX)/A(1,J)
TEMP = X(JX)
DO 70 I = J + 1,MIN(N,J+K)
X(IX) = X(IX) - TEMP*A(L+I,J)
IX = IX + INCX
70 CONTINUE
END IF
JX = JX + INCX
80 CONTINUE
END IF
END IF
ELSE
*
* Form x := inv( A')*x.
*
IF (LSAME(UPLO,'U')) THEN
KPLUS1 = K + 1
IF (INCX.EQ.1) THEN
DO 100 J = 1,N
TEMP = X(J)
L = KPLUS1 - J
DO 90 I = MAX(1,J-K),J - 1
TEMP = TEMP - A(L+I,J)*X(I)
90 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J)
X(J) = TEMP
100 CONTINUE
ELSE
JX = KX
DO 120 J = 1,N
TEMP = X(JX)
IX = KX
L = KPLUS1 - J
DO 110 I = MAX(1,J-K),J - 1
TEMP = TEMP - A(L+I,J)*X(IX)
IX = IX + INCX
110 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J)
X(JX) = TEMP
JX = JX + INCX
IF (J.GT.K) KX = KX + INCX
120 CONTINUE
END IF
ELSE
IF (INCX.EQ.1) THEN
DO 140 J = N,1,-1
TEMP = X(J)
L = 1 - J
DO 130 I = MIN(N,J+K),J + 1,-1
TEMP = TEMP - A(L+I,J)*X(I)
130 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(1,J)
X(J) = TEMP
140 CONTINUE
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 160 J = N,1,-1
TEMP = X(JX)
IX = KX
L = 1 - J
DO 150 I = MIN(N,J+K),J + 1,-1
TEMP = TEMP - A(L+I,J)*X(IX)
IX = IX - INCX
150 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(1,J)
X(JX) = TEMP
JX = JX - INCX
IF ((N-J).GE.K) KX = KX - INCX
160 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of DTBSV .
*
END
SUBROUTINE DTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX)
* .. Scalar Arguments ..
INTEGER INCX,N
CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP(*),X(*)
* ..
*
* Purpose
* =======
*
* DTPMV performs one of the matrix-vector operations
*
* x := A*x, or x := A'*x,
*
* where x is an n element vector and A is an n by n unit, or non-unit,
* upper or lower triangular matrix, supplied in packed form.
*
* Arguments
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the matrix 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.
*
* Unchanged on exit.
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the operation to be performed as
* follows:
*
* TRANS = 'N' or 'n' x := A*x.
*
* TRANS = 'T' or 't' x := A'*x.
*
* TRANS = 'C' or 'c' x := A'*x.
*
* Unchanged on exit.
*
* DIAG - 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.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* AP - DOUBLE PRECISION array of DIMENSION at least
* ( ( n*( n + 1 ) )/2 ).
* Before entry with UPLO = 'U' or 'u', the array AP must
* contain the upper triangular matrix packed sequentially,
* column by column, so that AP( 1 ) contains a( 1, 1 ),
* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
* respectively, and so on.
* Before entry with UPLO = 'L' or 'l', the array AP must
* contain the lower triangular matrix packed sequentially,
* column by column, so that AP( 1 ) contains a( 1, 1 ),
* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
* respectively, and so on.
* Note that when DIAG = 'U' or 'u', the diagonal elements of
* A are not referenced, but are assumed to be unity.
* Unchanged on exit.
*
* X - DOUBLE PRECISION array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x. On exit, X is overwritten with the
* tranformed vector x.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- 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 ZERO
PARAMETER (ZERO=0.0D+0)
* ..
* .. Local Scalars ..
DOUBLE PRECISION TEMP
INTEGER I,INFO,IX,J,JX,K,KK,KX
LOGICAL NOUNIT
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
*
* 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 (INCX.EQ.0) THEN
INFO = 7
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('DTPMV ',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 AP are
* accessed sequentially with one pass through AP.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form x:= A*x.
*
IF (LSAME(UPLO,'U')) THEN
KK = 1
IF (INCX.EQ.1) THEN
DO 20 J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = X(J)
K = KK
DO 10 I = 1,J - 1
X(I) = X(I) + TEMP*AP(K)
K = K + 1
10 CONTINUE
IF (NOUNIT) X(J) = X(J)*AP(KK+J-1)
END IF
KK = KK + J
20 CONTINUE
ELSE
JX = KX
DO 40 J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = X(JX)
IX = KX
DO 30 K = KK,KK + J - 2
X(IX) = X(IX) + TEMP*AP(K)
IX = IX + INCX
30 CONTINUE
IF (NOUNIT) X(JX) = X(JX)*AP(KK+J-1)
END IF
JX = JX + INCX
KK = KK + J
40 CONTINUE
END IF
ELSE
KK = (N* (N+1))/2
IF (INCX.EQ.1) THEN
DO 60 J = N,1,-1
IF (X(J).NE.ZERO) THEN
TEMP = X(J)
K = KK
DO 50 I = N,J + 1,-1
X(I) = X(I) + TEMP*AP(K)
K = K - 1
50 CONTINUE
IF (NOUNIT) X(J) = X(J)*AP(KK-N+J)
END IF
KK = KK - (N-J+1)
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 K = KK,KK - (N- (J+1)),-1
X(IX) = X(IX) + TEMP*AP(K)
IX = IX - INCX
70 CONTINUE
IF (NOUNIT) X(JX) = X(JX)*AP(KK-N+J)
END IF
JX = JX - INCX
KK = KK - (N-J+1)
80 CONTINUE
END IF
END IF
ELSE
*
* Form x := A'*x.
*
IF (LSAME(UPLO,'U')) THEN
KK = (N* (N+1))/2
IF (INCX.EQ.1) THEN
DO 100 J = N,1,-1
TEMP = X(J)
IF (NOUNIT) TEMP = TEMP*AP(KK)
K = KK - 1
DO 90 I = J - 1,1,-1
TEMP = TEMP + AP(K)*X(I)
K = K - 1
90 CONTINUE
X(J) = TEMP
KK = KK - J
100 CONTINUE
ELSE
JX = KX + (N-1)*INCX
DO 120 J = N,1,-1
TEMP = X(JX)
IX = JX
IF (NOUNIT) TEMP = TEMP*AP(KK)
DO 110 K = KK - 1,KK - J + 1,-1
IX = IX - INCX
TEMP = TEMP + AP(K)*X(IX)
110 CONTINUE
X(JX) = TEMP
JX = JX - INCX
KK = KK - J
120 CONTINUE
END IF
ELSE
KK = 1
IF (INCX.EQ.1) THEN
DO 140 J = 1,N
TEMP = X(J)
IF (NOUNIT) TEMP = TEMP*AP(KK)
K = KK + 1
DO 130 I = J + 1,N
TEMP = TEMP + AP(K)*X(I)
K = K + 1
130 CONTINUE
X(J) = TEMP
KK = KK + (N-J+1)
140 CONTINUE
ELSE
JX = KX
DO 160 J = 1,N
TEMP = X(JX)
IX = JX
IF (NOUNIT) TEMP = TEMP*AP(KK)
DO 150 K = KK + 1,KK + N - J
IX = IX + INCX
TEMP = TEMP + AP(K)*X(IX)
150 CONTINUE
X(JX) = TEMP
JX = JX + INCX
KK = KK + (N-J+1)
160 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of DTPMV .
*
END
SUBROUTINE DTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX)
* .. Scalar Arguments ..
INTEGER INCX,N
CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP(*),X(*)
* ..
*
* Purpose
* =======
*
* DTPSV solves one of the systems of equations
*
* A*x = b, or A'*x = b,
*
* where b and x are n element vectors and A is an n by n unit, or
* non-unit, upper or lower triangular matrix, supplied in packed form.
*
* No test for singularity or near-singularity is included in this
* routine. Such tests must be performed before calling this routine.
*
* Arguments
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the matrix 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.
*
* Unchanged on exit.
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the equations to be solved as
* follows:
*
* TRANS = 'N' or 'n' A*x = b.
*
* TRANS = 'T' or 't' A'*x = b.
*
* TRANS = 'C' or 'c' A'*x = b.
*
* Unchanged on exit.
*
* DIAG - 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.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* AP - DOUBLE PRECISION array of DIMENSION at least
* ( ( n*( n + 1 ) )/2 ).
* Before entry with UPLO = 'U' or 'u', the array AP must
* contain the upper triangular matrix packed sequentially,
* column by column, so that AP( 1 ) contains a( 1, 1 ),
* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
* respectively, and so on.
* Before entry with UPLO = 'L' or 'l', the array AP must
* contain the lower triangular matrix packed sequentially,
* column by column, so that AP( 1 ) contains a( 1, 1 ),
* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
* respectively, and so on.
* Note that when DIAG = 'U' or 'u', the diagonal elements of
* A are not referenced, but are assumed to be unity.
* Unchanged on exit.
*
* X - DOUBLE PRECISION array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element right-hand side vector b. On exit, X is overwritten
* with the solution vector x.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- 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 ZERO
PARAMETER (ZERO=0.0D+0)
* ..
* .. Local Scalars ..
DOUBLE PRECISION TEMP
INTEGER I,INFO,IX,J,JX,K,KK,KX
LOGICAL NOUNIT
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
*
* 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 (INCX.EQ.0) THEN
INFO = 7
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('DTPSV ',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 AP are
* accessed sequentially with one pass through AP.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form x := inv( A )*x.
*
IF (LSAME(UPLO,'U')) THEN
KK = (N* (N+1))/2
IF (INCX.EQ.1) THEN
DO 20 J = N,1,-1
IF (X(J).NE.ZERO) THEN
IF (NOUNIT) X(J) = X(J)/AP(KK)
TEMP = X(J)
K = KK - 1
DO 10 I = J - 1,1,-1
X(I) = X(I) - TEMP*AP(K)
K = K - 1
10 CONTINUE
END IF
KK = KK - J
20 CONTINUE
ELSE
JX = KX + (N-1)*INCX
DO 40 J = N,1,-1
IF (X(JX).NE.ZERO) THEN
IF (NOUNIT) X(JX) = X(JX)/AP(KK)
TEMP = X(JX)
IX = JX
DO 30 K = KK - 1,KK - J + 1,-1
IX = IX - INCX
X(IX) = X(IX) - TEMP*AP(K)
30 CONTINUE
END IF
JX = JX - INCX
KK = KK - J
40 CONTINUE
END IF
ELSE
KK = 1
IF (INCX.EQ.1) THEN
DO 60 J = 1,N
IF (X(J).NE.ZERO) THEN
IF (NOUNIT) X(J) = X(J)/AP(KK)
TEMP = X(J)
K = KK + 1
DO 50 I = J + 1,N
X(I) = X(I) - TEMP*AP(K)
K = K + 1
50 CONTINUE
END IF
KK = KK + (N-J+1)
60 CONTINUE
ELSE
JX = KX
DO 80 J = 1,N
IF (X(JX).NE.ZERO) THEN
IF (NOUNIT) X(JX) = X(JX)/AP(KK)
TEMP = X(JX)
IX = JX
DO 70 K = KK + 1,KK + N - J
IX = IX + INCX
X(IX) = X(IX) - TEMP*AP(K)
70 CONTINUE
END IF
JX = JX + INCX
KK = KK + (N-J+1)
80 CONTINUE
END IF
END IF
ELSE
*
* Form x := inv( A' )*x.
*
IF (LSAME(UPLO,'U')) THEN
KK = 1
IF (INCX.EQ.1) THEN
DO 100 J = 1,N
TEMP = X(J)
K = KK
DO 90 I = 1,J - 1
TEMP = TEMP - AP(K)*X(I)
K = K + 1
90 CONTINUE
IF (NOUNIT) TEMP = TEMP/AP(KK+J-1)
X(J) = TEMP
KK = KK + J
100 CONTINUE
ELSE
JX = KX
DO 120 J = 1,N
TEMP = X(JX)
IX = KX
DO 110 K = KK,KK + J - 2
TEMP = TEMP - AP(K)*X(IX)
IX = IX + INCX
110 CONTINUE
IF (NOUNIT) TEMP = TEMP/AP(KK+J-1)
X(JX) = TEMP
JX = JX + INCX
KK = KK + J
120 CONTINUE
END IF
ELSE
KK = (N* (N+1))/2
IF (INCX.EQ.1) THEN
DO 140 J = N,1,-1
TEMP = X(J)
K = KK
DO 130 I = N,J + 1,-1
TEMP = TEMP - AP(K)*X(I)
K = K - 1
130 CONTINUE
IF (NOUNIT) TEMP = TEMP/AP(KK-N+J)
X(J) = TEMP
KK = KK - (N-J+1)
140 CONTINUE
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 160 J = N,1,-1
TEMP = X(JX)
IX = KX
DO 150 K = KK,KK - (N- (J+1)),-1
TEMP = TEMP - AP(K)*X(IX)
IX = IX - INCX
150 CONTINUE
IF (NOUNIT) TEMP = TEMP/AP(KK-N+J)
X(JX) = TEMP
JX = JX - INCX
KK = KK - (N-J+1)
160 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of DTPSV .
*
END
SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA
INTEGER LDA,LDB,M,N
CHARACTER DIAG,SIDE,TRANSA,UPLO
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),B(LDB,*)
* ..
*
* Purpose
* =======
*
* DTRMM performs one of the matrix-matrix operations
*
* B := alpha*op( A )*B, or B := alpha*B*op( A ),
*
* where alpha is a scalar, B is an m by n matrix, 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'.
*
* Arguments
* ==========
*
* SIDE - CHARACTER*1.
* On entry, SIDE specifies whether op( A ) multiplies B from
* the left or right as follows:
*
* SIDE = 'L' or 'l' B := alpha*op( A )*B.
*
* SIDE = 'R' or 'r' B := alpha*B*op( A ).
*
* Unchanged on exit.
*
* UPLO - 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.
*
* Unchanged on exit.
*
* TRANSA - 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'.
*
* TRANSA = 'C' or 'c' op( A ) = A'.
*
* Unchanged on exit.
*
* DIAG - 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.
*
* Unchanged on exit.
*
* M - INTEGER.
* On entry, M specifies the number of rows of B. M must be at
* least zero.
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the number of columns of B. N must be
* at least zero.
* Unchanged on exit.
*
* ALPHA - 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.
* Unchanged on exit.
*
* A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m
* when SIDE = 'L' or 'l' and 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.
* Unchanged on exit.
*
* LDA - 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 ).
* Unchanged on exit.
*
* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ).
* Before entry, the leading m by n part of the array B must
* contain the matrix B, and on exit is overwritten by the
* transformed matrix.
*
* LDB - 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 ).
* Unchanged on exit.
*
*
* 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('DTRMM ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF (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'*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'.
*
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)
* .. Scalar Arguments ..
INTEGER INCX,LDA,N
CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),X(*)
* ..
*
* Purpose
* =======
*
* DTRMV performs one of the matrix-vector operations
*
* x := A*x, or x := A'*x,
*
* where x is an n element vector and A is an n by n unit, or non-unit,
* upper or lower triangular matrix.
*
* Arguments
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the matrix 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.
*
* Unchanged on exit.
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the operation to be performed as
* follows:
*
* TRANS = 'N' or 'n' x := A*x.
*
* TRANS = 'T' or 't' x := A'*x.
*
* TRANS = 'C' or 'c' x := A'*x.
*
* Unchanged on exit.
*
* DIAG - 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.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U' or 'u', the leading n by n
* 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 n by n
* 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.
* Unchanged on exit.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. LDA must be at least
* max( 1, n ).
* Unchanged on exit.
*
* X - DOUBLE PRECISION array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x. On exit, X is overwritten with the
* tranformed vector x.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- 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 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'*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)
* .. 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'.
*
* The matrix X is overwritten on B.
*
* Arguments
* ==========
*
* SIDE - 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.
*
* Unchanged on exit.
*
* UPLO - 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.
*
* Unchanged on exit.
*
* TRANSA - 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'.
*
* TRANSA = 'C' or 'c' op( A ) = A'.
*
* Unchanged on exit.
*
* DIAG - 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.
*
* Unchanged on exit.
*
* M - INTEGER.
* On entry, M specifies the number of rows of B. M must be at
* least zero.
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the number of columns of B. N must be
* at least zero.
* Unchanged on exit.
*
* ALPHA - 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.
* Unchanged on exit.
*
* A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m
* when SIDE = 'L' or 'l' and 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.
* Unchanged on exit.
*
* LDA - 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 ).
* Unchanged on exit.
*
* B - DOUBLE PRECISION array of 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 - 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 ).
* Unchanged on exit.
*
*
* 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 (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' )*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' ).
*
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
SUBROUTINE DTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
* .. Scalar Arguments ..
INTEGER INCX,LDA,N
CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),X(*)
* ..
*
* Purpose
* =======
*
* DTRSV solves one of the systems of equations
*
* A*x = b, or A'*x = b,
*
* where b and x are n element vectors and A is an n by n unit, or
* non-unit, upper or lower triangular matrix.
*
* No test for singularity or near-singularity is included in this
* routine. Such tests must be performed before calling this routine.
*
* Arguments
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the matrix 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.
*
* Unchanged on exit.
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the equations to be solved as
* follows:
*
* TRANS = 'N' or 'n' A*x = b.
*
* TRANS = 'T' or 't' A'*x = b.
*
* TRANS = 'C' or 'c' A'*x = b.
*
* Unchanged on exit.
*
* DIAG - 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.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U' or 'u', the leading n by n
* 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 n by n
* 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.
* Unchanged on exit.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. LDA must be at least
* max( 1, n ).
* Unchanged on exit.
*
* X - DOUBLE PRECISION array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element right-hand side vector b. On exit, X is overwritten
* with the solution vector x.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- 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 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('DTRSV ',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 := inv( A )*x.
*
IF (LSAME(UPLO,'U')) THEN
IF (INCX.EQ.1) THEN
DO 20 J = N,1,-1
IF (X(J).NE.ZERO) THEN
IF (NOUNIT) X(J) = X(J)/A(J,J)
TEMP = X(J)
DO 10 I = J - 1,1,-1
X(I) = X(I) - TEMP*A(I,J)
10 CONTINUE
END IF
20 CONTINUE
ELSE
JX = KX + (N-1)*INCX
DO 40 J = N,1,-1
IF (X(JX).NE.ZERO) THEN
IF (NOUNIT) X(JX) = X(JX)/A(J,J)
TEMP = X(JX)
IX = JX
DO 30 I = J - 1,1,-1
IX = IX - INCX
X(IX) = X(IX) - TEMP*A(I,J)
30 CONTINUE
END IF
JX = JX - INCX
40 CONTINUE
END IF
ELSE
IF (INCX.EQ.1) THEN
DO 60 J = 1,N
IF (X(J).NE.ZERO) THEN
IF (NOUNIT) X(J) = X(J)/A(J,J)
TEMP = X(J)
DO 50 I = J + 1,N
X(I) = X(I) - TEMP*A(I,J)
50 CONTINUE
END IF
60 CONTINUE
ELSE
JX = KX
DO 80 J = 1,N
IF (X(JX).NE.ZERO) THEN
IF (NOUNIT) X(JX) = X(JX)/A(J,J)
TEMP = X(JX)
IX = JX
DO 70 I = J + 1,N
IX = IX + INCX
X(IX) = X(IX) - TEMP*A(I,J)
70 CONTINUE
END IF
JX = JX + INCX
80 CONTINUE
END IF
END IF
ELSE
*
* Form x := inv( A' )*x.
*
IF (LSAME(UPLO,'U')) THEN
IF (INCX.EQ.1) THEN
DO 100 J = 1,N
TEMP = X(J)
DO 90 I = 1,J - 1
TEMP = TEMP - A(I,J)*X(I)
90 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(J,J)
X(J) = TEMP
100 CONTINUE
ELSE
JX = KX
DO 120 J = 1,N
TEMP = X(JX)
IX = KX
DO 110 I = 1,J - 1
TEMP = TEMP - A(I,J)*X(IX)
IX = IX + INCX
110 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(J,J)
X(JX) = TEMP
JX = JX + INCX
120 CONTINUE
END IF
ELSE
IF (INCX.EQ.1) THEN
DO 140 J = N,1,-1
TEMP = X(J)
DO 130 I = N,J + 1,-1
TEMP = TEMP - A(I,J)*X(I)
130 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(J,J)
X(J) = TEMP
140 CONTINUE
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 160 J = N,1,-1
TEMP = X(JX)
IX = KX
DO 150 I = N,J + 1,-1
TEMP = TEMP - A(I,J)*X(IX)
IX = IX - INCX
150 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(J,J)
X(JX) = TEMP
JX = JX - INCX
160 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of DTRSV .
*
END
INTEGER FUNCTION IDAMAX(N,DX,INCX)
* .. Scalar Arguments ..
INTEGER INCX,N
* ..
* .. Array Arguments ..
DOUBLE PRECISION DX(*)
* ..
*
* Purpose
* =======
*
* finds the index of element having max. absolute value.
* 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) GO TO 20
*
* code for increment not equal to 1
*
IX = 1
DMAX = DABS(DX(1))
IX = IX + INCX
DO 10 I = 2,N
IF (DABS(DX(IX)).LE.DMAX) GO TO 5
IDAMAX = I
DMAX = DABS(DX(IX))
5 IX = IX + INCX
10 CONTINUE
RETURN
*
* code for increment equal to 1
*
20 DMAX = DABS(DX(1))
DO 30 I = 2,N
IF (DABS(DX(I)).LE.DMAX) GO TO 30
IDAMAX = I
DMAX = DABS(DX(I))
30 CONTINUE
RETURN
END
INTEGER FUNCTION ISAMAX(N,SX,INCX)
* .. Scalar Arguments ..
INTEGER INCX,N
* ..
* .. Array Arguments ..
REAL SX(*)
* ..
*
* Purpose
* =======
*
* finds the index of element having max. absolute value.
* 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 ..
REAL SMAX
INTEGER I,IX
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
ISAMAX = 0
IF (N.LT.1 .OR. INCX.LE.0) RETURN
ISAMAX = 1
IF (N.EQ.1) RETURN
IF (INCX.EQ.1) GO TO 20
*
* code for increment not equal to 1
*
IX = 1
SMAX = ABS(SX(1))
IX = IX + INCX
DO 10 I = 2,N
IF (ABS(SX(IX)).LE.SMAX) GO TO 5
ISAMAX = I
SMAX = ABS(SX(IX))
5 IX = IX + INCX
10 CONTINUE
RETURN
*
* code for increment equal to 1
*
20 SMAX = ABS(SX(1))
DO 30 I = 2,N
IF (ABS(SX(I)).LE.SMAX) GO TO 30
ISAMAX = I
SMAX = ABS(SX(I))
30 CONTINUE
RETURN
END
LOGICAL FUNCTION LSAME(CA,CB)
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER CA,CB
* ..
*
* Purpose
* =======
*
* LSAME returns .TRUE. if CA is the same letter as CB regardless of
* case.
*
* Arguments
* =========
*
* CA (input) CHARACTER*1
*
* CB (input) 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
REAL FUNCTION SASUM(N,SX,INCX)
* .. Scalar Arguments ..
INTEGER INCX,N
* ..
* .. Array Arguments ..
REAL SX(*)
* ..
*
* Purpose
* =======
*
* takes the sum of the absolute values.
* uses unrolled loops for increment equal to one.
* 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 ..
REAL STEMP
INTEGER I,M,MP1,NINCX
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS,MOD
* ..
SASUM = 0.0e0
STEMP = 0.0e0
IF (N.LE.0 .OR. INCX.LE.0) RETURN
IF (INCX.EQ.1) GO TO 20
*
* code for increment not equal to 1
*
NINCX = N*INCX
DO 10 I = 1,NINCX,INCX
STEMP = STEMP + ABS(SX(I))
10 CONTINUE
SASUM = STEMP
RETURN
*
* code for increment equal to 1
*
*
* clean-up loop
*
20 M = MOD(N,6)
IF (M.EQ.0) GO TO 40
DO 30 I = 1,M
STEMP = STEMP + ABS(SX(I))
30 CONTINUE
IF (N.LT.6) GO TO 60
40 MP1 = M + 1
DO 50 I = MP1,N,6
STEMP = STEMP + ABS(SX(I)) + ABS(SX(I+1)) + ABS(SX(I+2)) +
+ ABS(SX(I+3)) + ABS(SX(I+4)) + ABS(SX(I+5))
50 CONTINUE
60 SASUM = STEMP
RETURN
END
SUBROUTINE SAXPY(N,SA,SX,INCX,SY,INCY)
* .. Scalar Arguments ..
REAL SA
INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
REAL SX(*),SY(*)
* ..
*
* Purpose
* =======
*
* SAXPY constant times a vector plus a vector.
* uses unrolled loop for increments equal to one.
* 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 (SA.EQ.0.0) RETURN
IF (INCX.EQ.1 .AND. INCY.EQ.1) GO TO 20
*
* 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 10 I = 1,N
SY(IY) = SY(IY) + SA*SX(IX)
IX = IX + INCX
IY = IY + INCY
10 CONTINUE
RETURN
*
* code for both increments equal to 1
*
*
* clean-up loop
*
20 M = MOD(N,4)
IF (M.EQ.0) GO TO 40
DO 30 I = 1,M
SY(I) = SY(I) + SA*SX(I)
30 CONTINUE
IF (N.LT.4) RETURN
40 MP1 = M + 1
DO 50 I = MP1,N,4
SY(I) = SY(I) + SA*SX(I)
SY(I+1) = SY(I+1) + SA*SX(I+1)
SY(I+2) = SY(I+2) + SA*SX(I+2)
SY(I+3) = SY(I+3) + SA*SX(I+3)
50 CONTINUE
RETURN
END
SUBROUTINE SCOPY(N,SX,INCX,SY,INCY)
* .. Scalar Arguments ..
INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
REAL SX(*),SY(*)
* ..
*
* Purpose
* =======
*
* copies a vector, x, to a vector, y.
* uses unrolled loops for increments equal to 1.
* 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) GO TO 20
*
* 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 10 I = 1,N
SY(IY) = SX(IX)
IX = IX + INCX
IY = IY + INCY
10 CONTINUE
RETURN
*
* code for both increments equal to 1
*
*
* clean-up loop
*
20 M = MOD(N,7)
IF (M.EQ.0) GO TO 40
DO 30 I = 1,M
SY(I) = SX(I)
30 CONTINUE
IF (N.LT.7) RETURN
40 MP1 = M + 1
DO 50 I = MP1,N,7
SY(I) = SX(I)
SY(I+1) = SX(I+1)
SY(I+2) = SX(I+2)
SY(I+3) = SX(I+3)
SY(I+4) = SX(I+4)
SY(I+5) = SX(I+5)
SY(I+6) = SX(I+6)
50 CONTINUE
RETURN
END
REAL FUNCTION SDOT(N,SX,INCX,SY,INCY)
* .. Scalar Arguments ..
INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
REAL SX(*),SY(*)
* ..
*
* Purpose
* =======
*
* forms the dot product of two vectors.
* uses unrolled loops for increments equal to one.
* jack dongarra, linpack, 3/11/78.
* modified 12/3/93, array(1) declarations changed to array(*)
*
*
* .. Local Scalars ..
REAL STEMP
INTEGER I,IX,IY,M,MP1
* ..
* .. Intrinsic Functions ..
INTRINSIC MOD
* ..
STEMP = 0.0e0
SDOT = 0.0e0
IF (N.LE.0) RETURN
IF (INCX.EQ.1 .AND. INCY.EQ.1) GO TO 20
*
* 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 10 I = 1,N
STEMP = STEMP + SX(IX)*SY(IY)
IX = IX + INCX
IY = IY + INCY
10 CONTINUE
SDOT = STEMP
RETURN
*
* code for both increments equal to 1
*
*
* clean-up loop
*
20 M = MOD(N,5)
IF (M.EQ.0) GO TO 40
DO 30 I = 1,M
STEMP = STEMP + SX(I)*SY(I)
30 CONTINUE
IF (N.LT.5) GO TO 60
40 MP1 = M + 1
DO 50 I = MP1,N,5
STEMP = STEMP + SX(I)*SY(I) + SX(I+1)*SY(I+1) +
+ SX(I+2)*SY(I+2) + SX(I+3)*SY(I+3) + SX(I+4)*SY(I+4)
50 CONTINUE
60 SDOT = STEMP
RETURN
END
REAL FUNCTION SDSDOT(N,SB,SX,INCX,SY,INCY)
* .. Scalar Arguments ..
REAL SB
INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
REAL SX(*),SY(*)
* ..
*
* PURPOSE
* =======
*
* Compute the inner product of two vectors with extended
* precision accumulation.
*
* Returns S.P. result with dot product accumulated in D.P.
* SDSDOT = SB + sum for I = 0 to N-1 of SX(LX+I*INCX)*SY(LY+I*INCY),
* where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is
* defined in a similar way using INCY.
*
* AUTHOR
* ======
* Lawson, C. L., (JPL), Hanson, R. J., (SNLA),
* Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL)
*
* ARGUMENTS
* =========
*
* N (input) INTEGER
* number of elements in input vector(s)
*
* SB (input) REAL
* single precision scalar to be added to inner product
*
* SX (input) REAL array, dimension (N)
* single precision vector with N elements
*
* INCX (input) INTEGER
* storage spacing between elements of SX
*
* SY (input) REAL array, dimension (N)
* single precision vector with N elements
*
* INCY (input) INTEGER
* storage spacing between elements of SY
*
* SDSDOT (output) REAL
* single precision dot product (SB if N .LE. 0)
*
* REFERENCES
* ==========
*
* C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
* Krogh, Basic linear algebra subprograms for Fortran
* usage, Algorithm No. 539, Transactions on Mathematical
* Software 5, 3 (September 1979), pp. 308-323.
*
* REVISION HISTORY (YYMMDD)
* ==========================
*
* 791001 DATE WRITTEN
* 890531 Changed all specific intrinsics to generic. (WRB)
* 890831 Modified array declarations. (WRB)
* 890831 REVISION DATE from Version 3.2
* 891214 Prologue converted to Version 4.0 format. (BAB)
* 920310 Corrected definition of LX in DESCRIPTION. (WRB)
* 920501 Reformatted the REFERENCES section. (WRB)
* 070118 Reformat to LAPACK coding style
*
* =====================================================================
*
* .. Local Scalars ..
DOUBLE PRECISION DSDOT
INTEGER I,KX,KY,NS
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
DSDOT = SB
IF (N.LE.0) GO TO 30
IF (INCX.EQ.INCY .AND. INCX.GT.0) GO TO 40
*
* Code for unequal or nonpositive increments.
*
KX = 1
KY = 1
IF (INCX.LT.0) KX = 1 + (1-N)*INCX
IF (INCY.LT.0) KY = 1 + (1-N)*INCY
DO 10 I = 1,N
DSDOT = DSDOT + DBLE(SX(KX))*DBLE(SY(KY))
KX = KX + INCX
KY = KY + INCY
10 CONTINUE
30 SDSDOT = DSDOT
RETURN
*
* Code for equal and positive increments.
*
40 NS = N*INCX
DO 50 I = 1,NS,INCX
DSDOT = DSDOT + DBLE(SX(I))*DBLE(SY(I))
50 CONTINUE
SDSDOT = DSDOT
RETURN
END
SUBROUTINE SGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
* .. Scalar Arguments ..
REAL ALPHA,BETA
INTEGER INCX,INCY,KL,KU,LDA,M,N
CHARACTER TRANS
* ..
* .. Array Arguments ..
REAL A(LDA,*),X(*),Y(*)
* ..
*
* Purpose
* =======
*
* SGBMV performs one of the matrix-vector operations
*
* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y,
*
* where alpha and beta are scalars, x and y are vectors and A is an
* m by n band matrix, with kl sub-diagonals and ku super-diagonals.
*
* Arguments
* ==========
*
* TRANS - 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'*x + beta*y.
*
* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y.
*
* Unchanged on exit.
*
* M - INTEGER.
* On entry, M specifies the number of rows of the matrix A.
* M must be at least zero.
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the number of columns of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* KL - INTEGER.
* On entry, KL specifies the number of sub-diagonals of the
* matrix A. KL must satisfy 0 .le. KL.
* Unchanged on exit.
*
* KU - INTEGER.
* On entry, KU specifies the number of super-diagonals of the
* matrix A. KU must satisfy 0 .le. KU.
* Unchanged on exit.
*
* ALPHA - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, n ).
* Before entry, the leading ( kl + ku + 1 ) by n part of the
* array A must contain the matrix of coefficients, supplied
* column by column, with the leading diagonal of the matrix in
* row ( ku + 1 ) of the array, the first super-diagonal
* starting at position 2 in row ku, the first sub-diagonal
* starting at position 1 in row ( ku + 2 ), and so on.
* Elements in the array A that do not correspond to elements
* in the band matrix (such as the top left ku by ku triangle)
* are not referenced.
* The following program segment will transfer a band matrix
* from conventional full matrix storage to band storage:
*
* DO 20, J = 1, N
* K = KU + 1 - J
* DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL )
* A( K + I, J ) = matrix( I, J )
* 10 CONTINUE
* 20 CONTINUE
*
* Unchanged on exit.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. LDA must be at least
* ( kl + ku + 1 ).
* Unchanged on exit.
*
* X - REAL array of 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.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
* BETA - REAL .
* On entry, BETA specifies the scalar beta. When BETA is
* supplied as zero then Y need not be set on input.
* Unchanged on exit.
*
* Y - REAL array of DIMENSION at least
* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
* and at least
* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
* Before entry, the incremented array Y must contain the
* vector y. On exit, Y is overwritten by the updated vector y.
*
* INCY - INTEGER.
* On entry, INCY specifies the increment for the elements of
* Y. INCY must not be zero.
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- 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 ..
REAL ONE,ZERO
PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
* ..
* .. Local Scalars ..
REAL TEMP
INTEGER I,INFO,IX,IY,J,JX,JY,K,KUP1,KX,KY,LENX,LENY
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX,MIN
* ..
*
* 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 (KL.LT.0) THEN
INFO = 4
ELSE IF (KU.LT.0) THEN
INFO = 5
ELSE IF (LDA.LT. (KL+KU+1)) THEN
INFO = 8
ELSE IF (INCX.EQ.0) THEN
INFO = 10
ELSE IF (INCY.EQ.0) THEN
INFO = 13
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('SGBMV ',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 the band part of 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
KUP1 = KU + 1
IF (LSAME(TRANS,'N')) THEN
*
* Form y := alpha*A*x + y.
*
JX = KX
IF (INCY.EQ.1) THEN
DO 60 J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = ALPHA*X(JX)
K = KUP1 - J
DO 50 I = MAX(1,J-KU),MIN(M,J+KL)
Y(I) = Y(I) + TEMP*A(K+I,J)
50 CONTINUE
END IF
JX = JX + INCX
60 CONTINUE
ELSE
DO 80 J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = ALPHA*X(JX)
IY = KY
K = KUP1 - J
DO 70 I = MAX(1,J-KU),MIN(M,J+KL)
Y(IY) = Y(IY) + TEMP*A(K+I,J)
IY = IY + INCY
70 CONTINUE
END IF
JX = JX + INCX
IF (J.GT.KU) KY = KY + INCY
80 CONTINUE
END IF
ELSE
*
* Form y := alpha*A'*x + y.
*
JY = KY
IF (INCX.EQ.1) THEN
DO 100 J = 1,N
TEMP = ZERO
K = KUP1 - J
DO 90 I = MAX(1,J-KU),MIN(M,J+KL)
TEMP = TEMP + A(K+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
K = KUP1 - J
DO 110 I = MAX(1,J-KU),MIN(M,J+KL)
TEMP = TEMP + A(K+I,J)*X(IX)
IX = IX + INCX
110 CONTINUE
Y(JY) = Y(JY) + ALPHA*TEMP
JY = JY + INCY
IF (J.GT.KU) KX = KX + INCX
120 CONTINUE
END IF
END IF
*
RETURN
*
* End of SGBMV .
*
END
SUBROUTINE SGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
* .. Scalar Arguments ..
REAL ALPHA,BETA
INTEGER K,LDA,LDB,LDC,M,N
CHARACTER TRANSA,TRANSB
* ..
* .. Array Arguments ..
REAL A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
* Purpose
* =======
*
* SGEMM performs one of the matrix-matrix operations
*
* C := alpha*op( A )*op( B ) + beta*C,
*
* where op( X ) is one of
*
* op( X ) = X or op( X ) = X',
*
* alpha and beta are scalars, and A, B and C are matrices, with op( A )
* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix.
*
* Arguments
* ==========
*
* TRANSA - 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'.
*
* TRANSA = 'C' or 'c', op( A ) = A'.
*
* Unchanged on exit.
*
* TRANSB - CHARACTER*1.
* On entry, TRANSB specifies the form of op( B ) to be used in
* the matrix multiplication as follows:
*
* TRANSB = 'N' or 'n', op( B ) = B.
*
* TRANSB = 'T' or 't', op( B ) = B'.
*
* TRANSB = 'C' or 'c', op( B ) = B'.
*
* Unchanged on exit.
*
* M - INTEGER.
* On entry, M specifies the number of rows of the matrix
* op( A ) and of the matrix C. M must be at least zero.
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the number of columns of the matrix
* op( B ) and the number of columns of the matrix C. N must be
* at least zero.
* Unchanged on exit.
*
* K - INTEGER.
* On entry, K specifies the number of columns of the matrix
* op( A ) and the number of rows of the matrix op( B ). K must
* be at least zero.
* Unchanged on exit.
*
* ALPHA - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, ka ), where ka is
* k when TRANSA = 'N' or 'n', and is m otherwise.
* Before entry with TRANSA = 'N' or 'n', the leading m by k
* part of the array A must contain the matrix A, otherwise
* the leading k by m part of the array A must contain the
* matrix A.
* Unchanged on exit.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. When TRANSA = 'N' or 'n' then
* LDA must be at least max( 1, m ), otherwise LDA must be at
* least max( 1, k ).
* Unchanged on exit.
*
* B - REAL array of DIMENSION ( LDB, kb ), where kb is
* n when TRANSB = 'N' or 'n', and is k otherwise.
* Before entry with TRANSB = 'N' or 'n', the leading k by n
* part of the array B must contain the matrix B, otherwise
* the leading n by k part of the array B must contain the
* matrix B.
* Unchanged on exit.
*
* LDB - INTEGER.
* On entry, LDB specifies the first dimension of B as declared
* in the calling (sub) program. When TRANSB = 'N' or 'n' then
* LDB must be at least max( 1, k ), otherwise LDB must be at
* least max( 1, n ).
* Unchanged on exit.
*
* BETA - REAL .
* On entry, BETA specifies the scalar beta. When BETA is
* supplied as zero then C need not be set on input.
* Unchanged on exit.
*
* C - REAL array of DIMENSION ( LDC, n ).
* Before entry, the leading m by n part of the array C must
* contain the matrix C, except when beta is zero, in which
* case C need not be set on entry.
* On exit, the array C is overwritten by the m by n matrix
* ( alpha*op( A )*op( B ) + beta*C ).
*
* LDC - INTEGER.
* On entry, LDC specifies the first dimension of C as declared
* in the calling (sub) program. LDC must be at least
* max( 1, m ).
* Unchanged on exit.
*
*
* 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 ..
REAL TEMP
INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB
LOGICAL NOTA,NOTB
* ..
* .. Parameters ..
REAL ONE,ZERO
PARAMETER (ONE=1.0E+0,ZERO=0.0E+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('SGEMM ',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
IF (B(L,J).NE.ZERO) THEN
TEMP = ALPHA*B(L,J)
DO 70 I = 1,M
C(I,J) = C(I,J) + TEMP*A(I,L)
70 CONTINUE
END IF
80 CONTINUE
90 CONTINUE
ELSE
*
* Form C := alpha*A'*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' + 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
IF (B(J,L).NE.ZERO) THEN
TEMP = ALPHA*B(J,L)
DO 150 I = 1,M
C(I,J) = C(I,J) + TEMP*A(I,L)
150 CONTINUE
END IF
160 CONTINUE
170 CONTINUE
ELSE
*
* Form C := alpha*A'*B' + 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 SGEMM .
*
END
SUBROUTINE SGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
* .. Scalar Arguments ..
REAL ALPHA,BETA
INTEGER INCX,INCY,LDA,M,N
CHARACTER TRANS
* ..
* .. Array Arguments ..
REAL A(LDA,*),X(*),Y(*)
* ..
*
* Purpose
* =======
*
* SGEMV performs one of the matrix-vector operations
*
* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y,
*
* where alpha and beta are scalars, x and y are vectors and A is an
* m by n matrix.
*
* Arguments
* ==========
*
* TRANS - 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'*x + beta*y.
*
* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y.
*
* Unchanged on exit.
*
* M - INTEGER.
* On entry, M specifies the number of rows of the matrix A.
* M must be at least zero.
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the number of columns of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* ALPHA - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, n ).
* Before entry, the leading m by n part of the array A must
* contain the matrix of coefficients.
* Unchanged on exit.
*
* LDA - 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 ).
* Unchanged on exit.
*
* X - REAL array of 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.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
* BETA - REAL .
* On entry, BETA specifies the scalar beta. When BETA is
* supplied as zero then Y need not be set on input.
* Unchanged on exit.
*
* Y - REAL array of 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 - INTEGER.
* On entry, INCY specifies the increment for the elements of
* Y. INCY must not be zero.
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- 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 ..
REAL ONE,ZERO
PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
* ..
* .. Local Scalars ..
REAL 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('SGEMV ',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
IF (X(JX).NE.ZERO) THEN
TEMP = ALPHA*X(JX)
DO 50 I = 1,M
Y(I) = Y(I) + TEMP*A(I,J)
50 CONTINUE
END IF
JX = JX + INCX
60 CONTINUE
ELSE
DO 80 J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = ALPHA*X(JX)
IY = KY
DO 70 I = 1,M
Y(IY) = Y(IY) + TEMP*A(I,J)
IY = IY + INCY
70 CONTINUE
END IF
JX = JX + INCX
80 CONTINUE
END IF
ELSE
*
* Form y := alpha*A'*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 SGEMV .
*
END
SUBROUTINE SGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
* .. Scalar Arguments ..
REAL ALPHA
INTEGER INCX,INCY,LDA,M,N
* ..
* .. Array Arguments ..
REAL A(LDA,*),X(*),Y(*)
* ..
*
* Purpose
* =======
*
* SGER performs the rank 1 operation
*
* A := alpha*x*y' + A,
*
* where alpha is a scalar, x is an m element vector, y is an n element
* vector and A is an m by n matrix.
*
* Arguments
* ==========
*
* M - INTEGER.
* On entry, M specifies the number of rows of the matrix A.
* M must be at least zero.
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the number of columns of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* ALPHA - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( m - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the m
* element vector x.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
* Y - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCY ) ).
* Before entry, the incremented array Y must contain the n
* element vector y.
* Unchanged on exit.
*
* INCY - INTEGER.
* On entry, INCY specifies the increment for the elements of
* Y. INCY must not be zero.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, n ).
* Before entry, the leading m by n part of the array A must
* contain the matrix of coefficients. On exit, A is
* overwritten by the updated matrix.
*
* LDA - 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 ).
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- 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 ..
REAL ZERO
PARAMETER (ZERO=0.0E+0)
* ..
* .. Local Scalars ..
REAL 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('SGER ',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 SGER .
*
END
REAL FUNCTION SNRM2(N,X,INCX)
* .. Scalar Arguments ..
INTEGER INCX,N
* ..
* .. Array Arguments ..
REAL X(*)
* ..
*
* Purpose
* =======
*
* SNRM2 returns the euclidean norm of a vector via the function
* name, so that
*
* SNRM2 := sqrt( x'*x ).
*
* Further Details
* ===============
*
* -- This version written on 25-October-1982.
* Modified on 14-October-1993 to inline the call to SLASSQ.
* Sven Hammarling, Nag Ltd.
*
*
* .. Parameters ..
REAL ONE,ZERO
PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
* ..
* .. Local Scalars ..
REAL 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 SLASSQ( 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
*
SNRM2 = NORM
RETURN
*
* End of SNRM2.
*
END
SUBROUTINE SROT(N,SX,INCX,SY,INCY,C,S)
* .. Scalar Arguments ..
REAL C,S
INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
REAL SX(*),SY(*)
* ..
*
* Purpose
* =======
*
* applies a plane rotation.
*
* Further Details
* ===============
*
* jack dongarra, linpack, 3/11/78.
* modified 12/3/93, array(1) declarations changed to array(*)
*
*
* .. Local Scalars ..
REAL STEMP
INTEGER I,IX,IY
* ..
IF (N.LE.0) RETURN
IF (INCX.EQ.1 .AND. INCY.EQ.1) GO TO 20
*
* 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 10 I = 1,N
STEMP = C*SX(IX) + S*SY(IY)
SY(IY) = C*SY(IY) - S*SX(IX)
SX(IX) = STEMP
IX = IX + INCX
IY = IY + INCY
10 CONTINUE
RETURN
*
* code for both increments equal to 1
*
20 DO 30 I = 1,N
STEMP = C*SX(I) + S*SY(I)
SY(I) = C*SY(I) - S*SX(I)
SX(I) = STEMP
30 CONTINUE
RETURN
END
SUBROUTINE SROTG(SA,SB,C,S)
* .. Scalar Arguments ..
REAL C,S,SA,SB
* ..
*
* Purpose
* =======
*
* construct givens plane rotation.
* jack dongarra, linpack, 3/11/78.
*
*
* .. Local Scalars ..
REAL R,ROE,SCALE,Z
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS,SIGN,SQRT
* ..
ROE = SB
IF (ABS(SA).GT.ABS(SB)) ROE = SA
SCALE = ABS(SA) + ABS(SB)
IF (SCALE.NE.0.0) GO TO 10
C = 1.0
S = 0.0
R = 0.0
Z = 0.0
GO TO 20
10 R = SCALE*SQRT((SA/SCALE)**2+ (SB/SCALE)**2)
R = SIGN(1.0,ROE)*R
C = SA/R
S = SB/R
Z = 1.0
IF (ABS(SA).GT.ABS(SB)) Z = S
IF (ABS(SB).GE.ABS(SA) .AND. C.NE.0.0) Z = 1.0/C
20 SA = R
SB = Z
RETURN
END
SUBROUTINE SROTM(N,SX,INCX,SY,INCY,SPARAM)
* .. Scalar Arguments ..
INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
REAL SPARAM(5),SX(1),SY(1)
* ..
*
* Purpose
* =======
*
* APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX
*
* (SX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF SX ARE IN
* (DX**T)
*
* SX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE
* LX = (-INCX)*N, AND SIMILARLY FOR SY USING USING LY AND INCY.
* WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS..
*
* SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0
*
* (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0)
* H=( ) ( ) ( ) ( )
* (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0).
* SEE SROTMG FOR A DESCRIPTION OF DATA STORAGE IN SPARAM.
*
*
* Arguments
* =========
*
* N (input) INTEGER
* number of elements in input vector(s)
*
* SX (input/output) REAL array, dimension N
* double precision vector with 5 elements
*
* INCX (input) INTEGER
* storage spacing between elements of SX
*
* SY (input/output) REAL array, dimension N
* double precision vector with N elements
*
* INCY (input) INTEGER
* storage spacing between elements of SY
*
* SPARAM (input/output) REAL array, dimension 5
* SPARAM(1)=SFLAG
* SPARAM(2)=SH11
* SPARAM(3)=SH21
* SPARAM(4)=SH12
* SPARAM(5)=SH22
*
* =====================================================================
*
* .. Local Scalars ..
REAL SFLAG,SH11,SH12,SH21,SH22,TWO,W,Z,ZERO
INTEGER I,KX,KY,NSTEPS
* ..
* .. Data statements ..
DATA ZERO,TWO/0.E0,2.E0/
* ..
*
SFLAG = SPARAM(1)
IF (N.LE.0 .OR. (SFLAG+TWO.EQ.ZERO)) GO TO 140
IF (.NOT. (INCX.EQ.INCY.AND.INCX.GT.0)) GO TO 70
*
NSTEPS = N*INCX
IF (SFLAG) 50,10,30
10 CONTINUE
SH12 = SPARAM(4)
SH21 = SPARAM(3)
DO 20 I = 1,NSTEPS,INCX
W = SX(I)
Z = SY(I)
SX(I) = W + Z*SH12
SY(I) = W*SH21 + Z
20 CONTINUE
GO TO 140
30 CONTINUE
SH11 = SPARAM(2)
SH22 = SPARAM(5)
DO 40 I = 1,NSTEPS,INCX
W = SX(I)
Z = SY(I)
SX(I) = W*SH11 + Z
SY(I) = -W + SH22*Z
40 CONTINUE
GO TO 140
50 CONTINUE
SH11 = SPARAM(2)
SH12 = SPARAM(4)
SH21 = SPARAM(3)
SH22 = SPARAM(5)
DO 60 I = 1,NSTEPS,INCX
W = SX(I)
Z = SY(I)
SX(I) = W*SH11 + Z*SH12
SY(I) = W*SH21 + Z*SH22
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
*
IF (SFLAG) 120,80,100
80 CONTINUE
SH12 = SPARAM(4)
SH21 = SPARAM(3)
DO 90 I = 1,N
W = SX(KX)
Z = SY(KY)
SX(KX) = W + Z*SH12
SY(KY) = W*SH21 + Z
KX = KX + INCX
KY = KY + INCY
90 CONTINUE
GO TO 140
100 CONTINUE
SH11 = SPARAM(2)
SH22 = SPARAM(5)
DO 110 I = 1,N
W = SX(KX)
Z = SY(KY)
SX(KX) = W*SH11 + Z
SY(KY) = -W + SH22*Z
KX = KX + INCX
KY = KY + INCY
110 CONTINUE
GO TO 140
120 CONTINUE
SH11 = SPARAM(2)
SH12 = SPARAM(4)
SH21 = SPARAM(3)
SH22 = SPARAM(5)
DO 130 I = 1,N
W = SX(KX)
Z = SY(KY)
SX(KX) = W*SH11 + Z*SH12
SY(KY) = W*SH21 + Z*SH22
KX = KX + INCX
KY = KY + INCY
130 CONTINUE
140 CONTINUE
RETURN
END
SUBROUTINE SROTMG(SD1,SD2,SX1,SY1,SPARAM)
* .. Scalar Arguments ..
REAL SD1,SD2,SX1,SY1
* ..
* .. Array Arguments ..
REAL SPARAM(5)
* ..
*
* Purpose
* =======
*
* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
* THE SECOND COMPONENT OF THE 2-VECTOR (SQRT(SD1)*SX1,SQRT(SD2)*
* SY2)**T.
* WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS..
*
* SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0
*
* (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0)
* H=( ) ( ) ( ) ( )
* (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0).
* LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22
* RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE
* VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.)
*
* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
* OF SD1 AND SD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
*
*
* Arguments
* =========
*
*
* SD1 (input/output) REAL
*
* SD2 (input/output) REAL
*
* SX1 (input/output) REAL
*
* SY1 (input) REAL
*
*
* SPARAM (input/output) REAL array, dimension 5
* SPARAM(1)=SFLAG
* SPARAM(2)=SH11
* SPARAM(3)=SH21
* SPARAM(4)=SH12
* SPARAM(5)=SH22
*
* =====================================================================
*
* .. Local Scalars ..
REAL GAM,GAMSQ,ONE,RGAMSQ,SFLAG,SH11,SH12,SH21,SH22,SP1,SP2,SQ1,
+ SQ2,STEMP,SU,TWO,ZERO
INTEGER IGO
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Data statements ..
*
DATA ZERO,ONE,TWO/0.E0,1.E0,2.E0/
DATA GAM,GAMSQ,RGAMSQ/4096.E0,1.67772E7,5.96046E-8/
* ..
IF (.NOT.SD1.LT.ZERO) GO TO 10
* GO ZERO-H-D-AND-SX1..
GO TO 60
10 CONTINUE
* CASE-SD1-NONNEGATIVE
SP2 = SD2*SY1
IF (.NOT.SP2.EQ.ZERO) GO TO 20
SFLAG = -TWO
GO TO 260
* REGULAR-CASE..
20 CONTINUE
SP1 = SD1*SX1
SQ2 = SP2*SY1
SQ1 = SP1*SX1
*
IF (.NOT.ABS(SQ1).GT.ABS(SQ2)) GO TO 40
SH21 = -SY1/SX1
SH12 = SP2/SP1
*
SU = ONE - SH12*SH21
*
IF (.NOT.SU.LE.ZERO) GO TO 30
* GO ZERO-H-D-AND-SX1..
GO TO 60
30 CONTINUE
SFLAG = ZERO
SD1 = SD1/SU
SD2 = SD2/SU
SX1 = SX1*SU
* GO SCALE-CHECK..
GO TO 100
40 CONTINUE
IF (.NOT.SQ2.LT.ZERO) GO TO 50
* GO ZERO-H-D-AND-SX1..
GO TO 60
50 CONTINUE
SFLAG = ONE
SH11 = SP1/SP2
SH22 = SX1/SY1
SU = ONE + SH11*SH22
STEMP = SD2/SU
SD2 = SD1/SU
SD1 = STEMP
SX1 = SY1*SU
* GO SCALE-CHECK
GO TO 100
* PROCEDURE..ZERO-H-D-AND-SX1..
60 CONTINUE
SFLAG = -ONE
SH11 = ZERO
SH12 = ZERO
SH21 = ZERO
SH22 = ZERO
*
SD1 = ZERO
SD2 = ZERO
SX1 = ZERO
* RETURN..
GO TO 220
* PROCEDURE..FIX-H..
70 CONTINUE
IF (.NOT.SFLAG.GE.ZERO) GO TO 90
*
IF (.NOT.SFLAG.EQ.ZERO) GO TO 80
SH11 = ONE
SH22 = ONE
SFLAG = -ONE
GO TO 90
80 CONTINUE
SH21 = -ONE
SH12 = ONE
SFLAG = -ONE
90 CONTINUE
GO TO IGO(120,150,180,210)
* PROCEDURE..SCALE-CHECK
100 CONTINUE
110 CONTINUE
IF (.NOT.SD1.LE.RGAMSQ) GO TO 130
IF (SD1.EQ.ZERO) GO TO 160
ASSIGN 120 TO IGO
* FIX-H..
GO TO 70
120 CONTINUE
SD1 = SD1*GAM**2
SX1 = SX1/GAM
SH11 = SH11/GAM
SH12 = SH12/GAM
GO TO 110
130 CONTINUE
140 CONTINUE
IF (.NOT.SD1.GE.GAMSQ) GO TO 160
ASSIGN 150 TO IGO
* FIX-H..
GO TO 70
150 CONTINUE
SD1 = SD1/GAM**2
SX1 = SX1*GAM
SH11 = SH11*GAM
SH12 = SH12*GAM
GO TO 140
160 CONTINUE
170 CONTINUE
IF (.NOT.ABS(SD2).LE.RGAMSQ) GO TO 190
IF (SD2.EQ.ZERO) GO TO 220
ASSIGN 180 TO IGO
* FIX-H..
GO TO 70
180 CONTINUE
SD2 = SD2*GAM**2
SH21 = SH21/GAM
SH22 = SH22/GAM
GO TO 170
190 CONTINUE
200 CONTINUE
IF (.NOT.ABS(SD2).GE.GAMSQ) GO TO 220
ASSIGN 210 TO IGO
* FIX-H..
GO TO 70
210 CONTINUE
SD2 = SD2/GAM**2
SH21 = SH21*GAM
SH22 = SH22*GAM
GO TO 200
220 CONTINUE
IF (SFLAG) 250,230,240
230 CONTINUE
SPARAM(3) = SH21
SPARAM(4) = SH12
GO TO 260
240 CONTINUE
SPARAM(2) = SH11
SPARAM(5) = SH22
GO TO 260
250 CONTINUE
SPARAM(2) = SH11
SPARAM(3) = SH21
SPARAM(4) = SH12
SPARAM(5) = SH22
260 CONTINUE
SPARAM(1) = SFLAG
RETURN
END
SUBROUTINE SSBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
* .. Scalar Arguments ..
REAL ALPHA,BETA
INTEGER INCX,INCY,K,LDA,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
REAL A(LDA,*),X(*),Y(*)
* ..
*
* Purpose
* =======
*
* SSBMV performs the matrix-vector operation
*
* y := alpha*A*x + beta*y,
*
* where alpha and beta are scalars, x and y are n element vectors and
* A is an n by n symmetric band matrix, with k super-diagonals.
*
* Arguments
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the band matrix A is being supplied as
* follows:
*
* UPLO = 'U' or 'u' The upper triangular part of A is
* being supplied.
*
* UPLO = 'L' or 'l' The lower triangular part of A is
* being supplied.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* K - INTEGER.
* On entry, K specifies the number of super-diagonals of the
* matrix A. K must satisfy 0 .le. K.
* Unchanged on exit.
*
* ALPHA - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
* by n part of the array A must contain the upper triangular
* band part of the symmetric matrix, supplied column by
* column, with the leading diagonal of the matrix in row
* ( k + 1 ) of the array, the first super-diagonal starting at
* position 2 in row k, and so on. The top left k by k triangle
* of the array A is not referenced.
* The following program segment will transfer the upper
* triangular part of a symmetric band matrix from conventional
* full matrix storage to band storage:
*
* DO 20, J = 1, N
* M = K + 1 - J
* DO 10, I = MAX( 1, J - K ), J
* A( M + I, J ) = matrix( I, J )
* 10 CONTINUE
* 20 CONTINUE
*
* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
* by n part of the array A must contain the lower triangular
* band part of the symmetric matrix, supplied column by
* column, with the leading diagonal of the matrix in row 1 of
* the array, the first sub-diagonal starting at position 1 in
* row 2, and so on. The bottom right k by k triangle of the
* array A is not referenced.
* The following program segment will transfer the lower
* triangular part of a symmetric band matrix from conventional
* full matrix storage to band storage:
*
* DO 20, J = 1, N
* M = 1 - J
* DO 10, I = J, MIN( N, J + K )
* A( M + I, J ) = matrix( I, J )
* 10 CONTINUE
* 20 CONTINUE
*
* Unchanged on exit.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. LDA must be at least
* ( k + 1 ).
* Unchanged on exit.
*
* X - REAL array of DIMENSION at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the
* vector x.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
* BETA - REAL .
* On entry, BETA specifies the scalar beta.
* Unchanged on exit.
*
* Y - REAL array of DIMENSION at least
* ( 1 + ( n - 1 )*abs( INCY ) ).
* Before entry, the incremented array Y must contain the
* vector y. On exit, Y is overwritten by the updated vector y.
*
* INCY - INTEGER.
* On entry, INCY specifies the increment for the elements of
* Y. INCY must not be zero.
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- 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 ..
REAL ONE,ZERO
PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
* ..
* .. Local Scalars ..
REAL TEMP1,TEMP2
INTEGER I,INFO,IX,IY,J,JX,JY,KPLUS1,KX,KY,L
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX,MIN
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
INFO = 1
ELSE IF (N.LT.0) THEN
INFO = 2
ELSE IF (K.LT.0) THEN
INFO = 3
ELSE IF (LDA.LT. (K+1)) 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('SSBMV ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
*
* Set up the start points in X and Y.
*
IF (INCX.GT.0) THEN
KX = 1
ELSE
KX = 1 - (N-1)*INCX
END IF
IF (INCY.GT.0) THEN
KY = 1
ELSE
KY = 1 - (N-1)*INCY
END IF
*
* Start the operations. In this version the elements of the array 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,N
Y(I) = ZERO
10 CONTINUE
ELSE
DO 20 I = 1,N
Y(I) = BETA*Y(I)
20 CONTINUE
END IF
ELSE
IY = KY
IF (BETA.EQ.ZERO) THEN
DO 30 I = 1,N
Y(IY) = ZERO
IY = IY + INCY
30 CONTINUE
ELSE
DO 40 I = 1,N
Y(IY) = BETA*Y(IY)
IY = IY + INCY
40 CONTINUE
END IF
END IF
END IF
IF (ALPHA.EQ.ZERO) RETURN
IF (LSAME(UPLO,'U')) THEN
*
* Form y when upper triangle of A is stored.
*
KPLUS1 = K + 1
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 60 J = 1,N
TEMP1 = ALPHA*X(J)
TEMP2 = ZERO
L = KPLUS1 - J
DO 50 I = MAX(1,J-K),J - 1
Y(I) = Y(I) + TEMP1*A(L+I,J)
TEMP2 = TEMP2 + A(L+I,J)*X(I)
50 CONTINUE
Y(J) = Y(J) + TEMP1*A(KPLUS1,J) + ALPHA*TEMP2
60 CONTINUE
ELSE
JX = KX
JY = KY
DO 80 J = 1,N
TEMP1 = ALPHA*X(JX)
TEMP2 = ZERO
IX = KX
IY = KY
L = KPLUS1 - J
DO 70 I = MAX(1,J-K),J - 1
Y(IY) = Y(IY) + TEMP1*A(L+I,J)
TEMP2 = TEMP2 + A(L+I,J)*X(IX)
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
Y(JY) = Y(JY) + TEMP1*A(KPLUS1,J) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
IF (J.GT.K) THEN
KX = KX + INCX
KY = KY + INCY
END IF
80 CONTINUE
END IF
ELSE
*
* Form y when lower triangle of A is stored.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 100 J = 1,N
TEMP1 = ALPHA*X(J)
TEMP2 = ZERO
Y(J) = Y(J) + TEMP1*A(1,J)
L = 1 - J
DO 90 I = J + 1,MIN(N,J+K)
Y(I) = Y(I) + TEMP1*A(L+I,J)
TEMP2 = TEMP2 + A(L+I,J)*X(I)
90 CONTINUE
Y(J) = Y(J) + ALPHA*TEMP2
100 CONTINUE
ELSE
JX = KX
JY = KY
DO 120 J = 1,N
TEMP1 = ALPHA*X(JX)
TEMP2 = ZERO
Y(JY) = Y(JY) + TEMP1*A(1,J)
L = 1 - J
IX = JX
IY = JY
DO 110 I = J + 1,MIN(N,J+K)
IX = IX + INCX
IY = IY + INCY
Y(IY) = Y(IY) + TEMP1*A(L+I,J)
TEMP2 = TEMP2 + A(L+I,J)*X(IX)
110 CONTINUE
Y(JY) = Y(JY) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
120 CONTINUE
END IF
END IF
*
RETURN
*
* End of SSBMV .
*
END
SUBROUTINE SSCAL(N,SA,SX,INCX)
* .. Scalar Arguments ..
REAL SA
INTEGER INCX,N
* ..
* .. Array Arguments ..
REAL SX(*)
* ..
*
* Purpose
* =======
*
* scales a vector by a constant.
* uses unrolled loops for increment equal to 1.
* 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) GO TO 20
*
* code for increment not equal to 1
*
NINCX = N*INCX
DO 10 I = 1,NINCX,INCX
SX(I) = SA*SX(I)
10 CONTINUE
RETURN
*
* code for increment equal to 1
*
*
* clean-up loop
*
20 M = MOD(N,5)
IF (M.EQ.0) GO TO 40
DO 30 I = 1,M
SX(I) = SA*SX(I)
30 CONTINUE
IF (N.LT.5) RETURN
40 MP1 = M + 1
DO 50 I = MP1,N,5
SX(I) = SA*SX(I)
SX(I+1) = SA*SX(I+1)
SX(I+2) = SA*SX(I+2)
SX(I+3) = SA*SX(I+3)
SX(I+4) = SA*SX(I+4)
50 CONTINUE
RETURN
END
SUBROUTINE SSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY)
* .. Scalar Arguments ..
REAL ALPHA,BETA
INTEGER INCX,INCY,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
REAL AP(*),X(*),Y(*)
* ..
*
* Purpose
* =======
*
* SSPMV performs the matrix-vector operation
*
* y := alpha*A*x + beta*y,
*
* where alpha and beta are scalars, x and y are n element vectors and
* A is an n by n symmetric matrix, supplied in packed form.
*
* Arguments
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the matrix A is supplied in the packed
* array AP as follows:
*
* UPLO = 'U' or 'u' The upper triangular part of A is
* supplied in AP.
*
* UPLO = 'L' or 'l' The lower triangular part of A is
* supplied in AP.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* ALPHA - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* AP - REAL array of DIMENSION at least
* ( ( n*( n + 1 ) )/2 ).
* Before entry with UPLO = 'U' or 'u', the array AP must
* contain the upper triangular part of the symmetric matrix
* packed sequentially, column by column, so that AP( 1 )
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
* and a( 2, 2 ) respectively, and so on.
* Before entry with UPLO = 'L' or 'l', the array AP must
* contain the lower triangular part of the symmetric matrix
* packed sequentially, column by column, so that AP( 1 )
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
* and a( 3, 1 ) respectively, and so on.
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
* BETA - REAL .
* On entry, BETA specifies the scalar beta. When BETA is
* supplied as zero then Y need not be set on input.
* Unchanged on exit.
*
* Y - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCY ) ).
* Before entry, the incremented array Y must contain the n
* element vector y. On exit, Y is overwritten by the updated
* vector y.
*
* INCY - INTEGER.
* On entry, INCY specifies the increment for the elements of
* Y. INCY must not be zero.
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- 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 ..
REAL ONE,ZERO
PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
* ..
* .. Local Scalars ..
REAL TEMP1,TEMP2
INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
INFO = 1
ELSE IF (N.LT.0) THEN
INFO = 2
ELSE IF (INCX.EQ.0) THEN
INFO = 6
ELSE IF (INCY.EQ.0) THEN
INFO = 9
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('SSPMV ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
*
* Set up the start points in X and Y.
*
IF (INCX.GT.0) THEN
KX = 1
ELSE
KX = 1 - (N-1)*INCX
END IF
IF (INCY.GT.0) THEN
KY = 1
ELSE
KY = 1 - (N-1)*INCY
END IF
*
* Start the operations. In this version the elements of the array AP
* are accessed sequentially with one pass through AP.
*
* First form y := beta*y.
*
IF (BETA.NE.ONE) THEN
IF (INCY.EQ.1) THEN
IF (BETA.EQ.ZERO) THEN
DO 10 I = 1,N
Y(I) = ZERO
10 CONTINUE
ELSE
DO 20 I = 1,N
Y(I) = BETA*Y(I)
20 CONTINUE
END IF
ELSE
IY = KY
IF (BETA.EQ.ZERO) THEN
DO 30 I = 1,N
Y(IY) = ZERO
IY = IY + INCY
30 CONTINUE
ELSE
DO 40 I = 1,N
Y(IY) = BETA*Y(IY)
IY = IY + INCY
40 CONTINUE
END IF
END IF
END IF
IF (ALPHA.EQ.ZERO) RETURN
KK = 1
IF (LSAME(UPLO,'U')) THEN
*
* Form y when AP contains the upper triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 60 J = 1,N
TEMP1 = ALPHA*X(J)
TEMP2 = ZERO
K = KK
DO 50 I = 1,J - 1
Y(I) = Y(I) + TEMP1*AP(K)
TEMP2 = TEMP2 + AP(K)*X(I)
K = K + 1
50 CONTINUE
Y(J) = Y(J) + TEMP1*AP(KK+J-1) + ALPHA*TEMP2
KK = KK + J
60 CONTINUE
ELSE
JX = KX
JY = KY
DO 80 J = 1,N
TEMP1 = ALPHA*X(JX)
TEMP2 = ZERO
IX = KX
IY = KY
DO 70 K = KK,KK + J - 2
Y(IY) = Y(IY) + TEMP1*AP(K)
TEMP2 = TEMP2 + AP(K)*X(IX)
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
Y(JY) = Y(JY) + TEMP1*AP(KK+J-1) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
KK = KK + J
80 CONTINUE
END IF
ELSE
*
* Form y when AP contains the lower triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 100 J = 1,N
TEMP1 = ALPHA*X(J)
TEMP2 = ZERO
Y(J) = Y(J) + TEMP1*AP(KK)
K = KK + 1
DO 90 I = J + 1,N
Y(I) = Y(I) + TEMP1*AP(K)
TEMP2 = TEMP2 + AP(K)*X(I)
K = K + 1
90 CONTINUE
Y(J) = Y(J) + ALPHA*TEMP2
KK = KK + (N-J+1)
100 CONTINUE
ELSE
JX = KX
JY = KY
DO 120 J = 1,N
TEMP1 = ALPHA*X(JX)
TEMP2 = ZERO
Y(JY) = Y(JY) + TEMP1*AP(KK)
IX = JX
IY = JY
DO 110 K = KK + 1,KK + N - J
IX = IX + INCX
IY = IY + INCY
Y(IY) = Y(IY) + TEMP1*AP(K)
TEMP2 = TEMP2 + AP(K)*X(IX)
110 CONTINUE
Y(JY) = Y(JY) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
KK = KK + (N-J+1)
120 CONTINUE
END IF
END IF
*
RETURN
*
* End of SSPMV .
*
END
SUBROUTINE SSPR(UPLO,N,ALPHA,X,INCX,AP)
* .. Scalar Arguments ..
REAL ALPHA
INTEGER INCX,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
REAL AP(*),X(*)
* ..
*
* Purpose
* =======
*
* SSPR performs the symmetric rank 1 operation
*
* A := alpha*x*x' + A,
*
* where alpha is a real scalar, x is an n element vector and A is an
* n by n symmetric matrix, supplied in packed form.
*
* Arguments
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the matrix A is supplied in the packed
* array AP as follows:
*
* UPLO = 'U' or 'u' The upper triangular part of A is
* supplied in AP.
*
* UPLO = 'L' or 'l' The lower triangular part of A is
* supplied in AP.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* ALPHA - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
* AP - REAL array of DIMENSION at least
* ( ( n*( n + 1 ) )/2 ).
* Before entry with UPLO = 'U' or 'u', the array AP must
* contain the upper triangular part of the symmetric matrix
* packed sequentially, column by column, so that AP( 1 )
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
* and a( 2, 2 ) respectively, and so on. On exit, the array
* AP is overwritten by the upper triangular part of the
* updated matrix.
* Before entry with UPLO = 'L' or 'l', the array AP must
* contain the lower triangular part of the symmetric matrix
* packed sequentially, column by column, so that AP( 1 )
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
* and a( 3, 1 ) respectively, and so on. On exit, the array
* AP is overwritten by the lower triangular part of the
* updated matrix.
*
*
* Level 2 Blas routine.
*
* -- 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 ..
REAL ZERO
PARAMETER (ZERO=0.0E+0)
* ..
* .. Local Scalars ..
REAL TEMP
INTEGER I,INFO,IX,J,JX,K,KK,KX
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
INFO = 1
ELSE IF (N.LT.0) THEN
INFO = 2
ELSE IF (INCX.EQ.0) THEN
INFO = 5
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('SSPR ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
*
* Set the start point in X if the increment is not unity.
*
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 the array AP
* are accessed sequentially with one pass through AP.
*
KK = 1
IF (LSAME(UPLO,'U')) THEN
*
* Form A when upper triangle is stored in AP.
*
IF (INCX.EQ.1) THEN
DO 20 J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = ALPHA*X(J)
K = KK
DO 10 I = 1,J
AP(K) = AP(K) + X(I)*TEMP
K = K + 1
10 CONTINUE
END IF
KK = KK + J
20 CONTINUE
ELSE
JX = KX
DO 40 J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = ALPHA*X(JX)
IX = KX
DO 30 K = KK,KK + J - 1
AP(K) = AP(K) + X(IX)*TEMP
IX = IX + INCX
30 CONTINUE
END IF
JX = JX + INCX
KK = KK + J
40 CONTINUE
END IF
ELSE
*
* Form A when lower triangle is stored in AP.
*
IF (INCX.EQ.1) THEN
DO 60 J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = ALPHA*X(J)
K = KK
DO 50 I = J,N
AP(K) = AP(K) + X(I)*TEMP
K = K + 1
50 CONTINUE
END IF
KK = KK + N - J + 1
60 CONTINUE
ELSE
JX = KX
DO 80 J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = ALPHA*X(JX)
IX = JX
DO 70 K = KK,KK + N - J
AP(K) = AP(K) + X(IX)*TEMP
IX = IX + INCX
70 CONTINUE
END IF
JX = JX + INCX
KK = KK + N - J + 1
80 CONTINUE
END IF
END IF
*
RETURN
*
* End of SSPR .
*
END
SUBROUTINE SSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP)
* .. Scalar Arguments ..
REAL ALPHA
INTEGER INCX,INCY,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
REAL AP(*),X(*),Y(*)
* ..
*
* Purpose
* =======
*
* SSPR2 performs the symmetric rank 2 operation
*
* A := alpha*x*y' + alpha*y*x' + A,
*
* where alpha is a scalar, x and y are n element vectors and A is an
* n by n symmetric matrix, supplied in packed form.
*
* Arguments
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the matrix A is supplied in the packed
* array AP as follows:
*
* UPLO = 'U' or 'u' The upper triangular part of A is
* supplied in AP.
*
* UPLO = 'L' or 'l' The lower triangular part of A is
* supplied in AP.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* ALPHA - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
* Y - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCY ) ).
* Before entry, the incremented array Y must contain the n
* element vector y.
* Unchanged on exit.
*
* INCY - INTEGER.
* On entry, INCY specifies the increment for the elements of
* Y. INCY must not be zero.
* Unchanged on exit.
*
* AP - REAL array of DIMENSION at least
* ( ( n*( n + 1 ) )/2 ).
* Before entry with UPLO = 'U' or 'u', the array AP must
* contain the upper triangular part of the symmetric matrix
* packed sequentially, column by column, so that AP( 1 )
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
* and a( 2, 2 ) respectively, and so on. On exit, the array
* AP is overwritten by the upper triangular part of the
* updated matrix.
* Before entry with UPLO = 'L' or 'l', the array AP must
* contain the lower triangular part of the symmetric matrix
* packed sequentially, column by column, so that AP( 1 )
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
* and a( 3, 1 ) respectively, and so on. On exit, the array
* AP is overwritten by the lower triangular part of the
* updated matrix.
*
*
* Level 2 Blas routine.
*
* -- 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 ..
REAL ZERO
PARAMETER (ZERO=0.0E+0)
* ..
* .. Local Scalars ..
REAL TEMP1,TEMP2
INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) 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
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('SSPR2 ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
*
* Set up the start points in X and Y if the increments are not both
* unity.
*
IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN
IF (INCX.GT.0) THEN
KX = 1
ELSE
KX = 1 - (N-1)*INCX
END IF
IF (INCY.GT.0) THEN
KY = 1
ELSE
KY = 1 - (N-1)*INCY
END IF
JX = KX
JY = KY
END IF
*
* Start the operations. In this version the elements of the array AP
* are accessed sequentially with one pass through AP.
*
KK = 1
IF (LSAME(UPLO,'U')) THEN
*
* Form A when upper triangle is stored in AP.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 20 J = 1,N
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
TEMP1 = ALPHA*Y(J)
TEMP2 = ALPHA*X(J)
K = KK
DO 10 I = 1,J
AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2
K = K + 1
10 CONTINUE
END IF
KK = KK + J
20 CONTINUE
ELSE
DO 40 J = 1,N
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
TEMP1 = ALPHA*Y(JY)
TEMP2 = ALPHA*X(JX)
IX = KX
IY = KY
DO 30 K = KK,KK + J - 1
AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2
IX = IX + INCX
IY = IY + INCY
30 CONTINUE
END IF
JX = JX + INCX
JY = JY + INCY
KK = KK + J
40 CONTINUE
END IF
ELSE
*
* Form A when lower triangle is stored in AP.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 60 J = 1,N
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
TEMP1 = ALPHA*Y(J)
TEMP2 = ALPHA*X(J)
K = KK
DO 50 I = J,N
AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2
K = K + 1
50 CONTINUE
END IF
KK = KK + N - J + 1
60 CONTINUE
ELSE
DO 80 J = 1,N
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
TEMP1 = ALPHA*Y(JY)
TEMP2 = ALPHA*X(JX)
IX = JX
IY = JY
DO 70 K = KK,KK + N - J
AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
END IF
JX = JX + INCX
JY = JY + INCY
KK = KK + N - J + 1
80 CONTINUE
END IF
END IF
*
RETURN
*
* End of SSPR2 .
*
END
SUBROUTINE SSWAP(N,SX,INCX,SY,INCY)
* .. Scalar Arguments ..
INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
REAL SX(*),SY(*)
* ..
*
* Purpose
* =======
*
* interchanges two vectors.
* uses unrolled loops for increments equal to 1.
* jack dongarra, linpack, 3/11/78.
* modified 12/3/93, array(1) declarations changed to array(*)
*
*
* .. Local Scalars ..
REAL STEMP
INTEGER I,IX,IY,M,MP1
* ..
* .. Intrinsic Functions ..
INTRINSIC MOD
* ..
IF (N.LE.0) RETURN
IF (INCX.EQ.1 .AND. INCY.EQ.1) GO TO 20
*
* 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 10 I = 1,N
STEMP = SX(IX)
SX(IX) = SY(IY)
SY(IY) = STEMP
IX = IX + INCX
IY = IY + INCY
10 CONTINUE
RETURN
*
* code for both increments equal to 1
*
*
* clean-up loop
*
20 M = MOD(N,3)
IF (M.EQ.0) GO TO 40
DO 30 I = 1,M
STEMP = SX(I)
SX(I) = SY(I)
SY(I) = STEMP
30 CONTINUE
IF (N.LT.3) RETURN
40 MP1 = M + 1
DO 50 I = MP1,N,3
STEMP = SX(I)
SX(I) = SY(I)
SY(I) = STEMP
STEMP = SX(I+1)
SX(I+1) = SY(I+1)
SY(I+1) = STEMP
STEMP = SX(I+2)
SX(I+2) = SY(I+2)
SY(I+2) = STEMP
50 CONTINUE
RETURN
END
SUBROUTINE SSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
* .. Scalar Arguments ..
REAL ALPHA,BETA
INTEGER LDA,LDB,LDC,M,N
CHARACTER SIDE,UPLO
* ..
* .. Array Arguments ..
REAL A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
* Purpose
* =======
*
* SSYMM performs one of the matrix-matrix operations
*
* C := alpha*A*B + beta*C,
*
* or
*
* C := alpha*B*A + beta*C,
*
* where alpha and beta are scalars, A is a symmetric matrix and B and
* C are m by n matrices.
*
* Arguments
* ==========
*
* SIDE - CHARACTER*1.
* On entry, SIDE specifies whether the symmetric matrix A
* appears on the left or right in the operation as follows:
*
* SIDE = 'L' or 'l' C := alpha*A*B + beta*C,
*
* SIDE = 'R' or 'r' C := alpha*B*A + beta*C,
*
* Unchanged on exit.
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the symmetric matrix A is to be
* referenced as follows:
*
* UPLO = 'U' or 'u' Only the upper triangular part of the
* symmetric matrix is to be referenced.
*
* UPLO = 'L' or 'l' Only the lower triangular part of the
* symmetric matrix is to be referenced.
*
* Unchanged on exit.
*
* M - INTEGER.
* On entry, M specifies the number of rows of the matrix C.
* M must be at least zero.
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the number of columns of the matrix C.
* N must be at least zero.
* Unchanged on exit.
*
* ALPHA - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, ka ), where ka is
* m when SIDE = 'L' or 'l' and is n otherwise.
* Before entry with SIDE = 'L' or 'l', the m by m part of
* the array A must contain the symmetric matrix, such that
* when UPLO = 'U' or 'u', the leading m by m upper triangular
* part of the array A must contain the upper triangular part
* of the symmetric matrix and the strictly lower triangular
* part of A is not referenced, and when UPLO = 'L' or 'l',
* the leading m by m lower triangular part of the array A
* must contain the lower triangular part of the symmetric
* matrix and the strictly upper triangular part of A is not
* referenced.
* Before entry with SIDE = 'R' or 'r', the n by n part of
* the array A must contain the symmetric matrix, such that
* when UPLO = 'U' or 'u', the leading n by n upper triangular
* part of the array A must contain the upper triangular part
* of the symmetric matrix and the strictly lower triangular
* part of A is not referenced, and when UPLO = 'L' or 'l',
* the leading n by n lower triangular part of the array A
* must contain the lower triangular part of the symmetric
* matrix and the strictly upper triangular part of A is not
* referenced.
* Unchanged on exit.
*
* LDA - 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 ), otherwise LDA must be at
* least max( 1, n ).
* Unchanged on exit.
*
* B - REAL array of DIMENSION ( LDB, n ).
* Before entry, the leading m by n part of the array B must
* contain the matrix B.
* Unchanged on exit.
*
* LDB - 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 ).
* Unchanged on exit.
*
* BETA - REAL .
* On entry, BETA specifies the scalar beta. When BETA is
* supplied as zero then C need not be set on input.
* Unchanged on exit.
*
* C - REAL array of DIMENSION ( LDC, n ).
* Before entry, the leading m by n part of the array C must
* contain the matrix C, except when beta is zero, in which
* case C need not be set on entry.
* On exit, the array C is overwritten by the m by n updated
* matrix.
*
* LDC - INTEGER.
* On entry, LDC specifies the first dimension of C as declared
* in the calling (sub) program. LDC must be at least
* max( 1, m ).
* Unchanged on exit.
*
*
* 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 ..
REAL TEMP1,TEMP2
INTEGER I,INFO,J,K,NROWA
LOGICAL UPPER
* ..
* .. Parameters ..
REAL ONE,ZERO
PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
* ..
*
* Set NROWA as the number of rows of A.
*
IF (LSAME(SIDE,'L')) THEN
NROWA = M
ELSE
NROWA = N
END IF
UPPER = LSAME(UPLO,'U')
*
* Test the input parameters.
*
INFO = 0
IF ((.NOT.LSAME(SIDE,'L')) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
INFO = 1
ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
INFO = 2
ELSE IF (M.LT.0) THEN
INFO = 3
ELSE IF (N.LT.0) THEN
INFO = 4
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
INFO = 7
ELSE IF (LDB.LT.MAX(1,M)) THEN
INFO = 9
ELSE IF (LDC.LT.MAX(1,M)) THEN
INFO = 12
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('SSYMM ',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
*
* And when 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 (LSAME(SIDE,'L')) THEN
*
* Form C := alpha*A*B + beta*C.
*
IF (UPPER) THEN
DO 70 J = 1,N
DO 60 I = 1,M
TEMP1 = ALPHA*B(I,J)
TEMP2 = ZERO
DO 50 K = 1,I - 1
C(K,J) = C(K,J) + TEMP1*A(K,I)
TEMP2 = TEMP2 + B(K,J)*A(K,I)
50 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = TEMP1*A(I,I) + ALPHA*TEMP2
ELSE
C(I,J) = BETA*C(I,J) + TEMP1*A(I,I) +
+ ALPHA*TEMP2
END IF
60 CONTINUE
70 CONTINUE
ELSE
DO 100 J = 1,N
DO 90 I = M,1,-1
TEMP1 = ALPHA*B(I,J)
TEMP2 = ZERO
DO 80 K = I + 1,M
C(K,J) = C(K,J) + TEMP1*A(K,I)
TEMP2 = TEMP2 + B(K,J)*A(K,I)
80 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = TEMP1*A(I,I) + ALPHA*TEMP2
ELSE
C(I,J) = BETA*C(I,J) + TEMP1*A(I,I) +
+ ALPHA*TEMP2
END IF
90 CONTINUE
100 CONTINUE
END IF
ELSE
*
* Form C := alpha*B*A + beta*C.
*
DO 170 J = 1,N
TEMP1 = ALPHA*A(J,J)
IF (BETA.EQ.ZERO) THEN
DO 110 I = 1,M
C(I,J) = TEMP1*B(I,J)
110 CONTINUE
ELSE
DO 120 I = 1,M
C(I,J) = BETA*C(I,J) + TEMP1*B(I,J)
120 CONTINUE
END IF
DO 140 K = 1,J - 1
IF (UPPER) THEN
TEMP1 = ALPHA*A(K,J)
ELSE
TEMP1 = ALPHA*A(J,K)
END IF
DO 130 I = 1,M
C(I,J) = C(I,J) + TEMP1*B(I,K)
130 CONTINUE
140 CONTINUE
DO 160 K = J + 1,N
IF (UPPER) THEN
TEMP1 = ALPHA*A(J,K)
ELSE
TEMP1 = ALPHA*A(K,J)
END IF
DO 150 I = 1,M
C(I,J) = C(I,J) + TEMP1*B(I,K)
150 CONTINUE
160 CONTINUE
170 CONTINUE
END IF
*
RETURN
*
* End of SSYMM .
*
END
SUBROUTINE SSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
* .. Scalar Arguments ..
REAL ALPHA,BETA
INTEGER INCX,INCY,LDA,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
REAL A(LDA,*),X(*),Y(*)
* ..
*
* Purpose
* =======
*
* SSYMV performs the matrix-vector operation
*
* y := alpha*A*x + beta*y,
*
* where alpha and beta are scalars, x and y are n element vectors and
* A is an n by n symmetric matrix.
*
* Arguments
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the array A is to be referenced as
* follows:
*
* UPLO = 'U' or 'u' Only the upper triangular part of A
* is to be referenced.
*
* UPLO = 'L' or 'l' Only the lower triangular part of A
* is to be referenced.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* ALPHA - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U' or 'u', the leading n by n
* upper triangular part of the array A must contain the upper
* triangular part of the symmetric matrix and the strictly
* lower triangular part of A is not referenced.
* Before entry with UPLO = 'L' or 'l', the leading n by n
* lower triangular part of the array A must contain the lower
* triangular part of the symmetric matrix and the strictly
* upper triangular part of A is not referenced.
* Unchanged on exit.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. LDA must be at least
* max( 1, n ).
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
* BETA - REAL .
* On entry, BETA specifies the scalar beta. When BETA is
* supplied as zero then Y need not be set on input.
* Unchanged on exit.
*
* Y - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCY ) ).
* Before entry, the incremented array Y must contain the n
* element vector y. On exit, Y is overwritten by the updated
* vector y.
*
* INCY - INTEGER.
* On entry, INCY specifies the increment for the elements of
* Y. INCY must not be zero.
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- 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 ..
REAL ONE,ZERO
PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
* ..
* .. Local Scalars ..
REAL TEMP1,TEMP2
INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY
* ..
* .. 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 (N.LT.0) THEN
INFO = 2
ELSE IF (LDA.LT.MAX(1,N)) THEN
INFO = 5
ELSE IF (INCX.EQ.0) THEN
INFO = 7
ELSE IF (INCY.EQ.0) THEN
INFO = 10
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('SSYMV ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
*
* Set up the start points in X and Y.
*
IF (INCX.GT.0) THEN
KX = 1
ELSE
KX = 1 - (N-1)*INCX
END IF
IF (INCY.GT.0) THEN
KY = 1
ELSE
KY = 1 - (N-1)*INCY
END IF
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through the triangular part
* of 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,N
Y(I) = ZERO
10 CONTINUE
ELSE
DO 20 I = 1,N
Y(I) = BETA*Y(I)
20 CONTINUE
END IF
ELSE
IY = KY
IF (BETA.EQ.ZERO) THEN
DO 30 I = 1,N
Y(IY) = ZERO
IY = IY + INCY
30 CONTINUE
ELSE
DO 40 I = 1,N
Y(IY) = BETA*Y(IY)
IY = IY + INCY
40 CONTINUE
END IF
END IF
END IF
IF (ALPHA.EQ.ZERO) RETURN
IF (LSAME(UPLO,'U')) THEN
*
* Form y when A is stored in upper triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 60 J = 1,N
TEMP1 = ALPHA*X(J)
TEMP2 = ZERO
DO 50 I = 1,J - 1
Y(I) = Y(I) + TEMP1*A(I,J)
TEMP2 = TEMP2 + A(I,J)*X(I)
50 CONTINUE
Y(J) = Y(J) + TEMP1*A(J,J) + ALPHA*TEMP2
60 CONTINUE
ELSE
JX = KX
JY = KY
DO 80 J = 1,N
TEMP1 = ALPHA*X(JX)
TEMP2 = ZERO
IX = KX
IY = KY
DO 70 I = 1,J - 1
Y(IY) = Y(IY) + TEMP1*A(I,J)
TEMP2 = TEMP2 + A(I,J)*X(IX)
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
Y(JY) = Y(JY) + TEMP1*A(J,J) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
80 CONTINUE
END IF
ELSE
*
* Form y when A is stored in lower triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 100 J = 1,N
TEMP1 = ALPHA*X(J)
TEMP2 = ZERO
Y(J) = Y(J) + TEMP1*A(J,J)
DO 90 I = J + 1,N
Y(I) = Y(I) + TEMP1*A(I,J)
TEMP2 = TEMP2 + A(I,J)*X(I)
90 CONTINUE
Y(J) = Y(J) + ALPHA*TEMP2
100 CONTINUE
ELSE
JX = KX
JY = KY
DO 120 J = 1,N
TEMP1 = ALPHA*X(JX)
TEMP2 = ZERO
Y(JY) = Y(JY) + TEMP1*A(J,J)
IX = JX
IY = JY
DO 110 I = J + 1,N
IX = IX + INCX
IY = IY + INCY
Y(IY) = Y(IY) + TEMP1*A(I,J)
TEMP2 = TEMP2 + A(I,J)*X(IX)
110 CONTINUE
Y(JY) = Y(JY) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
120 CONTINUE
END IF
END IF
*
RETURN
*
* End of SSYMV .
*
END
SUBROUTINE SSYR(UPLO,N,ALPHA,X,INCX,A,LDA)
* .. Scalar Arguments ..
REAL ALPHA
INTEGER INCX,LDA,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
REAL A(LDA,*),X(*)
* ..
*
* Purpose
* =======
*
* SSYR performs the symmetric rank 1 operation
*
* A := alpha*x*x' + A,
*
* where alpha is a real scalar, x is an n element vector and A is an
* n by n symmetric matrix.
*
* Arguments
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the array A is to be referenced as
* follows:
*
* UPLO = 'U' or 'u' Only the upper triangular part of A
* is to be referenced.
*
* UPLO = 'L' or 'l' Only the lower triangular part of A
* is to be referenced.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* ALPHA - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U' or 'u', the leading n by n
* upper triangular part of the array A must contain the upper
* triangular part of the symmetric matrix and the strictly
* lower triangular part of A is not referenced. On exit, the
* upper triangular part of the array A is overwritten by the
* upper triangular part of the updated matrix.
* Before entry with UPLO = 'L' or 'l', the leading n by n
* lower triangular part of the array A must contain the lower
* triangular part of the symmetric matrix and the strictly
* upper triangular part of A is not referenced. On exit, the
* lower triangular part of the array A is overwritten by the
* lower triangular part of the updated matrix.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. LDA must be at least
* max( 1, n ).
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- 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 ..
REAL ZERO
PARAMETER (ZERO=0.0E+0)
* ..
* .. Local Scalars ..
REAL TEMP
INTEGER I,INFO,IX,J,JX,KX
* ..
* .. 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 (N.LT.0) THEN
INFO = 2
ELSE IF (INCX.EQ.0) THEN
INFO = 5
ELSE IF (LDA.LT.MAX(1,N)) THEN
INFO = 7
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('SSYR ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
*
* Set the start point in X if the increment is not unity.
*
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 the triangular part
* of A.
*
IF (LSAME(UPLO,'U')) THEN
*
* Form A when A is stored in upper triangle.
*
IF (INCX.EQ.1) THEN
DO 20 J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = ALPHA*X(J)
DO 10 I = 1,J
A(I,J) = A(I,J) + X(I)*TEMP
10 CONTINUE
END IF
20 CONTINUE
ELSE
JX = KX
DO 40 J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = ALPHA*X(JX)
IX = KX
DO 30 I = 1,J
A(I,J) = A(I,J) + X(IX)*TEMP
IX = IX + INCX
30 CONTINUE
END IF
JX = JX + INCX
40 CONTINUE
END IF
ELSE
*
* Form A when A is stored in lower triangle.
*
IF (INCX.EQ.1) THEN
DO 60 J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = ALPHA*X(J)
DO 50 I = J,N
A(I,J) = A(I,J) + X(I)*TEMP
50 CONTINUE
END IF
60 CONTINUE
ELSE
JX = KX
DO 80 J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = ALPHA*X(JX)
IX = JX
DO 70 I = J,N
A(I,J) = A(I,J) + X(IX)*TEMP
IX = IX + INCX
70 CONTINUE
END IF
JX = JX + INCX
80 CONTINUE
END IF
END IF
*
RETURN
*
* End of SSYR .
*
END
SUBROUTINE SSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA)
* .. Scalar Arguments ..
REAL ALPHA
INTEGER INCX,INCY,LDA,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
REAL A(LDA,*),X(*),Y(*)
* ..
*
* Purpose
* =======
*
* SSYR2 performs the symmetric rank 2 operation
*
* A := alpha*x*y' + alpha*y*x' + A,
*
* where alpha is a scalar, x and y are n element vectors and A is an n
* by n symmetric matrix.
*
* Arguments
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the array A is to be referenced as
* follows:
*
* UPLO = 'U' or 'u' Only the upper triangular part of A
* is to be referenced.
*
* UPLO = 'L' or 'l' Only the lower triangular part of A
* is to be referenced.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* ALPHA - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
* Y - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCY ) ).
* Before entry, the incremented array Y must contain the n
* element vector y.
* Unchanged on exit.
*
* INCY - INTEGER.
* On entry, INCY specifies the increment for the elements of
* Y. INCY must not be zero.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U' or 'u', the leading n by n
* upper triangular part of the array A must contain the upper
* triangular part of the symmetric matrix and the strictly
* lower triangular part of A is not referenced. On exit, the
* upper triangular part of the array A is overwritten by the
* upper triangular part of the updated matrix.
* Before entry with UPLO = 'L' or 'l', the leading n by n
* lower triangular part of the array A must contain the lower
* triangular part of the symmetric matrix and the strictly
* upper triangular part of A is not referenced. On exit, the
* lower triangular part of the array A is overwritten by the
* lower triangular part of the updated matrix.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. LDA must be at least
* max( 1, n ).
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- 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 ..
REAL ZERO
PARAMETER (ZERO=0.0E+0)
* ..
* .. Local Scalars ..
REAL TEMP1,TEMP2
INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY
* ..
* .. 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 (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,N)) THEN
INFO = 9
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('SSYR2 ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
*
* Set up the start points in X and Y if the increments are not both
* unity.
*
IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN
IF (INCX.GT.0) THEN
KX = 1
ELSE
KX = 1 - (N-1)*INCX
END IF
IF (INCY.GT.0) THEN
KY = 1
ELSE
KY = 1 - (N-1)*INCY
END IF
JX = KX
JY = KY
END IF
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through the triangular part
* of A.
*
IF (LSAME(UPLO,'U')) THEN
*
* Form A when A is stored in the upper triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 20 J = 1,N
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
TEMP1 = ALPHA*Y(J)
TEMP2 = ALPHA*X(J)
DO 10 I = 1,J
A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
10 CONTINUE
END IF
20 CONTINUE
ELSE
DO 40 J = 1,N
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
TEMP1 = ALPHA*Y(JY)
TEMP2 = ALPHA*X(JX)
IX = KX
IY = KY
DO 30 I = 1,J
A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
IX = IX + INCX
IY = IY + INCY
30 CONTINUE
END IF
JX = JX + INCX
JY = JY + INCY
40 CONTINUE
END IF
ELSE
*
* Form A when A is stored in the lower triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 60 J = 1,N
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
TEMP1 = ALPHA*Y(J)
TEMP2 = ALPHA*X(J)
DO 50 I = J,N
A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
50 CONTINUE
END IF
60 CONTINUE
ELSE
DO 80 J = 1,N
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
TEMP1 = ALPHA*Y(JY)
TEMP2 = ALPHA*X(JX)
IX = JX
IY = JY
DO 70 I = J,N
A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
END IF
JX = JX + INCX
JY = JY + INCY
80 CONTINUE
END IF
END IF
*
RETURN
*
* End of SSYR2 .
*
END
SUBROUTINE SSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
* .. Scalar Arguments ..
REAL ALPHA,BETA
INTEGER K,LDA,LDB,LDC,N
CHARACTER TRANS,UPLO
* ..
* .. Array Arguments ..
REAL A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
* Purpose
* =======
*
* SSYR2K performs one of the symmetric rank 2k operations
*
* C := alpha*A*B' + alpha*B*A' + beta*C,
*
* or
*
* C := alpha*A'*B + alpha*B'*A + beta*C,
*
* where alpha and beta are scalars, C is an n by n symmetric matrix
* and A and B are n by k matrices in the first case and k by n
* matrices in the second case.
*
* Arguments
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the array C is to be referenced as
* follows:
*
* UPLO = 'U' or 'u' Only the upper triangular part of C
* is to be referenced.
*
* UPLO = 'L' or 'l' Only the lower triangular part of C
* is to be referenced.
*
* Unchanged on exit.
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the operation to be performed as
* follows:
*
* TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' +
* beta*C.
*
* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A +
* beta*C.
*
* TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A +
* beta*C.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix C. N must be
* at least zero.
* Unchanged on exit.
*
* K - INTEGER.
* On entry with TRANS = 'N' or 'n', K specifies the number
* of columns of the matrices A and B, and on entry with
* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number
* of rows of the matrices A and B. K must be at least zero.
* Unchanged on exit.
*
* ALPHA - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, ka ), where ka is
* k when TRANS = 'N' or 'n', and is n otherwise.
* Before entry with TRANS = 'N' or 'n', the leading n by k
* part of the array A must contain the matrix A, otherwise
* the leading k by n part of the array A must contain the
* matrix A.
* Unchanged on exit.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. When TRANS = 'N' or 'n'
* then LDA must be at least max( 1, n ), otherwise LDA must
* be at least max( 1, k ).
* Unchanged on exit.
*
* B - REAL array of DIMENSION ( LDB, kb ), where kb is
* k when TRANS = 'N' or 'n', and is n otherwise.
* Before entry with TRANS = 'N' or 'n', the leading n by k
* part of the array B must contain the matrix B, otherwise
* the leading k by n part of the array B must contain the
* matrix B.
* Unchanged on exit.
*
* LDB - INTEGER.
* On entry, LDB specifies the first dimension of B as declared
* in the calling (sub) program. When TRANS = 'N' or 'n'
* then LDB must be at least max( 1, n ), otherwise LDB must
* be at least max( 1, k ).
* Unchanged on exit.
*
* BETA - REAL .
* On entry, BETA specifies the scalar beta.
* Unchanged on exit.
*
* C - REAL array of DIMENSION ( LDC, n ).
* Before entry with UPLO = 'U' or 'u', the leading n by n
* upper triangular part of the array C must contain the upper
* triangular part of the symmetric matrix and the strictly
* lower triangular part of C is not referenced. On exit, the
* upper triangular part of the array C is overwritten by the
* upper triangular part of the updated matrix.
* Before entry with UPLO = 'L' or 'l', the leading n by n
* lower triangular part of the array C must contain the lower
* triangular part of the symmetric matrix and the strictly
* upper triangular part of C is not referenced. On exit, the
* lower triangular part of the array C is overwritten by the
* lower triangular part of the updated matrix.
*
* LDC - INTEGER.
* On entry, LDC specifies the first dimension of C as declared
* in the calling (sub) program. LDC must be at least
* max( 1, n ).
* Unchanged on exit.
*
*
* 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 ..
REAL TEMP1,TEMP2
INTEGER I,INFO,J,L,NROWA
LOGICAL UPPER
* ..
* .. Parameters ..
REAL ONE,ZERO
PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
* ..
*
* Test the input parameters.
*
IF (LSAME(TRANS,'N')) THEN
NROWA = N
ELSE
NROWA = K
END IF
UPPER = LSAME(UPLO,'U')
*
INFO = 0
IF ((.NOT.UPPER) .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 (N.LT.0) THEN
INFO = 3
ELSE IF (K.LT.0) THEN
INFO = 4
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
INFO = 7
ELSE IF (LDB.LT.MAX(1,NROWA)) THEN
INFO = 9
ELSE IF (LDC.LT.MAX(1,N)) THEN
INFO = 12
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('SSYR2K',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR.
+ (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
*
* And when alpha.eq.zero.
*
IF (ALPHA.EQ.ZERO) THEN
IF (UPPER) THEN
IF (BETA.EQ.ZERO) THEN
DO 20 J = 1,N
DO 10 I = 1,J
C(I,J) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1,N
DO 30 I = 1,J
C(I,J) = BETA*C(I,J)
30 CONTINUE
40 CONTINUE
END IF
ELSE
IF (BETA.EQ.ZERO) THEN
DO 60 J = 1,N
DO 50 I = J,N
C(I,J) = ZERO
50 CONTINUE
60 CONTINUE
ELSE
DO 80 J = 1,N
DO 70 I = J,N
C(I,J) = BETA*C(I,J)
70 CONTINUE
80 CONTINUE
END IF
END IF
RETURN
END IF
*
* Start the operations.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form C := alpha*A*B' + alpha*B*A' + C.
*
IF (UPPER) THEN
DO 130 J = 1,N
IF (BETA.EQ.ZERO) THEN
DO 90 I = 1,J
C(I,J) = ZERO
90 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
DO 100 I = 1,J
C(I,J) = BETA*C(I,J)
100 CONTINUE
END IF
DO 120 L = 1,K
IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
TEMP1 = ALPHA*B(J,L)
TEMP2 = ALPHA*A(J,L)
DO 110 I = 1,J
C(I,J) = C(I,J) + A(I,L)*TEMP1 +
+ B(I,L)*TEMP2
110 CONTINUE
END IF
120 CONTINUE
130 CONTINUE
ELSE
DO 180 J = 1,N
IF (BETA.EQ.ZERO) THEN
DO 140 I = J,N
C(I,J) = ZERO
140 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
DO 150 I = J,N
C(I,J) = BETA*C(I,J)
150 CONTINUE
END IF
DO 170 L = 1,K
IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
TEMP1 = ALPHA*B(J,L)
TEMP2 = ALPHA*A(J,L)
DO 160 I = J,N
C(I,J) = C(I,J) + A(I,L)*TEMP1 +
+ B(I,L)*TEMP2
160 CONTINUE
END IF
170 CONTINUE
180 CONTINUE
END IF
ELSE
*
* Form C := alpha*A'*B + alpha*B'*A + C.
*
IF (UPPER) THEN
DO 210 J = 1,N
DO 200 I = 1,J
TEMP1 = ZERO
TEMP2 = ZERO
DO 190 L = 1,K
TEMP1 = TEMP1 + A(L,I)*B(L,J)
TEMP2 = TEMP2 + B(L,I)*A(L,J)
190 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2
ELSE
C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
+ ALPHA*TEMP2
END IF
200 CONTINUE
210 CONTINUE
ELSE
DO 240 J = 1,N
DO 230 I = J,N
TEMP1 = ZERO
TEMP2 = ZERO
DO 220 L = 1,K
TEMP1 = TEMP1 + A(L,I)*B(L,J)
TEMP2 = TEMP2 + B(L,I)*A(L,J)
220 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2
ELSE
C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
+ ALPHA*TEMP2
END IF
230 CONTINUE
240 CONTINUE
END IF
END IF
*
RETURN
*
* End of SSYR2K.
*
END
SUBROUTINE SSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
* .. Scalar Arguments ..
REAL ALPHA,BETA
INTEGER K,LDA,LDC,N
CHARACTER TRANS,UPLO
* ..
* .. Array Arguments ..
REAL A(LDA,*),C(LDC,*)
* ..
*
* Purpose
* =======
*
* SSYRK performs one of the symmetric rank k operations
*
* C := alpha*A*A' + beta*C,
*
* or
*
* C := alpha*A'*A + beta*C,
*
* where alpha and beta are scalars, C is an n by n symmetric matrix
* and A is an n by k matrix in the first case and a k by n matrix
* in the second case.
*
* Arguments
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the array C is to be referenced as
* follows:
*
* UPLO = 'U' or 'u' Only the upper triangular part of C
* is to be referenced.
*
* UPLO = 'L' or 'l' Only the lower triangular part of C
* is to be referenced.
*
* Unchanged on exit.
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the operation to be performed as
* follows:
*
* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C.
*
* TRANS = 'T' or 't' C := alpha*A'*A + beta*C.
*
* TRANS = 'C' or 'c' C := alpha*A'*A + beta*C.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix C. N must be
* at least zero.
* Unchanged on exit.
*
* K - INTEGER.
* On entry with TRANS = 'N' or 'n', K specifies the number
* of columns of the matrix A, and on entry with
* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number
* of rows of the matrix A. K must be at least zero.
* Unchanged on exit.
*
* ALPHA - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, ka ), where ka is
* k when TRANS = 'N' or 'n', and is n otherwise.
* Before entry with TRANS = 'N' or 'n', the leading n by k
* part of the array A must contain the matrix A, otherwise
* the leading k by n part of the array A must contain the
* matrix A.
* Unchanged on exit.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. When TRANS = 'N' or 'n'
* then LDA must be at least max( 1, n ), otherwise LDA must
* be at least max( 1, k ).
* Unchanged on exit.
*
* BETA - REAL .
* On entry, BETA specifies the scalar beta.
* Unchanged on exit.
*
* C - REAL array of DIMENSION ( LDC, n ).
* Before entry with UPLO = 'U' or 'u', the leading n by n
* upper triangular part of the array C must contain the upper
* triangular part of the symmetric matrix and the strictly
* lower triangular part of C is not referenced. On exit, the
* upper triangular part of the array C is overwritten by the
* upper triangular part of the updated matrix.
* Before entry with UPLO = 'L' or 'l', the leading n by n
* lower triangular part of the array C must contain the lower
* triangular part of the symmetric matrix and the strictly
* upper triangular part of C is not referenced. On exit, the
* lower triangular part of the array C is overwritten by the
* lower triangular part of the updated matrix.
*
* LDC - INTEGER.
* On entry, LDC specifies the first dimension of C as declared
* in the calling (sub) program. LDC must be at least
* max( 1, n ).
* Unchanged on exit.
*
*
* 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 ..
REAL TEMP
INTEGER I,INFO,J,L,NROWA
LOGICAL UPPER
* ..
* .. Parameters ..
REAL ONE,ZERO
PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
* ..
*
* Test the input parameters.
*
IF (LSAME(TRANS,'N')) THEN
NROWA = N
ELSE
NROWA = K
END IF
UPPER = LSAME(UPLO,'U')
*
INFO = 0
IF ((.NOT.UPPER) .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 (N.LT.0) THEN
INFO = 3
ELSE IF (K.LT.0) THEN
INFO = 4
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
INFO = 7
ELSE IF (LDC.LT.MAX(1,N)) THEN
INFO = 10
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('SSYRK ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR.
+ (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
*
* And when alpha.eq.zero.
*
IF (ALPHA.EQ.ZERO) THEN
IF (UPPER) THEN
IF (BETA.EQ.ZERO) THEN
DO 20 J = 1,N
DO 10 I = 1,J
C(I,J) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1,N
DO 30 I = 1,J
C(I,J) = BETA*C(I,J)
30 CONTINUE
40 CONTINUE
END IF
ELSE
IF (BETA.EQ.ZERO) THEN
DO 60 J = 1,N
DO 50 I = J,N
C(I,J) = ZERO
50 CONTINUE
60 CONTINUE
ELSE
DO 80 J = 1,N
DO 70 I = J,N
C(I,J) = BETA*C(I,J)
70 CONTINUE
80 CONTINUE
END IF
END IF
RETURN
END IF
*
* Start the operations.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form C := alpha*A*A' + beta*C.
*
IF (UPPER) THEN
DO 130 J = 1,N
IF (BETA.EQ.ZERO) THEN
DO 90 I = 1,J
C(I,J) = ZERO
90 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
DO 100 I = 1,J
C(I,J) = BETA*C(I,J)
100 CONTINUE
END IF
DO 120 L = 1,K
IF (A(J,L).NE.ZERO) THEN
TEMP = ALPHA*A(J,L)
DO 110 I = 1,J
C(I,J) = C(I,J) + TEMP*A(I,L)
110 CONTINUE
END IF
120 CONTINUE
130 CONTINUE
ELSE
DO 180 J = 1,N
IF (BETA.EQ.ZERO) THEN
DO 140 I = J,N
C(I,J) = ZERO
140 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
DO 150 I = J,N
C(I,J) = BETA*C(I,J)
150 CONTINUE
END IF
DO 170 L = 1,K
IF (A(J,L).NE.ZERO) THEN
TEMP = ALPHA*A(J,L)
DO 160 I = J,N
C(I,J) = C(I,J) + TEMP*A(I,L)
160 CONTINUE
END IF
170 CONTINUE
180 CONTINUE
END IF
ELSE
*
* Form C := alpha*A'*A + beta*C.
*
IF (UPPER) THEN
DO 210 J = 1,N
DO 200 I = 1,J
TEMP = ZERO
DO 190 L = 1,K
TEMP = TEMP + A(L,I)*A(L,J)
190 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP
ELSE
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
END IF
200 CONTINUE
210 CONTINUE
ELSE
DO 240 J = 1,N
DO 230 I = J,N
TEMP = ZERO
DO 220 L = 1,K
TEMP = TEMP + A(L,I)*A(L,J)
220 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP
ELSE
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
END IF
230 CONTINUE
240 CONTINUE
END IF
END IF
*
RETURN
*
* End of SSYRK .
*
END
SUBROUTINE STBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
* .. Scalar Arguments ..
INTEGER INCX,K,LDA,N
CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
REAL A(LDA,*),X(*)
* ..
*
* Purpose
* =======
*
* STBMV performs one of the matrix-vector operations
*
* x := A*x, or x := A'*x,
*
* where x is an n element vector and A is an n by n unit, or non-unit,
* upper or lower triangular band matrix, with ( k + 1 ) diagonals.
*
* Arguments
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the matrix 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.
*
* Unchanged on exit.
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the operation to be performed as
* follows:
*
* TRANS = 'N' or 'n' x := A*x.
*
* TRANS = 'T' or 't' x := A'*x.
*
* TRANS = 'C' or 'c' x := A'*x.
*
* Unchanged on exit.
*
* DIAG - 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.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* K - INTEGER.
* On entry with UPLO = 'U' or 'u', K specifies the number of
* super-diagonals of the matrix A.
* On entry with UPLO = 'L' or 'l', K specifies the number of
* sub-diagonals of the matrix A.
* K must satisfy 0 .le. K.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
* by n part of the array A must contain the upper triangular
* band part of the matrix of coefficients, supplied column by
* column, with the leading diagonal of the matrix in row
* ( k + 1 ) of the array, the first super-diagonal starting at
* position 2 in row k, and so on. The top left k by k triangle
* of the array A is not referenced.
* The following program segment will transfer an upper
* triangular band matrix from conventional full matrix storage
* to band storage:
*
* DO 20, J = 1, N
* M = K + 1 - J
* DO 10, I = MAX( 1, J - K ), J
* A( M + I, J ) = matrix( I, J )
* 10 CONTINUE
* 20 CONTINUE
*
* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
* by n part of the array A must contain the lower triangular
* band part of the matrix of coefficients, supplied column by
* column, with the leading diagonal of the matrix in row 1 of
* the array, the first sub-diagonal starting at position 1 in
* row 2, and so on. The bottom right k by k triangle of the
* array A is not referenced.
* The following program segment will transfer a lower
* triangular band matrix from conventional full matrix storage
* to band storage:
*
* DO 20, J = 1, N
* M = 1 - J
* DO 10, I = J, MIN( N, J + K )
* A( M + I, J ) = matrix( I, J )
* 10 CONTINUE
* 20 CONTINUE
*
* Note that when DIAG = 'U' or 'u' the elements of the array A
* corresponding to the diagonal elements of the matrix are not
* referenced, but are assumed to be unity.
* Unchanged on exit.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. LDA must be at least
* ( k + 1 ).
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x. On exit, X is overwritten with the
* tranformed vector x.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- 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 ..
REAL ZERO
PARAMETER (ZERO=0.0E+0)
* ..
* .. Local Scalars ..
REAL TEMP
INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L
LOGICAL NOUNIT
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX,MIN
* ..
*
* 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 (K.LT.0) THEN
INFO = 5
ELSE IF (LDA.LT. (K+1)) THEN
INFO = 7
ELSE IF (INCX.EQ.0) THEN
INFO = 9
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('STBMV ',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
KPLUS1 = K + 1
IF (INCX.EQ.1) THEN
DO 20 J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = X(J)
L = KPLUS1 - J
DO 10 I = MAX(1,J-K),J - 1
X(I) = X(I) + TEMP*A(L+I,J)
10 CONTINUE
IF (NOUNIT) X(J) = X(J)*A(KPLUS1,J)
END IF
20 CONTINUE
ELSE
JX = KX
DO 40 J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = X(JX)
IX = KX
L = KPLUS1 - J
DO 30 I = MAX(1,J-K),J - 1
X(IX) = X(IX) + TEMP*A(L+I,J)
IX = IX + INCX
30 CONTINUE
IF (NOUNIT) X(JX) = X(JX)*A(KPLUS1,J)
END IF
JX = JX + INCX
IF (J.GT.K) KX = KX + 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)
L = 1 - J
DO 50 I = MIN(N,J+K),J + 1,-1
X(I) = X(I) + TEMP*A(L+I,J)
50 CONTINUE
IF (NOUNIT) X(J) = X(J)*A(1,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
L = 1 - J
DO 70 I = MIN(N,J+K),J + 1,-1
X(IX) = X(IX) + TEMP*A(L+I,J)
IX = IX - INCX
70 CONTINUE
IF (NOUNIT) X(JX) = X(JX)*A(1,J)
END IF
JX = JX - INCX
IF ((N-J).GE.K) KX = KX - INCX
80 CONTINUE
END IF
END IF
ELSE
*
* Form x := A'*x.
*
IF (LSAME(UPLO,'U')) THEN
KPLUS1 = K + 1
IF (INCX.EQ.1) THEN
DO 100 J = N,1,-1
TEMP = X(J)
L = KPLUS1 - J
IF (NOUNIT) TEMP = TEMP*A(KPLUS1,J)
DO 90 I = J - 1,MAX(1,J-K),-1
TEMP = TEMP + A(L+I,J)*X(I)
90 CONTINUE
X(J) = TEMP
100 CONTINUE
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 120 J = N,1,-1
TEMP = X(JX)
KX = KX - INCX
IX = KX
L = KPLUS1 - J
IF (NOUNIT) TEMP = TEMP*A(KPLUS1,J)
DO 110 I = J - 1,MAX(1,J-K),-1
TEMP = TEMP + A(L+I,J)*X(IX)
IX = IX - INCX
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)
L = 1 - J
IF (NOUNIT) TEMP = TEMP*A(1,J)
DO 130 I = J + 1,MIN(N,J+K)
TEMP = TEMP + A(L+I,J)*X(I)
130 CONTINUE
X(J) = TEMP
140 CONTINUE
ELSE
JX = KX
DO 160 J = 1,N
TEMP = X(JX)
KX = KX + INCX
IX = KX
L = 1 - J
IF (NOUNIT) TEMP = TEMP*A(1,J)
DO 150 I = J + 1,MIN(N,J+K)
TEMP = TEMP + A(L+I,J)*X(IX)
IX = IX + INCX
150 CONTINUE
X(JX) = TEMP
JX = JX + INCX
160 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of STBMV .
*
END
SUBROUTINE STBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
* .. Scalar Arguments ..
INTEGER INCX,K,LDA,N
CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
REAL A(LDA,*),X(*)
* ..
*
* Purpose
* =======
*
* STBSV solves one of the systems of equations
*
* A*x = b, or A'*x = b,
*
* where b and x are n element vectors and A is an n by n unit, or
* non-unit, upper or lower triangular band matrix, with ( k + 1 )
* diagonals.
*
* No test for singularity or near-singularity is included in this
* routine. Such tests must be performed before calling this routine.
*
* Arguments
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the matrix 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.
*
* Unchanged on exit.
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the equations to be solved as
* follows:
*
* TRANS = 'N' or 'n' A*x = b.
*
* TRANS = 'T' or 't' A'*x = b.
*
* TRANS = 'C' or 'c' A'*x = b.
*
* Unchanged on exit.
*
* DIAG - 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.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* K - INTEGER.
* On entry with UPLO = 'U' or 'u', K specifies the number of
* super-diagonals of the matrix A.
* On entry with UPLO = 'L' or 'l', K specifies the number of
* sub-diagonals of the matrix A.
* K must satisfy 0 .le. K.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
* by n part of the array A must contain the upper triangular
* band part of the matrix of coefficients, supplied column by
* column, with the leading diagonal of the matrix in row
* ( k + 1 ) of the array, the first super-diagonal starting at
* position 2 in row k, and so on. The top left k by k triangle
* of the array A is not referenced.
* The following program segment will transfer an upper
* triangular band matrix from conventional full matrix storage
* to band storage:
*
* DO 20, J = 1, N
* M = K + 1 - J
* DO 10, I = MAX( 1, J - K ), J
* A( M + I, J ) = matrix( I, J )
* 10 CONTINUE
* 20 CONTINUE
*
* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
* by n part of the array A must contain the lower triangular
* band part of the matrix of coefficients, supplied column by
* column, with the leading diagonal of the matrix in row 1 of
* the array, the first sub-diagonal starting at position 1 in
* row 2, and so on. The bottom right k by k triangle of the
* array A is not referenced.
* The following program segment will transfer a lower
* triangular band matrix from conventional full matrix storage
* to band storage:
*
* DO 20, J = 1, N
* M = 1 - J
* DO 10, I = J, MIN( N, J + K )
* A( M + I, J ) = matrix( I, J )
* 10 CONTINUE
* 20 CONTINUE
*
* Note that when DIAG = 'U' or 'u' the elements of the array A
* corresponding to the diagonal elements of the matrix are not
* referenced, but are assumed to be unity.
* Unchanged on exit.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. LDA must be at least
* ( k + 1 ).
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element right-hand side vector b. On exit, X is overwritten
* with the solution vector x.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- 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 ..
REAL ZERO
PARAMETER (ZERO=0.0E+0)
* ..
* .. Local Scalars ..
REAL TEMP
INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L
LOGICAL NOUNIT
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX,MIN
* ..
*
* 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 (K.LT.0) THEN
INFO = 5
ELSE IF (LDA.LT. (K+1)) THEN
INFO = 7
ELSE IF (INCX.EQ.0) THEN
INFO = 9
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('STBSV ',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 by sequentially with one pass through A.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form x := inv( A )*x.
*
IF (LSAME(UPLO,'U')) THEN
KPLUS1 = K + 1
IF (INCX.EQ.1) THEN
DO 20 J = N,1,-1
IF (X(J).NE.ZERO) THEN
L = KPLUS1 - J
IF (NOUNIT) X(J) = X(J)/A(KPLUS1,J)
TEMP = X(J)
DO 10 I = J - 1,MAX(1,J-K),-1
X(I) = X(I) - TEMP*A(L+I,J)
10 CONTINUE
END IF
20 CONTINUE
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 40 J = N,1,-1
KX = KX - INCX
IF (X(JX).NE.ZERO) THEN
IX = KX
L = KPLUS1 - J
IF (NOUNIT) X(JX) = X(JX)/A(KPLUS1,J)
TEMP = X(JX)
DO 30 I = J - 1,MAX(1,J-K),-1
X(IX) = X(IX) - TEMP*A(L+I,J)
IX = IX - INCX
30 CONTINUE
END IF
JX = JX - INCX
40 CONTINUE
END IF
ELSE
IF (INCX.EQ.1) THEN
DO 60 J = 1,N
IF (X(J).NE.ZERO) THEN
L = 1 - J
IF (NOUNIT) X(J) = X(J)/A(1,J)
TEMP = X(J)
DO 50 I = J + 1,MIN(N,J+K)
X(I) = X(I) - TEMP*A(L+I,J)
50 CONTINUE
END IF
60 CONTINUE
ELSE
JX = KX
DO 80 J = 1,N
KX = KX + INCX
IF (X(JX).NE.ZERO) THEN
IX = KX
L = 1 - J
IF (NOUNIT) X(JX) = X(JX)/A(1,J)
TEMP = X(JX)
DO 70 I = J + 1,MIN(N,J+K)
X(IX) = X(IX) - TEMP*A(L+I,J)
IX = IX + INCX
70 CONTINUE
END IF
JX = JX + INCX
80 CONTINUE
END IF
END IF
ELSE
*
* Form x := inv( A')*x.
*
IF (LSAME(UPLO,'U')) THEN
KPLUS1 = K + 1
IF (INCX.EQ.1) THEN
DO 100 J = 1,N
TEMP = X(J)
L = KPLUS1 - J
DO 90 I = MAX(1,J-K),J - 1
TEMP = TEMP - A(L+I,J)*X(I)
90 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J)
X(J) = TEMP
100 CONTINUE
ELSE
JX = KX
DO 120 J = 1,N
TEMP = X(JX)
IX = KX
L = KPLUS1 - J
DO 110 I = MAX(1,J-K),J - 1
TEMP = TEMP - A(L+I,J)*X(IX)
IX = IX + INCX
110 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J)
X(JX) = TEMP
JX = JX + INCX
IF (J.GT.K) KX = KX + INCX
120 CONTINUE
END IF
ELSE
IF (INCX.EQ.1) THEN
DO 140 J = N,1,-1
TEMP = X(J)
L = 1 - J
DO 130 I = MIN(N,J+K),J + 1,-1
TEMP = TEMP - A(L+I,J)*X(I)
130 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(1,J)
X(J) = TEMP
140 CONTINUE
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 160 J = N,1,-1
TEMP = X(JX)
IX = KX
L = 1 - J
DO 150 I = MIN(N,J+K),J + 1,-1
TEMP = TEMP - A(L+I,J)*X(IX)
IX = IX - INCX
150 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(1,J)
X(JX) = TEMP
JX = JX - INCX
IF ((N-J).GE.K) KX = KX - INCX
160 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of STBSV .
*
END
SUBROUTINE STPMV(UPLO,TRANS,DIAG,N,AP,X,INCX)
* .. Scalar Arguments ..
INTEGER INCX,N
CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
REAL AP(*),X(*)
* ..
*
* Purpose
* =======
*
* STPMV performs one of the matrix-vector operations
*
* x := A*x, or x := A'*x,
*
* where x is an n element vector and A is an n by n unit, or non-unit,
* upper or lower triangular matrix, supplied in packed form.
*
* Arguments
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the matrix 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.
*
* Unchanged on exit.
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the operation to be performed as
* follows:
*
* TRANS = 'N' or 'n' x := A*x.
*
* TRANS = 'T' or 't' x := A'*x.
*
* TRANS = 'C' or 'c' x := A'*x.
*
* Unchanged on exit.
*
* DIAG - 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.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* AP - REAL array of DIMENSION at least
* ( ( n*( n + 1 ) )/2 ).
* Before entry with UPLO = 'U' or 'u', the array AP must
* contain the upper triangular matrix packed sequentially,
* column by column, so that AP( 1 ) contains a( 1, 1 ),
* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
* respectively, and so on.
* Before entry with UPLO = 'L' or 'l', the array AP must
* contain the lower triangular matrix packed sequentially,
* column by column, so that AP( 1 ) contains a( 1, 1 ),
* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
* respectively, and so on.
* Note that when DIAG = 'U' or 'u', the diagonal elements of
* A are not referenced, but are assumed to be unity.
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x. On exit, X is overwritten with the
* tranformed vector x.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- 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 ..
REAL ZERO
PARAMETER (ZERO=0.0E+0)
* ..
* .. Local Scalars ..
REAL TEMP
INTEGER I,INFO,IX,J,JX,K,KK,KX
LOGICAL NOUNIT
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
*
* 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 (INCX.EQ.0) THEN
INFO = 7
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('STPMV ',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 AP are
* accessed sequentially with one pass through AP.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form x:= A*x.
*
IF (LSAME(UPLO,'U')) THEN
KK = 1
IF (INCX.EQ.1) THEN
DO 20 J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = X(J)
K = KK
DO 10 I = 1,J - 1
X(I) = X(I) + TEMP*AP(K)
K = K + 1
10 CONTINUE
IF (NOUNIT) X(J) = X(J)*AP(KK+J-1)
END IF
KK = KK + J
20 CONTINUE
ELSE
JX = KX
DO 40 J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = X(JX)
IX = KX
DO 30 K = KK,KK + J - 2
X(IX) = X(IX) + TEMP*AP(K)
IX = IX + INCX
30 CONTINUE
IF (NOUNIT) X(JX) = X(JX)*AP(KK+J-1)
END IF
JX = JX + INCX
KK = KK + J
40 CONTINUE
END IF
ELSE
KK = (N* (N+1))/2
IF (INCX.EQ.1) THEN
DO 60 J = N,1,-1
IF (X(J).NE.ZERO) THEN
TEMP = X(J)
K = KK
DO 50 I = N,J + 1,-1
X(I) = X(I) + TEMP*AP(K)
K = K - 1
50 CONTINUE
IF (NOUNIT) X(J) = X(J)*AP(KK-N+J)
END IF
KK = KK - (N-J+1)
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 K = KK,KK - (N- (J+1)),-1
X(IX) = X(IX) + TEMP*AP(K)
IX = IX - INCX
70 CONTINUE
IF (NOUNIT) X(JX) = X(JX)*AP(KK-N+J)
END IF
JX = JX - INCX
KK = KK - (N-J+1)
80 CONTINUE
END IF
END IF
ELSE
*
* Form x := A'*x.
*
IF (LSAME(UPLO,'U')) THEN
KK = (N* (N+1))/2
IF (INCX.EQ.1) THEN
DO 100 J = N,1,-1
TEMP = X(J)
IF (NOUNIT) TEMP = TEMP*AP(KK)
K = KK - 1
DO 90 I = J - 1,1,-1
TEMP = TEMP + AP(K)*X(I)
K = K - 1
90 CONTINUE
X(J) = TEMP
KK = KK - J
100 CONTINUE
ELSE
JX = KX + (N-1)*INCX
DO 120 J = N,1,-1
TEMP = X(JX)
IX = JX
IF (NOUNIT) TEMP = TEMP*AP(KK)
DO 110 K = KK - 1,KK - J + 1,-1
IX = IX - INCX
TEMP = TEMP + AP(K)*X(IX)
110 CONTINUE
X(JX) = TEMP
JX = JX - INCX
KK = KK - J
120 CONTINUE
END IF
ELSE
KK = 1
IF (INCX.EQ.1) THEN
DO 140 J = 1,N
TEMP = X(J)
IF (NOUNIT) TEMP = TEMP*AP(KK)
K = KK + 1
DO 130 I = J + 1,N
TEMP = TEMP + AP(K)*X(I)
K = K + 1
130 CONTINUE
X(J) = TEMP
KK = KK + (N-J+1)
140 CONTINUE
ELSE
JX = KX
DO 160 J = 1,N
TEMP = X(JX)
IX = JX
IF (NOUNIT) TEMP = TEMP*AP(KK)
DO 150 K = KK + 1,KK + N - J
IX = IX + INCX
TEMP = TEMP + AP(K)*X(IX)
150 CONTINUE
X(JX) = TEMP
JX = JX + INCX
KK = KK + (N-J+1)
160 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of STPMV .
*
END
SUBROUTINE STPSV(UPLO,TRANS,DIAG,N,AP,X,INCX)
* .. Scalar Arguments ..
INTEGER INCX,N
CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
REAL AP(*),X(*)
* ..
*
* Purpose
* =======
*
* STPSV solves one of the systems of equations
*
* A*x = b, or A'*x = b,
*
* where b and x are n element vectors and A is an n by n unit, or
* non-unit, upper or lower triangular matrix, supplied in packed form.
*
* No test for singularity or near-singularity is included in this
* routine. Such tests must be performed before calling this routine.
*
* Arguments
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the matrix 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.
*
* Unchanged on exit.
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the equations to be solved as
* follows:
*
* TRANS = 'N' or 'n' A*x = b.
*
* TRANS = 'T' or 't' A'*x = b.
*
* TRANS = 'C' or 'c' A'*x = b.
*
* Unchanged on exit.
*
* DIAG - 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.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* AP - REAL array of DIMENSION at least
* ( ( n*( n + 1 ) )/2 ).
* Before entry with UPLO = 'U' or 'u', the array AP must
* contain the upper triangular matrix packed sequentially,
* column by column, so that AP( 1 ) contains a( 1, 1 ),
* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
* respectively, and so on.
* Before entry with UPLO = 'L' or 'l', the array AP must
* contain the lower triangular matrix packed sequentially,
* column by column, so that AP( 1 ) contains a( 1, 1 ),
* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
* respectively, and so on.
* Note that when DIAG = 'U' or 'u', the diagonal elements of
* A are not referenced, but are assumed to be unity.
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element right-hand side vector b. On exit, X is overwritten
* with the solution vector x.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- 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 ..
REAL ZERO
PARAMETER (ZERO=0.0E+0)
* ..
* .. Local Scalars ..
REAL TEMP
INTEGER I,INFO,IX,J,JX,K,KK,KX
LOGICAL NOUNIT
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
*
* 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 (INCX.EQ.0) THEN
INFO = 7
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('STPSV ',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 AP are
* accessed sequentially with one pass through AP.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form x := inv( A )*x.
*
IF (LSAME(UPLO,'U')) THEN
KK = (N* (N+1))/2
IF (INCX.EQ.1) THEN
DO 20 J = N,1,-1
IF (X(J).NE.ZERO) THEN
IF (NOUNIT) X(J) = X(J)/AP(KK)
TEMP = X(J)
K = KK - 1
DO 10 I = J - 1,1,-1
X(I) = X(I) - TEMP*AP(K)
K = K - 1
10 CONTINUE
END IF
KK = KK - J
20 CONTINUE
ELSE
JX = KX + (N-1)*INCX
DO 40 J = N,1,-1
IF (X(JX).NE.ZERO) THEN
IF (NOUNIT) X(JX) = X(JX)/AP(KK)
TEMP = X(JX)
IX = JX
DO 30 K = KK - 1,KK - J + 1,-1
IX = IX - INCX
X(IX) = X(IX) - TEMP*AP(K)
30 CONTINUE
END IF
JX = JX - INCX
KK = KK - J
40 CONTINUE
END IF
ELSE
KK = 1
IF (INCX.EQ.1) THEN
DO 60 J = 1,N
IF (X(J).NE.ZERO) THEN
IF (NOUNIT) X(J) = X(J)/AP(KK)
TEMP = X(J)
K = KK + 1
DO 50 I = J + 1,N
X(I) = X(I) - TEMP*AP(K)
K = K + 1
50 CONTINUE
END IF
KK = KK + (N-J+1)
60 CONTINUE
ELSE
JX = KX
DO 80 J = 1,N
IF (X(JX).NE.ZERO) THEN
IF (NOUNIT) X(JX) = X(JX)/AP(KK)
TEMP = X(JX)
IX = JX
DO 70 K = KK + 1,KK + N - J
IX = IX + INCX
X(IX) = X(IX) - TEMP*AP(K)
70 CONTINUE
END IF
JX = JX + INCX
KK = KK + (N-J+1)
80 CONTINUE
END IF
END IF
ELSE
*
* Form x := inv( A' )*x.
*
IF (LSAME(UPLO,'U')) THEN
KK = 1
IF (INCX.EQ.1) THEN
DO 100 J = 1,N
TEMP = X(J)
K = KK
DO 90 I = 1,J - 1
TEMP = TEMP - AP(K)*X(I)
K = K + 1
90 CONTINUE
IF (NOUNIT) TEMP = TEMP/AP(KK+J-1)
X(J) = TEMP
KK = KK + J
100 CONTINUE
ELSE
JX = KX
DO 120 J = 1,N
TEMP = X(JX)
IX = KX
DO 110 K = KK,KK + J - 2
TEMP = TEMP - AP(K)*X(IX)
IX = IX + INCX
110 CONTINUE
IF (NOUNIT) TEMP = TEMP/AP(KK+J-1)
X(JX) = TEMP
JX = JX + INCX
KK = KK + J
120 CONTINUE
END IF
ELSE
KK = (N* (N+1))/2
IF (INCX.EQ.1) THEN
DO 140 J = N,1,-1
TEMP = X(J)
K = KK
DO 130 I = N,J + 1,-1
TEMP = TEMP - AP(K)*X(I)
K = K - 1
130 CONTINUE
IF (NOUNIT) TEMP = TEMP/AP(KK-N+J)
X(J) = TEMP
KK = KK - (N-J+1)
140 CONTINUE
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 160 J = N,1,-1
TEMP = X(JX)
IX = KX
DO 150 K = KK,KK - (N- (J+1)),-1
TEMP = TEMP - AP(K)*X(IX)
IX = IX - INCX
150 CONTINUE
IF (NOUNIT) TEMP = TEMP/AP(KK-N+J)
X(JX) = TEMP
JX = JX - INCX
KK = KK - (N-J+1)
160 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of STPSV .
*
END
SUBROUTINE STRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
* .. Scalar Arguments ..
REAL ALPHA
INTEGER LDA,LDB,M,N
CHARACTER DIAG,SIDE,TRANSA,UPLO
* ..
* .. Array Arguments ..
REAL A(LDA,*),B(LDB,*)
* ..
*
* Purpose
* =======
*
* STRMM performs one of the matrix-matrix operations
*
* B := alpha*op( A )*B, or B := alpha*B*op( A ),
*
* where alpha is a scalar, B is an m by n matrix, 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'.
*
* Arguments
* ==========
*
* SIDE - CHARACTER*1.
* On entry, SIDE specifies whether op( A ) multiplies B from
* the left or right as follows:
*
* SIDE = 'L' or 'l' B := alpha*op( A )*B.
*
* SIDE = 'R' or 'r' B := alpha*B*op( A ).
*
* Unchanged on exit.
*
* UPLO - 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.
*
* Unchanged on exit.
*
* TRANSA - 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'.
*
* TRANSA = 'C' or 'c' op( A ) = A'.
*
* Unchanged on exit.
*
* DIAG - 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.
*
* Unchanged on exit.
*
* M - INTEGER.
* On entry, M specifies the number of rows of B. M must be at
* least zero.
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the number of columns of B. N must be
* at least zero.
* Unchanged on exit.
*
* ALPHA - REAL .
* On entry, ALPHA specifies the scalar alpha. When alpha is
* zero then A is not referenced and B need not be set before
* entry.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, k ), where k is m
* when SIDE = 'L' or 'l' and 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.
* Unchanged on exit.
*
* LDA - 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 ).
* Unchanged on exit.
*
* B - REAL array of DIMENSION ( LDB, n ).
* Before entry, the leading m by n part of the array B must
* contain the matrix B, and on exit is overwritten by the
* transformed matrix.
*
* LDB - 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 ).
* Unchanged on exit.
*
*
* 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 ..
REAL TEMP
INTEGER I,INFO,J,K,NROWA
LOGICAL LSIDE,NOUNIT,UPPER
* ..
* .. Parameters ..
REAL ONE,ZERO
PARAMETER (ONE=1.0E+0,ZERO=0.0E+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('STRMM ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF (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'*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'.
*
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 STRMM .
*
END
SUBROUTINE STRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
* .. Scalar Arguments ..
INTEGER INCX,LDA,N
CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
REAL A(LDA,*),X(*)
* ..
*
* Purpose
* =======
*
* STRMV performs one of the matrix-vector operations
*
* x := A*x, or x := A'*x,
*
* where x is an n element vector and A is an n by n unit, or non-unit,
* upper or lower triangular matrix.
*
* Arguments
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the matrix 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.
*
* Unchanged on exit.
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the operation to be performed as
* follows:
*
* TRANS = 'N' or 'n' x := A*x.
*
* TRANS = 'T' or 't' x := A'*x.
*
* TRANS = 'C' or 'c' x := A'*x.
*
* Unchanged on exit.
*
* DIAG - 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.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U' or 'u', the leading n by n
* 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 n by n
* 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.
* Unchanged on exit.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. LDA must be at least
* max( 1, n ).
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x. On exit, X is overwritten with the
* tranformed vector x.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- 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 ..
REAL ZERO
PARAMETER (ZERO=0.0E+0)
* ..
* .. Local Scalars ..
REAL 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('STRMV ',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'*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 STRMV .
*
END
SUBROUTINE STRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
* .. Scalar Arguments ..
REAL ALPHA
INTEGER LDA,LDB,M,N
CHARACTER DIAG,SIDE,TRANSA,UPLO
* ..
* .. Array Arguments ..
REAL A(LDA,*),B(LDB,*)
* ..
*
* Purpose
* =======
*
* STRSM 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'.
*
* The matrix X is overwritten on B.
*
* Arguments
* ==========
*
* SIDE - 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.
*
* Unchanged on exit.
*
* UPLO - 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.
*
* Unchanged on exit.
*
* TRANSA - 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'.
*
* TRANSA = 'C' or 'c' op( A ) = A'.
*
* Unchanged on exit.
*
* DIAG - 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.
*
* Unchanged on exit.
*
* M - INTEGER.
* On entry, M specifies the number of rows of B. M must be at
* least zero.
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the number of columns of B. N must be
* at least zero.
* Unchanged on exit.
*
* ALPHA - REAL .
* On entry, ALPHA specifies the scalar alpha. When alpha is
* zero then A is not referenced and B need not be set before
* entry.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, k ), where k is m
* when SIDE = 'L' or 'l' and 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.
* Unchanged on exit.
*
* LDA - 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 ).
* Unchanged on exit.
*
* B - REAL array of 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 - 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 ).
* Unchanged on exit.
*
*
* 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 ..
REAL TEMP
INTEGER I,INFO,J,K,NROWA
LOGICAL LSIDE,NOUNIT,UPPER
* ..
* .. Parameters ..
REAL ONE,ZERO
PARAMETER (ONE=1.0E+0,ZERO=0.0E+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('STRSM ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF (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' )*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' ).
*
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 STRSM .
*
END
SUBROUTINE STRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
* .. Scalar Arguments ..
INTEGER INCX,LDA,N
CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
REAL A(LDA,*),X(*)
* ..
*
* Purpose
* =======
*
* STRSV solves one of the systems of equations
*
* A*x = b, or A'*x = b,
*
* where b and x are n element vectors and A is an n by n unit, or
* non-unit, upper or lower triangular matrix.
*
* No test for singularity or near-singularity is included in this
* routine. Such tests must be performed before calling this routine.
*
* Arguments
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the matrix 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.
*
* Unchanged on exit.
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the equations to be solved as
* follows:
*
* TRANS = 'N' or 'n' A*x = b.
*
* TRANS = 'T' or 't' A'*x = b.
*
* TRANS = 'C' or 'c' A'*x = b.
*
* Unchanged on exit.
*
* DIAG - 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.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U' or 'u', the leading n by n
* 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 n by n
* 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.
* Unchanged on exit.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. LDA must be at least
* max( 1, n ).
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element right-hand side vector b. On exit, X is overwritten
* with the solution vector x.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- 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 ..
REAL ZERO
PARAMETER (ZERO=0.0E+0)
* ..
* .. Local Scalars ..
REAL 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('STRSV ',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 := inv( A )*x.
*
IF (LSAME(UPLO,'U')) THEN
IF (INCX.EQ.1) THEN
DO 20 J = N,1,-1
IF (X(J).NE.ZERO) THEN
IF (NOUNIT) X(J) = X(J)/A(J,J)
TEMP = X(J)
DO 10 I = J - 1,1,-1
X(I) = X(I) - TEMP*A(I,J)
10 CONTINUE
END IF
20 CONTINUE
ELSE
JX = KX + (N-1)*INCX
DO 40 J = N,1,-1
IF (X(JX).NE.ZERO) THEN
IF (NOUNIT) X(JX) = X(JX)/A(J,J)
TEMP = X(JX)
IX = JX
DO 30 I = J - 1,1,-1
IX = IX - INCX
X(IX) = X(IX) - TEMP*A(I,J)
30 CONTINUE
END IF
JX = JX - INCX
40 CONTINUE
END IF
ELSE
IF (INCX.EQ.1) THEN
DO 60 J = 1,N
IF (X(J).NE.ZERO) THEN
IF (NOUNIT) X(J) = X(J)/A(J,J)
TEMP = X(J)
DO 50 I = J + 1,N
X(I) = X(I) - TEMP*A(I,J)
50 CONTINUE
END IF
60 CONTINUE
ELSE
JX = KX
DO 80 J = 1,N
IF (X(JX).NE.ZERO) THEN
IF (NOUNIT) X(JX) = X(JX)/A(J,J)
TEMP = X(JX)
IX = JX
DO 70 I = J + 1,N
IX = IX + INCX
X(IX) = X(IX) - TEMP*A(I,J)
70 CONTINUE
END IF
JX = JX + INCX
80 CONTINUE
END IF
END IF
ELSE
*
* Form x := inv( A' )*x.
*
IF (LSAME(UPLO,'U')) THEN
IF (INCX.EQ.1) THEN
DO 100 J = 1,N
TEMP = X(J)
DO 90 I = 1,J - 1
TEMP = TEMP - A(I,J)*X(I)
90 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(J,J)
X(J) = TEMP
100 CONTINUE
ELSE
JX = KX
DO 120 J = 1,N
TEMP = X(JX)
IX = KX
DO 110 I = 1,J - 1
TEMP = TEMP - A(I,J)*X(IX)
IX = IX + INCX
110 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(J,J)
X(JX) = TEMP
JX = JX + INCX
120 CONTINUE
END IF
ELSE
IF (INCX.EQ.1) THEN
DO 140 J = N,1,-1
TEMP = X(J)
DO 130 I = N,J + 1,-1
TEMP = TEMP - A(I,J)*X(I)
130 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(J,J)
X(J) = TEMP
140 CONTINUE
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 160 J = N,1,-1
TEMP = X(JX)
IX = KX
DO 150 I = N,J + 1,-1
TEMP = TEMP - A(I,J)*X(IX)
IX = IX - INCX
150 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(J,J)
X(JX) = TEMP
JX = JX - INCX
160 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of STRSV .
*
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/blas/Makefile_javasrc 0000644 0001750 0001750 00000002051 10616163231 023626 0 ustar osallou osallou .SUFFIXES: .f .java
ROOT=../..
include $(ROOT)/make.def
$(BLAS_JAR): $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR) $(ROOT)/$(ERR_DIR)/$(ERR_JAR) blas.f
$(MAKE) nojar
/bin/rm -f `find . -name "*.class"`
mkdir -p $(JAVASRC_OUTDIR)
$(JAVAC) -classpath $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR) -d $(JAVASRC_OUTDIR) $(OUTDIR)/$(BLAS_PDIR)/*.java
/bin/rm -f $(JAVASRC_OUTDIR)/$(BLAS_PDIR)/*.old
$(JAVAB) $(JAVASRC_OUTDIR)/$(BLAS_PDIR)/*.class
mkdir -p $(SIMPLE_DIR)/$(BLAS_PDIR)
-mv `find $(JAVASRC_OUTDIR) -name "[A-Z][A-Z]*.class"` $(SIMPLE_DIR)/$(BLAS_PDIR)
cd $(JAVASRC_OUTDIR); $(JAR) cvf ../$(BLAS_JAR) `find . -name "*.class"`
cd $(SIMPLE_DIR); $(JAR) cvf ../$(SIMPLE_BLAS_JAR) `find . -name "*.class"`
$(ROOT)/$(ERR_DIR)/$(ERR_JAR):
cd $(ROOT)/$(ERR_DIR);$(MAKE) -f Makefile_javasrc
$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):
cd $(ROOT)/$(UTIL_DIR); $(MAKE)
verify: $(BLAS_JAR)
cd $(JAVASRC_OUTDIR); $(VERIFY) $(BLAS_PDIR)/*.class
clean:
/bin/rm -rf *.java *.class *.f2j $(SBLAS_JAR) $(SIMPLE_SBLAS_JAR) $(OUTDIR) $(JAVASRC_OUTDIR) $(SIMPLE_DIR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/blas/Makefile 0000644 0001750 0001750 00000002103 10616163231 022113 0 ustar osallou osallou .SUFFIXES: .f .java
ROOT=../..
include $(ROOT)/make.def
F2JFLAGS=-c .:$(OUTDIR):$(ROOT)/$(ERR_OBJ) -p $(BLAS_PACKAGE) -o $(OUTDIR) -s -d $(STATIC)
$(BLAS_JAR): $(ROOT)/$(ERR_DIR)/$(ERR_JAR) $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR) blas.f
$(F2J) $(F2JFLAGS) blas.f > /dev/null
cd $(OUTDIR); $(JAR) cvf ../$(BLAS_JAR) `find . -name "*.class"`
mkdir -p $(SIMPLE_DIR)/$(BLAS_PDIR)
-cp `find $(OUTDIR)/$(BLAS_PDIR) -name "[A-Z][A-Z]*.java"` $(SIMPLE_DIR)/$(BLAS_PDIR)
-$(JAVAC) -classpath .:$(BLAS_JAR):$(SIMPLE_DIR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR) $(SIMPLE_DIR)/$(BLAS_PDIR)/*.java
cd $(SIMPLE_DIR); $(JAR) cvf ../$(SIMPLE_BLAS_JAR) `find . -name "*.class"`
nojar: $(ROOT)/$(ERR_DIR)/$(ERR_JAR) blas.f
$(F2J) $(F2JFLAGS) blas.f > /dev/null
$(ROOT)/$(ERR_DIR)/$(ERR_JAR):
cd $(ROOT)/$(ERR_DIR);$(MAKE)
javasrc:
$(MAKE) -f Makefile_javasrc
$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):
cd $(ROOT)/$(UTIL_DIR); $(MAKE)
verify: $(BLAS_JAR)
./verify_all.csh
clean:
/bin/rm -rf *.java *.class *.f2j $(BLAS_JAR) $(SIMPLE_BLAS_JAR) $(OUTDIR) $(JAVASRC_OUTDIR) $(SIMPLE_DIR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/blas/verify_all.csh 0000755 0001750 0001750 00000000271 10616163231 023315 0 ustar osallou osallou #!/bin/csh
setenv CPTMP $CLASSPATH":../../error_reporting/xerbla.jar"
cd obj
foreach file(org/netlib/blas/*.class)
java -classpath $CPTMP de.fub.bytecode.verifier.Verifier $file
end
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/ 0000755 0001750 0001750 00000000000 11734055026 021217 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/matgen/ 0000755 0001750 0001750 00000000000 11734055025 022471 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/matgen/Makefile_javasrc 0000644 0001750 0001750 00000002303 10616163237 025643 0 ustar osallou osallou .SUFFIXES: .f .java
ROOT=../../..
include $(ROOT)/make.def
BLAS=$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR)
LAPACK=$(ROOT)/$(LAPACK_DIR)/$(LAPACK_JAR)
tester: $(BLAS) $(LAPACK) $(OUTDIR)/Matgen.f2j
/bin/rm -f `find $(OUTDIR) -name "*.class"`
mkdir -p $(JAVASRC_OUTDIR)
$(JAVAC) -classpath $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/$(LAPACK_DIR)/$(LAPACK_JAR) -d $(JAVASRC_OUTDIR) $(OUTDIR)/$(MATGEN_PDIR)/*.java
/bin/rm -f $(JAVASRC_OUTDIR)/$(MATGEN_PDIR)/*.old
$(JAVAB) $(JAVASRC_OUTDIR)/$(MATGEN_PDIR)/*.class
/bin/rm -f $(MATGEN_JAR)
cd $(JAVASRC_OUTDIR); $(JAR) cvf ../$(MATGEN_JAR) `find . -name "*.class"`
$(OUTDIR)/Matgen.f2j: matgen.f
$(MAKE) nojar
$(BLAS):
cd $(ROOT)/$(BLAS_DIR); $(MAKE) -f Makefile_javasrc
$(LAPACK):
cd $(ROOT)/$(LAPACK_DIR); $(MAKE) -f Makefile_javasrc
verify: $(ROOT)/$(MATGEN_IDX)
cd $(JAVASRC_OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/../$(LAPACK_DIR)/$(LAPACK_JAR) $(VERIFY) $(MATGEN_PDIR)/*.class
clean:
/bin/rm -rf *.java *.class *.f2j $(JAVASRC_OUTDIR) $(OUTDIR) $(MATGEN_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/matgen/Makefile 0000644 0001750 0001750 00000001764 10616163237 024144 0 ustar osallou osallou .SUFFIXES: .f .java
ROOT=../../..
include $(ROOT)/make.def
BLAS=$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR)
LAPACK=$(ROOT)/$(LAPACK_DIR)/$(LAPACK_JAR)
F2JFLAGS=-c .:$(ROOT)/$(BLAS_OBJ):$(ROOT)/$(ERR_OBJ):$(ROOT)/$(LAPACK_OBJ) -p $(MATGEN_PACKAGE) -o $(OUTDIR) $(STATIC)
tester: $(BLAS) $(LAPACK) $(ROOT)/$(MATGEN_IDX)
/bin/rm -f $(MATGEN_JAR)
cd $(OUTDIR); $(JAR) cvf ../$(MATGEN_JAR) `find . -name "*.class"`
nojar: $(BLAS) $(LAPACK) $(ROOT)/$(MATGEN_IDX)
javasrc:
$(MAKE) -f Makefile_javasrc
$(ROOT)/$(MATGEN_IDX): matgen.f
$(F2J) $(F2JFLAGS) $< > /dev/null
$(BLAS):
cd $(ROOT)/$(BLAS_DIR); $(MAKE)
$(LAPACK):
cd $(ROOT)/$(LAPACK_DIR); $(MAKE)
verify: $(ROOT)/$(MATGEN_IDX)
cd $(OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/../$(LAPACK_DIR)/$(LAPACK_JAR) $(VERIFY) $(MATGEN_PDIR)/*.class
clean:
/bin/rm -rf *.java *.class *.f2j $(JAVASRC_OUTDIR) $(OUTDIR) $(MATGEN_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/matgen/matgen.f 0000644 0001750 0001750 00000547401 10616163237 024131 0 ustar osallou osallou SUBROUTINE DLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO )
*
* -- LAPACK auxiliary test routine (version 3.1)
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, KL, KU, LDA, M, N
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
DOUBLE PRECISION A( LDA, * ), D( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLAGGE generates a real general m by n matrix A, by pre- and post-
* multiplying a real diagonal matrix D with random orthogonal matrices:
* A = U*D*V. The lower and upper bandwidths may then be reduced to
* kl and ku by additional orthogonal transformations.
*
* 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.
*
* KL (input) INTEGER
* The number of nonzero subdiagonals within the band of A.
* 0 <= KL <= M-1.
*
* KU (input) INTEGER
* The number of nonzero superdiagonals within the band of A.
* 0 <= KU <= N-1.
*
* D (input) DOUBLE PRECISION array, dimension (min(M,N))
* The diagonal elements of the diagonal matrix D.
*
* A (output) DOUBLE PRECISION array, dimension (LDA,N)
* The generated m by n matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= M.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry, the seed of the random number generator; the array
* elements must be between 0 and 4095, and ISEED(4) must be
* odd.
* On exit, the seed is updated.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (M+N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION TAU, WA, WB, WN
* ..
* .. External Subroutines ..
EXTERNAL DGEMV, DGER, DLARNV, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SIGN
* ..
* .. External Functions ..
DOUBLE PRECISION DNRM2
EXTERNAL DNRM2
* ..
* .. 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( KL.LT.0 .OR. KL.GT.M-1 ) THEN
INFO = -3
ELSE IF( KU.LT.0 .OR. KU.GT.N-1 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -7
END IF
IF( INFO.LT.0 ) THEN
CALL XERBLA( 'DLAGGE', -INFO )
RETURN
END IF
*
* initialize A to diagonal matrix
*
DO 20 J = 1, N
DO 10 I = 1, M
A( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
DO 30 I = 1, MIN( M, N )
A( I, I ) = D( I )
30 CONTINUE
*
* pre- and post-multiply A by random orthogonal matrices
*
DO 40 I = MIN( M, N ), 1, -1
IF( I.LT.M ) THEN
*
* generate random reflection
*
CALL DLARNV( 3, ISEED, M-I+1, WORK )
WN = DNRM2( M-I+1, WORK, 1 )
WA = SIGN( WN, WORK( 1 ) )
IF( WN.EQ.ZERO ) THEN
TAU = ZERO
ELSE
WB = WORK( 1 ) + WA
CALL DSCAL( M-I, ONE / WB, WORK( 2 ), 1 )
WORK( 1 ) = ONE
TAU = WB / WA
END IF
*
* multiply A(i:m,i:n) by random reflection from the left
*
CALL DGEMV( 'Transpose', M-I+1, N-I+1, ONE, A( I, I ), LDA,
$ WORK, 1, ZERO, WORK( M+1 ), 1 )
CALL DGER( M-I+1, N-I+1, -TAU, WORK, 1, WORK( M+1 ), 1,
$ A( I, I ), LDA )
END IF
IF( I.LT.N ) THEN
*
* generate random reflection
*
CALL DLARNV( 3, ISEED, N-I+1, WORK )
WN = DNRM2( N-I+1, WORK, 1 )
WA = SIGN( WN, WORK( 1 ) )
IF( WN.EQ.ZERO ) THEN
TAU = ZERO
ELSE
WB = WORK( 1 ) + WA
CALL DSCAL( N-I, ONE / WB, WORK( 2 ), 1 )
WORK( 1 ) = ONE
TAU = WB / WA
END IF
*
* multiply A(i:m,i:n) by random reflection from the right
*
CALL DGEMV( 'No transpose', M-I+1, N-I+1, ONE, A( I, I ),
$ LDA, WORK, 1, ZERO, WORK( N+1 ), 1 )
CALL DGER( M-I+1, N-I+1, -TAU, WORK( N+1 ), 1, WORK, 1,
$ A( I, I ), LDA )
END IF
40 CONTINUE
*
* Reduce number of subdiagonals to KL and number of superdiagonals
* to KU
*
DO 70 I = 1, MAX( M-1-KL, N-1-KU )
IF( KL.LE.KU ) THEN
*
* annihilate subdiagonal elements first (necessary if KL = 0)
*
IF( I.LE.MIN( M-1-KL, N ) ) THEN
*
* generate reflection to annihilate A(kl+i+1:m,i)
*
WN = DNRM2( M-KL-I+1, A( KL+I, I ), 1 )
WA = SIGN( WN, A( KL+I, I ) )
IF( WN.EQ.ZERO ) THEN
TAU = ZERO
ELSE
WB = A( KL+I, I ) + WA
CALL DSCAL( M-KL-I, ONE / WB, A( KL+I+1, I ), 1 )
A( KL+I, I ) = ONE
TAU = WB / WA
END IF
*
* apply reflection to A(kl+i:m,i+1:n) from the left
*
CALL DGEMV( 'Transpose', M-KL-I+1, N-I, ONE,
$ A( KL+I, I+1 ), LDA, A( KL+I, I ), 1, ZERO,
$ WORK, 1 )
CALL DGER( M-KL-I+1, N-I, -TAU, A( KL+I, I ), 1, WORK, 1,
$ A( KL+I, I+1 ), LDA )
A( KL+I, I ) = -WA
END IF
*
IF( I.LE.MIN( N-1-KU, M ) ) THEN
*
* generate reflection to annihilate A(i,ku+i+1:n)
*
WN = DNRM2( N-KU-I+1, A( I, KU+I ), LDA )
WA = SIGN( WN, A( I, KU+I ) )
IF( WN.EQ.ZERO ) THEN
TAU = ZERO
ELSE
WB = A( I, KU+I ) + WA
CALL DSCAL( N-KU-I, ONE / WB, A( I, KU+I+1 ), LDA )
A( I, KU+I ) = ONE
TAU = WB / WA
END IF
*
* apply reflection to A(i+1:m,ku+i:n) from the right
*
CALL DGEMV( 'No transpose', M-I, N-KU-I+1, ONE,
$ A( I+1, KU+I ), LDA, A( I, KU+I ), LDA, ZERO,
$ WORK, 1 )
CALL DGER( M-I, N-KU-I+1, -TAU, WORK, 1, A( I, KU+I ),
$ LDA, A( I+1, KU+I ), LDA )
A( I, KU+I ) = -WA
END IF
ELSE
*
* annihilate superdiagonal elements first (necessary if
* KU = 0)
*
IF( I.LE.MIN( N-1-KU, M ) ) THEN
*
* generate reflection to annihilate A(i,ku+i+1:n)
*
WN = DNRM2( N-KU-I+1, A( I, KU+I ), LDA )
WA = SIGN( WN, A( I, KU+I ) )
IF( WN.EQ.ZERO ) THEN
TAU = ZERO
ELSE
WB = A( I, KU+I ) + WA
CALL DSCAL( N-KU-I, ONE / WB, A( I, KU+I+1 ), LDA )
A( I, KU+I ) = ONE
TAU = WB / WA
END IF
*
* apply reflection to A(i+1:m,ku+i:n) from the right
*
CALL DGEMV( 'No transpose', M-I, N-KU-I+1, ONE,
$ A( I+1, KU+I ), LDA, A( I, KU+I ), LDA, ZERO,
$ WORK, 1 )
CALL DGER( M-I, N-KU-I+1, -TAU, WORK, 1, A( I, KU+I ),
$ LDA, A( I+1, KU+I ), LDA )
A( I, KU+I ) = -WA
END IF
*
IF( I.LE.MIN( M-1-KL, N ) ) THEN
*
* generate reflection to annihilate A(kl+i+1:m,i)
*
WN = DNRM2( M-KL-I+1, A( KL+I, I ), 1 )
WA = SIGN( WN, A( KL+I, I ) )
IF( WN.EQ.ZERO ) THEN
TAU = ZERO
ELSE
WB = A( KL+I, I ) + WA
CALL DSCAL( M-KL-I, ONE / WB, A( KL+I+1, I ), 1 )
A( KL+I, I ) = ONE
TAU = WB / WA
END IF
*
* apply reflection to A(kl+i:m,i+1:n) from the left
*
CALL DGEMV( 'Transpose', M-KL-I+1, N-I, ONE,
$ A( KL+I, I+1 ), LDA, A( KL+I, I ), 1, ZERO,
$ WORK, 1 )
CALL DGER( M-KL-I+1, N-I, -TAU, A( KL+I, I ), 1, WORK, 1,
$ A( KL+I, I+1 ), LDA )
A( KL+I, I ) = -WA
END IF
END IF
*
DO 50 J = KL + I + 1, M
A( J, I ) = ZERO
50 CONTINUE
*
DO 60 J = KU + I + 1, N
A( I, J ) = ZERO
60 CONTINUE
70 CONTINUE
RETURN
*
* End of DLAGGE
*
END
SUBROUTINE DLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO )
*
* -- LAPACK auxiliary test routine (version 3.1)
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, N
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
DOUBLE PRECISION A( LDA, * ), D( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLAGSY generates a real symmetric matrix A, by pre- and post-
* multiplying a real diagonal matrix D with a random orthogonal matrix:
* A = U*D*U'. The semi-bandwidth may then be reduced to k by additional
* orthogonal transformations.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* K (input) INTEGER
* The number of nonzero subdiagonals within the band of A.
* 0 <= K <= N-1.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The diagonal elements of the diagonal matrix D.
*
* A (output) DOUBLE PRECISION array, dimension (LDA,N)
* The generated n by n symmetric matrix A (the full matrix is
* stored).
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= N.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry, the seed of the random number generator; the array
* elements must be between 0 and 4095, and ISEED(4) must be
* odd.
* On exit, the seed is updated.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, HALF
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION ALPHA, TAU, WA, WB, WN
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DGEMV, DGER, DLARNV, DSCAL, DSYMV,
$ DSYR2, XERBLA
* ..
* .. External Functions ..
DOUBLE PRECISION DDOT, DNRM2
EXTERNAL DDOT, DNRM2
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SIGN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( K.LT.0 .OR. K.GT.N-1 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
END IF
IF( INFO.LT.0 ) THEN
CALL XERBLA( 'DLAGSY', -INFO )
RETURN
END IF
*
* initialize lower triangle of A to diagonal matrix
*
DO 20 J = 1, N
DO 10 I = J + 1, N
A( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
DO 30 I = 1, N
A( I, I ) = D( I )
30 CONTINUE
*
* Generate lower triangle of symmetric matrix
*
DO 40 I = N - 1, 1, -1
*
* generate random reflection
*
CALL DLARNV( 3, ISEED, N-I+1, WORK )
WN = DNRM2( N-I+1, WORK, 1 )
WA = SIGN( WN, WORK( 1 ) )
IF( WN.EQ.ZERO ) THEN
TAU = ZERO
ELSE
WB = WORK( 1 ) + WA
CALL DSCAL( N-I, ONE / WB, WORK( 2 ), 1 )
WORK( 1 ) = ONE
TAU = WB / WA
END IF
*
* apply random reflection to A(i:n,i:n) from the left
* and the right
*
* compute y := tau * A * u
*
CALL DSYMV( 'Lower', N-I+1, TAU, A( I, I ), LDA, WORK, 1, ZERO,
$ WORK( N+1 ), 1 )
*
* compute v := y - 1/2 * tau * ( y, u ) * u
*
ALPHA = -HALF*TAU*DDOT( N-I+1, WORK( N+1 ), 1, WORK, 1 )
CALL DAXPY( N-I+1, ALPHA, WORK, 1, WORK( N+1 ), 1 )
*
* apply the transformation as a rank-2 update to A(i:n,i:n)
*
CALL DSYR2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1,
$ A( I, I ), LDA )
40 CONTINUE
*
* Reduce number of subdiagonals to K
*
DO 60 I = 1, N - 1 - K
*
* generate reflection to annihilate A(k+i+1:n,i)
*
WN = DNRM2( N-K-I+1, A( K+I, I ), 1 )
WA = SIGN( WN, A( K+I, I ) )
IF( WN.EQ.ZERO ) THEN
TAU = ZERO
ELSE
WB = A( K+I, I ) + WA
CALL DSCAL( N-K-I, ONE / WB, A( K+I+1, I ), 1 )
A( K+I, I ) = ONE
TAU = WB / WA
END IF
*
* apply reflection to A(k+i:n,i+1:k+i-1) from the left
*
CALL DGEMV( 'Transpose', N-K-I+1, K-1, ONE, A( K+I, I+1 ), LDA,
$ A( K+I, I ), 1, ZERO, WORK, 1 )
CALL DGER( N-K-I+1, K-1, -TAU, A( K+I, I ), 1, WORK, 1,
$ A( K+I, I+1 ), LDA )
*
* apply reflection to A(k+i:n,k+i:n) from the left and the right
*
* compute y := tau * A * u
*
CALL DSYMV( 'Lower', N-K-I+1, TAU, A( K+I, K+I ), LDA,
$ A( K+I, I ), 1, ZERO, WORK, 1 )
*
* compute v := y - 1/2 * tau * ( y, u ) * u
*
ALPHA = -HALF*TAU*DDOT( N-K-I+1, WORK, 1, A( K+I, I ), 1 )
CALL DAXPY( N-K-I+1, ALPHA, A( K+I, I ), 1, WORK, 1 )
*
* apply symmetric rank-2 update to A(k+i:n,k+i:n)
*
CALL DSYR2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1,
$ A( K+I, K+I ), LDA )
*
A( K+I, I ) = -WA
DO 50 J = K + I + 1, N
A( J, I ) = ZERO
50 CONTINUE
60 CONTINUE
*
* Store full symmetric matrix
*
DO 80 J = 1, N
DO 70 I = J + 1, N
A( J, I ) = A( I, J )
70 CONTINUE
80 CONTINUE
RETURN
*
* End of DLAGSY
*
END
SUBROUTINE DLAKF2( M, N, A, LDA, B, D, E, Z, LDZ )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDZ, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDA, * ), D( LDA, * ),
$ E( LDA, * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* Form the 2*M*N by 2*M*N matrix
*
* Z = [ kron(In, A) -kron(B', Im) ]
* [ kron(In, D) -kron(E', Im) ],
*
* where In is the identity matrix of size n and X' is the transpose
* of X. kron(X, Y) is the Kronecker product between the matrices X
* and Y.
*
* Arguments
* =========
*
* M (input) INTEGER
* Size of matrix, must be >= 1.
*
* N (input) INTEGER
* Size of matrix, must be >= 1.
*
* A (input) DOUBLE PRECISION, dimension ( LDA, M )
* The matrix A in the output matrix Z.
*
* LDA (input) INTEGER
* The leading dimension of A, B, D, and E. ( LDA >= M+N )
*
* B (input) DOUBLE PRECISION, dimension ( LDA, N )
* D (input) DOUBLE PRECISION, dimension ( LDA, M )
* E (input) DOUBLE PRECISION, dimension ( LDA, N )
* The matrices used in forming the output matrix Z.
*
* Z (output) DOUBLE PRECISION, dimension ( LDZ, 2*M*N )
* The resultant Kronecker M*N*2 by M*N*2 matrix (see above.)
*
* LDZ (input) INTEGER
* The leading dimension of Z. ( LDZ >= 2*M*N )
*
* ====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, IK, J, JK, L, MN, MN2
* ..
* .. External Subroutines ..
EXTERNAL DLASET
* ..
* .. Executable Statements ..
*
* Initialize Z
*
MN = M*N
MN2 = 2*MN
CALL DLASET( 'Full', MN2, MN2, ZERO, ZERO, Z, LDZ )
*
IK = 1
DO 50 L = 1, N
*
* form kron(In, A)
*
DO 20 I = 1, M
DO 10 J = 1, M
Z( IK+I-1, IK+J-1 ) = A( I, J )
10 CONTINUE
20 CONTINUE
*
* form kron(In, D)
*
DO 40 I = 1, M
DO 30 J = 1, M
Z( IK+MN+I-1, IK+J-1 ) = D( I, J )
30 CONTINUE
40 CONTINUE
*
IK = IK + M
50 CONTINUE
*
IK = 1
DO 90 L = 1, N
JK = MN + 1
*
DO 80 J = 1, N
*
* form -kron(B', Im)
*
DO 60 I = 1, M
Z( IK+I-1, JK+I-1 ) = -B( J, L )
60 CONTINUE
*
* form -kron(E', Im)
*
DO 70 I = 1, M
Z( IK+MN+I-1, JK+I-1 ) = -E( J, L )
70 CONTINUE
*
JK = JK + M
80 CONTINUE
*
IK = IK + M
90 CONTINUE
*
RETURN
*
* End of DLAKF2
*
END
DOUBLE PRECISION FUNCTION DLARAN( ISEED )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Array Arguments ..
INTEGER ISEED( 4 )
* ..
*
* Purpose
* =======
*
* DLARAN returns a random real number from a uniform (0,1)
* distribution.
*
* Arguments
* =========
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry, the seed of the random number generator; the array
* elements must be between 0 and 4095, and ISEED(4) must be
* odd.
* On exit, the seed is updated.
*
* Further Details
* ===============
*
* This routine uses a multiplicative congruential method with modulus
* 2**48 and multiplier 33952834046453 (see G.S.Fishman,
* 'Multiplicative congruential random number generators with modulus
* 2**b: an exhaustive analysis for b = 32 and a partial analysis for
* b = 48', Math. Comp. 189, pp 331-344, 1990).
*
* 48-bit integers are stored in 4 integer array elements with 12 bits
* per element. Hence the routine is portable across machines with
* integers of 32 bits or more.
*
* =====================================================================
*
* .. Parameters ..
INTEGER M1, M2, M3, M4
PARAMETER ( M1 = 494, M2 = 322, M3 = 2508, M4 = 2549 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
INTEGER IPW2
DOUBLE PRECISION R
PARAMETER ( IPW2 = 4096, R = ONE / IPW2 )
* ..
* .. Local Scalars ..
INTEGER IT1, IT2, IT3, IT4
DOUBLE PRECISION RNDOUT
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MOD
* ..
* .. Executable Statements ..
10 CONTINUE
*
* multiply the seed by the multiplier modulo 2**48
*
IT4 = ISEED( 4 )*M4
IT3 = IT4 / IPW2
IT4 = IT4 - IPW2*IT3
IT3 = IT3 + ISEED( 3 )*M4 + ISEED( 4 )*M3
IT2 = IT3 / IPW2
IT3 = IT3 - IPW2*IT2
IT2 = IT2 + ISEED( 2 )*M4 + ISEED( 3 )*M3 + ISEED( 4 )*M2
IT1 = IT2 / IPW2
IT2 = IT2 - IPW2*IT1
IT1 = IT1 + ISEED( 1 )*M4 + ISEED( 2 )*M3 + ISEED( 3 )*M2 +
$ ISEED( 4 )*M1
IT1 = MOD( IT1, IPW2 )
*
* return updated seed
*
ISEED( 1 ) = IT1
ISEED( 2 ) = IT2
ISEED( 3 ) = IT3
ISEED( 4 ) = IT4
*
* convert 48-bit integer to a real number in the interval (0,1)
*
RNDOUT = R*( DBLE( IT1 )+R*( DBLE( IT2 )+R*( DBLE( IT3 )+R*
$ ( DBLE( IT4 ) ) ) ) )
*
IF (RNDOUT.EQ.1.0D+0) THEN
* If a real number has n bits of precision, and the first
* n bits of the 48-bit integer above happen to be all 1 (which
* will occur about once every 2**n calls), then DLARAN will
* be rounded to exactly 1.0.
* Since DLARAN is not supposed to return exactly 0.0 or 1.0
* (and some callers of DLARAN, such as CLARND, depend on that),
* the statistically correct thing to do in this situation is
* simply to iterate again.
* N.B. the case DLARAN = 0.0 should not be possible.
*
GOTO 10
END IF
*
DLARAN = RNDOUT
RETURN
*
* End of DLARAN
*
END
SUBROUTINE DLARGE( N, A, LDA, ISEED, WORK, INFO )
*
* -- LAPACK auxiliary test routine (version 3.1)
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLARGE pre- and post-multiplies a real general n by n matrix A
* with a random orthogonal matrix: A = U*D*U'.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the original n by n matrix A.
* On exit, A is overwritten by U*A*U' for some random
* orthogonal matrix U.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= N.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry, the seed of the random number generator; the array
* elements must be between 0 and 4095, and ISEED(4) must be
* odd.
* On exit, the seed is updated.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I
DOUBLE PRECISION TAU, WA, WB, WN
* ..
* .. External Subroutines ..
EXTERNAL DGEMV, DGER, DLARNV, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SIGN
* ..
* .. External Functions ..
DOUBLE PRECISION DNRM2
EXTERNAL DNRM2
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -3
END IF
IF( INFO.LT.0 ) THEN
CALL XERBLA( 'DLARGE', -INFO )
RETURN
END IF
*
* pre- and post-multiply A by random orthogonal matrix
*
DO 10 I = N, 1, -1
*
* generate random reflection
*
CALL DLARNV( 3, ISEED, N-I+1, WORK )
WN = DNRM2( N-I+1, WORK, 1 )
WA = SIGN( WN, WORK( 1 ) )
IF( WN.EQ.ZERO ) THEN
TAU = ZERO
ELSE
WB = WORK( 1 ) + WA
CALL DSCAL( N-I, ONE / WB, WORK( 2 ), 1 )
WORK( 1 ) = ONE
TAU = WB / WA
END IF
*
* multiply A(i:n,1:n) by random reflection from the left
*
CALL DGEMV( 'Transpose', N-I+1, N, ONE, A( I, 1 ), LDA, WORK,
$ 1, ZERO, WORK( N+1 ), 1 )
CALL DGER( N-I+1, N, -TAU, WORK, 1, WORK( N+1 ), 1, A( I, 1 ),
$ LDA )
*
* multiply A(1:n,i:n) by random reflection from the right
*
CALL DGEMV( 'No transpose', N, N-I+1, ONE, A( 1, I ), LDA,
$ WORK, 1, ZERO, WORK( N+1 ), 1 )
CALL DGER( N, N-I+1, -TAU, WORK( N+1 ), 1, WORK, 1, A( 1, I ),
$ LDA )
10 CONTINUE
RETURN
*
* End of DLARGE
*
END
DOUBLE PRECISION FUNCTION DLARND( IDIST, ISEED )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IDIST
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
* ..
*
* Purpose
* =======
*
* DLARND returns a random real number from a uniform or normal
* distribution.
*
* Arguments
* =========
*
* IDIST (input) INTEGER
* Specifies the distribution of the random numbers:
* = 1: uniform (0,1)
* = 2: uniform (-1,1)
* = 3: normal (0,1)
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry, the seed of the random number generator; the array
* elements must be between 0 and 4095, and ISEED(4) must be
* odd.
* On exit, the seed is updated.
*
* Further Details
* ===============
*
* This routine calls the auxiliary routine DLARAN to generate a random
* real number from a uniform (0,1) distribution. The Box-Muller method
* is used to transform numbers from a uniform to a normal distribution.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, TWO
PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 )
DOUBLE PRECISION TWOPI
PARAMETER ( TWOPI = 6.2831853071795864769252867663D+0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION T1, T2
* ..
* .. External Functions ..
DOUBLE PRECISION DLARAN
EXTERNAL DLARAN
* ..
* .. Intrinsic Functions ..
INTRINSIC COS, LOG, SQRT
* ..
* .. Executable Statements ..
*
* Generate a real random number from a uniform (0,1) distribution
*
T1 = DLARAN( ISEED )
*
IF( IDIST.EQ.1 ) THEN
*
* uniform (0,1)
*
DLARND = T1
ELSE IF( IDIST.EQ.2 ) THEN
*
* uniform (-1,1)
*
DLARND = TWO*T1 - ONE
ELSE IF( IDIST.EQ.3 ) THEN
*
* normal (0,1)
*
T2 = DLARAN( ISEED )
DLARND = SQRT( -TWO*LOG( T1 ) )*COS( TWOPI*T2 )
END IF
RETURN
*
* End of DLARND
*
END
SUBROUTINE DLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO )
*
* -- LAPACK auxiliary test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER INIT, SIDE
INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
DOUBLE PRECISION A( LDA, * ), X( * )
* ..
*
* Purpose
* =======
*
* DLAROR pre- or post-multiplies an M by N matrix A by a random
* orthogonal matrix U, overwriting A. A may optionally be initialized
* to the identity matrix before multiplying by U. U is generated using
* the method of G.W. Stewart (SIAM J. Numer. Anal. 17, 1980, 403-409).
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* Specifies whether A is multiplied on the left or right by U.
* = 'L': Multiply A on the left (premultiply) by U
* = 'R': Multiply A on the right (postmultiply) by U'
* = 'C' or 'T': Multiply A on the left by U and the right
* by U' (Here, U' means U-transpose.)
*
* INIT (input) CHARACTER*1
* Specifies whether or not A should be initialized to the
* identity matrix.
* = 'I': Initialize A to (a section of) the identity matrix
* before applying U.
* = 'N': No initialization. Apply U to the input matrix A.
*
* INIT = 'I' may be used to generate square or rectangular
* orthogonal matrices:
*
* For M = N and SIDE = 'L' or 'R', the rows will be orthogonal
* to each other, as will the columns.
*
* If M < N, SIDE = 'R' produces a dense matrix whose rows are
* orthogonal and whose columns are not, while SIDE = 'L'
* produces a matrix whose rows are orthogonal, and whose first
* M columns are orthogonal, and whose remaining columns are
* zero.
*
* If M > N, SIDE = 'L' produces a dense matrix whose columns
* are orthogonal and whose rows are not, while SIDE = 'R'
* produces a matrix whose columns are orthogonal, and whose
* first M rows are orthogonal, and whose remaining rows are
* zero.
*
* M (input) INTEGER
* The number of rows of A.
*
* N (input) INTEGER
* The number of columns of A.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
* On entry, the array A.
* On exit, overwritten by U A ( if SIDE = 'L' ),
* or by A U ( if SIDE = 'R' ),
* or by U A U' ( if SIDE = 'C' or 'T').
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The array elements should be between 0 and 4095;
* if not they will be reduced mod 4096. Also, ISEED(4) must
* be odd. The random number generator uses a linear
* congruential sequence limited to small integers, and so
* should produce machine independent random numbers. The
* values of ISEED are changed on exit, and can be used in the
* next call to DLAROR to continue the same random number
* sequence.
*
* X (workspace) DOUBLE PRECISION array, dimension (3*MAX( M, N ))
* Workspace of length
* 2*M + N if SIDE = 'L',
* 2*N + M if SIDE = 'R',
* 3*N if SIDE = 'C' or 'T'.
*
* INFO (output) INTEGER
* An error flag. It is set to:
* = 0: normal return
* < 0: if INFO = -k, the k-th argument had an illegal value
* = 1: if the random numbers generated by DLARND are bad.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TOOSML
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0,
$ TOOSML = 1.0D-20 )
* ..
* .. Local Scalars ..
INTEGER IROW, ITYPE, IXFRM, J, JCOL, KBEG, NXFRM
DOUBLE PRECISION FACTOR, XNORM, XNORMS
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLARND, DNRM2
EXTERNAL LSAME, DLARND, DNRM2
* ..
* .. External Subroutines ..
EXTERNAL DGEMV, DGER, DLASET, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SIGN
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 .OR. M.EQ.0 )
$ RETURN
*
ITYPE = 0
IF( LSAME( SIDE, 'L' ) ) THEN
ITYPE = 1
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
ITYPE = 2
ELSE IF( LSAME( SIDE, 'C' ) .OR. LSAME( SIDE, 'T' ) ) THEN
ITYPE = 3
END IF
*
* Check for argument errors.
*
INFO = 0
IF( ITYPE.EQ.0 ) THEN
INFO = -1
ELSE IF( M.LT.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.3 .AND. N.NE.M ) ) THEN
INFO = -4
ELSE IF( LDA.LT.M ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAROR', -INFO )
RETURN
END IF
*
IF( ITYPE.EQ.1 ) THEN
NXFRM = M
ELSE
NXFRM = N
END IF
*
* Initialize A to the identity matrix if desired
*
IF( LSAME( INIT, 'I' ) )
$ CALL DLASET( 'Full', M, N, ZERO, ONE, A, LDA )
*
* If no rotation possible, multiply by random +/-1
*
* Compute rotation by computing Householder transformations
* H(2), H(3), ..., H(nhouse)
*
DO 10 J = 1, NXFRM
X( J ) = ZERO
10 CONTINUE
*
DO 30 IXFRM = 2, NXFRM
KBEG = NXFRM - IXFRM + 1
*
* Generate independent normal( 0, 1 ) random numbers
*
DO 20 J = KBEG, NXFRM
X( J ) = DLARND( 3, ISEED )
20 CONTINUE
*
* Generate a Householder transformation from the random vector X
*
XNORM = DNRM2( IXFRM, X( KBEG ), 1 )
XNORMS = SIGN( XNORM, X( KBEG ) )
X( KBEG+NXFRM ) = SIGN( ONE, -X( KBEG ) )
FACTOR = XNORMS*( XNORMS+X( KBEG ) )
IF( ABS( FACTOR ).LT.TOOSML ) THEN
INFO = 1
CALL XERBLA( 'DLAROR', INFO )
RETURN
ELSE
FACTOR = ONE / FACTOR
END IF
X( KBEG ) = X( KBEG ) + XNORMS
*
* Apply Householder transformation to A
*
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.3 ) THEN
*
* Apply H(k) from the left.
*
CALL DGEMV( 'T', IXFRM, N, ONE, A( KBEG, 1 ), LDA,
$ X( KBEG ), 1, ZERO, X( 2*NXFRM+1 ), 1 )
CALL DGER( IXFRM, N, -FACTOR, X( KBEG ), 1, X( 2*NXFRM+1 ),
$ 1, A( KBEG, 1 ), LDA )
*
END IF
*
IF( ITYPE.EQ.2 .OR. ITYPE.EQ.3 ) THEN
*
* Apply H(k) from the right.
*
CALL DGEMV( 'N', M, IXFRM, ONE, A( 1, KBEG ), LDA,
$ X( KBEG ), 1, ZERO, X( 2*NXFRM+1 ), 1 )
CALL DGER( M, IXFRM, -FACTOR, X( 2*NXFRM+1 ), 1, X( KBEG ),
$ 1, A( 1, KBEG ), LDA )
*
END IF
30 CONTINUE
*
X( 2*NXFRM ) = SIGN( ONE, DLARND( 3, ISEED ) )
*
* Scale the matrix A by D.
*
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.3 ) THEN
DO 40 IROW = 1, M
CALL DSCAL( N, X( NXFRM+IROW ), A( IROW, 1 ), LDA )
40 CONTINUE
END IF
*
IF( ITYPE.EQ.2 .OR. ITYPE.EQ.3 ) THEN
DO 50 JCOL = 1, N
CALL DSCAL( M, X( NXFRM+JCOL ), A( 1, JCOL ), 1 )
50 CONTINUE
END IF
RETURN
*
* End of DLAROR
*
END
SUBROUTINE DLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT,
$ XRIGHT )
*
* -- LAPACK auxiliary test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL LLEFT, LRIGHT, LROWS
INTEGER LDA, NL
DOUBLE PRECISION C, S, XLEFT, XRIGHT
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( * )
* ..
*
* Purpose
* =======
*
* DLAROT applies a (Givens) rotation to two adjacent rows or
* columns, where one element of the first and/or last column/row
* November 2006
* for use on matrices stored in some format other than GE, so
* that elements of the matrix may be used or modified for which
* no array element is provided.
*
* One example is a symmetric matrix in SB format (bandwidth=4), for
* which UPLO='L': Two adjacent rows will have the format:
*
* row j: * * * * * . . . .
* row j+1: * * * * * . . . .
*
* '*' indicates elements for which storage is provided,
* '.' indicates elements for which no storage is provided, but
* are not necessarily zero; their values are determined by
* symmetry. ' ' indicates elements which are necessarily zero,
* and have no storage provided.
*
* Those columns which have two '*'s can be handled by DROT.
* Those columns which have no '*'s can be ignored, since as long
* as the Givens rotations are carefully applied to preserve
* symmetry, their values are determined.
* Those columns which have one '*' have to be handled separately,
* by using separate variables "p" and "q":
*
* row j: * * * * * p . . .
* row j+1: q * * * * * . . . .
*
* The element p would have to be set correctly, then that column
* is rotated, setting p to its new value. The next call to
* DLAROT would rotate columns j and j+1, using p, and restore
* symmetry. The element q would start out being zero, and be
* made non-zero by the rotation. Later, rotations would presumably
* be chosen to zero q out.
*
* Typical Calling Sequences: rotating the i-th and (i+1)-st rows.
* ------- ------- ---------
*
* General dense matrix:
*
* CALL DLAROT(.TRUE.,.FALSE.,.FALSE., N, C,S,
* A(i,1),LDA, DUMMY, DUMMY)
*
* General banded matrix in GB format:
*
* j = MAX(1, i-KL )
* NL = MIN( N, i+KU+1 ) + 1-j
* CALL DLAROT( .TRUE., i-KL.GE.1, i+KU.LT.N, NL, C,S,
* A(KU+i+1-j,j),LDA-1, XLEFT, XRIGHT )
*
* [ note that i+1-j is just MIN(i,KL+1) ]
*
* Symmetric banded matrix in SY format, bandwidth K,
* lower triangle only:
*
* j = MAX(1, i-K )
* NL = MIN( K+1, i ) + 1
* CALL DLAROT( .TRUE., i-K.GE.1, .TRUE., NL, C,S,
* A(i,j), LDA, XLEFT, XRIGHT )
*
* Same, but upper triangle only:
*
* NL = MIN( K+1, N-i ) + 1
* CALL DLAROT( .TRUE., .TRUE., i+K.LT.N, NL, C,S,
* A(i,i), LDA, XLEFT, XRIGHT )
*
* Symmetric banded matrix in SB format, bandwidth K,
* lower triangle only:
*
* [ same as for SY, except:]
* . . . .
* A(i+1-j,j), LDA-1, XLEFT, XRIGHT )
*
* [ note that i+1-j is just MIN(i,K+1) ]
*
* Same, but upper triangle only:
* . . .
* A(K+1,i), LDA-1, XLEFT, XRIGHT )
*
* Rotating columns is just the transpose of rotating rows, except
* for GB and SB: (rotating columns i and i+1)
*
* GB:
* j = MAX(1, i-KU )
* NL = MIN( N, i+KL+1 ) + 1-j
* CALL DLAROT( .TRUE., i-KU.GE.1, i+KL.LT.N, NL, C,S,
* A(KU+j+1-i,i),LDA-1, XTOP, XBOTTM )
*
* [note that KU+j+1-i is just MAX(1,KU+2-i)]
*
* SB: (upper triangle)
*
* . . . . . .
* A(K+j+1-i,i),LDA-1, XTOP, XBOTTM )
*
* SB: (lower triangle)
*
* . . . . . .
* A(1,i),LDA-1, XTOP, XBOTTM )
*
* Arguments
* =========
*
* LROWS - LOGICAL
* If .TRUE., then DLAROT will rotate two rows. If .FALSE.,
* then it will rotate two columns.
* Not modified.
*
* LLEFT - LOGICAL
* If .TRUE., then XLEFT will be used instead of the
* corresponding element of A for the first element in the
* second row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.)
* If .FALSE., then the corresponding element of A will be
* used.
* Not modified.
*
* LRIGHT - LOGICAL
* If .TRUE., then XRIGHT will be used instead of the
* corresponding element of A for the last element in the
* first row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) If
* .FALSE., then the corresponding element of A will be used.
* Not modified.
*
* NL - INTEGER
* The length of the rows (if LROWS=.TRUE.) or columns (if
* LROWS=.FALSE.) to be rotated. If XLEFT and/or XRIGHT are
* used, the columns/rows they are in should be included in
* NL, e.g., if LLEFT = LRIGHT = .TRUE., then NL must be at
* least 2. The number of rows/columns to be rotated
* exclusive of those involving XLEFT and/or XRIGHT may
* not be negative, i.e., NL minus how many of LLEFT and
* LRIGHT are .TRUE. must be at least zero; if not, XERBLA
* will be called.
* Not modified.
*
* C, S - DOUBLE PRECISION
* Specify the Givens rotation to be applied. If LROWS is
* true, then the matrix ( c s )
* (-s c ) is applied from the left;
* if false, then the transpose thereof is applied from the
* right. For a Givens rotation, C**2 + S**2 should be 1,
* but this is not checked.
* Not modified.
*
* A - DOUBLE PRECISION array.
* The array containing the rows/columns to be rotated. The
* first element of A should be the upper left element to
* be rotated.
* Read and modified.
*
* LDA - INTEGER
* The "effective" leading dimension of A. If A contains
* a matrix stored in GE or SY format, then this is just
* the leading dimension of A as dimensioned in the calling
* routine. If A contains a matrix stored in band (GB or SB)
* format, then this should be *one less* than the leading
* dimension used in the calling routine. Thus, if
* A were dimensioned A(LDA,*) in DLAROT, then A(1,j) would
* be the j-th element in the first of the two rows
* to be rotated, and A(2,j) would be the j-th in the second,
* regardless of how the array may be stored in the calling
* routine. [A cannot, however, actually be dimensioned thus,
* since for band format, the row number may exceed LDA, which
* is not legal FORTRAN.]
* If LROWS=.TRUE., then LDA must be at least 1, otherwise
* it must be at least NL minus the number of .TRUE. values
* in XLEFT and XRIGHT.
* Not modified.
*
* XLEFT - DOUBLE PRECISION
* If LLEFT is .TRUE., then XLEFT will be used and modified
* instead of A(2,1) (if LROWS=.TRUE.) or A(1,2)
* (if LROWS=.FALSE.).
* Read and modified.
*
* XRIGHT - DOUBLE PRECISION
* If LRIGHT is .TRUE., then XRIGHT will be used and modified
* instead of A(1,NL) (if LROWS=.TRUE.) or A(NL,1)
* (if LROWS=.FALSE.).
* Read and modified.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER IINC, INEXT, IX, IY, IYT, NT
* ..
* .. Local Arrays ..
DOUBLE PRECISION XT( 2 ), YT( 2 )
* ..
* .. External Subroutines ..
EXTERNAL DROT, XERBLA
* ..
* .. Executable Statements ..
*
* Set up indices, arrays for ends
*
IF( LROWS ) THEN
IINC = LDA
INEXT = 1
ELSE
IINC = 1
INEXT = LDA
END IF
*
IF( LLEFT ) THEN
NT = 1
IX = 1 + IINC
IY = 2 + LDA
XT( 1 ) = A( 1 )
YT( 1 ) = XLEFT
ELSE
NT = 0
IX = 1
IY = 1 + INEXT
END IF
*
IF( LRIGHT ) THEN
IYT = 1 + INEXT + ( NL-1 )*IINC
NT = NT + 1
XT( NT ) = XRIGHT
YT( NT ) = A( IYT )
END IF
*
* Check for errors
*
IF( NL.LT.NT ) THEN
CALL XERBLA( 'DLAROT', 4 )
RETURN
END IF
IF( LDA.LE.0 .OR. ( .NOT.LROWS .AND. LDA.LT.NL-NT ) ) THEN
CALL XERBLA( 'DLAROT', 8 )
RETURN
END IF
*
* Rotate
*
CALL DROT( NL-NT, A( IX ), IINC, A( IY ), IINC, C, S )
CALL DROT( NT, XT, 1, YT, 1, C, S )
*
* Stuff values back into XLEFT, XRIGHT, etc.
*
IF( LLEFT ) THEN
A( 1 ) = XT( 1 )
XLEFT = YT( 1 )
END IF
*
IF( LRIGHT ) THEN
XRIGHT = XT( NT )
A( IYT ) = YT( NT )
END IF
*
RETURN
*
* End of DLAROT
*
END
SUBROUTINE DLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO )
*
* -- LAPACK auxiliary test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IDIST, INFO, IRSIGN, MODE, N
DOUBLE PRECISION COND
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
DOUBLE PRECISION D( * )
* ..
*
* Purpose
* =======
*
* DLATM1 computes the entries of D(1..N) as specified by
* MODE, COND and IRSIGN. IDIST and ISEED determine the generation
* of random numbers. DLATM1 is called by SLATMR to generate
* random test matrices for LAPACK programs.
*
* Arguments
* =========
*
* MODE - INTEGER
* On entry describes how D is to be computed:
* MODE = 0 means do not change D.
* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND
* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND
* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1))
* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
* MODE = 5 sets D to random numbers in the range
* ( 1/COND , 1 ) such that their logarithms
* are uniformly distributed.
* MODE = 6 set D to random numbers from same distribution
* as the rest of the matrix.
* MODE < 0 has the same meaning as ABS(MODE), except that
* the order of the elements of D is reversed.
* Thus if MODE is positive, D has entries ranging from
* 1 to 1/COND, if negative, from 1/COND to 1,
* Not modified.
*
* COND - DOUBLE PRECISION
* On entry, used as described under MODE above.
* If used, it must be >= 1. Not modified.
*
* IRSIGN - INTEGER
* On entry, if MODE neither -6, 0 nor 6, determines sign of
* entries of D
* 0 => leave entries of D unchanged
* 1 => multiply each entry of D by 1 or -1 with probability .5
*
* IDIST - CHARACTER*1
* On entry, IDIST specifies the type of distribution to be
* used to generate a random matrix .
* 1 => UNIFORM( 0, 1 )
* 2 => UNIFORM( -1, 1 )
* 3 => NORMAL( 0, 1 )
* Not modified.
*
* ISEED - INTEGER array, dimension ( 4 )
* On entry ISEED specifies the seed of the random number
* generator. The random number generator uses a
* linear congruential sequence limited to small
* integers, and so should produce machine independent
* random numbers. The values of ISEED are changed on
* exit, and can be used in the next call to DLATM1
* to continue the same random number sequence.
* Changed on exit.
*
* D - DOUBLE PRECISION array, dimension ( MIN( M , N ) )
* Array to be computed according to MODE, COND and IRSIGN.
* May be changed on exit if MODE is nonzero.
*
* N - INTEGER
* Number of entries of D. Not modified.
*
* INFO - INTEGER
* 0 => normal termination
* -1 => if MODE not in range -6 to 6
* -2 => if MODE neither -6, 0 nor 6, and
* IRSIGN neither 0 nor 1
* -3 => if MODE neither -6, 0 nor 6 and COND less than 1
* -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 3
* -7 => if N negative
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION HALF
PARAMETER ( HALF = 0.5D0 )
* ..
* .. Local Scalars ..
INTEGER I
DOUBLE PRECISION ALPHA, TEMP
* ..
* .. External Functions ..
DOUBLE PRECISION DLARAN
EXTERNAL DLARAN
* ..
* .. External Subroutines ..
EXTERNAL DLARNV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, EXP, LOG
* ..
* .. Executable Statements ..
*
* Decode and Test the input parameters. Initialize flags & seed.
*
INFO = 0
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Set INFO if an error
*
IF( MODE.LT.-6 .OR. MODE.GT.6 ) THEN
INFO = -1
ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
$ ( IRSIGN.NE.0 .AND. IRSIGN.NE.1 ) ) THEN
INFO = -2
ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
$ COND.LT.ONE ) THEN
INFO = -3
ELSE IF( ( MODE.EQ.6 .OR. MODE.EQ.-6 ) .AND.
$ ( IDIST.LT.1 .OR. IDIST.GT.3 ) ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -7
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLATM1', -INFO )
RETURN
END IF
*
* Compute D according to COND and MODE
*
IF( MODE.NE.0 ) THEN
GO TO ( 10, 30, 50, 70, 90, 110 )ABS( MODE )
*
* One large D value:
*
10 CONTINUE
DO 20 I = 1, N
D( I ) = ONE / COND
20 CONTINUE
D( 1 ) = ONE
GO TO 120
*
* One small D value:
*
30 CONTINUE
DO 40 I = 1, N
D( I ) = ONE
40 CONTINUE
D( N ) = ONE / COND
GO TO 120
*
* Exponentially distributed D values:
*
50 CONTINUE
D( 1 ) = ONE
IF( N.GT.1 ) THEN
ALPHA = COND**( -ONE / DBLE( N-1 ) )
DO 60 I = 2, N
D( I ) = ALPHA**( I-1 )
60 CONTINUE
END IF
GO TO 120
*
* Arithmetically distributed D values:
*
70 CONTINUE
D( 1 ) = ONE
IF( N.GT.1 ) THEN
TEMP = ONE / COND
ALPHA = ( ONE-TEMP ) / DBLE( N-1 )
DO 80 I = 2, N
D( I ) = DBLE( N-I )*ALPHA + TEMP
80 CONTINUE
END IF
GO TO 120
*
* Randomly distributed D values on ( 1/COND , 1):
*
90 CONTINUE
ALPHA = LOG( ONE / COND )
DO 100 I = 1, N
D( I ) = EXP( ALPHA*DLARAN( ISEED ) )
100 CONTINUE
GO TO 120
*
* Randomly distributed D values from IDIST
*
110 CONTINUE
CALL DLARNV( IDIST, ISEED, N, D )
*
120 CONTINUE
*
* If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign
* random signs to D
*
IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
$ IRSIGN.EQ.1 ) THEN
DO 130 I = 1, N
TEMP = DLARAN( ISEED )
IF( TEMP.GT.HALF )
$ D( I ) = -D( I )
130 CONTINUE
END IF
*
* Reverse if MODE < 0
*
IF( MODE.LT.0 ) THEN
DO 140 I = 1, N / 2
TEMP = D( I )
D( I ) = D( N+1-I )
D( N+1-I ) = TEMP
140 CONTINUE
END IF
*
END IF
*
RETURN
*
* End of DLATM1
*
END
DOUBLE PRECISION FUNCTION DLATM2( M, N, I, J, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE )
*
* -- LAPACK auxiliary test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
*
INTEGER I, IDIST, IGRADE, IPVTNG, J, KL, KU, M, N
DOUBLE PRECISION SPARSE
* ..
*
* .. Array Arguments ..
*
INTEGER ISEED( 4 ), IWORK( * )
DOUBLE PRECISION D( * ), DL( * ), DR( * )
* ..
*
* Purpose
* =======
*
* DLATM2 returns the (I,J) entry of a random matrix of dimension
* (M, N) described by the other paramters. It is called by the
* DLATMR routine in order to build random test matrices. No error
* checking on parameters is done, because this routine is called in
* a tight loop by DLATMR which has already checked the parameters.
*
* Use of DLATM2 differs from SLATM3 in the order in which the random
* number generator is called to fill in random matrix entries.
* With DLATM2, the generator is called to fill in the pivoted matrix
* columnwise. With DLATM3, the generator is called to fill in the
* matrix columnwise, after which it is pivoted. Thus, DLATM3 can
* be used to construct random matrices which differ only in their
* order of rows and/or columns. DLATM2 is used to construct band
* matrices while avoiding calling the random number generator for
* entries outside the band (and therefore generating random numbers
*
* The matrix whose (I,J) entry is returned is constructed as
* follows (this routine only computes one entry):
*
* If I is outside (1..M) or J is outside (1..N), return zero
* (this is convenient for generating matrices in band format).
*
* Generate a matrix A with random entries of distribution IDIST.
*
* Set the diagonal to D.
*
* Grade the matrix, if desired, from the left (by DL) and/or
* from the right (by DR or DL) as specified by IGRADE.
*
* Permute, if desired, the rows and/or columns as specified by
* IPVTNG and IWORK.
*
* Band the matrix to have lower bandwidth KL and upper
* bandwidth KU.
*
* Set random entries to zero as specified by SPARSE.
*
* Arguments
* =========
*
* M - INTEGER
* Number of rows of matrix. Not modified.
*
* N - INTEGER
* Number of columns of matrix. Not modified.
*
* I - INTEGER
* Row of entry to be returned. Not modified.
*
* J - INTEGER
* Column of entry to be returned. Not modified.
*
* KL - INTEGER
* Lower bandwidth. Not modified.
*
* KU - INTEGER
* Upper bandwidth. Not modified.
*
* IDIST - INTEGER
* On entry, IDIST specifies the type of distribution to be
* used to generate a random matrix .
* 1 => UNIFORM( 0, 1 )
* 2 => UNIFORM( -1, 1 )
* 3 => NORMAL( 0, 1 )
* Not modified.
*
* ISEED - INTEGER array of dimension ( 4 )
* Seed for random number generator.
* Changed on exit.
*
* D - DOUBLE PRECISION array of dimension ( MIN( I , J ) )
* Diagonal entries of matrix. Not modified.
*
* IGRADE - INTEGER
* Specifies grading of matrix as follows:
* 0 => no grading
* 1 => matrix premultiplied by diag( DL )
* 2 => matrix postmultiplied by diag( DR )
* 3 => matrix premultiplied by diag( DL ) and
* postmultiplied by diag( DR )
* 4 => matrix premultiplied by diag( DL ) and
* postmultiplied by inv( diag( DL ) )
* 5 => matrix premultiplied by diag( DL ) and
* postmultiplied by diag( DL )
* Not modified.
*
* DL - DOUBLE PRECISION array ( I or J, as appropriate )
* Left scale factors for grading matrix. Not modified.
*
* DR - DOUBLE PRECISION array ( I or J, as appropriate )
* Right scale factors for grading matrix. Not modified.
*
* IPVTNG - INTEGER
* On entry specifies pivoting permutations as follows:
* 0 => none.
* 1 => row pivoting.
* 2 => column pivoting.
* 3 => full pivoting, i.e., on both sides.
* Not modified.
*
* IWORK - INTEGER array ( I or J, as appropriate )
* This array specifies the permutation used. The
* row (or column) in position K was originally in
* position IWORK( K ).
* This differs from IWORK for DLATM3. Not modified.
*
* SPARSE - DOUBLE PRECISION between 0. and 1.
* On entry specifies the sparsity of the matrix
* if sparse matix is to be generated.
* SPARSE should lie between 0 and 1.
* A uniform ( 0, 1 ) random number x is generated and
* compared to SPARSE; if x is larger the matrix entry
* is unchanged and if x is smaller the entry is set
* to zero. Thus on the average a fraction SPARSE of the
* entries will be set to zero.
* Not modified.
*
* =====================================================================
*
* .. Parameters ..
*
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
*
* .. Local Scalars ..
*
INTEGER ISUB, JSUB
DOUBLE PRECISION TEMP
* ..
*
* .. External Functions ..
*
DOUBLE PRECISION DLARAN, DLARND
EXTERNAL DLARAN, DLARND
* ..
*
*-----------------------------------------------------------------------
*
* .. Executable Statements ..
*
*
* Check for I and J in range
*
IF( I.LT.1 .OR. I.GT.M .OR. J.LT.1 .OR. J.GT.N ) THEN
DLATM2 = ZERO
RETURN
END IF
*
* Check for banding
*
IF( J.GT.I+KU .OR. J.LT.I-KL ) THEN
DLATM2 = ZERO
RETURN
END IF
*
* Check for sparsity
*
IF( SPARSE.GT.ZERO ) THEN
IF( DLARAN( ISEED ).LT.SPARSE ) THEN
DLATM2 = ZERO
RETURN
END IF
END IF
*
* Compute subscripts depending on IPVTNG
*
IF( IPVTNG.EQ.0 ) THEN
ISUB = I
JSUB = J
ELSE IF( IPVTNG.EQ.1 ) THEN
ISUB = IWORK( I )
JSUB = J
ELSE IF( IPVTNG.EQ.2 ) THEN
ISUB = I
JSUB = IWORK( J )
ELSE IF( IPVTNG.EQ.3 ) THEN
ISUB = IWORK( I )
JSUB = IWORK( J )
END IF
*
* Compute entry and grade it according to IGRADE
*
IF( ISUB.EQ.JSUB ) THEN
TEMP = D( ISUB )
ELSE
TEMP = DLARND( IDIST, ISEED )
END IF
IF( IGRADE.EQ.1 ) THEN
TEMP = TEMP*DL( ISUB )
ELSE IF( IGRADE.EQ.2 ) THEN
TEMP = TEMP*DR( JSUB )
ELSE IF( IGRADE.EQ.3 ) THEN
TEMP = TEMP*DL( ISUB )*DR( JSUB )
ELSE IF( IGRADE.EQ.4 .AND. ISUB.NE.JSUB ) THEN
TEMP = TEMP*DL( ISUB ) / DL( JSUB )
ELSE IF( IGRADE.EQ.5 ) THEN
TEMP = TEMP*DL( ISUB )*DL( JSUB )
END IF
DLATM2 = TEMP
RETURN
*
* End of DLATM2
*
END
DOUBLE PRECISION FUNCTION DLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
$ SPARSE )
*
* -- LAPACK auxiliary test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
*
INTEGER I, IDIST, IGRADE, IPVTNG, ISUB, J, JSUB, KL,
$ KU, M, N
DOUBLE PRECISION SPARSE
* ..
*
* .. Array Arguments ..
*
INTEGER ISEED( 4 ), IWORK( * )
DOUBLE PRECISION D( * ), DL( * ), DR( * )
* ..
*
* Purpose
* =======
*
* DLATM3 returns the (ISUB,JSUB) entry of a random matrix of
* dimension (M, N) described by the other paramters. (ISUB,JSUB)
* is the final position of the (I,J) entry after pivoting
* according to IPVTNG and IWORK. DLATM3 is called by the
* DLATMR routine in order to build random test matrices. No error
* checking on parameters is done, because this routine is called in
* a tight loop by DLATMR which has already checked the parameters.
*
* Use of DLATM3 differs from SLATM2 in the order in which the random
* number generator is called to fill in random matrix entries.
* With DLATM2, the generator is called to fill in the pivoted matrix
* columnwise. With DLATM3, the generator is called to fill in the
* matrix columnwise, after which it is pivoted. Thus, DLATM3 can
* be used to construct random matrices which differ only in their
* order of rows and/or columns. DLATM2 is used to construct band
* matrices while avoiding calling the random number generator for
* entries outside the band (and therefore generating random numbers
* in different orders for different pivot orders).
*
* The matrix whose (ISUB,JSUB) entry is returned is constructed as
* follows (this routine only computes one entry):
*
* If ISUB is outside (1..M) or JSUB is outside (1..N), return zero
* (this is convenient for generating matrices in band format).
*
* Generate a matrix A with random entries of distribution IDIST.
*
* Set the diagonal to D.
*
* Grade the matrix, if desired, from the left (by DL) and/or
* from the right (by DR or DL) as specified by IGRADE.
*
* Permute, if desired, the rows and/or columns as specified by
* IPVTNG and IWORK.
*
* Band the matrix to have lower bandwidth KL and upper
* bandwidth KU.
*
* Set random entries to zero as specified by SPARSE.
*
* Arguments
* =========
*
* M - INTEGER
* Number of rows of matrix. Not modified.
*
* N - INTEGER
* Number of columns of matrix. Not modified.
*
* I - INTEGER
* Row of unpivoted entry to be returned. Not modified.
*
* J - INTEGER
* Column of unpivoted entry to be returned. Not modified.
*
* ISUB - INTEGER
* Row of pivoted entry to be returned. Changed on exit.
*
* JSUB - INTEGER
* Column of pivoted entry to be returned. Changed on exit.
*
* KL - INTEGER
* Lower bandwidth. Not modified.
*
* KU - INTEGER
* Upper bandwidth. Not modified.
*
* IDIST - INTEGER
* On entry, IDIST specifies the type of distribution to be
* used to generate a random matrix .
* 1 => UNIFORM( 0, 1 )
* 2 => UNIFORM( -1, 1 )
* 3 => NORMAL( 0, 1 )
* Not modified.
*
* ISEED - INTEGER array of dimension ( 4 )
* Seed for random number generator.
* Changed on exit.
*
* D - DOUBLE PRECISION array of dimension ( MIN( I , J ) )
* Diagonal entries of matrix. Not modified.
*
* IGRADE - INTEGER
* Specifies grading of matrix as follows:
* 0 => no grading
* 1 => matrix premultiplied by diag( DL )
* 2 => matrix postmultiplied by diag( DR )
* 3 => matrix premultiplied by diag( DL ) and
* postmultiplied by diag( DR )
* 4 => matrix premultiplied by diag( DL ) and
* postmultiplied by inv( diag( DL ) )
* 5 => matrix premultiplied by diag( DL ) and
* postmultiplied by diag( DL )
* Not modified.
*
* DL - DOUBLE PRECISION array ( I or J, as appropriate )
* Left scale factors for grading matrix. Not modified.
*
* DR - DOUBLE PRECISION array ( I or J, as appropriate )
* Right scale factors for grading matrix. Not modified.
*
* IPVTNG - INTEGER
* On entry specifies pivoting permutations as follows:
* 0 => none.
* 1 => row pivoting.
* 2 => column pivoting.
* 3 => full pivoting, i.e., on both sides.
* Not modified.
*
* IWORK - INTEGER array ( I or J, as appropriate )
* This array specifies the permutation used. The
* row (or column) originally in position K is in
* position IWORK( K ) after pivoting.
* This differs from IWORK for DLATM2. Not modified.
*
* SPARSE - DOUBLE PRECISION between 0. and 1.
* On entry specifies the sparsity of the matrix
* if sparse matix is to be generated.
* SPARSE should lie between 0 and 1.
* A uniform ( 0, 1 ) random number x is generated and
* compared to SPARSE; if x is larger the matrix entry
* is unchanged and if x is smaller the entry is set
* to zero. Thus on the average a fraction SPARSE of the
* entries will be set to zero.
* Not modified.
*
* =====================================================================
*
* .. Parameters ..
*
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
*
* .. Local Scalars ..
*
DOUBLE PRECISION TEMP
* ..
*
* .. External Functions ..
*
DOUBLE PRECISION DLARAN, DLARND
EXTERNAL DLARAN, DLARND
* ..
*
*-----------------------------------------------------------------------
*
* .. Executable Statements ..
*
*
* Check for I and J in range
*
IF( I.LT.1 .OR. I.GT.M .OR. J.LT.1 .OR. J.GT.N ) THEN
ISUB = I
JSUB = J
DLATM3 = ZERO
RETURN
END IF
*
* Compute subscripts depending on IPVTNG
*
IF( IPVTNG.EQ.0 ) THEN
ISUB = I
JSUB = J
ELSE IF( IPVTNG.EQ.1 ) THEN
ISUB = IWORK( I )
JSUB = J
ELSE IF( IPVTNG.EQ.2 ) THEN
ISUB = I
JSUB = IWORK( J )
ELSE IF( IPVTNG.EQ.3 ) THEN
ISUB = IWORK( I )
JSUB = IWORK( J )
END IF
*
* Check for banding
*
IF( JSUB.GT.ISUB+KU .OR. JSUB.LT.ISUB-KL ) THEN
DLATM3 = ZERO
RETURN
END IF
*
* Check for sparsity
*
IF( SPARSE.GT.ZERO ) THEN
IF( DLARAN( ISEED ).LT.SPARSE ) THEN
DLATM3 = ZERO
RETURN
END IF
END IF
*
* Compute entry and grade it according to IGRADE
*
IF( I.EQ.J ) THEN
TEMP = D( I )
ELSE
TEMP = DLARND( IDIST, ISEED )
END IF
IF( IGRADE.EQ.1 ) THEN
TEMP = TEMP*DL( I )
ELSE IF( IGRADE.EQ.2 ) THEN
TEMP = TEMP*DR( J )
ELSE IF( IGRADE.EQ.3 ) THEN
TEMP = TEMP*DL( I )*DR( J )
ELSE IF( IGRADE.EQ.4 .AND. I.NE.J ) THEN
TEMP = TEMP*DL( I ) / DL( J )
ELSE IF( IGRADE.EQ.5 ) THEN
TEMP = TEMP*DL( I )*DL( J )
END IF
DLATM3 = TEMP
RETURN
*
* End of DLATM3
*
END
SUBROUTINE DLATM5( PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD,
$ E, LDE, F, LDF, R, LDR, L, LDL, ALPHA, QBLCKA,
$ QBLCKB )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDB, LDC, LDD, LDE, LDF, LDL, LDR, M, N,
$ PRTYPE, QBLCKA, QBLCKB
DOUBLE PRECISION ALPHA
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ),
$ D( LDD, * ), E( LDE, * ), F( LDF, * ),
$ L( LDL, * ), R( LDR, * )
* ..
*
* Purpose
* =======
*
* DLATM5 generates matrices involved in the Generalized Sylvester
* equation:
*
* A * R - L * B = C
* D * R - L * E = F
*
* They also satisfy (the diagonalization condition)
*
* [ I -L ] ( [ A -C ], [ D -F ] ) [ I R ] = ( [ A ], [ D ] )
* [ I ] ( [ B ] [ E ] ) [ I ] ( [ B ] [ E ] )
*
*
* Arguments
* =========
*
* PRTYPE (input) INTEGER
* "Points" to a certian type of the matrices to generate
* (see futher details).
*
* M (input) INTEGER
* Specifies the order of A and D and the number of rows in
* C, F, R and L.
*
* N (input) INTEGER
* Specifies the order of B and E and the number of columns in
* C, F, R and L.
*
* A (output) DOUBLE PRECISION array, dimension (LDA, M).
* On exit A M-by-M is initialized according to PRTYPE.
*
* LDA (input) INTEGER
* The leading dimension of A.
*
* B (output) DOUBLE PRECISION array, dimension (LDB, N).
* On exit B N-by-N is initialized according to PRTYPE.
*
* LDB (input) INTEGER
* The leading dimension of B.
*
* C (output) DOUBLE PRECISION array, dimension (LDC, N).
* On exit C M-by-N is initialized according to PRTYPE.
*
* LDC (input) INTEGER
* The leading dimension of C.
*
* D (output) DOUBLE PRECISION array, dimension (LDD, M).
* On exit D M-by-M is initialized according to PRTYPE.
*
* LDD (input) INTEGER
* The leading dimension of D.
*
* E (output) DOUBLE PRECISION array, dimension (LDE, N).
* On exit E N-by-N is initialized according to PRTYPE.
*
* LDE (input) INTEGER
* The leading dimension of E.
*
* F (output) DOUBLE PRECISION array, dimension (LDF, N).
* On exit F M-by-N is initialized according to PRTYPE.
*
* LDF (input) INTEGER
* The leading dimension of F.
*
* R (output) DOUBLE PRECISION array, dimension (LDR, N).
* On exit R M-by-N is initialized according to PRTYPE.
*
* LDR (input) INTEGER
* The leading dimension of R.
*
* L (output) DOUBLE PRECISION array, dimension (LDL, N).
* On exit L M-by-N is initialized according to PRTYPE.
*
* LDL (input) INTEGER
* The leading dimension of L.
*
* ALPHA (input) DOUBLE PRECISION
* Parameter used in generating PRTYPE = 1 and 5 matrices.
*
* QBLCKA (input) INTEGER
* When PRTYPE = 3, specifies the distance between 2-by-2
* blocks on the diagonal in A. Otherwise, QBLCKA is not
* referenced. QBLCKA > 1.
*
* QBLCKB (input) INTEGER
* When PRTYPE = 3, specifies the distance between 2-by-2
* blocks on the diagonal in B. Otherwise, QBLCKB is not
* referenced. QBLCKB > 1.
*
*
* Further Details
* ===============
*
* PRTYPE = 1: A and B are Jordan blocks, D and E are identity matrices
*
* A : if (i == j) then A(i, j) = 1.0
* if (j == i + 1) then A(i, j) = -1.0
* else A(i, j) = 0.0, i, j = 1...M
*
* B : if (i == j) then B(i, j) = 1.0 - ALPHA
* if (j == i + 1) then B(i, j) = 1.0
* else B(i, j) = 0.0, i, j = 1...N
*
* D : if (i == j) then D(i, j) = 1.0
* else D(i, j) = 0.0, i, j = 1...M
*
* E : if (i == j) then E(i, j) = 1.0
* else E(i, j) = 0.0, i, j = 1...N
*
* L = R are chosen from [-10...10],
* which specifies the right hand sides (C, F).
*
* PRTYPE = 2 or 3: Triangular and/or quasi- triangular.
*
* A : if (i <= j) then A(i, j) = [-1...1]
* else A(i, j) = 0.0, i, j = 1...M
*
* if (PRTYPE = 3) then
* A(k + 1, k + 1) = A(k, k)
* A(k + 1, k) = [-1...1]
* sign(A(k, k + 1) = -(sin(A(k + 1, k))
* k = 1, M - 1, QBLCKA
*
* B : if (i <= j) then B(i, j) = [-1...1]
* else B(i, j) = 0.0, i, j = 1...N
*
* if (PRTYPE = 3) then
* B(k + 1, k + 1) = B(k, k)
* B(k + 1, k) = [-1...1]
* sign(B(k, k + 1) = -(sign(B(k + 1, k))
* k = 1, N - 1, QBLCKB
*
* D : if (i <= j) then D(i, j) = [-1...1].
* else D(i, j) = 0.0, i, j = 1...M
*
*
* E : if (i <= j) then D(i, j) = [-1...1]
* else E(i, j) = 0.0, i, j = 1...N
*
* L, R are chosen from [-10...10],
* which specifies the right hand sides (C, F).
*
* PRTYPE = 4 Full
* A(i, j) = [-10...10]
* D(i, j) = [-1...1] i,j = 1...M
* B(i, j) = [-10...10]
* E(i, j) = [-1...1] i,j = 1...N
* R(i, j) = [-10...10]
* L(i, j) = [-1...1] i = 1..M ,j = 1...N
*
* L, R specifies the right hand sides (C, F).
*
* PRTYPE = 5 special case common and/or close eigs.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO, TWENTY, HALF, TWO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0, TWENTY = 2.0D+1,
$ HALF = 0.5D+0, TWO = 2.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, K
DOUBLE PRECISION IMEPS, REEPS
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MOD, SIN
* ..
* .. External Subroutines ..
EXTERNAL DGEMM
* ..
* .. Executable Statements ..
*
IF( PRTYPE.EQ.1 ) THEN
DO 20 I = 1, M
DO 10 J = 1, M
IF( I.EQ.J ) THEN
A( I, J ) = ONE
D( I, J ) = ONE
ELSE IF( I.EQ.J-1 ) THEN
A( I, J ) = -ONE
D( I, J ) = ZERO
ELSE
A( I, J ) = ZERO
D( I, J ) = ZERO
END IF
10 CONTINUE
20 CONTINUE
*
DO 40 I = 1, N
DO 30 J = 1, N
IF( I.EQ.J ) THEN
B( I, J ) = ONE - ALPHA
E( I, J ) = ONE
ELSE IF( I.EQ.J-1 ) THEN
B( I, J ) = ONE
E( I, J ) = ZERO
ELSE
B( I, J ) = ZERO
E( I, J ) = ZERO
END IF
30 CONTINUE
40 CONTINUE
*
DO 60 I = 1, M
DO 50 J = 1, N
R( I, J ) = ( HALF-SIN( DBLE( I / J ) ) )*TWENTY
L( I, J ) = R( I, J )
50 CONTINUE
60 CONTINUE
*
ELSE IF( PRTYPE.EQ.2 .OR. PRTYPE.EQ.3 ) THEN
DO 80 I = 1, M
DO 70 J = 1, M
IF( I.LE.J ) THEN
A( I, J ) = ( HALF-SIN( DBLE( I ) ) )*TWO
D( I, J ) = ( HALF-SIN( DBLE( I*J ) ) )*TWO
ELSE
A( I, J ) = ZERO
D( I, J ) = ZERO
END IF
70 CONTINUE
80 CONTINUE
*
DO 100 I = 1, N
DO 90 J = 1, N
IF( I.LE.J ) THEN
B( I, J ) = ( HALF-SIN( DBLE( I+J ) ) )*TWO
E( I, J ) = ( HALF-SIN( DBLE( J ) ) )*TWO
ELSE
B( I, J ) = ZERO
E( I, J ) = ZERO
END IF
90 CONTINUE
100 CONTINUE
*
DO 120 I = 1, M
DO 110 J = 1, N
R( I, J ) = ( HALF-SIN( DBLE( I*J ) ) )*TWENTY
L( I, J ) = ( HALF-SIN( DBLE( I+J ) ) )*TWENTY
110 CONTINUE
120 CONTINUE
*
IF( PRTYPE.EQ.3 ) THEN
IF( QBLCKA.LE.1 )
$ QBLCKA = 2
DO 130 K = 1, M - 1, QBLCKA
A( K+1, K+1 ) = A( K, K )
A( K+1, K ) = -SIN( A( K, K+1 ) )
130 CONTINUE
*
IF( QBLCKB.LE.1 )
$ QBLCKB = 2
DO 140 K = 1, N - 1, QBLCKB
B( K+1, K+1 ) = B( K, K )
B( K+1, K ) = -SIN( B( K, K+1 ) )
140 CONTINUE
END IF
*
ELSE IF( PRTYPE.EQ.4 ) THEN
DO 160 I = 1, M
DO 150 J = 1, M
A( I, J ) = ( HALF-SIN( DBLE( I*J ) ) )*TWENTY
D( I, J ) = ( HALF-SIN( DBLE( I+J ) ) )*TWO
150 CONTINUE
160 CONTINUE
*
DO 180 I = 1, N
DO 170 J = 1, N
B( I, J ) = ( HALF-SIN( DBLE( I+J ) ) )*TWENTY
E( I, J ) = ( HALF-SIN( DBLE( I*J ) ) )*TWO
170 CONTINUE
180 CONTINUE
*
DO 200 I = 1, M
DO 190 J = 1, N
R( I, J ) = ( HALF-SIN( DBLE( J / I ) ) )*TWENTY
L( I, J ) = ( HALF-SIN( DBLE( I*J ) ) )*TWO
190 CONTINUE
200 CONTINUE
*
ELSE IF( PRTYPE.GE.5 ) THEN
REEPS = HALF*TWO*TWENTY / ALPHA
IMEPS = ( HALF-TWO ) / ALPHA
DO 220 I = 1, M
DO 210 J = 1, N
R( I, J ) = ( HALF-SIN( DBLE( I*J ) ) )*ALPHA / TWENTY
L( I, J ) = ( HALF-SIN( DBLE( I+J ) ) )*ALPHA / TWENTY
210 CONTINUE
220 CONTINUE
*
DO 230 I = 1, M
D( I, I ) = ONE
230 CONTINUE
*
DO 240 I = 1, M
IF( I.LE.4 ) THEN
A( I, I ) = ONE
IF( I.GT.2 )
$ A( I, I ) = ONE + REEPS
IF( MOD( I, 2 ).NE.0 .AND. I.LT.M ) THEN
A( I, I+1 ) = IMEPS
ELSE IF( I.GT.1 ) THEN
A( I, I-1 ) = -IMEPS
END IF
ELSE IF( I.LE.8 ) THEN
IF( I.LE.6 ) THEN
A( I, I ) = REEPS
ELSE
A( I, I ) = -REEPS
END IF
IF( MOD( I, 2 ).NE.0 .AND. I.LT.M ) THEN
A( I, I+1 ) = ONE
ELSE IF( I.GT.1 ) THEN
A( I, I-1 ) = -ONE
END IF
ELSE
A( I, I ) = ONE
IF( MOD( I, 2 ).NE.0 .AND. I.LT.M ) THEN
A( I, I+1 ) = IMEPS*2
ELSE IF( I.GT.1 ) THEN
A( I, I-1 ) = -IMEPS*2
END IF
END IF
240 CONTINUE
*
DO 250 I = 1, N
E( I, I ) = ONE
IF( I.LE.4 ) THEN
B( I, I ) = -ONE
IF( I.GT.2 )
$ B( I, I ) = ONE - REEPS
IF( MOD( I, 2 ).NE.0 .AND. I.LT.N ) THEN
B( I, I+1 ) = IMEPS
ELSE IF( I.GT.1 ) THEN
B( I, I-1 ) = -IMEPS
END IF
ELSE IF( I.LE.8 ) THEN
IF( I.LE.6 ) THEN
B( I, I ) = REEPS
ELSE
B( I, I ) = -REEPS
END IF
IF( MOD( I, 2 ).NE.0 .AND. I.LT.N ) THEN
B( I, I+1 ) = ONE + IMEPS
ELSE IF( I.GT.1 ) THEN
B( I, I-1 ) = -ONE - IMEPS
END IF
ELSE
B( I, I ) = ONE - REEPS
IF( MOD( I, 2 ).NE.0 .AND. I.LT.N ) THEN
B( I, I+1 ) = IMEPS*2
ELSE IF( I.GT.1 ) THEN
B( I, I-1 ) = -IMEPS*2
END IF
END IF
250 CONTINUE
END IF
*
* Compute rhs (C, F)
*
CALL DGEMM( 'N', 'N', M, N, M, ONE, A, LDA, R, LDR, ZERO, C, LDC )
CALL DGEMM( 'N', 'N', M, N, N, -ONE, L, LDL, B, LDB, ONE, C, LDC )
CALL DGEMM( 'N', 'N', M, N, M, ONE, D, LDD, R, LDR, ZERO, F, LDF )
CALL DGEMM( 'N', 'N', M, N, N, -ONE, L, LDL, E, LDE, ONE, F, LDF )
*
* End of DLATM5
*
END
SUBROUTINE DLATM6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA,
$ BETA, WX, WY, S, DIF )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDX, LDY, N, TYPE
DOUBLE PRECISION ALPHA, BETA, WX, WY
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDA, * ), DIF( * ), S( * ),
$ X( LDX, * ), Y( LDY, * )
* ..
*
* Purpose
* =======
*
* DLATM6 generates test matrices for the generalized eigenvalue
* problem, their corresponding right and left eigenvector matrices,
* and also reciprocal condition numbers for all eigenvalues and
* the reciprocal condition numbers of eigenvectors corresponding to
* the 1th and 5th eigenvalues.
*
* Test Matrices
* =============
*
* Two kinds of test matrix pairs
*
* (A, B) = inverse(YH) * (Da, Db) * inverse(X)
*
* are used in the tests:
*
* Type 1:
* Da = 1+a 0 0 0 0 Db = 1 0 0 0 0
* 0 2+a 0 0 0 0 1 0 0 0
* 0 0 3+a 0 0 0 0 1 0 0
* 0 0 0 4+a 0 0 0 0 1 0
* 0 0 0 0 5+a , 0 0 0 0 1 , and
*
* Type 2:
* Da = 1 -1 0 0 0 Db = 1 0 0 0 0
* 1 1 0 0 0 0 1 0 0 0
* 0 0 1 0 0 0 0 1 0 0
* 0 0 0 1+a 1+b 0 0 0 1 0
* 0 0 0 -1-b 1+a , 0 0 0 0 1 .
*
* In both cases the same inverse(YH) and inverse(X) are used to compute
* (A, B), giving the exact eigenvectors to (A,B) as (YH, X):
*
* YH: = 1 0 -y y -y X = 1 0 -x -x x
* 0 1 -y y -y 0 1 x -x -x
* 0 0 1 0 0 0 0 1 0 0
* 0 0 0 1 0 0 0 0 1 0
* 0 0 0 0 1, 0 0 0 0 1 ,
*
* where a, b, x and y will have all values independently of each other.
*
* Arguments
* =========
*
* TYPE (input) INTEGER
* Specifies the problem type (see futher details).
*
* N (input) INTEGER
* Size of the matrices A and B.
*
* A (output) DOUBLE PRECISION array, dimension (LDA, N).
* On exit A N-by-N is initialized according to TYPE.
*
* LDA (input) INTEGER
* The leading dimension of A and of B.
*
* B (output) DOUBLE PRECISION array, dimension (LDA, N).
* On exit B N-by-N is initialized according to TYPE.
*
* X (output) DOUBLE PRECISION array, dimension (LDX, N).
* On exit X is the N-by-N matrix of right eigenvectors.
*
* LDX (input) INTEGER
* The leading dimension of X.
*
* Y (output) DOUBLE PRECISION array, dimension (LDY, N).
* On exit Y is the N-by-N matrix of left eigenvectors.
*
* LDY (input) INTEGER
* The leading dimension of Y.
*
* ALPHA (input) DOUBLE PRECISION
* BETA (input) DOUBLE PRECISION
* Weighting constants for matrix A.
*
* WX (input) DOUBLE PRECISION
* Constant for right eigenvector matrix.
*
* WY (input) DOUBLE PRECISION
* Constant for left eigenvector matrix.
*
* S (output) DOUBLE PRECISION array, dimension (N)
* S(i) is the reciprocal condition number for eigenvalue i.
*
* DIF (output) DOUBLE PRECISION array, dimension (N)
* DIF(i) is the reciprocal condition number for eigenvector i.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, THREE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0,
$ THREE = 3.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
* ..
* .. Local Arrays ..
DOUBLE PRECISION WORK( 100 ), Z( 12, 12 )
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, SQRT
* ..
* .. External Subroutines ..
EXTERNAL DGESVD, DLACPY, DLAKF2
* ..
* .. Executable Statements ..
*
* Generate test problem ...
* (Da, Db) ...
*
DO 20 I = 1, N
DO 10 J = 1, N
*
IF( I.EQ.J ) THEN
A( I, I ) = DBLE( I ) + ALPHA
B( I, I ) = ONE
ELSE
A( I, J ) = ZERO
B( I, J ) = ZERO
END IF
*
10 CONTINUE
20 CONTINUE
*
* Form X and Y
*
CALL DLACPY( 'F', N, N, B, LDA, Y, LDY )
Y( 3, 1 ) = -WY
Y( 4, 1 ) = WY
Y( 5, 1 ) = -WY
Y( 3, 2 ) = -WY
Y( 4, 2 ) = WY
Y( 5, 2 ) = -WY
*
CALL DLACPY( 'F', N, N, B, LDA, X, LDX )
X( 1, 3 ) = -WX
X( 1, 4 ) = -WX
X( 1, 5 ) = WX
X( 2, 3 ) = WX
X( 2, 4 ) = -WX
X( 2, 5 ) = -WX
*
* Form (A, B)
*
B( 1, 3 ) = WX + WY
B( 2, 3 ) = -WX + WY
B( 1, 4 ) = WX - WY
B( 2, 4 ) = WX - WY
B( 1, 5 ) = -WX + WY
B( 2, 5 ) = WX + WY
IF( TYPE.EQ.1 ) THEN
A( 1, 3 ) = WX*A( 1, 1 ) + WY*A( 3, 3 )
A( 2, 3 ) = -WX*A( 2, 2 ) + WY*A( 3, 3 )
A( 1, 4 ) = WX*A( 1, 1 ) - WY*A( 4, 4 )
A( 2, 4 ) = WX*A( 2, 2 ) - WY*A( 4, 4 )
A( 1, 5 ) = -WX*A( 1, 1 ) + WY*A( 5, 5 )
A( 2, 5 ) = WX*A( 2, 2 ) + WY*A( 5, 5 )
ELSE IF( TYPE.EQ.2 ) THEN
A( 1, 3 ) = TWO*WX + WY
A( 2, 3 ) = WY
A( 1, 4 ) = -WY*( TWO+ALPHA+BETA )
A( 2, 4 ) = TWO*WX - WY*( TWO+ALPHA+BETA )
A( 1, 5 ) = -TWO*WX + WY*( ALPHA-BETA )
A( 2, 5 ) = WY*( ALPHA-BETA )
A( 1, 1 ) = ONE
A( 1, 2 ) = -ONE
A( 2, 1 ) = ONE
A( 2, 2 ) = A( 1, 1 )
A( 3, 3 ) = ONE
A( 4, 4 ) = ONE + ALPHA
A( 4, 5 ) = ONE + BETA
A( 5, 4 ) = -A( 4, 5 )
A( 5, 5 ) = A( 4, 4 )
END IF
*
* Compute condition numbers
*
IF( TYPE.EQ.1 ) THEN
*
S( 1 ) = ONE / SQRT( ( ONE+THREE*WY*WY ) /
$ ( ONE+A( 1, 1 )*A( 1, 1 ) ) )
S( 2 ) = ONE / SQRT( ( ONE+THREE*WY*WY ) /
$ ( ONE+A( 2, 2 )*A( 2, 2 ) ) )
S( 3 ) = ONE / SQRT( ( ONE+TWO*WX*WX ) /
$ ( ONE+A( 3, 3 )*A( 3, 3 ) ) )
S( 4 ) = ONE / SQRT( ( ONE+TWO*WX*WX ) /
$ ( ONE+A( 4, 4 )*A( 4, 4 ) ) )
S( 5 ) = ONE / SQRT( ( ONE+TWO*WX*WX ) /
$ ( ONE+A( 5, 5 )*A( 5, 5 ) ) )
*
CALL DLAKF2( 1, 4, A, LDA, A( 2, 2 ), B, B( 2, 2 ), Z, 12 )
CALL DGESVD( 'N', 'N', 8, 8, Z, 12, WORK, WORK( 9 ), 1,
$ WORK( 10 ), 1, WORK( 11 ), 40, INFO )
DIF( 1 ) = WORK( 8 )
*
CALL DLAKF2( 4, 1, A, LDA, A( 5, 5 ), B, B( 5, 5 ), Z, 12 )
CALL DGESVD( 'N', 'N', 8, 8, Z, 12, WORK, WORK( 9 ), 1,
$ WORK( 10 ), 1, WORK( 11 ), 40, INFO )
DIF( 5 ) = WORK( 8 )
*
ELSE IF( TYPE.EQ.2 ) THEN
*
S( 1 ) = ONE / SQRT( ONE / THREE+WY*WY )
S( 2 ) = S( 1 )
S( 3 ) = ONE / SQRT( ONE / TWO+WX*WX )
S( 4 ) = ONE / SQRT( ( ONE+TWO*WX*WX ) /
$ ( ONE+( ONE+ALPHA )*( ONE+ALPHA )+( ONE+BETA )*( ONE+
$ BETA ) ) )
S( 5 ) = S( 4 )
*
CALL DLAKF2( 2, 3, A, LDA, A( 3, 3 ), B, B( 3, 3 ), Z, 12 )
CALL DGESVD( 'N', 'N', 12, 12, Z, 12, WORK, WORK( 13 ), 1,
$ WORK( 14 ), 1, WORK( 15 ), 60, INFO )
DIF( 1 ) = WORK( 12 )
*
CALL DLAKF2( 3, 2, A, LDA, A( 4, 4 ), B, B( 4, 4 ), Z, 12 )
CALL DGESVD( 'N', 'N', 12, 12, Z, 12, WORK, WORK( 13 ), 1,
$ WORK( 14 ), 1, WORK( 15 ), 60, INFO )
DIF( 5 ) = WORK( 12 )
*
END IF
*
RETURN
*
* End of DLATM6
*
END
SUBROUTINE DLATME( N, DIST, ISEED, D, MODE, COND, DMAX, EI, RSIGN,
$ UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, A,
$ LDA, WORK, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIST, RSIGN, SIM, UPPER
INTEGER INFO, KL, KU, LDA, MODE, MODES, N
DOUBLE PRECISION ANORM, COND, CONDS, DMAX
* ..
* .. Array Arguments ..
CHARACTER EI( * )
INTEGER ISEED( 4 )
DOUBLE PRECISION A( LDA, * ), D( * ), DS( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLATME generates random non-symmetric square matrices with
* specified eigenvalues for testing LAPACK programs.
*
* DLATME operates by applying the following sequence of
* operations:
*
* 1. Set the diagonal to D, where D may be input or
* computed according to MODE, COND, DMAX, and RSIGN
* as described below.
*
* 2. If complex conjugate pairs are desired (MODE=0 and EI(1)='R',
* or MODE=5), certain pairs of adjacent elements of D are
* interpreted as the real and complex parts of a complex
* conjugate pair; A thus becomes block diagonal, with 1x1
* and 2x2 blocks.
*
* 3. If UPPER='T', the upper triangle of A is set to random values
* out of distribution DIST.
*
* 4. If SIM='T', A is multiplied on the left by a random matrix
* X, whose singular values are specified by DS, MODES, and
* CONDS, and on the right by X inverse.
*
* 5. If KL < N-1, the lower bandwidth is reduced to KL using
* Householder transformations. If KU < N-1, the upper
* bandwidth is reduced to KU.
*
* 6. If ANORM is not negative, the matrix is scaled to have
* maximum-element-norm ANORM.
*
* (Note: since the matrix cannot be reduced beyond Hessenberg form,
* no packing options are available.)
*
* Arguments
* =========
*
* N - INTEGER
* The number of columns (or rows) of A. Not modified.
*
* DIST - CHARACTER*1
* On entry, DIST specifies the type of distribution to be used
* to generate the random eigen-/singular values, and for the
* upper triangle (see UPPER).
* 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform )
* 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric )
* 'N' => NORMAL( 0, 1 ) ( 'N' for normal )
* Not modified.
*
* ISEED - INTEGER array, dimension ( 4 )
* On entry ISEED specifies the seed of the random number
* generator. They should lie between 0 and 4095 inclusive,
* and ISEED(4) should be odd. The random number generator
* uses a linear congruential sequence limited to small
* integers, and so should produce machine independent
* random numbers. The values of ISEED are changed on
* exit, and can be used in the next call to DLATME
* to continue the same random number sequence.
* Changed on exit.
*
* D - DOUBLE PRECISION array, dimension ( N )
* This array is used to specify the eigenvalues of A. If
* MODE=0, then D is assumed to contain the eigenvalues (but
* see the description of EI), otherwise they will be
* computed according to MODE, COND, DMAX, and RSIGN and
* placed in D.
* Modified if MODE is nonzero.
*
* MODE - INTEGER
* On entry this describes how the eigenvalues are to
* be specified:
* MODE = 0 means use D (with EI) as input
* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND
* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND
* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1))
* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
* MODE = 5 sets D to random numbers in the range
* ( 1/COND , 1 ) such that their logarithms
* are uniformly distributed. Each odd-even pair
* of elements will be either used as two real
* eigenvalues or as the real and imaginary part
* of a complex conjugate pair of eigenvalues;
* the choice of which is done is random, with
* 50-50 probability, for each pair.
* MODE = 6 set D to random numbers from same distribution
* as the rest of the matrix.
* MODE < 0 has the same meaning as ABS(MODE), except that
* the order of the elements of D is reversed.
* Thus if MODE is between 1 and 4, D has entries ranging
* from 1 to 1/COND, if between -1 and -4, D has entries
* ranging from 1/COND to 1,
* Not modified.
*
* COND - DOUBLE PRECISION
* On entry, this is used as described under MODE above.
* If used, it must be >= 1. Not modified.
*
* DMAX - DOUBLE PRECISION
* If MODE is neither -6, 0 nor 6, the contents of D, as
* computed according to MODE and COND, will be scaled by
* DMAX / max(abs(D(i))). Note that DMAX need not be
* positive: if DMAX is negative (or zero), D will be
* scaled by a negative number (or zero).
* Not modified.
*
* EI - CHARACTER*1 array, dimension ( N )
* If MODE is 0, and EI(1) is not ' ' (space character),
* this array specifies which elements of D (on input) are
* real eigenvalues and which are the real and imaginary parts
* of a complex conjugate pair of eigenvalues. The elements
* of EI may then only have the values 'R' and 'I'. If
* EI(j)='R' and EI(j+1)='I', then the j-th eigenvalue is
* CMPLX( D(j) , D(j+1) ), and the (j+1)-th is the complex
* conjugate thereof. If EI(j)=EI(j+1)='R', then the j-th
* eigenvalue is D(j) (i.e., real). EI(1) may not be 'I',
* nor may two adjacent elements of EI both have the value 'I'.
* If MODE is not 0, then EI is ignored. If MODE is 0 and
* EI(1)=' ', then the eigenvalues will all be real.
* Not modified.
*
* RSIGN - CHARACTER*1
* If MODE is not 0, 6, or -6, and RSIGN='T', then the
* elements of D, as computed according to MODE and COND, will
* be multiplied by a random sign (+1 or -1). If RSIGN='F',
* they will not be. RSIGN may only have the values 'T' or
* 'F'.
* Not modified.
*
* UPPER - CHARACTER*1
* If UPPER='T', then the elements of A above the diagonal
* (and above the 2x2 diagonal blocks, if A has complex
* eigenvalues) will be set to random numbers out of DIST.
* If UPPER='F', they will not. UPPER may only have the
* values 'T' or 'F'.
* Not modified.
*
* SIM - CHARACTER*1
* If SIM='T', then A will be operated on by a "similarity
* transform", i.e., multiplied on the left by a matrix X and
* on the right by X inverse. X = U S V, where U and V are
* random unitary matrices and S is a (diagonal) matrix of
* singular values specified by DS, MODES, and CONDS. If
* SIM='F', then A will not be transformed.
* Not modified.
*
* DS - DOUBLE PRECISION array, dimension ( N )
* This array is used to specify the singular values of X,
* in the same way that D specifies the eigenvalues of A.
* If MODE=0, the DS contains the singular values, which
* may not be zero.
* Modified if MODE is nonzero.
*
* MODES - INTEGER
* CONDS - DOUBLE PRECISION
* Same as MODE and COND, but for specifying the diagonal
* of S. MODES=-6 and +6 are not allowed (since they would
* result in randomly ill-conditioned eigenvalues.)
*
* KL - INTEGER
* This specifies the lower bandwidth of the matrix. KL=1
* specifies upper Hessenberg form. If KL is at least N-1,
* then A will have full lower bandwidth. KL must be at
* least 1.
* Not modified.
*
* KU - INTEGER
* This specifies the upper bandwidth of the matrix. KU=1
* specifies lower Hessenberg form. If KU is at least N-1,
* then A will have full upper bandwidth; if KU and KL
* are both at least N-1, then A will be dense. Only one of
* KU and KL may be less than N-1. KU must be at least 1.
* Not modified.
*
* ANORM - DOUBLE PRECISION
* If ANORM is not negative, then A will be scaled by a non-
* negative real number to make the maximum-element-norm of A
* to be ANORM.
* Not modified.
*
* A - DOUBLE PRECISION array, dimension ( LDA, N )
* On exit A is the desired test matrix.
* Modified.
*
* LDA - INTEGER
* LDA specifies the first dimension of A as declared in the
* calling program. LDA must be at least N.
* Not modified.
*
* WORK - DOUBLE PRECISION array, dimension ( 3*N )
* Workspace.
* Modified.
*
* INFO - INTEGER
* Error code. On exit, INFO will be set to one of the
* following values:
* 0 => normal return
* -1 => N negative
* -2 => DIST illegal string
* -5 => MODE not in range -6 to 6
* -6 => COND less than 1.0, and MODE neither -6, 0 nor 6
* -8 => EI(1) is not ' ' or 'R', EI(j) is not 'R' or 'I', or
* two adjacent elements of EI are 'I'.
* -9 => RSIGN is not 'T' or 'F'
* -10 => UPPER is not 'T' or 'F'
* -11 => SIM is not 'T' or 'F'
* -12 => MODES=0 and DS has a zero singular value.
* -13 => MODES is not in the range -5 to 5.
* -14 => MODES is nonzero and CONDS is less than 1.
* -15 => KL is less than 1.
* -16 => KU is less than 1, or KL and KU are both less than
* N-1.
* -19 => LDA is less than N.
* 1 => Error return from DLATM1 (computing D)
* 2 => Cannot scale to DMAX (max. eigenvalue is 0)
* 3 => Error return from DLATM1 (computing DS)
* 4 => Error return from DLARGE
* 5 => Zero singular value from DLATM1.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION HALF
PARAMETER ( HALF = 1.0D0 / 2.0D0 )
* ..
* .. Local Scalars ..
LOGICAL BADEI, BADS, USEEI
INTEGER I, IC, ICOLS, IDIST, IINFO, IR, IROWS, IRSIGN,
$ ISIM, IUPPER, J, JC, JCR, JR
DOUBLE PRECISION ALPHA, TAU, TEMP, XNORMS
* ..
* .. Local Arrays ..
DOUBLE PRECISION TEMPA( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLANGE, DLARAN
EXTERNAL LSAME, DLANGE, DLARAN
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMV, DGER, DLARFG, DLARGE, DLARNV,
$ DLASET, DLATM1, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MOD
* ..
* .. Executable Statements ..
*
* 1) Decode and Test the input parameters.
* Initialize flags & seed.
*
INFO = 0
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Decode DIST
*
IF( LSAME( DIST, 'U' ) ) THEN
IDIST = 1
ELSE IF( LSAME( DIST, 'S' ) ) THEN
IDIST = 2
ELSE IF( LSAME( DIST, 'N' ) ) THEN
IDIST = 3
ELSE
IDIST = -1
END IF
*
* Check EI
*
USEEI = .TRUE.
BADEI = .FALSE.
IF( LSAME( EI( 1 ), ' ' ) .OR. MODE.NE.0 ) THEN
USEEI = .FALSE.
ELSE
IF( LSAME( EI( 1 ), 'R' ) ) THEN
DO 10 J = 2, N
IF( LSAME( EI( J ), 'I' ) ) THEN
IF( LSAME( EI( J-1 ), 'I' ) )
$ BADEI = .TRUE.
ELSE
IF( .NOT.LSAME( EI( J ), 'R' ) )
$ BADEI = .TRUE.
END IF
10 CONTINUE
ELSE
BADEI = .TRUE.
END IF
END IF
*
* Decode RSIGN
*
IF( LSAME( RSIGN, 'T' ) ) THEN
IRSIGN = 1
ELSE IF( LSAME( RSIGN, 'F' ) ) THEN
IRSIGN = 0
ELSE
IRSIGN = -1
END IF
*
* Decode UPPER
*
IF( LSAME( UPPER, 'T' ) ) THEN
IUPPER = 1
ELSE IF( LSAME( UPPER, 'F' ) ) THEN
IUPPER = 0
ELSE
IUPPER = -1
END IF
*
* Decode SIM
*
IF( LSAME( SIM, 'T' ) ) THEN
ISIM = 1
ELSE IF( LSAME( SIM, 'F' ) ) THEN
ISIM = 0
ELSE
ISIM = -1
END IF
*
* Check DS, if MODES=0 and ISIM=1
*
BADS = .FALSE.
IF( MODES.EQ.0 .AND. ISIM.EQ.1 ) THEN
DO 20 J = 1, N
IF( DS( J ).EQ.ZERO )
$ BADS = .TRUE.
20 CONTINUE
END IF
*
* Set INFO if an error
*
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( IDIST.EQ.-1 ) THEN
INFO = -2
ELSE IF( ABS( MODE ).GT.6 ) THEN
INFO = -5
ELSE IF( ( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) .AND. COND.LT.ONE )
$ THEN
INFO = -6
ELSE IF( BADEI ) THEN
INFO = -8
ELSE IF( IRSIGN.EQ.-1 ) THEN
INFO = -9
ELSE IF( IUPPER.EQ.-1 ) THEN
INFO = -10
ELSE IF( ISIM.EQ.-1 ) THEN
INFO = -11
ELSE IF( BADS ) THEN
INFO = -12
ELSE IF( ISIM.EQ.1 .AND. ABS( MODES ).GT.5 ) THEN
INFO = -13
ELSE IF( ISIM.EQ.1 .AND. MODES.NE.0 .AND. CONDS.LT.ONE ) THEN
INFO = -14
ELSE IF( KL.LT.1 ) THEN
INFO = -15
ELSE IF( KU.LT.1 .OR. ( KU.LT.N-1 .AND. KL.LT.N-1 ) ) THEN
INFO = -16
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -19
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLATME', -INFO )
RETURN
END IF
*
* Initialize random number generator
*
DO 30 I = 1, 4
ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 )
30 CONTINUE
*
IF( MOD( ISEED( 4 ), 2 ).NE.1 )
$ ISEED( 4 ) = ISEED( 4 ) + 1
*
* 2) Set up diagonal of A
*
* Compute D according to COND and MODE
*
CALL DLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 1
RETURN
END IF
IF( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) THEN
*
* Scale by DMAX
*
TEMP = ABS( D( 1 ) )
DO 40 I = 2, N
TEMP = MAX( TEMP, ABS( D( I ) ) )
40 CONTINUE
*
IF( TEMP.GT.ZERO ) THEN
ALPHA = DMAX / TEMP
ELSE IF( DMAX.NE.ZERO ) THEN
INFO = 2
RETURN
ELSE
ALPHA = ZERO
END IF
*
CALL DSCAL( N, ALPHA, D, 1 )
*
END IF
*
CALL DLASET( 'Full', N, N, ZERO, ZERO, A, LDA )
CALL DCOPY( N, D, 1, A, LDA+1 )
*
* Set up complex conjugate pairs
*
IF( MODE.EQ.0 ) THEN
IF( USEEI ) THEN
DO 50 J = 2, N
IF( LSAME( EI( J ), 'I' ) ) THEN
A( J-1, J ) = A( J, J )
A( J, J-1 ) = -A( J, J )
A( J, J ) = A( J-1, J-1 )
END IF
50 CONTINUE
END IF
*
ELSE IF( ABS( MODE ).EQ.5 ) THEN
*
DO 60 J = 2, N, 2
IF( DLARAN( ISEED ).GT.HALF ) THEN
A( J-1, J ) = A( J, J )
A( J, J-1 ) = -A( J, J )
A( J, J ) = A( J-1, J-1 )
END IF
60 CONTINUE
END IF
*
* 3) If UPPER='T', set upper triangle of A to random numbers.
* (but don't modify the corners of 2x2 blocks.)
*
IF( IUPPER.NE.0 ) THEN
DO 70 JC = 2, N
IF( A( JC-1, JC ).NE.ZERO ) THEN
JR = JC - 2
ELSE
JR = JC - 1
END IF
CALL DLARNV( IDIST, ISEED, JR, A( 1, JC ) )
70 CONTINUE
END IF
*
* 4) If SIM='T', apply similarity transformation.
*
* -1
* Transform is X A X , where X = U S V, thus
*
* it is U S V A V' (1/S) U'
*
IF( ISIM.NE.0 ) THEN
*
* Compute S (singular values of the eigenvector matrix)
* according to CONDS and MODES
*
CALL DLATM1( MODES, CONDS, 0, 0, ISEED, DS, N, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 3
RETURN
END IF
*
* Multiply by V and V'
*
CALL DLARGE( N, A, LDA, ISEED, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 4
RETURN
END IF
*
* Multiply by S and (1/S)
*
DO 80 J = 1, N
CALL DSCAL( N, DS( J ), A( J, 1 ), LDA )
IF( DS( J ).NE.ZERO ) THEN
CALL DSCAL( N, ONE / DS( J ), A( 1, J ), 1 )
ELSE
INFO = 5
RETURN
END IF
80 CONTINUE
*
* Multiply by U and U'
*
CALL DLARGE( N, A, LDA, ISEED, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 4
RETURN
END IF
END IF
*
* 5) Reduce the bandwidth.
*
IF( KL.LT.N-1 ) THEN
*
* Reduce bandwidth -- kill column
*
DO 90 JCR = KL + 1, N - 1
IC = JCR - KL
IROWS = N + 1 - JCR
ICOLS = N + KL - JCR
*
CALL DCOPY( IROWS, A( JCR, IC ), 1, WORK, 1 )
XNORMS = WORK( 1 )
CALL DLARFG( IROWS, XNORMS, WORK( 2 ), 1, TAU )
WORK( 1 ) = ONE
*
CALL DGEMV( 'T', IROWS, ICOLS, ONE, A( JCR, IC+1 ), LDA,
$ WORK, 1, ZERO, WORK( IROWS+1 ), 1 )
CALL DGER( IROWS, ICOLS, -TAU, WORK, 1, WORK( IROWS+1 ), 1,
$ A( JCR, IC+1 ), LDA )
*
CALL DGEMV( 'N', N, IROWS, ONE, A( 1, JCR ), LDA, WORK, 1,
$ ZERO, WORK( IROWS+1 ), 1 )
CALL DGER( N, IROWS, -TAU, WORK( IROWS+1 ), 1, WORK, 1,
$ A( 1, JCR ), LDA )
*
A( JCR, IC ) = XNORMS
CALL DLASET( 'Full', IROWS-1, 1, ZERO, ZERO, A( JCR+1, IC ),
$ LDA )
90 CONTINUE
ELSE IF( KU.LT.N-1 ) THEN
*
* Reduce upper bandwidth -- kill a row at a time.
*
DO 100 JCR = KU + 1, N - 1
IR = JCR - KU
IROWS = N + KU - JCR
ICOLS = N + 1 - JCR
*
CALL DCOPY( ICOLS, A( IR, JCR ), LDA, WORK, 1 )
XNORMS = WORK( 1 )
CALL DLARFG( ICOLS, XNORMS, WORK( 2 ), 1, TAU )
WORK( 1 ) = ONE
*
CALL DGEMV( 'N', IROWS, ICOLS, ONE, A( IR+1, JCR ), LDA,
$ WORK, 1, ZERO, WORK( ICOLS+1 ), 1 )
CALL DGER( IROWS, ICOLS, -TAU, WORK( ICOLS+1 ), 1, WORK, 1,
$ A( IR+1, JCR ), LDA )
*
CALL DGEMV( 'C', ICOLS, N, ONE, A( JCR, 1 ), LDA, WORK, 1,
$ ZERO, WORK( ICOLS+1 ), 1 )
CALL DGER( ICOLS, N, -TAU, WORK, 1, WORK( ICOLS+1 ), 1,
$ A( JCR, 1 ), LDA )
*
A( IR, JCR ) = XNORMS
CALL DLASET( 'Full', 1, ICOLS-1, ZERO, ZERO, A( IR, JCR+1 ),
$ LDA )
100 CONTINUE
END IF
*
* Scale the matrix to have norm ANORM
*
IF( ANORM.GE.ZERO ) THEN
TEMP = DLANGE( 'M', N, N, A, LDA, TEMPA )
IF( TEMP.GT.ZERO ) THEN
ALPHA = ANORM / TEMP
DO 110 J = 1, N
CALL DSCAL( N, ALPHA, A( 1, J ), 1 )
110 CONTINUE
END IF
END IF
*
RETURN
*
* End of DLATME
*
END
SUBROUTINE DLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX,
$ RSIGN, GRADE, DL, MODEL, CONDL, DR, MODER,
$ CONDR, PIVTNG, IPIVOT, KL, KU, SPARSE, ANORM,
$ PACK, A, LDA, IWORK, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIST, GRADE, PACK, PIVTNG, RSIGN, SYM
INTEGER INFO, KL, KU, LDA, M, MODE, MODEL, MODER, N
DOUBLE PRECISION ANORM, COND, CONDL, CONDR, DMAX, SPARSE
* ..
* .. Array Arguments ..
INTEGER IPIVOT( * ), ISEED( 4 ), IWORK( * )
DOUBLE PRECISION A( LDA, * ), D( * ), DL( * ), DR( * )
* ..
*
* Purpose
* =======
*
* DLATMR generates random matrices of various types for testing
* LAPACK programs.
*
* DLATMR operates by applying the following sequence of
* operations:
*
* Generate a matrix A with random entries of distribution DIST
* which is symmetric if SYM='S', and nonsymmetric
* if SYM='N'.
*
* Set the diagonal to D, where D may be input or
* computed according to MODE, COND, DMAX and RSIGN
* as described below.
*
* Grade the matrix, if desired, from the left and/or right
* as specified by GRADE. The inputs DL, MODEL, CONDL, DR,
* MODER and CONDR also determine the grading as described
* below.
*
* Permute, if desired, the rows and/or columns as specified by
* PIVTNG and IPIVOT.
*
* Set random entries to zero, if desired, to get a random sparse
* matrix as specified by SPARSE.
*
* Make A a band matrix, if desired, by zeroing out the matrix
* outside a band of lower bandwidth KL and upper bandwidth KU.
*
* Scale A, if desired, to have maximum entry ANORM.
*
* Pack the matrix if desired. Options specified by PACK are:
* no packing
* zero out upper half (if symmetric)
* zero out lower half (if symmetric)
* store the upper half columnwise (if symmetric or
* square upper triangular)
* store the lower half columnwise (if symmetric or
* square lower triangular)
* same as upper half rowwise if symmetric
* store the lower triangle in banded format (if symmetric)
* store the upper triangle in banded format (if symmetric)
* store the entire matrix in banded format
*
* Note: If two calls to DLATMR differ only in the PACK parameter,
* they will generate mathematically equivalent matrices.
*
* If two calls to DLATMR both have full bandwidth (KL = M-1
* and KU = N-1), and differ only in the PIVTNG and PACK
* parameters, then the matrices generated will differ only
* in the order of the rows and/or columns, and otherwise
* contain the same data. This consistency cannot be and
* is not maintained with less than full bandwidth.
*
* Arguments
* =========
*
* M - INTEGER
* Number of rows of A. Not modified.
*
* N - INTEGER
* Number of columns of A. Not modified.
*
* DIST - CHARACTER*1
* On entry, DIST specifies the type of distribution to be used
* to generate a random matrix .
* 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform )
* 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric )
* 'N' => NORMAL( 0, 1 ) ( 'N' for normal )
* Not modified.
*
* ISEED - INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. They should lie between 0 and 4095 inclusive,
* and ISEED(4) should be odd. The random number generator
* uses a linear congruential sequence limited to small
* integers, and so should produce machine independent
* random numbers. The values of ISEED are changed on
* exit, and can be used in the next call to DLATMR
* to continue the same random number sequence.
* Changed on exit.
*
* SYM - CHARACTER*1
* If SYM='S' or 'H', generated matrix is symmetric.
* If SYM='N', generated matrix is nonsymmetric.
* Not modified.
*
* D - DOUBLE PRECISION array, dimension (min(M,N))
* On entry this array specifies the diagonal entries
* of the diagonal of A. D may either be specified
* on entry, or set according to MODE and COND as described
* below. May be changed on exit if MODE is nonzero.
*
* MODE - INTEGER
* On entry describes how D is to be used:
* MODE = 0 means use D as input
* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND
* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND
* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1))
* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
* MODE = 5 sets D to random numbers in the range
* ( 1/COND , 1 ) such that their logarithms
* are uniformly distributed.
* MODE = 6 set D to random numbers from same distribution
* as the rest of the matrix.
* MODE < 0 has the same meaning as ABS(MODE), except that
* the order of the elements of D is reversed.
* Thus if MODE is positive, D has entries ranging from
* 1 to 1/COND, if negative, from 1/COND to 1,
* Not modified.
*
* COND - DOUBLE PRECISION
* On entry, used as described under MODE above.
* If used, it must be >= 1. Not modified.
*
* DMAX - DOUBLE PRECISION
* If MODE neither -6, 0 nor 6, the diagonal is scaled by
* DMAX / max(abs(D(i))), so that maximum absolute entry
* of diagonal is abs(DMAX). If DMAX is negative (or zero),
* diagonal will be scaled by a negative number (or zero).
*
* RSIGN - CHARACTER*1
* If MODE neither -6, 0 nor 6, specifies sign of diagonal
* as follows:
* 'T' => diagonal entries are multiplied by 1 or -1
* with probability .5
* 'F' => diagonal unchanged
* Not modified.
*
* GRADE - CHARACTER*1
* Specifies grading of matrix as follows:
* 'N' => no grading
* 'L' => matrix premultiplied by diag( DL )
* (only if matrix nonsymmetric)
* 'R' => matrix postmultiplied by diag( DR )
* (only if matrix nonsymmetric)
* 'B' => matrix premultiplied by diag( DL ) and
* postmultiplied by diag( DR )
* (only if matrix nonsymmetric)
* 'S' or 'H' => matrix premultiplied by diag( DL ) and
* postmultiplied by diag( DL )
* ('S' for symmetric, or 'H' for Hermitian)
* 'E' => matrix premultiplied by diag( DL ) and
* postmultiplied by inv( diag( DL ) )
* ( 'E' for eigenvalue invariance)
* (only if matrix nonsymmetric)
* Note: if GRADE='E', then M must equal N.
* Not modified.
*
* DL - DOUBLE PRECISION array, dimension (M)
* If MODEL=0, then on entry this array specifies the diagonal
* entries of a diagonal matrix used as described under GRADE
* above. If MODEL is not zero, then DL will be set according
* to MODEL and CONDL, analogous to the way D is set according
* to MODE and COND (except there is no DMAX parameter for DL).
* If GRADE='E', then DL cannot have zero entries.
* Not referenced if GRADE = 'N' or 'R'. Changed on exit.
*
* MODEL - INTEGER
* This specifies how the diagonal array DL is to be computed,
* just as MODE specifies how D is to be computed.
* Not modified.
*
* CONDL - DOUBLE PRECISION
* When MODEL is not zero, this specifies the condition number
* of the computed DL. Not modified.
*
* DR - DOUBLE PRECISION array, dimension (N)
* If MODER=0, then on entry this array specifies the diagonal
* entries of a diagonal matrix used as described under GRADE
* above. If MODER is not zero, then DR will be set according
* to MODER and CONDR, analogous to the way D is set according
* to MODE and COND (except there is no DMAX parameter for DR).
* Not referenced if GRADE = 'N', 'L', 'H', 'S' or 'E'.
* Changed on exit.
*
* MODER - INTEGER
* This specifies how the diagonal array DR is to be computed,
* just as MODE specifies how D is to be computed.
* Not modified.
*
* CONDR - DOUBLE PRECISION
* When MODER is not zero, this specifies the condition number
* of the computed DR. Not modified.
*
* PIVTNG - CHARACTER*1
* On entry specifies pivoting permutations as follows:
* 'N' or ' ' => none.
* 'L' => left or row pivoting (matrix must be nonsymmetric).
* 'R' => right or column pivoting (matrix must be
* nonsymmetric).
* 'B' or 'F' => both or full pivoting, i.e., on both sides.
* In this case, M must equal N
*
* If two calls to DLATMR both have full bandwidth (KL = M-1
* and KU = N-1), and differ only in the PIVTNG and PACK
* parameters, then the matrices generated will differ only
* in the order of the rows and/or columns, and otherwise
* contain the same data. This consistency cannot be
* maintained with less than full bandwidth.
*
* IPIVOT - INTEGER array, dimension (N or M)
* This array specifies the permutation used. After the
* basic matrix is generated, the rows, columns, or both
* are permuted. If, say, row pivoting is selected, DLATMR
* starts with the *last* row and interchanges the M-th and
* IPIVOT(M)-th rows, then moves to the next-to-last row,
* interchanging the (M-1)-th and the IPIVOT(M-1)-th rows,
* and so on. In terms of "2-cycles", the permutation is
* (1 IPIVOT(1)) (2 IPIVOT(2)) ... (M IPIVOT(M))
* where the rightmost cycle is applied first. This is the
* *inverse* of the effect of pivoting in LINPACK. The idea
* is that factoring (with pivoting) an identity matrix
* which has been inverse-pivoted in this way should
* result in a pivot vector identical to IPIVOT.
* Not referenced if PIVTNG = 'N'. Not modified.
*
* SPARSE - DOUBLE PRECISION
* On entry specifies the sparsity of the matrix if a sparse
* matrix is to be generated. SPARSE should lie between
* 0 and 1. To generate a sparse matrix, for each matrix entry
* a uniform ( 0, 1 ) random number x is generated and
* compared to SPARSE; if x is larger the matrix entry
* is unchanged and if x is smaller the entry is set
* to zero. Thus on the average a fraction SPARSE of the
* entries will be set to zero.
* Not modified.
*
* KL - INTEGER
* On entry specifies the lower bandwidth of the matrix. For
* example, KL=0 implies upper triangular, KL=1 implies upper
* Hessenberg, and KL at least M-1 implies the matrix is not
* banded. Must equal KU if matrix is symmetric.
* Not modified.
*
* KU - INTEGER
* On entry specifies the upper bandwidth of the matrix. For
* example, KU=0 implies lower triangular, KU=1 implies lower
* Hessenberg, and KU at least N-1 implies the matrix is not
* banded. Must equal KL if matrix is symmetric.
* Not modified.
*
* ANORM - DOUBLE PRECISION
* On entry specifies maximum entry of output matrix
* (output matrix will by multiplied by a constant so that
* its largest absolute entry equal ANORM)
* if ANORM is nonnegative. If ANORM is negative no scaling
* is done. Not modified.
*
* PACK - CHARACTER*1
* On entry specifies packing of matrix as follows:
* 'N' => no packing
* 'U' => zero out all subdiagonal entries (if symmetric)
* 'L' => zero out all superdiagonal entries (if symmetric)
* 'C' => store the upper triangle columnwise
* (only if matrix symmetric or square upper triangular)
* 'R' => store the lower triangle columnwise
* (only if matrix symmetric or square lower triangular)
* (same as upper half rowwise if symmetric)
* 'B' => store the lower triangle in band storage scheme
* (only if matrix symmetric)
* 'Q' => store the upper triangle in band storage scheme
* (only if matrix symmetric)
* 'Z' => store the entire matrix in band storage scheme
* (pivoting can be provided for by using this
* option to store A in the trailing rows of
* the allocated storage)
*
* Using these options, the various LAPACK packed and banded
* storage schemes can be obtained:
* GB - use 'Z'
* PB, SB or TB - use 'B' or 'Q'
* PP, SP or TP - use 'C' or 'R'
*
* If two calls to DLATMR differ only in the PACK parameter,
* they will generate mathematically equivalent matrices.
* Not modified.
*
* A - DOUBLE PRECISION array, dimension (LDA,N)
* On exit A is the desired test matrix. Only those
* entries of A which are significant on output
* will be referenced (even if A is in packed or band
* storage format). The 'unoccupied corners' of A in
* band format will be zeroed out.
*
* LDA - INTEGER
* on entry LDA specifies the first dimension of A as
* declared in the calling program.
* If PACK='N', 'U' or 'L', LDA must be at least max ( 1, M ).
* If PACK='C' or 'R', LDA must be at least 1.
* If PACK='B', or 'Q', LDA must be MIN ( KU+1, N )
* If PACK='Z', LDA must be at least KUU+KLL+1, where
* KUU = MIN ( KU, N-1 ) and KLL = MIN ( KL, N-1 )
* Not modified.
*
* IWORK - INTEGER array, dimension ( N or M)
* Workspace. Not referenced if PIVTNG = 'N'. Changed on exit.
*
* INFO - INTEGER
* Error parameter on exit:
* 0 => normal return
* -1 => M negative or unequal to N and SYM='S' or 'H'
* -2 => N negative
* -3 => DIST illegal string
* -5 => SYM illegal string
* -7 => MODE not in range -6 to 6
* -8 => COND less than 1.0, and MODE neither -6, 0 nor 6
* -10 => MODE neither -6, 0 nor 6 and RSIGN illegal string
* -11 => GRADE illegal string, or GRADE='E' and
* M not equal to N, or GRADE='L', 'R', 'B' or 'E' and
* SYM = 'S' or 'H'
* -12 => GRADE = 'E' and DL contains zero
* -13 => MODEL not in range -6 to 6 and GRADE= 'L', 'B', 'H',
* 'S' or 'E'
* -14 => CONDL less than 1.0, GRADE='L', 'B', 'H', 'S' or 'E',
* and MODEL neither -6, 0 nor 6
* -16 => MODER not in range -6 to 6 and GRADE= 'R' or 'B'
* -17 => CONDR less than 1.0, GRADE='R' or 'B', and
* MODER neither -6, 0 nor 6
* -18 => PIVTNG illegal string, or PIVTNG='B' or 'F' and
* M not equal to N, or PIVTNG='L' or 'R' and SYM='S'
* or 'H'
* -19 => IPIVOT contains out of range number and
* PIVTNG not equal to 'N'
* -20 => KL negative
* -21 => KU negative, or SYM='S' or 'H' and KU not equal to KL
* -22 => SPARSE not in range 0. to 1.
* -24 => PACK illegal string, or PACK='U', 'L', 'B' or 'Q'
* and SYM='N', or PACK='C' and SYM='N' and either KL
* not equal to 0 or N not equal to M, or PACK='R' and
* SYM='N', and either KU not equal to 0 or N not equal
* to M
* -26 => LDA too small
* 1 => Error return from DLATM1 (computing D)
* 2 => Cannot scale diagonal to DMAX (max. entry is 0)
* 3 => Error return from DLATM1 (computing DL)
* 4 => Error return from DLATM1 (computing DR)
* 5 => ANORM is positive, but matrix constructed prior to
* attempting to scale it to have norm ANORM, is zero
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL BADPVT, DZERO, FULBND
INTEGER I, IDIST, IGRADE, IISUB, IPACK, IPVTNG, IRSIGN,
$ ISUB, ISYM, J, JJSUB, JSUB, K, KLL, KUU, MNMIN,
$ MNSUB, MXSUB, NPVTS
DOUBLE PRECISION ALPHA, ONORM, TEMP
* ..
* .. Local Arrays ..
DOUBLE PRECISION TEMPA( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLANGB, DLANGE, DLANSB, DLANSP, DLANSY, DLATM2,
$ DLATM3
EXTERNAL LSAME, DLANGB, DLANGE, DLANSB, DLANSP, DLANSY,
$ DLATM2, DLATM3
* ..
* .. External Subroutines ..
EXTERNAL DLATM1, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, MOD
* ..
* .. Executable Statements ..
*
* 1) Decode and Test the input parameters.
* Initialize flags & seed.
*
INFO = 0
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
* Decode DIST
*
IF( LSAME( DIST, 'U' ) ) THEN
IDIST = 1
ELSE IF( LSAME( DIST, 'S' ) ) THEN
IDIST = 2
ELSE IF( LSAME( DIST, 'N' ) ) THEN
IDIST = 3
ELSE
IDIST = -1
END IF
*
* Decode SYM
*
IF( LSAME( SYM, 'S' ) ) THEN
ISYM = 0
ELSE IF( LSAME( SYM, 'N' ) ) THEN
ISYM = 1
ELSE IF( LSAME( SYM, 'H' ) ) THEN
ISYM = 0
ELSE
ISYM = -1
END IF
*
* Decode RSIGN
*
IF( LSAME( RSIGN, 'F' ) ) THEN
IRSIGN = 0
ELSE IF( LSAME( RSIGN, 'T' ) ) THEN
IRSIGN = 1
ELSE
IRSIGN = -1
END IF
*
* Decode PIVTNG
*
IF( LSAME( PIVTNG, 'N' ) ) THEN
IPVTNG = 0
ELSE IF( LSAME( PIVTNG, ' ' ) ) THEN
IPVTNG = 0
ELSE IF( LSAME( PIVTNG, 'L' ) ) THEN
IPVTNG = 1
NPVTS = M
ELSE IF( LSAME( PIVTNG, 'R' ) ) THEN
IPVTNG = 2
NPVTS = N
ELSE IF( LSAME( PIVTNG, 'B' ) ) THEN
IPVTNG = 3
NPVTS = MIN( N, M )
ELSE IF( LSAME( PIVTNG, 'F' ) ) THEN
IPVTNG = 3
NPVTS = MIN( N, M )
ELSE
IPVTNG = -1
END IF
*
* Decode GRADE
*
IF( LSAME( GRADE, 'N' ) ) THEN
IGRADE = 0
ELSE IF( LSAME( GRADE, 'L' ) ) THEN
IGRADE = 1
ELSE IF( LSAME( GRADE, 'R' ) ) THEN
IGRADE = 2
ELSE IF( LSAME( GRADE, 'B' ) ) THEN
IGRADE = 3
ELSE IF( LSAME( GRADE, 'E' ) ) THEN
IGRADE = 4
ELSE IF( LSAME( GRADE, 'H' ) .OR. LSAME( GRADE, 'S' ) ) THEN
IGRADE = 5
ELSE
IGRADE = -1
END IF
*
* Decode PACK
*
IF( LSAME( PACK, 'N' ) ) THEN
IPACK = 0
ELSE IF( LSAME( PACK, 'U' ) ) THEN
IPACK = 1
ELSE IF( LSAME( PACK, 'L' ) ) THEN
IPACK = 2
ELSE IF( LSAME( PACK, 'C' ) ) THEN
IPACK = 3
ELSE IF( LSAME( PACK, 'R' ) ) THEN
IPACK = 4
ELSE IF( LSAME( PACK, 'B' ) ) THEN
IPACK = 5
ELSE IF( LSAME( PACK, 'Q' ) ) THEN
IPACK = 6
ELSE IF( LSAME( PACK, 'Z' ) ) THEN
IPACK = 7
ELSE
IPACK = -1
END IF
*
* Set certain internal parameters
*
MNMIN = MIN( M, N )
KLL = MIN( KL, M-1 )
KUU = MIN( KU, N-1 )
*
* If inv(DL) is used, check to see if DL has a zero entry.
*
DZERO = .FALSE.
IF( IGRADE.EQ.4 .AND. MODEL.EQ.0 ) THEN
DO 10 I = 1, M
IF( DL( I ).EQ.ZERO )
$ DZERO = .TRUE.
10 CONTINUE
END IF
*
* Check values in IPIVOT
*
BADPVT = .FALSE.
IF( IPVTNG.GT.0 ) THEN
DO 20 J = 1, NPVTS
IF( IPIVOT( J ).LE.0 .OR. IPIVOT( J ).GT.NPVTS )
$ BADPVT = .TRUE.
20 CONTINUE
END IF
*
* Set INFO if an error
*
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( M.NE.N .AND. ISYM.EQ.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( IDIST.EQ.-1 ) THEN
INFO = -3
ELSE IF( ISYM.EQ.-1 ) THEN
INFO = -5
ELSE IF( MODE.LT.-6 .OR. MODE.GT.6 ) THEN
INFO = -7
ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
$ COND.LT.ONE ) THEN
INFO = -8
ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
$ IRSIGN.EQ.-1 ) THEN
INFO = -10
ELSE IF( IGRADE.EQ.-1 .OR. ( IGRADE.EQ.4 .AND. M.NE.N ) .OR.
$ ( ( IGRADE.GE.1 .AND. IGRADE.LE.4 ) .AND. ISYM.EQ.0 ) )
$ THEN
INFO = -11
ELSE IF( IGRADE.EQ.4 .AND. DZERO ) THEN
INFO = -12
ELSE IF( ( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR.
$ IGRADE.EQ.5 ) .AND. ( MODEL.LT.-6 .OR. MODEL.GT.6 ) )
$ THEN
INFO = -13
ELSE IF( ( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR.
$ IGRADE.EQ.5 ) .AND. ( MODEL.NE.-6 .AND. MODEL.NE.0 .AND.
$ MODEL.NE.6 ) .AND. CONDL.LT.ONE ) THEN
INFO = -14
ELSE IF( ( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) .AND.
$ ( MODER.LT.-6 .OR. MODER.GT.6 ) ) THEN
INFO = -16
ELSE IF( ( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) .AND.
$ ( MODER.NE.-6 .AND. MODER.NE.0 .AND. MODER.NE.6 ) .AND.
$ CONDR.LT.ONE ) THEN
INFO = -17
ELSE IF( IPVTNG.EQ.-1 .OR. ( IPVTNG.EQ.3 .AND. M.NE.N ) .OR.
$ ( ( IPVTNG.EQ.1 .OR. IPVTNG.EQ.2 ) .AND. ISYM.EQ.0 ) )
$ THEN
INFO = -18
ELSE IF( IPVTNG.NE.0 .AND. BADPVT ) THEN
INFO = -19
ELSE IF( KL.LT.0 ) THEN
INFO = -20
ELSE IF( KU.LT.0 .OR. ( ISYM.EQ.0 .AND. KL.NE.KU ) ) THEN
INFO = -21
ELSE IF( SPARSE.LT.ZERO .OR. SPARSE.GT.ONE ) THEN
INFO = -22
ELSE IF( IPACK.EQ.-1 .OR. ( ( IPACK.EQ.1 .OR. IPACK.EQ.2 .OR.
$ IPACK.EQ.5 .OR. IPACK.EQ.6 ) .AND. ISYM.EQ.1 ) .OR.
$ ( IPACK.EQ.3 .AND. ISYM.EQ.1 .AND. ( KL.NE.0 .OR. M.NE.
$ N ) ) .OR. ( IPACK.EQ.4 .AND. ISYM.EQ.1 .AND. ( KU.NE.
$ 0 .OR. M.NE.N ) ) ) THEN
INFO = -24
ELSE IF( ( ( IPACK.EQ.0 .OR. IPACK.EQ.1 .OR. IPACK.EQ.2 ) .AND.
$ LDA.LT.MAX( 1, M ) ) .OR. ( ( IPACK.EQ.3 .OR. IPACK.EQ.
$ 4 ) .AND. LDA.LT.1 ) .OR. ( ( IPACK.EQ.5 .OR. IPACK.EQ.
$ 6 ) .AND. LDA.LT.KUU+1 ) .OR.
$ ( IPACK.EQ.7 .AND. LDA.LT.KLL+KUU+1 ) ) THEN
INFO = -26
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLATMR', -INFO )
RETURN
END IF
*
* Decide if we can pivot consistently
*
FULBND = .FALSE.
IF( KUU.EQ.N-1 .AND. KLL.EQ.M-1 )
$ FULBND = .TRUE.
*
* Initialize random number generator
*
DO 30 I = 1, 4
ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 )
30 CONTINUE
*
ISEED( 4 ) = 2*( ISEED( 4 ) / 2 ) + 1
*
* 2) Set up D, DL, and DR, if indicated.
*
* Compute D according to COND and MODE
*
CALL DLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, MNMIN, INFO )
IF( INFO.NE.0 ) THEN
INFO = 1
RETURN
END IF
IF( MODE.NE.0 .AND. MODE.NE.-6 .AND. MODE.NE.6 ) THEN
*
* Scale by DMAX
*
TEMP = ABS( D( 1 ) )
DO 40 I = 2, MNMIN
TEMP = MAX( TEMP, ABS( D( I ) ) )
40 CONTINUE
IF( TEMP.EQ.ZERO .AND. DMAX.NE.ZERO ) THEN
INFO = 2
RETURN
END IF
IF( TEMP.NE.ZERO ) THEN
ALPHA = DMAX / TEMP
ELSE
ALPHA = ONE
END IF
DO 50 I = 1, MNMIN
D( I ) = ALPHA*D( I )
50 CONTINUE
*
END IF
*
* Compute DL if grading set
*
IF( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR. IGRADE.EQ.
$ 5 ) THEN
CALL DLATM1( MODEL, CONDL, 0, IDIST, ISEED, DL, M, INFO )
IF( INFO.NE.0 ) THEN
INFO = 3
RETURN
END IF
END IF
*
* Compute DR if grading set
*
IF( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) THEN
CALL DLATM1( MODER, CONDR, 0, IDIST, ISEED, DR, N, INFO )
IF( INFO.NE.0 ) THEN
INFO = 4
RETURN
END IF
END IF
*
* 3) Generate IWORK if pivoting
*
IF( IPVTNG.GT.0 ) THEN
DO 60 I = 1, NPVTS
IWORK( I ) = I
60 CONTINUE
IF( FULBND ) THEN
DO 70 I = 1, NPVTS
K = IPIVOT( I )
J = IWORK( I )
IWORK( I ) = IWORK( K )
IWORK( K ) = J
70 CONTINUE
ELSE
DO 80 I = NPVTS, 1, -1
K = IPIVOT( I )
J = IWORK( I )
IWORK( I ) = IWORK( K )
IWORK( K ) = J
80 CONTINUE
END IF
END IF
*
* 4) Generate matrices for each kind of PACKing
* Always sweep matrix columnwise (if symmetric, upper
* half only) so that matrix generated does not depend
* on PACK
*
IF( FULBND ) THEN
*
* Use DLATM3 so matrices generated with differing PIVOTing only
* differ only in the order of their rows and/or columns.
*
IF( IPACK.EQ.0 ) THEN
IF( ISYM.EQ.0 ) THEN
DO 100 J = 1, N
DO 90 I = 1, J
TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
A( ISUB, JSUB ) = TEMP
A( JSUB, ISUB ) = TEMP
90 CONTINUE
100 CONTINUE
ELSE IF( ISYM.EQ.1 ) THEN
DO 120 J = 1, N
DO 110 I = 1, M
TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
A( ISUB, JSUB ) = TEMP
110 CONTINUE
120 CONTINUE
END IF
*
ELSE IF( IPACK.EQ.1 ) THEN
*
DO 140 J = 1, N
DO 130 I = 1, J
TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
$ SPARSE )
MNSUB = MIN( ISUB, JSUB )
MXSUB = MAX( ISUB, JSUB )
A( MNSUB, MXSUB ) = TEMP
IF( MNSUB.NE.MXSUB )
$ A( MXSUB, MNSUB ) = ZERO
130 CONTINUE
140 CONTINUE
*
ELSE IF( IPACK.EQ.2 ) THEN
*
DO 160 J = 1, N
DO 150 I = 1, J
TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
$ SPARSE )
MNSUB = MIN( ISUB, JSUB )
MXSUB = MAX( ISUB, JSUB )
A( MXSUB, MNSUB ) = TEMP
IF( MNSUB.NE.MXSUB )
$ A( MNSUB, MXSUB ) = ZERO
150 CONTINUE
160 CONTINUE
*
ELSE IF( IPACK.EQ.3 ) THEN
*
DO 180 J = 1, N
DO 170 I = 1, J
TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
$ SPARSE )
*
* Compute K = location of (ISUB,JSUB) entry in packed
* array
*
MNSUB = MIN( ISUB, JSUB )
MXSUB = MAX( ISUB, JSUB )
K = MXSUB*( MXSUB-1 ) / 2 + MNSUB
*
* Convert K to (IISUB,JJSUB) location
*
JJSUB = ( K-1 ) / LDA + 1
IISUB = K - LDA*( JJSUB-1 )
*
A( IISUB, JJSUB ) = TEMP
170 CONTINUE
180 CONTINUE
*
ELSE IF( IPACK.EQ.4 ) THEN
*
DO 200 J = 1, N
DO 190 I = 1, J
TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
$ SPARSE )
*
* Compute K = location of (I,J) entry in packed array
*
MNSUB = MIN( ISUB, JSUB )
MXSUB = MAX( ISUB, JSUB )
IF( MNSUB.EQ.1 ) THEN
K = MXSUB
ELSE
K = N*( N+1 ) / 2 - ( N-MNSUB+1 )*( N-MNSUB+2 ) /
$ 2 + MXSUB - MNSUB + 1
END IF
*
* Convert K to (IISUB,JJSUB) location
*
JJSUB = ( K-1 ) / LDA + 1
IISUB = K - LDA*( JJSUB-1 )
*
A( IISUB, JJSUB ) = TEMP
190 CONTINUE
200 CONTINUE
*
ELSE IF( IPACK.EQ.5 ) THEN
*
DO 220 J = 1, N
DO 210 I = J - KUU, J
IF( I.LT.1 ) THEN
A( J-I+1, I+N ) = ZERO
ELSE
TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
MNSUB = MIN( ISUB, JSUB )
MXSUB = MAX( ISUB, JSUB )
A( MXSUB-MNSUB+1, MNSUB ) = TEMP
END IF
210 CONTINUE
220 CONTINUE
*
ELSE IF( IPACK.EQ.6 ) THEN
*
DO 240 J = 1, N
DO 230 I = J - KUU, J
TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
$ SPARSE )
MNSUB = MIN( ISUB, JSUB )
MXSUB = MAX( ISUB, JSUB )
A( MNSUB-MXSUB+KUU+1, MXSUB ) = TEMP
230 CONTINUE
240 CONTINUE
*
ELSE IF( IPACK.EQ.7 ) THEN
*
IF( ISYM.EQ.0 ) THEN
DO 260 J = 1, N
DO 250 I = J - KUU, J
TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
MNSUB = MIN( ISUB, JSUB )
MXSUB = MAX( ISUB, JSUB )
A( MNSUB-MXSUB+KUU+1, MXSUB ) = TEMP
IF( I.LT.1 )
$ A( J-I+1+KUU, I+N ) = ZERO
IF( I.GE.1 .AND. MNSUB.NE.MXSUB )
$ A( MXSUB-MNSUB+1+KUU, MNSUB ) = TEMP
250 CONTINUE
260 CONTINUE
ELSE IF( ISYM.EQ.1 ) THEN
DO 280 J = 1, N
DO 270 I = J - KUU, J + KLL
TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
A( ISUB-JSUB+KUU+1, JSUB ) = TEMP
270 CONTINUE
280 CONTINUE
END IF
*
END IF
*
ELSE
*
* Use DLATM2
*
IF( IPACK.EQ.0 ) THEN
IF( ISYM.EQ.0 ) THEN
DO 300 J = 1, N
DO 290 I = 1, J
A( I, J ) = DLATM2( M, N, I, J, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
A( J, I ) = A( I, J )
290 CONTINUE
300 CONTINUE
ELSE IF( ISYM.EQ.1 ) THEN
DO 320 J = 1, N
DO 310 I = 1, M
A( I, J ) = DLATM2( M, N, I, J, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
310 CONTINUE
320 CONTINUE
END IF
*
ELSE IF( IPACK.EQ.1 ) THEN
*
DO 340 J = 1, N
DO 330 I = 1, J
A( I, J ) = DLATM2( M, N, I, J, KL, KU, IDIST, ISEED,
$ D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE )
IF( I.NE.J )
$ A( J, I ) = ZERO
330 CONTINUE
340 CONTINUE
*
ELSE IF( IPACK.EQ.2 ) THEN
*
DO 360 J = 1, N
DO 350 I = 1, J
A( J, I ) = DLATM2( M, N, I, J, KL, KU, IDIST, ISEED,
$ D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE )
IF( I.NE.J )
$ A( I, J ) = ZERO
350 CONTINUE
360 CONTINUE
*
ELSE IF( IPACK.EQ.3 ) THEN
*
ISUB = 0
JSUB = 1
DO 380 J = 1, N
DO 370 I = 1, J
ISUB = ISUB + 1
IF( ISUB.GT.LDA ) THEN
ISUB = 1
JSUB = JSUB + 1
END IF
A( ISUB, JSUB ) = DLATM2( M, N, I, J, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
370 CONTINUE
380 CONTINUE
*
ELSE IF( IPACK.EQ.4 ) THEN
*
IF( ISYM.EQ.0 ) THEN
DO 400 J = 1, N
DO 390 I = 1, J
*
* Compute K = location of (I,J) entry in packed array
*
IF( I.EQ.1 ) THEN
K = J
ELSE
K = N*( N+1 ) / 2 - ( N-I+1 )*( N-I+2 ) / 2 +
$ J - I + 1
END IF
*
* Convert K to (ISUB,JSUB) location
*
JSUB = ( K-1 ) / LDA + 1
ISUB = K - LDA*( JSUB-1 )
*
A( ISUB, JSUB ) = DLATM2( M, N, I, J, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL, DR,
$ IPVTNG, IWORK, SPARSE )
390 CONTINUE
400 CONTINUE
ELSE
ISUB = 0
JSUB = 1
DO 420 J = 1, N
DO 410 I = J, M
ISUB = ISUB + 1
IF( ISUB.GT.LDA ) THEN
ISUB = 1
JSUB = JSUB + 1
END IF
A( ISUB, JSUB ) = DLATM2( M, N, I, J, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL, DR,
$ IPVTNG, IWORK, SPARSE )
410 CONTINUE
420 CONTINUE
END IF
*
ELSE IF( IPACK.EQ.5 ) THEN
*
DO 440 J = 1, N
DO 430 I = J - KUU, J
IF( I.LT.1 ) THEN
A( J-I+1, I+N ) = ZERO
ELSE
A( J-I+1, I ) = DLATM2( M, N, I, J, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
END IF
430 CONTINUE
440 CONTINUE
*
ELSE IF( IPACK.EQ.6 ) THEN
*
DO 460 J = 1, N
DO 450 I = J - KUU, J
A( I-J+KUU+1, J ) = DLATM2( M, N, I, J, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
450 CONTINUE
460 CONTINUE
*
ELSE IF( IPACK.EQ.7 ) THEN
*
IF( ISYM.EQ.0 ) THEN
DO 480 J = 1, N
DO 470 I = J - KUU, J
A( I-J+KUU+1, J ) = DLATM2( M, N, I, J, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL,
$ DR, IPVTNG, IWORK, SPARSE )
IF( I.LT.1 )
$ A( J-I+1+KUU, I+N ) = ZERO
IF( I.GE.1 .AND. I.NE.J )
$ A( J-I+1+KUU, I ) = A( I-J+KUU+1, J )
470 CONTINUE
480 CONTINUE
ELSE IF( ISYM.EQ.1 ) THEN
DO 500 J = 1, N
DO 490 I = J - KUU, J + KLL
A( I-J+KUU+1, J ) = DLATM2( M, N, I, J, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL,
$ DR, IPVTNG, IWORK, SPARSE )
490 CONTINUE
500 CONTINUE
END IF
*
END IF
*
END IF
*
* 5) Scaling the norm
*
IF( IPACK.EQ.0 ) THEN
ONORM = DLANGE( 'M', M, N, A, LDA, TEMPA )
ELSE IF( IPACK.EQ.1 ) THEN
ONORM = DLANSY( 'M', 'U', N, A, LDA, TEMPA )
ELSE IF( IPACK.EQ.2 ) THEN
ONORM = DLANSY( 'M', 'L', N, A, LDA, TEMPA )
ELSE IF( IPACK.EQ.3 ) THEN
ONORM = DLANSP( 'M', 'U', N, A, TEMPA )
ELSE IF( IPACK.EQ.4 ) THEN
ONORM = DLANSP( 'M', 'L', N, A, TEMPA )
ELSE IF( IPACK.EQ.5 ) THEN
ONORM = DLANSB( 'M', 'L', N, KLL, A, LDA, TEMPA )
ELSE IF( IPACK.EQ.6 ) THEN
ONORM = DLANSB( 'M', 'U', N, KUU, A, LDA, TEMPA )
ELSE IF( IPACK.EQ.7 ) THEN
ONORM = DLANGB( 'M', N, KLL, KUU, A, LDA, TEMPA )
END IF
*
IF( ANORM.GE.ZERO ) THEN
*
IF( ANORM.GT.ZERO .AND. ONORM.EQ.ZERO ) THEN
*
* Desired scaling impossible
*
INFO = 5
RETURN
*
ELSE IF( ( ANORM.GT.ONE .AND. ONORM.LT.ONE ) .OR.
$ ( ANORM.LT.ONE .AND. ONORM.GT.ONE ) ) THEN
*
* Scale carefully to avoid over / underflow
*
IF( IPACK.LE.2 ) THEN
DO 510 J = 1, N
CALL DSCAL( M, ONE / ONORM, A( 1, J ), 1 )
CALL DSCAL( M, ANORM, A( 1, J ), 1 )
510 CONTINUE
*
ELSE IF( IPACK.EQ.3 .OR. IPACK.EQ.4 ) THEN
*
CALL DSCAL( N*( N+1 ) / 2, ONE / ONORM, A, 1 )
CALL DSCAL( N*( N+1 ) / 2, ANORM, A, 1 )
*
ELSE IF( IPACK.GE.5 ) THEN
*
DO 520 J = 1, N
CALL DSCAL( KLL+KUU+1, ONE / ONORM, A( 1, J ), 1 )
CALL DSCAL( KLL+KUU+1, ANORM, A( 1, J ), 1 )
520 CONTINUE
*
END IF
*
ELSE
*
* Scale straightforwardly
*
IF( IPACK.LE.2 ) THEN
DO 530 J = 1, N
CALL DSCAL( M, ANORM / ONORM, A( 1, J ), 1 )
530 CONTINUE
*
ELSE IF( IPACK.EQ.3 .OR. IPACK.EQ.4 ) THEN
*
CALL DSCAL( N*( N+1 ) / 2, ANORM / ONORM, A, 1 )
*
ELSE IF( IPACK.GE.5 ) THEN
*
DO 540 J = 1, N
CALL DSCAL( KLL+KUU+1, ANORM / ONORM, A( 1, J ), 1 )
540 CONTINUE
END IF
*
END IF
*
END IF
*
* End of DLATMR
*
END
SUBROUTINE DLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX,
$ KL, KU, PACK, A, LDA, WORK, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIST, PACK, SYM
INTEGER INFO, KL, KU, LDA, M, MODE, N
DOUBLE PRECISION COND, DMAX
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
DOUBLE PRECISION A( LDA, * ), D( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLATMS generates random matrices with specified singular values
* (or symmetric/hermitian with specified eigenvalues)
* for testing LAPACK programs.
*
* DLATMS operates by applying the following sequence of
* operations:
*
* Set the diagonal to D, where D may be input or
* computed according to MODE, COND, DMAX, and SYM
* as described below.
*
* Generate a matrix with the appropriate band structure, by one
* of two methods:
*
* Method A:
* Generate a dense M x N matrix by multiplying D on the left
* and the right by random unitary matrices, then:
*
* Reduce the bandwidth according to KL and KU, using
* Householder transformations.
*
* Method B:
* Convert the bandwidth-0 (i.e., diagonal) matrix to a
* bandwidth-1 matrix using Givens rotations, "chasing"
* out-of-band elements back, much as in QR; then
* convert the bandwidth-1 to a bandwidth-2 matrix, etc.
* Note that for reasonably small bandwidths (relative to
* M and N) this requires less storage, as a dense matrix
* is not generated. Also, for symmetric matrices, only
* one triangle is generated.
*
* Method A is chosen if the bandwidth is a large fraction of the
* order of the matrix, and LDA is at least M (so a dense
* matrix can be stored.) Method B is chosen if the bandwidth
* is small (< 1/2 N for symmetric, < .3 N+M for
* non-symmetric), or LDA is less than M and not less than the
* bandwidth.
*
* Pack the matrix if desired. Options specified by PACK are:
* no packing
* zero out upper half (if symmetric)
* zero out lower half (if symmetric)
* store the upper half columnwise (if symmetric or upper
* triangular)
* store the lower half columnwise (if symmetric or lower
* triangular)
* store the lower triangle in banded format (if symmetric
* or lower triangular)
* store the upper triangle in banded format (if symmetric
* or upper triangular)
* store the entire matrix in banded format
* If Method B is chosen, and band format is specified, then the
* matrix will be generated in the band format, so no repacking
* will be necessary.
*
* Arguments
* =========
*
* M - INTEGER
* The number of rows of A. Not modified.
*
* N - INTEGER
* The number of columns of A. Not modified.
*
* DIST - CHARACTER*1
* On entry, DIST specifies the type of distribution to be used
* to generate the random eigen-/singular values.
* 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform )
* 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric )
* 'N' => NORMAL( 0, 1 ) ( 'N' for normal )
* Not modified.
*
* ISEED - INTEGER array, dimension ( 4 )
* On entry ISEED specifies the seed of the random number
* generator. They should lie between 0 and 4095 inclusive,
* and ISEED(4) should be odd. The random number generator
* uses a linear congruential sequence limited to small
* integers, and so should produce machine independent
* random numbers. The values of ISEED are changed on
* exit, and can be used in the next call to DLATMS
* to continue the same random number sequence.
* Changed on exit.
*
* SYM - CHARACTER*1
* If SYM='S' or 'H', the generated matrix is symmetric, with
* eigenvalues specified by D, COND, MODE, and DMAX; they
* may be positive, negative, or zero.
* If SYM='P', the generated matrix is symmetric, with
* eigenvalues (= singular values) specified by D, COND,
* MODE, and DMAX; they will not be negative.
* If SYM='N', the generated matrix is nonsymmetric, with
* singular values specified by D, COND, MODE, and DMAX;
* they will not be negative.
* Not modified.
*
* D - DOUBLE PRECISION array, dimension ( MIN( M , N ) )
* This array is used to specify the singular values or
* eigenvalues of A (see SYM, above.) If MODE=0, then D is
* assumed to contain the singular/eigenvalues, otherwise
* they will be computed according to MODE, COND, and DMAX,
* and placed in D.
* Modified if MODE is nonzero.
*
* MODE - INTEGER
* On entry this describes how the singular/eigenvalues are to
* be specified:
* MODE = 0 means use D as input
* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND
* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND
* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1))
* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
* MODE = 5 sets D to random numbers in the range
* ( 1/COND , 1 ) such that their logarithms
* are uniformly distributed.
* MODE = 6 set D to random numbers from same distribution
* as the rest of the matrix.
* MODE < 0 has the same meaning as ABS(MODE), except that
* the order of the elements of D is reversed.
* Thus if MODE is positive, D has entries ranging from
* 1 to 1/COND, if negative, from 1/COND to 1,
* If SYM='S' or 'H', and MODE is neither 0, 6, nor -6, then
* the elements of D will also be multiplied by a random
* sign (i.e., +1 or -1.)
* Not modified.
*
* COND - DOUBLE PRECISION
* On entry, this is used as described under MODE above.
* If used, it must be >= 1. Not modified.
*
* DMAX - DOUBLE PRECISION
* If MODE is neither -6, 0 nor 6, the contents of D, as
* computed according to MODE and COND, will be scaled by
* DMAX / max(abs(D(i))); thus, the maximum absolute eigen- or
* singular value (which is to say the norm) will be abs(DMAX).
* Note that DMAX need not be positive: if DMAX is negative
* (or zero), D will be scaled by a negative number (or zero).
* Not modified.
*
* KL - INTEGER
* This specifies the lower bandwidth of the matrix. For
* example, KL=0 implies upper triangular, KL=1 implies upper
* Hessenberg, and KL being at least M-1 means that the matrix
* has full lower bandwidth. KL must equal KU if the matrix
* is symmetric.
* Not modified.
*
* KU - INTEGER
* This specifies the upper bandwidth of the matrix. For
* example, KU=0 implies lower triangular, KU=1 implies lower
* Hessenberg, and KU being at least N-1 means that the matrix
* has full upper bandwidth. KL must equal KU if the matrix
* is symmetric.
* Not modified.
*
* PACK - CHARACTER*1
* This specifies packing of matrix as follows:
* 'N' => no packing
* 'U' => zero out all subdiagonal entries (if symmetric)
* 'L' => zero out all superdiagonal entries (if symmetric)
* 'C' => store the upper triangle columnwise
* (only if the matrix is symmetric or upper triangular)
* 'R' => store the lower triangle columnwise
* (only if the matrix is symmetric or lower triangular)
* 'B' => store the lower triangle in band storage scheme
* (only if matrix symmetric or lower triangular)
* 'Q' => store the upper triangle in band storage scheme
* (only if matrix symmetric or upper triangular)
* 'Z' => store the entire matrix in band storage scheme
* (pivoting can be provided for by using this
* option to store A in the trailing rows of
* the allocated storage)
*
* Using these options, the various LAPACK packed and banded
* storage schemes can be obtained:
* GB - use 'Z'
* PB, SB or TB - use 'B' or 'Q'
* PP, SP or TP - use 'C' or 'R'
*
* If two calls to DLATMS differ only in the PACK parameter,
* they will generate mathematically equivalent matrices.
* Not modified.
*
* A - DOUBLE PRECISION array, dimension ( LDA, N )
* On exit A is the desired test matrix. A is first generated
* in full (unpacked) form, and then packed, if so specified
* by PACK. Thus, the first M elements of the first N
* columns will always be modified. If PACK specifies a
* packed or banded storage scheme, all LDA elements of the
* first N columns will be modified; the elements of the
* array which do not correspond to elements of the generated
* matrix are set to zero.
* Modified.
*
* LDA - INTEGER
* LDA specifies the first dimension of A as declared in the
* calling program. If PACK='N', 'U', 'L', 'C', or 'R', then
* LDA must be at least M. If PACK='B' or 'Q', then LDA must
* be at least MIN( KL, M-1) (which is equal to MIN(KU,N-1)).
* If PACK='Z', LDA must be large enough to hold the packed
* array: MIN( KU, N-1) + MIN( KL, M-1) + 1.
* Not modified.
*
* WORK - DOUBLE PRECISION array, dimension ( 3*MAX( N , M ) )
* Workspace.
* Modified.
*
* INFO - INTEGER
* Error code. On exit, INFO will be set to one of the
* following values:
* 0 => normal return
* -1 => M negative or unequal to N and SYM='S', 'H', or 'P'
* -2 => N negative
* -3 => DIST illegal string
* -5 => SYM illegal string
* -7 => MODE not in range -6 to 6
* -8 => COND less than 1.0, and MODE neither -6, 0 nor 6
* -10 => KL negative
* -11 => KU negative, or SYM='S' or 'H' and KU not equal to KL
* -12 => PACK illegal string, or PACK='U' or 'L', and SYM='N';
* or PACK='C' or 'Q' and SYM='N' and KL is not zero;
* or PACK='R' or 'B' and SYM='N' and KU is not zero;
* or PACK='U', 'L', 'C', 'R', 'B', or 'Q', and M is not
* N.
* -14 => LDA is less than M, or PACK='Z' and LDA is less than
* MIN(KU,N-1) + MIN(KL,M-1) + 1.
* 1 => Error return from DLATM1
* 2 => Cannot scale to DMAX (max. sing. value is 0)
* 3 => Error return from DLAGGE or SLAGSY
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION TWOPI
PARAMETER ( TWOPI = 6.2831853071795864769252867663D+0 )
* ..
* .. Local Scalars ..
LOGICAL GIVENS, ILEXTR, ILTEMP, TOPDWN
INTEGER I, IC, ICOL, IDIST, IENDCH, IINFO, IL, ILDA,
$ IOFFG, IOFFST, IPACK, IPACKG, IR, IR1, IR2,
$ IROW, IRSIGN, ISKEW, ISYM, ISYMPK, J, JC, JCH,
$ JKL, JKU, JR, K, LLB, MINLDA, MNMIN, MR, NC,
$ UUB
DOUBLE PRECISION ALPHA, ANGLE, C, DUMMY, EXTRA, S, TEMP
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLARND
EXTERNAL LSAME, DLARND
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLAGGE, DLAGSY, DLAROT, DLARTG, DLASET,
$ DLATM1, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, COS, DBLE, MAX, MIN, MOD, SIN
* ..
* .. Executable Statements ..
*
* 1) Decode and Test the input parameters.
* Initialize flags & seed.
*
INFO = 0
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
* Decode DIST
*
IF( LSAME( DIST, 'U' ) ) THEN
IDIST = 1
ELSE IF( LSAME( DIST, 'S' ) ) THEN
IDIST = 2
ELSE IF( LSAME( DIST, 'N' ) ) THEN
IDIST = 3
ELSE
IDIST = -1
END IF
*
* Decode SYM
*
IF( LSAME( SYM, 'N' ) ) THEN
ISYM = 1
IRSIGN = 0
ELSE IF( LSAME( SYM, 'P' ) ) THEN
ISYM = 2
IRSIGN = 0
ELSE IF( LSAME( SYM, 'S' ) ) THEN
ISYM = 2
IRSIGN = 1
ELSE IF( LSAME( SYM, 'H' ) ) THEN
ISYM = 2
IRSIGN = 1
ELSE
ISYM = -1
END IF
*
* Decode PACK
*
ISYMPK = 0
IF( LSAME( PACK, 'N' ) ) THEN
IPACK = 0
ELSE IF( LSAME( PACK, 'U' ) ) THEN
IPACK = 1
ISYMPK = 1
ELSE IF( LSAME( PACK, 'L' ) ) THEN
IPACK = 2
ISYMPK = 1
ELSE IF( LSAME( PACK, 'C' ) ) THEN
IPACK = 3
ISYMPK = 2
ELSE IF( LSAME( PACK, 'R' ) ) THEN
IPACK = 4
ISYMPK = 3
ELSE IF( LSAME( PACK, 'B' ) ) THEN
IPACK = 5
ISYMPK = 3
ELSE IF( LSAME( PACK, 'Q' ) ) THEN
IPACK = 6
ISYMPK = 2
ELSE IF( LSAME( PACK, 'Z' ) ) THEN
IPACK = 7
ELSE
IPACK = -1
END IF
*
* Set certain internal parameters
*
MNMIN = MIN( M, N )
LLB = MIN( KL, M-1 )
UUB = MIN( KU, N-1 )
MR = MIN( M, N+LLB )
NC = MIN( N, M+UUB )
*
IF( IPACK.EQ.5 .OR. IPACK.EQ.6 ) THEN
MINLDA = UUB + 1
ELSE IF( IPACK.EQ.7 ) THEN
MINLDA = LLB + UUB + 1
ELSE
MINLDA = M
END IF
*
* Use Givens rotation method if bandwidth small enough,
* or if LDA is too small to store the matrix unpacked.
*
GIVENS = .FALSE.
IF( ISYM.EQ.1 ) THEN
IF( DBLE( LLB+UUB ).LT.0.3D0*DBLE( MAX( 1, MR+NC ) ) )
$ GIVENS = .TRUE.
ELSE
IF( 2*LLB.LT.M )
$ GIVENS = .TRUE.
END IF
IF( LDA.LT.M .AND. LDA.GE.MINLDA )
$ GIVENS = .TRUE.
*
* Set INFO if an error
*
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( M.NE.N .AND. ISYM.NE.1 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( IDIST.EQ.-1 ) THEN
INFO = -3
ELSE IF( ISYM.EQ.-1 ) THEN
INFO = -5
ELSE IF( ABS( MODE ).GT.6 ) THEN
INFO = -7
ELSE IF( ( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) .AND. COND.LT.ONE )
$ THEN
INFO = -8
ELSE IF( KL.LT.0 ) THEN
INFO = -10
ELSE IF( KU.LT.0 .OR. ( ISYM.NE.1 .AND. KL.NE.KU ) ) THEN
INFO = -11
ELSE IF( IPACK.EQ.-1 .OR. ( ISYMPK.EQ.1 .AND. ISYM.EQ.1 ) .OR.
$ ( ISYMPK.EQ.2 .AND. ISYM.EQ.1 .AND. KL.GT.0 ) .OR.
$ ( ISYMPK.EQ.3 .AND. ISYM.EQ.1 .AND. KU.GT.0 ) .OR.
$ ( ISYMPK.NE.0 .AND. M.NE.N ) ) THEN
INFO = -12
ELSE IF( LDA.LT.MAX( 1, MINLDA ) ) THEN
INFO = -14
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLATMS', -INFO )
RETURN
END IF
*
* Initialize random number generator
*
DO 10 I = 1, 4
ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 )
10 CONTINUE
*
IF( MOD( ISEED( 4 ), 2 ).NE.1 )
$ ISEED( 4 ) = ISEED( 4 ) + 1
*
* 2) Set up D if indicated.
*
* Compute D according to COND and MODE
*
CALL DLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, MNMIN, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 1
RETURN
END IF
*
* Choose Top-Down if D is (apparently) increasing,
* Bottom-Up if D is (apparently) decreasing.
*
IF( ABS( D( 1 ) ).LE.ABS( D( MNMIN ) ) ) THEN
TOPDWN = .TRUE.
ELSE
TOPDWN = .FALSE.
END IF
*
IF( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) THEN
*
* Scale by DMAX
*
TEMP = ABS( D( 1 ) )
DO 20 I = 2, MNMIN
TEMP = MAX( TEMP, ABS( D( I ) ) )
20 CONTINUE
*
IF( TEMP.GT.ZERO ) THEN
ALPHA = DMAX / TEMP
ELSE
INFO = 2
RETURN
END IF
*
CALL DSCAL( MNMIN, ALPHA, D, 1 )
*
END IF
*
* 3) Generate Banded Matrix using Givens rotations.
* Also the special case of UUB=LLB=0
*
* Compute Addressing constants to cover all
* storage formats. Whether GE, SY, GB, or SB,
* upper or lower triangle or both,
* the (i,j)-th element is in
* A( i - ISKEW*j + IOFFST, j )
*
IF( IPACK.GT.4 ) THEN
ILDA = LDA - 1
ISKEW = 1
IF( IPACK.GT.5 ) THEN
IOFFST = UUB + 1
ELSE
IOFFST = 1
END IF
ELSE
ILDA = LDA
ISKEW = 0
IOFFST = 0
END IF
*
* IPACKG is the format that the matrix is generated in. If this is
* different from IPACK, then the matrix must be repacked at the
* end. It also signals how to compute the norm, for scaling.
*
IPACKG = 0
CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
*
* Diagonal Matrix -- We are done, unless it
* is to be stored SP/PP/TP (PACK='R' or 'C')
*
IF( LLB.EQ.0 .AND. UUB.EQ.0 ) THEN
CALL DCOPY( MNMIN, D, 1, A( 1-ISKEW+IOFFST, 1 ), ILDA+1 )
IF( IPACK.LE.2 .OR. IPACK.GE.5 )
$ IPACKG = IPACK
*
ELSE IF( GIVENS ) THEN
*
* Check whether to use Givens rotations,
* Householder transformations, or nothing.
*
IF( ISYM.EQ.1 ) THEN
*
* Non-symmetric -- A = U D V
*
IF( IPACK.GT.4 ) THEN
IPACKG = IPACK
ELSE
IPACKG = 0
END IF
*
CALL DCOPY( MNMIN, D, 1, A( 1-ISKEW+IOFFST, 1 ), ILDA+1 )
*
IF( TOPDWN ) THEN
JKL = 0
DO 50 JKU = 1, UUB
*
* Transform from bandwidth JKL, JKU-1 to JKL, JKU
*
* Last row actually rotated is M
* Last column actually rotated is MIN( M+JKU, N )
*
DO 40 JR = 1, MIN( M+JKU, N ) + JKL - 1
EXTRA = ZERO
ANGLE = TWOPI*DLARND( 1, ISEED )
C = COS( ANGLE )
S = SIN( ANGLE )
ICOL = MAX( 1, JR-JKL )
IF( JR.LT.M ) THEN
IL = MIN( N, JR+JKU ) + 1 - ICOL
CALL DLAROT( .TRUE., JR.GT.JKL, .FALSE., IL, C,
$ S, A( JR-ISKEW*ICOL+IOFFST, ICOL ),
$ ILDA, EXTRA, DUMMY )
END IF
*
* Chase "EXTRA" back up
*
IR = JR
IC = ICOL
DO 30 JCH = JR - JKL, 1, -JKL - JKU
IF( IR.LT.M ) THEN
CALL DLARTG( A( IR+1-ISKEW*( IC+1 )+IOFFST,
$ IC+1 ), EXTRA, C, S, DUMMY )
END IF
IROW = MAX( 1, JCH-JKU )
IL = IR + 2 - IROW
TEMP = ZERO
ILTEMP = JCH.GT.JKU
CALL DLAROT( .FALSE., ILTEMP, .TRUE., IL, C, -S,
$ A( IROW-ISKEW*IC+IOFFST, IC ),
$ ILDA, TEMP, EXTRA )
IF( ILTEMP ) THEN
CALL DLARTG( A( IROW+1-ISKEW*( IC+1 )+IOFFST,
$ IC+1 ), TEMP, C, S, DUMMY )
ICOL = MAX( 1, JCH-JKU-JKL )
IL = IC + 2 - ICOL
EXTRA = ZERO
CALL DLAROT( .TRUE., JCH.GT.JKU+JKL, .TRUE.,
$ IL, C, -S, A( IROW-ISKEW*ICOL+
$ IOFFST, ICOL ), ILDA, EXTRA,
$ TEMP )
IC = ICOL
IR = IROW
END IF
30 CONTINUE
40 CONTINUE
50 CONTINUE
*
JKU = UUB
DO 80 JKL = 1, LLB
*
* Transform from bandwidth JKL-1, JKU to JKL, JKU
*
DO 70 JC = 1, MIN( N+JKL, M ) + JKU - 1
EXTRA = ZERO
ANGLE = TWOPI*DLARND( 1, ISEED )
C = COS( ANGLE )
S = SIN( ANGLE )
IROW = MAX( 1, JC-JKU )
IF( JC.LT.N ) THEN
IL = MIN( M, JC+JKL ) + 1 - IROW
CALL DLAROT( .FALSE., JC.GT.JKU, .FALSE., IL, C,
$ S, A( IROW-ISKEW*JC+IOFFST, JC ),
$ ILDA, EXTRA, DUMMY )
END IF
*
* Chase "EXTRA" back up
*
IC = JC
IR = IROW
DO 60 JCH = JC - JKU, 1, -JKL - JKU
IF( IC.LT.N ) THEN
CALL DLARTG( A( IR+1-ISKEW*( IC+1 )+IOFFST,
$ IC+1 ), EXTRA, C, S, DUMMY )
END IF
ICOL = MAX( 1, JCH-JKL )
IL = IC + 2 - ICOL
TEMP = ZERO
ILTEMP = JCH.GT.JKL
CALL DLAROT( .TRUE., ILTEMP, .TRUE., IL, C, -S,
$ A( IR-ISKEW*ICOL+IOFFST, ICOL ),
$ ILDA, TEMP, EXTRA )
IF( ILTEMP ) THEN
CALL DLARTG( A( IR+1-ISKEW*( ICOL+1 )+IOFFST,
$ ICOL+1 ), TEMP, C, S, DUMMY )
IROW = MAX( 1, JCH-JKL-JKU )
IL = IR + 2 - IROW
EXTRA = ZERO
CALL DLAROT( .FALSE., JCH.GT.JKL+JKU, .TRUE.,
$ IL, C, -S, A( IROW-ISKEW*ICOL+
$ IOFFST, ICOL ), ILDA, EXTRA,
$ TEMP )
IC = ICOL
IR = IROW
END IF
60 CONTINUE
70 CONTINUE
80 CONTINUE
*
ELSE
*
* Bottom-Up -- Start at the bottom right.
*
JKL = 0
DO 110 JKU = 1, UUB
*
* Transform from bandwidth JKL, JKU-1 to JKL, JKU
*
* First row actually rotated is M
* First column actually rotated is MIN( M+JKU, N )
*
IENDCH = MIN( M, N+JKL ) - 1
DO 100 JC = MIN( M+JKU, N ) - 1, 1 - JKL, -1
EXTRA = ZERO
ANGLE = TWOPI*DLARND( 1, ISEED )
C = COS( ANGLE )
S = SIN( ANGLE )
IROW = MAX( 1, JC-JKU+1 )
IF( JC.GT.0 ) THEN
IL = MIN( M, JC+JKL+1 ) + 1 - IROW
CALL DLAROT( .FALSE., .FALSE., JC+JKL.LT.M, IL,
$ C, S, A( IROW-ISKEW*JC+IOFFST,
$ JC ), ILDA, DUMMY, EXTRA )
END IF
*
* Chase "EXTRA" back down
*
IC = JC
DO 90 JCH = JC + JKL, IENDCH, JKL + JKU
ILEXTR = IC.GT.0
IF( ILEXTR ) THEN
CALL DLARTG( A( JCH-ISKEW*IC+IOFFST, IC ),
$ EXTRA, C, S, DUMMY )
END IF
IC = MAX( 1, IC )
ICOL = MIN( N-1, JCH+JKU )
ILTEMP = JCH + JKU.LT.N
TEMP = ZERO
CALL DLAROT( .TRUE., ILEXTR, ILTEMP, ICOL+2-IC,
$ C, S, A( JCH-ISKEW*IC+IOFFST, IC ),
$ ILDA, EXTRA, TEMP )
IF( ILTEMP ) THEN
CALL DLARTG( A( JCH-ISKEW*ICOL+IOFFST,
$ ICOL ), TEMP, C, S, DUMMY )
IL = MIN( IENDCH, JCH+JKL+JKU ) + 2 - JCH
EXTRA = ZERO
CALL DLAROT( .FALSE., .TRUE.,
$ JCH+JKL+JKU.LE.IENDCH, IL, C, S,
$ A( JCH-ISKEW*ICOL+IOFFST,
$ ICOL ), ILDA, TEMP, EXTRA )
IC = ICOL
END IF
90 CONTINUE
100 CONTINUE
110 CONTINUE
*
JKU = UUB
DO 140 JKL = 1, LLB
*
* Transform from bandwidth JKL-1, JKU to JKL, JKU
*
* First row actually rotated is MIN( N+JKL, M )
* First column actually rotated is N
*
IENDCH = MIN( N, M+JKU ) - 1
DO 130 JR = MIN( N+JKL, M ) - 1, 1 - JKU, -1
EXTRA = ZERO
ANGLE = TWOPI*DLARND( 1, ISEED )
C = COS( ANGLE )
S = SIN( ANGLE )
ICOL = MAX( 1, JR-JKL+1 )
IF( JR.GT.0 ) THEN
IL = MIN( N, JR+JKU+1 ) + 1 - ICOL
CALL DLAROT( .TRUE., .FALSE., JR+JKU.LT.N, IL,
$ C, S, A( JR-ISKEW*ICOL+IOFFST,
$ ICOL ), ILDA, DUMMY, EXTRA )
END IF
*
* Chase "EXTRA" back down
*
IR = JR
DO 120 JCH = JR + JKU, IENDCH, JKL + JKU
ILEXTR = IR.GT.0
IF( ILEXTR ) THEN
CALL DLARTG( A( IR-ISKEW*JCH+IOFFST, JCH ),
$ EXTRA, C, S, DUMMY )
END IF
IR = MAX( 1, IR )
IROW = MIN( M-1, JCH+JKL )
ILTEMP = JCH + JKL.LT.M
TEMP = ZERO
CALL DLAROT( .FALSE., ILEXTR, ILTEMP, IROW+2-IR,
$ C, S, A( IR-ISKEW*JCH+IOFFST,
$ JCH ), ILDA, EXTRA, TEMP )
IF( ILTEMP ) THEN
CALL DLARTG( A( IROW-ISKEW*JCH+IOFFST, JCH ),
$ TEMP, C, S, DUMMY )
IL = MIN( IENDCH, JCH+JKL+JKU ) + 2 - JCH
EXTRA = ZERO
CALL DLAROT( .TRUE., .TRUE.,
$ JCH+JKL+JKU.LE.IENDCH, IL, C, S,
$ A( IROW-ISKEW*JCH+IOFFST, JCH ),
$ ILDA, TEMP, EXTRA )
IR = IROW
END IF
120 CONTINUE
130 CONTINUE
140 CONTINUE
END IF
*
ELSE
*
* Symmetric -- A = U D U'
*
IPACKG = IPACK
IOFFG = IOFFST
*
IF( TOPDWN ) THEN
*
* Top-Down -- Generate Upper triangle only
*
IF( IPACK.GE.5 ) THEN
IPACKG = 6
IOFFG = UUB + 1
ELSE
IPACKG = 1
END IF
CALL DCOPY( MNMIN, D, 1, A( 1-ISKEW+IOFFG, 1 ), ILDA+1 )
*
DO 170 K = 1, UUB
DO 160 JC = 1, N - 1
IROW = MAX( 1, JC-K )
IL = MIN( JC+1, K+2 )
EXTRA = ZERO
TEMP = A( JC-ISKEW*( JC+1 )+IOFFG, JC+1 )
ANGLE = TWOPI*DLARND( 1, ISEED )
C = COS( ANGLE )
S = SIN( ANGLE )
CALL DLAROT( .FALSE., JC.GT.K, .TRUE., IL, C, S,
$ A( IROW-ISKEW*JC+IOFFG, JC ), ILDA,
$ EXTRA, TEMP )
CALL DLAROT( .TRUE., .TRUE., .FALSE.,
$ MIN( K, N-JC )+1, C, S,
$ A( ( 1-ISKEW )*JC+IOFFG, JC ), ILDA,
$ TEMP, DUMMY )
*
* Chase EXTRA back up the matrix
*
ICOL = JC
DO 150 JCH = JC - K, 1, -K
CALL DLARTG( A( JCH+1-ISKEW*( ICOL+1 )+IOFFG,
$ ICOL+1 ), EXTRA, C, S, DUMMY )
TEMP = A( JCH-ISKEW*( JCH+1 )+IOFFG, JCH+1 )
CALL DLAROT( .TRUE., .TRUE., .TRUE., K+2, C, -S,
$ A( ( 1-ISKEW )*JCH+IOFFG, JCH ),
$ ILDA, TEMP, EXTRA )
IROW = MAX( 1, JCH-K )
IL = MIN( JCH+1, K+2 )
EXTRA = ZERO
CALL DLAROT( .FALSE., JCH.GT.K, .TRUE., IL, C,
$ -S, A( IROW-ISKEW*JCH+IOFFG, JCH ),
$ ILDA, EXTRA, TEMP )
ICOL = JCH
150 CONTINUE
160 CONTINUE
170 CONTINUE
*
* If we need lower triangle, copy from upper. Note that
* the order of copying is chosen to work for 'q' -> 'b'
*
IF( IPACK.NE.IPACKG .AND. IPACK.NE.3 ) THEN
DO 190 JC = 1, N
IROW = IOFFST - ISKEW*JC
DO 180 JR = JC, MIN( N, JC+UUB )
A( JR+IROW, JC ) = A( JC-ISKEW*JR+IOFFG, JR )
180 CONTINUE
190 CONTINUE
IF( IPACK.EQ.5 ) THEN
DO 210 JC = N - UUB + 1, N
DO 200 JR = N + 2 - JC, UUB + 1
A( JR, JC ) = ZERO
200 CONTINUE
210 CONTINUE
END IF
IF( IPACKG.EQ.6 ) THEN
IPACKG = IPACK
ELSE
IPACKG = 0
END IF
END IF
ELSE
*
* Bottom-Up -- Generate Lower triangle only
*
IF( IPACK.GE.5 ) THEN
IPACKG = 5
IF( IPACK.EQ.6 )
$ IOFFG = 1
ELSE
IPACKG = 2
END IF
CALL DCOPY( MNMIN, D, 1, A( 1-ISKEW+IOFFG, 1 ), ILDA+1 )
*
DO 240 K = 1, UUB
DO 230 JC = N - 1, 1, -1
IL = MIN( N+1-JC, K+2 )
EXTRA = ZERO
TEMP = A( 1+( 1-ISKEW )*JC+IOFFG, JC )
ANGLE = TWOPI*DLARND( 1, ISEED )
C = COS( ANGLE )
S = -SIN( ANGLE )
CALL DLAROT( .FALSE., .TRUE., N-JC.GT.K, IL, C, S,
$ A( ( 1-ISKEW )*JC+IOFFG, JC ), ILDA,
$ TEMP, EXTRA )
ICOL = MAX( 1, JC-K+1 )
CALL DLAROT( .TRUE., .FALSE., .TRUE., JC+2-ICOL, C,
$ S, A( JC-ISKEW*ICOL+IOFFG, ICOL ),
$ ILDA, DUMMY, TEMP )
*
* Chase EXTRA back down the matrix
*
ICOL = JC
DO 220 JCH = JC + K, N - 1, K
CALL DLARTG( A( JCH-ISKEW*ICOL+IOFFG, ICOL ),
$ EXTRA, C, S, DUMMY )
TEMP = A( 1+( 1-ISKEW )*JCH+IOFFG, JCH )
CALL DLAROT( .TRUE., .TRUE., .TRUE., K+2, C, S,
$ A( JCH-ISKEW*ICOL+IOFFG, ICOL ),
$ ILDA, EXTRA, TEMP )
IL = MIN( N+1-JCH, K+2 )
EXTRA = ZERO
CALL DLAROT( .FALSE., .TRUE., N-JCH.GT.K, IL, C,
$ S, A( ( 1-ISKEW )*JCH+IOFFG, JCH ),
$ ILDA, TEMP, EXTRA )
ICOL = JCH
220 CONTINUE
230 CONTINUE
240 CONTINUE
*
* If we need upper triangle, copy from lower. Note that
* the order of copying is chosen to work for 'b' -> 'q'
*
IF( IPACK.NE.IPACKG .AND. IPACK.NE.4 ) THEN
DO 260 JC = N, 1, -1
IROW = IOFFST - ISKEW*JC
DO 250 JR = JC, MAX( 1, JC-UUB ), -1
A( JR+IROW, JC ) = A( JC-ISKEW*JR+IOFFG, JR )
250 CONTINUE
260 CONTINUE
IF( IPACK.EQ.6 ) THEN
DO 280 JC = 1, UUB
DO 270 JR = 1, UUB + 1 - JC
A( JR, JC ) = ZERO
270 CONTINUE
280 CONTINUE
END IF
IF( IPACKG.EQ.5 ) THEN
IPACKG = IPACK
ELSE
IPACKG = 0
END IF
END IF
END IF
END IF
*
ELSE
*
* 4) Generate Banded Matrix by first
* Rotating by random Unitary matrices,
* then reducing the bandwidth using Householder
* transformations.
*
* Note: we should get here only if LDA .ge. N
*
IF( ISYM.EQ.1 ) THEN
*
* Non-symmetric -- A = U D V
*
CALL DLAGGE( MR, NC, LLB, UUB, D, A, LDA, ISEED, WORK,
$ IINFO )
ELSE
*
* Symmetric -- A = U D U'
*
CALL DLAGSY( M, LLB, D, A, LDA, ISEED, WORK, IINFO )
*
END IF
IF( IINFO.NE.0 ) THEN
INFO = 3
RETURN
END IF
END IF
*
* 5) Pack the matrix
*
IF( IPACK.NE.IPACKG ) THEN
IF( IPACK.EQ.1 ) THEN
*
* 'U' -- Upper triangular, not packed
*
DO 300 J = 1, M
DO 290 I = J + 1, M
A( I, J ) = ZERO
290 CONTINUE
300 CONTINUE
*
ELSE IF( IPACK.EQ.2 ) THEN
*
* 'L' -- Lower triangular, not packed
*
DO 320 J = 2, M
DO 310 I = 1, J - 1
A( I, J ) = ZERO
310 CONTINUE
320 CONTINUE
*
ELSE IF( IPACK.EQ.3 ) THEN
*
* 'C' -- Upper triangle packed Columnwise.
*
ICOL = 1
IROW = 0
DO 340 J = 1, M
DO 330 I = 1, J
IROW = IROW + 1
IF( IROW.GT.LDA ) THEN
IROW = 1
ICOL = ICOL + 1
END IF
A( IROW, ICOL ) = A( I, J )
330 CONTINUE
340 CONTINUE
*
ELSE IF( IPACK.EQ.4 ) THEN
*
* 'R' -- Lower triangle packed Columnwise.
*
ICOL = 1
IROW = 0
DO 360 J = 1, M
DO 350 I = J, M
IROW = IROW + 1
IF( IROW.GT.LDA ) THEN
IROW = 1
ICOL = ICOL + 1
END IF
A( IROW, ICOL ) = A( I, J )
350 CONTINUE
360 CONTINUE
*
ELSE IF( IPACK.GE.5 ) THEN
*
* 'B' -- The lower triangle is packed as a band matrix.
* 'Q' -- The upper triangle is packed as a band matrix.
* 'Z' -- The whole matrix is packed as a band matrix.
*
IF( IPACK.EQ.5 )
$ UUB = 0
IF( IPACK.EQ.6 )
$ LLB = 0
*
DO 380 J = 1, UUB
DO 370 I = MIN( J+LLB, M ), 1, -1
A( I-J+UUB+1, J ) = A( I, J )
370 CONTINUE
380 CONTINUE
*
DO 400 J = UUB + 2, N
DO 390 I = J - UUB, MIN( J+LLB, M )
A( I-J+UUB+1, J ) = A( I, J )
390 CONTINUE
400 CONTINUE
END IF
*
* If packed, zero out extraneous elements.
*
* Symmetric/Triangular Packed --
* zero out everything after A(IROW,ICOL)
*
IF( IPACK.EQ.3 .OR. IPACK.EQ.4 ) THEN
DO 420 JC = ICOL, M
DO 410 JR = IROW + 1, LDA
A( JR, JC ) = ZERO
410 CONTINUE
IROW = 0
420 CONTINUE
*
ELSE IF( IPACK.GE.5 ) THEN
*
* Packed Band --
* 1st row is now in A( UUB+2-j, j), zero above it
* m-th row is now in A( M+UUB-j,j), zero below it
* last non-zero diagonal is now in A( UUB+LLB+1,j ),
* zero below it, too.
*
IR1 = UUB + LLB + 2
IR2 = UUB + M + 2
DO 450 JC = 1, N
DO 430 JR = 1, UUB + 1 - JC
A( JR, JC ) = ZERO
430 CONTINUE
DO 440 JR = MAX( 1, MIN( IR1, IR2-JC ) ), LDA
A( JR, JC ) = ZERO
440 CONTINUE
450 CONTINUE
END IF
END IF
*
RETURN
*
* End of DLATMS
*
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/blas2/ 0000755 0001750 0001750 00000000000 11734055023 022217 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/blas2/Makefile_javasrc 0000644 0001750 0001750 00000002633 10616163233 025375 0 ustar osallou osallou .SUFFIXES: .f .java
ROOT=../../..
include $(ROOT)/make.def
tester: $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(BLAS2TEST_IDX) $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
/bin/rm -f `find $(OUTDIR) -name "*.class"`
mkdir -p $(JAVASRC_OUTDIR)
$(JAVAC) -classpath .:$(JAVASRC_OUTDIR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) -d $(JAVASRC_OUTDIR) $(OUTDIR)/$(BLASTEST_PDIR)/*.java
/bin/rm -f $(JAVASRC_OUTDIR)/$(BLASTEST_PDIR)/*.old
$(JAVAB) $(JAVASRC_OUTDIR)/$(BLASTEST_PDIR)/*.class
/bin/rm -f $(BLAS2TEST_JAR)
cd $(JAVASRC_OUTDIR); $(JAR) cvf ../$(BLAS2TEST_JAR) `find . -name "*.class"`
$(JAR) uvf $(BLAS2TEST_JAR) `find org -name "*.class"`
$(ROOT)/$(BLAS2TEST_IDX): dblat2.f
$(MAKE) nojar
$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):
cd $(ROOT)/$(BLAS_DIR); $(MAKE) -f Makefile_javasrc
$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):
cd $(ROOT)/$(UTIL_DIR); $(MAKE)
runtest: tester
$(JAVA) $(JFLAGS) -cp .:$(BLAS2TEST_JAR):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR) $(BLASTEST_PACKAGE).Dblat2 < dblat2.in
verify: $(ROOT)/$(BLAS2TEST_IDX)
cd $(JAVASRC_OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:..:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR) $(VERIFY) $(BLASTEST_PDIR)/*.class
clean:
/bin/rm -rf *.java *.class *.f2j org $(OUTDIR) $(JAVASRC_OUTDIR) $(BLAS2TEST_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/blas2/Makefile 0000644 0001750 0001750 00000002531 10616163233 023661 0 ustar osallou osallou .SUFFIXES: .f .java
ROOT=../../..
include $(ROOT)/make.def
XERBLAFLAGS= -c .:$(ROOT)/$(BLAS_OBJ) -p $(ERR_PACKAGE)
F2JFLAGS=-c .:$(ROOT)/$(BLAS_OBJ) -p $(BLASTEST_PACKAGE) -o $(OUTDIR) $(STATIC)
tester: $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(BLAS2TEST_IDX) $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
/bin/rm -f $(BLAS2TEST_JAR)
cd $(OUTDIR); $(JAR) cvf0 ../$(BLAS2TEST_JAR) `find . -name "*.class"`
$(JAR) uvf0 $(BLAS2TEST_JAR) `find org -name "*.class"`
nojar: $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(BLAS2TEST_IDX) $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
$(ROOT)/$(BLAS2TEST_IDX): dblat2.f
$(F2J) $(XERBLAFLAGS) xerbla.f > /dev/null
$(F2J) $(F2JFLAGS) $< > /dev/null
$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):
cd $(ROOT)/$(BLAS_DIR); $(MAKE)
$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):
cd $(ROOT)/$(UTIL_DIR); $(MAKE)
runtest: tester
$(JAVA) $(JFLAGS) -cp .:$(BLAS2TEST_JAR):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR) $(BLASTEST_PACKAGE).Dblat2 < dblat2.in
srctest:
$(MAKE) -f Makefile_javasrc
verify: $(ROOT)/$(BLAS2TEST_IDX)
cd $(OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:..:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR) $(VERIFY) $(BLASTEST_PDIR)/*.class
clean:
/bin/rm -rf *.java *.class *.f2j org $(OUTDIR) $(JAVASRC_OUTDIR) $(BLAS2TEST_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/blas2/dblat2.f 0000644 0001750 0001750 00000326621 10616163233 023551 0 ustar osallou osallou PROGRAM DBLAT2
*
* Test program for the DOUBLE PRECISION Level 2 Blas.
*
* The program must be driven by a short data file. The first 18 records
* of the file are read using list-directed input, the last 16 records
* are read using the format ( A6, L2 ). An annotated example of a data
* file can be obtained by deleting the first 3 characters from the
* following 34 lines:
* 'dblat2.out' NAME OF SUMMARY OUTPUT FILE
* 6 UNIT NUMBER OF SUMMARY FILE
* 'DBLAT2.SNAP' NAME OF SNAPSHOT OUTPUT FILE
* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
* F LOGICAL FLAG, T TO STOP ON FAILURES.
* T LOGICAL FLAG, T TO TEST ERROR EXITS.
* 16.0 THRESHOLD VALUE OF TEST RATIO
* 6 NUMBER OF VALUES OF N
* 0 1 2 3 5 9 VALUES OF N
* 4 NUMBER OF VALUES OF K
* 0 1 2 4 VALUES OF K
* 4 NUMBER OF VALUES OF INCX AND INCY
* 1 2 -1 -2 VALUES OF INCX AND INCY
* 3 NUMBER OF VALUES OF ALPHA
* 0.0 1.0 0.7 VALUES OF ALPHA
* 3 NUMBER OF VALUES OF BETA
* 0.0 1.0 0.9 VALUES OF BETAC
* DGEMV T PUT F FOR NO TEST. SAME COLUMNS.
* DGBMV T PUT F FOR NO TEST. SAME COLUMNS.
* DSYMV T PUT F FOR NO TEST. SAME COLUMNS.
* DSBMV T PUT F FOR NO TEST. SAME COLUMNS.
* DSPMV T PUT F FOR NO TEST. SAME COLUMNS.
* DTRMV T PUT F FOR NO TEST. SAME COLUMNS.
* DTBMV T PUT F FOR NO TEST. SAME COLUMNS.
* DTPMV T PUT F FOR NO TEST. SAME COLUMNS.
* DTRSV T PUT F FOR NO TEST. SAME COLUMNS.
* DTBSV T PUT F FOR NO TEST. SAME COLUMNS.
* DTPSV T PUT F FOR NO TEST. SAME COLUMNS.
* DGER T PUT F FOR NO TEST. SAME COLUMNS.
* DSYR T PUT F FOR NO TEST. SAME COLUMNS.
* DSPR T PUT F FOR NO TEST. SAME COLUMNS.
* DSYR2 T PUT F FOR NO TEST. SAME COLUMNS.
* DSPR2 T PUT F FOR NO TEST. SAME COLUMNS.
*
* See:
*
* Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J..
* An extended set of Fortran Basic Linear Algebra Subprograms.
*
* Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics
* and Computer Science Division, Argonne National Laboratory,
* 9700 South Cass Avenue, Argonne, Illinois 60439, US.
*
* Or
*
* NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms
* Group Ltd., NAG Central Office, 256 Banbury Road, Oxford
* OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st
* Street, Suite 100, Downers Grove, Illinois 60515-1263, USA.
*
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers
* can be run multiple times without deleting generated
* output files (susan)
*
* .. Parameters ..
INTEGER NIN
PARAMETER ( NIN = 5 )
INTEGER NSUBS
PARAMETER ( NSUBS = 16 )
DOUBLE PRECISION ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
INTEGER NMAX, INCMAX
PARAMETER ( NMAX = 65, INCMAX = 2 )
INTEGER NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX
PARAMETER ( NINMAX = 7, NIDMAX = 9, NKBMAX = 7,
$ NALMAX = 7, NBEMAX = 7 )
* .. Local Scalars ..
DOUBLE PRECISION EPS, ERR, THRESH
INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, NKB,
$ NOUT, NTRA
LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
$ TSTERR
CHARACTER*1 TRANS
CHARACTER*6 SNAMET
CHARACTER*32 SNAPS, SUMMRY
* .. Local Arrays ..
DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ),
$ ALF( NALMAX ), AS( NMAX*NMAX ), BET( NBEMAX ),
$ G( NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
$ XX( NMAX*INCMAX ), Y( NMAX ),
$ YS( NMAX*INCMAX ), YT( NMAX ),
$ YY( NMAX*INCMAX ), Z( 2*NMAX )
INTEGER IDIM( NIDMAX ), INC( NINMAX ), KB( NKBMAX )
LOGICAL LTEST( NSUBS )
CHARACTER*6 SNAMES( NSUBS )
* .. External Functions ..
DOUBLE PRECISION DDIFF
LOGICAL LDE
EXTERNAL DDIFF, LDE
* .. External Subroutines ..
EXTERNAL DCHK1, DCHK2, DCHK3, DCHK4, DCHK5, DCHK6,
$ DCHKE, DMVCH
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
COMMON /SRNAMC/SRNAMT
* .. Data statements ..
DATA SNAMES/'DGEMV ', 'DGBMV ', 'DSYMV ', 'DSBMV ',
$ 'DSPMV ', 'DTRMV ', 'DTBMV ', 'DTPMV ',
$ 'DTRSV ', 'DTBSV ', 'DTPSV ', 'DGER ',
$ 'DSYR ', 'DSPR ', 'DSYR2 ', 'DSPR2 '/
* .. Executable Statements ..
*
* Read name and unit number for summary output file and open file.
*
READ( NIN, FMT = * )SUMMRY
READ( NIN, FMT = * )NOUT
OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' )
NOUTC = NOUT
*
* Read name and unit number for snapshot output file and open file.
*
READ( NIN, FMT = * )SNAPS
READ( NIN, FMT = * )NTRA
TRACE = NTRA.GE.0
IF( TRACE )THEN
OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' )
END IF
* Read the flag that directs rewinding of the snapshot file.
READ( NIN, FMT = * )REWI
REWI = REWI.AND.TRACE
* Read the flag that directs stopping on any failure.
READ( NIN, FMT = * )SFATAL
* Read the flag that indicates whether error exits are to be tested.
READ( NIN, FMT = * )TSTERR
* Read the threshold value of the test ratio
READ( NIN, FMT = * )THRESH
*
* Read and check the parameter values for the tests.
*
* Values of N
READ( NIN, FMT = * )NIDIM
IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN
WRITE( NOUT, FMT = 9997 )'N', NIDMAX
GO TO 230
END IF
READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM )
DO 10 I = 1, NIDIM
IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN
WRITE( NOUT, FMT = 9996 )NMAX
GO TO 230
END IF
10 CONTINUE
* Values of K
READ( NIN, FMT = * )NKB
IF( NKB.LT.1.OR.NKB.GT.NKBMAX )THEN
WRITE( NOUT, FMT = 9997 )'K', NKBMAX
GO TO 230
END IF
READ( NIN, FMT = * )( KB( I ), I = 1, NKB )
DO 20 I = 1, NKB
IF( KB( I ).LT.0 )THEN
WRITE( NOUT, FMT = 9995 )
GO TO 230
END IF
20 CONTINUE
* Values of INCX and INCY
READ( NIN, FMT = * )NINC
IF( NINC.LT.1.OR.NINC.GT.NINMAX )THEN
WRITE( NOUT, FMT = 9997 )'INCX AND INCY', NINMAX
GO TO 230
END IF
READ( NIN, FMT = * )( INC( I ), I = 1, NINC )
DO 30 I = 1, NINC
IF( INC( I ).EQ.0.OR.ABS( INC( I ) ).GT.INCMAX )THEN
WRITE( NOUT, FMT = 9994 )INCMAX
GO TO 230
END IF
30 CONTINUE
* Values of ALPHA
READ( NIN, FMT = * )NALF
IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN
WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX
GO TO 230
END IF
READ( NIN, FMT = * )( ALF( I ), I = 1, NALF )
* Values of BETA
READ( NIN, FMT = * )NBET
IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN
WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX
GO TO 230
END IF
READ( NIN, FMT = * )( BET( I ), I = 1, NBET )
*
* Report values of parameters.
*
WRITE( NOUT, FMT = 9993 )
WRITE( NOUT, FMT = 9992 )( IDIM( I ), I = 1, NIDIM )
WRITE( NOUT, FMT = 9991 )( KB( I ), I = 1, NKB )
WRITE( NOUT, FMT = 9990 )( INC( I ), I = 1, NINC )
WRITE( NOUT, FMT = 9989 )( ALF( I ), I = 1, NALF )
WRITE( NOUT, FMT = 9988 )( BET( I ), I = 1, NBET )
IF( .NOT.TSTERR )THEN
WRITE( NOUT, FMT = * )
WRITE( NOUT, FMT = 9980 )
END IF
WRITE( NOUT, FMT = * )
WRITE( NOUT, FMT = 9999 )THRESH
WRITE( NOUT, FMT = * )
*
* Read names of subroutines and flags which indicate
* whether they are to be tested.
*
DO 40 I = 1, NSUBS
LTEST( I ) = .FALSE.
40 CONTINUE
50 READ( NIN, FMT = 9984, END = 80 )SNAMET, LTESTT
DO 60 I = 1, NSUBS
IF( SNAMET.EQ.SNAMES( I ) )
$ GO TO 70
60 CONTINUE
WRITE( NOUT, FMT = 9986 )SNAMET
STOP
70 LTEST( I ) = LTESTT
GO TO 50
*
80 CONTINUE
CLOSE ( NIN )
*
* Compute EPS (the machine precision).
*
EPS = ONE
90 CONTINUE
IF( DDIFF( ONE + EPS, ONE ).EQ.ZERO )
$ GO TO 100
EPS = HALF*EPS
GO TO 90
100 CONTINUE
EPS = EPS + EPS
WRITE( NOUT, FMT = 9998 )EPS
*
* Check the reliability of DMVCH using exact data.
*
N = MIN( 32, NMAX )
DO 120 J = 1, N
DO 110 I = 1, N
A( I, J ) = MAX( I - J + 1, 0 )
110 CONTINUE
X( J ) = J
Y( J ) = ZERO
120 CONTINUE
DO 130 J = 1, N
YY( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3
130 CONTINUE
* YY holds the exact result. On exit from DMVCH YT holds
* the result computed by DMVCH.
TRANS = 'N'
CALL DMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G,
$ YY, EPS, ERR, FATAL, NOUT, .TRUE. )
SAME = LDE( YY, YT, N )
IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR
STOP
END IF
TRANS = 'T'
CALL DMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G,
$ YY, EPS, ERR, FATAL, NOUT, .TRUE. )
SAME = LDE( YY, YT, N )
IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR
STOP
END IF
*
* Test each subroutine in turn.
*
DO 210 ISNUM = 1, NSUBS
WRITE( NOUT, FMT = * )
IF( .NOT.LTEST( ISNUM ) )THEN
* Subprogram is not to be tested.
WRITE( NOUT, FMT = 9983 )SNAMES( ISNUM )
ELSE
SRNAMT = SNAMES( ISNUM )
* Test error exits.
IF( TSTERR )THEN
CALL DCHKE( ISNUM, SNAMES( ISNUM ), NOUT )
WRITE( NOUT, FMT = * )
END IF
* Test computations.
INFOT = 0
OK = .TRUE.
FATAL = .FALSE.
GO TO ( 140, 140, 150, 150, 150, 160, 160,
$ 160, 160, 160, 160, 170, 180, 180,
$ 190, 190 )ISNUM
* Test DGEMV, 01, and DGBMV, 02.
140 CALL DCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF,
$ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS,
$ X, XX, XS, Y, YY, YS, YT, G )
GO TO 200
* Test DSYMV, 03, DSBMV, 04, and DSPMV, 05.
150 CALL DCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF,
$ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS,
$ X, XX, XS, Y, YY, YS, YT, G )
GO TO 200
* Test DTRMV, 06, DTBMV, 07, DTPMV, 08,
* DTRSV, 09, DTBSV, 10, and DTPSV, 11.
160 CALL DCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC,
$ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z )
GO TO 200
* Test DGER, 12.
170 CALL DCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
$ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
$ YT, G, Z )
GO TO 200
* Test DSYR, 13, and DSPR, 14.
180 CALL DCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
$ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
$ YT, G, Z )
GO TO 200
* Test DSYR2, 15, and DSPR2, 16.
190 CALL DCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
$ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
$ YT, G, Z )
*
200 IF( FATAL.AND.SFATAL )
$ GO TO 220
END IF
210 CONTINUE
WRITE( NOUT, FMT = 9982 )
GO TO 240
*
220 CONTINUE
WRITE( NOUT, FMT = 9981 )
GO TO 240
*
230 CONTINUE
WRITE( NOUT, FMT = 9987 )
*
240 CONTINUE
IF( TRACE )
$ CLOSE ( NTRA )
CLOSE ( NOUT )
STOP
*
9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES',
$ 'S THAN', F8.2 )
9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, D9.1 )
9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ',
$ 'THAN ', I2 )
9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 )
9995 FORMAT( ' VALUE OF K IS LESS THAN 0' )
9994 FORMAT( ' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ',
$ I2 )
9993 FORMAT( ' TESTS OF THE DOUBLE PRECISION LEVEL 2 BLAS', //' THE F',
$ 'OLLOWING PARAMETER VALUES WILL BE USED:' )
9992 FORMAT( ' FOR N ', 9I6 )
9991 FORMAT( ' FOR K ', 7I6 )
9990 FORMAT( ' FOR INCX AND INCY ', 7I6 )
9989 FORMAT( ' FOR ALPHA ', 7F6.1 )
9988 FORMAT( ' FOR BETA ', 7F6.1 )
9987 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
$ /' ******* TESTS ABANDONED *******' )
9986 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T',
$ 'ESTS ABANDONED *******' )
9985 FORMAT( ' ERROR IN DMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
$ 'ATED WRONGLY.', /' DMVCH WAS CALLED WITH TRANS = ', A1,
$ ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '.', /
$ ' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.'
$ , /' ******* TESTS ABANDONED *******' )
9984 FORMAT( A6, L2 )
9983 FORMAT( 1X, A6, ' WAS NOT TESTED' )
9982 FORMAT( /' END OF TESTS' )
9981 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
*
* End of DBLAT2.
*
END
SUBROUTINE DCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET,
$ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX,
$ XS, Y, YY, YS, YT, G )
*
* Tests DGEMV and DGBMV.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Parameters ..
DOUBLE PRECISION ZERO, HALF
PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0 )
* .. Scalar Arguments ..
DOUBLE PRECISION EPS, THRESH
INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
$ NOUT, NTRA
LOGICAL FATAL, REWI, TRACE
CHARACTER*6 SNAME
* .. Array Arguments ..
DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ),
$ X( NMAX ), XS( NMAX*INCMAX ),
$ XX( NMAX*INCMAX ), Y( NMAX ),
$ YS( NMAX*INCMAX ), YT( NMAX ),
$ YY( NMAX*INCMAX )
INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
* .. Local Scalars ..
DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL
INTEGER I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY,
$ INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA,
$ LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK,
$ NL, NS
LOGICAL BANDED, FULL, NULL, RESET, SAME, TRAN
CHARACTER*1 TRANS, TRANSS
CHARACTER*3 ICH
* .. Local Arrays ..
LOGICAL ISAME( 13 )
* .. External Functions ..
LOGICAL LDE, LDERES
EXTERNAL LDE, LDERES
* .. External Subroutines ..
EXTERNAL DGBMV, DGEMV, DMAKE, DMVCH
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
* .. Data statements ..
DATA ICH/'NTC'/
* .. Executable Statements ..
FULL = SNAME( 3: 3 ).EQ.'E'
BANDED = SNAME( 3: 3 ).EQ.'B'
* Define the number of arguments.
IF( FULL )THEN
NARGS = 11
ELSE IF( BANDED )THEN
NARGS = 13
END IF
*
NC = 0
RESET = .TRUE.
ERRMAX = ZERO
*
DO 120 IN = 1, NIDIM
N = IDIM( IN )
ND = N/2 + 1
*
DO 110 IM = 1, 2
IF( IM.EQ.1 )
$ M = MAX( N - ND, 0 )
IF( IM.EQ.2 )
$ M = MIN( N + ND, NMAX )
*
IF( BANDED )THEN
NK = NKB
ELSE
NK = 1
END IF
DO 100 IKU = 1, NK
IF( BANDED )THEN
KU = KB( IKU )
KL = MAX( KU - 1, 0 )
ELSE
KU = N - 1
KL = M - 1
END IF
* Set LDA to 1 more than minimum value if room.
IF( BANDED )THEN
LDA = KL + KU + 1
ELSE
LDA = M
END IF
IF( LDA.LT.NMAX )
$ LDA = LDA + 1
* Skip tests if not enough room.
IF( LDA.GT.NMAX )
$ GO TO 100
LAA = LDA*N
NULL = N.LE.0.OR.M.LE.0
*
* Generate the matrix A.
*
TRANSL = ZERO
CALL DMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, AA,
$ LDA, KL, KU, RESET, TRANSL )
*
DO 90 IC = 1, 3
TRANS = ICH( IC: IC )
TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
*
IF( TRAN )THEN
ML = N
NL = M
ELSE
ML = M
NL = N
END IF
*
DO 80 IX = 1, NINC
INCX = INC( IX )
LX = ABS( INCX )*NL
*
* Generate the vector X.
*
TRANSL = HALF
CALL DMAKE( 'GE', ' ', ' ', 1, NL, X, 1, XX,
$ ABS( INCX ), 0, NL - 1, RESET, TRANSL )
IF( NL.GT.1 )THEN
X( NL/2 ) = ZERO
XX( 1 + ABS( INCX )*( NL/2 - 1 ) ) = ZERO
END IF
*
DO 70 IY = 1, NINC
INCY = INC( IY )
LY = ABS( INCY )*ML
*
DO 60 IA = 1, NALF
ALPHA = ALF( IA )
*
DO 50 IB = 1, NBET
BETA = BET( IB )
*
* Generate the vector Y.
*
TRANSL = ZERO
CALL DMAKE( 'GE', ' ', ' ', 1, ML, Y, 1,
$ YY, ABS( INCY ), 0, ML - 1,
$ RESET, TRANSL )
*
NC = NC + 1
*
* Save every datum before calling the
* subroutine.
*
TRANSS = TRANS
MS = M
NS = N
KLS = KL
KUS = KU
ALS = ALPHA
DO 10 I = 1, LAA
AS( I ) = AA( I )
10 CONTINUE
LDAS = LDA
DO 20 I = 1, LX
XS( I ) = XX( I )
20 CONTINUE
INCXS = INCX
BLS = BETA
DO 30 I = 1, LY
YS( I ) = YY( I )
30 CONTINUE
INCYS = INCY
*
* Call the subroutine.
*
IF( FULL )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9994 )NC, SNAME,
$ TRANS, M, N, ALPHA, LDA, INCX, BETA,
$ INCY
IF( REWI )
$ REWIND NTRA
CALL DGEMV( TRANS, M, N, ALPHA, AA,
$ LDA, XX, INCX, BETA, YY,
$ INCY )
ELSE IF( BANDED )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9995 )NC, SNAME,
$ TRANS, M, N, KL, KU, ALPHA, LDA,
$ INCX, BETA, INCY
IF( REWI )
$ REWIND NTRA
CALL DGBMV( TRANS, M, N, KL, KU, ALPHA,
$ AA, LDA, XX, INCX, BETA,
$ YY, INCY )
END IF
*
* Check if error-exit was taken incorrectly.
*
IF( .NOT.OK )THEN
WRITE( NOUT, FMT = 9993 )
FATAL = .TRUE.
GO TO 130
END IF
*
* See what data changed inside subroutines.
*
ISAME( 1 ) = TRANS.EQ.TRANSS
ISAME( 2 ) = MS.EQ.M
ISAME( 3 ) = NS.EQ.N
IF( FULL )THEN
ISAME( 4 ) = ALS.EQ.ALPHA
ISAME( 5 ) = LDE( AS, AA, LAA )
ISAME( 6 ) = LDAS.EQ.LDA
ISAME( 7 ) = LDE( XS, XX, LX )
ISAME( 8 ) = INCXS.EQ.INCX
ISAME( 9 ) = BLS.EQ.BETA
IF( NULL )THEN
ISAME( 10 ) = LDE( YS, YY, LY )
ELSE
ISAME( 10 ) = LDERES( 'GE', ' ', 1,
$ ML, YS, YY,
$ ABS( INCY ) )
END IF
ISAME( 11 ) = INCYS.EQ.INCY
ELSE IF( BANDED )THEN
ISAME( 4 ) = KLS.EQ.KL
ISAME( 5 ) = KUS.EQ.KU
ISAME( 6 ) = ALS.EQ.ALPHA
ISAME( 7 ) = LDE( AS, AA, LAA )
ISAME( 8 ) = LDAS.EQ.LDA
ISAME( 9 ) = LDE( XS, XX, LX )
ISAME( 10 ) = INCXS.EQ.INCX
ISAME( 11 ) = BLS.EQ.BETA
IF( NULL )THEN
ISAME( 12 ) = LDE( YS, YY, LY )
ELSE
ISAME( 12 ) = LDERES( 'GE', ' ', 1,
$ ML, YS, YY,
$ ABS( INCY ) )
END IF
ISAME( 13 ) = INCYS.EQ.INCY
END IF
*
* If data was incorrectly changed, report
* and return.
*
SAME = .TRUE.
DO 40 I = 1, NARGS
SAME = SAME.AND.ISAME( I )
IF( .NOT.ISAME( I ) )
$ WRITE( NOUT, FMT = 9998 )I
40 CONTINUE
IF( .NOT.SAME )THEN
FATAL = .TRUE.
GO TO 130
END IF
*
IF( .NOT.NULL )THEN
*
* Check the result.
*
CALL DMVCH( TRANS, M, N, ALPHA, A,
$ NMAX, X, INCX, BETA, Y,
$ INCY, YT, G, YY, EPS, ERR,
$ FATAL, NOUT, .TRUE. )
ERRMAX = MAX( ERRMAX, ERR )
* If got really bad answer, report and
* return.
IF( FATAL )
$ GO TO 130
ELSE
* Avoid repeating tests with M.le.0 or
* N.le.0.
GO TO 110
END IF
*
50 CONTINUE
*
60 CONTINUE
*
70 CONTINUE
*
80 CONTINUE
*
90 CONTINUE
*
100 CONTINUE
*
110 CONTINUE
*
120 CONTINUE
*
* Report result.
*
IF( ERRMAX.LT.THRESH )THEN
WRITE( NOUT, FMT = 9999 )SNAME, NC
ELSE
WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
END IF
GO TO 140
*
130 CONTINUE
WRITE( NOUT, FMT = 9996 )SNAME
IF( FULL )THEN
WRITE( NOUT, FMT = 9994 )NC, SNAME, TRANS, M, N, ALPHA, LDA,
$ INCX, BETA, INCY
ELSE IF( BANDED )THEN
WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANS, M, N, KL, KU,
$ ALPHA, LDA, INCX, BETA, INCY
END IF
*
140 CONTINUE
RETURN
*
9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
$ 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
$ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
$ ' - SUSPECT *******' )
9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 4( I3, ',' ), F4.1,
$ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, ') .' )
9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), F4.1,
$ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2,
$ ') .' )
9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
* End of DCHK1.
*
END
SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET,
$ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX,
$ XS, Y, YY, YS, YT, G )
*
* Tests DSYMV, DSBMV and DSPMV.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Parameters ..
DOUBLE PRECISION ZERO, HALF
PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0 )
* .. Scalar Arguments ..
DOUBLE PRECISION EPS, THRESH
INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
$ NOUT, NTRA
LOGICAL FATAL, REWI, TRACE
CHARACTER*6 SNAME
* .. Array Arguments ..
DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ),
$ X( NMAX ), XS( NMAX*INCMAX ),
$ XX( NMAX*INCMAX ), Y( NMAX ),
$ YS( NMAX*INCMAX ), YT( NMAX ),
$ YY( NMAX*INCMAX )
INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
* .. Local Scalars ..
DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL
INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY,
$ INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY,
$ N, NARGS, NC, NK, NS
LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME
CHARACTER*1 UPLO, UPLOS
CHARACTER*2 ICH
* .. Local Arrays ..
LOGICAL ISAME( 13 )
* .. External Functions ..
LOGICAL LDE, LDERES
EXTERNAL LDE, LDERES
* .. External Subroutines ..
EXTERNAL DMAKE, DMVCH, DSBMV, DSPMV, DSYMV
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
* .. Data statements ..
DATA ICH/'UL'/
* .. Executable Statements ..
FULL = SNAME( 3: 3 ).EQ.'Y'
BANDED = SNAME( 3: 3 ).EQ.'B'
PACKED = SNAME( 3: 3 ).EQ.'P'
* Define the number of arguments.
IF( FULL )THEN
NARGS = 10
ELSE IF( BANDED )THEN
NARGS = 11
ELSE IF( PACKED )THEN
NARGS = 9
END IF
*
NC = 0
RESET = .TRUE.
ERRMAX = ZERO
*
DO 110 IN = 1, NIDIM
N = IDIM( IN )
*
IF( BANDED )THEN
NK = NKB
ELSE
NK = 1
END IF
DO 100 IK = 1, NK
IF( BANDED )THEN
K = KB( IK )
ELSE
K = N - 1
END IF
* Set LDA to 1 more than minimum value if room.
IF( BANDED )THEN
LDA = K + 1
ELSE
LDA = N
END IF
IF( LDA.LT.NMAX )
$ LDA = LDA + 1
* Skip tests if not enough room.
IF( LDA.GT.NMAX )
$ GO TO 100
IF( PACKED )THEN
LAA = ( N*( N + 1 ) )/2
ELSE
LAA = LDA*N
END IF
NULL = N.LE.0
*
DO 90 IC = 1, 2
UPLO = ICH( IC: IC )
*
* Generate the matrix A.
*
TRANSL = ZERO
CALL DMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, AA,
$ LDA, K, K, RESET, TRANSL )
*
DO 80 IX = 1, NINC
INCX = INC( IX )
LX = ABS( INCX )*N
*
* Generate the vector X.
*
TRANSL = HALF
CALL DMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX,
$ ABS( INCX ), 0, N - 1, RESET, TRANSL )
IF( N.GT.1 )THEN
X( N/2 ) = ZERO
XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
END IF
*
DO 70 IY = 1, NINC
INCY = INC( IY )
LY = ABS( INCY )*N
*
DO 60 IA = 1, NALF
ALPHA = ALF( IA )
*
DO 50 IB = 1, NBET
BETA = BET( IB )
*
* Generate the vector Y.
*
TRANSL = ZERO
CALL DMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY,
$ ABS( INCY ), 0, N - 1, RESET,
$ TRANSL )
*
NC = NC + 1
*
* Save every datum before calling the
* subroutine.
*
UPLOS = UPLO
NS = N
KS = K
ALS = ALPHA
DO 10 I = 1, LAA
AS( I ) = AA( I )
10 CONTINUE
LDAS = LDA
DO 20 I = 1, LX
XS( I ) = XX( I )
20 CONTINUE
INCXS = INCX
BLS = BETA
DO 30 I = 1, LY
YS( I ) = YY( I )
30 CONTINUE
INCYS = INCY
*
* Call the subroutine.
*
IF( FULL )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9993 )NC, SNAME,
$ UPLO, N, ALPHA, LDA, INCX, BETA, INCY
IF( REWI )
$ REWIND NTRA
CALL DSYMV( UPLO, N, ALPHA, AA, LDA, XX,
$ INCX, BETA, YY, INCY )
ELSE IF( BANDED )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9994 )NC, SNAME,
$ UPLO, N, K, ALPHA, LDA, INCX, BETA,
$ INCY
IF( REWI )
$ REWIND NTRA
CALL DSBMV( UPLO, N, K, ALPHA, AA, LDA,
$ XX, INCX, BETA, YY, INCY )
ELSE IF( PACKED )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9995 )NC, SNAME,
$ UPLO, N, ALPHA, INCX, BETA, INCY
IF( REWI )
$ REWIND NTRA
CALL DSPMV( UPLO, N, ALPHA, AA, XX, INCX,
$ BETA, YY, INCY )
END IF
*
* Check if error-exit was taken incorrectly.
*
IF( .NOT.OK )THEN
WRITE( NOUT, FMT = 9992 )
FATAL = .TRUE.
GO TO 120
END IF
*
* See what data changed inside subroutines.
*
ISAME( 1 ) = UPLO.EQ.UPLOS
ISAME( 2 ) = NS.EQ.N
IF( FULL )THEN
ISAME( 3 ) = ALS.EQ.ALPHA
ISAME( 4 ) = LDE( AS, AA, LAA )
ISAME( 5 ) = LDAS.EQ.LDA
ISAME( 6 ) = LDE( XS, XX, LX )
ISAME( 7 ) = INCXS.EQ.INCX
ISAME( 8 ) = BLS.EQ.BETA
IF( NULL )THEN
ISAME( 9 ) = LDE( YS, YY, LY )
ELSE
ISAME( 9 ) = LDERES( 'GE', ' ', 1, N,
$ YS, YY, ABS( INCY ) )
END IF
ISAME( 10 ) = INCYS.EQ.INCY
ELSE IF( BANDED )THEN
ISAME( 3 ) = KS.EQ.K
ISAME( 4 ) = ALS.EQ.ALPHA
ISAME( 5 ) = LDE( AS, AA, LAA )
ISAME( 6 ) = LDAS.EQ.LDA
ISAME( 7 ) = LDE( XS, XX, LX )
ISAME( 8 ) = INCXS.EQ.INCX
ISAME( 9 ) = BLS.EQ.BETA
IF( NULL )THEN
ISAME( 10 ) = LDE( YS, YY, LY )
ELSE
ISAME( 10 ) = LDERES( 'GE', ' ', 1, N,
$ YS, YY, ABS( INCY ) )
END IF
ISAME( 11 ) = INCYS.EQ.INCY
ELSE IF( PACKED )THEN
ISAME( 3 ) = ALS.EQ.ALPHA
ISAME( 4 ) = LDE( AS, AA, LAA )
ISAME( 5 ) = LDE( XS, XX, LX )
ISAME( 6 ) = INCXS.EQ.INCX
ISAME( 7 ) = BLS.EQ.BETA
IF( NULL )THEN
ISAME( 8 ) = LDE( YS, YY, LY )
ELSE
ISAME( 8 ) = LDERES( 'GE', ' ', 1, N,
$ YS, YY, ABS( INCY ) )
END IF
ISAME( 9 ) = INCYS.EQ.INCY
END IF
*
* If data was incorrectly changed, report and
* return.
*
SAME = .TRUE.
DO 40 I = 1, NARGS
SAME = SAME.AND.ISAME( I )
IF( .NOT.ISAME( I ) )
$ WRITE( NOUT, FMT = 9998 )I
40 CONTINUE
IF( .NOT.SAME )THEN
FATAL = .TRUE.
GO TO 120
END IF
*
IF( .NOT.NULL )THEN
*
* Check the result.
*
CALL DMVCH( 'N', N, N, ALPHA, A, NMAX, X,
$ INCX, BETA, Y, INCY, YT, G,
$ YY, EPS, ERR, FATAL, NOUT,
$ .TRUE. )
ERRMAX = MAX( ERRMAX, ERR )
* If got really bad answer, report and
* return.
IF( FATAL )
$ GO TO 120
ELSE
* Avoid repeating tests with N.le.0
GO TO 110
END IF
*
50 CONTINUE
*
60 CONTINUE
*
70 CONTINUE
*
80 CONTINUE
*
90 CONTINUE
*
100 CONTINUE
*
110 CONTINUE
*
* Report result.
*
IF( ERRMAX.LT.THRESH )THEN
WRITE( NOUT, FMT = 9999 )SNAME, NC
ELSE
WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
END IF
GO TO 130
*
120 CONTINUE
WRITE( NOUT, FMT = 9996 )SNAME
IF( FULL )THEN
WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, LDA, INCX,
$ BETA, INCY
ELSE IF( BANDED )THEN
WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, K, ALPHA, LDA,
$ INCX, BETA, INCY
ELSE IF( PACKED )THEN
WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, N, ALPHA, INCX,
$ BETA, INCY
END IF
*
130 CONTINUE
RETURN
*
9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
$ 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
$ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
$ ' - SUSPECT *******' )
9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', AP',
$ ', X,', I2, ',', F4.1, ', Y,', I2, ') .' )
9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), F4.1,
$ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2,
$ ') .' )
9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', A,',
$ I3, ', X,', I2, ',', F4.1, ', Y,', I2, ') .' )
9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
* End of DCHK2.
*
END
SUBROUTINE DCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$ FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX,
$ INCMAX, A, AA, AS, X, XX, XS, XT, G, Z )
*
* Tests DTRMV, DTBMV, DTPMV, DTRSV, DTBSV and DTPSV.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Parameters ..
DOUBLE PRECISION ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
* .. Scalar Arguments ..
DOUBLE PRECISION EPS, THRESH
INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA
LOGICAL FATAL, REWI, TRACE
CHARACTER*6 SNAME
* .. Array Arguments ..
DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ),
$ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
$ XS( NMAX*INCMAX ), XT( NMAX ),
$ XX( NMAX*INCMAX ), Z( NMAX )
INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
* .. Local Scalars ..
DOUBLE PRECISION ERR, ERRMAX, TRANSL
INTEGER I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K,
$ KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS
LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME
CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS
CHARACTER*2 ICHD, ICHU
CHARACTER*3 ICHT
* .. Local Arrays ..
LOGICAL ISAME( 13 )
* .. External Functions ..
LOGICAL LDE, LDERES
EXTERNAL LDE, LDERES
* .. External Subroutines ..
EXTERNAL DMAKE, DMVCH, DTBMV, DTBSV, DTPMV, DTPSV,
$ DTRMV, DTRSV
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
* .. Data statements ..
DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/
* .. Executable Statements ..
FULL = SNAME( 3: 3 ).EQ.'R'
BANDED = SNAME( 3: 3 ).EQ.'B'
PACKED = SNAME( 3: 3 ).EQ.'P'
* Define the number of arguments.
IF( FULL )THEN
NARGS = 8
ELSE IF( BANDED )THEN
NARGS = 9
ELSE IF( PACKED )THEN
NARGS = 7
END IF
*
NC = 0
RESET = .TRUE.
ERRMAX = ZERO
* Set up zero vector for DMVCH.
DO 10 I = 1, NMAX
Z( I ) = ZERO
10 CONTINUE
*
DO 110 IN = 1, NIDIM
N = IDIM( IN )
*
IF( BANDED )THEN
NK = NKB
ELSE
NK = 1
END IF
DO 100 IK = 1, NK
IF( BANDED )THEN
K = KB( IK )
ELSE
K = N - 1
END IF
* Set LDA to 1 more than minimum value if room.
IF( BANDED )THEN
LDA = K + 1
ELSE
LDA = N
END IF
IF( LDA.LT.NMAX )
$ LDA = LDA + 1
* Skip tests if not enough room.
IF( LDA.GT.NMAX )
$ GO TO 100
IF( PACKED )THEN
LAA = ( N*( N + 1 ) )/2
ELSE
LAA = LDA*N
END IF
NULL = N.LE.0
*
DO 90 ICU = 1, 2
UPLO = ICHU( ICU: ICU )
*
DO 80 ICT = 1, 3
TRANS = ICHT( ICT: ICT )
*
DO 70 ICD = 1, 2
DIAG = ICHD( ICD: ICD )
*
* Generate the matrix A.
*
TRANSL = ZERO
CALL DMAKE( SNAME( 2: 3 ), UPLO, DIAG, N, N, A,
$ NMAX, AA, LDA, K, K, RESET, TRANSL )
*
DO 60 IX = 1, NINC
INCX = INC( IX )
LX = ABS( INCX )*N
*
* Generate the vector X.
*
TRANSL = HALF
CALL DMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX,
$ ABS( INCX ), 0, N - 1, RESET,
$ TRANSL )
IF( N.GT.1 )THEN
X( N/2 ) = ZERO
XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
END IF
*
NC = NC + 1
*
* Save every datum before calling the subroutine.
*
UPLOS = UPLO
TRANSS = TRANS
DIAGS = DIAG
NS = N
KS = K
DO 20 I = 1, LAA
AS( I ) = AA( I )
20 CONTINUE
LDAS = LDA
DO 30 I = 1, LX
XS( I ) = XX( I )
30 CONTINUE
INCXS = INCX
*
* Call the subroutine.
*
IF( SNAME( 4: 5 ).EQ.'MV' )THEN
IF( FULL )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9993 )NC, SNAME,
$ UPLO, TRANS, DIAG, N, LDA, INCX
IF( REWI )
$ REWIND NTRA
CALL DTRMV( UPLO, TRANS, DIAG, N, AA, LDA,
$ XX, INCX )
ELSE IF( BANDED )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9994 )NC, SNAME,
$ UPLO, TRANS, DIAG, N, K, LDA, INCX
IF( REWI )
$ REWIND NTRA
CALL DTBMV( UPLO, TRANS, DIAG, N, K, AA,
$ LDA, XX, INCX )
ELSE IF( PACKED )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9995 )NC, SNAME,
$ UPLO, TRANS, DIAG, N, INCX
IF( REWI )
$ REWIND NTRA
CALL DTPMV( UPLO, TRANS, DIAG, N, AA, XX,
$ INCX )
END IF
ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN
IF( FULL )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9993 )NC, SNAME,
$ UPLO, TRANS, DIAG, N, LDA, INCX
IF( REWI )
$ REWIND NTRA
CALL DTRSV( UPLO, TRANS, DIAG, N, AA, LDA,
$ XX, INCX )
ELSE IF( BANDED )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9994 )NC, SNAME,
$ UPLO, TRANS, DIAG, N, K, LDA, INCX
IF( REWI )
$ REWIND NTRA
CALL DTBSV( UPLO, TRANS, DIAG, N, K, AA,
$ LDA, XX, INCX )
ELSE IF( PACKED )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9995 )NC, SNAME,
$ UPLO, TRANS, DIAG, N, INCX
IF( REWI )
$ REWIND NTRA
CALL DTPSV( UPLO, TRANS, DIAG, N, AA, XX,
$ INCX )
END IF
END IF
*
* Check if error-exit was taken incorrectly.
*
IF( .NOT.OK )THEN
WRITE( NOUT, FMT = 9992 )
FATAL = .TRUE.
GO TO 120
END IF
*
* See what data changed inside subroutines.
*
ISAME( 1 ) = UPLO.EQ.UPLOS
ISAME( 2 ) = TRANS.EQ.TRANSS
ISAME( 3 ) = DIAG.EQ.DIAGS
ISAME( 4 ) = NS.EQ.N
IF( FULL )THEN
ISAME( 5 ) = LDE( AS, AA, LAA )
ISAME( 6 ) = LDAS.EQ.LDA
IF( NULL )THEN
ISAME( 7 ) = LDE( XS, XX, LX )
ELSE
ISAME( 7 ) = LDERES( 'GE', ' ', 1, N, XS,
$ XX, ABS( INCX ) )
END IF
ISAME( 8 ) = INCXS.EQ.INCX
ELSE IF( BANDED )THEN
ISAME( 5 ) = KS.EQ.K
ISAME( 6 ) = LDE( AS, AA, LAA )
ISAME( 7 ) = LDAS.EQ.LDA
IF( NULL )THEN
ISAME( 8 ) = LDE( XS, XX, LX )
ELSE
ISAME( 8 ) = LDERES( 'GE', ' ', 1, N, XS,
$ XX, ABS( INCX ) )
END IF
ISAME( 9 ) = INCXS.EQ.INCX
ELSE IF( PACKED )THEN
ISAME( 5 ) = LDE( AS, AA, LAA )
IF( NULL )THEN
ISAME( 6 ) = LDE( XS, XX, LX )
ELSE
ISAME( 6 ) = LDERES( 'GE', ' ', 1, N, XS,
$ XX, ABS( INCX ) )
END IF
ISAME( 7 ) = INCXS.EQ.INCX
END IF
*
* If data was incorrectly changed, report and
* return.
*
SAME = .TRUE.
DO 40 I = 1, NARGS
SAME = SAME.AND.ISAME( I )
IF( .NOT.ISAME( I ) )
$ WRITE( NOUT, FMT = 9998 )I
40 CONTINUE
IF( .NOT.SAME )THEN
FATAL = .TRUE.
GO TO 120
END IF
*
IF( .NOT.NULL )THEN
IF( SNAME( 4: 5 ).EQ.'MV' )THEN
*
* Check the result.
*
CALL DMVCH( TRANS, N, N, ONE, A, NMAX, X,
$ INCX, ZERO, Z, INCX, XT, G,
$ XX, EPS, ERR, FATAL, NOUT,
$ .TRUE. )
ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN
*
* Compute approximation to original vector.
*
DO 50 I = 1, N
Z( I ) = XX( 1 + ( I - 1 )*
$ ABS( INCX ) )
XX( 1 + ( I - 1 )*ABS( INCX ) )
$ = X( I )
50 CONTINUE
CALL DMVCH( TRANS, N, N, ONE, A, NMAX, Z,
$ INCX, ZERO, X, INCX, XT, G,
$ XX, EPS, ERR, FATAL, NOUT,
$ .FALSE. )
END IF
ERRMAX = MAX( ERRMAX, ERR )
* If got really bad answer, report and return.
IF( FATAL )
$ GO TO 120
ELSE
* Avoid repeating tests with N.le.0.
GO TO 110
END IF
*
60 CONTINUE
*
70 CONTINUE
*
80 CONTINUE
*
90 CONTINUE
*
100 CONTINUE
*
110 CONTINUE
*
* Report result.
*
IF( ERRMAX.LT.THRESH )THEN
WRITE( NOUT, FMT = 9999 )SNAME, NC
ELSE
WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
END IF
GO TO 130
*
120 CONTINUE
WRITE( NOUT, FMT = 9996 )SNAME
IF( FULL )THEN
WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, DIAG, N, LDA,
$ INCX
ELSE IF( BANDED )THEN
WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, DIAG, N, K,
$ LDA, INCX
ELSE IF( PACKED )THEN
WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, TRANS, DIAG, N, INCX
END IF
*
130 CONTINUE
RETURN
*
9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
$ 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
$ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
$ ' - SUSPECT *******' )
9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
9995 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', AP, ',
$ 'X,', I2, ') .' )
9994 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), 2( I3, ',' ),
$ ' A,', I3, ', X,', I2, ') .' )
9993 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', A,',
$ I3, ', X,', I2, ') .' )
9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
* End of DCHK3.
*
END
SUBROUTINE DCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
$ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
$ Z )
*
* Tests DGER.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Parameters ..
DOUBLE PRECISION ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
* .. Scalar Arguments ..
DOUBLE PRECISION EPS, THRESH
INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
LOGICAL FATAL, REWI, TRACE
CHARACTER*6 SNAME
* .. Array Arguments ..
DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
$ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
$ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
$ YY( NMAX*INCMAX ), Z( NMAX )
INTEGER IDIM( NIDIM ), INC( NINC )
* .. Local Scalars ..
DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX, TRANSL
INTEGER I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX,
$ IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS,
$ NC, ND, NS
LOGICAL NULL, RESET, SAME
* .. Local Arrays ..
DOUBLE PRECISION W( 1 )
LOGICAL ISAME( 13 )
* .. External Functions ..
LOGICAL LDE, LDERES
EXTERNAL LDE, LDERES
* .. External Subroutines ..
EXTERNAL DGER, DMAKE, DMVCH
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
* .. Executable Statements ..
* Define the number of arguments.
NARGS = 9
*
NC = 0
RESET = .TRUE.
ERRMAX = ZERO
*
DO 120 IN = 1, NIDIM
N = IDIM( IN )
ND = N/2 + 1
*
DO 110 IM = 1, 2
IF( IM.EQ.1 )
$ M = MAX( N - ND, 0 )
IF( IM.EQ.2 )
$ M = MIN( N + ND, NMAX )
*
* Set LDA to 1 more than minimum value if room.
LDA = M
IF( LDA.LT.NMAX )
$ LDA = LDA + 1
* Skip tests if not enough room.
IF( LDA.GT.NMAX )
$ GO TO 110
LAA = LDA*N
NULL = N.LE.0.OR.M.LE.0
*
DO 100 IX = 1, NINC
INCX = INC( IX )
LX = ABS( INCX )*M
*
* Generate the vector X.
*
TRANSL = HALF
CALL DMAKE( 'GE', ' ', ' ', 1, M, X, 1, XX, ABS( INCX ),
$ 0, M - 1, RESET, TRANSL )
IF( M.GT.1 )THEN
X( M/2 ) = ZERO
XX( 1 + ABS( INCX )*( M/2 - 1 ) ) = ZERO
END IF
*
DO 90 IY = 1, NINC
INCY = INC( IY )
LY = ABS( INCY )*N
*
* Generate the vector Y.
*
TRANSL = ZERO
CALL DMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY,
$ ABS( INCY ), 0, N - 1, RESET, TRANSL )
IF( N.GT.1 )THEN
Y( N/2 ) = ZERO
YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO
END IF
*
DO 80 IA = 1, NALF
ALPHA = ALF( IA )
*
* Generate the matrix A.
*
TRANSL = ZERO
CALL DMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX,
$ AA, LDA, M - 1, N - 1, RESET, TRANSL )
*
NC = NC + 1
*
* Save every datum before calling the subroutine.
*
MS = M
NS = N
ALS = ALPHA
DO 10 I = 1, LAA
AS( I ) = AA( I )
10 CONTINUE
LDAS = LDA
DO 20 I = 1, LX
XS( I ) = XX( I )
20 CONTINUE
INCXS = INCX
DO 30 I = 1, LY
YS( I ) = YY( I )
30 CONTINUE
INCYS = INCY
*
* Call the subroutine.
*
IF( TRACE )
$ WRITE( NTRA, FMT = 9994 )NC, SNAME, M, N,
$ ALPHA, INCX, INCY, LDA
IF( REWI )
$ REWIND NTRA
CALL DGER( M, N, ALPHA, XX, INCX, YY, INCY, AA,
$ LDA )
*
* Check if error-exit was taken incorrectly.
*
IF( .NOT.OK )THEN
WRITE( NOUT, FMT = 9993 )
FATAL = .TRUE.
GO TO 140
END IF
*
* See what data changed inside subroutine.
*
ISAME( 1 ) = MS.EQ.M
ISAME( 2 ) = NS.EQ.N
ISAME( 3 ) = ALS.EQ.ALPHA
ISAME( 4 ) = LDE( XS, XX, LX )
ISAME( 5 ) = INCXS.EQ.INCX
ISAME( 6 ) = LDE( YS, YY, LY )
ISAME( 7 ) = INCYS.EQ.INCY
IF( NULL )THEN
ISAME( 8 ) = LDE( AS, AA, LAA )
ELSE
ISAME( 8 ) = LDERES( 'GE', ' ', M, N, AS, AA,
$ LDA )
END IF
ISAME( 9 ) = LDAS.EQ.LDA
*
* If data was incorrectly changed, report and return.
*
SAME = .TRUE.
DO 40 I = 1, NARGS
SAME = SAME.AND.ISAME( I )
IF( .NOT.ISAME( I ) )
$ WRITE( NOUT, FMT = 9998 )I
40 CONTINUE
IF( .NOT.SAME )THEN
FATAL = .TRUE.
GO TO 140
END IF
*
IF( .NOT.NULL )THEN
*
* Check the result column by column.
*
IF( INCX.GT.0 )THEN
DO 50 I = 1, M
Z( I ) = X( I )
50 CONTINUE
ELSE
DO 60 I = 1, M
Z( I ) = X( M - I + 1 )
60 CONTINUE
END IF
DO 70 J = 1, N
IF( INCY.GT.0 )THEN
W( 1 ) = Y( J )
ELSE
W( 1 ) = Y( N - J + 1 )
END IF
CALL DMVCH( 'N', M, 1, ALPHA, Z, NMAX, W, 1,
$ ONE, A( 1, J ), 1, YT, G,
$ AA( 1 + ( J - 1 )*LDA ), EPS,
$ ERR, FATAL, NOUT, .TRUE. )
ERRMAX = MAX( ERRMAX, ERR )
* If got really bad answer, report and return.
IF( FATAL )
$ GO TO 130
70 CONTINUE
ELSE
* Avoid repeating tests with M.le.0 or N.le.0.
GO TO 110
END IF
*
80 CONTINUE
*
90 CONTINUE
*
100 CONTINUE
*
110 CONTINUE
*
120 CONTINUE
*
* Report result.
*
IF( ERRMAX.LT.THRESH )THEN
WRITE( NOUT, FMT = 9999 )SNAME, NC
ELSE
WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
END IF
GO TO 150
*
130 CONTINUE
WRITE( NOUT, FMT = 9995 )J
*
140 CONTINUE
WRITE( NOUT, FMT = 9996 )SNAME
WRITE( NOUT, FMT = 9994 )NC, SNAME, M, N, ALPHA, INCX, INCY, LDA
*
150 CONTINUE
RETURN
*
9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
$ 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
$ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
$ ' - SUSPECT *******' )
9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
9994 FORMAT( 1X, I6, ': ', A6, '(', 2( I3, ',' ), F4.1, ', X,', I2,
$ ', Y,', I2, ', A,', I3, ') .' )
9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
* End of DCHK4.
*
END
SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
$ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
$ Z )
*
* Tests DSYR and DSPR.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Parameters ..
DOUBLE PRECISION ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
* .. Scalar Arguments ..
DOUBLE PRECISION EPS, THRESH
INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
LOGICAL FATAL, REWI, TRACE
CHARACTER*6 SNAME
* .. Array Arguments ..
DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
$ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
$ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
$ YY( NMAX*INCMAX ), Z( NMAX )
INTEGER IDIM( NIDIM ), INC( NINC )
* .. Local Scalars ..
DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX, TRANSL
INTEGER I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA,
$ LDA, LDAS, LJ, LX, N, NARGS, NC, NS
LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER
CHARACTER*1 UPLO, UPLOS
CHARACTER*2 ICH
* .. Local Arrays ..
DOUBLE PRECISION W( 1 )
LOGICAL ISAME( 13 )
* .. External Functions ..
LOGICAL LDE, LDERES
EXTERNAL LDE, LDERES
* .. External Subroutines ..
EXTERNAL DMAKE, DMVCH, DSPR, DSYR
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
* .. Data statements ..
DATA ICH/'UL'/
* .. Executable Statements ..
FULL = SNAME( 3: 3 ).EQ.'Y'
PACKED = SNAME( 3: 3 ).EQ.'P'
* Define the number of arguments.
IF( FULL )THEN
NARGS = 7
ELSE IF( PACKED )THEN
NARGS = 6
END IF
*
NC = 0
RESET = .TRUE.
ERRMAX = ZERO
*
DO 100 IN = 1, NIDIM
N = IDIM( IN )
* Set LDA to 1 more than minimum value if room.
LDA = N
IF( LDA.LT.NMAX )
$ LDA = LDA + 1
* Skip tests if not enough room.
IF( LDA.GT.NMAX )
$ GO TO 100
IF( PACKED )THEN
LAA = ( N*( N + 1 ) )/2
ELSE
LAA = LDA*N
END IF
*
DO 90 IC = 1, 2
UPLO = ICH( IC: IC )
UPPER = UPLO.EQ.'U'
*
DO 80 IX = 1, NINC
INCX = INC( IX )
LX = ABS( INCX )*N
*
* Generate the vector X.
*
TRANSL = HALF
CALL DMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ),
$ 0, N - 1, RESET, TRANSL )
IF( N.GT.1 )THEN
X( N/2 ) = ZERO
XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
END IF
*
DO 70 IA = 1, NALF
ALPHA = ALF( IA )
NULL = N.LE.0.OR.ALPHA.EQ.ZERO
*
* Generate the matrix A.
*
TRANSL = ZERO
CALL DMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX,
$ AA, LDA, N - 1, N - 1, RESET, TRANSL )
*
NC = NC + 1
*
* Save every datum before calling the subroutine.
*
UPLOS = UPLO
NS = N
ALS = ALPHA
DO 10 I = 1, LAA
AS( I ) = AA( I )
10 CONTINUE
LDAS = LDA
DO 20 I = 1, LX
XS( I ) = XX( I )
20 CONTINUE
INCXS = INCX
*
* Call the subroutine.
*
IF( FULL )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N,
$ ALPHA, INCX, LDA
IF( REWI )
$ REWIND NTRA
CALL DSYR( UPLO, N, ALPHA, XX, INCX, AA, LDA )
ELSE IF( PACKED )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N,
$ ALPHA, INCX
IF( REWI )
$ REWIND NTRA
CALL DSPR( UPLO, N, ALPHA, XX, INCX, AA )
END IF
*
* Check if error-exit was taken incorrectly.
*
IF( .NOT.OK )THEN
WRITE( NOUT, FMT = 9992 )
FATAL = .TRUE.
GO TO 120
END IF
*
* See what data changed inside subroutines.
*
ISAME( 1 ) = UPLO.EQ.UPLOS
ISAME( 2 ) = NS.EQ.N
ISAME( 3 ) = ALS.EQ.ALPHA
ISAME( 4 ) = LDE( XS, XX, LX )
ISAME( 5 ) = INCXS.EQ.INCX
IF( NULL )THEN
ISAME( 6 ) = LDE( AS, AA, LAA )
ELSE
ISAME( 6 ) = LDERES( SNAME( 2: 3 ), UPLO, N, N, AS,
$ AA, LDA )
END IF
IF( .NOT.PACKED )THEN
ISAME( 7 ) = LDAS.EQ.LDA
END IF
*
* If data was incorrectly changed, report and return.
*
SAME = .TRUE.
DO 30 I = 1, NARGS
SAME = SAME.AND.ISAME( I )
IF( .NOT.ISAME( I ) )
$ WRITE( NOUT, FMT = 9998 )I
30 CONTINUE
IF( .NOT.SAME )THEN
FATAL = .TRUE.
GO TO 120
END IF
*
IF( .NOT.NULL )THEN
*
* Check the result column by column.
*
IF( INCX.GT.0 )THEN
DO 40 I = 1, N
Z( I ) = X( I )
40 CONTINUE
ELSE
DO 50 I = 1, N
Z( I ) = X( N - I + 1 )
50 CONTINUE
END IF
JA = 1
DO 60 J = 1, N
W( 1 ) = Z( J )
IF( UPPER )THEN
JJ = 1
LJ = J
ELSE
JJ = J
LJ = N - J + 1
END IF
CALL DMVCH( 'N', LJ, 1, ALPHA, Z( JJ ), LJ, W,
$ 1, ONE, A( JJ, J ), 1, YT, G,
$ AA( JA ), EPS, ERR, FATAL, NOUT,
$ .TRUE. )
IF( FULL )THEN
IF( UPPER )THEN
JA = JA + LDA
ELSE
JA = JA + LDA + 1
END IF
ELSE
JA = JA + LJ
END IF
ERRMAX = MAX( ERRMAX, ERR )
* If got really bad answer, report and return.
IF( FATAL )
$ GO TO 110
60 CONTINUE
ELSE
* Avoid repeating tests if N.le.0.
IF( N.LE.0 )
$ GO TO 100
END IF
*
70 CONTINUE
*
80 CONTINUE
*
90 CONTINUE
*
100 CONTINUE
*
* Report result.
*
IF( ERRMAX.LT.THRESH )THEN
WRITE( NOUT, FMT = 9999 )SNAME, NC
ELSE
WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
END IF
GO TO 130
*
110 CONTINUE
WRITE( NOUT, FMT = 9995 )J
*
120 CONTINUE
WRITE( NOUT, FMT = 9996 )SNAME
IF( FULL )THEN
WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX, LDA
ELSE IF( PACKED )THEN
WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, ALPHA, INCX
END IF
*
130 CONTINUE
RETURN
*
9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
$ 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
$ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
$ ' - SUSPECT *******' )
9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,',
$ I2, ', AP) .' )
9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,',
$ I2, ', A,', I3, ') .' )
9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
* End of DCHK5.
*
END
SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
$ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
$ Z )
*
* Tests DSYR2 and DSPR2.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Parameters ..
DOUBLE PRECISION ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
* .. Scalar Arguments ..
DOUBLE PRECISION EPS, THRESH
INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
LOGICAL FATAL, REWI, TRACE
CHARACTER*6 SNAME
* .. Array Arguments ..
DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
$ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
$ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
$ YY( NMAX*INCMAX ), Z( NMAX, 2 )
INTEGER IDIM( NIDIM ), INC( NINC )
* .. Local Scalars ..
DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX, TRANSL
INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX,
$ IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N,
$ NARGS, NC, NS
LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER
CHARACTER*1 UPLO, UPLOS
CHARACTER*2 ICH
* .. Local Arrays ..
DOUBLE PRECISION W( 2 )
LOGICAL ISAME( 13 )
* .. External Functions ..
LOGICAL LDE, LDERES
EXTERNAL LDE, LDERES
* .. External Subroutines ..
EXTERNAL DMAKE, DMVCH, DSPR2, DSYR2
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
* .. Data statements ..
DATA ICH/'UL'/
* .. Executable Statements ..
FULL = SNAME( 3: 3 ).EQ.'Y'
PACKED = SNAME( 3: 3 ).EQ.'P'
* Define the number of arguments.
IF( FULL )THEN
NARGS = 9
ELSE IF( PACKED )THEN
NARGS = 8
END IF
*
NC = 0
RESET = .TRUE.
ERRMAX = ZERO
*
DO 140 IN = 1, NIDIM
N = IDIM( IN )
* Set LDA to 1 more than minimum value if room.
LDA = N
IF( LDA.LT.NMAX )
$ LDA = LDA + 1
* Skip tests if not enough room.
IF( LDA.GT.NMAX )
$ GO TO 140
IF( PACKED )THEN
LAA = ( N*( N + 1 ) )/2
ELSE
LAA = LDA*N
END IF
*
DO 130 IC = 1, 2
UPLO = ICH( IC: IC )
UPPER = UPLO.EQ.'U'
*
DO 120 IX = 1, NINC
INCX = INC( IX )
LX = ABS( INCX )*N
*
* Generate the vector X.
*
TRANSL = HALF
CALL DMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ),
$ 0, N - 1, RESET, TRANSL )
IF( N.GT.1 )THEN
X( N/2 ) = ZERO
XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
END IF
*
DO 110 IY = 1, NINC
INCY = INC( IY )
LY = ABS( INCY )*N
*
* Generate the vector Y.
*
TRANSL = ZERO
CALL DMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY,
$ ABS( INCY ), 0, N - 1, RESET, TRANSL )
IF( N.GT.1 )THEN
Y( N/2 ) = ZERO
YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO
END IF
*
DO 100 IA = 1, NALF
ALPHA = ALF( IA )
NULL = N.LE.0.OR.ALPHA.EQ.ZERO
*
* Generate the matrix A.
*
TRANSL = ZERO
CALL DMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A,
$ NMAX, AA, LDA, N - 1, N - 1, RESET,
$ TRANSL )
*
NC = NC + 1
*
* Save every datum before calling the subroutine.
*
UPLOS = UPLO
NS = N
ALS = ALPHA
DO 10 I = 1, LAA
AS( I ) = AA( I )
10 CONTINUE
LDAS = LDA
DO 20 I = 1, LX
XS( I ) = XX( I )
20 CONTINUE
INCXS = INCX
DO 30 I = 1, LY
YS( I ) = YY( I )
30 CONTINUE
INCYS = INCY
*
* Call the subroutine.
*
IF( FULL )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N,
$ ALPHA, INCX, INCY, LDA
IF( REWI )
$ REWIND NTRA
CALL DSYR2( UPLO, N, ALPHA, XX, INCX, YY, INCY,
$ AA, LDA )
ELSE IF( PACKED )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N,
$ ALPHA, INCX, INCY
IF( REWI )
$ REWIND NTRA
CALL DSPR2( UPLO, N, ALPHA, XX, INCX, YY, INCY,
$ AA )
END IF
*
* Check if error-exit was taken incorrectly.
*
IF( .NOT.OK )THEN
WRITE( NOUT, FMT = 9992 )
FATAL = .TRUE.
GO TO 160
END IF
*
* See what data changed inside subroutines.
*
ISAME( 1 ) = UPLO.EQ.UPLOS
ISAME( 2 ) = NS.EQ.N
ISAME( 3 ) = ALS.EQ.ALPHA
ISAME( 4 ) = LDE( XS, XX, LX )
ISAME( 5 ) = INCXS.EQ.INCX
ISAME( 6 ) = LDE( YS, YY, LY )
ISAME( 7 ) = INCYS.EQ.INCY
IF( NULL )THEN
ISAME( 8 ) = LDE( AS, AA, LAA )
ELSE
ISAME( 8 ) = LDERES( SNAME( 2: 3 ), UPLO, N, N,
$ AS, AA, LDA )
END IF
IF( .NOT.PACKED )THEN
ISAME( 9 ) = LDAS.EQ.LDA
END IF
*
* If data was incorrectly changed, report and return.
*
SAME = .TRUE.
DO 40 I = 1, NARGS
SAME = SAME.AND.ISAME( I )
IF( .NOT.ISAME( I ) )
$ WRITE( NOUT, FMT = 9998 )I
40 CONTINUE
IF( .NOT.SAME )THEN
FATAL = .TRUE.
GO TO 160
END IF
*
IF( .NOT.NULL )THEN
*
* Check the result column by column.
*
IF( INCX.GT.0 )THEN
DO 50 I = 1, N
Z( I, 1 ) = X( I )
50 CONTINUE
ELSE
DO 60 I = 1, N
Z( I, 1 ) = X( N - I + 1 )
60 CONTINUE
END IF
IF( INCY.GT.0 )THEN
DO 70 I = 1, N
Z( I, 2 ) = Y( I )
70 CONTINUE
ELSE
DO 80 I = 1, N
Z( I, 2 ) = Y( N - I + 1 )
80 CONTINUE
END IF
JA = 1
DO 90 J = 1, N
W( 1 ) = Z( J, 2 )
W( 2 ) = Z( J, 1 )
IF( UPPER )THEN
JJ = 1
LJ = J
ELSE
JJ = J
LJ = N - J + 1
END IF
CALL DMVCH( 'N', LJ, 2, ALPHA, Z( JJ, 1 ),
$ NMAX, W, 1, ONE, A( JJ, J ), 1,
$ YT, G, AA( JA ), EPS, ERR, FATAL,
$ NOUT, .TRUE. )
IF( FULL )THEN
IF( UPPER )THEN
JA = JA + LDA
ELSE
JA = JA + LDA + 1
END IF
ELSE
JA = JA + LJ
END IF
ERRMAX = MAX( ERRMAX, ERR )
* If got really bad answer, report and return.
IF( FATAL )
$ GO TO 150
90 CONTINUE
ELSE
* Avoid repeating tests with N.le.0.
IF( N.LE.0 )
$ GO TO 140
END IF
*
100 CONTINUE
*
110 CONTINUE
*
120 CONTINUE
*
130 CONTINUE
*
140 CONTINUE
*
* Report result.
*
IF( ERRMAX.LT.THRESH )THEN
WRITE( NOUT, FMT = 9999 )SNAME, NC
ELSE
WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
END IF
GO TO 170
*
150 CONTINUE
WRITE( NOUT, FMT = 9995 )J
*
160 CONTINUE
WRITE( NOUT, FMT = 9996 )SNAME
IF( FULL )THEN
WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX,
$ INCY, LDA
ELSE IF( PACKED )THEN
WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, ALPHA, INCX, INCY
END IF
*
170 CONTINUE
RETURN
*
9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
$ 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
$ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
$ ' - SUSPECT *******' )
9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,',
$ I2, ', Y,', I2, ', AP) .' )
9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,',
$ I2, ', Y,', I2, ', A,', I3, ') .' )
9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
* End of DCHK6.
*
END
SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT )
*
* Tests the error exits from the Level 2 Blas.
* Requires a special version of the error-handling routine XERBLA.
* ALPHA, BETA, A, X and Y should not need to be defined.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Scalar Arguments ..
INTEGER ISNUM, NOUT
CHARACTER*6 SRNAMT
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
* .. Local Scalars ..
DOUBLE PRECISION ALPHA, BETA
* .. Local Arrays ..
DOUBLE PRECISION A( 1, 1 ), X( 1 ), Y( 1 )
* .. External Subroutines ..
EXTERNAL CHKXER, DGBMV, DGEMV, DGER, DSBMV, DSPMV, DSPR,
$ DSPR2, DSYMV, DSYR, DSYR2, DTBMV, DTBSV, DTPMV,
$ DTPSV, DTRMV, DTRSV
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
* .. Executable Statements ..
* OK is set to .FALSE. by the special version of XERBLA or by CHKXER
* if anything is wrong.
OK = .TRUE.
* LERR is set to .TRUE. by the special version of XERBLA each time
* it is called, and is then tested and re-set by CHKXER.
LERR = .FALSE.
GO TO ( 10, 20, 30, 40, 50, 60, 70, 80,
$ 90, 100, 110, 120, 130, 140, 150,
$ 160 )ISNUM
10 INFOT = 1
CALL DGEMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGEMV( 'N', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGEMV( 'N', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DGEMV( 'N', 2, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DGEMV( 'N', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DGEMV( 'N', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 170
20 INFOT = 1
CALL DGBMV( '/', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGBMV( 'N', -1, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGBMV( 'N', 0, -1, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGBMV( 'N', 0, 0, -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGBMV( 'N', 2, 0, 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DGBMV( 'N', 0, 0, 1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 13
CALL DGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 170
30 INFOT = 1
CALL DSYMV( '/', 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSYMV( 'U', -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DSYMV( 'U', 2, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DSYMV( 'U', 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DSYMV( 'U', 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 170
40 INFOT = 1
CALL DSBMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSBMV( 'U', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSBMV( 'U', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DSBMV( 'U', 0, 1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DSBMV( 'U', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DSBMV( 'U', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 170
50 INFOT = 1
CALL DSPMV( '/', 0, ALPHA, A, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSPMV( 'U', -1, ALPHA, A, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DSPMV( 'U', 0, ALPHA, A, X, 0, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DSPMV( 'U', 0, ALPHA, A, X, 1, BETA, Y, 0 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 170
60 INFOT = 1
CALL DTRMV( '/', 'N', 'N', 0, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTRMV( 'U', '/', 'N', 0, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DTRMV( 'U', 'N', '/', 0, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DTRMV( 'U', 'N', 'N', -1, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DTRMV( 'U', 'N', 'N', 2, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DTRMV( 'U', 'N', 'N', 0, A, 1, X, 0 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 170
70 INFOT = 1
CALL DTBMV( '/', 'N', 'N', 0, 0, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTBMV( 'U', '/', 'N', 0, 0, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DTBMV( 'U', 'N', '/', 0, 0, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DTBMV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTBMV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DTBMV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DTBMV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 170
80 INFOT = 1
CALL DTPMV( '/', 'N', 'N', 0, A, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTPMV( 'U', '/', 'N', 0, A, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DTPMV( 'U', 'N', '/', 0, A, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DTPMV( 'U', 'N', 'N', -1, A, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DTPMV( 'U', 'N', 'N', 0, A, X, 0 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 170
90 INFOT = 1
CALL DTRSV( '/', 'N', 'N', 0, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTRSV( 'U', '/', 'N', 0, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DTRSV( 'U', 'N', '/', 0, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DTRSV( 'U', 'N', 'N', -1, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DTRSV( 'U', 'N', 'N', 2, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DTRSV( 'U', 'N', 'N', 0, A, 1, X, 0 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 170
100 INFOT = 1
CALL DTBSV( '/', 'N', 'N', 0, 0, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTBSV( 'U', '/', 'N', 0, 0, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DTBSV( 'U', 'N', '/', 0, 0, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DTBSV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTBSV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DTBSV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DTBSV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 170
110 INFOT = 1
CALL DTPSV( '/', 'N', 'N', 0, A, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTPSV( 'U', '/', 'N', 0, A, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DTPSV( 'U', 'N', '/', 0, A, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DTPSV( 'U', 'N', 'N', -1, A, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DTPSV( 'U', 'N', 'N', 0, A, X, 0 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 170
120 INFOT = 1
CALL DGER( -1, 0, ALPHA, X, 1, Y, 1, A, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGER( 0, -1, ALPHA, X, 1, Y, 1, A, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGER( 0, 0, ALPHA, X, 0, Y, 1, A, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DGER( 0, 0, ALPHA, X, 1, Y, 0, A, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DGER( 2, 0, ALPHA, X, 1, Y, 1, A, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 170
130 INFOT = 1
CALL DSYR( '/', 0, ALPHA, X, 1, A, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSYR( 'U', -1, ALPHA, X, 1, A, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DSYR( 'U', 0, ALPHA, X, 0, A, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DSYR( 'U', 2, ALPHA, X, 1, A, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 170
140 INFOT = 1
CALL DSPR( '/', 0, ALPHA, X, 1, A )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSPR( 'U', -1, ALPHA, X, 1, A )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DSPR( 'U', 0, ALPHA, X, 0, A )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 170
150 INFOT = 1
CALL DSYR2( '/', 0, ALPHA, X, 1, Y, 1, A, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSYR2( 'U', -1, ALPHA, X, 1, Y, 1, A, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DSYR2( 'U', 0, ALPHA, X, 0, Y, 1, A, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DSYR2( 'U', 0, ALPHA, X, 1, Y, 0, A, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DSYR2( 'U', 2, ALPHA, X, 1, Y, 1, A, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 170
160 INFOT = 1
CALL DSPR2( '/', 0, ALPHA, X, 1, Y, 1, A )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSPR2( 'U', -1, ALPHA, X, 1, Y, 1, A )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DSPR2( 'U', 0, ALPHA, X, 0, Y, 1, A )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DSPR2( 'U', 0, ALPHA, X, 1, Y, 0, A )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
*
170 IF( OK )THEN
WRITE( NOUT, FMT = 9999 )SRNAMT
ELSE
WRITE( NOUT, FMT = 9998 )SRNAMT
END IF
RETURN
*
9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' )
9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****',
$ '**' )
*
* End of DCHKE.
*
END
SUBROUTINE DMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL,
$ KU, RESET, TRANSL )
*
* Generates values for an M by N matrix A within the bandwidth
* defined by KL and KU.
* Stores the values in the array AA in the data structure required
* by the routine, with unwanted elements set to rogue value.
*
* TYPE is 'GE', 'GB', 'SY', 'SB', 'SP', 'TR', 'TB' OR 'TP'.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
DOUBLE PRECISION ROGUE
PARAMETER ( ROGUE = -1.0D10 )
* .. Scalar Arguments ..
DOUBLE PRECISION TRANSL
INTEGER KL, KU, LDA, M, N, NMAX
LOGICAL RESET
CHARACTER*1 DIAG, UPLO
CHARACTER*2 TYPE
* .. Array Arguments ..
DOUBLE PRECISION A( NMAX, * ), AA( * )
* .. Local Scalars ..
INTEGER I, I1, I2, I3, IBEG, IEND, IOFF, J, KK
LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER
* .. External Functions ..
DOUBLE PRECISION DBEG
EXTERNAL DBEG
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* .. Executable Statements ..
GEN = TYPE( 1: 1 ).EQ.'G'
SYM = TYPE( 1: 1 ).EQ.'S'
TRI = TYPE( 1: 1 ).EQ.'T'
UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U'
LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L'
UNIT = TRI.AND.DIAG.EQ.'U'
*
* Generate data in array A.
*
DO 20 J = 1, N
DO 10 I = 1, M
IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) )
$ THEN
IF( ( I.LE.J.AND.J - I.LE.KU ).OR.
$ ( I.GE.J.AND.I - J.LE.KL ) )THEN
A( I, J ) = DBEG( RESET ) + TRANSL
ELSE
A( I, J ) = ZERO
END IF
IF( I.NE.J )THEN
IF( SYM )THEN
A( J, I ) = A( I, J )
ELSE IF( TRI )THEN
A( J, I ) = ZERO
END IF
END IF
END IF
10 CONTINUE
IF( TRI )
$ A( J, J ) = A( J, J ) + ONE
IF( UNIT )
$ A( J, J ) = ONE
20 CONTINUE
*
* Store elements in array AS in data structure required by routine.
*
IF( TYPE.EQ.'GE' )THEN
DO 50 J = 1, N
DO 30 I = 1, M
AA( I + ( J - 1 )*LDA ) = A( I, J )
30 CONTINUE
DO 40 I = M + 1, LDA
AA( I + ( J - 1 )*LDA ) = ROGUE
40 CONTINUE
50 CONTINUE
ELSE IF( TYPE.EQ.'GB' )THEN
DO 90 J = 1, N
DO 60 I1 = 1, KU + 1 - J
AA( I1 + ( J - 1 )*LDA ) = ROGUE
60 CONTINUE
DO 70 I2 = I1, MIN( KL + KU + 1, KU + 1 + M - J )
AA( I2 + ( J - 1 )*LDA ) = A( I2 + J - KU - 1, J )
70 CONTINUE
DO 80 I3 = I2, LDA
AA( I3 + ( J - 1 )*LDA ) = ROGUE
80 CONTINUE
90 CONTINUE
ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN
DO 130 J = 1, N
IF( UPPER )THEN
IBEG = 1
IF( UNIT )THEN
IEND = J - 1
ELSE
IEND = J
END IF
ELSE
IF( UNIT )THEN
IBEG = J + 1
ELSE
IBEG = J
END IF
IEND = N
END IF
DO 100 I = 1, IBEG - 1
AA( I + ( J - 1 )*LDA ) = ROGUE
100 CONTINUE
DO 110 I = IBEG, IEND
AA( I + ( J - 1 )*LDA ) = A( I, J )
110 CONTINUE
DO 120 I = IEND + 1, LDA
AA( I + ( J - 1 )*LDA ) = ROGUE
120 CONTINUE
130 CONTINUE
ELSE IF( TYPE.EQ.'SB'.OR.TYPE.EQ.'TB' )THEN
DO 170 J = 1, N
IF( UPPER )THEN
KK = KL + 1
IBEG = MAX( 1, KL + 2 - J )
IF( UNIT )THEN
IEND = KL
ELSE
IEND = KL + 1
END IF
ELSE
KK = 1
IF( UNIT )THEN
IBEG = 2
ELSE
IBEG = 1
END IF
IEND = MIN( KL + 1, 1 + M - J )
END IF
DO 140 I = 1, IBEG - 1
AA( I + ( J - 1 )*LDA ) = ROGUE
140 CONTINUE
DO 150 I = IBEG, IEND
AA( I + ( J - 1 )*LDA ) = A( I + J - KK, J )
150 CONTINUE
DO 160 I = IEND + 1, LDA
AA( I + ( J - 1 )*LDA ) = ROGUE
160 CONTINUE
170 CONTINUE
ELSE IF( TYPE.EQ.'SP'.OR.TYPE.EQ.'TP' )THEN
IOFF = 0
DO 190 J = 1, N
IF( UPPER )THEN
IBEG = 1
IEND = J
ELSE
IBEG = J
IEND = N
END IF
DO 180 I = IBEG, IEND
IOFF = IOFF + 1
AA( IOFF ) = A( I, J )
IF( I.EQ.J )THEN
IF( UNIT )
$ AA( IOFF ) = ROGUE
END IF
180 CONTINUE
190 CONTINUE
END IF
RETURN
*
* End of DMAKE.
*
END
SUBROUTINE DMVCH( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y,
$ INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV )
*
* Checks the results of the computational tests.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA, BETA, EPS, ERR
INTEGER INCX, INCY, M, N, NMAX, NOUT
LOGICAL FATAL, MV
CHARACTER*1 TRANS
* .. Array Arguments ..
DOUBLE PRECISION A( NMAX, * ), G( * ), X( * ), Y( * ), YT( * ),
$ YY( * )
* .. Local Scalars ..
DOUBLE PRECISION ERRI
INTEGER I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL
LOGICAL TRAN
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* .. Executable Statements ..
TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
IF( TRAN )THEN
ML = N
NL = M
ELSE
ML = M
NL = N
END IF
IF( INCX.LT.0 )THEN
KX = NL
INCXL = -1
ELSE
KX = 1
INCXL = 1
END IF
IF( INCY.LT.0 )THEN
KY = ML
INCYL = -1
ELSE
KY = 1
INCYL = 1
END IF
*
* Compute expected result in YT using data in A, X and Y.
* Compute gauges in G.
*
IY = KY
DO 30 I = 1, ML
YT( IY ) = ZERO
G( IY ) = ZERO
JX = KX
IF( TRAN )THEN
DO 10 J = 1, NL
YT( IY ) = YT( IY ) + A( J, I )*X( JX )
G( IY ) = G( IY ) + ABS( A( J, I )*X( JX ) )
JX = JX + INCXL
10 CONTINUE
ELSE
DO 20 J = 1, NL
YT( IY ) = YT( IY ) + A( I, J )*X( JX )
G( IY ) = G( IY ) + ABS( A( I, J )*X( JX ) )
JX = JX + INCXL
20 CONTINUE
END IF
YT( IY ) = ALPHA*YT( IY ) + BETA*Y( IY )
G( IY ) = ABS( ALPHA )*G( IY ) + ABS( BETA*Y( IY ) )
IY = IY + INCYL
30 CONTINUE
*
* Compute the error ratio for this result.
*
ERR = ZERO
DO 40 I = 1, ML
ERRI = ABS( YT( I ) - YY( 1 + ( I - 1 )*ABS( INCY ) ) )/EPS
IF( G( I ).NE.ZERO )
$ ERRI = ERRI/G( I )
ERR = MAX( ERR, ERRI )
IF( ERR*SQRT( EPS ).GE.ONE )
$ GO TO 50
40 CONTINUE
* If the loop completes, all results are at least half accurate.
GO TO 70
*
* Report fatal error.
*
50 FATAL = .TRUE.
WRITE( NOUT, FMT = 9999 )
DO 60 I = 1, ML
IF( MV )THEN
WRITE( NOUT, FMT = 9998 )I, YT( I ),
$ YY( 1 + ( I - 1 )*ABS( INCY ) )
ELSE
WRITE( NOUT, FMT = 9998 )I,
$ YY( 1 + ( I - 1 )*ABS( INCY ) ), YT( I )
END IF
60 CONTINUE
*
70 CONTINUE
RETURN
*
9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
$ 'F ACCURATE *******', /' EXPECTED RESULT COMPU',
$ 'TED RESULT' )
9998 FORMAT( 1X, I7, 2G18.6 )
*
* End of DMVCH.
*
END
LOGICAL FUNCTION LDE( RI, RJ, LR )
*
* Tests if two arrays are identical.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Scalar Arguments ..
INTEGER LR
* .. Array Arguments ..
DOUBLE PRECISION RI( * ), RJ( * )
* .. Local Scalars ..
INTEGER I
* .. Executable Statements ..
DO 10 I = 1, LR
IF( RI( I ).NE.RJ( I ) )
$ GO TO 20
10 CONTINUE
LDE = .TRUE.
GO TO 30
20 CONTINUE
LDE = .FALSE.
30 RETURN
*
* End of LDE.
*
END
LOGICAL FUNCTION LDERES( TYPE, UPLO, M, N, AA, AS, LDA )
*
* Tests if selected elements in two arrays are equal.
*
* TYPE is 'GE', 'SY' or 'SP'.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Scalar Arguments ..
INTEGER LDA, M, N
CHARACTER*1 UPLO
CHARACTER*2 TYPE
* .. Array Arguments ..
DOUBLE PRECISION AA( LDA, * ), AS( LDA, * )
* .. Local Scalars ..
INTEGER I, IBEG, IEND, J
LOGICAL UPPER
* .. Executable Statements ..
UPPER = UPLO.EQ.'U'
IF( TYPE.EQ.'GE' )THEN
DO 20 J = 1, N
DO 10 I = M + 1, LDA
IF( AA( I, J ).NE.AS( I, J ) )
$ GO TO 70
10 CONTINUE
20 CONTINUE
ELSE IF( TYPE.EQ.'SY' )THEN
DO 50 J = 1, N
IF( UPPER )THEN
IBEG = 1
IEND = J
ELSE
IBEG = J
IEND = N
END IF
DO 30 I = 1, IBEG - 1
IF( AA( I, J ).NE.AS( I, J ) )
$ GO TO 70
30 CONTINUE
DO 40 I = IEND + 1, LDA
IF( AA( I, J ).NE.AS( I, J ) )
$ GO TO 70
40 CONTINUE
50 CONTINUE
END IF
*
60 CONTINUE
LDERES = .TRUE.
GO TO 80
70 CONTINUE
LDERES = .FALSE.
80 RETURN
*
* End of LDERES.
*
END
DOUBLE PRECISION FUNCTION DBEG( RESET )
*
* Generates random numbers uniformly distributed between -0.5 and 0.5.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Scalar Arguments ..
LOGICAL RESET
* .. Local Scalars ..
INTEGER I, IC, MI
* .. Save statement ..
SAVE I, IC, MI
* .. Intrinsic Functions ..
INTRINSIC DBLE
* .. Executable Statements ..
IF( RESET )THEN
* Initialize local variables.
MI = 891
I = 7
IC = 0
RESET = .FALSE.
END IF
*
* The sequence of values of I is bounded between 1 and 999.
* If initial I = 1,2,3,6,7 or 9, the period will be 50.
* If initial I = 4 or 8, the period will be 25.
* If initial I = 5, the period will be 10.
* IC is used to break up the period by skipping 1 value of I in 6.
*
IC = IC + 1
10 I = I*MI
I = I - 1000*( I/1000 )
IF( IC.GE.5 )THEN
IC = 0
GO TO 10
END IF
DBEG = DBLE( I - 500 )/1001.0D0
RETURN
*
* End of DBEG.
*
END
DOUBLE PRECISION FUNCTION DDIFF( X, Y )
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
*
* .. Scalar Arguments ..
DOUBLE PRECISION X, Y
* .. Executable Statements ..
DDIFF = X - Y
RETURN
*
* End of DDIFF.
*
END
SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
*
* Tests whether XERBLA has detected an error when it should.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Scalar Arguments ..
INTEGER INFOT, NOUT
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
* .. Executable Statements ..
IF( .NOT.LERR )THEN
WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT
OK = .FALSE.
END IF
LERR = .FALSE.
RETURN
*
9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D',
$ 'ETECTED BY ', A6, ' *****' )
*
* End of CHKXER.
*
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/blas2/dblat2.in 0000644 0001750 0001750 00000002672 10616163233 023727 0 ustar osallou osallou 'dblat2.out' NAME OF SUMMARY OUTPUT FILE
6 UNIT NUMBER OF SUMMARY FILE
'DBLAT2.SNAP' NAME OF SNAPSHOT OUTPUT FILE
-1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
F LOGICAL FLAG, T TO STOP ON FAILURES.
T LOGICAL FLAG, T TO TEST ERROR EXITS.
16.0 THRESHOLD VALUE OF TEST RATIO
6 NUMBER OF VALUES OF N
0 1 2 3 5 9 VALUES OF N
4 NUMBER OF VALUES OF K
0 1 2 4 VALUES OF K
4 NUMBER OF VALUES OF INCX AND INCY
1 2 -1 -2 VALUES OF INCX AND INCY
3 NUMBER OF VALUES OF ALPHA
0.0 1.0 0.7 VALUES OF ALPHA
3 NUMBER OF VALUES OF BETA
0.0 1.0 0.9 VALUES OF BETA
DGEMV T PUT F FOR NO TEST. SAME COLUMNS.
DGBMV T PUT F FOR NO TEST. SAME COLUMNS.
DSYMV T PUT F FOR NO TEST. SAME COLUMNS.
DSBMV T PUT F FOR NO TEST. SAME COLUMNS.
DSPMV T PUT F FOR NO TEST. SAME COLUMNS.
DTRMV T PUT F FOR NO TEST. SAME COLUMNS.
DTBMV T PUT F FOR NO TEST. SAME COLUMNS.
DTPMV T PUT F FOR NO TEST. SAME COLUMNS.
DTRSV T PUT F FOR NO TEST. SAME COLUMNS.
DTBSV T PUT F FOR NO TEST. SAME COLUMNS.
DTPSV T PUT F FOR NO TEST. SAME COLUMNS.
DGER T PUT F FOR NO TEST. SAME COLUMNS.
DSYR T PUT F FOR NO TEST. SAME COLUMNS.
DSPR T PUT F FOR NO TEST. SAME COLUMNS.
DSYR2 T PUT F FOR NO TEST. SAME COLUMNS.
DSPR2 T PUT F FOR NO TEST. SAME COLUMNS.
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/blas2/xerbla.f 0000644 0001750 0001750 00000003400 10616163233 023641 0 ustar osallou osallou SUBROUTINE XERBLA( SRNAME, INFO )
*
* f2j NOTE: this is compiled separately from dblat2.f because
* it needs to be in package org.netlib.err while the rest of
* dblat2.f routines should be in org.netlib.blas.testing.
*
* This is a special version of XERBLA to be used only as part of
* the test program for testing error exits from the Level 2 BLAS
* routines.
*
* XERBLA is an error handler for the Level 2 BLAS routines.
*
* It is called by the Level 2 BLAS routines if an input parameter is
* invalid.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Scalar Arguments ..
INTEGER INFO
CHARACTER*6 SRNAME
* .. Scalars in Common ..
INTEGER INFOT, NOUT
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUT, OK, LERR
COMMON /SRNAMC/SRNAMT
* .. Executable Statements ..
LERR = .TRUE.
IF( INFO.NE.INFOT )THEN
IF( INFOT.NE.0 )THEN
WRITE( NOUT, FMT = 9999 )INFO, INFOT
ELSE
WRITE( NOUT, FMT = 9997 )INFO
END IF
OK = .FALSE.
END IF
IF( SRNAME.NE.SRNAMT )THEN
WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT
OK = .FALSE.
END IF
RETURN
*
9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD',
$ ' OF ', I2, ' *******' )
9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE',
$ 'AD OF ', A6, ' *******' )
9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6,
$ ' *******' )
*
* End of XERBLA
*
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/Makefile_javasrc 0000644 0001750 0001750 00000004344 10616163233 024373 0 ustar osallou osallou .PHONY: blas1 blas2 blas3 runtests clean sblas1 sblas2 sblas3 eig lin seig slin
ROOT=../..
include $(ROOT)/make.def
testers: blas1 blas2 blas3 eig lin sblas1 sblas2 sblas3 slin seig
blas1: $(ROOT)/$(BLAS1TEST_IDX)
blas2: $(ROOT)/$(BLAS2TEST_IDX)
blas3: $(ROOT)/$(BLAS3TEST_IDX)
eig: $(ROOT)/$(EIGTEST_IDX)
lin: $(ROOT)/$(LINTEST_IDX)
sblas1: $(ROOT)/$(SBLAS1TEST_IDX)
sblas2: $(ROOT)/$(SBLAS2TEST_IDX)
sblas3: $(ROOT)/$(SBLAS3TEST_IDX)
seig: $(ROOT)/$(SEIGTEST_IDX)
slin: $(ROOT)/$(SLINTEST_IDX)
$(ROOT)/$(BLAS1TEST_IDX):
cd blas1;$(MAKE) -f Makefile_javasrc
$(ROOT)/$(BLAS2TEST_IDX):
cd blas2;$(MAKE) -f Makefile_javasrc
$(ROOT)/$(BLAS3TEST_IDX):
cd blas3;$(MAKE) -f Makefile_javasrc
$(ROOT)/$(EIGTEST_IDX):
cd eig;$(MAKE) -f Makefile_javasrc
$(ROOT)/$(LINTEST_IDX):
cd lin;$(MAKE) -f Makefile_javasrc
$(ROOT)/$(SBLAS1TEST_IDX):
cd sblas1;$(MAKE) -f Makefile_javasrc
$(ROOT)/$(SBLAS2TEST_IDX):
cd sblas2;$(MAKE) -f Makefile_javasrc
$(ROOT)/$(SBLAS3TEST_IDX):
cd sblas3;$(MAKE) -f Makefile_javasrc
$(ROOT)/$(SEIGTEST_IDX):
cd seig;$(MAKE) -f Makefile_javasrc
$(ROOT)/$(SLINTEST_IDX):
cd slin;$(MAKE) -f Makefile_javasrc
runtests: blastest lintest eigtest sblastest slintest seigtest
blastest:
cd blas1;$(MAKE) -f Makefile_javasrc runtest
cd blas2;$(MAKE) -f Makefile_javasrc runtest
cd blas3;$(MAKE) -f Makefile_javasrc runtest
sblastest:
cd sblas1;$(MAKE) -f Makefile_javasrc runtest
cd sblas2;$(MAKE) -f Makefile_javasrc runtest
cd sblas3;$(MAKE) -f Makefile_javasrc runtest
eigtest:
cd eig;$(MAKE) -f Makefile_javasrc runtest
seigtest:
cd seig;$(MAKE) -f Makefile_javasrc runtest
lintest:
cd lin;$(MAKE) -f Makefile_javasrc runtest
slintest:
cd slin;$(MAKE) -f Makefile_javasrc runtest
clean:
cd blas1;$(MAKE) -f Makefile_javasrc clean
cd blas2;$(MAKE) -f Makefile_javasrc clean
cd blas3;$(MAKE) -f Makefile_javasrc clean
cd sblas1;$(MAKE) -f Makefile_javasrc clean
cd sblas2;$(MAKE) -f Makefile_javasrc clean
cd sblas3;$(MAKE) -f Makefile_javasrc clean
cd eig;$(MAKE) -f Makefile_javasrc clean
cd seig;$(MAKE) -f Makefile_javasrc clean
cd lin;$(MAKE) -f Makefile_javasrc clean
cd slin;$(MAKE) -f Makefile_javasrc clean
cd matgen;$(MAKE) -f Makefile_javasrc clean
cd smatgen;$(MAKE) -f Makefile_javasrc clean
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/sblas1/ 0000755 0001750 0001750 00000000000 11734055025 022403 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/sblas1/sblat1.f 0000644 0001750 0001750 00000074751 10616163237 023761 0 ustar osallou osallou PROGRAM SBLAT1
* Test program for the REAL Level 1 BLAS.
* Based upon the original BLAS test routine together with:
* F06EAF Example Program Text
* .. Parameters ..
INTEGER NOUT
PARAMETER (NOUT=6)
* .. Scalars in Common ..
INTEGER ICASE, INCX, INCY, MODE, N
LOGICAL PASS
* .. Local Scalars ..
REAL SFAC
INTEGER IC
* .. External Subroutines ..
EXTERNAL CHECK0, CHECK1, CHECK2, CHECK3, HEADER
* .. Common blocks ..
COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
* .. Data statements ..
DATA SFAC/9.765625E-4/
* .. Executable Statements ..
WRITE (NOUT,99999)
DO 20 IC = 1, 10
ICASE = IC
CALL HEADER
*
* .. Initialize PASS, INCX, INCY, and MODE for a new case. ..
* .. the value 9999 for INCX, INCY or MODE will appear in the ..
* .. detailed output, if any, for cases that do not involve ..
* .. these parameters ..
*
PASS = .TRUE.
INCX = 9999
INCY = 9999
MODE = 9999
IF (ICASE.EQ.3) THEN
CALL CHECK0(SFAC)
ELSE IF (ICASE.EQ.7 .OR. ICASE.EQ.8 .OR. ICASE.EQ.9 .OR.
+ ICASE.EQ.10) THEN
CALL CHECK1(SFAC)
ELSE IF (ICASE.EQ.1 .OR. ICASE.EQ.2 .OR. ICASE.EQ.5 .OR.
+ ICASE.EQ.6) THEN
CALL CHECK2(SFAC)
ELSE IF (ICASE.EQ.4) THEN
CALL CHECK3(SFAC)
END IF
* -- Print
IF (PASS) WRITE (NOUT,99998)
20 CONTINUE
STOP
*
99999 FORMAT (' Real BLAS Test Program Results',/1X)
99998 FORMAT (' ----- PASS -----')
END
SUBROUTINE HEADER
* .. Parameters ..
INTEGER NOUT
PARAMETER (NOUT=6)
* .. Scalars in Common ..
INTEGER ICASE, INCX, INCY, MODE, N
LOGICAL PASS
* .. Local Arrays ..
CHARACTER*6 L(10)
* .. Common blocks ..
COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
* .. Data statements ..
DATA L(1)/' SDOT '/
DATA L(2)/'SAXPY '/
DATA L(3)/'SROTG '/
DATA L(4)/' SROT '/
DATA L(5)/'SCOPY '/
DATA L(6)/'SSWAP '/
DATA L(7)/'SNRM2 '/
DATA L(8)/'SASUM '/
DATA L(9)/'SSCAL '/
DATA L(10)/'ISAMAX'/
* .. Executable Statements ..
WRITE (NOUT,99999) ICASE, L(ICASE)
RETURN
*
99999 FORMAT (/' Test of subprogram number',I3,12X,A6)
END
SUBROUTINE CHECK0(SFAC)
* .. Parameters ..
INTEGER NOUT
PARAMETER (NOUT=6)
* .. Scalar Arguments ..
REAL SFAC
* .. Scalars in Common ..
INTEGER ICASE, INCX, INCY, MODE, N
LOGICAL PASS
* .. Local Scalars ..
REAL D12, SA, SB, SC, SS
INTEGER K
* .. Local Arrays ..
REAL DA1(8), DATRUE(8), DB1(8), DBTRUE(8), DC1(8),
+ DS1(8)
* .. External Subroutines ..
EXTERNAL SROTG, STEST1
* .. Common blocks ..
COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
* .. Data statements ..
DATA DA1/0.3E0, 0.4E0, -0.3E0, -0.4E0, -0.3E0, 0.0E0,
+ 0.0E0, 1.0E0/
DATA DB1/0.4E0, 0.3E0, 0.4E0, 0.3E0, -0.4E0, 0.0E0,
+ 1.0E0, 0.0E0/
DATA DC1/0.6E0, 0.8E0, -0.6E0, 0.8E0, 0.6E0, 1.0E0,
+ 0.0E0, 1.0E0/
DATA DS1/0.8E0, 0.6E0, 0.8E0, -0.6E0, 0.8E0, 0.0E0,
+ 1.0E0, 0.0E0/
DATA DATRUE/0.5E0, 0.5E0, 0.5E0, -0.5E0, -0.5E0,
+ 0.0E0, 1.0E0, 1.0E0/
DATA DBTRUE/0.0E0, 0.6E0, 0.0E0, -0.6E0, 0.0E0,
+ 0.0E0, 1.0E0, 0.0E0/
DATA D12/4096.0E0/
* .. Executable Statements ..
*
* Compute true values which cannot be prestored
* in decimal notation
*
DBTRUE(1) = 1.0E0/0.6E0
DBTRUE(3) = -1.0E0/0.6E0
DBTRUE(5) = 1.0E0/0.6E0
*
DO 20 K = 1, 8
* .. Set N=K for identification in output if any ..
N = K
IF (ICASE.EQ.3) THEN
* .. SROTG ..
IF (K.GT.8) GO TO 40
SA = DA1(K)
SB = DB1(K)
CALL SROTG(SA,SB,SC,SS)
CALL STEST1(SA,DATRUE(K),DATRUE(K),SFAC)
CALL STEST1(SB,DBTRUE(K),DBTRUE(K),SFAC)
CALL STEST1(SC,DC1(K),DC1(K),SFAC)
CALL STEST1(SS,DS1(K),DS1(K),SFAC)
ELSE
WRITE (NOUT,*) ' Shouldn''t be here in CHECK0'
STOP
END IF
20 CONTINUE
40 RETURN
END
SUBROUTINE CHECK1(SFAC)
* .. Parameters ..
INTEGER NOUT
PARAMETER (NOUT=6)
* .. Scalar Arguments ..
REAL SFAC
* .. Scalars in Common ..
INTEGER ICASE, INCX, INCY, MODE, N
LOGICAL PASS
* .. Local Scalars ..
INTEGER I, LEN, NP1
* .. Local Arrays ..
REAL DTRUE1(5), DTRUE3(5), DTRUE5(8,5,2), DV(8,5,2),
+ SA(10), STEMP(1), STRUE(8), SX(8)
INTEGER ITRUE2(5)
* .. External Functions ..
REAL SASUM, SNRM2
INTEGER ISAMAX
EXTERNAL SASUM, SNRM2, ISAMAX
* .. External Subroutines ..
EXTERNAL ITEST1, SSCAL, STEST, STEST1
* .. Intrinsic Functions ..
INTRINSIC MAX
* .. Common blocks ..
COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
* .. Data statements ..
DATA SA/0.3E0, -1.0E0, 0.0E0, 1.0E0, 0.3E0, 0.3E0,
+ 0.3E0, 0.3E0, 0.3E0, 0.3E0/
DATA DV/0.1E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0,
+ 2.0E0, 2.0E0, 0.3E0, 3.0E0, 3.0E0, 3.0E0, 3.0E0,
+ 3.0E0, 3.0E0, 3.0E0, 0.3E0, -0.4E0, 4.0E0,
+ 4.0E0, 4.0E0, 4.0E0, 4.0E0, 4.0E0, 0.2E0,
+ -0.6E0, 0.3E0, 5.0E0, 5.0E0, 5.0E0, 5.0E0,
+ 5.0E0, 0.1E0, -0.3E0, 0.5E0, -0.1E0, 6.0E0,
+ 6.0E0, 6.0E0, 6.0E0, 0.1E0, 8.0E0, 8.0E0, 8.0E0,
+ 8.0E0, 8.0E0, 8.0E0, 8.0E0, 0.3E0, 9.0E0, 9.0E0,
+ 9.0E0, 9.0E0, 9.0E0, 9.0E0, 9.0E0, 0.3E0, 2.0E0,
+ -0.4E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0,
+ 0.2E0, 3.0E0, -0.6E0, 5.0E0, 0.3E0, 2.0E0,
+ 2.0E0, 2.0E0, 0.1E0, 4.0E0, -0.3E0, 6.0E0,
+ -0.5E0, 7.0E0, -0.1E0, 3.0E0/
DATA DTRUE1/0.0E0, 0.3E0, 0.5E0, 0.7E0, 0.6E0/
DATA DTRUE3/0.0E0, 0.3E0, 0.7E0, 1.1E0, 1.0E0/
DATA DTRUE5/0.10E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0,
+ 2.0E0, 2.0E0, 2.0E0, -0.3E0, 3.0E0, 3.0E0,
+ 3.0E0, 3.0E0, 3.0E0, 3.0E0, 3.0E0, 0.0E0, 0.0E0,
+ 4.0E0, 4.0E0, 4.0E0, 4.0E0, 4.0E0, 4.0E0,
+ 0.20E0, -0.60E0, 0.30E0, 5.0E0, 5.0E0, 5.0E0,
+ 5.0E0, 5.0E0, 0.03E0, -0.09E0, 0.15E0, -0.03E0,
+ 6.0E0, 6.0E0, 6.0E0, 6.0E0, 0.10E0, 8.0E0,
+ 8.0E0, 8.0E0, 8.0E0, 8.0E0, 8.0E0, 8.0E0,
+ 0.09E0, 9.0E0, 9.0E0, 9.0E0, 9.0E0, 9.0E0,
+ 9.0E0, 9.0E0, 0.09E0, 2.0E0, -0.12E0, 2.0E0,
+ 2.0E0, 2.0E0, 2.0E0, 2.0E0, 0.06E0, 3.0E0,
+ -0.18E0, 5.0E0, 0.09E0, 2.0E0, 2.0E0, 2.0E0,
+ 0.03E0, 4.0E0, -0.09E0, 6.0E0, -0.15E0, 7.0E0,
+ -0.03E0, 3.0E0/
DATA ITRUE2/0, 1, 2, 2, 3/
* .. Executable Statements ..
DO 80 INCX = 1, 2
DO 60 NP1 = 1, 5
N = NP1 - 1
LEN = 2*MAX(N,1)
* .. Set vector arguments ..
DO 20 I = 1, LEN
SX(I) = DV(I,NP1,INCX)
20 CONTINUE
*
IF (ICASE.EQ.7) THEN
* .. SNRM2 ..
STEMP(1) = DTRUE1(NP1)
CALL STEST1(SNRM2(N,SX,INCX),STEMP(1),STEMP,SFAC)
ELSE IF (ICASE.EQ.8) THEN
* .. SASUM ..
STEMP(1) = DTRUE3(NP1)
CALL STEST1(SASUM(N,SX,INCX),STEMP(1),STEMP,SFAC)
ELSE IF (ICASE.EQ.9) THEN
* .. SSCAL ..
CALL SSCAL(N,SA((INCX-1)*5+NP1),SX,INCX)
DO 40 I = 1, LEN
STRUE(I) = DTRUE5(I,NP1,INCX)
40 CONTINUE
CALL STEST(LEN,SX,STRUE,STRUE,SFAC)
ELSE IF (ICASE.EQ.10) THEN
* .. ISAMAX ..
CALL ITEST1(ISAMAX(N,SX,INCX),ITRUE2(NP1))
ELSE
WRITE (NOUT,*) ' Shouldn''t be here in CHECK1'
STOP
END IF
60 CONTINUE
80 CONTINUE
RETURN
END
SUBROUTINE CHECK2(SFAC)
* .. Parameters ..
INTEGER NOUT
PARAMETER (NOUT=6)
* .. Scalar Arguments ..
REAL SFAC
* .. Scalars in Common ..
INTEGER ICASE, INCX, INCY, MODE, N
LOGICAL PASS
* .. Local Scalars ..
REAL SA, SC, SS
INTEGER I, J, KI, KN, KSIZE, LENX, LENY, MX, MY
* .. Local Arrays ..
REAL DT10X(7,4,4), DT10Y(7,4,4), DT7(4,4),
+ DT8(7,4,4), DT9X(7,4,4), DT9Y(7,4,4), DX1(7),
+ DY1(7), SSIZE1(4), SSIZE2(14,2), STX(7), STY(7),
+ SX(7), SY(7)
INTEGER INCXS(4), INCYS(4), LENS(4,2), NS(4)
* .. External Functions ..
REAL SDOT
EXTERNAL SDOT
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, SSWAP, STEST, STEST1
* .. Intrinsic Functions ..
INTRINSIC ABS, MIN
* .. Common blocks ..
COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
* .. Data statements ..
DATA SA/0.3E0/
DATA INCXS/1, 2, -2, -1/
DATA INCYS/1, -2, 1, -2/
DATA LENS/1, 1, 2, 4, 1, 1, 3, 7/
DATA NS/0, 1, 2, 4/
DATA DX1/0.6E0, 0.1E0, -0.5E0, 0.8E0, 0.9E0, -0.3E0,
+ -0.4E0/
DATA DY1/0.5E0, -0.9E0, 0.3E0, 0.7E0, -0.6E0, 0.2E0,
+ 0.8E0/
DATA SC, SS/0.8E0, 0.6E0/
DATA DT7/0.0E0, 0.30E0, 0.21E0, 0.62E0, 0.0E0,
+ 0.30E0, -0.07E0, 0.85E0, 0.0E0, 0.30E0, -0.79E0,
+ -0.74E0, 0.0E0, 0.30E0, 0.33E0, 1.27E0/
DATA DT8/0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.68E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.68E0, -0.87E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.68E0, -0.87E0, 0.15E0,
+ 0.94E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.68E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.35E0, -0.9E0, 0.48E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.38E0, -0.9E0, 0.57E0, 0.7E0, -0.75E0,
+ 0.2E0, 0.98E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.68E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.35E0, -0.72E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.38E0,
+ -0.63E0, 0.15E0, 0.88E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.68E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.68E0, -0.9E0, 0.33E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.68E0, -0.9E0, 0.33E0, 0.7E0,
+ -0.75E0, 0.2E0, 1.04E0/
DATA DT9X/0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.78E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.78E0, -0.46E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.78E0, -0.46E0, -0.22E0,
+ 1.06E0, 0.0E0, 0.0E0, 0.0E0, 0.6E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.78E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.66E0, 0.1E0, -0.1E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.96E0, 0.1E0, -0.76E0, 0.8E0, 0.90E0,
+ -0.3E0, -0.02E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.78E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.0E0, -0.06E0, 0.1E0,
+ -0.1E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.90E0,
+ 0.1E0, -0.22E0, 0.8E0, 0.18E0, -0.3E0, -0.02E0,
+ 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.78E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.78E0, 0.26E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.78E0, 0.26E0, -0.76E0, 1.12E0,
+ 0.0E0, 0.0E0, 0.0E0/
DATA DT9Y/0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.04E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.04E0, -0.78E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.04E0, -0.78E0, 0.54E0,
+ 0.08E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.04E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.7E0,
+ -0.9E0, -0.12E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.64E0, -0.9E0, -0.30E0, 0.7E0, -0.18E0, 0.2E0,
+ 0.28E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.04E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.7E0, -1.08E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.64E0, -1.26E0,
+ 0.54E0, 0.20E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.04E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.04E0, -0.9E0, 0.18E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.04E0, -0.9E0, 0.18E0, 0.7E0,
+ -0.18E0, 0.2E0, 0.16E0/
DATA DT10X/0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.5E0, -0.9E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.5E0, -0.9E0, 0.3E0, 0.7E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.3E0, 0.1E0, 0.5E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.8E0, 0.1E0, -0.6E0,
+ 0.8E0, 0.3E0, -0.3E0, 0.5E0, 0.6E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, -0.9E0,
+ 0.1E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.7E0,
+ 0.1E0, 0.3E0, 0.8E0, -0.9E0, -0.3E0, 0.5E0,
+ 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.5E0, 0.3E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.5E0, 0.3E0, -0.6E0, 0.8E0, 0.0E0, 0.0E0,
+ 0.0E0/
DATA DT10Y/0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.6E0, 0.1E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.6E0, 0.1E0, -0.5E0, 0.8E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, -0.5E0, -0.9E0, 0.6E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.0E0, -0.4E0, -0.9E0, 0.9E0,
+ 0.7E0, -0.5E0, 0.2E0, 0.6E0, 0.5E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.6E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, -0.5E0,
+ 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ -0.4E0, 0.9E0, -0.5E0, 0.6E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.6E0, -0.9E0, 0.1E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.6E0, -0.9E0, 0.1E0, 0.7E0,
+ -0.5E0, 0.2E0, 0.8E0/
DATA SSIZE1/0.0E0, 0.3E0, 1.6E0, 3.2E0/
DATA SSIZE2/0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0,
+ 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0,
+ 1.17E0, 1.17E0, 1.17E0/
* .. Executable Statements ..
*
DO 120 KI = 1, 4
INCX = INCXS(KI)
INCY = INCYS(KI)
MX = ABS(INCX)
MY = ABS(INCY)
*
DO 100 KN = 1, 4
N = NS(KN)
KSIZE = MIN(2,KN)
LENX = LENS(KN,MX)
LENY = LENS(KN,MY)
* .. Initialize all argument arrays ..
DO 20 I = 1, 7
SX(I) = DX1(I)
SY(I) = DY1(I)
20 CONTINUE
*
IF (ICASE.EQ.1) THEN
* .. SDOT ..
CALL STEST1(SDOT(N,SX,INCX,SY,INCY),DT7(KN,KI),SSIZE1(KN)
+ ,SFAC)
ELSE IF (ICASE.EQ.2) THEN
* .. SAXPY ..
CALL SAXPY(N,SA,SX,INCX,SY,INCY)
DO 40 J = 1, LENY
STY(J) = DT8(J,KN,KI)
40 CONTINUE
CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC)
ELSE IF (ICASE.EQ.5) THEN
* .. SCOPY ..
DO 60 I = 1, 7
STY(I) = DT10Y(I,KN,KI)
60 CONTINUE
CALL SCOPY(N,SX,INCX,SY,INCY)
CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.0E0)
ELSE IF (ICASE.EQ.6) THEN
* .. SSWAP ..
CALL SSWAP(N,SX,INCX,SY,INCY)
DO 80 I = 1, 7
STX(I) = DT10X(I,KN,KI)
STY(I) = DT10Y(I,KN,KI)
80 CONTINUE
CALL STEST(LENX,SX,STX,SSIZE2(1,1),1.0E0)
CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.0E0)
ELSE
WRITE (NOUT,*) ' Shouldn''t be here in CHECK2'
STOP
END IF
100 CONTINUE
120 CONTINUE
RETURN
END
SUBROUTINE CHECK3(SFAC)
* .. Parameters ..
INTEGER NOUT
PARAMETER (NOUT=6)
* .. Scalar Arguments ..
REAL SFAC
* .. Scalars in Common ..
INTEGER ICASE, INCX, INCY, MODE, N
LOGICAL PASS
* .. Local Scalars ..
REAL SA, SC, SS
INTEGER I, K, KI, KN, KSIZE, LENX, LENY, MX, MY
* .. Local Arrays ..
REAL COPYX(5), COPYY(5), DT9X(7,4,4), DT9Y(7,4,4),
+ DX1(7), DY1(7), MWPC(11), MWPS(11), MWPSTX(5),
+ MWPSTY(5), MWPTX(11,5), MWPTY(11,5), MWPX(5),
+ MWPY(5), SSIZE2(14,2), STX(7), STY(7), SX(7),
+ SY(7)
INTEGER INCXS(4), INCYS(4), LENS(4,2), MWPINX(11),
+ MWPINY(11), MWPN(11), NS(4)
* .. External Subroutines ..
EXTERNAL SROT, STEST
* .. Intrinsic Functions ..
INTRINSIC ABS, MIN
* .. Common blocks ..
COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
* .. Data statements ..
DATA SA/0.3E0/
DATA INCXS/1, 2, -2, -1/
DATA INCYS/1, -2, 1, -2/
DATA LENS/1, 1, 2, 4, 1, 1, 3, 7/
DATA NS/0, 1, 2, 4/
DATA DX1/0.6E0, 0.1E0, -0.5E0, 0.8E0, 0.9E0, -0.3E0,
+ -0.4E0/
DATA DY1/0.5E0, -0.9E0, 0.3E0, 0.7E0, -0.6E0, 0.2E0,
+ 0.8E0/
DATA SC, SS/0.8E0, 0.6E0/
DATA DT9X/0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.78E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.78E0, -0.46E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.78E0, -0.46E0, -0.22E0,
+ 1.06E0, 0.0E0, 0.0E0, 0.0E0, 0.6E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.78E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.66E0, 0.1E0, -0.1E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.96E0, 0.1E0, -0.76E0, 0.8E0, 0.90E0,
+ -0.3E0, -0.02E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.78E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.0E0, -0.06E0, 0.1E0,
+ -0.1E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.90E0,
+ 0.1E0, -0.22E0, 0.8E0, 0.18E0, -0.3E0, -0.02E0,
+ 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.78E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.78E0, 0.26E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.78E0, 0.26E0, -0.76E0, 1.12E0,
+ 0.0E0, 0.0E0, 0.0E0/
DATA DT9Y/0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.04E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.04E0, -0.78E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.04E0, -0.78E0, 0.54E0,
+ 0.08E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.04E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.7E0,
+ -0.9E0, -0.12E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.64E0, -0.9E0, -0.30E0, 0.7E0, -0.18E0, 0.2E0,
+ 0.28E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.04E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.7E0, -1.08E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.64E0, -1.26E0,
+ 0.54E0, 0.20E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.04E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.04E0, -0.9E0, 0.18E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.04E0, -0.9E0, 0.18E0, 0.7E0,
+ -0.18E0, 0.2E0, 0.16E0/
DATA SSIZE2/0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0,
+ 0.0E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0,
+ 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0,
+ 1.17E0, 1.17E0, 1.17E0/
* .. Executable Statements ..
*
DO 60 KI = 1, 4
INCX = INCXS(KI)
INCY = INCYS(KI)
MX = ABS(INCX)
MY = ABS(INCY)
*
DO 40 KN = 1, 4
N = NS(KN)
KSIZE = MIN(2,KN)
LENX = LENS(KN,MX)
LENY = LENS(KN,MY)
*
IF (ICASE.EQ.4) THEN
* .. SROT ..
DO 20 I = 1, 7
SX(I) = DX1(I)
SY(I) = DY1(I)
STX(I) = DT9X(I,KN,KI)
STY(I) = DT9Y(I,KN,KI)
20 CONTINUE
CALL SROT(N,SX,INCX,SY,INCY,SC,SS)
CALL STEST(LENX,SX,STX,SSIZE2(1,KSIZE),SFAC)
CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC)
ELSE
WRITE (NOUT,*) ' Shouldn''t be here in CHECK3'
STOP
END IF
40 CONTINUE
60 CONTINUE
*
MWPC(1) = 1
DO 80 I = 2, 11
MWPC(I) = 0
80 CONTINUE
MWPS(1) = 0
DO 100 I = 2, 6
MWPS(I) = 1
100 CONTINUE
DO 120 I = 7, 11
MWPS(I) = -1
120 CONTINUE
MWPINX(1) = 1
MWPINX(2) = 1
MWPINX(3) = 1
MWPINX(4) = -1
MWPINX(5) = 1
MWPINX(6) = -1
MWPINX(7) = 1
MWPINX(8) = 1
MWPINX(9) = -1
MWPINX(10) = 1
MWPINX(11) = -1
MWPINY(1) = 1
MWPINY(2) = 1
MWPINY(3) = -1
MWPINY(4) = -1
MWPINY(5) = 2
MWPINY(6) = 1
MWPINY(7) = 1
MWPINY(8) = -1
MWPINY(9) = -1
MWPINY(10) = 2
MWPINY(11) = 1
DO 140 I = 1, 11
MWPN(I) = 5
140 CONTINUE
MWPN(5) = 3
MWPN(10) = 3
DO 160 I = 1, 5
MWPX(I) = I
MWPY(I) = I
MWPTX(1,I) = I
MWPTY(1,I) = I
MWPTX(2,I) = I
MWPTY(2,I) = -I
MWPTX(3,I) = 6 - I
MWPTY(3,I) = I - 6
MWPTX(4,I) = I
MWPTY(4,I) = -I
MWPTX(6,I) = 6 - I
MWPTY(6,I) = I - 6
MWPTX(7,I) = -I
MWPTY(7,I) = I
MWPTX(8,I) = I - 6
MWPTY(8,I) = 6 - I
MWPTX(9,I) = -I
MWPTY(9,I) = I
MWPTX(11,I) = I - 6
MWPTY(11,I) = 6 - I
160 CONTINUE
MWPTX(5,1) = 1
MWPTX(5,2) = 3
MWPTX(5,3) = 5
MWPTX(5,4) = 4
MWPTX(5,5) = 5
MWPTY(5,1) = -1
MWPTY(5,2) = 2
MWPTY(5,3) = -2
MWPTY(5,4) = 4
MWPTY(5,5) = -3
MWPTX(10,1) = -1
MWPTX(10,2) = -3
MWPTX(10,3) = -5
MWPTX(10,4) = 4
MWPTX(10,5) = 5
MWPTY(10,1) = 1
MWPTY(10,2) = 2
MWPTY(10,3) = 2
MWPTY(10,4) = 4
MWPTY(10,5) = 3
DO 200 I = 1, 11
INCX = MWPINX(I)
INCY = MWPINY(I)
DO 180 K = 1, 5
COPYX(K) = MWPX(K)
COPYY(K) = MWPY(K)
MWPSTX(K) = MWPTX(I,K)
MWPSTY(K) = MWPTY(I,K)
180 CONTINUE
CALL SROT(MWPN(I),COPYX,INCX,COPYY,INCY,MWPC(I),MWPS(I))
CALL STEST(5,COPYX,MWPSTX,MWPSTX,SFAC)
CALL STEST(5,COPYY,MWPSTY,MWPSTY,SFAC)
200 CONTINUE
RETURN
END
SUBROUTINE STEST(LEN,SCOMP,STRUE,SSIZE,SFAC)
* ********************************* STEST **************************
*
* THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO
* SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE
* NEGLIGIBLE.
*
* C. L. LAWSON, JPL, 1974 DEC 10
*
* .. Parameters ..
INTEGER NOUT
PARAMETER (NOUT=6)
* .. Scalar Arguments ..
REAL SFAC
INTEGER LEN
* .. Array Arguments ..
REAL SCOMP(LEN), SSIZE(LEN), STRUE(LEN)
* .. Scalars in Common ..
INTEGER ICASE, INCX, INCY, MODE, N
LOGICAL PASS
* .. Local Scalars ..
REAL SD
INTEGER I
* .. External Functions ..
REAL SDIFF
EXTERNAL SDIFF
* .. Intrinsic Functions ..
INTRINSIC ABS
* .. Common blocks ..
COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
* .. Executable Statements ..
*
DO 40 I = 1, LEN
SD = SCOMP(I) - STRUE(I)
IF (SDIFF(ABS(SSIZE(I))+ABS(SFAC*SD),ABS(SSIZE(I))).EQ.0.0E0)
+ GO TO 40
*
* HERE SCOMP(I) IS NOT CLOSE TO STRUE(I).
*
IF ( .NOT. PASS) GO TO 20
* PRINT FAIL MESSAGE AND HEADER.
PASS = .FALSE.
WRITE (NOUT,99999)
WRITE (NOUT,99998)
20 WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, I, SCOMP(I),
+ STRUE(I), SD, SSIZE(I)
40 CONTINUE
RETURN
*
99999 FORMAT (' FAIL')
99998 FORMAT (/' CASE N INCX INCY MODE I ',
+ ' COMP(I) TRUE(I) DIFFERENCE',
+ ' SIZE(I)',/1X)
99997 FORMAT (1X,I4,I3,3I5,I3,2E36.8,2E12.4)
END
SUBROUTINE STEST1(SCOMP1,STRUE1,SSIZE,SFAC)
* ************************* STEST1 *****************************
*
* THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN
* REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE
* ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT.
*
* C.L. LAWSON, JPL, 1978 DEC 6
*
* .. Scalar Arguments ..
REAL SCOMP1, SFAC, STRUE1
* .. Array Arguments ..
REAL SSIZE(*)
* .. Local Arrays ..
REAL SCOMP(1), STRUE(1)
* .. External Subroutines ..
EXTERNAL STEST
* .. Executable Statements ..
*
SCOMP(1) = SCOMP1
STRUE(1) = STRUE1
CALL STEST(1,SCOMP,STRUE,SSIZE,SFAC)
*
RETURN
END
REAL FUNCTION SDIFF(SA,SB)
* ********************************* SDIFF **************************
* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15
*
* .. Scalar Arguments ..
REAL SA, SB
* .. Executable Statements ..
SDIFF = SA - SB
RETURN
END
SUBROUTINE ITEST1(ICOMP,ITRUE)
* ********************************* ITEST1 *************************
*
* THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR
* EQUALITY.
* C. L. LAWSON, JPL, 1974 DEC 10
*
* .. Parameters ..
INTEGER NOUT
PARAMETER (NOUT=6)
* .. Scalar Arguments ..
INTEGER ICOMP, ITRUE
* .. Scalars in Common ..
INTEGER ICASE, INCX, INCY, MODE, N
LOGICAL PASS
* .. Local Scalars ..
INTEGER ID
* .. Common blocks ..
COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
* .. Executable Statements ..
*
IF (ICOMP.EQ.ITRUE) GO TO 40
*
* HERE ICOMP IS NOT EQUAL TO ITRUE.
*
IF ( .NOT. PASS) GO TO 20
* PRINT FAIL MESSAGE AND HEADER.
PASS = .FALSE.
WRITE (NOUT,99999)
WRITE (NOUT,99998)
20 ID = ICOMP - ITRUE
WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, ICOMP, ITRUE, ID
40 CONTINUE
RETURN
*
99999 FORMAT (' FAIL')
99998 FORMAT (/' CASE N INCX INCY MODE ',
+ ' COMP TRUE DIFFERENCE',
+ /1X)
99997 FORMAT (1X,I4,I3,3I5,2I36,I12)
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/sblas1/Makefile_javasrc 0000644 0001750 0001750 00000002522 10616442121 025550 0 ustar osallou osallou .SUFFIXES: .f .java
ROOT=../../..
include $(ROOT)/make.def
tester: $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(SBLAS1TEST_IDX) $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
/bin/rm -f `find . -name "*.class"`
mkdir -p $(JAVASRC_OUTDIR)
$(JAVAC) -classpath $(JAVASRC_OUTDIR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) -d $(JAVASRC_OUTDIR) $(OUTDIR)/$(SBLASTEST_PDIR)/*.java
/bin/rm -f $(JAVASRC_OUTDIR)/$(SBLASTEST_PDIR)/*.old
$(JAVAB) $(JAVASRC_OUTDIR)/$(SBLASTEST_PDIR)/*.class
/bin/rm -f $(SBLAS1TEST_JAR)
cd $(JAVASRC_OUTDIR); $(JAR) cvf ../$(SBLAS1TEST_JAR) `find . -name "*.class"`
$(ROOT)/$(SBLAS1TEST_IDX): sblat1.f
$(MAKE) nojar
$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):
cd $(ROOT)/$(BLAS_DIR); $(MAKE) -f Makefile_javasrc
$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):
cd $(ROOT)/$(UTIL_DIR); $(MAKE)
runtest: tester
$(JAVA) $(JFLAGS) -cp .:$(SBLAS1TEST_JAR):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR) $(SBLASTEST_PACKAGE).Sblat1
verify: $(ROOT)/$(SBLAS1TEST_IDX)
cd $(JAVASRC_OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR) $(VERIFY) $(SBLASTEST_PDIR)/*.class
clean:
/bin/rm -rf *.java *.class *.f2j $(OUTDIR) $(JAVASRC_OUTDIR) $(SBLAS1TEST_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/sblas1/Makefile 0000644 0001750 0001750 00000002274 10616442121 024043 0 ustar osallou osallou .SUFFIXES: .f .java
ROOT=../../..
include $(ROOT)/make.def
F2JFLAGS=-c .:$(ROOT)/$(BLAS_OBJ) -p $(SBLASTEST_PACKAGE) -o $(OUTDIR) $(STATIC)
tester: $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(SBLAS1TEST_IDX) $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
/bin/rm -f $(SBLAS1TEST_JAR)
cd $(OUTDIR); $(JAR) cvf ../$(SBLAS1TEST_JAR) `find . -name "*.class"`
nojar: $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(SBLAS1TEST_IDX) $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
$(ROOT)/$(SBLAS1TEST_IDX): sblat1.f
$(F2J) $(F2JFLAGS) $< > /dev/null
$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):
cd $(ROOT)/$(BLAS_DIR); $(MAKE)
$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):
cd $(ROOT)/$(UTIL_DIR); $(MAKE)
runtest: tester
$(JAVA) $(JFLAGS) -cp .:$(SBLAS1TEST_JAR):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR) $(SBLASTEST_PACKAGE).Sblat1
srctest:
$(MAKE) -f Makefile_javasrc runtest
verify: $(ROOT)/$(SBLAS1TEST_IDX)
cd $(OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR) $(VERIFY) $(SBLASTEST_PDIR)/*.class
clean:
/bin/rm -rf *.java *.class *.f2j $(OUTDIR) $(JAVASRC_OUTDIR) $(SBLAS1TEST_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/sblas3/ 0000755 0001750 0001750 00000000000 11734055025 022405 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/sblas3/Makefile_javasrc 0000644 0001750 0001750 00000002651 10616442122 025556 0 ustar osallou osallou .SUFFIXES: .f .java
ROOT=../../..
include $(ROOT)/make.def
tester: $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(SBLAS3TEST_IDX) $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
/bin/rm -f `find $(OUTDIR) -name "*.class"`
mkdir -p $(JAVASRC_OUTDIR)
$(JAVAC) -classpath .:$(JAVASRC_OUTDIR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) -d $(JAVASRC_OUTDIR) $(OUTDIR)/$(SBLASTEST_PDIR)/*.java
/bin/rm -f $(JAVASRC_OUTDIR)/$(SBLASTEST_PDIR)/*.old
$(JAVAB) $(JAVASRC_OUTDIR)/$(SBLASTEST_PDIR)/*.class
/bin/rm -f $(SBLAS3TEST_JAR)
cd $(JAVASRC_OUTDIR); $(JAR) cvf ../$(SBLAS3TEST_JAR) `find . -name "*.class"`
$(JAR) uvf $(SBLAS3TEST_JAR) `find org -name "*.class"`
$(ROOT)/$(SBLAS3TEST_IDX): sblat3.f
$(MAKE) nojar
$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):
cd $(ROOT)/$(BLAS_DIR); $(MAKE) -f Makefile_javasrc
$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):
cd $(ROOT)/$(UTIL_DIR); $(MAKE)
runtest: tester
$(JAVA) $(JFLAGS) -cp .:$(SBLAS3TEST_JAR):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR) $(SBLASTEST_PACKAGE).Sblat3 < sblat3.in
verify: $(ROOT)/$(SBLAS3TEST_IDX)
cd $(JAVASRC_OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:..:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR) $(VERIFY) $(SBLASTEST_PDIR)/*.class
clean:
/bin/rm -rf *.java *.class *.f2j org $(OUTDIR) $(JAVASRC_OUTDIR) $(SBLAS3TEST_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/sblas3/Makefile 0000644 0001750 0001750 00000002543 10616442122 024045 0 ustar osallou osallou .SUFFIXES: .f .java
ROOT=../../..
include $(ROOT)/make.def
XERBLAFLAGS= -c .:$(ROOT)/$(BLAS_OBJ) -p $(ERR_PACKAGE)
F2JFLAGS=-c .:$(ROOT)/$(BLAS_OBJ) -p $(SBLASTEST_PACKAGE) -o $(OUTDIR) $(STATIC)
tester: $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(SBLAS3TEST_IDX) $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
/bin/rm -f $(SBLAS3TEST_JAR)
cd $(OUTDIR); $(JAR) cvf ../$(SBLAS3TEST_JAR) `find . -name "*.class"`
$(JAR) uvf $(SBLAS3TEST_JAR) `find org -name "*.class"`
nojar: $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(SBLAS3TEST_IDX) $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
$(ROOT)/$(SBLAS3TEST_IDX): sblat3.f
$(F2J) $(XERBLAFLAGS) xerbla.f > /dev/null
$(F2J) $(F2JFLAGS) $< > /dev/null
$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):
cd $(ROOT)/$(BLAS_DIR); $(MAKE)
$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):
cd $(ROOT)/$(UTIL_DIR); $(MAKE)
runtest: tester
$(JAVA) $(JFLAGS) -cp .:$(SBLAS3TEST_JAR):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR) $(SBLASTEST_PACKAGE).Sblat3 < sblat3.in
srctest:
$(MAKE) -f Makefile_javasrc
verify: $(ROOT)/$(SBLAS3TEST_IDX)
cd $(OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:..:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR) $(VERIFY) $(SBLASTEST_PDIR)/*.class
clean:
/bin/rm -rf *.java *.class *.f2j org $(OUTDIR) $(JAVASRC_OUTDIR) $(SBLAS3TEST_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/sblas3/sblat3.in 0000644 0001750 0001750 00000001562 10616163240 024126 0 ustar osallou osallou 'sblat3.out' NAME OF SUMMARY OUTPUT FILE
6 UNIT NUMBER OF SUMMARY FILE
'SBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE
-1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
F LOGICAL FLAG, T TO STOP ON FAILURES.
T LOGICAL FLAG, T TO TEST ERROR EXITS.
16.0 THRESHOLD VALUE OF TEST RATIO
6 NUMBER OF VALUES OF N
0 1 2 3 5 9 VALUES OF N
3 NUMBER OF VALUES OF ALPHA
0.0 1.0 0.7 VALUES OF ALPHA
3 NUMBER OF VALUES OF BETA
0.0 1.0 1.3 VALUES OF BETA
SGEMM T PUT F FOR NO TEST. SAME COLUMNS.
SSYMM T PUT F FOR NO TEST. SAME COLUMNS.
STRMM T PUT F FOR NO TEST. SAME COLUMNS.
STRSM T PUT F FOR NO TEST. SAME COLUMNS.
SSYRK T PUT F FOR NO TEST. SAME COLUMNS.
SSYR2K T PUT F FOR NO TEST. SAME COLUMNS.
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/sblas3/sblat3.f 0000644 0001750 0001750 00000306505 10616163240 023752 0 ustar osallou osallou PROGRAM SBLAT3
*
* Test program for the REAL Level 3 Blas.
*
* The program must be driven by a short data file. The first 14 records
* of the file are read using list-directed input, the last 6 records
* are read using the format ( A6, L2 ). An annotated example of a data
* file can be obtained by deleting the first 3 characters from the
* following 20 lines:
* 'sblat3.out' NAME OF SUMMARY OUTPUT FILE
* 6 UNIT NUMBER OF SUMMARY FILE
* 'SBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE
* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
* F LOGICAL FLAG, T TO STOP ON FAILURES.
* T LOGICAL FLAG, T TO TEST ERROR EXITS.
* 16.0 THRESHOLD VALUE OF TEST RATIO
* 6 NUMBER OF VALUES OF N
* 0 1 2 3 5 9 VALUES OF N
* 3 NUMBER OF VALUES OF ALPHA
* 0.0 1.0 0.7 VALUES OF ALPHA
* 3 NUMBER OF VALUES OF BETA
* 0.0 1.0 1.3 VALUES OF BETA
* SGEMM T PUT F FOR NO TEST. SAME COLUMNS.
* SSYMM T PUT F FOR NO TEST. SAME COLUMNS.
* STRMM T PUT F FOR NO TEST. SAME COLUMNS.
* STRSM T PUT F FOR NO TEST. SAME COLUMNS.
* SSYRK T PUT F FOR NO TEST. SAME COLUMNS.
* SSYR2K T PUT F FOR NO TEST. SAME COLUMNS.
*
* See:
*
* Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S.
* A Set of Level 3 Basic Linear Algebra Subprograms.
*
* Technical Memorandum No.88 (Revision 1), Mathematics and
* Computer Science Division, Argonne National Laboratory, 9700
* South Cass Avenue, Argonne, Illinois 60439, US.
*
* -- 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.
*
* 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers
* can be run multiple times without deleting generated
* output files (susan)
*
* .. Parameters ..
INTEGER NIN
PARAMETER ( NIN = 5 )
INTEGER NSUBS
PARAMETER ( NSUBS = 6 )
REAL ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 )
INTEGER NMAX
PARAMETER ( NMAX = 65 )
INTEGER NIDMAX, NALMAX, NBEMAX
PARAMETER ( NIDMAX = 9, NALMAX = 7, NBEMAX = 7 )
* .. Local Scalars ..
REAL EPS, ERR, THRESH
INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA
LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
$ TSTERR
CHARACTER*1 TRANSA, TRANSB
CHARACTER*6 SNAMET
CHARACTER*32 SNAPS, SUMMRY
* .. Local Arrays ..
REAL AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ),
$ ALF( NALMAX ), AS( NMAX*NMAX ),
$ BB( NMAX*NMAX ), BET( NBEMAX ),
$ BS( NMAX*NMAX ), C( NMAX, NMAX ),
$ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ),
$ G( NMAX ), W( 2*NMAX )
INTEGER IDIM( NIDMAX )
LOGICAL LTEST( NSUBS )
CHARACTER*6 SNAMES( NSUBS )
* .. External Functions ..
REAL SDIFF
LOGICAL LSE
EXTERNAL SDIFF, LSE
* .. External Subroutines ..
EXTERNAL SCHK1, SCHK2, SCHK3, SCHK4, SCHK5, SCHKE, SMMCH
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
COMMON /SRNAMC/SRNAMT
* .. Data statements ..
DATA SNAMES/'SGEMM ', 'SSYMM ', 'STRMM ', 'STRSM ',
$ 'SSYRK ', 'SSYR2K'/
* .. Executable Statements ..
*
* Read name and unit number for summary output file and open file.
*
READ( NIN, FMT = * )SUMMRY
READ( NIN, FMT = * )NOUT
OPEN( NOUT, FILE = SUMMRY )
NOUTC = NOUT
*
* Read name and unit number for snapshot output file and open file.
*
READ( NIN, FMT = * )SNAPS
READ( NIN, FMT = * )NTRA
TRACE = NTRA.GE.0
IF( TRACE )THEN
OPEN( NTRA, FILE = SNAPS )
END IF
* Read the flag that directs rewinding of the snapshot file.
READ( NIN, FMT = * )REWI
REWI = REWI.AND.TRACE
* Read the flag that directs stopping on any failure.
READ( NIN, FMT = * )SFATAL
* Read the flag that indicates whether error exits are to be tested.
READ( NIN, FMT = * )TSTERR
* Read the threshold value of the test ratio
READ( NIN, FMT = * )THRESH
*
* Read and check the parameter values for the tests.
*
* Values of N
READ( NIN, FMT = * )NIDIM
IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN
WRITE( NOUT, FMT = 9997 )'N', NIDMAX
GO TO 220
END IF
READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM )
DO 10 I = 1, NIDIM
IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN
WRITE( NOUT, FMT = 9996 )NMAX
GO TO 220
END IF
10 CONTINUE
* Values of ALPHA
READ( NIN, FMT = * )NALF
IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN
WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX
GO TO 220
END IF
READ( NIN, FMT = * )( ALF( I ), I = 1, NALF )
* Values of BETA
READ( NIN, FMT = * )NBET
IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN
WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX
GO TO 220
END IF
READ( NIN, FMT = * )( BET( I ), I = 1, NBET )
*
* Report values of parameters.
*
WRITE( NOUT, FMT = 9995 )
WRITE( NOUT, FMT = 9994 )( IDIM( I ), I = 1, NIDIM )
WRITE( NOUT, FMT = 9993 )( ALF( I ), I = 1, NALF )
WRITE( NOUT, FMT = 9992 )( BET( I ), I = 1, NBET )
IF( .NOT.TSTERR )THEN
WRITE( NOUT, FMT = * )
WRITE( NOUT, FMT = 9984 )
END IF
WRITE( NOUT, FMT = * )
WRITE( NOUT, FMT = 9999 )THRESH
WRITE( NOUT, FMT = * )
*
* Read names of subroutines and flags which indicate
* whether they are to be tested.
*
DO 20 I = 1, NSUBS
LTEST( I ) = .FALSE.
20 CONTINUE
30 READ( NIN, FMT = 9988, END = 60 )SNAMET, LTESTT
DO 40 I = 1, NSUBS
IF( SNAMET.EQ.SNAMES( I ) )
$ GO TO 50
40 CONTINUE
WRITE( NOUT, FMT = 9990 )SNAMET
STOP
50 LTEST( I ) = LTESTT
GO TO 30
*
60 CONTINUE
CLOSE ( NIN )
*
* Compute EPS (the machine precision).
*
EPS = ONE
70 CONTINUE
IF( SDIFF( ONE + EPS, ONE ).EQ.ZERO )
$ GO TO 80
EPS = HALF*EPS
GO TO 70
80 CONTINUE
EPS = EPS + EPS
WRITE( NOUT, FMT = 9998 )EPS
*
* Check the reliability of SMMCH using exact data.
*
N = MIN( 32, NMAX )
DO 100 J = 1, N
DO 90 I = 1, N
AB( I, J ) = MAX( I - J + 1, 0 )
90 CONTINUE
AB( J, NMAX + 1 ) = J
AB( 1, NMAX + J ) = J
C( J, 1 ) = ZERO
100 CONTINUE
DO 110 J = 1, N
CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3
110 CONTINUE
* CC holds the exact result. On exit from SMMCH CT holds
* the result computed by SMMCH.
TRANSA = 'N'
TRANSB = 'N'
CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
$ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
$ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
SAME = LSE( CC, CT, N )
IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
STOP
END IF
TRANSB = 'T'
CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
$ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
$ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
SAME = LSE( CC, CT, N )
IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
STOP
END IF
DO 120 J = 1, N
AB( J, NMAX + 1 ) = N - J + 1
AB( 1, NMAX + J ) = N - J + 1
120 CONTINUE
DO 130 J = 1, N
CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 -
$ ( ( J + 1 )*J*( J - 1 ) )/3
130 CONTINUE
TRANSA = 'T'
TRANSB = 'N'
CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
$ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
$ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
SAME = LSE( CC, CT, N )
IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
STOP
END IF
TRANSB = 'T'
CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
$ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
$ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
SAME = LSE( CC, CT, N )
IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
STOP
END IF
*
* Test each subroutine in turn.
*
DO 200 ISNUM = 1, NSUBS
WRITE( NOUT, FMT = * )
IF( .NOT.LTEST( ISNUM ) )THEN
* Subprogram is not to be tested.
WRITE( NOUT, FMT = 9987 )SNAMES( ISNUM )
ELSE
SRNAMT = SNAMES( ISNUM )
* Test error exits.
IF( TSTERR )THEN
CALL SCHKE( ISNUM, SNAMES( ISNUM ), NOUT )
WRITE( NOUT, FMT = * )
END IF
* Test computations.
INFOT = 0
OK = .TRUE.
FATAL = .FALSE.
GO TO ( 140, 150, 160, 160, 170, 180 )ISNUM
* Test SGEMM, 01.
140 CALL SCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
$ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
$ CC, CS, CT, G )
GO TO 190
* Test SSYMM, 02.
150 CALL SCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
$ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
$ CC, CS, CT, G )
GO TO 190
* Test STRMM, 03, STRSM, 04.
160 CALL SCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB,
$ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C )
GO TO 190
* Test SSYRK, 05.
170 CALL SCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
$ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
$ CC, CS, CT, G )
GO TO 190
* Test SSYR2K, 06.
180 CALL SCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
$ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W )
GO TO 190
*
190 IF( FATAL.AND.SFATAL )
$ GO TO 210
END IF
200 CONTINUE
WRITE( NOUT, FMT = 9986 )
GO TO 230
*
210 CONTINUE
WRITE( NOUT, FMT = 9985 )
GO TO 230
*
220 CONTINUE
WRITE( NOUT, FMT = 9991 )
*
230 CONTINUE
IF( TRACE )
$ CLOSE ( NTRA )
CLOSE ( NOUT )
STOP
*
9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES',
$ 'S THAN', F8.2 )
9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 )
9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ',
$ 'THAN ', I2 )
9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 )
9995 FORMAT( ' TESTS OF THE REAL LEVEL 3 BLAS', //' THE F',
$ 'OLLOWING PARAMETER VALUES WILL BE USED:' )
9994 FORMAT( ' FOR N ', 9I6 )
9993 FORMAT( ' FOR ALPHA ', 7F6.1 )
9992 FORMAT( ' FOR BETA ', 7F6.1 )
9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
$ /' ******* TESTS ABANDONED *******' )
9990 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T',
$ 'ESTS ABANDONED *******' )
9989 FORMAT( ' ERROR IN SMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
$ 'ATED WRONGLY.', /' SMMCH WAS CALLED WITH TRANSA = ', A1,
$ ' AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ',
$ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ',
$ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ',
$ '*******' )
9988 FORMAT( A6, L2 )
9987 FORMAT( 1X, A6, ' WAS NOT TESTED' )
9986 FORMAT( /' END OF TESTS' )
9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
*
* End of SBLAT3.
*
END
SUBROUTINE SCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
$ A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
*
* Tests SGEMM.
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- 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.
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0 )
* .. Scalar Arguments ..
REAL EPS, THRESH
INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
LOGICAL FATAL, REWI, TRACE
CHARACTER*6 SNAME
* .. Array Arguments ..
REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), B( NMAX, NMAX ),
$ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
$ C( NMAX, NMAX ), CC( NMAX*NMAX ),
$ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
INTEGER IDIM( NIDIM )
* .. Local Scalars ..
REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX
INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA,
$ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M,
$ MA, MB, MS, N, NA, NARGS, NB, NC, NS
LOGICAL NULL, RESET, SAME, TRANA, TRANB
CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB
CHARACTER*3 ICH
* .. Local Arrays ..
LOGICAL ISAME( 13 )
* .. External Functions ..
LOGICAL LSE, LSERES
EXTERNAL LSE, LSERES
* .. External Subroutines ..
EXTERNAL SGEMM, SMAKE, SMMCH
* .. Intrinsic Functions ..
INTRINSIC MAX
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
* .. Data statements ..
DATA ICH/'NTC'/
* .. Executable Statements ..
*
NARGS = 13
NC = 0
RESET = .TRUE.
ERRMAX = ZERO
*
DO 110 IM = 1, NIDIM
M = IDIM( IM )
*
DO 100 IN = 1, NIDIM
N = IDIM( IN )
* Set LDC to 1 more than minimum value if room.
LDC = M
IF( LDC.LT.NMAX )
$ LDC = LDC + 1
* Skip tests if not enough room.
IF( LDC.GT.NMAX )
$ GO TO 100
LCC = LDC*N
NULL = N.LE.0.OR.M.LE.0
*
DO 90 IK = 1, NIDIM
K = IDIM( IK )
*
DO 80 ICA = 1, 3
TRANSA = ICH( ICA: ICA )
TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
*
IF( TRANA )THEN
MA = K
NA = M
ELSE
MA = M
NA = K
END IF
* Set LDA to 1 more than minimum value if room.
LDA = MA
IF( LDA.LT.NMAX )
$ LDA = LDA + 1
* Skip tests if not enough room.
IF( LDA.GT.NMAX )
$ GO TO 80
LAA = LDA*NA
*
* Generate the matrix A.
*
CALL SMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA,
$ RESET, ZERO )
*
DO 70 ICB = 1, 3
TRANSB = ICH( ICB: ICB )
TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
*
IF( TRANB )THEN
MB = N
NB = K
ELSE
MB = K
NB = N
END IF
* Set LDB to 1 more than minimum value if room.
LDB = MB
IF( LDB.LT.NMAX )
$ LDB = LDB + 1
* Skip tests if not enough room.
IF( LDB.GT.NMAX )
$ GO TO 70
LBB = LDB*NB
*
* Generate the matrix B.
*
CALL SMAKE( 'GE', ' ', ' ', MB, NB, B, NMAX, BB,
$ LDB, RESET, ZERO )
*
DO 60 IA = 1, NALF
ALPHA = ALF( IA )
*
DO 50 IB = 1, NBET
BETA = BET( IB )
*
* Generate the matrix C.
*
CALL SMAKE( 'GE', ' ', ' ', M, N, C, NMAX,
$ CC, LDC, RESET, ZERO )
*
NC = NC + 1
*
* Save every datum before calling the
* subroutine.
*
TRANAS = TRANSA
TRANBS = TRANSB
MS = M
NS = N
KS = K
ALS = ALPHA
DO 10 I = 1, LAA
AS( I ) = AA( I )
10 CONTINUE
LDAS = LDA
DO 20 I = 1, LBB
BS( I ) = BB( I )
20 CONTINUE
LDBS = LDB
BLS = BETA
DO 30 I = 1, LCC
CS( I ) = CC( I )
30 CONTINUE
LDCS = LDC
*
* Call the subroutine.
*
IF( TRACE )
$ WRITE( NTRA, FMT = 9995 )NC, SNAME,
$ TRANSA, TRANSB, M, N, K, ALPHA, LDA, LDB,
$ BETA, LDC
IF( REWI )
$ REWIND NTRA
CALL SGEMM( TRANSA, TRANSB, M, N, K, ALPHA,
$ AA, LDA, BB, LDB, BETA, CC, LDC )
*
* Check if error-exit was taken incorrectly.
*
IF( .NOT.OK )THEN
WRITE( NOUT, FMT = 9994 )
FATAL = .TRUE.
GO TO 120
END IF
*
* See what data changed inside subroutines.
*
ISAME( 1 ) = TRANSA.EQ.TRANAS
ISAME( 2 ) = TRANSB.EQ.TRANBS
ISAME( 3 ) = MS.EQ.M
ISAME( 4 ) = NS.EQ.N
ISAME( 5 ) = KS.EQ.K
ISAME( 6 ) = ALS.EQ.ALPHA
ISAME( 7 ) = LSE( AS, AA, LAA )
ISAME( 8 ) = LDAS.EQ.LDA
ISAME( 9 ) = LSE( BS, BB, LBB )
ISAME( 10 ) = LDBS.EQ.LDB
ISAME( 11 ) = BLS.EQ.BETA
IF( NULL )THEN
ISAME( 12 ) = LSE( CS, CC, LCC )
ELSE
ISAME( 12 ) = LSERES( 'GE', ' ', M, N, CS,
$ CC, LDC )
END IF
ISAME( 13 ) = LDCS.EQ.LDC
*
* If data was incorrectly changed, report
* and return.
*
SAME = .TRUE.
DO 40 I = 1, NARGS
SAME = SAME.AND.ISAME( I )
IF( .NOT.ISAME( I ) )
$ WRITE( NOUT, FMT = 9998 )I
40 CONTINUE
IF( .NOT.SAME )THEN
FATAL = .TRUE.
GO TO 120
END IF
*
IF( .NOT.NULL )THEN
*
* Check the result.
*
CALL SMMCH( TRANSA, TRANSB, M, N, K,
$ ALPHA, A, NMAX, B, NMAX, BETA,
$ C, NMAX, CT, G, CC, LDC, EPS,
$ ERR, FATAL, NOUT, .TRUE. )
ERRMAX = MAX( ERRMAX, ERR )
* If got really bad answer, report and
* return.
IF( FATAL )
$ GO TO 120
END IF
*
50 CONTINUE
*
60 CONTINUE
*
70 CONTINUE
*
80 CONTINUE
*
90 CONTINUE
*
100 CONTINUE
*
110 CONTINUE
*
* Report result.
*
IF( ERRMAX.LT.THRESH )THEN
WRITE( NOUT, FMT = 9999 )SNAME, NC
ELSE
WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
END IF
GO TO 130
*
120 CONTINUE
WRITE( NOUT, FMT = 9996 )SNAME
WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, TRANSB, M, N, K,
$ ALPHA, LDA, LDB, BETA, LDC
*
130 CONTINUE
RETURN
*
9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
$ 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
$ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
$ ' - SUSPECT *******' )
9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',''', A1, ''',',
$ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ',
$ 'C,', I3, ').' )
9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
* End of SCHK1.
*
END
SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
$ A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
*
* Tests SSYMM.
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- 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.
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0 )
* .. Scalar Arguments ..
REAL EPS, THRESH
INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
LOGICAL FATAL, REWI, TRACE
CHARACTER*6 SNAME
* .. Array Arguments ..
REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), B( NMAX, NMAX ),
$ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
$ C( NMAX, NMAX ), CC( NMAX*NMAX ),
$ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
INTEGER IDIM( NIDIM )
* .. Local Scalars ..
REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX
INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC,
$ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA,
$ NARGS, NC, NS
LOGICAL LEFT, NULL, RESET, SAME
CHARACTER*1 SIDE, SIDES, UPLO, UPLOS
CHARACTER*2 ICHS, ICHU
* .. Local Arrays ..
LOGICAL ISAME( 13 )
* .. External Functions ..
LOGICAL LSE, LSERES
EXTERNAL LSE, LSERES
* .. External Subroutines ..
EXTERNAL SMAKE, SMMCH, SSYMM
* .. Intrinsic Functions ..
INTRINSIC MAX
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
* .. Data statements ..
DATA ICHS/'LR'/, ICHU/'UL'/
* .. Executable Statements ..
*
NARGS = 12
NC = 0
RESET = .TRUE.
ERRMAX = ZERO
*
DO 100 IM = 1, NIDIM
M = IDIM( IM )
*
DO 90 IN = 1, NIDIM
N = IDIM( IN )
* Set LDC to 1 more than minimum value if room.
LDC = M
IF( LDC.LT.NMAX )
$ LDC = LDC + 1
* Skip tests if not enough room.
IF( LDC.GT.NMAX )
$ GO TO 90
LCC = LDC*N
NULL = N.LE.0.OR.M.LE.0
*
* Set LDB to 1 more than minimum value if room.
LDB = M
IF( LDB.LT.NMAX )
$ LDB = LDB + 1
* Skip tests if not enough room.
IF( LDB.GT.NMAX )
$ GO TO 90
LBB = LDB*N
*
* Generate the matrix B.
*
CALL SMAKE( 'GE', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET,
$ ZERO )
*
DO 80 ICS = 1, 2
SIDE = ICHS( ICS: ICS )
LEFT = SIDE.EQ.'L'
*
IF( LEFT )THEN
NA = M
ELSE
NA = N
END IF
* Set LDA to 1 more than minimum value if room.
LDA = NA
IF( LDA.LT.NMAX )
$ LDA = LDA + 1
* Skip tests if not enough room.
IF( LDA.GT.NMAX )
$ GO TO 80
LAA = LDA*NA
*
DO 70 ICU = 1, 2
UPLO = ICHU( ICU: ICU )
*
* Generate the symmetric matrix A.
*
CALL SMAKE( 'SY', UPLO, ' ', NA, NA, A, NMAX, AA, LDA,
$ RESET, ZERO )
*
DO 60 IA = 1, NALF
ALPHA = ALF( IA )
*
DO 50 IB = 1, NBET
BETA = BET( IB )
*
* Generate the matrix C.
*
CALL SMAKE( 'GE', ' ', ' ', M, N, C, NMAX, CC,
$ LDC, RESET, ZERO )
*
NC = NC + 1
*
* Save every datum before calling the
* subroutine.
*
SIDES = SIDE
UPLOS = UPLO
MS = M
NS = N
ALS = ALPHA
DO 10 I = 1, LAA
AS( I ) = AA( I )
10 CONTINUE
LDAS = LDA
DO 20 I = 1, LBB
BS( I ) = BB( I )
20 CONTINUE
LDBS = LDB
BLS = BETA
DO 30 I = 1, LCC
CS( I ) = CC( I )
30 CONTINUE
LDCS = LDC
*
* Call the subroutine.
*
IF( TRACE )
$ WRITE( NTRA, FMT = 9995 )NC, SNAME, SIDE,
$ UPLO, M, N, ALPHA, LDA, LDB, BETA, LDC
IF( REWI )
$ REWIND NTRA
CALL SSYMM( SIDE, UPLO, M, N, ALPHA, AA, LDA,
$ BB, LDB, BETA, CC, LDC )
*
* Check if error-exit was taken incorrectly.
*
IF( .NOT.OK )THEN
WRITE( NOUT, FMT = 9994 )
FATAL = .TRUE.
GO TO 110
END IF
*
* See what data changed inside subroutines.
*
ISAME( 1 ) = SIDES.EQ.SIDE
ISAME( 2 ) = UPLOS.EQ.UPLO
ISAME( 3 ) = MS.EQ.M
ISAME( 4 ) = NS.EQ.N
ISAME( 5 ) = ALS.EQ.ALPHA
ISAME( 6 ) = LSE( AS, AA, LAA )
ISAME( 7 ) = LDAS.EQ.LDA
ISAME( 8 ) = LSE( BS, BB, LBB )
ISAME( 9 ) = LDBS.EQ.LDB
ISAME( 10 ) = BLS.EQ.BETA
IF( NULL )THEN
ISAME( 11 ) = LSE( CS, CC, LCC )
ELSE
ISAME( 11 ) = LSERES( 'GE', ' ', M, N, CS,
$ CC, LDC )
END IF
ISAME( 12 ) = LDCS.EQ.LDC
*
* If data was incorrectly changed, report and
* return.
*
SAME = .TRUE.
DO 40 I = 1, NARGS
SAME = SAME.AND.ISAME( I )
IF( .NOT.ISAME( I ) )
$ WRITE( NOUT, FMT = 9998 )I
40 CONTINUE
IF( .NOT.SAME )THEN
FATAL = .TRUE.
GO TO 110
END IF
*
IF( .NOT.NULL )THEN
*
* Check the result.
*
IF( LEFT )THEN
CALL SMMCH( 'N', 'N', M, N, M, ALPHA, A,
$ NMAX, B, NMAX, BETA, C, NMAX,
$ CT, G, CC, LDC, EPS, ERR,
$ FATAL, NOUT, .TRUE. )
ELSE
CALL SMMCH( 'N', 'N', M, N, N, ALPHA, B,
$ NMAX, A, NMAX, BETA, C, NMAX,
$ CT, G, CC, LDC, EPS, ERR,
$ FATAL, NOUT, .TRUE. )
END IF
ERRMAX = MAX( ERRMAX, ERR )
* If got really bad answer, report and
* return.
IF( FATAL )
$ GO TO 110
END IF
*
50 CONTINUE
*
60 CONTINUE
*
70 CONTINUE
*
80 CONTINUE
*
90 CONTINUE
*
100 CONTINUE
*
* Report result.
*
IF( ERRMAX.LT.THRESH )THEN
WRITE( NOUT, FMT = 9999 )SNAME, NC
ELSE
WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
END IF
GO TO 120
*
110 CONTINUE
WRITE( NOUT, FMT = 9996 )SNAME
WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, M, N, ALPHA, LDA,
$ LDB, BETA, LDC
*
120 CONTINUE
RETURN
*
9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
$ 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
$ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
$ ' - SUSPECT *******' )
9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
9995 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
$ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ',
$ ' .' )
9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
* End of SCHK2.
*
END
SUBROUTINE SCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$ FATAL, NIDIM, IDIM, NALF, ALF, NMAX, A, AA, AS,
$ B, BB, BS, CT, G, C )
*
* Tests STRMM and STRSM.
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- 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.
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0, ONE = 1.0 )
* .. Scalar Arguments ..
REAL EPS, THRESH
INTEGER NALF, NIDIM, NMAX, NOUT, NTRA
LOGICAL FATAL, REWI, TRACE
CHARACTER*6 SNAME
* .. Array Arguments ..
REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), B( NMAX, NMAX ),
$ BB( NMAX*NMAX ), BS( NMAX*NMAX ),
$ C( NMAX, NMAX ), CT( NMAX ), G( NMAX )
INTEGER IDIM( NIDIM )
* .. Local Scalars ..
REAL ALPHA, ALS, ERR, ERRMAX
INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB,
$ LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC,
$ NS
LOGICAL LEFT, NULL, RESET, SAME
CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO,
$ UPLOS
CHARACTER*2 ICHD, ICHS, ICHU
CHARACTER*3 ICHT
* .. Local Arrays ..
LOGICAL ISAME( 13 )
* .. External Functions ..
LOGICAL LSE, LSERES
EXTERNAL LSE, LSERES
* .. External Subroutines ..
EXTERNAL SMAKE, SMMCH, STRMM, STRSM
* .. Intrinsic Functions ..
INTRINSIC MAX
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
* .. Data statements ..
DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/, ICHS/'LR'/
* .. Executable Statements ..
*
NARGS = 11
NC = 0
RESET = .TRUE.
ERRMAX = ZERO
* Set up zero matrix for SMMCH.
DO 20 J = 1, NMAX
DO 10 I = 1, NMAX
C( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
*
DO 140 IM = 1, NIDIM
M = IDIM( IM )
*
DO 130 IN = 1, NIDIM
N = IDIM( IN )
* Set LDB to 1 more than minimum value if room.
LDB = M
IF( LDB.LT.NMAX )
$ LDB = LDB + 1
* Skip tests if not enough room.
IF( LDB.GT.NMAX )
$ GO TO 130
LBB = LDB*N
NULL = M.LE.0.OR.N.LE.0
*
DO 120 ICS = 1, 2
SIDE = ICHS( ICS: ICS )
LEFT = SIDE.EQ.'L'
IF( LEFT )THEN
NA = M
ELSE
NA = N
END IF
* Set LDA to 1 more than minimum value if room.
LDA = NA
IF( LDA.LT.NMAX )
$ LDA = LDA + 1
* Skip tests if not enough room.
IF( LDA.GT.NMAX )
$ GO TO 130
LAA = LDA*NA
*
DO 110 ICU = 1, 2
UPLO = ICHU( ICU: ICU )
*
DO 100 ICT = 1, 3
TRANSA = ICHT( ICT: ICT )
*
DO 90 ICD = 1, 2
DIAG = ICHD( ICD: ICD )
*
DO 80 IA = 1, NALF
ALPHA = ALF( IA )
*
* Generate the matrix A.
*
CALL SMAKE( 'TR', UPLO, DIAG, NA, NA, A,
$ NMAX, AA, LDA, RESET, ZERO )
*
* Generate the matrix B.
*
CALL SMAKE( 'GE', ' ', ' ', M, N, B, NMAX,
$ BB, LDB, RESET, ZERO )
*
NC = NC + 1
*
* Save every datum before calling the
* subroutine.
*
SIDES = SIDE
UPLOS = UPLO
TRANAS = TRANSA
DIAGS = DIAG
MS = M
NS = N
ALS = ALPHA
DO 30 I = 1, LAA
AS( I ) = AA( I )
30 CONTINUE
LDAS = LDA
DO 40 I = 1, LBB
BS( I ) = BB( I )
40 CONTINUE
LDBS = LDB
*
* Call the subroutine.
*
IF( SNAME( 4: 5 ).EQ.'MM' )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9995 )NC, SNAME,
$ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,
$ LDA, LDB
IF( REWI )
$ REWIND NTRA
CALL STRMM( SIDE, UPLO, TRANSA, DIAG, M,
$ N, ALPHA, AA, LDA, BB, LDB )
ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9995 )NC, SNAME,
$ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,
$ LDA, LDB
IF( REWI )
$ REWIND NTRA
CALL STRSM( SIDE, UPLO, TRANSA, DIAG, M,
$ N, ALPHA, AA, LDA, BB, LDB )
END IF
*
* Check if error-exit was taken incorrectly.
*
IF( .NOT.OK )THEN
WRITE( NOUT, FMT = 9994 )
FATAL = .TRUE.
GO TO 150
END IF
*
* See what data changed inside subroutines.
*
ISAME( 1 ) = SIDES.EQ.SIDE
ISAME( 2 ) = UPLOS.EQ.UPLO
ISAME( 3 ) = TRANAS.EQ.TRANSA
ISAME( 4 ) = DIAGS.EQ.DIAG
ISAME( 5 ) = MS.EQ.M
ISAME( 6 ) = NS.EQ.N
ISAME( 7 ) = ALS.EQ.ALPHA
ISAME( 8 ) = LSE( AS, AA, LAA )
ISAME( 9 ) = LDAS.EQ.LDA
IF( NULL )THEN
ISAME( 10 ) = LSE( BS, BB, LBB )
ELSE
ISAME( 10 ) = LSERES( 'GE', ' ', M, N, BS,
$ BB, LDB )
END IF
ISAME( 11 ) = LDBS.EQ.LDB
*
* If data was incorrectly changed, report and
* return.
*
SAME = .TRUE.
DO 50 I = 1, NARGS
SAME = SAME.AND.ISAME( I )
IF( .NOT.ISAME( I ) )
$ WRITE( NOUT, FMT = 9998 )I
50 CONTINUE
IF( .NOT.SAME )THEN
FATAL = .TRUE.
GO TO 150
END IF
*
IF( .NOT.NULL )THEN
IF( SNAME( 4: 5 ).EQ.'MM' )THEN
*
* Check the result.
*
IF( LEFT )THEN
CALL SMMCH( TRANSA, 'N', M, N, M,
$ ALPHA, A, NMAX, B, NMAX,
$ ZERO, C, NMAX, CT, G,
$ BB, LDB, EPS, ERR,
$ FATAL, NOUT, .TRUE. )
ELSE
CALL SMMCH( 'N', TRANSA, M, N, N,
$ ALPHA, B, NMAX, A, NMAX,
$ ZERO, C, NMAX, CT, G,
$ BB, LDB, EPS, ERR,
$ FATAL, NOUT, .TRUE. )
END IF
ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN
*
* Compute approximation to original
* matrix.
*
DO 70 J = 1, N
DO 60 I = 1, M
C( I, J ) = BB( I + ( J - 1 )*
$ LDB )
BB( I + ( J - 1 )*LDB ) = ALPHA*
$ B( I, J )
60 CONTINUE
70 CONTINUE
*
IF( LEFT )THEN
CALL SMMCH( TRANSA, 'N', M, N, M,
$ ONE, A, NMAX, C, NMAX,
$ ZERO, B, NMAX, CT, G,
$ BB, LDB, EPS, ERR,
$ FATAL, NOUT, .FALSE. )
ELSE
CALL SMMCH( 'N', TRANSA, M, N, N,
$ ONE, C, NMAX, A, NMAX,
$ ZERO, B, NMAX, CT, G,
$ BB, LDB, EPS, ERR,
$ FATAL, NOUT, .FALSE. )
END IF
END IF
ERRMAX = MAX( ERRMAX, ERR )
* If got really bad answer, report and
* return.
IF( FATAL )
$ GO TO 150
END IF
*
80 CONTINUE
*
90 CONTINUE
*
100 CONTINUE
*
110 CONTINUE
*
120 CONTINUE
*
130 CONTINUE
*
140 CONTINUE
*
* Report result.
*
IF( ERRMAX.LT.THRESH )THEN
WRITE( NOUT, FMT = 9999 )SNAME, NC
ELSE
WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
END IF
GO TO 160
*
150 CONTINUE
WRITE( NOUT, FMT = 9996 )SNAME
WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, TRANSA, DIAG, M,
$ N, ALPHA, LDA, LDB
*
160 CONTINUE
RETURN
*
9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
$ 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
$ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
$ ' - SUSPECT *******' )
9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
9995 FORMAT( 1X, I6, ': ', A6, '(', 4( '''', A1, ''',' ), 2( I3, ',' ),
$ F4.1, ', A,', I3, ', B,', I3, ') .' )
9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
* End of SCHK3.
*
END
SUBROUTINE SCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
$ A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
*
* Tests SSYRK.
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- 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.
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0 )
* .. Scalar Arguments ..
REAL EPS, THRESH
INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
LOGICAL FATAL, REWI, TRACE
CHARACTER*6 SNAME
* .. Array Arguments ..
REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), B( NMAX, NMAX ),
$ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
$ C( NMAX, NMAX ), CC( NMAX*NMAX ),
$ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
INTEGER IDIM( NIDIM )
* .. Local Scalars ..
REAL ALPHA, ALS, BETA, BETS, ERR, ERRMAX
INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS,
$ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA,
$ NARGS, NC, NS
LOGICAL NULL, RESET, SAME, TRAN, UPPER
CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS
CHARACTER*2 ICHU
CHARACTER*3 ICHT
* .. Local Arrays ..
LOGICAL ISAME( 13 )
* .. External Functions ..
LOGICAL LSE, LSERES
EXTERNAL LSE, LSERES
* .. External Subroutines ..
EXTERNAL SMAKE, SMMCH, SSYRK
* .. Intrinsic Functions ..
INTRINSIC MAX
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
* .. Data statements ..
DATA ICHT/'NTC'/, ICHU/'UL'/
* .. Executable Statements ..
*
NARGS = 10
NC = 0
RESET = .TRUE.
ERRMAX = ZERO
*
DO 100 IN = 1, NIDIM
N = IDIM( IN )
* Set LDC to 1 more than minimum value if room.
LDC = N
IF( LDC.LT.NMAX )
$ LDC = LDC + 1
* Skip tests if not enough room.
IF( LDC.GT.NMAX )
$ GO TO 100
LCC = LDC*N
NULL = N.LE.0
*
DO 90 IK = 1, NIDIM
K = IDIM( IK )
*
DO 80 ICT = 1, 3
TRANS = ICHT( ICT: ICT )
TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
IF( TRAN )THEN
MA = K
NA = N
ELSE
MA = N
NA = K
END IF
* Set LDA to 1 more than minimum value if room.
LDA = MA
IF( LDA.LT.NMAX )
$ LDA = LDA + 1
* Skip tests if not enough room.
IF( LDA.GT.NMAX )
$ GO TO 80
LAA = LDA*NA
*
* Generate the matrix A.
*
CALL SMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA,
$ RESET, ZERO )
*
DO 70 ICU = 1, 2
UPLO = ICHU( ICU: ICU )
UPPER = UPLO.EQ.'U'
*
DO 60 IA = 1, NALF
ALPHA = ALF( IA )
*
DO 50 IB = 1, NBET
BETA = BET( IB )
*
* Generate the matrix C.
*
CALL SMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC,
$ LDC, RESET, ZERO )
*
NC = NC + 1
*
* Save every datum before calling the subroutine.
*
UPLOS = UPLO
TRANSS = TRANS
NS = N
KS = K
ALS = ALPHA
DO 10 I = 1, LAA
AS( I ) = AA( I )
10 CONTINUE
LDAS = LDA
BETS = BETA
DO 20 I = 1, LCC
CS( I ) = CC( I )
20 CONTINUE
LDCS = LDC
*
* Call the subroutine.
*
IF( TRACE )
$ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO,
$ TRANS, N, K, ALPHA, LDA, BETA, LDC
IF( REWI )
$ REWIND NTRA
CALL SSYRK( UPLO, TRANS, N, K, ALPHA, AA, LDA,
$ BETA, CC, LDC )
*
* Check if error-exit was taken incorrectly.
*
IF( .NOT.OK )THEN
WRITE( NOUT, FMT = 9993 )
FATAL = .TRUE.
GO TO 120
END IF
*
* See what data changed inside subroutines.
*
ISAME( 1 ) = UPLOS.EQ.UPLO
ISAME( 2 ) = TRANSS.EQ.TRANS
ISAME( 3 ) = NS.EQ.N
ISAME( 4 ) = KS.EQ.K
ISAME( 5 ) = ALS.EQ.ALPHA
ISAME( 6 ) = LSE( AS, AA, LAA )
ISAME( 7 ) = LDAS.EQ.LDA
ISAME( 8 ) = BETS.EQ.BETA
IF( NULL )THEN
ISAME( 9 ) = LSE( CS, CC, LCC )
ELSE
ISAME( 9 ) = LSERES( 'SY', UPLO, N, N, CS,
$ CC, LDC )
END IF
ISAME( 10 ) = LDCS.EQ.LDC
*
* If data was incorrectly changed, report and
* return.
*
SAME = .TRUE.
DO 30 I = 1, NARGS
SAME = SAME.AND.ISAME( I )
IF( .NOT.ISAME( I ) )
$ WRITE( NOUT, FMT = 9998 )I
30 CONTINUE
IF( .NOT.SAME )THEN
FATAL = .TRUE.
GO TO 120
END IF
*
IF( .NOT.NULL )THEN
*
* Check the result column by column.
*
JC = 1
DO 40 J = 1, N
IF( UPPER )THEN
JJ = 1
LJ = J
ELSE
JJ = J
LJ = N - J + 1
END IF
IF( TRAN )THEN
CALL SMMCH( 'T', 'N', LJ, 1, K, ALPHA,
$ A( 1, JJ ), NMAX,
$ A( 1, J ), NMAX, BETA,
$ C( JJ, J ), NMAX, CT, G,
$ CC( JC ), LDC, EPS, ERR,
$ FATAL, NOUT, .TRUE. )
ELSE
CALL SMMCH( 'N', 'T', LJ, 1, K, ALPHA,
$ A( JJ, 1 ), NMAX,
$ A( J, 1 ), NMAX, BETA,
$ C( JJ, J ), NMAX, CT, G,
$ CC( JC ), LDC, EPS, ERR,
$ FATAL, NOUT, .TRUE. )
END IF
IF( UPPER )THEN
JC = JC + LDC
ELSE
JC = JC + LDC + 1
END IF
ERRMAX = MAX( ERRMAX, ERR )
* If got really bad answer, report and
* return.
IF( FATAL )
$ GO TO 110
40 CONTINUE
END IF
*
50 CONTINUE
*
60 CONTINUE
*
70 CONTINUE
*
80 CONTINUE
*
90 CONTINUE
*
100 CONTINUE
*
* Report result.
*
IF( ERRMAX.LT.THRESH )THEN
WRITE( NOUT, FMT = 9999 )SNAME, NC
ELSE
WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
END IF
GO TO 130
*
110 CONTINUE
IF( N.GT.1 )
$ WRITE( NOUT, FMT = 9995 )J
*
120 CONTINUE
WRITE( NOUT, FMT = 9996 )SNAME
WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA,
$ LDA, BETA, LDC
*
130 CONTINUE
RETURN
*
9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
$ 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
$ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
$ ' - SUSPECT *******' )
9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
$ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' )
9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
* End of SCHK4.
*
END
SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
$ AB, AA, AS, BB, BS, C, CC, CS, CT, G, W )
*
* Tests SSYR2K.
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- 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.
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0 )
* .. Scalar Arguments ..
REAL EPS, THRESH
INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
LOGICAL FATAL, REWI, TRACE
CHARACTER*6 SNAME
* .. Array Arguments ..
REAL AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ),
$ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ),
$ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ),
$ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ),
$ G( NMAX ), W( 2*NMAX )
INTEGER IDIM( NIDIM )
* .. Local Scalars ..
REAL ALPHA, ALS, BETA, BETS, ERR, ERRMAX
INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB,
$ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS,
$ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS
LOGICAL NULL, RESET, SAME, TRAN, UPPER
CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS
CHARACTER*2 ICHU
CHARACTER*3 ICHT
* .. Local Arrays ..
LOGICAL ISAME( 13 )
* .. External Functions ..
LOGICAL LSE, LSERES
EXTERNAL LSE, LSERES
* .. External Subroutines ..
EXTERNAL SMAKE, SMMCH, SSYR2K
* .. Intrinsic Functions ..
INTRINSIC MAX
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
* .. Data statements ..
DATA ICHT/'NTC'/, ICHU/'UL'/
* .. Executable Statements ..
*
NARGS = 12
NC = 0
RESET = .TRUE.
ERRMAX = ZERO
*
DO 130 IN = 1, NIDIM
N = IDIM( IN )
* Set LDC to 1 more than minimum value if room.
LDC = N
IF( LDC.LT.NMAX )
$ LDC = LDC + 1
* Skip tests if not enough room.
IF( LDC.GT.NMAX )
$ GO TO 130
LCC = LDC*N
NULL = N.LE.0
*
DO 120 IK = 1, NIDIM
K = IDIM( IK )
*
DO 110 ICT = 1, 3
TRANS = ICHT( ICT: ICT )
TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
IF( TRAN )THEN
MA = K
NA = N
ELSE
MA = N
NA = K
END IF
* Set LDA to 1 more than minimum value if room.
LDA = MA
IF( LDA.LT.NMAX )
$ LDA = LDA + 1
* Skip tests if not enough room.
IF( LDA.GT.NMAX )
$ GO TO 110
LAA = LDA*NA
*
* Generate the matrix A.
*
IF( TRAN )THEN
CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB, 2*NMAX, AA,
$ LDA, RESET, ZERO )
ELSE
CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB, NMAX, AA, LDA,
$ RESET, ZERO )
END IF
*
* Generate the matrix B.
*
LDB = LDA
LBB = LAA
IF( TRAN )THEN
CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB( K + 1 ),
$ 2*NMAX, BB, LDB, RESET, ZERO )
ELSE
CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB( K*NMAX + 1 ),
$ NMAX, BB, LDB, RESET, ZERO )
END IF
*
DO 100 ICU = 1, 2
UPLO = ICHU( ICU: ICU )
UPPER = UPLO.EQ.'U'
*
DO 90 IA = 1, NALF
ALPHA = ALF( IA )
*
DO 80 IB = 1, NBET
BETA = BET( IB )
*
* Generate the matrix C.
*
CALL SMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC,
$ LDC, RESET, ZERO )
*
NC = NC + 1
*
* Save every datum before calling the subroutine.
*
UPLOS = UPLO
TRANSS = TRANS
NS = N
KS = K
ALS = ALPHA
DO 10 I = 1, LAA
AS( I ) = AA( I )
10 CONTINUE
LDAS = LDA
DO 20 I = 1, LBB
BS( I ) = BB( I )
20 CONTINUE
LDBS = LDB
BETS = BETA
DO 30 I = 1, LCC
CS( I ) = CC( I )
30 CONTINUE
LDCS = LDC
*
* Call the subroutine.
*
IF( TRACE )
$ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO,
$ TRANS, N, K, ALPHA, LDA, LDB, BETA, LDC
IF( REWI )
$ REWIND NTRA
CALL SSYR2K( UPLO, TRANS, N, K, ALPHA, AA, LDA,
$ BB, LDB, BETA, CC, LDC )
*
* Check if error-exit was taken incorrectly.
*
IF( .NOT.OK )THEN
WRITE( NOUT, FMT = 9993 )
FATAL = .TRUE.
GO TO 150
END IF
*
* See what data changed inside subroutines.
*
ISAME( 1 ) = UPLOS.EQ.UPLO
ISAME( 2 ) = TRANSS.EQ.TRANS
ISAME( 3 ) = NS.EQ.N
ISAME( 4 ) = KS.EQ.K
ISAME( 5 ) = ALS.EQ.ALPHA
ISAME( 6 ) = LSE( AS, AA, LAA )
ISAME( 7 ) = LDAS.EQ.LDA
ISAME( 8 ) = LSE( BS, BB, LBB )
ISAME( 9 ) = LDBS.EQ.LDB
ISAME( 10 ) = BETS.EQ.BETA
IF( NULL )THEN
ISAME( 11 ) = LSE( CS, CC, LCC )
ELSE
ISAME( 11 ) = LSERES( 'SY', UPLO, N, N, CS,
$ CC, LDC )
END IF
ISAME( 12 ) = LDCS.EQ.LDC
*
* If data was incorrectly changed, report and
* return.
*
SAME = .TRUE.
DO 40 I = 1, NARGS
SAME = SAME.AND.ISAME( I )
IF( .NOT.ISAME( I ) )
$ WRITE( NOUT, FMT = 9998 )I
40 CONTINUE
IF( .NOT.SAME )THEN
FATAL = .TRUE.
GO TO 150
END IF
*
IF( .NOT.NULL )THEN
*
* Check the result column by column.
*
JJAB = 1
JC = 1
DO 70 J = 1, N
IF( UPPER )THEN
JJ = 1
LJ = J
ELSE
JJ = J
LJ = N - J + 1
END IF
IF( TRAN )THEN
DO 50 I = 1, K
W( I ) = AB( ( J - 1 )*2*NMAX + K +
$ I )
W( K + I ) = AB( ( J - 1 )*2*NMAX +
$ I )
50 CONTINUE
CALL SMMCH( 'T', 'N', LJ, 1, 2*K,
$ ALPHA, AB( JJAB ), 2*NMAX,
$ W, 2*NMAX, BETA,
$ C( JJ, J ), NMAX, CT, G,
$ CC( JC ), LDC, EPS, ERR,
$ FATAL, NOUT, .TRUE. )
ELSE
DO 60 I = 1, K
W( I ) = AB( ( K + I - 1 )*NMAX +
$ J )
W( K + I ) = AB( ( I - 1 )*NMAX +
$ J )
60 CONTINUE
CALL SMMCH( 'N', 'N', LJ, 1, 2*K,
$ ALPHA, AB( JJ ), NMAX, W,
$ 2*NMAX, BETA, C( JJ, J ),
$ NMAX, CT, G, CC( JC ), LDC,
$ EPS, ERR, FATAL, NOUT,
$ .TRUE. )
END IF
IF( UPPER )THEN
JC = JC + LDC
ELSE
JC = JC + LDC + 1
IF( TRAN )
$ JJAB = JJAB + 2*NMAX
END IF
ERRMAX = MAX( ERRMAX, ERR )
* If got really bad answer, report and
* return.
IF( FATAL )
$ GO TO 140
70 CONTINUE
END IF
*
80 CONTINUE
*
90 CONTINUE
*
100 CONTINUE
*
110 CONTINUE
*
120 CONTINUE
*
130 CONTINUE
*
* Report result.
*
IF( ERRMAX.LT.THRESH )THEN
WRITE( NOUT, FMT = 9999 )SNAME, NC
ELSE
WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
END IF
GO TO 160
*
140 CONTINUE
IF( N.GT.1 )
$ WRITE( NOUT, FMT = 9995 )J
*
150 CONTINUE
WRITE( NOUT, FMT = 9996 )SNAME
WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA,
$ LDA, LDB, BETA, LDC
*
160 CONTINUE
RETURN
*
9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
$ 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
$ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
$ ' - SUSPECT *******' )
9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
$ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ',
$ ' .' )
9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
* End of SCHK5.
*
END
SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT )
*
* Tests the error exits from the Level 3 Blas.
* Requires a special version of the error-handling routine XERBLA.
* A, B and C should not need to be defined.
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- 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.
*
* 3-19-92: Initialize ALPHA and BETA (eca)
* 3-19-92: Fix argument 12 in calls to SSYMM with INFOT = 9 (eca)
*
* .. Scalar Arguments ..
INTEGER ISNUM, NOUT
CHARACTER*6 SRNAMT
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
* .. Parameters ..
REAL ONE, TWO
PARAMETER ( ONE = 1.0E0, TWO = 2.0E0 )
* .. Local Scalars ..
REAL ALPHA, BETA
* .. Local Arrays ..
REAL A( 2, 1 ), B( 2, 1 ), C( 2, 1 )
* .. External Subroutines ..
EXTERNAL CHKXER, SGEMM, SSYMM, SSYR2K, SSYRK, STRMM,
$ STRSM
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
* .. Executable Statements ..
* OK is set to .FALSE. by the special version of XERBLA or by CHKXER
* if anything is wrong.
OK = .TRUE.
* LERR is set to .TRUE. by the special version of XERBLA each time
* it is called, and is then tested and re-set by CHKXER.
LERR = .FALSE.
*
* Initialize ALPHA and BETA.
*
ALPHA = ONE
BETA = TWO
*
GO TO ( 10, 20, 30, 40, 50, 60 )ISNUM
10 INFOT = 1
CALL SGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 1
CALL SGEMM( '/', 'T', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGEMM( 'N', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGEMM( 'T', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGEMM( 'N', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGEMM( 'N', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGEMM( 'T', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGEMM( 'T', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGEMM( 'N', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGEMM( 'N', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGEMM( 'T', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGEMM( 'T', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGEMM( 'N', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGEMM( 'N', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGEMM( 'T', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGEMM( 'T', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SGEMM( 'T', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SGEMM( 'N', 'N', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SGEMM( 'N', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SGEMM( 'T', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 13
CALL SGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 13
CALL SGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 13
CALL SGEMM( 'T', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 13
CALL SGEMM( 'T', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 70
20 INFOT = 1
CALL SSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSYMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSYMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSYMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSYMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSYMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SSYMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SSYMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SSYMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SSYMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SSYMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SSYMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SSYMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 70
30 INFOT = 1
CALL STRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STRMM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL STRMM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL STRMM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STRMM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STRMM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STRMM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STRMM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STRMM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STRMM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STRMM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STRMM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL STRMM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL STRMM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL STRMM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL STRMM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL STRMM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL STRMM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL STRMM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL STRMM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL STRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL STRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL STRMM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL STRMM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL STRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL STRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL STRMM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL STRMM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL STRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL STRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL STRMM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL STRMM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL STRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL STRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL STRMM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL STRMM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 70
40 INFOT = 1
CALL STRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STRSM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL STRSM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL STRSM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STRSM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STRSM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STRSM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STRSM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STRSM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STRSM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STRSM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STRSM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL STRSM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL STRSM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL STRSM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL STRSM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL STRSM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL STRSM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL STRSM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL STRSM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL STRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL STRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL STRSM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL STRSM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL STRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL STRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL STRSM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL STRSM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL STRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL STRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL STRSM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL STRSM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL STRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL STRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL STRSM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL STRSM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 70
50 INFOT = 1
CALL SSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSYRK( 'U', '/', 0, 0, ALPHA, A, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSYRK( 'U', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSYRK( 'U', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSYRK( 'L', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSYRK( 'L', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SSYRK( 'U', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SSYRK( 'U', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SSYRK( 'L', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SSYRK( 'L', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SSYRK( 'U', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SSYRK( 'U', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SSYRK( 'L', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SSYRK( 'L', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SSYRK( 'U', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SSYRK( 'U', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SSYRK( 'L', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SSYRK( 'L', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 70
60 INFOT = 1
CALL SSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSYR2K( 'U', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSYR2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSYR2K( 'U', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSYR2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSYR2K( 'L', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SSYR2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SSYR2K( 'U', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SSYR2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SSYR2K( 'L', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SSYR2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SSYR2K( 'U', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SSYR2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SSYR2K( 'L', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SSYR2K( 'U', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SSYR2K( 'L', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SSYR2K( 'U', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
*
70 IF( OK )THEN
WRITE( NOUT, FMT = 9999 )SRNAMT
ELSE
WRITE( NOUT, FMT = 9998 )SRNAMT
END IF
RETURN
*
9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' )
9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****',
$ '**' )
*
* End of SCHKE.
*
END
SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET,
$ TRANSL )
*
* Generates values for an M by N matrix A.
* Stores the values in the array AA in the data structure required
* by the routine, with unwanted elements set to rogue value.
*
* TYPE is 'GE', 'SY' or 'TR'.
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- 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.
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0, ONE = 1.0 )
REAL ROGUE
PARAMETER ( ROGUE = -1.0E10 )
* .. Scalar Arguments ..
REAL TRANSL
INTEGER LDA, M, N, NMAX
LOGICAL RESET
CHARACTER*1 DIAG, UPLO
CHARACTER*2 TYPE
* .. Array Arguments ..
REAL A( NMAX, * ), AA( * )
* .. Local Scalars ..
INTEGER I, IBEG, IEND, J
LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER
* .. External Functions ..
REAL SBEG
EXTERNAL SBEG
* .. Executable Statements ..
GEN = TYPE.EQ.'GE'
SYM = TYPE.EQ.'SY'
TRI = TYPE.EQ.'TR'
UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U'
LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L'
UNIT = TRI.AND.DIAG.EQ.'U'
*
* Generate data in array A.
*
DO 20 J = 1, N
DO 10 I = 1, M
IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) )
$ THEN
A( I, J ) = SBEG( RESET ) + TRANSL
IF( I.NE.J )THEN
* Set some elements to zero
IF( N.GT.3.AND.J.EQ.N/2 )
$ A( I, J ) = ZERO
IF( SYM )THEN
A( J, I ) = A( I, J )
ELSE IF( TRI )THEN
A( J, I ) = ZERO
END IF
END IF
END IF
10 CONTINUE
IF( TRI )
$ A( J, J ) = A( J, J ) + ONE
IF( UNIT )
$ A( J, J ) = ONE
20 CONTINUE
*
* Store elements in array AS in data structure required by routine.
*
IF( TYPE.EQ.'GE' )THEN
DO 50 J = 1, N
DO 30 I = 1, M
AA( I + ( J - 1 )*LDA ) = A( I, J )
30 CONTINUE
DO 40 I = M + 1, LDA
AA( I + ( J - 1 )*LDA ) = ROGUE
40 CONTINUE
50 CONTINUE
ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN
DO 90 J = 1, N
IF( UPPER )THEN
IBEG = 1
IF( UNIT )THEN
IEND = J - 1
ELSE
IEND = J
END IF
ELSE
IF( UNIT )THEN
IBEG = J + 1
ELSE
IBEG = J
END IF
IEND = N
END IF
DO 60 I = 1, IBEG - 1
AA( I + ( J - 1 )*LDA ) = ROGUE
60 CONTINUE
DO 70 I = IBEG, IEND
AA( I + ( J - 1 )*LDA ) = A( I, J )
70 CONTINUE
DO 80 I = IEND + 1, LDA
AA( I + ( J - 1 )*LDA ) = ROGUE
80 CONTINUE
90 CONTINUE
END IF
RETURN
*
* End of SMAKE.
*
END
SUBROUTINE SMMCH( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB,
$ BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL,
$ NOUT, MV )
*
* Checks the results of the computational tests.
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- 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.
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0, ONE = 1.0 )
* .. Scalar Arguments ..
REAL ALPHA, BETA, EPS, ERR
INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT
LOGICAL FATAL, MV
CHARACTER*1 TRANSA, TRANSB
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), C( LDC, * ),
$ CC( LDCC, * ), CT( * ), G( * )
* .. Local Scalars ..
REAL ERRI
INTEGER I, J, K
LOGICAL TRANA, TRANB
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* .. Executable Statements ..
TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
*
* Compute expected result, one column at a time, in CT using data
* in A, B and C.
* Compute gauges in G.
*
DO 120 J = 1, N
*
DO 10 I = 1, M
CT( I ) = ZERO
G( I ) = ZERO
10 CONTINUE
IF( .NOT.TRANA.AND..NOT.TRANB )THEN
DO 30 K = 1, KK
DO 20 I = 1, M
CT( I ) = CT( I ) + A( I, K )*B( K, J )
G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( K, J ) )
20 CONTINUE
30 CONTINUE
ELSE IF( TRANA.AND..NOT.TRANB )THEN
DO 50 K = 1, KK
DO 40 I = 1, M
CT( I ) = CT( I ) + A( K, I )*B( K, J )
G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( K, J ) )
40 CONTINUE
50 CONTINUE
ELSE IF( .NOT.TRANA.AND.TRANB )THEN
DO 70 K = 1, KK
DO 60 I = 1, M
CT( I ) = CT( I ) + A( I, K )*B( J, K )
G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( J, K ) )
60 CONTINUE
70 CONTINUE
ELSE IF( TRANA.AND.TRANB )THEN
DO 90 K = 1, KK
DO 80 I = 1, M
CT( I ) = CT( I ) + A( K, I )*B( J, K )
G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( J, K ) )
80 CONTINUE
90 CONTINUE
END IF
DO 100 I = 1, M
CT( I ) = ALPHA*CT( I ) + BETA*C( I, J )
G( I ) = ABS( ALPHA )*G( I ) + ABS( BETA )*ABS( C( I, J ) )
100 CONTINUE
*
* Compute the error ratio for this result.
*
ERR = ZERO
DO 110 I = 1, M
ERRI = ABS( CT( I ) - CC( I, J ) )/EPS
IF( G( I ).NE.ZERO )
$ ERRI = ERRI/G( I )
ERR = MAX( ERR, ERRI )
IF( ERR*SQRT( EPS ).GE.ONE )
$ GO TO 130
110 CONTINUE
*
120 CONTINUE
*
* If the loop completes, all results are at least half accurate.
GO TO 150
*
* Report fatal error.
*
130 FATAL = .TRUE.
WRITE( NOUT, FMT = 9999 )
DO 140 I = 1, M
IF( MV )THEN
WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J )
ELSE
WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I )
END IF
140 CONTINUE
IF( N.GT.1 )
$ WRITE( NOUT, FMT = 9997 )J
*
150 CONTINUE
RETURN
*
9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
$ 'F ACCURATE *******', /' EXPECTED RESULT COMPU',
$ 'TED RESULT' )
9998 FORMAT( 1X, I7, 2G18.6 )
9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
*
* End of SMMCH.
*
END
LOGICAL FUNCTION LSE( RI, RJ, LR )
*
* Tests if two arrays are identical.
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- 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.
*
* .. Scalar Arguments ..
INTEGER LR
* .. Array Arguments ..
REAL RI( * ), RJ( * )
* .. Local Scalars ..
INTEGER I
* .. Executable Statements ..
DO 10 I = 1, LR
IF( RI( I ).NE.RJ( I ) )
$ GO TO 20
10 CONTINUE
LSE = .TRUE.
GO TO 30
20 CONTINUE
LSE = .FALSE.
30 RETURN
*
* End of LSE.
*
END
LOGICAL FUNCTION LSERES( TYPE, UPLO, M, N, AA, AS, LDA )
*
* Tests if selected elements in two arrays are equal.
*
* TYPE is 'GE' or 'SY'.
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- 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.
*
* .. Scalar Arguments ..
INTEGER LDA, M, N
CHARACTER*1 UPLO
CHARACTER*2 TYPE
* .. Array Arguments ..
REAL AA( LDA, * ), AS( LDA, * )
* .. Local Scalars ..
INTEGER I, IBEG, IEND, J
LOGICAL UPPER
* .. Executable Statements ..
UPPER = UPLO.EQ.'U'
IF( TYPE.EQ.'GE' )THEN
DO 20 J = 1, N
DO 10 I = M + 1, LDA
IF( AA( I, J ).NE.AS( I, J ) )
$ GO TO 70
10 CONTINUE
20 CONTINUE
ELSE IF( TYPE.EQ.'SY' )THEN
DO 50 J = 1, N
IF( UPPER )THEN
IBEG = 1
IEND = J
ELSE
IBEG = J
IEND = N
END IF
DO 30 I = 1, IBEG - 1
IF( AA( I, J ).NE.AS( I, J ) )
$ GO TO 70
30 CONTINUE
DO 40 I = IEND + 1, LDA
IF( AA( I, J ).NE.AS( I, J ) )
$ GO TO 70
40 CONTINUE
50 CONTINUE
END IF
*
60 CONTINUE
LSERES = .TRUE.
GO TO 80
70 CONTINUE
LSERES = .FALSE.
80 RETURN
*
* End of LSERES.
*
END
REAL FUNCTION SBEG( RESET )
*
* Generates random numbers uniformly distributed between -0.5 and 0.5.
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- 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.
*
* .. Scalar Arguments ..
LOGICAL RESET
* .. Local Scalars ..
INTEGER I, IC, MI
* .. Save statement ..
SAVE I, IC, MI
* .. Executable Statements ..
IF( RESET )THEN
* Initialize local variables.
MI = 891
I = 7
IC = 0
RESET = .FALSE.
END IF
*
* The sequence of values of I is bounded between 1 and 999.
* If initial I = 1,2,3,6,7 or 9, the period will be 50.
* If initial I = 4 or 8, the period will be 25.
* If initial I = 5, the period will be 10.
* IC is used to break up the period by skipping 1 value of I in 6.
*
IC = IC + 1
10 I = I*MI
I = I - 1000*( I/1000 )
IF( IC.GE.5 )THEN
IC = 0
GO TO 10
END IF
SBEG = ( I - 500 )/1001.0
RETURN
*
* End of SBEG.
*
END
REAL FUNCTION SDIFF( X, Y )
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- 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.
*
* .. Scalar Arguments ..
REAL X, Y
* .. Executable Statements ..
SDIFF = X - Y
RETURN
*
* End of SDIFF.
*
END
SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
*
* Tests whether XERBLA has detected an error when it should.
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- 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.
*
* .. Scalar Arguments ..
INTEGER INFOT, NOUT
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
* .. Executable Statements ..
IF( .NOT.LERR )THEN
WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT
OK = .FALSE.
END IF
LERR = .FALSE.
RETURN
*
9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D',
$ 'ETECTED BY ', A6, ' *****' )
*
* End of CHKXER.
*
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/sblas3/xerbla.f 0000644 0001750 0001750 00000003551 10616163240 024032 0 ustar osallou osallou SUBROUTINE XERBLA( SRNAME, INFO )
*
* f2j NOTE: this is compiled separately from dblat2.f because
* it needs to be in package org.netlib.err while the rest of
* dblat2.f routines should be in org.netlib.blas.testing.
*
* This is a special version of XERBLA to be used only as part of
* the test program for testing error exits from the Level 3 BLAS
* routines.
*
* XERBLA is an error handler for the Level 3 BLAS routines.
*
* It is called by the Level 3 BLAS routines if an input parameter is
* invalid.
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- 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.
*
* .. Scalar Arguments ..
INTEGER INFO
CHARACTER*6 SRNAME
* .. Scalars in Common ..
INTEGER INFOT, NOUT
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUT, OK, LERR
COMMON /SRNAMC/SRNAMT
* .. Executable Statements ..
LERR = .TRUE.
IF( INFO.NE.INFOT )THEN
IF( INFOT.NE.0 )THEN
WRITE( NOUT, FMT = 9999 )INFO, INFOT
ELSE
WRITE( NOUT, FMT = 9997 )INFO
END IF
OK = .FALSE.
END IF
IF( SRNAME.NE.SRNAMT )THEN
WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT
OK = .FALSE.
END IF
RETURN
*
9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD',
$ ' OF ', I2, ' *******' )
9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE',
$ 'AD OF ', A6, ' *******' )
9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6,
$ ' *******' )
*
* End of XERBLA
*
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/Makefile 0000644 0001750 0001750 00000003136 10616163232 022657 0 ustar osallou osallou .PHONY: blas1 blas2 blas3 runtests clean sblas1 sblas2 sblas3 eig lin seig slin
ROOT=../..
include $(ROOT)/make.def
testers: blas1 blas2 blas3 eig lin sblas1 sblas2 sblas3 seig slin
blas1: $(ROOT)/$(BLAS1TEST_IDX)
blas2: $(ROOT)/$(BLAS2TEST_IDX)
blas3: $(ROOT)/$(BLAS3TEST_IDX)
eig: $(ROOT)/$(EIGTEST_IDX)
lin: $(ROOT)/$(LINTEST_IDX)
sblas1: $(ROOT)/$(SBLAS1TEST_IDX)
sblas2: $(ROOT)/$(SBLAS2TEST_IDX)
sblas3: $(ROOT)/$(SBLAS3TEST_IDX)
seig: $(ROOT)/$(SEIGTEST_IDX)
slin: $(ROOT)/$(SLINTEST_IDX)
$(ROOT)/$(BLAS1TEST_IDX):
cd blas1;$(MAKE)
$(ROOT)/$(BLAS2TEST_IDX):
cd blas2;$(MAKE)
$(ROOT)/$(BLAS3TEST_IDX):
cd blas3;$(MAKE)
$(ROOT)/$(EIGTEST_IDX):
cd eig;$(MAKE)
$(ROOT)/$(LINTEST_IDX):
cd lin;$(MAKE)
$(ROOT)/$(SBLAS1TEST_IDX):
cd sblas1;$(MAKE)
$(ROOT)/$(SBLAS2TEST_IDX):
cd sblas2;$(MAKE)
$(ROOT)/$(SBLAS3TEST_IDX):
cd sblas3;$(MAKE)
$(ROOT)/$(SEIGTEST_IDX):
cd seig;$(MAKE)
$(ROOT)/$(SLINTEST_IDX):
cd slin;$(MAKE)
runtests: blastest lintest eigtest sblastest slintest seigtest
blastest:
cd blas1;$(MAKE) runtest
cd blas2;$(MAKE) runtest
cd blas3;$(MAKE) runtest
sblastest:
cd sblas1;$(MAKE) runtest
cd sblas2;$(MAKE) runtest
cd sblas3;$(MAKE) runtest
eigtest:
cd eig;$(MAKE) runtest
seigtest:
cd seig;$(MAKE) runtest
lintest:
cd lin;$(MAKE) runtest
slintest:
cd slin;$(MAKE) runtest
clean:
cd blas1;$(MAKE) clean
cd blas2;$(MAKE) clean
cd blas3;$(MAKE) clean
cd sblas1;$(MAKE) clean
cd sblas2;$(MAKE) clean
cd sblas3;$(MAKE) clean
cd eig;$(MAKE) clean
cd seig;$(MAKE) clean
cd lin;$(MAKE) clean
cd slin;$(MAKE) clean
cd matgen;$(MAKE) clean
cd smatgen;$(MAKE) clean
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/seig/ 0000755 0001750 0001750 00000000000 11734055026 022146 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/seig/ssg.in 0000644 0001750 0001750 00000001371 10616163241 023271 0 ustar osallou osallou SSG: Data file for testing Generalized Symmetric Eigenvalue Problem routines
7 Number of values of N
0 1 2 3 5 10 16 Values of N (dimension)
3 Number of values of NB
1 3 20 Values of NB (blocksize)
2 2 2 Values of NBMIN (minimum blocksize)
1 1 1 Values of NX (crossover point)
20.0 Threshold value
T Put T to test the LAPACK routines
T Put T to test the driver routines
T Put T to test the error exits
1 Code to interpret the seed
SSG 21
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/seig/ssb.in 0000644 0001750 0001750 00000000735 10616163241 023267 0 ustar osallou osallou SSB: Data file for testing Symmetric Eigenvalue Problem routines
2 Number of values of N
5 20 Values of N (dimension)
5 Number of values of K
0 1 2 5 16 Values of K (band width)
20.0 Threshold value
T Put T to test the error exits
1 Code to interpret the seed
SSB 15
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/seig/sgbal.in 0000644 0001750 0001750 00000036213 10616163241 023570 0 ustar osallou osallou SGL: Tests SGGBAL
6
0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.2000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.3000E+01 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.4000E+01 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.5000E+01 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.6000E+01
0.6000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.5000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.4000E+01 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.3000E+01 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.2000E+01 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
1 1
0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.2000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.3000E+01 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.4000E+01 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.5000E+01 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.6000E+01
0.6000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.5000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.4000E+01 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.3000E+01 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.2000E+01 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.5000E+01 0.6000E+01
0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.5000E+01 0.6000E+01
6
0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.1000E+01 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.1000E+01 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01
0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
1 1
0.1000E+01 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.1000E+01 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
0.1000E+01 0.2000E+01 0.3000E+01 0.3000E+01 0.2000E+01 0.1000E+01
0.1000E+01 0.2000E+01 0.3000E+01 0.3000E+01 0.2000E+01 0.1000E+01
6
0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.1000E+01 0.2000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.1000E+01 0.2000E+01 0.3000E+01 0.0000E+00 0.0000E+00 0.0000E+00
0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.0000E+00 0.0000E+00
0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.5000E+01 0.0000E+00
0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.5000E+01 0.6000E+01
0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.1000E+01 0.2000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.1000E+01 0.2000E+01 0.3000E+01 0.0000E+00 0.0000E+00 0.0000E+00
0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.0000E+00 0.0000E+00
0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.5000E+01 0.0000E+00
0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.5000E+01 0.6000E+01
1 1
0.6000E+01 0.5000E+01 0.4000E+01 0.3000E+01 0.2000E+01 0.1000E+01
0.0000E+00 0.5000E+01 0.4000E+01 0.3000E+01 0.2000E+01 0.1000E+01
0.0000E+00 0.0000E+00 0.4000E+01 0.3000E+01 0.2000E+01 0.1000E+01
0.0000E+00 0.0000E+00 0.0000E+00 0.3000E+01 0.2000E+01 0.1000E+01
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.2000E+01 0.1000E+01
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
0.6000E+01 0.5000E+01 0.4000E+01 0.3000E+01 0.2000E+01 0.1000E+01
0.0000E+00 0.5000E+01 0.4000E+01 0.3000E+01 0.2000E+01 0.1000E+01
0.0000E+00 0.0000E+00 0.4000E+01 0.3000E+01 0.2000E+01 0.1000E+01
0.0000E+00 0.0000E+00 0.0000E+00 0.3000E+01 0.2000E+01 0.1000E+01
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.2000E+01 0.1000E+01
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
0.1000E+01 0.2000E+01 0.3000E+01 0.3000E+01 0.2000E+01 0.1000E+01
0.1000E+01 0.2000E+01 0.3000E+01 0.3000E+01 0.2000E+01 0.1000E+01
5
0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.1000E+01 0.2000E+01 0.0000E+00 0.0000E+00 0.0000E+00
0.1000E+01 0.2000E+01 0.3000E+01 0.0000E+00 0.0000E+00
0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.0000E+00
0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.5000E+01
0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
1 1
0.5000E+01 0.4000E+01 0.3000E+01 0.2000E+01 0.1000E+01
0.0000E+00 0.4000E+01 0.3000E+01 0.2000E+01 0.1000E+01
0.0000E+00 0.0000E+00 0.3000E+01 0.2000E+01 0.1000E+01
0.0000E+00 0.0000E+00 0.0000E+00 0.2000E+01 0.1000E+01
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
0.1000E+01 0.2000E+01 0.3000E+01 0.2000E+01 0.1000E+01
0.1000E+01 0.2000E+01 0.3000E+01 0.2000E+01 0.1000E+01
6
0.1000E+01 0.1000E+11 0.1000E+11 0.1000E+11 0.1000E+11 0.1000E+11
0.1000E+01 0.1000E+01 0.1000E+11 0.1000E+11 0.1000E+11 0.1000E+11
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+11 0.1000E+11 0.1000E+11
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+11 0.1000E+11
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+11
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01 0.1000E+11 0.1000E+11 0.1000E+11 0.1000E+11 0.1000E+11
0.1000E+01 0.1000E+01 0.1000E+11 0.1000E+11 0.1000E+11 0.1000E+11
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+11 0.1000E+11 0.1000E+11
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+11 0.1000E+11
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+11
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
1 6
0.1000E-03 0.1000E+05 0.1000E+04 0.1000E+02 0.1000E+00 0.1000E-01
0.1000E-02 0.1000E-04 0.1000E+05 0.1000E+03 0.1000E+01 0.1000E+00
0.1000E+00 0.1000E-02 0.1000E-03 0.1000E+05 0.1000E+03 0.1000E+02
0.1000E+02 0.1000E+00 0.1000E-01 0.1000E-03 0.1000E+05 0.1000E+04
0.1000E+03 0.1000E+01 0.1000E+00 0.1000E-02 0.1000E-04 0.1000E+05
0.1000E+05 0.1000E+03 0.1000E+02 0.1000E+00 0.1000E-02 0.1000E-03
0.1000E-03 0.1000E+05 0.1000E+04 0.1000E+02 0.1000E+00 0.1000E-01
0.1000E-02 0.1000E-04 0.1000E+05 0.1000E+03 0.1000E+01 0.1000E+00
0.1000E+00 0.1000E-02 0.1000E-03 0.1000E+05 0.1000E+03 0.1000E+02
0.1000E+02 0.1000E+00 0.1000E-01 0.1000E-03 0.1000E+05 0.1000E+04
0.1000E+03 0.1000E+01 0.1000E+00 0.1000E-02 0.1000E-04 0.1000E+05
0.1000E+05 0.1000E+03 0.1000E+02 0.1000E+00 0.1000E-02 0.1000E-03
0.1000E-05 0.1000E-04 0.1000E-02 0.1000E+00 0.1000E+01 0.1000E+03
0.1000E+03 0.1000E+01 0.1000E+00 0.1000E-02 0.1000E-04 0.1000E-05
6
0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+07 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E-05 0.1000E+07
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+07 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E-05 0.1000E-05
0.1000E+07 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+07 0.1000E+07
0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+07 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E-05 0.1000E+07
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+07 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E-05 0.1000E-05
0.1000E+07 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+07 0.1000E+07
4 6
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E-04 0.1000E+04 0.1000E+00
0.0000E+00 0.1000E+01 0.1000E+01 0.1000E-04 0.1000E+04 0.1000E+00
0.0000E+00 0.0000E+00 0.1000E+01 0.1000E-04 0.1000E+04 0.1000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E-03 0.1000E+05
0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+05 0.1000E+01 0.1000E-03
0.0000E+00 0.0000E+00 0.0000E+00 0.1000E-03 0.1000E+05 0.1000E+01
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E-04 0.1000E+04 0.1000E+00
0.0000E+00 0.1000E+01 0.1000E+01 0.1000E-04 0.1000E+04 0.1000E+00
0.0000E+00 0.0000E+00 0.1000E+01 0.1000E-04 0.1000E+04 0.1000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E-03 0.1000E+05
0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+05 0.1000E+01 0.1000E-03
0.0000E+00 0.0000E+00 0.0000E+00 0.1000E-03 0.1000E+05 0.1000E+01
0.4000E+01 0.4000E+01 0.4000E+01 0.1000E+00 0.1000E+04 0.1000E-04
0.2000E+01 0.3000E+01 0.4000E+01 0.1000E-04 0.1000E+04 0.1000E+00
7
0.0000E+00 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01
0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01
0.0000E+00 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01
0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00
0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.1000E+01
0.0000E+00 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01
0.0000E+00 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01
0.0000E+00 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01
0.0000E+00 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01
0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00
0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.1000E+01
0.0000E+00 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01
3 5
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01
0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01
0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01
0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01
0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
0.1000E+01
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.1000E+01
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01
0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01
0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01
0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01
0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
0.1000E+01
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.1000E+01
0.3000E+01 0.2000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.6000E+01
0.5000E+01
0.1000E+01 0.3000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.2000E+01
0.2000E+01
6
-0.2000E+02 -0.1000E+05 -0.2000E+01 -0.1000E+07 -0.1000E+02 -0.2000E+06
0.6000E-02 0.4000E+01 0.6000E-03 0.2000E+03 0.3000E-02 0.3000E+02
-0.2000E+00 -0.3000E+03 -0.4000E-01 -0.1000E+05 0.0000E+00 0.3000E+04
0.6000E-04 0.4000E-01 0.9000E-05 0.9000E+01 0.3000E-04 0.5000E+00
0.6000E-01 0.5000E+02 0.8000E-02 -0.4000E+04 0.8000E-01 0.0000E+00
0.0000E+00 0.1000E+04 0.7000E+00 -0.2000E+06 0.1300E+02 -0.6000E+05
-0.2000E+02 -0.1000E+05 0.2000E+01 -0.2000E+07 0.1000E+02 -0.1000E+06
0.5000E-02 0.3000E+01 -0.2000E-03 0.4000E+03 -0.1000E-02 0.3000E+02
0.0000E+00 -0.1000E+03 -0.8000E-01 0.2000E+05 -0.4000E+00 0.0000E+00
0.5000E-04 0.3000E-01 0.2000E-05 0.4000E+01 0.2000E-04 0.1000E+00
0.4000E-01 0.3000E+02 -0.1000E-02 0.3000E+04 -0.1000E-01 0.6000E+03
-0.1000E+01 0.0000E+00 0.4000E+00 -0.1000E+06 0.4000E+01 0.2000E+05
1 6
-0.2000E+00 -0.1000E+01 -0.2000E+00 -0.1000E+01 -0.1000E+01 -0.2000E+01
0.6000E+00 0.4000E+01 0.6000E+00 0.2000E+01 0.3000E+01 0.3000E+01
-0.2000E+00 -0.3000E+01 -0.4000E+00 -0.1000E+01 0.0000E+00 0.3000E+01
0.6000E+00 0.4000E+01 0.9000E+00 0.9000E+01 0.3000E+01 0.5000E+01
0.6000E+00 0.5000E+01 0.8000E+00 -0.4000E+01 0.8000E+01 0.0000E+00
0.0000E+00 0.1000E+01 0.7000E+00 -0.2000E+01 0.1300E+02 -0.6000E+01
-0.2000E+00 -0.1000E+01 0.2000E+00 -0.2000E+01 0.1000E+01 -0.1000E+01
0.5000E+00 0.3000E+01 -0.2000E+00 0.4000E+01 -0.1000E+01 0.3000E+01
0.0000E+00 -0.1000E+01 -0.8000E+00 0.2000E+01 -0.4000E+01 0.0000E+00
0.5000E+00 0.3000E+01 0.2000E+00 0.4000E+01 0.2000E+01 0.1000E+01
0.4000E+00 0.3000E+01 -0.1000E+00 0.3000E+01 -0.1000E+01 0.6000E+01
-0.1000E+00 0.0000E+00 0.4000E+00 -0.1000E+01 0.4000E+01 0.2000E+01
0.1000E-02 0.1000E+02 0.1000E+00 0.1000E+04 0.1000E+01 0.1000E-01
0.1000E+02 0.1000E+00 0.1000E+03 0.1000E-02 0.1000E+03 0.1000E-01
0
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/seig/Makefile_javasrc 0000644 0001750 0001750 00000003243 10616442122 025314 0 ustar osallou osallou .PHONY: DUMMY
.SUFFIXES: .f .java
ROOT=../../..
include $(ROOT)/make.def
BLAS=$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR)
LAPACK=$(ROOT)/$(LAPACK_DIR)/$(LAPACK_JAR)
SMATGEN=$(ROOT)/$(SMATGEN_DIR)/$(SMATGEN_JAR)
tester: $(BLAS) $(LAPACK) $(SMATGEN) $(OUTDIR)/Seigtest.f2j util
/bin/rm -f `find $(OUTDIR) -name "*.class"`
mkdir -p $(JAVASRC_OUTDIR)
$(JAVAC) -classpath .:$(JAVASRC_OUTDIR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(SMATGEN):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/$(LAPACK_DIR)/$(LAPACK_JAR) -d $(JAVASRC_OUTDIR) $(OUTDIR)/$(SEIGTEST_PDIR)/*.java
/bin/rm -f $(JAVASRC_OUTDIR)/$(SEIGTEST_PDIR)/*.old
$(JAVAB) $(JAVASRC_OUTDIR)/$(SEIGTEST_PDIR)/*.class
/bin/rm -f $(SEIGTEST_JAR)
cd $(JAVASRC_OUTDIR); $(JAR) cvf ../$(SEIGTEST_JAR) `find . -name "*.class"`
$(JAR) uvf $(SEIGTEST_JAR) `find org -name "*.class"`
$(OUTDIR)/Seigtest.f2j: seigtest.f
$(MAKE) nojar
$(BLAS):
cd $(ROOT)/$(BLAS_DIR); $(MAKE) -f Makefile_javasrc
$(LAPACK):
cd $(ROOT)/$(LAPACK_DIR); $(MAKE) -f Makefile_javasrc
$(SMATGEN):
cd $(ROOT)/$(SMATGEN_DIR); $(MAKE) -f Makefile_javasrc
util:
cd $(ROOT)/$(UTIL_DIR); $(MAKE)
runtest: tester *.in
*.in: DUMMY
$(JAVA) $(JFLAGS) -cp .:$(SEIGTEST_JAR):$(SMATGEN):$(BLAS):$(LAPACK):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR) $(SEIGTEST_PACKAGE).Schkee < $@
verify: $(ROOT)/$(SEIGTEST_IDX)
cd $(JAVASRC_OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:..:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(SMATGEN_DIR)/$(SMATGEN_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/../$(LAPACK_DIR)/$(LAPACK_JAR) $(VERIFY) $(SEIGTEST_PDIR)/*.class
clean:
/bin/rm -rf *.java *.class *.f2j org $(JAVASRC_OUTDIR) $(OUTDIR) $(SEIGTEST_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/seig/sgd.in 0000644 0001750 0001750 00000010500 10616163241 023244 0 ustar osallou osallou SGS Data for the Real Nonsymmetric Schur Form Driver
5 Number of matrix dimensions
2 6 10 12 20 30 Matrix dimensions
1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
10 Threshold for test ratios
.TRUE. Put T to test the error exits
0 Code to interpret the seed
SGS 26 Test all 26 matrix types
SGV Data for the Real Nonsymmetric Eigenvalue Problem Driver
6 Number of matrix dimensions
2 6 8 10 15 20 Matrix dimensions
1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
10 Threshold value
.TRUE. Put T to test the error exits
0 Code to interpret the seed
SGV 26 Test all 26 matrix types
SGX Data for the Real Nonsymmetric Schur Form Expert Driver
2 Largest matrix dimension (0 <= NSIZE <= 5)
1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
10 Threshold for test ratios
.TRUE. Put T to test the error exits
0 Code to interpret the seed
SGX Data for the Real Nonsymmetric Schur Form Expert Driver
0 Largest matrix dimension (0 <= NSIZE <= 5)
1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
10 Threshold for test ratios
.TRUE. Put T to test the error exits
0 Code to interpret the seed
4
2
8.0000E+00 4.0000E+00 -1.3000E+01 4.0000E+00 Input matrix A
0.0000E+00 7.0000E+00 -2.4000E+01 -3.0000E+00
0.0000E+00 0.0000E+00 3.0000E+00 -5.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 1.6000E+01
9.0000E+00 -1.0000E+00 1.0000E+00 -6.0000E+00 Input matrix B
0.0000E+00 4.0000E+00 1.6000E+01 -2.4000E+01
0.0000E+00 0.0000E+00 -1.1000E+01 6.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 4.0000E+00
2.5901E-01 1.7592E+00 Condition #'s for cluster selected from lower 2x2
4
2
1.0000E+00 2.0000E+00 3.0000E+00 4.0000E+00 Input matrix A
0.0000E+00 5.0000E+00 6.0000E+00 7.0000E+00
0.0000E+00 0.0000E+00 8.0000E+00 9.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+01
-1.0000E+00 -1.0000E+00 -1.0000E+00 -1.0000E+00 Input matrix B
0.0000E+00 -1.0000E+00 -1.0000E+00 -1.0000E+00
0.0000E+00 0.0000E+00 1.0000E+00 -1.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
9.8173E-01 6.3649E-01 Condition #'s for cluster selected from lower 2x2
0
SXV Data for the Real Nonsymmetric Eigenvalue Expert Driver
5 Largest matrix dimension
1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
10 Threshold for test ratios
.TRUE. Put T to test the error exits
0 Code to interpret the seed
SXV Data for the Real Nonsymmetric Eigenvalue Expert Driver
0 Largest matrix dimension
1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
10 Threshold for test ratios
.TRUE. Put T to test the error exits
0 Code to interpret the seed
4
8.0000E+00 4.0000E+00 -1.3000E+01 4.0000E+00 Input matrix A
0.0000E+00 7.0000E+00 -2.4000E+01 -3.0000E+00
0.0000E+00 0.0000E+00 3.0000E+00 -5.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 1.6000E+01
9.0000E+00 -1.0000E+00 1.0000E+00 -6.0000E+00 Input matrix B
0.0000E+00 4.0000E+00 1.6000E+01 -2.4000E+01
0.0000E+00 0.0000E+00 -1.1000E+01 6.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 4.0000E+00
3.1476E+00 2.5286E+00 4.2241E+00 3.4160E+00 eigenvalue condition #'s
6.7340E-01 1.1380E+00 3.5424E+00 9.5917E-01 eigenvector condition #'s
4
1.0000E+00 2.0000E+00 3.0000E+00 4.0000E+00 Input matrix A
0.0000E+00 5.0000E+00 6.0000E+00 7.0000E+00
0.0000E+00 0.0000E+00 8.0000E+00 9.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+01
-1.0000E+00 -1.0000E+00 -1.0000E+00 -1.0000E+00 Input matrix B
0.0000E+00 -1.0000E+00 -1.0000E+00 -1.0000E+00
0.0000E+00 0.0000E+00 1.0000E+00 -1.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
1.3639E+00 4.0417E+00 6.4089E-01 6.8030E-01 eigenvalue condition #'s
7.6064E-01 8.4964E-01 1.1222E-01 1.1499E-01 eigenvector condition #'s
0
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/seig/nep.in 0000644 0001750 0001750 00000002132 10616163240 023252 0 ustar osallou osallou NEP: Data file for testing Nonsymmetric Eigenvalue Problem routines
7 Number of values of N
0 1 2 3 5 10 16 Values of N (dimension)
5 Number of values of NB, NBMIN, NX, INMIN, IN WIN, INIBL, ISHFTS, and IACC22
1 3 3 3 20 Values of NB (blocksize)
2 2 2 2 2 Values of NBMIN (minimum blocksize)
1 0 5 9 1 Values of NX (crossover point)
11 12 11 15 11 Values of INMIN (LAHQR vs TTQRE crossover point, >= 11)
2 3 5 3 2 Values of INWIN (recommended deflation window size)
0 5 7 3 200 Values of INIBL (nibble crossover point)
1 2 4 2 1 Values of ISHFTS (number of simultaneous shifts)
0 1 2 0 1 Values of IACC22 (select structured matrix multiply: 0, 1 or 2)
20.0 Threshold value
T Put T to test the error exits
1 Code to interpret the seed
NEP 21
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/seig/Makefile 0000644 0001750 0001750 00000003156 10616442122 023606 0 ustar osallou osallou .PHONY: DUMMY
.SUFFIXES: .f .java
ROOT=../../..
include $(ROOT)/make.def
BLAS=$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR)
LAPACK=$(ROOT)/$(LAPACK_DIR)/$(LAPACK_JAR)
SMATGEN=$(ROOT)/$(SMATGEN_DIR)/$(SMATGEN_JAR)
XERBLAFLAGS= -c .:$(ROOT)/$(BLAS_OBJ) -p $(ERR_PACKAGE)
F2JFLAGS=-c .:$(ROOT)/$(BLAS_OBJ):$(ROOT)/$(LAPACK_OBJ):$(ROOT)/$(SMATGEN_OBJ) -p $(SEIGTEST_PACKAGE) -o $(OUTDIR) $(STATIC)
tester: $(BLAS) $(LAPACK) $(SMATGEN) $(OUTDIR)/Seigtest.f2j util
/bin/rm -f $(SEIGTEST_JAR)
cd $(OUTDIR); $(JAR) cvf ../$(SEIGTEST_JAR) `find . -name "*.class"`
$(JAR) uvf $(SEIGTEST_JAR) `find org -name "*.class"`
nojar: $(BLAS) $(LAPACK) $(SMATGEN) $(OUTDIR)/Seigtest.f2j util
$(OUTDIR)/Seigtest.f2j: seigtest.f
$(F2J) $(XERBLAFLAGS) xerbla.f > /dev/null
$(F2J) $(F2JFLAGS) $< > /dev/null
$(BLAS):
cd $(ROOT)/$(BLAS_DIR); $(MAKE)
$(LAPACK):
cd $(ROOT)/$(LAPACK_DIR); $(MAKE)
$(SMATGEN):
cd $(ROOT)/$(SMATGEN_DIR); $(MAKE)
util:
cd $(ROOT)/$(UTIL_DIR); $(MAKE)
runtest: tester *.in
srctest:
$(MAKE) -f Makefile_javasrc runtest
verify: $(ROOT)/$(SEIGTEST_IDX)
cd $(OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:..:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(SMATGEN_DIR)/$(SMATGEN_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/../$(LAPACK_DIR)/$(LAPACK_JAR) $(VERIFY) $(SEIGTEST_PDIR)/*.class
*.in: DUMMY
$(JAVA) $(JFLAGS) -cp .:$(SEIGTEST_JAR):$(SMATGEN):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/$(LAPACK_DIR)/$(LAPACK_JAR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR) $(SEIGTEST_PACKAGE).Schkee < $@
clean:
/bin/rm -rf *.java *.class *.f2j org $(JAVASRC_OUTDIR) $(OUTDIR) $(SEIGTEST_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/seig/sbb.in 0000644 0001750 0001750 00000001222 10616163240 023235 0 ustar osallou osallou SBB: Data file for testing banded Singular Value Decomposition routines
20 Number of values of M
0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 10 10 16 16 Values of M
0 1 2 3 0 1 2 3 0 1 2 3 0 1 2 3 10 16 10 16 Values of N
5 Number of values of K
0 1 2 3 16 Values of K (band width)
2 Number of values of NRHS
1 2 Values of NRHS
20.0 Threshold value
F Put T to test the error exits
1 Code to interpret the seed
SBB 15
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/seig/gsv.in 0000644 0001750 0001750 00000001031 10616163240 023264 0 ustar osallou osallou GSV: Data file for testing Generalized SVD routines
8 Number of values of M, P, N
0 5 9 10 20 12 12 40 Values of M (row dimension)
4 0 12 14 10 10 20 15 Values of P (row dimension)
3 10 15 12 8 20 8 20 Values of N (column dimension)
20.0 Threshold value of test ratio
T Put T to test the error exits
1 Code to interpret the seed
GSV 8 List types on next line if 0 < NTYPES < 8
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/seig/sbal.in 0000644 0001750 0001750 00000023075 10616163240 023422 0 ustar osallou osallou SBL: Tests SGEBAL
5
0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.2000E+01 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.3000E+01 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.4000E+01 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.5000E+01
1 1
0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.2000E+01 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.3000E+01 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.4000E+01 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.5000E+01
0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.5000E+01
5
0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.1000E+01 0.2000E+01 0.0000E+00 0.0000E+00 0.0000E+00
0.1000E+01 0.2000E+01 0.3000E+01 0.0000E+00 0.0000E+00
0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.0000E+00
0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.5000E+01
1 1
0.5000E+01 0.4000E+01 0.3000E+01 0.2000E+01 0.1000E+01
0.0000E+00 0.4000E+01 0.3000E+01 0.2000E+01 0.1000E+01
0.0000E+00 0.0000E+00 0.3000E+01 0.2000E+01 0.1000E+01
0.0000E+00 0.0000E+00 0.0000E+00 0.2000E+01 0.1000E+01
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
0.1000E+01 0.2000E+01 0.3000E+01 0.2000E+01 0.1000E+01
5
0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.1000E+01 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.1000E+01 0.1000E+01 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01
1 1
0.1000E+01 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.1000E+01 0.1000E+01 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
0.1000E+01 0.2000E+01 0.3000E+01 0.2000E+01 0.1000E+01
4
0.0000E+00 0.2000E+01 0.1000E+00 0.0000E+00
0.2000E+01 0.0000E+00 0.0000E+00 0.1000E+00
0.1000E+03 0.0000E+00 0.0000E+00 0.2000E+01
0.0000E+00 0.1000E+03 0.2000E+01 0.0000E+00
1 4
0.0000E-03 2.0000E+00 3.2000E+00 0.0000E-03
2.0000E+00 0.0000E-03 0.0000E-03 3.2000E+00
3.1250E+00 0.0000E-03 0.0000E-03 2.0000E+00
0.0000E-03 3.1250E+00 2.0000E+00 0.0000E-03
62.5000E-03 62.5000E-03 2.0000E+00 2.0000E+00
6
0.2000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1024E+04
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1280E+03
0.0000E+00 0.2000E+01 0.3000E+04 0.0000E+00 0.0000E+00 0.2000E+01
0.1280E+03 0.4000E+01 0.4000E-02 0.5000E+01 0.6000E+03 0.8000E+01
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.2000E-02 0.2000E+01
0.8000E+01 0.8192E+04 0.0000E+00 0.0000E+00 0.0000E+00 0.2000E+01
4 6
0.5000E+01 0.4000E-02 0.6000E+03 0.1024E+04 0.5000E+00 0.8000E+01
0.0000E+00 0.3000E+04 0.0000E+00 0.0000E+00 0.2500E+00 0.2000E+01
0.0000E+00 0.0000E+00 0.2000E-02 0.0000E+00 0.0000E+00 0.2000E+01
0.0000E+00 0.0000E+00 0.0000E+00 0.2000E+01 0.0000E+00 0.1280E+03
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1024E+04
0.0000E+00 0.0000E+00 0.0000E+00 0.6400E+02 0.1024E+04 0.2000E+01
0.4000E+01 0.3000E+01 0.5000E+01 0.8000E+01 0.1250E+00 0.1000E+01
5
0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.8000E+01
0.0000E+00 0.2000E+01 0.8192E+04 0.2000E+01 0.4000E+01
0.2500E-03 0.1250E-03 0.4000E+01 0.0000E+00 0.6400E+02
0.0000E+00 0.2000E+01 0.1024E+04 0.4000E+01 0.8000E+01
0.0000E+00 0.8192E+04 0.0000E+00 0.0000E+00 0.8000E+01
1 5
1.0000E+00 0.0000E-03 0.0000E-03 0.0000E-03 250.0000E-03
0.0000E-03 2.0000E+00 1.0240E+03 16.0000E+00 16.0000E+00
256.0000E-03 1.0000E-03 4.0000E+00 0.0000E-03 2.0480E+03
0.0000E-03 250.0000E-03 16.0000E+00 4.0000E+00 4.0000E+00
0.0000E-03 2.0480E+03 0.0000E-03 0.0000E-03 8.0000E+00
64.0000E+00 500.0000E-03 62.5000E-03 4.0000E+00 2.0000E+00
4
0.1000E+01 0.1000E+07 0.1000E+07 0.1000E+07
-0.2000E+07 0.3000E+01 0.2000E-05 0.3000E-05
-0.3000E+07 0.0000E+00 0.1000E-05 0.2000E+01
0.1000E+07 0.0000E+00 0.3000E-05 0.4000E+07
1 4
1.0000E+00 1.0000E+06 2.0000E+06 1.0000E+06
-2.0000E+06 3.0000E+00 4.0000E-06 3.0000E-06
-1.5000E+06 0.0000E-03 1.0000E-06 1.0000E+00
1.0000E+06 0.0000E-03 6.0000E-06 4.0000E+06
1.0000E+00 1.0000E+00 2.0000E+00 1.0000E+00
4
0.1000E+01 0.1000E+05 0.1000E+05 0.1000E+05
-0.2000E+05 0.3000E+01 0.2000E-02 0.3000E-02
0.0000E+00 0.2000E+01 0.0000E+00 -0.3000E+05
0.0000E+00 0.0000E+00 0.1000E+05 0.0000E+00
1 4
1.0000E+00 10.0000E+03 10.0000E+03 5.0000E+03
-20.0000E+03 3.0000E+00 2.0000E-03 1.5000E-03
0.0000E-03 2.0000E+00 0.0000E-03 -15.0000E+03
0.0000E-03 0.0000E-03 20.0000E+03 0.0000E-03
1.0000E+00 1.0000E+00 1.0000E+00 500.0000E-03
5
0.1000E+01 0.5120E+03 0.4096E+04 3.2768E+04 2.62144E+05
0.8000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.8000E+01 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.8000E+01 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.8000E+01 0.0000E+00
1 5
1.0000E+00 32.0000E+00 32.0000E+00 32.0000E+000 32.0000E+00
128.0000E+00 0.0000E-03 0.0000E-03 0.0000E-003 0.0000E-03
0.0000E-03 64.0000E+00 0.0000E-03 0.0000E-003 0.0000E-03
0.0000E-03 0.0000E-03 64.0000E+00 0.0000E-003 0.0000E-03
0.0000E-03 0.0000E-03 0.0000E-03 64.0000E+000 0.0000E-03
256.0000E+00 16.0000E+00 2.0000E+00 250.0000E-03 31.2500E-03
6
0.1000E+01 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00
0.1000E+01 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
2 5
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
0.3000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.4000E+01
7
0.6000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00
0.0000E+00 0.4000E+01 0.0000E+00 0.2500E-03 0.1250E-01 0.2000E-01 0.1250E+00
0.1000E+01 0.1280E+03 0.6400E+02 0.0000E+00 0.0000E+00 -0.2000E+01 0.1600E+02
0.0000E+00 1.6384E+04 0.0000E+00 0.1000E+01 -0.4000E+03 0.2560E+03 -0.4000E+04
-0.2000E+01 -0.2560E+03 0.0000E+00 0.1250E-01 0.2000E+01 0.2000E+01 0.3200E+02
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.8000E+01 0.0000E+00 0.4000E-02 0.1250E+00 -0.2000E+00 0.3000E+01
2 5
6.4000E+01 2.5000E-01 5.00000E-01 0.0000E+00 0.0000E+00 1.0000E+00 -2.0000E+00
0.0000E+00 4.0000E+00 2.00000E+00 4.0960E+00 1.6000E+00 0.0000E+00 1.0240E+01
0.0000E+00 5.0000E-01 3.00000E+00 4.0960E+00 1.0000E+00 0.0000E+00 -6.4000E+00
0.0000E+00 1.0000E+00 -3.90625E+00 1.0000E+00 -3.1250E+00 0.0000E+00 8.0000E+00
0.0000E+00 -2.0000E+00 4.00000E+00 1.6000E+00 2.0000E+00 -8.0000E+00 8.0000E+00
0.0000E+00 0.0000E+00 0.00000E+00 0.0000E+00 0.0000E+00 6.0000E+00 1.0000E+00
0.0000E+00 0.0000E+00 0.00000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
3.0000E+00 1.953125E-03 3.1250E-02 3.2000E+01 2.5000E-01 1.0000E+00 6.0000E+00
5
0.1000E+04 0.2000E+01 0.3000E+01 0.4000E+01 0.5000E+06
0.9000E+01 0.0000E+00 0.2000E-03 0.1000E+01 0.3000E+01
0.0000E+00 -0.3000E+03 0.2000E+01 0.1000E+01 0.1000E+01
0.9000E+01 0.2000E-02 0.1000E+01 0.1000E+01 -0.1000E+04
0.6000E+01 0.2000E+03 0.1000E+01 0.6000E+03 0.3000E+01
1 5
1.0000E+03 3.1250E-02 3.7500E-01 6.2500E-02 3.90625E+03
5.7600E+02 0.0000E+00 1.6000E-03 1.0000E+00 1.5000E+00
0.0000E+00 -3.7500E+01 2.0000E+00 1.2500E-01 6.2500E-02
5.7600E+02 2.0000E-03 8.0000E+00 1.0000E+00 -5.0000E+02
7.6800E+02 4.0000E+02 1.6000E+01 1.2000E+03 3.0000E+00
1.2800E+02 2.0000E+00 1.6000E+01 2.0000E+00 1.0000E+00
5
1.0000E+00 1.0000E+15 0.0000E+00 0.0000E+00 0.0000E+00
1.0000E-15 1.0000E+00 1.0000E+15 0.0000E+00 0.0000E+00
0.0000E+00 1.0000E-15 1.0000E+00 1.0000E+15 0.0000E+00
0.0000E+00 0.0000E+00 1.0000E-15 1.0000E+00 1.0000E+15
0.0000E+00 0.0000E+00 0.0000E+00 1.0000E-15 1.0000E+00
1 5
1.0000000E+00 7.1054273E+00 0.0000000E+00 0.0000000E+00 0.0000000E+00
1.4073749E-01 1.0000000E+00 3.5527136E+00 0.0000000E+00 0.0000000E+00
0.0000000E+00 2.8147498E-01 1.0000000E+00 1.7763568E+00 0.0000000E+00
0.0000000E+00 0.0000000E+00 5.6294996E-01 1.0000000E+00 8.8817841E-01
0.0000000E+00 0.0000000E+00 0.0000000E+00 1.1258999E+00 1.0000000E+00
5.0706024E+30 3.6028797E+16 1.2800000E+02 2.2737368E-13 2.0194839E-28
0
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/seig/glm.in 0000644 0001750 0001750 00000001105 10616163240 023246 0 ustar osallou osallou GLM: Data file for testing Generalized Linear Regression Model routines
6 Number of values of M, P, and N
0 5 8 15 20 40 Values of M (row dimension)
9 0 15 12 15 30 Values of P (row dimension)
5 5 10 25 30 40 Values of N (col dimension), M <= N <= M+P
20.0 Threshold value of test ratio
T Put T to test the error exits
1 Code to interpret the seed
GLM 8 List types on next line if 0 < NTYPES < 8
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/seig/sbak.in 0000644 0001750 0001750 00000013547 10616163240 023424 0 ustar osallou osallou SBK: Tests SGEBAK
5 1 1
0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.5000E+01
0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
5 1 1
0.1000E+01 0.2000E+01 0.3000E+01 0.2000E+01 0.1000E+01
0.1000E+01 0.1000E+01 0.1000E+01 -0.6667E+00 -0.4167E-01
0.0000E+00 -0.2500E+00 -0.6667E+00 0.1000E+01 0.1667E+00
0.0000E+00 0.0000E+00 0.2222E+00 -0.1000E+01 -0.5000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.5000E+00 0.1000E+01
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 -0.1000E+01
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 -0.1000E+01
0.0000E+00 0.0000E+00 0.0000E+00 0.5000E+00 0.1000E+01
0.0000E+00 0.0000E+00 0.2222E+00 -0.1000E+01 -0.5000E+00
0.0000E+00 -0.2500E+00 -0.6667E+00 0.1000E+01 0.1667E+00
0.1000E+01 0.1000E+01 0.1000E+01 -0.6667E+00 -0.4167E-01
5 1 1
0.1000E+01 0.2000E+01 0.3000E+01 0.2000E+01 0.1000E+01
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.0000E+00 -0.6000E-17 -0.6000E-17 -0.6000E-17 -0.6000E-17
0.0000E+00 0.0000E+00 0.3600E-34 0.3600E-34 0.3600E-34
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.3600E-34 0.3600E-34 0.3600E-34
0.0000E+00 -0.6000E-17 -0.6000E-17 -0.6000E-17 -0.6000E-17
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
6 4 6
0.4000E+01 0.3000E+01 0.5000E+01 0.1000E+03 0.1000E+00 0.1000E+01
0.1000E+01 0.1336E-05 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.0000E+00 0.1000E+01 0.0000E+00 -0.3001E-10 -0.3252E-04 0.1305E-01
0.0000E+00 0.0000E+00 -0.8330E-02 0.8929E-09 -0.6712E-04 0.6687E-04
0.0000E+00 0.0000E+00 0.0000E+00 -0.4455E-05 -0.3355E-02 0.3345E-02
0.0000E+00 0.0000E+00 0.0000E+00 0.4455E-06 -0.3356E-01 0.3344E-01
0.0000E+00 0.0000E+00 0.0000E+00 0.4411E-09 0.1011E+00 0.1008E+00
0.0000E+00 0.0000E+00 0.0000E+00 -0.4455E-03 -0.3355E+00 0.3345E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.4455E-07 -0.3356E-02 0.3344E-02
0.0000E+00 0.1000E+01 0.0000E+00 -0.3001E-10 -0.3252E-04 0.1305E-01
0.1000E+01 0.1336E-05 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.0000E+00 0.0000E+00 -0.8330E-02 0.8929E-09 -0.6712E-04 0.6687E-04
0.0000E+00 0.0000E+00 0.0000E+00 0.4411E-09 0.1011E+00 0.1008E+00
5 1 5
0.1000E+03 0.1000E+00 0.1000E-01 0.1000E+01 0.1000E+02
0.1366E-03 -0.6829E-04 0.1252E-03 0.1000E+01 0.1950E-14
0.1000E+01 0.1000E+01 -0.2776E-16 0.3601E-05 -0.6073E-17
0.2736E+00 -0.1363E+00 0.2503E+00 -0.3322E-05 -0.2000E-02
0.6909E-02 -0.3443E-02 0.6196E-02 0.1666E-01 0.1000E+01
0.3899E+00 -0.2033E+00 -0.3420E+00 -0.1000E-02 0.6000E-14
0.1366E-01 -0.6829E-02 0.1252E-01 0.1000E+03 0.1950E-12
0.1000E+00 0.1000E+00 -0.2776E-17 0.3601E-06 -0.6073E-18
0.2736E-02 -0.1363E-02 0.2503E-02 -0.3322E-07 -0.2000E-04
0.6909E-02 -0.3443E-02 0.6196E-02 0.1666E-01 0.1000E+01
0.3899E+01 -0.2033E+01 -0.3420E+01 -0.1000E-01 0.6000E-13
6 2 5
0.3000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.4000E+01
0.1000E+01 0.1000E+01 0.2776E-15 -0.2405E-16 0.0000E+00 0.1000E+01
0.0000E+00 0.7500E+00 0.1000E+01 0.8520E-01 0.0000E+00 -0.1520E-16
0.0000E+00 0.7500E+00 -0.8093E+00 0.1000E+01 0.0000E+00 -0.1520E-16
0.0000E+00 0.7500E+00 -0.9533E-01 -0.5426E+00 0.1000E+01 -0.1520E-16
0.0000E+00 0.7500E+00 -0.9533E-01 -0.5426E+00 -0.1000E+01 -0.1520E-16
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.4559E-16
0.0000E+00 0.7500E+00 -0.8093E+00 0.1000E+01 0.0000E+00 -0.1520E-16
0.0000E+00 0.7500E+00 0.1000E+01 0.8520E-01 0.0000E+00 -0.1520E-16
0.1000E+01 0.1000E+01 0.2776E-15 -0.2405E-16 0.0000E+00 0.1000E+01
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.4559E-16
0.0000E+00 0.7500E+00 -0.9533E-01 -0.5426E+00 -0.1000E+01 -0.1520E-16
0.0000E+00 0.7500E+00 -0.9533E-01 -0.5426E+00 0.1000E+01 -0.1520E-16
7 2 5
0.3000E+01 0.1000E-02 0.1000E-01 0.1000E+02 0.1000E+00 0.1000E+01
0.6000E+01
0.1000E+01 -0.1105E-01 0.3794E-01 -0.9378E-01 -0.3481E-01 0.4465E+00
-0.3602E-01
0.0000E+00 -0.4556E+00 -0.4545E+00 0.1000E+01 0.4639E+00 -0.6512E+00
0.4781E+00
0.0000E+00 -0.2734E+00 -0.7946E+00 0.6303E+00 0.1000E+01 -0.6279E+00
0.1000E+01
0.0000E+00 0.1000E+01 -0.6939E-17 0.4259E-01 -0.6495E+00 -0.5581E+00
-0.6452E+00
0.0000E+00 -0.3904E+00 -0.4029E+00 -0.1685E+00 -0.9429E+00 0.1000E+01
-0.9371E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 -0.2558E+00
0.3308E-03
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
-0.1985E-02
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 -0.2558E+00
0.3308E-03
0.0000E+00 -0.4556E-03 -0.4545E-03 0.1000E-02 0.4639E-03 -0.6512E-03
0.4781E-03
0.1000E+01 -0.1105E-01 0.3794E-01 -0.9378E-01 -0.3481E-01 0.4465E+00
-0.3602E-01
0.0000E+00 0.1000E+02 -0.6939E-16 0.4259E+00 -0.6495E+01 -0.5581E+01
-0.6452E+01
0.0000E+00 -0.3904E-01 -0.4029E-01 -0.1685E-01 -0.9429E-01 0.1000E+00
-0.9371E-01
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
-0.1985E-02
0.0000E+00 -0.2734E-02 -0.7946E-02 0.6303E-02 0.1000E-01 -0.6279E-02
0.1000E-01
0 0 0
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/seig/svd.in 0000644 0001750 0001750 00000001740 10616163241 023271 0 ustar osallou osallou SVD: Data file for testing Singular Value Decomposition routines
19 Number of values of M
0 0 0 1 1 1 2 2 3 3 3 10 10 16 16 30 30 40 40 Values of M
0 1 3 0 1 2 0 1 0 1 3 10 16 10 16 30 40 30 40 Values of N
5 Number of parameter values
1 3 3 3 20 Values of NB (blocksize)
2 2 2 2 2 Values of NBMIN (minimum blocksize)
1 0 5 9 1 Values of NX (crossover point)
2 0 2 2 2 Values of NRHS
35.0 Threshold value
T Put T to test the LAPACK routines
T Put T to test the driver routines
T Put T to test the error exits
1 Code to interpret the seed
SVD 16
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/seig/sgbak.in 0000644 0001750 0001750 00000026220 10616163241 023564 0 ustar osallou osallou SGK: Tests SGGBAK
6 3
0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.2000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.3000E+01 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.4000E+01 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.5000E+01 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.6000E+01
0.6000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.5000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.4000E+01 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.3000E+01 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.2000E+01 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
0.1000E+01 0.1000E+01 0.1000E+01
0.2000E+01 0.2000E+01 0.2000E+01
0.3000E+01 0.3000E+01 0.3000E+01
0.4000E+01 0.4000E+01 0.4000E+01
0.5000E+01 0.5000E+01 0.5000E+01
0.6000E+01 0.6000E+01 0.6000E+01
-0.1000E+01 -0.1000E+01 -0.1000E+01
-0.2000E+01 -0.2000E+01 -0.2000E+01
-0.3000E+01 -0.3000E+01 -0.3000E+01
-0.4000E+01 -0.4000E+01 -0.4000E+01
-0.5000E+01 -0.5000E+01 -0.5000E+01
-0.6000E+01 -0.6000E+01 -0.6000E+01
6 3
0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.2000E+01 0.2100E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.3000E+01 0.3100E+01 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.4000E+01 0.4100E+01 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.5000E+01 0.5100E+01 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.6000E+01 0.6100E+01
0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.2000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.3000E+01 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.4000E+01 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.5000E+01 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.6000E+01
0.1000E+01 0.1000E+01 0.1000E+01
0.2000E+01 0.2000E+01 0.2000E+01
0.3000E+01 0.3000E+01 0.3000E+01
0.4000E+01 0.4000E+01 0.4000E+01
0.5000E+01 0.5000E+01 0.5000E+01
0.6000E+01 0.6000E+01 0.6000E+01
-0.1000E+01 -0.1000E+01 -0.1000E+01
-0.2000E+01 -0.2000E+01 -0.2000E+01
-0.3000E+01 -0.3000E+01 -0.3000E+01
-0.4000E+01 -0.4000E+01 -0.4000E+01
-0.5000E+01 -0.5000E+01 -0.5000E+01
-0.6000E+01 -0.6000E+01 -0.6000E+01
5 5
0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.1000E+01 0.2000E+01 0.0000E+00 0.0000E+00 0.0000E+00
0.1000E+01 0.2000E+01 0.3000E+01 0.0000E+00 0.0000E+00
0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.0000E+00
0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.5000E+01
0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.2000E+01 0.2000E+01 0.2000E+01 0.2000E+01 0.2000E+01
0.3000E+01 0.3000E+01 0.3000E+01 0.3000E+01 0.3000E+01
0.4000E+01 0.4000E+01 0.4000E+01 0.4000E+01 0.4000E+01
0.5000E+01 0.5000E+01 0.5000E+01 0.5000E+01 0.5000E+01
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.2000E+01 0.2000E+01 0.2000E+01 0.2000E+01 0.2000E+01
0.3000E+01 0.3000E+01 0.3000E+01 0.3000E+01 0.3000E+01
0.4000E+01 0.4000E+01 0.4000E+01 0.4000E+01 0.4000E+01
0.5000E+01 0.5000E+01 0.5000E+01 0.5000E+01 0.5000E+01
6 5
0.1000E+01 0.1000E+11 0.1000E+11 0.1000E+11 0.1000E+11 0.1000E+11
0.1000E+01 0.1000E+01 0.1000E+11 0.1000E+11 0.1000E+11 0.1000E+11
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+11 0.1000E+11 0.1000E+11
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+11 0.1000E+11
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+11
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01 0.1000E+11 0.1000E+11 0.1000E+11 0.1000E+11 0.1000E+11
0.1000E+01 0.1000E+01 0.1000E+11 0.1000E+11 0.1000E+11 0.1000E+11
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+11 0.1000E+11 0.1000E+11
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+11 0.1000E+11
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+11
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01 0.2000E+01 -0.3000E+01 0.4000E+01 0.5000E+01
0.8000E+01 0.9000E+01 0.0000E+00 0.9000E+01 0.2000E+01
0.0000E+00 -0.9000E+01 0.2000E+01 0.1000E+01 0.1000E+01
0.8000E+01 0.2000E+01 0.1000E+01 0.0000E+00 0.2000E+01
0.0000E+00 0.3000E+01 0.2000E+01 0.1000E+01 0.1000E+01
0.2000E+01 0.1000E+01 0.9000E+01 0.0000E+00 0.1000E+01
0.1000E+01 -0.2000E+01 0.3000E+01 0.4000E+01 0.5000E+01
-0.8000E+01 0.9000E+01 0.0000E+00 0.9000E+01 0.2000E+01
0.0000E+00 0.9000E+01 0.2000E+01 0.1000E+01 0.1000E+01
0.8000E+01 0.2000E+01 0.1000E+01 0.0000E+00 0.2000E+01
0.0000E+00 0.3000E+01 0.2000E+01 0.1000E+01 0.1000E+01
0.2000E+01 0.8000E+01 0.9000E+01 0.0000E+00 0.1000E+01
6 2
0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+07 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E-05 0.1000E+07
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+07 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E-05 0.1000E-05
0.1000E+07 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+07 0.1000E+07
0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+07 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E-05 0.1000E+07
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+07 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E-05 0.1000E-05
0.1000E+07 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+07 0.1000E+07
0.1000E+01 0.1000E+01
0.2000E+01 0.2000E+01
0.3000E+01 0.3000E+01
0.4000E+01 0.4000E+01
0.5000E+01 0.5000E+01
0.6000E+01 0.6000E+01
0.1100E+01 0.1100E+01
0.2200E+01 0.2200E+01
0.3300E+01 0.3300E+01
0.4400E+01 0.4400E+01
0.5500E+01 0.5500E+01
0.6600E+01 0.6600E+01
7 3
0.0000E+00 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01
0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01
0.0000E+00 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01
0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00
0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.1000E+01
0.0000E+00 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01
0.0000E+00 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01
0.0000E+00 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01
0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01
0.0000E+00 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01
0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00
0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.1000E+01
0.0000E+00 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
0.1000E+01
0.1000E+01 0.1000E+01 0.1000E+01
0.2000E+01 0.2000E+01 0.2000E+01
0.3000E+01 0.3000E+01 0.3000E+01
0.4000E+01 0.4000E+01 0.4000E+01
0.5000E+01 0.5000E+01 0.5000E+01
0.6000E+01 0.6000E+01 0.6000E+01
0.7000E+01 0.7000E+01 0.7000E+01
-0.1000E+01 -0.1000E+01 -0.1000E+01
-0.2000E+01 -0.2000E+01 -0.2000E+01
-0.3000E+01 -0.3000E+01 -0.3000E+01
-0.4000E+01 -0.4000E+01 -0.4000E+01
-0.5000E+01 -0.5000E+01 -0.5000E+01
-0.6000E+01 -0.6000E+01 -0.6000E+01
-0.7000E+01 -0.7000E+01 -0.7000E+01
7 3
0.0000E+00 0.1000E+04 0.0000E+00 0.1000E+04 0.1000E+04 0.1000E+04
0.1000E-04
0.0000E+00 0.1000E-04 0.1000E+04 0.1000E-04 0.1000E-04 0.1000E+04
0.1000E+04
0.1000E+04 0.1000E+04 0.1000E-04 0.1000E+04 0.1000E+04 0.1000E+04
0.1000E+04
0.0000E+00 0.1000E-04 0.0000E+00 0.1000E+00 0.1000E+04 0.1000E-04
0.1000E+04
0.0000E+00 0.1000E+04 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00
0.0000E+00 0.4000E-04 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.1000E-04
0.0000E+00 0.1000E+04 0.0000E+00 0.1000E+04 0.1000E+04 0.1000E-04
0.1000E+04
0.0000E+00 0.1000E-01 0.0000E+00 0.1000E+04 0.1000E-04 0.1000E+04
0.1000E+04
0.0000E+00 0.1000E+04 0.1000E+04 0.1000E+04 0.1000E+04 0.1000E+00
0.1000E+04
0.1000E+04 0.1000E+04 0.1000E+04 0.1000E+04 0.1000E-04 0.1000E+04
0.1000E+04
0.0000E+00 0.4000E-01 0.0000E+00 0.1000E+04 0.1000E+01 0.1000E+04
0.1000E+04
0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00
0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.1000E+01
0.0000E+00 0.1000E-04 0.0000E+00 0.1000E+04 0.1000E+01 0.1000E+01
0.1000E-04
0.1000E+01 0.1000E+01 0.1000E+01
0.2000E+01 0.2000E+01 0.2000E+01
0.3000E+01 0.3000E+01 0.3000E+01
0.4000E+01 0.4000E+01 0.4000E+01
0.5000E+01 0.5000E+01 0.5000E+01
0.6000E+01 0.6000E+01 0.6000E+01
0.7000E+01 0.7000E+01 0.7000E+01
0.1000E+01 0.1000E+01 0.1000E+01
0.2000E+01 0.2000E+01 0.2000E+01
0.3000E+01 0.3000E+01 0.3000E+01
0.4000E+01 0.4000E+01 0.4000E+01
0.5000E+01 0.5000E+01 0.5000E+01
0.6000E+01 0.6000E+01 0.6000E+01
0.7000E+01 0.7000E+01 0.7000E+01
6 2
-0.2000E+02 -0.1000E+05 -0.2000E+01 -0.1000E+07 -0.1000E+02 -0.2000E+06
0.6000E-02 0.4000E+01 0.6000E-03 0.2000E+03 0.3000E-02 0.3000E+02
-0.2000E+00 -0.3000E+03 -0.4000E-01 -0.1000E+05 0.0000E+00 0.3000E+04
0.6000E-04 0.4000E-01 0.9000E-05 0.9000E+01 0.3000E-04 0.5000E+00
0.6000E-01 0.5000E+02 0.8000E-02 -0.4000E+04 0.8000E-01 0.0000E+00
0.0000E+00 0.1000E+04 0.7000E+00 -0.2000E+06 0.1300E+02 -0.6000E+05
-0.2000E+02 -0.1000E+05 0.2000E+01 -0.2000E+07 0.1000E+02 -0.1000E+06
0.5000E-02 0.3000E+01 -0.2000E-03 0.4000E+03 -0.1000E-02 0.3000E+02
0.0000E+00 -0.1000E+03 -0.8000E-01 0.2000E+05 -0.4000E+00 0.0000E+00
0.5000E-04 0.3000E-01 0.2000E-05 0.4000E+01 0.2000E-04 0.1000E+00
0.4000E-01 0.3000E+02 -0.1000E-02 0.3000E+04 -0.1000E-01 0.6000E+03
-0.1000E+01 0.0000E+00 0.4000E+00 -0.1000E+06 0.4000E+01 0.2000E+05
0.1000E+01 0.1000E+01
0.2000E+01 0.2000E+01
0.3000E+01 0.3000E+01
0.4000E+01 0.4000E+01
0.5000E+01 0.5000E+01
0.6000E+01 0.6000E+01
0.1000E+02 0.1000E+02
0.2000E+02 0.2000E+02
0.3000E+02 0.3000E+02
0.4000E+02 0.4000E+02
0.5000E+02 0.5000E+02
0.6000E+02 0.6000E+02
0 0
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/seig/sep.in 0000644 0001750 0001750 00000001355 10616163241 023266 0 ustar osallou osallou SEP: Data file for testing Symmetric Eigenvalue Problem routines
6 Number of values of N
0 1 2 3 5 20 Values of N (dimension)
5 Number of values of NB
1 3 3 3 10 Values of NB (blocksize)
2 2 2 2 2 Values of NBMIN (minimum blocksize)
1 0 5 9 1 Values of NX (crossover point)
50.0 Threshold value
T Put T to test the LAPACK routines
T Put T to test the driver routines
T Put T to test the error exits
1 Code to interpret the seed
SEP 21
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/seig/sec.in 0000644 0001750 0001750 00000150725 10616163240 023256 0 ustar osallou osallou SEC Key indicating type of input
20.0 Threshold value for test ratios
8 2 7
1.0E+00 1.0E+00 1.1E+00 1.3E+00 2.0E+00 3.0E+00 -4.7E+00 3.3E+00
-1.0E+00 1.0E+00 3.7E+00 7.9E+00 4.0E+00 5.3E+00 3.3E+00 -9.0E-01
0.0E+00 0.0E+00 2.0E+00 -3.0E+00 3.4E+00 6.5E+00 5.2E+00 1.8E+00
0.0E+00 0.0E+00 4.0E+00 2.0E+00 -5.3E+00 -8.9E+00 -2.0E-01 -5.0E-01
0.0E+00 0.0E+00 0.0E+00 0.0E+00 4.2E+00 2.0E+00 3.3E+00 2.3E+00
0.0E+00 0.0E+00 0.0E+00 0.0E+00 -3.7E+00 4.2E+00 9.9E+00 8.8E+00
0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 9.9E+00 8.8E+00
0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 -9.9E+00 9.9E+00
8 7 2
1.0E+00 1.0E+00 1.1E+00 1.3E+00 2.0E+00 3.0E+00 -4.7E+00 3.3E+00
-1.0E+00 1.0E+00 3.7E+00 7.9E+00 4.0E+00 5.3E+00 3.3E+00 -9.0E-01
0.0E+00 0.0E+00 2.0E+00 -3.0E+00 3.4E+00 6.5E+00 5.2E+00 1.8E+00
0.0E+00 0.0E+00 4.0E+00 2.0E+00 -5.3E+00 -8.9E+00 -2.0E-01 -5.0E-01
0.0E+00 0.0E+00 0.0E+00 0.0E+00 4.2E+00 2.0E+00 3.3E+00 2.3E+00
0.0E+00 0.0E+00 0.0E+00 0.0E+00 -3.7E+00 4.2E+00 9.9E+00 8.8E+00
0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 9.9E+00 8.8E+00
0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 -9.9E+00 9.9E+00
8 1 7
1.0E+00 1.0E+00 1.1E+00 1.3E+00 2.0E+00 3.0E+00 -4.7E+00 3.3E+00
0.0E+00 1.0E+00 3.7E+00 7.9E+00 4.0E+00 5.3E+00 3.3E+00 -9.0E-01
0.0E+00 0.0E+00 2.0E+00 -3.0E+00 3.4E+00 6.5E+00 5.2E+00 1.8E+00
0.0E+00 0.0E+00 4.0E+00 2.0E+00 -5.3E+00 -8.9E+00 -2.0E-01 -5.0E-01
0.0E+00 0.0E+00 0.0E+00 0.0E+00 4.2E+00 2.0E+00 3.3E+00 2.3E+00
0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 4.2E+00 9.9E+00 8.8E+00
0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 9.9E+00 8.8E+00
0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 -9.9E+00 9.9E+00
8 8 2
1.0E+00 1.0E+00 1.1E+00 1.3E+00 2.0E+00 3.0E+00 -4.7E+00 3.3E+00
-1.1E+00 1.0E+00 3.7E+00 7.9E+00 4.0E+00 5.3E+00 3.3E+00 -9.0E-01
0.0E+00 0.0E+00 2.0E+00 -3.0E+00 3.4E+00 6.5E+00 5.2E+00 1.8E+00
0.0E+00 0.0E+00 0.0E+00 2.0E+00 -5.3E+00 -8.9E+00 -2.0E-01 -5.0E-01
0.0E+00 0.0E+00 0.0E+00 0.0E+00 4.2E+00 2.0E+00 3.3E+00 2.3E+00
0.0E+00 0.0E+00 0.0E+00 0.0E+00 -3.7E+00 4.2E+00 9.9E+00 8.8E+00
0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 9.9E+00 8.8E+00
0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 9.9E+00
7 2 7
1.1E+00 1.0E-16 2.7E+00 3.3E+00 2.3E+00 3.4E+00 5.6E+00
-1.0E-16 1.1E+00 4.2E+00 5.1E+00 -1.0E-01 -2.0E-01 -3.0E-01
0.0E+00 0.0E+00 2.3E+00 1.0E+00 1.0E+02 1.0E+03 1.0E+02
0.0E+00 0.0E+00 0.0E+00 3.9E+00 3.2E+00 6.5E+00 3.2E+00
0.0E+00 0.0E+00 0.0E+00 -9.0E-01 3.9E+00 6.3E+00 3.0E+00
0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 6.3E+00 3.0E+00
0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 -9.0E-01 6.3E+00
7 2 7
1.1E+00 1.0E-16 2.7E+00 3.3E+00 2.3E+00 3.4E+00 5.6E+00
-1.0E-16 1.1E+00 4.2E+00 5.1E+00 -1.0E-01 -2.0E-01 -3.0E-01
0.0E+00 0.0E+00 2.3E+00 1.0E+00 1.0E+02 1.0E+03 1.0E+02
0.0E+00 0.0E+00 0.0E+00 3.9E+00 3.2E-15 6.5E+00 3.2E+00
0.0E+00 0.0E+00 0.0E+00 -9.0E-16 3.9E+00 6.3E+00 3.0E+00
0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 6.3E+00 3.0E+00
0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 6.4E+00
7 2 7
1.1E+00 1.0E-16 2.7E+00 3.3E+00 2.3E+00 3.4E+00 5.6E+00
-1.0E-16 1.1E+00 4.2E+00 5.1E+00 -1.0E-01 -2.0E-01 -3.0E-01
0.0E+00 0.0E+00 2.3E+00 1.0E+00 1.0E+02 1.0E+03 1.0E+02
0.0E+00 0.0E+00 0.0E+00 3.9E+00 3.2E-15 6.5E+00 3.2E+00
0.0E+00 0.0E+00 0.0E+00 -9.0E-16 3.9E+00 6.3E+00 3.0E+00
0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 6.3E+00 3.0E+00
0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 -9.0E-21 6.3E+00
7 1 7
1.1E+00 1.0E-16 2.7E+00 3.3E+00 2.3E+00 3.4E+00 5.6E+00
0.0E+00 1.1E+00 4.2E+00 5.1E+00 -1.0E-01 -2.0E-01 -3.0E-01
0.0E+00 0.0E+00 2.3E+00 1.0E+00 1.0E+02 1.0E+03 1.0E+02
0.0E+00 0.0E+00 0.0E+00 3.9E+00 3.2E-15 6.5E+00 3.2E+00
0.0E+00 0.0E+00 0.0E+00 -9.0E-16 3.9E+00 6.3E+00 3.0E+00
0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 6.3E+00 3.0E+00
0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 -9.0E-21 6.3E+00
7 1 7
1.1E+00 -1.1E+00 2.7E+00 3.3E+00 2.3E+00 3.4E+00 5.6E+00
2.3E+00 1.1E+00 4.2E+00 5.1E+00 -1.0E-01 -2.0E-01 -3.0E-01
0.0E+00 0.0E+00 2.3E+00 1.0E+00 1.0E+02 1.0E+03 1.0E+02
0.0E+00 0.0E+00 0.0E+00 3.9E+00 3.2E+00 6.5E+00 3.2E+00
0.0E+00 0.0E+00 0.0E+00 -9.0E-21 3.9E+00 6.3E+00 3.0E+00
0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 6.3E+00 3.0E-20
0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 -9.0E-21 6.3E+00
7 7 2
6.3E+00 3.0E+00 2.7E+00 3.3E+00 2.3E+00 3.4E+00 5.6E+00
-9.0E-01 6.3E+00 4.2E+00 5.1E+00 -1.0E-01 -2.0E-01 -3.0E-01
0.0E+00 0.0E+00 2.3E+00 1.0E+00 1.0E+02 1.0E+03 1.0E+02
0.0E+00 0.0E+00 0.0E+00 3.9E+00 3.2E+00 6.5E+00 3.2E+00
0.0E+00 0.0E+00 0.0E+00 0.0E+00 3.8E+00 6.3E+00 3.0E+00
0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 1.1E+00 1.4E-20
0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 -1.6E-20 1.1E+00
7 7 2
6.3E+00 3.0E+00 2.7E+00 3.3E+00 2.3E+00 3.4E+00 5.6E+00
-9.0E-01 6.3E+00 4.2E+00 5.1E+00 -1.0E-01 -2.0E-01 -3.0E-01
0.0E+00 0.0E+00 2.3E+00 1.0E+00 1.0E+02 1.0E+03 1.0E+02
0.0E+00 0.0E+00 0.0E+00 3.9E+00 3.2E+00 6.5E+00 3.2E+00
0.0E+00 0.0E+00 0.0E+00 -9.0E-01 3.9E+00 6.3E+00 3.0E+00
0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 1.1E+00 1.4E-20
0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 -1.6E-20 1.1E+00
7 7 2
1.1E+00 1.0E-16 2.7E+00 3.3E+00 2.3E+00 3.4E+00 5.6E+00
-1.0E-16 1.1E+00 4.2E+00 5.1E+00 -1.0E-01 -2.0E-01 -3.0E-01
0.0E+00 0.0E+00 2.3E+00 1.0E+00 1.0E+02 1.0E+03 1.0E+02
0.0E+00 0.0E+00 0.0E+00 3.9E+00 3.2E-15 6.5E+00 3.2E+00
0.0E+00 0.0E+00 0.0E+00 -9.0E-16 3.9E+00 6.3E+00 3.0E+00
0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 6.3E+00 3.0E+00
0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 -9.0E-21 6.3E+00
7 7 1
1.1E+00 1.0E-16 2.7E+06 3.3E+00 2.3E+00 3.4E+00 5.6E+00
0.0E+00 1.1E+00 4.2E+06 5.1E+00 -1.0E-01 -2.0E-01 -3.0E-01
0.0E+00 0.0E+00 2.3E+00 1.0E+07 1.0E+08 1.0E+03 1.0E+02
0.0E+00 0.0E+00 0.0E+00 3.9E+00 3.2E-15 6.5E+04 3.2E+00
0.0E+00 0.0E+00 0.0E+00 -9.0E-16 3.9E+00 6.3E+03 3.0E+05
0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 6.3E+00 3.0E+00
0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 -9.0E-21 6.3E+00
8 8 1
1.1E+00 -1.0E-16 2.7E+06 2.3E+04 3.3E+00 2.3E+00 3.4E+00 5.6E+00
1.0E-16 1.1E+00 4.2E+06 -1.0E-01 5.1E+00 -1.0E-01 -2.0E-01 -3.0E-01
0.0E+00 0.0E+00 2.3E+00 1.1E-16 1.0E+07 1.0E+08 1.0E+03 1.0E+02
0.0E+00 0.0E+00 -1.1E-13 2.3E+00 1.0E+07 1.0E+08 1.0E+03 1.0E+02
0.0E+00 0.0E+00 0.0E+00 0.0E+00 3.9E+00 3.2E-15 6.5E+04 3.2E+00
0.0E+00 0.0E+00 0.0E+00 0.0E+00 -9.0E-16 3.9E+00 6.3E+03 3.0E+05
0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 6.3E+00 3.0E-20
0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 -9.0E-21 6.3E+00
0 0 0
1
0.0000E+00
0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
1
1.0000E+00
1.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
2
0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
2
3.0000E+00 2.0000E+00
2.0000E+00 3.0000E+00
1.0000E+00 0.0000E+00 1.0000E+00 4.0000E+00
5.0000E+00 0.0000E+00 1.0000E+00 4.0000E+00
2
3.0000E+00 -2.0000E+00
2.0000E+00 3.0000E+00
3.0000E+00 2.0000E+00 1.0000E+00 4.0000E+00
3.0000E+00 -2.0000E+00 1.0000E+00 4.0000E+00
6
1.0000E-07 -1.0000E-07 1.0000E+00 1.1000E+00 2.3000E+00 3.7000E+00
3.0000E-07 1.0000E-07 1.0000E+00 1.0000E+00 -1.3000E+00 -7.7000E+00
0.0000E+00 0.0000E+00 3.0000E-07 1.0000E-07 2.2000E+00 3.3000E+00
0.0000E+00 0.0000E+00 -1.0000E-07 3.0000E-07 1.8000E+00 1.6000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 4.0000E-06 5.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 3.0000E+00 4.0000E-06
-3.8730E+00 0.0000E+00 6.9855E-01 2.2823E+00
1.0000E-07 1.7321E-07 9.7611E-08 5.0060E-14
1.0000E-07 -1.7321E-07 9.7611E-08 5.0060E-14
3.0000E-07 1.0000E-07 1.0000E-07 9.4094E-14
3.0000E-07 -1.0000E-07 1.0000E-07 9.4094E-14
3.8730E+00 0.0000E+00 4.0659E-01 1.5283E+00
4
7.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00
-1.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00
-1.0000E+00 1.0000E+00 5.0000E+00 -3.0000E+00
1.0000E+00 -1.0000E+00 3.0000E+00 3.0000E+00
3.9603E+00 4.0425E-02 1.1244E-05 3.1179E-05
3.9603E+00 -4.0425E-02 1.1244E-05 3.1179E-05
4.0397E+00 3.8854E-02 1.0807E-05 2.9981E-05
4.0397E+00 -3.8854E-02 1.0807E-05 2.9981E-05
5
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
0.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
0.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
0.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
0.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
5
1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
1.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
1.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
1.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
1.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
1.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
6
1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
6
1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
6
1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 2.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 3.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 4.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 5.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 6.0000E+00
1.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
2.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
3.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
4.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
5.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
6.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
4
9.4480E-01 6.7670E-01 6.9080E-01 5.9650E-01
5.8760E-01 8.6420E-01 6.7690E-01 7.2600E-02
7.2560E-01 1.9430E-01 9.6870E-01 2.8310E-01
2.8490E-01 5.8000E-02 4.8450E-01 7.3610E-01
2.4326E-01 2.1409E-01 8.7105E-01 3.5073E-01
2.4326E-01 -2.1409E-01 8.7105E-01 3.5073E-01
7.4091E-01 0.0000E+00 9.8194E-01 4.6989E-01
2.2864E+00 0.0000E+00 9.7723E-01 1.5455E+00
6
5.0410E-01 6.6520E-01 7.7190E-01 6.3870E-01 5.9550E-01 6.1310E-01
1.5740E-01 3.7340E-01 5.9840E-01 1.5470E-01 9.4270E-01 6.5900E-02
4.4170E-01 7.2300E-02 1.5440E-01 5.4920E-01 8.7000E-03 3.0040E-01
2.0080E-01 6.0800E-01 3.0340E-01 8.4390E-01 2.3900E-01 5.7680E-01
9.3610E-01 7.4130E-01 1.4440E-01 1.7860E-01 1.4280E-01 7.2630E-01
5.5990E-01 9.3360E-01 7.8000E-02 4.0930E-01 6.7140E-01 5.6170E-01
-5.2278E-01 0.0000E+00 2.7888E-01 1.1793E-01
-3.5380E-01 0.0000E+00 3.5427E-01 6.8911E-02
-8.0876E-03 0.0000E+00 3.4558E-01 1.3489E-01
3.4760E-01 3.0525E-01 5.4661E-01 1.7729E-01
3.4760E-01 -3.0525E-01 5.4661E-01 1.7729E-01
2.7698E+00 0.0000E+00 9.6635E-01 1.8270E+00
5
2.0000E-03 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 1.0000E-03 1.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 -1.0000E-03 1.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 -2.0000E-03 1.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
-2.0000E-03 0.0000E+00 2.4000E-11 2.3952E-11
-1.0000E-03 0.0000E+00 6.0000E-12 5.9940E-12
0.0000E+00 0.0000E+00 4.0000E-12 3.9920E-12
1.0000E-03 0.0000E+00 6.0000E-12 5.9940E-12
2.0000E-03 0.0000E+00 2.4000E-11 2.3952E-11
10
4.8630E-01 9.1260E-01 2.1900E-02 6.0110E-01 1.4050E-01 2.0840E-01
8.2640E-01 8.4410E-01 3.1420E-01 8.6750E-01
7.1500E-01 2.6480E-01 8.8510E-01 2.6150E-01 5.9520E-01 4.7800E-01
7.6730E-01 4.6110E-01 5.7320E-01 7.7000E-03
2.1210E-01 5.5080E-01 5.2350E-01 3.0810E-01 6.6020E-01 2.8900E-01
2.3140E-01 2.2790E-01 9.6600E-02 1.0910E-01
7.1510E-01 8.5790E-01 5.7710E-01 5.1140E-01 1.9010E-01 9.0810E-01
6.0090E-01 7.1980E-01 1.0640E-01 8.6840E-01
5.6800E-01 2.8100E-02 4.0140E-01 6.3150E-01 1.1480E-01 7.5800E-02
9.4230E-01 7.2030E-01 3.6850E-01 1.7430E-01
7.7210E-01 3.0280E-01 5.5640E-01 9.9980E-01 3.6520E-01 5.2580E-01
3.7030E-01 6.7790E-01 9.9350E-01 5.0270E-01
7.3960E-01 4.5600E-02 7.4740E-01 9.2880E-01 2.2000E-03 8.2600E-02
3.6340E-01 4.9120E-01 9.4050E-01 3.8910E-01
5.6370E-01 8.5540E-01 3.2100E-02 2.6380E-01 3.6090E-01 6.4970E-01
8.4690E-01 9.3500E-01 3.7000E-02 2.9170E-01
8.6560E-01 6.3270E-01 3.5620E-01 6.3560E-01 2.7360E-01 6.5120E-01
1.0220E-01 2.8880E-01 5.7620E-01 4.0790E-01
5.3320E-01 4.1210E-01 7.2870E-01 2.3110E-01 6.8300E-01 7.3860E-01
8.1800E-01 9.8150E-01 8.0550E-01 2.5660E-01
-4.6121E-01 7.2657E-01 4.7781E-01 1.5842E-01
-4.6121E-01 -7.2657E-01 4.7781E-01 1.5842E-01
-4.5164E-01 0.0000E+00 4.6034E-01 1.9931E-01
-1.4922E-01 4.8255E-01 4.7500E-01 9.1686E-02
-1.4922E-01 -4.8255E-01 4.7500E-01 9.1686E-02
3.3062E-02 0.0000E+00 2.9729E-01 8.2469E-02
3.0849E-01 1.1953E-01 4.2947E-01 3.9688E-02
3.0849E-01 -1.1953E-01 4.2947E-01 3.9688E-02
5.4509E-01 0.0000E+00 7.0777E-01 1.5033E-01
5.0352E+00 0.0000E+00 9.7257E-01 3.5548E+00
4
-3.8730E-01 3.6560E-01 3.1200E-02 -5.8340E-01
5.5230E-01 -1.1854E+00 9.8330E-01 7.6670E-01
1.6746E+00 -1.9900E-02 -1.8293E+00 5.7180E-01
-5.2500E-01 3.5340E-01 -2.7210E-01 -8.8300E-02
-1.8952E+00 7.5059E-01 8.1913E-01 7.7090E-01
-1.8952E+00 -7.5059E-01 8.1913E-01 7.7090E-01
-9.5162E-02 0.0000E+00 8.0499E-01 4.9037E-01
3.9520E-01 0.0000E+00 9.8222E-01 4.9037E-01
6
-1.0777E+00 1.7027E+00 2.6510E-01 8.5160E-01 1.0121E+00 2.5710E-01
-1.3400E-02 3.9030E-01 -1.2680E+00 2.7530E-01 -3.2350E-01 -1.3844E+00
1.5230E-01 3.0680E-01 8.7330E-01 -3.3410E-01 -4.8310E-01 -1.5416E+00
1.4470E-01 -6.0570E-01 3.1900E-02 -1.0905E+00 -8.3700E-02 6.2410E-01
-7.6510E-01 -1.7889E+00 -1.5069E+00 -6.0210E-01 5.2170E-01 6.4700E-01
8.1940E-01 2.1100E-01 5.4320E-01 7.5610E-01 1.7130E-01 5.5400E-01
-1.7029E+00 0.0000E+00 6.7909E-01 6.7220E-01
-1.0307E+00 0.0000E+00 7.2671E-01 2.0436E-01
2.8487E-01 1.2101E+00 3.9757E-01 4.9797E-01
2.8487E-01 -1.2101E+00 3.9757E-01 4.9797E-01
1.1675E+00 4.6631E-01 4.2334E-01 1.9048E-01
1.1675E+00 -4.6631E-01 4.2334E-01 1.9048E-01
10
-1.0639E+00 1.6120E-01 1.5620E-01 3.4360E-01 -6.7480E-01 1.6598E+00
6.4650E-01 -7.8630E-01 -2.6100E-01 7.0190E-01
-8.4400E-01 -2.2439E+00 1.8800E+00 -1.0005E+00 7.4500E-02 -1.6156E+00
2.8220E-01 8.5600E-01 1.3497E+00 -1.5883E+00
1.5988E+00 1.1758E+00 1.2398E+00 1.1173E+00 2.1500E-01 4.3140E-01
1.8500E-01 7.9470E-01 6.6260E-01 8.6460E-01
-2.2960E-01 1.2442E+00 2.3242E+00 -5.0690E-01 -7.5160E-01 -5.4370E-01
-2.5990E-01 1.2830E+00 -1.1067E+00 -1.1150E-01
-3.6040E-01 4.0420E-01 6.1240E-01 -1.2164E+00 -9.4650E-01 -3.1460E-01
1.8310E-01 7.3710E-01 1.4278E+00 2.9220E-01
4.6150E-01 3.8740E-01 -4.2900E-02 -9.3600E-01 7.1160E-01 -8.2590E-01
-1.7640E+00 -9.4660E-01 1.8202E+00 -2.5480E-01
1.2934E+00 -9.7550E-01 6.7480E-01 -1.0481E+00 -1.8442E+00 -5.4600E-02
7.4050E-01 6.1000E-03 1.2430E+00 -1.8490E-01
-3.4710E-01 -9.5800E-01 1.6530E-01 9.1300E-02 -5.2010E-01 -1.1832E+00
8.5410E-01 -2.3200E-01 -1.6155E+00 5.5180E-01
1.0190E+00 -6.8240E-01 8.0850E-01 2.5950E-01 -3.7580E-01 -1.8825E+00
1.6473E+00 -6.5920E-01 8.0250E-01 -4.9000E-03
1.2670E+00 -4.2400E-02 8.9570E-01 -1.6770E-01 1.4620E-01 9.8800E-01
-2.3170E-01 -1.4483E+00 -5.8200E-02 1.9700E-02
-2.6992E+00 9.0387E-01 6.4005E-01 4.1615E-01
-2.6992E+00 -9.0387E-01 6.4005E-01 4.1615E-01
-2.4366E+00 0.0000E+00 6.9083E-01 2.5476E-01
-1.2882E+00 8.8930E-01 5.3435E-01 6.0878E-01
-1.2882E+00 -8.8930E-01 5.3435E-01 6.0878E-01
9.0275E-01 0.0000E+00 2.9802E-01 4.7530E-01
9.0442E-01 2.5661E+00 7.3193E-01 6.2016E-01
9.0442E-01 -2.5661E+00 7.3193E-01 6.2016E-01
1.6774E+00 0.0000E+00 3.0743E-01 4.1726E-01
3.0060E+00 0.0000E+00 8.5623E-01 4.3175E-01
4
-1.2298E+00 -2.3142E+00 -6.9800E-02 1.0523E+00
2.0390E-01 -1.2298E+00 8.0500E-02 9.7860E-01
0.0000E+00 0.0000E+00 2.5600E-01 -8.9100E-01
0.0000E+00 0.0000E+00 2.7480E-01 2.5600E-01
-1.2298E+00 6.8692E-01 4.7136E-01 7.1772E-01
-1.2298E+00 -6.8692E-01 4.7136E-01 7.1772E-01
2.5600E-01 4.9482E-01 8.0960E-01 5.1408E-01
2.5600E-01 -4.9482E-01 8.0960E-01 5.1408E-01
6
5.9930E-01 1.9372E+00 -1.6160E-01 -1.4602E+00 6.0180E-01 2.7120E+00
-2.2049E+00 5.9930E-01 -1.0679E+00 1.9405E+00 -1.4400E+00 -2.2110E-01
0.0000E+00 0.0000E+00 -2.4567E+00 -6.8650E-01 -1.9101E+00 6.4960E-01
0.0000E+00 0.0000E+00 0.0000E+00 7.3620E-01 3.9700E-01 -1.5190E-01
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 -1.0034E+00 1.1954E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 -1.3400E-01 -1.0034E+00
-2.4567E+00 0.0000E+00 4.7091E-01 8.5788E-01
-1.0034E+00 4.0023E-01 3.6889E-01 1.8909E-01
-1.0034E+00 -4.0023E-01 3.6889E-01 1.8909E-01
5.9930E-01 2.0667E+00 5.8849E-01 1.3299E+00
5.9930E-01 -2.0667E+00 5.8849E-01 1.3299E+00
7.3620E-01 0.0000E+00 6.0845E-01 9.6725E-01
4
1.0000E-04 1.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 -1.0000E-04 1.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 1.0000E-02 1.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 -5.0000E-03
-5.0000E-03 0.0000E+00 3.7485E-07 3.6932E-07
-1.0000E-04 0.0000E+00 9.8979E-09 9.8493E-09
1.0000E-04 0.0000E+00 1.0098E-08 1.0046E-08
1.0000E-02 0.0000E+00 1.4996E-06 1.4773E-06
3
2.0000E-06 1.0000E+00 -2.0000E+00
1.0000E-06 -2.0000E+00 4.0000E+00
0.0000E+00 1.0000E+00 -2.0000E+00
-4.0000E+00 0.0000E+00 7.3030E-01 4.0000E+00
0.0000E+00 0.0000E+00 7.2801E-01 1.3726E-06
2.2096E-06 0.0000E+00 8.2763E-01 2.2096E-06
6
2.4080E-01 6.5530E-01 9.1660E-01 5.0300E-02 2.8490E-01 2.4080E-01
6.9070E-01 9.7000E-01 1.4020E-01 5.7820E-01 6.7670E-01 6.9070E-01
1.0620E-01 3.8000E-02 7.0540E-01 2.4320E-01 8.6420E-01 1.0620E-01
2.6400E-01 9.8800E-02 1.7800E-02 9.4480E-01 1.9430E-01 2.6400E-01
7.0340E-01 2.5600E-01 2.6110E-01 5.8760E-01 5.8000E-02 7.0340E-01
4.0210E-01 5.5980E-01 1.3580E-01 7.2560E-01 6.9080E-01 4.0210E-01
-3.4008E-01 3.2133E-01 5.7839E-01 2.0310E-01
-3.4008E-01 -3.2133E-01 5.7839E-01 2.0310E-01
-1.6998E-07 0.0000E+00 4.9641E-01 2.1574E-01
7.2311E-01 5.9389E-02 7.0039E-01 4.1945E-02
7.2311E-01 -5.9389E-02 7.0039E-01 4.1945E-02
2.5551E+00 0.0000E+00 9.2518E-01 1.7390E+00
6
3.4800E+00 -2.9900E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
-4.9000E-01 2.4800E+00 -1.9900E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 -4.9000E-01 1.4800E+00 -9.9000E-01 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 -9.9000E-01 1.4800E+00 -4.9000E-01 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 -1.9900E+00 2.4800E+00 -4.9000E-01
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 -2.9900E+00 3.4800E+00
1.3034E-02 0.0000E+00 7.5301E-01 6.0533E-01
1.1294E+00 0.0000E+00 6.0479E-01 2.8613E-01
2.0644E+00 0.0000E+00 5.4665E-01 1.7376E-01
2.8388E+00 0.0000E+00 4.2771E-01 3.0915E-01
4.3726E+00 0.0000E+00 6.6370E-01 7.6443E-02
4.4618E+00 0.0000E+00 5.7388E-01 8.9227E-02
6
0.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
1.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 1.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 1.0000E+00
-1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
-1.7321E+00 0.0000E+00 8.6603E-01 7.2597E-01
-1.0000E+00 0.0000E+00 5.0000E-01 2.6417E-01
0.0000E+00 0.0000E+00 2.9582E-31 1.4600E-07
0.0000E+00 0.0000E+00 2.9582E-31 6.2446E-08
1.0000E+00 0.0000E+00 5.0000E-01 2.6417E-01
1.7321E+00 0.0000E+00 8.6603E-01 3.7896E-01
6
3.5345E-01 9.3023E-01 7.4679E-02 -1.0059E-02 4.6698E-02 -4.3480E-02
9.3545E-01 -3.5147E-01 -2.8216E-02 3.8008E-03 -1.7644E-02 1.6428E-02
0.0000E+00 -1.0555E-01 7.5211E-01 -1.0131E-01 4.7030E-01 -4.3789E-01
0.0000E+00 0.0000E+00 6.5419E-01 1.1779E-01 -5.4678E-01 5.0911E-01
0.0000E+00 0.0000E+00 0.0000E+00 -9.8780E-01 -1.1398E-01 1.0612E-01
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 6.8144E-01 7.3187E-01
-9.9980E-01 1.9645E-02 1.0000E+00 3.9290E-02
-9.9980E-01 -1.9645E-02 1.0000E+00 3.9290E-02
7.4539E-01 6.6663E-01 1.0000E+00 5.2120E-01
7.4539E-01 -6.6663E-01 1.0000E+00 5.2120E-01
9.9929E-01 3.7545E-02 1.0000E+00 7.5089E-02
9.9929E-01 -3.7545E-02 1.0000E+00 7.5089E-02
6
1.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00
5.0000E-01 3.3330E-01 2.5000E-01 2.0000E-01 1.6670E-01 1.4290E-01
3.3330E-01 2.5000E-01 2.0000E-01 1.6670E-01 1.4290E-01 1.2500E-01
2.5000E-01 2.0000E-01 1.6670E-01 1.4290E-01 1.2500E-01 1.1110E-01
2.0000E-01 1.6670E-01 1.4290E-01 1.2500E-01 1.1110E-01 1.0000E-01
1.6670E-01 1.4290E-01 1.2500E-01 1.1110E-01 1.0000E-01 9.0900E-02
-2.2135E-01 0.0000E+00 4.0841E-01 1.6605E-01
-3.1956E-02 0.0000E+00 3.7927E-01 3.0531E-02
-8.5031E-04 0.0000E+00 6.2793E-01 7.8195E-04
-5.8584E-05 0.0000E+00 8.1156E-01 7.2478E-05
1.3895E-05 0.0000E+00 9.7087E-01 7.2478E-05
2.1324E+00 0.0000E+00 8.4325E-01 1.8048E+00
12
1.2000E+01 1.1000E+01 1.0000E+01 9.0000E+00 8.0000E+00 7.0000E+00
6.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
1.1000E+01 1.1000E+01 1.0000E+01 9.0000E+00 8.0000E+00 7.0000E+00
6.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
0.0000E+00 1.0000E+01 1.0000E+01 9.0000E+00 8.0000E+00 7.0000E+00
6.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
0.0000E+00 0.0000E+00 9.0000E+00 9.0000E+00 8.0000E+00 7.0000E+00
6.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 8.0000E+00 8.0000E+00 7.0000E+00
6.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 7.0000E+00 7.0000E+00
6.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 6.0000E+00
6.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
5.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 4.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 3.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 2.0000E+00 2.0000E+00 1.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
-2.8234E-02 0.0000E+00 2.8690E-06 3.2094E-06
7.2587E-02 9.0746E-02 1.5885E-06 9.9934E-07
7.2587E-02 -9.0746E-02 1.5885E-06 9.9934E-07
1.8533E-01 0.0000E+00 6.5757E-07 7.8673E-07
2.8828E-01 0.0000E+00 1.8324E-06 2.0796E-06
6.4315E-01 0.0000E+00 6.8640E-05 6.1058E-05
1.5539E+00 0.0000E+00 4.6255E-03 6.4028E-03
3.5119E+00 0.0000E+00 1.4447E-01 1.9470E-01
6.9615E+00 0.0000E+00 5.8447E-01 1.2016E+00
1.2311E+01 0.0000E+00 3.1823E-01 1.4273E+00
2.0199E+01 0.0000E+00 2.0079E-01 2.4358E+00
3.2229E+01 0.0000E+00 3.0424E-01 5.6865E+00
6
0.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
5.0000E+00 0.0000E+00 2.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 4.0000E+00 0.0000E+00 3.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 3.0000E+00 0.0000E+00 4.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 2.0000E+00 0.0000E+00 5.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
-5.0000E+00 0.0000E+00 8.2295E-01 1.2318E+00
-3.0000E+00 0.0000E+00 7.2281E-01 7.5970E-01
-1.0000E+00 0.0000E+00 6.2854E-01 6.9666E-01
1.0000E+00 0.0000E+00 6.2854E-01 6.9666E-01
3.0000E+00 0.0000E+00 7.2281E-01 7.5970E-01
5.0000E+00 0.0000E+00 8.2295E-01 1.2318E+00
6
1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
-1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
-1.0000E+00 -1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
-1.0000E+00 -1.0000E+00 -1.0000E+00 1.0000E+00 0.0000E+00 1.0000E+00
-1.0000E+00 -1.0000E+00 -1.0000E+00 -1.0000E+00 1.0000E+00 1.0000E+00
-1.0000E+00 -1.0000E+00 -1.0000E+00 -1.0000E+00 -1.0000E+00 1.0000E+00
8.0298E-02 2.4187E+00 8.9968E-01 1.5236E+00
8.0298E-02 -2.4187E+00 8.9968E-01 1.5236E+00
1.4415E+00 6.2850E-01 9.6734E-01 4.2793E-01
1.4415E+00 -6.2850E-01 9.6734E-01 4.2793E-01
1.4782E+00 1.5638E-01 9.7605E-01 2.2005E-01
1.4782E+00 -1.5638E-01 9.7605E-01 2.2005E-01
6
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
0.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00 1.0000E+00
1.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00
1.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00
0.0000E+00 1.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00
-3.5343E-02 7.4812E-01 3.9345E-01 1.8415E-01
-3.5343E-02 -7.4812E-01 3.9345E-01 1.8415E-01
5.8440E-07 0.0000E+00 2.8868E-01 1.7003E-01
6.4087E-01 7.2822E-01 4.5013E-01 2.9425E-01
6.4087E-01 -7.2822E-01 4.5013E-01 2.9425E-01
3.7889E+00 0.0000E+00 9.6305E-01 2.2469E+00
6
1.0000E+00 4.0112E+00 1.2750E+01 4.0213E+01 1.2656E+02 3.9788E+02
1.0000E+00 3.2616E+00 1.0629E+01 3.3342E+01 1.0479E+02 3.2936E+02
1.0000E+00 3.1500E+00 9.8006E+00 3.0630E+01 9.6164E+01 3.0215E+02
1.0000E+00 3.2755E+00 1.0420E+01 3.2957E+01 1.0374E+02 3.2616E+02
1.0000E+00 2.8214E+00 8.4558E+00 2.6296E+01 8.2443E+01 2.5893E+02
1.0000E+00 2.6406E+00 8.3565E+00 2.6558E+01 8.3558E+01 2.6268E+02
-5.3220E-01 0.0000E+00 5.3287E-01 3.8557E-01
-1.0118E-01 0.0000E+00 7.2342E-01 9.1303E-02
-9.8749E-03 0.0000E+00 7.3708E-01 1.1032E-02
2.9861E-03 0.0000E+00 4.4610E-01 1.2861E-02
1.8075E-01 0.0000E+00 4.2881E-01 1.7378E-01
3.9260E+02 0.0000E+00 4.8057E-01 3.9201E+02
8
0.0000E+00 4.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00
1.0000E+00 0.0000E+00 4.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00
0.0000E+00 1.0000E+00 0.0000E+00 4.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 4.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 4.0000E+00
0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
4.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
0.0000E+00 4.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
1.0000E+00 0.0000E+00
-3.7588E+00 0.0000E+00 1.2253E-01 1.2978E-01
-3.0642E+00 0.0000E+00 4.9811E-02 8.0162E-02
-2.0000E+00 0.0000E+00 3.6914E-02 8.2942E-02
-6.9459E-01 0.0000E+00 3.3328E-02 1.3738E-01
6.9459E-01 0.0000E+00 3.3328E-02 1.1171E-01
2.0000E+00 0.0000E+00 3.6914E-02 7.2156E-02
3.0642E+00 0.0000E+00 4.9811E-02 6.8352E-02
3.7588E+00 0.0000E+00 1.2253E-01 1.1527E-01
6
8.5000E+00 -1.0472E+01 2.8944E+00 -1.5279E+00 1.1056E+00 -5.0000E-01
2.6180E+00 -1.1708E+00 -2.0000E+00 8.9440E-01 -6.1800E-01 2.7640E-01
-7.2360E-01 2.0000E+00 -1.7080E-01 -1.6180E+00 8.9440E-01 -3.8200E-01
3.8200E-01 -8.9440E-01 1.6180E+00 1.7080E-01 -2.0000E+00 7.2360E-01
-2.7640E-01 6.1800E-01 -8.9440E-01 2.0000E+00 1.1708E+00 -2.6180E+00
5.0000E-01 -1.1056E+00 1.5279E+00 -2.8944E+00 1.0472E+01 -8.5000E+00
-5.8930E-01 0.0000E+00 1.7357E-04 2.8157E-04
-2.7627E-01 4.9852E-01 1.7486E-04 1.6704E-04
-2.7627E-01 -4.9852E-01 1.7486E-04 1.6704E-04
2.7509E-01 5.0059E-01 1.7635E-04 1.6828E-04
2.7509E-01 -5.0059E-01 1.7635E-04 1.6828E-04
5.9167E-01 0.0000E+00 1.7623E-04 3.0778E-04
4
4.0000E+00 -5.0000E+00 0.0000E+00 3.0000E+00
0.0000E+00 4.0000E+00 -3.0000E+00 -5.0000E+00
5.0000E+00 -3.0000E+00 4.0000E+00 0.0000E+00
3.0000E+00 0.0000E+00 5.0000E+00 4.0000E+00
1.0000E+00 5.0000E+00 1.0000E+00 4.3333E+00
1.0000E+00 -5.0000E+00 1.0000E+00 4.3333E+00
2.0000E+00 0.0000E+00 1.0000E+00 4.3333E+00
1.2000E+01 0.0000E+00 1.0000E+00 9.1250E+00
5
1.5000E+01 1.1000E+01 6.0000E+00 -9.0000E+00 -1.5000E+01
1.0000E+00 3.0000E+00 9.0000E+00 -3.0000E+00 -8.0000E+00
7.0000E+00 6.0000E+00 6.0000E+00 -3.0000E+00 -1.1000E+01
7.0000E+00 7.0000E+00 5.0000E+00 -3.0000E+00 -1.1000E+01
1.7000E+01 1.2000E+01 5.0000E+00 -1.0000E+01 -1.6000E+01
-9.9999E-01 0.0000E+00 2.1768E-01 5.2263E-01
1.4980E+00 3.5752E+00 3.9966E-04 6.0947E-03
1.4980E+00 -3.5752E+00 3.9966E-04 6.0947E-03
1.5020E+00 3.5662E+00 3.9976E-04 6.0960E-03
1.5020E+00 -3.5662E+00 3.9976E-04 6.0960E-03
6
-9.0000E+00 2.1000E+01 -1.5000E+01 4.0000E+00 2.0000E+00 0.0000E+00
-1.0000E+01 2.1000E+01 -1.4000E+01 4.0000E+00 2.0000E+00 0.0000E+00
-8.0000E+00 1.6000E+01 -1.1000E+01 4.0000E+00 2.0000E+00 0.0000E+00
-6.0000E+00 1.2000E+01 -9.0000E+00 3.0000E+00 3.0000E+00 0.0000E+00
-4.0000E+00 8.0000E+00 -6.0000E+00 0.0000E+00 5.0000E+00 0.0000E+00
-2.0000E+00 4.0000E+00 -3.0000E+00 0.0000E+00 1.0000E+00 3.0000E+00
1.0000E+00 6.2559E-04 6.4875E-05 5.0367E-04
1.0000E+00 -6.2559E-04 6.4875E-05 5.0367E-04
2.0000E+00 1.0001E+00 5.4076E-02 2.3507E-01
2.0000E+00 -1.0001E+00 5.4076E-02 2.3507E-01
3.0000E+00 0.0000E+00 8.6149E-01 5.4838E-07
3.0000E+00 0.0000E+00 1.2425E-01 1.2770E-06
10
1.0000E+00 1.0000E+00 1.0000E+00 -2.0000E+00 1.0000E+00 -1.0000E+00
2.0000E+00 -2.0000E+00 4.0000E+00 -3.0000E+00
-1.0000E+00 2.0000E+00 3.0000E+00 -4.0000E+00 2.0000E+00 -2.0000E+00
4.0000E+00 -4.0000E+00 8.0000E+00 -6.0000E+00
-1.0000E+00 0.0000E+00 5.0000E+00 -5.0000E+00 3.0000E+00 -3.0000E+00
6.0000E+00 -6.0000E+00 1.2000E+01 -9.0000E+00
-1.0000E+00 0.0000E+00 3.0000E+00 -4.0000E+00 4.0000E+00 -4.0000E+00
8.0000E+00 -8.0000E+00 1.6000E+01 -1.2000E+01
-1.0000E+00 0.0000E+00 3.0000E+00 -6.0000E+00 5.0000E+00 -4.0000E+00
1.0000E+01 -1.0000E+01 2.0000E+01 -1.5000E+01
-1.0000E+00 0.0000E+00 3.0000E+00 -6.0000E+00 2.0000E+00 -2.0000E+00
1.2000E+01 -1.2000E+01 2.4000E+01 -1.8000E+01
-1.0000E+00 0.0000E+00 3.0000E+00 -6.0000E+00 2.0000E+00 -5.0000E+00
1.5000E+01 -1.3000E+01 2.8000E+01 -2.1000E+01
-1.0000E+00 0.0000E+00 3.0000E+00 -6.0000E+00 2.0000E+00 -5.0000E+00
1.2000E+01 -1.1000E+01 3.2000E+01 -2.4000E+01
-1.0000E+00 0.0000E+00 3.0000E+00 -6.0000E+00 2.0000E+00 -5.0000E+00
1.2000E+01 -1.4000E+01 3.7000E+01 -2.6000E+01
-1.0000E+00 0.0000E+00 3.0000E+00 -6.0000E+00 2.0000E+00 -5.0000E+00
1.2000E+01 -1.4000E+01 3.6000E+01 -2.5000E+01
1.0000E+00 0.0000E+00 3.6037E-02 7.9613E-02
1.9867E+00 0.0000E+00 7.4283E-05 7.4025E-06
2.0000E+00 2.5052E-03 1.4346E-04 6.7839E-07
2.0000E+00 -2.5052E-03 1.4346E-04 6.7839E-07
2.0067E+00 1.1763E-02 6.7873E-05 5.7496E-06
2.0067E+00 -1.1763E-02 6.7873E-05 5.7496E-06
2.9970E+00 0.0000E+00 9.2779E-05 2.6519E-06
3.0000E+00 8.7028E-04 2.7358E-04 1.9407E-07
3.0000E+00 -8.7028E-04 2.7358E-04 1.9407E-07
3.0030E+00 0.0000E+00 9.2696E-05 2.6477E-06
0
1 1
1
0.00000E+00
1.00000E+00 0.00000E+00
1 1
1
1.00000E+00
1.00000E+00 1.00000E+00
6 3
4 5 6
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
1.00000E+00 4.43734E-31
6 3
4 5 6
1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00
1.00000E+00 1.19209E-07
6 3
4 5 6
1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00
4.01235E-36 3.20988E-36
6 3
4 5 6
1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 1.00000E+00
4.01235E-36 3.20988E-36
6 3
4 5 6
1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 2.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 3.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 4.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 5.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 6.00000E+00
1.00000E+00 1.00000E+00
2 1
1
1.00000E+00 2.00000E+00
0.00000E+00 3.00000E+00
7.07107E-01 2.00000E+00
4 2
1 2
8.52400E-01 5.61100E-01 7.04300E-01 9.54000E-01
2.79800E-01 7.21600E-01 9.61300E-01 3.58200E-01
7.08100E-01 4.09400E-01 2.25000E-01 9.51800E-01
5.54300E-01 5.22000E-01 6.86000E-01 3.07000E-02
7.22196E-01 4.63943E-01
7 6
1 2 3 4 5 6
7.81800E-01 5.65700E-01 7.62100E-01 7.43600E-01 2.55300E-01 4.10000E-01
1.34000E-02
6.45800E-01 2.66600E-01 5.51000E-01 8.31800E-01 9.27100E-01 6.20900E-01
7.83900E-01
1.31600E-01 4.91400E-01 1.77100E-01 1.96400E-01 1.08500E-01 9.27000E-01
2.24700E-01
6.41000E-01 4.68900E-01 9.65900E-01 8.88400E-01 3.76900E-01 9.67300E-01
6.18300E-01
8.38200E-01 8.74300E-01 4.50700E-01 9.44200E-01 7.75500E-01 9.67600E-01
7.83100E-01
3.25900E-01 7.38900E-01 8.30200E-01 4.52100E-01 3.01500E-01 2.13300E-01
8.43400E-01
5.24400E-01 5.01600E-01 7.52900E-01 3.83800E-01 8.47900E-01 9.12800E-01
5.77000E-01
9.43220E-01 3.20530E+00
4 2
2 3
-9.85900E-01 1.47840E+00 -1.33600E-01 -2.95970E+00
-4.33700E-01 -6.54000E-01 -7.15500E-01 1.23760E+00
-7.36300E-01 -1.97680E+00 -1.95100E-01 3.43200E-01
6.41400E-01 -1.40880E+00 6.39400E-01 8.58000E-02
5.22869E-01 5.45530E-01
7 5
1 2 3 4 5
2.72840E+00 2.15200E-01 -1.05200E+00 -2.44600E-01 -6.53000E-02 3.90500E-01
1.40980E+00
9.75300E-01 6.51500E-01 -4.76200E-01 5.42100E-01 6.20900E-01 4.75900E-01
-1.44930E+00
-9.05200E-01 1.79000E-01 -7.08600E-01 4.62100E-01 1.05800E+00 2.24260E+00
1.58260E+00
-7.17900E-01 -2.53400E-01 -4.73900E-01 -1.08100E+00 4.13800E-01 -9.50000E-02
1.45300E-01
-1.37990E+00 -1.06490E+00 1.25580E+00 7.80100E-01 -6.40500E-01 -8.61000E-02
8.30000E-02
2.84900E-01 -1.29900E-01 4.80000E-02 -2.58600E-01 4.18900E-01 1.37680E+00
8.20800E-01
-5.44200E-01 9.74900E-01 9.55800E-01 1.23700E-01 1.09020E+00 -1.40600E-01
1.90960E+00
6.04729E-01 9.00391E-01
6 4
3 4 5 6
0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00
1.00000E-06 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 5.00000E-01
4.89525E-05 4.56492E-05
8 4
1 2 3 4
1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 1.00000E+01 0.00000E+00
1.00000E+01 0.00000E+00
0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 1.00000E+01
1.00000E+01 0.00000E+00
0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 1.00000E+01
1.00000E+01 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 1.00000E+01
0.00000E+00 1.00000E+01
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 5.00000E-01 1.00000E+00
0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 5.00000E-01
1.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
5.00000E-01 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 5.00000E-01
9.56158E-05 4.14317E-05
9 3
1 2 3
1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
7.50000E-01 1.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 7.50000E-01 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 7.50000E-01
1.00000E+00 5.55801E-07
10 4
1 2 3 4
1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
8.75000E-01 1.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 8.75000E-01 1.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 8.75000E-01 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 8.75000E-01
1.00000E+00 1.16972E-10
12 6
1 2 3 4 5 6
1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
1.00000E+01 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 1.00000E+01 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 1.00000E+01 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+01 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+01 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+01
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
9.37500E-01 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 9.37500E-01 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 9.37500E-01 1.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 9.37500E-01 1.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 9.37500E-01 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 9.37500E-01
1.85655E-10 2.20147E-16
12 7
6 7 8 9 10 11 12
1.20000E+01 1.10000E+01 1.00000E+01 9.00000E+00 8.00000E+00 7.00000E+00
6.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
1.10000E+01 1.10000E+01 1.00000E+01 9.00000E+00 8.00000E+00 7.00000E+00
6.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
0.00000E+00 1.00000E+01 1.00000E+01 9.00000E+00 8.00000E+00 7.00000E+00
6.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
0.00000E+00 0.00000E+00 9.00000E+00 9.00000E+00 8.00000E+00 7.00000E+00
6.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 8.00000E+00 8.00000E+00 7.00000E+00
6.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 7.00000E+00 7.00000E+00
6.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 6.00000E+00
6.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
5.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 4.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 3.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 2.00000E+00 2.00000E+00 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 1.00000E+00
6.92558E-05 5.52606E-05
3 1
1
2.00000E-06 1.00000E+00 -2.00000E+00
1.00000E-06 -2.00000E+00 4.00000E+00
0.00000E+00 1.00000E+00 -2.00000E+00
7.30297E-01 4.00000E+00
5 1
3
2.00000E-03 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 1.00000E-03 1.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 -1.00000E-03 1.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 -2.00000E-03 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
3.99999E-12 3.99201E-12
6 4
1 2 3 5
1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
1.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00
1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00
1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00
1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00
2.93294E-01 1.63448E-01
6 2
3 4
0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00
1.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 1.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 1.00000E+00
-1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00
3.97360E-01 3.58295E-01
6 3
3 4 5
1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00
5.00000E-01 3.33300E-01 2.50000E-01 2.00000E-01 1.66700E-01 1.42900E-01
3.33300E-01 2.50000E-01 2.00000E-01 1.66700E-01 1.42900E-01 1.25000E-01
2.50000E-01 2.00000E-01 1.66700E-01 1.42900E-01 1.25000E-01 1.11100E-01
2.00000E-01 1.66700E-01 1.42900E-01 1.25000E-01 1.11100E-01 1.00000E-01
1.66700E-01 1.42900E-01 1.25000E-01 1.11100E-01 1.00000E-01 9.09000E-02
7.28934E-01 1.24624E-02
5 1
1
1.50000E+01 1.10000E+01 6.00000E+00 -9.00000E+00 -1.50000E+01
1.00000E+00 3.00000E+00 9.00000E+00 -3.00000E+00 -8.00000E+00
7.00000E+00 6.00000E+00 6.00000E+00 -3.00000E+00 -1.10000E+01
7.00000E+00 7.00000E+00 5.00000E+00 -3.00000E+00 -1.10000E+01
1.70000E+01 1.20000E+01 5.00000E+00 -1.00000E+01 -1.60000E+01
2.17680E-01 5.22626E-01
6 2
1 2
-9.00000E+00 2.10000E+01 -1.50000E+01 4.00000E+00 2.00000E+00 0.00000E+00
-1.00000E+01 2.10000E+01 -1.40000E+01 4.00000E+00 2.00000E+00 0.00000E+00
-8.00000E+00 1.60000E+01 -1.10000E+01 4.00000E+00 2.00000E+00 0.00000E+00
-6.00000E+00 1.20000E+01 -9.00000E+00 3.00000E+00 3.00000E+00 0.00000E+00
-4.00000E+00 8.00000E+00 -6.00000E+00 0.00000E+00 5.00000E+00 0.00000E+00
-2.00000E+00 4.00000E+00 -3.00000E+00 0.00000E+00 1.00000E+00 3.00000E+00
6.78904E-02 4.22005E-02
10 1
1
1.00000E+00 1.00000E+00 1.00000E+00 -2.00000E+00 1.00000E+00 -1.00000E+00
2.00000E+00 -2.00000E+00 4.00000E+00 -3.00000E+00
-1.00000E+00 2.00000E+00 3.00000E+00 -4.00000E+00 2.00000E+00 -2.00000E+00
4.00000E+00 -4.00000E+00 8.00000E+00 -6.00000E+00
-1.00000E+00 0.00000E+00 5.00000E+00 -5.00000E+00 3.00000E+00 -3.00000E+00
6.00000E+00 -6.00000E+00 1.20000E+01 -9.00000E+00
-1.00000E+00 0.00000E+00 3.00000E+00 -4.00000E+00 4.00000E+00 -4.00000E+00
8.00000E+00 -8.00000E+00 1.60000E+01 -1.20000E+01
-1.00000E+00 0.00000E+00 3.00000E+00 -6.00000E+00 5.00000E+00 -4.00000E+00
1.00000E+01 -1.00000E+01 2.00000E+01 -1.50000E+01
-1.00000E+00 0.00000E+00 3.00000E+00 -6.00000E+00 2.00000E+00 -2.00000E+00
1.20000E+01 -1.20000E+01 2.40000E+01 -1.80000E+01
-1.00000E+00 0.00000E+00 3.00000E+00 -6.00000E+00 2.00000E+00 -5.00000E+00
1.50000E+01 -1.30000E+01 2.80000E+01 -2.10000E+01
-1.00000E+00 0.00000E+00 3.00000E+00 -6.00000E+00 2.00000E+00 -5.00000E+00
1.20000E+01 -1.10000E+01 3.20000E+01 -2.40000E+01
-1.00000E+00 0.00000E+00 3.00000E+00 -6.00000E+00 2.00000E+00 -5.00000E+00
1.20000E+01 -1.40000E+01 3.70000E+01 -2.60000E+01
-1.00000E+00 0.00000E+00 3.00000E+00 -6.00000E+00 2.00000E+00 -5.00000E+00
1.20000E+01 -1.40000E+01 3.60000E+01 -2.50000E+01
3.60372E-02 7.96134E-02
0 0
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/seig/gqr.in 0000644 0001750 0001750 00000000762 10616163240 023270 0 ustar osallou osallou GQR: Data file for testing Generalized QR and RQ routines
3 Number of values of M, P and N
0 3 10 Values of M
0 5 20 Values of P
0 3 30 Values of N
20.0 Threshold value of test ratio
T Put T to test the error exits
1 Code to interpret the seed
GQR 8 List types on next line if 0 < NTYPES < 8
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/seig/sed.in 0000644 0001750 0001750 00000136215 10616163240 023255 0 ustar osallou osallou SEV Data file for the Real Nonsymmetric Eigenvalue Driver
6 Number of matrix dimensions
0 1 2 3 5 10 20 Matrix dimensions
3 3 1 11 4 8 2 0 Parameters NB, NBMIN, NXOVER, INMIN, INWIN, INIBL, ISHFTS, IACC22
20.0 Threshold for test ratios
T
2 Read another line with random number generator seed
2518 3899 995 397 Seed for random number generator
SEV 21 Use all matrix types
SES Data file for the Real Nonsymmetric Schur Form Driver
6 Number of matrix dimensions
0 1 2 3 5 10 20 Matrix dimensions
3 3 1 11 4 8 2 0 Parameters NB, NBMIN, NXOVER, INMIN, INWIN, INIBL, ISHFTS, IACC22
20.0 Threshold for test ratios
T
2 Read another line with random number generator seed
2518 3899 995 397 Seed for random number generator
SES 21 Use all matrix types
SVX Data file for the Real Nonsymmetric Eigenvalue Expert Driver
6 Number of matrix dimensions
0 1 2 3 5 10 20 Matrix dimensions
3 3 1 11 4 8 2 0 Parameters NB, NBMIN, NXOVER, INMIN, INWIN, INIBL, ISHFTS, IACC22
20.0 Threshold for test ratios
T
2 Read another line with random number generator seed
2518 3899 995 397 Seed for random number generator
SVX 21 Use all matrix types
1
0.0000E+00
0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
1
1.0000E+00
1.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
2
0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
2
3.0000E+00 2.0000E+00
2.0000E+00 3.0000E+00
1.0000E+00 0.0000E+00 1.0000E+00 4.0000E+00
5.0000E+00 0.0000E+00 1.0000E+00 4.0000E+00
2
3.0000E+00 -2.0000E+00
2.0000E+00 3.0000E+00
3.0000E+00 2.0000E+00 1.0000E+00 4.0000E+00
3.0000E+00 -2.0000E+00 1.0000E+00 4.0000E+00
6
1.0000E-07 -1.0000E-07 1.0000E+00 1.1000E+00 2.3000E+00 3.7000E+00
3.0000E-07 1.0000E-07 1.0000E+00 1.0000E+00 -1.3000E+00 -7.7000E+00
0.0000E+00 0.0000E+00 3.0000E-07 1.0000E-07 2.2000E+00 3.3000E+00
0.0000E+00 0.0000E+00 -1.0000E-07 3.0000E-07 1.8000E+00 1.6000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 4.0000E-06 5.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 3.0000E+00 4.0000E-06
-3.8730E+00 0.0000E+00 6.9855E-01 2.2823E+00
1.0000E-07 1.7321E-07 9.7611E-08 5.0060E-14
1.0000E-07 -1.7321E-07 9.7611E-08 5.0060E-14
3.0000E-07 1.0000E-07 1.0000E-07 9.4094E-14
3.0000E-07 -1.0000E-07 1.0000E-07 9.4094E-14
3.8730E+00 0.0000E+00 4.0659E-01 1.5283E+00
4
7.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00
-1.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00
-1.0000E+00 1.0000E+00 5.0000E+00 -3.0000E+00
1.0000E+00 -1.0000E+00 3.0000E+00 3.0000E+00
3.9603E+00 4.0425E-02 1.1244E-05 3.1179E-05
3.9603E+00 -4.0425E-02 1.1244E-05 3.1179E-05
4.0397E+00 3.8854E-02 1.0807E-05 2.9981E-05
4.0397E+00 -3.8854E-02 1.0807E-05 2.9981E-05
5
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
0.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
0.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
0.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
0.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
5
1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
1.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
1.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
1.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
1.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
1.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
6
1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
6
1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
6
1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 2.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 3.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 4.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 5.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 6.0000E+00
1.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
2.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
3.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
4.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
5.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
6.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
4
9.4480E-01 6.7670E-01 6.9080E-01 5.9650E-01
5.8760E-01 8.6420E-01 6.7690E-01 7.2600E-02
7.2560E-01 1.9430E-01 9.6870E-01 2.8310E-01
2.8490E-01 5.8000E-02 4.8450E-01 7.3610E-01
2.4326E-01 2.1409E-01 8.7105E-01 3.5073E-01
2.4326E-01 -2.1409E-01 8.7105E-01 3.5073E-01
7.4091E-01 0.0000E+00 9.8194E-01 4.6989E-01
2.2864E+00 0.0000E+00 9.7723E-01 1.5455E+00
6
5.0410E-01 6.6520E-01 7.7190E-01 6.3870E-01 5.9550E-01 6.1310E-01
1.5740E-01 3.7340E-01 5.9840E-01 1.5470E-01 9.4270E-01 6.5900E-02
4.4170E-01 7.2300E-02 1.5440E-01 5.4920E-01 8.7000E-03 3.0040E-01
2.0080E-01 6.0800E-01 3.0340E-01 8.4390E-01 2.3900E-01 5.7680E-01
9.3610E-01 7.4130E-01 1.4440E-01 1.7860E-01 1.4280E-01 7.2630E-01
5.5990E-01 9.3360E-01 7.8000E-02 4.0930E-01 6.7140E-01 5.6170E-01
-5.2278E-01 0.0000E+00 2.7888E-01 1.1793E-01
-3.5380E-01 0.0000E+00 3.5427E-01 6.8911E-02
-8.0876E-03 0.0000E+00 3.4558E-01 1.3489E-01
3.4760E-01 3.0525E-01 5.4661E-01 1.7729E-01
3.4760E-01 -3.0525E-01 5.4661E-01 1.7729E-01
2.7698E+00 0.0000E+00 9.6635E-01 1.8270E+00
5
2.0000E-03 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 1.0000E-03 1.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 -1.0000E-03 1.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 -2.0000E-03 1.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
-2.0000E-03 0.0000E+00 2.4000E-11 2.3952E-11
-1.0000E-03 0.0000E+00 6.0000E-12 5.9940E-12
0.0000E+00 0.0000E+00 4.0000E-12 3.9920E-12
1.0000E-03 0.0000E+00 6.0000E-12 5.9940E-12
2.0000E-03 0.0000E+00 2.4000E-11 2.3952E-11
10
4.8630E-01 9.1260E-01 2.1900E-02 6.0110E-01 1.4050E-01 2.0840E-01
8.2640E-01 8.4410E-01 3.1420E-01 8.6750E-01
7.1500E-01 2.6480E-01 8.8510E-01 2.6150E-01 5.9520E-01 4.7800E-01
7.6730E-01 4.6110E-01 5.7320E-01 7.7000E-03
2.1210E-01 5.5080E-01 5.2350E-01 3.0810E-01 6.6020E-01 2.8900E-01
2.3140E-01 2.2790E-01 9.6600E-02 1.0910E-01
7.1510E-01 8.5790E-01 5.7710E-01 5.1140E-01 1.9010E-01 9.0810E-01
6.0090E-01 7.1980E-01 1.0640E-01 8.6840E-01
5.6800E-01 2.8100E-02 4.0140E-01 6.3150E-01 1.1480E-01 7.5800E-02
9.4230E-01 7.2030E-01 3.6850E-01 1.7430E-01
7.7210E-01 3.0280E-01 5.5640E-01 9.9980E-01 3.6520E-01 5.2580E-01
3.7030E-01 6.7790E-01 9.9350E-01 5.0270E-01
7.3960E-01 4.5600E-02 7.4740E-01 9.2880E-01 2.2000E-03 8.2600E-02
3.6340E-01 4.9120E-01 9.4050E-01 3.8910E-01
5.6370E-01 8.5540E-01 3.2100E-02 2.6380E-01 3.6090E-01 6.4970E-01
8.4690E-01 9.3500E-01 3.7000E-02 2.9170E-01
8.6560E-01 6.3270E-01 3.5620E-01 6.3560E-01 2.7360E-01 6.5120E-01
1.0220E-01 2.8880E-01 5.7620E-01 4.0790E-01
5.3320E-01 4.1210E-01 7.2870E-01 2.3110E-01 6.8300E-01 7.3860E-01
8.1800E-01 9.8150E-01 8.0550E-01 2.5660E-01
-4.6121E-01 7.2657E-01 4.7781E-01 1.5842E-01
-4.6121E-01 -7.2657E-01 4.7781E-01 1.5842E-01
-4.5164E-01 0.0000E+00 4.6034E-01 1.9931E-01
-1.4922E-01 4.8255E-01 4.7500E-01 9.1686E-02
-1.4922E-01 -4.8255E-01 4.7500E-01 9.1686E-02
3.3062E-02 0.0000E+00 2.9729E-01 8.2469E-02
3.0849E-01 1.1953E-01 4.2947E-01 3.9688E-02
3.0849E-01 -1.1953E-01 4.2947E-01 3.9688E-02
5.4509E-01 0.0000E+00 7.0777E-01 1.5033E-01
5.0352E+00 0.0000E+00 9.7257E-01 3.5548E+00
4
-3.8730E-01 3.6560E-01 3.1200E-02 -5.8340E-01
5.5230E-01 -1.1854E+00 9.8330E-01 7.6670E-01
1.6746E+00 -1.9900E-02 -1.8293E+00 5.7180E-01
-5.2500E-01 3.5340E-01 -2.7210E-01 -8.8300E-02
-1.8952E+00 7.5059E-01 8.1913E-01 7.7090E-01
-1.8952E+00 -7.5059E-01 8.1913E-01 7.7090E-01
-9.5162E-02 0.0000E+00 8.0499E-01 4.9037E-01
3.9520E-01 0.0000E+00 9.8222E-01 4.9037E-01
6
-1.0777E+00 1.7027E+00 2.6510E-01 8.5160E-01 1.0121E+00 2.5710E-01
-1.3400E-02 3.9030E-01 -1.2680E+00 2.7530E-01 -3.2350E-01 -1.3844E+00
1.5230E-01 3.0680E-01 8.7330E-01 -3.3410E-01 -4.8310E-01 -1.5416E+00
1.4470E-01 -6.0570E-01 3.1900E-02 -1.0905E+00 -8.3700E-02 6.2410E-01
-7.6510E-01 -1.7889E+00 -1.5069E+00 -6.0210E-01 5.2170E-01 6.4700E-01
8.1940E-01 2.1100E-01 5.4320E-01 7.5610E-01 1.7130E-01 5.5400E-01
-1.7029E+00 0.0000E+00 6.7909E-01 6.7220E-01
-1.0307E+00 0.0000E+00 7.2671E-01 2.0436E-01
2.8487E-01 1.2101E+00 3.9757E-01 4.9797E-01
2.8487E-01 -1.2101E+00 3.9757E-01 4.9797E-01
1.1675E+00 4.6631E-01 4.2334E-01 1.9048E-01
1.1675E+00 -4.6631E-01 4.2334E-01 1.9048E-01
10
-1.0639E+00 1.6120E-01 1.5620E-01 3.4360E-01 -6.7480E-01 1.6598E+00
6.4650E-01 -7.8630E-01 -2.6100E-01 7.0190E-01
-8.4400E-01 -2.2439E+00 1.8800E+00 -1.0005E+00 7.4500E-02 -1.6156E+00
2.8220E-01 8.5600E-01 1.3497E+00 -1.5883E+00
1.5988E+00 1.1758E+00 1.2398E+00 1.1173E+00 2.1500E-01 4.3140E-01
1.8500E-01 7.9470E-01 6.6260E-01 8.6460E-01
-2.2960E-01 1.2442E+00 2.3242E+00 -5.0690E-01 -7.5160E-01 -5.4370E-01
-2.5990E-01 1.2830E+00 -1.1067E+00 -1.1150E-01
-3.6040E-01 4.0420E-01 6.1240E-01 -1.2164E+00 -9.4650E-01 -3.1460E-01
1.8310E-01 7.3710E-01 1.4278E+00 2.9220E-01
4.6150E-01 3.8740E-01 -4.2900E-02 -9.3600E-01 7.1160E-01 -8.2590E-01
-1.7640E+00 -9.4660E-01 1.8202E+00 -2.5480E-01
1.2934E+00 -9.7550E-01 6.7480E-01 -1.0481E+00 -1.8442E+00 -5.4600E-02
7.4050E-01 6.1000E-03 1.2430E+00 -1.8490E-01
-3.4710E-01 -9.5800E-01 1.6530E-01 9.1300E-02 -5.2010E-01 -1.1832E+00
8.5410E-01 -2.3200E-01 -1.6155E+00 5.5180E-01
1.0190E+00 -6.8240E-01 8.0850E-01 2.5950E-01 -3.7580E-01 -1.8825E+00
1.6473E+00 -6.5920E-01 8.0250E-01 -4.9000E-03
1.2670E+00 -4.2400E-02 8.9570E-01 -1.6770E-01 1.4620E-01 9.8800E-01
-2.3170E-01 -1.4483E+00 -5.8200E-02 1.9700E-02
-2.6992E+00 9.0387E-01 6.4005E-01 4.1615E-01
-2.6992E+00 -9.0387E-01 6.4005E-01 4.1615E-01
-2.4366E+00 0.0000E+00 6.9083E-01 2.5476E-01
-1.2882E+00 8.8930E-01 5.3435E-01 6.0878E-01
-1.2882E+00 -8.8930E-01 5.3435E-01 6.0878E-01
9.0275E-01 0.0000E+00 2.9802E-01 4.7530E-01
9.0442E-01 2.5661E+00 7.3193E-01 6.2016E-01
9.0442E-01 -2.5661E+00 7.3193E-01 6.2016E-01
1.6774E+00 0.0000E+00 3.0743E-01 4.1726E-01
3.0060E+00 0.0000E+00 8.5623E-01 4.3175E-01
4
-1.2298E+00 -2.3142E+00 -6.9800E-02 1.0523E+00
2.0390E-01 -1.2298E+00 8.0500E-02 9.7860E-01
0.0000E+00 0.0000E+00 2.5600E-01 -8.9100E-01
0.0000E+00 0.0000E+00 2.7480E-01 2.5600E-01
-1.2298E+00 6.8692E-01 4.7136E-01 7.1772E-01
-1.2298E+00 -6.8692E-01 4.7136E-01 7.1772E-01
2.5600E-01 4.9482E-01 8.0960E-01 5.1408E-01
2.5600E-01 -4.9482E-01 8.0960E-01 5.1408E-01
6
5.9930E-01 1.9372E+00 -1.6160E-01 -1.4602E+00 6.0180E-01 2.7120E+00
-2.2049E+00 5.9930E-01 -1.0679E+00 1.9405E+00 -1.4400E+00 -2.2110E-01
0.0000E+00 0.0000E+00 -2.4567E+00 -6.8650E-01 -1.9101E+00 6.4960E-01
0.0000E+00 0.0000E+00 0.0000E+00 7.3620E-01 3.9700E-01 -1.5190E-01
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 -1.0034E+00 1.1954E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 -1.3400E-01 -1.0034E+00
-2.4567E+00 0.0000E+00 4.7091E-01 8.5788E-01
-1.0034E+00 4.0023E-01 3.6889E-01 1.8909E-01
-1.0034E+00 -4.0023E-01 3.6889E-01 1.8909E-01
5.9930E-01 2.0667E+00 5.8849E-01 1.3299E+00
5.9930E-01 -2.0667E+00 5.8849E-01 1.3299E+00
7.3620E-01 0.0000E+00 6.0845E-01 9.6725E-01
4
1.0000E-04 1.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 -1.0000E-04 1.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 1.0000E-02 1.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 -5.0000E-03
-5.0000E-03 0.0000E+00 3.7485E-07 3.6932E-07
-1.0000E-04 0.0000E+00 9.8979E-09 9.8493E-09
1.0000E-04 0.0000E+00 1.0098E-08 1.0046E-08
1.0000E-02 0.0000E+00 1.4996E-06 1.4773E-06
3
2.0000E-06 1.0000E+00 -2.0000E+00
1.0000E-06 -2.0000E+00 4.0000E+00
0.0000E+00 1.0000E+00 -2.0000E+00
-4.0000E+00 0.0000E+00 7.3030E-01 4.0000E+00
0.0000E+00 0.0000E+00 7.2801E-01 1.3726E-06
2.2096E-06 0.0000E+00 8.2763E-01 2.2096E-06
6
2.4080E-01 6.5530E-01 9.1660E-01 5.0300E-02 2.8490E-01 2.4080E-01
6.9070E-01 9.7000E-01 1.4020E-01 5.7820E-01 6.7670E-01 6.9070E-01
1.0620E-01 3.8000E-02 7.0540E-01 2.4320E-01 8.6420E-01 1.0620E-01
2.6400E-01 9.8800E-02 1.7800E-02 9.4480E-01 1.9430E-01 2.6400E-01
7.0340E-01 2.5600E-01 2.6110E-01 5.8760E-01 5.8000E-02 7.0340E-01
4.0210E-01 5.5980E-01 1.3580E-01 7.2560E-01 6.9080E-01 4.0210E-01
-3.4008E-01 3.2133E-01 5.7839E-01 2.0310E-01
-3.4008E-01 -3.2133E-01 5.7839E-01 2.0310E-01
-1.6998E-07 0.0000E+00 4.9641E-01 2.1574E-01
7.2311E-01 5.9389E-02 7.0039E-01 4.1945E-02
7.2311E-01 -5.9389E-02 7.0039E-01 4.1945E-02
2.5551E+00 0.0000E+00 9.2518E-01 1.7390E+00
6
3.4800E+00 -2.9900E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
-4.9000E-01 2.4800E+00 -1.9900E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 -4.9000E-01 1.4800E+00 -9.9000E-01 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 -9.9000E-01 1.4800E+00 -4.9000E-01 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 -1.9900E+00 2.4800E+00 -4.9000E-01
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 -2.9900E+00 3.4800E+00
1.3034E-02 0.0000E+00 7.5301E-01 6.0533E-01
1.1294E+00 0.0000E+00 6.0479E-01 2.8613E-01
2.0644E+00 0.0000E+00 5.4665E-01 1.7376E-01
2.8388E+00 0.0000E+00 4.2771E-01 3.0915E-01
4.3726E+00 0.0000E+00 6.6370E-01 7.6443E-02
4.4618E+00 0.0000E+00 5.7388E-01 8.9227E-02
6
0.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
1.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 1.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 1.0000E+00
-1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
-1.7321E+00 0.0000E+00 8.6603E-01 7.2597E-01
-1.0000E+00 0.0000E+00 5.0000E-01 2.6417E-01
0.0000E+00 0.0000E+00 2.9582E-31 1.4600E-07
0.0000E+00 0.0000E+00 2.9582E-31 6.2446E-08
1.0000E+00 0.0000E+00 5.0000E-01 2.6417E-01
1.7321E+00 0.0000E+00 8.6603E-01 3.7896E-01
6
3.5345E-01 9.3023E-01 7.4679E-02 -1.0059E-02 4.6698E-02 -4.3480E-02
9.3545E-01 -3.5147E-01 -2.8216E-02 3.8008E-03 -1.7644E-02 1.6428E-02
0.0000E+00 -1.0555E-01 7.5211E-01 -1.0131E-01 4.7030E-01 -4.3789E-01
0.0000E+00 0.0000E+00 6.5419E-01 1.1779E-01 -5.4678E-01 5.0911E-01
0.0000E+00 0.0000E+00 0.0000E+00 -9.8780E-01 -1.1398E-01 1.0612E-01
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 6.8144E-01 7.3187E-01
-9.9980E-01 1.9645E-02 1.0000E+00 3.9290E-02
-9.9980E-01 -1.9645E-02 1.0000E+00 3.9290E-02
7.4539E-01 6.6663E-01 1.0000E+00 5.2120E-01
7.4539E-01 -6.6663E-01 1.0000E+00 5.2120E-01
9.9929E-01 3.7545E-02 1.0000E+00 7.5089E-02
9.9929E-01 -3.7545E-02 1.0000E+00 7.5089E-02
6
1.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00
5.0000E-01 3.3330E-01 2.5000E-01 2.0000E-01 1.6670E-01 1.4290E-01
3.3330E-01 2.5000E-01 2.0000E-01 1.6670E-01 1.4290E-01 1.2500E-01
2.5000E-01 2.0000E-01 1.6670E-01 1.4290E-01 1.2500E-01 1.1110E-01
2.0000E-01 1.6670E-01 1.4290E-01 1.2500E-01 1.1110E-01 1.0000E-01
1.6670E-01 1.4290E-01 1.2500E-01 1.1110E-01 1.0000E-01 9.0900E-02
-2.2135E-01 0.0000E+00 4.0841E-01 1.6605E-01
-3.1956E-02 0.0000E+00 3.7927E-01 3.0531E-02
-8.5031E-04 0.0000E+00 6.2793E-01 7.8195E-04
-5.8584E-05 0.0000E+00 8.1156E-01 7.2478E-05
1.3895E-05 0.0000E+00 9.7087E-01 7.2478E-05
2.1324E+00 0.0000E+00 8.4325E-01 1.8048E+00
12
1.2000E+01 1.1000E+01 1.0000E+01 9.0000E+00 8.0000E+00 7.0000E+00
6.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
1.1000E+01 1.1000E+01 1.0000E+01 9.0000E+00 8.0000E+00 7.0000E+00
6.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
0.0000E+00 1.0000E+01 1.0000E+01 9.0000E+00 8.0000E+00 7.0000E+00
6.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
0.0000E+00 0.0000E+00 9.0000E+00 9.0000E+00 8.0000E+00 7.0000E+00
6.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 8.0000E+00 8.0000E+00 7.0000E+00
6.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 7.0000E+00 7.0000E+00
6.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 6.0000E+00
6.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
5.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 4.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 3.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 2.0000E+00 2.0000E+00 1.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
-2.8234E-02 0.0000E+00 2.8690E-06 3.2094E-06
7.2587E-02 9.0746E-02 1.5885E-06 9.9934E-07
7.2587E-02 -9.0746E-02 1.5885E-06 9.9934E-07
1.8533E-01 0.0000E+00 6.5757E-07 7.8673E-07
2.8828E-01 0.0000E+00 1.8324E-06 2.0796E-06
6.4315E-01 0.0000E+00 6.8640E-05 6.1058E-05
1.5539E+00 0.0000E+00 4.6255E-03 6.4028E-03
3.5119E+00 0.0000E+00 1.4447E-01 1.9470E-01
6.9615E+00 0.0000E+00 5.8447E-01 1.2016E+00
1.2311E+01 0.0000E+00 3.1823E-01 1.4273E+00
2.0199E+01 0.0000E+00 2.0079E-01 2.4358E+00
3.2229E+01 0.0000E+00 3.0424E-01 5.6865E+00
6
0.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
5.0000E+00 0.0000E+00 2.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 4.0000E+00 0.0000E+00 3.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 3.0000E+00 0.0000E+00 4.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 2.0000E+00 0.0000E+00 5.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
-5.0000E+00 0.0000E+00 8.2295E-01 1.2318E+00
-3.0000E+00 0.0000E+00 7.2281E-01 7.5970E-01
-1.0000E+00 0.0000E+00 6.2854E-01 6.9666E-01
1.0000E+00 0.0000E+00 6.2854E-01 6.9666E-01
3.0000E+00 0.0000E+00 7.2281E-01 7.5970E-01
5.0000E+00 0.0000E+00 8.2295E-01 1.2318E+00
6
1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
-1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
-1.0000E+00 -1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
-1.0000E+00 -1.0000E+00 -1.0000E+00 1.0000E+00 0.0000E+00 1.0000E+00
-1.0000E+00 -1.0000E+00 -1.0000E+00 -1.0000E+00 1.0000E+00 1.0000E+00
-1.0000E+00 -1.0000E+00 -1.0000E+00 -1.0000E+00 -1.0000E+00 1.0000E+00
8.0298E-02 2.4187E+00 8.9968E-01 1.5236E+00
8.0298E-02 -2.4187E+00 8.9968E-01 1.5236E+00
1.4415E+00 6.2850E-01 9.6734E-01 4.2793E-01
1.4415E+00 -6.2850E-01 9.6734E-01 4.2793E-01
1.4782E+00 1.5638E-01 9.7605E-01 2.2005E-01
1.4782E+00 -1.5638E-01 9.7605E-01 2.2005E-01
6
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
0.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00 1.0000E+00
1.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00
1.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00
0.0000E+00 1.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00
-3.5343E-02 7.4812E-01 3.9345E-01 1.8415E-01
-3.5343E-02 -7.4812E-01 3.9345E-01 1.8415E-01
5.8440E-07 0.0000E+00 2.8868E-01 1.7003E-01
6.4087E-01 7.2822E-01 4.5013E-01 2.9425E-01
6.4087E-01 -7.2822E-01 4.5013E-01 2.9425E-01
3.7889E+00 0.0000E+00 9.6305E-01 2.2469E+00
6
1.0000E+00 4.0112E+00 1.2750E+01 4.0213E+01 1.2656E+02 3.9788E+02
1.0000E+00 3.2616E+00 1.0629E+01 3.3342E+01 1.0479E+02 3.2936E+02
1.0000E+00 3.1500E+00 9.8006E+00 3.0630E+01 9.6164E+01 3.0215E+02
1.0000E+00 3.2755E+00 1.0420E+01 3.2957E+01 1.0374E+02 3.2616E+02
1.0000E+00 2.8214E+00 8.4558E+00 2.6296E+01 8.2443E+01 2.5893E+02
1.0000E+00 2.6406E+00 8.3565E+00 2.6558E+01 8.3558E+01 2.6268E+02
-5.3220E-01 0.0000E+00 5.3287E-01 3.8557E-01
-1.0118E-01 0.0000E+00 7.2342E-01 9.1303E-02
-9.8749E-03 0.0000E+00 7.3708E-01 1.1032E-02
2.9861E-03 0.0000E+00 4.4610E-01 1.2861E-02
1.8075E-01 0.0000E+00 4.2881E-01 1.7378E-01
3.9260E+02 0.0000E+00 4.8057E-01 3.9201E+02
8
0.0000E+00 4.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00
1.0000E+00 0.0000E+00 4.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00
0.0000E+00 1.0000E+00 0.0000E+00 4.0000E+00 0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 4.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 4.0000E+00
0.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
4.0000E+00 0.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
0.0000E+00 4.0000E+00
0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
1.0000E+00 0.0000E+00
-3.7588E+00 0.0000E+00 1.2253E-01 1.2978E-01
-3.0642E+00 0.0000E+00 4.9811E-02 8.0162E-02
-2.0000E+00 0.0000E+00 3.6914E-02 8.2942E-02
-6.9459E-01 0.0000E+00 3.3328E-02 1.3738E-01
6.9459E-01 0.0000E+00 3.3328E-02 1.1171E-01
2.0000E+00 0.0000E+00 3.6914E-02 7.2156E-02
3.0642E+00 0.0000E+00 4.9811E-02 6.8352E-02
3.7588E+00 0.0000E+00 1.2253E-01 1.1527E-01
6
8.5000E+00 -1.0472E+01 2.8944E+00 -1.5279E+00 1.1056E+00 -5.0000E-01
2.6180E+00 -1.1708E+00 -2.0000E+00 8.9440E-01 -6.1800E-01 2.7640E-01
-7.2360E-01 2.0000E+00 -1.7080E-01 -1.6180E+00 8.9440E-01 -3.8200E-01
3.8200E-01 -8.9440E-01 1.6180E+00 1.7080E-01 -2.0000E+00 7.2360E-01
-2.7640E-01 6.1800E-01 -8.9440E-01 2.0000E+00 1.1708E+00 -2.6180E+00
5.0000E-01 -1.1056E+00 1.5279E+00 -2.8944E+00 1.0472E+01 -8.5000E+00
-5.8930E-01 0.0000E+00 1.7357E-04 2.8157E-04
-2.7627E-01 4.9852E-01 1.7486E-04 1.6704E-04
-2.7627E-01 -4.9852E-01 1.7486E-04 1.6704E-04
2.7509E-01 5.0059E-01 1.7635E-04 1.6828E-04
2.7509E-01 -5.0059E-01 1.7635E-04 1.6828E-04
5.9167E-01 0.0000E+00 1.7623E-04 3.0778E-04
4
4.0000E+00 -5.0000E+00 0.0000E+00 3.0000E+00
0.0000E+00 4.0000E+00 -3.0000E+00 -5.0000E+00
5.0000E+00 -3.0000E+00 4.0000E+00 0.0000E+00
3.0000E+00 0.0000E+00 5.0000E+00 4.0000E+00
1.0000E+00 5.0000E+00 1.0000E+00 4.3333E+00
1.0000E+00 -5.0000E+00 1.0000E+00 4.3333E+00
2.0000E+00 0.0000E+00 1.0000E+00 4.3333E+00
1.2000E+01 0.0000E+00 1.0000E+00 9.1250E+00
5
1.5000E+01 1.1000E+01 6.0000E+00 -9.0000E+00 -1.5000E+01
1.0000E+00 3.0000E+00 9.0000E+00 -3.0000E+00 -8.0000E+00
7.0000E+00 6.0000E+00 6.0000E+00 -3.0000E+00 -1.1000E+01
7.0000E+00 7.0000E+00 5.0000E+00 -3.0000E+00 -1.1000E+01
1.7000E+01 1.2000E+01 5.0000E+00 -1.0000E+01 -1.6000E+01
-9.9999E-01 0.0000E+00 2.1768E-01 5.2263E-01
1.4980E+00 3.5752E+00 3.9966E-04 6.0947E-03
1.4980E+00 -3.5752E+00 3.9966E-04 6.0947E-03
1.5020E+00 3.5662E+00 3.9976E-04 6.0960E-03
1.5020E+00 -3.5662E+00 3.9976E-04 6.0960E-03
6
-9.0000E+00 2.1000E+01 -1.5000E+01 4.0000E+00 2.0000E+00 0.0000E+00
-1.0000E+01 2.1000E+01 -1.4000E+01 4.0000E+00 2.0000E+00 0.0000E+00
-8.0000E+00 1.6000E+01 -1.1000E+01 4.0000E+00 2.0000E+00 0.0000E+00
-6.0000E+00 1.2000E+01 -9.0000E+00 3.0000E+00 3.0000E+00 0.0000E+00
-4.0000E+00 8.0000E+00 -6.0000E+00 0.0000E+00 5.0000E+00 0.0000E+00
-2.0000E+00 4.0000E+00 -3.0000E+00 0.0000E+00 1.0000E+00 3.0000E+00
1.0000E+00 6.2559E-04 6.4875E-05 5.0367E-04
1.0000E+00 -6.2559E-04 6.4875E-05 5.0367E-04
2.0000E+00 1.0001E+00 5.4076E-02 2.3507E-01
2.0000E+00 -1.0001E+00 5.4076E-02 2.3507E-01
3.0000E+00 0.0000E+00 8.6149E-01 5.4838E-07
3.0000E+00 0.0000E+00 1.2425E-01 1.2770E-06
10
1.0000E+00 1.0000E+00 1.0000E+00 -2.0000E+00 1.0000E+00 -1.0000E+00
2.0000E+00 -2.0000E+00 4.0000E+00 -3.0000E+00
-1.0000E+00 2.0000E+00 3.0000E+00 -4.0000E+00 2.0000E+00 -2.0000E+00
4.0000E+00 -4.0000E+00 8.0000E+00 -6.0000E+00
-1.0000E+00 0.0000E+00 5.0000E+00 -5.0000E+00 3.0000E+00 -3.0000E+00
6.0000E+00 -6.0000E+00 1.2000E+01 -9.0000E+00
-1.0000E+00 0.0000E+00 3.0000E+00 -4.0000E+00 4.0000E+00 -4.0000E+00
8.0000E+00 -8.0000E+00 1.6000E+01 -1.2000E+01
-1.0000E+00 0.0000E+00 3.0000E+00 -6.0000E+00 5.0000E+00 -4.0000E+00
1.0000E+01 -1.0000E+01 2.0000E+01 -1.5000E+01
-1.0000E+00 0.0000E+00 3.0000E+00 -6.0000E+00 2.0000E+00 -2.0000E+00
1.2000E+01 -1.2000E+01 2.4000E+01 -1.8000E+01
-1.0000E+00 0.0000E+00 3.0000E+00 -6.0000E+00 2.0000E+00 -5.0000E+00
1.5000E+01 -1.3000E+01 2.8000E+01 -2.1000E+01
-1.0000E+00 0.0000E+00 3.0000E+00 -6.0000E+00 2.0000E+00 -5.0000E+00
1.2000E+01 -1.1000E+01 3.2000E+01 -2.4000E+01
-1.0000E+00 0.0000E+00 3.0000E+00 -6.0000E+00 2.0000E+00 -5.0000E+00
1.2000E+01 -1.4000E+01 3.7000E+01 -2.6000E+01
-1.0000E+00 0.0000E+00 3.0000E+00 -6.0000E+00 2.0000E+00 -5.0000E+00
1.2000E+01 -1.4000E+01 3.6000E+01 -2.5000E+01
1.0000E+00 0.0000E+00 3.6037E-02 7.9613E-02
1.9867E+00 0.0000E+00 7.4283E-05 7.4025E-06
2.0000E+00 2.5052E-03 1.4346E-04 6.7839E-07
2.0000E+00 -2.5052E-03 1.4346E-04 6.7839E-07
2.0067E+00 1.1763E-02 6.7873E-05 5.7496E-06
2.0067E+00 -1.1763E-02 6.7873E-05 5.7496E-06
2.9970E+00 0.0000E+00 9.2779E-05 2.6519E-06
3.0000E+00 8.7028E-04 2.7358E-04 1.9407E-07
3.0000E+00 -8.7028E-04 2.7358E-04 1.9407E-07
3.0030E+00 0.0000E+00 9.2696E-05 2.6477E-06
0
SSX Data file for the Real Nonsymmetric Schur Form Expert Driver
6 Number of matrix dimensions
0 1 2 3 5 10 20 Matrix dimensions
3 3 1 11 4 8 2 0 Parameters NB, NBMIN, NXOVER, INMIN, INWIN, INIBL, ISHFTS, IACC22
20.0 Threshold for test ratios
T
2 Read another line with random number generator seed
2518 3899 995 397 Seed for random number generator
SSX 21 Use all matrix types
1 1
1
0.00000E+00
1.00000E+00 0.00000E+00
1 1
1
1.00000E+00
1.00000E+00 1.00000E+00
6 6
1 2 3 4 5 6
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
1.00000E+00 4.43734E-31
6 0
1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00
1.00000E+00 1.00000E+00
6 6
1 2 3 4 5 6
1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00
1.00000E+00 2.00000E+00
6 1
1
1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 1.00000E+00
1.00000E+00 2.00000E+00
6 3
4 5 6
1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 2.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 3.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 4.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 5.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 6.00000E+00
1.00000E+00 1.00000E+00
2 1
1
1.00000E+00 2.00000E+00
0.00000E+00 3.00000E+00
7.07107E-01 2.00000E+00
4 2
1 2
8.52400E-01 5.61100E-01 7.04300E-01 9.54000E-01
2.79800E-01 7.21600E-01 9.61300E-01 3.58200E-01
7.08100E-01 4.09400E-01 2.25000E-01 9.51800E-01
5.54300E-01 5.22000E-01 6.86000E-01 3.07000E-02
7.22196E-01 4.63943E-01
7 6
1 2 3 4 5 6
7.81800E-01 5.65700E-01 7.62100E-01 7.43600E-01 2.55300E-01 4.10000E-01
1.34000E-02
6.45800E-01 2.66600E-01 5.51000E-01 8.31800E-01 9.27100E-01 6.20900E-01
7.83900E-01
1.31600E-01 4.91400E-01 1.77100E-01 1.96400E-01 1.08500E-01 9.27000E-01
2.24700E-01
6.41000E-01 4.68900E-01 9.65900E-01 8.88400E-01 3.76900E-01 9.67300E-01
6.18300E-01
8.38200E-01 8.74300E-01 4.50700E-01 9.44200E-01 7.75500E-01 9.67600E-01
7.83100E-01
3.25900E-01 7.38900E-01 8.30200E-01 4.52100E-01 3.01500E-01 2.13300E-01
8.43400E-01
5.24400E-01 5.01600E-01 7.52900E-01 3.83800E-01 8.47900E-01 9.12800E-01
5.77000E-01
9.43220E-01 3.20530E+00
4 2
2 3
-9.85900E-01 1.47840E+00 -1.33600E-01 -2.95970E+00
-4.33700E-01 -6.54000E-01 -7.15500E-01 1.23760E+00
-7.36300E-01 -1.97680E+00 -1.95100E-01 3.43200E-01
6.41400E-01 -1.40880E+00 6.39400E-01 8.58000E-02
5.22869E-01 5.45530E-01
7 5
1 2 3 4 5
2.72840E+00 2.15200E-01 -1.05200E+00 -2.44600E-01 -6.53000E-02 3.90500E-01
1.40980E+00
9.75300E-01 6.51500E-01 -4.76200E-01 5.42100E-01 6.20900E-01 4.75900E-01
-1.44930E+00
-9.05200E-01 1.79000E-01 -7.08600E-01 4.62100E-01 1.05800E+00 2.24260E+00
1.58260E+00
-7.17900E-01 -2.53400E-01 -4.73900E-01 -1.08100E+00 4.13800E-01 -9.50000E-02
1.45300E-01
-1.37990E+00 -1.06490E+00 1.25580E+00 7.80100E-01 -6.40500E-01 -8.61000E-02
8.30000E-02
2.84900E-01 -1.29900E-01 4.80000E-02 -2.58600E-01 4.18900E-01 1.37680E+00
8.20800E-01
-5.44200E-01 9.74900E-01 9.55800E-01 1.23700E-01 1.09020E+00 -1.40600E-01
1.90960E+00
6.04729E-01 9.00391E-01
6 4
3 4 5 6
0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00
1.00000E-06 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 5.00000E-01
4.89525E-05 4.56492E-05
8 4
1 2 3 4
1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 1.00000E+01 0.00000E+00
1.00000E+01 0.00000E+00
0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 1.00000E+01
1.00000E+01 0.00000E+00
0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 1.00000E+01
1.00000E+01 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 1.00000E+01
0.00000E+00 1.00000E+01
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 5.00000E-01 1.00000E+00
0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 5.00000E-01
1.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
5.00000E-01 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 5.00000E-01
9.56158E-05 4.14317E-05
9 3
1 2 3
1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
7.50000E-01 1.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 7.50000E-01 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 7.50000E-01
1.00000E+00 5.55801E-07
10 4
1 2 3 4
1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
8.75000E-01 1.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 8.75000E-01 1.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 8.75000E-01 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 8.75000E-01
1.00000E+00 1.16972E-10
12 6
1 2 3 4 5 6
1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
1.00000E+01 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 1.00000E+01 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 1.00000E+01 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+01 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+01 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+01
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
9.37500E-01 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 9.37500E-01 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 9.37500E-01 1.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 9.37500E-01 1.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 9.37500E-01 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 9.37500E-01
1.85655E-10 2.20147E-16
12 7
6 7 8 9 10 11 12
1.20000E+01 1.10000E+01 1.00000E+01 9.00000E+00 8.00000E+00 7.00000E+00
6.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
1.10000E+01 1.10000E+01 1.00000E+01 9.00000E+00 8.00000E+00 7.00000E+00
6.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
0.00000E+00 1.00000E+01 1.00000E+01 9.00000E+00 8.00000E+00 7.00000E+00
6.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
0.00000E+00 0.00000E+00 9.00000E+00 9.00000E+00 8.00000E+00 7.00000E+00
6.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 8.00000E+00 8.00000E+00 7.00000E+00
6.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 7.00000E+00 7.00000E+00
6.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 6.00000E+00
6.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
5.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 4.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 3.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 2.00000E+00 2.00000E+00 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 1.00000E+00
6.92558E-05 5.52606E-05
3 1
1
2.00000E-06 1.00000E+00 -2.00000E+00
1.00000E-06 -2.00000E+00 4.00000E+00
0.00000E+00 1.00000E+00 -2.00000E+00
7.30297E-01 4.00000E+00
5 1
3
2.00000E-03 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 1.00000E-03 1.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 -1.00000E-03 1.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 -2.00000E-03 1.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
3.99999E-12 3.99201E-12
6 4
1 2 3 5
1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
1.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00
1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00
1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00
1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00
2.93294E-01 1.63448E-01
6 2
3 4
0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00
1.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 1.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00
0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 1.00000E+00
-1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00
3.97360E-01 3.58295E-01
6 3
3 4 5
1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00
5.00000E-01 3.33300E-01 2.50000E-01 2.00000E-01 1.66700E-01 1.42900E-01
3.33300E-01 2.50000E-01 2.00000E-01 1.66700E-01 1.42900E-01 1.25000E-01
2.50000E-01 2.00000E-01 1.66700E-01 1.42900E-01 1.25000E-01 1.11100E-01
2.00000E-01 1.66700E-01 1.42900E-01 1.25000E-01 1.11100E-01 1.00000E-01
1.66700E-01 1.42900E-01 1.25000E-01 1.11100E-01 1.00000E-01 9.09000E-02
7.28934E-01 1.24624E-02
5 1
1
1.50000E+01 1.10000E+01 6.00000E+00 -9.00000E+00 -1.50000E+01
1.00000E+00 3.00000E+00 9.00000E+00 -3.00000E+00 -8.00000E+00
7.00000E+00 6.00000E+00 6.00000E+00 -3.00000E+00 -1.10000E+01
7.00000E+00 7.00000E+00 5.00000E+00 -3.00000E+00 -1.10000E+01
1.70000E+01 1.20000E+01 5.00000E+00 -1.00000E+01 -1.60000E+01
2.17680E-01 5.22626E-01
6 2
1 2
-9.00000E+00 2.10000E+01 -1.50000E+01 4.00000E+00 2.00000E+00 0.00000E+00
-1.00000E+01 2.10000E+01 -1.40000E+01 4.00000E+00 2.00000E+00 0.00000E+00
-8.00000E+00 1.60000E+01 -1.10000E+01 4.00000E+00 2.00000E+00 0.00000E+00
-6.00000E+00 1.20000E+01 -9.00000E+00 3.00000E+00 3.00000E+00 0.00000E+00
-4.00000E+00 8.00000E+00 -6.00000E+00 0.00000E+00 5.00000E+00 0.00000E+00
-2.00000E+00 4.00000E+00 -3.00000E+00 0.00000E+00 1.00000E+00 3.00000E+00
6.78904E-02 4.22005E-02
10 1
1
1.00000E+00 1.00000E+00 1.00000E+00 -2.00000E+00 1.00000E+00 -1.00000E+00
2.00000E+00 -2.00000E+00 4.00000E+00 -3.00000E+00
-1.00000E+00 2.00000E+00 3.00000E+00 -4.00000E+00 2.00000E+00 -2.00000E+00
4.00000E+00 -4.00000E+00 8.00000E+00 -6.00000E+00
-1.00000E+00 0.00000E+00 5.00000E+00 -5.00000E+00 3.00000E+00 -3.00000E+00
6.00000E+00 -6.00000E+00 1.20000E+01 -9.00000E+00
-1.00000E+00 0.00000E+00 3.00000E+00 -4.00000E+00 4.00000E+00 -4.00000E+00
8.00000E+00 -8.00000E+00 1.60000E+01 -1.20000E+01
-1.00000E+00 0.00000E+00 3.00000E+00 -6.00000E+00 5.00000E+00 -4.00000E+00
1.00000E+01 -1.00000E+01 2.00000E+01 -1.50000E+01
-1.00000E+00 0.00000E+00 3.00000E+00 -6.00000E+00 2.00000E+00 -2.00000E+00
1.20000E+01 -1.20000E+01 2.40000E+01 -1.80000E+01
-1.00000E+00 0.00000E+00 3.00000E+00 -6.00000E+00 2.00000E+00 -5.00000E+00
1.50000E+01 -1.30000E+01 2.80000E+01 -2.10000E+01
-1.00000E+00 0.00000E+00 3.00000E+00 -6.00000E+00 2.00000E+00 -5.00000E+00
1.20000E+01 -1.10000E+01 3.20000E+01 -2.40000E+01
-1.00000E+00 0.00000E+00 3.00000E+00 -6.00000E+00 2.00000E+00 -5.00000E+00
1.20000E+01 -1.40000E+01 3.70000E+01 -2.60000E+01
-1.00000E+00 0.00000E+00 3.00000E+00 -6.00000E+00 2.00000E+00 -5.00000E+00
1.20000E+01 -1.40000E+01 3.60000E+01 -2.50000E+01
3.60372E-02 7.96134E-02
0 0
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/seig/lse.in 0000644 0001750 0001750 00000001001 10616163240 023245 0 ustar osallou osallou LSE: Data file for testing Constrained Linear Least Squares routines
6 Number of values of M, P, and N
6 0 5 8 10 30 Values of M
0 5 5 5 8 20 Values of P
5 5 6 8 12 40 Values of N, note P<= N <= P+M
20.0 Threshold value of test ratio
T Put T to test the error exits
1 Code to interpret the seed
LSE 8 List types on next line if 0 < NTYPES < 8
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/seig/sgg.in 0000644 0001750 0001750 00000001563 10616163241 023260 0 ustar osallou osallou SGG: Data file for testing Nonsymmetric Eigenvalue Problem routines
7 Number of values of N
0 1 2 3 5 10 16 Values of N (dimension)
4 Number of parameter values
1 1 2 2 Values of NB (blocksize)
40 40 2 2 Values of NBMIN (minimum blocksize)
2 4 2 4 Values of NSHIFT (no. of shifts)
40 40 2 2 Values of MAXB (multishift crossover pt)
40 40 2 2 Values of NBCOL (minimum col. dimension)
20.0 Threshold value
T Put T to test the LAPACK routines
T Put T to test the driver routines
T Put T to test the error exits
1 Code to interpret the seed
SGG 26
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/seig/seigtest.f 0000644 0001750 0001750 00005177670 10616163240 024167 0 ustar osallou osallou SUBROUTINE ALAHDG( IOUNIT, PATH )
*
* -- LAPACK test routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER IOUNIT
* ..
*
* Purpose
* =======
*
* ALAHDG prints header information for the different test paths.
*
* Arguments
* =========
*
* IOUNIT (input) INTEGER
* The unit number to which the header information should be
* printed.
*
* PATH (input) CHARACTER*3
* The name of the path for which the header information is to
* be printed. Current paths are
* GQR: GQR (general matrices)
* GRQ: GRQ (general matrices)
* LSE: LSE Problem
* GLM: GLM Problem
* GSV: Generalized Singular Value Decomposition
*
* =====================================================================
*
* .. Local Scalars ..
CHARACTER*3 C2
INTEGER ITYPE
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. Executable Statements ..
*
IF( IOUNIT.LE.0 )
$ RETURN
C2 = PATH( 1: 3 )
*
* First line describing matrices in this path
*
IF( LSAMEN( 3, C2, 'GQR' ) ) THEN
ITYPE = 1
WRITE( IOUNIT, FMT = 9991 )PATH
ELSE IF( LSAMEN( 3, C2, 'GRQ' ) ) THEN
ITYPE = 2
WRITE( IOUNIT, FMT = 9992 )PATH
ELSE IF( LSAMEN( 3, C2, 'LSE' ) ) THEN
ITYPE = 3
WRITE( IOUNIT, FMT = 9993 )PATH
ELSE IF( LSAMEN( 3, C2, 'GLM' ) ) THEN
ITYPE = 4
WRITE( IOUNIT, FMT = 9994 )PATH
ELSE IF( LSAMEN( 3, C2, 'GSV' ) ) THEN
ITYPE = 5
WRITE( IOUNIT, FMT = 9995 )PATH
END IF
*
* Matrix types
*
WRITE( IOUNIT, FMT = 9999 )'Matrix types: '
*
IF( ITYPE.EQ.1 )THEN
WRITE( IOUNIT, FMT = 9950 )1
WRITE( IOUNIT, FMT = 9952 )2
WRITE( IOUNIT, FMT = 9954 )3
WRITE( IOUNIT, FMT = 9955 )4
WRITE( IOUNIT, FMT = 9956 )5
WRITE( IOUNIT, FMT = 9957 )6
WRITE( IOUNIT, FMT = 9961 )7
WRITE( IOUNIT, FMT = 9962 )8
ELSE IF( ITYPE.EQ.2 )THEN
WRITE( IOUNIT, FMT = 9951 )1
WRITE( IOUNIT, FMT = 9953 )2
WRITE( IOUNIT, FMT = 9954 )3
WRITE( IOUNIT, FMT = 9955 )4
WRITE( IOUNIT, FMT = 9956 )5
WRITE( IOUNIT, FMT = 9957 )6
WRITE( IOUNIT, FMT = 9961 )7
WRITE( IOUNIT, FMT = 9962 )8
ELSE IF( ITYPE.EQ.3 )THEN
WRITE( IOUNIT, FMT = 9950 )1
WRITE( IOUNIT, FMT = 9952 )2
WRITE( IOUNIT, FMT = 9954 )3
WRITE( IOUNIT, FMT = 9955 )4
WRITE( IOUNIT, FMT = 9955 )5
WRITE( IOUNIT, FMT = 9955 )6
WRITE( IOUNIT, FMT = 9955 )7
WRITE( IOUNIT, FMT = 9955 )8
ELSE IF( ITYPE.EQ.4 )THEN
WRITE( IOUNIT, FMT = 9951 )1
WRITE( IOUNIT, FMT = 9953 )2
WRITE( IOUNIT, FMT = 9954 )3
WRITE( IOUNIT, FMT = 9955 )4
WRITE( IOUNIT, FMT = 9955 )5
WRITE( IOUNIT, FMT = 9955 )6
WRITE( IOUNIT, FMT = 9955 )7
WRITE( IOUNIT, FMT = 9955 )8
ELSE IF( ITYPE.EQ.5 )THEN
WRITE( IOUNIT, FMT = 9950 )1
WRITE( IOUNIT, FMT = 9952 )2
WRITE( IOUNIT, FMT = 9954 )3
WRITE( IOUNIT, FMT = 9955 )4
WRITE( IOUNIT, FMT = 9956 )5
WRITE( IOUNIT, FMT = 9957 )6
WRITE( IOUNIT, FMT = 9959 )7
WRITE( IOUNIT, FMT = 9960 )8
END IF
*
* Tests performed
*
WRITE( IOUNIT, FMT = 9999 )'Test ratios: '
*
IF( ITYPE.EQ.1 ) THEN
*
* GQR decomposition of rectangular matrices
*
WRITE( IOUNIT, FMT = 9930 )1
WRITE( IOUNIT, FMT = 9931 )2
WRITE( IOUNIT, FMT = 9932 )3
WRITE( IOUNIT, FMT = 9933 )4
ELSE IF( ITYPE.EQ.2 ) THEN
*
* GRQ decomposition of rectangular matrices
*
WRITE( IOUNIT, FMT = 9934 )1
WRITE( IOUNIT, FMT = 9935 )2
WRITE( IOUNIT, FMT = 9932 )3
WRITE( IOUNIT, FMT = 9933 )4
ELSE IF( ITYPE.EQ.3 ) THEN
*
* LSE Problem
*
WRITE( IOUNIT, FMT = 9937 )1
WRITE( IOUNIT, FMT = 9938 )2
ELSE IF( ITYPE.EQ.4 ) THEN
*
* GLM Problem
*
WRITE( IOUNIT, FMT = 9939 )1
ELSE IF( ITYPE.EQ.5 ) THEN
*
* GSVD
*
WRITE( IOUNIT, FMT = 9940 )1
WRITE( IOUNIT, FMT = 9941 )2
WRITE( IOUNIT, FMT = 9942 )3
WRITE( IOUNIT, FMT = 9943 )4
WRITE( IOUNIT, FMT = 9944 )5
END IF
*
9999 FORMAT( 1X, A )
9991 FORMAT( / 1X, A3, ': GQR factorization of general matrices' )
9992 FORMAT( / 1X, A3, ': GRQ factorization of general matrices' )
9993 FORMAT( / 1X, A3, ': LSE Problem' )
9994 FORMAT( / 1X, A3, ': GLM Problem' )
9995 FORMAT( / 1X, A3, ': Generalized Singular Value Decomposition' )
*
9950 FORMAT( 3X, I2, ': A-diagonal matrix B-upper triangular' )
9951 FORMAT( 3X, I2, ': A-diagonal matrix B-lower triangular' )
9952 FORMAT( 3X, I2, ': A-upper triangular B-upper triangular' )
9953 FORMAT( 3X, I2, ': A-lower triangular B-diagonal triangular' )
9954 FORMAT( 3X, I2, ': A-lower triangular B-upper triangular' )
*
9955 FORMAT( 3X, I2, ': Random matrices cond(A)=100, cond(B)=10,' )
*
9956 FORMAT( 3X, I2, ': Random matrices cond(A)= sqrt( 0.1/EPS ) ',
$ 'cond(B)= sqrt( 0.1/EPS )' )
9957 FORMAT( 3X, I2, ': Random matrices cond(A)= 0.1/EPS ',
$ 'cond(B)= 0.1/EPS' )
9959 FORMAT( 3X, I2, ': Random matrices cond(A)= sqrt( 0.1/EPS ) ',
$ 'cond(B)= 0.1/EPS ' )
9960 FORMAT( 3X, I2, ': Random matrices cond(A)= 0.1/EPS ',
$ 'cond(B)= sqrt( 0.1/EPS )' )
*
9961 FORMAT( 3X, I2, ': Matrix scaled near underflow limit' )
9962 FORMAT( 3X, I2, ': Matrix scaled near overflow limit' )
*
*
* GQR test ratio
*
9930 FORMAT( 3X, I2, ': norm( R - Q'' * A ) / ( min( N, M )*norm( A )',
$ '* EPS )' )
9931 FORMAT( 3X, I2, ': norm( T * Z - Q'' * B ) / ( min(P,N)*norm(B)',
$ '* EPS )' )
9932 FORMAT( 3X, I2, ': norm( I - Q''*Q ) / ( N * EPS )' )
9933 FORMAT( 3X, I2, ': norm( I - Z''*Z ) / ( P * EPS )' )
*
* GRQ test ratio
*
9934 FORMAT( 3X, I2, ': norm( R - A * Q'' ) / ( min( N,M )*norm(A) * ',
$ 'EPS )' )
9935 FORMAT( 3X, I2, ': norm( T * Q - Z'' * B ) / ( min( P,N ) * nor',
$ 'm(B)*EPS )' )
*
* LSE test ratio
*
9937 FORMAT( 3X, I2, ': norm( A*x - c ) / ( norm(A)*norm(x) * EPS )' )
9938 FORMAT( 3X, I2, ': norm( B*x - d ) / ( norm(B)*norm(x) * EPS )' )
*
* GLM test ratio
*
9939 FORMAT( 3X, I2, ': norm( d - A*x - B*y ) / ( (norm(A)+norm(B) )*',
$ '(norm(x)+norm(y))*EPS )' )
*
* GSVD test ratio
*
9940 FORMAT( 3X, I2, ': norm( U'' * A * Q - D1 * R ) / ( min( M, N )*',
$ 'norm( A ) * EPS )' )
9941 FORMAT( 3X, I2, ': norm( V'' * B * Q - D2 * R ) / ( min( P, N )*',
$ 'norm( B ) * EPS )' )
9942 FORMAT( 3X, I2, ': norm( I - U''*U ) / ( M * EPS )' )
9943 FORMAT( 3X, I2, ': norm( I - V''*V ) / ( P * EPS )' )
9944 FORMAT( 3X, I2, ': norm( I - Q''*Q ) / ( N * EPS )' )
RETURN
*
* End of ALAHDG
*
END
SUBROUTINE ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NIN, NMATS, NOUT, NTYPES
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
* ..
*
* Purpose
* =======
*
* ALAREQ handles input for the LAPACK test program. It is called
* to evaluate the input line which requested NMATS matrix types for
* PATH. The flow of control is as follows:
*
* If NMATS = NTYPES then
* DOTYPE(1:NTYPES) = .TRUE.
* else
* Read the next input line for NMATS matrix types
* Set DOTYPE(I) = .TRUE. for each valid type I
* endif
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* An LAPACK path name for testing.
*
* NMATS (input) INTEGER
* The number of matrix types to be used in testing this path.
*
* DOTYPE (output) LOGICAL array, dimension (NTYPES)
* The vector of flags indicating if each type will be tested.
*
* NTYPES (input) INTEGER
* The maximum number of matrix types for this path.
*
* NIN (input) INTEGER
* The unit number for input. NIN >= 1.
*
* NOUT (input) INTEGER
* The unit number for output. NOUT >= 1.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL FIRSTT
CHARACTER C1
CHARACTER*10 INTSTR
CHARACTER*80 LINE
INTEGER I, I1, IC, J, K, LENP, NT
* ..
* .. Local Arrays ..
INTEGER NREQ( 100 )
* ..
* .. Intrinsic Functions ..
INTRINSIC LEN
* ..
* .. Data statements ..
DATA INTSTR / '0123456789' /
* ..
* .. Executable Statements ..
*
IF( NMATS.GE.NTYPES ) THEN
*
* Test everything if NMATS >= NTYPES.
*
DO 10 I = 1, NTYPES
DOTYPE( I ) = .TRUE.
10 CONTINUE
ELSE
DO 20 I = 1, NTYPES
DOTYPE( I ) = .FALSE.
20 CONTINUE
FIRSTT = .TRUE.
*
* Read a line of matrix types if 0 < NMATS < NTYPES.
*
IF( NMATS.GT.0 ) THEN
READ( NIN, FMT = '(A80)', END = 90 )LINE
LENP = LEN( LINE )
I = 0
DO 60 J = 1, NMATS
NREQ( J ) = 0
I1 = 0
30 CONTINUE
I = I + 1
IF( I.GT.LENP ) THEN
IF( J.EQ.NMATS .AND. I1.GT.0 ) THEN
GO TO 60
ELSE
WRITE( NOUT, FMT = 9995 )LINE
WRITE( NOUT, FMT = 9994 )NMATS
GO TO 80
END IF
END IF
IF( LINE( I: I ).NE.' ' .AND. LINE( I: I ).NE.',' ) THEN
I1 = I
C1 = LINE( I1: I1 )
*
* Check that a valid integer was read
*
DO 40 K = 1, 10
IF( C1.EQ.INTSTR( K: K ) ) THEN
IC = K - 1
GO TO 50
END IF
40 CONTINUE
WRITE( NOUT, FMT = 9996 )I, LINE
WRITE( NOUT, FMT = 9994 )NMATS
GO TO 80
50 CONTINUE
NREQ( J ) = 10*NREQ( J ) + IC
GO TO 30
ELSE IF( I1.GT.0 ) THEN
GO TO 60
ELSE
GO TO 30
END IF
60 CONTINUE
END IF
DO 70 I = 1, NMATS
NT = NREQ( I )
IF( NT.GT.0 .AND. NT.LE.NTYPES ) THEN
IF( DOTYPE( NT ) ) THEN
IF( FIRSTT )
$ WRITE( NOUT, FMT = * )
FIRSTT = .FALSE.
WRITE( NOUT, FMT = 9997 )NT, PATH
END IF
DOTYPE( NT ) = .TRUE.
ELSE
WRITE( NOUT, FMT = 9999 )PATH, NT, NTYPES
9999 FORMAT( ' *** Invalid type request for ', A3, ', type ',
$ I4, ': must satisfy 1 <= type <= ', I2 )
END IF
70 CONTINUE
80 CONTINUE
END IF
RETURN
*
90 CONTINUE
WRITE( NOUT, FMT = 9998 )PATH
9998 FORMAT( /' *** End of file reached when trying to read matrix ',
$ 'types for ', A3, /' *** Check that you are requesting the',
$ ' right number of types for each path', / )
9997 FORMAT( ' *** Warning: duplicate request of matrix type ', I2,
$ ' for ', A3 )
9996 FORMAT( //' *** Invalid integer value in column ', I2,
$ ' of input', ' line:', /A79 )
9995 FORMAT( //' *** Not enough matrix types on input line', /A79 )
9994 FORMAT( ' ==> Specify ', I4, ' matrix types on this line or ',
$ 'adjust NTYPES on previous line' )
WRITE( NOUT, FMT = * )
STOP
*
* End of ALAREQ
*
END
SUBROUTINE ALASUM( TYPE, NOUT, NFAIL, NRUN, NERRS )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 TYPE
INTEGER NFAIL, NOUT, NRUN, NERRS
* ..
*
* Purpose
* =======
*
* ALASUM prints a summary of results from one of the -CHK- routines.
*
* Arguments
* =========
*
* TYPE (input) CHARACTER*3
* The LAPACK path name.
*
* NOUT (input) INTEGER
* The unit number on which results are to be printed.
* NOUT >= 0.
*
* NFAIL (input) INTEGER
* The number of tests which did not pass the threshold ratio.
*
* NRUN (input) INTEGER
* The total number of tests.
*
* NERRS (input) INTEGER
* The number of error messages recorded.
*
* =====================================================================
*
* .. Executable Statements ..
*
IF( NFAIL.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )TYPE, NFAIL, NRUN
ELSE
WRITE( NOUT, FMT = 9998 )TYPE, NRUN
END IF
IF( NERRS.GT.0 ) THEN
WRITE( NOUT, FMT = 9997 )NERRS
END IF
*
9999 FORMAT( 1X, A3, ': ', I6, ' out of ', I6,
$ ' tests failed to pass the threshold' )
9998 FORMAT( /1X, 'All tests for ', A3,
$ ' routines passed the threshold (', I6, ' tests run)' )
9997 FORMAT( 6X, I6, ' error messages recorded' )
RETURN
*
* End of ALASUM
*
END
SUBROUTINE ALASVM( TYPE, NOUT, NFAIL, NRUN, NERRS )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 TYPE
INTEGER NFAIL, NOUT, NRUN, NERRS
* ..
*
* Purpose
* =======
*
* ALASVM prints a summary of results from one of the -DRV- routines.
*
* Arguments
* =========
*
* TYPE (input) CHARACTER*3
* The LAPACK path name.
*
* NOUT (input) INTEGER
* The unit number on which results are to be printed.
* NOUT >= 0.
*
* NFAIL (input) INTEGER
* The number of tests which did not pass the threshold ratio.
*
* NRUN (input) INTEGER
* The total number of tests.
*
* NERRS (input) INTEGER
* The number of error messages recorded.
*
* =====================================================================
*
* .. Executable Statements ..
*
IF( NFAIL.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )TYPE, NFAIL, NRUN
ELSE
WRITE( NOUT, FMT = 9998 )TYPE, NRUN
END IF
IF( NERRS.GT.0 ) THEN
WRITE( NOUT, FMT = 9997 )NERRS
END IF
*
9999 FORMAT( 1X, A3, ' drivers: ', I6, ' out of ', I6,
$ ' tests failed to pass the threshold' )
9998 FORMAT( /1X, 'All tests for ', A3, ' drivers passed the ',
$ 'threshold (', I6, ' tests run)' )
9997 FORMAT( 14X, I6, ' error messages recorded' )
RETURN
*
* End of ALASVM
*
END
SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
*
* Tests whether XERBLA has detected an error when it should.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Scalar Arguments ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Executable Statements ..
IF( .NOT.LERR ) THEN
WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT
OK = .FALSE.
END IF
LERR = .FALSE.
RETURN
*
9999 FORMAT( ' *** Illegal value of parameter number ', I2,
$ ' not detected by ', A6, ' ***' )
*
* End of CHKXER.
*
END
INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3,
$ N4 )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*( * ) NAME, OPTS
INTEGER ISPEC, N1, N2, N3, N4
* ..
*
* Purpose
* =======
*
* ILAENV returns problem-dependent parameters for the local
* environment. See ISPEC for a description of the parameters.
*
* In this version, the problem-dependent parameters are contained in
* the integer array IPARMS in the common block CLAENV and the value
* with index ISPEC is copied to ILAENV. This version of ILAENV is
* to be used in conjunction with XLAENV in TESTING and TIMING.
*
* 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
* = 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 and QZ methods
* for nonsymmetric eigenvalue problems.
* = 9: maximum size of the subproblems at the bottom of the
* computation tree in the divide-and-conquer algorithm
* =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
*
* Other specifications (up to 100) can be added later.
*
* NAME (input) CHARACTER*(*)
* The name of the calling subroutine.
*
* 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.
*
* (ILAENV) (output) INTEGER
* >= 0: the value of the parameter specified by ISPEC
* < 0: if ILAENV = -k, the k-th argument had an illegal value.
*
* 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 )
*
* =====================================================================
*
* .. Intrinsic Functions ..
INTRINSIC INT, MIN, REAL
* ..
* .. External Functions ..
INTEGER IEEECK
EXTERNAL IEEECK
* ..
* .. Arrays in Common ..
INTEGER IPARMS( 100 )
* ..
* .. Common blocks ..
COMMON / CLAENV / IPARMS
* ..
* .. Save statement ..
SAVE / CLAENV /
* ..
* .. Executable Statements ..
*
IF( ISPEC.GE.1 .AND. ISPEC.LE.5 ) THEN
*
* Return a value from the common block.
*
ILAENV = IPARMS( ISPEC )
*
ELSE IF( ISPEC.EQ.6 ) THEN
*
* Compute SVD crossover point.
*
ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 )
*
ELSE IF( ISPEC.GE.7 .AND. ISPEC.LE.9 ) THEN
*
* Return a value from the common block.
*
ILAENV = IPARMS( ISPEC )
*
ELSE IF( ISPEC.EQ.10 ) THEN
*
* IEEE NaN arithmetic can be trusted not to trap
*
C ILAENV = 0
ILAENV = 1
IF( ILAENV.EQ.1 ) THEN
ILAENV = IEEECK( 0, 0.0, 1.0 )
END IF
*
ELSE IF( ISPEC.EQ.11 ) THEN
*
* Infinity arithmetic can be trusted not to trap
*
C ILAENV = 0
ILAENV = 1
IF( ILAENV.EQ.1 ) THEN
ILAENV = IEEECK( 1, 0.0, 1.0 )
END IF
*
ELSE IF(( ISPEC.GE.12 ) .AND. (ISPEC.LE.16)) THEN
*
* 12 <= ISPEC <= 16: xHSEQR or one of its subroutines.
*
ILAENV = IPARMS( ISPEC )
* WRITE(*,*) 'ISPEC = ',ISPEC,' ILAENV =',ILAENV
* ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 )
*
ELSE
*
* Invalid value for ISPEC
*
ILAENV = -1
END IF
*
RETURN
*
* End of ILAENV
*
END
INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK )
*
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 = 11, K22MIN = 14, KACMIN = 14,
$ NIBBLE = 14, KNWSWP = 500 )
REAL TWO
PARAMETER ( TWO = 2.0 )
* ..
* .. Scalar Arguments ..
INTEGER IHI, ILO, ISPEC, LWORK, N
CHARACTER NAME*( * ), OPTS*( * )
* ..
* .. 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 LAHQR, 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
SUBROUTINE SBDT01( M, N, KD, A, LDA, Q, LDQ, D, E, PT, LDPT, WORK,
$ RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KD, LDA, LDPT, LDQ, M, N
REAL RESID
* ..
* .. Array Arguments ..
REAL A( LDA, * ), D( * ), E( * ), PT( LDPT, * ),
$ Q( LDQ, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SBDT01 reconstructs a general matrix A from its bidiagonal form
* A = Q * B * P'
* where Q (m by min(m,n)) and P' (min(m,n) by n) are orthogonal
* matrices and B is bidiagonal.
*
* The test ratio to test the reduction is
* RESID = norm( A - Q * B * PT ) / ( n * norm(A) * EPS )
* where PT = P' and EPS is the machine precision.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrices A and Q.
*
* N (input) INTEGER
* The number of columns of the matrices A and P'.
*
* KD (input) INTEGER
* If KD = 0, B is diagonal and the array E is not referenced.
* If KD = 1, the reduction was performed by xGEBRD; B is upper
* bidiagonal if M >= N, and lower bidiagonal if M < N.
* If KD = -1, the reduction was performed by xGBBRD; B is
* always upper bidiagonal.
*
* A (input) REAL array, dimension (LDA,N)
* The m by n matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* Q (input) REAL array, dimension (LDQ,N)
* The m by min(m,n) orthogonal matrix Q in the reduction
* A = Q * B * P'.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,M).
*
* D (input) REAL array, dimension (min(M,N))
* The diagonal elements of the bidiagonal matrix B.
*
* E (input) REAL array, dimension (min(M,N)-1)
* The superdiagonal elements of the bidiagonal matrix B if
* m >= n, or the subdiagonal elements of B if m < n.
*
* PT (input) REAL array, dimension (LDPT,N)
* The min(m,n) by n orthogonal matrix P' in the reduction
* A = Q * B * P'.
*
* LDPT (input) INTEGER
* The leading dimension of the array PT.
* LDPT >= max(1,min(M,N)).
*
* WORK (workspace) REAL array, dimension (M+N)
*
* RESID (output) REAL
* The test ratio: norm(A - Q * B * P') / ( n * norm(A) * EPS )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
REAL ANORM, EPS
* ..
* .. External Functions ..
REAL SASUM, SLAMCH, SLANGE
EXTERNAL SASUM, SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Compute A - Q * B * P' one column at a time.
*
RESID = ZERO
IF( KD.NE.0 ) THEN
*
* B is bidiagonal.
*
IF( KD.NE.0 .AND. M.GE.N ) THEN
*
* B is upper bidiagonal and M >= N.
*
DO 20 J = 1, N
CALL SCOPY( M, A( 1, J ), 1, WORK, 1 )
DO 10 I = 1, N - 1
WORK( M+I ) = D( I )*PT( I, J ) + E( I )*PT( I+1, J )
10 CONTINUE
WORK( M+N ) = D( N )*PT( N, J )
CALL SGEMV( 'No transpose', M, N, -ONE, Q, LDQ,
$ WORK( M+1 ), 1, ONE, WORK, 1 )
RESID = MAX( RESID, SASUM( M, WORK, 1 ) )
20 CONTINUE
ELSE IF( KD.LT.0 ) THEN
*
* B is upper bidiagonal and M < N.
*
DO 40 J = 1, N
CALL SCOPY( M, A( 1, J ), 1, WORK, 1 )
DO 30 I = 1, M - 1
WORK( M+I ) = D( I )*PT( I, J ) + E( I )*PT( I+1, J )
30 CONTINUE
WORK( M+M ) = D( M )*PT( M, J )
CALL SGEMV( 'No transpose', M, M, -ONE, Q, LDQ,
$ WORK( M+1 ), 1, ONE, WORK, 1 )
RESID = MAX( RESID, SASUM( M, WORK, 1 ) )
40 CONTINUE
ELSE
*
* B is lower bidiagonal.
*
DO 60 J = 1, N
CALL SCOPY( M, A( 1, J ), 1, WORK, 1 )
WORK( M+1 ) = D( 1 )*PT( 1, J )
DO 50 I = 2, M
WORK( M+I ) = E( I-1 )*PT( I-1, J ) +
$ D( I )*PT( I, J )
50 CONTINUE
CALL SGEMV( 'No transpose', M, M, -ONE, Q, LDQ,
$ WORK( M+1 ), 1, ONE, WORK, 1 )
RESID = MAX( RESID, SASUM( M, WORK, 1 ) )
60 CONTINUE
END IF
ELSE
*
* B is diagonal.
*
IF( M.GE.N ) THEN
DO 80 J = 1, N
CALL SCOPY( M, A( 1, J ), 1, WORK, 1 )
DO 70 I = 1, N
WORK( M+I ) = D( I )*PT( I, J )
70 CONTINUE
CALL SGEMV( 'No transpose', M, N, -ONE, Q, LDQ,
$ WORK( M+1 ), 1, ONE, WORK, 1 )
RESID = MAX( RESID, SASUM( M, WORK, 1 ) )
80 CONTINUE
ELSE
DO 100 J = 1, N
CALL SCOPY( M, A( 1, J ), 1, WORK, 1 )
DO 90 I = 1, M
WORK( M+I ) = D( I )*PT( I, J )
90 CONTINUE
CALL SGEMV( 'No transpose', M, M, -ONE, Q, LDQ,
$ WORK( M+1 ), 1, ONE, WORK, 1 )
RESID = MAX( RESID, SASUM( M, WORK, 1 ) )
100 CONTINUE
END IF
END IF
*
* Compute norm(A - Q * B * P') / ( n * norm(A) * EPS )
*
ANORM = SLANGE( '1', M, N, A, LDA, WORK )
EPS = SLAMCH( 'Precision' )
*
IF( ANORM.LE.ZERO ) THEN
IF( RESID.NE.ZERO )
$ RESID = ONE / EPS
ELSE
IF( ANORM.GE.RESID ) THEN
RESID = ( RESID / ANORM ) / ( REAL( N )*EPS )
ELSE
IF( ANORM.LT.ONE ) THEN
RESID = ( MIN( RESID, REAL( N )*ANORM ) / ANORM ) /
$ ( REAL( N )*EPS )
ELSE
RESID = MIN( RESID / ANORM, REAL( N ) ) /
$ ( REAL( N )*EPS )
END IF
END IF
END IF
*
RETURN
*
* End of SBDT01
*
END
SUBROUTINE SBDT02( M, N, B, LDB, C, LDC, U, LDU, WORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDB, LDC, LDU, M, N
REAL RESID
* ..
* .. Array Arguments ..
REAL B( LDB, * ), C( LDC, * ), U( LDU, * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* SBDT02 tests the change of basis C = U' * B by computing the residual
*
* RESID = norm( B - U * C ) / ( max(m,n) * norm(B) * EPS ),
*
* where B and C are M by N matrices, U is an M by M orthogonal matrix,
* and EPS is the machine precision.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrices B and C and the order of
* the matrix Q.
*
* N (input) INTEGER
* The number of columns of the matrices B and C.
*
* B (input) REAL array, dimension (LDB,N)
* The m by n matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,M).
*
* C (input) REAL array, dimension (LDC,N)
* The m by n matrix C, assumed to contain U' * B.
*
* LDC (input) INTEGER
* The leading dimension of the array C. LDC >= max(1,M).
*
* U (input) REAL array, dimension (LDU,M)
* The m by m orthogonal matrix U.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= max(1,M).
*
* WORK (workspace) REAL array, dimension (M)
*
* RESID (output) REAL
* RESID = norm( B - U * C ) / ( max(m,n) * norm(B) * EPS ),
*
* ======================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER J
REAL BNORM, EPS, REALMN
* ..
* .. External Functions ..
REAL SASUM, SLAMCH, SLANGE
EXTERNAL SASUM, SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
RESID = ZERO
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
REALMN = REAL( MAX( M, N ) )
EPS = SLAMCH( 'Precision' )
*
* Compute norm( B - U * C )
*
DO 10 J = 1, N
CALL SCOPY( M, B( 1, J ), 1, WORK, 1 )
CALL SGEMV( 'No transpose', M, M, -ONE, U, LDU, C( 1, J ), 1,
$ ONE, WORK, 1 )
RESID = MAX( RESID, SASUM( M, WORK, 1 ) )
10 CONTINUE
*
* Compute norm of B.
*
BNORM = SLANGE( '1', M, N, B, LDB, WORK )
*
IF( BNORM.LE.ZERO ) THEN
IF( RESID.NE.ZERO )
$ RESID = ONE / EPS
ELSE
IF( BNORM.GE.RESID ) THEN
RESID = ( RESID / BNORM ) / ( REALMN*EPS )
ELSE
IF( BNORM.LT.ONE ) THEN
RESID = ( MIN( RESID, REALMN*BNORM ) / BNORM ) /
$ ( REALMN*EPS )
ELSE
RESID = MIN( RESID / BNORM, REALMN ) / ( REALMN*EPS )
END IF
END IF
END IF
RETURN
*
* End of SBDT02
*
END
SUBROUTINE SBDT03( UPLO, N, KD, D, E, U, LDU, S, VT, LDVT, WORK,
$ RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER KD, LDU, LDVT, N
REAL RESID
* ..
* .. Array Arguments ..
REAL D( * ), E( * ), S( * ), U( LDU, * ),
$ VT( LDVT, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SBDT03 reconstructs a bidiagonal matrix B from its SVD:
* S = U' * B * V
* where U and V are orthogonal matrices and S is diagonal.
*
* The test ratio to test the singular value decomposition is
* RESID = norm( B - U * S * VT ) / ( n * norm(B) * EPS )
* where VT = V' and EPS is the machine precision.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix B is upper or lower bidiagonal.
* = 'U': Upper bidiagonal
* = 'L': Lower bidiagonal
*
* N (input) INTEGER
* The order of the matrix B.
*
* KD (input) INTEGER
* The bandwidth of the bidiagonal matrix B. If KD = 1, the
* matrix B is bidiagonal, and if KD = 0, B is diagonal and E is
* not referenced. If KD is greater than 1, it is assumed to be
* 1, and if KD is less than 0, it is assumed to be 0.
*
* D (input) REAL array, dimension (N)
* The n diagonal elements of the bidiagonal matrix B.
*
* E (input) REAL array, dimension (N-1)
* The (n-1) superdiagonal elements of the bidiagonal matrix B
* if UPLO = 'U', or the (n-1) subdiagonal elements of B if
* UPLO = 'L'.
*
* U (input) REAL array, dimension (LDU,N)
* The n by n orthogonal matrix U in the reduction B = U'*A*P.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= max(1,N)
*
* S (input) REAL array, dimension (N)
* The singular values from the SVD of B, sorted in decreasing
* order.
*
* VT (input) REAL array, dimension (LDVT,N)
* The n by n orthogonal matrix V' in the reduction
* B = U * S * V'.
*
* LDVT (input) INTEGER
* The leading dimension of the array VT.
*
* WORK (workspace) REAL array, dimension (2*N)
*
* RESID (output) REAL
* The test ratio: norm(B - U * S * V') / ( n * norm(A) * EPS )
*
* ======================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
REAL BNORM, EPS
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SASUM, SLAMCH
EXTERNAL LSAME, ISAMAX, SASUM, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SGEMV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
RESID = ZERO
IF( N.LE.0 )
$ RETURN
*
* Compute B - U * S * V' one column at a time.
*
BNORM = ZERO
IF( KD.GE.1 ) THEN
*
* B is bidiagonal.
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* B is upper bidiagonal.
*
DO 20 J = 1, N
DO 10 I = 1, N
WORK( N+I ) = S( I )*VT( I, J )
10 CONTINUE
CALL SGEMV( 'No transpose', N, N, -ONE, U, LDU,
$ WORK( N+1 ), 1, ZERO, WORK, 1 )
WORK( J ) = WORK( J ) + D( J )
IF( J.GT.1 ) THEN
WORK( J-1 ) = WORK( J-1 ) + E( J-1 )
BNORM = MAX( BNORM, ABS( D( J ) )+ABS( E( J-1 ) ) )
ELSE
BNORM = MAX( BNORM, ABS( D( J ) ) )
END IF
RESID = MAX( RESID, SASUM( N, WORK, 1 ) )
20 CONTINUE
ELSE
*
* B is lower bidiagonal.
*
DO 40 J = 1, N
DO 30 I = 1, N
WORK( N+I ) = S( I )*VT( I, J )
30 CONTINUE
CALL SGEMV( 'No transpose', N, N, -ONE, U, LDU,
$ WORK( N+1 ), 1, ZERO, WORK, 1 )
WORK( J ) = WORK( J ) + D( J )
IF( J.LT.N ) THEN
WORK( J+1 ) = WORK( J+1 ) + E( J )
BNORM = MAX( BNORM, ABS( D( J ) )+ABS( E( J ) ) )
ELSE
BNORM = MAX( BNORM, ABS( D( J ) ) )
END IF
RESID = MAX( RESID, SASUM( N, WORK, 1 ) )
40 CONTINUE
END IF
ELSE
*
* B is diagonal.
*
DO 60 J = 1, N
DO 50 I = 1, N
WORK( N+I ) = S( I )*VT( I, J )
50 CONTINUE
CALL SGEMV( 'No transpose', N, N, -ONE, U, LDU, WORK( N+1 ),
$ 1, ZERO, WORK, 1 )
WORK( J ) = WORK( J ) + D( J )
RESID = MAX( RESID, SASUM( N, WORK, 1 ) )
60 CONTINUE
J = ISAMAX( N, D, 1 )
BNORM = ABS( D( J ) )
END IF
*
* Compute norm(B - U * S * V') / ( n * norm(B) * EPS )
*
EPS = SLAMCH( 'Precision' )
*
IF( BNORM.LE.ZERO ) THEN
IF( RESID.NE.ZERO )
$ RESID = ONE / EPS
ELSE
IF( BNORM.GE.RESID ) THEN
RESID = ( RESID / BNORM ) / ( REAL( N )*EPS )
ELSE
IF( BNORM.LT.ONE ) THEN
RESID = ( MIN( RESID, REAL( N )*BNORM ) / BNORM ) /
$ ( REAL( N )*EPS )
ELSE
RESID = MIN( RESID / BNORM, REAL( N ) ) /
$ ( REAL( N )*EPS )
END IF
END IF
END IF
*
RETURN
*
* End of SBDT03
*
END
SUBROUTINE SCHKBB( NSIZES, MVAL, NVAL, NWDTHS, KK, NTYPES, DOTYPE,
$ NRHS, ISEED, THRESH, NOUNIT, A, LDA, AB, LDAB,
$ BD, BE, Q, LDQ, P, LDP, C, LDC, CC, WORK,
$ LWORK, RESULT, INFO )
*
* -- LAPACK test routine (release 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDAB, LDC, LDP, LDQ, LWORK, NOUNIT,
$ NRHS, NSIZES, NTYPES, NWDTHS
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER ISEED( 4 ), KK( * ), MVAL( * ), NVAL( * )
REAL A( LDA, * ), AB( LDAB, * ), BD( * ), BE( * ),
$ C( LDC, * ), CC( LDC, * ), P( LDP, * ),
$ Q( LDQ, * ), RESULT( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SCHKBB tests the reduction of a general real rectangular band
* matrix to bidiagonal form.
*
* SGBBRD factors a general band matrix A as Q B P* , where * means
* transpose, B is upper bidiagonal, and Q and P are orthogonal;
* SGBBRD can also overwrite a given matrix C with Q* C .
*
* For each pair of matrix dimensions (M,N) and each selected matrix
* type, an M by N matrix A and an M by NRHS matrix C are generated.
* The problem dimensions are as follows
* A: M x N
* Q: M x M
* P: N x N
* B: min(M,N) x min(M,N)
* C: M x NRHS
*
* For each generated matrix, 4 tests are performed:
*
* (1) | A - Q B PT | / ( |A| max(M,N) ulp ), PT = P'
*
* (2) | I - Q' Q | / ( M ulp )
*
* (3) | I - PT PT' | / ( N ulp )
*
* (4) | Y - Q' C | / ( |Y| max(M,NRHS) ulp ), where Y = Q' C.
*
* The "types" are specified by a logical array DOTYPE( 1:NTYPES );
* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
* Currently, the list of possible types is:
*
* The possible matrix types are
*
* (1) The zero matrix.
* (2) The identity matrix.
*
* (3) A diagonal matrix with evenly spaced entries
* 1, ..., ULP and random signs.
* (ULP = (first number larger than 1) - 1 )
* (4) A diagonal matrix with geometrically spaced entries
* 1, ..., ULP and random signs.
* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
* and random signs.
*
* (6) Same as (3), but multiplied by SQRT( overflow threshold )
* (7) Same as (3), but multiplied by SQRT( underflow threshold )
*
* (8) A matrix of the form U D V, where U and V are orthogonal and
* D has evenly spaced entries 1, ..., ULP with random signs
* on the diagonal.
*
* (9) A matrix of the form U D V, where U and V are orthogonal and
* D has geometrically spaced entries 1, ..., ULP with random
* signs on the diagonal.
*
* (10) A matrix of the form U D V, where U and V are orthogonal and
* D has "clustered" entries 1, ULP,..., ULP with random
* signs on the diagonal.
*
* (11) Same as (8), but multiplied by SQRT( overflow threshold )
* (12) Same as (8), but multiplied by SQRT( underflow threshold )
*
* (13) Rectangular matrix with random entries chosen from (-1,1).
* (14) Same as (13), but multiplied by SQRT( overflow threshold )
* (15) Same as (13), but multiplied by SQRT( underflow threshold )
*
* Arguments
* =========
*
* NSIZES (input) INTEGER
* The number of values of M and N contained in the vectors
* MVAL and NVAL. The matrix sizes are used in pairs (M,N).
* If NSIZES is zero, SCHKBB does nothing. NSIZES must be at
* least zero.
*
* MVAL (input) INTEGER array, dimension (NSIZES)
* The values of the matrix row dimension M.
*
* NVAL (input) INTEGER array, dimension (NSIZES)
* The values of the matrix column dimension N.
*
* NWDTHS (input) INTEGER
* The number of bandwidths to use. If it is zero,
* SCHKBB does nothing. It must be at least zero.
*
* KK (input) INTEGER array, dimension (NWDTHS)
* An array containing the bandwidths to be used for the band
* matrices. The values must be at least zero.
*
* NTYPES (input) INTEGER
* The number of elements in DOTYPE. If it is zero, SCHKBB
* does nothing. It must be at least zero. If it is MAXTYP+1
* and NSIZES is 1, then an additional type, MAXTYP+1 is
* defined, which is to use whatever matrix is in A. This
* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
* DOTYPE(MAXTYP+1) is .TRUE. .
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* If DOTYPE(j) is .TRUE., then for each size in NN a
* matrix of that size and of type j will be generated.
* If NTYPES is smaller than the maximum number of types
* defined (PARAMETER MAXTYP), then types NTYPES+1 through
* MAXTYP will not be generated. If NTYPES is larger
* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
* will be ignored.
*
* NRHS (input) INTEGER
* The number of columns in the "right-hand side" matrix C.
* If NRHS = 0, then the operations on the right-hand side will
* not be tested. NRHS must be at least 0.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The array elements should be between 0 and 4095;
* if not they will be reduced mod 4096. Also, ISEED(4) must
* be odd. The random number generator uses a linear
* congruential sequence limited to small integers, and so
* should produce machine independent random numbers. The
* values of ISEED are changed on exit, and can be used in the
* next call to SCHKBB to continue the same random number
* sequence.
*
* THRESH (input) REAL
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error
* is scaled to be O(1), so THRESH should be a reasonably
* small multiple of 1, e.g., 10 or 100. In particular,
* it should not depend on the precision (single vs. double)
* or the size of the matrix. It must be at least zero.
*
* NOUNIT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns IINFO not equal to 0.)
*
* A (input/workspace) REAL array, dimension
* (LDA, max(NN))
* Used to hold the matrix A.
*
* LDA (input) INTEGER
* The leading dimension of A. It must be at least 1
* and at least max( NN ).
*
* AB (workspace) REAL array, dimension (LDAB, max(NN))
* Used to hold A in band storage format.
*
* LDAB (input) INTEGER
* The leading dimension of AB. It must be at least 2 (not 1!)
* and at least max( KK )+1.
*
* BD (workspace) REAL array, dimension (max(NN))
* Used to hold the diagonal of the bidiagonal matrix computed
* by SGBBRD.
*
* BE (workspace) REAL array, dimension (max(NN))
* Used to hold the off-diagonal of the bidiagonal matrix
* computed by SGBBRD.
*
* Q (workspace) REAL array, dimension (LDQ, max(NN))
* Used to hold the orthogonal matrix Q computed by SGBBRD.
*
* LDQ (input) INTEGER
* The leading dimension of Q. It must be at least 1
* and at least max( NN ).
*
* P (workspace) REAL array, dimension (LDP, max(NN))
* Used to hold the orthogonal matrix P computed by SGBBRD.
*
* LDP (input) INTEGER
* The leading dimension of P. It must be at least 1
* and at least max( NN ).
*
* C (workspace) REAL array, dimension (LDC, max(NN))
* Used to hold the matrix C updated by SGBBRD.
*
* LDC (input) INTEGER
* The leading dimension of U. It must be at least 1
* and at least max( NN ).
*
* CC (workspace) REAL array, dimension (LDC, max(NN))
* Used to hold a copy of the matrix C.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The number of entries in WORK. This must be at least
* max( LDA+1, max(NN)+1 )*max(NN).
*
* RESULT (output) REAL array, dimension (4)
* The values computed by the tests described above.
* The values are currently limited to 1/ulp, to avoid
* overflow.
*
* INFO (output) INTEGER
* If 0, then everything ran OK.
*
*-----------------------------------------------------------------------
*
* Some Local Variables and Parameters:
* ---- ----- --------- --- ----------
* ZERO, ONE Real 0 and 1.
* MAXTYP The number of types defined.
* NTEST The number of tests performed, or which can
* be performed so far, for the current matrix.
* NTESTT The total number of tests performed so far.
* NMAX Largest value in NN.
* NMATS The number of matrices generated so far.
* NERRS The number of tests which have exceeded THRESH
* so far.
* COND, IMODE Values to be passed to the matrix generators.
* ANORM Norm of A; passed to matrix generators.
*
* OVFL, UNFL Overflow and underflow thresholds.
* ULP, ULPINV Finest relative precision and its inverse.
* RTOVFL, RTUNFL Square roots of the previous 2 values.
* The following four arrays decode JTYPE:
* KTYPE(j) The general type (1-10) for type "j".
* KMODE(j) The MODE value to be passed to the matrix
* generator for type "j".
* KMAGN(j) The order of magnitude ( O(1),
* O(overflow^(1/2) ), O(underflow^(1/2) )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 15 )
* ..
* .. Local Scalars ..
LOGICAL BADMM, BADNN, BADNNB
INTEGER I, IINFO, IMODE, ITYPE, J, JCOL, JR, JSIZE,
$ JTYPE, JWIDTH, K, KL, KMAX, KU, M, MMAX, MNMAX,
$ MNMIN, MTYPES, N, NERRS, NMATS, NMAX, NTEST,
$ NTESTT
REAL AMNINV, ANORM, COND, OVFL, RTOVFL, RTUNFL, ULP,
$ ULPINV, UNFL
* ..
* .. Local Arrays ..
INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KMAGN( MAXTYP ),
$ KMODE( MAXTYP ), KTYPE( MAXTYP )
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SBDT01, SBDT02, SGBBRD, SLACPY, SLAHD2, SLASET,
$ SLASUM, SLATMR, SLATMS, SORT01, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL, SQRT
* ..
* .. Data statements ..
DATA KTYPE / 1, 2, 5*4, 5*6, 3*9 /
DATA KMAGN / 2*1, 3*1, 2, 3, 3*1, 2, 3, 1, 2, 3 /
DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
$ 0, 0 /
* ..
* .. Executable Statements ..
*
* Check for errors
*
NTESTT = 0
INFO = 0
*
* Important constants
*
BADMM = .FALSE.
BADNN = .FALSE.
MMAX = 1
NMAX = 1
MNMAX = 1
DO 10 J = 1, NSIZES
MMAX = MAX( MMAX, MVAL( J ) )
IF( MVAL( J ).LT.0 )
$ BADMM = .TRUE.
NMAX = MAX( NMAX, NVAL( J ) )
IF( NVAL( J ).LT.0 )
$ BADNN = .TRUE.
MNMAX = MAX( MNMAX, MIN( MVAL( J ), NVAL( J ) ) )
10 CONTINUE
*
BADNNB = .FALSE.
KMAX = 0
DO 20 J = 1, NWDTHS
KMAX = MAX( KMAX, KK( J ) )
IF( KK( J ).LT.0 )
$ BADNNB = .TRUE.
20 CONTINUE
*
* Check for errors
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADMM ) THEN
INFO = -2
ELSE IF( BADNN ) THEN
INFO = -3
ELSE IF( NWDTHS.LT.0 ) THEN
INFO = -4
ELSE IF( BADNNB ) THEN
INFO = -5
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -6
ELSE IF( NRHS.LT.0 ) THEN
INFO = -8
ELSE IF( LDA.LT.NMAX ) THEN
INFO = -13
ELSE IF( LDAB.LT.2*KMAX+1 ) THEN
INFO = -15
ELSE IF( LDQ.LT.NMAX ) THEN
INFO = -19
ELSE IF( LDP.LT.NMAX ) THEN
INFO = -21
ELSE IF( LDC.LT.NMAX ) THEN
INFO = -23
ELSE IF( ( MAX( LDA, NMAX )+1 )*NMAX.GT.LWORK ) THEN
INFO = -26
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SCHKBB', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 .OR. NWDTHS.EQ.0 )
$ RETURN
*
* More Important constants
*
UNFL = SLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
ULPINV = ONE / ULP
RTUNFL = SQRT( UNFL )
RTOVFL = SQRT( OVFL )
*
* Loop over sizes, widths, types
*
NERRS = 0
NMATS = 0
*
DO 160 JSIZE = 1, NSIZES
M = MVAL( JSIZE )
N = NVAL( JSIZE )
MNMIN = MIN( M, N )
AMNINV = ONE / REAL( MAX( 1, M, N ) )
*
DO 150 JWIDTH = 1, NWDTHS
K = KK( JWIDTH )
IF( K.GE.M .AND. K.GE.N )
$ GO TO 150
KL = MAX( 0, MIN( M-1, K ) )
KU = MAX( 0, MIN( N-1, K ) )
*
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
DO 140 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 140
NMATS = NMATS + 1
NTEST = 0
*
DO 30 J = 1, 4
IOLDSD( J ) = ISEED( J )
30 CONTINUE
*
* Compute "A".
*
* Control parameters:
*
* KMAGN KMODE KTYPE
* =1 O(1) clustered 1 zero
* =2 large clustered 2 identity
* =3 small exponential (none)
* =4 arithmetic diagonal, (w/ singular values)
* =5 random log (none)
* =6 random nonhermitian, w/ singular values
* =7 (none)
* =8 (none)
* =9 random nonhermitian
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 90
*
ITYPE = KTYPE( JTYPE )
IMODE = KMODE( JTYPE )
*
* Compute norm
*
GO TO ( 40, 50, 60 )KMAGN( JTYPE )
*
40 CONTINUE
ANORM = ONE
GO TO 70
*
50 CONTINUE
ANORM = ( RTOVFL*ULP )*AMNINV
GO TO 70
*
60 CONTINUE
ANORM = RTUNFL*MAX( M, N )*ULPINV
GO TO 70
*
70 CONTINUE
*
CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
CALL SLASET( 'Full', LDAB, N, ZERO, ZERO, AB, LDAB )
IINFO = 0
COND = ULPINV
*
* Special Matrices -- Identity & Jordan block
*
* Zero
*
IF( ITYPE.EQ.1 ) THEN
IINFO = 0
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Identity
*
DO 80 JCOL = 1, N
A( JCOL, JCOL ) = ANORM
80 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Diagonal Matrix, singular values specified
*
CALL SLATMS( M, N, 'S', ISEED, 'N', WORK, IMODE, COND,
$ ANORM, 0, 0, 'N', A, LDA, WORK( M+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.6 ) THEN
*
* Nonhermitian, singular values specified
*
CALL SLATMS( M, N, 'S', ISEED, 'N', WORK, IMODE, COND,
$ ANORM, KL, KU, 'N', A, LDA, WORK( M+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.9 ) THEN
*
* Nonhermitian, random entries
*
CALL SLATMR( M, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, KL,
$ KU, ZERO, ANORM, 'N', A, LDA, IDUMMA,
$ IINFO )
*
ELSE
*
IINFO = 1
END IF
*
* Generate Right-Hand Side
*
CALL SLATMR( M, NRHS, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( M+1 ), 1, ONE,
$ WORK( 2*M+1 ), 1, ONE, 'N', IDUMMA, M, NRHS,
$ ZERO, ONE, 'NO', C, LDC, IDUMMA, IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
90 CONTINUE
*
* Copy A to band storage.
*
DO 110 J = 1, N
DO 100 I = MAX( 1, J-KU ), MIN( M, J+KL )
AB( KU+1+I-J, J ) = A( I, J )
100 CONTINUE
110 CONTINUE
*
* Copy C
*
CALL SLACPY( 'Full', M, NRHS, C, LDC, CC, LDC )
*
* Call SGBBRD to compute B, Q and P, and to update C.
*
CALL SGBBRD( 'B', M, N, NRHS, KL, KU, AB, LDAB, BD, BE,
$ Q, LDQ, P, LDP, CC, LDC, WORK, IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SGBBRD', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 1 ) = ULPINV
GO TO 120
END IF
END IF
*
* Test 1: Check the decomposition A := Q * B * P'
* 2: Check the orthogonality of Q
* 3: Check the orthogonality of P
* 4: Check the computation of Q' * C
*
CALL SBDT01( M, N, -1, A, LDA, Q, LDQ, BD, BE, P, LDP,
$ WORK, RESULT( 1 ) )
CALL SORT01( 'Columns', M, M, Q, LDQ, WORK, LWORK,
$ RESULT( 2 ) )
CALL SORT01( 'Rows', N, N, P, LDP, WORK, LWORK,
$ RESULT( 3 ) )
CALL SBDT02( M, NRHS, C, LDC, CC, LDC, Q, LDQ, WORK,
$ RESULT( 4 ) )
*
* End of Loop -- Check for RESULT(j) > THRESH
*
NTEST = 4
120 CONTINUE
NTESTT = NTESTT + NTEST
*
* Print out tests which fail.
*
DO 130 JR = 1, NTEST
IF( RESULT( JR ).GE.THRESH ) THEN
IF( NERRS.EQ.0 )
$ CALL SLAHD2( NOUNIT, 'SBB' )
NERRS = NERRS + 1
WRITE( NOUNIT, FMT = 9998 )M, N, K, IOLDSD, JTYPE,
$ JR, RESULT( JR )
END IF
130 CONTINUE
*
140 CONTINUE
150 CONTINUE
160 CONTINUE
*
* Summary
*
CALL SLASUM( 'SBB', NOUNIT, NERRS, NTESTT )
RETURN
*
9999 FORMAT( ' SCHKBB: ', A, ' returned INFO=', I5, '.', / 9X, 'M=',
$ I5, ' N=', I5, ' K=', I5, ', JTYPE=', I5, ', ISEED=(',
$ 3( I5, ',' ), I5, ')' )
9998 FORMAT( ' M =', I4, ' N=', I4, ', K=', I3, ', seed=',
$ 4( I4, ',' ), ' type ', I2, ', test(', I2, ')=', G10.3 )
*
* End of SCHKBB
*
END
SUBROUTINE SCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS,
$ ISEED, THRESH, A, LDA, BD, BE, S1, S2, X, LDX,
$ Y, Z, Q, LDQ, PT, LDPT, U, VT, WORK, LWORK,
$ IWORK, NOUT, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDPT, LDQ, LDX, LWORK, NOUT, NRHS,
$ NSIZES, NTYPES
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER ISEED( 4 ), IWORK( * ), MVAL( * ), NVAL( * )
REAL A( LDA, * ), BD( * ), BE( * ), PT( LDPT, * ),
$ Q( LDQ, * ), S1( * ), S2( * ), U( LDPT, * ),
$ VT( LDPT, * ), WORK( * ), X( LDX, * ),
$ Y( LDX, * ), Z( LDX, * )
* ..
*
* Purpose
* =======
*
* SCHKBD checks the singular value decomposition (SVD) routines.
*
* SGEBRD reduces a real general m by n matrix A to upper or lower
* bidiagonal form B by an orthogonal transformation: Q' * A * P = B
* (or A = Q * B * P'). The matrix B is upper bidiagonal if m >= n
* and lower bidiagonal if m < n.
*
* SORGBR generates the orthogonal matrices Q and P' from SGEBRD.
* Note that Q and P are not necessarily square.
*
* SBDSQR computes the singular value decomposition of the bidiagonal
* matrix B as B = U S V'. It is called three times to compute
* 1) B = U S1 V', where S1 is the diagonal matrix of singular
* values and the columns of the matrices U and V are the left
* and right singular vectors, respectively, of B.
* 2) Same as 1), but the singular values are stored in S2 and the
* singular vectors are not computed.
* 3) A = (UQ) S (P'V'), the SVD of the original matrix A.
* In addition, SBDSQR has an option to apply the left orthogonal matrix
* U to a matrix X, useful in least squares applications.
*
* SBDSDC computes the singular value decomposition of the bidiagonal
* matrix B as B = U S V' using divide-and-conquer. It is called twice
* to compute
* 1) B = U S1 V', where S1 is the diagonal matrix of singular
* values and the columns of the matrices U and V are the left
* and right singular vectors, respectively, of B.
* 2) Same as 1), but the singular values are stored in S2 and the
* singular vectors are not computed.
*
* For each pair of matrix dimensions (M,N) and each selected matrix
* type, an M by N matrix A and an M by NRHS matrix X are generated.
* The problem dimensions are as follows
* A: M x N
* Q: M x min(M,N) (but M x M if NRHS > 0)
* P: min(M,N) x N
* B: min(M,N) x min(M,N)
* U, V: min(M,N) x min(M,N)
* S1, S2 diagonal, order min(M,N)
* X: M x NRHS
*
* For each generated matrix, 14 tests are performed:
*
* Test SGEBRD and SORGBR
*
* (1) | A - Q B PT | / ( |A| max(M,N) ulp ), PT = P'
*
* (2) | I - Q' Q | / ( M ulp )
*
* (3) | I - PT PT' | / ( N ulp )
*
* Test SBDSQR on bidiagonal matrix B
*
* (4) | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V'
*
* (5) | Y - U Z | / ( |Y| max(min(M,N),k) ulp ), where Y = Q' X
* and Z = U' Y.
* (6) | I - U' U | / ( min(M,N) ulp )
*
* (7) | I - VT VT' | / ( min(M,N) ulp )
*
* (8) S1 contains min(M,N) nonnegative values in decreasing order.
* (Return 0 if true, 1/ULP if false.)
*
* (9) | S1 - S2 | / ( |S1| ulp ), where S2 is computed without
* computing U and V.
*
* (10) 0 if the true singular values of B are within THRESH of
* those in S1. 2*THRESH if they are not. (Tested using
* SSVDCH)
*
* Test SBDSQR on matrix A
*
* (11) | A - (QU) S (VT PT) | / ( |A| max(M,N) ulp )
*
* (12) | X - (QU) Z | / ( |X| max(M,k) ulp )
*
* (13) | I - (QU)'(QU) | / ( M ulp )
*
* (14) | I - (VT PT) (PT'VT') | / ( N ulp )
*
* Test SBDSDC on bidiagonal matrix B
*
* (15) | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V'
*
* (16) | I - U' U | / ( min(M,N) ulp )
*
* (17) | I - VT VT' | / ( min(M,N) ulp )
*
* (18) S1 contains min(M,N) nonnegative values in decreasing order.
* (Return 0 if true, 1/ULP if false.)
*
* (19) | S1 - S2 | / ( |S1| ulp ), where S2 is computed without
* computing U and V.
* The possible matrix types are
*
* (1) The zero matrix.
* (2) The identity matrix.
*
* (3) A diagonal matrix with evenly spaced entries
* 1, ..., ULP and random signs.
* (ULP = (first number larger than 1) - 1 )
* (4) A diagonal matrix with geometrically spaced entries
* 1, ..., ULP and random signs.
* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
* and random signs.
*
* (6) Same as (3), but multiplied by SQRT( overflow threshold )
* (7) Same as (3), but multiplied by SQRT( underflow threshold )
*
* (8) A matrix of the form U D V, where U and V are orthogonal and
* D has evenly spaced entries 1, ..., ULP with random signs
* on the diagonal.
*
* (9) A matrix of the form U D V, where U and V are orthogonal and
* D has geometrically spaced entries 1, ..., ULP with random
* signs on the diagonal.
*
* (10) A matrix of the form U D V, where U and V are orthogonal and
* D has "clustered" entries 1, ULP,..., ULP with random
* signs on the diagonal.
*
* (11) Same as (8), but multiplied by SQRT( overflow threshold )
* (12) Same as (8), but multiplied by SQRT( underflow threshold )
*
* (13) Rectangular matrix with random entries chosen from (-1,1).
* (14) Same as (13), but multiplied by SQRT( overflow threshold )
* (15) Same as (13), but multiplied by SQRT( underflow threshold )
*
* Special case:
* (16) A bidiagonal matrix with random entries chosen from a
* logarithmic distribution on [ulp^2,ulp^(-2)] (I.e., each
* entry is e^x, where x is chosen uniformly on
* [ 2 log(ulp), -2 log(ulp) ] .) For *this* type:
* (a) SGEBRD is not called to reduce it to bidiagonal form.
* (b) the bidiagonal is min(M,N) x min(M,N); if M= THRESH. To have
* every test ratio printed, use THRESH = 0. Note that the
* expected value of the test ratios is O(1), so THRESH should
* be a reasonably small multiple of 1, e.g., 10 or 100.
*
* A (workspace) REAL array, dimension (LDA,NMAX)
* where NMAX is the maximum value of N in NVAL.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,MMAX),
* where MMAX is the maximum value of M in MVAL.
*
* BD (workspace) REAL array, dimension
* (max(min(MVAL(j),NVAL(j))))
*
* BE (workspace) REAL array, dimension
* (max(min(MVAL(j),NVAL(j))))
*
* S1 (workspace) REAL array, dimension
* (max(min(MVAL(j),NVAL(j))))
*
* S2 (workspace) REAL array, dimension
* (max(min(MVAL(j),NVAL(j))))
*
* X (workspace) REAL array, dimension (LDX,NRHS)
*
* LDX (input) INTEGER
* The leading dimension of the arrays X, Y, and Z.
* LDX >= max(1,MMAX)
*
* Y (workspace) REAL array, dimension (LDX,NRHS)
*
* Z (workspace) REAL array, dimension (LDX,NRHS)
*
* Q (workspace) REAL array, dimension (LDQ,MMAX)
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,MMAX).
*
* PT (workspace) REAL array, dimension (LDPT,NMAX)
*
* LDPT (input) INTEGER
* The leading dimension of the arrays PT, U, and V.
* LDPT >= max(1, max(min(MVAL(j),NVAL(j)))).
*
* U (workspace) REAL array, dimension
* (LDPT,max(min(MVAL(j),NVAL(j))))
*
* V (workspace) REAL array, dimension
* (LDPT,max(min(MVAL(j),NVAL(j))))
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The number of entries in WORK. This must be at least
* 3(M+N) and M(M + max(M,N,k) + 1) + N*min(M,N) for all
* pairs (M,N)=(MM(j),NN(j))
*
* IWORK (workspace) INTEGER array, dimension at least 8*min(M,N)
*
* NOUT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns IINFO not equal to 0.)
*
* INFO (output) INTEGER
* If 0, then everything ran OK.
* -1: NSIZES < 0
* -2: Some MM(j) < 0
* -3: Some NN(j) < 0
* -4: NTYPES < 0
* -6: NRHS < 0
* -8: THRESH < 0
* -11: LDA < 1 or LDA < MMAX, where MMAX is max( MM(j) ).
* -17: LDB < 1 or LDB < MMAX.
* -21: LDQ < 1 or LDQ < MMAX.
* -23: LDPT< 1 or LDPT< MNMAX.
* -27: LWORK too small.
* If SLATMR, SLATMS, SGEBRD, SORGBR, or SBDSQR,
* returns an error code, the
* absolute value of it is returned.
*
*-----------------------------------------------------------------------
*
* Some Local Variables and Parameters:
* ---- ----- --------- --- ----------
*
* ZERO, ONE Real 0 and 1.
* MAXTYP The number of types defined.
* NTEST The number of tests performed, or which can
* be performed so far, for the current matrix.
* MMAX Largest value in NN.
* NMAX Largest value in NN.
* MNMIN min(MM(j), NN(j)) (the dimension of the bidiagonal
* matrix.)
* MNMAX The maximum value of MNMIN for j=1,...,NSIZES.
* NFAIL The number of tests which have exceeded THRESH
* COND, IMODE Values to be passed to the matrix generators.
* ANORM Norm of A; passed to matrix generators.
*
* OVFL, UNFL Overflow and underflow thresholds.
* RTOVFL, RTUNFL Square roots of the previous 2 values.
* ULP, ULPINV Finest relative precision and its inverse.
*
* The following four arrays decode JTYPE:
* KTYPE(j) The general type (1-10) for type "j".
* KMODE(j) The MODE value to be passed to the matrix
* generator for type "j".
* KMAGN(j) The order of magnitude ( O(1),
* O(overflow^(1/2) ), O(underflow^(1/2) )
*
* ======================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO, HALF
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ HALF = 0.5E0 )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 16 )
* ..
* .. Local Scalars ..
LOGICAL BADMM, BADNN, BIDIAG
CHARACTER UPLO
CHARACTER*3 PATH
INTEGER I, IINFO, IMODE, ITYPE, J, JCOL, JSIZE, JTYPE,
$ LOG2UI, M, MINWRK, MMAX, MNMAX, MNMIN, MQ,
$ MTYPES, N, NFAIL, NMAX, NTEST
REAL AMNINV, ANORM, COND, OVFL, RTOVFL, RTUNFL,
$ TEMP1, TEMP2, ULP, ULPINV, UNFL
* ..
* .. Local Arrays ..
INTEGER IDUM( 1 ), IOLDSD( 4 ), KMAGN( MAXTYP ),
$ KMODE( MAXTYP ), KTYPE( MAXTYP )
REAL DUM( 1 ), DUMMA( 1 ), RESULT( 19 )
* ..
* .. External Functions ..
REAL SLAMCH, SLARND
EXTERNAL SLAMCH, SLARND
* ..
* .. External Subroutines ..
EXTERNAL ALASUM, SBDSDC, SBDSQR, SBDT01, SBDT02, SBDT03,
$ SCOPY, SGEBRD, SGEMM, SLABAD, SLACPY, SLAHD2,
$ SLASET, SLATMR, SLATMS, SORGBR, SORT01, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, EXP, INT, LOG, MAX, MIN, SQRT
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA KTYPE / 1, 2, 5*4, 5*6, 3*9, 10 /
DATA KMAGN / 2*1, 3*1, 2, 3, 3*1, 2, 3, 1, 2, 3, 0 /
DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
$ 0, 0, 0 /
* ..
* .. Executable Statements ..
*
* Check for errors
*
INFO = 0
*
BADMM = .FALSE.
BADNN = .FALSE.
MMAX = 1
NMAX = 1
MNMAX = 1
MINWRK = 1
DO 10 J = 1, NSIZES
MMAX = MAX( MMAX, MVAL( J ) )
IF( MVAL( J ).LT.0 )
$ BADMM = .TRUE.
NMAX = MAX( NMAX, NVAL( J ) )
IF( NVAL( J ).LT.0 )
$ BADNN = .TRUE.
MNMAX = MAX( MNMAX, MIN( MVAL( J ), NVAL( J ) ) )
MINWRK = MAX( MINWRK, 3*( MVAL( J )+NVAL( J ) ),
$ MVAL( J )*( MVAL( J )+MAX( MVAL( J ), NVAL( J ),
$ NRHS )+1 )+NVAL( J )*MIN( NVAL( J ), MVAL( J ) ) )
10 CONTINUE
*
* Check for errors
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADMM ) THEN
INFO = -2
ELSE IF( BADNN ) THEN
INFO = -3
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -4
ELSE IF( NRHS.LT.0 ) THEN
INFO = -6
ELSE IF( LDA.LT.MMAX ) THEN
INFO = -11
ELSE IF( LDX.LT.MMAX ) THEN
INFO = -17
ELSE IF( LDQ.LT.MMAX ) THEN
INFO = -21
ELSE IF( LDPT.LT.MNMAX ) THEN
INFO = -23
ELSE IF( MINWRK.GT.LWORK ) THEN
INFO = -27
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SCHKBD', -INFO )
RETURN
END IF
*
* Initialize constants
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'BD'
NFAIL = 0
NTEST = 0
UNFL = SLAMCH( 'Safe minimum' )
OVFL = SLAMCH( 'Overflow' )
CALL SLABAD( UNFL, OVFL )
ULP = SLAMCH( 'Precision' )
ULPINV = ONE / ULP
LOG2UI = INT( LOG( ULPINV ) / LOG( TWO ) )
RTUNFL = SQRT( UNFL )
RTOVFL = SQRT( OVFL )
INFOT = 0
*
* Loop over sizes, types
*
DO 200 JSIZE = 1, NSIZES
M = MVAL( JSIZE )
N = NVAL( JSIZE )
MNMIN = MIN( M, N )
AMNINV = ONE / MAX( M, N, 1 )
*
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
DO 190 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 190
*
DO 20 J = 1, 4
IOLDSD( J ) = ISEED( J )
20 CONTINUE
*
DO 30 J = 1, 14
RESULT( J ) = -ONE
30 CONTINUE
*
UPLO = ' '
*
* Compute "A"
*
* Control parameters:
*
* KMAGN KMODE KTYPE
* =1 O(1) clustered 1 zero
* =2 large clustered 2 identity
* =3 small exponential (none)
* =4 arithmetic diagonal, (w/ eigenvalues)
* =5 random symmetric, w/ eigenvalues
* =6 nonsymmetric, w/ singular values
* =7 random diagonal
* =8 random symmetric
* =9 random nonsymmetric
* =10 random bidiagonal (log. distrib.)
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 100
*
ITYPE = KTYPE( JTYPE )
IMODE = KMODE( JTYPE )
*
* Compute norm
*
GO TO ( 40, 50, 60 )KMAGN( JTYPE )
*
40 CONTINUE
ANORM = ONE
GO TO 70
*
50 CONTINUE
ANORM = ( RTOVFL*ULP )*AMNINV
GO TO 70
*
60 CONTINUE
ANORM = RTUNFL*MAX( M, N )*ULPINV
GO TO 70
*
70 CONTINUE
*
CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
IINFO = 0
COND = ULPINV
*
BIDIAG = .FALSE.
IF( ITYPE.EQ.1 ) THEN
*
* Zero matrix
*
IINFO = 0
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Identity
*
DO 80 JCOL = 1, MNMIN
A( JCOL, JCOL ) = ANORM
80 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Diagonal Matrix, [Eigen]values Specified
*
CALL SLATMS( MNMIN, MNMIN, 'S', ISEED, 'N', WORK, IMODE,
$ COND, ANORM, 0, 0, 'N', A, LDA,
$ WORK( MNMIN+1 ), IINFO )
*
ELSE IF( ITYPE.EQ.5 ) THEN
*
* Symmetric, eigenvalues specified
*
CALL SLATMS( MNMIN, MNMIN, 'S', ISEED, 'S', WORK, IMODE,
$ COND, ANORM, M, N, 'N', A, LDA,
$ WORK( MNMIN+1 ), IINFO )
*
ELSE IF( ITYPE.EQ.6 ) THEN
*
* Nonsymmetric, singular values specified
*
CALL SLATMS( M, N, 'S', ISEED, 'N', WORK, IMODE, COND,
$ ANORM, M, N, 'N', A, LDA, WORK( MNMIN+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.7 ) THEN
*
* Diagonal, random entries
*
CALL SLATMR( MNMIN, MNMIN, 'S', ISEED, 'N', WORK, 6, ONE,
$ ONE, 'T', 'N', WORK( MNMIN+1 ), 1, ONE,
$ WORK( 2*MNMIN+1 ), 1, ONE, 'N', IWORK, 0, 0,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.8 ) THEN
*
* Symmetric, random entries
*
CALL SLATMR( MNMIN, MNMIN, 'S', ISEED, 'S', WORK, 6, ONE,
$ ONE, 'T', 'N', WORK( MNMIN+1 ), 1, ONE,
$ WORK( M+MNMIN+1 ), 1, ONE, 'N', IWORK, M, N,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.9 ) THEN
*
* Nonsymmetric, random entries
*
CALL SLATMR( M, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( MNMIN+1 ), 1, ONE,
$ WORK( M+MNMIN+1 ), 1, ONE, 'N', IWORK, M, N,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.10 ) THEN
*
* Bidiagonal, random entries
*
TEMP1 = -TWO*LOG( ULP )
DO 90 J = 1, MNMIN
BD( J ) = EXP( TEMP1*SLARND( 2, ISEED ) )
IF( J.LT.MNMIN )
$ BE( J ) = EXP( TEMP1*SLARND( 2, ISEED ) )
90 CONTINUE
*
IINFO = 0
BIDIAG = .TRUE.
IF( M.GE.N ) THEN
UPLO = 'U'
ELSE
UPLO = 'L'
END IF
ELSE
IINFO = 1
END IF
*
IF( IINFO.EQ.0 ) THEN
*
* Generate Right-Hand Side
*
IF( BIDIAG ) THEN
CALL SLATMR( MNMIN, NRHS, 'S', ISEED, 'N', WORK, 6,
$ ONE, ONE, 'T', 'N', WORK( MNMIN+1 ), 1,
$ ONE, WORK( 2*MNMIN+1 ), 1, ONE, 'N',
$ IWORK, MNMIN, NRHS, ZERO, ONE, 'NO', Y,
$ LDX, IWORK, IINFO )
ELSE
CALL SLATMR( M, NRHS, 'S', ISEED, 'N', WORK, 6, ONE,
$ ONE, 'T', 'N', WORK( M+1 ), 1, ONE,
$ WORK( 2*M+1 ), 1, ONE, 'N', IWORK, M,
$ NRHS, ZERO, ONE, 'NO', X, LDX, IWORK,
$ IINFO )
END IF
END IF
*
* Error Exit
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )'Generator', IINFO, M, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
100 CONTINUE
*
* Call SGEBRD and SORGBR to compute B, Q, and P, do tests.
*
IF( .NOT.BIDIAG ) THEN
*
* Compute transformations to reduce A to bidiagonal form:
* B := Q' * A * P.
*
CALL SLACPY( ' ', M, N, A, LDA, Q, LDQ )
CALL SGEBRD( M, N, Q, LDQ, BD, BE, WORK, WORK( MNMIN+1 ),
$ WORK( 2*MNMIN+1 ), LWORK-2*MNMIN, IINFO )
*
* Check error code from SGEBRD.
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )'SGEBRD', IINFO, M, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
CALL SLACPY( ' ', M, N, Q, LDQ, PT, LDPT )
IF( M.GE.N ) THEN
UPLO = 'U'
ELSE
UPLO = 'L'
END IF
*
* Generate Q
*
MQ = M
IF( NRHS.LE.0 )
$ MQ = MNMIN
CALL SORGBR( 'Q', M, MQ, N, Q, LDQ, WORK,
$ WORK( 2*MNMIN+1 ), LWORK-2*MNMIN, IINFO )
*
* Check error code from SORGBR.
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )'SORGBR(Q)', IINFO, M, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
* Generate P'
*
CALL SORGBR( 'P', MNMIN, N, M, PT, LDPT, WORK( MNMIN+1 ),
$ WORK( 2*MNMIN+1 ), LWORK-2*MNMIN, IINFO )
*
* Check error code from SORGBR.
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )'SORGBR(P)', IINFO, M, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
* Apply Q' to an M by NRHS matrix X: Y := Q' * X.
*
CALL SGEMM( 'Transpose', 'No transpose', M, NRHS, M, ONE,
$ Q, LDQ, X, LDX, ZERO, Y, LDX )
*
* Test 1: Check the decomposition A := Q * B * PT
* 2: Check the orthogonality of Q
* 3: Check the orthogonality of PT
*
CALL SBDT01( M, N, 1, A, LDA, Q, LDQ, BD, BE, PT, LDPT,
$ WORK, RESULT( 1 ) )
CALL SORT01( 'Columns', M, MQ, Q, LDQ, WORK, LWORK,
$ RESULT( 2 ) )
CALL SORT01( 'Rows', MNMIN, N, PT, LDPT, WORK, LWORK,
$ RESULT( 3 ) )
END IF
*
* Use SBDSQR to form the SVD of the bidiagonal matrix B:
* B := U * S1 * VT, and compute Z = U' * Y.
*
CALL SCOPY( MNMIN, BD, 1, S1, 1 )
IF( MNMIN.GT.0 )
$ CALL SCOPY( MNMIN-1, BE, 1, WORK, 1 )
CALL SLACPY( ' ', M, NRHS, Y, LDX, Z, LDX )
CALL SLASET( 'Full', MNMIN, MNMIN, ZERO, ONE, U, LDPT )
CALL SLASET( 'Full', MNMIN, MNMIN, ZERO, ONE, VT, LDPT )
*
CALL SBDSQR( UPLO, MNMIN, MNMIN, MNMIN, NRHS, S1, WORK, VT,
$ LDPT, U, LDPT, Z, LDX, WORK( MNMIN+1 ), IINFO )
*
* Check error code from SBDSQR.
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )'SBDSQR(vects)', IINFO, M, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 4 ) = ULPINV
GO TO 170
END IF
END IF
*
* Use SBDSQR to compute only the singular values of the
* bidiagonal matrix B; U, VT, and Z should not be modified.
*
CALL SCOPY( MNMIN, BD, 1, S2, 1 )
IF( MNMIN.GT.0 )
$ CALL SCOPY( MNMIN-1, BE, 1, WORK, 1 )
*
CALL SBDSQR( UPLO, MNMIN, 0, 0, 0, S2, WORK, VT, LDPT, U,
$ LDPT, Z, LDX, WORK( MNMIN+1 ), IINFO )
*
* Check error code from SBDSQR.
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )'SBDSQR(values)', IINFO, M, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 9 ) = ULPINV
GO TO 170
END IF
END IF
*
* Test 4: Check the decomposition B := U * S1 * VT
* 5: Check the computation Z := U' * Y
* 6: Check the orthogonality of U
* 7: Check the orthogonality of VT
*
CALL SBDT03( UPLO, MNMIN, 1, BD, BE, U, LDPT, S1, VT, LDPT,
$ WORK, RESULT( 4 ) )
CALL SBDT02( MNMIN, NRHS, Y, LDX, Z, LDX, U, LDPT, WORK,
$ RESULT( 5 ) )
CALL SORT01( 'Columns', MNMIN, MNMIN, U, LDPT, WORK, LWORK,
$ RESULT( 6 ) )
CALL SORT01( 'Rows', MNMIN, MNMIN, VT, LDPT, WORK, LWORK,
$ RESULT( 7 ) )
*
* Test 8: Check that the singular values are sorted in
* non-increasing order and are non-negative
*
RESULT( 8 ) = ZERO
DO 110 I = 1, MNMIN - 1
IF( S1( I ).LT.S1( I+1 ) )
$ RESULT( 8 ) = ULPINV
IF( S1( I ).LT.ZERO )
$ RESULT( 8 ) = ULPINV
110 CONTINUE
IF( MNMIN.GE.1 ) THEN
IF( S1( MNMIN ).LT.ZERO )
$ RESULT( 8 ) = ULPINV
END IF
*
* Test 9: Compare SBDSQR with and without singular vectors
*
TEMP2 = ZERO
*
DO 120 J = 1, MNMIN
TEMP1 = ABS( S1( J )-S2( J ) ) /
$ MAX( SQRT( UNFL )*MAX( S1( 1 ), ONE ),
$ ULP*MAX( ABS( S1( J ) ), ABS( S2( J ) ) ) )
TEMP2 = MAX( TEMP1, TEMP2 )
120 CONTINUE
*
RESULT( 9 ) = TEMP2
*
* Test 10: Sturm sequence test of singular values
* Go up by factors of two until it succeeds
*
TEMP1 = THRESH*( HALF-ULP )
*
DO 130 J = 0, LOG2UI
* CALL SSVDCH( MNMIN, BD, BE, S1, TEMP1, IINFO )
IF( IINFO.EQ.0 )
$ GO TO 140
TEMP1 = TEMP1*TWO
130 CONTINUE
*
140 CONTINUE
RESULT( 10 ) = TEMP1
*
* Use SBDSQR to form the decomposition A := (QU) S (VT PT)
* from the bidiagonal form A := Q B PT.
*
IF( .NOT.BIDIAG ) THEN
CALL SCOPY( MNMIN, BD, 1, S2, 1 )
IF( MNMIN.GT.0 )
$ CALL SCOPY( MNMIN-1, BE, 1, WORK, 1 )
*
CALL SBDSQR( UPLO, MNMIN, N, M, NRHS, S2, WORK, PT, LDPT,
$ Q, LDQ, Y, LDX, WORK( MNMIN+1 ), IINFO )
*
* Test 11: Check the decomposition A := Q*U * S2 * VT*PT
* 12: Check the computation Z := U' * Q' * X
* 13: Check the orthogonality of Q*U
* 14: Check the orthogonality of VT*PT
*
CALL SBDT01( M, N, 0, A, LDA, Q, LDQ, S2, DUMMA, PT,
$ LDPT, WORK, RESULT( 11 ) )
CALL SBDT02( M, NRHS, X, LDX, Y, LDX, Q, LDQ, WORK,
$ RESULT( 12 ) )
CALL SORT01( 'Columns', M, MQ, Q, LDQ, WORK, LWORK,
$ RESULT( 13 ) )
CALL SORT01( 'Rows', MNMIN, N, PT, LDPT, WORK, LWORK,
$ RESULT( 14 ) )
END IF
*
* Use SBDSDC to form the SVD of the bidiagonal matrix B:
* B := U * S1 * VT
*
CALL SCOPY( MNMIN, BD, 1, S1, 1 )
IF( MNMIN.GT.0 )
$ CALL SCOPY( MNMIN-1, BE, 1, WORK, 1 )
CALL SLASET( 'Full', MNMIN, MNMIN, ZERO, ONE, U, LDPT )
CALL SLASET( 'Full', MNMIN, MNMIN, ZERO, ONE, VT, LDPT )
*
CALL SBDSDC( UPLO, 'I', MNMIN, S1, WORK, U, LDPT, VT, LDPT,
$ DUM, IDUM, WORK( MNMIN+1 ), IWORK, IINFO )
*
* Check error code from SBDSDC.
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )'SBDSDC(vects)', IINFO, M, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 15 ) = ULPINV
GO TO 170
END IF
END IF
*
* Use SBDSDC to compute only the singular values of the
* bidiagonal matrix B; U and VT should not be modified.
*
CALL SCOPY( MNMIN, BD, 1, S2, 1 )
IF( MNMIN.GT.0 )
$ CALL SCOPY( MNMIN-1, BE, 1, WORK, 1 )
*
CALL SBDSDC( UPLO, 'N', MNMIN, S2, WORK, DUM, 1, DUM, 1,
$ DUM, IDUM, WORK( MNMIN+1 ), IWORK, IINFO )
*
* Check error code from SBDSDC.
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )'SBDSDC(values)', IINFO, M, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 18 ) = ULPINV
GO TO 170
END IF
END IF
*
* Test 15: Check the decomposition B := U * S1 * VT
* 16: Check the orthogonality of U
* 17: Check the orthogonality of VT
*
CALL SBDT03( UPLO, MNMIN, 1, BD, BE, U, LDPT, S1, VT, LDPT,
$ WORK, RESULT( 15 ) )
CALL SORT01( 'Columns', MNMIN, MNMIN, U, LDPT, WORK, LWORK,
$ RESULT( 16 ) )
CALL SORT01( 'Rows', MNMIN, MNMIN, VT, LDPT, WORK, LWORK,
$ RESULT( 17 ) )
*
* Test 18: Check that the singular values are sorted in
* non-increasing order and are non-negative
*
RESULT( 18 ) = ZERO
DO 150 I = 1, MNMIN - 1
IF( S1( I ).LT.S1( I+1 ) )
$ RESULT( 18 ) = ULPINV
IF( S1( I ).LT.ZERO )
$ RESULT( 18 ) = ULPINV
150 CONTINUE
IF( MNMIN.GE.1 ) THEN
IF( S1( MNMIN ).LT.ZERO )
$ RESULT( 18 ) = ULPINV
END IF
*
* Test 19: Compare SBDSQR with and without singular vectors
*
TEMP2 = ZERO
*
DO 160 J = 1, MNMIN
TEMP1 = ABS( S1( J )-S2( J ) ) /
$ MAX( SQRT( UNFL )*MAX( S1( 1 ), ONE ),
$ ULP*MAX( ABS( S1( 1 ) ), ABS( S2( 1 ) ) ) )
TEMP2 = MAX( TEMP1, TEMP2 )
160 CONTINUE
*
RESULT( 19 ) = TEMP2
*
* End of Loop -- Check for RESULT(j) > THRESH
*
170 CONTINUE
DO 180 J = 1, 19
IF( RESULT( J ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 )
$ CALL SLAHD2( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )M, N, JTYPE, IOLDSD, J,
$ RESULT( J )
NFAIL = NFAIL + 1
END IF
180 CONTINUE
IF( .NOT.BIDIAG ) THEN
NTEST = NTEST + 19
ELSE
NTEST = NTEST + 5
END IF
*
190 CONTINUE
200 CONTINUE
*
* Summary
*
CALL ALASUM( PATH, NOUT, NFAIL, NTEST, 0 )
*
RETURN
*
* End of SCHKBD
*
9999 FORMAT( ' M=', I5, ', N=', I5, ', type ', I2, ', seed=',
$ 4( I4, ',' ), ' test(', I2, ')=', G11.4 )
9998 FORMAT( ' SCHKBD: ', A, ' returned INFO=', I6, '.', / 9X, 'M=',
$ I6, ', N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ),
$ I5, ')' )
*
END
SUBROUTINE SCHKBK( NIN, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER NIN, NOUT
* ..
*
* Purpose
* =======
*
* SCHKBK tests SGEBAK, a routine for backward transformation of
* the computed right or left eigenvectors if the orginal matrix
* was preprocessed by balance subroutine SGEBAL.
*
* Arguments
* =========
*
* NIN (input) INTEGER
* The logical unit number for input. NIN > 0.
*
* NOUT (input) INTEGER
* The logical unit number for output. NOUT > 0.
*
* ======================================================================
*
* .. Parameters ..
INTEGER LDE
PARAMETER ( LDE = 20 )
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
INTEGER I, IHI, ILO, INFO, J, KNT, N, NINFO
REAL EPS, RMAX, SAFMIN, VMAX, X
* ..
* .. Local Arrays ..
INTEGER LMAX( 2 )
REAL E( LDE, LDE ), EIN( LDE, LDE ), SCALE( LDE )
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SGEBAK
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
LMAX( 1 ) = 0
LMAX( 2 ) = 0
NINFO = 0
KNT = 0
RMAX = ZERO
EPS = SLAMCH( 'E' )
SAFMIN = SLAMCH( 'S' )
*
10 CONTINUE
*
READ( NIN, FMT = * )N, ILO, IHI
IF( N.EQ.0 )
$ GO TO 60
*
READ( NIN, FMT = * )( SCALE( I ), I = 1, N )
DO 20 I = 1, N
READ( NIN, FMT = * )( E( I, J ), J = 1, N )
20 CONTINUE
*
DO 30 I = 1, N
READ( NIN, FMT = * )( EIN( I, J ), J = 1, N )
30 CONTINUE
*
KNT = KNT + 1
CALL SGEBAK( 'B', 'R', N, ILO, IHI, SCALE, N, E, LDE, INFO )
*
IF( INFO.NE.0 ) THEN
NINFO = NINFO + 1
LMAX( 1 ) = KNT
END IF
*
VMAX = ZERO
DO 50 I = 1, N
DO 40 J = 1, N
X = ABS( E( I, J )-EIN( I, J ) ) / EPS
IF( ABS( E( I, J ) ).GT.SAFMIN )
$ X = X / ABS( E( I, J ) )
VMAX = MAX( VMAX, X )
40 CONTINUE
50 CONTINUE
*
IF( VMAX.GT.RMAX ) THEN
LMAX( 2 ) = KNT
RMAX = VMAX
END IF
*
GO TO 10
*
60 CONTINUE
*
WRITE( NOUT, FMT = 9999 )
9999 FORMAT( 1X, '.. test output of SGEBAK .. ' )
*
WRITE( NOUT, FMT = 9998 )RMAX
9998 FORMAT( 1X, 'value of largest test error = ', E12.3 )
WRITE( NOUT, FMT = 9997 )LMAX( 1 )
9997 FORMAT( 1X, 'example number where info is not zero = ', I4 )
WRITE( NOUT, FMT = 9996 )LMAX( 2 )
9996 FORMAT( 1X, 'example number having largest error = ', I4 )
WRITE( NOUT, FMT = 9995 )NINFO
9995 FORMAT( 1X, 'number of examples where info is not 0 = ', I4 )
WRITE( NOUT, FMT = 9994 )KNT
9994 FORMAT( 1X, 'total number of examples tested = ', I4 )
*
RETURN
*
* End of SCHKBK
*
END
SUBROUTINE SCHKBL( NIN, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER NIN, NOUT
* ..
*
* Purpose
* =======
*
* SCHKBL tests SGEBAL, a routine for balancing a general real
* matrix and isolating some of its eigenvalues.
*
* Arguments
* =========
*
* NIN (input) INTEGER
* The logical unit number for input. NIN > 0.
*
* NOUT (input) INTEGER
* The logical unit number for output. NOUT > 0.
*
* ======================================================================
*
* .. Parameters ..
INTEGER LDA
PARAMETER ( LDA = 20 )
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, IHI, IHIIN, ILO, ILOIN, INFO, J, KNT, N,
$ NINFO
REAL ANORM, MEPS, RMAX, SFMIN, TEMP, VMAX
* ..
* .. Local Arrays ..
INTEGER LMAX( 3 )
REAL A( LDA, LDA ), AIN( LDA, LDA ), DUMMY( 1 ),
$ SCALE( LDA ), SCALIN( LDA )
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE
EXTERNAL SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SGEBAL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
LMAX( 1 ) = 0
LMAX( 2 ) = 0
LMAX( 3 ) = 0
NINFO = 0
KNT = 0
RMAX = ZERO
VMAX = ZERO
SFMIN = SLAMCH( 'S' )
MEPS = SLAMCH( 'E' )
*
10 CONTINUE
*
READ( NIN, FMT = * )N
IF( N.EQ.0 )
$ GO TO 70
DO 20 I = 1, N
READ( NIN, FMT = * )( A( I, J ), J = 1, N )
20 CONTINUE
*
READ( NIN, FMT = * )ILOIN, IHIIN
DO 30 I = 1, N
READ( NIN, FMT = * )( AIN( I, J ), J = 1, N )
30 CONTINUE
READ( NIN, FMT = * )( SCALIN( I ), I = 1, N )
*
ANORM = SLANGE( 'M', N, N, A, LDA, DUMMY )
KNT = KNT + 1
*
CALL SGEBAL( 'B', N, A, LDA, ILO, IHI, SCALE, INFO )
*
IF( INFO.NE.0 ) THEN
NINFO = NINFO + 1
LMAX( 1 ) = KNT
END IF
*
IF( ILO.NE.ILOIN .OR. IHI.NE.IHIIN ) THEN
NINFO = NINFO + 1
LMAX( 2 ) = KNT
END IF
*
DO 50 I = 1, N
DO 40 J = 1, N
TEMP = MAX( A( I, J ), AIN( I, J ) )
TEMP = MAX( TEMP, SFMIN )
VMAX = MAX( VMAX, ABS( A( I, J )-AIN( I, J ) ) / TEMP )
40 CONTINUE
50 CONTINUE
*
DO 60 I = 1, N
TEMP = MAX( SCALE( I ), SCALIN( I ) )
TEMP = MAX( TEMP, SFMIN )
VMAX = MAX( VMAX, ABS( SCALE( I )-SCALIN( I ) ) / TEMP )
60 CONTINUE
*
*
IF( VMAX.GT.RMAX ) THEN
LMAX( 3 ) = KNT
RMAX = VMAX
END IF
*
GO TO 10
*
70 CONTINUE
*
WRITE( NOUT, FMT = 9999 )
9999 FORMAT( 1X, '.. test output of SGEBAL .. ' )
*
WRITE( NOUT, FMT = 9998 )RMAX
9998 FORMAT( 1X, 'value of largest test error = ', E12.3 )
WRITE( NOUT, FMT = 9997 )LMAX( 1 )
9997 FORMAT( 1X, 'example number where info is not zero = ', I4 )
WRITE( NOUT, FMT = 9996 )LMAX( 2 )
9996 FORMAT( 1X, 'example number where ILO or IHI wrong = ', I4 )
WRITE( NOUT, FMT = 9995 )LMAX( 3 )
9995 FORMAT( 1X, 'example number having largest error = ', I4 )
WRITE( NOUT, FMT = 9994 )NINFO
9994 FORMAT( 1X, 'number of examples where info is not 0 = ', I4 )
WRITE( NOUT, FMT = 9993 )KNT
9993 FORMAT( 1X, 'total number of examples tested = ', I4 )
*
RETURN
*
* End of SCHKBL
*
END
SUBROUTINE SCHKEC( THRESH, TSTERR, NIN, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NIN, NOUT
REAL THRESH
* ..
*
* Purpose
* =======
*
* SCHKEC tests eigen- condition estimation routines
* SLALN2, SLASY2, SLANV2, SLAQTR, SLAEXC,
* STRSYL, STREXC, STRSNA, STRSEN
*
* In all cases, the routine runs through a fixed set of numerical
* examples, subjects them to various tests, and compares the test
* results to a threshold THRESH. In addition, STREXC, STRSNA and STRSEN
* are tested by reading in precomputed examples from a file (on input
* unit NIN). Output is written to output unit NOUT.
*
* Arguments
* =========
*
* THRESH (input) REAL
* Threshold for residual tests. A computed test ratio passes
* the threshold if it is less than THRESH.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NIN (input) INTEGER
* The logical unit number for input.
*
* NOUT (input) INTEGER
* The logical unit number for output.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL OK
CHARACTER*3 PATH
INTEGER KLAEXC, KLALN2, KLANV2, KLAQTR, KLASY2, KTREXC,
$ KTRSEN, KTRSNA, KTRSYL, LLAEXC, LLALN2, LLANV2,
$ LLAQTR, LLASY2, LTREXC, LTRSYL, NLANV2, NLAQTR,
$ NLASY2, NTESTS, NTRSYL
REAL EPS, RLAEXC, RLALN2, RLANV2, RLAQTR, RLASY2,
$ RTREXC, RTRSYL, SFMIN
* ..
* .. Local Arrays ..
INTEGER LTRSEN( 3 ), LTRSNA( 3 ), NLAEXC( 2 ),
$ NLALN2( 2 ), NTREXC( 3 ), NTRSEN( 3 ),
$ NTRSNA( 3 )
REAL RTRSEN( 3 ), RTRSNA( 3 )
* ..
* .. External Subroutines ..
EXTERNAL SERREC, SGET31, SGET32, SGET33, SGET34, SGET35,
$ SGET36, SGET37, SGET38, SGET39
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Executable Statements ..
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'EC'
EPS = SLAMCH( 'P' )
SFMIN = SLAMCH( 'S' )
*
* Print header information
*
WRITE( NOUT, FMT = 9989 )
WRITE( NOUT, FMT = 9988 )EPS, SFMIN
WRITE( NOUT, FMT = 9987 )THRESH
*
* Test error exits if TSTERR is .TRUE.
*
IF( TSTERR )
$ CALL SERREC( PATH, NOUT )
*
OK = .TRUE.
CALL SGET31( RLALN2, LLALN2, NLALN2, KLALN2 )
IF( RLALN2.GT.THRESH .OR. NLALN2( 1 ).NE.0 ) THEN
OK = .FALSE.
WRITE( NOUT, FMT = 9999 )RLALN2, LLALN2, NLALN2, KLALN2
END IF
*
CALL SGET32( RLASY2, LLASY2, NLASY2, KLASY2 )
IF( RLASY2.GT.THRESH ) THEN
OK = .FALSE.
WRITE( NOUT, FMT = 9998 )RLASY2, LLASY2, NLASY2, KLASY2
END IF
*
CALL SGET33( RLANV2, LLANV2, NLANV2, KLANV2 )
IF( RLANV2.GT.THRESH .OR. NLANV2.NE.0 ) THEN
OK = .FALSE.
WRITE( NOUT, FMT = 9997 )RLANV2, LLANV2, NLANV2, KLANV2
END IF
*
CALL SGET34( RLAEXC, LLAEXC, NLAEXC, KLAEXC )
IF( RLAEXC.GT.THRESH .OR. NLAEXC( 2 ).NE.0 ) THEN
OK = .FALSE.
WRITE( NOUT, FMT = 9996 )RLAEXC, LLAEXC, NLAEXC, KLAEXC
END IF
*
CALL SGET35( RTRSYL, LTRSYL, NTRSYL, KTRSYL )
IF( RTRSYL.GT.THRESH ) THEN
OK = .FALSE.
WRITE( NOUT, FMT = 9995 )RTRSYL, LTRSYL, NTRSYL, KTRSYL
END IF
*
CALL SGET36( RTREXC, LTREXC, NTREXC, KTREXC, NIN )
IF( RTREXC.GT.THRESH .OR. NTREXC( 3 ).GT.0 ) THEN
OK = .FALSE.
WRITE( NOUT, FMT = 9994 )RTREXC, LTREXC, NTREXC, KTREXC
END IF
*
CALL SGET37( RTRSNA, LTRSNA, NTRSNA, KTRSNA, NIN )
IF( RTRSNA( 1 ).GT.THRESH .OR. RTRSNA( 2 ).GT.THRESH .OR.
$ NTRSNA( 1 ).NE.0 .OR. NTRSNA( 2 ).NE.0 .OR. NTRSNA( 3 ).NE.0 )
$ THEN
OK = .FALSE.
WRITE( NOUT, FMT = 9993 )RTRSNA, LTRSNA, NTRSNA, KTRSNA
END IF
*
CALL SGET38( RTRSEN, LTRSEN, NTRSEN, KTRSEN, NIN )
IF( RTRSEN( 1 ).GT.THRESH .OR. RTRSEN( 2 ).GT.THRESH .OR.
$ NTRSEN( 1 ).NE.0 .OR. NTRSEN( 2 ).NE.0 .OR. NTRSEN( 3 ).NE.0 )
$ THEN
OK = .FALSE.
WRITE( NOUT, FMT = 9992 )RTRSEN, LTRSEN, NTRSEN, KTRSEN
END IF
*
CALL SGET39( RLAQTR, LLAQTR, NLAQTR, KLAQTR )
IF( RLAQTR.GT.THRESH ) THEN
OK = .FALSE.
WRITE( NOUT, FMT = 9991 )RLAQTR, LLAQTR, NLAQTR, KLAQTR
END IF
*
NTESTS = KLALN2 + KLASY2 + KLANV2 + KLAEXC + KTRSYL + KTREXC +
$ KTRSNA + KTRSEN + KLAQTR
IF( OK )
$ WRITE( NOUT, FMT = 9990 )PATH, NTESTS
*
RETURN
9999 FORMAT( ' Error in SLALN2: RMAX =', E12.3, / ' LMAX = ', I8, ' N',
$ 'INFO=', 2I8, ' KNT=', I8 )
9998 FORMAT( ' Error in SLASY2: RMAX =', E12.3, / ' LMAX = ', I8, ' N',
$ 'INFO=', I8, ' KNT=', I8 )
9997 FORMAT( ' Error in SLANV2: RMAX =', E12.3, / ' LMAX = ', I8, ' N',
$ 'INFO=', I8, ' KNT=', I8 )
9996 FORMAT( ' Error in SLAEXC: RMAX =', E12.3, / ' LMAX = ', I8, ' N',
$ 'INFO=', 2I8, ' KNT=', I8 )
9995 FORMAT( ' Error in STRSYL: RMAX =', E12.3, / ' LMAX = ', I8, ' N',
$ 'INFO=', I8, ' KNT=', I8 )
9994 FORMAT( ' Error in STREXC: RMAX =', E12.3, / ' LMAX = ', I8, ' N',
$ 'INFO=', 3I8, ' KNT=', I8 )
9993 FORMAT( ' Error in STRSNA: RMAX =', 3E12.3, / ' LMAX = ', 3I8,
$ ' NINFO=', 3I8, ' KNT=', I8 )
9992 FORMAT( ' Error in STRSEN: RMAX =', 3E12.3, / ' LMAX = ', 3I8,
$ ' NINFO=', 3I8, ' KNT=', I8 )
9991 FORMAT( ' Error in SLAQTR: RMAX =', E12.3, / ' LMAX = ', I8, ' N',
$ 'INFO=', I8, ' KNT=', I8 )
9990 FORMAT( / 1X, 'All tests for ', A3, ' routines passed the thresh',
$ 'old (', I6, ' tests run)' )
9989 FORMAT( ' Tests of the Nonsymmetric eigenproblem condition estim',
$ 'ation routines', / ' SLALN2, SLASY2, SLANV2, SLAEXC, STRS',
$ 'YL, STREXC, STRSNA, STRSEN, SLAQTR', / )
9988 FORMAT( ' Relative machine precision (EPS) = ', E16.6, / ' Safe ',
$ 'minimum (SFMIN) = ', E16.6, / )
9987 FORMAT( ' Routines pass computational tests if test ratio is les',
$ 's than', F8.2, / / )
*
* End of SCHKEC
*
END
PROGRAM SCHKEE
*
* -- LAPACK test routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* February 2007
*
* Purpose
* =======
*
* SCHKEE tests the REAL LAPACK subroutines for the matrix
* eigenvalue problem. The test paths in this version are
*
* NEP (Nonsymmetric Eigenvalue Problem):
* Test SGEHRD, SORGHR, SHSEQR, STREVC, SHSEIN, and SORMHR
*
* SEP (Symmetric Eigenvalue Problem):
* Test SSYTRD, SORGTR, SSTEQR, SSTERF, SSTEIN, SSTEDC,
* and drivers SSYEV(X), SSBEV(X), SSPEV(X), SSTEV(X),
* SSYEVD, SSBEVD, SSPEVD, SSTEVD
*
* SVD (Singular Value Decomposition):
* Test SGEBRD, SORGBR, SBDSQR, SBDSDC
* and the drivers SGESVD, SGESDD
*
* SEV (Nonsymmetric Eigenvalue/eigenvector Driver):
* Test SGEEV
*
* SES (Nonsymmetric Schur form Driver):
* Test SGEES
*
* SVX (Nonsymmetric Eigenvalue/eigenvector Expert Driver):
* Test SGEEVX
*
* SSX (Nonsymmetric Schur form Expert Driver):
* Test SGEESX
*
* SGG (Generalized Nonsymmetric Eigenvalue Problem):
* Test SGGHRD, SGGBAL, SGGBAK, SHGEQZ, and STGEVC
* and the driver routines SGEGS and SGEGV
*
* SGS (Generalized Nonsymmetric Schur form Driver):
* Test SGGES
*
* SGV (Generalized Nonsymmetric Eigenvalue/eigenvector Driver):
* Test SGGEV
*
* SGX (Generalized Nonsymmetric Schur form Expert Driver):
* Test SGGESX
*
* SXV (Generalized Nonsymmetric Eigenvalue/eigenvector Expert Driver):
* Test SGGEVX
*
* SSG (Symmetric Generalized Eigenvalue Problem):
* Test SSYGST, SSYGV, SSYGVD, SSYGVX, SSPGST, SSPGV, SSPGVD,
* SSPGVX, SSBGST, SSBGV, SSBGVD, and SSBGVX
*
* SSB (Symmetric Band Eigenvalue Problem):
* Test SSBTRD
*
* SBB (Band Singular Value Decomposition):
* Test SGBBRD
*
* SEC (Eigencondition estimation):
* Test SLALN2, SLASY2, SLAEQU, SLAEXC, STRSYL, STREXC, STRSNA,
* STRSEN, and SLAQTR
*
* SBL (Balancing a general matrix)
* Test SGEBAL
*
* SBK (Back transformation on a balanced matrix)
* Test SGEBAK
*
* SGL (Balancing a matrix pair)
* Test SGGBAL
*
* SGK (Back transformation on a matrix pair)
* Test SGGBAK
*
* GLM (Generalized Linear Regression Model):
* Tests SGGGLM
*
* GQR (Generalized QR and RQ factorizations):
* Tests SGGQRF and SGGRQF
*
* GSV (Generalized Singular Value Decomposition):
* Tests SGGSVD, SGGSVP, STGSJA, SLAGS2, SLAPLL, and SLAPMT
*
* LSE (Constrained Linear Least Squares):
* Tests SGGLSE
*
* Each test path has a different set of inputs, but the data sets for
* the driver routines xEV, xES, xVX, and xSX can be concatenated in a
* single input file. The first line of input should contain one of the
* 3-character path names in columns 1-3. The number of remaining lines
* depends on what is found on the first line.
*
* The number of matrix types used in testing is often controllable from
* the input file. The number of matrix types for each path, and the
* test routine that describes them, is as follows:
*
* Path name(s) Types Test routine
*
* SHS or NEP 21 SCHKHS
* SST or SEP 21 SCHKST (routines)
* 18 SDRVST (drivers)
* SBD or SVD 16 SCHKBD (routines)
* 5 SDRVBD (drivers)
* SEV 21 SDRVEV
* SES 21 SDRVES
* SVX 21 SDRVVX
* SSX 21 SDRVSX
* SGG 26 SCHKGG (routines)
* 26 SDRVGG (drivers)
* SGS 26 SDRGES
* SGX 5 SDRGSX
* SGV 26 SDRGEV
* SXV 2 SDRGVX
* SSG 21 SDRVSG
* SSB 15 SCHKSB
* SBB 15 SCHKBB
* SEC - SCHKEC
* SBL - SCHKBL
* SBK - SCHKBK
* SGL - SCHKGL
* SGK - SCHKGK
* GLM 8 SCKGLM
* GQR 8 SCKGQR
* GSV 8 SCKGSV
* LSE 8 SCKLSE
*
*-----------------------------------------------------------------------
*
* NEP input file:
*
* line 2: NN, INTEGER
* Number of values of N.
*
* line 3: NVAL, INTEGER array, dimension (NN)
* The values for the matrix dimension N.
*
* line 4: NPARMS, INTEGER
* Number of values of the parameters NB, NBMIN, NX, NS, and
* MAXB.
*
* line 5: NBVAL, INTEGER array, dimension (NPARMS)
* The values for the blocksize NB.
*
* line 6: NBMIN, INTEGER array, dimension (NPARMS)
* The values for the minimum blocksize NBMIN.
*
* line 7: NXVAL, INTEGER array, dimension (NPARMS)
* The values for the crossover point NX.
*
* line 8: INMIN, INTEGER array, dimension (NPARMS)
* LAHQR vs TTQRE crossover point, >= 11
*
* line 9: INWIN, INTEGER array, dimension (NPARMS)
* recommended deflation window size
*
* line 10: INIBL, INTEGER array, dimension (NPARMS)
* nibble crossover point
*
* line 11: ISHFTS, INTEGER array, dimension (NPARMS)
* number of simultaneous shifts)
*
* line 12: IACC22, INTEGER array, dimension (NPARMS)
* select structured matrix multiply: 0, 1 or 2)
*
* line 13: THRESH
* Threshold value for the test ratios. Information will be
* printed about each test for which the test ratio is greater
* than or equal to the threshold. To have all of the test
* ratios printed, use THRESH = 0.0 .
*
* line 14: NEWSD, INTEGER
* A code indicating how to set the random number seed.
* = 0: Set the seed to a default value before each run
* = 1: Initialize the seed to a default value only before the
* first run
* = 2: Like 1, but use the seed values on the next line
*
* If line 14 was 2:
*
* line 15: INTEGER array, dimension (4)
* Four integer values for the random number seed.
*
* lines 15-EOF: The remaining lines occur in sets of 1 or 2 and allow
* the user to specify the matrix types. Each line contains
* a 3-character path name in columns 1-3, and the number
* of matrix types must be the first nonblank item in columns
* 4-80. If the number of matrix types is at least 1 but is
* less than the maximum number of possible types, a second
* line will be read to get the numbers of the matrix types to
* be used. For example,
* NEP 21
* requests all of the matrix types for the nonsymmetric
* eigenvalue problem, while
* NEP 4
* 9 10 11 12
* requests only matrices of type 9, 10, 11, and 12.
*
* The valid 3-character path names are 'NEP' or 'SHS' for the
* nonsymmetric eigenvalue routines.
*
*-----------------------------------------------------------------------
*
* SEP or SSG input file:
*
* line 2: NN, INTEGER
* Number of values of N.
*
* line 3: NVAL, INTEGER array, dimension (NN)
* The values for the matrix dimension N.
*
* line 4: NPARMS, INTEGER
* Number of values of the parameters NB, NBMIN, and NX.
*
* line 5: NBVAL, INTEGER array, dimension (NPARMS)
* The values for the blocksize NB.
*
* line 6: NBMIN, INTEGER array, dimension (NPARMS)
* The values for the minimum blocksize NBMIN.
*
* line 7: NXVAL, INTEGER array, dimension (NPARMS)
* The values for the crossover point NX.
*
* line 8: THRESH
* Threshold value for the test ratios. Information will be
* printed about each test for which the test ratio is greater
* than or equal to the threshold.
*
* line 9: TSTCHK, LOGICAL
* Flag indicating whether or not to test the LAPACK routines.
*
* line 10: TSTDRV, LOGICAL
* Flag indicating whether or not to test the driver routines.
*
* line 11: TSTERR, LOGICAL
* Flag indicating whether or not to test the error exits for
* the LAPACK routines and driver routines.
*
* line 12: NEWSD, INTEGER
* A code indicating how to set the random number seed.
* = 0: Set the seed to a default value before each run
* = 1: Initialize the seed to a default value only before the
* first run
* = 2: Like 1, but use the seed values on the next line
*
* If line 12 was 2:
*
* line 13: INTEGER array, dimension (4)
* Four integer values for the random number seed.
*
* lines 13-EOF: Lines specifying matrix types, as for NEP.
* The 3-character path names are 'SEP' or 'SST' for the
* symmetric eigenvalue routines and driver routines, and
* 'SSG' for the routines for the symmetric generalized
* eigenvalue problem.
*
*-----------------------------------------------------------------------
*
* SVD input file:
*
* line 2: NN, INTEGER
* Number of values of M and N.
*
* line 3: MVAL, INTEGER array, dimension (NN)
* The values for the matrix row dimension M.
*
* line 4: NVAL, INTEGER array, dimension (NN)
* The values for the matrix column dimension N.
*
* line 5: NPARMS, INTEGER
* Number of values of the parameter NB, NBMIN, NX, and NRHS.
*
* line 6: NBVAL, INTEGER array, dimension (NPARMS)
* The values for the blocksize NB.
*
* line 7: NBMIN, INTEGER array, dimension (NPARMS)
* The values for the minimum blocksize NBMIN.
*
* line 8: NXVAL, INTEGER array, dimension (NPARMS)
* The values for the crossover point NX.
*
* line 9: NSVAL, INTEGER array, dimension (NPARMS)
* The values for the number of right hand sides NRHS.
*
* line 10: THRESH
* Threshold value for the test ratios. Information will be
* printed about each test for which the test ratio is greater
* than or equal to the threshold.
*
* line 11: TSTCHK, LOGICAL
* Flag indicating whether or not to test the LAPACK routines.
*
* line 12: TSTDRV, LOGICAL
* Flag indicating whether or not to test the driver routines.
*
* line 13: TSTERR, LOGICAL
* Flag indicating whether or not to test the error exits for
* the LAPACK routines and driver routines.
*
* line 14: NEWSD, INTEGER
* A code indicating how to set the random number seed.
* = 0: Set the seed to a default value before each run
* = 1: Initialize the seed to a default value only before the
* first run
* = 2: Like 1, but use the seed values on the next line
*
* If line 14 was 2:
*
* line 15: INTEGER array, dimension (4)
* Four integer values for the random number seed.
*
* lines 15-EOF: Lines specifying matrix types, as for NEP.
* The 3-character path names are 'SVD' or 'SBD' for both the
* SVD routines and the SVD driver routines.
*
*-----------------------------------------------------------------------
*
* SEV and SES data files:
*
* line 1: 'SEV' or 'SES' in columns 1 to 3.
*
* line 2: NSIZES, INTEGER
* Number of sizes of matrices to use. Should be at least 0
* and at most 20. If NSIZES = 0, no testing is done
* (although the remaining 3 lines are still read).
*
* line 3: NN, INTEGER array, dimension(NSIZES)
* Dimensions of matrices to be tested.
*
* line 4: NB, NBMIN, NX, NS, NBCOL, INTEGERs
* These integer parameters determine how blocking is done
* (see ILAENV for details)
* NB : block size
* NBMIN : minimum block size
* NX : minimum dimension for blocking
* NS : number of shifts in xHSEQR
* NBCOL : minimum column dimension for blocking
*
* line 5: THRESH, REAL
* The test threshold against which computed residuals are
* compared. Should generally be in the range from 10. to 20.
* If it is 0., all test case data will be printed.
*
* line 6: TSTERR, LOGICAL
* Flag indicating whether or not to test the error exits.
*
* line 7: NEWSD, INTEGER
* A code indicating how to set the random number seed.
* = 0: Set the seed to a default value before each run
* = 1: Initialize the seed to a default value only before the
* first run
* = 2: Like 1, but use the seed values on the next line
*
* If line 7 was 2:
*
* line 8: INTEGER array, dimension (4)
* Four integer values for the random number seed.
*
* lines 9 and following: Lines specifying matrix types, as for NEP.
* The 3-character path name is 'SEV' to test SGEEV, or
* 'SES' to test SGEES.
*
*-----------------------------------------------------------------------
*
* The SVX data has two parts. The first part is identical to SEV,
* and the second part consists of test matrices with precomputed
* solutions.
*
* line 1: 'SVX' in columns 1-3.
*
* line 2: NSIZES, INTEGER
* If NSIZES = 0, no testing of randomly generated examples
* is done, but any precomputed examples are tested.
*
* line 3: NN, INTEGER array, dimension(NSIZES)
*
* line 4: NB, NBMIN, NX, NS, NBCOL, INTEGERs
*
* line 5: THRESH, REAL
*
* line 6: TSTERR, LOGICAL
*
* line 7: NEWSD, INTEGER
*
* If line 7 was 2:
*
* line 8: INTEGER array, dimension (4)
*
* lines 9 and following: The first line contains 'SVX' in columns 1-3
* followed by the number of matrix types, possibly with
* a second line to specify certain matrix types.
* If the number of matrix types = 0, no testing of randomly
* generated examples is done, but any precomputed examples
* are tested.
*
* remaining lines : Each matrix is stored on 1+2*N lines, where N is
* its dimension. The first line contains the dimension (a
* single integer). The next N lines contain the matrix, one
* row per line. The last N lines correspond to each
* eigenvalue. Each of these last N lines contains 4 real
* values: the real part of the eigenvalue, the imaginary
* part of the eigenvalue, the reciprocal condition number of
* the eigenvalues, and the reciprocal condition number of the
* eigenvector. The end of data is indicated by dimension N=0.
* Even if no data is to be tested, there must be at least one
* line containing N=0.
*
*-----------------------------------------------------------------------
*
* The SSX data is like SVX. The first part is identical to SEV, and the
* second part consists of test matrices with precomputed solutions.
*
* line 1: 'SSX' in columns 1-3.
*
* line 2: NSIZES, INTEGER
* If NSIZES = 0, no testing of randomly generated examples
* is done, but any precomputed examples are tested.
*
* line 3: NN, INTEGER array, dimension(NSIZES)
*
* line 4: NB, NBMIN, NX, NS, NBCOL, INTEGERs
*
* line 5: THRESH, REAL
*
* line 6: TSTERR, LOGICAL
*
* line 7: NEWSD, INTEGER
*
* If line 7 was 2:
*
* line 8: INTEGER array, dimension (4)
*
* lines 9 and following: The first line contains 'SSX' in columns 1-3
* followed by the number of matrix types, possibly with
* a second line to specify certain matrix types.
* If the number of matrix types = 0, no testing of randomly
* generated examples is done, but any precomputed examples
* are tested.
*
* remaining lines : Each matrix is stored on 3+N lines, where N is its
* dimension. The first line contains the dimension N and the
* dimension M of an invariant subspace. The second line
* contains M integers, identifying the eigenvalues in the
* invariant subspace (by their position in a list of
* eigenvalues ordered by increasing real part). The next N
* lines contain the matrix. The last line contains the
* reciprocal condition number for the average of the selected
* eigenvalues, and the reciprocal condition number for the
* corresponding right invariant subspace. The end of data is
* indicated by a line containing N=0 and M=0. Even if no data
* is to be tested, there must be at least one line containing
* N=0 and M=0.
*
*-----------------------------------------------------------------------
*
* SGG input file:
*
* line 2: NN, INTEGER
* Number of values of N.
*
* line 3: NVAL, INTEGER array, dimension (NN)
* The values for the matrix dimension N.
*
* line 4: NPARMS, INTEGER
* Number of values of the parameters NB, NBMIN, NS, MAXB, and
* NBCOL.
*
* line 5: NBVAL, INTEGER array, dimension (NPARMS)
* The values for the blocksize NB.
*
* line 6: NBMIN, INTEGER array, dimension (NPARMS)
* The values for NBMIN, the minimum row dimension for blocks.
*
* line 7: NSVAL, INTEGER array, dimension (NPARMS)
* The values for the number of shifts.
*
* line 8: MXBVAL, INTEGER array, dimension (NPARMS)
* The values for MAXB, used in determining minimum blocksize.
*
* line 9: NBCOL, INTEGER array, dimension (NPARMS)
* The values for NBCOL, the minimum column dimension for
* blocks.
*
* line 10: THRESH
* Threshold value for the test ratios. Information will be
* printed about each test for which the test ratio is greater
* than or equal to the threshold.
*
* line 11: TSTCHK, LOGICAL
* Flag indicating whether or not to test the LAPACK routines.
*
* line 12: TSTDRV, LOGICAL
* Flag indicating whether or not to test the driver routines.
*
* line 13: TSTERR, LOGICAL
* Flag indicating whether or not to test the error exits for
* the LAPACK routines and driver routines.
*
* line 14: NEWSD, INTEGER
* A code indicating how to set the random number seed.
* = 0: Set the seed to a default value before each run
* = 1: Initialize the seed to a default value only before the
* first run
* = 2: Like 1, but use the seed values on the next line
*
* If line 14 was 2:
*
* line 15: INTEGER array, dimension (4)
* Four integer values for the random number seed.
*
* lines 15-EOF: Lines specifying matrix types, as for NEP.
* The 3-character path name is 'SGG' for the generalized
* eigenvalue problem routines and driver routines.
*
*-----------------------------------------------------------------------
*
* SGS and SGV input files:
*
* line 1: 'SGS' or 'SGV' in columns 1 to 3.
*
* line 2: NN, INTEGER
* Number of values of N.
*
* line 3: NVAL, INTEGER array, dimension(NN)
* Dimensions of matrices to be tested.
*
* line 4: NB, NBMIN, NX, NS, NBCOL, INTEGERs
* These integer parameters determine how blocking is done
* (see ILAENV for details)
* NB : block size
* NBMIN : minimum block size
* NX : minimum dimension for blocking
* NS : number of shifts in xHGEQR
* NBCOL : minimum column dimension for blocking
*
* line 5: THRESH, REAL
* The test threshold against which computed residuals are
* compared. Should generally be in the range from 10. to 20.
* If it is 0., all test case data will be printed.
*
* line 6: TSTERR, LOGICAL
* Flag indicating whether or not to test the error exits.
*
* line 7: NEWSD, INTEGER
* A code indicating how to set the random number seed.
* = 0: Set the seed to a default value before each run
* = 1: Initialize the seed to a default value only before the
* first run
* = 2: Like 1, but use the seed values on the next line
*
* If line 17 was 2:
*
* line 7: INTEGER array, dimension (4)
* Four integer values for the random number seed.
*
* lines 7-EOF: Lines specifying matrix types, as for NEP.
* The 3-character path name is 'SGS' for the generalized
* eigenvalue problem routines and driver routines.
*
*-----------------------------------------------------------------------
*
* SXV input files:
*
* line 1: 'SXV' in columns 1 to 3.
*
* line 2: N, INTEGER
* Value of N.
*
* line 3: NB, NBMIN, NX, NS, NBCOL, INTEGERs
* These integer parameters determine how blocking is done
* (see ILAENV for details)
* NB : block size
* NBMIN : minimum block size
* NX : minimum dimension for blocking
* NS : number of shifts in xHGEQR
* NBCOL : minimum column dimension for blocking
*
* line 4: THRESH, REAL
* The test threshold against which computed residuals are
* compared. Should generally be in the range from 10. to 20.
* Information will be printed about each test for which the
* test ratio is greater than or equal to the threshold.
*
* line 5: TSTERR, LOGICAL
* Flag indicating whether or not to test the error exits for
* the LAPACK routines and driver routines.
*
* line 6: NEWSD, INTEGER
* A code indicating how to set the random number seed.
* = 0: Set the seed to a default value before each run
* = 1: Initialize the seed to a default value only before the
* first run
* = 2: Like 1, but use the seed values on the next line
*
* If line 6 was 2:
*
* line 7: INTEGER array, dimension (4)
* Four integer values for the random number seed.
*
* If line 2 was 0:
*
* line 7-EOF: Precomputed examples are tested.
*
* remaining lines : Each example is stored on 3+2*N lines, where N is
* its dimension. The first line contains the dimension (a
* single integer). The next N lines contain the matrix A, one
* row per line. The next N lines contain the matrix B. The
* next line contains the reciprocals of the eigenvalue
* condition numbers. The last line contains the reciprocals of
* the eigenvector condition numbers. The end of data is
* indicated by dimension N=0. Even if no data is to be tested,
* there must be at least one line containing N=0.
*
*-----------------------------------------------------------------------
*
* SGX input files:
*
* line 1: 'SGX' in columns 1 to 3.
*
* line 2: N, INTEGER
* Value of N.
*
* line 3: NB, NBMIN, NX, NS, NBCOL, INTEGERs
* These integer parameters determine how blocking is done
* (see ILAENV for details)
* NB : block size
* NBMIN : minimum block size
* NX : minimum dimension for blocking
* NS : number of shifts in xHGEQR
* NBCOL : minimum column dimension for blocking
*
* line 4: THRESH, REAL
* The test threshold against which computed residuals are
* compared. Should generally be in the range from 10. to 20.
* Information will be printed about each test for which the
* test ratio is greater than or equal to the threshold.
*
* line 5: TSTERR, LOGICAL
* Flag indicating whether or not to test the error exits for
* the LAPACK routines and driver routines.
*
* line 6: NEWSD, INTEGER
* A code indicating how to set the random number seed.
* = 0: Set the seed to a default value before each run
* = 1: Initialize the seed to a default value only before the
* first run
* = 2: Like 1, but use the seed values on the next line
*
* If line 6 was 2:
*
* line 7: INTEGER array, dimension (4)
* Four integer values for the random number seed.
*
* If line 2 was 0:
*
* line 7-EOF: Precomputed examples are tested.
*
* remaining lines : Each example is stored on 3+2*N lines, where N is
* its dimension. The first line contains the dimension (a
* single integer). The next line contains an integer k such
* that only the last k eigenvalues will be selected and appear
* in the leading diagonal blocks of $A$ and $B$. The next N
* lines contain the matrix A, one row per line. The next N
* lines contain the matrix B. The last line contains the
* reciprocal of the eigenvalue cluster condition number and the
* reciprocal of the deflating subspace (associated with the
* selected eigencluster) condition number. The end of data is
* indicated by dimension N=0. Even if no data is to be tested,
* there must be at least one line containing N=0.
*
*-----------------------------------------------------------------------
*
* SSB input file:
*
* line 2: NN, INTEGER
* Number of values of N.
*
* line 3: NVAL, INTEGER array, dimension (NN)
* The values for the matrix dimension N.
*
* line 4: NK, INTEGER
* Number of values of K.
*
* line 5: KVAL, INTEGER array, dimension (NK)
* The values for the matrix dimension K.
*
* line 6: THRESH
* Threshold value for the test ratios. Information will be
* printed about each test for which the test ratio is greater
* than or equal to the threshold.
*
* line 7: NEWSD, INTEGER
* A code indicating how to set the random number seed.
* = 0: Set the seed to a default value before each run
* = 1: Initialize the seed to a default value only before the
* first run
* = 2: Like 1, but use the seed values on the next line
*
* If line 7 was 2:
*
* line 8: INTEGER array, dimension (4)
* Four integer values for the random number seed.
*
* lines 8-EOF: Lines specifying matrix types, as for NEP.
* The 3-character path name is 'SSB'.
*
*-----------------------------------------------------------------------
*
* SBB input file:
*
* line 2: NN, INTEGER
* Number of values of M and N.
*
* line 3: MVAL, INTEGER array, dimension (NN)
* The values for the matrix row dimension M.
*
* line 4: NVAL, INTEGER array, dimension (NN)
* The values for the matrix column dimension N.
*
* line 4: NK, INTEGER
* Number of values of K.
*
* line 5: KVAL, INTEGER array, dimension (NK)
* The values for the matrix bandwidth K.
*
* line 6: NPARMS, INTEGER
* Number of values of the parameter NRHS
*
* line 7: NSVAL, INTEGER array, dimension (NPARMS)
* The values for the number of right hand sides NRHS.
*
* line 8: THRESH
* Threshold value for the test ratios. Information will be
* printed about each test for which the test ratio is greater
* than or equal to the threshold.
*
* line 9: NEWSD, INTEGER
* A code indicating how to set the random number seed.
* = 0: Set the seed to a default value before each run
* = 1: Initialize the seed to a default value only before the
* first run
* = 2: Like 1, but use the seed values on the next line
*
* If line 9 was 2:
*
* line 10: INTEGER array, dimension (4)
* Four integer values for the random number seed.
*
* lines 10-EOF: Lines specifying matrix types, as for SVD.
* The 3-character path name is 'SBB'.
*
*-----------------------------------------------------------------------
*
* SEC input file:
*
* line 2: THRESH, REAL
* Threshold value for the test ratios. Information will be
* printed about each test for which the test ratio is greater
* than or equal to the threshold.
*
* lines 3-EOF:
*
* Input for testing the eigencondition routines consists of a set of
* specially constructed test cases and their solutions. The data
* format is not intended to be modified by the user.
*
*-----------------------------------------------------------------------
*
* SBL and SBK input files:
*
* line 1: 'SBL' in columns 1-3 to test SGEBAL, or 'SBK' in
* columns 1-3 to test SGEBAK.
*
* The remaining lines consist of specially constructed test cases.
*
*-----------------------------------------------------------------------
*
* SGL and SGK input files:
*
* line 1: 'SGL' in columns 1-3 to test SGGBAL, or 'SGK' in
* columns 1-3 to test SGGBAK.
*
* The remaining lines consist of specially constructed test cases.
*
*-----------------------------------------------------------------------
*
* GLM data file:
*
* line 1: 'GLM' in columns 1 to 3.
*
* line 2: NN, INTEGER
* Number of values of M, P, and N.
*
* line 3: MVAL, INTEGER array, dimension(NN)
* Values of M (row dimension).
*
* line 4: PVAL, INTEGER array, dimension(NN)
* Values of P (row dimension).
*
* line 5: NVAL, INTEGER array, dimension(NN)
* Values of N (column dimension), note M <= N <= M+P.
*
* line 6: THRESH, REAL
* Threshold value for the test ratios. Information will be
* printed about each test for which the test ratio is greater
* than or equal to the threshold.
*
* line 7: TSTERR, LOGICAL
* Flag indicating whether or not to test the error exits for
* the LAPACK routines and driver routines.
*
* line 8: NEWSD, INTEGER
* A code indicating how to set the random number seed.
* = 0: Set the seed to a default value before each run
* = 1: Initialize the seed to a default value only before the
* first run
* = 2: Like 1, but use the seed values on the next line
*
* If line 8 was 2:
*
* line 9: INTEGER array, dimension (4)
* Four integer values for the random number seed.
*
* lines 9-EOF: Lines specifying matrix types, as for NEP.
* The 3-character path name is 'GLM' for the generalized
* linear regression model routines.
*
*-----------------------------------------------------------------------
*
* GQR data file:
*
* line 1: 'GQR' in columns 1 to 3.
*
* line 2: NN, INTEGER
* Number of values of M, P, and N.
*
* line 3: MVAL, INTEGER array, dimension(NN)
* Values of M.
*
* line 4: PVAL, INTEGER array, dimension(NN)
* Values of P.
*
* line 5: NVAL, INTEGER array, dimension(NN)
* Values of N.
*
* line 6: THRESH, REAL
* Threshold value for the test ratios. Information will be
* printed about each test for which the test ratio is greater
* than or equal to the threshold.
*
* line 7: TSTERR, LOGICAL
* Flag indicating whether or not to test the error exits for
* the LAPACK routines and driver routines.
*
* line 8: NEWSD, INTEGER
* A code indicating how to set the random number seed.
* = 0: Set the seed to a default value before each run
* = 1: Initialize the seed to a default value only before the
* first run
* = 2: Like 1, but use the seed values on the next line
*
* If line 8 was 2:
*
* line 9: INTEGER array, dimension (4)
* Four integer values for the random number seed.
*
* lines 9-EOF: Lines specifying matrix types, as for NEP.
* The 3-character path name is 'GQR' for the generalized
* QR and RQ routines.
*
*-----------------------------------------------------------------------
*
* GSV data file:
*
* line 1: 'GSV' in columns 1 to 3.
*
* line 2: NN, INTEGER
* Number of values of M, P, and N.
*
* line 3: MVAL, INTEGER array, dimension(NN)
* Values of M (row dimension).
*
* line 4: PVAL, INTEGER array, dimension(NN)
* Values of P (row dimension).
*
* line 5: NVAL, INTEGER array, dimension(NN)
* Values of N (column dimension).
*
* line 6: THRESH, REAL
* Threshold value for the test ratios. Information will be
* printed about each test for which the test ratio is greater
* than or equal to the threshold.
*
* line 7: TSTERR, LOGICAL
* Flag indicating whether or not to test the error exits for
* the LAPACK routines and driver routines.
*
* line 8: NEWSD, INTEGER
* A code indicating how to set the random number seed.
* = 0: Set the seed to a default value before each run
* = 1: Initialize the seed to a default value only before the
* first run
* = 2: Like 1, but use the seed values on the next line
*
* If line 8 was 2:
*
* line 9: INTEGER array, dimension (4)
* Four integer values for the random number seed.
*
* lines 9-EOF: Lines specifying matrix types, as for NEP.
* The 3-character path name is 'GSV' for the generalized
* SVD routines.
*
*-----------------------------------------------------------------------
*
* LSE data file:
*
* line 1: 'LSE' in columns 1 to 3.
*
* line 2: NN, INTEGER
* Number of values of M, P, and N.
*
* line 3: MVAL, INTEGER array, dimension(NN)
* Values of M.
*
* line 4: PVAL, INTEGER array, dimension(NN)
* Values of P.
*
* line 5: NVAL, INTEGER array, dimension(NN)
* Values of N, note P <= N <= P+M.
*
* line 6: THRESH, REAL
* Threshold value for the test ratios. Information will be
* printed about each test for which the test ratio is greater
* than or equal to the threshold.
*
* line 7: TSTERR, LOGICAL
* Flag indicating whether or not to test the error exits for
* the LAPACK routines and driver routines.
*
* line 8: NEWSD, INTEGER
* A code indicating how to set the random number seed.
* = 0: Set the seed to a default value before each run
* = 1: Initialize the seed to a default value only before the
* first run
* = 2: Like 1, but use the seed values on the next line
*
* If line 8 was 2:
*
* line 9: INTEGER array, dimension (4)
* Four integer values for the random number seed.
*
* lines 9-EOF: Lines specifying matrix types, as for NEP.
* The 3-character path name is 'GSV' for the generalized
* SVD routines.
*
*-----------------------------------------------------------------------
*
* NMAX is currently set to 132 and must be at least 12 for some of the
* precomputed examples, and LWORK = NMAX*(5*NMAX+5)+1 in the parameter
* statements below. For SVD, we assume NRHS may be as big as N. The
* parameter NEED is set to 14 to allow for 14 N-by-N matrices for SGG.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 132 )
INTEGER NCMAX
PARAMETER ( NCMAX = 20 )
INTEGER NEED
PARAMETER ( NEED = 14 )
INTEGER LWORK
PARAMETER ( LWORK = NMAX*( 5*NMAX+5 )+1 )
INTEGER LIWORK
PARAMETER ( LIWORK = NMAX*( 5*NMAX+20 ) )
INTEGER MAXIN
PARAMETER ( MAXIN = 20 )
INTEGER MAXT
PARAMETER ( MAXT = 30 )
INTEGER NIN, NOUT
PARAMETER ( NIN = 5, NOUT = 6 )
* ..
* .. Local Scalars ..
LOGICAL FATAL, GLM, GQR, GSV, LSE, NEP, SBB, SBK, SBL,
$ SEP, SES, SEV, SGG, SGK, SGL, SGS, SGV, SGX,
$ SSB, SSX, SVD, SVX, SXV, TSTCHK, TSTDIF,
$ TSTDRV, TSTERR
CHARACTER C1
CHARACTER*3 C3, PATH
CHARACTER*6 VNAME
CHARACTER*10 INTSTR
CHARACTER*80 LINE
INTEGER I, I1, IC, INFO, ITMP, K, LENP, MAXTYP, NEWSD,
$ NK, NN, NPARMS, NRHS, NTYPES,
$ VERS_MAJOR, VERS_MINOR, VERS_PATCH
REAL EPS, S1, S2, THRESH, THRSHN
* ..
* .. Local Arrays ..
LOGICAL DOTYPE( MAXT ), LOGWRK( NMAX )
INTEGER IOLDSD( 4 ), ISEED( 4 ), IWORK( LIWORK ),
$ KVAL( MAXIN ), MVAL( MAXIN ), MXBVAL( MAXIN ),
$ NBCOL( MAXIN ), NBMIN( MAXIN ), NBVAL( MAXIN ),
$ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ),
$ PVAL( MAXIN )
INTEGER INMIN( MAXIN ), INWIN( MAXIN ), INIBL( MAXIN ),
$ ISHFTS( MAXIN ), IACC22( MAXIN )
REAL A( NMAX*NMAX, NEED ), B( NMAX*NMAX, 5 ),
$ C( NCMAX*NCMAX, NCMAX*NCMAX ), D( NMAX, 12 ),
$ RESULT( 500 ), TAUA( NMAX ), TAUB( NMAX ),
$ WORK( LWORK ), X( 5*NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
REAL SECOND, SLAMCH
EXTERNAL LSAMEN, SECOND, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL ALAREQ, SCHKBB, SCHKBD, SCHKBK, SCHKBL, SCHKEC,
$ SCHKGG, SCHKGK, SCHKGL, SCHKHS, SCHKSB, SCHKST,
$ SCKGLM, SCKGQR, SCKGSV, SCKLSE, SDRGES, SDRGEV,
$ SDRGSX, SDRGVX, SDRVBD, SDRVES, SDRVEV, SDRVGG,
$ SDRVSG, SDRVST, SDRVSX, SDRVVX, SERRBD, SERRED,
$ SERRGG, SERRHS, SERRST, ILAVER, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC LEN, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, MAXB, NPROC, NSHIFT, NUNIT, SELDIM,
$ SELOPT
* ..
* .. Arrays in Common ..
LOGICAL SELVAL( 20 )
INTEGER IPARMS( 100 )
REAL SELWI( 20 ), SELWR( 20 )
* ..
* .. Common blocks ..
COMMON / CENVIR / NPROC, NSHIFT, MAXB
COMMON / CLAENV / IPARMS
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
COMMON / SSLCT / SELOPT, SELDIM, SELVAL, SELWR, SELWI
* ..
* .. Data statements ..
DATA INTSTR / '0123456789' /
DATA IOLDSD / 0, 0, 0, 1 /
* ..
* .. Executable Statements ..
*
S1 = SECOND( )
FATAL = .FALSE.
NUNIT = NOUT
*
* Return to here to read multiple sets of data
*
10 CONTINUE
*
* Read the first line and set the 3-character test path
*
READ( NIN, FMT = '(A80)', END = 380 )LINE
PATH = LINE( 1: 3 )
NEP = LSAMEN( 3, PATH, 'NEP' ) .OR. LSAMEN( 3, PATH, 'SHS' )
SEP = LSAMEN( 3, PATH, 'SEP' ) .OR. LSAMEN( 3, PATH, 'SST' ) .OR.
$ LSAMEN( 3, PATH, 'SSG' )
SVD = LSAMEN( 3, PATH, 'SVD' ) .OR. LSAMEN( 3, PATH, 'SBD' )
SEV = LSAMEN( 3, PATH, 'SEV' )
SES = LSAMEN( 3, PATH, 'SES' )
SVX = LSAMEN( 3, PATH, 'SVX' )
SSX = LSAMEN( 3, PATH, 'SSX' )
SGG = LSAMEN( 3, PATH, 'SGG' )
SGS = LSAMEN( 3, PATH, 'SGS' )
SGX = LSAMEN( 3, PATH, 'SGX' )
SGV = LSAMEN( 3, PATH, 'SGV' )
SXV = LSAMEN( 3, PATH, 'SXV' )
SSB = LSAMEN( 3, PATH, 'SSB' )
SBB = LSAMEN( 3, PATH, 'SBB' )
GLM = LSAMEN( 3, PATH, 'GLM' )
GQR = LSAMEN( 3, PATH, 'GQR' ) .OR. LSAMEN( 3, PATH, 'GRQ' )
GSV = LSAMEN( 3, PATH, 'GSV' )
LSE = LSAMEN( 3, PATH, 'LSE' )
SBL = LSAMEN( 3, PATH, 'SBL' )
SBK = LSAMEN( 3, PATH, 'SBK' )
SGL = LSAMEN( 3, PATH, 'SGL' )
SGK = LSAMEN( 3, PATH, 'SGK' )
*
* Report values of parameters.
*
IF( PATH.EQ.' ' ) THEN
GO TO 10
ELSE IF( NEP ) THEN
WRITE( NOUT, FMT = 9987 )
ELSE IF( SEP ) THEN
WRITE( NOUT, FMT = 9986 )
ELSE IF( SVD ) THEN
WRITE( NOUT, FMT = 9985 )
ELSE IF( SEV ) THEN
WRITE( NOUT, FMT = 9979 )
ELSE IF( SES ) THEN
WRITE( NOUT, FMT = 9978 )
ELSE IF( SVX ) THEN
WRITE( NOUT, FMT = 9977 )
ELSE IF( SSX ) THEN
WRITE( NOUT, FMT = 9976 )
ELSE IF( SGG ) THEN
WRITE( NOUT, FMT = 9975 )
ELSE IF( SGS ) THEN
WRITE( NOUT, FMT = 9964 )
ELSE IF( SGX ) THEN
WRITE( NOUT, FMT = 9965 )
ELSE IF( SGV ) THEN
WRITE( NOUT, FMT = 9963 )
ELSE IF( SXV ) THEN
WRITE( NOUT, FMT = 9962 )
ELSE IF( SSB ) THEN
WRITE( NOUT, FMT = 9974 )
ELSE IF( SBB ) THEN
WRITE( NOUT, FMT = 9967 )
ELSE IF( GLM ) THEN
WRITE( NOUT, FMT = 9971 )
ELSE IF( GQR ) THEN
WRITE( NOUT, FMT = 9970 )
ELSE IF( GSV ) THEN
WRITE( NOUT, FMT = 9969 )
ELSE IF( LSE ) THEN
WRITE( NOUT, FMT = 9968 )
ELSE IF( SBL ) THEN
*
* SGEBAL: Balancing
*
CALL SCHKBL( NIN, NOUT )
GO TO 10
ELSE IF( SBK ) THEN
*
* SGEBAK: Back transformation
*
CALL SCHKBK( NIN, NOUT )
GO TO 10
ELSE IF( SGL ) THEN
*
* SGGBAL: Balancing
*
CALL SCHKGL( NIN, NOUT )
GO TO 10
ELSE IF( SGK ) THEN
*
* SGGBAK: Back transformation
*
CALL SCHKGK( NIN, NOUT )
GO TO 10
ELSE IF( LSAMEN( 3, PATH, 'SEC' ) ) THEN
*
* SEC: Eigencondition estimation
*
READ( NIN, FMT = * )THRESH
CALL XLAENV( 1, 1 )
CALL XLAENV( 12, 11 )
CALL XLAENV( 13, 2 )
CALL XLAENV( 14, 0 )
CALL XLAENV( 15, 2 )
CALL XLAENV( 16, 2 )
TSTERR = .TRUE.
CALL SCHKEC( THRESH, TSTERR, NIN, NOUT )
GO TO 10
ELSE
WRITE( NOUT, FMT = 9992 )PATH
GO TO 10
END IF
CALL ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH )
WRITE( NOUT, FMT = 9972 ) VERS_MAJOR, VERS_MINOR, VERS_PATCH
WRITE( NOUT, FMT = 9984 )
*
* Read the number of values of M, P, and N.
*
READ( NIN, FMT = * )NN
IF( NN.LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )' NN ', NN, 1
NN = 0
FATAL = .TRUE.
ELSE IF( NN.GT.MAXIN ) THEN
WRITE( NOUT, FMT = 9988 )' NN ', NN, MAXIN
NN = 0
FATAL = .TRUE.
END IF
*
* Read the values of M
*
IF( .NOT.( SGX .OR. SXV ) ) THEN
READ( NIN, FMT = * )( MVAL( I ), I = 1, NN )
IF( SVD ) THEN
VNAME = ' M '
ELSE
VNAME = ' N '
END IF
DO 20 I = 1, NN
IF( MVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )VNAME, MVAL( I ), 0
FATAL = .TRUE.
ELSE IF( MVAL( I ).GT.NMAX ) THEN
WRITE( NOUT, FMT = 9988 )VNAME, MVAL( I ), NMAX
FATAL = .TRUE.
END IF
20 CONTINUE
WRITE( NOUT, FMT = 9983 )'M: ', ( MVAL( I ), I = 1, NN )
END IF
*
* Read the values of P
*
IF( GLM .OR. GQR .OR. GSV .OR. LSE ) THEN
READ( NIN, FMT = * )( PVAL( I ), I = 1, NN )
DO 30 I = 1, NN
IF( PVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )' P ', PVAL( I ), 0
FATAL = .TRUE.
ELSE IF( PVAL( I ).GT.NMAX ) THEN
WRITE( NOUT, FMT = 9988 )' P ', PVAL( I ), NMAX
FATAL = .TRUE.
END IF
30 CONTINUE
WRITE( NOUT, FMT = 9983 )'P: ', ( PVAL( I ), I = 1, NN )
END IF
*
* Read the values of N
*
IF( SVD .OR. SBB .OR. GLM .OR. GQR .OR. GSV .OR. LSE ) THEN
READ( NIN, FMT = * )( NVAL( I ), I = 1, NN )
DO 40 I = 1, NN
IF( NVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )' N ', NVAL( I ), 0
FATAL = .TRUE.
ELSE IF( NVAL( I ).GT.NMAX ) THEN
WRITE( NOUT, FMT = 9988 )' N ', NVAL( I ), NMAX
FATAL = .TRUE.
END IF
40 CONTINUE
ELSE
DO 50 I = 1, NN
NVAL( I ) = MVAL( I )
50 CONTINUE
END IF
IF( .NOT.( SGX .OR. SXV ) ) THEN
WRITE( NOUT, FMT = 9983 )'N: ', ( NVAL( I ), I = 1, NN )
ELSE
WRITE( NOUT, FMT = 9983 )'N: ', NN
END IF
*
* Read the number of values of K, followed by the values of K
*
IF( SSB .OR. SBB ) THEN
READ( NIN, FMT = * )NK
READ( NIN, FMT = * )( KVAL( I ), I = 1, NK )
DO 60 I = 1, NK
IF( KVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )' K ', KVAL( I ), 0
FATAL = .TRUE.
ELSE IF( KVAL( I ).GT.NMAX ) THEN
WRITE( NOUT, FMT = 9988 )' K ', KVAL( I ), NMAX
FATAL = .TRUE.
END IF
60 CONTINUE
WRITE( NOUT, FMT = 9983 )'K: ', ( KVAL( I ), I = 1, NK )
END IF
*
IF( SEV .OR. SES .OR. SVX .OR. SSX ) THEN
*
* For the nonsymmetric QR driver routines, only one set of
* parameters is allowed.
*
READ( NIN, FMT = * )NBVAL( 1 ), NBMIN( 1 ), NXVAL( 1 ),
$ INMIN( 1 ), INWIN( 1 ), INIBL(1), ISHFTS(1), IACC22(1)
IF( NBVAL( 1 ).LT.1 ) THEN
WRITE( NOUT, FMT = 9989 )' NB ', NBVAL( 1 ), 1
FATAL = .TRUE.
ELSE IF( NBMIN( 1 ).LT.1 ) THEN
WRITE( NOUT, FMT = 9989 )'NBMIN ', NBMIN( 1 ), 1
FATAL = .TRUE.
ELSE IF( NXVAL( 1 ).LT.1 ) THEN
WRITE( NOUT, FMT = 9989 )' NX ', NXVAL( 1 ), 1
FATAL = .TRUE.
ELSE IF( INMIN( 1 ).LT.1 ) THEN
WRITE( NOUT, FMT = 9989 )' INMIN ', INMIN( 1 ), 1
FATAL = .TRUE.
ELSE IF( INWIN( 1 ).LT.1 ) THEN
WRITE( NOUT, FMT = 9989 )' INWIN ', INWIN( 1 ), 1
FATAL = .TRUE.
ELSE IF( INIBL( 1 ).LT.1 ) THEN
WRITE( NOUT, FMT = 9989 )' INIBL ', INIBL( 1 ), 1
FATAL = .TRUE.
ELSE IF( ISHFTS( 1 ).LT.1 ) THEN
WRITE( NOUT, FMT = 9989 )' ISHFTS ', ISHFTS( 1 ), 1
FATAL = .TRUE.
ELSE IF( IACC22( 1 ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )' IACC22 ', IACC22( 1 ), 0
FATAL = .TRUE.
END IF
CALL XLAENV( 1, NBVAL( 1 ) )
CALL XLAENV( 2, NBMIN( 1 ) )
CALL XLAENV( 3, NXVAL( 1 ) )
CALL XLAENV(12, MAX( 11, INMIN( 1 ) ) )
CALL XLAENV(13, INWIN( 1 ) )
CALL XLAENV(14, INIBL( 1 ) )
CALL XLAENV(15, ISHFTS( 1 ) )
CALL XLAENV(16, IACC22( 1 ) )
WRITE( NOUT, FMT = 9983 )'NB: ', NBVAL( 1 )
WRITE( NOUT, FMT = 9983 )'NBMIN:', NBMIN( 1 )
WRITE( NOUT, FMT = 9983 )'NX: ', NXVAL( 1 )
WRITE( NOUT, FMT = 9983 )'INMIN: ', INMIN( 1 )
WRITE( NOUT, FMT = 9983 )'INWIN: ', INWIN( 1 )
WRITE( NOUT, FMT = 9983 )'INIBL: ', INIBL( 1 )
WRITE( NOUT, FMT = 9983 )'ISHFTS: ', ISHFTS( 1 )
WRITE( NOUT, FMT = 9983 )'IACC22: ', IACC22( 1 )
*
ELSE IF( SGS .OR. SGX .OR. SGV .OR. SXV ) THEN
*
* For the nonsymmetric generalized driver routines, only one set
* of parameters is allowed.
*
READ( NIN, FMT = * )NBVAL( 1 ), NBMIN( 1 ), NXVAL( 1 ),
$ NSVAL( 1 ), MXBVAL( 1 )
IF( NBVAL( 1 ).LT.1 ) THEN
WRITE( NOUT, FMT = 9989 )' NB ', NBVAL( 1 ), 1
FATAL = .TRUE.
ELSE IF( NBMIN( 1 ).LT.1 ) THEN
WRITE( NOUT, FMT = 9989 )'NBMIN ', NBMIN( 1 ), 1
FATAL = .TRUE.
ELSE IF( NXVAL( 1 ).LT.1 ) THEN
WRITE( NOUT, FMT = 9989 )' NX ', NXVAL( 1 ), 1
FATAL = .TRUE.
ELSE IF( NSVAL( 1 ).LT.2 ) THEN
WRITE( NOUT, FMT = 9989 )' NS ', NSVAL( 1 ), 2
FATAL = .TRUE.
ELSE IF( MXBVAL( 1 ).LT.1 ) THEN
WRITE( NOUT, FMT = 9989 )' MAXB ', MXBVAL( 1 ), 1
FATAL = .TRUE.
END IF
CALL XLAENV( 1, NBVAL( 1 ) )
CALL XLAENV( 2, NBMIN( 1 ) )
CALL XLAENV( 3, NXVAL( 1 ) )
CALL XLAENV( 4, NSVAL( 1 ) )
CALL XLAENV( 8, MXBVAL( 1 ) )
WRITE( NOUT, FMT = 9983 )'NB: ', NBVAL( 1 )
WRITE( NOUT, FMT = 9983 )'NBMIN:', NBMIN( 1 )
WRITE( NOUT, FMT = 9983 )'NX: ', NXVAL( 1 )
WRITE( NOUT, FMT = 9983 )'NS: ', NSVAL( 1 )
WRITE( NOUT, FMT = 9983 )'MAXB: ', MXBVAL( 1 )
*
ELSE IF( .NOT.SSB .AND. .NOT.GLM .AND. .NOT.GQR .AND. .NOT.
$ GSV .AND. .NOT.LSE ) THEN
*
* For the other paths, the number of parameters can be varied
* from the input file. Read the number of parameter values.
*
READ( NIN, FMT = * )NPARMS
IF( NPARMS.LT.1 ) THEN
WRITE( NOUT, FMT = 9989 )'NPARMS', NPARMS, 1
NPARMS = 0
FATAL = .TRUE.
ELSE IF( NPARMS.GT.MAXIN ) THEN
WRITE( NOUT, FMT = 9988 )'NPARMS', NPARMS, MAXIN
NPARMS = 0
FATAL = .TRUE.
END IF
*
* Read the values of NB
*
IF( .NOT.SBB ) THEN
READ( NIN, FMT = * )( NBVAL( I ), I = 1, NPARMS )
DO 70 I = 1, NPARMS
IF( NBVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )' NB ', NBVAL( I ), 0
FATAL = .TRUE.
ELSE IF( NBVAL( I ).GT.NMAX ) THEN
WRITE( NOUT, FMT = 9988 )' NB ', NBVAL( I ), NMAX
FATAL = .TRUE.
END IF
70 CONTINUE
WRITE( NOUT, FMT = 9983 )'NB: ',
$ ( NBVAL( I ), I = 1, NPARMS )
END IF
*
* Read the values of NBMIN
*
IF( NEP .OR. SEP .OR. SVD .OR. SGG ) THEN
READ( NIN, FMT = * )( NBMIN( I ), I = 1, NPARMS )
DO 80 I = 1, NPARMS
IF( NBMIN( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )'NBMIN ', NBMIN( I ), 0
FATAL = .TRUE.
ELSE IF( NBMIN( I ).GT.NMAX ) THEN
WRITE( NOUT, FMT = 9988 )'NBMIN ', NBMIN( I ), NMAX
FATAL = .TRUE.
END IF
80 CONTINUE
WRITE( NOUT, FMT = 9983 )'NBMIN:',
$ ( NBMIN( I ), I = 1, NPARMS )
ELSE
DO 90 I = 1, NPARMS
NBMIN( I ) = 1
90 CONTINUE
END IF
*
* Read the values of NX
*
IF( NEP .OR. SEP .OR. SVD ) THEN
READ( NIN, FMT = * )( NXVAL( I ), I = 1, NPARMS )
DO 100 I = 1, NPARMS
IF( NXVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )' NX ', NXVAL( I ), 0
FATAL = .TRUE.
ELSE IF( NXVAL( I ).GT.NMAX ) THEN
WRITE( NOUT, FMT = 9988 )' NX ', NXVAL( I ), NMAX
FATAL = .TRUE.
END IF
100 CONTINUE
WRITE( NOUT, FMT = 9983 )'NX: ',
$ ( NXVAL( I ), I = 1, NPARMS )
ELSE
DO 110 I = 1, NPARMS
NXVAL( I ) = 1
110 CONTINUE
END IF
*
* Read the values of NSHIFT (if SGG) or NRHS (if SVD
* or SBB).
*
IF( SVD .OR. SBB .OR. SGG ) THEN
READ( NIN, FMT = * )( NSVAL( I ), I = 1, NPARMS )
DO 120 I = 1, NPARMS
IF( NSVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )' NS ', NSVAL( I ), 0
FATAL = .TRUE.
ELSE IF( NSVAL( I ).GT.NMAX ) THEN
WRITE( NOUT, FMT = 9988 )' NS ', NSVAL( I ), NMAX
FATAL = .TRUE.
END IF
120 CONTINUE
WRITE( NOUT, FMT = 9983 )'NS: ',
$ ( NSVAL( I ), I = 1, NPARMS )
ELSE
DO 130 I = 1, NPARMS
NSVAL( I ) = 1
130 CONTINUE
END IF
*
* Read the values for MAXB.
*
IF( SGG ) THEN
READ( NIN, FMT = * )( MXBVAL( I ), I = 1, NPARMS )
DO 140 I = 1, NPARMS
IF( MXBVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )' MAXB ', MXBVAL( I ), 0
FATAL = .TRUE.
ELSE IF( MXBVAL( I ).GT.NMAX ) THEN
WRITE( NOUT, FMT = 9988 )' MAXB ', MXBVAL( I ), NMAX
FATAL = .TRUE.
END IF
140 CONTINUE
WRITE( NOUT, FMT = 9983 )'MAXB: ',
$ ( MXBVAL( I ), I = 1, NPARMS )
ELSE
DO 150 I = 1, NPARMS
MXBVAL( I ) = 1
150 CONTINUE
END IF
*
* Read the values for INMIN.
*
IF( NEP ) THEN
READ( NIN, FMT = * )( INMIN( I ), I = 1, NPARMS )
DO 540 I = 1, NPARMS
IF( INMIN( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )' INMIN ', INMIN( I ), 0
FATAL = .TRUE.
END IF
540 CONTINUE
WRITE( NOUT, FMT = 9983 )'INMIN: ',
$ ( INMIN( I ), I = 1, NPARMS )
ELSE
DO 550 I = 1, NPARMS
INMIN( I ) = 1
550 CONTINUE
END IF
*
* Read the values for INWIN.
*
IF( NEP ) THEN
READ( NIN, FMT = * )( INWIN( I ), I = 1, NPARMS )
DO 560 I = 1, NPARMS
IF( INWIN( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )' INWIN ', INWIN( I ), 0
FATAL = .TRUE.
END IF
560 CONTINUE
WRITE( NOUT, FMT = 9983 )'INWIN: ',
$ ( INWIN( I ), I = 1, NPARMS )
ELSE
DO 570 I = 1, NPARMS
INWIN( I ) = 1
570 CONTINUE
END IF
*
* Read the values for INIBL.
*
IF( NEP ) THEN
READ( NIN, FMT = * )( INIBL( I ), I = 1, NPARMS )
DO 580 I = 1, NPARMS
IF( INIBL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )' INIBL ', INIBL( I ), 0
FATAL = .TRUE.
END IF
580 CONTINUE
WRITE( NOUT, FMT = 9983 )'INIBL: ',
$ ( INIBL( I ), I = 1, NPARMS )
ELSE
DO 590 I = 1, NPARMS
INIBL( I ) = 1
590 CONTINUE
END IF
*
* Read the values for ISHFTS.
*
IF( NEP ) THEN
READ( NIN, FMT = * )( ISHFTS( I ), I = 1, NPARMS )
DO 600 I = 1, NPARMS
IF( ISHFTS( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )' ISHFTS ', ISHFTS( I ), 0
FATAL = .TRUE.
END IF
600 CONTINUE
WRITE( NOUT, FMT = 9983 )'ISHFTS: ',
$ ( ISHFTS( I ), I = 1, NPARMS )
ELSE
DO 610 I = 1, NPARMS
ISHFTS( I ) = 1
610 CONTINUE
END IF
*
* Read the values for IACC22.
*
IF( NEP ) THEN
READ( NIN, FMT = * )( IACC22( I ), I = 1, NPARMS )
DO 620 I = 1, NPARMS
IF( IACC22( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )' IACC22 ', IACC22( I ), 0
FATAL = .TRUE.
END IF
620 CONTINUE
WRITE( NOUT, FMT = 9983 )'IACC22: ',
$ ( IACC22( I ), I = 1, NPARMS )
ELSE
DO 630 I = 1, NPARMS
IACC22( I ) = 1
630 CONTINUE
END IF
*
* Read the values for NBCOL.
*
IF( SGG ) THEN
READ( NIN, FMT = * )( NBCOL( I ), I = 1, NPARMS )
DO 160 I = 1, NPARMS
IF( NBCOL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )'NBCOL ', NBCOL( I ), 0
FATAL = .TRUE.
ELSE IF( NBCOL( I ).GT.NMAX ) THEN
WRITE( NOUT, FMT = 9988 )'NBCOL ', NBCOL( I ), NMAX
FATAL = .TRUE.
END IF
160 CONTINUE
WRITE( NOUT, FMT = 9983 )'NBCOL:',
$ ( NBCOL( I ), I = 1, NPARMS )
ELSE
DO 170 I = 1, NPARMS
NBCOL( I ) = 1
170 CONTINUE
END IF
END IF
*
* Calculate and print the machine dependent constants.
*
WRITE( NOUT, FMT = * )
EPS = SLAMCH( 'Underflow threshold' )
WRITE( NOUT, FMT = 9981 )'underflow', EPS
EPS = SLAMCH( 'Overflow threshold' )
WRITE( NOUT, FMT = 9981 )'overflow ', EPS
EPS = SLAMCH( 'Epsilon' )
WRITE( NOUT, FMT = 9981 )'precision', EPS
*
* Read the threshold value for the test ratios.
*
READ( NIN, FMT = * )THRESH
WRITE( NOUT, FMT = 9982 )THRESH
IF( SEP .OR. SVD .OR. SGG ) THEN
*
* Read the flag that indicates whether to test LAPACK routines.
*
READ( NIN, FMT = * )TSTCHK
*
* Read the flag that indicates whether to test driver routines.
*
READ( NIN, FMT = * )TSTDRV
END IF
*
* Read the flag that indicates whether to test the error exits.
*
READ( NIN, FMT = * )TSTERR
*
* Read the code describing how to set the random number seed.
*
READ( NIN, FMT = * )NEWSD
*
* If NEWSD = 2, read another line with 4 integers for the seed.
*
IF( NEWSD.EQ.2 )
$ READ( NIN, FMT = * )( IOLDSD( I ), I = 1, 4 )
*
DO 180 I = 1, 4
ISEED( I ) = IOLDSD( I )
180 CONTINUE
*
IF( FATAL ) THEN
WRITE( NOUT, FMT = 9999 )
STOP
END IF
*
* Read the input lines indicating the test path and its parameters.
* The first three characters indicate the test path, and the number
* of test matrix types must be the first nonblank item in columns
* 4-80.
*
190 CONTINUE
*
IF( .NOT.( SGX .OR. SXV ) ) THEN
*
200 CONTINUE
READ( NIN, FMT = '(A80)', END = 380 )LINE
C3 = LINE( 1: 3 )
LENP = LEN( LINE )
I = 3
ITMP = 0
I1 = 0
210 CONTINUE
I = I + 1
IF( I.GT.LENP ) THEN
IF( I1.GT.0 ) THEN
GO TO 240
ELSE
NTYPES = MAXT
GO TO 240
END IF
END IF
IF( LINE( I: I ).NE.' ' .AND. LINE( I: I ).NE.',' ) THEN
I1 = I
C1 = LINE( I1: I1 )
*
* Check that a valid integer was read
*
DO 220 K = 1, 10
IF( C1.EQ.INTSTR( K: K ) ) THEN
IC = K - 1
GO TO 230
END IF
220 CONTINUE
WRITE( NOUT, FMT = 9991 )I, LINE
GO TO 200
230 CONTINUE
ITMP = 10*ITMP + IC
GO TO 210
ELSE IF( I1.GT.0 ) THEN
GO TO 240
ELSE
GO TO 210
END IF
240 CONTINUE
NTYPES = ITMP
*
* Skip the tests if NTYPES is <= 0.
*
IF( .NOT.( SEV .OR. SES .OR. SVX .OR. SSX .OR. SGV .OR.
$ SGS ) .AND. NTYPES.LE.0 ) THEN
WRITE( NOUT, FMT = 9990 )C3
GO TO 200
END IF
*
ELSE
IF( SXV )
$ C3 = 'SXV'
IF( SGX )
$ C3 = 'SGX'
END IF
*
* Reset the random number seed.
*
IF( NEWSD.EQ.0 ) THEN
DO 250 K = 1, 4
ISEED( K ) = IOLDSD( K )
250 CONTINUE
END IF
*
IF( LSAMEN( 3, C3, 'SHS' ) .OR. LSAMEN( 3, C3, 'NEP' ) ) THEN
*
* -------------------------------------
* NEP: Nonsymmetric Eigenvalue Problem
* -------------------------------------
* Vary the parameters
* NB = block size
* NBMIN = minimum block size
* NX = crossover point
* NS = number of shifts
* MAXB = minimum submatrix size
*
MAXTYP = 21
NTYPES = MIN( MAXTYP, NTYPES )
CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
CALL XLAENV( 1, 1 )
IF( TSTERR )
$ CALL SERRHS( 'SHSEQR', NOUT )
DO 270 I = 1, NPARMS
CALL XLAENV( 1, NBVAL( I ) )
CALL XLAENV( 2, NBMIN( I ) )
CALL XLAENV( 3, NXVAL( I ) )
CALL XLAENV(12, MAX( 11, INMIN( I ) ) )
CALL XLAENV(13, INWIN( I ) )
CALL XLAENV(14, INIBL( I ) )
CALL XLAENV(15, ISHFTS( I ) )
CALL XLAENV(16, IACC22( I ) )
*
IF( NEWSD.EQ.0 ) THEN
DO 260 K = 1, 4
ISEED( K ) = IOLDSD( K )
260 CONTINUE
END IF
WRITE( NOUT, FMT = 9961 )C3, NBVAL( I ), NBMIN( I ),
$ NXVAL( I ), MAX( 11, INMIN(I)),
$ INWIN( I ), INIBL( I ), ISHFTS( I ), IACC22( I )
CALL SCHKHS( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, NOUT,
$ A( 1, 1 ), NMAX, A( 1, 2 ), A( 1, 3 ),
$ A( 1, 4 ), A( 1, 5 ), NMAX, A( 1, 6 ),
$ A( 1, 7 ), D( 1, 1 ), D( 1, 2 ), D( 1, 3 ),
$ D( 1, 4 ), A( 1, 8 ), A( 1, 9 ), A( 1, 10 ),
$ A( 1, 11 ), A( 1, 12 ), D( 1, 5 ), WORK, LWORK,
$ IWORK, LOGWRK, RESULT, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'SCHKHS', INFO
270 CONTINUE
*
ELSE IF( LSAMEN( 3, C3, 'SST' ) .OR. LSAMEN( 3, C3, 'SEP' ) ) THEN
*
* ----------------------------------
* SEP: Symmetric Eigenvalue Problem
* ----------------------------------
* Vary the parameters
* NB = block size
* NBMIN = minimum block size
* NX = crossover point
*
MAXTYP = 21
NTYPES = MIN( MAXTYP, NTYPES )
CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
CALL XLAENV( 1, 1 )
CALL XLAENV( 9, 25 )
IF( TSTERR )
$ CALL SERRST( 'SST', NOUT )
DO 290 I = 1, NPARMS
CALL XLAENV( 1, NBVAL( I ) )
CALL XLAENV( 2, NBMIN( I ) )
CALL XLAENV( 3, NXVAL( I ) )
*
IF( NEWSD.EQ.0 ) THEN
DO 280 K = 1, 4
ISEED( K ) = IOLDSD( K )
280 CONTINUE
END IF
WRITE( NOUT, FMT = 9997 )C3, NBVAL( I ), NBMIN( I ),
$ NXVAL( I )
IF( TSTCHK ) THEN
CALL SCHKST( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH,
$ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), D( 1, 1 ),
$ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), D( 1, 5 ),
$ D( 1, 6 ), D( 1, 7 ), D( 1, 8 ), D( 1, 9 ),
$ D( 1, 10 ), D( 1, 11 ), A( 1, 3 ), NMAX,
$ A( 1, 4 ), A( 1, 5 ), D( 1, 12 ), A( 1, 6 ),
$ WORK, LWORK, IWORK, LIWORK, RESULT, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'SCHKST', INFO
END IF
IF( TSTDRV ) THEN
CALL SDRVST( NN, NVAL, 18, DOTYPE, ISEED, THRESH,
$ NOUT, A( 1, 1 ), NMAX, D( 1, 3 ), D( 1, 4 ),
$ D( 1, 5 ), D( 1, 6 ), D( 1, 8 ), D( 1, 9 ),
$ D( 1, 10 ), D( 1, 11), A( 1, 2 ), NMAX,
$ A( 1, 3 ), D( 1, 12 ), A( 1, 4 ), WORK,
$ LWORK, IWORK, LIWORK, RESULT, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'SDRVST', INFO
END IF
290 CONTINUE
*
ELSE IF( LSAMEN( 3, C3, 'SSG' ) ) THEN
*
* ----------------------------------------------
* SSG: Symmetric Generalized Eigenvalue Problem
* ----------------------------------------------
* Vary the parameters
* NB = block size
* NBMIN = minimum block size
* NX = crossover point
*
MAXTYP = 21
NTYPES = MIN( MAXTYP, NTYPES )
CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
CALL XLAENV( 9, 25 )
DO 310 I = 1, NPARMS
CALL XLAENV( 1, NBVAL( I ) )
CALL XLAENV( 2, NBMIN( I ) )
CALL XLAENV( 3, NXVAL( I ) )
*
IF( NEWSD.EQ.0 ) THEN
DO 300 K = 1, 4
ISEED( K ) = IOLDSD( K )
300 CONTINUE
END IF
WRITE( NOUT, FMT = 9997 )C3, NBVAL( I ), NBMIN( I ),
$ NXVAL( I )
IF( TSTCHK ) THEN
CALL SDRVSG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH,
$ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX,
$ D( 1, 3 ), A( 1, 3 ), NMAX, A( 1, 4 ),
$ A( 1, 5 ), A( 1, 6 ), A( 1, 7 ), WORK,
$ LWORK, IWORK, LIWORK, RESULT, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'SDRVSG', INFO
END IF
310 CONTINUE
*
ELSE IF( LSAMEN( 3, C3, 'SBD' ) .OR. LSAMEN( 3, C3, 'SVD' ) ) THEN
*
* ----------------------------------
* SVD: Singular Value Decomposition
* ----------------------------------
* Vary the parameters
* NB = block size
* NBMIN = minimum block size
* NX = crossover point
* NRHS = number of right hand sides
*
MAXTYP = 16
NTYPES = MIN( MAXTYP, NTYPES )
CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
CALL XLAENV( 1, 1 )
CALL XLAENV( 9, 25 )
*
* Test the error exits
*
IF( TSTERR .AND. TSTCHK )
$ CALL SERRBD( 'SBD', NOUT )
IF( TSTERR .AND. TSTDRV )
$ CALL SERRED( 'SBD', NOUT )
*
DO 330 I = 1, NPARMS
NRHS = NSVAL( I )
CALL XLAENV( 1, NBVAL( I ) )
CALL XLAENV( 2, NBMIN( I ) )
CALL XLAENV( 3, NXVAL( I ) )
IF( NEWSD.EQ.0 ) THEN
DO 320 K = 1, 4
ISEED( K ) = IOLDSD( K )
320 CONTINUE
END IF
WRITE( NOUT, FMT = 9995 )C3, NBVAL( I ), NBMIN( I ),
$ NXVAL( I ), NRHS
IF( TSTCHK ) THEN
CALL SCHKBD( NN, MVAL, NVAL, MAXTYP, DOTYPE, NRHS, ISEED,
$ THRESH, A( 1, 1 ), NMAX, D( 1, 1 ),
$ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), A( 1, 2 ),
$ NMAX, A( 1, 3 ), A( 1, 4 ), A( 1, 5 ), NMAX,
$ A( 1, 6 ), NMAX, A( 1, 7 ), A( 1, 8 ), WORK,
$ LWORK, IWORK, NOUT, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'SCHKBD', INFO
END IF
IF( TSTDRV )
$ CALL SDRVBD( NN, MVAL, NVAL, MAXTYP, DOTYPE, ISEED,
$ THRESH, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX,
$ A( 1, 3 ), NMAX, A( 1, 4 ), A( 1, 5 ),
$ A( 1, 6 ), D( 1, 1 ), D( 1, 2 ), D( 1, 3 ),
$ WORK, LWORK, IWORK, NOUT, INFO )
330 CONTINUE
*
ELSE IF( LSAMEN( 3, C3, 'SEV' ) ) THEN
*
* --------------------------------------------
* SEV: Nonsymmetric Eigenvalue Problem Driver
* SGEEV (eigenvalues and eigenvectors)
* --------------------------------------------
*
MAXTYP = 21
NTYPES = MIN( MAXTYP, NTYPES )
IF( NTYPES.LE.0 ) THEN
WRITE( NOUT, FMT = 9990 )C3
ELSE
IF( TSTERR )
$ CALL SERRED( C3, NOUT )
CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
CALL SDRVEV( NN, NVAL, NTYPES, DOTYPE, ISEED, THRESH, NOUT,
$ A( 1, 1 ), NMAX, A( 1, 2 ), D( 1, 1 ),
$ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), A( 1, 3 ),
$ NMAX, A( 1, 4 ), NMAX, A( 1, 5 ), NMAX, RESULT,
$ WORK, LWORK, IWORK, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'SGEEV', INFO
END IF
WRITE( NOUT, FMT = 9973 )
GO TO 10
*
ELSE IF( LSAMEN( 3, C3, 'SES' ) ) THEN
*
* --------------------------------------------
* SES: Nonsymmetric Eigenvalue Problem Driver
* SGEES (Schur form)
* --------------------------------------------
*
MAXTYP = 21
NTYPES = MIN( MAXTYP, NTYPES )
IF( NTYPES.LE.0 ) THEN
WRITE( NOUT, FMT = 9990 )C3
ELSE
IF( TSTERR )
$ CALL SERRED( C3, NOUT )
CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
CALL SDRVES( NN, NVAL, NTYPES, DOTYPE, ISEED, THRESH, NOUT,
$ A( 1, 1 ), NMAX, A( 1, 2 ), A( 1, 3 ),
$ D( 1, 1 ), D( 1, 2 ), D( 1, 3 ), D( 1, 4 ),
$ A( 1, 4 ), NMAX, RESULT, WORK, LWORK, IWORK,
$ LOGWRK, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'SGEES', INFO
END IF
WRITE( NOUT, FMT = 9973 )
GO TO 10
*
ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
*
* --------------------------------------------------------------
* SVX: Nonsymmetric Eigenvalue Problem Expert Driver
* SGEEVX (eigenvalues, eigenvectors and condition numbers)
* --------------------------------------------------------------
*
MAXTYP = 21
NTYPES = MIN( MAXTYP, NTYPES )
IF( NTYPES.LT.0 ) THEN
WRITE( NOUT, FMT = 9990 )C3
ELSE
IF( TSTERR )
$ CALL SERRED( C3, NOUT )
CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
CALL SDRVVX( NN, NVAL, NTYPES, DOTYPE, ISEED, THRESH, NIN,
$ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), D( 1, 1 ),
$ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), A( 1, 3 ),
$ NMAX, A( 1, 4 ), NMAX, A( 1, 5 ), NMAX,
$ D( 1, 5 ), D( 1, 6 ), D( 1, 7 ), D( 1, 8 ),
$ D( 1, 9 ), D( 1, 10 ), D( 1, 11 ), D( 1, 12 ),
$ RESULT, WORK, LWORK, IWORK, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'SGEEVX', INFO
END IF
WRITE( NOUT, FMT = 9973 )
GO TO 10
*
ELSE IF( LSAMEN( 3, C3, 'SSX' ) ) THEN
*
* ---------------------------------------------------
* SSX: Nonsymmetric Eigenvalue Problem Expert Driver
* SGEESX (Schur form and condition numbers)
* ---------------------------------------------------
*
MAXTYP = 21
NTYPES = MIN( MAXTYP, NTYPES )
IF( NTYPES.LT.0 ) THEN
WRITE( NOUT, FMT = 9990 )C3
ELSE
IF( TSTERR )
$ CALL SERRED( C3, NOUT )
CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
CALL SDRVSX( NN, NVAL, NTYPES, DOTYPE, ISEED, THRESH, NIN,
$ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), A( 1, 3 ),
$ D( 1, 1 ), D( 1, 2 ), D( 1, 3 ), D( 1, 4 ),
$ D( 1, 5 ), D( 1, 6 ), A( 1, 4 ), NMAX,
$ A( 1, 5 ), RESULT, WORK, LWORK, IWORK, LOGWRK,
$ INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'SGEESX', INFO
END IF
WRITE( NOUT, FMT = 9973 )
GO TO 10
*
ELSE IF( LSAMEN( 3, C3, 'SGG' ) ) THEN
*
* -------------------------------------------------
* SGG: Generalized Nonsymmetric Eigenvalue Problem
* -------------------------------------------------
* Vary the parameters
* NB = block size
* NBMIN = minimum block size
* NS = number of shifts
* MAXB = minimum submatrix size
* NBCOL = minimum column dimension for blocks
*
MAXTYP = 26
NTYPES = MIN( MAXTYP, NTYPES )
CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
IF( TSTCHK .AND. TSTERR )
$ CALL SERRGG( C3, NOUT )
DO 350 I = 1, NPARMS
CALL XLAENV( 1, NBVAL( I ) )
CALL XLAENV( 2, NBMIN( I ) )
CALL XLAENV( 4, NSVAL( I ) )
CALL XLAENV( 8, MXBVAL( I ) )
CALL XLAENV( 5, NBCOL( I ) )
*
IF( NEWSD.EQ.0 ) THEN
DO 340 K = 1, 4
ISEED( K ) = IOLDSD( K )
340 CONTINUE
END IF
WRITE( NOUT, FMT = 9996 )C3, NBVAL( I ), NBMIN( I ),
$ NSVAL( I ), MXBVAL( I ), NBCOL( I )
TSTDIF = .FALSE.
THRSHN = 10.
IF( TSTCHK ) THEN
CALL SCHKGG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH,
$ TSTDIF, THRSHN, NOUT, A( 1, 1 ), NMAX,
$ A( 1, 2 ), A( 1, 3 ), A( 1, 4 ), A( 1, 5 ),
$ A( 1, 6 ), A( 1, 7 ), A( 1, 8 ), A( 1, 9 ),
$ NMAX, A( 1, 10 ), A( 1, 11 ), A( 1, 12 ),
$ D( 1, 1 ), D( 1, 2 ), D( 1, 3 ), D( 1, 4 ),
$ D( 1, 5 ), D( 1, 6 ), A( 1, 13 ),
$ A( 1, 14 ), WORK, LWORK, LOGWRK, RESULT,
$ INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'SCHKGG', INFO
END IF
CALL XLAENV( 1, 1 )
IF( TSTDRV ) THEN
CALL SDRVGG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH,
$ THRSHN, NOUT, A( 1, 1 ), NMAX, A( 1, 2 ),
$ A( 1, 3 ), A( 1, 4 ), A( 1, 5 ), A( 1, 6 ),
$ A( 1, 7 ), NMAX, A( 1, 8 ), D( 1, 1 ),
$ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), D( 1, 5 ),
$ D( 1, 6 ), A( 1, 13 ), A( 1, 14 ), WORK,
$ LWORK, RESULT, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'SDRVGG', INFO
END IF
350 CONTINUE
*
ELSE IF( LSAMEN( 3, C3, 'SGS' ) ) THEN
*
* -------------------------------------------------
* SGS: Generalized Nonsymmetric Eigenvalue Problem
* SGGES (Schur form)
* -------------------------------------------------
*
MAXTYP = 26
NTYPES = MIN( MAXTYP, NTYPES )
IF( NTYPES.LE.0 ) THEN
WRITE( NOUT, FMT = 9990 )C3
ELSE
IF( TSTERR )
$ CALL SERRGG( C3, NOUT )
CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
CALL SDRGES( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, NOUT,
$ A( 1, 1 ), NMAX, A( 1, 2 ), A( 1, 3 ),
$ A( 1, 4 ), A( 1, 7 ), NMAX, A( 1, 8 ),
$ D( 1, 1 ), D( 1, 2 ), D( 1, 3 ), WORK, LWORK,
$ RESULT, LOGWRK, INFO )
*
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'SDRGES', INFO
END IF
WRITE( NOUT, FMT = 9973 )
GO TO 10
*
ELSE IF( SGX ) THEN
*
* -------------------------------------------------
* SGX: Generalized Nonsymmetric Eigenvalue Problem
* SGGESX (Schur form and condition numbers)
* -------------------------------------------------
*
MAXTYP = 5
NTYPES = MAXTYP
IF( NN.LT.0 ) THEN
WRITE( NOUT, FMT = 9990 )C3
ELSE
IF( TSTERR )
$ CALL SERRGG( C3, NOUT )
CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
CALL XLAENV( 5, 2 )
CALL SDRGSX( NN, NCMAX, THRESH, NIN, NOUT, A( 1, 1 ), NMAX,
$ A( 1, 2 ), A( 1, 3 ), A( 1, 4 ), A( 1, 5 ),
$ A( 1, 6 ), D( 1, 1 ), D( 1, 2 ), D( 1, 3 ),
$ C( 1, 1 ), NCMAX*NCMAX, A( 1, 12 ), WORK,
$ LWORK, IWORK, LIWORK, LOGWRK, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'SDRGSX', INFO
END IF
WRITE( NOUT, FMT = 9973 )
GO TO 10
*
ELSE IF( LSAMEN( 3, C3, 'SGV' ) ) THEN
*
* -------------------------------------------------
* SGV: Generalized Nonsymmetric Eigenvalue Problem
* SGGEV (Eigenvalue/vector form)
* -------------------------------------------------
*
MAXTYP = 26
NTYPES = MIN( MAXTYP, NTYPES )
IF( NTYPES.LE.0 ) THEN
WRITE( NOUT, FMT = 9990 )C3
ELSE
IF( TSTERR )
$ CALL SERRGG( C3, NOUT )
CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
CALL SDRGEV( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, NOUT,
$ A( 1, 1 ), NMAX, A( 1, 2 ), A( 1, 3 ),
$ A( 1, 4 ), A( 1, 7 ), NMAX, A( 1, 8 ),
$ A( 1, 9 ), NMAX, D( 1, 1 ), D( 1, 2 ),
$ D( 1, 3 ), D( 1, 4 ), D( 1, 5 ), D( 1, 6 ),
$ WORK, LWORK, RESULT, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'SDRGEV', INFO
END IF
WRITE( NOUT, FMT = 9973 )
GO TO 10
*
ELSE IF( SXV ) THEN
*
* -------------------------------------------------
* SXV: Generalized Nonsymmetric Eigenvalue Problem
* SGGEVX (eigenvalue/vector with condition numbers)
* -------------------------------------------------
*
MAXTYP = 2
NTYPES = MAXTYP
IF( NN.LT.0 ) THEN
WRITE( NOUT, FMT = 9990 )C3
ELSE
IF( TSTERR )
$ CALL SERRGG( C3, NOUT )
CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
CALL SDRGVX( NN, THRESH, NIN, NOUT, A( 1, 1 ), NMAX,
$ A( 1, 2 ), A( 1, 3 ), A( 1, 4 ), D( 1, 1 ),
$ D( 1, 2 ), D( 1, 3 ), A( 1, 5 ), A( 1, 6 ),
$ IWORK( 1 ), IWORK( 2 ), D( 1, 4 ), D( 1, 5 ),
$ D( 1, 6 ), D( 1, 7 ), D( 1, 8 ), D( 1, 9 ),
$ WORK, LWORK, IWORK( 3 ), LIWORK-2, RESULT,
$ LOGWRK, INFO )
*
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'SDRGVX', INFO
END IF
WRITE( NOUT, FMT = 9973 )
GO TO 10
*
ELSE IF( LSAMEN( 3, C3, 'SSB' ) ) THEN
*
* ------------------------------
* SSB: Symmetric Band Reduction
* ------------------------------
*
MAXTYP = 15
NTYPES = MIN( MAXTYP, NTYPES )
CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
IF( TSTERR )
$ CALL SERRST( 'SSB', NOUT )
CALL SCHKSB( NN, NVAL, NK, KVAL, MAXTYP, DOTYPE, ISEED, THRESH,
$ NOUT, A( 1, 1 ), NMAX, D( 1, 1 ), D( 1, 2 ),
$ A( 1, 2 ), NMAX, WORK, LWORK, RESULT, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'SCHKSB', INFO
*
ELSE IF( LSAMEN( 3, C3, 'SBB' ) ) THEN
*
* ------------------------------
* SBB: General Band Reduction
* ------------------------------
*
MAXTYP = 15
NTYPES = MIN( MAXTYP, NTYPES )
CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
DO 370 I = 1, NPARMS
NRHS = NSVAL( I )
*
IF( NEWSD.EQ.0 ) THEN
DO 360 K = 1, 4
ISEED( K ) = IOLDSD( K )
360 CONTINUE
END IF
WRITE( NOUT, FMT = 9966 )C3, NRHS
CALL SCHKBB( NN, MVAL, NVAL, NK, KVAL, MAXTYP, DOTYPE, NRHS,
$ ISEED, THRESH, NOUT, A( 1, 1 ), NMAX,
$ A( 1, 2 ), 2*NMAX, D( 1, 1 ), D( 1, 2 ),
$ A( 1, 4 ), NMAX, A( 1, 5 ), NMAX, A( 1, 6 ),
$ NMAX, A( 1, 7 ), WORK, LWORK, RESULT, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'SCHKBB', INFO
370 CONTINUE
*
ELSE IF( LSAMEN( 3, C3, 'GLM' ) ) THEN
*
* -----------------------------------------
* GLM: Generalized Linear Regression Model
* -----------------------------------------
*
CALL XLAENV( 1, 1 )
IF( TSTERR )
$ CALL SERRGG( 'GLM', NOUT )
CALL SCKGLM( NN, MVAL, PVAL, NVAL, NTYPES, ISEED, THRESH, NMAX,
$ A( 1, 1 ), A( 1, 2 ), B( 1, 1 ), B( 1, 2 ), X,
$ WORK, D( 1, 1 ), NIN, NOUT, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'SCKGLM', INFO
*
ELSE IF( LSAMEN( 3, C3, 'GQR' ) ) THEN
*
* ------------------------------------------
* GQR: Generalized QR and RQ factorizations
* ------------------------------------------
*
CALL XLAENV( 1, 1 )
IF( TSTERR )
$ CALL SERRGG( 'GQR', NOUT )
CALL SCKGQR( NN, MVAL, NN, PVAL, NN, NVAL, NTYPES, ISEED,
$ THRESH, NMAX, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
$ A( 1, 4 ), TAUA, B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
$ B( 1, 4 ), B( 1, 5 ), TAUB, WORK, D( 1, 1 ), NIN,
$ NOUT, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'SCKGQR', INFO
*
ELSE IF( LSAMEN( 3, C3, 'GSV' ) ) THEN
*
* ----------------------------------------------
* GSV: Generalized Singular Value Decomposition
* ----------------------------------------------
*
IF( TSTERR )
$ CALL SERRGG( 'GSV', NOUT )
CALL SCKGSV( NN, MVAL, PVAL, NVAL, NTYPES, ISEED, THRESH, NMAX,
$ A( 1, 1 ), A( 1, 2 ), B( 1, 1 ), B( 1, 2 ),
$ A( 1, 3 ), B( 1, 3 ), A( 1, 4 ), TAUA, TAUB,
$ B( 1, 4 ), IWORK, WORK, D( 1, 1 ), NIN, NOUT,
$ INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'SCKGSV', INFO
*
ELSE IF( LSAMEN( 3, C3, 'LSE' ) ) THEN
*
* --------------------------------------
* LSE: Constrained Linear Least Squares
* --------------------------------------
*
CALL XLAENV( 1, 1 )
IF( TSTERR )
$ CALL SERRGG( 'LSE', NOUT )
CALL SCKLSE( NN, MVAL, PVAL, NVAL, NTYPES, ISEED, THRESH, NMAX,
$ A( 1, 1 ), A( 1, 2 ), B( 1, 1 ), B( 1, 2 ), X,
$ WORK, D( 1, 1 ), NIN, NOUT, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'SCKLSE', INFO
*
ELSE
WRITE( NOUT, FMT = * )
WRITE( NOUT, FMT = * )
WRITE( NOUT, FMT = 9992 )C3
END IF
IF( .NOT.( SGX .OR. SXV ) )
$ GO TO 190
380 CONTINUE
WRITE( NOUT, FMT = 9994 )
S2 = SECOND( )
WRITE( NOUT, FMT = 9993 )S2 - S1
*
9999 FORMAT( / ' Execution not attempted due to input errors' )
9998 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NX =', I4,
$ ', NS =', I4, ', MAXB =', I4 )
9997 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NX =', I4 )
9996 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NS =', I4,
$ ', MAXB =', I4, ', NBCOL =', I4 )
9995 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NX =', I4,
$ ', NRHS =', I4 )
9994 FORMAT( / / ' End of tests' )
9993 FORMAT( ' Total time used = ', F12.2, ' seconds', / )
9992 FORMAT( 1X, A3, ': Unrecognized path name' )
9991 FORMAT( / / ' *** Invalid integer value in column ', I2,
$ ' of input', ' line:', / A79 )
9990 FORMAT( / / 1X, A3, ' routines were not tested' )
9989 FORMAT( ' Invalid input value: ', A6, '=', I6, '; must be >=',
$ I6 )
9988 FORMAT( ' Invalid input value: ', A6, '=', I6, '; must be <=',
$ I6 )
9987 FORMAT( ' Tests of the Nonsymmetric Eigenvalue Problem routines' )
9986 FORMAT( ' Tests of the Symmetric Eigenvalue Problem routines' )
9985 FORMAT( ' Tests of the Singular Value Decomposition routines' )
9984 FORMAT( / ' The following parameter values will be used:' )
9983 FORMAT( 4X, A6, 10I6, / 10X, 10I6 )
9982 FORMAT( / ' Routines pass computational tests if test ratio is ',
$ 'less than', F8.2, / )
9981 FORMAT( ' Relative machine ', A, ' is taken to be', E16.6 )
9980 FORMAT( ' *** Error code from ', A6, ' = ', I4 )
9979 FORMAT( / ' Tests of the Nonsymmetric Eigenvalue Problem Driver',
$ / ' SGEEV (eigenvalues and eigevectors)' )
9978 FORMAT( / ' Tests of the Nonsymmetric Eigenvalue Problem Driver',
$ / ' SGEES (Schur form)' )
9977 FORMAT( / ' Tests of the Nonsymmetric Eigenvalue Problem Expert',
$ ' Driver', / ' SGEEVX (eigenvalues, eigenvectors and',
$ ' condition numbers)' )
9976 FORMAT( / ' Tests of the Nonsymmetric Eigenvalue Problem Expert',
$ ' Driver', / ' SGEESX (Schur form and condition',
$ ' numbers)' )
9975 FORMAT( / ' Tests of the Generalized Nonsymmetric Eigenvalue ',
$ 'Problem routines' )
9974 FORMAT( ' Tests of SSBTRD', / ' (reduction of a symmetric band ',
$ 'matrix to tridiagonal form)' )
9973 FORMAT( / 1X, 71( '-' ) )
9972 FORMAT( / ' LAPACK VERSION ', I1, '.', I1, '.', I1 )
9971 FORMAT( / ' Tests of the Generalized Linear Regression Model ',
$ 'routines' )
9970 FORMAT( / ' Tests of the Generalized QR and RQ routines' )
9969 FORMAT( / ' Tests of the Generalized Singular Value',
$ ' Decomposition routines' )
9968 FORMAT( / ' Tests of the Linear Least Squares routines' )
9967 FORMAT( ' Tests of SGBBRD', / ' (reduction of a general band ',
$ 'matrix to real bidiagonal form)' )
9966 FORMAT( / / 1X, A3, ': NRHS =', I4 )
9965 FORMAT( / ' Tests of the Generalized Nonsymmetric Eigenvalue ',
$ 'Problem Expert Driver SGGESX' )
9964 FORMAT( / ' Tests of the Generalized Nonsymmetric Eigenvalue ',
$ 'Problem Driver SGGES' )
9963 FORMAT( / ' Tests of the Generalized Nonsymmetric Eigenvalue ',
$ 'Problem Driver SGGEV' )
9962 FORMAT( / ' Tests of the Generalized Nonsymmetric Eigenvalue ',
$ 'Problem Expert Driver SGGEVX' )
9961 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NX =', I4,
$ ', INMIN=', I4,
$ ', INWIN =', I4, ', INIBL =', I4, ', ISHFTS =', I4,
$ ', IACC22 =', I4)
*
* End of SCHKEE
*
END
SUBROUTINE SCHKGG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
$ TSTDIF, THRSHN, NOUNIT, A, LDA, B, H, T, S1,
$ S2, P1, P2, U, LDU, V, Q, Z, ALPHR1, ALPHI1,
$ BETA1, ALPHR3, ALPHI3, BETA3, EVECTL, EVECTR,
$ WORK, LWORK, LLWORK, RESULT, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTDIF
INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES
REAL THRESH, THRSHN
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * ), LLWORK( * )
INTEGER ISEED( 4 ), NN( * )
REAL A( LDA, * ), ALPHI1( * ), ALPHI3( * ),
$ ALPHR1( * ), ALPHR3( * ), B( LDA, * ),
$ BETA1( * ), BETA3( * ), EVECTL( LDU, * ),
$ EVECTR( LDU, * ), H( LDA, * ), P1( LDA, * ),
$ P2( LDA, * ), Q( LDU, * ), RESULT( 15 ),
$ S1( LDA, * ), S2( LDA, * ), T( LDA, * ),
$ U( LDU, * ), V( LDU, * ), WORK( * ),
$ Z( LDU, * )
* ..
*
* Purpose
* =======
*
* SCHKGG checks the nonsymmetric generalized eigenvalue problem
* routines.
* T T T
* SGGHRD factors A and B as U H V and U T V , where means
* transpose, H is hessenberg, T is triangular and U and V are
* orthogonal.
* T T
* SHGEQZ factors H and T as Q S Z and Q P Z , where P is upper
* triangular, S is in generalized Schur form (block upper triangular,
* with 1x1 and 2x2 blocks on the diagonal, the 2x2 blocks
* corresponding to complex conjugate pairs of generalized
* eigenvalues), and Q and Z are orthogonal. It also computes the
* generalized eigenvalues (alpha(1),beta(1)),...,(alpha(n),beta(n)),
* where alpha(j)=S(j,j) and beta(j)=P(j,j) -- thus,
* w(j) = alpha(j)/beta(j) is a root of the generalized eigenvalue
* problem
*
* det( A - w(j) B ) = 0
*
* and m(j) = beta(j)/alpha(j) is a root of the essentially equivalent
* problem
*
* det( m(j) A - B ) = 0
*
* STGEVC computes the matrix L of left eigenvectors and the matrix R
* of right eigenvectors for the matrix pair ( S, P ). In the
* description below, l and r are left and right eigenvectors
* corresponding to the generalized eigenvalues (alpha,beta).
*
* When SCHKGG is called, a number of matrix "sizes" ("n's") and a
* number of matrix "types" are specified. For each size ("n")
* and each type of matrix, one matrix will be generated and used
* to test the nonsymmetric eigenroutines. For each matrix, 15
* tests will be performed. The first twelve "test ratios" should be
* small -- O(1). They will be compared with the threshhold THRESH:
*
* T
* (1) | A - U H V | / ( |A| n ulp )
*
* T
* (2) | B - U T V | / ( |B| n ulp )
*
* T
* (3) | I - UU | / ( n ulp )
*
* T
* (4) | I - VV | / ( n ulp )
*
* T
* (5) | H - Q S Z | / ( |H| n ulp )
*
* T
* (6) | T - Q P Z | / ( |T| n ulp )
*
* T
* (7) | I - QQ | / ( n ulp )
*
* T
* (8) | I - ZZ | / ( n ulp )
*
* (9) max over all left eigenvalue/-vector pairs (beta/alpha,l) of
*
* | l**H * (beta S - alpha P) | / ( ulp max( |beta S|, |alpha P| ) )
*
* (10) max over all left eigenvalue/-vector pairs (beta/alpha,l') of
* T
* | l'**H * (beta H - alpha T) | / ( ulp max( |beta H|, |alpha T| ) )
*
* where the eigenvectors l' are the result of passing Q to
* STGEVC and back transforming (HOWMNY='B').
*
* (11) max over all right eigenvalue/-vector pairs (beta/alpha,r) of
*
* | (beta S - alpha T) r | / ( ulp max( |beta S|, |alpha T| ) )
*
* (12) max over all right eigenvalue/-vector pairs (beta/alpha,r') of
*
* | (beta H - alpha T) r' | / ( ulp max( |beta H|, |alpha T| ) )
*
* where the eigenvectors r' are the result of passing Z to
* STGEVC and back transforming (HOWMNY='B').
*
* The last three test ratios will usually be small, but there is no
* mathematical requirement that they be so. They are therefore
* compared with THRESH only if TSTDIF is .TRUE.
*
* (13) | S(Q,Z computed) - S(Q,Z not computed) | / ( |S| ulp )
*
* (14) | P(Q,Z computed) - P(Q,Z not computed) | / ( |P| ulp )
*
* (15) max( |alpha(Q,Z computed) - alpha(Q,Z not computed)|/|S| ,
* |beta(Q,Z computed) - beta(Q,Z not computed)|/|P| ) / ulp
*
* In addition, the normalization of L and R are checked, and compared
* with the threshhold THRSHN.
*
* Test Matrices
* ---- --------
*
* The sizes of the test matrices are specified by an array
* NN(1:NSIZES); the value of each element NN(j) specifies one size.
* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if
* DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
* Currently, the list of possible types is:
*
* (1) ( 0, 0 ) (a pair of zero matrices)
*
* (2) ( I, 0 ) (an identity and a zero matrix)
*
* (3) ( 0, I ) (an identity and a zero matrix)
*
* (4) ( I, I ) (a pair of identity matrices)
*
* t t
* (5) ( J , J ) (a pair of transposed Jordan blocks)
*
* t ( I 0 )
* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t )
* ( 0 I ) ( 0 J )
* and I is a k x k identity and J a (k+1)x(k+1)
* Jordan block; k=(N-1)/2
*
* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal
* matrix with those diagonal entries.)
* (8) ( I, D )
*
* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big
*
* (10) ( small*D, big*I )
*
* (11) ( big*I, small*D )
*
* (12) ( small*I, big*D )
*
* (13) ( big*D, big*I )
*
* (14) ( small*D, small*I )
*
* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and
* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 )
* t t
* (16) U ( J , J ) V where U and V are random orthogonal matrices.
*
* (17) U ( T1, T2 ) V where T1 and T2 are upper triangular matrices
* with random O(1) entries above the diagonal
* and diagonal entries diag(T1) =
* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) =
* ( 0, N-3, N-4,..., 1, 0, 0 )
*
* (18) U ( T1, T2 ) V diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 )
* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 )
* s = machine precision.
*
* (19) U ( T1, T2 ) V diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 )
* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 )
*
* N-5
* (20) U ( T1, T2 ) V diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 )
* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
*
* (21) U ( T1, T2 ) V diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 )
* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
* where r1,..., r(N-4) are random.
*
* (22) U ( big*T1, small*T2 ) V diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (23) U ( small*T1, big*T2 ) V diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (24) U ( small*T1, small*T2 ) V diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (25) U ( big*T1, big*T2 ) V diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (26) U ( T1, T2 ) V where T1 and T2 are random upper-triangular
* matrices.
*
* Arguments
* =========
*
* NSIZES (input) INTEGER
* The number of sizes of matrices to use. If it is zero,
* SCHKGG does nothing. It must be at least zero.
*
* NN (input) INTEGER array, dimension (NSIZES)
* An array containing the sizes to be used for the matrices.
* Zero values will be skipped. The values must be at least
* zero.
*
* NTYPES (input) INTEGER
* The number of elements in DOTYPE. If it is zero, SCHKGG
* does nothing. It must be at least zero. If it is MAXTYP+1
* and NSIZES is 1, then an additional type, MAXTYP+1 is
* defined, which is to use whatever matrix is in A. This
* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
* DOTYPE(MAXTYP+1) is .TRUE. .
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* If DOTYPE(j) is .TRUE., then for each size in NN a
* matrix of that size and of type j will be generated.
* If NTYPES is smaller than the maximum number of types
* defined (PARAMETER MAXTYP), then types NTYPES+1 through
* MAXTYP will not be generated. If NTYPES is larger
* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
* will be ignored.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The array elements should be between 0 and 4095;
* if not they will be reduced mod 4096. Also, ISEED(4) must
* be odd. The random number generator uses a linear
* congruential sequence limited to small integers, and so
* should produce machine independent random numbers. The
* values of ISEED are changed on exit, and can be used in the
* next call to SCHKGG to continue the same random number
* sequence.
*
* THRESH (input) REAL
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error is
* scaled to be O(1), so THRESH should be a reasonably small
* multiple of 1, e.g., 10 or 100. In particular, it should
* not depend on the precision (single vs. double) or the size
* of the matrix. It must be at least zero.
*
* TSTDIF (input) LOGICAL
* Specifies whether test ratios 13-15 will be computed and
* compared with THRESH.
* = .FALSE.: Only test ratios 1-12 will be computed and tested.
* Ratios 13-15 will be set to zero.
* = .TRUE.: All the test ratios 1-15 will be computed and
* tested.
*
* THRSHN (input) REAL
* Threshhold for reporting eigenvector normalization error.
* If the normalization of any eigenvector differs from 1 by
* more than THRSHN*ulp, then a special error message will be
* printed. (This is handled separately from the other tests,
* since only a compiler or programming error should cause an
* error message, at least if THRSHN is at least 5--10.)
*
* NOUNIT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns IINFO not equal to 0.)
*
* A (input/workspace) REAL array, dimension
* (LDA, max(NN))
* Used to hold the original A matrix. Used as input only
* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
* DOTYPE(MAXTYP+1)=.TRUE.
*
* LDA (input) INTEGER
* The leading dimension of A, B, H, T, S1, P1, S2, and P2.
* It must be at least 1 and at least max( NN ).
*
* B (input/workspace) REAL array, dimension
* (LDA, max(NN))
* Used to hold the original B matrix. Used as input only
* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
* DOTYPE(MAXTYP+1)=.TRUE.
*
* H (workspace) REAL array, dimension (LDA, max(NN))
* The upper Hessenberg matrix computed from A by SGGHRD.
*
* T (workspace) REAL array, dimension (LDA, max(NN))
* The upper triangular matrix computed from B by SGGHRD.
*
* S1 (workspace) REAL array, dimension (LDA, max(NN))
* The Schur (block upper triangular) matrix computed from H by
* SHGEQZ when Q and Z are also computed.
*
* S2 (workspace) REAL array, dimension (LDA, max(NN))
* The Schur (block upper triangular) matrix computed from H by
* SHGEQZ when Q and Z are not computed.
*
* P1 (workspace) REAL array, dimension (LDA, max(NN))
* The upper triangular matrix computed from T by SHGEQZ
* when Q and Z are also computed.
*
* P2 (workspace) REAL array, dimension (LDA, max(NN))
* The upper triangular matrix computed from T by SHGEQZ
* when Q and Z are not computed.
*
* U (workspace) REAL array, dimension (LDU, max(NN))
* The (left) orthogonal matrix computed by SGGHRD.
*
* LDU (input) INTEGER
* The leading dimension of U, V, Q, Z, EVECTL, and EVECTR. It
* must be at least 1 and at least max( NN ).
*
* V (workspace) REAL array, dimension (LDU, max(NN))
* The (right) orthogonal matrix computed by SGGHRD.
*
* Q (workspace) REAL array, dimension (LDU, max(NN))
* The (left) orthogonal matrix computed by SHGEQZ.
*
* Z (workspace) REAL array, dimension (LDU, max(NN))
* The (left) orthogonal matrix computed by SHGEQZ.
*
* ALPHR1 (workspace) REAL array, dimension (max(NN))
* ALPHI1 (workspace) REAL array, dimension (max(NN))
* BETA1 (workspace) REAL array, dimension (max(NN))
*
* The generalized eigenvalues of (A,B) computed by SHGEQZ
* when Q, Z, and the full Schur matrices are computed.
* On exit, ( ALPHR1(k)+ALPHI1(k)*i ) / BETA1(k) is the k-th
* generalized eigenvalue of the matrices in A and B.
*
* ALPHR3 (workspace) REAL array, dimension (max(NN))
* ALPHI3 (workspace) REAL array, dimension (max(NN))
* BETA3 (workspace) REAL array, dimension (max(NN))
*
* EVECTL (workspace) REAL array, dimension (LDU, max(NN))
* The (block lower triangular) left eigenvector matrix for
* the matrices in S1 and P1. (See STGEVC for the format.)
*
* EVECTR (workspace) REAL array, dimension (LDU, max(NN))
* The (block upper triangular) right eigenvector matrix for
* the matrices in S1 and P1. (See STGEVC for the format.)
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The number of entries in WORK. This must be at least
* max( 2 * N**2, 6*N, 1 ), for all N=NN(j).
*
* LLWORK (workspace) LOGICAL array, dimension (max(NN))
*
* RESULT (output) REAL array, dimension (15)
* The values computed by the tests described above.
* The values are currently limited to 1/ulp, to avoid
* overflow.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: A routine returned an error code. INFO is the
* absolute value of the INFO value returned.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0, ONE = 1.0 )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 26 )
* ..
* .. Local Scalars ..
LOGICAL BADNN
INTEGER I1, IADD, IINFO, IN, J, JC, JR, JSIZE, JTYPE,
$ LWKOPT, MTYPES, N, N1, NERRS, NMATS, NMAX,
$ NTEST, NTESTT
REAL ANORM, BNORM, SAFMAX, SAFMIN, TEMP1, TEMP2,
$ ULP, ULPINV
* ..
* .. Local Arrays ..
INTEGER IASIGN( MAXTYP ), IBSIGN( MAXTYP ),
$ IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ),
$ KATYPE( MAXTYP ), KAZERO( MAXTYP ),
$ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ),
$ KBZERO( MAXTYP ), KCLASS( MAXTYP ),
$ KTRIAN( MAXTYP ), KZ1( 6 ), KZ2( 6 )
REAL DUMMA( 4 ), RMAGN( 0: 3 )
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE, SLARND
EXTERNAL SLAMCH, SLANGE, SLARND
* ..
* .. External Subroutines ..
EXTERNAL SGEQR2, SGET51, SGET52, SGGHRD, SHGEQZ, SLABAD,
$ SLACPY, SLARFG, SLASET, SLASUM, SLATM4, SORM2R,
$ STGEVC, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL, SIGN
* ..
* .. Data statements ..
DATA KCLASS / 15*1, 10*2, 1*3 /
DATA KZ1 / 0, 1, 2, 1, 3, 3 /
DATA KZ2 / 0, 0, 1, 2, 1, 1 /
DATA KADD / 0, 0, 0, 0, 3, 2 /
DATA KATYPE / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4,
$ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 /
DATA KBTYPE / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4,
$ 1, 1, -4, 2, -4, 8*8, 0 /
DATA KAZERO / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3,
$ 4*5, 4*3, 1 /
DATA KBZERO / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4,
$ 4*6, 4*4, 1 /
DATA KAMAGN / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3,
$ 2, 1 /
DATA KBMAGN / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3,
$ 2, 1 /
DATA KTRIAN / 16*0, 10*1 /
DATA IASIGN / 6*0, 2, 0, 2*2, 2*0, 3*2, 0, 2, 3*0,
$ 5*2, 0 /
DATA IBSIGN / 7*0, 2, 2*0, 2*2, 2*0, 2, 0, 2, 9*0 /
* ..
* .. Executable Statements ..
*
* Check for errors
*
INFO = 0
*
BADNN = .FALSE.
NMAX = 1
DO 10 J = 1, NSIZES
NMAX = MAX( NMAX, NN( J ) )
IF( NN( J ).LT.0 )
$ BADNN = .TRUE.
10 CONTINUE
*
* Maximum blocksize and shift -- we assume that blocksize and number
* of shifts are monotone increasing functions of N.
*
LWKOPT = MAX( 6*NMAX, 2*NMAX*NMAX, 1 )
*
* Check for errors
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADNN ) THEN
INFO = -2
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -3
ELSE IF( THRESH.LT.ZERO ) THEN
INFO = -6
ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN
INFO = -10
ELSE IF( LDU.LE.1 .OR. LDU.LT.NMAX ) THEN
INFO = -19
ELSE IF( LWKOPT.GT.LWORK ) THEN
INFO = -30
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SCHKGG', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
$ RETURN
*
SAFMIN = SLAMCH( 'Safe minimum' )
ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
SAFMIN = SAFMIN / ULP
SAFMAX = ONE / SAFMIN
CALL SLABAD( SAFMIN, SAFMAX )
ULPINV = ONE / ULP
*
* The values RMAGN(2:3) depend on N, see below.
*
RMAGN( 0 ) = ZERO
RMAGN( 1 ) = ONE
*
* Loop over sizes, types
*
NTESTT = 0
NERRS = 0
NMATS = 0
*
DO 240 JSIZE = 1, NSIZES
N = NN( JSIZE )
N1 = MAX( 1, N )
RMAGN( 2 ) = SAFMAX*ULP / REAL( N1 )
RMAGN( 3 ) = SAFMIN*ULPINV*N1
*
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
DO 230 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 230
NMATS = NMATS + 1
NTEST = 0
*
* Save ISEED in case of an error.
*
DO 20 J = 1, 4
IOLDSD( J ) = ISEED( J )
20 CONTINUE
*
* Initialize RESULT
*
DO 30 J = 1, 15
RESULT( J ) = ZERO
30 CONTINUE
*
* Compute A and B
*
* Description of control parameters:
*
* KCLASS: =1 means w/o rotation, =2 means w/ rotation,
* =3 means random.
* KATYPE: the "type" to be passed to SLATM4 for computing A.
* KAZERO: the pattern of zeros on the diagonal for A:
* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ),
* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ),
* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of
* non-zero entries.)
* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1),
* =2: large, =3: small.
* IASIGN: 1 if the diagonal elements of A are to be
* multiplied by a random magnitude 1 number, =2 if
* randomly chosen diagonal blocks are to be rotated
* to form 2x2 blocks.
* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B.
* KTRIAN: =0: don't fill in the upper triangle, =1: do.
* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO.
* RMAGN: used to implement KAMAGN and KBMAGN.
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 110
IINFO = 0
IF( KCLASS( JTYPE ).LT.3 ) THEN
*
* Generate A (w/o rotation)
*
IF( ABS( KATYPE( JTYPE ) ).EQ.3 ) THEN
IN = 2*( ( N-1 ) / 2 ) + 1
IF( IN.NE.N )
$ CALL SLASET( 'Full', N, N, ZERO, ZERO, A, LDA )
ELSE
IN = N
END IF
CALL SLATM4( KATYPE( JTYPE ), IN, KZ1( KAZERO( JTYPE ) ),
$ KZ2( KAZERO( JTYPE ) ), IASIGN( JTYPE ),
$ RMAGN( KAMAGN( JTYPE ) ), ULP,
$ RMAGN( KTRIAN( JTYPE )*KAMAGN( JTYPE ) ), 2,
$ ISEED, A, LDA )
IADD = KADD( KAZERO( JTYPE ) )
IF( IADD.GT.0 .AND. IADD.LE.N )
$ A( IADD, IADD ) = RMAGN( KAMAGN( JTYPE ) )
*
* Generate B (w/o rotation)
*
IF( ABS( KBTYPE( JTYPE ) ).EQ.3 ) THEN
IN = 2*( ( N-1 ) / 2 ) + 1
IF( IN.NE.N )
$ CALL SLASET( 'Full', N, N, ZERO, ZERO, B, LDA )
ELSE
IN = N
END IF
CALL SLATM4( KBTYPE( JTYPE ), IN, KZ1( KBZERO( JTYPE ) ),
$ KZ2( KBZERO( JTYPE ) ), IBSIGN( JTYPE ),
$ RMAGN( KBMAGN( JTYPE ) ), ONE,
$ RMAGN( KTRIAN( JTYPE )*KBMAGN( JTYPE ) ), 2,
$ ISEED, B, LDA )
IADD = KADD( KBZERO( JTYPE ) )
IF( IADD.NE.0 .AND. IADD.LE.N )
$ B( IADD, IADD ) = RMAGN( KBMAGN( JTYPE ) )
*
IF( KCLASS( JTYPE ).EQ.2 .AND. N.GT.0 ) THEN
*
* Include rotations
*
* Generate U, V as Householder transformations times
* a diagonal matrix.
*
DO 50 JC = 1, N - 1
DO 40 JR = JC, N
U( JR, JC ) = SLARND( 3, ISEED )
V( JR, JC ) = SLARND( 3, ISEED )
40 CONTINUE
CALL SLARFG( N+1-JC, U( JC, JC ), U( JC+1, JC ), 1,
$ WORK( JC ) )
WORK( 2*N+JC ) = SIGN( ONE, U( JC, JC ) )
U( JC, JC ) = ONE
CALL SLARFG( N+1-JC, V( JC, JC ), V( JC+1, JC ), 1,
$ WORK( N+JC ) )
WORK( 3*N+JC ) = SIGN( ONE, V( JC, JC ) )
V( JC, JC ) = ONE
50 CONTINUE
U( N, N ) = ONE
WORK( N ) = ZERO
WORK( 3*N ) = SIGN( ONE, SLARND( 2, ISEED ) )
V( N, N ) = ONE
WORK( 2*N ) = ZERO
WORK( 4*N ) = SIGN( ONE, SLARND( 2, ISEED ) )
*
* Apply the diagonal matrices
*
DO 70 JC = 1, N
DO 60 JR = 1, N
A( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
$ A( JR, JC )
B( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
$ B( JR, JC )
60 CONTINUE
70 CONTINUE
CALL SORM2R( 'L', 'N', N, N, N-1, U, LDU, WORK, A,
$ LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
CALL SORM2R( 'R', 'T', N, N, N-1, V, LDU, WORK( N+1 ),
$ A, LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
CALL SORM2R( 'L', 'N', N, N, N-1, U, LDU, WORK, B,
$ LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
CALL SORM2R( 'R', 'T', N, N, N-1, V, LDU, WORK( N+1 ),
$ B, LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
END IF
ELSE
*
* Random matrices
*
DO 90 JC = 1, N
DO 80 JR = 1, N
A( JR, JC ) = RMAGN( KAMAGN( JTYPE ) )*
$ SLARND( 2, ISEED )
B( JR, JC ) = RMAGN( KBMAGN( JTYPE ) )*
$ SLARND( 2, ISEED )
80 CONTINUE
90 CONTINUE
END IF
*
ANORM = SLANGE( '1', N, N, A, LDA, WORK )
BNORM = SLANGE( '1', N, N, B, LDA, WORK )
*
100 CONTINUE
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
110 CONTINUE
*
* Call SGEQR2, SORM2R, and SGGHRD to compute H, T, U, and V
*
CALL SLACPY( ' ', N, N, A, LDA, H, LDA )
CALL SLACPY( ' ', N, N, B, LDA, T, LDA )
NTEST = 1
RESULT( 1 ) = ULPINV
*
CALL SGEQR2( N, N, T, LDA, WORK, WORK( N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SGEQR2', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
*
CALL SORM2R( 'L', 'T', N, N, N, T, LDA, WORK, H, LDA,
$ WORK( N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SORM2R', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
*
CALL SLASET( 'Full', N, N, ZERO, ONE, U, LDU )
CALL SORM2R( 'R', 'N', N, N, N, T, LDA, WORK, U, LDU,
$ WORK( N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SORM2R', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
*
CALL SGGHRD( 'V', 'I', N, 1, N, H, LDA, T, LDA, U, LDU, V,
$ LDU, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SGGHRD', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
NTEST = 4
*
* Do tests 1--4
*
CALL SGET51( 1, N, A, LDA, H, LDA, U, LDU, V, LDU, WORK,
$ RESULT( 1 ) )
CALL SGET51( 1, N, B, LDA, T, LDA, U, LDU, V, LDU, WORK,
$ RESULT( 2 ) )
CALL SGET51( 3, N, B, LDA, T, LDA, U, LDU, U, LDU, WORK,
$ RESULT( 3 ) )
CALL SGET51( 3, N, B, LDA, T, LDA, V, LDU, V, LDU, WORK,
$ RESULT( 4 ) )
*
* Call SHGEQZ to compute S1, P1, S2, P2, Q, and Z, do tests.
*
* Compute T1 and UZ
*
* Eigenvalues only
*
CALL SLACPY( ' ', N, N, H, LDA, S2, LDA )
CALL SLACPY( ' ', N, N, T, LDA, P2, LDA )
NTEST = 5
RESULT( 5 ) = ULPINV
*
CALL SHGEQZ( 'E', 'N', 'N', N, 1, N, S2, LDA, P2, LDA,
$ ALPHR3, ALPHI3, BETA3, Q, LDU, Z, LDU, WORK,
$ LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SHGEQZ(E)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
*
* Eigenvalues and Full Schur Form
*
CALL SLACPY( ' ', N, N, H, LDA, S2, LDA )
CALL SLACPY( ' ', N, N, T, LDA, P2, LDA )
*
CALL SHGEQZ( 'S', 'N', 'N', N, 1, N, S2, LDA, P2, LDA,
$ ALPHR1, ALPHI1, BETA1, Q, LDU, Z, LDU, WORK,
$ LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SHGEQZ(S)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
*
* Eigenvalues, Schur Form, and Schur Vectors
*
CALL SLACPY( ' ', N, N, H, LDA, S1, LDA )
CALL SLACPY( ' ', N, N, T, LDA, P1, LDA )
*
CALL SHGEQZ( 'S', 'I', 'I', N, 1, N, S1, LDA, P1, LDA,
$ ALPHR1, ALPHI1, BETA1, Q, LDU, Z, LDU, WORK,
$ LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SHGEQZ(V)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
*
NTEST = 8
*
* Do Tests 5--8
*
CALL SGET51( 1, N, H, LDA, S1, LDA, Q, LDU, Z, LDU, WORK,
$ RESULT( 5 ) )
CALL SGET51( 1, N, T, LDA, P1, LDA, Q, LDU, Z, LDU, WORK,
$ RESULT( 6 ) )
CALL SGET51( 3, N, T, LDA, P1, LDA, Q, LDU, Q, LDU, WORK,
$ RESULT( 7 ) )
CALL SGET51( 3, N, T, LDA, P1, LDA, Z, LDU, Z, LDU, WORK,
$ RESULT( 8 ) )
*
* Compute the Left and Right Eigenvectors of (S1,P1)
*
* 9: Compute the left eigenvector Matrix without
* back transforming:
*
NTEST = 9
RESULT( 9 ) = ULPINV
*
* To test "SELECT" option, compute half of the eigenvectors
* in one call, and half in another
*
I1 = N / 2
DO 120 J = 1, I1
LLWORK( J ) = .TRUE.
120 CONTINUE
DO 130 J = I1 + 1, N
LLWORK( J ) = .FALSE.
130 CONTINUE
*
CALL STGEVC( 'L', 'S', LLWORK, N, S1, LDA, P1, LDA, EVECTL,
$ LDU, DUMMA, LDU, N, IN, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'STGEVC(L,S1)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
*
I1 = IN
DO 140 J = 1, I1
LLWORK( J ) = .FALSE.
140 CONTINUE
DO 150 J = I1 + 1, N
LLWORK( J ) = .TRUE.
150 CONTINUE
*
CALL STGEVC( 'L', 'S', LLWORK, N, S1, LDA, P1, LDA,
$ EVECTL( 1, I1+1 ), LDU, DUMMA, LDU, N, IN,
$ WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'STGEVC(L,S2)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
*
CALL SGET52( .TRUE., N, S1, LDA, P1, LDA, EVECTL, LDU,
$ ALPHR1, ALPHI1, BETA1, WORK, DUMMA( 1 ) )
RESULT( 9 ) = DUMMA( 1 )
IF( DUMMA( 2 ).GT.THRSHN ) THEN
WRITE( NOUNIT, FMT = 9998 )'Left', 'STGEVC(HOWMNY=S)',
$ DUMMA( 2 ), N, JTYPE, IOLDSD
END IF
*
* 10: Compute the left eigenvector Matrix with
* back transforming:
*
NTEST = 10
RESULT( 10 ) = ULPINV
CALL SLACPY( 'F', N, N, Q, LDU, EVECTL, LDU )
CALL STGEVC( 'L', 'B', LLWORK, N, S1, LDA, P1, LDA, EVECTL,
$ LDU, DUMMA, LDU, N, IN, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'STGEVC(L,B)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
*
CALL SGET52( .TRUE., N, H, LDA, T, LDA, EVECTL, LDU, ALPHR1,
$ ALPHI1, BETA1, WORK, DUMMA( 1 ) )
RESULT( 10 ) = DUMMA( 1 )
IF( DUMMA( 2 ).GT.THRSHN ) THEN
WRITE( NOUNIT, FMT = 9998 )'Left', 'STGEVC(HOWMNY=B)',
$ DUMMA( 2 ), N, JTYPE, IOLDSD
END IF
*
* 11: Compute the right eigenvector Matrix without
* back transforming:
*
NTEST = 11
RESULT( 11 ) = ULPINV
*
* To test "SELECT" option, compute half of the eigenvectors
* in one call, and half in another
*
I1 = N / 2
DO 160 J = 1, I1
LLWORK( J ) = .TRUE.
160 CONTINUE
DO 170 J = I1 + 1, N
LLWORK( J ) = .FALSE.
170 CONTINUE
*
CALL STGEVC( 'R', 'S', LLWORK, N, S1, LDA, P1, LDA, DUMMA,
$ LDU, EVECTR, LDU, N, IN, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'STGEVC(R,S1)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
*
I1 = IN
DO 180 J = 1, I1
LLWORK( J ) = .FALSE.
180 CONTINUE
DO 190 J = I1 + 1, N
LLWORK( J ) = .TRUE.
190 CONTINUE
*
CALL STGEVC( 'R', 'S', LLWORK, N, S1, LDA, P1, LDA, DUMMA,
$ LDU, EVECTR( 1, I1+1 ), LDU, N, IN, WORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'STGEVC(R,S2)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
*
CALL SGET52( .FALSE., N, S1, LDA, P1, LDA, EVECTR, LDU,
$ ALPHR1, ALPHI1, BETA1, WORK, DUMMA( 1 ) )
RESULT( 11 ) = DUMMA( 1 )
IF( DUMMA( 2 ).GT.THRESH ) THEN
WRITE( NOUNIT, FMT = 9998 )'Right', 'STGEVC(HOWMNY=S)',
$ DUMMA( 2 ), N, JTYPE, IOLDSD
END IF
*
* 12: Compute the right eigenvector Matrix with
* back transforming:
*
NTEST = 12
RESULT( 12 ) = ULPINV
CALL SLACPY( 'F', N, N, Z, LDU, EVECTR, LDU )
CALL STGEVC( 'R', 'B', LLWORK, N, S1, LDA, P1, LDA, DUMMA,
$ LDU, EVECTR, LDU, N, IN, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'STGEVC(R,B)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
*
CALL SGET52( .FALSE., N, H, LDA, T, LDA, EVECTR, LDU,
$ ALPHR1, ALPHI1, BETA1, WORK, DUMMA( 1 ) )
RESULT( 12 ) = DUMMA( 1 )
IF( DUMMA( 2 ).GT.THRESH ) THEN
WRITE( NOUNIT, FMT = 9998 )'Right', 'STGEVC(HOWMNY=B)',
$ DUMMA( 2 ), N, JTYPE, IOLDSD
END IF
*
* Tests 13--15 are done only on request
*
IF( TSTDIF ) THEN
*
* Do Tests 13--14
*
CALL SGET51( 2, N, S1, LDA, S2, LDA, Q, LDU, Z, LDU,
$ WORK, RESULT( 13 ) )
CALL SGET51( 2, N, P1, LDA, P2, LDA, Q, LDU, Z, LDU,
$ WORK, RESULT( 14 ) )
*
* Do Test 15
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 200 J = 1, N
TEMP1 = MAX( TEMP1, ABS( ALPHR1( J )-ALPHR3( J ) )+
$ ABS( ALPHI1( J )-ALPHI3( J ) ) )
TEMP2 = MAX( TEMP2, ABS( BETA1( J )-BETA3( J ) ) )
200 CONTINUE
*
TEMP1 = TEMP1 / MAX( SAFMIN, ULP*MAX( TEMP1, ANORM ) )
TEMP2 = TEMP2 / MAX( SAFMIN, ULP*MAX( TEMP2, BNORM ) )
RESULT( 15 ) = MAX( TEMP1, TEMP2 )
NTEST = 15
ELSE
RESULT( 13 ) = ZERO
RESULT( 14 ) = ZERO
RESULT( 15 ) = ZERO
NTEST = 12
END IF
*
* End of Loop -- Check for RESULT(j) > THRESH
*
210 CONTINUE
*
NTESTT = NTESTT + NTEST
*
* Print out tests which fail.
*
DO 220 JR = 1, NTEST
IF( RESULT( JR ).GE.THRESH ) THEN
*
* If this is the first test to fail,
* print a header to the data file.
*
IF( NERRS.EQ.0 ) THEN
WRITE( NOUNIT, FMT = 9997 )'SGG'
*
* Matrix types
*
WRITE( NOUNIT, FMT = 9996 )
WRITE( NOUNIT, FMT = 9995 )
WRITE( NOUNIT, FMT = 9994 )'Orthogonal'
*
* Tests performed
*
WRITE( NOUNIT, FMT = 9993 )'orthogonal', '''',
$ 'transpose', ( '''', J = 1, 10 )
*
END IF
NERRS = NERRS + 1
IF( RESULT( JR ).LT.10000.0 ) THEN
WRITE( NOUNIT, FMT = 9992 )N, JTYPE, IOLDSD, JR,
$ RESULT( JR )
ELSE
WRITE( NOUNIT, FMT = 9991 )N, JTYPE, IOLDSD, JR,
$ RESULT( JR )
END IF
END IF
220 CONTINUE
*
230 CONTINUE
240 CONTINUE
*
* Summary
*
CALL SLASUM( 'SGG', NOUNIT, NERRS, NTESTT )
RETURN
*
9999 FORMAT( ' SCHKGG: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
*
9998 FORMAT( ' SCHKGG: ', A, ' Eigenvectors from ', A, ' incorrectly ',
$ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 9X,
$ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5,
$ ')' )
*
9997 FORMAT( / 1X, A3, ' -- Real Generalized eigenvalue problem' )
*
9996 FORMAT( ' Matrix types (see SCHKGG for details): ' )
*
9995 FORMAT( ' Special Matrices:', 23X,
$ '(J''=transposed Jordan block)',
$ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ',
$ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ',
$ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I',
$ ') 11=(large*I, small*D) 13=(large*D, large*I)', /
$ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ',
$ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' )
9994 FORMAT( ' Matrices Rotated by Random ', A, ' Matrices U, V:',
$ / ' 16=Transposed Jordan Blocks 19=geometric ',
$ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ',
$ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ',
$ 'alpha, beta=0,1 21=random alpha, beta=0,1',
$ / ' Large & Small Matrices:', / ' 22=(large, small) ',
$ '23=(small,large) 24=(small,small) 25=(large,large)',
$ / ' 26=random O(1) matrices.' )
*
9993 FORMAT( / ' Tests performed: (H is Hessenberg, S is Schur, B, ',
$ 'T, P are triangular,', / 20X, 'U, V, Q, and Z are ', A,
$ ', l and r are the', / 20X,
$ 'appropriate left and right eigenvectors, resp., a is',
$ / 20X, 'alpha, b is beta, and ', A, ' means ', A, '.)',
$ / ' 1 = | A - U H V', A,
$ ' | / ( |A| n ulp ) 2 = | B - U T V', A,
$ ' | / ( |B| n ulp )', / ' 3 = | I - UU', A,
$ ' | / ( n ulp ) 4 = | I - VV', A,
$ ' | / ( n ulp )', / ' 5 = | H - Q S Z', A,
$ ' | / ( |H| n ulp )', 6X, '6 = | T - Q P Z', A,
$ ' | / ( |T| n ulp )', / ' 7 = | I - QQ', A,
$ ' | / ( n ulp ) 8 = | I - ZZ', A,
$ ' | / ( n ulp )', / ' 9 = max | ( b S - a P )', A,
$ ' l | / const. 10 = max | ( b H - a T )', A,
$ ' l | / const.', /
$ ' 11= max | ( b S - a P ) r | / const. 12 = max | ( b H',
$ ' - a T ) r | / const.', / 1X )
*
9992 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
$ 4( I4, ',' ), ' result ', I2, ' is', 0P, F8.2 )
9991 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
$ 4( I4, ',' ), ' result ', I2, ' is', 1P, E10.3 )
*
* End of SCHKGG
*
END
SUBROUTINE SCHKGK( NIN, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER NIN, NOUT
* ..
*
* Purpose
* =======
*
* SCHKGK tests SGGBAK, a routine for backward balancing of
* a matrix pair (A, B).
*
* Arguments
* =========
*
* NIN (input) INTEGER
* The logical unit number for input. NIN > 0.
*
* NOUT (input) INTEGER
* The logical unit number for output. NOUT > 0.
*
* =====================================================================
*
* .. Parameters ..
INTEGER LDA, LDB, LDVL, LDVR
PARAMETER ( LDA = 50, LDB = 50, LDVL = 50, LDVR = 50 )
INTEGER LDE, LDF, LDWORK
PARAMETER ( LDE = 50, LDF = 50, LDWORK = 50 )
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, IHI, ILO, INFO, J, KNT, M, N, NINFO
REAL ANORM, BNORM, EPS, RMAX, VMAX
* ..
* .. Local Arrays ..
INTEGER LMAX( 4 )
REAL A( LDA, LDA ), AF( LDA, LDA ), B( LDB, LDB ),
$ BF( LDB, LDB ), E( LDE, LDE ), F( LDF, LDF ),
$ LSCALE( LDA ), RSCALE( LDA ), VL( LDVL, LDVL ),
$ VLF( LDVL, LDVL ), VR( LDVR, LDVR ),
$ VRF( LDVR, LDVR ), WORK( LDWORK, LDWORK )
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE
EXTERNAL SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SGGBAK, SGGBAL, SLACPY
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Initialization
*
LMAX( 1 ) = 0
LMAX( 2 ) = 0
LMAX( 3 ) = 0
LMAX( 4 ) = 0
NINFO = 0
KNT = 0
RMAX = ZERO
*
EPS = SLAMCH( 'Precision' )
*
10 CONTINUE
READ( NIN, FMT = * )N, M
IF( N.EQ.0 )
$ GO TO 100
*
DO 20 I = 1, N
READ( NIN, FMT = * )( A( I, J ), J = 1, N )
20 CONTINUE
*
DO 30 I = 1, N
READ( NIN, FMT = * )( B( I, J ), J = 1, N )
30 CONTINUE
*
DO 40 I = 1, N
READ( NIN, FMT = * )( VL( I, J ), J = 1, M )
40 CONTINUE
*
DO 50 I = 1, N
READ( NIN, FMT = * )( VR( I, J ), J = 1, M )
50 CONTINUE
*
KNT = KNT + 1
*
ANORM = SLANGE( 'M', N, N, A, LDA, WORK )
BNORM = SLANGE( 'M', N, N, B, LDB, WORK )
*
CALL SLACPY( 'FULL', N, N, A, LDA, AF, LDA )
CALL SLACPY( 'FULL', N, N, B, LDB, BF, LDB )
*
CALL SGGBAL( 'B', N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE,
$ WORK, INFO )
IF( INFO.NE.0 ) THEN
NINFO = NINFO + 1
LMAX( 1 ) = KNT
END IF
*
CALL SLACPY( 'FULL', N, M, VL, LDVL, VLF, LDVL )
CALL SLACPY( 'FULL', N, M, VR, LDVR, VRF, LDVR )
*
CALL SGGBAK( 'B', 'L', N, ILO, IHI, LSCALE, RSCALE, M, VL, LDVL,
$ INFO )
IF( INFO.NE.0 ) THEN
NINFO = NINFO + 1
LMAX( 2 ) = KNT
END IF
*
CALL SGGBAK( 'B', 'R', N, ILO, IHI, LSCALE, RSCALE, M, VR, LDVR,
$ INFO )
IF( INFO.NE.0 ) THEN
NINFO = NINFO + 1
LMAX( 3 ) = KNT
END IF
*
* Test of SGGBAK
*
* Check tilde(VL)'*A*tilde(VR) - VL'*tilde(A)*VR
* where tilde(A) denotes the transformed matrix.
*
CALL SGEMM( 'N', 'N', N, M, N, ONE, AF, LDA, VR, LDVR, ZERO, WORK,
$ LDWORK )
CALL SGEMM( 'T', 'N', M, M, N, ONE, VL, LDVL, WORK, LDWORK, ZERO,
$ E, LDE )
*
CALL SGEMM( 'N', 'N', N, M, N, ONE, A, LDA, VRF, LDVR, ZERO, WORK,
$ LDWORK )
CALL SGEMM( 'T', 'N', M, M, N, ONE, VLF, LDVL, WORK, LDWORK, ZERO,
$ F, LDF )
*
VMAX = ZERO
DO 70 J = 1, M
DO 60 I = 1, M
VMAX = MAX( VMAX, ABS( E( I, J )-F( I, J ) ) )
60 CONTINUE
70 CONTINUE
VMAX = VMAX / ( EPS*MAX( ANORM, BNORM ) )
IF( VMAX.GT.RMAX ) THEN
LMAX( 4 ) = KNT
RMAX = VMAX
END IF
*
* Check tilde(VL)'*B*tilde(VR) - VL'*tilde(B)*VR
*
CALL SGEMM( 'N', 'N', N, M, N, ONE, BF, LDB, VR, LDVR, ZERO, WORK,
$ LDWORK )
CALL SGEMM( 'T', 'N', M, M, N, ONE, VL, LDVL, WORK, LDWORK, ZERO,
$ E, LDE )
*
CALL SGEMM( 'N', 'N', N, M, N, ONE, B, LDB, VRF, LDVR, ZERO, WORK,
$ LDWORK )
CALL SGEMM( 'T', 'N', M, M, N, ONE, VLF, LDVL, WORK, LDWORK, ZERO,
$ F, LDF )
*
VMAX = ZERO
DO 90 J = 1, M
DO 80 I = 1, M
VMAX = MAX( VMAX, ABS( E( I, J )-F( I, J ) ) )
80 CONTINUE
90 CONTINUE
VMAX = VMAX / ( EPS*MAX( ANORM, BNORM ) )
IF( VMAX.GT.RMAX ) THEN
LMAX( 4 ) = KNT
RMAX = VMAX
END IF
*
GO TO 10
*
100 CONTINUE
*
WRITE( NOUT, FMT = 9999 )
9999 FORMAT( 1X, '.. test output of SGGBAK .. ' )
*
WRITE( NOUT, FMT = 9998 )RMAX
9998 FORMAT( ' value of largest test error =', E12.3 )
WRITE( NOUT, FMT = 9997 )LMAX( 1 )
9997 FORMAT( ' example number where SGGBAL info is not 0 =', I4 )
WRITE( NOUT, FMT = 9996 )LMAX( 2 )
9996 FORMAT( ' example number where SGGBAK(L) info is not 0 =', I4 )
WRITE( NOUT, FMT = 9995 )LMAX( 3 )
9995 FORMAT( ' example number where SGGBAK(R) info is not 0 =', I4 )
WRITE( NOUT, FMT = 9994 )LMAX( 4 )
9994 FORMAT( ' example number having largest error =', I4 )
WRITE( NOUT, FMT = 9992 )NINFO
9992 FORMAT( ' number of examples where info is not 0 =', I4 )
WRITE( NOUT, FMT = 9991 )KNT
9991 FORMAT( ' total number of examples tested =', I4 )
*
RETURN
*
* End of SCHKGK
*
END
SUBROUTINE SCHKGL( NIN, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER NIN, NOUT
* ..
*
* Purpose
* =======
*
* SCHKGL tests SGGBAL, a routine for balancing a matrix pair (A, B).
*
* Arguments
* =========
*
* NIN (input) INTEGER
* The logical unit number for input. NIN > 0.
*
* NOUT (input) INTEGER
* The logical unit number for output. NOUT > 0.
*
* =====================================================================
*
* .. Parameters ..
INTEGER LDA, LDB, LWORK
PARAMETER ( LDA = 20, LDB = 20, LWORK = 6*LDA )
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, IHI, IHIIN, ILO, ILOIN, INFO, J, KNT, N,
$ NINFO
REAL ANORM, BNORM, EPS, RMAX, VMAX
* ..
* .. Local Arrays ..
INTEGER LMAX( 5 )
REAL A( LDA, LDA ), AIN( LDA, LDA ), B( LDB, LDB ),
$ BIN( LDB, LDB ), LSCALE( LDA ), LSCLIN( LDA ),
$ RSCALE( LDA ), RSCLIN( LDA ), WORK( LWORK )
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE
EXTERNAL SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SGGBAL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
LMAX( 1 ) = 0
LMAX( 2 ) = 0
LMAX( 3 ) = 0
NINFO = 0
KNT = 0
RMAX = ZERO
*
EPS = SLAMCH( 'Precision' )
*
10 CONTINUE
*
READ( NIN, FMT = * )N
IF( N.EQ.0 )
$ GO TO 90
DO 20 I = 1, N
READ( NIN, FMT = * )( A( I, J ), J = 1, N )
20 CONTINUE
*
DO 30 I = 1, N
READ( NIN, FMT = * )( B( I, J ), J = 1, N )
30 CONTINUE
*
READ( NIN, FMT = * )ILOIN, IHIIN
DO 40 I = 1, N
READ( NIN, FMT = * )( AIN( I, J ), J = 1, N )
40 CONTINUE
DO 50 I = 1, N
READ( NIN, FMT = * )( BIN( I, J ), J = 1, N )
50 CONTINUE
*
READ( NIN, FMT = * )( LSCLIN( I ), I = 1, N )
READ( NIN, FMT = * )( RSCLIN( I ), I = 1, N )
*
ANORM = SLANGE( 'M', N, N, A, LDA, WORK )
BNORM = SLANGE( 'M', N, N, B, LDB, WORK )
*
KNT = KNT + 1
*
CALL SGGBAL( 'B', N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE,
$ WORK, INFO )
*
IF( INFO.NE.0 ) THEN
NINFO = NINFO + 1
LMAX( 1 ) = KNT
END IF
*
IF( ILO.NE.ILOIN .OR. IHI.NE.IHIIN ) THEN
NINFO = NINFO + 1
LMAX( 2 ) = KNT
END IF
*
VMAX = ZERO
DO 70 I = 1, N
DO 60 J = 1, N
VMAX = MAX( VMAX, ABS( A( I, J )-AIN( I, J ) ) )
VMAX = MAX( VMAX, ABS( B( I, J )-BIN( I, J ) ) )
60 CONTINUE
70 CONTINUE
*
DO 80 I = 1, N
VMAX = MAX( VMAX, ABS( LSCALE( I )-LSCLIN( I ) ) )
VMAX = MAX( VMAX, ABS( RSCALE( I )-RSCLIN( I ) ) )
80 CONTINUE
*
VMAX = VMAX / ( EPS*MAX( ANORM, BNORM ) )
*
IF( VMAX.GT.RMAX ) THEN
LMAX( 3 ) = KNT
RMAX = VMAX
END IF
*
GO TO 10
*
90 CONTINUE
*
WRITE( NOUT, FMT = 9999 )
9999 FORMAT( 1X, '.. test output of SGGBAL .. ' )
*
WRITE( NOUT, FMT = 9998 )RMAX
9998 FORMAT( 1X, 'value of largest test error = ', E12.3 )
WRITE( NOUT, FMT = 9997 )LMAX( 1 )
9997 FORMAT( 1X, 'example number where info is not zero = ', I4 )
WRITE( NOUT, FMT = 9996 )LMAX( 2 )
9996 FORMAT( 1X, 'example number where ILO or IHI wrong = ', I4 )
WRITE( NOUT, FMT = 9995 )LMAX( 3 )
9995 FORMAT( 1X, 'example number having largest error = ', I4 )
WRITE( NOUT, FMT = 9994 )NINFO
9994 FORMAT( 1X, 'number of examples where info is not 0 = ', I4 )
WRITE( NOUT, FMT = 9993 )KNT
9993 FORMAT( 1X, 'total number of examples tested = ', I4 )
*
RETURN
*
* End of SCHKGL
*
END
SUBROUTINE SCHKHS( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
$ NOUNIT, A, LDA, H, T1, T2, U, LDU, Z, UZ, WR1,
$ WI1, WR3, WI3, EVECTL, EVECTR, EVECTY, EVECTX,
$ UU, TAU, WORK, NWORK, IWORK, SELECT, RESULT,
$ INFO )
*
* -- LAPACK test routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* February 2007
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDU, NOUNIT, NSIZES, NTYPES, NWORK
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * ), SELECT( * )
INTEGER ISEED( 4 ), IWORK( * ), NN( * )
REAL A( LDA, * ), EVECTL( LDU, * ),
$ EVECTR( LDU, * ), EVECTX( LDU, * ),
$ EVECTY( LDU, * ), H( LDA, * ), RESULT( 14 ),
$ T1( LDA, * ), T2( LDA, * ), TAU( * ),
$ U( LDU, * ), UU( LDU, * ), UZ( LDU, * ),
$ WI1( * ), WI3( * ), WORK( * ), WR1( * ),
$ WR3( * ), Z( LDU, * )
* ..
*
* Purpose
* =======
*
* SCHKHS checks the nonsymmetric eigenvalue problem routines.
*
* SGEHRD factors A as U H U' , where ' means transpose,
* H is hessenberg, and U is an orthogonal matrix.
*
* SORGHR generates the orthogonal matrix U.
*
* SORMHR multiplies a matrix by the orthogonal matrix U.
*
* SHSEQR factors H as Z T Z' , where Z is orthogonal and
* T is "quasi-triangular", and the eigenvalue vector W.
*
* STREVC computes the left and right eigenvector matrices
* L and R for T.
*
* SHSEIN computes the left and right eigenvector matrices
* Y and X for H, using inverse iteration.
*
* When SCHKHS is called, a number of matrix "sizes" ("n's") and a
* number of matrix "types" are specified. For each size ("n")
* and each type of matrix, one matrix will be generated and used
* to test the nonsymmetric eigenroutines. For each matrix, 14
* tests will be performed:
*
* (1) | A - U H U**T | / ( |A| n ulp )
*
* (2) | I - UU**T | / ( n ulp )
*
* (3) | H - Z T Z**T | / ( |H| n ulp )
*
* (4) | I - ZZ**T | / ( n ulp )
*
* (5) | A - UZ H (UZ)**T | / ( |A| n ulp )
*
* (6) | I - UZ (UZ)**T | / ( n ulp )
*
* (7) | T(Z computed) - T(Z not computed) | / ( |T| ulp )
*
* (8) | W(Z computed) - W(Z not computed) | / ( |W| ulp )
*
* (9) | TR - RW | / ( |T| |R| ulp )
*
* (10) | L**H T - W**H L | / ( |T| |L| ulp )
*
* (11) | HX - XW | / ( |H| |X| ulp )
*
* (12) | Y**H H - W**H Y | / ( |H| |Y| ulp )
*
* (13) | AX - XW | / ( |A| |X| ulp )
*
* (14) | Y**H A - W**H Y | / ( |A| |Y| ulp )
*
* The "sizes" are specified by an array NN(1:NSIZES); the value of
* each element NN(j) specifies one size.
* The "types" are specified by a logical array DOTYPE( 1:NTYPES );
* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
* Currently, the list of possible types is:
*
* (1) The zero matrix.
* (2) The identity matrix.
* (3) A (transposed) Jordan block, with 1's on the diagonal.
*
* (4) A diagonal matrix with evenly spaced entries
* 1, ..., ULP and random signs.
* (ULP = (first number larger than 1) - 1 )
* (5) A diagonal matrix with geometrically spaced entries
* 1, ..., ULP and random signs.
* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
* and random signs.
*
* (7) Same as (4), but multiplied by SQRT( overflow threshold )
* (8) Same as (4), but multiplied by SQRT( underflow threshold )
*
* (9) A matrix of the form U' T U, where U is orthogonal and
* T has evenly spaced entries 1, ..., ULP with random signs
* on the diagonal and random O(1) entries in the upper
* triangle.
*
* (10) A matrix of the form U' T U, where U is orthogonal and
* T has geometrically spaced entries 1, ..., ULP with random
* signs on the diagonal and random O(1) entries in the upper
* triangle.
*
* (11) A matrix of the form U' T U, where U is orthogonal and
* T has "clustered" entries 1, ULP,..., ULP with random
* signs on the diagonal and random O(1) entries in the upper
* triangle.
*
* (12) A matrix of the form U' T U, where U is orthogonal and
* T has real or complex conjugate paired eigenvalues randomly
* chosen from ( ULP, 1 ) and random O(1) entries in the upper
* triangle.
*
* (13) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP
* with random signs on the diagonal and random O(1) entries
* in the upper triangle.
*
* (14) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has geometrically spaced entries
* 1, ..., ULP with random signs on the diagonal and random
* O(1) entries in the upper triangle.
*
* (15) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP
* with random signs on the diagonal and random O(1) entries
* in the upper triangle.
*
* (16) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has real or complex conjugate paired
* eigenvalues randomly chosen from ( ULP, 1 ) and random
* O(1) entries in the upper triangle.
*
* (17) Same as (16), but multiplied by SQRT( overflow threshold )
* (18) Same as (16), but multiplied by SQRT( underflow threshold )
*
* (19) Nonsymmetric matrix with random entries chosen from (-1,1).
* (20) Same as (19), but multiplied by SQRT( overflow threshold )
* (21) Same as (19), but multiplied by SQRT( underflow threshold )
*
* Arguments
* ==========
*
* NSIZES - INTEGER
* The number of sizes of matrices to use. If it is zero,
* SCHKHS does nothing. It must be at least zero.
* Not modified.
*
* NN - INTEGER array, dimension (NSIZES)
* An array containing the sizes to be used for the matrices.
* Zero values will be skipped. The values must be at least
* zero.
* Not modified.
*
* NTYPES - INTEGER
* The number of elements in DOTYPE. If it is zero, SCHKHS
* does nothing. It must be at least zero. If it is MAXTYP+1
* and NSIZES is 1, then an additional type, MAXTYP+1 is
* defined, which is to use whatever matrix is in A. This
* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
* DOTYPE(MAXTYP+1) is .TRUE. .
* Not modified.
*
* DOTYPE - LOGICAL array, dimension (NTYPES)
* If DOTYPE(j) is .TRUE., then for each size in NN a
* matrix of that size and of type j will be generated.
* If NTYPES is smaller than the maximum number of types
* defined (PARAMETER MAXTYP), then types NTYPES+1 through
* MAXTYP will not be generated. If NTYPES is larger
* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
* will be ignored.
* Not modified.
*
* ISEED - INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The array elements should be between 0 and 4095;
* if not they will be reduced mod 4096. Also, ISEED(4) must
* be odd. The random number generator uses a linear
* congruential sequence limited to small integers, and so
* should produce machine independent random numbers. The
* values of ISEED are changed on exit, and can be used in the
* next call to SCHKHS to continue the same random number
* sequence.
* Modified.
*
* THRESH - REAL
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error
* is scaled to be O(1), so THRESH should be a reasonably
* small multiple of 1, e.g., 10 or 100. In particular,
* it should not depend on the precision (single vs. double)
* or the size of the matrix. It must be at least zero.
* Not modified.
*
* NOUNIT - INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns IINFO not equal to 0.)
* Not modified.
*
* A - REAL array, dimension (LDA,max(NN))
* Used to hold the matrix whose eigenvalues are to be
* computed. On exit, A contains the last matrix actually
* used.
* Modified.
*
* LDA - INTEGER
* The leading dimension of A, H, T1 and T2. It must be at
* least 1 and at least max( NN ).
* Not modified.
*
* H - REAL array, dimension (LDA,max(NN))
* The upper hessenberg matrix computed by SGEHRD. On exit,
* H contains the Hessenberg form of the matrix in A.
* Modified.
*
* T1 - REAL array, dimension (LDA,max(NN))
* The Schur (="quasi-triangular") matrix computed by SHSEQR
* if Z is computed. On exit, T1 contains the Schur form of
* the matrix in A.
* Modified.
*
* T2 - REAL array, dimension (LDA,max(NN))
* The Schur matrix computed by SHSEQR when Z is not computed.
* This should be identical to T1.
* Modified.
*
* LDU - INTEGER
* The leading dimension of U, Z, UZ and UU. It must be at
* least 1 and at least max( NN ).
* Not modified.
*
* U - REAL array, dimension (LDU,max(NN))
* The orthogonal matrix computed by SGEHRD.
* Modified.
*
* Z - REAL array, dimension (LDU,max(NN))
* The orthogonal matrix computed by SHSEQR.
* Modified.
*
* UZ - REAL array, dimension (LDU,max(NN))
* The product of U times Z.
* Modified.
*
* WR1 - REAL array, dimension (max(NN))
* WI1 - REAL array, dimension (max(NN))
* The real and imaginary parts of the eigenvalues of A,
* as computed when Z is computed.
* On exit, WR1 + WI1*i are the eigenvalues of the matrix in A.
* Modified.
*
* WR3 - REAL array, dimension (max(NN))
* WI3 - REAL array, dimension (max(NN))
* Like WR1, WI1, these arrays contain the eigenvalues of A,
* but those computed when SHSEQR only computes the
* eigenvalues, i.e., not the Schur vectors and no more of the
* Schur form than is necessary for computing the
* eigenvalues.
* Modified.
*
* EVECTL - REAL array, dimension (LDU,max(NN))
* The (upper triangular) left eigenvector matrix for the
* matrix in T1. For complex conjugate pairs, the real part
* is stored in one row and the imaginary part in the next.
* Modified.
*
* EVECTR - REAL array, dimension (LDU,max(NN))
* The (upper triangular) right eigenvector matrix for the
* matrix in T1. For complex conjugate pairs, the real part
* is stored in one column and the imaginary part in the next.
* Modified.
*
* EVECTY - REAL array, dimension (LDU,max(NN))
* The left eigenvector matrix for the
* matrix in H. For complex conjugate pairs, the real part
* is stored in one row and the imaginary part in the next.
* Modified.
*
* EVECTX - REAL array, dimension (LDU,max(NN))
* The right eigenvector matrix for the
* matrix in H. For complex conjugate pairs, the real part
* is stored in one column and the imaginary part in the next.
* Modified.
*
* UU - REAL array, dimension (LDU,max(NN))
* Details of the orthogonal matrix computed by SGEHRD.
* Modified.
*
* TAU - REAL array, dimension(max(NN))
* Further details of the orthogonal matrix computed by SGEHRD.
* Modified.
*
* WORK - REAL array, dimension (NWORK)
* Workspace.
* Modified.
*
* NWORK - INTEGER
* The number of entries in WORK. NWORK >= 4*NN(j)*NN(j) + 2.
*
* IWORK - INTEGER array, dimension (max(NN))
* Workspace.
* Modified.
*
* SELECT - LOGICAL array, dimension (max(NN))
* Workspace.
* Modified.
*
* RESULT - REAL array, dimension (14)
* The values computed by the fourteen tests described above.
* The values are currently limited to 1/ulp, to avoid
* overflow.
* Modified.
*
* INFO - INTEGER
* If 0, then everything ran OK.
* -1: NSIZES < 0
* -2: Some NN(j) < 0
* -3: NTYPES < 0
* -6: THRESH < 0
* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
* -14: LDU < 1 or LDU < NMAX.
* -28: NWORK too small.
* If SLATMR, SLATMS, or SLATME returns an error code, the
* absolute value of it is returned.
* If 1, then SHSEQR could not find all the shifts.
* If 2, then the EISPACK code (for small blocks) failed.
* If >2, then 30*N iterations were not enough to find an
* eigenvalue or to decompose the problem.
* Modified.
*
*-----------------------------------------------------------------------
*
* Some Local Variables and Parameters:
* ---- ----- --------- --- ----------
*
* ZERO, ONE Real 0 and 1.
* MAXTYP The number of types defined.
* MTEST The number of tests defined: care must be taken
* that (1) the size of RESULT, (2) the number of
* tests actually performed, and (3) MTEST agree.
* NTEST The number of tests performed on this matrix
* so far. This should be less than MTEST, and
* equal to it by the last test. It will be less
* if any of the routines being tested indicates
* that it could not compute the matrices that
* would be tested.
* NMAX Largest value in NN.
* NMATS The number of matrices generated so far.
* NERRS The number of tests which have exceeded THRESH
* so far (computed by SLAFTS).
* COND, CONDS,
* IMODE Values to be passed to the matrix generators.
* ANORM Norm of A; passed to matrix generators.
*
* OVFL, UNFL Overflow and underflow thresholds.
* ULP, ULPINV Finest relative precision and its inverse.
* RTOVFL, RTUNFL,
* RTULP, RTULPI Square roots of the previous 4 values.
*
* The following four arrays decode JTYPE:
* KTYPE(j) The general type (1-10) for type "j".
* KMODE(j) The MODE value to be passed to the matrix
* generator for type "j".
* KMAGN(j) The order of magnitude ( O(1),
* O(overflow^(1/2) ), O(underflow^(1/2) )
* KCONDS(j) Selects whether CONDS is to be 1 or
* 1/sqrt(ulp). (0 means irrelevant.)
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0, ONE = 1.0 )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 21 )
* ..
* .. Local Scalars ..
LOGICAL BADNN, MATCH
INTEGER I, IHI, IINFO, ILO, IMODE, IN, ITYPE, J, JCOL,
$ JJ, JSIZE, JTYPE, K, MTYPES, N, N1, NERRS,
$ NMATS, NMAX, NSELC, NSELR, NTEST, NTESTT
REAL ANINV, ANORM, COND, CONDS, OVFL, RTOVFL, RTULP,
$ RTULPI, RTUNFL, TEMP1, TEMP2, ULP, ULPINV, UNFL
* ..
* .. Local Arrays ..
CHARACTER ADUMMA( 1 )
INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( MAXTYP ),
$ KMAGN( MAXTYP ), KMODE( MAXTYP ),
$ KTYPE( MAXTYP )
REAL DUMMA( 6 )
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEHRD, SGEMM, SGET10, SGET22, SHSEIN,
$ SHSEQR, SHST01, SLABAD, SLACPY, SLAFTS, SLASET,
$ SLASUM, SLATME, SLATMR, SLATMS, SORGHR, SORMHR,
$ STREVC, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL, SQRT
* ..
* .. Data statements ..
DATA KTYPE / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
DATA KMAGN / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
$ 3, 1, 2, 3 /
DATA KMODE / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
$ 1, 5, 5, 5, 4, 3, 1 /
DATA KCONDS / 3*0, 5*0, 4*1, 6*2, 3*0 /
* ..
* .. Executable Statements ..
*
* Check for errors
*
NTESTT = 0
INFO = 0
*
BADNN = .FALSE.
NMAX = 0
DO 10 J = 1, NSIZES
NMAX = MAX( NMAX, NN( J ) )
IF( NN( J ).LT.0 )
$ BADNN = .TRUE.
10 CONTINUE
*
* Check for errors
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADNN ) THEN
INFO = -2
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -3
ELSE IF( THRESH.LT.ZERO ) THEN
INFO = -6
ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN
INFO = -9
ELSE IF( LDU.LE.1 .OR. LDU.LT.NMAX ) THEN
INFO = -14
ELSE IF( 4*NMAX*NMAX+2.GT.NWORK ) THEN
INFO = -28
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SCHKHS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
$ RETURN
*
* More important constants
*
UNFL = SLAMCH( 'Safe minimum' )
OVFL = SLAMCH( 'Overflow' )
CALL SLABAD( UNFL, OVFL )
ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
ULPINV = ONE / ULP
RTUNFL = SQRT( UNFL )
RTOVFL = SQRT( OVFL )
RTULP = SQRT( ULP )
RTULPI = ONE / RTULP
*
* Loop over sizes, types
*
NERRS = 0
NMATS = 0
*
DO 270 JSIZE = 1, NSIZES
N = NN( JSIZE )
IF( N.EQ.0 )
$ GO TO 270
N1 = MAX( 1, N )
ANINV = ONE / REAL( N1 )
*
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
DO 260 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 260
NMATS = NMATS + 1
NTEST = 0
*
* Save ISEED in case of an error.
*
DO 20 J = 1, 4
IOLDSD( J ) = ISEED( J )
20 CONTINUE
*
* Initialize RESULT
*
DO 30 J = 1, 14
RESULT( J ) = ZERO
30 CONTINUE
*
* Compute "A"
*
* Control parameters:
*
* KMAGN KCONDS KMODE KTYPE
* =1 O(1) 1 clustered 1 zero
* =2 large large clustered 2 identity
* =3 small exponential Jordan
* =4 arithmetic diagonal, (w/ eigenvalues)
* =5 random log symmetric, w/ eigenvalues
* =6 random general, w/ eigenvalues
* =7 random diagonal
* =8 random symmetric
* =9 random general
* =10 random triangular
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 100
*
ITYPE = KTYPE( JTYPE )
IMODE = KMODE( JTYPE )
*
* Compute norm
*
GO TO ( 40, 50, 60 )KMAGN( JTYPE )
*
40 CONTINUE
ANORM = ONE
GO TO 70
*
50 CONTINUE
ANORM = ( RTOVFL*ULP )*ANINV
GO TO 70
*
60 CONTINUE
ANORM = RTUNFL*N*ULPINV
GO TO 70
*
70 CONTINUE
*
CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
IINFO = 0
COND = ULPINV
*
* Special Matrices
*
IF( ITYPE.EQ.1 ) THEN
*
* Zero
*
IINFO = 0
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Identity
*
DO 80 JCOL = 1, N
A( JCOL, JCOL ) = ANORM
80 CONTINUE
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* Jordan Block
*
DO 90 JCOL = 1, N
A( JCOL, JCOL ) = ANORM
IF( JCOL.GT.1 )
$ A( JCOL, JCOL-1 ) = ONE
90 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Diagonal Matrix, [Eigen]values Specified
*
CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.5 ) THEN
*
* Symmetric, eigenvalues specified
*
CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, N, N, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.6 ) THEN
*
* General, eigenvalues specified
*
IF( KCONDS( JTYPE ).EQ.1 ) THEN
CONDS = ONE
ELSE IF( KCONDS( JTYPE ).EQ.2 ) THEN
CONDS = RTULPI
ELSE
CONDS = ZERO
END IF
*
ADUMMA( 1 ) = ' '
CALL SLATME( N, 'S', ISEED, WORK, IMODE, COND, ONE,
$ ADUMMA, 'T', 'T', 'T', WORK( N+1 ), 4,
$ CONDS, N, N, ANORM, A, LDA, WORK( 2*N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.7 ) THEN
*
* Diagonal, random eigenvalues
*
CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.8 ) THEN
*
* Symmetric, random eigenvalues
*
CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.9 ) THEN
*
* General, random eigenvalues
*
CALL SLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.10 ) THEN
*
* Triangular, random eigenvalues
*
CALL SLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, 0,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE
*
IINFO = 1
END IF
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
100 CONTINUE
*
* Call SGEHRD to compute H and U, do tests.
*
CALL SLACPY( ' ', N, N, A, LDA, H, LDA )
*
NTEST = 1
*
ILO = 1
IHI = N
*
CALL SGEHRD( N, ILO, IHI, H, LDA, WORK, WORK( N+1 ),
$ NWORK-N, IINFO )
*
IF( IINFO.NE.0 ) THEN
RESULT( 1 ) = ULPINV
WRITE( NOUNIT, FMT = 9999 )'SGEHRD', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 250
END IF
*
DO 120 J = 1, N - 1
UU( J+1, J ) = ZERO
DO 110 I = J + 2, N
U( I, J ) = H( I, J )
UU( I, J ) = H( I, J )
H( I, J ) = ZERO
110 CONTINUE
120 CONTINUE
CALL SCOPY( N-1, WORK, 1, TAU, 1 )
CALL SORGHR( N, ILO, IHI, U, LDU, WORK, WORK( N+1 ),
$ NWORK-N, IINFO )
NTEST = 2
*
CALL SHST01( N, ILO, IHI, A, LDA, H, LDA, U, LDU, WORK,
$ NWORK, RESULT( 1 ) )
*
* Call SHSEQR to compute T1, T2 and Z, do tests.
*
* Eigenvalues only (WR3,WI3)
*
CALL SLACPY( ' ', N, N, H, LDA, T2, LDA )
NTEST = 3
RESULT( 3 ) = ULPINV
*
CALL SHSEQR( 'E', 'N', N, ILO, IHI, T2, LDA, WR3, WI3, UZ,
$ LDU, WORK, NWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SHSEQR(E)', IINFO, N, JTYPE,
$ IOLDSD
IF( IINFO.LE.N+2 ) THEN
INFO = ABS( IINFO )
GO TO 250
END IF
END IF
*
* Eigenvalues (WR1,WI1) and Full Schur Form (T2)
*
CALL SLACPY( ' ', N, N, H, LDA, T2, LDA )
*
CALL SHSEQR( 'S', 'N', N, ILO, IHI, T2, LDA, WR1, WI1, UZ,
$ LDU, WORK, NWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.LE.N+2 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SHSEQR(S)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 250
END IF
*
* Eigenvalues (WR1,WI1), Schur Form (T1), and Schur vectors
* (UZ)
*
CALL SLACPY( ' ', N, N, H, LDA, T1, LDA )
CALL SLACPY( ' ', N, N, U, LDU, UZ, LDA )
*
CALL SHSEQR( 'S', 'V', N, ILO, IHI, T1, LDA, WR1, WI1, UZ,
$ LDU, WORK, NWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.LE.N+2 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SHSEQR(V)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 250
END IF
*
* Compute Z = U' UZ
*
CALL SGEMM( 'T', 'N', N, N, N, ONE, U, LDU, UZ, LDU, ZERO,
$ Z, LDU )
NTEST = 8
*
* Do Tests 3: | H - Z T Z' | / ( |H| n ulp )
* and 4: | I - Z Z' | / ( n ulp )
*
CALL SHST01( N, ILO, IHI, H, LDA, T1, LDA, Z, LDU, WORK,
$ NWORK, RESULT( 3 ) )
*
* Do Tests 5: | A - UZ T (UZ)' | / ( |A| n ulp )
* and 6: | I - UZ (UZ)' | / ( n ulp )
*
CALL SHST01( N, ILO, IHI, A, LDA, T1, LDA, UZ, LDU, WORK,
$ NWORK, RESULT( 5 ) )
*
* Do Test 7: | T2 - T1 | / ( |T| n ulp )
*
CALL SGET10( N, N, T2, LDA, T1, LDA, WORK, RESULT( 7 ) )
*
* Do Test 8: | W3 - W1 | / ( max(|W1|,|W3|) ulp )
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 130 J = 1, N
TEMP1 = MAX( TEMP1, ABS( WR1( J ) )+ABS( WI1( J ) ),
$ ABS( WR3( J ) )+ABS( WI3( J ) ) )
TEMP2 = MAX( TEMP2, ABS( WR1( J )-WR3( J ) )+
$ ABS( WR1( J )-WR3( J ) ) )
130 CONTINUE
*
RESULT( 8 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) )
*
* Compute the Left and Right Eigenvectors of T
*
* Compute the Right eigenvector Matrix:
*
NTEST = 9
RESULT( 9 ) = ULPINV
*
* Select last max(N/4,1) real, max(N/4,1) complex eigenvectors
*
NSELC = 0
NSELR = 0
J = N
140 CONTINUE
IF( WI1( J ).EQ.ZERO ) THEN
IF( NSELR.LT.MAX( N / 4, 1 ) ) THEN
NSELR = NSELR + 1
SELECT( J ) = .TRUE.
ELSE
SELECT( J ) = .FALSE.
END IF
J = J - 1
ELSE
IF( NSELC.LT.MAX( N / 4, 1 ) ) THEN
NSELC = NSELC + 1
SELECT( J ) = .TRUE.
SELECT( J-1 ) = .FALSE.
ELSE
SELECT( J ) = .FALSE.
SELECT( J-1 ) = .FALSE.
END IF
J = J - 2
END IF
IF( J.GT.0 )
$ GO TO 140
*
CALL STREVC( 'Right', 'All', SELECT, N, T1, LDA, DUMMA, LDU,
$ EVECTR, LDU, N, IN, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'STREVC(R,A)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
GO TO 250
END IF
*
* Test 9: | TR - RW | / ( |T| |R| ulp )
*
CALL SGET22( 'N', 'N', 'N', N, T1, LDA, EVECTR, LDU, WR1,
$ WI1, WORK, DUMMA( 1 ) )
RESULT( 9 ) = DUMMA( 1 )
IF( DUMMA( 2 ).GT.THRESH ) THEN
WRITE( NOUNIT, FMT = 9998 )'Right', 'STREVC',
$ DUMMA( 2 ), N, JTYPE, IOLDSD
END IF
*
* Compute selected right eigenvectors and confirm that
* they agree with previous right eigenvectors
*
CALL STREVC( 'Right', 'Some', SELECT, N, T1, LDA, DUMMA,
$ LDU, EVECTL, LDU, N, IN, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'STREVC(R,S)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
GO TO 250
END IF
*
K = 1
MATCH = .TRUE.
DO 170 J = 1, N
IF( SELECT( J ) .AND. WI1( J ).EQ.ZERO ) THEN
DO 150 JJ = 1, N
IF( EVECTR( JJ, J ).NE.EVECTL( JJ, K ) ) THEN
MATCH = .FALSE.
GO TO 180
END IF
150 CONTINUE
K = K + 1
ELSE IF( SELECT( J ) .AND. WI1( J ).NE.ZERO ) THEN
DO 160 JJ = 1, N
IF( EVECTR( JJ, J ).NE.EVECTL( JJ, K ) .OR.
$ EVECTR( JJ, J+1 ).NE.EVECTL( JJ, K+1 ) ) THEN
MATCH = .FALSE.
GO TO 180
END IF
160 CONTINUE
K = K + 2
END IF
170 CONTINUE
180 CONTINUE
IF( .NOT.MATCH )
$ WRITE( NOUNIT, FMT = 9997 )'Right', 'STREVC', N, JTYPE,
$ IOLDSD
*
* Compute the Left eigenvector Matrix:
*
NTEST = 10
RESULT( 10 ) = ULPINV
CALL STREVC( 'Left', 'All', SELECT, N, T1, LDA, EVECTL, LDU,
$ DUMMA, LDU, N, IN, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'STREVC(L,A)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
GO TO 250
END IF
*
* Test 10: | LT - WL | / ( |T| |L| ulp )
*
CALL SGET22( 'Trans', 'N', 'Conj', N, T1, LDA, EVECTL, LDU,
$ WR1, WI1, WORK, DUMMA( 3 ) )
RESULT( 10 ) = DUMMA( 3 )
IF( DUMMA( 4 ).GT.THRESH ) THEN
WRITE( NOUNIT, FMT = 9998 )'Left', 'STREVC', DUMMA( 4 ),
$ N, JTYPE, IOLDSD
END IF
*
* Compute selected left eigenvectors and confirm that
* they agree with previous left eigenvectors
*
CALL STREVC( 'Left', 'Some', SELECT, N, T1, LDA, EVECTR,
$ LDU, DUMMA, LDU, N, IN, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'STREVC(L,S)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
GO TO 250
END IF
*
K = 1
MATCH = .TRUE.
DO 210 J = 1, N
IF( SELECT( J ) .AND. WI1( J ).EQ.ZERO ) THEN
DO 190 JJ = 1, N
IF( EVECTL( JJ, J ).NE.EVECTR( JJ, K ) ) THEN
MATCH = .FALSE.
GO TO 220
END IF
190 CONTINUE
K = K + 1
ELSE IF( SELECT( J ) .AND. WI1( J ).NE.ZERO ) THEN
DO 200 JJ = 1, N
IF( EVECTL( JJ, J ).NE.EVECTR( JJ, K ) .OR.
$ EVECTL( JJ, J+1 ).NE.EVECTR( JJ, K+1 ) ) THEN
MATCH = .FALSE.
GO TO 220
END IF
200 CONTINUE
K = K + 2
END IF
210 CONTINUE
220 CONTINUE
IF( .NOT.MATCH )
$ WRITE( NOUNIT, FMT = 9997 )'Left', 'STREVC', N, JTYPE,
$ IOLDSD
*
* Call SHSEIN for Right eigenvectors of H, do test 11
*
NTEST = 11
RESULT( 11 ) = ULPINV
DO 230 J = 1, N
SELECT( J ) = .TRUE.
230 CONTINUE
*
CALL SHSEIN( 'Right', 'Qr', 'Ninitv', SELECT, N, H, LDA,
$ WR3, WI3, DUMMA, LDU, EVECTX, LDU, N1, IN,
$ WORK, IWORK, IWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SHSEIN(R)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 )
$ GO TO 250
ELSE
*
* Test 11: | HX - XW | / ( |H| |X| ulp )
*
* (from inverse iteration)
*
CALL SGET22( 'N', 'N', 'N', N, H, LDA, EVECTX, LDU, WR3,
$ WI3, WORK, DUMMA( 1 ) )
IF( DUMMA( 1 ).LT.ULPINV )
$ RESULT( 11 ) = DUMMA( 1 )*ANINV
IF( DUMMA( 2 ).GT.THRESH ) THEN
WRITE( NOUNIT, FMT = 9998 )'Right', 'SHSEIN',
$ DUMMA( 2 ), N, JTYPE, IOLDSD
END IF
END IF
*
* Call SHSEIN for Left eigenvectors of H, do test 12
*
NTEST = 12
RESULT( 12 ) = ULPINV
DO 240 J = 1, N
SELECT( J ) = .TRUE.
240 CONTINUE
*
CALL SHSEIN( 'Left', 'Qr', 'Ninitv', SELECT, N, H, LDA, WR3,
$ WI3, EVECTY, LDU, DUMMA, LDU, N1, IN, WORK,
$ IWORK, IWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SHSEIN(L)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 )
$ GO TO 250
ELSE
*
* Test 12: | YH - WY | / ( |H| |Y| ulp )
*
* (from inverse iteration)
*
CALL SGET22( 'C', 'N', 'C', N, H, LDA, EVECTY, LDU, WR3,
$ WI3, WORK, DUMMA( 3 ) )
IF( DUMMA( 3 ).LT.ULPINV )
$ RESULT( 12 ) = DUMMA( 3 )*ANINV
IF( DUMMA( 4 ).GT.THRESH ) THEN
WRITE( NOUNIT, FMT = 9998 )'Left', 'SHSEIN',
$ DUMMA( 4 ), N, JTYPE, IOLDSD
END IF
END IF
*
* Call SORMHR for Right eigenvectors of A, do test 13
*
NTEST = 13
RESULT( 13 ) = ULPINV
*
CALL SORMHR( 'Left', 'No transpose', N, N, ILO, IHI, UU,
$ LDU, TAU, EVECTX, LDU, WORK, NWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SORMHR(R)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 )
$ GO TO 250
ELSE
*
* Test 13: | AX - XW | / ( |A| |X| ulp )
*
* (from inverse iteration)
*
CALL SGET22( 'N', 'N', 'N', N, A, LDA, EVECTX, LDU, WR3,
$ WI3, WORK, DUMMA( 1 ) )
IF( DUMMA( 1 ).LT.ULPINV )
$ RESULT( 13 ) = DUMMA( 1 )*ANINV
END IF
*
* Call SORMHR for Left eigenvectors of A, do test 14
*
NTEST = 14
RESULT( 14 ) = ULPINV
*
CALL SORMHR( 'Left', 'No transpose', N, N, ILO, IHI, UU,
$ LDU, TAU, EVECTY, LDU, WORK, NWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SORMHR(L)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 )
$ GO TO 250
ELSE
*
* Test 14: | YA - WY | / ( |A| |Y| ulp )
*
* (from inverse iteration)
*
CALL SGET22( 'C', 'N', 'C', N, A, LDA, EVECTY, LDU, WR3,
$ WI3, WORK, DUMMA( 3 ) )
IF( DUMMA( 3 ).LT.ULPINV )
$ RESULT( 14 ) = DUMMA( 3 )*ANINV
END IF
*
* End of Loop -- Check for RESULT(j) > THRESH
*
250 CONTINUE
*
NTESTT = NTESTT + NTEST
CALL SLAFTS( 'SHS', N, N, JTYPE, NTEST, RESULT, IOLDSD,
$ THRESH, NOUNIT, NERRS )
*
260 CONTINUE
270 CONTINUE
*
* Summary
*
CALL SLASUM( 'SHS', NOUNIT, NERRS, NTESTT )
*
RETURN
*
9999 FORMAT( ' SCHKHS: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
9998 FORMAT( ' SCHKHS: ', A, ' Eigenvectors from ', A, ' incorrectly ',
$ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 9X,
$ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5,
$ ')' )
9997 FORMAT( ' SCHKHS: Selected ', A, ' Eigenvectors from ', A,
$ ' do not match other eigenvectors ', 9X, 'N=', I6,
$ ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
*
* End of SCHKHS
*
END
SUBROUTINE SCHKSB( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, ISEED,
$ THRESH, NOUNIT, A, LDA, SD, SE, U, LDU, WORK,
$ LWORK, RESULT, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES,
$ NWDTHS
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER ISEED( 4 ), KK( * ), NN( * )
REAL A( LDA, * ), RESULT( * ), SD( * ), SE( * ),
$ U( LDU, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SCHKSB tests the reduction of a symmetric band matrix to tridiagonal
* form, used with the symmetric eigenvalue problem.
*
* SSBTRD factors a symmetric band matrix A as U S U' , where ' means
* transpose, S is symmetric tridiagonal, and U is orthogonal.
* SSBTRD can use either just the lower or just the upper triangle
* of A; SCHKSB checks both cases.
*
* When SCHKSB is called, a number of matrix "sizes" ("n's"), a number
* of bandwidths ("k's"), and a number of matrix "types" are
* specified. For each size ("n"), each bandwidth ("k") less than or
* equal to "n", and each type of matrix, one matrix will be generated
* and used to test the symmetric banded reduction routine. For each
* matrix, a number of tests will be performed:
*
* (1) | A - V S V' | / ( |A| n ulp ) computed by SSBTRD with
* UPLO='U'
*
* (2) | I - UU' | / ( n ulp )
*
* (3) | A - V S V' | / ( |A| n ulp ) computed by SSBTRD with
* UPLO='L'
*
* (4) | I - UU' | / ( n ulp )
*
* The "sizes" are specified by an array NN(1:NSIZES); the value of
* each element NN(j) specifies one size.
* The "types" are specified by a logical array DOTYPE( 1:NTYPES );
* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
* Currently, the list of possible types is:
*
* (1) The zero matrix.
* (2) The identity matrix.
*
* (3) A diagonal matrix with evenly spaced entries
* 1, ..., ULP and random signs.
* (ULP = (first number larger than 1) - 1 )
* (4) A diagonal matrix with geometrically spaced entries
* 1, ..., ULP and random signs.
* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
* and random signs.
*
* (6) Same as (4), but multiplied by SQRT( overflow threshold )
* (7) Same as (4), but multiplied by SQRT( underflow threshold )
*
* (8) A matrix of the form U' D U, where U is orthogonal and
* D has evenly spaced entries 1, ..., ULP with random signs
* on the diagonal.
*
* (9) A matrix of the form U' D U, where U is orthogonal and
* D has geometrically spaced entries 1, ..., ULP with random
* signs on the diagonal.
*
* (10) A matrix of the form U' D U, where U is orthogonal and
* D has "clustered" entries 1, ULP,..., ULP with random
* signs on the diagonal.
*
* (11) Same as (8), but multiplied by SQRT( overflow threshold )
* (12) Same as (8), but multiplied by SQRT( underflow threshold )
*
* (13) Symmetric matrix with random entries chosen from (-1,1).
* (14) Same as (13), but multiplied by SQRT( overflow threshold )
* (15) Same as (13), but multiplied by SQRT( underflow threshold )
*
* Arguments
* =========
*
* NSIZES (input) INTEGER
* The number of sizes of matrices to use. If it is zero,
* SCHKSB does nothing. It must be at least zero.
*
* NN (input) INTEGER array, dimension (NSIZES)
* An array containing the sizes to be used for the matrices.
* Zero values will be skipped. The values must be at least
* zero.
*
* NWDTHS (input) INTEGER
* The number of bandwidths to use. If it is zero,
* SCHKSB does nothing. It must be at least zero.
*
* KK (input) INTEGER array, dimension (NWDTHS)
* An array containing the bandwidths to be used for the band
* matrices. The values must be at least zero.
*
* NTYPES (input) INTEGER
* The number of elements in DOTYPE. If it is zero, SCHKSB
* does nothing. It must be at least zero. If it is MAXTYP+1
* and NSIZES is 1, then an additional type, MAXTYP+1 is
* defined, which is to use whatever matrix is in A. This
* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
* DOTYPE(MAXTYP+1) is .TRUE. .
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* If DOTYPE(j) is .TRUE., then for each size in NN a
* matrix of that size and of type j will be generated.
* If NTYPES is smaller than the maximum number of types
* defined (PARAMETER MAXTYP), then types NTYPES+1 through
* MAXTYP will not be generated. If NTYPES is larger
* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
* will be ignored.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The array elements should be between 0 and 4095;
* if not they will be reduced mod 4096. Also, ISEED(4) must
* be odd. The random number generator uses a linear
* congruential sequence limited to small integers, and so
* should produce machine independent random numbers. The
* values of ISEED are changed on exit, and can be used in the
* next call to SCHKSB to continue the same random number
* sequence.
*
* THRESH (input) REAL
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error
* is scaled to be O(1), so THRESH should be a reasonably
* small multiple of 1, e.g., 10 or 100. In particular,
* it should not depend on the precision (single vs. double)
* or the size of the matrix. It must be at least zero.
*
* NOUNIT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns IINFO not equal to 0.)
*
* A (input/workspace) REAL array, dimension
* (LDA, max(NN))
* Used to hold the matrix whose eigenvalues are to be
* computed.
*
* LDA (input) INTEGER
* The leading dimension of A. It must be at least 2 (not 1!)
* and at least max( KK )+1.
*
* SD (workspace) REAL array, dimension (max(NN))
* Used to hold the diagonal of the tridiagonal matrix computed
* by SSBTRD.
*
* SE (workspace) REAL array, dimension (max(NN))
* Used to hold the off-diagonal of the tridiagonal matrix
* computed by SSBTRD.
*
* U (workspace) REAL array, dimension (LDU, max(NN))
* Used to hold the orthogonal matrix computed by SSBTRD.
*
* LDU (input) INTEGER
* The leading dimension of U. It must be at least 1
* and at least max( NN ).
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The number of entries in WORK. This must be at least
* max( LDA+1, max(NN)+1 )*max(NN).
*
* RESULT (output) REAL array, dimension (4)
* The values computed by the tests described above.
* The values are currently limited to 1/ulp, to avoid
* overflow.
*
* INFO (output) INTEGER
* If 0, then everything ran OK.
*
*-----------------------------------------------------------------------
*
* Some Local Variables and Parameters:
* ---- ----- --------- --- ----------
* ZERO, ONE Real 0 and 1.
* MAXTYP The number of types defined.
* NTEST The number of tests performed, or which can
* be performed so far, for the current matrix.
* NTESTT The total number of tests performed so far.
* NMAX Largest value in NN.
* NMATS The number of matrices generated so far.
* NERRS The number of tests which have exceeded THRESH
* so far.
* COND, IMODE Values to be passed to the matrix generators.
* ANORM Norm of A; passed to matrix generators.
*
* OVFL, UNFL Overflow and underflow thresholds.
* ULP, ULPINV Finest relative precision and its inverse.
* RTOVFL, RTUNFL Square roots of the previous 2 values.
* The following four arrays decode JTYPE:
* KTYPE(j) The general type (1-10) for type "j".
* KMODE(j) The MODE value to be passed to the matrix
* generator for type "j".
* KMAGN(j) The order of magnitude ( O(1),
* O(overflow^(1/2) ), O(underflow^(1/2) )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO, TEN
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ TEN = 10.0E0 )
REAL HALF
PARAMETER ( HALF = ONE / TWO )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 15 )
* ..
* .. Local Scalars ..
LOGICAL BADNN, BADNNB
INTEGER I, IINFO, IMODE, ITYPE, J, JC, JCOL, JR, JSIZE,
$ JTYPE, JWIDTH, K, KMAX, MTYPES, N, NERRS,
$ NMATS, NMAX, NTEST, NTESTT
REAL ANINV, ANORM, COND, OVFL, RTOVFL, RTUNFL,
$ TEMP1, ULP, ULPINV, UNFL
* ..
* .. Local Arrays ..
INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KMAGN( MAXTYP ),
$ KMODE( MAXTYP ), KTYPE( MAXTYP )
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SLACPY, SLASUM, SLATMR, SLATMS, SLASET, SSBT21,
$ SSBTRD, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL, SQRT
* ..
* .. Data statements ..
DATA KTYPE / 1, 2, 5*4, 5*5, 3*8 /
DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
$ 2, 3 /
DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
$ 0, 0 /
* ..
* .. Executable Statements ..
*
* Check for errors
*
NTESTT = 0
INFO = 0
*
* Important constants
*
BADNN = .FALSE.
NMAX = 1
DO 10 J = 1, NSIZES
NMAX = MAX( NMAX, NN( J ) )
IF( NN( J ).LT.0 )
$ BADNN = .TRUE.
10 CONTINUE
*
BADNNB = .FALSE.
KMAX = 0
DO 20 J = 1, NSIZES
KMAX = MAX( KMAX, KK( J ) )
IF( KK( J ).LT.0 )
$ BADNNB = .TRUE.
20 CONTINUE
KMAX = MIN( NMAX-1, KMAX )
*
* Check for errors
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADNN ) THEN
INFO = -2
ELSE IF( NWDTHS.LT.0 ) THEN
INFO = -3
ELSE IF( BADNNB ) THEN
INFO = -4
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.KMAX+1 ) THEN
INFO = -11
ELSE IF( LDU.LT.NMAX ) THEN
INFO = -15
ELSE IF( ( MAX( LDA, NMAX )+1 )*NMAX.GT.LWORK ) THEN
INFO = -17
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SCHKSB', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 .OR. NWDTHS.EQ.0 )
$ RETURN
*
* More Important constants
*
UNFL = SLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
ULPINV = ONE / ULP
RTUNFL = SQRT( UNFL )
RTOVFL = SQRT( OVFL )
*
* Loop over sizes, types
*
NERRS = 0
NMATS = 0
*
DO 190 JSIZE = 1, NSIZES
N = NN( JSIZE )
ANINV = ONE / REAL( MAX( 1, N ) )
*
DO 180 JWIDTH = 1, NWDTHS
K = KK( JWIDTH )
IF( K.GT.N )
$ GO TO 180
K = MAX( 0, MIN( N-1, K ) )
*
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
DO 170 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 170
NMATS = NMATS + 1
NTEST = 0
*
DO 30 J = 1, 4
IOLDSD( J ) = ISEED( J )
30 CONTINUE
*
* Compute "A".
* Store as "Upper"; later, we will copy to other format.
*
* Control parameters:
*
* KMAGN KMODE KTYPE
* =1 O(1) clustered 1 zero
* =2 large clustered 2 identity
* =3 small exponential (none)
* =4 arithmetic diagonal, (w/ eigenvalues)
* =5 random log symmetric, w/ eigenvalues
* =6 random (none)
* =7 random diagonal
* =8 random symmetric
* =9 positive definite
* =10 diagonally dominant tridiagonal
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 100
*
ITYPE = KTYPE( JTYPE )
IMODE = KMODE( JTYPE )
*
* Compute norm
*
GO TO ( 40, 50, 60 )KMAGN( JTYPE )
*
40 CONTINUE
ANORM = ONE
GO TO 70
*
50 CONTINUE
ANORM = ( RTOVFL*ULP )*ANINV
GO TO 70
*
60 CONTINUE
ANORM = RTUNFL*N*ULPINV
GO TO 70
*
70 CONTINUE
*
CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
IINFO = 0
IF( JTYPE.LE.15 ) THEN
COND = ULPINV
ELSE
COND = ULPINV*ANINV / TEN
END IF
*
* Special Matrices -- Identity & Jordan block
*
* Zero
*
IF( ITYPE.EQ.1 ) THEN
IINFO = 0
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Identity
*
DO 80 JCOL = 1, N
A( K+1, JCOL ) = ANORM
80 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Diagonal Matrix, [Eigen]values Specified
*
CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, 0, 0, 'Q', A( K+1, 1 ), LDA,
$ WORK( N+1 ), IINFO )
*
ELSE IF( ITYPE.EQ.5 ) THEN
*
* Symmetric, eigenvalues specified
*
CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, K, K, 'Q', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.7 ) THEN
*
* Diagonal, random eigenvalues
*
CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
$ ZERO, ANORM, 'Q', A( K+1, 1 ), LDA,
$ IDUMMA, IINFO )
*
ELSE IF( ITYPE.EQ.8 ) THEN
*
* Symmetric, random eigenvalues
*
CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, K, K,
$ ZERO, ANORM, 'Q', A, LDA, IDUMMA, IINFO )
*
ELSE IF( ITYPE.EQ.9 ) THEN
*
* Positive definite, eigenvalues specified.
*
CALL SLATMS( N, N, 'S', ISEED, 'P', WORK, IMODE, COND,
$ ANORM, K, K, 'Q', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.10 ) THEN
*
* Positive definite tridiagonal, eigenvalues specified.
*
IF( N.GT.1 )
$ K = MAX( 1, K )
CALL SLATMS( N, N, 'S', ISEED, 'P', WORK, IMODE, COND,
$ ANORM, 1, 1, 'Q', A( K, 1 ), LDA,
$ WORK( N+1 ), IINFO )
DO 90 I = 2, N
TEMP1 = ABS( A( K, I ) ) /
$ SQRT( ABS( A( K+1, I-1 )*A( K+1, I ) ) )
IF( TEMP1.GT.HALF ) THEN
A( K, I ) = HALF*SQRT( ABS( A( K+1,
$ I-1 )*A( K+1, I ) ) )
END IF
90 CONTINUE
*
ELSE
*
IINFO = 1
END IF
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
100 CONTINUE
*
* Call SSBTRD to compute S and U from upper triangle.
*
CALL SLACPY( ' ', K+1, N, A, LDA, WORK, LDA )
*
NTEST = 1
CALL SSBTRD( 'V', 'U', N, K, WORK, LDA, SD, SE, U, LDU,
$ WORK( LDA*N+1 ), IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSBTRD(U)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 1 ) = ULPINV
GO TO 150
END IF
END IF
*
* Do tests 1 and 2
*
CALL SSBT21( 'Upper', N, K, 1, A, LDA, SD, SE, U, LDU,
$ WORK, RESULT( 1 ) )
*
* Convert A from Upper-Triangle-Only storage to
* Lower-Triangle-Only storage.
*
DO 120 JC = 1, N
DO 110 JR = 0, MIN( K, N-JC )
A( JR+1, JC ) = A( K+1-JR, JC+JR )
110 CONTINUE
120 CONTINUE
DO 140 JC = N + 1 - K, N
DO 130 JR = MIN( K, N-JC ) + 1, K
A( JR+1, JC ) = ZERO
130 CONTINUE
140 CONTINUE
*
* Call SSBTRD to compute S and U from lower triangle
*
CALL SLACPY( ' ', K+1, N, A, LDA, WORK, LDA )
*
NTEST = 3
CALL SSBTRD( 'V', 'L', N, K, WORK, LDA, SD, SE, U, LDU,
$ WORK( LDA*N+1 ), IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSBTRD(L)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 3 ) = ULPINV
GO TO 150
END IF
END IF
NTEST = 4
*
* Do tests 3 and 4
*
CALL SSBT21( 'Lower', N, K, 1, A, LDA, SD, SE, U, LDU,
$ WORK, RESULT( 3 ) )
*
* End of Loop -- Check for RESULT(j) > THRESH
*
150 CONTINUE
NTESTT = NTESTT + NTEST
*
* Print out tests which fail.
*
DO 160 JR = 1, NTEST
IF( RESULT( JR ).GE.THRESH ) THEN
*
* If this is the first test to fail,
* print a header to the data file.
*
IF( NERRS.EQ.0 ) THEN
WRITE( NOUNIT, FMT = 9998 )'SSB'
WRITE( NOUNIT, FMT = 9997 )
WRITE( NOUNIT, FMT = 9996 )
WRITE( NOUNIT, FMT = 9995 )'Symmetric'
WRITE( NOUNIT, FMT = 9994 )'orthogonal', '''',
$ 'transpose', ( '''', J = 1, 4 )
END IF
NERRS = NERRS + 1
WRITE( NOUNIT, FMT = 9993 )N, K, IOLDSD, JTYPE,
$ JR, RESULT( JR )
END IF
160 CONTINUE
*
170 CONTINUE
180 CONTINUE
190 CONTINUE
*
* Summary
*
CALL SLASUM( 'SSB', NOUNIT, NERRS, NTESTT )
RETURN
*
9999 FORMAT( ' SCHKSB: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
*
9998 FORMAT( / 1X, A3,
$ ' -- Real Symmetric Banded Tridiagonal Reduction Routines' )
9997 FORMAT( ' Matrix types (see SCHKSB for details): ' )
*
9996 FORMAT( / ' Special Matrices:',
$ / ' 1=Zero matrix. ',
$ ' 5=Diagonal: clustered entries.',
$ / ' 2=Identity matrix. ',
$ ' 6=Diagonal: large, evenly spaced.',
$ / ' 3=Diagonal: evenly spaced entries. ',
$ ' 7=Diagonal: small, evenly spaced.',
$ / ' 4=Diagonal: geometr. spaced entries.' )
9995 FORMAT( ' Dense ', A, ' Banded Matrices:',
$ / ' 8=Evenly spaced eigenvals. ',
$ ' 12=Small, evenly spaced eigenvals.',
$ / ' 9=Geometrically spaced eigenvals. ',
$ ' 13=Matrix with random O(1) entries.',
$ / ' 10=Clustered eigenvalues. ',
$ ' 14=Matrix with large random entries.',
$ / ' 11=Large, evenly spaced eigenvals. ',
$ ' 15=Matrix with small random entries.' )
*
9994 FORMAT( / ' Tests performed: (S is Tridiag, U is ', A, ',',
$ / 20X, A, ' means ', A, '.', / ' UPLO=''U'':',
$ / ' 1= | A - U S U', A1, ' | / ( |A| n ulp ) ',
$ ' 2= | I - U U', A1, ' | / ( n ulp )', / ' UPLO=''L'':',
$ / ' 3= | A - U S U', A1, ' | / ( |A| n ulp ) ',
$ ' 4= | I - U U', A1, ' | / ( n ulp )' )
9993 FORMAT( ' N=', I5, ', K=', I4, ', seed=', 4( I4, ',' ), ' type ',
$ I2, ', test(', I2, ')=', G10.3 )
*
* End of SCHKSB
*
END
SUBROUTINE SCHKST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
$ NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5,
$ WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK,
$ LWORK, IWORK, LIWORK, RESULT, INFO )
IMPLICIT NONE
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES,
$ NTYPES
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER ISEED( 4 ), IWORK( * ), NN( * )
REAL A( LDA, * ), AP( * ), D1( * ), D2( * ),
$ D3( * ), D4( * ), D5( * ), RESULT( * ),
$ SD( * ), SE( * ), TAU( * ), U( LDU, * ),
$ V( LDU, * ), VP( * ), WA1( * ), WA2( * ),
$ WA3( * ), WORK( * ), WR( * ), Z( LDU, * )
* ..
*
* Purpose
* =======
*
* SCHKST checks the symmetric eigenvalue problem routines.
*
* SSYTRD factors A as U S U' , where ' means transpose,
* S is symmetric tridiagonal, and U is orthogonal.
* SSYTRD can use either just the lower or just the upper triangle
* of A; SCHKST checks both cases.
* U is represented as a product of Householder
* transformations, whose vectors are stored in the first
* n-1 columns of V, and whose scale factors are in TAU.
*
* SSPTRD does the same as SSYTRD, except that A and V are stored
* in "packed" format.
*
* SORGTR constructs the matrix U from the contents of V and TAU.
*
* SOPGTR constructs the matrix U from the contents of VP and TAU.
*
* SSTEQR factors S as Z D1 Z' , where Z is the orthogonal
* matrix of eigenvectors and D1 is a diagonal matrix with
* the eigenvalues on the diagonal. D2 is the matrix of
* eigenvalues computed when Z is not computed.
*
* SSTERF computes D3, the matrix of eigenvalues, by the
* PWK method, which does not yield eigenvectors.
*
* SPTEQR factors S as Z4 D4 Z4' , for a
* symmetric positive definite tridiagonal matrix.
* D5 is the matrix of eigenvalues computed when Z is not
* computed.
*
* SSTEBZ computes selected eigenvalues. WA1, WA2, and
* WA3 will denote eigenvalues computed to high
* absolute accuracy, with different range options.
* WR will denote eigenvalues computed to high relative
* accuracy.
*
* SSTEIN computes Y, the eigenvectors of S, given the
* eigenvalues.
*
* SSTEDC factors S as Z D1 Z' , where Z is the orthogonal
* matrix of eigenvectors and D1 is a diagonal matrix with
* the eigenvalues on the diagonal ('I' option). It may also
* update an input orthogonal matrix, usually the output
* from SSYTRD/SORGTR or SSPTRD/SOPGTR ('V' option). It may
* also just compute eigenvalues ('N' option).
*
* SSTEMR factors S as Z D1 Z' , where Z is the orthogonal
* matrix of eigenvectors and D1 is a diagonal matrix with
* the eigenvalues on the diagonal ('I' option). SSTEMR
* uses the Relatively Robust Representation whenever possible.
*
* When SCHKST is called, a number of matrix "sizes" ("n's") and a
* number of matrix "types" are specified. For each size ("n")
* and each type of matrix, one matrix will be generated and used
* to test the symmetric eigenroutines. For each matrix, a number
* of tests will be performed:
*
* (1) | A - V S V' | / ( |A| n ulp ) SSYTRD( UPLO='U', ... )
*
* (2) | I - UV' | / ( n ulp ) SORGTR( UPLO='U', ... )
*
* (3) | A - V S V' | / ( |A| n ulp ) SSYTRD( UPLO='L', ... )
*
* (4) | I - UV' | / ( n ulp ) SORGTR( UPLO='L', ... )
*
* (5-8) Same as 1-4, but for SSPTRD and SOPGTR.
*
* (9) | S - Z D Z' | / ( |S| n ulp ) SSTEQR('V',...)
*
* (10) | I - ZZ' | / ( n ulp ) SSTEQR('V',...)
*
* (11) | D1 - D2 | / ( |D1| ulp ) SSTEQR('N',...)
*
* (12) | D1 - D3 | / ( |D1| ulp ) SSTERF
*
* (13) 0 if the true eigenvalues (computed by sturm count)
* of S are within THRESH of
* those in D1. 2*THRESH if they are not. (Tested using
* SSTECH)
*
* For S positive definite,
*
* (14) | S - Z4 D4 Z4' | / ( |S| n ulp ) SPTEQR('V',...)
*
* (15) | I - Z4 Z4' | / ( n ulp ) SPTEQR('V',...)
*
* (16) | D4 - D5 | / ( 100 |D4| ulp ) SPTEQR('N',...)
*
* When S is also diagonally dominant by the factor gamma < 1,
*
* (17) max | D4(i) - WR(i) | / ( |D4(i)| omega ) ,
* i
* omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4
* SSTEBZ( 'A', 'E', ...)
*
* (18) | WA1 - D3 | / ( |D3| ulp ) SSTEBZ( 'A', 'E', ...)
*
* (19) ( max { min | WA2(i)-WA3(j) | } +
* i j
* max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
* i j
* SSTEBZ( 'I', 'E', ...)
*
* (20) | S - Y WA1 Y' | / ( |S| n ulp ) SSTEBZ, SSTEIN
*
* (21) | I - Y Y' | / ( n ulp ) SSTEBZ, SSTEIN
*
* (22) | S - Z D Z' | / ( |S| n ulp ) SSTEDC('I')
*
* (23) | I - ZZ' | / ( n ulp ) SSTEDC('I')
*
* (24) | S - Z D Z' | / ( |S| n ulp ) SSTEDC('V')
*
* (25) | I - ZZ' | / ( n ulp ) SSTEDC('V')
*
* (26) | D1 - D2 | / ( |D1| ulp ) SSTEDC('V') and
* SSTEDC('N')
*
* Test 27 is disabled at the moment because SSTEMR does not
* guarantee high relatvie accuracy.
*
* (27) max | D6(i) - WR(i) | / ( |D6(i)| omega ) ,
* i
* omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4
* SSTEMR('V', 'A')
*
* (28) max | D6(i) - WR(i) | / ( |D6(i)| omega ) ,
* i
* omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4
* SSTEMR('V', 'I')
*
* Tests 29 through 34 are disable at present because SSTEMR
* does not handle partial specturm requests.
*
* (29) | S - Z D Z' | / ( |S| n ulp ) SSTEMR('V', 'I')
*
* (30) | I - ZZ' | / ( n ulp ) SSTEMR('V', 'I')
*
* (31) ( max { min | WA2(i)-WA3(j) | } +
* i j
* max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
* i j
* SSTEMR('N', 'I') vs. SSTEMR('V', 'I')
*
* (32) | S - Z D Z' | / ( |S| n ulp ) SSTEMR('V', 'V')
*
* (33) | I - ZZ' | / ( n ulp ) SSTEMR('V', 'V')
*
* (34) ( max { min | WA2(i)-WA3(j) | } +
* i j
* max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
* i j
* SSTEMR('N', 'V') vs. SSTEMR('V', 'V')
*
* (35) | S - Z D Z' | / ( |S| n ulp ) SSTEMR('V', 'A')
*
* (36) | I - ZZ' | / ( n ulp ) SSTEMR('V', 'A')
*
* (37) ( max { min | WA2(i)-WA3(j) | } +
* i j
* max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
* i j
* SSTEMR('N', 'A') vs. SSTEMR('V', 'A')
*
* The "sizes" are specified by an array NN(1:NSIZES); the value of
* each element NN(j) specifies one size.
* The "types" are specified by a logical array DOTYPE( 1:NTYPES );
* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
* Currently, the list of possible types is:
*
* (1) The zero matrix.
* (2) The identity matrix.
*
* (3) A diagonal matrix with evenly spaced entries
* 1, ..., ULP and random signs.
* (ULP = (first number larger than 1) - 1 )
* (4) A diagonal matrix with geometrically spaced entries
* 1, ..., ULP and random signs.
* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
* and random signs.
*
* (6) Same as (4), but multiplied by SQRT( overflow threshold )
* (7) Same as (4), but multiplied by SQRT( underflow threshold )
*
* (8) A matrix of the form U' D U, where U is orthogonal and
* D has evenly spaced entries 1, ..., ULP with random signs
* on the diagonal.
*
* (9) A matrix of the form U' D U, where U is orthogonal and
* D has geometrically spaced entries 1, ..., ULP with random
* signs on the diagonal.
*
* (10) A matrix of the form U' D U, where U is orthogonal and
* D has "clustered" entries 1, ULP,..., ULP with random
* signs on the diagonal.
*
* (11) Same as (8), but multiplied by SQRT( overflow threshold )
* (12) Same as (8), but multiplied by SQRT( underflow threshold )
*
* (13) Symmetric matrix with random entries chosen from (-1,1).
* (14) Same as (13), but multiplied by SQRT( overflow threshold )
* (15) Same as (13), but multiplied by SQRT( underflow threshold )
* (16) Same as (8), but diagonal elements are all positive.
* (17) Same as (9), but diagonal elements are all positive.
* (18) Same as (10), but diagonal elements are all positive.
* (19) Same as (16), but multiplied by SQRT( overflow threshold )
* (20) Same as (16), but multiplied by SQRT( underflow threshold )
* (21) A diagonally dominant tridiagonal matrix with geometrically
* spaced diagonal entries 1, ..., ULP.
*
* Arguments
* =========
*
* NSIZES (input) INTEGER
* The number of sizes of matrices to use. If it is zero,
* SCHKST does nothing. It must be at least zero.
*
* NN (input) INTEGER array, dimension (NSIZES)
* An array containing the sizes to be used for the matrices.
* Zero values will be skipped. The values must be at least
* zero.
*
* NTYPES (input) INTEGER
* The number of elements in DOTYPE. If it is zero, SCHKST
* does nothing. It must be at least zero. If it is MAXTYP+1
* and NSIZES is 1, then an additional type, MAXTYP+1 is
* defined, which is to use whatever matrix is in A. This
* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
* DOTYPE(MAXTYP+1) is .TRUE. .
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* If DOTYPE(j) is .TRUE., then for each size in NN a
* matrix of that size and of type j will be generated.
* If NTYPES is smaller than the maximum number of types
* defined (PARAMETER MAXTYP), then types NTYPES+1 through
* MAXTYP will not be generated. If NTYPES is larger
* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
* will be ignored.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The array elements should be between 0 and 4095;
* if not they will be reduced mod 4096. Also, ISEED(4) must
* be odd. The random number generator uses a linear
* congruential sequence limited to small integers, and so
* should produce machine independent random numbers. The
* values of ISEED are changed on exit, and can be used in the
* next call to SCHKST to continue the same random number
* sequence.
*
* THRESH (input) REAL
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error
* is scaled to be O(1), so THRESH should be a reasonably
* small multiple of 1, e.g., 10 or 100. In particular,
* it should not depend on the precision (single vs. double)
* or the size of the matrix. It must be at least zero.
*
* NOUNIT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns IINFO not equal to 0.)
*
* A (input/workspace/output) REAL array of
* dimension ( LDA , max(NN) )
* Used to hold the matrix whose eigenvalues are to be
* computed. On exit, A contains the last matrix actually
* used.
*
* LDA (input) INTEGER
* The leading dimension of A. It must be at
* least 1 and at least max( NN ).
*
* AP (workspace) REAL array of
* dimension( max(NN)*max(NN+1)/2 )
* The matrix A stored in packed format.
*
* SD (workspace/output) REAL array of
* dimension( max(NN) )
* The diagonal of the tridiagonal matrix computed by SSYTRD.
* On exit, SD and SE contain the tridiagonal form of the
* matrix in A.
*
* SE (workspace/output) REAL array of
* dimension( max(NN) )
* The off-diagonal of the tridiagonal matrix computed by
* SSYTRD. On exit, SD and SE contain the tridiagonal form of
* the matrix in A.
*
* D1 (workspace/output) REAL array of
* dimension( max(NN) )
* The eigenvalues of A, as computed by SSTEQR simlutaneously
* with Z. On exit, the eigenvalues in D1 correspond with the
* matrix in A.
*
* D2 (workspace/output) REAL array of
* dimension( max(NN) )
* The eigenvalues of A, as computed by SSTEQR if Z is not
* computed. On exit, the eigenvalues in D2 correspond with
* the matrix in A.
*
* D3 (workspace/output) REAL array of
* dimension( max(NN) )
* The eigenvalues of A, as computed by SSTERF. On exit, the
* eigenvalues in D3 correspond with the matrix in A.
*
* U (workspace/output) REAL array of
* dimension( LDU, max(NN) ).
* The orthogonal matrix computed by SSYTRD + SORGTR.
*
* LDU (input) INTEGER
* The leading dimension of U, Z, and V. It must be at least 1
* and at least max( NN ).
*
* V (workspace/output) REAL array of
* dimension( LDU, max(NN) ).
* The Housholder vectors computed by SSYTRD in reducing A to
* tridiagonal form. The vectors computed with UPLO='U' are
* in the upper triangle, and the vectors computed with UPLO='L'
* are in the lower triangle. (As described in SSYTRD, the
* sub- and superdiagonal are not set to 1, although the
* true Householder vector has a 1 in that position. The
* routines that use V, such as SORGTR, set those entries to
* 1 before using them, and then restore them later.)
*
* VP (workspace) REAL array of
* dimension( max(NN)*max(NN+1)/2 )
* The matrix V stored in packed format.
*
* TAU (workspace/output) REAL array of
* dimension( max(NN) )
* The Householder factors computed by SSYTRD in reducing A
* to tridiagonal form.
*
* Z (workspace/output) REAL array of
* dimension( LDU, max(NN) ).
* The orthogonal matrix of eigenvectors computed by SSTEQR,
* SPTEQR, and SSTEIN.
*
* WORK (workspace/output) REAL array of
* dimension( LWORK )
*
* LWORK (input) INTEGER
* The number of entries in WORK. This must be at least
* 1 + 4 * Nmax + 2 * Nmax * lg Nmax + 3 * Nmax**2
* where Nmax = max( NN(j), 2 ) and lg = log base 2.
*
* IWORK (workspace/output) INTEGER array,
* dimension (6 + 6*Nmax + 5 * Nmax * lg Nmax )
* where Nmax = max( NN(j), 2 ) and lg = log base 2.
* Workspace.
*
* RESULT (output) REAL array, dimension (26)
* The values computed by the tests described above.
* The values are currently limited to 1/ulp, to avoid
* overflow.
*
* INFO (output) INTEGER
* If 0, then everything ran OK.
* -1: NSIZES < 0
* -2: Some NN(j) < 0
* -3: NTYPES < 0
* -5: THRESH < 0
* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
* -23: LDU < 1 or LDU < NMAX.
* -29: LWORK too small.
* If SLATMR, SLATMS, SSYTRD, SORGTR, SSTEQR, SSTERF,
* or SORMC2 returns an error code, the
* absolute value of it is returned.
*
*-----------------------------------------------------------------------
*
* Some Local Variables and Parameters:
* ---- ----- --------- --- ----------
* ZERO, ONE Real 0 and 1.
* MAXTYP The number of types defined.
* NTEST The number of tests performed, or which can
* be performed so far, for the current matrix.
* NTESTT The total number of tests performed so far.
* NBLOCK Blocksize as returned by ENVIR.
* NMAX Largest value in NN.
* NMATS The number of matrices generated so far.
* NERRS The number of tests which have exceeded THRESH
* so far.
* COND, IMODE Values to be passed to the matrix generators.
* ANORM Norm of A; passed to matrix generators.
*
* OVFL, UNFL Overflow and underflow thresholds.
* ULP, ULPINV Finest relative precision and its inverse.
* RTOVFL, RTUNFL Square roots of the previous 2 values.
* The following four arrays decode JTYPE:
* KTYPE(j) The general type (1-10) for type "j".
* KMODE(j) The MODE value to be passed to the matrix
* generator for type "j".
* KMAGN(j) The order of magnitude ( O(1),
* O(overflow^(1/2) ), O(underflow^(1/2) )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO, EIGHT, TEN, HUN
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ EIGHT = 8.0E0, TEN = 10.0E0, HUN = 100.0E0 )
REAL HALF
PARAMETER ( HALF = ONE / TWO )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 21 )
LOGICAL SRANGE
PARAMETER ( SRANGE = .FALSE. )
LOGICAL SREL
PARAMETER ( SREL = .FALSE. )
* ..
* .. Local Scalars ..
LOGICAL BADNN, TRYRAC
INTEGER I, IINFO, IL, IMODE, ITEMP, ITYPE, IU, J, JC,
$ JR, JSIZE, JTYPE, LGN, LIWEDC, LOG2UI, LWEDC,
$ M, M2, M3, MTYPES, N, NAP, NBLOCK, NERRS,
$ NMATS, NMAX, NSPLIT, NTEST, NTESTT
REAL ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
$ RTUNFL, TEMP1, TEMP2, TEMP3, TEMP4, ULP,
$ ULPINV, UNFL, VL, VU
* ..
* .. Local Arrays ..
INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
$ KMAGN( MAXTYP ), KMODE( MAXTYP ),
$ KTYPE( MAXTYP )
REAL DUMMA( 1 )
* ..
* .. External Functions ..
INTEGER ILAENV
REAL SLAMCH, SLARND, SSXT1
EXTERNAL ILAENV, SLAMCH, SLARND, SSXT1
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLABAD, SLACPY, SLASET, SLASUM, SLATMR,
$ SLATMS, SOPGTR, SORGTR, SPTEQR, SSPT21, SSPTRD,
$ SSTEBZ, SSTECH, SSTEDC, SSTEMR, SSTEIN, SSTEQR,
$ SSTERF, SSTT21, SSTT22, SSYT21, SSYTRD, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX, MIN, REAL, SQRT
* ..
* .. Data statements ..
DATA KTYPE / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8,
$ 8, 8, 9, 9, 9, 9, 9, 10 /
DATA KMAGN / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
$ 2, 3, 1, 1, 1, 2, 3, 1 /
DATA KMODE / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
$ 0, 0, 4, 3, 1, 4, 4, 3 /
* ..
* .. Executable Statements ..
*
* Keep ftnchek happy
IDUMMA( 1 ) = 1
*
* Check for errors
*
NTESTT = 0
INFO = 0
*
* Important constants
*
BADNN = .FALSE.
TRYRAC = .TRUE.
NMAX = 1
DO 10 J = 1, NSIZES
NMAX = MAX( NMAX, NN( J ) )
IF( NN( J ).LT.0 )
$ BADNN = .TRUE.
10 CONTINUE
*
NBLOCK = ILAENV( 1, 'SSYTRD', 'L', NMAX, -1, -1, -1 )
NBLOCK = MIN( NMAX, MAX( 1, NBLOCK ) )
*
* Check for errors
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADNN ) THEN
INFO = -2
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.NMAX ) THEN
INFO = -9
ELSE IF( LDU.LT.NMAX ) THEN
INFO = -23
ELSE IF( 2*MAX( 2, NMAX )**2.GT.LWORK ) THEN
INFO = -29
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SCHKST', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
$ RETURN
*
* More Important constants
*
UNFL = SLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
CALL SLABAD( UNFL, OVFL )
ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
ULPINV = ONE / ULP
LOG2UI = INT( LOG( ULPINV ) / LOG( TWO ) )
RTUNFL = SQRT( UNFL )
RTOVFL = SQRT( OVFL )
*
* Loop over sizes, types
*
DO 20 I = 1, 4
ISEED2( I ) = ISEED( I )
20 CONTINUE
NERRS = 0
NMATS = 0
*
DO 310 JSIZE = 1, NSIZES
N = NN( JSIZE )
IF( N.GT.0 ) THEN
LGN = INT( LOG( REAL( N ) ) / LOG( TWO ) )
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
LWEDC = 1 + 4*N + 2*N*LGN + 3*N**2
LIWEDC = 6 + 6*N + 5*N*LGN
ELSE
LWEDC = 8
LIWEDC = 12
END IF
NAP = ( N*( N+1 ) ) / 2
ANINV = ONE / REAL( MAX( 1, N ) )
*
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
DO 300 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 300
NMATS = NMATS + 1
NTEST = 0
*
DO 30 J = 1, 4
IOLDSD( J ) = ISEED( J )
30 CONTINUE
*
* Compute "A"
*
* Control parameters:
*
* KMAGN KMODE KTYPE
* =1 O(1) clustered 1 zero
* =2 large clustered 2 identity
* =3 small exponential (none)
* =4 arithmetic diagonal, (w/ eigenvalues)
* =5 random log symmetric, w/ eigenvalues
* =6 random (none)
* =7 random diagonal
* =8 random symmetric
* =9 positive definite
* =10 diagonally dominant tridiagonal
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 100
*
ITYPE = KTYPE( JTYPE )
IMODE = KMODE( JTYPE )
*
* Compute norm
*
GO TO ( 40, 50, 60 )KMAGN( JTYPE )
*
40 CONTINUE
ANORM = ONE
GO TO 70
*
50 CONTINUE
ANORM = ( RTOVFL*ULP )*ANINV
GO TO 70
*
60 CONTINUE
ANORM = RTUNFL*N*ULPINV
GO TO 70
*
70 CONTINUE
*
CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
IINFO = 0
IF( JTYPE.LE.15 ) THEN
COND = ULPINV
ELSE
COND = ULPINV*ANINV / TEN
END IF
*
* Special Matrices -- Identity & Jordan block
*
* Zero
*
IF( ITYPE.EQ.1 ) THEN
IINFO = 0
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Identity
*
DO 80 JC = 1, N
A( JC, JC ) = ANORM
80 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Diagonal Matrix, [Eigen]values Specified
*
CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
*
ELSE IF( ITYPE.EQ.5 ) THEN
*
* Symmetric, eigenvalues specified
*
CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, N, N, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.7 ) THEN
*
* Diagonal, random eigenvalues
*
CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.8 ) THEN
*
* Symmetric, random eigenvalues
*
CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.9 ) THEN
*
* Positive definite, eigenvalues specified.
*
CALL SLATMS( N, N, 'S', ISEED, 'P', WORK, IMODE, COND,
$ ANORM, N, N, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.10 ) THEN
*
* Positive definite tridiagonal, eigenvalues specified.
*
CALL SLATMS( N, N, 'S', ISEED, 'P', WORK, IMODE, COND,
$ ANORM, 1, 1, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
DO 90 I = 2, N
TEMP1 = ABS( A( I-1, I ) ) /
$ SQRT( ABS( A( I-1, I-1 )*A( I, I ) ) )
IF( TEMP1.GT.HALF ) THEN
A( I-1, I ) = HALF*SQRT( ABS( A( I-1, I-1 )*A( I,
$ I ) ) )
A( I, I-1 ) = A( I-1, I )
END IF
90 CONTINUE
*
ELSE
*
IINFO = 1
END IF
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
100 CONTINUE
*
* Call SSYTRD and SORGTR to compute S and U from
* upper triangle.
*
CALL SLACPY( 'U', N, N, A, LDA, V, LDU )
*
NTEST = 1
CALL SSYTRD( 'U', N, V, LDU, SD, SE, TAU, WORK, LWORK,
$ IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSYTRD(U)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 1 ) = ULPINV
GO TO 280
END IF
END IF
*
CALL SLACPY( 'U', N, N, V, LDU, U, LDU )
*
NTEST = 2
CALL SORGTR( 'U', N, U, LDU, TAU, WORK, LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SORGTR(U)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 2 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do tests 1 and 2
*
CALL SSYT21( 2, 'Upper', N, 1, A, LDA, SD, SE, U, LDU, V,
$ LDU, TAU, WORK, RESULT( 1 ) )
CALL SSYT21( 3, 'Upper', N, 1, A, LDA, SD, SE, U, LDU, V,
$ LDU, TAU, WORK, RESULT( 2 ) )
*
* Call SSYTRD and SORGTR to compute S and U from
* lower triangle, do tests.
*
CALL SLACPY( 'L', N, N, A, LDA, V, LDU )
*
NTEST = 3
CALL SSYTRD( 'L', N, V, LDU, SD, SE, TAU, WORK, LWORK,
$ IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSYTRD(L)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 3 ) = ULPINV
GO TO 280
END IF
END IF
*
CALL SLACPY( 'L', N, N, V, LDU, U, LDU )
*
NTEST = 4
CALL SORGTR( 'L', N, U, LDU, TAU, WORK, LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SORGTR(L)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 4 ) = ULPINV
GO TO 280
END IF
END IF
*
CALL SSYT21( 2, 'Lower', N, 1, A, LDA, SD, SE, U, LDU, V,
$ LDU, TAU, WORK, RESULT( 3 ) )
CALL SSYT21( 3, 'Lower', N, 1, A, LDA, SD, SE, U, LDU, V,
$ LDU, TAU, WORK, RESULT( 4 ) )
*
* Store the upper triangle of A in AP
*
I = 0
DO 120 JC = 1, N
DO 110 JR = 1, JC
I = I + 1
AP( I ) = A( JR, JC )
110 CONTINUE
120 CONTINUE
*
* Call SSPTRD and SOPGTR to compute S and U from AP
*
CALL SCOPY( NAP, AP, 1, VP, 1 )
*
NTEST = 5
CALL SSPTRD( 'U', N, VP, SD, SE, TAU, IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSPTRD(U)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 5 ) = ULPINV
GO TO 280
END IF
END IF
*
NTEST = 6
CALL SOPGTR( 'U', N, VP, TAU, U, LDU, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SOPGTR(U)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 6 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do tests 5 and 6
*
CALL SSPT21( 2, 'Upper', N, 1, AP, SD, SE, U, LDU, VP, TAU,
$ WORK, RESULT( 5 ) )
CALL SSPT21( 3, 'Upper', N, 1, AP, SD, SE, U, LDU, VP, TAU,
$ WORK, RESULT( 6 ) )
*
* Store the lower triangle of A in AP
*
I = 0
DO 140 JC = 1, N
DO 130 JR = JC, N
I = I + 1
AP( I ) = A( JR, JC )
130 CONTINUE
140 CONTINUE
*
* Call SSPTRD and SOPGTR to compute S and U from AP
*
CALL SCOPY( NAP, AP, 1, VP, 1 )
*
NTEST = 7
CALL SSPTRD( 'L', N, VP, SD, SE, TAU, IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSPTRD(L)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 7 ) = ULPINV
GO TO 280
END IF
END IF
*
NTEST = 8
CALL SOPGTR( 'L', N, VP, TAU, U, LDU, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SOPGTR(L)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 8 ) = ULPINV
GO TO 280
END IF
END IF
*
CALL SSPT21( 2, 'Lower', N, 1, AP, SD, SE, U, LDU, VP, TAU,
$ WORK, RESULT( 7 ) )
CALL SSPT21( 3, 'Lower', N, 1, AP, SD, SE, U, LDU, VP, TAU,
$ WORK, RESULT( 8 ) )
*
* Call SSTEQR to compute D1, D2, and Z, do tests.
*
* Compute D1 and Z
*
CALL SCOPY( N, SD, 1, D1, 1 )
IF( N.GT.0 )
$ CALL SCOPY( N-1, SE, 1, WORK, 1 )
CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDU )
*
NTEST = 9
CALL SSTEQR( 'V', N, D1, WORK, Z, LDU, WORK( N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEQR(V)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 9 ) = ULPINV
GO TO 280
END IF
END IF
*
* Compute D2
*
CALL SCOPY( N, SD, 1, D2, 1 )
IF( N.GT.0 )
$ CALL SCOPY( N-1, SE, 1, WORK, 1 )
*
NTEST = 11
CALL SSTEQR( 'N', N, D2, WORK, WORK( N+1 ), LDU,
$ WORK( N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEQR(N)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 11 ) = ULPINV
GO TO 280
END IF
END IF
*
* Compute D3 (using PWK method)
*
CALL SCOPY( N, SD, 1, D3, 1 )
IF( N.GT.0 )
$ CALL SCOPY( N-1, SE, 1, WORK, 1 )
*
NTEST = 12
CALL SSTERF( N, D3, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTERF', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 12 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do Tests 9 and 10
*
CALL SSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK,
$ RESULT( 9 ) )
*
* Do Tests 11 and 12
*
TEMP1 = ZERO
TEMP2 = ZERO
TEMP3 = ZERO
TEMP4 = ZERO
*
DO 150 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) )
TEMP3 = MAX( TEMP3, ABS( D1( J ) ), ABS( D3( J ) ) )
TEMP4 = MAX( TEMP4, ABS( D1( J )-D3( J ) ) )
150 CONTINUE
*
RESULT( 11 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) )
RESULT( 12 ) = TEMP4 / MAX( UNFL, ULP*MAX( TEMP3, TEMP4 ) )
*
* Do Test 13 -- Sturm Sequence Test of Eigenvalues
* Go up by factors of two until it succeeds
*
NTEST = 13
TEMP1 = THRESH*( HALF-ULP )
*
DO 160 J = 0, LOG2UI
CALL SSTECH( N, SD, SE, D1, TEMP1, WORK, IINFO )
IF( IINFO.EQ.0 )
$ GO TO 170
TEMP1 = TEMP1*TWO
160 CONTINUE
*
170 CONTINUE
RESULT( 13 ) = TEMP1
*
* For positive definite matrices ( JTYPE.GT.15 ) call SPTEQR
* and do tests 14, 15, and 16 .
*
IF( JTYPE.GT.15 ) THEN
*
* Compute D4 and Z4
*
CALL SCOPY( N, SD, 1, D4, 1 )
IF( N.GT.0 )
$ CALL SCOPY( N-1, SE, 1, WORK, 1 )
CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDU )
*
NTEST = 14
CALL SPTEQR( 'V', N, D4, WORK, Z, LDU, WORK( N+1 ),
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SPTEQR(V)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 14 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do Tests 14 and 15
*
CALL SSTT21( N, 0, SD, SE, D4, DUMMA, Z, LDU, WORK,
$ RESULT( 14 ) )
*
* Compute D5
*
CALL SCOPY( N, SD, 1, D5, 1 )
IF( N.GT.0 )
$ CALL SCOPY( N-1, SE, 1, WORK, 1 )
*
NTEST = 16
CALL SPTEQR( 'N', N, D5, WORK, Z, LDU, WORK( N+1 ),
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SPTEQR(N)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 16 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do Test 16
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 180 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D4( J ) ), ABS( D5( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D4( J )-D5( J ) ) )
180 CONTINUE
*
RESULT( 16 ) = TEMP2 / MAX( UNFL,
$ HUN*ULP*MAX( TEMP1, TEMP2 ) )
ELSE
RESULT( 14 ) = ZERO
RESULT( 15 ) = ZERO
RESULT( 16 ) = ZERO
END IF
*
* Call SSTEBZ with different options and do tests 17-18.
*
* If S is positive definite and diagonally dominant,
* ask for all eigenvalues with high relative accuracy.
*
VL = ZERO
VU = ZERO
IL = 0
IU = 0
IF( JTYPE.EQ.21 ) THEN
NTEST = 17
ABSTOL = UNFL + UNFL
CALL SSTEBZ( 'A', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE,
$ M, NSPLIT, WR, IWORK( 1 ), IWORK( N+1 ),
$ WORK, IWORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEBZ(A,rel)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 17 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do test 17
*
TEMP2 = TWO*( TWO*N-ONE )*ULP*( ONE+EIGHT*HALF**2 ) /
$ ( ONE-HALF )**4
*
TEMP1 = ZERO
DO 190 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D4( J )-WR( N-J+1 ) ) /
$ ( ABSTOL+ABS( D4( J ) ) ) )
190 CONTINUE
*
RESULT( 17 ) = TEMP1 / TEMP2
ELSE
RESULT( 17 ) = ZERO
END IF
*
* Now ask for all eigenvalues with high absolute accuracy.
*
NTEST = 18
ABSTOL = UNFL + UNFL
CALL SSTEBZ( 'A', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, M,
$ NSPLIT, WA1, IWORK( 1 ), IWORK( N+1 ), WORK,
$ IWORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEBZ(A)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 18 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do test 18
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 200 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D3( J ) ), ABS( WA1( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D3( J )-WA1( J ) ) )
200 CONTINUE
*
RESULT( 18 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) )
*
* Choose random values for IL and IU, and ask for the
* IL-th through IU-th eigenvalues.
*
NTEST = 19
IF( N.LE.1 ) THEN
IL = 1
IU = N
ELSE
IL = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) )
IU = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) )
IF( IU.LT.IL ) THEN
ITEMP = IU
IU = IL
IL = ITEMP
END IF
END IF
*
CALL SSTEBZ( 'I', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE,
$ M2, NSPLIT, WA2, IWORK( 1 ), IWORK( N+1 ),
$ WORK, IWORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEBZ(I)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 19 ) = ULPINV
GO TO 280
END IF
END IF
*
* Determine the values VL and VU of the IL-th and IU-th
* eigenvalues and ask for all eigenvalues in this range.
*
IF( N.GT.0 ) THEN
IF( IL.NE.1 ) THEN
VL = WA1( IL ) - MAX( HALF*( WA1( IL )-WA1( IL-1 ) ),
$ ULP*ANORM, TWO*RTUNFL )
ELSE
VL = WA1( 1 ) - MAX( HALF*( WA1( N )-WA1( 1 ) ),
$ ULP*ANORM, TWO*RTUNFL )
END IF
IF( IU.NE.N ) THEN
VU = WA1( IU ) + MAX( HALF*( WA1( IU+1 )-WA1( IU ) ),
$ ULP*ANORM, TWO*RTUNFL )
ELSE
VU = WA1( N ) + MAX( HALF*( WA1( N )-WA1( 1 ) ),
$ ULP*ANORM, TWO*RTUNFL )
END IF
ELSE
VL = ZERO
VU = ONE
END IF
*
CALL SSTEBZ( 'V', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE,
$ M3, NSPLIT, WA3, IWORK( 1 ), IWORK( N+1 ),
$ WORK, IWORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEBZ(V)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 19 ) = ULPINV
GO TO 280
END IF
END IF
*
IF( M3.EQ.0 .AND. N.NE.0 ) THEN
RESULT( 19 ) = ULPINV
GO TO 280
END IF
*
* Do test 19
*
TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
IF( N.GT.0 ) THEN
TEMP3 = MAX( ABS( WA1( N ) ), ABS( WA1( 1 ) ) )
ELSE
TEMP3 = ZERO
END IF
*
RESULT( 19 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, TEMP3*ULP )
*
* Call SSTEIN to compute eigenvectors corresponding to
* eigenvalues in WA1. (First call SSTEBZ again, to make sure
* it returns these eigenvalues in the correct order.)
*
NTEST = 21
CALL SSTEBZ( 'A', 'B', N, VL, VU, IL, IU, ABSTOL, SD, SE, M,
$ NSPLIT, WA1, IWORK( 1 ), IWORK( N+1 ), WORK,
$ IWORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEBZ(A,B)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 20 ) = ULPINV
RESULT( 21 ) = ULPINV
GO TO 280
END IF
END IF
*
CALL SSTEIN( N, SD, SE, M, WA1, IWORK( 1 ), IWORK( N+1 ), Z,
$ LDU, WORK, IWORK( 2*N+1 ), IWORK( 3*N+1 ),
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEIN', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 20 ) = ULPINV
RESULT( 21 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do tests 20 and 21
*
CALL SSTT21( N, 0, SD, SE, WA1, DUMMA, Z, LDU, WORK,
$ RESULT( 20 ) )
*
* Call SSTEDC(I) to compute D1 and Z, do tests.
*
* Compute D1 and Z
*
CALL SCOPY( N, SD, 1, D1, 1 )
IF( N.GT.0 )
$ CALL SCOPY( N-1, SE, 1, WORK, 1 )
CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDU )
*
NTEST = 22
CALL SSTEDC( 'I', N, D1, WORK, Z, LDU, WORK( N+1 ), LWEDC-N,
$ IWORK, LIWEDC, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEDC(I)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 22 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do Tests 22 and 23
*
CALL SSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK,
$ RESULT( 22 ) )
*
* Call SSTEDC(V) to compute D1 and Z, do tests.
*
* Compute D1 and Z
*
CALL SCOPY( N, SD, 1, D1, 1 )
IF( N.GT.0 )
$ CALL SCOPY( N-1, SE, 1, WORK, 1 )
CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDU )
*
NTEST = 24
CALL SSTEDC( 'V', N, D1, WORK, Z, LDU, WORK( N+1 ), LWEDC-N,
$ IWORK, LIWEDC, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEDC(V)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 24 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do Tests 24 and 25
*
CALL SSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK,
$ RESULT( 24 ) )
*
* Call SSTEDC(N) to compute D2, do tests.
*
* Compute D2
*
CALL SCOPY( N, SD, 1, D2, 1 )
IF( N.GT.0 )
$ CALL SCOPY( N-1, SE, 1, WORK, 1 )
CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDU )
*
NTEST = 26
CALL SSTEDC( 'N', N, D2, WORK, Z, LDU, WORK( N+1 ), LWEDC-N,
$ IWORK, LIWEDC, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEDC(N)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 26 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do Test 26
*
TEMP1 = ZERO
TEMP2 = ZERO
*
DO 210 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) )
210 CONTINUE
*
RESULT( 26 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) )
*
* Only test SSTEMR if IEEE compliant
*
IF( ILAENV( 10, 'SSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 .AND.
$ ILAENV( 11, 'SSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 ) THEN
*
* Call SSTEMR, do test 27 (relative eigenvalue accuracy)
*
* If S is positive definite and diagonally dominant,
* ask for all eigenvalues with high relative accuracy.
*
VL = ZERO
VU = ZERO
IL = 0
IU = 0
IF( JTYPE.EQ.21 .AND. SREL ) THEN
NTEST = 27
ABSTOL = UNFL + UNFL
CALL SSTEMR( 'V', 'A', N, SD, SE, VL, VU, IL, IU,
$ M, WR, Z, LDU, N, IWORK( 1 ), TRYRAC,
$ WORK, LWORK, IWORK( 2*N+1 ), LWORK-2*N,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEMR(V,A,rel)',
$ IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 27 ) = ULPINV
GO TO 270
END IF
END IF
*
* Do test 27
*
TEMP2 = TWO*( TWO*N-ONE )*ULP*( ONE+EIGHT*HALF**2 ) /
$ ( ONE-HALF )**4
*
TEMP1 = ZERO
DO 220 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D4( J )-WR( N-J+1 ) ) /
$ ( ABSTOL+ABS( D4( J ) ) ) )
220 CONTINUE
*
RESULT( 27 ) = TEMP1 / TEMP2
*
IL = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) )
IU = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) )
IF( IU.LT.IL ) THEN
ITEMP = IU
IU = IL
IL = ITEMP
END IF
*
IF( SRANGE ) THEN
NTEST = 28
ABSTOL = UNFL + UNFL
CALL SSTEMR( 'V', 'I', N, SD, SE, VL, VU, IL, IU,
$ M, WR, Z, LDU, N, IWORK( 1 ), TRYRAC,
$ WORK, LWORK, IWORK( 2*N+1 ),
$ LWORK-2*N, IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEMR(V,I,rel)',
$ IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 28 ) = ULPINV
GO TO 270
END IF
END IF
*
*
* Do test 28
*
TEMP2 = TWO*( TWO*N-ONE )*ULP*
$ ( ONE+EIGHT*HALF**2 ) / ( ONE-HALF )**4
*
TEMP1 = ZERO
DO 230 J = IL, IU
TEMP1 = MAX( TEMP1, ABS( WR( J-IL+1 )-D4( N-J+
$ 1 ) ) / ( ABSTOL+ABS( WR( J-IL+1 ) ) ) )
230 CONTINUE
*
RESULT( 28 ) = TEMP1 / TEMP2
ELSE
RESULT( 28 ) = ZERO
END IF
ELSE
RESULT( 27 ) = ZERO
RESULT( 28 ) = ZERO
END IF
*
* Call SSTEMR(V,I) to compute D1 and Z, do tests.
*
* Compute D1 and Z
*
CALL SCOPY( N, SD, 1, D5, 1 )
IF( N.GT.0 )
$ CALL SCOPY( N-1, SE, 1, WORK, 1 )
CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDU )
*
IF( SRANGE ) THEN
NTEST = 29
IL = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) )
IU = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) )
IF( IU.LT.IL ) THEN
ITEMP = IU
IU = IL
IL = ITEMP
END IF
CALL SSTEMR( 'V', 'I', N, D5, WORK, VL, VU, IL, IU,
$ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC,
$ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ),
$ LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEMR(V,I)', IINFO,
$ N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 29 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do Tests 29 and 30
*
CALL SSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK,
$ M, RESULT( 29 ) )
*
* Call SSTEMR to compute D2, do tests.
*
* Compute D2
*
CALL SCOPY( N, SD, 1, D5, 1 )
IF( N.GT.0 )
$ CALL SCOPY( N-1, SE, 1, WORK, 1 )
*
NTEST = 31
CALL SSTEMR( 'N', 'I', N, D5, WORK, VL, VU, IL, IU,
$ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC,
$ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ),
$ LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEMR(N,I)', IINFO,
$ N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 31 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do Test 31
*
TEMP1 = ZERO
TEMP2 = ZERO
*
DO 240 J = 1, IU - IL + 1
TEMP1 = MAX( TEMP1, ABS( D1( J ) ),
$ ABS( D2( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) )
240 CONTINUE
*
RESULT( 31 ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
*
* Call SSTEMR(V,V) to compute D1 and Z, do tests.
*
* Compute D1 and Z
*
CALL SCOPY( N, SD, 1, D5, 1 )
IF( N.GT.0 )
$ CALL SCOPY( N-1, SE, 1, WORK, 1 )
CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDU )
*
NTEST = 32
*
IF( N.GT.0 ) THEN
IF( IL.NE.1 ) THEN
VL = D2( IL ) - MAX( HALF*
$ ( D2( IL )-D2( IL-1 ) ), ULP*ANORM,
$ TWO*RTUNFL )
ELSE
VL = D2( 1 ) - MAX( HALF*( D2( N )-D2( 1 ) ),
$ ULP*ANORM, TWO*RTUNFL )
END IF
IF( IU.NE.N ) THEN
VU = D2( IU ) + MAX( HALF*
$ ( D2( IU+1 )-D2( IU ) ), ULP*ANORM,
$ TWO*RTUNFL )
ELSE
VU = D2( N ) + MAX( HALF*( D2( N )-D2( 1 ) ),
$ ULP*ANORM, TWO*RTUNFL )
END IF
ELSE
VL = ZERO
VU = ONE
END IF
*
CALL SSTEMR( 'V', 'V', N, D5, WORK, VL, VU, IL, IU,
$ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC,
$ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ),
$ LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEMR(V,V)', IINFO,
$ N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 32 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do Tests 32 and 33
*
CALL SSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK,
$ M, RESULT( 32 ) )
*
* Call SSTEMR to compute D2, do tests.
*
* Compute D2
*
CALL SCOPY( N, SD, 1, D5, 1 )
IF( N.GT.0 )
$ CALL SCOPY( N-1, SE, 1, WORK, 1 )
*
NTEST = 34
CALL SSTEMR( 'N', 'V', N, D5, WORK, VL, VU, IL, IU,
$ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC,
$ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ),
$ LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEMR(N,V)', IINFO,
$ N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 34 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do Test 34
*
TEMP1 = ZERO
TEMP2 = ZERO
*
DO 250 J = 1, IU - IL + 1
TEMP1 = MAX( TEMP1, ABS( D1( J ) ),
$ ABS( D2( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) )
250 CONTINUE
*
RESULT( 34 ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
ELSE
RESULT( 29 ) = ZERO
RESULT( 30 ) = ZERO
RESULT( 31 ) = ZERO
RESULT( 32 ) = ZERO
RESULT( 33 ) = ZERO
RESULT( 34 ) = ZERO
END IF
*
*
* Call SSTEMR(V,A) to compute D1 and Z, do tests.
*
* Compute D1 and Z
*
CALL SCOPY( N, SD, 1, D5, 1 )
IF( N.GT.0 )
$ CALL SCOPY( N-1, SE, 1, WORK, 1 )
*
NTEST = 35
*
CALL SSTEMR( 'V', 'A', N, D5, WORK, VL, VU, IL, IU,
$ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC,
$ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ),
$ LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEMR(V,A)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 35 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do Tests 35 and 36
*
CALL SSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, M,
$ RESULT( 35 ) )
*
* Call SSTEMR to compute D2, do tests.
*
* Compute D2
*
CALL SCOPY( N, SD, 1, D5, 1 )
IF( N.GT.0 )
$ CALL SCOPY( N-1, SE, 1, WORK, 1 )
*
NTEST = 37
CALL SSTEMR( 'N', 'A', N, D5, WORK, VL, VU, IL, IU,
$ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC,
$ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ),
$ LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEMR(N,A)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 37 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do Test 34
*
TEMP1 = ZERO
TEMP2 = ZERO
*
DO 260 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) )
260 CONTINUE
*
RESULT( 37 ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
END IF
270 CONTINUE
280 CONTINUE
NTESTT = NTESTT + NTEST
*
* End of Loop -- Check for RESULT(j) > THRESH
*
*
* Print out tests which fail.
*
DO 290 JR = 1, NTEST
IF( RESULT( JR ).GE.THRESH ) THEN
*
* If this is the first test to fail,
* print a header to the data file.
*
IF( NERRS.EQ.0 ) THEN
WRITE( NOUNIT, FMT = 9998 )'SST'
WRITE( NOUNIT, FMT = 9997 )
WRITE( NOUNIT, FMT = 9996 )
WRITE( NOUNIT, FMT = 9995 )'Symmetric'
WRITE( NOUNIT, FMT = 9994 )
*
* Tests performed
*
WRITE( NOUNIT, FMT = 9988 )
END IF
NERRS = NERRS + 1
WRITE( NOUNIT, FMT = 9990 )N, IOLDSD, JTYPE, JR,
$ RESULT( JR )
END IF
290 CONTINUE
300 CONTINUE
310 CONTINUE
*
* Summary
*
CALL SLASUM( 'SST', NOUNIT, NERRS, NTESTT )
RETURN
*
9999 FORMAT( ' SCHKST: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
*
9998 FORMAT( / 1X, A3, ' -- Real Symmetric eigenvalue problem' )
9997 FORMAT( ' Matrix types (see SCHKST for details): ' )
*
9996 FORMAT( / ' Special Matrices:',
$ / ' 1=Zero matrix. ',
$ ' 5=Diagonal: clustered entries.',
$ / ' 2=Identity matrix. ',
$ ' 6=Diagonal: large, evenly spaced.',
$ / ' 3=Diagonal: evenly spaced entries. ',
$ ' 7=Diagonal: small, evenly spaced.',
$ / ' 4=Diagonal: geometr. spaced entries.' )
9995 FORMAT( ' Dense ', A, ' Matrices:',
$ / ' 8=Evenly spaced eigenvals. ',
$ ' 12=Small, evenly spaced eigenvals.',
$ / ' 9=Geometrically spaced eigenvals. ',
$ ' 13=Matrix with random O(1) entries.',
$ / ' 10=Clustered eigenvalues. ',
$ ' 14=Matrix with large random entries.',
$ / ' 11=Large, evenly spaced eigenvals. ',
$ ' 15=Matrix with small random entries.' )
9994 FORMAT( ' 16=Positive definite, evenly spaced eigenvalues',
$ / ' 17=Positive definite, geometrically spaced eigenvlaues',
$ / ' 18=Positive definite, clustered eigenvalues',
$ / ' 19=Positive definite, small evenly spaced eigenvalues',
$ / ' 20=Positive definite, large evenly spaced eigenvalues',
$ / ' 21=Diagonally dominant tridiagonal, geometrically',
$ ' spaced eigenvalues' )
*
9993 FORMAT( / ' Tests performed: ',
$ '(S is Tridiag, D is diagonal, U and Z are ', A, ',', / 20X,
$ A, ', W is a diagonal matrix of eigenvalues,', / 20X,
$ ' V is U represented by Householder vectors, and', / 20X,
$ ' Y is a matrix of eigenvectors of S.)',
$ / ' SSYTRD, UPLO=''U'':', / ' 1= | A - V S V', A1,
$ ' | / ( |A| n ulp ) ', ' 2= | I - U V', A1,
$ ' | / ( n ulp )', / ' SSYTRD, UPLO=''L'':',
$ / ' 3= | A - V S V', A1, ' | / ( |A| n ulp ) ',
$ ' 4= | I - U V', A1, ' | / ( n ulp )' )
9992 FORMAT( ' SSPTRD, UPLO=''U'':', / ' 5= | A - V S V', A1,
$ ' | / ( |A| n ulp ) ', ' 6= | I - U V', A1,
$ ' | / ( n ulp )', / ' SSPTRD, UPLO=''L'':',
$ / ' 7= | A - V S V', A1, ' | / ( |A| n ulp ) ',
$ ' 8= | I - U V', A1, ' | / ( n ulp )',
$ / ' 9= | S - Z D Z', A1, ' | / ( |S| n ulp ) ',
$ ' 10= | I - Z Z', A1, ' | / ( n ulp )',
$ / ' 11= |D(with Z) - D(w/o Z)| / (|D| ulp) ',
$ ' 12= | D(PWK) - D(QR) | / (|D| ulp)',
$ / ' 13= Sturm sequence test on W ' )
9991 FORMAT( ' 14= | S - Z4 D4 Z4', A1, ' | / (|S| n ulp)',
$ / ' 15= | I - Z4 Z4', A1, ' | / (n ulp ) ',
$ ' 16= | D4 - D5 | / ( 100 |D4| ulp ) ',
$ / ' 17= max | D4(i) - WR(i) | / ( |D4(i)| (2n-1) ulp )',
$ / ' 18= | WA1 - D3 | / ( |D3| ulp )',
$ / ' 19= max | WA2(i) - WA3(ii) | / ( |D3| ulp )',
$ / ' 20= | S - Y WA1 Y', A1, ' | / ( |S| n ulp )',
$ / ' 21= | I - Y Y', A1, ' | / ( n ulp )' )
9990 FORMAT( ' N=', I5, ', seed=', 4( I4, ',' ), ' type ', I2,
$ ', test(', I2, ')=', G10.3 )
9989 FORMAT( ' 22= | S - Z D Z', A1, '| / ( |S| n ulp ) for SSTEDC(I)',
$ / ' 23= | I - Z Z', A1, '| / ( n ulp ) for SSTEDC(I)',
$ / ' 24= | S - Z D Z', A1, '| / ( |S| n ulp ) for SSTEDC(V)',
$ / ' 25= | I - Z Z', A1, '| / ( n ulp ) for SSTEDC(V)',
$ / ' 26= | D1(SSTEDC(V)) - D2(SSTEDC(N)) | / ( |D1| ulp )' )
*
9988 FORMAT( / 'Test performed: see SCHKST for details.', / )
* End of SCHKST
*
END
SUBROUTINE SCKGLM( NN, MVAL, PVAL, NVAL, NMATS, ISEED, THRESH,
$ NMAX, A, AF, B, BF, X, WORK, RWORK, NIN, NOUT,
$ INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, NIN, NMATS, NMAX, NN, NOUT
REAL THRESH
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 ), MVAL( * ), NVAL( * ), PVAL( * )
REAL A( * ), AF( * ), B( * ), BF( * ), RWORK( * ),
$ WORK( * ), X( * )
* ..
*
* Purpose
* =======
*
* SCKGLM tests SGGGLM - subroutine for solving generalized linear
* model problem.
*
* Arguments
* =========
*
* NN (input) INTEGER
* The number of values of N, M and P contained in the vectors
* NVAL, MVAL and PVAL.
*
* MVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension M.
*
* PVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension P.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix row dimension N.
*
* NMATS (input) INTEGER
* The number of matrix types to be tested for each combination
* of matrix dimensions. If NMATS >= NTYPES (the maximum
* number of matrix types), then all the different types are
* generated for testing. If NMATS < NTYPES, another input line
* is read to get the numbers of the matrix types to be used.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry, the seed of the random number generator. The array
* elements should be between 0 and 4095, otherwise they will be
* reduced mod 4096, and ISEED(4) must be odd.
* On exit, the next seed in the random number sequence after
* all the test matrices have been generated.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESID >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* NMAX (input) INTEGER
* The maximum value permitted for M or N, used in dimensioning
* the work arrays.
*
* A (workspace) REAL array, dimension (NMAX*NMAX)
*
* AF (workspace) REAL array, dimension (NMAX*NMAX)
*
* B (workspace) REAL array, dimension (NMAX*NMAX)
*
* BF (workspace) REAL array, dimension (NMAX*NMAX)
*
* X (workspace) REAL array, dimension (4*NMAX)
*
* RWORK (workspace) REAL array, dimension (NMAX)
*
* WORK (workspace) REAL array, dimension (NMAX*NMAX)
*
* NIN (input) INTEGER
* The unit number for input.
*
* NOUT (input) INTEGER
* The unit number for output.
*
* INFO (output) INTEGER
* = 0 : successful exit
* > 0 : If SLATMS returns an error code, the absolute value
* of it is returned.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTYPES
PARAMETER ( NTYPES = 8 )
* ..
* .. Local Scalars ..
LOGICAL FIRSTT
CHARACTER DISTA, DISTB, TYPE
CHARACTER*3 PATH
INTEGER I, IINFO, IK, IMAT, KLA, KLB, KUA, KUB, LDA,
$ LDB, LWORK, M, MODEA, MODEB, N, NFAIL, NRUN, P
REAL ANORM, BNORM, CNDNMA, CNDNMB, RESID
* ..
* .. Local Arrays ..
LOGICAL DOTYPE( NTYPES )
* ..
* .. External Functions ..
REAL SLARND
EXTERNAL SLARND
* ..
* .. External Subroutines ..
EXTERNAL ALAHDG, ALAREQ, ALASUM, SGLMTS, SLATB9, SLATMS
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
* Initialize constants.
*
PATH( 1: 3 ) = 'GLM'
INFO = 0
NRUN = 0
NFAIL = 0
FIRSTT = .TRUE.
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
LDA = NMAX
LDB = NMAX
LWORK = NMAX*NMAX
*
* Check for valid input values.
*
DO 10 IK = 1, NN
M = MVAL( IK )
P = PVAL( IK )
N = NVAL( IK )
IF( M.GT.N .OR. N.GT.M+P ) THEN
IF( FIRSTT ) THEN
WRITE( NOUT, FMT = * )
FIRSTT = .FALSE.
END IF
WRITE( NOUT, FMT = 9997 )M, P, N
END IF
10 CONTINUE
FIRSTT = .TRUE.
*
* Do for each value of M in MVAL.
*
DO 40 IK = 1, NN
M = MVAL( IK )
P = PVAL( IK )
N = NVAL( IK )
IF( M.GT.N .OR. N.GT.M+P )
$ GO TO 40
*
DO 30 IMAT = 1, NTYPES
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 30
*
* Set up parameters with SLATB9 and generate test
* matrices A and B with SLATMS.
*
CALL SLATB9( PATH, IMAT, M, P, N, TYPE, KLA, KUA, KLB, KUB,
$ ANORM, BNORM, MODEA, MODEB, CNDNMA, CNDNMB,
$ DISTA, DISTB )
*
CALL SLATMS( N, M, DISTA, ISEED, TYPE, RWORK, MODEA, CNDNMA,
$ ANORM, KLA, KUA, 'No packing', A, LDA, WORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9999 )IINFO
INFO = ABS( IINFO )
GO TO 30
END IF
*
CALL SLATMS( N, P, DISTB, ISEED, TYPE, RWORK, MODEB, CNDNMB,
$ BNORM, KLB, KUB, 'No packing', B, LDB, WORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9999 )IINFO
INFO = ABS( IINFO )
GO TO 30
END IF
*
* Generate random left hand side vector of GLM
*
DO 20 I = 1, N
X( I ) = SLARND( 2, ISEED )
20 CONTINUE
*
CALL SGLMTS( N, M, P, A, AF, LDA, B, BF, LDB, X,
$ X( NMAX+1 ), X( 2*NMAX+1 ), X( 3*NMAX+1 ),
$ WORK, LWORK, RWORK, RESID )
*
* Print information about the tests that did not
* pass the threshold.
*
IF( RESID.GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. FIRSTT ) THEN
FIRSTT = .FALSE.
CALL ALAHDG( NOUT, PATH )
END IF
WRITE( NOUT, FMT = 9998 )N, M, P, IMAT, 1, RESID
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
*
30 CONTINUE
40 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, 0 )
*
9999 FORMAT( ' SLATMS in SCKGLM INFO = ', I5 )
9998 FORMAT( ' N=', I4, ' M=', I4, ', P=', I4, ', type ', I2,
$ ', test ', I2, ', ratio=', G13.6 )
9997 FORMAT( ' *** Invalid input for GLM: M = ', I6, ', P = ', I6,
$ ', N = ', I6, ';', / ' must satisfy M <= N <= M+P ',
$ '(this set of values will be skipped)' )
RETURN
*
* End of SCKGLM
*
END
SUBROUTINE SCKGQR( NM, MVAL, NP, PVAL, NN, NVAL, NMATS, ISEED,
$ THRESH, NMAX, A, AF, AQ, AR, TAUA, B, BF, BZ,
$ BT, BWK, TAUB, WORK, RWORK, NIN, NOUT, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, NIN, NM, NMATS, NMAX, NN, NOUT, NP
REAL THRESH
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 ), MVAL( * ), NVAL( * ), PVAL( * )
REAL A( * ), AF( * ), AQ( * ), AR( * ), B( * ),
$ BF( * ), BT( * ), BWK( * ), BZ( * ),
$ RWORK( * ), TAUA( * ), TAUB( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SCKGQR tests
* SGGQRF: GQR factorization for N-by-M matrix A and N-by-P matrix B,
* SGGRQF: GRQ factorization for M-by-N matrix A and P-by-N matrix B.
*
* Arguments
* =========
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row(column) dimension M.
*
* NP (input) INTEGER
* The number of values of P contained in the vector PVAL.
*
* PVAL (input) INTEGER array, dimension (NP)
* The values of the matrix row(column) dimension P.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column(row) dimension N.
*
* NMATS (input) INTEGER
* The number of matrix types to be tested for each combination
* of matrix dimensions. If NMATS >= NTYPES (the maximum
* number of matrix types), then all the different types are
* generated for testing. If NMATS < NTYPES, another input line
* is read to get the numbers of the matrix types to be used.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry, the seed of the random number generator. The array
* elements should be between 0 and 4095, otherwise they will be
* reduced mod 4096, and ISEED(4) must be odd.
* On exit, the next seed in the random number sequence after
* all the test matrices have been generated.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* NMAX (input) INTEGER
* The maximum value permitted for M or N, used in dimensioning
* the work arrays.
*
* A (workspace) REAL array, dimension (NMAX*NMAX)
*
* AF (workspace) REAL array, dimension (NMAX*NMAX)
*
* AQ (workspace) REAL array, dimension (NMAX*NMAX)
*
* AR (workspace) REAL array, dimension (NMAX*NMAX)
*
* TAUA (workspace) REAL array, dimension (NMAX)
*
* B (workspace) REAL array, dimension (NMAX*NMAX)
*
* BF (workspace) REAL array, dimension (NMAX*NMAX)
*
* BZ (workspace) REAL array, dimension (NMAX*NMAX)
*
* BT (workspace) REAL array, dimension (NMAX*NMAX)
*
* BWK (workspace) REAL array, dimension (NMAX*NMAX)
*
* TAUB (workspace) REAL array, dimension (NMAX)
*
* WORK (workspace) REAL array, dimension (NMAX*NMAX)
*
* RWORK (workspace) REAL array, dimension (NMAX)
*
* NIN (input) INTEGER
* The unit number for input.
*
* NOUT (input) INTEGER
* The unit number for output.
*
* INFO (output) INTEGER
* = 0 : successful exit
* > 0 : If SLATMS returns an error code, the absolute value
* of it is returned.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTESTS
PARAMETER ( NTESTS = 7 )
INTEGER NTYPES
PARAMETER ( NTYPES = 8 )
* ..
* .. Local Scalars ..
LOGICAL FIRSTT
CHARACTER DISTA, DISTB, TYPE
CHARACTER*3 PATH
INTEGER I, IINFO, IM, IMAT, IN, IP, KLA, KLB, KUA, KUB,
$ LDA, LDB, LWORK, M, MODEA, MODEB, N, NFAIL,
$ NRUN, NT, P
REAL ANORM, BNORM, CNDNMA, CNDNMB
* ..
* .. Local Arrays ..
LOGICAL DOTYPE( NTYPES )
REAL RESULT( NTESTS )
* ..
* .. External Subroutines ..
EXTERNAL ALAHDG, ALAREQ, ALASUM, SGQRTS, SGRQTS, SLATB9,
$ SLATMS
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
* Initialize constants.
*
PATH( 1: 3 ) = 'GQR'
INFO = 0
NRUN = 0
NFAIL = 0
FIRSTT = .TRUE.
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
LDA = NMAX
LDB = NMAX
LWORK = NMAX*NMAX
*
* Do for each value of M in MVAL.
*
DO 60 IM = 1, NM
M = MVAL( IM )
*
* Do for each value of P in PVAL.
*
DO 50 IP = 1, NP
P = PVAL( IP )
*
* Do for each value of N in NVAL.
*
DO 40 IN = 1, NN
N = NVAL( IN )
*
DO 30 IMAT = 1, NTYPES
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 30
*
* Test SGGRQF
*
* Set up parameters with SLATB9 and generate test
* matrices A and B with SLATMS.
*
CALL SLATB9( 'GRQ', IMAT, M, P, N, TYPE, KLA, KUA,
$ KLB, KUB, ANORM, BNORM, MODEA, MODEB,
$ CNDNMA, CNDNMB, DISTA, DISTB )
*
* Generate M by N matrix A
*
CALL SLATMS( M, N, DISTA, ISEED, TYPE, RWORK, MODEA,
$ CNDNMA, ANORM, KLA, KUA, 'No packing', A,
$ LDA, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9999 )IINFO
INFO = ABS( IINFO )
GO TO 30
END IF
*
* Generate P by N matrix B
*
CALL SLATMS( P, N, DISTB, ISEED, TYPE, RWORK, MODEB,
$ CNDNMB, BNORM, KLB, KUB, 'No packing', B,
$ LDB, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9999 )IINFO
INFO = ABS( IINFO )
GO TO 30
END IF
*
NT = 4
*
CALL SGRQTS( M, P, N, A, AF, AQ, AR, LDA, TAUA, B, BF,
$ BZ, BT, BWK, LDB, TAUB, WORK, LWORK,
$ RWORK, RESULT )
*
* Print information about the tests that did not
* pass the threshold.
*
DO 10 I = 1, NT
IF( RESULT( I ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. FIRSTT ) THEN
FIRSTT = .FALSE.
CALL ALAHDG( NOUT, 'GRQ' )
END IF
WRITE( NOUT, FMT = 9998 )M, P, N, IMAT, I,
$ RESULT( I )
NFAIL = NFAIL + 1
END IF
10 CONTINUE
NRUN = NRUN + NT
*
* Test SGGQRF
*
* Set up parameters with SLATB9 and generate test
* matrices A and B with SLATMS.
*
CALL SLATB9( 'GQR', IMAT, M, P, N, TYPE, KLA, KUA,
$ KLB, KUB, ANORM, BNORM, MODEA, MODEB,
$ CNDNMA, CNDNMB, DISTA, DISTB )
*
* Generate N-by-M matrix A
*
CALL SLATMS( N, M, DISTA, ISEED, TYPE, RWORK, MODEA,
$ CNDNMA, ANORM, KLA, KUA, 'No packing', A,
$ LDA, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9999 )IINFO
INFO = ABS( IINFO )
GO TO 30
END IF
*
* Generate N-by-P matrix B
*
CALL SLATMS( N, P, DISTB, ISEED, TYPE, RWORK, MODEA,
$ CNDNMA, BNORM, KLB, KUB, 'No packing', B,
$ LDB, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9999 )IINFO
INFO = ABS( IINFO )
GO TO 30
END IF
*
NT = 4
*
CALL SGQRTS( N, M, P, A, AF, AQ, AR, LDA, TAUA, B, BF,
$ BZ, BT, BWK, LDB, TAUB, WORK, LWORK,
$ RWORK, RESULT )
*
* Print information about the tests that did not
* pass the threshold.
*
DO 20 I = 1, NT
IF( RESULT( I ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. FIRSTT ) THEN
FIRSTT = .FALSE.
CALL ALAHDG( NOUT, PATH )
END IF
WRITE( NOUT, FMT = 9997 )N, M, P, IMAT, I,
$ RESULT( I )
NFAIL = NFAIL + 1
END IF
20 CONTINUE
NRUN = NRUN + NT
*
30 CONTINUE
40 CONTINUE
50 CONTINUE
60 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, 0 )
*
9999 FORMAT( ' SLATMS in SCKGQR: INFO = ', I5 )
9998 FORMAT( ' M=', I4, ' P=', I4, ', N=', I4, ', type ', I2,
$ ', test ', I2, ', ratio=', G13.6 )
9997 FORMAT( ' N=', I4, ' M=', I4, ', P=', I4, ', type ', I2,
$ ', test ', I2, ', ratio=', G13.6 )
RETURN
*
* End of SCKGQR
*
END
SUBROUTINE SCKGSV( NM, MVAL, PVAL, NVAL, NMATS, ISEED, THRESH,
$ NMAX, A, AF, B, BF, U, V, Q, ALPHA, BETA, R,
$ IWORK, WORK, RWORK, NIN, NOUT, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, NIN, NM, NMATS, NMAX, NOUT
REAL THRESH
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 ), IWORK( * ), MVAL( * ), NVAL( * ),
$ PVAL( * )
REAL A( * ), AF( * ), ALPHA( * ), B( * ), BETA( * ),
$ BF( * ), Q( * ), R( * ), RWORK( * ), U( * ),
$ V( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SCKGSV tests SGGSVD:
* the GSVD for M-by-N matrix A and P-by-N matrix B.
*
* Arguments
* =========
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* PVAL (input) INTEGER array, dimension (NP)
* The values of the matrix row dimension P.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NMATS (input) INTEGER
* The number of matrix types to be tested for each combination
* of matrix dimensions. If NMATS >= NTYPES (the maximum
* number of matrix types), then all the different types are
* generated for testing. If NMATS < NTYPES, another input line
* is read to get the numbers of the matrix types to be used.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry, the seed of the random number generator. The array
* elements should be between 0 and 4095, otherwise they will be
* reduced mod 4096, and ISEED(4) must be odd.
* On exit, the next seed in the random number sequence after
* all the test matrices have been generated.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* NMAX (input) INTEGER
* The maximum value permitted for M or N, used in dimensioning
* the work arrays.
*
* A (workspace) REAL array, dimension (NMAX*NMAX)
*
* AF (workspace) REAL array, dimension (NMAX*NMAX)
*
* B (workspace) REAL array, dimension (NMAX*NMAX)
*
* BF (workspace) REAL array, dimension (NMAX*NMAX)
*
* U (workspace) REAL array, dimension (NMAX*NMAX)
*
* V (workspace) REAL array, dimension (NMAX*NMAX)
*
* Q (workspace) REAL array, dimension (NMAX*NMAX)
*
* ALPHA (workspace) REAL array, dimension (NMAX)
*
* BETA (workspace) REAL array, dimension (NMAX)
*
* R (workspace) REAL array, dimension (NMAX*NMAX)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* WORK (workspace) REAL array, dimension (NMAX*NMAX)
*
* RWORK (workspace) REAL array, dimension (NMAX)
*
* NIN (input) INTEGER
* The unit number for input.
*
* NOUT (input) INTEGER
* The unit number for output.
*
* INFO (output) INTEGER
* = 0 : successful exit
* > 0 : If SLATMS returns an error code, the absolute value
* of it is returned.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTESTS
PARAMETER ( NTESTS = 7 )
INTEGER NTYPES
PARAMETER ( NTYPES = 8 )
* ..
* .. Local Scalars ..
LOGICAL FIRSTT
CHARACTER DISTA, DISTB, TYPE
CHARACTER*3 PATH
INTEGER I, IINFO, IM, IMAT, KLA, KLB, KUA, KUB, LDA,
$ LDB, LDQ, LDR, LDU, LDV, LWORK, M, MODEA,
$ MODEB, N, NFAIL, NRUN, NT, P
REAL ANORM, BNORM, CNDNMA, CNDNMB
* ..
* .. Local Arrays ..
LOGICAL DOTYPE( NTYPES )
REAL RESULT( NTESTS )
* ..
* .. External Subroutines ..
EXTERNAL ALAHDG, ALAREQ, ALASUM, SGSVTS, SLATB9, SLATMS
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 3 ) = 'GSV'
INFO = 0
NRUN = 0
NFAIL = 0
FIRSTT = .TRUE.
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
LDA = NMAX
LDB = NMAX
LDU = NMAX
LDV = NMAX
LDQ = NMAX
LDR = NMAX
LWORK = NMAX*NMAX
*
* Do for each value of M in MVAL.
*
DO 30 IM = 1, NM
M = MVAL( IM )
P = PVAL( IM )
N = NVAL( IM )
*
DO 20 IMAT = 1, NTYPES
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 20
*
* Set up parameters with SLATB9 and generate test
* matrices A and B with SLATMS.
*
CALL SLATB9( PATH, IMAT, M, P, N, TYPE, KLA, KUA, KLB, KUB,
$ ANORM, BNORM, MODEA, MODEB, CNDNMA, CNDNMB,
$ DISTA, DISTB )
*
* Generate M by N matrix A
*
CALL SLATMS( M, N, DISTA, ISEED, TYPE, RWORK, MODEA, CNDNMA,
$ ANORM, KLA, KUA, 'No packing', A, LDA, WORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9999 )IINFO
INFO = ABS( IINFO )
GO TO 20
END IF
*
CALL SLATMS( P, N, DISTB, ISEED, TYPE, RWORK, MODEB, CNDNMB,
$ BNORM, KLB, KUB, 'No packing', B, LDB, WORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9999 )IINFO
INFO = ABS( IINFO )
GO TO 20
END IF
*
NT = 6
*
CALL SGSVTS( M, P, N, A, AF, LDA, B, BF, LDB, U, LDU, V,
$ LDV, Q, LDQ, ALPHA, BETA, R, LDR, IWORK, WORK,
$ LWORK, RWORK, RESULT )
*
* Print information about the tests that did not
* pass the threshold.
*
DO 10 I = 1, NT
IF( RESULT( I ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. FIRSTT ) THEN
FIRSTT = .FALSE.
CALL ALAHDG( NOUT, PATH )
END IF
WRITE( NOUT, FMT = 9998 )M, P, N, IMAT, I,
$ RESULT( I )
NFAIL = NFAIL + 1
END IF
10 CONTINUE
NRUN = NRUN + NT
20 CONTINUE
30 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, 0 )
*
9999 FORMAT( ' SLATMS in SCKGSV INFO = ', I5 )
9998 FORMAT( ' M=', I4, ' P=', I4, ', N=', I4, ', type ', I2,
$ ', test ', I2, ', ratio=', G13.6 )
RETURN
*
* End of SCKGSV
*
END
SUBROUTINE SCKLSE( NN, MVAL, PVAL, NVAL, NMATS, ISEED, THRESH,
$ NMAX, A, AF, B, BF, X, WORK, RWORK, NIN, NOUT,
$ INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, NIN, NMATS, NMAX, NN, NOUT
REAL THRESH
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 ), MVAL( * ), NVAL( * ), PVAL( * )
REAL A( * ), AF( * ), B( * ), BF( * ), RWORK( * ),
$ WORK( * ), X( * )
* ..
*
* Purpose
* =======
*
* SCKLSE tests SGGLSE - a subroutine for solving linear equality
* constrained least square problem (LSE).
*
* Arguments
* =========
*
* NN (input) INTEGER
* The number of values of (M,P,N) contained in the vectors
* (MVAL, PVAL, NVAL).
*
* MVAL (input) INTEGER array, dimension (NN)
* The values of the matrix row(column) dimension M.
*
* PVAL (input) INTEGER array, dimension (NN)
* The values of the matrix row(column) dimension P.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column(row) dimension N.
*
* NMATS (input) INTEGER
* The number of matrix types to be tested for each combination
* of matrix dimensions. If NMATS >= NTYPES (the maximum
* number of matrix types), then all the different types are
* generated for testing. If NMATS < NTYPES, another input line
* is read to get the numbers of the matrix types to be used.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry, the seed of the random number generator. The array
* elements should be between 0 and 4095, otherwise they will be
* reduced mod 4096, and ISEED(4) must be odd.
* On exit, the next seed in the random number sequence after
* all the test matrices have been generated.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* NMAX (input) INTEGER
* The maximum value permitted for M or N, used in dimensioning
* the work arrays.
*
* A (workspace) REAL array, dimension (NMAX*NMAX)
*
* AF (workspace) REAL array, dimension (NMAX*NMAX)
*
* B (workspace) REAL array, dimension (NMAX*NMAX)
*
* BF (workspace) REAL array, dimension (NMAX*NMAX)
*
* X (workspace) REAL array, dimension (5*NMAX)
*
* WORK (workspace) REAL array, dimension (NMAX*NMAX)
*
* RWORK (workspace) REAL array, dimension (NMAX)
*
* NIN (input) INTEGER
* The unit number for input.
*
* NOUT (input) INTEGER
* The unit number for output.
*
* INFO (output) INTEGER
* = 0 : successful exit
* > 0 : If SLATMS returns an error code, the absolute value
* of it is returned.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTESTS
PARAMETER ( NTESTS = 7 )
INTEGER NTYPES
PARAMETER ( NTYPES = 8 )
* ..
* .. Local Scalars ..
LOGICAL FIRSTT
CHARACTER DISTA, DISTB, TYPE
CHARACTER*3 PATH
INTEGER I, IINFO, IK, IMAT, KLA, KLB, KUA, KUB, LDA,
$ LDB, LWORK, M, MODEA, MODEB, N, NFAIL, NRUN,
$ NT, P
REAL ANORM, BNORM, CNDNMA, CNDNMB
* ..
* .. Local Arrays ..
LOGICAL DOTYPE( NTYPES )
REAL RESULT( NTESTS )
* ..
* .. External Subroutines ..
EXTERNAL ALAHDG, ALAREQ, ALASUM, SLARHS, SLATB9, SLATMS,
$ SLSETS
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 3 ) = 'LSE'
INFO = 0
NRUN = 0
NFAIL = 0
FIRSTT = .TRUE.
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
LDA = NMAX
LDB = NMAX
LWORK = NMAX*NMAX
*
* Check for valid input values.
*
DO 10 IK = 1, NN
M = MVAL( IK )
P = PVAL( IK )
N = NVAL( IK )
IF( P.GT.N .OR. N.GT.M+P ) THEN
IF( FIRSTT ) THEN
WRITE( NOUT, FMT = * )
FIRSTT = .FALSE.
END IF
WRITE( NOUT, FMT = 9997 )M, P, N
END IF
10 CONTINUE
FIRSTT = .TRUE.
*
* Do for each value of M in MVAL.
*
DO 40 IK = 1, NN
M = MVAL( IK )
P = PVAL( IK )
N = NVAL( IK )
IF( P.GT.N .OR. N.GT.M+P )
$ GO TO 40
*
DO 30 IMAT = 1, NTYPES
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 30
*
* Set up parameters with SLATB9 and generate test
* matrices A and B with SLATMS.
*
CALL SLATB9( PATH, IMAT, M, P, N, TYPE, KLA, KUA, KLB, KUB,
$ ANORM, BNORM, MODEA, MODEB, CNDNMA, CNDNMB,
$ DISTA, DISTB )
*
CALL SLATMS( M, N, DISTA, ISEED, TYPE, RWORK, MODEA, CNDNMA,
$ ANORM, KLA, KUA, 'No packing', A, LDA, WORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9999 )IINFO
INFO = ABS( IINFO )
GO TO 30
END IF
*
CALL SLATMS( P, N, DISTB, ISEED, TYPE, RWORK, MODEB, CNDNMB,
$ BNORM, KLB, KUB, 'No packing', B, LDB, WORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9999 )IINFO
INFO = ABS( IINFO )
GO TO 30
END IF
*
* Generate the right-hand sides C and D for the LSE.
*
CALL SLARHS( 'SGE', 'New solution', 'Upper', 'N', M, N,
$ MAX( M-1, 0 ), MAX( N-1, 0 ), 1, A, LDA,
$ X( 4*NMAX+1 ), MAX( N, 1 ), X, MAX( M, 1 ),
$ ISEED, IINFO )
*
CALL SLARHS( 'SGE', 'Computed', 'Upper', 'N', P, N,
$ MAX( P-1, 0 ), MAX( N-1, 0 ), 1, B, LDB,
$ X( 4*NMAX+1 ), MAX( N, 1 ), X( 2*NMAX+1 ),
$ MAX( P, 1 ), ISEED, IINFO )
*
NT = 2
*
CALL SLSETS( M, P, N, A, AF, LDA, B, BF, LDB, X,
$ X( NMAX+1 ), X( 2*NMAX+1 ), X( 3*NMAX+1 ),
$ X( 4*NMAX+1 ), WORK, LWORK, RWORK,
$ RESULT( 1 ) )
*
* Print information about the tests that did not
* pass the threshold.
*
DO 20 I = 1, NT
IF( RESULT( I ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. FIRSTT ) THEN
FIRSTT = .FALSE.
CALL ALAHDG( NOUT, PATH )
END IF
WRITE( NOUT, FMT = 9998 )M, P, N, IMAT, I,
$ RESULT( I )
NFAIL = NFAIL + 1
END IF
20 CONTINUE
NRUN = NRUN + NT
*
30 CONTINUE
40 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, 0 )
*
9999 FORMAT( ' SLATMS in SCKLSE INFO = ', I5 )
9998 FORMAT( ' M=', I4, ' P=', I4, ', N=', I4, ', type ', I2,
$ ', test ', I2, ', ratio=', G13.6 )
9997 FORMAT( ' *** Invalid input for LSE: M = ', I6, ', P = ', I6,
$ ', N = ', I6, ';', / ' must satisfy P <= N <= P+M ',
$ '(this set of values will be skipped)' )
RETURN
*
* End of SCKLSE
*
END
SUBROUTINE SDRGES( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
$ NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, ALPHAR,
$ ALPHAI, BETA, WORK, LWORK, RESULT, BWORK,
$ INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL BWORK( * ), DOTYPE( * )
INTEGER ISEED( 4 ), NN( * )
REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
$ B( LDA, * ), BETA( * ), Q( LDQ, * ),
$ RESULT( 13 ), S( LDA, * ), T( LDA, * ),
$ WORK( * ), Z( LDQ, * )
* ..
*
* Purpose
* =======
*
* SDRGES checks the nonsymmetric generalized eigenvalue (Schur form)
* problem driver SGGES.
*
* SGGES factors A and B as Q S Z' and Q T Z' , where ' means
* transpose, T is upper triangular, S is in generalized Schur form
* (block upper triangular, with 1x1 and 2x2 blocks on the diagonal,
* the 2x2 blocks corresponding to complex conjugate pairs of
* generalized eigenvalues), and Q and Z are orthogonal. It also
* computes the generalized eigenvalues (alpha(j),beta(j)), j=1,...,n,
* Thus, w(j) = alpha(j)/beta(j) is a root of the characteristic
* equation
* det( A - w(j) B ) = 0
* Optionally it also reorder the eigenvalues so that a selected
* cluster of eigenvalues appears in the leading diagonal block of the
* Schur forms.
*
* When SDRGES is called, a number of matrix "sizes" ("N's") and a
* number of matrix "TYPES" are specified. For each size ("N")
* and each TYPE of matrix, a pair of matrices (A, B) will be generated
* and used for testing. For each matrix pair, the following 13 tests
* will be performed and compared with the threshhold THRESH except
* the tests (5), (11) and (13).
*
*
* (1) | A - Q S Z' | / ( |A| n ulp ) (no sorting of eigenvalues)
*
*
* (2) | B - Q T Z' | / ( |B| n ulp ) (no sorting of eigenvalues)
*
*
* (3) | I - QQ' | / ( n ulp ) (no sorting of eigenvalues)
*
*
* (4) | I - ZZ' | / ( n ulp ) (no sorting of eigenvalues)
*
* (5) if A is in Schur form (i.e. quasi-triangular form)
* (no sorting of eigenvalues)
*
* (6) if eigenvalues = diagonal blocks of the Schur form (S, T),
* i.e., test the maximum over j of D(j) where:
*
* if alpha(j) is real:
* |alpha(j) - S(j,j)| |beta(j) - T(j,j)|
* D(j) = ------------------------ + -----------------------
* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|)
*
* if alpha(j) is complex:
* | det( s S - w T ) |
* D(j) = ---------------------------------------------------
* ulp max( s norm(S), |w| norm(T) )*norm( s S - w T )
*
* and S and T are here the 2 x 2 diagonal blocks of S and T
* corresponding to the j-th and j+1-th eigenvalues.
* (no sorting of eigenvalues)
*
* (7) | (A,B) - Q (S,T) Z' | / ( | (A,B) | n ulp )
* (with sorting of eigenvalues).
*
* (8) | I - QQ' | / ( n ulp ) (with sorting of eigenvalues).
*
* (9) | I - ZZ' | / ( n ulp ) (with sorting of eigenvalues).
*
* (10) if A is in Schur form (i.e. quasi-triangular form)
* (with sorting of eigenvalues).
*
* (11) if eigenvalues = diagonal blocks of the Schur form (S, T),
* i.e. test the maximum over j of D(j) where:
*
* if alpha(j) is real:
* |alpha(j) - S(j,j)| |beta(j) - T(j,j)|
* D(j) = ------------------------ + -----------------------
* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|)
*
* if alpha(j) is complex:
* | det( s S - w T ) |
* D(j) = ---------------------------------------------------
* ulp max( s norm(S), |w| norm(T) )*norm( s S - w T )
*
* and S and T are here the 2 x 2 diagonal blocks of S and T
* corresponding to the j-th and j+1-th eigenvalues.
* (with sorting of eigenvalues).
*
* (12) if sorting worked and SDIM is the number of eigenvalues
* which were SELECTed.
*
* Test Matrices
* =============
*
* The sizes of the test matrices are specified by an array
* NN(1:NSIZES); the value of each element NN(j) specifies one size.
* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if
* DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
* Currently, the list of possible types is:
*
* (1) ( 0, 0 ) (a pair of zero matrices)
*
* (2) ( I, 0 ) (an identity and a zero matrix)
*
* (3) ( 0, I ) (an identity and a zero matrix)
*
* (4) ( I, I ) (a pair of identity matrices)
*
* t t
* (5) ( J , J ) (a pair of transposed Jordan blocks)
*
* t ( I 0 )
* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t )
* ( 0 I ) ( 0 J )
* and I is a k x k identity and J a (k+1)x(k+1)
* Jordan block; k=(N-1)/2
*
* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal
* matrix with those diagonal entries.)
* (8) ( I, D )
*
* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big
*
* (10) ( small*D, big*I )
*
* (11) ( big*I, small*D )
*
* (12) ( small*I, big*D )
*
* (13) ( big*D, big*I )
*
* (14) ( small*D, small*I )
*
* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and
* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 )
* t t
* (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices.
*
* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices
* with random O(1) entries above the diagonal
* and diagonal entries diag(T1) =
* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) =
* ( 0, N-3, N-4,..., 1, 0, 0 )
*
* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 )
* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 )
* s = machine precision.
*
* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 )
* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 )
*
* N-5
* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 )
* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
*
* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 )
* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
* where r1,..., r(N-4) are random.
*
* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular
* matrices.
*
*
* Arguments
* =========
*
* NSIZES (input) INTEGER
* The number of sizes of matrices to use. If it is zero,
* SDRGES does nothing. NSIZES >= 0.
*
* NN (input) INTEGER array, dimension (NSIZES)
* An array containing the sizes to be used for the matrices.
* Zero values will be skipped. NN >= 0.
*
* NTYPES (input) INTEGER
* The number of elements in DOTYPE. If it is zero, SDRGES
* does nothing. It must be at least zero. If it is MAXTYP+1
* and NSIZES is 1, then an additional type, MAXTYP+1 is
* defined, which is to use whatever matrix is in A on input.
* This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
* DOTYPE(MAXTYP+1) is .TRUE. .
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* If DOTYPE(j) is .TRUE., then for each size in NN a
* matrix of that size and of type j will be generated.
* If NTYPES is smaller than the maximum number of types
* defined (PARAMETER MAXTYP), then types NTYPES+1 through
* MAXTYP will not be generated. If NTYPES is larger
* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
* will be ignored.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The array elements should be between 0 and 4095;
* if not they will be reduced mod 4096. Also, ISEED(4) must
* be odd. The random number generator uses a linear
* congruential sequence limited to small integers, and so
* should produce machine independent random numbers. The
* values of ISEED are changed on exit, and can be used in the
* next call to SDRGES to continue the same random number
* sequence.
*
* THRESH (input) REAL
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error is
* scaled to be O(1), so THRESH should be a reasonably small
* multiple of 1, e.g., 10 or 100. In particular, it should
* not depend on the precision (single vs. double) or the size
* of the matrix. THRESH >= 0.
*
* NOUNIT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns IINFO not equal to 0.)
*
* A (input/workspace) REAL array,
* dimension(LDA, max(NN))
* Used to hold the original A matrix. Used as input only
* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
* DOTYPE(MAXTYP+1)=.TRUE.
*
* LDA (input) INTEGER
* The leading dimension of A, B, S, and T.
* It must be at least 1 and at least max( NN ).
*
* B (input/workspace) REAL array,
* dimension(LDA, max(NN))
* Used to hold the original B matrix. Used as input only
* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
* DOTYPE(MAXTYP+1)=.TRUE.
*
* S (workspace) REAL array, dimension (LDA, max(NN))
* The Schur form matrix computed from A by SGGES. On exit, S
* contains the Schur form matrix corresponding to the matrix
* in A.
*
* T (workspace) REAL array, dimension (LDA, max(NN))
* The upper triangular matrix computed from B by SGGES.
*
* Q (workspace) REAL array, dimension (LDQ, max(NN))
* The (left) orthogonal matrix computed by SGGES.
*
* LDQ (input) INTEGER
* The leading dimension of Q and Z. It must
* be at least 1 and at least max( NN ).
*
* Z (workspace) REAL array, dimension( LDQ, max(NN) )
* The (right) orthogonal matrix computed by SGGES.
*
* ALPHAR (workspace) REAL array, dimension (max(NN))
* ALPHAI (workspace) REAL array, dimension (max(NN))
* BETA (workspace) REAL array, dimension (max(NN))
* The generalized eigenvalues of (A,B) computed by SGGES.
* ( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th
* generalized eigenvalue of A and B.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* LWORK >= MAX( 10*(N+1), 3*N*N ), where N is the largest
* matrix dimension.
*
* RESULT (output) REAL array, dimension (15)
* The values computed by the tests described above.
* The values are currently limited to 1/ulp, to avoid overflow.
*
* BWORK (workspace) LOGICAL array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: A routine returned an error code. INFO is the
* absolute value of the INFO value returned.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 26 )
* ..
* .. Local Scalars ..
LOGICAL BADNN, ILABAD
CHARACTER SORT
INTEGER I, I1, IADD, IERR, IINFO, IN, ISORT, J, JC, JR,
$ JSIZE, JTYPE, KNTEIG, MAXWRK, MINWRK, MTYPES,
$ N, N1, NB, NERRS, NMATS, NMAX, NTEST, NTESTT,
$ RSUB, SDIM
REAL SAFMAX, SAFMIN, TEMP1, TEMP2, ULP, ULPINV
* ..
* .. Local Arrays ..
INTEGER IASIGN( MAXTYP ), IBSIGN( MAXTYP ),
$ IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ),
$ KATYPE( MAXTYP ), KAZERO( MAXTYP ),
$ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ),
$ KBZERO( MAXTYP ), KCLASS( MAXTYP ),
$ KTRIAN( MAXTYP ), KZ1( 6 ), KZ2( 6 )
REAL RMAGN( 0: 3 )
* ..
* .. External Functions ..
LOGICAL SLCTES
INTEGER ILAENV
REAL SLAMCH, SLARND
EXTERNAL SLCTES, ILAENV, SLAMCH, SLARND
* ..
* .. External Subroutines ..
EXTERNAL ALASVM, SGET51, SGET53, SGET54, SGGES, SLABAD,
$ SLACPY, SLARFG, SLASET, SLATM4, SORM2R, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL, SIGN
* ..
* .. Data statements ..
DATA KCLASS / 15*1, 10*2, 1*3 /
DATA KZ1 / 0, 1, 2, 1, 3, 3 /
DATA KZ2 / 0, 0, 1, 2, 1, 1 /
DATA KADD / 0, 0, 0, 0, 3, 2 /
DATA KATYPE / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4,
$ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 /
DATA KBTYPE / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4,
$ 1, 1, -4, 2, -4, 8*8, 0 /
DATA KAZERO / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3,
$ 4*5, 4*3, 1 /
DATA KBZERO / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4,
$ 4*6, 4*4, 1 /
DATA KAMAGN / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3,
$ 2, 1 /
DATA KBMAGN / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3,
$ 2, 1 /
DATA KTRIAN / 16*0, 10*1 /
DATA IASIGN / 6*0, 2, 0, 2*2, 2*0, 3*2, 0, 2, 3*0,
$ 5*2, 0 /
DATA IBSIGN / 7*0, 2, 2*0, 2*2, 2*0, 2, 0, 2, 9*0 /
* ..
* .. Executable Statements ..
*
* Check for errors
*
INFO = 0
*
BADNN = .FALSE.
NMAX = 1
DO 10 J = 1, NSIZES
NMAX = MAX( NMAX, NN( J ) )
IF( NN( J ).LT.0 )
$ BADNN = .TRUE.
10 CONTINUE
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADNN ) THEN
INFO = -2
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -3
ELSE IF( THRESH.LT.ZERO ) THEN
INFO = -6
ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN
INFO = -9
ELSE IF( LDQ.LE.1 .OR. LDQ.LT.NMAX ) THEN
INFO = -14
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.
*
MINWRK = 1
IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN
MINWRK = MAX( 10*( NMAX+1 ), 3*NMAX*NMAX )
NB = MAX( 1, ILAENV( 1, 'SGEQRF', ' ', NMAX, NMAX, -1, -1 ),
$ ILAENV( 1, 'SORMQR', 'LT', NMAX, NMAX, NMAX, -1 ),
$ ILAENV( 1, 'SORGQR', ' ', NMAX, NMAX, NMAX, -1 ) )
MAXWRK = MAX( 10*( NMAX+1 ), 2*NMAX+NMAX*NB, 3*NMAX*NMAX )
WORK( 1 ) = MAXWRK
END IF
*
IF( LWORK.LT.MINWRK )
$ INFO = -20
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SDRGES', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
$ RETURN
*
SAFMIN = SLAMCH( 'Safe minimum' )
ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
SAFMIN = SAFMIN / ULP
SAFMAX = ONE / SAFMIN
CALL SLABAD( SAFMIN, SAFMAX )
ULPINV = ONE / ULP
*
* The values RMAGN(2:3) depend on N, see below.
*
RMAGN( 0 ) = ZERO
RMAGN( 1 ) = ONE
*
* Loop over matrix sizes
*
NTESTT = 0
NERRS = 0
NMATS = 0
*
DO 190 JSIZE = 1, NSIZES
N = NN( JSIZE )
N1 = MAX( 1, N )
RMAGN( 2 ) = SAFMAX*ULP / REAL( N1 )
RMAGN( 3 ) = SAFMIN*ULPINV*REAL( N1 )
*
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
* Loop over matrix types
*
DO 180 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 180
NMATS = NMATS + 1
NTEST = 0
*
* Save ISEED in case of an error.
*
DO 20 J = 1, 4
IOLDSD( J ) = ISEED( J )
20 CONTINUE
*
* Initialize RESULT
*
DO 30 J = 1, 13
RESULT( J ) = ZERO
30 CONTINUE
*
* Generate test matrices A and B
*
* Description of control parameters:
*
* KCLASS: =1 means w/o rotation, =2 means w/ rotation,
* =3 means random.
* KATYPE: the "type" to be passed to SLATM4 for computing A.
* KAZERO: the pattern of zeros on the diagonal for A:
* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ),
* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ),
* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of
* non-zero entries.)
* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1),
* =2: large, =3: small.
* IASIGN: 1 if the diagonal elements of A are to be
* multiplied by a random magnitude 1 number, =2 if
* randomly chosen diagonal blocks are to be rotated
* to form 2x2 blocks.
* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B.
* KTRIAN: =0: don't fill in the upper triangle, =1: do.
* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO.
* RMAGN: used to implement KAMAGN and KBMAGN.
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 110
IINFO = 0
IF( KCLASS( JTYPE ).LT.3 ) THEN
*
* Generate A (w/o rotation)
*
IF( ABS( KATYPE( JTYPE ) ).EQ.3 ) THEN
IN = 2*( ( N-1 ) / 2 ) + 1
IF( IN.NE.N )
$ CALL SLASET( 'Full', N, N, ZERO, ZERO, A, LDA )
ELSE
IN = N
END IF
CALL SLATM4( KATYPE( JTYPE ), IN, KZ1( KAZERO( JTYPE ) ),
$ KZ2( KAZERO( JTYPE ) ), IASIGN( JTYPE ),
$ RMAGN( KAMAGN( JTYPE ) ), ULP,
$ RMAGN( KTRIAN( JTYPE )*KAMAGN( JTYPE ) ), 2,
$ ISEED, A, LDA )
IADD = KADD( KAZERO( JTYPE ) )
IF( IADD.GT.0 .AND. IADD.LE.N )
$ A( IADD, IADD ) = ONE
*
* Generate B (w/o rotation)
*
IF( ABS( KBTYPE( JTYPE ) ).EQ.3 ) THEN
IN = 2*( ( N-1 ) / 2 ) + 1
IF( IN.NE.N )
$ CALL SLASET( 'Full', N, N, ZERO, ZERO, B, LDA )
ELSE
IN = N
END IF
CALL SLATM4( KBTYPE( JTYPE ), IN, KZ1( KBZERO( JTYPE ) ),
$ KZ2( KBZERO( JTYPE ) ), IBSIGN( JTYPE ),
$ RMAGN( KBMAGN( JTYPE ) ), ONE,
$ RMAGN( KTRIAN( JTYPE )*KBMAGN( JTYPE ) ), 2,
$ ISEED, B, LDA )
IADD = KADD( KBZERO( JTYPE ) )
IF( IADD.NE.0 .AND. IADD.LE.N )
$ B( IADD, IADD ) = ONE
*
IF( KCLASS( JTYPE ).EQ.2 .AND. N.GT.0 ) THEN
*
* Include rotations
*
* Generate Q, Z as Householder transformations times
* a diagonal matrix.
*
DO 50 JC = 1, N - 1
DO 40 JR = JC, N
Q( JR, JC ) = SLARND( 3, ISEED )
Z( JR, JC ) = SLARND( 3, ISEED )
40 CONTINUE
CALL SLARFG( N+1-JC, Q( JC, JC ), Q( JC+1, JC ), 1,
$ WORK( JC ) )
WORK( 2*N+JC ) = SIGN( ONE, Q( JC, JC ) )
Q( JC, JC ) = ONE
CALL SLARFG( N+1-JC, Z( JC, JC ), Z( JC+1, JC ), 1,
$ WORK( N+JC ) )
WORK( 3*N+JC ) = SIGN( ONE, Z( JC, JC ) )
Z( JC, JC ) = ONE
50 CONTINUE
Q( N, N ) = ONE
WORK( N ) = ZERO
WORK( 3*N ) = SIGN( ONE, SLARND( 2, ISEED ) )
Z( N, N ) = ONE
WORK( 2*N ) = ZERO
WORK( 4*N ) = SIGN( ONE, SLARND( 2, ISEED ) )
*
* Apply the diagonal matrices
*
DO 70 JC = 1, N
DO 60 JR = 1, N
A( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
$ A( JR, JC )
B( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
$ B( JR, JC )
60 CONTINUE
70 CONTINUE
CALL SORM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, A,
$ LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
CALL SORM2R( 'R', 'T', N, N, N-1, Z, LDQ, WORK( N+1 ),
$ A, LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
CALL SORM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, B,
$ LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
CALL SORM2R( 'R', 'T', N, N, N-1, Z, LDQ, WORK( N+1 ),
$ B, LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
END IF
ELSE
*
* Random matrices
*
DO 90 JC = 1, N
DO 80 JR = 1, N
A( JR, JC ) = RMAGN( KAMAGN( JTYPE ) )*
$ SLARND( 2, ISEED )
B( JR, JC ) = RMAGN( KBMAGN( JTYPE ) )*
$ SLARND( 2, ISEED )
80 CONTINUE
90 CONTINUE
END IF
*
100 CONTINUE
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
110 CONTINUE
*
DO 120 I = 1, 13
RESULT( I ) = -ONE
120 CONTINUE
*
* Test with and without sorting of eigenvalues
*
DO 150 ISORT = 0, 1
IF( ISORT.EQ.0 ) THEN
SORT = 'N'
RSUB = 0
ELSE
SORT = 'S'
RSUB = 5
END IF
*
* Call SGGES to compute H, T, Q, Z, alpha, and beta.
*
CALL SLACPY( 'Full', N, N, A, LDA, S, LDA )
CALL SLACPY( 'Full', N, N, B, LDA, T, LDA )
NTEST = 1 + RSUB + ISORT
RESULT( 1+RSUB+ISORT ) = ULPINV
CALL SGGES( 'V', 'V', SORT, SLCTES, N, S, LDA, T, LDA,
$ SDIM, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDQ,
$ WORK, LWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 1+RSUB+ISORT ) = ULPINV
WRITE( NOUNIT, FMT = 9999 )'SGGES', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 160
END IF
*
NTEST = 4 + RSUB
*
* Do tests 1--4 (or tests 7--9 when reordering )
*
IF( ISORT.EQ.0 ) THEN
CALL SGET51( 1, N, A, LDA, S, LDA, Q, LDQ, Z, LDQ,
$ WORK, RESULT( 1 ) )
CALL SGET51( 1, N, B, LDA, T, LDA, Q, LDQ, Z, LDQ,
$ WORK, RESULT( 2 ) )
ELSE
CALL SGET54( N, A, LDA, B, LDA, S, LDA, T, LDA, Q,
$ LDQ, Z, LDQ, WORK, RESULT( 7 ) )
END IF
CALL SGET51( 3, N, A, LDA, T, LDA, Q, LDQ, Q, LDQ, WORK,
$ RESULT( 3+RSUB ) )
CALL SGET51( 3, N, B, LDA, T, LDA, Z, LDQ, Z, LDQ, WORK,
$ RESULT( 4+RSUB ) )
*
* Do test 5 and 6 (or Tests 10 and 11 when reordering):
* check Schur form of A and compare eigenvalues with
* diagonals.
*
NTEST = 6 + RSUB
TEMP1 = ZERO
*
DO 130 J = 1, N
ILABAD = .FALSE.
IF( ALPHAI( J ).EQ.ZERO ) THEN
TEMP2 = ( ABS( ALPHAR( J )-S( J, J ) ) /
$ MAX( SAFMIN, ABS( ALPHAR( J ) ), ABS( S( J,
$ J ) ) )+ABS( BETA( J )-T( J, J ) ) /
$ MAX( SAFMIN, ABS( BETA( J ) ), ABS( T( J,
$ J ) ) ) ) / ULP
*
IF( J.LT.N ) THEN
IF( S( J+1, J ).NE.ZERO ) THEN
ILABAD = .TRUE.
RESULT( 5+RSUB ) = ULPINV
END IF
END IF
IF( J.GT.1 ) THEN
IF( S( J, J-1 ).NE.ZERO ) THEN
ILABAD = .TRUE.
RESULT( 5+RSUB ) = ULPINV
END IF
END IF
*
ELSE
IF( ALPHAI( J ).GT.ZERO ) THEN
I1 = J
ELSE
I1 = J - 1
END IF
IF( I1.LE.0 .OR. I1.GE.N ) THEN
ILABAD = .TRUE.
ELSE IF( I1.LT.N-1 ) THEN
IF( S( I1+2, I1+1 ).NE.ZERO ) THEN
ILABAD = .TRUE.
RESULT( 5+RSUB ) = ULPINV
END IF
ELSE IF( I1.GT.1 ) THEN
IF( S( I1, I1-1 ).NE.ZERO ) THEN
ILABAD = .TRUE.
RESULT( 5+RSUB ) = ULPINV
END IF
END IF
IF( .NOT.ILABAD ) THEN
CALL SGET53( S( I1, I1 ), LDA, T( I1, I1 ), LDA,
$ BETA( J ), ALPHAR( J ),
$ ALPHAI( J ), TEMP2, IERR )
IF( IERR.GE.3 ) THEN
WRITE( NOUNIT, FMT = 9998 )IERR, J, N,
$ JTYPE, IOLDSD
INFO = ABS( IERR )
END IF
ELSE
TEMP2 = ULPINV
END IF
*
END IF
TEMP1 = MAX( TEMP1, TEMP2 )
IF( ILABAD ) THEN
WRITE( NOUNIT, FMT = 9997 )J, N, JTYPE, IOLDSD
END IF
130 CONTINUE
RESULT( 6+RSUB ) = TEMP1
*
IF( ISORT.GE.1 ) THEN
*
* Do test 12
*
NTEST = 12
RESULT( 12 ) = ZERO
KNTEIG = 0
DO 140 I = 1, N
IF( SLCTES( ALPHAR( I ), ALPHAI( I ),
$ BETA( I ) ) .OR. SLCTES( ALPHAR( I ),
$ -ALPHAI( I ), BETA( I ) ) ) THEN
KNTEIG = KNTEIG + 1
END IF
IF( I.LT.N ) THEN
IF( ( SLCTES( ALPHAR( I+1 ), ALPHAI( I+1 ),
$ BETA( I+1 ) ) .OR. SLCTES( ALPHAR( I+1 ),
$ -ALPHAI( I+1 ), BETA( I+1 ) ) ) .AND.
$ ( .NOT.( SLCTES( ALPHAR( I ), ALPHAI( I ),
$ BETA( I ) ) .OR. SLCTES( ALPHAR( I ),
$ -ALPHAI( I ), BETA( I ) ) ) ) .AND.
$ IINFO.NE.N+2 ) THEN
RESULT( 12 ) = ULPINV
END IF
END IF
140 CONTINUE
IF( SDIM.NE.KNTEIG ) THEN
RESULT( 12 ) = ULPINV
END IF
END IF
*
150 CONTINUE
*
* End of Loop -- Check for RESULT(j) > THRESH
*
160 CONTINUE
*
NTESTT = NTESTT + NTEST
*
* Print out tests which fail.
*
DO 170 JR = 1, NTEST
IF( RESULT( JR ).GE.THRESH ) THEN
*
* If this is the first test to fail,
* print a header to the data file.
*
IF( NERRS.EQ.0 ) THEN
WRITE( NOUNIT, FMT = 9996 )'SGS'
*
* Matrix types
*
WRITE( NOUNIT, FMT = 9995 )
WRITE( NOUNIT, FMT = 9994 )
WRITE( NOUNIT, FMT = 9993 )'Orthogonal'
*
* Tests performed
*
WRITE( NOUNIT, FMT = 9992 )'orthogonal', '''',
$ 'transpose', ( '''', J = 1, 8 )
*
END IF
NERRS = NERRS + 1
IF( RESULT( JR ).LT.10000.0 ) THEN
WRITE( NOUNIT, FMT = 9991 )N, JTYPE, IOLDSD, JR,
$ RESULT( JR )
ELSE
WRITE( NOUNIT, FMT = 9990 )N, JTYPE, IOLDSD, JR,
$ RESULT( JR )
END IF
END IF
170 CONTINUE
*
180 CONTINUE
190 CONTINUE
*
* Summary
*
CALL ALASVM( 'SGS', NOUNIT, NERRS, NTESTT, 0 )
*
WORK( 1 ) = MAXWRK
*
RETURN
*
9999 FORMAT( ' SDRGES: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ', ISEED=(', 4( I4, ',' ), I5, ')' )
*
9998 FORMAT( ' SDRGES: SGET53 returned INFO=', I1, ' for eigenvalue ',
$ I6, '.', / 9X, 'N=', I6, ', JTYPE=', I6, ', ISEED=(',
$ 4( I4, ',' ), I5, ')' )
*
9997 FORMAT( ' SDRGES: S not in Schur form at eigenvalue ', I6, '.',
$ / 9X, 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ),
$ I5, ')' )
*
9996 FORMAT( / 1X, A3, ' -- Real Generalized Schur form driver' )
*
9995 FORMAT( ' Matrix types (see SDRGES for details): ' )
*
9994 FORMAT( ' Special Matrices:', 23X,
$ '(J''=transposed Jordan block)',
$ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ',
$ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ',
$ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I',
$ ') 11=(large*I, small*D) 13=(large*D, large*I)', /
$ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ',
$ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' )
9993 FORMAT( ' Matrices Rotated by Random ', A, ' Matrices U, V:',
$ / ' 16=Transposed Jordan Blocks 19=geometric ',
$ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ',
$ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ',
$ 'alpha, beta=0,1 21=random alpha, beta=0,1',
$ / ' Large & Small Matrices:', / ' 22=(large, small) ',
$ '23=(small,large) 24=(small,small) 25=(large,large)',
$ / ' 26=random O(1) matrices.' )
*
9992 FORMAT( / ' Tests performed: (S is Schur, T is triangular, ',
$ 'Q and Z are ', A, ',', / 19X,
$ 'l and r are the appropriate left and right', / 19X,
$ 'eigenvectors, resp., a is alpha, b is beta, and', / 19X, A,
$ ' means ', A, '.)', / ' Without ordering: ',
$ / ' 1 = | A - Q S Z', A,
$ ' | / ( |A| n ulp ) 2 = | B - Q T Z', A,
$ ' | / ( |B| n ulp )', / ' 3 = | I - QQ', A,
$ ' | / ( n ulp ) 4 = | I - ZZ', A,
$ ' | / ( n ulp )', / ' 5 = A is in Schur form S',
$ / ' 6 = difference between (alpha,beta)',
$ ' and diagonals of (S,T)', / ' With ordering: ',
$ / ' 7 = | (A,B) - Q (S,T) Z', A,
$ ' | / ( |(A,B)| n ulp ) ', / ' 8 = | I - QQ', A,
$ ' | / ( n ulp ) 9 = | I - ZZ', A,
$ ' | / ( n ulp )', / ' 10 = A is in Schur form S',
$ / ' 11 = difference between (alpha,beta) and diagonals',
$ ' of (S,T)', / ' 12 = SDIM is the correct number of ',
$ 'selected eigenvalues', / )
9991 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
$ 4( I4, ',' ), ' result ', I2, ' is', 0P, F8.2 )
9990 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
$ 4( I4, ',' ), ' result ', I2, ' is', 1P, E10.3 )
*
* End of SDRGES
*
END
SUBROUTINE SDRGEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
$ NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, QE, LDQE,
$ ALPHAR, ALPHAI, BETA, ALPHR1, ALPHI1, BETA1,
$ WORK, LWORK, RESULT, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDQ, LDQE, LWORK, NOUNIT, NSIZES,
$ NTYPES
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER ISEED( 4 ), NN( * )
REAL A( LDA, * ), ALPHAI( * ), ALPHI1( * ),
$ ALPHAR( * ), ALPHR1( * ), B( LDA, * ),
$ BETA( * ), BETA1( * ), Q( LDQ, * ),
$ QE( LDQE, * ), RESULT( * ), S( LDA, * ),
$ T( LDA, * ), WORK( * ), Z( LDQ, * )
* ..
*
* Purpose
* =======
*
* SDRGEV checks the nonsymmetric generalized eigenvalue problem driver
* routine SGGEV.
*
* SGGEV computes for a pair of n-by-n nonsymmetric matrices (A,B) the
* generalized eigenvalues and, optionally, the left and right
* eigenvectors.
*
* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
* or a ratio alpha/beta = w, such that A - w*B is singular. It is
* usually represented as the pair (alpha,beta), as there is reasonalbe
* interpretation for beta=0, and even for both being zero.
*
* A right generalized eigenvector corresponding to a generalized
* eigenvalue w for a pair of matrices (A,B) is a vector r such that
* (A - wB) * r = 0. A left generalized eigenvector is a vector l such
* that l**H * (A - wB) = 0, where l**H is the conjugate-transpose of l.
*
* When SDRGEV is called, a number of matrix "sizes" ("n's") and a
* number of matrix "types" are specified. For each size ("n")
* and each type of matrix, a pair of matrices (A, B) will be generated
* and used for testing. For each matrix pair, the following tests
* will be performed and compared with the threshhold THRESH.
*
* Results from SGGEV:
*
* (1) max over all left eigenvalue/-vector pairs (alpha/beta,l) of
*
* | VL**H * (beta A - alpha B) |/( ulp max(|beta A|, |alpha B|) )
*
* where VL**H is the conjugate-transpose of VL.
*
* (2) | |VL(i)| - 1 | / ulp and whether largest component real
*
* VL(i) denotes the i-th column of VL.
*
* (3) max over all left eigenvalue/-vector pairs (alpha/beta,r) of
*
* | (beta A - alpha B) * VR | / ( ulp max(|beta A|, |alpha B|) )
*
* (4) | |VR(i)| - 1 | / ulp and whether largest component real
*
* VR(i) denotes the i-th column of VR.
*
* (5) W(full) = W(partial)
* W(full) denotes the eigenvalues computed when both l and r
* are also computed, and W(partial) denotes the eigenvalues
* computed when only W, only W and r, or only W and l are
* computed.
*
* (6) VL(full) = VL(partial)
* VL(full) denotes the left eigenvectors computed when both l
* and r are computed, and VL(partial) denotes the result
* when only l is computed.
*
* (7) VR(full) = VR(partial)
* VR(full) denotes the right eigenvectors computed when both l
* and r are also computed, and VR(partial) denotes the result
* when only l is computed.
*
*
* Test Matrices
* ---- --------
*
* The sizes of the test matrices are specified by an array
* NN(1:NSIZES); the value of each element NN(j) specifies one size.
* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if
* DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
* Currently, the list of possible types is:
*
* (1) ( 0, 0 ) (a pair of zero matrices)
*
* (2) ( I, 0 ) (an identity and a zero matrix)
*
* (3) ( 0, I ) (an identity and a zero matrix)
*
* (4) ( I, I ) (a pair of identity matrices)
*
* t t
* (5) ( J , J ) (a pair of transposed Jordan blocks)
*
* t ( I 0 )
* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t )
* ( 0 I ) ( 0 J )
* and I is a k x k identity and J a (k+1)x(k+1)
* Jordan block; k=(N-1)/2
*
* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal
* matrix with those diagonal entries.)
* (8) ( I, D )
*
* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big
*
* (10) ( small*D, big*I )
*
* (11) ( big*I, small*D )
*
* (12) ( small*I, big*D )
*
* (13) ( big*D, big*I )
*
* (14) ( small*D, small*I )
*
* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and
* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 )
* t t
* (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices.
*
* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices
* with random O(1) entries above the diagonal
* and diagonal entries diag(T1) =
* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) =
* ( 0, N-3, N-4,..., 1, 0, 0 )
*
* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 )
* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 )
* s = machine precision.
*
* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 )
* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 )
*
* N-5
* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 )
* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
*
* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 )
* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
* where r1,..., r(N-4) are random.
*
* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular
* matrices.
*
*
* Arguments
* =========
*
* NSIZES (input) INTEGER
* The number of sizes of matrices to use. If it is zero,
* SDRGES does nothing. NSIZES >= 0.
*
* NN (input) INTEGER array, dimension (NSIZES)
* An array containing the sizes to be used for the matrices.
* Zero values will be skipped. NN >= 0.
*
* NTYPES (input) INTEGER
* The number of elements in DOTYPE. If it is zero, SDRGES
* does nothing. It must be at least zero. If it is MAXTYP+1
* and NSIZES is 1, then an additional type, MAXTYP+1 is
* defined, which is to use whatever matrix is in A. This
* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
* DOTYPE(MAXTYP+1) is .TRUE. .
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* If DOTYPE(j) is .TRUE., then for each size in NN a
* matrix of that size and of type j will be generated.
* If NTYPES is smaller than the maximum number of types
* defined (PARAMETER MAXTYP), then types NTYPES+1 through
* MAXTYP will not be generated. If NTYPES is larger
* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
* will be ignored.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The array elements should be between 0 and 4095;
* if not they will be reduced mod 4096. Also, ISEED(4) must
* be odd. The random number generator uses a linear
* congruential sequence limited to small integers, and so
* should produce machine independent random numbers. The
* values of ISEED are changed on exit, and can be used in the
* next call to SDRGES to continue the same random number
* sequence.
*
* THRESH (input) REAL
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error is
* scaled to be O(1), so THRESH should be a reasonably small
* multiple of 1, e.g., 10 or 100. In particular, it should
* not depend on the precision (single vs. double) or the size
* of the matrix. It must be at least zero.
*
* NOUNIT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns IERR not equal to 0.)
*
* A (input/workspace) REAL array,
* dimension(LDA, max(NN))
* Used to hold the original A matrix. Used as input only
* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
* DOTYPE(MAXTYP+1)=.TRUE.
*
* LDA (input) INTEGER
* The leading dimension of A, B, S, and T.
* It must be at least 1 and at least max( NN ).
*
* B (input/workspace) REAL array,
* dimension(LDA, max(NN))
* Used to hold the original B matrix. Used as input only
* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
* DOTYPE(MAXTYP+1)=.TRUE.
*
* S (workspace) REAL array,
* dimension (LDA, max(NN))
* The Schur form matrix computed from A by SGGES. On exit, S
* contains the Schur form matrix corresponding to the matrix
* in A.
*
* T (workspace) REAL array,
* dimension (LDA, max(NN))
* The upper triangular matrix computed from B by SGGES.
*
* Q (workspace) REAL array,
* dimension (LDQ, max(NN))
* The (left) eigenvectors matrix computed by SGGEV.
*
* LDQ (input) INTEGER
* The leading dimension of Q and Z. It must
* be at least 1 and at least max( NN ).
*
* Z (workspace) REAL array, dimension( LDQ, max(NN) )
* The (right) orthogonal matrix computed by SGGES.
*
* QE (workspace) REAL array, dimension( LDQ, max(NN) )
* QE holds the computed right or left eigenvectors.
*
* LDQE (input) INTEGER
* The leading dimension of QE. LDQE >= max(1,max(NN)).
*
* ALPHAR (workspace) REAL array, dimension (max(NN))
* ALPHAI (workspace) REAL array, dimension (max(NN))
* BETA (workspace) REAL array, dimension (max(NN))
* The generalized eigenvalues of (A,B) computed by SGGEV.
* ( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th
* generalized eigenvalue of A and B.
*
* ALPHR1 (workspace) REAL array, dimension (max(NN))
* ALPHI1 (workspace) REAL array, dimension (max(NN))
* BETA1 (workspace) REAL array, dimension (max(NN))
* Like ALPHAR, ALPHAI, BETA, these arrays contain the
* eigenvalues of A and B, but those computed when SGGEV only
* computes a partial eigendecomposition, i.e. not the
* eigenvalues and left and right eigenvectors.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The number of entries in WORK. LWORK >= MAX( 8*N, N*(N+1) ).
*
* RESULT (output) REAL array, dimension (2)
* The values computed by the tests described above.
* The values are currently limited to 1/ulp, to avoid overflow.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: A routine returned an error code. INFO is the
* absolute value of the INFO value returned.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 26 )
* ..
* .. Local Scalars ..
LOGICAL BADNN
INTEGER I, IADD, IERR, IN, J, JC, JR, JSIZE, JTYPE,
$ MAXWRK, MINWRK, MTYPES, N, N1, NERRS, NMATS,
$ NMAX, NTESTT
REAL SAFMAX, SAFMIN, ULP, ULPINV
* ..
* .. Local Arrays ..
INTEGER IASIGN( MAXTYP ), IBSIGN( MAXTYP ),
$ IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ),
$ KATYPE( MAXTYP ), KAZERO( MAXTYP ),
$ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ),
$ KBZERO( MAXTYP ), KCLASS( MAXTYP ),
$ KTRIAN( MAXTYP ), KZ1( 6 ), KZ2( 6 )
REAL RMAGN( 0: 3 )
* ..
* .. External Functions ..
INTEGER ILAENV
REAL SLAMCH, SLARND
EXTERNAL ILAENV, SLAMCH, SLARND
* ..
* .. External Subroutines ..
EXTERNAL ALASVM, SGET52, SGGEV, SLABAD, SLACPY, SLARFG,
$ SLASET, SLATM4, SORM2R, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL, SIGN
* ..
* .. Data statements ..
DATA KCLASS / 15*1, 10*2, 1*3 /
DATA KZ1 / 0, 1, 2, 1, 3, 3 /
DATA KZ2 / 0, 0, 1, 2, 1, 1 /
DATA KADD / 0, 0, 0, 0, 3, 2 /
DATA KATYPE / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4,
$ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 /
DATA KBTYPE / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4,
$ 1, 1, -4, 2, -4, 8*8, 0 /
DATA KAZERO / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3,
$ 4*5, 4*3, 1 /
DATA KBZERO / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4,
$ 4*6, 4*4, 1 /
DATA KAMAGN / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3,
$ 2, 1 /
DATA KBMAGN / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3,
$ 2, 1 /
DATA KTRIAN / 16*0, 10*1 /
DATA IASIGN / 6*0, 2, 0, 2*2, 2*0, 3*2, 0, 2, 3*0,
$ 5*2, 0 /
DATA IBSIGN / 7*0, 2, 2*0, 2*2, 2*0, 2, 0, 2, 9*0 /
* ..
* .. Executable Statements ..
*
* Check for errors
*
INFO = 0
*
BADNN = .FALSE.
NMAX = 1
DO 10 J = 1, NSIZES
NMAX = MAX( NMAX, NN( J ) )
IF( NN( J ).LT.0 )
$ BADNN = .TRUE.
10 CONTINUE
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADNN ) THEN
INFO = -2
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -3
ELSE IF( THRESH.LT.ZERO ) THEN
INFO = -6
ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN
INFO = -9
ELSE IF( LDQ.LE.1 .OR. LDQ.LT.NMAX ) THEN
INFO = -14
ELSE IF( LDQE.LE.1 .OR. LDQE.LT.NMAX ) THEN
INFO = -17
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.
*
MINWRK = 1
IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN
MINWRK = MAX( 1, 8*NMAX, NMAX*( NMAX+1 ) )
MAXWRK = 7*NMAX + NMAX*ILAENV( 1, 'SGEQRF', ' ', NMAX, 1, NMAX,
$ 0 )
MAXWRK = MAX( MAXWRK, NMAX*( NMAX+1 ) )
WORK( 1 ) = MAXWRK
END IF
*
IF( LWORK.LT.MINWRK )
$ INFO = -25
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SDRGEV', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
$ RETURN
*
SAFMIN = SLAMCH( 'Safe minimum' )
ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
SAFMIN = SAFMIN / ULP
SAFMAX = ONE / SAFMIN
CALL SLABAD( SAFMIN, SAFMAX )
ULPINV = ONE / ULP
*
* The values RMAGN(2:3) depend on N, see below.
*
RMAGN( 0 ) = ZERO
RMAGN( 1 ) = ONE
*
* Loop over sizes, types
*
NTESTT = 0
NERRS = 0
NMATS = 0
*
DO 220 JSIZE = 1, NSIZES
N = NN( JSIZE )
N1 = MAX( 1, N )
RMAGN( 2 ) = SAFMAX*ULP / REAL( N1 )
RMAGN( 3 ) = SAFMIN*ULPINV*N1
*
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
DO 210 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 210
NMATS = NMATS + 1
*
* Save ISEED in case of an error.
*
DO 20 J = 1, 4
IOLDSD( J ) = ISEED( J )
20 CONTINUE
*
* Generate test matrices A and B
*
* Description of control parameters:
*
* KCLASS: =1 means w/o rotation, =2 means w/ rotation,
* =3 means random.
* KATYPE: the "type" to be passed to SLATM4 for computing A.
* KAZERO: the pattern of zeros on the diagonal for A:
* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ),
* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ),
* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of
* non-zero entries.)
* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1),
* =2: large, =3: small.
* IASIGN: 1 if the diagonal elements of A are to be
* multiplied by a random magnitude 1 number, =2 if
* randomly chosen diagonal blocks are to be rotated
* to form 2x2 blocks.
* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B.
* KTRIAN: =0: don't fill in the upper triangle, =1: do.
* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO.
* RMAGN: used to implement KAMAGN and KBMAGN.
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 100
IERR = 0
IF( KCLASS( JTYPE ).LT.3 ) THEN
*
* Generate A (w/o rotation)
*
IF( ABS( KATYPE( JTYPE ) ).EQ.3 ) THEN
IN = 2*( ( N-1 ) / 2 ) + 1
IF( IN.NE.N )
$ CALL SLASET( 'Full', N, N, ZERO, ZERO, A, LDA )
ELSE
IN = N
END IF
CALL SLATM4( KATYPE( JTYPE ), IN, KZ1( KAZERO( JTYPE ) ),
$ KZ2( KAZERO( JTYPE ) ), IASIGN( JTYPE ),
$ RMAGN( KAMAGN( JTYPE ) ), ULP,
$ RMAGN( KTRIAN( JTYPE )*KAMAGN( JTYPE ) ), 2,
$ ISEED, A, LDA )
IADD = KADD( KAZERO( JTYPE ) )
IF( IADD.GT.0 .AND. IADD.LE.N )
$ A( IADD, IADD ) = ONE
*
* Generate B (w/o rotation)
*
IF( ABS( KBTYPE( JTYPE ) ).EQ.3 ) THEN
IN = 2*( ( N-1 ) / 2 ) + 1
IF( IN.NE.N )
$ CALL SLASET( 'Full', N, N, ZERO, ZERO, B, LDA )
ELSE
IN = N
END IF
CALL SLATM4( KBTYPE( JTYPE ), IN, KZ1( KBZERO( JTYPE ) ),
$ KZ2( KBZERO( JTYPE ) ), IBSIGN( JTYPE ),
$ RMAGN( KBMAGN( JTYPE ) ), ONE,
$ RMAGN( KTRIAN( JTYPE )*KBMAGN( JTYPE ) ), 2,
$ ISEED, B, LDA )
IADD = KADD( KBZERO( JTYPE ) )
IF( IADD.NE.0 .AND. IADD.LE.N )
$ B( IADD, IADD ) = ONE
*
IF( KCLASS( JTYPE ).EQ.2 .AND. N.GT.0 ) THEN
*
* Include rotations
*
* Generate Q, Z as Householder transformations times
* a diagonal matrix.
*
DO 40 JC = 1, N - 1
DO 30 JR = JC, N
Q( JR, JC ) = SLARND( 3, ISEED )
Z( JR, JC ) = SLARND( 3, ISEED )
30 CONTINUE
CALL SLARFG( N+1-JC, Q( JC, JC ), Q( JC+1, JC ), 1,
$ WORK( JC ) )
WORK( 2*N+JC ) = SIGN( ONE, Q( JC, JC ) )
Q( JC, JC ) = ONE
CALL SLARFG( N+1-JC, Z( JC, JC ), Z( JC+1, JC ), 1,
$ WORK( N+JC ) )
WORK( 3*N+JC ) = SIGN( ONE, Z( JC, JC ) )
Z( JC, JC ) = ONE
40 CONTINUE
Q( N, N ) = ONE
WORK( N ) = ZERO
WORK( 3*N ) = SIGN( ONE, SLARND( 2, ISEED ) )
Z( N, N ) = ONE
WORK( 2*N ) = ZERO
WORK( 4*N ) = SIGN( ONE, SLARND( 2, ISEED ) )
*
* Apply the diagonal matrices
*
DO 60 JC = 1, N
DO 50 JR = 1, N
A( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
$ A( JR, JC )
B( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
$ B( JR, JC )
50 CONTINUE
60 CONTINUE
CALL SORM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, A,
$ LDA, WORK( 2*N+1 ), IERR )
IF( IERR.NE.0 )
$ GO TO 90
CALL SORM2R( 'R', 'T', N, N, N-1, Z, LDQ, WORK( N+1 ),
$ A, LDA, WORK( 2*N+1 ), IERR )
IF( IERR.NE.0 )
$ GO TO 90
CALL SORM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, B,
$ LDA, WORK( 2*N+1 ), IERR )
IF( IERR.NE.0 )
$ GO TO 90
CALL SORM2R( 'R', 'T', N, N, N-1, Z, LDQ, WORK( N+1 ),
$ B, LDA, WORK( 2*N+1 ), IERR )
IF( IERR.NE.0 )
$ GO TO 90
END IF
ELSE
*
* Random matrices
*
DO 80 JC = 1, N
DO 70 JR = 1, N
A( JR, JC ) = RMAGN( KAMAGN( JTYPE ) )*
$ SLARND( 2, ISEED )
B( JR, JC ) = RMAGN( KBMAGN( JTYPE ) )*
$ SLARND( 2, ISEED )
70 CONTINUE
80 CONTINUE
END IF
*
90 CONTINUE
*
IF( IERR.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'Generator', IERR, N, JTYPE,
$ IOLDSD
INFO = ABS( IERR )
RETURN
END IF
*
100 CONTINUE
*
DO 110 I = 1, 7
RESULT( I ) = -ONE
110 CONTINUE
*
* Call SGGEV to compute eigenvalues and eigenvectors.
*
CALL SLACPY( ' ', N, N, A, LDA, S, LDA )
CALL SLACPY( ' ', N, N, B, LDA, T, LDA )
CALL SGGEV( 'V', 'V', N, S, LDA, T, LDA, ALPHAR, ALPHAI,
$ BETA, Q, LDQ, Z, LDQ, WORK, LWORK, IERR )
IF( IERR.NE.0 .AND. IERR.NE.N+1 ) THEN
RESULT( 1 ) = ULPINV
WRITE( NOUNIT, FMT = 9999 )'SGGEV1', IERR, N, JTYPE,
$ IOLDSD
INFO = ABS( IERR )
GO TO 190
END IF
*
* Do the tests (1) and (2)
*
CALL SGET52( .TRUE., N, A, LDA, B, LDA, Q, LDQ, ALPHAR,
$ ALPHAI, BETA, WORK, RESULT( 1 ) )
IF( RESULT( 2 ).GT.THRESH ) THEN
WRITE( NOUNIT, FMT = 9998 )'Left', 'SGGEV1',
$ RESULT( 2 ), N, JTYPE, IOLDSD
END IF
*
* Do the tests (3) and (4)
*
CALL SGET52( .FALSE., N, A, LDA, B, LDA, Z, LDQ, ALPHAR,
$ ALPHAI, BETA, WORK, RESULT( 3 ) )
IF( RESULT( 4 ).GT.THRESH ) THEN
WRITE( NOUNIT, FMT = 9998 )'Right', 'SGGEV1',
$ RESULT( 4 ), N, JTYPE, IOLDSD
END IF
*
* Do the test (5)
*
CALL SLACPY( ' ', N, N, A, LDA, S, LDA )
CALL SLACPY( ' ', N, N, B, LDA, T, LDA )
CALL SGGEV( 'N', 'N', N, S, LDA, T, LDA, ALPHR1, ALPHI1,
$ BETA1, Q, LDQ, Z, LDQ, WORK, LWORK, IERR )
IF( IERR.NE.0 .AND. IERR.NE.N+1 ) THEN
RESULT( 1 ) = ULPINV
WRITE( NOUNIT, FMT = 9999 )'SGGEV2', IERR, N, JTYPE,
$ IOLDSD
INFO = ABS( IERR )
GO TO 190
END IF
*
DO 120 J = 1, N
IF( ALPHAR( J ).NE.ALPHR1( J ) .OR. ALPHAI( J ).NE.
$ ALPHI1( J ) .OR. BETA( J ).NE.BETA1( J ) )
$ RESULT( 5 ) = ULPINV
120 CONTINUE
*
* Do the test (6): Compute eigenvalues and left eigenvectors,
* and test them
*
CALL SLACPY( ' ', N, N, A, LDA, S, LDA )
CALL SLACPY( ' ', N, N, B, LDA, T, LDA )
CALL SGGEV( 'V', 'N', N, S, LDA, T, LDA, ALPHR1, ALPHI1,
$ BETA1, QE, LDQE, Z, LDQ, WORK, LWORK, IERR )
IF( IERR.NE.0 .AND. IERR.NE.N+1 ) THEN
RESULT( 1 ) = ULPINV
WRITE( NOUNIT, FMT = 9999 )'SGGEV3', IERR, N, JTYPE,
$ IOLDSD
INFO = ABS( IERR )
GO TO 190
END IF
*
DO 130 J = 1, N
IF( ALPHAR( J ).NE.ALPHR1( J ) .OR. ALPHAI( J ).NE.
$ ALPHI1( J ) .OR. BETA( J ).NE.BETA1( J ) )
$ RESULT( 6 ) = ULPINV
130 CONTINUE
*
DO 150 J = 1, N
DO 140 JC = 1, N
IF( Q( J, JC ).NE.QE( J, JC ) )
$ RESULT( 6 ) = ULPINV
140 CONTINUE
150 CONTINUE
*
* DO the test (7): Compute eigenvalues and right eigenvectors,
* and test them
*
CALL SLACPY( ' ', N, N, A, LDA, S, LDA )
CALL SLACPY( ' ', N, N, B, LDA, T, LDA )
CALL SGGEV( 'N', 'V', N, S, LDA, T, LDA, ALPHR1, ALPHI1,
$ BETA1, Q, LDQ, QE, LDQE, WORK, LWORK, IERR )
IF( IERR.NE.0 .AND. IERR.NE.N+1 ) THEN
RESULT( 1 ) = ULPINV
WRITE( NOUNIT, FMT = 9999 )'SGGEV4', IERR, N, JTYPE,
$ IOLDSD
INFO = ABS( IERR )
GO TO 190
END IF
*
DO 160 J = 1, N
IF( ALPHAR( J ).NE.ALPHR1( J ) .OR. ALPHAI( J ).NE.
$ ALPHI1( J ) .OR. BETA( J ).NE.BETA1( J ) )
$ RESULT( 7 ) = ULPINV
160 CONTINUE
*
DO 180 J = 1, N
DO 170 JC = 1, N
IF( Z( J, JC ).NE.QE( J, JC ) )
$ RESULT( 7 ) = ULPINV
170 CONTINUE
180 CONTINUE
*
* End of Loop -- Check for RESULT(j) > THRESH
*
190 CONTINUE
*
NTESTT = NTESTT + 7
*
* Print out tests which fail.
*
DO 200 JR = 1, 7
IF( RESULT( JR ).GE.THRESH ) THEN
*
* If this is the first test to fail,
* print a header to the data file.
*
IF( NERRS.EQ.0 ) THEN
WRITE( NOUNIT, FMT = 9997 )'SGV'
*
* Matrix types
*
WRITE( NOUNIT, FMT = 9996 )
WRITE( NOUNIT, FMT = 9995 )
WRITE( NOUNIT, FMT = 9994 )'Orthogonal'
*
* Tests performed
*
WRITE( NOUNIT, FMT = 9993 )
*
END IF
NERRS = NERRS + 1
IF( RESULT( JR ).LT.10000.0 ) THEN
WRITE( NOUNIT, FMT = 9992 )N, JTYPE, IOLDSD, JR,
$ RESULT( JR )
ELSE
WRITE( NOUNIT, FMT = 9991 )N, JTYPE, IOLDSD, JR,
$ RESULT( JR )
END IF
END IF
200 CONTINUE
*
210 CONTINUE
220 CONTINUE
*
* Summary
*
CALL ALASVM( 'SGV', NOUNIT, NERRS, NTESTT, 0 )
*
WORK( 1 ) = MAXWRK
*
RETURN
*
9999 FORMAT( ' SDRGEV: ', A, ' returned INFO=', I6, '.', / 3X, 'N=',
$ I6, ', JTYPE=', I6, ', ISEED=(', 4( I4, ',' ), I5, ')' )
*
9998 FORMAT( ' SDRGEV: ', A, ' Eigenvectors from ', A, ' incorrectly ',
$ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 3X,
$ 'N=', I4, ', JTYPE=', I3, ', ISEED=(', 4( I4, ',' ), I5,
$ ')' )
*
9997 FORMAT( / 1X, A3, ' -- Real Generalized eigenvalue problem driver'
$ )
*
9996 FORMAT( ' Matrix types (see SDRGEV for details): ' )
*
9995 FORMAT( ' Special Matrices:', 23X,
$ '(J''=transposed Jordan block)',
$ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ',
$ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ',
$ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I',
$ ') 11=(large*I, small*D) 13=(large*D, large*I)', /
$ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ',
$ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' )
9994 FORMAT( ' Matrices Rotated by Random ', A, ' Matrices U, V:',
$ / ' 16=Transposed Jordan Blocks 19=geometric ',
$ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ',
$ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ',
$ 'alpha, beta=0,1 21=random alpha, beta=0,1',
$ / ' Large & Small Matrices:', / ' 22=(large, small) ',
$ '23=(small,large) 24=(small,small) 25=(large,large)',
$ / ' 26=random O(1) matrices.' )
*
9993 FORMAT( / ' Tests performed: ',
$ / ' 1 = max | ( b A - a B )''*l | / const.,',
$ / ' 2 = | |VR(i)| - 1 | / ulp,',
$ / ' 3 = max | ( b A - a B )*r | / const.',
$ / ' 4 = | |VL(i)| - 1 | / ulp,',
$ / ' 5 = 0 if W same no matter if r or l computed,',
$ / ' 6 = 0 if l same no matter if l computed,',
$ / ' 7 = 0 if r same no matter if r computed,', / 1X )
9992 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
$ 4( I4, ',' ), ' result ', I2, ' is', 0P, F8.2 )
9991 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
$ 4( I4, ',' ), ' result ', I2, ' is', 1P, E10.3 )
*
* End of SDRGEV
*
END
SUBROUTINE SDRGSX( NSIZE, NCMAX, THRESH, NIN, NOUT, A, LDA, B,
$ AI, BI, Z, Q, ALPHAR, ALPHAI, BETA, C, LDC, S,
$ WORK, LWORK, IWORK, LIWORK, BWORK, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDC, LIWORK, LWORK, NCMAX, NIN,
$ NOUT, NSIZE
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL BWORK( * )
INTEGER IWORK( * )
REAL A( LDA, * ), AI( LDA, * ), ALPHAI( * ),
$ ALPHAR( * ), B( LDA, * ), BETA( * ),
$ BI( LDA, * ), C( LDC, * ), Q( LDA, * ), S( * ),
$ WORK( * ), Z( LDA, * )
* ..
*
* Purpose
* =======
*
* SDRGSX checks the nonsymmetric generalized eigenvalue (Schur form)
* problem expert driver SGGESX.
*
* SGGESX factors A and B as Q S Z' and Q T Z', where ' means
* transpose, T is upper triangular, S is in generalized Schur form
* (block upper triangular, with 1x1 and 2x2 blocks on the diagonal,
* the 2x2 blocks corresponding to complex conjugate pairs of
* generalized eigenvalues), and Q and Z are orthogonal. It also
* computes the generalized eigenvalues (alpha(1),beta(1)), ...,
* (alpha(n),beta(n)). Thus, w(j) = alpha(j)/beta(j) is a root of the
* characteristic equation
*
* det( A - w(j) B ) = 0
*
* Optionally it also reorders the eigenvalues so that a selected
* cluster of eigenvalues appears in the leading diagonal block of the
* Schur forms; computes a reciprocal condition number for the average
* of the selected eigenvalues; and computes a reciprocal condition
* number for the right and left deflating subspaces corresponding to
* the selected eigenvalues.
*
* When SDRGSX is called with NSIZE > 0, five (5) types of built-in
* matrix pairs are used to test the routine SGGESX.
*
* When SDRGSX is called with NSIZE = 0, it reads in test matrix data
* to test SGGESX.
*
* For each matrix pair, the following tests will be performed and
* compared with the threshhold THRESH except for the tests (7) and (9):
*
* (1) | A - Q S Z' | / ( |A| n ulp )
*
* (2) | B - Q T Z' | / ( |B| n ulp )
*
* (3) | I - QQ' | / ( n ulp )
*
* (4) | I - ZZ' | / ( n ulp )
*
* (5) if A is in Schur form (i.e. quasi-triangular form)
*
* (6) maximum over j of D(j) where:
*
* if alpha(j) is real:
* |alpha(j) - S(j,j)| |beta(j) - T(j,j)|
* D(j) = ------------------------ + -----------------------
* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|)
*
* if alpha(j) is complex:
* | det( s S - w T ) |
* D(j) = ---------------------------------------------------
* ulp max( s norm(S), |w| norm(T) )*norm( s S - w T )
*
* and S and T are here the 2 x 2 diagonal blocks of S and T
* corresponding to the j-th and j+1-th eigenvalues.
*
* (7) if sorting worked and SDIM is the number of eigenvalues
* which were selected.
*
* (8) the estimated value DIF does not differ from the true values of
* Difu and Difl more than a factor 10*THRESH. If the estimate DIF
* equals zero the corresponding true values of Difu and Difl
* should be less than EPS*norm(A, B). If the true value of Difu
* and Difl equal zero, the estimate DIF should be less than
* EPS*norm(A, B).
*
* (9) If INFO = N+3 is returned by SGGESX, the reordering "failed"
* and we check that DIF = PL = PR = 0 and that the true value of
* Difu and Difl is < EPS*norm(A, B). We count the events when
* INFO=N+3.
*
* For read-in test matrices, the above tests are run except that the
* exact value for DIF (and PL) is input data. Additionally, there is
* one more test run for read-in test matrices:
*
* (10) the estimated value PL does not differ from the true value of
* PLTRU more than a factor THRESH. If the estimate PL equals
* zero the corresponding true value of PLTRU should be less than
* EPS*norm(A, B). If the true value of PLTRU equal zero, the
* estimate PL should be less than EPS*norm(A, B).
*
* Note that for the built-in tests, a total of 10*NSIZE*(NSIZE-1)
* matrix pairs are generated and tested. NSIZE should be kept small.
*
* SVD (routine SGESVD) is used for computing the true value of DIF_u
* and DIF_l when testing the built-in test problems.
*
* Built-in Test Matrices
* ======================
*
* All built-in test matrices are the 2 by 2 block of triangular
* matrices
*
* A = [ A11 A12 ] and B = [ B11 B12 ]
* [ A22 ] [ B22 ]
*
* where for different type of A11 and A22 are given as the following.
* A12 and B12 are chosen so that the generalized Sylvester equation
*
* A11*R - L*A22 = -A12
* B11*R - L*B22 = -B12
*
* have prescribed solution R and L.
*
* Type 1: A11 = J_m(1,-1) and A_22 = J_k(1-a,1).
* B11 = I_m, B22 = I_k
* where J_k(a,b) is the k-by-k Jordan block with ``a'' on
* diagonal and ``b'' on superdiagonal.
*
* Type 2: A11 = (a_ij) = ( 2(.5-sin(i)) ) and
* B11 = (b_ij) = ( 2(.5-sin(ij)) ) for i=1,...,m, j=i,...,m
* A22 = (a_ij) = ( 2(.5-sin(i+j)) ) and
* B22 = (b_ij) = ( 2(.5-sin(ij)) ) for i=m+1,...,k, j=i,...,k
*
* Type 3: A11, A22 and B11, B22 are chosen as for Type 2, but each
* second diagonal block in A_11 and each third diagonal block
* in A_22 are made as 2 by 2 blocks.
*
* Type 4: A11 = ( 20(.5 - sin(ij)) ) and B22 = ( 2(.5 - sin(i+j)) )
* for i=1,...,m, j=1,...,m and
* A22 = ( 20(.5 - sin(i+j)) ) and B22 = ( 2(.5 - sin(ij)) )
* for i=m+1,...,k, j=m+1,...,k
*
* Type 5: (A,B) and have potentially close or common eigenvalues and
* very large departure from block diagonality A_11 is chosen
* as the m x m leading submatrix of A_1:
* | 1 b |
* | -b 1 |
* | 1+d b |
* | -b 1+d |
* A_1 = | d 1 |
* | -1 d |
* | -d 1 |
* | -1 -d |
* | 1 |
* and A_22 is chosen as the k x k leading submatrix of A_2:
* | -1 b |
* | -b -1 |
* | 1-d b |
* | -b 1-d |
* A_2 = | d 1+b |
* | -1-b d |
* | -d 1+b |
* | -1+b -d |
* | 1-d |
* and matrix B are chosen as identity matrices (see SLATM5).
*
*
* Arguments
* =========
*
* NSIZE (input) INTEGER
* The maximum size of the matrices to use. NSIZE >= 0.
* If NSIZE = 0, no built-in tests matrices are used, but
* read-in test matrices are used to test SGGESX.
*
* NCMAX (input) INTEGER
* Maximum allowable NMAX for generating Kroneker matrix
* in call to SLAKF2
*
* THRESH (input) REAL
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error
* is scaled to be O(1), so THRESH should be a reasonably
* small multiple of 1, e.g., 10 or 100. In particular,
* it should not depend on the precision (single vs. double)
* or the size of the matrix. THRESH >= 0.
*
* NIN (input) INTEGER
* The FORTRAN unit number for reading in the data file of
* problems to solve.
*
* NOUT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns IINFO not equal to 0.)
*
* A (workspace) REAL array, dimension (LDA, NSIZE)
* Used to store the matrix whose eigenvalues are to be
* computed. On exit, A contains the last matrix actually used.
*
* LDA (input) INTEGER
* The leading dimension of A, B, AI, BI, Z and Q,
* LDA >= max( 1, NSIZE ). For the read-in test,
* LDA >= max( 1, N ), N is the size of the test matrices.
*
* B (workspace) REAL array, dimension (LDA, NSIZE)
* Used to store the matrix whose eigenvalues are to be
* computed. On exit, B contains the last matrix actually used.
*
* AI (workspace) REAL array, dimension (LDA, NSIZE)
* Copy of A, modified by SGGESX.
*
* BI (workspace) REAL array, dimension (LDA, NSIZE)
* Copy of B, modified by SGGESX.
*
* Z (workspace) REAL array, dimension (LDA, NSIZE)
* Z holds the left Schur vectors computed by SGGESX.
*
* Q (workspace) REAL array, dimension (LDA, NSIZE)
* Q holds the right Schur vectors computed by SGGESX.
*
* ALPHAR (workspace) REAL array, dimension (NSIZE)
* ALPHAI (workspace) REAL array, dimension (NSIZE)
* BETA (workspace) REAL array, dimension (NSIZE)
* On exit, (ALPHAR + ALPHAI*i)/BETA are the eigenvalues.
*
* C (workspace) REAL array, dimension (LDC, LDC)
* Store the matrix generated by subroutine SLAKF2, this is the
* matrix formed by Kronecker products used for estimating
* DIF.
*
* LDC (input) INTEGER
* The leading dimension of C. LDC >= max(1, LDA*LDA/2 ).
*
* S (workspace) REAL array, dimension (LDC)
* Singular values of C
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* LWORK >= MAX( 5*NSIZE*NSIZE/2 - 2, 10*(NSIZE+1) )
*
* IWORK (workspace) INTEGER array, dimension (LIWORK)
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK. LIWORK >= NSIZE + 6.
*
* BWORK (workspace) LOGICAL array, dimension (LDA)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: A routine returned an error code.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TEN
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TEN = 1.0E+1 )
* ..
* .. Local Scalars ..
LOGICAL ILABAD
CHARACTER SENSE
INTEGER BDSPAC, I, I1, IFUNC, IINFO, J, LINFO, MAXWRK,
$ MINWRK, MM, MN2, NERRS, NPTKNT, NTEST, NTESTT,
$ PRTYPE, QBA, QBB
REAL ABNRM, BIGNUM, DIFTRU, PLTRU, SMLNUM, TEMP1,
$ TEMP2, THRSH2, ULP, ULPINV, WEIGHT
* ..
* .. Local Arrays ..
REAL DIFEST( 2 ), PL( 2 ), RESULT( 10 )
* ..
* .. External Functions ..
LOGICAL SLCTSX
INTEGER ILAENV
REAL SLAMCH, SLANGE
EXTERNAL SLCTSX, ILAENV, SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL ALASVM, SGESVD, SGET51, SGET53, SGGESX, SLABAD,
$ SLACPY, SLAKF2, SLASET, SLATM5, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Scalars in Common ..
LOGICAL FS
INTEGER K, M, MPLUSN, N
* ..
* .. Common blocks ..
COMMON / MN / M, N, MPLUSN, K, FS
* ..
* .. Executable Statements ..
*
* Check for errors
*
IF( NSIZE.LT.0 ) THEN
INFO = -1
ELSE IF( THRESH.LT.ZERO ) THEN
INFO = -2
ELSE IF( NIN.LE.0 ) THEN
INFO = -3
ELSE IF( NOUT.LE.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.1 .OR. LDA.LT.NSIZE ) THEN
INFO = -6
ELSE IF( LDC.LT.1 .OR. LDC.LT.NSIZE*NSIZE / 2 ) THEN
INFO = -17
ELSE IF( LIWORK.LT.NSIZE+6 ) THEN
INFO = -21
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.)
*
MINWRK = 1
IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN
c MINWRK = MAX( 10*( NSIZE+1 ), 5*NSIZE*NSIZE / 2-2 )
MINWRK = MAX( 10*( NSIZE+1 ), 5*NSIZE*NSIZE / 2 )
*
* workspace for sggesx
*
MAXWRK = 9*( NSIZE+1 ) + NSIZE*
$ ILAENV( 1, 'SGEQRF', ' ', NSIZE, 1, NSIZE, 0 )
MAXWRK = MAX( MAXWRK, 9*( NSIZE+1 )+NSIZE*
$ ILAENV( 1, 'SORGQR', ' ', NSIZE, 1, NSIZE, -1 ) )
*
* workspace for sgesvd
*
BDSPAC = 5*NSIZE*NSIZE / 2
MAXWRK = MAX( MAXWRK, 3*NSIZE*NSIZE / 2+NSIZE*NSIZE*
$ ILAENV( 1, 'SGEBRD', ' ', NSIZE*NSIZE / 2,
$ NSIZE*NSIZE / 2, -1, -1 ) )
MAXWRK = MAX( MAXWRK, BDSPAC )
*
MAXWRK = MAX( MAXWRK, MINWRK )
*
WORK( 1 ) = MAXWRK
END IF
*
IF( LWORK.LT.MINWRK )
$ INFO = -19
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SDRGSX', -INFO )
RETURN
END IF
*
* Important constants
*
ULP = SLAMCH( 'P' )
ULPINV = ONE / ULP
SMLNUM = SLAMCH( 'S' ) / ULP
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
THRSH2 = TEN*THRESH
NTESTT = 0
NERRS = 0
*
* Go to the tests for read-in matrix pairs
*
IFUNC = 0
IF( NSIZE.EQ.0 )
$ GO TO 70
*
* Test the built-in matrix pairs.
* Loop over different functions (IFUNC) of SGGESX, types (PRTYPE)
* of test matrices, different size (M+N)
*
PRTYPE = 0
QBA = 3
QBB = 4
WEIGHT = SQRT( ULP )
*
DO 60 IFUNC = 0, 3
DO 50 PRTYPE = 1, 5
DO 40 M = 1, NSIZE - 1
DO 30 N = 1, NSIZE - M
*
WEIGHT = ONE / WEIGHT
MPLUSN = M + N
*
* Generate test matrices
*
FS = .TRUE.
K = 0
*
CALL SLASET( 'Full', MPLUSN, MPLUSN, ZERO, ZERO, AI,
$ LDA )
CALL SLASET( 'Full', MPLUSN, MPLUSN, ZERO, ZERO, BI,
$ LDA )
*
CALL SLATM5( PRTYPE, M, N, AI, LDA, AI( M+1, M+1 ),
$ LDA, AI( 1, M+1 ), LDA, BI, LDA,
$ BI( M+1, M+1 ), LDA, BI( 1, M+1 ), LDA,
$ Q, LDA, Z, LDA, WEIGHT, QBA, QBB )
*
* Compute the Schur factorization and swapping the
* m-by-m (1,1)-blocks with n-by-n (2,2)-blocks.
* Swapping is accomplished via the function SLCTSX
* which is supplied below.
*
IF( IFUNC.EQ.0 ) THEN
SENSE = 'N'
ELSE IF( IFUNC.EQ.1 ) THEN
SENSE = 'E'
ELSE IF( IFUNC.EQ.2 ) THEN
SENSE = 'V'
ELSE IF( IFUNC.EQ.3 ) THEN
SENSE = 'B'
END IF
*
CALL SLACPY( 'Full', MPLUSN, MPLUSN, AI, LDA, A, LDA )
CALL SLACPY( 'Full', MPLUSN, MPLUSN, BI, LDA, B, LDA )
*
CALL SGGESX( 'V', 'V', 'S', SLCTSX, SENSE, MPLUSN, AI,
$ LDA, BI, LDA, MM, ALPHAR, ALPHAI, BETA,
$ Q, LDA, Z, LDA, PL, DIFEST, WORK, LWORK,
$ IWORK, LIWORK, BWORK, LINFO )
*
IF( LINFO.NE.0 .AND. LINFO.NE.MPLUSN+2 ) THEN
RESULT( 1 ) = ULPINV
WRITE( NOUT, FMT = 9999 )'SGGESX', LINFO, MPLUSN,
$ PRTYPE
INFO = LINFO
GO TO 30
END IF
*
* Compute the norm(A, B)
*
CALL SLACPY( 'Full', MPLUSN, MPLUSN, AI, LDA, WORK,
$ MPLUSN )
CALL SLACPY( 'Full', MPLUSN, MPLUSN, BI, LDA,
$ WORK( MPLUSN*MPLUSN+1 ), MPLUSN )
ABNRM = SLANGE( 'Fro', MPLUSN, 2*MPLUSN, WORK, MPLUSN,
$ WORK )
*
* Do tests (1) to (4)
*
CALL SGET51( 1, MPLUSN, A, LDA, AI, LDA, Q, LDA, Z,
$ LDA, WORK, RESULT( 1 ) )
CALL SGET51( 1, MPLUSN, B, LDA, BI, LDA, Q, LDA, Z,
$ LDA, WORK, RESULT( 2 ) )
CALL SGET51( 3, MPLUSN, B, LDA, BI, LDA, Q, LDA, Q,
$ LDA, WORK, RESULT( 3 ) )
CALL SGET51( 3, MPLUSN, B, LDA, BI, LDA, Z, LDA, Z,
$ LDA, WORK, RESULT( 4 ) )
NTEST = 4
*
* Do tests (5) and (6): check Schur form of A and
* compare eigenvalues with diagonals.
*
TEMP1 = ZERO
RESULT( 5 ) = ZERO
RESULT( 6 ) = ZERO
*
DO 10 J = 1, MPLUSN
ILABAD = .FALSE.
IF( ALPHAI( J ).EQ.ZERO ) THEN
TEMP2 = ( ABS( ALPHAR( J )-AI( J, J ) ) /
$ MAX( SMLNUM, ABS( ALPHAR( J ) ),
$ ABS( AI( J, J ) ) )+
$ ABS( BETA( J )-BI( J, J ) ) /
$ MAX( SMLNUM, ABS( BETA( J ) ),
$ ABS( BI( J, J ) ) ) ) / ULP
IF( J.LT.MPLUSN ) THEN
IF( AI( J+1, J ).NE.ZERO ) THEN
ILABAD = .TRUE.
RESULT( 5 ) = ULPINV
END IF
END IF
IF( J.GT.1 ) THEN
IF( AI( J, J-1 ).NE.ZERO ) THEN
ILABAD = .TRUE.
RESULT( 5 ) = ULPINV
END IF
END IF
ELSE
IF( ALPHAI( J ).GT.ZERO ) THEN
I1 = J
ELSE
I1 = J - 1
END IF
IF( I1.LE.0 .OR. I1.GE.MPLUSN ) THEN
ILABAD = .TRUE.
ELSE IF( I1.LT.MPLUSN-1 ) THEN
IF( AI( I1+2, I1+1 ).NE.ZERO ) THEN
ILABAD = .TRUE.
RESULT( 5 ) = ULPINV
END IF
ELSE IF( I1.GT.1 ) THEN
IF( AI( I1, I1-1 ).NE.ZERO ) THEN
ILABAD = .TRUE.
RESULT( 5 ) = ULPINV
END IF
END IF
IF( .NOT.ILABAD ) THEN
CALL SGET53( AI( I1, I1 ), LDA, BI( I1, I1 ),
$ LDA, BETA( J ), ALPHAR( J ),
$ ALPHAI( J ), TEMP2, IINFO )
IF( IINFO.GE.3 ) THEN
WRITE( NOUT, FMT = 9997 )IINFO, J,
$ MPLUSN, PRTYPE
INFO = ABS( IINFO )
END IF
ELSE
TEMP2 = ULPINV
END IF
END IF
TEMP1 = MAX( TEMP1, TEMP2 )
IF( ILABAD ) THEN
WRITE( NOUT, FMT = 9996 )J, MPLUSN, PRTYPE
END IF
10 CONTINUE
RESULT( 6 ) = TEMP1
NTEST = NTEST + 2
*
* Test (7) (if sorting worked)
*
RESULT( 7 ) = ZERO
IF( LINFO.EQ.MPLUSN+3 ) THEN
RESULT( 7 ) = ULPINV
ELSE IF( MM.NE.N ) THEN
RESULT( 7 ) = ULPINV
END IF
NTEST = NTEST + 1
*
* Test (8): compare the estimated value DIF and its
* value. first, compute the exact DIF.
*
RESULT( 8 ) = ZERO
MN2 = MM*( MPLUSN-MM )*2
IF( IFUNC.GE.2 .AND. MN2.LE.NCMAX*NCMAX ) THEN
*
* Note: for either following two causes, there are
* almost same number of test cases fail the test.
*
CALL SLAKF2( MM, MPLUSN-MM, AI, LDA,
$ AI( MM+1, MM+1 ), BI,
$ BI( MM+1, MM+1 ), C, LDC )
*
CALL SGESVD( 'N', 'N', MN2, MN2, C, LDC, S, WORK,
$ 1, WORK( 2 ), 1, WORK( 3 ), LWORK-2,
$ INFO )
DIFTRU = S( MN2 )
*
IF( DIFEST( 2 ).EQ.ZERO ) THEN
IF( DIFTRU.GT.ABNRM*ULP )
$ RESULT( 8 ) = ULPINV
ELSE IF( DIFTRU.EQ.ZERO ) THEN
IF( DIFEST( 2 ).GT.ABNRM*ULP )
$ RESULT( 8 ) = ULPINV
ELSE IF( ( DIFTRU.GT.THRSH2*DIFEST( 2 ) ) .OR.
$ ( DIFTRU*THRSH2.LT.DIFEST( 2 ) ) ) THEN
RESULT( 8 ) = MAX( DIFTRU / DIFEST( 2 ),
$ DIFEST( 2 ) / DIFTRU )
END IF
NTEST = NTEST + 1
END IF
*
* Test (9)
*
RESULT( 9 ) = ZERO
IF( LINFO.EQ.( MPLUSN+2 ) ) THEN
IF( DIFTRU.GT.ABNRM*ULP )
$ RESULT( 9 ) = ULPINV
IF( ( IFUNC.GT.1 ) .AND. ( DIFEST( 2 ).NE.ZERO ) )
$ RESULT( 9 ) = ULPINV
IF( ( IFUNC.EQ.1 ) .AND. ( PL( 1 ).NE.ZERO ) )
$ RESULT( 9 ) = ULPINV
NTEST = NTEST + 1
END IF
*
NTESTT = NTESTT + NTEST
*
* Print out tests which fail.
*
DO 20 J = 1, 9
IF( RESULT( J ).GE.THRESH ) THEN
*
* If this is the first test to fail,
* print a header to the data file.
*
IF( NERRS.EQ.0 ) THEN
WRITE( NOUT, FMT = 9995 )'SGX'
*
* Matrix types
*
WRITE( NOUT, FMT = 9993 )
*
* Tests performed
*
WRITE( NOUT, FMT = 9992 )'orthogonal', '''',
$ 'transpose', ( '''', I = 1, 4 )
*
END IF
NERRS = NERRS + 1
IF( RESULT( J ).LT.10000.0 ) THEN
WRITE( NOUT, FMT = 9991 )MPLUSN, PRTYPE,
$ WEIGHT, M, J, RESULT( J )
ELSE
WRITE( NOUT, FMT = 9990 )MPLUSN, PRTYPE,
$ WEIGHT, M, J, RESULT( J )
END IF
END IF
20 CONTINUE
*
30 CONTINUE
40 CONTINUE
50 CONTINUE
60 CONTINUE
*
GO TO 150
*
70 CONTINUE
*
* Read in data from file to check accuracy of condition estimation
* Read input data until N=0
*
NPTKNT = 0
*
80 CONTINUE
READ( NIN, FMT = *, END = 140 )MPLUSN
IF( MPLUSN.EQ.0 )
$ GO TO 140
READ( NIN, FMT = *, END = 140 )N
DO 90 I = 1, MPLUSN
READ( NIN, FMT = * )( AI( I, J ), J = 1, MPLUSN )
90 CONTINUE
DO 100 I = 1, MPLUSN
READ( NIN, FMT = * )( BI( I, J ), J = 1, MPLUSN )
100 CONTINUE
READ( NIN, FMT = * )PLTRU, DIFTRU
*
NPTKNT = NPTKNT + 1
FS = .TRUE.
K = 0
M = MPLUSN - N
*
CALL SLACPY( 'Full', MPLUSN, MPLUSN, AI, LDA, A, LDA )
CALL SLACPY( 'Full', MPLUSN, MPLUSN, BI, LDA, B, LDA )
*
* Compute the Schur factorization while swaping the
* m-by-m (1,1)-blocks with n-by-n (2,2)-blocks.
*
CALL SGGESX( 'V', 'V', 'S', SLCTSX, 'B', MPLUSN, AI, LDA, BI, LDA,
$ MM, ALPHAR, ALPHAI, BETA, Q, LDA, Z, LDA, PL, DIFEST,
$ WORK, LWORK, IWORK, LIWORK, BWORK, LINFO )
*
IF( LINFO.NE.0 .AND. LINFO.NE.MPLUSN+2 ) THEN
RESULT( 1 ) = ULPINV
WRITE( NOUT, FMT = 9998 )'SGGESX', LINFO, MPLUSN, NPTKNT
GO TO 130
END IF
*
* Compute the norm(A, B)
* (should this be norm of (A,B) or (AI,BI)?)
*
CALL SLACPY( 'Full', MPLUSN, MPLUSN, AI, LDA, WORK, MPLUSN )
CALL SLACPY( 'Full', MPLUSN, MPLUSN, BI, LDA,
$ WORK( MPLUSN*MPLUSN+1 ), MPLUSN )
ABNRM = SLANGE( 'Fro', MPLUSN, 2*MPLUSN, WORK, MPLUSN, WORK )
*
* Do tests (1) to (4)
*
CALL SGET51( 1, MPLUSN, A, LDA, AI, LDA, Q, LDA, Z, LDA, WORK,
$ RESULT( 1 ) )
CALL SGET51( 1, MPLUSN, B, LDA, BI, LDA, Q, LDA, Z, LDA, WORK,
$ RESULT( 2 ) )
CALL SGET51( 3, MPLUSN, B, LDA, BI, LDA, Q, LDA, Q, LDA, WORK,
$ RESULT( 3 ) )
CALL SGET51( 3, MPLUSN, B, LDA, BI, LDA, Z, LDA, Z, LDA, WORK,
$ RESULT( 4 ) )
*
* Do tests (5) and (6): check Schur form of A and compare
* eigenvalues with diagonals.
*
NTEST = 6
TEMP1 = ZERO
RESULT( 5 ) = ZERO
RESULT( 6 ) = ZERO
*
DO 110 J = 1, MPLUSN
ILABAD = .FALSE.
IF( ALPHAI( J ).EQ.ZERO ) THEN
TEMP2 = ( ABS( ALPHAR( J )-AI( J, J ) ) /
$ MAX( SMLNUM, ABS( ALPHAR( J ) ), ABS( AI( J,
$ J ) ) )+ABS( BETA( J )-BI( J, J ) ) /
$ MAX( SMLNUM, ABS( BETA( J ) ), ABS( BI( J, J ) ) ) )
$ / ULP
IF( J.LT.MPLUSN ) THEN
IF( AI( J+1, J ).NE.ZERO ) THEN
ILABAD = .TRUE.
RESULT( 5 ) = ULPINV
END IF
END IF
IF( J.GT.1 ) THEN
IF( AI( J, J-1 ).NE.ZERO ) THEN
ILABAD = .TRUE.
RESULT( 5 ) = ULPINV
END IF
END IF
ELSE
IF( ALPHAI( J ).GT.ZERO ) THEN
I1 = J
ELSE
I1 = J - 1
END IF
IF( I1.LE.0 .OR. I1.GE.MPLUSN ) THEN
ILABAD = .TRUE.
ELSE IF( I1.LT.MPLUSN-1 ) THEN
IF( AI( I1+2, I1+1 ).NE.ZERO ) THEN
ILABAD = .TRUE.
RESULT( 5 ) = ULPINV
END IF
ELSE IF( I1.GT.1 ) THEN
IF( AI( I1, I1-1 ).NE.ZERO ) THEN
ILABAD = .TRUE.
RESULT( 5 ) = ULPINV
END IF
END IF
IF( .NOT.ILABAD ) THEN
CALL SGET53( AI( I1, I1 ), LDA, BI( I1, I1 ), LDA,
$ BETA( J ), ALPHAR( J ), ALPHAI( J ), TEMP2,
$ IINFO )
IF( IINFO.GE.3 ) THEN
WRITE( NOUT, FMT = 9997 )IINFO, J, MPLUSN, NPTKNT
INFO = ABS( IINFO )
END IF
ELSE
TEMP2 = ULPINV
END IF
END IF
TEMP1 = MAX( TEMP1, TEMP2 )
IF( ILABAD ) THEN
WRITE( NOUT, FMT = 9996 )J, MPLUSN, NPTKNT
END IF
110 CONTINUE
RESULT( 6 ) = TEMP1
*
* Test (7) (if sorting worked) <--------- need to be checked.
*
NTEST = 7
RESULT( 7 ) = ZERO
IF( LINFO.EQ.MPLUSN+3 )
$ RESULT( 7 ) = ULPINV
*
* Test (8): compare the estimated value of DIF and its true value.
*
NTEST = 8
RESULT( 8 ) = ZERO
IF( DIFEST( 2 ).EQ.ZERO ) THEN
IF( DIFTRU.GT.ABNRM*ULP )
$ RESULT( 8 ) = ULPINV
ELSE IF( DIFTRU.EQ.ZERO ) THEN
IF( DIFEST( 2 ).GT.ABNRM*ULP )
$ RESULT( 8 ) = ULPINV
ELSE IF( ( DIFTRU.GT.THRSH2*DIFEST( 2 ) ) .OR.
$ ( DIFTRU*THRSH2.LT.DIFEST( 2 ) ) ) THEN
RESULT( 8 ) = MAX( DIFTRU / DIFEST( 2 ), DIFEST( 2 ) / DIFTRU )
END IF
*
* Test (9)
*
NTEST = 9
RESULT( 9 ) = ZERO
IF( LINFO.EQ.( MPLUSN+2 ) ) THEN
IF( DIFTRU.GT.ABNRM*ULP )
$ RESULT( 9 ) = ULPINV
IF( ( IFUNC.GT.1 ) .AND. ( DIFEST( 2 ).NE.ZERO ) )
$ RESULT( 9 ) = ULPINV
IF( ( IFUNC.EQ.1 ) .AND. ( PL( 1 ).NE.ZERO ) )
$ RESULT( 9 ) = ULPINV
END IF
*
* Test (10): compare the estimated value of PL and it true value.
*
NTEST = 10
RESULT( 10 ) = ZERO
IF( PL( 1 ).EQ.ZERO ) THEN
IF( PLTRU.GT.ABNRM*ULP )
$ RESULT( 10 ) = ULPINV
ELSE IF( PLTRU.EQ.ZERO ) THEN
IF( PL( 1 ).GT.ABNRM*ULP )
$ RESULT( 10 ) = ULPINV
ELSE IF( ( PLTRU.GT.THRESH*PL( 1 ) ) .OR.
$ ( PLTRU*THRESH.LT.PL( 1 ) ) ) THEN
RESULT( 10 ) = ULPINV
END IF
*
NTESTT = NTESTT + NTEST
*
* Print out tests which fail.
*
DO 120 J = 1, NTEST
IF( RESULT( J ).GE.THRESH ) THEN
*
* If this is the first test to fail,
* print a header to the data file.
*
IF( NERRS.EQ.0 ) THEN
WRITE( NOUT, FMT = 9995 )'SGX'
*
* Matrix types
*
WRITE( NOUT, FMT = 9994 )
*
* Tests performed
*
WRITE( NOUT, FMT = 9992 )'orthogonal', '''',
$ 'transpose', ( '''', I = 1, 4 )
*
END IF
NERRS = NERRS + 1
IF( RESULT( J ).LT.10000.0 ) THEN
WRITE( NOUT, FMT = 9989 )NPTKNT, MPLUSN, J, RESULT( J )
ELSE
WRITE( NOUT, FMT = 9988 )NPTKNT, MPLUSN, J, RESULT( J )
END IF
END IF
*
120 CONTINUE
*
130 CONTINUE
GO TO 80
140 CONTINUE
*
150 CONTINUE
*
* Summary
*
CALL ALASVM( 'SGX', NOUT, NERRS, NTESTT, 0 )
*
WORK( 1 ) = MAXWRK
*
RETURN
*
9999 FORMAT( ' SDRGSX: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ')' )
*
9998 FORMAT( ' SDRGSX: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', Input Example #', I2, ')' )
*
9997 FORMAT( ' SDRGSX: SGET53 returned INFO=', I1, ' for eigenvalue ',
$ I6, '.', / 9X, 'N=', I6, ', JTYPE=', I6, ')' )
*
9996 FORMAT( ' SDRGSX: S not in Schur form at eigenvalue ', I6, '.',
$ / 9X, 'N=', I6, ', JTYPE=', I6, ')' )
*
9995 FORMAT( / 1X, A3, ' -- Real Expert Generalized Schur form',
$ ' problem driver' )
*
9994 FORMAT( 'Input Example' )
*
9993 FORMAT( ' Matrix types: ', /
$ ' 1: A is a block diagonal matrix of Jordan blocks ',
$ 'and B is the identity ', / ' matrix, ',
$ / ' 2: A and B are upper triangular matrices, ',
$ / ' 3: A and B are as type 2, but each second diagonal ',
$ 'block in A_11 and ', /
$ ' each third diaongal block in A_22 are 2x2 blocks,',
$ / ' 4: A and B are block diagonal matrices, ',
$ / ' 5: (A,B) has potentially close or common ',
$ 'eigenvalues.', / )
*
9992 FORMAT( / ' Tests performed: (S is Schur, T is triangular, ',
$ 'Q and Z are ', A, ',', / 19X,
$ ' a is alpha, b is beta, and ', A, ' means ', A, '.)',
$ / ' 1 = | A - Q S Z', A,
$ ' | / ( |A| n ulp ) 2 = | B - Q T Z', A,
$ ' | / ( |B| n ulp )', / ' 3 = | I - QQ', A,
$ ' | / ( n ulp ) 4 = | I - ZZ', A,
$ ' | / ( n ulp )', / ' 5 = 1/ULP if A is not in ',
$ 'Schur form S', / ' 6 = difference between (alpha,beta)',
$ ' and diagonals of (S,T)', /
$ ' 7 = 1/ULP if SDIM is not the correct number of ',
$ 'selected eigenvalues', /
$ ' 8 = 1/ULP if DIFEST/DIFTRU > 10*THRESH or ',
$ 'DIFTRU/DIFEST > 10*THRESH',
$ / ' 9 = 1/ULP if DIFEST <> 0 or DIFTRU > ULP*norm(A,B) ',
$ 'when reordering fails', /
$ ' 10 = 1/ULP if PLEST/PLTRU > THRESH or ',
$ 'PLTRU/PLEST > THRESH', /
$ ' ( Test 10 is only for input examples )', / )
9991 FORMAT( ' Matrix order=', I2, ', type=', I2, ', a=', E10.4,
$ ', order(A_11)=', I2, ', result ', I2, ' is ', 0P, F8.2 )
9990 FORMAT( ' Matrix order=', I2, ', type=', I2, ', a=', E10.4,
$ ', order(A_11)=', I2, ', result ', I2, ' is ', 0P, E10.4 )
9989 FORMAT( ' Input example #', I2, ', matrix order=', I4, ',',
$ ' result ', I2, ' is', 0P, F8.2 )
9988 FORMAT( ' Input example #', I2, ', matrix order=', I4, ',',
$ ' result ', I2, ' is', 1P, E10.3 )
*
* End of SDRGSX
*
END
SUBROUTINE SDRGVX( NSIZE, THRESH, NIN, NOUT, A, LDA, B, AI, BI,
$ ALPHAR, ALPHAI, BETA, VL, VR, ILO, IHI, LSCALE,
$ RSCALE, S, STRU, DIF, DIFTRU, WORK, LWORK,
$ IWORK, LIWORK, RESULT, BWORK, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IHI, ILO, INFO, LDA, LIWORK, LWORK, NIN, NOUT,
$ NSIZE
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL BWORK( * )
INTEGER IWORK( * )
REAL A( LDA, * ), AI( LDA, * ), ALPHAI( * ),
$ ALPHAR( * ), B( LDA, * ), BETA( * ),
$ BI( LDA, * ), DIF( * ), DIFTRU( * ),
$ LSCALE( * ), RESULT( 4 ), RSCALE( * ), S( * ),
$ STRU( * ), VL( LDA, * ), VR( LDA, * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* SDRGVX checks the nonsymmetric generalized eigenvalue problem
* expert driver SGGEVX.
*
* SGGEVX computes the generalized eigenvalues, (optionally) the left
* and/or right eigenvectors, (optionally) computes a balancing
* transformation to improve the conditioning, and (optionally)
* reciprocal condition numbers for the eigenvalues and eigenvectors.
*
* When SDRGVX is called with NSIZE > 0, two types of test matrix pairs
* are generated by the subroutine SLATM6 and test the driver SGGEVX.
* The test matrices have the known exact condition numbers for
* eigenvalues. For the condition numbers of the eigenvectors
* corresponding the first and last eigenvalues are also know
* ``exactly'' (see SLATM6).
*
* For each matrix pair, the following tests will be performed and
* compared with the threshhold THRESH.
*
* (1) max over all left eigenvalue/-vector pairs (beta/alpha,l) of
*
* | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) )
*
* where l**H is the conjugate tranpose of l.
*
* (2) max over all right eigenvalue/-vector pairs (beta/alpha,r) of
*
* | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) )
*
* (3) The condition number S(i) of eigenvalues computed by SGGEVX
* differs less than a factor THRESH from the exact S(i) (see
* SLATM6).
*
* (4) DIF(i) computed by STGSNA differs less than a factor 10*THRESH
* from the exact value (for the 1st and 5th vectors only).
*
* Test Matrices
* =============
*
* Two kinds of test matrix pairs
*
* (A, B) = inverse(YH) * (Da, Db) * inverse(X)
*
* are used in the tests:
*
* 1: Da = 1+a 0 0 0 0 Db = 1 0 0 0 0
* 0 2+a 0 0 0 0 1 0 0 0
* 0 0 3+a 0 0 0 0 1 0 0
* 0 0 0 4+a 0 0 0 0 1 0
* 0 0 0 0 5+a , 0 0 0 0 1 , and
*
* 2: Da = 1 -1 0 0 0 Db = 1 0 0 0 0
* 1 1 0 0 0 0 1 0 0 0
* 0 0 1 0 0 0 0 1 0 0
* 0 0 0 1+a 1+b 0 0 0 1 0
* 0 0 0 -1-b 1+a , 0 0 0 0 1 .
*
* In both cases the same inverse(YH) and inverse(X) are used to compute
* (A, B), giving the exact eigenvectors to (A,B) as (YH, X):
*
* YH: = 1 0 -y y -y X = 1 0 -x -x x
* 0 1 -y y -y 0 1 x -x -x
* 0 0 1 0 0 0 0 1 0 0
* 0 0 0 1 0 0 0 0 1 0
* 0 0 0 0 1, 0 0 0 0 1 , where
*
* a, b, x and y will have all values independently of each other from
* { sqrt(sqrt(ULP)), 0.1, 1, 10, 1/sqrt(sqrt(ULP)) }.
*
* Arguments
* =========
*
* NSIZE (input) INTEGER
* The number of sizes of matrices to use. NSIZE must be at
* least zero. If it is zero, no randomly generated matrices
* are tested, but any test matrices read from NIN will be
* tested.
*
* THRESH (input) REAL
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error
* is scaled to be O(1), so THRESH should be a reasonably
* small multiple of 1, e.g., 10 or 100. In particular,
* it should not depend on the precision (single vs. double)
* or the size of the matrix. It must be at least zero.
*
* NIN (input) INTEGER
* The FORTRAN unit number for reading in the data file of
* problems to solve.
*
* NOUT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns IINFO not equal to 0.)
*
* A (workspace) REAL array, dimension (LDA, NSIZE)
* Used to hold the matrix whose eigenvalues are to be
* computed. On exit, A contains the last matrix actually used.
*
* LDA (input) INTEGER
* The leading dimension of A, B, AI, BI, Ao, and Bo.
* It must be at least 1 and at least NSIZE.
*
* B (workspace) REAL array, dimension (LDA, NSIZE)
* Used to hold the matrix whose eigenvalues are to be
* computed. On exit, B contains the last matrix actually used.
*
* AI (workspace) REAL array, dimension (LDA, NSIZE)
* Copy of A, modified by SGGEVX.
*
* BI (workspace) REAL array, dimension (LDA, NSIZE)
* Copy of B, modified by SGGEVX.
*
* ALPHAR (workspace) REAL array, dimension (NSIZE)
* ALPHAI (workspace) REAL array, dimension (NSIZE)
* BETA (workspace) REAL array, dimension (NSIZE)
* On exit, (ALPHAR + ALPHAI*i)/BETA are the eigenvalues.
*
* VL (workspace) REAL array, dimension (LDA, NSIZE)
* VL holds the left eigenvectors computed by SGGEVX.
*
* VR (workspace) REAL array, dimension (LDA, NSIZE)
* VR holds the right eigenvectors computed by SGGEVX.
*
* ILO (output/workspace) INTEGER
*
* IHI (output/workspace) INTEGER
*
* LSCALE (output/workspace) REAL array, dimension (N)
*
* RSCALE (output/workspace) REAL array, dimension (N)
*
* S (output/workspace) REAL array, dimension (N)
*
* STRU (output/workspace) REAL array, dimension (N)
*
* DIF (output/workspace) REAL array, dimension (N)
*
* DIFTRU (output/workspace) REAL array, dimension (N)
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* Leading dimension of WORK. LWORK >= 2*N*N+12*N+16.
*
* IWORK (workspace) INTEGER array, dimension (LIWORK)
*
* LIWORK (input) INTEGER
* Leading dimension of IWORK. Must be at least N+6.
*
* RESULT (output/workspace) REAL array, dimension (4)
*
* BWORK (workspace) LOGICAL array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: A routine returned an error code.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TEN, TNTH
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TEN = 1.0E+1,
$ TNTH = 1.0E-1 )
* ..
* .. Local Scalars ..
INTEGER I, IPTYPE, IWA, IWB, IWX, IWY, J, LINFO,
$ MAXWRK, MINWRK, N, NERRS, NMAX, NPTKNT, NTESTT
REAL ABNORM, ANORM, BNORM, RATIO1, RATIO2, THRSH2,
$ ULP, ULPINV
* ..
* .. Local Arrays ..
REAL WEIGHT( 5 )
* ..
* .. External Functions ..
INTEGER ILAENV
REAL SLAMCH, SLANGE
EXTERNAL ILAENV, SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL ALASVM, SGET52, SGGEVX, SLACPY, SLATM6, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Check for errors
*
INFO = 0
*
NMAX = 5
*
IF( NSIZE.LT.0 ) THEN
INFO = -1
ELSE IF( THRESH.LT.ZERO ) THEN
INFO = -2
ELSE IF( NIN.LE.0 ) THEN
INFO = -3
ELSE IF( NOUT.LE.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.1 .OR. LDA.LT.NMAX ) THEN
INFO = -6
ELSE IF( LIWORK.LT.NMAX+6 ) THEN
INFO = -26
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.)
*
MINWRK = 1
IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN
MINWRK = 2*NMAX*NMAX + 12*NMAX + 16
MAXWRK = 6*NMAX + NMAX*ILAENV( 1, 'SGEQRF', ' ', NMAX, 1, NMAX,
$ 0 )
MAXWRK = MAX( MAXWRK, 2*NMAX*NMAX+12*NMAX+16 )
WORK( 1 ) = MAXWRK
END IF
*
IF( LWORK.LT.MINWRK )
$ INFO = -24
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SDRGVX', -INFO )
RETURN
END IF
*
N = 5
ULP = SLAMCH( 'P' )
ULPINV = ONE / ULP
THRSH2 = TEN*THRESH
NERRS = 0
NPTKNT = 0
NTESTT = 0
*
IF( NSIZE.EQ.0 )
$ GO TO 90
*
* Parameters used for generating test matrices.
*
WEIGHT( 1 ) = SQRT( SQRT( ULP ) )
WEIGHT( 2 ) = TNTH
WEIGHT( 3 ) = ONE
WEIGHT( 4 ) = ONE / WEIGHT( 2 )
WEIGHT( 5 ) = ONE / WEIGHT( 1 )
*
DO 80 IPTYPE = 1, 2
DO 70 IWA = 1, 5
DO 60 IWB = 1, 5
DO 50 IWX = 1, 5
DO 40 IWY = 1, 5
*
* generated a test matrix pair
*
CALL SLATM6( IPTYPE, 5, A, LDA, B, VR, LDA, VL,
$ LDA, WEIGHT( IWA ), WEIGHT( IWB ),
$ WEIGHT( IWX ), WEIGHT( IWY ), STRU,
$ DIFTRU )
*
* Compute eigenvalues/eigenvectors of (A, B).
* Compute eigenvalue/eigenvector condition numbers
* using computed eigenvectors.
*
CALL SLACPY( 'F', N, N, A, LDA, AI, LDA )
CALL SLACPY( 'F', N, N, B, LDA, BI, LDA )
*
CALL SGGEVX( 'N', 'V', 'V', 'B', N, AI, LDA, BI,
$ LDA, ALPHAR, ALPHAI, BETA, VL, LDA,
$ VR, LDA, ILO, IHI, LSCALE, RSCALE,
$ ANORM, BNORM, S, DIF, WORK, LWORK,
$ IWORK, BWORK, LINFO )
IF( LINFO.NE.0 ) THEN
RESULT( 1 ) = ULPINV
WRITE( NOUT, FMT = 9999 )'SGGEVX', LINFO, N,
$ IPTYPE
GO TO 30
END IF
*
* Compute the norm(A, B)
*
CALL SLACPY( 'Full', N, N, AI, LDA, WORK, N )
CALL SLACPY( 'Full', N, N, BI, LDA, WORK( N*N+1 ),
$ N )
ABNORM = SLANGE( 'Fro', N, 2*N, WORK, N, WORK )
*
* Tests (1) and (2)
*
RESULT( 1 ) = ZERO
CALL SGET52( .TRUE., N, A, LDA, B, LDA, VL, LDA,
$ ALPHAR, ALPHAI, BETA, WORK,
$ RESULT( 1 ) )
IF( RESULT( 2 ).GT.THRESH ) THEN
WRITE( NOUT, FMT = 9998 )'Left', 'SGGEVX',
$ RESULT( 2 ), N, IPTYPE, IWA, IWB, IWX, IWY
END IF
*
RESULT( 2 ) = ZERO
CALL SGET52( .FALSE., N, A, LDA, B, LDA, VR, LDA,
$ ALPHAR, ALPHAI, BETA, WORK,
$ RESULT( 2 ) )
IF( RESULT( 3 ).GT.THRESH ) THEN
WRITE( NOUT, FMT = 9998 )'Right', 'SGGEVX',
$ RESULT( 3 ), N, IPTYPE, IWA, IWB, IWX, IWY
END IF
*
* Test (3)
*
RESULT( 3 ) = ZERO
DO 10 I = 1, N
IF( S( I ).EQ.ZERO ) THEN
IF( STRU( I ).GT.ABNORM*ULP )
$ RESULT( 3 ) = ULPINV
ELSE IF( STRU( I ).EQ.ZERO ) THEN
IF( S( I ).GT.ABNORM*ULP )
$ RESULT( 3 ) = ULPINV
ELSE
WORK( I ) = MAX( ABS( STRU( I ) / S( I ) ),
$ ABS( S( I ) / STRU( I ) ) )
RESULT( 3 ) = MAX( RESULT( 3 ), WORK( I ) )
END IF
10 CONTINUE
*
* Test (4)
*
RESULT( 4 ) = ZERO
IF( DIF( 1 ).EQ.ZERO ) THEN
IF( DIFTRU( 1 ).GT.ABNORM*ULP )
$ RESULT( 4 ) = ULPINV
ELSE IF( DIFTRU( 1 ).EQ.ZERO ) THEN
IF( DIF( 1 ).GT.ABNORM*ULP )
$ RESULT( 4 ) = ULPINV
ELSE IF( DIF( 5 ).EQ.ZERO ) THEN
IF( DIFTRU( 5 ).GT.ABNORM*ULP )
$ RESULT( 4 ) = ULPINV
ELSE IF( DIFTRU( 5 ).EQ.ZERO ) THEN
IF( DIF( 5 ).GT.ABNORM*ULP )
$ RESULT( 4 ) = ULPINV
ELSE
RATIO1 = MAX( ABS( DIFTRU( 1 ) / DIF( 1 ) ),
$ ABS( DIF( 1 ) / DIFTRU( 1 ) ) )
RATIO2 = MAX( ABS( DIFTRU( 5 ) / DIF( 5 ) ),
$ ABS( DIF( 5 ) / DIFTRU( 5 ) ) )
RESULT( 4 ) = MAX( RATIO1, RATIO2 )
END IF
*
NTESTT = NTESTT + 4
*
* Print out tests which fail.
*
DO 20 J = 1, 4
IF( ( RESULT( J ).GE.THRSH2 .AND. J.GE.4 ) .OR.
$ ( RESULT( J ).GE.THRESH .AND. J.LE.3 ) )
$ THEN
*
* If this is the first test to fail,
* print a header to the data file.
*
IF( NERRS.EQ.0 ) THEN
WRITE( NOUT, FMT = 9997 )'SXV'
*
* Print out messages for built-in examples
*
* Matrix types
*
WRITE( NOUT, FMT = 9995 )
WRITE( NOUT, FMT = 9994 )
WRITE( NOUT, FMT = 9993 )
*
* Tests performed
*
WRITE( NOUT, FMT = 9992 )'''',
$ 'transpose', ''''
*
END IF
NERRS = NERRS + 1
IF( RESULT( J ).LT.10000.0 ) THEN
WRITE( NOUT, FMT = 9991 )IPTYPE, IWA,
$ IWB, IWX, IWY, J, RESULT( J )
ELSE
WRITE( NOUT, FMT = 9990 )IPTYPE, IWA,
$ IWB, IWX, IWY, J, RESULT( J )
END IF
END IF
20 CONTINUE
*
30 CONTINUE
*
40 CONTINUE
50 CONTINUE
60 CONTINUE
70 CONTINUE
80 CONTINUE
*
GO TO 150
*
90 CONTINUE
*
* Read in data from file to check accuracy of condition estimation
* Read input data until N=0
*
READ( NIN, FMT = *, END = 150 )N
IF( N.EQ.0 )
$ GO TO 150
DO 100 I = 1, N
READ( NIN, FMT = * )( A( I, J ), J = 1, N )
100 CONTINUE
DO 110 I = 1, N
READ( NIN, FMT = * )( B( I, J ), J = 1, N )
110 CONTINUE
READ( NIN, FMT = * )( STRU( I ), I = 1, N )
READ( NIN, FMT = * )( DIFTRU( I ), I = 1, N )
*
NPTKNT = NPTKNT + 1
*
* Compute eigenvalues/eigenvectors of (A, B).
* Compute eigenvalue/eigenvector condition numbers
* using computed eigenvectors.
*
CALL SLACPY( 'F', N, N, A, LDA, AI, LDA )
CALL SLACPY( 'F', N, N, B, LDA, BI, LDA )
*
CALL SGGEVX( 'N', 'V', 'V', 'B', N, AI, LDA, BI, LDA, ALPHAR,
$ ALPHAI, BETA, VL, LDA, VR, LDA, ILO, IHI, LSCALE,
$ RSCALE, ANORM, BNORM, S, DIF, WORK, LWORK, IWORK,
$ BWORK, LINFO )
*
IF( LINFO.NE.0 ) THEN
RESULT( 1 ) = ULPINV
WRITE( NOUT, FMT = 9987 )'SGGEVX', LINFO, N, NPTKNT
GO TO 140
END IF
*
* Compute the norm(A, B)
*
CALL SLACPY( 'Full', N, N, AI, LDA, WORK, N )
CALL SLACPY( 'Full', N, N, BI, LDA, WORK( N*N+1 ), N )
ABNORM = SLANGE( 'Fro', N, 2*N, WORK, N, WORK )
*
* Tests (1) and (2)
*
RESULT( 1 ) = ZERO
CALL SGET52( .TRUE., N, A, LDA, B, LDA, VL, LDA, ALPHAR, ALPHAI,
$ BETA, WORK, RESULT( 1 ) )
IF( RESULT( 2 ).GT.THRESH ) THEN
WRITE( NOUT, FMT = 9986 )'Left', 'SGGEVX', RESULT( 2 ), N,
$ NPTKNT
END IF
*
RESULT( 2 ) = ZERO
CALL SGET52( .FALSE., N, A, LDA, B, LDA, VR, LDA, ALPHAR, ALPHAI,
$ BETA, WORK, RESULT( 2 ) )
IF( RESULT( 3 ).GT.THRESH ) THEN
WRITE( NOUT, FMT = 9986 )'Right', 'SGGEVX', RESULT( 3 ), N,
$ NPTKNT
END IF
*
* Test (3)
*
RESULT( 3 ) = ZERO
DO 120 I = 1, N
IF( S( I ).EQ.ZERO ) THEN
IF( STRU( I ).GT.ABNORM*ULP )
$ RESULT( 3 ) = ULPINV
ELSE IF( STRU( I ).EQ.ZERO ) THEN
IF( S( I ).GT.ABNORM*ULP )
$ RESULT( 3 ) = ULPINV
ELSE
WORK( I ) = MAX( ABS( STRU( I ) / S( I ) ),
$ ABS( S( I ) / STRU( I ) ) )
RESULT( 3 ) = MAX( RESULT( 3 ), WORK( I ) )
END IF
120 CONTINUE
*
* Test (4)
*
RESULT( 4 ) = ZERO
IF( DIF( 1 ).EQ.ZERO ) THEN
IF( DIFTRU( 1 ).GT.ABNORM*ULP )
$ RESULT( 4 ) = ULPINV
ELSE IF( DIFTRU( 1 ).EQ.ZERO ) THEN
IF( DIF( 1 ).GT.ABNORM*ULP )
$ RESULT( 4 ) = ULPINV
ELSE IF( DIF( 5 ).EQ.ZERO ) THEN
IF( DIFTRU( 5 ).GT.ABNORM*ULP )
$ RESULT( 4 ) = ULPINV
ELSE IF( DIFTRU( 5 ).EQ.ZERO ) THEN
IF( DIF( 5 ).GT.ABNORM*ULP )
$ RESULT( 4 ) = ULPINV
ELSE
RATIO1 = MAX( ABS( DIFTRU( 1 ) / DIF( 1 ) ),
$ ABS( DIF( 1 ) / DIFTRU( 1 ) ) )
RATIO2 = MAX( ABS( DIFTRU( 5 ) / DIF( 5 ) ),
$ ABS( DIF( 5 ) / DIFTRU( 5 ) ) )
RESULT( 4 ) = MAX( RATIO1, RATIO2 )
END IF
*
NTESTT = NTESTT + 4
*
* Print out tests which fail.
*
DO 130 J = 1, 4
IF( RESULT( J ).GE.THRSH2 ) THEN
*
* If this is the first test to fail,
* print a header to the data file.
*
IF( NERRS.EQ.0 ) THEN
WRITE( NOUT, FMT = 9997 )'SXV'
*
* Print out messages for built-in examples
*
* Matrix types
*
WRITE( NOUT, FMT = 9996 )
*
* Tests performed
*
WRITE( NOUT, FMT = 9992 )'''', 'transpose', ''''
*
END IF
NERRS = NERRS + 1
IF( RESULT( J ).LT.10000.0 ) THEN
WRITE( NOUT, FMT = 9989 )NPTKNT, N, J, RESULT( J )
ELSE
WRITE( NOUT, FMT = 9988 )NPTKNT, N, J, RESULT( J )
END IF
END IF
130 CONTINUE
*
140 CONTINUE
*
GO TO 90
150 CONTINUE
*
* Summary
*
CALL ALASVM( 'SXV', NOUT, NERRS, NTESTT, 0 )
*
WORK( 1 ) = MAXWRK
*
RETURN
*
9999 FORMAT( ' SDRGVX: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ')' )
*
9998 FORMAT( ' SDRGVX: ', A, ' Eigenvectors from ', A, ' incorrectly ',
$ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 9X,
$ 'N=', I6, ', JTYPE=', I6, ', IWA=', I5, ', IWB=', I5,
$ ', IWX=', I5, ', IWY=', I5 )
*
9997 FORMAT( / 1X, A3, ' -- Real Expert Eigenvalue/vector',
$ ' problem driver' )
*
9996 FORMAT( ' Input Example' )
*
9995 FORMAT( ' Matrix types: ', / )
*
9994 FORMAT( ' TYPE 1: Da is diagonal, Db is identity, ',
$ / ' A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1) ',
$ / ' YH and X are left and right eigenvectors. ', / )
*
9993 FORMAT( ' TYPE 2: Da is quasi-diagonal, Db is identity, ',
$ / ' A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1) ',
$ / ' YH and X are left and right eigenvectors. ', / )
*
9992 FORMAT( / ' Tests performed: ', / 4X,
$ ' a is alpha, b is beta, l is a left eigenvector, ', / 4X,
$ ' r is a right eigenvector and ', A, ' means ', A, '.',
$ / ' 1 = max | ( b A - a B )', A, ' l | / const.',
$ / ' 2 = max | ( b A - a B ) r | / const.',
$ / ' 3 = max ( Sest/Stru, Stru/Sest ) ',
$ ' over all eigenvalues', /
$ ' 4 = max( DIFest/DIFtru, DIFtru/DIFest ) ',
$ ' over the 1st and 5th eigenvectors', / )
*
9991 FORMAT( ' Type=', I2, ',', ' IWA=', I2, ', IWB=', I2, ', IWX=',
$ I2, ', IWY=', I2, ', result ', I2, ' is', 0P, F8.2 )
9990 FORMAT( ' Type=', I2, ',', ' IWA=', I2, ', IWB=', I2, ', IWX=',
$ I2, ', IWY=', I2, ', result ', I2, ' is', 1P, E10.3 )
9989 FORMAT( ' Input example #', I2, ', matrix order=', I4, ',',
$ ' result ', I2, ' is', 0P, F8.2 )
9988 FORMAT( ' Input example #', I2, ', matrix order=', I4, ',',
$ ' result ', I2, ' is', 1P, E10.3 )
9987 FORMAT( ' SDRGVX: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', Input example #', I2, ')' )
*
9986 FORMAT( ' SDRGVX: ', A, ' Eigenvectors from ', A, ' incorrectly ',
$ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 9X,
$ 'N=', I6, ', Input Example #', I2, ')' )
*
*
* End of SDRGVX
*
END
SUBROUTINE SDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH,
$ A, LDA, U, LDU, VT, LDVT, ASAV, USAV, VTSAV, S,
$ SSAV, E, WORK, LWORK, IWORK, NOUT, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDU, LDVT, LWORK, NOUT, NSIZES,
$ NTYPES
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER ISEED( 4 ), IWORK( * ), MM( * ), NN( * )
REAL A( LDA, * ), ASAV( LDA, * ), E( * ), S( * ),
$ SSAV( * ), U( LDU, * ), USAV( LDU, * ),
$ VT( LDVT, * ), VTSAV( LDVT, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SDRVBD checks the singular value decomposition (SVD) drivers
* SGESVD and SGESDD.
* Both SGESVD and SGESDD factor A = U diag(S) VT, where U and VT are
* orthogonal and diag(S) is diagonal with the entries of the array S
* on its diagonal. The entries of S are the singular values,
* nonnegative and stored in decreasing order. U and VT can be
* optionally not computed, overwritten on A, or computed partially.
*
* A is M by N. Let MNMIN = min( M, N ). S has dimension MNMIN.
* U can be M by M or M by MNMIN. VT can be N by N or MNMIN by N.
*
* When SDRVBD is called, a number of matrix "sizes" (M's and N's)
* and a number of matrix "types" are specified. For each size (M,N)
* and each type of matrix, and for the minimal workspace as well as
* workspace adequate to permit blocking, an M x N matrix "A" will be
* generated and used to test the SVD routines. For each matrix, A will
* be factored as A = U diag(S) VT and the following 12 tests computed:
*
* Test for SGESVD:
*
* (1) | A - U diag(S) VT | / ( |A| max(M,N) ulp )
*
* (2) | I - U'U | / ( M ulp )
*
* (3) | I - VT VT' | / ( N ulp )
*
* (4) S contains MNMIN nonnegative values in decreasing order.
* (Return 0 if true, 1/ULP if false.)
*
* (5) | U - Upartial | / ( M ulp ) where Upartial is a partially
* computed U.
*
* (6) | VT - VTpartial | / ( N ulp ) where VTpartial is a partially
* computed VT.
*
* (7) | S - Spartial | / ( MNMIN ulp |S| ) where Spartial is the
* vector of singular values from the partial SVD
*
* Test for SGESDD:
*
* (8) | A - U diag(S) VT | / ( |A| max(M,N) ulp )
*
* (9) | I - U'U | / ( M ulp )
*
* (10) | I - VT VT' | / ( N ulp )
*
* (11) S contains MNMIN nonnegative values in decreasing order.
* (Return 0 if true, 1/ULP if false.)
*
* (12) | U - Upartial | / ( M ulp ) where Upartial is a partially
* computed U.
*
* (13) | VT - VTpartial | / ( N ulp ) where VTpartial is a partially
* computed VT.
*
* (14) | S - Spartial | / ( MNMIN ulp |S| ) where Spartial is the
* vector of singular values from the partial SVD
*
* The "sizes" are specified by the arrays MM(1:NSIZES) and
* NN(1:NSIZES); the value of each element pair (MM(j),NN(j))
* specifies one size. The "types" are specified by a logical array
* DOTYPE( 1:NTYPES ); if DOTYPE(j) is .TRUE., then matrix type "j"
* will be generated.
* Currently, the list of possible types is:
*
* (1) The zero matrix.
* (2) The identity matrix.
* (3) A matrix of the form U D V, where U and V are orthogonal and
* D has evenly spaced entries 1, ..., ULP with random signs
* on the diagonal.
* (4) Same as (3), but multiplied by the underflow-threshold / ULP.
* (5) Same as (3), but multiplied by the overflow-threshold * ULP.
*
* Arguments
* ==========
*
* NSIZES (input) INTEGER
* The number of matrix sizes (M,N) contained in the vectors
* MM and NN.
*
* MM (input) INTEGER array, dimension (NSIZES)
* The values of the matrix row dimension M.
*
* NN (input) INTEGER array, dimension (NSIZES)
* The values of the matrix column dimension N.
*
* NTYPES (input) INTEGER
* The number of elements in DOTYPE. If it is zero, SDRVBD
* does nothing. It must be at least zero. If it is MAXTYP+1
* and NSIZES is 1, then an additional type, MAXTYP+1 is
* defined, which is to use whatever matrices are in A and B.
* This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
* DOTYPE(MAXTYP+1) is .TRUE. .
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* If DOTYPE(j) is .TRUE., then for each size (m,n), a matrix
* of type j will be generated. If NTYPES is smaller than the
* maximum number of types defined (PARAMETER MAXTYP), then
* types NTYPES+1 through MAXTYP will not be generated. If
* NTYPES is larger than MAXTYP, DOTYPE(MAXTYP+1) through
* DOTYPE(NTYPES) will be ignored.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry, the seed of the random number generator. The array
* elements should be between 0 and 4095; if not they will be
* reduced mod 4096. Also, ISEED(4) must be odd.
* On exit, ISEED is changed and can be used in the next call to
* SDRVBD to continue the same random number sequence.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. The test
* ratios are scaled to be O(1), so THRESH should be a small
* multiple of 1, e.g., 10 or 100. To have every test ratio
* printed, use THRESH = 0.
*
* A (workspace) REAL array, dimension (LDA,NMAX)
* where NMAX is the maximum value of N in NN.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,MMAX),
* where MMAX is the maximum value of M in MM.
*
* U (workspace) REAL array, dimension (LDU,MMAX)
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= max(1,MMAX).
*
* VT (workspace) REAL array, dimension (LDVT,NMAX)
*
* LDVT (input) INTEGER
* The leading dimension of the array VT. LDVT >= max(1,NMAX).
*
* ASAV (workspace) REAL array, dimension (LDA,NMAX)
*
* USAV (workspace) REAL array, dimension (LDU,MMAX)
*
* VTSAV (workspace) REAL array, dimension (LDVT,NMAX)
*
* S (workspace) REAL array, dimension
* (max(min(MM,NN)))
*
* SSAV (workspace) REAL array, dimension
* (max(min(MM,NN)))
*
* E (workspace) REAL array, dimension
* (max(min(MM,NN)))
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The number of entries in WORK. This must be at least
* max(3*MN+MX,5*MN-4)+2*MN**2 for all pairs
* pairs (MN,MX)=( min(MM(j),NN(j), max(MM(j),NN(j)) )
*
* IWORK (workspace) INTEGER array, dimension at least 8*min(M,N)
*
* NOUT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns IINFO not equal to 0.)
*
* INFO (output) INTEGER
* If 0, then everything ran OK.
* -1: NSIZES < 0
* -2: Some MM(j) < 0
* -3: Some NN(j) < 0
* -4: NTYPES < 0
* -7: THRESH < 0
* -10: LDA < 1 or LDA < MMAX, where MMAX is max( MM(j) ).
* -12: LDU < 1 or LDU < MMAX.
* -14: LDVT < 1 or LDVT < NMAX, where NMAX is max( NN(j) ).
* -21: LWORK too small.
* If SLATMS, or SGESVD returns an error code, the
* absolute value of it is returned.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 5 )
* ..
* .. Local Scalars ..
LOGICAL BADMM, BADNN
CHARACTER JOBQ, JOBU, JOBVT
CHARACTER*3 PATH
INTEGER I, IINFO, IJQ, IJU, IJVT, IWS, IWTMP, J, JSIZE,
$ JTYPE, LSWORK, M, MINWRK, MMAX, MNMAX, MNMIN,
$ MTYPES, N, NFAIL, NMAX, NTEST
REAL ANORM, DIF, DIV, OVFL, ULP, ULPINV, UNFL
* ..
* .. Local Arrays ..
CHARACTER CJOB( 4 )
INTEGER IOLDSD( 4 )
REAL RESULT( 14 )
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL ALASVM, SBDT01, SGESDD, SGESVD, SLABAD, SLACPY,
$ SLASET, SLATMS, SORT01, SORT03, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA CJOB / 'N', 'O', 'S', 'A' /
* ..
* .. Executable Statements ..
*
* Check for errors
*
INFO = 0
BADMM = .FALSE.
BADNN = .FALSE.
MMAX = 1
NMAX = 1
MNMAX = 1
MINWRK = 1
DO 10 J = 1, NSIZES
MMAX = MAX( MMAX, MM( J ) )
IF( MM( J ).LT.0 )
$ BADMM = .TRUE.
NMAX = MAX( NMAX, NN( J ) )
IF( NN( J ).LT.0 )
$ BADNN = .TRUE.
MNMAX = MAX( MNMAX, MIN( MM( J ), NN( J ) ) )
MINWRK = MAX( MINWRK, MAX( 3*MIN( MM( J ),
$ NN( J ) )+MAX( MM( J ), NN( J ) ), 5*MIN( MM( J ),
$ NN( J )-4 ) )+2*MIN( MM( J ), NN( J ) )**2 )
10 CONTINUE
*
* Check for errors
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADMM ) THEN
INFO = -2
ELSE IF( BADNN ) THEN
INFO = -3
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, MMAX ) ) THEN
INFO = -10
ELSE IF( LDU.LT.MAX( 1, MMAX ) ) THEN
INFO = -12
ELSE IF( LDVT.LT.MAX( 1, NMAX ) ) THEN
INFO = -14
ELSE IF( MINWRK.GT.LWORK ) THEN
INFO = -21
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SDRVBD', -INFO )
RETURN
END IF
*
* Initialize constants
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'BD'
NFAIL = 0
NTEST = 0
UNFL = SLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
CALL SLABAD( UNFL, OVFL )
ULP = SLAMCH( 'Precision' )
ULPINV = ONE / ULP
INFOT = 0
*
* Loop over sizes, types
*
DO 150 JSIZE = 1, NSIZES
M = MM( JSIZE )
N = NN( JSIZE )
MNMIN = MIN( M, N )
*
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
DO 140 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 140
*
DO 20 J = 1, 4
IOLDSD( J ) = ISEED( J )
20 CONTINUE
*
* Compute "A"
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 30
*
IF( JTYPE.EQ.1 ) THEN
*
* Zero matrix
*
CALL SLASET( 'Full', M, N, ZERO, ZERO, A, LDA )
*
ELSE IF( JTYPE.EQ.2 ) THEN
*
* Identity matrix
*
CALL SLASET( 'Full', M, N, ZERO, ONE, A, LDA )
*
ELSE
*
* (Scaled) random matrix
*
IF( JTYPE.EQ.3 )
$ ANORM = ONE
IF( JTYPE.EQ.4 )
$ ANORM = UNFL / ULP
IF( JTYPE.EQ.5 )
$ ANORM = OVFL*ULP
CALL SLATMS( M, N, 'U', ISEED, 'N', S, 4, REAL( MNMIN ),
$ ANORM, M-1, N-1, 'N', A, LDA, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9996 )'Generator', IINFO, M, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
END IF
*
30 CONTINUE
CALL SLACPY( 'F', M, N, A, LDA, ASAV, LDA )
*
* Do for minimal and adequate (for blocking) workspace
*
DO 130 IWS = 1, 4
*
DO 40 J = 1, 14
RESULT( J ) = -ONE
40 CONTINUE
*
* Test SGESVD: Factorize A
*
IWTMP = MAX( 3*MIN( M, N )+MAX( M, N ), 5*MIN( M, N ) )
LSWORK = IWTMP + ( IWS-1 )*( LWORK-IWTMP ) / 3
LSWORK = MIN( LSWORK, LWORK )
LSWORK = MAX( LSWORK, 1 )
IF( IWS.EQ.4 )
$ LSWORK = LWORK
*
IF( IWS.GT.1 )
$ CALL SLACPY( 'F', M, N, ASAV, LDA, A, LDA )
SRNAMT = 'SGESVD'
CALL SGESVD( 'A', 'A', M, N, A, LDA, SSAV, USAV, LDU,
$ VTSAV, LDVT, WORK, LSWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9995 )'GESVD', IINFO, M, N, JTYPE,
$ LSWORK, IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
* Do tests 1--4
*
CALL SBDT01( M, N, 0, ASAV, LDA, USAV, LDU, SSAV, E,
$ VTSAV, LDVT, WORK, RESULT( 1 ) )
IF( M.NE.0 .AND. N.NE.0 ) THEN
CALL SORT01( 'Columns', M, M, USAV, LDU, WORK, LWORK,
$ RESULT( 2 ) )
CALL SORT01( 'Rows', N, N, VTSAV, LDVT, WORK, LWORK,
$ RESULT( 3 ) )
END IF
RESULT( 4 ) = ZERO
DO 50 I = 1, MNMIN - 1
IF( SSAV( I ).LT.SSAV( I+1 ) )
$ RESULT( 4 ) = ULPINV
IF( SSAV( I ).LT.ZERO )
$ RESULT( 4 ) = ULPINV
50 CONTINUE
IF( MNMIN.GE.1 ) THEN
IF( SSAV( MNMIN ).LT.ZERO )
$ RESULT( 4 ) = ULPINV
END IF
*
* Do partial SVDs, comparing to SSAV, USAV, and VTSAV
*
RESULT( 5 ) = ZERO
RESULT( 6 ) = ZERO
RESULT( 7 ) = ZERO
DO 80 IJU = 0, 3
DO 70 IJVT = 0, 3
IF( ( IJU.EQ.3 .AND. IJVT.EQ.3 ) .OR.
$ ( IJU.EQ.1 .AND. IJVT.EQ.1 ) )GO TO 70
JOBU = CJOB( IJU+1 )
JOBVT = CJOB( IJVT+1 )
CALL SLACPY( 'F', M, N, ASAV, LDA, A, LDA )
SRNAMT = 'SGESVD'
CALL SGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU,
$ VT, LDVT, WORK, LSWORK, IINFO )
*
* Compare U
*
DIF = ZERO
IF( M.GT.0 .AND. N.GT.0 ) THEN
IF( IJU.EQ.1 ) THEN
CALL SORT03( 'C', M, MNMIN, M, MNMIN, USAV,
$ LDU, A, LDA, WORK, LWORK, DIF,
$ IINFO )
ELSE IF( IJU.EQ.2 ) THEN
CALL SORT03( 'C', M, MNMIN, M, MNMIN, USAV,
$ LDU, U, LDU, WORK, LWORK, DIF,
$ IINFO )
ELSE IF( IJU.EQ.3 ) THEN
CALL SORT03( 'C', M, M, M, MNMIN, USAV, LDU,
$ U, LDU, WORK, LWORK, DIF,
$ IINFO )
END IF
END IF
RESULT( 5 ) = MAX( RESULT( 5 ), DIF )
*
* Compare VT
*
DIF = ZERO
IF( M.GT.0 .AND. N.GT.0 ) THEN
IF( IJVT.EQ.1 ) THEN
CALL SORT03( 'R', N, MNMIN, N, MNMIN, VTSAV,
$ LDVT, A, LDA, WORK, LWORK, DIF,
$ IINFO )
ELSE IF( IJVT.EQ.2 ) THEN
CALL SORT03( 'R', N, MNMIN, N, MNMIN, VTSAV,
$ LDVT, VT, LDVT, WORK, LWORK,
$ DIF, IINFO )
ELSE IF( IJVT.EQ.3 ) THEN
CALL SORT03( 'R', N, N, N, MNMIN, VTSAV,
$ LDVT, VT, LDVT, WORK, LWORK,
$ DIF, IINFO )
END IF
END IF
RESULT( 6 ) = MAX( RESULT( 6 ), DIF )
*
* Compare S
*
DIF = ZERO
DIV = MAX( REAL( MNMIN )*ULP*S( 1 ), UNFL )
DO 60 I = 1, MNMIN - 1
IF( SSAV( I ).LT.SSAV( I+1 ) )
$ DIF = ULPINV
IF( SSAV( I ).LT.ZERO )
$ DIF = ULPINV
DIF = MAX( DIF, ABS( SSAV( I )-S( I ) ) / DIV )
60 CONTINUE
RESULT( 7 ) = MAX( RESULT( 7 ), DIF )
70 CONTINUE
80 CONTINUE
*
* Test SGESDD: Factorize A
*
IWTMP = 5*MNMIN*MNMIN + 9*MNMIN + MAX( M, N )
LSWORK = IWTMP + ( IWS-1 )*( LWORK-IWTMP ) / 3
LSWORK = MIN( LSWORK, LWORK )
LSWORK = MAX( LSWORK, 1 )
IF( IWS.EQ.4 )
$ LSWORK = LWORK
*
CALL SLACPY( 'F', M, N, ASAV, LDA, A, LDA )
SRNAMT = 'SGESDD'
CALL SGESDD( 'A', M, N, A, LDA, SSAV, USAV, LDU, VTSAV,
$ LDVT, WORK, LSWORK, IWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9995 )'GESDD', IINFO, M, N, JTYPE,
$ LSWORK, IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
* Do tests 8--11
*
CALL SBDT01( M, N, 0, ASAV, LDA, USAV, LDU, SSAV, E,
$ VTSAV, LDVT, WORK, RESULT( 8 ) )
IF( M.NE.0 .AND. N.NE.0 ) THEN
CALL SORT01( 'Columns', M, M, USAV, LDU, WORK, LWORK,
$ RESULT( 9 ) )
CALL SORT01( 'Rows', N, N, VTSAV, LDVT, WORK, LWORK,
$ RESULT( 10 ) )
END IF
RESULT( 11 ) = ZERO
DO 90 I = 1, MNMIN - 1
IF( SSAV( I ).LT.SSAV( I+1 ) )
$ RESULT( 11 ) = ULPINV
IF( SSAV( I ).LT.ZERO )
$ RESULT( 11 ) = ULPINV
90 CONTINUE
IF( MNMIN.GE.1 ) THEN
IF( SSAV( MNMIN ).LT.ZERO )
$ RESULT( 11 ) = ULPINV
END IF
*
* Do partial SVDs, comparing to SSAV, USAV, and VTSAV
*
RESULT( 12 ) = ZERO
RESULT( 13 ) = ZERO
RESULT( 14 ) = ZERO
DO 110 IJQ = 0, 2
JOBQ = CJOB( IJQ+1 )
CALL SLACPY( 'F', M, N, ASAV, LDA, A, LDA )
SRNAMT = 'SGESDD'
CALL SGESDD( JOBQ, M, N, A, LDA, S, U, LDU, VT, LDVT,
$ WORK, LSWORK, IWORK, IINFO )
*
* Compare U
*
DIF = ZERO
IF( M.GT.0 .AND. N.GT.0 ) THEN
IF( IJQ.EQ.1 ) THEN
IF( M.GE.N ) THEN
CALL SORT03( 'C', M, MNMIN, M, MNMIN, USAV,
$ LDU, A, LDA, WORK, LWORK, DIF,
$ INFO )
ELSE
CALL SORT03( 'C', M, MNMIN, M, MNMIN, USAV,
$ LDU, U, LDU, WORK, LWORK, DIF,
$ INFO )
END IF
ELSE IF( IJQ.EQ.2 ) THEN
CALL SORT03( 'C', M, MNMIN, M, MNMIN, USAV, LDU,
$ U, LDU, WORK, LWORK, DIF, INFO )
END IF
END IF
RESULT( 12 ) = MAX( RESULT( 12 ), DIF )
*
* Compare VT
*
DIF = ZERO
IF( M.GT.0 .AND. N.GT.0 ) THEN
IF( IJQ.EQ.1 ) THEN
IF( M.GE.N ) THEN
CALL SORT03( 'R', N, MNMIN, N, MNMIN, VTSAV,
$ LDVT, VT, LDVT, WORK, LWORK,
$ DIF, INFO )
ELSE
CALL SORT03( 'R', N, MNMIN, N, MNMIN, VTSAV,
$ LDVT, A, LDA, WORK, LWORK, DIF,
$ INFO )
END IF
ELSE IF( IJQ.EQ.2 ) THEN
CALL SORT03( 'R', N, MNMIN, N, MNMIN, VTSAV,
$ LDVT, VT, LDVT, WORK, LWORK, DIF,
$ INFO )
END IF
END IF
RESULT( 13 ) = MAX( RESULT( 13 ), DIF )
*
* Compare S
*
DIF = ZERO
DIV = MAX( REAL( MNMIN )*ULP*S( 1 ), UNFL )
DO 100 I = 1, MNMIN - 1
IF( SSAV( I ).LT.SSAV( I+1 ) )
$ DIF = ULPINV
IF( SSAV( I ).LT.ZERO )
$ DIF = ULPINV
DIF = MAX( DIF, ABS( SSAV( I )-S( I ) ) / DIV )
100 CONTINUE
RESULT( 14 ) = MAX( RESULT( 14 ), DIF )
110 CONTINUE
*
* End of Loop -- Check for RESULT(j) > THRESH
*
DO 120 J = 1, 14
IF( RESULT( J ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 ) THEN
WRITE( NOUT, FMT = 9999 )
WRITE( NOUT, FMT = 9998 )
END IF
WRITE( NOUT, FMT = 9997 )M, N, JTYPE, IWS, IOLDSD,
$ J, RESULT( J )
NFAIL = NFAIL + 1
END IF
120 CONTINUE
NTEST = NTEST + 14
*
130 CONTINUE
140 CONTINUE
150 CONTINUE
*
* Summary
*
CALL ALASVM( PATH, NOUT, NFAIL, NTEST, 0 )
*
9999 FORMAT( ' SVD -- Real Singular Value Decomposition Driver ',
$ / ' Matrix types (see SDRVBD for details):',
$ / / ' 1 = Zero matrix', / ' 2 = Identity matrix',
$ / ' 3 = Evenly spaced singular values near 1',
$ / ' 4 = Evenly spaced singular values near underflow',
$ / ' 5 = Evenly spaced singular values near overflow', / /
$ ' Tests performed: ( A is dense, U and V are orthogonal,',
$ / 19X, ' S is an array, and Upartial, VTpartial, and',
$ / 19X, ' Spartial are partially computed U, VT and S),', / )
9998 FORMAT( ' 1 = | A - U diag(S) VT | / ( |A| max(M,N) ulp ) ',
$ / ' 2 = | I - U**T U | / ( M ulp ) ',
$ / ' 3 = | I - VT VT**T | / ( N ulp ) ',
$ / ' 4 = 0 if S contains min(M,N) nonnegative values in',
$ ' decreasing order, else 1/ulp',
$ / ' 5 = | U - Upartial | / ( M ulp )',
$ / ' 6 = | VT - VTpartial | / ( N ulp )',
$ / ' 7 = | S - Spartial | / ( min(M,N) ulp |S| )',
$ / ' 8 = | A - U diag(S) VT | / ( |A| max(M,N) ulp ) ',
$ / ' 9 = | I - U**T U | / ( M ulp ) ',
$ / '10 = | I - VT VT**T | / ( N ulp ) ',
$ / '11 = 0 if S contains min(M,N) nonnegative values in',
$ ' decreasing order, else 1/ulp',
$ / '12 = | U - Upartial | / ( M ulp )',
$ / '13 = | VT - VTpartial | / ( N ulp )',
$ / '14 = | S - Spartial | / ( min(M,N) ulp |S| )', / / )
9997 FORMAT( ' M=', I5, ', N=', I5, ', type ', I1, ', IWS=', I1,
$ ', seed=', 4( I4, ',' ), ' test(', I2, ')=', G11.4 )
9996 FORMAT( ' SDRVBD: ', A, ' returned INFO=', I6, '.', / 9X, 'M=',
$ I6, ', N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ),
$ I5, ')' )
9995 FORMAT( ' SDRVBD: ', A, ' returned INFO=', I6, '.', / 9X, 'M=',
$ I6, ', N=', I6, ', JTYPE=', I6, ', LSWORK=', I6, / 9X,
$ 'ISEED=(', 3( I5, ',' ), I5, ')' )
*
RETURN
*
* End of SDRVBD
*
END
SUBROUTINE SDRVES( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
$ NOUNIT, A, LDA, H, HT, WR, WI, WRT, WIT, VS,
$ LDVS, RESULT, WORK, NWORK, IWORK, BWORK, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDVS, NOUNIT, NSIZES, NTYPES, NWORK
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL BWORK( * ), DOTYPE( * )
INTEGER ISEED( 4 ), IWORK( * ), NN( * )
REAL A( LDA, * ), H( LDA, * ), HT( LDA, * ),
$ RESULT( 13 ), VS( LDVS, * ), WI( * ), WIT( * ),
$ WORK( * ), WR( * ), WRT( * )
* ..
*
* Purpose
* =======
*
* SDRVES checks the nonsymmetric eigenvalue (Schur form) problem
* driver SGEES.
*
* When SDRVES is called, a number of matrix "sizes" ("n's") and a
* number of matrix "types" are specified. For each size ("n")
* and each type of matrix, one matrix will be generated and used
* to test the nonsymmetric eigenroutines. For each matrix, 13
* tests will be performed:
*
* (1) 0 if T is in Schur form, 1/ulp otherwise
* (no sorting of eigenvalues)
*
* (2) | A - VS T VS' | / ( n |A| ulp )
*
* Here VS is the matrix of Schur eigenvectors, and T is in Schur
* form (no sorting of eigenvalues).
*
* (3) | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues).
*
* (4) 0 if WR+sqrt(-1)*WI are eigenvalues of T
* 1/ulp otherwise
* (no sorting of eigenvalues)
*
* (5) 0 if T(with VS) = T(without VS),
* 1/ulp otherwise
* (no sorting of eigenvalues)
*
* (6) 0 if eigenvalues(with VS) = eigenvalues(without VS),
* 1/ulp otherwise
* (no sorting of eigenvalues)
*
* (7) 0 if T is in Schur form, 1/ulp otherwise
* (with sorting of eigenvalues)
*
* (8) | A - VS T VS' | / ( n |A| ulp )
*
* Here VS is the matrix of Schur eigenvectors, and T is in Schur
* form (with sorting of eigenvalues).
*
* (9) | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues).
*
* (10) 0 if WR+sqrt(-1)*WI are eigenvalues of T
* 1/ulp otherwise
* (with sorting of eigenvalues)
*
* (11) 0 if T(with VS) = T(without VS),
* 1/ulp otherwise
* (with sorting of eigenvalues)
*
* (12) 0 if eigenvalues(with VS) = eigenvalues(without VS),
* 1/ulp otherwise
* (with sorting of eigenvalues)
*
* (13) if sorting worked and SDIM is the number of
* eigenvalues which were SELECTed
*
* The "sizes" are specified by an array NN(1:NSIZES); the value of
* each element NN(j) specifies one size.
* The "types" are specified by a logical array DOTYPE( 1:NTYPES );
* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
* Currently, the list of possible types is:
*
* (1) The zero matrix.
* (2) The identity matrix.
* (3) A (transposed) Jordan block, with 1's on the diagonal.
*
* (4) A diagonal matrix with evenly spaced entries
* 1, ..., ULP and random signs.
* (ULP = (first number larger than 1) - 1 )
* (5) A diagonal matrix with geometrically spaced entries
* 1, ..., ULP and random signs.
* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
* and random signs.
*
* (7) Same as (4), but multiplied by a constant near
* the overflow threshold
* (8) Same as (4), but multiplied by a constant near
* the underflow threshold
*
* (9) A matrix of the form U' T U, where U is orthogonal and
* T has evenly spaced entries 1, ..., ULP with random signs
* on the diagonal and random O(1) entries in the upper
* triangle.
*
* (10) A matrix of the form U' T U, where U is orthogonal and
* T has geometrically spaced entries 1, ..., ULP with random
* signs on the diagonal and random O(1) entries in the upper
* triangle.
*
* (11) A matrix of the form U' T U, where U is orthogonal and
* T has "clustered" entries 1, ULP,..., ULP with random
* signs on the diagonal and random O(1) entries in the upper
* triangle.
*
* (12) A matrix of the form U' T U, where U is orthogonal and
* T has real or complex conjugate paired eigenvalues randomly
* chosen from ( ULP, 1 ) and random O(1) entries in the upper
* triangle.
*
* (13) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP
* with random signs on the diagonal and random O(1) entries
* in the upper triangle.
*
* (14) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has geometrically spaced entries
* 1, ..., ULP with random signs on the diagonal and random
* O(1) entries in the upper triangle.
*
* (15) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP
* with random signs on the diagonal and random O(1) entries
* in the upper triangle.
*
* (16) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has real or complex conjugate paired
* eigenvalues randomly chosen from ( ULP, 1 ) and random
* O(1) entries in the upper triangle.
*
* (17) Same as (16), but multiplied by a constant
* near the overflow threshold
* (18) Same as (16), but multiplied by a constant
* near the underflow threshold
*
* (19) Nonsymmetric matrix with random entries chosen from (-1,1).
* If N is at least 4, all entries in first two rows and last
* row, and first column and last two columns are zero.
* (20) Same as (19), but multiplied by a constant
* near the overflow threshold
* (21) Same as (19), but multiplied by a constant
* near the underflow threshold
*
* Arguments
* =========
*
* NSIZES (input) INTEGER
* The number of sizes of matrices to use. If it is zero,
* SDRVES does nothing. It must be at least zero.
*
* NN (input) INTEGER array, dimension (NSIZES)
* An array containing the sizes to be used for the matrices.
* Zero values will be skipped. The values must be at least
* zero.
*
* NTYPES (input) INTEGER
* The number of elements in DOTYPE. If it is zero, SDRVES
* does nothing. It must be at least zero. If it is MAXTYP+1
* and NSIZES is 1, then an additional type, MAXTYP+1 is
* defined, which is to use whatever matrix is in A. This
* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
* DOTYPE(MAXTYP+1) is .TRUE. .
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* If DOTYPE(j) is .TRUE., then for each size in NN a
* matrix of that size and of type j will be generated.
* If NTYPES is smaller than the maximum number of types
* defined (PARAMETER MAXTYP), then types NTYPES+1 through
* MAXTYP will not be generated. If NTYPES is larger
* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
* will be ignored.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The array elements should be between 0 and 4095;
* if not they will be reduced mod 4096. Also, ISEED(4) must
* be odd. The random number generator uses a linear
* congruential sequence limited to small integers, and so
* should produce machine independent random numbers. The
* values of ISEED are changed on exit, and can be used in the
* next call to SDRVES to continue the same random number
* sequence.
*
* THRESH (input) REAL
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error
* is scaled to be O(1), so THRESH should be a reasonably
* small multiple of 1, e.g., 10 or 100. In particular,
* it should not depend on the precision (single vs. double)
* or the size of the matrix. It must be at least zero.
*
* NOUNIT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns INFO not equal to 0.)
*
* A (workspace) REAL array, dimension (LDA, max(NN))
* Used to hold the matrix whose eigenvalues are to be
* computed. On exit, A contains the last matrix actually used.
*
* LDA (input) INTEGER
* The leading dimension of A, and H. LDA must be at
* least 1 and at least max(NN).
*
* H (workspace) REAL array, dimension (LDA, max(NN))
* Another copy of the test matrix A, modified by SGEES.
*
* HT (workspace) REAL array, dimension (LDA, max(NN))
* Yet another copy of the test matrix A, modified by SGEES.
*
* WR (workspace) REAL array, dimension (max(NN))
* WI (workspace) REAL array, dimension (max(NN))
* The real and imaginary parts of the eigenvalues of A.
* On exit, WR + WI*i are the eigenvalues of the matrix in A.
*
* WRT (workspace) REAL array, dimension (max(NN))
* WIT (workspace) REAL array, dimension (max(NN))
* Like WR, WI, these arrays contain the eigenvalues of A,
* but those computed when SGEES only computes a partial
* eigendecomposition, i.e. not Schur vectors
*
* VS (workspace) REAL array, dimension (LDVS, max(NN))
* VS holds the computed Schur vectors.
*
* LDVS (input) INTEGER
* Leading dimension of VS. Must be at least max(1,max(NN)).
*
* RESULT (output) REAL array, dimension (13)
* The values computed by the 13 tests described above.
* The values are currently limited to 1/ulp, to avoid overflow.
*
* WORK (workspace) REAL array, dimension (NWORK)
*
* NWORK (input) INTEGER
* The number of entries in WORK. This must be at least
* 5*NN(j)+2*NN(j)**2 for all j.
*
* IWORK (workspace) INTEGER array, dimension (max(NN))
*
* INFO (output) INTEGER
* If 0, then everything ran OK.
* -1: NSIZES < 0
* -2: Some NN(j) < 0
* -3: NTYPES < 0
* -6: THRESH < 0
* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
* -17: LDVS < 1 or LDVS < NMAX, where NMAX is max( NN(j) ).
* -20: NWORK too small.
* If SLATMR, SLATMS, SLATME or SGEES returns an error code,
* the absolute value of it is returned.
*
*-----------------------------------------------------------------------
*
* Some Local Variables and Parameters:
* ---- ----- --------- --- ----------
*
* ZERO, ONE Real 0 and 1.
* MAXTYP The number of types defined.
* NMAX Largest value in NN.
* NERRS The number of tests which have exceeded THRESH
* COND, CONDS,
* IMODE Values to be passed to the matrix generators.
* ANORM Norm of A; passed to matrix generators.
*
* OVFL, UNFL Overflow and underflow thresholds.
* ULP, ULPINV Finest relative precision and its inverse.
* RTULP, RTULPI Square roots of the previous 4 values.
*
* The following four arrays decode JTYPE:
* KTYPE(j) The general type (1-10) for type "j".
* KMODE(j) The MODE value to be passed to the matrix
* generator for type "j".
* KMAGN(j) The order of magnitude ( O(1),
* O(overflow^(1/2) ), O(underflow^(1/2) )
* KCONDS(j) Selectw whether CONDS is to be 1 or
* 1/sqrt(ulp). (0 means irrelevant.)
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 21 )
* ..
* .. Local Scalars ..
LOGICAL BADNN
CHARACTER SORT
CHARACTER*3 PATH
INTEGER I, IINFO, IMODE, ISORT, ITYPE, IWK, J, JCOL,
$ JSIZE, JTYPE, KNTEIG, LWORK, MTYPES, N,
$ NERRS, NFAIL, NMAX, NNWORK, NTEST, NTESTF,
$ NTESTT, RSUB, SDIM
REAL ANORM, COND, CONDS, OVFL, RTULP, RTULPI, TMP,
$ ULP, ULPINV, UNFL
* ..
* .. Local Arrays ..
CHARACTER ADUMMA( 1 )
INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( MAXTYP ),
$ KMAGN( MAXTYP ), KMODE( MAXTYP ),
$ KTYPE( MAXTYP )
REAL RES( 2 )
* ..
* .. Arrays in Common ..
LOGICAL SELVAL( 20 )
REAL SELWI( 20 ), SELWR( 20 )
* ..
* .. Scalars in Common ..
INTEGER SELDIM, SELOPT
* ..
* .. Common blocks ..
COMMON / SSLCT / SELOPT, SELDIM, SELVAL, SELWR, SELWI
* ..
* .. External Functions ..
LOGICAL SSLECT
REAL SLAMCH
EXTERNAL SSLECT, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SGEES, SHST01, SLABAD, SLACPY, SLASUM, SLATME,
$ SLATMR, SLATMS, SLASET, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SIGN, SQRT
* ..
* .. Data statements ..
DATA KTYPE / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
DATA KMAGN / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
$ 3, 1, 2, 3 /
DATA KMODE / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
$ 1, 5, 5, 5, 4, 3, 1 /
DATA KCONDS / 3*0, 5*0, 4*1, 6*2, 3*0 /
* ..
* .. Executable Statements ..
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'ES'
*
* Check for errors
*
NTESTT = 0
NTESTF = 0
INFO = 0
SELOPT = 0
*
* Important constants
*
BADNN = .FALSE.
NMAX = 0
DO 10 J = 1, NSIZES
NMAX = MAX( NMAX, NN( J ) )
IF( NN( J ).LT.0 )
$ BADNN = .TRUE.
10 CONTINUE
*
* Check for errors
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADNN ) THEN
INFO = -2
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -3
ELSE IF( THRESH.LT.ZERO ) THEN
INFO = -6
ELSE IF( NOUNIT.LE.0 ) THEN
INFO = -7
ELSE IF( LDA.LT.1 .OR. LDA.LT.NMAX ) THEN
INFO = -9
ELSE IF( LDVS.LT.1 .OR. LDVS.LT.NMAX ) THEN
INFO = -17
ELSE IF( 5*NMAX+2*NMAX**2.GT.NWORK ) THEN
INFO = -20
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SDRVES', -INFO )
RETURN
END IF
*
* Quick return if nothing to do
*
IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
$ RETURN
*
* More Important constants
*
UNFL = SLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
CALL SLABAD( UNFL, OVFL )
ULP = SLAMCH( 'Precision' )
ULPINV = ONE / ULP
RTULP = SQRT( ULP )
RTULPI = ONE / RTULP
*
* Loop over sizes, types
*
NERRS = 0
*
DO 270 JSIZE = 1, NSIZES
N = NN( JSIZE )
MTYPES = MAXTYP
IF( NSIZES.EQ.1 .AND. NTYPES.EQ.MAXTYP+1 )
$ MTYPES = MTYPES + 1
*
DO 260 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 260
*
* Save ISEED in case of an error.
*
DO 20 J = 1, 4
IOLDSD( J ) = ISEED( J )
20 CONTINUE
*
* Compute "A"
*
* Control parameters:
*
* KMAGN KCONDS KMODE KTYPE
* =1 O(1) 1 clustered 1 zero
* =2 large large clustered 2 identity
* =3 small exponential Jordan
* =4 arithmetic diagonal, (w/ eigenvalues)
* =5 random log symmetric, w/ eigenvalues
* =6 random general, w/ eigenvalues
* =7 random diagonal
* =8 random symmetric
* =9 random general
* =10 random triangular
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 90
*
ITYPE = KTYPE( JTYPE )
IMODE = KMODE( JTYPE )
*
* Compute norm
*
GO TO ( 30, 40, 50 )KMAGN( JTYPE )
*
30 CONTINUE
ANORM = ONE
GO TO 60
*
40 CONTINUE
ANORM = OVFL*ULP
GO TO 60
*
50 CONTINUE
ANORM = UNFL*ULPINV
GO TO 60
*
60 CONTINUE
*
CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
IINFO = 0
COND = ULPINV
*
* Special Matrices -- Identity & Jordan block
*
* Zero
*
IF( ITYPE.EQ.1 ) THEN
IINFO = 0
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Identity
*
DO 70 JCOL = 1, N
A( JCOL, JCOL ) = ANORM
70 CONTINUE
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* Jordan Block
*
DO 80 JCOL = 1, N
A( JCOL, JCOL ) = ANORM
IF( JCOL.GT.1 )
$ A( JCOL, JCOL-1 ) = ONE
80 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Diagonal Matrix, [Eigen]values Specified
*
CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.5 ) THEN
*
* Symmetric, eigenvalues specified
*
CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, N, N, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.6 ) THEN
*
* General, eigenvalues specified
*
IF( KCONDS( JTYPE ).EQ.1 ) THEN
CONDS = ONE
ELSE IF( KCONDS( JTYPE ).EQ.2 ) THEN
CONDS = RTULPI
ELSE
CONDS = ZERO
END IF
*
ADUMMA( 1 ) = ' '
CALL SLATME( N, 'S', ISEED, WORK, IMODE, COND, ONE,
$ ADUMMA, 'T', 'T', 'T', WORK( N+1 ), 4,
$ CONDS, N, N, ANORM, A, LDA, WORK( 2*N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.7 ) THEN
*
* Diagonal, random eigenvalues
*
CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.8 ) THEN
*
* Symmetric, random eigenvalues
*
CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.9 ) THEN
*
* General, random eigenvalues
*
CALL SLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
IF( N.GE.4 ) THEN
CALL SLASET( 'Full', 2, N, ZERO, ZERO, A, LDA )
CALL SLASET( 'Full', N-3, 1, ZERO, ZERO, A( 3, 1 ),
$ LDA )
CALL SLASET( 'Full', N-3, 2, ZERO, ZERO, A( 3, N-1 ),
$ LDA )
CALL SLASET( 'Full', 1, N, ZERO, ZERO, A( N, 1 ),
$ LDA )
END IF
*
ELSE IF( ITYPE.EQ.10 ) THEN
*
* Triangular, random eigenvalues
*
CALL SLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, 0,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE
*
IINFO = 1
END IF
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9992 )'Generator', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
90 CONTINUE
*
* Test for minimal and generous workspace
*
DO 250 IWK = 1, 2
IF( IWK.EQ.1 ) THEN
NNWORK = 3*N
ELSE
NNWORK = 5*N + 2*N**2
END IF
NNWORK = MAX( NNWORK, 1 )
*
* Initialize RESULT
*
DO 100 J = 1, 13
RESULT( J ) = -ONE
100 CONTINUE
*
* Test with and without sorting of eigenvalues
*
DO 210 ISORT = 0, 1
IF( ISORT.EQ.0 ) THEN
SORT = 'N'
RSUB = 0
ELSE
SORT = 'S'
RSUB = 6
END IF
*
* Compute Schur form and Schur vectors, and test them
*
CALL SLACPY( 'F', N, N, A, LDA, H, LDA )
CALL SGEES( 'V', SORT, SSLECT, N, H, LDA, SDIM, WR,
$ WI, VS, LDVS, WORK, NNWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 1+RSUB ) = ULPINV
WRITE( NOUNIT, FMT = 9992 )'SGEES1', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
GO TO 220
END IF
*
* Do Test (1) or Test (7)
*
RESULT( 1+RSUB ) = ZERO
DO 120 J = 1, N - 2
DO 110 I = J + 2, N
IF( H( I, J ).NE.ZERO )
$ RESULT( 1+RSUB ) = ULPINV
110 CONTINUE
120 CONTINUE
DO 130 I = 1, N - 2
IF( H( I+1, I ).NE.ZERO .AND. H( I+2, I+1 ).NE.
$ ZERO )RESULT( 1+RSUB ) = ULPINV
130 CONTINUE
DO 140 I = 1, N - 1
IF( H( I+1, I ).NE.ZERO ) THEN
IF( H( I, I ).NE.H( I+1, I+1 ) .OR.
$ H( I, I+1 ).EQ.ZERO .OR.
$ SIGN( ONE, H( I+1, I ) ).EQ.
$ SIGN( ONE, H( I, I+1 ) ) )RESULT( 1+RSUB )
$ = ULPINV
END IF
140 CONTINUE
*
* Do Tests (2) and (3) or Tests (8) and (9)
*
LWORK = MAX( 1, 2*N*N )
CALL SHST01( N, 1, N, A, LDA, H, LDA, VS, LDVS, WORK,
$ LWORK, RES )
RESULT( 2+RSUB ) = RES( 1 )
RESULT( 3+RSUB ) = RES( 2 )
*
* Do Test (4) or Test (10)
*
RESULT( 4+RSUB ) = ZERO
DO 150 I = 1, N
IF( H( I, I ).NE.WR( I ) )
$ RESULT( 4+RSUB ) = ULPINV
150 CONTINUE
IF( N.GT.1 ) THEN
IF( H( 2, 1 ).EQ.ZERO .AND. WI( 1 ).NE.ZERO )
$ RESULT( 4+RSUB ) = ULPINV
IF( H( N, N-1 ).EQ.ZERO .AND. WI( N ).NE.ZERO )
$ RESULT( 4+RSUB ) = ULPINV
END IF
DO 160 I = 1, N - 1
IF( H( I+1, I ).NE.ZERO ) THEN
TMP = SQRT( ABS( H( I+1, I ) ) )*
$ SQRT( ABS( H( I, I+1 ) ) )
RESULT( 4+RSUB ) = MAX( RESULT( 4+RSUB ),
$ ABS( WI( I )-TMP ) /
$ MAX( ULP*TMP, UNFL ) )
RESULT( 4+RSUB ) = MAX( RESULT( 4+RSUB ),
$ ABS( WI( I+1 )+TMP ) /
$ MAX( ULP*TMP, UNFL ) )
ELSE IF( I.GT.1 ) THEN
IF( H( I+1, I ).EQ.ZERO .AND. H( I, I-1 ).EQ.
$ ZERO .AND. WI( I ).NE.ZERO )RESULT( 4+RSUB )
$ = ULPINV
END IF
160 CONTINUE
*
* Do Test (5) or Test (11)
*
CALL SLACPY( 'F', N, N, A, LDA, HT, LDA )
CALL SGEES( 'N', SORT, SSLECT, N, HT, LDA, SDIM, WRT,
$ WIT, VS, LDVS, WORK, NNWORK, BWORK,
$ IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 5+RSUB ) = ULPINV
WRITE( NOUNIT, FMT = 9992 )'SGEES2', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
GO TO 220
END IF
*
RESULT( 5+RSUB ) = ZERO
DO 180 J = 1, N
DO 170 I = 1, N
IF( H( I, J ).NE.HT( I, J ) )
$ RESULT( 5+RSUB ) = ULPINV
170 CONTINUE
180 CONTINUE
*
* Do Test (6) or Test (12)
*
RESULT( 6+RSUB ) = ZERO
DO 190 I = 1, N
IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
$ RESULT( 6+RSUB ) = ULPINV
190 CONTINUE
*
* Do Test (13)
*
IF( ISORT.EQ.1 ) THEN
RESULT( 13 ) = ZERO
KNTEIG = 0
DO 200 I = 1, N
IF( SSLECT( WR( I ), WI( I ) ) .OR.
$ SSLECT( WR( I ), -WI( I ) ) )
$ KNTEIG = KNTEIG + 1
IF( I.LT.N ) THEN
IF( ( SSLECT( WR( I+1 ),
$ WI( I+1 ) ) .OR. SSLECT( WR( I+1 ),
$ -WI( I+1 ) ) ) .AND.
$ ( .NOT.( SSLECT( WR( I ),
$ WI( I ) ) .OR. SSLECT( WR( I ),
$ -WI( I ) ) ) ) .AND. IINFO.NE.N+2 )
$ RESULT( 13 ) = ULPINV
END IF
200 CONTINUE
IF( SDIM.NE.KNTEIG ) THEN
RESULT( 13 ) = ULPINV
END IF
END IF
*
210 CONTINUE
*
* End of Loop -- Check for RESULT(j) > THRESH
*
220 CONTINUE
*
NTEST = 0
NFAIL = 0
DO 230 J = 1, 13
IF( RESULT( J ).GE.ZERO )
$ NTEST = NTEST + 1
IF( RESULT( J ).GE.THRESH )
$ NFAIL = NFAIL + 1
230 CONTINUE
*
IF( NFAIL.GT.0 )
$ NTESTF = NTESTF + 1
IF( NTESTF.EQ.1 ) THEN
WRITE( NOUNIT, FMT = 9999 )PATH
WRITE( NOUNIT, FMT = 9998 )
WRITE( NOUNIT, FMT = 9997 )
WRITE( NOUNIT, FMT = 9996 )
WRITE( NOUNIT, FMT = 9995 )THRESH
WRITE( NOUNIT, FMT = 9994 )
NTESTF = 2
END IF
*
DO 240 J = 1, 13
IF( RESULT( J ).GE.THRESH ) THEN
WRITE( NOUNIT, FMT = 9993 )N, IWK, IOLDSD, JTYPE,
$ J, RESULT( J )
END IF
240 CONTINUE
*
NERRS = NERRS + NFAIL
NTESTT = NTESTT + NTEST
*
250 CONTINUE
260 CONTINUE
270 CONTINUE
*
* Summary
*
CALL SLASUM( PATH, NOUNIT, NERRS, NTESTT )
*
9999 FORMAT( / 1X, A3, ' -- Real Schur Form Decomposition Driver',
$ / ' Matrix types (see SDRVES for details): ' )
*
9998 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ',
$ ' ', ' 5=Diagonal: geometr. spaced entries.',
$ / ' 2=Identity matrix. ', ' 6=Diagona',
$ 'l: clustered entries.', / ' 3=Transposed Jordan block. ',
$ ' ', ' 7=Diagonal: large, evenly spaced.', / ' ',
$ '4=Diagonal: evenly spaced entries. ', ' 8=Diagonal: s',
$ 'mall, evenly spaced.' )
9997 FORMAT( ' Dense, Non-Symmetric Matrices:', / ' 9=Well-cond., ev',
$ 'enly spaced eigenvals.', ' 14=Ill-cond., geomet. spaced e',
$ 'igenals.', / ' 10=Well-cond., geom. spaced eigenvals. ',
$ ' 15=Ill-conditioned, clustered e.vals.', / ' 11=Well-cond',
$ 'itioned, clustered e.vals. ', ' 16=Ill-cond., random comp',
$ 'lex ', / ' 12=Well-cond., random complex ', 6X, ' ',
$ ' 17=Ill-cond., large rand. complx ', / ' 13=Ill-condi',
$ 'tioned, evenly spaced. ', ' 18=Ill-cond., small rand.',
$ ' complx ' )
9996 FORMAT( ' 19=Matrix with random O(1) entries. ', ' 21=Matrix ',
$ 'with small random entries.', / ' 20=Matrix with large ran',
$ 'dom entries. ', / )
9995 FORMAT( ' Tests performed with test threshold =', F8.2,
$ / ' ( A denotes A on input and T denotes A on output)',
$ / / ' 1 = 0 if T in Schur form (no sort), ',
$ ' 1/ulp otherwise', /
$ ' 2 = | A - VS T transpose(VS) | / ( n |A| ulp ) (no sort)',
$ / ' 3 = | I - VS transpose(VS) | / ( n ulp ) (no sort) ', /
$ ' 4 = 0 if WR+sqrt(-1)*WI are eigenvalues of T (no sort),',
$ ' 1/ulp otherwise', /
$ ' 5 = 0 if T same no matter if VS computed (no sort),',
$ ' 1/ulp otherwise', /
$ ' 6 = 0 if WR, WI same no matter if VS computed (no sort)',
$ ', 1/ulp otherwise' )
9994 FORMAT( ' 7 = 0 if T in Schur form (sort), ', ' 1/ulp otherwise',
$ / ' 8 = | A - VS T transpose(VS) | / ( n |A| ulp ) (sort)',
$ / ' 9 = | I - VS transpose(VS) | / ( n ulp ) (sort) ',
$ / ' 10 = 0 if WR+sqrt(-1)*WI are eigenvalues of T (sort),',
$ ' 1/ulp otherwise', /
$ ' 11 = 0 if T same no matter if VS computed (sort),',
$ ' 1/ulp otherwise', /
$ ' 12 = 0 if WR, WI same no matter if VS computed (sort),',
$ ' 1/ulp otherwise', /
$ ' 13 = 0 if sorting succesful, 1/ulp otherwise', / )
9993 FORMAT( ' N=', I5, ', IWK=', I2, ', seed=', 4( I4, ',' ),
$ ' type ', I2, ', test(', I2, ')=', G10.3 )
9992 FORMAT( ' SDRVES: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
*
RETURN
*
* End of SDRVES
*
END
SUBROUTINE SDRVEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
$ NOUNIT, A, LDA, H, WR, WI, WR1, WI1, VL, LDVL,
$ VR, LDVR, LRE, LDLRE, RESULT, WORK, NWORK,
$ IWORK, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NOUNIT, NSIZES,
$ NTYPES, NWORK
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER ISEED( 4 ), IWORK( * ), NN( * )
REAL A( LDA, * ), H( LDA, * ), LRE( LDLRE, * ),
$ RESULT( 7 ), VL( LDVL, * ), VR( LDVR, * ),
$ WI( * ), WI1( * ), WORK( * ), WR( * ), WR1( * )
* ..
*
* Purpose
* =======
*
* SDRVEV checks the nonsymmetric eigenvalue problem driver SGEEV.
*
* When SDRVEV is called, a number of matrix "sizes" ("n's") and a
* number of matrix "types" are specified. For each size ("n")
* and each type of matrix, one matrix will be generated and used
* to test the nonsymmetric eigenroutines. For each matrix, 7
* tests will be performed:
*
* (1) | A * VR - VR * W | / ( n |A| ulp )
*
* Here VR is the matrix of unit right eigenvectors.
* W is a block diagonal matrix, with a 1x1 block for each
* real eigenvalue and a 2x2 block for each complex conjugate
* pair. If eigenvalues j and j+1 are a complex conjugate pair,
* so WR(j) = WR(j+1) = wr and WI(j) = - WI(j+1) = wi, then the
* 2 x 2 block corresponding to the pair will be:
*
* ( wr wi )
* ( -wi wr )
*
* Such a block multiplying an n x 2 matrix ( ur ui ) on the
* right will be the same as multiplying ur + i*ui by wr + i*wi.
*
* (2) | A**H * VL - VL * W**H | / ( n |A| ulp )
*
* Here VL is the matrix of unit left eigenvectors, A**H is the
* conjugate transpose of A, and W is as above.
*
* (3) | |VR(i)| - 1 | / ulp and whether largest component real
*
* VR(i) denotes the i-th column of VR.
*
* (4) | |VL(i)| - 1 | / ulp and whether largest component real
*
* VL(i) denotes the i-th column of VL.
*
* (5) W(full) = W(partial)
*
* W(full) denotes the eigenvalues computed when both VR and VL
* are also computed, and W(partial) denotes the eigenvalues
* computed when only W, only W and VR, or only W and VL are
* computed.
*
* (6) VR(full) = VR(partial)
*
* VR(full) denotes the right eigenvectors computed when both VR
* and VL are computed, and VR(partial) denotes the result
* when only VR is computed.
*
* (7) VL(full) = VL(partial)
*
* VL(full) denotes the left eigenvectors computed when both VR
* and VL are also computed, and VL(partial) denotes the result
* when only VL is computed.
*
* The "sizes" are specified by an array NN(1:NSIZES); the value of
* each element NN(j) specifies one size.
* The "types" are specified by a logical array DOTYPE( 1:NTYPES );
* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
* Currently, the list of possible types is:
*
* (1) The zero matrix.
* (2) The identity matrix.
* (3) A (transposed) Jordan block, with 1's on the diagonal.
*
* (4) A diagonal matrix with evenly spaced entries
* 1, ..., ULP and random signs.
* (ULP = (first number larger than 1) - 1 )
* (5) A diagonal matrix with geometrically spaced entries
* 1, ..., ULP and random signs.
* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
* and random signs.
*
* (7) Same as (4), but multiplied by a constant near
* the overflow threshold
* (8) Same as (4), but multiplied by a constant near
* the underflow threshold
*
* (9) A matrix of the form U' T U, where U is orthogonal and
* T has evenly spaced entries 1, ..., ULP with random signs
* on the diagonal and random O(1) entries in the upper
* triangle.
*
* (10) A matrix of the form U' T U, where U is orthogonal and
* T has geometrically spaced entries 1, ..., ULP with random
* signs on the diagonal and random O(1) entries in the upper
* triangle.
*
* (11) A matrix of the form U' T U, where U is orthogonal and
* T has "clustered" entries 1, ULP,..., ULP with random
* signs on the diagonal and random O(1) entries in the upper
* triangle.
*
* (12) A matrix of the form U' T U, where U is orthogonal and
* T has real or complex conjugate paired eigenvalues randomly
* chosen from ( ULP, 1 ) and random O(1) entries in the upper
* triangle.
*
* (13) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP
* with random signs on the diagonal and random O(1) entries
* in the upper triangle.
*
* (14) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has geometrically spaced entries
* 1, ..., ULP with random signs on the diagonal and random
* O(1) entries in the upper triangle.
*
* (15) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP
* with random signs on the diagonal and random O(1) entries
* in the upper triangle.
*
* (16) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has real or complex conjugate paired
* eigenvalues randomly chosen from ( ULP, 1 ) and random
* O(1) entries in the upper triangle.
*
* (17) Same as (16), but multiplied by a constant
* near the overflow threshold
* (18) Same as (16), but multiplied by a constant
* near the underflow threshold
*
* (19) Nonsymmetric matrix with random entries chosen from (-1,1).
* If N is at least 4, all entries in first two rows and last
* row, and first column and last two columns are zero.
* (20) Same as (19), but multiplied by a constant
* near the overflow threshold
* (21) Same as (19), but multiplied by a constant
* near the underflow threshold
*
* Arguments
* ==========
*
* NSIZES (input) INTEGER
* The number of sizes of matrices to use. If it is zero,
* SDRVEV does nothing. It must be at least zero.
*
* NN (input) INTEGER array, dimension (NSIZES)
* An array containing the sizes to be used for the matrices.
* Zero values will be skipped. The values must be at least
* zero.
*
* NTYPES (input) INTEGER
* The number of elements in DOTYPE. If it is zero, SDRVEV
* does nothing. It must be at least zero. If it is MAXTYP+1
* and NSIZES is 1, then an additional type, MAXTYP+1 is
* defined, which is to use whatever matrix is in A. This
* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
* DOTYPE(MAXTYP+1) is .TRUE. .
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* If DOTYPE(j) is .TRUE., then for each size in NN a
* matrix of that size and of type j will be generated.
* If NTYPES is smaller than the maximum number of types
* defined (PARAMETER MAXTYP), then types NTYPES+1 through
* MAXTYP will not be generated. If NTYPES is larger
* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
* will be ignored.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The array elements should be between 0 and 4095;
* if not they will be reduced mod 4096. Also, ISEED(4) must
* be odd. The random number generator uses a linear
* congruential sequence limited to small integers, and so
* should produce machine independent random numbers. The
* values of ISEED are changed on exit, and can be used in the
* next call to SDRVEV to continue the same random number
* sequence.
*
* THRESH (input) REAL
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error
* is scaled to be O(1), so THRESH should be a reasonably
* small multiple of 1, e.g., 10 or 100. In particular,
* it should not depend on the precision (single vs. double)
* or the size of the matrix. It must be at least zero.
*
* NOUNIT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns INFO not equal to 0.)
*
* A (workspace) REAL array, dimension (LDA, max(NN))
* Used to hold the matrix whose eigenvalues are to be
* computed. On exit, A contains the last matrix actually used.
*
* LDA (input) INTEGER
* The leading dimension of A, and H. LDA must be at
* least 1 and at least max(NN).
*
* H (workspace) REAL array, dimension (LDA, max(NN))
* Another copy of the test matrix A, modified by SGEEV.
*
* WR (workspace) REAL array, dimension (max(NN))
* WI (workspace) REAL array, dimension (max(NN))
* The real and imaginary parts of the eigenvalues of A.
* On exit, WR + WI*i are the eigenvalues of the matrix in A.
*
* WR1 (workspace) REAL array, dimension (max(NN))
* WI1 (workspace) REAL array, dimension (max(NN))
* Like WR, WI, these arrays contain the eigenvalues of A,
* but those computed when SGEEV only computes a partial
* eigendecomposition, i.e. not the eigenvalues and left
* and right eigenvectors.
*
* VL (workspace) REAL array, dimension (LDVL, max(NN))
* VL holds the computed left eigenvectors.
*
* LDVL (input) INTEGER
* Leading dimension of VL. Must be at least max(1,max(NN)).
*
* VR (workspace) REAL array, dimension (LDVR, max(NN))
* VR holds the computed right eigenvectors.
*
* LDVR (input) INTEGER
* Leading dimension of VR. Must be at least max(1,max(NN)).
*
* LRE (workspace) REAL array, dimension (LDLRE,max(NN))
* LRE holds the computed right or left eigenvectors.
*
* LDLRE (input) INTEGER
* Leading dimension of LRE. Must be at least max(1,max(NN)).
*
* RESULT (output) REAL array, dimension (7)
* The values computed by the seven tests described above.
* The values are currently limited to 1/ulp, to avoid overflow.
*
* WORK (workspace) REAL array, dimension (NWORK)
*
* NWORK (input) INTEGER
* The number of entries in WORK. This must be at least
* 5*NN(j)+2*NN(j)**2 for all j.
*
* IWORK (workspace) INTEGER array, dimension (max(NN))
*
* INFO (output) INTEGER
* If 0, then everything ran OK.
* -1: NSIZES < 0
* -2: Some NN(j) < 0
* -3: NTYPES < 0
* -6: THRESH < 0
* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
* -16: LDVL < 1 or LDVL < NMAX, where NMAX is max( NN(j) ).
* -18: LDVR < 1 or LDVR < NMAX, where NMAX is max( NN(j) ).
* -20: LDLRE < 1 or LDLRE < NMAX, where NMAX is max( NN(j) ).
* -23: NWORK too small.
* If SLATMR, SLATMS, SLATME or SGEEV returns an error code,
* the absolute value of it is returned.
*
*-----------------------------------------------------------------------
*
* Some Local Variables and Parameters:
* ---- ----- --------- --- ----------
*
* ZERO, ONE Real 0 and 1.
* MAXTYP The number of types defined.
* NMAX Largest value in NN.
* NERRS The number of tests which have exceeded THRESH
* COND, CONDS,
* IMODE Values to be passed to the matrix generators.
* ANORM Norm of A; passed to matrix generators.
*
* OVFL, UNFL Overflow and underflow thresholds.
* ULP, ULPINV Finest relative precision and its inverse.
* RTULP, RTULPI Square roots of the previous 4 values.
*
* The following four arrays decode JTYPE:
* KTYPE(j) The general type (1-10) for type "j".
* KMODE(j) The MODE value to be passed to the matrix
* generator for type "j".
* KMAGN(j) The order of magnitude ( O(1),
* O(overflow^(1/2) ), O(underflow^(1/2) )
* KCONDS(j) Selectw whether CONDS is to be 1 or
* 1/sqrt(ulp). (0 means irrelevant.)
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
REAL TWO
PARAMETER ( TWO = 2.0E0 )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 21 )
* ..
* .. Local Scalars ..
LOGICAL BADNN
CHARACTER*3 PATH
INTEGER IINFO, IMODE, ITYPE, IWK, J, JCOL, JJ, JSIZE,
$ JTYPE, MTYPES, N, NERRS, NFAIL, NMAX,
$ NNWORK, NTEST, NTESTF, NTESTT
REAL ANORM, COND, CONDS, OVFL, RTULP, RTULPI, TNRM,
$ ULP, ULPINV, UNFL, VMX, VRMX, VTST
* ..
* .. Local Arrays ..
CHARACTER ADUMMA( 1 )
INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( MAXTYP ),
$ KMAGN( MAXTYP ), KMODE( MAXTYP ),
$ KTYPE( MAXTYP )
REAL DUM( 1 ), RES( 2 )
* ..
* .. External Functions ..
REAL SLAMCH, SLAPY2, SNRM2
EXTERNAL SLAMCH, SLAPY2, SNRM2
* ..
* .. External Subroutines ..
EXTERNAL SGEEV, SGET22, SLABAD, SLACPY, SLASUM, SLATME,
$ SLATMR, SLATMS, SLASET, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Data statements ..
DATA KTYPE / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
DATA KMAGN / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
$ 3, 1, 2, 3 /
DATA KMODE / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
$ 1, 5, 5, 5, 4, 3, 1 /
DATA KCONDS / 3*0, 5*0, 4*1, 6*2, 3*0 /
* ..
* .. Executable Statements ..
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'EV'
*
* Check for errors
*
NTESTT = 0
NTESTF = 0
INFO = 0
*
* Important constants
*
BADNN = .FALSE.
NMAX = 0
DO 10 J = 1, NSIZES
NMAX = MAX( NMAX, NN( J ) )
IF( NN( J ).LT.0 )
$ BADNN = .TRUE.
10 CONTINUE
*
* Check for errors
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADNN ) THEN
INFO = -2
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -3
ELSE IF( THRESH.LT.ZERO ) THEN
INFO = -6
ELSE IF( NOUNIT.LE.0 ) THEN
INFO = -7
ELSE IF( LDA.LT.1 .OR. LDA.LT.NMAX ) THEN
INFO = -9
ELSE IF( LDVL.LT.1 .OR. LDVL.LT.NMAX ) THEN
INFO = -16
ELSE IF( LDVR.LT.1 .OR. LDVR.LT.NMAX ) THEN
INFO = -18
ELSE IF( LDLRE.LT.1 .OR. LDLRE.LT.NMAX ) THEN
INFO = -20
ELSE IF( 5*NMAX+2*NMAX**2.GT.NWORK ) THEN
INFO = -23
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SDRVEV', -INFO )
RETURN
END IF
*
* Quick return if nothing to do
*
IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
$ RETURN
*
* More Important constants
*
UNFL = SLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
CALL SLABAD( UNFL, OVFL )
ULP = SLAMCH( 'Precision' )
ULPINV = ONE / ULP
RTULP = SQRT( ULP )
RTULPI = ONE / RTULP
*
* Loop over sizes, types
*
NERRS = 0
*
DO 270 JSIZE = 1, NSIZES
N = NN( JSIZE )
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
DO 260 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 260
*
* Save ISEED in case of an error.
*
DO 20 J = 1, 4
IOLDSD( J ) = ISEED( J )
20 CONTINUE
*
* Compute "A"
*
* Control parameters:
*
* KMAGN KCONDS KMODE KTYPE
* =1 O(1) 1 clustered 1 zero
* =2 large large clustered 2 identity
* =3 small exponential Jordan
* =4 arithmetic diagonal, (w/ eigenvalues)
* =5 random log symmetric, w/ eigenvalues
* =6 random general, w/ eigenvalues
* =7 random diagonal
* =8 random symmetric
* =9 random general
* =10 random triangular
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 90
*
ITYPE = KTYPE( JTYPE )
IMODE = KMODE( JTYPE )
*
* Compute norm
*
GO TO ( 30, 40, 50 )KMAGN( JTYPE )
*
30 CONTINUE
ANORM = ONE
GO TO 60
*
40 CONTINUE
ANORM = OVFL*ULP
GO TO 60
*
50 CONTINUE
ANORM = UNFL*ULPINV
GO TO 60
*
60 CONTINUE
*
CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
IINFO = 0
COND = ULPINV
*
* Special Matrices -- Identity & Jordan block
*
* Zero
*
IF( ITYPE.EQ.1 ) THEN
IINFO = 0
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Identity
*
DO 70 JCOL = 1, N
A( JCOL, JCOL ) = ANORM
70 CONTINUE
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* Jordan Block
*
DO 80 JCOL = 1, N
A( JCOL, JCOL ) = ANORM
IF( JCOL.GT.1 )
$ A( JCOL, JCOL-1 ) = ONE
80 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Diagonal Matrix, [Eigen]values Specified
*
CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.5 ) THEN
*
* Symmetric, eigenvalues specified
*
CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, N, N, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.6 ) THEN
*
* General, eigenvalues specified
*
IF( KCONDS( JTYPE ).EQ.1 ) THEN
CONDS = ONE
ELSE IF( KCONDS( JTYPE ).EQ.2 ) THEN
CONDS = RTULPI
ELSE
CONDS = ZERO
END IF
*
ADUMMA( 1 ) = ' '
CALL SLATME( N, 'S', ISEED, WORK, IMODE, COND, ONE,
$ ADUMMA, 'T', 'T', 'T', WORK( N+1 ), 4,
$ CONDS, N, N, ANORM, A, LDA, WORK( 2*N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.7 ) THEN
*
* Diagonal, random eigenvalues
*
CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.8 ) THEN
*
* Symmetric, random eigenvalues
*
CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.9 ) THEN
*
* General, random eigenvalues
*
CALL SLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
IF( N.GE.4 ) THEN
CALL SLASET( 'Full', 2, N, ZERO, ZERO, A, LDA )
CALL SLASET( 'Full', N-3, 1, ZERO, ZERO, A( 3, 1 ),
$ LDA )
CALL SLASET( 'Full', N-3, 2, ZERO, ZERO, A( 3, N-1 ),
$ LDA )
CALL SLASET( 'Full', 1, N, ZERO, ZERO, A( N, 1 ),
$ LDA )
END IF
*
ELSE IF( ITYPE.EQ.10 ) THEN
*
* Triangular, random eigenvalues
*
CALL SLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, 0,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE
*
IINFO = 1
END IF
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9993 )'Generator', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
90 CONTINUE
*
* Test for minimal and generous workspace
*
DO 250 IWK = 1, 2
IF( IWK.EQ.1 ) THEN
NNWORK = 4*N
ELSE
NNWORK = 5*N + 2*N**2
END IF
NNWORK = MAX( NNWORK, 1 )
*
* Initialize RESULT
*
DO 100 J = 1, 7
RESULT( J ) = -ONE
100 CONTINUE
*
* Compute eigenvalues and eigenvectors, and test them
*
CALL SLACPY( 'F', N, N, A, LDA, H, LDA )
CALL SGEEV( 'V', 'V', N, H, LDA, WR, WI, VL, LDVL, VR,
$ LDVR, WORK, NNWORK, IINFO )
IF( IINFO.NE.0 ) THEN
RESULT( 1 ) = ULPINV
WRITE( NOUNIT, FMT = 9993 )'SGEEV1', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 220
END IF
*
* Do Test (1)
*
CALL SGET22( 'N', 'N', 'N', N, A, LDA, VR, LDVR, WR, WI,
$ WORK, RES )
RESULT( 1 ) = RES( 1 )
*
* Do Test (2)
*
CALL SGET22( 'T', 'N', 'T', N, A, LDA, VL, LDVL, WR, WI,
$ WORK, RES )
RESULT( 2 ) = RES( 1 )
*
* Do Test (3)
*
DO 120 J = 1, N
TNRM = ONE
IF( WI( J ).EQ.ZERO ) THEN
TNRM = SNRM2( N, VR( 1, J ), 1 )
ELSE IF( WI( J ).GT.ZERO ) THEN
TNRM = SLAPY2( SNRM2( N, VR( 1, J ), 1 ),
$ SNRM2( N, VR( 1, J+1 ), 1 ) )
END IF
RESULT( 3 ) = MAX( RESULT( 3 ),
$ MIN( ULPINV, ABS( TNRM-ONE ) / ULP ) )
IF( WI( J ).GT.ZERO ) THEN
VMX = ZERO
VRMX = ZERO
DO 110 JJ = 1, N
VTST = SLAPY2( VR( JJ, J ), VR( JJ, J+1 ) )
IF( VTST.GT.VMX )
$ VMX = VTST
IF( VR( JJ, J+1 ).EQ.ZERO .AND.
$ ABS( VR( JJ, J ) ).GT.VRMX )
$ VRMX = ABS( VR( JJ, J ) )
110 CONTINUE
IF( VRMX / VMX.LT.ONE-TWO*ULP )
$ RESULT( 3 ) = ULPINV
END IF
120 CONTINUE
*
* Do Test (4)
*
DO 140 J = 1, N
TNRM = ONE
IF( WI( J ).EQ.ZERO ) THEN
TNRM = SNRM2( N, VL( 1, J ), 1 )
ELSE IF( WI( J ).GT.ZERO ) THEN
TNRM = SLAPY2( SNRM2( N, VL( 1, J ), 1 ),
$ SNRM2( N, VL( 1, J+1 ), 1 ) )
END IF
RESULT( 4 ) = MAX( RESULT( 4 ),
$ MIN( ULPINV, ABS( TNRM-ONE ) / ULP ) )
IF( WI( J ).GT.ZERO ) THEN
VMX = ZERO
VRMX = ZERO
DO 130 JJ = 1, N
VTST = SLAPY2( VL( JJ, J ), VL( JJ, J+1 ) )
IF( VTST.GT.VMX )
$ VMX = VTST
IF( VL( JJ, J+1 ).EQ.ZERO .AND.
$ ABS( VL( JJ, J ) ).GT.VRMX )
$ VRMX = ABS( VL( JJ, J ) )
130 CONTINUE
IF( VRMX / VMX.LT.ONE-TWO*ULP )
$ RESULT( 4 ) = ULPINV
END IF
140 CONTINUE
*
* Compute eigenvalues only, and test them
*
CALL SLACPY( 'F', N, N, A, LDA, H, LDA )
CALL SGEEV( 'N', 'N', N, H, LDA, WR1, WI1, DUM, 1, DUM,
$ 1, WORK, NNWORK, IINFO )
IF( IINFO.NE.0 ) THEN
RESULT( 1 ) = ULPINV
WRITE( NOUNIT, FMT = 9993 )'SGEEV2', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 220
END IF
*
* Do Test (5)
*
DO 150 J = 1, N
IF( WR( J ).NE.WR1( J ) .OR. WI( J ).NE.WI1( J ) )
$ RESULT( 5 ) = ULPINV
150 CONTINUE
*
* Compute eigenvalues and right eigenvectors, and test them
*
CALL SLACPY( 'F', N, N, A, LDA, H, LDA )
CALL SGEEV( 'N', 'V', N, H, LDA, WR1, WI1, DUM, 1, LRE,
$ LDLRE, WORK, NNWORK, IINFO )
IF( IINFO.NE.0 ) THEN
RESULT( 1 ) = ULPINV
WRITE( NOUNIT, FMT = 9993 )'SGEEV3', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 220
END IF
*
* Do Test (5) again
*
DO 160 J = 1, N
IF( WR( J ).NE.WR1( J ) .OR. WI( J ).NE.WI1( J ) )
$ RESULT( 5 ) = ULPINV
160 CONTINUE
*
* Do Test (6)
*
DO 180 J = 1, N
DO 170 JJ = 1, N
IF( VR( J, JJ ).NE.LRE( J, JJ ) )
$ RESULT( 6 ) = ULPINV
170 CONTINUE
180 CONTINUE
*
* Compute eigenvalues and left eigenvectors, and test them
*
CALL SLACPY( 'F', N, N, A, LDA, H, LDA )
CALL SGEEV( 'V', 'N', N, H, LDA, WR1, WI1, LRE, LDLRE,
$ DUM, 1, WORK, NNWORK, IINFO )
IF( IINFO.NE.0 ) THEN
RESULT( 1 ) = ULPINV
WRITE( NOUNIT, FMT = 9993 )'SGEEV4', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 220
END IF
*
* Do Test (5) again
*
DO 190 J = 1, N
IF( WR( J ).NE.WR1( J ) .OR. WI( J ).NE.WI1( J ) )
$ RESULT( 5 ) = ULPINV
190 CONTINUE
*
* Do Test (7)
*
DO 210 J = 1, N
DO 200 JJ = 1, N
IF( VL( J, JJ ).NE.LRE( J, JJ ) )
$ RESULT( 7 ) = ULPINV
200 CONTINUE
210 CONTINUE
*
* End of Loop -- Check for RESULT(j) > THRESH
*
220 CONTINUE
*
NTEST = 0
NFAIL = 0
DO 230 J = 1, 7
IF( RESULT( J ).GE.ZERO )
$ NTEST = NTEST + 1
IF( RESULT( J ).GE.THRESH )
$ NFAIL = NFAIL + 1
230 CONTINUE
*
IF( NFAIL.GT.0 )
$ NTESTF = NTESTF + 1
IF( NTESTF.EQ.1 ) THEN
WRITE( NOUNIT, FMT = 9999 )PATH
WRITE( NOUNIT, FMT = 9998 )
WRITE( NOUNIT, FMT = 9997 )
WRITE( NOUNIT, FMT = 9996 )
WRITE( NOUNIT, FMT = 9995 )THRESH
NTESTF = 2
END IF
*
DO 240 J = 1, 7
IF( RESULT( J ).GE.THRESH ) THEN
WRITE( NOUNIT, FMT = 9994 )N, IWK, IOLDSD, JTYPE,
$ J, RESULT( J )
END IF
240 CONTINUE
*
NERRS = NERRS + NFAIL
NTESTT = NTESTT + NTEST
*
250 CONTINUE
260 CONTINUE
270 CONTINUE
*
* Summary
*
CALL SLASUM( PATH, NOUNIT, NERRS, NTESTT )
*
9999 FORMAT( / 1X, A3, ' -- Real Eigenvalue-Eigenvector Decomposition',
$ ' Driver', / ' Matrix types (see SDRVEV for details): ' )
*
9998 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ',
$ ' ', ' 5=Diagonal: geometr. spaced entries.',
$ / ' 2=Identity matrix. ', ' 6=Diagona',
$ 'l: clustered entries.', / ' 3=Transposed Jordan block. ',
$ ' ', ' 7=Diagonal: large, evenly spaced.', / ' ',
$ '4=Diagonal: evenly spaced entries. ', ' 8=Diagonal: s',
$ 'mall, evenly spaced.' )
9997 FORMAT( ' Dense, Non-Symmetric Matrices:', / ' 9=Well-cond., ev',
$ 'enly spaced eigenvals.', ' 14=Ill-cond., geomet. spaced e',
$ 'igenals.', / ' 10=Well-cond., geom. spaced eigenvals. ',
$ ' 15=Ill-conditioned, clustered e.vals.', / ' 11=Well-cond',
$ 'itioned, clustered e.vals. ', ' 16=Ill-cond., random comp',
$ 'lex ', / ' 12=Well-cond., random complex ', 6X, ' ',
$ ' 17=Ill-cond., large rand. complx ', / ' 13=Ill-condi',
$ 'tioned, evenly spaced. ', ' 18=Ill-cond., small rand.',
$ ' complx ' )
9996 FORMAT( ' 19=Matrix with random O(1) entries. ', ' 21=Matrix ',
$ 'with small random entries.', / ' 20=Matrix with large ran',
$ 'dom entries. ', / )
9995 FORMAT( ' Tests performed with test threshold =', F8.2,
$ / / ' 1 = | A VR - VR W | / ( n |A| ulp ) ',
$ / ' 2 = | transpose(A) VL - VL W | / ( n |A| ulp ) ',
$ / ' 3 = | |VR(i)| - 1 | / ulp ',
$ / ' 4 = | |VL(i)| - 1 | / ulp ',
$ / ' 5 = 0 if W same no matter if VR or VL computed,',
$ ' 1/ulp otherwise', /
$ ' 6 = 0 if VR same no matter if VL computed,',
$ ' 1/ulp otherwise', /
$ ' 7 = 0 if VL same no matter if VR computed,',
$ ' 1/ulp otherwise', / )
9994 FORMAT( ' N=', I5, ', IWK=', I2, ', seed=', 4( I4, ',' ),
$ ' type ', I2, ', test(', I2, ')=', G10.3 )
9993 FORMAT( ' SDRVEV: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
*
RETURN
*
* End of SDRVEV
*
END
SUBROUTINE SDRVGG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
$ THRSHN, NOUNIT, A, LDA, B, S, T, S2, T2, Q,
$ LDQ, Z, ALPHR1, ALPHI1, BETA1, ALPHR2, ALPHI2,
$ BETA2, VL, VR, WORK, LWORK, RESULT, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES
REAL THRESH, THRSHN
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER ISEED( 4 ), NN( * )
REAL A( LDA, * ), ALPHI1( * ), ALPHI2( * ),
$ ALPHR1( * ), ALPHR2( * ), B( LDA, * ),
$ BETA1( * ), BETA2( * ), Q( LDQ, * ),
$ RESULT( * ), S( LDA, * ), S2( LDA, * ),
$ T( LDA, * ), T2( LDA, * ), VL( LDQ, * ),
$ VR( LDQ, * ), WORK( * ), Z( LDQ, * )
* ..
*
* Purpose
* =======
*
* SDRVGG checks the nonsymmetric generalized eigenvalue driver
* routines.
* T T T
* SGEGS factors A and B as Q S Z and Q T Z , where means
* transpose, T is upper triangular, S is in generalized Schur form
* (block upper triangular, with 1x1 and 2x2 blocks on the diagonal,
* the 2x2 blocks corresponding to complex conjugate pairs of
* generalized eigenvalues), and Q and Z are orthogonal. It also
* computes the generalized eigenvalues (alpha(1),beta(1)), ...,
* (alpha(n),beta(n)), where alpha(j)=S(j,j) and beta(j)=P(j,j) --
* thus, w(j) = alpha(j)/beta(j) is a root of the generalized
* eigenvalue problem
*
* det( A - w(j) B ) = 0
*
* and m(j) = beta(j)/alpha(j) is a root of the essentially equivalent
* problem
*
* det( m(j) A - B ) = 0
*
* SGEGV computes the generalized eigenvalues (alpha(1),beta(1)), ...,
* (alpha(n),beta(n)), the matrix L whose columns contain the
* generalized left eigenvectors l, and the matrix R whose columns
* contain the generalized right eigenvectors r for the pair (A,B).
*
* When SDRVGG is called, a number of matrix "sizes" ("n's") and a
* number of matrix "types" are specified. For each size ("n")
* and each type of matrix, one matrix will be generated and used
* to test the nonsymmetric eigenroutines. For each matrix, 7
* tests will be performed and compared with the threshhold THRESH:
*
* Results from SGEGS:
*
* T
* (1) | A - Q S Z | / ( |A| n ulp )
*
* T
* (2) | B - Q T Z | / ( |B| n ulp )
*
* T
* (3) | I - QQ | / ( n ulp )
*
* T
* (4) | I - ZZ | / ( n ulp )
*
* (5) maximum over j of D(j) where:
*
* if alpha(j) is real:
* |alpha(j) - S(j,j)| |beta(j) - T(j,j)|
* D(j) = ------------------------ + -----------------------
* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|)
*
* if alpha(j) is complex:
* | det( s S - w T ) |
* D(j) = ---------------------------------------------------
* ulp max( s norm(S), |w| norm(T) )*norm( s S - w T )
*
* and S and T are here the 2 x 2 diagonal blocks of S and T
* corresponding to the j-th eigenvalue.
*
* Results from SGEGV:
*
* (6) max over all left eigenvalue/-vector pairs (beta/alpha,l) of
*
* | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) )
*
* where l**H is the conjugate tranpose of l.
*
* (7) max over all right eigenvalue/-vector pairs (beta/alpha,r) of
*
* | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) )
*
* Test Matrices
* ---- --------
*
* The sizes of the test matrices are specified by an array
* NN(1:NSIZES); the value of each element NN(j) specifies one size.
* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if
* DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
* Currently, the list of possible types is:
*
* (1) ( 0, 0 ) (a pair of zero matrices)
*
* (2) ( I, 0 ) (an identity and a zero matrix)
*
* (3) ( 0, I ) (an identity and a zero matrix)
*
* (4) ( I, I ) (a pair of identity matrices)
*
* t t
* (5) ( J , J ) (a pair of transposed Jordan blocks)
*
* t ( I 0 )
* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t )
* ( 0 I ) ( 0 J )
* and I is a k x k identity and J a (k+1)x(k+1)
* Jordan block; k=(N-1)/2
*
* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal
* matrix with those diagonal entries.)
* (8) ( I, D )
*
* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big
*
* (10) ( small*D, big*I )
*
* (11) ( big*I, small*D )
*
* (12) ( small*I, big*D )
*
* (13) ( big*D, big*I )
*
* (14) ( small*D, small*I )
*
* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and
* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 )
* t t
* (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices.
*
* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices
* with random O(1) entries above the diagonal
* and diagonal entries diag(T1) =
* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) =
* ( 0, N-3, N-4,..., 1, 0, 0 )
*
* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 )
* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 )
* s = machine precision.
*
* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 )
* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 )
*
* N-5
* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 )
* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
*
* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 )
* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
* where r1,..., r(N-4) are random.
*
* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular
* matrices.
*
* Arguments
* =========
*
* NSIZES (input) INTEGER
* The number of sizes of matrices to use. If it is zero,
* SDRVGG does nothing. It must be at least zero.
*
* NN (input) INTEGER array, dimension (NSIZES)
* An array containing the sizes to be used for the matrices.
* Zero values will be skipped. The values must be at least
* zero.
*
* NTYPES (input) INTEGER
* The number of elements in DOTYPE. If it is zero, SDRVGG
* does nothing. It must be at least zero. If it is MAXTYP+1
* and NSIZES is 1, then an additional type, MAXTYP+1 is
* defined, which is to use whatever matrix is in A. This
* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
* DOTYPE(MAXTYP+1) is .TRUE. .
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* If DOTYPE(j) is .TRUE., then for each size in NN a
* matrix of that size and of type j will be generated.
* If NTYPES is smaller than the maximum number of types
* defined (PARAMETER MAXTYP), then types NTYPES+1 through
* MAXTYP will not be generated. If NTYPES is larger
* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
* will be ignored.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The array elements should be between 0 and 4095;
* if not they will be reduced mod 4096. Also, ISEED(4) must
* be odd. The random number generator uses a linear
* congruential sequence limited to small integers, and so
* should produce machine independent random numbers. The
* values of ISEED are changed on exit, and can be used in the
* next call to SDRVGG to continue the same random number
* sequence.
*
* THRESH (input) REAL
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error is
* scaled to be O(1), so THRESH should be a reasonably small
* multiple of 1, e.g., 10 or 100. In particular, it should
* not depend on the precision (single vs. double) or the size
* of the matrix. It must be at least zero.
*
* THRSHN (input) REAL
* Threshhold for reporting eigenvector normalization error.
* If the normalization of any eigenvector differs from 1 by
* more than THRSHN*ulp, then a special error message will be
* printed. (This is handled separately from the other tests,
* since only a compiler or programming error should cause an
* error message, at least if THRSHN is at least 5--10.)
*
* NOUNIT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns IINFO not equal to 0.)
*
* A (input/workspace) REAL array, dimension
* (LDA, max(NN))
* Used to hold the original A matrix. Used as input only
* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
* DOTYPE(MAXTYP+1)=.TRUE.
*
* LDA (input) INTEGER
* The leading dimension of A, B, S, T, S2, and T2.
* It must be at least 1 and at least max( NN ).
*
* B (input/workspace) REAL array, dimension
* (LDA, max(NN))
* Used to hold the original B matrix. Used as input only
* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
* DOTYPE(MAXTYP+1)=.TRUE.
*
* S (workspace) REAL array, dimension (LDA, max(NN))
* The Schur form matrix computed from A by SGEGS. On exit, S
* contains the Schur form matrix corresponding to the matrix
* in A.
*
* T (workspace) REAL array, dimension (LDA, max(NN))
* The upper triangular matrix computed from B by SGEGS.
*
* S2 (workspace) REAL array, dimension (LDA, max(NN))
* The matrix computed from A by SGEGV. This will be the
* Schur form of some matrix related to A, but will not, in
* general, be the same as S.
*
* T2 (workspace) REAL array, dimension (LDA, max(NN))
* The matrix computed from B by SGEGV. This will be the
* Schur form of some matrix related to B, but will not, in
* general, be the same as T.
*
* Q (workspace) REAL array, dimension (LDQ, max(NN))
* The (left) orthogonal matrix computed by SGEGS.
*
* LDQ (input) INTEGER
* The leading dimension of Q, Z, VL, and VR. It must
* be at least 1 and at least max( NN ).
*
* Z (workspace) REAL array of
* dimension( LDQ, max(NN) )
* The (right) orthogonal matrix computed by SGEGS.
*
* ALPHR1 (workspace) REAL array, dimension (max(NN))
* ALPHI1 (workspace) REAL array, dimension (max(NN))
* BETA1 (workspace) REAL array, dimension (max(NN))
*
* The generalized eigenvalues of (A,B) computed by SGEGS.
* ( ALPHR1(k)+ALPHI1(k)*i ) / BETA1(k) is the k-th
* generalized eigenvalue of the matrices in A and B.
*
* ALPHR2 (workspace) REAL array, dimension (max(NN))
* ALPHI2 (workspace) REAL array, dimension (max(NN))
* BETA2 (workspace) REAL array, dimension (max(NN))
*
* The generalized eigenvalues of (A,B) computed by SGEGV.
* ( ALPHR2(k)+ALPHI2(k)*i ) / BETA2(k) is the k-th
* generalized eigenvalue of the matrices in A and B.
*
* VL (workspace) REAL array, dimension (LDQ, max(NN))
* The (block lower triangular) left eigenvector matrix for
* the matrices in A and B. (See STGEVC for the format.)
*
* VR (workspace) REAL array, dimension (LDQ, max(NN))
* The (block upper triangular) right eigenvector matrix for
* the matrices in A and B. (See STGEVC for the format.)
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The number of entries in WORK. This must be at least
* 2*N + MAX( 6*N, N*(NB+1), (k+1)*(2*k+N+1) ), where
* "k" is the sum of the blocksize and number-of-shifts for
* SHGEQZ, and NB is the greatest of the blocksizes for
* SGEQRF, SORMQR, and SORGQR. (The blocksizes and the
* number-of-shifts are retrieved through calls to ILAENV.)
*
* RESULT (output) REAL array, dimension (15)
* The values computed by the tests described above.
* The values are currently limited to 1/ulp, to avoid
* overflow.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: A routine returned an error code. INFO is the
* absolute value of the INFO value returned.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0, ONE = 1.0 )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 26 )
* ..
* .. Local Scalars ..
LOGICAL BADNN, ILABAD
INTEGER I1, IADD, IINFO, IN, J, JC, JR, JSIZE, JTYPE,
$ LWKOPT, MTYPES, N, N1, NB, NBZ, NERRS, NMATS,
$ NMAX, NS, NTEST, NTESTT
REAL SAFMAX, SAFMIN, TEMP1, TEMP2, ULP, ULPINV
* ..
* .. Local Arrays ..
INTEGER IASIGN( MAXTYP ), IBSIGN( MAXTYP ),
$ IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ),
$ KATYPE( MAXTYP ), KAZERO( MAXTYP ),
$ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ),
$ KBZERO( MAXTYP ), KCLASS( MAXTYP ),
$ KTRIAN( MAXTYP ), KZ1( 6 ), KZ2( 6 )
REAL DUMMA( 4 ), RMAGN( 0: 3 )
* ..
* .. External Functions ..
INTEGER ILAENV
REAL SLAMCH, SLARND
EXTERNAL ILAENV, SLAMCH, SLARND
* ..
* .. External Subroutines ..
EXTERNAL ALASVM, SGEGS, SGEGV, SGET51, SGET52, SGET53,
$ SLABAD, SLACPY, SLARFG, SLASET, SLATM4, SORM2R,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL, SIGN
* ..
* .. Data statements ..
DATA KCLASS / 15*1, 10*2, 1*3 /
DATA KZ1 / 0, 1, 2, 1, 3, 3 /
DATA KZ2 / 0, 0, 1, 2, 1, 1 /
DATA KADD / 0, 0, 0, 0, 3, 2 /
DATA KATYPE / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4,
$ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 /
DATA KBTYPE / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4,
$ 1, 1, -4, 2, -4, 8*8, 0 /
DATA KAZERO / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3,
$ 4*5, 4*3, 1 /
DATA KBZERO / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4,
$ 4*6, 4*4, 1 /
DATA KAMAGN / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3,
$ 2, 1 /
DATA KBMAGN / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3,
$ 2, 1 /
DATA KTRIAN / 16*0, 10*1 /
DATA IASIGN / 6*0, 2, 0, 2*2, 2*0, 3*2, 0, 2, 3*0,
$ 5*2, 0 /
DATA IBSIGN / 7*0, 2, 2*0, 2*2, 2*0, 2, 0, 2, 9*0 /
* ..
* .. Executable Statements ..
*
* Check for errors
*
INFO = 0
*
BADNN = .FALSE.
NMAX = 1
DO 10 J = 1, NSIZES
NMAX = MAX( NMAX, NN( J ) )
IF( NN( J ).LT.0 )
$ BADNN = .TRUE.
10 CONTINUE
*
* Maximum blocksize and shift -- we assume that blocksize and number
* of shifts are monotone increasing functions of N.
*
NB = MAX( 1, ILAENV( 1, 'SGEQRF', ' ', NMAX, NMAX, -1, -1 ),
$ ILAENV( 1, 'SORMQR', 'LT', NMAX, NMAX, NMAX, -1 ),
$ ILAENV( 1, 'SORGQR', ' ', NMAX, NMAX, NMAX, -1 ) )
NBZ = ILAENV( 1, 'SHGEQZ', 'SII', NMAX, 1, NMAX, 0 )
NS = ILAENV( 4, 'SHGEQZ', 'SII', NMAX, 1, NMAX, 0 )
I1 = NBZ + NS
LWKOPT = 2*NMAX + MAX( 6*NMAX, NMAX*( NB+1 ),
$ ( 2*I1+NMAX+1 )*( I1+1 ) )
*
* Check for errors
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADNN ) THEN
INFO = -2
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -3
ELSE IF( THRESH.LT.ZERO ) THEN
INFO = -6
ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN
INFO = -10
ELSE IF( LDQ.LE.1 .OR. LDQ.LT.NMAX ) THEN
INFO = -19
ELSE IF( LWKOPT.GT.LWORK ) THEN
INFO = -30
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SDRVGG', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
$ RETURN
*
SAFMIN = SLAMCH( 'Safe minimum' )
ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
SAFMIN = SAFMIN / ULP
SAFMAX = ONE / SAFMIN
CALL SLABAD( SAFMIN, SAFMAX )
ULPINV = ONE / ULP
*
* The values RMAGN(2:3) depend on N, see below.
*
RMAGN( 0 ) = ZERO
RMAGN( 1 ) = ONE
*
* Loop over sizes, types
*
NTESTT = 0
NERRS = 0
NMATS = 0
*
DO 170 JSIZE = 1, NSIZES
N = NN( JSIZE )
N1 = MAX( 1, N )
RMAGN( 2 ) = SAFMAX*ULP / REAL( N1 )
RMAGN( 3 ) = SAFMIN*ULPINV*N1
*
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
DO 160 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 160
NMATS = NMATS + 1
NTEST = 0
*
* Save ISEED in case of an error.
*
DO 20 J = 1, 4
IOLDSD( J ) = ISEED( J )
20 CONTINUE
*
* Initialize RESULT
*
DO 30 J = 1, 15
RESULT( J ) = ZERO
30 CONTINUE
*
* Compute A and B
*
* Description of control parameters:
*
* KCLASS: =1 means w/o rotation, =2 means w/ rotation,
* =3 means random.
* KATYPE: the "type" to be passed to SLATM4 for computing A.
* KAZERO: the pattern of zeros on the diagonal for A:
* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ),
* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ),
* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of
* non-zero entries.)
* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1),
* =2: large, =3: small.
* IASIGN: 1 if the diagonal elements of A are to be
* multiplied by a random magnitude 1 number, =2 if
* randomly chosen diagonal blocks are to be rotated
* to form 2x2 blocks.
* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B.
* KTRIAN: =0: don't fill in the upper triangle, =1: do.
* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO.
* RMAGN: used to implement KAMAGN and KBMAGN.
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 110
IINFO = 0
IF( KCLASS( JTYPE ).LT.3 ) THEN
*
* Generate A (w/o rotation)
*
IF( ABS( KATYPE( JTYPE ) ).EQ.3 ) THEN
IN = 2*( ( N-1 ) / 2 ) + 1
IF( IN.NE.N )
$ CALL SLASET( 'Full', N, N, ZERO, ZERO, A, LDA )
ELSE
IN = N
END IF
CALL SLATM4( KATYPE( JTYPE ), IN, KZ1( KAZERO( JTYPE ) ),
$ KZ2( KAZERO( JTYPE ) ), IASIGN( JTYPE ),
$ RMAGN( KAMAGN( JTYPE ) ), ULP,
$ RMAGN( KTRIAN( JTYPE )*KAMAGN( JTYPE ) ), 2,
$ ISEED, A, LDA )
IADD = KADD( KAZERO( JTYPE ) )
IF( IADD.GT.0 .AND. IADD.LE.N )
$ A( IADD, IADD ) = ONE
*
* Generate B (w/o rotation)
*
IF( ABS( KBTYPE( JTYPE ) ).EQ.3 ) THEN
IN = 2*( ( N-1 ) / 2 ) + 1
IF( IN.NE.N )
$ CALL SLASET( 'Full', N, N, ZERO, ZERO, B, LDA )
ELSE
IN = N
END IF
CALL SLATM4( KBTYPE( JTYPE ), IN, KZ1( KBZERO( JTYPE ) ),
$ KZ2( KBZERO( JTYPE ) ), IBSIGN( JTYPE ),
$ RMAGN( KBMAGN( JTYPE ) ), ONE,
$ RMAGN( KTRIAN( JTYPE )*KBMAGN( JTYPE ) ), 2,
$ ISEED, B, LDA )
IADD = KADD( KBZERO( JTYPE ) )
IF( IADD.NE.0 .AND. IADD.LE.N )
$ B( IADD, IADD ) = ONE
*
IF( KCLASS( JTYPE ).EQ.2 .AND. N.GT.0 ) THEN
*
* Include rotations
*
* Generate Q, Z as Householder transformations times
* a diagonal matrix.
*
DO 50 JC = 1, N - 1
DO 40 JR = JC, N
Q( JR, JC ) = SLARND( 3, ISEED )
Z( JR, JC ) = SLARND( 3, ISEED )
40 CONTINUE
CALL SLARFG( N+1-JC, Q( JC, JC ), Q( JC+1, JC ), 1,
$ WORK( JC ) )
WORK( 2*N+JC ) = SIGN( ONE, Q( JC, JC ) )
Q( JC, JC ) = ONE
CALL SLARFG( N+1-JC, Z( JC, JC ), Z( JC+1, JC ), 1,
$ WORK( N+JC ) )
WORK( 3*N+JC ) = SIGN( ONE, Z( JC, JC ) )
Z( JC, JC ) = ONE
50 CONTINUE
Q( N, N ) = ONE
WORK( N ) = ZERO
WORK( 3*N ) = SIGN( ONE, SLARND( 2, ISEED ) )
Z( N, N ) = ONE
WORK( 2*N ) = ZERO
WORK( 4*N ) = SIGN( ONE, SLARND( 2, ISEED ) )
*
* Apply the diagonal matrices
*
DO 70 JC = 1, N
DO 60 JR = 1, N
A( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
$ A( JR, JC )
B( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
$ B( JR, JC )
60 CONTINUE
70 CONTINUE
CALL SORM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, A,
$ LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
CALL SORM2R( 'R', 'T', N, N, N-1, Z, LDQ, WORK( N+1 ),
$ A, LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
CALL SORM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, B,
$ LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
CALL SORM2R( 'R', 'T', N, N, N-1, Z, LDQ, WORK( N+1 ),
$ B, LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
END IF
ELSE
*
* Random matrices
*
DO 90 JC = 1, N
DO 80 JR = 1, N
A( JR, JC ) = RMAGN( KAMAGN( JTYPE ) )*
$ SLARND( 2, ISEED )
B( JR, JC ) = RMAGN( KBMAGN( JTYPE ) )*
$ SLARND( 2, ISEED )
80 CONTINUE
90 CONTINUE
END IF
*
100 CONTINUE
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
110 CONTINUE
*
* Call SGEGS to compute H, T, Q, Z, alpha, and beta.
*
CALL SLACPY( ' ', N, N, A, LDA, S, LDA )
CALL SLACPY( ' ', N, N, B, LDA, T, LDA )
NTEST = 1
RESULT( 1 ) = ULPINV
*
CALL SGEGS( 'V', 'V', N, S, LDA, T, LDA, ALPHR1, ALPHI1,
$ BETA1, Q, LDQ, Z, LDQ, WORK, LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SGEGS', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 140
END IF
*
NTEST = 4
*
* Do tests 1--4
*
CALL SGET51( 1, N, A, LDA, S, LDA, Q, LDQ, Z, LDQ, WORK,
$ RESULT( 1 ) )
CALL SGET51( 1, N, B, LDA, T, LDA, Q, LDQ, Z, LDQ, WORK,
$ RESULT( 2 ) )
CALL SGET51( 3, N, B, LDA, T, LDA, Q, LDQ, Q, LDQ, WORK,
$ RESULT( 3 ) )
CALL SGET51( 3, N, B, LDA, T, LDA, Z, LDQ, Z, LDQ, WORK,
$ RESULT( 4 ) )
*
* Do test 5: compare eigenvalues with diagonals.
* Also check Schur form of A.
*
TEMP1 = ZERO
*
DO 120 J = 1, N
ILABAD = .FALSE.
IF( ALPHI1( J ).EQ.ZERO ) THEN
TEMP2 = ( ABS( ALPHR1( J )-S( J, J ) ) /
$ MAX( SAFMIN, ABS( ALPHR1( J ) ), ABS( S( J,
$ J ) ) )+ABS( BETA1( J )-T( J, J ) ) /
$ MAX( SAFMIN, ABS( BETA1( J ) ), ABS( T( J,
$ J ) ) ) ) / ULP
IF( J.LT.N ) THEN
IF( S( J+1, J ).NE.ZERO )
$ ILABAD = .TRUE.
END IF
IF( J.GT.1 ) THEN
IF( S( J, J-1 ).NE.ZERO )
$ ILABAD = .TRUE.
END IF
ELSE
IF( ALPHI1( J ).GT.ZERO ) THEN
I1 = J
ELSE
I1 = J - 1
END IF
IF( I1.LE.0 .OR. I1.GE.N ) THEN
ILABAD = .TRUE.
ELSE IF( I1.LT.N-1 ) THEN
IF( S( I1+2, I1+1 ).NE.ZERO )
$ ILABAD = .TRUE.
ELSE IF( I1.GT.1 ) THEN
IF( S( I1, I1-1 ).NE.ZERO )
$ ILABAD = .TRUE.
END IF
IF( .NOT.ILABAD ) THEN
CALL SGET53( S( I1, I1 ), LDA, T( I1, I1 ), LDA,
$ BETA1( J ), ALPHR1( J ), ALPHI1( J ),
$ TEMP2, IINFO )
IF( IINFO.GE.3 ) THEN
WRITE( NOUNIT, FMT = 9997 )IINFO, J, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
END IF
ELSE
TEMP2 = ULPINV
END IF
END IF
TEMP1 = MAX( TEMP1, TEMP2 )
IF( ILABAD ) THEN
WRITE( NOUNIT, FMT = 9996 )J, N, JTYPE, IOLDSD
END IF
120 CONTINUE
RESULT( 5 ) = TEMP1
*
* Call SGEGV to compute S2, T2, VL, and VR, do tests.
*
* Eigenvalues and Eigenvectors
*
CALL SLACPY( ' ', N, N, A, LDA, S2, LDA )
CALL SLACPY( ' ', N, N, B, LDA, T2, LDA )
NTEST = 6
RESULT( 6 ) = ULPINV
*
CALL SGEGV( 'V', 'V', N, S2, LDA, T2, LDA, ALPHR2, ALPHI2,
$ BETA2, VL, LDQ, VR, LDQ, WORK, LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SGEGV', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 140
END IF
*
NTEST = 7
*
* Do Tests 6 and 7
*
CALL SGET52( .TRUE., N, A, LDA, B, LDA, VL, LDQ, ALPHR2,
$ ALPHI2, BETA2, WORK, DUMMA( 1 ) )
RESULT( 6 ) = DUMMA( 1 )
IF( DUMMA( 2 ).GT.THRSHN ) THEN
WRITE( NOUNIT, FMT = 9998 )'Left', 'SGEGV', DUMMA( 2 ),
$ N, JTYPE, IOLDSD
END IF
*
CALL SGET52( .FALSE., N, A, LDA, B, LDA, VR, LDQ, ALPHR2,
$ ALPHI2, BETA2, WORK, DUMMA( 1 ) )
RESULT( 7 ) = DUMMA( 1 )
IF( DUMMA( 2 ).GT.THRESH ) THEN
WRITE( NOUNIT, FMT = 9998 )'Right', 'SGEGV', DUMMA( 2 ),
$ N, JTYPE, IOLDSD
END IF
*
* Check form of Complex eigenvalues.
*
DO 130 J = 1, N
ILABAD = .FALSE.
IF( ALPHI2( J ).GT.ZERO ) THEN
IF( J.EQ.N ) THEN
ILABAD = .TRUE.
ELSE IF( ALPHI2( J+1 ).GE.ZERO ) THEN
ILABAD = .TRUE.
END IF
ELSE IF( ALPHI2( J ).LT.ZERO ) THEN
IF( J.EQ.1 ) THEN
ILABAD = .TRUE.
ELSE IF( ALPHI2( J-1 ).LE.ZERO ) THEN
ILABAD = .TRUE.
END IF
END IF
IF( ILABAD ) THEN
WRITE( NOUNIT, FMT = 9996 )J, N, JTYPE, IOLDSD
END IF
130 CONTINUE
*
* End of Loop -- Check for RESULT(j) > THRESH
*
140 CONTINUE
*
NTESTT = NTESTT + NTEST
*
* Print out tests which fail.
*
DO 150 JR = 1, NTEST
IF( RESULT( JR ).GE.THRESH ) THEN
*
* If this is the first test to fail,
* print a header to the data file.
*
IF( NERRS.EQ.0 ) THEN
WRITE( NOUNIT, FMT = 9995 )'SGG'
*
* Matrix types
*
WRITE( NOUNIT, FMT = 9994 )
WRITE( NOUNIT, FMT = 9993 )
WRITE( NOUNIT, FMT = 9992 )'Orthogonal'
*
* Tests performed
*
WRITE( NOUNIT, FMT = 9991 )'orthogonal', '''',
$ 'transpose', ( '''', J = 1, 5 )
*
END IF
NERRS = NERRS + 1
IF( RESULT( JR ).LT.10000.0 ) THEN
WRITE( NOUNIT, FMT = 9990 )N, JTYPE, IOLDSD, JR,
$ RESULT( JR )
ELSE
WRITE( NOUNIT, FMT = 9989 )N, JTYPE, IOLDSD, JR,
$ RESULT( JR )
END IF
END IF
150 CONTINUE
*
160 CONTINUE
170 CONTINUE
*
* Summary
*
CALL ALASVM( 'SGG', NOUNIT, NERRS, NTESTT, 0 )
RETURN
*
9999 FORMAT( ' SDRVGG: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
*
9998 FORMAT( ' SDRVGG: ', A, ' Eigenvectors from ', A, ' incorrectly ',
$ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 9X,
$ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5,
$ ')' )
*
9997 FORMAT( ' SDRVGG: SGET53 returned INFO=', I1, ' for eigenvalue ',
$ I6, '.', / 9X, 'N=', I6, ', JTYPE=', I6, ', ISEED=(',
$ 3( I5, ',' ), I5, ')' )
*
9996 FORMAT( ' SDRVGG: S not in Schur form at eigenvalue ', I6, '.',
$ / 9X, 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ),
$ I5, ')' )
*
9995 FORMAT( / 1X, A3, ' -- Real Generalized eigenvalue problem driver'
$ )
*
9994 FORMAT( ' Matrix types (see SDRVGG for details): ' )
*
9993 FORMAT( ' Special Matrices:', 23X,
$ '(J''=transposed Jordan block)',
$ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ',
$ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ',
$ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I',
$ ') 11=(large*I, small*D) 13=(large*D, large*I)', /
$ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ',
$ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' )
9992 FORMAT( ' Matrices Rotated by Random ', A, ' Matrices U, V:',
$ / ' 16=Transposed Jordan Blocks 19=geometric ',
$ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ',
$ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ',
$ 'alpha, beta=0,1 21=random alpha, beta=0,1',
$ / ' Large & Small Matrices:', / ' 22=(large, small) ',
$ '23=(small,large) 24=(small,small) 25=(large,large)',
$ / ' 26=random O(1) matrices.' )
*
9991 FORMAT( / ' Tests performed: (S is Schur, T is triangular, ',
$ 'Q and Z are ', A, ',', / 20X,
$ 'l and r are the appropriate left and right', / 19X,
$ 'eigenvectors, resp., a is alpha, b is beta, and', / 19X, A,
$ ' means ', A, '.)', / ' 1 = | A - Q S Z', A,
$ ' | / ( |A| n ulp ) 2 = | B - Q T Z', A,
$ ' | / ( |B| n ulp )', / ' 3 = | I - QQ', A,
$ ' | / ( n ulp ) 4 = | I - ZZ', A,
$ ' | / ( n ulp )', /
$ ' 5 = difference between (alpha,beta) and diagonals of',
$ ' (S,T)', / ' 6 = max | ( b A - a B )', A,
$ ' l | / const. 7 = max | ( b A - a B ) r | / const.',
$ / 1X )
9990 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
$ 4( I4, ',' ), ' result ', I3, ' is', 0P, F8.2 )
9989 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
$ 4( I4, ',' ), ' result ', I3, ' is', 1P, E10.3 )
*
* End of SDRVGG
*
END
SUBROUTINE SDRVSG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
$ NOUNIT, A, LDA, B, LDB, D, Z, LDZ, AB, BB, AP,
$ BP, WORK, NWORK, IWORK, LIWORK, RESULT, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
*******************************************************************
*
* modified August 1997, a new parameter LIWORK is added
* in the calling sequence.
*
* test routine SSGT01 is also modified
*
*******************************************************************
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LDZ, LIWORK, NOUNIT, NSIZES,
$ NTYPES, NWORK
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER ISEED( 4 ), IWORK( * ), NN( * )
REAL A( LDA, * ), AB( LDA, * ), AP( * ),
$ B( LDB, * ), BB( LDB, * ), BP( * ), D( * ),
$ RESULT( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SDRVSG checks the real symmetric generalized eigenproblem
* drivers.
*
* SSYGV computes all eigenvalues and, optionally,
* eigenvectors of a real symmetric-definite generalized
* eigenproblem.
*
* SSYGVD computes all eigenvalues and, optionally,
* eigenvectors of a real symmetric-definite generalized
* eigenproblem using a divide and conquer algorithm.
*
* SSYGVX computes selected eigenvalues and, optionally,
* eigenvectors of a real symmetric-definite generalized
* eigenproblem.
*
* SSPGV computes all eigenvalues and, optionally,
* eigenvectors of a real symmetric-definite generalized
* eigenproblem in packed storage.
*
* SSPGVD computes all eigenvalues and, optionally,
* eigenvectors of a real symmetric-definite generalized
* eigenproblem in packed storage using a divide and
* conquer algorithm.
*
* SSPGVX computes selected eigenvalues and, optionally,
* eigenvectors of a real symmetric-definite generalized
* eigenproblem in packed storage.
*
* SSBGV computes all eigenvalues and, optionally,
* eigenvectors of a real symmetric-definite banded
* generalized eigenproblem.
*
* SSBGVD computes all eigenvalues and, optionally,
* eigenvectors of a real symmetric-definite banded
* generalized eigenproblem using a divide and conquer
* algorithm.
*
* SSBGVX computes selected eigenvalues and, optionally,
* eigenvectors of a real symmetric-definite banded
* generalized eigenproblem.
*
* When SDRVSG is called, a number of matrix "sizes" ("n's") and a
* number of matrix "types" are specified. For each size ("n")
* and each type of matrix, one matrix A of the given type will be
* generated; a random well-conditioned matrix B is also generated
* and the pair (A,B) is used to test the drivers.
*
* For each pair (A,B), the following tests are performed:
*
* (1) SSYGV with ITYPE = 1 and UPLO ='U':
*
* | A Z - B Z D | / ( |A| |Z| n ulp )
*
* (2) as (1) but calling SSPGV
* (3) as (1) but calling SSBGV
* (4) as (1) but with UPLO = 'L'
* (5) as (4) but calling SSPGV
* (6) as (4) but calling SSBGV
*
* (7) SSYGV with ITYPE = 2 and UPLO ='U':
*
* | A B Z - Z D | / ( |A| |Z| n ulp )
*
* (8) as (7) but calling SSPGV
* (9) as (7) but with UPLO = 'L'
* (10) as (9) but calling SSPGV
*
* (11) SSYGV with ITYPE = 3 and UPLO ='U':
*
* | B A Z - Z D | / ( |A| |Z| n ulp )
*
* (12) as (11) but calling SSPGV
* (13) as (11) but with UPLO = 'L'
* (14) as (13) but calling SSPGV
*
* SSYGVD, SSPGVD and SSBGVD performed the same 14 tests.
*
* SSYGVX, SSPGVX and SSBGVX performed the above 14 tests with
* the parameter RANGE = 'A', 'N' and 'I', respectively.
*
* The "sizes" are specified by an array NN(1:NSIZES); the value
* of each element NN(j) specifies one size.
* The "types" are specified by a logical array DOTYPE( 1:NTYPES );
* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
* This type is used for the matrix A which has half-bandwidth KA.
* B is generated as a well-conditioned positive definite matrix
* with half-bandwidth KB (<= KA).
* Currently, the list of possible types for A is:
*
* (1) The zero matrix.
* (2) The identity matrix.
*
* (3) A diagonal matrix with evenly spaced entries
* 1, ..., ULP and random signs.
* (ULP = (first number larger than 1) - 1 )
* (4) A diagonal matrix with geometrically spaced entries
* 1, ..., ULP and random signs.
* (5) A diagonal matrix with "clustered" entries
* 1, ULP, ..., ULP and random signs.
*
* (6) Same as (4), but multiplied by SQRT( overflow threshold )
* (7) Same as (4), but multiplied by SQRT( underflow threshold )
*
* (8) A matrix of the form U* D U, where U is orthogonal and
* D has evenly spaced entries 1, ..., ULP with random signs
* on the diagonal.
*
* (9) A matrix of the form U* D U, where U is orthogonal and
* D has geometrically spaced entries 1, ..., ULP with random
* signs on the diagonal.
*
* (10) A matrix of the form U* D U, where U is orthogonal and
* D has "clustered" entries 1, ULP,..., ULP with random
* signs on the diagonal.
*
* (11) Same as (8), but multiplied by SQRT( overflow threshold )
* (12) Same as (8), but multiplied by SQRT( underflow threshold )
*
* (13) symmetric matrix with random entries chosen from (-1,1).
* (14) Same as (13), but multiplied by SQRT( overflow threshold )
* (15) Same as (13), but multiplied by SQRT( underflow threshold)
*
* (16) Same as (8), but with KA = 1 and KB = 1
* (17) Same as (8), but with KA = 2 and KB = 1
* (18) Same as (8), but with KA = 2 and KB = 2
* (19) Same as (8), but with KA = 3 and KB = 1
* (20) Same as (8), but with KA = 3 and KB = 2
* (21) Same as (8), but with KA = 3 and KB = 3
*
* Arguments
* =========
*
* NSIZES INTEGER
* The number of sizes of matrices to use. If it is zero,
* SDRVSG does nothing. It must be at least zero.
* Not modified.
*
* NN INTEGER array, dimension (NSIZES)
* An array containing the sizes to be used for the matrices.
* Zero values will be skipped. The values must be at least
* zero.
* Not modified.
*
* NTYPES INTEGER
* The number of elements in DOTYPE. If it is zero, SDRVSG
* does nothing. It must be at least zero. If it is MAXTYP+1
* and NSIZES is 1, then an additional type, MAXTYP+1 is
* defined, which is to use whatever matrix is in A. This
* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
* DOTYPE(MAXTYP+1) is .TRUE. .
* Not modified.
*
* DOTYPE LOGICAL array, dimension (NTYPES)
* If DOTYPE(j) is .TRUE., then for each size in NN a
* matrix of that size and of type j will be generated.
* If NTYPES is smaller than the maximum number of types
* defined (PARAMETER MAXTYP), then types NTYPES+1 through
* MAXTYP will not be generated. If NTYPES is larger
* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
* will be ignored.
* Not modified.
*
* ISEED INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The array elements should be between 0 and 4095;
* if not they will be reduced mod 4096. Also, ISEED(4) must
* be odd. The random number generator uses a linear
* congruential sequence limited to small integers, and so
* should produce machine independent random numbers. The
* values of ISEED are changed on exit, and can be used in the
* next call to SDRVSG to continue the same random number
* sequence.
* Modified.
*
* THRESH REAL
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error
* is scaled to be O(1), so THRESH should be a reasonably
* small multiple of 1, e.g., 10 or 100. In particular,
* it should not depend on the precision (single vs. double)
* or the size of the matrix. It must be at least zero.
* Not modified.
*
* NOUNIT INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns IINFO not equal to 0.)
* Not modified.
*
* A REAL array, dimension (LDA , max(NN))
* Used to hold the matrix whose eigenvalues are to be
* computed. On exit, A contains the last matrix actually
* used.
* Modified.
*
* LDA INTEGER
* The leading dimension of A and AB. It must be at
* least 1 and at least max( NN ).
* Not modified.
*
* B REAL array, dimension (LDB , max(NN))
* Used to hold the symmetric positive definite matrix for
* the generailzed problem.
* On exit, B contains the last matrix actually
* used.
* Modified.
*
* LDB INTEGER
* The leading dimension of B and BB. It must be at
* least 1 and at least max( NN ).
* Not modified.
*
* D REAL array, dimension (max(NN))
* The eigenvalues of A. On exit, the eigenvalues in D
* correspond with the matrix in A.
* Modified.
*
* Z REAL array, dimension (LDZ, max(NN))
* The matrix of eigenvectors.
* Modified.
*
* LDZ INTEGER
* The leading dimension of Z. It must be at least 1 and
* at least max( NN ).
* Not modified.
*
* AB REAL array, dimension (LDA, max(NN))
* Workspace.
* Modified.
*
* BB REAL array, dimension (LDB, max(NN))
* Workspace.
* Modified.
*
* AP REAL array, dimension (max(NN)**2)
* Workspace.
* Modified.
*
* BP REAL array, dimension (max(NN)**2)
* Workspace.
* Modified.
*
* WORK REAL array, dimension (NWORK)
* Workspace.
* Modified.
*
* NWORK INTEGER
* The number of entries in WORK. This must be at least
* 1+5*N+2*N*lg(N)+3*N**2 where N = max( NN(j) ) and
* lg( N ) = smallest integer k such that 2**k >= N.
* Not modified.
*
* IWORK INTEGER array, dimension (LIWORK)
* Workspace.
* Modified.
*
* LIWORK INTEGER
* The number of entries in WORK. This must be at least 6*N.
* Not modified.
*
* RESULT REAL array, dimension (70)
* The values computed by the 70 tests described above.
* Modified.
*
* INFO INTEGER
* If 0, then everything ran OK.
* -1: NSIZES < 0
* -2: Some NN(j) < 0
* -3: NTYPES < 0
* -5: THRESH < 0
* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
* -16: LDZ < 1 or LDZ < NMAX.
* -21: NWORK too small.
* -23: LIWORK too small.
* If SLATMR, SLATMS, SSYGV, SSPGV, SSBGV, SSYGVD, SSPGVD,
* SSBGVD, SSYGVX, SSPGVX or SSBGVX returns an error code,
* the absolute value of it is returned.
* Modified.
*
* ----------------------------------------------------------------------
*
* Some Local Variables and Parameters:
* ---- ----- --------- --- ----------
* ZERO, ONE Real 0 and 1.
* MAXTYP The number of types defined.
* NTEST The number of tests that have been run
* on this matrix.
* NTESTT The total number of tests for this call.
* NMAX Largest value in NN.
* NMATS The number of matrices generated so far.
* NERRS The number of tests which have exceeded THRESH
* so far (computed by SLAFTS).
* COND, IMODE Values to be passed to the matrix generators.
* ANORM Norm of A; passed to matrix generators.
*
* OVFL, UNFL Overflow and underflow thresholds.
* ULP, ULPINV Finest relative precision and its inverse.
* RTOVFL, RTUNFL Square roots of the previous 2 values.
* The following four arrays decode JTYPE:
* KTYPE(j) The general type (1-10) for type "j".
* KMODE(j) The MODE value to be passed to the matrix
* generator for type "j".
* KMAGN(j) The order of magnitude ( O(1),
* O(overflow^(1/2) ), O(underflow^(1/2) )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TEN
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TEN = 10.0E0 )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 21 )
* ..
* .. Local Scalars ..
LOGICAL BADNN
CHARACTER UPLO
INTEGER I, IBTYPE, IBUPLO, IINFO, IJ, IL, IMODE, ITEMP,
$ ITYPE, IU, J, JCOL, JSIZE, JTYPE, KA, KA9, KB,
$ KB9, M, MTYPES, N, NERRS, NMATS, NMAX, NTEST,
$ NTESTT
REAL ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
$ RTUNFL, ULP, ULPINV, UNFL, VL, VU
* ..
* .. Local Arrays ..
INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
$ KMAGN( MAXTYP ), KMODE( MAXTYP ),
$ KTYPE( MAXTYP )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLARND
EXTERNAL LSAME, SLAMCH, SLARND
* ..
* .. External Subroutines ..
EXTERNAL SLABAD, SLACPY, SLAFTS, SLASET, SLASUM, SLATMR,
$ SLATMS, SSBGV, SSBGVD, SSBGVX, SSGT01, SSPGV,
$ SSPGVD, SSPGVX, SSYGV, SSYGVD, SSYGVX, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL, SQRT
* ..
* .. Data statements ..
DATA KTYPE / 1, 2, 5*4, 5*5, 3*8, 6*9 /
DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
$ 2, 3, 6*1 /
DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
$ 0, 0, 6*4 /
* ..
* .. Executable Statements ..
*
* 1) Check for errors
*
NTESTT = 0
INFO = 0
*
BADNN = .FALSE.
NMAX = 0
DO 10 J = 1, NSIZES
NMAX = MAX( NMAX, NN( J ) )
IF( NN( J ).LT.0 )
$ BADNN = .TRUE.
10 CONTINUE
*
* Check for errors
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADNN ) THEN
INFO = -2
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN
INFO = -9
ELSE IF( LDZ.LE.1 .OR. LDZ.LT.NMAX ) THEN
INFO = -16
ELSE IF( 2*MAX( NMAX, 3 )**2.GT.NWORK ) THEN
INFO = -21
ELSE IF( 2*MAX( NMAX, 3 )**2.GT.LIWORK ) THEN
INFO = -23
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SDRVSG', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
$ RETURN
*
* More Important constants
*
UNFL = SLAMCH( 'Safe minimum' )
OVFL = SLAMCH( 'Overflow' )
CALL SLABAD( UNFL, OVFL )
ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
ULPINV = ONE / ULP
RTUNFL = SQRT( UNFL )
RTOVFL = SQRT( OVFL )
*
DO 20 I = 1, 4
ISEED2( I ) = ISEED( I )
20 CONTINUE
*
* Loop over sizes, types
*
NERRS = 0
NMATS = 0
*
DO 650 JSIZE = 1, NSIZES
N = NN( JSIZE )
ANINV = ONE / REAL( MAX( 1, N ) )
*
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
KA9 = 0
KB9 = 0
DO 640 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 640
NMATS = NMATS + 1
NTEST = 0
*
DO 30 J = 1, 4
IOLDSD( J ) = ISEED( J )
30 CONTINUE
*
* 2) Compute "A"
*
* Control parameters:
*
* KMAGN KMODE KTYPE
* =1 O(1) clustered 1 zero
* =2 large clustered 2 identity
* =3 small exponential (none)
* =4 arithmetic diagonal, w/ eigenvalues
* =5 random log hermitian, w/ eigenvalues
* =6 random (none)
* =7 random diagonal
* =8 random hermitian
* =9 banded, w/ eigenvalues
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 90
*
ITYPE = KTYPE( JTYPE )
IMODE = KMODE( JTYPE )
*
* Compute norm
*
GO TO ( 40, 50, 60 )KMAGN( JTYPE )
*
40 CONTINUE
ANORM = ONE
GO TO 70
*
50 CONTINUE
ANORM = ( RTOVFL*ULP )*ANINV
GO TO 70
*
60 CONTINUE
ANORM = RTUNFL*N*ULPINV
GO TO 70
*
70 CONTINUE
*
IINFO = 0
COND = ULPINV
*
* Special Matrices -- Identity & Jordan block
*
IF( ITYPE.EQ.1 ) THEN
*
* Zero
*
KA = 0
KB = 0
CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Identity
*
KA = 0
KB = 0
CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
DO 80 JCOL = 1, N
A( JCOL, JCOL ) = ANORM
80 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Diagonal Matrix, [Eigen]values Specified
*
KA = 0
KB = 0
CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.5 ) THEN
*
* symmetric, eigenvalues specified
*
KA = MAX( 0, N-1 )
KB = KA
CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, N, N, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.7 ) THEN
*
* Diagonal, random eigenvalues
*
KA = 0
KB = 0
CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.8 ) THEN
*
* symmetric, random eigenvalues
*
KA = MAX( 0, N-1 )
KB = KA
CALL SLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.9 ) THEN
*
* symmetric banded, eigenvalues specified
*
* The following values are used for the half-bandwidths:
*
* ka = 1 kb = 1
* ka = 2 kb = 1
* ka = 2 kb = 2
* ka = 3 kb = 1
* ka = 3 kb = 2
* ka = 3 kb = 3
*
KB9 = KB9 + 1
IF( KB9.GT.KA9 ) THEN
KA9 = KA9 + 1
KB9 = 1
END IF
KA = MAX( 0, MIN( N-1, KA9 ) )
KB = MAX( 0, MIN( N-1, KB9 ) )
CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, KA, KA, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE
*
IINFO = 1
END IF
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
90 CONTINUE
*
ABSTOL = UNFL + UNFL
IF( N.LE.1 ) THEN
IL = 1
IU = N
ELSE
IL = 1 + ( N-1 )*SLARND( 1, ISEED2 )
IU = 1 + ( N-1 )*SLARND( 1, ISEED2 )
IF( IL.GT.IU ) THEN
ITEMP = IL
IL = IU
IU = ITEMP
END IF
END IF
*
* 3) Call SSYGV, SSPGV, SSBGV, SSYGVD, SSPGVD, SSBGVD,
* SSYGVX, SSPGVX, and SSBGVX, do tests.
*
* loop over the three generalized problems
* IBTYPE = 1: A*x = (lambda)*B*x
* IBTYPE = 2: A*B*x = (lambda)*x
* IBTYPE = 3: B*A*x = (lambda)*x
*
DO 630 IBTYPE = 1, 3
*
* loop over the setting UPLO
*
DO 620 IBUPLO = 1, 2
IF( IBUPLO.EQ.1 )
$ UPLO = 'U'
IF( IBUPLO.EQ.2 )
$ UPLO = 'L'
*
* Generate random well-conditioned positive definite
* matrix B, of bandwidth not greater than that of A.
*
CALL SLATMS( N, N, 'U', ISEED, 'P', WORK, 5, TEN, ONE,
$ KB, KB, UPLO, B, LDB, WORK( N+1 ),
$ IINFO )
*
* Test SSYGV
*
NTEST = NTEST + 1
*
CALL SLACPY( ' ', N, N, A, LDA, Z, LDZ )
CALL SLACPY( UPLO, N, N, B, LDB, BB, LDB )
*
CALL SSYGV( IBTYPE, 'V', UPLO, N, Z, LDZ, BB, LDB, D,
$ WORK, NWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSYGV(V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 100
END IF
END IF
*
* Do Test
*
CALL SSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
* Test SSYGVD
*
NTEST = NTEST + 1
*
CALL SLACPY( ' ', N, N, A, LDA, Z, LDZ )
CALL SLACPY( UPLO, N, N, B, LDB, BB, LDB )
*
CALL SSYGVD( IBTYPE, 'V', UPLO, N, Z, LDZ, BB, LDB, D,
$ WORK, NWORK, IWORK, LIWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSYGVD(V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 100
END IF
END IF
*
* Do Test
*
CALL SSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
* Test SSYGVX
*
NTEST = NTEST + 1
*
CALL SLACPY( ' ', N, N, A, LDA, AB, LDA )
CALL SLACPY( UPLO, N, N, B, LDB, BB, LDB )
*
CALL SSYGVX( IBTYPE, 'V', 'A', UPLO, N, AB, LDA, BB,
$ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z,
$ LDZ, WORK, NWORK, IWORK( N+1 ), IWORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSYGVX(V,A' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 100
END IF
END IF
*
* Do Test
*
CALL SSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 1
*
CALL SLACPY( ' ', N, N, A, LDA, AB, LDA )
CALL SLACPY( UPLO, N, N, B, LDB, BB, LDB )
*
* since we do not know the exact eigenvalues of this
* eigenpair, we just set VL and VU as constants.
* It is quite possible that there are no eigenvalues
* in this interval.
*
VL = ZERO
VU = ANORM
CALL SSYGVX( IBTYPE, 'V', 'V', UPLO, N, AB, LDA, BB,
$ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z,
$ LDZ, WORK, NWORK, IWORK( N+1 ), IWORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSYGVX(V,V,' //
$ UPLO // ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 100
END IF
END IF
*
* Do Test
*
CALL SSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 1
*
CALL SLACPY( ' ', N, N, A, LDA, AB, LDA )
CALL SLACPY( UPLO, N, N, B, LDB, BB, LDB )
*
CALL SSYGVX( IBTYPE, 'V', 'I', UPLO, N, AB, LDA, BB,
$ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z,
$ LDZ, WORK, NWORK, IWORK( N+1 ), IWORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSYGVX(V,I,' //
$ UPLO // ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 100
END IF
END IF
*
* Do Test
*
CALL SSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
100 CONTINUE
*
* Test SSPGV
*
NTEST = NTEST + 1
*
* Copy the matrices into packed storage.
*
IF( LSAME( UPLO, 'U' ) ) THEN
IJ = 1
DO 120 J = 1, N
DO 110 I = 1, J
AP( IJ ) = A( I, J )
BP( IJ ) = B( I, J )
IJ = IJ + 1
110 CONTINUE
120 CONTINUE
ELSE
IJ = 1
DO 140 J = 1, N
DO 130 I = J, N
AP( IJ ) = A( I, J )
BP( IJ ) = B( I, J )
IJ = IJ + 1
130 CONTINUE
140 CONTINUE
END IF
*
CALL SSPGV( IBTYPE, 'V', UPLO, N, AP, BP, D, Z, LDZ,
$ WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSPGV(V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 310
END IF
END IF
*
* Do Test
*
CALL SSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
* Test SSPGVD
*
NTEST = NTEST + 1
*
* Copy the matrices into packed storage.
*
IF( LSAME( UPLO, 'U' ) ) THEN
IJ = 1
DO 160 J = 1, N
DO 150 I = 1, J
AP( IJ ) = A( I, J )
BP( IJ ) = B( I, J )
IJ = IJ + 1
150 CONTINUE
160 CONTINUE
ELSE
IJ = 1
DO 180 J = 1, N
DO 170 I = J, N
AP( IJ ) = A( I, J )
BP( IJ ) = B( I, J )
IJ = IJ + 1
170 CONTINUE
180 CONTINUE
END IF
*
CALL SSPGVD( IBTYPE, 'V', UPLO, N, AP, BP, D, Z, LDZ,
$ WORK, NWORK, IWORK, LIWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSPGVD(V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 310
END IF
END IF
*
* Do Test
*
CALL SSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
* Test SSPGVX
*
NTEST = NTEST + 1
*
* Copy the matrices into packed storage.
*
IF( LSAME( UPLO, 'U' ) ) THEN
IJ = 1
DO 200 J = 1, N
DO 190 I = 1, J
AP( IJ ) = A( I, J )
BP( IJ ) = B( I, J )
IJ = IJ + 1
190 CONTINUE
200 CONTINUE
ELSE
IJ = 1
DO 220 J = 1, N
DO 210 I = J, N
AP( IJ ) = A( I, J )
BP( IJ ) = B( I, J )
IJ = IJ + 1
210 CONTINUE
220 CONTINUE
END IF
*
CALL SSPGVX( IBTYPE, 'V', 'A', UPLO, N, AP, BP, VL,
$ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK,
$ IWORK( N+1 ), IWORK, INFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSPGVX(V,A' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 310
END IF
END IF
*
* Do Test
*
CALL SSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 1
*
* Copy the matrices into packed storage.
*
IF( LSAME( UPLO, 'U' ) ) THEN
IJ = 1
DO 240 J = 1, N
DO 230 I = 1, J
AP( IJ ) = A( I, J )
BP( IJ ) = B( I, J )
IJ = IJ + 1
230 CONTINUE
240 CONTINUE
ELSE
IJ = 1
DO 260 J = 1, N
DO 250 I = J, N
AP( IJ ) = A( I, J )
BP( IJ ) = B( I, J )
IJ = IJ + 1
250 CONTINUE
260 CONTINUE
END IF
*
VL = ZERO
VU = ANORM
CALL SSPGVX( IBTYPE, 'V', 'V', UPLO, N, AP, BP, VL,
$ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK,
$ IWORK( N+1 ), IWORK, INFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSPGVX(V,V' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 310
END IF
END IF
*
* Do Test
*
CALL SSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 1
*
* Copy the matrices into packed storage.
*
IF( LSAME( UPLO, 'U' ) ) THEN
IJ = 1
DO 280 J = 1, N
DO 270 I = 1, J
AP( IJ ) = A( I, J )
BP( IJ ) = B( I, J )
IJ = IJ + 1
270 CONTINUE
280 CONTINUE
ELSE
IJ = 1
DO 300 J = 1, N
DO 290 I = J, N
AP( IJ ) = A( I, J )
BP( IJ ) = B( I, J )
IJ = IJ + 1
290 CONTINUE
300 CONTINUE
END IF
*
CALL SSPGVX( IBTYPE, 'V', 'I', UPLO, N, AP, BP, VL,
$ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK,
$ IWORK( N+1 ), IWORK, INFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSPGVX(V,I' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 310
END IF
END IF
*
* Do Test
*
CALL SSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
310 CONTINUE
*
IF( IBTYPE.EQ.1 ) THEN
*
* TEST SSBGV
*
NTEST = NTEST + 1
*
* Copy the matrices into band storage.
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 340 J = 1, N
DO 320 I = MAX( 1, J-KA ), J
AB( KA+1+I-J, J ) = A( I, J )
320 CONTINUE
DO 330 I = MAX( 1, J-KB ), J
BB( KB+1+I-J, J ) = B( I, J )
330 CONTINUE
340 CONTINUE
ELSE
DO 370 J = 1, N
DO 350 I = J, MIN( N, J+KA )
AB( 1+I-J, J ) = A( I, J )
350 CONTINUE
DO 360 I = J, MIN( N, J+KB )
BB( 1+I-J, J ) = B( I, J )
360 CONTINUE
370 CONTINUE
END IF
*
CALL SSBGV( 'V', UPLO, N, KA, KB, AB, LDA, BB, LDB,
$ D, Z, LDZ, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSBGV(V,' //
$ UPLO // ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 620
END IF
END IF
*
* Do Test
*
CALL SSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
* TEST SSBGVD
*
NTEST = NTEST + 1
*
* Copy the matrices into band storage.
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 400 J = 1, N
DO 380 I = MAX( 1, J-KA ), J
AB( KA+1+I-J, J ) = A( I, J )
380 CONTINUE
DO 390 I = MAX( 1, J-KB ), J
BB( KB+1+I-J, J ) = B( I, J )
390 CONTINUE
400 CONTINUE
ELSE
DO 430 J = 1, N
DO 410 I = J, MIN( N, J+KA )
AB( 1+I-J, J ) = A( I, J )
410 CONTINUE
DO 420 I = J, MIN( N, J+KB )
BB( 1+I-J, J ) = B( I, J )
420 CONTINUE
430 CONTINUE
END IF
*
CALL SSBGVD( 'V', UPLO, N, KA, KB, AB, LDA, BB,
$ LDB, D, Z, LDZ, WORK, NWORK, IWORK,
$ LIWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSBGVD(V,' //
$ UPLO // ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 620
END IF
END IF
*
* Do Test
*
CALL SSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
* Test SSBGVX
*
NTEST = NTEST + 1
*
* Copy the matrices into band storage.
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 460 J = 1, N
DO 440 I = MAX( 1, J-KA ), J
AB( KA+1+I-J, J ) = A( I, J )
440 CONTINUE
DO 450 I = MAX( 1, J-KB ), J
BB( KB+1+I-J, J ) = B( I, J )
450 CONTINUE
460 CONTINUE
ELSE
DO 490 J = 1, N
DO 470 I = J, MIN( N, J+KA )
AB( 1+I-J, J ) = A( I, J )
470 CONTINUE
DO 480 I = J, MIN( N, J+KB )
BB( 1+I-J, J ) = B( I, J )
480 CONTINUE
490 CONTINUE
END IF
*
CALL SSBGVX( 'V', 'A', UPLO, N, KA, KB, AB, LDA,
$ BB, LDB, BP, MAX( 1, N ), VL, VU, IL,
$ IU, ABSTOL, M, D, Z, LDZ, WORK,
$ IWORK( N+1 ), IWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSBGVX(V,A' //
$ UPLO // ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 620
END IF
END IF
*
* Do Test
*
CALL SSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
*
NTEST = NTEST + 1
*
* Copy the matrices into band storage.
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 520 J = 1, N
DO 500 I = MAX( 1, J-KA ), J
AB( KA+1+I-J, J ) = A( I, J )
500 CONTINUE
DO 510 I = MAX( 1, J-KB ), J
BB( KB+1+I-J, J ) = B( I, J )
510 CONTINUE
520 CONTINUE
ELSE
DO 550 J = 1, N
DO 530 I = J, MIN( N, J+KA )
AB( 1+I-J, J ) = A( I, J )
530 CONTINUE
DO 540 I = J, MIN( N, J+KB )
BB( 1+I-J, J ) = B( I, J )
540 CONTINUE
550 CONTINUE
END IF
*
VL = ZERO
VU = ANORM
CALL SSBGVX( 'V', 'V', UPLO, N, KA, KB, AB, LDA,
$ BB, LDB, BP, MAX( 1, N ), VL, VU, IL,
$ IU, ABSTOL, M, D, Z, LDZ, WORK,
$ IWORK( N+1 ), IWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSBGVX(V,V' //
$ UPLO // ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 620
END IF
END IF
*
* Do Test
*
CALL SSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 1
*
* Copy the matrices into band storage.
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 580 J = 1, N
DO 560 I = MAX( 1, J-KA ), J
AB( KA+1+I-J, J ) = A( I, J )
560 CONTINUE
DO 570 I = MAX( 1, J-KB ), J
BB( KB+1+I-J, J ) = B( I, J )
570 CONTINUE
580 CONTINUE
ELSE
DO 610 J = 1, N
DO 590 I = J, MIN( N, J+KA )
AB( 1+I-J, J ) = A( I, J )
590 CONTINUE
DO 600 I = J, MIN( N, J+KB )
BB( 1+I-J, J ) = B( I, J )
600 CONTINUE
610 CONTINUE
END IF
*
CALL SSBGVX( 'V', 'I', UPLO, N, KA, KB, AB, LDA,
$ BB, LDB, BP, MAX( 1, N ), VL, VU, IL,
$ IU, ABSTOL, M, D, Z, LDZ, WORK,
$ IWORK( N+1 ), IWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSBGVX(V,I' //
$ UPLO // ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 620
END IF
END IF
*
* Do Test
*
CALL SSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
END IF
*
620 CONTINUE
630 CONTINUE
*
* End of Loop -- Check for RESULT(j) > THRESH
*
NTESTT = NTESTT + NTEST
CALL SLAFTS( 'SSG', N, N, JTYPE, NTEST, RESULT, IOLDSD,
$ THRESH, NOUNIT, NERRS )
640 CONTINUE
650 CONTINUE
*
* Summary
*
CALL SLASUM( 'SSG', NOUNIT, NERRS, NTESTT )
*
RETURN
*
* End of SDRVSG
*
9999 FORMAT( ' SDRVSG: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
END
SUBROUTINE SDRVST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
$ NOUNIT, A, LDA, D1, D2, D3, D4, EVEIGS, WA1,
$ WA2, WA3, U, LDU, V, TAU, Z, WORK, LWORK,
$ IWORK, LIWORK, RESULT, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES,
$ NTYPES
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER ISEED( 4 ), IWORK( * ), NN( * )
REAL A( LDA, * ), D1( * ), D2( * ), D3( * ),
$ D4( * ), EVEIGS( * ), RESULT( * ), TAU( * ),
$ U( LDU, * ), V( LDU, * ), WA1( * ), WA2( * ),
$ WA3( * ), WORK( * ), Z( LDU, * )
* ..
*
* Purpose
* =======
*
* SDRVST checks the symmetric eigenvalue problem drivers.
*
* SSTEV computes all eigenvalues and, optionally,
* eigenvectors of a real symmetric tridiagonal matrix.
*
* SSTEVX computes selected eigenvalues and, optionally,
* eigenvectors of a real symmetric tridiagonal matrix.
*
* SSTEVR computes selected eigenvalues and, optionally,
* eigenvectors of a real symmetric tridiagonal matrix
* using the Relatively Robust Representation where it can.
*
* SSYEV computes all eigenvalues and, optionally,
* eigenvectors of a real symmetric matrix.
*
* SSYEVX computes selected eigenvalues and, optionally,
* eigenvectors of a real symmetric matrix.
*
* SSYEVR computes selected eigenvalues and, optionally,
* eigenvectors of a real symmetric matrix
* using the Relatively Robust Representation where it can.
*
* SSPEV computes all eigenvalues and, optionally,
* eigenvectors of a real symmetric matrix in packed
* storage.
*
* SSPEVX computes selected eigenvalues and, optionally,
* eigenvectors of a real symmetric matrix in packed
* storage.
*
* SSBEV computes all eigenvalues and, optionally,
* eigenvectors of a real symmetric band matrix.
*
* SSBEVX computes selected eigenvalues and, optionally,
* eigenvectors of a real symmetric band matrix.
*
* SSYEVD computes all eigenvalues and, optionally,
* eigenvectors of a real symmetric matrix using
* a divide and conquer algorithm.
*
* SSPEVD computes all eigenvalues and, optionally,
* eigenvectors of a real symmetric matrix in packed
* storage, using a divide and conquer algorithm.
*
* SSBEVD computes all eigenvalues and, optionally,
* eigenvectors of a real symmetric band matrix,
* using a divide and conquer algorithm.
*
* When SDRVST is called, a number of matrix "sizes" ("n's") and a
* number of matrix "types" are specified. For each size ("n")
* and each type of matrix, one matrix will be generated and used
* to test the appropriate drivers. For each matrix and each
* driver routine called, the following tests will be performed:
*
* (1) | A - Z D Z' | / ( |A| n ulp )
*
* (2) | I - Z Z' | / ( n ulp )
*
* (3) | D1 - D2 | / ( |D1| ulp )
*
* where Z is the matrix of eigenvectors returned when the
* eigenvector option is given and D1 and D2 are the eigenvalues
* returned with and without the eigenvector option.
*
* The "sizes" are specified by an array NN(1:NSIZES); the value of
* each element NN(j) specifies one size.
* The "types" are specified by a logical array DOTYPE( 1:NTYPES );
* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
* Currently, the list of possible types is:
*
* (1) The zero matrix.
* (2) The identity matrix.
*
* (3) A diagonal matrix with evenly spaced eigenvalues
* 1, ..., ULP and random signs.
* (ULP = (first number larger than 1) - 1 )
* (4) A diagonal matrix with geometrically spaced eigenvalues
* 1, ..., ULP and random signs.
* (5) A diagonal matrix with "clustered" eigenvalues
* 1, ULP, ..., ULP and random signs.
*
* (6) Same as (4), but multiplied by SQRT( overflow threshold )
* (7) Same as (4), but multiplied by SQRT( underflow threshold )
*
* (8) A matrix of the form U' D U, where U is orthogonal and
* D has evenly spaced entries 1, ..., ULP with random signs
* on the diagonal.
*
* (9) A matrix of the form U' D U, where U is orthogonal and
* D has geometrically spaced entries 1, ..., ULP with random
* signs on the diagonal.
*
* (10) A matrix of the form U' D U, where U is orthogonal and
* D has "clustered" entries 1, ULP,..., ULP with random
* signs on the diagonal.
*
* (11) Same as (8), but multiplied by SQRT( overflow threshold )
* (12) Same as (8), but multiplied by SQRT( underflow threshold )
*
* (13) Symmetric matrix with random entries chosen from (-1,1).
* (14) Same as (13), but multiplied by SQRT( overflow threshold )
* (15) Same as (13), but multiplied by SQRT( underflow threshold )
* (16) A band matrix with half bandwidth randomly chosen between
* 0 and N-1, with evenly spaced eigenvalues 1, ..., ULP
* with random signs.
* (17) Same as (16), but multiplied by SQRT( overflow threshold )
* (18) Same as (16), but multiplied by SQRT( underflow threshold )
*
* Arguments
* =========
*
* NSIZES INTEGER
* The number of sizes of matrices to use. If it is zero,
* SDRVST does nothing. It must be at least zero.
* Not modified.
*
* NN INTEGER array, dimension (NSIZES)
* An array containing the sizes to be used for the matrices.
* Zero values will be skipped. The values must be at least
* zero.
* Not modified.
*
* NTYPES INTEGER
* The number of elements in DOTYPE. If it is zero, SDRVST
* does nothing. It must be at least zero. If it is MAXTYP+1
* and NSIZES is 1, then an additional type, MAXTYP+1 is
* defined, which is to use whatever matrix is in A. This
* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
* DOTYPE(MAXTYP+1) is .TRUE. .
* Not modified.
*
* DOTYPE LOGICAL array, dimension (NTYPES)
* If DOTYPE(j) is .TRUE., then for each size in NN a
* matrix of that size and of type j will be generated.
* If NTYPES is smaller than the maximum number of types
* defined (PARAMETER MAXTYP), then types NTYPES+1 through
* MAXTYP will not be generated. If NTYPES is larger
* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
* will be ignored.
* Not modified.
*
* ISEED INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The array elements should be between 0 and 4095;
* if not they will be reduced mod 4096. Also, ISEED(4) must
* be odd. The random number generator uses a linear
* congruential sequence limited to small integers, and so
* should produce machine independent random numbers. The
* values of ISEED are changed on exit, and can be used in the
* next call to SDRVST to continue the same random number
* sequence.
* Modified.
*
* THRESH REAL
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error
* is scaled to be O(1), so THRESH should be a reasonably
* small multiple of 1, e.g., 10 or 100. In particular,
* it should not depend on the precision (single vs. double)
* or the size of the matrix. It must be at least zero.
* Not modified.
*
* NOUNIT INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns IINFO not equal to 0.)
* Not modified.
*
* A REAL array, dimension (LDA , max(NN))
* Used to hold the matrix whose eigenvalues are to be
* computed. On exit, A contains the last matrix actually
* used.
* Modified.
*
* LDA INTEGER
* The leading dimension of A. It must be at
* least 1 and at least max( NN ).
* Not modified.
*
* D1 REAL array, dimension (max(NN))
* The eigenvalues of A, as computed by SSTEQR simlutaneously
* with Z. On exit, the eigenvalues in D1 correspond with the
* matrix in A.
* Modified.
*
* D2 REAL array, dimension (max(NN))
* The eigenvalues of A, as computed by SSTEQR if Z is not
* computed. On exit, the eigenvalues in D2 correspond with
* the matrix in A.
* Modified.
*
* D3 REAL array, dimension (max(NN))
* The eigenvalues of A, as computed by SSTERF. On exit, the
* eigenvalues in D3 correspond with the matrix in A.
* Modified.
*
* D4 REAL array, dimension
*
* EVEIGS REAL array, dimension (max(NN))
* The eigenvalues as computed by SSTEV('N', ... )
* (I reserve the right to change this to the output of
* whichever algorithm computes the most accurate eigenvalues).
*
* WA1 REAL array, dimension
*
* WA2 REAL array, dimension
*
* WA3 REAL array, dimension
*
* U REAL array, dimension (LDU, max(NN))
* The orthogonal matrix computed by SSYTRD + SORGTR.
* Modified.
*
* LDU INTEGER
* The leading dimension of U, Z, and V. It must be at
* least 1 and at least max( NN ).
* Not modified.
*
* V REAL array, dimension (LDU, max(NN))
* The Housholder vectors computed by SSYTRD in reducing A to
* tridiagonal form.
* Modified.
*
* TAU REAL array, dimension (max(NN))
* The Householder factors computed by SSYTRD in reducing A
* to tridiagonal form.
* Modified.
*
* Z REAL array, dimension (LDU, max(NN))
* The orthogonal matrix of eigenvectors computed by SSTEQR,
* SPTEQR, and SSTEIN.
* Modified.
*
* WORK REAL array, dimension (LWORK)
* Workspace.
* Modified.
*
* LWORK INTEGER
* The number of entries in WORK. This must be at least
* 1 + 4 * Nmax + 2 * Nmax * lg Nmax + 4 * Nmax**2
* where Nmax = max( NN(j), 2 ) and lg = log base 2.
* Not modified.
*
* IWORK INTEGER array,
* dimension (6 + 6*Nmax + 5 * Nmax * lg Nmax )
* where Nmax = max( NN(j), 2 ) and lg = log base 2.
* Workspace.
* Modified.
*
* RESULT REAL array, dimension (105)
* The values computed by the tests described above.
* The values are currently limited to 1/ulp, to avoid
* overflow.
* Modified.
*
* INFO INTEGER
* If 0, then everything ran OK.
* -1: NSIZES < 0
* -2: Some NN(j) < 0
* -3: NTYPES < 0
* -5: THRESH < 0
* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
* -16: LDU < 1 or LDU < NMAX.
* -21: LWORK too small.
* If SLATMR, SLATMS, SSYTRD, SORGTR, SSTEQR, SSTERF,
* or SORMTR returns an error code, the
* absolute value of it is returned.
* Modified.
*
*-----------------------------------------------------------------------
*
* Some Local Variables and Parameters:
* ---- ----- --------- --- ----------
* ZERO, ONE Real 0 and 1.
* MAXTYP The number of types defined.
* NTEST The number of tests performed, or which can
* be performed so far, for the current matrix.
* NTESTT The total number of tests performed so far.
* NMAX Largest value in NN.
* NMATS The number of matrices generated so far.
* NERRS The number of tests which have exceeded THRESH
* so far (computed by SLAFTS).
* COND, IMODE Values to be passed to the matrix generators.
* ANORM Norm of A; passed to matrix generators.
*
* OVFL, UNFL Overflow and underflow thresholds.
* ULP, ULPINV Finest relative precision and its inverse.
* RTOVFL, RTUNFL Square roots of the previous 2 values.
* The following four arrays decode JTYPE:
* KTYPE(j) The general type (1-10) for type "j".
* KMODE(j) The MODE value to be passed to the matrix
* generator for type "j".
* KMAGN(j) The order of magnitude ( O(1),
* O(overflow^(1/2) ), O(underflow^(1/2) )
*
* The tests performed are: Routine tested
* 1= | A - U S U' | / ( |A| n ulp ) SSTEV('V', ... )
* 2= | I - U U' | / ( n ulp ) SSTEV('V', ... )
* 3= |D(with Z) - D(w/o Z)| / (|D| ulp) SSTEV('N', ... )
* 4= | A - U S U' | / ( |A| n ulp ) SSTEVX('V','A', ... )
* 5= | I - U U' | / ( n ulp ) SSTEVX('V','A', ... )
* 6= |D(with Z) - EVEIGS| / (|D| ulp) SSTEVX('N','A', ... )
* 7= | A - U S U' | / ( |A| n ulp ) SSTEVR('V','A', ... )
* 8= | I - U U' | / ( n ulp ) SSTEVR('V','A', ... )
* 9= |D(with Z) - EVEIGS| / (|D| ulp) SSTEVR('N','A', ... )
* 10= | A - U S U' | / ( |A| n ulp ) SSTEVX('V','I', ... )
* 11= | I - U U' | / ( n ulp ) SSTEVX('V','I', ... )
* 12= |D(with Z) - D(w/o Z)| / (|D| ulp) SSTEVX('N','I', ... )
* 13= | A - U S U' | / ( |A| n ulp ) SSTEVX('V','V', ... )
* 14= | I - U U' | / ( n ulp ) SSTEVX('V','V', ... )
* 15= |D(with Z) - D(w/o Z)| / (|D| ulp) SSTEVX('N','V', ... )
* 16= | A - U S U' | / ( |A| n ulp ) SSTEVD('V', ... )
* 17= | I - U U' | / ( n ulp ) SSTEVD('V', ... )
* 18= |D(with Z) - EVEIGS| / (|D| ulp) SSTEVD('N', ... )
* 19= | A - U S U' | / ( |A| n ulp ) SSTEVR('V','I', ... )
* 20= | I - U U' | / ( n ulp ) SSTEVR('V','I', ... )
* 21= |D(with Z) - D(w/o Z)| / (|D| ulp) SSTEVR('N','I', ... )
* 22= | A - U S U' | / ( |A| n ulp ) SSTEVR('V','V', ... )
* 23= | I - U U' | / ( n ulp ) SSTEVR('V','V', ... )
* 24= |D(with Z) - D(w/o Z)| / (|D| ulp) SSTEVR('N','V', ... )
*
* 25= | A - U S U' | / ( |A| n ulp ) SSYEV('L','V', ... )
* 26= | I - U U' | / ( n ulp ) SSYEV('L','V', ... )
* 27= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEV('L','N', ... )
* 28= | A - U S U' | / ( |A| n ulp ) SSYEVX('L','V','A', ... )
* 29= | I - U U' | / ( n ulp ) SSYEVX('L','V','A', ... )
* 30= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVX('L','N','A', ... )
* 31= | A - U S U' | / ( |A| n ulp ) SSYEVX('L','V','I', ... )
* 32= | I - U U' | / ( n ulp ) SSYEVX('L','V','I', ... )
* 33= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVX('L','N','I', ... )
* 34= | A - U S U' | / ( |A| n ulp ) SSYEVX('L','V','V', ... )
* 35= | I - U U' | / ( n ulp ) SSYEVX('L','V','V', ... )
* 36= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVX('L','N','V', ... )
* 37= | A - U S U' | / ( |A| n ulp ) SSPEV('L','V', ... )
* 38= | I - U U' | / ( n ulp ) SSPEV('L','V', ... )
* 39= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEV('L','N', ... )
* 40= | A - U S U' | / ( |A| n ulp ) SSPEVX('L','V','A', ... )
* 41= | I - U U' | / ( n ulp ) SSPEVX('L','V','A', ... )
* 42= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVX('L','N','A', ... )
* 43= | A - U S U' | / ( |A| n ulp ) SSPEVX('L','V','I', ... )
* 44= | I - U U' | / ( n ulp ) SSPEVX('L','V','I', ... )
* 45= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVX('L','N','I', ... )
* 46= | A - U S U' | / ( |A| n ulp ) SSPEVX('L','V','V', ... )
* 47= | I - U U' | / ( n ulp ) SSPEVX('L','V','V', ... )
* 48= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVX('L','N','V', ... )
* 49= | A - U S U' | / ( |A| n ulp ) SSBEV('L','V', ... )
* 50= | I - U U' | / ( n ulp ) SSBEV('L','V', ... )
* 51= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEV('L','N', ... )
* 52= | A - U S U' | / ( |A| n ulp ) SSBEVX('L','V','A', ... )
* 53= | I - U U' | / ( n ulp ) SSBEVX('L','V','A', ... )
* 54= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVX('L','N','A', ... )
* 55= | A - U S U' | / ( |A| n ulp ) SSBEVX('L','V','I', ... )
* 56= | I - U U' | / ( n ulp ) SSBEVX('L','V','I', ... )
* 57= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVX('L','N','I', ... )
* 58= | A - U S U' | / ( |A| n ulp ) SSBEVX('L','V','V', ... )
* 59= | I - U U' | / ( n ulp ) SSBEVX('L','V','V', ... )
* 60= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVX('L','N','V', ... )
* 61= | A - U S U' | / ( |A| n ulp ) SSYEVD('L','V', ... )
* 62= | I - U U' | / ( n ulp ) SSYEVD('L','V', ... )
* 63= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVD('L','N', ... )
* 64= | A - U S U' | / ( |A| n ulp ) SSPEVD('L','V', ... )
* 65= | I - U U' | / ( n ulp ) SSPEVD('L','V', ... )
* 66= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVD('L','N', ... )
* 67= | A - U S U' | / ( |A| n ulp ) SSBEVD('L','V', ... )
* 68= | I - U U' | / ( n ulp ) SSBEVD('L','V', ... )
* 69= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVD('L','N', ... )
* 70= | A - U S U' | / ( |A| n ulp ) SSYEVR('L','V','A', ... )
* 71= | I - U U' | / ( n ulp ) SSYEVR('L','V','A', ... )
* 72= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVR('L','N','A', ... )
* 73= | A - U S U' | / ( |A| n ulp ) SSYEVR('L','V','I', ... )
* 74= | I - U U' | / ( n ulp ) SSYEVR('L','V','I', ... )
* 75= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVR('L','N','I', ... )
* 76= | A - U S U' | / ( |A| n ulp ) SSYEVR('L','V','V', ... )
* 77= | I - U U' | / ( n ulp ) SSYEVR('L','V','V', ... )
* 78= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVR('L','N','V', ... )
*
* Tests 25 through 78 are repeated (as tests 79 through 132)
* with UPLO='U'
*
* To be added in 1999
*
* 79= | A - U S U' | / ( |A| n ulp ) SSPEVR('L','V','A', ... )
* 80= | I - U U' | / ( n ulp ) SSPEVR('L','V','A', ... )
* 81= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVR('L','N','A', ... )
* 82= | A - U S U' | / ( |A| n ulp ) SSPEVR('L','V','I', ... )
* 83= | I - U U' | / ( n ulp ) SSPEVR('L','V','I', ... )
* 84= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVR('L','N','I', ... )
* 85= | A - U S U' | / ( |A| n ulp ) SSPEVR('L','V','V', ... )
* 86= | I - U U' | / ( n ulp ) SSPEVR('L','V','V', ... )
* 87= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVR('L','N','V', ... )
* 88= | A - U S U' | / ( |A| n ulp ) SSBEVR('L','V','A', ... )
* 89= | I - U U' | / ( n ulp ) SSBEVR('L','V','A', ... )
* 90= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVR('L','N','A', ... )
* 91= | A - U S U' | / ( |A| n ulp ) SSBEVR('L','V','I', ... )
* 92= | I - U U' | / ( n ulp ) SSBEVR('L','V','I', ... )
* 93= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVR('L','N','I', ... )
* 94= | A - U S U' | / ( |A| n ulp ) SSBEVR('L','V','V', ... )
* 95= | I - U U' | / ( n ulp ) SSBEVR('L','V','V', ... )
* 96= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVR('L','N','V', ... )
*
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO, TEN
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ TEN = 10.0E0 )
REAL HALF
PARAMETER ( HALF = 0.5E0 )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 18 )
* ..
* .. Local Scalars ..
LOGICAL BADNN
CHARACTER UPLO
INTEGER I, IDIAG, IHBW, IINFO, IL, IMODE, INDX, IROW,
$ ITEMP, ITYPE, IU, IUPLO, J, J1, J2, JCOL,
$ JSIZE, JTYPE, KD, LGN, LIWEDC, LWEDC, M, M2,
$ M3, MTYPES, N, NERRS, NMATS, NMAX, NTEST,
$ NTESTT
REAL ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
$ RTUNFL, TEMP1, TEMP2, TEMP3, ULP, ULPINV, UNFL,
$ VL, VU
* ..
* .. Local Arrays ..
INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
$ ISEED3( 4 ), KMAGN( MAXTYP ), KMODE( MAXTYP ),
$ KTYPE( MAXTYP )
* ..
* .. External Functions ..
REAL SLAMCH, SLARND, SSXT1
EXTERNAL SLAMCH, SLARND, SSXT1
* ..
* .. External Subroutines ..
EXTERNAL ALASVM, SLABAD, SLACPY, SLAFTS, SLASET, SLATMR,
$ SLATMS, SSBEV, SSBEVD, SSBEVX, SSPEV, SSPEVD,
$ SSPEVX, SSTEV, SSTEVD, SSTEVR, SSTEVX, SSTT21,
$ SSTT22, SSYEV, SSYEVD, SSYEVR, SSYEVX, SSYT21,
$ SSYT22, XERBLA
* ..
* .. Scalars in Common ..
CHARACTER*6 SRNAMT
* ..
* .. Common blocks ..
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX, MIN, REAL, SQRT
* ..
* .. Data statements ..
DATA KTYPE / 1, 2, 5*4, 5*5, 3*8, 3*9 /
DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
$ 2, 3, 1, 2, 3 /
DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
$ 0, 0, 4, 4, 4 /
* ..
* .. Executable Statements ..
*
* Keep ftrnchek happy
*
VL = ZERO
VU = ZERO
*
* 1) Check for errors
*
NTESTT = 0
INFO = 0
*
BADNN = .FALSE.
NMAX = 1
DO 10 J = 1, NSIZES
NMAX = MAX( NMAX, NN( J ) )
IF( NN( J ).LT.0 )
$ BADNN = .TRUE.
10 CONTINUE
*
* Check for errors
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADNN ) THEN
INFO = -2
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.NMAX ) THEN
INFO = -9
ELSE IF( LDU.LT.NMAX ) THEN
INFO = -16
ELSE IF( 2*MAX( 2, NMAX )**2.GT.LWORK ) THEN
INFO = -21
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SDRVST', -INFO )
RETURN
END IF
*
* Quick return if nothing to do
*
IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
$ RETURN
*
* More Important constants
*
UNFL = SLAMCH( 'Safe minimum' )
OVFL = SLAMCH( 'Overflow' )
CALL SLABAD( UNFL, OVFL )
ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
ULPINV = ONE / ULP
RTUNFL = SQRT( UNFL )
RTOVFL = SQRT( OVFL )
*
* Loop over sizes, types
*
DO 20 I = 1, 4
ISEED2( I ) = ISEED( I )
ISEED3( I ) = ISEED( I )
20 CONTINUE
*
NERRS = 0
NMATS = 0
*
*
DO 1740 JSIZE = 1, NSIZES
N = NN( JSIZE )
IF( N.GT.0 ) THEN
LGN = INT( LOG( REAL( N ) ) / LOG( TWO ) )
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
LWEDC = 1 + 4*N + 2*N*LGN + 4*N**2
c LIWEDC = 6 + 6*N + 5*N*LGN
LIWEDC = 3 + 5*N
ELSE
LWEDC = 9
c LIWEDC = 12
LIWEDC = 8
END IF
ANINV = ONE / REAL( MAX( 1, N ) )
*
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
DO 1730 JTYPE = 1, MTYPES
*
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 1730
NMATS = NMATS + 1
NTEST = 0
*
DO 30 J = 1, 4
IOLDSD( J ) = ISEED( J )
30 CONTINUE
*
* 2) Compute "A"
*
* Control parameters:
*
* KMAGN KMODE KTYPE
* =1 O(1) clustered 1 zero
* =2 large clustered 2 identity
* =3 small exponential (none)
* =4 arithmetic diagonal, (w/ eigenvalues)
* =5 random log symmetric, w/ eigenvalues
* =6 random (none)
* =7 random diagonal
* =8 random symmetric
* =9 band symmetric, w/ eigenvalues
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 110
*
ITYPE = KTYPE( JTYPE )
IMODE = KMODE( JTYPE )
*
* Compute norm
*
GO TO ( 40, 50, 60 )KMAGN( JTYPE )
*
40 CONTINUE
ANORM = ONE
GO TO 70
*
50 CONTINUE
ANORM = ( RTOVFL*ULP )*ANINV
GO TO 70
*
60 CONTINUE
ANORM = RTUNFL*N*ULPINV
GO TO 70
*
70 CONTINUE
*
CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
IINFO = 0
COND = ULPINV
*
* Special Matrices -- Identity & Jordan block
*
* Zero
*
IF( ITYPE.EQ.1 ) THEN
IINFO = 0
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Identity
*
DO 80 JCOL = 1, N
A( JCOL, JCOL ) = ANORM
80 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Diagonal Matrix, [Eigen]values Specified
*
CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.5 ) THEN
*
* Symmetric, eigenvalues specified
*
CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, N, N, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.7 ) THEN
*
* Diagonal, random eigenvalues
*
IDUMMA( 1 ) = 1
CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.8 ) THEN
*
* Symmetric, random eigenvalues
*
IDUMMA( 1 ) = 1
CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.9 ) THEN
*
* Symmetric banded, eigenvalues specified
*
IHBW = INT( ( N-1 )*SLARND( 1, ISEED3 ) )
CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, IHBW, IHBW, 'Z', U, LDU, WORK( N+1 ),
$ IINFO )
*
* Store as dense matrix for most routines.
*
CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
DO 100 IDIAG = -IHBW, IHBW
IROW = IHBW - IDIAG + 1
J1 = MAX( 1, IDIAG+1 )
J2 = MIN( N, N+IDIAG )
DO 90 J = J1, J2
I = J - IDIAG
A( I, J ) = U( IROW, J )
90 CONTINUE
100 CONTINUE
ELSE
IINFO = 1
END IF
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
110 CONTINUE
*
ABSTOL = UNFL + UNFL
IF( N.LE.1 ) THEN
IL = 1
IU = N
ELSE
IL = 1 + INT( ( N-1 )*SLARND( 1, ISEED2 ) )
IU = 1 + INT( ( N-1 )*SLARND( 1, ISEED2 ) )
IF( IL.GT.IU ) THEN
ITEMP = IL
IL = IU
IU = ITEMP
END IF
END IF
*
* 3) If matrix is tridiagonal, call SSTEV and SSTEVX.
*
IF( JTYPE.LE.7 ) THEN
NTEST = 1
DO 120 I = 1, N
D1( I ) = REAL( A( I, I ) )
120 CONTINUE
DO 130 I = 1, N - 1
D2( I ) = REAL( A( I+1, I ) )
130 CONTINUE
SRNAMT = 'SSTEV'
CALL SSTEV( 'V', N, D1, D2, Z, LDU, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEV(V)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 1 ) = ULPINV
RESULT( 2 ) = ULPINV
RESULT( 3 ) = ULPINV
GO TO 180
END IF
END IF
*
* Do tests 1 and 2.
*
DO 140 I = 1, N
D3( I ) = REAL( A( I, I ) )
140 CONTINUE
DO 150 I = 1, N - 1
D4( I ) = REAL( A( I+1, I ) )
150 CONTINUE
CALL SSTT21( N, 0, D3, D4, D1, D2, Z, LDU, WORK,
$ RESULT( 1 ) )
*
NTEST = 3
DO 160 I = 1, N - 1
D4( I ) = REAL( A( I+1, I ) )
160 CONTINUE
SRNAMT = 'SSTEV'
CALL SSTEV( 'N', N, D3, D4, Z, LDU, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEV(N)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 3 ) = ULPINV
GO TO 180
END IF
END IF
*
* Do test 3.
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 170 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) )
170 CONTINUE
RESULT( 3 ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
180 CONTINUE
*
NTEST = 4
DO 190 I = 1, N
EVEIGS( I ) = D3( I )
D1( I ) = REAL( A( I, I ) )
190 CONTINUE
DO 200 I = 1, N - 1
D2( I ) = REAL( A( I+1, I ) )
200 CONTINUE
SRNAMT = 'SSTEVX'
CALL SSTEVX( 'V', 'A', N, D1, D2, VL, VU, IL, IU, ABSTOL,
$ M, WA1, Z, LDU, WORK, IWORK, IWORK( 5*N+1 ),
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEVX(V,A)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 4 ) = ULPINV
RESULT( 5 ) = ULPINV
RESULT( 6 ) = ULPINV
GO TO 250
END IF
END IF
IF( N.GT.0 ) THEN
TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) )
ELSE
TEMP3 = ZERO
END IF
*
* Do tests 4 and 5.
*
DO 210 I = 1, N
D3( I ) = REAL( A( I, I ) )
210 CONTINUE
DO 220 I = 1, N - 1
D4( I ) = REAL( A( I+1, I ) )
220 CONTINUE
CALL SSTT21( N, 0, D3, D4, WA1, D2, Z, LDU, WORK,
$ RESULT( 4 ) )
*
NTEST = 6
DO 230 I = 1, N - 1
D4( I ) = REAL( A( I+1, I ) )
230 CONTINUE
SRNAMT = 'SSTEVX'
CALL SSTEVX( 'N', 'A', N, D3, D4, VL, VU, IL, IU, ABSTOL,
$ M2, WA2, Z, LDU, WORK, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEVX(N,A)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 6 ) = ULPINV
GO TO 250
END IF
END IF
*
* Do test 6.
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 240 J = 1, N
TEMP1 = MAX( TEMP1, ABS( WA2( J ) ),
$ ABS( EVEIGS( J ) ) )
TEMP2 = MAX( TEMP2, ABS( WA2( J )-EVEIGS( J ) ) )
240 CONTINUE
RESULT( 6 ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
250 CONTINUE
*
NTEST = 7
DO 260 I = 1, N
D1( I ) = REAL( A( I, I ) )
260 CONTINUE
DO 270 I = 1, N - 1
D2( I ) = REAL( A( I+1, I ) )
270 CONTINUE
SRNAMT = 'SSTEVR'
CALL SSTEVR( 'V', 'A', N, D1, D2, VL, VU, IL, IU, ABSTOL,
$ M, WA1, Z, LDU, IWORK, WORK, LWORK,
$ IWORK(2*N+1), LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEVR(V,A)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 7 ) = ULPINV
RESULT( 8 ) = ULPINV
GO TO 320
END IF
END IF
IF( N.GT.0 ) THEN
TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) )
ELSE
TEMP3 = ZERO
END IF
*
* Do tests 7 and 8.
*
DO 280 I = 1, N
D3( I ) = REAL( A( I, I ) )
280 CONTINUE
DO 290 I = 1, N - 1
D4( I ) = REAL( A( I+1, I ) )
290 CONTINUE
CALL SSTT21( N, 0, D3, D4, WA1, D2, Z, LDU, WORK,
$ RESULT( 7 ) )
*
NTEST = 9
DO 300 I = 1, N - 1
D4( I ) = REAL( A( I+1, I ) )
300 CONTINUE
SRNAMT = 'SSTEVR'
CALL SSTEVR( 'N', 'A', N, D3, D4, VL, VU, IL, IU, ABSTOL,
$ M2, WA2, Z, LDU, IWORK, WORK, LWORK,
$ IWORK(2*N+1), LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEVR(N,A)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 9 ) = ULPINV
GO TO 320
END IF
END IF
*
* Do test 9.
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 310 J = 1, N
TEMP1 = MAX( TEMP1, ABS( WA2( J ) ),
$ ABS( EVEIGS( J ) ) )
TEMP2 = MAX( TEMP2, ABS( WA2( J )-EVEIGS( J ) ) )
310 CONTINUE
RESULT( 9 ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
320 CONTINUE
*
*
NTEST = 10
DO 330 I = 1, N
D1( I ) = REAL( A( I, I ) )
330 CONTINUE
DO 340 I = 1, N - 1
D2( I ) = REAL( A( I+1, I ) )
340 CONTINUE
SRNAMT = 'SSTEVX'
CALL SSTEVX( 'V', 'I', N, D1, D2, VL, VU, IL, IU, ABSTOL,
$ M2, WA2, Z, LDU, WORK, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEVX(V,I)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 10 ) = ULPINV
RESULT( 11 ) = ULPINV
RESULT( 12 ) = ULPINV
GO TO 380
END IF
END IF
*
* Do tests 10 and 11.
*
DO 350 I = 1, N
D3( I ) = REAL( A( I, I ) )
350 CONTINUE
DO 360 I = 1, N - 1
D4( I ) = REAL( A( I+1, I ) )
360 CONTINUE
CALL SSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK,
$ MAX( 1, M2 ), RESULT( 10 ) )
*
*
NTEST = 12
DO 370 I = 1, N - 1
D4( I ) = REAL( A( I+1, I ) )
370 CONTINUE
SRNAMT = 'SSTEVX'
CALL SSTEVX( 'N', 'I', N, D3, D4, VL, VU, IL, IU, ABSTOL,
$ M3, WA3, Z, LDU, WORK, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEVX(N,I)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 12 ) = ULPINV
GO TO 380
END IF
END IF
*
* Do test 12.
*
TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
RESULT( 12 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, ULP*TEMP3 )
*
380 CONTINUE
*
NTEST = 12
IF( N.GT.0 ) THEN
IF( IL.NE.1 ) THEN
VL = WA1( IL ) - MAX( HALF*
$ ( WA1( IL )-WA1( IL-1 ) ), TEN*ULP*TEMP3,
$ TEN*RTUNFL )
ELSE
VL = WA1( 1 ) - MAX( HALF*( WA1( N )-WA1( 1 ) ),
$ TEN*ULP*TEMP3, TEN*RTUNFL )
END IF
IF( IU.NE.N ) THEN
VU = WA1( IU ) + MAX( HALF*
$ ( WA1( IU+1 )-WA1( IU ) ), TEN*ULP*TEMP3,
$ TEN*RTUNFL )
ELSE
VU = WA1( N ) + MAX( HALF*( WA1( N )-WA1( 1 ) ),
$ TEN*ULP*TEMP3, TEN*RTUNFL )
END IF
ELSE
VL = ZERO
VU = ONE
END IF
*
DO 390 I = 1, N
D1( I ) = REAL( A( I, I ) )
390 CONTINUE
DO 400 I = 1, N - 1
D2( I ) = REAL( A( I+1, I ) )
400 CONTINUE
SRNAMT = 'SSTEVX'
CALL SSTEVX( 'V', 'V', N, D1, D2, VL, VU, IL, IU, ABSTOL,
$ M2, WA2, Z, LDU, WORK, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEVX(V,V)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 13 ) = ULPINV
RESULT( 14 ) = ULPINV
RESULT( 15 ) = ULPINV
GO TO 440
END IF
END IF
*
IF( M2.EQ.0 .AND. N.GT.0 ) THEN
RESULT( 13 ) = ULPINV
RESULT( 14 ) = ULPINV
RESULT( 15 ) = ULPINV
GO TO 440
END IF
*
* Do tests 13 and 14.
*
DO 410 I = 1, N
D3( I ) = REAL( A( I, I ) )
410 CONTINUE
DO 420 I = 1, N - 1
D4( I ) = REAL( A( I+1, I ) )
420 CONTINUE
CALL SSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK,
$ MAX( 1, M2 ), RESULT( 13 ) )
*
NTEST = 15
DO 430 I = 1, N - 1
D4( I ) = REAL( A( I+1, I ) )
430 CONTINUE
SRNAMT = 'SSTEVX'
CALL SSTEVX( 'N', 'V', N, D3, D4, VL, VU, IL, IU, ABSTOL,
$ M3, WA3, Z, LDU, WORK, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEVX(N,V)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 15 ) = ULPINV
GO TO 440
END IF
END IF
*
* Do test 15.
*
TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
RESULT( 15 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, TEMP3*ULP )
*
440 CONTINUE
*
NTEST = 16
DO 450 I = 1, N
D1( I ) = REAL( A( I, I ) )
450 CONTINUE
DO 460 I = 1, N - 1
D2( I ) = REAL( A( I+1, I ) )
460 CONTINUE
SRNAMT = 'SSTEVD'
CALL SSTEVD( 'V', N, D1, D2, Z, LDU, WORK, LWEDC, IWORK,
$ LIWEDC, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEVD(V)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 16 ) = ULPINV
RESULT( 17 ) = ULPINV
RESULT( 18 ) = ULPINV
GO TO 510
END IF
END IF
*
* Do tests 16 and 17.
*
DO 470 I = 1, N
D3( I ) = REAL( A( I, I ) )
470 CONTINUE
DO 480 I = 1, N - 1
D4( I ) = REAL( A( I+1, I ) )
480 CONTINUE
CALL SSTT21( N, 0, D3, D4, D1, D2, Z, LDU, WORK,
$ RESULT( 16 ) )
*
NTEST = 18
DO 490 I = 1, N - 1
D4( I ) = REAL( A( I+1, I ) )
490 CONTINUE
SRNAMT = 'SSTEVD'
CALL SSTEVD( 'N', N, D3, D4, Z, LDU, WORK, LWEDC, IWORK,
$ LIWEDC, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEVD(N)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 18 ) = ULPINV
GO TO 510
END IF
END IF
*
* Do test 18.
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 500 J = 1, N
TEMP1 = MAX( TEMP1, ABS( EVEIGS( J ) ),
$ ABS( D3( J ) ) )
TEMP2 = MAX( TEMP2, ABS( EVEIGS( J )-D3( J ) ) )
500 CONTINUE
RESULT( 18 ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
510 CONTINUE
*
NTEST = 19
DO 520 I = 1, N
D1( I ) = REAL( A( I, I ) )
520 CONTINUE
DO 530 I = 1, N - 1
D2( I ) = REAL( A( I+1, I ) )
530 CONTINUE
SRNAMT = 'SSTEVR'
CALL SSTEVR( 'V', 'I', N, D1, D2, VL, VU, IL, IU, ABSTOL,
$ M2, WA2, Z, LDU, IWORK, WORK, LWORK,
$ IWORK(2*N+1), LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEVR(V,I)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 19 ) = ULPINV
RESULT( 20 ) = ULPINV
RESULT( 21 ) = ULPINV
GO TO 570
END IF
END IF
*
* DO tests 19 and 20.
*
DO 540 I = 1, N
D3( I ) = REAL( A( I, I ) )
540 CONTINUE
DO 550 I = 1, N - 1
D4( I ) = REAL( A( I+1, I ) )
550 CONTINUE
CALL SSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK,
$ MAX( 1, M2 ), RESULT( 19 ) )
*
*
NTEST = 21
DO 560 I = 1, N - 1
D4( I ) = REAL( A( I+1, I ) )
560 CONTINUE
SRNAMT = 'SSTEVR'
CALL SSTEVR( 'N', 'I', N, D3, D4, VL, VU, IL, IU, ABSTOL,
$ M3, WA3, Z, LDU, IWORK, WORK, LWORK,
$ IWORK(2*N+1), LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEVR(N,I)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 21 ) = ULPINV
GO TO 570
END IF
END IF
*
* Do test 21.
*
TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
RESULT( 21 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, ULP*TEMP3 )
*
570 CONTINUE
*
NTEST = 21
IF( N.GT.0 ) THEN
IF( IL.NE.1 ) THEN
VL = WA1( IL ) - MAX( HALF*
$ ( WA1( IL )-WA1( IL-1 ) ), TEN*ULP*TEMP3,
$ TEN*RTUNFL )
ELSE
VL = WA1( 1 ) - MAX( HALF*( WA1( N )-WA1( 1 ) ),
$ TEN*ULP*TEMP3, TEN*RTUNFL )
END IF
IF( IU.NE.N ) THEN
VU = WA1( IU ) + MAX( HALF*
$ ( WA1( IU+1 )-WA1( IU ) ), TEN*ULP*TEMP3,
$ TEN*RTUNFL )
ELSE
VU = WA1( N ) + MAX( HALF*( WA1( N )-WA1( 1 ) ),
$ TEN*ULP*TEMP3, TEN*RTUNFL )
END IF
ELSE
VL = ZERO
VU = ONE
END IF
*
DO 580 I = 1, N
D1( I ) = REAL( A( I, I ) )
580 CONTINUE
DO 590 I = 1, N - 1
D2( I ) = REAL( A( I+1, I ) )
590 CONTINUE
SRNAMT = 'SSTEVR'
CALL SSTEVR( 'V', 'V', N, D1, D2, VL, VU, IL, IU, ABSTOL,
$ M2, WA2, Z, LDU, IWORK, WORK, LWORK,
$ IWORK(2*N+1), LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEVR(V,V)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 22 ) = ULPINV
RESULT( 23 ) = ULPINV
RESULT( 24 ) = ULPINV
GO TO 630
END IF
END IF
*
IF( M2.EQ.0 .AND. N.GT.0 ) THEN
RESULT( 22 ) = ULPINV
RESULT( 23 ) = ULPINV
RESULT( 24 ) = ULPINV
GO TO 630
END IF
*
* Do tests 22 and 23.
*
DO 600 I = 1, N
D3( I ) = REAL( A( I, I ) )
600 CONTINUE
DO 610 I = 1, N - 1
D4( I ) = REAL( A( I+1, I ) )
610 CONTINUE
CALL SSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK,
$ MAX( 1, M2 ), RESULT( 22 ) )
*
NTEST = 24
DO 620 I = 1, N - 1
D4( I ) = REAL( A( I+1, I ) )
620 CONTINUE
SRNAMT = 'SSTEVR'
CALL SSTEVR( 'N', 'V', N, D3, D4, VL, VU, IL, IU, ABSTOL,
$ M3, WA3, Z, LDU, IWORK, WORK, LWORK,
$ IWORK(2*N+1), LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSTEVR(N,V)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 24 ) = ULPINV
GO TO 630
END IF
END IF
*
* Do test 24.
*
TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
RESULT( 24 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, TEMP3*ULP )
*
630 CONTINUE
*
*
*
ELSE
*
DO 640 I = 1, 24
RESULT( I ) = ZERO
640 CONTINUE
NTEST = 24
END IF
*
* Perform remaining tests storing upper or lower triangular
* part of matrix.
*
DO 1720 IUPLO = 0, 1
IF( IUPLO.EQ.0 ) THEN
UPLO = 'L'
ELSE
UPLO = 'U'
END IF
*
* 4) Call SSYEV and SSYEVX.
*
CALL SLACPY( ' ', N, N, A, LDA, V, LDU )
*
NTEST = NTEST + 1
SRNAMT = 'SSYEV'
CALL SSYEV( 'V', UPLO, N, A, LDU, D1, WORK, LWORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSYEV(V,' // UPLO // ')',
$ IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 660
END IF
END IF
*
* Do tests 25 and 26 (or +54)
*
CALL SSYT21( 1, UPLO, N, 0, V, LDU, D1, D2, A, LDU, Z,
$ LDU, TAU, WORK, RESULT( NTEST ) )
*
CALL SLACPY( ' ', N, N, V, LDU, A, LDA )
*
NTEST = NTEST + 2
SRNAMT = 'SSYEV'
CALL SSYEV( 'N', UPLO, N, A, LDU, D3, WORK, LWORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSYEV(N,' // UPLO // ')',
$ IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 660
END IF
END IF
*
* Do test 27 (or +54)
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 650 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) )
650 CONTINUE
RESULT( NTEST ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
660 CONTINUE
CALL SLACPY( ' ', N, N, V, LDU, A, LDA )
*
NTEST = NTEST + 1
*
IF( N.GT.0 ) THEN
TEMP3 = MAX( ABS( D1( 1 ) ), ABS( D1( N ) ) )
IF( IL.NE.1 ) THEN
VL = D1( IL ) - MAX( HALF*( D1( IL )-D1( IL-1 ) ),
$ TEN*ULP*TEMP3, TEN*RTUNFL )
ELSE IF( N.GT.0 ) THEN
VL = D1( 1 ) - MAX( HALF*( D1( N )-D1( 1 ) ),
$ TEN*ULP*TEMP3, TEN*RTUNFL )
END IF
IF( IU.NE.N ) THEN
VU = D1( IU ) + MAX( HALF*( D1( IU+1 )-D1( IU ) ),
$ TEN*ULP*TEMP3, TEN*RTUNFL )
ELSE IF( N.GT.0 ) THEN
VU = D1( N ) + MAX( HALF*( D1( N )-D1( 1 ) ),
$ TEN*ULP*TEMP3, TEN*RTUNFL )
END IF
ELSE
TEMP3 = ZERO
VL = ZERO
VU = ONE
END IF
*
SRNAMT = 'SSYEVX'
CALL SSYEVX( 'V', 'A', UPLO, N, A, LDU, VL, VU, IL, IU,
$ ABSTOL, M, WA1, Z, LDU, WORK, LWORK, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSYEVX(V,A,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 680
END IF
END IF
*
* Do tests 28 and 29 (or +54)
*
CALL SLACPY( ' ', N, N, V, LDU, A, LDA )
*
CALL SSYT21( 1, UPLO, N, 0, A, LDU, D1, D2, Z, LDU, V,
$ LDU, TAU, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 2
SRNAMT = 'SSYEVX'
CALL SSYEVX( 'N', 'A', UPLO, N, A, LDU, VL, VU, IL, IU,
$ ABSTOL, M2, WA2, Z, LDU, WORK, LWORK, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSYEVX(N,A,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 680
END IF
END IF
*
* Do test 30 (or +54)
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 670 J = 1, N
TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) )
TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) )
670 CONTINUE
RESULT( NTEST ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
680 CONTINUE
*
NTEST = NTEST + 1
CALL SLACPY( ' ', N, N, V, LDU, A, LDA )
SRNAMT = 'SSYEVX'
CALL SSYEVX( 'V', 'I', UPLO, N, A, LDU, VL, VU, IL, IU,
$ ABSTOL, M2, WA2, Z, LDU, WORK, LWORK, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSYEVX(V,I,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 690
END IF
END IF
*
* Do tests 31 and 32 (or +54)
*
CALL SLACPY( ' ', N, N, V, LDU, A, LDA )
*
CALL SSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU,
$ V, LDU, TAU, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 2
CALL SLACPY( ' ', N, N, V, LDU, A, LDA )
SRNAMT = 'SSYEVX'
CALL SSYEVX( 'N', 'I', UPLO, N, A, LDU, VL, VU, IL, IU,
$ ABSTOL, M3, WA3, Z, LDU, WORK, LWORK, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSYEVX(N,I,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 690
END IF
END IF
*
* Do test 33 (or +54)
*
TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
RESULT( NTEST ) = ( TEMP1+TEMP2 ) /
$ MAX( UNFL, ULP*TEMP3 )
690 CONTINUE
*
NTEST = NTEST + 1
CALL SLACPY( ' ', N, N, V, LDU, A, LDA )
SRNAMT = 'SSYEVX'
CALL SSYEVX( 'V', 'V', UPLO, N, A, LDU, VL, VU, IL, IU,
$ ABSTOL, M2, WA2, Z, LDU, WORK, LWORK, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSYEVX(V,V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 700
END IF
END IF
*
* Do tests 34 and 35 (or +54)
*
CALL SLACPY( ' ', N, N, V, LDU, A, LDA )
*
CALL SSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU,
$ V, LDU, TAU, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 2
CALL SLACPY( ' ', N, N, V, LDU, A, LDA )
SRNAMT = 'SSYEVX'
CALL SSYEVX( 'N', 'V', UPLO, N, A, LDU, VL, VU, IL, IU,
$ ABSTOL, M3, WA3, Z, LDU, WORK, LWORK, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSYEVX(N,V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 700
END IF
END IF
*
IF( M3.EQ.0 .AND. N.GT.0 ) THEN
RESULT( NTEST ) = ULPINV
GO TO 700
END IF
*
* Do test 36 (or +54)
*
TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
IF( N.GT.0 ) THEN
TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) )
ELSE
TEMP3 = ZERO
END IF
RESULT( NTEST ) = ( TEMP1+TEMP2 ) /
$ MAX( UNFL, TEMP3*ULP )
*
700 CONTINUE
*
* 5) Call SSPEV and SSPEVX.
*
CALL SLACPY( ' ', N, N, V, LDU, A, LDA )
*
* Load array WORK with the upper or lower triangular
* part of the matrix in packed form.
*
IF( IUPLO.EQ.1 ) THEN
INDX = 1
DO 720 J = 1, N
DO 710 I = 1, J
WORK( INDX ) = A( I, J )
INDX = INDX + 1
710 CONTINUE
720 CONTINUE
ELSE
INDX = 1
DO 740 J = 1, N
DO 730 I = J, N
WORK( INDX ) = A( I, J )
INDX = INDX + 1
730 CONTINUE
740 CONTINUE
END IF
*
NTEST = NTEST + 1
SRNAMT = 'SSPEV'
CALL SSPEV( 'V', UPLO, N, WORK, D1, Z, LDU, V, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSPEV(V,' // UPLO // ')',
$ IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 800
END IF
END IF
*
* Do tests 37 and 38 (or +54)
*
CALL SSYT21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V,
$ LDU, TAU, WORK, RESULT( NTEST ) )
*
IF( IUPLO.EQ.1 ) THEN
INDX = 1
DO 760 J = 1, N
DO 750 I = 1, J
WORK( INDX ) = A( I, J )
INDX = INDX + 1
750 CONTINUE
760 CONTINUE
ELSE
INDX = 1
DO 780 J = 1, N
DO 770 I = J, N
WORK( INDX ) = A( I, J )
INDX = INDX + 1
770 CONTINUE
780 CONTINUE
END IF
*
NTEST = NTEST + 2
SRNAMT = 'SSPEV'
CALL SSPEV( 'N', UPLO, N, WORK, D3, Z, LDU, V, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSPEV(N,' // UPLO // ')',
$ IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 800
END IF
END IF
*
* Do test 39 (or +54)
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 790 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) )
790 CONTINUE
RESULT( NTEST ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
* Load array WORK with the upper or lower triangular part
* of the matrix in packed form.
*
800 CONTINUE
IF( IUPLO.EQ.1 ) THEN
INDX = 1
DO 820 J = 1, N
DO 810 I = 1, J
WORK( INDX ) = A( I, J )
INDX = INDX + 1
810 CONTINUE
820 CONTINUE
ELSE
INDX = 1
DO 840 J = 1, N
DO 830 I = J, N
WORK( INDX ) = A( I, J )
INDX = INDX + 1
830 CONTINUE
840 CONTINUE
END IF
*
NTEST = NTEST + 1
*
IF( N.GT.0 ) THEN
TEMP3 = MAX( ABS( D1( 1 ) ), ABS( D1( N ) ) )
IF( IL.NE.1 ) THEN
VL = D1( IL ) - MAX( HALF*( D1( IL )-D1( IL-1 ) ),
$ TEN*ULP*TEMP3, TEN*RTUNFL )
ELSE IF( N.GT.0 ) THEN
VL = D1( 1 ) - MAX( HALF*( D1( N )-D1( 1 ) ),
$ TEN*ULP*TEMP3, TEN*RTUNFL )
END IF
IF( IU.NE.N ) THEN
VU = D1( IU ) + MAX( HALF*( D1( IU+1 )-D1( IU ) ),
$ TEN*ULP*TEMP3, TEN*RTUNFL )
ELSE IF( N.GT.0 ) THEN
VU = D1( N ) + MAX( HALF*( D1( N )-D1( 1 ) ),
$ TEN*ULP*TEMP3, TEN*RTUNFL )
END IF
ELSE
TEMP3 = ZERO
VL = ZERO
VU = ONE
END IF
*
SRNAMT = 'SSPEVX'
CALL SSPEVX( 'V', 'A', UPLO, N, WORK, VL, VU, IL, IU,
$ ABSTOL, M, WA1, Z, LDU, V, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSPEVX(V,A,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 900
END IF
END IF
*
* Do tests 40 and 41 (or +54)
*
CALL SSYT21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V,
$ LDU, TAU, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 2
*
IF( IUPLO.EQ.1 ) THEN
INDX = 1
DO 860 J = 1, N
DO 850 I = 1, J
WORK( INDX ) = A( I, J )
INDX = INDX + 1
850 CONTINUE
860 CONTINUE
ELSE
INDX = 1
DO 880 J = 1, N
DO 870 I = J, N
WORK( INDX ) = A( I, J )
INDX = INDX + 1
870 CONTINUE
880 CONTINUE
END IF
*
SRNAMT = 'SSPEVX'
CALL SSPEVX( 'N', 'A', UPLO, N, WORK, VL, VU, IL, IU,
$ ABSTOL, M2, WA2, Z, LDU, V, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSPEVX(N,A,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 900
END IF
END IF
*
* Do test 42 (or +54)
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 890 J = 1, N
TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) )
TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) )
890 CONTINUE
RESULT( NTEST ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
900 CONTINUE
IF( IUPLO.EQ.1 ) THEN
INDX = 1
DO 920 J = 1, N
DO 910 I = 1, J
WORK( INDX ) = A( I, J )
INDX = INDX + 1
910 CONTINUE
920 CONTINUE
ELSE
INDX = 1
DO 940 J = 1, N
DO 930 I = J, N
WORK( INDX ) = A( I, J )
INDX = INDX + 1
930 CONTINUE
940 CONTINUE
END IF
*
NTEST = NTEST + 1
*
SRNAMT = 'SSPEVX'
CALL SSPEVX( 'V', 'I', UPLO, N, WORK, VL, VU, IL, IU,
$ ABSTOL, M2, WA2, Z, LDU, V, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSPEVX(V,I,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 990
END IF
END IF
*
* Do tests 43 and 44 (or +54)
*
CALL SSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU,
$ V, LDU, TAU, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 2
*
IF( IUPLO.EQ.1 ) THEN
INDX = 1
DO 960 J = 1, N
DO 950 I = 1, J
WORK( INDX ) = A( I, J )
INDX = INDX + 1
950 CONTINUE
960 CONTINUE
ELSE
INDX = 1
DO 980 J = 1, N
DO 970 I = J, N
WORK( INDX ) = A( I, J )
INDX = INDX + 1
970 CONTINUE
980 CONTINUE
END IF
*
SRNAMT = 'SSPEVX'
CALL SSPEVX( 'N', 'I', UPLO, N, WORK, VL, VU, IL, IU,
$ ABSTOL, M3, WA3, Z, LDU, V, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSPEVX(N,I,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 990
END IF
END IF
*
IF( M3.EQ.0 .AND. N.GT.0 ) THEN
RESULT( NTEST ) = ULPINV
GO TO 990
END IF
*
* Do test 45 (or +54)
*
TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
IF( N.GT.0 ) THEN
TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) )
ELSE
TEMP3 = ZERO
END IF
RESULT( NTEST ) = ( TEMP1+TEMP2 ) /
$ MAX( UNFL, TEMP3*ULP )
*
990 CONTINUE
IF( IUPLO.EQ.1 ) THEN
INDX = 1
DO 1010 J = 1, N
DO 1000 I = 1, J
WORK( INDX ) = A( I, J )
INDX = INDX + 1
1000 CONTINUE
1010 CONTINUE
ELSE
INDX = 1
DO 1030 J = 1, N
DO 1020 I = J, N
WORK( INDX ) = A( I, J )
INDX = INDX + 1
1020 CONTINUE
1030 CONTINUE
END IF
*
NTEST = NTEST + 1
*
SRNAMT = 'SSPEVX'
CALL SSPEVX( 'V', 'V', UPLO, N, WORK, VL, VU, IL, IU,
$ ABSTOL, M2, WA2, Z, LDU, V, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSPEVX(V,V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 1080
END IF
END IF
*
* Do tests 46 and 47 (or +54)
*
CALL SSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU,
$ V, LDU, TAU, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 2
*
IF( IUPLO.EQ.1 ) THEN
INDX = 1
DO 1050 J = 1, N
DO 1040 I = 1, J
WORK( INDX ) = A( I, J )
INDX = INDX + 1
1040 CONTINUE
1050 CONTINUE
ELSE
INDX = 1
DO 1070 J = 1, N
DO 1060 I = J, N
WORK( INDX ) = A( I, J )
INDX = INDX + 1
1060 CONTINUE
1070 CONTINUE
END IF
*
SRNAMT = 'SSPEVX'
CALL SSPEVX( 'N', 'V', UPLO, N, WORK, VL, VU, IL, IU,
$ ABSTOL, M3, WA3, Z, LDU, V, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSPEVX(N,V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 1080
END IF
END IF
*
IF( M3.EQ.0 .AND. N.GT.0 ) THEN
RESULT( NTEST ) = ULPINV
GO TO 1080
END IF
*
* Do test 48 (or +54)
*
TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
IF( N.GT.0 ) THEN
TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) )
ELSE
TEMP3 = ZERO
END IF
RESULT( NTEST ) = ( TEMP1+TEMP2 ) /
$ MAX( UNFL, TEMP3*ULP )
*
1080 CONTINUE
*
* 6) Call SSBEV and SSBEVX.
*
IF( JTYPE.LE.7 ) THEN
KD = 1
ELSE IF( JTYPE.GE.8 .AND. JTYPE.LE.15 ) THEN
KD = MAX( N-1, 0 )
ELSE
KD = IHBW
END IF
*
* Load array V with the upper or lower triangular part
* of the matrix in band form.
*
IF( IUPLO.EQ.1 ) THEN
DO 1100 J = 1, N
DO 1090 I = MAX( 1, J-KD ), J
V( KD+1+I-J, J ) = A( I, J )
1090 CONTINUE
1100 CONTINUE
ELSE
DO 1120 J = 1, N
DO 1110 I = J, MIN( N, J+KD )
V( 1+I-J, J ) = A( I, J )
1110 CONTINUE
1120 CONTINUE
END IF
*
NTEST = NTEST + 1
SRNAMT = 'SSBEV'
CALL SSBEV( 'V', UPLO, N, KD, V, LDU, D1, Z, LDU, WORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSBEV(V,' // UPLO // ')',
$ IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 1180
END IF
END IF
*
* Do tests 49 and 50 (or ... )
*
CALL SSYT21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V,
$ LDU, TAU, WORK, RESULT( NTEST ) )
*
IF( IUPLO.EQ.1 ) THEN
DO 1140 J = 1, N
DO 1130 I = MAX( 1, J-KD ), J
V( KD+1+I-J, J ) = A( I, J )
1130 CONTINUE
1140 CONTINUE
ELSE
DO 1160 J = 1, N
DO 1150 I = J, MIN( N, J+KD )
V( 1+I-J, J ) = A( I, J )
1150 CONTINUE
1160 CONTINUE
END IF
*
NTEST = NTEST + 2
SRNAMT = 'SSBEV'
CALL SSBEV( 'N', UPLO, N, KD, V, LDU, D3, Z, LDU, WORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSBEV(N,' // UPLO // ')',
$ IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 1180
END IF
END IF
*
* Do test 51 (or +54)
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 1170 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) )
1170 CONTINUE
RESULT( NTEST ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
* Load array V with the upper or lower triangular part
* of the matrix in band form.
*
1180 CONTINUE
IF( IUPLO.EQ.1 ) THEN
DO 1200 J = 1, N
DO 1190 I = MAX( 1, J-KD ), J
V( KD+1+I-J, J ) = A( I, J )
1190 CONTINUE
1200 CONTINUE
ELSE
DO 1220 J = 1, N
DO 1210 I = J, MIN( N, J+KD )
V( 1+I-J, J ) = A( I, J )
1210 CONTINUE
1220 CONTINUE
END IF
*
NTEST = NTEST + 1
SRNAMT = 'SSBEVX'
CALL SSBEVX( 'V', 'A', UPLO, N, KD, V, LDU, U, LDU, VL,
$ VU, IL, IU, ABSTOL, M, WA2, Z, LDU, WORK,
$ IWORK, IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSBEVX(V,A,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 1280
END IF
END IF
*
* Do tests 52 and 53 (or +54)
*
CALL SSYT21( 1, UPLO, N, 0, A, LDU, WA2, D2, Z, LDU, V,
$ LDU, TAU, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 2
*
IF( IUPLO.EQ.1 ) THEN
DO 1240 J = 1, N
DO 1230 I = MAX( 1, J-KD ), J
V( KD+1+I-J, J ) = A( I, J )
1230 CONTINUE
1240 CONTINUE
ELSE
DO 1260 J = 1, N
DO 1250 I = J, MIN( N, J+KD )
V( 1+I-J, J ) = A( I, J )
1250 CONTINUE
1260 CONTINUE
END IF
*
SRNAMT = 'SSBEVX'
CALL SSBEVX( 'N', 'A', UPLO, N, KD, V, LDU, U, LDU, VL,
$ VU, IL, IU, ABSTOL, M3, WA3, Z, LDU, WORK,
$ IWORK, IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSBEVX(N,A,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 1280
END IF
END IF
*
* Do test 54 (or +54)
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 1270 J = 1, N
TEMP1 = MAX( TEMP1, ABS( WA2( J ) ), ABS( WA3( J ) ) )
TEMP2 = MAX( TEMP2, ABS( WA2( J )-WA3( J ) ) )
1270 CONTINUE
RESULT( NTEST ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
1280 CONTINUE
NTEST = NTEST + 1
IF( IUPLO.EQ.1 ) THEN
DO 1300 J = 1, N
DO 1290 I = MAX( 1, J-KD ), J
V( KD+1+I-J, J ) = A( I, J )
1290 CONTINUE
1300 CONTINUE
ELSE
DO 1320 J = 1, N
DO 1310 I = J, MIN( N, J+KD )
V( 1+I-J, J ) = A( I, J )
1310 CONTINUE
1320 CONTINUE
END IF
*
SRNAMT = 'SSBEVX'
CALL SSBEVX( 'V', 'I', UPLO, N, KD, V, LDU, U, LDU, VL,
$ VU, IL, IU, ABSTOL, M2, WA2, Z, LDU, WORK,
$ IWORK, IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSBEVX(V,I,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 1370
END IF
END IF
*
* Do tests 55 and 56 (or +54)
*
CALL SSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU,
$ V, LDU, TAU, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 2
*
IF( IUPLO.EQ.1 ) THEN
DO 1340 J = 1, N
DO 1330 I = MAX( 1, J-KD ), J
V( KD+1+I-J, J ) = A( I, J )
1330 CONTINUE
1340 CONTINUE
ELSE
DO 1360 J = 1, N
DO 1350 I = J, MIN( N, J+KD )
V( 1+I-J, J ) = A( I, J )
1350 CONTINUE
1360 CONTINUE
END IF
*
SRNAMT = 'SSBEVX'
CALL SSBEVX( 'N', 'I', UPLO, N, KD, V, LDU, U, LDU, VL,
$ VU, IL, IU, ABSTOL, M3, WA3, Z, LDU, WORK,
$ IWORK, IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSBEVX(N,I,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 1370
END IF
END IF
*
* Do test 57 (or +54)
*
TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
IF( N.GT.0 ) THEN
TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) )
ELSE
TEMP3 = ZERO
END IF
RESULT( NTEST ) = ( TEMP1+TEMP2 ) /
$ MAX( UNFL, TEMP3*ULP )
*
1370 CONTINUE
NTEST = NTEST + 1
IF( IUPLO.EQ.1 ) THEN
DO 1390 J = 1, N
DO 1380 I = MAX( 1, J-KD ), J
V( KD+1+I-J, J ) = A( I, J )
1380 CONTINUE
1390 CONTINUE
ELSE
DO 1410 J = 1, N
DO 1400 I = J, MIN( N, J+KD )
V( 1+I-J, J ) = A( I, J )
1400 CONTINUE
1410 CONTINUE
END IF
*
SRNAMT = 'SSBEVX'
CALL SSBEVX( 'V', 'V', UPLO, N, KD, V, LDU, U, LDU, VL,
$ VU, IL, IU, ABSTOL, M2, WA2, Z, LDU, WORK,
$ IWORK, IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSBEVX(V,V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 1460
END IF
END IF
*
* Do tests 58 and 59 (or +54)
*
CALL SSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU,
$ V, LDU, TAU, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 2
*
IF( IUPLO.EQ.1 ) THEN
DO 1430 J = 1, N
DO 1420 I = MAX( 1, J-KD ), J
V( KD+1+I-J, J ) = A( I, J )
1420 CONTINUE
1430 CONTINUE
ELSE
DO 1450 J = 1, N
DO 1440 I = J, MIN( N, J+KD )
V( 1+I-J, J ) = A( I, J )
1440 CONTINUE
1450 CONTINUE
END IF
*
SRNAMT = 'SSBEVX'
CALL SSBEVX( 'N', 'V', UPLO, N, KD, V, LDU, U, LDU, VL,
$ VU, IL, IU, ABSTOL, M3, WA3, Z, LDU, WORK,
$ IWORK, IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSBEVX(N,V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 1460
END IF
END IF
*
IF( M3.EQ.0 .AND. N.GT.0 ) THEN
RESULT( NTEST ) = ULPINV
GO TO 1460
END IF
*
* Do test 60 (or +54)
*
TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
IF( N.GT.0 ) THEN
TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) )
ELSE
TEMP3 = ZERO
END IF
RESULT( NTEST ) = ( TEMP1+TEMP2 ) /
$ MAX( UNFL, TEMP3*ULP )
*
1460 CONTINUE
*
* 7) Call SSYEVD
*
CALL SLACPY( ' ', N, N, A, LDA, V, LDU )
*
NTEST = NTEST + 1
SRNAMT = 'SSYEVD'
CALL SSYEVD( 'V', UPLO, N, A, LDU, D1, WORK, LWEDC,
$ IWORK, LIWEDC, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSYEVD(V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 1480
END IF
END IF
*
* Do tests 61 and 62 (or +54)
*
CALL SSYT21( 1, UPLO, N, 0, V, LDU, D1, D2, A, LDU, Z,
$ LDU, TAU, WORK, RESULT( NTEST ) )
*
CALL SLACPY( ' ', N, N, V, LDU, A, LDA )
*
NTEST = NTEST + 2
SRNAMT = 'SSYEVD'
CALL SSYEVD( 'N', UPLO, N, A, LDU, D3, WORK, LWEDC,
$ IWORK, LIWEDC, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSYEVD(N,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 1480
END IF
END IF
*
* Do test 63 (or +54)
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 1470 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) )
1470 CONTINUE
RESULT( NTEST ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
1480 CONTINUE
*
* 8) Call SSPEVD.
*
CALL SLACPY( ' ', N, N, V, LDU, A, LDA )
*
* Load array WORK with the upper or lower triangular
* part of the matrix in packed form.
*
IF( IUPLO.EQ.1 ) THEN
INDX = 1
DO 1500 J = 1, N
DO 1490 I = 1, J
WORK( INDX ) = A( I, J )
INDX = INDX + 1
1490 CONTINUE
1500 CONTINUE
ELSE
INDX = 1
DO 1520 J = 1, N
DO 1510 I = J, N
WORK( INDX ) = A( I, J )
INDX = INDX + 1
1510 CONTINUE
1520 CONTINUE
END IF
*
NTEST = NTEST + 1
SRNAMT = 'SSPEVD'
CALL SSPEVD( 'V', UPLO, N, WORK, D1, Z, LDU,
$ WORK( INDX ), LWEDC-INDX+1, IWORK, LIWEDC,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSPEVD(V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 1580
END IF
END IF
*
* Do tests 64 and 65 (or +54)
*
CALL SSYT21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V,
$ LDU, TAU, WORK, RESULT( NTEST ) )
*
IF( IUPLO.EQ.1 ) THEN
INDX = 1
DO 1540 J = 1, N
DO 1530 I = 1, J
*
WORK( INDX ) = A( I, J )
INDX = INDX + 1
1530 CONTINUE
1540 CONTINUE
ELSE
INDX = 1
DO 1560 J = 1, N
DO 1550 I = J, N
WORK( INDX ) = A( I, J )
INDX = INDX + 1
1550 CONTINUE
1560 CONTINUE
END IF
*
NTEST = NTEST + 2
SRNAMT = 'SSPEVD'
CALL SSPEVD( 'N', UPLO, N, WORK, D3, Z, LDU,
$ WORK( INDX ), LWEDC-INDX+1, IWORK, LIWEDC,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSPEVD(N,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 1580
END IF
END IF
*
* Do test 66 (or +54)
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 1570 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) )
1570 CONTINUE
RESULT( NTEST ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
1580 CONTINUE
*
* 9) Call SSBEVD.
*
IF( JTYPE.LE.7 ) THEN
KD = 1
ELSE IF( JTYPE.GE.8 .AND. JTYPE.LE.15 ) THEN
KD = MAX( N-1, 0 )
ELSE
KD = IHBW
END IF
*
* Load array V with the upper or lower triangular part
* of the matrix in band form.
*
IF( IUPLO.EQ.1 ) THEN
DO 1600 J = 1, N
DO 1590 I = MAX( 1, J-KD ), J
V( KD+1+I-J, J ) = A( I, J )
1590 CONTINUE
1600 CONTINUE
ELSE
DO 1620 J = 1, N
DO 1610 I = J, MIN( N, J+KD )
V( 1+I-J, J ) = A( I, J )
1610 CONTINUE
1620 CONTINUE
END IF
*
NTEST = NTEST + 1
SRNAMT = 'SSBEVD'
CALL SSBEVD( 'V', UPLO, N, KD, V, LDU, D1, Z, LDU, WORK,
$ LWEDC, IWORK, LIWEDC, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSBEVD(V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 1680
END IF
END IF
*
* Do tests 67 and 68 (or +54)
*
CALL SSYT21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V,
$ LDU, TAU, WORK, RESULT( NTEST ) )
*
IF( IUPLO.EQ.1 ) THEN
DO 1640 J = 1, N
DO 1630 I = MAX( 1, J-KD ), J
V( KD+1+I-J, J ) = A( I, J )
1630 CONTINUE
1640 CONTINUE
ELSE
DO 1660 J = 1, N
DO 1650 I = J, MIN( N, J+KD )
V( 1+I-J, J ) = A( I, J )
1650 CONTINUE
1660 CONTINUE
END IF
*
NTEST = NTEST + 2
SRNAMT = 'SSBEVD'
CALL SSBEVD( 'N', UPLO, N, KD, V, LDU, D3, Z, LDU, WORK,
$ LWEDC, IWORK, LIWEDC, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSBEVD(N,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 1680
END IF
END IF
*
* Do test 69 (or +54)
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 1670 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) )
1670 CONTINUE
RESULT( NTEST ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
1680 CONTINUE
*
*
CALL SLACPY( ' ', N, N, A, LDA, V, LDU )
NTEST = NTEST + 1
SRNAMT = 'SSYEVR'
CALL SSYEVR( 'V', 'A', UPLO, N, A, LDU, VL, VU, IL, IU,
$ ABSTOL, M, WA1, Z, LDU, IWORK, WORK, LWORK,
$ IWORK(2*N+1), LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSYEVR(V,A,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 1700
END IF
END IF
*
* Do tests 70 and 71 (or ... )
*
CALL SLACPY( ' ', N, N, V, LDU, A, LDA )
*
CALL SSYT21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V,
$ LDU, TAU, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 2
SRNAMT = 'SSYEVR'
CALL SSYEVR( 'N', 'A', UPLO, N, A, LDU, VL, VU, IL, IU,
$ ABSTOL, M2, WA2, Z, LDU, IWORK, WORK, LWORK,
$ IWORK(2*N+1), LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSYEVR(N,A,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 1700
END IF
END IF
*
* Do test 72 (or ... )
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 1690 J = 1, N
TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) )
TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) )
1690 CONTINUE
RESULT( NTEST ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
1700 CONTINUE
*
NTEST = NTEST + 1
CALL SLACPY( ' ', N, N, V, LDU, A, LDA )
SRNAMT = 'SSYEVR'
CALL SSYEVR( 'V', 'I', UPLO, N, A, LDU, VL, VU, IL, IU,
$ ABSTOL, M2, WA2, Z, LDU, IWORK, WORK, LWORK,
$ IWORK(2*N+1), LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSYEVR(V,I,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 1710
END IF
END IF
*
* Do tests 73 and 74 (or +54)
*
CALL SLACPY( ' ', N, N, V, LDU, A, LDA )
*
CALL SSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU,
$ V, LDU, TAU, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 2
CALL SLACPY( ' ', N, N, V, LDU, A, LDA )
SRNAMT = 'SSYEVR'
CALL SSYEVR( 'N', 'I', UPLO, N, A, LDU, VL, VU, IL, IU,
$ ABSTOL, M3, WA3, Z, LDU, IWORK, WORK, LWORK,
$ IWORK(2*N+1), LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSYEVR(N,I,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 1710
END IF
END IF
*
* Do test 75 (or +54)
*
TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
RESULT( NTEST ) = ( TEMP1+TEMP2 ) /
$ MAX( UNFL, ULP*TEMP3 )
1710 CONTINUE
*
NTEST = NTEST + 1
CALL SLACPY( ' ', N, N, V, LDU, A, LDA )
SRNAMT = 'SSYEVR'
CALL SSYEVR( 'V', 'V', UPLO, N, A, LDU, VL, VU, IL, IU,
$ ABSTOL, M2, WA2, Z, LDU, IWORK, WORK, LWORK,
$ IWORK(2*N+1), LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSYEVR(V,V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 700
END IF
END IF
*
* Do tests 76 and 77 (or +54)
*
CALL SLACPY( ' ', N, N, V, LDU, A, LDA )
*
CALL SSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU,
$ V, LDU, TAU, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 2
CALL SLACPY( ' ', N, N, V, LDU, A, LDA )
SRNAMT = 'SSYEVR'
CALL SSYEVR( 'N', 'V', UPLO, N, A, LDU, VL, VU, IL, IU,
$ ABSTOL, M3, WA3, Z, LDU, IWORK, WORK, LWORK,
$ IWORK(2*N+1), LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SSYEVR(N,V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 700
END IF
END IF
*
IF( M3.EQ.0 .AND. N.GT.0 ) THEN
RESULT( NTEST ) = ULPINV
GO TO 700
END IF
*
* Do test 78 (or +54)
*
TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
IF( N.GT.0 ) THEN
TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) )
ELSE
TEMP3 = ZERO
END IF
RESULT( NTEST ) = ( TEMP1+TEMP2 ) /
$ MAX( UNFL, TEMP3*ULP )
*
CALL SLACPY( ' ', N, N, V, LDU, A, LDA )
*
1720 CONTINUE
*
* End of Loop -- Check for RESULT(j) > THRESH
*
NTESTT = NTESTT + NTEST
*
CALL SLAFTS( 'SST', N, N, JTYPE, NTEST, RESULT, IOLDSD,
$ THRESH, NOUNIT, NERRS )
*
1730 CONTINUE
1740 CONTINUE
*
* Summary
*
CALL ALASVM( 'SST', NOUNIT, NERRS, NTESTT, 0 )
*
9999 FORMAT( ' SDRVST: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
*
RETURN
*
* End of SDRVST
*
END
SUBROUTINE SDRVSX( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
$ NIUNIT, NOUNIT, A, LDA, H, HT, WR, WI, WRT,
$ WIT, WRTMP, WITMP, VS, LDVS, VS1, RESULT, WORK,
$ LWORK, IWORK, BWORK, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDVS, LWORK, NIUNIT, NOUNIT, NSIZES,
$ NTYPES
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL BWORK( * ), DOTYPE( * )
INTEGER ISEED( 4 ), IWORK( * ), NN( * )
REAL A( LDA, * ), H( LDA, * ), HT( LDA, * ),
$ RESULT( 17 ), VS( LDVS, * ), VS1( LDVS, * ),
$ WI( * ), WIT( * ), WITMP( * ), WORK( * ),
$ WR( * ), WRT( * ), WRTMP( * )
* ..
*
* Purpose
* =======
*
* SDRVSX checks the nonsymmetric eigenvalue (Schur form) problem
* expert driver SGEESX.
*
* SDRVSX uses both test matrices generated randomly depending on
* data supplied in the calling sequence, as well as on data
* read from an input file and including precomputed condition
* numbers to which it compares the ones it computes.
*
* When SDRVSX is called, a number of matrix "sizes" ("n's") and a
* number of matrix "types" are specified. For each size ("n")
* and each type of matrix, one matrix will be generated and used
* to test the nonsymmetric eigenroutines. For each matrix, 15
* tests will be performed:
*
* (1) 0 if T is in Schur form, 1/ulp otherwise
* (no sorting of eigenvalues)
*
* (2) | A - VS T VS' | / ( n |A| ulp )
*
* Here VS is the matrix of Schur eigenvectors, and T is in Schur
* form (no sorting of eigenvalues).
*
* (3) | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues).
*
* (4) 0 if WR+sqrt(-1)*WI are eigenvalues of T
* 1/ulp otherwise
* (no sorting of eigenvalues)
*
* (5) 0 if T(with VS) = T(without VS),
* 1/ulp otherwise
* (no sorting of eigenvalues)
*
* (6) 0 if eigenvalues(with VS) = eigenvalues(without VS),
* 1/ulp otherwise
* (no sorting of eigenvalues)
*
* (7) 0 if T is in Schur form, 1/ulp otherwise
* (with sorting of eigenvalues)
*
* (8) | A - VS T VS' | / ( n |A| ulp )
*
* Here VS is the matrix of Schur eigenvectors, and T is in Schur
* form (with sorting of eigenvalues).
*
* (9) | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues).
*
* (10) 0 if WR+sqrt(-1)*WI are eigenvalues of T
* 1/ulp otherwise
* If workspace sufficient, also compare WR, WI with and
* without reciprocal condition numbers
* (with sorting of eigenvalues)
*
* (11) 0 if T(with VS) = T(without VS),
* 1/ulp otherwise
* If workspace sufficient, also compare T with and without
* reciprocal condition numbers
* (with sorting of eigenvalues)
*
* (12) 0 if eigenvalues(with VS) = eigenvalues(without VS),
* 1/ulp otherwise
* If workspace sufficient, also compare VS with and without
* reciprocal condition numbers
* (with sorting of eigenvalues)
*
* (13) if sorting worked and SDIM is the number of
* eigenvalues which were SELECTed
* If workspace sufficient, also compare SDIM with and
* without reciprocal condition numbers
*
* (14) if RCONDE the same no matter if VS and/or RCONDV computed
*
* (15) if RCONDV the same no matter if VS and/or RCONDE computed
*
* The "sizes" are specified by an array NN(1:NSIZES); the value of
* each element NN(j) specifies one size.
* The "types" are specified by a logical array DOTYPE( 1:NTYPES );
* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
* Currently, the list of possible types is:
*
* (1) The zero matrix.
* (2) The identity matrix.
* (3) A (transposed) Jordan block, with 1's on the diagonal.
*
* (4) A diagonal matrix with evenly spaced entries
* 1, ..., ULP and random signs.
* (ULP = (first number larger than 1) - 1 )
* (5) A diagonal matrix with geometrically spaced entries
* 1, ..., ULP and random signs.
* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
* and random signs.
*
* (7) Same as (4), but multiplied by a constant near
* the overflow threshold
* (8) Same as (4), but multiplied by a constant near
* the underflow threshold
*
* (9) A matrix of the form U' T U, where U is orthogonal and
* T has evenly spaced entries 1, ..., ULP with random signs
* on the diagonal and random O(1) entries in the upper
* triangle.
*
* (10) A matrix of the form U' T U, where U is orthogonal and
* T has geometrically spaced entries 1, ..., ULP with random
* signs on the diagonal and random O(1) entries in the upper
* triangle.
*
* (11) A matrix of the form U' T U, where U is orthogonal and
* T has "clustered" entries 1, ULP,..., ULP with random
* signs on the diagonal and random O(1) entries in the upper
* triangle.
*
* (12) A matrix of the form U' T U, where U is orthogonal and
* T has real or complex conjugate paired eigenvalues randomly
* chosen from ( ULP, 1 ) and random O(1) entries in the upper
* triangle.
*
* (13) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP
* with random signs on the diagonal and random O(1) entries
* in the upper triangle.
*
* (14) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has geometrically spaced entries
* 1, ..., ULP with random signs on the diagonal and random
* O(1) entries in the upper triangle.
*
* (15) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP
* with random signs on the diagonal and random O(1) entries
* in the upper triangle.
*
* (16) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has real or complex conjugate paired
* eigenvalues randomly chosen from ( ULP, 1 ) and random
* O(1) entries in the upper triangle.
*
* (17) Same as (16), but multiplied by a constant
* near the overflow threshold
* (18) Same as (16), but multiplied by a constant
* near the underflow threshold
*
* (19) Nonsymmetric matrix with random entries chosen from (-1,1).
* If N is at least 4, all entries in first two rows and last
* row, and first column and last two columns are zero.
* (20) Same as (19), but multiplied by a constant
* near the overflow threshold
* (21) Same as (19), but multiplied by a constant
* near the underflow threshold
*
* In addition, an input file will be read from logical unit number
* NIUNIT. The file contains matrices along with precomputed
* eigenvalues and reciprocal condition numbers for the eigenvalue
* average and right invariant subspace. For these matrices, in
* addition to tests (1) to (15) we will compute the following two
* tests:
*
* (16) |RCONDE - RCDEIN| / cond(RCONDE)
*
* RCONDE is the reciprocal average eigenvalue condition number
* computed by SGEESX and RCDEIN (the precomputed true value)
* is supplied as input. cond(RCONDE) is the condition number
* of RCONDE, and takes errors in computing RCONDE into account,
* so that the resulting quantity should be O(ULP). cond(RCONDE)
* is essentially given by norm(A)/RCONDV.
*
* (17) |RCONDV - RCDVIN| / cond(RCONDV)
*
* RCONDV is the reciprocal right invariant subspace condition
* number computed by SGEESX and RCDVIN (the precomputed true
* value) is supplied as input. cond(RCONDV) is the condition
* number of RCONDV, and takes errors in computing RCONDV into
* account, so that the resulting quantity should be O(ULP).
* cond(RCONDV) is essentially given by norm(A)/RCONDE.
*
* Arguments
* =========
*
* NSIZES (input) INTEGER
* The number of sizes of matrices to use. NSIZES must be at
* least zero. If it is zero, no randomly generated matrices
* are tested, but any test matrices read from NIUNIT will be
* tested.
*
* NN (input) INTEGER array, dimension (NSIZES)
* An array containing the sizes to be used for the matrices.
* Zero values will be skipped. The values must be at least
* zero.
*
* NTYPES (input) INTEGER
* The number of elements in DOTYPE. NTYPES must be at least
* zero. If it is zero, no randomly generated test matrices
* are tested, but and test matrices read from NIUNIT will be
* tested. If it is MAXTYP+1 and NSIZES is 1, then an
* additional type, MAXTYP+1 is defined, which is to use
* whatever matrix is in A. This is only useful if
* DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. .
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* If DOTYPE(j) is .TRUE., then for each size in NN a
* matrix of that size and of type j will be generated.
* If NTYPES is smaller than the maximum number of types
* defined (PARAMETER MAXTYP), then types NTYPES+1 through
* MAXTYP will not be generated. If NTYPES is larger
* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
* will be ignored.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The array elements should be between 0 and 4095;
* if not they will be reduced mod 4096. Also, ISEED(4) must
* be odd. The random number generator uses a linear
* congruential sequence limited to small integers, and so
* should produce machine independent random numbers. The
* values of ISEED are changed on exit, and can be used in the
* next call to SDRVSX to continue the same random number
* sequence.
*
* THRESH (input) REAL
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error
* is scaled to be O(1), so THRESH should be a reasonably
* small multiple of 1, e.g., 10 or 100. In particular,
* it should not depend on the precision (single vs. double)
* or the size of the matrix. It must be at least zero.
*
* NIUNIT (input) INTEGER
* The FORTRAN unit number for reading in the data file of
* problems to solve.
*
* NOUNIT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns INFO not equal to 0.)
*
* A (workspace) REAL array, dimension (LDA, max(NN))
* Used to hold the matrix whose eigenvalues are to be
* computed. On exit, A contains the last matrix actually used.
*
* LDA (input) INTEGER
* The leading dimension of A, and H. LDA must be at
* least 1 and at least max( NN ).
*
* H (workspace) REAL array, dimension (LDA, max(NN))
* Another copy of the test matrix A, modified by SGEESX.
*
* HT (workspace) REAL array, dimension (LDA, max(NN))
* Yet another copy of the test matrix A, modified by SGEESX.
*
* WR (workspace) REAL array, dimension (max(NN))
* WI (workspace) REAL array, dimension (max(NN))
* The real and imaginary parts of the eigenvalues of A.
* On exit, WR + WI*i are the eigenvalues of the matrix in A.
*
* WRT (workspace) REAL array, dimension (max(NN))
* WIT (workspace) REAL array, dimension (max(NN))
* Like WR, WI, these arrays contain the eigenvalues of A,
* but those computed when SGEESX only computes a partial
* eigendecomposition, i.e. not Schur vectors
*
* WRTMP (workspace) REAL array, dimension (max(NN))
* WITMP (workspace) REAL array, dimension (max(NN))
* More temporary storage for eigenvalues.
*
* VS (workspace) REAL array, dimension (LDVS, max(NN))
* VS holds the computed Schur vectors.
*
* LDVS (input) INTEGER
* Leading dimension of VS. Must be at least max(1,max(NN)).
*
* VS1 (workspace) REAL array, dimension (LDVS, max(NN))
* VS1 holds another copy of the computed Schur vectors.
*
* RESULT (output) REAL array, dimension (17)
* The values computed by the 17 tests described above.
* The values are currently limited to 1/ulp, to avoid overflow.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The number of entries in WORK. This must be at least
* max(3*NN(j),2*NN(j)**2) for all j.
*
* IWORK (workspace) INTEGER array, dimension (max(NN)*max(NN))
*
* INFO (output) INTEGER
* If 0, successful exit.
* <0, input parameter -INFO is incorrect
* >0, SLATMR, SLATMS, SLATME or SGET24 returned an error
* code and INFO is its absolute value
*
*-----------------------------------------------------------------------
*
* Some Local Variables and Parameters:
* ---- ----- --------- --- ----------
* ZERO, ONE Real 0 and 1.
* MAXTYP The number of types defined.
* NMAX Largest value in NN.
* NERRS The number of tests which have exceeded THRESH
* COND, CONDS,
* IMODE Values to be passed to the matrix generators.
* ANORM Norm of A; passed to matrix generators.
*
* OVFL, UNFL Overflow and underflow thresholds.
* ULP, ULPINV Finest relative precision and its inverse.
* RTULP, RTULPI Square roots of the previous 4 values.
* The following four arrays decode JTYPE:
* KTYPE(j) The general type (1-10) for type "j".
* KMODE(j) The MODE value to be passed to the matrix
* generator for type "j".
* KMAGN(j) The order of magnitude ( O(1),
* O(overflow^(1/2) ), O(underflow^(1/2) )
* KCONDS(j) Selectw whether CONDS is to be 1 or
* 1/sqrt(ulp). (0 means irrelevant.)
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 21 )
* ..
* .. Local Scalars ..
LOGICAL BADNN
CHARACTER*3 PATH
INTEGER I, IINFO, IMODE, ITYPE, IWK, J, JCOL, JSIZE,
$ JTYPE, MTYPES, N, NERRS, NFAIL, NMAX,
$ NNWORK, NSLCT, NTEST, NTESTF, NTESTT
REAL ANORM, COND, CONDS, OVFL, RCDEIN, RCDVIN,
$ RTULP, RTULPI, ULP, ULPINV, UNFL
* ..
* .. Local Arrays ..
CHARACTER ADUMMA( 1 )
INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISLCT( 20 ),
$ KCONDS( MAXTYP ), KMAGN( MAXTYP ),
$ KMODE( MAXTYP ), KTYPE( MAXTYP )
* ..
* .. Arrays in Common ..
LOGICAL SELVAL( 20 )
REAL SELWI( 20 ), SELWR( 20 )
* ..
* .. Scalars in Common ..
INTEGER SELDIM, SELOPT
* ..
* .. Common blocks ..
COMMON / SSLCT / SELOPT, SELDIM, SELVAL, SELWR, SELWI
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SGET24, SLABAD, SLASUM, SLATME, SLATMR, SLATMS,
$ SLASET, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Data statements ..
DATA KTYPE / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
DATA KMAGN / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
$ 3, 1, 2, 3 /
DATA KMODE / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
$ 1, 5, 5, 5, 4, 3, 1 /
DATA KCONDS / 3*0, 5*0, 4*1, 6*2, 3*0 /
* ..
* .. Executable Statements ..
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'SX'
*
* Check for errors
*
NTESTT = 0
NTESTF = 0
INFO = 0
*
* Important constants
*
BADNN = .FALSE.
*
* 12 is the largest dimension in the input file of precomputed
* problems
*
NMAX = 12
DO 10 J = 1, NSIZES
NMAX = MAX( NMAX, NN( J ) )
IF( NN( J ).LT.0 )
$ BADNN = .TRUE.
10 CONTINUE
*
* Check for errors
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADNN ) THEN
INFO = -2
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -3
ELSE IF( THRESH.LT.ZERO ) THEN
INFO = -6
ELSE IF( NIUNIT.LE.0 ) THEN
INFO = -7
ELSE IF( NOUNIT.LE.0 ) THEN
INFO = -8
ELSE IF( LDA.LT.1 .OR. LDA.LT.NMAX ) THEN
INFO = -10
ELSE IF( LDVS.LT.1 .OR. LDVS.LT.NMAX ) THEN
INFO = -20
ELSE IF( MAX( 3*NMAX, 2*NMAX**2 ).GT.LWORK ) THEN
INFO = -24
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SDRVSX', -INFO )
RETURN
END IF
*
* If nothing to do check on NIUNIT
*
IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
$ GO TO 150
*
* More Important constants
*
UNFL = SLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
CALL SLABAD( UNFL, OVFL )
ULP = SLAMCH( 'Precision' )
ULPINV = ONE / ULP
RTULP = SQRT( ULP )
RTULPI = ONE / RTULP
*
* Loop over sizes, types
*
NERRS = 0
*
DO 140 JSIZE = 1, NSIZES
N = NN( JSIZE )
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
DO 130 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 130
*
* Save ISEED in case of an error.
*
DO 20 J = 1, 4
IOLDSD( J ) = ISEED( J )
20 CONTINUE
*
* Compute "A"
*
* Control parameters:
*
* KMAGN KCONDS KMODE KTYPE
* =1 O(1) 1 clustered 1 zero
* =2 large large clustered 2 identity
* =3 small exponential Jordan
* =4 arithmetic diagonal, (w/ eigenvalues)
* =5 random log symmetric, w/ eigenvalues
* =6 random general, w/ eigenvalues
* =7 random diagonal
* =8 random symmetric
* =9 random general
* =10 random triangular
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 90
*
ITYPE = KTYPE( JTYPE )
IMODE = KMODE( JTYPE )
*
* Compute norm
*
GO TO ( 30, 40, 50 )KMAGN( JTYPE )
*
30 CONTINUE
ANORM = ONE
GO TO 60
*
40 CONTINUE
ANORM = OVFL*ULP
GO TO 60
*
50 CONTINUE
ANORM = UNFL*ULPINV
GO TO 60
*
60 CONTINUE
*
CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
IINFO = 0
COND = ULPINV
*
* Special Matrices -- Identity & Jordan block
*
* Zero
*
IF( ITYPE.EQ.1 ) THEN
IINFO = 0
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Identity
*
DO 70 JCOL = 1, N
A( JCOL, JCOL ) = ANORM
70 CONTINUE
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* Jordan Block
*
DO 80 JCOL = 1, N
A( JCOL, JCOL ) = ANORM
IF( JCOL.GT.1 )
$ A( JCOL, JCOL-1 ) = ONE
80 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Diagonal Matrix, [Eigen]values Specified
*
CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.5 ) THEN
*
* Symmetric, eigenvalues specified
*
CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, N, N, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.6 ) THEN
*
* General, eigenvalues specified
*
IF( KCONDS( JTYPE ).EQ.1 ) THEN
CONDS = ONE
ELSE IF( KCONDS( JTYPE ).EQ.2 ) THEN
CONDS = RTULPI
ELSE
CONDS = ZERO
END IF
*
ADUMMA( 1 ) = ' '
CALL SLATME( N, 'S', ISEED, WORK, IMODE, COND, ONE,
$ ADUMMA, 'T', 'T', 'T', WORK( N+1 ), 4,
$ CONDS, N, N, ANORM, A, LDA, WORK( 2*N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.7 ) THEN
*
* Diagonal, random eigenvalues
*
CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.8 ) THEN
*
* Symmetric, random eigenvalues
*
CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.9 ) THEN
*
* General, random eigenvalues
*
CALL SLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
IF( N.GE.4 ) THEN
CALL SLASET( 'Full', 2, N, ZERO, ZERO, A, LDA )
CALL SLASET( 'Full', N-3, 1, ZERO, ZERO, A( 3, 1 ),
$ LDA )
CALL SLASET( 'Full', N-3, 2, ZERO, ZERO, A( 3, N-1 ),
$ LDA )
CALL SLASET( 'Full', 1, N, ZERO, ZERO, A( N, 1 ),
$ LDA )
END IF
*
ELSE IF( ITYPE.EQ.10 ) THEN
*
* Triangular, random eigenvalues
*
CALL SLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, 0,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE
*
IINFO = 1
END IF
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9991 )'Generator', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
90 CONTINUE
*
* Test for minimal and generous workspace
*
DO 120 IWK = 1, 2
IF( IWK.EQ.1 ) THEN
NNWORK = 3*N
ELSE
NNWORK = MAX( 3*N, 2*N*N )
END IF
NNWORK = MAX( NNWORK, 1 )
*
CALL SGET24( .FALSE., JTYPE, THRESH, IOLDSD, NOUNIT, N,
$ A, LDA, H, HT, WR, WI, WRT, WIT, WRTMP,
$ WITMP, VS, LDVS, VS1, RCDEIN, RCDVIN, NSLCT,
$ ISLCT, RESULT, WORK, NNWORK, IWORK, BWORK,
$ INFO )
*
* Check for RESULT(j) > THRESH
*
NTEST = 0
NFAIL = 0
DO 100 J = 1, 15
IF( RESULT( J ).GE.ZERO )
$ NTEST = NTEST + 1
IF( RESULT( J ).GE.THRESH )
$ NFAIL = NFAIL + 1
100 CONTINUE
*
IF( NFAIL.GT.0 )
$ NTESTF = NTESTF + 1
IF( NTESTF.EQ.1 ) THEN
WRITE( NOUNIT, FMT = 9999 )PATH
WRITE( NOUNIT, FMT = 9998 )
WRITE( NOUNIT, FMT = 9997 )
WRITE( NOUNIT, FMT = 9996 )
WRITE( NOUNIT, FMT = 9995 )THRESH
WRITE( NOUNIT, FMT = 9994 )
NTESTF = 2
END IF
*
DO 110 J = 1, 15
IF( RESULT( J ).GE.THRESH ) THEN
WRITE( NOUNIT, FMT = 9993 )N, IWK, IOLDSD, JTYPE,
$ J, RESULT( J )
END IF
110 CONTINUE
*
NERRS = NERRS + NFAIL
NTESTT = NTESTT + NTEST
*
120 CONTINUE
130 CONTINUE
140 CONTINUE
*
150 CONTINUE
*
* Read in data from file to check accuracy of condition estimation
* Read input data until N=0
*
JTYPE = 0
160 CONTINUE
READ( NIUNIT, FMT = *, END = 200 )N, NSLCT
IF( N.EQ.0 )
$ GO TO 200
JTYPE = JTYPE + 1
ISEED( 1 ) = JTYPE
IF( NSLCT.GT.0 )
$ READ( NIUNIT, FMT = * )( ISLCT( I ), I = 1, NSLCT )
DO 170 I = 1, N
READ( NIUNIT, FMT = * )( A( I, J ), J = 1, N )
170 CONTINUE
READ( NIUNIT, FMT = * )RCDEIN, RCDVIN
*
CALL SGET24( .TRUE., 22, THRESH, ISEED, NOUNIT, N, A, LDA, H, HT,
$ WR, WI, WRT, WIT, WRTMP, WITMP, VS, LDVS, VS1,
$ RCDEIN, RCDVIN, NSLCT, ISLCT, RESULT, WORK, LWORK,
$ IWORK, BWORK, INFO )
*
* Check for RESULT(j) > THRESH
*
NTEST = 0
NFAIL = 0
DO 180 J = 1, 17
IF( RESULT( J ).GE.ZERO )
$ NTEST = NTEST + 1
IF( RESULT( J ).GE.THRESH )
$ NFAIL = NFAIL + 1
180 CONTINUE
*
IF( NFAIL.GT.0 )
$ NTESTF = NTESTF + 1
IF( NTESTF.EQ.1 ) THEN
WRITE( NOUNIT, FMT = 9999 )PATH
WRITE( NOUNIT, FMT = 9998 )
WRITE( NOUNIT, FMT = 9997 )
WRITE( NOUNIT, FMT = 9996 )
WRITE( NOUNIT, FMT = 9995 )THRESH
WRITE( NOUNIT, FMT = 9994 )
NTESTF = 2
END IF
DO 190 J = 1, 17
IF( RESULT( J ).GE.THRESH ) THEN
WRITE( NOUNIT, FMT = 9992 )N, JTYPE, J, RESULT( J )
END IF
190 CONTINUE
*
NERRS = NERRS + NFAIL
NTESTT = NTESTT + NTEST
GO TO 160
200 CONTINUE
*
* Summary
*
CALL SLASUM( PATH, NOUNIT, NERRS, NTESTT )
*
9999 FORMAT( / 1X, A3, ' -- Real Schur Form Decomposition Expert ',
$ 'Driver', / ' Matrix types (see SDRVSX for details):' )
*
9998 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ',
$ ' ', ' 5=Diagonal: geometr. spaced entries.',
$ / ' 2=Identity matrix. ', ' 6=Diagona',
$ 'l: clustered entries.', / ' 3=Transposed Jordan block. ',
$ ' ', ' 7=Diagonal: large, evenly spaced.', / ' ',
$ '4=Diagonal: evenly spaced entries. ', ' 8=Diagonal: s',
$ 'mall, evenly spaced.' )
9997 FORMAT( ' Dense, Non-Symmetric Matrices:', / ' 9=Well-cond., ev',
$ 'enly spaced eigenvals.', ' 14=Ill-cond., geomet. spaced e',
$ 'igenals.', / ' 10=Well-cond., geom. spaced eigenvals. ',
$ ' 15=Ill-conditioned, clustered e.vals.', / ' 11=Well-cond',
$ 'itioned, clustered e.vals. ', ' 16=Ill-cond., random comp',
$ 'lex ', / ' 12=Well-cond., random complex ', ' ',
$ ' 17=Ill-cond., large rand. complx ', / ' 13=Ill-condi',
$ 'tioned, evenly spaced. ', ' 18=Ill-cond., small rand.',
$ ' complx ' )
9996 FORMAT( ' 19=Matrix with random O(1) entries. ', ' 21=Matrix ',
$ 'with small random entries.', / ' 20=Matrix with large ran',
$ 'dom entries. ', / )
9995 FORMAT( ' Tests performed with test threshold =', F8.2,
$ / ' ( A denotes A on input and T denotes A on output)',
$ / / ' 1 = 0 if T in Schur form (no sort), ',
$ ' 1/ulp otherwise', /
$ ' 2 = | A - VS T transpose(VS) | / ( n |A| ulp ) (no sort)',
$ / ' 3 = | I - VS transpose(VS) | / ( n ulp ) (no sort) ', /
$ ' 4 = 0 if WR+sqrt(-1)*WI are eigenvalues of T (no sort),',
$ ' 1/ulp otherwise', /
$ ' 5 = 0 if T same no matter if VS computed (no sort),',
$ ' 1/ulp otherwise', /
$ ' 6 = 0 if WR, WI same no matter if VS computed (no sort)',
$ ', 1/ulp otherwise' )
9994 FORMAT( ' 7 = 0 if T in Schur form (sort), ', ' 1/ulp otherwise',
$ / ' 8 = | A - VS T transpose(VS) | / ( n |A| ulp ) (sort)',
$ / ' 9 = | I - VS transpose(VS) | / ( n ulp ) (sort) ',
$ / ' 10 = 0 if WR+sqrt(-1)*WI are eigenvalues of T (sort),',
$ ' 1/ulp otherwise', /
$ ' 11 = 0 if T same no matter what else computed (sort),',
$ ' 1/ulp otherwise', /
$ ' 12 = 0 if WR, WI same no matter what else computed ',
$ '(sort), 1/ulp otherwise', /
$ ' 13 = 0 if sorting succesful, 1/ulp otherwise',
$ / ' 14 = 0 if RCONDE same no matter what else computed,',
$ ' 1/ulp otherwise', /
$ ' 15 = 0 if RCONDv same no matter what else computed,',
$ ' 1/ulp otherwise', /
$ ' 16 = | RCONDE - RCONDE(precomputed) | / cond(RCONDE),',
$ / ' 17 = | RCONDV - RCONDV(precomputed) | / cond(RCONDV),' )
9993 FORMAT( ' N=', I5, ', IWK=', I2, ', seed=', 4( I4, ',' ),
$ ' type ', I2, ', test(', I2, ')=', G10.3 )
9992 FORMAT( ' N=', I5, ', input example =', I3, ', test(', I2, ')=',
$ G10.3 )
9991 FORMAT( ' SDRVSX: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
*
RETURN
*
* End of SDRVSX
*
END
SUBROUTINE SDRVVX( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
$ NIUNIT, NOUNIT, A, LDA, H, WR, WI, WR1, WI1,
$ VL, LDVL, VR, LDVR, LRE, LDLRE, RCONDV, RCNDV1,
$ RCDVIN, RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1,
$ RESULT, WORK, NWORK, IWORK, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NIUNIT, NOUNIT,
$ NSIZES, NTYPES, NWORK
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER ISEED( 4 ), IWORK( * ), NN( * )
REAL A( LDA, * ), H( LDA, * ), LRE( LDLRE, * ),
$ RCDEIN( * ), RCDVIN( * ), RCNDE1( * ),
$ RCNDV1( * ), RCONDE( * ), RCONDV( * ),
$ RESULT( 11 ), SCALE( * ), SCALE1( * ),
$ VL( LDVL, * ), VR( LDVR, * ), WI( * ),
$ WI1( * ), WORK( * ), WR( * ), WR1( * )
* ..
*
* Purpose
* =======
*
* SDRVVX checks the nonsymmetric eigenvalue problem expert driver
* SGEEVX.
*
* SDRVVX uses both test matrices generated randomly depending on
* data supplied in the calling sequence, as well as on data
* read from an input file and including precomputed condition
* numbers to which it compares the ones it computes.
*
* When SDRVVX is called, a number of matrix "sizes" ("n's") and a
* number of matrix "types" are specified in the calling sequence.
* For each size ("n") and each type of matrix, one matrix will be
* generated and used to test the nonsymmetric eigenroutines. For
* each matrix, 9 tests will be performed:
*
* (1) | A * VR - VR * W | / ( n |A| ulp )
*
* Here VR is the matrix of unit right eigenvectors.
* W is a block diagonal matrix, with a 1x1 block for each
* real eigenvalue and a 2x2 block for each complex conjugate
* pair. If eigenvalues j and j+1 are a complex conjugate pair,
* so WR(j) = WR(j+1) = wr and WI(j) = - WI(j+1) = wi, then the
* 2 x 2 block corresponding to the pair will be:
*
* ( wr wi )
* ( -wi wr )
*
* Such a block multiplying an n x 2 matrix ( ur ui ) on the
* right will be the same as multiplying ur + i*ui by wr + i*wi.
*
* (2) | A**H * VL - VL * W**H | / ( n |A| ulp )
*
* Here VL is the matrix of unit left eigenvectors, A**H is the
* conjugate transpose of A, and W is as above.
*
* (3) | |VR(i)| - 1 | / ulp and largest component real
*
* VR(i) denotes the i-th column of VR.
*
* (4) | |VL(i)| - 1 | / ulp and largest component real
*
* VL(i) denotes the i-th column of VL.
*
* (5) W(full) = W(partial)
*
* W(full) denotes the eigenvalues computed when VR, VL, RCONDV
* and RCONDE are also computed, and W(partial) denotes the
* eigenvalues computed when only some of VR, VL, RCONDV, and
* RCONDE are computed.
*
* (6) VR(full) = VR(partial)
*
* VR(full) denotes the right eigenvectors computed when VL, RCONDV
* and RCONDE are computed, and VR(partial) denotes the result
* when only some of VL and RCONDV are computed.
*
* (7) VL(full) = VL(partial)
*
* VL(full) denotes the left eigenvectors computed when VR, RCONDV
* and RCONDE are computed, and VL(partial) denotes the result
* when only some of VR and RCONDV are computed.
*
* (8) 0 if SCALE, ILO, IHI, ABNRM (full) =
* SCALE, ILO, IHI, ABNRM (partial)
* 1/ulp otherwise
*
* SCALE, ILO, IHI and ABNRM describe how the matrix is balanced.
* (full) is when VR, VL, RCONDE and RCONDV are also computed, and
* (partial) is when some are not computed.
*
* (9) RCONDV(full) = RCONDV(partial)
*
* RCONDV(full) denotes the reciprocal condition numbers of the
* right eigenvectors computed when VR, VL and RCONDE are also
* computed. RCONDV(partial) denotes the reciprocal condition
* numbers when only some of VR, VL and RCONDE are computed.
*
* The "sizes" are specified by an array NN(1:NSIZES); the value of
* each element NN(j) specifies one size.
* The "types" are specified by a logical array DOTYPE( 1:NTYPES );
* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
* Currently, the list of possible types is:
*
* (1) The zero matrix.
* (2) The identity matrix.
* (3) A (transposed) Jordan block, with 1's on the diagonal.
*
* (4) A diagonal matrix with evenly spaced entries
* 1, ..., ULP and random signs.
* (ULP = (first number larger than 1) - 1 )
* (5) A diagonal matrix with geometrically spaced entries
* 1, ..., ULP and random signs.
* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
* and random signs.
*
* (7) Same as (4), but multiplied by a constant near
* the overflow threshold
* (8) Same as (4), but multiplied by a constant near
* the underflow threshold
*
* (9) A matrix of the form U' T U, where U is orthogonal and
* T has evenly spaced entries 1, ..., ULP with random signs
* on the diagonal and random O(1) entries in the upper
* triangle.
*
* (10) A matrix of the form U' T U, where U is orthogonal and
* T has geometrically spaced entries 1, ..., ULP with random
* signs on the diagonal and random O(1) entries in the upper
* triangle.
*
* (11) A matrix of the form U' T U, where U is orthogonal and
* T has "clustered" entries 1, ULP,..., ULP with random
* signs on the diagonal and random O(1) entries in the upper
* triangle.
*
* (12) A matrix of the form U' T U, where U is orthogonal and
* T has real or complex conjugate paired eigenvalues randomly
* chosen from ( ULP, 1 ) and random O(1) entries in the upper
* triangle.
*
* (13) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP
* with random signs on the diagonal and random O(1) entries
* in the upper triangle.
*
* (14) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has geometrically spaced entries
* 1, ..., ULP with random signs on the diagonal and random
* O(1) entries in the upper triangle.
*
* (15) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP
* with random signs on the diagonal and random O(1) entries
* in the upper triangle.
*
* (16) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has real or complex conjugate paired
* eigenvalues randomly chosen from ( ULP, 1 ) and random
* O(1) entries in the upper triangle.
*
* (17) Same as (16), but multiplied by a constant
* near the overflow threshold
* (18) Same as (16), but multiplied by a constant
* near the underflow threshold
*
* (19) Nonsymmetric matrix with random entries chosen from (-1,1).
* If N is at least 4, all entries in first two rows and last
* row, and first column and last two columns are zero.
* (20) Same as (19), but multiplied by a constant
* near the overflow threshold
* (21) Same as (19), but multiplied by a constant
* near the underflow threshold
*
* In addition, an input file will be read from logical unit number
* NIUNIT. The file contains matrices along with precomputed
* eigenvalues and reciprocal condition numbers for the eigenvalues
* and right eigenvectors. For these matrices, in addition to tests
* (1) to (9) we will compute the following two tests:
*
* (10) |RCONDV - RCDVIN| / cond(RCONDV)
*
* RCONDV is the reciprocal right eigenvector condition number
* computed by SGEEVX and RCDVIN (the precomputed true value)
* is supplied as input. cond(RCONDV) is the condition number of
* RCONDV, and takes errors in computing RCONDV into account, so
* that the resulting quantity should be O(ULP). cond(RCONDV) is
* essentially given by norm(A)/RCONDE.
*
* (11) |RCONDE - RCDEIN| / cond(RCONDE)
*
* RCONDE is the reciprocal eigenvalue condition number
* computed by SGEEVX and RCDEIN (the precomputed true value)
* is supplied as input. cond(RCONDE) is the condition number
* of RCONDE, and takes errors in computing RCONDE into account,
* so that the resulting quantity should be O(ULP). cond(RCONDE)
* is essentially given by norm(A)/RCONDV.
*
* Arguments
* ==========
*
* NSIZES (input) INTEGER
* The number of sizes of matrices to use. NSIZES must be at
* least zero. If it is zero, no randomly generated matrices
* are tested, but any test matrices read from NIUNIT will be
* tested.
*
* NN (input) INTEGER array, dimension (NSIZES)
* An array containing the sizes to be used for the matrices.
* Zero values will be skipped. The values must be at least
* zero.
*
* NTYPES (input) INTEGER
* The number of elements in DOTYPE. NTYPES must be at least
* zero. If it is zero, no randomly generated test matrices
* are tested, but and test matrices read from NIUNIT will be
* tested. If it is MAXTYP+1 and NSIZES is 1, then an
* additional type, MAXTYP+1 is defined, which is to use
* whatever matrix is in A. This is only useful if
* DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. .
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* If DOTYPE(j) is .TRUE., then for each size in NN a
* matrix of that size and of type j will be generated.
* If NTYPES is smaller than the maximum number of types
* defined (PARAMETER MAXTYP), then types NTYPES+1 through
* MAXTYP will not be generated. If NTYPES is larger
* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
* will be ignored.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The array elements should be between 0 and 4095;
* if not they will be reduced mod 4096. Also, ISEED(4) must
* be odd. The random number generator uses a linear
* congruential sequence limited to small integers, and so
* should produce machine independent random numbers. The
* values of ISEED are changed on exit, and can be used in the
* next call to SDRVVX to continue the same random number
* sequence.
*
* THRESH (input) REAL
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error
* is scaled to be O(1), so THRESH should be a reasonably
* small multiple of 1, e.g., 10 or 100. In particular,
* it should not depend on the precision (single vs. double)
* or the size of the matrix. It must be at least zero.
*
* NIUNIT (input) INTEGER
* The FORTRAN unit number for reading in the data file of
* problems to solve.
*
* NOUNIT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns INFO not equal to 0.)
*
* A (workspace) REAL array, dimension
* (LDA, max(NN,12))
* Used to hold the matrix whose eigenvalues are to be
* computed. On exit, A contains the last matrix actually used.
*
* LDA (input) INTEGER
* The leading dimension of the arrays A and H.
* LDA >= max(NN,12), since 12 is the dimension of the largest
* matrix in the precomputed input file.
*
* H (workspace) REAL array, dimension
* (LDA, max(NN,12))
* Another copy of the test matrix A, modified by SGEEVX.
*
* WR (workspace) REAL array, dimension (max(NN))
* WI (workspace) REAL array, dimension (max(NN))
* The real and imaginary parts of the eigenvalues of A.
* On exit, WR + WI*i are the eigenvalues of the matrix in A.
*
* WR1 (workspace) REAL array, dimension (max(NN,12))
* WI1 (workspace) REAL array, dimension (max(NN,12))
* Like WR, WI, these arrays contain the eigenvalues of A,
* but those computed when SGEEVX only computes a partial
* eigendecomposition, i.e. not the eigenvalues and left
* and right eigenvectors.
*
* VL (workspace) REAL array, dimension
* (LDVL, max(NN,12))
* VL holds the computed left eigenvectors.
*
* LDVL (input) INTEGER
* Leading dimension of VL. Must be at least max(1,max(NN,12)).
*
* VR (workspace) REAL array, dimension
* (LDVR, max(NN,12))
* VR holds the computed right eigenvectors.
*
* LDVR (input) INTEGER
* Leading dimension of VR. Must be at least max(1,max(NN,12)).
*
* LRE (workspace) REAL array, dimension
* (LDLRE, max(NN,12))
* LRE holds the computed right or left eigenvectors.
*
* LDLRE (input) INTEGER
* Leading dimension of LRE. Must be at least max(1,max(NN,12))
*
* RCONDV (workspace) REAL array, dimension (N)
* RCONDV holds the computed reciprocal condition numbers
* for eigenvectors.
*
* RCNDV1 (workspace) REAL array, dimension (N)
* RCNDV1 holds more computed reciprocal condition numbers
* for eigenvectors.
*
* RCDVIN (workspace) REAL array, dimension (N)
* When COMP = .TRUE. RCDVIN holds the precomputed reciprocal
* condition numbers for eigenvectors to be compared with
* RCONDV.
*
* RCONDE (workspace) REAL array, dimension (N)
* RCONDE holds the computed reciprocal condition numbers
* for eigenvalues.
*
* RCNDE1 (workspace) REAL array, dimension (N)
* RCNDE1 holds more computed reciprocal condition numbers
* for eigenvalues.
*
* RCDEIN (workspace) REAL array, dimension (N)
* When COMP = .TRUE. RCDEIN holds the precomputed reciprocal
* condition numbers for eigenvalues to be compared with
* RCONDE.
*
* RESULT (output) REAL array, dimension (11)
* The values computed by the seven tests described above.
* The values are currently limited to 1/ulp, to avoid overflow.
*
* WORK (workspace) REAL array, dimension (NWORK)
*
* NWORK (input) INTEGER
* The number of entries in WORK. This must be at least
* max(6*12+2*12**2,6*NN(j)+2*NN(j)**2) =
* max( 360 ,6*NN(j)+2*NN(j)**2) for all j.
*
* IWORK (workspace) INTEGER array, dimension (2*max(NN,12))
*
* INFO (output) INTEGER
* If 0, then successful exit.
* If <0, then input paramter -INFO is incorrect.
* If >0, SLATMR, SLATMS, SLATME or SGET23 returned an error
* code, and INFO is its absolute value.
*
*-----------------------------------------------------------------------
*
* Some Local Variables and Parameters:
* ---- ----- --------- --- ----------
*
* ZERO, ONE Real 0 and 1.
* MAXTYP The number of types defined.
* NMAX Largest value in NN or 12.
* NERRS The number of tests which have exceeded THRESH
* COND, CONDS,
* IMODE Values to be passed to the matrix generators.
* ANORM Norm of A; passed to matrix generators.
*
* OVFL, UNFL Overflow and underflow thresholds.
* ULP, ULPINV Finest relative precision and its inverse.
* RTULP, RTULPI Square roots of the previous 4 values.
*
* The following four arrays decode JTYPE:
* KTYPE(j) The general type (1-10) for type "j".
* KMODE(j) The MODE value to be passed to the matrix
* generator for type "j".
* KMAGN(j) The order of magnitude ( O(1),
* O(overflow^(1/2) ), O(underflow^(1/2) )
* KCONDS(j) Selectw whether CONDS is to be 1 or
* 1/sqrt(ulp). (0 means irrelevant.)
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 21 )
* ..
* .. Local Scalars ..
LOGICAL BADNN
CHARACTER BALANC
CHARACTER*3 PATH
INTEGER I, IBAL, IINFO, IMODE, ITYPE, IWK, J, JCOL,
$ JSIZE, JTYPE, MTYPES, N, NERRS, NFAIL,
$ NMAX, NNWORK, NTEST, NTESTF, NTESTT
REAL ANORM, COND, CONDS, OVFL, RTULP, RTULPI, ULP,
$ ULPINV, UNFL
* ..
* .. Local Arrays ..
CHARACTER ADUMMA( 1 ), BAL( 4 )
INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( MAXTYP ),
$ KMAGN( MAXTYP ), KMODE( MAXTYP ),
$ KTYPE( MAXTYP )
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SGET23, SLABAD, SLASUM, SLATME, SLATMR, SLATMS,
$ SLASET, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Data statements ..
DATA KTYPE / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
DATA KMAGN / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
$ 3, 1, 2, 3 /
DATA KMODE / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
$ 1, 5, 5, 5, 4, 3, 1 /
DATA KCONDS / 3*0, 5*0, 4*1, 6*2, 3*0 /
DATA BAL / 'N', 'P', 'S', 'B' /
* ..
* .. Executable Statements ..
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'VX'
*
* Check for errors
*
NTESTT = 0
NTESTF = 0
INFO = 0
*
* Important constants
*
BADNN = .FALSE.
*
* 12 is the largest dimension in the input file of precomputed
* problems
*
NMAX = 12
DO 10 J = 1, NSIZES
NMAX = MAX( NMAX, NN( J ) )
IF( NN( J ).LT.0 )
$ BADNN = .TRUE.
10 CONTINUE
*
* Check for errors
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADNN ) THEN
INFO = -2
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -3
ELSE IF( THRESH.LT.ZERO ) THEN
INFO = -6
ELSE IF( LDA.LT.1 .OR. LDA.LT.NMAX ) THEN
INFO = -10
ELSE IF( LDVL.LT.1 .OR. LDVL.LT.NMAX ) THEN
INFO = -17
ELSE IF( LDVR.LT.1 .OR. LDVR.LT.NMAX ) THEN
INFO = -19
ELSE IF( LDLRE.LT.1 .OR. LDLRE.LT.NMAX ) THEN
INFO = -21
ELSE IF( 6*NMAX+2*NMAX**2.GT.NWORK ) THEN
INFO = -32
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SDRVVX', -INFO )
RETURN
END IF
*
* If nothing to do check on NIUNIT
*
IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
$ GO TO 160
*
* More Important constants
*
UNFL = SLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
CALL SLABAD( UNFL, OVFL )
ULP = SLAMCH( 'Precision' )
ULPINV = ONE / ULP
RTULP = SQRT( ULP )
RTULPI = ONE / RTULP
*
* Loop over sizes, types
*
NERRS = 0
*
DO 150 JSIZE = 1, NSIZES
N = NN( JSIZE )
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
DO 140 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 140
*
* Save ISEED in case of an error.
*
DO 20 J = 1, 4
IOLDSD( J ) = ISEED( J )
20 CONTINUE
*
* Compute "A"
*
* Control parameters:
*
* KMAGN KCONDS KMODE KTYPE
* =1 O(1) 1 clustered 1 zero
* =2 large large clustered 2 identity
* =3 small exponential Jordan
* =4 arithmetic diagonal, (w/ eigenvalues)
* =5 random log symmetric, w/ eigenvalues
* =6 random general, w/ eigenvalues
* =7 random diagonal
* =8 random symmetric
* =9 random general
* =10 random triangular
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 90
*
ITYPE = KTYPE( JTYPE )
IMODE = KMODE( JTYPE )
*
* Compute norm
*
GO TO ( 30, 40, 50 )KMAGN( JTYPE )
*
30 CONTINUE
ANORM = ONE
GO TO 60
*
40 CONTINUE
ANORM = OVFL*ULP
GO TO 60
*
50 CONTINUE
ANORM = UNFL*ULPINV
GO TO 60
*
60 CONTINUE
*
CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
IINFO = 0
COND = ULPINV
*
* Special Matrices -- Identity & Jordan block
*
* Zero
*
IF( ITYPE.EQ.1 ) THEN
IINFO = 0
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Identity
*
DO 70 JCOL = 1, N
A( JCOL, JCOL ) = ANORM
70 CONTINUE
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* Jordan Block
*
DO 80 JCOL = 1, N
A( JCOL, JCOL ) = ANORM
IF( JCOL.GT.1 )
$ A( JCOL, JCOL-1 ) = ONE
80 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Diagonal Matrix, [Eigen]values Specified
*
CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.5 ) THEN
*
* Symmetric, eigenvalues specified
*
CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, N, N, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.6 ) THEN
*
* General, eigenvalues specified
*
IF( KCONDS( JTYPE ).EQ.1 ) THEN
CONDS = ONE
ELSE IF( KCONDS( JTYPE ).EQ.2 ) THEN
CONDS = RTULPI
ELSE
CONDS = ZERO
END IF
*
ADUMMA( 1 ) = ' '
CALL SLATME( N, 'S', ISEED, WORK, IMODE, COND, ONE,
$ ADUMMA, 'T', 'T', 'T', WORK( N+1 ), 4,
$ CONDS, N, N, ANORM, A, LDA, WORK( 2*N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.7 ) THEN
*
* Diagonal, random eigenvalues
*
CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.8 ) THEN
*
* Symmetric, random eigenvalues
*
CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.9 ) THEN
*
* General, random eigenvalues
*
CALL SLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
IF( N.GE.4 ) THEN
CALL SLASET( 'Full', 2, N, ZERO, ZERO, A, LDA )
CALL SLASET( 'Full', N-3, 1, ZERO, ZERO, A( 3, 1 ),
$ LDA )
CALL SLASET( 'Full', N-3, 2, ZERO, ZERO, A( 3, N-1 ),
$ LDA )
CALL SLASET( 'Full', 1, N, ZERO, ZERO, A( N, 1 ),
$ LDA )
END IF
*
ELSE IF( ITYPE.EQ.10 ) THEN
*
* Triangular, random eigenvalues
*
CALL SLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, 0,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE
*
IINFO = 1
END IF
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9992 )'Generator', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
90 CONTINUE
*
* Test for minimal and generous workspace
*
DO 130 IWK = 1, 3
IF( IWK.EQ.1 ) THEN
NNWORK = 3*N
ELSE IF( IWK.EQ.2 ) THEN
NNWORK = 6*N + N**2
ELSE
NNWORK = 6*N + 2*N**2
END IF
NNWORK = MAX( NNWORK, 1 )
*
* Test for all balancing options
*
DO 120 IBAL = 1, 4
BALANC = BAL( IBAL )
*
* Perform tests
*
CALL SGET23( .FALSE., BALANC, JTYPE, THRESH, IOLDSD,
$ NOUNIT, N, A, LDA, H, WR, WI, WR1, WI1,
$ VL, LDVL, VR, LDVR, LRE, LDLRE, RCONDV,
$ RCNDV1, RCDVIN, RCONDE, RCNDE1, RCDEIN,
$ SCALE, SCALE1, RESULT, WORK, NNWORK,
$ IWORK, INFO )
*
* Check for RESULT(j) > THRESH
*
NTEST = 0
NFAIL = 0
DO 100 J = 1, 9
IF( RESULT( J ).GE.ZERO )
$ NTEST = NTEST + 1
IF( RESULT( J ).GE.THRESH )
$ NFAIL = NFAIL + 1
100 CONTINUE
*
IF( NFAIL.GT.0 )
$ NTESTF = NTESTF + 1
IF( NTESTF.EQ.1 ) THEN
WRITE( NOUNIT, FMT = 9999 )PATH
WRITE( NOUNIT, FMT = 9998 )
WRITE( NOUNIT, FMT = 9997 )
WRITE( NOUNIT, FMT = 9996 )
WRITE( NOUNIT, FMT = 9995 )THRESH
NTESTF = 2
END IF
*
DO 110 J = 1, 9
IF( RESULT( J ).GE.THRESH ) THEN
WRITE( NOUNIT, FMT = 9994 )BALANC, N, IWK,
$ IOLDSD, JTYPE, J, RESULT( J )
END IF
110 CONTINUE
*
NERRS = NERRS + NFAIL
NTESTT = NTESTT + NTEST
*
120 CONTINUE
130 CONTINUE
140 CONTINUE
150 CONTINUE
*
160 CONTINUE
*
* Read in data from file to check accuracy of condition estimation.
* Assume input eigenvalues are sorted lexicographically (increasing
* by real part, then decreasing by imaginary part)
*
JTYPE = 0
170 CONTINUE
READ( NIUNIT, FMT = *, END = 220 )N
*
* Read input data until N=0
*
IF( N.EQ.0 )
$ GO TO 220
JTYPE = JTYPE + 1
ISEED( 1 ) = JTYPE
DO 180 I = 1, N
READ( NIUNIT, FMT = * )( A( I, J ), J = 1, N )
180 CONTINUE
DO 190 I = 1, N
READ( NIUNIT, FMT = * )WR1( I ), WI1( I ), RCDEIN( I ),
$ RCDVIN( I )
190 CONTINUE
CALL SGET23( .TRUE., 'N', 22, THRESH, ISEED, NOUNIT, N, A, LDA, H,
$ WR, WI, WR1, WI1, VL, LDVL, VR, LDVR, LRE, LDLRE,
$ RCONDV, RCNDV1, RCDVIN, RCONDE, RCNDE1, RCDEIN,
$ SCALE, SCALE1, RESULT, WORK, 6*N+2*N**2, IWORK,
$ INFO )
*
* Check for RESULT(j) > THRESH
*
NTEST = 0
NFAIL = 0
DO 200 J = 1, 11
IF( RESULT( J ).GE.ZERO )
$ NTEST = NTEST + 1
IF( RESULT( J ).GE.THRESH )
$ NFAIL = NFAIL + 1
200 CONTINUE
*
IF( NFAIL.GT.0 )
$ NTESTF = NTESTF + 1
IF( NTESTF.EQ.1 ) THEN
WRITE( NOUNIT, FMT = 9999 )PATH
WRITE( NOUNIT, FMT = 9998 )
WRITE( NOUNIT, FMT = 9997 )
WRITE( NOUNIT, FMT = 9996 )
WRITE( NOUNIT, FMT = 9995 )THRESH
NTESTF = 2
END IF
*
DO 210 J = 1, 11
IF( RESULT( J ).GE.THRESH ) THEN
WRITE( NOUNIT, FMT = 9993 )N, JTYPE, J, RESULT( J )
END IF
210 CONTINUE
*
NERRS = NERRS + NFAIL
NTESTT = NTESTT + NTEST
GO TO 170
220 CONTINUE
*
* Summary
*
CALL SLASUM( PATH, NOUNIT, NERRS, NTESTT )
*
9999 FORMAT( / 1X, A3, ' -- Real Eigenvalue-Eigenvector Decomposition',
$ ' Expert Driver', /
$ ' Matrix types (see SDRVVX for details): ' )
*
9998 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ',
$ ' ', ' 5=Diagonal: geometr. spaced entries.',
$ / ' 2=Identity matrix. ', ' 6=Diagona',
$ 'l: clustered entries.', / ' 3=Transposed Jordan block. ',
$ ' ', ' 7=Diagonal: large, evenly spaced.', / ' ',
$ '4=Diagonal: evenly spaced entries. ', ' 8=Diagonal: s',
$ 'mall, evenly spaced.' )
9997 FORMAT( ' Dense, Non-Symmetric Matrices:', / ' 9=Well-cond., ev',
$ 'enly spaced eigenvals.', ' 14=Ill-cond., geomet. spaced e',
$ 'igenals.', / ' 10=Well-cond., geom. spaced eigenvals. ',
$ ' 15=Ill-conditioned, clustered e.vals.', / ' 11=Well-cond',
$ 'itioned, clustered e.vals. ', ' 16=Ill-cond., random comp',
$ 'lex ', / ' 12=Well-cond., random complex ', ' ',
$ ' 17=Ill-cond., large rand. complx ', / ' 13=Ill-condi',
$ 'tioned, evenly spaced. ', ' 18=Ill-cond., small rand.',
$ ' complx ' )
9996 FORMAT( ' 19=Matrix with random O(1) entries. ', ' 21=Matrix ',
$ 'with small random entries.', / ' 20=Matrix with large ran',
$ 'dom entries. ', ' 22=Matrix read from input file', / )
9995 FORMAT( ' Tests performed with test threshold =', F8.2,
$ / / ' 1 = | A VR - VR W | / ( n |A| ulp ) ',
$ / ' 2 = | transpose(A) VL - VL W | / ( n |A| ulp ) ',
$ / ' 3 = | |VR(i)| - 1 | / ulp ',
$ / ' 4 = | |VL(i)| - 1 | / ulp ',
$ / ' 5 = 0 if W same no matter if VR or VL computed,',
$ ' 1/ulp otherwise', /
$ ' 6 = 0 if VR same no matter what else computed,',
$ ' 1/ulp otherwise', /
$ ' 7 = 0 if VL same no matter what else computed,',
$ ' 1/ulp otherwise', /
$ ' 8 = 0 if RCONDV same no matter what else computed,',
$ ' 1/ulp otherwise', /
$ ' 9 = 0 if SCALE, ILO, IHI, ABNRM same no matter what else',
$ ' computed, 1/ulp otherwise',
$ / ' 10 = | RCONDV - RCONDV(precomputed) | / cond(RCONDV),',
$ / ' 11 = | RCONDE - RCONDE(precomputed) | / cond(RCONDE),' )
9994 FORMAT( ' BALANC=''', A1, ''',N=', I4, ',IWK=', I1, ', seed=',
$ 4( I4, ',' ), ' type ', I2, ', test(', I2, ')=', G10.3 )
9993 FORMAT( ' N=', I5, ', input example =', I3, ', test(', I2, ')=',
$ G10.3 )
9992 FORMAT( ' SDRVVX: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
*
RETURN
*
* End of SDRVVX
*
END
SUBROUTINE SERRBD( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* SERRBD tests the error exits for SGEBRD, SORGBR, SORMBR, SBDSQR and
* SBDSDC.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX, LW
PARAMETER ( NMAX = 4, LW = NMAX )
* ..
* .. Local Scalars ..
CHARACTER*2 C2
INTEGER I, INFO, J, NT
* ..
* .. Local Arrays ..
INTEGER IQ( NMAX, NMAX ), IW( NMAX )
REAL A( NMAX, NMAX ), D( NMAX ), E( NMAX ),
$ Q( NMAX, NMAX ), TP( NMAX ), TQ( NMAX ),
$ U( NMAX, NMAX ), V( NMAX, NMAX ), W( LW )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL CHKXER, SBDSDC, SBDSQR, SGEBD2, SGEBRD, SORGBR,
$ SORMBR
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
C2 = PATH( 2: 3 )
*
* Set the variables to innocuous values.
*
DO 20 J = 1, NMAX
DO 10 I = 1, NMAX
A( I, J ) = 1. / REAL( I+J )
10 CONTINUE
20 CONTINUE
OK = .TRUE.
NT = 0
*
* Test error exits of the SVD routines.
*
IF( LSAMEN( 2, C2, 'BD' ) ) THEN
*
* SGEBRD
*
SRNAMT = 'SGEBRD'
INFOT = 1
CALL SGEBRD( -1, 0, A, 1, D, E, TQ, TP, W, 1, INFO )
CALL CHKXER( 'SGEBRD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGEBRD( 0, -1, A, 1, D, E, TQ, TP, W, 1, INFO )
CALL CHKXER( 'SGEBRD', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGEBRD( 2, 1, A, 1, D, E, TQ, TP, W, 2, INFO )
CALL CHKXER( 'SGEBRD', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SGEBRD( 2, 1, A, 2, D, E, TQ, TP, W, 1, INFO )
CALL CHKXER( 'SGEBRD', INFOT, NOUT, LERR, OK )
NT = NT + 4
*
* SGEBD2
*
SRNAMT = 'SGEBD2'
INFOT = 1
CALL SGEBD2( -1, 0, A, 1, D, E, TQ, TP, W, INFO )
CALL CHKXER( 'SGEBD2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGEBD2( 0, -1, A, 1, D, E, TQ, TP, W, INFO )
CALL CHKXER( 'SGEBD2', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGEBD2( 2, 1, A, 1, D, E, TQ, TP, W, INFO )
CALL CHKXER( 'SGEBD2', INFOT, NOUT, LERR, OK )
NT = NT + 3
*
* SORGBR
*
SRNAMT = 'SORGBR'
INFOT = 1
CALL SORGBR( '/', 0, 0, 0, A, 1, TQ, W, 1, INFO )
CALL CHKXER( 'SORGBR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORGBR( 'Q', -1, 0, 0, A, 1, TQ, W, 1, INFO )
CALL CHKXER( 'SORGBR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORGBR( 'Q', 0, -1, 0, A, 1, TQ, W, 1, INFO )
CALL CHKXER( 'SORGBR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORGBR( 'Q', 0, 1, 0, A, 1, TQ, W, 1, INFO )
CALL CHKXER( 'SORGBR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORGBR( 'Q', 1, 0, 1, A, 1, TQ, W, 1, INFO )
CALL CHKXER( 'SORGBR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORGBR( 'P', 1, 0, 0, A, 1, TQ, W, 1, INFO )
CALL CHKXER( 'SORGBR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORGBR( 'P', 0, 1, 1, A, 1, TQ, W, 1, INFO )
CALL CHKXER( 'SORGBR', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SORGBR( 'Q', 0, 0, -1, A, 1, TQ, W, 1, INFO )
CALL CHKXER( 'SORGBR', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SORGBR( 'Q', 2, 1, 1, A, 1, TQ, W, 1, INFO )
CALL CHKXER( 'SORGBR', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SORGBR( 'Q', 2, 2, 1, A, 2, TQ, W, 1, INFO )
CALL CHKXER( 'SORGBR', INFOT, NOUT, LERR, OK )
NT = NT + 10
*
* SORMBR
*
SRNAMT = 'SORMBR'
INFOT = 1
CALL SORMBR( '/', 'L', 'T', 0, 0, 0, A, 1, TQ, U, 1, W, 1,
$ INFO )
CALL CHKXER( 'SORMBR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORMBR( 'Q', '/', 'T', 0, 0, 0, A, 1, TQ, U, 1, W, 1,
$ INFO )
CALL CHKXER( 'SORMBR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORMBR( 'Q', 'L', '/', 0, 0, 0, A, 1, TQ, U, 1, W, 1,
$ INFO )
CALL CHKXER( 'SORMBR', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SORMBR( 'Q', 'L', 'T', -1, 0, 0, A, 1, TQ, U, 1, W, 1,
$ INFO )
CALL CHKXER( 'SORMBR', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORMBR( 'Q', 'L', 'T', 0, -1, 0, A, 1, TQ, U, 1, W, 1,
$ INFO )
CALL CHKXER( 'SORMBR', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SORMBR( 'Q', 'L', 'T', 0, 0, -1, A, 1, TQ, U, 1, W, 1,
$ INFO )
CALL CHKXER( 'SORMBR', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SORMBR( 'Q', 'L', 'T', 2, 0, 0, A, 1, TQ, U, 2, W, 1,
$ INFO )
CALL CHKXER( 'SORMBR', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SORMBR( 'Q', 'R', 'T', 0, 2, 0, A, 1, TQ, U, 1, W, 1,
$ INFO )
CALL CHKXER( 'SORMBR', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SORMBR( 'P', 'L', 'T', 2, 0, 2, A, 1, TQ, U, 2, W, 1,
$ INFO )
CALL CHKXER( 'SORMBR', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SORMBR( 'P', 'R', 'T', 0, 2, 2, A, 1, TQ, U, 1, W, 1,
$ INFO )
CALL CHKXER( 'SORMBR', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL SORMBR( 'Q', 'R', 'T', 2, 0, 0, A, 1, TQ, U, 1, W, 1,
$ INFO )
CALL CHKXER( 'SORMBR', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL SORMBR( 'Q', 'L', 'T', 0, 2, 0, A, 1, TQ, U, 1, W, 1,
$ INFO )
CALL CHKXER( 'SORMBR', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL SORMBR( 'Q', 'R', 'T', 2, 0, 0, A, 1, TQ, U, 2, W, 1,
$ INFO )
CALL CHKXER( 'SORMBR', INFOT, NOUT, LERR, OK )
NT = NT + 13
*
* SBDSQR
*
SRNAMT = 'SBDSQR'
INFOT = 1
CALL SBDSQR( '/', 0, 0, 0, 0, D, E, V, 1, U, 1, A, 1, W, INFO )
CALL CHKXER( 'SBDSQR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SBDSQR( 'U', -1, 0, 0, 0, D, E, V, 1, U, 1, A, 1, W,
$ INFO )
CALL CHKXER( 'SBDSQR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SBDSQR( 'U', 0, -1, 0, 0, D, E, V, 1, U, 1, A, 1, W,
$ INFO )
CALL CHKXER( 'SBDSQR', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SBDSQR( 'U', 0, 0, -1, 0, D, E, V, 1, U, 1, A, 1, W,
$ INFO )
CALL CHKXER( 'SBDSQR', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SBDSQR( 'U', 0, 0, 0, -1, D, E, V, 1, U, 1, A, 1, W,
$ INFO )
CALL CHKXER( 'SBDSQR', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SBDSQR( 'U', 2, 1, 0, 0, D, E, V, 1, U, 1, A, 1, W, INFO )
CALL CHKXER( 'SBDSQR', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL SBDSQR( 'U', 0, 0, 2, 0, D, E, V, 1, U, 1, A, 1, W, INFO )
CALL CHKXER( 'SBDSQR', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL SBDSQR( 'U', 2, 0, 0, 1, D, E, V, 1, U, 1, A, 1, W, INFO )
CALL CHKXER( 'SBDSQR', INFOT, NOUT, LERR, OK )
NT = NT + 8
*
* SBDSDC
*
SRNAMT = 'SBDSDC'
INFOT = 1
CALL SBDSDC( '/', 'N', 0, D, E, U, 1, V, 1, Q, IQ, W, IW,
$ INFO )
CALL CHKXER( 'SBDSDC', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SBDSDC( 'U', '/', 0, D, E, U, 1, V, 1, Q, IQ, W, IW,
$ INFO )
CALL CHKXER( 'SBDSDC', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SBDSDC( 'U', 'N', -1, D, E, U, 1, V, 1, Q, IQ, W, IW,
$ INFO )
CALL CHKXER( 'SBDSDC', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SBDSDC( 'U', 'I', 2, D, E, U, 1, V, 1, Q, IQ, W, IW,
$ INFO )
CALL CHKXER( 'SBDSDC', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SBDSDC( 'U', 'I', 2, D, E, U, 2, V, 1, Q, IQ, W, IW,
$ INFO )
CALL CHKXER( 'SBDSDC', INFOT, NOUT, LERR, OK )
NT = NT + 5
END IF
*
* Print a summary line.
*
IF( OK ) THEN
WRITE( NOUT, FMT = 9999 )PATH, NT
ELSE
WRITE( NOUT, FMT = 9998 )PATH
END IF
*
9999 FORMAT( 1X, A3, ' routines passed the tests of the error exits',
$ ' (', I3, ' tests done)' )
9998 FORMAT( ' *** ', A3, ' routines failed the tests of the error ',
$ 'exits ***' )
*
RETURN
*
* End of SERRBD
*
END
SUBROUTINE SERREC( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* SERREC tests the error exits for the routines for eigen- condition
* estimation for REAL matrices:
* STRSYL, STREXC, STRSNA and STRSEN.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
REAL ONE, ZERO
PARAMETER ( NMAX = 4, ONE = 1.0E0, ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
INTEGER I, IFST, ILST, INFO, J, M, NT
REAL SCALE
* ..
* .. Local Arrays ..
LOGICAL SEL( NMAX )
INTEGER IWORK( NMAX )
REAL A( NMAX, NMAX ), B( NMAX, NMAX ),
$ C( NMAX, NMAX ), S( NMAX ), SEP( NMAX ),
$ WI( NMAX ), WORK( NMAX ), WR( NMAX )
* ..
* .. External Subroutines ..
EXTERNAL CHKXER, STREXC, STRSEN, STRSNA, STRSYL
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
OK = .TRUE.
NT = 0
*
* Initialize A, B and SEL
*
DO 20 J = 1, NMAX
DO 10 I = 1, NMAX
A( I, J ) = ZERO
B( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
DO 30 I = 1, NMAX
A( I, I ) = ONE
SEL( I ) = .TRUE.
30 CONTINUE
*
* Test STRSYL
*
SRNAMT = 'STRSYL'
INFOT = 1
CALL STRSYL( 'X', 'N', 1, 0, 0, A, 1, B, 1, C, 1, SCALE, INFO )
CALL CHKXER( 'STRSYL', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STRSYL( 'N', 'X', 1, 0, 0, A, 1, B, 1, C, 1, SCALE, INFO )
CALL CHKXER( 'STRSYL', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL STRSYL( 'N', 'N', 0, 0, 0, A, 1, B, 1, C, 1, SCALE, INFO )
CALL CHKXER( 'STRSYL', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL STRSYL( 'N', 'N', 1, -1, 0, A, 1, B, 1, C, 1, SCALE, INFO )
CALL CHKXER( 'STRSYL', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STRSYL( 'N', 'N', 1, 0, -1, A, 1, B, 1, C, 1, SCALE, INFO )
CALL CHKXER( 'STRSYL', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL STRSYL( 'N', 'N', 1, 2, 0, A, 1, B, 1, C, 2, SCALE, INFO )
CALL CHKXER( 'STRSYL', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL STRSYL( 'N', 'N', 1, 0, 2, A, 1, B, 1, C, 1, SCALE, INFO )
CALL CHKXER( 'STRSYL', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL STRSYL( 'N', 'N', 1, 2, 0, A, 2, B, 1, C, 1, SCALE, INFO )
CALL CHKXER( 'STRSYL', INFOT, NOUT, LERR, OK )
NT = NT + 8
*
* Test STREXC
*
SRNAMT = 'STREXC'
IFST = 1
ILST = 1
INFOT = 1
CALL STREXC( 'X', 1, A, 1, B, 1, IFST, ILST, WORK, INFO )
CALL CHKXER( 'STREXC', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL STREXC( 'N', 0, A, 1, B, 1, IFST, ILST, WORK, INFO )
CALL CHKXER( 'STREXC', INFOT, NOUT, LERR, OK )
INFOT = 4
ILST = 2
CALL STREXC( 'N', 2, A, 1, B, 1, IFST, ILST, WORK, INFO )
CALL CHKXER( 'STREXC', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL STREXC( 'V', 2, A, 2, B, 1, IFST, ILST, WORK, INFO )
CALL CHKXER( 'STREXC', INFOT, NOUT, LERR, OK )
INFOT = 7
IFST = 0
ILST = 1
CALL STREXC( 'V', 1, A, 1, B, 1, IFST, ILST, WORK, INFO )
CALL CHKXER( 'STREXC', INFOT, NOUT, LERR, OK )
INFOT = 7
IFST = 2
CALL STREXC( 'V', 1, A, 1, B, 1, IFST, ILST, WORK, INFO )
CALL CHKXER( 'STREXC', INFOT, NOUT, LERR, OK )
INFOT = 8
IFST = 1
ILST = 0
CALL STREXC( 'V', 1, A, 1, B, 1, IFST, ILST, WORK, INFO )
CALL CHKXER( 'STREXC', INFOT, NOUT, LERR, OK )
INFOT = 8
ILST = 2
CALL STREXC( 'V', 1, A, 1, B, 1, IFST, ILST, WORK, INFO )
CALL CHKXER( 'STREXC', INFOT, NOUT, LERR, OK )
NT = NT + 8
*
* Test STRSNA
*
SRNAMT = 'STRSNA'
INFOT = 1
CALL STRSNA( 'X', 'A', SEL, 0, A, 1, B, 1, C, 1, S, SEP, 1, M,
$ WORK, 1, IWORK, INFO )
CALL CHKXER( 'STRSNA', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STRSNA( 'B', 'X', SEL, 0, A, 1, B, 1, C, 1, S, SEP, 1, M,
$ WORK, 1, IWORK, INFO )
CALL CHKXER( 'STRSNA', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL STRSNA( 'B', 'A', SEL, -1, A, 1, B, 1, C, 1, S, SEP, 1, M,
$ WORK, 1, IWORK, INFO )
CALL CHKXER( 'STRSNA', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL STRSNA( 'V', 'A', SEL, 2, A, 1, B, 1, C, 1, S, SEP, 2, M,
$ WORK, 2, IWORK, INFO )
CALL CHKXER( 'STRSNA', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL STRSNA( 'B', 'A', SEL, 2, A, 2, B, 1, C, 2, S, SEP, 2, M,
$ WORK, 2, IWORK, INFO )
CALL CHKXER( 'STRSNA', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL STRSNA( 'B', 'A', SEL, 2, A, 2, B, 2, C, 1, S, SEP, 2, M,
$ WORK, 2, IWORK, INFO )
CALL CHKXER( 'STRSNA', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL STRSNA( 'B', 'A', SEL, 1, A, 1, B, 1, C, 1, S, SEP, 0, M,
$ WORK, 1, IWORK, INFO )
CALL CHKXER( 'STRSNA', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL STRSNA( 'B', 'S', SEL, 2, A, 2, B, 2, C, 2, S, SEP, 1, M,
$ WORK, 2, IWORK, INFO )
CALL CHKXER( 'STRSNA', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL STRSNA( 'B', 'A', SEL, 2, A, 2, B, 2, C, 2, S, SEP, 2, M,
$ WORK, 1, IWORK, INFO )
CALL CHKXER( 'STRSNA', INFOT, NOUT, LERR, OK )
NT = NT + 9
*
* Test STRSEN
*
SEL( 1 ) = .FALSE.
SRNAMT = 'STRSEN'
INFOT = 1
CALL STRSEN( 'X', 'N', SEL, 0, A, 1, B, 1, WR, WI, M, S( 1 ),
$ SEP( 1 ), WORK, 1, IWORK, 1, INFO )
CALL CHKXER( 'STRSEN', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STRSEN( 'N', 'X', SEL, 0, A, 1, B, 1, WR, WI, M, S( 1 ),
$ SEP( 1 ), WORK, 1, IWORK, 1, INFO )
CALL CHKXER( 'STRSEN', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL STRSEN( 'N', 'N', SEL, -1, A, 1, B, 1, WR, WI, M, S( 1 ),
$ SEP( 1 ), WORK, 1, IWORK, 1, INFO )
CALL CHKXER( 'STRSEN', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL STRSEN( 'N', 'N', SEL, 2, A, 1, B, 1, WR, WI, M, S( 1 ),
$ SEP( 1 ), WORK, 2, IWORK, 1, INFO )
CALL CHKXER( 'STRSEN', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL STRSEN( 'N', 'V', SEL, 2, A, 2, B, 1, WR, WI, M, S( 1 ),
$ SEP( 1 ), WORK, 1, IWORK, 1, INFO )
CALL CHKXER( 'STRSEN', INFOT, NOUT, LERR, OK )
INFOT = 15
CALL STRSEN( 'N', 'V', SEL, 2, A, 2, B, 2, WR, WI, M, S( 1 ),
$ SEP( 1 ), WORK, 0, IWORK, 1, INFO )
CALL CHKXER( 'STRSEN', INFOT, NOUT, LERR, OK )
INFOT = 15
CALL STRSEN( 'E', 'V', SEL, 3, A, 3, B, 3, WR, WI, M, S( 1 ),
$ SEP( 1 ), WORK, 1, IWORK, 1, INFO )
CALL CHKXER( 'STRSEN', INFOT, NOUT, LERR, OK )
INFOT = 15
CALL STRSEN( 'V', 'V', SEL, 3, A, 3, B, 3, WR, WI, M, S( 1 ),
$ SEP( 1 ), WORK, 3, IWORK, 2, INFO )
CALL CHKXER( 'STRSEN', INFOT, NOUT, LERR, OK )
INFOT = 17
CALL STRSEN( 'E', 'V', SEL, 2, A, 2, B, 2, WR, WI, M, S( 1 ),
$ SEP( 1 ), WORK, 1, IWORK, 0, INFO )
CALL CHKXER( 'STRSEN', INFOT, NOUT, LERR, OK )
INFOT = 17
CALL STRSEN( 'V', 'V', SEL, 3, A, 3, B, 3, WR, WI, M, S( 1 ),
$ SEP( 1 ), WORK, 4, IWORK, 1, INFO )
CALL CHKXER( 'STRSEN', INFOT, NOUT, LERR, OK )
NT = NT + 10
*
* Print a summary line.
*
IF( OK ) THEN
WRITE( NOUT, FMT = 9999 )PATH, NT
ELSE
WRITE( NOUT, FMT = 9998 )PATH
END IF
*
RETURN
9999 FORMAT( 1X, A3, ' routines passed the tests of the error exits (',
$ I3, ' tests done)' )
9998 FORMAT( ' *** ', A3, ' routines failed the tests of the error ex',
$ 'its ***' )
*
* End of SERREC
*
END
SUBROUTINE SERRED( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* SERRED tests the error exits for the eigenvalue driver routines for
* REAL matrices:
*
* PATH driver description
* ---- ------ -----------
* SEV SGEEV find eigenvalues/eigenvectors for nonsymmetric A
* SES SGEES find eigenvalues/Schur form for nonsymmetric A
* SVX SGEEVX SGEEV + balancing and condition estimation
* SSX SGEESX SGEES + balancing and condition estimation
* SBD SGESVD compute SVD of an M-by-N matrix A
* SGESDD compute SVD of an M-by-N matrix A (by divide and
* conquer)
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
REAL ONE, ZERO
PARAMETER ( NMAX = 4, ONE = 1.0E0, ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
CHARACTER*2 C2
INTEGER I, IHI, ILO, INFO, J, NT, SDIM
REAL ABNRM
* ..
* .. Local Arrays ..
LOGICAL B( NMAX )
INTEGER IW( 2*NMAX )
REAL A( NMAX, NMAX ), R1( NMAX ), R2( NMAX ),
$ S( NMAX ), U( NMAX, NMAX ), VL( NMAX, NMAX ),
$ VR( NMAX, NMAX ), VT( NMAX, NMAX ),
$ W( 4*NMAX ), WI( NMAX ), WR( NMAX )
* ..
* .. External Subroutines ..
EXTERNAL CHKXER, SGEES, SGEESX, SGEEV, SGEEVX, SGESDD,
$ SGESVD
* ..
* .. External Functions ..
LOGICAL LSAMEN, SSLECT
EXTERNAL LSAMEN, SSLECT
* ..
* .. Arrays in Common ..
LOGICAL SELVAL( 20 )
REAL SELWI( 20 ), SELWR( 20 )
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT, SELDIM, SELOPT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
COMMON / SSLCT / SELOPT, SELDIM, SELVAL, SELWR, SELWI
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
C2 = PATH( 2: 3 )
*
* Initialize A
*
DO 20 J = 1, NMAX
DO 10 I = 1, NMAX
A( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
DO 30 I = 1, NMAX
A( I, I ) = ONE
30 CONTINUE
OK = .TRUE.
NT = 0
*
IF( LSAMEN( 2, C2, 'EV' ) ) THEN
*
* Test SGEEV
*
SRNAMT = 'SGEEV '
INFOT = 1
CALL SGEEV( 'X', 'N', 0, A, 1, WR, WI, VL, 1, VR, 1, W, 1,
$ INFO )
CALL CHKXER( 'SGEEV ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGEEV( 'N', 'X', 0, A, 1, WR, WI, VL, 1, VR, 1, W, 1,
$ INFO )
CALL CHKXER( 'SGEEV ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGEEV( 'N', 'N', -1, A, 1, WR, WI, VL, 1, VR, 1, W, 1,
$ INFO )
CALL CHKXER( 'SGEEV ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGEEV( 'N', 'N', 2, A, 1, WR, WI, VL, 1, VR, 1, W, 6,
$ INFO )
CALL CHKXER( 'SGEEV ', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SGEEV( 'V', 'N', 2, A, 2, WR, WI, VL, 1, VR, 1, W, 8,
$ INFO )
CALL CHKXER( 'SGEEV ', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL SGEEV( 'N', 'V', 2, A, 2, WR, WI, VL, 1, VR, 1, W, 8,
$ INFO )
CALL CHKXER( 'SGEEV ', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL SGEEV( 'V', 'V', 1, A, 1, WR, WI, VL, 1, VR, 1, W, 3,
$ INFO )
CALL CHKXER( 'SGEEV ', INFOT, NOUT, LERR, OK )
NT = NT + 7
*
ELSE IF( LSAMEN( 2, C2, 'ES' ) ) THEN
*
* Test SGEES
*
SRNAMT = 'SGEES '
INFOT = 1
CALL SGEES( 'X', 'N', SSLECT, 0, A, 1, SDIM, WR, WI, VL, 1, W,
$ 1, B, INFO )
CALL CHKXER( 'SGEES ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGEES( 'N', 'X', SSLECT, 0, A, 1, SDIM, WR, WI, VL, 1, W,
$ 1, B, INFO )
CALL CHKXER( 'SGEES ', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGEES( 'N', 'S', SSLECT, -1, A, 1, SDIM, WR, WI, VL, 1, W,
$ 1, B, INFO )
CALL CHKXER( 'SGEES ', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SGEES( 'N', 'S', SSLECT, 2, A, 1, SDIM, WR, WI, VL, 1, W,
$ 6, B, INFO )
CALL CHKXER( 'SGEES ', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL SGEES( 'V', 'S', SSLECT, 2, A, 2, SDIM, WR, WI, VL, 1, W,
$ 6, B, INFO )
CALL CHKXER( 'SGEES ', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL SGEES( 'N', 'S', SSLECT, 1, A, 1, SDIM, WR, WI, VL, 1, W,
$ 2, B, INFO )
CALL CHKXER( 'SGEES ', INFOT, NOUT, LERR, OK )
NT = NT + 6
*
ELSE IF( LSAMEN( 2, C2, 'VX' ) ) THEN
*
* Test SGEEVX
*
SRNAMT = 'SGEEVX'
INFOT = 1
CALL SGEEVX( 'X', 'N', 'N', 'N', 0, A, 1, WR, WI, VL, 1, VR, 1,
$ ILO, IHI, S, ABNRM, R1, R2, W, 1, IW, INFO )
CALL CHKXER( 'SGEEVX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGEEVX( 'N', 'X', 'N', 'N', 0, A, 1, WR, WI, VL, 1, VR, 1,
$ ILO, IHI, S, ABNRM, R1, R2, W, 1, IW, INFO )
CALL CHKXER( 'SGEEVX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGEEVX( 'N', 'N', 'X', 'N', 0, A, 1, WR, WI, VL, 1, VR, 1,
$ ILO, IHI, S, ABNRM, R1, R2, W, 1, IW, INFO )
CALL CHKXER( 'SGEEVX', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGEEVX( 'N', 'N', 'N', 'X', 0, A, 1, WR, WI, VL, 1, VR, 1,
$ ILO, IHI, S, ABNRM, R1, R2, W, 1, IW, INFO )
CALL CHKXER( 'SGEEVX', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGEEVX( 'N', 'N', 'N', 'N', -1, A, 1, WR, WI, VL, 1, VR,
$ 1, ILO, IHI, S, ABNRM, R1, R2, W, 1, IW, INFO )
CALL CHKXER( 'SGEEVX', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SGEEVX( 'N', 'N', 'N', 'N', 2, A, 1, WR, WI, VL, 1, VR, 1,
$ ILO, IHI, S, ABNRM, R1, R2, W, 1, IW, INFO )
CALL CHKXER( 'SGEEVX', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL SGEEVX( 'N', 'V', 'N', 'N', 2, A, 2, WR, WI, VL, 1, VR, 1,
$ ILO, IHI, S, ABNRM, R1, R2, W, 6, IW, INFO )
CALL CHKXER( 'SGEEVX', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL SGEEVX( 'N', 'N', 'V', 'N', 2, A, 2, WR, WI, VL, 1, VR, 1,
$ ILO, IHI, S, ABNRM, R1, R2, W, 6, IW, INFO )
CALL CHKXER( 'SGEEVX', INFOT, NOUT, LERR, OK )
INFOT = 21
CALL SGEEVX( 'N', 'N', 'N', 'N', 1, A, 1, WR, WI, VL, 1, VR, 1,
$ ILO, IHI, S, ABNRM, R1, R2, W, 1, IW, INFO )
CALL CHKXER( 'SGEEVX', INFOT, NOUT, LERR, OK )
INFOT = 21
CALL SGEEVX( 'N', 'V', 'N', 'N', 1, A, 1, WR, WI, VL, 1, VR, 1,
$ ILO, IHI, S, ABNRM, R1, R2, W, 2, IW, INFO )
CALL CHKXER( 'SGEEVX', INFOT, NOUT, LERR, OK )
INFOT = 21
CALL SGEEVX( 'N', 'N', 'V', 'V', 1, A, 1, WR, WI, VL, 1, VR, 1,
$ ILO, IHI, S, ABNRM, R1, R2, W, 3, IW, INFO )
CALL CHKXER( 'SGEEVX', INFOT, NOUT, LERR, OK )
NT = NT + 11
*
ELSE IF( LSAMEN( 2, C2, 'SX' ) ) THEN
*
* Test SGEESX
*
SRNAMT = 'SGEESX'
INFOT = 1
CALL SGEESX( 'X', 'N', SSLECT, 'N', 0, A, 1, SDIM, WR, WI, VL,
$ 1, R1( 1 ), R2( 1 ), W, 1, IW, 1, B, INFO )
CALL CHKXER( 'SGEESX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGEESX( 'N', 'X', SSLECT, 'N', 0, A, 1, SDIM, WR, WI, VL,
$ 1, R1( 1 ), R2( 1 ), W, 1, IW, 1, B, INFO )
CALL CHKXER( 'SGEESX', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGEESX( 'N', 'N', SSLECT, 'X', 0, A, 1, SDIM, WR, WI, VL,
$ 1, R1( 1 ), R2( 1 ), W, 1, IW, 1, B, INFO )
CALL CHKXER( 'SGEESX', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGEESX( 'N', 'N', SSLECT, 'N', -1, A, 1, SDIM, WR, WI, VL,
$ 1, R1( 1 ), R2( 1 ), W, 1, IW, 1, B, INFO )
CALL CHKXER( 'SGEESX', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SGEESX( 'N', 'N', SSLECT, 'N', 2, A, 1, SDIM, WR, WI, VL,
$ 1, R1( 1 ), R2( 1 ), W, 6, IW, 1, B, INFO )
CALL CHKXER( 'SGEESX', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SGEESX( 'V', 'N', SSLECT, 'N', 2, A, 2, SDIM, WR, WI, VL,
$ 1, R1( 1 ), R2( 1 ), W, 6, IW, 1, B, INFO )
CALL CHKXER( 'SGEESX', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL SGEESX( 'N', 'N', SSLECT, 'N', 1, A, 1, SDIM, WR, WI, VL,
$ 1, R1( 1 ), R2( 1 ), W, 2, IW, 1, B, INFO )
CALL CHKXER( 'SGEESX', INFOT, NOUT, LERR, OK )
NT = NT + 7
*
ELSE IF( LSAMEN( 2, C2, 'BD' ) ) THEN
*
* Test SGESVD
*
SRNAMT = 'SGESVD'
INFOT = 1
CALL SGESVD( 'X', 'N', 0, 0, A, 1, S, U, 1, VT, 1, W, 1, INFO )
CALL CHKXER( 'SGESVD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGESVD( 'N', 'X', 0, 0, A, 1, S, U, 1, VT, 1, W, 1, INFO )
CALL CHKXER( 'SGESVD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGESVD( 'O', 'O', 0, 0, A, 1, S, U, 1, VT, 1, W, 1, INFO )
CALL CHKXER( 'SGESVD', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGESVD( 'N', 'N', -1, 0, A, 1, S, U, 1, VT, 1, W, 1,
$ INFO )
CALL CHKXER( 'SGESVD', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGESVD( 'N', 'N', 0, -1, A, 1, S, U, 1, VT, 1, W, 1,
$ INFO )
CALL CHKXER( 'SGESVD', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SGESVD( 'N', 'N', 2, 1, A, 1, S, U, 1, VT, 1, W, 5, INFO )
CALL CHKXER( 'SGESVD', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SGESVD( 'A', 'N', 2, 1, A, 2, S, U, 1, VT, 1, W, 5, INFO )
CALL CHKXER( 'SGESVD', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL SGESVD( 'N', 'A', 1, 2, A, 1, S, U, 1, VT, 1, W, 5, INFO )
CALL CHKXER( 'SGESVD', INFOT, NOUT, LERR, OK )
NT = NT + 8
*
* Test SGESDD
*
SRNAMT = 'SGESDD'
INFOT = 1
CALL SGESDD( 'X', 0, 0, A, 1, S, U, 1, VT, 1, W, 1, IW, INFO )
CALL CHKXER( 'SGESDD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGESDD( 'N', -1, 0, A, 1, S, U, 1, VT, 1, W, 1, IW, INFO )
CALL CHKXER( 'SGESDD', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGESDD( 'N', 0, -1, A, 1, S, U, 1, VT, 1, W, 1, IW, INFO )
CALL CHKXER( 'SGESDD', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGESDD( 'N', 2, 1, A, 1, S, U, 1, VT, 1, W, 5, IW, INFO )
CALL CHKXER( 'SGESDD', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SGESDD( 'A', 2, 1, A, 2, S, U, 1, VT, 1, W, 5, IW, INFO )
CALL CHKXER( 'SGESDD', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SGESDD( 'A', 1, 2, A, 1, S, U, 1, VT, 1, W, 5, IW, INFO )
CALL CHKXER( 'SGESDD', INFOT, NOUT, LERR, OK )
NT = NT + 6
END IF
*
* Print a summary line.
*
IF( .NOT.LSAMEN( 2, C2, 'BD' ) ) THEN
IF( OK ) THEN
WRITE( NOUT, FMT = 9999 )PATH, NT
ELSE
WRITE( NOUT, FMT = 9998 )PATH
END IF
END IF
*
9999 FORMAT( 1X, A3, ' routines passed the tests of the error exits (',
$ I3, ' tests done)' )
9998 FORMAT( ' *** ', A3, ' routines failed the tests of the error ex',
$ 'its ***' )
RETURN
*
* End of SERRED
*
END
SUBROUTINE SERRGG( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* SERRGG tests the error exits for SGGES, SGGESX, SGGEV, SGGEVX,
* SGGGLM, SGGHRD, SGGLSE, SGGQRF, SGGRQF, SGGSVD, SGGSVP, SHGEQZ,
* STGEVC, STGEXC, STGSEN, STGSJA, STGSNA, and STGSYL.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX, LW
PARAMETER ( NMAX = 3, LW = 6*NMAX )
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
CHARACTER*2 C2
INTEGER DUMMYK, DUMMYL, I, IFST, ILST, INFO, J, M,
$ NCYCLE, NT, SDIM
REAL ANRM, BNRM, DIF, SCALE, TOLA, TOLB
* ..
* .. Local Arrays ..
LOGICAL BW( NMAX ), SEL( NMAX )
INTEGER IW( NMAX )
REAL A( NMAX, NMAX ), B( NMAX, NMAX ), LS( NMAX ),
$ Q( NMAX, NMAX ), R1( NMAX ), R2( NMAX ),
$ R3( NMAX ), RCE( 2 ), RCV( 2 ), RS( NMAX ),
$ TAU( NMAX ), U( NMAX, NMAX ), V( NMAX, NMAX ),
$ W( LW ), Z( NMAX, NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN, SLCTES, SLCTSX
EXTERNAL LSAMEN, SLCTES, SLCTSX
* ..
* .. External Subroutines ..
EXTERNAL CHKXER, SGGES, SGGESX, SGGEV, SGGEVX, SGGGLM,
$ SGGHRD, SGGLSE, SGGQRF, SGGRQF, SGGSVD, SGGSVP,
$ SHGEQZ, STGEVC, STGEXC, STGSEN, STGSJA, STGSNA,
$ STGSYL
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
C2 = PATH( 2: 3 )
*
* Set the variables to innocuous values.
*
DO 20 J = 1, NMAX
SEL( J ) = .TRUE.
DO 10 I = 1, NMAX
A( I, J ) = ZERO
B( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
DO 30 I = 1, NMAX
A( I, I ) = ONE
B( I, I ) = ONE
30 CONTINUE
OK = .TRUE.
TOLA = 1.0E0
TOLB = 1.0E0
IFST = 1
ILST = 1
NT = 0
*
* Test error exits for the GG path.
*
IF( LSAMEN( 2, C2, 'GG' ) ) THEN
*
* SGGHRD
*
SRNAMT = 'SGGHRD'
INFOT = 1
CALL SGGHRD( '/', 'N', 0, 1, 0, A, 1, B, 1, Q, 1, Z, 1, INFO )
CALL CHKXER( 'SGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGGHRD( 'N', '/', 0, 1, 0, A, 1, B, 1, Q, 1, Z, 1, INFO )
CALL CHKXER( 'SGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGGHRD( 'N', 'N', -1, 0, 0, A, 1, B, 1, Q, 1, Z, 1, INFO )
CALL CHKXER( 'SGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGGHRD( 'N', 'N', 0, 0, 0, A, 1, B, 1, Q, 1, Z, 1, INFO )
CALL CHKXER( 'SGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGGHRD( 'N', 'N', 0, 1, 1, A, 1, B, 1, Q, 1, Z, 1, INFO )
CALL CHKXER( 'SGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SGGHRD( 'N', 'N', 2, 1, 1, A, 1, B, 2, Q, 1, Z, 1, INFO )
CALL CHKXER( 'SGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SGGHRD( 'N', 'N', 2, 1, 1, A, 2, B, 1, Q, 1, Z, 1, INFO )
CALL CHKXER( 'SGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL SGGHRD( 'V', 'N', 2, 1, 1, A, 2, B, 2, Q, 1, Z, 1, INFO )
CALL CHKXER( 'SGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL SGGHRD( 'N', 'V', 2, 1, 1, A, 2, B, 2, Q, 1, Z, 1, INFO )
CALL CHKXER( 'SGGHRD', INFOT, NOUT, LERR, OK )
NT = NT + 9
*
* SHGEQZ
*
SRNAMT = 'SHGEQZ'
INFOT = 1
CALL SHGEQZ( '/', 'N', 'N', 0, 1, 0, A, 1, B, 1, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'SHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SHGEQZ( 'E', '/', 'N', 0, 1, 0, A, 1, B, 1, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'SHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SHGEQZ( 'E', 'N', '/', 0, 1, 0, A, 1, B, 1, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'SHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SHGEQZ( 'E', 'N', 'N', -1, 0, 0, A, 1, B, 1, R1, R2, R3,
$ Q, 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'SHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SHGEQZ( 'E', 'N', 'N', 0, 0, 0, A, 1, B, 1, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'SHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SHGEQZ( 'E', 'N', 'N', 0, 1, 1, A, 1, B, 1, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'SHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SHGEQZ( 'E', 'N', 'N', 2, 1, 1, A, 1, B, 2, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'SHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SHGEQZ( 'E', 'N', 'N', 2, 1, 1, A, 2, B, 1, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'SHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 15
CALL SHGEQZ( 'E', 'V', 'N', 2, 1, 1, A, 2, B, 2, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'SHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 17
CALL SHGEQZ( 'E', 'N', 'V', 2, 1, 1, A, 2, B, 2, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'SHGEQZ', INFOT, NOUT, LERR, OK )
NT = NT + 10
*
* STGEVC
*
SRNAMT = 'STGEVC'
INFOT = 1
CALL STGEVC( '/', 'A', SEL, 0, A, 1, B, 1, Q, 1, Z, 1, 0, M, W,
$ INFO )
CALL CHKXER( 'STGEVC', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STGEVC( 'R', '/', SEL, 0, A, 1, B, 1, Q, 1, Z, 1, 0, M, W,
$ INFO )
CALL CHKXER( 'STGEVC', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL STGEVC( 'R', 'A', SEL, -1, A, 1, B, 1, Q, 1, Z, 1, 0, M,
$ W, INFO )
CALL CHKXER( 'STGEVC', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL STGEVC( 'R', 'A', SEL, 2, A, 1, B, 2, Q, 1, Z, 2, 0, M, W,
$ INFO )
CALL CHKXER( 'STGEVC', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL STGEVC( 'R', 'A', SEL, 2, A, 2, B, 1, Q, 1, Z, 2, 0, M, W,
$ INFO )
CALL CHKXER( 'STGEVC', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL STGEVC( 'L', 'A', SEL, 2, A, 2, B, 2, Q, 1, Z, 1, 0, M, W,
$ INFO )
CALL CHKXER( 'STGEVC', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL STGEVC( 'R', 'A', SEL, 2, A, 2, B, 2, Q, 1, Z, 1, 0, M, W,
$ INFO )
CALL CHKXER( 'STGEVC', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL STGEVC( 'R', 'A', SEL, 2, A, 2, B, 2, Q, 1, Z, 2, 1, M, W,
$ INFO )
CALL CHKXER( 'STGEVC', INFOT, NOUT, LERR, OK )
NT = NT + 8
*
* Test error exits for the GSV path.
*
ELSE IF( LSAMEN( 3, PATH, 'GSV' ) ) THEN
*
* SGGSVD
*
SRNAMT = 'SGGSVD'
INFOT = 1
CALL SGGSVD( '/', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'SGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGGSVD( 'N', '/', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'SGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGGSVD( 'N', 'N', '/', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'SGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGGSVD( 'N', 'N', 'N', -1, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'SGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGGSVD( 'N', 'N', 'N', 0, -1, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'SGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SGGSVD( 'N', 'N', 'N', 0, 0, -1, DUMMYK, DUMMYL, A, 1, B,
$ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'SGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SGGSVD( 'N', 'N', 'N', 2, 1, 1, DUMMYK, DUMMYL, A, 1, B,
$ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'SGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SGGSVD( 'N', 'N', 'N', 1, 1, 2, DUMMYK, DUMMYL, A, 1, B,
$ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'SGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL SGGSVD( 'U', 'N', 'N', 2, 2, 2, DUMMYK, DUMMYL, A, 2, B,
$ 2, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'SGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 18
CALL SGGSVD( 'N', 'V', 'N', 1, 1, 2, DUMMYK, DUMMYL, A, 1, B,
$ 2, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'SGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 20
CALL SGGSVD( 'N', 'N', 'Q', 1, 2, 1, DUMMYK, DUMMYL, A, 1, B,
$ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'SGGSVD', INFOT, NOUT, LERR, OK )
NT = NT + 11
*
* SGGSVP
*
SRNAMT = 'SGGSVP'
INFOT = 1
CALL SGGSVP( '/', 'N', 'N', 0, 0, 0, A, 1, B, 1, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'SGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGGSVP( 'N', '/', 'N', 0, 0, 0, A, 1, B, 1, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'SGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGGSVP( 'N', 'N', '/', 0, 0, 0, A, 1, B, 1, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'SGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGGSVP( 'N', 'N', 'N', -1, 0, 0, A, 1, B, 1, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'SGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGGSVP( 'N', 'N', 'N', 0, -1, 0, A, 1, B, 1, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'SGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SGGSVP( 'N', 'N', 'N', 0, 0, -1, A, 1, B, 1, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'SGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SGGSVP( 'N', 'N', 'N', 2, 1, 1, A, 1, B, 1, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'SGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SGGSVP( 'N', 'N', 'N', 1, 2, 1, A, 1, B, 1, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'SGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL SGGSVP( 'U', 'N', 'N', 2, 2, 2, A, 2, B, 2, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'SGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 18
CALL SGGSVP( 'N', 'V', 'N', 1, 2, 1, A, 1, B, 2, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'SGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 20
CALL SGGSVP( 'N', 'N', 'Q', 1, 1, 2, A, 1, B, 1, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'SGGSVP', INFOT, NOUT, LERR, OK )
NT = NT + 11
*
* STGSJA
*
SRNAMT = 'STGSJA'
INFOT = 1
CALL STGSJA( '/', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, TOLA, TOLB, R1, R2, U, 1, V, 1, Q, 1, W,
$ NCYCLE, INFO )
CALL CHKXER( 'STGSJA', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STGSJA( 'N', '/', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, TOLA, TOLB, R1, R2, U, 1, V, 1, Q, 1, W,
$ NCYCLE, INFO )
CALL CHKXER( 'STGSJA', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL STGSJA( 'N', 'N', '/', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, TOLA, TOLB, R1, R2, U, 1, V, 1, Q, 1, W,
$ NCYCLE, INFO )
CALL CHKXER( 'STGSJA', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL STGSJA( 'N', 'N', 'N', -1, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, TOLA, TOLB, R1, R2, U, 1, V, 1, Q, 1, W,
$ NCYCLE, INFO )
CALL CHKXER( 'STGSJA', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STGSJA( 'N', 'N', 'N', 0, -1, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, TOLA, TOLB, R1, R2, U, 1, V, 1, Q, 1, W,
$ NCYCLE, INFO )
CALL CHKXER( 'STGSJA', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL STGSJA( 'N', 'N', 'N', 0, 0, -1, DUMMYK, DUMMYL, A, 1, B,
$ 1, TOLA, TOLB, R1, R2, U, 1, V, 1, Q, 1, W,
$ NCYCLE, INFO )
CALL CHKXER( 'STGSJA', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL STGSJA( 'N', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 0, B,
$ 1, TOLA, TOLB, R1, R2, U, 1, V, 1, Q, 1, W,
$ NCYCLE, INFO )
CALL CHKXER( 'STGSJA', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL STGSJA( 'N', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 0, TOLA, TOLB, R1, R2, U, 1, V, 1, Q, 1, W,
$ NCYCLE, INFO )
CALL CHKXER( 'STGSJA', INFOT, NOUT, LERR, OK )
INFOT = 18
CALL STGSJA( 'U', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, TOLA, TOLB, R1, R2, U, 0, V, 1, Q, 1, W,
$ NCYCLE, INFO )
CALL CHKXER( 'STGSJA', INFOT, NOUT, LERR, OK )
INFOT = 20
CALL STGSJA( 'N', 'V', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, TOLA, TOLB, R1, R2, U, 1, V, 0, Q, 1, W,
$ NCYCLE, INFO )
CALL CHKXER( 'STGSJA', INFOT, NOUT, LERR, OK )
INFOT = 22
CALL STGSJA( 'N', 'N', 'Q', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, TOLA, TOLB, R1, R2, U, 1, V, 1, Q, 0, W,
$ NCYCLE, INFO )
CALL CHKXER( 'STGSJA', INFOT, NOUT, LERR, OK )
NT = NT + 11
*
* Test error exits for the GLM path.
*
ELSE IF( LSAMEN( 3, PATH, 'GLM' ) ) THEN
*
* SGGGLM
*
SRNAMT = 'SGGGLM'
INFOT = 1
CALL SGGGLM( -1, 0, 0, A, 1, B, 1, R1, R2, R3, W, LW, INFO )
CALL CHKXER( 'SGGGLM', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGGGLM( 0, -1, 0, A, 1, B, 1, R1, R2, R3, W, LW, INFO )
CALL CHKXER( 'SGGGLM', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGGGLM( 0, 1, 0, A, 1, B, 1, R1, R2, R3, W, LW, INFO )
CALL CHKXER( 'SGGGLM', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGGGLM( 0, 0, -1, A, 1, B, 1, R1, R2, R3, W, LW, INFO )
CALL CHKXER( 'SGGGLM', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGGGLM( 1, 0, 0, A, 1, B, 1, R1, R2, R3, W, LW, INFO )
CALL CHKXER( 'SGGGLM', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGGGLM( 0, 0, 0, A, 0, B, 1, R1, R2, R3, W, LW, INFO )
CALL CHKXER( 'SGGGLM', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SGGGLM( 0, 0, 0, A, 1, B, 0, R1, R2, R3, W, LW, INFO )
CALL CHKXER( 'SGGGLM', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SGGGLM( 1, 1, 1, A, 1, B, 1, R1, R2, R3, W, 1, INFO )
CALL CHKXER( 'SGGGLM', INFOT, NOUT, LERR, OK )
NT = NT + 8
*
* Test error exits for the LSE path.
*
ELSE IF( LSAMEN( 3, PATH, 'LSE' ) ) THEN
*
* SGGLSE
*
SRNAMT = 'SGGLSE'
INFOT = 1
CALL SGGLSE( -1, 0, 0, A, 1, B, 1, R1, R2, R3, W, LW, INFO )
CALL CHKXER( 'SGGLSE', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGGLSE( 0, -1, 0, A, 1, B, 1, R1, R2, R3, W, LW, INFO )
CALL CHKXER( 'SGGLSE', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGGLSE( 0, 0, -1, A, 1, B, 1, R1, R2, R3, W, LW, INFO )
CALL CHKXER( 'SGGLSE', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGGLSE( 0, 0, 1, A, 1, B, 1, R1, R2, R3, W, LW, INFO )
CALL CHKXER( 'SGGLSE', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGGLSE( 0, 1, 0, A, 1, B, 1, R1, R2, R3, W, LW, INFO )
CALL CHKXER( 'SGGLSE', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGGLSE( 0, 0, 0, A, 0, B, 1, R1, R2, R3, W, LW, INFO )
CALL CHKXER( 'SGGLSE', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SGGLSE( 0, 0, 0, A, 1, B, 0, R1, R2, R3, W, LW, INFO )
CALL CHKXER( 'SGGLSE', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SGGLSE( 1, 1, 1, A, 1, B, 1, R1, R2, R3, W, 1, INFO )
CALL CHKXER( 'SGGLSE', INFOT, NOUT, LERR, OK )
NT = NT + 8
*
* Test error exits for the GQR path.
*
ELSE IF( LSAMEN( 3, PATH, 'GQR' ) ) THEN
*
* SGGQRF
*
SRNAMT = 'SGGQRF'
INFOT = 1
CALL SGGQRF( -1, 0, 0, A, 1, R1, B, 1, R2, W, LW, INFO )
CALL CHKXER( 'SGGQRF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGGQRF( 0, -1, 0, A, 1, R1, B, 1, R2, W, LW, INFO )
CALL CHKXER( 'SGGQRF', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGGQRF( 0, 0, -1, A, 1, R1, B, 1, R2, W, LW, INFO )
CALL CHKXER( 'SGGQRF', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGGQRF( 0, 0, 0, A, 0, R1, B, 1, R2, W, LW, INFO )
CALL CHKXER( 'SGGQRF', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SGGQRF( 0, 0, 0, A, 1, R1, B, 0, R2, W, LW, INFO )
CALL CHKXER( 'SGGQRF', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL SGGQRF( 1, 1, 2, A, 1, R1, B, 1, R2, W, 1, INFO )
CALL CHKXER( 'SGGQRF', INFOT, NOUT, LERR, OK )
NT = NT + 6
*
* SGGRQF
*
SRNAMT = 'SGGRQF'
INFOT = 1
CALL SGGRQF( -1, 0, 0, A, 1, R1, B, 1, R2, W, LW, INFO )
CALL CHKXER( 'SGGRQF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGGRQF( 0, -1, 0, A, 1, R1, B, 1, R2, W, LW, INFO )
CALL CHKXER( 'SGGRQF', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGGRQF( 0, 0, -1, A, 1, R1, B, 1, R2, W, LW, INFO )
CALL CHKXER( 'SGGRQF', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGGRQF( 0, 0, 0, A, 0, R1, B, 1, R2, W, LW, INFO )
CALL CHKXER( 'SGGRQF', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SGGRQF( 0, 0, 0, A, 1, R1, B, 0, R2, W, LW, INFO )
CALL CHKXER( 'SGGRQF', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL SGGRQF( 1, 1, 2, A, 1, R1, B, 1, R2, W, 1, INFO )
CALL CHKXER( 'SGGRQF', INFOT, NOUT, LERR, OK )
NT = NT + 6
*
* Test error exits for the SGS, SGV, SGX, and SXV paths.
*
ELSE IF( LSAMEN( 3, PATH, 'SGS' ) .OR.
$ LSAMEN( 3, PATH, 'SGV' ) .OR.
$ LSAMEN( 3, PATH, 'SGX' ) .OR. LSAMEN( 3, PATH, 'SXV' ) )
$ THEN
*
* SGGES
*
SRNAMT = 'SGGES '
INFOT = 1
CALL SGGES( '/', 'N', 'S', SLCTES, 1, A, 1, B, 1, SDIM, R1, R2,
$ R3, Q, 1, U, 1, W, 1, BW, INFO )
CALL CHKXER( 'SGGES ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGGES( 'N', '/', 'S', SLCTES, 1, A, 1, B, 1, SDIM, R1, R2,
$ R3, Q, 1, U, 1, W, 1, BW, INFO )
CALL CHKXER( 'SGGES ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGGES( 'N', 'V', '/', SLCTES, 1, A, 1, B, 1, SDIM, R1, R2,
$ R3, Q, 1, U, 1, W, 1, BW, INFO )
CALL CHKXER( 'SGGES ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGGES( 'N', 'V', 'S', SLCTES, -1, A, 1, B, 1, SDIM, R1,
$ R2, R3, Q, 1, U, 1, W, 1, BW, INFO )
CALL CHKXER( 'SGGES ', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SGGES( 'N', 'V', 'S', SLCTES, 1, A, 0, B, 1, SDIM, R1, R2,
$ R3, Q, 1, U, 1, W, 1, BW, INFO )
CALL CHKXER( 'SGGES ', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SGGES( 'N', 'V', 'S', SLCTES, 1, A, 1, B, 0, SDIM, R1, R2,
$ R3, Q, 1, U, 1, W, 1, BW, INFO )
CALL CHKXER( 'SGGES ', INFOT, NOUT, LERR, OK )
INFOT = 15
CALL SGGES( 'N', 'V', 'S', SLCTES, 1, A, 1, B, 1, SDIM, R1, R2,
$ R3, Q, 0, U, 1, W, 1, BW, INFO )
CALL CHKXER( 'SGGES ', INFOT, NOUT, LERR, OK )
INFOT = 15
CALL SGGES( 'V', 'V', 'S', SLCTES, 2, A, 2, B, 2, SDIM, R1, R2,
$ R3, Q, 1, U, 2, W, 1, BW, INFO )
CALL CHKXER( 'SGGES ', INFOT, NOUT, LERR, OK )
INFOT = 17
CALL SGGES( 'N', 'V', 'S', SLCTES, 1, A, 1, B, 1, SDIM, R1, R2,
$ R3, Q, 1, U, 0, W, 1, BW, INFO )
CALL CHKXER( 'SGGES ', INFOT, NOUT, LERR, OK )
INFOT = 17
CALL SGGES( 'V', 'V', 'S', SLCTES, 2, A, 2, B, 2, SDIM, R1, R2,
$ R3, Q, 2, U, 1, W, 1, BW, INFO )
CALL CHKXER( 'SGGES ', INFOT, NOUT, LERR, OK )
INFOT = 19
CALL SGGES( 'V', 'V', 'S', SLCTES, 2, A, 2, B, 2, SDIM, R1, R2,
$ R3, Q, 2, U, 2, W, 1, BW, INFO )
CALL CHKXER( 'SGGES ', INFOT, NOUT, LERR, OK )
NT = NT + 11
*
* SGGESX
*
SRNAMT = 'SGGESX'
INFOT = 1
CALL SGGESX( '/', 'N', 'S', SLCTSX, 'N', 1, A, 1, B, 1, SDIM,
$ R1, R2, R3, Q, 1, U, 1, RCE, RCV, W, 1, IW, 1, BW,
$ INFO )
CALL CHKXER( 'SGGESX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGGESX( 'N', '/', 'S', SLCTSX, 'N', 1, A, 1, B, 1, SDIM,
$ R1, R2, R3, Q, 1, U, 1, RCE, RCV, W, 1, IW, 1, BW,
$ INFO )
CALL CHKXER( 'SGGESX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGGESX( 'V', 'V', '/', SLCTSX, 'N', 1, A, 1, B, 1, SDIM,
$ R1, R2, R3, Q, 1, U, 1, RCE, RCV, W, 1, IW, 1, BW,
$ INFO )
CALL CHKXER( 'SGGESX', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGGESX( 'V', 'V', 'S', SLCTSX, '/', 1, A, 1, B, 1, SDIM,
$ R1, R2, R3, Q, 1, U, 1, RCE, RCV, W, 1, IW, 1, BW,
$ INFO )
CALL CHKXER( 'SGGESX', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SGGESX( 'V', 'V', 'S', SLCTSX, 'B', -1, A, 1, B, 1, SDIM,
$ R1, R2, R3, Q, 1, U, 1, RCE, RCV, W, 1, IW, 1, BW,
$ INFO )
CALL CHKXER( 'SGGESX', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SGGESX( 'V', 'V', 'S', SLCTSX, 'B', 1, A, 0, B, 1, SDIM,
$ R1, R2, R3, Q, 1, U, 1, RCE, RCV, W, 1, IW, 1, BW,
$ INFO )
CALL CHKXER( 'SGGESX', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SGGESX( 'V', 'V', 'S', SLCTSX, 'B', 1, A, 1, B, 0, SDIM,
$ R1, R2, R3, Q, 1, U, 1, RCE, RCV, W, 1, IW, 1, BW,
$ INFO )
CALL CHKXER( 'SGGESX', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL SGGESX( 'V', 'V', 'S', SLCTSX, 'B', 1, A, 1, B, 1, SDIM,
$ R1, R2, R3, Q, 0, U, 1, RCE, RCV, W, 1, IW, 1, BW,
$ INFO )
CALL CHKXER( 'SGGESX', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL SGGESX( 'V', 'V', 'S', SLCTSX, 'B', 2, A, 2, B, 2, SDIM,
$ R1, R2, R3, Q, 1, U, 1, RCE, RCV, W, 1, IW, 1, BW,
$ INFO )
CALL CHKXER( 'SGGESX', INFOT, NOUT, LERR, OK )
INFOT = 18
CALL SGGESX( 'V', 'V', 'S', SLCTSX, 'B', 1, A, 1, B, 1, SDIM,
$ R1, R2, R3, Q, 1, U, 0, RCE, RCV, W, 1, IW, 1, BW,
$ INFO )
CALL CHKXER( 'SGGESX', INFOT, NOUT, LERR, OK )
INFOT = 18
CALL SGGESX( 'V', 'V', 'S', SLCTSX, 'B', 2, A, 2, B, 2, SDIM,
$ R1, R2, R3, Q, 2, U, 1, RCE, RCV, W, 1, IW, 1, BW,
$ INFO )
CALL CHKXER( 'SGGESX', INFOT, NOUT, LERR, OK )
INFOT = 22
CALL SGGESX( 'V', 'V', 'S', SLCTSX, 'B', 2, A, 2, B, 2, SDIM,
$ R1, R2, R3, Q, 2, U, 2, RCE, RCV, W, 1, IW, 1, BW,
$ INFO )
CALL CHKXER( 'SGGESX', INFOT, NOUT, LERR, OK )
INFOT = 24
CALL SGGESX( 'V', 'V', 'S', SLCTSX, 'V', 1, A, 1, B, 1, SDIM,
$ R1, R2, R3, Q, 1, U, 1, RCE, RCV, W, 32, IW, 0,
$ BW, INFO )
CALL CHKXER( 'SGGESX', INFOT, NOUT, LERR, OK )
NT = NT + 13
*
* SGGEV
*
SRNAMT = 'SGGEV '
INFOT = 1
CALL SGGEV( '/', 'N', 1, A, 1, B, 1, R1, R2, R3, Q, 1, U, 1, W,
$ 1, INFO )
CALL CHKXER( 'SGGEV ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGGEV( 'N', '/', 1, A, 1, B, 1, R1, R2, R3, Q, 1, U, 1, W,
$ 1, INFO )
CALL CHKXER( 'SGGEV ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGGEV( 'V', 'V', -1, A, 1, B, 1, R1, R2, R3, Q, 1, U, 1,
$ W, 1, INFO )
CALL CHKXER( 'SGGEV ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGGEV( 'V', 'V', 1, A, 0, B, 1, R1, R2, R3, Q, 1, U, 1, W,
$ 1, INFO )
CALL CHKXER( 'SGGEV ', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SGGEV( 'V', 'V', 1, A, 1, B, 0, R1, R2, R3, Q, 1, U, 1, W,
$ 1, INFO )
CALL CHKXER( 'SGGEV ', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SGGEV( 'N', 'V', 1, A, 1, B, 1, R1, R2, R3, Q, 0, U, 1, W,
$ 1, INFO )
CALL CHKXER( 'SGGEV ', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SGGEV( 'V', 'V', 2, A, 2, B, 2, R1, R2, R3, Q, 1, U, 2, W,
$ 1, INFO )
CALL CHKXER( 'SGGEV ', INFOT, NOUT, LERR, OK )
INFOT = 14
CALL SGGEV( 'V', 'N', 2, A, 2, B, 2, R1, R2, R3, Q, 2, U, 0, W,
$ 1, INFO )
CALL CHKXER( 'SGGEV ', INFOT, NOUT, LERR, OK )
INFOT = 14
CALL SGGEV( 'V', 'V', 2, A, 2, B, 2, R1, R2, R3, Q, 2, U, 1, W,
$ 1, INFO )
CALL CHKXER( 'SGGEV ', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL SGGEV( 'V', 'V', 1, A, 1, B, 1, R1, R2, R3, Q, 1, U, 1, W,
$ 1, INFO )
CALL CHKXER( 'SGGEV ', INFOT, NOUT, LERR, OK )
NT = NT + 10
*
* SGGEVX
*
SRNAMT = 'SGGEVX'
INFOT = 1
CALL SGGEVX( '/', 'N', 'N', 'N', 1, A, 1, B, 1, R1, R2, R3, Q,
$ 1, U, 1, 1, 1, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
$ IW, BW, INFO )
CALL CHKXER( 'SGGEVX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGGEVX( 'N', '/', 'N', 'N', 1, A, 1, B, 1, R1, R2, R3, Q,
$ 1, U, 1, 1, 1, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
$ IW, BW, INFO )
CALL CHKXER( 'SGGEVX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGGEVX( 'N', 'N', '/', 'N', 1, A, 1, B, 1, R1, R2, R3, Q,
$ 1, U, 1, 1, 1, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
$ IW, BW, INFO )
CALL CHKXER( 'SGGEVX', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGGEVX( 'N', 'N', 'N', '/', 1, A, 1, B, 1, R1, R2, R3, Q,
$ 1, U, 1, 1, 1, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
$ IW, BW, INFO )
CALL CHKXER( 'SGGEVX', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGGEVX( 'N', 'N', 'N', 'N', -1, A, 1, B, 1, R1, R2, R3, Q,
$ 1, U, 1, 1, 1, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
$ IW, BW, INFO )
CALL CHKXER( 'SGGEVX', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SGGEVX( 'N', 'N', 'N', 'N', 1, A, 0, B, 1, R1, R2, R3, Q,
$ 1, U, 1, 1, 1, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
$ IW, BW, INFO )
CALL CHKXER( 'SGGEVX', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SGGEVX( 'N', 'N', 'N', 'N', 1, A, 1, B, 0, R1, R2, R3, Q,
$ 1, U, 1, 1, 1, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
$ IW, BW, INFO )
CALL CHKXER( 'SGGEVX', INFOT, NOUT, LERR, OK )
INFOT = 14
CALL SGGEVX( 'N', 'N', 'N', 'N', 1, A, 1, B, 1, R1, R2, R3, Q,
$ 0, U, 1, 1, 1, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
$ IW, BW, INFO )
CALL CHKXER( 'SGGEVX', INFOT, NOUT, LERR, OK )
INFOT = 14
CALL SGGEVX( 'N', 'V', 'N', 'N', 2, A, 2, B, 2, R1, R2, R3, Q,
$ 1, U, 2, 1, 2, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
$ IW, BW, INFO )
CALL CHKXER( 'SGGEVX', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL SGGEVX( 'N', 'N', 'N', 'N', 1, A, 1, B, 1, R1, R2, R3, Q,
$ 1, U, 0, 1, 1, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
$ IW, BW, INFO )
CALL CHKXER( 'SGGEVX', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL SGGEVX( 'N', 'N', 'V', 'N', 2, A, 2, B, 2, R1, R2, R3, Q,
$ 2, U, 1, 1, 2, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
$ IW, BW, INFO )
CALL CHKXER( 'SGGEVX', INFOT, NOUT, LERR, OK )
INFOT = 26
CALL SGGEVX( 'N', 'N', 'V', 'N', 2, A, 2, B, 2, R1, R2, R3, Q,
$ 2, U, 2, 1, 2, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
$ IW, BW, INFO )
CALL CHKXER( 'SGGEVX', INFOT, NOUT, LERR, OK )
NT = NT + 12
*
* STGEXC
*
SRNAMT = 'STGEXC'
INFOT = 3
CALL STGEXC( .TRUE., .TRUE., -1, A, 1, B, 1, Q, 1, Z, 1, IFST,
$ ILST, W, 1, INFO )
CALL CHKXER( 'STGEXC', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STGEXC( .TRUE., .TRUE., 1, A, 0, B, 1, Q, 1, Z, 1, IFST,
$ ILST, W, 1, INFO )
CALL CHKXER( 'STGEXC', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL STGEXC( .TRUE., .TRUE., 1, A, 1, B, 0, Q, 1, Z, 1, IFST,
$ ILST, W, 1, INFO )
CALL CHKXER( 'STGEXC', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL STGEXC( .FALSE., .TRUE., 1, A, 1, B, 1, Q, 0, Z, 1, IFST,
$ ILST, W, 1, INFO )
CALL CHKXER( 'STGEXC', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL STGEXC( .TRUE., .TRUE., 1, A, 1, B, 1, Q, 0, Z, 1, IFST,
$ ILST, W, 1, INFO )
CALL CHKXER( 'STGEXC', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL STGEXC( .TRUE., .FALSE., 1, A, 1, B, 1, Q, 1, Z, 0, IFST,
$ ILST, W, 1, INFO )
CALL CHKXER( 'STGEXC', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL STGEXC( .TRUE., .TRUE., 1, A, 1, B, 1, Q, 1, Z, 0, IFST,
$ ILST, W, 1, INFO )
CALL CHKXER( 'STGEXC', INFOT, NOUT, LERR, OK )
INFOT = 15
CALL STGEXC( .TRUE., .TRUE., 1, A, 1, B, 1, Q, 1, Z, 1, IFST,
$ ILST, W, 0, INFO )
CALL CHKXER( 'STGEXC', INFOT, NOUT, LERR, OK )
NT = NT + 8
*
* STGSEN
*
SRNAMT = 'STGSEN'
INFOT = 1
CALL STGSEN( -1, .TRUE., .TRUE., SEL, 1, A, 1, B, 1, R1, R2,
$ R3, Q, 1, Z, 1, M, TOLA, TOLB, RCV, W, 1, IW, 1,
$ INFO )
CALL CHKXER( 'STGSEN', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STGSEN( 1, .TRUE., .TRUE., SEL, -1, A, 1, B, 1, R1, R2,
$ R3, Q, 1, Z, 1, M, TOLA, TOLB, RCV, W, 1, IW, 1,
$ INFO )
CALL CHKXER( 'STGSEN', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL STGSEN( 1, .TRUE., .TRUE., SEL, 1, A, 0, B, 1, R1, R2, R3,
$ Q, 1, Z, 1, M, TOLA, TOLB, RCV, W, 1, IW, 1,
$ INFO )
CALL CHKXER( 'STGSEN', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL STGSEN( 1, .TRUE., .TRUE., SEL, 1, A, 1, B, 0, R1, R2, R3,
$ Q, 1, Z, 1, M, TOLA, TOLB, RCV, W, 1, IW, 1,
$ INFO )
CALL CHKXER( 'STGSEN', INFOT, NOUT, LERR, OK )
INFOT = 14
CALL STGSEN( 1, .TRUE., .TRUE., SEL, 1, A, 1, B, 1, R1, R2, R3,
$ Q, 0, Z, 1, M, TOLA, TOLB, RCV, W, 1, IW, 1,
$ INFO )
CALL CHKXER( 'STGSEN', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL STGSEN( 1, .TRUE., .TRUE., SEL, 1, A, 1, B, 1, R1, R2, R3,
$ Q, 1, Z, 0, M, TOLA, TOLB, RCV, W, 1, IW, 1,
$ INFO )
CALL CHKXER( 'STGSEN', INFOT, NOUT, LERR, OK )
INFOT = 22
CALL STGSEN( 0, .TRUE., .TRUE., SEL, 1, A, 1, B, 1, R1, R2, R3,
$ Q, 1, Z, 1, M, TOLA, TOLB, RCV, W, 1, IW, 1,
$ INFO )
CALL CHKXER( 'STGSEN', INFOT, NOUT, LERR, OK )
INFOT = 22
CALL STGSEN( 1, .TRUE., .TRUE., SEL, 1, A, 1, B, 1, R1, R2, R3,
$ Q, 1, Z, 1, M, TOLA, TOLB, RCV, W, 1, IW, 1,
$ INFO )
CALL CHKXER( 'STGSEN', INFOT, NOUT, LERR, OK )
INFOT = 22
CALL STGSEN( 2, .TRUE., .TRUE., SEL, 1, A, 1, B, 1, R1, R2, R3,
$ Q, 1, Z, 1, M, TOLA, TOLB, RCV, W, 1, IW, 1,
$ INFO )
CALL CHKXER( 'STGSEN', INFOT, NOUT, LERR, OK )
INFOT = 24
CALL STGSEN( 0, .TRUE., .TRUE., SEL, 1, A, 1, B, 1, R1, R2, R3,
$ Q, 1, Z, 1, M, TOLA, TOLB, RCV, W, 20, IW, 0,
$ INFO )
CALL CHKXER( 'STGSEN', INFOT, NOUT, LERR, OK )
INFOT = 24
CALL STGSEN( 1, .TRUE., .TRUE., SEL, 1, A, 1, B, 1, R1, R2, R3,
$ Q, 1, Z, 1, M, TOLA, TOLB, RCV, W, 20, IW, 0,
$ INFO )
CALL CHKXER( 'STGSEN', INFOT, NOUT, LERR, OK )
INFOT = 24
CALL STGSEN( 2, .TRUE., .TRUE., SEL, 1, A, 1, B, 1, R1, R2, R3,
$ Q, 1, Z, 1, M, TOLA, TOLB, RCV, W, 20, IW, 1,
$ INFO )
CALL CHKXER( 'STGSEN', INFOT, NOUT, LERR, OK )
NT = NT + 12
*
* STGSNA
*
SRNAMT = 'STGSNA'
INFOT = 1
CALL STGSNA( '/', 'A', SEL, 1, A, 1, B, 1, Q, 1, U, 1, R1, R2,
$ 1, M, W, 1, IW, INFO )
CALL CHKXER( 'STGSNA', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STGSNA( 'B', '/', SEL, 1, A, 1, B, 1, Q, 1, U, 1, R1, R2,
$ 1, M, W, 1, IW, INFO )
CALL CHKXER( 'STGSNA', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL STGSNA( 'B', 'A', SEL, -1, A, 1, B, 1, Q, 1, U, 1, R1, R2,
$ 1, M, W, 1, IW, INFO )
CALL CHKXER( 'STGSNA', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL STGSNA( 'B', 'A', SEL, 1, A, 0, B, 1, Q, 1, U, 1, R1, R2,
$ 1, M, W, 1, IW, INFO )
CALL CHKXER( 'STGSNA', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL STGSNA( 'B', 'A', SEL, 1, A, 1, B, 0, Q, 1, U, 1, R1, R2,
$ 1, M, W, 1, IW, INFO )
CALL CHKXER( 'STGSNA', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL STGSNA( 'E', 'A', SEL, 1, A, 1, B, 1, Q, 0, U, 1, R1, R2,
$ 1, M, W, 1, IW, INFO )
CALL CHKXER( 'STGSNA', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL STGSNA( 'E', 'A', SEL, 1, A, 1, B, 1, Q, 1, U, 0, R1, R2,
$ 1, M, W, 1, IW, INFO )
CALL CHKXER( 'STGSNA', INFOT, NOUT, LERR, OK )
INFOT = 15
CALL STGSNA( 'E', 'A', SEL, 1, A, 1, B, 1, Q, 1, U, 1, R1, R2,
$ 0, M, W, 1, IW, INFO )
CALL CHKXER( 'STGSNA', INFOT, NOUT, LERR, OK )
INFOT = 18
CALL STGSNA( 'E', 'A', SEL, 1, A, 1, B, 1, Q, 1, U, 1, R1, R2,
$ 1, M, W, 0, IW, INFO )
CALL CHKXER( 'STGSNA', INFOT, NOUT, LERR, OK )
NT = NT + 9
*
* STGSYL
*
SRNAMT = 'STGSYL'
INFOT = 1
CALL STGSYL( '/', 0, 1, 1, A, 1, B, 1, Q, 1, U, 1, V, 1, Z, 1,
$ SCALE, DIF, W, 1, IW, INFO )
CALL CHKXER( 'STGSYL', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STGSYL( 'N', -1, 1, 1, A, 1, B, 1, Q, 1, U, 1, V, 1, Z, 1,
$ SCALE, DIF, W, 1, IW, INFO )
CALL CHKXER( 'STGSYL', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL STGSYL( 'N', 0, 0, 1, A, 1, B, 1, Q, 1, U, 1, V, 1, Z, 1,
$ SCALE, DIF, W, 1, IW, INFO )
CALL CHKXER( 'STGSYL', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL STGSYL( 'N', 0, 1, 0, A, 1, B, 1, Q, 1, U, 1, V, 1, Z, 1,
$ SCALE, DIF, W, 1, IW, INFO )
CALL CHKXER( 'STGSYL', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL STGSYL( 'N', 0, 1, 1, A, 0, B, 1, Q, 1, U, 1, V, 1, Z, 1,
$ SCALE, DIF, W, 1, IW, INFO )
CALL CHKXER( 'STGSYL', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL STGSYL( 'N', 0, 1, 1, A, 1, B, 0, Q, 1, U, 1, V, 1, Z, 1,
$ SCALE, DIF, W, 1, IW, INFO )
CALL CHKXER( 'STGSYL', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL STGSYL( 'N', 0, 1, 1, A, 1, B, 1, Q, 0, U, 1, V, 1, Z, 1,
$ SCALE, DIF, W, 1, IW, INFO )
CALL CHKXER( 'STGSYL', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL STGSYL( 'N', 0, 1, 1, A, 1, B, 1, Q, 1, U, 0, V, 1, Z, 1,
$ SCALE, DIF, W, 1, IW, INFO )
CALL CHKXER( 'STGSYL', INFOT, NOUT, LERR, OK )
INFOT = 14
CALL STGSYL( 'N', 0, 1, 1, A, 1, B, 1, Q, 1, U, 1, V, 0, Z, 1,
$ SCALE, DIF, W, 1, IW, INFO )
CALL CHKXER( 'STGSYL', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL STGSYL( 'N', 0, 1, 1, A, 1, B, 1, Q, 1, U, 1, V, 1, Z, 0,
$ SCALE, DIF, W, 1, IW, INFO )
CALL CHKXER( 'STGSYL', INFOT, NOUT, LERR, OK )
INFOT = 20
CALL STGSYL( 'N', 1, 1, 1, A, 1, B, 1, Q, 1, U, 1, V, 1, Z, 1,
$ SCALE, DIF, W, 1, IW, INFO )
CALL CHKXER( 'STGSYL', INFOT, NOUT, LERR, OK )
INFOT = 20
CALL STGSYL( 'N', 2, 1, 1, A, 1, B, 1, Q, 1, U, 1, V, 1, Z, 1,
$ SCALE, DIF, W, 1, IW, INFO )
CALL CHKXER( 'STGSYL', INFOT, NOUT, LERR, OK )
NT = NT + 12
END IF
*
* Print a summary line.
*
IF( OK ) THEN
WRITE( NOUT, FMT = 9999 )PATH, NT
ELSE
WRITE( NOUT, FMT = 9998 )PATH
END IF
*
9999 FORMAT( 1X, A3, ' routines passed the tests of the error exits (',
$ I3, ' tests done)' )
9998 FORMAT( ' *** ', A3, ' routines failed the tests of the error ',
$ 'exits ***' )
*
RETURN
*
* End of SERRGG
*
END
SUBROUTINE SERRHS( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* SERRHS tests the error exits for SGEBAK, SGEBAL, SGEHRD, SORGHR,
* SORMHR, SHSEQR, SHSEIN, and STREVC.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX, LW
PARAMETER ( NMAX = 3, LW = ( NMAX+2 )*( NMAX+2 )+NMAX )
* ..
* .. Local Scalars ..
CHARACTER*2 C2
INTEGER I, ILO, IHI, INFO, J, M, NT
* ..
* .. Local Arrays ..
LOGICAL SEL( NMAX )
INTEGER IFAILL( NMAX ), IFAILR( NMAX )
REAL A( NMAX, NMAX ), C( NMAX, NMAX ), TAU( NMAX ),
$ VL( NMAX, NMAX ), VR( NMAX, NMAX ), W( LW ),
$ WI( NMAX ), WR( NMAX ), S( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL CHKXER, SGEBAK, SGEBAL, SGEHRD, SHSEIN, SHSEQR,
$ SORGHR, SORMHR, STREVC
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
C2 = PATH( 2: 3 )
*
* Set the variables to innocuous values.
*
DO 20 J = 1, NMAX
DO 10 I = 1, NMAX
A( I, J ) = 1. / REAL( I+J )
10 CONTINUE
WI( J ) = REAL( J )
SEL( J ) = .TRUE.
20 CONTINUE
OK = .TRUE.
NT = 0
*
* Test error exits of the nonsymmetric eigenvalue routines.
*
IF( LSAMEN( 2, C2, 'HS' ) ) THEN
*
* SGEBAL
*
SRNAMT = 'SGEBAL'
INFOT = 1
CALL SGEBAL( '/', 0, A, 1, ILO, IHI, S, INFO )
CALL CHKXER( 'SGEBAL', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGEBAL( 'N', -1, A, 1, ILO, IHI, S, INFO )
CALL CHKXER( 'SGEBAL', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGEBAL( 'N', 2, A, 1, ILO, IHI, S, INFO )
CALL CHKXER( 'SGEBAL', INFOT, NOUT, LERR, OK )
NT = NT + 3
*
* SGEBAK
*
SRNAMT = 'SGEBAK'
INFOT = 1
CALL SGEBAK( '/', 'R', 0, 1, 0, S, 0, A, 1, INFO )
CALL CHKXER( 'SGEBAK', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGEBAK( 'N', '/', 0, 1, 0, S, 0, A, 1, INFO )
CALL CHKXER( 'SGEBAK', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGEBAK( 'N', 'R', -1, 1, 0, S, 0, A, 1, INFO )
CALL CHKXER( 'SGEBAK', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGEBAK( 'N', 'R', 0, 0, 0, S, 0, A, 1, INFO )
CALL CHKXER( 'SGEBAK', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGEBAK( 'N', 'R', 0, 2, 0, S, 0, A, 1, INFO )
CALL CHKXER( 'SGEBAK', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGEBAK( 'N', 'R', 2, 2, 1, S, 0, A, 2, INFO )
CALL CHKXER( 'SGEBAK', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGEBAK( 'N', 'R', 0, 1, 1, S, 0, A, 1, INFO )
CALL CHKXER( 'SGEBAK', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SGEBAK( 'N', 'R', 0, 1, 0, S, -1, A, 1, INFO )
CALL CHKXER( 'SGEBAK', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SGEBAK( 'N', 'R', 2, 1, 2, S, 0, A, 1, INFO )
CALL CHKXER( 'SGEBAK', INFOT, NOUT, LERR, OK )
NT = NT + 9
*
* SGEHRD
*
SRNAMT = 'SGEHRD'
INFOT = 1
CALL SGEHRD( -1, 1, 1, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'SGEHRD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGEHRD( 0, 0, 0, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'SGEHRD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGEHRD( 0, 2, 0, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'SGEHRD', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGEHRD( 1, 1, 0, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'SGEHRD', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGEHRD( 0, 1, 1, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'SGEHRD', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGEHRD( 2, 1, 1, A, 1, TAU, W, 2, INFO )
CALL CHKXER( 'SGEHRD', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SGEHRD( 2, 1, 2, A, 2, TAU, W, 1, INFO )
CALL CHKXER( 'SGEHRD', INFOT, NOUT, LERR, OK )
NT = NT + 7
*
* SORGHR
*
SRNAMT = 'SORGHR'
INFOT = 1
CALL SORGHR( -1, 1, 1, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'SORGHR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORGHR( 0, 0, 0, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'SORGHR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORGHR( 0, 2, 0, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'SORGHR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORGHR( 1, 1, 0, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'SORGHR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORGHR( 0, 1, 1, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'SORGHR', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORGHR( 2, 1, 1, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'SORGHR', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SORGHR( 3, 1, 3, A, 3, TAU, W, 1, INFO )
CALL CHKXER( 'SORGHR', INFOT, NOUT, LERR, OK )
NT = NT + 7
*
* SORMHR
*
SRNAMT = 'SORMHR'
INFOT = 1
CALL SORMHR( '/', 'N', 0, 0, 1, 0, A, 1, TAU, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'SORMHR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORMHR( 'L', '/', 0, 0, 1, 0, A, 1, TAU, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'SORMHR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORMHR( 'L', 'N', -1, 0, 1, 0, A, 1, TAU, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'SORMHR', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SORMHR( 'L', 'N', 0, -1, 1, 0, A, 1, TAU, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'SORMHR', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORMHR( 'L', 'N', 0, 0, 0, 0, A, 1, TAU, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'SORMHR', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORMHR( 'L', 'N', 0, 0, 2, 0, A, 1, TAU, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'SORMHR', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORMHR( 'L', 'N', 1, 2, 2, 1, A, 1, TAU, C, 1, W, 2,
$ INFO )
CALL CHKXER( 'SORMHR', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORMHR( 'R', 'N', 2, 1, 2, 1, A, 1, TAU, C, 2, W, 2,
$ INFO )
CALL CHKXER( 'SORMHR', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SORMHR( 'L', 'N', 1, 1, 1, 0, A, 1, TAU, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'SORMHR', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SORMHR( 'L', 'N', 0, 1, 1, 1, A, 1, TAU, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'SORMHR', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SORMHR( 'R', 'N', 1, 0, 1, 1, A, 1, TAU, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'SORMHR', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SORMHR( 'L', 'N', 2, 1, 1, 1, A, 1, TAU, C, 2, W, 1,
$ INFO )
CALL CHKXER( 'SORMHR', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SORMHR( 'R', 'N', 1, 2, 1, 1, A, 1, TAU, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'SORMHR', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL SORMHR( 'L', 'N', 2, 1, 1, 1, A, 2, TAU, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'SORMHR', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL SORMHR( 'L', 'N', 1, 2, 1, 1, A, 1, TAU, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'SORMHR', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL SORMHR( 'R', 'N', 2, 1, 1, 1, A, 1, TAU, C, 2, W, 1,
$ INFO )
CALL CHKXER( 'SORMHR', INFOT, NOUT, LERR, OK )
NT = NT + 16
*
* SHSEQR
*
SRNAMT = 'SHSEQR'
INFOT = 1
CALL SHSEQR( '/', 'N', 0, 1, 0, A, 1, WR, WI, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'SHSEQR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SHSEQR( 'E', '/', 0, 1, 0, A, 1, WR, WI, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'SHSEQR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SHSEQR( 'E', 'N', -1, 1, 0, A, 1, WR, WI, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'SHSEQR', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SHSEQR( 'E', 'N', 0, 0, 0, A, 1, WR, WI, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'SHSEQR', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SHSEQR( 'E', 'N', 0, 2, 0, A, 1, WR, WI, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'SHSEQR', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SHSEQR( 'E', 'N', 1, 1, 0, A, 1, WR, WI, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'SHSEQR', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SHSEQR( 'E', 'N', 1, 1, 2, A, 1, WR, WI, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'SHSEQR', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SHSEQR( 'E', 'N', 2, 1, 2, A, 1, WR, WI, C, 2, W, 1,
$ INFO )
CALL CHKXER( 'SHSEQR', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL SHSEQR( 'E', 'V', 2, 1, 2, A, 2, WR, WI, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'SHSEQR', INFOT, NOUT, LERR, OK )
NT = NT + 9
*
* SHSEIN
*
SRNAMT = 'SHSEIN'
INFOT = 1
CALL SHSEIN( '/', 'N', 'N', SEL, 0, A, 1, WR, WI, VL, 1, VR, 1,
$ 0, M, W, IFAILL, IFAILR, INFO )
CALL CHKXER( 'SHSEIN', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SHSEIN( 'R', '/', 'N', SEL, 0, A, 1, WR, WI, VL, 1, VR, 1,
$ 0, M, W, IFAILL, IFAILR, INFO )
CALL CHKXER( 'SHSEIN', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SHSEIN( 'R', 'N', '/', SEL, 0, A, 1, WR, WI, VL, 1, VR, 1,
$ 0, M, W, IFAILL, IFAILR, INFO )
CALL CHKXER( 'SHSEIN', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SHSEIN( 'R', 'N', 'N', SEL, -1, A, 1, WR, WI, VL, 1, VR,
$ 1, 0, M, W, IFAILL, IFAILR, INFO )
CALL CHKXER( 'SHSEIN', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SHSEIN( 'R', 'N', 'N', SEL, 2, A, 1, WR, WI, VL, 1, VR, 2,
$ 4, M, W, IFAILL, IFAILR, INFO )
CALL CHKXER( 'SHSEIN', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL SHSEIN( 'L', 'N', 'N', SEL, 2, A, 2, WR, WI, VL, 1, VR, 1,
$ 4, M, W, IFAILL, IFAILR, INFO )
CALL CHKXER( 'SHSEIN', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL SHSEIN( 'R', 'N', 'N', SEL, 2, A, 2, WR, WI, VL, 1, VR, 1,
$ 4, M, W, IFAILL, IFAILR, INFO )
CALL CHKXER( 'SHSEIN', INFOT, NOUT, LERR, OK )
INFOT = 14
CALL SHSEIN( 'R', 'N', 'N', SEL, 2, A, 2, WR, WI, VL, 1, VR, 2,
$ 1, M, W, IFAILL, IFAILR, INFO )
CALL CHKXER( 'SHSEIN', INFOT, NOUT, LERR, OK )
NT = NT + 8
*
* STREVC
*
SRNAMT = 'STREVC'
INFOT = 1
CALL STREVC( '/', 'A', SEL, 0, A, 1, VL, 1, VR, 1, 0, M, W,
$ INFO )
CALL CHKXER( 'STREVC', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STREVC( 'L', '/', SEL, 0, A, 1, VL, 1, VR, 1, 0, M, W,
$ INFO )
CALL CHKXER( 'STREVC', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL STREVC( 'L', 'A', SEL, -1, A, 1, VL, 1, VR, 1, 0, M, W,
$ INFO )
CALL CHKXER( 'STREVC', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL STREVC( 'L', 'A', SEL, 2, A, 1, VL, 2, VR, 1, 4, M, W,
$ INFO )
CALL CHKXER( 'STREVC', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL STREVC( 'L', 'A', SEL, 2, A, 2, VL, 1, VR, 1, 4, M, W,
$ INFO )
CALL CHKXER( 'STREVC', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL STREVC( 'R', 'A', SEL, 2, A, 2, VL, 1, VR, 1, 4, M, W,
$ INFO )
CALL CHKXER( 'STREVC', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL STREVC( 'L', 'A', SEL, 2, A, 2, VL, 2, VR, 1, 1, M, W,
$ INFO )
CALL CHKXER( 'STREVC', INFOT, NOUT, LERR, OK )
NT = NT + 7
END IF
*
* Print a summary line.
*
IF( OK ) THEN
WRITE( NOUT, FMT = 9999 )PATH, NT
ELSE
WRITE( NOUT, FMT = 9998 )PATH
END IF
*
9999 FORMAT( 1X, A3, ' routines passed the tests of the error exits',
$ ' (', I3, ' tests done)' )
9998 FORMAT( ' *** ', A3, ' routines failed the tests of the error ',
$ 'exits ***' )
*
RETURN
*
* End of SERRHS
*
END
SUBROUTINE SERRST( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* SERRST tests the error exits for SSYTRD, SORGTR, SORMTR, SSPTRD,
* SOPGTR, SOPMTR, SSTEQR, SSTERF, SSTEBZ, SSTEIN, SPTEQR, SSBTRD,
* SSYEV, SSYEVX, SSYEVD, SSBEV, SSBEVX, SSBEVD,
* SSPEV, SSPEVX, SSPEVD, SSTEV, SSTEVX, SSTEVD, and SSTEDC.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* NMAX has to be at least 3 or LIW may be too small
* .. Parameters ..
INTEGER NMAX, LIW, LW
PARAMETER ( NMAX = 3, LIW = 12*NMAX, LW = 20*NMAX )
* ..
* .. Local Scalars ..
CHARACTER*2 C2
INTEGER I, INFO, J, M, N, NSPLIT, NT
* ..
* .. Local Arrays ..
INTEGER I1( NMAX ), I2( NMAX ), I3( NMAX ), IW( LIW )
REAL A( NMAX, NMAX ), C( NMAX, NMAX ), D( NMAX ),
$ E( NMAX ), Q( NMAX, NMAX ), R( NMAX ),
$ TAU( NMAX ), W( LW ), X( NMAX ),
$ Z( NMAX, NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL CHKXER, SOPGTR, SOPMTR, SORGTR, SORMTR, SPTEQR,
$ SSBEV, SSBEVD, SSBEVX, SSBTRD, SSPEV, SSPEVD,
$ SSPEVX, SSPTRD, SSTEBZ, SSTEDC, SSTEIN, SSTEQR,
$ SSTERF, SSTEV, SSTEVD, SSTEVR, SSTEVX, SSYEV,
$ SSYEVD, SSYEVR, SSYEVX, SSYTRD
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
C2 = PATH( 2: 3 )
*
* Set the variables to innocuous values.
*
DO 20 J = 1, NMAX
DO 10 I = 1, NMAX
A( I, J ) = 1. / REAL( I+J )
10 CONTINUE
20 CONTINUE
DO 30 J = 1, NMAX
D( J ) = REAL( J )
E( J ) = 0.0
I1( J ) = J
I2( J ) = J
TAU( J ) = 1.
30 CONTINUE
OK = .TRUE.
NT = 0
*
* Test error exits for the ST path.
*
IF( LSAMEN( 2, C2, 'ST' ) ) THEN
*
* SSYTRD
*
SRNAMT = 'SSYTRD'
INFOT = 1
CALL SSYTRD( '/', 0, A, 1, D, E, TAU, W, 1, INFO )
CALL CHKXER( 'SSYTRD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSYTRD( 'U', -1, A, 1, D, E, TAU, W, 1, INFO )
CALL CHKXER( 'SSYTRD', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SSYTRD( 'U', 2, A, 1, D, E, TAU, W, 1, INFO )
CALL CHKXER( 'SSYTRD', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SSYTRD( 'U', 0, A, 1, D, E, TAU, W, 0, INFO )
CALL CHKXER( 'SSYTRD', INFOT, NOUT, LERR, OK )
NT = NT + 4
*
* SORGTR
*
SRNAMT = 'SORGTR'
INFOT = 1
CALL SORGTR( '/', 0, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'SORGTR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORGTR( 'U', -1, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'SORGTR', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SORGTR( 'U', 2, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'SORGTR', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SORGTR( 'U', 3, A, 3, TAU, W, 1, INFO )
CALL CHKXER( 'SORGTR', INFOT, NOUT, LERR, OK )
NT = NT + 4
*
* SORMTR
*
SRNAMT = 'SORMTR'
INFOT = 1
CALL SORMTR( '/', 'U', 'N', 0, 0, A, 1, TAU, C, 1, W, 1, INFO )
CALL CHKXER( 'SORMTR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORMTR( 'L', '/', 'N', 0, 0, A, 1, TAU, C, 1, W, 1, INFO )
CALL CHKXER( 'SORMTR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORMTR( 'L', 'U', '/', 0, 0, A, 1, TAU, C, 1, W, 1, INFO )
CALL CHKXER( 'SORMTR', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SORMTR( 'L', 'U', 'N', -1, 0, A, 1, TAU, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'SORMTR', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORMTR( 'L', 'U', 'N', 0, -1, A, 1, TAU, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'SORMTR', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SORMTR( 'L', 'U', 'N', 2, 0, A, 1, TAU, C, 2, W, 1, INFO )
CALL CHKXER( 'SORMTR', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SORMTR( 'R', 'U', 'N', 0, 2, A, 1, TAU, C, 1, W, 1, INFO )
CALL CHKXER( 'SORMTR', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SORMTR( 'L', 'U', 'N', 2, 0, A, 2, TAU, C, 1, W, 1, INFO )
CALL CHKXER( 'SORMTR', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SORMTR( 'L', 'U', 'N', 0, 2, A, 1, TAU, C, 1, W, 1, INFO )
CALL CHKXER( 'SORMTR', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SORMTR( 'R', 'U', 'N', 2, 0, A, 1, TAU, C, 2, W, 1, INFO )
CALL CHKXER( 'SORMTR', INFOT, NOUT, LERR, OK )
NT = NT + 10
*
* SSPTRD
*
SRNAMT = 'SSPTRD'
INFOT = 1
CALL SSPTRD( '/', 0, A, D, E, TAU, INFO )
CALL CHKXER( 'SSPTRD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSPTRD( 'U', -1, A, D, E, TAU, INFO )
CALL CHKXER( 'SSPTRD', INFOT, NOUT, LERR, OK )
NT = NT + 2
*
* SOPGTR
*
SRNAMT = 'SOPGTR'
INFOT = 1
CALL SOPGTR( '/', 0, A, TAU, Z, 1, W, INFO )
CALL CHKXER( 'SOPGTR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SOPGTR( 'U', -1, A, TAU, Z, 1, W, INFO )
CALL CHKXER( 'SOPGTR', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SOPGTR( 'U', 2, A, TAU, Z, 1, W, INFO )
CALL CHKXER( 'SOPGTR', INFOT, NOUT, LERR, OK )
NT = NT + 3
*
* SOPMTR
*
SRNAMT = 'SOPMTR'
INFOT = 1
CALL SOPMTR( '/', 'U', 'N', 0, 0, A, TAU, C, 1, W, INFO )
CALL CHKXER( 'SOPMTR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SOPMTR( 'L', '/', 'N', 0, 0, A, TAU, C, 1, W, INFO )
CALL CHKXER( 'SOPMTR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SOPMTR( 'L', 'U', '/', 0, 0, A, TAU, C, 1, W, INFO )
CALL CHKXER( 'SOPMTR', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SOPMTR( 'L', 'U', 'N', -1, 0, A, TAU, C, 1, W, INFO )
CALL CHKXER( 'SOPMTR', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SOPMTR( 'L', 'U', 'N', 0, -1, A, TAU, C, 1, W, INFO )
CALL CHKXER( 'SOPMTR', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SOPMTR( 'L', 'U', 'N', 2, 0, A, TAU, C, 1, W, INFO )
CALL CHKXER( 'SOPMTR', INFOT, NOUT, LERR, OK )
NT = NT + 6
*
* SPTEQR
*
SRNAMT = 'SPTEQR'
INFOT = 1
CALL SPTEQR( '/', 0, D, E, Z, 1, W, INFO )
CALL CHKXER( 'SPTEQR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SPTEQR( 'N', -1, D, E, Z, 1, W, INFO )
CALL CHKXER( 'SPTEQR', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SPTEQR( 'V', 2, D, E, Z, 1, W, INFO )
CALL CHKXER( 'SPTEQR', INFOT, NOUT, LERR, OK )
NT = NT + 3
*
* SSTEBZ
*
SRNAMT = 'SSTEBZ'
INFOT = 1
CALL SSTEBZ( '/', 'E', 0, 0.0, 1.0, 1, 0, 0.0, D, E, M, NSPLIT,
$ X, I1, I2, W, IW, INFO )
CALL CHKXER( 'SSTEBZ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSTEBZ( 'A', '/', 0, 0.0, 0.0, 0, 0, 0.0, D, E, M, NSPLIT,
$ X, I1, I2, W, IW, INFO )
CALL CHKXER( 'SSTEBZ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSTEBZ( 'A', 'E', -1, 0.0, 0.0, 0, 0, 0.0, D, E, M,
$ NSPLIT, X, I1, I2, W, IW, INFO )
CALL CHKXER( 'SSTEBZ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SSTEBZ( 'V', 'E', 0, 0.0, 0.0, 0, 0, 0.0, D, E, M, NSPLIT,
$ X, I1, I2, W, IW, INFO )
CALL CHKXER( 'SSTEBZ', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SSTEBZ( 'I', 'E', 0, 0.0, 0.0, 0, 0, 0.0, D, E, M, NSPLIT,
$ X, I1, I2, W, IW, INFO )
CALL CHKXER( 'SSTEBZ', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SSTEBZ( 'I', 'E', 1, 0.0, 0.0, 2, 1, 0.0, D, E, M, NSPLIT,
$ X, I1, I2, W, IW, INFO )
CALL CHKXER( 'SSTEBZ', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SSTEBZ( 'I', 'E', 1, 0.0, 0.0, 1, 0, 0.0, D, E, M, NSPLIT,
$ X, I1, I2, W, IW, INFO )
CALL CHKXER( 'SSTEBZ', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SSTEBZ( 'I', 'E', 1, 0.0, 0.0, 1, 2, 0.0, D, E, M, NSPLIT,
$ X, I1, I2, W, IW, INFO )
CALL CHKXER( 'SSTEBZ', INFOT, NOUT, LERR, OK )
NT = NT + 8
*
* SSTEIN
*
SRNAMT = 'SSTEIN'
INFOT = 1
CALL SSTEIN( -1, D, E, 0, X, I1, I2, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'SSTEIN', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SSTEIN( 0, D, E, -1, X, I1, I2, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'SSTEIN', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SSTEIN( 0, D, E, 1, X, I1, I2, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'SSTEIN', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SSTEIN( 2, D, E, 0, X, I1, I2, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'SSTEIN', INFOT, NOUT, LERR, OK )
NT = NT + 4
*
* SSTEQR
*
SRNAMT = 'SSTEQR'
INFOT = 1
CALL SSTEQR( '/', 0, D, E, Z, 1, W, INFO )
CALL CHKXER( 'SSTEQR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSTEQR( 'N', -1, D, E, Z, 1, W, INFO )
CALL CHKXER( 'SSTEQR', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SSTEQR( 'V', 2, D, E, Z, 1, W, INFO )
CALL CHKXER( 'SSTEQR', INFOT, NOUT, LERR, OK )
NT = NT + 3
*
* SSTERF
*
SRNAMT = 'SSTERF'
INFOT = 1
CALL SSTERF( -1, D, E, INFO )
CALL CHKXER( 'SSTERF', INFOT, NOUT, LERR, OK )
NT = NT + 1
*
* SSTEDC
*
SRNAMT = 'SSTEDC'
INFOT = 1
CALL SSTEDC( '/', 0, D, E, Z, 1, W, 1, IW, 1, INFO )
CALL CHKXER( 'SSTEDC', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSTEDC( 'N', -1, D, E, Z, 1, W, 1, IW, 1, INFO )
CALL CHKXER( 'SSTEDC', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SSTEDC( 'V', 2, D, E, Z, 1, W, 23, IW, 28, INFO )
CALL CHKXER( 'SSTEDC', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SSTEDC( 'N', 1, D, E, Z, 1, W, 0, IW, 1, INFO )
CALL CHKXER( 'SSTEDC', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SSTEDC( 'I', 2, D, E, Z, 2, W, 0, IW, 12, INFO )
CALL CHKXER( 'SSTEDC', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SSTEDC( 'V', 2, D, E, Z, 2, W, 0, IW, 28, INFO )
CALL CHKXER( 'SSTEDC', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SSTEDC( 'N', 1, D, E, Z, 1, W, 1, IW, 0, INFO )
CALL CHKXER( 'SSTEDC', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SSTEDC( 'I', 2, D, E, Z, 2, W, 19, IW, 0, INFO )
CALL CHKXER( 'SSTEDC', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SSTEDC( 'V', 2, D, E, Z, 2, W, 23, IW, 0, INFO )
CALL CHKXER( 'SSTEDC', INFOT, NOUT, LERR, OK )
NT = NT + 9
*
* SSTEVD
*
SRNAMT = 'SSTEVD'
INFOT = 1
CALL SSTEVD( '/', 0, D, E, Z, 1, W, 1, IW, 1, INFO )
CALL CHKXER( 'SSTEVD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSTEVD( 'N', -1, D, E, Z, 1, W, 1, IW, 1, INFO )
CALL CHKXER( 'SSTEVD', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SSTEVD( 'V', 2, D, E, Z, 1, W, 19, IW, 12, INFO )
CALL CHKXER( 'SSTEVD', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SSTEVD( 'N', 1, D, E, Z, 1, W, 0, IW, 1, INFO )
CALL CHKXER( 'SSTEVD', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SSTEVD( 'V', 2, D, E, Z, 2, W, 12, IW, 12, INFO )
CALL CHKXER( 'SSTEVD', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SSTEVD( 'N', 0, D, E, Z, 1, W, 1, IW, 0, INFO )
CALL CHKXER( 'SSTEVD', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SSTEVD( 'V', 2, D, E, Z, 2, W, 19, IW, 11, INFO )
CALL CHKXER( 'SSTEVD', INFOT, NOUT, LERR, OK )
NT = NT + 7
*
* SSTEV
*
SRNAMT = 'SSTEV '
INFOT = 1
CALL SSTEV( '/', 0, D, E, Z, 1, W, INFO )
CALL CHKXER( 'SSTEV ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSTEV( 'N', -1, D, E, Z, 1, W, INFO )
CALL CHKXER( 'SSTEV ', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SSTEV( 'V', 2, D, E, Z, 1, W, INFO )
CALL CHKXER( 'SSTEV ', INFOT, NOUT, LERR, OK )
NT = NT + 3
*
* SSTEVX
*
SRNAMT = 'SSTEVX'
INFOT = 1
CALL SSTEVX( '/', 'A', 0, D, E, 0.0, 0.0, 0, 0, 0.0, M, X, Z,
$ 1, W, IW, I3, INFO )
CALL CHKXER( 'SSTEVX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSTEVX( 'N', '/', 0, D, E, 0.0, 1.0, 1, 0, 0.0, M, X, Z,
$ 1, W, IW, I3, INFO )
CALL CHKXER( 'SSTEVX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSTEVX( 'N', 'A', -1, D, E, 0.0, 0.0, 0, 0, 0.0, M, X, Z,
$ 1, W, IW, I3, INFO )
CALL CHKXER( 'SSTEVX', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SSTEVX( 'N', 'V', 1, D, E, 0.0, 0.0, 0, 0, 0.0, M, X, Z,
$ 1, W, IW, I3, INFO )
CALL CHKXER( 'SSTEVX', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SSTEVX( 'N', 'I', 1, D, E, 0.0, 0.0, 0, 0, 0.0, M, X, Z,
$ 1, W, IW, I3, INFO )
CALL CHKXER( 'SSTEVX', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SSTEVX( 'N', 'I', 1, D, E, 0.0, 0.0, 2, 1, 0.0, M, X, Z,
$ 1, W, IW, I3, INFO )
CALL CHKXER( 'SSTEVX', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SSTEVX( 'N', 'I', 2, D, E, 0.0, 0.0, 2, 1, 0.0, M, X, Z,
$ 1, W, IW, I3, INFO )
CALL CHKXER( 'SSTEVX', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SSTEVX( 'N', 'I', 1, D, E, 0.0, 0.0, 1, 2, 0.0, M, X, Z,
$ 1, W, IW, I3, INFO )
CALL CHKXER( 'SSTEVX', INFOT, NOUT, LERR, OK )
INFOT = 14
CALL SSTEVX( 'V', 'A', 2, D, E, 0.0, 0.0, 0, 0, 0.0, M, X, Z,
$ 1, W, IW, I3, INFO )
CALL CHKXER( 'SSTEVX', INFOT, NOUT, LERR, OK )
NT = NT + 9
*
* SSTEVR
*
N = 1
SRNAMT = 'SSTEVR'
INFOT = 1
CALL SSTEVR( '/', 'A', 0, D, E, 0.0, 0.0, 1, 1, 0.0, M, R, Z,
$ 1, IW, X, 20*N, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'SSTEVR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSTEVR( 'V', '/', 0, D, E, 0.0, 0.0, 1, 1, 0.0, M, R, Z,
$ 1, IW, X, 20*N, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'SSTEVR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSTEVR( 'V', 'A', -1, D, E, 0.0, 0.0, 1, 1, 0.0, M, R, Z,
$ 1, IW, X, 20*N, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'SSTEVR', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SSTEVR( 'V', 'V', 1, D, E, 0.0, 0.0, 1, 1, 0.0, M, R, Z,
$ 1, IW, X, 20*N, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'SSTEVR', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SSTEVR( 'V', 'I', 1, D, E, 0.0, 0.0, 0, 1, 0.0, M, W, Z,
$ 1, IW, X, 20*N, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'SSTEVR', INFOT, NOUT, LERR, OK )
INFOT = 9
N = 2
CALL SSTEVR( 'V', 'I', 2, D, E, 0.0, 0.0, 2, 1, 0.0, M, W, Z,
$ 1, IW, X, 20*N, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'SSTEVR', INFOT, NOUT, LERR, OK )
INFOT = 14
N = 1
CALL SSTEVR( 'V', 'I', 1, D, E, 0.0, 0.0, 1, 1, 0.0, M, W, Z,
$ 0, IW, X, 20*N, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'SSTEVR', INFOT, NOUT, LERR, OK )
INFOT = 17
CALL SSTEVR( 'V', 'I', 1, D, E, 0.0, 0.0, 1, 1, 0.0, M, W, Z,
$ 1, IW, X, 20*N-1, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'SSTEVR', INFOT, NOUT, LERR, OK )
INFOT = 19
CALL SSTEVR( 'V', 'I', 1, D, E, 0.0, 0.0, 1, 1, 0.0, M, W, Z,
$ 1, IW, X, 20*N, IW( 2*N+1 ), 10*N-1, INFO )
CALL CHKXER( 'SSTEVR', INFOT, NOUT, LERR, OK )
NT = NT + 9
*
* SSYEVD
*
SRNAMT = 'SSYEVD'
INFOT = 1
CALL SSYEVD( '/', 'U', 0, A, 1, X, W, 1, IW, 1, INFO )
CALL CHKXER( 'SSYEVD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSYEVD( 'N', '/', 0, A, 1, X, W, 1, IW, 1, INFO )
CALL CHKXER( 'SSYEVD', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSYEVD( 'N', 'U', -1, A, 1, X, W, 1, IW, 1, INFO )
CALL CHKXER( 'SSYEVD', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SSYEVD( 'N', 'U', 2, A, 1, X, W, 3, IW, 1, INFO )
CALL CHKXER( 'SSYEVD', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SSYEVD( 'N', 'U', 1, A, 1, X, W, 0, IW, 1, INFO )
CALL CHKXER( 'SSYEVD', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SSYEVD( 'N', 'U', 2, A, 2, X, W, 4, IW, 1, INFO )
CALL CHKXER( 'SSYEVD', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SSYEVD( 'V', 'U', 2, A, 2, X, W, 20, IW, 12, INFO )
CALL CHKXER( 'SSYEVD', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SSYEVD( 'N', 'U', 1, A, 1, X, W, 1, IW, 0, INFO )
CALL CHKXER( 'SSYEVD', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SSYEVD( 'N', 'U', 2, A, 2, X, W, 5, IW, 0, INFO )
CALL CHKXER( 'SSYEVD', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SSYEVD( 'V', 'U', 2, A, 2, X, W, 27, IW, 11, INFO )
CALL CHKXER( 'SSYEVD', INFOT, NOUT, LERR, OK )
NT = NT + 10
*
* SSYEVR
*
SRNAMT = 'SSYEVR'
N = 1
INFOT = 1
CALL SSYEVR( '/', 'A', 'U', 0, A, 1, 0.0, 0.0, 1, 1, 0.0, M, R,
$ Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'SSYEVR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSYEVR( 'V', '/', 'U', 0, A, 1, 0.0, 0.0, 1, 1, 0.0, M, R,
$ Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'SSYEVR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSYEVR( 'V', 'A', '/', -1, A, 1, 0.0, 0.0, 1, 1, 0.0, M,
$ R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'SSYEVR', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SSYEVR( 'V', 'A', 'U', -1, A, 1, 0.0, 0.0, 1, 1, 0.0, M,
$ R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'SSYEVR', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SSYEVR( 'V', 'A', 'U', 2, A, 1, 0.0, 0.0, 1, 1, 0.0, M, R,
$ Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'SSYEVR', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SSYEVR( 'V', 'V', 'U', 1, A, 1, 0.0E0, 0.0E0, 1, 1, 0.0,
$ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'SSYEVR', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SSYEVR( 'V', 'I', 'U', 1, A, 1, 0.0E0, 0.0E0, 0, 1, 0.0,
$ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'SSYEVR', INFOT, NOUT, LERR, OK )
INFOT = 10
*
CALL SSYEVR( 'V', 'I', 'U', 2, A, 2, 0.0E0, 0.0E0, 2, 1, 0.0,
$ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'SSYEVR', INFOT, NOUT, LERR, OK )
INFOT = 15
CALL SSYEVR( 'V', 'I', 'U', 1, A, 1, 0.0E0, 0.0E0, 1, 1, 0.0,
$ M, R, Z, 0, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'SSYEVR', INFOT, NOUT, LERR, OK )
INFOT = 18
CALL SSYEVR( 'V', 'I', 'U', 1, A, 1, 0.0E0, 0.0E0, 1, 1, 0.0,
$ M, R, Z, 1, IW, Q, 26*N-1, IW( 2*N+1 ), 10*N,
$ INFO )
CALL CHKXER( 'SSYEVR', INFOT, NOUT, LERR, OK )
INFOT = 20
CALL SSYEVR( 'V', 'I', 'U', 1, A, 1, 0.0E0, 0.0E0, 1, 1, 0.0,
$ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N-1,
$ INFO )
CALL CHKXER( 'SSYEVR', INFOT, NOUT, LERR, OK )
NT = NT + 11
*
* SSYEV
*
SRNAMT = 'SSYEV '
INFOT = 1
CALL SSYEV( '/', 'U', 0, A, 1, X, W, 1, INFO )
CALL CHKXER( 'SSYEV ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSYEV( 'N', '/', 0, A, 1, X, W, 1, INFO )
CALL CHKXER( 'SSYEV ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSYEV( 'N', 'U', -1, A, 1, X, W, 1, INFO )
CALL CHKXER( 'SSYEV ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SSYEV( 'N', 'U', 2, A, 1, X, W, 3, INFO )
CALL CHKXER( 'SSYEV ', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SSYEV( 'N', 'U', 1, A, 1, X, W, 1, INFO )
CALL CHKXER( 'SSYEV ', INFOT, NOUT, LERR, OK )
NT = NT + 5
*
* SSYEVX
*
SRNAMT = 'SSYEVX'
INFOT = 1
CALL SSYEVX( '/', 'A', 'U', 0, A, 1, 0.0, 0.0, 0, 0, 0.0, M, X,
$ Z, 1, W, 1, IW, I3, INFO )
CALL CHKXER( 'SSYEVX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSYEVX( 'N', '/', 'U', 0, A, 1, 0.0, 1.0, 1, 0, 0.0, M, X,
$ Z, 1, W, 1, IW, I3, INFO )
CALL CHKXER( 'SSYEVX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSYEVX( 'N', 'A', '/', 0, A, 1, 0.0, 0.0, 0, 0, 0.0, M, X,
$ Z, 1, W, 1, IW, I3, INFO )
INFOT = 4
CALL SSYEVX( 'N', 'A', 'U', -1, A, 1, 0.0, 0.0, 0, 0, 0.0, M,
$ X, Z, 1, W, 1, IW, I3, INFO )
CALL CHKXER( 'SSYEVX', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SSYEVX( 'N', 'A', 'U', 2, A, 1, 0.0, 0.0, 0, 0, 0.0, M, X,
$ Z, 1, W, 16, IW, I3, INFO )
CALL CHKXER( 'SSYEVX', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SSYEVX( 'N', 'V', 'U', 1, A, 1, 0.0, 0.0, 0, 0, 0.0, M, X,
$ Z, 1, W, 8, IW, I3, INFO )
CALL CHKXER( 'SSYEVX', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SSYEVX( 'N', 'I', 'U', 1, A, 1, 0.0, 0.0, 0, 0, 0.0, M, X,
$ Z, 1, W, 8, IW, I3, INFO )
CALL CHKXER( 'SSYEVX', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SSYEVX( 'N', 'I', 'U', 1, A, 1, 0.0, 0.0, 2, 1, 0.0, M, X,
$ Z, 1, W, 8, IW, I3, INFO )
CALL CHKXER( 'SSYEVX', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SSYEVX( 'N', 'I', 'U', 2, A, 2, 0.0, 0.0, 2, 1, 0.0, M, X,
$ Z, 1, W, 16, IW, I3, INFO )
CALL CHKXER( 'SSYEVX', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SSYEVX( 'N', 'I', 'U', 1, A, 1, 0.0, 0.0, 1, 2, 0.0, M, X,
$ Z, 1, W, 8, IW, I3, INFO )
CALL CHKXER( 'SSYEVX', INFOT, NOUT, LERR, OK )
INFOT = 15
CALL SSYEVX( 'V', 'A', 'U', 2, A, 2, 0.0, 0.0, 0, 0, 0.0, M, X,
$ Z, 1, W, 16, IW, I3, INFO )
CALL CHKXER( 'SSYEVX', INFOT, NOUT, LERR, OK )
INFOT = 17
CALL SSYEVX( 'V', 'A', 'U', 1, A, 1, 0.0, 0.0, 0, 0, 0.0, M, X,
$ Z, 1, W, 0, IW, I3, INFO )
CALL CHKXER( 'SSYEVX', INFOT, NOUT, LERR, OK )
NT = NT + 12
*
* SSPEVD
*
SRNAMT = 'SSPEVD'
INFOT = 1
CALL SSPEVD( '/', 'U', 0, A, X, Z, 1, W, 1, IW, 1, INFO )
CALL CHKXER( 'SSPEVD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSPEVD( 'N', '/', 0, A, X, Z, 1, W, 1, IW, 1, INFO )
CALL CHKXER( 'SSPEVD', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSPEVD( 'N', 'U', -1, A, X, Z, 1, W, 1, IW, 1, INFO )
CALL CHKXER( 'SSPEVD', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SSPEVD( 'V', 'U', 2, A, X, Z, 1, W, 23, IW, 12, INFO )
CALL CHKXER( 'SSPEVD', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SSPEVD( 'N', 'U', 1, A, X, Z, 1, W, 0, IW, 1, INFO )
CALL CHKXER( 'SSPEVD', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SSPEVD( 'N', 'U', 2, A, X, Z, 1, W, 3, IW, 1, INFO )
CALL CHKXER( 'SSPEVD', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SSPEVD( 'V', 'U', 2, A, X, Z, 2, W, 16, IW, 12, INFO )
CALL CHKXER( 'SSPEVD', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL SSPEVD( 'N', 'U', 1, A, X, Z, 1, W, 1, IW, 0, INFO )
CALL CHKXER( 'SSPEVD', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL SSPEVD( 'N', 'U', 2, A, X, Z, 1, W, 4, IW, 0, INFO )
CALL CHKXER( 'SSPEVD', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL SSPEVD( 'V', 'U', 2, A, X, Z, 2, W, 23, IW, 11, INFO )
CALL CHKXER( 'SSPEVD', INFOT, NOUT, LERR, OK )
NT = NT + 10
*
* SSPEV
*
SRNAMT = 'SSPEV '
INFOT = 1
CALL SSPEV( '/', 'U', 0, A, W, Z, 1, X, INFO )
CALL CHKXER( 'SSPEV ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSPEV( 'N', '/', 0, A, W, Z, 1, X, INFO )
CALL CHKXER( 'SSPEV ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSPEV( 'N', 'U', -1, A, W, Z, 1, X, INFO )
CALL CHKXER( 'SSPEV ', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SSPEV( 'V', 'U', 2, A, W, Z, 1, X, INFO )
CALL CHKXER( 'SSPEV ', INFOT, NOUT, LERR, OK )
NT = NT + 4
*
* SSPEVX
*
SRNAMT = 'SSPEVX'
INFOT = 1
CALL SSPEVX( '/', 'A', 'U', 0, A, 0.0, 0.0, 0, 0, 0.0, M, X, Z,
$ 1, W, IW, I3, INFO )
CALL CHKXER( 'SSPEVX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSPEVX( 'N', '/', 'U', 0, A, 0.0, 0.0, 0, 0, 0.0, M, X, Z,
$ 1, W, IW, I3, INFO )
CALL CHKXER( 'SSPEVX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSPEVX( 'N', 'A', '/', 0, A, 0.0, 0.0, 0, 0, 0.0, M, X, Z,
$ 1, W, IW, I3, INFO )
INFOT = 4
CALL SSPEVX( 'N', 'A', 'U', -1, A, 0.0, 0.0, 0, 0, 0.0, M, X,
$ Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'SSPEVX', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SSPEVX( 'N', 'V', 'U', 1, A, 0.0, 0.0, 0, 0, 0.0, M, X, Z,
$ 1, W, IW, I3, INFO )
CALL CHKXER( 'SSPEVX', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SSPEVX( 'N', 'I', 'U', 1, A, 0.0, 0.0, 0, 0, 0.0, M, X, Z,
$ 1, W, IW, I3, INFO )
CALL CHKXER( 'SSPEVX', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SSPEVX( 'N', 'I', 'U', 1, A, 0.0, 0.0, 2, 1, 0.0, M, X, Z,
$ 1, W, IW, I3, INFO )
CALL CHKXER( 'SSPEVX', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SSPEVX( 'N', 'I', 'U', 2, A, 0.0, 0.0, 2, 1, 0.0, M, X, Z,
$ 1, W, IW, I3, INFO )
CALL CHKXER( 'SSPEVX', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SSPEVX( 'N', 'I', 'U', 1, A, 0.0, 0.0, 1, 2, 0.0, M, X, Z,
$ 1, W, IW, I3, INFO )
CALL CHKXER( 'SSPEVX', INFOT, NOUT, LERR, OK )
INFOT = 14
CALL SSPEVX( 'V', 'A', 'U', 2, A, 0.0, 0.0, 0, 0, 0.0, M, X, Z,
$ 1, W, IW, I3, INFO )
CALL CHKXER( 'SSPEVX', INFOT, NOUT, LERR, OK )
NT = NT + 10
*
* Test error exits for the SB path.
*
ELSE IF( LSAMEN( 2, C2, 'SB' ) ) THEN
*
* SSBTRD
*
SRNAMT = 'SSBTRD'
INFOT = 1
CALL SSBTRD( '/', 'U', 0, 0, A, 1, D, E, Z, 1, W, INFO )
CALL CHKXER( 'SSBTRD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSBTRD( 'N', '/', 0, 0, A, 1, D, E, Z, 1, W, INFO )
CALL CHKXER( 'SSBTRD', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSBTRD( 'N', 'U', -1, 0, A, 1, D, E, Z, 1, W, INFO )
CALL CHKXER( 'SSBTRD', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SSBTRD( 'N', 'U', 0, -1, A, 1, D, E, Z, 1, W, INFO )
CALL CHKXER( 'SSBTRD', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SSBTRD( 'N', 'U', 1, 1, A, 1, D, E, Z, 1, W, INFO )
CALL CHKXER( 'SSBTRD', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SSBTRD( 'V', 'U', 2, 0, A, 1, D, E, Z, 1, W, INFO )
CALL CHKXER( 'SSBTRD', INFOT, NOUT, LERR, OK )
NT = NT + 6
*
* SSBEVD
*
SRNAMT = 'SSBEVD'
INFOT = 1
CALL SSBEVD( '/', 'U', 0, 0, A, 1, X, Z, 1, W, 1, IW, 1, INFO )
CALL CHKXER( 'SSBEVD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSBEVD( 'N', '/', 0, 0, A, 1, X, Z, 1, W, 1, IW, 1, INFO )
CALL CHKXER( 'SSBEVD', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSBEVD( 'N', 'U', -1, 0, A, 1, X, Z, 1, W, 1, IW, 1,
$ INFO )
CALL CHKXER( 'SSBEVD', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SSBEVD( 'N', 'U', 0, -1, A, 1, X, Z, 1, W, 1, IW, 1,
$ INFO )
CALL CHKXER( 'SSBEVD', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SSBEVD( 'N', 'U', 2, 1, A, 1, X, Z, 1, W, 4, IW, 1, INFO )
CALL CHKXER( 'SSBEVD', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SSBEVD( 'V', 'U', 2, 1, A, 2, X, Z, 1, W, 25, IW, 12,
$ INFO )
CALL CHKXER( 'SSBEVD', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL SSBEVD( 'N', 'U', 1, 0, A, 1, X, Z, 1, W, 0, IW, 1, INFO )
CALL CHKXER( 'SSBEVD', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL SSBEVD( 'N', 'U', 2, 0, A, 1, X, Z, 1, W, 3, IW, 1, INFO )
CALL CHKXER( 'SSBEVD', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL SSBEVD( 'V', 'U', 2, 0, A, 1, X, Z, 2, W, 18, IW, 12,
$ INFO )
CALL CHKXER( 'SSBEVD', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL SSBEVD( 'N', 'U', 1, 0, A, 1, X, Z, 1, W, 1, IW, 0, INFO )
CALL CHKXER( 'SSBEVD', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL SSBEVD( 'V', 'U', 2, 0, A, 1, X, Z, 2, W, 25, IW, 11,
$ INFO )
CALL CHKXER( 'SSBEVD', INFOT, NOUT, LERR, OK )
NT = NT + 11
*
* SSBEV
*
SRNAMT = 'SSBEV '
INFOT = 1
CALL SSBEV( '/', 'U', 0, 0, A, 1, X, Z, 1, W, INFO )
CALL CHKXER( 'SSBEV ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSBEV( 'N', '/', 0, 0, A, 1, X, Z, 1, W, INFO )
CALL CHKXER( 'SSBEV ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSBEV( 'N', 'U', -1, 0, A, 1, X, Z, 1, W, INFO )
CALL CHKXER( 'SSBEV ', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SSBEV( 'N', 'U', 0, -1, A, 1, X, Z, 1, W, INFO )
CALL CHKXER( 'SSBEV ', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SSBEV( 'N', 'U', 2, 1, A, 1, X, Z, 1, W, INFO )
CALL CHKXER( 'SSBEV ', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SSBEV( 'V', 'U', 2, 0, A, 1, X, Z, 1, W, INFO )
CALL CHKXER( 'SSBEV ', INFOT, NOUT, LERR, OK )
NT = NT + 6
*
* SSBEVX
*
SRNAMT = 'SSBEVX'
INFOT = 1
CALL SSBEVX( '/', 'A', 'U', 0, 0, A, 1, Q, 1, 0.0, 0.0, 0, 0,
$ 0.0, M, X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'SSBEVX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSBEVX( 'N', '/', 'U', 0, 0, A, 1, Q, 1, 0.0, 0.0, 0, 0,
$ 0.0, M, X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'SSBEVX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSBEVX( 'N', 'A', '/', 0, 0, A, 1, Q, 1, 0.0, 0.0, 0, 0,
$ 0.0, M, X, Z, 1, W, IW, I3, INFO )
INFOT = 4
CALL SSBEVX( 'N', 'A', 'U', -1, 0, A, 1, Q, 1, 0.0, 0.0, 0, 0,
$ 0.0, M, X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'SSBEVX', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SSBEVX( 'N', 'A', 'U', 0, -1, A, 1, Q, 1, 0.0, 0.0, 0, 0,
$ 0.0, M, X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'SSBEVX', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SSBEVX( 'N', 'A', 'U', 2, 1, A, 1, Q, 1, 0.0, 0.0, 0, 0,
$ 0.0, M, X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'SSBEVX', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SSBEVX( 'V', 'A', 'U', 2, 0, A, 1, Q, 1, 0.0, 0.0, 0, 0,
$ 0.0, M, X, Z, 2, W, IW, I3, INFO )
CALL CHKXER( 'SSBEVX', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL SSBEVX( 'N', 'V', 'U', 1, 0, A, 1, Q, 1, 0.0, 0.0, 0, 0,
$ 0.0, M, X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'SSBEVX', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SSBEVX( 'N', 'I', 'U', 1, 0, A, 1, Q, 1, 0.0, 0.0, 0, 0,
$ 0.0, M, X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'SSBEVX', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SSBEVX( 'N', 'I', 'U', 1, 0, A, 1, Q, 1, 0.0, 0.0, 2, 1,
$ 0.0, M, X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'SSBEVX', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL SSBEVX( 'N', 'I', 'U', 2, 0, A, 1, Q, 1, 0.0, 0.0, 2, 1,
$ 0.0, M, X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'SSBEVX', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL SSBEVX( 'N', 'I', 'U', 1, 0, A, 1, Q, 1, 0.0, 0.0, 1, 2,
$ 0.0, M, X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'SSBEVX', INFOT, NOUT, LERR, OK )
INFOT = 18
CALL SSBEVX( 'V', 'A', 'U', 2, 0, A, 1, Q, 2, 0.0, 0.0, 0, 0,
$ 0.0, M, X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'SSBEVX', INFOT, NOUT, LERR, OK )
NT = NT + 13
END IF
*
* Print a summary line.
*
IF( OK ) THEN
WRITE( NOUT, FMT = 9999 )PATH, NT
ELSE
WRITE( NOUT, FMT = 9998 )PATH
END IF
*
9999 FORMAT( 1X, A3, ' routines passed the tests of the error exits',
$ ' (', I3, ' tests done)' )
9998 FORMAT( ' *** ', A3, ' routines failed the tests of the error ',
$ 'exits ***' )
*
RETURN
*
* End of SERRST
*
END
SUBROUTINE SGET02( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB,
$ RWORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER LDA, LDB, LDX, M, N, NRHS
REAL RESID
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), RWORK( * ),
$ X( LDX, * )
* ..
*
* Purpose
* =======
*
* SGET02 computes the residual for a solution of a system of linear
* equations A*x = b or A'*x = b:
* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ),
* where EPS is the machine epsilon.
*
* Arguments
* =========
*
* TRANS (input) CHARACTER*1
* Specifies the form of the system of equations:
* = 'N': A *x = b
* = 'T': A'*x = b, where A' is the transpose of A
* = 'C': A'*x = b, where A' is the transpose of A
*
* 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.
*
* NRHS (input) INTEGER
* The number of columns of B, the matrix of right hand sides.
* NRHS >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The original M x N matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* X (input) REAL array, dimension (LDX,NRHS)
* The computed solution vectors for the system of linear
* equations.
*
* LDX (input) INTEGER
* The leading dimension of the array X. If TRANS = 'N',
* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M).
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the right hand side vectors for the system of
* linear equations.
* On exit, B is overwritten with the difference B - A*X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. IF TRANS = 'N',
* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N).
*
* RWORK (workspace) REAL array, dimension (M)
*
* RESID (output) REAL
* The maximum over the number of right hand sides of
* norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER J, N1, N2
REAL ANORM, BNORM, EPS, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SASUM, SLAMCH, SLANGE
EXTERNAL LSAME, SASUM, SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SGEMM
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Quick exit if M = 0 or N = 0 or NRHS = 0
*
IF( M.LE.0 .OR. N.LE.0 .OR. NRHS.EQ.0 ) THEN
RESID = ZERO
RETURN
END IF
*
IF( LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) ) THEN
N1 = N
N2 = M
ELSE
N1 = M
N2 = N
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0.
*
EPS = SLAMCH( 'Epsilon' )
ANORM = SLANGE( '1', N1, N2, A, LDA, RWORK )
IF( ANORM.LE.ZERO ) THEN
RESID = ONE / EPS
RETURN
END IF
*
* Compute B - A*X (or B - A'*X ) and store in B.
*
CALL SGEMM( TRANS, 'No transpose', N1, NRHS, N2, -ONE, A, LDA, X,
$ LDX, ONE, B, LDB )
*
* Compute the maximum over the number of right hand sides of
* norm(B - A*X) / ( norm(A) * norm(X) * EPS ) .
*
RESID = ZERO
DO 10 J = 1, NRHS
BNORM = SASUM( N1, B( 1, J ), 1 )
XNORM = SASUM( N2, X( 1, J ), 1 )
IF( XNORM.LE.ZERO ) THEN
RESID = ONE / EPS
ELSE
RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) / EPS )
END IF
10 CONTINUE
*
RETURN
*
* End of SGET02
*
END
SUBROUTINE SGET10( M, N, A, LDA, B, LDB, WORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDB, M, N
REAL RESULT
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGET10 compares two matrices A and B and computes the ratio
* RESULT = norm( A - B ) / ( norm(A) * M * EPS )
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrices A and B.
*
* N (input) INTEGER
* The number of columns of the matrices A and B.
*
* A (input) REAL array, dimension (LDA,N)
* The m by n matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (input) REAL array, dimension (LDB,N)
* The m by n matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,M).
*
* WORK (workspace) REAL array, dimension (M)
*
* RESULT (output) REAL
* RESULT = norm( A - B ) / ( norm(A) * M * EPS )
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER J
REAL ANORM, EPS, UNFL, WNORM
* ..
* .. External Functions ..
REAL SASUM, SLAMCH, SLANGE
EXTERNAL SASUM, SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 ) THEN
RESULT = ZERO
RETURN
END IF
*
UNFL = SLAMCH( 'Safe minimum' )
EPS = SLAMCH( 'Precision' )
*
WNORM = ZERO
DO 10 J = 1, N
CALL SCOPY( M, A( 1, J ), 1, WORK, 1 )
CALL SAXPY( M, -ONE, B( 1, J ), 1, WORK, 1 )
WNORM = MAX( WNORM, SASUM( N, WORK, 1 ) )
10 CONTINUE
*
ANORM = MAX( SLANGE( '1', M, N, A, LDA, WORK ), UNFL )
*
IF( ANORM.GT.WNORM ) THEN
RESULT = ( WNORM / ANORM ) / ( M*EPS )
ELSE
IF( ANORM.LT.ONE ) THEN
RESULT = ( MIN( WNORM, M*ANORM ) / ANORM ) / ( M*EPS )
ELSE
RESULT = MIN( WNORM / ANORM, REAL( M ) ) / ( M*EPS )
END IF
END IF
*
RETURN
*
* End of SGET10
*
END
SUBROUTINE SGET22( TRANSA, TRANSE, TRANSW, N, A, LDA, E, LDE, WR,
$ WI, WORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANSA, TRANSE, TRANSW
INTEGER LDA, LDE, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), E( LDE, * ), RESULT( 2 ), WI( * ),
$ WORK( * ), WR( * )
* ..
*
* Purpose
* =======
*
* SGET22 does an eigenvector check.
*
* The basic test is:
*
* RESULT(1) = | A E - E W | / ( |A| |E| ulp )
*
* using the 1-norm. It also tests the normalization of E:
*
* RESULT(2) = max | m-norm(E(j)) - 1 | / ( n ulp )
* j
*
* where E(j) is the j-th eigenvector, and m-norm is the max-norm of a
* vector. If an eigenvector is complex, as determined from WI(j)
* nonzero, then the max-norm of the vector ( er + i*ei ) is the maximum
* of
* |er(1)| + |ei(1)|, ... , |er(n)| + |ei(n)|
*
* W is a block diagonal matrix, with a 1 by 1 block for each real
* eigenvalue and a 2 by 2 block for each complex conjugate pair.
* If eigenvalues j and j+1 are a complex conjugate pair, so that
* WR(j) = WR(j+1) = wr and WI(j) = - WI(j+1) = wi, then the 2 by 2
* block corresponding to the pair will be:
*
* ( wr wi )
* ( -wi wr )
*
* Such a block multiplying an n by 2 matrix ( ur ui ) on the right
* will be the same as multiplying ur + i*ui by wr + i*wi.
*
* To handle various schemes for storage of left eigenvectors, there are
* options to use A-transpose instead of A, E-transpose instead of E,
* and/or W-transpose instead of W.
*
* Arguments
* ==========
*
* TRANSA (input) CHARACTER*1
* Specifies whether or not A is transposed.
* = 'N': No transpose
* = 'T': Transpose
* = 'C': Conjugate transpose (= Transpose)
*
* TRANSE (input) CHARACTER*1
* Specifies whether or not E is transposed.
* = 'N': No transpose, eigenvectors are in columns of E
* = 'T': Transpose, eigenvectors are in rows of E
* = 'C': Conjugate transpose (= Transpose)
*
* TRANSW (input) CHARACTER*1
* Specifies whether or not W is transposed.
* = 'N': No transpose
* = 'T': Transpose, use -WI(j) instead of WI(j)
* = 'C': Conjugate transpose, use -WI(j) instead of WI(j)
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The matrix whose eigenvectors are in E.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* E (input) REAL array, dimension (LDE,N)
* The matrix of eigenvectors. If TRANSE = 'N', the eigenvectors
* are stored in the columns of E, if TRANSE = 'T' or 'C', the
* eigenvectors are stored in the rows of E.
*
* LDE (input) INTEGER
* The leading dimension of the array E. LDE >= max(1,N).
*
* WR (input) REAL array, dimension (N)
* WI (input) REAL array, dimension (N)
* The real and imaginary parts of the eigenvalues of A.
* Purely real eigenvalues are indicated by WI(j) = 0.
* Complex conjugate pairs are indicated by WR(j)=WR(j+1) and
* WI(j) = - WI(j+1) non-zero; the real part is assumed to be
* stored in the j-th row/column and the imaginary part in
* the (j+1)-th row/column.
*
* WORK (workspace) REAL array, dimension (N*(N+1))
*
* RESULT (output) REAL array, dimension (2)
* RESULT(1) = | A E - E W | / ( |A| |E| ulp )
* RESULT(2) = max | m-norm(E(j)) - 1 | / ( n ulp )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0, ONE = 1.0 )
* ..
* .. Local Scalars ..
CHARACTER NORMA, NORME
INTEGER IECOL, IEROW, INCE, IPAIR, ITRNSE, J, JCOL,
$ JVEC
REAL ANORM, ENORM, ENRMAX, ENRMIN, ERRNRM, TEMP1,
$ ULP, UNFL
* ..
* .. Local Arrays ..
REAL WMAT( 2, 2 )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANGE
EXTERNAL LSAME, SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SGEMM, SLASET
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL
* ..
* .. Executable Statements ..
*
* Initialize RESULT (in case N=0)
*
RESULT( 1 ) = ZERO
RESULT( 2 ) = ZERO
IF( N.LE.0 )
$ RETURN
*
UNFL = SLAMCH( 'Safe minimum' )
ULP = SLAMCH( 'Precision' )
*
ITRNSE = 0
INCE = 1
NORMA = 'O'
NORME = 'O'
*
IF( LSAME( TRANSA, 'T' ) .OR. LSAME( TRANSA, 'C' ) ) THEN
NORMA = 'I'
END IF
IF( LSAME( TRANSE, 'T' ) .OR. LSAME( TRANSE, 'C' ) ) THEN
NORME = 'I'
ITRNSE = 1
INCE = LDE
END IF
*
* Check normalization of E
*
ENRMIN = ONE / ULP
ENRMAX = ZERO
IF( ITRNSE.EQ.0 ) THEN
*
* Eigenvectors are column vectors.
*
IPAIR = 0
DO 30 JVEC = 1, N
TEMP1 = ZERO
IF( IPAIR.EQ.0 .AND. JVEC.LT.N .AND. WI( JVEC ).NE.ZERO )
$ IPAIR = 1
IF( IPAIR.EQ.1 ) THEN
*
* Complex eigenvector
*
DO 10 J = 1, N
TEMP1 = MAX( TEMP1, ABS( E( J, JVEC ) )+
$ ABS( E( J, JVEC+1 ) ) )
10 CONTINUE
ENRMIN = MIN( ENRMIN, TEMP1 )
ENRMAX = MAX( ENRMAX, TEMP1 )
IPAIR = 2
ELSE IF( IPAIR.EQ.2 ) THEN
IPAIR = 0
ELSE
*
* Real eigenvector
*
DO 20 J = 1, N
TEMP1 = MAX( TEMP1, ABS( E( J, JVEC ) ) )
20 CONTINUE
ENRMIN = MIN( ENRMIN, TEMP1 )
ENRMAX = MAX( ENRMAX, TEMP1 )
IPAIR = 0
END IF
30 CONTINUE
*
ELSE
*
* Eigenvectors are row vectors.
*
DO 40 JVEC = 1, N
WORK( JVEC ) = ZERO
40 CONTINUE
*
DO 60 J = 1, N
IPAIR = 0
DO 50 JVEC = 1, N
IF( IPAIR.EQ.0 .AND. JVEC.LT.N .AND. WI( JVEC ).NE.ZERO )
$ IPAIR = 1
IF( IPAIR.EQ.1 ) THEN
WORK( JVEC ) = MAX( WORK( JVEC ),
$ ABS( E( J, JVEC ) )+ABS( E( J,
$ JVEC+1 ) ) )
WORK( JVEC+1 ) = WORK( JVEC )
ELSE IF( IPAIR.EQ.2 ) THEN
IPAIR = 0
ELSE
WORK( JVEC ) = MAX( WORK( JVEC ),
$ ABS( E( J, JVEC ) ) )
IPAIR = 0
END IF
50 CONTINUE
60 CONTINUE
*
DO 70 JVEC = 1, N
ENRMIN = MIN( ENRMIN, WORK( JVEC ) )
ENRMAX = MAX( ENRMAX, WORK( JVEC ) )
70 CONTINUE
END IF
*
* Norm of A:
*
ANORM = MAX( SLANGE( NORMA, N, N, A, LDA, WORK ), UNFL )
*
* Norm of E:
*
ENORM = MAX( SLANGE( NORME, N, N, E, LDE, WORK ), ULP )
*
* Norm of error:
*
* Error = AE - EW
*
CALL SLASET( 'Full', N, N, ZERO, ZERO, WORK, N )
*
IPAIR = 0
IEROW = 1
IECOL = 1
*
DO 80 JCOL = 1, N
IF( ITRNSE.EQ.1 ) THEN
IEROW = JCOL
ELSE
IECOL = JCOL
END IF
*
IF( IPAIR.EQ.0 .AND. WI( JCOL ).NE.ZERO )
$ IPAIR = 1
*
IF( IPAIR.EQ.1 ) THEN
WMAT( 1, 1 ) = WR( JCOL )
WMAT( 2, 1 ) = -WI( JCOL )
WMAT( 1, 2 ) = WI( JCOL )
WMAT( 2, 2 ) = WR( JCOL )
CALL SGEMM( TRANSE, TRANSW, N, 2, 2, ONE, E( IEROW, IECOL ),
$ LDE, WMAT, 2, ZERO, WORK( N*( JCOL-1 )+1 ), N )
IPAIR = 2
ELSE IF( IPAIR.EQ.2 ) THEN
IPAIR = 0
*
ELSE
*
CALL SAXPY( N, WR( JCOL ), E( IEROW, IECOL ), INCE,
$ WORK( N*( JCOL-1 )+1 ), 1 )
IPAIR = 0
END IF
*
80 CONTINUE
*
CALL SGEMM( TRANSA, TRANSE, N, N, N, ONE, A, LDA, E, LDE, -ONE,
$ WORK, N )
*
ERRNRM = SLANGE( 'One', N, N, WORK, N, WORK( N*N+1 ) ) / ENORM
*
* Compute RESULT(1) (avoiding under/overflow)
*
IF( ANORM.GT.ERRNRM ) THEN
RESULT( 1 ) = ( ERRNRM / ANORM ) / ULP
ELSE
IF( ANORM.LT.ONE ) THEN
RESULT( 1 ) = ( MIN( ERRNRM, ANORM ) / ANORM ) / ULP
ELSE
RESULT( 1 ) = MIN( ERRNRM / ANORM, ONE ) / ULP
END IF
END IF
*
* Compute RESULT(2) : the normalization error in E.
*
RESULT( 2 ) = MAX( ABS( ENRMAX-ONE ), ABS( ENRMIN-ONE ) ) /
$ ( REAL( N )*ULP )
*
RETURN
*
* End of SGET22
*
END
SUBROUTINE SGET23( COMP, BALANC, JTYPE, THRESH, ISEED, NOUNIT, N,
$ A, LDA, H, WR, WI, WR1, WI1, VL, LDVL, VR,
$ LDVR, LRE, LDLRE, RCONDV, RCNDV1, RCDVIN,
$ RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1, RESULT,
$ WORK, LWORK, IWORK, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL COMP
CHARACTER BALANC
INTEGER INFO, JTYPE, LDA, LDLRE, LDVL, LDVR, LWORK, N,
$ NOUNIT
REAL THRESH
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 ), IWORK( * )
REAL A( LDA, * ), H( LDA, * ), LRE( LDLRE, * ),
$ RCDEIN( * ), RCDVIN( * ), RCNDE1( * ),
$ RCNDV1( * ), RCONDE( * ), RCONDV( * ),
$ RESULT( 11 ), SCALE( * ), SCALE1( * ),
$ VL( LDVL, * ), VR( LDVR, * ), WI( * ),
$ WI1( * ), WORK( * ), WR( * ), WR1( * )
* ..
*
* Purpose
* =======
*
* SGET23 checks the nonsymmetric eigenvalue problem driver SGEEVX.
* If COMP = .FALSE., the first 8 of the following tests will be
* performed on the input matrix A, and also test 9 if LWORK is
* sufficiently large.
* if COMP is .TRUE. all 11 tests will be performed.
*
* (1) | A * VR - VR * W | / ( n |A| ulp )
*
* Here VR is the matrix of unit right eigenvectors.
* W is a block diagonal matrix, with a 1x1 block for each
* real eigenvalue and a 2x2 block for each complex conjugate
* pair. If eigenvalues j and j+1 are a complex conjugate pair,
* so WR(j) = WR(j+1) = wr and WI(j) = - WI(j+1) = wi, then the
* 2 x 2 block corresponding to the pair will be:
*
* ( wr wi )
* ( -wi wr )
*
* Such a block multiplying an n x 2 matrix ( ur ui ) on the
* right will be the same as multiplying ur + i*ui by wr + i*wi.
*
* (2) | A**H * VL - VL * W**H | / ( n |A| ulp )
*
* Here VL is the matrix of unit left eigenvectors, A**H is the
* conjugate transpose of A, and W is as above.
*
* (3) | |VR(i)| - 1 | / ulp and largest component real
*
* VR(i) denotes the i-th column of VR.
*
* (4) | |VL(i)| - 1 | / ulp and largest component real
*
* VL(i) denotes the i-th column of VL.
*
* (5) 0 if W(full) = W(partial), 1/ulp otherwise
*
* W(full) denotes the eigenvalues computed when VR, VL, RCONDV
* and RCONDE are also computed, and W(partial) denotes the
* eigenvalues computed when only some of VR, VL, RCONDV, and
* RCONDE are computed.
*
* (6) 0 if VR(full) = VR(partial), 1/ulp otherwise
*
* VR(full) denotes the right eigenvectors computed when VL, RCONDV
* and RCONDE are computed, and VR(partial) denotes the result
* when only some of VL and RCONDV are computed.
*
* (7) 0 if VL(full) = VL(partial), 1/ulp otherwise
*
* VL(full) denotes the left eigenvectors computed when VR, RCONDV
* and RCONDE are computed, and VL(partial) denotes the result
* when only some of VR and RCONDV are computed.
*
* (8) 0 if SCALE, ILO, IHI, ABNRM (full) =
* SCALE, ILO, IHI, ABNRM (partial)
* 1/ulp otherwise
*
* SCALE, ILO, IHI and ABNRM describe how the matrix is balanced.
* (full) is when VR, VL, RCONDE and RCONDV are also computed, and
* (partial) is when some are not computed.
*
* (9) 0 if RCONDV(full) = RCONDV(partial), 1/ulp otherwise
*
* RCONDV(full) denotes the reciprocal condition numbers of the
* right eigenvectors computed when VR, VL and RCONDE are also
* computed. RCONDV(partial) denotes the reciprocal condition
* numbers when only some of VR, VL and RCONDE are computed.
*
* (10) |RCONDV - RCDVIN| / cond(RCONDV)
*
* RCONDV is the reciprocal right eigenvector condition number
* computed by SGEEVX and RCDVIN (the precomputed true value)
* is supplied as input. cond(RCONDV) is the condition number of
* RCONDV, and takes errors in computing RCONDV into account, so
* that the resulting quantity should be O(ULP). cond(RCONDV) is
* essentially given by norm(A)/RCONDE.
*
* (11) |RCONDE - RCDEIN| / cond(RCONDE)
*
* RCONDE is the reciprocal eigenvalue condition number
* computed by SGEEVX and RCDEIN (the precomputed true value)
* is supplied as input. cond(RCONDE) is the condition number
* of RCONDE, and takes errors in computing RCONDE into account,
* so that the resulting quantity should be O(ULP). cond(RCONDE)
* is essentially given by norm(A)/RCONDV.
*
* Arguments
* =========
*
* COMP (input) LOGICAL
* COMP describes which input tests to perform:
* = .FALSE. if the computed condition numbers are not to
* be tested against RCDVIN and RCDEIN
* = .TRUE. if they are to be compared
*
* BALANC (input) CHARACTER
* Describes the balancing option to be tested.
* = 'N' for no permuting or diagonal scaling
* = 'P' for permuting but no diagonal scaling
* = 'S' for no permuting but diagonal scaling
* = 'B' for permuting and diagonal scaling
*
* JTYPE (input) INTEGER
* Type of input matrix. Used to label output if error occurs.
*
* THRESH (input) REAL
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error
* is scaled to be O(1), so THRESH should be a reasonably
* small multiple of 1, e.g., 10 or 100. In particular,
* it should not depend on the precision (single vs. double)
* or the size of the matrix. It must be at least zero.
*
* ISEED (input) INTEGER array, dimension (4)
* If COMP = .FALSE., the random number generator seed
* used to produce matrix.
* If COMP = .TRUE., ISEED(1) = the number of the example.
* Used to label output if error occurs.
*
* NOUNIT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns INFO not equal to 0.)
*
* N (input) INTEGER
* The dimension of A. N must be at least 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* Used to hold the matrix whose eigenvalues are to be
* computed.
*
* LDA (input) INTEGER
* The leading dimension of A, and H. LDA must be at
* least 1 and at least N.
*
* H (workspace) REAL array, dimension (LDA,N)
* Another copy of the test matrix A, modified by SGEEVX.
*
* WR (workspace) REAL array, dimension (N)
* WI (workspace) REAL array, dimension (N)
* The real and imaginary parts of the eigenvalues of A.
* On exit, WR + WI*i are the eigenvalues of the matrix in A.
*
* WR1 (workspace) REAL array, dimension (N)
* WI1 (workspace) REAL array, dimension (N)
* Like WR, WI, these arrays contain the eigenvalues of A,
* but those computed when SGEEVX only computes a partial
* eigendecomposition, i.e. not the eigenvalues and left
* and right eigenvectors.
*
* VL (workspace) REAL array, dimension (LDVL,N)
* VL holds the computed left eigenvectors.
*
* LDVL (input) INTEGER
* Leading dimension of VL. Must be at least max(1,N).
*
* VR (workspace) REAL array, dimension (LDVR,N)
* VR holds the computed right eigenvectors.
*
* LDVR (input) INTEGER
* Leading dimension of VR. Must be at least max(1,N).
*
* LRE (workspace) REAL array, dimension (LDLRE,N)
* LRE holds the computed right or left eigenvectors.
*
* LDLRE (input) INTEGER
* Leading dimension of LRE. Must be at least max(1,N).
*
* RCONDV (workspace) REAL array, dimension (N)
* RCONDV holds the computed reciprocal condition numbers
* for eigenvectors.
*
* RCNDV1 (workspace) REAL array, dimension (N)
* RCNDV1 holds more computed reciprocal condition numbers
* for eigenvectors.
*
* RCDVIN (input) REAL array, dimension (N)
* When COMP = .TRUE. RCDVIN holds the precomputed reciprocal
* condition numbers for eigenvectors to be compared with
* RCONDV.
*
* RCONDE (workspace) REAL array, dimension (N)
* RCONDE holds the computed reciprocal condition numbers
* for eigenvalues.
*
* RCNDE1 (workspace) REAL array, dimension (N)
* RCNDE1 holds more computed reciprocal condition numbers
* for eigenvalues.
*
* RCDEIN (input) REAL array, dimension (N)
* When COMP = .TRUE. RCDEIN holds the precomputed reciprocal
* condition numbers for eigenvalues to be compared with
* RCONDE.
*
* SCALE (workspace) REAL array, dimension (N)
* Holds information describing balancing of matrix.
*
* SCALE1 (workspace) REAL array, dimension (N)
* Holds information describing balancing of matrix.
*
* RESULT (output) REAL array, dimension (11)
* The values computed by the 11 tests described above.
* The values are currently limited to 1/ulp, to avoid
* overflow.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The number of entries in WORK. This must be at least
* 3*N, and 6*N+N**2 if tests 9, 10 or 11 are to be performed.
*
* IWORK (workspace) INTEGER array, dimension (2*N)
*
* INFO (output) INTEGER
* If 0, successful exit.
* If <0, input parameter -INFO had an incorrect value.
* If >0, SGEEVX returned an error code, the absolute
* value of which is returned.
*
* =====================================================================
*
*
* .. Parameters ..
REAL ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 )
REAL EPSIN
PARAMETER ( EPSIN = 5.9605E-8 )
* ..
* .. Local Scalars ..
LOGICAL BALOK, NOBAL
CHARACTER SENSE
INTEGER I, IHI, IHI1, IINFO, ILO, ILO1, ISENS, ISENSM,
$ J, JJ, KMIN
REAL ABNRM, ABNRM1, EPS, SMLNUM, TNRM, TOL, TOLIN,
$ ULP, ULPINV, V, VIMIN, VMAX, VMX, VRMIN, VRMX,
$ VTST
* ..
* .. Local Arrays ..
CHARACTER SENS( 2 )
REAL DUM( 1 ), RES( 2 )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLAPY2, SNRM2
EXTERNAL LSAME, SLAMCH, SLAPY2, SNRM2
* ..
* .. External Subroutines ..
EXTERNAL SGEEVX, SGET22, SLACPY, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL
* ..
* .. Data statements ..
DATA SENS / 'N', 'V' /
* ..
* .. Executable Statements ..
*
* Check for errors
*
NOBAL = LSAME( BALANC, 'N' )
BALOK = NOBAL .OR. LSAME( BALANC, 'P' ) .OR.
$ LSAME( BALANC, 'S' ) .OR. LSAME( BALANC, 'B' )
INFO = 0
IF( .NOT.BALOK ) THEN
INFO = -2
ELSE IF( THRESH.LT.ZERO ) THEN
INFO = -4
ELSE IF( NOUNIT.LE.0 ) THEN
INFO = -6
ELSE IF( N.LT.0 ) THEN
INFO = -7
ELSE IF( LDA.LT.1 .OR. LDA.LT.N ) THEN
INFO = -9
ELSE IF( LDVL.LT.1 .OR. LDVL.LT.N ) THEN
INFO = -16
ELSE IF( LDVR.LT.1 .OR. LDVR.LT.N ) THEN
INFO = -18
ELSE IF( LDLRE.LT.1 .OR. LDLRE.LT.N ) THEN
INFO = -20
ELSE IF( LWORK.LT.3*N .OR. ( COMP .AND. LWORK.LT.6*N+N*N ) ) THEN
INFO = -31
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGET23', -INFO )
RETURN
END IF
*
* Quick return if nothing to do
*
DO 10 I = 1, 11
RESULT( I ) = -ONE
10 CONTINUE
*
IF( N.EQ.0 )
$ RETURN
*
* More Important constants
*
ULP = SLAMCH( 'Precision' )
SMLNUM = SLAMCH( 'S' )
ULPINV = ONE / ULP
*
* Compute eigenvalues and eigenvectors, and test them
*
IF( LWORK.GE.6*N+N*N ) THEN
SENSE = 'B'
ISENSM = 2
ELSE
SENSE = 'E'
ISENSM = 1
END IF
CALL SLACPY( 'F', N, N, A, LDA, H, LDA )
CALL SGEEVX( BALANC, 'V', 'V', SENSE, N, H, LDA, WR, WI, VL, LDVL,
$ VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV,
$ WORK, LWORK, IWORK, IINFO )
IF( IINFO.NE.0 ) THEN
RESULT( 1 ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'SGEEVX1', IINFO, N, JTYPE,
$ BALANC, ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'SGEEVX1', IINFO, N, ISEED( 1 )
END IF
INFO = ABS( IINFO )
RETURN
END IF
*
* Do Test (1)
*
CALL SGET22( 'N', 'N', 'N', N, A, LDA, VR, LDVR, WR, WI, WORK,
$ RES )
RESULT( 1 ) = RES( 1 )
*
* Do Test (2)
*
CALL SGET22( 'T', 'N', 'T', N, A, LDA, VL, LDVL, WR, WI, WORK,
$ RES )
RESULT( 2 ) = RES( 1 )
*
* Do Test (3)
*
DO 30 J = 1, N
TNRM = ONE
IF( WI( J ).EQ.ZERO ) THEN
TNRM = SNRM2( N, VR( 1, J ), 1 )
ELSE IF( WI( J ).GT.ZERO ) THEN
TNRM = SLAPY2( SNRM2( N, VR( 1, J ), 1 ),
$ SNRM2( N, VR( 1, J+1 ), 1 ) )
END IF
RESULT( 3 ) = MAX( RESULT( 3 ),
$ MIN( ULPINV, ABS( TNRM-ONE ) / ULP ) )
IF( WI( J ).GT.ZERO ) THEN
VMX = ZERO
VRMX = ZERO
DO 20 JJ = 1, N
VTST = SLAPY2( VR( JJ, J ), VR( JJ, J+1 ) )
IF( VTST.GT.VMX )
$ VMX = VTST
IF( VR( JJ, J+1 ).EQ.ZERO .AND. ABS( VR( JJ, J ) ).GT.
$ VRMX )VRMX = ABS( VR( JJ, J ) )
20 CONTINUE
IF( VRMX / VMX.LT.ONE-TWO*ULP )
$ RESULT( 3 ) = ULPINV
END IF
30 CONTINUE
*
* Do Test (4)
*
DO 50 J = 1, N
TNRM = ONE
IF( WI( J ).EQ.ZERO ) THEN
TNRM = SNRM2( N, VL( 1, J ), 1 )
ELSE IF( WI( J ).GT.ZERO ) THEN
TNRM = SLAPY2( SNRM2( N, VL( 1, J ), 1 ),
$ SNRM2( N, VL( 1, J+1 ), 1 ) )
END IF
RESULT( 4 ) = MAX( RESULT( 4 ),
$ MIN( ULPINV, ABS( TNRM-ONE ) / ULP ) )
IF( WI( J ).GT.ZERO ) THEN
VMX = ZERO
VRMX = ZERO
DO 40 JJ = 1, N
VTST = SLAPY2( VL( JJ, J ), VL( JJ, J+1 ) )
IF( VTST.GT.VMX )
$ VMX = VTST
IF( VL( JJ, J+1 ).EQ.ZERO .AND. ABS( VL( JJ, J ) ).GT.
$ VRMX )VRMX = ABS( VL( JJ, J ) )
40 CONTINUE
IF( VRMX / VMX.LT.ONE-TWO*ULP )
$ RESULT( 4 ) = ULPINV
END IF
50 CONTINUE
*
* Test for all options of computing condition numbers
*
DO 200 ISENS = 1, ISENSM
*
SENSE = SENS( ISENS )
*
* Compute eigenvalues only, and test them
*
CALL SLACPY( 'F', N, N, A, LDA, H, LDA )
CALL SGEEVX( BALANC, 'N', 'N', SENSE, N, H, LDA, WR1, WI1, DUM,
$ 1, DUM, 1, ILO1, IHI1, SCALE1, ABNRM1, RCNDE1,
$ RCNDV1, WORK, LWORK, IWORK, IINFO )
IF( IINFO.NE.0 ) THEN
RESULT( 1 ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'SGEEVX2', IINFO, N, JTYPE,
$ BALANC, ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'SGEEVX2', IINFO, N,
$ ISEED( 1 )
END IF
INFO = ABS( IINFO )
GO TO 190
END IF
*
* Do Test (5)
*
DO 60 J = 1, N
IF( WR( J ).NE.WR1( J ) .OR. WI( J ).NE.WI1( J ) )
$ RESULT( 5 ) = ULPINV
60 CONTINUE
*
* Do Test (8)
*
IF( .NOT.NOBAL ) THEN
DO 70 J = 1, N
IF( SCALE( J ).NE.SCALE1( J ) )
$ RESULT( 8 ) = ULPINV
70 CONTINUE
IF( ILO.NE.ILO1 )
$ RESULT( 8 ) = ULPINV
IF( IHI.NE.IHI1 )
$ RESULT( 8 ) = ULPINV
IF( ABNRM.NE.ABNRM1 )
$ RESULT( 8 ) = ULPINV
END IF
*
* Do Test (9)
*
IF( ISENS.EQ.2 .AND. N.GT.1 ) THEN
DO 80 J = 1, N
IF( RCONDV( J ).NE.RCNDV1( J ) )
$ RESULT( 9 ) = ULPINV
80 CONTINUE
END IF
*
* Compute eigenvalues and right eigenvectors, and test them
*
CALL SLACPY( 'F', N, N, A, LDA, H, LDA )
CALL SGEEVX( BALANC, 'N', 'V', SENSE, N, H, LDA, WR1, WI1, DUM,
$ 1, LRE, LDLRE, ILO1, IHI1, SCALE1, ABNRM1, RCNDE1,
$ RCNDV1, WORK, LWORK, IWORK, IINFO )
IF( IINFO.NE.0 ) THEN
RESULT( 1 ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'SGEEVX3', IINFO, N, JTYPE,
$ BALANC, ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'SGEEVX3', IINFO, N,
$ ISEED( 1 )
END IF
INFO = ABS( IINFO )
GO TO 190
END IF
*
* Do Test (5) again
*
DO 90 J = 1, N
IF( WR( J ).NE.WR1( J ) .OR. WI( J ).NE.WI1( J ) )
$ RESULT( 5 ) = ULPINV
90 CONTINUE
*
* Do Test (6)
*
DO 110 J = 1, N
DO 100 JJ = 1, N
IF( VR( J, JJ ).NE.LRE( J, JJ ) )
$ RESULT( 6 ) = ULPINV
100 CONTINUE
110 CONTINUE
*
* Do Test (8) again
*
IF( .NOT.NOBAL ) THEN
DO 120 J = 1, N
IF( SCALE( J ).NE.SCALE1( J ) )
$ RESULT( 8 ) = ULPINV
120 CONTINUE
IF( ILO.NE.ILO1 )
$ RESULT( 8 ) = ULPINV
IF( IHI.NE.IHI1 )
$ RESULT( 8 ) = ULPINV
IF( ABNRM.NE.ABNRM1 )
$ RESULT( 8 ) = ULPINV
END IF
*
* Do Test (9) again
*
IF( ISENS.EQ.2 .AND. N.GT.1 ) THEN
DO 130 J = 1, N
IF( RCONDV( J ).NE.RCNDV1( J ) )
$ RESULT( 9 ) = ULPINV
130 CONTINUE
END IF
*
* Compute eigenvalues and left eigenvectors, and test them
*
CALL SLACPY( 'F', N, N, A, LDA, H, LDA )
CALL SGEEVX( BALANC, 'V', 'N', SENSE, N, H, LDA, WR1, WI1, LRE,
$ LDLRE, DUM, 1, ILO1, IHI1, SCALE1, ABNRM1, RCNDE1,
$ RCNDV1, WORK, LWORK, IWORK, IINFO )
IF( IINFO.NE.0 ) THEN
RESULT( 1 ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'SGEEVX4', IINFO, N, JTYPE,
$ BALANC, ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'SGEEVX4', IINFO, N,
$ ISEED( 1 )
END IF
INFO = ABS( IINFO )
GO TO 190
END IF
*
* Do Test (5) again
*
DO 140 J = 1, N
IF( WR( J ).NE.WR1( J ) .OR. WI( J ).NE.WI1( J ) )
$ RESULT( 5 ) = ULPINV
140 CONTINUE
*
* Do Test (7)
*
DO 160 J = 1, N
DO 150 JJ = 1, N
IF( VL( J, JJ ).NE.LRE( J, JJ ) )
$ RESULT( 7 ) = ULPINV
150 CONTINUE
160 CONTINUE
*
* Do Test (8) again
*
IF( .NOT.NOBAL ) THEN
DO 170 J = 1, N
IF( SCALE( J ).NE.SCALE1( J ) )
$ RESULT( 8 ) = ULPINV
170 CONTINUE
IF( ILO.NE.ILO1 )
$ RESULT( 8 ) = ULPINV
IF( IHI.NE.IHI1 )
$ RESULT( 8 ) = ULPINV
IF( ABNRM.NE.ABNRM1 )
$ RESULT( 8 ) = ULPINV
END IF
*
* Do Test (9) again
*
IF( ISENS.EQ.2 .AND. N.GT.1 ) THEN
DO 180 J = 1, N
IF( RCONDV( J ).NE.RCNDV1( J ) )
$ RESULT( 9 ) = ULPINV
180 CONTINUE
END IF
*
190 CONTINUE
*
200 CONTINUE
*
* If COMP, compare condition numbers to precomputed ones
*
IF( COMP ) THEN
CALL SLACPY( 'F', N, N, A, LDA, H, LDA )
CALL SGEEVX( 'N', 'V', 'V', 'B', N, H, LDA, WR, WI, VL, LDVL,
$ VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV,
$ WORK, LWORK, IWORK, IINFO )
IF( IINFO.NE.0 ) THEN
RESULT( 1 ) = ULPINV
WRITE( NOUNIT, FMT = 9999 )'SGEEVX5', IINFO, N, ISEED( 1 )
INFO = ABS( IINFO )
GO TO 250
END IF
*
* Sort eigenvalues and condition numbers lexicographically
* to compare with inputs
*
DO 220 I = 1, N - 1
KMIN = I
VRMIN = WR( I )
VIMIN = WI( I )
DO 210 J = I + 1, N
IF( WR( J ).LT.VRMIN ) THEN
KMIN = J
VRMIN = WR( J )
VIMIN = WI( J )
END IF
210 CONTINUE
WR( KMIN ) = WR( I )
WI( KMIN ) = WI( I )
WR( I ) = VRMIN
WI( I ) = VIMIN
VRMIN = RCONDE( KMIN )
RCONDE( KMIN ) = RCONDE( I )
RCONDE( I ) = VRMIN
VRMIN = RCONDV( KMIN )
RCONDV( KMIN ) = RCONDV( I )
RCONDV( I ) = VRMIN
220 CONTINUE
*
* Compare condition numbers for eigenvectors
* taking their condition numbers into account
*
RESULT( 10 ) = ZERO
EPS = MAX( EPSIN, ULP )
V = MAX( REAL( N )*EPS*ABNRM, SMLNUM )
IF( ABNRM.EQ.ZERO )
$ V = ONE
DO 230 I = 1, N
IF( V.GT.RCONDV( I )*RCONDE( I ) ) THEN
TOL = RCONDV( I )
ELSE
TOL = V / RCONDE( I )
END IF
IF( V.GT.RCDVIN( I )*RCDEIN( I ) ) THEN
TOLIN = RCDVIN( I )
ELSE
TOLIN = V / RCDEIN( I )
END IF
TOL = MAX( TOL, SMLNUM / EPS )
TOLIN = MAX( TOLIN, SMLNUM / EPS )
IF( EPS*( RCDVIN( I )-TOLIN ).GT.RCONDV( I )+TOL ) THEN
VMAX = ONE / EPS
ELSE IF( RCDVIN( I )-TOLIN.GT.RCONDV( I )+TOL ) THEN
VMAX = ( RCDVIN( I )-TOLIN ) / ( RCONDV( I )+TOL )
ELSE IF( RCDVIN( I )+TOLIN.LT.EPS*( RCONDV( I )-TOL ) ) THEN
VMAX = ONE / EPS
ELSE IF( RCDVIN( I )+TOLIN.LT.RCONDV( I )-TOL ) THEN
VMAX = ( RCONDV( I )-TOL ) / ( RCDVIN( I )+TOLIN )
ELSE
VMAX = ONE
END IF
RESULT( 10 ) = MAX( RESULT( 10 ), VMAX )
230 CONTINUE
*
* Compare condition numbers for eigenvalues
* taking their condition numbers into account
*
RESULT( 11 ) = ZERO
DO 240 I = 1, N
IF( V.GT.RCONDV( I ) ) THEN
TOL = ONE
ELSE
TOL = V / RCONDV( I )
END IF
IF( V.GT.RCDVIN( I ) ) THEN
TOLIN = ONE
ELSE
TOLIN = V / RCDVIN( I )
END IF
TOL = MAX( TOL, SMLNUM / EPS )
TOLIN = MAX( TOLIN, SMLNUM / EPS )
IF( EPS*( RCDEIN( I )-TOLIN ).GT.RCONDE( I )+TOL ) THEN
VMAX = ONE / EPS
ELSE IF( RCDEIN( I )-TOLIN.GT.RCONDE( I )+TOL ) THEN
VMAX = ( RCDEIN( I )-TOLIN ) / ( RCONDE( I )+TOL )
ELSE IF( RCDEIN( I )+TOLIN.LT.EPS*( RCONDE( I )-TOL ) ) THEN
VMAX = ONE / EPS
ELSE IF( RCDEIN( I )+TOLIN.LT.RCONDE( I )-TOL ) THEN
VMAX = ( RCONDE( I )-TOL ) / ( RCDEIN( I )+TOLIN )
ELSE
VMAX = ONE
END IF
RESULT( 11 ) = MAX( RESULT( 11 ), VMAX )
240 CONTINUE
250 CONTINUE
*
END IF
*
9999 FORMAT( ' SGET23: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', INPUT EXAMPLE NUMBER = ', I4 )
9998 FORMAT( ' SGET23: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ', BALANC = ', A, ', ISEED=(',
$ 3( I5, ',' ), I5, ')' )
*
RETURN
*
* End of SGET23
*
END
SUBROUTINE SGET24( COMP, JTYPE, THRESH, ISEED, NOUNIT, N, A, LDA,
$ H, HT, WR, WI, WRT, WIT, WRTMP, WITMP, VS,
$ LDVS, VS1, RCDEIN, RCDVIN, NSLCT, ISLCT,
$ RESULT, WORK, LWORK, IWORK, BWORK, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL COMP
INTEGER INFO, JTYPE, LDA, LDVS, LWORK, N, NOUNIT, NSLCT
REAL RCDEIN, RCDVIN, THRESH
* ..
* .. Array Arguments ..
LOGICAL BWORK( * )
INTEGER ISEED( 4 ), ISLCT( * ), IWORK( * )
REAL A( LDA, * ), H( LDA, * ), HT( LDA, * ),
$ RESULT( 17 ), VS( LDVS, * ), VS1( LDVS, * ),
$ WI( * ), WIT( * ), WITMP( * ), WORK( * ),
$ WR( * ), WRT( * ), WRTMP( * )
* ..
*
* Purpose
* =======
*
* SGET24 checks the nonsymmetric eigenvalue (Schur form) problem
* expert driver SGEESX.
*
* If COMP = .FALSE., the first 13 of the following tests will be
* be performed on the input matrix A, and also tests 14 and 15
* if LWORK is sufficiently large.
* If COMP = .TRUE., all 17 test will be performed.
*
* (1) 0 if T is in Schur form, 1/ulp otherwise
* (no sorting of eigenvalues)
*
* (2) | A - VS T VS' | / ( n |A| ulp )
*
* Here VS is the matrix of Schur eigenvectors, and T is in Schur
* form (no sorting of eigenvalues).
*
* (3) | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues).
*
* (4) 0 if WR+sqrt(-1)*WI are eigenvalues of T
* 1/ulp otherwise
* (no sorting of eigenvalues)
*
* (5) 0 if T(with VS) = T(without VS),
* 1/ulp otherwise
* (no sorting of eigenvalues)
*
* (6) 0 if eigenvalues(with VS) = eigenvalues(without VS),
* 1/ulp otherwise
* (no sorting of eigenvalues)
*
* (7) 0 if T is in Schur form, 1/ulp otherwise
* (with sorting of eigenvalues)
*
* (8) | A - VS T VS' | / ( n |A| ulp )
*
* Here VS is the matrix of Schur eigenvectors, and T is in Schur
* form (with sorting of eigenvalues).
*
* (9) | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues).
*
* (10) 0 if WR+sqrt(-1)*WI are eigenvalues of T
* 1/ulp otherwise
* If workspace sufficient, also compare WR, WI with and
* without reciprocal condition numbers
* (with sorting of eigenvalues)
*
* (11) 0 if T(with VS) = T(without VS),
* 1/ulp otherwise
* If workspace sufficient, also compare T with and without
* reciprocal condition numbers
* (with sorting of eigenvalues)
*
* (12) 0 if eigenvalues(with VS) = eigenvalues(without VS),
* 1/ulp otherwise
* If workspace sufficient, also compare VS with and without
* reciprocal condition numbers
* (with sorting of eigenvalues)
*
* (13) if sorting worked and SDIM is the number of
* eigenvalues which were SELECTed
* If workspace sufficient, also compare SDIM with and
* without reciprocal condition numbers
*
* (14) if RCONDE the same no matter if VS and/or RCONDV computed
*
* (15) if RCONDV the same no matter if VS and/or RCONDE computed
*
* (16) |RCONDE - RCDEIN| / cond(RCONDE)
*
* RCONDE is the reciprocal average eigenvalue condition number
* computed by SGEESX and RCDEIN (the precomputed true value)
* is supplied as input. cond(RCONDE) is the condition number
* of RCONDE, and takes errors in computing RCONDE into account,
* so that the resulting quantity should be O(ULP). cond(RCONDE)
* is essentially given by norm(A)/RCONDV.
*
* (17) |RCONDV - RCDVIN| / cond(RCONDV)
*
* RCONDV is the reciprocal right invariant subspace condition
* number computed by SGEESX and RCDVIN (the precomputed true
* value) is supplied as input. cond(RCONDV) is the condition
* number of RCONDV, and takes errors in computing RCONDV into
* account, so that the resulting quantity should be O(ULP).
* cond(RCONDV) is essentially given by norm(A)/RCONDE.
*
* Arguments
* =========
*
* COMP (input) LOGICAL
* COMP describes which input tests to perform:
* = .FALSE. if the computed condition numbers are not to
* be tested against RCDVIN and RCDEIN
* = .TRUE. if they are to be compared
*
* JTYPE (input) INTEGER
* Type of input matrix. Used to label output if error occurs.
*
* ISEED (input) INTEGER array, dimension (4)
* If COMP = .FALSE., the random number generator seed
* used to produce matrix.
* If COMP = .TRUE., ISEED(1) = the number of the example.
* Used to label output if error occurs.
*
* THRESH (input) REAL
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error
* is scaled to be O(1), so THRESH should be a reasonably
* small multiple of 1, e.g., 10 or 100. In particular,
* it should not depend on the precision (single vs. double)
* or the size of the matrix. It must be at least zero.
*
* NOUNIT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns INFO not equal to 0.)
*
* N (input) INTEGER
* The dimension of A. N must be at least 0.
*
* A (input/output) REAL array, dimension (LDA, N)
* Used to hold the matrix whose eigenvalues are to be
* computed.
*
* LDA (input) INTEGER
* The leading dimension of A, and H. LDA must be at
* least 1 and at least N.
*
* H (workspace) REAL array, dimension (LDA, N)
* Another copy of the test matrix A, modified by SGEESX.
*
* HT (workspace) REAL array, dimension (LDA, N)
* Yet another copy of the test matrix A, modified by SGEESX.
*
* WR (workspace) REAL array, dimension (N)
* WI (workspace) REAL array, dimension (N)
* The real and imaginary parts of the eigenvalues of A.
* On exit, WR + WI*i are the eigenvalues of the matrix in A.
*
* WRT (workspace) REAL array, dimension (N)
* WIT (workspace) REAL array, dimension (N)
* Like WR, WI, these arrays contain the eigenvalues of A,
* but those computed when SGEESX only computes a partial
* eigendecomposition, i.e. not Schur vectors
*
* WRTMP (workspace) REAL array, dimension (N)
* WITMP (workspace) REAL array, dimension (N)
* Like WR, WI, these arrays contain the eigenvalues of A,
* but sorted by increasing real part.
*
* VS (workspace) REAL array, dimension (LDVS, N)
* VS holds the computed Schur vectors.
*
* LDVS (input) INTEGER
* Leading dimension of VS. Must be at least max(1, N).
*
* VS1 (workspace) REAL array, dimension (LDVS, N)
* VS1 holds another copy of the computed Schur vectors.
*
* RCDEIN (input) REAL
* When COMP = .TRUE. RCDEIN holds the precomputed reciprocal
* condition number for the average of selected eigenvalues.
*
* RCDVIN (input) REAL
* When COMP = .TRUE. RCDVIN holds the precomputed reciprocal
* condition number for the selected right invariant subspace.
*
* NSLCT (input) INTEGER
* When COMP = .TRUE. the number of selected eigenvalues
* corresponding to the precomputed values RCDEIN and RCDVIN.
*
* ISLCT (input) INTEGER array, dimension (NSLCT)
* When COMP = .TRUE. ISLCT selects the eigenvalues of the
* input matrix corresponding to the precomputed values RCDEIN
* and RCDVIN. For I=1, ... ,NSLCT, if ISLCT(I) = J, then the
* eigenvalue with the J-th largest real part is selected.
* Not referenced if COMP = .FALSE.
*
* RESULT (output) REAL array, dimension (17)
* The values computed by the 17 tests described above.
* The values are currently limited to 1/ulp, to avoid
* overflow.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The number of entries in WORK to be passed to SGEESX. This
* must be at least 3*N, and N+N**2 if tests 14--16 are to
* be performed.
*
* IWORK (workspace) INTEGER array, dimension (N*N)
*
* BWORK (workspace) LOGICAL array, dimension (N)
*
* INFO (output) INTEGER
* If 0, successful exit.
* If <0, input parameter -INFO had an incorrect value.
* If >0, SGEESX returned an error code, the absolute
* value of which is returned.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
REAL EPSIN
PARAMETER ( EPSIN = 5.9605E-8 )
* ..
* .. Local Scalars ..
CHARACTER SORT
INTEGER I, IINFO, ISORT, ITMP, J, KMIN, KNTEIG, LIWORK,
$ RSUB, SDIM, SDIM1
REAL ANORM, EPS, RCNDE1, RCNDV1, RCONDE, RCONDV,
$ SMLNUM, TMP, TOL, TOLIN, ULP, ULPINV, V, VIMIN,
$ VRMIN, WNORM
* ..
* .. Local Arrays ..
INTEGER IPNT( 20 )
* ..
* .. Arrays in Common ..
LOGICAL SELVAL( 20 )
REAL SELWI( 20 ), SELWR( 20 )
* ..
* .. Scalars in Common ..
INTEGER SELDIM, SELOPT
* ..
* .. Common blocks ..
COMMON / SSLCT / SELOPT, SELDIM, SELVAL, SELWR, SELWI
* ..
* .. External Functions ..
LOGICAL SSLECT
REAL SLAMCH, SLANGE
EXTERNAL SSLECT, SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEESX, SGEMM, SLACPY, SORT01, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Check for errors
*
INFO = 0
IF( THRESH.LT.ZERO ) THEN
INFO = -3
ELSE IF( NOUNIT.LE.0 ) THEN
INFO = -5
ELSE IF( N.LT.0 ) THEN
INFO = -6
ELSE IF( LDA.LT.1 .OR. LDA.LT.N ) THEN
INFO = -8
ELSE IF( LDVS.LT.1 .OR. LDVS.LT.N ) THEN
INFO = -18
ELSE IF( LWORK.LT.3*N ) THEN
INFO = -26
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGET24', -INFO )
RETURN
END IF
*
* Quick return if nothing to do
*
DO 10 I = 1, 17
RESULT( I ) = -ONE
10 CONTINUE
*
IF( N.EQ.0 )
$ RETURN
*
* Important constants
*
SMLNUM = SLAMCH( 'Safe minimum' )
ULP = SLAMCH( 'Precision' )
ULPINV = ONE / ULP
*
* Perform tests (1)-(13)
*
SELOPT = 0
LIWORK = N*N
DO 120 ISORT = 0, 1
IF( ISORT.EQ.0 ) THEN
SORT = 'N'
RSUB = 0
ELSE
SORT = 'S'
RSUB = 6
END IF
*
* Compute Schur form and Schur vectors, and test them
*
CALL SLACPY( 'F', N, N, A, LDA, H, LDA )
CALL SGEESX( 'V', SORT, SSLECT, 'N', N, H, LDA, SDIM, WR, WI,
$ VS, LDVS, RCONDE, RCONDV, WORK, LWORK, IWORK,
$ LIWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 1+RSUB ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'SGEESX1', IINFO, N, JTYPE,
$ ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'SGEESX1', IINFO, N,
$ ISEED( 1 )
END IF
INFO = ABS( IINFO )
RETURN
END IF
IF( ISORT.EQ.0 ) THEN
CALL SCOPY( N, WR, 1, WRTMP, 1 )
CALL SCOPY( N, WI, 1, WITMP, 1 )
END IF
*
* Do Test (1) or Test (7)
*
RESULT( 1+RSUB ) = ZERO
DO 30 J = 1, N - 2
DO 20 I = J + 2, N
IF( H( I, J ).NE.ZERO )
$ RESULT( 1+RSUB ) = ULPINV
20 CONTINUE
30 CONTINUE
DO 40 I = 1, N - 2
IF( H( I+1, I ).NE.ZERO .AND. H( I+2, I+1 ).NE.ZERO )
$ RESULT( 1+RSUB ) = ULPINV
40 CONTINUE
DO 50 I = 1, N - 1
IF( H( I+1, I ).NE.ZERO ) THEN
IF( H( I, I ).NE.H( I+1, I+1 ) .OR. H( I, I+1 ).EQ.
$ ZERO .OR. SIGN( ONE, H( I+1, I ) ).EQ.
$ SIGN( ONE, H( I, I+1 ) ) )RESULT( 1+RSUB ) = ULPINV
END IF
50 CONTINUE
*
* Test (2) or (8): Compute norm(A - Q*H*Q') / (norm(A) * N * ULP)
*
* Copy A to VS1, used as workspace
*
CALL SLACPY( ' ', N, N, A, LDA, VS1, LDVS )
*
* Compute Q*H and store in HT.
*
CALL SGEMM( 'No transpose', 'No transpose', N, N, N, ONE, VS,
$ LDVS, H, LDA, ZERO, HT, LDA )
*
* Compute A - Q*H*Q'
*
CALL SGEMM( 'No transpose', 'Transpose', N, N, N, -ONE, HT,
$ LDA, VS, LDVS, ONE, VS1, LDVS )
*
ANORM = MAX( SLANGE( '1', N, N, A, LDA, WORK ), SMLNUM )
WNORM = SLANGE( '1', N, N, VS1, LDVS, WORK )
*
IF( ANORM.GT.WNORM ) THEN
RESULT( 2+RSUB ) = ( WNORM / ANORM ) / ( N*ULP )
ELSE
IF( ANORM.LT.ONE ) THEN
RESULT( 2+RSUB ) = ( MIN( WNORM, N*ANORM ) / ANORM ) /
$ ( N*ULP )
ELSE
RESULT( 2+RSUB ) = MIN( WNORM / ANORM, REAL( N ) ) /
$ ( N*ULP )
END IF
END IF
*
* Test (3) or (9): Compute norm( I - Q'*Q ) / ( N * ULP )
*
CALL SORT01( 'Columns', N, N, VS, LDVS, WORK, LWORK,
$ RESULT( 3+RSUB ) )
*
* Do Test (4) or Test (10)
*
RESULT( 4+RSUB ) = ZERO
DO 60 I = 1, N
IF( H( I, I ).NE.WR( I ) )
$ RESULT( 4+RSUB ) = ULPINV
60 CONTINUE
IF( N.GT.1 ) THEN
IF( H( 2, 1 ).EQ.ZERO .AND. WI( 1 ).NE.ZERO )
$ RESULT( 4+RSUB ) = ULPINV
IF( H( N, N-1 ).EQ.ZERO .AND. WI( N ).NE.ZERO )
$ RESULT( 4+RSUB ) = ULPINV
END IF
DO 70 I = 1, N - 1
IF( H( I+1, I ).NE.ZERO ) THEN
TMP = SQRT( ABS( H( I+1, I ) ) )*
$ SQRT( ABS( H( I, I+1 ) ) )
RESULT( 4+RSUB ) = MAX( RESULT( 4+RSUB ),
$ ABS( WI( I )-TMP ) /
$ MAX( ULP*TMP, SMLNUM ) )
RESULT( 4+RSUB ) = MAX( RESULT( 4+RSUB ),
$ ABS( WI( I+1 )+TMP ) /
$ MAX( ULP*TMP, SMLNUM ) )
ELSE IF( I.GT.1 ) THEN
IF( H( I+1, I ).EQ.ZERO .AND. H( I, I-1 ).EQ.ZERO .AND.
$ WI( I ).NE.ZERO )RESULT( 4+RSUB ) = ULPINV
END IF
70 CONTINUE
*
* Do Test (5) or Test (11)
*
CALL SLACPY( 'F', N, N, A, LDA, HT, LDA )
CALL SGEESX( 'N', SORT, SSLECT, 'N', N, HT, LDA, SDIM, WRT,
$ WIT, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, IWORK,
$ LIWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 5+RSUB ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'SGEESX2', IINFO, N, JTYPE,
$ ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'SGEESX2', IINFO, N,
$ ISEED( 1 )
END IF
INFO = ABS( IINFO )
GO TO 250
END IF
*
RESULT( 5+RSUB ) = ZERO
DO 90 J = 1, N
DO 80 I = 1, N
IF( H( I, J ).NE.HT( I, J ) )
$ RESULT( 5+RSUB ) = ULPINV
80 CONTINUE
90 CONTINUE
*
* Do Test (6) or Test (12)
*
RESULT( 6+RSUB ) = ZERO
DO 100 I = 1, N
IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
$ RESULT( 6+RSUB ) = ULPINV
100 CONTINUE
*
* Do Test (13)
*
IF( ISORT.EQ.1 ) THEN
RESULT( 13 ) = ZERO
KNTEIG = 0
DO 110 I = 1, N
IF( SSLECT( WR( I ), WI( I ) ) .OR.
$ SSLECT( WR( I ), -WI( I ) ) )KNTEIG = KNTEIG + 1
IF( I.LT.N ) THEN
IF( ( SSLECT( WR( I+1 ), WI( I+1 ) ) .OR.
$ SSLECT( WR( I+1 ), -WI( I+1 ) ) ) .AND.
$ ( .NOT.( SSLECT( WR( I ),
$ WI( I ) ) .OR. SSLECT( WR( I ),
$ -WI( I ) ) ) ) .AND. IINFO.NE.N+2 )RESULT( 13 )
$ = ULPINV
END IF
110 CONTINUE
IF( SDIM.NE.KNTEIG )
$ RESULT( 13 ) = ULPINV
END IF
*
120 CONTINUE
*
* If there is enough workspace, perform tests (14) and (15)
* as well as (10) through (13)
*
IF( LWORK.GE.N+( N*N ) / 2 ) THEN
*
* Compute both RCONDE and RCONDV with VS
*
SORT = 'S'
RESULT( 14 ) = ZERO
RESULT( 15 ) = ZERO
CALL SLACPY( 'F', N, N, A, LDA, HT, LDA )
CALL SGEESX( 'V', SORT, SSLECT, 'B', N, HT, LDA, SDIM1, WRT,
$ WIT, VS1, LDVS, RCONDE, RCONDV, WORK, LWORK,
$ IWORK, LIWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 14 ) = ULPINV
RESULT( 15 ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'SGEESX3', IINFO, N, JTYPE,
$ ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'SGEESX3', IINFO, N,
$ ISEED( 1 )
END IF
INFO = ABS( IINFO )
GO TO 250
END IF
*
* Perform tests (10), (11), (12), and (13)
*
DO 140 I = 1, N
IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
$ RESULT( 10 ) = ULPINV
DO 130 J = 1, N
IF( H( I, J ).NE.HT( I, J ) )
$ RESULT( 11 ) = ULPINV
IF( VS( I, J ).NE.VS1( I, J ) )
$ RESULT( 12 ) = ULPINV
130 CONTINUE
140 CONTINUE
IF( SDIM.NE.SDIM1 )
$ RESULT( 13 ) = ULPINV
*
* Compute both RCONDE and RCONDV without VS, and compare
*
CALL SLACPY( 'F', N, N, A, LDA, HT, LDA )
CALL SGEESX( 'N', SORT, SSLECT, 'B', N, HT, LDA, SDIM1, WRT,
$ WIT, VS1, LDVS, RCNDE1, RCNDV1, WORK, LWORK,
$ IWORK, LIWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 14 ) = ULPINV
RESULT( 15 ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'SGEESX4', IINFO, N, JTYPE,
$ ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'SGEESX4', IINFO, N,
$ ISEED( 1 )
END IF
INFO = ABS( IINFO )
GO TO 250
END IF
*
* Perform tests (14) and (15)
*
IF( RCNDE1.NE.RCONDE )
$ RESULT( 14 ) = ULPINV
IF( RCNDV1.NE.RCONDV )
$ RESULT( 15 ) = ULPINV
*
* Perform tests (10), (11), (12), and (13)
*
DO 160 I = 1, N
IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
$ RESULT( 10 ) = ULPINV
DO 150 J = 1, N
IF( H( I, J ).NE.HT( I, J ) )
$ RESULT( 11 ) = ULPINV
IF( VS( I, J ).NE.VS1( I, J ) )
$ RESULT( 12 ) = ULPINV
150 CONTINUE
160 CONTINUE
IF( SDIM.NE.SDIM1 )
$ RESULT( 13 ) = ULPINV
*
* Compute RCONDE with VS, and compare
*
CALL SLACPY( 'F', N, N, A, LDA, HT, LDA )
CALL SGEESX( 'V', SORT, SSLECT, 'E', N, HT, LDA, SDIM1, WRT,
$ WIT, VS1, LDVS, RCNDE1, RCNDV1, WORK, LWORK,
$ IWORK, LIWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 14 ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'SGEESX5', IINFO, N, JTYPE,
$ ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'SGEESX5', IINFO, N,
$ ISEED( 1 )
END IF
INFO = ABS( IINFO )
GO TO 250
END IF
*
* Perform test (14)
*
IF( RCNDE1.NE.RCONDE )
$ RESULT( 14 ) = ULPINV
*
* Perform tests (10), (11), (12), and (13)
*
DO 180 I = 1, N
IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
$ RESULT( 10 ) = ULPINV
DO 170 J = 1, N
IF( H( I, J ).NE.HT( I, J ) )
$ RESULT( 11 ) = ULPINV
IF( VS( I, J ).NE.VS1( I, J ) )
$ RESULT( 12 ) = ULPINV
170 CONTINUE
180 CONTINUE
IF( SDIM.NE.SDIM1 )
$ RESULT( 13 ) = ULPINV
*
* Compute RCONDE without VS, and compare
*
CALL SLACPY( 'F', N, N, A, LDA, HT, LDA )
CALL SGEESX( 'N', SORT, SSLECT, 'E', N, HT, LDA, SDIM1, WRT,
$ WIT, VS1, LDVS, RCNDE1, RCNDV1, WORK, LWORK,
$ IWORK, LIWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 14 ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'SGEESX6', IINFO, N, JTYPE,
$ ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'SGEESX6', IINFO, N,
$ ISEED( 1 )
END IF
INFO = ABS( IINFO )
GO TO 250
END IF
*
* Perform test (14)
*
IF( RCNDE1.NE.RCONDE )
$ RESULT( 14 ) = ULPINV
*
* Perform tests (10), (11), (12), and (13)
*
DO 200 I = 1, N
IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
$ RESULT( 10 ) = ULPINV
DO 190 J = 1, N
IF( H( I, J ).NE.HT( I, J ) )
$ RESULT( 11 ) = ULPINV
IF( VS( I, J ).NE.VS1( I, J ) )
$ RESULT( 12 ) = ULPINV
190 CONTINUE
200 CONTINUE
IF( SDIM.NE.SDIM1 )
$ RESULT( 13 ) = ULPINV
*
* Compute RCONDV with VS, and compare
*
CALL SLACPY( 'F', N, N, A, LDA, HT, LDA )
CALL SGEESX( 'V', SORT, SSLECT, 'V', N, HT, LDA, SDIM1, WRT,
$ WIT, VS1, LDVS, RCNDE1, RCNDV1, WORK, LWORK,
$ IWORK, LIWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 15 ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'SGEESX7', IINFO, N, JTYPE,
$ ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'SGEESX7', IINFO, N,
$ ISEED( 1 )
END IF
INFO = ABS( IINFO )
GO TO 250
END IF
*
* Perform test (15)
*
IF( RCNDV1.NE.RCONDV )
$ RESULT( 15 ) = ULPINV
*
* Perform tests (10), (11), (12), and (13)
*
DO 220 I = 1, N
IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
$ RESULT( 10 ) = ULPINV
DO 210 J = 1, N
IF( H( I, J ).NE.HT( I, J ) )
$ RESULT( 11 ) = ULPINV
IF( VS( I, J ).NE.VS1( I, J ) )
$ RESULT( 12 ) = ULPINV
210 CONTINUE
220 CONTINUE
IF( SDIM.NE.SDIM1 )
$ RESULT( 13 ) = ULPINV
*
* Compute RCONDV without VS, and compare
*
CALL SLACPY( 'F', N, N, A, LDA, HT, LDA )
CALL SGEESX( 'N', SORT, SSLECT, 'V', N, HT, LDA, SDIM1, WRT,
$ WIT, VS1, LDVS, RCNDE1, RCNDV1, WORK, LWORK,
$ IWORK, LIWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 15 ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'SGEESX8', IINFO, N, JTYPE,
$ ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'SGEESX8', IINFO, N,
$ ISEED( 1 )
END IF
INFO = ABS( IINFO )
GO TO 250
END IF
*
* Perform test (15)
*
IF( RCNDV1.NE.RCONDV )
$ RESULT( 15 ) = ULPINV
*
* Perform tests (10), (11), (12), and (13)
*
DO 240 I = 1, N
IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
$ RESULT( 10 ) = ULPINV
DO 230 J = 1, N
IF( H( I, J ).NE.HT( I, J ) )
$ RESULT( 11 ) = ULPINV
IF( VS( I, J ).NE.VS1( I, J ) )
$ RESULT( 12 ) = ULPINV
230 CONTINUE
240 CONTINUE
IF( SDIM.NE.SDIM1 )
$ RESULT( 13 ) = ULPINV
*
END IF
*
250 CONTINUE
*
* If there are precomputed reciprocal condition numbers, compare
* computed values with them.
*
IF( COMP ) THEN
*
* First set up SELOPT, SELDIM, SELVAL, SELWR, and SELWI so that
* the logical function SSLECT selects the eigenvalues specified
* by NSLCT and ISLCT.
*
SELDIM = N
SELOPT = 1
EPS = MAX( ULP, EPSIN )
DO 260 I = 1, N
IPNT( I ) = I
SELVAL( I ) = .FALSE.
SELWR( I ) = WRTMP( I )
SELWI( I ) = WITMP( I )
260 CONTINUE
DO 280 I = 1, N - 1
KMIN = I
VRMIN = WRTMP( I )
VIMIN = WITMP( I )
DO 270 J = I + 1, N
IF( WRTMP( J ).LT.VRMIN ) THEN
KMIN = J
VRMIN = WRTMP( J )
VIMIN = WITMP( J )
END IF
270 CONTINUE
WRTMP( KMIN ) = WRTMP( I )
WITMP( KMIN ) = WITMP( I )
WRTMP( I ) = VRMIN
WITMP( I ) = VIMIN
ITMP = IPNT( I )
IPNT( I ) = IPNT( KMIN )
IPNT( KMIN ) = ITMP
280 CONTINUE
DO 290 I = 1, NSLCT
SELVAL( IPNT( ISLCT( I ) ) ) = .TRUE.
290 CONTINUE
*
* Compute condition numbers
*
CALL SLACPY( 'F', N, N, A, LDA, HT, LDA )
CALL SGEESX( 'N', 'S', SSLECT, 'B', N, HT, LDA, SDIM1, WRT,
$ WIT, VS1, LDVS, RCONDE, RCONDV, WORK, LWORK,
$ IWORK, LIWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 16 ) = ULPINV
RESULT( 17 ) = ULPINV
WRITE( NOUNIT, FMT = 9999 )'SGEESX9', IINFO, N, ISEED( 1 )
INFO = ABS( IINFO )
GO TO 300
END IF
*
* Compare condition number for average of selected eigenvalues
* taking its condition number into account
*
ANORM = SLANGE( '1', N, N, A, LDA, WORK )
V = MAX( REAL( N )*EPS*ANORM, SMLNUM )
IF( ANORM.EQ.ZERO )
$ V = ONE
IF( V.GT.RCONDV ) THEN
TOL = ONE
ELSE
TOL = V / RCONDV
END IF
IF( V.GT.RCDVIN ) THEN
TOLIN = ONE
ELSE
TOLIN = V / RCDVIN
END IF
TOL = MAX( TOL, SMLNUM / EPS )
TOLIN = MAX( TOLIN, SMLNUM / EPS )
IF( EPS*( RCDEIN-TOLIN ).GT.RCONDE+TOL ) THEN
RESULT( 16 ) = ULPINV
ELSE IF( RCDEIN-TOLIN.GT.RCONDE+TOL ) THEN
RESULT( 16 ) = ( RCDEIN-TOLIN ) / ( RCONDE+TOL )
ELSE IF( RCDEIN+TOLIN.LT.EPS*( RCONDE-TOL ) ) THEN
RESULT( 16 ) = ULPINV
ELSE IF( RCDEIN+TOLIN.LT.RCONDE-TOL ) THEN
RESULT( 16 ) = ( RCONDE-TOL ) / ( RCDEIN+TOLIN )
ELSE
RESULT( 16 ) = ONE
END IF
*
* Compare condition numbers for right invariant subspace
* taking its condition number into account
*
IF( V.GT.RCONDV*RCONDE ) THEN
TOL = RCONDV
ELSE
TOL = V / RCONDE
END IF
IF( V.GT.RCDVIN*RCDEIN ) THEN
TOLIN = RCDVIN
ELSE
TOLIN = V / RCDEIN
END IF
TOL = MAX( TOL, SMLNUM / EPS )
TOLIN = MAX( TOLIN, SMLNUM / EPS )
IF( EPS*( RCDVIN-TOLIN ).GT.RCONDV+TOL ) THEN
RESULT( 17 ) = ULPINV
ELSE IF( RCDVIN-TOLIN.GT.RCONDV+TOL ) THEN
RESULT( 17 ) = ( RCDVIN-TOLIN ) / ( RCONDV+TOL )
ELSE IF( RCDVIN+TOLIN.LT.EPS*( RCONDV-TOL ) ) THEN
RESULT( 17 ) = ULPINV
ELSE IF( RCDVIN+TOLIN.LT.RCONDV-TOL ) THEN
RESULT( 17 ) = ( RCONDV-TOL ) / ( RCDVIN+TOLIN )
ELSE
RESULT( 17 ) = ONE
END IF
*
300 CONTINUE
*
END IF
*
9999 FORMAT( ' SGET24: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', INPUT EXAMPLE NUMBER = ', I4 )
9998 FORMAT( ' SGET24: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
*
RETURN
*
* End of SGET24
*
END
SUBROUTINE SGET31( RMAX, LMAX, NINFO, KNT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KNT, LMAX
REAL RMAX
* ..
* .. Array Arguments ..
INTEGER NINFO( 2 )
* ..
*
* Purpose
* =======
*
* SGET31 tests SLALN2, a routine for solving
*
* (ca A - w D)X = sB
*
* where A is an NA by NA matrix (NA=1 or 2 only), w is a real (NW=1) or
* complex (NW=2) constant, ca is a real constant, D is an NA by NA real
* diagonal matrix, and B is an NA by NW matrix (when NW=2 the second
* column of B contains the imaginary part of the solution). The code
* returns X and s, where s is a scale factor, less than or equal to 1,
* which is chosen to avoid overflow in X.
*
* If any singular values of ca A-w D are less than another input
* parameter SMIN, they are perturbed up to SMIN.
*
* The test condition is that the scaled residual
*
* norm( (ca A-w D)*X - s*B ) /
* ( max( ulp*norm(ca A-w D), SMIN )*norm(X) )
*
* should be on the order of 1. Here, ulp is the machine precision.
* Also, it is verified that SCALE is less than or equal to 1, and that
* XNORM = infinity-norm(X).
*
* Arguments
* ==========
*
* RMAX (output) REAL
* Value of the largest test ratio.
*
* LMAX (output) INTEGER
* Example number where largest test ratio achieved.
*
* NINFO (output) INTEGER array, dimension (3)
* NINFO(1) = number of examples with INFO less than 0
* NINFO(2) = number of examples with INFO greater than 0
*
* KNT (output) INTEGER
* Total number of examples tested.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0 )
REAL TWO, THREE, FOUR
PARAMETER ( TWO = 2.0E0, THREE = 3.0E0, FOUR = 4.0E0 )
REAL SEVEN, TEN
PARAMETER ( SEVEN = 7.0E0, TEN = 10.0E0 )
REAL TWNONE
PARAMETER ( TWNONE = 21.0E0 )
* ..
* .. Local Scalars ..
INTEGER IA, IB, ICA, ID1, ID2, INFO, ISMIN, ITRANS,
$ IWI, IWR, NA, NW
REAL BIGNUM, CA, D1, D2, DEN, EPS, RES, SCALE, SMIN,
$ SMLNUM, TMP, UNFL, WI, WR, XNORM
* ..
* .. Local Arrays ..
LOGICAL LTRANS( 0: 1 )
REAL A( 2, 2 ), B( 2, 2 ), VAB( 3 ), VCA( 5 ),
$ VDD( 4 ), VSMIN( 4 ), VWI( 4 ), VWR( 4 ),
$ X( 2, 2 )
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SLABAD, SLALN2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Data statements ..
DATA LTRANS / .FALSE., .TRUE. /
* ..
* .. Executable Statements ..
*
* Get machine parameters
*
EPS = SLAMCH( 'P' )
UNFL = SLAMCH( 'U' )
SMLNUM = SLAMCH( 'S' ) / EPS
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
*
* Set up test case parameters
*
VSMIN( 1 ) = SMLNUM
VSMIN( 2 ) = EPS
VSMIN( 3 ) = ONE / ( TEN*TEN )
VSMIN( 4 ) = ONE / EPS
VAB( 1 ) = SQRT( SMLNUM )
VAB( 2 ) = ONE
VAB( 3 ) = SQRT( BIGNUM )
VWR( 1 ) = ZERO
VWR( 2 ) = HALF
VWR( 3 ) = TWO
VWR( 4 ) = ONE
VWI( 1 ) = SMLNUM
VWI( 2 ) = EPS
VWI( 3 ) = ONE
VWI( 4 ) = TWO
VDD( 1 ) = SQRT( SMLNUM )
VDD( 2 ) = ONE
VDD( 3 ) = TWO
VDD( 4 ) = SQRT( BIGNUM )
VCA( 1 ) = ZERO
VCA( 2 ) = SQRT( SMLNUM )
VCA( 3 ) = EPS
VCA( 4 ) = HALF
VCA( 5 ) = ONE
*
KNT = 0
NINFO( 1 ) = 0
NINFO( 2 ) = 0
LMAX = 0
RMAX = ZERO
*
* Begin test loop
*
DO 190 ID1 = 1, 4
D1 = VDD( ID1 )
DO 180 ID2 = 1, 4
D2 = VDD( ID2 )
DO 170 ICA = 1, 5
CA = VCA( ICA )
DO 160 ITRANS = 0, 1
DO 150 ISMIN = 1, 4
SMIN = VSMIN( ISMIN )
*
NA = 1
NW = 1
DO 30 IA = 1, 3
A( 1, 1 ) = VAB( IA )
DO 20 IB = 1, 3
B( 1, 1 ) = VAB( IB )
DO 10 IWR = 1, 4
IF( D1.EQ.ONE .AND. D2.EQ.ONE .AND. CA.EQ.
$ ONE ) THEN
WR = VWR( IWR )*A( 1, 1 )
ELSE
WR = VWR( IWR )
END IF
WI = ZERO
CALL SLALN2( LTRANS( ITRANS ), NA, NW,
$ SMIN, CA, A, 2, D1, D2, B, 2,
$ WR, WI, X, 2, SCALE, XNORM,
$ INFO )
IF( INFO.LT.0 )
$ NINFO( 1 ) = NINFO( 1 ) + 1
IF( INFO.GT.0 )
$ NINFO( 2 ) = NINFO( 2 ) + 1
RES = ABS( ( CA*A( 1, 1 )-WR*D1 )*
$ X( 1, 1 )-SCALE*B( 1, 1 ) )
IF( INFO.EQ.0 ) THEN
DEN = MAX( EPS*( ABS( ( CA*A( 1,
$ 1 )-WR*D1 )*X( 1, 1 ) ) ),
$ SMLNUM )
ELSE
DEN = MAX( SMIN*ABS( X( 1, 1 ) ),
$ SMLNUM )
END IF
RES = RES / DEN
IF( ABS( X( 1, 1 ) ).LT.UNFL .AND.
$ ABS( B( 1, 1 ) ).LE.SMLNUM*
$ ABS( CA*A( 1, 1 )-WR*D1 ) )RES = ZERO
IF( SCALE.GT.ONE )
$ RES = RES + ONE / EPS
RES = RES + ABS( XNORM-ABS( X( 1, 1 ) ) )
$ / MAX( SMLNUM, XNORM ) / EPS
IF( INFO.NE.0 .AND. INFO.NE.1 )
$ RES = RES + ONE / EPS
KNT = KNT + 1
IF( RES.GT.RMAX ) THEN
LMAX = KNT
RMAX = RES
END IF
10 CONTINUE
20 CONTINUE
30 CONTINUE
*
NA = 1
NW = 2
DO 70 IA = 1, 3
A( 1, 1 ) = VAB( IA )
DO 60 IB = 1, 3
B( 1, 1 ) = VAB( IB )
B( 1, 2 ) = -HALF*VAB( IB )
DO 50 IWR = 1, 4
IF( D1.EQ.ONE .AND. D2.EQ.ONE .AND. CA.EQ.
$ ONE ) THEN
WR = VWR( IWR )*A( 1, 1 )
ELSE
WR = VWR( IWR )
END IF
DO 40 IWI = 1, 4
IF( D1.EQ.ONE .AND. D2.EQ.ONE .AND.
$ CA.EQ.ONE ) THEN
WI = VWI( IWI )*A( 1, 1 )
ELSE
WI = VWI( IWI )
END IF
CALL SLALN2( LTRANS( ITRANS ), NA, NW,
$ SMIN, CA, A, 2, D1, D2, B,
$ 2, WR, WI, X, 2, SCALE,
$ XNORM, INFO )
IF( INFO.LT.0 )
$ NINFO( 1 ) = NINFO( 1 ) + 1
IF( INFO.GT.0 )
$ NINFO( 2 ) = NINFO( 2 ) + 1
RES = ABS( ( CA*A( 1, 1 )-WR*D1 )*
$ X( 1, 1 )+( WI*D1 )*X( 1, 2 )-
$ SCALE*B( 1, 1 ) )
RES = RES + ABS( ( -WI*D1 )*X( 1, 1 )+
$ ( CA*A( 1, 1 )-WR*D1 )*X( 1, 2 )-
$ SCALE*B( 1, 2 ) )
IF( INFO.EQ.0 ) THEN
DEN = MAX( EPS*( MAX( ABS( CA*A( 1,
$ 1 )-WR*D1 ), ABS( D1*WI ) )*
$ ( ABS( X( 1, 1 ) )+ABS( X( 1,
$ 2 ) ) ) ), SMLNUM )
ELSE
DEN = MAX( SMIN*( ABS( X( 1,
$ 1 ) )+ABS( X( 1, 2 ) ) ),
$ SMLNUM )
END IF
RES = RES / DEN
IF( ABS( X( 1, 1 ) ).LT.UNFL .AND.
$ ABS( X( 1, 2 ) ).LT.UNFL .AND.
$ ABS( B( 1, 1 ) ).LE.SMLNUM*
$ ABS( CA*A( 1, 1 )-WR*D1 ) )
$ RES = ZERO
IF( SCALE.GT.ONE )
$ RES = RES + ONE / EPS
RES = RES + ABS( XNORM-
$ ABS( X( 1, 1 ) )-
$ ABS( X( 1, 2 ) ) ) /
$ MAX( SMLNUM, XNORM ) / EPS
IF( INFO.NE.0 .AND. INFO.NE.1 )
$ RES = RES + ONE / EPS
KNT = KNT + 1
IF( RES.GT.RMAX ) THEN
LMAX = KNT
RMAX = RES
END IF
40 CONTINUE
50 CONTINUE
60 CONTINUE
70 CONTINUE
*
NA = 2
NW = 1
DO 100 IA = 1, 3
A( 1, 1 ) = VAB( IA )
A( 1, 2 ) = -THREE*VAB( IA )
A( 2, 1 ) = -SEVEN*VAB( IA )
A( 2, 2 ) = TWNONE*VAB( IA )
DO 90 IB = 1, 3
B( 1, 1 ) = VAB( IB )
B( 2, 1 ) = -TWO*VAB( IB )
DO 80 IWR = 1, 4
IF( D1.EQ.ONE .AND. D2.EQ.ONE .AND. CA.EQ.
$ ONE ) THEN
WR = VWR( IWR )*A( 1, 1 )
ELSE
WR = VWR( IWR )
END IF
WI = ZERO
CALL SLALN2( LTRANS( ITRANS ), NA, NW,
$ SMIN, CA, A, 2, D1, D2, B, 2,
$ WR, WI, X, 2, SCALE, XNORM,
$ INFO )
IF( INFO.LT.0 )
$ NINFO( 1 ) = NINFO( 1 ) + 1
IF( INFO.GT.0 )
$ NINFO( 2 ) = NINFO( 2 ) + 1
IF( ITRANS.EQ.1 ) THEN
TMP = A( 1, 2 )
A( 1, 2 ) = A( 2, 1 )
A( 2, 1 ) = TMP
END IF
RES = ABS( ( CA*A( 1, 1 )-WR*D1 )*
$ X( 1, 1 )+( CA*A( 1, 2 ) )*
$ X( 2, 1 )-SCALE*B( 1, 1 ) )
RES = RES + ABS( ( CA*A( 2, 1 ) )*
$ X( 1, 1 )+( CA*A( 2, 2 )-WR*D2 )*
$ X( 2, 1 )-SCALE*B( 2, 1 ) )
IF( INFO.EQ.0 ) THEN
DEN = MAX( EPS*( MAX( ABS( CA*A( 1,
$ 1 )-WR*D1 )+ABS( CA*A( 1, 2 ) ),
$ ABS( CA*A( 2, 1 ) )+ABS( CA*A( 2,
$ 2 )-WR*D2 ) )*MAX( ABS( X( 1,
$ 1 ) ), ABS( X( 2, 1 ) ) ) ),
$ SMLNUM )
ELSE
DEN = MAX( EPS*( MAX( SMIN / EPS,
$ MAX( ABS( CA*A( 1,
$ 1 )-WR*D1 )+ABS( CA*A( 1, 2 ) ),
$ ABS( CA*A( 2, 1 ) )+ABS( CA*A( 2,
$ 2 )-WR*D2 ) ) )*MAX( ABS( X( 1,
$ 1 ) ), ABS( X( 2, 1 ) ) ) ),
$ SMLNUM )
END IF
RES = RES / DEN
IF( ABS( X( 1, 1 ) ).LT.UNFL .AND.
$ ABS( X( 2, 1 ) ).LT.UNFL .AND.
$ ABS( B( 1, 1 ) )+ABS( B( 2, 1 ) ).LE.
$ SMLNUM*( ABS( CA*A( 1,
$ 1 )-WR*D1 )+ABS( CA*A( 1,
$ 2 ) )+ABS( CA*A( 2,
$ 1 ) )+ABS( CA*A( 2, 2 )-WR*D2 ) ) )
$ RES = ZERO
IF( SCALE.GT.ONE )
$ RES = RES + ONE / EPS
RES = RES + ABS( XNORM-
$ MAX( ABS( X( 1, 1 ) ), ABS( X( 2,
$ 1 ) ) ) ) / MAX( SMLNUM, XNORM ) /
$ EPS
IF( INFO.NE.0 .AND. INFO.NE.1 )
$ RES = RES + ONE / EPS
KNT = KNT + 1
IF( RES.GT.RMAX ) THEN
LMAX = KNT
RMAX = RES
END IF
80 CONTINUE
90 CONTINUE
100 CONTINUE
*
NA = 2
NW = 2
DO 140 IA = 1, 3
A( 1, 1 ) = VAB( IA )*TWO
A( 1, 2 ) = -THREE*VAB( IA )
A( 2, 1 ) = -SEVEN*VAB( IA )
A( 2, 2 ) = TWNONE*VAB( IA )
DO 130 IB = 1, 3
B( 1, 1 ) = VAB( IB )
B( 2, 1 ) = -TWO*VAB( IB )
B( 1, 2 ) = FOUR*VAB( IB )
B( 2, 2 ) = -SEVEN*VAB( IB )
DO 120 IWR = 1, 4
IF( D1.EQ.ONE .AND. D2.EQ.ONE .AND. CA.EQ.
$ ONE ) THEN
WR = VWR( IWR )*A( 1, 1 )
ELSE
WR = VWR( IWR )
END IF
DO 110 IWI = 1, 4
IF( D1.EQ.ONE .AND. D2.EQ.ONE .AND.
$ CA.EQ.ONE ) THEN
WI = VWI( IWI )*A( 1, 1 )
ELSE
WI = VWI( IWI )
END IF
CALL SLALN2( LTRANS( ITRANS ), NA, NW,
$ SMIN, CA, A, 2, D1, D2, B,
$ 2, WR, WI, X, 2, SCALE,
$ XNORM, INFO )
IF( INFO.LT.0 )
$ NINFO( 1 ) = NINFO( 1 ) + 1
IF( INFO.GT.0 )
$ NINFO( 2 ) = NINFO( 2 ) + 1
IF( ITRANS.EQ.1 ) THEN
TMP = A( 1, 2 )
A( 1, 2 ) = A( 2, 1 )
A( 2, 1 ) = TMP
END IF
RES = ABS( ( CA*A( 1, 1 )-WR*D1 )*
$ X( 1, 1 )+( CA*A( 1, 2 ) )*
$ X( 2, 1 )+( WI*D1 )*X( 1, 2 )-
$ SCALE*B( 1, 1 ) )
RES = RES + ABS( ( CA*A( 1,
$ 1 )-WR*D1 )*X( 1, 2 )+
$ ( CA*A( 1, 2 ) )*X( 2, 2 )-
$ ( WI*D1 )*X( 1, 1 )-SCALE*
$ B( 1, 2 ) )
RES = RES + ABS( ( CA*A( 2, 1 ) )*
$ X( 1, 1 )+( CA*A( 2, 2 )-WR*D2 )*
$ X( 2, 1 )+( WI*D2 )*X( 2, 2 )-
$ SCALE*B( 2, 1 ) )
RES = RES + ABS( ( CA*A( 2, 1 ) )*
$ X( 1, 2 )+( CA*A( 2, 2 )-WR*D2 )*
$ X( 2, 2 )-( WI*D2 )*X( 2, 1 )-
$ SCALE*B( 2, 2 ) )
IF( INFO.EQ.0 ) THEN
DEN = MAX( EPS*( MAX( ABS( CA*A( 1,
$ 1 )-WR*D1 )+ABS( CA*A( 1,
$ 2 ) )+ABS( WI*D1 ),
$ ABS( CA*A( 2,
$ 1 ) )+ABS( CA*A( 2,
$ 2 )-WR*D2 )+ABS( WI*D2 ) )*
$ MAX( ABS( X( 1,
$ 1 ) )+ABS( X( 2, 1 ) ),
$ ABS( X( 1, 2 ) )+ABS( X( 2,
$ 2 ) ) ) ), SMLNUM )
ELSE
DEN = MAX( EPS*( MAX( SMIN / EPS,
$ MAX( ABS( CA*A( 1,
$ 1 )-WR*D1 )+ABS( CA*A( 1,
$ 2 ) )+ABS( WI*D1 ),
$ ABS( CA*A( 2,
$ 1 ) )+ABS( CA*A( 2,
$ 2 )-WR*D2 )+ABS( WI*D2 ) ) )*
$ MAX( ABS( X( 1,
$ 1 ) )+ABS( X( 2, 1 ) ),
$ ABS( X( 1, 2 ) )+ABS( X( 2,
$ 2 ) ) ) ), SMLNUM )
END IF
RES = RES / DEN
IF( ABS( X( 1, 1 ) ).LT.UNFL .AND.
$ ABS( X( 2, 1 ) ).LT.UNFL .AND.
$ ABS( X( 1, 2 ) ).LT.UNFL .AND.
$ ABS( X( 2, 2 ) ).LT.UNFL .AND.
$ ABS( B( 1, 1 ) )+
$ ABS( B( 2, 1 ) ).LE.SMLNUM*
$ ( ABS( CA*A( 1, 1 )-WR*D1 )+
$ ABS( CA*A( 1, 2 ) )+ABS( CA*A( 2,
$ 1 ) )+ABS( CA*A( 2,
$ 2 )-WR*D2 )+ABS( WI*D2 )+ABS( WI*
$ D1 ) ) )RES = ZERO
IF( SCALE.GT.ONE )
$ RES = RES + ONE / EPS
RES = RES + ABS( XNORM-
$ MAX( ABS( X( 1, 1 ) )+ABS( X( 1,
$ 2 ) ), ABS( X( 2,
$ 1 ) )+ABS( X( 2, 2 ) ) ) ) /
$ MAX( SMLNUM, XNORM ) / EPS
IF( INFO.NE.0 .AND. INFO.NE.1 )
$ RES = RES + ONE / EPS
KNT = KNT + 1
IF( RES.GT.RMAX ) THEN
LMAX = KNT
RMAX = RES
END IF
110 CONTINUE
120 CONTINUE
130 CONTINUE
140 CONTINUE
150 CONTINUE
160 CONTINUE
170 CONTINUE
180 CONTINUE
190 CONTINUE
*
RETURN
*
* End of SGET31
*
END
SUBROUTINE SGET32( RMAX, LMAX, NINFO, KNT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KNT, LMAX, NINFO
REAL RMAX
* ..
*
* Purpose
* =======
*
* SGET32 tests SLASY2, a routine for solving
*
* op(TL)*X + ISGN*X*op(TR) = SCALE*B
*
* where TL is N1 by N1, TR is N2 by N2, and N1,N2 =1 or 2 only.
* X and B are N1 by N2, op() is an optional transpose, an
* ISGN = 1 or -1. SCALE is chosen less than or equal to 1 to
* avoid overflow in X.
*
* The test condition is that the scaled residual
*
* norm( op(TL)*X + ISGN*X*op(TR) = SCALE*B )
* / ( max( ulp*norm(TL), ulp*norm(TR)) * norm(X), SMLNUM )
*
* should be on the order of 1. Here, ulp is the machine precision.
* Also, it is verified that SCALE is less than or equal to 1, and
* that XNORM = infinity-norm(X).
*
* Arguments
* ==========
*
* RMAX (output) REAL
* Value of the largest test ratio.
*
* LMAX (output) INTEGER
* Example number where largest test ratio achieved.
*
* NINFO (output) INTEGER
* Number of examples returned with INFO.NE.0.
*
* KNT (output) INTEGER
* Total number of examples tested.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
REAL TWO, FOUR, EIGHT
PARAMETER ( TWO = 2.0E0, FOUR = 4.0E0, EIGHT = 8.0E0 )
* ..
* .. Local Scalars ..
LOGICAL LTRANL, LTRANR
INTEGER IB, IB1, IB2, IB3, INFO, ISGN, ITL, ITLSCL,
$ ITR, ITRANL, ITRANR, ITRSCL, N1, N2
REAL BIGNUM, DEN, EPS, RES, SCALE, SGN, SMLNUM, TMP,
$ TNRM, XNORM, XNRM
* ..
* .. Local Arrays ..
INTEGER ITVAL( 2, 2, 8 )
REAL B( 2, 2 ), TL( 2, 2 ), TR( 2, 2 ), VAL( 3 ),
$ X( 2, 2 )
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SLABAD, SLASY2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Data statements ..
DATA ITVAL / 8, 4, 2, 1, 4, 8, 1, 2, 2, 1, 8, 4, 1,
$ 2, 4, 8, 9, 4, 2, 1, 4, 9, 1, 2, 2, 1, 9, 4, 1,
$ 2, 4, 9 /
* ..
* .. Executable Statements ..
*
* Get machine parameters
*
EPS = SLAMCH( 'P' )
SMLNUM = SLAMCH( 'S' ) / EPS
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
*
* Set up test case parameters
*
VAL( 1 ) = SQRT( SMLNUM )
VAL( 2 ) = ONE
VAL( 3 ) = SQRT( BIGNUM )
*
KNT = 0
NINFO = 0
LMAX = 0
RMAX = ZERO
*
* Begin test loop
*
DO 230 ITRANL = 0, 1
DO 220 ITRANR = 0, 1
DO 210 ISGN = -1, 1, 2
SGN = ISGN
LTRANL = ITRANL.EQ.1
LTRANR = ITRANR.EQ.1
*
N1 = 1
N2 = 1
DO 30 ITL = 1, 3
DO 20 ITR = 1, 3
DO 10 IB = 1, 3
TL( 1, 1 ) = VAL( ITL )
TR( 1, 1 ) = VAL( ITR )
B( 1, 1 ) = VAL( IB )
KNT = KNT + 1
CALL SLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL,
$ 2, TR, 2, B, 2, SCALE, X, 2, XNORM,
$ INFO )
IF( INFO.NE.0 )
$ NINFO = NINFO + 1
RES = ABS( ( TL( 1, 1 )+SGN*TR( 1, 1 ) )*
$ X( 1, 1 )-SCALE*B( 1, 1 ) )
IF( INFO.EQ.0 ) THEN
DEN = MAX( EPS*( ( ABS( TR( 1,
$ 1 ) )+ABS( TL( 1, 1 ) ) )*ABS( X( 1,
$ 1 ) ) ), SMLNUM )
ELSE
DEN = SMLNUM*MAX( ABS( X( 1, 1 ) ), ONE )
END IF
RES = RES / DEN
IF( SCALE.GT.ONE )
$ RES = RES + ONE / EPS
RES = RES + ABS( XNORM-ABS( X( 1, 1 ) ) ) /
$ MAX( SMLNUM, XNORM ) / EPS
IF( INFO.NE.0 .AND. INFO.NE.1 )
$ RES = RES + ONE / EPS
IF( RES.GT.RMAX ) THEN
LMAX = KNT
RMAX = RES
END IF
10 CONTINUE
20 CONTINUE
30 CONTINUE
*
N1 = 2
N2 = 1
DO 80 ITL = 1, 8
DO 70 ITLSCL = 1, 3
DO 60 ITR = 1, 3
DO 50 IB1 = 1, 3
DO 40 IB2 = 1, 3
B( 1, 1 ) = VAL( IB1 )
B( 2, 1 ) = -FOUR*VAL( IB2 )
TL( 1, 1 ) = ITVAL( 1, 1, ITL )*
$ VAL( ITLSCL )
TL( 2, 1 ) = ITVAL( 2, 1, ITL )*
$ VAL( ITLSCL )
TL( 1, 2 ) = ITVAL( 1, 2, ITL )*
$ VAL( ITLSCL )
TL( 2, 2 ) = ITVAL( 2, 2, ITL )*
$ VAL( ITLSCL )
TR( 1, 1 ) = VAL( ITR )
KNT = KNT + 1
CALL SLASY2( LTRANL, LTRANR, ISGN, N1, N2,
$ TL, 2, TR, 2, B, 2, SCALE, X,
$ 2, XNORM, INFO )
IF( INFO.NE.0 )
$ NINFO = NINFO + 1
IF( LTRANL ) THEN
TMP = TL( 1, 2 )
TL( 1, 2 ) = TL( 2, 1 )
TL( 2, 1 ) = TMP
END IF
RES = ABS( ( TL( 1, 1 )+SGN*TR( 1, 1 ) )*
$ X( 1, 1 )+TL( 1, 2 )*X( 2, 1 )-
$ SCALE*B( 1, 1 ) )
RES = RES + ABS( ( TL( 2, 2 )+SGN*TR( 1,
$ 1 ) )*X( 2, 1 )+TL( 2, 1 )*
$ X( 1, 1 )-SCALE*B( 2, 1 ) )
TNRM = ABS( TR( 1, 1 ) ) +
$ ABS( TL( 1, 1 ) ) +
$ ABS( TL( 1, 2 ) ) +
$ ABS( TL( 2, 1 ) ) +
$ ABS( TL( 2, 2 ) )
XNRM = MAX( ABS( X( 1, 1 ) ),
$ ABS( X( 2, 1 ) ) )
DEN = MAX( SMLNUM, SMLNUM*XNRM,
$ ( TNRM*EPS )*XNRM )
RES = RES / DEN
IF( SCALE.GT.ONE )
$ RES = RES + ONE / EPS
RES = RES + ABS( XNORM-XNRM ) /
$ MAX( SMLNUM, XNORM ) / EPS
IF( RES.GT.RMAX ) THEN
LMAX = KNT
RMAX = RES
END IF
40 CONTINUE
50 CONTINUE
60 CONTINUE
70 CONTINUE
80 CONTINUE
*
N1 = 1
N2 = 2
DO 130 ITR = 1, 8
DO 120 ITRSCL = 1, 3
DO 110 ITL = 1, 3
DO 100 IB1 = 1, 3
DO 90 IB2 = 1, 3
B( 1, 1 ) = VAL( IB1 )
B( 1, 2 ) = -TWO*VAL( IB2 )
TR( 1, 1 ) = ITVAL( 1, 1, ITR )*
$ VAL( ITRSCL )
TR( 2, 1 ) = ITVAL( 2, 1, ITR )*
$ VAL( ITRSCL )
TR( 1, 2 ) = ITVAL( 1, 2, ITR )*
$ VAL( ITRSCL )
TR( 2, 2 ) = ITVAL( 2, 2, ITR )*
$ VAL( ITRSCL )
TL( 1, 1 ) = VAL( ITL )
KNT = KNT + 1
CALL SLASY2( LTRANL, LTRANR, ISGN, N1, N2,
$ TL, 2, TR, 2, B, 2, SCALE, X,
$ 2, XNORM, INFO )
IF( INFO.NE.0 )
$ NINFO = NINFO + 1
IF( LTRANR ) THEN
TMP = TR( 1, 2 )
TR( 1, 2 ) = TR( 2, 1 )
TR( 2, 1 ) = TMP
END IF
TNRM = ABS( TL( 1, 1 ) ) +
$ ABS( TR( 1, 1 ) ) +
$ ABS( TR( 1, 2 ) ) +
$ ABS( TR( 2, 2 ) ) +
$ ABS( TR( 2, 1 ) )
XNRM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) )
RES = ABS( ( ( TL( 1, 1 )+SGN*TR( 1,
$ 1 ) ) )*( X( 1, 1 ) )+
$ ( SGN*TR( 2, 1 ) )*( X( 1, 2 ) )-
$ ( SCALE*B( 1, 1 ) ) )
RES = RES + ABS( ( ( TL( 1, 1 )+SGN*TR( 2,
$ 2 ) ) )*( X( 1, 2 ) )+
$ ( SGN*TR( 1, 2 ) )*( X( 1, 1 ) )-
$ ( SCALE*B( 1, 2 ) ) )
DEN = MAX( SMLNUM, SMLNUM*XNRM,
$ ( TNRM*EPS )*XNRM )
RES = RES / DEN
IF( SCALE.GT.ONE )
$ RES = RES + ONE / EPS
RES = RES + ABS( XNORM-XNRM ) /
$ MAX( SMLNUM, XNORM ) / EPS
IF( RES.GT.RMAX ) THEN
LMAX = KNT
RMAX = RES
END IF
90 CONTINUE
100 CONTINUE
110 CONTINUE
120 CONTINUE
130 CONTINUE
*
N1 = 2
N2 = 2
DO 200 ITR = 1, 8
DO 190 ITRSCL = 1, 3
DO 180 ITL = 1, 8
DO 170 ITLSCL = 1, 3
DO 160 IB1 = 1, 3
DO 150 IB2 = 1, 3
DO 140 IB3 = 1, 3
B( 1, 1 ) = VAL( IB1 )
B( 2, 1 ) = -FOUR*VAL( IB2 )
B( 1, 2 ) = -TWO*VAL( IB3 )
B( 2, 2 ) = EIGHT*
$ MIN( VAL( IB1 ), VAL
$ ( IB2 ), VAL( IB3 ) )
TR( 1, 1 ) = ITVAL( 1, 1, ITR )*
$ VAL( ITRSCL )
TR( 2, 1 ) = ITVAL( 2, 1, ITR )*
$ VAL( ITRSCL )
TR( 1, 2 ) = ITVAL( 1, 2, ITR )*
$ VAL( ITRSCL )
TR( 2, 2 ) = ITVAL( 2, 2, ITR )*
$ VAL( ITRSCL )
TL( 1, 1 ) = ITVAL( 1, 1, ITL )*
$ VAL( ITLSCL )
TL( 2, 1 ) = ITVAL( 2, 1, ITL )*
$ VAL( ITLSCL )
TL( 1, 2 ) = ITVAL( 1, 2, ITL )*
$ VAL( ITLSCL )
TL( 2, 2 ) = ITVAL( 2, 2, ITL )*
$ VAL( ITLSCL )
KNT = KNT + 1
CALL SLASY2( LTRANL, LTRANR, ISGN,
$ N1, N2, TL, 2, TR, 2,
$ B, 2, SCALE, X, 2,
$ XNORM, INFO )
IF( INFO.NE.0 )
$ NINFO = NINFO + 1
IF( LTRANR ) THEN
TMP = TR( 1, 2 )
TR( 1, 2 ) = TR( 2, 1 )
TR( 2, 1 ) = TMP
END IF
IF( LTRANL ) THEN
TMP = TL( 1, 2 )
TL( 1, 2 ) = TL( 2, 1 )
TL( 2, 1 ) = TMP
END IF
TNRM = ABS( TR( 1, 1 ) ) +
$ ABS( TR( 2, 1 ) ) +
$ ABS( TR( 1, 2 ) ) +
$ ABS( TR( 2, 2 ) ) +
$ ABS( TL( 1, 1 ) ) +
$ ABS( TL( 2, 1 ) ) +
$ ABS( TL( 1, 2 ) ) +
$ ABS( TL( 2, 2 ) )
XNRM = MAX( ABS( X( 1, 1 ) )+
$ ABS( X( 1, 2 ) ),
$ ABS( X( 2, 1 ) )+
$ ABS( X( 2, 2 ) ) )
RES = ABS( ( ( TL( 1, 1 )+SGN*TR( 1,
$ 1 ) ) )*( X( 1, 1 ) )+
$ ( SGN*TR( 2, 1 ) )*
$ ( X( 1, 2 ) )+( TL( 1, 2 ) )*
$ ( X( 2, 1 ) )-
$ ( SCALE*B( 1, 1 ) ) )
RES = RES + ABS( ( TL( 1, 1 ) )*
$ ( X( 1, 2 ) )+
$ ( SGN*TR( 1, 2 ) )*
$ ( X( 1, 1 ) )+
$ ( SGN*TR( 2, 2 ) )*
$ ( X( 1, 2 ) )+( TL( 1, 2 ) )*
$ ( X( 2, 2 ) )-
$ ( SCALE*B( 1, 2 ) ) )
RES = RES + ABS( ( TL( 2, 1 ) )*
$ ( X( 1, 1 ) )+
$ ( SGN*TR( 1, 1 ) )*
$ ( X( 2, 1 ) )+
$ ( SGN*TR( 2, 1 ) )*
$ ( X( 2, 2 ) )+( TL( 2, 2 ) )*
$ ( X( 2, 1 ) )-
$ ( SCALE*B( 2, 1 ) ) )
RES = RES + ABS( ( ( TL( 2,
$ 2 )+SGN*TR( 2, 2 ) ) )*
$ ( X( 2, 2 ) )+
$ ( SGN*TR( 1, 2 ) )*
$ ( X( 2, 1 ) )+( TL( 2, 1 ) )*
$ ( X( 1, 2 ) )-
$ ( SCALE*B( 2, 2 ) ) )
DEN = MAX( SMLNUM, SMLNUM*XNRM,
$ ( TNRM*EPS )*XNRM )
RES = RES / DEN
IF( SCALE.GT.ONE )
$ RES = RES + ONE / EPS
RES = RES + ABS( XNORM-XNRM ) /
$ MAX( SMLNUM, XNORM ) / EPS
IF( RES.GT.RMAX ) THEN
LMAX = KNT
RMAX = RES
END IF
140 CONTINUE
150 CONTINUE
160 CONTINUE
170 CONTINUE
180 CONTINUE
190 CONTINUE
200 CONTINUE
210 CONTINUE
220 CONTINUE
230 CONTINUE
*
RETURN
*
* End of SGET32
*
END
SUBROUTINE SGET33( RMAX, LMAX, NINFO, KNT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KNT, LMAX, NINFO
REAL RMAX
* ..
*
* Purpose
* =======
*
* SGET33 tests SLANV2, a routine for putting 2 by 2 blocks into
* standard form. In other words, it computes a two by two rotation
* [[C,S];[-S,C]] where in
*
* [ C S ][T(1,1) T(1,2)][ C -S ] = [ T11 T12 ]
* [-S C ][T(2,1) T(2,2)][ S C ] [ T21 T22 ]
*
* either
* 1) T21=0 (real eigenvalues), or
* 2) T11=T22 and T21*T12<0 (complex conjugate eigenvalues).
* We also verify that the residual is small.
*
* Arguments
* ==========
*
* RMAX (output) REAL
* Value of the largest test ratio.
*
* LMAX (output) INTEGER
* Example number where largest test ratio achieved.
*
* NINFO (output) INTEGER
* Number of examples returned with INFO .NE. 0.
*
* KNT (output) INTEGER
* Total number of examples tested.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
REAL TWO, FOUR
PARAMETER ( TWO = 2.0E0, FOUR = 4.0E0 )
* ..
* .. Local Scalars ..
INTEGER I1, I2, I3, I4, IM1, IM2, IM3, IM4, J1, J2, J3
REAL BIGNUM, CS, EPS, RES, SMLNUM, SN, SUM, TNRM,
$ WI1, WI2, WR1, WR2
* ..
* .. Local Arrays ..
REAL Q( 2, 2 ), T( 2, 2 ), T1( 2, 2 ), T2( 2, 2 ),
$ VAL( 4 ), VM( 3 )
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SLABAD, SLANV2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SIGN
* ..
* .. Executable Statements ..
*
* Get machine parameters
*
EPS = SLAMCH( 'P' )
SMLNUM = SLAMCH( 'S' ) / EPS
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
*
* Set up test case parameters
*
VAL( 1 ) = ONE
VAL( 2 ) = ONE + TWO*EPS
VAL( 3 ) = TWO
VAL( 4 ) = TWO - FOUR*EPS
VM( 1 ) = SMLNUM
VM( 2 ) = ONE
VM( 3 ) = BIGNUM
*
KNT = 0
NINFO = 0
LMAX = 0
RMAX = ZERO
*
* Begin test loop
*
DO 150 I1 = 1, 4
DO 140 I2 = 1, 4
DO 130 I3 = 1, 4
DO 120 I4 = 1, 4
DO 110 IM1 = 1, 3
DO 100 IM2 = 1, 3
DO 90 IM3 = 1, 3
DO 80 IM4 = 1, 3
T( 1, 1 ) = VAL( I1 )*VM( IM1 )
T( 1, 2 ) = VAL( I2 )*VM( IM2 )
T( 2, 1 ) = -VAL( I3 )*VM( IM3 )
T( 2, 2 ) = VAL( I4 )*VM( IM4 )
TNRM = MAX( ABS( T( 1, 1 ) ),
$ ABS( T( 1, 2 ) ), ABS( T( 2, 1 ) ),
$ ABS( T( 2, 2 ) ) )
T1( 1, 1 ) = T( 1, 1 )
T1( 1, 2 ) = T( 1, 2 )
T1( 2, 1 ) = T( 2, 1 )
T1( 2, 2 ) = T( 2, 2 )
Q( 1, 1 ) = ONE
Q( 1, 2 ) = ZERO
Q( 2, 1 ) = ZERO
Q( 2, 2 ) = ONE
*
CALL SLANV2( T( 1, 1 ), T( 1, 2 ),
$ T( 2, 1 ), T( 2, 2 ), WR1,
$ WI1, WR2, WI2, CS, SN )
DO 10 J1 = 1, 2
RES = Q( J1, 1 )*CS + Q( J1, 2 )*SN
Q( J1, 2 ) = -Q( J1, 1 )*SN +
$ Q( J1, 2 )*CS
Q( J1, 1 ) = RES
10 CONTINUE
*
RES = ZERO
RES = RES + ABS( Q( 1, 1 )**2+
$ Q( 1, 2 )**2-ONE ) / EPS
RES = RES + ABS( Q( 2, 2 )**2+
$ Q( 2, 1 )**2-ONE ) / EPS
RES = RES + ABS( Q( 1, 1 )*Q( 2, 1 )+
$ Q( 1, 2 )*Q( 2, 2 ) ) / EPS
DO 40 J1 = 1, 2
DO 30 J2 = 1, 2
T2( J1, J2 ) = ZERO
DO 20 J3 = 1, 2
T2( J1, J2 ) = T2( J1, J2 ) +
$ T1( J1, J3 )*
$ Q( J3, J2 )
20 CONTINUE
30 CONTINUE
40 CONTINUE
DO 70 J1 = 1, 2
DO 60 J2 = 1, 2
SUM = T( J1, J2 )
DO 50 J3 = 1, 2
SUM = SUM - Q( J3, J1 )*
$ T2( J3, J2 )
50 CONTINUE
RES = RES + ABS( SUM ) / EPS / TNRM
60 CONTINUE
70 CONTINUE
IF( T( 2, 1 ).NE.ZERO .AND.
$ ( T( 1, 1 ).NE.T( 2,
$ 2 ) .OR. SIGN( ONE, T( 1,
$ 2 ) )*SIGN( ONE, T( 2,
$ 1 ) ).GT.ZERO ) )RES = RES + ONE / EPS
KNT = KNT + 1
IF( RES.GT.RMAX ) THEN
LMAX = KNT
RMAX = RES
END IF
80 CONTINUE
90 CONTINUE
100 CONTINUE
110 CONTINUE
120 CONTINUE
130 CONTINUE
140 CONTINUE
150 CONTINUE
*
RETURN
*
* End of SGET33
*
END
SUBROUTINE SGET34( RMAX, LMAX, NINFO, KNT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KNT, LMAX
REAL RMAX
* ..
* .. Array Arguments ..
INTEGER NINFO( 2 )
* ..
*
* Purpose
* =======
*
* SGET34 tests SLAEXC, a routine for swapping adjacent blocks (either
* 1 by 1 or 2 by 2) on the diagonal of a matrix in real Schur form.
* Thus, SLAEXC computes an orthogonal matrix Q such that
*
* Q' * [ A B ] * Q = [ C1 B1 ]
* [ 0 C ] [ 0 A1 ]
*
* where C1 is similar to C and A1 is similar to A. Both A and C are
* assumed to be in standard form (equal diagonal entries and
* offdiagonal with differing signs) and A1 and C1 are returned with the
* same properties.
*
* The test code verifies these last last assertions, as well as that
* the residual in the above equation is small.
*
* Arguments
* ==========
*
* RMAX (output) REAL
* Value of the largest test ratio.
*
* LMAX (output) INTEGER
* Example number where largest test ratio achieved.
*
* NINFO (output) INTEGER array, dimension (2)
* NINFO(J) is the number of examples where INFO=J occurred.
*
* KNT (output) INTEGER
* Total number of examples tested.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0 )
REAL TWO, THREE
PARAMETER ( TWO = 2.0E0, THREE = 3.0E0 )
INTEGER LWORK
PARAMETER ( LWORK = 32 )
* ..
* .. Local Scalars ..
INTEGER I, IA, IA11, IA12, IA21, IA22, IAM, IB, IC,
$ IC11, IC12, IC21, IC22, ICM, INFO, J
REAL BIGNUM, EPS, RES, SMLNUM, TNRM
* ..
* .. Local Arrays ..
REAL Q( 4, 4 ), RESULT( 2 ), T( 4, 4 ), T1( 4, 4 ),
$ VAL( 9 ), VM( 2 ), WORK( LWORK )
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLAEXC
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, REAL, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Get machine parameters
*
EPS = SLAMCH( 'P' )
SMLNUM = SLAMCH( 'S' ) / EPS
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
*
* Set up test case parameters
*
VAL( 1 ) = ZERO
VAL( 2 ) = SQRT( SMLNUM )
VAL( 3 ) = ONE
VAL( 4 ) = TWO
VAL( 5 ) = SQRT( BIGNUM )
VAL( 6 ) = -SQRT( SMLNUM )
VAL( 7 ) = -ONE
VAL( 8 ) = -TWO
VAL( 9 ) = -SQRT( BIGNUM )
VM( 1 ) = ONE
VM( 2 ) = ONE + TWO*EPS
CALL SCOPY( 16, VAL( 4 ), 0, T( 1, 1 ), 1 )
*
NINFO( 1 ) = 0
NINFO( 2 ) = 0
KNT = 0
LMAX = 0
RMAX = ZERO
*
* Begin test loop
*
DO 40 IA = 1, 9
DO 30 IAM = 1, 2
DO 20 IB = 1, 9
DO 10 IC = 1, 9
T( 1, 1 ) = VAL( IA )*VM( IAM )
T( 2, 2 ) = VAL( IC )
T( 1, 2 ) = VAL( IB )
T( 2, 1 ) = ZERO
TNRM = MAX( ABS( T( 1, 1 ) ), ABS( T( 2, 2 ) ),
$ ABS( T( 1, 2 ) ) )
CALL SCOPY( 16, T, 1, T1, 1 )
CALL SCOPY( 16, VAL( 1 ), 0, Q, 1 )
CALL SCOPY( 4, VAL( 3 ), 0, Q, 5 )
CALL SLAEXC( .TRUE., 2, T, 4, Q, 4, 1, 1, 1, WORK,
$ INFO )
IF( INFO.NE.0 )
$ NINFO( INFO ) = NINFO( INFO ) + 1
CALL SHST01( 2, 1, 2, T1, 4, T, 4, Q, 4, WORK, LWORK,
$ RESULT )
RES = RESULT( 1 ) + RESULT( 2 )
IF( INFO.NE.0 )
$ RES = RES + ONE / EPS
IF( T( 1, 1 ).NE.T1( 2, 2 ) )
$ RES = RES + ONE / EPS
IF( T( 2, 2 ).NE.T1( 1, 1 ) )
$ RES = RES + ONE / EPS
IF( T( 2, 1 ).NE.ZERO )
$ RES = RES + ONE / EPS
KNT = KNT + 1
IF( RES.GT.RMAX ) THEN
LMAX = KNT
RMAX = RES
END IF
10 CONTINUE
20 CONTINUE
30 CONTINUE
40 CONTINUE
*
DO 110 IA = 1, 5
DO 100 IAM = 1, 2
DO 90 IB = 1, 5
DO 80 IC11 = 1, 5
DO 70 IC12 = 2, 5
DO 60 IC21 = 2, 4
DO 50 IC22 = -1, 1, 2
T( 1, 1 ) = VAL( IA )*VM( IAM )
T( 1, 2 ) = VAL( IB )
T( 1, 3 ) = -TWO*VAL( IB )
T( 2, 1 ) = ZERO
T( 2, 2 ) = VAL( IC11 )
T( 2, 3 ) = VAL( IC12 )
T( 3, 1 ) = ZERO
T( 3, 2 ) = -VAL( IC21 )
T( 3, 3 ) = VAL( IC11 )*REAL( IC22 )
TNRM = MAX( ABS( T( 1, 1 ) ),
$ ABS( T( 1, 2 ) ), ABS( T( 1, 3 ) ),
$ ABS( T( 2, 2 ) ), ABS( T( 2, 3 ) ),
$ ABS( T( 3, 2 ) ), ABS( T( 3, 3 ) ) )
CALL SCOPY( 16, T, 1, T1, 1 )
CALL SCOPY( 16, VAL( 1 ), 0, Q, 1 )
CALL SCOPY( 4, VAL( 3 ), 0, Q, 5 )
CALL SLAEXC( .TRUE., 3, T, 4, Q, 4, 1, 1, 2,
$ WORK, INFO )
IF( INFO.NE.0 )
$ NINFO( INFO ) = NINFO( INFO ) + 1
CALL SHST01( 3, 1, 3, T1, 4, T, 4, Q, 4,
$ WORK, LWORK, RESULT )
RES = RESULT( 1 ) + RESULT( 2 )
IF( INFO.EQ.0 ) THEN
IF( T1( 1, 1 ).NE.T( 3, 3 ) )
$ RES = RES + ONE / EPS
IF( T( 3, 1 ).NE.ZERO )
$ RES = RES + ONE / EPS
IF( T( 3, 2 ).NE.ZERO )
$ RES = RES + ONE / EPS
IF( T( 2, 1 ).NE.0 .AND.
$ ( T( 1, 1 ).NE.T( 2,
$ 2 ) .OR. SIGN( ONE, T( 1,
$ 2 ) ).EQ.SIGN( ONE, T( 2, 1 ) ) ) )
$ RES = RES + ONE / EPS
END IF
KNT = KNT + 1
IF( RES.GT.RMAX ) THEN
LMAX = KNT
RMAX = RES
END IF
50 CONTINUE
60 CONTINUE
70 CONTINUE
80 CONTINUE
90 CONTINUE
100 CONTINUE
110 CONTINUE
*
DO 180 IA11 = 1, 5
DO 170 IA12 = 2, 5
DO 160 IA21 = 2, 4
DO 150 IA22 = -1, 1, 2
DO 140 ICM = 1, 2
DO 130 IB = 1, 5
DO 120 IC = 1, 5
T( 1, 1 ) = VAL( IA11 )
T( 1, 2 ) = VAL( IA12 )
T( 1, 3 ) = -TWO*VAL( IB )
T( 2, 1 ) = -VAL( IA21 )
T( 2, 2 ) = VAL( IA11 )*REAL( IA22 )
T( 2, 3 ) = VAL( IB )
T( 3, 1 ) = ZERO
T( 3, 2 ) = ZERO
T( 3, 3 ) = VAL( IC )*VM( ICM )
TNRM = MAX( ABS( T( 1, 1 ) ),
$ ABS( T( 1, 2 ) ), ABS( T( 1, 3 ) ),
$ ABS( T( 2, 2 ) ), ABS( T( 2, 3 ) ),
$ ABS( T( 3, 2 ) ), ABS( T( 3, 3 ) ) )
CALL SCOPY( 16, T, 1, T1, 1 )
CALL SCOPY( 16, VAL( 1 ), 0, Q, 1 )
CALL SCOPY( 4, VAL( 3 ), 0, Q, 5 )
CALL SLAEXC( .TRUE., 3, T, 4, Q, 4, 1, 2, 1,
$ WORK, INFO )
IF( INFO.NE.0 )
$ NINFO( INFO ) = NINFO( INFO ) + 1
CALL SHST01( 3, 1, 3, T1, 4, T, 4, Q, 4,
$ WORK, LWORK, RESULT )
RES = RESULT( 1 ) + RESULT( 2 )
IF( INFO.EQ.0 ) THEN
IF( T1( 3, 3 ).NE.T( 1, 1 ) )
$ RES = RES + ONE / EPS
IF( T( 2, 1 ).NE.ZERO )
$ RES = RES + ONE / EPS
IF( T( 3, 1 ).NE.ZERO )
$ RES = RES + ONE / EPS
IF( T( 3, 2 ).NE.0 .AND.
$ ( T( 2, 2 ).NE.T( 3,
$ 3 ) .OR. SIGN( ONE, T( 2,
$ 3 ) ).EQ.SIGN( ONE, T( 3, 2 ) ) ) )
$ RES = RES + ONE / EPS
END IF
KNT = KNT + 1
IF( RES.GT.RMAX ) THEN
LMAX = KNT
RMAX = RES
END IF
120 CONTINUE
130 CONTINUE
140 CONTINUE
150 CONTINUE
160 CONTINUE
170 CONTINUE
180 CONTINUE
*
DO 300 IA11 = 1, 5
DO 290 IA12 = 2, 5
DO 280 IA21 = 2, 4
DO 270 IA22 = -1, 1, 2
DO 260 IB = 1, 5
DO 250 IC11 = 3, 4
DO 240 IC12 = 3, 4
DO 230 IC21 = 3, 4
DO 220 IC22 = -1, 1, 2
DO 210 ICM = 5, 7
IAM = 1
T( 1, 1 ) = VAL( IA11 )*VM( IAM )
T( 1, 2 ) = VAL( IA12 )*VM( IAM )
T( 1, 3 ) = -TWO*VAL( IB )
T( 1, 4 ) = HALF*VAL( IB )
T( 2, 1 ) = -T( 1, 2 )*VAL( IA21 )
T( 2, 2 ) = VAL( IA11 )*
$ REAL( IA22 )*VM( IAM )
T( 2, 3 ) = VAL( IB )
T( 2, 4 ) = THREE*VAL( IB )
T( 3, 1 ) = ZERO
T( 3, 2 ) = ZERO
T( 3, 3 ) = VAL( IC11 )*
$ ABS( VAL( ICM ) )
T( 3, 4 ) = VAL( IC12 )*
$ ABS( VAL( ICM ) )
T( 4, 1 ) = ZERO
T( 4, 2 ) = ZERO
T( 4, 3 ) = -T( 3, 4 )*VAL( IC21 )*
$ ABS( VAL( ICM ) )
T( 4, 4 ) = VAL( IC11 )*
$ REAL( IC22 )*
$ ABS( VAL( ICM ) )
TNRM = ZERO
DO 200 I = 1, 4
DO 190 J = 1, 4
TNRM = MAX( TNRM,
$ ABS( T( I, J ) ) )
190 CONTINUE
200 CONTINUE
CALL SCOPY( 16, T, 1, T1, 1 )
CALL SCOPY( 16, VAL( 1 ), 0, Q, 1 )
CALL SCOPY( 4, VAL( 3 ), 0, Q, 5 )
CALL SLAEXC( .TRUE., 4, T, 4, Q, 4,
$ 1, 2, 2, WORK, INFO )
IF( INFO.NE.0 )
$ NINFO( INFO ) = NINFO( INFO ) + 1
CALL SHST01( 4, 1, 4, T1, 4, T, 4,
$ Q, 4, WORK, LWORK,
$ RESULT )
RES = RESULT( 1 ) + RESULT( 2 )
IF( INFO.EQ.0 ) THEN
IF( T( 3, 1 ).NE.ZERO )
$ RES = RES + ONE / EPS
IF( T( 4, 1 ).NE.ZERO )
$ RES = RES + ONE / EPS
IF( T( 3, 2 ).NE.ZERO )
$ RES = RES + ONE / EPS
IF( T( 4, 2 ).NE.ZERO )
$ RES = RES + ONE / EPS
IF( T( 2, 1 ).NE.0 .AND.
$ ( T( 1, 1 ).NE.T( 2,
$ 2 ) .OR. SIGN( ONE, T( 1,
$ 2 ) ).EQ.SIGN( ONE, T( 2,
$ 1 ) ) ) )RES = RES +
$ ONE / EPS
IF( T( 4, 3 ).NE.0 .AND.
$ ( T( 3, 3 ).NE.T( 4,
$ 4 ) .OR. SIGN( ONE, T( 3,
$ 4 ) ).EQ.SIGN( ONE, T( 4,
$ 3 ) ) ) )RES = RES +
$ ONE / EPS
END IF
KNT = KNT + 1
IF( RES.GT.RMAX ) THEN
LMAX = KNT
RMAX = RES
END IF
210 CONTINUE
220 CONTINUE
230 CONTINUE
240 CONTINUE
250 CONTINUE
260 CONTINUE
270 CONTINUE
280 CONTINUE
290 CONTINUE
300 CONTINUE
*
RETURN
*
* End of SGET34
*
END
SUBROUTINE SGET35( RMAX, LMAX, NINFO, KNT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KNT, LMAX, NINFO
REAL RMAX
* ..
*
* Purpose
* =======
*
* SGET35 tests STRSYL, a routine for solving the Sylvester matrix
* equation
*
* op(A)*X + ISGN*X*op(B) = scale*C,
*
* A and B are assumed to be in Schur canonical form, op() represents an
* optional transpose, and ISGN can be -1 or +1. Scale is an output
* less than or equal to 1, chosen to avoid overflow in X.
*
* The test code verifies that the following residual is order 1:
*
* norm(op(A)*X + ISGN*X*op(B) - scale*C) /
* (EPS*max(norm(A),norm(B))*norm(X))
*
* Arguments
* ==========
*
* RMAX (output) REAL
* Value of the largest test ratio.
*
* LMAX (output) INTEGER
* Example number where largest test ratio achieved.
*
* NINFO (output) INTEGER
* Number of examples where INFO is nonzero.
*
* KNT (output) INTEGER
* Total number of examples tested.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
REAL TWO, FOUR
PARAMETER ( TWO = 2.0E0, FOUR = 4.0E0 )
* ..
* .. Local Scalars ..
CHARACTER TRANA, TRANB
INTEGER I, IMA, IMB, IMLDA1, IMLDA2, IMLDB1, IMLOFF,
$ INFO, ISGN, ITRANA, ITRANB, J, M, N
REAL BIGNUM, CNRM, EPS, RES, RES1, RMUL, SCALE,
$ SMLNUM, TNRM, XNRM
* ..
* .. Local Arrays ..
INTEGER IDIM( 8 ), IVAL( 6, 6, 8 )
REAL A( 6, 6 ), B( 6, 6 ), C( 6, 6 ), CC( 6, 6 ),
$ DUM( 1 ), VM1( 3 ), VM2( 3 )
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE
EXTERNAL SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, STRSYL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, REAL, SIN, SQRT
* ..
* .. Data statements ..
DATA IDIM / 1, 2, 3, 4, 3, 3, 6, 4 /
DATA IVAL / 1, 35*0, 1, 2, 4*0, -2, 0, 28*0, 1, 5*0,
$ 5, 1, 2, 3*0, -8, -2, 1, 21*0, 3, 4, 4*0, -5,
$ 3, 4*0, 1, 2, 1, 4, 2*0, -3, -9, -1, 1, 14*0,
$ 1, 5*0, 2, 3, 4*0, 5, 6, 7, 21*0, 1, 5*0, 1, 3,
$ -4, 3*0, 2, 5, 2, 21*0, 1, 2, 4*0, -2, 0, 4*0,
$ 5, 6, 3, 4, 2*0, -1, -9, -5, 2, 2*0, 4*8, 5, 6,
$ 4*9, -7, 5, 1, 5*0, 1, 5, 2, 3*0, 2, -21, 5,
$ 3*0, 1, 2, 3, 4, 14*0 /
* ..
* .. Executable Statements ..
*
* Get machine parameters
*
EPS = SLAMCH( 'P' )
SMLNUM = SLAMCH( 'S' )*FOUR / EPS
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
*
* Set up test case parameters
*
VM1( 1 ) = SQRT( SMLNUM )
VM1( 2 ) = ONE
VM1( 3 ) = SQRT( BIGNUM )
VM2( 1 ) = ONE
VM2( 2 ) = ONE + TWO*EPS
VM2( 3 ) = TWO
*
KNT = 0
NINFO = 0
LMAX = 0
RMAX = ZERO
*
* Begin test loop
*
DO 150 ITRANA = 1, 2
DO 140 ITRANB = 1, 2
DO 130 ISGN = -1, 1, 2
DO 120 IMA = 1, 8
DO 110 IMLDA1 = 1, 3
DO 100 IMLDA2 = 1, 3
DO 90 IMLOFF = 1, 2
DO 80 IMB = 1, 8
DO 70 IMLDB1 = 1, 3
IF( ITRANA.EQ.1 )
$ TRANA = 'N'
IF( ITRANA.EQ.2 )
$ TRANA = 'T'
IF( ITRANB.EQ.1 )
$ TRANB = 'N'
IF( ITRANB.EQ.2 )
$ TRANB = 'T'
M = IDIM( IMA )
N = IDIM( IMB )
TNRM = ZERO
DO 20 I = 1, M
DO 10 J = 1, M
A( I, J ) = IVAL( I, J, IMA )
IF( ABS( I-J ).LE.1 ) THEN
A( I, J ) = A( I, J )*
$ VM1( IMLDA1 )
A( I, J ) = A( I, J )*
$ VM2( IMLDA2 )
ELSE
A( I, J ) = A( I, J )*
$ VM1( IMLOFF )
END IF
TNRM = MAX( TNRM,
$ ABS( A( I, J ) ) )
10 CONTINUE
20 CONTINUE
DO 40 I = 1, N
DO 30 J = 1, N
B( I, J ) = IVAL( I, J, IMB )
IF( ABS( I-J ).LE.1 ) THEN
B( I, J ) = B( I, J )*
$ VM1( IMLDB1 )
ELSE
B( I, J ) = B( I, J )*
$ VM1( IMLOFF )
END IF
TNRM = MAX( TNRM,
$ ABS( B( I, J ) ) )
30 CONTINUE
40 CONTINUE
CNRM = ZERO
DO 60 I = 1, M
DO 50 J = 1, N
C( I, J ) = SIN( REAL( I*J ) )
CNRM = MAX( CNRM, C( I, J ) )
CC( I, J ) = C( I, J )
50 CONTINUE
60 CONTINUE
KNT = KNT + 1
CALL STRSYL( TRANA, TRANB, ISGN, M, N,
$ A, 6, B, 6, C, 6, SCALE,
$ INFO )
IF( INFO.NE.0 )
$ NINFO = NINFO + 1
XNRM = SLANGE( 'M', M, N, C, 6, DUM )
RMUL = ONE
IF( XNRM.GT.ONE .AND. TNRM.GT.ONE )
$ THEN
IF( XNRM.GT.BIGNUM / TNRM ) THEN
RMUL = ONE / MAX( XNRM, TNRM )
END IF
END IF
CALL SGEMM( TRANA, 'N', M, N, M, RMUL,
$ A, 6, C, 6, -SCALE*RMUL,
$ CC, 6 )
CALL SGEMM( 'N', TRANB, M, N, N,
$ REAL( ISGN )*RMUL, C, 6, B,
$ 6, ONE, CC, 6 )
RES1 = SLANGE( 'M', M, N, CC, 6, DUM )
RES = RES1 / MAX( SMLNUM, SMLNUM*XNRM,
$ ( ( RMUL*TNRM )*EPS )*XNRM )
IF( RES.GT.RMAX ) THEN
LMAX = KNT
RMAX = RES
END IF
70 CONTINUE
80 CONTINUE
90 CONTINUE
100 CONTINUE
110 CONTINUE
120 CONTINUE
130 CONTINUE
140 CONTINUE
150 CONTINUE
*
RETURN
*
* End of SGET35
*
END
SUBROUTINE SGET36( RMAX, LMAX, NINFO, KNT, NIN )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KNT, LMAX, NIN
REAL RMAX
* ..
* .. Array Arguments ..
INTEGER NINFO( 3 )
* ..
*
* Purpose
* =======
*
* SGET36 tests STREXC, a routine for moving blocks (either 1 by 1 or
* 2 by 2) on the diagonal of a matrix in real Schur form. Thus, SLAEXC
* computes an orthogonal matrix Q such that
*
* Q' * T1 * Q = T2
*
* and where one of the diagonal blocks of T1 (the one at row IFST) has
* been moved to position ILST.
*
* The test code verifies that the residual Q'*T1*Q-T2 is small, that T2
* is in Schur form, and that the final position of the IFST block is
* ILST (within +-1).
*
* The test matrices are read from a file with logical unit number NIN.
*
* Arguments
* ==========
*
* RMAX (output) REAL
* Value of the largest test ratio.
*
* LMAX (output) INTEGER
* Example number where largest test ratio achieved.
*
* NINFO (output) INTEGER array, dimension (3)
* NINFO(J) is the number of examples where INFO=J.
*
* KNT (output) INTEGER
* Total number of examples tested.
*
* NIN (input) INTEGER
* Input logical unit number.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
INTEGER LDT, LWORK
PARAMETER ( LDT = 10, LWORK = 2*LDT*LDT )
* ..
* .. Local Scalars ..
INTEGER I, IFST, IFST1, IFST2, IFSTSV, ILST, ILST1,
$ ILST2, ILSTSV, INFO1, INFO2, J, LOC, N
REAL EPS, RES
* ..
* .. Local Arrays ..
REAL Q( LDT, LDT ), RESULT( 2 ), T1( LDT, LDT ),
$ T2( LDT, LDT ), TMP( LDT, LDT ), WORK( LWORK )
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SHST01, SLACPY, SLASET, STREXC
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SIGN
* ..
* .. Executable Statements ..
*
EPS = SLAMCH( 'P' )
RMAX = ZERO
LMAX = 0
KNT = 0
NINFO( 1 ) = 0
NINFO( 2 ) = 0
NINFO( 3 ) = 0
*
* Read input data until N=0
*
10 CONTINUE
READ( NIN, FMT = * )N, IFST, ILST
IF( N.EQ.0 )
$ RETURN
KNT = KNT + 1
DO 20 I = 1, N
READ( NIN, FMT = * )( TMP( I, J ), J = 1, N )
20 CONTINUE
CALL SLACPY( 'F', N, N, TMP, LDT, T1, LDT )
CALL SLACPY( 'F', N, N, TMP, LDT, T2, LDT )
IFSTSV = IFST
ILSTSV = ILST
IFST1 = IFST
ILST1 = ILST
IFST2 = IFST
ILST2 = ILST
RES = ZERO
*
* Test without accumulating Q
*
CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDT )
CALL STREXC( 'N', N, T1, LDT, Q, LDT, IFST1, ILST1, WORK, INFO1 )
DO 40 I = 1, N
DO 30 J = 1, N
IF( I.EQ.J .AND. Q( I, J ).NE.ONE )
$ RES = RES + ONE / EPS
IF( I.NE.J .AND. Q( I, J ).NE.ZERO )
$ RES = RES + ONE / EPS
30 CONTINUE
40 CONTINUE
*
* Test with accumulating Q
*
CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDT )
CALL STREXC( 'V', N, T2, LDT, Q, LDT, IFST2, ILST2, WORK, INFO2 )
*
* Compare T1 with T2
*
DO 60 I = 1, N
DO 50 J = 1, N
IF( T1( I, J ).NE.T2( I, J ) )
$ RES = RES + ONE / EPS
50 CONTINUE
60 CONTINUE
IF( IFST1.NE.IFST2 )
$ RES = RES + ONE / EPS
IF( ILST1.NE.ILST2 )
$ RES = RES + ONE / EPS
IF( INFO1.NE.INFO2 )
$ RES = RES + ONE / EPS
*
* Test for successful reordering of T2
*
IF( INFO2.NE.0 ) THEN
NINFO( INFO2 ) = NINFO( INFO2 ) + 1
ELSE
IF( ABS( IFST2-IFSTSV ).GT.1 )
$ RES = RES + ONE / EPS
IF( ABS( ILST2-ILSTSV ).GT.1 )
$ RES = RES + ONE / EPS
END IF
*
* Test for small residual, and orthogonality of Q
*
CALL SHST01( N, 1, N, TMP, LDT, T2, LDT, Q, LDT, WORK, LWORK,
$ RESULT )
RES = RES + RESULT( 1 ) + RESULT( 2 )
*
* Test for T2 being in Schur form
*
LOC = 1
70 CONTINUE
IF( T2( LOC+1, LOC ).NE.ZERO ) THEN
*
* 2 by 2 block
*
IF( T2( LOC, LOC+1 ).EQ.ZERO .OR. T2( LOC, LOC ).NE.
$ T2( LOC+1, LOC+1 ) .OR. SIGN( ONE, T2( LOC, LOC+1 ) ).EQ.
$ SIGN( ONE, T2( LOC+1, LOC ) ) )RES = RES + ONE / EPS
DO 80 I = LOC + 2, N
IF( T2( I, LOC ).NE.ZERO )
$ RES = RES + ONE / RES
IF( T2( I, LOC+1 ).NE.ZERO )
$ RES = RES + ONE / RES
80 CONTINUE
LOC = LOC + 2
ELSE
*
* 1 by 1 block
*
DO 90 I = LOC + 1, N
IF( T2( I, LOC ).NE.ZERO )
$ RES = RES + ONE / RES
90 CONTINUE
LOC = LOC + 1
END IF
IF( LOC.LT.N )
$ GO TO 70
IF( RES.GT.RMAX ) THEN
RMAX = RES
LMAX = KNT
END IF
GO TO 10
*
* End of SGET36
*
END
SUBROUTINE SGET37( RMAX, LMAX, NINFO, KNT, NIN )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KNT, NIN
* ..
* .. Array Arguments ..
INTEGER LMAX( 3 ), NINFO( 3 )
REAL RMAX( 3 )
* ..
*
* Purpose
* =======
*
* SGET37 tests STRSNA, a routine for estimating condition numbers of
* eigenvalues and/or right eigenvectors of a matrix.
*
* The test matrices are read from a file with logical unit number NIN.
*
* Arguments
* ==========
*
* RMAX (output) REAL array, dimension (3)
* Value of the largest test ratio.
* RMAX(1) = largest ratio comparing different calls to STRSNA
* RMAX(2) = largest error in reciprocal condition
* numbers taking their conditioning into account
* RMAX(3) = largest error in reciprocal condition
* numbers not taking their conditioning into
* account (may be larger than RMAX(2))
*
* LMAX (output) INTEGER array, dimension (3)
* LMAX(i) is example number where largest test ratio
* RMAX(i) is achieved. Also:
* If SGEHRD returns INFO nonzero on example i, LMAX(1)=i
* If SHSEQR returns INFO nonzero on example i, LMAX(2)=i
* If STRSNA returns INFO nonzero on example i, LMAX(3)=i
*
* NINFO (output) INTEGER array, dimension (3)
* NINFO(1) = No. of times SGEHRD returned INFO nonzero
* NINFO(2) = No. of times SHSEQR returned INFO nonzero
* NINFO(3) = No. of times STRSNA returned INFO nonzero
*
* KNT (output) INTEGER
* Total number of examples tested.
*
* NIN (input) INTEGER
* Input logical unit number
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 )
REAL EPSIN
PARAMETER ( EPSIN = 5.9605E-8 )
INTEGER LDT, LWORK
PARAMETER ( LDT = 20, LWORK = 2*LDT*( 10+LDT ) )
* ..
* .. Local Scalars ..
INTEGER I, ICMP, IFND, INFO, ISCL, J, KMIN, M, N
REAL BIGNUM, EPS, SMLNUM, TNRM, TOL, TOLIN, V,
$ VIMIN, VMAX, VMUL, VRMIN
* ..
* .. Local Arrays ..
LOGICAL SELECT( LDT )
INTEGER IWORK( 2*LDT ), LCMP( 3 )
REAL DUM( 1 ), LE( LDT, LDT ), RE( LDT, LDT ),
$ S( LDT ), SEP( LDT ), SEPIN( LDT ),
$ SEPTMP( LDT ), SIN( LDT ), STMP( LDT ),
$ T( LDT, LDT ), TMP( LDT, LDT ), VAL( 3 ),
$ WI( LDT ), WIIN( LDT ), WITMP( LDT ),
$ WORK( LWORK ), WR( LDT ), WRIN( LDT ),
$ WRTMP( LDT )
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE
EXTERNAL SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEHRD, SHSEQR, SLABAD, SLACPY, SSCAL,
$ STREVC, STRSNA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, REAL, SQRT
* ..
* .. Executable Statements ..
*
EPS = SLAMCH( 'P' )
SMLNUM = SLAMCH( 'S' ) / EPS
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
*
* EPSIN = 2**(-24) = precision to which input data computed
*
EPS = MAX( EPS, EPSIN )
RMAX( 1 ) = ZERO
RMAX( 2 ) = ZERO
RMAX( 3 ) = ZERO
LMAX( 1 ) = 0
LMAX( 2 ) = 0
LMAX( 3 ) = 0
KNT = 0
NINFO( 1 ) = 0
NINFO( 2 ) = 0
NINFO( 3 ) = 0
*
VAL( 1 ) = SQRT( SMLNUM )
VAL( 2 ) = ONE
VAL( 3 ) = SQRT( BIGNUM )
*
* Read input data until N=0. Assume input eigenvalues are sorted
* lexicographically (increasing by real part, then decreasing by
* imaginary part)
*
10 CONTINUE
READ( NIN, FMT = * )N
IF( N.EQ.0 )
$ RETURN
DO 20 I = 1, N
READ( NIN, FMT = * )( TMP( I, J ), J = 1, N )
20 CONTINUE
DO 30 I = 1, N
READ( NIN, FMT = * )WRIN( I ), WIIN( I ), SIN( I ), SEPIN( I )
30 CONTINUE
TNRM = SLANGE( 'M', N, N, TMP, LDT, WORK )
*
* Begin test
*
DO 240 ISCL = 1, 3
*
* Scale input matrix
*
KNT = KNT + 1
CALL SLACPY( 'F', N, N, TMP, LDT, T, LDT )
VMUL = VAL( ISCL )
DO 40 I = 1, N
CALL SSCAL( N, VMUL, T( 1, I ), 1 )
40 CONTINUE
IF( TNRM.EQ.ZERO )
$ VMUL = ONE
*
* Compute eigenvalues and eigenvectors
*
CALL SGEHRD( N, 1, N, T, LDT, WORK( 1 ), WORK( N+1 ), LWORK-N,
$ INFO )
IF( INFO.NE.0 ) THEN
LMAX( 1 ) = KNT
NINFO( 1 ) = NINFO( 1 ) + 1
GO TO 240
END IF
DO 60 J = 1, N - 2
DO 50 I = J + 2, N
T( I, J ) = ZERO
50 CONTINUE
60 CONTINUE
*
* Compute Schur form
*
CALL SHSEQR( 'S', 'N', N, 1, N, T, LDT, WR, WI, DUM, 1, WORK,
$ LWORK, INFO )
IF( INFO.NE.0 ) THEN
LMAX( 2 ) = KNT
NINFO( 2 ) = NINFO( 2 ) + 1
GO TO 240
END IF
*
* Compute eigenvectors
*
CALL STREVC( 'Both', 'All', SELECT, N, T, LDT, LE, LDT, RE,
$ LDT, N, M, WORK, INFO )
*
* Compute condition numbers
*
CALL STRSNA( 'Both', 'All', SELECT, N, T, LDT, LE, LDT, RE,
$ LDT, S, SEP, N, M, WORK, N, IWORK, INFO )
IF( INFO.NE.0 ) THEN
LMAX( 3 ) = KNT
NINFO( 3 ) = NINFO( 3 ) + 1
GO TO 240
END IF
*
* Sort eigenvalues and condition numbers lexicographically
* to compare with inputs
*
CALL SCOPY( N, WR, 1, WRTMP, 1 )
CALL SCOPY( N, WI, 1, WITMP, 1 )
CALL SCOPY( N, S, 1, STMP, 1 )
CALL SCOPY( N, SEP, 1, SEPTMP, 1 )
CALL SSCAL( N, ONE / VMUL, SEPTMP, 1 )
DO 80 I = 1, N - 1
KMIN = I
VRMIN = WRTMP( I )
VIMIN = WITMP( I )
DO 70 J = I + 1, N
IF( WRTMP( J ).LT.VRMIN ) THEN
KMIN = J
VRMIN = WRTMP( J )
VIMIN = WITMP( J )
END IF
70 CONTINUE
WRTMP( KMIN ) = WRTMP( I )
WITMP( KMIN ) = WITMP( I )
WRTMP( I ) = VRMIN
WITMP( I ) = VIMIN
VRMIN = STMP( KMIN )
STMP( KMIN ) = STMP( I )
STMP( I ) = VRMIN
VRMIN = SEPTMP( KMIN )
SEPTMP( KMIN ) = SEPTMP( I )
SEPTMP( I ) = VRMIN
80 CONTINUE
*
* Compare condition numbers for eigenvalues
* taking their condition numbers into account
*
V = MAX( TWO*REAL( N )*EPS*TNRM, SMLNUM )
IF( TNRM.EQ.ZERO )
$ V = ONE
DO 90 I = 1, N
IF( V.GT.SEPTMP( I ) ) THEN
TOL = ONE
ELSE
TOL = V / SEPTMP( I )
END IF
IF( V.GT.SEPIN( I ) ) THEN
TOLIN = ONE
ELSE
TOLIN = V / SEPIN( I )
END IF
TOL = MAX( TOL, SMLNUM / EPS )
TOLIN = MAX( TOLIN, SMLNUM / EPS )
IF( EPS*( SIN( I )-TOLIN ).GT.STMP( I )+TOL ) THEN
VMAX = ONE / EPS
ELSE IF( SIN( I )-TOLIN.GT.STMP( I )+TOL ) THEN
VMAX = ( SIN( I )-TOLIN ) / ( STMP( I )+TOL )
ELSE IF( SIN( I )+TOLIN.LT.EPS*( STMP( I )-TOL ) ) THEN
VMAX = ONE / EPS
ELSE IF( SIN( I )+TOLIN.LT.STMP( I )-TOL ) THEN
VMAX = ( STMP( I )-TOL ) / ( SIN( I )+TOLIN )
ELSE
VMAX = ONE
END IF
IF( VMAX.GT.RMAX( 2 ) ) THEN
RMAX( 2 ) = VMAX
IF( NINFO( 2 ).EQ.0 )
$ LMAX( 2 ) = KNT
END IF
90 CONTINUE
*
* Compare condition numbers for eigenvectors
* taking their condition numbers into account
*
DO 100 I = 1, N
IF( V.GT.SEPTMP( I )*STMP( I ) ) THEN
TOL = SEPTMP( I )
ELSE
TOL = V / STMP( I )
END IF
IF( V.GT.SEPIN( I )*SIN( I ) ) THEN
TOLIN = SEPIN( I )
ELSE
TOLIN = V / SIN( I )
END IF
TOL = MAX( TOL, SMLNUM / EPS )
TOLIN = MAX( TOLIN, SMLNUM / EPS )
IF( EPS*( SEPIN( I )-TOLIN ).GT.SEPTMP( I )+TOL ) THEN
VMAX = ONE / EPS
ELSE IF( SEPIN( I )-TOLIN.GT.SEPTMP( I )+TOL ) THEN
VMAX = ( SEPIN( I )-TOLIN ) / ( SEPTMP( I )+TOL )
ELSE IF( SEPIN( I )+TOLIN.LT.EPS*( SEPTMP( I )-TOL ) ) THEN
VMAX = ONE / EPS
ELSE IF( SEPIN( I )+TOLIN.LT.SEPTMP( I )-TOL ) THEN
VMAX = ( SEPTMP( I )-TOL ) / ( SEPIN( I )+TOLIN )
ELSE
VMAX = ONE
END IF
IF( VMAX.GT.RMAX( 2 ) ) THEN
RMAX( 2 ) = VMAX
IF( NINFO( 2 ).EQ.0 )
$ LMAX( 2 ) = KNT
END IF
100 CONTINUE
*
* Compare condition numbers for eigenvalues
* without taking their condition numbers into account
*
DO 110 I = 1, N
IF( SIN( I ).LE.REAL( 2*N )*EPS .AND. STMP( I ).LE.
$ REAL( 2*N )*EPS ) THEN
VMAX = ONE
ELSE IF( EPS*SIN( I ).GT.STMP( I ) ) THEN
VMAX = ONE / EPS
ELSE IF( SIN( I ).GT.STMP( I ) ) THEN
VMAX = SIN( I ) / STMP( I )
ELSE IF( SIN( I ).LT.EPS*STMP( I ) ) THEN
VMAX = ONE / EPS
ELSE IF( SIN( I ).LT.STMP( I ) ) THEN
VMAX = STMP( I ) / SIN( I )
ELSE
VMAX = ONE
END IF
IF( VMAX.GT.RMAX( 3 ) ) THEN
RMAX( 3 ) = VMAX
IF( NINFO( 3 ).EQ.0 )
$ LMAX( 3 ) = KNT
END IF
110 CONTINUE
*
* Compare condition numbers for eigenvectors
* without taking their condition numbers into account
*
DO 120 I = 1, N
IF( SEPIN( I ).LE.V .AND. SEPTMP( I ).LE.V ) THEN
VMAX = ONE
ELSE IF( EPS*SEPIN( I ).GT.SEPTMP( I ) ) THEN
VMAX = ONE / EPS
ELSE IF( SEPIN( I ).GT.SEPTMP( I ) ) THEN
VMAX = SEPIN( I ) / SEPTMP( I )
ELSE IF( SEPIN( I ).LT.EPS*SEPTMP( I ) ) THEN
VMAX = ONE / EPS
ELSE IF( SEPIN( I ).LT.SEPTMP( I ) ) THEN
VMAX = SEPTMP( I ) / SEPIN( I )
ELSE
VMAX = ONE
END IF
IF( VMAX.GT.RMAX( 3 ) ) THEN
RMAX( 3 ) = VMAX
IF( NINFO( 3 ).EQ.0 )
$ LMAX( 3 ) = KNT
END IF
120 CONTINUE
*
* Compute eigenvalue condition numbers only and compare
*
VMAX = ZERO
DUM( 1 ) = -ONE
CALL SCOPY( N, DUM, 0, STMP, 1 )
CALL SCOPY( N, DUM, 0, SEPTMP, 1 )
CALL STRSNA( 'Eigcond', 'All', SELECT, N, T, LDT, LE, LDT, RE,
$ LDT, STMP, SEPTMP, N, M, WORK, N, IWORK, INFO )
IF( INFO.NE.0 ) THEN
LMAX( 3 ) = KNT
NINFO( 3 ) = NINFO( 3 ) + 1
GO TO 240
END IF
DO 130 I = 1, N
IF( STMP( I ).NE.S( I ) )
$ VMAX = ONE / EPS
IF( SEPTMP( I ).NE.DUM( 1 ) )
$ VMAX = ONE / EPS
130 CONTINUE
*
* Compute eigenvector condition numbers only and compare
*
CALL SCOPY( N, DUM, 0, STMP, 1 )
CALL SCOPY( N, DUM, 0, SEPTMP, 1 )
CALL STRSNA( 'Veccond', 'All', SELECT, N, T, LDT, LE, LDT, RE,
$ LDT, STMP, SEPTMP, N, M, WORK, N, IWORK, INFO )
IF( INFO.NE.0 ) THEN
LMAX( 3 ) = KNT
NINFO( 3 ) = NINFO( 3 ) + 1
GO TO 240
END IF
DO 140 I = 1, N
IF( STMP( I ).NE.DUM( 1 ) )
$ VMAX = ONE / EPS
IF( SEPTMP( I ).NE.SEP( I ) )
$ VMAX = ONE / EPS
140 CONTINUE
*
* Compute all condition numbers using SELECT and compare
*
DO 150 I = 1, N
SELECT( I ) = .TRUE.
150 CONTINUE
CALL SCOPY( N, DUM, 0, STMP, 1 )
CALL SCOPY( N, DUM, 0, SEPTMP, 1 )
CALL STRSNA( 'Bothcond', 'Some', SELECT, N, T, LDT, LE, LDT,
$ RE, LDT, STMP, SEPTMP, N, M, WORK, N, IWORK,
$ INFO )
IF( INFO.NE.0 ) THEN
LMAX( 3 ) = KNT
NINFO( 3 ) = NINFO( 3 ) + 1
GO TO 240
END IF
DO 160 I = 1, N
IF( SEPTMP( I ).NE.SEP( I ) )
$ VMAX = ONE / EPS
IF( STMP( I ).NE.S( I ) )
$ VMAX = ONE / EPS
160 CONTINUE
*
* Compute eigenvalue condition numbers using SELECT and compare
*
CALL SCOPY( N, DUM, 0, STMP, 1 )
CALL SCOPY( N, DUM, 0, SEPTMP, 1 )
CALL STRSNA( 'Eigcond', 'Some', SELECT, N, T, LDT, LE, LDT, RE,
$ LDT, STMP, SEPTMP, N, M, WORK, N, IWORK, INFO )
IF( INFO.NE.0 ) THEN
LMAX( 3 ) = KNT
NINFO( 3 ) = NINFO( 3 ) + 1
GO TO 240
END IF
DO 170 I = 1, N
IF( STMP( I ).NE.S( I ) )
$ VMAX = ONE / EPS
IF( SEPTMP( I ).NE.DUM( 1 ) )
$ VMAX = ONE / EPS
170 CONTINUE
*
* Compute eigenvector condition numbers using SELECT and compare
*
CALL SCOPY( N, DUM, 0, STMP, 1 )
CALL SCOPY( N, DUM, 0, SEPTMP, 1 )
CALL STRSNA( 'Veccond', 'Some', SELECT, N, T, LDT, LE, LDT, RE,
$ LDT, STMP, SEPTMP, N, M, WORK, N, IWORK, INFO )
IF( INFO.NE.0 ) THEN
LMAX( 3 ) = KNT
NINFO( 3 ) = NINFO( 3 ) + 1
GO TO 240
END IF
DO 180 I = 1, N
IF( STMP( I ).NE.DUM( 1 ) )
$ VMAX = ONE / EPS
IF( SEPTMP( I ).NE.SEP( I ) )
$ VMAX = ONE / EPS
180 CONTINUE
IF( VMAX.GT.RMAX( 1 ) ) THEN
RMAX( 1 ) = VMAX
IF( NINFO( 1 ).EQ.0 )
$ LMAX( 1 ) = KNT
END IF
*
* Select first real and first complex eigenvalue
*
IF( WI( 1 ).EQ.ZERO ) THEN
LCMP( 1 ) = 1
IFND = 0
DO 190 I = 2, N
IF( IFND.EQ.1 .OR. WI( I ).EQ.ZERO ) THEN
SELECT( I ) = .FALSE.
ELSE
IFND = 1
LCMP( 2 ) = I
LCMP( 3 ) = I + 1
CALL SCOPY( N, RE( 1, I ), 1, RE( 1, 2 ), 1 )
CALL SCOPY( N, RE( 1, I+1 ), 1, RE( 1, 3 ), 1 )
CALL SCOPY( N, LE( 1, I ), 1, LE( 1, 2 ), 1 )
CALL SCOPY( N, LE( 1, I+1 ), 1, LE( 1, 3 ), 1 )
END IF
190 CONTINUE
IF( IFND.EQ.0 ) THEN
ICMP = 1
ELSE
ICMP = 3
END IF
ELSE
LCMP( 1 ) = 1
LCMP( 2 ) = 2
IFND = 0
DO 200 I = 3, N
IF( IFND.EQ.1 .OR. WI( I ).NE.ZERO ) THEN
SELECT( I ) = .FALSE.
ELSE
LCMP( 3 ) = I
IFND = 1
CALL SCOPY( N, RE( 1, I ), 1, RE( 1, 3 ), 1 )
CALL SCOPY( N, LE( 1, I ), 1, LE( 1, 3 ), 1 )
END IF
200 CONTINUE
IF( IFND.EQ.0 ) THEN
ICMP = 2
ELSE
ICMP = 3
END IF
END IF
*
* Compute all selected condition numbers
*
CALL SCOPY( ICMP, DUM, 0, STMP, 1 )
CALL SCOPY( ICMP, DUM, 0, SEPTMP, 1 )
CALL STRSNA( 'Bothcond', 'Some', SELECT, N, T, LDT, LE, LDT,
$ RE, LDT, STMP, SEPTMP, N, M, WORK, N, IWORK,
$ INFO )
IF( INFO.NE.0 ) THEN
LMAX( 3 ) = KNT
NINFO( 3 ) = NINFO( 3 ) + 1
GO TO 240
END IF
DO 210 I = 1, ICMP
J = LCMP( I )
IF( SEPTMP( I ).NE.SEP( J ) )
$ VMAX = ONE / EPS
IF( STMP( I ).NE.S( J ) )
$ VMAX = ONE / EPS
210 CONTINUE
*
* Compute selected eigenvalue condition numbers
*
CALL SCOPY( ICMP, DUM, 0, STMP, 1 )
CALL SCOPY( ICMP, DUM, 0, SEPTMP, 1 )
CALL STRSNA( 'Eigcond', 'Some', SELECT, N, T, LDT, LE, LDT, RE,
$ LDT, STMP, SEPTMP, N, M, WORK, N, IWORK, INFO )
IF( INFO.NE.0 ) THEN
LMAX( 3 ) = KNT
NINFO( 3 ) = NINFO( 3 ) + 1
GO TO 240
END IF
DO 220 I = 1, ICMP
J = LCMP( I )
IF( STMP( I ).NE.S( J ) )
$ VMAX = ONE / EPS
IF( SEPTMP( I ).NE.DUM( 1 ) )
$ VMAX = ONE / EPS
220 CONTINUE
*
* Compute selected eigenvector condition numbers
*
CALL SCOPY( ICMP, DUM, 0, STMP, 1 )
CALL SCOPY( ICMP, DUM, 0, SEPTMP, 1 )
CALL STRSNA( 'Veccond', 'Some', SELECT, N, T, LDT, LE, LDT, RE,
$ LDT, STMP, SEPTMP, N, M, WORK, N, IWORK, INFO )
IF( INFO.NE.0 ) THEN
LMAX( 3 ) = KNT
NINFO( 3 ) = NINFO( 3 ) + 1
GO TO 240
END IF
DO 230 I = 1, ICMP
J = LCMP( I )
IF( STMP( I ).NE.DUM( 1 ) )
$ VMAX = ONE / EPS
IF( SEPTMP( I ).NE.SEP( J ) )
$ VMAX = ONE / EPS
230 CONTINUE
IF( VMAX.GT.RMAX( 1 ) ) THEN
RMAX( 1 ) = VMAX
IF( NINFO( 1 ).EQ.0 )
$ LMAX( 1 ) = KNT
END IF
240 CONTINUE
GO TO 10
*
* End of SGET37
*
END
SUBROUTINE SGET38( RMAX, LMAX, NINFO, KNT, NIN )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KNT, NIN
* ..
* .. Array Arguments ..
INTEGER LMAX( 3 ), NINFO( 3 )
REAL RMAX( 3 )
* ..
*
* Purpose
* =======
*
* SGET38 tests STRSEN, a routine for estimating condition numbers of a
* cluster of eigenvalues and/or its associated right invariant subspace
*
* The test matrices are read from a file with logical unit number NIN.
*
* Arguments
* ==========
*
* RMAX (output) REAL array, dimension (3)
* Values of the largest test ratios.
* RMAX(1) = largest residuals from SHST01 or comparing
* different calls to STRSEN
* RMAX(2) = largest error in reciprocal condition
* numbers taking their conditioning into account
* RMAX(3) = largest error in reciprocal condition
* numbers not taking their conditioning into
* account (may be larger than RMAX(2))
*
* LMAX (output) INTEGER array, dimension (3)
* LMAX(i) is example number where largest test ratio
* RMAX(i) is achieved. Also:
* If SGEHRD returns INFO nonzero on example i, LMAX(1)=i
* If SHSEQR returns INFO nonzero on example i, LMAX(2)=i
* If STRSEN returns INFO nonzero on example i, LMAX(3)=i
*
* NINFO (output) INTEGER array, dimension (3)
* NINFO(1) = No. of times SGEHRD returned INFO nonzero
* NINFO(2) = No. of times SHSEQR returned INFO nonzero
* NINFO(3) = No. of times STRSEN returned INFO nonzero
*
* KNT (output) INTEGER
* Total number of examples tested.
*
* NIN (input) INTEGER
* Input logical unit number.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 )
REAL EPSIN
PARAMETER ( EPSIN = 5.9605E-8 )
INTEGER LDT, LWORK
PARAMETER ( LDT = 20, LWORK = 2*LDT*( 10+LDT ) )
INTEGER LIWORK
PARAMETER ( LIWORK = LDT*LDT )
* ..
* .. Local Scalars ..
INTEGER I, INFO, ISCL, ITMP, J, KMIN, M, N, NDIM
REAL BIGNUM, EPS, S, SEP, SEPIN, SEPTMP, SIN,
$ SMLNUM, STMP, TNRM, TOL, TOLIN, V, VIMIN, VMAX,
$ VMUL, VRMIN
* ..
* .. Local Arrays ..
LOGICAL SELECT( LDT )
INTEGER IPNT( LDT ), ISELEC( LDT ), IWORK( LIWORK )
REAL Q( LDT, LDT ), QSAV( LDT, LDT ),
$ QTMP( LDT, LDT ), RESULT( 2 ), T( LDT, LDT ),
$ TMP( LDT, LDT ), TSAV( LDT, LDT ),
$ TSAV1( LDT, LDT ), TTMP( LDT, LDT ), VAL( 3 ),
$ WI( LDT ), WITMP( LDT ), WORK( LWORK ),
$ WR( LDT ), WRTMP( LDT )
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE
EXTERNAL SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEHRD, SHSEQR, SHST01, SLABAD, SLACPY,
$ SORGHR, SSCAL, STRSEN
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, REAL, SQRT
* ..
* .. Executable Statements ..
*
EPS = SLAMCH( 'P' )
SMLNUM = SLAMCH( 'S' ) / EPS
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
*
* EPSIN = 2**(-24) = precision to which input data computed
*
EPS = MAX( EPS, EPSIN )
RMAX( 1 ) = ZERO
RMAX( 2 ) = ZERO
RMAX( 3 ) = ZERO
LMAX( 1 ) = 0
LMAX( 2 ) = 0
LMAX( 3 ) = 0
KNT = 0
NINFO( 1 ) = 0
NINFO( 2 ) = 0
NINFO( 3 ) = 0
*
VAL( 1 ) = SQRT( SMLNUM )
VAL( 2 ) = ONE
VAL( 3 ) = SQRT( SQRT( BIGNUM ) )
*
* Read input data until N=0. Assume input eigenvalues are sorted
* lexicographically (increasing by real part, then decreasing by
* imaginary part)
*
10 CONTINUE
READ( NIN, FMT = * )N, NDIM
IF( N.EQ.0 )
$ RETURN
READ( NIN, FMT = * )( ISELEC( I ), I = 1, NDIM )
DO 20 I = 1, N
READ( NIN, FMT = * )( TMP( I, J ), J = 1, N )
20 CONTINUE
READ( NIN, FMT = * )SIN, SEPIN
*
TNRM = SLANGE( 'M', N, N, TMP, LDT, WORK )
DO 160 ISCL = 1, 3
*
* Scale input matrix
*
KNT = KNT + 1
CALL SLACPY( 'F', N, N, TMP, LDT, T, LDT )
VMUL = VAL( ISCL )
DO 30 I = 1, N
CALL SSCAL( N, VMUL, T( 1, I ), 1 )
30 CONTINUE
IF( TNRM.EQ.ZERO )
$ VMUL = ONE
CALL SLACPY( 'F', N, N, T, LDT, TSAV, LDT )
*
* Compute Schur form
*
CALL SGEHRD( N, 1, N, T, LDT, WORK( 1 ), WORK( N+1 ), LWORK-N,
$ INFO )
IF( INFO.NE.0 ) THEN
LMAX( 1 ) = KNT
NINFO( 1 ) = NINFO( 1 ) + 1
GO TO 160
END IF
*
* Generate orthogonal matrix
*
CALL SLACPY( 'L', N, N, T, LDT, Q, LDT )
CALL SORGHR( N, 1, N, Q, LDT, WORK( 1 ), WORK( N+1 ), LWORK-N,
$ INFO )
*
* Compute Schur form
*
CALL SHSEQR( 'S', 'V', N, 1, N, T, LDT, WR, WI, Q, LDT, WORK,
$ LWORK, INFO )
IF( INFO.NE.0 ) THEN
LMAX( 2 ) = KNT
NINFO( 2 ) = NINFO( 2 ) + 1
GO TO 160
END IF
*
* Sort, select eigenvalues
*
DO 40 I = 1, N
IPNT( I ) = I
SELECT( I ) = .FALSE.
40 CONTINUE
CALL SCOPY( N, WR, 1, WRTMP, 1 )
CALL SCOPY( N, WI, 1, WITMP, 1 )
DO 60 I = 1, N - 1
KMIN = I
VRMIN = WRTMP( I )
VIMIN = WITMP( I )
DO 50 J = I + 1, N
IF( WRTMP( J ).LT.VRMIN ) THEN
KMIN = J
VRMIN = WRTMP( J )
VIMIN = WITMP( J )
END IF
50 CONTINUE
WRTMP( KMIN ) = WRTMP( I )
WITMP( KMIN ) = WITMP( I )
WRTMP( I ) = VRMIN
WITMP( I ) = VIMIN
ITMP = IPNT( I )
IPNT( I ) = IPNT( KMIN )
IPNT( KMIN ) = ITMP
60 CONTINUE
DO 70 I = 1, NDIM
SELECT( IPNT( ISELEC( I ) ) ) = .TRUE.
70 CONTINUE
*
* Compute condition numbers
*
CALL SLACPY( 'F', N, N, Q, LDT, QSAV, LDT )
CALL SLACPY( 'F', N, N, T, LDT, TSAV1, LDT )
CALL STRSEN( 'B', 'V', SELECT, N, T, LDT, Q, LDT, WRTMP, WITMP,
$ M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO )
IF( INFO.NE.0 ) THEN
LMAX( 3 ) = KNT
NINFO( 3 ) = NINFO( 3 ) + 1
GO TO 160
END IF
SEPTMP = SEP / VMUL
STMP = S
*
* Compute residuals
*
CALL SHST01( N, 1, N, TSAV, LDT, T, LDT, Q, LDT, WORK, LWORK,
$ RESULT )
VMAX = MAX( RESULT( 1 ), RESULT( 2 ) )
IF( VMAX.GT.RMAX( 1 ) ) THEN
RMAX( 1 ) = VMAX
IF( NINFO( 1 ).EQ.0 )
$ LMAX( 1 ) = KNT
END IF
*
* Compare condition number for eigenvalue cluster
* taking its condition number into account
*
V = MAX( TWO*REAL( N )*EPS*TNRM, SMLNUM )
IF( TNRM.EQ.ZERO )
$ V = ONE
IF( V.GT.SEPTMP ) THEN
TOL = ONE
ELSE
TOL = V / SEPTMP
END IF
IF( V.GT.SEPIN ) THEN
TOLIN = ONE
ELSE
TOLIN = V / SEPIN
END IF
TOL = MAX( TOL, SMLNUM / EPS )
TOLIN = MAX( TOLIN, SMLNUM / EPS )
IF( EPS*( SIN-TOLIN ).GT.STMP+TOL ) THEN
VMAX = ONE / EPS
ELSE IF( SIN-TOLIN.GT.STMP+TOL ) THEN
VMAX = ( SIN-TOLIN ) / ( STMP+TOL )
ELSE IF( SIN+TOLIN.LT.EPS*( STMP-TOL ) ) THEN
VMAX = ONE / EPS
ELSE IF( SIN+TOLIN.LT.STMP-TOL ) THEN
VMAX = ( STMP-TOL ) / ( SIN+TOLIN )
ELSE
VMAX = ONE
END IF
IF( VMAX.GT.RMAX( 2 ) ) THEN
RMAX( 2 ) = VMAX
IF( NINFO( 2 ).EQ.0 )
$ LMAX( 2 ) = KNT
END IF
*
* Compare condition numbers for invariant subspace
* taking its condition number into account
*
IF( V.GT.SEPTMP*STMP ) THEN
TOL = SEPTMP
ELSE
TOL = V / STMP
END IF
IF( V.GT.SEPIN*SIN ) THEN
TOLIN = SEPIN
ELSE
TOLIN = V / SIN
END IF
TOL = MAX( TOL, SMLNUM / EPS )
TOLIN = MAX( TOLIN, SMLNUM / EPS )
IF( EPS*( SEPIN-TOLIN ).GT.SEPTMP+TOL ) THEN
VMAX = ONE / EPS
ELSE IF( SEPIN-TOLIN.GT.SEPTMP+TOL ) THEN
VMAX = ( SEPIN-TOLIN ) / ( SEPTMP+TOL )
ELSE IF( SEPIN+TOLIN.LT.EPS*( SEPTMP-TOL ) ) THEN
VMAX = ONE / EPS
ELSE IF( SEPIN+TOLIN.LT.SEPTMP-TOL ) THEN
VMAX = ( SEPTMP-TOL ) / ( SEPIN+TOLIN )
ELSE
VMAX = ONE
END IF
IF( VMAX.GT.RMAX( 2 ) ) THEN
RMAX( 2 ) = VMAX
IF( NINFO( 2 ).EQ.0 )
$ LMAX( 2 ) = KNT
END IF
*
* Compare condition number for eigenvalue cluster
* without taking its condition number into account
*
IF( SIN.LE.REAL( 2*N )*EPS .AND. STMP.LE.REAL( 2*N )*EPS ) THEN
VMAX = ONE
ELSE IF( EPS*SIN.GT.STMP ) THEN
VMAX = ONE / EPS
ELSE IF( SIN.GT.STMP ) THEN
VMAX = SIN / STMP
ELSE IF( SIN.LT.EPS*STMP ) THEN
VMAX = ONE / EPS
ELSE IF( SIN.LT.STMP ) THEN
VMAX = STMP / SIN
ELSE
VMAX = ONE
END IF
IF( VMAX.GT.RMAX( 3 ) ) THEN
RMAX( 3 ) = VMAX
IF( NINFO( 3 ).EQ.0 )
$ LMAX( 3 ) = KNT
END IF
*
* Compare condition numbers for invariant subspace
* without taking its condition number into account
*
IF( SEPIN.LE.V .AND. SEPTMP.LE.V ) THEN
VMAX = ONE
ELSE IF( EPS*SEPIN.GT.SEPTMP ) THEN
VMAX = ONE / EPS
ELSE IF( SEPIN.GT.SEPTMP ) THEN
VMAX = SEPIN / SEPTMP
ELSE IF( SEPIN.LT.EPS*SEPTMP ) THEN
VMAX = ONE / EPS
ELSE IF( SEPIN.LT.SEPTMP ) THEN
VMAX = SEPTMP / SEPIN
ELSE
VMAX = ONE
END IF
IF( VMAX.GT.RMAX( 3 ) ) THEN
RMAX( 3 ) = VMAX
IF( NINFO( 3 ).EQ.0 )
$ LMAX( 3 ) = KNT
END IF
*
* Compute eigenvalue condition number only and compare
* Update Q
*
VMAX = ZERO
CALL SLACPY( 'F', N, N, TSAV1, LDT, TTMP, LDT )
CALL SLACPY( 'F', N, N, QSAV, LDT, QTMP, LDT )
SEPTMP = -ONE
STMP = -ONE
CALL STRSEN( 'E', 'V', SELECT, N, TTMP, LDT, QTMP, LDT, WRTMP,
$ WITMP, M, STMP, SEPTMP, WORK, LWORK, IWORK,
$ LIWORK, INFO )
IF( INFO.NE.0 ) THEN
LMAX( 3 ) = KNT
NINFO( 3 ) = NINFO( 3 ) + 1
GO TO 160
END IF
IF( S.NE.STMP )
$ VMAX = ONE / EPS
IF( -ONE.NE.SEPTMP )
$ VMAX = ONE / EPS
DO 90 I = 1, N
DO 80 J = 1, N
IF( TTMP( I, J ).NE.T( I, J ) )
$ VMAX = ONE / EPS
IF( QTMP( I, J ).NE.Q( I, J ) )
$ VMAX = ONE / EPS
80 CONTINUE
90 CONTINUE
*
* Compute invariant subspace condition number only and compare
* Update Q
*
CALL SLACPY( 'F', N, N, TSAV1, LDT, TTMP, LDT )
CALL SLACPY( 'F', N, N, QSAV, LDT, QTMP, LDT )
SEPTMP = -ONE
STMP = -ONE
CALL STRSEN( 'V', 'V', SELECT, N, TTMP, LDT, QTMP, LDT, WRTMP,
$ WITMP, M, STMP, SEPTMP, WORK, LWORK, IWORK,
$ LIWORK, INFO )
IF( INFO.NE.0 ) THEN
LMAX( 3 ) = KNT
NINFO( 3 ) = NINFO( 3 ) + 1
GO TO 160
END IF
IF( -ONE.NE.STMP )
$ VMAX = ONE / EPS
IF( SEP.NE.SEPTMP )
$ VMAX = ONE / EPS
DO 110 I = 1, N
DO 100 J = 1, N
IF( TTMP( I, J ).NE.T( I, J ) )
$ VMAX = ONE / EPS
IF( QTMP( I, J ).NE.Q( I, J ) )
$ VMAX = ONE / EPS
100 CONTINUE
110 CONTINUE
*
* Compute eigenvalue condition number only and compare
* Do not update Q
*
CALL SLACPY( 'F', N, N, TSAV1, LDT, TTMP, LDT )
CALL SLACPY( 'F', N, N, QSAV, LDT, QTMP, LDT )
SEPTMP = -ONE
STMP = -ONE
CALL STRSEN( 'E', 'N', SELECT, N, TTMP, LDT, QTMP, LDT, WRTMP,
$ WITMP, M, STMP, SEPTMP, WORK, LWORK, IWORK,
$ LIWORK, INFO )
IF( INFO.NE.0 ) THEN
LMAX( 3 ) = KNT
NINFO( 3 ) = NINFO( 3 ) + 1
GO TO 160
END IF
IF( S.NE.STMP )
$ VMAX = ONE / EPS
IF( -ONE.NE.SEPTMP )
$ VMAX = ONE / EPS
DO 130 I = 1, N
DO 120 J = 1, N
IF( TTMP( I, J ).NE.T( I, J ) )
$ VMAX = ONE / EPS
IF( QTMP( I, J ).NE.QSAV( I, J ) )
$ VMAX = ONE / EPS
120 CONTINUE
130 CONTINUE
*
* Compute invariant subspace condition number only and compare
* Do not update Q
*
CALL SLACPY( 'F', N, N, TSAV1, LDT, TTMP, LDT )
CALL SLACPY( 'F', N, N, QSAV, LDT, QTMP, LDT )
SEPTMP = -ONE
STMP = -ONE
CALL STRSEN( 'V', 'N', SELECT, N, TTMP, LDT, QTMP, LDT, WRTMP,
$ WITMP, M, STMP, SEPTMP, WORK, LWORK, IWORK,
$ LIWORK, INFO )
IF( INFO.NE.0 ) THEN
LMAX( 3 ) = KNT
NINFO( 3 ) = NINFO( 3 ) + 1
GO TO 160
END IF
IF( -ONE.NE.STMP )
$ VMAX = ONE / EPS
IF( SEP.NE.SEPTMP )
$ VMAX = ONE / EPS
DO 150 I = 1, N
DO 140 J = 1, N
IF( TTMP( I, J ).NE.T( I, J ) )
$ VMAX = ONE / EPS
IF( QTMP( I, J ).NE.QSAV( I, J ) )
$ VMAX = ONE / EPS
140 CONTINUE
150 CONTINUE
IF( VMAX.GT.RMAX( 1 ) ) THEN
RMAX( 1 ) = VMAX
IF( NINFO( 1 ).EQ.0 )
$ LMAX( 1 ) = KNT
END IF
160 CONTINUE
GO TO 10
*
* End of SGET38
*
END
SUBROUTINE SGET39( RMAX, LMAX, NINFO, KNT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KNT, LMAX, NINFO
REAL RMAX
* ..
*
* Purpose
* =======
*
* SGET39 tests SLAQTR, a routine for solving the real or
* special complex quasi upper triangular system
*
* op(T)*p = scale*c,
* or
* op(T + iB)*(p+iq) = scale*(c+id),
*
* in real arithmetic. T is upper quasi-triangular.
* If it is complex, then the first diagonal block of T must be
* 1 by 1, B has the special structure
*
* B = [ b(1) b(2) ... b(n) ]
* [ w ]
* [ w ]
* [ . ]
* [ w ]
*
* op(A) = A or A', where A' denotes the conjugate transpose of
* the matrix A.
*
* On input, X = [ c ]. On output, X = [ p ].
* [ d ] [ q ]
*
* Scale is an output less than or equal to 1, chosen to avoid
* overflow in X.
* This subroutine is specially designed for the condition number
* estimation in the eigenproblem routine STRSNA.
*
* The test code verifies that the following residual is order 1:
*
* ||(T+i*B)*(x1+i*x2) - scale*(d1+i*d2)||
* -----------------------------------------
* max(ulp*(||T||+||B||)*(||x1||+||x2||),
* (||T||+||B||)*smlnum/ulp,
* smlnum)
*
* (The (||T||+||B||)*smlnum/ulp term accounts for possible
* (gradual or nongradual) underflow in x1 and x2.)
*
* Arguments
* ==========
*
* RMAX (output) REAL
* Value of the largest test ratio.
*
* LMAX (output) INTEGER
* Example number where largest test ratio achieved.
*
* NINFO (output) INTEGER
* Number of examples where INFO is nonzero.
*
* KNT (output) INTEGER
* Total number of examples tested.
*
* =====================================================================
*
* .. Parameters ..
INTEGER LDT, LDT2
PARAMETER ( LDT = 10, LDT2 = 2*LDT )
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0, ONE = 1.0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, IVM1, IVM2, IVM3, IVM4, IVM5, J, K, N,
$ NDIM
REAL BIGNUM, DOMIN, DUMM, EPS, NORM, NORMTB, RESID,
$ SCALE, SMLNUM, W, XNORM
* ..
* .. External Functions ..
INTEGER ISAMAX
REAL SASUM, SDOT, SLAMCH, SLANGE
EXTERNAL ISAMAX, SASUM, SDOT, SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMV, SLABAD, SLAQTR
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, COS, MAX, REAL, SIN, SQRT
* ..
* .. Local Arrays ..
INTEGER IDIM( 6 ), IVAL( 5, 5, 6 )
REAL B( LDT ), D( LDT2 ), DUM( 1 ), T( LDT, LDT ),
$ VM1( 5 ), VM2( 5 ), VM3( 5 ), VM4( 5 ),
$ VM5( 3 ), WORK( LDT ), X( LDT2 ), Y( LDT2 )
* ..
* .. Data statements ..
DATA IDIM / 4, 5*5 /
DATA IVAL / 3, 4*0, 1, 1, -1, 0, 0, 3, 2, 1, 0, 0,
$ 4, 3, 2, 2, 0, 5*0, 1, 4*0, 2, 2, 3*0, 3, 3, 4,
$ 0, 0, 4, 2, 2, 3, 0, 4*1, 5, 1, 4*0, 2, 4, -2,
$ 0, 0, 3, 3, 4, 0, 0, 4, 2, 2, 3, 0, 5*1, 1,
$ 4*0, 2, 1, -1, 0, 0, 9, 8, 1, 0, 0, 4, 9, 1, 2,
$ -1, 5*2, 9, 4*0, 6, 4, 0, 0, 0, 3, 2, 1, 1, 0,
$ 5, 1, -1, 1, 0, 5*2, 4, 4*0, 2, 2, 0, 0, 0, 1,
$ 4, 4, 0, 0, 2, 4, 2, 2, -1, 5*2 /
* ..
* .. Executable Statements ..
*
* Get machine parameters
*
EPS = SLAMCH( 'P' )
SMLNUM = SLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
*
* Set up test case parameters
*
VM1( 1 ) = ONE
VM1( 2 ) = SQRT( SMLNUM )
VM1( 3 ) = SQRT( VM1( 2 ) )
VM1( 4 ) = SQRT( BIGNUM )
VM1( 5 ) = SQRT( VM1( 4 ) )
*
VM2( 1 ) = ONE
VM2( 2 ) = SQRT( SMLNUM )
VM2( 3 ) = SQRT( VM2( 2 ) )
VM2( 4 ) = SQRT( BIGNUM )
VM2( 5 ) = SQRT( VM2( 4 ) )
*
VM3( 1 ) = ONE
VM3( 2 ) = SQRT( SMLNUM )
VM3( 3 ) = SQRT( VM3( 2 ) )
VM3( 4 ) = SQRT( BIGNUM )
VM3( 5 ) = SQRT( VM3( 4 ) )
*
VM4( 1 ) = ONE
VM4( 2 ) = SQRT( SMLNUM )
VM4( 3 ) = SQRT( VM4( 2 ) )
VM4( 4 ) = SQRT( BIGNUM )
VM4( 5 ) = SQRT( VM4( 4 ) )
*
VM5( 1 ) = ONE
VM5( 2 ) = EPS
VM5( 3 ) = SQRT( SMLNUM )
*
* Initalization
*
KNT = 0
RMAX = ZERO
NINFO = 0
SMLNUM = SMLNUM / EPS
*
* Begin test loop
*
DO 140 IVM5 = 1, 3
DO 130 IVM4 = 1, 5
DO 120 IVM3 = 1, 5
DO 110 IVM2 = 1, 5
DO 100 IVM1 = 1, 5
DO 90 NDIM = 1, 6
*
N = IDIM( NDIM )
DO 20 I = 1, N
DO 10 J = 1, N
T( I, J ) = REAL( IVAL( I, J, NDIM ) )*
$ VM1( IVM1 )
IF( I.GE.J )
$ T( I, J ) = T( I, J )*VM5( IVM5 )
10 CONTINUE
20 CONTINUE
*
W = ONE*VM2( IVM2 )
*
DO 30 I = 1, N
B( I ) = COS( REAL( I ) )*VM3( IVM3 )
30 CONTINUE
*
DO 40 I = 1, 2*N
D( I ) = SIN( REAL( I ) )*VM4( IVM4 )
40 CONTINUE
*
NORM = SLANGE( '1', N, N, T, LDT, WORK )
K = ISAMAX( N, B, 1 )
NORMTB = NORM + ABS( B( K ) ) + ABS( W )
*
CALL SCOPY( N, D, 1, X, 1 )
KNT = KNT + 1
CALL SLAQTR( .FALSE., .TRUE., N, T, LDT, DUM,
$ DUMM, SCALE, X, WORK, INFO )
IF( INFO.NE.0 )
$ NINFO = NINFO + 1
*
* || T*x - scale*d || /
* max(ulp*||T||*||x||,smlnum/ulp*||T||,smlnum)
*
CALL SCOPY( N, D, 1, Y, 1 )
CALL SGEMV( 'No transpose', N, N, ONE, T, LDT,
$ X, 1, -SCALE, Y, 1 )
XNORM = SASUM( N, X, 1 )
RESID = SASUM( N, Y, 1 )
DOMIN = MAX( SMLNUM, ( SMLNUM / EPS )*NORM,
$ ( NORM*EPS )*XNORM )
RESID = RESID / DOMIN
IF( RESID.GT.RMAX ) THEN
RMAX = RESID
LMAX = KNT
END IF
*
CALL SCOPY( N, D, 1, X, 1 )
KNT = KNT + 1
CALL SLAQTR( .TRUE., .TRUE., N, T, LDT, DUM,
$ DUMM, SCALE, X, WORK, INFO )
IF( INFO.NE.0 )
$ NINFO = NINFO + 1
*
* || T*x - scale*d || /
* max(ulp*||T||*||x||,smlnum/ulp*||T||,smlnum)
*
CALL SCOPY( N, D, 1, Y, 1 )
CALL SGEMV( 'Transpose', N, N, ONE, T, LDT, X,
$ 1, -SCALE, Y, 1 )
XNORM = SASUM( N, X, 1 )
RESID = SASUM( N, Y, 1 )
DOMIN = MAX( SMLNUM, ( SMLNUM / EPS )*NORM,
$ ( NORM*EPS )*XNORM )
RESID = RESID / DOMIN
IF( RESID.GT.RMAX ) THEN
RMAX = RESID
LMAX = KNT
END IF
*
CALL SCOPY( 2*N, D, 1, X, 1 )
KNT = KNT + 1
CALL SLAQTR( .FALSE., .FALSE., N, T, LDT, B, W,
$ SCALE, X, WORK, INFO )
IF( INFO.NE.0 )
$ NINFO = NINFO + 1
*
* ||(T+i*B)*(x1+i*x2) - scale*(d1+i*d2)|| /
* max(ulp*(||T||+||B||)*(||x1||+||x2||),
* smlnum/ulp * (||T||+||B||), smlnum )
*
*
CALL SCOPY( 2*N, D, 1, Y, 1 )
Y( 1 ) = SDOT( N, B, 1, X( 1+N ), 1 ) +
$ SCALE*Y( 1 )
DO 50 I = 2, N
Y( I ) = W*X( I+N ) + SCALE*Y( I )
50 CONTINUE
CALL SGEMV( 'No transpose', N, N, ONE, T, LDT,
$ X, 1, -ONE, Y, 1 )
*
Y( 1+N ) = SDOT( N, B, 1, X, 1 ) -
$ SCALE*Y( 1+N )
DO 60 I = 2, N
Y( I+N ) = W*X( I ) - SCALE*Y( I+N )
60 CONTINUE
CALL SGEMV( 'No transpose', N, N, ONE, T, LDT,
$ X( 1+N ), 1, ONE, Y( 1+N ), 1 )
*
RESID = SASUM( 2*N, Y, 1 )
DOMIN = MAX( SMLNUM, ( SMLNUM / EPS )*NORMTB,
$ EPS*( NORMTB*SASUM( 2*N, X, 1 ) ) )
RESID = RESID / DOMIN
IF( RESID.GT.RMAX ) THEN
RMAX = RESID
LMAX = KNT
END IF
*
CALL SCOPY( 2*N, D, 1, X, 1 )
KNT = KNT + 1
CALL SLAQTR( .TRUE., .FALSE., N, T, LDT, B, W,
$ SCALE, X, WORK, INFO )
IF( INFO.NE.0 )
$ NINFO = NINFO + 1
*
* ||(T+i*B)*(x1+i*x2) - scale*(d1+i*d2)|| /
* max(ulp*(||T||+||B||)*(||x1||+||x2||),
* smlnum/ulp * (||T||+||B||), smlnum )
*
CALL SCOPY( 2*N, D, 1, Y, 1 )
Y( 1 ) = B( 1 )*X( 1+N ) - SCALE*Y( 1 )
DO 70 I = 2, N
Y( I ) = B( I )*X( 1+N ) + W*X( I+N ) -
$ SCALE*Y( I )
70 CONTINUE
CALL SGEMV( 'Transpose', N, N, ONE, T, LDT, X,
$ 1, ONE, Y, 1 )
*
Y( 1+N ) = B( 1 )*X( 1 ) + SCALE*Y( 1+N )
DO 80 I = 2, N
Y( I+N ) = B( I )*X( 1 ) + W*X( I ) +
$ SCALE*Y( I+N )
80 CONTINUE
CALL SGEMV( 'Transpose', N, N, ONE, T, LDT,
$ X( 1+N ), 1, -ONE, Y( 1+N ), 1 )
*
RESID = SASUM( 2*N, Y, 1 )
DOMIN = MAX( SMLNUM, ( SMLNUM / EPS )*NORMTB,
$ EPS*( NORMTB*SASUM( 2*N, X, 1 ) ) )
RESID = RESID / DOMIN
IF( RESID.GT.RMAX ) THEN
RMAX = RESID
LMAX = KNT
END IF
*
90 CONTINUE
100 CONTINUE
110 CONTINUE
120 CONTINUE
130 CONTINUE
140 CONTINUE
*
RETURN
*
* End of SGET39
*
END
SUBROUTINE SGET51( ITYPE, N, A, LDA, B, LDB, U, LDU, V, LDV, WORK,
$ RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER ITYPE, LDA, LDB, LDU, LDV, N
REAL RESULT
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), U( LDU, * ),
$ V( LDV, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGET51 generally checks a decomposition of the form
*
* A = U B V'
*
* where ' means transpose and U and V are orthogonal.
*
* Specifically, if ITYPE=1
*
* RESULT = | A - U B V' | / ( |A| n ulp )
*
* If ITYPE=2, then:
*
* RESULT = | A - B | / ( |A| n ulp )
*
* If ITYPE=3, then:
*
* RESULT = | I - UU' | / ( n ulp )
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* Specifies the type of tests to be performed.
* =1: RESULT = | A - U B V' | / ( |A| n ulp )
* =2: RESULT = | A - B | / ( |A| n ulp )
* =3: RESULT = | I - UU' | / ( n ulp )
*
* N (input) INTEGER
* The size of the matrix. If it is zero, SGET51 does nothing.
* It must be at least zero.
*
* A (input) REAL array, dimension (LDA, N)
* The original (unfactored) matrix.
*
* LDA (input) INTEGER
* The leading dimension of A. It must be at least 1
* and at least N.
*
* B (input) REAL array, dimension (LDB, N)
* The factored matrix.
*
* LDB (input) INTEGER
* The leading dimension of B. It must be at least 1
* and at least N.
*
* U (input) REAL array, dimension (LDU, N)
* The orthogonal matrix on the left-hand side in the
* decomposition.
* Not referenced if ITYPE=2
*
* LDU (input) INTEGER
* The leading dimension of U. LDU must be at least N and
* at least 1.
*
* V (input) REAL array, dimension (LDV, N)
* The orthogonal matrix on the left-hand side in the
* decomposition.
* Not referenced if ITYPE=2
*
* LDV (input) INTEGER
* The leading dimension of V. LDV must be at least N and
* at least 1.
*
* WORK (workspace) REAL array, dimension (2*N**2)
*
* RESULT (output) REAL
* The values computed by the test specified by ITYPE. The
* value is currently limited to 1/ulp, to avoid overflow.
* Errors are flagged by RESULT=10/ulp.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TEN
PARAMETER ( ZERO = 0.0, ONE = 1.0E0, TEN = 10.0E0 )
* ..
* .. Local Scalars ..
INTEGER JCOL, JDIAG, JROW
REAL ANORM, ULP, UNFL, WNORM
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE
EXTERNAL SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SLACPY
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Executable Statements ..
*
RESULT = ZERO
IF( N.LE.0 )
$ RETURN
*
* Constants
*
UNFL = SLAMCH( 'Safe minimum' )
ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
*
* Some Error Checks
*
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
RESULT = TEN / ULP
RETURN
END IF
*
IF( ITYPE.LE.2 ) THEN
*
* Tests scaled by the norm(A)
*
ANORM = MAX( SLANGE( '1', N, N, A, LDA, WORK ), UNFL )
*
IF( ITYPE.EQ.1 ) THEN
*
* ITYPE=1: Compute W = A - UBV'
*
CALL SLACPY( ' ', N, N, A, LDA, WORK, N )
CALL SGEMM( 'N', 'N', N, N, N, ONE, U, LDU, B, LDB, ZERO,
$ WORK( N**2+1 ), N )
*
CALL SGEMM( 'N', 'C', N, N, N, -ONE, WORK( N**2+1 ), N, V,
$ LDV, ONE, WORK, N )
*
ELSE
*
* ITYPE=2: Compute W = A - B
*
CALL SLACPY( ' ', N, N, B, LDB, WORK, N )
*
DO 20 JCOL = 1, N
DO 10 JROW = 1, N
WORK( JROW+N*( JCOL-1 ) ) = WORK( JROW+N*( JCOL-1 ) )
$ - A( JROW, JCOL )
10 CONTINUE
20 CONTINUE
END IF
*
* Compute norm(W)/ ( ulp*norm(A) )
*
WNORM = SLANGE( '1', N, N, WORK, N, WORK( N**2+1 ) )
*
IF( ANORM.GT.WNORM ) THEN
RESULT = ( WNORM / ANORM ) / ( N*ULP )
ELSE
IF( ANORM.LT.ONE ) THEN
RESULT = ( MIN( WNORM, N*ANORM ) / ANORM ) / ( N*ULP )
ELSE
RESULT = MIN( WNORM / ANORM, REAL( N ) ) / ( N*ULP )
END IF
END IF
*
ELSE
*
* Tests not scaled by norm(A)
*
* ITYPE=3: Compute UU' - I
*
CALL SGEMM( 'N', 'C', N, N, N, ONE, U, LDU, U, LDU, ZERO, WORK,
$ N )
*
DO 30 JDIAG = 1, N
WORK( ( N+1 )*( JDIAG-1 )+1 ) = WORK( ( N+1 )*( JDIAG-1 )+
$ 1 ) - ONE
30 CONTINUE
*
RESULT = MIN( SLANGE( '1', N, N, WORK, N, WORK( N**2+1 ) ),
$ REAL( N ) ) / ( N*ULP )
END IF
*
RETURN
*
* End of SGET51
*
END
SUBROUTINE SGET52( LEFT, N, A, LDA, B, LDB, E, LDE, ALPHAR,
$ ALPHAI, BETA, WORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL LEFT
INTEGER LDA, LDB, LDE, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
$ B( LDB, * ), BETA( * ), E( LDE, * ),
$ RESULT( 2 ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGET52 does an eigenvector check for the generalized eigenvalue
* problem.
*
* The basic test for right eigenvectors is:
*
* | b(j) A E(j) - a(j) B E(j) |
* RESULT(1) = max -------------------------------
* j n ulp max( |b(j) A|, |a(j) B| )
*
* using the 1-norm. Here, a(j)/b(j) = w is the j-th generalized
* eigenvalue of A - w B, or, equivalently, b(j)/a(j) = m is the j-th
* generalized eigenvalue of m A - B.
*
* For real eigenvalues, the test is straightforward. For complex
* eigenvalues, E(j) and a(j) are complex, represented by
* Er(j) + i*Ei(j) and ar(j) + i*ai(j), resp., so the test for that
* eigenvector becomes
*
* max( |Wr|, |Wi| )
* --------------------------------------------
* n ulp max( |b(j) A|, (|ar(j)|+|ai(j)|) |B| )
*
* where
*
* Wr = b(j) A Er(j) - ar(j) B Er(j) + ai(j) B Ei(j)
*
* Wi = b(j) A Ei(j) - ai(j) B Er(j) - ar(j) B Ei(j)
*
* T T _
* For left eigenvectors, A , B , a, and b are used.
*
* SGET52 also tests the normalization of E. Each eigenvector is
* supposed to be normalized so that the maximum "absolute value"
* of its elements is 1, where in this case, "absolute value"
* of a complex value x is |Re(x)| + |Im(x)| ; let us call this
* maximum "absolute value" norm of a vector v M(v).
* if a(j)=b(j)=0, then the eigenvector is set to be the jth coordinate
* vector. The normalization test is:
*
* RESULT(2) = max | M(v(j)) - 1 | / ( n ulp )
* eigenvectors v(j)
*
* Arguments
* =========
*
* LEFT (input) LOGICAL
* =.TRUE.: The eigenvectors in the columns of E are assumed
* to be *left* eigenvectors.
* =.FALSE.: The eigenvectors in the columns of E are assumed
* to be *right* eigenvectors.
*
* N (input) INTEGER
* The size of the matrices. If it is zero, SGET52 does
* nothing. It must be at least zero.
*
* A (input) REAL array, dimension (LDA, N)
* The matrix A.
*
* LDA (input) INTEGER
* The leading dimension of A. It must be at least 1
* and at least N.
*
* B (input) REAL array, dimension (LDB, N)
* The matrix B.
*
* LDB (input) INTEGER
* The leading dimension of B. It must be at least 1
* and at least N.
*
* E (input) REAL array, dimension (LDE, N)
* The matrix of eigenvectors. It must be O( 1 ). Complex
* eigenvalues and eigenvectors always come in pairs, the
* eigenvalue and its conjugate being stored in adjacent
* elements of ALPHAR, ALPHAI, and BETA. Thus, if a(j)/b(j)
* and a(j+1)/b(j+1) are a complex conjugate pair of
* generalized eigenvalues, then E(,j) contains the real part
* of the eigenvector and E(,j+1) contains the imaginary part.
* Note that whether E(,j) is a real eigenvector or part of a
* complex one is specified by whether ALPHAI(j) is zero or not.
*
* LDE (input) INTEGER
* The leading dimension of E. It must be at least 1 and at
* least N.
*
* ALPHAR (input) REAL array, dimension (N)
* The real parts of the values a(j) as described above, which,
* along with b(j), define the generalized eigenvalues.
* Complex eigenvalues always come in complex conjugate pairs
* a(j)/b(j) and a(j+1)/b(j+1), which are stored in adjacent
* elements in ALPHAR, ALPHAI, and BETA. Thus, if the j-th
* and (j+1)-st eigenvalues form a pair, ALPHAR(j+1)/BETA(j+1)
* is assumed to be equal to ALPHAR(j)/BETA(j).
*
* ALPHAI (input) REAL array, dimension (N)
* The imaginary parts of the values a(j) as described above,
* which, along with b(j), define the generalized eigenvalues.
* If ALPHAI(j)=0, then the eigenvalue is real, otherwise it
* is part of a complex conjugate pair. Complex eigenvalues
* always come in complex conjugate pairs a(j)/b(j) and
* a(j+1)/b(j+1), which are stored in adjacent elements in
* ALPHAR, ALPHAI, and BETA. Thus, if the j-th and (j+1)-st
* eigenvalues form a pair, ALPHAI(j+1)/BETA(j+1) is assumed to
* be equal to -ALPHAI(j)/BETA(j). Also, nonzero values in
* ALPHAI are assumed to always come in adjacent pairs.
*
* BETA (input) REAL array, dimension (N)
* The values b(j) as described above, which, along with a(j),
* define the generalized eigenvalues.
*
* WORK (workspace) REAL array, dimension (N**2+N)
*
* RESULT (output) REAL array, dimension (2)
* The values computed by the test described above. If A E or
* B E is likely to overflow, then RESULT(1:2) is set to
* 10 / ulp.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TEN
PARAMETER ( ZERO = 0.0, ONE = 1.0, TEN = 10.0 )
* ..
* .. Local Scalars ..
LOGICAL ILCPLX
CHARACTER NORMAB, TRANS
INTEGER J, JVEC
REAL ABMAX, ACOEF, ALFMAX, ANORM, BCOEFI, BCOEFR,
$ BETMAX, BNORM, ENORM, ENRMER, ERRNRM, SAFMAX,
$ SAFMIN, SALFI, SALFR, SBETA, SCALE, TEMP1, ULP
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE
EXTERNAL SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SGEMV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, REAL
* ..
* .. Executable Statements ..
*
RESULT( 1 ) = ZERO
RESULT( 2 ) = ZERO
IF( N.LE.0 )
$ RETURN
*
SAFMIN = SLAMCH( 'Safe minimum' )
SAFMAX = ONE / SAFMIN
ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
*
IF( LEFT ) THEN
TRANS = 'T'
NORMAB = 'I'
ELSE
TRANS = 'N'
NORMAB = 'O'
END IF
*
* Norm of A, B, and E:
*
ANORM = MAX( SLANGE( NORMAB, N, N, A, LDA, WORK ), SAFMIN )
BNORM = MAX( SLANGE( NORMAB, N, N, B, LDB, WORK ), SAFMIN )
ENORM = MAX( SLANGE( 'O', N, N, E, LDE, WORK ), ULP )
ALFMAX = SAFMAX / MAX( ONE, BNORM )
BETMAX = SAFMAX / MAX( ONE, ANORM )
*
* Compute error matrix.
* Column i = ( b(i) A - a(i) B ) E(i) / max( |a(i) B| |b(i) A| )
*
ILCPLX = .FALSE.
DO 10 JVEC = 1, N
IF( ILCPLX ) THEN
*
* 2nd Eigenvalue/-vector of pair -- do nothing
*
ILCPLX = .FALSE.
ELSE
SALFR = ALPHAR( JVEC )
SALFI = ALPHAI( JVEC )
SBETA = BETA( JVEC )
IF( SALFI.EQ.ZERO ) THEN
*
* Real eigenvalue and -vector
*
ABMAX = MAX( ABS( SALFR ), ABS( SBETA ) )
IF( ABS( SALFR ).GT.ALFMAX .OR. ABS( SBETA ).GT.
$ BETMAX .OR. ABMAX.LT.ONE ) THEN
SCALE = ONE / MAX( ABMAX, SAFMIN )
SALFR = SCALE*SALFR
SBETA = SCALE*SBETA
END IF
SCALE = ONE / MAX( ABS( SALFR )*BNORM,
$ ABS( SBETA )*ANORM, SAFMIN )
ACOEF = SCALE*SBETA
BCOEFR = SCALE*SALFR
CALL SGEMV( TRANS, N, N, ACOEF, A, LDA, E( 1, JVEC ), 1,
$ ZERO, WORK( N*( JVEC-1 )+1 ), 1 )
CALL SGEMV( TRANS, N, N, -BCOEFR, B, LDA, E( 1, JVEC ),
$ 1, ONE, WORK( N*( JVEC-1 )+1 ), 1 )
ELSE
*
* Complex conjugate pair
*
ILCPLX = .TRUE.
IF( JVEC.EQ.N ) THEN
RESULT( 1 ) = TEN / ULP
RETURN
END IF
ABMAX = MAX( ABS( SALFR )+ABS( SALFI ), ABS( SBETA ) )
IF( ABS( SALFR )+ABS( SALFI ).GT.ALFMAX .OR.
$ ABS( SBETA ).GT.BETMAX .OR. ABMAX.LT.ONE ) THEN
SCALE = ONE / MAX( ABMAX, SAFMIN )
SALFR = SCALE*SALFR
SALFI = SCALE*SALFI
SBETA = SCALE*SBETA
END IF
SCALE = ONE / MAX( ( ABS( SALFR )+ABS( SALFI ) )*BNORM,
$ ABS( SBETA )*ANORM, SAFMIN )
ACOEF = SCALE*SBETA
BCOEFR = SCALE*SALFR
BCOEFI = SCALE*SALFI
IF( LEFT ) THEN
BCOEFI = -BCOEFI
END IF
*
CALL SGEMV( TRANS, N, N, ACOEF, A, LDA, E( 1, JVEC ), 1,
$ ZERO, WORK( N*( JVEC-1 )+1 ), 1 )
CALL SGEMV( TRANS, N, N, -BCOEFR, B, LDA, E( 1, JVEC ),
$ 1, ONE, WORK( N*( JVEC-1 )+1 ), 1 )
CALL SGEMV( TRANS, N, N, BCOEFI, B, LDA, E( 1, JVEC+1 ),
$ 1, ONE, WORK( N*( JVEC-1 )+1 ), 1 )
*
CALL SGEMV( TRANS, N, N, ACOEF, A, LDA, E( 1, JVEC+1 ),
$ 1, ZERO, WORK( N*JVEC+1 ), 1 )
CALL SGEMV( TRANS, N, N, -BCOEFI, B, LDA, E( 1, JVEC ),
$ 1, ONE, WORK( N*JVEC+1 ), 1 )
CALL SGEMV( TRANS, N, N, -BCOEFR, B, LDA, E( 1, JVEC+1 ),
$ 1, ONE, WORK( N*JVEC+1 ), 1 )
END IF
END IF
10 CONTINUE
*
ERRNRM = SLANGE( 'One', N, N, WORK, N, WORK( N**2+1 ) ) / ENORM
*
* Compute RESULT(1)
*
RESULT( 1 ) = ERRNRM / ULP
*
* Normalization of E:
*
ENRMER = ZERO
ILCPLX = .FALSE.
DO 40 JVEC = 1, N
IF( ILCPLX ) THEN
ILCPLX = .FALSE.
ELSE
TEMP1 = ZERO
IF( ALPHAI( JVEC ).EQ.ZERO ) THEN
DO 20 J = 1, N
TEMP1 = MAX( TEMP1, ABS( E( J, JVEC ) ) )
20 CONTINUE
ENRMER = MAX( ENRMER, TEMP1-ONE )
ELSE
ILCPLX = .TRUE.
DO 30 J = 1, N
TEMP1 = MAX( TEMP1, ABS( E( J, JVEC ) )+
$ ABS( E( J, JVEC+1 ) ) )
30 CONTINUE
ENRMER = MAX( ENRMER, TEMP1-ONE )
END IF
END IF
40 CONTINUE
*
* Compute RESULT(2) : the normalization error in E.
*
RESULT( 2 ) = ENRMER / ( REAL( N )*ULP )
*
RETURN
*
* End of SGET52
*
END
SUBROUTINE SGET53( A, LDA, B, LDB, SCALE, WR, WI, RESULT, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB
REAL RESULT, SCALE, WI, WR
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* SGET53 checks the generalized eigenvalues computed by SLAG2.
*
* The basic test for an eigenvalue is:
*
* | det( s A - w B ) |
* RESULT = ---------------------------------------------------
* ulp max( s norm(A), |w| norm(B) )*norm( s A - w B )
*
* Two "safety checks" are performed:
*
* (1) ulp*max( s*norm(A), |w|*norm(B) ) must be at least
* safe_minimum. This insures that the test performed is
* not essentially det(0*A + 0*B)=0.
*
* (2) s*norm(A) + |w|*norm(B) must be less than 1/safe_minimum.
* This insures that s*A - w*B will not overflow.
*
* If these tests are not passed, then s and w are scaled and
* tested anyway, if this is possible.
*
* Arguments
* =========
*
* A (input) REAL array, dimension (LDA, 2)
* The 2x2 matrix A.
*
* LDA (input) INTEGER
* The leading dimension of A. It must be at least 2.
*
* B (input) REAL array, dimension (LDB, N)
* The 2x2 upper-triangular matrix B.
*
* LDB (input) INTEGER
* The leading dimension of B. It must be at least 2.
*
* SCALE (input) REAL
* The "scale factor" s in the formula s A - w B . It is
* assumed to be non-negative.
*
* WR (input) REAL
* The real part of the eigenvalue w in the formula
* s A - w B .
*
* WI (input) REAL
* The imaginary part of the eigenvalue w in the formula
* s A - w B .
*
* RESULT (output) REAL
* If INFO is 2 or less, the value computed by the test
* described above.
* If INFO=3, this will just be 1/ulp.
*
* INFO (output) INTEGER
* =0: The input data pass the "safety checks".
* =1: s*norm(A) + |w|*norm(B) > 1/safe_minimum.
* =2: ulp*max( s*norm(A), |w|*norm(B) ) < safe_minimum
* =3: same as INFO=2, but s and w could not be scaled so
* as to compute the test.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0, ONE = 1.0 )
* ..
* .. Local Scalars ..
REAL ABSW, ANORM, BNORM, CI11, CI12, CI22, CNORM,
$ CR11, CR12, CR21, CR22, CSCALE, DETI, DETR, S1,
$ SAFMIN, SCALES, SIGMIN, TEMP, ULP, WIS, WRS
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Initialize
*
INFO = 0
RESULT = ZERO
SCALES = SCALE
WRS = WR
WIS = WI
*
* Machine constants and norms
*
SAFMIN = SLAMCH( 'Safe minimum' )
ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
ABSW = ABS( WRS ) + ABS( WIS )
ANORM = MAX( ABS( A( 1, 1 ) )+ABS( A( 2, 1 ) ),
$ ABS( A( 1, 2 ) )+ABS( A( 2, 2 ) ), SAFMIN )
BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 1, 2 ) )+ABS( B( 2, 2 ) ),
$ SAFMIN )
*
* Check for possible overflow.
*
TEMP = ( SAFMIN*BNORM )*ABSW + ( SAFMIN*ANORM )*SCALES
IF( TEMP.GE.ONE ) THEN
*
* Scale down to avoid overflow
*
INFO = 1
TEMP = ONE / TEMP
SCALES = SCALES*TEMP
WRS = WRS*TEMP
WIS = WIS*TEMP
ABSW = ABS( WRS ) + ABS( WIS )
END IF
S1 = MAX( ULP*MAX( SCALES*ANORM, ABSW*BNORM ),
$ SAFMIN*MAX( SCALES, ABSW ) )
*
* Check for W and SCALE essentially zero.
*
IF( S1.LT.SAFMIN ) THEN
INFO = 2
IF( SCALES.LT.SAFMIN .AND. ABSW.LT.SAFMIN ) THEN
INFO = 3
RESULT = ONE / ULP
RETURN
END IF
*
* Scale up to avoid underflow
*
TEMP = ONE / MAX( SCALES*ANORM+ABSW*BNORM, SAFMIN )
SCALES = SCALES*TEMP
WRS = WRS*TEMP
WIS = WIS*TEMP
ABSW = ABS( WRS ) + ABS( WIS )
S1 = MAX( ULP*MAX( SCALES*ANORM, ABSW*BNORM ),
$ SAFMIN*MAX( SCALES, ABSW ) )
IF( S1.LT.SAFMIN ) THEN
INFO = 3
RESULT = ONE / ULP
RETURN
END IF
END IF
*
* Compute C = s A - w B
*
CR11 = SCALES*A( 1, 1 ) - WRS*B( 1, 1 )
CI11 = -WIS*B( 1, 1 )
CR21 = SCALES*A( 2, 1 )
CR12 = SCALES*A( 1, 2 ) - WRS*B( 1, 2 )
CI12 = -WIS*B( 1, 2 )
CR22 = SCALES*A( 2, 2 ) - WRS*B( 2, 2 )
CI22 = -WIS*B( 2, 2 )
*
* Compute the smallest singular value of s A - w B:
*
* |det( s A - w B )|
* sigma_min = ------------------
* norm( s A - w B )
*
CNORM = MAX( ABS( CR11 )+ABS( CI11 )+ABS( CR21 ),
$ ABS( CR12 )+ABS( CI12 )+ABS( CR22 )+ABS( CI22 ), SAFMIN )
CSCALE = ONE / SQRT( CNORM )
DETR = ( CSCALE*CR11 )*( CSCALE*CR22 ) -
$ ( CSCALE*CI11 )*( CSCALE*CI22 ) -
$ ( CSCALE*CR12 )*( CSCALE*CR21 )
DETI = ( CSCALE*CR11 )*( CSCALE*CI22 ) +
$ ( CSCALE*CI11 )*( CSCALE*CR22 ) -
$ ( CSCALE*CI12 )*( CSCALE*CR21 )
SIGMIN = ABS( DETR ) + ABS( DETI )
RESULT = SIGMIN / S1
RETURN
*
* End of SGET53
*
END
SUBROUTINE SGET54( N, A, LDA, B, LDB, S, LDS, T, LDT, U, LDU, V,
$ LDV, WORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDB, LDS, LDT, LDU, LDV, N
REAL RESULT
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), S( LDS, * ),
$ T( LDT, * ), U( LDU, * ), V( LDV, * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* SGET54 checks a generalized decomposition of the form
*
* A = U*S*V' and B = U*T* V'
*
* where ' means transpose and U and V are orthogonal.
*
* Specifically,
*
* RESULT = ||( A - U*S*V', B - U*T*V' )|| / (||( A, B )||*n*ulp )
*
* Arguments
* =========
*
* N (input) INTEGER
* The size of the matrix. If it is zero, SGET54 does nothing.
* It must be at least zero.
*
* A (input) REAL array, dimension (LDA, N)
* The original (unfactored) matrix A.
*
* LDA (input) INTEGER
* The leading dimension of A. It must be at least 1
* and at least N.
*
* B (input) REAL array, dimension (LDB, N)
* The original (unfactored) matrix B.
*
* LDB (input) INTEGER
* The leading dimension of B. It must be at least 1
* and at least N.
*
* S (input) REAL array, dimension (LDS, N)
* The factored matrix S.
*
* LDS (input) INTEGER
* The leading dimension of S. It must be at least 1
* and at least N.
*
* T (input) REAL array, dimension (LDT, N)
* The factored matrix T.
*
* LDT (input) INTEGER
* The leading dimension of T. It must be at least 1
* and at least N.
*
* U (input) REAL array, dimension (LDU, N)
* The orthogonal matrix on the left-hand side in the
* decomposition.
*
* LDU (input) INTEGER
* The leading dimension of U. LDU must be at least N and
* at least 1.
*
* V (input) REAL array, dimension (LDV, N)
* The orthogonal matrix on the left-hand side in the
* decomposition.
*
* LDV (input) INTEGER
* The leading dimension of V. LDV must be at least N and
* at least 1.
*
* WORK (workspace) REAL array, dimension (3*N**2)
*
* RESULT (output) REAL
* The value RESULT, It is currently limited to 1/ulp, to
* avoid overflow. Errors are flagged by RESULT=10/ulp.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
REAL ABNORM, ULP, UNFL, WNORM
* ..
* .. Local Arrays ..
REAL DUM( 1 )
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE
EXTERNAL SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SLACPY
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Executable Statements ..
*
RESULT = ZERO
IF( N.LE.0 )
$ RETURN
*
* Constants
*
UNFL = SLAMCH( 'Safe minimum' )
ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
*
* compute the norm of (A,B)
*
CALL SLACPY( 'Full', N, N, A, LDA, WORK, N )
CALL SLACPY( 'Full', N, N, B, LDB, WORK( N*N+1 ), N )
ABNORM = MAX( SLANGE( '1', N, 2*N, WORK, N, DUM ), UNFL )
*
* Compute W1 = A - U*S*V', and put in the array WORK(1:N*N)
*
CALL SLACPY( ' ', N, N, A, LDA, WORK, N )
CALL SGEMM( 'N', 'N', N, N, N, ONE, U, LDU, S, LDS, ZERO,
$ WORK( N*N+1 ), N )
*
CALL SGEMM( 'N', 'C', N, N, N, -ONE, WORK( N*N+1 ), N, V, LDV,
$ ONE, WORK, N )
*
* Compute W2 = B - U*T*V', and put in the workarray W(N*N+1:2*N*N)
*
CALL SLACPY( ' ', N, N, B, LDB, WORK( N*N+1 ), N )
CALL SGEMM( 'N', 'N', N, N, N, ONE, U, LDU, T, LDT, ZERO,
$ WORK( 2*N*N+1 ), N )
*
CALL SGEMM( 'N', 'C', N, N, N, -ONE, WORK( 2*N*N+1 ), N, V, LDV,
$ ONE, WORK( N*N+1 ), N )
*
* Compute norm(W)/ ( ulp*norm((A,B)) )
*
WNORM = SLANGE( '1', N, 2*N, WORK, N, DUM )
*
IF( ABNORM.GT.WNORM ) THEN
RESULT = ( WNORM / ABNORM ) / ( 2*N*ULP )
ELSE
IF( ABNORM.LT.ONE ) THEN
RESULT = ( MIN( WNORM, 2*N*ABNORM ) / ABNORM ) / ( 2*N*ULP )
ELSE
RESULT = MIN( WNORM / ABNORM, REAL( 2*N ) ) / ( 2*N*ULP )
END IF
END IF
*
RETURN
*
* End of SGET54
*
END
SUBROUTINE SGLMTS( N, M, P, A, AF, LDA, B, BF, LDB, D, DF,
$ X, U, WORK, LWORK, RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDB, LWORK, M, P, N
REAL RESULT
* ..
* .. Array Arguments ..
REAL A( LDA, * ), AF( LDA, * ), B( LDB, * ),
$ BF( LDB, * ), RWORK( * ), D( * ), DF( * ),
$ U( * ), WORK( LWORK ), X( * )
*
* Purpose
* =======
*
* SGLMTS tests SGGGLM - a subroutine for solving the generalized
* linear model problem.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of rows of the matrices A and B. N >= 0.
*
* M (input) INTEGER
* The number of columns of the matrix A. M >= 0.
*
* P (input) INTEGER
* The number of columns of the matrix B. P >= 0.
*
* A (input) REAL array, dimension (LDA,M)
* The N-by-M matrix A.
*
* AF (workspace) REAL array, dimension (LDA,M)
*
* LDA (input) INTEGER
* The leading dimension of the arrays A, AF. LDA >= max(M,N).
*
* B (input) REAL array, dimension (LDB,P)
* The N-by-P matrix A.
*
* BF (workspace) REAL array, dimension (LDB,P)
*
* LDB (input) INTEGER
* The leading dimension of the arrays B, BF. LDB >= max(P,N).
*
* D (input) REAL array, dimension( N )
* On input, the left hand side of the GLM.
*
* DF (workspace) REAL array, dimension( N )
*
* X (output) REAL array, dimension( M )
* solution vector X in the GLM problem.
*
* U (output) REAL array, dimension( P )
* solution vector U in the GLM problem.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
*
* RWORK (workspace) REAL array, dimension (M)
*
* RESULT (output) REAL
* The test ratio:
* norm( d - A*x - B*u )
* RESULT = -----------------------------------------
* (norm(A)+norm(B))*(norm(x)+norm(u))*EPS
*
* ====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER INFO
REAL ANORM, BNORM, EPS, XNORM, YNORM, DNORM, UNFL
* ..
* .. External Functions ..
REAL SASUM, SLAMCH, SLANGE
EXTERNAL SASUM, SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SLACPY
*
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
EPS = SLAMCH( 'Epsilon' )
UNFL = SLAMCH( 'Safe minimum' )
ANORM = MAX( SLANGE( '1', N, M, A, LDA, RWORK ), UNFL )
BNORM = MAX( SLANGE( '1', N, P, B, LDB, RWORK ), UNFL )
*
* Copy the matrices A and B to the arrays AF and BF,
* and the vector D the array DF.
*
CALL SLACPY( 'Full', N, M, A, LDA, AF, LDA )
CALL SLACPY( 'Full', N, P, B, LDB, BF, LDB )
CALL SCOPY( N, D, 1, DF, 1 )
*
* Solve GLM problem
*
CALL SGGGLM( N, M, P, AF, LDA, BF, LDB, DF, X, U, WORK, LWORK,
$ INFO )
*
* Test the residual for the solution of LSE
*
* norm( d - A*x - B*u )
* RESULT = -----------------------------------------
* (norm(A)+norm(B))*(norm(x)+norm(u))*EPS
*
CALL SCOPY( N, D, 1, DF, 1 )
CALL SGEMV( 'No transpose', N, M, -ONE, A, LDA, X, 1,
$ ONE, DF, 1 )
*
CALL SGEMV( 'No transpose', N, P, -ONE, B, LDB, U, 1,
$ ONE, DF, 1 )
*
DNORM = SASUM( N, DF, 1 )
XNORM = SASUM( M, X, 1 ) + SASUM( P, U, 1 )
YNORM = ANORM + BNORM
*
IF( XNORM.LE.ZERO ) THEN
RESULT = ZERO
ELSE
RESULT = ( ( DNORM / YNORM ) / XNORM ) /EPS
END IF
*
RETURN
*
* End of SGLMTS
*
END
SUBROUTINE SGQRTS( N, M, P, A, AF, Q, R, LDA, TAUA, B, BF, Z, T,
$ BWK, LDB, TAUB, WORK, LWORK, RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDB, LWORK, M, P, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), AF( LDA, * ), R( LDA, * ),
$ Q( LDA, * ), B( LDB, * ), BF( LDB, * ),
$ T( LDB, * ), Z( LDB, * ), BWK( LDB, * ),
$ TAUA( * ), TAUB( * ), RESULT( 4 ),
$ RWORK( * ), WORK( LWORK )
* ..
*
* Purpose
* =======
*
* SGQRTS tests SGGQRF, which computes the GQR factorization of an
* N-by-M matrix A and a N-by-P matrix B: A = Q*R and B = Q*T*Z.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of rows of the matrices A and B. N >= 0.
*
* M (input) INTEGER
* The number of columns of the matrix A. M >= 0.
*
* P (input) INTEGER
* The number of columns of the matrix B. P >= 0.
*
* A (input) REAL array, dimension (LDA,M)
* The N-by-M matrix A.
*
* AF (output) REAL array, dimension (LDA,N)
* Details of the GQR factorization of A and B, as returned
* by SGGQRF, see SGGQRF for further details.
*
* Q (output) REAL array, dimension (LDA,N)
* The M-by-M orthogonal matrix Q.
*
* R (workspace) REAL array, dimension (LDA,MAX(M,N))
*
* LDA (input) INTEGER
* The leading dimension of the arrays A, AF, R and Q.
* LDA >= max(M,N).
*
* TAUA (output) REAL array, dimension (min(M,N))
* The scalar factors of the elementary reflectors, as returned
* by SGGQRF.
*
* B (input) REAL array, dimension (LDB,P)
* On entry, the N-by-P matrix A.
*
* BF (output) REAL array, dimension (LDB,N)
* Details of the GQR factorization of A and B, as returned
* by SGGQRF, see SGGQRF for further details.
*
* Z (output) REAL array, dimension (LDB,P)
* The P-by-P orthogonal matrix Z.
*
* T (workspace) REAL array, dimension (LDB,max(P,N))
*
* BWK (workspace) REAL array, dimension (LDB,N)
*
* LDB (input) INTEGER
* The leading dimension of the arrays B, BF, Z and T.
* LDB >= max(P,N).
*
* TAUB (output) REAL array, dimension (min(P,N))
* The scalar factors of the elementary reflectors, as returned
* by SGGRQF.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The dimension of the array WORK, LWORK >= max(N,M,P)**2.
*
* RWORK (workspace) REAL array, dimension (max(N,M,P))
*
* RESULT (output) REAL array, dimension (4)
* The test ratios:
* RESULT(1) = norm( R - Q'*A ) / ( MAX(M,N)*norm(A)*ULP)
* RESULT(2) = norm( T*Z - Q'*B ) / (MAX(P,N)*norm(B)*ULP)
* RESULT(3) = norm( I - Q'*Q ) / ( M*ULP )
* RESULT(4) = norm( I - Z'*Z ) / ( P*ULP )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
REAL ROGUE
PARAMETER ( ROGUE = -1.0E+10 )
* ..
* .. Local Scalars ..
INTEGER INFO
REAL ANORM, BNORM, ULP, UNFL, RESID
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE, SLANSY
EXTERNAL SLAMCH, SLANGE, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SLACPY, SLASET, SORGQR,
$ SORGRQ, SSYRK
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Executable Statements ..
*
ULP = SLAMCH( 'Precision' )
UNFL = SLAMCH( 'Safe minimum' )
*
* Copy the matrix A to the array AF.
*
CALL SLACPY( 'Full', N, M, A, LDA, AF, LDA )
CALL SLACPY( 'Full', N, P, B, LDB, BF, LDB )
*
ANORM = MAX( SLANGE( '1', N, M, A, LDA, RWORK ), UNFL )
BNORM = MAX( SLANGE( '1', N, P, B, LDB, RWORK ), UNFL )
*
* Factorize the matrices A and B in the arrays AF and BF.
*
CALL SGGQRF( N, M, P, AF, LDA, TAUA, BF, LDB, TAUB, WORK,
$ LWORK, INFO )
*
* Generate the N-by-N matrix Q
*
CALL SLASET( 'Full', N, N, ROGUE, ROGUE, Q, LDA )
CALL SLACPY( 'Lower', N-1, M, AF( 2,1 ), LDA, Q( 2,1 ), LDA )
CALL SORGQR( N, N, MIN( N, M ), Q, LDA, TAUA, WORK, LWORK, INFO )
*
* Generate the P-by-P matrix Z
*
CALL SLASET( 'Full', P, P, ROGUE, ROGUE, Z, LDB )
IF( N.LE.P ) THEN
IF( N.GT.0 .AND. N.LT.P )
$ CALL SLACPY( 'Full', N, P-N, BF, LDB, Z( P-N+1, 1 ), LDB )
IF( N.GT.1 )
$ CALL SLACPY( 'Lower', N-1, N-1, BF( 2, P-N+1 ), LDB,
$ Z( P-N+2, P-N+1 ), LDB )
ELSE
IF( P.GT.1)
$ CALL SLACPY( 'Lower', P-1, P-1, BF( N-P+2, 1 ), LDB,
$ Z( 2, 1 ), LDB )
END IF
CALL SORGRQ( P, P, MIN( N, P ), Z, LDB, TAUB, WORK, LWORK, INFO )
*
* Copy R
*
CALL SLASET( 'Full', N, M, ZERO, ZERO, R, LDA )
CALL SLACPY( 'Upper', N, M, AF, LDA, R, LDA )
*
* Copy T
*
CALL SLASET( 'Full', N, P, ZERO, ZERO, T, LDB )
IF( N.LE.P ) THEN
CALL SLACPY( 'Upper', N, N, BF( 1, P-N+1 ), LDB, T( 1, P-N+1 ),
$ LDB )
ELSE
CALL SLACPY( 'Full', N-P, P, BF, LDB, T, LDB )
CALL SLACPY( 'Upper', P, P, BF( N-P+1, 1 ), LDB, T( N-P+1, 1 ),
$ LDB )
END IF
*
* Compute R - Q'*A
*
CALL SGEMM( 'Transpose', 'No transpose', N, M, N, -ONE, Q, LDA, A,
$ LDA, ONE, R, LDA )
*
* Compute norm( R - Q'*A ) / ( MAX(M,N)*norm(A)*ULP ) .
*
RESID = SLANGE( '1', N, M, R, LDA, RWORK )
IF( ANORM.GT.ZERO ) THEN
RESULT( 1 ) = ( ( RESID / REAL( MAX(1,M,N) ) ) / ANORM ) / ULP
ELSE
RESULT( 1 ) = ZERO
END IF
*
* Compute T*Z - Q'*B
*
CALL SGEMM( 'No Transpose', 'No transpose', N, P, P, ONE, T, LDB,
$ Z, LDB, ZERO, BWK, LDB )
CALL SGEMM( 'Transpose', 'No transpose', N, P, N, -ONE, Q, LDA,
$ B, LDB, ONE, BWK, LDB )
*
* Compute norm( T*Z - Q'*B ) / ( MAX(P,N)*norm(A)*ULP ) .
*
RESID = SLANGE( '1', N, P, BWK, LDB, RWORK )
IF( BNORM.GT.ZERO ) THEN
RESULT( 2 ) = ( ( RESID / REAL( MAX(1,P,N ) ) )/BNORM ) / ULP
ELSE
RESULT( 2 ) = ZERO
END IF
*
* Compute I - Q'*Q
*
CALL SLASET( 'Full', N, N, ZERO, ONE, R, LDA )
CALL SSYRK( 'Upper', 'Transpose', N, N, -ONE, Q, LDA, ONE, R,
$ LDA )
*
* Compute norm( I - Q'*Q ) / ( N * ULP ) .
*
RESID = SLANSY( '1', 'Upper', N, R, LDA, RWORK )
RESULT( 3 ) = ( RESID / REAL( MAX( 1, N ) ) ) / ULP
*
* Compute I - Z'*Z
*
CALL SLASET( 'Full', P, P, ZERO, ONE, T, LDB )
CALL SSYRK( 'Upper', 'Transpose', P, P, -ONE, Z, LDB, ONE, T,
$ LDB )
*
* Compute norm( I - Z'*Z ) / ( P*ULP ) .
*
RESID = SLANSY( '1', 'Upper', P, T, LDB, RWORK )
RESULT( 4 ) = ( RESID / REAL( MAX( 1, P ) ) ) / ULP
*
RETURN
*
* End of SGQRTS
*
END
SUBROUTINE SGRQTS( M, P, N, A, AF, Q, R, LDA, TAUA, B, BF, Z, T,
$ BWK, LDB, TAUB, WORK, LWORK, RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDB, LWORK, M, P, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), AF( LDA, * ), R( LDA, * ),
$ Q( LDA, * ),
$ B( LDB, * ), BF( LDB, * ), T( LDB, * ),
$ Z( LDB, * ), BWK( LDB, * ),
$ TAUA( * ), TAUB( * ),
$ RESULT( 4 ), RWORK( * ), WORK( LWORK )
* ..
*
* Purpose
* =======
*
* SGRQTS tests SGGRQF, which computes the GRQ factorization of an
* M-by-N matrix A and a P-by-N matrix B: A = R*Q and B = Z*T*Q.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix A. M >= 0.
*
* P (input) INTEGER
* The number of rows of the matrix B. P >= 0.
*
* N (input) INTEGER
* The number of columns of the matrices A and B. N >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The M-by-N matrix A.
*
* AF (output) REAL array, dimension (LDA,N)
* Details of the GRQ factorization of A and B, as returned
* by SGGRQF, see SGGRQF for further details.
*
* Q (output) REAL array, dimension (LDA,N)
* The N-by-N orthogonal matrix Q.
*
* R (workspace) REAL array, dimension (LDA,MAX(M,N))
*
* LDA (input) INTEGER
* The leading dimension of the arrays A, AF, R and Q.
* LDA >= max(M,N).
*
* TAUA (output) REAL array, dimension (min(M,N))
* The scalar factors of the elementary reflectors, as returned
* by SGGQRC.
*
* B (input) REAL array, dimension (LDB,N)
* On entry, the P-by-N matrix A.
*
* BF (output) REAL array, dimension (LDB,N)
* Details of the GQR factorization of A and B, as returned
* by SGGRQF, see SGGRQF for further details.
*
* Z (output) REAL array, dimension (LDB,P)
* The P-by-P orthogonal matrix Z.
*
* T (workspace) REAL array, dimension (LDB,max(P,N))
*
* BWK (workspace) REAL array, dimension (LDB,N)
*
* LDB (input) INTEGER
* The leading dimension of the arrays B, BF, Z and T.
* LDB >= max(P,N).
*
* TAUB (output) REAL array, dimension (min(P,N))
* The scalar factors of the elementary reflectors, as returned
* by SGGRQF.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The dimension of the array WORK, LWORK >= max(M,P,N)**2.
*
* RWORK (workspace) REAL array, dimension (M)
*
* RESULT (output) REAL array, dimension (4)
* The test ratios:
* RESULT(1) = norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP)
* RESULT(2) = norm( T*Q - Z'*B ) / (MAX(P,N)*norm(B)*ULP)
* RESULT(3) = norm( I - Q'*Q ) / ( N*ULP )
* RESULT(4) = norm( I - Z'*Z ) / ( P*ULP )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
REAL ROGUE
PARAMETER ( ROGUE = -1.0E+10 )
* ..
* .. Local Scalars ..
INTEGER INFO
REAL ANORM, BNORM, ULP, UNFL, RESID
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE, SLANSY
EXTERNAL SLAMCH, SLANGE, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SGGRQF, SLACPY, SLASET, SORGQR,
$ SORGRQ, SSYRK
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Executable Statements ..
*
ULP = SLAMCH( 'Precision' )
UNFL = SLAMCH( 'Safe minimum' )
*
* Copy the matrix A to the array AF.
*
CALL SLACPY( 'Full', M, N, A, LDA, AF, LDA )
CALL SLACPY( 'Full', P, N, B, LDB, BF, LDB )
*
ANORM = MAX( SLANGE( '1', M, N, A, LDA, RWORK ), UNFL )
BNORM = MAX( SLANGE( '1', P, N, B, LDB, RWORK ), UNFL )
*
* Factorize the matrices A and B in the arrays AF and BF.
*
CALL SGGRQF( M, P, N, AF, LDA, TAUA, BF, LDB, TAUB, WORK,
$ LWORK, INFO )
*
* Generate the N-by-N matrix Q
*
CALL SLASET( 'Full', N, N, ROGUE, ROGUE, Q, LDA )
IF( M.LE.N ) THEN
IF( M.GT.0 .AND. M.LT.N )
$ CALL SLACPY( 'Full', M, N-M, AF, LDA, Q( N-M+1, 1 ), LDA )
IF( M.GT.1 )
$ CALL SLACPY( 'Lower', M-1, M-1, AF( 2, N-M+1 ), LDA,
$ Q( N-M+2, N-M+1 ), LDA )
ELSE
IF( N.GT.1 )
$ CALL SLACPY( 'Lower', N-1, N-1, AF( M-N+2, 1 ), LDA,
$ Q( 2, 1 ), LDA )
END IF
CALL SORGRQ( N, N, MIN( M, N ), Q, LDA, TAUA, WORK, LWORK, INFO )
*
* Generate the P-by-P matrix Z
*
CALL SLASET( 'Full', P, P, ROGUE, ROGUE, Z, LDB )
IF( P.GT.1 )
$ CALL SLACPY( 'Lower', P-1, N, BF( 2,1 ), LDB, Z( 2,1 ), LDB )
CALL SORGQR( P, P, MIN( P,N ), Z, LDB, TAUB, WORK, LWORK, INFO )
*
* Copy R
*
CALL SLASET( 'Full', M, N, ZERO, ZERO, R, LDA )
IF( M.LE.N )THEN
CALL SLACPY( 'Upper', M, M, AF( 1, N-M+1 ), LDA, R( 1, N-M+1 ),
$ LDA )
ELSE
CALL SLACPY( 'Full', M-N, N, AF, LDA, R, LDA )
CALL SLACPY( 'Upper', N, N, AF( M-N+1, 1 ), LDA, R( M-N+1, 1 ),
$ LDA )
END IF
*
* Copy T
*
CALL SLASET( 'Full', P, N, ZERO, ZERO, T, LDB )
CALL SLACPY( 'Upper', P, N, BF, LDB, T, LDB )
*
* Compute R - A*Q'
*
CALL SGEMM( 'No transpose', 'Transpose', M, N, N, -ONE, A, LDA, Q,
$ LDA, ONE, R, LDA )
*
* Compute norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP ) .
*
RESID = SLANGE( '1', M, N, R, LDA, RWORK )
IF( ANORM.GT.ZERO ) THEN
RESULT( 1 ) = ( ( RESID / REAL(MAX(1,M,N) ) ) / ANORM ) / ULP
ELSE
RESULT( 1 ) = ZERO
END IF
*
* Compute T*Q - Z'*B
*
CALL SGEMM( 'Transpose', 'No transpose', P, N, P, ONE, Z, LDB, B,
$ LDB, ZERO, BWK, LDB )
CALL SGEMM( 'No transpose', 'No transpose', P, N, N, ONE, T, LDB,
$ Q, LDA, -ONE, BWK, LDB )
*
* Compute norm( T*Q - Z'*B ) / ( MAX(P,N)*norm(A)*ULP ) .
*
RESID = SLANGE( '1', P, N, BWK, LDB, RWORK )
IF( BNORM.GT.ZERO ) THEN
RESULT( 2 ) = ( ( RESID / REAL( MAX( 1,P,M ) ) )/BNORM ) / ULP
ELSE
RESULT( 2 ) = ZERO
END IF
*
* Compute I - Q*Q'
*
CALL SLASET( 'Full', N, N, ZERO, ONE, R, LDA )
CALL SSYRK( 'Upper', 'No Transpose', N, N, -ONE, Q, LDA, ONE, R,
$ LDA )
*
* Compute norm( I - Q'*Q ) / ( N * ULP ) .
*
RESID = SLANSY( '1', 'Upper', N, R, LDA, RWORK )
RESULT( 3 ) = ( RESID / REAL( MAX( 1,N ) ) ) / ULP
*
* Compute I - Z'*Z
*
CALL SLASET( 'Full', P, P, ZERO, ONE, T, LDB )
CALL SSYRK( 'Upper', 'Transpose', P, P, -ONE, Z, LDB, ONE, T,
$ LDB )
*
* Compute norm( I - Z'*Z ) / ( P*ULP ) .
*
RESID = SLANSY( '1', 'Upper', P, T, LDB, RWORK )
RESULT( 4 ) = ( RESID / REAL( MAX( 1,P ) ) ) / ULP
*
RETURN
*
* End of SGRQTS
*
END
SUBROUTINE SGSVTS( M, P, N, A, AF, LDA, B, BF, LDB, U, LDU, V,
$ LDV, Q, LDQ, ALPHA, BETA, R, LDR, IWORK, WORK,
$ LWORK, RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDB, LDQ, LDR, LDU, LDV, LWORK, M, N, P
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL A( LDA, * ), AF( LDA, * ), ALPHA( * ),
$ B( LDB, * ), BETA( * ), BF( LDB, * ),
$ Q( LDQ, * ), R( LDR, * ), RESULT( 6 ),
$ RWORK( * ), U( LDU, * ), V( LDV, * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* SGSVTS tests SGGSVD, which computes the GSVD of an M-by-N matrix A
* and a P-by-N matrix B:
* U'*A*Q = D1*R and V'*B*Q = D2*R.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix A. M >= 0.
*
* P (input) INTEGER
* The number of rows of the matrix B. P >= 0.
*
* N (input) INTEGER
* The number of columns of the matrices A and B. N >= 0.
*
* A (input) REAL array, dimension (LDA,M)
* The M-by-N matrix A.
*
* AF (output) REAL array, dimension (LDA,N)
* Details of the GSVD of A and B, as returned by SGGSVD,
* see SGGSVD for further details.
*
* LDA (input) INTEGER
* The leading dimension of the arrays A and AF.
* LDA >= max( 1,M ).
*
* B (input) REAL array, dimension (LDB,P)
* On entry, the P-by-N matrix B.
*
* BF (output) REAL array, dimension (LDB,N)
* Details of the GSVD of A and B, as returned by SGGSVD,
* see SGGSVD for further details.
*
* LDB (input) INTEGER
* The leading dimension of the arrays B and BF.
* LDB >= max(1,P).
*
* U (output) REAL array, dimension(LDU,M)
* The M by M orthogonal matrix U.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= max(1,M).
*
* V (output) REAL array, dimension(LDV,M)
* The P by P orthogonal matrix V.
*
* LDV (input) INTEGER
* The leading dimension of the array V. LDV >= max(1,P).
*
* Q (output) REAL array, dimension(LDQ,N)
* The N by N orthogonal matrix Q.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* ALPHA (output) REAL array, dimension (N)
* BETA (output) REAL array, dimension (N)
* The generalized singular value pairs of A and B, the
* ``diagonal'' matrices D1 and D2 are constructed from
* ALPHA and BETA, see subroutine SGGSVD for details.
*
* R (output) REAL array, dimension(LDQ,N)
* The upper triangular matrix R.
*
* LDR (input) INTEGER
* The leading dimension of the array R. LDR >= max(1,N).
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The dimension of the array WORK,
* LWORK >= max(M,P,N)*max(M,P,N).
*
* RWORK (workspace) REAL array, dimension (max(M,P,N))
*
* RESULT (output) REAL array, dimension (6)
* The test ratios:
* RESULT(1) = norm( U'*A*Q - D1*R ) / ( MAX(M,N)*norm(A)*ULP)
* RESULT(2) = norm( V'*B*Q - D2*R ) / ( MAX(P,N)*norm(B)*ULP)
* RESULT(3) = norm( I - U'*U ) / ( M*ULP )
* RESULT(4) = norm( I - V'*V ) / ( P*ULP )
* RESULT(5) = norm( I - Q'*Q ) / ( N*ULP )
* RESULT(6) = 0 if ALPHA is in decreasing order;
* = ULPINV otherwise.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J, K, L
REAL ANORM, BNORM, RESID, TEMP, ULP, ULPINV, UNFL
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE, SLANSY
EXTERNAL SLAMCH, SLANGE, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMM, SGGSVD, SLACPY, SLASET, SSYRK
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Executable Statements ..
*
ULP = SLAMCH( 'Precision' )
ULPINV = ONE / ULP
UNFL = SLAMCH( 'Safe minimum' )
*
* Copy the matrix A to the array AF.
*
CALL SLACPY( 'Full', M, N, A, LDA, AF, LDA )
CALL SLACPY( 'Full', P, N, B, LDB, BF, LDB )
*
ANORM = MAX( SLANGE( '1', M, N, A, LDA, RWORK ), UNFL )
BNORM = MAX( SLANGE( '1', P, N, B, LDB, RWORK ), UNFL )
*
* Factorize the matrices A and B in the arrays AF and BF.
*
CALL SGGSVD( 'U', 'V', 'Q', M, N, P, K, L, AF, LDA, BF, LDB,
$ ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, IWORK,
$ INFO )
*
* Copy R
*
DO 20 I = 1, MIN( K+L, M )
DO 10 J = I, K + L
R( I, J ) = AF( I, N-K-L+J )
10 CONTINUE
20 CONTINUE
*
IF( M-K-L.LT.0 ) THEN
DO 40 I = M + 1, K + L
DO 30 J = I, K + L
R( I, J ) = BF( I-K, N-K-L+J )
30 CONTINUE
40 CONTINUE
END IF
*
* Compute A:= U'*A*Q - D1*R
*
CALL SGEMM( 'No transpose', 'No transpose', M, N, N, ONE, A, LDA,
$ Q, LDQ, ZERO, WORK, LDA )
*
CALL SGEMM( 'Transpose', 'No transpose', M, N, M, ONE, U, LDU,
$ WORK, LDA, ZERO, A, LDA )
*
DO 60 I = 1, K
DO 50 J = I, K + L
A( I, N-K-L+J ) = A( I, N-K-L+J ) - R( I, J )
50 CONTINUE
60 CONTINUE
*
DO 80 I = K + 1, MIN( K+L, M )
DO 70 J = I, K + L
A( I, N-K-L+J ) = A( I, N-K-L+J ) - ALPHA( I )*R( I, J )
70 CONTINUE
80 CONTINUE
*
* Compute norm( U'*A*Q - D1*R ) / ( MAX(1,M,N)*norm(A)*ULP ) .
*
RESID = SLANGE( '1', M, N, A, LDA, RWORK )
*
IF( ANORM.GT.ZERO ) THEN
RESULT( 1 ) = ( ( RESID / REAL( MAX( 1, M, N ) ) ) / ANORM ) /
$ ULP
ELSE
RESULT( 1 ) = ZERO
END IF
*
* Compute B := V'*B*Q - D2*R
*
CALL SGEMM( 'No transpose', 'No transpose', P, N, N, ONE, B, LDB,
$ Q, LDQ, ZERO, WORK, LDB )
*
CALL SGEMM( 'Transpose', 'No transpose', P, N, P, ONE, V, LDV,
$ WORK, LDB, ZERO, B, LDB )
*
DO 100 I = 1, L
DO 90 J = I, L
B( I, N-L+J ) = B( I, N-L+J ) - BETA( K+I )*R( K+I, K+J )
90 CONTINUE
100 CONTINUE
*
* Compute norm( V'*B*Q - D2*R ) / ( MAX(P,N)*norm(B)*ULP ) .
*
RESID = SLANGE( '1', P, N, B, LDB, RWORK )
IF( BNORM.GT.ZERO ) THEN
RESULT( 2 ) = ( ( RESID / REAL( MAX( 1, P, N ) ) ) / BNORM ) /
$ ULP
ELSE
RESULT( 2 ) = ZERO
END IF
*
* Compute I - U'*U
*
CALL SLASET( 'Full', M, M, ZERO, ONE, WORK, LDQ )
CALL SSYRK( 'Upper', 'Transpose', M, M, -ONE, U, LDU, ONE, WORK,
$ LDU )
*
* Compute norm( I - U'*U ) / ( M * ULP ) .
*
RESID = SLANSY( '1', 'Upper', M, WORK, LDU, RWORK )
RESULT( 3 ) = ( RESID / REAL( MAX( 1, M ) ) ) / ULP
*
* Compute I - V'*V
*
CALL SLASET( 'Full', P, P, ZERO, ONE, WORK, LDV )
CALL SSYRK( 'Upper', 'Transpose', P, P, -ONE, V, LDV, ONE, WORK,
$ LDV )
*
* Compute norm( I - V'*V ) / ( P * ULP ) .
*
RESID = SLANSY( '1', 'Upper', P, WORK, LDV, RWORK )
RESULT( 4 ) = ( RESID / REAL( MAX( 1, P ) ) ) / ULP
*
* Compute I - Q'*Q
*
CALL SLASET( 'Full', N, N, ZERO, ONE, WORK, LDQ )
CALL SSYRK( 'Upper', 'Transpose', N, N, -ONE, Q, LDQ, ONE, WORK,
$ LDQ )
*
* Compute norm( I - Q'*Q ) / ( N * ULP ) .
*
RESID = SLANSY( '1', 'Upper', N, WORK, LDQ, RWORK )
RESULT( 5 ) = ( RESID / REAL( MAX( 1, N ) ) ) / ULP
*
* Check sorting
*
CALL SCOPY( N, ALPHA, 1, WORK, 1 )
DO 110 I = K + 1, MIN( K+L, M )
J = IWORK( I )
IF( I.NE.J ) THEN
TEMP = WORK( I )
WORK( I ) = WORK( J )
WORK( J ) = TEMP
END IF
110 CONTINUE
*
RESULT( 6 ) = ZERO
DO 120 I = K + 1, MIN( K+L, M ) - 1
IF( WORK( I ).LT.WORK( I+1 ) )
$ RESULT( 6 ) = ULPINV
120 CONTINUE
*
RETURN
*
* End of SGSVTS
*
END
SUBROUTINE SHST01( N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK,
$ LWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IHI, ILO, LDA, LDH, LDQ, LWORK, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), H( LDH, * ), Q( LDQ, * ),
$ RESULT( 2 ), WORK( LWORK )
* ..
*
* Purpose
* =======
*
* SHST01 tests the reduction of a general matrix A to upper Hessenberg
* form: A = Q*H*Q'. Two test ratios are computed;
*
* RESULT(1) = norm( A - Q*H*Q' ) / ( norm(A) * N * EPS )
* RESULT(2) = norm( I - Q'*Q ) / ( N * EPS )
*
* The matrix Q is assumed to be given explicitly as it would be
* following SGEHRD + SORGHR.
*
* In this version, ILO and IHI are not used and are assumed to be 1 and
* N, respectively.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* A is assumed to be upper triangular in rows and columns
* 1:ILO-1 and IHI+1:N, so Q differs from the identity only in
* rows and columns ILO+1:IHI.
*
* A (input) REAL array, dimension (LDA,N)
* The original n by n matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* H (input) REAL array, dimension (LDH,N)
* The upper Hessenberg matrix H from the reduction A = Q*H*Q'
* as computed by SGEHRD. H is assumed to be zero below the
* first subdiagonal.
*
* LDH (input) INTEGER
* The leading dimension of the array H. LDH >= max(1,N).
*
* Q (input) REAL array, dimension (LDQ,N)
* The orthogonal matrix Q from the reduction A = Q*H*Q' as
* computed by SGEHRD + SORGHR.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of the array WORK. LWORK >= 2*N*N.
*
* RESULT (output) REAL array, dimension (2)
* RESULT(1) = norm( A - Q*H*Q' ) / ( norm(A) * N * EPS )
* RESULT(2) = norm( I - Q'*Q ) / ( N * EPS )
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER LDWORK
REAL ANORM, EPS, OVFL, SMLNUM, UNFL, WNORM
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE
EXTERNAL SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SLABAD, SLACPY, SORT01
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.0 ) THEN
RESULT( 1 ) = ZERO
RESULT( 2 ) = ZERO
RETURN
END IF
*
UNFL = SLAMCH( 'Safe minimum' )
EPS = SLAMCH( 'Precision' )
OVFL = ONE / UNFL
CALL SLABAD( UNFL, OVFL )
SMLNUM = UNFL*N / EPS
*
* Test 1: Compute norm( A - Q*H*Q' ) / ( norm(A) * N * EPS )
*
* Copy A to WORK
*
LDWORK = MAX( 1, N )
CALL SLACPY( ' ', N, N, A, LDA, WORK, LDWORK )
*
* Compute Q*H
*
CALL SGEMM( 'No transpose', 'No transpose', N, N, N, ONE, Q, LDQ,
$ H, LDH, ZERO, WORK( LDWORK*N+1 ), LDWORK )
*
* Compute A - Q*H*Q'
*
CALL SGEMM( 'No transpose', 'Transpose', N, N, N, -ONE,
$ WORK( LDWORK*N+1 ), LDWORK, Q, LDQ, ONE, WORK,
$ LDWORK )
*
ANORM = MAX( SLANGE( '1', N, N, A, LDA, WORK( LDWORK*N+1 ) ),
$ UNFL )
WNORM = SLANGE( '1', N, N, WORK, LDWORK, WORK( LDWORK*N+1 ) )
*
* Note that RESULT(1) cannot overflow and is bounded by 1/(N*EPS)
*
RESULT( 1 ) = MIN( WNORM, ANORM ) / MAX( SMLNUM, ANORM*EPS ) / N
*
* Test 2: Compute norm( I - Q'*Q ) / ( N * EPS )
*
CALL SORT01( 'Columns', N, N, Q, LDQ, WORK, LWORK, RESULT( 2 ) )
*
RETURN
*
* End of SHST01
*
END
SUBROUTINE SLAFTS( TYPE, M, N, IMAT, NTESTS, RESULT, ISEED,
$ THRESH, IOUNIT, IE )
*
* -- LAPACK auxiliary test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 TYPE
INTEGER IE, IMAT, IOUNIT, M, N, NTESTS
REAL THRESH
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
REAL RESULT( * )
* ..
*
* Purpose
* =======
*
* SLAFTS tests the result vector against the threshold value to
* see which tests for this matrix type failed to pass the threshold.
* Output is to the file given by unit IOUNIT.
*
* Arguments
* =========
*
* TYPE - CHARACTER*3
* On entry, TYPE specifies the matrix type to be used in the
* printed messages.
* Not modified.
*
* N - INTEGER
* On entry, N specifies the order of the test matrix.
* Not modified.
*
* IMAT - INTEGER
* On entry, IMAT specifies the type of the test matrix.
* A listing of the different types is printed by SLAHD2
* to the output file if a test fails to pass the threshold.
* Not modified.
*
* NTESTS - INTEGER
* On entry, NTESTS is the number of tests performed on the
* subroutines in the path given by TYPE.
* Not modified.
*
* RESULT - REAL array of dimension( NTESTS )
* On entry, RESULT contains the test ratios from the tests
* performed in the calling program.
* Not modified.
*
* ISEED - INTEGER array of dimension( 4 )
* Contains the random seed that generated the matrix used
* for the tests whose ratios are in RESULT.
* Not modified.
*
* THRESH - REAL
* On entry, THRESH specifies the acceptable threshold of the
* test ratios. If RESULT( K ) > THRESH, then the K-th test
* did not pass the threshold and a message will be printed.
* Not modified.
*
* IOUNIT - INTEGER
* On entry, IOUNIT specifies the unit number of the file
* to which the messages are printed.
* Not modified.
*
* IE - INTEGER
* On entry, IE contains the number of tests which have
* failed to pass the threshold so far.
* Updated on exit if any of the ratios in RESULT also fail.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER K
* ..
* .. External Subroutines ..
EXTERNAL SLAHD2
* ..
* .. Executable Statements ..
*
IF( M.EQ.N ) THEN
*
* Output for square matrices:
*
DO 10 K = 1, NTESTS
IF( RESULT( K ).GE.THRESH ) THEN
*
* If this is the first test to fail, call SLAHD2
* to print a header to the data file.
*
IF( IE.EQ.0 )
$ CALL SLAHD2( IOUNIT, TYPE )
IE = IE + 1
*** WRITE( IOUNIT, 15 )' Matrix of order', N,
*** $ ', type ', IMAT,
*** $ ', test ', K,
*** $ ', ratio = ', RESULT( K )
*** 15 FORMAT( A16, I5, 2( A8, I2 ), A11, G13.6 )
IF( RESULT( K ).LT.10000.0 ) THEN
WRITE( IOUNIT, FMT = 9999 )N, IMAT, ISEED, K,
$ RESULT( K )
9999 FORMAT( ' Matrix order=', I5, ', type=', I2,
$ ', seed=', 4( I4, ',' ), ' result ', I3, ' is',
$ 0P, F8.2 )
ELSE
WRITE( IOUNIT, FMT = 9998 )N, IMAT, ISEED, K,
$ RESULT( K )
9998 FORMAT( ' Matrix order=', I5, ', type=', I2,
$ ', seed=', 4( I4, ',' ), ' result ', I3, ' is',
$ 1P, E10.3 )
END IF
END IF
10 CONTINUE
ELSE
*
* Output for rectangular matrices
*
DO 20 K = 1, NTESTS
IF( RESULT( K ).GE.THRESH ) THEN
*
* If this is the first test to fail, call SLAHD2
* to print a header to the data file.
*
IF( IE.EQ.0 )
$ CALL SLAHD2( IOUNIT, TYPE )
IE = IE + 1
*** WRITE( IOUNIT, FMT = 9997 )' Matrix of size', M, ' x',
*** $ N, ', type ', IMAT, ', test ', K, ', ratio = ',
*** $ RESULT( K )
*** 9997 FORMAT( A10, I5, A2, I5, A7, I2, A8, I2, A11, G13.6 )
IF( RESULT( K ).LT.10000.0 ) THEN
WRITE( IOUNIT, FMT = 9997 )M, N, IMAT, ISEED, K,
$ RESULT( K )
9997 FORMAT( 1X, I5, ' x', I5, ' matrix, type=', I2, ', s',
$ 'eed=', 3( I4, ',' ), I4, ': result ', I3,
$ ' is', 0P, F8.2 )
ELSE
WRITE( IOUNIT, FMT = 9996 )M, N, IMAT, ISEED, K,
$ RESULT( K )
9996 FORMAT( 1X, I5, ' x', I5, ' matrix, type=', I2, ', s',
$ 'eed=', 3( I4, ',' ), I4, ': result ', I3,
$ ' is', 1P, E10.3 )
END IF
END IF
20 CONTINUE
*
END IF
RETURN
*
* End of SLAFTS
*
END
SUBROUTINE SLAHD2( IOUNIT, PATH )
*
* -- LAPACK auxiliary test routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER IOUNIT
* ..
*
* Purpose
* =======
*
* SLAHD2 prints header information for the different test paths.
*
* Arguments
* =========
*
* IOUNIT (input) INTEGER.
* On entry, IOUNIT specifies the unit number to which the
* header information should be printed.
*
* PATH (input) CHARACTER*3.
* On entry, PATH contains the name of the path for which the
* header information is to be printed. Current paths are
*
* SHS, CHS: Non-symmetric eigenproblem.
* SST, CST: Symmetric eigenproblem.
* SSG, CSG: Symmetric Generalized eigenproblem.
* SBD, CBD: Singular Value Decomposition (SVD)
* SBB, CBB: General Banded reduction to bidiagonal form
*
* These paths also are supplied in double precision (replace
* leading S by D and leading C by Z in path names).
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL CORZ, SORD
CHARACTER*2 C2
INTEGER J
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Executable Statements ..
*
IF( IOUNIT.LE.0 )
$ RETURN
SORD = LSAME( PATH, 'S' ) .OR. LSAME( PATH, 'D' )
CORZ = LSAME( PATH, 'C' ) .OR. LSAME( PATH, 'Z' )
IF( .NOT.SORD .AND. .NOT.CORZ ) THEN
WRITE( IOUNIT, FMT = 9999 )PATH
END IF
C2 = PATH( 2: 3 )
*
IF( LSAMEN( 2, C2, 'HS' ) ) THEN
IF( SORD ) THEN
*
* Real Non-symmetric Eigenvalue Problem:
*
WRITE( IOUNIT, FMT = 9998 )PATH
*
* Matrix types
*
WRITE( IOUNIT, FMT = 9988 )
WRITE( IOUNIT, FMT = 9987 )
WRITE( IOUNIT, FMT = 9986 )'pairs ', 'pairs ', 'prs.',
$ 'prs.'
WRITE( IOUNIT, FMT = 9985 )
*
* Tests performed
*
WRITE( IOUNIT, FMT = 9984 )'orthogonal', '''=transpose',
$ ( '''', J = 1, 6 )
*
ELSE
*
* Complex Non-symmetric Eigenvalue Problem:
*
WRITE( IOUNIT, FMT = 9997 )PATH
*
* Matrix types
*
WRITE( IOUNIT, FMT = 9988 )
WRITE( IOUNIT, FMT = 9987 )
WRITE( IOUNIT, FMT = 9986 )'e.vals', 'e.vals', 'e.vs',
$ 'e.vs'
WRITE( IOUNIT, FMT = 9985 )
*
* Tests performed
*
WRITE( IOUNIT, FMT = 9984 )'unitary', '*=conj.transp.',
$ ( '*', J = 1, 6 )
END IF
*
ELSE IF( LSAMEN( 2, C2, 'ST' ) ) THEN
*
IF( SORD ) THEN
*
* Real Symmetric Eigenvalue Problem:
*
WRITE( IOUNIT, FMT = 9996 )PATH
*
* Matrix types
*
WRITE( IOUNIT, FMT = 9983 )
WRITE( IOUNIT, FMT = 9982 )
WRITE( IOUNIT, FMT = 9981 )'Symmetric'
*
* Tests performed
*
WRITE( IOUNIT, FMT = 9968 )
*
ELSE
*
* Complex Hermitian Eigenvalue Problem:
*
WRITE( IOUNIT, FMT = 9995 )PATH
*
* Matrix types
*
WRITE( IOUNIT, FMT = 9983 )
WRITE( IOUNIT, FMT = 9982 )
WRITE( IOUNIT, FMT = 9981 )'Hermitian'
*
* Tests performed
*
WRITE( IOUNIT, FMT = 9967 )
END IF
*
ELSE IF( LSAMEN( 2, C2, 'SG' ) ) THEN
*
IF( SORD ) THEN
*
* Real Symmetric Generalized Eigenvalue Problem:
*
WRITE( IOUNIT, FMT = 9992 )PATH
*
* Matrix types
*
WRITE( IOUNIT, FMT = 9980 )
WRITE( IOUNIT, FMT = 9979 )
WRITE( IOUNIT, FMT = 9978 )'Symmetric'
*
* Tests performed
*
WRITE( IOUNIT, FMT = 9977 )
WRITE( IOUNIT, FMT = 9976 )
*
ELSE
*
* Complex Hermitian Generalized Eigenvalue Problem:
*
WRITE( IOUNIT, FMT = 9991 )PATH
*
* Matrix types
*
WRITE( IOUNIT, FMT = 9980 )
WRITE( IOUNIT, FMT = 9979 )
WRITE( IOUNIT, FMT = 9978 )'Hermitian'
*
* Tests performed
*
WRITE( IOUNIT, FMT = 9975 )
WRITE( IOUNIT, FMT = 9974 )
*
END IF
*
ELSE IF( LSAMEN( 2, C2, 'BD' ) ) THEN
*
IF( SORD ) THEN
*
* Real Singular Value Decomposition:
*
WRITE( IOUNIT, FMT = 9994 )PATH
*
* Matrix types
*
WRITE( IOUNIT, FMT = 9973 )
*
* Tests performed
*
WRITE( IOUNIT, FMT = 9972 )'orthogonal'
WRITE( IOUNIT, FMT = 9971 )
ELSE
*
* Complex Singular Value Decomposition:
*
WRITE( IOUNIT, FMT = 9993 )PATH
*
* Matrix types
*
WRITE( IOUNIT, FMT = 9973 )
*
* Tests performed
*
WRITE( IOUNIT, FMT = 9972 )'unitary '
WRITE( IOUNIT, FMT = 9971 )
END IF
*
ELSE IF( LSAMEN( 2, C2, 'BB' ) ) THEN
*
IF( SORD ) THEN
*
* Real General Band reduction to bidiagonal form:
*
WRITE( IOUNIT, FMT = 9990 )PATH
*
* Matrix types
*
WRITE( IOUNIT, FMT = 9970 )
*
* Tests performed
*
WRITE( IOUNIT, FMT = 9969 )'orthogonal'
ELSE
*
* Complex Band reduction to bidiagonal form:
*
WRITE( IOUNIT, FMT = 9989 )PATH
*
* Matrix types
*
WRITE( IOUNIT, FMT = 9970 )
*
* Tests performed
*
WRITE( IOUNIT, FMT = 9969 )'unitary '
END IF
*
ELSE
*
WRITE( IOUNIT, FMT = 9999 )PATH
RETURN
END IF
*
RETURN
*
9999 FORMAT( 1X, A3, ': no header available' )
9998 FORMAT( / 1X, A3, ' -- Real Non-symmetric eigenvalue problem' )
9997 FORMAT( / 1X, A3, ' -- Complex Non-symmetric eigenvalue problem' )
9996 FORMAT( / 1X, A3, ' -- Real Symmetric eigenvalue problem' )
9995 FORMAT( / 1X, A3, ' -- Complex Hermitian eigenvalue problem' )
9994 FORMAT( / 1X, A3, ' -- Real Singular Value Decomposition' )
9993 FORMAT( / 1X, A3, ' -- Complex Singular Value Decomposition' )
9992 FORMAT( / 1X, A3, ' -- Real Symmetric Generalized eigenvalue ',
$ 'problem' )
9991 FORMAT( / 1X, A3, ' -- Complex Hermitian Generalized eigenvalue ',
$ 'problem' )
9990 FORMAT( / 1X, A3, ' -- Real Band reduc. to bidiagonal form' )
9989 FORMAT( / 1X, A3, ' -- Complex Band reduc. to bidiagonal form' )
*
9988 FORMAT( ' Matrix types (see xCHKHS for details): ' )
*
9987 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ',
$ ' ', ' 5=Diagonal: geometr. spaced entries.',
$ / ' 2=Identity matrix. ', ' 6=Diagona',
$ 'l: clustered entries.', / ' 3=Transposed Jordan block. ',
$ ' ', ' 7=Diagonal: large, evenly spaced.', / ' ',
$ '4=Diagonal: evenly spaced entries. ', ' 8=Diagonal: s',
$ 'mall, evenly spaced.' )
9986 FORMAT( ' Dense, Non-Symmetric Matrices:', / ' 9=Well-cond., ev',
$ 'enly spaced eigenvals.', ' 14=Ill-cond., geomet. spaced e',
$ 'igenals.', / ' 10=Well-cond., geom. spaced eigenvals. ',
$ ' 15=Ill-conditioned, clustered e.vals.', / ' 11=Well-cond',
$ 'itioned, clustered e.vals. ', ' 16=Ill-cond., random comp',
$ 'lex ', A6, / ' 12=Well-cond., random complex ', A6, ' ',
$ ' 17=Ill-cond., large rand. complx ', A4, / ' 13=Ill-condi',
$ 'tioned, evenly spaced. ', ' 18=Ill-cond., small rand.',
$ ' complx ', A4 )
9985 FORMAT( ' 19=Matrix with random O(1) entries. ', ' 21=Matrix ',
$ 'with small random entries.', / ' 20=Matrix with large ran',
$ 'dom entries. ' )
9984 FORMAT( / ' Tests performed: ', '(H is Hessenberg, T is Schur,',
$ ' U and Z are ', A, ',', / 20X, A, ', W is a diagonal matr',
$ 'ix of eigenvalues,', / 20X, 'L and R are the left and rig',
$ 'ht eigenvector matrices)', / ' 1 = | A - U H U', A1, ' |',
$ ' / ( |A| n ulp ) ', ' 2 = | I - U U', A1, ' | / ',
$ '( n ulp )', / ' 3 = | H - Z T Z', A1, ' | / ( |H| n ulp ',
$ ') ', ' 4 = | I - Z Z', A1, ' | / ( n ulp )',
$ / ' 5 = | A - UZ T (UZ)', A1, ' | / ( |A| n ulp ) ',
$ ' 6 = | I - UZ (UZ)', A1, ' | / ( n ulp )', / ' 7 = | T(',
$ 'e.vects.) - T(no e.vects.) | / ( |T| ulp )', / ' 8 = | W',
$ '(e.vects.) - W(no e.vects.) | / ( |W| ulp )', / ' 9 = | ',
$ 'TR - RW | / ( |T| |R| ulp ) ', ' 10 = | LT - WL | / (',
$ ' |T| |L| ulp )', / ' 11= |HX - XW| / (|H| |X| ulp) (inv.',
$ 'it)', ' 12= |YH - WY| / (|H| |Y| ulp) (inv.it)' )
*
* Symmetric/Hermitian eigenproblem
*
9983 FORMAT( ' Matrix types (see xDRVST for details): ' )
*
9982 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ',
$ ' ', ' 5=Diagonal: clustered entries.', / ' 2=',
$ 'Identity matrix. ', ' 6=Diagonal: lar',
$ 'ge, evenly spaced.', / ' 3=Diagonal: evenly spaced entri',
$ 'es. ', ' 7=Diagonal: small, evenly spaced.', / ' 4=D',
$ 'iagonal: geometr. spaced entries.' )
9981 FORMAT( ' Dense ', A, ' Matrices:', / ' 8=Evenly spaced eigen',
$ 'vals. ', ' 12=Small, evenly spaced eigenvals.',
$ / ' 9=Geometrically spaced eigenvals. ', ' 13=Matrix ',
$ 'with random O(1) entries.', / ' 10=Clustered eigenvalues.',
$ ' ', ' 14=Matrix with large random entries.',
$ / ' 11=Large, evenly spaced eigenvals. ', ' 15=Matrix ',
$ 'with small random entries.' )
*
* Symmetric/Hermitian Generalized eigenproblem
*
9980 FORMAT( ' Matrix types (see xDRVSG for details): ' )
*
9979 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ',
$ ' ', ' 5=Diagonal: clustered entries.', / ' 2=',
$ 'Identity matrix. ', ' 6=Diagonal: lar',
$ 'ge, evenly spaced.', / ' 3=Diagonal: evenly spaced entri',
$ 'es. ', ' 7=Diagonal: small, evenly spaced.', / ' 4=D',
$ 'iagonal: geometr. spaced entries.' )
9978 FORMAT( ' Dense or Banded ', A, ' Matrices: ',
$ / ' 8=Evenly spaced eigenvals. ',
$ ' 15=Matrix with small random entries.',
$ / ' 9=Geometrically spaced eigenvals. ',
$ ' 16=Evenly spaced eigenvals, KA=1, KB=1.',
$ / ' 10=Clustered eigenvalues. ',
$ ' 17=Evenly spaced eigenvals, KA=2, KB=1.',
$ / ' 11=Large, evenly spaced eigenvals. ',
$ ' 18=Evenly spaced eigenvals, KA=2, KB=2.',
$ / ' 12=Small, evenly spaced eigenvals. ',
$ ' 19=Evenly spaced eigenvals, KA=3, KB=1.',
$ / ' 13=Matrix with random O(1) entries. ',
$ ' 20=Evenly spaced eigenvals, KA=3, KB=2.',
$ / ' 14=Matrix with large random entries.',
$ ' 21=Evenly spaced eigenvals, KA=3, KB=3.' )
9977 FORMAT( / ' Tests performed: ',
$ / '( For each pair (A,B), where A is of the given type ',
$ / ' and B is a random well-conditioned matrix. D is ',
$ / ' diagonal, and Z is orthogonal. )',
$ / ' 1 = SSYGV, with ITYPE=1 and UPLO=''U'':',
$ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
$ / ' 2 = SSPGV, with ITYPE=1 and UPLO=''U'':',
$ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
$ / ' 3 = SSBGV, with ITYPE=1 and UPLO=''U'':',
$ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
$ / ' 4 = SSYGV, with ITYPE=1 and UPLO=''L'':',
$ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
$ / ' 5 = SSPGV, with ITYPE=1 and UPLO=''L'':',
$ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
$ / ' 6 = SSBGV, with ITYPE=1 and UPLO=''L'':',
$ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ' )
9976 FORMAT( ' 7 = SSYGV, with ITYPE=2 and UPLO=''U'':',
$ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
$ / ' 8 = SSPGV, with ITYPE=2 and UPLO=''U'':',
$ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
$ / ' 9 = SSPGV, with ITYPE=2 and UPLO=''L'':',
$ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
$ / '10 = SSPGV, with ITYPE=2 and UPLO=''L'':',
$ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
$ / '11 = SSYGV, with ITYPE=3 and UPLO=''U'':',
$ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ',
$ / '12 = SSPGV, with ITYPE=3 and UPLO=''U'':',
$ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ',
$ / '13 = SSYGV, with ITYPE=3 and UPLO=''L'':',
$ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ',
$ / '14 = SSPGV, with ITYPE=3 and UPLO=''L'':',
$ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ' )
9975 FORMAT( / ' Tests performed: ',
$ / '( For each pair (A,B), where A is of the given type ',
$ / ' and B is a random well-conditioned matrix. D is ',
$ / ' diagonal, and Z is unitary. )',
$ / ' 1 = CHEGV, with ITYPE=1 and UPLO=''U'':',
$ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
$ / ' 2 = CHPGV, with ITYPE=1 and UPLO=''U'':',
$ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
$ / ' 3 = CHBGV, with ITYPE=1 and UPLO=''U'':',
$ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
$ / ' 4 = CHEGV, with ITYPE=1 and UPLO=''L'':',
$ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
$ / ' 5 = CHPGV, with ITYPE=1 and UPLO=''L'':',
$ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
$ / ' 6 = CHBGV, with ITYPE=1 and UPLO=''L'':',
$ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ' )
9974 FORMAT( ' 7 = CHEGV, with ITYPE=2 and UPLO=''U'':',
$ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
$ / ' 8 = CHPGV, with ITYPE=2 and UPLO=''U'':',
$ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
$ / ' 9 = CHPGV, with ITYPE=2 and UPLO=''L'':',
$ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
$ / '10 = CHPGV, with ITYPE=2 and UPLO=''L'':',
$ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
$ / '11 = CHEGV, with ITYPE=3 and UPLO=''U'':',
$ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ',
$ / '12 = CHPGV, with ITYPE=3 and UPLO=''U'':',
$ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ',
$ / '13 = CHEGV, with ITYPE=3 and UPLO=''L'':',
$ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ',
$ / '14 = CHPGV, with ITYPE=3 and UPLO=''L'':',
$ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ' )
*
* Singular Value Decomposition
*
9973 FORMAT( ' Matrix types (see xCHKBD for details):',
$ / ' Diagonal matrices:', / ' 1: Zero', 28X,
$ ' 5: Clustered entries', / ' 2: Identity', 24X,
$ ' 6: Large, evenly spaced entries',
$ / ' 3: Evenly spaced entries', 11X,
$ ' 7: Small, evenly spaced entries',
$ / ' 4: Geometrically spaced entries',
$ / ' General matrices:', / ' 8: Evenly spaced sing. vals.',
$ 7X, '12: Small, evenly spaced sing vals',
$ / ' 9: Geometrically spaced sing vals ',
$ '13: Random, O(1) entries', / ' 10: Clustered sing. vals.',
$ 11X, '14: Random, scaled near overflow',
$ / ' 11: Large, evenly spaced sing vals ',
$ '15: Random, scaled near underflow' )
*
9972 FORMAT( / ' Test ratios: ',
$ '(B: bidiagonal, S: diagonal, Q, P, U, and V: ', A10, / 16X,
$ 'X: m x nrhs, Y = Q'' X, and Z = U'' Y)',
$ / ' 1: norm( A - Q B P'' ) / ( norm(A) max(m,n) ulp )',
$ / ' 2: norm( I - Q'' Q ) / ( m ulp )',
$ / ' 3: norm( I - P'' P ) / ( n ulp )',
$ / ' 4: norm( B - U S V'' ) / ( norm(B) min(m,n) ulp )', /
$ ' 5: norm( Y - U Z ) / ( norm(Z) max(min(m,n),k) ulp )'
$ , / ' 6: norm( I - U'' U ) / ( min(m,n) ulp )',
$ / ' 7: norm( I - V'' V ) / ( min(m,n) ulp )' )
9971 FORMAT( ' 8: Test ordering of S (0 if nondecreasing, 1/ulp ',
$ ' otherwise)', /
$ ' 9: norm( S - S2 ) / ( norm(S) ulp ),',
$ ' where S2 is computed', / 44X,
$ 'without computing U and V''',
$ / ' 10: Sturm sequence test ',
$ '(0 if sing. vals of B within THRESH of S)',
$ / ' 11: norm( A - (QU) S (V'' P'') ) / ',
$ '( norm(A) max(m,n) ulp )', /
$ ' 12: norm( X - (QU) Z ) / ( |X| max(M,k) ulp )',
$ / ' 13: norm( I - (QU)''(QU) ) / ( M ulp )',
$ / ' 14: norm( I - (V'' P'') (P V) ) / ( N ulp )' )
*
* Band reduction to bidiagonal form
*
9970 FORMAT( ' Matrix types (see xCHKBB for details):',
$ / ' Diagonal matrices:', / ' 1: Zero', 28X,
$ ' 5: Clustered entries', / ' 2: Identity', 24X,
$ ' 6: Large, evenly spaced entries',
$ / ' 3: Evenly spaced entries', 11X,
$ ' 7: Small, evenly spaced entries',
$ / ' 4: Geometrically spaced entries',
$ / ' General matrices:', / ' 8: Evenly spaced sing. vals.',
$ 7X, '12: Small, evenly spaced sing vals',
$ / ' 9: Geometrically spaced sing vals ',
$ '13: Random, O(1) entries', / ' 10: Clustered sing. vals.',
$ 11X, '14: Random, scaled near overflow',
$ / ' 11: Large, evenly spaced sing vals ',
$ '15: Random, scaled near underflow' )
*
9969 FORMAT( / ' Test ratios: ', '(B: upper bidiagonal, Q and P: ',
$ A10, / 16X, 'C: m x nrhs, PT = P'', Y = Q'' C)',
$ / ' 1: norm( A - Q B PT ) / ( norm(A) max(m,n) ulp )',
$ / ' 2: norm( I - Q'' Q ) / ( m ulp )',
$ / ' 3: norm( I - PT PT'' ) / ( n ulp )',
$ / ' 4: norm( Y - Q'' C ) / ( norm(Y) max(m,nrhs) ulp )' )
9968 FORMAT( / ' Tests performed: See sdrvst.f' )
9967 FORMAT( / ' Tests performed: See cdrvst.f' )
*
* End of SLAHD2
*
END
SUBROUTINE SLARFY( UPLO, N, V, INCV, TAU, C, LDC, WORK )
*
* -- LAPACK auxiliary test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INCV, LDC, N
REAL TAU
* ..
* .. Array Arguments ..
REAL C( LDC, * ), V( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SLARFY applies an elementary reflector, or Householder matrix, H,
* to an n x n symmetric matrix C, from both the left and the right.
*
* H is represented in the form
*
* H = I - tau * v * v'
*
* where tau is a scalar and v is a vector.
*
* If tau is zero, then H is taken to be the unit matrix.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix C is stored.
* = 'U': Upper triangle
* = 'L': Lower triangle
*
* N (input) INTEGER
* The number of rows and columns of the matrix C. N >= 0.
*
* V (input) REAL array, dimension
* (1 + (N-1)*abs(INCV))
* The vector v as described above.
*
* INCV (input) INTEGER
* The increment between successive elements of v. INCV must
* not be zero.
*
* TAU (input) REAL
* The value tau as described above.
*
* C (input/output) REAL array, dimension (LDC, N)
* On entry, the matrix C.
* On exit, C is overwritten by H * C * H'.
*
* LDC (input) INTEGER
* The leading dimension of the array C. LDC >= max( 1, N ).
*
* WORK (workspace) REAL array, dimension (N)
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO, HALF
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0, HALF = 0.5E+0 )
* ..
* .. Local Scalars ..
REAL ALPHA
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SSYMV, SSYR2
* ..
* .. External Functions ..
REAL SDOT
EXTERNAL SDOT
* ..
* .. Executable Statements ..
*
IF( TAU.EQ.ZERO )
$ RETURN
*
* Form w:= C * v
*
CALL SSYMV( UPLO, N, ONE, C, LDC, V, INCV, ZERO, WORK, 1 )
*
ALPHA = -HALF*TAU*SDOT( N, WORK, 1, V, INCV )
CALL SAXPY( N, ALPHA, V, INCV, WORK, 1 )
*
* C := C - v * w' - w * v'
*
CALL SSYR2( UPLO, N, -TAU, V, INCV, WORK, 1, C, LDC )
*
RETURN
*
* End of SLARFY
*
END
SUBROUTINE SLARHS( PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS,
$ A, LDA, X, LDX, B, LDB, ISEED, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS, UPLO, XTYPE
CHARACTER*3 PATH
INTEGER INFO, KL, KU, LDA, LDB, LDX, M, N, NRHS
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
REAL A( LDA, * ), B( LDB, * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* SLARHS chooses a set of NRHS random solution vectors and sets
* up the right hand sides for the linear system
* op( A ) * X = B,
* where op( A ) may be A or A' (transpose of A).
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The type of the real matrix A. PATH may be given in any
* combination of upper and lower case. Valid types include
* xGE: General m x n matrix
* xGB: General banded matrix
* xPO: Symmetric positive definite, 2-D storage
* xPP: Symmetric positive definite packed
* xPB: Symmetric positive definite banded
* xSY: Symmetric indefinite, 2-D storage
* xSP: Symmetric indefinite packed
* xSB: Symmetric indefinite banded
* xTR: Triangular
* xTP: Triangular packed
* xTB: Triangular banded
* xQR: General m x n matrix
* xLQ: General m x n matrix
* xQL: General m x n matrix
* xRQ: General m x n matrix
* where the leading character indicates the precision.
*
* XTYPE (input) CHARACTER*1
* Specifies how the exact solution X will be determined:
* = 'N': New solution; generate a random X.
* = 'C': Computed; use value of X on entry.
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* matrix A is stored, if A is symmetric.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the operation applied to the matrix A.
* = 'N': System is A * x = b
* = 'T': System is A'* x = b
* = 'C': System is A'* x = b
*
* M (input) INTEGER
* The number or rows of the matrix A. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix A. N >= 0.
*
* KL (input) INTEGER
* Used only if A is a band matrix; specifies the number of
* subdiagonals of A if A is a general band matrix or if A is
* symmetric or triangular and UPLO = 'L'; specifies the number
* of superdiagonals of A if A is symmetric or triangular and
* UPLO = 'U'. 0 <= KL <= M-1.
*
* KU (input) INTEGER
* Used only if A is a general band matrix or if A is
* triangular.
*
* If PATH = xGB, specifies the number of superdiagonals of A,
* and 0 <= KU <= N-1.
*
* If PATH = xTR, xTP, or xTB, specifies whether or not the
* matrix has unit diagonal:
* = 1: matrix has non-unit diagonal (default)
* = 2: matrix has unit diagonal
*
* NRHS (input) INTEGER
* The number of right hand side vectors in the system A*X = B.
*
* A (input) REAL array, dimension (LDA,N)
* The test matrix whose type is given by PATH.
*
* LDA (input) INTEGER
* The leading dimension of the array A.
* If PATH = xGB, LDA >= KL+KU+1.
* If PATH = xPB, xSB, xHB, or xTB, LDA >= KL+1.
* Otherwise, LDA >= max(1,M).
*
* X (input or output) REAL array, dimension(LDX,NRHS)
* On entry, if XTYPE = 'C' (for 'Computed'), then X contains
* the exact solution to the system of linear equations.
* On exit, if XTYPE = 'N' (for 'New'), then X is initialized
* with random values.
*
* LDX (input) INTEGER
* The leading dimension of the array X. If TRANS = 'N',
* LDX >= max(1,N); if TRANS = 'T', LDX >= max(1,M).
*
* B (output) REAL array, dimension (LDB,NRHS)
* The right hand side vector(s) for the system of equations,
* computed from B = op(A) * X, where op(A) is determined by
* TRANS.
*
* LDB (input) INTEGER
* The leading dimension of the array B. If TRANS = 'N',
* LDB >= max(1,M); if TRANS = 'T', LDB >= max(1,N).
*
* ISEED (input/output) INTEGER array, dimension (4)
* The seed vector for the random number generator (used in
* SLATMS). Modified on exit.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL BAND, GEN, NOTRAN, QRS, SYM, TRAN, TRI
CHARACTER C1, DIAG
CHARACTER*2 C2
INTEGER J, MB, NX
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL SGBMV, SGEMM, SLACPY, SLARNV, SSBMV, SSPMV,
$ SSYMM, STBMV, STPMV, STRMM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
C1 = PATH( 1: 1 )
C2 = PATH( 2: 3 )
TRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
NOTRAN = .NOT.TRAN
GEN = LSAME( PATH( 2: 2 ), 'G' )
QRS = LSAME( PATH( 2: 2 ), 'Q' ) .OR. LSAME( PATH( 3: 3 ), 'Q' )
SYM = LSAME( PATH( 2: 2 ), 'P' ) .OR. LSAME( PATH( 2: 2 ), 'S' )
TRI = LSAME( PATH( 2: 2 ), 'T' )
BAND = LSAME( PATH( 3: 3 ), 'B' )
IF( .NOT.LSAME( C1, 'Single precision' ) ) THEN
INFO = -1
ELSE IF( .NOT.( LSAME( XTYPE, 'N' ) .OR. LSAME( XTYPE, 'C' ) ) )
$ THEN
INFO = -2
ELSE IF( ( SYM .OR. TRI ) .AND. .NOT.
$ ( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) THEN
INFO = -3
ELSE IF( ( GEN .OR. QRS ) .AND. .NOT.
$ ( TRAN .OR. LSAME( TRANS, 'N' ) ) ) THEN
INFO = -4
ELSE IF( M.LT.0 ) THEN
INFO = -5
ELSE IF( N.LT.0 ) THEN
INFO = -6
ELSE IF( BAND .AND. KL.LT.0 ) THEN
INFO = -7
ELSE IF( BAND .AND. KU.LT.0 ) THEN
INFO = -8
ELSE IF( NRHS.LT.0 ) THEN
INFO = -9
ELSE IF( ( .NOT.BAND .AND. LDA.LT.MAX( 1, M ) ) .OR.
$ ( BAND .AND. ( SYM .OR. TRI ) .AND. LDA.LT.KL+1 ) .OR.
$ ( BAND .AND. GEN .AND. LDA.LT.KL+KU+1 ) ) THEN
INFO = -11
ELSE IF( ( NOTRAN .AND. LDX.LT.MAX( 1, N ) ) .OR.
$ ( TRAN .AND. LDX.LT.MAX( 1, M ) ) ) THEN
INFO = -13
ELSE IF( ( NOTRAN .AND. LDB.LT.MAX( 1, M ) ) .OR.
$ ( TRAN .AND. LDB.LT.MAX( 1, N ) ) ) THEN
INFO = -15
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLARHS', -INFO )
RETURN
END IF
*
* Initialize X to NRHS random vectors unless XTYPE = 'C'.
*
IF( TRAN ) THEN
NX = M
MB = N
ELSE
NX = N
MB = M
END IF
IF( .NOT.LSAME( XTYPE, 'C' ) ) THEN
DO 10 J = 1, NRHS
CALL SLARNV( 2, ISEED, N, X( 1, J ) )
10 CONTINUE
END IF
*
* Multiply X by op( A ) using an appropriate
* matrix multiply routine.
*
IF( LSAMEN( 2, C2, 'GE' ) .OR. LSAMEN( 2, C2, 'QR' ) .OR.
$ LSAMEN( 2, C2, 'LQ' ) .OR. LSAMEN( 2, C2, 'QL' ) .OR.
$ LSAMEN( 2, C2, 'RQ' ) ) THEN
*
* General matrix
*
CALL SGEMM( TRANS, 'N', MB, NRHS, NX, ONE, A, LDA, X, LDX,
$ ZERO, B, LDB )
*
ELSE IF( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'SY' ) ) THEN
*
* Symmetric matrix, 2-D storage
*
CALL SSYMM( 'Left', UPLO, N, NRHS, ONE, A, LDA, X, LDX, ZERO,
$ B, LDB )
*
ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
*
* General matrix, band storage
*
DO 20 J = 1, NRHS
CALL SGBMV( TRANS, MB, NX, KL, KU, ONE, A, LDA, X( 1, J ),
$ 1, ZERO, B( 1, J ), 1 )
20 CONTINUE
*
ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN
*
* Symmetric matrix, band storage
*
DO 30 J = 1, NRHS
CALL SSBMV( UPLO, N, KL, ONE, A, LDA, X( 1, J ), 1, ZERO,
$ B( 1, J ), 1 )
30 CONTINUE
*
ELSE IF( LSAMEN( 2, C2, 'PP' ) .OR. LSAMEN( 2, C2, 'SP' ) ) THEN
*
* Symmetric matrix, packed storage
*
DO 40 J = 1, NRHS
CALL SSPMV( UPLO, N, ONE, A, X( 1, J ), 1, ZERO, B( 1, J ),
$ 1 )
40 CONTINUE
*
ELSE IF( LSAMEN( 2, C2, 'TR' ) ) THEN
*
* Triangular matrix. Note that for triangular matrices,
* KU = 1 => non-unit triangular
* KU = 2 => unit triangular
*
CALL SLACPY( 'Full', N, NRHS, X, LDX, B, LDB )
IF( KU.EQ.2 ) THEN
DIAG = 'U'
ELSE
DIAG = 'N'
END IF
CALL STRMM( 'Left', UPLO, TRANS, DIAG, N, NRHS, ONE, A, LDA, B,
$ LDB )
*
ELSE IF( LSAMEN( 2, C2, 'TP' ) ) THEN
*
* Triangular matrix, packed storage
*
CALL SLACPY( 'Full', N, NRHS, X, LDX, B, LDB )
IF( KU.EQ.2 ) THEN
DIAG = 'U'
ELSE
DIAG = 'N'
END IF
DO 50 J = 1, NRHS
CALL STPMV( UPLO, TRANS, DIAG, N, A, B( 1, J ), 1 )
50 CONTINUE
*
ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
*
* Triangular matrix, banded storage
*
CALL SLACPY( 'Full', N, NRHS, X, LDX, B, LDB )
IF( KU.EQ.2 ) THEN
DIAG = 'U'
ELSE
DIAG = 'N'
END IF
DO 60 J = 1, NRHS
CALL STBMV( UPLO, TRANS, DIAG, N, KL, A, LDA, B( 1, J ), 1 )
60 CONTINUE
*
ELSE
*
* If PATH is none of the above, return with an error code.
*
INFO = -1
CALL XERBLA( 'SLARHS', -INFO )
END IF
*
RETURN
*
* End of SLARHS
*
END
SUBROUTINE SLASUM( TYPE, IOUNIT, IE, NRUN )
*
* -- LAPACK auxiliary test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 TYPE
INTEGER IE, IOUNIT, NRUN
* ..
*
* Purpose
* =======
*
* SLASUM prints a summary of the results from one of the test routines.
*
* =====================================================================
*
* .. Executable Statements ..
*
IF( IE.GT.0 ) THEN
WRITE( IOUNIT, FMT = 9999 )TYPE, ': ', IE, ' out of ', NRUN,
$ ' tests failed to pass the threshold'
ELSE
WRITE( IOUNIT, FMT = 9998 )'All tests for ', TYPE,
$ ' passed the threshold (', NRUN, ' tests run)'
END IF
9999 FORMAT( 1X, A3, A2, I4, A8, I5, A35 )
9998 FORMAT( / 1X, A14, A3, A23, I5, A11 )
RETURN
*
* End of SLASUM
*
END
SUBROUTINE SLATB9( PATH, IMAT, M, P, N, TYPE, KLA, KUA,
$ KLB, KUB, ANORM, BNORM, MODEA, MODEB,
$ CNDNMA, CNDNMB, DISTA, DISTB )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DISTA, DISTB, TYPE
CHARACTER*3 PATH
INTEGER IMAT, KLA, KUA, KLB, KUB, M, P, MODEA, MODEB, N
REAL ANORM, BNORM, CNDNMA, CNDNMB
* ..
*
* Purpose
* =======
*
* SLATB9 sets parameters for the matrix generator based on the type of
* matrix to be generated.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name.
*
* IMAT (input) INTEGER
* An integer key describing which matrix to generate for this
* path.
*
* M (input) INTEGER
* The number of rows in the matrix to be generated.
*
* N (input) INTEGER
* The number of columns in the matrix to be generated.
*
* TYPE (output) CHARACTER*1
* The type of the matrix to be generated:
* = 'S': symmetric matrix;
* = 'P': symmetric positive (semi)definite matrix;
* = 'N': nonsymmetric matrix.
*
* KL (output) INTEGER
* The lower band width of the matrix to be generated.
*
* KU (output) INTEGER
* The upper band width of the matrix to be generated.
*
* ANORM (output) REAL
* The desired norm of the matrix to be generated. The diagonal
* matrix of singular values or eigenvalues is scaled by this
* value.
*
* MODE (output) INTEGER
* A key indicating how to choose the vector of eigenvalues.
*
* CNDNUM (output) REAL
* The desired condition number.
*
* DIST (output) CHARACTER*1
* The type of distribution to be used by the random number
* generator.
*
* =====================================================================
*
* .. Parameters ..
REAL SHRINK, TENTH
PARAMETER ( SHRINK = 0.25E0, TENTH = 0.1E+0 )
REAL ONE, TEN
PARAMETER ( ONE = 1.0E+0, TEN = 1.0E+1 )
* ..
* .. Local Scalars ..
LOGICAL FIRST
REAL BADC1, BADC2, EPS, LARGE, SMALL
* ..
* .. External Functions ..
LOGICAL LSAMEN
REAL SLAMCH
EXTERNAL LSAMEN, SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. External Subroutines ..
EXTERNAL SLABAD
* ..
* .. Save statement ..
SAVE EPS, SMALL, LARGE, BADC1, BADC2, FIRST
* ..
* .. Data statements ..
DATA FIRST / .TRUE. /
* ..
* .. Executable Statements ..
*
* Set some constants for use in the subroutine.
*
IF( FIRST ) THEN
FIRST = .FALSE.
EPS = SLAMCH( 'Precision' )
BADC2 = TENTH / EPS
BADC1 = SQRT( BADC2 )
SMALL = SLAMCH( 'Safe minimum' )
LARGE = ONE / SMALL
*
* If it looks like we're on a Cray, take the square root of
* SMALL and LARGE to avoid overflow and underflow problems.
*
CALL SLABAD( SMALL, LARGE )
SMALL = SHRINK*( SMALL / EPS )
LARGE = ONE / SMALL
END IF
*
* Set some parameters we don't plan to change.
*
TYPE = 'N'
DISTA = 'S'
DISTB = 'S'
MODEA = 3
MODEB = 4
*
* Set the lower and upper bandwidths.
*
IF( LSAMEN( 3, PATH, 'GRQ') .OR. LSAMEN( 3, PATH, 'LSE') .OR.
$ LSAMEN( 3, PATH, 'GSV') )THEN
*
* A: M by N, B: P by N
*
IF( IMAT.EQ.1 ) THEN
*
* A: diagonal, B: upper triangular
*
KLA = 0
KUA = 0
KLB = 0
KUB = MAX( N-1,0 )
*
ELSE IF( IMAT.EQ.2 ) THEN
*
* A: upper triangular, B: upper triangular
*
KLA = 0
KUA = MAX( N-1, 0 )
KLB = 0
KUB = MAX( N-1, 0 )
*
ELSE IF( IMAT.EQ.3 ) THEN
*
* A: lower triangular, B: upper triangular
*
KLA = MAX( M-1, 0 )
KUA = 0
KLB = 0
KUB = MAX( N-1, 0 )
*
ELSE
*
* A: general dense, B: general dense
*
KLA = MAX( M-1, 0 )
KUA = MAX( N-1, 0 )
KLB = MAX( P-1, 0 )
KUB = MAX( N-1, 0 )
*
END IF
*
ELSE IF( LSAMEN( 3, PATH, 'GQR' ) .OR.
$ LSAMEN( 3, PATH, 'GLM') )THEN
*
* A: N by M, B: N by P
*
IF( IMAT.EQ.1 ) THEN
*
* A: diagonal, B: lower triangular
*
KLA = 0
KUA = 0
KLB = MAX( N-1,0 )
KUB = 0
ELSE IF( IMAT.EQ.2 ) THEN
*
* A: lower triangular, B: diagonal
*
KLA = MAX( N-1, 0 )
KUA = 0
KLB = 0
KUB = 0
*
ELSE IF( IMAT.EQ.3 ) THEN
*
* A: lower triangular, B: upper triangular
*
KLA = MAX( N-1, 0 )
KUA = 0
KLB = 0
KUB = MAX( P-1, 0 )
*
ELSE
*
* A: general dense, B: general dense
*
KLA = MAX( N-1, 0 )
KUA = MAX( M-1, 0 )
KLB = MAX( N-1, 0 )
KUB = MAX( P-1, 0 )
END IF
*
END IF
*
* Set the condition number and norm.
*
CNDNMA = TEN*TEN
CNDNMB = TEN
IF( LSAMEN( 3, PATH, 'GQR') .OR. LSAMEN( 3, PATH, 'GRQ') .OR.
$ LSAMEN( 3, PATH, 'GSV') )THEN
IF( IMAT.EQ.5 ) THEN
CNDNMA = BADC1
CNDNMB = BADC1
ELSE IF( IMAT.EQ.6 ) THEN
CNDNMA = BADC2
CNDNMB = BADC2
ELSE IF( IMAT.EQ.7 ) THEN
CNDNMA = BADC1
CNDNMB = BADC2
ELSE IF( IMAT.EQ.8 ) THEN
CNDNMA = BADC2
CNDNMB = BADC1
END IF
END IF
*
ANORM = TEN
BNORM = TEN*TEN*TEN
IF( LSAMEN( 3, PATH, 'GQR') .OR. LSAMEN( 3, PATH, 'GRQ') )THEN
IF( IMAT.EQ.7 ) THEN
ANORM = SMALL
BNORM = LARGE
ELSE IF( IMAT.EQ.8 ) THEN
ANORM = LARGE
BNORM = SMALL
END IF
END IF
*
IF( N.LE.1 )THEN
CNDNMA = ONE
CNDNMB = ONE
END IF
*
RETURN
*
* End of SLATB9
*
END
SUBROUTINE SLATM4( ITYPE, N, NZ1, NZ2, ISIGN, AMAGN, RCOND,
$ TRIANG, IDIST, ISEED, A, LDA )
*
* -- LAPACK auxiliary test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IDIST, ISIGN, ITYPE, LDA, N, NZ1, NZ2
REAL AMAGN, RCOND, TRIANG
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
REAL A( LDA, * )
* ..
*
* Purpose
* =======
*
* SLATM4 generates basic square matrices, which may later be
* multiplied by others in order to produce test matrices. It is
* intended mainly to be used to test the generalized eigenvalue
* routines.
*
* It first generates the diagonal and (possibly) subdiagonal,
* according to the value of ITYPE, NZ1, NZ2, ISIGN, AMAGN, and RCOND.
* It then fills in the upper triangle with random numbers, if TRIANG is
* non-zero.
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* The "type" of matrix on the diagonal and sub-diagonal.
* If ITYPE < 0, then type abs(ITYPE) is generated and then
* swapped end for end (A(I,J) := A'(N-J,N-I).) See also
* the description of AMAGN and ISIGN.
*
* Special types:
* = 0: the zero matrix.
* = 1: the identity.
* = 2: a transposed Jordan block.
* = 3: If N is odd, then a k+1 x k+1 transposed Jordan block
* followed by a k x k identity block, where k=(N-1)/2.
* If N is even, then k=(N-2)/2, and a zero diagonal entry
* is tacked onto the end.
*
* Diagonal types. The diagonal consists of NZ1 zeros, then
* k=N-NZ1-NZ2 nonzeros. The subdiagonal is zero. ITYPE
* specifies the nonzero diagonal entries as follows:
* = 4: 1, ..., k
* = 5: 1, RCOND, ..., RCOND
* = 6: 1, ..., 1, RCOND
* = 7: 1, a, a^2, ..., a^(k-1)=RCOND
* = 8: 1, 1-d, 1-2*d, ..., 1-(k-1)*d=RCOND
* = 9: random numbers chosen from (RCOND,1)
* = 10: random numbers with distribution IDIST (see SLARND.)
*
* N (input) INTEGER
* The order of the matrix.
*
* NZ1 (input) INTEGER
* If abs(ITYPE) > 3, then the first NZ1 diagonal entries will
* be zero.
*
* NZ2 (input) INTEGER
* If abs(ITYPE) > 3, then the last NZ2 diagonal entries will
* be zero.
*
* ISIGN (input) INTEGER
* = 0: The sign of the diagonal and subdiagonal entries will
* be left unchanged.
* = 1: The diagonal and subdiagonal entries will have their
* sign changed at random.
* = 2: If ITYPE is 2 or 3, then the same as ISIGN=1.
* Otherwise, with probability 0.5, odd-even pairs of
* diagonal entries A(2*j-1,2*j-1), A(2*j,2*j) will be
* converted to a 2x2 block by pre- and post-multiplying
* by distinct random orthogonal rotations. The remaining
* diagonal entries will have their sign changed at random.
*
* AMAGN (input) REAL
* The diagonal and subdiagonal entries will be multiplied by
* AMAGN.
*
* RCOND (input) REAL
* If abs(ITYPE) > 4, then the smallest diagonal entry will be
* entry will be RCOND. RCOND must be between 0 and 1.
*
* TRIANG (input) REAL
* The entries above the diagonal will be random numbers with
* magnitude bounded by TRIANG (i.e., random numbers multiplied
* by TRIANG.)
*
* IDIST (input) INTEGER
* Specifies the type of distribution to be used to generate a
* random matrix.
* = 1: UNIFORM( 0, 1 )
* = 2: UNIFORM( -1, 1 )
* = 3: NORMAL ( 0, 1 )
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The values of ISEED are changed on exit, and can
* be used in the next call to SLATM4 to continue the same
* random number sequence.
* Note: ISEED(4) should be odd, for the random number generator
* used at present.
*
* A (output) REAL array, dimension (LDA, N)
* Array to be computed.
*
* LDA (input) INTEGER
* Leading dimension of A. Must be at least 1 and at least N.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 )
REAL HALF
PARAMETER ( HALF = ONE / TWO )
* ..
* .. Local Scalars ..
INTEGER I, IOFF, ISDB, ISDE, JC, JD, JR, K, KBEG, KEND,
$ KLEN
REAL ALPHA, CL, CR, SAFMIN, SL, SR, SV1, SV2, TEMP
* ..
* .. External Functions ..
REAL SLAMCH, SLARAN, SLARND
EXTERNAL SLAMCH, SLARAN, SLARND
* ..
* .. External Subroutines ..
EXTERNAL SLASET
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, EXP, LOG, MAX, MIN, MOD, REAL, SQRT
* ..
* .. Executable Statements ..
*
IF( N.LE.0 )
$ RETURN
CALL SLASET( 'Full', N, N, ZERO, ZERO, A, LDA )
*
* Insure a correct ISEED
*
IF( MOD( ISEED( 4 ), 2 ).NE.1 )
$ ISEED( 4 ) = ISEED( 4 ) + 1
*
* Compute diagonal and subdiagonal according to ITYPE, NZ1, NZ2,
* and RCOND
*
IF( ITYPE.NE.0 ) THEN
IF( ABS( ITYPE ).GE.4 ) THEN
KBEG = MAX( 1, MIN( N, NZ1+1 ) )
KEND = MAX( KBEG, MIN( N, N-NZ2 ) )
KLEN = KEND + 1 - KBEG
ELSE
KBEG = 1
KEND = N
KLEN = N
END IF
ISDB = 1
ISDE = 0
GO TO ( 10, 30, 50, 80, 100, 120, 140, 160,
$ 180, 200 )ABS( ITYPE )
*
* abs(ITYPE) = 1: Identity
*
10 CONTINUE
DO 20 JD = 1, N
A( JD, JD ) = ONE
20 CONTINUE
GO TO 220
*
* abs(ITYPE) = 2: Transposed Jordan block
*
30 CONTINUE
DO 40 JD = 1, N - 1
A( JD+1, JD ) = ONE
40 CONTINUE
ISDB = 1
ISDE = N - 1
GO TO 220
*
* abs(ITYPE) = 3: Transposed Jordan block, followed by the
* identity.
*
50 CONTINUE
K = ( N-1 ) / 2
DO 60 JD = 1, K
A( JD+1, JD ) = ONE
60 CONTINUE
ISDB = 1
ISDE = K
DO 70 JD = K + 2, 2*K + 1
A( JD, JD ) = ONE
70 CONTINUE
GO TO 220
*
* abs(ITYPE) = 4: 1,...,k
*
80 CONTINUE
DO 90 JD = KBEG, KEND
A( JD, JD ) = REAL( JD-NZ1 )
90 CONTINUE
GO TO 220
*
* abs(ITYPE) = 5: One large D value:
*
100 CONTINUE
DO 110 JD = KBEG + 1, KEND
A( JD, JD ) = RCOND
110 CONTINUE
A( KBEG, KBEG ) = ONE
GO TO 220
*
* abs(ITYPE) = 6: One small D value:
*
120 CONTINUE
DO 130 JD = KBEG, KEND - 1
A( JD, JD ) = ONE
130 CONTINUE
A( KEND, KEND ) = RCOND
GO TO 220
*
* abs(ITYPE) = 7: Exponentially distributed D values:
*
140 CONTINUE
A( KBEG, KBEG ) = ONE
IF( KLEN.GT.1 ) THEN
ALPHA = RCOND**( ONE / REAL( KLEN-1 ) )
DO 150 I = 2, KLEN
A( NZ1+I, NZ1+I ) = ALPHA**REAL( I-1 )
150 CONTINUE
END IF
GO TO 220
*
* abs(ITYPE) = 8: Arithmetically distributed D values:
*
160 CONTINUE
A( KBEG, KBEG ) = ONE
IF( KLEN.GT.1 ) THEN
ALPHA = ( ONE-RCOND ) / REAL( KLEN-1 )
DO 170 I = 2, KLEN
A( NZ1+I, NZ1+I ) = REAL( KLEN-I )*ALPHA + RCOND
170 CONTINUE
END IF
GO TO 220
*
* abs(ITYPE) = 9: Randomly distributed D values on ( RCOND, 1):
*
180 CONTINUE
ALPHA = LOG( RCOND )
DO 190 JD = KBEG, KEND
A( JD, JD ) = EXP( ALPHA*SLARAN( ISEED ) )
190 CONTINUE
GO TO 220
*
* abs(ITYPE) = 10: Randomly distributed D values from DIST
*
200 CONTINUE
DO 210 JD = KBEG, KEND
A( JD, JD ) = SLARND( IDIST, ISEED )
210 CONTINUE
*
220 CONTINUE
*
* Scale by AMAGN
*
DO 230 JD = KBEG, KEND
A( JD, JD ) = AMAGN*REAL( A( JD, JD ) )
230 CONTINUE
DO 240 JD = ISDB, ISDE
A( JD+1, JD ) = AMAGN*REAL( A( JD+1, JD ) )
240 CONTINUE
*
* If ISIGN = 1 or 2, assign random signs to diagonal and
* subdiagonal
*
IF( ISIGN.GT.0 ) THEN
DO 250 JD = KBEG, KEND
IF( REAL( A( JD, JD ) ).NE.ZERO ) THEN
IF( SLARAN( ISEED ).GT.HALF )
$ A( JD, JD ) = -A( JD, JD )
END IF
250 CONTINUE
DO 260 JD = ISDB, ISDE
IF( REAL( A( JD+1, JD ) ).NE.ZERO ) THEN
IF( SLARAN( ISEED ).GT.HALF )
$ A( JD+1, JD ) = -A( JD+1, JD )
END IF
260 CONTINUE
END IF
*
* Reverse if ITYPE < 0
*
IF( ITYPE.LT.0 ) THEN
DO 270 JD = KBEG, ( KBEG+KEND-1 ) / 2
TEMP = A( JD, JD )
A( JD, JD ) = A( KBEG+KEND-JD, KBEG+KEND-JD )
A( KBEG+KEND-JD, KBEG+KEND-JD ) = TEMP
270 CONTINUE
DO 280 JD = 1, ( N-1 ) / 2
TEMP = A( JD+1, JD )
A( JD+1, JD ) = A( N+1-JD, N-JD )
A( N+1-JD, N-JD ) = TEMP
280 CONTINUE
END IF
*
* If ISIGN = 2, and no subdiagonals already, then apply
* random rotations to make 2x2 blocks.
*
IF( ISIGN.EQ.2 .AND. ITYPE.NE.2 .AND. ITYPE.NE.3 ) THEN
SAFMIN = SLAMCH( 'S' )
DO 290 JD = KBEG, KEND - 1, 2
IF( SLARAN( ISEED ).GT.HALF ) THEN
*
* Rotation on left.
*
CL = TWO*SLARAN( ISEED ) - ONE
SL = TWO*SLARAN( ISEED ) - ONE
TEMP = ONE / MAX( SAFMIN, SQRT( CL**2+SL**2 ) )
CL = CL*TEMP
SL = SL*TEMP
*
* Rotation on right.
*
CR = TWO*SLARAN( ISEED ) - ONE
SR = TWO*SLARAN( ISEED ) - ONE
TEMP = ONE / MAX( SAFMIN, SQRT( CR**2+SR**2 ) )
CR = CR*TEMP
SR = SR*TEMP
*
* Apply
*
SV1 = A( JD, JD )
SV2 = A( JD+1, JD+1 )
A( JD, JD ) = CL*CR*SV1 + SL*SR*SV2
A( JD+1, JD ) = -SL*CR*SV1 + CL*SR*SV2
A( JD, JD+1 ) = -CL*SR*SV1 + SL*CR*SV2
A( JD+1, JD+1 ) = SL*SR*SV1 + CL*CR*SV2
END IF
290 CONTINUE
END IF
*
END IF
*
* Fill in upper triangle (except for 2x2 blocks)
*
IF( TRIANG.NE.ZERO ) THEN
IF( ISIGN.NE.2 .OR. ITYPE.EQ.2 .OR. ITYPE.EQ.3 ) THEN
IOFF = 1
ELSE
IOFF = 2
DO 300 JR = 1, N - 1
IF( A( JR+1, JR ).EQ.ZERO )
$ A( JR, JR+1 ) = TRIANG*SLARND( IDIST, ISEED )
300 CONTINUE
END IF
*
DO 320 JC = 2, N
DO 310 JR = 1, JC - IOFF
A( JR, JC ) = TRIANG*SLARND( IDIST, ISEED )
310 CONTINUE
320 CONTINUE
END IF
*
RETURN
*
* End of SLATM4
*
END
LOGICAL FUNCTION SLCTES( ZR, ZI, D )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
REAL D, ZI, ZR
* ..
*
* Purpose
* =======
*
* SLCTES returns .TRUE. if the eigenvalue (ZR/D) + sqrt(-1)*(ZI/D)
* is to be selected (specifically, in this subroutine, if the real
* part of the eigenvalue is negative), and otherwise it returns
* .FALSE..
*
* It is used by the test routine SDRGES to test whether the driver
* routine SGGES succesfully sorts eigenvalues.
*
* Arguments
* =========
*
* ZR (input) REAL
* The numerator of the real part of a complex eigenvalue
* (ZR/D) + i*(ZI/D).
*
* ZI (input) REAL
* The numerator of the imaginary part of a complex eigenvalue
* (ZR/D) + i*(ZI).
*
* D (input) REAL
* The denominator part of a complex eigenvalue
* (ZR/D) + i*(ZI/D).
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Intrinsic Functions ..
INTRINSIC SIGN
* ..
* .. Executable Statements ..
*
IF( D.EQ.ZERO ) THEN
SLCTES = ( ZR.LT.ZERO )
ELSE
SLCTES = ( SIGN( ONE, ZR ).NE.SIGN( ONE, D ) )
END IF
*
RETURN
*
* End of SLCTES
*
END
LOGICAL FUNCTION SLCTSX( AR, AI, BETA )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
REAL AI, AR, BETA
* ..
*
* Purpose
* =======
*
* This function is used to determine what eigenvalues will be
* selected. If this is part of the test driver SDRGSX, do not
* change the code UNLESS you are testing input examples and not
* using the built-in examples.
*
* Arguments
* =========
*
* AR (input) REAL
* The numerator of the real part of a complex eigenvalue
* (AR/BETA) + i*(AI/BETA).
*
* AI (input) REAL
* The numerator of the imaginary part of a complex eigenvalue
* (AR/BETA) + i*(AI).
*
* BETA (input) REAL
* The denominator part of a complex eigenvalue
* (AR/BETA) + i*(AI/BETA).
*
* =====================================================================
*
* .. Scalars in Common ..
LOGICAL FS
INTEGER I, M, MPLUSN, N
* ..
* .. Common blocks ..
COMMON / MN / M, N, MPLUSN, I, FS
* ..
* .. Save statement ..
SAVE
* ..
* .. Executable Statements ..
*
IF( FS ) THEN
I = I + 1
IF( I.LE.M ) THEN
SLCTSX = .FALSE.
ELSE
SLCTSX = .TRUE.
END IF
IF( I.EQ.MPLUSN ) THEN
FS = .FALSE.
I = 0
END IF
ELSE
I = I + 1
IF( I.LE.N ) THEN
SLCTSX = .TRUE.
ELSE
SLCTSX = .FALSE.
END IF
IF( I.EQ.MPLUSN ) THEN
FS = .TRUE.
I = 0
END IF
END IF
*
* IF( AR/BETA.GT.0.0 )THEN
* SLCTSX = .TRUE.
* ELSE
* SLCTSX = .FALSE.
* END IF
*
RETURN
*
* End of SLCTSX
*
END
SUBROUTINE SLSETS( M, P, N, A, AF, LDA, B, BF, LDB, C, CF,
$ D, DF, X, WORK, LWORK, RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDB, LWORK, M, P, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), AF( LDA, * ), B( LDB, * ),
$ BF( LDB, * ), RESULT( 2 ), RWORK( * ),
$ C( * ), D( * ), CF( * ), DF( * ),
$ WORK( LWORK ), X( * )
*
* Purpose
* =======
*
* SLSETS tests SGGLSE - a subroutine for solving linear equality
* constrained least square problem (LSE).
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix A. M >= 0.
*
* P (input) INTEGER
* The number of rows of the matrix B. P >= 0.
*
* N (input) INTEGER
* The number of columns of the matrices A and B. N >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The M-by-N matrix A.
*
* AF (workspace) REAL array, dimension (LDA,N)
*
* LDA (input) INTEGER
* The leading dimension of the arrays A, AF, Q and R.
* LDA >= max(M,N).
*
* B (input) REAL array, dimension (LDB,N)
* The P-by-N matrix A.
*
* BF (workspace) REAL array, dimension (LDB,N)
*
* LDB (input) INTEGER
* The leading dimension of the arrays B, BF, V and S.
* LDB >= max(P,N).
*
* C (input) REAL array, dimension( M )
* the vector C in the LSE problem.
*
* CF (workspace) REAL array, dimension( M )
*
* D (input) REAL array, dimension( P )
* the vector D in the LSE problem.
*
* DF (workspace) REAL array, dimension( P )
*
* X (output) REAL array, dimension( N )
* solution vector X in the LSE problem.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
*
* RWORK (workspace) REAL array, dimension (M)
*
* RESULT (output) REAL array, dimension (2)
* The test ratios:
* RESULT(1) = norm( A*x - c )/ norm(A)*norm(X)*EPS
* RESULT(2) = norm( B*x - d )/ norm(B)*norm(X)*EPS
*
* ====================================================================
*
* ..
* .. Local Scalars ..
INTEGER INFO
* ..
* .. External Subroutines ..
EXTERNAL SGGLSE, SLACPY, SGET02
* ..
* .. Executable Statements ..
*
* Copy the matrices A and B to the arrays AF and BF,
* and the vectors C and D to the arrays CF and DF,
*
CALL SLACPY( 'Full', M, N, A, LDA, AF, LDA )
CALL SLACPY( 'Full', P, N, B, LDB, BF, LDB )
CALL SCOPY( M, C, 1, CF, 1 )
CALL SCOPY( P, D, 1, DF, 1 )
*
* Solve LSE problem
*
CALL SGGLSE( M, N, P, AF, LDA, BF, LDB, CF, DF, X,
$ WORK, LWORK, INFO )
*
* Test the residual for the solution of LSE
*
* Compute RESULT(1) = norm( A*x - c ) / norm(A)*norm(X)*EPS
*
CALL SCOPY( M, C, 1, CF, 1 )
CALL SCOPY( P, D, 1, DF, 1 )
CALL SGET02( 'No transpose', M, N, 1, A, LDA, X, N, CF, M,
$ RWORK, RESULT( 1 ) )
*
* Compute result(2) = norm( B*x - d ) / norm(B)*norm(X)*EPS
*
CALL SGET02( 'No transpose', P, N, 1, B, LDB, X, N, DF, P,
$ RWORK, RESULT( 2 ) )
*
RETURN
*
* End of SLSETS
*
END
SUBROUTINE SORT01( ROWCOL, M, N, U, LDU, WORK, LWORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER ROWCOL
INTEGER LDU, LWORK, M, N
REAL RESID
* ..
* .. Array Arguments ..
REAL U( LDU, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SORT01 checks that the matrix U is orthogonal by computing the ratio
*
* RESID = norm( I - U*U' ) / ( n * EPS ), if ROWCOL = 'R',
* or
* RESID = norm( I - U'*U ) / ( m * EPS ), if ROWCOL = 'C'.
*
* Alternatively, if there isn't sufficient workspace to form
* I - U*U' or I - U'*U, the ratio is computed as
*
* RESID = abs( I - U*U' ) / ( n * EPS ), if ROWCOL = 'R',
* or
* RESID = abs( I - U'*U ) / ( m * EPS ), if ROWCOL = 'C'.
*
* where EPS is the machine precision. ROWCOL is used only if m = n;
* if m > n, ROWCOL is assumed to be 'C', and if m < n, ROWCOL is
* assumed to be 'R'.
*
* Arguments
* =========
*
* ROWCOL (input) CHARACTER
* Specifies whether the rows or columns of U should be checked
* for orthogonality. Used only if M = N.
* = 'R': Check for orthogonal rows of U
* = 'C': Check for orthogonal columns of U
*
* M (input) INTEGER
* The number of rows of the matrix U.
*
* N (input) INTEGER
* The number of columns of the matrix U.
*
* U (input) REAL array, dimension (LDU,N)
* The orthogonal matrix U. U is checked for orthogonal columns
* if m > n or if m = n and ROWCOL = 'C'. U is checked for
* orthogonal rows if m < n or if m = n and ROWCOL = 'R'.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= max(1,M).
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of the array WORK. For best performance, LWORK
* should be at least N*(N+1) if ROWCOL = 'C' or M*(M+1) if
* ROWCOL = 'R', but the test will be done even if LWORK is 0.
*
* RESID (output) REAL
* RESID = norm( I - U * U' ) / ( n * EPS ), if ROWCOL = 'R', or
* RESID = norm( I - U' * U ) / ( m * EPS ), if ROWCOL = 'C'.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
CHARACTER TRANSU
INTEGER I, J, K, LDWORK, MNMIN
REAL EPS, TMP
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SDOT, SLAMCH, SLANSY
EXTERNAL LSAME, SDOT, SLAMCH, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL SLASET, SSYRK
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Executable Statements ..
*
RESID = ZERO
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
EPS = SLAMCH( 'Precision' )
IF( M.LT.N .OR. ( M.EQ.N .AND. LSAME( ROWCOL, 'R' ) ) ) THEN
TRANSU = 'N'
K = N
ELSE
TRANSU = 'T'
K = M
END IF
MNMIN = MIN( M, N )
*
IF( ( MNMIN+1 )*MNMIN.LE.LWORK ) THEN
LDWORK = MNMIN
ELSE
LDWORK = 0
END IF
IF( LDWORK.GT.0 ) THEN
*
* Compute I - U*U' or I - U'*U.
*
CALL SLASET( 'Upper', MNMIN, MNMIN, ZERO, ONE, WORK, LDWORK )
CALL SSYRK( 'Upper', TRANSU, MNMIN, K, -ONE, U, LDU, ONE, WORK,
$ LDWORK )
*
* Compute norm( I - U*U' ) / ( K * EPS ) .
*
RESID = SLANSY( '1', 'Upper', MNMIN, WORK, LDWORK,
$ WORK( LDWORK*MNMIN+1 ) )
RESID = ( RESID / REAL( K ) ) / EPS
ELSE IF( TRANSU.EQ.'T' ) THEN
*
* Find the maximum element in abs( I - U'*U ) / ( m * EPS )
*
DO 20 J = 1, N
DO 10 I = 1, J
IF( I.NE.J ) THEN
TMP = ZERO
ELSE
TMP = ONE
END IF
TMP = TMP - SDOT( M, U( 1, I ), 1, U( 1, J ), 1 )
RESID = MAX( RESID, ABS( TMP ) )
10 CONTINUE
20 CONTINUE
RESID = ( RESID / REAL( M ) ) / EPS
ELSE
*
* Find the maximum element in abs( I - U*U' ) / ( n * EPS )
*
DO 40 J = 1, M
DO 30 I = 1, J
IF( I.NE.J ) THEN
TMP = ZERO
ELSE
TMP = ONE
END IF
TMP = TMP - SDOT( N, U( J, 1 ), LDU, U( I, 1 ), LDU )
RESID = MAX( RESID, ABS( TMP ) )
30 CONTINUE
40 CONTINUE
RESID = ( RESID / REAL( N ) ) / EPS
END IF
RETURN
*
* End of SORT01
*
END
SUBROUTINE SORT03( RC, MU, MV, N, K, U, LDU, V, LDV, WORK, LWORK,
$ RESULT, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*( * ) RC
INTEGER INFO, K, LDU, LDV, LWORK, MU, MV, N
REAL RESULT
* ..
* .. Array Arguments ..
REAL U( LDU, * ), V( LDV, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SORT03 compares two orthogonal matrices U and V to see if their
* corresponding rows or columns span the same spaces. The rows are
* checked if RC = 'R', and the columns are checked if RC = 'C'.
*
* RESULT is the maximum of
*
* | V*V' - I | / ( MV ulp ), if RC = 'R', or
*
* | V'*V - I | / ( MV ulp ), if RC = 'C',
*
* and the maximum over rows (or columns) 1 to K of
*
* | U(i) - S*V(i) |/ ( N ulp )
*
* where S is +-1 (chosen to minimize the expression), U(i) is the i-th
* row (column) of U, and V(i) is the i-th row (column) of V.
*
* Arguments
* ==========
*
* RC (input) CHARACTER*1
* If RC = 'R' the rows of U and V are to be compared.
* If RC = 'C' the columns of U and V are to be compared.
*
* MU (input) INTEGER
* The number of rows of U if RC = 'R', and the number of
* columns if RC = 'C'. If MU = 0 SORT03 does nothing.
* MU must be at least zero.
*
* MV (input) INTEGER
* The number of rows of V if RC = 'R', and the number of
* columns if RC = 'C'. If MV = 0 SORT03 does nothing.
* MV must be at least zero.
*
* N (input) INTEGER
* If RC = 'R', the number of columns in the matrices U and V,
* and if RC = 'C', the number of rows in U and V. If N = 0
* SORT03 does nothing. N must be at least zero.
*
* K (input) INTEGER
* The number of rows or columns of U and V to compare.
* 0 <= K <= max(MU,MV).
*
* U (input) REAL array, dimension (LDU,N)
* The first matrix to compare. If RC = 'R', U is MU by N, and
* if RC = 'C', U is N by MU.
*
* LDU (input) INTEGER
* The leading dimension of U. If RC = 'R', LDU >= max(1,MU),
* and if RC = 'C', LDU >= max(1,N).
*
* V (input) REAL array, dimension (LDV,N)
* The second matrix to compare. If RC = 'R', V is MV by N, and
* if RC = 'C', V is N by MV.
*
* LDV (input) INTEGER
* The leading dimension of V. If RC = 'R', LDV >= max(1,MV),
* and if RC = 'C', LDV >= max(1,N).
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of the array WORK. For best performance, LWORK
* should be at least N*N if RC = 'C' or M*M if RC = 'R', but
* the tests will be done even if LWORK is 0.
*
* RESULT (output) REAL
* The value computed by the test described above. RESULT is
* limited to 1/ulp to avoid overflow.
*
* INFO (output) INTEGER
* 0 indicates a successful exit
* -k indicates the k-th parameter had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
INTEGER I, IRC, J, LMX
REAL RES1, RES2, S, ULP
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SLAMCH
EXTERNAL LSAME, ISAMAX, SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL, SIGN
* ..
* .. External Subroutines ..
EXTERNAL SORT01, XERBLA
* ..
* .. Executable Statements ..
*
* Check inputs
*
INFO = 0
IF( LSAME( RC, 'R' ) ) THEN
IRC = 0
ELSE IF( LSAME( RC, 'C' ) ) THEN
IRC = 1
ELSE
IRC = -1
END IF
IF( IRC.EQ.-1 ) THEN
INFO = -1
ELSE IF( MU.LT.0 ) THEN
INFO = -2
ELSE IF( MV.LT.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( K.LT.0 .OR. K.GT.MAX( MU, MV ) ) THEN
INFO = -5
ELSE IF( ( IRC.EQ.0 .AND. LDU.LT.MAX( 1, MU ) ) .OR.
$ ( IRC.EQ.1 .AND. LDU.LT.MAX( 1, N ) ) ) THEN
INFO = -7
ELSE IF( ( IRC.EQ.0 .AND. LDV.LT.MAX( 1, MV ) ) .OR.
$ ( IRC.EQ.1 .AND. LDV.LT.MAX( 1, N ) ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SORT03', -INFO )
RETURN
END IF
*
* Initialize result
*
RESULT = ZERO
IF( MU.EQ.0 .OR. MV.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
* Machine constants
*
ULP = SLAMCH( 'Precision' )
*
IF( IRC.EQ.0 ) THEN
*
* Compare rows
*
RES1 = ZERO
DO 20 I = 1, K
LMX = ISAMAX( N, U( I, 1 ), LDU )
S = SIGN( ONE, U( I, LMX ) )*SIGN( ONE, V( I, LMX ) )
DO 10 J = 1, N
RES1 = MAX( RES1, ABS( U( I, J )-S*V( I, J ) ) )
10 CONTINUE
20 CONTINUE
RES1 = RES1 / ( REAL( N )*ULP )
*
* Compute orthogonality of rows of V.
*
CALL SORT01( 'Rows', MV, N, V, LDV, WORK, LWORK, RES2 )
*
ELSE
*
* Compare columns
*
RES1 = ZERO
DO 40 I = 1, K
LMX = ISAMAX( N, U( 1, I ), 1 )
S = SIGN( ONE, U( LMX, I ) )*SIGN( ONE, V( LMX, I ) )
DO 30 J = 1, N
RES1 = MAX( RES1, ABS( U( J, I )-S*V( J, I ) ) )
30 CONTINUE
40 CONTINUE
RES1 = RES1 / ( REAL( N )*ULP )
*
* Compute orthogonality of columns of V.
*
CALL SORT01( 'Columns', N, MV, V, LDV, WORK, LWORK, RES2 )
END IF
*
RESULT = MIN( MAX( RES1, RES2 ), ONE / ULP )
RETURN
*
* End of SORT03
*
END
SUBROUTINE SSBT21( UPLO, N, KA, KS, A, LDA, D, E, U, LDU, WORK,
$ RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER KA, KS, LDA, LDU, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), D( * ), E( * ), RESULT( 2 ),
$ U( LDU, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SSBT21 generally checks a decomposition of the form
*
* A = U S U'
*
* where ' means transpose, A is symmetric banded, U is
* orthogonal, and S is diagonal (if KS=0) or symmetric
* tridiagonal (if KS=1).
*
* Specifically:
*
* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and*
* RESULT(2) = | I - UU' | / ( n ulp )
*
* Arguments
* =========
*
* UPLO (input) CHARACTER
* If UPLO='U', the upper triangle of A and V will be used and
* the (strictly) lower triangle will not be referenced.
* If UPLO='L', the lower triangle of A and V will be used and
* the (strictly) upper triangle will not be referenced.
*
* N (input) INTEGER
* The size of the matrix. If it is zero, SSBT21 does nothing.
* It must be at least zero.
*
* KA (input) INTEGER
* The bandwidth of the matrix A. It must be at least zero. If
* it is larger than N-1, then max( 0, N-1 ) will be used.
*
* KS (input) INTEGER
* The bandwidth of the matrix S. It may only be zero or one.
* If zero, then S is diagonal, and E is not referenced. If
* one, then S is symmetric tri-diagonal.
*
* A (input) REAL array, dimension (LDA, N)
* The original (unfactored) matrix. It is assumed to be
* symmetric, and only the upper (UPLO='U') or only the lower
* (UPLO='L') will be referenced.
*
* LDA (input) INTEGER
* The leading dimension of A. It must be at least 1
* and at least min( KA, N-1 ).
*
* D (input) REAL array, dimension (N)
* The diagonal of the (symmetric tri-) diagonal matrix S.
*
* E (input) REAL array, dimension (N-1)
* The off-diagonal of the (symmetric tri-) diagonal matrix S.
* E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and
* (3,2) element, etc.
* Not referenced if KS=0.
*
* U (input) REAL array, dimension (LDU, N)
* The orthogonal matrix in the decomposition, expressed as a
* dense matrix (i.e., not as a product of Householder
* transformations, Givens transformations, etc.)
*
* LDU (input) INTEGER
* The leading dimension of U. LDU must be at least N and
* at least 1.
*
* WORK (workspace) REAL array, dimension (N**2+N)
*
* RESULT (output) REAL array, dimension (2)
* The values computed by the two tests described above. The
* values are currently limited to 1/ulp, to avoid overflow.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL LOWER
CHARACTER CUPLO
INTEGER IKA, J, JC, JR, LW
REAL ANORM, ULP, UNFL, WNORM
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANGE, SLANSB, SLANSP
EXTERNAL LSAME, SLAMCH, SLANGE, SLANSB, SLANSP
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SSPR, SSPR2
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Executable Statements ..
*
* Constants
*
RESULT( 1 ) = ZERO
RESULT( 2 ) = ZERO
IF( N.LE.0 )
$ RETURN
*
IKA = MAX( 0, MIN( N-1, KA ) )
LW = ( N*( N+1 ) ) / 2
*
IF( LSAME( UPLO, 'U' ) ) THEN
LOWER = .FALSE.
CUPLO = 'U'
ELSE
LOWER = .TRUE.
CUPLO = 'L'
END IF
*
UNFL = SLAMCH( 'Safe minimum' )
ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
*
* Some Error Checks
*
* Do Test 1
*
* Norm of A:
*
ANORM = MAX( SLANSB( '1', CUPLO, N, IKA, A, LDA, WORK ), UNFL )
*
* Compute error matrix: Error = A - U S U'
*
* Copy A from SB to SP storage format.
*
J = 0
DO 50 JC = 1, N
IF( LOWER ) THEN
DO 10 JR = 1, MIN( IKA+1, N+1-JC )
J = J + 1
WORK( J ) = A( JR, JC )
10 CONTINUE
DO 20 JR = IKA + 2, N + 1 - JC
J = J + 1
WORK( J ) = ZERO
20 CONTINUE
ELSE
DO 30 JR = IKA + 2, JC
J = J + 1
WORK( J ) = ZERO
30 CONTINUE
DO 40 JR = MIN( IKA, JC-1 ), 0, -1
J = J + 1
WORK( J ) = A( IKA+1-JR, JC )
40 CONTINUE
END IF
50 CONTINUE
*
DO 60 J = 1, N
CALL SSPR( CUPLO, N, -D( J ), U( 1, J ), 1, WORK )
60 CONTINUE
*
IF( N.GT.1 .AND. KS.EQ.1 ) THEN
DO 70 J = 1, N - 1
CALL SSPR2( CUPLO, N, -E( J ), U( 1, J ), 1, U( 1, J+1 ), 1,
$ WORK )
70 CONTINUE
END IF
WNORM = SLANSP( '1', CUPLO, N, WORK, WORK( LW+1 ) )
*
IF( ANORM.GT.WNORM ) THEN
RESULT( 1 ) = ( WNORM / ANORM ) / ( N*ULP )
ELSE
IF( ANORM.LT.ONE ) THEN
RESULT( 1 ) = ( MIN( WNORM, N*ANORM ) / ANORM ) / ( N*ULP )
ELSE
RESULT( 1 ) = MIN( WNORM / ANORM, REAL( N ) ) / ( N*ULP )
END IF
END IF
*
* Do Test 2
*
* Compute UU' - I
*
CALL SGEMM( 'N', 'C', N, N, N, ONE, U, LDU, U, LDU, ZERO, WORK,
$ N )
*
DO 80 J = 1, N
WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - ONE
80 CONTINUE
*
RESULT( 2 ) = MIN( SLANGE( '1', N, N, WORK, N, WORK( N**2+1 ) ),
$ REAL( N ) ) / ( N*ULP )
*
RETURN
*
* End of SSBT21
*
END
SUBROUTINE SSGT01( ITYPE, UPLO, N, M, A, LDA, B, LDB, Z, LDZ, D,
$ WORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* modified August 1997, a new parameter M is added to the calling
* sequence.
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER ITYPE, LDA, LDB, LDZ, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), D( * ), RESULT( * ),
$ WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SSGT01 checks a decomposition of the form
*
* A Z = B Z D or
* A B Z = Z D or
* B A Z = Z D
*
* where A is a symmetric matrix, B is
* symmetric positive definite, Z is orthogonal, and D is diagonal.
*
* One of the following test ratios is computed:
*
* ITYPE = 1: RESULT(1) = | A Z - B Z D | / ( |A| |Z| n ulp )
*
* ITYPE = 2: RESULT(1) = | A B Z - Z D | / ( |A| |Z| n ulp )
*
* ITYPE = 3: RESULT(1) = | B A Z - Z D | / ( |A| |Z| n ulp )
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* The form of the symmetric generalized eigenproblem.
* = 1: A*z = (lambda)*B*z
* = 2: A*B*z = (lambda)*z
* = 3: B*A*z = (lambda)*z
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrices A and B is stored.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* M (input) INTEGER
* The number of eigenvalues found. 0 <= M <= N.
*
* A (input) REAL array, dimension (LDA, N)
* The original symmetric matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input) REAL array, dimension (LDB, N)
* The original symmetric positive definite matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* Z (input) REAL array, dimension (LDZ, M)
* The computed eigenvectors of the generalized eigenproblem.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= max(1,N).
*
* D (input) REAL array, dimension (M)
* The computed eigenvalues of the generalized eigenproblem.
*
* WORK (workspace) REAL array, dimension (N*N)
*
* RESULT (output) REAL array, dimension (1)
* The test ratio as described above.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
INTEGER I
REAL ANORM, ULP
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE, SLANSY
EXTERNAL SLAMCH, SLANGE, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL SSCAL, SSYMM
* ..
* .. Executable Statements ..
*
RESULT( 1 ) = ZERO
IF( N.LE.0 )
$ RETURN
*
ULP = SLAMCH( 'Epsilon' )
*
* Compute product of 1-norms of A and Z.
*
ANORM = SLANSY( '1', UPLO, N, A, LDA, WORK )*
$ SLANGE( '1', N, M, Z, LDZ, WORK )
IF( ANORM.EQ.ZERO )
$ ANORM = ONE
*
IF( ITYPE.EQ.1 ) THEN
*
* Norm of AZ - BZD
*
CALL SSYMM( 'Left', UPLO, N, M, ONE, A, LDA, Z, LDZ, ZERO,
$ WORK, N )
DO 10 I = 1, M
CALL SSCAL( N, D( I ), Z( 1, I ), 1 )
10 CONTINUE
CALL SSYMM( 'Left', UPLO, N, M, ONE, B, LDB, Z, LDZ, -ONE,
$ WORK, N )
*
RESULT( 1 ) = ( SLANGE( '1', N, M, WORK, N, WORK ) / ANORM ) /
$ ( N*ULP )
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Norm of ABZ - ZD
*
CALL SSYMM( 'Left', UPLO, N, M, ONE, B, LDB, Z, LDZ, ZERO,
$ WORK, N )
DO 20 I = 1, M
CALL SSCAL( N, D( I ), Z( 1, I ), 1 )
20 CONTINUE
CALL SSYMM( 'Left', UPLO, N, M, ONE, A, LDA, WORK, N, -ONE, Z,
$ LDZ )
*
RESULT( 1 ) = ( SLANGE( '1', N, M, Z, LDZ, WORK ) / ANORM ) /
$ ( N*ULP )
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* Norm of BAZ - ZD
*
CALL SSYMM( 'Left', UPLO, N, M, ONE, A, LDA, Z, LDZ, ZERO,
$ WORK, N )
DO 30 I = 1, M
CALL SSCAL( N, D( I ), Z( 1, I ), 1 )
30 CONTINUE
CALL SSYMM( 'Left', UPLO, N, M, ONE, B, LDB, WORK, N, -ONE, Z,
$ LDZ )
*
RESULT( 1 ) = ( SLANGE( '1', N, M, Z, LDZ, WORK ) / ANORM ) /
$ ( N*ULP )
END IF
*
RETURN
*
* End of SSGT01
*
END
LOGICAL FUNCTION SSLECT( ZR, ZI )
*
* -- LAPACK test routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* February 2007
*
* .. Scalar Arguments ..
REAL ZI, ZR
* ..
*
* Purpose
* =======
*
* SSLECT returns .TRUE. if the eigenvalue ZR+sqrt(-1)*ZI is to be
* selected, and otherwise it returns .FALSE.
* It is used by SCHK41 to test if SGEES succesfully sorts eigenvalues,
* and by SCHK43 to test if SGEESX succesfully sorts eigenvalues.
*
* The common block /SSLCT/ controls how eigenvalues are selected.
* If SELOPT = 0, then SSLECT return .TRUE. when ZR is less than zero,
* and .FALSE. otherwise.
* If SELOPT is at least 1, SSLECT returns SELVAL(SELOPT) and adds 1
* to SELOPT, cycling back to 1 at SELMAX.
*
* Arguments
* =========
*
* ZR (input) REAL
* The real part of a complex eigenvalue ZR + i*ZI.
*
* ZI (input) REAL
* The imaginary part of a complex eigenvalue ZR + i*ZI.
*
* =====================================================================
*
* .. Arrays in Common ..
LOGICAL SELVAL( 20 )
REAL SELWI( 20 ), SELWR( 20 )
* ..
* .. Scalars in Common ..
INTEGER SELDIM, SELOPT
* ..
* .. Common blocks ..
COMMON / SSLCT / SELOPT, SELDIM, SELVAL, SELWR, SELWI
* ..
* .. Local Scalars ..
INTEGER I
REAL RMIN, X
* ..
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
* ..
* .. External Functions ..
REAL SLAPY2
EXTERNAL SLAPY2
* ..
* .. Executable Statements ..
*
IF( SELOPT.EQ.0 ) THEN
SSLECT = ( ZR.LT.ZERO )
ELSE
RMIN = SLAPY2( ZR-SELWR( 1 ), ZI-SELWI( 1 ) )
SSLECT = SELVAL( 1 )
DO 10 I = 2, SELDIM
X = SLAPY2( ZR-SELWR( I ), ZI-SELWI( I ) )
IF( X.LE.RMIN ) THEN
RMIN = X
SSLECT = SELVAL( I )
END IF
10 CONTINUE
END IF
RETURN
*
* End of SSLECT
*
END
SUBROUTINE SSPT21( ITYPE, UPLO, N, KBAND, AP, D, E, U, LDU, VP,
$ TAU, WORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER ITYPE, KBAND, LDU, N
* ..
* .. Array Arguments ..
REAL AP( * ), D( * ), E( * ), RESULT( 2 ), TAU( * ),
$ U( LDU, * ), VP( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SSPT21 generally checks a decomposition of the form
*
* A = U S U'
*
* where ' means transpose, A is symmetric (stored in packed format), U
* is orthogonal, and S is diagonal (if KBAND=0) or symmetric
* tridiagonal (if KBAND=1). If ITYPE=1, then U is represented as a
* dense matrix, otherwise the U is expressed as a product of
* Householder transformations, whose vectors are stored in the array
* "V" and whose scaling constants are in "TAU"; we shall use the
* letter "V" to refer to the product of Householder transformations
* (which should be equal to U).
*
* Specifically, if ITYPE=1, then:
*
* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and*
* RESULT(2) = | I - UU' | / ( n ulp )
*
* If ITYPE=2, then:
*
* RESULT(1) = | A - V S V' | / ( |A| n ulp )
*
* If ITYPE=3, then:
*
* RESULT(1) = | I - VU' | / ( n ulp )
*
* Packed storage means that, for example, if UPLO='U', then the columns
* of the upper triangle of A are stored one after another, so that
* A(1,j+1) immediately follows A(j,j) in the array AP. Similarly, if
* UPLO='L', then the columns of the lower triangle of A are stored one
* after another in AP, so that A(j+1,j+1) immediately follows A(n,j)
* in the array AP. This means that A(i,j) is stored in:
*
* AP( i + j*(j-1)/2 ) if UPLO='U'
*
* AP( i + (2*n-j)*(j-1)/2 ) if UPLO='L'
*
* The array VP bears the same relation to the matrix V that A does to
* AP.
*
* For ITYPE > 1, the transformation U is expressed as a product
* of Householder transformations:
*
* If UPLO='U', then V = H(n-1)...H(1), where
*
* H(j) = I - tau(j) v(j) v(j)'
*
* and the first j-1 elements of v(j) are stored in V(1:j-1,j+1),
* (i.e., VP( j*(j+1)/2 + 1 : j*(j+1)/2 + j-1 ) ),
* the j-th element is 1, and the last n-j elements are 0.
*
* If UPLO='L', then V = H(1)...H(n-1), where
*
* H(j) = I - tau(j) v(j) v(j)'
*
* and the first j elements of v(j) are 0, the (j+1)-st is 1, and the
* (j+2)-nd through n-th elements are stored in V(j+2:n,j) (i.e.,
* in VP( (2*n-j)*(j-1)/2 + j+2 : (2*n-j)*(j-1)/2 + n ) .)
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* Specifies the type of tests to be performed.
* 1: U expressed as a dense orthogonal matrix:
* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and*
* RESULT(2) = | I - UU' | / ( n ulp )
*
* 2: U expressed as a product V of Housholder transformations:
* RESULT(1) = | A - V S V' | / ( |A| n ulp )
*
* 3: U expressed both as a dense orthogonal matrix and
* as a product of Housholder transformations:
* RESULT(1) = | I - VU' | / ( n ulp )
*
* UPLO (input) CHARACTER
* If UPLO='U', AP and VP are considered to contain the upper
* triangle of A and V.
* If UPLO='L', AP and VP are considered to contain the lower
* triangle of A and V.
*
* N (input) INTEGER
* The size of the matrix. If it is zero, SSPT21 does nothing.
* It must be at least zero.
*
* KBAND (input) INTEGER
* The bandwidth of the matrix. It may only be zero or one.
* If zero, then S is diagonal, and E is not referenced. If
* one, then S is symmetric tri-diagonal.
*
* AP (input) REAL array, dimension (N*(N+1)/2)
* The original (unfactored) matrix. It is assumed to be
* symmetric, and contains the columns of just the upper
* triangle (UPLO='U') or only the lower triangle (UPLO='L'),
* packed one after another.
*
* D (input) REAL array, dimension (N)
* The diagonal of the (symmetric tri-) diagonal matrix.
*
* E (input) REAL array, dimension (N-1)
* The off-diagonal of the (symmetric tri-) diagonal matrix.
* E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and
* (3,2) element, etc.
* Not referenced if KBAND=0.
*
* U (input) REAL array, dimension (LDU, N)
* If ITYPE=1 or 3, this contains the orthogonal matrix in
* the decomposition, expressed as a dense matrix. If ITYPE=2,
* then it is not referenced.
*
* LDU (input) INTEGER
* The leading dimension of U. LDU must be at least N and
* at least 1.
*
* VP (input) REAL array, dimension (N*(N+1)/2)
* If ITYPE=2 or 3, the columns of this array contain the
* Householder vectors used to describe the orthogonal matrix
* in the decomposition, as described in purpose.
* *NOTE* If ITYPE=2 or 3, V is modified and restored. The
* subdiagonal (if UPLO='L') or the superdiagonal (if UPLO='U')
* is set to one, and later reset to its original value, during
* the course of the calculation.
* If ITYPE=1, then it is neither referenced nor modified.
*
* TAU (input) REAL array, dimension (N)
* If ITYPE >= 2, then TAU(j) is the scalar factor of
* v(j) v(j)' in the Householder transformation H(j) of
* the product U = H(1)...H(n-2)
* If ITYPE < 2, then TAU is not referenced.
*
* WORK (workspace) REAL array, dimension (N**2+N)
* Workspace.
*
* RESULT (output) REAL array, dimension (2)
* The values computed by the two tests described above. The
* values are currently limited to 1/ulp, to avoid overflow.
* RESULT(1) is always modified. RESULT(2) is modified only
* if ITYPE=1.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TEN
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TEN = 10.0E0 )
REAL HALF
PARAMETER ( HALF = 1.0E+0 / 2.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL LOWER
CHARACTER CUPLO
INTEGER IINFO, J, JP, JP1, JR, LAP
REAL ANORM, TEMP, ULP, UNFL, VSAVE, WNORM
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SDOT, SLAMCH, SLANGE, SLANSP
EXTERNAL LSAME, SDOT, SLAMCH, SLANGE, SLANSP
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, SGEMM, SLACPY, SLASET, SOPMTR,
$ SSPMV, SSPR, SSPR2
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Executable Statements ..
*
* 1) Constants
*
RESULT( 1 ) = ZERO
IF( ITYPE.EQ.1 )
$ RESULT( 2 ) = ZERO
IF( N.LE.0 )
$ RETURN
*
LAP = ( N*( N+1 ) ) / 2
*
IF( LSAME( UPLO, 'U' ) ) THEN
LOWER = .FALSE.
CUPLO = 'U'
ELSE
LOWER = .TRUE.
CUPLO = 'L'
END IF
*
UNFL = SLAMCH( 'Safe minimum' )
ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
*
* Some Error Checks
*
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
RESULT( 1 ) = TEN / ULP
RETURN
END IF
*
* Do Test 1
*
* Norm of A:
*
IF( ITYPE.EQ.3 ) THEN
ANORM = ONE
ELSE
ANORM = MAX( SLANSP( '1', CUPLO, N, AP, WORK ), UNFL )
END IF
*
* Compute error matrix:
*
IF( ITYPE.EQ.1 ) THEN
*
* ITYPE=1: error = A - U S U'
*
CALL SLASET( 'Full', N, N, ZERO, ZERO, WORK, N )
CALL SCOPY( LAP, AP, 1, WORK, 1 )
*
DO 10 J = 1, N
CALL SSPR( CUPLO, N, -D( J ), U( 1, J ), 1, WORK )
10 CONTINUE
*
IF( N.GT.1 .AND. KBAND.EQ.1 ) THEN
DO 20 J = 1, N - 1
CALL SSPR2( CUPLO, N, -E( J ), U( 1, J ), 1, U( 1, J+1 ),
$ 1, WORK )
20 CONTINUE
END IF
WNORM = SLANSP( '1', CUPLO, N, WORK, WORK( N**2+1 ) )
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* ITYPE=2: error = V S V' - A
*
CALL SLASET( 'Full', N, N, ZERO, ZERO, WORK, N )
*
IF( LOWER ) THEN
WORK( LAP ) = D( N )
DO 40 J = N - 1, 1, -1
JP = ( ( 2*N-J )*( J-1 ) ) / 2
JP1 = JP + N - J
IF( KBAND.EQ.1 ) THEN
WORK( JP+J+1 ) = ( ONE-TAU( J ) )*E( J )
DO 30 JR = J + 2, N
WORK( JP+JR ) = -TAU( J )*E( J )*VP( JP+JR )
30 CONTINUE
END IF
*
IF( TAU( J ).NE.ZERO ) THEN
VSAVE = VP( JP+J+1 )
VP( JP+J+1 ) = ONE
CALL SSPMV( 'L', N-J, ONE, WORK( JP1+J+1 ),
$ VP( JP+J+1 ), 1, ZERO, WORK( LAP+1 ), 1 )
TEMP = -HALF*TAU( J )*SDOT( N-J, WORK( LAP+1 ), 1,
$ VP( JP+J+1 ), 1 )
CALL SAXPY( N-J, TEMP, VP( JP+J+1 ), 1, WORK( LAP+1 ),
$ 1 )
CALL SSPR2( 'L', N-J, -TAU( J ), VP( JP+J+1 ), 1,
$ WORK( LAP+1 ), 1, WORK( JP1+J+1 ) )
VP( JP+J+1 ) = VSAVE
END IF
WORK( JP+J ) = D( J )
40 CONTINUE
ELSE
WORK( 1 ) = D( 1 )
DO 60 J = 1, N - 1
JP = ( J*( J-1 ) ) / 2
JP1 = JP + J
IF( KBAND.EQ.1 ) THEN
WORK( JP1+J ) = ( ONE-TAU( J ) )*E( J )
DO 50 JR = 1, J - 1
WORK( JP1+JR ) = -TAU( J )*E( J )*VP( JP1+JR )
50 CONTINUE
END IF
*
IF( TAU( J ).NE.ZERO ) THEN
VSAVE = VP( JP1+J )
VP( JP1+J ) = ONE
CALL SSPMV( 'U', J, ONE, WORK, VP( JP1+1 ), 1, ZERO,
$ WORK( LAP+1 ), 1 )
TEMP = -HALF*TAU( J )*SDOT( J, WORK( LAP+1 ), 1,
$ VP( JP1+1 ), 1 )
CALL SAXPY( J, TEMP, VP( JP1+1 ), 1, WORK( LAP+1 ),
$ 1 )
CALL SSPR2( 'U', J, -TAU( J ), VP( JP1+1 ), 1,
$ WORK( LAP+1 ), 1, WORK )
VP( JP1+J ) = VSAVE
END IF
WORK( JP1+J+1 ) = D( J+1 )
60 CONTINUE
END IF
*
DO 70 J = 1, LAP
WORK( J ) = WORK( J ) - AP( J )
70 CONTINUE
WNORM = SLANSP( '1', CUPLO, N, WORK, WORK( LAP+1 ) )
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* ITYPE=3: error = U V' - I
*
IF( N.LT.2 )
$ RETURN
CALL SLACPY( ' ', N, N, U, LDU, WORK, N )
CALL SOPMTR( 'R', CUPLO, 'T', N, N, VP, TAU, WORK, N,
$ WORK( N**2+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
RESULT( 1 ) = TEN / ULP
RETURN
END IF
*
DO 80 J = 1, N
WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - ONE
80 CONTINUE
*
WNORM = SLANGE( '1', N, N, WORK, N, WORK( N**2+1 ) )
END IF
*
IF( ANORM.GT.WNORM ) THEN
RESULT( 1 ) = ( WNORM / ANORM ) / ( N*ULP )
ELSE
IF( ANORM.LT.ONE ) THEN
RESULT( 1 ) = ( MIN( WNORM, N*ANORM ) / ANORM ) / ( N*ULP )
ELSE
RESULT( 1 ) = MIN( WNORM / ANORM, REAL( N ) ) / ( N*ULP )
END IF
END IF
*
* Do Test 2
*
* Compute UU' - I
*
IF( ITYPE.EQ.1 ) THEN
CALL SGEMM( 'N', 'C', N, N, N, ONE, U, LDU, U, LDU, ZERO, WORK,
$ N )
*
DO 90 J = 1, N
WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - ONE
90 CONTINUE
*
RESULT( 2 ) = MIN( SLANGE( '1', N, N, WORK, N,
$ WORK( N**2+1 ) ), REAL( N ) ) / ( N*ULP )
END IF
*
RETURN
*
* End of SSPT21
*
END
SUBROUTINE SSTECH( N, A, B, EIG, TOL, WORK, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, N
REAL TOL
* ..
* .. Array Arguments ..
REAL A( * ), B( * ), EIG( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* Let T be the tridiagonal matrix with diagonal entries A(1) ,...,
* A(N) and offdiagonal entries B(1) ,..., B(N-1)). SSTECH checks to
* see if EIG(1) ,..., EIG(N) are indeed accurate eigenvalues of T.
* It does this by expanding each EIG(I) into an interval
* [SVD(I) - EPS, SVD(I) + EPS], merging overlapping intervals if
* any, and using Sturm sequences to count and verify whether each
* resulting interval has the correct number of eigenvalues (using
* SSTECT). Here EPS = TOL*MACHEPS*MAXEIG, where MACHEPS is the
* machine precision and MAXEIG is the absolute value of the largest
* eigenvalue. If each interval contains the correct number of
* eigenvalues, INFO = 0 is returned, otherwise INFO is the index of
* the first eigenvalue in the first bad interval.
*
* Arguments
* =========
*
* N (input) INTEGER
* The dimension of the tridiagonal matrix T.
*
* A (input) REAL array, dimension (N)
* The diagonal entries of the tridiagonal matrix T.
*
* B (input) REAL array, dimension (N-1)
* The offdiagonal entries of the tridiagonal matrix T.
*
* EIG (input) REAL array, dimension (N)
* The purported eigenvalues to be checked.
*
* TOL (input) REAL
* Error tolerance for checking, a multiple of the
* machine precision.
*
* WORK (workspace) REAL array, dimension (N)
*
* INFO (output) INTEGER
* 0 if the eigenvalues are all correct (to within
* 1 +- TOL*MACHEPS*MAXEIG)
* >0 if the interval containing the INFO-th eigenvalue
* contains the incorrect number of eigenvalues.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
INTEGER BPNT, COUNT, I, ISUB, J, NUML, NUMU, TPNT
REAL EMIN, EPS, LOWER, MX, TUPPR, UNFLEP, UPPER
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SSTECT
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Check input parameters
*
INFO = 0
IF( N.EQ.0 )
$ RETURN
IF( N.LT.0 ) THEN
INFO = -1
RETURN
END IF
IF( TOL.LT.ZERO ) THEN
INFO = -5
RETURN
END IF
*
* Get machine constants
*
EPS = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
UNFLEP = SLAMCH( 'Safe minimum' ) / EPS
EPS = TOL*EPS
*
* Compute maximum absolute eigenvalue, error tolerance
*
MX = ABS( EIG( 1 ) )
DO 10 I = 2, N
MX = MAX( MX, ABS( EIG( I ) ) )
10 CONTINUE
EPS = MAX( EPS*MX, UNFLEP )
*
* Sort eigenvalues from EIG into WORK
*
DO 20 I = 1, N
WORK( I ) = EIG( I )
20 CONTINUE
DO 40 I = 1, N - 1
ISUB = 1
EMIN = WORK( 1 )
DO 30 J = 2, N + 1 - I
IF( WORK( J ).LT.EMIN ) THEN
ISUB = J
EMIN = WORK( J )
END IF
30 CONTINUE
IF( ISUB.NE.N+1-I ) THEN
WORK( ISUB ) = WORK( N+1-I )
WORK( N+1-I ) = EMIN
END IF
40 CONTINUE
*
* TPNT points to singular value at right endpoint of interval
* BPNT points to singular value at left endpoint of interval
*
TPNT = 1
BPNT = 1
*
* Begin loop over all intervals
*
50 CONTINUE
UPPER = WORK( TPNT ) + EPS
LOWER = WORK( BPNT ) - EPS
*
* Begin loop merging overlapping intervals
*
60 CONTINUE
IF( BPNT.EQ.N )
$ GO TO 70
TUPPR = WORK( BPNT+1 ) + EPS
IF( TUPPR.LT.LOWER )
$ GO TO 70
*
* Merge
*
BPNT = BPNT + 1
LOWER = WORK( BPNT ) - EPS
GO TO 60
70 CONTINUE
*
* Count singular values in interval [ LOWER, UPPER ]
*
CALL SSTECT( N, A, B, LOWER, NUML )
CALL SSTECT( N, A, B, UPPER, NUMU )
COUNT = NUMU - NUML
IF( COUNT.NE.BPNT-TPNT+1 ) THEN
*
* Wrong number of singular values in interval
*
INFO = TPNT
GO TO 80
END IF
TPNT = BPNT + 1
BPNT = TPNT
IF( TPNT.LE.N )
$ GO TO 50
80 CONTINUE
RETURN
*
* End of SSTECH
*
END
SUBROUTINE SSTECT( N, A, B, SHIFT, NUM )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER N, NUM
REAL SHIFT
* ..
* .. Array Arguments ..
REAL A( * ), B( * )
* ..
*
* Purpose
* =======
*
* SSTECT counts the number NUM of eigenvalues of a tridiagonal
* matrix T which are less than or equal to SHIFT. T has
* diagonal entries A(1), ... , A(N), and offdiagonal entries
* B(1), ..., B(N-1).
* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
* Matrix", Report CS41, Computer Science Dept., Stanford
* University, July 21, 1966
*
* Arguments
* =========
*
* N (input) INTEGER
* The dimension of the tridiagonal matrix T.
*
* A (input) REAL array, dimension (N)
* The diagonal entries of the tridiagonal matrix T.
*
* B (input) REAL array, dimension (N-1)
* The offdiagonal entries of the tridiagonal matrix T.
*
* SHIFT (input) REAL
* The shift, used as described under Purpose.
*
* NUM (output) INTEGER
* The number of eigenvalues of T less than or equal
* to SHIFT.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, THREE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, THREE = 3.0E0 )
* ..
* .. Local Scalars ..
INTEGER I
REAL M1, M2, MX, OVFL, SOV, SSHIFT, SSUN, SUN, TMP,
$ TOM, U, UNFL
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Get machine constants
*
UNFL = SLAMCH( 'Safe minimum' )
OVFL = SLAMCH( 'Overflow' )
*
* Find largest entry
*
MX = ABS( A( 1 ) )
DO 10 I = 1, N - 1
MX = MAX( MX, ABS( A( I+1 ) ), ABS( B( I ) ) )
10 CONTINUE
*
* Handle easy cases, including zero matrix
*
IF( SHIFT.GE.THREE*MX ) THEN
NUM = N
RETURN
END IF
IF( SHIFT.LT.-THREE*MX ) THEN
NUM = 0
RETURN
END IF
*
* Compute scale factors as in Kahan's report
* At this point, MX .NE. 0 so we can divide by it
*
SUN = SQRT( UNFL )
SSUN = SQRT( SUN )
SOV = SQRT( OVFL )
TOM = SSUN*SOV
IF( MX.LE.ONE ) THEN
M1 = ONE / MX
M2 = TOM
ELSE
M1 = ONE
M2 = TOM / MX
END IF
*
* Begin counting
*
NUM = 0
SSHIFT = ( SHIFT*M1 )*M2
U = ( A( 1 )*M1 )*M2 - SSHIFT
IF( U.LE.SUN ) THEN
IF( U.LE.ZERO ) THEN
NUM = NUM + 1
IF( U.GT.-SUN )
$ U = -SUN
ELSE
U = SUN
END IF
END IF
DO 20 I = 2, N
TMP = ( B( I-1 )*M1 )*M2
U = ( ( A( I )*M1 )*M2-TMP*( TMP / U ) ) - SSHIFT
IF( U.LE.SUN ) THEN
IF( U.LE.ZERO ) THEN
NUM = NUM + 1
IF( U.GT.-SUN )
$ U = -SUN
ELSE
U = SUN
END IF
END IF
20 CONTINUE
RETURN
*
* End of SSTECT
*
END
SUBROUTINE SSTT21( N, KBAND, AD, AE, SD, SE, U, LDU, WORK,
$ RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KBAND, LDU, N
* ..
* .. Array Arguments ..
REAL AD( * ), AE( * ), RESULT( 2 ), SD( * ),
$ SE( * ), U( LDU, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SSTT21 checks a decomposition of the form
*
* A = U S U'
*
* where ' means transpose, A is symmetric tridiagonal, U is orthogonal,
* and S is diagonal (if KBAND=0) or symmetric tridiagonal (if KBAND=1).
* Two tests are performed:
*
* RESULT(1) = | A - U S U' | / ( |A| n ulp )
*
* RESULT(2) = | I - UU' | / ( n ulp )
*
* Arguments
* =========
*
* N (input) INTEGER
* The size of the matrix. If it is zero, SSTT21 does nothing.
* It must be at least zero.
*
* KBAND (input) INTEGER
* The bandwidth of the matrix S. It may only be zero or one.
* If zero, then S is diagonal, and SE is not referenced. If
* one, then S is symmetric tri-diagonal.
*
* AD (input) REAL array, dimension (N)
* The diagonal of the original (unfactored) matrix A. A is
* assumed to be symmetric tridiagonal.
*
* AE (input) REAL array, dimension (N-1)
* The off-diagonal of the original (unfactored) matrix A. A
* is assumed to be symmetric tridiagonal. AE(1) is the (1,2)
* and (2,1) element, AE(2) is the (2,3) and (3,2) element, etc.
*
* SD (input) REAL array, dimension (N)
* The diagonal of the (symmetric tri-) diagonal matrix S.
*
* SE (input) REAL array, dimension (N-1)
* The off-diagonal of the (symmetric tri-) diagonal matrix S.
* Not referenced if KBSND=0. If KBAND=1, then AE(1) is the
* (1,2) and (2,1) element, SE(2) is the (2,3) and (3,2)
* element, etc.
*
* U (input) REAL array, dimension (LDU, N)
* The orthogonal matrix in the decomposition.
*
* LDU (input) INTEGER
* The leading dimension of U. LDU must be at least N.
*
* WORK (workspace) REAL array, dimension (N*(N+1))
*
* RESULT (output) REAL array, dimension (2)
* The values computed by the two tests described above. The
* values are currently limited to 1/ulp, to avoid overflow.
* RESULT(1) is always modified.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
INTEGER J
REAL ANORM, TEMP1, TEMP2, ULP, UNFL, WNORM
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE, SLANSY
EXTERNAL SLAMCH, SLANGE, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SLASET, SSYR, SSYR2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL
* ..
* .. Executable Statements ..
*
* 1) Constants
*
RESULT( 1 ) = ZERO
RESULT( 2 ) = ZERO
IF( N.LE.0 )
$ RETURN
*
UNFL = SLAMCH( 'Safe minimum' )
ULP = SLAMCH( 'Precision' )
*
* Do Test 1
*
* Copy A & Compute its 1-Norm:
*
CALL SLASET( 'Full', N, N, ZERO, ZERO, WORK, N )
*
ANORM = ZERO
TEMP1 = ZERO
*
DO 10 J = 1, N - 1
WORK( ( N+1 )*( J-1 )+1 ) = AD( J )
WORK( ( N+1 )*( J-1 )+2 ) = AE( J )
TEMP2 = ABS( AE( J ) )
ANORM = MAX( ANORM, ABS( AD( J ) )+TEMP1+TEMP2 )
TEMP1 = TEMP2
10 CONTINUE
*
WORK( N**2 ) = AD( N )
ANORM = MAX( ANORM, ABS( AD( N ) )+TEMP1, UNFL )
*
* Norm of A - USU'
*
DO 20 J = 1, N
CALL SSYR( 'L', N, -SD( J ), U( 1, J ), 1, WORK, N )
20 CONTINUE
*
IF( N.GT.1 .AND. KBAND.EQ.1 ) THEN
DO 30 J = 1, N - 1
CALL SSYR2( 'L', N, -SE( J ), U( 1, J ), 1, U( 1, J+1 ), 1,
$ WORK, N )
30 CONTINUE
END IF
*
WNORM = SLANSY( '1', 'L', N, WORK, N, WORK( N**2+1 ) )
*
IF( ANORM.GT.WNORM ) THEN
RESULT( 1 ) = ( WNORM / ANORM ) / ( N*ULP )
ELSE
IF( ANORM.LT.ONE ) THEN
RESULT( 1 ) = ( MIN( WNORM, N*ANORM ) / ANORM ) / ( N*ULP )
ELSE
RESULT( 1 ) = MIN( WNORM / ANORM, REAL( N ) ) / ( N*ULP )
END IF
END IF
*
* Do Test 2
*
* Compute UU' - I
*
CALL SGEMM( 'N', 'C', N, N, N, ONE, U, LDU, U, LDU, ZERO, WORK,
$ N )
*
DO 40 J = 1, N
WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - ONE
40 CONTINUE
*
RESULT( 2 ) = MIN( REAL( N ), SLANGE( '1', N, N, WORK, N,
$ WORK( N**2+1 ) ) ) / ( N*ULP )
*
RETURN
*
* End of SSTT21
*
END
SUBROUTINE SSTT22( N, M, KBAND, AD, AE, SD, SE, U, LDU, WORK,
$ LDWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KBAND, LDU, LDWORK, M, N
* ..
* .. Array Arguments ..
REAL AD( * ), AE( * ), RESULT( 2 ), SD( * ),
$ SE( * ), U( LDU, * ), WORK( LDWORK, * )
* ..
*
* Purpose
* =======
*
* SSTT22 checks a set of M eigenvalues and eigenvectors,
*
* A U = U S
*
* where A is symmetric tridiagonal, the columns of U are orthogonal,
* and S is diagonal (if KBAND=0) or symmetric tridiagonal (if KBAND=1).
* Two tests are performed:
*
* RESULT(1) = | U' A U - S | / ( |A| m ulp )
*
* RESULT(2) = | I - U'U | / ( m ulp )
*
* Arguments
* =========
*
* N (input) INTEGER
* The size of the matrix. If it is zero, SSTT22 does nothing.
* It must be at least zero.
*
* M (input) INTEGER
* The number of eigenpairs to check. If it is zero, SSTT22
* does nothing. It must be at least zero.
*
* KBAND (input) INTEGER
* The bandwidth of the matrix S. It may only be zero or one.
* If zero, then S is diagonal, and SE is not referenced. If
* one, then S is symmetric tri-diagonal.
*
* AD (input) REAL array, dimension (N)
* The diagonal of the original (unfactored) matrix A. A is
* assumed to be symmetric tridiagonal.
*
* AE (input) REAL array, dimension (N)
* The off-diagonal of the original (unfactored) matrix A. A
* is assumed to be symmetric tridiagonal. AE(1) is ignored,
* AE(2) is the (1,2) and (2,1) element, etc.
*
* SD (input) REAL array, dimension (N)
* The diagonal of the (symmetric tri-) diagonal matrix S.
*
* SE (input) REAL array, dimension (N)
* The off-diagonal of the (symmetric tri-) diagonal matrix S.
* Not referenced if KBSND=0. If KBAND=1, then AE(1) is
* ignored, SE(2) is the (1,2) and (2,1) element, etc.
*
* U (input) REAL array, dimension (LDU, N)
* The orthogonal matrix in the decomposition.
*
* LDU (input) INTEGER
* The leading dimension of U. LDU must be at least N.
*
* WORK (workspace) REAL array, dimension (LDWORK, M+1)
*
* LDWORK (input) INTEGER
* The leading dimension of WORK. LDWORK must be at least
* max(1,M).
*
* RESULT (output) REAL array, dimension (2)
* The values computed by the two tests described above. The
* values are currently limited to 1/ulp, to avoid overflow.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
INTEGER I, J, K
REAL ANORM, AUKJ, ULP, UNFL, WNORM
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE, SLANSY
EXTERNAL SLAMCH, SLANGE, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL SGEMM
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL
* ..
* .. Executable Statements ..
*
RESULT( 1 ) = ZERO
RESULT( 2 ) = ZERO
IF( N.LE.0 .OR. M.LE.0 )
$ RETURN
*
UNFL = SLAMCH( 'Safe minimum' )
ULP = SLAMCH( 'Epsilon' )
*
* Do Test 1
*
* Compute the 1-norm of A.
*
IF( N.GT.1 ) THEN
ANORM = ABS( AD( 1 ) ) + ABS( AE( 1 ) )
DO 10 J = 2, N - 1
ANORM = MAX( ANORM, ABS( AD( J ) )+ABS( AE( J ) )+
$ ABS( AE( J-1 ) ) )
10 CONTINUE
ANORM = MAX( ANORM, ABS( AD( N ) )+ABS( AE( N-1 ) ) )
ELSE
ANORM = ABS( AD( 1 ) )
END IF
ANORM = MAX( ANORM, UNFL )
*
* Norm of U'AU - S
*
DO 40 I = 1, M
DO 30 J = 1, M
WORK( I, J ) = ZERO
DO 20 K = 1, N
AUKJ = AD( K )*U( K, J )
IF( K.NE.N )
$ AUKJ = AUKJ + AE( K )*U( K+1, J )
IF( K.NE.1 )
$ AUKJ = AUKJ + AE( K-1 )*U( K-1, J )
WORK( I, J ) = WORK( I, J ) + U( K, I )*AUKJ
20 CONTINUE
30 CONTINUE
WORK( I, I ) = WORK( I, I ) - SD( I )
IF( KBAND.EQ.1 ) THEN
IF( I.NE.1 )
$ WORK( I, I-1 ) = WORK( I, I-1 ) - SE( I-1 )
IF( I.NE.N )
$ WORK( I, I+1 ) = WORK( I, I+1 ) - SE( I )
END IF
40 CONTINUE
*
WNORM = SLANSY( '1', 'L', M, WORK, M, WORK( 1, M+1 ) )
*
IF( ANORM.GT.WNORM ) THEN
RESULT( 1 ) = ( WNORM / ANORM ) / ( M*ULP )
ELSE
IF( ANORM.LT.ONE ) THEN
RESULT( 1 ) = ( MIN( WNORM, M*ANORM ) / ANORM ) / ( M*ULP )
ELSE
RESULT( 1 ) = MIN( WNORM / ANORM, REAL( M ) ) / ( M*ULP )
END IF
END IF
*
* Do Test 2
*
* Compute U'U - I
*
CALL SGEMM( 'T', 'N', M, M, N, ONE, U, LDU, U, LDU, ZERO, WORK,
$ M )
*
DO 50 J = 1, M
WORK( J, J ) = WORK( J, J ) - ONE
50 CONTINUE
*
RESULT( 2 ) = MIN( REAL( M ), SLANGE( '1', M, M, WORK, M, WORK( 1,
$ M+1 ) ) ) / ( M*ULP )
*
RETURN
*
* End of SSTT22
*
END
SUBROUTINE SSVDCH( N, S, E, SVD, TOL, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, N
REAL TOL
* ..
* .. Array Arguments ..
REAL E( * ), S( * ), SVD( * )
* ..
*
* Purpose
* =======
*
* SSVDCH checks to see if SVD(1) ,..., SVD(N) are accurate singular
* values of the bidiagonal matrix B with diagonal entries
* S(1) ,..., S(N) and superdiagonal entries E(1) ,..., E(N-1)).
* It does this by expanding each SVD(I) into an interval
* [SVD(I) * (1-EPS) , SVD(I) * (1+EPS)], merging overlapping intervals
* if any, and using Sturm sequences to count and verify whether each
* resulting interval has the correct number of singular values (using
* SSVDCT). Here EPS=TOL*MAX(N/10,1)*MACHEP, where MACHEP is the
* machine precision. The routine assumes the singular values are sorted
* with SVD(1) the largest and SVD(N) smallest. If each interval
* contains the correct number of singular values, INFO = 0 is returned,
* otherwise INFO is the index of the first singular value in the first
* bad interval.
*
* Arguments
* ==========
*
* N (input) INTEGER
* The dimension of the bidiagonal matrix B.
*
* S (input) REAL array, dimension (N)
* The diagonal entries of the bidiagonal matrix B.
*
* E (input) REAL array, dimension (N-1)
* The superdiagonal entries of the bidiagonal matrix B.
*
* SVD (input) REAL array, dimension (N)
* The computed singular values to be checked.
*
* TOL (input) REAL
* Error tolerance for checking, a multiplier of the
* machine precision.
*
* INFO (output) INTEGER
* =0 if the singular values are all correct (to within
* 1 +- TOL*MACHEPS)
* >0 if the interval containing the INFO-th singular value
* contains the incorrect number of singular values.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E0 )
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
INTEGER BPNT, COUNT, NUML, NUMU, TPNT
REAL EPS, LOWER, OVFL, TUPPR, UNFL, UNFLEP, UPPER
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SSVDCT
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Get machine constants
*
INFO = 0
IF( N.LE.0 )
$ RETURN
UNFL = SLAMCH( 'Safe minimum' )
OVFL = SLAMCH( 'Overflow' )
EPS = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
*
* UNFLEP is chosen so that when an eigenvalue is multiplied by the
* scale factor sqrt(OVFL)*sqrt(sqrt(UNFL))/MX in SSVDCT, it exceeds
* sqrt(UNFL), which is the lower limit for SSVDCT.
*
UNFLEP = ( SQRT( SQRT( UNFL ) ) / SQRT( OVFL ) )*SVD( 1 ) +
$ UNFL / EPS
*
* The value of EPS works best when TOL .GE. 10.
*
EPS = TOL*MAX( N / 10, 1 )*EPS
*
* TPNT points to singular value at right endpoint of interval
* BPNT points to singular value at left endpoint of interval
*
TPNT = 1
BPNT = 1
*
* Begin loop over all intervals
*
10 CONTINUE
UPPER = ( ONE+EPS )*SVD( TPNT ) + UNFLEP
LOWER = ( ONE-EPS )*SVD( BPNT ) - UNFLEP
IF( LOWER.LE.UNFLEP )
$ LOWER = -UPPER
*
* Begin loop merging overlapping intervals
*
20 CONTINUE
IF( BPNT.EQ.N )
$ GO TO 30
TUPPR = ( ONE+EPS )*SVD( BPNT+1 ) + UNFLEP
IF( TUPPR.LT.LOWER )
$ GO TO 30
*
* Merge
*
BPNT = BPNT + 1
LOWER = ( ONE-EPS )*SVD( BPNT ) - UNFLEP
IF( LOWER.LE.UNFLEP )
$ LOWER = -UPPER
GO TO 20
30 CONTINUE
*
* Count singular values in interval [ LOWER, UPPER ]
*
CALL SSVDCT( N, S, E, LOWER, NUML )
CALL SSVDCT( N, S, E, UPPER, NUMU )
COUNT = NUMU - NUML
IF( LOWER.LT.ZERO )
$ COUNT = COUNT / 2
IF( COUNT.NE.BPNT-TPNT+1 ) THEN
*
* Wrong number of singular values in interval
*
INFO = TPNT
GO TO 40
END IF
TPNT = BPNT + 1
BPNT = TPNT
IF( TPNT.LE.N )
$ GO TO 10
40 CONTINUE
RETURN
*
* End of SSVDCH
*
END
SUBROUTINE SSVDCT( N, S, E, SHIFT, NUM )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER N, NUM
REAL SHIFT
* ..
* .. Array Arguments ..
REAL E( * ), S( * )
* ..
*
* Purpose
* =======
*
* SSVDCT counts the number NUM of eigenvalues of a 2*N by 2*N
* tridiagonal matrix T which are less than or equal to SHIFT. T is
* formed by putting zeros on the diagonal and making the off-diagonals
* equal to S(1), E(1), S(2), E(2), ... , E(N-1), S(N). If SHIFT is
* positive, NUM is equal to N plus the number of singular values of a
* bidiagonal matrix B less than or equal to SHIFT. Here B has diagonal
* entries S(1), ..., S(N) and superdiagonal entries E(1), ... E(N-1).
* If SHIFT is negative, NUM is equal to the number of singular values
* of B greater than or equal to -SHIFT.
*
* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
* Matrix", Report CS41, Computer Science Dept., Stanford University,
* July 21, 1966
*
* Arguments
* =========
*
* N (input) INTEGER
* The dimension of the bidiagonal matrix B.
*
* S (input) REAL array, dimension (N)
* The diagonal entries of the bidiagonal matrix B.
*
* E (input) REAL array of dimension (N-1)
* The superdiagonal entries of the bidiagonal matrix B.
*
* SHIFT (input) REAL
* The shift, used as described under Purpose.
*
* NUM (output) INTEGER
* The number of eigenvalues of T less than or equal to SHIFT.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E0 )
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
INTEGER I
REAL M1, M2, MX, OVFL, SOV, SSHIFT, SSUN, SUN, TMP,
$ TOM, U, UNFL
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Get machine constants
*
UNFL = 2*SLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
*
* Find largest entry
*
MX = ABS( S( 1 ) )
DO 10 I = 1, N - 1
MX = MAX( MX, ABS( S( I+1 ) ), ABS( E( I ) ) )
10 CONTINUE
*
IF( MX.EQ.ZERO ) THEN
IF( SHIFT.LT.ZERO ) THEN
NUM = 0
ELSE
NUM = 2*N
END IF
RETURN
END IF
*
* Compute scale factors as in Kahan's report
*
SUN = SQRT( UNFL )
SSUN = SQRT( SUN )
SOV = SQRT( OVFL )
TOM = SSUN*SOV
IF( MX.LE.ONE ) THEN
M1 = ONE / MX
M2 = TOM
ELSE
M1 = ONE
M2 = TOM / MX
END IF
*
* Begin counting
*
U = ONE
NUM = 0
SSHIFT = ( SHIFT*M1 )*M2
U = -SSHIFT
IF( U.LE.SUN ) THEN
IF( U.LE.ZERO ) THEN
NUM = NUM + 1
IF( U.GT.-SUN )
$ U = -SUN
ELSE
U = SUN
END IF
END IF
TMP = ( S( 1 )*M1 )*M2
U = -TMP*( TMP / U ) - SSHIFT
IF( U.LE.SUN ) THEN
IF( U.LE.ZERO ) THEN
NUM = NUM + 1
IF( U.GT.-SUN )
$ U = -SUN
ELSE
U = SUN
END IF
END IF
DO 20 I = 1, N - 1
TMP = ( E( I )*M1 )*M2
U = -TMP*( TMP / U ) - SSHIFT
IF( U.LE.SUN ) THEN
IF( U.LE.ZERO ) THEN
NUM = NUM + 1
IF( U.GT.-SUN )
$ U = -SUN
ELSE
U = SUN
END IF
END IF
TMP = ( S( I+1 )*M1 )*M2
U = -TMP*( TMP / U ) - SSHIFT
IF( U.LE.SUN ) THEN
IF( U.LE.ZERO ) THEN
NUM = NUM + 1
IF( U.GT.-SUN )
$ U = -SUN
ELSE
U = SUN
END IF
END IF
20 CONTINUE
RETURN
*
* End of SSVDCT
*
END
REAL FUNCTION SSXT1( IJOB, D1, N1, D2, N2, ABSTOL,
$ ULP, UNFL )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IJOB, N1, N2
REAL ABSTOL, ULP, UNFL
* ..
* .. Array Arguments ..
REAL D1( * ), D2( * )
* ..
*
* Purpose
* =======
*
* SSXT1 computes the difference between a set of eigenvalues.
* The result is returned as the function value.
*
* IJOB = 1: Computes max { min | D1(i)-D2(j) | }
* i j
*
* IJOB = 2: Computes max { min | D1(i)-D2(j) | /
* i j
* ( ABSTOL + |D1(i)|*ULP ) }
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* Specifies the type of tests to be performed. (See above.)
*
* D1 (input) REAL array, dimension (N1)
* The first array. D1 should be in increasing order, i.e.,
* D1(j) <= D1(j+1).
*
* N1 (input) INTEGER
* The length of D1.
*
* D2 (input) REAL array, dimension (N2)
* The second array. D2 should be in increasing order, i.e.,
* D2(j) <= D2(j+1).
*
* N2 (input) INTEGER
* The length of D2.
*
* ABSTOL (input) REAL
* The absolute tolerance, used as a measure of the error.
*
* ULP (input) REAL
* Machine precision.
*
* UNFL (input) REAL
* The smallest positive number whose reciprocal does not
* overflow.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
INTEGER I, J
REAL TEMP1, TEMP2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
TEMP1 = ZERO
*
J = 1
DO 20 I = 1, N1
10 CONTINUE
IF( D2( J ).LT.D1( I ) .AND. J.LT.N2 ) THEN
J = J + 1
GO TO 10
END IF
IF( J.EQ.1 ) THEN
TEMP2 = ABS( D2( J )-D1( I ) )
IF( IJOB.EQ.2 )
$ TEMP2 = TEMP2 / MAX( UNFL, ABSTOL+ULP*ABS( D1( I ) ) )
ELSE
TEMP2 = MIN( ABS( D2( J )-D1( I ) ),
$ ABS( D1( I )-D2( J-1 ) ) )
IF( IJOB.EQ.2 )
$ TEMP2 = TEMP2 / MAX( UNFL, ABSTOL+ULP*ABS( D1( I ) ) )
END IF
TEMP1 = MAX( TEMP1, TEMP2 )
20 CONTINUE
*
SSXT1 = TEMP1
RETURN
*
* End of SSXT1
*
END
SUBROUTINE SSYT21( ITYPE, UPLO, N, KBAND, A, LDA, D, E, U, LDU, V,
$ LDV, TAU, WORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER ITYPE, KBAND, LDA, LDU, LDV, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), D( * ), E( * ), RESULT( 2 ),
$ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SSYT21 generally checks a decomposition of the form
*
* A = U S U'
*
* where ' means transpose, A is symmetric, U is orthogonal, and S is
* diagonal (if KBAND=0) or symmetric tridiagonal (if KBAND=1).
*
* If ITYPE=1, then U is represented as a dense matrix; otherwise U is
* expressed as a product of Householder transformations, whose vectors
* are stored in the array "V" and whose scaling constants are in "TAU".
* We shall use the letter "V" to refer to the product of Householder
* transformations (which should be equal to U).
*
* Specifically, if ITYPE=1, then:
*
* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and*
* RESULT(2) = | I - UU' | / ( n ulp )
*
* If ITYPE=2, then:
*
* RESULT(1) = | A - V S V' | / ( |A| n ulp )
*
* If ITYPE=3, then:
*
* RESULT(1) = | I - VU' | / ( n ulp )
*
* For ITYPE > 1, the transformation U is expressed as a product
* V = H(1)...H(n-2), where H(j) = I - tau(j) v(j) v(j)' and each
* vector v(j) has its first j elements 0 and the remaining n-j elements
* stored in V(j+1:n,j).
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* Specifies the type of tests to be performed.
* 1: U expressed as a dense orthogonal matrix:
* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and*
* RESULT(2) = | I - UU' | / ( n ulp )
*
* 2: U expressed as a product V of Housholder transformations:
* RESULT(1) = | A - V S V' | / ( |A| n ulp )
*
* 3: U expressed both as a dense orthogonal matrix and
* as a product of Housholder transformations:
* RESULT(1) = | I - VU' | / ( n ulp )
*
* UPLO (input) CHARACTER
* If UPLO='U', the upper triangle of A and V will be used and
* the (strictly) lower triangle will not be referenced.
* If UPLO='L', the lower triangle of A and V will be used and
* the (strictly) upper triangle will not be referenced.
*
* N (input) INTEGER
* The size of the matrix. If it is zero, SSYT21 does nothing.
* It must be at least zero.
*
* KBAND (input) INTEGER
* The bandwidth of the matrix. It may only be zero or one.
* If zero, then S is diagonal, and E is not referenced. If
* one, then S is symmetric tri-diagonal.
*
* A (input) REAL array, dimension (LDA, N)
* The original (unfactored) matrix. It is assumed to be
* symmetric, and only the upper (UPLO='U') or only the lower
* (UPLO='L') will be referenced.
*
* LDA (input) INTEGER
* The leading dimension of A. It must be at least 1
* and at least N.
*
* D (input) REAL array, dimension (N)
* The diagonal of the (symmetric tri-) diagonal matrix.
*
* E (input) REAL array, dimension (N-1)
* The off-diagonal of the (symmetric tri-) diagonal matrix.
* E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and
* (3,2) element, etc.
* Not referenced if KBAND=0.
*
* U (input) REAL array, dimension (LDU, N)
* If ITYPE=1 or 3, this contains the orthogonal matrix in
* the decomposition, expressed as a dense matrix. If ITYPE=2,
* then it is not referenced.
*
* LDU (input) INTEGER
* The leading dimension of U. LDU must be at least N and
* at least 1.
*
* V (input) REAL array, dimension (LDV, N)
* If ITYPE=2 or 3, the columns of this array contain the
* Householder vectors used to describe the orthogonal matrix
* in the decomposition. If UPLO='L', then the vectors are in
* the lower triangle, if UPLO='U', then in the upper
* triangle.
* *NOTE* If ITYPE=2 or 3, V is modified and restored. The
* subdiagonal (if UPLO='L') or the superdiagonal (if UPLO='U')
* is set to one, and later reset to its original value, during
* the course of the calculation.
* If ITYPE=1, then it is neither referenced nor modified.
*
* LDV (input) INTEGER
* The leading dimension of V. LDV must be at least N and
* at least 1.
*
* TAU (input) REAL array, dimension (N)
* If ITYPE >= 2, then TAU(j) is the scalar factor of
* v(j) v(j)' in the Householder transformation H(j) of
* the product U = H(1)...H(n-2)
* If ITYPE < 2, then TAU is not referenced.
*
* WORK (workspace) REAL array, dimension (2*N**2)
*
* RESULT (output) REAL array, dimension (2)
* The values computed by the two tests described above. The
* values are currently limited to 1/ulp, to avoid overflow.
* RESULT(1) is always modified. RESULT(2) is modified only
* if ITYPE=1.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TEN
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TEN = 10.0E0 )
* ..
* .. Local Scalars ..
LOGICAL LOWER
CHARACTER CUPLO
INTEGER IINFO, J, JCOL, JR, JROW
REAL ANORM, ULP, UNFL, VSAVE, WNORM
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANGE, SLANSY
EXTERNAL LSAME, SLAMCH, SLANGE, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SLACPY, SLARFY, SLASET, SORM2L, SORM2R,
$ SSYR, SSYR2
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Executable Statements ..
*
RESULT( 1 ) = ZERO
IF( ITYPE.EQ.1 )
$ RESULT( 2 ) = ZERO
IF( N.LE.0 )
$ RETURN
*
IF( LSAME( UPLO, 'U' ) ) THEN
LOWER = .FALSE.
CUPLO = 'U'
ELSE
LOWER = .TRUE.
CUPLO = 'L'
END IF
*
UNFL = SLAMCH( 'Safe minimum' )
ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
*
* Some Error Checks
*
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
RESULT( 1 ) = TEN / ULP
RETURN
END IF
*
* Do Test 1
*
* Norm of A:
*
IF( ITYPE.EQ.3 ) THEN
ANORM = ONE
ELSE
ANORM = MAX( SLANSY( '1', CUPLO, N, A, LDA, WORK ), UNFL )
END IF
*
* Compute error matrix:
*
IF( ITYPE.EQ.1 ) THEN
*
* ITYPE=1: error = A - U S U'
*
CALL SLASET( 'Full', N, N, ZERO, ZERO, WORK, N )
CALL SLACPY( CUPLO, N, N, A, LDA, WORK, N )
*
DO 10 J = 1, N
CALL SSYR( CUPLO, N, -D( J ), U( 1, J ), 1, WORK, N )
10 CONTINUE
*
IF( N.GT.1 .AND. KBAND.EQ.1 ) THEN
DO 20 J = 1, N - 1
CALL SSYR2( CUPLO, N, -E( J ), U( 1, J ), 1, U( 1, J+1 ),
$ 1, WORK, N )
20 CONTINUE
END IF
WNORM = SLANSY( '1', CUPLO, N, WORK, N, WORK( N**2+1 ) )
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* ITYPE=2: error = V S V' - A
*
CALL SLASET( 'Full', N, N, ZERO, ZERO, WORK, N )
*
IF( LOWER ) THEN
WORK( N**2 ) = D( N )
DO 40 J = N - 1, 1, -1
IF( KBAND.EQ.1 ) THEN
WORK( ( N+1 )*( J-1 )+2 ) = ( ONE-TAU( J ) )*E( J )
DO 30 JR = J + 2, N
WORK( ( J-1 )*N+JR ) = -TAU( J )*E( J )*V( JR, J )
30 CONTINUE
END IF
*
VSAVE = V( J+1, J )
V( J+1, J ) = ONE
CALL SLARFY( 'L', N-J, V( J+1, J ), 1, TAU( J ),
$ WORK( ( N+1 )*J+1 ), N, WORK( N**2+1 ) )
V( J+1, J ) = VSAVE
WORK( ( N+1 )*( J-1 )+1 ) = D( J )
40 CONTINUE
ELSE
WORK( 1 ) = D( 1 )
DO 60 J = 1, N - 1
IF( KBAND.EQ.1 ) THEN
WORK( ( N+1 )*J ) = ( ONE-TAU( J ) )*E( J )
DO 50 JR = 1, J - 1
WORK( J*N+JR ) = -TAU( J )*E( J )*V( JR, J+1 )
50 CONTINUE
END IF
*
VSAVE = V( J, J+1 )
V( J, J+1 ) = ONE
CALL SLARFY( 'U', J, V( 1, J+1 ), 1, TAU( J ), WORK, N,
$ WORK( N**2+1 ) )
V( J, J+1 ) = VSAVE
WORK( ( N+1 )*J+1 ) = D( J+1 )
60 CONTINUE
END IF
*
DO 90 JCOL = 1, N
IF( LOWER ) THEN
DO 70 JROW = JCOL, N
WORK( JROW+N*( JCOL-1 ) ) = WORK( JROW+N*( JCOL-1 ) )
$ - A( JROW, JCOL )
70 CONTINUE
ELSE
DO 80 JROW = 1, JCOL
WORK( JROW+N*( JCOL-1 ) ) = WORK( JROW+N*( JCOL-1 ) )
$ - A( JROW, JCOL )
80 CONTINUE
END IF
90 CONTINUE
WNORM = SLANSY( '1', CUPLO, N, WORK, N, WORK( N**2+1 ) )
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* ITYPE=3: error = U V' - I
*
IF( N.LT.2 )
$ RETURN
CALL SLACPY( ' ', N, N, U, LDU, WORK, N )
IF( LOWER ) THEN
CALL SORM2R( 'R', 'T', N, N-1, N-1, V( 2, 1 ), LDV, TAU,
$ WORK( N+1 ), N, WORK( N**2+1 ), IINFO )
ELSE
CALL SORM2L( 'R', 'T', N, N-1, N-1, V( 1, 2 ), LDV, TAU,
$ WORK, N, WORK( N**2+1 ), IINFO )
END IF
IF( IINFO.NE.0 ) THEN
RESULT( 1 ) = TEN / ULP
RETURN
END IF
*
DO 100 J = 1, N
WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - ONE
100 CONTINUE
*
WNORM = SLANGE( '1', N, N, WORK, N, WORK( N**2+1 ) )
END IF
*
IF( ANORM.GT.WNORM ) THEN
RESULT( 1 ) = ( WNORM / ANORM ) / ( N*ULP )
ELSE
IF( ANORM.LT.ONE ) THEN
RESULT( 1 ) = ( MIN( WNORM, N*ANORM ) / ANORM ) / ( N*ULP )
ELSE
RESULT( 1 ) = MIN( WNORM / ANORM, REAL( N ) ) / ( N*ULP )
END IF
END IF
*
* Do Test 2
*
* Compute UU' - I
*
IF( ITYPE.EQ.1 ) THEN
CALL SGEMM( 'N', 'C', N, N, N, ONE, U, LDU, U, LDU, ZERO, WORK,
$ N )
*
DO 110 J = 1, N
WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - ONE
110 CONTINUE
*
RESULT( 2 ) = MIN( SLANGE( '1', N, N, WORK, N,
$ WORK( N**2+1 ) ), REAL( N ) ) / ( N*ULP )
END IF
*
RETURN
*
* End of SSYT21
*
END
SUBROUTINE SSYT22( ITYPE, UPLO, N, M, KBAND, A, LDA, D, E, U, LDU,
$ V, LDV, TAU, WORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER ITYPE, KBAND, LDA, LDU, LDV, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), D( * ), E( * ), RESULT( 2 ),
$ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SSYT22 generally checks a decomposition of the form
*
* A U = U S
*
* where A is symmetric, the columns of U are orthonormal, and S
* is diagonal (if KBAND=0) or symmetric tridiagonal (if
* KBAND=1). If ITYPE=1, then U is represented as a dense matrix,
* otherwise the U is expressed as a product of Householder
* transformations, whose vectors are stored in the array "V" and
* whose scaling constants are in "TAU"; we shall use the letter
* "V" to refer to the product of Householder transformations
* (which should be equal to U).
*
* Specifically, if ITYPE=1, then:
*
* RESULT(1) = | U' A U - S | / ( |A| m ulp ) *and*
* RESULT(2) = | I - U'U | / ( m ulp )
*
* Arguments
* =========
*
* ITYPE INTEGER
* Specifies the type of tests to be performed.
* 1: U expressed as a dense orthogonal matrix:
* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and*
* RESULT(2) = | I - UU' | / ( n ulp )
*
* UPLO CHARACTER
* If UPLO='U', the upper triangle of A will be used and the
* (strictly) lower triangle will not be referenced. If
* UPLO='L', the lower triangle of A will be used and the
* (strictly) upper triangle will not be referenced.
* Not modified.
*
* N INTEGER
* The size of the matrix. If it is zero, SSYT22 does nothing.
* It must be at least zero.
* Not modified.
*
* M INTEGER
* The number of columns of U. If it is zero, SSYT22 does
* nothing. It must be at least zero.
* Not modified.
*
* KBAND INTEGER
* The bandwidth of the matrix. It may only be zero or one.
* If zero, then S is diagonal, and E is not referenced. If
* one, then S is symmetric tri-diagonal.
* Not modified.
*
* A REAL array, dimension (LDA , N)
* The original (unfactored) matrix. It is assumed to be
* symmetric, and only the upper (UPLO='U') or only the lower
* (UPLO='L') will be referenced.
* Not modified.
*
* LDA INTEGER
* The leading dimension of A. It must be at least 1
* and at least N.
* Not modified.
*
* D REAL array, dimension (N)
* The diagonal of the (symmetric tri-) diagonal matrix.
* Not modified.
*
* E REAL array, dimension (N)
* The off-diagonal of the (symmetric tri-) diagonal matrix.
* E(1) is ignored, E(2) is the (1,2) and (2,1) element, etc.
* Not referenced if KBAND=0.
* Not modified.
*
* U REAL array, dimension (LDU, N)
* If ITYPE=1 or 3, this contains the orthogonal matrix in
* the decomposition, expressed as a dense matrix. If ITYPE=2,
* then it is not referenced.
* Not modified.
*
* LDU INTEGER
* The leading dimension of U. LDU must be at least N and
* at least 1.
* Not modified.
*
* V REAL array, dimension (LDV, N)
* If ITYPE=2 or 3, the lower triangle of this array contains
* the Householder vectors used to describe the orthogonal
* matrix in the decomposition. If ITYPE=1, then it is not
* referenced.
* Not modified.
*
* LDV INTEGER
* The leading dimension of V. LDV must be at least N and
* at least 1.
* Not modified.
*
* TAU REAL array, dimension (N)
* If ITYPE >= 2, then TAU(j) is the scalar factor of
* v(j) v(j)' in the Householder transformation H(j) of
* the product U = H(1)...H(n-2)
* If ITYPE < 2, then TAU is not referenced.
* Not modified.
*
* WORK REAL array, dimension (2*N**2)
* Workspace.
* Modified.
*
* RESULT REAL array, dimension (2)
* The values computed by the two tests described above. The
* values are currently limited to 1/ulp, to avoid overflow.
* RESULT(1) is always modified. RESULT(2) is modified only
* if LDU is at least N.
* Modified.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
INTEGER J, JJ, JJ1, JJ2, NN, NNP1
REAL ANORM, ULP, UNFL, WNORM
* ..
* .. External Functions ..
REAL SLAMCH, SLANSY
EXTERNAL SLAMCH, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SSYMM
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Executable Statements ..
*
RESULT( 1 ) = ZERO
RESULT( 2 ) = ZERO
IF( N.LE.0 .OR. M.LE.0 )
$ RETURN
*
UNFL = SLAMCH( 'Safe minimum' )
ULP = SLAMCH( 'Precision' )
*
* Do Test 1
*
* Norm of A:
*
ANORM = MAX( SLANSY( '1', UPLO, N, A, LDA, WORK ), UNFL )
*
* Compute error matrix:
*
* ITYPE=1: error = U' A U - S
*
CALL SSYMM( 'L', UPLO, N, M, ONE, A, LDA, U, LDU, ZERO, WORK, N )
NN = N*N
NNP1 = NN + 1
CALL SGEMM( 'T', 'N', M, M, N, ONE, U, LDU, WORK, N, ZERO,
$ WORK( NNP1 ), N )
DO 10 J = 1, M
JJ = NN + ( J-1 )*N + J
WORK( JJ ) = WORK( JJ ) - D( J )
10 CONTINUE
IF( KBAND.EQ.1 .AND. N.GT.1 ) THEN
DO 20 J = 2, M
JJ1 = NN + ( J-1 )*N + J - 1
JJ2 = NN + ( J-2 )*N + J
WORK( JJ1 ) = WORK( JJ1 ) - E( J-1 )
WORK( JJ2 ) = WORK( JJ2 ) - E( J-1 )
20 CONTINUE
END IF
WNORM = SLANSY( '1', UPLO, M, WORK( NNP1 ), N, WORK( 1 ) )
*
IF( ANORM.GT.WNORM ) THEN
RESULT( 1 ) = ( WNORM / ANORM ) / ( M*ULP )
ELSE
IF( ANORM.LT.ONE ) THEN
RESULT( 1 ) = ( MIN( WNORM, M*ANORM ) / ANORM ) / ( M*ULP )
ELSE
RESULT( 1 ) = MIN( WNORM / ANORM, REAL( M ) ) / ( M*ULP )
END IF
END IF
*
* Do Test 2
*
* Compute U'U - I
*
IF( ITYPE.EQ.1 )
$ CALL SORT01( 'Columns', N, M, U, LDU, WORK, 2*N*N,
$ RESULT( 2 ) )
*
RETURN
*
* End of SSYT22
*
END
SUBROUTINE XLAENV( ISPEC, NVALUE )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER ISPEC, NVALUE
* ..
*
* Purpose
* =======
*
* XLAENV sets certain machine- and problem-dependent quantities
* which will later be retrieved by ILAENV.
*
* Arguments
* =========
*
* ISPEC (input) INTEGER
* Specifies the parameter to be set in the COMMON array IPARMS.
* = 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
* = 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: another crossover point, for the multishift QR and QZ
* methods for nonsymmetric eigenvalue problems.
* = 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
*
* NVALUE (input) INTEGER
* The value of the parameter specified by ISPEC.
*
* =====================================================================
*
* .. Arrays in Common ..
INTEGER IPARMS( 100 )
* ..
* .. Common blocks ..
COMMON / CLAENV / IPARMS
* ..
* .. Save statement ..
SAVE / CLAENV /
* ..
* .. Executable Statements ..
*
IF( ISPEC.GE.1 .AND. ISPEC.LE.16 ) THEN
IPARMS( ISPEC ) = NVALUE
END IF
*
RETURN
*
* End of XLAENV
*
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/seig/xerbla.f 0000644 0001750 0001750 00000004623 10616163241 023574 0 ustar osallou osallou SUBROUTINE XERBLA( SRNAME, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*6 SRNAME
INTEGER INFO
* ..
*
* Purpose
* =======
*
* This is a special version of XERBLA to be used only as part of
* the test program for testing error exits from the LAPACK routines.
* Error messages are printed if INFO.NE.INFOT or if SRNAME.NE.SRNAMT,
* where INFOT and SRNAMT are values stored in COMMON.
*
* Arguments
* =========
*
* SRNAME (input) CHARACTER*6
* The name of the subroutine calling XERBLA. This name should
* match the COMMON variable SRNAMT.
*
* INFO (input) INTEGER
* The error return code from the calling subroutine. INFO
* should equal the COMMON variable INFOT.
*
* Further Details
* ======= =======
*
* The following variables are passed via the common blocks INFOC and
* SRNAMC:
*
* INFOT INTEGER Expected integer return code
* NOUT INTEGER Unit number for printing error messages
* OK LOGICAL Set to .TRUE. if INFO = INFOT and
* SRNAME = SRNAMT, otherwise set to .FALSE.
* LERR LOGICAL Set to .TRUE., indicating that XERBLA was called
* SRNAMT CHARACTER*6 Expected name of calling subroutine
*
*
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
LERR = .TRUE.
IF( INFO.NE.INFOT ) THEN
IF( INFOT.NE.0 ) THEN
WRITE( NOUT, FMT = 9999 )SRNAMT, INFO, INFOT
ELSE
WRITE( NOUT, FMT = 9997 )SRNAME, INFO
END IF
OK = .FALSE.
END IF
IF( SRNAME.NE.SRNAMT ) THEN
WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT
OK = .FALSE.
END IF
RETURN
*
9999 FORMAT( ' *** XERBLA was called from ', A6, ' with INFO = ', I6,
$ ' instead of ', I2, ' ***' )
9998 FORMAT( ' *** XERBLA was called with SRNAME = ', A6,
$ ' instead of ', A6, ' ***' )
9997 FORMAT( ' *** On entry to ', A6, ' parameter number ', I6,
$ ' had an illegal value ***' )
*
* End of XERBLA
*
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/blas1/ 0000755 0001750 0001750 00000000000 11734055023 022216 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/blas1/Makefile_javasrc 0000644 0001750 0001750 00000002506 10616163233 025373 0 ustar osallou osallou .SUFFIXES: .f .java
ROOT=../../..
include $(ROOT)/make.def
tester: $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(BLAS1TEST_IDX) $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
/bin/rm -f `find . -name "*.class"`
mkdir -p $(JAVASRC_OUTDIR)
$(JAVAC) -classpath $(JAVASRC_OUTDIR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) -d $(JAVASRC_OUTDIR) $(OUTDIR)/$(BLASTEST_PDIR)/*.java
/bin/rm -f $(JAVASRC_OUTDIR)/$(BLASTEST_PDIR)/*.old
$(JAVAB) $(JAVASRC_OUTDIR)/$(BLASTEST_PDIR)/*.class
/bin/rm -f $(BLAS1TEST_JAR)
cd $(JAVASRC_OUTDIR); $(JAR) cvf ../$(BLAS1TEST_JAR) `find . -name "*.class"`
$(ROOT)/$(BLAS1TEST_IDX): dblat1.f
$(MAKE) nojar
$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):
cd $(ROOT)/$(BLAS_DIR); $(MAKE) -f Makefile_javasrc
$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):
cd $(ROOT)/$(UTIL_DIR); $(MAKE)
runtest: tester
$(JAVA) $(JFLAGS) -cp .:$(BLAS1TEST_JAR):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR) $(BLASTEST_PACKAGE).Dblat1
verify: $(ROOT)/$(BLAS1TEST_IDX)
cd $(JAVASRC_OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR) $(VERIFY) $(BLASTEST_PDIR)/*.class
clean:
/bin/rm -rf *.java *.class *.f2j $(OUTDIR) $(JAVASRC_OUTDIR) $(BLAS1TEST_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/blas1/dblat1.f 0000644 0001750 0001750 00000074751 10616163233 023553 0 ustar osallou osallou PROGRAM DBLAT1
* Test program for the DOUBLE PRECISION Level 1 BLAS.
* Based upon the original BLAS test routine together with:
* F06EAF Example Program Text
* .. Parameters ..
INTEGER NOUT
PARAMETER (NOUT=6)
* .. Scalars in Common ..
INTEGER ICASE, INCX, INCY, MODE, N
LOGICAL PASS
* .. Local Scalars ..
DOUBLE PRECISION SFAC
INTEGER IC
* .. External Subroutines ..
EXTERNAL CHECK0, CHECK1, CHECK2, CHECK3, HEADER
* .. Common blocks ..
COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
* .. Data statements ..
DATA SFAC/9.765625D-4/
* .. Executable Statements ..
WRITE (NOUT,99999)
DO 20 IC = 1, 10
ICASE = IC
CALL HEADER
*
* .. Initialize PASS, INCX, INCY, and MODE for a new case. ..
* .. the value 9999 for INCX, INCY or MODE will appear in the ..
* .. detailed output, if any, for cases that do not involve ..
* .. these parameters ..
*
PASS = .TRUE.
INCX = 9999
INCY = 9999
MODE = 9999
IF (ICASE.EQ.3) THEN
CALL CHECK0(SFAC)
ELSE IF (ICASE.EQ.7 .OR. ICASE.EQ.8 .OR. ICASE.EQ.9 .OR.
+ ICASE.EQ.10) THEN
CALL CHECK1(SFAC)
ELSE IF (ICASE.EQ.1 .OR. ICASE.EQ.2 .OR. ICASE.EQ.5 .OR.
+ ICASE.EQ.6) THEN
CALL CHECK2(SFAC)
ELSE IF (ICASE.EQ.4) THEN
CALL CHECK3(SFAC)
END IF
* -- Print
IF (PASS) WRITE (NOUT,99998)
20 CONTINUE
STOP
*
99999 FORMAT (' Real BLAS Test Program Results',/1X)
99998 FORMAT (' ----- PASS -----')
END
SUBROUTINE HEADER
* .. Parameters ..
INTEGER NOUT
PARAMETER (NOUT=6)
* .. Scalars in Common ..
INTEGER ICASE, INCX, INCY, MODE, N
LOGICAL PASS
* .. Local Arrays ..
CHARACTER*6 L(10)
* .. Common blocks ..
COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
* .. Data statements ..
DATA L(1)/' DDOT '/
DATA L(2)/'DAXPY '/
DATA L(3)/'DROTG '/
DATA L(4)/' DROT '/
DATA L(5)/'DCOPY '/
DATA L(6)/'DSWAP '/
DATA L(7)/'DNRM2 '/
DATA L(8)/'DASUM '/
DATA L(9)/'DSCAL '/
DATA L(10)/'IDAMAX'/
* .. Executable Statements ..
WRITE (NOUT,99999) ICASE, L(ICASE)
RETURN
*
99999 FORMAT (/' Test of subprogram number',I3,12X,A6)
END
SUBROUTINE CHECK0(SFAC)
* .. Parameters ..
INTEGER NOUT
PARAMETER (NOUT=6)
* .. Scalar Arguments ..
DOUBLE PRECISION SFAC
* .. Scalars in Common ..
INTEGER ICASE, INCX, INCY, MODE, N
LOGICAL PASS
* .. Local Scalars ..
DOUBLE PRECISION D12, SA, SB, SC, SS
INTEGER K
* .. Local Arrays ..
DOUBLE PRECISION DA1(8), DATRUE(8), DB1(8), DBTRUE(8), DC1(8),
+ DS1(8)
* .. External Subroutines ..
EXTERNAL DROTG, STEST1
* .. Common blocks ..
COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
* .. Data statements ..
DATA DA1/0.3D0, 0.4D0, -0.3D0, -0.4D0, -0.3D0, 0.0D0,
+ 0.0D0, 1.0D0/
DATA DB1/0.4D0, 0.3D0, 0.4D0, 0.3D0, -0.4D0, 0.0D0,
+ 1.0D0, 0.0D0/
DATA DC1/0.6D0, 0.8D0, -0.6D0, 0.8D0, 0.6D0, 1.0D0,
+ 0.0D0, 1.0D0/
DATA DS1/0.8D0, 0.6D0, 0.8D0, -0.6D0, 0.8D0, 0.0D0,
+ 1.0D0, 0.0D0/
DATA DATRUE/0.5D0, 0.5D0, 0.5D0, -0.5D0, -0.5D0,
+ 0.0D0, 1.0D0, 1.0D0/
DATA DBTRUE/0.0D0, 0.6D0, 0.0D0, -0.6D0, 0.0D0,
+ 0.0D0, 1.0D0, 0.0D0/
DATA D12/4096.0D0/
* .. Executable Statements ..
*
* Compute true values which cannot be prestored
* in decimal notation
*
DBTRUE(1) = 1.0D0/0.6D0
DBTRUE(3) = -1.0D0/0.6D0
DBTRUE(5) = 1.0D0/0.6D0
*
DO 20 K = 1, 8
* .. Set N=K for identification in output if any ..
N = K
IF (ICASE.EQ.3) THEN
* .. DROTG ..
IF (K.GT.8) GO TO 40
SA = DA1(K)
SB = DB1(K)
CALL DROTG(SA,SB,SC,SS)
CALL STEST1(SA,DATRUE(K),DATRUE(K),SFAC)
CALL STEST1(SB,DBTRUE(K),DBTRUE(K),SFAC)
CALL STEST1(SC,DC1(K),DC1(K),SFAC)
CALL STEST1(SS,DS1(K),DS1(K),SFAC)
ELSE
WRITE (NOUT,*) ' Shouldn''t be here in CHECK0'
STOP
END IF
20 CONTINUE
40 RETURN
END
SUBROUTINE CHECK1(SFAC)
* .. Parameters ..
INTEGER NOUT
PARAMETER (NOUT=6)
* .. Scalar Arguments ..
DOUBLE PRECISION SFAC
* .. Scalars in Common ..
INTEGER ICASE, INCX, INCY, MODE, N
LOGICAL PASS
* .. Local Scalars ..
INTEGER I, LEN, NP1
* .. Local Arrays ..
DOUBLE PRECISION DTRUE1(5), DTRUE3(5), DTRUE5(8,5,2), DV(8,5,2),
+ SA(10), STEMP(1), STRUE(8), SX(8)
INTEGER ITRUE2(5)
* .. External Functions ..
DOUBLE PRECISION DASUM, DNRM2
INTEGER IDAMAX
EXTERNAL DASUM, DNRM2, IDAMAX
* .. External Subroutines ..
EXTERNAL ITEST1, DSCAL, STEST, STEST1
* .. Intrinsic Functions ..
INTRINSIC MAX
* .. Common blocks ..
COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
* .. Data statements ..
DATA SA/0.3D0, -1.0D0, 0.0D0, 1.0D0, 0.3D0, 0.3D0,
+ 0.3D0, 0.3D0, 0.3D0, 0.3D0/
DATA DV/0.1D0, 2.0D0, 2.0D0, 2.0D0, 2.0D0, 2.0D0,
+ 2.0D0, 2.0D0, 0.3D0, 3.0D0, 3.0D0, 3.0D0, 3.0D0,
+ 3.0D0, 3.0D0, 3.0D0, 0.3D0, -0.4D0, 4.0D0,
+ 4.0D0, 4.0D0, 4.0D0, 4.0D0, 4.0D0, 0.2D0,
+ -0.6D0, 0.3D0, 5.0D0, 5.0D0, 5.0D0, 5.0D0,
+ 5.0D0, 0.1D0, -0.3D0, 0.5D0, -0.1D0, 6.0D0,
+ 6.0D0, 6.0D0, 6.0D0, 0.1D0, 8.0D0, 8.0D0, 8.0D0,
+ 8.0D0, 8.0D0, 8.0D0, 8.0D0, 0.3D0, 9.0D0, 9.0D0,
+ 9.0D0, 9.0D0, 9.0D0, 9.0D0, 9.0D0, 0.3D0, 2.0D0,
+ -0.4D0, 2.0D0, 2.0D0, 2.0D0, 2.0D0, 2.0D0,
+ 0.2D0, 3.0D0, -0.6D0, 5.0D0, 0.3D0, 2.0D0,
+ 2.0D0, 2.0D0, 0.1D0, 4.0D0, -0.3D0, 6.0D0,
+ -0.5D0, 7.0D0, -0.1D0, 3.0D0/
DATA DTRUE1/0.0D0, 0.3D0, 0.5D0, 0.7D0, 0.6D0/
DATA DTRUE3/0.0D0, 0.3D0, 0.7D0, 1.1D0, 1.0D0/
DATA DTRUE5/0.10D0, 2.0D0, 2.0D0, 2.0D0, 2.0D0,
+ 2.0D0, 2.0D0, 2.0D0, -0.3D0, 3.0D0, 3.0D0,
+ 3.0D0, 3.0D0, 3.0D0, 3.0D0, 3.0D0, 0.0D0, 0.0D0,
+ 4.0D0, 4.0D0, 4.0D0, 4.0D0, 4.0D0, 4.0D0,
+ 0.20D0, -0.60D0, 0.30D0, 5.0D0, 5.0D0, 5.0D0,
+ 5.0D0, 5.0D0, 0.03D0, -0.09D0, 0.15D0, -0.03D0,
+ 6.0D0, 6.0D0, 6.0D0, 6.0D0, 0.10D0, 8.0D0,
+ 8.0D0, 8.0D0, 8.0D0, 8.0D0, 8.0D0, 8.0D0,
+ 0.09D0, 9.0D0, 9.0D0, 9.0D0, 9.0D0, 9.0D0,
+ 9.0D0, 9.0D0, 0.09D0, 2.0D0, -0.12D0, 2.0D0,
+ 2.0D0, 2.0D0, 2.0D0, 2.0D0, 0.06D0, 3.0D0,
+ -0.18D0, 5.0D0, 0.09D0, 2.0D0, 2.0D0, 2.0D0,
+ 0.03D0, 4.0D0, -0.09D0, 6.0D0, -0.15D0, 7.0D0,
+ -0.03D0, 3.0D0/
DATA ITRUE2/0, 1, 2, 2, 3/
* .. Executable Statements ..
DO 80 INCX = 1, 2
DO 60 NP1 = 1, 5
N = NP1 - 1
LEN = 2*MAX(N,1)
* .. Set vector arguments ..
DO 20 I = 1, LEN
SX(I) = DV(I,NP1,INCX)
20 CONTINUE
*
IF (ICASE.EQ.7) THEN
* .. DNRM2 ..
STEMP(1) = DTRUE1(NP1)
CALL STEST1(DNRM2(N,SX,INCX),STEMP(1),STEMP,SFAC)
ELSE IF (ICASE.EQ.8) THEN
* .. DASUM ..
STEMP(1) = DTRUE3(NP1)
CALL STEST1(DASUM(N,SX,INCX),STEMP(1),STEMP,SFAC)
ELSE IF (ICASE.EQ.9) THEN
* .. DSCAL ..
CALL DSCAL(N,SA((INCX-1)*5+NP1),SX,INCX)
DO 40 I = 1, LEN
STRUE(I) = DTRUE5(I,NP1,INCX)
40 CONTINUE
CALL STEST(LEN,SX,STRUE,STRUE,SFAC)
ELSE IF (ICASE.EQ.10) THEN
* .. IDAMAX ..
CALL ITEST1(IDAMAX(N,SX,INCX),ITRUE2(NP1))
ELSE
WRITE (NOUT,*) ' Shouldn''t be here in CHECK1'
STOP
END IF
60 CONTINUE
80 CONTINUE
RETURN
END
SUBROUTINE CHECK2(SFAC)
* .. Parameters ..
INTEGER NOUT
PARAMETER (NOUT=6)
* .. Scalar Arguments ..
DOUBLE PRECISION SFAC
* .. Scalars in Common ..
INTEGER ICASE, INCX, INCY, MODE, N
LOGICAL PASS
* .. Local Scalars ..
DOUBLE PRECISION SA, SC, SS
INTEGER I, J, KI, KN, KSIZE, LENX, LENY, MX, MY
* .. Local Arrays ..
DOUBLE PRECISION DT10X(7,4,4), DT10Y(7,4,4), DT7(4,4),
+ DT8(7,4,4), DT9X(7,4,4), DT9Y(7,4,4), DX1(7),
+ DY1(7), SSIZE1(4), SSIZE2(14,2), STX(7), STY(7),
+ SX(7), SY(7)
INTEGER INCXS(4), INCYS(4), LENS(4,2), NS(4)
* .. External Functions ..
DOUBLE PRECISION DDOT
EXTERNAL DDOT
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DSWAP, STEST, STEST1
* .. Intrinsic Functions ..
INTRINSIC ABS, MIN
* .. Common blocks ..
COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
* .. Data statements ..
DATA SA/0.3D0/
DATA INCXS/1, 2, -2, -1/
DATA INCYS/1, -2, 1, -2/
DATA LENS/1, 1, 2, 4, 1, 1, 3, 7/
DATA NS/0, 1, 2, 4/
DATA DX1/0.6D0, 0.1D0, -0.5D0, 0.8D0, 0.9D0, -0.3D0,
+ -0.4D0/
DATA DY1/0.5D0, -0.9D0, 0.3D0, 0.7D0, -0.6D0, 0.2D0,
+ 0.8D0/
DATA SC, SS/0.8D0, 0.6D0/
DATA DT7/0.0D0, 0.30D0, 0.21D0, 0.62D0, 0.0D0,
+ 0.30D0, -0.07D0, 0.85D0, 0.0D0, 0.30D0, -0.79D0,
+ -0.74D0, 0.0D0, 0.30D0, 0.33D0, 1.27D0/
DATA DT8/0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.68D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.68D0, -0.87D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.68D0, -0.87D0, 0.15D0,
+ 0.94D0, 0.0D0, 0.0D0, 0.0D0, 0.5D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.68D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.35D0, -0.9D0, 0.48D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.38D0, -0.9D0, 0.57D0, 0.7D0, -0.75D0,
+ 0.2D0, 0.98D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.68D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.35D0, -0.72D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.38D0,
+ -0.63D0, 0.15D0, 0.88D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.68D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.68D0, -0.9D0, 0.33D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.68D0, -0.9D0, 0.33D0, 0.7D0,
+ -0.75D0, 0.2D0, 1.04D0/
DATA DT9X/0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.78D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.78D0, -0.46D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.78D0, -0.46D0, -0.22D0,
+ 1.06D0, 0.0D0, 0.0D0, 0.0D0, 0.6D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.78D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.66D0, 0.1D0, -0.1D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.96D0, 0.1D0, -0.76D0, 0.8D0, 0.90D0,
+ -0.3D0, -0.02D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.78D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.0D0, -0.06D0, 0.1D0,
+ -0.1D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.90D0,
+ 0.1D0, -0.22D0, 0.8D0, 0.18D0, -0.3D0, -0.02D0,
+ 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.78D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.78D0, 0.26D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.78D0, 0.26D0, -0.76D0, 1.12D0,
+ 0.0D0, 0.0D0, 0.0D0/
DATA DT9Y/0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.04D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.04D0, -0.78D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.04D0, -0.78D0, 0.54D0,
+ 0.08D0, 0.0D0, 0.0D0, 0.0D0, 0.5D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.04D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.7D0,
+ -0.9D0, -0.12D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.64D0, -0.9D0, -0.30D0, 0.7D0, -0.18D0, 0.2D0,
+ 0.28D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.04D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.7D0, -1.08D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.64D0, -1.26D0,
+ 0.54D0, 0.20D0, 0.0D0, 0.0D0, 0.0D0, 0.5D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.04D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.04D0, -0.9D0, 0.18D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.04D0, -0.9D0, 0.18D0, 0.7D0,
+ -0.18D0, 0.2D0, 0.16D0/
DATA DT10X/0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.5D0, -0.9D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.5D0, -0.9D0, 0.3D0, 0.7D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.3D0, 0.1D0, 0.5D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.8D0, 0.1D0, -0.6D0,
+ 0.8D0, 0.3D0, -0.3D0, 0.5D0, 0.6D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.5D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, -0.9D0,
+ 0.1D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.7D0,
+ 0.1D0, 0.3D0, 0.8D0, -0.9D0, -0.3D0, 0.5D0,
+ 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.5D0, 0.3D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.5D0, 0.3D0, -0.6D0, 0.8D0, 0.0D0, 0.0D0,
+ 0.0D0/
DATA DT10Y/0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.6D0, 0.1D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.6D0, 0.1D0, -0.5D0, 0.8D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, -0.5D0, -0.9D0, 0.6D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.0D0, -0.4D0, -0.9D0, 0.9D0,
+ 0.7D0, -0.5D0, 0.2D0, 0.6D0, 0.5D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.6D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, -0.5D0,
+ 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ -0.4D0, 0.9D0, -0.5D0, 0.6D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.6D0, -0.9D0, 0.1D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.6D0, -0.9D0, 0.1D0, 0.7D0,
+ -0.5D0, 0.2D0, 0.8D0/
DATA SSIZE1/0.0D0, 0.3D0, 1.6D0, 3.2D0/
DATA SSIZE2/0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0,
+ 1.17D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0,
+ 1.17D0, 1.17D0, 1.17D0/
* .. Executable Statements ..
*
DO 120 KI = 1, 4
INCX = INCXS(KI)
INCY = INCYS(KI)
MX = ABS(INCX)
MY = ABS(INCY)
*
DO 100 KN = 1, 4
N = NS(KN)
KSIZE = MIN(2,KN)
LENX = LENS(KN,MX)
LENY = LENS(KN,MY)
* .. Initialize all argument arrays ..
DO 20 I = 1, 7
SX(I) = DX1(I)
SY(I) = DY1(I)
20 CONTINUE
*
IF (ICASE.EQ.1) THEN
* .. DDOT ..
CALL STEST1(DDOT(N,SX,INCX,SY,INCY),DT7(KN,KI),SSIZE1(KN)
+ ,SFAC)
ELSE IF (ICASE.EQ.2) THEN
* .. DAXPY ..
CALL DAXPY(N,SA,SX,INCX,SY,INCY)
DO 40 J = 1, LENY
STY(J) = DT8(J,KN,KI)
40 CONTINUE
CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC)
ELSE IF (ICASE.EQ.5) THEN
* .. DCOPY ..
DO 60 I = 1, 7
STY(I) = DT10Y(I,KN,KI)
60 CONTINUE
CALL DCOPY(N,SX,INCX,SY,INCY)
CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.0D0)
ELSE IF (ICASE.EQ.6) THEN
* .. DSWAP ..
CALL DSWAP(N,SX,INCX,SY,INCY)
DO 80 I = 1, 7
STX(I) = DT10X(I,KN,KI)
STY(I) = DT10Y(I,KN,KI)
80 CONTINUE
CALL STEST(LENX,SX,STX,SSIZE2(1,1),1.0D0)
CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.0D0)
ELSE
WRITE (NOUT,*) ' Shouldn''t be here in CHECK2'
STOP
END IF
100 CONTINUE
120 CONTINUE
RETURN
END
SUBROUTINE CHECK3(SFAC)
* .. Parameters ..
INTEGER NOUT
PARAMETER (NOUT=6)
* .. Scalar Arguments ..
DOUBLE PRECISION SFAC
* .. Scalars in Common ..
INTEGER ICASE, INCX, INCY, MODE, N
LOGICAL PASS
* .. Local Scalars ..
DOUBLE PRECISION SA, SC, SS
INTEGER I, K, KI, KN, KSIZE, LENX, LENY, MX, MY
* .. Local Arrays ..
DOUBLE PRECISION COPYX(5), COPYY(5), DT9X(7,4,4), DT9Y(7,4,4),
+ DX1(7), DY1(7), MWPC(11), MWPS(11), MWPSTX(5),
+ MWPSTY(5), MWPTX(11,5), MWPTY(11,5), MWPX(5),
+ MWPY(5), SSIZE2(14,2), STX(7), STY(7), SX(7),
+ SY(7)
INTEGER INCXS(4), INCYS(4), LENS(4,2), MWPINX(11),
+ MWPINY(11), MWPN(11), NS(4)
* .. External Subroutines ..
EXTERNAL DROT, STEST
* .. Intrinsic Functions ..
INTRINSIC ABS, MIN
* .. Common blocks ..
COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
* .. Data statements ..
DATA SA/0.3D0/
DATA INCXS/1, 2, -2, -1/
DATA INCYS/1, -2, 1, -2/
DATA LENS/1, 1, 2, 4, 1, 1, 3, 7/
DATA NS/0, 1, 2, 4/
DATA DX1/0.6D0, 0.1D0, -0.5D0, 0.8D0, 0.9D0, -0.3D0,
+ -0.4D0/
DATA DY1/0.5D0, -0.9D0, 0.3D0, 0.7D0, -0.6D0, 0.2D0,
+ 0.8D0/
DATA SC, SS/0.8D0, 0.6D0/
DATA DT9X/0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.78D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.78D0, -0.46D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.78D0, -0.46D0, -0.22D0,
+ 1.06D0, 0.0D0, 0.0D0, 0.0D0, 0.6D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.78D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.66D0, 0.1D0, -0.1D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.96D0, 0.1D0, -0.76D0, 0.8D0, 0.90D0,
+ -0.3D0, -0.02D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.78D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.0D0, -0.06D0, 0.1D0,
+ -0.1D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.90D0,
+ 0.1D0, -0.22D0, 0.8D0, 0.18D0, -0.3D0, -0.02D0,
+ 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.78D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.78D0, 0.26D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.78D0, 0.26D0, -0.76D0, 1.12D0,
+ 0.0D0, 0.0D0, 0.0D0/
DATA DT9Y/0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.04D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.04D0, -0.78D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.04D0, -0.78D0, 0.54D0,
+ 0.08D0, 0.0D0, 0.0D0, 0.0D0, 0.5D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.04D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.7D0,
+ -0.9D0, -0.12D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.64D0, -0.9D0, -0.30D0, 0.7D0, -0.18D0, 0.2D0,
+ 0.28D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.04D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.7D0, -1.08D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.64D0, -1.26D0,
+ 0.54D0, 0.20D0, 0.0D0, 0.0D0, 0.0D0, 0.5D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.04D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.04D0, -0.9D0, 0.18D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.04D0, -0.9D0, 0.18D0, 0.7D0,
+ -0.18D0, 0.2D0, 0.16D0/
DATA SSIZE2/0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ 0.0D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0,
+ 1.17D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0,
+ 1.17D0, 1.17D0, 1.17D0/
* .. Executable Statements ..
*
DO 60 KI = 1, 4
INCX = INCXS(KI)
INCY = INCYS(KI)
MX = ABS(INCX)
MY = ABS(INCY)
*
DO 40 KN = 1, 4
N = NS(KN)
KSIZE = MIN(2,KN)
LENX = LENS(KN,MX)
LENY = LENS(KN,MY)
*
IF (ICASE.EQ.4) THEN
* .. DROT ..
DO 20 I = 1, 7
SX(I) = DX1(I)
SY(I) = DY1(I)
STX(I) = DT9X(I,KN,KI)
STY(I) = DT9Y(I,KN,KI)
20 CONTINUE
CALL DROT(N,SX,INCX,SY,INCY,SC,SS)
CALL STEST(LENX,SX,STX,SSIZE2(1,KSIZE),SFAC)
CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC)
ELSE
WRITE (NOUT,*) ' Shouldn''t be here in CHECK3'
STOP
END IF
40 CONTINUE
60 CONTINUE
*
MWPC(1) = 1
DO 80 I = 2, 11
MWPC(I) = 0
80 CONTINUE
MWPS(1) = 0
DO 100 I = 2, 6
MWPS(I) = 1
100 CONTINUE
DO 120 I = 7, 11
MWPS(I) = -1
120 CONTINUE
MWPINX(1) = 1
MWPINX(2) = 1
MWPINX(3) = 1
MWPINX(4) = -1
MWPINX(5) = 1
MWPINX(6) = -1
MWPINX(7) = 1
MWPINX(8) = 1
MWPINX(9) = -1
MWPINX(10) = 1
MWPINX(11) = -1
MWPINY(1) = 1
MWPINY(2) = 1
MWPINY(3) = -1
MWPINY(4) = -1
MWPINY(5) = 2
MWPINY(6) = 1
MWPINY(7) = 1
MWPINY(8) = -1
MWPINY(9) = -1
MWPINY(10) = 2
MWPINY(11) = 1
DO 140 I = 1, 11
MWPN(I) = 5
140 CONTINUE
MWPN(5) = 3
MWPN(10) = 3
DO 160 I = 1, 5
MWPX(I) = I
MWPY(I) = I
MWPTX(1,I) = I
MWPTY(1,I) = I
MWPTX(2,I) = I
MWPTY(2,I) = -I
MWPTX(3,I) = 6 - I
MWPTY(3,I) = I - 6
MWPTX(4,I) = I
MWPTY(4,I) = -I
MWPTX(6,I) = 6 - I
MWPTY(6,I) = I - 6
MWPTX(7,I) = -I
MWPTY(7,I) = I
MWPTX(8,I) = I - 6
MWPTY(8,I) = 6 - I
MWPTX(9,I) = -I
MWPTY(9,I) = I
MWPTX(11,I) = I - 6
MWPTY(11,I) = 6 - I
160 CONTINUE
MWPTX(5,1) = 1
MWPTX(5,2) = 3
MWPTX(5,3) = 5
MWPTX(5,4) = 4
MWPTX(5,5) = 5
MWPTY(5,1) = -1
MWPTY(5,2) = 2
MWPTY(5,3) = -2
MWPTY(5,4) = 4
MWPTY(5,5) = -3
MWPTX(10,1) = -1
MWPTX(10,2) = -3
MWPTX(10,3) = -5
MWPTX(10,4) = 4
MWPTX(10,5) = 5
MWPTY(10,1) = 1
MWPTY(10,2) = 2
MWPTY(10,3) = 2
MWPTY(10,4) = 4
MWPTY(10,5) = 3
DO 200 I = 1, 11
INCX = MWPINX(I)
INCY = MWPINY(I)
DO 180 K = 1, 5
COPYX(K) = MWPX(K)
COPYY(K) = MWPY(K)
MWPSTX(K) = MWPTX(I,K)
MWPSTY(K) = MWPTY(I,K)
180 CONTINUE
CALL DROT(MWPN(I),COPYX,INCX,COPYY,INCY,MWPC(I),MWPS(I))
CALL STEST(5,COPYX,MWPSTX,MWPSTX,SFAC)
CALL STEST(5,COPYY,MWPSTY,MWPSTY,SFAC)
200 CONTINUE
RETURN
END
SUBROUTINE STEST(LEN,SCOMP,STRUE,SSIZE,SFAC)
* ********************************* STEST **************************
*
* THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO
* SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE
* NEGLIGIBLE.
*
* C. L. LAWSON, JPL, 1974 DEC 10
*
* .. Parameters ..
INTEGER NOUT
PARAMETER (NOUT=6)
* .. Scalar Arguments ..
DOUBLE PRECISION SFAC
INTEGER LEN
* .. Array Arguments ..
DOUBLE PRECISION SCOMP(LEN), SSIZE(LEN), STRUE(LEN)
* .. Scalars in Common ..
INTEGER ICASE, INCX, INCY, MODE, N
LOGICAL PASS
* .. Local Scalars ..
DOUBLE PRECISION SD
INTEGER I
* .. External Functions ..
DOUBLE PRECISION SDIFF
EXTERNAL SDIFF
* .. Intrinsic Functions ..
INTRINSIC ABS
* .. Common blocks ..
COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
* .. Executable Statements ..
*
DO 40 I = 1, LEN
SD = SCOMP(I) - STRUE(I)
IF (SDIFF(ABS(SSIZE(I))+ABS(SFAC*SD),ABS(SSIZE(I))).EQ.0.0D0)
+ GO TO 40
*
* HERE SCOMP(I) IS NOT CLOSE TO STRUE(I).
*
IF ( .NOT. PASS) GO TO 20
* PRINT FAIL MESSAGE AND HEADER.
PASS = .FALSE.
WRITE (NOUT,99999)
WRITE (NOUT,99998)
20 WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, I, SCOMP(I),
+ STRUE(I), SD, SSIZE(I)
40 CONTINUE
RETURN
*
99999 FORMAT (' FAIL')
99998 FORMAT (/' CASE N INCX INCY MODE I ',
+ ' COMP(I) TRUE(I) DIFFERENCE',
+ ' SIZE(I)',/1X)
99997 FORMAT (1X,I4,I3,3I5,I3,2D36.8,2D12.4)
END
SUBROUTINE STEST1(SCOMP1,STRUE1,SSIZE,SFAC)
* ************************* STEST1 *****************************
*
* THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN
* REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE
* ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT.
*
* C.L. LAWSON, JPL, 1978 DEC 6
*
* .. Scalar Arguments ..
DOUBLE PRECISION SCOMP1, SFAC, STRUE1
* .. Array Arguments ..
DOUBLE PRECISION SSIZE(*)
* .. Local Arrays ..
DOUBLE PRECISION SCOMP(1), STRUE(1)
* .. External Subroutines ..
EXTERNAL STEST
* .. Executable Statements ..
*
SCOMP(1) = SCOMP1
STRUE(1) = STRUE1
CALL STEST(1,SCOMP,STRUE,SSIZE,SFAC)
*
RETURN
END
DOUBLE PRECISION FUNCTION SDIFF(SA,SB)
* ********************************* SDIFF **************************
* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15
*
* .. Scalar Arguments ..
DOUBLE PRECISION SA, SB
* .. Executable Statements ..
SDIFF = SA - SB
RETURN
END
SUBROUTINE ITEST1(ICOMP,ITRUE)
* ********************************* ITEST1 *************************
*
* THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR
* EQUALITY.
* C. L. LAWSON, JPL, 1974 DEC 10
*
* .. Parameters ..
INTEGER NOUT
PARAMETER (NOUT=6)
* .. Scalar Arguments ..
INTEGER ICOMP, ITRUE
* .. Scalars in Common ..
INTEGER ICASE, INCX, INCY, MODE, N
LOGICAL PASS
* .. Local Scalars ..
INTEGER ID
* .. Common blocks ..
COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
* .. Executable Statements ..
*
IF (ICOMP.EQ.ITRUE) GO TO 40
*
* HERE ICOMP IS NOT EQUAL TO ITRUE.
*
IF ( .NOT. PASS) GO TO 20
* PRINT FAIL MESSAGE AND HEADER.
PASS = .FALSE.
WRITE (NOUT,99999)
WRITE (NOUT,99998)
20 ID = ICOMP - ITRUE
WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, ICOMP, ITRUE, ID
40 CONTINUE
RETURN
*
99999 FORMAT (' FAIL')
99998 FORMAT (/' CASE N INCX INCY MODE ',
+ ' COMP TRUE DIFFERENCE',
+ /1X)
99997 FORMAT (1X,I4,I3,3I5,2I36,I12)
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/blas1/Makefile 0000644 0001750 0001750 00000002261 10616163233 023660 0 ustar osallou osallou .SUFFIXES: .f .java
ROOT=../../..
include $(ROOT)/make.def
F2JFLAGS=-c .:$(ROOT)/$(BLAS_OBJ) -p $(BLASTEST_PACKAGE) -o $(OUTDIR) $(STATIC)
tester: $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(BLAS1TEST_IDX) $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
/bin/rm -f $(BLAS1TEST_JAR)
cd $(OUTDIR); $(JAR) cvf ../$(BLAS1TEST_JAR) `find . -name "*.class"`
nojar: $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(BLAS1TEST_IDX) $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
$(ROOT)/$(BLAS1TEST_IDX): dblat1.f
$(F2J) $(F2JFLAGS) $< > /dev/null
$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):
cd $(ROOT)/$(BLAS_DIR); $(MAKE)
$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):
cd $(ROOT)/$(UTIL_DIR); $(MAKE)
runtest: tester
$(JAVA) $(JFLAGS) -cp .:$(BLAS1TEST_JAR):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR) $(BLASTEST_PACKAGE).Dblat1
srctest:
$(MAKE) -f Makefile_javasrc runtest
verify: $(ROOT)/$(BLAS1TEST_IDX)
cd $(OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR) $(VERIFY) $(BLASTEST_PDIR)/*.class
clean:
/bin/rm -rf *.java *.class *.f2j $(OUTDIR) $(JAVASRC_OUTDIR) $(BLAS1TEST_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/slin/ 0000755 0001750 0001750 00000000000 11734055026 022164 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/slin/slintest.f 0000644 0001750 0001750 00004442015 10616163241 024207 0 ustar osallou osallou SUBROUTINE ALADHD( IOUNIT, PATH )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER IOUNIT
* ..
*
* Purpose
* =======
*
* ALADHD prints header information for the driver routines test paths.
*
* Arguments
* =========
*
* IOUNIT (input) INTEGER
* The unit number to which the header information should be
* printed.
*
* PATH (input) CHARACTER*3
* The name of the path for which the header information is to
* be printed. Current paths are
* _GE: General matrices
* _GB: General band
* _GT: General Tridiagonal
* _PO: Symmetric or Hermitian positive definite
* _PP: Symmetric or Hermitian positive definite packed
* _PB: Symmetric or Hermitian positive definite band
* _PT: Symmetric or Hermitian positive definite tridiagonal
* _SY: Symmetric indefinite
* _SP: Symmetric indefinite packed
* _HE: (complex) Hermitian indefinite
* _HP: (complex) Hermitian indefinite packed
* The first character must be one of S, D, C, or Z (C or Z only
* if complex).
*
* .. Local Scalars ..
LOGICAL CORZ, SORD
CHARACTER C1, C3
CHARACTER*2 P2
CHARACTER*9 SYM
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Executable Statements ..
*
IF( IOUNIT.LE.0 )
$ RETURN
C1 = PATH( 1: 1 )
C3 = PATH( 3: 3 )
P2 = PATH( 2: 3 )
SORD = LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' )
CORZ = LSAME( C1, 'C' ) .OR. LSAME( C1, 'Z' )
IF( .NOT.( SORD .OR. CORZ ) )
$ RETURN
*
IF( LSAMEN( 2, P2, 'GE' ) ) THEN
*
* GE: General dense
*
WRITE( IOUNIT, FMT = 9999 )PATH
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9989 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9981 )1
WRITE( IOUNIT, FMT = 9980 )2
WRITE( IOUNIT, FMT = 9979 )3
WRITE( IOUNIT, FMT = 9978 )4
WRITE( IOUNIT, FMT = 9977 )5
WRITE( IOUNIT, FMT = 9976 )6
WRITE( IOUNIT, FMT = 9972 )7
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'GB' ) ) THEN
*
* GB: General band
*
WRITE( IOUNIT, FMT = 9998 )PATH
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9988 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9981 )1
WRITE( IOUNIT, FMT = 9980 )2
WRITE( IOUNIT, FMT = 9979 )3
WRITE( IOUNIT, FMT = 9978 )4
WRITE( IOUNIT, FMT = 9977 )5
WRITE( IOUNIT, FMT = 9976 )6
WRITE( IOUNIT, FMT = 9972 )7
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'GT' ) ) THEN
*
* GT: General tridiagonal
*
WRITE( IOUNIT, FMT = 9997 )PATH
WRITE( IOUNIT, FMT = 9987 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9981 )1
WRITE( IOUNIT, FMT = 9980 )2
WRITE( IOUNIT, FMT = 9979 )3
WRITE( IOUNIT, FMT = 9978 )4
WRITE( IOUNIT, FMT = 9977 )5
WRITE( IOUNIT, FMT = 9976 )6
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'PO' ) .OR. LSAMEN( 2, P2, 'PP' ) ) THEN
*
* PO: Positive definite full
* PP: Positive definite packed
*
IF( SORD ) THEN
SYM = 'Symmetric'
ELSE
SYM = 'Hermitian'
END IF
IF( LSAME( C3, 'O' ) ) THEN
WRITE( IOUNIT, FMT = 9996 )PATH, SYM
ELSE
WRITE( IOUNIT, FMT = 9995 )PATH, SYM
END IF
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9985 )PATH
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9975 )1
WRITE( IOUNIT, FMT = 9980 )2
WRITE( IOUNIT, FMT = 9979 )3
WRITE( IOUNIT, FMT = 9978 )4
WRITE( IOUNIT, FMT = 9977 )5
WRITE( IOUNIT, FMT = 9976 )6
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'PB' ) ) THEN
*
* PB: Positive definite band
*
IF( SORD ) THEN
WRITE( IOUNIT, FMT = 9994 )PATH, 'Symmetric'
ELSE
WRITE( IOUNIT, FMT = 9994 )PATH, 'Hermitian'
END IF
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9984 )PATH
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9975 )1
WRITE( IOUNIT, FMT = 9980 )2
WRITE( IOUNIT, FMT = 9979 )3
WRITE( IOUNIT, FMT = 9978 )4
WRITE( IOUNIT, FMT = 9977 )5
WRITE( IOUNIT, FMT = 9976 )6
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'PT' ) ) THEN
*
* PT: Positive definite tridiagonal
*
IF( SORD ) THEN
WRITE( IOUNIT, FMT = 9993 )PATH, 'Symmetric'
ELSE
WRITE( IOUNIT, FMT = 9993 )PATH, 'Hermitian'
END IF
WRITE( IOUNIT, FMT = 9986 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9973 )1
WRITE( IOUNIT, FMT = 9980 )2
WRITE( IOUNIT, FMT = 9979 )3
WRITE( IOUNIT, FMT = 9978 )4
WRITE( IOUNIT, FMT = 9977 )5
WRITE( IOUNIT, FMT = 9976 )6
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'SY' ) .OR. LSAMEN( 2, P2, 'SP' ) ) THEN
*
* SY: Symmetric indefinite full
* SP: Symmetric indefinite packed
*
IF( LSAME( C3, 'Y' ) ) THEN
WRITE( IOUNIT, FMT = 9992 )PATH, 'Symmetric'
ELSE
WRITE( IOUNIT, FMT = 9991 )PATH, 'Symmetric'
END IF
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
IF( SORD ) THEN
WRITE( IOUNIT, FMT = 9983 )
ELSE
WRITE( IOUNIT, FMT = 9982 )
END IF
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9974 )1
WRITE( IOUNIT, FMT = 9980 )2
WRITE( IOUNIT, FMT = 9979 )3
WRITE( IOUNIT, FMT = 9977 )4
WRITE( IOUNIT, FMT = 9978 )5
WRITE( IOUNIT, FMT = 9976 )6
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'HE' ) .OR. LSAMEN( 2, P2, 'HP' ) ) THEN
*
* HE: Hermitian indefinite full
* HP: Hermitian indefinite packed
*
IF( LSAME( C3, 'E' ) ) THEN
WRITE( IOUNIT, FMT = 9992 )PATH, 'Hermitian'
ELSE
WRITE( IOUNIT, FMT = 9991 )PATH, 'Hermitian'
END IF
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9983 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9974 )1
WRITE( IOUNIT, FMT = 9980 )2
WRITE( IOUNIT, FMT = 9979 )3
WRITE( IOUNIT, FMT = 9977 )4
WRITE( IOUNIT, FMT = 9978 )5
WRITE( IOUNIT, FMT = 9976 )6
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE
*
* Print error message if no header is available.
*
WRITE( IOUNIT, FMT = 9990 )PATH
END IF
*
* First line of header
*
9999 FORMAT( / 1X, A3, ' drivers: General dense matrices' )
9998 FORMAT( / 1X, A3, ' drivers: General band matrices' )
9997 FORMAT( / 1X, A3, ' drivers: General tridiagonal' )
9996 FORMAT( / 1X, A3, ' drivers: ', A9,
$ ' positive definite matrices' )
9995 FORMAT( / 1X, A3, ' drivers: ', A9,
$ ' positive definite packed matrices' )
9994 FORMAT( / 1X, A3, ' drivers: ', A9,
$ ' positive definite band matrices' )
9993 FORMAT( / 1X, A3, ' drivers: ', A9,
$ ' positive definite tridiagonal' )
9992 FORMAT( / 1X, A3, ' drivers: ', A9, ' indefinite matrices' )
9991 FORMAT( / 1X, A3, ' drivers: ', A9,
$ ' indefinite packed matrices' )
9990 FORMAT( / 1X, A3, ': No header available' )
*
* GE matrix types
*
9989 FORMAT( 4X, '1. Diagonal', 24X, '7. Last n/2 columns zero', / 4X,
$ '2. Upper triangular', 16X,
$ '8. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
$ '3. Lower triangular', 16X, '9. Random, CNDNUM = 0.1/EPS',
$ / 4X, '4. Random, CNDNUM = 2', 13X,
$ '10. Scaled near underflow', / 4X, '5. First column zero',
$ 14X, '11. Scaled near overflow', / 4X,
$ '6. Last column zero' )
*
* GB matrix types
*
9988 FORMAT( 4X, '1. Random, CNDNUM = 2', 14X,
$ '5. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
$ '2. First column zero', 15X, '6. Random, CNDNUM = 0.1/EPS',
$ / 4X, '3. Last column zero', 16X,
$ '7. Scaled near underflow', / 4X,
$ '4. Last n/2 columns zero', 11X, '8. Scaled near overflow' )
*
* GT matrix types
*
9987 FORMAT( ' Matrix types (1-6 have specified condition numbers):',
$ / 4X, '1. Diagonal', 24X, '7. Random, unspecified CNDNUM',
$ / 4X, '2. Random, CNDNUM = 2', 14X, '8. First column zero',
$ / 4X, '3. Random, CNDNUM = sqrt(0.1/EPS)', 2X,
$ '9. Last column zero', / 4X, '4. Random, CNDNUM = 0.1/EPS',
$ 7X, '10. Last n/2 columns zero', / 4X,
$ '5. Scaled near underflow', 10X,
$ '11. Scaled near underflow', / 4X,
$ '6. Scaled near overflow', 11X, '12. Scaled near overflow' )
*
* PT matrix types
*
9986 FORMAT( ' Matrix types (1-6 have specified condition numbers):',
$ / 4X, '1. Diagonal', 24X, '7. Random, unspecified CNDNUM',
$ / 4X, '2. Random, CNDNUM = 2', 14X,
$ '8. First row and column zero', / 4X,
$ '3. Random, CNDNUM = sqrt(0.1/EPS)', 2X,
$ '9. Last row and column zero', / 4X,
$ '4. Random, CNDNUM = 0.1/EPS', 7X,
$ '10. Middle row and column zero', / 4X,
$ '5. Scaled near underflow', 10X,
$ '11. Scaled near underflow', / 4X,
$ '6. Scaled near overflow', 11X, '12. Scaled near overflow' )
*
* PO, PP matrix types
*
9985 FORMAT( 4X, '1. Diagonal', 24X,
$ '6. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
$ '2. Random, CNDNUM = 2', 14X, '7. Random, CNDNUM = 0.1/EPS',
$ / 3X, '*3. First row and column zero', 7X,
$ '8. Scaled near underflow', / 3X,
$ '*4. Last row and column zero', 8X,
$ '9. Scaled near overflow', / 3X,
$ '*5. Middle row and column zero', / 3X,
$ '(* - tests error exits from ', A3,
$ 'TRF, no test ratios are computed)' )
*
* PB matrix types
*
9984 FORMAT( 4X, '1. Random, CNDNUM = 2', 14X,
$ '5. Random, CNDNUM = sqrt(0.1/EPS)', / 3X,
$ '*2. First row and column zero', 7X,
$ '6. Random, CNDNUM = 0.1/EPS', / 3X,
$ '*3. Last row and column zero', 8X,
$ '7. Scaled near underflow', / 3X,
$ '*4. Middle row and column zero', 6X,
$ '8. Scaled near overflow', / 3X,
$ '(* - tests error exits from ', A3,
$ 'TRF, no test ratios are computed)' )
*
* SSY, SSP, CHE, CHP matrix types
*
9983 FORMAT( 4X, '1. Diagonal', 24X,
$ '6. Last n/2 rows and columns zero', / 4X,
$ '2. Random, CNDNUM = 2', 14X,
$ '7. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
$ '3. First row and column zero', 7X,
$ '8. Random, CNDNUM = 0.1/EPS', / 4X,
$ '4. Last row and column zero', 8X,
$ '9. Scaled near underflow', / 4X,
$ '5. Middle row and column zero', 5X,
$ '10. Scaled near overflow' )
*
* CSY, CSP matrix types
*
9982 FORMAT( 4X, '1. Diagonal', 24X,
$ '7. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
$ '2. Random, CNDNUM = 2', 14X, '8. Random, CNDNUM = 0.1/EPS',
$ / 4X, '3. First row and column zero', 7X,
$ '9. Scaled near underflow', / 4X,
$ '4. Last row and column zero', 7X,
$ '10. Scaled near overflow', / 4X,
$ '5. Middle row and column zero', 5X,
$ '11. Block diagonal matrix', / 4X,
$ '6. Last n/2 rows and columns zero' )
*
* Test ratios
*
9981 FORMAT( 3X, I2, ': norm( L * U - A ) / ( N * norm(A) * EPS )' )
9980 FORMAT( 3X, I2, ': norm( B - A * X ) / ',
$ '( norm(A) * norm(X) * EPS )' )
9979 FORMAT( 3X, I2, ': norm( X - XACT ) / ',
$ '( norm(XACT) * CNDNUM * EPS )' )
9978 FORMAT( 3X, I2, ': norm( X - XACT ) / ',
$ '( norm(XACT) * (error bound) )' )
9977 FORMAT( 3X, I2, ': (backward error) / EPS' )
9976 FORMAT( 3X, I2, ': RCOND * CNDNUM - 1.0' )
9975 FORMAT( 3X, I2, ': norm( U'' * U - A ) / ( N * norm(A) * EPS )',
$ ', or', / 7X, 'norm( L * L'' - A ) / ( N * norm(A) * EPS )'
$ )
9974 FORMAT( 3X, I2, ': norm( U*D*U'' - A ) / ( N * norm(A) * EPS )',
$ ', or', / 7X, 'norm( L*D*L'' - A ) / ( N * norm(A) * EPS )'
$ )
9973 FORMAT( 3X, I2, ': norm( U''*D*U - A ) / ( N * norm(A) * EPS )',
$ ', or', / 7X, 'norm( L*D*L'' - A ) / ( N * norm(A) * EPS )'
$ )
9972 FORMAT( 3X, I2, ': abs( WORK(1) - RPVGRW ) /',
$ ' ( max( WORK(1), RPVGRW ) * EPS )' )
*
RETURN
*
* End of ALADHD
*
END
SUBROUTINE ALAERH( PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU,
$ N5, IMAT, NFAIL, NERRS, NOUT )
*
* -- LAPACK auxiliary test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
CHARACTER*6 SUBNAM
CHARACTER*( * ) OPTS
INTEGER IMAT, INFO, INFOE, KL, KU, M, N, N5, NERRS,
$ NFAIL, NOUT
* ..
*
* Purpose
* =======
*
* ALAERH is an error handler for the LAPACK routines. It prints the
* header if this is the first error message and prints the error code
* and form of recovery, if any. The character evaluations in this
* routine may make it slow, but it should not be called once the LAPACK
* routines are fully debugged.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name of subroutine SUBNAM.
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine that returned an error code.
*
* INFO (input) INTEGER
* The error code returned from routine SUBNAM.
*
* INFOE (input) INTEGER
* The expected error code from routine SUBNAM, if SUBNAM were
* error-free. If INFOE = 0, an error message is printed, but
* if INFOE.NE.0, we assume only the return code INFO is wrong.
*
* OPTS (input) CHARACTER*(*)
* The character options to the subroutine SUBNAM, 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'.
*
* M (input) INTEGER
* The matrix row dimension.
*
* N (input) INTEGER
* The matrix column dimension. Accessed only if PATH = xGE or
* xGB.
*
* KL (input) INTEGER
* The number of sub-diagonals of the matrix. Accessed only if
* PATH = xGB, xPB, or xTB. Also used for NRHS for PATH = xLS.
*
* KU (input) INTEGER
* The number of super-diagonals of the matrix. Accessed only
* if PATH = xGB.
*
* N5 (input) INTEGER
* A fifth integer parameter, may be the blocksize NB or the
* number of right hand sides NRHS.
*
* IMAT (input) INTEGER
* The matrix type.
*
* NFAIL (input) INTEGER
* The number of prior tests that did not pass the threshold;
* used to determine if the header should be printed.
*
* NERRS (input/output) INTEGER
* On entry, the number of errors already detected; used to
* determine if the header should be printed.
* On exit, NERRS is increased by 1.
*
* NOUT (input) INTEGER
* The unit number on which results are to be printed.
*
* =====================================================================
*
* .. Local Scalars ..
CHARACTER UPLO
CHARACTER*2 P2
CHARACTER*3 C3
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL ALADHD, ALAHD
* ..
* .. Executable Statements ..
*
IF( INFO.EQ.0 )
$ RETURN
P2 = PATH( 2: 3 )
C3 = SUBNAM( 4: 6 )
*
* Print the header if this is the first error message.
*
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) THEN
IF( LSAMEN( 3, C3, 'SV ' ) .OR. LSAMEN( 3, C3, 'SVX' ) ) THEN
CALL ALADHD( NOUT, PATH )
ELSE
CALL ALAHD( NOUT, PATH )
END IF
END IF
NERRS = NERRS + 1
*
* Print the message detailing the error and form of recovery,
* if any.
*
IF( LSAMEN( 2, P2, 'GE' ) ) THEN
*
* xGE: General matrices
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9988 )SUBNAM, INFO, INFOE, M, N, N5,
$ IMAT
ELSE
WRITE( NOUT, FMT = 9975 )SUBNAM, INFO, M, N, N5, IMAT
END IF
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9949 )
*
ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9984 )SUBNAM, INFO, INFOE, N, N5,
$ IMAT
ELSE
WRITE( NOUT, FMT = 9970 )SUBNAM, INFO, N, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9992 )SUBNAM, INFO, INFOE,
$ OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT
ELSE
WRITE( NOUT, FMT = 9997 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), N, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
*
WRITE( NOUT, FMT = 9971 )SUBNAM, INFO, N, N5, IMAT
*
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN
*
WRITE( NOUT, FMT = 9978 )SUBNAM, INFO, M, N, IMAT
*
ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN
*
WRITE( NOUT, FMT = 9969 )SUBNAM, INFO, OPTS( 1: 1 ), M,
$ IMAT
*
ELSE IF( LSAMEN( 3, C3, 'LS ' ) ) THEN
*
WRITE( NOUT, FMT = 9965 )SUBNAM, INFO, OPTS( 1: 1 ), M, N,
$ KL, N5, IMAT
*
ELSE IF( LSAMEN( 3, C3, 'LSX' ) .OR. LSAMEN( 3, C3, 'LSS' ) )
$ THEN
*
WRITE( NOUT, FMT = 9974 )SUBNAM, INFO, M, N, KL, N5, IMAT
*
ELSE
*
WRITE( NOUT, FMT = 9963 )SUBNAM, INFO, OPTS( 1: 1 ), M, N5,
$ IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'GB' ) ) THEN
*
* xGB: General band matrices
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9989 )SUBNAM, INFO, INFOE, M, N, KL,
$ KU, N5, IMAT
ELSE
WRITE( NOUT, FMT = 9976 )SUBNAM, INFO, M, N, KL, KU, N5,
$ IMAT
END IF
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9949 )
*
ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9986 )SUBNAM, INFO, INFOE, N, KL, KU,
$ N5, IMAT
ELSE
WRITE( NOUT, FMT = 9972 )SUBNAM, INFO, N, KL, KU, N5,
$ IMAT
END IF
*
ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9993 )SUBNAM, INFO, INFOE,
$ OPTS( 1: 1 ), OPTS( 2: 2 ), N, KL, KU, N5, IMAT
ELSE
WRITE( NOUT, FMT = 9998 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), N, KL, KU, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN
*
WRITE( NOUT, FMT = 9977 )SUBNAM, INFO, M, N, KL, KU, IMAT
*
ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN
*
WRITE( NOUT, FMT = 9968 )SUBNAM, INFO, OPTS( 1: 1 ), M, KL,
$ KU, IMAT
*
ELSE
*
WRITE( NOUT, FMT = 9964 )SUBNAM, INFO, OPTS( 1: 1 ), M, KL,
$ KU, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'GT' ) ) THEN
*
* xGT: General tridiagonal matrices
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9987 )SUBNAM, INFO, INFOE, N, IMAT
ELSE
WRITE( NOUT, FMT = 9973 )SUBNAM, INFO, N, IMAT
END IF
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9949 )
*
ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9984 )SUBNAM, INFO, INFOE, N, N5,
$ IMAT
ELSE
WRITE( NOUT, FMT = 9970 )SUBNAM, INFO, N, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9992 )SUBNAM, INFO, INFOE,
$ OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT
ELSE
WRITE( NOUT, FMT = 9997 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), N, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN
*
WRITE( NOUT, FMT = 9969 )SUBNAM, INFO, OPTS( 1: 1 ), M,
$ IMAT
*
ELSE
*
WRITE( NOUT, FMT = 9963 )SUBNAM, INFO, OPTS( 1: 1 ), M, N5,
$ IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'PO' ) ) THEN
*
* xPO: Symmetric or Hermitian positive definite matrices
*
UPLO = OPTS( 1: 1 )
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9980 )SUBNAM, INFO, INFOE, UPLO, M,
$ N5, IMAT
ELSE
WRITE( NOUT, FMT = 9956 )SUBNAM, INFO, UPLO, M, N5, IMAT
END IF
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9949 )
*
ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9979 )SUBNAM, INFO, INFOE, UPLO, N,
$ N5, IMAT
ELSE
WRITE( NOUT, FMT = 9955 )SUBNAM, INFO, UPLO, N, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9990 )SUBNAM, INFO, INFOE,
$ OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT
ELSE
WRITE( NOUT, FMT = 9995 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), N, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
*
WRITE( NOUT, FMT = 9956 )SUBNAM, INFO, UPLO, M, N5, IMAT
*
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) .OR.
$ LSAMEN( 3, C3, 'CON' ) ) THEN
*
WRITE( NOUT, FMT = 9960 )SUBNAM, INFO, UPLO, M, IMAT
*
ELSE
*
WRITE( NOUT, FMT = 9955 )SUBNAM, INFO, UPLO, M, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'SY' ) .OR. LSAMEN( 2, P2, 'HE' ) ) THEN
*
* xHE, or xSY: Symmetric or Hermitian indefinite matrices
*
UPLO = OPTS( 1: 1 )
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9980 )SUBNAM, INFO, INFOE, UPLO, M,
$ N5, IMAT
ELSE
WRITE( NOUT, FMT = 9956 )SUBNAM, INFO, UPLO, M, N5, IMAT
END IF
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9949 )
*
ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9979 )SUBNAM, INFO, INFOE, UPLO, N,
$ N5, IMAT
ELSE
WRITE( NOUT, FMT = 9955 )SUBNAM, INFO, UPLO, N, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9990 )SUBNAM, INFO, INFOE,
$ OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT
ELSE
WRITE( NOUT, FMT = 9995 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), N, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) .OR.
$ LSAMEN( 3, C3, 'TRI' ) .OR. LSAMEN( 3, C3, 'CON' ) )
$ THEN
*
WRITE( NOUT, FMT = 9960 )SUBNAM, INFO, UPLO, M, IMAT
*
ELSE
*
WRITE( NOUT, FMT = 9955 )SUBNAM, INFO, UPLO, M, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'PP' ) .OR. LSAMEN( 2, P2, 'SP' ) .OR.
$ LSAMEN( 2, P2, 'HP' ) ) THEN
*
* xPP, xHP, or xSP: Symmetric or Hermitian packed matrices
*
UPLO = OPTS( 1: 1 )
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9983 )SUBNAM, INFO, INFOE, UPLO, M,
$ IMAT
ELSE
WRITE( NOUT, FMT = 9960 )SUBNAM, INFO, UPLO, M, IMAT
END IF
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9949 )
*
ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9979 )SUBNAM, INFO, INFOE, UPLO, N,
$ N5, IMAT
ELSE
WRITE( NOUT, FMT = 9955 )SUBNAM, INFO, UPLO, N, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9990 )SUBNAM, INFO, INFOE,
$ OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT
ELSE
WRITE( NOUT, FMT = 9995 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), N, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) .OR.
$ LSAMEN( 3, C3, 'TRI' ) .OR. LSAMEN( 3, C3, 'CON' ) )
$ THEN
*
WRITE( NOUT, FMT = 9960 )SUBNAM, INFO, UPLO, M, IMAT
*
ELSE
*
WRITE( NOUT, FMT = 9955 )SUBNAM, INFO, UPLO, M, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'PB' ) ) THEN
*
* xPB: Symmetric (Hermitian) positive definite band matrix
*
UPLO = OPTS( 1: 1 )
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9982 )SUBNAM, INFO, INFOE, UPLO, M,
$ KL, N5, IMAT
ELSE
WRITE( NOUT, FMT = 9958 )SUBNAM, INFO, UPLO, M, KL, N5,
$ IMAT
END IF
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9949 )
*
ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9981 )SUBNAM, INFO, INFOE, UPLO, N,
$ KL, N5, IMAT
ELSE
WRITE( NOUT, FMT = 9957 )SUBNAM, INFO, UPLO, N, KL, N5,
$ IMAT
END IF
*
ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9991 )SUBNAM, INFO, INFOE,
$ OPTS( 1: 1 ), OPTS( 2: 2 ), N, KL, N5, IMAT
ELSE
WRITE( NOUT, FMT = 9996 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), N, KL, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) .OR.
$ LSAMEN( 3, C3, 'CON' ) ) THEN
*
WRITE( NOUT, FMT = 9959 )SUBNAM, INFO, UPLO, M, KL, IMAT
*
ELSE
*
WRITE( NOUT, FMT = 9957 )SUBNAM, INFO, UPLO, M, KL, N5,
$ IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'PT' ) ) THEN
*
* xPT: Positive definite tridiagonal matrices
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9987 )SUBNAM, INFO, INFOE, N, IMAT
ELSE
WRITE( NOUT, FMT = 9973 )SUBNAM, INFO, N, IMAT
END IF
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9949 )
*
ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9984 )SUBNAM, INFO, INFOE, N, N5,
$ IMAT
ELSE
WRITE( NOUT, FMT = 9970 )SUBNAM, INFO, N, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9994 )SUBNAM, INFO, INFOE,
$ OPTS( 1: 1 ), N, N5, IMAT
ELSE
WRITE( NOUT, FMT = 9999 )SUBNAM, INFO, OPTS( 1: 1 ), N,
$ N5, IMAT
END IF
*
ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN
*
IF( LSAME( SUBNAM( 1: 1 ), 'S' ) .OR.
$ LSAME( SUBNAM( 1: 1 ), 'D' ) ) THEN
WRITE( NOUT, FMT = 9973 )SUBNAM, INFO, M, IMAT
ELSE
WRITE( NOUT, FMT = 9969 )SUBNAM, INFO, OPTS( 1: 1 ), M,
$ IMAT
END IF
*
ELSE
*
WRITE( NOUT, FMT = 9963 )SUBNAM, INFO, OPTS( 1: 1 ), M, N5,
$ IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'TR' ) ) THEN
*
* xTR: Triangular matrix
*
IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
WRITE( NOUT, FMT = 9961 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), M, N5, IMAT
ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN
WRITE( NOUT, FMT = 9967 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), OPTS( 3: 3 ), M, IMAT
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATRS' ) ) THEN
WRITE( NOUT, FMT = 9952 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), OPTS( 3: 3 ), OPTS( 4: 4 ), M, IMAT
ELSE
WRITE( NOUT, FMT = 9953 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), OPTS( 3: 3 ), M, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'TP' ) ) THEN
*
* xTP: Triangular packed matrix
*
IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
WRITE( NOUT, FMT = 9962 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), M, IMAT
ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN
WRITE( NOUT, FMT = 9967 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), OPTS( 3: 3 ), M, IMAT
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATPS' ) ) THEN
WRITE( NOUT, FMT = 9952 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), OPTS( 3: 3 ), OPTS( 4: 4 ), M, IMAT
ELSE
WRITE( NOUT, FMT = 9953 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), OPTS( 3: 3 ), M, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'TB' ) ) THEN
*
* xTB: Triangular band matrix
*
IF( LSAMEN( 3, C3, 'CON' ) ) THEN
WRITE( NOUT, FMT = 9966 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), OPTS( 3: 3 ), M, KL, IMAT
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATBS' ) ) THEN
WRITE( NOUT, FMT = 9951 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), OPTS( 3: 3 ), OPTS( 4: 4 ), M, KL, IMAT
ELSE
WRITE( NOUT, FMT = 9954 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), OPTS( 3: 3 ), M, KL, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'QR' ) ) THEN
*
* xQR: QR factorization
*
IF( LSAMEN( 3, C3, 'QRS' ) ) THEN
WRITE( NOUT, FMT = 9974 )SUBNAM, INFO, M, N, KL, N5, IMAT
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN
WRITE( NOUT, FMT = 9978 )SUBNAM, INFO, M, N, IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'LQ' ) ) THEN
*
* xLQ: LQ factorization
*
IF( LSAMEN( 3, C3, 'LQS' ) ) THEN
WRITE( NOUT, FMT = 9974 )SUBNAM, INFO, M, N, KL, N5, IMAT
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN
WRITE( NOUT, FMT = 9978 )SUBNAM, INFO, M, N, IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'QL' ) ) THEN
*
* xQL: QL factorization
*
IF( LSAMEN( 3, C3, 'QLS' ) ) THEN
WRITE( NOUT, FMT = 9974 )SUBNAM, INFO, M, N, KL, N5, IMAT
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN
WRITE( NOUT, FMT = 9978 )SUBNAM, INFO, M, N, IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'RQ' ) ) THEN
*
* xRQ: RQ factorization
*
IF( LSAMEN( 3, C3, 'RQS' ) ) THEN
WRITE( NOUT, FMT = 9974 )SUBNAM, INFO, M, N, KL, N5, IMAT
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN
WRITE( NOUT, FMT = 9978 )SUBNAM, INFO, M, N, IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'LU' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9988 )SUBNAM, INFO, INFOE, M, N, N5,
$ IMAT
ELSE
WRITE( NOUT, FMT = 9975 )SUBNAM, INFO, M, N, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'CH' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9985 )SUBNAM, INFO, INFOE, M, N5, IMAT
ELSE
WRITE( NOUT, FMT = 9971 )SUBNAM, INFO, M, N5, IMAT
END IF
*
ELSE
*
* Print a generic message if the path is unknown.
*
WRITE( NOUT, FMT = 9950 )SUBNAM, INFO
END IF
*
* Description of error message (alphabetical, left to right)
*
* SUBNAM, INFO, FACT, N, NRHS, IMAT
*
9999 FORMAT( ' *** Error code from ', A6, '=', I5, ', FACT=''', A1,
$ ''', N=', I5, ', NRHS=', I4, ', type ', I2 )
*
* SUBNAM, INFO, FACT, TRANS, N, KL, KU, NRHS, IMAT
*
9998 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> FACT=''',
$ A1, ''', TRANS=''', A1, ''', N=', I5, ', KL=', I5, ', KU=',
$ I5, ', NRHS=', I4, ', type ', I1 )
*
* SUBNAM, INFO, FACT, TRANS, N, NRHS, IMAT
*
9997 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> FACT=''',
$ A1, ''', TRANS=''', A1, ''', N =', I5, ', NRHS =', I4,
$ ', type ', I2 )
*
* SUBNAM, INFO, FACT, UPLO, N, KD, NRHS, IMAT
*
9996 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> FACT=''',
$ A1, ''', UPLO=''', A1, ''', N=', I5, ', KD=', I5, ', NRHS=',
$ I4, ', type ', I2 )
*
* SUBNAM, INFO, FACT, UPLO, N, NRHS, IMAT
*
9995 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> FACT=''',
$ A1, ''', UPLO=''', A1, ''', N =', I5, ', NRHS =', I4,
$ ', type ', I2 )
*
* SUBNAM, INFO, INFOE, FACT, N, NRHS, IMAT
*
9994 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, / ' ==> FACT=''', A1, ''', N =', I5, ', NRHS =', I4,
$ ', type ', I2 )
*
* SUBNAM, INFO, INFOE, FACT, TRANS, N, KL, KU, NRHS, IMAT
*
9993 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, / ' ==> FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5,
$ ', KL=', I5, ', KU=', I5, ', NRHS=', I4, ', type ', I1 )
*
* SUBNAM, INFO, INFOE, FACT, TRANS, N, NRHS, IMAT
*
9992 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, / ' ==> FACT=''', A1, ''', TRANS=''', A1, ''', N =', I5,
$ ', NRHS =', I4, ', type ', I2 )
*
* SUBNAM, INFO, INFOE, FACT, UPLO, N, KD, NRHS, IMAT
*
9991 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, / ' ==> FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5,
$ ', KD=', I5, ', NRHS=', I4, ', type ', I2 )
*
* SUBNAM, INFO, INFOE, FACT, UPLO, N, NRHS, IMAT
*
9990 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, / ' ==> FACT=''', A1, ''', UPLO=''', A1, ''', N =', I5,
$ ', NRHS =', I4, ', type ', I2 )
*
* SUBNAM, INFO, INFOE, M, N, KL, KU, NB, IMAT
*
9989 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, / ' ==> M = ', I5, ', N =', I5, ', KL =', I5, ', KU =',
$ I5, ', NB =', I4, ', type ', I2 )
*
* SUBNAM, INFO, INFOE, M, N, NB, IMAT
*
9988 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, / ' ==> M =', I5, ', N =', I5, ', NB =', I4, ', type ',
$ I2 )
*
* SUBNAM, INFO, INFOE, N, IMAT
*
9987 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, ' for N=', I5, ', type ', I2 )
*
* SUBNAM, INFO, INFOE, N, KL, KU, NRHS, IMAT
*
9986 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, / ' ==> N =', I5, ', KL =', I5, ', KU =', I5,
$ ', NRHS =', I4, ', type ', I2 )
*
* SUBNAM, INFO, INFOE, N, NB, IMAT
*
9985 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, / ' ==> N =', I5, ', NB =', I4, ', type ', I2 )
*
* SUBNAM, INFO, INFOE, N, NRHS, IMAT
*
9984 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, / ' ==> N =', I5, ', NRHS =', I4, ', type ', I2 )
*
* SUBNAM, INFO, INFOE, UPLO, N, IMAT
*
9983 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, / ' ==> UPLO = ''', A1, ''', N =', I5, ', type ', I2 )
*
* SUBNAM, INFO, INFOE, UPLO, N, KD, NB, IMAT
*
9982 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, / ' ==> UPLO = ''', A1, ''', N =', I5, ', KD =', I5,
$ ', NB =', I4, ', type ', I2 )
*
* SUBNAM, INFO, INFOE, UPLO, N, KD, NRHS, IMAT
*
9981 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, / ' ==> UPLO=''', A1, ''', N =', I5, ', KD =', I5,
$ ', NRHS =', I4, ', type ', I2 )
*
* SUBNAM, INFO, INFOE, UPLO, N, NB, IMAT
*
9980 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, / ' ==> UPLO = ''', A1, ''', N =', I5, ', NB =', I4,
$ ', type ', I2 )
*
* SUBNAM, INFO, INFOE, UPLO, N, NRHS, IMAT
*
9979 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, / ' ==> UPLO = ''', A1, ''', N =', I5, ', NRHS =', I4,
$ ', type ', I2 )
*
* SUBNAM, INFO, M, N, IMAT
*
9978 FORMAT( ' *** Error code from ', A6, ' =', I5, ' for M =', I5,
$ ', N =', I5, ', type ', I2 )
*
* SUBNAM, INFO, M, N, KL, KU, IMAT
*
9977 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> M = ', I5,
$ ', N =', I5, ', KL =', I5, ', KU =', I5, ', type ', I2 )
*
* SUBNAM, INFO, M, N, KL, KU, NB, IMAT
*
9976 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> M = ', I5,
$ ', N =', I5, ', KL =', I5, ', KU =', I5, ', NB =', I4,
$ ', type ', I2 )
*
* SUBNAM, INFO, M, N, NB, IMAT
*
9975 FORMAT( ' *** Error code from ', A6, '=', I5, ' for M=', I5,
$ ', N=', I5, ', NB=', I4, ', type ', I2 )
*
* SUBNAM, INFO, M, N, NRHS, NB, IMAT
*
9974 FORMAT( ' *** Error code from ', A6, '=', I5, / ' ==> M =', I5,
$ ', N =', I5, ', NRHS =', I4, ', NB =', I4, ', type ', I2 )
*
* SUBNAM, INFO, N, IMAT
*
9973 FORMAT( ' *** Error code from ', A6, ' =', I5, ' for N =', I5,
$ ', type ', I2 )
*
* SUBNAM, INFO, N, KL, KU, NRHS, IMAT
*
9972 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> N =', I5,
$ ', KL =', I5, ', KU =', I5, ', NRHS =', I4, ', type ', I2 )
*
* SUBNAM, INFO, N, NB, IMAT
*
9971 FORMAT( ' *** Error code from ', A6, '=', I5, ' for N=', I5,
$ ', NB=', I4, ', type ', I2 )
*
* SUBNAM, INFO, N, NRHS, IMAT
*
9970 FORMAT( ' *** Error code from ', A6, ' =', I5, ' for N =', I5,
$ ', NRHS =', I4, ', type ', I2 )
*
* SUBNAM, INFO, NORM, N, IMAT
*
9969 FORMAT( ' *** Error code from ', A6, ' =', I5, ' for NORM = ''',
$ A1, ''', N =', I5, ', type ', I2 )
*
* SUBNAM, INFO, NORM, N, KL, KU, IMAT
*
9968 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> NORM =''',
$ A1, ''', N =', I5, ', KL =', I5, ', KU =', I5, ', type ',
$ I2 )
*
* SUBNAM, INFO, NORM, UPLO, DIAG, N, IMAT
*
9967 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> NORM=''',
$ A1, ''', UPLO =''', A1, ''', DIAG=''', A1, ''', N =', I5,
$ ', type ', I2 )
*
* SUBNAM, INFO, NORM, UPLO, DIAG, N, KD, IMAT
*
9966 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> NORM=''',
$ A1, ''', UPLO =''', A1, ''', DIAG=''', A1, ''', N=', I5,
$ ', KD=', I5, ', type ', I2 )
*
* SUBNAM, INFO, TRANS, M, N, NRHS, NB, IMAT
*
9965 FORMAT( ' *** Error code from ', A6, ' =', I5,
$ / ' ==> TRANS = ''', A1, ''', M =', I5, ', N =', I5,
$ ', NRHS =', I4, ', NB =', I4, ', type ', I2 )
*
* SUBNAM, INFO, TRANS, N, KL, KU, NRHS, IMAT
*
9964 FORMAT( ' *** Error code from ', A6, '=', I5, / ' ==> TRANS=''',
$ A1, ''', N =', I5, ', KL =', I5, ', KU =', I5, ', NRHS =',
$ I4, ', type ', I2 )
*
* SUBNAM, INFO, TRANS, N, NRHS, IMAT
*
9963 FORMAT( ' *** Error code from ', A6, ' =', I5,
$ / ' ==> TRANS = ''', A1, ''', N =', I5, ', NRHS =', I4,
$ ', type ', I2 )
*
* SUBNAM, INFO, UPLO, DIAG, N, IMAT
*
9962 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO=''',
$ A1, ''', DIAG =''', A1, ''', N =', I5, ', type ', I2 )
*
* SUBNAM, INFO, UPLO, DIAG, N, NB, IMAT
*
9961 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO=''',
$ A1, ''', DIAG =''', A1, ''', N =', I5, ', NB =', I4,
$ ', type ', I2 )
*
* SUBNAM, INFO, UPLO, N, IMAT
*
9960 FORMAT( ' *** Error code from ', A6, ' =', I5, ' for UPLO = ''',
$ A1, ''', N =', I5, ', type ', I2 )
*
* SUBNAM, INFO, UPLO, N, KD, IMAT
*
9959 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO = ''',
$ A1, ''', N =', I5, ', KD =', I5, ', type ', I2 )
*
* SUBNAM, INFO, UPLO, N, KD, NB, IMAT
*
9958 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO = ''',
$ A1, ''', N =', I5, ', KD =', I5, ', NB =', I4, ', type ',
$ I2 )
*
* SUBNAM, INFO, UPLO, N, KD, NRHS, IMAT
*
9957 FORMAT( ' *** Error code from ', A6, '=', I5, / ' ==> UPLO = ''',
$ A1, ''', N =', I5, ', KD =', I5, ', NRHS =', I4, ', type ',
$ I2 )
*
* SUBNAM, INFO, UPLO, N, NB, IMAT
*
9956 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO = ''',
$ A1, ''', N =', I5, ', NB =', I4, ', type ', I2 )
*
* SUBNAM, INFO, UPLO, N, NRHS, IMAT
*
9955 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO = ''',
$ A1, ''', N =', I5, ', NRHS =', I4, ', type ', I2 )
*
* SUBNAM, INFO, UPLO, TRANS, DIAG, N, KD, NRHS, IMAT
*
9954 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO=''',
$ A1, ''', TRANS=''', A1, ''', DIAG=''', A1, ''', N=', I5,
$ ', KD=', I5, ', NRHS=', I4, ', type ', I2 )
*
* SUBNAM, INFO, UPLO, TRANS, DIAG, N, NRHS, IMAT
*
9953 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO=''',
$ A1, ''', TRANS=''', A1, ''', DIAG=''', A1, ''', N =', I5,
$ ', NRHS =', I4, ', type ', I2 )
*
* SUBNAM, INFO, UPLO, TRANS, DIAG, NORMIN, N, IMAT
*
9952 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO=''',
$ A1, ''', TRANS=''', A1, ''', DIAG=''', A1, ''', NORMIN=''',
$ A1, ''', N =', I5, ', type ', I2 )
*
* SUBNAM, INFO, UPLO, TRANS, DIAG, NORMIN, N, KD, IMAT
*
9951 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO=''',
$ A1, ''', TRANS=''', A1, ''', DIAG=''', A1, ''', NORMIN=''',
$ A1, ''', N=', I5, ', KD=', I5, ', type ', I2 )
*
* Unknown type
*
9950 FORMAT( ' *** Error code from ', A6, ' =', I5 )
*
* What we do next
*
9949 FORMAT( ' ==> Doing only the condition estimate for this case' )
*
RETURN
*
* End of ALAERH
*
END
SUBROUTINE ALAESM( PATH, OK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL OK
CHARACTER*3 PATH
INTEGER NOUT
* ..
*
* Purpose
* =======
*
* ALAESM prints a summary of results from one of the -ERR- routines.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name.
*
* OK (input) LOGICAL
* The flag from CHKXER that indicates whether or not the tests
* of error exits passed.
*
* NOUT (input) INTEGER
* The unit number on which results are to be printed.
* NOUT >= 0.
*
* =====================================================================
*
* .. Executable Statements ..
*
IF( OK ) THEN
WRITE( NOUT, FMT = 9999 )PATH
ELSE
WRITE( NOUT, FMT = 9998 )PATH
END IF
*
9999 FORMAT( 1X, A3, ' routines passed the tests of the error exits'
$ )
9998 FORMAT( ' *** ', A3, ' routines failed the tests of the error ',
$ 'exits ***' )
RETURN
*
* End of ALAESM
*
END
SUBROUTINE ALAHD( IOUNIT, PATH )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER IOUNIT
* ..
*
* Purpose
* =======
*
* ALAHD prints header information for the different test paths.
*
* Arguments
* =========
*
* IOUNIT (input) INTEGER
* The unit number to which the header information should be
* printed.
*
* PATH (input) CHARACTER*3
* The name of the path for which the header information is to
* be printed. Current paths are
* _GE: General matrices
* _GB: General band
* _GT: General Tridiagonal
* _PO: Symmetric or Hermitian positive definite
* _PP: Symmetric or Hermitian positive definite packed
* _PB: Symmetric or Hermitian positive definite band
* _PT: Symmetric or Hermitian positive definite tridiagonal
* _SY: Symmetric indefinite
* _SP: Symmetric indefinite packed
* _HE: (complex) Hermitian indefinite
* _HP: (complex) Hermitian indefinite packed
* _TR: Triangular
* _TP: Triangular packed
* _TB: Triangular band
* _QR: QR (general matrices)
* _LQ: LQ (general matrices)
* _QL: QL (general matrices)
* _RQ: RQ (general matrices)
* _QP: QR with column pivoting
* _TZ: Trapezoidal
* _LS: Least Squares driver routines
* _LU: LU variants
* _CH: Cholesky variants
* _QS: QR variants
* The first character must be one of S, D, C, or Z (C or Z only
* if complex).
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL CORZ, SORD
CHARACTER C1, C3
CHARACTER*2 P2
CHARACTER*6 SUBNAM
CHARACTER*9 SYM
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Executable Statements ..
*
IF( IOUNIT.LE.0 )
$ RETURN
C1 = PATH( 1: 1 )
C3 = PATH( 3: 3 )
P2 = PATH( 2: 3 )
SORD = LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' )
CORZ = LSAME( C1, 'C' ) .OR. LSAME( C1, 'Z' )
IF( .NOT.( SORD .OR. CORZ ) )
$ RETURN
*
IF( LSAMEN( 2, P2, 'GE' ) ) THEN
*
* GE: General dense
*
WRITE( IOUNIT, FMT = 9999 )PATH
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9979 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9962 )1
WRITE( IOUNIT, FMT = 9961 )2
WRITE( IOUNIT, FMT = 9960 )3
WRITE( IOUNIT, FMT = 9959 )4
WRITE( IOUNIT, FMT = 9958 )5
WRITE( IOUNIT, FMT = 9957 )6
WRITE( IOUNIT, FMT = 9956 )7
WRITE( IOUNIT, FMT = 9955 )8
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'GB' ) ) THEN
*
* GB: General band
*
WRITE( IOUNIT, FMT = 9998 )PATH
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9978 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9962 )1
WRITE( IOUNIT, FMT = 9960 )2
WRITE( IOUNIT, FMT = 9959 )3
WRITE( IOUNIT, FMT = 9958 )4
WRITE( IOUNIT, FMT = 9957 )5
WRITE( IOUNIT, FMT = 9956 )6
WRITE( IOUNIT, FMT = 9955 )7
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'GT' ) ) THEN
*
* GT: General tridiagonal
*
WRITE( IOUNIT, FMT = 9997 )PATH
WRITE( IOUNIT, FMT = 9977 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9962 )1
WRITE( IOUNIT, FMT = 9960 )2
WRITE( IOUNIT, FMT = 9959 )3
WRITE( IOUNIT, FMT = 9958 )4
WRITE( IOUNIT, FMT = 9957 )5
WRITE( IOUNIT, FMT = 9956 )6
WRITE( IOUNIT, FMT = 9955 )7
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'PO' ) .OR. LSAMEN( 2, P2, 'PP' ) ) THEN
*
* PO: Positive definite full
* PP: Positive definite packed
*
IF( SORD ) THEN
SYM = 'Symmetric'
ELSE
SYM = 'Hermitian'
END IF
IF( LSAME( C3, 'O' ) ) THEN
WRITE( IOUNIT, FMT = 9996 )PATH, SYM
ELSE
WRITE( IOUNIT, FMT = 9995 )PATH, SYM
END IF
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9975 )PATH
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9954 )1
WRITE( IOUNIT, FMT = 9961 )2
WRITE( IOUNIT, FMT = 9960 )3
WRITE( IOUNIT, FMT = 9959 )4
WRITE( IOUNIT, FMT = 9958 )5
WRITE( IOUNIT, FMT = 9957 )6
WRITE( IOUNIT, FMT = 9956 )7
WRITE( IOUNIT, FMT = 9955 )8
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'PB' ) ) THEN
*
* PB: Positive definite band
*
IF( SORD ) THEN
WRITE( IOUNIT, FMT = 9994 )PATH, 'Symmetric'
ELSE
WRITE( IOUNIT, FMT = 9994 )PATH, 'Hermitian'
END IF
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9973 )PATH
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9954 )1
WRITE( IOUNIT, FMT = 9960 )2
WRITE( IOUNIT, FMT = 9959 )3
WRITE( IOUNIT, FMT = 9958 )4
WRITE( IOUNIT, FMT = 9957 )5
WRITE( IOUNIT, FMT = 9956 )6
WRITE( IOUNIT, FMT = 9955 )7
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'PT' ) ) THEN
*
* PT: Positive definite tridiagonal
*
IF( SORD ) THEN
WRITE( IOUNIT, FMT = 9993 )PATH, 'Symmetric'
ELSE
WRITE( IOUNIT, FMT = 9993 )PATH, 'Hermitian'
END IF
WRITE( IOUNIT, FMT = 9976 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9952 )1
WRITE( IOUNIT, FMT = 9960 )2
WRITE( IOUNIT, FMT = 9959 )3
WRITE( IOUNIT, FMT = 9958 )4
WRITE( IOUNIT, FMT = 9957 )5
WRITE( IOUNIT, FMT = 9956 )6
WRITE( IOUNIT, FMT = 9955 )7
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'SY' ) .OR. LSAMEN( 2, P2, 'SP' ) ) THEN
*
* SY: Symmetric indefinite full
* SP: Symmetric indefinite packed
*
IF( LSAME( C3, 'Y' ) ) THEN
WRITE( IOUNIT, FMT = 9992 )PATH, 'Symmetric'
ELSE
WRITE( IOUNIT, FMT = 9991 )PATH, 'Symmetric'
END IF
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
IF( SORD ) THEN
WRITE( IOUNIT, FMT = 9972 )
ELSE
WRITE( IOUNIT, FMT = 9971 )
END IF
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9953 )1
WRITE( IOUNIT, FMT = 9961 )2
WRITE( IOUNIT, FMT = 9960 )3
WRITE( IOUNIT, FMT = 9959 )4
WRITE( IOUNIT, FMT = 9958 )5
WRITE( IOUNIT, FMT = 9956 )6
WRITE( IOUNIT, FMT = 9957 )7
WRITE( IOUNIT, FMT = 9955 )8
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'HE' ) .OR. LSAMEN( 2, P2, 'HP' ) ) THEN
*
* HE: Hermitian indefinite full
* HP: Hermitian indefinite packed
*
IF( LSAME( C3, 'E' ) ) THEN
WRITE( IOUNIT, FMT = 9992 )PATH, 'Hermitian'
ELSE
WRITE( IOUNIT, FMT = 9991 )PATH, 'Hermitian'
END IF
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9972 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9953 )1
WRITE( IOUNIT, FMT = 9961 )2
WRITE( IOUNIT, FMT = 9960 )3
WRITE( IOUNIT, FMT = 9959 )4
WRITE( IOUNIT, FMT = 9958 )5
WRITE( IOUNIT, FMT = 9956 )6
WRITE( IOUNIT, FMT = 9957 )7
WRITE( IOUNIT, FMT = 9955 )8
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'TR' ) .OR. LSAMEN( 2, P2, 'TP' ) ) THEN
*
* TR: Triangular full
* TP: Triangular packed
*
IF( LSAME( C3, 'R' ) ) THEN
WRITE( IOUNIT, FMT = 9990 )PATH
SUBNAM = PATH( 1: 1 ) // 'LATRS'
ELSE
WRITE( IOUNIT, FMT = 9989 )PATH
SUBNAM = PATH( 1: 1 ) // 'LATPS'
END IF
WRITE( IOUNIT, FMT = 9966 )PATH
WRITE( IOUNIT, FMT = 9965 )SUBNAM
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9961 )1
WRITE( IOUNIT, FMT = 9960 )2
WRITE( IOUNIT, FMT = 9959 )3
WRITE( IOUNIT, FMT = 9958 )4
WRITE( IOUNIT, FMT = 9957 )5
WRITE( IOUNIT, FMT = 9956 )6
WRITE( IOUNIT, FMT = 9955 )7
WRITE( IOUNIT, FMT = 9951 )SUBNAM, 8
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'TB' ) ) THEN
*
* TB: Triangular band
*
WRITE( IOUNIT, FMT = 9988 )PATH
SUBNAM = PATH( 1: 1 ) // 'LATBS'
WRITE( IOUNIT, FMT = 9964 )PATH
WRITE( IOUNIT, FMT = 9963 )SUBNAM
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9960 )1
WRITE( IOUNIT, FMT = 9959 )2
WRITE( IOUNIT, FMT = 9958 )3
WRITE( IOUNIT, FMT = 9957 )4
WRITE( IOUNIT, FMT = 9956 )5
WRITE( IOUNIT, FMT = 9955 )6
WRITE( IOUNIT, FMT = 9951 )SUBNAM, 7
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'QR' ) ) THEN
*
* QR decomposition of rectangular matrices
*
WRITE( IOUNIT, FMT = 9987 )PATH, 'QR'
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9970 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9950 )1
WRITE( IOUNIT, FMT = 9946 )2
WRITE( IOUNIT, FMT = 9944 )3, 'M'
WRITE( IOUNIT, FMT = 9943 )4, 'M'
WRITE( IOUNIT, FMT = 9942 )5, 'M'
WRITE( IOUNIT, FMT = 9941 )6, 'M'
WRITE( IOUNIT, FMT = 9960 )7
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'LQ' ) ) THEN
*
* LQ decomposition of rectangular matrices
*
WRITE( IOUNIT, FMT = 9987 )PATH, 'LQ'
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9970 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9949 )1
WRITE( IOUNIT, FMT = 9945 )2
WRITE( IOUNIT, FMT = 9944 )3, 'N'
WRITE( IOUNIT, FMT = 9943 )4, 'N'
WRITE( IOUNIT, FMT = 9942 )5, 'N'
WRITE( IOUNIT, FMT = 9941 )6, 'N'
WRITE( IOUNIT, FMT = 9960 )7
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'QL' ) ) THEN
*
* QL decomposition of rectangular matrices
*
WRITE( IOUNIT, FMT = 9987 )PATH, 'QL'
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9970 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9948 )1
WRITE( IOUNIT, FMT = 9946 )2
WRITE( IOUNIT, FMT = 9944 )3, 'M'
WRITE( IOUNIT, FMT = 9943 )4, 'M'
WRITE( IOUNIT, FMT = 9942 )5, 'M'
WRITE( IOUNIT, FMT = 9941 )6, 'M'
WRITE( IOUNIT, FMT = 9960 )7
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'RQ' ) ) THEN
*
* RQ decomposition of rectangular matrices
*
WRITE( IOUNIT, FMT = 9987 )PATH, 'RQ'
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9970 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9947 )1
WRITE( IOUNIT, FMT = 9945 )2
WRITE( IOUNIT, FMT = 9944 )3, 'N'
WRITE( IOUNIT, FMT = 9943 )4, 'N'
WRITE( IOUNIT, FMT = 9942 )5, 'N'
WRITE( IOUNIT, FMT = 9941 )6, 'N'
WRITE( IOUNIT, FMT = 9960 )7
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'QP' ) ) THEN
*
* QR decomposition with column pivoting
*
WRITE( IOUNIT, FMT = 9986 )PATH
WRITE( IOUNIT, FMT = 9969 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9940 )1
WRITE( IOUNIT, FMT = 9939 )2
WRITE( IOUNIT, FMT = 9938 )3
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'TZ' ) ) THEN
*
* TZ: Trapezoidal
*
WRITE( IOUNIT, FMT = 9985 )PATH
WRITE( IOUNIT, FMT = 9968 )
WRITE( IOUNIT, FMT = 9929 )C1, C1
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9940 )1
WRITE( IOUNIT, FMT = 9937 )2
WRITE( IOUNIT, FMT = 9938 )3
WRITE( IOUNIT, FMT = 9940 )4
WRITE( IOUNIT, FMT = 9937 )5
WRITE( IOUNIT, FMT = 9938 )6
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'LS' ) ) THEN
*
* LS: Least Squares driver routines for
* LS, LSD, LSS, LSX and LSY.
*
WRITE( IOUNIT, FMT = 9984 )PATH
WRITE( IOUNIT, FMT = 9967 )
WRITE( IOUNIT, FMT = 9921 )C1, C1, C1, C1, C1
WRITE( IOUNIT, FMT = 9935 )1
WRITE( IOUNIT, FMT = 9931 )2
WRITE( IOUNIT, FMT = 9933 )3
WRITE( IOUNIT, FMT = 9935 )4
WRITE( IOUNIT, FMT = 9934 )5
WRITE( IOUNIT, FMT = 9932 )6
WRITE( IOUNIT, FMT = 9920 )
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'LU' ) ) THEN
*
* LU factorization variants
*
WRITE( IOUNIT, FMT = 9983 )PATH
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9979 )
WRITE( IOUNIT, FMT = '( '' Test ratio:'' )' )
WRITE( IOUNIT, FMT = 9962 )1
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'CH' ) ) THEN
*
* Cholesky factorization variants
*
WRITE( IOUNIT, FMT = 9982 )PATH
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9974 )
WRITE( IOUNIT, FMT = '( '' Test ratio:'' )' )
WRITE( IOUNIT, FMT = 9954 )1
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'QS' ) ) THEN
*
* QR factorization variants
*
WRITE( IOUNIT, FMT = 9981 )PATH
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9970 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
*
ELSE
*
* Print error message if no header is available.
*
WRITE( IOUNIT, FMT = 9980 )PATH
END IF
*
* First line of header
*
9999 FORMAT( / 1X, A3, ': General dense matrices' )
9998 FORMAT( / 1X, A3, ': General band matrices' )
9997 FORMAT( / 1X, A3, ': General tridiagonal' )
9996 FORMAT( / 1X, A3, ': ', A9, ' positive definite matrices' )
9995 FORMAT( / 1X, A3, ': ', A9, ' positive definite packed matrices'
$ )
9994 FORMAT( / 1X, A3, ': ', A9, ' positive definite band matrices' )
9993 FORMAT( / 1X, A3, ': ', A9, ' positive definite tridiagonal' )
9992 FORMAT( / 1X, A3, ': ', A9, ' indefinite matrices' )
9991 FORMAT( / 1X, A3, ': ', A9, ' indefinite packed matrices' )
9990 FORMAT( / 1X, A3, ': Triangular matrices' )
9989 FORMAT( / 1X, A3, ': Triangular packed matrices' )
9988 FORMAT( / 1X, A3, ': Triangular band matrices' )
9987 FORMAT( / 1X, A3, ': ', A2, ' factorization of general matrices'
$ )
9986 FORMAT( / 1X, A3, ': QR factorization with column pivoting' )
9985 FORMAT( / 1X, A3, ': RQ factorization of trapezoidal matrix' )
9984 FORMAT( / 1X, A3, ': Least squares driver routines' )
9983 FORMAT( / 1X, A3, ': LU factorization variants' )
9982 FORMAT( / 1X, A3, ': Cholesky factorization variants' )
9981 FORMAT( / 1X, A3, ': QR factorization variants' )
9980 FORMAT( / 1X, A3, ': No header available' )
*
* GE matrix types
*
9979 FORMAT( 4X, '1. Diagonal', 24X, '7. Last n/2 columns zero', / 4X,
$ '2. Upper triangular', 16X,
$ '8. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
$ '3. Lower triangular', 16X, '9. Random, CNDNUM = 0.1/EPS',
$ / 4X, '4. Random, CNDNUM = 2', 13X,
$ '10. Scaled near underflow', / 4X, '5. First column zero',
$ 14X, '11. Scaled near overflow', / 4X,
$ '6. Last column zero' )
*
* GB matrix types
*
9978 FORMAT( 4X, '1. Random, CNDNUM = 2', 14X,
$ '5. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
$ '2. First column zero', 15X, '6. Random, CNDNUM = .01/EPS',
$ / 4X, '3. Last column zero', 16X,
$ '7. Scaled near underflow', / 4X,
$ '4. Last n/2 columns zero', 11X, '8. Scaled near overflow' )
*
* GT matrix types
*
9977 FORMAT( ' Matrix types (1-6 have specified condition numbers):',
$ / 4X, '1. Diagonal', 24X, '7. Random, unspecified CNDNUM',
$ / 4X, '2. Random, CNDNUM = 2', 14X, '8. First column zero',
$ / 4X, '3. Random, CNDNUM = sqrt(0.1/EPS)', 2X,
$ '9. Last column zero', / 4X, '4. Random, CNDNUM = 0.1/EPS',
$ 7X, '10. Last n/2 columns zero', / 4X,
$ '5. Scaled near underflow', 10X,
$ '11. Scaled near underflow', / 4X,
$ '6. Scaled near overflow', 11X, '12. Scaled near overflow' )
*
* PT matrix types
*
9976 FORMAT( ' Matrix types (1-6 have specified condition numbers):',
$ / 4X, '1. Diagonal', 24X, '7. Random, unspecified CNDNUM',
$ / 4X, '2. Random, CNDNUM = 2', 14X,
$ '8. First row and column zero', / 4X,
$ '3. Random, CNDNUM = sqrt(0.1/EPS)', 2X,
$ '9. Last row and column zero', / 4X,
$ '4. Random, CNDNUM = 0.1/EPS', 7X,
$ '10. Middle row and column zero', / 4X,
$ '5. Scaled near underflow', 10X,
$ '11. Scaled near underflow', / 4X,
$ '6. Scaled near overflow', 11X, '12. Scaled near overflow' )
*
* PO, PP matrix types
*
9975 FORMAT( 4X, '1. Diagonal', 24X,
$ '6. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
$ '2. Random, CNDNUM = 2', 14X, '7. Random, CNDNUM = 0.1/EPS',
$ / 3X, '*3. First row and column zero', 7X,
$ '8. Scaled near underflow', / 3X,
$ '*4. Last row and column zero', 8X,
$ '9. Scaled near overflow', / 3X,
$ '*5. Middle row and column zero', / 3X,
$ '(* - tests error exits from ', A3,
$ 'TRF, no test ratios are computed)' )
*
* CH matrix types
*
9974 FORMAT( 4X, '1. Diagonal', 24X,
$ '6. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
$ '2. Random, CNDNUM = 2', 14X, '7. Random, CNDNUM = 0.1/EPS',
$ / 3X, '*3. First row and column zero', 7X,
$ '8. Scaled near underflow', / 3X,
$ '*4. Last row and column zero', 8X,
$ '9. Scaled near overflow', / 3X,
$ '*5. Middle row and column zero', / 3X,
$ '(* - tests error exits, no test ratios are computed)' )
*
* PB matrix types
*
9973 FORMAT( 4X, '1. Random, CNDNUM = 2', 14X,
$ '5. Random, CNDNUM = sqrt(0.1/EPS)', / 3X,
$ '*2. First row and column zero', 7X,
$ '6. Random, CNDNUM = 0.1/EPS', / 3X,
$ '*3. Last row and column zero', 8X,
$ '7. Scaled near underflow', / 3X,
$ '*4. Middle row and column zero', 6X,
$ '8. Scaled near overflow', / 3X,
$ '(* - tests error exits from ', A3,
$ 'TRF, no test ratios are computed)' )
*
* SSY, SSP, CHE, CHP matrix types
*
9972 FORMAT( 4X, '1. Diagonal', 24X,
$ '6. Last n/2 rows and columns zero', / 4X,
$ '2. Random, CNDNUM = 2', 14X,
$ '7. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
$ '3. First row and column zero', 7X,
$ '8. Random, CNDNUM = 0.1/EPS', / 4X,
$ '4. Last row and column zero', 8X,
$ '9. Scaled near underflow', / 4X,
$ '5. Middle row and column zero', 5X,
$ '10. Scaled near overflow' )
*
* CSY, CSP matrix types
*
9971 FORMAT( 4X, '1. Diagonal', 24X,
$ '7. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
$ '2. Random, CNDNUM = 2', 14X, '8. Random, CNDNUM = 0.1/EPS',
$ / 4X, '3. First row and column zero', 7X,
$ '9. Scaled near underflow', / 4X,
$ '4. Last row and column zero', 7X,
$ '10. Scaled near overflow', / 4X,
$ '5. Middle row and column zero', 5X,
$ '11. Block diagonal matrix', / 4X,
$ '6. Last n/2 rows and columns zero' )
*
* QR matrix types
*
9970 FORMAT( 4X, '1. Diagonal', 24X,
$ '5. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
$ '2. Upper triangular', 16X, '6. Random, CNDNUM = 0.1/EPS',
$ / 4X, '3. Lower triangular', 16X,
$ '7. Scaled near underflow', / 4X, '4. Random, CNDNUM = 2',
$ 14X, '8. Scaled near overflow' )
*
* QP matrix types
*
9969 FORMAT( ' Matrix types (2-6 have condition 1/EPS):', / 4X,
$ '1. Zero matrix', 21X, '4. First n/2 columns fixed', / 4X,
$ '2. One small eigenvalue', 12X, '5. Last n/2 columns fixed',
$ / 4X, '3. Geometric distribution', 10X,
$ '6. Every second column fixed' )
*
* TZ matrix types
*
9968 FORMAT( ' Matrix types (2-3 have condition 1/EPS):', / 4X,
$ '1. Zero matrix', / 4X, '2. One small eigenvalue', / 4X,
$ '3. Geometric distribution' )
*
* LS matrix types
*
9967 FORMAT( ' Matrix types (1-3: full rank, 4-6: rank deficient):',
$ / 4X, '1 and 4. Normal scaling', / 4X,
$ '2 and 5. Scaled near overflow', / 4X,
$ '3 and 6. Scaled near underflow' )
*
* TR, TP matrix types
*
9966 FORMAT( ' Matrix types for ', A3, ' routines:', / 4X,
$ '1. Diagonal', 24X, '6. Scaled near overflow', / 4X,
$ '2. Random, CNDNUM = 2', 14X, '7. Identity', / 4X,
$ '3. Random, CNDNUM = sqrt(0.1/EPS) ',
$ '8. Unit triangular, CNDNUM = 2', / 4X,
$ '4. Random, CNDNUM = 0.1/EPS', 8X,
$ '9. Unit, CNDNUM = sqrt(0.1/EPS)', / 4X,
$ '5. Scaled near underflow', 10X,
$ '10. Unit, CNDNUM = 0.1/EPS' )
9965 FORMAT( ' Special types for testing ', A6, ':', / 3X,
$ '11. Matrix elements are O(1), large right hand side', / 3X,
$ '12. First diagonal causes overflow,',
$ ' offdiagonal column norms < 1', / 3X,
$ '13. First diagonal causes overflow,',
$ ' offdiagonal column norms > 1', / 3X,
$ '14. Growth factor underflows, solution does not overflow',
$ / 3X, '15. Small diagonal causes gradual overflow', / 3X,
$ '16. One zero diagonal element', / 3X,
$ '17. Large offdiagonals cause overflow when adding a column'
$ , / 3X, '18. Unit triangular with large right hand side' )
*
* TB matrix types
*
9964 FORMAT( ' Matrix types for ', A3, ' routines:', / 4X,
$ '1. Random, CNDNUM = 2', 14X, '6. Identity', / 4X,
$ '2. Random, CNDNUM = sqrt(0.1/EPS) ',
$ '7. Unit triangular, CNDNUM = 2', / 4X,
$ '3. Random, CNDNUM = 0.1/EPS', 8X,
$ '8. Unit, CNDNUM = sqrt(0.1/EPS)', / 4X,
$ '4. Scaled near underflow', 11X,
$ '9. Unit, CNDNUM = 0.1/EPS', / 4X,
$ '5. Scaled near overflow' )
9963 FORMAT( ' Special types for testing ', A6, ':', / 3X,
$ '10. Matrix elements are O(1), large right hand side', / 3X,
$ '11. First diagonal causes overflow,',
$ ' offdiagonal column norms < 1', / 3X,
$ '12. First diagonal causes overflow,',
$ ' offdiagonal column norms > 1', / 3X,
$ '13. Growth factor underflows, solution does not overflow',
$ / 3X, '14. Small diagonal causes gradual overflow', / 3X,
$ '15. One zero diagonal element', / 3X,
$ '16. Large offdiagonals cause overflow when adding a column'
$ , / 3X, '17. Unit triangular with large right hand side' )
*
* Test ratios
*
9962 FORMAT( 3X, I2, ': norm( L * U - A ) / ( N * norm(A) * EPS )' )
9961 FORMAT( 3X, I2, ': norm( I - A*AINV ) / ',
$ '( N * norm(A) * norm(AINV) * EPS )' )
9960 FORMAT( 3X, I2, ': norm( B - A * X ) / ',
$ '( norm(A) * norm(X) * EPS )' )
9959 FORMAT( 3X, I2, ': norm( X - XACT ) / ',
$ '( norm(XACT) * CNDNUM * EPS )' )
9958 FORMAT( 3X, I2, ': norm( X - XACT ) / ',
$ '( norm(XACT) * CNDNUM * EPS ), refined' )
9957 FORMAT( 3X, I2, ': norm( X - XACT ) / ',
$ '( norm(XACT) * (error bound) )' )
9956 FORMAT( 3X, I2, ': (backward error) / EPS' )
9955 FORMAT( 3X, I2, ': RCOND * CNDNUM - 1.0' )
9954 FORMAT( 3X, I2, ': norm( U'' * U - A ) / ( N * norm(A) * EPS )',
$ ', or', / 7X, 'norm( L * L'' - A ) / ( N * norm(A) * EPS )'
$ )
9953 FORMAT( 3X, I2, ': norm( U*D*U'' - A ) / ( N * norm(A) * EPS )',
$ ', or', / 7X, 'norm( L*D*L'' - A ) / ( N * norm(A) * EPS )'
$ )
9952 FORMAT( 3X, I2, ': norm( U''*D*U - A ) / ( N * norm(A) * EPS )',
$ ', or', / 7X, 'norm( L*D*L'' - A ) / ( N * norm(A) * EPS )'
$ )
9951 FORMAT( ' Test ratio for ', A6, ':', / 3X, I2,
$ ': norm( s*b - A*x ) / ( norm(A) * norm(x) * EPS )' )
9950 FORMAT( 3X, I2, ': norm( R - Q'' * A ) / ( M * norm(A) * EPS )' )
9949 FORMAT( 3X, I2, ': norm( L - A * Q'' ) / ( N * norm(A) * EPS )' )
9948 FORMAT( 3X, I2, ': norm( L - Q'' * A ) / ( M * norm(A) * EPS )' )
9947 FORMAT( 3X, I2, ': norm( R - A * Q'' ) / ( N * norm(A) * EPS )' )
9946 FORMAT( 3X, I2, ': norm( I - Q''*Q ) / ( M * EPS )' )
9945 FORMAT( 3X, I2, ': norm( I - Q*Q'' ) / ( N * EPS )' )
9944 FORMAT( 3X, I2, ': norm( Q*C - Q*C ) / ', '( ', A1,
$ ' * norm(C) * EPS )' )
9943 FORMAT( 3X, I2, ': norm( C*Q - C*Q ) / ', '( ', A1,
$ ' * norm(C) * EPS )' )
9942 FORMAT( 3X, I2, ': norm( Q''*C - Q''*C )/ ', '( ', A1,
$ ' * norm(C) * EPS )' )
9941 FORMAT( 3X, I2, ': norm( C*Q'' - C*Q'' )/ ', '( ', A1,
$ ' * norm(C) * EPS )' )
9940 FORMAT( 3X, I2, ': norm(svd(A) - svd(R)) / ',
$ '( M * norm(svd(R)) * EPS )' )
9939 FORMAT( 3X, I2, ': norm( A*P - Q*R ) / ( M * norm(A) * EPS )'
$ )
9938 FORMAT( 3X, I2, ': norm( I - Q''*Q ) / ( M * EPS )' )
9937 FORMAT( 3X, I2, ': norm( A - R*Q ) / ( M * norm(A) * EPS )'
$ )
9936 FORMAT( ' Test ratios (1-2: ', A1, 'GELS, 3-6: ', A1,
$ 'GELSS, 7-10: ', A1, 'GELSX):' )
9935 FORMAT( 3X, I2, ': norm( B - A * X ) / ',
$ '( max(M,N) * norm(A) * norm(X) * EPS )' )
9934 FORMAT( 3X, I2, ': norm( (A*X-B)'' *A ) / ',
$ '( max(M,N,NRHS) * norm(A) * norm(B) * EPS )' )
9933 FORMAT( 3X, I2, ': norm(svd(A)-svd(R)) / ',
$ '( min(M,N) * norm(svd(R)) * EPS )' )
9932 FORMAT( 3X, I2, ': Check if X is in the row space of A or A''' )
9931 FORMAT( 3X, I2, ': norm( (A*X-B)'' *A ) / ',
$ '( max(M,N,NRHS) * norm(A) * norm(B) * EPS )', / 7X,
$ 'if TRANS=''N'' and M.GE.N or TRANS=''T'' and M.LT.N, ',
$ 'otherwise', / 7X,
$ 'check if X is in the row space of A or A'' ',
$ '(overdetermined case)' )
9930 FORMAT( 3X, ' 7-10: same as 3-6' )
9929 FORMAT( ' Test ratios (1-3: ', A1, 'TZRQF, 4-6: ', A1,
$ 'TZRZF):' )
9920 FORMAT( 3X, ' 7-10: same as 3-6', 3X, ' 11-14: same as 3-6',
$ 3X, ' 15-18: same as 3-6' )
9921 FORMAT( ' Test ratios:', / ' (1-2: ', A1, 'GELS, 3-6: ', A1,
$ 'GELSX, 7-10: ', A1, 'GELSY, 11-14: ', A1, 'GELSS, 15-18: ',
$ A1, 'GELSD)' )
*
RETURN
*
* End of ALAHD
*
END
SUBROUTINE ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NIN, NMATS, NOUT, NTYPES
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
* ..
*
* Purpose
* =======
*
* ALAREQ handles input for the LAPACK test program. It is called
* to evaluate the input line which requested NMATS matrix types for
* PATH. The flow of control is as follows:
*
* If NMATS = NTYPES then
* DOTYPE(1:NTYPES) = .TRUE.
* else
* Read the next input line for NMATS matrix types
* Set DOTYPE(I) = .TRUE. for each valid type I
* endif
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* An LAPACK path name for testing.
*
* NMATS (input) INTEGER
* The number of matrix types to be used in testing this path.
*
* DOTYPE (output) LOGICAL array, dimension (NTYPES)
* The vector of flags indicating if each type will be tested.
*
* NTYPES (input) INTEGER
* The maximum number of matrix types for this path.
*
* NIN (input) INTEGER
* The unit number for input. NIN >= 1.
*
* NOUT (input) INTEGER
* The unit number for output. NOUT >= 1.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL FIRSTT
CHARACTER C1
CHARACTER*10 INTSTR
CHARACTER*80 LINE
INTEGER I, I1, IC, J, K, LENP, NT
* ..
* .. Local Arrays ..
INTEGER NREQ( 100 )
* ..
* .. Intrinsic Functions ..
INTRINSIC LEN
* ..
* .. Data statements ..
DATA INTSTR / '0123456789' /
* ..
* .. Executable Statements ..
*
IF( NMATS.GE.NTYPES ) THEN
*
* Test everything if NMATS >= NTYPES.
*
DO 10 I = 1, NTYPES
DOTYPE( I ) = .TRUE.
10 CONTINUE
ELSE
DO 20 I = 1, NTYPES
DOTYPE( I ) = .FALSE.
20 CONTINUE
FIRSTT = .TRUE.
*
* Read a line of matrix types if 0 < NMATS < NTYPES.
*
IF( NMATS.GT.0 ) THEN
READ( NIN, FMT = '(A80)', END = 90 )LINE
LENP = LEN( LINE )
I = 0
DO 60 J = 1, NMATS
NREQ( J ) = 0
I1 = 0
30 CONTINUE
I = I + 1
IF( I.GT.LENP ) THEN
IF( J.EQ.NMATS .AND. I1.GT.0 ) THEN
GO TO 60
ELSE
WRITE( NOUT, FMT = 9995 )LINE
WRITE( NOUT, FMT = 9994 )NMATS
GO TO 80
END IF
END IF
IF( LINE( I: I ).NE.' ' .AND. LINE( I: I ).NE.',' ) THEN
I1 = I
C1 = LINE( I1: I1 )
*
* Check that a valid integer was read
*
DO 40 K = 1, 10
IF( C1.EQ.INTSTR( K: K ) ) THEN
IC = K - 1
GO TO 50
END IF
40 CONTINUE
WRITE( NOUT, FMT = 9996 )I, LINE
WRITE( NOUT, FMT = 9994 )NMATS
GO TO 80
50 CONTINUE
NREQ( J ) = 10*NREQ( J ) + IC
GO TO 30
ELSE IF( I1.GT.0 ) THEN
GO TO 60
ELSE
GO TO 30
END IF
60 CONTINUE
END IF
DO 70 I = 1, NMATS
NT = NREQ( I )
IF( NT.GT.0 .AND. NT.LE.NTYPES ) THEN
IF( DOTYPE( NT ) ) THEN
IF( FIRSTT )
$ WRITE( NOUT, FMT = * )
FIRSTT = .FALSE.
WRITE( NOUT, FMT = 9997 )NT, PATH
END IF
DOTYPE( NT ) = .TRUE.
ELSE
WRITE( NOUT, FMT = 9999 )PATH, NT, NTYPES
9999 FORMAT( ' *** Invalid type request for ', A3, ', type ',
$ I4, ': must satisfy 1 <= type <= ', I2 )
END IF
70 CONTINUE
80 CONTINUE
END IF
RETURN
*
90 CONTINUE
WRITE( NOUT, FMT = 9998 )PATH
9998 FORMAT( /' *** End of file reached when trying to read matrix ',
$ 'types for ', A3, /' *** Check that you are requesting the',
$ ' right number of types for each path', / )
9997 FORMAT( ' *** Warning: duplicate request of matrix type ', I2,
$ ' for ', A3 )
9996 FORMAT( //' *** Invalid integer value in column ', I2,
$ ' of input', ' line:', /A79 )
9995 FORMAT( //' *** Not enough matrix types on input line', /A79 )
9994 FORMAT( ' ==> Specify ', I4, ' matrix types on this line or ',
$ 'adjust NTYPES on previous line' )
WRITE( NOUT, FMT = * )
STOP
*
* End of ALAREQ
*
END
SUBROUTINE ALASUM( TYPE, NOUT, NFAIL, NRUN, NERRS )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 TYPE
INTEGER NFAIL, NOUT, NRUN, NERRS
* ..
*
* Purpose
* =======
*
* ALASUM prints a summary of results from one of the -CHK- routines.
*
* Arguments
* =========
*
* TYPE (input) CHARACTER*3
* The LAPACK path name.
*
* NOUT (input) INTEGER
* The unit number on which results are to be printed.
* NOUT >= 0.
*
* NFAIL (input) INTEGER
* The number of tests which did not pass the threshold ratio.
*
* NRUN (input) INTEGER
* The total number of tests.
*
* NERRS (input) INTEGER
* The number of error messages recorded.
*
* =====================================================================
*
* .. Executable Statements ..
*
IF( NFAIL.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )TYPE, NFAIL, NRUN
ELSE
WRITE( NOUT, FMT = 9998 )TYPE, NRUN
END IF
IF( NERRS.GT.0 ) THEN
WRITE( NOUT, FMT = 9997 )NERRS
END IF
*
9999 FORMAT( 1X, A3, ': ', I6, ' out of ', I6,
$ ' tests failed to pass the threshold' )
9998 FORMAT( /1X, 'All tests for ', A3,
$ ' routines passed the threshold (', I6, ' tests run)' )
9997 FORMAT( 6X, I6, ' error messages recorded' )
RETURN
*
* End of ALASUM
*
END
SUBROUTINE ALASVM( TYPE, NOUT, NFAIL, NRUN, NERRS )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 TYPE
INTEGER NFAIL, NOUT, NRUN, NERRS
* ..
*
* Purpose
* =======
*
* ALASVM prints a summary of results from one of the -DRV- routines.
*
* Arguments
* =========
*
* TYPE (input) CHARACTER*3
* The LAPACK path name.
*
* NOUT (input) INTEGER
* The unit number on which results are to be printed.
* NOUT >= 0.
*
* NFAIL (input) INTEGER
* The number of tests which did not pass the threshold ratio.
*
* NRUN (input) INTEGER
* The total number of tests.
*
* NERRS (input) INTEGER
* The number of error messages recorded.
*
* =====================================================================
*
* .. Executable Statements ..
*
IF( NFAIL.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )TYPE, NFAIL, NRUN
ELSE
WRITE( NOUT, FMT = 9998 )TYPE, NRUN
END IF
IF( NERRS.GT.0 ) THEN
WRITE( NOUT, FMT = 9997 )NERRS
END IF
*
9999 FORMAT( 1X, A3, ' drivers: ', I6, ' out of ', I6,
$ ' tests failed to pass the threshold' )
9998 FORMAT( /1X, 'All tests for ', A3, ' drivers passed the ',
$ 'threshold (', I6, ' tests run)' )
9997 FORMAT( 14X, I6, ' error messages recorded' )
RETURN
*
* End of ALASVM
*
END
SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
*
* Tests whether XERBLA has detected an error when it should.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* =====================================================================
*
* .. Scalar Arguments ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Executable Statements ..
IF( .NOT.LERR ) THEN
WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT
OK = .FALSE.
END IF
LERR = .FALSE.
RETURN
*
9999 FORMAT( ' *** Illegal value of parameter number ', I2,
$ ' not detected by ', A6, ' ***' )
*
* End of CHKXER.
*
END
SUBROUTINE ICOPY( N, SX, INCX, SY, INCY )
*
* -- LAPACK auxiliary test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INCX, INCY, N
* ..
* .. Array Arguments ..
INTEGER SX( * ), SY( * )
* ..
*
* Purpose
* =======
*
* ICOPY copies an integer vector x to an integer vector y.
* Uses unrolled loops for increments equal to 1.
*
* Arguments
* =========
*
* N (input) INTEGER
* The length of the vectors SX and SY.
*
* SX (input) INTEGER array, dimension (1+(N-1)*abs(INCX))
* The vector X.
*
* INCX (input) INTEGER
* The spacing between consecutive elements of SX.
*
* SY (output) INTEGER array, dimension (1+(N-1)*abs(INCY))
* The vector Y.
*
* INCY (input) INTEGER
* The spacing between consecutive elements of SY.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, IX, IY, M, MP1
* ..
* .. Intrinsic Functions ..
INTRINSIC MOD
* ..
* .. Executable Statements ..
*
IF( N.LE.0 )
$ RETURN
IF( INCX.EQ.1 .AND. INCY.EQ.1 )
$ GO TO 20
*
* 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 10 I = 1, N
SY( IY ) = SX( IX )
IX = IX + INCX
IY = IY + INCY
10 CONTINUE
RETURN
*
* Code for both increments equal to 1
*
* Clean-up loop
*
20 CONTINUE
M = MOD( N, 7 )
IF( M.EQ.0 )
$ GO TO 40
DO 30 I = 1, M
SY( I ) = SX( I )
30 CONTINUE
IF( N.LT.7 )
$ RETURN
40 CONTINUE
MP1 = M + 1
DO 50 I = MP1, N, 7
SY( I ) = SX( I )
SY( I+1 ) = SX( I+1 )
SY( I+2 ) = SX( I+2 )
SY( I+3 ) = SX( I+3 )
SY( I+4 ) = SX( I+4 )
SY( I+5 ) = SX( I+5 )
SY( I+6 ) = SX( I+6 )
50 CONTINUE
RETURN
*
* End of ICOPY
*
END
INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3,
$ N4 )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*( * ) NAME, OPTS
INTEGER ISPEC, N1, N2, N3, N4
* ..
*
* Purpose
* =======
*
* ILAENV returns problem-dependent parameters for the local
* environment. See ISPEC for a description of the parameters.
*
* In this version, the problem-dependent parameters are contained in
* the integer array IPARMS in the common block CLAENV and the value
* with index ISPEC is copied to ILAENV. This version of ILAENV is
* to be used in conjunction with XLAENV in TESTING and TIMING.
*
* 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
* = 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 and QZ methods
* for nonsymmetric eigenvalue problems.
* = 9: maximum size of the subproblems at the bottom of the
* computation tree in the divide-and-conquer algorithm
* =10: ieee NaN arithmetic can be trusted not to trap
* =11: infinity arithmetic can be trusted not to trap
*
* Other specifications (up to 100) can be added later.
*
* NAME (input) CHARACTER*(*)
* The name of the calling subroutine.
*
* 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.
*
* (ILAENV) (output) INTEGER
* >= 0: the value of the parameter specified by ISPEC
* < 0: if ILAENV = -k, the k-th argument had an illegal value.
*
* 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 )
*
* =====================================================================
*
* .. Intrinsic Functions ..
INTRINSIC INT, MIN, REAL
* ..
* .. External Functions ..
INTEGER IEEECK
EXTERNAL IEEECK
* ..
* .. Arrays in Common ..
INTEGER IPARMS( 100 )
* ..
* .. Common blocks ..
COMMON / CLAENV / IPARMS
* ..
* .. Save statement ..
SAVE / CLAENV /
* ..
* .. Executable Statements ..
*
IF( ISPEC.GE.1 .AND. ISPEC.LE.5 ) THEN
*
* Return a value from the common block.
*
ILAENV = IPARMS( ISPEC )
*
ELSE IF( ISPEC.EQ.6 ) THEN
*
* Compute SVD crossover point.
*
ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 )
*
ELSE IF( ISPEC.GE.7 .AND. ISPEC.LE.9 ) THEN
*
* Return a value from the common block.
*
ILAENV = IPARMS( ISPEC )
*
ELSE IF( ISPEC.EQ.10 ) THEN
*
* IEEE NaN arithmetic can be trusted not to trap
*
C ILAENV = 0
ILAENV = 1
IF( ILAENV.EQ.1 ) THEN
ILAENV = IEEECK( 0, 0.0, 1.0 )
END IF
*
ELSE IF( ISPEC.EQ.11 ) THEN
*
* Infinity arithmetic can be trusted not to trap
*
C ILAENV = 0
ILAENV = 1
IF( ILAENV.EQ.1 ) THEN
ILAENV = IEEECK( 1, 0.0, 1.0 )
END IF
*
ELSE
*
* Invalid value for ISPEC
*
ILAENV = -1
END IF
*
RETURN
*
* End of ILAENV
*
END
PROGRAM SCHKAA
*
* -- LAPACK test routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* January 2007
*
* Purpose
* =======
*
* SCHKAA is the main test program for the REAL LAPACK
* linear equation routines
*
* The program must be driven by a short data file. The first 14 records
* specify problem dimensions and program options using list-directed
* input. The remaining lines specify the LAPACK test paths and the
* number of matrix types to use in testing. An annotated example of a
* data file can be obtained by deleting the first 3 characters from the
* following 36 lines:
* Data file for testing REAL LAPACK linear eqn. routines
* 7 Number of values of M
* 0 1 2 3 5 10 16 Values of M (row dimension)
* 7 Number of values of N
* 0 1 2 3 5 10 16 Values of N (column dimension)
* 1 Number of values of NRHS
* 2 Values of NRHS (number of right hand sides)
* 5 Number of values of NB
* 1 3 3 3 20 Values of NB (the blocksize)
* 1 0 5 9 1 Values of NX (crossover point)
* 20.0 Threshold value of test ratio
* T Put T to test the LAPACK routines
* T Put T to test the driver routines
* T Put T to test the error exits
* SGE 11 List types on next line if 0 < NTYPES < 11
* SGB 8 List types on next line if 0 < NTYPES < 8
* SGT 12 List types on next line if 0 < NTYPES < 12
* SPO 9 List types on next line if 0 < NTYPES < 9
* SPP 9 List types on next line if 0 < NTYPES < 9
* SPB 8 List types on next line if 0 < NTYPES < 8
* SPT 12 List types on next line if 0 < NTYPES < 12
* SSY 10 List types on next line if 0 < NTYPES < 10
* SSP 10 List types on next line if 0 < NTYPES < 10
* STR 18 List types on next line if 0 < NTYPES < 18
* STP 18 List types on next line if 0 < NTYPES < 18
* STB 17 List types on next line if 0 < NTYPES < 17
* SQR 8 List types on next line if 0 < NTYPES < 8
* SRQ 8 List types on next line if 0 < NTYPES < 8
* SLQ 8 List types on next line if 0 < NTYPES < 8
* SQL 8 List types on next line if 0 < NTYPES < 8
* SQP 6 List types on next line if 0 < NTYPES < 6
* STZ 3 List types on next line if 0 < NTYPES < 3
* SLS 6 List types on next line if 0 < NTYPES < 6
* SEQ
*
* Internal Parameters
* ===================
*
* NMAX INTEGER
* The maximum allowable value for N
*
* MAXIN INTEGER
* The number of different values that can be used for each of
* M, N, NRHS, NB, and NX
*
* MAXRHS INTEGER
* The maximum number of right hand sides
*
* NIN INTEGER
* The unit number for input
*
* NOUT INTEGER
* The unit number for output
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 132 )
INTEGER MAXIN
PARAMETER ( MAXIN = 12 )
INTEGER MAXRHS
PARAMETER ( MAXRHS = 16 )
INTEGER MATMAX
PARAMETER ( MATMAX = 30 )
INTEGER NIN, NOUT
PARAMETER ( NIN = 5, NOUT = 6 )
INTEGER KDMAX
PARAMETER ( KDMAX = NMAX+( NMAX+1 ) / 4 )
* ..
* .. Local Scalars ..
LOGICAL FATAL, TSTCHK, TSTDRV, TSTERR
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 PATH
CHARACTER*10 INTSTR
CHARACTER*72 ALINE
INTEGER I, IC, J, K, LA, LAFAC, LDA, NB, NM, NMATS, NN,
$ NNB, NNB2, NNS, NRHS, NTYPES,
$ VERS_MAJOR, VERS_MINOR, VERS_PATCH
REAL EPS, S1, S2, THREQ, THRESH
* ..
* .. Local Arrays ..
LOGICAL DOTYPE( MATMAX )
INTEGER IWORK( 25*NMAX ), MVAL( MAXIN ),
$ NBVAL( MAXIN ), NBVAL2( MAXIN ),
$ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN )
REAL A( ( KDMAX+1 )*NMAX, 7 ), B( NMAX*MAXRHS, 4 ),
$ RWORK( 5*NMAX+2*MAXRHS ), S( 2*NMAX ),
$ WORK( NMAX, NMAX+MAXRHS+30 )
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
REAL SECOND, SLAMCH
EXTERNAL LSAME, LSAMEN, SECOND, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL ALAREQ, SCHKEQ, SCHKGB, SCHKGE, SCHKGT, SCHKLQ,
$ SCHKPB, SCHKPO, SCHKPP, SCHKPT, SCHKQ3, SCHKQL,
$ SCHKQP, SCHKQR, SCHKRQ, SCHKSP, SCHKSY, SCHKTB,
$ SCHKTP, SCHKTR, SCHKTZ, SDRVGB, SDRVGE, SDRVGT,
$ SDRVLS, SDRVPB, SDRVPO, SDRVPP, SDRVPT, SDRVSP,
$ SDRVSY, ILAVER
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Arrays in Common ..
INTEGER IPARMS( 100 )
* ..
* .. Common blocks ..
COMMON / CLAENV / IPARMS
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA THREQ / 2.0E0 / , INTSTR / '0123456789' /
* ..
* .. Executable Statements ..
*
S1 = SECOND( )
LDA = NMAX
FATAL = .FALSE.
*
* Read a dummy line.
*
READ( NIN, FMT = * )
*
* Report values of parameters.
*
CALL ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH )
WRITE( NOUT, FMT = 9994 ) VERS_MAJOR, VERS_MINOR, VERS_PATCH
*
* Read the values of M
*
READ( NIN, FMT = * )NM
IF( NM.LT.1 ) THEN
WRITE( NOUT, FMT = 9996 )' NM ', NM, 1
NM = 0
FATAL = .TRUE.
ELSE IF( NM.GT.MAXIN ) THEN
WRITE( NOUT, FMT = 9995 )' NM ', NM, MAXIN
NM = 0
FATAL = .TRUE.
END IF
READ( NIN, FMT = * )( MVAL( I ), I = 1, NM )
DO 10 I = 1, NM
IF( MVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9996 )' M ', MVAL( I ), 0
FATAL = .TRUE.
ELSE IF( MVAL( I ).GT.NMAX ) THEN
WRITE( NOUT, FMT = 9995 )' M ', MVAL( I ), NMAX
FATAL = .TRUE.
END IF
10 CONTINUE
IF( NM.GT.0 )
$ WRITE( NOUT, FMT = 9993 )'M ', ( MVAL( I ), I = 1, NM )
*
* Read the values of N
*
READ( NIN, FMT = * )NN
IF( NN.LT.1 ) THEN
WRITE( NOUT, FMT = 9996 )' NN ', NN, 1
NN = 0
FATAL = .TRUE.
ELSE IF( NN.GT.MAXIN ) THEN
WRITE( NOUT, FMT = 9995 )' NN ', NN, MAXIN
NN = 0
FATAL = .TRUE.
END IF
READ( NIN, FMT = * )( NVAL( I ), I = 1, NN )
DO 20 I = 1, NN
IF( NVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9996 )' N ', NVAL( I ), 0
FATAL = .TRUE.
ELSE IF( NVAL( I ).GT.NMAX ) THEN
WRITE( NOUT, FMT = 9995 )' N ', NVAL( I ), NMAX
FATAL = .TRUE.
END IF
20 CONTINUE
IF( NN.GT.0 )
$ WRITE( NOUT, FMT = 9993 )'N ', ( NVAL( I ), I = 1, NN )
*
* Read the values of NRHS
*
READ( NIN, FMT = * )NNS
IF( NNS.LT.1 ) THEN
WRITE( NOUT, FMT = 9996 )' NNS', NNS, 1
NNS = 0
FATAL = .TRUE.
ELSE IF( NNS.GT.MAXIN ) THEN
WRITE( NOUT, FMT = 9995 )' NNS', NNS, MAXIN
NNS = 0
FATAL = .TRUE.
END IF
READ( NIN, FMT = * )( NSVAL( I ), I = 1, NNS )
DO 30 I = 1, NNS
IF( NSVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9996 )'NRHS', NSVAL( I ), 0
FATAL = .TRUE.
ELSE IF( NSVAL( I ).GT.MAXRHS ) THEN
WRITE( NOUT, FMT = 9995 )'NRHS', NSVAL( I ), MAXRHS
FATAL = .TRUE.
END IF
30 CONTINUE
IF( NNS.GT.0 )
$ WRITE( NOUT, FMT = 9993 )'NRHS', ( NSVAL( I ), I = 1, NNS )
*
* Read the values of NB
*
READ( NIN, FMT = * )NNB
IF( NNB.LT.1 ) THEN
WRITE( NOUT, FMT = 9996 )'NNB ', NNB, 1
NNB = 0
FATAL = .TRUE.
ELSE IF( NNB.GT.MAXIN ) THEN
WRITE( NOUT, FMT = 9995 )'NNB ', NNB, MAXIN
NNB = 0
FATAL = .TRUE.
END IF
READ( NIN, FMT = * )( NBVAL( I ), I = 1, NNB )
DO 40 I = 1, NNB
IF( NBVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9996 )' NB ', NBVAL( I ), 0
FATAL = .TRUE.
END IF
40 CONTINUE
IF( NNB.GT.0 )
$ WRITE( NOUT, FMT = 9993 )'NB ', ( NBVAL( I ), I = 1, NNB )
*
* Set NBVAL2 to be the set of unique values of NB
*
NNB2 = 0
DO 60 I = 1, NNB
NB = NBVAL( I )
DO 50 J = 1, NNB2
IF( NB.EQ.NBVAL2( J ) )
$ GO TO 60
50 CONTINUE
NNB2 = NNB2 + 1
NBVAL2( NNB2 ) = NB
60 CONTINUE
*
* Read the values of NX
*
READ( NIN, FMT = * )( NXVAL( I ), I = 1, NNB )
DO 70 I = 1, NNB
IF( NXVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9996 )' NX ', NXVAL( I ), 0
FATAL = .TRUE.
END IF
70 CONTINUE
IF( NNB.GT.0 )
$ WRITE( NOUT, FMT = 9993 )'NX ', ( NXVAL( I ), I = 1, NNB )
*
* Read the threshold value for the test ratios.
*
READ( NIN, FMT = * )THRESH
WRITE( NOUT, FMT = 9992 )THRESH
*
* Read the flag that indicates whether to test the LAPACK routines.
*
READ( NIN, FMT = * )TSTCHK
*
* Read the flag that indicates whether to test the driver routines.
*
READ( NIN, FMT = * )TSTDRV
*
* Read the flag that indicates whether to test the error exits.
*
READ( NIN, FMT = * )TSTERR
*
IF( FATAL ) THEN
WRITE( NOUT, FMT = 9999 )
STOP
END IF
*
* Calculate and print the machine dependent constants.
*
EPS = SLAMCH( 'Underflow threshold' )
WRITE( NOUT, FMT = 9991 )'underflow', EPS
EPS = SLAMCH( 'Overflow threshold' )
WRITE( NOUT, FMT = 9991 )'overflow ', EPS
EPS = SLAMCH( 'Epsilon' )
WRITE( NOUT, FMT = 9991 )'precision', EPS
WRITE( NOUT, FMT = * )
*
80 CONTINUE
*
* Read a test path and the number of matrix types to use.
*
READ( NIN, FMT = '(A72)', END = 140 )ALINE
PATH = ALINE( 1: 3 )
NMATS = MATMAX
I = 3
90 CONTINUE
I = I + 1
IF( I.GT.72 ) THEN
NMATS = MATMAX
GO TO 130
END IF
IF( ALINE( I: I ).EQ.' ' )
$ GO TO 90
NMATS = 0
100 CONTINUE
C1 = ALINE( I: I )
DO 110 K = 1, 10
IF( C1.EQ.INTSTR( K: K ) ) THEN
IC = K - 1
GO TO 120
END IF
110 CONTINUE
GO TO 130
120 CONTINUE
NMATS = NMATS*10 + IC
I = I + 1
IF( I.GT.72 )
$ GO TO 130
GO TO 100
130 CONTINUE
C1 = PATH( 1: 1 )
C2 = PATH( 2: 3 )
NRHS = NSVAL( 1 )
*
* Check first character for correct precision.
*
IF( .NOT.LSAME( C1, 'Single precision' ) ) THEN
WRITE( NOUT, FMT = 9990 )PATH
*
ELSE IF( NMATS.LE.0 ) THEN
*
* Check for a positive number of tests requested.
*
WRITE( NOUT, FMT = 9989 )PATH
*
ELSE IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
* GE: general matrices
*
NTYPES = 11
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL SCHKGE( DOTYPE, NM, MVAL, NN, NVAL, NNB2, NBVAL2, NNS,
$ NSVAL, THRESH, TSTERR, LDA, A( 1, 1 ),
$ A( 1, 2 ), A( 1, 3 ), B( 1, 1 ), B( 1, 2 ),
$ B( 1, 3 ), WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
IF( TSTDRV ) THEN
CALL SDRVGE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, LDA,
$ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B( 1, 1 ),
$ B( 1, 2 ), B( 1, 3 ), B( 1, 4 ), S, WORK,
$ RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
*
* GB: general banded matrices
*
LA = ( 2*KDMAX+1 )*NMAX
LAFAC = ( 3*KDMAX+1 )*NMAX
NTYPES = 8
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL SCHKGB( DOTYPE, NM, MVAL, NN, NVAL, NNB2, NBVAL2, NNS,
$ NSVAL, THRESH, TSTERR, A( 1, 1 ), LA,
$ A( 1, 3 ), LAFAC, B( 1, 1 ), B( 1, 2 ),
$ B( 1, 3 ), WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
IF( TSTDRV ) THEN
CALL SDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
$ A( 1, 1 ), LA, A( 1, 3 ), LAFAC, A( 1, 6 ),
$ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), B( 1, 4 ), S,
$ WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'GT' ) ) THEN
*
* GT: general tridiagonal matrices
*
NTYPES = 12
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL SCHKGT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
$ A( 1, 1 ), A( 1, 2 ), B( 1, 1 ), B( 1, 2 ),
$ B( 1, 3 ), WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
IF( TSTDRV ) THEN
CALL SDRVGT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
$ A( 1, 1 ), A( 1, 2 ), B( 1, 1 ), B( 1, 2 ),
$ B( 1, 3 ), WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'PO' ) ) THEN
*
* PO: positive definite matrices
*
NTYPES = 9
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL SCHKPO( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL,
$ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ),
$ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
$ WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
IF( TSTDRV ) THEN
CALL SDRVPO( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, LDA,
$ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B( 1, 1 ),
$ B( 1, 2 ), B( 1, 3 ), B( 1, 4 ), S, WORK,
$ RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'PP' ) ) THEN
*
* PP: positive definite packed matrices
*
NTYPES = 9
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL SCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
$ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
$ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK, RWORK,
$ IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
IF( TSTDRV ) THEN
CALL SDRVPP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, LDA,
$ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B( 1, 1 ),
$ B( 1, 2 ), B( 1, 3 ), B( 1, 4 ), S, WORK,
$ RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN
*
* PB: positive definite banded matrices
*
NTYPES = 8
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL SCHKPB( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL,
$ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ),
$ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
$ WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
IF( TSTDRV ) THEN
CALL SDRVPB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, LDA,
$ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B( 1, 1 ),
$ B( 1, 2 ), B( 1, 3 ), B( 1, 4 ), S, WORK,
$ RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'PT' ) ) THEN
*
* PT: positive definite tridiagonal matrices
*
NTYPES = 12
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL SCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
$ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B( 1, 1 ),
$ B( 1, 2 ), B( 1, 3 ), WORK, RWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
IF( TSTDRV ) THEN
CALL SDRVPT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
$ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B( 1, 1 ),
$ B( 1, 2 ), B( 1, 3 ), WORK, RWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'SY' ) ) THEN
*
* SY: symmetric indefinite matrices
*
NTYPES = 10
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL SCHKSY( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL,
$ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ),
$ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
$ WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
IF( TSTDRV ) THEN
CALL SDRVSY( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, LDA,
$ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B( 1, 1 ),
$ B( 1, 2 ), B( 1, 3 ), WORK, RWORK, IWORK,
$ NOUT )
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
* SP: symmetric indefinite packed matrices
*
NTYPES = 10
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL SCHKSP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
$ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
$ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK, RWORK,
$ IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
IF( TSTDRV ) THEN
CALL SDRVSP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, LDA,
$ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B( 1, 1 ),
$ B( 1, 2 ), B( 1, 3 ), WORK, RWORK, IWORK,
$ NOUT )
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'TR' ) ) THEN
*
* TR: triangular matrices
*
NTYPES = 18
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL SCHKTR( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL,
$ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ),
$ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK, RWORK,
$ IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'TP' ) ) THEN
*
* TP: triangular packed matrices
*
NTYPES = 18
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL SCHKTP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
$ LDA, A( 1, 1 ), A( 1, 2 ), B( 1, 1 ),
$ B( 1, 2 ), B( 1, 3 ), WORK, RWORK, IWORK,
$ NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
*
* TB: triangular banded matrices
*
NTYPES = 17
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL SCHKTB( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
$ LDA, A( 1, 1 ), A( 1, 2 ), B( 1, 1 ),
$ B( 1, 2 ), B( 1, 3 ), WORK, RWORK, IWORK,
$ NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'QR' ) ) THEN
*
* QR: QR factorization
*
NTYPES = 8
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL SCHKQR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
$ NRHS, THRESH, TSTERR, NMAX, A( 1, 1 ),
$ A( 1, 2 ), A( 1, 3 ), A( 1, 4 ), A( 1, 5 ),
$ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), B( 1, 4 ),
$ WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'LQ' ) ) THEN
*
* LQ: LQ factorization
*
NTYPES = 8
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL SCHKLQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
$ NRHS, THRESH, TSTERR, NMAX, A( 1, 1 ),
$ A( 1, 2 ), A( 1, 3 ), A( 1, 4 ), A( 1, 5 ),
$ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), B( 1, 4 ),
$ WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'QL' ) ) THEN
*
* QL: QL factorization
*
NTYPES = 8
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL SCHKQL( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
$ NRHS, THRESH, TSTERR, NMAX, A( 1, 1 ),
$ A( 1, 2 ), A( 1, 3 ), A( 1, 4 ), A( 1, 5 ),
$ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), B( 1, 4 ),
$ WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'RQ' ) ) THEN
*
* RQ: RQ factorization
*
NTYPES = 8
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL SCHKRQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
$ NRHS, THRESH, TSTERR, NMAX, A( 1, 1 ),
$ A( 1, 2 ), A( 1, 3 ), A( 1, 4 ), A( 1, 5 ),
$ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), B( 1, 4 ),
$ WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'QP' ) ) THEN
*
* QP: QR factorization with pivoting
*
NTYPES = 6
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL SCHKQP( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR,
$ A( 1, 1 ), A( 1, 2 ), B( 1, 1 ), B( 1, 2 ),
$ B( 1, 3 ), WORK, IWORK, NOUT )
CALL SCHKQ3( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
$ THRESH, A( 1, 1 ), A( 1, 2 ), B( 1, 1 ),
$ B( 1, 2 ), B( 1, 3 ), WORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'TZ' ) ) THEN
*
* TZ: Trapezoidal matrix
*
NTYPES = 3
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL SCHKTZ( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR,
$ A( 1, 1 ), A( 1, 2 ), B( 1, 1 ), B( 1, 2 ),
$ B( 1, 3 ), WORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'LS' ) ) THEN
*
* LS: Least squares drivers
*
NTYPES = 6
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTDRV ) THEN
CALL SDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB,
$ NBVAL, NXVAL, THRESH, TSTERR, A( 1, 1 ),
$ A( 1, 2 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
$ RWORK, RWORK( NMAX+1 ), WORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'EQ' ) ) THEN
*
* EQ: Equilibration routines for general and positive definite
* matrices (THREQ should be between 2 and 10)
*
IF( TSTCHK ) THEN
CALL SCHKEQ( THREQ, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
ELSE
*
WRITE( NOUT, FMT = 9990 )PATH
END IF
*
* Go back to get another input line.
*
GO TO 80
*
* Branch to this line when the last record is read.
*
140 CONTINUE
CLOSE ( NIN )
S2 = SECOND( )
WRITE( NOUT, FMT = 9998 )
WRITE( NOUT, FMT = 9997 )S2 - S1
*
9999 FORMAT( / ' Execution not attempted due to input errors' )
9998 FORMAT( / ' End of tests' )
9997 FORMAT( ' Total time used = ', F12.2, ' seconds', / )
9996 FORMAT( ' Invalid input value: ', A4, '=', I6, '; must be >=',
$ I6 )
9995 FORMAT( ' Invalid input value: ', A4, '=', I6, '; must be <=',
$ I6 )
9994 FORMAT( ' Tests of the REAL LAPACK routines ',
$ / ' LAPACK VERSION ', I1, '.', I1, '.', I1,
$ / / ' The following parameter values will be used:' )
9993 FORMAT( 4X, A4, ': ', 10I6, / 11X, 10I6 )
9992 FORMAT( / ' Routines pass computational tests if test ratio is ',
$ 'less than', F8.2, / )
9991 FORMAT( ' Relative machine ', A, ' is taken to be', E16.6 )
9990 FORMAT( / 1X, A3, ': Unrecognized path name' )
9989 FORMAT( / 1X, A3, ' routines were not tested' )
9988 FORMAT( / 1X, A3, ' driver routines were not tested' )
*
* End of SCHKAA
*
END
SUBROUTINE SCHKEQ( THRESH, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER NOUT
REAL THRESH
* ..
*
* Purpose
* =======
*
* SCHKEQ tests SGEEQU, SGBEQU, SPOEQU, SPPEQU and SPBEQU
*
* Arguments
* =========
*
* THRESH (input) REAL
* Threshold for testing routines. Should be between 2 and 10.
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TEN
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E+0, TEN = 1.0E1 )
INTEGER NSZ, NSZB
PARAMETER ( NSZ = 5, NSZB = 3*NSZ-2 )
INTEGER NSZP, NPOW
PARAMETER ( NSZP = ( NSZ*( NSZ+1 ) ) / 2,
$ NPOW = 2*NSZ+1 )
* ..
* .. Local Scalars ..
LOGICAL OK
CHARACTER*3 PATH
INTEGER I, INFO, J, KL, KU, M, N
REAL CCOND, EPS, NORM, RATIO, RCMAX, RCMIN, RCOND
* ..
* .. Local Arrays ..
REAL A( NSZ, NSZ ), AB( NSZB, NSZ ), AP( NSZP ),
$ C( NSZ ), POW( NPOW ), R( NSZ ), RESLTS( 5 ),
$ RPOW( NPOW )
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SGBEQU, SGEEQU, SPBEQU, SPOEQU, SPPEQU
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
PATH( 1:1 ) = 'Single precision'
PATH( 2:3 ) = 'EQ'
*
EPS = SLAMCH( 'P' )
DO 10 I = 1, 5
RESLTS( I ) = ZERO
10 CONTINUE
DO 20 I = 1, NPOW
POW( I ) = TEN**( I-1 )
RPOW( I ) = ONE / POW( I )
20 CONTINUE
*
* Test SGEEQU
*
DO 80 N = 0, NSZ
DO 70 M = 0, NSZ
*
DO 40 J = 1, NSZ
DO 30 I = 1, NSZ
IF( I.LE.M .AND. J.LE.N ) THEN
A( I, J ) = POW( I+J+1 )*( -1 )**( I+J )
ELSE
A( I, J ) = ZERO
END IF
30 CONTINUE
40 CONTINUE
*
CALL SGEEQU( M, N, A, NSZ, R, C, RCOND, CCOND, NORM, INFO )
*
IF( INFO.NE.0 ) THEN
RESLTS( 1 ) = ONE
ELSE
IF( N.NE.0 .AND. M.NE.0 ) THEN
RESLTS( 1 ) = MAX( RESLTS( 1 ),
$ ABS( ( RCOND-RPOW( M ) ) / RPOW( M ) ) )
RESLTS( 1 ) = MAX( RESLTS( 1 ),
$ ABS( ( CCOND-RPOW( N ) ) / RPOW( N ) ) )
RESLTS( 1 ) = MAX( RESLTS( 1 ),
$ ABS( ( NORM-POW( N+M+1 ) ) / POW( N+M+
$ 1 ) ) )
DO 50 I = 1, M
RESLTS( 1 ) = MAX( RESLTS( 1 ),
$ ABS( ( R( I )-RPOW( I+N+1 ) ) /
$ RPOW( I+N+1 ) ) )
50 CONTINUE
DO 60 J = 1, N
RESLTS( 1 ) = MAX( RESLTS( 1 ),
$ ABS( ( C( J )-POW( N-J+1 ) ) /
$ POW( N-J+1 ) ) )
60 CONTINUE
END IF
END IF
*
70 CONTINUE
80 CONTINUE
*
* Test with zero rows and columns
*
DO 90 J = 1, NSZ
A( MAX( NSZ-1, 1 ), J ) = ZERO
90 CONTINUE
CALL SGEEQU( NSZ, NSZ, A, NSZ, R, C, RCOND, CCOND, NORM, INFO )
IF( INFO.NE.MAX( NSZ-1, 1 ) )
$ RESLTS( 1 ) = ONE
*
DO 100 J = 1, NSZ
A( MAX( NSZ-1, 1 ), J ) = ONE
100 CONTINUE
DO 110 I = 1, NSZ
A( I, MAX( NSZ-1, 1 ) ) = ZERO
110 CONTINUE
CALL SGEEQU( NSZ, NSZ, A, NSZ, R, C, RCOND, CCOND, NORM, INFO )
IF( INFO.NE.NSZ+MAX( NSZ-1, 1 ) )
$ RESLTS( 1 ) = ONE
RESLTS( 1 ) = RESLTS( 1 ) / EPS
*
* Test SGBEQU
*
DO 250 N = 0, NSZ
DO 240 M = 0, NSZ
DO 230 KL = 0, MAX( M-1, 0 )
DO 220 KU = 0, MAX( N-1, 0 )
*
DO 130 J = 1, NSZ
DO 120 I = 1, NSZB
AB( I, J ) = ZERO
120 CONTINUE
130 CONTINUE
DO 150 J = 1, N
DO 140 I = 1, M
IF( I.LE.MIN( M, J+KL ) .AND. I.GE.
$ MAX( 1, J-KU ) .AND. J.LE.N ) THEN
AB( KU+1+I-J, J ) = POW( I+J+1 )*
$ ( -1 )**( I+J )
END IF
140 CONTINUE
150 CONTINUE
*
CALL SGBEQU( M, N, KL, KU, AB, NSZB, R, C, RCOND,
$ CCOND, NORM, INFO )
*
IF( INFO.NE.0 ) THEN
IF( .NOT.( ( N+KL.LT.M .AND. INFO.EQ.N+KL+1 ) .OR.
$ ( M+KU.LT.N .AND. INFO.EQ.2*M+KU+1 ) ) ) THEN
RESLTS( 2 ) = ONE
END IF
ELSE
IF( N.NE.0 .AND. M.NE.0 ) THEN
*
RCMIN = R( 1 )
RCMAX = R( 1 )
DO 160 I = 1, M
RCMIN = MIN( RCMIN, R( I ) )
RCMAX = MAX( RCMAX, R( I ) )
160 CONTINUE
RATIO = RCMIN / RCMAX
RESLTS( 2 ) = MAX( RESLTS( 2 ),
$ ABS( ( RCOND-RATIO ) / RATIO ) )
*
RCMIN = C( 1 )
RCMAX = C( 1 )
DO 170 J = 1, N
RCMIN = MIN( RCMIN, C( J ) )
RCMAX = MAX( RCMAX, C( J ) )
170 CONTINUE
RATIO = RCMIN / RCMAX
RESLTS( 2 ) = MAX( RESLTS( 2 ),
$ ABS( ( CCOND-RATIO ) / RATIO ) )
*
RESLTS( 2 ) = MAX( RESLTS( 2 ),
$ ABS( ( NORM-POW( N+M+1 ) ) /
$ POW( N+M+1 ) ) )
DO 190 I = 1, M
RCMAX = ZERO
DO 180 J = 1, N
IF( I.LE.J+KL .AND. I.GE.J-KU ) THEN
RATIO = ABS( R( I )*POW( I+J+1 )*
$ C( J ) )
RCMAX = MAX( RCMAX, RATIO )
END IF
180 CONTINUE
RESLTS( 2 ) = MAX( RESLTS( 2 ),
$ ABS( ONE-RCMAX ) )
190 CONTINUE
*
DO 210 J = 1, N
RCMAX = ZERO
DO 200 I = 1, M
IF( I.LE.J+KL .AND. I.GE.J-KU ) THEN
RATIO = ABS( R( I )*POW( I+J+1 )*
$ C( J ) )
RCMAX = MAX( RCMAX, RATIO )
END IF
200 CONTINUE
RESLTS( 2 ) = MAX( RESLTS( 2 ),
$ ABS( ONE-RCMAX ) )
210 CONTINUE
END IF
END IF
*
220 CONTINUE
230 CONTINUE
240 CONTINUE
250 CONTINUE
RESLTS( 2 ) = RESLTS( 2 ) / EPS
*
* Test SPOEQU
*
DO 290 N = 0, NSZ
*
DO 270 I = 1, NSZ
DO 260 J = 1, NSZ
IF( I.LE.N .AND. J.EQ.I ) THEN
A( I, J ) = POW( I+J+1 )*( -1 )**( I+J )
ELSE
A( I, J ) = ZERO
END IF
260 CONTINUE
270 CONTINUE
*
CALL SPOEQU( N, A, NSZ, R, RCOND, NORM, INFO )
*
IF( INFO.NE.0 ) THEN
RESLTS( 3 ) = ONE
ELSE
IF( N.NE.0 ) THEN
RESLTS( 3 ) = MAX( RESLTS( 3 ),
$ ABS( ( RCOND-RPOW( N ) ) / RPOW( N ) ) )
RESLTS( 3 ) = MAX( RESLTS( 3 ),
$ ABS( ( NORM-POW( 2*N+1 ) ) / POW( 2*N+
$ 1 ) ) )
DO 280 I = 1, N
RESLTS( 3 ) = MAX( RESLTS( 3 ),
$ ABS( ( R( I )-RPOW( I+1 ) ) / RPOW( I+
$ 1 ) ) )
280 CONTINUE
END IF
END IF
290 CONTINUE
A( MAX( NSZ-1, 1 ), MAX( NSZ-1, 1 ) ) = -ONE
CALL SPOEQU( NSZ, A, NSZ, R, RCOND, NORM, INFO )
IF( INFO.NE.MAX( NSZ-1, 1 ) )
$ RESLTS( 3 ) = ONE
RESLTS( 3 ) = RESLTS( 3 ) / EPS
*
* Test SPPEQU
*
DO 360 N = 0, NSZ
*
* Upper triangular packed storage
*
DO 300 I = 1, ( N*( N+1 ) ) / 2
AP( I ) = ZERO
300 CONTINUE
DO 310 I = 1, N
AP( ( I*( I+1 ) ) / 2 ) = POW( 2*I+1 )
310 CONTINUE
*
CALL SPPEQU( 'U', N, AP, R, RCOND, NORM, INFO )
*
IF( INFO.NE.0 ) THEN
RESLTS( 4 ) = ONE
ELSE
IF( N.NE.0 ) THEN
RESLTS( 4 ) = MAX( RESLTS( 4 ),
$ ABS( ( RCOND-RPOW( N ) ) / RPOW( N ) ) )
RESLTS( 4 ) = MAX( RESLTS( 4 ),
$ ABS( ( NORM-POW( 2*N+1 ) ) / POW( 2*N+
$ 1 ) ) )
DO 320 I = 1, N
RESLTS( 4 ) = MAX( RESLTS( 4 ),
$ ABS( ( R( I )-RPOW( I+1 ) ) / RPOW( I+
$ 1 ) ) )
320 CONTINUE
END IF
END IF
*
* Lower triangular packed storage
*
DO 330 I = 1, ( N*( N+1 ) ) / 2
AP( I ) = ZERO
330 CONTINUE
J = 1
DO 340 I = 1, N
AP( J ) = POW( 2*I+1 )
J = J + ( N-I+1 )
340 CONTINUE
*
CALL SPPEQU( 'L', N, AP, R, RCOND, NORM, INFO )
*
IF( INFO.NE.0 ) THEN
RESLTS( 4 ) = ONE
ELSE
IF( N.NE.0 ) THEN
RESLTS( 4 ) = MAX( RESLTS( 4 ),
$ ABS( ( RCOND-RPOW( N ) ) / RPOW( N ) ) )
RESLTS( 4 ) = MAX( RESLTS( 4 ),
$ ABS( ( NORM-POW( 2*N+1 ) ) / POW( 2*N+
$ 1 ) ) )
DO 350 I = 1, N
RESLTS( 4 ) = MAX( RESLTS( 4 ),
$ ABS( ( R( I )-RPOW( I+1 ) ) / RPOW( I+
$ 1 ) ) )
350 CONTINUE
END IF
END IF
*
360 CONTINUE
I = ( NSZ*( NSZ+1 ) ) / 2 - 2
AP( I ) = -ONE
CALL SPPEQU( 'L', NSZ, AP, R, RCOND, NORM, INFO )
IF( INFO.NE.MAX( NSZ-1, 1 ) )
$ RESLTS( 4 ) = ONE
RESLTS( 4 ) = RESLTS( 4 ) / EPS
*
* Test SPBEQU
*
DO 460 N = 0, NSZ
DO 450 KL = 0, MAX( N-1, 0 )
*
* Test upper triangular storage
*
DO 380 J = 1, NSZ
DO 370 I = 1, NSZB
AB( I, J ) = ZERO
370 CONTINUE
380 CONTINUE
DO 390 J = 1, N
AB( KL+1, J ) = POW( 2*J+1 )
390 CONTINUE
*
CALL SPBEQU( 'U', N, KL, AB, NSZB, R, RCOND, NORM, INFO )
*
IF( INFO.NE.0 ) THEN
RESLTS( 5 ) = ONE
ELSE
IF( N.NE.0 ) THEN
RESLTS( 5 ) = MAX( RESLTS( 5 ),
$ ABS( ( RCOND-RPOW( N ) ) / RPOW( N ) ) )
RESLTS( 5 ) = MAX( RESLTS( 5 ),
$ ABS( ( NORM-POW( 2*N+1 ) ) / POW( 2*N+
$ 1 ) ) )
DO 400 I = 1, N
RESLTS( 5 ) = MAX( RESLTS( 5 ),
$ ABS( ( R( I )-RPOW( I+1 ) ) /
$ RPOW( I+1 ) ) )
400 CONTINUE
END IF
END IF
IF( N.NE.0 ) THEN
AB( KL+1, MAX( N-1, 1 ) ) = -ONE
CALL SPBEQU( 'U', N, KL, AB, NSZB, R, RCOND, NORM, INFO )
IF( INFO.NE.MAX( N-1, 1 ) )
$ RESLTS( 5 ) = ONE
END IF
*
* Test lower triangular storage
*
DO 420 J = 1, NSZ
DO 410 I = 1, NSZB
AB( I, J ) = ZERO
410 CONTINUE
420 CONTINUE
DO 430 J = 1, N
AB( 1, J ) = POW( 2*J+1 )
430 CONTINUE
*
CALL SPBEQU( 'L', N, KL, AB, NSZB, R, RCOND, NORM, INFO )
*
IF( INFO.NE.0 ) THEN
RESLTS( 5 ) = ONE
ELSE
IF( N.NE.0 ) THEN
RESLTS( 5 ) = MAX( RESLTS( 5 ),
$ ABS( ( RCOND-RPOW( N ) ) / RPOW( N ) ) )
RESLTS( 5 ) = MAX( RESLTS( 5 ),
$ ABS( ( NORM-POW( 2*N+1 ) ) / POW( 2*N+
$ 1 ) ) )
DO 440 I = 1, N
RESLTS( 5 ) = MAX( RESLTS( 5 ),
$ ABS( ( R( I )-RPOW( I+1 ) ) /
$ RPOW( I+1 ) ) )
440 CONTINUE
END IF
END IF
IF( N.NE.0 ) THEN
AB( 1, MAX( N-1, 1 ) ) = -ONE
CALL SPBEQU( 'L', N, KL, AB, NSZB, R, RCOND, NORM, INFO )
IF( INFO.NE.MAX( N-1, 1 ) )
$ RESLTS( 5 ) = ONE
END IF
450 CONTINUE
460 CONTINUE
RESLTS( 5 ) = RESLTS( 5 ) / EPS
OK = ( RESLTS( 1 ).LE.THRESH ) .AND.
$ ( RESLTS( 2 ).LE.THRESH ) .AND.
$ ( RESLTS( 3 ).LE.THRESH ) .AND.
$ ( RESLTS( 4 ).LE.THRESH ) .AND. ( RESLTS( 5 ).LE.THRESH )
WRITE( NOUT, FMT = * )
IF( OK ) THEN
WRITE( NOUT, FMT = 9999 )PATH
ELSE
IF( RESLTS( 1 ).GT.THRESH )
$ WRITE( NOUT, FMT = 9998 )RESLTS( 1 ), THRESH
IF( RESLTS( 2 ).GT.THRESH )
$ WRITE( NOUT, FMT = 9997 )RESLTS( 2 ), THRESH
IF( RESLTS( 3 ).GT.THRESH )
$ WRITE( NOUT, FMT = 9996 )RESLTS( 3 ), THRESH
IF( RESLTS( 4 ).GT.THRESH )
$ WRITE( NOUT, FMT = 9995 )RESLTS( 4 ), THRESH
IF( RESLTS( 5 ).GT.THRESH )
$ WRITE( NOUT, FMT = 9994 )RESLTS( 5 ), THRESH
END IF
9999 FORMAT( 1X, 'All tests for ', A3,
$ ' routines passed the threshold' )
9998 FORMAT( ' SGEEQU failed test with value ', E10.3, ' exceeding',
$ ' threshold ', E10.3 )
9997 FORMAT( ' SGBEQU failed test with value ', E10.3, ' exceeding',
$ ' threshold ', E10.3 )
9996 FORMAT( ' SPOEQU failed test with value ', E10.3, ' exceeding',
$ ' threshold ', E10.3 )
9995 FORMAT( ' SPPEQU failed test with value ', E10.3, ' exceeding',
$ ' threshold ', E10.3 )
9994 FORMAT( ' SPBEQU failed test with value ', E10.3, ' exceeding',
$ ' threshold ', E10.3 )
RETURN
*
* End of SCHKEQ
*
END
SUBROUTINE SCHKGB( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS,
$ NSVAL, THRESH, TSTERR, A, LA, AFAC, LAFAC, B,
$ X, XACT, WORK, RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER LA, LAFAC, NM, NN, NNB, NNS, NOUT
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ),
$ NVAL( * )
REAL A( * ), AFAC( * ), B( * ), RWORK( * ),
$ WORK( * ), X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* SCHKGB tests SGBTRF, -TRS, -RFS, and -CON
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NNB (input) INTEGER
* The number of values of NB contained in the vector NBVAL.
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* A (workspace) REAL array, dimension (LA)
*
* LA (input) INTEGER
* The length of the array A. LA >= (KLMAX+KUMAX+1)*NMAX
* where KLMAX is the largest entry in the local array KLVAL,
* KUMAX is the largest entry in the local array KUVAL and
* NMAX is the largest entry in the input array NVAL.
*
* AFAC (workspace) REAL array, dimension (LAFAC)
*
* LAFAC (input) INTEGER
* The length of the array AFAC. LAFAC >= (2*KLMAX+KUMAX+1)*NMAX
* where KLMAX is the largest entry in the local array KLVAL,
* KUMAX is the largest entry in the local array KUVAL and
* NMAX is the largest entry in the input array NVAL.
*
* B (workspace) REAL array, dimension (NMAX*NSMAX)
* where NSMAX is the largest entry in NSVAL.
*
* X (workspace) REAL array, dimension (NMAX*NSMAX)
*
* XACT (workspace) REAL array, dimension (NMAX*NSMAX)
*
* WORK (workspace) REAL array, dimension
* (NMAX*max(3,NSMAX,NMAX))
*
* RWORK (workspace) REAL array, dimension
* (max(NMAX,2*NSMAX))
*
* IWORK (workspace) INTEGER array, dimension (2*NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
INTEGER NTYPES, NTESTS
PARAMETER ( NTYPES = 8, NTESTS = 7 )
INTEGER NBW, NTRAN
PARAMETER ( NBW = 4, NTRAN = 3 )
* ..
* .. Local Scalars ..
LOGICAL TRFCON, ZEROT
CHARACTER DIST, NORM, TRANS, TYPE, XTYPE
CHARACTER*3 PATH
INTEGER I, I1, I2, IKL, IKU, IM, IMAT, IN, INB, INFO,
$ IOFF, IRHS, ITRAN, IZERO, J, K, KL, KOFF, KU,
$ LDA, LDAFAC, LDB, M, MODE, N, NB, NERRS, NFAIL,
$ NIMAT, NKL, NKU, NRHS, NRUN
REAL AINVNM, ANORM, ANORMI, ANORMO, CNDNUM, RCOND,
$ RCONDC, RCONDI, RCONDO
* ..
* .. Local Arrays ..
CHARACTER TRANSS( NTRAN )
INTEGER ISEED( 4 ), ISEEDY( 4 ), KLVAL( NBW ),
$ KUVAL( NBW )
REAL RESULT( NTESTS )
* ..
* .. External Functions ..
REAL SGET06, SLANGB, SLANGE
EXTERNAL SGET06, SLANGB, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, SCOPY, SERRGE, SGBCON,
$ SGBRFS, SGBT01, SGBT02, SGBT05, SGBTRF, SGBTRS,
$ SGET04, SLACPY, SLARHS, SLASET, SLATB4, SLATMS,
$ XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 / ,
$ TRANSS / 'N', 'T', 'C' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'GB'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL SERRGE( PATH, NOUT )
INFOT = 0
CALL XLAENV( 2, 2 )
*
* Initialize the first value for the lower and upper bandwidths.
*
KLVAL( 1 ) = 0
KUVAL( 1 ) = 0
*
* Do for each value of M in MVAL
*
DO 160 IM = 1, NM
M = MVAL( IM )
*
* Set values to use for the lower bandwidth.
*
KLVAL( 2 ) = M + ( M+1 ) / 4
*
* KLVAL( 2 ) = MAX( M-1, 0 )
*
KLVAL( 3 ) = ( 3*M-1 ) / 4
KLVAL( 4 ) = ( M+1 ) / 4
*
* Do for each value of N in NVAL
*
DO 150 IN = 1, NN
N = NVAL( IN )
XTYPE = 'N'
*
* Set values to use for the upper bandwidth.
*
KUVAL( 2 ) = N + ( N+1 ) / 4
*
* KUVAL( 2 ) = MAX( N-1, 0 )
*
KUVAL( 3 ) = ( 3*N-1 ) / 4
KUVAL( 4 ) = ( N+1 ) / 4
*
* Set limits on the number of loop iterations.
*
NKL = MIN( M+1, 4 )
IF( N.EQ.0 )
$ NKL = 2
NKU = MIN( N+1, 4 )
IF( M.EQ.0 )
$ NKU = 2
NIMAT = NTYPES
IF( M.LE.0 .OR. N.LE.0 )
$ NIMAT = 1
*
DO 140 IKL = 1, NKL
*
* Do for KL = 0, (5*M+1)/4, (3M-1)/4, and (M+1)/4. This
* order makes it easier to skip redundant values for small
* values of M.
*
KL = KLVAL( IKL )
DO 130 IKU = 1, NKU
*
* Do for KU = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This
* order makes it easier to skip redundant values for
* small values of N.
*
KU = KUVAL( IKU )
*
* Check that A and AFAC are big enough to generate this
* matrix.
*
LDA = KL + KU + 1
LDAFAC = 2*KL + KU + 1
IF( ( LDA*N ).GT.LA .OR. ( LDAFAC*N ).GT.LAFAC ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
IF( N*( KL+KU+1 ).GT.LA ) THEN
WRITE( NOUT, FMT = 9999 )LA, M, N, KL, KU,
$ N*( KL+KU+1 )
NERRS = NERRS + 1
END IF
IF( N*( 2*KL+KU+1 ).GT.LAFAC ) THEN
WRITE( NOUT, FMT = 9998 )LAFAC, M, N, KL, KU,
$ N*( 2*KL+KU+1 )
NERRS = NERRS + 1
END IF
GO TO 130
END IF
*
DO 120 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 120
*
* Skip types 2, 3, or 4 if the matrix size is too
* small.
*
ZEROT = IMAT.GE.2 .AND. IMAT.LE.4
IF( ZEROT .AND. N.LT.IMAT-1 )
$ GO TO 120
*
IF( .NOT.ZEROT .OR. .NOT.DOTYPE( 1 ) ) THEN
*
* Set up parameters with SLATB4 and generate a
* test matrix with SLATMS.
*
CALL SLATB4( PATH, IMAT, M, N, TYPE, KL, KU,
$ ANORM, MODE, CNDNUM, DIST )
*
KOFF = MAX( 1, KU+2-N )
DO 20 I = 1, KOFF - 1
A( I ) = ZERO
20 CONTINUE
SRNAMT = 'SLATMS'
CALL SLATMS( M, N, DIST, ISEED, TYPE, RWORK,
$ MODE, CNDNUM, ANORM, KL, KU, 'Z',
$ A( KOFF ), LDA, WORK, INFO )
*
* Check the error code from SLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', M,
$ N, KL, KU, -1, IMAT, NFAIL,
$ NERRS, NOUT )
GO TO 120
END IF
ELSE IF( IZERO.GT.0 ) THEN
*
* Use the same matrix for types 3 and 4 as for
* type 2 by copying back the zeroed out column.
*
CALL SCOPY( I2-I1+1, B, 1, A( IOFF+I1 ), 1 )
END IF
*
* For types 2, 3, and 4, zero one or more columns of
* the matrix to test that INFO is returned correctly.
*
IZERO = 0
IF( ZEROT ) THEN
IF( IMAT.EQ.2 ) THEN
IZERO = 1
ELSE IF( IMAT.EQ.3 ) THEN
IZERO = MIN( M, N )
ELSE
IZERO = MIN( M, N ) / 2 + 1
END IF
IOFF = ( IZERO-1 )*LDA
IF( IMAT.LT.4 ) THEN
*
* Store the column to be zeroed out in B.
*
I1 = MAX( 1, KU+2-IZERO )
I2 = MIN( KL+KU+1, KU+1+( M-IZERO ) )
CALL SCOPY( I2-I1+1, A( IOFF+I1 ), 1, B, 1 )
*
DO 30 I = I1, I2
A( IOFF+I ) = ZERO
30 CONTINUE
ELSE
DO 50 J = IZERO, N
DO 40 I = MAX( 1, KU+2-J ),
$ MIN( KL+KU+1, KU+1+( M-J ) )
A( IOFF+I ) = ZERO
40 CONTINUE
IOFF = IOFF + LDA
50 CONTINUE
END IF
END IF
*
* These lines, if used in place of the calls in the
* loop over INB, cause the code to bomb on a Sun
* SPARCstation.
*
* ANORMO = SLANGB( 'O', N, KL, KU, A, LDA, RWORK )
* ANORMI = SLANGB( 'I', N, KL, KU, A, LDA, RWORK )
*
* Do for each blocksize in NBVAL
*
DO 110 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
*
* Compute the LU factorization of the band matrix.
*
IF( M.GT.0 .AND. N.GT.0 )
$ CALL SLACPY( 'Full', KL+KU+1, N, A, LDA,
$ AFAC( KL+1 ), LDAFAC )
SRNAMT = 'SGBTRF'
CALL SGBTRF( M, N, KL, KU, AFAC, LDAFAC, IWORK,
$ INFO )
*
* Check error code from SGBTRF.
*
IF( INFO.NE.IZERO )
$ CALL ALAERH( PATH, 'SGBTRF', INFO, IZERO,
$ ' ', M, N, KL, KU, NB, IMAT,
$ NFAIL, NERRS, NOUT )
TRFCON = .FALSE.
*
*+ TEST 1
* Reconstruct matrix from factors and compute
* residual.
*
CALL SGBT01( M, N, KL, KU, A, LDA, AFAC, LDAFAC,
$ IWORK, WORK, RESULT( 1 ) )
*
* Print information about the tests so far that
* did not pass the threshold.
*
IF( RESULT( 1 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9997 )M, N, KL, KU, NB,
$ IMAT, 1, RESULT( 1 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
*
* Skip the remaining tests if this is not the
* first block size or if M .ne. N.
*
IF( INB.GT.1 .OR. M.NE.N )
$ GO TO 110
*
ANORMO = SLANGB( 'O', N, KL, KU, A, LDA, RWORK )
ANORMI = SLANGB( 'I', N, KL, KU, A, LDA, RWORK )
*
IF( INFO.EQ.0 ) THEN
*
* Form the inverse of A so we can get a good
* estimate of CNDNUM = norm(A) * norm(inv(A)).
*
LDB = MAX( 1, N )
CALL SLASET( 'Full', N, N, ZERO, ONE, WORK,
$ LDB )
SRNAMT = 'SGBTRS'
CALL SGBTRS( 'No transpose', N, KL, KU, N,
$ AFAC, LDAFAC, IWORK, WORK, LDB,
$ INFO )
*
* Compute the 1-norm condition number of A.
*
AINVNM = SLANGE( 'O', N, N, WORK, LDB,
$ RWORK )
IF( ANORMO.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDO = ONE
ELSE
RCONDO = ( ONE / ANORMO ) / AINVNM
END IF
*
* Compute the infinity-norm condition number of
* A.
*
AINVNM = SLANGE( 'I', N, N, WORK, LDB,
$ RWORK )
IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDI = ONE
ELSE
RCONDI = ( ONE / ANORMI ) / AINVNM
END IF
ELSE
*
* Do only the condition estimate if INFO.NE.0.
*
TRFCON = .TRUE.
RCONDO = ZERO
RCONDI = ZERO
END IF
*
* Skip the solve tests if the matrix is singular.
*
IF( TRFCON )
$ GO TO 90
*
DO 80 IRHS = 1, NNS
NRHS = NSVAL( IRHS )
XTYPE = 'N'
*
DO 70 ITRAN = 1, NTRAN
TRANS = TRANSS( ITRAN )
IF( ITRAN.EQ.1 ) THEN
RCONDC = RCONDO
NORM = 'O'
ELSE
RCONDC = RCONDI
NORM = 'I'
END IF
*
*+ TEST 2:
* Solve and compute residual for A * X = B.
*
SRNAMT = 'SLARHS'
CALL SLARHS( PATH, XTYPE, ' ', TRANS, N,
$ N, KL, KU, NRHS, A, LDA,
$ XACT, LDB, B, LDB, ISEED,
$ INFO )
XTYPE = 'C'
CALL SLACPY( 'Full', N, NRHS, B, LDB, X,
$ LDB )
*
SRNAMT = 'SGBTRS'
CALL SGBTRS( TRANS, N, KL, KU, NRHS, AFAC,
$ LDAFAC, IWORK, X, LDB, INFO )
*
* Check error code from SGBTRS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SGBTRS', INFO, 0,
$ TRANS, N, N, KL, KU, -1,
$ IMAT, NFAIL, NERRS, NOUT )
*
CALL SLACPY( 'Full', N, NRHS, B, LDB,
$ WORK, LDB )
CALL SGBT02( TRANS, M, N, KL, KU, NRHS, A,
$ LDA, X, LDB, WORK, LDB,
$ RESULT( 2 ) )
*
*+ TEST 3:
* Check solution from generated exact
* solution.
*
CALL SGET04( N, NRHS, X, LDB, XACT, LDB,
$ RCONDC, RESULT( 3 ) )
*
*+ TESTS 4, 5, 6:
* Use iterative refinement to improve the
* solution.
*
SRNAMT = 'SGBRFS'
CALL SGBRFS( TRANS, N, KL, KU, NRHS, A,
$ LDA, AFAC, LDAFAC, IWORK, B,
$ LDB, X, LDB, RWORK,
$ RWORK( NRHS+1 ), WORK,
$ IWORK( N+1 ), INFO )
*
* Check error code from SGBRFS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SGBRFS', INFO, 0,
$ TRANS, N, N, KL, KU, NRHS,
$ IMAT, NFAIL, NERRS, NOUT )
*
CALL SGET04( N, NRHS, X, LDB, XACT, LDB,
$ RCONDC, RESULT( 4 ) )
CALL SGBT05( TRANS, N, KL, KU, NRHS, A,
$ LDA, B, LDB, X, LDB, XACT,
$ LDB, RWORK, RWORK( NRHS+1 ),
$ RESULT( 5 ) )
DO 60 K = 2, 6
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9996 )TRANS, N,
$ KL, KU, NRHS, IMAT, K,
$ RESULT( K )
NFAIL = NFAIL + 1
END IF
60 CONTINUE
NRUN = NRUN + 5
70 CONTINUE
80 CONTINUE
*
*+ TEST 7:
* Get an estimate of RCOND = 1/CNDNUM.
*
90 CONTINUE
DO 100 ITRAN = 1, 2
IF( ITRAN.EQ.1 ) THEN
ANORM = ANORMO
RCONDC = RCONDO
NORM = 'O'
ELSE
ANORM = ANORMI
RCONDC = RCONDI
NORM = 'I'
END IF
SRNAMT = 'SGBCON'
CALL SGBCON( NORM, N, KL, KU, AFAC, LDAFAC,
$ IWORK, ANORM, RCOND, WORK,
$ IWORK( N+1 ), INFO )
*
* Check error code from SGBCON.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SGBCON', INFO, 0,
$ NORM, N, N, KL, KU, -1, IMAT,
$ NFAIL, NERRS, NOUT )
*
RESULT( 7 ) = SGET06( RCOND, RCONDC )
*
* Print information about the tests that did
* not pass the threshold.
*
IF( RESULT( 7 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9995 )NORM, N, KL, KU,
$ IMAT, 7, RESULT( 7 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
100 CONTINUE
*
110 CONTINUE
120 CONTINUE
130 CONTINUE
140 CONTINUE
150 CONTINUE
160 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' *** In SCHKGB, LA=', I5, ' is too small for M=', I5,
$ ', N=', I5, ', KL=', I4, ', KU=', I4,
$ / ' ==> Increase LA to at least ', I5 )
9998 FORMAT( ' *** In SCHKGB, LAFAC=', I5, ' is too small for M=', I5,
$ ', N=', I5, ', KL=', I4, ', KU=', I4,
$ / ' ==> Increase LAFAC to at least ', I5 )
9997 FORMAT( ' M =', I5, ', N =', I5, ', KL=', I5, ', KU=', I5,
$ ', NB =', I4, ', type ', I1, ', test(', I1, ')=', G12.5 )
9996 FORMAT( ' TRANS=''', A1, ''', N=', I5, ', KL=', I5, ', KU=', I5,
$ ', NRHS=', I3, ', type ', I1, ', test(', I1, ')=', G12.5 )
9995 FORMAT( ' NORM =''', A1, ''', N=', I5, ', KL=', I5, ', KU=', I5,
$ ',', 10X, ' type ', I1, ', test(', I1, ')=', G12.5 )
*
RETURN
*
* End of SCHKGB
*
END
SUBROUTINE SCHKGE( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS,
$ NSVAL, THRESH, TSTERR, NMAX, A, AFAC, AINV, B,
$ X, XACT, WORK, RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* January 2007
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NM, NMAX, NN, NNB, NNS, NOUT
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ),
$ NVAL( * )
REAL A( * ), AFAC( * ), AINV( * ), B( * ),
$ RWORK( * ), WORK( * ), X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* SCHKGE tests SGETRF, -TRI, -TRS, -RFS, and -CON.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NNB (input) INTEGER
* The number of values of NB contained in the vector NBVAL.
*
* NBVAL (input) INTEGER array, dimension (NBVAL)
* The values of the blocksize NB.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for M or N, used in dimensioning
* the work arrays.
*
* A (workspace) REAL array, dimension (NMAX*NMAX)
*
* AFAC (workspace) REAL array, dimension (NMAX*NMAX)
*
* AINV (workspace) REAL array, dimension (NMAX*NMAX)
*
* B (workspace) REAL array, dimension (NMAX*NSMAX)
* where NSMAX is the largest entry in NSVAL.
*
* X (workspace) REAL array, dimension (NMAX*NSMAX)
*
* XACT (workspace) REAL array, dimension (NMAX*NSMAX)
*
* WORK (workspace) REAL array, dimension
* (NMAX*max(3,NSMAX))
*
* RWORK (workspace) REAL array, dimension
* (max(2*NMAX,2*NSMAX+NWORK))
*
* IWORK (workspace) INTEGER array, dimension (2*NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
INTEGER NTYPES
PARAMETER ( NTYPES = 11 )
INTEGER NTESTS
PARAMETER ( NTESTS = 8 )
INTEGER NTRAN
PARAMETER ( NTRAN = 3 )
* ..
* .. Local Scalars ..
LOGICAL TRFCON, ZEROT
CHARACTER DIST, NORM, TRANS, TYPE, XTYPE
CHARACTER*3 PATH
INTEGER I, IM, IMAT, IN, INB, INFO, IOFF, IRHS, ITRAN,
$ IZERO, K, KL, KU, LDA, LWORK, M, MODE, N, NB,
$ NERRS, NFAIL, NIMAT, NRHS, NRUN, NT
REAL AINVNM, ANORM, ANORMI, ANORMO, CNDNUM, DUMMY,
$ RCOND, RCONDC, RCONDI, RCONDO
* ..
* .. Local Arrays ..
CHARACTER TRANSS( NTRAN )
INTEGER ISEED( 4 ), ISEEDY( 4 )
REAL RESULT( NTESTS )
* ..
* .. External Functions ..
REAL SGET06, SLANGE
EXTERNAL SGET06, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, SERRGE, SGECON, SGERFS,
$ SGET01, SGET02, SGET03, SGET04, SGET07, SGETRF,
$ SGETRI, SGETRS, SLACPY, SLARHS, SLASET, SLATB4,
$ SLATMS, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 / ,
$ TRANSS / 'N', 'T', 'C' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'GE'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
CALL XLAENV( 1, 1 )
IF( TSTERR )
$ CALL SERRGE( PATH, NOUT )
INFOT = 0
CALL XLAENV( 2, 2 )
*
* Do for each value of M in MVAL
*
DO 120 IM = 1, NM
M = MVAL( IM )
LDA = MAX( 1, M )
*
* Do for each value of N in NVAL
*
DO 110 IN = 1, NN
N = NVAL( IN )
XTYPE = 'N'
NIMAT = NTYPES
IF( M.LE.0 .OR. N.LE.0 )
$ NIMAT = 1
*
DO 100 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 100
*
* Skip types 5, 6, or 7 if the matrix size is too small.
*
ZEROT = IMAT.GE.5 .AND. IMAT.LE.7
IF( ZEROT .AND. N.LT.IMAT-4 )
$ GO TO 100
*
* Set up parameters with SLATB4 and generate a test matrix
* with SLATMS.
*
CALL SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
*
SRNAMT = 'SLATMS'
CALL SLATMS( M, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, 'No packing', A, LDA,
$ WORK, INFO )
*
* Check error code from SLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', M, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 100
END IF
*
* For types 5-7, zero one or more columns of the matrix to
* test that INFO is returned correctly.
*
IF( ZEROT ) THEN
IF( IMAT.EQ.5 ) THEN
IZERO = 1
ELSE IF( IMAT.EQ.6 ) THEN
IZERO = MIN( M, N )
ELSE
IZERO = MIN( M, N ) / 2 + 1
END IF
IOFF = ( IZERO-1 )*LDA
IF( IMAT.LT.7 ) THEN
DO 20 I = 1, M
A( IOFF+I ) = ZERO
20 CONTINUE
ELSE
CALL SLASET( 'Full', M, N-IZERO+1, ZERO, ZERO,
$ A( IOFF+1 ), LDA )
END IF
ELSE
IZERO = 0
END IF
*
* These lines, if used in place of the calls in the DO 60
* loop, cause the code to bomb on a Sun SPARCstation.
*
* ANORMO = SLANGE( 'O', M, N, A, LDA, RWORK )
* ANORMI = SLANGE( 'I', M, N, A, LDA, RWORK )
*
* Do for each blocksize in NBVAL
*
DO 90 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
*
* Compute the LU factorization of the matrix.
*
CALL SLACPY( 'Full', M, N, A, LDA, AFAC, LDA )
SRNAMT = 'SGETRF'
CALL SGETRF( M, N, AFAC, LDA, IWORK, INFO )
*
* Check error code from SGETRF.
*
IF( INFO.NE.IZERO )
$ CALL ALAERH( PATH, 'SGETRF', INFO, IZERO, ' ', M,
$ N, -1, -1, NB, IMAT, NFAIL, NERRS,
$ NOUT )
TRFCON = .FALSE.
*
*+ TEST 1
* Reconstruct matrix from factors and compute residual.
*
CALL SLACPY( 'Full', M, N, AFAC, LDA, AINV, LDA )
CALL SGET01( M, N, A, LDA, AINV, LDA, IWORK, RWORK,
$ RESULT( 1 ) )
NT = 1
*
*+ TEST 2
* Form the inverse if the factorization was successful
* and compute the residual.
*
IF( M.EQ.N .AND. INFO.EQ.0 ) THEN
CALL SLACPY( 'Full', N, N, AFAC, LDA, AINV, LDA )
SRNAMT = 'SGETRI'
NRHS = NSVAL( 1 )
LWORK = NMAX*MAX( 3, NRHS )
CALL SGETRI( N, AINV, LDA, IWORK, WORK, LWORK,
$ INFO )
*
* Check error code from SGETRI.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SGETRI', INFO, 0, ' ', N, N,
$ -1, -1, NB, IMAT, NFAIL, NERRS,
$ NOUT )
*
* Compute the residual for the matrix times its
* inverse. Also compute the 1-norm condition number
* of A.
*
CALL SGET03( N, A, LDA, AINV, LDA, WORK, LDA,
$ RWORK, RCONDO, RESULT( 2 ) )
ANORMO = SLANGE( 'O', M, N, A, LDA, RWORK )
*
* Compute the infinity-norm condition number of A.
*
ANORMI = SLANGE( 'I', M, N, A, LDA, RWORK )
AINVNM = SLANGE( 'I', N, N, AINV, LDA, RWORK )
IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDI = ONE
ELSE
RCONDI = ( ONE / ANORMI ) / AINVNM
END IF
NT = 2
ELSE
*
* Do only the condition estimate if INFO > 0.
*
TRFCON = .TRUE.
ANORMO = SLANGE( 'O', M, N, A, LDA, RWORK )
ANORMI = SLANGE( 'I', M, N, A, LDA, RWORK )
RCONDO = ZERO
RCONDI = ZERO
END IF
*
* Print information about the tests so far that did not
* pass the threshold.
*
DO 30 K = 1, NT
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )M, N, NB, IMAT, K,
$ RESULT( K )
NFAIL = NFAIL + 1
END IF
30 CONTINUE
NRUN = NRUN + NT
*
* Skip the remaining tests if this is not the first
* block size or if M .ne. N. Skip the solve tests if
* the matrix is singular.
*
IF( INB.GT.1 .OR. M.NE.N )
$ GO TO 90
IF( TRFCON )
$ GO TO 70
*
DO 60 IRHS = 1, NNS
NRHS = NSVAL( IRHS )
XTYPE = 'N'
*
DO 50 ITRAN = 1, NTRAN
TRANS = TRANSS( ITRAN )
IF( ITRAN.EQ.1 ) THEN
RCONDC = RCONDO
ELSE
RCONDC = RCONDI
END IF
*
*+ TEST 3
* Solve and compute residual for A * X = B.
*
SRNAMT = 'SLARHS'
CALL SLARHS( PATH, XTYPE, ' ', TRANS, N, N, KL,
$ KU, NRHS, A, LDA, XACT, LDA, B,
$ LDA, ISEED, INFO )
XTYPE = 'C'
*
CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
SRNAMT = 'SGETRS'
CALL SGETRS( TRANS, N, NRHS, AFAC, LDA, IWORK,
$ X, LDA, INFO )
*
* Check error code from SGETRS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SGETRS', INFO, 0, TRANS,
$ N, N, -1, -1, NRHS, IMAT, NFAIL,
$ NERRS, NOUT )
*
CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK,
$ LDA )
CALL SGET02( TRANS, N, N, NRHS, A, LDA, X, LDA,
$ WORK, LDA, RWORK, RESULT( 3 ) )
*
*+ TEST 4
* Check solution from generated exact solution.
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 4 ) )
*
*+ TESTS 5, 6, and 7
* Use iterative refinement to improve the
* solution.
*
SRNAMT = 'SGERFS'
CALL SGERFS( TRANS, N, NRHS, A, LDA, AFAC, LDA,
$ IWORK, B, LDA, X, LDA, RWORK,
$ RWORK( NRHS+1 ), WORK,
$ IWORK( N+1 ), INFO )
*
* Check error code from SGERFS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SGERFS', INFO, 0, TRANS,
$ N, N, -1, -1, NRHS, IMAT, NFAIL,
$ NERRS, NOUT )
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 5 ) )
CALL SGET07( TRANS, N, NRHS, A, LDA, B, LDA, X,
$ LDA, XACT, LDA, RWORK,
$ RWORK( NRHS+1 ), RESULT( 6 ) )
*
* Print information about the tests that did not
* pass the threshold.
*
DO 40 K = 3, 7
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )TRANS, N, NRHS,
$ IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
40 CONTINUE
NRUN = NRUN + 5
50 CONTINUE
60 CONTINUE
*
*+ TEST 8
* Get an estimate of RCOND = 1/CNDNUM.
*
70 CONTINUE
DO 80 ITRAN = 1, 2
IF( ITRAN.EQ.1 ) THEN
ANORM = ANORMO
RCONDC = RCONDO
NORM = 'O'
ELSE
ANORM = ANORMI
RCONDC = RCONDI
NORM = 'I'
END IF
SRNAMT = 'SGECON'
CALL SGECON( NORM, N, AFAC, LDA, ANORM, RCOND,
$ WORK, IWORK( N+1 ), INFO )
*
* Check error code from SGECON.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SGECON', INFO, 0, NORM, N,
$ N, -1, -1, -1, IMAT, NFAIL, NERRS,
$ NOUT )
*
* This line is needed on a Sun SPARCstation.
*
DUMMY = RCOND
*
RESULT( 8 ) = SGET06( RCOND, RCONDC )
*
* Print information about the tests that did not pass
* the threshold.
*
IF( RESULT( 8 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9997 )NORM, N, IMAT, 8,
$ RESULT( 8 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
80 CONTINUE
90 CONTINUE
100 CONTINUE
110 CONTINUE
120 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' M = ', I5, ', N =', I5, ', NB =', I4, ', type ', I2,
$ ', test(', I2, ') =', G12.5 )
9998 FORMAT( ' TRANS=''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
$ I2, ', test(', I2, ') =', G12.5 )
9997 FORMAT( ' NORM =''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
$ ', test(', I2, ') =', G12.5 )
RETURN
*
* End of SCHKGE
*
END
SUBROUTINE SCHKGT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
$ A, AF, B, X, XACT, WORK, RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NN, NNS, NOUT
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
REAL A( * ), AF( * ), B( * ), RWORK( * ), WORK( * ),
$ X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* SCHKGT tests SGTTRF, -TRS, -RFS, and -CON
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* A (workspace) REAL array, dimension (NMAX*4)
*
* AF (workspace) REAL array, dimension (NMAX*4)
*
* B (workspace) REAL array, dimension (NMAX*NSMAX)
* where NSMAX is the largest entry in NSVAL.
*
* X (workspace) REAL array, dimension (NMAX*NSMAX)
*
* XACT (workspace) REAL array, dimension (NMAX*NSMAX)
*
* WORK (workspace) REAL array, dimension
* (NMAX*max(3,NSMAX))
*
* RWORK (workspace) REAL array, dimension
* (max(NMAX,2*NSMAX))
*
* IWORK (workspace) INTEGER array, dimension (2*NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
INTEGER NTYPES
PARAMETER ( NTYPES = 12 )
INTEGER NTESTS
PARAMETER ( NTESTS = 7 )
* ..
* .. Local Scalars ..
LOGICAL TRFCON, ZEROT
CHARACTER DIST, NORM, TRANS, TYPE
CHARACTER*3 PATH
INTEGER I, IMAT, IN, INFO, IRHS, ITRAN, IX, IZERO, J,
$ K, KL, KOFF, KU, LDA, M, MODE, N, NERRS, NFAIL,
$ NIMAT, NRHS, NRUN
REAL AINVNM, ANORM, COND, RCOND, RCONDC, RCONDI,
$ RCONDO
* ..
* .. Local Arrays ..
CHARACTER TRANSS( 3 )
INTEGER ISEED( 4 ), ISEEDY( 4 )
REAL RESULT( NTESTS ), Z( 3 )
* ..
* .. External Functions ..
REAL SASUM, SGET06, SLANGT
EXTERNAL SASUM, SGET06, SLANGT
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, SCOPY, SERRGE, SGET04,
$ SGTCON, SGTRFS, SGTT01, SGTT02, SGTT05, SGTTRF,
$ SGTTRS, SLACPY, SLAGTM, SLARNV, SLATB4, SLATMS,
$ SSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 0, 0, 0, 1 / , TRANSS / 'N', 'T',
$ 'C' /
* ..
* .. Executable Statements ..
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'GT'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL SERRGE( PATH, NOUT )
INFOT = 0
*
DO 110 IN = 1, NN
*
* Do for each value of N in NVAL.
*
N = NVAL( IN )
M = MAX( N-1, 0 )
LDA = MAX( 1, N )
NIMAT = NTYPES
IF( N.LE.0 )
$ NIMAT = 1
*
DO 100 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 100
*
* Set up parameters with SLATB4.
*
CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ COND, DIST )
*
ZEROT = IMAT.GE.8 .AND. IMAT.LE.10
IF( IMAT.LE.6 ) THEN
*
* Types 1-6: generate matrices of known condition number.
*
KOFF = MAX( 2-KU, 3-MAX( 1, N ) )
SRNAMT = 'SLATMS'
CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, COND,
$ ANORM, KL, KU, 'Z', AF( KOFF ), 3, WORK,
$ INFO )
*
* Check the error code from SLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', N, N, KL,
$ KU, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 100
END IF
IZERO = 0
*
IF( N.GT.1 ) THEN
CALL SCOPY( N-1, AF( 4 ), 3, A, 1 )
CALL SCOPY( N-1, AF( 3 ), 3, A( N+M+1 ), 1 )
END IF
CALL SCOPY( N, AF( 2 ), 3, A( M+1 ), 1 )
ELSE
*
* Types 7-12: generate tridiagonal matrices with
* unknown condition numbers.
*
IF( .NOT.ZEROT .OR. .NOT.DOTYPE( 7 ) ) THEN
*
* Generate a matrix with elements from [-1,1].
*
CALL SLARNV( 2, ISEED, N+2*M, A )
IF( ANORM.NE.ONE )
$ CALL SSCAL( N+2*M, ANORM, A, 1 )
ELSE IF( IZERO.GT.0 ) THEN
*
* Reuse the last matrix by copying back the zeroed out
* elements.
*
IF( IZERO.EQ.1 ) THEN
A( N ) = Z( 2 )
IF( N.GT.1 )
$ A( 1 ) = Z( 3 )
ELSE IF( IZERO.EQ.N ) THEN
A( 3*N-2 ) = Z( 1 )
A( 2*N-1 ) = Z( 2 )
ELSE
A( 2*N-2+IZERO ) = Z( 1 )
A( N-1+IZERO ) = Z( 2 )
A( IZERO ) = Z( 3 )
END IF
END IF
*
* If IMAT > 7, set one column of the matrix to 0.
*
IF( .NOT.ZEROT ) THEN
IZERO = 0
ELSE IF( IMAT.EQ.8 ) THEN
IZERO = 1
Z( 2 ) = A( N )
A( N ) = ZERO
IF( N.GT.1 ) THEN
Z( 3 ) = A( 1 )
A( 1 ) = ZERO
END IF
ELSE IF( IMAT.EQ.9 ) THEN
IZERO = N
Z( 1 ) = A( 3*N-2 )
Z( 2 ) = A( 2*N-1 )
A( 3*N-2 ) = ZERO
A( 2*N-1 ) = ZERO
ELSE
IZERO = ( N+1 ) / 2
DO 20 I = IZERO, N - 1
A( 2*N-2+I ) = ZERO
A( N-1+I ) = ZERO
A( I ) = ZERO
20 CONTINUE
A( 3*N-2 ) = ZERO
A( 2*N-1 ) = ZERO
END IF
END IF
*
*+ TEST 1
* Factor A as L*U and compute the ratio
* norm(L*U - A) / (n * norm(A) * EPS )
*
CALL SCOPY( N+2*M, A, 1, AF, 1 )
SRNAMT = 'SGTTRF'
CALL SGTTRF( N, AF, AF( M+1 ), AF( N+M+1 ), AF( N+2*M+1 ),
$ IWORK, INFO )
*
* Check error code from SGTTRF.
*
IF( INFO.NE.IZERO )
$ CALL ALAERH( PATH, 'SGTTRF', INFO, IZERO, ' ', N, N, 1,
$ 1, -1, IMAT, NFAIL, NERRS, NOUT )
TRFCON = INFO.NE.0
*
CALL SGTT01( N, A, A( M+1 ), A( N+M+1 ), AF, AF( M+1 ),
$ AF( N+M+1 ), AF( N+2*M+1 ), IWORK, WORK, LDA,
$ RWORK, RESULT( 1 ) )
*
* Print the test ratio if it is .GE. THRESH.
*
IF( RESULT( 1 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )N, IMAT, 1, RESULT( 1 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
*
DO 50 ITRAN = 1, 2
TRANS = TRANSS( ITRAN )
IF( ITRAN.EQ.1 ) THEN
NORM = 'O'
ELSE
NORM = 'I'
END IF
ANORM = SLANGT( NORM, N, A, A( M+1 ), A( N+M+1 ) )
*
IF( .NOT.TRFCON ) THEN
*
* Use SGTTRS to solve for one column at a time of inv(A)
* or inv(A^T), computing the maximum column sum as we
* go.
*
AINVNM = ZERO
DO 40 I = 1, N
DO 30 J = 1, N
X( J ) = ZERO
30 CONTINUE
X( I ) = ONE
CALL SGTTRS( TRANS, N, 1, AF, AF( M+1 ),
$ AF( N+M+1 ), AF( N+2*M+1 ), IWORK, X,
$ LDA, INFO )
AINVNM = MAX( AINVNM, SASUM( N, X, 1 ) )
40 CONTINUE
*
* Compute RCONDC = 1 / (norm(A) * norm(inv(A))
*
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDC = ONE
ELSE
RCONDC = ( ONE / ANORM ) / AINVNM
END IF
IF( ITRAN.EQ.1 ) THEN
RCONDO = RCONDC
ELSE
RCONDI = RCONDC
END IF
ELSE
RCONDC = ZERO
END IF
*
*+ TEST 7
* Estimate the reciprocal of the condition number of the
* matrix.
*
SRNAMT = 'SGTCON'
CALL SGTCON( NORM, N, AF, AF( M+1 ), AF( N+M+1 ),
$ AF( N+2*M+1 ), IWORK, ANORM, RCOND, WORK,
$ IWORK( N+1 ), INFO )
*
* Check error code from SGTCON.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SGTCON', INFO, 0, NORM, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
RESULT( 7 ) = SGET06( RCOND, RCONDC )
*
* Print the test ratio if it is .GE. THRESH.
*
IF( RESULT( 7 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9997 )NORM, N, IMAT, 7,
$ RESULT( 7 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
50 CONTINUE
*
* Skip the remaining tests if the matrix is singular.
*
IF( TRFCON )
$ GO TO 100
*
DO 90 IRHS = 1, NNS
NRHS = NSVAL( IRHS )
*
* Generate NRHS random solution vectors.
*
IX = 1
DO 60 J = 1, NRHS
CALL SLARNV( 2, ISEED, N, XACT( IX ) )
IX = IX + LDA
60 CONTINUE
*
DO 80 ITRAN = 1, 3
TRANS = TRANSS( ITRAN )
IF( ITRAN.EQ.1 ) THEN
RCONDC = RCONDO
ELSE
RCONDC = RCONDI
END IF
*
* Set the right hand side.
*
CALL SLAGTM( TRANS, N, NRHS, ONE, A, A( M+1 ),
$ A( N+M+1 ), XACT, LDA, ZERO, B, LDA )
*
*+ TEST 2
* Solve op(A) * X = B and compute the residual.
*
CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
SRNAMT = 'SGTTRS'
CALL SGTTRS( TRANS, N, NRHS, AF, AF( M+1 ),
$ AF( N+M+1 ), AF( N+2*M+1 ), IWORK, X,
$ LDA, INFO )
*
* Check error code from SGTTRS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SGTTRS', INFO, 0, TRANS, N, N,
$ -1, -1, NRHS, IMAT, NFAIL, NERRS,
$ NOUT )
*
CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
CALL SGTT02( TRANS, N, NRHS, A, A( M+1 ), A( N+M+1 ),
$ X, LDA, WORK, LDA, RWORK, RESULT( 2 ) )
*
*+ TEST 3
* Check solution from generated exact solution.
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
*
*+ TESTS 4, 5, and 6
* Use iterative refinement to improve the solution.
*
SRNAMT = 'SGTRFS'
CALL SGTRFS( TRANS, N, NRHS, A, A( M+1 ), A( N+M+1 ),
$ AF, AF( M+1 ), AF( N+M+1 ),
$ AF( N+2*M+1 ), IWORK, B, LDA, X, LDA,
$ RWORK, RWORK( NRHS+1 ), WORK,
$ IWORK( N+1 ), INFO )
*
* Check error code from SGTRFS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SGTRFS', INFO, 0, TRANS, N, N,
$ -1, -1, NRHS, IMAT, NFAIL, NERRS,
$ NOUT )
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 4 ) )
CALL SGTT05( TRANS, N, NRHS, A, A( M+1 ), A( N+M+1 ),
$ B, LDA, X, LDA, XACT, LDA, RWORK,
$ RWORK( NRHS+1 ), RESULT( 5 ) )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 70 K = 2, 6
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )TRANS, N, NRHS, IMAT,
$ K, RESULT( K )
NFAIL = NFAIL + 1
END IF
70 CONTINUE
NRUN = NRUN + 5
80 CONTINUE
90 CONTINUE
*
100 CONTINUE
110 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( 12X, 'N =', I5, ',', 10X, ' type ', I2, ', test(', I2,
$ ') = ', G12.5 )
9998 FORMAT( ' TRANS=''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
$ I2, ', test(', I2, ') = ', G12.5 )
9997 FORMAT( ' NORM =''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
$ ', test(', I2, ') = ', G12.5 )
RETURN
*
* End of SCHKGT
*
END
SUBROUTINE SCHKLQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
$ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AL, AC,
$ B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NM, NMAX, NN, NNB, NOUT, NRHS
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
$ NXVAL( * )
REAL A( * ), AC( * ), AF( * ), AL( * ), AQ( * ),
$ B( * ), RWORK( * ), TAU( * ), WORK( * ),
$ X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* SCHKLQ tests SGELQF, SORGLQ and SORMLQ.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* NRHS (input) INTEGER
* The number of right hand side vectors to be generated for
* each linear system.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for M or N, used in dimensioning
* the work arrays.
*
* A (workspace) REAL array, dimension (NMAX*NMAX)
*
* AF (workspace) REAL array, dimension (NMAX*NMAX)
*
* AQ (workspace) REAL array, dimension (NMAX*NMAX)
*
* AL (workspace) REAL array, dimension (NMAX*NMAX)
*
* AC (workspace) REAL array, dimension (NMAX*NMAX)
*
* B (workspace) REAL array, dimension (NMAX*NRHS)
*
* X (workspace) REAL array, dimension (NMAX*NRHS)
*
* XACT (workspace) REAL array, dimension (NMAX*NRHS)
*
* TAU (workspace) REAL array, dimension (NMAX)
*
* WORK (workspace) REAL array, dimension (NMAX*NMAX)
*
* RWORK (workspace) REAL array, dimension (NMAX)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTESTS
PARAMETER ( NTESTS = 7 )
INTEGER NTYPES
PARAMETER ( NTYPES = 8 )
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
CHARACTER DIST, TYPE
CHARACTER*3 PATH
INTEGER I, IK, IM, IMAT, IN, INB, INFO, K, KL, KU, LDA,
$ LWORK, M, MINMN, MODE, N, NB, NERRS, NFAIL, NK,
$ NRUN, NT, NX
REAL ANORM, CNDNUM
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 )
REAL RESULT( NTESTS )
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, SERRLQ, SGELQS, SGET02,
$ SLACPY, SLARHS, SLATB4, SLATMS, SLQT01, SLQT02,
$ SLQT03, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'LQ'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL SERRLQ( PATH, NOUT )
INFOT = 0
CALL XLAENV( 2, 2 )
*
LDA = NMAX
LWORK = NMAX*MAX( NMAX, NRHS )
*
* Do for each value of M in MVAL.
*
DO 70 IM = 1, NM
M = MVAL( IM )
*
* Do for each value of N in NVAL.
*
DO 60 IN = 1, NN
N = NVAL( IN )
MINMN = MIN( M, N )
DO 50 IMAT = 1, NTYPES
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 50
*
* Set up parameters with SLATB4 and generate a test matrix
* with SLATMS.
*
CALL SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
*
SRNAMT = 'SLATMS'
CALL SLATMS( M, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, 'No packing', A, LDA,
$ WORK, INFO )
*
* Check error code from SLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', M, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 50
END IF
*
* Set some values for K: the first value must be MINMN,
* corresponding to the call of SLQT01; other values are
* used in the calls of SLQT02, and must not exceed MINMN.
*
KVAL( 1 ) = MINMN
KVAL( 2 ) = 0
KVAL( 3 ) = 1
KVAL( 4 ) = MINMN / 2
IF( MINMN.EQ.0 ) THEN
NK = 1
ELSE IF( MINMN.EQ.1 ) THEN
NK = 2
ELSE IF( MINMN.LE.3 ) THEN
NK = 3
ELSE
NK = 4
END IF
*
* Do for each value of K in KVAL
*
DO 40 IK = 1, NK
K = KVAL( IK )
*
* Do for each pair of values (NB,NX) in NBVAL and NXVAL.
*
DO 30 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
NT = 2
IF( IK.EQ.1 ) THEN
*
* Test SGELQF
*
CALL SLQT01( M, N, A, AF, AQ, AL, LDA, TAU,
$ WORK, LWORK, RWORK, RESULT( 1 ) )
ELSE IF( M.LE.N ) THEN
*
* Test SORGLQ, using factorization
* returned by SLQT01
*
CALL SLQT02( M, N, K, A, AF, AQ, AL, LDA, TAU,
$ WORK, LWORK, RWORK, RESULT( 1 ) )
ELSE
RESULT( 1 ) = ZERO
RESULT( 2 ) = ZERO
END IF
IF( M.GE.K ) THEN
*
* Test SORMLQ, using factorization returned
* by SLQT01
*
CALL SLQT03( M, N, K, AF, AC, AL, AQ, LDA, TAU,
$ WORK, LWORK, RWORK, RESULT( 3 ) )
NT = NT + 4
*
* If M>=N and K=N, call SGELQS to solve a system
* with NRHS right hand sides and compute the
* residual.
*
IF( K.EQ.M .AND. INB.EQ.1 ) THEN
*
* Generate a solution and set the right
* hand side.
*
SRNAMT = 'SLARHS'
CALL SLARHS( PATH, 'New', 'Full',
$ 'No transpose', M, N, 0, 0,
$ NRHS, A, LDA, XACT, LDA, B, LDA,
$ ISEED, INFO )
*
CALL SLACPY( 'Full', M, NRHS, B, LDA, X,
$ LDA )
SRNAMT = 'SGELQS'
CALL SGELQS( M, N, NRHS, AF, LDA, TAU, X,
$ LDA, WORK, LWORK, INFO )
*
* Check error code from SGELQS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SGELQS', INFO, 0, ' ',
$ M, N, NRHS, -1, NB, IMAT,
$ NFAIL, NERRS, NOUT )
*
CALL SGET02( 'No transpose', M, N, NRHS, A,
$ LDA, X, LDA, B, LDA, RWORK,
$ RESULT( 7 ) )
NT = NT + 1
ELSE
RESULT( 7 ) = ZERO
END IF
ELSE
RESULT( 3 ) = ZERO
RESULT( 4 ) = ZERO
RESULT( 5 ) = ZERO
RESULT( 6 ) = ZERO
END IF
*
* Print information about the tests that did not
* pass the threshold.
*
DO 20 I = 1, NT
IF( RESULT( I ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )M, N, K, NB, NX,
$ IMAT, I, RESULT( I )
NFAIL = NFAIL + 1
END IF
20 CONTINUE
NRUN = NRUN + NT
30 CONTINUE
40 CONTINUE
50 CONTINUE
60 CONTINUE
70 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' M=', I5, ', N=', I5, ', K=', I5, ', NB=', I4, ', NX=',
$ I5, ', type ', I2, ', test(', I2, ')=', G12.5 )
RETURN
*
* End of SCHKLQ
*
END
SUBROUTINE SCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
$ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
$ XACT, WORK, RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NMAX, NN, NNB, NNS, NOUT
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
REAL A( * ), AFAC( * ), AINV( * ), B( * ),
$ RWORK( * ), WORK( * ), X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* SCHKPB tests SPBTRF, -TRS, -RFS, and -CON.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* NNB (input) INTEGER
* The number of values of NB contained in the vector NBVAL.
*
* NBVAL (input) INTEGER array, dimension (NBVAL)
* The values of the blocksize NB.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for N, used in dimensioning the
* work arrays.
*
* A (workspace) REAL array, dimension (NMAX*NMAX)
*
* AFAC (workspace) REAL array, dimension (NMAX*NMAX)
*
* AINV (workspace) REAL array, dimension (NMAX*NMAX)
*
* B (workspace) REAL array, dimension (NMAX*NSMAX)
* where NSMAX is the largest entry in NSVAL.
*
* X (workspace) REAL array, dimension (NMAX*NSMAX)
*
* XACT (workspace) REAL array, dimension (NMAX*NSMAX)
*
* WORK (workspace) REAL array, dimension
* (NMAX*max(3,NSMAX))
*
* RWORK (workspace) REAL array, dimension
* (max(NMAX,2*NSMAX))
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
INTEGER NTYPES, NTESTS
PARAMETER ( NTYPES = 8, NTESTS = 7 )
INTEGER NBW
PARAMETER ( NBW = 4 )
* ..
* .. Local Scalars ..
LOGICAL ZEROT
CHARACTER DIST, PACKIT, TYPE, UPLO, XTYPE
CHARACTER*3 PATH
INTEGER I, I1, I2, IKD, IMAT, IN, INB, INFO, IOFF,
$ IRHS, IUPLO, IW, IZERO, K, KD, KL, KOFF, KU,
$ LDA, LDAB, MODE, N, NB, NERRS, NFAIL, NIMAT,
$ NKD, NRHS, NRUN
REAL AINVNM, ANORM, CNDNUM, RCOND, RCONDC
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 ), ISEEDY( 4 ), KDVAL( NBW )
REAL RESULT( NTESTS )
* ..
* .. External Functions ..
REAL SGET06, SLANGE, SLANSB
EXTERNAL SGET06, SLANGE, SLANSB
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, SCOPY, SERRPO, SGET04,
$ SLACPY, SLARHS, SLASET, SLATB4, SLATMS, SPBCON,
$ SPBRFS, SPBT01, SPBT02, SPBT05, SPBTRF, SPBTRS,
$ SSWAP, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'PB'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL SERRPO( PATH, NOUT )
INFOT = 0
CALL XLAENV( 2, 2 )
KDVAL( 1 ) = 0
*
* Do for each value of N in NVAL
*
DO 90 IN = 1, NN
N = NVAL( IN )
LDA = MAX( N, 1 )
XTYPE = 'N'
*
* Set limits on the number of loop iterations.
*
NKD = MAX( 1, MIN( N, 4 ) )
NIMAT = NTYPES
IF( N.EQ.0 )
$ NIMAT = 1
*
KDVAL( 2 ) = N + ( N+1 ) / 4
KDVAL( 3 ) = ( 3*N-1 ) / 4
KDVAL( 4 ) = ( N+1 ) / 4
*
DO 80 IKD = 1, NKD
*
* Do for KD = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This order
* makes it easier to skip redundant values for small values
* of N.
*
KD = KDVAL( IKD )
LDAB = KD + 1
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 70 IUPLO = 1, 2
KOFF = 1
IF( IUPLO.EQ.1 ) THEN
UPLO = 'U'
KOFF = MAX( 1, KD+2-N )
PACKIT = 'Q'
ELSE
UPLO = 'L'
PACKIT = 'B'
END IF
*
DO 60 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 60
*
* Skip types 2, 3, or 4 if the matrix size is too small.
*
ZEROT = IMAT.GE.2 .AND. IMAT.LE.4
IF( ZEROT .AND. N.LT.IMAT-1 )
$ GO TO 60
*
IF( .NOT.ZEROT .OR. .NOT.DOTYPE( 1 ) ) THEN
*
* Set up parameters with SLATB4 and generate a test
* matrix with SLATMS.
*
CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM,
$ MODE, CNDNUM, DIST )
*
SRNAMT = 'SLATMS'
CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KD, KD, PACKIT,
$ A( KOFF ), LDAB, WORK, INFO )
*
* Check error code from SLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N,
$ N, KD, KD, -1, IMAT, NFAIL, NERRS,
$ NOUT )
GO TO 60
END IF
ELSE IF( IZERO.GT.0 ) THEN
*
* Use the same matrix for types 3 and 4 as for type
* 2 by copying back the zeroed out column,
*
IW = 2*LDA + 1
IF( IUPLO.EQ.1 ) THEN
IOFF = ( IZERO-1 )*LDAB + KD + 1
CALL SCOPY( IZERO-I1, WORK( IW ), 1,
$ A( IOFF-IZERO+I1 ), 1 )
IW = IW + IZERO - I1
CALL SCOPY( I2-IZERO+1, WORK( IW ), 1,
$ A( IOFF ), MAX( LDAB-1, 1 ) )
ELSE
IOFF = ( I1-1 )*LDAB + 1
CALL SCOPY( IZERO-I1, WORK( IW ), 1,
$ A( IOFF+IZERO-I1 ),
$ MAX( LDAB-1, 1 ) )
IOFF = ( IZERO-1 )*LDAB + 1
IW = IW + IZERO - I1
CALL SCOPY( I2-IZERO+1, WORK( IW ), 1,
$ A( IOFF ), 1 )
END IF
END IF
*
* For types 2-4, zero one row and column of the matrix
* to test that INFO is returned correctly.
*
IZERO = 0
IF( ZEROT ) THEN
IF( IMAT.EQ.2 ) THEN
IZERO = 1
ELSE IF( IMAT.EQ.3 ) THEN
IZERO = N
ELSE
IZERO = N / 2 + 1
END IF
*
* Save the zeroed out row and column in WORK(*,3)
*
IW = 2*LDA
DO 20 I = 1, MIN( 2*KD+1, N )
WORK( IW+I ) = ZERO
20 CONTINUE
IW = IW + 1
I1 = MAX( IZERO-KD, 1 )
I2 = MIN( IZERO+KD, N )
*
IF( IUPLO.EQ.1 ) THEN
IOFF = ( IZERO-1 )*LDAB + KD + 1
CALL SSWAP( IZERO-I1, A( IOFF-IZERO+I1 ), 1,
$ WORK( IW ), 1 )
IW = IW + IZERO - I1
CALL SSWAP( I2-IZERO+1, A( IOFF ),
$ MAX( LDAB-1, 1 ), WORK( IW ), 1 )
ELSE
IOFF = ( I1-1 )*LDAB + 1
CALL SSWAP( IZERO-I1, A( IOFF+IZERO-I1 ),
$ MAX( LDAB-1, 1 ), WORK( IW ), 1 )
IOFF = ( IZERO-1 )*LDAB + 1
IW = IW + IZERO - I1
CALL SSWAP( I2-IZERO+1, A( IOFF ), 1,
$ WORK( IW ), 1 )
END IF
END IF
*
* Do for each value of NB in NBVAL
*
DO 50 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
*
* Compute the L*L' or U'*U factorization of the band
* matrix.
*
CALL SLACPY( 'Full', KD+1, N, A, LDAB, AFAC, LDAB )
SRNAMT = 'SPBTRF'
CALL SPBTRF( UPLO, N, KD, AFAC, LDAB, INFO )
*
* Check error code from SPBTRF.
*
IF( INFO.NE.IZERO ) THEN
CALL ALAERH( PATH, 'SPBTRF', INFO, IZERO, UPLO,
$ N, N, KD, KD, NB, IMAT, NFAIL,
$ NERRS, NOUT )
GO TO 50
END IF
*
* Skip the tests if INFO is not 0.
*
IF( INFO.NE.0 )
$ GO TO 50
*
*+ TEST 1
* Reconstruct matrix from factors and compute
* residual.
*
CALL SLACPY( 'Full', KD+1, N, AFAC, LDAB, AINV,
$ LDAB )
CALL SPBT01( UPLO, N, KD, A, LDAB, AINV, LDAB,
$ RWORK, RESULT( 1 ) )
*
* Print the test ratio if it is .GE. THRESH.
*
IF( RESULT( 1 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )UPLO, N, KD, NB, IMAT,
$ 1, RESULT( 1 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
*
* Only do other tests if this is the first blocksize.
*
IF( INB.GT.1 )
$ GO TO 50
*
* Form the inverse of A so we can get a good estimate
* of RCONDC = 1/(norm(A) * norm(inv(A))).
*
CALL SLASET( 'Full', N, N, ZERO, ONE, AINV, LDA )
SRNAMT = 'SPBTRS'
CALL SPBTRS( UPLO, N, KD, N, AFAC, LDAB, AINV, LDA,
$ INFO )
*
* Compute RCONDC = 1/(norm(A) * norm(inv(A))).
*
ANORM = SLANSB( '1', UPLO, N, KD, A, LDAB, RWORK )
AINVNM = SLANGE( '1', N, N, AINV, LDA, RWORK )
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDC = ONE
ELSE
RCONDC = ( ONE / ANORM ) / AINVNM
END IF
*
DO 40 IRHS = 1, NNS
NRHS = NSVAL( IRHS )
*
*+ TEST 2
* Solve and compute residual for A * X = B.
*
SRNAMT = 'SLARHS'
CALL SLARHS( PATH, XTYPE, UPLO, ' ', N, N, KD,
$ KD, NRHS, A, LDAB, XACT, LDA, B,
$ LDA, ISEED, INFO )
CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
SRNAMT = 'SPBTRS'
CALL SPBTRS( UPLO, N, KD, NRHS, AFAC, LDAB, X,
$ LDA, INFO )
*
* Check error code from SPBTRS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SPBTRS', INFO, 0, UPLO,
$ N, N, KD, KD, NRHS, IMAT, NFAIL,
$ NERRS, NOUT )
*
CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK,
$ LDA )
CALL SPBT02( UPLO, N, KD, NRHS, A, LDAB, X, LDA,
$ WORK, LDA, RWORK, RESULT( 2 ) )
*
*+ TEST 3
* Check solution from generated exact solution.
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
*
*+ TESTS 4, 5, and 6
* Use iterative refinement to improve the solution.
*
SRNAMT = 'SPBRFS'
CALL SPBRFS( UPLO, N, KD, NRHS, A, LDAB, AFAC,
$ LDAB, B, LDA, X, LDA, RWORK,
$ RWORK( NRHS+1 ), WORK, IWORK,
$ INFO )
*
* Check error code from SPBRFS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SPBRFS', INFO, 0, UPLO,
$ N, N, KD, KD, NRHS, IMAT, NFAIL,
$ NERRS, NOUT )
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 4 ) )
CALL SPBT05( UPLO, N, KD, NRHS, A, LDAB, B, LDA,
$ X, LDA, XACT, LDA, RWORK,
$ RWORK( NRHS+1 ), RESULT( 5 ) )
*
* Print information about the tests that did not
* pass the threshold.
*
DO 30 K = 2, 6
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )UPLO, N, KD,
$ NRHS, IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
30 CONTINUE
NRUN = NRUN + 5
40 CONTINUE
*
*+ TEST 7
* Get an estimate of RCOND = 1/CNDNUM.
*
SRNAMT = 'SPBCON'
CALL SPBCON( UPLO, N, KD, AFAC, LDAB, ANORM, RCOND,
$ WORK, IWORK, INFO )
*
* Check error code from SPBCON.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SPBCON', INFO, 0, UPLO, N,
$ N, KD, KD, -1, IMAT, NFAIL, NERRS,
$ NOUT )
*
RESULT( 7 ) = SGET06( RCOND, RCONDC )
*
* Print the test ratio if it is .GE. THRESH.
*
IF( RESULT( 7 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9997 )UPLO, N, KD, IMAT, 7,
$ RESULT( 7 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
50 CONTINUE
60 CONTINUE
70 CONTINUE
80 CONTINUE
90 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' UPLO=''', A1, ''', N=', I5, ', KD=', I5, ', NB=', I4,
$ ', type ', I2, ', test ', I2, ', ratio= ', G12.5 )
9998 FORMAT( ' UPLO=''', A1, ''', N=', I5, ', KD=', I5, ', NRHS=', I3,
$ ', type ', I2, ', test(', I2, ') = ', G12.5 )
9997 FORMAT( ' UPLO=''', A1, ''', N=', I5, ', KD=', I5, ',', 10X,
$ ' type ', I2, ', test(', I2, ') = ', G12.5 )
RETURN
*
* End of SCHKPB
*
END
SUBROUTINE SCHKPO( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
$ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
$ XACT, WORK, RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NMAX, NN, NNB, NNS, NOUT
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
REAL A( * ), AFAC( * ), AINV( * ), B( * ),
$ RWORK( * ), WORK( * ), X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* SCHKPO tests SPOTRF, -TRI, -TRS, -RFS, and -CON
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* NNB (input) INTEGER
* The number of values of NB contained in the vector NBVAL.
*
* NBVAL (input) INTEGER array, dimension (NBVAL)
* The values of the blocksize NB.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for N, used in dimensioning the
* work arrays.
*
* A (workspace) REAL array, dimension (NMAX*NMAX)
*
* AFAC (workspace) REAL array, dimension (NMAX*NMAX)
*
* AINV (workspace) REAL array, dimension (NMAX*NMAX)
*
* B (workspace) REAL array, dimension (NMAX*NSMAX)
* where NSMAX is the largest entry in NSVAL.
*
* X (workspace) REAL array, dimension (NMAX*NSMAX)
*
* XACT (workspace) REAL array, dimension (NMAX*NSMAX)
*
* WORK (workspace) REAL array, dimension
* (NMAX*max(3,NSMAX))
*
* RWORK (workspace) REAL array, dimension
* (max(NMAX,2*NSMAX))
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
INTEGER NTYPES
PARAMETER ( NTYPES = 9 )
INTEGER NTESTS
PARAMETER ( NTESTS = 8 )
* ..
* .. Local Scalars ..
LOGICAL ZEROT
CHARACTER DIST, TYPE, UPLO, XTYPE
CHARACTER*3 PATH
INTEGER I, IMAT, IN, INB, INFO, IOFF, IRHS, IUPLO,
$ IZERO, K, KL, KU, LDA, MODE, N, NB, NERRS,
$ NFAIL, NIMAT, NRHS, NRUN
REAL ANORM, CNDNUM, RCOND, RCONDC
* ..
* .. Local Arrays ..
CHARACTER UPLOS( 2 )
INTEGER ISEED( 4 ), ISEEDY( 4 )
REAL RESULT( NTESTS )
* ..
* .. External Functions ..
REAL SGET06, SLANSY
EXTERNAL SGET06, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, SERRPO, SGET04, SLACPY,
$ SLARHS, SLATB4, SLATMS, SPOCON, SPORFS, SPOT01,
$ SPOT02, SPOT03, SPOT05, SPOTRF, SPOTRI, SPOTRS,
$ XLAENV
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
DATA UPLOS / 'U', 'L' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'PO'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL SERRPO( PATH, NOUT )
INFOT = 0
CALL XLAENV( 2, 2 )
*
* Do for each value of N in NVAL
*
DO 120 IN = 1, NN
N = NVAL( IN )
LDA = MAX( N, 1 )
XTYPE = 'N'
NIMAT = NTYPES
IF( N.LE.0 )
$ NIMAT = 1
*
IZERO = 0
DO 110 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 110
*
* Skip types 3, 4, or 5 if the matrix size is too small.
*
ZEROT = IMAT.GE.3 .AND. IMAT.LE.5
IF( ZEROT .AND. N.LT.IMAT-2 )
$ GO TO 110
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 100 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
*
* Set up parameters with SLATB4 and generate a test matrix
* with SLATMS.
*
CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
*
SRNAMT = 'SLATMS'
CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
$ INFO )
*
* Check error code from SLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 100
END IF
*
* For types 3-5, zero one row and column of the matrix to
* test that INFO is returned correctly.
*
IF( ZEROT ) THEN
IF( IMAT.EQ.3 ) THEN
IZERO = 1
ELSE IF( IMAT.EQ.4 ) THEN
IZERO = N
ELSE
IZERO = N / 2 + 1
END IF
IOFF = ( IZERO-1 )*LDA
*
* Set row and column IZERO of A to 0.
*
IF( IUPLO.EQ.1 ) THEN
DO 20 I = 1, IZERO - 1
A( IOFF+I ) = ZERO
20 CONTINUE
IOFF = IOFF + IZERO
DO 30 I = IZERO, N
A( IOFF ) = ZERO
IOFF = IOFF + LDA
30 CONTINUE
ELSE
IOFF = IZERO
DO 40 I = 1, IZERO - 1
A( IOFF ) = ZERO
IOFF = IOFF + LDA
40 CONTINUE
IOFF = IOFF - IZERO
DO 50 I = IZERO, N
A( IOFF+I ) = ZERO
50 CONTINUE
END IF
ELSE
IZERO = 0
END IF
*
* Do for each value of NB in NBVAL
*
DO 90 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
*
* Compute the L*L' or U'*U factorization of the matrix.
*
CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
SRNAMT = 'SPOTRF'
CALL SPOTRF( UPLO, N, AFAC, LDA, INFO )
*
* Check error code from SPOTRF.
*
IF( INFO.NE.IZERO ) THEN
CALL ALAERH( PATH, 'SPOTRF', INFO, IZERO, UPLO, N,
$ N, -1, -1, NB, IMAT, NFAIL, NERRS,
$ NOUT )
GO TO 90
END IF
*
* Skip the tests if INFO is not 0.
*
IF( INFO.NE.0 )
$ GO TO 90
*
*+ TEST 1
* Reconstruct matrix from factors and compute residual.
*
CALL SLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
CALL SPOT01( UPLO, N, A, LDA, AINV, LDA, RWORK,
$ RESULT( 1 ) )
*
*+ TEST 2
* Form the inverse and compute the residual.
*
CALL SLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
SRNAMT = 'SPOTRI'
CALL SPOTRI( UPLO, N, AINV, LDA, INFO )
*
* Check error code from SPOTRI.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SPOTRI', INFO, 0, UPLO, N, N,
$ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
CALL SPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA,
$ RWORK, RCONDC, RESULT( 2 ) )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 60 K = 1, 2
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
$ RESULT( K )
NFAIL = NFAIL + 1
END IF
60 CONTINUE
NRUN = NRUN + 2
*
* Skip the rest of the tests unless this is the first
* blocksize.
*
IF( INB.NE.1 )
$ GO TO 90
*
DO 80 IRHS = 1, NNS
NRHS = NSVAL( IRHS )
*
*+ TEST 3
* Solve and compute residual for A * X = B .
*
SRNAMT = 'SLARHS'
CALL SLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
$ NRHS, A, LDA, XACT, LDA, B, LDA,
$ ISEED, INFO )
CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
SRNAMT = 'SPOTRS'
CALL SPOTRS( UPLO, N, NRHS, AFAC, LDA, X, LDA,
$ INFO )
*
* Check error code from SPOTRS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SPOTRS', INFO, 0, UPLO, N,
$ N, -1, -1, NRHS, IMAT, NFAIL,
$ NERRS, NOUT )
*
CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
CALL SPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
$ LDA, RWORK, RESULT( 3 ) )
*
*+ TEST 4
* Check solution from generated exact solution.
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 4 ) )
*
*+ TESTS 5, 6, and 7
* Use iterative refinement to improve the solution.
*
SRNAMT = 'SPORFS'
CALL SPORFS( UPLO, N, NRHS, A, LDA, AFAC, LDA, B,
$ LDA, X, LDA, RWORK, RWORK( NRHS+1 ),
$ WORK, IWORK, INFO )
*
* Check error code from SPORFS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SPORFS', INFO, 0, UPLO, N,
$ N, -1, -1, NRHS, IMAT, NFAIL,
$ NERRS, NOUT )
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 5 ) )
CALL SPOT05( UPLO, N, NRHS, A, LDA, B, LDA, X, LDA,
$ XACT, LDA, RWORK, RWORK( NRHS+1 ),
$ RESULT( 6 ) )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 70 K = 3, 7
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS,
$ IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
70 CONTINUE
NRUN = NRUN + 5
80 CONTINUE
*
*+ TEST 8
* Get an estimate of RCOND = 1/CNDNUM.
*
ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK )
SRNAMT = 'SPOCON'
CALL SPOCON( UPLO, N, AFAC, LDA, ANORM, RCOND, WORK,
$ IWORK, INFO )
*
* Check error code from SPOCON.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SPOCON', INFO, 0, UPLO, N, N,
$ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
RESULT( 8 ) = SGET06( RCOND, RCONDC )
*
* Print the test ratio if it is .GE. THRESH.
*
IF( RESULT( 8 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 8,
$ RESULT( 8 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
90 CONTINUE
100 CONTINUE
110 CONTINUE
120 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ',
$ I2, ', test ', I2, ', ratio =', G12.5 )
9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
$ I2, ', test(', I2, ') =', G12.5 )
9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
$ ', test(', I2, ') =', G12.5 )
RETURN
*
* End of SCHKPO
*
END
SUBROUTINE SCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
$ NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK,
$ IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NMAX, NN, NNS, NOUT
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
REAL A( * ), AFAC( * ), AINV( * ), B( * ),
$ RWORK( * ), WORK( * ), X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* SCHKPP tests SPPTRF, -TRI, -TRS, -RFS, and -CON
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for N, used in dimensioning the
* work arrays.
*
* A (workspace) REAL array, dimension
* (NMAX*(NMAX+1)/2)
*
* AFAC (workspace) REAL array, dimension
* (NMAX*(NMAX+1)/2)
*
* AINV (workspace) REAL array, dimension
* (NMAX*(NMAX+1)/2)
*
* B (workspace) REAL array, dimension (NMAX*NSMAX)
* where NSMAX is the largest entry in NSVAL.
*
* X (workspace) REAL array, dimension (NMAX*NSMAX)
*
* XACT (workspace) REAL array, dimension (NMAX*NSMAX)
*
* WORK (workspace) REAL array, dimension
* (NMAX*max(3,NSMAX))
*
* RWORK (workspace) REAL array, dimension
* (max(NMAX,2*NSMAX))
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
INTEGER NTYPES
PARAMETER ( NTYPES = 9 )
INTEGER NTESTS
PARAMETER ( NTESTS = 8 )
* ..
* .. Local Scalars ..
LOGICAL ZEROT
CHARACTER DIST, PACKIT, TYPE, UPLO, XTYPE
CHARACTER*3 PATH
INTEGER I, IMAT, IN, INFO, IOFF, IRHS, IUPLO, IZERO, K,
$ KL, KU, LDA, MODE, N, NERRS, NFAIL, NIMAT, NPP,
$ NRHS, NRUN
REAL ANORM, CNDNUM, RCOND, RCONDC
* ..
* .. Local Arrays ..
CHARACTER PACKS( 2 ), UPLOS( 2 )
INTEGER ISEED( 4 ), ISEEDY( 4 )
REAL RESULT( NTESTS )
* ..
* .. External Functions ..
REAL SGET06, SLANSP
EXTERNAL SGET06, SLANSP
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, SCOPY, SERRPO, SGET04,
$ SLACPY, SLARHS, SLATB4, SLATMS, SPPCON, SPPRFS,
$ SPPT01, SPPT02, SPPT03, SPPT05, SPPTRF, SPPTRI,
$ SPPTRS
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
DATA UPLOS / 'U', 'L' / , PACKS / 'C', 'R' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'PP'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL SERRPO( PATH, NOUT )
INFOT = 0
*
* Do for each value of N in NVAL
*
DO 110 IN = 1, NN
N = NVAL( IN )
LDA = MAX( N, 1 )
XTYPE = 'N'
NIMAT = NTYPES
IF( N.LE.0 )
$ NIMAT = 1
*
DO 100 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 100
*
* Skip types 3, 4, or 5 if the matrix size is too small.
*
ZEROT = IMAT.GE.3 .AND. IMAT.LE.5
IF( ZEROT .AND. N.LT.IMAT-2 )
$ GO TO 100
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 90 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
PACKIT = PACKS( IUPLO )
*
* Set up parameters with SLATB4 and generate a test matrix
* with SLATMS.
*
CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
*
SRNAMT = 'SLATMS'
CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
$ INFO )
*
* Check error code from SLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 90
END IF
*
* For types 3-5, zero one row and column of the matrix to
* test that INFO is returned correctly.
*
IF( ZEROT ) THEN
IF( IMAT.EQ.3 ) THEN
IZERO = 1
ELSE IF( IMAT.EQ.4 ) THEN
IZERO = N
ELSE
IZERO = N / 2 + 1
END IF
*
* Set row and column IZERO of A to 0.
*
IF( IUPLO.EQ.1 ) THEN
IOFF = ( IZERO-1 )*IZERO / 2
DO 20 I = 1, IZERO - 1
A( IOFF+I ) = ZERO
20 CONTINUE
IOFF = IOFF + IZERO
DO 30 I = IZERO, N
A( IOFF ) = ZERO
IOFF = IOFF + I
30 CONTINUE
ELSE
IOFF = IZERO
DO 40 I = 1, IZERO - 1
A( IOFF ) = ZERO
IOFF = IOFF + N - I
40 CONTINUE
IOFF = IOFF - IZERO
DO 50 I = IZERO, N
A( IOFF+I ) = ZERO
50 CONTINUE
END IF
ELSE
IZERO = 0
END IF
*
* Compute the L*L' or U'*U factorization of the matrix.
*
NPP = N*( N+1 ) / 2
CALL SCOPY( NPP, A, 1, AFAC, 1 )
SRNAMT = 'SPPTRF'
CALL SPPTRF( UPLO, N, AFAC, INFO )
*
* Check error code from SPPTRF.
*
IF( INFO.NE.IZERO ) THEN
CALL ALAERH( PATH, 'SPPTRF', INFO, IZERO, UPLO, N, N,
$ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 90
END IF
*
* Skip the tests if INFO is not 0.
*
IF( INFO.NE.0 )
$ GO TO 90
*
*+ TEST 1
* Reconstruct matrix from factors and compute residual.
*
CALL SCOPY( NPP, AFAC, 1, AINV, 1 )
CALL SPPT01( UPLO, N, A, AINV, RWORK, RESULT( 1 ) )
*
*+ TEST 2
* Form the inverse and compute the residual.
*
CALL SCOPY( NPP, AFAC, 1, AINV, 1 )
SRNAMT = 'SPPTRI'
CALL SPPTRI( UPLO, N, AINV, INFO )
*
* Check error code from SPPTRI.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SPPTRI', INFO, 0, UPLO, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
CALL SPPT03( UPLO, N, A, AINV, WORK, LDA, RWORK, RCONDC,
$ RESULT( 2 ) )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 60 K = 1, 2
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )UPLO, N, IMAT, K,
$ RESULT( K )
NFAIL = NFAIL + 1
END IF
60 CONTINUE
NRUN = NRUN + 2
*
DO 80 IRHS = 1, NNS
NRHS = NSVAL( IRHS )
*
*+ TEST 3
* Solve and compute residual for A * X = B.
*
SRNAMT = 'SLARHS'
CALL SLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
$ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED,
$ INFO )
CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
SRNAMT = 'SPPTRS'
CALL SPPTRS( UPLO, N, NRHS, AFAC, X, LDA, INFO )
*
* Check error code from SPPTRS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SPPTRS', INFO, 0, UPLO, N, N,
$ -1, -1, NRHS, IMAT, NFAIL, NERRS,
$ NOUT )
*
CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
CALL SPPT02( UPLO, N, NRHS, A, X, LDA, WORK, LDA,
$ RWORK, RESULT( 3 ) )
*
*+ TEST 4
* Check solution from generated exact solution.
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 4 ) )
*
*+ TESTS 5, 6, and 7
* Use iterative refinement to improve the solution.
*
SRNAMT = 'SPPRFS'
CALL SPPRFS( UPLO, N, NRHS, A, AFAC, B, LDA, X, LDA,
$ RWORK, RWORK( NRHS+1 ), WORK, IWORK,
$ INFO )
*
* Check error code from SPPRFS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SPPRFS', INFO, 0, UPLO, N, N,
$ -1, -1, NRHS, IMAT, NFAIL, NERRS,
$ NOUT )
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 5 ) )
CALL SPPT05( UPLO, N, NRHS, A, B, LDA, X, LDA, XACT,
$ LDA, RWORK, RWORK( NRHS+1 ),
$ RESULT( 6 ) )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 70 K = 3, 7
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, IMAT,
$ K, RESULT( K )
NFAIL = NFAIL + 1
END IF
70 CONTINUE
NRUN = NRUN + 5
80 CONTINUE
*
*+ TEST 8
* Get an estimate of RCOND = 1/CNDNUM.
*
ANORM = SLANSP( '1', UPLO, N, A, RWORK )
SRNAMT = 'SPPCON'
CALL SPPCON( UPLO, N, AFAC, ANORM, RCOND, WORK, IWORK,
$ INFO )
*
* Check error code from SPPCON.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SPPCON', INFO, 0, UPLO, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
RESULT( 8 ) = SGET06( RCOND, RCONDC )
*
* Print the test ratio if greater than or equal to THRESH.
*
IF( RESULT( 8 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )UPLO, N, IMAT, 8,
$ RESULT( 8 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
90 CONTINUE
100 CONTINUE
110 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', type ', I2, ', test ',
$ I2, ', ratio =', G12.5 )
9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
$ I2, ', test(', I2, ') =', G12.5 )
RETURN
*
* End of SCHKPP
*
END
SUBROUTINE SCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
$ A, D, E, B, X, XACT, WORK, RWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NN, NNS, NOUT
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER NSVAL( * ), NVAL( * )
REAL A( * ), B( * ), D( * ), E( * ), RWORK( * ),
$ WORK( * ), X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* SCHKPT tests SPTTRF, -TRS, -RFS, and -CON
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* A (workspace) REAL array, dimension (NMAX*2)
*
* D (workspace) REAL array, dimension (NMAX*2)
*
* E (workspace) REAL array, dimension (NMAX*2)
*
* B (workspace) REAL array, dimension (NMAX*NSMAX)
* where NSMAX is the largest entry in NSVAL.
*
* X (workspace) REAL array, dimension (NMAX*NSMAX)
*
* XACT (workspace) REAL array, dimension (NMAX*NSMAX)
*
* WORK (workspace) REAL array, dimension
* (NMAX*max(3,NSMAX))
*
* RWORK (workspace) REAL array, dimension
* (max(NMAX,2*NSMAX))
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
INTEGER NTYPES
PARAMETER ( NTYPES = 12 )
INTEGER NTESTS
PARAMETER ( NTESTS = 7 )
* ..
* .. Local Scalars ..
LOGICAL ZEROT
CHARACTER DIST, TYPE
CHARACTER*3 PATH
INTEGER I, IA, IMAT, IN, INFO, IRHS, IX, IZERO, J, K,
$ KL, KU, LDA, MODE, N, NERRS, NFAIL, NIMAT,
$ NRHS, NRUN
REAL AINVNM, ANORM, COND, DMAX, RCOND, RCONDC
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 ), ISEEDY( 4 )
REAL RESULT( NTESTS ), Z( 3 )
* ..
* .. External Functions ..
INTEGER ISAMAX
REAL SASUM, SGET06, SLANST
EXTERNAL ISAMAX, SASUM, SGET06, SLANST
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, SCOPY, SERRGT, SGET04,
$ SLACPY, SLAPTM, SLARNV, SLATB4, SLATMS, SPTCON,
$ SPTRFS, SPTT01, SPTT02, SPTT05, SPTTRF, SPTTRS,
$ SSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 0, 0, 0, 1 /
* ..
* .. Executable Statements ..
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'PT'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL SERRGT( PATH, NOUT )
INFOT = 0
*
DO 110 IN = 1, NN
*
* Do for each value of N in NVAL.
*
N = NVAL( IN )
LDA = MAX( 1, N )
NIMAT = NTYPES
IF( N.LE.0 )
$ NIMAT = 1
*
DO 100 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( N.GT.0 .AND. .NOT.DOTYPE( IMAT ) )
$ GO TO 100
*
* Set up parameters with SLATB4.
*
CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ COND, DIST )
*
ZEROT = IMAT.GE.8 .AND. IMAT.LE.10
IF( IMAT.LE.6 ) THEN
*
* Type 1-6: generate a symmetric tridiagonal matrix of
* known condition number in lower triangular band storage.
*
SRNAMT = 'SLATMS'
CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, COND,
$ ANORM, KL, KU, 'B', A, 2, WORK, INFO )
*
* Check the error code from SLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', N, N, KL,
$ KU, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 100
END IF
IZERO = 0
*
* Copy the matrix to D and E.
*
IA = 1
DO 20 I = 1, N - 1
D( I ) = A( IA )
E( I ) = A( IA+1 )
IA = IA + 2
20 CONTINUE
IF( N.GT.0 )
$ D( N ) = A( IA )
ELSE
*
* Type 7-12: generate a diagonally dominant matrix with
* unknown condition number in the vectors D and E.
*
IF( .NOT.ZEROT .OR. .NOT.DOTYPE( 7 ) ) THEN
*
* Let D and E have values from [-1,1].
*
CALL SLARNV( 2, ISEED, N, D )
CALL SLARNV( 2, ISEED, N-1, E )
*
* Make the tridiagonal matrix diagonally dominant.
*
IF( N.EQ.1 ) THEN
D( 1 ) = ABS( D( 1 ) )
ELSE
D( 1 ) = ABS( D( 1 ) ) + ABS( E( 1 ) )
D( N ) = ABS( D( N ) ) + ABS( E( N-1 ) )
DO 30 I = 2, N - 1
D( I ) = ABS( D( I ) ) + ABS( E( I ) ) +
$ ABS( E( I-1 ) )
30 CONTINUE
END IF
*
* Scale D and E so the maximum element is ANORM.
*
IX = ISAMAX( N, D, 1 )
DMAX = D( IX )
CALL SSCAL( N, ANORM / DMAX, D, 1 )
CALL SSCAL( N-1, ANORM / DMAX, E, 1 )
*
ELSE IF( IZERO.GT.0 ) THEN
*
* Reuse the last matrix by copying back the zeroed out
* elements.
*
IF( IZERO.EQ.1 ) THEN
D( 1 ) = Z( 2 )
IF( N.GT.1 )
$ E( 1 ) = Z( 3 )
ELSE IF( IZERO.EQ.N ) THEN
E( N-1 ) = Z( 1 )
D( N ) = Z( 2 )
ELSE
E( IZERO-1 ) = Z( 1 )
D( IZERO ) = Z( 2 )
E( IZERO ) = Z( 3 )
END IF
END IF
*
* For types 8-10, set one row and column of the matrix to
* zero.
*
IZERO = 0
IF( IMAT.EQ.8 ) THEN
IZERO = 1
Z( 2 ) = D( 1 )
D( 1 ) = ZERO
IF( N.GT.1 ) THEN
Z( 3 ) = E( 1 )
E( 1 ) = ZERO
END IF
ELSE IF( IMAT.EQ.9 ) THEN
IZERO = N
IF( N.GT.1 ) THEN
Z( 1 ) = E( N-1 )
E( N-1 ) = ZERO
END IF
Z( 2 ) = D( N )
D( N ) = ZERO
ELSE IF( IMAT.EQ.10 ) THEN
IZERO = ( N+1 ) / 2
IF( IZERO.GT.1 ) THEN
Z( 1 ) = E( IZERO-1 )
E( IZERO-1 ) = ZERO
Z( 3 ) = E( IZERO )
E( IZERO ) = ZERO
END IF
Z( 2 ) = D( IZERO )
D( IZERO ) = ZERO
END IF
END IF
*
CALL SCOPY( N, D, 1, D( N+1 ), 1 )
IF( N.GT.1 )
$ CALL SCOPY( N-1, E, 1, E( N+1 ), 1 )
*
*+ TEST 1
* Factor A as L*D*L' and compute the ratio
* norm(L*D*L' - A) / (n * norm(A) * EPS )
*
CALL SPTTRF( N, D( N+1 ), E( N+1 ), INFO )
*
* Check error code from SPTTRF.
*
IF( INFO.NE.IZERO ) THEN
CALL ALAERH( PATH, 'SPTTRF', INFO, IZERO, ' ', N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 100
END IF
*
IF( INFO.GT.0 ) THEN
RCONDC = ZERO
GO TO 90
END IF
*
CALL SPTT01( N, D, E, D( N+1 ), E( N+1 ), WORK,
$ RESULT( 1 ) )
*
* Print the test ratio if greater than or equal to THRESH.
*
IF( RESULT( 1 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )N, IMAT, 1, RESULT( 1 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
*
* Compute RCONDC = 1 / (norm(A) * norm(inv(A))
*
* Compute norm(A).
*
ANORM = SLANST( '1', N, D, E )
*
* Use SPTTRS to solve for one column at a time of inv(A),
* computing the maximum column sum as we go.
*
AINVNM = ZERO
DO 50 I = 1, N
DO 40 J = 1, N
X( J ) = ZERO
40 CONTINUE
X( I ) = ONE
CALL SPTTRS( N, 1, D( N+1 ), E( N+1 ), X, LDA, INFO )
AINVNM = MAX( AINVNM, SASUM( N, X, 1 ) )
50 CONTINUE
RCONDC = ONE / MAX( ONE, ANORM*AINVNM )
*
DO 80 IRHS = 1, NNS
NRHS = NSVAL( IRHS )
*
* Generate NRHS random solution vectors.
*
IX = 1
DO 60 J = 1, NRHS
CALL SLARNV( 2, ISEED, N, XACT( IX ) )
IX = IX + LDA
60 CONTINUE
*
* Set the right hand side.
*
CALL SLAPTM( N, NRHS, ONE, D, E, XACT, LDA, ZERO, B,
$ LDA )
*
*+ TEST 2
* Solve A*x = b and compute the residual.
*
CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
CALL SPTTRS( N, NRHS, D( N+1 ), E( N+1 ), X, LDA, INFO )
*
* Check error code from SPTTRS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SPTTRS', INFO, 0, ' ', N, N, -1,
$ -1, NRHS, IMAT, NFAIL, NERRS, NOUT )
*
CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
CALL SPTT02( N, NRHS, D, E, X, LDA, WORK, LDA,
$ RESULT( 2 ) )
*
*+ TEST 3
* Check solution from generated exact solution.
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
*
*+ TESTS 4, 5, and 6
* Use iterative refinement to improve the solution.
*
SRNAMT = 'SPTRFS'
CALL SPTRFS( N, NRHS, D, E, D( N+1 ), E( N+1 ), B, LDA,
$ X, LDA, RWORK, RWORK( NRHS+1 ), WORK, INFO )
*
* Check error code from SPTRFS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SPTRFS', INFO, 0, ' ', N, N, -1,
$ -1, NRHS, IMAT, NFAIL, NERRS, NOUT )
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 4 ) )
CALL SPTT05( N, NRHS, D, E, B, LDA, X, LDA, XACT, LDA,
$ RWORK, RWORK( NRHS+1 ), RESULT( 5 ) )
*
* Print information about the tests that did not pass the
* threshold.
*
DO 70 K = 2, 6
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )N, NRHS, IMAT, K,
$ RESULT( K )
NFAIL = NFAIL + 1
END IF
70 CONTINUE
NRUN = NRUN + 5
80 CONTINUE
*
*+ TEST 7
* Estimate the reciprocal of the condition number of the
* matrix.
*
90 CONTINUE
SRNAMT = 'SPTCON'
CALL SPTCON( N, D( N+1 ), E( N+1 ), ANORM, RCOND, RWORK,
$ INFO )
*
* Check error code from SPTCON.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SPTCON', INFO, 0, ' ', N, N, -1, -1,
$ -1, IMAT, NFAIL, NERRS, NOUT )
*
RESULT( 7 ) = SGET06( RCOND, RCONDC )
*
* Print the test ratio if greater than or equal to THRESH.
*
IF( RESULT( 7 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )N, IMAT, 7, RESULT( 7 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
100 CONTINUE
110 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' N =', I5, ', type ', I2, ', test ', I2, ', ratio = ',
$ G12.5 )
9998 FORMAT( ' N =', I5, ', NRHS=', I3, ', type ', I2, ', test(', I2,
$ ') = ', G12.5 )
RETURN
*
* End of SCHKPT
*
END
SUBROUTINE SCHKQ3( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
$ THRESH, A, COPYA, S, COPYS, TAU, WORK, IWORK,
$ NOUT )
*
* -- LAPACK test routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* January 2007
*
* .. Scalar Arguments ..
INTEGER NM, NN, NNB, NOUT
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
$ NXVAL( * )
REAL A( * ), COPYA( * ), COPYS( * ), S( * ),
$ TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SCHKQ3 tests SGEQP3.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* A (workspace) REAL array, dimension (MMAX*NMAX)
* where MMAX is the maximum value of M in MVAL and NMAX is the
* maximum value of N in NVAL.
*
* COPYA (workspace) REAL array, dimension (MMAX*NMAX)
*
* S (workspace) REAL array, dimension
* (min(MMAX,NMAX))
*
* COPYS (workspace) REAL array, dimension
* (min(MMAX,NMAX))
*
* TAU (workspace) REAL array, dimension (MMAX)
*
* WORK (workspace) REAL array, dimension
* (MMAX*NMAX + 4*NMAX + MMAX)
*
* IWORK (workspace) INTEGER array, dimension (2*NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTYPES
PARAMETER ( NTYPES = 6 )
INTEGER NTESTS
PARAMETER ( NTESTS = 3 )
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
CHARACTER*3 PATH
INTEGER I, IHIGH, ILOW, IM, IMODE, IN, INB, INFO,
$ ISTEP, K, LDA, LW, LWORK, M, MNMIN, MODE, N,
$ NB, NERRS, NFAIL, NRUN, NX
REAL EPS
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 ), ISEEDY( 4 )
REAL RESULT( NTESTS )
* ..
* .. External Functions ..
REAL SLAMCH, SQPT01, SQRT11, SQRT12
EXTERNAL SLAMCH, SQPT01, SQRT11, SQRT12
* ..
* .. External Subroutines ..
EXTERNAL ALAHD, ALASUM, ICOPY, SGEQP3, SLACPY, SLAORD,
$ SLASET, SLATMS, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, IOUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, IOUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'Q3'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
EPS = SLAMCH( 'Epsilon' )
INFOT = 0
*
DO 90 IM = 1, NM
*
* Do for each value of M in MVAL.
*
M = MVAL( IM )
LDA = MAX( 1, M )
*
DO 80 IN = 1, NN
*
* Do for each value of N in NVAL.
*
N = NVAL( IN )
MNMIN = MIN( M, N )
LWORK = MAX( 1, M*MAX( M, N )+4*MNMIN+MAX( M, N ),
$ M*N + 2*MNMIN + 4*N )
*
DO 70 IMODE = 1, NTYPES
IF( .NOT.DOTYPE( IMODE ) )
$ GO TO 70
*
* Do for each type of matrix
* 1: zero matrix
* 2: one small singular value
* 3: geometric distribution of singular values
* 4: first n/2 columns fixed
* 5: last n/2 columns fixed
* 6: every second column fixed
*
MODE = IMODE
IF( IMODE.GT.3 )
$ MODE = 1
*
* Generate test matrix of size m by n using
* singular value distribution indicated by `mode'.
*
DO 20 I = 1, N
IWORK( I ) = 0
20 CONTINUE
IF( IMODE.EQ.1 ) THEN
CALL SLASET( 'Full', M, N, ZERO, ZERO, COPYA, LDA )
DO 30 I = 1, MNMIN
COPYS( I ) = ZERO
30 CONTINUE
ELSE
CALL SLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', COPYS,
$ MODE, ONE / EPS, ONE, M, N, 'No packing',
$ COPYA, LDA, WORK, INFO )
IF( IMODE.GE.4 ) THEN
IF( IMODE.EQ.4 ) THEN
ILOW = 1
ISTEP = 1
IHIGH = MAX( 1, N / 2 )
ELSE IF( IMODE.EQ.5 ) THEN
ILOW = MAX( 1, N / 2 )
ISTEP = 1
IHIGH = N
ELSE IF( IMODE.EQ.6 ) THEN
ILOW = 1
ISTEP = 2
IHIGH = N
END IF
DO 40 I = ILOW, IHIGH, ISTEP
IWORK( I ) = 1
40 CONTINUE
END IF
CALL SLAORD( 'Decreasing', MNMIN, COPYS, 1 )
END IF
*
DO 60 INB = 1, NNB
*
* Do for each pair of values (NB,NX) in NBVAL and NXVAL.
*
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
*
* Get a working copy of COPYA into A and a copy of
* vector IWORK.
*
CALL SLACPY( 'All', M, N, COPYA, LDA, A, LDA )
CALL ICOPY( N, IWORK( 1 ), 1, IWORK( N+1 ), 1 )
*
* Compute the QR factorization with pivoting of A
*
LW = MAX( 1, 2*N+NB*( N+1 ) )
*
* Compute the QP3 factorization of A
*
SRNAMT = 'SGEQP3'
CALL SGEQP3( M, N, A, LDA, IWORK( N+1 ), TAU, WORK,
$ LW, INFO )
*
* Compute norm(svd(a) - svd(r))
*
RESULT( 1 ) = SQRT12( M, N, A, LDA, COPYS, WORK,
$ LWORK )
*
* Compute norm( A*P - Q*R )
*
RESULT( 2 ) = SQPT01( M, N, MNMIN, COPYA, A, LDA, TAU,
$ IWORK( N+1 ), WORK, LWORK )
*
* Compute Q'*Q
*
RESULT( 3 ) = SQRT11( M, MNMIN, A, LDA, TAU, WORK,
$ LWORK )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 50 K = 1, NTESTS
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )'SGEQP3', M, N, NB,
$ IMODE, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
50 CONTINUE
NRUN = NRUN + NTESTS
*
60 CONTINUE
70 CONTINUE
80 CONTINUE
90 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( 1X, A6, ' M =', I5, ', N =', I5, ', NB =', I4, ', type ',
$ I2, ', test ', I2, ', ratio =', G12.5 )
*
* End of SCHKQ3
*
END
SUBROUTINE SCHKQL( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
$ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AL, AC,
$ B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NM, NMAX, NN, NNB, NOUT, NRHS
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
$ NXVAL( * )
REAL A( * ), AC( * ), AF( * ), AL( * ), AQ( * ),
$ B( * ), RWORK( * ), TAU( * ), WORK( * ),
$ X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* SCHKQL tests SGEQLF, SORGQL and SORMQL.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* NRHS (input) INTEGER
* The number of right hand side vectors to be generated for
* each linear system.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for M or N, used in dimensioning
* the work arrays.
*
* A (workspace) REAL array, dimension (NMAX*NMAX)
*
* AF (workspace) REAL array, dimension (NMAX*NMAX)
*
* AQ (workspace) REAL array, dimension (NMAX*NMAX)
*
* AL (workspace) REAL array, dimension (NMAX*NMAX)
*
* AC (workspace) REAL array, dimension (NMAX*NMAX)
*
* B (workspace) REAL array, dimension (NMAX*NRHS)
*
* X (workspace) REAL array, dimension (NMAX*NRHS)
*
* XACT (workspace) REAL array, dimension (NMAX*NRHS)
*
* TAU (workspace) REAL array, dimension (NMAX)
*
* WORK (workspace) REAL array, dimension (NMAX*NMAX)
*
* RWORK (workspace) REAL array, dimension (NMAX)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTESTS
PARAMETER ( NTESTS = 7 )
INTEGER NTYPES
PARAMETER ( NTYPES = 8 )
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
CHARACTER DIST, TYPE
CHARACTER*3 PATH
INTEGER I, IK, IM, IMAT, IN, INB, INFO, K, KL, KU, LDA,
$ LWORK, M, MINMN, MODE, N, NB, NERRS, NFAIL, NK,
$ NRUN, NT, NX
REAL ANORM, CNDNUM
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 )
REAL RESULT( NTESTS )
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, SERRQL, SGEQLS, SGET02,
$ SLACPY, SLARHS, SLATB4, SLATMS, SQLT01, SQLT02,
$ SQLT03, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'QL'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL SERRQL( PATH, NOUT )
INFOT = 0
CALL XLAENV( 2, 2 )
*
LDA = NMAX
LWORK = NMAX*MAX( NMAX, NRHS )
*
* Do for each value of M in MVAL.
*
DO 70 IM = 1, NM
M = MVAL( IM )
*
* Do for each value of N in NVAL.
*
DO 60 IN = 1, NN
N = NVAL( IN )
MINMN = MIN( M, N )
DO 50 IMAT = 1, NTYPES
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 50
*
* Set up parameters with SLATB4 and generate a test matrix
* with SLATMS.
*
CALL SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
*
SRNAMT = 'SLATMS'
CALL SLATMS( M, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, 'No packing', A, LDA,
$ WORK, INFO )
*
* Check error code from SLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', M, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 50
END IF
*
* Set some values for K: the first value must be MINMN,
* corresponding to the call of SQLT01; other values are
* used in the calls of SQLT02, and must not exceed MINMN.
*
KVAL( 1 ) = MINMN
KVAL( 2 ) = 0
KVAL( 3 ) = 1
KVAL( 4 ) = MINMN / 2
IF( MINMN.EQ.0 ) THEN
NK = 1
ELSE IF( MINMN.EQ.1 ) THEN
NK = 2
ELSE IF( MINMN.LE.3 ) THEN
NK = 3
ELSE
NK = 4
END IF
*
* Do for each value of K in KVAL
*
DO 40 IK = 1, NK
K = KVAL( IK )
*
* Do for each pair of values (NB,NX) in NBVAL and NXVAL.
*
DO 30 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
NT = 2
IF( IK.EQ.1 ) THEN
*
* Test SGEQLF
*
CALL SQLT01( M, N, A, AF, AQ, AL, LDA, TAU,
$ WORK, LWORK, RWORK, RESULT( 1 ) )
ELSE IF( M.GE.N ) THEN
*
* Test SORGQL, using factorization
* returned by SQLT01
*
CALL SQLT02( M, N, K, A, AF, AQ, AL, LDA, TAU,
$ WORK, LWORK, RWORK, RESULT( 1 ) )
ELSE
RESULT( 1 ) = ZERO
RESULT( 2 ) = ZERO
END IF
IF( M.GE.K ) THEN
*
* Test SORMQL, using factorization returned
* by SQLT01
*
CALL SQLT03( M, N, K, AF, AC, AL, AQ, LDA, TAU,
$ WORK, LWORK, RWORK, RESULT( 3 ) )
NT = NT + 4
*
* If M>=N and K=N, call SGEQLS to solve a system
* with NRHS right hand sides and compute the
* residual.
*
IF( K.EQ.N .AND. INB.EQ.1 ) THEN
*
* Generate a solution and set the right
* hand side.
*
SRNAMT = 'SLARHS'
CALL SLARHS( PATH, 'New', 'Full',
$ 'No transpose', M, N, 0, 0,
$ NRHS, A, LDA, XACT, LDA, B, LDA,
$ ISEED, INFO )
*
CALL SLACPY( 'Full', M, NRHS, B, LDA, X,
$ LDA )
SRNAMT = 'SGEQLS'
CALL SGEQLS( M, N, NRHS, AF, LDA, TAU, X,
$ LDA, WORK, LWORK, INFO )
*
* Check error code from SGEQLS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SGEQLS', INFO, 0, ' ',
$ M, N, NRHS, -1, NB, IMAT,
$ NFAIL, NERRS, NOUT )
*
CALL SGET02( 'No transpose', M, N, NRHS, A,
$ LDA, X( M-N+1 ), LDA, B, LDA,
$ RWORK, RESULT( 7 ) )
NT = NT + 1
ELSE
RESULT( 7 ) = ZERO
END IF
ELSE
RESULT( 3 ) = ZERO
RESULT( 4 ) = ZERO
RESULT( 5 ) = ZERO
RESULT( 6 ) = ZERO
END IF
*
* Print information about the tests that did not
* pass the threshold.
*
DO 20 I = 1, NT
IF( RESULT( I ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )M, N, K, NB, NX,
$ IMAT, I, RESULT( I )
NFAIL = NFAIL + 1
END IF
20 CONTINUE
NRUN = NRUN + NT
30 CONTINUE
40 CONTINUE
50 CONTINUE
60 CONTINUE
70 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' M=', I5, ', N=', I5, ', K=', I5, ', NB=', I4, ', NX=',
$ I5, ', type ', I2, ', test(', I2, ')=', G12.5 )
RETURN
*
* End of SCHKQL
*
END
SUBROUTINE SCHKQP( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A,
$ COPYA, S, COPYS, TAU, WORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* January 2007
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NM, NN, NOUT
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), MVAL( * ), NVAL( * )
REAL A( * ), COPYA( * ), COPYS( * ), S( * ),
$ TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SCHKQP tests SGEQPF.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* A (workspace) REAL array, dimension (MMAX*NMAX)
* where MMAX is the maximum value of M in MVAL and NMAX is the
* maximum value of N in NVAL.
*
* COPYA (workspace) REAL array, dimension (MMAX*NMAX)
*
* S (workspace) REAL array, dimension
* (min(MMAX,NMAX))
*
* COPYS (workspace) REAL array, dimension
* (min(MMAX,NMAX))
*
* TAU (workspace) REAL array, dimension (MMAX)
*
* WORK (workspace) REAL array, dimension
* (MMAX*NMAX + 4*NMAX + MMAX)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTYPES
PARAMETER ( NTYPES = 6 )
INTEGER NTESTS
PARAMETER ( NTESTS = 3 )
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
CHARACTER*3 PATH
INTEGER I, IHIGH, ILOW, IM, IMODE, IN, INFO, ISTEP, K,
$ LDA, LWORK, M, MNMIN, MODE, N, NERRS, NFAIL,
$ NRUN
REAL EPS
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 ), ISEEDY( 4 )
REAL RESULT( NTESTS )
* ..
* .. External Functions ..
REAL SLAMCH, SQPT01, SQRT11, SQRT12
EXTERNAL SLAMCH, SQPT01, SQRT11, SQRT12
* ..
* .. External Subroutines ..
EXTERNAL ALAHD, ALASUM, SERRQP, SGEQPF, SLACPY, SLAORD,
$ SLASET, SLATMS
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, IOUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, IOUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'QP'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
EPS = SLAMCH( 'Epsilon' )
*
* Test the error exits
*
IF( TSTERR )
$ CALL SERRQP( PATH, NOUT )
INFOT = 0
*
DO 80 IM = 1, NM
*
* Do for each value of M in MVAL.
*
M = MVAL( IM )
LDA = MAX( 1, M )
*
DO 70 IN = 1, NN
*
* Do for each value of N in NVAL.
*
N = NVAL( IN )
MNMIN = MIN( M, N )
LWORK = MAX( 1, M*MAX( M, N ) + 4*MNMIN + MAX( M, N ),
$ M*N + 2*MNMIN + 4*N )
*
DO 60 IMODE = 1, NTYPES
IF( .NOT.DOTYPE( IMODE ) )
$ GO TO 60
*
* Do for each type of matrix
* 1: zero matrix
* 2: one small singular value
* 3: geometric distribution of singular values
* 4: first n/2 columns fixed
* 5: last n/2 columns fixed
* 6: every second column fixed
*
MODE = IMODE
IF( IMODE.GT.3 )
$ MODE = 1
*
* Generate test matrix of size m by n using
* singular value distribution indicated by `mode'.
*
DO 20 I = 1, N
IWORK( I ) = 0
20 CONTINUE
IF( IMODE.EQ.1 ) THEN
CALL SLASET( 'Full', M, N, ZERO, ZERO, COPYA, LDA )
DO 30 I = 1, MNMIN
COPYS( I ) = ZERO
30 CONTINUE
ELSE
CALL SLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', COPYS,
$ MODE, ONE / EPS, ONE, M, N, 'No packing',
$ COPYA, LDA, WORK, INFO )
IF( IMODE.GE.4 ) THEN
IF( IMODE.EQ.4 ) THEN
ILOW = 1
ISTEP = 1
IHIGH = MAX( 1, N / 2 )
ELSE IF( IMODE.EQ.5 ) THEN
ILOW = MAX( 1, N / 2 )
ISTEP = 1
IHIGH = N
ELSE IF( IMODE.EQ.6 ) THEN
ILOW = 1
ISTEP = 2
IHIGH = N
END IF
DO 40 I = ILOW, IHIGH, ISTEP
IWORK( I ) = 1
40 CONTINUE
END IF
CALL SLAORD( 'Decreasing', MNMIN, COPYS, 1 )
END IF
*
* Save A and its singular values
*
CALL SLACPY( 'All', M, N, COPYA, LDA, A, LDA )
*
* Compute the QR factorization with pivoting of A
*
SRNAMT = 'SGEQPF'
CALL SGEQPF( M, N, A, LDA, IWORK, TAU, WORK, INFO )
*
* Compute norm(svd(a) - svd(r))
*
RESULT( 1 ) = SQRT12( M, N, A, LDA, COPYS, WORK, LWORK )
*
* Compute norm( A*P - Q*R )
*
RESULT( 2 ) = SQPT01( M, N, MNMIN, COPYA, A, LDA, TAU,
$ IWORK, WORK, LWORK )
*
* Compute Q'*Q
*
RESULT( 3 ) = SQRT11( M, MNMIN, A, LDA, TAU, WORK,
$ LWORK )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 50 K = 1, 3
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )M, N, IMODE, K,
$ RESULT( K )
NFAIL = NFAIL + 1
END IF
50 CONTINUE
NRUN = NRUN + 3
60 CONTINUE
70 CONTINUE
80 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' M =', I5, ', N =', I5, ', type ', I2, ', test ', I2,
$ ', ratio =', G12.5 )
*
* End of SCHKQP
*
END
SUBROUTINE SCHKQR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
$ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC,
$ B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NM, NMAX, NN, NNB, NOUT, NRHS
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
$ NXVAL( * )
REAL A( * ), AC( * ), AF( * ), AQ( * ), AR( * ),
$ B( * ), RWORK( * ), TAU( * ), WORK( * ),
$ X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* SCHKQR tests SGEQRF, SORGQR and SORMQR.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* NRHS (input) INTEGER
* The number of right hand side vectors to be generated for
* each linear system.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for M or N, used in dimensioning
* the work arrays.
*
* A (workspace) REAL array, dimension (NMAX*NMAX)
*
* AF (workspace) REAL array, dimension (NMAX*NMAX)
*
* AQ (workspace) REAL array, dimension (NMAX*NMAX)
*
* AR (workspace) REAL array, dimension (NMAX*NMAX)
*
* AC (workspace) REAL array, dimension (NMAX*NMAX)
*
* B (workspace) REAL array, dimension (NMAX*NRHS)
*
* X (workspace) REAL array, dimension (NMAX*NRHS)
*
* XACT (workspace) REAL array, dimension (NMAX*NRHS)
*
* TAU (workspace) REAL array, dimension (NMAX)
*
* WORK (workspace) REAL array, dimension (NMAX*NMAX)
*
* RWORK (workspace) REAL array, dimension (NMAX)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTESTS
PARAMETER ( NTESTS = 7 )
INTEGER NTYPES
PARAMETER ( NTYPES = 8 )
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
CHARACTER DIST, TYPE
CHARACTER*3 PATH
INTEGER I, IK, IM, IMAT, IN, INB, INFO, K, KL, KU, LDA,
$ LWORK, M, MINMN, MODE, N, NB, NERRS, NFAIL, NK,
$ NRUN, NT, NX
REAL ANORM, CNDNUM
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 )
REAL RESULT( NTESTS )
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, SERRQR, SGEQRS, SGET02,
$ SLACPY, SLARHS, SLATB4, SLATMS, SQRT01, SQRT02,
$ SQRT03, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'QR'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL SERRQR( PATH, NOUT )
INFOT = 0
CALL XLAENV( 2, 2 )
*
LDA = NMAX
LWORK = NMAX*MAX( NMAX, NRHS )
*
* Do for each value of M in MVAL.
*
DO 70 IM = 1, NM
M = MVAL( IM )
*
* Do for each value of N in NVAL.
*
DO 60 IN = 1, NN
N = NVAL( IN )
MINMN = MIN( M, N )
DO 50 IMAT = 1, NTYPES
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 50
*
* Set up parameters with SLATB4 and generate a test matrix
* with SLATMS.
*
CALL SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
*
SRNAMT = 'SLATMS'
CALL SLATMS( M, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, 'No packing', A, LDA,
$ WORK, INFO )
*
* Check error code from SLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', M, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 50
END IF
*
* Set some values for K: the first value must be MINMN,
* corresponding to the call of SQRT01; other values are
* used in the calls of SQRT02, and must not exceed MINMN.
*
KVAL( 1 ) = MINMN
KVAL( 2 ) = 0
KVAL( 3 ) = 1
KVAL( 4 ) = MINMN / 2
IF( MINMN.EQ.0 ) THEN
NK = 1
ELSE IF( MINMN.EQ.1 ) THEN
NK = 2
ELSE IF( MINMN.LE.3 ) THEN
NK = 3
ELSE
NK = 4
END IF
*
* Do for each value of K in KVAL
*
DO 40 IK = 1, NK
K = KVAL( IK )
*
* Do for each pair of values (NB,NX) in NBVAL and NXVAL.
*
DO 30 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
NT = 2
IF( IK.EQ.1 ) THEN
*
* Test SGEQRF
*
CALL SQRT01( M, N, A, AF, AQ, AR, LDA, TAU,
$ WORK, LWORK, RWORK, RESULT( 1 ) )
ELSE IF( M.GE.N ) THEN
*
* Test SORGQR, using factorization
* returned by SQRT01
*
CALL SQRT02( M, N, K, A, AF, AQ, AR, LDA, TAU,
$ WORK, LWORK, RWORK, RESULT( 1 ) )
ELSE
RESULT( 1 ) = ZERO
RESULT( 2 ) = ZERO
END IF
IF( M.GE.K ) THEN
*
* Test SORMQR, using factorization returned
* by SQRT01
*
CALL SQRT03( M, N, K, AF, AC, AR, AQ, LDA, TAU,
$ WORK, LWORK, RWORK, RESULT( 3 ) )
NT = NT + 4
*
* If M>=N and K=N, call SGEQRS to solve a system
* with NRHS right hand sides and compute the
* residual.
*
IF( K.EQ.N .AND. INB.EQ.1 ) THEN
*
* Generate a solution and set the right
* hand side.
*
SRNAMT = 'SLARHS'
CALL SLARHS( PATH, 'New', 'Full',
$ 'No transpose', M, N, 0, 0,
$ NRHS, A, LDA, XACT, LDA, B, LDA,
$ ISEED, INFO )
*
CALL SLACPY( 'Full', M, NRHS, B, LDA, X,
$ LDA )
SRNAMT = 'SGEQRS'
CALL SGEQRS( M, N, NRHS, AF, LDA, TAU, X,
$ LDA, WORK, LWORK, INFO )
*
* Check error code from SGEQRS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SGEQRS', INFO, 0, ' ',
$ M, N, NRHS, -1, NB, IMAT,
$ NFAIL, NERRS, NOUT )
*
CALL SGET02( 'No transpose', M, N, NRHS, A,
$ LDA, X, LDA, B, LDA, RWORK,
$ RESULT( 7 ) )
NT = NT + 1
ELSE
RESULT( 7 ) = ZERO
END IF
ELSE
RESULT( 3 ) = ZERO
RESULT( 4 ) = ZERO
RESULT( 5 ) = ZERO
RESULT( 6 ) = ZERO
END IF
*
* Print information about the tests that did not
* pass the threshold.
*
DO 20 I = 1, NT
IF( RESULT( I ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )M, N, K, NB, NX,
$ IMAT, I, RESULT( I )
NFAIL = NFAIL + 1
END IF
20 CONTINUE
NRUN = NRUN + NT
30 CONTINUE
40 CONTINUE
50 CONTINUE
60 CONTINUE
70 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' M=', I5, ', N=', I5, ', K=', I5, ', NB=', I4, ', NX=',
$ I5, ', type ', I2, ', test(', I2, ')=', G12.5 )
RETURN
*
* End of SCHKQR
*
END
SUBROUTINE SCHKRQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
$ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC,
$ B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NM, NMAX, NN, NNB, NOUT, NRHS
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
$ NXVAL( * )
REAL A( * ), AC( * ), AF( * ), AQ( * ), AR( * ),
$ B( * ), RWORK( * ), TAU( * ), WORK( * ),
$ X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* SCHKRQ tests SGERQF, SORGRQ and SORMRQ.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* NRHS (input) INTEGER
* The number of right hand side vectors to be generated for
* each linear system.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for M or N, used in dimensioning
* the work arrays.
*
* A (workspace) REAL array, dimension (NMAX*NMAX)
*
* AF (workspace) REAL array, dimension (NMAX*NMAX)
*
* AQ (workspace) REAL array, dimension (NMAX*NMAX)
*
* AR (workspace) REAL array, dimension (NMAX*NMAX)
*
* AC (workspace) REAL array, dimension (NMAX*NMAX)
*
* B (workspace) REAL array, dimension (NMAX*NRHS)
*
* X (workspace) REAL array, dimension (NMAX*NRHS)
*
* XACT (workspace) REAL array, dimension (NMAX*NRHS)
*
* TAU (workspace) REAL array, dimension (NMAX)
*
* WORK (workspace) REAL array, dimension (NMAX*NMAX)
*
* RWORK (workspace) REAL array, dimension (NMAX)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTESTS
PARAMETER ( NTESTS = 7 )
INTEGER NTYPES
PARAMETER ( NTYPES = 8 )
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
CHARACTER DIST, TYPE
CHARACTER*3 PATH
INTEGER I, IK, IM, IMAT, IN, INB, INFO, K, KL, KU, LDA,
$ LWORK, M, MINMN, MODE, N, NB, NERRS, NFAIL, NK,
$ NRUN, NT, NX
REAL ANORM, CNDNUM
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 )
REAL RESULT( NTESTS )
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, SERRRQ, SGERQS, SGET02,
$ SLACPY, SLARHS, SLATB4, SLATMS, SRQT01, SRQT02,
$ SRQT03, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'RQ'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL SERRRQ( PATH, NOUT )
INFOT = 0
CALL XLAENV( 2, 2 )
*
LDA = NMAX
LWORK = NMAX*MAX( NMAX, NRHS )
*
* Do for each value of M in MVAL.
*
DO 70 IM = 1, NM
M = MVAL( IM )
*
* Do for each value of N in NVAL.
*
DO 60 IN = 1, NN
N = NVAL( IN )
MINMN = MIN( M, N )
DO 50 IMAT = 1, NTYPES
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 50
*
* Set up parameters with SLATB4 and generate a test matrix
* with SLATMS.
*
CALL SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
*
SRNAMT = 'SLATMS'
CALL SLATMS( M, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, 'No packing', A, LDA,
$ WORK, INFO )
*
* Check error code from SLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', M, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 50
END IF
*
* Set some values for K: the first value must be MINMN,
* corresponding to the call of SRQT01; other values are
* used in the calls of SRQT02, and must not exceed MINMN.
*
KVAL( 1 ) = MINMN
KVAL( 2 ) = 0
KVAL( 3 ) = 1
KVAL( 4 ) = MINMN / 2
IF( MINMN.EQ.0 ) THEN
NK = 1
ELSE IF( MINMN.EQ.1 ) THEN
NK = 2
ELSE IF( MINMN.LE.3 ) THEN
NK = 3
ELSE
NK = 4
END IF
*
* Do for each value of K in KVAL
*
DO 40 IK = 1, NK
K = KVAL( IK )
*
* Do for each pair of values (NB,NX) in NBVAL and NXVAL.
*
DO 30 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
NT = 2
IF( IK.EQ.1 ) THEN
*
* Test SGERQF
*
CALL SRQT01( M, N, A, AF, AQ, AR, LDA, TAU,
$ WORK, LWORK, RWORK, RESULT( 1 ) )
ELSE IF( M.LE.N ) THEN
*
* Test SORGRQ, using factorization
* returned by SRQT01
*
CALL SRQT02( M, N, K, A, AF, AQ, AR, LDA, TAU,
$ WORK, LWORK, RWORK, RESULT( 1 ) )
ELSE
RESULT( 1 ) = ZERO
RESULT( 2 ) = ZERO
END IF
IF( M.GE.K ) THEN
*
* Test SORMRQ, using factorization returned
* by SRQT01
*
CALL SRQT03( M, N, K, AF, AC, AR, AQ, LDA, TAU,
$ WORK, LWORK, RWORK, RESULT( 3 ) )
NT = NT + 4
*
* If M>=N and K=N, call SGERQS to solve a system
* with NRHS right hand sides and compute the
* residual.
*
IF( K.EQ.M .AND. INB.EQ.1 ) THEN
*
* Generate a solution and set the right
* hand side.
*
SRNAMT = 'SLARHS'
CALL SLARHS( PATH, 'New', 'Full',
$ 'No transpose', M, N, 0, 0,
$ NRHS, A, LDA, XACT, LDA, B, LDA,
$ ISEED, INFO )
*
CALL SLACPY( 'Full', M, NRHS, B, LDA,
$ X( N-M+1 ), LDA )
SRNAMT = 'SGERQS'
CALL SGERQS( M, N, NRHS, AF, LDA, TAU, X,
$ LDA, WORK, LWORK, INFO )
*
* Check error code from SGERQS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SGERQS', INFO, 0, ' ',
$ M, N, NRHS, -1, NB, IMAT,
$ NFAIL, NERRS, NOUT )
*
CALL SGET02( 'No transpose', M, N, NRHS, A,
$ LDA, X, LDA, B, LDA, RWORK,
$ RESULT( 7 ) )
NT = NT + 1
ELSE
RESULT( 7 ) = ZERO
END IF
ELSE
RESULT( 3 ) = ZERO
RESULT( 4 ) = ZERO
RESULT( 5 ) = ZERO
RESULT( 6 ) = ZERO
END IF
*
* Print information about the tests that did not
* pass the threshold.
*
DO 20 I = 1, NT
IF( RESULT( I ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )M, N, K, NB, NX,
$ IMAT, I, RESULT( I )
NFAIL = NFAIL + 1
END IF
20 CONTINUE
NRUN = NRUN + NT
30 CONTINUE
40 CONTINUE
50 CONTINUE
60 CONTINUE
70 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' M=', I5, ', N=', I5, ', K=', I5, ', NB=', I4, ', NX=',
$ I5, ', type ', I2, ', test(', I2, ')=', G12.5 )
RETURN
*
* End of SCHKRQ
*
END
SUBROUTINE SCHKSP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
$ NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK,
$ IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NMAX, NN, NNS, NOUT
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
REAL A( * ), AFAC( * ), AINV( * ), B( * ),
$ RWORK( * ), WORK( * ), X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* SCHKSP tests SSPTRF, -TRI, -TRS, -RFS, and -CON
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for N, used in dimensioning the
* work arrays.
*
* A (workspace) REAL array, dimension
* (NMAX*(NMAX+1)/2)
*
* AFAC (workspace) REAL array, dimension
* (NMAX*(NMAX+1)/2)
*
* AINV (workspace) REAL array, dimension
* (NMAX*(NMAX+1)/2)
*
* B (workspace) REAL array, dimension (NMAX*NSMAX)
* where NSMAX is the largest entry in NSVAL.
*
* X (workspace) REAL array, dimension (NMAX*NSMAX)
*
* XACT (workspace) REAL array, dimension (NMAX*NSMAX)
*
* WORK (workspace) REAL array, dimension
* (NMAX*max(2,NSMAX))
*
* RWORK (workspace) REAL array,
* dimension (NMAX+2*NSMAX)
*
* IWORK (workspace) INTEGER array, dimension (2*NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
INTEGER NTYPES
PARAMETER ( NTYPES = 10 )
INTEGER NTESTS
PARAMETER ( NTESTS = 8 )
* ..
* .. Local Scalars ..
LOGICAL TRFCON, ZEROT
CHARACTER DIST, PACKIT, TYPE, UPLO, XTYPE
CHARACTER*3 PATH
INTEGER I, I1, I2, IMAT, IN, INFO, IOFF, IRHS, IUPLO,
$ IZERO, J, K, KL, KU, LDA, MODE, N, NERRS,
$ NFAIL, NIMAT, NPP, NRHS, NRUN, NT
REAL ANORM, CNDNUM, RCOND, RCONDC
* ..
* .. Local Arrays ..
CHARACTER UPLOS( 2 )
INTEGER ISEED( 4 ), ISEEDY( 4 )
REAL RESULT( NTESTS )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SGET06, SLANSP
EXTERNAL LSAME, SGET06, SLANSP
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, SCOPY, SERRSY, SGET04,
$ SLACPY, SLARHS, SLATB4, SLATMS, SPPT02, SPPT03,
$ SPPT05, SSPCON, SSPRFS, SSPT01, SSPTRF, SSPTRI,
$ SSPTRS
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
DATA UPLOS / 'U', 'L' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'SP'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL SERRSY( PATH, NOUT )
INFOT = 0
*
* Do for each value of N in NVAL
*
DO 170 IN = 1, NN
N = NVAL( IN )
LDA = MAX( N, 1 )
XTYPE = 'N'
NIMAT = NTYPES
IF( N.LE.0 )
$ NIMAT = 1
*
IZERO = 0
DO 160 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 160
*
* Skip types 3, 4, 5, or 6 if the matrix size is too small.
*
ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
IF( ZEROT .AND. N.LT.IMAT-2 )
$ GO TO 160
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 150 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
IF( LSAME( UPLO, 'U' ) ) THEN
PACKIT = 'C'
ELSE
PACKIT = 'R'
END IF
*
* Set up parameters with SLATB4 and generate a test matrix
* with SLATMS.
*
CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
*
SRNAMT = 'SLATMS'
CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
$ INFO )
*
* Check error code from SLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 150
END IF
*
* For types 3-6, zero one or more rows and columns of
* the matrix to test that INFO is returned correctly.
*
IF( ZEROT ) THEN
IF( IMAT.EQ.3 ) THEN
IZERO = 1
ELSE IF( IMAT.EQ.4 ) THEN
IZERO = N
ELSE
IZERO = N / 2 + 1
END IF
*
IF( IMAT.LT.6 ) THEN
*
* Set row and column IZERO to zero.
*
IF( IUPLO.EQ.1 ) THEN
IOFF = ( IZERO-1 )*IZERO / 2
DO 20 I = 1, IZERO - 1
A( IOFF+I ) = ZERO
20 CONTINUE
IOFF = IOFF + IZERO
DO 30 I = IZERO, N
A( IOFF ) = ZERO
IOFF = IOFF + I
30 CONTINUE
ELSE
IOFF = IZERO
DO 40 I = 1, IZERO - 1
A( IOFF ) = ZERO
IOFF = IOFF + N - I
40 CONTINUE
IOFF = IOFF - IZERO
DO 50 I = IZERO, N
A( IOFF+I ) = ZERO
50 CONTINUE
END IF
ELSE
IOFF = 0
IF( IUPLO.EQ.1 ) THEN
*
* Set the first IZERO rows and columns to zero.
*
DO 70 J = 1, N
I2 = MIN( J, IZERO )
DO 60 I = 1, I2
A( IOFF+I ) = ZERO
60 CONTINUE
IOFF = IOFF + J
70 CONTINUE
ELSE
*
* Set the last IZERO rows and columns to zero.
*
DO 90 J = 1, N
I1 = MAX( J, IZERO )
DO 80 I = I1, N
A( IOFF+I ) = ZERO
80 CONTINUE
IOFF = IOFF + N - J
90 CONTINUE
END IF
END IF
ELSE
IZERO = 0
END IF
*
* Compute the L*D*L' or U*D*U' factorization of the matrix.
*
NPP = N*( N+1 ) / 2
CALL SCOPY( NPP, A, 1, AFAC, 1 )
SRNAMT = 'SSPTRF'
CALL SSPTRF( UPLO, N, AFAC, IWORK, INFO )
*
* Adjust the expected value of INFO to account for
* pivoting.
*
K = IZERO
IF( K.GT.0 ) THEN
100 CONTINUE
IF( IWORK( K ).LT.0 ) THEN
IF( IWORK( K ).NE.-K ) THEN
K = -IWORK( K )
GO TO 100
END IF
ELSE IF( IWORK( K ).NE.K ) THEN
K = IWORK( K )
GO TO 100
END IF
END IF
*
* Check error code from SSPTRF.
*
IF( INFO.NE.K )
$ CALL ALAERH( PATH, 'SSPTRF', INFO, K, UPLO, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
IF( INFO.NE.0 ) THEN
TRFCON = .TRUE.
ELSE
TRFCON = .FALSE.
END IF
*
*+ TEST 1
* Reconstruct matrix from factors and compute residual.
*
CALL SSPT01( UPLO, N, A, AFAC, IWORK, AINV, LDA, RWORK,
$ RESULT( 1 ) )
NT = 1
*
*+ TEST 2
* Form the inverse and compute the residual.
*
IF( .NOT.TRFCON ) THEN
CALL SCOPY( NPP, AFAC, 1, AINV, 1 )
SRNAMT = 'SSPTRI'
CALL SSPTRI( UPLO, N, AINV, IWORK, WORK, INFO )
*
* Check error code from SSPTRI.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SSPTRI', INFO, 0, UPLO, N, N,
$ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
CALL SPPT03( UPLO, N, A, AINV, WORK, LDA, RWORK,
$ RCONDC, RESULT( 2 ) )
NT = 2
END IF
*
* Print information about the tests that did not pass
* the threshold.
*
DO 110 K = 1, NT
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )UPLO, N, IMAT, K,
$ RESULT( K )
NFAIL = NFAIL + 1
END IF
110 CONTINUE
NRUN = NRUN + NT
*
* Do only the condition estimate if INFO is not 0.
*
IF( TRFCON ) THEN
RCONDC = ZERO
GO TO 140
END IF
*
DO 130 IRHS = 1, NNS
NRHS = NSVAL( IRHS )
*
*+ TEST 3
* Solve and compute residual for A * X = B.
*
SRNAMT = 'SLARHS'
CALL SLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
$ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED,
$ INFO )
CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
SRNAMT = 'SSPTRS'
CALL SSPTRS( UPLO, N, NRHS, AFAC, IWORK, X, LDA,
$ INFO )
*
* Check error code from SSPTRS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SSPTRS', INFO, 0, UPLO, N, N,
$ -1, -1, NRHS, IMAT, NFAIL, NERRS,
$ NOUT )
*
CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
CALL SPPT02( UPLO, N, NRHS, A, X, LDA, WORK, LDA,
$ RWORK, RESULT( 3 ) )
*
*+ TEST 4
* Check solution from generated exact solution.
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 4 ) )
*
*+ TESTS 5, 6, and 7
* Use iterative refinement to improve the solution.
*
SRNAMT = 'SSPRFS'
CALL SSPRFS( UPLO, N, NRHS, A, AFAC, IWORK, B, LDA, X,
$ LDA, RWORK, RWORK( NRHS+1 ), WORK,
$ IWORK( N+1 ), INFO )
*
* Check error code from SSPRFS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SSPRFS', INFO, 0, UPLO, N, N,
$ -1, -1, NRHS, IMAT, NFAIL, NERRS,
$ NOUT )
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 5 ) )
CALL SPPT05( UPLO, N, NRHS, A, B, LDA, X, LDA, XACT,
$ LDA, RWORK, RWORK( NRHS+1 ),
$ RESULT( 6 ) )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 120 K = 3, 7
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, IMAT,
$ K, RESULT( K )
NFAIL = NFAIL + 1
END IF
120 CONTINUE
NRUN = NRUN + 5
130 CONTINUE
*
*+ TEST 8
* Get an estimate of RCOND = 1/CNDNUM.
*
140 CONTINUE
ANORM = SLANSP( '1', UPLO, N, A, RWORK )
SRNAMT = 'SSPCON'
CALL SSPCON( UPLO, N, AFAC, IWORK, ANORM, RCOND, WORK,
$ IWORK( N+1 ), INFO )
*
* Check error code from SSPCON.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SSPCON', INFO, 0, UPLO, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
RESULT( 8 ) = SGET06( RCOND, RCONDC )
*
* Print the test ratio if it is .GE. THRESH.
*
IF( RESULT( 8 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )UPLO, N, IMAT, 8,
$ RESULT( 8 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
150 CONTINUE
160 CONTINUE
170 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', type ', I2, ', test ',
$ I2, ', ratio =', G12.5 )
9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
$ I2, ', test(', I2, ') =', G12.5 )
RETURN
*
* End of SCHKSP
*
END
SUBROUTINE SCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
$ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
$ XACT, WORK, RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NMAX, NN, NNB, NNS, NOUT
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
REAL A( * ), AFAC( * ), AINV( * ), B( * ),
$ RWORK( * ), WORK( * ), X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* SCHKSY tests SSYTRF, -TRI, -TRS, -RFS, and -CON.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* NNB (input) INTEGER
* The number of values of NB contained in the vector NBVAL.
*
* NBVAL (input) INTEGER array, dimension (NBVAL)
* The values of the blocksize NB.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for N, used in dimensioning the
* work arrays.
*
* A (workspace) REAL array, dimension (NMAX*NMAX)
*
* AFAC (workspace) REAL array, dimension (NMAX*NMAX)
*
* AINV (workspace) REAL array, dimension (NMAX*NMAX)
*
* B (workspace) REAL array, dimension (NMAX*NSMAX)
* where NSMAX is the largest entry in NSVAL.
*
* X (workspace) REAL array, dimension (NMAX*NSMAX)
*
* XACT (workspace) REAL array, dimension (NMAX*NSMAX)
*
* WORK (workspace) REAL array, dimension
* (NMAX*max(3,NSMAX))
*
* RWORK (workspace) REAL array, dimension
* (max(NMAX,2*NSMAX))
*
* IWORK (workspace) INTEGER array, dimension (2*NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
INTEGER NTYPES
PARAMETER ( NTYPES = 10 )
INTEGER NTESTS
PARAMETER ( NTESTS = 8 )
* ..
* .. Local Scalars ..
LOGICAL TRFCON, ZEROT
CHARACTER DIST, TYPE, UPLO, XTYPE
CHARACTER*3 PATH
INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
$ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE,
$ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT
REAL ANORM, CNDNUM, RCOND, RCONDC
* ..
* .. Local Arrays ..
CHARACTER UPLOS( 2 )
INTEGER ISEED( 4 ), ISEEDY( 4 )
REAL RESULT( NTESTS )
* ..
* .. External Functions ..
REAL SGET06, SLANSY
EXTERNAL SGET06, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, SERRSY, SGET04, SLACPY,
$ SLARHS, SLATB4, SLATMS, SPOT02, SPOT03, SPOT05,
$ SSYCON, SSYRFS, SSYT01, SSYTRF, SSYTRI, SSYTRS,
$ XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
DATA UPLOS / 'U', 'L' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'SY'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL SERRSY( PATH, NOUT )
INFOT = 0
CALL XLAENV( 2, 2 )
*
* Do for each value of N in NVAL
*
DO 180 IN = 1, NN
N = NVAL( IN )
LDA = MAX( N, 1 )
XTYPE = 'N'
NIMAT = NTYPES
IF( N.LE.0 )
$ NIMAT = 1
*
IZERO = 0
DO 170 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 170
*
* Skip types 3, 4, 5, or 6 if the matrix size is too small.
*
ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
IF( ZEROT .AND. N.LT.IMAT-2 )
$ GO TO 170
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 160 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
*
* Set up parameters with SLATB4 and generate a test matrix
* with SLATMS.
*
CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
*
SRNAMT = 'SLATMS'
CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
$ INFO )
*
* Check error code from SLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 160
END IF
*
* For types 3-6, zero one or more rows and columns of
* the matrix to test that INFO is returned correctly.
*
IF( ZEROT ) THEN
IF( IMAT.EQ.3 ) THEN
IZERO = 1
ELSE IF( IMAT.EQ.4 ) THEN
IZERO = N
ELSE
IZERO = N / 2 + 1
END IF
*
IF( IMAT.LT.6 ) THEN
*
* Set row and column IZERO to zero.
*
IF( IUPLO.EQ.1 ) THEN
IOFF = ( IZERO-1 )*LDA
DO 20 I = 1, IZERO - 1
A( IOFF+I ) = ZERO
20 CONTINUE
IOFF = IOFF + IZERO
DO 30 I = IZERO, N
A( IOFF ) = ZERO
IOFF = IOFF + LDA
30 CONTINUE
ELSE
IOFF = IZERO
DO 40 I = 1, IZERO - 1
A( IOFF ) = ZERO
IOFF = IOFF + LDA
40 CONTINUE
IOFF = IOFF - IZERO
DO 50 I = IZERO, N
A( IOFF+I ) = ZERO
50 CONTINUE
END IF
ELSE
IOFF = 0
IF( IUPLO.EQ.1 ) THEN
*
* Set the first IZERO rows and columns to zero.
*
DO 70 J = 1, N
I2 = MIN( J, IZERO )
DO 60 I = 1, I2
A( IOFF+I ) = ZERO
60 CONTINUE
IOFF = IOFF + LDA
70 CONTINUE
ELSE
*
* Set the last IZERO rows and columns to zero.
*
DO 90 J = 1, N
I1 = MAX( J, IZERO )
DO 80 I = I1, N
A( IOFF+I ) = ZERO
80 CONTINUE
IOFF = IOFF + LDA
90 CONTINUE
END IF
END IF
ELSE
IZERO = 0
END IF
*
* Do for each value of NB in NBVAL
*
DO 150 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
*
* Compute the L*D*L' or U*D*U' factorization of the
* matrix.
*
CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
LWORK = MAX( 2, NB )*LDA
SRNAMT = 'SSYTRF'
CALL SSYTRF( UPLO, N, AFAC, LDA, IWORK, AINV, LWORK,
$ INFO )
*
* Adjust the expected value of INFO to account for
* pivoting.
*
K = IZERO
IF( K.GT.0 ) THEN
100 CONTINUE
IF( IWORK( K ).LT.0 ) THEN
IF( IWORK( K ).NE.-K ) THEN
K = -IWORK( K )
GO TO 100
END IF
ELSE IF( IWORK( K ).NE.K ) THEN
K = IWORK( K )
GO TO 100
END IF
END IF
*
* Check error code from SSYTRF.
*
IF( INFO.NE.K )
$ CALL ALAERH( PATH, 'SSYTRF', INFO, K, UPLO, N, N,
$ -1, -1, NB, IMAT, NFAIL, NERRS, NOUT )
IF( INFO.NE.0 ) THEN
TRFCON = .TRUE.
ELSE
TRFCON = .FALSE.
END IF
*
*+ TEST 1
* Reconstruct matrix from factors and compute residual.
*
CALL SSYT01( UPLO, N, A, LDA, AFAC, LDA, IWORK, AINV,
$ LDA, RWORK, RESULT( 1 ) )
NT = 1
*
*+ TEST 2
* Form the inverse and compute the residual.
*
IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN
CALL SLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
SRNAMT = 'SSYTRI'
CALL SSYTRI( UPLO, N, AINV, LDA, IWORK, WORK,
$ INFO )
*
* Check error code from SSYTRI.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SSYTRI', INFO, -1, UPLO, N,
$ N, -1, -1, -1, IMAT, NFAIL, NERRS,
$ NOUT )
*
CALL SPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA,
$ RWORK, RCONDC, RESULT( 2 ) )
NT = 2
END IF
*
* Print information about the tests that did not pass
* the threshold.
*
DO 110 K = 1, NT
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
$ RESULT( K )
NFAIL = NFAIL + 1
END IF
110 CONTINUE
NRUN = NRUN + NT
*
* Skip the other tests if this is not the first block
* size.
*
IF( INB.GT.1 )
$ GO TO 150
*
* Do only the condition estimate if INFO is not 0.
*
IF( TRFCON ) THEN
RCONDC = ZERO
GO TO 140
END IF
*
DO 130 IRHS = 1, NNS
NRHS = NSVAL( IRHS )
*
*+ TEST 3
* Solve and compute residual for A * X = B.
*
SRNAMT = 'SLARHS'
CALL SLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
$ NRHS, A, LDA, XACT, LDA, B, LDA,
$ ISEED, INFO )
CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
SRNAMT = 'SSYTRS'
CALL SSYTRS( UPLO, N, NRHS, AFAC, LDA, IWORK, X,
$ LDA, INFO )
*
* Check error code from SSYTRS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SSYTRS', INFO, 0, UPLO, N,
$ N, -1, -1, NRHS, IMAT, NFAIL,
$ NERRS, NOUT )
*
CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
CALL SPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
$ LDA, RWORK, RESULT( 3 ) )
*
*+ TEST 4
* Check solution from generated exact solution.
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 4 ) )
*
*+ TESTS 5, 6, and 7
* Use iterative refinement to improve the solution.
*
SRNAMT = 'SSYRFS'
CALL SSYRFS( UPLO, N, NRHS, A, LDA, AFAC, LDA,
$ IWORK, B, LDA, X, LDA, RWORK,
$ RWORK( NRHS+1 ), WORK, IWORK( N+1 ),
$ INFO )
*
* Check error code from SSYRFS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SSYRFS', INFO, 0, UPLO, N,
$ N, -1, -1, NRHS, IMAT, NFAIL,
$ NERRS, NOUT )
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 5 ) )
CALL SPOT05( UPLO, N, NRHS, A, LDA, B, LDA, X, LDA,
$ XACT, LDA, RWORK, RWORK( NRHS+1 ),
$ RESULT( 6 ) )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 120 K = 3, 7
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS,
$ IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
120 CONTINUE
NRUN = NRUN + 5
130 CONTINUE
*
*+ TEST 8
* Get an estimate of RCOND = 1/CNDNUM.
*
140 CONTINUE
ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK )
SRNAMT = 'SSYCON'
CALL SSYCON( UPLO, N, AFAC, LDA, IWORK, ANORM, RCOND,
$ WORK, IWORK( N+1 ), INFO )
*
* Check error code from SSYCON.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SSYCON', INFO, 0, UPLO, N, N,
$ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
RESULT( 8 ) = SGET06( RCOND, RCONDC )
*
* Print information about the tests that did not pass
* the threshold.
*
IF( RESULT( 8 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 8,
$ RESULT( 8 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
150 CONTINUE
*
160 CONTINUE
170 CONTINUE
180 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ',
$ I2, ', test ', I2, ', ratio =', G12.5 )
9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
$ I2, ', test(', I2, ') =', G12.5 )
9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
$ ', test(', I2, ') =', G12.5 )
RETURN
*
* End of SCHKSY
*
END
SUBROUTINE SCHKTB( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
$ NMAX, AB, AINV, B, X, XACT, WORK, RWORK, IWORK,
$ NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NMAX, NN, NNS, NOUT
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
REAL AB( * ), AINV( * ), B( * ), RWORK( * ),
$ WORK( * ), X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* SCHKTB tests STBTRS, -RFS, and -CON, and SLATBS.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The leading dimension of the work arrays.
* NMAX >= the maximum value of N in NVAL.
*
* AB (workspace) REAL array, dimension (NMAX*NMAX)
*
* AINV (workspace) REAL array, dimension (NMAX*NMAX)
*
* B (workspace) REAL array, dimension (NMAX*NSMAX)
* where NSMAX is the largest entry in NSVAL.
*
* X (workspace) REAL array, dimension (NMAX*NSMAX)
*
* XACT (workspace) REAL array, dimension (NMAX*NSMAX)
*
* WORK (workspace) REAL array, dimension
* (NMAX*max(3,NSMAX))
*
* RWORK (workspace) REAL array, dimension
* (max(NMAX,2*NSMAX))
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTYPE1, NTYPES
PARAMETER ( NTYPE1 = 9, NTYPES = 17 )
INTEGER NTESTS
PARAMETER ( NTESTS = 8 )
INTEGER NTRAN
PARAMETER ( NTRAN = 3 )
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
CHARACTER DIAG, NORM, TRANS, UPLO, XTYPE
CHARACTER*3 PATH
INTEGER I, IDIAG, IK, IMAT, IN, INFO, IRHS, ITRAN,
$ IUPLO, J, K, KD, LDA, LDAB, N, NERRS, NFAIL,
$ NIMAT, NIMAT2, NK, NRHS, NRUN
REAL AINVNM, ANORM, RCOND, RCONDC, RCONDI, RCONDO,
$ SCALE
* ..
* .. Local Arrays ..
CHARACTER TRANSS( NTRAN ), UPLOS( 2 )
INTEGER ISEED( 4 ), ISEEDY( 4 )
REAL RESULT( NTESTS )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLANTB, SLANTR
EXTERNAL LSAME, SLANTB, SLANTR
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, SCOPY, SERRTR, SGET04,
$ SLACPY, SLARHS, SLASET, SLATBS, SLATTB, STBCON,
$ STBRFS, STBSV, STBT02, STBT03, STBT05, STBT06,
$ STBTRS
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, IOUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, IOUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
DATA UPLOS / 'U', 'L' / , TRANSS / 'N', 'T', 'C' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'TB'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL SERRTR( PATH, NOUT )
INFOT = 0
*
DO 140 IN = 1, NN
*
* Do for each value of N in NVAL
*
N = NVAL( IN )
LDA = MAX( 1, N )
XTYPE = 'N'
NIMAT = NTYPE1
NIMAT2 = NTYPES
IF( N.LE.0 ) THEN
NIMAT = 1
NIMAT2 = NTYPE1 + 1
END IF
*
NK = MIN( N+1, 4 )
DO 130 IK = 1, NK
*
* Do for KD = 0, N, (3N-1)/4, and (N+1)/4. This order makes
* it easier to skip redundant values for small values of N.
*
IF( IK.EQ.1 ) THEN
KD = 0
ELSE IF( IK.EQ.2 ) THEN
KD = MAX( N, 0 )
ELSE IF( IK.EQ.3 ) THEN
KD = ( 3*N-1 ) / 4
ELSE IF( IK.EQ.4 ) THEN
KD = ( N+1 ) / 4
END IF
LDAB = KD + 1
*
DO 90 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 90
*
DO 80 IUPLO = 1, 2
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
UPLO = UPLOS( IUPLO )
*
* Call SLATTB to generate a triangular test matrix.
*
SRNAMT = 'SLATTB'
CALL SLATTB( IMAT, UPLO, 'No transpose', DIAG, ISEED,
$ N, KD, AB, LDAB, X, WORK, INFO )
*
* Set IDIAG = 1 for non-unit matrices, 2 for unit.
*
IF( LSAME( DIAG, 'N' ) ) THEN
IDIAG = 1
ELSE
IDIAG = 2
END IF
*
* Form the inverse of A so we can get a good estimate
* of RCONDC = 1/(norm(A) * norm(inv(A))).
*
CALL SLASET( 'Full', N, N, ZERO, ONE, AINV, LDA )
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
CALL STBSV( UPLO, 'No transpose', DIAG, J, KD,
$ AB, LDAB, AINV( ( J-1 )*LDA+1 ), 1 )
20 CONTINUE
ELSE
DO 30 J = 1, N
CALL STBSV( UPLO, 'No transpose', DIAG, N-J+1,
$ KD, AB( ( J-1 )*LDAB+1 ), LDAB,
$ AINV( ( J-1 )*LDA+J ), 1 )
30 CONTINUE
END IF
*
* Compute the 1-norm condition number of A.
*
ANORM = SLANTB( '1', UPLO, DIAG, N, KD, AB, LDAB,
$ RWORK )
AINVNM = SLANTR( '1', UPLO, DIAG, N, N, AINV, LDA,
$ RWORK )
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDO = ONE
ELSE
RCONDO = ( ONE / ANORM ) / AINVNM
END IF
*
* Compute the infinity-norm condition number of A.
*
ANORM = SLANTB( 'I', UPLO, DIAG, N, KD, AB, LDAB,
$ RWORK )
AINVNM = SLANTR( 'I', UPLO, DIAG, N, N, AINV, LDA,
$ RWORK )
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDI = ONE
ELSE
RCONDI = ( ONE / ANORM ) / AINVNM
END IF
*
DO 60 IRHS = 1, NNS
NRHS = NSVAL( IRHS )
XTYPE = 'N'
*
DO 50 ITRAN = 1, NTRAN
*
* Do for op(A) = A, A**T, or A**H.
*
TRANS = TRANSS( ITRAN )
IF( ITRAN.EQ.1 ) THEN
NORM = 'O'
RCONDC = RCONDO
ELSE
NORM = 'I'
RCONDC = RCONDI
END IF
*
*+ TEST 1
* Solve and compute residual for op(A)*x = b.
*
SRNAMT = 'SLARHS'
CALL SLARHS( PATH, XTYPE, UPLO, TRANS, N, N, KD,
$ IDIAG, NRHS, AB, LDAB, XACT, LDA,
$ B, LDA, ISEED, INFO )
XTYPE = 'C'
CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
SRNAMT = 'STBTRS'
CALL STBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB,
$ LDAB, X, LDA, INFO )
*
* Check error code from STBTRS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'STBTRS', INFO, 0,
$ UPLO // TRANS // DIAG, N, N, KD,
$ KD, NRHS, IMAT, NFAIL, NERRS,
$ NOUT )
*
CALL STBT02( UPLO, TRANS, DIAG, N, KD, NRHS, AB,
$ LDAB, X, LDA, B, LDA, WORK,
$ RESULT( 1 ) )
*
*+ TEST 2
* Check solution from generated exact solution.
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 2 ) )
*
*+ TESTS 3, 4, and 5
* Use iterative refinement to improve the solution
* and compute error bounds.
*
SRNAMT = 'STBRFS'
CALL STBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB,
$ LDAB, B, LDA, X, LDA, RWORK,
$ RWORK( NRHS+1 ), WORK, IWORK,
$ INFO )
*
* Check error code from STBRFS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'STBRFS', INFO, 0,
$ UPLO // TRANS // DIAG, N, N, KD,
$ KD, NRHS, IMAT, NFAIL, NERRS,
$ NOUT )
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
CALL STBT05( UPLO, TRANS, DIAG, N, KD, NRHS, AB,
$ LDAB, B, LDA, X, LDA, XACT, LDA,
$ RWORK, RWORK( NRHS+1 ),
$ RESULT( 4 ) )
*
* Print information about the tests that did not
* pass the threshold.
*
DO 40 K = 1, 5
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )UPLO, TRANS,
$ DIAG, N, KD, NRHS, IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
40 CONTINUE
NRUN = NRUN + 5
50 CONTINUE
60 CONTINUE
*
*+ TEST 6
* Get an estimate of RCOND = 1/CNDNUM.
*
DO 70 ITRAN = 1, 2
IF( ITRAN.EQ.1 ) THEN
NORM = 'O'
RCONDC = RCONDO
ELSE
NORM = 'I'
RCONDC = RCONDI
END IF
SRNAMT = 'STBCON'
CALL STBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB,
$ RCOND, WORK, IWORK, INFO )
*
* Check error code from STBCON.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'STBCON', INFO, 0,
$ NORM // UPLO // DIAG, N, N, KD, KD,
$ -1, IMAT, NFAIL, NERRS, NOUT )
*
CALL STBT06( RCOND, RCONDC, UPLO, DIAG, N, KD, AB,
$ LDAB, RWORK, RESULT( 6 ) )
*
* Print information about the tests that did not pass
* the threshold.
*
IF( RESULT( 6 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 ) 'STBCON', NORM, UPLO,
$ DIAG, N, KD, IMAT, 6, RESULT( 6 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
70 CONTINUE
80 CONTINUE
90 CONTINUE
*
* Use pathological test matrices to test SLATBS.
*
DO 120 IMAT = NTYPE1 + 1, NIMAT2
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 120
*
DO 110 IUPLO = 1, 2
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
UPLO = UPLOS( IUPLO )
DO 100 ITRAN = 1, NTRAN
*
* Do for op(A) = A, A**T, and A**H.
*
TRANS = TRANSS( ITRAN )
*
* Call SLATTB to generate a triangular test matrix.
*
SRNAMT = 'SLATTB'
CALL SLATTB( IMAT, UPLO, TRANS, DIAG, ISEED, N, KD,
$ AB, LDAB, X, WORK, INFO )
*
*+ TEST 7
* Solve the system op(A)*x = b
*
SRNAMT = 'SLATBS'
CALL SCOPY( N, X, 1, B, 1 )
CALL SLATBS( UPLO, TRANS, DIAG, 'N', N, KD, AB,
$ LDAB, B, SCALE, RWORK, INFO )
*
* Check error code from SLATBS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SLATBS', INFO, 0,
$ UPLO // TRANS // DIAG // 'N', N, N,
$ KD, KD, -1, IMAT, NFAIL, NERRS,
$ NOUT )
*
CALL STBT03( UPLO, TRANS, DIAG, N, KD, 1, AB, LDAB,
$ SCALE, RWORK, ONE, B, LDA, X, LDA,
$ WORK, RESULT( 7 ) )
*
*+ TEST 8
* Solve op(A)*x = b again with NORMIN = 'Y'.
*
CALL SCOPY( N, X, 1, B, 1 )
CALL SLATBS( UPLO, TRANS, DIAG, 'Y', N, KD, AB,
$ LDAB, B, SCALE, RWORK, INFO )
*
* Check error code from SLATBS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SLATBS', INFO, 0,
$ UPLO // TRANS // DIAG // 'Y', N, N,
$ KD, KD, -1, IMAT, NFAIL, NERRS,
$ NOUT )
*
CALL STBT03( UPLO, TRANS, DIAG, N, KD, 1, AB, LDAB,
$ SCALE, RWORK, ONE, B, LDA, X, LDA,
$ WORK, RESULT( 8 ) )
*
* Print information about the tests that did not pass
* the threshold.
*
IF( RESULT( 7 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9997 )'SLATBS', UPLO, TRANS,
$ DIAG, 'N', N, KD, IMAT, 7, RESULT( 7 )
NFAIL = NFAIL + 1
END IF
IF( RESULT( 8 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9997 )'SLATBS', UPLO, TRANS,
$ DIAG, 'Y', N, KD, IMAT, 8, RESULT( 8 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 2
100 CONTINUE
110 CONTINUE
120 CONTINUE
130 CONTINUE
140 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' UPLO=''', A1, ''', TRANS=''', A1, ''',
$ DIAG=''', A1, ''', N=', I5, ', KD=', I5, ', NRHS=', I5,
$ ', type ', I2, ', test(', I2, ')=', G12.5 )
9998 FORMAT( 1X, A6, '( ''', A1, ''', ''', A1, ''', ''', A1, ''',',
$ I5, ',', I5, ', ... ), type ', I2, ', test(', I2, ')=',
$ G12.5 )
9997 FORMAT( 1X, A6, '( ''', A1, ''', ''', A1, ''', ''', A1, ''', ''',
$ A1, ''',', I5, ',', I5, ', ... ), type ', I2, ', test(',
$ I1, ')=', G12.5 )
RETURN
*
* End of SCHKTB
*
END
SUBROUTINE SCHKTP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
$ NMAX, AP, AINVP, B, X, XACT, WORK, RWORK,
$ IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NMAX, NN, NNS, NOUT
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
REAL AINVP( * ), AP( * ), B( * ), RWORK( * ),
$ WORK( * ), X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* SCHKTP tests STPTRI, -TRS, -RFS, and -CON, and SLATPS
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The leading dimension of the work arrays. NMAX >= the
* maximumm value of N in NVAL.
*
* AP (workspace) REAL array, dimension
* (NMAX*(NMAX+1)/2)
*
* AINVP (workspace) REAL array, dimension
* (NMAX*(NMAX+1)/2)
*
* B (workspace) REAL array, dimension (NMAX*NSMAX)
* where NSMAX is the largest entry in NSVAL.
*
* X (workspace) REAL array, dimension (NMAX*NSMAX)
*
* XACT (workspace) REAL array, dimension (NMAX*NSMAX)
*
* WORK (workspace) REAL array, dimension
* (NMAX*max(3,NSMAX))
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* RWORK (workspace) REAL array, dimension
* (max(NMAX,2*NSMAX))
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTYPE1, NTYPES
PARAMETER ( NTYPE1 = 10, NTYPES = 18 )
INTEGER NTESTS
PARAMETER ( NTESTS = 9 )
INTEGER NTRAN
PARAMETER ( NTRAN = 3 )
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
CHARACTER DIAG, NORM, TRANS, UPLO, XTYPE
CHARACTER*3 PATH
INTEGER I, IDIAG, IMAT, IN, INFO, IRHS, ITRAN, IUPLO,
$ K, LAP, LDA, N, NERRS, NFAIL, NRHS, NRUN
REAL AINVNM, ANORM, RCOND, RCONDC, RCONDI, RCONDO,
$ SCALE
* ..
* .. Local Arrays ..
CHARACTER TRANSS( NTRAN ), UPLOS( 2 )
INTEGER ISEED( 4 ), ISEEDY( 4 )
REAL RESULT( NTESTS )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLANTP
EXTERNAL LSAME, SLANTP
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, SCOPY, SERRTR, SGET04,
$ SLACPY, SLARHS, SLATPS, SLATTP, STPCON, STPRFS,
$ STPT01, STPT02, STPT03, STPT05, STPT06, STPTRI,
$ STPTRS
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, IOUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, IOUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
DATA UPLOS / 'U', 'L' / , TRANSS / 'N', 'T', 'C' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'TP'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL SERRTR( PATH, NOUT )
INFOT = 0
*
DO 110 IN = 1, NN
*
* Do for each value of N in NVAL
*
N = NVAL( IN )
LDA = MAX( 1, N )
LAP = LDA*( LDA+1 ) / 2
XTYPE = 'N'
*
DO 70 IMAT = 1, NTYPE1
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 70
*
DO 60 IUPLO = 1, 2
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
UPLO = UPLOS( IUPLO )
*
* Call SLATTP to generate a triangular test matrix.
*
SRNAMT = 'SLATTP'
CALL SLATTP( IMAT, UPLO, 'No transpose', DIAG, ISEED, N,
$ AP, X, WORK, INFO )
*
* Set IDIAG = 1 for non-unit matrices, 2 for unit.
*
IF( LSAME( DIAG, 'N' ) ) THEN
IDIAG = 1
ELSE
IDIAG = 2
END IF
*
*+ TEST 1
* Form the inverse of A.
*
IF( N.GT.0 )
$ CALL SCOPY( LAP, AP, 1, AINVP, 1 )
SRNAMT = 'STPTRI'
CALL STPTRI( UPLO, DIAG, N, AINVP, INFO )
*
* Check error code from STPTRI.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'STPTRI', INFO, 0, UPLO // DIAG, N,
$ N, -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
* Compute the infinity-norm condition number of A.
*
ANORM = SLANTP( 'I', UPLO, DIAG, N, AP, RWORK )
AINVNM = SLANTP( 'I', UPLO, DIAG, N, AINVP, RWORK )
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDI = ONE
ELSE
RCONDI = ( ONE / ANORM ) / AINVNM
END IF
*
* Compute the residual for the triangular matrix times its
* inverse. Also compute the 1-norm condition number of A.
*
CALL STPT01( UPLO, DIAG, N, AP, AINVP, RCONDO, RWORK,
$ RESULT( 1 ) )
*
* Print the test ratio if it is .GE. THRESH.
*
IF( RESULT( 1 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )UPLO, DIAG, N, IMAT, 1,
$ RESULT( 1 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
*
DO 40 IRHS = 1, NNS
NRHS = NSVAL( IRHS )
XTYPE = 'N'
*
DO 30 ITRAN = 1, NTRAN
*
* Do for op(A) = A, A**T, or A**H.
*
TRANS = TRANSS( ITRAN )
IF( ITRAN.EQ.1 ) THEN
NORM = 'O'
RCONDC = RCONDO
ELSE
NORM = 'I'
RCONDC = RCONDI
END IF
*
*+ TEST 2
* Solve and compute residual for op(A)*x = b.
*
SRNAMT = 'SLARHS'
CALL SLARHS( PATH, XTYPE, UPLO, TRANS, N, N, 0,
$ IDIAG, NRHS, AP, LAP, XACT, LDA, B,
$ LDA, ISEED, INFO )
XTYPE = 'C'
CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
SRNAMT = 'STPTRS'
CALL STPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, X,
$ LDA, INFO )
*
* Check error code from STPTRS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'STPTRS', INFO, 0,
$ UPLO // TRANS // DIAG, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
CALL STPT02( UPLO, TRANS, DIAG, N, NRHS, AP, X,
$ LDA, B, LDA, WORK, RESULT( 2 ) )
*
*+ TEST 3
* Check solution from generated exact solution.
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
*
*+ TESTS 4, 5, and 6
* Use iterative refinement to improve the solution and
* compute error bounds.
*
SRNAMT = 'STPRFS'
CALL STPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B,
$ LDA, X, LDA, RWORK, RWORK( NRHS+1 ),
$ WORK, IWORK, INFO )
*
* Check error code from STPRFS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'STPRFS', INFO, 0,
$ UPLO // TRANS // DIAG, N, N, -1,
$ -1, NRHS, IMAT, NFAIL, NERRS,
$ NOUT )
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 4 ) )
CALL STPT05( UPLO, TRANS, DIAG, N, NRHS, AP, B,
$ LDA, X, LDA, XACT, LDA, RWORK,
$ RWORK( NRHS+1 ), RESULT( 5 ) )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 20 K = 2, 6
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )UPLO, TRANS, DIAG,
$ N, NRHS, IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
20 CONTINUE
NRUN = NRUN + 5
30 CONTINUE
40 CONTINUE
*
*+ TEST 7
* Get an estimate of RCOND = 1/CNDNUM.
*
DO 50 ITRAN = 1, 2
IF( ITRAN.EQ.1 ) THEN
NORM = 'O'
RCONDC = RCONDO
ELSE
NORM = 'I'
RCONDC = RCONDI
END IF
*
SRNAMT = 'STPCON'
CALL STPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK,
$ IWORK, INFO )
*
* Check error code from STPCON.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'STPCON', INFO, 0,
$ NORM // UPLO // DIAG, N, N, -1, -1,
$ -1, IMAT, NFAIL, NERRS, NOUT )
*
CALL STPT06( RCOND, RCONDC, UPLO, DIAG, N, AP, RWORK,
$ RESULT( 7 ) )
*
* Print the test ratio if it is .GE. THRESH.
*
IF( RESULT( 7 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9997 ) 'STPCON', NORM, UPLO,
$ DIAG, N, IMAT, 7, RESULT( 7 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
50 CONTINUE
60 CONTINUE
70 CONTINUE
*
* Use pathological test matrices to test SLATPS.
*
DO 100 IMAT = NTYPE1 + 1, NTYPES
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 100
*
DO 90 IUPLO = 1, 2
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
UPLO = UPLOS( IUPLO )
DO 80 ITRAN = 1, NTRAN
*
* Do for op(A) = A, A**T, or A**H.
*
TRANS = TRANSS( ITRAN )
*
* Call SLATTP to generate a triangular test matrix.
*
SRNAMT = 'SLATTP'
CALL SLATTP( IMAT, UPLO, TRANS, DIAG, ISEED, N, AP, X,
$ WORK, INFO )
*
*+ TEST 8
* Solve the system op(A)*x = b.
*
SRNAMT = 'SLATPS'
CALL SCOPY( N, X, 1, B, 1 )
CALL SLATPS( UPLO, TRANS, DIAG, 'N', N, AP, B, SCALE,
$ RWORK, INFO )
*
* Check error code from SLATPS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SLATPS', INFO, 0,
$ UPLO // TRANS // DIAG // 'N', N, N,
$ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
CALL STPT03( UPLO, TRANS, DIAG, N, 1, AP, SCALE,
$ RWORK, ONE, B, LDA, X, LDA, WORK,
$ RESULT( 8 ) )
*
*+ TEST 9
* Solve op(A)*x = b again with NORMIN = 'Y'.
*
CALL SCOPY( N, X, 1, B( N+1 ), 1 )
CALL SLATPS( UPLO, TRANS, DIAG, 'Y', N, AP, B( N+1 ),
$ SCALE, RWORK, INFO )
*
* Check error code from SLATPS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SLATPS', INFO, 0,
$ UPLO // TRANS // DIAG // 'Y', N, N,
$ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
CALL STPT03( UPLO, TRANS, DIAG, N, 1, AP, SCALE,
$ RWORK, ONE, B( N+1 ), LDA, X, LDA, WORK,
$ RESULT( 9 ) )
*
* Print information about the tests that did not pass
* the threshold.
*
IF( RESULT( 8 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9996 )'SLATPS', UPLO, TRANS,
$ DIAG, 'N', N, IMAT, 8, RESULT( 8 )
NFAIL = NFAIL + 1
END IF
IF( RESULT( 9 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9996 )'SLATPS', UPLO, TRANS,
$ DIAG, 'Y', N, IMAT, 9, RESULT( 9 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 2
80 CONTINUE
90 CONTINUE
100 CONTINUE
110 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' UPLO=''', A1, ''', DIAG=''', A1, ''', N=', I5,
$ ', type ', I2, ', test(', I2, ')= ', G12.5 )
9998 FORMAT( ' UPLO=''', A1, ''', TRANS=''', A1, ''', DIAG=''', A1,
$ ''', N=', I5, ''', NRHS=', I5, ', type ', I2, ', test(',
$ I2, ')= ', G12.5 )
9997 FORMAT( 1X, A6, '( ''', A1, ''', ''', A1, ''', ''', A1, ''',',
$ I5, ', ... ), type ', I2, ', test(', I2, ')=', G12.5 )
9996 FORMAT( 1X, A6, '( ''', A1, ''', ''', A1, ''', ''', A1, ''', ''',
$ A1, ''',', I5, ', ... ), type ', I2, ', test(', I2, ')=',
$ G12.5 )
RETURN
*
* End of SCHKTP
*
END
SUBROUTINE SCHKTR( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
$ THRESH, TSTERR, NMAX, A, AINV, B, X, XACT,
$ WORK, RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NMAX, NN, NNB, NNS, NOUT
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
REAL A( * ), AINV( * ), B( * ), RWORK( * ),
$ WORK( * ), X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* SCHKTR tests STRTRI, -TRS, -RFS, and -CON, and SLATRS
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NNB (input) INTEGER
* The number of values of NB contained in the vector NBVAL.
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The leading dimension of the work arrays.
* NMAX >= the maximum value of N in NVAL.
*
* A (workspace) REAL array, dimension (NMAX*NMAX)
*
* AINV (workspace) REAL array, dimension (NMAX*NMAX)
*
* B (workspace) REAL array, dimension (NMAX*NSMAX)
* where NSMAX is the largest entry in NSVAL.
*
* X (workspace) REAL array, dimension (NMAX*NSMAX)
*
* XACT (workspace) REAL array, dimension (NMAX*NSMAX)
*
* WORK (workspace) REAL array, dimension
* (NMAX*max(3,NSMAX))
*
* RWORK (workspace) REAL array, dimension
* (max(NMAX,2*NSMAX))
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTYPE1, NTYPES
PARAMETER ( NTYPE1 = 10, NTYPES = 18 )
INTEGER NTESTS
PARAMETER ( NTESTS = 9 )
INTEGER NTRAN
PARAMETER ( NTRAN = 3 )
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
CHARACTER DIAG, NORM, TRANS, UPLO, XTYPE
CHARACTER*3 PATH
INTEGER I, IDIAG, IMAT, IN, INB, INFO, IRHS, ITRAN,
$ IUPLO, K, LDA, N, NB, NERRS, NFAIL, NRHS, NRUN
REAL AINVNM, ANORM, DUMMY, RCOND, RCONDC, RCONDI,
$ RCONDO, SCALE
* ..
* .. Local Arrays ..
CHARACTER TRANSS( NTRAN ), UPLOS( 2 )
INTEGER ISEED( 4 ), ISEEDY( 4 )
REAL RESULT( NTESTS )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLANTR
EXTERNAL LSAME, SLANTR
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, SCOPY, SERRTR, SGET04,
$ SLACPY, SLARHS, SLATRS, SLATTR, STRCON, STRRFS,
$ STRT01, STRT02, STRT03, STRT05, STRT06, STRTRI,
$ STRTRS, XLAENV
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, IOUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, IOUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
DATA UPLOS / 'U', 'L' / , TRANSS / 'N', 'T', 'C' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'TR'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL SERRTR( PATH, NOUT )
INFOT = 0
CALL XLAENV( 2, 2 )
*
DO 120 IN = 1, NN
*
* Do for each value of N in NVAL
*
N = NVAL( IN )
LDA = MAX( 1, N )
XTYPE = 'N'
*
DO 80 IMAT = 1, NTYPE1
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 80
*
DO 70 IUPLO = 1, 2
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
UPLO = UPLOS( IUPLO )
*
* Call SLATTR to generate a triangular test matrix.
*
SRNAMT = 'SLATTR'
CALL SLATTR( IMAT, UPLO, 'No transpose', DIAG, ISEED, N,
$ A, LDA, X, WORK, INFO )
*
* Set IDIAG = 1 for non-unit matrices, 2 for unit.
*
IF( LSAME( DIAG, 'N' ) ) THEN
IDIAG = 1
ELSE
IDIAG = 2
END IF
*
DO 60 INB = 1, NNB
*
* Do for each blocksize in NBVAL
*
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
*
*+ TEST 1
* Form the inverse of A.
*
CALL SLACPY( UPLO, N, N, A, LDA, AINV, LDA )
SRNAMT = 'STRTRI'
CALL STRTRI( UPLO, DIAG, N, AINV, LDA, INFO )
*
* Check error code from STRTRI.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'STRTRI', INFO, 0, UPLO // DIAG,
$ N, N, -1, -1, NB, IMAT, NFAIL, NERRS,
$ NOUT )
*
* Compute the infinity-norm condition number of A.
*
ANORM = SLANTR( 'I', UPLO, DIAG, N, N, A, LDA, RWORK )
AINVNM = SLANTR( 'I', UPLO, DIAG, N, N, AINV, LDA,
$ RWORK )
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDI = ONE
ELSE
RCONDI = ( ONE / ANORM ) / AINVNM
END IF
*
* Compute the residual for the triangular matrix times
* its inverse. Also compute the 1-norm condition number
* of A.
*
CALL STRT01( UPLO, DIAG, N, A, LDA, AINV, LDA, RCONDO,
$ RWORK, RESULT( 1 ) )
*
* Print the test ratio if it is .GE. THRESH.
*
IF( RESULT( 1 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )UPLO, DIAG, N, NB, IMAT,
$ 1, RESULT( 1 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
*
* Skip remaining tests if not the first block size.
*
IF( INB.NE.1 )
$ GO TO 60
*
DO 40 IRHS = 1, NNS
NRHS = NSVAL( IRHS )
XTYPE = 'N'
*
DO 30 ITRAN = 1, NTRAN
*
* Do for op(A) = A, A**T, or A**H.
*
TRANS = TRANSS( ITRAN )
IF( ITRAN.EQ.1 ) THEN
NORM = 'O'
RCONDC = RCONDO
ELSE
NORM = 'I'
RCONDC = RCONDI
END IF
*
*+ TEST 2
* Solve and compute residual for op(A)*x = b.
*
SRNAMT = 'SLARHS'
CALL SLARHS( PATH, XTYPE, UPLO, TRANS, N, N, 0,
$ IDIAG, NRHS, A, LDA, XACT, LDA, B,
$ LDA, ISEED, INFO )
XTYPE = 'C'
CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
SRNAMT = 'STRTRS'
CALL STRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA,
$ X, LDA, INFO )
*
* Check error code from STRTRS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'STRTRS', INFO, 0,
$ UPLO // TRANS // DIAG, N, N, -1,
$ -1, NRHS, IMAT, NFAIL, NERRS,
$ NOUT )
*
* This line is needed on a Sun SPARCstation.
*
IF( N.GT.0 )
$ DUMMY = A( 1 )
*
CALL STRT02( UPLO, TRANS, DIAG, N, NRHS, A, LDA,
$ X, LDA, B, LDA, WORK, RESULT( 2 ) )
*
*+ TEST 3
* Check solution from generated exact solution.
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
*
*+ TESTS 4, 5, and 6
* Use iterative refinement to improve the solution
* and compute error bounds.
*
SRNAMT = 'STRRFS'
CALL STRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA,
$ B, LDA, X, LDA, RWORK,
$ RWORK( NRHS+1 ), WORK, IWORK,
$ INFO )
*
* Check error code from STRRFS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'STRRFS', INFO, 0,
$ UPLO // TRANS // DIAG, N, N, -1,
$ -1, NRHS, IMAT, NFAIL, NERRS,
$ NOUT )
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 4 ) )
CALL STRT05( UPLO, TRANS, DIAG, N, NRHS, A, LDA,
$ B, LDA, X, LDA, XACT, LDA, RWORK,
$ RWORK( NRHS+1 ), RESULT( 5 ) )
*
* Print information about the tests that did not
* pass the threshold.
*
DO 20 K = 2, 6
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )UPLO, TRANS,
$ DIAG, N, NRHS, IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
20 CONTINUE
NRUN = NRUN + 5
30 CONTINUE
40 CONTINUE
*
*+ TEST 7
* Get an estimate of RCOND = 1/CNDNUM.
*
DO 50 ITRAN = 1, 2
IF( ITRAN.EQ.1 ) THEN
NORM = 'O'
RCONDC = RCONDO
ELSE
NORM = 'I'
RCONDC = RCONDI
END IF
SRNAMT = 'STRCON'
CALL STRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND,
$ WORK, IWORK, INFO )
*
* Check error code from STRCON.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'STRCON', INFO, 0,
$ NORM // UPLO // DIAG, N, N, -1, -1,
$ -1, IMAT, NFAIL, NERRS, NOUT )
*
CALL STRT06( RCOND, RCONDC, UPLO, DIAG, N, A, LDA,
$ RWORK, RESULT( 7 ) )
*
* Print the test ratio if it is .GE. THRESH.
*
IF( RESULT( 7 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9997 )NORM, UPLO, N, IMAT,
$ 7, RESULT( 7 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
50 CONTINUE
60 CONTINUE
70 CONTINUE
80 CONTINUE
*
* Use pathological test matrices to test SLATRS.
*
DO 110 IMAT = NTYPE1 + 1, NTYPES
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 110
*
DO 100 IUPLO = 1, 2
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
UPLO = UPLOS( IUPLO )
DO 90 ITRAN = 1, NTRAN
*
* Do for op(A) = A, A**T, and A**H.
*
TRANS = TRANSS( ITRAN )
*
* Call SLATTR to generate a triangular test matrix.
*
SRNAMT = 'SLATTR'
CALL SLATTR( IMAT, UPLO, TRANS, DIAG, ISEED, N, A,
$ LDA, X, WORK, INFO )
*
*+ TEST 8
* Solve the system op(A)*x = b.
*
SRNAMT = 'SLATRS'
CALL SCOPY( N, X, 1, B, 1 )
CALL SLATRS( UPLO, TRANS, DIAG, 'N', N, A, LDA, B,
$ SCALE, RWORK, INFO )
*
* Check error code from SLATRS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SLATRS', INFO, 0,
$ UPLO // TRANS // DIAG // 'N', N, N,
$ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
CALL STRT03( UPLO, TRANS, DIAG, N, 1, A, LDA, SCALE,
$ RWORK, ONE, B, LDA, X, LDA, WORK,
$ RESULT( 8 ) )
*
*+ TEST 9
* Solve op(A)*X = b again with NORMIN = 'Y'.
*
CALL SCOPY( N, X, 1, B( N+1 ), 1 )
CALL SLATRS( UPLO, TRANS, DIAG, 'Y', N, A, LDA,
$ B( N+1 ), SCALE, RWORK, INFO )
*
* Check error code from SLATRS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SLATRS', INFO, 0,
$ UPLO // TRANS // DIAG // 'Y', N, N,
$ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
CALL STRT03( UPLO, TRANS, DIAG, N, 1, A, LDA, SCALE,
$ RWORK, ONE, B( N+1 ), LDA, X, LDA, WORK,
$ RESULT( 9 ) )
*
* Print information about the tests that did not pass
* the threshold.
*
IF( RESULT( 8 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9996 )'SLATRS', UPLO, TRANS,
$ DIAG, 'N', N, IMAT, 8, RESULT( 8 )
NFAIL = NFAIL + 1
END IF
IF( RESULT( 9 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9996 )'SLATRS', UPLO, TRANS,
$ DIAG, 'Y', N, IMAT, 9, RESULT( 9 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 2
90 CONTINUE
100 CONTINUE
110 CONTINUE
120 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' UPLO=''', A1, ''', DIAG=''', A1, ''', N=', I5, ', NB=',
$ I4, ', type ', I2, ', test(', I2, ')= ', G12.5 )
9998 FORMAT( ' UPLO=''', A1, ''', TRANS=''', A1, ''', DIAG=''', A1,
$ ''', N=', I5, ', NB=', I4, ', type ', I2, ',
$ test(', I2, ')= ', G12.5 )
9997 FORMAT( ' NORM=''', A1, ''', UPLO =''', A1, ''', N=', I5, ',',
$ 11X, ' type ', I2, ', test(', I2, ')=', G12.5 )
9996 FORMAT( 1X, A6, '( ''', A1, ''', ''', A1, ''', ''', A1, ''', ''',
$ A1, ''',', I5, ', ... ), type ', I2, ', test(', I2, ')=',
$ G12.5 )
RETURN
*
* End of SCHKTR
*
END
SUBROUTINE SCHKTZ( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A,
$ COPYA, S, COPYS, TAU, WORK, NOUT )
*
* -- LAPACK test routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* January 2007
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NM, NN, NOUT
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER MVAL( * ), NVAL( * )
REAL A( * ), COPYA( * ), COPYS( * ), S( * ),
$ TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SCHKTZ tests STZRQF and STZRZF.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* A (workspace) REAL array, dimension (MMAX*NMAX)
* where MMAX is the maximum value of M in MVAL and NMAX is the
* maximum value of N in NVAL.
*
* COPYA (workspace) REAL array, dimension (MMAX*NMAX)
*
* S (workspace) REAL array, dimension
* (min(MMAX,NMAX))
*
* COPYS (workspace) REAL array, dimension
* (min(MMAX,NMAX))
*
* TAU (workspace) REAL array, dimension (MMAX)
*
* WORK (workspace) REAL array, dimension
* (MMAX*NMAX + 4*NMAX + MMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTYPES
PARAMETER ( NTYPES = 3 )
INTEGER NTESTS
PARAMETER ( NTESTS = 6 )
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
CHARACTER*3 PATH
INTEGER I, IM, IMODE, IN, INFO, K, LDA, LWORK, M,
$ MNMIN, MODE, N, NERRS, NFAIL, NRUN
REAL EPS
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 ), ISEEDY( 4 )
REAL RESULT( NTESTS )
* ..
* .. External Functions ..
REAL SLAMCH, SQRT12, SRZT01, SRZT02, STZT01, STZT02
EXTERNAL SLAMCH, SQRT12, SRZT01, SRZT02, STZT01, STZT02
* ..
* .. External Subroutines ..
EXTERNAL ALAHD, ALASUM, SERRTZ, SGEQR2, SLACPY, SLAORD,
$ SLASET, SLATMS, STZRQF, STZRZF
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, IOUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, IOUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'TZ'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
EPS = SLAMCH( 'Epsilon' )
*
* Test the error exits
*
IF( TSTERR )
$ CALL SERRTZ( PATH, NOUT )
INFOT = 0
*
DO 70 IM = 1, NM
*
* Do for each value of M in MVAL.
*
M = MVAL( IM )
LDA = MAX( 1, M )
*
DO 60 IN = 1, NN
*
* Do for each value of N in NVAL for which M .LE. N.
*
N = NVAL( IN )
MNMIN = MIN( M, N )
LWORK = MAX( 1, N*N+4*M+N, M*N+2*MNMIN+4*N )
*
IF( M.LE.N ) THEN
DO 50 IMODE = 1, NTYPES
IF( .NOT.DOTYPE( IMODE ) )
$ GO TO 50
*
* Do for each type of singular value distribution.
* 0: zero matrix
* 1: one small singular value
* 2: exponential distribution
*
MODE = IMODE - 1
*
* Test STZRQF
*
* Generate test matrix of size m by n using
* singular value distribution indicated by `mode'.
*
IF( MODE.EQ.0 ) THEN
CALL SLASET( 'Full', M, N, ZERO, ZERO, A, LDA )
DO 20 I = 1, MNMIN
COPYS( I ) = ZERO
20 CONTINUE
ELSE
CALL SLATMS( M, N, 'Uniform', ISEED,
$ 'Nonsymmetric', COPYS, IMODE,
$ ONE / EPS, ONE, M, N, 'No packing', A,
$ LDA, WORK, INFO )
CALL SGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ),
$ INFO )
CALL SLASET( 'Lower', M-1, N, ZERO, ZERO, A( 2 ),
$ LDA )
CALL SLAORD( 'Decreasing', MNMIN, COPYS, 1 )
END IF
*
* Save A and its singular values
*
CALL SLACPY( 'All', M, N, A, LDA, COPYA, LDA )
*
* Call STZRQF to reduce the upper trapezoidal matrix to
* upper triangular form.
*
SRNAMT = 'STZRQF'
CALL STZRQF( M, N, A, LDA, TAU, INFO )
*
* Compute norm(svd(a) - svd(r))
*
RESULT( 1 ) = SQRT12( M, M, A, LDA, COPYS, WORK,
$ LWORK )
*
* Compute norm( A - R*Q )
*
RESULT( 2 ) = STZT01( M, N, COPYA, A, LDA, TAU, WORK,
$ LWORK )
*
* Compute norm(Q'*Q - I).
*
RESULT( 3 ) = STZT02( M, N, A, LDA, TAU, WORK, LWORK )
*
* Test STZRZF
*
* Generate test matrix of size m by n using
* singular value distribution indicated by `mode'.
*
IF( MODE.EQ.0 ) THEN
CALL SLASET( 'Full', M, N, ZERO, ZERO, A, LDA )
DO 30 I = 1, MNMIN
COPYS( I ) = ZERO
30 CONTINUE
ELSE
CALL SLATMS( M, N, 'Uniform', ISEED,
$ 'Nonsymmetric', COPYS, IMODE,
$ ONE / EPS, ONE, M, N, 'No packing', A,
$ LDA, WORK, INFO )
CALL SGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ),
$ INFO )
CALL SLASET( 'Lower', M-1, N, ZERO, ZERO, A( 2 ),
$ LDA )
CALL SLAORD( 'Decreasing', MNMIN, COPYS, 1 )
END IF
*
* Save A and its singular values
*
CALL SLACPY( 'All', M, N, A, LDA, COPYA, LDA )
*
* Call STZRZF to reduce the upper trapezoidal matrix to
* upper triangular form.
*
SRNAMT = 'STZRZF'
CALL STZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* Compute norm(svd(a) - svd(r))
*
RESULT( 4 ) = SQRT12( M, M, A, LDA, COPYS, WORK,
$ LWORK )
*
* Compute norm( A - R*Q )
*
RESULT( 5 ) = SRZT01( M, N, COPYA, A, LDA, TAU, WORK,
$ LWORK )
*
* Compute norm(Q'*Q - I).
*
RESULT( 6 ) = SRZT02( M, N, A, LDA, TAU, WORK, LWORK )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 40 K = 1, 6
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )M, N, IMODE, K,
$ RESULT( K )
NFAIL = NFAIL + 1
END IF
40 CONTINUE
NRUN = NRUN + 6
50 CONTINUE
END IF
60 CONTINUE
70 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' M =', I5, ', N =', I5, ', type ', I2, ', test ', I2,
$ ', ratio =', G12.5 )
*
* End if SCHKTZ
*
END
SUBROUTINE SDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA,
$ AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK,
$ RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER LA, LAFB, NN, NOUT, NRHS
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NVAL( * )
REAL A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ),
$ RWORK( * ), S( * ), WORK( * ), X( * ),
$ XACT( * )
* ..
*
* Purpose
* =======
*
* SDRVGB tests the driver routines SGBSV and -SVX.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NRHS (input) INTEGER
* The number of right hand side vectors to be generated for
* each linear system.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* A (workspace) REAL array, dimension (LA)
*
* LA (input) INTEGER
* The length of the array A. LA >= (2*NMAX-1)*NMAX
* where NMAX is the largest entry in NVAL.
*
* AFB (workspace) REAL array, dimension (LAFB)
*
* LAFB (input) INTEGER
* The length of the array AFB. LAFB >= (3*NMAX-2)*NMAX
* where NMAX is the largest entry in NVAL.
*
* ASAV (workspace) REAL array, dimension (LA)
*
* B (workspace) REAL array, dimension (NMAX*NRHS)
*
* BSAV (workspace) REAL array, dimension (NMAX*NRHS)
*
* X (workspace) REAL array, dimension (NMAX*NRHS)
*
* XACT (workspace) REAL array, dimension (NMAX*NRHS)
*
* S (workspace) REAL array, dimension (2*NMAX)
*
* WORK (workspace) REAL array, dimension
* (NMAX*max(3,NRHS,NMAX))
*
* RWORK (workspace) REAL array, dimension
* (max(NMAX,2*NRHS))
*
* IWORK (workspace) INTEGER array, dimension (2*NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
INTEGER NTYPES
PARAMETER ( NTYPES = 8 )
INTEGER NTESTS
PARAMETER ( NTESTS = 7 )
INTEGER NTRAN
PARAMETER ( NTRAN = 3 )
* ..
* .. Local Scalars ..
LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT
CHARACTER DIST, EQUED, FACT, TRANS, TYPE, XTYPE
CHARACTER*3 PATH
INTEGER I, I1, I2, IEQUED, IFACT, IKL, IKU, IMAT, IN,
$ INFO, IOFF, ITRAN, IZERO, J, K, K1, KL, KU,
$ LDA, LDAFB, LDB, MODE, N, NB, NBMIN, NERRS,
$ NFACT, NFAIL, NIMAT, NKL, NKU, NRUN, NT
REAL AINVNM, AMAX, ANORM, ANORMI, ANORMO, ANRMPV,
$ CNDNUM, COLCND, RCOND, RCONDC, RCONDI, RCONDO,
$ ROLDC, ROLDI, ROLDO, ROWCND, RPVGRW
* ..
* .. Local Arrays ..
CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN )
INTEGER ISEED( 4 ), ISEEDY( 4 )
REAL RESULT( NTESTS )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SGET06, SLAMCH, SLANGB, SLANGE, SLANTB
EXTERNAL LSAME, SGET06, SLAMCH, SLANGB, SLANGE, SLANTB
* ..
* .. External Subroutines ..
EXTERNAL ALADHD, ALAERH, ALASVM, SERRVX, SGBEQU, SGBSV,
$ SGBSVX, SGBT01, SGBT02, SGBT05, SGBTRF, SGBTRS,
$ SGET04, SLACPY, SLAQGB, SLARHS, SLASET, SLATB4,
$ SLATMS, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
DATA TRANSS / 'N', 'T', 'C' /
DATA FACTS / 'F', 'N', 'E' /
DATA EQUEDS / 'N', 'R', 'C', 'B' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'GB'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL SERRVX( PATH, NOUT )
INFOT = 0
*
* Set the block size and minimum block size for testing.
*
NB = 1
NBMIN = 2
CALL XLAENV( 1, NB )
CALL XLAENV( 2, NBMIN )
*
* Do for each value of N in NVAL
*
DO 150 IN = 1, NN
N = NVAL( IN )
LDB = MAX( N, 1 )
XTYPE = 'N'
*
* Set limits on the number of loop iterations.
*
NKL = MAX( 1, MIN( N, 4 ) )
IF( N.EQ.0 )
$ NKL = 1
NKU = NKL
NIMAT = NTYPES
IF( N.LE.0 )
$ NIMAT = 1
*
DO 140 IKL = 1, NKL
*
* Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes
* it easier to skip redundant values for small values of N.
*
IF( IKL.EQ.1 ) THEN
KL = 0
ELSE IF( IKL.EQ.2 ) THEN
KL = MAX( N-1, 0 )
ELSE IF( IKL.EQ.3 ) THEN
KL = ( 3*N-1 ) / 4
ELSE IF( IKL.EQ.4 ) THEN
KL = ( N+1 ) / 4
END IF
DO 130 IKU = 1, NKU
*
* Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order
* makes it easier to skip redundant values for small
* values of N.
*
IF( IKU.EQ.1 ) THEN
KU = 0
ELSE IF( IKU.EQ.2 ) THEN
KU = MAX( N-1, 0 )
ELSE IF( IKU.EQ.3 ) THEN
KU = ( 3*N-1 ) / 4
ELSE IF( IKU.EQ.4 ) THEN
KU = ( N+1 ) / 4
END IF
*
* Check that A and AFB are big enough to generate this
* matrix.
*
LDA = KL + KU + 1
LDAFB = 2*KL + KU + 1
IF( LDA*N.GT.LA .OR. LDAFB*N.GT.LAFB ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
IF( LDA*N.GT.LA ) THEN
WRITE( NOUT, FMT = 9999 )LA, N, KL, KU,
$ N*( KL+KU+1 )
NERRS = NERRS + 1
END IF
IF( LDAFB*N.GT.LAFB ) THEN
WRITE( NOUT, FMT = 9998 )LAFB, N, KL, KU,
$ N*( 2*KL+KU+1 )
NERRS = NERRS + 1
END IF
GO TO 130
END IF
*
DO 120 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 120
*
* Skip types 2, 3, or 4 if the matrix is too small.
*
ZEROT = IMAT.GE.2 .AND. IMAT.LE.4
IF( ZEROT .AND. N.LT.IMAT-1 )
$ GO TO 120
*
* Set up parameters with SLATB4 and generate a
* test matrix with SLATMS.
*
CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM,
$ MODE, CNDNUM, DIST )
RCONDC = ONE / CNDNUM
*
SRNAMT = 'SLATMS'
CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, 'Z', A, LDA, WORK,
$ INFO )
*
* Check the error code from SLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', N, N,
$ KL, KU, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 120
END IF
*
* For types 2, 3, and 4, zero one or more columns of
* the matrix to test that INFO is returned correctly.
*
IZERO = 0
IF( ZEROT ) THEN
IF( IMAT.EQ.2 ) THEN
IZERO = 1
ELSE IF( IMAT.EQ.3 ) THEN
IZERO = N
ELSE
IZERO = N / 2 + 1
END IF
IOFF = ( IZERO-1 )*LDA
IF( IMAT.LT.4 ) THEN
I1 = MAX( 1, KU+2-IZERO )
I2 = MIN( KL+KU+1, KU+1+( N-IZERO ) )
DO 20 I = I1, I2
A( IOFF+I ) = ZERO
20 CONTINUE
ELSE
DO 40 J = IZERO, N
DO 30 I = MAX( 1, KU+2-J ),
$ MIN( KL+KU+1, KU+1+( N-J ) )
A( IOFF+I ) = ZERO
30 CONTINUE
IOFF = IOFF + LDA
40 CONTINUE
END IF
END IF
*
* Save a copy of the matrix A in ASAV.
*
CALL SLACPY( 'Full', KL+KU+1, N, A, LDA, ASAV, LDA )
*
DO 110 IEQUED = 1, 4
EQUED = EQUEDS( IEQUED )
IF( IEQUED.EQ.1 ) THEN
NFACT = 3
ELSE
NFACT = 1
END IF
*
DO 100 IFACT = 1, NFACT
FACT = FACTS( IFACT )
PREFAC = LSAME( FACT, 'F' )
NOFACT = LSAME( FACT, 'N' )
EQUIL = LSAME( FACT, 'E' )
*
IF( ZEROT ) THEN
IF( PREFAC )
$ GO TO 100
RCONDO = ZERO
RCONDI = ZERO
*
ELSE IF( .NOT.NOFACT ) THEN
*
* Compute the condition number for comparison
* with the value returned by SGESVX (FACT =
* 'N' reuses the condition number from the
* previous iteration with FACT = 'F').
*
CALL SLACPY( 'Full', KL+KU+1, N, ASAV, LDA,
$ AFB( KL+1 ), LDAFB )
IF( EQUIL .OR. IEQUED.GT.1 ) THEN
*
* Compute row and column scale factors to
* equilibrate the matrix A.
*
CALL SGBEQU( N, N, KL, KU, AFB( KL+1 ),
$ LDAFB, S, S( N+1 ), ROWCND,
$ COLCND, AMAX, INFO )
IF( INFO.EQ.0 .AND. N.GT.0 ) THEN
IF( LSAME( EQUED, 'R' ) ) THEN
ROWCND = ZERO
COLCND = ONE
ELSE IF( LSAME( EQUED, 'C' ) ) THEN
ROWCND = ONE
COLCND = ZERO
ELSE IF( LSAME( EQUED, 'B' ) ) THEN
ROWCND = ZERO
COLCND = ZERO
END IF
*
* Equilibrate the matrix.
*
CALL SLAQGB( N, N, KL, KU, AFB( KL+1 ),
$ LDAFB, S, S( N+1 ),
$ ROWCND, COLCND, AMAX,
$ EQUED )
END IF
END IF
*
* Save the condition number of the
* non-equilibrated system for use in SGET04.
*
IF( EQUIL ) THEN
ROLDO = RCONDO
ROLDI = RCONDI
END IF
*
* Compute the 1-norm and infinity-norm of A.
*
ANORMO = SLANGB( '1', N, KL, KU, AFB( KL+1 ),
$ LDAFB, RWORK )
ANORMI = SLANGB( 'I', N, KL, KU, AFB( KL+1 ),
$ LDAFB, RWORK )
*
* Factor the matrix A.
*
CALL SGBTRF( N, N, KL, KU, AFB, LDAFB, IWORK,
$ INFO )
*
* Form the inverse of A.
*
CALL SLASET( 'Full', N, N, ZERO, ONE, WORK,
$ LDB )
SRNAMT = 'SGBTRS'
CALL SGBTRS( 'No transpose', N, KL, KU, N,
$ AFB, LDAFB, IWORK, WORK, LDB,
$ INFO )
*
* Compute the 1-norm condition number of A.
*
AINVNM = SLANGE( '1', N, N, WORK, LDB,
$ RWORK )
IF( ANORMO.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDO = ONE
ELSE
RCONDO = ( ONE / ANORMO ) / AINVNM
END IF
*
* Compute the infinity-norm condition number
* of A.
*
AINVNM = SLANGE( 'I', N, N, WORK, LDB,
$ RWORK )
IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDI = ONE
ELSE
RCONDI = ( ONE / ANORMI ) / AINVNM
END IF
END IF
*
DO 90 ITRAN = 1, NTRAN
*
* Do for each value of TRANS.
*
TRANS = TRANSS( ITRAN )
IF( ITRAN.EQ.1 ) THEN
RCONDC = RCONDO
ELSE
RCONDC = RCONDI
END IF
*
* Restore the matrix A.
*
CALL SLACPY( 'Full', KL+KU+1, N, ASAV, LDA,
$ A, LDA )
*
* Form an exact solution and set the right hand
* side.
*
SRNAMT = 'SLARHS'
CALL SLARHS( PATH, XTYPE, 'Full', TRANS, N,
$ N, KL, KU, NRHS, A, LDA, XACT,
$ LDB, B, LDB, ISEED, INFO )
XTYPE = 'C'
CALL SLACPY( 'Full', N, NRHS, B, LDB, BSAV,
$ LDB )
*
IF( NOFACT .AND. ITRAN.EQ.1 ) THEN
*
* --- Test SGBSV ---
*
* Compute the LU factorization of the matrix
* and solve the system.
*
CALL SLACPY( 'Full', KL+KU+1, N, A, LDA,
$ AFB( KL+1 ), LDAFB )
CALL SLACPY( 'Full', N, NRHS, B, LDB, X,
$ LDB )
*
SRNAMT = 'SGBSV '
CALL SGBSV( N, KL, KU, NRHS, AFB, LDAFB,
$ IWORK, X, LDB, INFO )
*
* Check error code from SGBSV .
*
IF( INFO.NE.IZERO )
$ CALL ALAERH( PATH, 'SGBSV ', INFO,
$ IZERO, ' ', N, N, KL, KU,
$ NRHS, IMAT, NFAIL, NERRS,
$ NOUT )
*
* Reconstruct matrix from factors and
* compute residual.
*
CALL SGBT01( N, N, KL, KU, A, LDA, AFB,
$ LDAFB, IWORK, WORK,
$ RESULT( 1 ) )
NT = 1
IF( IZERO.EQ.0 ) THEN
*
* Compute residual of the computed
* solution.
*
CALL SLACPY( 'Full', N, NRHS, B, LDB,
$ WORK, LDB )
CALL SGBT02( 'No transpose', N, N, KL,
$ KU, NRHS, A, LDA, X, LDB,
$ WORK, LDB, RESULT( 2 ) )
*
* Check solution from generated exact
* solution.
*
CALL SGET04( N, NRHS, X, LDB, XACT,
$ LDB, RCONDC, RESULT( 3 ) )
NT = 3
END IF
*
* Print information about the tests that did
* not pass the threshold.
*
DO 50 K = 1, NT
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
WRITE( NOUT, FMT = 9997 )'SGBSV ',
$ N, KL, KU, IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
50 CONTINUE
NRUN = NRUN + NT
END IF
*
* --- Test SGBSVX ---
*
IF( .NOT.PREFAC )
$ CALL SLASET( 'Full', 2*KL+KU+1, N, ZERO,
$ ZERO, AFB, LDAFB )
CALL SLASET( 'Full', N, NRHS, ZERO, ZERO, X,
$ LDB )
IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN
*
* Equilibrate the matrix if FACT = 'F' and
* EQUED = 'R', 'C', or 'B'.
*
CALL SLAQGB( N, N, KL, KU, A, LDA, S,
$ S( N+1 ), ROWCND, COLCND,
$ AMAX, EQUED )
END IF
*
* Solve the system and compute the condition
* number and error bounds using SGBSVX.
*
SRNAMT = 'SGBSVX'
CALL SGBSVX( FACT, TRANS, N, KL, KU, NRHS, A,
$ LDA, AFB, LDAFB, IWORK, EQUED,
$ S, S( N+1 ), B, LDB, X, LDB,
$ RCOND, RWORK, RWORK( NRHS+1 ),
$ WORK, IWORK( N+1 ), INFO )
*
* Check the error code from SGBSVX.
*
IF( INFO.NE.IZERO )
$ CALL ALAERH( PATH, 'SGBSVX', INFO, IZERO,
$ FACT // TRANS, N, N, KL, KU,
$ NRHS, IMAT, NFAIL, NERRS,
$ NOUT )
*
* Compare WORK(1) from SGBSVX with the computed
* reciprocal pivot growth factor RPVGRW
*
IF( INFO.NE.0 ) THEN
ANRMPV = ZERO
DO 70 J = 1, INFO
DO 60 I = MAX( KU+2-J, 1 ),
$ MIN( N+KU+1-J, KL+KU+1 )
ANRMPV = MAX( ANRMPV,
$ ABS( A( I+( J-1 )*LDA ) ) )
60 CONTINUE
70 CONTINUE
RPVGRW = SLANTB( 'M', 'U', 'N', INFO,
$ MIN( INFO-1, KL+KU ),
$ AFB( MAX( 1, KL+KU+2-INFO ) ),
$ LDAFB, WORK )
IF( RPVGRW.EQ.ZERO ) THEN
RPVGRW = ONE
ELSE
RPVGRW = ANRMPV / RPVGRW
END IF
ELSE
RPVGRW = SLANTB( 'M', 'U', 'N', N, KL+KU,
$ AFB, LDAFB, WORK )
IF( RPVGRW.EQ.ZERO ) THEN
RPVGRW = ONE
ELSE
RPVGRW = SLANGB( 'M', N, KL, KU, A,
$ LDA, WORK ) / RPVGRW
END IF
END IF
RESULT( 7 ) = ABS( RPVGRW-WORK( 1 ) ) /
$ MAX( WORK( 1 ), RPVGRW ) /
$ SLAMCH( 'E' )
*
IF( .NOT.PREFAC ) THEN
*
* Reconstruct matrix from factors and
* compute residual.
*
CALL SGBT01( N, N, KL, KU, A, LDA, AFB,
$ LDAFB, IWORK, WORK,
$ RESULT( 1 ) )
K1 = 1
ELSE
K1 = 2
END IF
*
IF( INFO.EQ.0 ) THEN
TRFCON = .FALSE.
*
* Compute residual of the computed solution.
*
CALL SLACPY( 'Full', N, NRHS, BSAV, LDB,
$ WORK, LDB )
CALL SGBT02( TRANS, N, N, KL, KU, NRHS,
$ ASAV, LDA, X, LDB, WORK, LDB,
$ RESULT( 2 ) )
*
* Check solution from generated exact
* solution.
*
IF( NOFACT .OR. ( PREFAC .AND.
$ LSAME( EQUED, 'N' ) ) ) THEN
CALL SGET04( N, NRHS, X, LDB, XACT,
$ LDB, RCONDC, RESULT( 3 ) )
ELSE
IF( ITRAN.EQ.1 ) THEN
ROLDC = ROLDO
ELSE
ROLDC = ROLDI
END IF
CALL SGET04( N, NRHS, X, LDB, XACT,
$ LDB, ROLDC, RESULT( 3 ) )
END IF
*
* Check the error bounds from iterative
* refinement.
*
CALL SGBT05( TRANS, N, KL, KU, NRHS, ASAV,
$ LDA, B, LDB, X, LDB, XACT,
$ LDB, RWORK, RWORK( NRHS+1 ),
$ RESULT( 4 ) )
ELSE
TRFCON = .TRUE.
END IF
*
* Compare RCOND from SGBSVX with the computed
* value in RCONDC.
*
RESULT( 6 ) = SGET06( RCOND, RCONDC )
*
* Print information about the tests that did
* not pass the threshold.
*
IF( .NOT.TRFCON ) THEN
DO 80 K = K1, NTESTS
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
IF( PREFAC ) THEN
WRITE( NOUT, FMT = 9995 )
$ 'SGBSVX', FACT, TRANS, N, KL,
$ KU, EQUED, IMAT, K,
$ RESULT( K )
ELSE
WRITE( NOUT, FMT = 9996 )
$ 'SGBSVX', FACT, TRANS, N, KL,
$ KU, IMAT, K, RESULT( K )
END IF
NFAIL = NFAIL + 1
END IF
80 CONTINUE
NRUN = NRUN + 7 - K1
ELSE
IF( RESULT( 1 ).GE.THRESH .AND. .NOT.
$ PREFAC ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
IF( PREFAC ) THEN
WRITE( NOUT, FMT = 9995 )'SGBSVX',
$ FACT, TRANS, N, KL, KU, EQUED,
$ IMAT, 1, RESULT( 1 )
ELSE
WRITE( NOUT, FMT = 9996 )'SGBSVX',
$ FACT, TRANS, N, KL, KU, IMAT, 1,
$ RESULT( 1 )
END IF
NFAIL = NFAIL + 1
NRUN = NRUN + 1
END IF
IF( RESULT( 6 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
IF( PREFAC ) THEN
WRITE( NOUT, FMT = 9995 )'SGBSVX',
$ FACT, TRANS, N, KL, KU, EQUED,
$ IMAT, 6, RESULT( 6 )
ELSE
WRITE( NOUT, FMT = 9996 )'SGBSVX',
$ FACT, TRANS, N, KL, KU, IMAT, 6,
$ RESULT( 6 )
END IF
NFAIL = NFAIL + 1
NRUN = NRUN + 1
END IF
IF( RESULT( 7 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
IF( PREFAC ) THEN
WRITE( NOUT, FMT = 9995 )'SGBSVX',
$ FACT, TRANS, N, KL, KU, EQUED,
$ IMAT, 7, RESULT( 7 )
ELSE
WRITE( NOUT, FMT = 9996 )'SGBSVX',
$ FACT, TRANS, N, KL, KU, IMAT, 7,
$ RESULT( 7 )
END IF
NFAIL = NFAIL + 1
NRUN = NRUN + 1
END IF
*
END IF
90 CONTINUE
100 CONTINUE
110 CONTINUE
120 CONTINUE
130 CONTINUE
140 CONTINUE
150 CONTINUE
*
* Print a summary of the results.
*
CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' *** In SDRVGB, LA=', I5, ' is too small for N=', I5,
$ ', KU=', I5, ', KL=', I5, / ' ==> Increase LA to at least ',
$ I5 )
9998 FORMAT( ' *** In SDRVGB, LAFB=', I5, ' is too small for N=', I5,
$ ', KU=', I5, ', KL=', I5, /
$ ' ==> Increase LAFB to at least ', I5 )
9997 FORMAT( 1X, A6, ', N=', I5, ', KL=', I5, ', KU=', I5, ', type ',
$ I1, ', test(', I1, ')=', G12.5 )
9996 FORMAT( 1X, A6, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',',
$ I5, ',...), type ', I1, ', test(', I1, ')=', G12.5 )
9995 FORMAT( 1X, A6, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',',
$ I5, ',...), EQUED=''', A1, ''', type ', I1, ', test(', I1,
$ ')=', G12.5 )
*
RETURN
*
* End of SDRVGB
*
END
SUBROUTINE SDRVGE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
$ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK,
$ RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NMAX, NN, NOUT, NRHS
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NVAL( * )
REAL A( * ), AFAC( * ), ASAV( * ), B( * ),
$ BSAV( * ), RWORK( * ), S( * ), WORK( * ),
$ X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* SDRVGE tests the driver routines SGESV and -SVX.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NRHS (input) INTEGER
* The number of right hand side vectors to be generated for
* each linear system.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for N, used in dimensioning the
* work arrays.
*
* A (workspace) REAL array, dimension (NMAX*NMAX)
*
* AFAC (workspace) REAL array, dimension (NMAX*NMAX)
*
* ASAV (workspace) REAL array, dimension (NMAX*NMAX)
*
* B (workspace) REAL array, dimension (NMAX*NRHS)
*
* BSAV (workspace) REAL array, dimension (NMAX*NRHS)
*
* X (workspace) REAL array, dimension (NMAX*NRHS)
*
* XACT (workspace) REAL array, dimension (NMAX*NRHS)
*
* S (workspace) REAL array, dimension (2*NMAX)
*
* WORK (workspace) REAL array, dimension
* (NMAX*max(3,NRHS))
*
* RWORK (workspace) REAL array, dimension (2*NRHS+NMAX)
*
* IWORK (workspace) INTEGER array, dimension (2*NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
INTEGER NTYPES
PARAMETER ( NTYPES = 11 )
INTEGER NTESTS
PARAMETER ( NTESTS = 7 )
INTEGER NTRAN
PARAMETER ( NTRAN = 3 )
* ..
* .. Local Scalars ..
LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT
CHARACTER DIST, EQUED, FACT, TRANS, TYPE, XTYPE
CHARACTER*3 PATH
INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, ITRAN,
$ IZERO, K, K1, KL, KU, LDA, LWORK, MODE, N, NB,
$ NBMIN, NERRS, NFACT, NFAIL, NIMAT, NRUN, NT
REAL AINVNM, AMAX, ANORM, ANORMI, ANORMO, CNDNUM,
$ COLCND, RCOND, RCONDC, RCONDI, RCONDO, ROLDC,
$ ROLDI, ROLDO, ROWCND, RPVGRW
* ..
* .. Local Arrays ..
CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN )
INTEGER ISEED( 4 ), ISEEDY( 4 )
REAL RESULT( NTESTS )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SGET06, SLAMCH, SLANGE, SLANTR
EXTERNAL LSAME, SGET06, SLAMCH, SLANGE, SLANTR
* ..
* .. External Subroutines ..
EXTERNAL ALADHD, ALAERH, ALASVM, SERRVX, SGEEQU, SGESV,
$ SGESVX, SGET01, SGET02, SGET04, SGET07, SGETRF,
$ SGETRI, SLACPY, SLAQGE, SLARHS, SLASET, SLATB4,
$ SLATMS, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
DATA TRANSS / 'N', 'T', 'C' /
DATA FACTS / 'F', 'N', 'E' /
DATA EQUEDS / 'N', 'R', 'C', 'B' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'GE'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL SERRVX( PATH, NOUT )
INFOT = 0
*
* Set the block size and minimum block size for testing.
*
NB = 1
NBMIN = 2
CALL XLAENV( 1, NB )
CALL XLAENV( 2, NBMIN )
*
* Do for each value of N in NVAL
*
DO 90 IN = 1, NN
N = NVAL( IN )
LDA = MAX( N, 1 )
XTYPE = 'N'
NIMAT = NTYPES
IF( N.LE.0 )
$ NIMAT = 1
*
DO 80 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 80
*
* Skip types 5, 6, or 7 if the matrix size is too small.
*
ZEROT = IMAT.GE.5 .AND. IMAT.LE.7
IF( ZEROT .AND. N.LT.IMAT-4 )
$ GO TO 80
*
* Set up parameters with SLATB4 and generate a test matrix
* with SLATMS.
*
CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
RCONDC = ONE / CNDNUM
*
SRNAMT = 'SLATMS'
CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, CNDNUM,
$ ANORM, KL, KU, 'No packing', A, LDA, WORK,
$ INFO )
*
* Check error code from SLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', N, N, -1, -1,
$ -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 80
END IF
*
* For types 5-7, zero one or more columns of the matrix to
* test that INFO is returned correctly.
*
IF( ZEROT ) THEN
IF( IMAT.EQ.5 ) THEN
IZERO = 1
ELSE IF( IMAT.EQ.6 ) THEN
IZERO = N
ELSE
IZERO = N / 2 + 1
END IF
IOFF = ( IZERO-1 )*LDA
IF( IMAT.LT.7 ) THEN
DO 20 I = 1, N
A( IOFF+I ) = ZERO
20 CONTINUE
ELSE
CALL SLASET( 'Full', N, N-IZERO+1, ZERO, ZERO,
$ A( IOFF+1 ), LDA )
END IF
ELSE
IZERO = 0
END IF
*
* Save a copy of the matrix A in ASAV.
*
CALL SLACPY( 'Full', N, N, A, LDA, ASAV, LDA )
*
DO 70 IEQUED = 1, 4
EQUED = EQUEDS( IEQUED )
IF( IEQUED.EQ.1 ) THEN
NFACT = 3
ELSE
NFACT = 1
END IF
*
DO 60 IFACT = 1, NFACT
FACT = FACTS( IFACT )
PREFAC = LSAME( FACT, 'F' )
NOFACT = LSAME( FACT, 'N' )
EQUIL = LSAME( FACT, 'E' )
*
IF( ZEROT ) THEN
IF( PREFAC )
$ GO TO 60
RCONDO = ZERO
RCONDI = ZERO
*
ELSE IF( .NOT.NOFACT ) THEN
*
* Compute the condition number for comparison with
* the value returned by SGESVX (FACT = 'N' reuses
* the condition number from the previous iteration
* with FACT = 'F').
*
CALL SLACPY( 'Full', N, N, ASAV, LDA, AFAC, LDA )
IF( EQUIL .OR. IEQUED.GT.1 ) THEN
*
* Compute row and column scale factors to
* equilibrate the matrix A.
*
CALL SGEEQU( N, N, AFAC, LDA, S, S( N+1 ),
$ ROWCND, COLCND, AMAX, INFO )
IF( INFO.EQ.0 .AND. N.GT.0 ) THEN
IF( LSAME( EQUED, 'R' ) ) THEN
ROWCND = ZERO
COLCND = ONE
ELSE IF( LSAME( EQUED, 'C' ) ) THEN
ROWCND = ONE
COLCND = ZERO
ELSE IF( LSAME( EQUED, 'B' ) ) THEN
ROWCND = ZERO
COLCND = ZERO
END IF
*
* Equilibrate the matrix.
*
CALL SLAQGE( N, N, AFAC, LDA, S, S( N+1 ),
$ ROWCND, COLCND, AMAX, EQUED )
END IF
END IF
*
* Save the condition number of the non-equilibrated
* system for use in SGET04.
*
IF( EQUIL ) THEN
ROLDO = RCONDO
ROLDI = RCONDI
END IF
*
* Compute the 1-norm and infinity-norm of A.
*
ANORMO = SLANGE( '1', N, N, AFAC, LDA, RWORK )
ANORMI = SLANGE( 'I', N, N, AFAC, LDA, RWORK )
*
* Factor the matrix A.
*
CALL SGETRF( N, N, AFAC, LDA, IWORK, INFO )
*
* Form the inverse of A.
*
CALL SLACPY( 'Full', N, N, AFAC, LDA, A, LDA )
LWORK = NMAX*MAX( 3, NRHS )
CALL SGETRI( N, A, LDA, IWORK, WORK, LWORK, INFO )
*
* Compute the 1-norm condition number of A.
*
AINVNM = SLANGE( '1', N, N, A, LDA, RWORK )
IF( ANORMO.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDO = ONE
ELSE
RCONDO = ( ONE / ANORMO ) / AINVNM
END IF
*
* Compute the infinity-norm condition number of A.
*
AINVNM = SLANGE( 'I', N, N, A, LDA, RWORK )
IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDI = ONE
ELSE
RCONDI = ( ONE / ANORMI ) / AINVNM
END IF
END IF
*
DO 50 ITRAN = 1, NTRAN
*
* Do for each value of TRANS.
*
TRANS = TRANSS( ITRAN )
IF( ITRAN.EQ.1 ) THEN
RCONDC = RCONDO
ELSE
RCONDC = RCONDI
END IF
*
* Restore the matrix A.
*
CALL SLACPY( 'Full', N, N, ASAV, LDA, A, LDA )
*
* Form an exact solution and set the right hand side.
*
SRNAMT = 'SLARHS'
CALL SLARHS( PATH, XTYPE, 'Full', TRANS, N, N, KL,
$ KU, NRHS, A, LDA, XACT, LDA, B, LDA,
$ ISEED, INFO )
XTYPE = 'C'
CALL SLACPY( 'Full', N, NRHS, B, LDA, BSAV, LDA )
*
IF( NOFACT .AND. ITRAN.EQ.1 ) THEN
*
* --- Test SGESV ---
*
* Compute the LU factorization of the matrix and
* solve the system.
*
CALL SLACPY( 'Full', N, N, A, LDA, AFAC, LDA )
CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
SRNAMT = 'SGESV '
CALL SGESV( N, NRHS, AFAC, LDA, IWORK, X, LDA,
$ INFO )
*
* Check error code from SGESV .
*
IF( INFO.NE.IZERO )
$ CALL ALAERH( PATH, 'SGESV ', INFO, IZERO,
$ ' ', N, N, -1, -1, NRHS, IMAT,
$ NFAIL, NERRS, NOUT )
*
* Reconstruct matrix from factors and compute
* residual.
*
CALL SGET01( N, N, A, LDA, AFAC, LDA, IWORK,
$ RWORK, RESULT( 1 ) )
NT = 1
IF( IZERO.EQ.0 ) THEN
*
* Compute residual of the computed solution.
*
CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK,
$ LDA )
CALL SGET02( 'No transpose', N, N, NRHS, A,
$ LDA, X, LDA, WORK, LDA, RWORK,
$ RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA,
$ RCONDC, RESULT( 3 ) )
NT = 3
END IF
*
* Print information about the tests that did not
* pass the threshold.
*
DO 30 K = 1, NT
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )'SGESV ', N,
$ IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
30 CONTINUE
NRUN = NRUN + NT
END IF
*
* --- Test SGESVX ---
*
IF( .NOT.PREFAC )
$ CALL SLASET( 'Full', N, N, ZERO, ZERO, AFAC,
$ LDA )
CALL SLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA )
IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN
*
* Equilibrate the matrix if FACT = 'F' and
* EQUED = 'R', 'C', or 'B'.
*
CALL SLAQGE( N, N, A, LDA, S, S( N+1 ), ROWCND,
$ COLCND, AMAX, EQUED )
END IF
*
* Solve the system and compute the condition number
* and error bounds using SGESVX.
*
SRNAMT = 'SGESVX'
CALL SGESVX( FACT, TRANS, N, NRHS, A, LDA, AFAC,
$ LDA, IWORK, EQUED, S, S( N+1 ), B,
$ LDA, X, LDA, RCOND, RWORK,
$ RWORK( NRHS+1 ), WORK, IWORK( N+1 ),
$ INFO )
*
* Check the error code from SGESVX.
*
IF( INFO.NE.IZERO )
$ CALL ALAERH( PATH, 'SGESVX', INFO, IZERO,
$ FACT // TRANS, N, N, -1, -1, NRHS,
$ IMAT, NFAIL, NERRS, NOUT )
*
* Compare WORK(1) from SGESVX with the computed
* reciprocal pivot growth factor RPVGRW
*
IF( INFO.NE.0 ) THEN
RPVGRW = SLANTR( 'M', 'U', 'N', INFO, INFO,
$ AFAC, LDA, WORK )
IF( RPVGRW.EQ.ZERO ) THEN
RPVGRW = ONE
ELSE
RPVGRW = SLANGE( 'M', N, INFO, A, LDA,
$ WORK ) / RPVGRW
END IF
ELSE
RPVGRW = SLANTR( 'M', 'U', 'N', N, N, AFAC, LDA,
$ WORK )
IF( RPVGRW.EQ.ZERO ) THEN
RPVGRW = ONE
ELSE
RPVGRW = SLANGE( 'M', N, N, A, LDA, WORK ) /
$ RPVGRW
END IF
END IF
RESULT( 7 ) = ABS( RPVGRW-WORK( 1 ) ) /
$ MAX( WORK( 1 ), RPVGRW ) /
$ SLAMCH( 'E' )
*
IF( .NOT.PREFAC ) THEN
*
* Reconstruct matrix from factors and compute
* residual.
*
CALL SGET01( N, N, A, LDA, AFAC, LDA, IWORK,
$ RWORK( 2*NRHS+1 ), RESULT( 1 ) )
K1 = 1
ELSE
K1 = 2
END IF
*
IF( INFO.EQ.0 ) THEN
TRFCON = .FALSE.
*
* Compute residual of the computed solution.
*
CALL SLACPY( 'Full', N, NRHS, BSAV, LDA, WORK,
$ LDA )
CALL SGET02( TRANS, N, N, NRHS, ASAV, LDA, X,
$ LDA, WORK, LDA, RWORK( 2*NRHS+1 ),
$ RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED,
$ 'N' ) ) ) THEN
CALL SGET04( N, NRHS, X, LDA, XACT, LDA,
$ RCONDC, RESULT( 3 ) )
ELSE
IF( ITRAN.EQ.1 ) THEN
ROLDC = ROLDO
ELSE
ROLDC = ROLDI
END IF
CALL SGET04( N, NRHS, X, LDA, XACT, LDA,
$ ROLDC, RESULT( 3 ) )
END IF
*
* Check the error bounds from iterative
* refinement.
*
CALL SGET07( TRANS, N, NRHS, ASAV, LDA, B, LDA,
$ X, LDA, XACT, LDA, RWORK,
$ RWORK( NRHS+1 ), RESULT( 4 ) )
ELSE
TRFCON = .TRUE.
END IF
*
* Compare RCOND from SGESVX with the computed value
* in RCONDC.
*
RESULT( 6 ) = SGET06( RCOND, RCONDC )
*
* Print information about the tests that did not pass
* the threshold.
*
IF( .NOT.TRFCON ) THEN
DO 40 K = K1, NTESTS
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
IF( PREFAC ) THEN
WRITE( NOUT, FMT = 9997 )'SGESVX',
$ FACT, TRANS, N, EQUED, IMAT, K,
$ RESULT( K )
ELSE
WRITE( NOUT, FMT = 9998 )'SGESVX',
$ FACT, TRANS, N, IMAT, K, RESULT( K )
END IF
NFAIL = NFAIL + 1
END IF
40 CONTINUE
NRUN = NRUN + 7 - K1
ELSE
IF( RESULT( 1 ).GE.THRESH .AND. .NOT.PREFAC )
$ THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
IF( PREFAC ) THEN
WRITE( NOUT, FMT = 9997 )'SGESVX', FACT,
$ TRANS, N, EQUED, IMAT, 1, RESULT( 1 )
ELSE
WRITE( NOUT, FMT = 9998 )'SGESVX', FACT,
$ TRANS, N, IMAT, 1, RESULT( 1 )
END IF
NFAIL = NFAIL + 1
NRUN = NRUN + 1
END IF
IF( RESULT( 6 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
IF( PREFAC ) THEN
WRITE( NOUT, FMT = 9997 )'SGESVX', FACT,
$ TRANS, N, EQUED, IMAT, 6, RESULT( 6 )
ELSE
WRITE( NOUT, FMT = 9998 )'SGESVX', FACT,
$ TRANS, N, IMAT, 6, RESULT( 6 )
END IF
NFAIL = NFAIL + 1
NRUN = NRUN + 1
END IF
IF( RESULT( 7 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
IF( PREFAC ) THEN
WRITE( NOUT, FMT = 9997 )'SGESVX', FACT,
$ TRANS, N, EQUED, IMAT, 7, RESULT( 7 )
ELSE
WRITE( NOUT, FMT = 9998 )'SGESVX', FACT,
$ TRANS, N, IMAT, 7, RESULT( 7 )
END IF
NFAIL = NFAIL + 1
NRUN = NRUN + 1
END IF
*
END IF
*
50 CONTINUE
60 CONTINUE
70 CONTINUE
80 CONTINUE
90 CONTINUE
*
* Print a summary of the results.
*
CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( 1X, A6, ', N =', I5, ', type ', I2, ', test(', I2, ') =',
$ G12.5 )
9998 FORMAT( 1X, A6, ', FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5,
$ ', type ', I2, ', test(', I1, ')=', G12.5 )
9997 FORMAT( 1X, A6, ', FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5,
$ ', EQUED=''', A1, ''', type ', I2, ', test(', I1, ')=',
$ G12.5 )
RETURN
*
* End of SDRVGE
*
END
SUBROUTINE SDRVGT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, AF,
$ B, X, XACT, WORK, RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NN, NOUT, NRHS
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NVAL( * )
REAL A( * ), AF( * ), B( * ), RWORK( * ), WORK( * ),
$ X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* SDRVGT tests SGTSV and -SVX.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* A (workspace) REAL array, dimension (NMAX*4)
*
* AF (workspace) REAL array, dimension (NMAX*4)
*
* B (workspace) REAL array, dimension (NMAX*NRHS)
*
* X (workspace) REAL array, dimension (NMAX*NRHS)
*
* XACT (workspace) REAL array, dimension (NMAX*NRHS)
*
* WORK (workspace) REAL array, dimension
* (NMAX*max(3,NRHS))
*
* RWORK (workspace) REAL array, dimension
* (max(NMAX,2*NRHS))
*
* IWORK (workspace) INTEGER array, dimension (2*NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
INTEGER NTYPES
PARAMETER ( NTYPES = 12 )
INTEGER NTESTS
PARAMETER ( NTESTS = 6 )
* ..
* .. Local Scalars ..
LOGICAL TRFCON, ZEROT
CHARACTER DIST, FACT, TRANS, TYPE
CHARACTER*3 PATH
INTEGER I, IFACT, IMAT, IN, INFO, ITRAN, IX, IZERO, J,
$ K, K1, KL, KOFF, KU, LDA, M, MODE, N, NERRS,
$ NFAIL, NIMAT, NRUN, NT
REAL AINVNM, ANORM, ANORMI, ANORMO, COND, RCOND,
$ RCONDC, RCONDI, RCONDO
* ..
* .. Local Arrays ..
CHARACTER TRANSS( 3 )
INTEGER ISEED( 4 ), ISEEDY( 4 )
REAL RESULT( NTESTS ), Z( 3 )
* ..
* .. External Functions ..
REAL SASUM, SGET06, SLANGT
EXTERNAL SASUM, SGET06, SLANGT
* ..
* .. External Subroutines ..
EXTERNAL ALADHD, ALAERH, ALASVM, SCOPY, SERRVX, SGET04,
$ SGTSV, SGTSVX, SGTT01, SGTT02, SGTT05, SGTTRF,
$ SGTTRS, SLACPY, SLAGTM, SLARNV, SLASET, SLATB4,
$ SLATMS, SSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 0, 0, 0, 1 / , TRANSS / 'N', 'T',
$ 'C' /
* ..
* .. Executable Statements ..
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'GT'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL SERRVX( PATH, NOUT )
INFOT = 0
*
DO 140 IN = 1, NN
*
* Do for each value of N in NVAL.
*
N = NVAL( IN )
M = MAX( N-1, 0 )
LDA = MAX( 1, N )
NIMAT = NTYPES
IF( N.LE.0 )
$ NIMAT = 1
*
DO 130 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 130
*
* Set up parameters with SLATB4.
*
CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ COND, DIST )
*
ZEROT = IMAT.GE.8 .AND. IMAT.LE.10
IF( IMAT.LE.6 ) THEN
*
* Types 1-6: generate matrices of known condition number.
*
KOFF = MAX( 2-KU, 3-MAX( 1, N ) )
SRNAMT = 'SLATMS'
CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, COND,
$ ANORM, KL, KU, 'Z', AF( KOFF ), 3, WORK,
$ INFO )
*
* Check the error code from SLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', N, N, KL,
$ KU, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 130
END IF
IZERO = 0
*
IF( N.GT.1 ) THEN
CALL SCOPY( N-1, AF( 4 ), 3, A, 1 )
CALL SCOPY( N-1, AF( 3 ), 3, A( N+M+1 ), 1 )
END IF
CALL SCOPY( N, AF( 2 ), 3, A( M+1 ), 1 )
ELSE
*
* Types 7-12: generate tridiagonal matrices with
* unknown condition numbers.
*
IF( .NOT.ZEROT .OR. .NOT.DOTYPE( 7 ) ) THEN
*
* Generate a matrix with elements from [-1,1].
*
CALL SLARNV( 2, ISEED, N+2*M, A )
IF( ANORM.NE.ONE )
$ CALL SSCAL( N+2*M, ANORM, A, 1 )
ELSE IF( IZERO.GT.0 ) THEN
*
* Reuse the last matrix by copying back the zeroed out
* elements.
*
IF( IZERO.EQ.1 ) THEN
A( N ) = Z( 2 )
IF( N.GT.1 )
$ A( 1 ) = Z( 3 )
ELSE IF( IZERO.EQ.N ) THEN
A( 3*N-2 ) = Z( 1 )
A( 2*N-1 ) = Z( 2 )
ELSE
A( 2*N-2+IZERO ) = Z( 1 )
A( N-1+IZERO ) = Z( 2 )
A( IZERO ) = Z( 3 )
END IF
END IF
*
* If IMAT > 7, set one column of the matrix to 0.
*
IF( .NOT.ZEROT ) THEN
IZERO = 0
ELSE IF( IMAT.EQ.8 ) THEN
IZERO = 1
Z( 2 ) = A( N )
A( N ) = ZERO
IF( N.GT.1 ) THEN
Z( 3 ) = A( 1 )
A( 1 ) = ZERO
END IF
ELSE IF( IMAT.EQ.9 ) THEN
IZERO = N
Z( 1 ) = A( 3*N-2 )
Z( 2 ) = A( 2*N-1 )
A( 3*N-2 ) = ZERO
A( 2*N-1 ) = ZERO
ELSE
IZERO = ( N+1 ) / 2
DO 20 I = IZERO, N - 1
A( 2*N-2+I ) = ZERO
A( N-1+I ) = ZERO
A( I ) = ZERO
20 CONTINUE
A( 3*N-2 ) = ZERO
A( 2*N-1 ) = ZERO
END IF
END IF
*
DO 120 IFACT = 1, 2
IF( IFACT.EQ.1 ) THEN
FACT = 'F'
ELSE
FACT = 'N'
END IF
*
* Compute the condition number for comparison with
* the value returned by SGTSVX.
*
IF( ZEROT ) THEN
IF( IFACT.EQ.1 )
$ GO TO 120
RCONDO = ZERO
RCONDI = ZERO
*
ELSE IF( IFACT.EQ.1 ) THEN
CALL SCOPY( N+2*M, A, 1, AF, 1 )
*
* Compute the 1-norm and infinity-norm of A.
*
ANORMO = SLANGT( '1', N, A, A( M+1 ), A( N+M+1 ) )
ANORMI = SLANGT( 'I', N, A, A( M+1 ), A( N+M+1 ) )
*
* Factor the matrix A.
*
CALL SGTTRF( N, AF, AF( M+1 ), AF( N+M+1 ),
$ AF( N+2*M+1 ), IWORK, INFO )
*
* Use SGTTRS to solve for one column at a time of
* inv(A), computing the maximum column sum as we go.
*
AINVNM = ZERO
DO 40 I = 1, N
DO 30 J = 1, N
X( J ) = ZERO
30 CONTINUE
X( I ) = ONE
CALL SGTTRS( 'No transpose', N, 1, AF, AF( M+1 ),
$ AF( N+M+1 ), AF( N+2*M+1 ), IWORK, X,
$ LDA, INFO )
AINVNM = MAX( AINVNM, SASUM( N, X, 1 ) )
40 CONTINUE
*
* Compute the 1-norm condition number of A.
*
IF( ANORMO.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDO = ONE
ELSE
RCONDO = ( ONE / ANORMO ) / AINVNM
END IF
*
* Use SGTTRS to solve for one column at a time of
* inv(A'), computing the maximum column sum as we go.
*
AINVNM = ZERO
DO 60 I = 1, N
DO 50 J = 1, N
X( J ) = ZERO
50 CONTINUE
X( I ) = ONE
CALL SGTTRS( 'Transpose', N, 1, AF, AF( M+1 ),
$ AF( N+M+1 ), AF( N+2*M+1 ), IWORK, X,
$ LDA, INFO )
AINVNM = MAX( AINVNM, SASUM( N, X, 1 ) )
60 CONTINUE
*
* Compute the infinity-norm condition number of A.
*
IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDI = ONE
ELSE
RCONDI = ( ONE / ANORMI ) / AINVNM
END IF
END IF
*
DO 110 ITRAN = 1, 3
TRANS = TRANSS( ITRAN )
IF( ITRAN.EQ.1 ) THEN
RCONDC = RCONDO
ELSE
RCONDC = RCONDI
END IF
*
* Generate NRHS random solution vectors.
*
IX = 1
DO 70 J = 1, NRHS
CALL SLARNV( 2, ISEED, N, XACT( IX ) )
IX = IX + LDA
70 CONTINUE
*
* Set the right hand side.
*
CALL SLAGTM( TRANS, N, NRHS, ONE, A, A( M+1 ),
$ A( N+M+1 ), XACT, LDA, ZERO, B, LDA )
*
IF( IFACT.EQ.2 .AND. ITRAN.EQ.1 ) THEN
*
* --- Test SGTSV ---
*
* Solve the system using Gaussian elimination with
* partial pivoting.
*
CALL SCOPY( N+2*M, A, 1, AF, 1 )
CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
SRNAMT = 'SGTSV '
CALL SGTSV( N, NRHS, AF, AF( M+1 ), AF( N+M+1 ), X,
$ LDA, INFO )
*
* Check error code from SGTSV .
*
IF( INFO.NE.IZERO )
$ CALL ALAERH( PATH, 'SGTSV ', INFO, IZERO, ' ',
$ N, N, 1, 1, NRHS, IMAT, NFAIL,
$ NERRS, NOUT )
NT = 1
IF( IZERO.EQ.0 ) THEN
*
* Check residual of computed solution.
*
CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK,
$ LDA )
CALL SGTT02( TRANS, N, NRHS, A, A( M+1 ),
$ A( N+M+1 ), X, LDA, WORK, LDA,
$ RWORK, RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
NT = 3
END IF
*
* Print information about the tests that did not pass
* the threshold.
*
DO 80 K = 2, NT
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )'SGTSV ', N, IMAT,
$ K, RESULT( K )
NFAIL = NFAIL + 1
END IF
80 CONTINUE
NRUN = NRUN + NT - 1
END IF
*
* --- Test SGTSVX ---
*
IF( IFACT.GT.1 ) THEN
*
* Initialize AF to zero.
*
DO 90 I = 1, 3*N - 2
AF( I ) = ZERO
90 CONTINUE
END IF
CALL SLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA )
*
* Solve the system and compute the condition number and
* error bounds using SGTSVX.
*
SRNAMT = 'SGTSVX'
CALL SGTSVX( FACT, TRANS, N, NRHS, A, A( M+1 ),
$ A( N+M+1 ), AF, AF( M+1 ), AF( N+M+1 ),
$ AF( N+2*M+1 ), IWORK, B, LDA, X, LDA,
$ RCOND, RWORK, RWORK( NRHS+1 ), WORK,
$ IWORK( N+1 ), INFO )
*
* Check the error code from SGTSVX.
*
IF( INFO.NE.IZERO )
$ CALL ALAERH( PATH, 'SGTSVX', INFO, IZERO,
$ FACT // TRANS, N, N, 1, 1, NRHS, IMAT,
$ NFAIL, NERRS, NOUT )
*
IF( IFACT.GE.2 ) THEN
*
* Reconstruct matrix from factors and compute
* residual.
*
CALL SGTT01( N, A, A( M+1 ), A( N+M+1 ), AF,
$ AF( M+1 ), AF( N+M+1 ), AF( N+2*M+1 ),
$ IWORK, WORK, LDA, RWORK, RESULT( 1 ) )
K1 = 1
ELSE
K1 = 2
END IF
*
IF( INFO.EQ.0 ) THEN
TRFCON = .FALSE.
*
* Check residual of computed solution.
*
CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
CALL SGTT02( TRANS, N, NRHS, A, A( M+1 ),
$ A( N+M+1 ), X, LDA, WORK, LDA, RWORK,
$ RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
*
* Check the error bounds from iterative refinement.
*
CALL SGTT05( TRANS, N, NRHS, A, A( M+1 ),
$ A( N+M+1 ), B, LDA, X, LDA, XACT, LDA,
$ RWORK, RWORK( NRHS+1 ), RESULT( 4 ) )
NT = 5
END IF
*
* Print information about the tests that did not pass
* the threshold.
*
DO 100 K = K1, NT
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )'SGTSVX', FACT, TRANS,
$ N, IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
100 CONTINUE
*
* Check the reciprocal of the condition number.
*
RESULT( 6 ) = SGET06( RCOND, RCONDC )
IF( RESULT( 6 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )'SGTSVX', FACT, TRANS, N,
$ IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + NT - K1 + 2
*
110 CONTINUE
120 CONTINUE
130 CONTINUE
140 CONTINUE
*
* Print a summary of the results.
*
CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( 1X, A6, ', N =', I5, ', type ', I2, ', test ', I2,
$ ', ratio = ', G12.5 )
9998 FORMAT( 1X, A6, ', FACT=''', A1, ''', TRANS=''', A1, ''', N =',
$ I5, ', type ', I2, ', test ', I2, ', ratio = ', G12.5 )
RETURN
*
* End of SDRVGT
*
END
SUBROUTINE SDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB,
$ NBVAL, NXVAL, THRESH, TSTERR, A, COPYA, B,
$ COPYB, C, S, COPYS, WORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* January 2007
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NM, NN, NNB, NNS, NOUT
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ),
$ NVAL( * ), NXVAL( * )
REAL A( * ), B( * ), C( * ), COPYA( * ), COPYB( * ),
$ COPYS( * ), S( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SDRVLS tests the least squares driver routines SGELS, SGELSS, SGELSX,
* SGELSY and SGELSD.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
* The matrix of type j is generated as follows:
* j=1: A = U*D*V where U and V are random orthogonal matrices
* and D has random entries (> 0.1) taken from a uniform
* distribution (0,1). A is full rank.
* j=2: The same of 1, but A is scaled up.
* j=3: The same of 1, but A is scaled down.
* j=4: A = U*D*V where U and V are random orthogonal matrices
* and D has 3*min(M,N)/4 random entries (> 0.1) taken
* from a uniform distribution (0,1) and the remaining
* entries set to 0. A is rank-deficient.
* j=5: The same of 4, but A is scaled up.
* j=6: The same of 5, but A is scaled down.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* A (workspace) REAL array, dimension (MMAX*NMAX)
* where MMAX is the maximum value of M in MVAL and NMAX is the
* maximum value of N in NVAL.
*
* COPYA (workspace) REAL array, dimension (MMAX*NMAX)
*
* B (workspace) REAL array, dimension (MMAX*NSMAX)
* where MMAX is the maximum value of M in MVAL and NSMAX is the
* maximum value of NRHS in NSVAL.
*
* COPYB (workspace) REAL array, dimension (MMAX*NSMAX)
*
* C (workspace) REAL array, dimension (MMAX*NSMAX)
*
* S (workspace) REAL array, dimension
* (min(MMAX,NMAX))
*
* COPYS (workspace) REAL array, dimension
* (min(MMAX,NMAX))
*
* WORK (workspace) REAL array,
* dimension (MMAX*NMAX + 4*NMAX + MMAX).
*
* IWORK (workspace) INTEGER array, dimension (15*NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTESTS
PARAMETER ( NTESTS = 18 )
INTEGER SMLSIZ
PARAMETER ( SMLSIZ = 25 )
REAL ONE, TWO, ZERO
PARAMETER ( ONE = 1.0E0, TWO = 2.0E0, ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
CHARACTER TRANS
CHARACTER*3 PATH
INTEGER CRANK, I, IM, IN, INB, INFO, INS, IRANK,
$ ISCALE, ITRAN, ITYPE, J, K, LDA, LDB, LDWORK,
$ LWLSY, LWORK, M, MNMIN, N, NB, NCOLS, NERRS,
$ NFAIL, NLVL, NRHS, NROWS, NRUN, RANK
REAL EPS, NORMA, NORMB, RCOND
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 ), ISEEDY( 4 )
REAL RESULT( NTESTS )
* ..
* .. External Functions ..
REAL SASUM, SLAMCH, SQRT12, SQRT14, SQRT17
EXTERNAL SASUM, SLAMCH, SQRT12, SQRT14, SQRT17
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASVM, SAXPY, SERRLS, SGELS,
$ SGELSD, SGELSS, SGELSX, SGELSY, SGEMM, SLACPY,
$ SLARNV, SQRT13, SQRT15, SQRT16, SSCAL,
$ XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC INT, LOG, MAX, MIN, REAL, SQRT
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, IOUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, IOUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'LS'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
EPS = SLAMCH( 'Epsilon' )
*
* Threshold for rank estimation
*
RCOND = SQRT( EPS ) - ( SQRT( EPS )-EPS ) / 2
*
* Test the error exits
*
CALL XLAENV( 2, 2 )
CALL XLAENV( 9, SMLSIZ )
IF( TSTERR )
$ CALL SERRLS( PATH, NOUT )
*
* Print the header if NM = 0 or NN = 0 and THRESH = 0.
*
IF( ( NM.EQ.0 .OR. NN.EQ.0 ) .AND. THRESH.EQ.ZERO )
$ CALL ALAHD( NOUT, PATH )
INFOT = 0
*
DO 150 IM = 1, NM
M = MVAL( IM )
LDA = MAX( 1, M )
*
DO 140 IN = 1, NN
N = NVAL( IN )
MNMIN = MIN( M, N )
LDB = MAX( 1, M, N )
*
DO 130 INS = 1, NNS
NRHS = NSVAL( INS )
NLVL = MAX( INT( LOG( MAX( ONE, REAL( MNMIN ) ) /
$ REAL( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1, 0 )
LWORK = MAX( 1, ( M+NRHS )*( N+2 ), ( N+NRHS )*( M+2 ),
$ M*N+4*MNMIN+MAX( M, N ), 12*MNMIN+2*MNMIN*SMLSIZ+
$ 8*MNMIN*NLVL+MNMIN*NRHS+(SMLSIZ+1)**2 )
*
DO 120 IRANK = 1, 2
DO 110 ISCALE = 1, 3
ITYPE = ( IRANK-1 )*3 + ISCALE
IF( .NOT.DOTYPE( ITYPE ) )
$ GO TO 110
*
IF( IRANK.EQ.1 ) THEN
*
* Test SGELS
*
* Generate a matrix of scaling type ISCALE
*
CALL SQRT13( ISCALE, M, N, COPYA, LDA, NORMA,
$ ISEED )
DO 40 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
CALL XLAENV( 3, NXVAL( INB ) )
*
DO 30 ITRAN = 1, 2
IF( ITRAN.EQ.1 ) THEN
TRANS = 'N'
NROWS = M
NCOLS = N
ELSE
TRANS = 'T'
NROWS = N
NCOLS = M
END IF
LDWORK = MAX( 1, NCOLS )
*
* Set up a consistent rhs
*
IF( NCOLS.GT.0 ) THEN
CALL SLARNV( 2, ISEED, NCOLS*NRHS,
$ WORK )
CALL SSCAL( NCOLS*NRHS,
$ ONE / REAL( NCOLS ), WORK,
$ 1 )
END IF
CALL SGEMM( TRANS, 'No transpose', NROWS,
$ NRHS, NCOLS, ONE, COPYA, LDA,
$ WORK, LDWORK, ZERO, B, LDB )
CALL SLACPY( 'Full', NROWS, NRHS, B, LDB,
$ COPYB, LDB )
*
* Solve LS or overdetermined system
*
IF( M.GT.0 .AND. N.GT.0 ) THEN
CALL SLACPY( 'Full', M, N, COPYA, LDA,
$ A, LDA )
CALL SLACPY( 'Full', NROWS, NRHS,
$ COPYB, LDB, B, LDB )
END IF
SRNAMT = 'SGELS '
CALL SGELS( TRANS, M, N, NRHS, A, LDA, B,
$ LDB, WORK, LWORK, INFO )
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SGELS ', INFO, 0,
$ TRANS, M, N, NRHS, -1, NB,
$ ITYPE, NFAIL, NERRS,
$ NOUT )
*
* Check correctness of results
*
LDWORK = MAX( 1, NROWS )
IF( NROWS.GT.0 .AND. NRHS.GT.0 )
$ CALL SLACPY( 'Full', NROWS, NRHS,
$ COPYB, LDB, C, LDB )
CALL SQRT16( TRANS, M, N, NRHS, COPYA,
$ LDA, B, LDB, C, LDB, WORK,
$ RESULT( 1 ) )
*
IF( ( ITRAN.EQ.1 .AND. M.GE.N ) .OR.
$ ( ITRAN.EQ.2 .AND. M.LT.N ) ) THEN
*
* Solving LS system
*
RESULT( 2 ) = SQRT17( TRANS, 1, M, N,
$ NRHS, COPYA, LDA, B, LDB,
$ COPYB, LDB, C, WORK,
$ LWORK )
ELSE
*
* Solving overdetermined system
*
RESULT( 2 ) = SQRT14( TRANS, M, N,
$ NRHS, COPYA, LDA, B, LDB,
$ WORK, LWORK )
END IF
*
* Print information about the tests that
* did not pass the threshold.
*
DO 20 K = 1, 2
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )TRANS, M,
$ N, NRHS, NB, ITYPE, K,
$ RESULT( K )
NFAIL = NFAIL + 1
END IF
20 CONTINUE
NRUN = NRUN + 2
30 CONTINUE
40 CONTINUE
END IF
*
* Generate a matrix of scaling type ISCALE and rank
* type IRANK.
*
CALL SQRT15( ISCALE, IRANK, M, N, NRHS, COPYA, LDA,
$ COPYB, LDB, COPYS, RANK, NORMA, NORMB,
$ ISEED, WORK, LWORK )
*
* workspace used: MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M)
*
* Initialize vector IWORK.
*
DO 50 J = 1, N
IWORK( J ) = 0
50 CONTINUE
LDWORK = MAX( 1, M )
*
* Test SGELSX
*
* SGELSX: Compute the minimum-norm solution X
* to min( norm( A * X - B ) ) using a complete
* orthogonal factorization.
*
CALL SLACPY( 'Full', M, N, COPYA, LDA, A, LDA )
CALL SLACPY( 'Full', M, NRHS, COPYB, LDB, B, LDB )
*
SRNAMT = 'SGELSX'
CALL SGELSX( M, N, NRHS, A, LDA, B, LDB, IWORK,
$ RCOND, CRANK, WORK, INFO )
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SGELSX', INFO, 0, ' ', M, N,
$ NRHS, -1, NB, ITYPE, NFAIL, NERRS,
$ NOUT )
*
* workspace used: MAX( MNMIN+3*N, 2*MNMIN+NRHS )
*
* Test 3: Compute relative error in svd
* workspace: M*N + 4*MIN(M,N) + MAX(M,N)
*
RESULT( 3 ) = SQRT12( CRANK, CRANK, A, LDA, COPYS,
$ WORK, LWORK )
*
* Test 4: Compute error in solution
* workspace: M*NRHS + M
*
CALL SLACPY( 'Full', M, NRHS, COPYB, LDB, WORK,
$ LDWORK )
CALL SQRT16( 'No transpose', M, N, NRHS, COPYA,
$ LDA, B, LDB, WORK, LDWORK,
$ WORK( M*NRHS+1 ), RESULT( 4 ) )
*
* Test 5: Check norm of r'*A
* workspace: NRHS*(M+N)
*
RESULT( 5 ) = ZERO
IF( M.GT.CRANK )
$ RESULT( 5 ) = SQRT17( 'No transpose', 1, M, N,
$ NRHS, COPYA, LDA, B, LDB, COPYB,
$ LDB, C, WORK, LWORK )
*
* Test 6: Check if x is in the rowspace of A
* workspace: (M+NRHS)*(N+2)
*
RESULT( 6 ) = ZERO
*
IF( N.GT.CRANK )
$ RESULT( 6 ) = SQRT14( 'No transpose', M, N,
$ NRHS, COPYA, LDA, B, LDB, WORK,
$ LWORK )
*
* Print information about the tests that did not
* pass the threshold.
*
DO 60 K = 3, 6
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )M, N, NRHS, NB,
$ ITYPE, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
60 CONTINUE
NRUN = NRUN + 4
*
* Loop for testing different block sizes.
*
DO 100 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
CALL XLAENV( 3, NXVAL( INB ) )
*
* Test SGELSY
*
* SGELSY: Compute the minimum-norm solution X
* to min( norm( A * X - B ) )
* using the rank-revealing orthogonal
* factorization.
*
* Initialize vector IWORK.
*
DO 70 J = 1, N
IWORK( J ) = 0
70 CONTINUE
*
* Set LWLSY to the adequate value.
*
LWLSY = MAX( 1, MNMIN+2*N+NB*( N+1 ),
$ 2*MNMIN+NB*NRHS )
*
CALL SLACPY( 'Full', M, N, COPYA, LDA, A, LDA )
CALL SLACPY( 'Full', M, NRHS, COPYB, LDB, B,
$ LDB )
*
SRNAMT = 'SGELSY'
CALL SGELSY( M, N, NRHS, A, LDA, B, LDB, IWORK,
$ RCOND, CRANK, WORK, LWLSY, INFO )
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SGELSY', INFO, 0, ' ', M,
$ N, NRHS, -1, NB, ITYPE, NFAIL,
$ NERRS, NOUT )
*
* Test 7: Compute relative error in svd
* workspace: M*N + 4*MIN(M,N) + MAX(M,N)
*
RESULT( 7 ) = SQRT12( CRANK, CRANK, A, LDA,
$ COPYS, WORK, LWORK )
*
* Test 8: Compute error in solution
* workspace: M*NRHS + M
*
CALL SLACPY( 'Full', M, NRHS, COPYB, LDB, WORK,
$ LDWORK )
CALL SQRT16( 'No transpose', M, N, NRHS, COPYA,
$ LDA, B, LDB, WORK, LDWORK,
$ WORK( M*NRHS+1 ), RESULT( 8 ) )
*
* Test 9: Check norm of r'*A
* workspace: NRHS*(M+N)
*
RESULT( 9 ) = ZERO
IF( M.GT.CRANK )
$ RESULT( 9 ) = SQRT17( 'No transpose', 1, M,
$ N, NRHS, COPYA, LDA, B, LDB,
$ COPYB, LDB, C, WORK, LWORK )
*
* Test 10: Check if x is in the rowspace of A
* workspace: (M+NRHS)*(N+2)
*
RESULT( 10 ) = ZERO
*
IF( N.GT.CRANK )
$ RESULT( 10 ) = SQRT14( 'No transpose', M, N,
$ NRHS, COPYA, LDA, B, LDB,
$ WORK, LWORK )
*
* Test SGELSS
*
* SGELSS: Compute the minimum-norm solution X
* to min( norm( A * X - B ) )
* using the SVD.
*
CALL SLACPY( 'Full', M, N, COPYA, LDA, A, LDA )
CALL SLACPY( 'Full', M, NRHS, COPYB, LDB, B,
$ LDB )
SRNAMT = 'SGELSS'
CALL SGELSS( M, N, NRHS, A, LDA, B, LDB, S,
$ RCOND, CRANK, WORK, LWORK, INFO )
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SGELSS', INFO, 0, ' ', M,
$ N, NRHS, -1, NB, ITYPE, NFAIL,
$ NERRS, NOUT )
*
* workspace used: 3*min(m,n) +
* max(2*min(m,n),nrhs,max(m,n))
*
* Test 11: Compute relative error in svd
*
IF( RANK.GT.0 ) THEN
CALL SAXPY( MNMIN, -ONE, COPYS, 1, S, 1 )
RESULT( 11 ) = SASUM( MNMIN, S, 1 ) /
$ SASUM( MNMIN, COPYS, 1 ) /
$ ( EPS*REAL( MNMIN ) )
ELSE
RESULT( 11 ) = ZERO
END IF
*
* Test 12: Compute error in solution
*
CALL SLACPY( 'Full', M, NRHS, COPYB, LDB, WORK,
$ LDWORK )
CALL SQRT16( 'No transpose', M, N, NRHS, COPYA,
$ LDA, B, LDB, WORK, LDWORK,
$ WORK( M*NRHS+1 ), RESULT( 12 ) )
*
* Test 13: Check norm of r'*A
*
RESULT( 13 ) = ZERO
IF( M.GT.CRANK )
$ RESULT( 13 ) = SQRT17( 'No transpose', 1, M,
$ N, NRHS, COPYA, LDA, B, LDB,
$ COPYB, LDB, C, WORK, LWORK )
*
* Test 14: Check if x is in the rowspace of A
*
RESULT( 14 ) = ZERO
IF( N.GT.CRANK )
$ RESULT( 14 ) = SQRT14( 'No transpose', M, N,
$ NRHS, COPYA, LDA, B, LDB,
$ WORK, LWORK )
*
* Test SGELSD
*
* SGELSD: Compute the minimum-norm solution X
* to min( norm( A * X - B ) ) using a
* divide and conquer SVD.
*
* Initialize vector IWORK.
*
DO 80 J = 1, N
IWORK( J ) = 0
80 CONTINUE
*
CALL SLACPY( 'Full', M, N, COPYA, LDA, A, LDA )
CALL SLACPY( 'Full', M, NRHS, COPYB, LDB, B,
$ LDB )
*
SRNAMT = 'SGELSD'
CALL SGELSD( M, N, NRHS, A, LDA, B, LDB, S,
$ RCOND, CRANK, WORK, LWORK, IWORK,
$ INFO )
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SGELSD', INFO, 0, ' ', M,
$ N, NRHS, -1, NB, ITYPE, NFAIL,
$ NERRS, NOUT )
*
* Test 15: Compute relative error in svd
*
IF( RANK.GT.0 ) THEN
CALL SAXPY( MNMIN, -ONE, COPYS, 1, S, 1 )
RESULT( 15 ) = SASUM( MNMIN, S, 1 ) /
$ SASUM( MNMIN, COPYS, 1 ) /
$ ( EPS*REAL( MNMIN ) )
ELSE
RESULT( 15 ) = ZERO
END IF
*
* Test 16: Compute error in solution
*
CALL SLACPY( 'Full', M, NRHS, COPYB, LDB, WORK,
$ LDWORK )
CALL SQRT16( 'No transpose', M, N, NRHS, COPYA,
$ LDA, B, LDB, WORK, LDWORK,
$ WORK( M*NRHS+1 ), RESULT( 16 ) )
*
* Test 17: Check norm of r'*A
*
RESULT( 17 ) = ZERO
IF( M.GT.CRANK )
$ RESULT( 17 ) = SQRT17( 'No transpose', 1, M,
$ N, NRHS, COPYA, LDA, B, LDB,
$ COPYB, LDB, C, WORK, LWORK )
*
* Test 18: Check if x is in the rowspace of A
*
RESULT( 18 ) = ZERO
IF( N.GT.CRANK )
$ RESULT( 18 ) = SQRT14( 'No transpose', M, N,
$ NRHS, COPYA, LDA, B, LDB,
$ WORK, LWORK )
*
* Print information about the tests that did not
* pass the threshold.
*
DO 90 K = 7, NTESTS
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )M, N, NRHS, NB,
$ ITYPE, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
90 CONTINUE
NRUN = NRUN + 12
*
100 CONTINUE
110 CONTINUE
120 CONTINUE
130 CONTINUE
140 CONTINUE
150 CONTINUE
*
* Print a summary of the results.
*
CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' TRANS=''', A1, ''', M=', I5, ', N=', I5, ', NRHS=', I4,
$ ', NB=', I4, ', type', I2, ', test(', I2, ')=', G12.5 )
9998 FORMAT( ' M=', I5, ', N=', I5, ', NRHS=', I4, ', NB=', I4,
$ ', type', I2, ', test(', I2, ')=', G12.5 )
RETURN
*
* End of SDRVLS
*
END
SUBROUTINE SDRVPB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
$ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK,
$ RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NMAX, NN, NOUT, NRHS
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NVAL( * )
REAL A( * ), AFAC( * ), ASAV( * ), B( * ),
$ BSAV( * ), RWORK( * ), S( * ), WORK( * ),
$ X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* SDRVPB tests the driver routines SPBSV and -SVX.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* NRHS (input) INTEGER
* The number of right hand side vectors to be generated for
* each linear system.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for N, used in dimensioning the
* work arrays.
*
* A (workspace) REAL array, dimension (NMAX*NMAX)
*
* AFAC (workspace) REAL array, dimension (NMAX*NMAX)
*
* ASAV (workspace) REAL array, dimension (NMAX*NMAX)
*
* B (workspace) REAL array, dimension (NMAX*NRHS)
*
* BSAV (workspace) REAL array, dimension (NMAX*NRHS)
*
* X (workspace) REAL array, dimension (NMAX*NRHS)
*
* XACT (workspace) REAL array, dimension (NMAX*NRHS)
*
* S (workspace) REAL array, dimension (NMAX)
*
* WORK (workspace) REAL array, dimension
* (NMAX*max(3,NRHS))
*
* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
INTEGER NTYPES, NTESTS
PARAMETER ( NTYPES = 8, NTESTS = 6 )
INTEGER NBW
PARAMETER ( NBW = 4 )
* ..
* .. Local Scalars ..
LOGICAL EQUIL, NOFACT, PREFAC, ZEROT
CHARACTER DIST, EQUED, FACT, PACKIT, TYPE, UPLO, XTYPE
CHARACTER*3 PATH
INTEGER I, I1, I2, IEQUED, IFACT, IKD, IMAT, IN, INFO,
$ IOFF, IUPLO, IW, IZERO, K, K1, KD, KL, KOFF,
$ KU, LDA, LDAB, MODE, N, NB, NBMIN, NERRS,
$ NFACT, NFAIL, NIMAT, NKD, NRUN, NT
REAL AINVNM, AMAX, ANORM, CNDNUM, RCOND, RCONDC,
$ ROLDC, SCOND
* ..
* .. Local Arrays ..
CHARACTER EQUEDS( 2 ), FACTS( 3 )
INTEGER ISEED( 4 ), ISEEDY( 4 ), KDVAL( NBW )
REAL RESULT( NTESTS )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SGET06, SLANGE, SLANSB
EXTERNAL LSAME, SGET06, SLANGE, SLANSB
* ..
* .. External Subroutines ..
EXTERNAL ALADHD, ALAERH, ALASVM, SCOPY, SERRVX, SGET04,
$ SLACPY, SLAQSB, SLARHS, SLASET, SLATB4, SLATMS,
$ SPBEQU, SPBSV, SPBSVX, SPBT01, SPBT02, SPBT05,
$ SPBTRF, SPBTRS, SSWAP, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
DATA FACTS / 'F', 'N', 'E' /
DATA EQUEDS / 'N', 'Y' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'PB'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL SERRVX( PATH, NOUT )
INFOT = 0
KDVAL( 1 ) = 0
*
* Set the block size and minimum block size for testing.
*
NB = 1
NBMIN = 2
CALL XLAENV( 1, NB )
CALL XLAENV( 2, NBMIN )
*
* Do for each value of N in NVAL
*
DO 110 IN = 1, NN
N = NVAL( IN )
LDA = MAX( N, 1 )
XTYPE = 'N'
*
* Set limits on the number of loop iterations.
*
NKD = MAX( 1, MIN( N, 4 ) )
NIMAT = NTYPES
IF( N.EQ.0 )
$ NIMAT = 1
*
KDVAL( 2 ) = N + ( N+1 ) / 4
KDVAL( 3 ) = ( 3*N-1 ) / 4
KDVAL( 4 ) = ( N+1 ) / 4
*
DO 100 IKD = 1, NKD
*
* Do for KD = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This order
* makes it easier to skip redundant values for small values
* of N.
*
KD = KDVAL( IKD )
LDAB = KD + 1
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 90 IUPLO = 1, 2
KOFF = 1
IF( IUPLO.EQ.1 ) THEN
UPLO = 'U'
PACKIT = 'Q'
KOFF = MAX( 1, KD+2-N )
ELSE
UPLO = 'L'
PACKIT = 'B'
END IF
*
DO 80 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 80
*
* Skip types 2, 3, or 4 if the matrix size is too small.
*
ZEROT = IMAT.GE.2 .AND. IMAT.LE.4
IF( ZEROT .AND. N.LT.IMAT-1 )
$ GO TO 80
*
IF( .NOT.ZEROT .OR. .NOT.DOTYPE( 1 ) ) THEN
*
* Set up parameters with SLATB4 and generate a test
* matrix with SLATMS.
*
CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM,
$ MODE, CNDNUM, DIST )
*
SRNAMT = 'SLATMS'
CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KD, KD, PACKIT,
$ A( KOFF ), LDAB, WORK, INFO )
*
* Check error code from SLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N,
$ N, -1, -1, -1, IMAT, NFAIL, NERRS,
$ NOUT )
GO TO 80
END IF
ELSE IF( IZERO.GT.0 ) THEN
*
* Use the same matrix for types 3 and 4 as for type
* 2 by copying back the zeroed out column,
*
IW = 2*LDA + 1
IF( IUPLO.EQ.1 ) THEN
IOFF = ( IZERO-1 )*LDAB + KD + 1
CALL SCOPY( IZERO-I1, WORK( IW ), 1,
$ A( IOFF-IZERO+I1 ), 1 )
IW = IW + IZERO - I1
CALL SCOPY( I2-IZERO+1, WORK( IW ), 1,
$ A( IOFF ), MAX( LDAB-1, 1 ) )
ELSE
IOFF = ( I1-1 )*LDAB + 1
CALL SCOPY( IZERO-I1, WORK( IW ), 1,
$ A( IOFF+IZERO-I1 ),
$ MAX( LDAB-1, 1 ) )
IOFF = ( IZERO-1 )*LDAB + 1
IW = IW + IZERO - I1
CALL SCOPY( I2-IZERO+1, WORK( IW ), 1,
$ A( IOFF ), 1 )
END IF
END IF
*
* For types 2-4, zero one row and column of the matrix
* to test that INFO is returned correctly.
*
IZERO = 0
IF( ZEROT ) THEN
IF( IMAT.EQ.2 ) THEN
IZERO = 1
ELSE IF( IMAT.EQ.3 ) THEN
IZERO = N
ELSE
IZERO = N / 2 + 1
END IF
*
* Save the zeroed out row and column in WORK(*,3)
*
IW = 2*LDA
DO 20 I = 1, MIN( 2*KD+1, N )
WORK( IW+I ) = ZERO
20 CONTINUE
IW = IW + 1
I1 = MAX( IZERO-KD, 1 )
I2 = MIN( IZERO+KD, N )
*
IF( IUPLO.EQ.1 ) THEN
IOFF = ( IZERO-1 )*LDAB + KD + 1
CALL SSWAP( IZERO-I1, A( IOFF-IZERO+I1 ), 1,
$ WORK( IW ), 1 )
IW = IW + IZERO - I1
CALL SSWAP( I2-IZERO+1, A( IOFF ),
$ MAX( LDAB-1, 1 ), WORK( IW ), 1 )
ELSE
IOFF = ( I1-1 )*LDAB + 1
CALL SSWAP( IZERO-I1, A( IOFF+IZERO-I1 ),
$ MAX( LDAB-1, 1 ), WORK( IW ), 1 )
IOFF = ( IZERO-1 )*LDAB + 1
IW = IW + IZERO - I1
CALL SSWAP( I2-IZERO+1, A( IOFF ), 1,
$ WORK( IW ), 1 )
END IF
END IF
*
* Save a copy of the matrix A in ASAV.
*
CALL SLACPY( 'Full', KD+1, N, A, LDAB, ASAV, LDAB )
*
DO 70 IEQUED = 1, 2
EQUED = EQUEDS( IEQUED )
IF( IEQUED.EQ.1 ) THEN
NFACT = 3
ELSE
NFACT = 1
END IF
*
DO 60 IFACT = 1, NFACT
FACT = FACTS( IFACT )
PREFAC = LSAME( FACT, 'F' )
NOFACT = LSAME( FACT, 'N' )
EQUIL = LSAME( FACT, 'E' )
*
IF( ZEROT ) THEN
IF( PREFAC )
$ GO TO 60
RCONDC = ZERO
*
ELSE IF( .NOT.LSAME( FACT, 'N' ) ) THEN
*
* Compute the condition number for comparison
* with the value returned by SPBSVX (FACT =
* 'N' reuses the condition number from the
* previous iteration with FACT = 'F').
*
CALL SLACPY( 'Full', KD+1, N, ASAV, LDAB,
$ AFAC, LDAB )
IF( EQUIL .OR. IEQUED.GT.1 ) THEN
*
* Compute row and column scale factors to
* equilibrate the matrix A.
*
CALL SPBEQU( UPLO, N, KD, AFAC, LDAB, S,
$ SCOND, AMAX, INFO )
IF( INFO.EQ.0 .AND. N.GT.0 ) THEN
IF( IEQUED.GT.1 )
$ SCOND = ZERO
*
* Equilibrate the matrix.
*
CALL SLAQSB( UPLO, N, KD, AFAC, LDAB,
$ S, SCOND, AMAX, EQUED )
END IF
END IF
*
* Save the condition number of the
* non-equilibrated system for use in SGET04.
*
IF( EQUIL )
$ ROLDC = RCONDC
*
* Compute the 1-norm of A.
*
ANORM = SLANSB( '1', UPLO, N, KD, AFAC, LDAB,
$ RWORK )
*
* Factor the matrix A.
*
CALL SPBTRF( UPLO, N, KD, AFAC, LDAB, INFO )
*
* Form the inverse of A.
*
CALL SLASET( 'Full', N, N, ZERO, ONE, A,
$ LDA )
SRNAMT = 'SPBTRS'
CALL SPBTRS( UPLO, N, KD, N, AFAC, LDAB, A,
$ LDA, INFO )
*
* Compute the 1-norm condition number of A.
*
AINVNM = SLANGE( '1', N, N, A, LDA, RWORK )
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDC = ONE
ELSE
RCONDC = ( ONE / ANORM ) / AINVNM
END IF
END IF
*
* Restore the matrix A.
*
CALL SLACPY( 'Full', KD+1, N, ASAV, LDAB, A,
$ LDAB )
*
* Form an exact solution and set the right hand
* side.
*
SRNAMT = 'SLARHS'
CALL SLARHS( PATH, XTYPE, UPLO, ' ', N, N, KD,
$ KD, NRHS, A, LDAB, XACT, LDA, B,
$ LDA, ISEED, INFO )
XTYPE = 'C'
CALL SLACPY( 'Full', N, NRHS, B, LDA, BSAV,
$ LDA )
*
IF( NOFACT ) THEN
*
* --- Test SPBSV ---
*
* Compute the L*L' or U'*U factorization of the
* matrix and solve the system.
*
CALL SLACPY( 'Full', KD+1, N, A, LDAB, AFAC,
$ LDAB )
CALL SLACPY( 'Full', N, NRHS, B, LDA, X,
$ LDA )
*
SRNAMT = 'SPBSV '
CALL SPBSV( UPLO, N, KD, NRHS, AFAC, LDAB, X,
$ LDA, INFO )
*
* Check error code from SPBSV .
*
IF( INFO.NE.IZERO ) THEN
CALL ALAERH( PATH, 'SPBSV ', INFO, IZERO,
$ UPLO, N, N, KD, KD, NRHS,
$ IMAT, NFAIL, NERRS, NOUT )
GO TO 40
ELSE IF( INFO.NE.0 ) THEN
GO TO 40
END IF
*
* Reconstruct matrix from factors and compute
* residual.
*
CALL SPBT01( UPLO, N, KD, A, LDAB, AFAC,
$ LDAB, RWORK, RESULT( 1 ) )
*
* Compute residual of the computed solution.
*
CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK,
$ LDA )
CALL SPBT02( UPLO, N, KD, NRHS, A, LDAB, X,
$ LDA, WORK, LDA, RWORK,
$ RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA,
$ RCONDC, RESULT( 3 ) )
NT = 3
*
* Print information about the tests that did
* not pass the threshold.
*
DO 30 K = 1, NT
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )'SPBSV ',
$ UPLO, N, KD, IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
30 CONTINUE
NRUN = NRUN + NT
40 CONTINUE
END IF
*
* --- Test SPBSVX ---
*
IF( .NOT.PREFAC )
$ CALL SLASET( 'Full', KD+1, N, ZERO, ZERO,
$ AFAC, LDAB )
CALL SLASET( 'Full', N, NRHS, ZERO, ZERO, X,
$ LDA )
IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN
*
* Equilibrate the matrix if FACT='F' and
* EQUED='Y'
*
CALL SLAQSB( UPLO, N, KD, A, LDAB, S, SCOND,
$ AMAX, EQUED )
END IF
*
* Solve the system and compute the condition
* number and error bounds using SPBSVX.
*
SRNAMT = 'SPBSVX'
CALL SPBSVX( FACT, UPLO, N, KD, NRHS, A, LDAB,
$ AFAC, LDAB, EQUED, S, B, LDA, X,
$ LDA, RCOND, RWORK, RWORK( NRHS+1 ),
$ WORK, IWORK, INFO )
*
* Check the error code from SPBSVX.
*
IF( INFO.NE.IZERO ) THEN
CALL ALAERH( PATH, 'SPBSVX', INFO, IZERO,
$ FACT // UPLO, N, N, KD, KD,
$ NRHS, IMAT, NFAIL, NERRS, NOUT )
GO TO 60
END IF
*
IF( INFO.EQ.0 ) THEN
IF( .NOT.PREFAC ) THEN
*
* Reconstruct matrix from factors and
* compute residual.
*
CALL SPBT01( UPLO, N, KD, A, LDAB, AFAC,
$ LDAB, RWORK( 2*NRHS+1 ),
$ RESULT( 1 ) )
K1 = 1
ELSE
K1 = 2
END IF
*
* Compute residual of the computed solution.
*
CALL SLACPY( 'Full', N, NRHS, BSAV, LDA,
$ WORK, LDA )
CALL SPBT02( UPLO, N, KD, NRHS, ASAV, LDAB,
$ X, LDA, WORK, LDA,
$ RWORK( 2*NRHS+1 ), RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED,
$ 'N' ) ) ) THEN
CALL SGET04( N, NRHS, X, LDA, XACT, LDA,
$ RCONDC, RESULT( 3 ) )
ELSE
CALL SGET04( N, NRHS, X, LDA, XACT, LDA,
$ ROLDC, RESULT( 3 ) )
END IF
*
* Check the error bounds from iterative
* refinement.
*
CALL SPBT05( UPLO, N, KD, NRHS, ASAV, LDAB,
$ B, LDA, X, LDA, XACT, LDA,
$ RWORK, RWORK( NRHS+1 ),
$ RESULT( 4 ) )
ELSE
K1 = 6
END IF
*
* Compare RCOND from SPBSVX with the computed
* value in RCONDC.
*
RESULT( 6 ) = SGET06( RCOND, RCONDC )
*
* Print information about the tests that did not
* pass the threshold.
*
DO 50 K = K1, 6
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
IF( PREFAC ) THEN
WRITE( NOUT, FMT = 9997 )'SPBSVX',
$ FACT, UPLO, N, KD, EQUED, IMAT, K,
$ RESULT( K )
ELSE
WRITE( NOUT, FMT = 9998 )'SPBSVX',
$ FACT, UPLO, N, KD, IMAT, K,
$ RESULT( K )
END IF
NFAIL = NFAIL + 1
END IF
50 CONTINUE
NRUN = NRUN + 7 - K1
60 CONTINUE
70 CONTINUE
80 CONTINUE
90 CONTINUE
100 CONTINUE
110 CONTINUE
*
* Print a summary of the results.
*
CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( 1X, A6, ', UPLO=''', A1, ''', N =', I5, ', KD =', I5,
$ ', type ', I1, ', test(', I1, ')=', G12.5 )
9998 FORMAT( 1X, A6, '( ''', A1, ''', ''', A1, ''', ', I5, ', ', I5,
$ ', ... ), type ', I1, ', test(', I1, ')=', G12.5 )
9997 FORMAT( 1X, A6, '( ''', A1, ''', ''', A1, ''', ', I5, ', ', I5,
$ ', ... ), EQUED=''', A1, ''', type ', I1, ', test(', I1,
$ ')=', G12.5 )
RETURN
*
* End of SDRVPB
*
END
SUBROUTINE SDRVPO( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
$ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK,
$ RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NMAX, NN, NOUT, NRHS
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NVAL( * )
REAL A( * ), AFAC( * ), ASAV( * ), B( * ),
$ BSAV( * ), RWORK( * ), S( * ), WORK( * ),
$ X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* SDRVPO tests the driver routines SPOSV and -SVX.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* NRHS (input) INTEGER
* The number of right hand side vectors to be generated for
* each linear system.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for N, used in dimensioning the
* work arrays.
*
* A (workspace) REAL array, dimension (NMAX*NMAX)
*
* AFAC (workspace) REAL array, dimension (NMAX*NMAX)
*
* ASAV (workspace) REAL array, dimension (NMAX*NMAX)
*
* B (workspace) REAL array, dimension (NMAX*NRHS)
*
* BSAV (workspace) REAL array, dimension (NMAX*NRHS)
*
* X (workspace) REAL array, dimension (NMAX*NRHS)
*
* XACT (workspace) REAL array, dimension (NMAX*NRHS)
*
* S (workspace) REAL array, dimension (NMAX)
*
* WORK (workspace) REAL array, dimension
* (NMAX*max(3,NRHS))
*
* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
INTEGER NTYPES
PARAMETER ( NTYPES = 9 )
INTEGER NTESTS
PARAMETER ( NTESTS = 6 )
* ..
* .. Local Scalars ..
LOGICAL EQUIL, NOFACT, PREFAC, ZEROT
CHARACTER DIST, EQUED, FACT, TYPE, UPLO, XTYPE
CHARACTER*3 PATH
INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
$ IZERO, K, K1, KL, KU, LDA, MODE, N, NB, NBMIN,
$ NERRS, NFACT, NFAIL, NIMAT, NRUN, NT
REAL AINVNM, AMAX, ANORM, CNDNUM, RCOND, RCONDC,
$ ROLDC, SCOND
* ..
* .. Local Arrays ..
CHARACTER EQUEDS( 2 ), FACTS( 3 ), UPLOS( 2 )
INTEGER ISEED( 4 ), ISEEDY( 4 )
REAL RESULT( NTESTS )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SGET06, SLANSY
EXTERNAL LSAME, SGET06, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL ALADHD, ALAERH, ALASVM, SERRVX, SGET04, SLACPY,
$ SLAQSY, SLARHS, SLASET, SLATB4, SLATMS, SPOEQU,
$ SPOSV, SPOSVX, SPOT01, SPOT02, SPOT05, SPOTRF,
$ SPOTRI, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
DATA UPLOS / 'U', 'L' /
DATA FACTS / 'F', 'N', 'E' /
DATA EQUEDS / 'N', 'Y' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'PO'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL SERRVX( PATH, NOUT )
INFOT = 0
*
* Set the block size and minimum block size for testing.
*
NB = 1
NBMIN = 2
CALL XLAENV( 1, NB )
CALL XLAENV( 2, NBMIN )
*
* Do for each value of N in NVAL
*
DO 130 IN = 1, NN
N = NVAL( IN )
LDA = MAX( N, 1 )
XTYPE = 'N'
NIMAT = NTYPES
IF( N.LE.0 )
$ NIMAT = 1
*
DO 120 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 120
*
* Skip types 3, 4, or 5 if the matrix size is too small.
*
ZEROT = IMAT.GE.3 .AND. IMAT.LE.5
IF( ZEROT .AND. N.LT.IMAT-2 )
$ GO TO 120
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 110 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
*
* Set up parameters with SLATB4 and generate a test matrix
* with SLATMS.
*
CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
*
SRNAMT = 'SLATMS'
CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
$ INFO )
*
* Check error code from SLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 110
END IF
*
* For types 3-5, zero one row and column of the matrix to
* test that INFO is returned correctly.
*
IF( ZEROT ) THEN
IF( IMAT.EQ.3 ) THEN
IZERO = 1
ELSE IF( IMAT.EQ.4 ) THEN
IZERO = N
ELSE
IZERO = N / 2 + 1
END IF
IOFF = ( IZERO-1 )*LDA
*
* Set row and column IZERO of A to 0.
*
IF( IUPLO.EQ.1 ) THEN
DO 20 I = 1, IZERO - 1
A( IOFF+I ) = ZERO
20 CONTINUE
IOFF = IOFF + IZERO
DO 30 I = IZERO, N
A( IOFF ) = ZERO
IOFF = IOFF + LDA
30 CONTINUE
ELSE
IOFF = IZERO
DO 40 I = 1, IZERO - 1
A( IOFF ) = ZERO
IOFF = IOFF + LDA
40 CONTINUE
IOFF = IOFF - IZERO
DO 50 I = IZERO, N
A( IOFF+I ) = ZERO
50 CONTINUE
END IF
ELSE
IZERO = 0
END IF
*
* Save a copy of the matrix A in ASAV.
*
CALL SLACPY( UPLO, N, N, A, LDA, ASAV, LDA )
*
DO 100 IEQUED = 1, 2
EQUED = EQUEDS( IEQUED )
IF( IEQUED.EQ.1 ) THEN
NFACT = 3
ELSE
NFACT = 1
END IF
*
DO 90 IFACT = 1, NFACT
FACT = FACTS( IFACT )
PREFAC = LSAME( FACT, 'F' )
NOFACT = LSAME( FACT, 'N' )
EQUIL = LSAME( FACT, 'E' )
*
IF( ZEROT ) THEN
IF( PREFAC )
$ GO TO 90
RCONDC = ZERO
*
ELSE IF( .NOT.LSAME( FACT, 'N' ) ) THEN
*
* Compute the condition number for comparison with
* the value returned by SPOSVX (FACT = 'N' reuses
* the condition number from the previous iteration
* with FACT = 'F').
*
CALL SLACPY( UPLO, N, N, ASAV, LDA, AFAC, LDA )
IF( EQUIL .OR. IEQUED.GT.1 ) THEN
*
* Compute row and column scale factors to
* equilibrate the matrix A.
*
CALL SPOEQU( N, AFAC, LDA, S, SCOND, AMAX,
$ INFO )
IF( INFO.EQ.0 .AND. N.GT.0 ) THEN
IF( IEQUED.GT.1 )
$ SCOND = ZERO
*
* Equilibrate the matrix.
*
CALL SLAQSY( UPLO, N, AFAC, LDA, S, SCOND,
$ AMAX, EQUED )
END IF
END IF
*
* Save the condition number of the
* non-equilibrated system for use in SGET04.
*
IF( EQUIL )
$ ROLDC = RCONDC
*
* Compute the 1-norm of A.
*
ANORM = SLANSY( '1', UPLO, N, AFAC, LDA, RWORK )
*
* Factor the matrix A.
*
CALL SPOTRF( UPLO, N, AFAC, LDA, INFO )
*
* Form the inverse of A.
*
CALL SLACPY( UPLO, N, N, AFAC, LDA, A, LDA )
CALL SPOTRI( UPLO, N, A, LDA, INFO )
*
* Compute the 1-norm condition number of A.
*
AINVNM = SLANSY( '1', UPLO, N, A, LDA, RWORK )
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDC = ONE
ELSE
RCONDC = ( ONE / ANORM ) / AINVNM
END IF
END IF
*
* Restore the matrix A.
*
CALL SLACPY( UPLO, N, N, ASAV, LDA, A, LDA )
*
* Form an exact solution and set the right hand side.
*
SRNAMT = 'SLARHS'
CALL SLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
$ NRHS, A, LDA, XACT, LDA, B, LDA,
$ ISEED, INFO )
XTYPE = 'C'
CALL SLACPY( 'Full', N, NRHS, B, LDA, BSAV, LDA )
*
IF( NOFACT ) THEN
*
* --- Test SPOSV ---
*
* Compute the L*L' or U'*U factorization of the
* matrix and solve the system.
*
CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
SRNAMT = 'SPOSV '
CALL SPOSV( UPLO, N, NRHS, AFAC, LDA, X, LDA,
$ INFO )
*
* Check error code from SPOSV .
*
IF( INFO.NE.IZERO ) THEN
CALL ALAERH( PATH, 'SPOSV ', INFO, IZERO,
$ UPLO, N, N, -1, -1, NRHS, IMAT,
$ NFAIL, NERRS, NOUT )
GO TO 70
ELSE IF( INFO.NE.0 ) THEN
GO TO 70
END IF
*
* Reconstruct matrix from factors and compute
* residual.
*
CALL SPOT01( UPLO, N, A, LDA, AFAC, LDA, RWORK,
$ RESULT( 1 ) )
*
* Compute residual of the computed solution.
*
CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK,
$ LDA )
CALL SPOT02( UPLO, N, NRHS, A, LDA, X, LDA,
$ WORK, LDA, RWORK, RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
NT = 3
*
* Print information about the tests that did not
* pass the threshold.
*
DO 60 K = 1, NT
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )'SPOSV ', UPLO,
$ N, IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
60 CONTINUE
NRUN = NRUN + NT
70 CONTINUE
END IF
*
* --- Test SPOSVX ---
*
IF( .NOT.PREFAC )
$ CALL SLASET( UPLO, N, N, ZERO, ZERO, AFAC, LDA )
CALL SLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA )
IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN
*
* Equilibrate the matrix if FACT='F' and
* EQUED='Y'.
*
CALL SLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX,
$ EQUED )
END IF
*
* Solve the system and compute the condition number
* and error bounds using SPOSVX.
*
SRNAMT = 'SPOSVX'
CALL SPOSVX( FACT, UPLO, N, NRHS, A, LDA, AFAC,
$ LDA, EQUED, S, B, LDA, X, LDA, RCOND,
$ RWORK, RWORK( NRHS+1 ), WORK, IWORK,
$ INFO )
*
* Check the error code from SPOSVX.
*
IF( INFO.NE.IZERO ) THEN
CALL ALAERH( PATH, 'SPOSVX', INFO, IZERO,
$ FACT // UPLO, N, N, -1, -1, NRHS,
$ IMAT, NFAIL, NERRS, NOUT )
GO TO 90
END IF
*
IF( INFO.EQ.0 ) THEN
IF( .NOT.PREFAC ) THEN
*
* Reconstruct matrix from factors and compute
* residual.
*
CALL SPOT01( UPLO, N, A, LDA, AFAC, LDA,
$ RWORK( 2*NRHS+1 ), RESULT( 1 ) )
K1 = 1
ELSE
K1 = 2
END IF
*
* Compute residual of the computed solution.
*
CALL SLACPY( 'Full', N, NRHS, BSAV, LDA, WORK,
$ LDA )
CALL SPOT02( UPLO, N, NRHS, ASAV, LDA, X, LDA,
$ WORK, LDA, RWORK( 2*NRHS+1 ),
$ RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED,
$ 'N' ) ) ) THEN
CALL SGET04( N, NRHS, X, LDA, XACT, LDA,
$ RCONDC, RESULT( 3 ) )
ELSE
CALL SGET04( N, NRHS, X, LDA, XACT, LDA,
$ ROLDC, RESULT( 3 ) )
END IF
*
* Check the error bounds from iterative
* refinement.
*
CALL SPOT05( UPLO, N, NRHS, ASAV, LDA, B, LDA,
$ X, LDA, XACT, LDA, RWORK,
$ RWORK( NRHS+1 ), RESULT( 4 ) )
ELSE
K1 = 6
END IF
*
* Compare RCOND from SPOSVX with the computed value
* in RCONDC.
*
RESULT( 6 ) = SGET06( RCOND, RCONDC )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 80 K = K1, 6
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
IF( PREFAC ) THEN
WRITE( NOUT, FMT = 9997 )'SPOSVX', FACT,
$ UPLO, N, EQUED, IMAT, K, RESULT( K )
ELSE
WRITE( NOUT, FMT = 9998 )'SPOSVX', FACT,
$ UPLO, N, IMAT, K, RESULT( K )
END IF
NFAIL = NFAIL + 1
END IF
80 CONTINUE
NRUN = NRUN + 7 - K1
90 CONTINUE
100 CONTINUE
110 CONTINUE
120 CONTINUE
130 CONTINUE
*
* Print a summary of the results.
*
CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( 1X, A6, ', UPLO=''', A1, ''', N =', I5, ', type ', I1,
$ ', test(', I1, ')=', G12.5 )
9998 FORMAT( 1X, A6, ', FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5,
$ ', type ', I1, ', test(', I1, ')=', G12.5 )
9997 FORMAT( 1X, A6, ', FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5,
$ ', EQUED=''', A1, ''', type ', I1, ', test(', I1, ') =',
$ G12.5 )
RETURN
*
* End of SDRVPO
*
END
SUBROUTINE SDRVPP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
$ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK,
$ RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NMAX, NN, NOUT, NRHS
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NVAL( * )
REAL A( * ), AFAC( * ), ASAV( * ), B( * ),
$ BSAV( * ), RWORK( * ), S( * ), WORK( * ),
$ X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* SDRVPP tests the driver routines SPPSV and -SVX.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* NRHS (input) INTEGER
* The number of right hand side vectors to be generated for
* each linear system.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for N, used in dimensioning the
* work arrays.
*
* A (workspace) REAL array, dimension
* (NMAX*(NMAX+1)/2)
*
* AFAC (workspace) REAL array, dimension
* (NMAX*(NMAX+1)/2)
*
* ASAV (workspace) REAL array, dimension
* (NMAX*(NMAX+1)/2)
*
* B (workspace) REAL array, dimension (NMAX*NRHS)
*
* BSAV (workspace) REAL array, dimension (NMAX*NRHS)
*
* X (workspace) REAL array, dimension (NMAX*NRHS)
*
* XACT (workspace) REAL array, dimension (NMAX*NRHS)
*
* S (workspace) REAL array, dimension (NMAX)
*
* WORK (workspace) REAL array, dimension
* (NMAX*max(3,NRHS))
*
* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
INTEGER NTYPES
PARAMETER ( NTYPES = 9 )
INTEGER NTESTS
PARAMETER ( NTESTS = 6 )
* ..
* .. Local Scalars ..
LOGICAL EQUIL, NOFACT, PREFAC, ZEROT
CHARACTER DIST, EQUED, FACT, PACKIT, TYPE, UPLO, XTYPE
CHARACTER*3 PATH
INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
$ IZERO, K, K1, KL, KU, LDA, MODE, N, NERRS,
$ NFACT, NFAIL, NIMAT, NPP, NRUN, NT
REAL AINVNM, AMAX, ANORM, CNDNUM, RCOND, RCONDC,
$ ROLDC, SCOND
* ..
* .. Local Arrays ..
CHARACTER EQUEDS( 2 ), FACTS( 3 ), PACKS( 2 ), UPLOS( 2 )
INTEGER ISEED( 4 ), ISEEDY( 4 )
REAL RESULT( NTESTS )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SGET06, SLANSP
EXTERNAL LSAME, SGET06, SLANSP
* ..
* .. External Subroutines ..
EXTERNAL ALADHD, ALAERH, ALASVM, SCOPY, SERRVX, SGET04,
$ SLACPY, SLAQSP, SLARHS, SLASET, SLATB4, SLATMS,
$ SPPEQU, SPPSV, SPPSVX, SPPT01, SPPT02, SPPT05,
$ SPPTRF, SPPTRI
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N', 'E' / ,
$ PACKS / 'C', 'R' / , EQUEDS / 'N', 'Y' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'PP'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL SERRVX( PATH, NOUT )
INFOT = 0
*
* Do for each value of N in NVAL
*
DO 140 IN = 1, NN
N = NVAL( IN )
LDA = MAX( N, 1 )
NPP = N*( N+1 ) / 2
XTYPE = 'N'
NIMAT = NTYPES
IF( N.LE.0 )
$ NIMAT = 1
*
DO 130 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 130
*
* Skip types 3, 4, or 5 if the matrix size is too small.
*
ZEROT = IMAT.GE.3 .AND. IMAT.LE.5
IF( ZEROT .AND. N.LT.IMAT-2 )
$ GO TO 130
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 120 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
PACKIT = PACKS( IUPLO )
*
* Set up parameters with SLATB4 and generate a test matrix
* with SLATMS.
*
CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
RCONDC = ONE / CNDNUM
*
SRNAMT = 'SLATMS'
CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
$ INFO )
*
* Check error code from SLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 120
END IF
*
* For types 3-5, zero one row and column of the matrix to
* test that INFO is returned correctly.
*
IF( ZEROT ) THEN
IF( IMAT.EQ.3 ) THEN
IZERO = 1
ELSE IF( IMAT.EQ.4 ) THEN
IZERO = N
ELSE
IZERO = N / 2 + 1
END IF
*
* Set row and column IZERO of A to 0.
*
IF( IUPLO.EQ.1 ) THEN
IOFF = ( IZERO-1 )*IZERO / 2
DO 20 I = 1, IZERO - 1
A( IOFF+I ) = ZERO
20 CONTINUE
IOFF = IOFF + IZERO
DO 30 I = IZERO, N
A( IOFF ) = ZERO
IOFF = IOFF + I
30 CONTINUE
ELSE
IOFF = IZERO
DO 40 I = 1, IZERO - 1
A( IOFF ) = ZERO
IOFF = IOFF + N - I
40 CONTINUE
IOFF = IOFF - IZERO
DO 50 I = IZERO, N
A( IOFF+I ) = ZERO
50 CONTINUE
END IF
ELSE
IZERO = 0
END IF
*
* Save a copy of the matrix A in ASAV.
*
CALL SCOPY( NPP, A, 1, ASAV, 1 )
*
DO 110 IEQUED = 1, 2
EQUED = EQUEDS( IEQUED )
IF( IEQUED.EQ.1 ) THEN
NFACT = 3
ELSE
NFACT = 1
END IF
*
DO 100 IFACT = 1, NFACT
FACT = FACTS( IFACT )
PREFAC = LSAME( FACT, 'F' )
NOFACT = LSAME( FACT, 'N' )
EQUIL = LSAME( FACT, 'E' )
*
IF( ZEROT ) THEN
IF( PREFAC )
$ GO TO 100
RCONDC = ZERO
*
ELSE IF( .NOT.LSAME( FACT, 'N' ) ) THEN
*
* Compute the condition number for comparison with
* the value returned by SPPSVX (FACT = 'N' reuses
* the condition number from the previous iteration
* with FACT = 'F').
*
CALL SCOPY( NPP, ASAV, 1, AFAC, 1 )
IF( EQUIL .OR. IEQUED.GT.1 ) THEN
*
* Compute row and column scale factors to
* equilibrate the matrix A.
*
CALL SPPEQU( UPLO, N, AFAC, S, SCOND, AMAX,
$ INFO )
IF( INFO.EQ.0 .AND. N.GT.0 ) THEN
IF( IEQUED.GT.1 )
$ SCOND = ZERO
*
* Equilibrate the matrix.
*
CALL SLAQSP( UPLO, N, AFAC, S, SCOND,
$ AMAX, EQUED )
END IF
END IF
*
* Save the condition number of the
* non-equilibrated system for use in SGET04.
*
IF( EQUIL )
$ ROLDC = RCONDC
*
* Compute the 1-norm of A.
*
ANORM = SLANSP( '1', UPLO, N, AFAC, RWORK )
*
* Factor the matrix A.
*
CALL SPPTRF( UPLO, N, AFAC, INFO )
*
* Form the inverse of A.
*
CALL SCOPY( NPP, AFAC, 1, A, 1 )
CALL SPPTRI( UPLO, N, A, INFO )
*
* Compute the 1-norm condition number of A.
*
AINVNM = SLANSP( '1', UPLO, N, A, RWORK )
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDC = ONE
ELSE
RCONDC = ( ONE / ANORM ) / AINVNM
END IF
END IF
*
* Restore the matrix A.
*
CALL SCOPY( NPP, ASAV, 1, A, 1 )
*
* Form an exact solution and set the right hand side.
*
SRNAMT = 'SLARHS'
CALL SLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
$ NRHS, A, LDA, XACT, LDA, B, LDA,
$ ISEED, INFO )
XTYPE = 'C'
CALL SLACPY( 'Full', N, NRHS, B, LDA, BSAV, LDA )
*
IF( NOFACT ) THEN
*
* --- Test SPPSV ---
*
* Compute the L*L' or U'*U factorization of the
* matrix and solve the system.
*
CALL SCOPY( NPP, A, 1, AFAC, 1 )
CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
SRNAMT = 'SPPSV '
CALL SPPSV( UPLO, N, NRHS, AFAC, X, LDA, INFO )
*
* Check error code from SPPSV .
*
IF( INFO.NE.IZERO ) THEN
CALL ALAERH( PATH, 'SPPSV ', INFO, IZERO,
$ UPLO, N, N, -1, -1, NRHS, IMAT,
$ NFAIL, NERRS, NOUT )
GO TO 70
ELSE IF( INFO.NE.0 ) THEN
GO TO 70
END IF
*
* Reconstruct matrix from factors and compute
* residual.
*
CALL SPPT01( UPLO, N, A, AFAC, RWORK,
$ RESULT( 1 ) )
*
* Compute residual of the computed solution.
*
CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK,
$ LDA )
CALL SPPT02( UPLO, N, NRHS, A, X, LDA, WORK,
$ LDA, RWORK, RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
NT = 3
*
* Print information about the tests that did not
* pass the threshold.
*
DO 60 K = 1, NT
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )'SPPSV ', UPLO,
$ N, IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
60 CONTINUE
NRUN = NRUN + NT
70 CONTINUE
END IF
*
* --- Test SPPSVX ---
*
IF( .NOT.PREFAC .AND. NPP.GT.0 )
$ CALL SLASET( 'Full', NPP, 1, ZERO, ZERO, AFAC,
$ NPP )
CALL SLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA )
IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN
*
* Equilibrate the matrix if FACT='F' and
* EQUED='Y'.
*
CALL SLAQSP( UPLO, N, A, S, SCOND, AMAX, EQUED )
END IF
*
* Solve the system and compute the condition number
* and error bounds using SPPSVX.
*
SRNAMT = 'SPPSVX'
CALL SPPSVX( FACT, UPLO, N, NRHS, A, AFAC, EQUED,
$ S, B, LDA, X, LDA, RCOND, RWORK,
$ RWORK( NRHS+1 ), WORK, IWORK, INFO )
*
* Check the error code from SPPSVX.
*
IF( INFO.NE.IZERO ) THEN
CALL ALAERH( PATH, 'SPPSVX', INFO, IZERO,
$ FACT // UPLO, N, N, -1, -1, NRHS,
$ IMAT, NFAIL, NERRS, NOUT )
GO TO 90
END IF
*
IF( INFO.EQ.0 ) THEN
IF( .NOT.PREFAC ) THEN
*
* Reconstruct matrix from factors and compute
* residual.
*
CALL SPPT01( UPLO, N, A, AFAC,
$ RWORK( 2*NRHS+1 ), RESULT( 1 ) )
K1 = 1
ELSE
K1 = 2
END IF
*
* Compute residual of the computed solution.
*
CALL SLACPY( 'Full', N, NRHS, BSAV, LDA, WORK,
$ LDA )
CALL SPPT02( UPLO, N, NRHS, ASAV, X, LDA, WORK,
$ LDA, RWORK( 2*NRHS+1 ),
$ RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED,
$ 'N' ) ) ) THEN
CALL SGET04( N, NRHS, X, LDA, XACT, LDA,
$ RCONDC, RESULT( 3 ) )
ELSE
CALL SGET04( N, NRHS, X, LDA, XACT, LDA,
$ ROLDC, RESULT( 3 ) )
END IF
*
* Check the error bounds from iterative
* refinement.
*
CALL SPPT05( UPLO, N, NRHS, ASAV, B, LDA, X,
$ LDA, XACT, LDA, RWORK,
$ RWORK( NRHS+1 ), RESULT( 4 ) )
ELSE
K1 = 6
END IF
*
* Compare RCOND from SPPSVX with the computed value
* in RCONDC.
*
RESULT( 6 ) = SGET06( RCOND, RCONDC )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 80 K = K1, 6
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
IF( PREFAC ) THEN
WRITE( NOUT, FMT = 9997 )'SPPSVX', FACT,
$ UPLO, N, EQUED, IMAT, K, RESULT( K )
ELSE
WRITE( NOUT, FMT = 9998 )'SPPSVX', FACT,
$ UPLO, N, IMAT, K, RESULT( K )
END IF
NFAIL = NFAIL + 1
END IF
80 CONTINUE
NRUN = NRUN + 7 - K1
90 CONTINUE
100 CONTINUE
110 CONTINUE
120 CONTINUE
130 CONTINUE
140 CONTINUE
*
* Print a summary of the results.
*
CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( 1X, A6, ', UPLO=''', A1, ''', N =', I5, ', type ', I1,
$ ', test(', I1, ')=', G12.5 )
9998 FORMAT( 1X, A6, ', FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5,
$ ', type ', I1, ', test(', I1, ')=', G12.5 )
9997 FORMAT( 1X, A6, ', FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5,
$ ', EQUED=''', A1, ''', type ', I1, ', test(', I1, ')=',
$ G12.5 )
RETURN
*
* End of SDRVPP
*
END
SUBROUTINE SDRVPT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, D,
$ E, B, X, XACT, WORK, RWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NN, NOUT, NRHS
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER NVAL( * )
REAL A( * ), B( * ), D( * ), E( * ), RWORK( * ),
$ WORK( * ), X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* SDRVPT tests SPTSV and -SVX.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* NRHS (input) INTEGER
* The number of right hand side vectors to be generated for
* each linear system.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* A (workspace) REAL array, dimension (NMAX*2)
*
* D (workspace) REAL array, dimension (NMAX*2)
*
* E (workspace) REAL array, dimension (NMAX*2)
*
* B (workspace) REAL array, dimension (NMAX*NRHS)
*
* X (workspace) REAL array, dimension (NMAX*NRHS)
*
* XACT (workspace) REAL array, dimension (NMAX*NRHS)
*
* WORK (workspace) REAL array, dimension
* (NMAX*max(3,NRHS))
*
* RWORK (workspace) REAL array, dimension
* (max(NMAX,2*NRHS))
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
INTEGER NTYPES
PARAMETER ( NTYPES = 12 )
INTEGER NTESTS
PARAMETER ( NTESTS = 6 )
* ..
* .. Local Scalars ..
LOGICAL ZEROT
CHARACTER DIST, FACT, TYPE
CHARACTER*3 PATH
INTEGER I, IA, IFACT, IMAT, IN, INFO, IX, IZERO, J, K,
$ K1, KL, KU, LDA, MODE, N, NERRS, NFAIL, NIMAT,
$ NRUN, NT
REAL AINVNM, ANORM, COND, DMAX, RCOND, RCONDC
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 ), ISEEDY( 4 )
REAL RESULT( NTESTS ), Z( 3 )
* ..
* .. External Functions ..
INTEGER ISAMAX
REAL SASUM, SGET06, SLANST
EXTERNAL ISAMAX, SASUM, SGET06, SLANST
* ..
* .. External Subroutines ..
EXTERNAL ALADHD, ALAERH, ALASVM, SCOPY, SERRVX, SGET04,
$ SLACPY, SLAPTM, SLARNV, SLASET, SLATB4, SLATMS,
$ SPTSV, SPTSVX, SPTT01, SPTT02, SPTT05, SPTTRF,
$ SPTTRS, SSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 0, 0, 0, 1 /
* ..
* .. Executable Statements ..
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'PT'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL SERRVX( PATH, NOUT )
INFOT = 0
*
DO 120 IN = 1, NN
*
* Do for each value of N in NVAL.
*
N = NVAL( IN )
LDA = MAX( 1, N )
NIMAT = NTYPES
IF( N.LE.0 )
$ NIMAT = 1
*
DO 110 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( N.GT.0 .AND. .NOT.DOTYPE( IMAT ) )
$ GO TO 110
*
* Set up parameters with SLATB4.
*
CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ COND, DIST )
*
ZEROT = IMAT.GE.8 .AND. IMAT.LE.10
IF( IMAT.LE.6 ) THEN
*
* Type 1-6: generate a symmetric tridiagonal matrix of
* known condition number in lower triangular band storage.
*
SRNAMT = 'SLATMS'
CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, COND,
$ ANORM, KL, KU, 'B', A, 2, WORK, INFO )
*
* Check the error code from SLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', N, N, KL,
$ KU, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 110
END IF
IZERO = 0
*
* Copy the matrix to D and E.
*
IA = 1
DO 20 I = 1, N - 1
D( I ) = A( IA )
E( I ) = A( IA+1 )
IA = IA + 2
20 CONTINUE
IF( N.GT.0 )
$ D( N ) = A( IA )
ELSE
*
* Type 7-12: generate a diagonally dominant matrix with
* unknown condition number in the vectors D and E.
*
IF( .NOT.ZEROT .OR. .NOT.DOTYPE( 7 ) ) THEN
*
* Let D and E have values from [-1,1].
*
CALL SLARNV( 2, ISEED, N, D )
CALL SLARNV( 2, ISEED, N-1, E )
*
* Make the tridiagonal matrix diagonally dominant.
*
IF( N.EQ.1 ) THEN
D( 1 ) = ABS( D( 1 ) )
ELSE
D( 1 ) = ABS( D( 1 ) ) + ABS( E( 1 ) )
D( N ) = ABS( D( N ) ) + ABS( E( N-1 ) )
DO 30 I = 2, N - 1
D( I ) = ABS( D( I ) ) + ABS( E( I ) ) +
$ ABS( E( I-1 ) )
30 CONTINUE
END IF
*
* Scale D and E so the maximum element is ANORM.
*
IX = ISAMAX( N, D, 1 )
DMAX = D( IX )
CALL SSCAL( N, ANORM / DMAX, D, 1 )
IF( N.GT.1 )
$ CALL SSCAL( N-1, ANORM / DMAX, E, 1 )
*
ELSE IF( IZERO.GT.0 ) THEN
*
* Reuse the last matrix by copying back the zeroed out
* elements.
*
IF( IZERO.EQ.1 ) THEN
D( 1 ) = Z( 2 )
IF( N.GT.1 )
$ E( 1 ) = Z( 3 )
ELSE IF( IZERO.EQ.N ) THEN
E( N-1 ) = Z( 1 )
D( N ) = Z( 2 )
ELSE
E( IZERO-1 ) = Z( 1 )
D( IZERO ) = Z( 2 )
E( IZERO ) = Z( 3 )
END IF
END IF
*
* For types 8-10, set one row and column of the matrix to
* zero.
*
IZERO = 0
IF( IMAT.EQ.8 ) THEN
IZERO = 1
Z( 2 ) = D( 1 )
D( 1 ) = ZERO
IF( N.GT.1 ) THEN
Z( 3 ) = E( 1 )
E( 1 ) = ZERO
END IF
ELSE IF( IMAT.EQ.9 ) THEN
IZERO = N
IF( N.GT.1 ) THEN
Z( 1 ) = E( N-1 )
E( N-1 ) = ZERO
END IF
Z( 2 ) = D( N )
D( N ) = ZERO
ELSE IF( IMAT.EQ.10 ) THEN
IZERO = ( N+1 ) / 2
IF( IZERO.GT.1 ) THEN
Z( 1 ) = E( IZERO-1 )
Z( 3 ) = E( IZERO )
E( IZERO-1 ) = ZERO
E( IZERO ) = ZERO
END IF
Z( 2 ) = D( IZERO )
D( IZERO ) = ZERO
END IF
END IF
*
* Generate NRHS random solution vectors.
*
IX = 1
DO 40 J = 1, NRHS
CALL SLARNV( 2, ISEED, N, XACT( IX ) )
IX = IX + LDA
40 CONTINUE
*
* Set the right hand side.
*
CALL SLAPTM( N, NRHS, ONE, D, E, XACT, LDA, ZERO, B, LDA )
*
DO 100 IFACT = 1, 2
IF( IFACT.EQ.1 ) THEN
FACT = 'F'
ELSE
FACT = 'N'
END IF
*
* Compute the condition number for comparison with
* the value returned by SPTSVX.
*
IF( ZEROT ) THEN
IF( IFACT.EQ.1 )
$ GO TO 100
RCONDC = ZERO
*
ELSE IF( IFACT.EQ.1 ) THEN
*
* Compute the 1-norm of A.
*
ANORM = SLANST( '1', N, D, E )
*
CALL SCOPY( N, D, 1, D( N+1 ), 1 )
IF( N.GT.1 )
$ CALL SCOPY( N-1, E, 1, E( N+1 ), 1 )
*
* Factor the matrix A.
*
CALL SPTTRF( N, D( N+1 ), E( N+1 ), INFO )
*
* Use SPTTRS to solve for one column at a time of
* inv(A), computing the maximum column sum as we go.
*
AINVNM = ZERO
DO 60 I = 1, N
DO 50 J = 1, N
X( J ) = ZERO
50 CONTINUE
X( I ) = ONE
CALL SPTTRS( N, 1, D( N+1 ), E( N+1 ), X, LDA,
$ INFO )
AINVNM = MAX( AINVNM, SASUM( N, X, 1 ) )
60 CONTINUE
*
* Compute the 1-norm condition number of A.
*
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDC = ONE
ELSE
RCONDC = ( ONE / ANORM ) / AINVNM
END IF
END IF
*
IF( IFACT.EQ.2 ) THEN
*
* --- Test SPTSV --
*
CALL SCOPY( N, D, 1, D( N+1 ), 1 )
IF( N.GT.1 )
$ CALL SCOPY( N-1, E, 1, E( N+1 ), 1 )
CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
* Factor A as L*D*L' and solve the system A*X = B.
*
SRNAMT = 'SPTSV '
CALL SPTSV( N, NRHS, D( N+1 ), E( N+1 ), X, LDA,
$ INFO )
*
* Check error code from SPTSV .
*
IF( INFO.NE.IZERO )
$ CALL ALAERH( PATH, 'SPTSV ', INFO, IZERO, ' ', N,
$ N, 1, 1, NRHS, IMAT, NFAIL, NERRS,
$ NOUT )
NT = 0
IF( IZERO.EQ.0 ) THEN
*
* Check the factorization by computing the ratio
* norm(L*D*L' - A) / (n * norm(A) * EPS )
*
CALL SPTT01( N, D, E, D( N+1 ), E( N+1 ), WORK,
$ RESULT( 1 ) )
*
* Compute the residual in the solution.
*
CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
CALL SPTT02( N, NRHS, D, E, X, LDA, WORK, LDA,
$ RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
NT = 3
END IF
*
* Print information about the tests that did not pass
* the threshold.
*
DO 70 K = 1, NT
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )'SPTSV ', N, IMAT, K,
$ RESULT( K )
NFAIL = NFAIL + 1
END IF
70 CONTINUE
NRUN = NRUN + NT
END IF
*
* --- Test SPTSVX ---
*
IF( IFACT.GT.1 ) THEN
*
* Initialize D( N+1:2*N ) and E( N+1:2*N ) to zero.
*
DO 80 I = 1, N - 1
D( N+I ) = ZERO
E( N+I ) = ZERO
80 CONTINUE
IF( N.GT.0 )
$ D( N+N ) = ZERO
END IF
*
CALL SLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA )
*
* Solve the system and compute the condition number and
* error bounds using SPTSVX.
*
SRNAMT = 'SPTSVX'
CALL SPTSVX( FACT, N, NRHS, D, E, D( N+1 ), E( N+1 ), B,
$ LDA, X, LDA, RCOND, RWORK, RWORK( NRHS+1 ),
$ WORK, INFO )
*
* Check the error code from SPTSVX.
*
IF( INFO.NE.IZERO )
$ CALL ALAERH( PATH, 'SPTSVX', INFO, IZERO, FACT, N, N,
$ 1, 1, NRHS, IMAT, NFAIL, NERRS, NOUT )
IF( IZERO.EQ.0 ) THEN
IF( IFACT.EQ.2 ) THEN
*
* Check the factorization by computing the ratio
* norm(L*D*L' - A) / (n * norm(A) * EPS )
*
K1 = 1
CALL SPTT01( N, D, E, D( N+1 ), E( N+1 ), WORK,
$ RESULT( 1 ) )
ELSE
K1 = 2
END IF
*
* Compute the residual in the solution.
*
CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
CALL SPTT02( N, NRHS, D, E, X, LDA, WORK, LDA,
$ RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
*
* Check error bounds from iterative refinement.
*
CALL SPTT05( N, NRHS, D, E, B, LDA, X, LDA, XACT, LDA,
$ RWORK, RWORK( NRHS+1 ), RESULT( 4 ) )
ELSE
K1 = 6
END IF
*
* Check the reciprocal of the condition number.
*
RESULT( 6 ) = SGET06( RCOND, RCONDC )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 90 K = K1, 6
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )'SPTSVX', FACT, N, IMAT,
$ K, RESULT( K )
NFAIL = NFAIL + 1
END IF
90 CONTINUE
NRUN = NRUN + 7 - K1
100 CONTINUE
110 CONTINUE
120 CONTINUE
*
* Print a summary of the results.
*
CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( 1X, A6, ', N =', I5, ', type ', I2, ', test ', I2,
$ ', ratio = ', G12.5 )
9998 FORMAT( 1X, A6, ', FACT=''', A1, ''', N =', I5, ', type ', I2,
$ ', test ', I2, ', ratio = ', G12.5 )
RETURN
*
* End of SDRVPT
*
END
SUBROUTINE SDRVSP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
$ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK,
$ NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NMAX, NN, NOUT, NRHS
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NVAL( * )
REAL A( * ), AFAC( * ), AINV( * ), B( * ),
$ RWORK( * ), WORK( * ), X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* SDRVSP tests the driver routines SSPSV and -SVX.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* NRHS (input) INTEGER
* The number of right hand side vectors to be generated for
* each linear system.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for N, used in dimensioning the
* work arrays.
*
* A (workspace) REAL array, dimension
* (NMAX*(NMAX+1)/2)
*
* AFAC (workspace) REAL array, dimension
* (NMAX*(NMAX+1)/2)
*
* AINV (workspace) REAL array, dimension
* (NMAX*(NMAX+1)/2)
*
* B (workspace) REAL array, dimension (NMAX*NRHS)
*
* X (workspace) REAL array, dimension (NMAX*NRHS)
*
* XACT (workspace) REAL array, dimension (NMAX*NRHS)
*
* WORK (workspace) REAL array, dimension
* (NMAX*max(2,NRHS))
*
* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS)
*
* IWORK (workspace) INTEGER array, dimension (2*NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
INTEGER NTYPES, NTESTS
PARAMETER ( NTYPES = 10, NTESTS = 6 )
INTEGER NFACT
PARAMETER ( NFACT = 2 )
* ..
* .. Local Scalars ..
LOGICAL ZEROT
CHARACTER DIST, FACT, PACKIT, TYPE, UPLO, XTYPE
CHARACTER*3 PATH
INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
$ IZERO, J, K, K1, KL, KU, LDA, LWORK, MODE, N,
$ NERRS, NFAIL, NIMAT, NPP, NRUN, NT
REAL AINVNM, ANORM, CNDNUM, RCOND, RCONDC
* ..
* .. Local Arrays ..
CHARACTER FACTS( NFACT )
INTEGER ISEED( 4 ), ISEEDY( 4 )
REAL RESULT( NTESTS )
* ..
* .. External Functions ..
REAL SGET06, SLANSP
EXTERNAL SGET06, SLANSP
* ..
* .. External Subroutines ..
EXTERNAL ALADHD, ALAERH, ALASVM, SCOPY, SERRVX, SGET04,
$ SLACPY, SLARHS, SLASET, SLATB4, SLATMS, SPPT02,
$ SPPT05, SSPSV, SSPSVX, SSPT01, SSPTRF, SSPTRI
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
DATA FACTS / 'F', 'N' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'SP'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
LWORK = MAX( 2*NMAX, NMAX*NRHS )
*
* Test the error exits
*
IF( TSTERR )
$ CALL SERRVX( PATH, NOUT )
INFOT = 0
*
* Do for each value of N in NVAL
*
DO 180 IN = 1, NN
N = NVAL( IN )
LDA = MAX( N, 1 )
NPP = N*( N+1 ) / 2
XTYPE = 'N'
NIMAT = NTYPES
IF( N.LE.0 )
$ NIMAT = 1
*
DO 170 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 170
*
* Skip types 3, 4, 5, or 6 if the matrix size is too small.
*
ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
IF( ZEROT .AND. N.LT.IMAT-2 )
$ GO TO 170
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 160 IUPLO = 1, 2
IF( IUPLO.EQ.1 ) THEN
UPLO = 'U'
PACKIT = 'C'
ELSE
UPLO = 'L'
PACKIT = 'R'
END IF
*
* Set up parameters with SLATB4 and generate a test matrix
* with SLATMS.
*
CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
*
SRNAMT = 'SLATMS'
CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
$ INFO )
*
* Check error code from SLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 160
END IF
*
* For types 3-6, zero one or more rows and columns of the
* matrix to test that INFO is returned correctly.
*
IF( ZEROT ) THEN
IF( IMAT.EQ.3 ) THEN
IZERO = 1
ELSE IF( IMAT.EQ.4 ) THEN
IZERO = N
ELSE
IZERO = N / 2 + 1
END IF
*
IF( IMAT.LT.6 ) THEN
*
* Set row and column IZERO to zero.
*
IF( IUPLO.EQ.1 ) THEN
IOFF = ( IZERO-1 )*IZERO / 2
DO 20 I = 1, IZERO - 1
A( IOFF+I ) = ZERO
20 CONTINUE
IOFF = IOFF + IZERO
DO 30 I = IZERO, N
A( IOFF ) = ZERO
IOFF = IOFF + I
30 CONTINUE
ELSE
IOFF = IZERO
DO 40 I = 1, IZERO - 1
A( IOFF ) = ZERO
IOFF = IOFF + N - I
40 CONTINUE
IOFF = IOFF - IZERO
DO 50 I = IZERO, N
A( IOFF+I ) = ZERO
50 CONTINUE
END IF
ELSE
IOFF = 0
IF( IUPLO.EQ.1 ) THEN
*
* Set the first IZERO rows and columns to zero.
*
DO 70 J = 1, N
I2 = MIN( J, IZERO )
DO 60 I = 1, I2
A( IOFF+I ) = ZERO
60 CONTINUE
IOFF = IOFF + J
70 CONTINUE
ELSE
*
* Set the last IZERO rows and columns to zero.
*
DO 90 J = 1, N
I1 = MAX( J, IZERO )
DO 80 I = I1, N
A( IOFF+I ) = ZERO
80 CONTINUE
IOFF = IOFF + N - J
90 CONTINUE
END IF
END IF
ELSE
IZERO = 0
END IF
*
DO 150 IFACT = 1, NFACT
*
* Do first for FACT = 'F', then for other values.
*
FACT = FACTS( IFACT )
*
* Compute the condition number for comparison with
* the value returned by SSPSVX.
*
IF( ZEROT ) THEN
IF( IFACT.EQ.1 )
$ GO TO 150
RCONDC = ZERO
*
ELSE IF( IFACT.EQ.1 ) THEN
*
* Compute the 1-norm of A.
*
ANORM = SLANSP( '1', UPLO, N, A, RWORK )
*
* Factor the matrix A.
*
CALL SCOPY( NPP, A, 1, AFAC, 1 )
CALL SSPTRF( UPLO, N, AFAC, IWORK, INFO )
*
* Compute inv(A) and take its norm.
*
CALL SCOPY( NPP, AFAC, 1, AINV, 1 )
CALL SSPTRI( UPLO, N, AINV, IWORK, WORK, INFO )
AINVNM = SLANSP( '1', UPLO, N, AINV, RWORK )
*
* Compute the 1-norm condition number of A.
*
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDC = ONE
ELSE
RCONDC = ( ONE / ANORM ) / AINVNM
END IF
END IF
*
* Form an exact solution and set the right hand side.
*
SRNAMT = 'SLARHS'
CALL SLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
$ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED,
$ INFO )
XTYPE = 'C'
*
* --- Test SSPSV ---
*
IF( IFACT.EQ.2 ) THEN
CALL SCOPY( NPP, A, 1, AFAC, 1 )
CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
* Factor the matrix and solve the system using SSPSV.
*
SRNAMT = 'SSPSV '
CALL SSPSV( UPLO, N, NRHS, AFAC, IWORK, X, LDA,
$ INFO )
*
* Adjust the expected value of INFO to account for
* pivoting.
*
K = IZERO
IF( K.GT.0 ) THEN
100 CONTINUE
IF( IWORK( K ).LT.0 ) THEN
IF( IWORK( K ).NE.-K ) THEN
K = -IWORK( K )
GO TO 100
END IF
ELSE IF( IWORK( K ).NE.K ) THEN
K = IWORK( K )
GO TO 100
END IF
END IF
*
* Check error code from SSPSV .
*
IF( INFO.NE.K ) THEN
CALL ALAERH( PATH, 'SSPSV ', INFO, K, UPLO, N,
$ N, -1, -1, NRHS, IMAT, NFAIL,
$ NERRS, NOUT )
GO TO 120
ELSE IF( INFO.NE.0 ) THEN
GO TO 120
END IF
*
* Reconstruct matrix from factors and compute
* residual.
*
CALL SSPT01( UPLO, N, A, AFAC, IWORK, AINV, LDA,
$ RWORK, RESULT( 1 ) )
*
* Compute residual of the computed solution.
*
CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
CALL SPPT02( UPLO, N, NRHS, A, X, LDA, WORK, LDA,
$ RWORK, RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
NT = 3
*
* Print information about the tests that did not pass
* the threshold.
*
DO 110 K = 1, NT
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )'SSPSV ', UPLO, N,
$ IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
110 CONTINUE
NRUN = NRUN + NT
120 CONTINUE
END IF
*
* --- Test SSPSVX ---
*
IF( IFACT.EQ.2 .AND. NPP.GT.0 )
$ CALL SLASET( 'Full', NPP, 1, ZERO, ZERO, AFAC,
$ NPP )
CALL SLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA )
*
* Solve the system and compute the condition number and
* error bounds using SSPSVX.
*
SRNAMT = 'SSPSVX'
CALL SSPSVX( FACT, UPLO, N, NRHS, A, AFAC, IWORK, B,
$ LDA, X, LDA, RCOND, RWORK,
$ RWORK( NRHS+1 ), WORK, IWORK( N+1 ),
$ INFO )
*
* Adjust the expected value of INFO to account for
* pivoting.
*
K = IZERO
IF( K.GT.0 ) THEN
130 CONTINUE
IF( IWORK( K ).LT.0 ) THEN
IF( IWORK( K ).NE.-K ) THEN
K = -IWORK( K )
GO TO 130
END IF
ELSE IF( IWORK( K ).NE.K ) THEN
K = IWORK( K )
GO TO 130
END IF
END IF
*
* Check the error code from SSPSVX.
*
IF( INFO.NE.K ) THEN
CALL ALAERH( PATH, 'SSPSVX', INFO, K, FACT // UPLO,
$ N, N, -1, -1, NRHS, IMAT, NFAIL,
$ NERRS, NOUT )
GO TO 150
END IF
*
IF( INFO.EQ.0 ) THEN
IF( IFACT.GE.2 ) THEN
*
* Reconstruct matrix from factors and compute
* residual.
*
CALL SSPT01( UPLO, N, A, AFAC, IWORK, AINV, LDA,
$ RWORK( 2*NRHS+1 ), RESULT( 1 ) )
K1 = 1
ELSE
K1 = 2
END IF
*
* Compute residual of the computed solution.
*
CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
CALL SPPT02( UPLO, N, NRHS, A, X, LDA, WORK, LDA,
$ RWORK( 2*NRHS+1 ), RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
*
* Check the error bounds from iterative refinement.
*
CALL SPPT05( UPLO, N, NRHS, A, B, LDA, X, LDA,
$ XACT, LDA, RWORK, RWORK( NRHS+1 ),
$ RESULT( 4 ) )
ELSE
K1 = 6
END IF
*
* Compare RCOND from SSPSVX with the computed value
* in RCONDC.
*
RESULT( 6 ) = SGET06( RCOND, RCONDC )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 140 K = K1, 6
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )'SSPSVX', FACT, UPLO,
$ N, IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
140 CONTINUE
NRUN = NRUN + 7 - K1
*
150 CONTINUE
*
160 CONTINUE
170 CONTINUE
180 CONTINUE
*
* Print a summary of the results.
*
CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( 1X, A6, ', UPLO=''', A1, ''', N =', I5, ', type ', I2,
$ ', test ', I2, ', ratio =', G12.5 )
9998 FORMAT( 1X, A6, ', FACT=''', A1, ''', UPLO=''', A1, ''', N =', I5,
$ ', type ', I2, ', test ', I2, ', ratio =', G12.5 )
RETURN
*
* End of SDRVSP
*
END
SUBROUTINE SDRVSY( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
$ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK,
$ NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NMAX, NN, NOUT, NRHS
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NVAL( * )
REAL A( * ), AFAC( * ), AINV( * ), B( * ),
$ RWORK( * ), WORK( * ), X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* SDRVSY tests the driver routines SSYSV and -SVX.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* NRHS (input) INTEGER
* The number of right hand side vectors to be generated for
* each linear system.
*
* THRESH (input) REAL
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for N, used in dimensioning the
* work arrays.
*
* A (workspace) REAL array, dimension (NMAX*NMAX)
*
* AFAC (workspace) REAL array, dimension (NMAX*NMAX)
*
* AINV (workspace) REAL array, dimension (NMAX*NMAX)
*
* B (workspace) REAL array, dimension (NMAX*NRHS)
*
* X (workspace) REAL array, dimension (NMAX*NRHS)
*
* XACT (workspace) REAL array, dimension (NMAX*NRHS)
*
* WORK (workspace) REAL array, dimension
* (NMAX*max(2,NRHS))
*
* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS)
*
* IWORK (workspace) INTEGER array, dimension (2*NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
INTEGER NTYPES, NTESTS
PARAMETER ( NTYPES = 10, NTESTS = 6 )
INTEGER NFACT
PARAMETER ( NFACT = 2 )
* ..
* .. Local Scalars ..
LOGICAL ZEROT
CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
CHARACTER*3 PATH
INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
$ IZERO, J, K, K1, KL, KU, LDA, LWORK, MODE, N,
$ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
REAL AINVNM, ANORM, CNDNUM, RCOND, RCONDC
* ..
* .. Local Arrays ..
CHARACTER FACTS( NFACT ), UPLOS( 2 )
INTEGER ISEED( 4 ), ISEEDY( 4 )
REAL RESULT( NTESTS )
* ..
* .. External Functions ..
REAL SGET06, SLANSY
EXTERNAL SGET06, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL ALADHD, ALAERH, ALASVM, SERRVX, SGET04, SLACPY,
$ SLARHS, SLASET, SLATB4, SLATMS, SPOT02, SPOT05,
$ SSYSV, SSYSVX, SSYT01, SSYTRF, SSYTRI, XLAENV
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'SY'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
LWORK = MAX( 2*NMAX, NMAX*NRHS )
*
* Test the error exits
*
IF( TSTERR )
$ CALL SERRVX( PATH, NOUT )
INFOT = 0
*
* Set the block size and minimum block size for testing.
*
NB = 1
NBMIN = 2
CALL XLAENV( 1, NB )
CALL XLAENV( 2, NBMIN )
*
* Do for each value of N in NVAL
*
DO 180 IN = 1, NN
N = NVAL( IN )
LDA = MAX( N, 1 )
XTYPE = 'N'
NIMAT = NTYPES
IF( N.LE.0 )
$ NIMAT = 1
*
DO 170 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 170
*
* Skip types 3, 4, 5, or 6 if the matrix size is too small.
*
ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
IF( ZEROT .AND. N.LT.IMAT-2 )
$ GO TO 170
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 160 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
*
* Set up parameters with SLATB4 and generate a test matrix
* with SLATMS.
*
CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
*
SRNAMT = 'SLATMS'
CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
$ INFO )
*
* Check error code from SLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 160
END IF
*
* For types 3-6, zero one or more rows and columns of the
* matrix to test that INFO is returned correctly.
*
IF( ZEROT ) THEN
IF( IMAT.EQ.3 ) THEN
IZERO = 1
ELSE IF( IMAT.EQ.4 ) THEN
IZERO = N
ELSE
IZERO = N / 2 + 1
END IF
*
IF( IMAT.LT.6 ) THEN
*
* Set row and column IZERO to zero.
*
IF( IUPLO.EQ.1 ) THEN
IOFF = ( IZERO-1 )*LDA
DO 20 I = 1, IZERO - 1
A( IOFF+I ) = ZERO
20 CONTINUE
IOFF = IOFF + IZERO
DO 30 I = IZERO, N
A( IOFF ) = ZERO
IOFF = IOFF + LDA
30 CONTINUE
ELSE
IOFF = IZERO
DO 40 I = 1, IZERO - 1
A( IOFF ) = ZERO
IOFF = IOFF + LDA
40 CONTINUE
IOFF = IOFF - IZERO
DO 50 I = IZERO, N
A( IOFF+I ) = ZERO
50 CONTINUE
END IF
ELSE
IOFF = 0
IF( IUPLO.EQ.1 ) THEN
*
* Set the first IZERO rows and columns to zero.
*
DO 70 J = 1, N
I2 = MIN( J, IZERO )
DO 60 I = 1, I2
A( IOFF+I ) = ZERO
60 CONTINUE
IOFF = IOFF + LDA
70 CONTINUE
ELSE
*
* Set the last IZERO rows and columns to zero.
*
DO 90 J = 1, N
I1 = MAX( J, IZERO )
DO 80 I = I1, N
A( IOFF+I ) = ZERO
80 CONTINUE
IOFF = IOFF + LDA
90 CONTINUE
END IF
END IF
ELSE
IZERO = 0
END IF
*
DO 150 IFACT = 1, NFACT
*
* Do first for FACT = 'F', then for other values.
*
FACT = FACTS( IFACT )
*
* Compute the condition number for comparison with
* the value returned by SSYSVX.
*
IF( ZEROT ) THEN
IF( IFACT.EQ.1 )
$ GO TO 150
RCONDC = ZERO
*
ELSE IF( IFACT.EQ.1 ) THEN
*
* Compute the 1-norm of A.
*
ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK )
*
* Factor the matrix A.
*
CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
CALL SSYTRF( UPLO, N, AFAC, LDA, IWORK, WORK,
$ LWORK, INFO )
*
* Compute inv(A) and take its norm.
*
CALL SLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
CALL SSYTRI( UPLO, N, AINV, LDA, IWORK, WORK,
$ INFO )
AINVNM = SLANSY( '1', UPLO, N, AINV, LDA, RWORK )
*
* Compute the 1-norm condition number of A.
*
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDC = ONE
ELSE
RCONDC = ( ONE / ANORM ) / AINVNM
END IF
END IF
*
* Form an exact solution and set the right hand side.
*
SRNAMT = 'SLARHS'
CALL SLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
$ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED,
$ INFO )
XTYPE = 'C'
*
* --- Test SSYSV ---
*
IF( IFACT.EQ.2 ) THEN
CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
* Factor the matrix and solve the system using SSYSV.
*
SRNAMT = 'SSYSV '
CALL SSYSV( UPLO, N, NRHS, AFAC, LDA, IWORK, X,
$ LDA, WORK, LWORK, INFO )
*
* Adjust the expected value of INFO to account for
* pivoting.
*
K = IZERO
IF( K.GT.0 ) THEN
100 CONTINUE
IF( IWORK( K ).LT.0 ) THEN
IF( IWORK( K ).NE.-K ) THEN
K = -IWORK( K )
GO TO 100
END IF
ELSE IF( IWORK( K ).NE.K ) THEN
K = IWORK( K )
GO TO 100
END IF
END IF
*
* Check error code from SSYSV .
*
IF( INFO.NE.K ) THEN
CALL ALAERH( PATH, 'SSYSV ', INFO, K, UPLO, N,
$ N, -1, -1, NRHS, IMAT, NFAIL,
$ NERRS, NOUT )
GO TO 120
ELSE IF( INFO.NE.0 ) THEN
GO TO 120
END IF
*
* Reconstruct matrix from factors and compute
* residual.
*
CALL SSYT01( UPLO, N, A, LDA, AFAC, LDA, IWORK,
$ AINV, LDA, RWORK, RESULT( 1 ) )
*
* Compute residual of the computed solution.
*
CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
CALL SPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
$ LDA, RWORK, RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
NT = 3
*
* Print information about the tests that did not pass
* the threshold.
*
DO 110 K = 1, NT
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )'SSYSV ', UPLO, N,
$ IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
110 CONTINUE
NRUN = NRUN + NT
120 CONTINUE
END IF
*
* --- Test SSYSVX ---
*
IF( IFACT.EQ.2 )
$ CALL SLASET( UPLO, N, N, ZERO, ZERO, AFAC, LDA )
CALL SLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA )
*
* Solve the system and compute the condition number and
* error bounds using SSYSVX.
*
SRNAMT = 'SSYSVX'
CALL SSYSVX( FACT, UPLO, N, NRHS, A, LDA, AFAC, LDA,
$ IWORK, B, LDA, X, LDA, RCOND, RWORK,
$ RWORK( NRHS+1 ), WORK, LWORK,
$ IWORK( N+1 ), INFO )
*
* Adjust the expected value of INFO to account for
* pivoting.
*
K = IZERO
IF( K.GT.0 ) THEN
130 CONTINUE
IF( IWORK( K ).LT.0 ) THEN
IF( IWORK( K ).NE.-K ) THEN
K = -IWORK( K )
GO TO 130
END IF
ELSE IF( IWORK( K ).NE.K ) THEN
K = IWORK( K )
GO TO 130
END IF
END IF
*
* Check the error code from SSYSVX.
*
IF( INFO.NE.K ) THEN
CALL ALAERH( PATH, 'SSYSVX', INFO, K, FACT // UPLO,
$ N, N, -1, -1, NRHS, IMAT, NFAIL,
$ NERRS, NOUT )
GO TO 150
END IF
*
IF( INFO.EQ.0 ) THEN
IF( IFACT.GE.2 ) THEN
*
* Reconstruct matrix from factors and compute
* residual.
*
CALL SSYT01( UPLO, N, A, LDA, AFAC, LDA, IWORK,
$ AINV, LDA, RWORK( 2*NRHS+1 ),
$ RESULT( 1 ) )
K1 = 1
ELSE
K1 = 2
END IF
*
* Compute residual of the computed solution.
*
CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
CALL SPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
$ LDA, RWORK( 2*NRHS+1 ), RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
*
* Check the error bounds from iterative refinement.
*
CALL SPOT05( UPLO, N, NRHS, A, LDA, B, LDA, X, LDA,
$ XACT, LDA, RWORK, RWORK( NRHS+1 ),
$ RESULT( 4 ) )
ELSE
K1 = 6
END IF
*
* Compare RCOND from SSYSVX with the computed value
* in RCONDC.
*
RESULT( 6 ) = SGET06( RCOND, RCONDC )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 140 K = K1, 6
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )'SSYSVX', FACT, UPLO,
$ N, IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
140 CONTINUE
NRUN = NRUN + 7 - K1
*
150 CONTINUE
*
160 CONTINUE
170 CONTINUE
180 CONTINUE
*
* Print a summary of the results.
*
CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( 1X, A6, ', UPLO=''', A1, ''', N =', I5, ', type ', I2,
$ ', test ', I2, ', ratio =', G12.5 )
9998 FORMAT( 1X, A6, ', FACT=''', A1, ''', UPLO=''', A1, ''', N =', I5,
$ ', type ', I2, ', test ', I2, ', ratio =', G12.5 )
RETURN
*
* End of SDRVSY
*
END
SUBROUTINE SERRGE( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* SERRGE tests the error exits for the REAL routines
* for general matrices.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX, LW
PARAMETER ( NMAX = 4, LW = 3*NMAX )
* ..
* .. Local Scalars ..
CHARACTER*2 C2
INTEGER I, INFO, J
REAL ANRM, CCOND, RCOND
* ..
* .. Local Arrays ..
INTEGER IP( NMAX ), IW( NMAX )
REAL A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
$ R1( NMAX ), R2( NMAX ), W( LW ), X( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, SGBCON, SGBEQU, SGBRFS, SGBTF2,
$ SGBTRF, SGBTRS, SGECON, SGEEQU, SGERFS, SGETF2,
$ SGETRF, SGETRI, SGETRS
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
C2 = PATH( 2: 3 )
*
* Set the variables to innocuous values.
*
DO 20 J = 1, NMAX
DO 10 I = 1, NMAX
A( I, J ) = 1. / REAL( I+J )
AF( I, J ) = 1. / REAL( I+J )
10 CONTINUE
B( J ) = 0.
R1( J ) = 0.
R2( J ) = 0.
W( J ) = 0.
X( J ) = 0.
IP( J ) = J
IW( J ) = J
20 CONTINUE
OK = .TRUE.
*
IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
* Test error exits of the routines that use the LU decomposition
* of a general matrix.
*
* SGETRF
*
SRNAMT = 'SGETRF'
INFOT = 1
CALL SGETRF( -1, 0, A, 1, IP, INFO )
CALL CHKXER( 'SGETRF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGETRF( 0, -1, A, 1, IP, INFO )
CALL CHKXER( 'SGETRF', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGETRF( 2, 1, A, 1, IP, INFO )
CALL CHKXER( 'SGETRF', INFOT, NOUT, LERR, OK )
*
* SGETF2
*
SRNAMT = 'SGETF2'
INFOT = 1
CALL SGETF2( -1, 0, A, 1, IP, INFO )
CALL CHKXER( 'SGETF2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGETF2( 0, -1, A, 1, IP, INFO )
CALL CHKXER( 'SGETF2', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGETF2( 2, 1, A, 1, IP, INFO )
CALL CHKXER( 'SGETF2', INFOT, NOUT, LERR, OK )
*
* SGETRI
*
SRNAMT = 'SGETRI'
INFOT = 1
CALL SGETRI( -1, A, 1, IP, W, LW, INFO )
CALL CHKXER( 'SGETRI', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGETRI( 2, A, 1, IP, W, LW, INFO )
CALL CHKXER( 'SGETRI', INFOT, NOUT, LERR, OK )
*
* SGETRS
*
SRNAMT = 'SGETRS'
INFOT = 1
CALL SGETRS( '/', 0, 0, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'SGETRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGETRS( 'N', -1, 0, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'SGETRS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGETRS( 'N', 0, -1, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'SGETRS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGETRS( 'N', 2, 1, A, 1, IP, B, 2, INFO )
CALL CHKXER( 'SGETRS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SGETRS( 'N', 2, 1, A, 2, IP, B, 1, INFO )
CALL CHKXER( 'SGETRS', INFOT, NOUT, LERR, OK )
*
* SGERFS
*
SRNAMT = 'SGERFS'
INFOT = 1
CALL SGERFS( '/', 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'SGERFS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGERFS( 'N', -1, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2,
$ W, IW, INFO )
CALL CHKXER( 'SGERFS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGERFS( 'N', 0, -1, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2,
$ W, IW, INFO )
CALL CHKXER( 'SGERFS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGERFS( 'N', 2, 1, A, 1, AF, 2, IP, B, 2, X, 2, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'SGERFS', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SGERFS( 'N', 2, 1, A, 2, AF, 1, IP, B, 2, X, 2, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'SGERFS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SGERFS( 'N', 2, 1, A, 2, AF, 2, IP, B, 1, X, 2, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'SGERFS', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SGERFS( 'N', 2, 1, A, 2, AF, 2, IP, B, 2, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'SGERFS', INFOT, NOUT, LERR, OK )
*
* SGECON
*
SRNAMT = 'SGECON'
INFOT = 1
CALL SGECON( '/', 0, A, 1, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'SGECON', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGECON( '1', -1, A, 1, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'SGECON', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGECON( '1', 2, A, 1, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'SGECON', INFOT, NOUT, LERR, OK )
*
* SGEEQU
*
SRNAMT = 'SGEEQU'
INFOT = 1
CALL SGEEQU( -1, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO )
CALL CHKXER( 'SGEEQU', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGEEQU( 0, -1, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO )
CALL CHKXER( 'SGEEQU', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGEEQU( 2, 2, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO )
CALL CHKXER( 'SGEEQU', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
*
* Test error exits of the routines that use the LU decomposition
* of a general band matrix.
*
* SGBTRF
*
SRNAMT = 'SGBTRF'
INFOT = 1
CALL SGBTRF( -1, 0, 0, 0, A, 1, IP, INFO )
CALL CHKXER( 'SGBTRF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGBTRF( 0, -1, 0, 0, A, 1, IP, INFO )
CALL CHKXER( 'SGBTRF', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGBTRF( 1, 1, -1, 0, A, 1, IP, INFO )
CALL CHKXER( 'SGBTRF', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGBTRF( 1, 1, 0, -1, A, 1, IP, INFO )
CALL CHKXER( 'SGBTRF', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SGBTRF( 2, 2, 1, 1, A, 3, IP, INFO )
CALL CHKXER( 'SGBTRF', INFOT, NOUT, LERR, OK )
*
* SGBTF2
*
SRNAMT = 'SGBTF2'
INFOT = 1
CALL SGBTF2( -1, 0, 0, 0, A, 1, IP, INFO )
CALL CHKXER( 'SGBTF2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGBTF2( 0, -1, 0, 0, A, 1, IP, INFO )
CALL CHKXER( 'SGBTF2', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGBTF2( 1, 1, -1, 0, A, 1, IP, INFO )
CALL CHKXER( 'SGBTF2', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGBTF2( 1, 1, 0, -1, A, 1, IP, INFO )
CALL CHKXER( 'SGBTF2', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SGBTF2( 2, 2, 1, 1, A, 3, IP, INFO )
CALL CHKXER( 'SGBTF2', INFOT, NOUT, LERR, OK )
*
* SGBTRS
*
SRNAMT = 'SGBTRS'
INFOT = 1
CALL SGBTRS( '/', 0, 0, 0, 1, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'SGBTRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGBTRS( 'N', -1, 0, 0, 1, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'SGBTRS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGBTRS( 'N', 1, -1, 0, 1, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'SGBTRS', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGBTRS( 'N', 1, 0, -1, 1, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'SGBTRS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGBTRS( 'N', 1, 0, 0, -1, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'SGBTRS', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SGBTRS( 'N', 2, 1, 1, 1, A, 3, IP, B, 2, INFO )
CALL CHKXER( 'SGBTRS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SGBTRS( 'N', 2, 0, 0, 1, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'SGBTRS', INFOT, NOUT, LERR, OK )
*
* SGBRFS
*
SRNAMT = 'SGBRFS'
INFOT = 1
CALL SGBRFS( '/', 0, 0, 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1,
$ R2, W, IW, INFO )
CALL CHKXER( 'SGBRFS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGBRFS( 'N', -1, 0, 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1,
$ R2, W, IW, INFO )
CALL CHKXER( 'SGBRFS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGBRFS( 'N', 1, -1, 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1,
$ R2, W, IW, INFO )
CALL CHKXER( 'SGBRFS', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGBRFS( 'N', 1, 0, -1, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1,
$ R2, W, IW, INFO )
CALL CHKXER( 'SGBRFS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGBRFS( 'N', 1, 0, 0, -1, A, 1, AF, 1, IP, B, 1, X, 1, R1,
$ R2, W, IW, INFO )
CALL CHKXER( 'SGBRFS', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SGBRFS( 'N', 2, 1, 1, 1, A, 2, AF, 4, IP, B, 2, X, 2, R1,
$ R2, W, IW, INFO )
CALL CHKXER( 'SGBRFS', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SGBRFS( 'N', 2, 1, 1, 1, A, 3, AF, 3, IP, B, 2, X, 2, R1,
$ R2, W, IW, INFO )
CALL CHKXER( 'SGBRFS', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SGBRFS( 'N', 2, 0, 0, 1, A, 1, AF, 1, IP, B, 1, X, 2, R1,
$ R2, W, IW, INFO )
CALL CHKXER( 'SGBRFS', INFOT, NOUT, LERR, OK )
INFOT = 14
CALL SGBRFS( 'N', 2, 0, 0, 1, A, 1, AF, 1, IP, B, 2, X, 1, R1,
$ R2, W, IW, INFO )
CALL CHKXER( 'SGBRFS', INFOT, NOUT, LERR, OK )
*
* SGBCON
*
SRNAMT = 'SGBCON'
INFOT = 1
CALL SGBCON( '/', 0, 0, 0, A, 1, IP, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'SGBCON', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGBCON( '1', -1, 0, 0, A, 1, IP, ANRM, RCOND, W, IW,
$ INFO )
CALL CHKXER( 'SGBCON', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGBCON( '1', 1, -1, 0, A, 1, IP, ANRM, RCOND, W, IW,
$ INFO )
CALL CHKXER( 'SGBCON', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGBCON( '1', 1, 0, -1, A, 1, IP, ANRM, RCOND, W, IW,
$ INFO )
CALL CHKXER( 'SGBCON', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SGBCON( '1', 2, 1, 1, A, 3, IP, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'SGBCON', INFOT, NOUT, LERR, OK )
*
* SGBEQU
*
SRNAMT = 'SGBEQU'
INFOT = 1
CALL SGBEQU( -1, 0, 0, 0, A, 1, R1, R2, RCOND, CCOND, ANRM,
$ INFO )
CALL CHKXER( 'SGBEQU', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGBEQU( 0, -1, 0, 0, A, 1, R1, R2, RCOND, CCOND, ANRM,
$ INFO )
CALL CHKXER( 'SGBEQU', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGBEQU( 1, 1, -1, 0, A, 1, R1, R2, RCOND, CCOND, ANRM,
$ INFO )
CALL CHKXER( 'SGBEQU', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGBEQU( 1, 1, 0, -1, A, 1, R1, R2, RCOND, CCOND, ANRM,
$ INFO )
CALL CHKXER( 'SGBEQU', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SGBEQU( 2, 2, 1, 1, A, 2, R1, R2, RCOND, CCOND, ANRM,
$ INFO )
CALL CHKXER( 'SGBEQU', INFOT, NOUT, LERR, OK )
END IF
*
* Print a summary line.
*
CALL ALAESM( PATH, OK, NOUT )
*
RETURN
*
* End of SERRGE
*
END
SUBROUTINE SERRGT( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* SERRGT tests the error exits for the REAL tridiagonal
* routines.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 2 )
* ..
* .. Local Scalars ..
CHARACTER*2 C2
INTEGER INFO
REAL ANORM, RCOND
* ..
* .. Local Arrays ..
INTEGER IP( NMAX ), IW( NMAX )
REAL B( NMAX ), C( NMAX ), CF( NMAX ), D( NMAX ),
$ DF( NMAX ), E( NMAX ), EF( NMAX ), F( NMAX ),
$ R1( NMAX ), R2( NMAX ), W( NMAX ), X( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, SGTCON, SGTRFS, SGTTRF, SGTTRS,
$ SPTCON, SPTRFS, SPTTRF, SPTTRS
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
C2 = PATH( 2: 3 )
D( 1 ) = 1.
D( 2 ) = 2.
DF( 1 ) = 1.
DF( 2 ) = 2.
E( 1 ) = 3.
E( 2 ) = 4.
EF( 1 ) = 3.
EF( 2 ) = 4.
ANORM = 1.0
OK = .TRUE.
*
IF( LSAMEN( 2, C2, 'GT' ) ) THEN
*
* Test error exits for the general tridiagonal routines.
*
* SGTTRF
*
SRNAMT = 'SGTTRF'
INFOT = 1
CALL SGTTRF( -1, C, D, E, F, IP, INFO )
CALL CHKXER( 'SGTTRF', INFOT, NOUT, LERR, OK )
*
* SGTTRS
*
SRNAMT = 'SGTTRS'
INFOT = 1
CALL SGTTRS( '/', 0, 0, C, D, E, F, IP, X, 1, INFO )
CALL CHKXER( 'SGTTRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGTTRS( 'N', -1, 0, C, D, E, F, IP, X, 1, INFO )
CALL CHKXER( 'SGTTRS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGTTRS( 'N', 0, -1, C, D, E, F, IP, X, 1, INFO )
CALL CHKXER( 'SGTTRS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SGTTRS( 'N', 2, 1, C, D, E, F, IP, X, 1, INFO )
CALL CHKXER( 'SGTTRS', INFOT, NOUT, LERR, OK )
*
* SGTRFS
*
SRNAMT = 'SGTRFS'
INFOT = 1
CALL SGTRFS( '/', 0, 0, C, D, E, CF, DF, EF, F, IP, B, 1, X, 1,
$ R1, R2, W, IW, INFO )
CALL CHKXER( 'SGTRFS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGTRFS( 'N', -1, 0, C, D, E, CF, DF, EF, F, IP, B, 1, X,
$ 1, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGTRFS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGTRFS( 'N', 0, -1, C, D, E, CF, DF, EF, F, IP, B, 1, X,
$ 1, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGTRFS', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL SGTRFS( 'N', 2, 1, C, D, E, CF, DF, EF, F, IP, B, 1, X, 2,
$ R1, R2, W, IW, INFO )
CALL CHKXER( 'SGTRFS', INFOT, NOUT, LERR, OK )
INFOT = 15
CALL SGTRFS( 'N', 2, 1, C, D, E, CF, DF, EF, F, IP, B, 2, X, 1,
$ R1, R2, W, IW, INFO )
CALL CHKXER( 'SGTRFS', INFOT, NOUT, LERR, OK )
*
* SGTCON
*
SRNAMT = 'SGTCON'
INFOT = 1
CALL SGTCON( '/', 0, C, D, E, F, IP, ANORM, RCOND, W, IW,
$ INFO )
CALL CHKXER( 'SGTCON', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGTCON( 'I', -1, C, D, E, F, IP, ANORM, RCOND, W, IW,
$ INFO )
CALL CHKXER( 'SGTCON', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SGTCON( 'I', 0, C, D, E, F, IP, -ANORM, RCOND, W, IW,
$ INFO )
CALL CHKXER( 'SGTCON', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'PT' ) ) THEN
*
* Test error exits for the positive definite tridiagonal
* routines.
*
* SPTTRF
*
SRNAMT = 'SPTTRF'
INFOT = 1
CALL SPTTRF( -1, D, E, INFO )
CALL CHKXER( 'SPTTRF', INFOT, NOUT, LERR, OK )
*
* SPTTRS
*
SRNAMT = 'SPTTRS'
INFOT = 1
CALL SPTTRS( -1, 0, D, E, X, 1, INFO )
CALL CHKXER( 'SPTTRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SPTTRS( 0, -1, D, E, X, 1, INFO )
CALL CHKXER( 'SPTTRS', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SPTTRS( 2, 1, D, E, X, 1, INFO )
CALL CHKXER( 'SPTTRS', INFOT, NOUT, LERR, OK )
*
* SPTRFS
*
SRNAMT = 'SPTRFS'
INFOT = 1
CALL SPTRFS( -1, 0, D, E, DF, EF, B, 1, X, 1, R1, R2, W, INFO )
CALL CHKXER( 'SPTRFS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SPTRFS( 0, -1, D, E, DF, EF, B, 1, X, 1, R1, R2, W, INFO )
CALL CHKXER( 'SPTRFS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SPTRFS( 2, 1, D, E, DF, EF, B, 1, X, 2, R1, R2, W, INFO )
CALL CHKXER( 'SPTRFS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SPTRFS( 2, 1, D, E, DF, EF, B, 2, X, 1, R1, R2, W, INFO )
CALL CHKXER( 'SPTRFS', INFOT, NOUT, LERR, OK )
*
* SPTCON
*
SRNAMT = 'SPTCON'
INFOT = 1
CALL SPTCON( -1, D, E, ANORM, RCOND, W, INFO )
CALL CHKXER( 'SPTCON', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SPTCON( 0, D, E, -ANORM, RCOND, W, INFO )
CALL CHKXER( 'SPTCON', INFOT, NOUT, LERR, OK )
END IF
*
* Print a summary line.
*
CALL ALAESM( PATH, OK, NOUT )
*
RETURN
*
* End of SERRGT
*
END
SUBROUTINE SERRLQ( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* SERRLQ tests the error exits for the REAL routines
* that use the LQ decomposition of a general matrix.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 2 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
* ..
* .. Local Arrays ..
REAL A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
$ W( NMAX ), X( NMAX )
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, SGELQ2, SGELQF, SGELQS, SORGL2,
$ SORGLQ, SORML2, SORMLQ
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
*
* Set the variables to innocuous values.
*
DO 20 J = 1, NMAX
DO 10 I = 1, NMAX
A( I, J ) = 1. / REAL( I+J )
AF( I, J ) = 1. / REAL( I+J )
10 CONTINUE
B( J ) = 0.
W( J ) = 0.
X( J ) = 0.
20 CONTINUE
OK = .TRUE.
*
* Error exits for LQ factorization
*
* SGELQF
*
SRNAMT = 'SGELQF'
INFOT = 1
CALL SGELQF( -1, 0, A, 1, B, W, 1, INFO )
CALL CHKXER( 'SGELQF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGELQF( 0, -1, A, 1, B, W, 1, INFO )
CALL CHKXER( 'SGELQF', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGELQF( 2, 1, A, 1, B, W, 2, INFO )
CALL CHKXER( 'SGELQF', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SGELQF( 2, 1, A, 2, B, W, 1, INFO )
CALL CHKXER( 'SGELQF', INFOT, NOUT, LERR, OK )
*
* SGELQ2
*
SRNAMT = 'SGELQ2'
INFOT = 1
CALL SGELQ2( -1, 0, A, 1, B, W, INFO )
CALL CHKXER( 'SGELQ2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGELQ2( 0, -1, A, 1, B, W, INFO )
CALL CHKXER( 'SGELQ2', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGELQ2( 2, 1, A, 1, B, W, INFO )
CALL CHKXER( 'SGELQ2', INFOT, NOUT, LERR, OK )
*
* SGELQS
*
SRNAMT = 'SGELQS'
INFOT = 1
CALL SGELQS( -1, 0, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGELQS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGELQS( 0, -1, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGELQS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGELQS( 2, 1, 0, A, 2, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGELQS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGELQS( 0, 0, -1, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGELQS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGELQS( 2, 2, 0, A, 1, X, B, 2, W, 1, INFO )
CALL CHKXER( 'SGELQS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SGELQS( 1, 2, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGELQS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SGELQS( 1, 1, 2, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGELQS', INFOT, NOUT, LERR, OK )
*
* SORGLQ
*
SRNAMT = 'SORGLQ'
INFOT = 1
CALL SORGLQ( -1, 0, 0, A, 1, X, W, 1, INFO )
CALL CHKXER( 'SORGLQ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORGLQ( 0, -1, 0, A, 1, X, W, 1, INFO )
CALL CHKXER( 'SORGLQ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORGLQ( 2, 1, 0, A, 2, X, W, 2, INFO )
CALL CHKXER( 'SORGLQ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORGLQ( 0, 0, -1, A, 1, X, W, 1, INFO )
CALL CHKXER( 'SORGLQ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORGLQ( 1, 1, 2, A, 1, X, W, 1, INFO )
CALL CHKXER( 'SORGLQ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORGLQ( 2, 2, 0, A, 1, X, W, 2, INFO )
CALL CHKXER( 'SORGLQ', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SORGLQ( 2, 2, 0, A, 2, X, W, 1, INFO )
CALL CHKXER( 'SORGLQ', INFOT, NOUT, LERR, OK )
*
* SORGL2
*
SRNAMT = 'SORGL2'
INFOT = 1
CALL SORGL2( -1, 0, 0, A, 1, X, W, INFO )
CALL CHKXER( 'SORGL2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORGL2( 0, -1, 0, A, 1, X, W, INFO )
CALL CHKXER( 'SORGL2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORGL2( 2, 1, 0, A, 2, X, W, INFO )
CALL CHKXER( 'SORGL2', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORGL2( 0, 0, -1, A, 1, X, W, INFO )
CALL CHKXER( 'SORGL2', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORGL2( 1, 1, 2, A, 1, X, W, INFO )
CALL CHKXER( 'SORGL2', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORGL2( 2, 2, 0, A, 1, X, W, INFO )
CALL CHKXER( 'SORGL2', INFOT, NOUT, LERR, OK )
*
* SORMLQ
*
SRNAMT = 'SORMLQ'
INFOT = 1
CALL SORMLQ( '/', 'N', 0, 0, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMLQ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORMLQ( 'L', '/', 0, 0, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMLQ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORMLQ( 'L', 'N', -1, 0, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMLQ', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SORMLQ( 'L', 'N', 0, -1, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMLQ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORMLQ( 'L', 'N', 0, 0, -1, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMLQ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORMLQ( 'L', 'N', 0, 1, 1, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMLQ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORMLQ( 'R', 'N', 1, 0, 1, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMLQ', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SORMLQ( 'L', 'N', 2, 0, 2, A, 1, X, AF, 2, W, 1, INFO )
CALL CHKXER( 'SORMLQ', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SORMLQ( 'R', 'N', 0, 2, 2, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMLQ', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SORMLQ( 'L', 'N', 2, 1, 0, A, 2, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMLQ', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SORMLQ( 'L', 'N', 1, 2, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMLQ', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SORMLQ( 'R', 'N', 2, 1, 0, A, 1, X, AF, 2, W, 1, INFO )
CALL CHKXER( 'SORMLQ', INFOT, NOUT, LERR, OK )
*
* SORML2
*
SRNAMT = 'SORML2'
INFOT = 1
CALL SORML2( '/', 'N', 0, 0, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORML2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORML2( 'L', '/', 0, 0, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORML2', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORML2( 'L', 'N', -1, 0, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORML2', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SORML2( 'L', 'N', 0, -1, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORML2', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORML2( 'L', 'N', 0, 0, -1, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORML2', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORML2( 'L', 'N', 0, 1, 1, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORML2', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORML2( 'R', 'N', 1, 0, 1, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORML2', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SORML2( 'L', 'N', 2, 1, 2, A, 1, X, AF, 2, W, INFO )
CALL CHKXER( 'SORML2', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SORML2( 'R', 'N', 1, 2, 2, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORML2', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SORML2( 'L', 'N', 2, 1, 0, A, 2, X, AF, 1, W, INFO )
CALL CHKXER( 'SORML2', INFOT, NOUT, LERR, OK )
*
* Print a summary line.
*
CALL ALAESM( PATH, OK, NOUT )
*
RETURN
*
* End of SERRLQ
*
END
SUBROUTINE SERRLS( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* SERRLS tests the error exits for the REAL least squares
* driver routines (SGELS, SGELSS, SGELSX, SGELSY, SGELSD).
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 2 )
* ..
* .. Local Scalars ..
CHARACTER*2 C2
INTEGER INFO, IRNK
REAL RCOND
* ..
* .. Local Arrays ..
INTEGER IP( NMAX )
REAL A( NMAX, NMAX ), B( NMAX, NMAX ), S( NMAX ),
$ W( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, SGELS, SGELSD, SGELSS, SGELSX,
$ SGELSY
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
C2 = PATH( 2: 3 )
A( 1, 1 ) = 1.0E+0
A( 1, 2 ) = 2.0E+0
A( 2, 2 ) = 3.0E+0
A( 2, 1 ) = 4.0E+0
OK = .TRUE.
*
IF( LSAMEN( 2, C2, 'LS' ) ) THEN
*
* Test error exits for the least squares driver routines.
*
* SGELS
*
SRNAMT = 'SGELS '
INFOT = 1
CALL SGELS( '/', 0, 0, 0, A, 1, B, 1, W, 1, INFO )
CALL CHKXER( 'SGELS ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGELS( 'N', -1, 0, 0, A, 1, B, 1, W, 1, INFO )
CALL CHKXER( 'SGELS ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGELS( 'N', 0, -1, 0, A, 1, B, 1, W, 1, INFO )
CALL CHKXER( 'SGELS ', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGELS( 'N', 0, 0, -1, A, 1, B, 1, W, 1, INFO )
CALL CHKXER( 'SGELS ', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SGELS( 'N', 2, 0, 0, A, 1, B, 2, W, 2, INFO )
CALL CHKXER( 'SGELS ', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SGELS( 'N', 2, 0, 0, A, 2, B, 1, W, 2, INFO )
CALL CHKXER( 'SGELS ', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SGELS( 'N', 1, 1, 0, A, 1, B, 1, W, 1, INFO )
CALL CHKXER( 'SGELS ', INFOT, NOUT, LERR, OK )
*
* SGELSS
*
SRNAMT = 'SGELSS'
INFOT = 1
CALL SGELSS( -1, 0, 0, A, 1, B, 1, S, RCOND, IRNK, W, 1, INFO )
CALL CHKXER( 'SGELSS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGELSS( 0, -1, 0, A, 1, B, 1, S, RCOND, IRNK, W, 1, INFO )
CALL CHKXER( 'SGELSS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGELSS( 0, 0, -1, A, 1, B, 1, S, RCOND, IRNK, W, 1, INFO )
CALL CHKXER( 'SGELSS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGELSS( 2, 0, 0, A, 1, B, 2, S, RCOND, IRNK, W, 2, INFO )
CALL CHKXER( 'SGELSS', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SGELSS( 2, 0, 0, A, 2, B, 1, S, RCOND, IRNK, W, 2, INFO )
CALL CHKXER( 'SGELSS', INFOT, NOUT, LERR, OK )
*
* SGELSX
*
SRNAMT = 'SGELSX'
INFOT = 1
CALL SGELSX( -1, 0, 0, A, 1, B, 1, IP, RCOND, IRNK, W, INFO )
CALL CHKXER( 'SGELSX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGELSX( 0, -1, 0, A, 1, B, 1, IP, RCOND, IRNK, W, INFO )
CALL CHKXER( 'SGELSX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGELSX( 0, 0, -1, A, 1, B, 1, IP, RCOND, IRNK, W, INFO )
CALL CHKXER( 'SGELSX', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGELSX( 2, 0, 0, A, 1, B, 2, IP, RCOND, IRNK, W, INFO )
CALL CHKXER( 'SGELSX', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SGELSX( 2, 0, 0, A, 2, B, 1, IP, RCOND, IRNK, W, INFO )
CALL CHKXER( 'SGELSX', INFOT, NOUT, LERR, OK )
*
* SGELSY
*
SRNAMT = 'SGELSY'
INFOT = 1
CALL SGELSY( -1, 0, 0, A, 1, B, 1, IP, RCOND, IRNK, W, 10,
$ INFO )
CALL CHKXER( 'SGELSY', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGELSY( 0, -1, 0, A, 1, B, 1, IP, RCOND, IRNK, W, 10,
$ INFO )
CALL CHKXER( 'SGELSY', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGELSY( 0, 0, -1, A, 1, B, 1, IP, RCOND, IRNK, W, 10,
$ INFO )
CALL CHKXER( 'SGELSY', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGELSY( 2, 0, 0, A, 1, B, 2, IP, RCOND, IRNK, W, 10,
$ INFO )
CALL CHKXER( 'SGELSY', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SGELSY( 2, 0, 0, A, 2, B, 1, IP, RCOND, IRNK, W, 10,
$ INFO )
CALL CHKXER( 'SGELSY', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SGELSY( 2, 2, 1, A, 2, B, 2, IP, RCOND, IRNK, W, 1, INFO )
CALL CHKXER( 'SGELSY', INFOT, NOUT, LERR, OK )
*
* SGELSD
*
SRNAMT = 'SGELSD'
INFOT = 1
CALL SGELSD( -1, 0, 0, A, 1, B, 1, S, RCOND, IRNK, W, 10,
$ IP, INFO )
CALL CHKXER( 'SGELSD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGELSD( 0, -1, 0, A, 1, B, 1, S, RCOND, IRNK, W, 10,
$ IP, INFO )
CALL CHKXER( 'SGELSD', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGELSD( 0, 0, -1, A, 1, B, 1, S, RCOND, IRNK, W, 10,
$ IP, INFO )
CALL CHKXER( 'SGELSD', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGELSD( 2, 0, 0, A, 1, B, 2, S, RCOND, IRNK, W, 10,
$ IP, INFO )
CALL CHKXER( 'SGELSD', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SGELSD( 2, 0, 0, A, 2, B, 1, S, RCOND, IRNK, W, 10,
$ IP, INFO )
CALL CHKXER( 'SGELSD', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SGELSD( 2, 2, 1, A, 2, B, 2, S, RCOND, IRNK, W, 1, IP,
$ INFO )
CALL CHKXER( 'SGELSD', INFOT, NOUT, LERR, OK )
END IF
*
* Print a summary line.
*
CALL ALAESM( PATH, OK, NOUT )
*
RETURN
*
* End of SERRLS
*
END
SUBROUTINE SERRPO( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* SERRPO tests the error exits for the REAL routines
* for symmetric positive definite matrices.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 4 )
* ..
* .. Local Scalars ..
CHARACTER*2 C2
INTEGER I, INFO, J
REAL ANRM, RCOND
* ..
* .. Local Arrays ..
INTEGER IW( NMAX )
REAL A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
$ R1( NMAX ), R2( NMAX ), W( 3*NMAX ), X( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, SPBCON, SPBEQU, SPBRFS, SPBTF2,
$ SPBTRF, SPBTRS, SPOCON, SPOEQU, SPORFS, SPOTF2,
$ SPOTRF, SPOTRI, SPOTRS, SPPCON, SPPEQU, SPPRFS,
$ SPPTRF, SPPTRI, SPPTRS
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
C2 = PATH( 2: 3 )
*
* Set the variables to innocuous values.
*
DO 20 J = 1, NMAX
DO 10 I = 1, NMAX
A( I, J ) = 1. / REAL( I+J )
AF( I, J ) = 1. / REAL( I+J )
10 CONTINUE
B( J ) = 0.
R1( J ) = 0.
R2( J ) = 0.
W( J ) = 0.
X( J ) = 0.
IW( J ) = J
20 CONTINUE
OK = .TRUE.
*
IF( LSAMEN( 2, C2, 'PO' ) ) THEN
*
* Test error exits of the routines that use the Cholesky
* decomposition of a symmetric positive definite matrix.
*
* SPOTRF
*
SRNAMT = 'SPOTRF'
INFOT = 1
CALL SPOTRF( '/', 0, A, 1, INFO )
CALL CHKXER( 'SPOTRF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SPOTRF( 'U', -1, A, 1, INFO )
CALL CHKXER( 'SPOTRF', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SPOTRF( 'U', 2, A, 1, INFO )
CALL CHKXER( 'SPOTRF', INFOT, NOUT, LERR, OK )
*
* SPOTF2
*
SRNAMT = 'SPOTF2'
INFOT = 1
CALL SPOTF2( '/', 0, A, 1, INFO )
CALL CHKXER( 'SPOTF2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SPOTF2( 'U', -1, A, 1, INFO )
CALL CHKXER( 'SPOTF2', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SPOTF2( 'U', 2, A, 1, INFO )
CALL CHKXER( 'SPOTF2', INFOT, NOUT, LERR, OK )
*
* SPOTRI
*
SRNAMT = 'SPOTRI'
INFOT = 1
CALL SPOTRI( '/', 0, A, 1, INFO )
CALL CHKXER( 'SPOTRI', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SPOTRI( 'U', -1, A, 1, INFO )
CALL CHKXER( 'SPOTRI', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SPOTRI( 'U', 2, A, 1, INFO )
CALL CHKXER( 'SPOTRI', INFOT, NOUT, LERR, OK )
*
* SPOTRS
*
SRNAMT = 'SPOTRS'
INFOT = 1
CALL SPOTRS( '/', 0, 0, A, 1, B, 1, INFO )
CALL CHKXER( 'SPOTRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SPOTRS( 'U', -1, 0, A, 1, B, 1, INFO )
CALL CHKXER( 'SPOTRS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SPOTRS( 'U', 0, -1, A, 1, B, 1, INFO )
CALL CHKXER( 'SPOTRS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SPOTRS( 'U', 2, 1, A, 1, B, 2, INFO )
CALL CHKXER( 'SPOTRS', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SPOTRS( 'U', 2, 1, A, 2, B, 1, INFO )
CALL CHKXER( 'SPOTRS', INFOT, NOUT, LERR, OK )
*
* SPORFS
*
SRNAMT = 'SPORFS'
INFOT = 1
CALL SPORFS( '/', 0, 0, A, 1, AF, 1, B, 1, X, 1, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'SPORFS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SPORFS( 'U', -1, 0, A, 1, AF, 1, B, 1, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'SPORFS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SPORFS( 'U', 0, -1, A, 1, AF, 1, B, 1, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'SPORFS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SPORFS( 'U', 2, 1, A, 1, AF, 2, B, 2, X, 2, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'SPORFS', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SPORFS( 'U', 2, 1, A, 2, AF, 1, B, 2, X, 2, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'SPORFS', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SPORFS( 'U', 2, 1, A, 2, AF, 2, B, 1, X, 2, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'SPORFS', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL SPORFS( 'U', 2, 1, A, 2, AF, 2, B, 2, X, 1, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'SPORFS', INFOT, NOUT, LERR, OK )
*
* SPOCON
*
SRNAMT = 'SPOCON'
INFOT = 1
CALL SPOCON( '/', 0, A, 1, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'SPOCON', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SPOCON( 'U', -1, A, 1, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'SPOCON', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SPOCON( 'U', 2, A, 1, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'SPOCON', INFOT, NOUT, LERR, OK )
*
* SPOEQU
*
SRNAMT = 'SPOEQU'
INFOT = 1
CALL SPOEQU( -1, A, 1, R1, RCOND, ANRM, INFO )
CALL CHKXER( 'SPOEQU', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SPOEQU( 2, A, 1, R1, RCOND, ANRM, INFO )
CALL CHKXER( 'SPOEQU', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'PP' ) ) THEN
*
* Test error exits of the routines that use the Cholesky
* decomposition of a symmetric positive definite packed matrix.
*
* SPPTRF
*
SRNAMT = 'SPPTRF'
INFOT = 1
CALL SPPTRF( '/', 0, A, INFO )
CALL CHKXER( 'SPPTRF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SPPTRF( 'U', -1, A, INFO )
CALL CHKXER( 'SPPTRF', INFOT, NOUT, LERR, OK )
*
* SPPTRI
*
SRNAMT = 'SPPTRI'
INFOT = 1
CALL SPPTRI( '/', 0, A, INFO )
CALL CHKXER( 'SPPTRI', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SPPTRI( 'U', -1, A, INFO )
CALL CHKXER( 'SPPTRI', INFOT, NOUT, LERR, OK )
*
* SPPTRS
*
SRNAMT = 'SPPTRS'
INFOT = 1
CALL SPPTRS( '/', 0, 0, A, B, 1, INFO )
CALL CHKXER( 'SPPTRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SPPTRS( 'U', -1, 0, A, B, 1, INFO )
CALL CHKXER( 'SPPTRS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SPPTRS( 'U', 0, -1, A, B, 1, INFO )
CALL CHKXER( 'SPPTRS', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SPPTRS( 'U', 2, 1, A, B, 1, INFO )
CALL CHKXER( 'SPPTRS', INFOT, NOUT, LERR, OK )
*
* SPPRFS
*
SRNAMT = 'SPPRFS'
INFOT = 1
CALL SPPRFS( '/', 0, 0, A, AF, B, 1, X, 1, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'SPPRFS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SPPRFS( 'U', -1, 0, A, AF, B, 1, X, 1, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'SPPRFS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SPPRFS( 'U', 0, -1, A, AF, B, 1, X, 1, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'SPPRFS', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SPPRFS( 'U', 2, 1, A, AF, B, 1, X, 2, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'SPPRFS', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SPPRFS( 'U', 2, 1, A, AF, B, 2, X, 1, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'SPPRFS', INFOT, NOUT, LERR, OK )
*
* SPPCON
*
SRNAMT = 'SPPCON'
INFOT = 1
CALL SPPCON( '/', 0, A, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'SPPCON', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SPPCON( 'U', -1, A, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'SPPCON', INFOT, NOUT, LERR, OK )
*
* SPPEQU
*
SRNAMT = 'SPPEQU'
INFOT = 1
CALL SPPEQU( '/', 0, A, R1, RCOND, ANRM, INFO )
CALL CHKXER( 'SPPEQU', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SPPEQU( 'U', -1, A, R1, RCOND, ANRM, INFO )
CALL CHKXER( 'SPPEQU', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN
*
* Test error exits of the routines that use the Cholesky
* decomposition of a symmetric positive definite band matrix.
*
* SPBTRF
*
SRNAMT = 'SPBTRF'
INFOT = 1
CALL SPBTRF( '/', 0, 0, A, 1, INFO )
CALL CHKXER( 'SPBTRF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SPBTRF( 'U', -1, 0, A, 1, INFO )
CALL CHKXER( 'SPBTRF', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SPBTRF( 'U', 1, -1, A, 1, INFO )
CALL CHKXER( 'SPBTRF', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SPBTRF( 'U', 2, 1, A, 1, INFO )
CALL CHKXER( 'SPBTRF', INFOT, NOUT, LERR, OK )
*
* SPBTF2
*
SRNAMT = 'SPBTF2'
INFOT = 1
CALL SPBTF2( '/', 0, 0, A, 1, INFO )
CALL CHKXER( 'SPBTF2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SPBTF2( 'U', -1, 0, A, 1, INFO )
CALL CHKXER( 'SPBTF2', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SPBTF2( 'U', 1, -1, A, 1, INFO )
CALL CHKXER( 'SPBTF2', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SPBTF2( 'U', 2, 1, A, 1, INFO )
CALL CHKXER( 'SPBTF2', INFOT, NOUT, LERR, OK )
*
* SPBTRS
*
SRNAMT = 'SPBTRS'
INFOT = 1
CALL SPBTRS( '/', 0, 0, 0, A, 1, B, 1, INFO )
CALL CHKXER( 'SPBTRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SPBTRS( 'U', -1, 0, 0, A, 1, B, 1, INFO )
CALL CHKXER( 'SPBTRS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SPBTRS( 'U', 1, -1, 0, A, 1, B, 1, INFO )
CALL CHKXER( 'SPBTRS', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SPBTRS( 'U', 0, 0, -1, A, 1, B, 1, INFO )
CALL CHKXER( 'SPBTRS', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SPBTRS( 'U', 2, 1, 1, A, 1, B, 1, INFO )
CALL CHKXER( 'SPBTRS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SPBTRS( 'U', 2, 0, 1, A, 1, B, 1, INFO )
CALL CHKXER( 'SPBTRS', INFOT, NOUT, LERR, OK )
*
* SPBRFS
*
SRNAMT = 'SPBRFS'
INFOT = 1
CALL SPBRFS( '/', 0, 0, 0, A, 1, AF, 1, B, 1, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'SPBRFS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SPBRFS( 'U', -1, 0, 0, A, 1, AF, 1, B, 1, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'SPBRFS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SPBRFS( 'U', 1, -1, 0, A, 1, AF, 1, B, 1, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'SPBRFS', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SPBRFS( 'U', 0, 0, -1, A, 1, AF, 1, B, 1, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'SPBRFS', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SPBRFS( 'U', 2, 1, 1, A, 1, AF, 2, B, 2, X, 2, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'SPBRFS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SPBRFS( 'U', 2, 1, 1, A, 2, AF, 1, B, 2, X, 2, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'SPBRFS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SPBRFS( 'U', 2, 0, 1, A, 1, AF, 1, B, 1, X, 2, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'SPBRFS', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SPBRFS( 'U', 2, 0, 1, A, 1, AF, 1, B, 2, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'SPBRFS', INFOT, NOUT, LERR, OK )
*
* SPBCON
*
SRNAMT = 'SPBCON'
INFOT = 1
CALL SPBCON( '/', 0, 0, A, 1, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'SPBCON', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SPBCON( 'U', -1, 0, A, 1, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'SPBCON', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SPBCON( 'U', 1, -1, A, 1, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'SPBCON', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SPBCON( 'U', 2, 1, A, 1, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'SPBCON', INFOT, NOUT, LERR, OK )
*
* SPBEQU
*
SRNAMT = 'SPBEQU'
INFOT = 1
CALL SPBEQU( '/', 0, 0, A, 1, R1, RCOND, ANRM, INFO )
CALL CHKXER( 'SPBEQU', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SPBEQU( 'U', -1, 0, A, 1, R1, RCOND, ANRM, INFO )
CALL CHKXER( 'SPBEQU', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SPBEQU( 'U', 1, -1, A, 1, R1, RCOND, ANRM, INFO )
CALL CHKXER( 'SPBEQU', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SPBEQU( 'U', 2, 1, A, 1, R1, RCOND, ANRM, INFO )
CALL CHKXER( 'SPBEQU', INFOT, NOUT, LERR, OK )
END IF
*
* Print a summary line.
*
CALL ALAESM( PATH, OK, NOUT )
*
RETURN
*
* End of SERRPO
*
END
SUBROUTINE SERRQL( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* SERRQL tests the error exits for the REAL routines
* that use the QL decomposition of a general matrix.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 2 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
* ..
* .. Local Arrays ..
REAL A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
$ W( NMAX ), X( NMAX )
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, SGEQL2, SGEQLF, SGEQLS, SORG2L,
$ SORGQL, SORM2L, SORMQL
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
*
* Set the variables to innocuous values.
*
DO 20 J = 1, NMAX
DO 10 I = 1, NMAX
A( I, J ) = 1. / REAL( I+J )
AF( I, J ) = 1. / REAL( I+J )
10 CONTINUE
B( J ) = 0.
W( J ) = 0.
X( J ) = 0.
20 CONTINUE
OK = .TRUE.
*
* Error exits for QL factorization
*
* SGEQLF
*
SRNAMT = 'SGEQLF'
INFOT = 1
CALL SGEQLF( -1, 0, A, 1, B, W, 1, INFO )
CALL CHKXER( 'SGEQLF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGEQLF( 0, -1, A, 1, B, W, 1, INFO )
CALL CHKXER( 'SGEQLF', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGEQLF( 2, 1, A, 1, B, W, 1, INFO )
CALL CHKXER( 'SGEQLF', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SGEQLF( 1, 2, A, 1, B, W, 1, INFO )
CALL CHKXER( 'SGEQLF', INFOT, NOUT, LERR, OK )
*
* SGEQL2
*
SRNAMT = 'SGEQL2'
INFOT = 1
CALL SGEQL2( -1, 0, A, 1, B, W, INFO )
CALL CHKXER( 'SGEQL2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGEQL2( 0, -1, A, 1, B, W, INFO )
CALL CHKXER( 'SGEQL2', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGEQL2( 2, 1, A, 1, B, W, INFO )
CALL CHKXER( 'SGEQL2', INFOT, NOUT, LERR, OK )
*
* SGEQLS
*
SRNAMT = 'SGEQLS'
INFOT = 1
CALL SGEQLS( -1, 0, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGEQLS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGEQLS( 0, -1, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGEQLS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGEQLS( 1, 2, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGEQLS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGEQLS( 0, 0, -1, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGEQLS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGEQLS( 2, 1, 0, A, 1, X, B, 2, W, 1, INFO )
CALL CHKXER( 'SGEQLS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SGEQLS( 2, 1, 0, A, 2, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGEQLS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SGEQLS( 1, 1, 2, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGEQLS', INFOT, NOUT, LERR, OK )
*
* SORGQL
*
SRNAMT = 'SORGQL'
INFOT = 1
CALL SORGQL( -1, 0, 0, A, 1, X, W, 1, INFO )
CALL CHKXER( 'SORGQL', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORGQL( 0, -1, 0, A, 1, X, W, 1, INFO )
CALL CHKXER( 'SORGQL', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORGQL( 1, 2, 0, A, 1, X, W, 2, INFO )
CALL CHKXER( 'SORGQL', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORGQL( 0, 0, -1, A, 1, X, W, 1, INFO )
CALL CHKXER( 'SORGQL', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORGQL( 1, 1, 2, A, 1, X, W, 1, INFO )
CALL CHKXER( 'SORGQL', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORGQL( 2, 1, 0, A, 1, X, W, 1, INFO )
CALL CHKXER( 'SORGQL', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SORGQL( 2, 2, 0, A, 2, X, W, 1, INFO )
CALL CHKXER( 'SORGQL', INFOT, NOUT, LERR, OK )
*
* SORG2L
*
SRNAMT = 'SORG2L'
INFOT = 1
CALL SORG2L( -1, 0, 0, A, 1, X, W, INFO )
CALL CHKXER( 'SORG2L', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORG2L( 0, -1, 0, A, 1, X, W, INFO )
CALL CHKXER( 'SORG2L', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORG2L( 1, 2, 0, A, 1, X, W, INFO )
CALL CHKXER( 'SORG2L', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORG2L( 0, 0, -1, A, 1, X, W, INFO )
CALL CHKXER( 'SORG2L', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORG2L( 2, 1, 2, A, 2, X, W, INFO )
CALL CHKXER( 'SORG2L', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORG2L( 2, 1, 0, A, 1, X, W, INFO )
CALL CHKXER( 'SORG2L', INFOT, NOUT, LERR, OK )
*
* SORMQL
*
SRNAMT = 'SORMQL'
INFOT = 1
CALL SORMQL( '/', 'N', 0, 0, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMQL', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORMQL( 'L', '/', 0, 0, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMQL', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORMQL( 'L', 'N', -1, 0, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMQL', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SORMQL( 'L', 'N', 0, -1, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMQL', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORMQL( 'L', 'N', 0, 0, -1, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMQL', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORMQL( 'L', 'N', 0, 1, 1, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMQL', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORMQL( 'R', 'N', 1, 0, 1, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMQL', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SORMQL( 'L', 'N', 2, 1, 0, A, 1, X, AF, 2, W, 1, INFO )
CALL CHKXER( 'SORMQL', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SORMQL( 'R', 'N', 1, 2, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMQL', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SORMQL( 'L', 'N', 2, 1, 0, A, 2, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMQL', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SORMQL( 'L', 'N', 1, 2, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMQL', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SORMQL( 'R', 'N', 2, 1, 0, A, 1, X, AF, 2, W, 1, INFO )
CALL CHKXER( 'SORMQL', INFOT, NOUT, LERR, OK )
*
* SORM2L
*
SRNAMT = 'SORM2L'
INFOT = 1
CALL SORM2L( '/', 'N', 0, 0, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORM2L', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORM2L( 'L', '/', 0, 0, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORM2L', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORM2L( 'L', 'N', -1, 0, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORM2L', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SORM2L( 'L', 'N', 0, -1, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORM2L', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORM2L( 'L', 'N', 0, 0, -1, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORM2L', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORM2L( 'L', 'N', 0, 1, 1, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORM2L', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORM2L( 'R', 'N', 1, 0, 1, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORM2L', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SORM2L( 'L', 'N', 2, 1, 0, A, 1, X, AF, 2, W, INFO )
CALL CHKXER( 'SORM2L', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SORM2L( 'R', 'N', 1, 2, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORM2L', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SORM2L( 'L', 'N', 2, 1, 0, A, 2, X, AF, 1, W, INFO )
CALL CHKXER( 'SORM2L', INFOT, NOUT, LERR, OK )
*
* Print a summary line.
*
CALL ALAESM( PATH, OK, NOUT )
*
RETURN
*
* End of SERRQL
*
END
SUBROUTINE SERRQP( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* SERRQP tests the error exits for SGEQPF and SGEQP3.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 3 )
* ..
* .. Local Scalars ..
CHARACTER*2 C2
INTEGER INFO, LW
* ..
* .. Local Arrays ..
INTEGER IP( NMAX )
REAL A( NMAX, NMAX ), TAU( NMAX ), W( 3*NMAX+1 )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, SGEQP3, SGEQPF
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
C2 = PATH( 2: 3 )
LW = 3*NMAX + 1
A( 1, 1 ) = 1.0E+0
A( 1, 2 ) = 2.0E+0
A( 2, 2 ) = 3.0E+0
A( 2, 1 ) = 4.0E+0
OK = .TRUE.
*
IF( LSAMEN( 2, C2, 'QP' ) ) THEN
*
* Test error exits for QR factorization with pivoting
*
* SGEQPF
*
SRNAMT = 'SGEQPF'
INFOT = 1
CALL SGEQPF( -1, 0, A, 1, IP, TAU, W, INFO )
CALL CHKXER( 'SGEQPF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGEQPF( 0, -1, A, 1, IP, TAU, W, INFO )
CALL CHKXER( 'SGEQPF', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGEQPF( 2, 0, A, 1, IP, TAU, W, INFO )
CALL CHKXER( 'SGEQPF', INFOT, NOUT, LERR, OK )
*
* SGEQP3
*
SRNAMT = 'SGEQP3'
INFOT = 1
CALL SGEQP3( -1, 0, A, 1, IP, TAU, W, LW, INFO )
CALL CHKXER( 'SGEQP3', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGEQP3( 1, -1, A, 1, IP, TAU, W, LW, INFO )
CALL CHKXER( 'SGEQP3', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGEQP3( 2, 3, A, 1, IP, TAU, W, LW, INFO )
CALL CHKXER( 'SGEQP3', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SGEQP3( 2, 2, A, 2, IP, TAU, W, LW-10, INFO )
CALL CHKXER( 'SGEQP3', INFOT, NOUT, LERR, OK )
END IF
*
* Print a summary line.
*
CALL ALAESM( PATH, OK, NOUT )
*
RETURN
*
* End of SERRQP
*
END
SUBROUTINE SERRQR( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* SERRQR tests the error exits for the REAL routines
* that use the QR decomposition of a general matrix.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 2 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
* ..
* .. Local Arrays ..
REAL A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
$ W( NMAX ), X( NMAX )
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, SGEQR2, SGEQRF, SGEQRS, SORG2R,
$ SORGQR, SORM2R, SORMQR
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
*
* Set the variables to innocuous values.
*
DO 20 J = 1, NMAX
DO 10 I = 1, NMAX
A( I, J ) = 1. / REAL( I+J )
AF( I, J ) = 1. / REAL( I+J )
10 CONTINUE
B( J ) = 0.
W( J ) = 0.
X( J ) = 0.
20 CONTINUE
OK = .TRUE.
*
* Error exits for QR factorization
*
* SGEQRF
*
SRNAMT = 'SGEQRF'
INFOT = 1
CALL SGEQRF( -1, 0, A, 1, B, W, 1, INFO )
CALL CHKXER( 'SGEQRF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGEQRF( 0, -1, A, 1, B, W, 1, INFO )
CALL CHKXER( 'SGEQRF', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGEQRF( 2, 1, A, 1, B, W, 1, INFO )
CALL CHKXER( 'SGEQRF', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SGEQRF( 1, 2, A, 1, B, W, 1, INFO )
CALL CHKXER( 'SGEQRF', INFOT, NOUT, LERR, OK )
*
* SGEQR2
*
SRNAMT = 'SGEQR2'
INFOT = 1
CALL SGEQR2( -1, 0, A, 1, B, W, INFO )
CALL CHKXER( 'SGEQR2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGEQR2( 0, -1, A, 1, B, W, INFO )
CALL CHKXER( 'SGEQR2', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGEQR2( 2, 1, A, 1, B, W, INFO )
CALL CHKXER( 'SGEQR2', INFOT, NOUT, LERR, OK )
*
* SGEQRS
*
SRNAMT = 'SGEQRS'
INFOT = 1
CALL SGEQRS( -1, 0, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGEQRS( 0, -1, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGEQRS( 1, 2, 0, A, 2, X, B, 2, W, 1, INFO )
CALL CHKXER( 'SGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGEQRS( 0, 0, -1, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGEQRS( 2, 1, 0, A, 1, X, B, 2, W, 1, INFO )
CALL CHKXER( 'SGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SGEQRS( 2, 1, 0, A, 2, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SGEQRS( 1, 1, 2, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGEQRS', INFOT, NOUT, LERR, OK )
*
* SORGQR
*
SRNAMT = 'SORGQR'
INFOT = 1
CALL SORGQR( -1, 0, 0, A, 1, X, W, 1, INFO )
CALL CHKXER( 'SORGQR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORGQR( 0, -1, 0, A, 1, X, W, 1, INFO )
CALL CHKXER( 'SORGQR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORGQR( 1, 2, 0, A, 1, X, W, 2, INFO )
CALL CHKXER( 'SORGQR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORGQR( 0, 0, -1, A, 1, X, W, 1, INFO )
CALL CHKXER( 'SORGQR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORGQR( 1, 1, 2, A, 1, X, W, 1, INFO )
CALL CHKXER( 'SORGQR', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORGQR( 2, 2, 0, A, 1, X, W, 2, INFO )
CALL CHKXER( 'SORGQR', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SORGQR( 2, 2, 0, A, 2, X, W, 1, INFO )
CALL CHKXER( 'SORGQR', INFOT, NOUT, LERR, OK )
*
* SORG2R
*
SRNAMT = 'SORG2R'
INFOT = 1
CALL SORG2R( -1, 0, 0, A, 1, X, W, INFO )
CALL CHKXER( 'SORG2R', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORG2R( 0, -1, 0, A, 1, X, W, INFO )
CALL CHKXER( 'SORG2R', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORG2R( 1, 2, 0, A, 1, X, W, INFO )
CALL CHKXER( 'SORG2R', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORG2R( 0, 0, -1, A, 1, X, W, INFO )
CALL CHKXER( 'SORG2R', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORG2R( 2, 1, 2, A, 2, X, W, INFO )
CALL CHKXER( 'SORG2R', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORG2R( 2, 1, 0, A, 1, X, W, INFO )
CALL CHKXER( 'SORG2R', INFOT, NOUT, LERR, OK )
*
* SORMQR
*
SRNAMT = 'SORMQR'
INFOT = 1
CALL SORMQR( '/', 'N', 0, 0, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMQR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORMQR( 'L', '/', 0, 0, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMQR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORMQR( 'L', 'N', -1, 0, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMQR', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SORMQR( 'L', 'N', 0, -1, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMQR', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORMQR( 'L', 'N', 0, 0, -1, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMQR', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORMQR( 'L', 'N', 0, 1, 1, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMQR', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORMQR( 'R', 'N', 1, 0, 1, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMQR', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SORMQR( 'L', 'N', 2, 1, 0, A, 1, X, AF, 2, W, 1, INFO )
CALL CHKXER( 'SORMQR', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SORMQR( 'R', 'N', 1, 2, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMQR', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SORMQR( 'L', 'N', 2, 1, 0, A, 2, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMQR', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SORMQR( 'L', 'N', 1, 2, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMQR', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SORMQR( 'R', 'N', 2, 1, 0, A, 1, X, AF, 2, W, 1, INFO )
CALL CHKXER( 'SORMQR', INFOT, NOUT, LERR, OK )
*
* SORM2R
*
SRNAMT = 'SORM2R'
INFOT = 1
CALL SORM2R( '/', 'N', 0, 0, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORM2R', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORM2R( 'L', '/', 0, 0, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORM2R', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORM2R( 'L', 'N', -1, 0, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORM2R', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SORM2R( 'L', 'N', 0, -1, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORM2R', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORM2R( 'L', 'N', 0, 0, -1, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORM2R', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORM2R( 'L', 'N', 0, 1, 1, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORM2R', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORM2R( 'R', 'N', 1, 0, 1, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORM2R', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SORM2R( 'L', 'N', 2, 1, 0, A, 1, X, AF, 2, W, INFO )
CALL CHKXER( 'SORM2R', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SORM2R( 'R', 'N', 1, 2, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORM2R', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SORM2R( 'L', 'N', 2, 1, 0, A, 2, X, AF, 1, W, INFO )
CALL CHKXER( 'SORM2R', INFOT, NOUT, LERR, OK )
*
* Print a summary line.
*
CALL ALAESM( PATH, OK, NOUT )
*
RETURN
*
* End of SERRQR
*
END
SUBROUTINE SERRRQ( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* SERRRQ tests the error exits for the REAL routines
* that use the RQ decomposition of a general matrix.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 2 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
* ..
* .. Local Arrays ..
REAL A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
$ W( NMAX ), X( NMAX )
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, SGERQ2, SGERQF, SGERQS, SORGR2,
$ SORGRQ, SORMR2, SORMRQ
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
*
* Set the variables to innocuous values.
*
DO 20 J = 1, NMAX
DO 10 I = 1, NMAX
A( I, J ) = 1. / REAL( I+J )
AF( I, J ) = 1. / REAL( I+J )
10 CONTINUE
B( J ) = 0.
W( J ) = 0.
X( J ) = 0.
20 CONTINUE
OK = .TRUE.
*
* Error exits for RQ factorization
*
* SGERQF
*
SRNAMT = 'SGERQF'
INFOT = 1
CALL SGERQF( -1, 0, A, 1, B, W, 1, INFO )
CALL CHKXER( 'SGERQF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGERQF( 0, -1, A, 1, B, W, 1, INFO )
CALL CHKXER( 'SGERQF', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGERQF( 2, 1, A, 1, B, W, 2, INFO )
CALL CHKXER( 'SGERQF', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SGERQF( 2, 1, A, 2, B, W, 1, INFO )
CALL CHKXER( 'SGERQF', INFOT, NOUT, LERR, OK )
*
* SGERQ2
*
SRNAMT = 'SGERQ2'
INFOT = 1
CALL SGERQ2( -1, 0, A, 1, B, W, INFO )
CALL CHKXER( 'SGERQ2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGERQ2( 0, -1, A, 1, B, W, INFO )
CALL CHKXER( 'SGERQ2', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGERQ2( 2, 1, A, 1, B, W, INFO )
CALL CHKXER( 'SGERQ2', INFOT, NOUT, LERR, OK )
*
* SGERQS
*
SRNAMT = 'SGERQS'
INFOT = 1
CALL SGERQS( -1, 0, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGERQS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGERQS( 0, -1, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGERQS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGERQS( 2, 1, 0, A, 2, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGERQS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGERQS( 0, 0, -1, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGERQS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGERQS( 2, 2, 0, A, 1, X, B, 2, W, 1, INFO )
CALL CHKXER( 'SGERQS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SGERQS( 2, 2, 0, A, 2, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGERQS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SGERQS( 1, 1, 2, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'SGERQS', INFOT, NOUT, LERR, OK )
*
* SORGRQ
*
SRNAMT = 'SORGRQ'
INFOT = 1
CALL SORGRQ( -1, 0, 0, A, 1, X, W, 1, INFO )
CALL CHKXER( 'SORGRQ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORGRQ( 0, -1, 0, A, 1, X, W, 1, INFO )
CALL CHKXER( 'SORGRQ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORGRQ( 2, 1, 0, A, 2, X, W, 2, INFO )
CALL CHKXER( 'SORGRQ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORGRQ( 0, 0, -1, A, 1, X, W, 1, INFO )
CALL CHKXER( 'SORGRQ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORGRQ( 1, 2, 2, A, 1, X, W, 1, INFO )
CALL CHKXER( 'SORGRQ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORGRQ( 2, 2, 0, A, 1, X, W, 2, INFO )
CALL CHKXER( 'SORGRQ', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SORGRQ( 2, 2, 0, A, 2, X, W, 1, INFO )
CALL CHKXER( 'SORGRQ', INFOT, NOUT, LERR, OK )
*
* SORGR2
*
SRNAMT = 'SORGR2'
INFOT = 1
CALL SORGR2( -1, 0, 0, A, 1, X, W, INFO )
CALL CHKXER( 'SORGR2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORGR2( 0, -1, 0, A, 1, X, W, INFO )
CALL CHKXER( 'SORGR2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORGR2( 2, 1, 0, A, 2, X, W, INFO )
CALL CHKXER( 'SORGR2', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORGR2( 0, 0, -1, A, 1, X, W, INFO )
CALL CHKXER( 'SORGR2', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORGR2( 1, 2, 2, A, 2, X, W, INFO )
CALL CHKXER( 'SORGR2', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORGR2( 2, 2, 0, A, 1, X, W, INFO )
CALL CHKXER( 'SORGR2', INFOT, NOUT, LERR, OK )
*
* SORMRQ
*
SRNAMT = 'SORMRQ'
INFOT = 1
CALL SORMRQ( '/', 'N', 0, 0, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMRQ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORMRQ( 'L', '/', 0, 0, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMRQ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORMRQ( 'L', 'N', -1, 0, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMRQ', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SORMRQ( 'L', 'N', 0, -1, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMRQ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORMRQ( 'L', 'N', 0, 0, -1, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMRQ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORMRQ( 'L', 'N', 0, 1, 1, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMRQ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORMRQ( 'R', 'N', 1, 0, 1, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMRQ', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SORMRQ( 'L', 'N', 2, 1, 2, A, 1, X, AF, 2, W, 1, INFO )
CALL CHKXER( 'SORMRQ', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SORMRQ( 'R', 'N', 1, 2, 2, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMRQ', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SORMRQ( 'L', 'N', 2, 1, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMRQ', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SORMRQ( 'L', 'N', 1, 2, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'SORMRQ', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SORMRQ( 'R', 'N', 2, 1, 0, A, 1, X, AF, 2, W, 1, INFO )
CALL CHKXER( 'SORMRQ', INFOT, NOUT, LERR, OK )
*
* SORMR2
*
SRNAMT = 'SORMR2'
INFOT = 1
CALL SORMR2( '/', 'N', 0, 0, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORMR2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SORMR2( 'L', '/', 0, 0, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORMR2', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SORMR2( 'L', 'N', -1, 0, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORMR2', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SORMR2( 'L', 'N', 0, -1, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORMR2', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORMR2( 'L', 'N', 0, 0, -1, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORMR2', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORMR2( 'L', 'N', 0, 1, 1, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORMR2', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SORMR2( 'R', 'N', 1, 0, 1, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORMR2', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SORMR2( 'L', 'N', 2, 1, 2, A, 1, X, AF, 2, W, INFO )
CALL CHKXER( 'SORMR2', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SORMR2( 'R', 'N', 1, 2, 2, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORMR2', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SORMR2( 'L', 'N', 2, 1, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'SORMR2', INFOT, NOUT, LERR, OK )
*
* Print a summary line.
*
CALL ALAESM( PATH, OK, NOUT )
*
RETURN
*
* End of SERRRQ
*
END
SUBROUTINE SERRSY( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* SERRSY tests the error exits for the REAL routines
* for symmetric indefinite matrices.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 4 )
* ..
* .. Local Scalars ..
CHARACTER*2 C2
INTEGER I, INFO, J
REAL ANRM, RCOND
* ..
* .. Local Arrays ..
INTEGER IP( NMAX ), IW( NMAX )
REAL A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
$ R1( NMAX ), R2( NMAX ), W( 3*NMAX ), X( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, SSPCON, SSPRFS, SSPTRF, SSPTRI,
$ SSPTRS, SSYCON, SSYRFS, SSYTF2, SSYTRF, SSYTRI,
$ SSYTRS
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
C2 = PATH( 2: 3 )
*
* Set the variables to innocuous values.
*
DO 20 J = 1, NMAX
DO 10 I = 1, NMAX
A( I, J ) = 1. / REAL( I+J )
AF( I, J ) = 1. / REAL( I+J )
10 CONTINUE
B( J ) = 0.
R1( J ) = 0.
R2( J ) = 0.
W( J ) = 0.
X( J ) = 0.
IP( J ) = J
IW( J ) = J
20 CONTINUE
ANRM = 1.0
RCOND = 1.0
OK = .TRUE.
*
IF( LSAMEN( 2, C2, 'SY' ) ) THEN
*
* Test error exits of the routines that use the Bunch-Kaufman
* factorization of a symmetric indefinite matrix.
*
* SSYTRF
*
SRNAMT = 'SSYTRF'
INFOT = 1
CALL SSYTRF( '/', 0, A, 1, IP, W, 1, INFO )
CALL CHKXER( 'SSYTRF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSYTRF( 'U', -1, A, 1, IP, W, 1, INFO )
CALL CHKXER( 'SSYTRF', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SSYTRF( 'U', 2, A, 1, IP, W, 4, INFO )
CALL CHKXER( 'SSYTRF', INFOT, NOUT, LERR, OK )
*
* SSYTF2
*
SRNAMT = 'SSYTF2'
INFOT = 1
CALL SSYTF2( '/', 0, A, 1, IP, INFO )
CALL CHKXER( 'SSYTF2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSYTF2( 'U', -1, A, 1, IP, INFO )
CALL CHKXER( 'SSYTF2', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SSYTF2( 'U', 2, A, 1, IP, INFO )
CALL CHKXER( 'SSYTF2', INFOT, NOUT, LERR, OK )
*
* SSYTRI
*
SRNAMT = 'SSYTRI'
INFOT = 1
CALL SSYTRI( '/', 0, A, 1, IP, W, INFO )
CALL CHKXER( 'SSYTRI', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSYTRI( 'U', -1, A, 1, IP, W, INFO )
CALL CHKXER( 'SSYTRI', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SSYTRI( 'U', 2, A, 1, IP, W, INFO )
CALL CHKXER( 'SSYTRI', INFOT, NOUT, LERR, OK )
*
* SSYTRS
*
SRNAMT = 'SSYTRS'
INFOT = 1
CALL SSYTRS( '/', 0, 0, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'SSYTRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSYTRS( 'U', -1, 0, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'SSYTRS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSYTRS( 'U', 0, -1, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'SSYTRS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SSYTRS( 'U', 2, 1, A, 1, IP, B, 2, INFO )
CALL CHKXER( 'SSYTRS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SSYTRS( 'U', 2, 1, A, 2, IP, B, 1, INFO )
CALL CHKXER( 'SSYTRS', INFOT, NOUT, LERR, OK )
*
* SSYRFS
*
SRNAMT = 'SSYRFS'
INFOT = 1
CALL SSYRFS( '/', 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'SSYRFS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSYRFS( 'U', -1, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2,
$ W, IW, INFO )
CALL CHKXER( 'SSYRFS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSYRFS( 'U', 0, -1, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2,
$ W, IW, INFO )
CALL CHKXER( 'SSYRFS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SSYRFS( 'U', 2, 1, A, 1, AF, 2, IP, B, 2, X, 2, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'SSYRFS', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SSYRFS( 'U', 2, 1, A, 2, AF, 1, IP, B, 2, X, 2, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'SSYRFS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SSYRFS( 'U', 2, 1, A, 2, AF, 2, IP, B, 1, X, 2, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'SSYRFS', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SSYRFS( 'U', 2, 1, A, 2, AF, 2, IP, B, 2, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'SSYRFS', INFOT, NOUT, LERR, OK )
*
* SSYCON
*
SRNAMT = 'SSYCON'
INFOT = 1
CALL SSYCON( '/', 0, A, 1, IP, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'SSYCON', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSYCON( 'U', -1, A, 1, IP, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'SSYCON', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SSYCON( 'U', 2, A, 1, IP, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'SSYCON', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SSYCON( 'U', 1, A, 1, IP, -1.0, RCOND, W, IW, INFO )
CALL CHKXER( 'SSYCON', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
* Test error exits of the routines that use the Bunch-Kaufman
* factorization of a symmetric indefinite packed matrix.
*
* SSPTRF
*
SRNAMT = 'SSPTRF'
INFOT = 1
CALL SSPTRF( '/', 0, A, IP, INFO )
CALL CHKXER( 'SSPTRF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSPTRF( 'U', -1, A, IP, INFO )
CALL CHKXER( 'SSPTRF', INFOT, NOUT, LERR, OK )
*
* SSPTRI
*
SRNAMT = 'SSPTRI'
INFOT = 1
CALL SSPTRI( '/', 0, A, IP, W, INFO )
CALL CHKXER( 'SSPTRI', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSPTRI( 'U', -1, A, IP, W, INFO )
CALL CHKXER( 'SSPTRI', INFOT, NOUT, LERR, OK )
*
* SSPTRS
*
SRNAMT = 'SSPTRS'
INFOT = 1
CALL SSPTRS( '/', 0, 0, A, IP, B, 1, INFO )
CALL CHKXER( 'SSPTRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSPTRS( 'U', -1, 0, A, IP, B, 1, INFO )
CALL CHKXER( 'SSPTRS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSPTRS( 'U', 0, -1, A, IP, B, 1, INFO )
CALL CHKXER( 'SSPTRS', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SSPTRS( 'U', 2, 1, A, IP, B, 1, INFO )
CALL CHKXER( 'SSPTRS', INFOT, NOUT, LERR, OK )
*
* SSPRFS
*
SRNAMT = 'SSPRFS'
INFOT = 1
CALL SSPRFS( '/', 0, 0, A, AF, IP, B, 1, X, 1, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'SSPRFS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSPRFS( 'U', -1, 0, A, AF, IP, B, 1, X, 1, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'SSPRFS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSPRFS( 'U', 0, -1, A, AF, IP, B, 1, X, 1, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'SSPRFS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SSPRFS( 'U', 2, 1, A, AF, IP, B, 1, X, 2, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'SSPRFS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SSPRFS( 'U', 2, 1, A, AF, IP, B, 2, X, 1, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'SSPRFS', INFOT, NOUT, LERR, OK )
*
* SSPCON
*
SRNAMT = 'SSPCON'
INFOT = 1
CALL SSPCON( '/', 0, A, IP, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'SSPCON', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSPCON( 'U', -1, A, IP, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'SSPCON', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SSPCON( 'U', 1, A, IP, -1.0, RCOND, W, IW, INFO )
CALL CHKXER( 'SSPCON', INFOT, NOUT, LERR, OK )
END IF
*
* Print a summary line.
*
CALL ALAESM( PATH, OK, NOUT )
*
RETURN
*
* End of SERRSY
*
END
SUBROUTINE SERRTR( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* SERRTR tests the error exits for the REAL triangular
* routines.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 2 )
* ..
* .. Local Scalars ..
CHARACTER*2 C2
INTEGER INFO
REAL RCOND, SCALE
* ..
* .. Local Arrays ..
INTEGER IW( NMAX )
REAL A( NMAX, NMAX ), B( NMAX ), R1( NMAX ),
$ R2( NMAX ), W( NMAX ), X( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, SLATBS, SLATPS, SLATRS, STBCON,
$ STBRFS, STBTRS, STPCON, STPRFS, STPTRI, STPTRS,
$ STRCON, STRRFS, STRTI2, STRTRI, STRTRS
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
C2 = PATH( 2: 3 )
A( 1, 1 ) = 1.
A( 1, 2 ) = 2.
A( 2, 2 ) = 3.
A( 2, 1 ) = 4.
OK = .TRUE.
*
IF( LSAMEN( 2, C2, 'TR' ) ) THEN
*
* Test error exits for the general triangular routines.
*
* STRTRI
*
SRNAMT = 'STRTRI'
INFOT = 1
CALL STRTRI( '/', 'N', 0, A, 1, INFO )
CALL CHKXER( 'STRTRI', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STRTRI( 'U', '/', 0, A, 1, INFO )
CALL CHKXER( 'STRTRI', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL STRTRI( 'U', 'N', -1, A, 1, INFO )
CALL CHKXER( 'STRTRI', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STRTRI( 'U', 'N', 2, A, 1, INFO )
CALL CHKXER( 'STRTRI', INFOT, NOUT, LERR, OK )
*
* STRTI2
*
SRNAMT = 'STRTI2'
INFOT = 1
CALL STRTI2( '/', 'N', 0, A, 1, INFO )
CALL CHKXER( 'STRTI2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STRTI2( 'U', '/', 0, A, 1, INFO )
CALL CHKXER( 'STRTI2', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL STRTI2( 'U', 'N', -1, A, 1, INFO )
CALL CHKXER( 'STRTI2', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STRTI2( 'U', 'N', 2, A, 1, INFO )
CALL CHKXER( 'STRTI2', INFOT, NOUT, LERR, OK )
*
* STRTRS
*
SRNAMT = 'STRTRS'
INFOT = 1
CALL STRTRS( '/', 'N', 'N', 0, 0, A, 1, X, 1, INFO )
CALL CHKXER( 'STRTRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STRTRS( 'U', '/', 'N', 0, 0, A, 1, X, 1, INFO )
CALL CHKXER( 'STRTRS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL STRTRS( 'U', 'N', '/', 0, 0, A, 1, X, 1, INFO )
CALL CHKXER( 'STRTRS', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL STRTRS( 'U', 'N', 'N', -1, 0, A, 1, X, 1, INFO )
CALL CHKXER( 'STRTRS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STRTRS( 'U', 'N', 'N', 0, -1, A, 1, X, 1, INFO )
CALL CHKXER( 'STRTRS', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL STRTRS( 'U', 'N', 'N', 2, 1, A, 1, X, 2, INFO )
CALL CHKXER( 'STRTRS', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL STRTRS( 'U', 'N', 'N', 2, 1, A, 2, X, 1, INFO )
CALL CHKXER( 'STRTRS', INFOT, NOUT, LERR, OK )
*
* STRRFS
*
SRNAMT = 'STRRFS'
INFOT = 1
CALL STRRFS( '/', 'N', 'N', 0, 0, A, 1, B, 1, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'STRRFS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STRRFS( 'U', '/', 'N', 0, 0, A, 1, B, 1, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'STRRFS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL STRRFS( 'U', 'N', '/', 0, 0, A, 1, B, 1, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'STRRFS', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL STRRFS( 'U', 'N', 'N', -1, 0, A, 1, B, 1, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'STRRFS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STRRFS( 'U', 'N', 'N', 0, -1, A, 1, B, 1, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'STRRFS', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL STRRFS( 'U', 'N', 'N', 2, 1, A, 1, B, 2, X, 2, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'STRRFS', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL STRRFS( 'U', 'N', 'N', 2, 1, A, 2, B, 1, X, 2, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'STRRFS', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL STRRFS( 'U', 'N', 'N', 2, 1, A, 2, B, 2, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'STRRFS', INFOT, NOUT, LERR, OK )
*
* STRCON
*
SRNAMT = 'STRCON'
INFOT = 1
CALL STRCON( '/', 'U', 'N', 0, A, 1, RCOND, W, IW, INFO )
CALL CHKXER( 'STRCON', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STRCON( '1', '/', 'N', 0, A, 1, RCOND, W, IW, INFO )
CALL CHKXER( 'STRCON', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL STRCON( '1', 'U', '/', 0, A, 1, RCOND, W, IW, INFO )
CALL CHKXER( 'STRCON', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL STRCON( '1', 'U', 'N', -1, A, 1, RCOND, W, IW, INFO )
CALL CHKXER( 'STRCON', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL STRCON( '1', 'U', 'N', 2, A, 1, RCOND, W, IW, INFO )
CALL CHKXER( 'STRCON', INFOT, NOUT, LERR, OK )
*
* SLATRS
*
SRNAMT = 'SLATRS'
INFOT = 1
CALL SLATRS( '/', 'N', 'N', 'N', 0, A, 1, X, SCALE, W, INFO )
CALL CHKXER( 'SLATRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SLATRS( 'U', '/', 'N', 'N', 0, A, 1, X, SCALE, W, INFO )
CALL CHKXER( 'SLATRS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SLATRS( 'U', 'N', '/', 'N', 0, A, 1, X, SCALE, W, INFO )
CALL CHKXER( 'SLATRS', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SLATRS( 'U', 'N', 'N', '/', 0, A, 1, X, SCALE, W, INFO )
CALL CHKXER( 'SLATRS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SLATRS( 'U', 'N', 'N', 'N', -1, A, 1, X, SCALE, W, INFO )
CALL CHKXER( 'SLATRS', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SLATRS( 'U', 'N', 'N', 'N', 2, A, 1, X, SCALE, W, INFO )
CALL CHKXER( 'SLATRS', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'TP' ) ) THEN
*
* Test error exits for the packed triangular routines.
*
* STPTRI
*
SRNAMT = 'STPTRI'
INFOT = 1
CALL STPTRI( '/', 'N', 0, A, INFO )
CALL CHKXER( 'STPTRI', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STPTRI( 'U', '/', 0, A, INFO )
CALL CHKXER( 'STPTRI', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL STPTRI( 'U', 'N', -1, A, INFO )
CALL CHKXER( 'STPTRI', INFOT, NOUT, LERR, OK )
*
* STPTRS
*
SRNAMT = 'STPTRS'
INFOT = 1
CALL STPTRS( '/', 'N', 'N', 0, 0, A, X, 1, INFO )
CALL CHKXER( 'STPTRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STPTRS( 'U', '/', 'N', 0, 0, A, X, 1, INFO )
CALL CHKXER( 'STPTRS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL STPTRS( 'U', 'N', '/', 0, 0, A, X, 1, INFO )
CALL CHKXER( 'STPTRS', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL STPTRS( 'U', 'N', 'N', -1, 0, A, X, 1, INFO )
CALL CHKXER( 'STPTRS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STPTRS( 'U', 'N', 'N', 0, -1, A, X, 1, INFO )
CALL CHKXER( 'STPTRS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL STPTRS( 'U', 'N', 'N', 2, 1, A, X, 1, INFO )
CALL CHKXER( 'STPTRS', INFOT, NOUT, LERR, OK )
*
* STPRFS
*
SRNAMT = 'STPRFS'
INFOT = 1
CALL STPRFS( '/', 'N', 'N', 0, 0, A, B, 1, X, 1, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'STPRFS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STPRFS( 'U', '/', 'N', 0, 0, A, B, 1, X, 1, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'STPRFS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL STPRFS( 'U', 'N', '/', 0, 0, A, B, 1, X, 1, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'STPRFS', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL STPRFS( 'U', 'N', 'N', -1, 0, A, B, 1, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'STPRFS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STPRFS( 'U', 'N', 'N', 0, -1, A, B, 1, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'STPRFS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL STPRFS( 'U', 'N', 'N', 2, 1, A, B, 1, X, 2, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'STPRFS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL STPRFS( 'U', 'N', 'N', 2, 1, A, B, 2, X, 1, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'STPRFS', INFOT, NOUT, LERR, OK )
*
* STPCON
*
SRNAMT = 'STPCON'
INFOT = 1
CALL STPCON( '/', 'U', 'N', 0, A, RCOND, W, IW, INFO )
CALL CHKXER( 'STPCON', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STPCON( '1', '/', 'N', 0, A, RCOND, W, IW, INFO )
CALL CHKXER( 'STPCON', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL STPCON( '1', 'U', '/', 0, A, RCOND, W, IW, INFO )
CALL CHKXER( 'STPCON', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL STPCON( '1', 'U', 'N', -1, A, RCOND, W, IW, INFO )
CALL CHKXER( 'STPCON', INFOT, NOUT, LERR, OK )
*
* SLATPS
*
SRNAMT = 'SLATPS'
INFOT = 1
CALL SLATPS( '/', 'N', 'N', 'N', 0, A, X, SCALE, W, INFO )
CALL CHKXER( 'SLATPS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SLATPS( 'U', '/', 'N', 'N', 0, A, X, SCALE, W, INFO )
CALL CHKXER( 'SLATPS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SLATPS( 'U', 'N', '/', 'N', 0, A, X, SCALE, W, INFO )
CALL CHKXER( 'SLATPS', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SLATPS( 'U', 'N', 'N', '/', 0, A, X, SCALE, W, INFO )
CALL CHKXER( 'SLATPS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SLATPS( 'U', 'N', 'N', 'N', -1, A, X, SCALE, W, INFO )
CALL CHKXER( 'SLATPS', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
*
* Test error exits for the banded triangular routines.
*
* STBTRS
*
SRNAMT = 'STBTRS'
INFOT = 1
CALL STBTRS( '/', 'N', 'N', 0, 0, 0, A, 1, X, 1, INFO )
CALL CHKXER( 'STBTRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STBTRS( 'U', '/', 'N', 0, 0, 0, A, 1, X, 1, INFO )
CALL CHKXER( 'STBTRS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL STBTRS( 'U', 'N', '/', 0, 0, 0, A, 1, X, 1, INFO )
CALL CHKXER( 'STBTRS', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL STBTRS( 'U', 'N', 'N', -1, 0, 0, A, 1, X, 1, INFO )
CALL CHKXER( 'STBTRS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STBTRS( 'U', 'N', 'N', 0, -1, 0, A, 1, X, 1, INFO )
CALL CHKXER( 'STBTRS', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL STBTRS( 'U', 'N', 'N', 0, 0, -1, A, 1, X, 1, INFO )
CALL CHKXER( 'STBTRS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL STBTRS( 'U', 'N', 'N', 2, 1, 1, A, 1, X, 2, INFO )
CALL CHKXER( 'STBTRS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL STBTRS( 'U', 'N', 'N', 2, 0, 1, A, 1, X, 1, INFO )
CALL CHKXER( 'STBTRS', INFOT, NOUT, LERR, OK )
*
* STBRFS
*
SRNAMT = 'STBRFS'
INFOT = 1
CALL STBRFS( '/', 'N', 'N', 0, 0, 0, A, 1, B, 1, X, 1, R1, R2,
$ W, IW, INFO )
CALL CHKXER( 'STBRFS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STBRFS( 'U', '/', 'N', 0, 0, 0, A, 1, B, 1, X, 1, R1, R2,
$ W, IW, INFO )
CALL CHKXER( 'STBRFS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL STBRFS( 'U', 'N', '/', 0, 0, 0, A, 1, B, 1, X, 1, R1, R2,
$ W, IW, INFO )
CALL CHKXER( 'STBRFS', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL STBRFS( 'U', 'N', 'N', -1, 0, 0, A, 1, B, 1, X, 1, R1, R2,
$ W, IW, INFO )
CALL CHKXER( 'STBRFS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STBRFS( 'U', 'N', 'N', 0, -1, 0, A, 1, B, 1, X, 1, R1, R2,
$ W, IW, INFO )
CALL CHKXER( 'STBRFS', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL STBRFS( 'U', 'N', 'N', 0, 0, -1, A, 1, B, 1, X, 1, R1, R2,
$ W, IW, INFO )
CALL CHKXER( 'STBRFS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL STBRFS( 'U', 'N', 'N', 2, 1, 1, A, 1, B, 2, X, 2, R1, R2,
$ W, IW, INFO )
CALL CHKXER( 'STBRFS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL STBRFS( 'U', 'N', 'N', 2, 1, 1, A, 2, B, 1, X, 2, R1, R2,
$ W, IW, INFO )
CALL CHKXER( 'STBRFS', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL STBRFS( 'U', 'N', 'N', 2, 1, 1, A, 2, B, 2, X, 1, R1, R2,
$ W, IW, INFO )
CALL CHKXER( 'STBRFS', INFOT, NOUT, LERR, OK )
*
* STBCON
*
SRNAMT = 'STBCON'
INFOT = 1
CALL STBCON( '/', 'U', 'N', 0, 0, A, 1, RCOND, W, IW, INFO )
CALL CHKXER( 'STBCON', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STBCON( '1', '/', 'N', 0, 0, A, 1, RCOND, W, IW, INFO )
CALL CHKXER( 'STBCON', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL STBCON( '1', 'U', '/', 0, 0, A, 1, RCOND, W, IW, INFO )
CALL CHKXER( 'STBCON', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL STBCON( '1', 'U', 'N', -1, 0, A, 1, RCOND, W, IW, INFO )
CALL CHKXER( 'STBCON', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STBCON( '1', 'U', 'N', 0, -1, A, 1, RCOND, W, IW, INFO )
CALL CHKXER( 'STBCON', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL STBCON( '1', 'U', 'N', 2, 1, A, 1, RCOND, W, IW, INFO )
CALL CHKXER( 'STBCON', INFOT, NOUT, LERR, OK )
*
* SLATBS
*
SRNAMT = 'SLATBS'
INFOT = 1
CALL SLATBS( '/', 'N', 'N', 'N', 0, 0, A, 1, X, SCALE, W,
$ INFO )
CALL CHKXER( 'SLATBS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SLATBS( 'U', '/', 'N', 'N', 0, 0, A, 1, X, SCALE, W,
$ INFO )
CALL CHKXER( 'SLATBS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SLATBS( 'U', 'N', '/', 'N', 0, 0, A, 1, X, SCALE, W,
$ INFO )
CALL CHKXER( 'SLATBS', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SLATBS( 'U', 'N', 'N', '/', 0, 0, A, 1, X, SCALE, W,
$ INFO )
CALL CHKXER( 'SLATBS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SLATBS( 'U', 'N', 'N', 'N', -1, 0, A, 1, X, SCALE, W,
$ INFO )
CALL CHKXER( 'SLATBS', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SLATBS( 'U', 'N', 'N', 'N', 1, -1, A, 1, X, SCALE, W,
$ INFO )
CALL CHKXER( 'SLATBS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SLATBS( 'U', 'N', 'N', 'N', 2, 1, A, 1, X, SCALE, W,
$ INFO )
CALL CHKXER( 'SLATBS', INFOT, NOUT, LERR, OK )
END IF
*
* Print a summary line.
*
CALL ALAESM( PATH, OK, NOUT )
*
RETURN
*
* End of SERRTR
*
END
SUBROUTINE SERRTZ( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* SERRTZ tests the error exits for STZRQF and STZRZF.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 2 )
* ..
* .. Local Scalars ..
CHARACTER*2 C2
INTEGER INFO
* ..
* .. Local Arrays ..
REAL A( NMAX, NMAX ), TAU( NMAX ), W( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, STZRQF, STZRZF
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
C2 = PATH( 2: 3 )
A( 1, 1 ) = 1.E+0
A( 1, 2 ) = 2.E+0
A( 2, 2 ) = 3.E+0
A( 2, 1 ) = 4.E+0
W( 1 ) = 0.0E+0
W( 2 ) = 0.0E+0
OK = .TRUE.
*
IF( LSAMEN( 2, C2, 'TZ' ) ) THEN
*
* Test error exits for the trapezoidal routines.
*
* STZRQF
*
SRNAMT = 'STZRQF'
INFOT = 1
CALL STZRQF( -1, 0, A, 1, TAU, INFO )
CALL CHKXER( 'STZRQF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STZRQF( 1, 0, A, 1, TAU, INFO )
CALL CHKXER( 'STZRQF', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL STZRQF( 2, 2, A, 1, TAU, INFO )
CALL CHKXER( 'STZRQF', INFOT, NOUT, LERR, OK )
*
* STZRZF
*
SRNAMT = 'STZRZF'
INFOT = 1
CALL STZRZF( -1, 0, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'STZRZF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STZRZF( 1, 0, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'STZRZF', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL STZRZF( 2, 2, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'STZRZF', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL STZRZF( 2, 2, A, 2, TAU, W, 1, INFO )
CALL CHKXER( 'STZRZF', INFOT, NOUT, LERR, OK )
END IF
*
* Print a summary line.
*
CALL ALAESM( PATH, OK, NOUT )
*
RETURN
*
* End of SERRTZ
*
END
SUBROUTINE SERRVX( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* January 2007
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* SERRVX tests the error exits for the REAL driver routines
* for solving linear systems of equations.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 4 )
* ..
* .. Local Scalars ..
CHARACTER EQ
CHARACTER*2 C2
INTEGER I, INFO, J
REAL RCOND
* ..
* .. Local Arrays ..
INTEGER IP( NMAX ), IW( NMAX )
REAL A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
$ C( NMAX ), R( NMAX ), R1( NMAX ), R2( NMAX ),
$ W( 2*NMAX ), X( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL CHKXER, SGBSV, SGBSVX, SGESV, SGESVX, SGTSV,
$ SGTSVX, SPBSV, SPBSVX, SPOSV, SPOSVX, SPPSV,
$ SPPSVX, SPTSV, SPTSVX, SSPSV, SSPSVX, SSYSV,
$ SSYSVX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
C2 = PATH( 2: 3 )
*
* Set the variables to innocuous values.
*
DO 20 J = 1, NMAX
DO 10 I = 1, NMAX
A( I, J ) = 1. / REAL( I+J )
AF( I, J ) = 1. / REAL( I+J )
10 CONTINUE
B( J ) = 0.
R1( J ) = 0.
R2( J ) = 0.
W( J ) = 0.
X( J ) = 0.
C( J ) = 0.
R( J ) = 0.
IP( J ) = J
20 CONTINUE
EQ = ' '
OK = .TRUE.
*
IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
* SGESV
*
SRNAMT = 'SGESV '
INFOT = 1
CALL SGESV( -1, 0, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'SGESV ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGESV( 0, -1, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'SGESV ', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGESV( 2, 1, A, 1, IP, B, 2, INFO )
CALL CHKXER( 'SGESV ', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SGESV( 2, 1, A, 2, IP, B, 1, INFO )
CALL CHKXER( 'SGESV ', INFOT, NOUT, LERR, OK )
*
* SGESVX
*
SRNAMT = 'SGESVX'
INFOT = 1
CALL SGESVX( '/', 'N', 0, 0, A, 1, AF, 1, IP, EQ, R, C, B, 1,
$ X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGESVX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGESVX( 'N', '/', 0, 0, A, 1, AF, 1, IP, EQ, R, C, B, 1,
$ X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGESVX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGESVX( 'N', 'N', -1, 0, A, 1, AF, 1, IP, EQ, R, C, B, 1,
$ X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGESVX', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGESVX( 'N', 'N', 0, -1, A, 1, AF, 1, IP, EQ, R, C, B, 1,
$ X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGESVX', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SGESVX( 'N', 'N', 2, 1, A, 1, AF, 2, IP, EQ, R, C, B, 2,
$ X, 2, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGESVX', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SGESVX( 'N', 'N', 2, 1, A, 2, AF, 1, IP, EQ, R, C, B, 2,
$ X, 2, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGESVX', INFOT, NOUT, LERR, OK )
INFOT = 10
EQ = '/'
CALL SGESVX( 'F', 'N', 0, 0, A, 1, AF, 1, IP, EQ, R, C, B, 1,
$ X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGESVX', INFOT, NOUT, LERR, OK )
INFOT = 11
EQ = 'R'
CALL SGESVX( 'F', 'N', 1, 0, A, 1, AF, 1, IP, EQ, R, C, B, 1,
$ X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGESVX', INFOT, NOUT, LERR, OK )
INFOT = 12
EQ = 'C'
CALL SGESVX( 'F', 'N', 1, 0, A, 1, AF, 1, IP, EQ, R, C, B, 1,
$ X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGESVX', INFOT, NOUT, LERR, OK )
INFOT = 14
CALL SGESVX( 'N', 'N', 2, 1, A, 2, AF, 2, IP, EQ, R, C, B, 1,
$ X, 2, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGESVX', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL SGESVX( 'N', 'N', 2, 1, A, 2, AF, 2, IP, EQ, R, C, B, 2,
$ X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGESVX', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
*
* SGBSV
*
SRNAMT = 'SGBSV '
INFOT = 1
CALL SGBSV( -1, 0, 0, 0, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'SGBSV ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGBSV( 1, -1, 0, 0, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'SGBSV ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGBSV( 1, 0, -1, 0, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'SGBSV ', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGBSV( 0, 0, 0, -1, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'SGBSV ', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SGBSV( 1, 1, 1, 0, A, 3, IP, B, 1, INFO )
CALL CHKXER( 'SGBSV ', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SGBSV( 2, 0, 0, 0, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'SGBSV ', INFOT, NOUT, LERR, OK )
*
* SGBSVX
*
SRNAMT = 'SGBSVX'
INFOT = 1
CALL SGBSVX( '/', 'N', 0, 0, 0, 0, A, 1, AF, 1, IP, EQ, R, C,
$ B, 1, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGBSVX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGBSVX( 'N', '/', 0, 0, 0, 0, A, 1, AF, 1, IP, EQ, R, C,
$ B, 1, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGBSVX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGBSVX( 'N', 'N', -1, 0, 0, 0, A, 1, AF, 1, IP, EQ, R, C,
$ B, 1, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGBSVX', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGBSVX( 'N', 'N', 1, -1, 0, 0, A, 1, AF, 1, IP, EQ, R, C,
$ B, 1, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGBSVX', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGBSVX( 'N', 'N', 1, 0, -1, 0, A, 1, AF, 1, IP, EQ, R, C,
$ B, 1, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGBSVX', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SGBSVX( 'N', 'N', 0, 0, 0, -1, A, 1, AF, 1, IP, EQ, R, C,
$ B, 1, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGBSVX', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SGBSVX( 'N', 'N', 1, 1, 1, 0, A, 2, AF, 4, IP, EQ, R, C,
$ B, 1, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGBSVX', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SGBSVX( 'N', 'N', 1, 1, 1, 0, A, 3, AF, 3, IP, EQ, R, C,
$ B, 1, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGBSVX', INFOT, NOUT, LERR, OK )
INFOT = 12
EQ = '/'
CALL SGBSVX( 'F', 'N', 0, 0, 0, 0, A, 1, AF, 1, IP, EQ, R, C,
$ B, 1, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGBSVX', INFOT, NOUT, LERR, OK )
INFOT = 13
EQ = 'R'
CALL SGBSVX( 'F', 'N', 1, 0, 0, 0, A, 1, AF, 1, IP, EQ, R, C,
$ B, 1, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGBSVX', INFOT, NOUT, LERR, OK )
INFOT = 14
EQ = 'C'
CALL SGBSVX( 'F', 'N', 1, 0, 0, 0, A, 1, AF, 1, IP, EQ, R, C,
$ B, 1, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGBSVX', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL SGBSVX( 'N', 'N', 2, 0, 0, 0, A, 1, AF, 1, IP, EQ, R, C,
$ B, 1, X, 2, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGBSVX', INFOT, NOUT, LERR, OK )
INFOT = 18
CALL SGBSVX( 'N', 'N', 2, 0, 0, 0, A, 1, AF, 1, IP, EQ, R, C,
$ B, 2, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGBSVX', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'GT' ) ) THEN
*
* SGTSV
*
SRNAMT = 'SGTSV '
INFOT = 1
CALL SGTSV( -1, 0, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B, 1,
$ INFO )
CALL CHKXER( 'SGTSV ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGTSV( 0, -1, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B, 1,
$ INFO )
CALL CHKXER( 'SGTSV ', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SGTSV( 2, 0, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B, 1, INFO )
CALL CHKXER( 'SGTSV ', INFOT, NOUT, LERR, OK )
*
* SGTSVX
*
SRNAMT = 'SGTSVX'
INFOT = 1
CALL SGTSVX( '/', 'N', 0, 0, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
$ AF( 1, 1 ), AF( 1, 2 ), AF( 1, 3 ), AF( 1, 4 ),
$ IP, B, 1, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGTSVX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGTSVX( 'N', '/', 0, 0, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
$ AF( 1, 1 ), AF( 1, 2 ), AF( 1, 3 ), AF( 1, 4 ),
$ IP, B, 1, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGTSVX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGTSVX( 'N', 'N', -1, 0, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
$ AF( 1, 1 ), AF( 1, 2 ), AF( 1, 3 ), AF( 1, 4 ),
$ IP, B, 1, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGTSVX', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGTSVX( 'N', 'N', 0, -1, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
$ AF( 1, 1 ), AF( 1, 2 ), AF( 1, 3 ), AF( 1, 4 ),
$ IP, B, 1, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGTSVX', INFOT, NOUT, LERR, OK )
INFOT = 14
CALL SGTSVX( 'N', 'N', 2, 0, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
$ AF( 1, 1 ), AF( 1, 2 ), AF( 1, 3 ), AF( 1, 4 ),
$ IP, B, 1, X, 2, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGTSVX', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL SGTSVX( 'N', 'N', 2, 0, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
$ AF( 1, 1 ), AF( 1, 2 ), AF( 1, 3 ), AF( 1, 4 ),
$ IP, B, 2, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SGTSVX', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'PO' ) ) THEN
*
* SPOSV
*
SRNAMT = 'SPOSV '
INFOT = 1
CALL SPOSV( '/', 0, 0, A, 1, B, 1, INFO )
CALL CHKXER( 'SPOSV ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SPOSV( 'U', -1, 0, A, 1, B, 1, INFO )
CALL CHKXER( 'SPOSV ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SPOSV( 'U', 0, -1, A, 1, B, 1, INFO )
CALL CHKXER( 'SPOSV ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SPOSV( 'U', 2, 0, A, 1, B, 2, INFO )
CALL CHKXER( 'SPOSV ', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SPOSV( 'U', 2, 0, A, 2, B, 1, INFO )
CALL CHKXER( 'SPOSV ', INFOT, NOUT, LERR, OK )
*
* SPOSVX
*
SRNAMT = 'SPOSVX'
INFOT = 1
CALL SPOSVX( '/', 'U', 0, 0, A, 1, AF, 1, EQ, C, B, 1, X, 1,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SPOSVX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SPOSVX( 'N', '/', 0, 0, A, 1, AF, 1, EQ, C, B, 1, X, 1,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SPOSVX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SPOSVX( 'N', 'U', -1, 0, A, 1, AF, 1, EQ, C, B, 1, X, 1,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SPOSVX', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SPOSVX( 'N', 'U', 0, -1, A, 1, AF, 1, EQ, C, B, 1, X, 1,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SPOSVX', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SPOSVX( 'N', 'U', 2, 0, A, 1, AF, 2, EQ, C, B, 2, X, 2,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SPOSVX', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SPOSVX( 'N', 'U', 2, 0, A, 2, AF, 1, EQ, C, B, 2, X, 2,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SPOSVX', INFOT, NOUT, LERR, OK )
INFOT = 9
EQ = '/'
CALL SPOSVX( 'F', 'U', 0, 0, A, 1, AF, 1, EQ, C, B, 1, X, 1,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SPOSVX', INFOT, NOUT, LERR, OK )
INFOT = 10
EQ = 'Y'
CALL SPOSVX( 'F', 'U', 1, 0, A, 1, AF, 1, EQ, C, B, 1, X, 1,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SPOSVX', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SPOSVX( 'N', 'U', 2, 0, A, 2, AF, 2, EQ, C, B, 1, X, 2,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SPOSVX', INFOT, NOUT, LERR, OK )
INFOT = 14
CALL SPOSVX( 'N', 'U', 2, 0, A, 2, AF, 2, EQ, C, B, 2, X, 1,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SPOSVX', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'PP' ) ) THEN
*
* SPPSV
*
SRNAMT = 'SPPSV '
INFOT = 1
CALL SPPSV( '/', 0, 0, A, B, 1, INFO )
CALL CHKXER( 'SPPSV ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SPPSV( 'U', -1, 0, A, B, 1, INFO )
CALL CHKXER( 'SPPSV ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SPPSV( 'U', 0, -1, A, B, 1, INFO )
CALL CHKXER( 'SPPSV ', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SPPSV( 'U', 2, 0, A, B, 1, INFO )
CALL CHKXER( 'SPPSV ', INFOT, NOUT, LERR, OK )
*
* SPPSVX
*
SRNAMT = 'SPPSVX'
INFOT = 1
CALL SPPSVX( '/', 'U', 0, 0, A, AF, EQ, C, B, 1, X, 1, RCOND,
$ R1, R2, W, IW, INFO )
CALL CHKXER( 'SPPSVX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SPPSVX( 'N', '/', 0, 0, A, AF, EQ, C, B, 1, X, 1, RCOND,
$ R1, R2, W, IW, INFO )
CALL CHKXER( 'SPPSVX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SPPSVX( 'N', 'U', -1, 0, A, AF, EQ, C, B, 1, X, 1, RCOND,
$ R1, R2, W, IW, INFO )
CALL CHKXER( 'SPPSVX', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SPPSVX( 'N', 'U', 0, -1, A, AF, EQ, C, B, 1, X, 1, RCOND,
$ R1, R2, W, IW, INFO )
CALL CHKXER( 'SPPSVX', INFOT, NOUT, LERR, OK )
INFOT = 7
EQ = '/'
CALL SPPSVX( 'F', 'U', 0, 0, A, AF, EQ, C, B, 1, X, 1, RCOND,
$ R1, R2, W, IW, INFO )
CALL CHKXER( 'SPPSVX', INFOT, NOUT, LERR, OK )
INFOT = 8
EQ = 'Y'
CALL SPPSVX( 'F', 'U', 1, 0, A, AF, EQ, C, B, 1, X, 1, RCOND,
$ R1, R2, W, IW, INFO )
CALL CHKXER( 'SPPSVX', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SPPSVX( 'N', 'U', 2, 0, A, AF, EQ, C, B, 1, X, 2, RCOND,
$ R1, R2, W, IW, INFO )
CALL CHKXER( 'SPPSVX', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SPPSVX( 'N', 'U', 2, 0, A, AF, EQ, C, B, 2, X, 1, RCOND,
$ R1, R2, W, IW, INFO )
CALL CHKXER( 'SPPSVX', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN
*
* SPBSV
*
SRNAMT = 'SPBSV '
INFOT = 1
CALL SPBSV( '/', 0, 0, 0, A, 1, B, 1, INFO )
CALL CHKXER( 'SPBSV ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SPBSV( 'U', -1, 0, 0, A, 1, B, 1, INFO )
CALL CHKXER( 'SPBSV ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SPBSV( 'U', 1, -1, 0, A, 1, B, 1, INFO )
CALL CHKXER( 'SPBSV ', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SPBSV( 'U', 0, 0, -1, A, 1, B, 1, INFO )
CALL CHKXER( 'SPBSV ', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SPBSV( 'U', 1, 1, 0, A, 1, B, 2, INFO )
CALL CHKXER( 'SPBSV ', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SPBSV( 'U', 2, 0, 0, A, 1, B, 1, INFO )
CALL CHKXER( 'SPBSV ', INFOT, NOUT, LERR, OK )
*
* SPBSVX
*
SRNAMT = 'SPBSVX'
INFOT = 1
CALL SPBSVX( '/', 'U', 0, 0, 0, A, 1, AF, 1, EQ, C, B, 1, X, 1,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SPBSVX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SPBSVX( 'N', '/', 0, 0, 0, A, 1, AF, 1, EQ, C, B, 1, X, 1,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SPBSVX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SPBSVX( 'N', 'U', -1, 0, 0, A, 1, AF, 1, EQ, C, B, 1, X,
$ 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SPBSVX', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SPBSVX( 'N', 'U', 1, -1, 0, A, 1, AF, 1, EQ, C, B, 1, X,
$ 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SPBSVX', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SPBSVX( 'N', 'U', 0, 0, -1, A, 1, AF, 1, EQ, C, B, 1, X,
$ 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SPBSVX', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SPBSVX( 'N', 'U', 1, 1, 0, A, 1, AF, 2, EQ, C, B, 2, X, 2,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SPBSVX', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SPBSVX( 'N', 'U', 1, 1, 0, A, 2, AF, 1, EQ, C, B, 2, X, 2,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SPBSVX', INFOT, NOUT, LERR, OK )
INFOT = 10
EQ = '/'
CALL SPBSVX( 'F', 'U', 0, 0, 0, A, 1, AF, 1, EQ, C, B, 1, X, 1,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SPBSVX', INFOT, NOUT, LERR, OK )
INFOT = 11
EQ = 'Y'
CALL SPBSVX( 'F', 'U', 1, 0, 0, A, 1, AF, 1, EQ, C, B, 1, X, 1,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SPBSVX', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL SPBSVX( 'N', 'U', 2, 0, 0, A, 1, AF, 1, EQ, C, B, 1, X, 2,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SPBSVX', INFOT, NOUT, LERR, OK )
INFOT = 15
CALL SPBSVX( 'N', 'U', 2, 0, 0, A, 1, AF, 1, EQ, C, B, 2, X, 1,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'SPBSVX', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'PT' ) ) THEN
*
* SPTSV
*
SRNAMT = 'SPTSV '
INFOT = 1
CALL SPTSV( -1, 0, A( 1, 1 ), A( 1, 2 ), B, 1, INFO )
CALL CHKXER( 'SPTSV ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SPTSV( 0, -1, A( 1, 1 ), A( 1, 2 ), B, 1, INFO )
CALL CHKXER( 'SPTSV ', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SPTSV( 2, 0, A( 1, 1 ), A( 1, 2 ), B, 1, INFO )
CALL CHKXER( 'SPTSV ', INFOT, NOUT, LERR, OK )
*
* SPTSVX
*
SRNAMT = 'SPTSVX'
INFOT = 1
CALL SPTSVX( '/', 0, 0, A( 1, 1 ), A( 1, 2 ), AF( 1, 1 ),
$ AF( 1, 2 ), B, 1, X, 1, RCOND, R1, R2, W, INFO )
CALL CHKXER( 'SPTSVX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SPTSVX( 'N', -1, 0, A( 1, 1 ), A( 1, 2 ), AF( 1, 1 ),
$ AF( 1, 2 ), B, 1, X, 1, RCOND, R1, R2, W, INFO )
CALL CHKXER( 'SPTSVX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SPTSVX( 'N', 0, -1, A( 1, 1 ), A( 1, 2 ), AF( 1, 1 ),
$ AF( 1, 2 ), B, 1, X, 1, RCOND, R1, R2, W, INFO )
CALL CHKXER( 'SPTSVX', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SPTSVX( 'N', 2, 0, A( 1, 1 ), A( 1, 2 ), AF( 1, 1 ),
$ AF( 1, 2 ), B, 1, X, 2, RCOND, R1, R2, W, INFO )
CALL CHKXER( 'SPTSVX', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL SPTSVX( 'N', 2, 0, A( 1, 1 ), A( 1, 2 ), AF( 1, 1 ),
$ AF( 1, 2 ), B, 2, X, 1, RCOND, R1, R2, W, INFO )
CALL CHKXER( 'SPTSVX', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SY' ) ) THEN
*
* SSYSV
*
SRNAMT = 'SSYSV '
INFOT = 1
CALL SSYSV( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'SSYSV ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSYSV( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'SSYSV ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSYSV( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'SSYSV ', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SSYSV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'SSYSV ', INFOT, NOUT, LERR, OK )
*
* SSYSVX
*
SRNAMT = 'SSYSVX'
INFOT = 1
CALL SSYSVX( '/', 'U', 0, 0, A, 1, AF, 1, IP, B, 1, X, 1,
$ RCOND, R1, R2, W, 1, IW, INFO )
CALL CHKXER( 'SSYSVX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSYSVX( 'N', '/', 0, 0, A, 1, AF, 1, IP, B, 1, X, 1,
$ RCOND, R1, R2, W, 1, IW, INFO )
CALL CHKXER( 'SSYSVX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSYSVX( 'N', 'U', -1, 0, A, 1, AF, 1, IP, B, 1, X, 1,
$ RCOND, R1, R2, W, 1, IW, INFO )
CALL CHKXER( 'SSYSVX', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SSYSVX( 'N', 'U', 0, -1, A, 1, AF, 1, IP, B, 1, X, 1,
$ RCOND, R1, R2, W, 1, IW, INFO )
CALL CHKXER( 'SSYSVX', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SSYSVX( 'N', 'U', 2, 0, A, 1, AF, 2, IP, B, 2, X, 2,
$ RCOND, R1, R2, W, 4, IW, INFO )
CALL CHKXER( 'SSYSVX', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SSYSVX( 'N', 'U', 2, 0, A, 2, AF, 1, IP, B, 2, X, 2,
$ RCOND, R1, R2, W, 4, IW, INFO )
CALL CHKXER( 'SSYSVX', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL SSYSVX( 'N', 'U', 2, 0, A, 2, AF, 2, IP, B, 1, X, 2,
$ RCOND, R1, R2, W, 4, IW, INFO )
CALL CHKXER( 'SSYSVX', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL SSYSVX( 'N', 'U', 2, 0, A, 2, AF, 2, IP, B, 2, X, 1,
$ RCOND, R1, R2, W, 4, IW, INFO )
CALL CHKXER( 'SSYSVX', INFOT, NOUT, LERR, OK )
INFOT = 18
CALL SSYSVX( 'N', 'U', 2, 0, A, 2, AF, 2, IP, B, 2, X, 2,
$ RCOND, R1, R2, W, 3, IW, INFO )
CALL CHKXER( 'SSYSVX', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
* SSPSV
*
SRNAMT = 'SSPSV '
INFOT = 1
CALL SSPSV( '/', 0, 0, A, IP, B, 1, INFO )
CALL CHKXER( 'SSPSV ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSPSV( 'U', -1, 0, A, IP, B, 1, INFO )
CALL CHKXER( 'SSPSV ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSPSV( 'U', 0, -1, A, IP, B, 1, INFO )
CALL CHKXER( 'SSPSV ', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SSPSV( 'U', 2, 0, A, IP, B, 1, INFO )
CALL CHKXER( 'SSPSV ', INFOT, NOUT, LERR, OK )
*
* SSPSVX
*
SRNAMT = 'SSPSVX'
INFOT = 1
CALL SSPSVX( '/', 'U', 0, 0, A, AF, IP, B, 1, X, 1, RCOND, R1,
$ R2, W, IW, INFO )
CALL CHKXER( 'SSPSVX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSPSVX( 'N', '/', 0, 0, A, AF, IP, B, 1, X, 1, RCOND, R1,
$ R2, W, IW, INFO )
CALL CHKXER( 'SSPSVX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSPSVX( 'N', 'U', -1, 0, A, AF, IP, B, 1, X, 1, RCOND, R1,
$ R2, W, IW, INFO )
CALL CHKXER( 'SSPSVX', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SSPSVX( 'N', 'U', 0, -1, A, AF, IP, B, 1, X, 1, RCOND, R1,
$ R2, W, IW, INFO )
CALL CHKXER( 'SSPSVX', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SSPSVX( 'N', 'U', 2, 0, A, AF, IP, B, 1, X, 2, RCOND, R1,
$ R2, W, IW, INFO )
CALL CHKXER( 'SSPSVX', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL SSPSVX( 'N', 'U', 2, 0, A, AF, IP, B, 2, X, 1, RCOND, R1,
$ R2, W, IW, INFO )
CALL CHKXER( 'SSPSVX', INFOT, NOUT, LERR, OK )
END IF
*
* Print a summary line.
*
IF( OK ) THEN
WRITE( NOUT, FMT = 9999 )PATH
ELSE
WRITE( NOUT, FMT = 9998 )PATH
END IF
*
9999 FORMAT( 1X, A3, ' drivers passed the tests of the error exits' )
9998 FORMAT( ' *** ', A3, ' drivers failed the tests of the error ',
$ 'exits ***' )
*
RETURN
*
* End of SERRVX
*
END
SUBROUTINE SGBT01( M, N, KL, KU, A, LDA, AFAC, LDAFAC, IPIV, WORK,
$ RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KL, KU, LDA, LDAFAC, M, N
REAL RESID
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
REAL A( LDA, * ), AFAC( LDAFAC, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SGBT01 reconstructs a band matrix A from its L*U factorization and
* computes the residual:
* norm(L*U - A) / ( N * norm(A) * EPS ),
* where EPS is the machine epsilon.
*
* The expression L*U - A is computed one column at a time, so A and
* AFAC are not modified.
*
* 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.
*
* KL (input) INTEGER
* The number of subdiagonals within the band of A. KL >= 0.
*
* KU (input) INTEGER
* The number of superdiagonals within the band of A. KU >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* The original matrix A in band storage, stored in rows 1 to
* KL+KU+1.
*
* LDA (input) INTEGER.
* The leading dimension of the array A. LDA >= max(1,KL+KU+1).
*
* AFAC (input) REAL array, dimension (LDAFAC,N)
* The factored form of the matrix A. AFAC contains the banded
* factors L and U from the L*U factorization, as computed by
* SGBTRF. U is stored as an upper triangular band matrix with
* KL+KU superdiagonals in rows 1 to KL+KU+1, and the
* multipliers used during the factorization are stored in rows
* KL+KU+2 to 2*KL+KU+1. See SGBTRF for further details.
*
* LDAFAC (input) INTEGER
* The leading dimension of the array AFAC.
* LDAFAC >= max(1,2*KL*KU+1).
*
* IPIV (input) INTEGER array, dimension (min(M,N))
* The pivot indices from SGBTRF.
*
* WORK (workspace) REAL array, dimension (2*KL+KU+1)
*
* RESID (output) REAL
* norm(L*U - A) / ( N * norm(A) * EPS )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, I1, I2, IL, IP, IW, J, JL, JU, JUA, KD, LENJ
REAL ANORM, EPS, T
* ..
* .. External Functions ..
REAL SASUM, SLAMCH
EXTERNAL SASUM, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Executable Statements ..
*
* Quick exit if M = 0 or N = 0.
*
RESID = ZERO
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
* Determine EPS and the norm of A.
*
EPS = SLAMCH( 'Epsilon' )
KD = KU + 1
ANORM = ZERO
DO 10 J = 1, N
I1 = MAX( KD+1-J, 1 )
I2 = MIN( KD+M-J, KL+KD )
IF( I2.GE.I1 )
$ ANORM = MAX( ANORM, SASUM( I2-I1+1, A( I1, J ), 1 ) )
10 CONTINUE
*
* Compute one column at a time of L*U - A.
*
KD = KL + KU + 1
DO 40 J = 1, N
*
* Copy the J-th column of U to WORK.
*
JU = MIN( KL+KU, J-1 )
JL = MIN( KL, M-J )
LENJ = MIN( M, J ) - J + JU + 1
IF( LENJ.GT.0 ) THEN
CALL SCOPY( LENJ, AFAC( KD-JU, J ), 1, WORK, 1 )
DO 20 I = LENJ + 1, JU + JL + 1
WORK( I ) = ZERO
20 CONTINUE
*
* Multiply by the unit lower triangular matrix L. Note that L
* is stored as a product of transformations and permutations.
*
DO 30 I = MIN( M-1, J ), J - JU, -1
IL = MIN( KL, M-I )
IF( IL.GT.0 ) THEN
IW = I - J + JU + 1
T = WORK( IW )
CALL SAXPY( IL, T, AFAC( KD+1, I ), 1, WORK( IW+1 ),
$ 1 )
IP = IPIV( I )
IF( I.NE.IP ) THEN
IP = IP - J + JU + 1
WORK( IW ) = WORK( IP )
WORK( IP ) = T
END IF
END IF
30 CONTINUE
*
* Subtract the corresponding column of A.
*
JUA = MIN( JU, KU )
IF( JUA+JL+1.GT.0 )
$ CALL SAXPY( JUA+JL+1, -ONE, A( KU+1-JUA, J ), 1,
$ WORK( JU+1-JUA ), 1 )
*
* Compute the 1-norm of the column.
*
RESID = MAX( RESID, SASUM( JU+JL+1, WORK, 1 ) )
END IF
40 CONTINUE
*
* Compute norm( L*U - A ) / ( N * norm(A) * EPS )
*
IF( ANORM.LE.ZERO ) THEN
IF( RESID.NE.ZERO )
$ RESID = ONE / EPS
ELSE
RESID = ( ( RESID / REAL( N ) ) / ANORM ) / EPS
END IF
*
RETURN
*
* End of SGBT01
*
END
SUBROUTINE SGBT02( TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B,
$ LDB, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER KL, KU, LDA, LDB, LDX, M, N, NRHS
REAL RESID
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* SGBT02 computes the residual for a solution of a banded system of
* equations A*x = b or A'*x = b:
* RESID = norm( B - A*X ) / ( norm(A) * norm(X) * EPS).
* where EPS is the machine precision.
*
* Arguments
* =========
*
* TRANS (input) CHARACTER*1
* Specifies the form of the system of equations:
* = 'N': A *x = b
* = 'T': A'*x = b, where A' is the transpose of A
* = 'C': A'*x = b, where A' is the transpose of A
*
* 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.
*
* KL (input) INTEGER
* The number of subdiagonals within the band of A. KL >= 0.
*
* KU (input) INTEGER
* The number of superdiagonals within the band of A. KU >= 0.
*
* NRHS (input) INTEGER
* The number of columns of B. NRHS >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The original matrix A in band storage, stored in rows 1 to
* KL+KU+1.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,KL+KU+1).
*
* X (input) REAL array, dimension (LDX,NRHS)
* The computed solution vectors for the system of linear
* equations.
*
* LDX (input) INTEGER
* The leading dimension of the array X. If TRANS = 'N',
* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M).
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the right hand side vectors for the system of
* linear equations.
* On exit, B is overwritten with the difference B - A*X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. IF TRANS = 'N',
* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N).
*
* RESID (output) REAL
* The maximum over the number of right hand sides of
* norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I1, I2, J, KD, N1
REAL ANORM, BNORM, EPS, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SASUM, SLAMCH
EXTERNAL LSAME, SASUM, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SGBMV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick return if N = 0 pr NRHS = 0
*
IF( M.LE.0 .OR. N.LE.0 .OR. NRHS.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0.
*
EPS = SLAMCH( 'Epsilon' )
KD = KU + 1
ANORM = ZERO
DO 10 J = 1, N
I1 = MAX( KD+1-J, 1 )
I2 = MIN( KD+M-J, KL+KD )
ANORM = MAX( ANORM, SASUM( I2-I1+1, A( I1, J ), 1 ) )
10 CONTINUE
IF( ANORM.LE.ZERO ) THEN
RESID = ONE / EPS
RETURN
END IF
*
IF( LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) ) THEN
N1 = N
ELSE
N1 = M
END IF
*
* Compute B - A*X (or B - A'*X )
*
DO 20 J = 1, NRHS
CALL SGBMV( TRANS, M, N, KL, KU, -ONE, A, LDA, X( 1, J ), 1,
$ ONE, B( 1, J ), 1 )
20 CONTINUE
*
* Compute the maximum over the number of right hand sides of
* norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
*
RESID = ZERO
DO 30 J = 1, NRHS
BNORM = SASUM( N1, B( 1, J ), 1 )
XNORM = SASUM( N1, X( 1, J ), 1 )
IF( XNORM.LE.ZERO ) THEN
RESID = ONE / EPS
ELSE
RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) / EPS )
END IF
30 CONTINUE
*
RETURN
*
* End of SGBT02
*
END
SUBROUTINE SGBT05( TRANS, N, KL, KU, NRHS, AB, LDAB, B, LDB, X,
$ LDX, XACT, LDXACT, FERR, BERR, RESLTS )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER KL, KU, LDAB, LDB, LDX, LDXACT, N, NRHS
* ..
* .. Array Arguments ..
REAL AB( LDAB, * ), B( LDB, * ), BERR( * ),
$ FERR( * ), RESLTS( * ), X( LDX, * ),
$ XACT( LDXACT, * )
* ..
*
* Purpose
* =======
*
* SGBT05 tests the error bounds from iterative refinement for the
* computed solution to a system of equations op(A)*X = B, where A is a
* general band matrix of order n with kl subdiagonals and ku
* superdiagonals and op(A) = A or A**T, depending on TRANS.
*
* RESLTS(1) = test of the error bound
* = norm(X - XACT) / ( norm(X) * FERR )
*
* A large value is returned if this ratio is not less than one.
*
* RESLTS(2) = residual from the iterative refinement routine
* = the maximum of BERR / ( NZ*EPS + (*) ), where
* (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i )
* and NZ = max. number of nonzeros in any row of A, plus 1
*
* 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**H * X = B (Conjugate transpose = Transpose)
*
* N (input) INTEGER
* The number of rows of the matrices X, B, and XACT, and the
* order of the matrix A. N >= 0.
*
* KL (input) INTEGER
* The number of subdiagonals within the band of A. KL >= 0.
*
* KU (input) INTEGER
* The number of superdiagonals within the band of A. KU >= 0.
*
* NRHS (input) INTEGER
* The number of columns of the matrices X, B, and XACT.
* NRHS >= 0.
*
* AB (input) REAL array, dimension (LDAB,N)
* The original band matrix A, stored in rows 1 to KL+KU+1.
* The j-th column of A is stored in the j-th column of the
* array AB as follows:
* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KL+KU+1.
*
* B (input) REAL array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input) REAL array, dimension (LDX,NRHS)
* The computed solution vectors. Each vector is stored as a
* column of the matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* XACT (input) REAL array, dimension (LDX,NRHS)
* The exact solution vectors. Each vector is stored as a
* column of the matrix XACT.
*
* LDXACT (input) INTEGER
* The leading dimension of the array XACT. LDXACT >= max(1,N).
*
* FERR (input) REAL array, dimension (NRHS)
* The estimated forward error bounds for each solution vector
* X. If XTRUE is the true solution, FERR bounds the magnitude
* of the largest entry in (X - XTRUE) divided by the magnitude
* of the largest entry in X.
*
* BERR (input) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector (i.e., the smallest relative change in any entry of A
* or B that makes X an exact solution).
*
* RESLTS (output) REAL array, dimension (2)
* The maximum over the NRHS solution vectors of the ratios:
* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
* RESLTS(2) = BERR / ( NZ*EPS + (*) )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN
INTEGER I, IMAX, J, K, NZ
REAL AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SLAMCH
EXTERNAL LSAME, ISAMAX, SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0.
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESLTS( 1 ) = ZERO
RESLTS( 2 ) = ZERO
RETURN
END IF
*
EPS = SLAMCH( 'Epsilon' )
UNFL = SLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
NOTRAN = LSAME( TRANS, 'N' )
NZ = MIN( KL+KU+2, N+1 )
*
* Test 1: Compute the maximum of
* norm(X - XACT) / ( norm(X) * FERR )
* over all the vectors X and XACT using the infinity-norm.
*
ERRBND = ZERO
DO 30 J = 1, NRHS
IMAX = ISAMAX( N, X( 1, J ), 1 )
XNORM = MAX( ABS( X( IMAX, J ) ), UNFL )
DIFF = ZERO
DO 10 I = 1, N
DIFF = MAX( DIFF, ABS( X( I, J )-XACT( I, J ) ) )
10 CONTINUE
*
IF( XNORM.GT.ONE ) THEN
GO TO 20
ELSE IF( DIFF.LE.OVFL*XNORM ) THEN
GO TO 20
ELSE
ERRBND = ONE / EPS
GO TO 30
END IF
*
20 CONTINUE
IF( DIFF / XNORM.LE.FERR( J ) ) THEN
ERRBND = MAX( ERRBND, ( DIFF / XNORM ) / FERR( J ) )
ELSE
ERRBND = ONE / EPS
END IF
30 CONTINUE
RESLTS( 1 ) = ERRBND
*
* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where
* (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i )
*
DO 70 K = 1, NRHS
DO 60 I = 1, N
TMP = ABS( B( I, K ) )
IF( NOTRAN ) THEN
DO 40 J = MAX( I-KL, 1 ), MIN( I+KU, N )
TMP = TMP + ABS( AB( KU+1+I-J, J ) )*ABS( X( J, K ) )
40 CONTINUE
ELSE
DO 50 J = MAX( I-KU, 1 ), MIN( I+KL, N )
TMP = TMP + ABS( AB( KU+1+J-I, I ) )*ABS( X( J, K ) )
50 CONTINUE
END IF
IF( I.EQ.1 ) THEN
AXBI = TMP
ELSE
AXBI = MIN( AXBI, TMP )
END IF
60 CONTINUE
TMP = BERR( K ) / ( NZ*EPS+NZ*UNFL / MAX( AXBI, NZ*UNFL ) )
IF( K.EQ.1 ) THEN
RESLTS( 2 ) = TMP
ELSE
RESLTS( 2 ) = MAX( RESLTS( 2 ), TMP )
END IF
70 CONTINUE
*
RETURN
*
* End of SGBT05
*
END
SUBROUTINE SGELQS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* Compute a minimum-norm solution
* min || A*X - B ||
* using the LQ factorization
* A = L*Q
* computed by SGELQF.
*
* 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 >= M >= 0.
*
* NRHS (input) INTEGER
* The number of columns of B. NRHS >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* Details of the LQ factorization of the original matrix A as
* returned by SGELQF.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= M.
*
* TAU (input) REAL array, dimension (M)
* Details of the orthogonal matrix Q.
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the m-by-nrhs right hand side matrix B.
* On exit, the n-by-nrhs solution matrix X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= N.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of the array WORK. LWORK must be at least NRHS,
* and should be at least NRHS*NB, where NB is the block size
* for this environment.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. External Subroutines ..
EXTERNAL SLASET, SORMLQ, STRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. M.GT.N ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LWORK.LT.1 .OR. LWORK.LT.NRHS .AND. M.GT.0 .AND. N.GT.0 )
$ THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGELQS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 .OR. M.EQ.0 )
$ RETURN
*
* Solve L*X = B(1:m,:)
*
CALL STRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', M, NRHS,
$ ONE, A, LDA, B, LDB )
*
* Set B(m+1:n,:) to zero
*
IF( M.LT.N )
$ CALL SLASET( 'Full', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB )
*
* B := Q' * B
*
CALL SORMLQ( 'Left', 'Transpose', N, NRHS, M, A, LDA, TAU, B, LDB,
$ WORK, LWORK, INFO )
*
RETURN
*
* End of SGELQS
*
END
SUBROUTINE SGEQLS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* Solve the least squares problem
* min || A*X - B ||
* using the QL factorization
* A = Q*L
* computed by SGEQLF.
*
* 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. M >= N >= 0.
*
* NRHS (input) INTEGER
* The number of columns of B. NRHS >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* Details of the QL factorization of the original matrix A as
* returned by SGEQLF.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= M.
*
* TAU (input) REAL array, dimension (N)
* Details of the orthogonal matrix Q.
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the m-by-nrhs right hand side matrix B.
* On exit, the n-by-nrhs solution matrix X, stored in rows
* m-n+1:m.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= M.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of the array WORK. LWORK must be at least NRHS,
* and should be at least NRHS*NB, where NB is the block size
* for this environment.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. External Subroutines ..
EXTERNAL SORMQL, STRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
INFO = -8
ELSE IF( LWORK.LT.1 .OR. LWORK.LT.NRHS .AND. M.GT.0 .AND. N.GT.0 )
$ THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGEQLS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 .OR. M.EQ.0 )
$ RETURN
*
* B := Q' * B
*
CALL SORMQL( 'Left', 'Transpose', M, NRHS, N, A, LDA, TAU, B, LDB,
$ WORK, LWORK, INFO )
*
* Solve L*X = B(m-n+1:m,:)
*
CALL STRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', N, NRHS,
$ ONE, A( M-N+1, 1 ), LDA, B( M-N+1, 1 ), LDB )
*
RETURN
*
* End of SGEQLS
*
END
SUBROUTINE SGEQRS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* Solve the least squares problem
* min || A*X - B ||
* using the QR factorization
* A = Q*R
* computed by SGEQRF.
*
* 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. M >= N >= 0.
*
* NRHS (input) INTEGER
* The number of columns of B. NRHS >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* Details of the QR factorization of the original matrix A as
* returned by SGEQRF.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= M.
*
* TAU (input) REAL array, dimension (N)
* Details of the orthogonal matrix Q.
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the m-by-nrhs right hand side matrix B.
* On exit, the n-by-nrhs solution matrix X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= M.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of the array WORK. LWORK must be at least NRHS,
* and should be at least NRHS*NB, where NB is the block size
* for this environment.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. External Subroutines ..
EXTERNAL SORMQR, STRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
INFO = -8
ELSE IF( LWORK.LT.1 .OR. LWORK.LT.NRHS .AND. M.GT.0 .AND. N.GT.0 )
$ THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGEQRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 .OR. M.EQ.0 )
$ RETURN
*
* B := Q' * B
*
CALL SORMQR( 'Left', 'Transpose', M, NRHS, N, A, LDA, TAU, B, LDB,
$ WORK, LWORK, INFO )
*
* Solve R*X = B(1:n,:)
*
CALL STRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, NRHS,
$ ONE, A, LDA, B, LDB )
*
RETURN
*
* End of SGEQRS
*
END
SUBROUTINE SGERQS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* Compute a minimum-norm solution
* min || A*X - B ||
* using the RQ factorization
* A = R*Q
* computed by SGERQF.
*
* 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 >= M >= 0.
*
* NRHS (input) INTEGER
* The number of columns of B. NRHS >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* Details of the RQ factorization of the original matrix A as
* returned by SGERQF.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= M.
*
* TAU (input) REAL array, dimension (M)
* Details of the orthogonal matrix Q.
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the right hand side vectors for the linear system.
* On exit, the solution vectors X. Each solution vector
* is contained in rows 1:N of a column of B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of the array WORK. LWORK must be at least NRHS,
* and should be at least NRHS*NB, where NB is the block size
* for this environment.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. External Subroutines ..
EXTERNAL SLASET, SORMRQ, STRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. M.GT.N ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LWORK.LT.1 .OR. LWORK.LT.NRHS .AND. M.GT.0 .AND. N.GT.0 )
$ THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGERQS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 .OR. M.EQ.0 )
$ RETURN
*
* Solve R*X = B(n-m+1:n,:)
*
CALL STRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', M, NRHS,
$ ONE, A( 1, N-M+1 ), LDA, B( N-M+1, 1 ), LDB )
*
* Set B(1:n-m,:) to zero
*
CALL SLASET( 'Full', N-M, NRHS, ZERO, ZERO, B, LDB )
*
* B := Q' * B
*
CALL SORMRQ( 'Left', 'Transpose', N, NRHS, M, A, LDA, TAU, B, LDB,
$ WORK, LWORK, INFO )
*
RETURN
*
* End of SGERQS
*
END
SUBROUTINE SGET01( M, N, A, LDA, AFAC, LDAFAC, IPIV, RWORK,
$ RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDAFAC, M, N
REAL RESID
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
REAL A( LDA, * ), AFAC( LDAFAC, * ), RWORK( * )
* ..
*
* Purpose
* =======
*
* SGET01 reconstructs a matrix A from its L*U factorization and
* computes the residual
* norm(L*U - A) / ( N * norm(A) * EPS ),
* where EPS is the machine epsilon.
*
* 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) REAL array, dimension (LDA,N)
* The original M x N matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* AFAC (input/output) REAL array, dimension (LDAFAC,N)
* The factored form of the matrix A. AFAC contains the factors
* L and U from the L*U factorization as computed by SGETRF.
* Overwritten with the reconstructed matrix, and then with the
* difference L*U - A.
*
* LDAFAC (input) INTEGER
* The leading dimension of the array AFAC. LDAFAC >= max(1,M).
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices from SGETRF.
*
* RWORK (workspace) REAL array, dimension (M)
*
* RESID (output) REAL
* norm(L*U - A) / ( N * norm(A) * EPS )
*
* =====================================================================
*
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, K
REAL ANORM, EPS, T
* ..
* .. External Functions ..
REAL SDOT, SLAMCH, SLANGE
EXTERNAL SDOT, SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SGEMV, SLASWP, SSCAL, STRMV
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN, REAL
* ..
* .. Executable Statements ..
*
* Quick exit if M = 0 or N = 0.
*
IF( M.LE.0 .OR. N.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Determine EPS and the norm of A.
*
EPS = SLAMCH( 'Epsilon' )
ANORM = SLANGE( '1', M, N, A, LDA, RWORK )
*
* Compute the product L*U and overwrite AFAC with the result.
* A column at a time of the product is obtained, starting with
* column N.
*
DO 10 K = N, 1, -1
IF( K.GT.M ) THEN
CALL STRMV( 'Lower', 'No transpose', 'Unit', M, AFAC,
$ LDAFAC, AFAC( 1, K ), 1 )
ELSE
*
* Compute elements (K+1:M,K)
*
T = AFAC( K, K )
IF( K+1.LE.M ) THEN
CALL SSCAL( M-K, T, AFAC( K+1, K ), 1 )
CALL SGEMV( 'No transpose', M-K, K-1, ONE,
$ AFAC( K+1, 1 ), LDAFAC, AFAC( 1, K ), 1, ONE,
$ AFAC( K+1, K ), 1 )
END IF
*
* Compute the (K,K) element
*
AFAC( K, K ) = T + SDOT( K-1, AFAC( K, 1 ), LDAFAC,
$ AFAC( 1, K ), 1 )
*
* Compute elements (1:K-1,K)
*
CALL STRMV( 'Lower', 'No transpose', 'Unit', K-1, AFAC,
$ LDAFAC, AFAC( 1, K ), 1 )
END IF
10 CONTINUE
CALL SLASWP( N, AFAC, LDAFAC, 1, MIN( M, N ), IPIV, -1 )
*
* Compute the difference L*U - A and store in AFAC.
*
DO 30 J = 1, N
DO 20 I = 1, M
AFAC( I, J ) = AFAC( I, J ) - A( I, J )
20 CONTINUE
30 CONTINUE
*
* Compute norm( L*U - A ) / ( N * norm(A) * EPS )
*
RESID = SLANGE( '1', M, N, AFAC, LDAFAC, RWORK )
*
IF( ANORM.LE.ZERO ) THEN
IF( RESID.NE.ZERO )
$ RESID = ONE / EPS
ELSE
RESID = ( ( RESID / REAL( N ) ) / ANORM ) / EPS
END IF
*
RETURN
*
* End of SGET01
*
END
SUBROUTINE SGET02( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB,
$ RWORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER LDA, LDB, LDX, M, N, NRHS
REAL RESID
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), RWORK( * ),
$ X( LDX, * )
* ..
*
* Purpose
* =======
*
* SGET02 computes the residual for a solution of a system of linear
* equations A*x = b or A'*x = b:
* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ),
* where EPS is the machine epsilon.
*
* Arguments
* =========
*
* TRANS (input) CHARACTER*1
* Specifies the form of the system of equations:
* = 'N': A *x = b
* = 'T': A'*x = b, where A' is the transpose of A
* = 'C': A'*x = b, where A' is the transpose of A
*
* 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.
*
* NRHS (input) INTEGER
* The number of columns of B, the matrix of right hand sides.
* NRHS >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The original M x N matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* X (input) REAL array, dimension (LDX,NRHS)
* The computed solution vectors for the system of linear
* equations.
*
* LDX (input) INTEGER
* The leading dimension of the array X. If TRANS = 'N',
* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M).
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the right hand side vectors for the system of
* linear equations.
* On exit, B is overwritten with the difference B - A*X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. IF TRANS = 'N',
* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N).
*
* RWORK (workspace) REAL array, dimension (M)
*
* RESID (output) REAL
* The maximum over the number of right hand sides of
* norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER J, N1, N2
REAL ANORM, BNORM, EPS, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SASUM, SLAMCH, SLANGE
EXTERNAL LSAME, SASUM, SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SGEMM
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Quick exit if M = 0 or N = 0 or NRHS = 0
*
IF( M.LE.0 .OR. N.LE.0 .OR. NRHS.EQ.0 ) THEN
RESID = ZERO
RETURN
END IF
*
IF( LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) ) THEN
N1 = N
N2 = M
ELSE
N1 = M
N2 = N
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0.
*
EPS = SLAMCH( 'Epsilon' )
ANORM = SLANGE( '1', N1, N2, A, LDA, RWORK )
IF( ANORM.LE.ZERO ) THEN
RESID = ONE / EPS
RETURN
END IF
*
* Compute B - A*X (or B - A'*X ) and store in B.
*
CALL SGEMM( TRANS, 'No transpose', N1, NRHS, N2, -ONE, A, LDA, X,
$ LDX, ONE, B, LDB )
*
* Compute the maximum over the number of right hand sides of
* norm(B - A*X) / ( norm(A) * norm(X) * EPS ) .
*
RESID = ZERO
DO 10 J = 1, NRHS
BNORM = SASUM( N1, B( 1, J ), 1 )
XNORM = SASUM( N2, X( 1, J ), 1 )
IF( XNORM.LE.ZERO ) THEN
RESID = ONE / EPS
ELSE
RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) / EPS )
END IF
10 CONTINUE
*
RETURN
*
* End of SGET02
*
END
SUBROUTINE SGET03( N, A, LDA, AINV, LDAINV, WORK, LDWORK, RWORK,
$ RCOND, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDAINV, LDWORK, N
REAL RCOND, RESID
* ..
* .. Array Arguments ..
REAL A( LDA, * ), AINV( LDAINV, * ), RWORK( * ),
$ WORK( LDWORK, * )
* ..
*
* Purpose
* =======
*
* SGET03 computes the residual for a general matrix times its inverse:
* norm( I - AINV*A ) / ( N * norm(A) * norm(AINV) * EPS ),
* where EPS is the machine epsilon.
*
* Arguments
* ==========
*
* N (input) INTEGER
* The number of rows and columns of the matrix A. N >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The original N x N matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* AINV (input) REAL array, dimension (LDAINV,N)
* The inverse of the matrix A.
*
* LDAINV (input) INTEGER
* The leading dimension of the array AINV. LDAINV >= max(1,N).
*
* WORK (workspace) REAL array, dimension (LDWORK,N)
*
* LDWORK (input) INTEGER
* The leading dimension of the array WORK. LDWORK >= max(1,N).
*
* RWORK (workspace) REAL array, dimension (N)
*
* RCOND (output) REAL
* The reciprocal of the condition number of A, computed as
* ( 1/norm(A) ) / norm(AINV).
*
* RESID (output) REAL
* norm(I - AINV*A) / ( N * norm(A) * norm(AINV) * EPS )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I
REAL AINVNM, ANORM, EPS
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE
EXTERNAL SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SGEMM
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0.
*
IF( N.LE.0 ) THEN
RCOND = ONE
RESID = ZERO
RETURN
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0.
*
EPS = SLAMCH( 'Epsilon' )
ANORM = SLANGE( '1', N, N, A, LDA, RWORK )
AINVNM = SLANGE( '1', N, N, AINV, LDAINV, RWORK )
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCOND = ZERO
RESID = ONE / EPS
RETURN
END IF
RCOND = ( ONE / ANORM ) / AINVNM
*
* Compute I - A * AINV
*
CALL SGEMM( 'No transpose', 'No transpose', N, N, N, -ONE,
$ AINV, LDAINV, A, LDA, ZERO, WORK, LDWORK )
DO 10 I = 1, N
WORK( I, I ) = ONE + WORK( I, I )
10 CONTINUE
*
* Compute norm(I - AINV*A) / (N * norm(A) * norm(AINV) * EPS)
*
RESID = SLANGE( '1', N, N, WORK, LDWORK, RWORK )
*
RESID = ( ( RESID*RCOND ) / EPS ) / REAL( N )
*
RETURN
*
* End of SGET03
*
END
SUBROUTINE SGET04( N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDX, LDXACT, N, NRHS
REAL RCOND, RESID
* ..
* .. Array Arguments ..
REAL X( LDX, * ), XACT( LDXACT, * )
* ..
*
* Purpose
* =======
*
* SGET04 computes the difference between a computed solution and the
* true solution to a system of linear equations.
*
* RESID = ( norm(X-XACT) * RCOND ) / ( norm(XACT) * EPS ),
* where RCOND is the reciprocal of the condition number and EPS is the
* machine epsilon.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of rows of the matrices X and XACT. N >= 0.
*
* NRHS (input) INTEGER
* The number of columns of the matrices X and XACT. NRHS >= 0.
*
* X (input) REAL array, dimension (LDX,NRHS)
* The computed solution vectors. Each vector is stored as a
* column of the matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* XACT (input) REAL array, dimension( LDX, NRHS )
* The exact solution vectors. Each vector is stored as a
* column of the matrix XACT.
*
* LDXACT (input) INTEGER
* The leading dimension of the array XACT. LDXACT >= max(1,N).
*
* RCOND (input) REAL
* The reciprocal of the condition number of the coefficient
* matrix in the system of equations.
*
* RESID (output) REAL
* The maximum over the NRHS solution vectors of
* ( norm(X-XACT) * RCOND ) / ( norm(XACT) * EPS )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, IX, J
REAL DIFFNM, EPS, XNORM
* ..
* .. External Functions ..
INTEGER ISAMAX
REAL SLAMCH
EXTERNAL ISAMAX, SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0.
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Exit with RESID = 1/EPS if RCOND is invalid.
*
EPS = SLAMCH( 'Epsilon' )
IF( RCOND.LT.ZERO ) THEN
RESID = 1.0 / EPS
RETURN
END IF
*
* Compute the maximum of
* norm(X - XACT) / ( norm(XACT) * EPS )
* over all the vectors X and XACT .
*
RESID = ZERO
DO 20 J = 1, NRHS
IX = ISAMAX( N, XACT( 1, J ), 1 )
XNORM = ABS( XACT( IX, J ) )
DIFFNM = ZERO
DO 10 I = 1, N
DIFFNM = MAX( DIFFNM, ABS( X( I, J )-XACT( I, J ) ) )
10 CONTINUE
IF( XNORM.LE.ZERO ) THEN
IF( DIFFNM.GT.ZERO )
$ RESID = 1.0 / EPS
ELSE
RESID = MAX( RESID, ( DIFFNM / XNORM )*RCOND )
END IF
20 CONTINUE
IF( RESID*EPS.LT.1.0 )
$ RESID = RESID / EPS
*
RETURN
*
* End of SGET04
*
END
REAL FUNCTION SGET06( RCOND, RCONDC )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
REAL RCOND, RCONDC
* ..
*
* Purpose
* =======
*
* SGET06 computes a test ratio to compare two values for RCOND.
*
* Arguments
* ==========
*
* RCOND (input) REAL
* The estimate of the reciprocal of the condition number of A,
* as computed by SGECON.
*
* RCONDC (input) REAL
* The reciprocal of the condition number of A, computed as
* ( 1/norm(A) ) / norm(inv(A)).
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
REAL EPS, RAT
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
EPS = SLAMCH( 'Epsilon' )
IF( RCOND.GT.ZERO ) THEN
IF( RCONDC.GT.ZERO ) THEN
RAT = MAX( RCOND, RCONDC ) / MIN( RCOND, RCONDC ) -
$ ( ONE-EPS )
ELSE
RAT = RCOND / EPS
END IF
ELSE
IF( RCONDC.GT.ZERO ) THEN
RAT = RCONDC / EPS
ELSE
RAT = ZERO
END IF
END IF
SGET06 = RAT
RETURN
*
* End of SGET06
*
END
SUBROUTINE SGET07( TRANS, N, NRHS, A, LDA, B, LDB, X, LDX, XACT,
$ LDXACT, FERR, BERR, RESLTS )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER LDA, LDB, LDX, LDXACT, N, NRHS
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ),
$ RESLTS( * ), X( LDX, * ), XACT( LDXACT, * )
* ..
*
* Purpose
* =======
*
* SGET07 tests the error bounds from iterative refinement for the
* computed solution to a system of equations op(A)*X = B, where A is a
* general n by n matrix and op(A) = A or A**T, depending on TRANS.
*
* RESLTS(1) = test of the error bound
* = norm(X - XACT) / ( norm(X) * FERR )
*
* A large value is returned if this ratio is not less than one.
*
* RESLTS(2) = residual from the iterative refinement routine
* = the maximum of BERR / ( (n+1)*EPS + (*) ), where
* (*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i )
*
* 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**H * X = B (Conjugate transpose = Transpose)
*
* N (input) INTEGER
* The number of rows of the matrices X and XACT. N >= 0.
*
* NRHS (input) INTEGER
* The number of columns of the matrices X and XACT. NRHS >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The original n by n matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input) REAL array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input) REAL array, dimension (LDX,NRHS)
* The computed solution vectors. Each vector is stored as a
* column of the matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* XACT (input) REAL array, dimension (LDX,NRHS)
* The exact solution vectors. Each vector is stored as a
* column of the matrix XACT.
*
* LDXACT (input) INTEGER
* The leading dimension of the array XACT. LDXACT >= max(1,N).
*
* FERR (input) REAL array, dimension (NRHS)
* The estimated forward error bounds for each solution vector
* X. If XTRUE is the true solution, FERR bounds the magnitude
* of the largest entry in (X - XTRUE) divided by the magnitude
* of the largest entry in X.
*
* BERR (input) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector (i.e., the smallest relative change in any entry of A
* or B that makes X an exact solution).
*
* RESLTS (output) REAL array, dimension (2)
* The maximum over the NRHS solution vectors of the ratios:
* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
* RESLTS(2) = BERR / ( (n+1)*EPS + (*) )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN
INTEGER I, IMAX, J, K
REAL AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SLAMCH
EXTERNAL LSAME, ISAMAX, SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0.
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESLTS( 1 ) = ZERO
RESLTS( 2 ) = ZERO
RETURN
END IF
*
EPS = SLAMCH( 'Epsilon' )
UNFL = SLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
NOTRAN = LSAME( TRANS, 'N' )
*
* Test 1: Compute the maximum of
* norm(X - XACT) / ( norm(X) * FERR )
* over all the vectors X and XACT using the infinity-norm.
*
ERRBND = ZERO
DO 30 J = 1, NRHS
IMAX = ISAMAX( N, X( 1, J ), 1 )
XNORM = MAX( ABS( X( IMAX, J ) ), UNFL )
DIFF = ZERO
DO 10 I = 1, N
DIFF = MAX( DIFF, ABS( X( I, J )-XACT( I, J ) ) )
10 CONTINUE
*
IF( XNORM.GT.ONE ) THEN
GO TO 20
ELSE IF( DIFF.LE.OVFL*XNORM ) THEN
GO TO 20
ELSE
ERRBND = ONE / EPS
GO TO 30
END IF
*
20 CONTINUE
IF( DIFF / XNORM.LE.FERR( J ) ) THEN
ERRBND = MAX( ERRBND, ( DIFF / XNORM ) / FERR( J ) )
ELSE
ERRBND = ONE / EPS
END IF
30 CONTINUE
RESLTS( 1 ) = ERRBND
*
* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where
* (*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i )
*
DO 70 K = 1, NRHS
DO 60 I = 1, N
TMP = ABS( B( I, K ) )
IF( NOTRAN ) THEN
DO 40 J = 1, N
TMP = TMP + ABS( A( I, J ) )*ABS( X( J, K ) )
40 CONTINUE
ELSE
DO 50 J = 1, N
TMP = TMP + ABS( A( J, I ) )*ABS( X( J, K ) )
50 CONTINUE
END IF
IF( I.EQ.1 ) THEN
AXBI = TMP
ELSE
AXBI = MIN( AXBI, TMP )
END IF
60 CONTINUE
TMP = BERR( K ) / ( ( N+1 )*EPS+( N+1 )*UNFL /
$ MAX( AXBI, ( N+1 )*UNFL ) )
IF( K.EQ.1 ) THEN
RESLTS( 2 ) = TMP
ELSE
RESLTS( 2 ) = MAX( RESLTS( 2 ), TMP )
END IF
70 CONTINUE
*
RETURN
*
* End of SGET07
*
END
SUBROUTINE SGTT01( N, DL, D, DU, DLF, DF, DUF, DU2, IPIV, WORK,
$ LDWORK, RWORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDWORK, N
REAL RESID
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
REAL D( * ), DF( * ), DL( * ), DLF( * ), DU( * ),
$ DU2( * ), DUF( * ), RWORK( * ),
$ WORK( LDWORK, * )
* ..
*
* Purpose
* =======
*
* SGTT01 reconstructs a tridiagonal matrix A from its LU factorization
* and computes the residual
* norm(L*U - A) / ( norm(A) * EPS ),
* where EPS is the machine epsilon.
*
* Arguments
* =========
*
* N (input) INTEGTER
* The order of the matrix A. N >= 0.
*
* DL (input) REAL array, dimension (N-1)
* The (n-1) sub-diagonal elements of A.
*
* D (input) REAL array, dimension (N)
* The diagonal elements of A.
*
* DU (input) REAL array, dimension (N-1)
* The (n-1) super-diagonal elements of A.
*
* DLF (input) REAL array, dimension (N-1)
* The (n-1) multipliers that define the matrix L from the
* LU factorization of A.
*
* DF (input) REAL array, dimension (N)
* The n diagonal elements of the upper triangular matrix U from
* the LU factorization of A.
*
* DUF (input) REAL array, dimension (N-1)
* The (n-1) elements of the first super-diagonal of U.
*
* DU2F (input) REAL array, dimension (N-2)
* The (n-2) elements of the second super-diagonal of U.
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices; for 1 <= i <= n, row i of the matrix was
* interchanged with row IPIV(i). IPIV(i) will always be either
* i or i+1; IPIV(i) = i indicates a row interchange was not
* required.
*
* WORK (workspace) REAL array, dimension (LDWORK,N)
*
* LDWORK (input) INTEGER
* The leading dimension of the array WORK. LDWORK >= max(1,N).
*
* RWORK (workspace) REAL array, dimension (N)
*
* RESID (output) REAL
* The scaled residual: norm(L*U - A) / (norm(A) * EPS)
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, IP, J, LASTJ
REAL ANORM, EPS, LI
* ..
* .. External Functions ..
REAL SLAMCH, SLANGT, SLANHS
EXTERNAL SLAMCH, SLANGT, SLANHS
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SSWAP
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
EPS = SLAMCH( 'Epsilon' )
*
* Copy the matrix U to WORK.
*
DO 20 J = 1, N
DO 10 I = 1, N
WORK( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
DO 30 I = 1, N
IF( I.EQ.1 ) THEN
WORK( I, I ) = DF( I )
IF( N.GE.2 )
$ WORK( I, I+1 ) = DUF( I )
IF( N.GE.3 )
$ WORK( I, I+2 ) = DU2( I )
ELSE IF( I.EQ.N ) THEN
WORK( I, I ) = DF( I )
ELSE
WORK( I, I ) = DF( I )
WORK( I, I+1 ) = DUF( I )
IF( I.LT.N-1 )
$ WORK( I, I+2 ) = DU2( I )
END IF
30 CONTINUE
*
* Multiply on the left by L.
*
LASTJ = N
DO 40 I = N - 1, 1, -1
LI = DLF( I )
CALL SAXPY( LASTJ-I+1, LI, WORK( I, I ), LDWORK,
$ WORK( I+1, I ), LDWORK )
IP = IPIV( I )
IF( IP.EQ.I ) THEN
LASTJ = MIN( I+2, N )
ELSE
CALL SSWAP( LASTJ-I+1, WORK( I, I ), LDWORK, WORK( I+1, I ),
$ LDWORK )
END IF
40 CONTINUE
*
* Subtract the matrix A.
*
WORK( 1, 1 ) = WORK( 1, 1 ) - D( 1 )
IF( N.GT.1 ) THEN
WORK( 1, 2 ) = WORK( 1, 2 ) - DU( 1 )
WORK( N, N-1 ) = WORK( N, N-1 ) - DL( N-1 )
WORK( N, N ) = WORK( N, N ) - D( N )
DO 50 I = 2, N - 1
WORK( I, I-1 ) = WORK( I, I-1 ) - DL( I-1 )
WORK( I, I ) = WORK( I, I ) - D( I )
WORK( I, I+1 ) = WORK( I, I+1 ) - DU( I )
50 CONTINUE
END IF
*
* Compute the 1-norm of the tridiagonal matrix A.
*
ANORM = SLANGT( '1', N, DL, D, DU )
*
* Compute the 1-norm of WORK, which is only guaranteed to be
* upper Hessenberg.
*
RESID = SLANHS( '1', N, WORK, LDWORK, RWORK )
*
* Compute norm(L*U - A) / (norm(A) * EPS)
*
IF( ANORM.LE.ZERO ) THEN
IF( RESID.NE.ZERO )
$ RESID = ONE / EPS
ELSE
RESID = ( RESID / ANORM ) / EPS
END IF
*
RETURN
*
* End of SGTT01
*
END
SUBROUTINE SGTT02( TRANS, N, NRHS, DL, D, DU, X, LDX, B, LDB,
$ RWORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER LDB, LDX, N, NRHS
REAL RESID
* ..
* .. Array Arguments ..
REAL B( LDB, * ), D( * ), DL( * ), DU( * ),
$ RWORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* SGTT02 computes the residual for the solution to a tridiagonal
* system of equations:
* RESID = norm(B - op(A)*X) / (norm(A) * norm(X) * EPS),
* where EPS is the machine epsilon.
*
* Arguments
* =========
*
* TRANS (input) CHARACTER
* Specifies the form of the residual.
* = 'N': B - A * X (No transpose)
* = 'T': B - A'* X (Transpose)
* = 'C': B - A'* X (Conjugate transpose = Transpose)
*
* N (input) INTEGTER
* 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 matrices B and X. NRHS >= 0.
*
* DL (input) REAL array, dimension (N-1)
* The (n-1) sub-diagonal elements of A.
*
* D (input) REAL array, dimension (N)
* The diagonal elements of A.
*
* DU (input) REAL array, dimension (N-1)
* The (n-1) super-diagonal elements of A.
*
* X (input) REAL array, dimension (LDX,NRHS)
* The computed solution vectors X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the right hand side vectors for the system of
* linear equations.
* On exit, B is overwritten with the difference B - op(A)*X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* RWORK (workspace) REAL array, dimension (N)
*
* RESID (output) REAL
* norm(B - op(A)*X) / (norm(A) * norm(X) * EPS)
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER J
REAL ANORM, BNORM, EPS, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SASUM, SLAMCH, SLANGT
EXTERNAL LSAME, SASUM, SLAMCH, SLANGT
* ..
* .. External Subroutines ..
EXTERNAL SLAGTM
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0
*
RESID = ZERO
IF( N.LE.0 .OR. NRHS.EQ.0 )
$ RETURN
*
* Compute the maximum over the number of right hand sides of
* norm(B - op(A)*X) / ( norm(A) * norm(X) * EPS ).
*
IF( LSAME( TRANS, 'N' ) ) THEN
ANORM = SLANGT( '1', N, DL, D, DU )
ELSE
ANORM = SLANGT( 'I', N, DL, D, DU )
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0.
*
EPS = SLAMCH( 'Epsilon' )
IF( ANORM.LE.ZERO ) THEN
RESID = ONE / EPS
RETURN
END IF
*
* Compute B - op(A)*X.
*
CALL SLAGTM( TRANS, N, NRHS, -ONE, DL, D, DU, X, LDX, ONE, B,
$ LDB )
*
DO 10 J = 1, NRHS
BNORM = SASUM( N, B( 1, J ), 1 )
XNORM = SASUM( N, X( 1, J ), 1 )
IF( XNORM.LE.ZERO ) THEN
RESID = ONE / EPS
ELSE
RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) / EPS )
END IF
10 CONTINUE
*
RETURN
*
* End of SGTT02
*
END
SUBROUTINE SGTT05( TRANS, N, NRHS, DL, D, DU, B, LDB, X, LDX,
$ XACT, LDXACT, FERR, BERR, RESLTS )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER LDB, LDX, LDXACT, N, NRHS
* ..
* .. Array Arguments ..
REAL B( LDB, * ), BERR( * ), D( * ), DL( * ),
$ DU( * ), FERR( * ), RESLTS( * ), X( LDX, * ),
$ XACT( LDXACT, * )
* ..
*
* Purpose
* =======
*
* SGTT05 tests the error bounds from iterative refinement for the
* computed solution to a system of equations A*X = B, where A is a
* general tridiagonal matrix of order n and op(A) = A or A**T,
* depending on TRANS.
*
* RESLTS(1) = test of the error bound
* = norm(X - XACT) / ( norm(X) * FERR )
*
* A large value is returned if this ratio is not less than one.
*
* RESLTS(2) = residual from the iterative refinement routine
* = the maximum of BERR / ( NZ*EPS + (*) ), where
* (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i )
* and NZ = max. number of nonzeros in any row of A, plus 1
*
* 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**H * X = B (Conjugate transpose = Transpose)
*
* N (input) INTEGER
* The number of rows of the matrices X and XACT. N >= 0.
*
* NRHS (input) INTEGER
* The number of columns of the matrices X and XACT. NRHS >= 0.
*
* DL (input) REAL array, dimension (N-1)
* The (n-1) sub-diagonal elements of A.
*
* D (input) REAL array, dimension (N)
* The diagonal elements of A.
*
* DU (input) REAL array, dimension (N-1)
* The (n-1) super-diagonal elements of A.
*
* B (input) REAL array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input) REAL array, dimension (LDX,NRHS)
* The computed solution vectors. Each vector is stored as a
* column of the matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* XACT (input) REAL array, dimension (LDX,NRHS)
* The exact solution vectors. Each vector is stored as a
* column of the matrix XACT.
*
* LDXACT (input) INTEGER
* The leading dimension of the array XACT. LDXACT >= max(1,N).
*
* FERR (input) REAL array, dimension (NRHS)
* The estimated forward error bounds for each solution vector
* X. If XTRUE is the true solution, FERR bounds the magnitude
* of the largest entry in (X - XTRUE) divided by the magnitude
* of the largest entry in X.
*
* BERR (input) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector (i.e., the smallest relative change in any entry of A
* or B that makes X an exact solution).
*
* RESLTS (output) REAL array, dimension (2)
* The maximum over the NRHS solution vectors of the ratios:
* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
* RESLTS(2) = BERR / ( NZ*EPS + (*) )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN
INTEGER I, IMAX, J, K, NZ
REAL AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SLAMCH
EXTERNAL LSAME, ISAMAX, SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0.
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESLTS( 1 ) = ZERO
RESLTS( 2 ) = ZERO
RETURN
END IF
*
EPS = SLAMCH( 'Epsilon' )
UNFL = SLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
NOTRAN = LSAME( TRANS, 'N' )
NZ = 4
*
* Test 1: Compute the maximum of
* norm(X - XACT) / ( norm(X) * FERR )
* over all the vectors X and XACT using the infinity-norm.
*
ERRBND = ZERO
DO 30 J = 1, NRHS
IMAX = ISAMAX( N, X( 1, J ), 1 )
XNORM = MAX( ABS( X( IMAX, J ) ), UNFL )
DIFF = ZERO
DO 10 I = 1, N
DIFF = MAX( DIFF, ABS( X( I, J )-XACT( I, J ) ) )
10 CONTINUE
*
IF( XNORM.GT.ONE ) THEN
GO TO 20
ELSE IF( DIFF.LE.OVFL*XNORM ) THEN
GO TO 20
ELSE
ERRBND = ONE / EPS
GO TO 30
END IF
*
20 CONTINUE
IF( DIFF / XNORM.LE.FERR( J ) ) THEN
ERRBND = MAX( ERRBND, ( DIFF / XNORM ) / FERR( J ) )
ELSE
ERRBND = ONE / EPS
END IF
30 CONTINUE
RESLTS( 1 ) = ERRBND
*
* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where
* (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i )
*
DO 60 K = 1, NRHS
IF( NOTRAN ) THEN
IF( N.EQ.1 ) THEN
AXBI = ABS( B( 1, K ) ) + ABS( D( 1 )*X( 1, K ) )
ELSE
AXBI = ABS( B( 1, K ) ) + ABS( D( 1 )*X( 1, K ) ) +
$ ABS( DU( 1 )*X( 2, K ) )
DO 40 I = 2, N - 1
TMP = ABS( B( I, K ) ) + ABS( DL( I-1 )*X( I-1, K ) )
$ + ABS( D( I )*X( I, K ) ) +
$ ABS( DU( I )*X( I+1, K ) )
AXBI = MIN( AXBI, TMP )
40 CONTINUE
TMP = ABS( B( N, K ) ) + ABS( DL( N-1 )*X( N-1, K ) ) +
$ ABS( D( N )*X( N, K ) )
AXBI = MIN( AXBI, TMP )
END IF
ELSE
IF( N.EQ.1 ) THEN
AXBI = ABS( B( 1, K ) ) + ABS( D( 1 )*X( 1, K ) )
ELSE
AXBI = ABS( B( 1, K ) ) + ABS( D( 1 )*X( 1, K ) ) +
$ ABS( DL( 1 )*X( 2, K ) )
DO 50 I = 2, N - 1
TMP = ABS( B( I, K ) ) + ABS( DU( I-1 )*X( I-1, K ) )
$ + ABS( D( I )*X( I, K ) ) +
$ ABS( DL( I )*X( I+1, K ) )
AXBI = MIN( AXBI, TMP )
50 CONTINUE
TMP = ABS( B( N, K ) ) + ABS( DU( N-1 )*X( N-1, K ) ) +
$ ABS( D( N )*X( N, K ) )
AXBI = MIN( AXBI, TMP )
END IF
END IF
TMP = BERR( K ) / ( NZ*EPS+NZ*UNFL / MAX( AXBI, NZ*UNFL ) )
IF( K.EQ.1 ) THEN
RESLTS( 2 ) = TMP
ELSE
RESLTS( 2 ) = MAX( RESLTS( 2 ), TMP )
END IF
60 CONTINUE
*
RETURN
*
* End of SGTT05
*
END
SUBROUTINE SLAORD( JOB, N, X, INCX )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOB
INTEGER INCX, N
* ..
* .. Array Arguments ..
REAL X( * )
* ..
*
* Purpose
* =======
*
* SLAORD sorts the elements of a vector x in increasing or decreasing
* order.
*
* Arguments
* =========
*
* JOB (input) CHARACTER
* = 'I': Sort in increasing order
* = 'D': Sort in decreasing order
*
* N (input) INTEGER
* The length of the vector X.
*
* X (input/output) REAL array, dimension
* (1+(N-1)*INCX)
* On entry, the vector of length n to be sorted.
* On exit, the vector x is sorted in the prescribed order.
*
* INCX (input) INTEGER
* The spacing between successive elements of X. INCX >= 0.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, INC, IX, IXNEXT
REAL TEMP
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
INC = ABS( INCX )
IF( LSAME( JOB, 'I' ) ) THEN
*
* Sort in increasing order
*
DO 20 I = 2, N
IX = 1 + ( I-1 )*INC
10 CONTINUE
IF( IX.EQ.1 )
$ GO TO 20
IXNEXT = IX - INC
IF( X( IX ).GT.X( IXNEXT ) ) THEN
GO TO 20
ELSE
TEMP = X( IX )
X( IX ) = X( IXNEXT )
X( IXNEXT ) = TEMP
END IF
IX = IXNEXT
GO TO 10
20 CONTINUE
*
ELSE IF( LSAME( JOB, 'D' ) ) THEN
*
* Sort in decreasing order
*
DO 40 I = 2, N
IX = 1 + ( I-1 )*INC
30 CONTINUE
IF( IX.EQ.1 )
$ GO TO 40
IXNEXT = IX - INC
IF( X( IX ).LT.X( IXNEXT ) ) THEN
GO TO 40
ELSE
TEMP = X( IX )
X( IX ) = X( IXNEXT )
X( IXNEXT ) = TEMP
END IF
IX = IXNEXT
GO TO 30
40 CONTINUE
END IF
RETURN
*
* End of SLAORD
*
END
SUBROUTINE SLAPTM( N, NRHS, ALPHA, D, E, X, LDX, BETA, B, LDB )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDB, LDX, N, NRHS
REAL ALPHA, BETA
* ..
* .. Array Arguments ..
REAL B( LDB, * ), D( * ), E( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* SLAPTM multiplies an N by NRHS matrix X by a symmetric tridiagonal
* matrix A and stores the result in a matrix B. The operation has the
* form
*
* B := alpha * A * X + beta * B
*
* where alpha may be either 1. or -1. and beta may be 0., 1., or -1.
*
* Arguments
* =========
*
* 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 matrices X and B.
*
* ALPHA (input) REAL
* The scalar alpha. ALPHA must be 1. or -1.; otherwise,
* it is assumed to be 0.
*
* D (input) REAL array, dimension (N)
* The n diagonal elements of the tridiagonal matrix A.
*
* E (input) REAL array, dimension (N-1)
* The (n-1) subdiagonal or superdiagonal elements of A.
*
* X (input) REAL array, dimension (LDX,NRHS)
* The N by NRHS matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(N,1).
*
* BETA (input) REAL
* The scalar beta. BETA must be 0., 1., or -1.; otherwise,
* it is assumed to be 1.
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the N by NRHS matrix B.
* On exit, B is overwritten by the matrix expression
* B := alpha * A * X + beta * B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(N,1).
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 )
$ RETURN
*
* Multiply B by BETA if BETA.NE.1.
*
IF( BETA.EQ.ZERO ) THEN
DO 20 J = 1, NRHS
DO 10 I = 1, N
B( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
ELSE IF( BETA.EQ.-ONE ) THEN
DO 40 J = 1, NRHS
DO 30 I = 1, N
B( I, J ) = -B( I, J )
30 CONTINUE
40 CONTINUE
END IF
*
IF( ALPHA.EQ.ONE ) THEN
*
* Compute B := B + A*X
*
DO 60 J = 1, NRHS
IF( N.EQ.1 ) THEN
B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J )
ELSE
B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) +
$ E( 1 )*X( 2, J )
B( N, J ) = B( N, J ) + E( N-1 )*X( N-1, J ) +
$ D( N )*X( N, J )
DO 50 I = 2, N - 1
B( I, J ) = B( I, J ) + E( I-1 )*X( I-1, J ) +
$ D( I )*X( I, J ) + E( I )*X( I+1, J )
50 CONTINUE
END IF
60 CONTINUE
ELSE IF( ALPHA.EQ.-ONE ) THEN
*
* Compute B := B - A*X
*
DO 80 J = 1, NRHS
IF( N.EQ.1 ) THEN
B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J )
ELSE
B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) -
$ E( 1 )*X( 2, J )
B( N, J ) = B( N, J ) - E( N-1 )*X( N-1, J ) -
$ D( N )*X( N, J )
DO 70 I = 2, N - 1
B( I, J ) = B( I, J ) - E( I-1 )*X( I-1, J ) -
$ D( I )*X( I, J ) - E( I )*X( I+1, J )
70 CONTINUE
END IF
80 CONTINUE
END IF
RETURN
*
* End of SLAPTM
*
END
SUBROUTINE SLARHS( PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS,
$ A, LDA, X, LDX, B, LDB, ISEED, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS, UPLO, XTYPE
CHARACTER*3 PATH
INTEGER INFO, KL, KU, LDA, LDB, LDX, M, N, NRHS
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
REAL A( LDA, * ), B( LDB, * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* SLARHS chooses a set of NRHS random solution vectors and sets
* up the right hand sides for the linear system
* op( A ) * X = B,
* where op( A ) may be A or A' (transpose of A).
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The type of the real matrix A. PATH may be given in any
* combination of upper and lower case. Valid types include
* xGE: General m x n matrix
* xGB: General banded matrix
* xPO: Symmetric positive definite, 2-D storage
* xPP: Symmetric positive definite packed
* xPB: Symmetric positive definite banded
* xSY: Symmetric indefinite, 2-D storage
* xSP: Symmetric indefinite packed
* xSB: Symmetric indefinite banded
* xTR: Triangular
* xTP: Triangular packed
* xTB: Triangular banded
* xQR: General m x n matrix
* xLQ: General m x n matrix
* xQL: General m x n matrix
* xRQ: General m x n matrix
* where the leading character indicates the precision.
*
* XTYPE (input) CHARACTER*1
* Specifies how the exact solution X will be determined:
* = 'N': New solution; generate a random X.
* = 'C': Computed; use value of X on entry.
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* matrix A is stored, if A is symmetric.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the operation applied to the matrix A.
* = 'N': System is A * x = b
* = 'T': System is A'* x = b
* = 'C': System is A'* x = b
*
* M (input) INTEGER
* The number or rows of the matrix A. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix A. N >= 0.
*
* KL (input) INTEGER
* Used only if A is a band matrix; specifies the number of
* subdiagonals of A if A is a general band matrix or if A is
* symmetric or triangular and UPLO = 'L'; specifies the number
* of superdiagonals of A if A is symmetric or triangular and
* UPLO = 'U'. 0 <= KL <= M-1.
*
* KU (input) INTEGER
* Used only if A is a general band matrix or if A is
* triangular.
*
* If PATH = xGB, specifies the number of superdiagonals of A,
* and 0 <= KU <= N-1.
*
* If PATH = xTR, xTP, or xTB, specifies whether or not the
* matrix has unit diagonal:
* = 1: matrix has non-unit diagonal (default)
* = 2: matrix has unit diagonal
*
* NRHS (input) INTEGER
* The number of right hand side vectors in the system A*X = B.
*
* A (input) REAL array, dimension (LDA,N)
* The test matrix whose type is given by PATH.
*
* LDA (input) INTEGER
* The leading dimension of the array A.
* If PATH = xGB, LDA >= KL+KU+1.
* If PATH = xPB, xSB, xHB, or xTB, LDA >= KL+1.
* Otherwise, LDA >= max(1,M).
*
* X (input or output) REAL array, dimension(LDX,NRHS)
* On entry, if XTYPE = 'C' (for 'Computed'), then X contains
* the exact solution to the system of linear equations.
* On exit, if XTYPE = 'N' (for 'New'), then X is initialized
* with random values.
*
* LDX (input) INTEGER
* The leading dimension of the array X. If TRANS = 'N',
* LDX >= max(1,N); if TRANS = 'T', LDX >= max(1,M).
*
* B (output) REAL array, dimension (LDB,NRHS)
* The right hand side vector(s) for the system of equations,
* computed from B = op(A) * X, where op(A) is determined by
* TRANS.
*
* LDB (input) INTEGER
* The leading dimension of the array B. If TRANS = 'N',
* LDB >= max(1,M); if TRANS = 'T', LDB >= max(1,N).
*
* ISEED (input/output) INTEGER array, dimension (4)
* The seed vector for the random number generator (used in
* SLATMS). Modified on exit.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL BAND, GEN, NOTRAN, QRS, SYM, TRAN, TRI
CHARACTER C1, DIAG
CHARACTER*2 C2
INTEGER J, MB, NX
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL SGBMV, SGEMM, SLACPY, SLARNV, SSBMV, SSPMV,
$ SSYMM, STBMV, STPMV, STRMM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
C1 = PATH( 1: 1 )
C2 = PATH( 2: 3 )
TRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
NOTRAN = .NOT.TRAN
GEN = LSAME( PATH( 2: 2 ), 'G' )
QRS = LSAME( PATH( 2: 2 ), 'Q' ) .OR. LSAME( PATH( 3: 3 ), 'Q' )
SYM = LSAME( PATH( 2: 2 ), 'P' ) .OR. LSAME( PATH( 2: 2 ), 'S' )
TRI = LSAME( PATH( 2: 2 ), 'T' )
BAND = LSAME( PATH( 3: 3 ), 'B' )
IF( .NOT.LSAME( C1, 'Single precision' ) ) THEN
INFO = -1
ELSE IF( .NOT.( LSAME( XTYPE, 'N' ) .OR. LSAME( XTYPE, 'C' ) ) )
$ THEN
INFO = -2
ELSE IF( ( SYM .OR. TRI ) .AND. .NOT.
$ ( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) THEN
INFO = -3
ELSE IF( ( GEN .OR. QRS ) .AND. .NOT.
$ ( TRAN .OR. LSAME( TRANS, 'N' ) ) ) THEN
INFO = -4
ELSE IF( M.LT.0 ) THEN
INFO = -5
ELSE IF( N.LT.0 ) THEN
INFO = -6
ELSE IF( BAND .AND. KL.LT.0 ) THEN
INFO = -7
ELSE IF( BAND .AND. KU.LT.0 ) THEN
INFO = -8
ELSE IF( NRHS.LT.0 ) THEN
INFO = -9
ELSE IF( ( .NOT.BAND .AND. LDA.LT.MAX( 1, M ) ) .OR.
$ ( BAND .AND. ( SYM .OR. TRI ) .AND. LDA.LT.KL+1 ) .OR.
$ ( BAND .AND. GEN .AND. LDA.LT.KL+KU+1 ) ) THEN
INFO = -11
ELSE IF( ( NOTRAN .AND. LDX.LT.MAX( 1, N ) ) .OR.
$ ( TRAN .AND. LDX.LT.MAX( 1, M ) ) ) THEN
INFO = -13
ELSE IF( ( NOTRAN .AND. LDB.LT.MAX( 1, M ) ) .OR.
$ ( TRAN .AND. LDB.LT.MAX( 1, N ) ) ) THEN
INFO = -15
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLARHS', -INFO )
RETURN
END IF
*
* Initialize X to NRHS random vectors unless XTYPE = 'C'.
*
IF( TRAN ) THEN
NX = M
MB = N
ELSE
NX = N
MB = M
END IF
IF( .NOT.LSAME( XTYPE, 'C' ) ) THEN
DO 10 J = 1, NRHS
CALL SLARNV( 2, ISEED, N, X( 1, J ) )
10 CONTINUE
END IF
*
* Multiply X by op( A ) using an appropriate
* matrix multiply routine.
*
IF( LSAMEN( 2, C2, 'GE' ) .OR. LSAMEN( 2, C2, 'QR' ) .OR.
$ LSAMEN( 2, C2, 'LQ' ) .OR. LSAMEN( 2, C2, 'QL' ) .OR.
$ LSAMEN( 2, C2, 'RQ' ) ) THEN
*
* General matrix
*
CALL SGEMM( TRANS, 'N', MB, NRHS, NX, ONE, A, LDA, X, LDX,
$ ZERO, B, LDB )
*
ELSE IF( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'SY' ) ) THEN
*
* Symmetric matrix, 2-D storage
*
CALL SSYMM( 'Left', UPLO, N, NRHS, ONE, A, LDA, X, LDX, ZERO,
$ B, LDB )
*
ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
*
* General matrix, band storage
*
DO 20 J = 1, NRHS
CALL SGBMV( TRANS, MB, NX, KL, KU, ONE, A, LDA, X( 1, J ),
$ 1, ZERO, B( 1, J ), 1 )
20 CONTINUE
*
ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN
*
* Symmetric matrix, band storage
*
DO 30 J = 1, NRHS
CALL SSBMV( UPLO, N, KL, ONE, A, LDA, X( 1, J ), 1, ZERO,
$ B( 1, J ), 1 )
30 CONTINUE
*
ELSE IF( LSAMEN( 2, C2, 'PP' ) .OR. LSAMEN( 2, C2, 'SP' ) ) THEN
*
* Symmetric matrix, packed storage
*
DO 40 J = 1, NRHS
CALL SSPMV( UPLO, N, ONE, A, X( 1, J ), 1, ZERO, B( 1, J ),
$ 1 )
40 CONTINUE
*
ELSE IF( LSAMEN( 2, C2, 'TR' ) ) THEN
*
* Triangular matrix. Note that for triangular matrices,
* KU = 1 => non-unit triangular
* KU = 2 => unit triangular
*
CALL SLACPY( 'Full', N, NRHS, X, LDX, B, LDB )
IF( KU.EQ.2 ) THEN
DIAG = 'U'
ELSE
DIAG = 'N'
END IF
CALL STRMM( 'Left', UPLO, TRANS, DIAG, N, NRHS, ONE, A, LDA, B,
$ LDB )
*
ELSE IF( LSAMEN( 2, C2, 'TP' ) ) THEN
*
* Triangular matrix, packed storage
*
CALL SLACPY( 'Full', N, NRHS, X, LDX, B, LDB )
IF( KU.EQ.2 ) THEN
DIAG = 'U'
ELSE
DIAG = 'N'
END IF
DO 50 J = 1, NRHS
CALL STPMV( UPLO, TRANS, DIAG, N, A, B( 1, J ), 1 )
50 CONTINUE
*
ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
*
* Triangular matrix, banded storage
*
CALL SLACPY( 'Full', N, NRHS, X, LDX, B, LDB )
IF( KU.EQ.2 ) THEN
DIAG = 'U'
ELSE
DIAG = 'N'
END IF
DO 60 J = 1, NRHS
CALL STBMV( UPLO, TRANS, DIAG, N, KL, A, LDA, B( 1, J ), 1 )
60 CONTINUE
*
ELSE
*
* If PATH is none of the above, return with an error code.
*
INFO = -1
CALL XERBLA( 'SLARHS', -INFO )
END IF
*
RETURN
*
* End of SLARHS
*
END
SUBROUTINE SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIST, TYPE
CHARACTER*3 PATH
INTEGER IMAT, KL, KU, M, MODE, N
REAL ANORM, CNDNUM
* ..
*
* Purpose
* =======
*
* SLATB4 sets parameters for the matrix generator based on the type of
* matrix to be generated.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name.
*
* IMAT (input) INTEGER
* An integer key describing which matrix to generate for this
* path.
*
* M (input) INTEGER
* The number of rows in the matrix to be generated.
*
* N (input) INTEGER
* The number of columns in the matrix to be generated.
*
* TYPE (output) CHARACTER*1
* The type of the matrix to be generated:
* = 'S': symmetric matrix
* = 'P': symmetric positive (semi)definite matrix
* = 'N': nonsymmetric matrix
*
* KL (output) INTEGER
* The lower band width of the matrix to be generated.
*
* KU (output) INTEGER
* The upper band width of the matrix to be generated.
*
* ANORM (output) REAL
* The desired norm of the matrix to be generated. The diagonal
* matrix of singular values or eigenvalues is scaled by this
* value.
*
* MODE (output) INTEGER
* A key indicating how to choose the vector of eigenvalues.
*
* CNDNUM (output) REAL
* The desired condition number.
*
* DIST (output) CHARACTER*1
* The type of distribution to be used by the random number
* generator.
*
* =====================================================================
*
* .. Parameters ..
REAL SHRINK, TENTH
PARAMETER ( SHRINK = 0.25E0, TENTH = 0.1E+0 )
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
REAL TWO
PARAMETER ( TWO = 2.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL FIRST
CHARACTER*2 C2
INTEGER MAT
REAL BADC1, BADC2, EPS, LARGE, SMALL
* ..
* .. External Functions ..
LOGICAL LSAMEN
REAL SLAMCH
EXTERNAL LSAMEN, SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. External Subroutines ..
EXTERNAL SLABAD
* ..
* .. Save statement ..
SAVE EPS, SMALL, LARGE, BADC1, BADC2, FIRST
* ..
* .. Data statements ..
DATA FIRST / .TRUE. /
* ..
* .. Executable Statements ..
*
* Set some constants for use in the subroutine.
*
IF( FIRST ) THEN
FIRST = .FALSE.
EPS = SLAMCH( 'Precision' )
BADC2 = TENTH / EPS
BADC1 = SQRT( BADC2 )
SMALL = SLAMCH( 'Safe minimum' )
LARGE = ONE / SMALL
*
* If it looks like we're on a Cray, take the square root of
* SMALL and LARGE to avoid overflow and underflow problems.
*
CALL SLABAD( SMALL, LARGE )
SMALL = SHRINK*( SMALL / EPS )
LARGE = ONE / SMALL
END IF
*
C2 = PATH( 2: 3 )
*
* Set some parameters we don't plan to change.
*
DIST = 'S'
MODE = 3
*
IF( LSAMEN( 2, C2, 'QR' ) .OR. LSAMEN( 2, C2, 'LQ' ) .OR.
$ LSAMEN( 2, C2, 'QL' ) .OR. LSAMEN( 2, C2, 'RQ' ) ) THEN
*
* xQR, xLQ, xQL, xRQ: Set parameters to generate a general
* M x N matrix.
*
* Set TYPE, the type of matrix to be generated.
*
TYPE = 'N'
*
* Set the lower and upper bandwidths.
*
IF( IMAT.EQ.1 ) THEN
KL = 0
KU = 0
ELSE IF( IMAT.EQ.2 ) THEN
KL = 0
KU = MAX( N-1, 0 )
ELSE IF( IMAT.EQ.3 ) THEN
KL = MAX( M-1, 0 )
KU = 0
ELSE
KL = MAX( M-1, 0 )
KU = MAX( N-1, 0 )
END IF
*
* Set the condition number and norm.
*
IF( IMAT.EQ.5 ) THEN
CNDNUM = BADC1
ELSE IF( IMAT.EQ.6 ) THEN
CNDNUM = BADC2
ELSE
CNDNUM = TWO
END IF
*
IF( IMAT.EQ.7 ) THEN
ANORM = SMALL
ELSE IF( IMAT.EQ.8 ) THEN
ANORM = LARGE
ELSE
ANORM = ONE
END IF
*
ELSE IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
* xGE: Set parameters to generate a general M x N matrix.
*
* Set TYPE, the type of matrix to be generated.
*
TYPE = 'N'
*
* Set the lower and upper bandwidths.
*
IF( IMAT.EQ.1 ) THEN
KL = 0
KU = 0
ELSE IF( IMAT.EQ.2 ) THEN
KL = 0
KU = MAX( N-1, 0 )
ELSE IF( IMAT.EQ.3 ) THEN
KL = MAX( M-1, 0 )
KU = 0
ELSE
KL = MAX( M-1, 0 )
KU = MAX( N-1, 0 )
END IF
*
* Set the condition number and norm.
*
IF( IMAT.EQ.8 ) THEN
CNDNUM = BADC1
ELSE IF( IMAT.EQ.9 ) THEN
CNDNUM = BADC2
ELSE
CNDNUM = TWO
END IF
*
IF( IMAT.EQ.10 ) THEN
ANORM = SMALL
ELSE IF( IMAT.EQ.11 ) THEN
ANORM = LARGE
ELSE
ANORM = ONE
END IF
*
ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
*
* xGB: Set parameters to generate a general banded matrix.
*
* Set TYPE, the type of matrix to be generated.
*
TYPE = 'N'
*
* Set the condition number and norm.
*
IF( IMAT.EQ.5 ) THEN
CNDNUM = BADC1
ELSE IF( IMAT.EQ.6 ) THEN
CNDNUM = TENTH*BADC2
ELSE
CNDNUM = TWO
END IF
*
IF( IMAT.EQ.7 ) THEN
ANORM = SMALL
ELSE IF( IMAT.EQ.8 ) THEN
ANORM = LARGE
ELSE
ANORM = ONE
END IF
*
ELSE IF( LSAMEN( 2, C2, 'GT' ) ) THEN
*
* xGT: Set parameters to generate a general tridiagonal matrix.
*
* Set TYPE, the type of matrix to be generated.
*
TYPE = 'N'
*
* Set the lower and upper bandwidths.
*
IF( IMAT.EQ.1 ) THEN
KL = 0
ELSE
KL = 1
END IF
KU = KL
*
* Set the condition number and norm.
*
IF( IMAT.EQ.3 ) THEN
CNDNUM = BADC1
ELSE IF( IMAT.EQ.4 ) THEN
CNDNUM = BADC2
ELSE
CNDNUM = TWO
END IF
*
IF( IMAT.EQ.5 .OR. IMAT.EQ.11 ) THEN
ANORM = SMALL
ELSE IF( IMAT.EQ.6 .OR. IMAT.EQ.12 ) THEN
ANORM = LARGE
ELSE
ANORM = ONE
END IF
*
ELSE IF( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'PP' ) .OR.
$ LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) ) THEN
*
* xPO, xPP, xSY, xSP: Set parameters to generate a
* symmetric matrix.
*
* Set TYPE, the type of matrix to be generated.
*
TYPE = C2( 1: 1 )
*
* Set the lower and upper bandwidths.
*
IF( IMAT.EQ.1 ) THEN
KL = 0
ELSE
KL = MAX( N-1, 0 )
END IF
KU = KL
*
* Set the condition number and norm.
*
IF( IMAT.EQ.6 ) THEN
CNDNUM = BADC1
ELSE IF( IMAT.EQ.7 ) THEN
CNDNUM = BADC2
ELSE
CNDNUM = TWO
END IF
*
IF( IMAT.EQ.8 ) THEN
ANORM = SMALL
ELSE IF( IMAT.EQ.9 ) THEN
ANORM = LARGE
ELSE
ANORM = ONE
END IF
*
ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN
*
* xPB: Set parameters to generate a symmetric band matrix.
*
* Set TYPE, the type of matrix to be generated.
*
TYPE = 'P'
*
* Set the norm and condition number.
*
IF( IMAT.EQ.5 ) THEN
CNDNUM = BADC1
ELSE IF( IMAT.EQ.6 ) THEN
CNDNUM = BADC2
ELSE
CNDNUM = TWO
END IF
*
IF( IMAT.EQ.7 ) THEN
ANORM = SMALL
ELSE IF( IMAT.EQ.8 ) THEN
ANORM = LARGE
ELSE
ANORM = ONE
END IF
*
ELSE IF( LSAMEN( 2, C2, 'PT' ) ) THEN
*
* xPT: Set parameters to generate a symmetric positive definite
* tridiagonal matrix.
*
TYPE = 'P'
IF( IMAT.EQ.1 ) THEN
KL = 0
ELSE
KL = 1
END IF
KU = KL
*
* Set the condition number and norm.
*
IF( IMAT.EQ.3 ) THEN
CNDNUM = BADC1
ELSE IF( IMAT.EQ.4 ) THEN
CNDNUM = BADC2
ELSE
CNDNUM = TWO
END IF
*
IF( IMAT.EQ.5 .OR. IMAT.EQ.11 ) THEN
ANORM = SMALL
ELSE IF( IMAT.EQ.6 .OR. IMAT.EQ.12 ) THEN
ANORM = LARGE
ELSE
ANORM = ONE
END IF
*
ELSE IF( LSAMEN( 2, C2, 'TR' ) .OR. LSAMEN( 2, C2, 'TP' ) ) THEN
*
* xTR, xTP: Set parameters to generate a triangular matrix
*
* Set TYPE, the type of matrix to be generated.
*
TYPE = 'N'
*
* Set the lower and upper bandwidths.
*
MAT = ABS( IMAT )
IF( MAT.EQ.1 .OR. MAT.EQ.7 ) THEN
KL = 0
KU = 0
ELSE IF( IMAT.LT.0 ) THEN
KL = MAX( N-1, 0 )
KU = 0
ELSE
KL = 0
KU = MAX( N-1, 0 )
END IF
*
* Set the condition number and norm.
*
IF( MAT.EQ.3 .OR. MAT.EQ.9 ) THEN
CNDNUM = BADC1
ELSE IF( MAT.EQ.4 ) THEN
CNDNUM = BADC2
ELSE IF( MAT.EQ.10 ) THEN
CNDNUM = BADC2
ELSE
CNDNUM = TWO
END IF
*
IF( MAT.EQ.5 ) THEN
ANORM = SMALL
ELSE IF( MAT.EQ.6 ) THEN
ANORM = LARGE
ELSE
ANORM = ONE
END IF
*
ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
*
* xTB: Set parameters to generate a triangular band matrix.
*
* Set TYPE, the type of matrix to be generated.
*
TYPE = 'N'
*
* Set the norm and condition number.
*
IF( IMAT.EQ.2 .OR. IMAT.EQ.8 ) THEN
CNDNUM = BADC1
ELSE IF( IMAT.EQ.3 .OR. IMAT.EQ.9 ) THEN
CNDNUM = BADC2
ELSE
CNDNUM = TWO
END IF
*
IF( IMAT.EQ.4 ) THEN
ANORM = SMALL
ELSE IF( IMAT.EQ.5 ) THEN
ANORM = LARGE
ELSE
ANORM = ONE
END IF
END IF
IF( N.LE.1 )
$ CNDNUM = ONE
*
RETURN
*
* End of SLATB4
*
END
SUBROUTINE SLATTB( IMAT, UPLO, TRANS, DIAG, ISEED, N, KD, AB,
$ LDAB, B, WORK, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER IMAT, INFO, KD, LDAB, N
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
REAL AB( LDAB, * ), B( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SLATTB generates a triangular test matrix in 2-dimensional storage.
* IMAT and UPLO uniquely specify the properties of the test matrix,
* which is returned in the array A.
*
* Arguments
* =========
*
* IMAT (input) INTEGER
* An integer key describing which matrix to generate for this
* path.
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A will be upper or lower
* triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies whether the matrix or its transpose will be used.
* = 'N': No transpose
* = 'T': Transpose
* = 'C': Conjugate transpose (= transpose)
*
* DIAG (output) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* ISEED (input/output) INTEGER array, dimension (4)
* The seed vector for the random number generator (used in
* SLATMS). Modified on exit.
*
* N (input) INTEGER
* The order of the matrix to be generated.
*
* KD (input) INTEGER
* The number of superdiagonals or subdiagonals of the banded
* triangular matrix A. KD >= 0.
*
* AB (output) REAL array, dimension (LDAB,N)
* The upper or lower triangular banded matrix A, stored in the
* first KD+1 rows of AB. Let j be a column of A, 1<=j<=n.
* If UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j.
* If UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* B (workspace) REAL array, dimension (N)
*
* WORK (workspace) REAL array, dimension (2*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, TWO, ZERO
PARAMETER ( ONE = 1.0E+0, TWO = 2.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
CHARACTER DIST, PACKIT, TYPE
CHARACTER*3 PATH
INTEGER I, IOFF, IY, J, JCOUNT, KL, KU, LENJ, MODE
REAL ANORM, BIGNUM, BNORM, BSCAL, CNDNUM, PLUS1,
$ PLUS2, REXP, SFAC, SMLNUM, STAR1, TEXP, TLEFT,
$ TNORM, TSCAL, ULP, UNFL
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SLAMCH, SLARND
EXTERNAL LSAME, ISAMAX, SLAMCH, SLARND
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLABAD, SLARNV, SLATB4, SLATMS, SSCAL,
$ SSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL, SIGN, SQRT
* ..
* .. Executable Statements ..
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'TB'
UNFL = SLAMCH( 'Safe minimum' )
ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
SMLNUM = UNFL
BIGNUM = ( ONE-ULP ) / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
IF( ( IMAT.GE.6 .AND. IMAT.LE.9 ) .OR. IMAT.EQ.17 ) THEN
DIAG = 'U'
ELSE
DIAG = 'N'
END IF
INFO = 0
*
* Quick return if N.LE.0.
*
IF( N.LE.0 )
$ RETURN
*
* Call SLATB4 to set parameters for SLATMS.
*
UPPER = LSAME( UPLO, 'U' )
IF( UPPER ) THEN
CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
KU = KD
IOFF = 1 + MAX( 0, KD-N+1 )
KL = 0
PACKIT = 'Q'
ELSE
CALL SLATB4( PATH, -IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
KL = KD
IOFF = 1
KU = 0
PACKIT = 'B'
END IF
*
* IMAT <= 5: Non-unit triangular matrix
*
IF( IMAT.LE.5 ) THEN
CALL SLATMS( N, N, DIST, ISEED, TYPE, B, MODE, CNDNUM, ANORM,
$ KL, KU, PACKIT, AB( IOFF, 1 ), LDAB, WORK, INFO )
*
* IMAT > 5: Unit triangular matrix
* The diagonal is deliberately set to something other than 1.
*
* IMAT = 6: Matrix is the identity
*
ELSE IF( IMAT.EQ.6 ) THEN
IF( UPPER ) THEN
DO 20 J = 1, N
DO 10 I = MAX( 1, KD+2-J ), KD
AB( I, J ) = ZERO
10 CONTINUE
AB( KD+1, J ) = J
20 CONTINUE
ELSE
DO 40 J = 1, N
AB( 1, J ) = J
DO 30 I = 2, MIN( KD+1, N-J+1 )
AB( I, J ) = ZERO
30 CONTINUE
40 CONTINUE
END IF
*
* IMAT > 6: Non-trivial unit triangular matrix
*
* A unit triangular matrix T with condition CNDNUM is formed.
* In this version, T only has bandwidth 2, the rest of it is zero.
*
ELSE IF( IMAT.LE.9 ) THEN
TNORM = SQRT( CNDNUM )
*
* Initialize AB to zero.
*
IF( UPPER ) THEN
DO 60 J = 1, N
DO 50 I = MAX( 1, KD+2-J ), KD
AB( I, J ) = ZERO
50 CONTINUE
AB( KD+1, J ) = REAL( J )
60 CONTINUE
ELSE
DO 80 J = 1, N
DO 70 I = 2, MIN( KD+1, N-J+1 )
AB( I, J ) = ZERO
70 CONTINUE
AB( 1, J ) = REAL( J )
80 CONTINUE
END IF
*
* Special case: T is tridiagonal. Set every other offdiagonal
* so that the matrix has norm TNORM+1.
*
IF( KD.EQ.1 ) THEN
IF( UPPER ) THEN
AB( 1, 2 ) = SIGN( TNORM, SLARND( 2, ISEED ) )
LENJ = ( N-3 ) / 2
CALL SLARNV( 2, ISEED, LENJ, WORK )
DO 90 J = 1, LENJ
AB( 1, 2*( J+1 ) ) = TNORM*WORK( J )
90 CONTINUE
ELSE
AB( 2, 1 ) = SIGN( TNORM, SLARND( 2, ISEED ) )
LENJ = ( N-3 ) / 2
CALL SLARNV( 2, ISEED, LENJ, WORK )
DO 100 J = 1, LENJ
AB( 2, 2*J+1 ) = TNORM*WORK( J )
100 CONTINUE
END IF
ELSE IF( KD.GT.1 ) THEN
*
* Form a unit triangular matrix T with condition CNDNUM. T is
* given by
* | 1 + * |
* | 1 + |
* T = | 1 + * |
* | 1 + |
* | 1 + * |
* | 1 + |
* | . . . |
* Each element marked with a '*' is formed by taking the product
* of the adjacent elements marked with '+'. The '*'s can be
* chosen freely, and the '+'s are chosen so that the inverse of
* T will have elements of the same magnitude as T.
*
* The two offdiagonals of T are stored in WORK.
*
STAR1 = SIGN( TNORM, SLARND( 2, ISEED ) )
SFAC = SQRT( TNORM )
PLUS1 = SIGN( SFAC, SLARND( 2, ISEED ) )
DO 110 J = 1, N, 2
PLUS2 = STAR1 / PLUS1
WORK( J ) = PLUS1
WORK( N+J ) = STAR1
IF( J+1.LE.N ) THEN
WORK( J+1 ) = PLUS2
WORK( N+J+1 ) = ZERO
PLUS1 = STAR1 / PLUS2
*
* Generate a new *-value with norm between sqrt(TNORM)
* and TNORM.
*
REXP = SLARND( 2, ISEED )
IF( REXP.LT.ZERO ) THEN
STAR1 = -SFAC**( ONE-REXP )
ELSE
STAR1 = SFAC**( ONE+REXP )
END IF
END IF
110 CONTINUE
*
* Copy the tridiagonal T to AB.
*
IF( UPPER ) THEN
CALL SCOPY( N-1, WORK, 1, AB( KD, 2 ), LDAB )
CALL SCOPY( N-2, WORK( N+1 ), 1, AB( KD-1, 3 ), LDAB )
ELSE
CALL SCOPY( N-1, WORK, 1, AB( 2, 1 ), LDAB )
CALL SCOPY( N-2, WORK( N+1 ), 1, AB( 3, 1 ), LDAB )
END IF
END IF
*
* IMAT > 9: Pathological test cases. These triangular matrices
* are badly scaled or badly conditioned, so when used in solving a
* triangular system they may cause overflow in the solution vector.
*
ELSE IF( IMAT.EQ.10 ) THEN
*
* Type 10: Generate a triangular matrix with elements between
* -1 and 1. Give the diagonal norm 2 to make it well-conditioned.
* Make the right hand side large so that it requires scaling.
*
IF( UPPER ) THEN
DO 120 J = 1, N
LENJ = MIN( J, KD+1 )
CALL SLARNV( 2, ISEED, LENJ, AB( KD+2-LENJ, J ) )
AB( KD+1, J ) = SIGN( TWO, AB( KD+1, J ) )
120 CONTINUE
ELSE
DO 130 J = 1, N
LENJ = MIN( N-J+1, KD+1 )
IF( LENJ.GT.0 )
$ CALL SLARNV( 2, ISEED, LENJ, AB( 1, J ) )
AB( 1, J ) = SIGN( TWO, AB( 1, J ) )
130 CONTINUE
END IF
*
* Set the right hand side so that the largest value is BIGNUM.
*
CALL SLARNV( 2, ISEED, N, B )
IY = ISAMAX( N, B, 1 )
BNORM = ABS( B( IY ) )
BSCAL = BIGNUM / MAX( ONE, BNORM )
CALL SSCAL( N, BSCAL, B, 1 )
*
ELSE IF( IMAT.EQ.11 ) THEN
*
* Type 11: Make the first diagonal element in the solve small to
* cause immediate overflow when dividing by T(j,j).
* In type 11, the offdiagonal elements are small (CNORM(j) < 1).
*
CALL SLARNV( 2, ISEED, N, B )
TSCAL = ONE / REAL( KD+1 )
IF( UPPER ) THEN
DO 140 J = 1, N
LENJ = MIN( J, KD+1 )
CALL SLARNV( 2, ISEED, LENJ, AB( KD+2-LENJ, J ) )
CALL SSCAL( LENJ-1, TSCAL, AB( KD+2-LENJ, J ), 1 )
AB( KD+1, J ) = SIGN( ONE, AB( KD+1, J ) )
140 CONTINUE
AB( KD+1, N ) = SMLNUM*AB( KD+1, N )
ELSE
DO 150 J = 1, N
LENJ = MIN( N-J+1, KD+1 )
CALL SLARNV( 2, ISEED, LENJ, AB( 1, J ) )
IF( LENJ.GT.1 )
$ CALL SSCAL( LENJ-1, TSCAL, AB( 2, J ), 1 )
AB( 1, J ) = SIGN( ONE, AB( 1, J ) )
150 CONTINUE
AB( 1, 1 ) = SMLNUM*AB( 1, 1 )
END IF
*
ELSE IF( IMAT.EQ.12 ) THEN
*
* Type 12: Make the first diagonal element in the solve small to
* cause immediate overflow when dividing by T(j,j).
* In type 12, the offdiagonal elements are O(1) (CNORM(j) > 1).
*
CALL SLARNV( 2, ISEED, N, B )
IF( UPPER ) THEN
DO 160 J = 1, N
LENJ = MIN( J, KD+1 )
CALL SLARNV( 2, ISEED, LENJ, AB( KD+2-LENJ, J ) )
AB( KD+1, J ) = SIGN( ONE, AB( KD+1, J ) )
160 CONTINUE
AB( KD+1, N ) = SMLNUM*AB( KD+1, N )
ELSE
DO 170 J = 1, N
LENJ = MIN( N-J+1, KD+1 )
CALL SLARNV( 2, ISEED, LENJ, AB( 1, J ) )
AB( 1, J ) = SIGN( ONE, AB( 1, J ) )
170 CONTINUE
AB( 1, 1 ) = SMLNUM*AB( 1, 1 )
END IF
*
ELSE IF( IMAT.EQ.13 ) THEN
*
* Type 13: T is diagonal with small numbers on the diagonal to
* make the growth factor underflow, but a small right hand side
* chosen so that the solution does not overflow.
*
IF( UPPER ) THEN
JCOUNT = 1
DO 190 J = N, 1, -1
DO 180 I = MAX( 1, KD+1-( J-1 ) ), KD
AB( I, J ) = ZERO
180 CONTINUE
IF( JCOUNT.LE.2 ) THEN
AB( KD+1, J ) = SMLNUM
ELSE
AB( KD+1, J ) = ONE
END IF
JCOUNT = JCOUNT + 1
IF( JCOUNT.GT.4 )
$ JCOUNT = 1
190 CONTINUE
ELSE
JCOUNT = 1
DO 210 J = 1, N
DO 200 I = 2, MIN( N-J+1, KD+1 )
AB( I, J ) = ZERO
200 CONTINUE
IF( JCOUNT.LE.2 ) THEN
AB( 1, J ) = SMLNUM
ELSE
AB( 1, J ) = ONE
END IF
JCOUNT = JCOUNT + 1
IF( JCOUNT.GT.4 )
$ JCOUNT = 1
210 CONTINUE
END IF
*
* Set the right hand side alternately zero and small.
*
IF( UPPER ) THEN
B( 1 ) = ZERO
DO 220 I = N, 2, -2
B( I ) = ZERO
B( I-1 ) = SMLNUM
220 CONTINUE
ELSE
B( N ) = ZERO
DO 230 I = 1, N - 1, 2
B( I ) = ZERO
B( I+1 ) = SMLNUM
230 CONTINUE
END IF
*
ELSE IF( IMAT.EQ.14 ) THEN
*
* Type 14: Make the diagonal elements small to cause gradual
* overflow when dividing by T(j,j). To control the amount of
* scaling needed, the matrix is bidiagonal.
*
TEXP = ONE / REAL( KD+1 )
TSCAL = SMLNUM**TEXP
CALL SLARNV( 2, ISEED, N, B )
IF( UPPER ) THEN
DO 250 J = 1, N
DO 240 I = MAX( 1, KD+2-J ), KD
AB( I, J ) = ZERO
240 CONTINUE
IF( J.GT.1 .AND. KD.GT.0 )
$ AB( KD, J ) = -ONE
AB( KD+1, J ) = TSCAL
250 CONTINUE
B( N ) = ONE
ELSE
DO 270 J = 1, N
DO 260 I = 3, MIN( N-J+1, KD+1 )
AB( I, J ) = ZERO
260 CONTINUE
IF( J.LT.N .AND. KD.GT.0 )
$ AB( 2, J ) = -ONE
AB( 1, J ) = TSCAL
270 CONTINUE
B( 1 ) = ONE
END IF
*
ELSE IF( IMAT.EQ.15 ) THEN
*
* Type 15: One zero diagonal element.
*
IY = N / 2 + 1
IF( UPPER ) THEN
DO 280 J = 1, N
LENJ = MIN( J, KD+1 )
CALL SLARNV( 2, ISEED, LENJ, AB( KD+2-LENJ, J ) )
IF( J.NE.IY ) THEN
AB( KD+1, J ) = SIGN( TWO, AB( KD+1, J ) )
ELSE
AB( KD+1, J ) = ZERO
END IF
280 CONTINUE
ELSE
DO 290 J = 1, N
LENJ = MIN( N-J+1, KD+1 )
CALL SLARNV( 2, ISEED, LENJ, AB( 1, J ) )
IF( J.NE.IY ) THEN
AB( 1, J ) = SIGN( TWO, AB( 1, J ) )
ELSE
AB( 1, J ) = ZERO
END IF
290 CONTINUE
END IF
CALL SLARNV( 2, ISEED, N, B )
CALL SSCAL( N, TWO, B, 1 )
*
ELSE IF( IMAT.EQ.16 ) THEN
*
* Type 16: Make the offdiagonal elements large to cause overflow
* when adding a column of T. In the non-transposed case, the
* matrix is constructed to cause overflow when adding a column in
* every other step.
*
TSCAL = UNFL / ULP
TSCAL = ( ONE-ULP ) / TSCAL
DO 310 J = 1, N
DO 300 I = 1, KD + 1
AB( I, J ) = ZERO
300 CONTINUE
310 CONTINUE
TEXP = ONE
IF( KD.GT.0 ) THEN
IF( UPPER ) THEN
DO 330 J = N, 1, -KD
DO 320 I = J, MAX( 1, J-KD+1 ), -2
AB( 1+( J-I ), I ) = -TSCAL / REAL( KD+2 )
AB( KD+1, I ) = ONE
B( I ) = TEXP*( ONE-ULP )
IF( I.GT.MAX( 1, J-KD+1 ) ) THEN
AB( 2+( J-I ), I-1 ) = -( TSCAL / REAL( KD+2 ) )
$ / REAL( KD+3 )
AB( KD+1, I-1 ) = ONE
B( I-1 ) = TEXP*REAL( ( KD+1 )*( KD+1 )+KD )
END IF
TEXP = TEXP*TWO
320 CONTINUE
B( MAX( 1, J-KD+1 ) ) = ( REAL( KD+2 ) /
$ REAL( KD+3 ) )*TSCAL
330 CONTINUE
ELSE
DO 350 J = 1, N, KD
TEXP = ONE
LENJ = MIN( KD+1, N-J+1 )
DO 340 I = J, MIN( N, J+KD-1 ), 2
AB( LENJ-( I-J ), J ) = -TSCAL / REAL( KD+2 )
AB( 1, J ) = ONE
B( J ) = TEXP*( ONE-ULP )
IF( I.LT.MIN( N, J+KD-1 ) ) THEN
AB( LENJ-( I-J+1 ), I+1 ) = -( TSCAL /
$ REAL( KD+2 ) ) / REAL( KD+3 )
AB( 1, I+1 ) = ONE
B( I+1 ) = TEXP*REAL( ( KD+1 )*( KD+1 )+KD )
END IF
TEXP = TEXP*TWO
340 CONTINUE
B( MIN( N, J+KD-1 ) ) = ( REAL( KD+2 ) /
$ REAL( KD+3 ) )*TSCAL
350 CONTINUE
END IF
ELSE
DO 360 J = 1, N
AB( 1, J ) = ONE
B( J ) = REAL( J )
360 CONTINUE
END IF
*
ELSE IF( IMAT.EQ.17 ) THEN
*
* Type 17: Generate a unit triangular matrix with elements
* between -1 and 1, and make the right hand side large so that it
* requires scaling.
*
IF( UPPER ) THEN
DO 370 J = 1, N
LENJ = MIN( J-1, KD )
CALL SLARNV( 2, ISEED, LENJ, AB( KD+1-LENJ, J ) )
AB( KD+1, J ) = REAL( J )
370 CONTINUE
ELSE
DO 380 J = 1, N
LENJ = MIN( N-J, KD )
IF( LENJ.GT.0 )
$ CALL SLARNV( 2, ISEED, LENJ, AB( 2, J ) )
AB( 1, J ) = REAL( J )
380 CONTINUE
END IF
*
* Set the right hand side so that the largest value is BIGNUM.
*
CALL SLARNV( 2, ISEED, N, B )
IY = ISAMAX( N, B, 1 )
BNORM = ABS( B( IY ) )
BSCAL = BIGNUM / MAX( ONE, BNORM )
CALL SSCAL( N, BSCAL, B, 1 )
*
ELSE IF( IMAT.EQ.18 ) THEN
*
* Type 18: Generate a triangular matrix with elements between
* BIGNUM/KD and BIGNUM so that at least one of the column
* norms will exceed BIGNUM.
*
TLEFT = BIGNUM / MAX( ONE, REAL( KD ) )
TSCAL = BIGNUM*( REAL( KD ) / REAL( KD+1 ) )
IF( UPPER ) THEN
DO 400 J = 1, N
LENJ = MIN( J, KD+1 )
CALL SLARNV( 2, ISEED, LENJ, AB( KD+2-LENJ, J ) )
DO 390 I = KD + 2 - LENJ, KD + 1
AB( I, J ) = SIGN( TLEFT, AB( I, J ) ) +
$ TSCAL*AB( I, J )
390 CONTINUE
400 CONTINUE
ELSE
DO 420 J = 1, N
LENJ = MIN( N-J+1, KD+1 )
CALL SLARNV( 2, ISEED, LENJ, AB( 1, J ) )
DO 410 I = 1, LENJ
AB( I, J ) = SIGN( TLEFT, AB( I, J ) ) +
$ TSCAL*AB( I, J )
410 CONTINUE
420 CONTINUE
END IF
CALL SLARNV( 2, ISEED, N, B )
CALL SSCAL( N, TWO, B, 1 )
END IF
*
* Flip the matrix if the transpose will be used.
*
IF( .NOT.LSAME( TRANS, 'N' ) ) THEN
IF( UPPER ) THEN
DO 430 J = 1, N / 2
LENJ = MIN( N-2*J+1, KD+1 )
CALL SSWAP( LENJ, AB( KD+1, J ), LDAB-1,
$ AB( KD+2-LENJ, N-J+1 ), -1 )
430 CONTINUE
ELSE
DO 440 J = 1, N / 2
LENJ = MIN( N-2*J+1, KD+1 )
CALL SSWAP( LENJ, AB( 1, J ), 1, AB( LENJ, N-J+2-LENJ ),
$ -LDAB+1 )
440 CONTINUE
END IF
END IF
*
RETURN
*
* End of SLATTB
*
END
SUBROUTINE SLATTP( IMAT, UPLO, TRANS, DIAG, ISEED, N, A, B, WORK,
$ INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER IMAT, INFO, N
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
REAL A( * ), B( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SLATTP generates a triangular test matrix in packed storage.
* IMAT and UPLO uniquely specify the properties of the test
* matrix, which is returned in the array AP.
*
* Arguments
* =========
*
* IMAT (input) INTEGER
* An integer key describing which matrix to generate for this
* path.
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A will be upper or lower
* triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies whether the matrix or its transpose will be used.
* = 'N': No transpose
* = 'T': Transpose
* = 'C': Conjugate transpose (= Transpose)
*
* DIAG (output) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* ISEED (input/output) INTEGER array, dimension (4)
* The seed vector for the random number generator (used in
* SLATMS). Modified on exit.
*
* N (input) INTEGER
* The order of the matrix to be generated.
*
* A (output) REAL array, dimension (N*(N+1)/2)
* The upper or lower triangular matrix A, packed columnwise in
* a linear array. The j-th column of A is stored in the array
* AP as follows:
* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j;
* if UPLO = 'L',
* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n.
*
* B (output) REAL array, dimension (N)
* The right hand side vector, if IMAT > 10.
*
* WORK (workspace) REAL array, dimension (3*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, TWO, ZERO
PARAMETER ( ONE = 1.0E+0, TWO = 2.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
CHARACTER DIST, PACKIT, TYPE
CHARACTER*3 PATH
INTEGER I, IY, J, JC, JCNEXT, JCOUNT, JJ, JL, JR, JX,
$ KL, KU, MODE
REAL ANORM, BIGNUM, BNORM, BSCAL, C, CNDNUM, PLUS1,
$ PLUS2, RA, RB, REXP, S, SFAC, SMLNUM, STAR1,
$ STEMP, T, TEXP, TLEFT, TSCAL, ULP, UNFL, X, Y,
$ Z
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SLAMCH, SLARND
EXTERNAL LSAME, ISAMAX, SLAMCH, SLARND
* ..
* .. External Subroutines ..
EXTERNAL SLABAD, SLARNV, SLATB4, SLATMS, SROT, SROTG,
$ SSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, REAL, SIGN, SQRT
* ..
* .. Executable Statements ..
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'TP'
UNFL = SLAMCH( 'Safe minimum' )
ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
SMLNUM = UNFL
BIGNUM = ( ONE-ULP ) / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
IF( ( IMAT.GE.7 .AND. IMAT.LE.10 ) .OR. IMAT.EQ.18 ) THEN
DIAG = 'U'
ELSE
DIAG = 'N'
END IF
INFO = 0
*
* Quick return if N.LE.0.
*
IF( N.LE.0 )
$ RETURN
*
* Call SLATB4 to set parameters for SLATMS.
*
UPPER = LSAME( UPLO, 'U' )
IF( UPPER ) THEN
CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
PACKIT = 'C'
ELSE
CALL SLATB4( PATH, -IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
PACKIT = 'R'
END IF
*
* IMAT <= 6: Non-unit triangular matrix
*
IF( IMAT.LE.6 ) THEN
CALL SLATMS( N, N, DIST, ISEED, TYPE, B, MODE, CNDNUM, ANORM,
$ KL, KU, PACKIT, A, N, WORK, INFO )
*
* IMAT > 6: Unit triangular matrix
* The diagonal is deliberately set to something other than 1.
*
* IMAT = 7: Matrix is the identity
*
ELSE IF( IMAT.EQ.7 ) THEN
IF( UPPER ) THEN
JC = 1
DO 20 J = 1, N
DO 10 I = 1, J - 1
A( JC+I-1 ) = ZERO
10 CONTINUE
A( JC+J-1 ) = J
JC = JC + J
20 CONTINUE
ELSE
JC = 1
DO 40 J = 1, N
A( JC ) = J
DO 30 I = J + 1, N
A( JC+I-J ) = ZERO
30 CONTINUE
JC = JC + N - J + 1
40 CONTINUE
END IF
*
* IMAT > 7: Non-trivial unit triangular matrix
*
* Generate a unit triangular matrix T with condition CNDNUM by
* forming a triangular matrix with known singular values and
* filling in the zero entries with Givens rotations.
*
ELSE IF( IMAT.LE.10 ) THEN
IF( UPPER ) THEN
JC = 0
DO 60 J = 1, N
DO 50 I = 1, J - 1
A( JC+I ) = ZERO
50 CONTINUE
A( JC+J ) = J
JC = JC + J
60 CONTINUE
ELSE
JC = 1
DO 80 J = 1, N
A( JC ) = J
DO 70 I = J + 1, N
A( JC+I-J ) = ZERO
70 CONTINUE
JC = JC + N - J + 1
80 CONTINUE
END IF
*
* Since the trace of a unit triangular matrix is 1, the product
* of its singular values must be 1. Let s = sqrt(CNDNUM),
* x = sqrt(s) - 1/sqrt(s), y = sqrt(2/(n-2))*x, and z = x**2.
* The following triangular matrix has singular values s, 1, 1,
* ..., 1, 1/s:
*
* 1 y y y ... y y z
* 1 0 0 ... 0 0 y
* 1 0 ... 0 0 y
* . ... . . .
* . . . .
* 1 0 y
* 1 y
* 1
*
* To fill in the zeros, we first multiply by a matrix with small
* condition number of the form
*
* 1 0 0 0 0 ...
* 1 + * 0 0 ...
* 1 + 0 0 0
* 1 + * 0 0
* 1 + 0 0
* ...
* 1 + 0
* 1 0
* 1
*
* Each element marked with a '*' is formed by taking the product
* of the adjacent elements marked with '+'. The '*'s can be
* chosen freely, and the '+'s are chosen so that the inverse of
* T will have elements of the same magnitude as T. If the *'s in
* both T and inv(T) have small magnitude, T is well conditioned.
* The two offdiagonals of T are stored in WORK.
*
* The product of these two matrices has the form
*
* 1 y y y y y . y y z
* 1 + * 0 0 . 0 0 y
* 1 + 0 0 . 0 0 y
* 1 + * . . . .
* 1 + . . . .
* . . . . .
* . . . .
* 1 + y
* 1 y
* 1
*
* Now we multiply by Givens rotations, using the fact that
*
* [ c s ] [ 1 w ] [ -c -s ] = [ 1 -w ]
* [ -s c ] [ 0 1 ] [ s -c ] [ 0 1 ]
* and
* [ -c -s ] [ 1 0 ] [ c s ] = [ 1 0 ]
* [ s -c ] [ w 1 ] [ -s c ] [ -w 1 ]
*
* where c = w / sqrt(w**2+4) and s = 2 / sqrt(w**2+4).
*
STAR1 = 0.25
SFAC = 0.5
PLUS1 = SFAC
DO 90 J = 1, N, 2
PLUS2 = STAR1 / PLUS1
WORK( J ) = PLUS1
WORK( N+J ) = STAR1
IF( J+1.LE.N ) THEN
WORK( J+1 ) = PLUS2
WORK( N+J+1 ) = ZERO
PLUS1 = STAR1 / PLUS2
REXP = SLARND( 2, ISEED )
STAR1 = STAR1*( SFAC**REXP )
IF( REXP.LT.ZERO ) THEN
STAR1 = -SFAC**( ONE-REXP )
ELSE
STAR1 = SFAC**( ONE+REXP )
END IF
END IF
90 CONTINUE
*
X = SQRT( CNDNUM ) - ONE / SQRT( CNDNUM )
IF( N.GT.2 ) THEN
Y = SQRT( TWO / REAL( N-2 ) )*X
ELSE
Y = ZERO
END IF
Z = X*X
*
IF( UPPER ) THEN
*
* Set the upper triangle of A with a unit triangular matrix
* of known condition number.
*
JC = 1
DO 100 J = 2, N
A( JC+1 ) = Y
IF( J.GT.2 )
$ A( JC+J-1 ) = WORK( J-2 )
IF( J.GT.3 )
$ A( JC+J-2 ) = WORK( N+J-3 )
JC = JC + J
100 CONTINUE
JC = JC - N
A( JC+1 ) = Z
DO 110 J = 2, N - 1
A( JC+J ) = Y
110 CONTINUE
ELSE
*
* Set the lower triangle of A with a unit triangular matrix
* of known condition number.
*
DO 120 I = 2, N - 1
A( I ) = Y
120 CONTINUE
A( N ) = Z
JC = N + 1
DO 130 J = 2, N - 1
A( JC+1 ) = WORK( J-1 )
IF( J.LT.N-1 )
$ A( JC+2 ) = WORK( N+J-1 )
A( JC+N-J ) = Y
JC = JC + N - J + 1
130 CONTINUE
END IF
*
* Fill in the zeros using Givens rotations
*
IF( UPPER ) THEN
JC = 1
DO 150 J = 1, N - 1
JCNEXT = JC + J
RA = A( JCNEXT+J-1 )
RB = TWO
CALL SROTG( RA, RB, C, S )
*
* Multiply by [ c s; -s c] on the left.
*
IF( N.GT.J+1 ) THEN
JX = JCNEXT + J
DO 140 I = J + 2, N
STEMP = C*A( JX+J ) + S*A( JX+J+1 )
A( JX+J+1 ) = -S*A( JX+J ) + C*A( JX+J+1 )
A( JX+J ) = STEMP
JX = JX + I
140 CONTINUE
END IF
*
* Multiply by [-c -s; s -c] on the right.
*
IF( J.GT.1 )
$ CALL SROT( J-1, A( JCNEXT ), 1, A( JC ), 1, -C, -S )
*
* Negate A(J,J+1).
*
A( JCNEXT+J-1 ) = -A( JCNEXT+J-1 )
JC = JCNEXT
150 CONTINUE
ELSE
JC = 1
DO 170 J = 1, N - 1
JCNEXT = JC + N - J + 1
RA = A( JC+1 )
RB = TWO
CALL SROTG( RA, RB, C, S )
*
* Multiply by [ c -s; s c] on the right.
*
IF( N.GT.J+1 )
$ CALL SROT( N-J-1, A( JCNEXT+1 ), 1, A( JC+2 ), 1, C,
$ -S )
*
* Multiply by [-c s; -s -c] on the left.
*
IF( J.GT.1 ) THEN
JX = 1
DO 160 I = 1, J - 1
STEMP = -C*A( JX+J-I ) + S*A( JX+J-I+1 )
A( JX+J-I+1 ) = -S*A( JX+J-I ) - C*A( JX+J-I+1 )
A( JX+J-I ) = STEMP
JX = JX + N - I + 1
160 CONTINUE
END IF
*
* Negate A(J+1,J).
*
A( JC+1 ) = -A( JC+1 )
JC = JCNEXT
170 CONTINUE
END IF
*
* IMAT > 10: Pathological test cases. These triangular matrices
* are badly scaled or badly conditioned, so when used in solving a
* triangular system they may cause overflow in the solution vector.
*
ELSE IF( IMAT.EQ.11 ) THEN
*
* Type 11: Generate a triangular matrix with elements between
* -1 and 1. Give the diagonal norm 2 to make it well-conditioned.
* Make the right hand side large so that it requires scaling.
*
IF( UPPER ) THEN
JC = 1
DO 180 J = 1, N
CALL SLARNV( 2, ISEED, J, A( JC ) )
A( JC+J-1 ) = SIGN( TWO, A( JC+J-1 ) )
JC = JC + J
180 CONTINUE
ELSE
JC = 1
DO 190 J = 1, N
CALL SLARNV( 2, ISEED, N-J+1, A( JC ) )
A( JC ) = SIGN( TWO, A( JC ) )
JC = JC + N - J + 1
190 CONTINUE
END IF
*
* Set the right hand side so that the largest value is BIGNUM.
*
CALL SLARNV( 2, ISEED, N, B )
IY = ISAMAX( N, B, 1 )
BNORM = ABS( B( IY ) )
BSCAL = BIGNUM / MAX( ONE, BNORM )
CALL SSCAL( N, BSCAL, B, 1 )
*
ELSE IF( IMAT.EQ.12 ) THEN
*
* Type 12: Make the first diagonal element in the solve small to
* cause immediate overflow when dividing by T(j,j).
* In type 12, the offdiagonal elements are small (CNORM(j) < 1).
*
CALL SLARNV( 2, ISEED, N, B )
TSCAL = ONE / MAX( ONE, REAL( N-1 ) )
IF( UPPER ) THEN
JC = 1
DO 200 J = 1, N
CALL SLARNV( 2, ISEED, J-1, A( JC ) )
CALL SSCAL( J-1, TSCAL, A( JC ), 1 )
A( JC+J-1 ) = SIGN( ONE, SLARND( 2, ISEED ) )
JC = JC + J
200 CONTINUE
A( N*( N+1 ) / 2 ) = SMLNUM
ELSE
JC = 1
DO 210 J = 1, N
CALL SLARNV( 2, ISEED, N-J, A( JC+1 ) )
CALL SSCAL( N-J, TSCAL, A( JC+1 ), 1 )
A( JC ) = SIGN( ONE, SLARND( 2, ISEED ) )
JC = JC + N - J + 1
210 CONTINUE
A( 1 ) = SMLNUM
END IF
*
ELSE IF( IMAT.EQ.13 ) THEN
*
* Type 13: Make the first diagonal element in the solve small to
* cause immediate overflow when dividing by T(j,j).
* In type 13, the offdiagonal elements are O(1) (CNORM(j) > 1).
*
CALL SLARNV( 2, ISEED, N, B )
IF( UPPER ) THEN
JC = 1
DO 220 J = 1, N
CALL SLARNV( 2, ISEED, J-1, A( JC ) )
A( JC+J-1 ) = SIGN( ONE, SLARND( 2, ISEED ) )
JC = JC + J
220 CONTINUE
A( N*( N+1 ) / 2 ) = SMLNUM
ELSE
JC = 1
DO 230 J = 1, N
CALL SLARNV( 2, ISEED, N-J, A( JC+1 ) )
A( JC ) = SIGN( ONE, SLARND( 2, ISEED ) )
JC = JC + N - J + 1
230 CONTINUE
A( 1 ) = SMLNUM
END IF
*
ELSE IF( IMAT.EQ.14 ) THEN
*
* Type 14: T is diagonal with small numbers on the diagonal to
* make the growth factor underflow, but a small right hand side
* chosen so that the solution does not overflow.
*
IF( UPPER ) THEN
JCOUNT = 1
JC = ( N-1 )*N / 2 + 1
DO 250 J = N, 1, -1
DO 240 I = 1, J - 1
A( JC+I-1 ) = ZERO
240 CONTINUE
IF( JCOUNT.LE.2 ) THEN
A( JC+J-1 ) = SMLNUM
ELSE
A( JC+J-1 ) = ONE
END IF
JCOUNT = JCOUNT + 1
IF( JCOUNT.GT.4 )
$ JCOUNT = 1
JC = JC - J + 1
250 CONTINUE
ELSE
JCOUNT = 1
JC = 1
DO 270 J = 1, N
DO 260 I = J + 1, N
A( JC+I-J ) = ZERO
260 CONTINUE
IF( JCOUNT.LE.2 ) THEN
A( JC ) = SMLNUM
ELSE
A( JC ) = ONE
END IF
JCOUNT = JCOUNT + 1
IF( JCOUNT.GT.4 )
$ JCOUNT = 1
JC = JC + N - J + 1
270 CONTINUE
END IF
*
* Set the right hand side alternately zero and small.
*
IF( UPPER ) THEN
B( 1 ) = ZERO
DO 280 I = N, 2, -2
B( I ) = ZERO
B( I-1 ) = SMLNUM
280 CONTINUE
ELSE
B( N ) = ZERO
DO 290 I = 1, N - 1, 2
B( I ) = ZERO
B( I+1 ) = SMLNUM
290 CONTINUE
END IF
*
ELSE IF( IMAT.EQ.15 ) THEN
*
* Type 15: Make the diagonal elements small to cause gradual
* overflow when dividing by T(j,j). To control the amount of
* scaling needed, the matrix is bidiagonal.
*
TEXP = ONE / MAX( ONE, REAL( N-1 ) )
TSCAL = SMLNUM**TEXP
CALL SLARNV( 2, ISEED, N, B )
IF( UPPER ) THEN
JC = 1
DO 310 J = 1, N
DO 300 I = 1, J - 2
A( JC+I-1 ) = ZERO
300 CONTINUE
IF( J.GT.1 )
$ A( JC+J-2 ) = -ONE
A( JC+J-1 ) = TSCAL
JC = JC + J
310 CONTINUE
B( N ) = ONE
ELSE
JC = 1
DO 330 J = 1, N
DO 320 I = J + 2, N
A( JC+I-J ) = ZERO
320 CONTINUE
IF( J.LT.N )
$ A( JC+1 ) = -ONE
A( JC ) = TSCAL
JC = JC + N - J + 1
330 CONTINUE
B( 1 ) = ONE
END IF
*
ELSE IF( IMAT.EQ.16 ) THEN
*
* Type 16: One zero diagonal element.
*
IY = N / 2 + 1
IF( UPPER ) THEN
JC = 1
DO 340 J = 1, N
CALL SLARNV( 2, ISEED, J, A( JC ) )
IF( J.NE.IY ) THEN
A( JC+J-1 ) = SIGN( TWO, A( JC+J-1 ) )
ELSE
A( JC+J-1 ) = ZERO
END IF
JC = JC + J
340 CONTINUE
ELSE
JC = 1
DO 350 J = 1, N
CALL SLARNV( 2, ISEED, N-J+1, A( JC ) )
IF( J.NE.IY ) THEN
A( JC ) = SIGN( TWO, A( JC ) )
ELSE
A( JC ) = ZERO
END IF
JC = JC + N - J + 1
350 CONTINUE
END IF
CALL SLARNV( 2, ISEED, N, B )
CALL SSCAL( N, TWO, B, 1 )
*
ELSE IF( IMAT.EQ.17 ) THEN
*
* Type 17: Make the offdiagonal elements large to cause overflow
* when adding a column of T. In the non-transposed case, the
* matrix is constructed to cause overflow when adding a column in
* every other step.
*
TSCAL = UNFL / ULP
TSCAL = ( ONE-ULP ) / TSCAL
DO 360 J = 1, N*( N+1 ) / 2
A( J ) = ZERO
360 CONTINUE
TEXP = ONE
IF( UPPER ) THEN
JC = ( N-1 )*N / 2 + 1
DO 370 J = N, 2, -2
A( JC ) = -TSCAL / REAL( N+1 )
A( JC+J-1 ) = ONE
B( J ) = TEXP*( ONE-ULP )
JC = JC - J + 1
A( JC ) = -( TSCAL / REAL( N+1 ) ) / REAL( N+2 )
A( JC+J-2 ) = ONE
B( J-1 ) = TEXP*REAL( N*N+N-1 )
TEXP = TEXP*TWO
JC = JC - J + 2
370 CONTINUE
B( 1 ) = ( REAL( N+1 ) / REAL( N+2 ) )*TSCAL
ELSE
JC = 1
DO 380 J = 1, N - 1, 2
A( JC+N-J ) = -TSCAL / REAL( N+1 )
A( JC ) = ONE
B( J ) = TEXP*( ONE-ULP )
JC = JC + N - J + 1
A( JC+N-J-1 ) = -( TSCAL / REAL( N+1 ) ) / REAL( N+2 )
A( JC ) = ONE
B( J+1 ) = TEXP*REAL( N*N+N-1 )
TEXP = TEXP*TWO
JC = JC + N - J
380 CONTINUE
B( N ) = ( REAL( N+1 ) / REAL( N+2 ) )*TSCAL
END IF
*
ELSE IF( IMAT.EQ.18 ) THEN
*
* Type 18: Generate a unit triangular matrix with elements
* between -1 and 1, and make the right hand side large so that it
* requires scaling.
*
IF( UPPER ) THEN
JC = 1
DO 390 J = 1, N
CALL SLARNV( 2, ISEED, J-1, A( JC ) )
A( JC+J-1 ) = ZERO
JC = JC + J
390 CONTINUE
ELSE
JC = 1
DO 400 J = 1, N
IF( J.LT.N )
$ CALL SLARNV( 2, ISEED, N-J, A( JC+1 ) )
A( JC ) = ZERO
JC = JC + N - J + 1
400 CONTINUE
END IF
*
* Set the right hand side so that the largest value is BIGNUM.
*
CALL SLARNV( 2, ISEED, N, B )
IY = ISAMAX( N, B, 1 )
BNORM = ABS( B( IY ) )
BSCAL = BIGNUM / MAX( ONE, BNORM )
CALL SSCAL( N, BSCAL, B, 1 )
*
ELSE IF( IMAT.EQ.19 ) THEN
*
* Type 19: Generate a triangular matrix with elements between
* BIGNUM/(n-1) and BIGNUM so that at least one of the column
* norms will exceed BIGNUM.
*
TLEFT = BIGNUM / MAX( ONE, REAL( N-1 ) )
TSCAL = BIGNUM*( REAL( N-1 ) / MAX( ONE, REAL( N ) ) )
IF( UPPER ) THEN
JC = 1
DO 420 J = 1, N
CALL SLARNV( 2, ISEED, J, A( JC ) )
DO 410 I = 1, J
A( JC+I-1 ) = SIGN( TLEFT, A( JC+I-1 ) ) +
$ TSCAL*A( JC+I-1 )
410 CONTINUE
JC = JC + J
420 CONTINUE
ELSE
JC = 1
DO 440 J = 1, N
CALL SLARNV( 2, ISEED, N-J+1, A( JC ) )
DO 430 I = J, N
A( JC+I-J ) = SIGN( TLEFT, A( JC+I-J ) ) +
$ TSCAL*A( JC+I-J )
430 CONTINUE
JC = JC + N - J + 1
440 CONTINUE
END IF
CALL SLARNV( 2, ISEED, N, B )
CALL SSCAL( N, TWO, B, 1 )
END IF
*
* Flip the matrix across its counter-diagonal if the transpose will
* be used.
*
IF( .NOT.LSAME( TRANS, 'N' ) ) THEN
IF( UPPER ) THEN
JJ = 1
JR = N*( N+1 ) / 2
DO 460 J = 1, N / 2
JL = JJ
DO 450 I = J, N - J
T = A( JR-I+J )
A( JR-I+J ) = A( JL )
A( JL ) = T
JL = JL + I
450 CONTINUE
JJ = JJ + J + 1
JR = JR - ( N-J+1 )
460 CONTINUE
ELSE
JL = 1
JJ = N*( N+1 ) / 2
DO 480 J = 1, N / 2
JR = JJ
DO 470 I = J, N - J
T = A( JL+I-J )
A( JL+I-J ) = A( JR )
A( JR ) = T
JR = JR - I
470 CONTINUE
JL = JL + N - J + 1
JJ = JJ - J - 1
480 CONTINUE
END IF
END IF
*
RETURN
*
* End of SLATTP
*
END
SUBROUTINE SLATTR( IMAT, UPLO, TRANS, DIAG, ISEED, N, A, LDA, B,
$ WORK, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER IMAT, INFO, LDA, N
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
REAL A( LDA, * ), B( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SLATTR generates a triangular test matrix.
* IMAT and UPLO uniquely specify the properties of the test
* matrix, which is returned in the array A.
*
* Arguments
* =========
*
* IMAT (input) INTEGER
* An integer key describing which matrix to generate for this
* path.
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A will be upper or lower
* triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies whether the matrix or its transpose will be used.
* = 'N': No transpose
* = 'T': Transpose
* = 'C': Conjugate transpose (= Transpose)
*
* DIAG (output) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* ISEED (input/output) INTEGER array, dimension (4)
* The seed vector for the random number generator (used in
* SLATMS). Modified on exit.
*
* N (input) INTEGER
* The order of the matrix to be generated.
*
* A (output) REAL array, dimension (LDA,N)
* The triangular matrix A. If UPLO = 'U', the leading n by n
* upper triangular part of the array A contains the upper
* triangular matrix, and the strictly lower triangular part of
* A is not referenced. If UPLO = 'L', the leading n by n lower
* triangular part of the array A contains the lower triangular
* matrix, and the strictly upper triangular part of A is not
* referenced. If DIAG = 'U', the diagonal elements of A are
* set so that A(k,k) = k for 1 <= k <= n.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (output) REAL array, dimension (N)
* The right hand side vector, if IMAT > 10.
*
* WORK (workspace) REAL array, dimension (3*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, TWO, ZERO
PARAMETER ( ONE = 1.0E+0, TWO = 2.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
CHARACTER DIST, TYPE
CHARACTER*3 PATH
INTEGER I, IY, J, JCOUNT, KL, KU, MODE
REAL ANORM, BIGNUM, BNORM, BSCAL, C, CNDNUM, PLUS1,
$ PLUS2, RA, RB, REXP, S, SFAC, SMLNUM, STAR1,
$ TEXP, TLEFT, TSCAL, ULP, UNFL, X, Y, Z
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SLAMCH, SLARND
EXTERNAL LSAME, ISAMAX, SLAMCH, SLARND
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLABAD, SLARNV, SLATB4, SLATMS, SROT,
$ SROTG, SSCAL, SSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, REAL, SIGN, SQRT
* ..
* .. Executable Statements ..
*
PATH( 1: 1 ) = 'Single precision'
PATH( 2: 3 ) = 'TR'
UNFL = SLAMCH( 'Safe minimum' )
ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
SMLNUM = UNFL
BIGNUM = ( ONE-ULP ) / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
IF( ( IMAT.GE.7 .AND. IMAT.LE.10 ) .OR. IMAT.EQ.18 ) THEN
DIAG = 'U'
ELSE
DIAG = 'N'
END IF
INFO = 0
*
* Quick return if N.LE.0.
*
IF( N.LE.0 )
$ RETURN
*
* Call SLATB4 to set parameters for SLATMS.
*
UPPER = LSAME( UPLO, 'U' )
IF( UPPER ) THEN
CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
ELSE
CALL SLATB4( PATH, -IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
END IF
*
* IMAT <= 6: Non-unit triangular matrix
*
IF( IMAT.LE.6 ) THEN
CALL SLATMS( N, N, DIST, ISEED, TYPE, B, MODE, CNDNUM, ANORM,
$ KL, KU, 'No packing', A, LDA, WORK, INFO )
*
* IMAT > 6: Unit triangular matrix
* The diagonal is deliberately set to something other than 1.
*
* IMAT = 7: Matrix is the identity
*
ELSE IF( IMAT.EQ.7 ) THEN
IF( UPPER ) THEN
DO 20 J = 1, N
DO 10 I = 1, J - 1
A( I, J ) = ZERO
10 CONTINUE
A( J, J ) = J
20 CONTINUE
ELSE
DO 40 J = 1, N
A( J, J ) = J
DO 30 I = J + 1, N
A( I, J ) = ZERO
30 CONTINUE
40 CONTINUE
END IF
*
* IMAT > 7: Non-trivial unit triangular matrix
*
* Generate a unit triangular matrix T with condition CNDNUM by
* forming a triangular matrix with known singular values and
* filling in the zero entries with Givens rotations.
*
ELSE IF( IMAT.LE.10 ) THEN
IF( UPPER ) THEN
DO 60 J = 1, N
DO 50 I = 1, J - 1
A( I, J ) = ZERO
50 CONTINUE
A( J, J ) = J
60 CONTINUE
ELSE
DO 80 J = 1, N
A( J, J ) = J
DO 70 I = J + 1, N
A( I, J ) = ZERO
70 CONTINUE
80 CONTINUE
END IF
*
* Since the trace of a unit triangular matrix is 1, the product
* of its singular values must be 1. Let s = sqrt(CNDNUM),
* x = sqrt(s) - 1/sqrt(s), y = sqrt(2/(n-2))*x, and z = x**2.
* The following triangular matrix has singular values s, 1, 1,
* ..., 1, 1/s:
*
* 1 y y y ... y y z
* 1 0 0 ... 0 0 y
* 1 0 ... 0 0 y
* . ... . . .
* . . . .
* 1 0 y
* 1 y
* 1
*
* To fill in the zeros, we first multiply by a matrix with small
* condition number of the form
*
* 1 0 0 0 0 ...
* 1 + * 0 0 ...
* 1 + 0 0 0
* 1 + * 0 0
* 1 + 0 0
* ...
* 1 + 0
* 1 0
* 1
*
* Each element marked with a '*' is formed by taking the product
* of the adjacent elements marked with '+'. The '*'s can be
* chosen freely, and the '+'s are chosen so that the inverse of
* T will have elements of the same magnitude as T. If the *'s in
* both T and inv(T) have small magnitude, T is well conditioned.
* The two offdiagonals of T are stored in WORK.
*
* The product of these two matrices has the form
*
* 1 y y y y y . y y z
* 1 + * 0 0 . 0 0 y
* 1 + 0 0 . 0 0 y
* 1 + * . . . .
* 1 + . . . .
* . . . . .
* . . . .
* 1 + y
* 1 y
* 1
*
* Now we multiply by Givens rotations, using the fact that
*
* [ c s ] [ 1 w ] [ -c -s ] = [ 1 -w ]
* [ -s c ] [ 0 1 ] [ s -c ] [ 0 1 ]
* and
* [ -c -s ] [ 1 0 ] [ c s ] = [ 1 0 ]
* [ s -c ] [ w 1 ] [ -s c ] [ -w 1 ]
*
* where c = w / sqrt(w**2+4) and s = 2 / sqrt(w**2+4).
*
STAR1 = 0.25
SFAC = 0.5
PLUS1 = SFAC
DO 90 J = 1, N, 2
PLUS2 = STAR1 / PLUS1
WORK( J ) = PLUS1
WORK( N+J ) = STAR1
IF( J+1.LE.N ) THEN
WORK( J+1 ) = PLUS2
WORK( N+J+1 ) = ZERO
PLUS1 = STAR1 / PLUS2
REXP = SLARND( 2, ISEED )
STAR1 = STAR1*( SFAC**REXP )
IF( REXP.LT.ZERO ) THEN
STAR1 = -SFAC**( ONE-REXP )
ELSE
STAR1 = SFAC**( ONE+REXP )
END IF
END IF
90 CONTINUE
*
X = SQRT( CNDNUM ) - 1 / SQRT( CNDNUM )
IF( N.GT.2 ) THEN
Y = SQRT( 2. / ( N-2 ) )*X
ELSE
Y = ZERO
END IF
Z = X*X
*
IF( UPPER ) THEN
IF( N.GT.3 ) THEN
CALL SCOPY( N-3, WORK, 1, A( 2, 3 ), LDA+1 )
IF( N.GT.4 )
$ CALL SCOPY( N-4, WORK( N+1 ), 1, A( 2, 4 ), LDA+1 )
END IF
DO 100 J = 2, N - 1
A( 1, J ) = Y
A( J, N ) = Y
100 CONTINUE
A( 1, N ) = Z
ELSE
IF( N.GT.3 ) THEN
CALL SCOPY( N-3, WORK, 1, A( 3, 2 ), LDA+1 )
IF( N.GT.4 )
$ CALL SCOPY( N-4, WORK( N+1 ), 1, A( 4, 2 ), LDA+1 )
END IF
DO 110 J = 2, N - 1
A( J, 1 ) = Y
A( N, J ) = Y
110 CONTINUE
A( N, 1 ) = Z
END IF
*
* Fill in the zeros using Givens rotations.
*
IF( UPPER ) THEN
DO 120 J = 1, N - 1
RA = A( J, J+1 )
RB = 2.0
CALL SROTG( RA, RB, C, S )
*
* Multiply by [ c s; -s c] on the left.
*
IF( N.GT.J+1 )
$ CALL SROT( N-J-1, A( J, J+2 ), LDA, A( J+1, J+2 ),
$ LDA, C, S )
*
* Multiply by [-c -s; s -c] on the right.
*
IF( J.GT.1 )
$ CALL SROT( J-1, A( 1, J+1 ), 1, A( 1, J ), 1, -C, -S )
*
* Negate A(J,J+1).
*
A( J, J+1 ) = -A( J, J+1 )
120 CONTINUE
ELSE
DO 130 J = 1, N - 1
RA = A( J+1, J )
RB = 2.0
CALL SROTG( RA, RB, C, S )
*
* Multiply by [ c -s; s c] on the right.
*
IF( N.GT.J+1 )
$ CALL SROT( N-J-1, A( J+2, J+1 ), 1, A( J+2, J ), 1, C,
$ -S )
*
* Multiply by [-c s; -s -c] on the left.
*
IF( J.GT.1 )
$ CALL SROT( J-1, A( J, 1 ), LDA, A( J+1, 1 ), LDA, -C,
$ S )
*
* Negate A(J+1,J).
*
A( J+1, J ) = -A( J+1, J )
130 CONTINUE
END IF
*
* IMAT > 10: Pathological test cases. These triangular matrices
* are badly scaled or badly conditioned, so when used in solving a
* triangular system they may cause overflow in the solution vector.
*
ELSE IF( IMAT.EQ.11 ) THEN
*
* Type 11: Generate a triangular matrix with elements between
* -1 and 1. Give the diagonal norm 2 to make it well-conditioned.
* Make the right hand side large so that it requires scaling.
*
IF( UPPER ) THEN
DO 140 J = 1, N
CALL SLARNV( 2, ISEED, J, A( 1, J ) )
A( J, J ) = SIGN( TWO, A( J, J ) )
140 CONTINUE
ELSE
DO 150 J = 1, N
CALL SLARNV( 2, ISEED, N-J+1, A( J, J ) )
A( J, J ) = SIGN( TWO, A( J, J ) )
150 CONTINUE
END IF
*
* Set the right hand side so that the largest value is BIGNUM.
*
CALL SLARNV( 2, ISEED, N, B )
IY = ISAMAX( N, B, 1 )
BNORM = ABS( B( IY ) )
BSCAL = BIGNUM / MAX( ONE, BNORM )
CALL SSCAL( N, BSCAL, B, 1 )
*
ELSE IF( IMAT.EQ.12 ) THEN
*
* Type 12: Make the first diagonal element in the solve small to
* cause immediate overflow when dividing by T(j,j).
* In type 12, the offdiagonal elements are small (CNORM(j) < 1).
*
CALL SLARNV( 2, ISEED, N, B )
TSCAL = ONE / MAX( ONE, REAL( N-1 ) )
IF( UPPER ) THEN
DO 160 J = 1, N
CALL SLARNV( 2, ISEED, J, A( 1, J ) )
CALL SSCAL( J-1, TSCAL, A( 1, J ), 1 )
A( J, J ) = SIGN( ONE, A( J, J ) )
160 CONTINUE
A( N, N ) = SMLNUM*A( N, N )
ELSE
DO 170 J = 1, N
CALL SLARNV( 2, ISEED, N-J+1, A( J, J ) )
IF( N.GT.J )
$ CALL SSCAL( N-J, TSCAL, A( J+1, J ), 1 )
A( J, J ) = SIGN( ONE, A( J, J ) )
170 CONTINUE
A( 1, 1 ) = SMLNUM*A( 1, 1 )
END IF
*
ELSE IF( IMAT.EQ.13 ) THEN
*
* Type 13: Make the first diagonal element in the solve small to
* cause immediate overflow when dividing by T(j,j).
* In type 13, the offdiagonal elements are O(1) (CNORM(j) > 1).
*
CALL SLARNV( 2, ISEED, N, B )
IF( UPPER ) THEN
DO 180 J = 1, N
CALL SLARNV( 2, ISEED, J, A( 1, J ) )
A( J, J ) = SIGN( ONE, A( J, J ) )
180 CONTINUE
A( N, N ) = SMLNUM*A( N, N )
ELSE
DO 190 J = 1, N
CALL SLARNV( 2, ISEED, N-J+1, A( J, J ) )
A( J, J ) = SIGN( ONE, A( J, J ) )
190 CONTINUE
A( 1, 1 ) = SMLNUM*A( 1, 1 )
END IF
*
ELSE IF( IMAT.EQ.14 ) THEN
*
* Type 14: T is diagonal with small numbers on the diagonal to
* make the growth factor underflow, but a small right hand side
* chosen so that the solution does not overflow.
*
IF( UPPER ) THEN
JCOUNT = 1
DO 210 J = N, 1, -1
DO 200 I = 1, J - 1
A( I, J ) = ZERO
200 CONTINUE
IF( JCOUNT.LE.2 ) THEN
A( J, J ) = SMLNUM
ELSE
A( J, J ) = ONE
END IF
JCOUNT = JCOUNT + 1
IF( JCOUNT.GT.4 )
$ JCOUNT = 1
210 CONTINUE
ELSE
JCOUNT = 1
DO 230 J = 1, N
DO 220 I = J + 1, N
A( I, J ) = ZERO
220 CONTINUE
IF( JCOUNT.LE.2 ) THEN
A( J, J ) = SMLNUM
ELSE
A( J, J ) = ONE
END IF
JCOUNT = JCOUNT + 1
IF( JCOUNT.GT.4 )
$ JCOUNT = 1
230 CONTINUE
END IF
*
* Set the right hand side alternately zero and small.
*
IF( UPPER ) THEN
B( 1 ) = ZERO
DO 240 I = N, 2, -2
B( I ) = ZERO
B( I-1 ) = SMLNUM
240 CONTINUE
ELSE
B( N ) = ZERO
DO 250 I = 1, N - 1, 2
B( I ) = ZERO
B( I+1 ) = SMLNUM
250 CONTINUE
END IF
*
ELSE IF( IMAT.EQ.15 ) THEN
*
* Type 15: Make the diagonal elements small to cause gradual
* overflow when dividing by T(j,j). To control the amount of
* scaling needed, the matrix is bidiagonal.
*
TEXP = ONE / MAX( ONE, REAL( N-1 ) )
TSCAL = SMLNUM**TEXP
CALL SLARNV( 2, ISEED, N, B )
IF( UPPER ) THEN
DO 270 J = 1, N
DO 260 I = 1, J - 2
A( I, J ) = 0.
260 CONTINUE
IF( J.GT.1 )
$ A( J-1, J ) = -ONE
A( J, J ) = TSCAL
270 CONTINUE
B( N ) = ONE
ELSE
DO 290 J = 1, N
DO 280 I = J + 2, N
A( I, J ) = 0.
280 CONTINUE
IF( J.LT.N )
$ A( J+1, J ) = -ONE
A( J, J ) = TSCAL
290 CONTINUE
B( 1 ) = ONE
END IF
*
ELSE IF( IMAT.EQ.16 ) THEN
*
* Type 16: One zero diagonal element.
*
IY = N / 2 + 1
IF( UPPER ) THEN
DO 300 J = 1, N
CALL SLARNV( 2, ISEED, J, A( 1, J ) )
IF( J.NE.IY ) THEN
A( J, J ) = SIGN( TWO, A( J, J ) )
ELSE
A( J, J ) = ZERO
END IF
300 CONTINUE
ELSE
DO 310 J = 1, N
CALL SLARNV( 2, ISEED, N-J+1, A( J, J ) )
IF( J.NE.IY ) THEN
A( J, J ) = SIGN( TWO, A( J, J ) )
ELSE
A( J, J ) = ZERO
END IF
310 CONTINUE
END IF
CALL SLARNV( 2, ISEED, N, B )
CALL SSCAL( N, TWO, B, 1 )
*
ELSE IF( IMAT.EQ.17 ) THEN
*
* Type 17: Make the offdiagonal elements large to cause overflow
* when adding a column of T. In the non-transposed case, the
* matrix is constructed to cause overflow when adding a column in
* every other step.
*
TSCAL = UNFL / ULP
TSCAL = ( ONE-ULP ) / TSCAL
DO 330 J = 1, N
DO 320 I = 1, N
A( I, J ) = 0.
320 CONTINUE
330 CONTINUE
TEXP = ONE
IF( UPPER ) THEN
DO 340 J = N, 2, -2
A( 1, J ) = -TSCAL / REAL( N+1 )
A( J, J ) = ONE
B( J ) = TEXP*( ONE-ULP )
A( 1, J-1 ) = -( TSCAL / REAL( N+1 ) ) / REAL( N+2 )
A( J-1, J-1 ) = ONE
B( J-1 ) = TEXP*REAL( N*N+N-1 )
TEXP = TEXP*2.
340 CONTINUE
B( 1 ) = ( REAL( N+1 ) / REAL( N+2 ) )*TSCAL
ELSE
DO 350 J = 1, N - 1, 2
A( N, J ) = -TSCAL / REAL( N+1 )
A( J, J ) = ONE
B( J ) = TEXP*( ONE-ULP )
A( N, J+1 ) = -( TSCAL / REAL( N+1 ) ) / REAL( N+2 )
A( J+1, J+1 ) = ONE
B( J+1 ) = TEXP*REAL( N*N+N-1 )
TEXP = TEXP*2.
350 CONTINUE
B( N ) = ( REAL( N+1 ) / REAL( N+2 ) )*TSCAL
END IF
*
ELSE IF( IMAT.EQ.18 ) THEN
*
* Type 18: Generate a unit triangular matrix with elements
* between -1 and 1, and make the right hand side large so that it
* requires scaling.
*
IF( UPPER ) THEN
DO 360 J = 1, N
CALL SLARNV( 2, ISEED, J-1, A( 1, J ) )
A( J, J ) = ZERO
360 CONTINUE
ELSE
DO 370 J = 1, N
IF( J.LT.N )
$ CALL SLARNV( 2, ISEED, N-J, A( J+1, J ) )
A( J, J ) = ZERO
370 CONTINUE
END IF
*
* Set the right hand side so that the largest value is BIGNUM.
*
CALL SLARNV( 2, ISEED, N, B )
IY = ISAMAX( N, B, 1 )
BNORM = ABS( B( IY ) )
BSCAL = BIGNUM / MAX( ONE, BNORM )
CALL SSCAL( N, BSCAL, B, 1 )
*
ELSE IF( IMAT.EQ.19 ) THEN
*
* Type 19: Generate a triangular matrix with elements between
* BIGNUM/(n-1) and BIGNUM so that at least one of the column
* norms will exceed BIGNUM.
* 1/3/91: SLATRS no longer can handle this case
*
TLEFT = BIGNUM / MAX( ONE, REAL( N-1 ) )
TSCAL = BIGNUM*( REAL( N-1 ) / MAX( ONE, REAL( N ) ) )
IF( UPPER ) THEN
DO 390 J = 1, N
CALL SLARNV( 2, ISEED, J, A( 1, J ) )
DO 380 I = 1, J
A( I, J ) = SIGN( TLEFT, A( I, J ) ) + TSCAL*A( I, J )
380 CONTINUE
390 CONTINUE
ELSE
DO 410 J = 1, N
CALL SLARNV( 2, ISEED, N-J+1, A( J, J ) )
DO 400 I = J, N
A( I, J ) = SIGN( TLEFT, A( I, J ) ) + TSCAL*A( I, J )
400 CONTINUE
410 CONTINUE
END IF
CALL SLARNV( 2, ISEED, N, B )
CALL SSCAL( N, TWO, B, 1 )
END IF
*
* Flip the matrix if the transpose will be used.
*
IF( .NOT.LSAME( TRANS, 'N' ) ) THEN
IF( UPPER ) THEN
DO 420 J = 1, N / 2
CALL SSWAP( N-2*J+1, A( J, J ), LDA, A( J+1, N-J+1 ),
$ -1 )
420 CONTINUE
ELSE
DO 430 J = 1, N / 2
CALL SSWAP( N-2*J+1, A( J, J ), 1, A( N-J+1, J+1 ),
$ -LDA )
430 CONTINUE
END IF
END IF
*
RETURN
*
* End of SLATTR
*
END
SUBROUTINE SLAVSP( UPLO, TRANS, DIAG, N, NRHS, A, IPIV, B, LDB,
$ INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
REAL A( * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* SLAVSP performs one of the matrix-vector operations
* x := A*x or x := A'*x,
* where x is an N element vector and A is one of the factors
* from the block U*D*U' or L*D*L' factorization computed by SSPTRF.
*
* If TRANS = 'N', multiplies by U or U * D (or L or L * D)
* If TRANS = 'T', multiplies by U' or D * U' (or L' or D * L' )
* If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L' )
*
* Arguments
* ==========
*
* UPLO (input) CHARACTER*1
* Specifies whether the factor stored in A is upper or lower
* triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the operation to be performed:
* = 'N': x := A*x
* = 'T': x := A'*x
* = 'C': x := A'*x
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the diagonal blocks are unit
* matrices. If the diagonal blocks are assumed to be unit,
* then A = U or A = L, otherwise A = U*D or A = L*D.
* = 'U': Diagonal blocks are assumed to be unit matrices.
* = 'N': Diagonal blocks are assumed to be non-unit matrices.
*
* N (input) INTEGER
* The number of rows and columns of the matrix A. N >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of vectors
* x to be multiplied by A. NRHS >= 0.
*
* A (input) REAL array, dimension (N*(N+1)/2)
* The block diagonal matrix D and the multipliers used to
* obtain the factor U or L, stored as a packed triangular
* matrix as computed by SSPTRF.
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices from SSPTRF.
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, B contains NRHS vectors of length N.
* On exit, B is overwritten with the product A * B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT
INTEGER J, K, KC, KCNEXT, KP
REAL D11, D12, D21, D22, T1, T2
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SGEMV, SGER, SSCAL, SSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* 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( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLAVSP ', -INFO )
RETURN
END IF
*
* Quick return if possible.
*
IF( N.EQ.0 )
$ RETURN
*
NOUNIT = LSAME( DIAG, 'N' )
*------------------------------------------
*
* Compute B := A * B (No transpose)
*
*------------------------------------------
IF( LSAME( TRANS, 'N' ) ) THEN
*
* Compute B := U*B
* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Loop forward applying the transformations.
*
K = 1
KC = 1
10 CONTINUE
IF( K.GT.N )
$ GO TO 30
*
* 1 x 1 pivot block
*
IF( IPIV( K ).GT.0 ) THEN
*
* Multiply by the diagonal element if forming U * D.
*
IF( NOUNIT )
$ CALL SSCAL( NRHS, A( KC+K-1 ), B( K, 1 ), LDB )
*
* Multiply by P(K) * inv(U(K)) if K > 1.
*
IF( K.GT.1 ) THEN
*
* Apply the transformation.
*
CALL SGER( K-1, NRHS, ONE, A( KC ), 1, B( K, 1 ), LDB,
$ B( 1, 1 ), LDB )
*
* Interchange if P(K) != I.
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
END IF
KC = KC + K
K = K + 1
ELSE
*
* 2 x 2 pivot block
*
KCNEXT = KC + K
*
* Multiply by the diagonal block if forming U * D.
*
IF( NOUNIT ) THEN
D11 = A( KCNEXT-1 )
D22 = A( KCNEXT+K )
D12 = A( KCNEXT+K-1 )
D21 = D12
DO 20 J = 1, NRHS
T1 = B( K, J )
T2 = B( K+1, J )
B( K, J ) = D11*T1 + D12*T2
B( K+1, J ) = D21*T1 + D22*T2
20 CONTINUE
END IF
*
* Multiply by P(K) * inv(U(K)) if K > 1.
*
IF( K.GT.1 ) THEN
*
* Apply the transformations.
*
CALL SGER( K-1, NRHS, ONE, A( KC ), 1, B( K, 1 ), LDB,
$ B( 1, 1 ), LDB )
CALL SGER( K-1, NRHS, ONE, A( KCNEXT ), 1,
$ B( K+1, 1 ), LDB, B( 1, 1 ), LDB )
*
* Interchange if P(K) != I.
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K )
$ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
END IF
KC = KCNEXT + K + 1
K = K + 2
END IF
GO TO 10
30 CONTINUE
*
* Compute B := L*B
* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) .
*
ELSE
*
* Loop backward applying the transformations to B.
*
K = N
KC = N*( N+1 ) / 2 + 1
40 CONTINUE
IF( K.LT.1 )
$ GO TO 60
KC = KC - ( N-K+1 )
*
* Test the pivot index. If greater than zero, a 1 x 1
* pivot was used, otherwise a 2 x 2 pivot was used.
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 pivot block:
*
* Multiply by the diagonal element if forming L * D.
*
IF( NOUNIT )
$ CALL SSCAL( NRHS, A( KC ), B( K, 1 ), LDB )
*
* Multiply by P(K) * inv(L(K)) if K < N.
*
IF( K.NE.N ) THEN
KP = IPIV( K )
*
* Apply the transformation.
*
CALL SGER( N-K, NRHS, ONE, A( KC+1 ), 1, B( K, 1 ),
$ LDB, B( K+1, 1 ), LDB )
*
* Interchange if a permutation was applied at the
* K-th step of the factorization.
*
IF( KP.NE.K )
$ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
END IF
K = K - 1
*
ELSE
*
* 2 x 2 pivot block:
*
KCNEXT = KC - ( N-K+2 )
*
* Multiply by the diagonal block if forming L * D.
*
IF( NOUNIT ) THEN
D11 = A( KCNEXT )
D22 = A( KC )
D21 = A( KCNEXT+1 )
D12 = D21
DO 50 J = 1, NRHS
T1 = B( K-1, J )
T2 = B( K, J )
B( K-1, J ) = D11*T1 + D12*T2
B( K, J ) = D21*T1 + D22*T2
50 CONTINUE
END IF
*
* Multiply by P(K) * inv(L(K)) if K < N.
*
IF( K.NE.N ) THEN
*
* Apply the transformation.
*
CALL SGER( N-K, NRHS, ONE, A( KC+1 ), 1, B( K, 1 ),
$ LDB, B( K+1, 1 ), LDB )
CALL SGER( N-K, NRHS, ONE, A( KCNEXT+2 ), 1,
$ B( K-1, 1 ), LDB, B( K+1, 1 ), LDB )
*
* Interchange if a permutation was applied at the
* K-th step of the factorization.
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K )
$ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
END IF
KC = KCNEXT
K = K - 2
END IF
GO TO 40
60 CONTINUE
END IF
*----------------------------------------
*
* Compute B := A' * B (transpose)
*
*----------------------------------------
ELSE
*
* Form B := U'*B
* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
* and U' = inv(U'(1))*P(1)* ... *inv(U'(m))*P(m)
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Loop backward applying the transformations.
*
K = N
KC = N*( N+1 ) / 2 + 1
70 CONTINUE
IF( K.LT.1 )
$ GO TO 90
KC = KC - K
*
* 1 x 1 pivot block.
*
IF( IPIV( K ).GT.0 ) THEN
IF( K.GT.1 ) THEN
*
* Interchange if P(K) != I.
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
* Apply the transformation
*
CALL SGEMV( 'Transpose', K-1, NRHS, ONE, B, LDB,
$ A( KC ), 1, ONE, B( K, 1 ), LDB )
END IF
IF( NOUNIT )
$ CALL SSCAL( NRHS, A( KC+K-1 ), B( K, 1 ), LDB )
K = K - 1
*
* 2 x 2 pivot block.
*
ELSE
KCNEXT = KC - ( K-1 )
IF( K.GT.2 ) THEN
*
* Interchange if P(K) != I.
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K-1 )
$ CALL SSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ),
$ LDB )
*
* Apply the transformations
*
CALL SGEMV( 'Transpose', K-2, NRHS, ONE, B, LDB,
$ A( KC ), 1, ONE, B( K, 1 ), LDB )
CALL SGEMV( 'Transpose', K-2, NRHS, ONE, B, LDB,
$ A( KCNEXT ), 1, ONE, B( K-1, 1 ), LDB )
END IF
*
* Multiply by the diagonal block if non-unit.
*
IF( NOUNIT ) THEN
D11 = A( KC-1 )
D22 = A( KC+K-1 )
D12 = A( KC+K-2 )
D21 = D12
DO 80 J = 1, NRHS
T1 = B( K-1, J )
T2 = B( K, J )
B( K-1, J ) = D11*T1 + D12*T2
B( K, J ) = D21*T1 + D22*T2
80 CONTINUE
END IF
KC = KCNEXT
K = K - 2
END IF
GO TO 70
90 CONTINUE
*
* Form B := L'*B
* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m))
* and L' = inv(L(m))*P(m)* ... *inv(L(1))*P(1)
*
ELSE
*
* Loop forward applying the L-transformations.
*
K = 1
KC = 1
100 CONTINUE
IF( K.GT.N )
$ GO TO 120
*
* 1 x 1 pivot block
*
IF( IPIV( K ).GT.0 ) THEN
IF( K.LT.N ) THEN
*
* Interchange if P(K) != I.
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
* Apply the transformation
*
CALL SGEMV( 'Transpose', N-K, NRHS, ONE, B( K+1, 1 ),
$ LDB, A( KC+1 ), 1, ONE, B( K, 1 ), LDB )
END IF
IF( NOUNIT )
$ CALL SSCAL( NRHS, A( KC ), B( K, 1 ), LDB )
KC = KC + N - K + 1
K = K + 1
*
* 2 x 2 pivot block.
*
ELSE
KCNEXT = KC + N - K + 1
IF( K.LT.N-1 ) THEN
*
* Interchange if P(K) != I.
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K+1 )
$ CALL SSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ),
$ LDB )
*
* Apply the transformation
*
CALL SGEMV( 'Transpose', N-K-1, NRHS, ONE,
$ B( K+2, 1 ), LDB, A( KCNEXT+1 ), 1, ONE,
$ B( K+1, 1 ), LDB )
CALL SGEMV( 'Transpose', N-K-1, NRHS, ONE,
$ B( K+2, 1 ), LDB, A( KC+2 ), 1, ONE,
$ B( K, 1 ), LDB )
END IF
*
* Multiply by the diagonal block if non-unit.
*
IF( NOUNIT ) THEN
D11 = A( KC )
D22 = A( KCNEXT )
D21 = A( KC+1 )
D12 = D21
DO 110 J = 1, NRHS
T1 = B( K, J )
T2 = B( K+1, J )
B( K, J ) = D11*T1 + D12*T2
B( K+1, J ) = D21*T1 + D22*T2
110 CONTINUE
END IF
KC = KCNEXT + ( N-K )
K = K + 2
END IF
GO TO 100
120 CONTINUE
END IF
*
END IF
RETURN
*
* End of SLAVSP
*
END
SUBROUTINE SLAVSY( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B,
$ LDB, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
REAL A( LDA, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* SLAVSY performs one of the matrix-vector operations
* x := A*x or x := A'*x,
* where x is an N element vector and A is one of the factors
* from the block U*D*U' or L*D*L' factorization computed by SSYTRF.
*
* If TRANS = 'N', multiplies by U or U * D (or L or L * D)
* If TRANS = 'T', multiplies by U' or D * U' (or L' or D * L')
* If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L')
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the factor stored in A is upper or lower
* triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the operation to be performed:
* = 'N': x := A*x
* = 'T': x := A'*x
* = 'C': x := A'*x
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the diagonal blocks are unit
* matrices. If the diagonal blocks are assumed to be unit,
* then A = U or A = L, otherwise A = U*D or A = L*D.
* = 'U': Diagonal blocks are assumed to be unit matrices.
* = 'N': Diagonal blocks are assumed to be non-unit matrices.
*
* N (input) INTEGER
* The number of rows and columns of the matrix A. N >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of vectors
* x to be multiplied by A. NRHS >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The block diagonal matrix D and the multipliers used to
* obtain the factor U or L as computed by SSYTRF.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices from SSYTRF.
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, B contains NRHS vectors of length N.
* On exit, B is overwritten with the product A * B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT
INTEGER J, K, KP
REAL D11, D12, D21, D22, T1, T2
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SGEMV, SGER, SSCAL, SSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* 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( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLAVSY ', -INFO )
RETURN
END IF
*
* Quick return if possible.
*
IF( N.EQ.0 )
$ RETURN
*
NOUNIT = LSAME( DIAG, 'N' )
*------------------------------------------
*
* Compute B := A * B (No transpose)
*
*------------------------------------------
IF( LSAME( TRANS, 'N' ) ) THEN
*
* Compute B := U*B
* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Loop forward applying the transformations.
*
K = 1
10 CONTINUE
IF( K.GT.N )
$ GO TO 30
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 pivot block
*
* Multiply by the diagonal element if forming U * D.
*
IF( NOUNIT )
$ CALL SSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
*
* Multiply by P(K) * inv(U(K)) if K > 1.
*
IF( K.GT.1 ) THEN
*
* Apply the transformation.
*
CALL SGER( K-1, NRHS, ONE, A( 1, K ), 1, B( K, 1 ),
$ LDB, B( 1, 1 ), LDB )
*
* Interchange if P(K) .ne. I.
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
END IF
K = K + 1
ELSE
*
* 2 x 2 pivot block
*
* Multiply by the diagonal block if forming U * D.
*
IF( NOUNIT ) THEN
D11 = A( K, K )
D22 = A( K+1, K+1 )
D12 = A( K, K+1 )
D21 = D12
DO 20 J = 1, NRHS
T1 = B( K, J )
T2 = B( K+1, J )
B( K, J ) = D11*T1 + D12*T2
B( K+1, J ) = D21*T1 + D22*T2
20 CONTINUE
END IF
*
* Multiply by P(K) * inv(U(K)) if K > 1.
*
IF( K.GT.1 ) THEN
*
* Apply the transformations.
*
CALL SGER( K-1, NRHS, ONE, A( 1, K ), 1, B( K, 1 ),
$ LDB, B( 1, 1 ), LDB )
CALL SGER( K-1, NRHS, ONE, A( 1, K+1 ), 1,
$ B( K+1, 1 ), LDB, B( 1, 1 ), LDB )
*
* Interchange if P(K) .ne. I.
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K )
$ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
END IF
K = K + 2
END IF
GO TO 10
30 CONTINUE
*
* Compute B := L*B
* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) .
*
ELSE
*
* Loop backward applying the transformations to B.
*
K = N
40 CONTINUE
IF( K.LT.1 )
$ GO TO 60
*
* Test the pivot index. If greater than zero, a 1 x 1
* pivot was used, otherwise a 2 x 2 pivot was used.
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 pivot block:
*
* Multiply by the diagonal element if forming L * D.
*
IF( NOUNIT )
$ CALL SSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
*
* Multiply by P(K) * inv(L(K)) if K < N.
*
IF( K.NE.N ) THEN
KP = IPIV( K )
*
* Apply the transformation.
*
CALL SGER( N-K, NRHS, ONE, A( K+1, K ), 1, B( K, 1 ),
$ LDB, B( K+1, 1 ), LDB )
*
* Interchange if a permutation was applied at the
* K-th step of the factorization.
*
IF( KP.NE.K )
$ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
END IF
K = K - 1
*
ELSE
*
* 2 x 2 pivot block:
*
* Multiply by the diagonal block if forming L * D.
*
IF( NOUNIT ) THEN
D11 = A( K-1, K-1 )
D22 = A( K, K )
D21 = A( K, K-1 )
D12 = D21
DO 50 J = 1, NRHS
T1 = B( K-1, J )
T2 = B( K, J )
B( K-1, J ) = D11*T1 + D12*T2
B( K, J ) = D21*T1 + D22*T2
50 CONTINUE
END IF
*
* Multiply by P(K) * inv(L(K)) if K < N.
*
IF( K.NE.N ) THEN
*
* Apply the transformation.
*
CALL SGER( N-K, NRHS, ONE, A( K+1, K ), 1, B( K, 1 ),
$ LDB, B( K+1, 1 ), LDB )
CALL SGER( N-K, NRHS, ONE, A( K+1, K-1 ), 1,
$ B( K-1, 1 ), LDB, B( K+1, 1 ), LDB )
*
* Interchange if a permutation was applied at the
* K-th step of the factorization.
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K )
$ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
END IF
K = K - 2
END IF
GO TO 40
60 CONTINUE
END IF
*----------------------------------------
*
* Compute B := A' * B (transpose)
*
*----------------------------------------
ELSE
*
* Form B := U'*B
* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
* and U' = inv(U'(1))*P(1)* ... *inv(U'(m))*P(m)
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Loop backward applying the transformations.
*
K = N
70 CONTINUE
IF( K.LT.1 )
$ GO TO 90
*
* 1 x 1 pivot block.
*
IF( IPIV( K ).GT.0 ) THEN
IF( K.GT.1 ) THEN
*
* Interchange if P(K) .ne. I.
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
* Apply the transformation
*
CALL SGEMV( 'Transpose', K-1, NRHS, ONE, B, LDB,
$ A( 1, K ), 1, ONE, B( K, 1 ), LDB )
END IF
IF( NOUNIT )
$ CALL SSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
K = K - 1
*
* 2 x 2 pivot block.
*
ELSE
IF( K.GT.2 ) THEN
*
* Interchange if P(K) .ne. I.
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K-1 )
$ CALL SSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ),
$ LDB )
*
* Apply the transformations
*
CALL SGEMV( 'Transpose', K-2, NRHS, ONE, B, LDB,
$ A( 1, K ), 1, ONE, B( K, 1 ), LDB )
CALL SGEMV( 'Transpose', K-2, NRHS, ONE, B, LDB,
$ A( 1, K-1 ), 1, ONE, B( K-1, 1 ), LDB )
END IF
*
* Multiply by the diagonal block if non-unit.
*
IF( NOUNIT ) THEN
D11 = A( K-1, K-1 )
D22 = A( K, K )
D12 = A( K-1, K )
D21 = D12
DO 80 J = 1, NRHS
T1 = B( K-1, J )
T2 = B( K, J )
B( K-1, J ) = D11*T1 + D12*T2
B( K, J ) = D21*T1 + D22*T2
80 CONTINUE
END IF
K = K - 2
END IF
GO TO 70
90 CONTINUE
*
* Form B := L'*B
* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m))
* and L' = inv(L'(m))*P(m)* ... *inv(L'(1))*P(1)
*
ELSE
*
* Loop forward applying the L-transformations.
*
K = 1
100 CONTINUE
IF( K.GT.N )
$ GO TO 120
*
* 1 x 1 pivot block
*
IF( IPIV( K ).GT.0 ) THEN
IF( K.LT.N ) THEN
*
* Interchange if P(K) .ne. I.
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
* Apply the transformation
*
CALL SGEMV( 'Transpose', N-K, NRHS, ONE, B( K+1, 1 ),
$ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB )
END IF
IF( NOUNIT )
$ CALL SSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
K = K + 1
*
* 2 x 2 pivot block.
*
ELSE
IF( K.LT.N-1 ) THEN
*
* Interchange if P(K) .ne. I.
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K+1 )
$ CALL SSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ),
$ LDB )
*
* Apply the transformation
*
CALL SGEMV( 'Transpose', N-K-1, NRHS, ONE,
$ B( K+2, 1 ), LDB, A( K+2, K+1 ), 1, ONE,
$ B( K+1, 1 ), LDB )
CALL SGEMV( 'Transpose', N-K-1, NRHS, ONE,
$ B( K+2, 1 ), LDB, A( K+2, K ), 1, ONE,
$ B( K, 1 ), LDB )
END IF
*
* Multiply by the diagonal block if non-unit.
*
IF( NOUNIT ) THEN
D11 = A( K, K )
D22 = A( K+1, K+1 )
D21 = A( K+1, K )
D12 = D21
DO 110 J = 1, NRHS
T1 = B( K, J )
T2 = B( K+1, J )
B( K, J ) = D11*T1 + D12*T2
B( K+1, J ) = D21*T1 + D22*T2
110 CONTINUE
END IF
K = K + 2
END IF
GO TO 100
120 CONTINUE
END IF
*
END IF
RETURN
*
* End of SLAVSY
*
END
SUBROUTINE SLQT01( M, N, A, AF, Q, L, LDA, TAU, WORK, LWORK,
$ RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), AF( LDA, * ), L( LDA, * ),
$ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* SLQT01 tests SGELQF, which computes the LQ factorization of an m-by-n
* matrix A, and partially tests SORGLQ which forms the n-by-n
* orthogonal matrix Q.
*
* SLQT01 compares L with A*Q', and checks that Q is orthogonal.
*
* 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) REAL array, dimension (LDA,N)
* The m-by-n matrix A.
*
* AF (output) REAL array, dimension (LDA,N)
* Details of the LQ factorization of A, as returned by SGELQF.
* See SGELQF for further details.
*
* Q (output) REAL array, dimension (LDA,N)
* The n-by-n orthogonal matrix Q.
*
* L (workspace) REAL array, dimension (LDA,max(M,N))
*
* LDA (input) INTEGER
* The leading dimension of the arrays A, AF, Q and L.
* LDA >= max(M,N).
*
* TAU (output) REAL array, dimension (min(M,N))
* The scalar factors of the elementary reflectors, as returned
* by SGELQF.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
*
* RWORK (workspace) REAL array, dimension (max(M,N))
*
* RESULT (output) REAL array, dimension (2)
* The test ratios:
* RESULT(1) = norm( L - A*Q' ) / ( N * norm(A) * EPS )
* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
REAL ROGUE
PARAMETER ( ROGUE = -1.0E+10 )
* ..
* .. Local Scalars ..
INTEGER INFO, MINMN
REAL ANORM, EPS, RESID
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE, SLANSY
EXTERNAL SLAMCH, SLANGE, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL SGELQF, SGEMM, SLACPY, SLASET, SORGLQ, SSYRK
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Scalars in Common ..
CHARACTER*6 SRNAMT
* ..
* .. Common blocks ..
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
MINMN = MIN( M, N )
EPS = SLAMCH( 'Epsilon' )
*
* Copy the matrix A to the array AF.
*
CALL SLACPY( 'Full', M, N, A, LDA, AF, LDA )
*
* Factorize the matrix A in the array AF.
*
SRNAMT = 'SGELQF'
CALL SGELQF( M, N, AF, LDA, TAU, WORK, LWORK, INFO )
*
* Copy details of Q
*
CALL SLASET( 'Full', N, N, ROGUE, ROGUE, Q, LDA )
IF( N.GT.1 )
$ CALL SLACPY( 'Upper', M, N-1, AF( 1, 2 ), LDA, Q( 1, 2 ), LDA )
*
* Generate the n-by-n matrix Q
*
SRNAMT = 'SORGLQ'
CALL SORGLQ( N, N, MINMN, Q, LDA, TAU, WORK, LWORK, INFO )
*
* Copy L
*
CALL SLASET( 'Full', M, N, ZERO, ZERO, L, LDA )
CALL SLACPY( 'Lower', M, N, AF, LDA, L, LDA )
*
* Compute L - A*Q'
*
CALL SGEMM( 'No transpose', 'Transpose', M, N, N, -ONE, A, LDA, Q,
$ LDA, ONE, L, LDA )
*
* Compute norm( L - Q'*A ) / ( N * norm(A) * EPS ) .
*
ANORM = SLANGE( '1', M, N, A, LDA, RWORK )
RESID = SLANGE( '1', M, N, L, LDA, RWORK )
IF( ANORM.GT.ZERO ) THEN
RESULT( 1 ) = ( ( RESID / REAL( MAX( 1, N ) ) ) / ANORM ) / EPS
ELSE
RESULT( 1 ) = ZERO
END IF
*
* Compute I - Q*Q'
*
CALL SLASET( 'Full', N, N, ZERO, ONE, L, LDA )
CALL SSYRK( 'Upper', 'No transpose', N, N, -ONE, Q, LDA, ONE, L,
$ LDA )
*
* Compute norm( I - Q*Q' ) / ( N * EPS ) .
*
RESID = SLANSY( '1', 'Upper', N, L, LDA, RWORK )
*
RESULT( 2 ) = ( RESID / REAL( MAX( 1, N ) ) ) / EPS
*
RETURN
*
* End of SLQT01
*
END
SUBROUTINE SLQT02( M, N, K, A, AF, Q, L, LDA, TAU, WORK, LWORK,
$ RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), AF( LDA, * ), L( LDA, * ),
$ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* SLQT02 tests SORGLQ, which generates an m-by-n matrix Q with
* orthonornmal rows that is defined as the product of k elementary
* reflectors.
*
* Given the LQ factorization of an m-by-n matrix A, SLQT02 generates
* the orthogonal matrix Q defined by the factorization of the first k
* rows of A; it compares L(1:k,1:m) with A(1:k,1:n)*Q(1:m,1:n)', and
* checks that the rows of Q are orthonormal.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix Q to be generated. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix Q to be generated.
* N >= M >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* matrix Q. M >= K >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The m-by-n matrix A which was factorized by SLQT01.
*
* AF (input) REAL array, dimension (LDA,N)
* Details of the LQ factorization of A, as returned by SGELQF.
* See SGELQF for further details.
*
* Q (workspace) REAL array, dimension (LDA,N)
*
* L (workspace) REAL array, dimension (LDA,M)
*
* LDA (input) INTEGER
* The leading dimension of the arrays A, AF, Q and L. LDA >= N.
*
* TAU (input) REAL array, dimension (M)
* The scalar factors of the elementary reflectors corresponding
* to the LQ factorization in AF.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
*
* RWORK (workspace) REAL array, dimension (M)
*
* RESULT (output) REAL array, dimension (2)
* The test ratios:
* RESULT(1) = norm( L - A*Q' ) / ( N * norm(A) * EPS )
* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
REAL ROGUE
PARAMETER ( ROGUE = -1.0E+10 )
* ..
* .. Local Scalars ..
INTEGER INFO
REAL ANORM, EPS, RESID
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE, SLANSY
EXTERNAL SLAMCH, SLANGE, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SLACPY, SLASET, SORGLQ, SSYRK
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, REAL
* ..
* .. Scalars in Common ..
CHARACTER*6 SRNAMT
* ..
* .. Common blocks ..
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
EPS = SLAMCH( 'Epsilon' )
*
* Copy the first k rows of the factorization to the array Q
*
CALL SLASET( 'Full', M, N, ROGUE, ROGUE, Q, LDA )
CALL SLACPY( 'Upper', K, N-1, AF( 1, 2 ), LDA, Q( 1, 2 ), LDA )
*
* Generate the first n columns of the matrix Q
*
SRNAMT = 'SORGLQ'
CALL SORGLQ( M, N, K, Q, LDA, TAU, WORK, LWORK, INFO )
*
* Copy L(1:k,1:m)
*
CALL SLASET( 'Full', K, M, ZERO, ZERO, L, LDA )
CALL SLACPY( 'Lower', K, M, AF, LDA, L, LDA )
*
* Compute L(1:k,1:m) - A(1:k,1:n) * Q(1:m,1:n)'
*
CALL SGEMM( 'No transpose', 'Transpose', K, M, N, -ONE, A, LDA, Q,
$ LDA, ONE, L, LDA )
*
* Compute norm( L - A*Q' ) / ( N * norm(A) * EPS ) .
*
ANORM = SLANGE( '1', K, N, A, LDA, RWORK )
RESID = SLANGE( '1', K, M, L, LDA, RWORK )
IF( ANORM.GT.ZERO ) THEN
RESULT( 1 ) = ( ( RESID / REAL( MAX( 1, N ) ) ) / ANORM ) / EPS
ELSE
RESULT( 1 ) = ZERO
END IF
*
* Compute I - Q*Q'
*
CALL SLASET( 'Full', M, M, ZERO, ONE, L, LDA )
CALL SSYRK( 'Upper', 'No transpose', M, N, -ONE, Q, LDA, ONE, L,
$ LDA )
*
* Compute norm( I - Q*Q' ) / ( N * EPS ) .
*
RESID = SLANSY( '1', 'Upper', M, L, LDA, RWORK )
*
RESULT( 2 ) = ( RESID / REAL( MAX( 1, N ) ) ) / EPS
*
RETURN
*
* End of SLQT02
*
END
SUBROUTINE SLQT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK,
$ RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
REAL AF( LDA, * ), C( LDA, * ), CC( LDA, * ),
$ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* SLQT03 tests SORMLQ, which computes Q*C, Q'*C, C*Q or C*Q'.
*
* SLQT03 compares the results of a call to SORMLQ with the results of
* forming Q explicitly by a call to SORGLQ and then performing matrix
* multiplication by a call to SGEMM.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows or columns of the matrix C; C is n-by-m if
* Q is applied from the left, or m-by-n if Q is applied from
* the right. M >= 0.
*
* N (input) INTEGER
* The order of the orthogonal matrix Q. N >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* orthogonal matrix Q. N >= K >= 0.
*
* AF (input) REAL array, dimension (LDA,N)
* Details of the LQ factorization of an m-by-n matrix, as
* returned by SGELQF. See SGELQF for further details.
*
* C (workspace) REAL array, dimension (LDA,N)
*
* CC (workspace) REAL array, dimension (LDA,N)
*
* Q (workspace) REAL array, dimension (LDA,N)
*
* LDA (input) INTEGER
* The leading dimension of the arrays AF, C, CC, and Q.
*
* TAU (input) REAL array, dimension (min(M,N))
* The scalar factors of the elementary reflectors corresponding
* to the LQ factorization in AF.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of WORK. LWORK must be at least M, and should be
* M*NB, where NB is the blocksize for this environment.
*
* RWORK (workspace) REAL array, dimension (M)
*
* RESULT (output) REAL array, dimension (4)
* The test ratios compare two techniques for multiplying a
* random matrix C by an n-by-n orthogonal matrix Q.
* RESULT(1) = norm( Q*C - Q*C ) / ( N * norm(C) * EPS )
* RESULT(2) = norm( C*Q - C*Q ) / ( N * norm(C) * EPS )
* RESULT(3) = norm( Q'*C - Q'*C )/ ( N * norm(C) * EPS )
* RESULT(4) = norm( C*Q' - C*Q' )/ ( N * norm(C) * EPS )
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E0 )
REAL ROGUE
PARAMETER ( ROGUE = -1.0E+10 )
* ..
* .. Local Scalars ..
CHARACTER SIDE, TRANS
INTEGER INFO, ISIDE, ITRANS, J, MC, NC
REAL CNORM, EPS, RESID
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANGE
EXTERNAL LSAME, SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SLACPY, SLARNV, SLASET, SORGLQ, SORMLQ
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 )
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, REAL
* ..
* .. Scalars in Common ..
CHARACTER*6 SRNAMT
* ..
* .. Common blocks ..
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEED / 1988, 1989, 1990, 1991 /
* ..
* .. Executable Statements ..
*
EPS = SLAMCH( 'Epsilon' )
*
* Copy the first k rows of the factorization to the array Q
*
CALL SLASET( 'Full', N, N, ROGUE, ROGUE, Q, LDA )
CALL SLACPY( 'Upper', K, N-1, AF( 1, 2 ), LDA, Q( 1, 2 ), LDA )
*
* Generate the n-by-n matrix Q
*
SRNAMT = 'SORGLQ'
CALL SORGLQ( N, N, K, Q, LDA, TAU, WORK, LWORK, INFO )
*
DO 30 ISIDE = 1, 2
IF( ISIDE.EQ.1 ) THEN
SIDE = 'L'
MC = N
NC = M
ELSE
SIDE = 'R'
MC = M
NC = N
END IF
*
* Generate MC by NC matrix C
*
DO 10 J = 1, NC
CALL SLARNV( 2, ISEED, MC, C( 1, J ) )
10 CONTINUE
CNORM = SLANGE( '1', MC, NC, C, LDA, RWORK )
IF( CNORM.EQ.0.0 )
$ CNORM = ONE
*
DO 20 ITRANS = 1, 2
IF( ITRANS.EQ.1 ) THEN
TRANS = 'N'
ELSE
TRANS = 'T'
END IF
*
* Copy C
*
CALL SLACPY( 'Full', MC, NC, C, LDA, CC, LDA )
*
* Apply Q or Q' to C
*
SRNAMT = 'SORMLQ'
CALL SORMLQ( SIDE, TRANS, MC, NC, K, AF, LDA, TAU, CC, LDA,
$ WORK, LWORK, INFO )
*
* Form explicit product and subtract
*
IF( LSAME( SIDE, 'L' ) ) THEN
CALL SGEMM( TRANS, 'No transpose', MC, NC, MC, -ONE, Q,
$ LDA, C, LDA, ONE, CC, LDA )
ELSE
CALL SGEMM( 'No transpose', TRANS, MC, NC, NC, -ONE, C,
$ LDA, Q, LDA, ONE, CC, LDA )
END IF
*
* Compute error in the difference
*
RESID = SLANGE( '1', MC, NC, CC, LDA, RWORK )
RESULT( ( ISIDE-1 )*2+ITRANS ) = RESID /
$ ( REAL( MAX( 1, N ) )*CNORM*EPS )
*
20 CONTINUE
30 CONTINUE
*
RETURN
*
* End of SLQT03
*
END
SUBROUTINE SPBT01( UPLO, N, KD, A, LDA, AFAC, LDAFAC, RWORK,
$ RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER KD, LDA, LDAFAC, N
REAL RESID
* ..
* .. Array Arguments ..
REAL A( LDA, * ), AFAC( LDAFAC, * ), RWORK( * )
* ..
*
* Purpose
* =======
*
* SPBT01 reconstructs a symmetric positive definite band matrix A from
* its L*L' or U'*U factorization and computes the residual
* norm( L*L' - A ) / ( N * norm(A) * EPS ) or
* norm( U'*U - A ) / ( N * norm(A) * EPS ),
* where EPS is the machine epsilon, L' is the conjugate transpose of
* L, and U' is the conjugate transpose of U.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The number of rows and columns of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of super-diagonals of the matrix A if UPLO = 'U',
* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The original symmetric band matrix A. If UPLO = 'U', the
* upper triangular part of A is stored as a band matrix; if
* UPLO = 'L', the lower triangular part of A is stored. The
* columns of the appropriate triangle are stored in the columns
* of A and the diagonals of the triangle are stored in the rows
* of A. See SPBTRF for further details.
*
* LDA (input) INTEGER.
* The leading dimension of the array A. LDA >= max(1,KD+1).
*
* AFAC (input) REAL array, dimension (LDAFAC,N)
* The factored form of the matrix A. AFAC contains the factor
* L or U from the L*L' or U'*U factorization in band storage
* format, as computed by SPBTRF.
*
* LDAFAC (input) INTEGER
* The leading dimension of the array AFAC.
* LDAFAC >= max(1,KD+1).
*
* RWORK (workspace) REAL array, dimension (N)
*
* RESID (output) REAL
* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS )
* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS )
*
* =====================================================================
*
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, K, KC, KLEN, ML, MU
REAL ANORM, EPS, T
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SDOT, SLAMCH, SLANSB
EXTERNAL LSAME, SDOT, SLAMCH, SLANSB
* ..
* .. External Subroutines ..
EXTERNAL SSCAL, SSYR, STRMV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0.
*
IF( N.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0.
*
EPS = SLAMCH( 'Epsilon' )
ANORM = SLANSB( '1', UPLO, N, KD, A, LDA, RWORK )
IF( ANORM.LE.ZERO ) THEN
RESID = ONE / EPS
RETURN
END IF
*
* Compute the product U'*U, overwriting U.
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 10 K = N, 1, -1
KC = MAX( 1, KD+2-K )
KLEN = KD + 1 - KC
*
* Compute the (K,K) element of the result.
*
T = SDOT( KLEN+1, AFAC( KC, K ), 1, AFAC( KC, K ), 1 )
AFAC( KD+1, K ) = T
*
* Compute the rest of column K.
*
IF( KLEN.GT.0 )
$ CALL STRMV( 'Upper', 'Transpose', 'Non-unit', KLEN,
$ AFAC( KD+1, K-KLEN ), LDAFAC-1,
$ AFAC( KC, K ), 1 )
*
10 CONTINUE
*
* UPLO = 'L': Compute the product L*L', overwriting L.
*
ELSE
DO 20 K = N, 1, -1
KLEN = MIN( KD, N-K )
*
* Add a multiple of column K of the factor L to each of
* columns K+1 through N.
*
IF( KLEN.GT.0 )
$ CALL SSYR( 'Lower', KLEN, ONE, AFAC( 2, K ), 1,
$ AFAC( 1, K+1 ), LDAFAC-1 )
*
* Scale column K by the diagonal element.
*
T = AFAC( 1, K )
CALL SSCAL( KLEN+1, T, AFAC( 1, K ), 1 )
*
20 CONTINUE
END IF
*
* Compute the difference L*L' - A or U'*U - A.
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 40 J = 1, N
MU = MAX( 1, KD+2-J )
DO 30 I = MU, KD + 1
AFAC( I, J ) = AFAC( I, J ) - A( I, J )
30 CONTINUE
40 CONTINUE
ELSE
DO 60 J = 1, N
ML = MIN( KD+1, N-J+1 )
DO 50 I = 1, ML
AFAC( I, J ) = AFAC( I, J ) - A( I, J )
50 CONTINUE
60 CONTINUE
END IF
*
* Compute norm( L*L' - A ) / ( N * norm(A) * EPS )
*
RESID = SLANSB( 'I', UPLO, N, KD, AFAC, LDAFAC, RWORK )
*
RESID = ( ( RESID / REAL( N ) ) / ANORM ) / EPS
*
RETURN
*
* End of SPBT01
*
END
SUBROUTINE SPBT02( UPLO, N, KD, NRHS, A, LDA, X, LDX, B, LDB,
$ RWORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER KD, LDA, LDB, LDX, N, NRHS
REAL RESID
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), RWORK( * ),
$ X( LDX, * )
* ..
*
* Purpose
* =======
*
* SPBT02 computes the residual for a solution of a symmetric banded
* system of equations A*x = b:
* RESID = norm( B - A*X ) / ( norm(A) * norm(X) * EPS)
* where EPS is the machine precision.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The number of rows and columns of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of super-diagonals of the matrix A if UPLO = 'U',
* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The original symmetric band matrix A. If UPLO = 'U', the
* upper triangular part of A is stored as a band matrix; if
* UPLO = 'L', the lower triangular part of A is stored. The
* columns of the appropriate triangle are stored in the columns
* of A and the diagonals of the triangle are stored in the rows
* of A. See SPBTRF for further details.
*
* LDA (input) INTEGER.
* The leading dimension of the array A. LDA >= max(1,KD+1).
*
* X (input) REAL array, dimension (LDX,NRHS)
* The computed solution vectors for the system of linear
* equations.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the right hand side vectors for the system of
* linear equations.
* On exit, B is overwritten with the difference B - A*X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* RWORK (workspace) REAL array, dimension (N)
*
* RESID (output) REAL
* The maximum over the number of right hand sides of
* norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER J
REAL ANORM, BNORM, EPS, XNORM
* ..
* .. External Functions ..
REAL SASUM, SLAMCH, SLANSB
EXTERNAL SASUM, SLAMCH, SLANSB
* ..
* .. External Subroutines ..
EXTERNAL SSBMV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0.
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0.
*
EPS = SLAMCH( 'Epsilon' )
ANORM = SLANSB( '1', UPLO, N, KD, A, LDA, RWORK )
IF( ANORM.LE.ZERO ) THEN
RESID = ONE / EPS
RETURN
END IF
*
* Compute B - A*X
*
DO 10 J = 1, NRHS
CALL SSBMV( UPLO, N, KD, -ONE, A, LDA, X( 1, J ), 1, ONE,
$ B( 1, J ), 1 )
10 CONTINUE
*
* Compute the maximum over the number of right hand sides of
* norm( B - A*X ) / ( norm(A) * norm(X) * EPS )
*
RESID = ZERO
DO 20 J = 1, NRHS
BNORM = SASUM( N, B( 1, J ), 1 )
XNORM = SASUM( N, X( 1, J ), 1 )
IF( XNORM.LE.ZERO ) THEN
RESID = ONE / EPS
ELSE
RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) / EPS )
END IF
20 CONTINUE
*
RETURN
*
* End of SPBT02
*
END
SUBROUTINE SPBT05( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX,
$ XACT, LDXACT, FERR, BERR, RESLTS )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER KD, LDAB, LDB, LDX, LDXACT, N, NRHS
* ..
* .. Array Arguments ..
REAL AB( LDAB, * ), B( LDB, * ), BERR( * ),
$ FERR( * ), RESLTS( * ), X( LDX, * ),
$ XACT( LDXACT, * )
* ..
*
* Purpose
* =======
*
* SPBT05 tests the error bounds from iterative refinement for the
* computed solution to a system of equations A*X = B, where A is a
* symmetric band matrix.
*
* RESLTS(1) = test of the error bound
* = norm(X - XACT) / ( norm(X) * FERR )
*
* A large value is returned if this ratio is not less than one.
*
* RESLTS(2) = residual from the iterative refinement routine
* = the maximum of BERR / ( NZ*EPS + (*) ), where
* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
* and NZ = max. number of nonzeros in any row of A, plus 1
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The number of rows of the matrices X, B, and XACT, and the
* order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of super-diagonals of the matrix A if UPLO = 'U',
* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
*
* NRHS (input) INTEGER
* The number of columns of the matrices X, B, and XACT.
* NRHS >= 0.
*
* AB (input) REAL array, dimension (LDAB,N)
* The upper or lower triangle of the symmetric band matrix A,
* stored in the first KD+1 rows of the array. The j-th column
* of A is stored in the j-th column of the array AB as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* B (input) REAL array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input) REAL array, dimension (LDX,NRHS)
* The computed solution vectors. Each vector is stored as a
* column of the matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* XACT (input) REAL array, dimension (LDX,NRHS)
* The exact solution vectors. Each vector is stored as a
* column of the matrix XACT.
*
* LDXACT (input) INTEGER
* The leading dimension of the array XACT. LDXACT >= max(1,N).
*
* FERR (input) REAL array, dimension (NRHS)
* The estimated forward error bounds for each solution vector
* X. If XTRUE is the true solution, FERR bounds the magnitude
* of the largest entry in (X - XTRUE) divided by the magnitude
* of the largest entry in X.
*
* BERR (input) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector (i.e., the smallest relative change in any entry of A
* or B that makes X an exact solution).
*
* RESLTS (output) REAL array, dimension (2)
* The maximum over the NRHS solution vectors of the ratios:
* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
* RESLTS(2) = BERR / ( NZ*EPS + (*) )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, IMAX, J, K, NZ
REAL AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SLAMCH
EXTERNAL LSAME, ISAMAX, SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0.
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESLTS( 1 ) = ZERO
RESLTS( 2 ) = ZERO
RETURN
END IF
*
EPS = SLAMCH( 'Epsilon' )
UNFL = SLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
UPPER = LSAME( UPLO, 'U' )
NZ = 2*MAX( KD, N-1 ) + 1
*
* Test 1: Compute the maximum of
* norm(X - XACT) / ( norm(X) * FERR )
* over all the vectors X and XACT using the infinity-norm.
*
ERRBND = ZERO
DO 30 J = 1, NRHS
IMAX = ISAMAX( N, X( 1, J ), 1 )
XNORM = MAX( ABS( X( IMAX, J ) ), UNFL )
DIFF = ZERO
DO 10 I = 1, N
DIFF = MAX( DIFF, ABS( X( I, J )-XACT( I, J ) ) )
10 CONTINUE
*
IF( XNORM.GT.ONE ) THEN
GO TO 20
ELSE IF( DIFF.LE.OVFL*XNORM ) THEN
GO TO 20
ELSE
ERRBND = ONE / EPS
GO TO 30
END IF
*
20 CONTINUE
IF( DIFF / XNORM.LE.FERR( J ) ) THEN
ERRBND = MAX( ERRBND, ( DIFF / XNORM ) / FERR( J ) )
ELSE
ERRBND = ONE / EPS
END IF
30 CONTINUE
RESLTS( 1 ) = ERRBND
*
* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where
* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
*
DO 90 K = 1, NRHS
DO 80 I = 1, N
TMP = ABS( B( I, K ) )
IF( UPPER ) THEN
DO 40 J = MAX( I-KD, 1 ), I
TMP = TMP + ABS( AB( KD+1-I+J, I ) )*ABS( X( J, K ) )
40 CONTINUE
DO 50 J = I + 1, MIN( I+KD, N )
TMP = TMP + ABS( AB( KD+1+I-J, J ) )*ABS( X( J, K ) )
50 CONTINUE
ELSE
DO 60 J = MAX( I-KD, 1 ), I - 1
TMP = TMP + ABS( AB( 1+I-J, J ) )*ABS( X( J, K ) )
60 CONTINUE
DO 70 J = I, MIN( I+KD, N )
TMP = TMP + ABS( AB( 1+J-I, I ) )*ABS( X( J, K ) )
70 CONTINUE
END IF
IF( I.EQ.1 ) THEN
AXBI = TMP
ELSE
AXBI = MIN( AXBI, TMP )
END IF
80 CONTINUE
TMP = BERR( K ) / ( NZ*EPS+NZ*UNFL / MAX( AXBI, NZ*UNFL ) )
IF( K.EQ.1 ) THEN
RESLTS( 2 ) = TMP
ELSE
RESLTS( 2 ) = MAX( RESLTS( 2 ), TMP )
END IF
90 CONTINUE
*
RETURN
*
* End of SPBT05
*
END
SUBROUTINE SPOT01( UPLO, N, A, LDA, AFAC, LDAFAC, RWORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDA, LDAFAC, N
REAL RESID
* ..
* .. Array Arguments ..
REAL A( LDA, * ), AFAC( LDAFAC, * ), RWORK( * )
* ..
*
* Purpose
* =======
*
* SPOT01 reconstructs a symmetric positive definite matrix A from
* its L*L' or U'*U factorization and computes the residual
* norm( L*L' - A ) / ( N * norm(A) * EPS ) or
* norm( U'*U - A ) / ( N * norm(A) * EPS ),
* where EPS is the machine epsilon.
*
* Arguments
* ==========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The number of rows and columns of the matrix A. N >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The original symmetric matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N)
*
* AFAC (input/output) REAL array, dimension (LDAFAC,N)
* On entry, the factor L or U from the L*L' or U'*U
* factorization of A.
* Overwritten with the reconstructed matrix, and then with the
* difference L*L' - A (or U'*U - A).
*
* LDAFAC (input) INTEGER
* The leading dimension of the array AFAC. LDAFAC >= max(1,N).
*
* RWORK (workspace) REAL array, dimension (N)
*
* RESID (output) REAL
* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS )
* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, K
REAL ANORM, EPS, T
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SDOT, SLAMCH, SLANSY
EXTERNAL LSAME, SDOT, SLAMCH, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL SSCAL, SSYR, STRMV
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0.
*
IF( N.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0.
*
EPS = SLAMCH( 'Epsilon' )
ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK )
IF( ANORM.LE.ZERO ) THEN
RESID = ONE / EPS
RETURN
END IF
*
* Compute the product U'*U, overwriting U.
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 10 K = N, 1, -1
*
* Compute the (K,K) element of the result.
*
T = SDOT( K, AFAC( 1, K ), 1, AFAC( 1, K ), 1 )
AFAC( K, K ) = T
*
* Compute the rest of column K.
*
CALL STRMV( 'Upper', 'Transpose', 'Non-unit', K-1, AFAC,
$ LDAFAC, AFAC( 1, K ), 1 )
*
10 CONTINUE
*
* Compute the product L*L', overwriting L.
*
ELSE
DO 20 K = N, 1, -1
*
* Add a multiple of column K of the factor L to each of
* columns K+1 through N.
*
IF( K+1.LE.N )
$ CALL SSYR( 'Lower', N-K, ONE, AFAC( K+1, K ), 1,
$ AFAC( K+1, K+1 ), LDAFAC )
*
* Scale column K by the diagonal element.
*
T = AFAC( K, K )
CALL SSCAL( N-K+1, T, AFAC( K, K ), 1 )
*
20 CONTINUE
END IF
*
* Compute the difference L*L' - A (or U'*U - A).
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 40 J = 1, N
DO 30 I = 1, J
AFAC( I, J ) = AFAC( I, J ) - A( I, J )
30 CONTINUE
40 CONTINUE
ELSE
DO 60 J = 1, N
DO 50 I = J, N
AFAC( I, J ) = AFAC( I, J ) - A( I, J )
50 CONTINUE
60 CONTINUE
END IF
*
* Compute norm( L*U - A ) / ( N * norm(A) * EPS )
*
RESID = SLANSY( '1', UPLO, N, AFAC, LDAFAC, RWORK )
*
RESID = ( ( RESID / REAL( N ) ) / ANORM ) / EPS
*
RETURN
*
* End of SPOT01
*
END
SUBROUTINE SPOT02( UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK,
$ RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDA, LDB, LDX, N, NRHS
REAL RESID
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), RWORK( * ),
$ X( LDX, * )
* ..
*
* Purpose
* =======
*
* SPOT02 computes the residual for the solution of a symmetric system
* of linear equations A*x = b:
*
* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ),
*
* where EPS is the machine epsilon.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The number of rows and columns of the matrix A. N >= 0.
*
* NRHS (input) INTEGER
* The number of columns of B, the matrix of right hand sides.
* NRHS >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The original symmetric matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N)
*
* X (input) REAL array, dimension (LDX,NRHS)
* The computed solution vectors for the system of linear
* equations.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the right hand side vectors for the system of
* linear equations.
* On exit, B is overwritten with the difference B - A*X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* RWORK (workspace) REAL array, dimension (N)
*
* RESID (output) REAL
* The maximum over the number of right hand sides of
* norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER J
REAL ANORM, BNORM, EPS, XNORM
* ..
* .. External Functions ..
REAL SASUM, SLAMCH, SLANSY
EXTERNAL SASUM, SLAMCH, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL SSYMM
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0.
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0.
*
EPS = SLAMCH( 'Epsilon' )
ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK )
IF( ANORM.LE.ZERO ) THEN
RESID = ONE / EPS
RETURN
END IF
*
* Compute B - A*X
*
CALL SSYMM( 'Left', UPLO, N, NRHS, -ONE, A, LDA, X, LDX, ONE, B,
$ LDB )
*
* Compute the maximum over the number of right hand sides of
* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) .
*
RESID = ZERO
DO 10 J = 1, NRHS
BNORM = SASUM( N, B( 1, J ), 1 )
XNORM = SASUM( N, X( 1, J ), 1 )
IF( XNORM.LE.ZERO ) THEN
RESID = ONE / EPS
ELSE
RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) / EPS )
END IF
10 CONTINUE
*
RETURN
*
* End of SPOT02
*
END
SUBROUTINE SPOT03( UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK,
$ RWORK, RCOND, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDA, LDAINV, LDWORK, N
REAL RCOND, RESID
* ..
* .. Array Arguments ..
REAL A( LDA, * ), AINV( LDAINV, * ), RWORK( * ),
$ WORK( LDWORK, * )
* ..
*
* Purpose
* =======
*
* SPOT03 computes the residual for a symmetric matrix times its
* inverse:
* norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ),
* where EPS is the machine epsilon.
*
* Arguments
* ==========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The number of rows and columns of the matrix A. N >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The original symmetric matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N)
*
* AINV (input/output) REAL array, dimension (LDAINV,N)
* On entry, the inverse of the matrix A, stored as a symmetric
* matrix in the same format as A.
* In this version, AINV is expanded into a full matrix and
* multiplied by A, so the opposing triangle of AINV will be
* changed; i.e., if the upper triangular part of AINV is
* stored, the lower triangular part will be used as work space.
*
* LDAINV (input) INTEGER
* The leading dimension of the array AINV. LDAINV >= max(1,N).
*
* WORK (workspace) REAL array, dimension (LDWORK,N)
*
* LDWORK (input) INTEGER
* The leading dimension of the array WORK. LDWORK >= max(1,N).
*
* RWORK (workspace) REAL array, dimension (N)
*
* RCOND (output) REAL
* The reciprocal of the condition number of A, computed as
* ( 1/norm(A) ) / norm(AINV).
*
* RESID (output) REAL
* norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
REAL AINVNM, ANORM, EPS
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANGE, SLANSY
EXTERNAL LSAME, SLAMCH, SLANGE, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL SSYMM
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0.
*
IF( N.LE.0 ) THEN
RCOND = ONE
RESID = ZERO
RETURN
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0.
*
EPS = SLAMCH( 'Epsilon' )
ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK )
AINVNM = SLANSY( '1', UPLO, N, AINV, LDAINV, RWORK )
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCOND = ZERO
RESID = ONE / EPS
RETURN
END IF
RCOND = ( ONE / ANORM ) / AINVNM
*
* Expand AINV into a full matrix and call SSYMM to multiply
* AINV on the left by A.
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = 1, J - 1
AINV( J, I ) = AINV( I, J )
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1, N
DO 30 I = J + 1, N
AINV( J, I ) = AINV( I, J )
30 CONTINUE
40 CONTINUE
END IF
CALL SSYMM( 'Left', UPLO, N, N, -ONE, A, LDA, AINV, LDAINV, ZERO,
$ WORK, LDWORK )
*
* Add the identity matrix to WORK .
*
DO 50 I = 1, N
WORK( I, I ) = WORK( I, I ) + ONE
50 CONTINUE
*
* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS)
*
RESID = SLANGE( '1', N, N, WORK, LDWORK, RWORK )
*
RESID = ( ( RESID*RCOND ) / EPS ) / REAL( N )
*
RETURN
*
* End of SPOT03
*
END
SUBROUTINE SPOT05( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, XACT,
$ LDXACT, FERR, BERR, RESLTS )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDA, LDB, LDX, LDXACT, N, NRHS
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ),
$ RESLTS( * ), X( LDX, * ), XACT( LDXACT, * )
* ..
*
* Purpose
* =======
*
* SPOT05 tests the error bounds from iterative refinement for the
* computed solution to a system of equations A*X = B, where A is a
* symmetric n by n matrix.
*
* RESLTS(1) = test of the error bound
* = norm(X - XACT) / ( norm(X) * FERR )
*
* A large value is returned if this ratio is not less than one.
*
* RESLTS(2) = residual from the iterative refinement routine
* = the maximum of BERR / ( (n+1)*EPS + (*) ), where
* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The number of rows of the matrices X, B, and XACT, and the
* order of the matrix A. N >= 0.
*
* NRHS (input) INTEGER
* The number of columns of the matrices X, B, and XACT.
* NRHS >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The symmetric matrix A. If UPLO = 'U', the leading n by n
* upper triangular part of A contains the upper triangular part
* of the matrix A, and the strictly lower triangular part of A
* is not referenced. If UPLO = 'L', the leading n by n lower
* triangular part of A contains the lower triangular part of
* the matrix A, and the strictly upper triangular part of A is
* not referenced.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input) REAL array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input) REAL array, dimension (LDX,NRHS)
* The computed solution vectors. Each vector is stored as a
* column of the matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* XACT (input) REAL array, dimension (LDX,NRHS)
* The exact solution vectors. Each vector is stored as a
* column of the matrix XACT.
*
* LDXACT (input) INTEGER
* The leading dimension of the array XACT. LDXACT >= max(1,N).
*
* FERR (input) REAL array, dimension (NRHS)
* The estimated forward error bounds for each solution vector
* X. If XTRUE is the true solution, FERR bounds the magnitude
* of the largest entry in (X - XTRUE) divided by the magnitude
* of the largest entry in X.
*
* BERR (input) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector (i.e., the smallest relative change in any entry of A
* or B that makes X an exact solution).
*
* RESLTS (output) REAL array, dimension (2)
* The maximum over the NRHS solution vectors of the ratios:
* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
* RESLTS(2) = BERR / ( (n+1)*EPS + (*) )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, IMAX, J, K
REAL AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SLAMCH
EXTERNAL LSAME, ISAMAX, SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0.
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESLTS( 1 ) = ZERO
RESLTS( 2 ) = ZERO
RETURN
END IF
*
EPS = SLAMCH( 'Epsilon' )
UNFL = SLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
UPPER = LSAME( UPLO, 'U' )
*
* Test 1: Compute the maximum of
* norm(X - XACT) / ( norm(X) * FERR )
* over all the vectors X and XACT using the infinity-norm.
*
ERRBND = ZERO
DO 30 J = 1, NRHS
IMAX = ISAMAX( N, X( 1, J ), 1 )
XNORM = MAX( ABS( X( IMAX, J ) ), UNFL )
DIFF = ZERO
DO 10 I = 1, N
DIFF = MAX( DIFF, ABS( X( I, J )-XACT( I, J ) ) )
10 CONTINUE
*
IF( XNORM.GT.ONE ) THEN
GO TO 20
ELSE IF( DIFF.LE.OVFL*XNORM ) THEN
GO TO 20
ELSE
ERRBND = ONE / EPS
GO TO 30
END IF
*
20 CONTINUE
IF( DIFF / XNORM.LE.FERR( J ) ) THEN
ERRBND = MAX( ERRBND, ( DIFF / XNORM ) / FERR( J ) )
ELSE
ERRBND = ONE / EPS
END IF
30 CONTINUE
RESLTS( 1 ) = ERRBND
*
* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where
* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
*
DO 90 K = 1, NRHS
DO 80 I = 1, N
TMP = ABS( B( I, K ) )
IF( UPPER ) THEN
DO 40 J = 1, I
TMP = TMP + ABS( A( J, I ) )*ABS( X( J, K ) )
40 CONTINUE
DO 50 J = I + 1, N
TMP = TMP + ABS( A( I, J ) )*ABS( X( J, K ) )
50 CONTINUE
ELSE
DO 60 J = 1, I - 1
TMP = TMP + ABS( A( I, J ) )*ABS( X( J, K ) )
60 CONTINUE
DO 70 J = I, N
TMP = TMP + ABS( A( J, I ) )*ABS( X( J, K ) )
70 CONTINUE
END IF
IF( I.EQ.1 ) THEN
AXBI = TMP
ELSE
AXBI = MIN( AXBI, TMP )
END IF
80 CONTINUE
TMP = BERR( K ) / ( ( N+1 )*EPS+( N+1 )*UNFL /
$ MAX( AXBI, ( N+1 )*UNFL ) )
IF( K.EQ.1 ) THEN
RESLTS( 2 ) = TMP
ELSE
RESLTS( 2 ) = MAX( RESLTS( 2 ), TMP )
END IF
90 CONTINUE
*
RETURN
*
* End of SPOT05
*
END
SUBROUTINE SPPT01( UPLO, N, A, AFAC, RWORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER N
REAL RESID
* ..
* .. Array Arguments ..
REAL A( * ), AFAC( * ), RWORK( * )
* ..
*
* Purpose
* =======
*
* SPPT01 reconstructs a symmetric positive definite packed matrix A
* from its L*L' or U'*U factorization and computes the residual
* norm( L*L' - A ) / ( N * norm(A) * EPS ) or
* norm( U'*U - A ) / ( N * norm(A) * EPS ),
* where EPS is the machine epsilon.
*
* Arguments
* ==========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The number of rows and columns of the matrix A. N >= 0.
*
* A (input) REAL array, dimension (N*(N+1)/2)
* The original symmetric matrix A, stored as a packed
* triangular matrix.
*
* AFAC (input/output) REAL array, dimension (N*(N+1)/2)
* On entry, the factor L or U from the L*L' or U'*U
* factorization of A, stored as a packed triangular matrix.
* Overwritten with the reconstructed matrix, and then with the
* difference L*L' - A (or U'*U - A).
*
* RWORK (workspace) REAL array, dimension (N)
*
* RESID (output) REAL
* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS )
* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, K, KC, NPP
REAL ANORM, EPS, T
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SDOT, SLAMCH, SLANSP
EXTERNAL LSAME, SDOT, SLAMCH, SLANSP
* ..
* .. External Subroutines ..
EXTERNAL SSCAL, SSPR, STPMV
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0
*
IF( N.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0.
*
EPS = SLAMCH( 'Epsilon' )
ANORM = SLANSP( '1', UPLO, N, A, RWORK )
IF( ANORM.LE.ZERO ) THEN
RESID = ONE / EPS
RETURN
END IF
*
* Compute the product U'*U, overwriting U.
*
IF( LSAME( UPLO, 'U' ) ) THEN
KC = ( N*( N-1 ) ) / 2 + 1
DO 10 K = N, 1, -1
*
* Compute the (K,K) element of the result.
*
T = SDOT( K, AFAC( KC ), 1, AFAC( KC ), 1 )
AFAC( KC+K-1 ) = T
*
* Compute the rest of column K.
*
IF( K.GT.1 ) THEN
CALL STPMV( 'Upper', 'Transpose', 'Non-unit', K-1, AFAC,
$ AFAC( KC ), 1 )
KC = KC - ( K-1 )
END IF
10 CONTINUE
*
* Compute the product L*L', overwriting L.
*
ELSE
KC = ( N*( N+1 ) ) / 2
DO 20 K = N, 1, -1
*
* Add a multiple of column K of the factor L to each of
* columns K+1 through N.
*
IF( K.LT.N )
$ CALL SSPR( 'Lower', N-K, ONE, AFAC( KC+1 ), 1,
$ AFAC( KC+N-K+1 ) )
*
* Scale column K by the diagonal element.
*
T = AFAC( KC )
CALL SSCAL( N-K+1, T, AFAC( KC ), 1 )
*
KC = KC - ( N-K+2 )
20 CONTINUE
END IF
*
* Compute the difference L*L' - A (or U'*U - A).
*
NPP = N*( N+1 ) / 2
DO 30 I = 1, NPP
AFAC( I ) = AFAC( I ) - A( I )
30 CONTINUE
*
* Compute norm( L*U - A ) / ( N * norm(A) * EPS )
*
RESID = SLANSP( '1', UPLO, N, AFAC, RWORK )
*
RESID = ( ( RESID / REAL( N ) ) / ANORM ) / EPS
*
RETURN
*
* End of SPPT01
*
END
SUBROUTINE SPPT02( UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK,
$ RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDB, LDX, N, NRHS
REAL RESID
* ..
* .. Array Arguments ..
REAL A( * ), B( LDB, * ), RWORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* SPPT02 computes the residual in the solution of a symmetric system
* of linear equations A*x = b when packed storage is used for the
* coefficient matrix. The ratio computed is
*
* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS),
*
* where EPS is the machine precision.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The number of rows and columns of the matrix A. N >= 0.
*
* NRHS (input) INTEGER
* The number of columns of B, the matrix of right hand sides.
* NRHS >= 0.
*
* A (input) REAL array, dimension (N*(N+1)/2)
* The original symmetric matrix A, stored as a packed
* triangular matrix.
*
* X (input) REAL array, dimension (LDX,NRHS)
* The computed solution vectors for the system of linear
* equations.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the right hand side vectors for the system of
* linear equations.
* On exit, B is overwritten with the difference B - A*X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* RWORK (workspace) REAL array, dimension (N)
*
* RESID (output) REAL
* The maximum over the number of right hand sides of
* norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER J
REAL ANORM, BNORM, EPS, XNORM
* ..
* .. External Functions ..
REAL SASUM, SLAMCH, SLANSP
EXTERNAL SASUM, SLAMCH, SLANSP
* ..
* .. External Subroutines ..
EXTERNAL SSPMV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0.
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0.
*
EPS = SLAMCH( 'Epsilon' )
ANORM = SLANSP( '1', UPLO, N, A, RWORK )
IF( ANORM.LE.ZERO ) THEN
RESID = ONE / EPS
RETURN
END IF
*
* Compute B - A*X for the matrix of right hand sides B.
*
DO 10 J = 1, NRHS
CALL SSPMV( UPLO, N, -ONE, A, X( 1, J ), 1, ONE, B( 1, J ), 1 )
10 CONTINUE
*
* Compute the maximum over the number of right hand sides of
* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) .
*
RESID = ZERO
DO 20 J = 1, NRHS
BNORM = SASUM( N, B( 1, J ), 1 )
XNORM = SASUM( N, X( 1, J ), 1 )
IF( XNORM.LE.ZERO ) THEN
RESID = ONE / EPS
ELSE
RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) / EPS )
END IF
20 CONTINUE
*
RETURN
*
* End of SPPT02
*
END
SUBROUTINE SPPT03( UPLO, N, A, AINV, WORK, LDWORK, RWORK, RCOND,
$ RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDWORK, N
REAL RCOND, RESID
* ..
* .. Array Arguments ..
REAL A( * ), AINV( * ), RWORK( * ),
$ WORK( LDWORK, * )
* ..
*
* Purpose
* =======
*
* SPPT03 computes the residual for a symmetric packed matrix times its
* inverse:
* norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ),
* where EPS is the machine epsilon.
*
* Arguments
* ==========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The number of rows and columns of the matrix A. N >= 0.
*
* A (input) REAL array, dimension (N*(N+1)/2)
* The original symmetric matrix A, stored as a packed
* triangular matrix.
*
* AINV (input) REAL array, dimension (N*(N+1)/2)
* The (symmetric) inverse of the matrix A, stored as a packed
* triangular matrix.
*
* WORK (workspace) REAL array, dimension (LDWORK,N)
*
* LDWORK (input) INTEGER
* The leading dimension of the array WORK. LDWORK >= max(1,N).
*
* RWORK (workspace) REAL array, dimension (N)
*
* RCOND (output) REAL
* The reciprocal of the condition number of A, computed as
* ( 1/norm(A) ) / norm(AINV).
*
* RESID (output) REAL
* norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, JJ
REAL AINVNM, ANORM, EPS
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANGE, SLANSP
EXTERNAL LSAME, SLAMCH, SLANGE, SLANSP
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SSPMV
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0.
*
IF( N.LE.0 ) THEN
RCOND = ONE
RESID = ZERO
RETURN
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0.
*
EPS = SLAMCH( 'Epsilon' )
ANORM = SLANSP( '1', UPLO, N, A, RWORK )
AINVNM = SLANSP( '1', UPLO, N, AINV, RWORK )
IF( ANORM.LE.ZERO .OR. AINVNM.EQ.ZERO ) THEN
RCOND = ZERO
RESID = ONE / EPS
RETURN
END IF
RCOND = ( ONE / ANORM ) / AINVNM
*
* UPLO = 'U':
* Copy the leading N-1 x N-1 submatrix of AINV to WORK(1:N,2:N) and
* expand it to a full matrix, then multiply by A one column at a
* time, moving the result one column to the left.
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Copy AINV
*
JJ = 1
DO 10 J = 1, N - 1
CALL SCOPY( J, AINV( JJ ), 1, WORK( 1, J+1 ), 1 )
CALL SCOPY( J-1, AINV( JJ ), 1, WORK( J, 2 ), LDWORK )
JJ = JJ + J
10 CONTINUE
JJ = ( ( N-1 )*N ) / 2 + 1
CALL SCOPY( N-1, AINV( JJ ), 1, WORK( N, 2 ), LDWORK )
*
* Multiply by A
*
DO 20 J = 1, N - 1
CALL SSPMV( 'Upper', N, -ONE, A, WORK( 1, J+1 ), 1, ZERO,
$ WORK( 1, J ), 1 )
20 CONTINUE
CALL SSPMV( 'Upper', N, -ONE, A, AINV( JJ ), 1, ZERO,
$ WORK( 1, N ), 1 )
*
* UPLO = 'L':
* Copy the trailing N-1 x N-1 submatrix of AINV to WORK(1:N,1:N-1)
* and multiply by A, moving each column to the right.
*
ELSE
*
* Copy AINV
*
CALL SCOPY( N-1, AINV( 2 ), 1, WORK( 1, 1 ), LDWORK )
JJ = N + 1
DO 30 J = 2, N
CALL SCOPY( N-J+1, AINV( JJ ), 1, WORK( J, J-1 ), 1 )
CALL SCOPY( N-J, AINV( JJ+1 ), 1, WORK( J, J ), LDWORK )
JJ = JJ + N - J + 1
30 CONTINUE
*
* Multiply by A
*
DO 40 J = N, 2, -1
CALL SSPMV( 'Lower', N, -ONE, A, WORK( 1, J-1 ), 1, ZERO,
$ WORK( 1, J ), 1 )
40 CONTINUE
CALL SSPMV( 'Lower', N, -ONE, A, AINV( 1 ), 1, ZERO,
$ WORK( 1, 1 ), 1 )
*
END IF
*
* Add the identity matrix to WORK .
*
DO 50 I = 1, N
WORK( I, I ) = WORK( I, I ) + ONE
50 CONTINUE
*
* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS)
*
RESID = SLANGE( '1', N, N, WORK, LDWORK, RWORK )
*
RESID = ( ( RESID*RCOND ) / EPS ) / REAL( N )
*
RETURN
*
* End of SPPT03
*
END
SUBROUTINE SPPT05( UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT,
$ LDXACT, FERR, BERR, RESLTS )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDB, LDX, LDXACT, N, NRHS
* ..
* .. Array Arguments ..
REAL AP( * ), B( LDB, * ), BERR( * ), FERR( * ),
$ RESLTS( * ), X( LDX, * ), XACT( LDXACT, * )
* ..
*
* Purpose
* =======
*
* SPPT05 tests the error bounds from iterative refinement for the
* computed solution to a system of equations A*X = B, where A is a
* symmetric matrix in packed storage format.
*
* RESLTS(1) = test of the error bound
* = norm(X - XACT) / ( norm(X) * FERR )
*
* A large value is returned if this ratio is not less than one.
*
* RESLTS(2) = residual from the iterative refinement routine
* = the maximum of BERR / ( (n+1)*EPS + (*) ), where
* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The number of rows of the matrices X, B, and XACT, and the
* order of the matrix A. N >= 0.
*
* NRHS (input) INTEGER
* The number of columns of the matrices X, B, and XACT.
* NRHS >= 0.
*
* AP (input) REAL array, dimension (N*(N+1)/2)
* The upper or lower triangle of the symmetric matrix A, packed
* columnwise in a linear array. The j-th column of A is stored
* in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
*
* B (input) REAL array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input) REAL array, dimension (LDX,NRHS)
* The computed solution vectors. Each vector is stored as a
* column of the matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* XACT (input) REAL array, dimension (LDX,NRHS)
* The exact solution vectors. Each vector is stored as a
* column of the matrix XACT.
*
* LDXACT (input) INTEGER
* The leading dimension of the array XACT. LDXACT >= max(1,N).
*
* FERR (input) REAL array, dimension (NRHS)
* The estimated forward error bounds for each solution vector
* X. If XTRUE is the true solution, FERR bounds the magnitude
* of the largest entry in (X - XTRUE) divided by the magnitude
* of the largest entry in X.
*
* BERR (input) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector (i.e., the smallest relative change in any entry of A
* or B that makes X an exact solution).
*
* RESLTS (output) REAL array, dimension (2)
* The maximum over the NRHS solution vectors of the ratios:
* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
* RESLTS(2) = BERR / ( (n+1)*EPS + (*) )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, IMAX, J, JC, K
REAL AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SLAMCH
EXTERNAL LSAME, ISAMAX, SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0.
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESLTS( 1 ) = ZERO
RESLTS( 2 ) = ZERO
RETURN
END IF
*
EPS = SLAMCH( 'Epsilon' )
UNFL = SLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
UPPER = LSAME( UPLO, 'U' )
*
* Test 1: Compute the maximum of
* norm(X - XACT) / ( norm(X) * FERR )
* over all the vectors X and XACT using the infinity-norm.
*
ERRBND = ZERO
DO 30 J = 1, NRHS
IMAX = ISAMAX( N, X( 1, J ), 1 )
XNORM = MAX( ABS( X( IMAX, J ) ), UNFL )
DIFF = ZERO
DO 10 I = 1, N
DIFF = MAX( DIFF, ABS( X( I, J )-XACT( I, J ) ) )
10 CONTINUE
*
IF( XNORM.GT.ONE ) THEN
GO TO 20
ELSE IF( DIFF.LE.OVFL*XNORM ) THEN
GO TO 20
ELSE
ERRBND = ONE / EPS
GO TO 30
END IF
*
20 CONTINUE
IF( DIFF / XNORM.LE.FERR( J ) ) THEN
ERRBND = MAX( ERRBND, ( DIFF / XNORM ) / FERR( J ) )
ELSE
ERRBND = ONE / EPS
END IF
30 CONTINUE
RESLTS( 1 ) = ERRBND
*
* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where
* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
*
DO 90 K = 1, NRHS
DO 80 I = 1, N
TMP = ABS( B( I, K ) )
IF( UPPER ) THEN
JC = ( ( I-1 )*I ) / 2
DO 40 J = 1, I
TMP = TMP + ABS( AP( JC+J ) )*ABS( X( J, K ) )
40 CONTINUE
JC = JC + I
DO 50 J = I + 1, N
TMP = TMP + ABS( AP( JC ) )*ABS( X( J, K ) )
JC = JC + J
50 CONTINUE
ELSE
JC = I
DO 60 J = 1, I - 1
TMP = TMP + ABS( AP( JC ) )*ABS( X( J, K ) )
JC = JC + N - J
60 CONTINUE
DO 70 J = I, N
TMP = TMP + ABS( AP( JC+J-I ) )*ABS( X( J, K ) )
70 CONTINUE
END IF
IF( I.EQ.1 ) THEN
AXBI = TMP
ELSE
AXBI = MIN( AXBI, TMP )
END IF
80 CONTINUE
TMP = BERR( K ) / ( ( N+1 )*EPS+( N+1 )*UNFL /
$ MAX( AXBI, ( N+1 )*UNFL ) )
IF( K.EQ.1 ) THEN
RESLTS( 2 ) = TMP
ELSE
RESLTS( 2 ) = MAX( RESLTS( 2 ), TMP )
END IF
90 CONTINUE
*
RETURN
*
* End of SPPT05
*
END
SUBROUTINE SPTT01( N, D, E, DF, EF, WORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER N
REAL RESID
* ..
* .. Array Arguments ..
REAL D( * ), DF( * ), E( * ), EF( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SPTT01 reconstructs a tridiagonal matrix A from its L*D*L'
* factorization and computes the residual
* norm(L*D*L' - A) / ( n * norm(A) * EPS ),
* where EPS is the machine epsilon.
*
* Arguments
* =========
*
* N (input) INTEGTER
* The order of the matrix A.
*
* D (input) REAL array, dimension (N)
* The n diagonal elements of the tridiagonal matrix A.
*
* E (input) REAL array, dimension (N-1)
* The (n-1) subdiagonal elements of the tridiagonal matrix A.
*
* DF (input) REAL array, dimension (N)
* The n diagonal elements of the factor L from the L*D*L'
* factorization of A.
*
* EF (input) REAL array, dimension (N-1)
* The (n-1) subdiagonal elements of the factor L from the
* L*D*L' factorization of A.
*
* WORK (workspace) REAL array, dimension (2*N)
*
* RESID (output) REAL
* norm(L*D*L' - A) / (n * norm(A) * EPS)
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I
REAL ANORM, DE, EPS
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, REAL
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
EPS = SLAMCH( 'Epsilon' )
*
* Construct the difference L*D*L' - A.
*
WORK( 1 ) = DF( 1 ) - D( 1 )
DO 10 I = 1, N - 1
DE = DF( I )*EF( I )
WORK( N+I ) = DE - E( I )
WORK( 1+I ) = DE*EF( I ) + DF( I+1 ) - D( I+1 )
10 CONTINUE
*
* Compute the 1-norms of the tridiagonal matrices A and WORK.
*
IF( N.EQ.1 ) THEN
ANORM = D( 1 )
RESID = ABS( WORK( 1 ) )
ELSE
ANORM = MAX( D( 1 )+ABS( E( 1 ) ), D( N )+ABS( E( N-1 ) ) )
RESID = MAX( ABS( WORK( 1 ) )+ABS( WORK( N+1 ) ),
$ ABS( WORK( N ) )+ABS( WORK( 2*N-1 ) ) )
DO 20 I = 2, N - 1
ANORM = MAX( ANORM, D( I )+ABS( E( I ) )+ABS( E( I-1 ) ) )
RESID = MAX( RESID, ABS( WORK( I ) )+ABS( WORK( N+I-1 ) )+
$ ABS( WORK( N+I ) ) )
20 CONTINUE
END IF
*
* Compute norm(L*D*L' - A) / (n * norm(A) * EPS)
*
IF( ANORM.LE.ZERO ) THEN
IF( RESID.NE.ZERO )
$ RESID = ONE / EPS
ELSE
RESID = ( ( RESID / REAL( N ) ) / ANORM ) / EPS
END IF
*
RETURN
*
* End of SPTT01
*
END
SUBROUTINE SPTT02( N, NRHS, D, E, X, LDX, B, LDB, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDB, LDX, N, NRHS
REAL RESID
* ..
* .. Array Arguments ..
REAL B( LDB, * ), D( * ), E( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* SPTT02 computes the residual for the solution to a symmetric
* tridiagonal system of equations:
* RESID = norm(B - A*X) / (norm(A) * norm(X) * EPS),
* where EPS is the machine epsilon.
*
* Arguments
* =========
*
* N (input) INTEGTER
* The order of the matrix A.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrices B and X. NRHS >= 0.
*
* D (input) REAL array, dimension (N)
* The n diagonal elements of the tridiagonal matrix A.
*
* E (input) REAL array, dimension (N-1)
* The (n-1) subdiagonal elements of the tridiagonal matrix A.
*
* X (input) REAL array, dimension (LDX,NRHS)
* The n by nrhs matrix of solution vectors X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the n by nrhs matrix of right hand side vectors B.
* On exit, B is overwritten with the difference B - A*X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* RESID (output) REAL
* norm(B - A*X) / (norm(A) * norm(X) * EPS)
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER J
REAL ANORM, BNORM, EPS, XNORM
* ..
* .. External Functions ..
REAL SASUM, SLAMCH, SLANST
EXTERNAL SASUM, SLAMCH, SLANST
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. External Subroutines ..
EXTERNAL SLAPTM
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Compute the 1-norm of the tridiagonal matrix A.
*
ANORM = SLANST( '1', N, D, E )
*
* Exit with RESID = 1/EPS if ANORM = 0.
*
EPS = SLAMCH( 'Epsilon' )
IF( ANORM.LE.ZERO ) THEN
RESID = ONE / EPS
RETURN
END IF
*
* Compute B - A*X.
*
CALL SLAPTM( N, NRHS, -ONE, D, E, X, LDX, ONE, B, LDB )
*
* Compute the maximum over the number of right hand sides of
* norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
*
RESID = ZERO
DO 10 J = 1, NRHS
BNORM = SASUM( N, B( 1, J ), 1 )
XNORM = SASUM( N, X( 1, J ), 1 )
IF( XNORM.LE.ZERO ) THEN
RESID = ONE / EPS
ELSE
RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) / EPS )
END IF
10 CONTINUE
*
RETURN
*
* End of SPTT02
*
END
SUBROUTINE SPTT05( N, NRHS, D, E, B, LDB, X, LDX, XACT, LDXACT,
$ FERR, BERR, RESLTS )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDB, LDX, LDXACT, N, NRHS
* ..
* .. Array Arguments ..
REAL B( LDB, * ), BERR( * ), D( * ), E( * ),
$ FERR( * ), RESLTS( * ), X( LDX, * ),
$ XACT( LDXACT, * )
* ..
*
* Purpose
* =======
*
* SPTT05 tests the error bounds from iterative refinement for the
* computed solution to a system of equations A*X = B, where A is a
* symmetric tridiagonal matrix of order n.
*
* RESLTS(1) = test of the error bound
* = norm(X - XACT) / ( norm(X) * FERR )
*
* A large value is returned if this ratio is not less than one.
*
* RESLTS(2) = residual from the iterative refinement routine
* = the maximum of BERR / ( NZ*EPS + (*) ), where
* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
* and NZ = max. number of nonzeros in any row of A, plus 1
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of rows of the matrices X, B, and XACT, and the
* order of the matrix A. N >= 0.
*
* NRHS (input) INTEGER
* The number of columns of the matrices X, B, and XACT.
* NRHS >= 0.
*
* D (input) REAL array, dimension (N)
* The n diagonal elements of the tridiagonal matrix A.
*
* E (input) REAL array, dimension (N-1)
* The (n-1) subdiagonal elements of the tridiagonal matrix A.
*
* B (input) REAL array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input) REAL array, dimension (LDX,NRHS)
* The computed solution vectors. Each vector is stored as a
* column of the matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* XACT (input) REAL array, dimension (LDX,NRHS)
* The exact solution vectors. Each vector is stored as a
* column of the matrix XACT.
*
* LDXACT (input) INTEGER
* The leading dimension of the array XACT. LDXACT >= max(1,N).
*
* FERR (input) REAL array, dimension (NRHS)
* The estimated forward error bounds for each solution vector
* X. If XTRUE is the true solution, FERR bounds the magnitude
* of the largest entry in (X - XTRUE) divided by the magnitude
* of the largest entry in X.
*
* BERR (input) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector (i.e., the smallest relative change in any entry of A
* or B that makes X an exact solution).
*
* RESLTS (output) REAL array, dimension (2)
* The maximum over the NRHS solution vectors of the ratios:
* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
* RESLTS(2) = BERR / ( NZ*EPS + (*) )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, IMAX, J, K, NZ
REAL AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
* ..
* .. External Functions ..
INTEGER ISAMAX
REAL SLAMCH
EXTERNAL ISAMAX, SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0.
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESLTS( 1 ) = ZERO
RESLTS( 2 ) = ZERO
RETURN
END IF
*
EPS = SLAMCH( 'Epsilon' )
UNFL = SLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
NZ = 4
*
* Test 1: Compute the maximum of
* norm(X - XACT) / ( norm(X) * FERR )
* over all the vectors X and XACT using the infinity-norm.
*
ERRBND = ZERO
DO 30 J = 1, NRHS
IMAX = ISAMAX( N, X( 1, J ), 1 )
XNORM = MAX( ABS( X( IMAX, J ) ), UNFL )
DIFF = ZERO
DO 10 I = 1, N
DIFF = MAX( DIFF, ABS( X( I, J )-XACT( I, J ) ) )
10 CONTINUE
*
IF( XNORM.GT.ONE ) THEN
GO TO 20
ELSE IF( DIFF.LE.OVFL*XNORM ) THEN
GO TO 20
ELSE
ERRBND = ONE / EPS
GO TO 30
END IF
*
20 CONTINUE
IF( DIFF / XNORM.LE.FERR( J ) ) THEN
ERRBND = MAX( ERRBND, ( DIFF / XNORM ) / FERR( J ) )
ELSE
ERRBND = ONE / EPS
END IF
30 CONTINUE
RESLTS( 1 ) = ERRBND
*
* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where
* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
*
DO 50 K = 1, NRHS
IF( N.EQ.1 ) THEN
AXBI = ABS( B( 1, K ) ) + ABS( D( 1 )*X( 1, K ) )
ELSE
AXBI = ABS( B( 1, K ) ) + ABS( D( 1 )*X( 1, K ) ) +
$ ABS( E( 1 )*X( 2, K ) )
DO 40 I = 2, N - 1
TMP = ABS( B( I, K ) ) + ABS( E( I-1 )*X( I-1, K ) ) +
$ ABS( D( I )*X( I, K ) ) + ABS( E( I )*X( I+1, K ) )
AXBI = MIN( AXBI, TMP )
40 CONTINUE
TMP = ABS( B( N, K ) ) + ABS( E( N-1 )*X( N-1, K ) ) +
$ ABS( D( N )*X( N, K ) )
AXBI = MIN( AXBI, TMP )
END IF
TMP = BERR( K ) / ( NZ*EPS+NZ*UNFL / MAX( AXBI, NZ*UNFL ) )
IF( K.EQ.1 ) THEN
RESLTS( 2 ) = TMP
ELSE
RESLTS( 2 ) = MAX( RESLTS( 2 ), TMP )
END IF
50 CONTINUE
*
RETURN
*
* End of SPTT05
*
END
SUBROUTINE SQLT01( M, N, A, AF, Q, L, LDA, TAU, WORK, LWORK,
$ RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), AF( LDA, * ), L( LDA, * ),
$ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* SQLT01 tests SGEQLF, which computes the QL factorization of an m-by-n
* matrix A, and partially tests SORGQL which forms the m-by-m
* orthogonal matrix Q.
*
* SQLT01 compares L with Q'*A, and checks that Q is orthogonal.
*
* 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) REAL array, dimension (LDA,N)
* The m-by-n matrix A.
*
* AF (output) REAL array, dimension (LDA,N)
* Details of the QL factorization of A, as returned by SGEQLF.
* See SGEQLF for further details.
*
* Q (output) REAL array, dimension (LDA,M)
* The m-by-m orthogonal matrix Q.
*
* L (workspace) REAL array, dimension (LDA,max(M,N))
*
* LDA (input) INTEGER
* The leading dimension of the arrays A, AF, Q and R.
* LDA >= max(M,N).
*
* TAU (output) REAL array, dimension (min(M,N))
* The scalar factors of the elementary reflectors, as returned
* by SGEQLF.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
*
* RWORK (workspace) REAL array, dimension (M)
*
* RESULT (output) REAL array, dimension (2)
* The test ratios:
* RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS )
* RESULT(2) = norm( I - Q'*Q ) / ( M * EPS )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
REAL ROGUE
PARAMETER ( ROGUE = -1.0E+10 )
* ..
* .. Local Scalars ..
INTEGER INFO, MINMN
REAL ANORM, EPS, RESID
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE, SLANSY
EXTERNAL SLAMCH, SLANGE, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SGEQLF, SLACPY, SLASET, SORGQL, SSYRK
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Scalars in Common ..
CHARACTER*6 SRNAMT
* ..
* .. Common blocks ..
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
MINMN = MIN( M, N )
EPS = SLAMCH( 'Epsilon' )
*
* Copy the matrix A to the array AF.
*
CALL SLACPY( 'Full', M, N, A, LDA, AF, LDA )
*
* Factorize the matrix A in the array AF.
*
SRNAMT = 'SGEQLF'
CALL SGEQLF( M, N, AF, LDA, TAU, WORK, LWORK, INFO )
*
* Copy details of Q
*
CALL SLASET( 'Full', M, M, ROGUE, ROGUE, Q, LDA )
IF( M.GE.N ) THEN
IF( N.LT.M .AND. N.GT.0 )
$ CALL SLACPY( 'Full', M-N, N, AF, LDA, Q( 1, M-N+1 ), LDA )
IF( N.GT.1 )
$ CALL SLACPY( 'Upper', N-1, N-1, AF( M-N+1, 2 ), LDA,
$ Q( M-N+1, M-N+2 ), LDA )
ELSE
IF( M.GT.1 )
$ CALL SLACPY( 'Upper', M-1, M-1, AF( 1, N-M+2 ), LDA,
$ Q( 1, 2 ), LDA )
END IF
*
* Generate the m-by-m matrix Q
*
SRNAMT = 'SORGQL'
CALL SORGQL( M, M, MINMN, Q, LDA, TAU, WORK, LWORK, INFO )
*
* Copy L
*
CALL SLASET( 'Full', M, N, ZERO, ZERO, L, LDA )
IF( M.GE.N ) THEN
IF( N.GT.0 )
$ CALL SLACPY( 'Lower', N, N, AF( M-N+1, 1 ), LDA,
$ L( M-N+1, 1 ), LDA )
ELSE
IF( N.GT.M .AND. M.GT.0 )
$ CALL SLACPY( 'Full', M, N-M, AF, LDA, L, LDA )
IF( M.GT.0 )
$ CALL SLACPY( 'Lower', M, M, AF( 1, N-M+1 ), LDA,
$ L( 1, N-M+1 ), LDA )
END IF
*
* Compute L - Q'*A
*
CALL SGEMM( 'Transpose', 'No transpose', M, N, M, -ONE, Q, LDA, A,
$ LDA, ONE, L, LDA )
*
* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) .
*
ANORM = SLANGE( '1', M, N, A, LDA, RWORK )
RESID = SLANGE( '1', M, N, L, LDA, RWORK )
IF( ANORM.GT.ZERO ) THEN
RESULT( 1 ) = ( ( RESID / REAL( MAX( 1, M ) ) ) / ANORM ) / EPS
ELSE
RESULT( 1 ) = ZERO
END IF
*
* Compute I - Q'*Q
*
CALL SLASET( 'Full', M, M, ZERO, ONE, L, LDA )
CALL SSYRK( 'Upper', 'Transpose', M, M, -ONE, Q, LDA, ONE, L,
$ LDA )
*
* Compute norm( I - Q'*Q ) / ( M * EPS ) .
*
RESID = SLANSY( '1', 'Upper', M, L, LDA, RWORK )
*
RESULT( 2 ) = ( RESID / REAL( MAX( 1, M ) ) ) / EPS
*
RETURN
*
* End of SQLT01
*
END
SUBROUTINE SQLT02( M, N, K, A, AF, Q, L, LDA, TAU, WORK, LWORK,
$ RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), AF( LDA, * ), L( LDA, * ),
$ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* SQLT02 tests SORGQL, which generates an m-by-n matrix Q with
* orthonornmal columns that is defined as the product of k elementary
* reflectors.
*
* Given the QL factorization of an m-by-n matrix A, SQLT02 generates
* the orthogonal matrix Q defined by the factorization of the last k
* columns of A; it compares L(m-n+1:m,n-k+1:n) with
* Q(1:m,m-n+1:m)'*A(1:m,n-k+1:n), and checks that the columns of Q are
* orthonormal.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix Q to be generated. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix Q to be generated.
* M >= N >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* matrix Q. N >= K >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The m-by-n matrix A which was factorized by SQLT01.
*
* AF (input) REAL array, dimension (LDA,N)
* Details of the QL factorization of A, as returned by SGEQLF.
* See SGEQLF for further details.
*
* Q (workspace) REAL array, dimension (LDA,N)
*
* L (workspace) REAL array, dimension (LDA,N)
*
* LDA (input) INTEGER
* The leading dimension of the arrays A, AF, Q and L. LDA >= M.
*
* TAU (input) REAL array, dimension (N)
* The scalar factors of the elementary reflectors corresponding
* to the QL factorization in AF.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
*
* RWORK (workspace) REAL array, dimension (M)
*
* RESULT (output) REAL array, dimension (2)
* The test ratios:
* RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS )
* RESULT(2) = norm( I - Q'*Q ) / ( M * EPS )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
REAL ROGUE
PARAMETER ( ROGUE = -1.0E+10 )
* ..
* .. Local Scalars ..
INTEGER INFO
REAL ANORM, EPS, RESID
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE, SLANSY
EXTERNAL SLAMCH, SLANGE, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SLACPY, SLASET, SORGQL, SSYRK
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, REAL
* ..
* .. Scalars in Common ..
CHARACTER*6 SRNAMT
* ..
* .. Common blocks ..
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
RESULT( 1 ) = ZERO
RESULT( 2 ) = ZERO
RETURN
END IF
*
EPS = SLAMCH( 'Epsilon' )
*
* Copy the last k columns of the factorization to the array Q
*
CALL SLASET( 'Full', M, N, ROGUE, ROGUE, Q, LDA )
IF( K.LT.M )
$ CALL SLACPY( 'Full', M-K, K, AF( 1, N-K+1 ), LDA,
$ Q( 1, N-K+1 ), LDA )
IF( K.GT.1 )
$ CALL SLACPY( 'Upper', K-1, K-1, AF( M-K+1, N-K+2 ), LDA,
$ Q( M-K+1, N-K+2 ), LDA )
*
* Generate the last n columns of the matrix Q
*
SRNAMT = 'SORGQL'
CALL SORGQL( M, N, K, Q, LDA, TAU( N-K+1 ), WORK, LWORK, INFO )
*
* Copy L(m-n+1:m,n-k+1:n)
*
CALL SLASET( 'Full', N, K, ZERO, ZERO, L( M-N+1, N-K+1 ), LDA )
CALL SLACPY( 'Lower', K, K, AF( M-K+1, N-K+1 ), LDA,
$ L( M-K+1, N-K+1 ), LDA )
*
* Compute L(m-n+1:m,n-k+1:n) - Q(1:m,m-n+1:m)' * A(1:m,n-k+1:n)
*
CALL SGEMM( 'Transpose', 'No transpose', N, K, M, -ONE, Q, LDA,
$ A( 1, N-K+1 ), LDA, ONE, L( M-N+1, N-K+1 ), LDA )
*
* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) .
*
ANORM = SLANGE( '1', M, K, A( 1, N-K+1 ), LDA, RWORK )
RESID = SLANGE( '1', N, K, L( M-N+1, N-K+1 ), LDA, RWORK )
IF( ANORM.GT.ZERO ) THEN
RESULT( 1 ) = ( ( RESID / REAL( MAX( 1, M ) ) ) / ANORM ) / EPS
ELSE
RESULT( 1 ) = ZERO
END IF
*
* Compute I - Q'*Q
*
CALL SLASET( 'Full', N, N, ZERO, ONE, L, LDA )
CALL SSYRK( 'Upper', 'Transpose', N, M, -ONE, Q, LDA, ONE, L,
$ LDA )
*
* Compute norm( I - Q'*Q ) / ( M * EPS ) .
*
RESID = SLANSY( '1', 'Upper', N, L, LDA, RWORK )
*
RESULT( 2 ) = ( RESID / REAL( MAX( 1, M ) ) ) / EPS
*
RETURN
*
* End of SQLT02
*
END
SUBROUTINE SQLT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK,
$ RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
REAL AF( LDA, * ), C( LDA, * ), CC( LDA, * ),
$ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* SQLT03 tests SORMQL, which computes Q*C, Q'*C, C*Q or C*Q'.
*
* SQLT03 compares the results of a call to SORMQL with the results of
* forming Q explicitly by a call to SORGQL and then performing matrix
* multiplication by a call to SGEMM.
*
* Arguments
* =========
*
* M (input) INTEGER
* The order of the orthogonal matrix Q. M >= 0.
*
* N (input) INTEGER
* The number of rows or columns of the matrix C; C is m-by-n if
* Q is applied from the left, or n-by-m if Q is applied from
* the right. N >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* orthogonal matrix Q. M >= K >= 0.
*
* AF (input) REAL array, dimension (LDA,N)
* Details of the QL factorization of an m-by-n matrix, as
* returned by SGEQLF. See SGEQLF for further details.
*
* C (workspace) REAL array, dimension (LDA,N)
*
* CC (workspace) REAL array, dimension (LDA,N)
*
* Q (workspace) REAL array, dimension (LDA,M)
*
* LDA (input) INTEGER
* The leading dimension of the arrays AF, C, CC, and Q.
*
* TAU (input) REAL array, dimension (min(M,N))
* The scalar factors of the elementary reflectors corresponding
* to the QL factorization in AF.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of WORK. LWORK must be at least M, and should be
* M*NB, where NB is the blocksize for this environment.
*
* RWORK (workspace) REAL array, dimension (M)
*
* RESULT (output) REAL array, dimension (4)
* The test ratios compare two techniques for multiplying a
* random matrix C by an m-by-m orthogonal matrix Q.
* RESULT(1) = norm( Q*C - Q*C ) / ( M * norm(C) * EPS )
* RESULT(2) = norm( C*Q - C*Q ) / ( M * norm(C) * EPS )
* RESULT(3) = norm( Q'*C - Q'*C )/ ( M * norm(C) * EPS )
* RESULT(4) = norm( C*Q' - C*Q' )/ ( M * norm(C) * EPS )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
REAL ROGUE
PARAMETER ( ROGUE = -1.0E+10 )
* ..
* .. Local Scalars ..
CHARACTER SIDE, TRANS
INTEGER INFO, ISIDE, ITRANS, J, MC, MINMN, NC
REAL CNORM, EPS, RESID
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANGE
EXTERNAL LSAME, SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SLACPY, SLARNV, SLASET, SORGQL, SORMQL
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 )
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Scalars in Common ..
CHARACTER*6 SRNAMT
* ..
* .. Common blocks ..
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEED / 1988, 1989, 1990, 1991 /
* ..
* .. Executable Statements ..
*
EPS = SLAMCH( 'Epsilon' )
MINMN = MIN( M, N )
*
* Quick return if possible
*
IF( MINMN.EQ.0 ) THEN
RESULT( 1 ) = ZERO
RESULT( 2 ) = ZERO
RESULT( 3 ) = ZERO
RESULT( 4 ) = ZERO
RETURN
END IF
*
* Copy the last k columns of the factorization to the array Q
*
CALL SLASET( 'Full', M, M, ROGUE, ROGUE, Q, LDA )
IF( K.GT.0 .AND. M.GT.K )
$ CALL SLACPY( 'Full', M-K, K, AF( 1, N-K+1 ), LDA,
$ Q( 1, M-K+1 ), LDA )
IF( K.GT.1 )
$ CALL SLACPY( 'Upper', K-1, K-1, AF( M-K+1, N-K+2 ), LDA,
$ Q( M-K+1, M-K+2 ), LDA )
*
* Generate the m-by-m matrix Q
*
SRNAMT = 'SORGQL'
CALL SORGQL( M, M, K, Q, LDA, TAU( MINMN-K+1 ), WORK, LWORK,
$ INFO )
*
DO 30 ISIDE = 1, 2
IF( ISIDE.EQ.1 ) THEN
SIDE = 'L'
MC = M
NC = N
ELSE
SIDE = 'R'
MC = N
NC = M
END IF
*
* Generate MC by NC matrix C
*
DO 10 J = 1, NC
CALL SLARNV( 2, ISEED, MC, C( 1, J ) )
10 CONTINUE
CNORM = SLANGE( '1', MC, NC, C, LDA, RWORK )
IF( CNORM.EQ.0.0 )
$ CNORM = ONE
*
DO 20 ITRANS = 1, 2
IF( ITRANS.EQ.1 ) THEN
TRANS = 'N'
ELSE
TRANS = 'T'
END IF
*
* Copy C
*
CALL SLACPY( 'Full', MC, NC, C, LDA, CC, LDA )
*
* Apply Q or Q' to C
*
SRNAMT = 'SORMQL'
IF( K.GT.0 )
$ CALL SORMQL( SIDE, TRANS, MC, NC, K, AF( 1, N-K+1 ), LDA,
$ TAU( MINMN-K+1 ), CC, LDA, WORK, LWORK,
$ INFO )
*
* Form explicit product and subtract
*
IF( LSAME( SIDE, 'L' ) ) THEN
CALL SGEMM( TRANS, 'No transpose', MC, NC, MC, -ONE, Q,
$ LDA, C, LDA, ONE, CC, LDA )
ELSE
CALL SGEMM( 'No transpose', TRANS, MC, NC, NC, -ONE, C,
$ LDA, Q, LDA, ONE, CC, LDA )
END IF
*
* Compute error in the difference
*
RESID = SLANGE( '1', MC, NC, CC, LDA, RWORK )
RESULT( ( ISIDE-1 )*2+ITRANS ) = RESID /
$ ( REAL( MAX( 1, M ) )*CNORM*EPS )
*
20 CONTINUE
30 CONTINUE
*
RETURN
*
* End of SQLT03
*
END
REAL FUNCTION SQPT01( M, N, K, A, AF, LDA, TAU, JPVT,
$ WORK, LWORK )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
INTEGER JPVT( * )
REAL A( LDA, * ), AF( LDA, * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* SQPT01 tests the QR-factorization with pivoting of a matrix A. The
* array AF contains the (possibly partial) QR-factorization of A, where
* the upper triangle of AF(1:k,1:k) is a partial triangular factor,
* the entries below the diagonal in the first k columns are the
* Householder vectors, and the rest of AF contains a partially updated
* matrix.
*
* This function returns ||A*P - Q*R||/(||norm(A)||*eps*M)
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrices A and AF.
*
* N (input) INTEGER
* The number of columns of the matrices A and AF.
*
* K (input) INTEGER
* The number of columns of AF that have been reduced
* to upper triangular form.
*
* A (input) REAL array, dimension (LDA, N)
* The original matrix A.
*
* AF (input) REAL array, dimension (LDA,N)
* The (possibly partial) output of SGEQPF. The upper triangle
* of AF(1:k,1:k) is a partial triangular factor, the entries
* below the diagonal in the first k columns are the Householder
* vectors, and the rest of AF contains a partially updated
* matrix.
*
* LDA (input) INTEGER
* The leading dimension of the arrays A and AF.
*
* TAU (input) REAL array, dimension (K)
* Details of the Householder transformations as returned by
* SGEQPF.
*
* JPVT (input) INTEGER array, dimension (N)
* Pivot information as returned by SGEQPF.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of the array WORK. LWORK >= M*N+N.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
REAL NORMA
* ..
* .. Local Arrays ..
REAL RWORK( 1 )
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE
EXTERNAL SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, SORMQR, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Executable Statements ..
*
SQPT01 = ZERO
*
* Test if there is enough workspace
*
IF( LWORK.LT.M*N+N ) THEN
CALL XERBLA( 'SQPT01', 10 )
RETURN
END IF
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
NORMA = SLANGE( 'One-norm', M, N, A, LDA, RWORK )
*
DO 30 J = 1, K
DO 10 I = 1, MIN( J, M )
WORK( ( J-1 )*M+I ) = AF( I, J )
10 CONTINUE
DO 20 I = J + 1, M
WORK( ( J-1 )*M+I ) = ZERO
20 CONTINUE
30 CONTINUE
DO 40 J = K + 1, N
CALL SCOPY( M, AF( 1, J ), 1, WORK( ( J-1 )*M+1 ), 1 )
40 CONTINUE
*
CALL SORMQR( 'Left', 'No transpose', M, N, K, AF, LDA, TAU, WORK,
$ M, WORK( M*N+1 ), LWORK-M*N, INFO )
*
DO 50 J = 1, N
*
* Compare i-th column of QR and jpvt(i)-th column of A
*
CALL SAXPY( M, -ONE, A( 1, JPVT( J ) ), 1, WORK( ( J-1 )*M+1 ),
$ 1 )
50 CONTINUE
*
SQPT01 = SLANGE( 'One-norm', M, N, WORK, M, RWORK ) /
$ ( REAL( MAX( M, N ) )*SLAMCH( 'Epsilon' ) )
IF( NORMA.NE.ZERO )
$ SQPT01 = SQPT01 / NORMA
*
RETURN
*
* End of SQPT01
*
END
SUBROUTINE SQRT01( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK,
$ RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), AF( LDA, * ), Q( LDA, * ),
$ R( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* SQRT01 tests SGEQRF, which computes the QR factorization of an m-by-n
* matrix A, and partially tests SORGQR which forms the m-by-m
* orthogonal matrix Q.
*
* SQRT01 compares R with Q'*A, and checks that Q is orthogonal.
*
* 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) REAL array, dimension (LDA,N)
* The m-by-n matrix A.
*
* AF (output) REAL array, dimension (LDA,N)
* Details of the QR factorization of A, as returned by SGEQRF.
* See SGEQRF for further details.
*
* Q (output) REAL array, dimension (LDA,M)
* The m-by-m orthogonal matrix Q.
*
* R (workspace) REAL array, dimension (LDA,max(M,N))
*
* LDA (input) INTEGER
* The leading dimension of the arrays A, AF, Q and R.
* LDA >= max(M,N).
*
* TAU (output) REAL array, dimension (min(M,N))
* The scalar factors of the elementary reflectors, as returned
* by SGEQRF.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
*
* RWORK (workspace) REAL array, dimension (M)
*
* RESULT (output) REAL array, dimension (2)
* The test ratios:
* RESULT(1) = norm( R - Q'*A ) / ( M * norm(A) * EPS )
* RESULT(2) = norm( I - Q'*Q ) / ( M * EPS )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
REAL ROGUE
PARAMETER ( ROGUE = -1.0E+10 )
* ..
* .. Local Scalars ..
INTEGER INFO, MINMN
REAL ANORM, EPS, RESID
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE, SLANSY
EXTERNAL SLAMCH, SLANGE, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SGEQRF, SLACPY, SLASET, SORGQR, SSYRK
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Scalars in Common ..
CHARACTER*6 SRNAMT
* ..
* .. Common blocks ..
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
MINMN = MIN( M, N )
EPS = SLAMCH( 'Epsilon' )
*
* Copy the matrix A to the array AF.
*
CALL SLACPY( 'Full', M, N, A, LDA, AF, LDA )
*
* Factorize the matrix A in the array AF.
*
SRNAMT = 'SGEQRF'
CALL SGEQRF( M, N, AF, LDA, TAU, WORK, LWORK, INFO )
*
* Copy details of Q
*
CALL SLASET( 'Full', M, M, ROGUE, ROGUE, Q, LDA )
CALL SLACPY( 'Lower', M-1, N, AF( 2, 1 ), LDA, Q( 2, 1 ), LDA )
*
* Generate the m-by-m matrix Q
*
SRNAMT = 'SORGQR'
CALL SORGQR( M, M, MINMN, Q, LDA, TAU, WORK, LWORK, INFO )
*
* Copy R
*
CALL SLASET( 'Full', M, N, ZERO, ZERO, R, LDA )
CALL SLACPY( 'Upper', M, N, AF, LDA, R, LDA )
*
* Compute R - Q'*A
*
CALL SGEMM( 'Transpose', 'No transpose', M, N, M, -ONE, Q, LDA, A,
$ LDA, ONE, R, LDA )
*
* Compute norm( R - Q'*A ) / ( M * norm(A) * EPS ) .
*
ANORM = SLANGE( '1', M, N, A, LDA, RWORK )
RESID = SLANGE( '1', M, N, R, LDA, RWORK )
IF( ANORM.GT.ZERO ) THEN
RESULT( 1 ) = ( ( RESID / REAL( MAX( 1, M ) ) ) / ANORM ) / EPS
ELSE
RESULT( 1 ) = ZERO
END IF
*
* Compute I - Q'*Q
*
CALL SLASET( 'Full', M, M, ZERO, ONE, R, LDA )
CALL SSYRK( 'Upper', 'Transpose', M, M, -ONE, Q, LDA, ONE, R,
$ LDA )
*
* Compute norm( I - Q'*Q ) / ( M * EPS ) .
*
RESID = SLANSY( '1', 'Upper', M, R, LDA, RWORK )
*
RESULT( 2 ) = ( RESID / REAL( MAX( 1, M ) ) ) / EPS
*
RETURN
*
* End of SQRT01
*
END
SUBROUTINE SQRT02( M, N, K, A, AF, Q, R, LDA, TAU, WORK, LWORK,
$ RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), AF( LDA, * ), Q( LDA, * ),
$ R( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* SQRT02 tests SORGQR, which generates an m-by-n matrix Q with
* orthonornmal columns that is defined as the product of k elementary
* reflectors.
*
* Given the QR factorization of an m-by-n matrix A, SQRT02 generates
* the orthogonal matrix Q defined by the factorization of the first k
* columns of A; it compares R(1:n,1:k) with Q(1:m,1:n)'*A(1:m,1:k),
* and checks that the columns of Q are orthonormal.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix Q to be generated. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix Q to be generated.
* M >= N >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* matrix Q. N >= K >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The m-by-n matrix A which was factorized by SQRT01.
*
* AF (input) REAL array, dimension (LDA,N)
* Details of the QR factorization of A, as returned by SGEQRF.
* See SGEQRF for further details.
*
* Q (workspace) REAL array, dimension (LDA,N)
*
* R (workspace) REAL array, dimension (LDA,N)
*
* LDA (input) INTEGER
* The leading dimension of the arrays A, AF, Q and R. LDA >= M.
*
* TAU (input) REAL array, dimension (N)
* The scalar factors of the elementary reflectors corresponding
* to the QR factorization in AF.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
*
* RWORK (workspace) REAL array, dimension (M)
*
* RESULT (output) REAL array, dimension (2)
* The test ratios:
* RESULT(1) = norm( R - Q'*A ) / ( M * norm(A) * EPS )
* RESULT(2) = norm( I - Q'*Q ) / ( M * EPS )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
REAL ROGUE
PARAMETER ( ROGUE = -1.0E+10 )
* ..
* .. Local Scalars ..
INTEGER INFO
REAL ANORM, EPS, RESID
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE, SLANSY
EXTERNAL SLAMCH, SLANGE, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SLACPY, SLASET, SORGQR, SSYRK
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, REAL
* ..
* .. Scalars in Common ..
CHARACTER*6 SRNAMT
* ..
* .. Common blocks ..
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
EPS = SLAMCH( 'Epsilon' )
*
* Copy the first k columns of the factorization to the array Q
*
CALL SLASET( 'Full', M, N, ROGUE, ROGUE, Q, LDA )
CALL SLACPY( 'Lower', M-1, K, AF( 2, 1 ), LDA, Q( 2, 1 ), LDA )
*
* Generate the first n columns of the matrix Q
*
SRNAMT = 'SORGQR'
CALL SORGQR( M, N, K, Q, LDA, TAU, WORK, LWORK, INFO )
*
* Copy R(1:n,1:k)
*
CALL SLASET( 'Full', N, K, ZERO, ZERO, R, LDA )
CALL SLACPY( 'Upper', N, K, AF, LDA, R, LDA )
*
* Compute R(1:n,1:k) - Q(1:m,1:n)' * A(1:m,1:k)
*
CALL SGEMM( 'Transpose', 'No transpose', N, K, M, -ONE, Q, LDA, A,
$ LDA, ONE, R, LDA )
*
* Compute norm( R - Q'*A ) / ( M * norm(A) * EPS ) .
*
ANORM = SLANGE( '1', M, K, A, LDA, RWORK )
RESID = SLANGE( '1', N, K, R, LDA, RWORK )
IF( ANORM.GT.ZERO ) THEN
RESULT( 1 ) = ( ( RESID / REAL( MAX( 1, M ) ) ) / ANORM ) / EPS
ELSE
RESULT( 1 ) = ZERO
END IF
*
* Compute I - Q'*Q
*
CALL SLASET( 'Full', N, N, ZERO, ONE, R, LDA )
CALL SSYRK( 'Upper', 'Transpose', N, M, -ONE, Q, LDA, ONE, R,
$ LDA )
*
* Compute norm( I - Q'*Q ) / ( M * EPS ) .
*
RESID = SLANSY( '1', 'Upper', N, R, LDA, RWORK )
*
RESULT( 2 ) = ( RESID / REAL( MAX( 1, M ) ) ) / EPS
*
RETURN
*
* End of SQRT02
*
END
SUBROUTINE SQRT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK,
$ RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
REAL AF( LDA, * ), C( LDA, * ), CC( LDA, * ),
$ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* SQRT03 tests SORMQR, which computes Q*C, Q'*C, C*Q or C*Q'.
*
* SQRT03 compares the results of a call to SORMQR with the results of
* forming Q explicitly by a call to SORGQR and then performing matrix
* multiplication by a call to SGEMM.
*
* Arguments
* =========
*
* M (input) INTEGER
* The order of the orthogonal matrix Q. M >= 0.
*
* N (input) INTEGER
* The number of rows or columns of the matrix C; C is m-by-n if
* Q is applied from the left, or n-by-m if Q is applied from
* the right. N >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* orthogonal matrix Q. M >= K >= 0.
*
* AF (input) REAL array, dimension (LDA,N)
* Details of the QR factorization of an m-by-n matrix, as
* returnedby SGEQRF. See SGEQRF for further details.
*
* C (workspace) REAL array, dimension (LDA,N)
*
* CC (workspace) REAL array, dimension (LDA,N)
*
* Q (workspace) REAL array, dimension (LDA,M)
*
* LDA (input) INTEGER
* The leading dimension of the arrays AF, C, CC, and Q.
*
* TAU (input) REAL array, dimension (min(M,N))
* The scalar factors of the elementary reflectors corresponding
* to the QR factorization in AF.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of WORK. LWORK must be at least M, and should be
* M*NB, where NB is the blocksize for this environment.
*
* RWORK (workspace) REAL array, dimension (M)
*
* RESULT (output) REAL array, dimension (4)
* The test ratios compare two techniques for multiplying a
* random matrix C by an m-by-m orthogonal matrix Q.
* RESULT(1) = norm( Q*C - Q*C ) / ( M * norm(C) * EPS )
* RESULT(2) = norm( C*Q - C*Q ) / ( M * norm(C) * EPS )
* RESULT(3) = norm( Q'*C - Q'*C )/ ( M * norm(C) * EPS )
* RESULT(4) = norm( C*Q' - C*Q' )/ ( M * norm(C) * EPS )
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E0 )
REAL ROGUE
PARAMETER ( ROGUE = -1.0E+10 )
* ..
* .. Local Scalars ..
CHARACTER SIDE, TRANS
INTEGER INFO, ISIDE, ITRANS, J, MC, NC
REAL CNORM, EPS, RESID
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANGE
EXTERNAL LSAME, SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SLACPY, SLARNV, SLASET, SORGQR, SORMQR
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 )
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, REAL
* ..
* .. Scalars in Common ..
CHARACTER*6 SRNAMT
* ..
* .. Common blocks ..
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEED / 1988, 1989, 1990, 1991 /
* ..
* .. Executable Statements ..
*
EPS = SLAMCH( 'Epsilon' )
*
* Copy the first k columns of the factorization to the array Q
*
CALL SLASET( 'Full', M, M, ROGUE, ROGUE, Q, LDA )
CALL SLACPY( 'Lower', M-1, K, AF( 2, 1 ), LDA, Q( 2, 1 ), LDA )
*
* Generate the m-by-m matrix Q
*
SRNAMT = 'SORGQR'
CALL SORGQR( M, M, K, Q, LDA, TAU, WORK, LWORK, INFO )
*
DO 30 ISIDE = 1, 2
IF( ISIDE.EQ.1 ) THEN
SIDE = 'L'
MC = M
NC = N
ELSE
SIDE = 'R'
MC = N
NC = M
END IF
*
* Generate MC by NC matrix C
*
DO 10 J = 1, NC
CALL SLARNV( 2, ISEED, MC, C( 1, J ) )
10 CONTINUE
CNORM = SLANGE( '1', MC, NC, C, LDA, RWORK )
IF( CNORM.EQ.0.0 )
$ CNORM = ONE
*
DO 20 ITRANS = 1, 2
IF( ITRANS.EQ.1 ) THEN
TRANS = 'N'
ELSE
TRANS = 'T'
END IF
*
* Copy C
*
CALL SLACPY( 'Full', MC, NC, C, LDA, CC, LDA )
*
* Apply Q or Q' to C
*
SRNAMT = 'SORMQR'
CALL SORMQR( SIDE, TRANS, MC, NC, K, AF, LDA, TAU, CC, LDA,
$ WORK, LWORK, INFO )
*
* Form explicit product and subtract
*
IF( LSAME( SIDE, 'L' ) ) THEN
CALL SGEMM( TRANS, 'No transpose', MC, NC, MC, -ONE, Q,
$ LDA, C, LDA, ONE, CC, LDA )
ELSE
CALL SGEMM( 'No transpose', TRANS, MC, NC, NC, -ONE, C,
$ LDA, Q, LDA, ONE, CC, LDA )
END IF
*
* Compute error in the difference
*
RESID = SLANGE( '1', MC, NC, CC, LDA, RWORK )
RESULT( ( ISIDE-1 )*2+ITRANS ) = RESID /
$ ( REAL( MAX( 1, M ) )*CNORM*EPS )
*
20 CONTINUE
30 CONTINUE
*
RETURN
*
* End of SQRT03
*
END
REAL FUNCTION SQRT11( M, K, A, LDA, TAU, WORK, LWORK )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER K, LDA, LWORK, M
* ..
* .. Array Arguments ..
REAL A( LDA, * ), TAU( * ), WORK( LWORK )
* ..
*
* Purpose
* =======
*
* SQRT11 computes the test ratio
*
* || Q'*Q - I || / (eps * m)
*
* where the orthogonal matrix Q is represented as a product of
* elementary transformations. Each transformation has the form
*
* H(k) = I - tau(k) v(k) v(k)'
*
* where tau(k) is stored in TAU(k) and v(k) is an m-vector of the form
* [ 0 ... 0 1 x(k) ]', where x(k) is a vector of length m-k stored
* in A(k+1:m,k).
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix A.
*
* K (input) INTEGER
* The number of columns of A whose subdiagonal entries
* contain information about orthogonal transformations.
*
* A (input) REAL array, dimension (LDA,K)
* The (possibly partial) output of a QR reduction routine.
*
* LDA (input) INTEGER
* The leading dimension of the array A.
*
* TAU (input) REAL array, dimension (K)
* The scaling factors tau for the elementary transformations as
* computed by the QR factorization routine.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of the array WORK. LWORK >= M*M + M.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
INTEGER INFO, J
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE
EXTERNAL SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SLASET, SORM2R, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. Local Arrays ..
REAL RDUMMY( 1 )
* ..
* .. Executable Statements ..
*
SQRT11 = ZERO
*
* Test for sufficient workspace
*
IF( LWORK.LT.M*M+M ) THEN
CALL XERBLA( 'SQRT11', 7 )
RETURN
END IF
*
* Quick return if possible
*
IF( M.LE.0 )
$ RETURN
*
CALL SLASET( 'Full', M, M, ZERO, ONE, WORK, M )
*
* Form Q
*
CALL SORM2R( 'Left', 'No transpose', M, M, K, A, LDA, TAU, WORK,
$ M, WORK( M*M+1 ), INFO )
*
* Form Q'*Q
*
CALL SORM2R( 'Left', 'Transpose', M, M, K, A, LDA, TAU, WORK, M,
$ WORK( M*M+1 ), INFO )
*
DO 10 J = 1, M
WORK( ( J-1 )*M+J ) = WORK( ( J-1 )*M+J ) - ONE
10 CONTINUE
*
SQRT11 = SLANGE( 'One-norm', M, M, WORK, M, RDUMMY ) /
$ ( REAL( M )*SLAMCH( 'Epsilon' ) )
*
RETURN
*
* End of SQRT11
*
END
REAL FUNCTION SQRT12( M, N, A, LDA, S, WORK, LWORK )
*
* -- LAPACK test routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* January 2007
*
* .. Scalar Arguments ..
INTEGER LDA, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), S( * ), WORK( LWORK )
* ..
*
* Purpose
* =======
*
* SQRT12 computes the singular values `svlues' of the upper trapezoid
* of A(1:M,1:N) and returns the ratio
*
* || s - svlues||/(||svlues||*eps*max(M,N))
*
* 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) REAL array, dimension (LDA,N)
* The M-by-N matrix A. Only the upper trapezoid is referenced.
*
* LDA (input) INTEGER
* The leading dimension of the array A.
*
* S (input) REAL array, dimension (min(M,N))
* The singular values of the matrix A.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of the array WORK. LWORK >= max(M*N + 4*min(M,N) +
* max(M,N), M*N+2*MIN( M, N )+4*N).
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, ISCL, J, MN
REAL ANRM, BIGNUM, NRMSVL, SMLNUM
* ..
* .. External Functions ..
REAL SASUM, SLAMCH, SLANGE, SNRM2
EXTERNAL SASUM, SLAMCH, SLANGE, SNRM2
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SBDSQR, SGEBD2, SLABAD, SLASCL, SLASET,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Local Arrays ..
REAL DUMMY( 1 )
* ..
* .. Executable Statements ..
*
SQRT12 = ZERO
*
* Test that enough workspace is supplied
*
IF( LWORK.LT.MAX( M*N+4*MIN( M, N )+MAX( M, N ),
$ M*N+2*MIN( M, N )+4*N) ) THEN
CALL XERBLA( 'SQRT12', 7 )
RETURN
END IF
*
* Quick return if possible
*
MN = MIN( M, N )
IF( MN.LE.ZERO )
$ RETURN
*
NRMSVL = SNRM2( MN, S, 1 )
*
* Copy upper triangle of A into work
*
CALL SLASET( 'Full', M, N, ZERO, ZERO, WORK, M )
DO 20 J = 1, N
DO 10 I = 1, MIN( J, M )
WORK( ( J-1 )*M+I ) = A( I, J )
10 CONTINUE
20 CONTINUE
*
* Get machine parameters
*
SMLNUM = SLAMCH( 'S' ) / SLAMCH( 'P' )
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
*
* Scale work if max entry outside range [SMLNUM,BIGNUM]
*
ANRM = SLANGE( 'M', M, N, WORK, M, DUMMY )
ISCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, WORK, M, INFO )
ISCL = 1
ELSE IF( ANRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, WORK, M, INFO )
ISCL = 1
END IF
*
IF( ANRM.NE.ZERO ) THEN
*
* Compute SVD of work
*
CALL SGEBD2( M, N, WORK, M, WORK( M*N+1 ), WORK( M*N+MN+1 ),
$ WORK( M*N+2*MN+1 ), WORK( M*N+3*MN+1 ),
$ WORK( M*N+4*MN+1 ), INFO )
CALL SBDSQR( 'Upper', MN, 0, 0, 0, WORK( M*N+1 ),
$ WORK( M*N+MN+1 ), DUMMY, MN, DUMMY, 1, DUMMY, MN,
$ WORK( M*N+2*MN+1 ), INFO )
*
IF( ISCL.EQ.1 ) THEN
IF( ANRM.GT.BIGNUM ) THEN
CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MN, 1,
$ WORK( M*N+1 ), MN, INFO )
END IF
IF( ANRM.LT.SMLNUM ) THEN
CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MN, 1,
$ WORK( M*N+1 ), MN, INFO )
END IF
END IF
*
ELSE
*
DO 30 I = 1, MN
WORK( M*N+I ) = ZERO
30 CONTINUE
END IF
*
* Compare s and singular values of work
*
CALL SAXPY( MN, -ONE, S, 1, WORK( M*N+1 ), 1 )
SQRT12 = SASUM( MN, WORK( M*N+1 ), 1 ) /
$ ( SLAMCH( 'Epsilon' )*REAL( MAX( M, N ) ) )
IF( NRMSVL.NE.ZERO )
$ SQRT12 = SQRT12 / NRMSVL
*
RETURN
*
* End of SQRT12
*
END
SUBROUTINE SQRT13( SCALE, M, N, A, LDA, NORMA, ISEED )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, M, N, SCALE
REAL NORMA
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
REAL A( LDA, * )
* ..
*
* Purpose
* =======
*
* SQRT13 generates a full-rank matrix that may be scaled to have large
* or small norm.
*
* Arguments
* =========
*
* SCALE (input) INTEGER
* SCALE = 1: normally scaled matrix
* SCALE = 2: matrix scaled up
* SCALE = 3: matrix scaled down
*
* M (input) INTEGER
* The number of rows of the matrix A.
*
* N (input) INTEGER
* The number of columns of A.
*
* A (output) REAL array, dimension (LDA,N)
* The M-by-N matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A.
*
* NORMA (output) REAL
* The one-norm of A.
*
* ISEED (input/output) integer array, dimension (4)
* Seed for random number generator
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E0 )
* ..
* .. Local Scalars ..
INTEGER INFO, J
REAL BIGNUM, SMLNUM
* ..
* .. External Functions ..
REAL SASUM, SLAMCH, SLANGE
EXTERNAL SASUM, SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SLABAD, SLARNV, SLASCL
* ..
* .. Intrinsic Functions ..
INTRINSIC SIGN
* ..
* .. Local Arrays ..
REAL DUMMY( 1 )
* ..
* .. Executable Statements ..
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
* benign matrix
*
DO 10 J = 1, N
CALL SLARNV( 2, ISEED, M, A( 1, J ) )
IF( J.LE.M ) THEN
A( J, J ) = A( J, J ) + SIGN( SASUM( M, A( 1, J ), 1 ),
$ A( J, J ) )
END IF
10 CONTINUE
*
* scaled versions
*
IF( SCALE.NE.1 ) THEN
NORMA = SLANGE( 'Max', M, N, A, LDA, DUMMY )
SMLNUM = SLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
SMLNUM = SMLNUM / SLAMCH( 'Epsilon' )
BIGNUM = ONE / SMLNUM
*
IF( SCALE.EQ.2 ) THEN
*
* matrix scaled up
*
CALL SLASCL( 'General', 0, 0, NORMA, BIGNUM, M, N, A, LDA,
$ INFO )
ELSE IF( SCALE.EQ.3 ) THEN
*
* matrix scaled down
*
CALL SLASCL( 'General', 0, 0, NORMA, SMLNUM, M, N, A, LDA,
$ INFO )
END IF
END IF
*
NORMA = SLANGE( 'One-norm', M, N, A, LDA, DUMMY )
RETURN
*
* End of SQRT13
*
END
REAL FUNCTION SQRT14( TRANS, M, N, NRHS, A, LDA, X,
$ LDX, WORK, LWORK )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER LDA, LDX, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
REAL A( LDA, * ), WORK( LWORK ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* SQRT14 checks whether X is in the row space of A or A'. It does so
* by scaling both X and A such that their norms are in the range
* [sqrt(eps), 1/sqrt(eps)], then computing a QR factorization of [A,X]
* (if TRANS = 'T') or an LQ factorization of [A',X]' (if TRANS = 'N'),
* and returning the norm of the trailing triangle, scaled by
* MAX(M,N,NRHS)*eps.
*
* Arguments
* =========
*
* TRANS (input) CHARACTER*1
* = 'N': No transpose, check for X in the row space of A
* = 'T': Transpose, check for X in the row space of A'.
*
* M (input) INTEGER
* The number of rows of the matrix A.
*
* N (input) INTEGER
* The number of columns of the matrix A.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of X.
*
* A (input) REAL array, dimension (LDA,N)
* The M-by-N matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A.
*
* X (input) REAL array, dimension (LDX,NRHS)
* If TRANS = 'N', the N-by-NRHS matrix X.
* IF TRANS = 'T', the M-by-NRHS matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X.
*
* WORK (workspace) REAL array dimension (LWORK)
*
* LWORK (input) INTEGER
* length of workspace array required
* If TRANS = 'N', LWORK >= (M+NRHS)*(N+2);
* if TRANS = 'T', LWORK >= (N+NRHS)*(M+2).
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL TPSD
INTEGER I, INFO, J, LDWORK
REAL ANRM, ERR, XNRM
* ..
* .. Local Arrays ..
REAL RWORK( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANGE
EXTERNAL LSAME, SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SGELQ2, SGEQR2, SLACPY, SLASCL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL
* ..
* .. Executable Statements ..
*
SQRT14 = ZERO
IF( LSAME( TRANS, 'N' ) ) THEN
LDWORK = M + NRHS
TPSD = .FALSE.
IF( LWORK.LT.( M+NRHS )*( N+2 ) ) THEN
CALL XERBLA( 'SQRT14', 10 )
RETURN
ELSE IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RETURN
END IF
ELSE IF( LSAME( TRANS, 'T' ) ) THEN
LDWORK = M
TPSD = .TRUE.
IF( LWORK.LT.( N+NRHS )*( M+2 ) ) THEN
CALL XERBLA( 'SQRT14', 10 )
RETURN
ELSE IF( M.LE.0 .OR. NRHS.LE.0 ) THEN
RETURN
END IF
ELSE
CALL XERBLA( 'SQRT14', 1 )
RETURN
END IF
*
* Copy and scale A
*
CALL SLACPY( 'All', M, N, A, LDA, WORK, LDWORK )
ANRM = SLANGE( 'M', M, N, WORK, LDWORK, RWORK )
IF( ANRM.NE.ZERO )
$ CALL SLASCL( 'G', 0, 0, ANRM, ONE, M, N, WORK, LDWORK, INFO )
*
* Copy X or X' into the right place and scale it
*
IF( TPSD ) THEN
*
* Copy X into columns n+1:n+nrhs of work
*
CALL SLACPY( 'All', M, NRHS, X, LDX, WORK( N*LDWORK+1 ),
$ LDWORK )
XNRM = SLANGE( 'M', M, NRHS, WORK( N*LDWORK+1 ), LDWORK,
$ RWORK )
IF( XNRM.NE.ZERO )
$ CALL SLASCL( 'G', 0, 0, XNRM, ONE, M, NRHS,
$ WORK( N*LDWORK+1 ), LDWORK, INFO )
ANRM = SLANGE( 'One-norm', M, N+NRHS, WORK, LDWORK, RWORK )
*
* Compute QR factorization of X
*
CALL SGEQR2( M, N+NRHS, WORK, LDWORK,
$ WORK( LDWORK*( N+NRHS )+1 ),
$ WORK( LDWORK*( N+NRHS )+MIN( M, N+NRHS )+1 ),
$ INFO )
*
* Compute largest entry in upper triangle of
* work(n+1:m,n+1:n+nrhs)
*
ERR = ZERO
DO 20 J = N + 1, N + NRHS
DO 10 I = N + 1, MIN( M, J )
ERR = MAX( ERR, ABS( WORK( I+( J-1 )*M ) ) )
10 CONTINUE
20 CONTINUE
*
ELSE
*
* Copy X' into rows m+1:m+nrhs of work
*
DO 40 I = 1, N
DO 30 J = 1, NRHS
WORK( M+J+( I-1 )*LDWORK ) = X( I, J )
30 CONTINUE
40 CONTINUE
*
XNRM = SLANGE( 'M', NRHS, N, WORK( M+1 ), LDWORK, RWORK )
IF( XNRM.NE.ZERO )
$ CALL SLASCL( 'G', 0, 0, XNRM, ONE, NRHS, N, WORK( M+1 ),
$ LDWORK, INFO )
*
* Compute LQ factorization of work
*
CALL SGELQ2( LDWORK, N, WORK, LDWORK, WORK( LDWORK*N+1 ),
$ WORK( LDWORK*( N+1 )+1 ), INFO )
*
* Compute largest entry in lower triangle in
* work(m+1:m+nrhs,m+1:n)
*
ERR = ZERO
DO 60 J = M + 1, N
DO 50 I = J, LDWORK
ERR = MAX( ERR, ABS( WORK( I+( J-1 )*LDWORK ) ) )
50 CONTINUE
60 CONTINUE
*
END IF
*
SQRT14 = ERR / ( REAL( MAX( M, N, NRHS ) )*SLAMCH( 'Epsilon' ) )
*
RETURN
*
* End of SQRT14
*
END
SUBROUTINE SQRT15( SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S,
$ RANK, NORMA, NORMB, ISEED, WORK, LWORK )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDB, LWORK, M, N, NRHS, RANK, RKSEL, SCALE
REAL NORMA, NORMB
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
REAL A( LDA, * ), B( LDB, * ), S( * ), WORK( LWORK )
* ..
*
* Purpose
* =======
*
* SQRT15 generates a matrix with full or deficient rank and of various
* norms.
*
* Arguments
* =========
*
* SCALE (input) INTEGER
* SCALE = 1: normally scaled matrix
* SCALE = 2: matrix scaled up
* SCALE = 3: matrix scaled down
*
* RKSEL (input) INTEGER
* RKSEL = 1: full rank matrix
* RKSEL = 2: rank-deficient matrix
*
* M (input) INTEGER
* The number of rows of the matrix A.
*
* N (input) INTEGER
* The number of columns of A.
*
* NRHS (input) INTEGER
* The number of columns of B.
*
* A (output) REAL array, dimension (LDA,N)
* The M-by-N matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A.
*
* B (output) REAL array, dimension (LDB, NRHS)
* A matrix that is in the range space of matrix A.
*
* LDB (input) INTEGER
* The leading dimension of the array B.
*
* S (output) REAL array, dimension MIN(M,N)
* Singular values of A.
*
* RANK (output) INTEGER
* number of nonzero singular values of A.
*
* NORMA (output) REAL
* one-norm of A.
*
* NORMB (output) REAL
* one-norm of B.
*
* ISEED (input/output) integer array, dimension (4)
* seed for random number generator.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* length of work space required.
* LWORK >= MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M)
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO, SVMIN
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ SVMIN = 0.1E0 )
* ..
* .. Local Scalars ..
INTEGER INFO, J, MN
REAL BIGNUM, EPS, SMLNUM, TEMP
* ..
* .. Local Arrays ..
REAL DUMMY( 1 )
* ..
* .. External Functions ..
REAL SASUM, SLAMCH, SLANGE, SLARND, SNRM2
EXTERNAL SASUM, SLAMCH, SLANGE, SLARND, SNRM2
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SLAORD, SLARF, SLARNV, SLAROR, SLASCL,
$ SLASET, SSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
MN = MIN( M, N )
IF( LWORK.LT.MAX( M+MN, MN*NRHS, 2*N+M ) ) THEN
CALL XERBLA( 'SQRT15', 16 )
RETURN
END IF
*
SMLNUM = SLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
EPS = SLAMCH( 'Epsilon' )
SMLNUM = ( SMLNUM / EPS ) / EPS
BIGNUM = ONE / SMLNUM
*
* Determine rank and (unscaled) singular values
*
IF( RKSEL.EQ.1 ) THEN
RANK = MN
ELSE IF( RKSEL.EQ.2 ) THEN
RANK = ( 3*MN ) / 4
DO 10 J = RANK + 1, MN
S( J ) = ZERO
10 CONTINUE
ELSE
CALL XERBLA( 'SQRT15', 2 )
END IF
*
IF( RANK.GT.0 ) THEN
*
* Nontrivial case
*
S( 1 ) = ONE
DO 30 J = 2, RANK
20 CONTINUE
TEMP = SLARND( 1, ISEED )
IF( TEMP.GT.SVMIN ) THEN
S( J ) = ABS( TEMP )
ELSE
GO TO 20
END IF
30 CONTINUE
CALL SLAORD( 'Decreasing', RANK, S, 1 )
*
* Generate 'rank' columns of a random orthogonal matrix in A
*
CALL SLARNV( 2, ISEED, M, WORK )
CALL SSCAL( M, ONE / SNRM2( M, WORK, 1 ), WORK, 1 )
CALL SLASET( 'Full', M, RANK, ZERO, ONE, A, LDA )
CALL SLARF( 'Left', M, RANK, WORK, 1, TWO, A, LDA,
$ WORK( M+1 ) )
*
* workspace used: m+mn
*
* Generate consistent rhs in the range space of A
*
CALL SLARNV( 2, ISEED, RANK*NRHS, WORK )
CALL SGEMM( 'No transpose', 'No transpose', M, NRHS, RANK, ONE,
$ A, LDA, WORK, RANK, ZERO, B, LDB )
*
* work space used: <= mn *nrhs
*
* generate (unscaled) matrix A
*
DO 40 J = 1, RANK
CALL SSCAL( M, S( J ), A( 1, J ), 1 )
40 CONTINUE
IF( RANK.LT.N )
$ CALL SLASET( 'Full', M, N-RANK, ZERO, ZERO, A( 1, RANK+1 ),
$ LDA )
CALL SLAROR( 'Right', 'No initialization', M, N, A, LDA, ISEED,
$ WORK, INFO )
*
ELSE
*
* work space used 2*n+m
*
* Generate null matrix and rhs
*
DO 50 J = 1, MN
S( J ) = ZERO
50 CONTINUE
CALL SLASET( 'Full', M, N, ZERO, ZERO, A, LDA )
CALL SLASET( 'Full', M, NRHS, ZERO, ZERO, B, LDB )
*
END IF
*
* Scale the matrix
*
IF( SCALE.NE.1 ) THEN
NORMA = SLANGE( 'Max', M, N, A, LDA, DUMMY )
IF( NORMA.NE.ZERO ) THEN
IF( SCALE.EQ.2 ) THEN
*
* matrix scaled up
*
CALL SLASCL( 'General', 0, 0, NORMA, BIGNUM, M, N, A,
$ LDA, INFO )
CALL SLASCL( 'General', 0, 0, NORMA, BIGNUM, MN, 1, S,
$ MN, INFO )
CALL SLASCL( 'General', 0, 0, NORMA, BIGNUM, M, NRHS, B,
$ LDB, INFO )
ELSE IF( SCALE.EQ.3 ) THEN
*
* matrix scaled down
*
CALL SLASCL( 'General', 0, 0, NORMA, SMLNUM, M, N, A,
$ LDA, INFO )
CALL SLASCL( 'General', 0, 0, NORMA, SMLNUM, MN, 1, S,
$ MN, INFO )
CALL SLASCL( 'General', 0, 0, NORMA, SMLNUM, M, NRHS, B,
$ LDB, INFO )
ELSE
CALL XERBLA( 'SQRT15', 1 )
RETURN
END IF
END IF
END IF
*
NORMA = SASUM( MN, S, 1 )
NORMB = SLANGE( 'One-norm', M, NRHS, B, LDB, DUMMY )
*
RETURN
*
* End of SQRT15
*
END
SUBROUTINE SQRT16( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB,
$ RWORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER LDA, LDB, LDX, M, N, NRHS
REAL RESID
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), RWORK( * ),
$ X( LDX, * )
* ..
*
* Purpose
* =======
*
* SQRT16 computes the residual for a solution of a system of linear
* equations A*x = b or A'*x = b:
* RESID = norm(B - A*X) / ( max(m,n) * norm(A) * norm(X) * EPS ),
* where EPS is the machine epsilon.
*
* Arguments
* =========
*
* TRANS (input) CHARACTER*1
* Specifies the form of the system of equations:
* = 'N': A *x = b
* = 'T': A'*x = b, where A' is the transpose of A
* = 'C': A'*x = b, where A' is the transpose of A
*
* 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.
*
* NRHS (input) INTEGER
* The number of columns of B, the matrix of right hand sides.
* NRHS >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The original M x N matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* X (input) REAL array, dimension (LDX,NRHS)
* The computed solution vectors for the system of linear
* equations.
*
* LDX (input) INTEGER
* The leading dimension of the array X. If TRANS = 'N',
* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M).
*
* B (input/output) REAL array, dimension (LDB,NRHS)
* On entry, the right hand side vectors for the system of
* linear equations.
* On exit, B is overwritten with the difference B - A*X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. IF TRANS = 'N',
* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N).
*
* RWORK (workspace) REAL array, dimension (M)
*
* RESID (output) REAL
* The maximum over the number of right hand sides of
* norm(B - A*X) / ( max(m,n) * norm(A) * norm(X) * EPS ).
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER J, N1, N2
REAL ANORM, BNORM, EPS, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SASUM, SLAMCH, SLANGE
EXTERNAL LSAME, SASUM, SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SGEMM
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Quick exit if M = 0 or N = 0 or NRHS = 0
*
IF( M.LE.0 .OR. N.LE.0 .OR. NRHS.EQ.0 ) THEN
RESID = ZERO
RETURN
END IF
*
IF( LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) ) THEN
ANORM = SLANGE( 'I', M, N, A, LDA, RWORK )
N1 = N
N2 = M
ELSE
ANORM = SLANGE( '1', M, N, A, LDA, RWORK )
N1 = M
N2 = N
END IF
*
EPS = SLAMCH( 'Epsilon' )
*
* Compute B - A*X (or B - A'*X ) and store in B.
*
CALL SGEMM( TRANS, 'No transpose', N1, NRHS, N2, -ONE, A, LDA, X,
$ LDX, ONE, B, LDB )
*
* Compute the maximum over the number of right hand sides of
* norm(B - A*X) / ( max(m,n) * norm(A) * norm(X) * EPS ) .
*
RESID = ZERO
DO 10 J = 1, NRHS
BNORM = SASUM( N1, B( 1, J ), 1 )
XNORM = SASUM( N2, X( 1, J ), 1 )
IF( ANORM.EQ.ZERO .AND. BNORM.EQ.ZERO ) THEN
RESID = ZERO
ELSE IF( ANORM.LE.ZERO .OR. XNORM.LE.ZERO ) THEN
RESID = ONE / EPS
ELSE
RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) /
$ ( MAX( M, N )*EPS ) )
END IF
10 CONTINUE
*
RETURN
*
* End of SQRT16
*
END
REAL FUNCTION SQRT17( TRANS, IRESID, M, N, NRHS, A,
$ LDA, X, LDX, B, LDB, C, WORK, LWORK )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER IRESID, LDA, LDB, LDX, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), C( LDB, * ),
$ WORK( LWORK ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* SQRT17 computes the ratio
*
* || R'*op(A) ||/(||A||*alpha*max(M,N,NRHS)*eps)
*
* where R = op(A)*X - B, op(A) is A or A', and
*
* alpha = ||B|| if IRESID = 1 (zero-residual problem)
* alpha = ||R|| if IRESID = 2 (otherwise).
*
* Arguments
* =========
*
* TRANS (input) CHARACTER*1
* Specifies whether or not the transpose of A is used.
* = 'N': No transpose, op(A) = A.
* = 'T': Transpose, op(A) = A'.
*
* IRESID (input) INTEGER
* IRESID = 1 indicates zero-residual problem.
* IRESID = 2 indicates non-zero residual.
*
* M (input) INTEGER
* The number of rows of the matrix A.
* If TRANS = 'N', the number of rows of the matrix B.
* If TRANS = 'T', the number of rows of the matrix X.
*
* N (input) INTEGER
* The number of columns of the matrix A.
* If TRANS = 'N', the number of rows of the matrix X.
* If TRANS = 'T', the number of rows of the matrix B.
*
* NRHS (input) INTEGER
* The number of columns of the matrices X and B.
*
* A (input) REAL array, dimension (LDA,N)
* The m-by-n matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= M.
*
* X (input) REAL array, dimension (LDX,NRHS)
* If TRANS = 'N', the n-by-nrhs matrix X.
* If TRANS = 'T', the m-by-nrhs matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X.
* If TRANS = 'N', LDX >= N.
* If TRANS = 'T', LDX >= M.
*
* B (input) REAL array, dimension (LDB,NRHS)
* If TRANS = 'N', the m-by-nrhs matrix B.
* If TRANS = 'T', the n-by-nrhs matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B.
* If TRANS = 'N', LDB >= M.
* If TRANS = 'T', LDB >= N.
*
* C (workspace) REAL array, dimension (LDB,NRHS)
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of the array WORK. LWORK >= NRHS*(M+N).
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
INTEGER INFO, ISCL, NCOLS, NROWS
REAL BIGNUM, ERR, NORMA, NORMB, NORMRS, NORMX,
$ SMLNUM
* ..
* .. Local Arrays ..
REAL RWORK( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANGE
EXTERNAL LSAME, SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SLACPY, SLASCL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, REAL
* ..
* .. Executable Statements ..
*
SQRT17 = ZERO
*
IF( LSAME( TRANS, 'N' ) ) THEN
NROWS = M
NCOLS = N
ELSE IF( LSAME( TRANS, 'T' ) ) THEN
NROWS = N
NCOLS = M
ELSE
CALL XERBLA( 'SQRT17', 1 )
RETURN
END IF
*
IF( LWORK.LT.NCOLS*NRHS ) THEN
CALL XERBLA( 'SQRT17', 13 )
RETURN
END IF
*
IF( M.LE.0 .OR. N.LE.0 .OR. NRHS.LE.0 ) THEN
RETURN
END IF
*
NORMA = SLANGE( 'One-norm', M, N, A, LDA, RWORK )
SMLNUM = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
BIGNUM = ONE / SMLNUM
ISCL = 0
*
* compute residual and scale it
*
CALL SLACPY( 'All', NROWS, NRHS, B, LDB, C, LDB )
CALL SGEMM( TRANS, 'No transpose', NROWS, NRHS, NCOLS, -ONE, A,
$ LDA, X, LDX, ONE, C, LDB )
NORMRS = SLANGE( 'Max', NROWS, NRHS, C, LDB, RWORK )
IF( NORMRS.GT.SMLNUM ) THEN
ISCL = 1
CALL SLASCL( 'General', 0, 0, NORMRS, ONE, NROWS, NRHS, C, LDB,
$ INFO )
END IF
*
* compute R'*A
*
CALL SGEMM( 'Transpose', TRANS, NRHS, NCOLS, NROWS, ONE, C, LDB,
$ A, LDA, ZERO, WORK, NRHS )
*
* compute and properly scale error
*
ERR = SLANGE( 'One-norm', NRHS, NCOLS, WORK, NRHS, RWORK )
IF( NORMA.NE.ZERO )
$ ERR = ERR / NORMA
*
IF( ISCL.EQ.1 )
$ ERR = ERR*NORMRS
*
IF( IRESID.EQ.1 ) THEN
NORMB = SLANGE( 'One-norm', NROWS, NRHS, B, LDB, RWORK )
IF( NORMB.NE.ZERO )
$ ERR = ERR / NORMB
ELSE
NORMX = SLANGE( 'One-norm', NCOLS, NRHS, X, LDX, RWORK )
IF( NORMX.NE.ZERO )
$ ERR = ERR / NORMX
END IF
*
SQRT17 = ERR / ( SLAMCH( 'Epsilon' )*REAL( MAX( M, N, NRHS ) ) )
RETURN
*
* End of SQRT17
*
END
SUBROUTINE SRQT01( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK,
$ RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), AF( LDA, * ), Q( LDA, * ),
$ R( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* SRQT01 tests SGERQF, which computes the RQ factorization of an m-by-n
* matrix A, and partially tests SORGRQ which forms the n-by-n
* orthogonal matrix Q.
*
* SRQT01 compares R with A*Q', and checks that Q is orthogonal.
*
* 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) REAL array, dimension (LDA,N)
* The m-by-n matrix A.
*
* AF (output) REAL array, dimension (LDA,N)
* Details of the RQ factorization of A, as returned by SGERQF.
* See SGERQF for further details.
*
* Q (output) REAL array, dimension (LDA,N)
* The n-by-n orthogonal matrix Q.
*
* R (workspace) REAL array, dimension (LDA,max(M,N))
*
* LDA (input) INTEGER
* The leading dimension of the arrays A, AF, Q and L.
* LDA >= max(M,N).
*
* TAU (output) REAL array, dimension (min(M,N))
* The scalar factors of the elementary reflectors, as returned
* by SGERQF.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
*
* RWORK (workspace) REAL array, dimension (max(M,N))
*
* RESULT (output) REAL array, dimension (2)
* The test ratios:
* RESULT(1) = norm( R - A*Q' ) / ( N * norm(A) * EPS )
* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
REAL ROGUE
PARAMETER ( ROGUE = -1.0E+10 )
* ..
* .. Local Scalars ..
INTEGER INFO, MINMN
REAL ANORM, EPS, RESID
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE, SLANSY
EXTERNAL SLAMCH, SLANGE, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SGERQF, SLACPY, SLASET, SORGRQ, SSYRK
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Scalars in Common ..
CHARACTER*6 SRNAMT
* ..
* .. Common blocks ..
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
MINMN = MIN( M, N )
EPS = SLAMCH( 'Epsilon' )
*
* Copy the matrix A to the array AF.
*
CALL SLACPY( 'Full', M, N, A, LDA, AF, LDA )
*
* Factorize the matrix A in the array AF.
*
SRNAMT = 'SGERQF'
CALL SGERQF( M, N, AF, LDA, TAU, WORK, LWORK, INFO )
*
* Copy details of Q
*
CALL SLASET( 'Full', N, N, ROGUE, ROGUE, Q, LDA )
IF( M.LE.N ) THEN
IF( M.GT.0 .AND. M.LT.N )
$ CALL SLACPY( 'Full', M, N-M, AF, LDA, Q( N-M+1, 1 ), LDA )
IF( M.GT.1 )
$ CALL SLACPY( 'Lower', M-1, M-1, AF( 2, N-M+1 ), LDA,
$ Q( N-M+2, N-M+1 ), LDA )
ELSE
IF( N.GT.1 )
$ CALL SLACPY( 'Lower', N-1, N-1, AF( M-N+2, 1 ), LDA,
$ Q( 2, 1 ), LDA )
END IF
*
* Generate the n-by-n matrix Q
*
SRNAMT = 'SORGRQ'
CALL SORGRQ( N, N, MINMN, Q, LDA, TAU, WORK, LWORK, INFO )
*
* Copy R
*
CALL SLASET( 'Full', M, N, ZERO, ZERO, R, LDA )
IF( M.LE.N ) THEN
IF( M.GT.0 )
$ CALL SLACPY( 'Upper', M, M, AF( 1, N-M+1 ), LDA,
$ R( 1, N-M+1 ), LDA )
ELSE
IF( M.GT.N .AND. N.GT.0 )
$ CALL SLACPY( 'Full', M-N, N, AF, LDA, R, LDA )
IF( N.GT.0 )
$ CALL SLACPY( 'Upper', N, N, AF( M-N+1, 1 ), LDA,
$ R( M-N+1, 1 ), LDA )
END IF
*
* Compute R - A*Q'
*
CALL SGEMM( 'No transpose', 'Transpose', M, N, N, -ONE, A, LDA, Q,
$ LDA, ONE, R, LDA )
*
* Compute norm( R - Q'*A ) / ( N * norm(A) * EPS ) .
*
ANORM = SLANGE( '1', M, N, A, LDA, RWORK )
RESID = SLANGE( '1', M, N, R, LDA, RWORK )
IF( ANORM.GT.ZERO ) THEN
RESULT( 1 ) = ( ( RESID / REAL( MAX( 1, N ) ) ) / ANORM ) / EPS
ELSE
RESULT( 1 ) = ZERO
END IF
*
* Compute I - Q*Q'
*
CALL SLASET( 'Full', N, N, ZERO, ONE, R, LDA )
CALL SSYRK( 'Upper', 'No transpose', N, N, -ONE, Q, LDA, ONE, R,
$ LDA )
*
* Compute norm( I - Q*Q' ) / ( N * EPS ) .
*
RESID = SLANSY( '1', 'Upper', N, R, LDA, RWORK )
*
RESULT( 2 ) = ( RESID / REAL( MAX( 1, N ) ) ) / EPS
*
RETURN
*
* End of SRQT01
*
END
SUBROUTINE SRQT02( M, N, K, A, AF, Q, R, LDA, TAU, WORK, LWORK,
$ RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), AF( LDA, * ), Q( LDA, * ),
$ R( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* SRQT02 tests SORGRQ, which generates an m-by-n matrix Q with
* orthonornmal rows that is defined as the product of k elementary
* reflectors.
*
* Given the RQ factorization of an m-by-n matrix A, SRQT02 generates
* the orthogonal matrix Q defined by the factorization of the last k
* rows of A; it compares R(m-k+1:m,n-m+1:n) with
* A(m-k+1:m,1:n)*Q(n-m+1:n,1:n)', and checks that the rows of Q are
* orthonormal.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix Q to be generated. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix Q to be generated.
* N >= M >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* matrix Q. M >= K >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The m-by-n matrix A which was factorized by SRQT01.
*
* AF (input) REAL array, dimension (LDA,N)
* Details of the RQ factorization of A, as returned by SGERQF.
* See SGERQF for further details.
*
* Q (workspace) REAL array, dimension (LDA,N)
*
* R (workspace) REAL array, dimension (LDA,M)
*
* LDA (input) INTEGER
* The leading dimension of the arrays A, AF, Q and L. LDA >= N.
*
* TAU (input) REAL array, dimension (M)
* The scalar factors of the elementary reflectors corresponding
* to the RQ factorization in AF.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
*
* RWORK (workspace) REAL array, dimension (M)
*
* RESULT (output) REAL array, dimension (2)
* The test ratios:
* RESULT(1) = norm( R - A*Q' ) / ( N * norm(A) * EPS )
* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
REAL ROGUE
PARAMETER ( ROGUE = -1.0E+10 )
* ..
* .. Local Scalars ..
INTEGER INFO
REAL ANORM, EPS, RESID
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE, SLANSY
EXTERNAL SLAMCH, SLANGE, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SLACPY, SLASET, SORGRQ, SSYRK
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, REAL
* ..
* .. Scalars in Common ..
CHARACTER*6 SRNAMT
* ..
* .. Common blocks ..
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
RESULT( 1 ) = ZERO
RESULT( 2 ) = ZERO
RETURN
END IF
*
EPS = SLAMCH( 'Epsilon' )
*
* Copy the last k rows of the factorization to the array Q
*
CALL SLASET( 'Full', M, N, ROGUE, ROGUE, Q, LDA )
IF( K.LT.N )
$ CALL SLACPY( 'Full', K, N-K, AF( M-K+1, 1 ), LDA,
$ Q( M-K+1, 1 ), LDA )
IF( K.GT.1 )
$ CALL SLACPY( 'Lower', K-1, K-1, AF( M-K+2, N-K+1 ), LDA,
$ Q( M-K+2, N-K+1 ), LDA )
*
* Generate the last n rows of the matrix Q
*
SRNAMT = 'SORGRQ'
CALL SORGRQ( M, N, K, Q, LDA, TAU( M-K+1 ), WORK, LWORK, INFO )
*
* Copy R(m-k+1:m,n-m+1:n)
*
CALL SLASET( 'Full', K, M, ZERO, ZERO, R( M-K+1, N-M+1 ), LDA )
CALL SLACPY( 'Upper', K, K, AF( M-K+1, N-K+1 ), LDA,
$ R( M-K+1, N-K+1 ), LDA )
*
* Compute R(m-k+1:m,n-m+1:n) - A(m-k+1:m,1:n) * Q(n-m+1:n,1:n)'
*
CALL SGEMM( 'No transpose', 'Transpose', K, M, N, -ONE,
$ A( M-K+1, 1 ), LDA, Q, LDA, ONE, R( M-K+1, N-M+1 ),
$ LDA )
*
* Compute norm( R - A*Q' ) / ( N * norm(A) * EPS ) .
*
ANORM = SLANGE( '1', K, N, A( M-K+1, 1 ), LDA, RWORK )
RESID = SLANGE( '1', K, M, R( M-K+1, N-M+1 ), LDA, RWORK )
IF( ANORM.GT.ZERO ) THEN
RESULT( 1 ) = ( ( RESID / REAL( MAX( 1, N ) ) ) / ANORM ) / EPS
ELSE
RESULT( 1 ) = ZERO
END IF
*
* Compute I - Q*Q'
*
CALL SLASET( 'Full', M, M, ZERO, ONE, R, LDA )
CALL SSYRK( 'Upper', 'No transpose', M, N, -ONE, Q, LDA, ONE, R,
$ LDA )
*
* Compute norm( I - Q*Q' ) / ( N * EPS ) .
*
RESID = SLANSY( '1', 'Upper', M, R, LDA, RWORK )
*
RESULT( 2 ) = ( RESID / REAL( MAX( 1, N ) ) ) / EPS
*
RETURN
*
* End of SRQT02
*
END
SUBROUTINE SRQT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK,
$ RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
REAL AF( LDA, * ), C( LDA, * ), CC( LDA, * ),
$ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* SRQT03 tests SORMRQ, which computes Q*C, Q'*C, C*Q or C*Q'.
*
* SRQT03 compares the results of a call to SORMRQ with the results of
* forming Q explicitly by a call to SORGRQ and then performing matrix
* multiplication by a call to SGEMM.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows or columns of the matrix C; C is n-by-m if
* Q is applied from the left, or m-by-n if Q is applied from
* the right. M >= 0.
*
* N (input) INTEGER
* The order of the orthogonal matrix Q. N >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* orthogonal matrix Q. N >= K >= 0.
*
* AF (input) REAL array, dimension (LDA,N)
* Details of the RQ factorization of an m-by-n matrix, as
* returned by SGERQF. See SGERQF for further details.
*
* C (workspace) REAL array, dimension (LDA,N)
*
* CC (workspace) REAL array, dimension (LDA,N)
*
* Q (workspace) REAL array, dimension (LDA,N)
*
* LDA (input) INTEGER
* The leading dimension of the arrays AF, C, CC, and Q.
*
* TAU (input) REAL array, dimension (min(M,N))
* The scalar factors of the elementary reflectors corresponding
* to the RQ factorization in AF.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of WORK. LWORK must be at least M, and should be
* M*NB, where NB is the blocksize for this environment.
*
* RWORK (workspace) REAL array, dimension (M)
*
* RESULT (output) REAL array, dimension (4)
* The test ratios compare two techniques for multiplying a
* random matrix C by an n-by-n orthogonal matrix Q.
* RESULT(1) = norm( Q*C - Q*C ) / ( N * norm(C) * EPS )
* RESULT(2) = norm( C*Q - C*Q ) / ( N * norm(C) * EPS )
* RESULT(3) = norm( Q'*C - Q'*C )/ ( N * norm(C) * EPS )
* RESULT(4) = norm( C*Q' - C*Q' )/ ( N * norm(C) * EPS )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
REAL ROGUE
PARAMETER ( ROGUE = -1.0E+10 )
* ..
* .. Local Scalars ..
CHARACTER SIDE, TRANS
INTEGER INFO, ISIDE, ITRANS, J, MC, MINMN, NC
REAL CNORM, EPS, RESID
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANGE
EXTERNAL LSAME, SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SLACPY, SLARNV, SLASET, SORGRQ, SORMRQ
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 )
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. Scalars in Common ..
CHARACTER*6 SRNAMT
* ..
* .. Common blocks ..
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEED / 1988, 1989, 1990, 1991 /
* ..
* .. Executable Statements ..
*
EPS = SLAMCH( 'Epsilon' )
MINMN = MIN( M, N )
*
* Quick return if possible
*
IF( MINMN.EQ.0 ) THEN
RESULT( 1 ) = ZERO
RESULT( 2 ) = ZERO
RESULT( 3 ) = ZERO
RESULT( 4 ) = ZERO
RETURN
END IF
*
* Copy the last k rows of the factorization to the array Q
*
CALL SLASET( 'Full', N, N, ROGUE, ROGUE, Q, LDA )
IF( K.GT.0 .AND. N.GT.K )
$ CALL SLACPY( 'Full', K, N-K, AF( M-K+1, 1 ), LDA,
$ Q( N-K+1, 1 ), LDA )
IF( K.GT.1 )
$ CALL SLACPY( 'Lower', K-1, K-1, AF( M-K+2, N-K+1 ), LDA,
$ Q( N-K+2, N-K+1 ), LDA )
*
* Generate the n-by-n matrix Q
*
SRNAMT = 'SORGRQ'
CALL SORGRQ( N, N, K, Q, LDA, TAU( MINMN-K+1 ), WORK, LWORK,
$ INFO )
*
DO 30 ISIDE = 1, 2
IF( ISIDE.EQ.1 ) THEN
SIDE = 'L'
MC = N
NC = M
ELSE
SIDE = 'R'
MC = M
NC = N
END IF
*
* Generate MC by NC matrix C
*
DO 10 J = 1, NC
CALL SLARNV( 2, ISEED, MC, C( 1, J ) )
10 CONTINUE
CNORM = SLANGE( '1', MC, NC, C, LDA, RWORK )
IF( CNORM.EQ.0.0 )
$ CNORM = ONE
*
DO 20 ITRANS = 1, 2
IF( ITRANS.EQ.1 ) THEN
TRANS = 'N'
ELSE
TRANS = 'T'
END IF
*
* Copy C
*
CALL SLACPY( 'Full', MC, NC, C, LDA, CC, LDA )
*
* Apply Q or Q' to C
*
SRNAMT = 'SORMRQ'
IF( K.GT.0 )
$ CALL SORMRQ( SIDE, TRANS, MC, NC, K, AF( M-K+1, 1 ), LDA,
$ TAU( MINMN-K+1 ), CC, LDA, WORK, LWORK,
$ INFO )
*
* Form explicit product and subtract
*
IF( LSAME( SIDE, 'L' ) ) THEN
CALL SGEMM( TRANS, 'No transpose', MC, NC, MC, -ONE, Q,
$ LDA, C, LDA, ONE, CC, LDA )
ELSE
CALL SGEMM( 'No transpose', TRANS, MC, NC, NC, -ONE, C,
$ LDA, Q, LDA, ONE, CC, LDA )
END IF
*
* Compute error in the difference
*
RESID = SLANGE( '1', MC, NC, CC, LDA, RWORK )
RESULT( ( ISIDE-1 )*2+ITRANS ) = RESID /
$ ( REAL( MAX( 1, N ) )*CNORM*EPS )
*
20 CONTINUE
30 CONTINUE
*
RETURN
*
* End of SRQT03
*
END
REAL FUNCTION SRZT01( M, N, A, AF, LDA, TAU, WORK,
$ LWORK )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), AF( LDA, * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* SRZT01 returns
* || A - R*Q || / ( M * eps * ||A|| )
* for an upper trapezoidal A that was factored with STZRZF.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrices A and AF.
*
* N (input) INTEGER
* The number of columns of the matrices A and AF.
*
* A (input) REAL array, dimension (LDA,N)
* The original upper trapezoidal M by N matrix A.
*
* AF (input) REAL array, dimension (LDA,N)
* The output of STZRZF for input matrix A.
* The lower triangle is not referenced.
*
* LDA (input) INTEGER
* The leading dimension of the arrays A and AF.
*
* TAU (input) REAL array, dimension (M)
* Details of the Householder transformations as returned by
* STZRZF.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of the array WORK. LWORK >= m*n + m*nb.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
REAL NORMA
* ..
* .. Local Arrays ..
REAL RWORK( 1 )
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE
EXTERNAL SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SLASET, SORMRZ, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, REAL
* ..
* .. Executable Statements ..
*
SRZT01 = ZERO
*
IF( LWORK.LT.M*N+M ) THEN
CALL XERBLA( 'SRZT01', 8 )
RETURN
END IF
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
NORMA = SLANGE( 'One-norm', M, N, A, LDA, RWORK )
*
* Copy upper triangle R
*
CALL SLASET( 'Full', M, N, ZERO, ZERO, WORK, M )
DO 20 J = 1, M
DO 10 I = 1, J
WORK( ( J-1 )*M+I ) = AF( I, J )
10 CONTINUE
20 CONTINUE
*
* R = R * P(1) * ... *P(m)
*
CALL SORMRZ( 'Right', 'No tranpose', M, N, M, N-M, AF, LDA, TAU,
$ WORK, M, WORK( M*N+1 ), LWORK-M*N, INFO )
*
* R = R - A
*
DO 30 I = 1, N
CALL SAXPY( M, -ONE, A( 1, I ), 1, WORK( ( I-1 )*M+1 ), 1 )
30 CONTINUE
*
SRZT01 = SLANGE( 'One-norm', M, N, WORK, M, RWORK )
*
SRZT01 = SRZT01 / ( SLAMCH( 'Epsilon' )*REAL( MAX( M, N ) ) )
IF( NORMA.NE.ZERO )
$ SRZT01 = SRZT01 / NORMA
*
RETURN
*
* End of SRZT01
*
END
REAL FUNCTION SRZT02( M, N, AF, LDA, TAU, WORK,
$ LWORK )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LWORK, M, N
* ..
* .. Array Arguments ..
REAL AF( LDA, * ), TAU( * ), WORK( LWORK )
* ..
*
* Purpose
* =======
*
* SRZT02 returns
* || I - Q'*Q || / ( M * eps)
* where the matrix Q is defined by the Householder transformations
* generated by STZRZF.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix AF.
*
* N (input) INTEGER
* The number of columns of the matrix AF.
*
* AF (input) REAL array, dimension (LDA,N)
* The output of STZRZF.
*
* LDA (input) INTEGER
* The leading dimension of the array AF.
*
* TAU (input) REAL array, dimension (M)
* Details of the Householder transformations as returned by
* STZRZF.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* length of WORK array. LWORK >= N*N+N*NB.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO
* ..
* .. Local Arrays ..
REAL RWORK( 1 )
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE
EXTERNAL SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SLASET, SORMRZ, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, REAL
* ..
* .. Executable Statements ..
*
SRZT02 = ZERO
*
IF( LWORK.LT.N*N+N ) THEN
CALL XERBLA( 'SRZT02', 7 )
RETURN
END IF
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
* Q := I
*
CALL SLASET( 'Full', N, N, ZERO, ONE, WORK, N )
*
* Q := P(1) * ... * P(m) * Q
*
CALL SORMRZ( 'Left', 'No transpose', N, N, M, N-M, AF, LDA, TAU,
$ WORK, N, WORK( N*N+1 ), LWORK-N*N, INFO )
*
* Q := P(m) * ... * P(1) * Q
*
CALL SORMRZ( 'Left', 'Transpose', N, N, M, N-M, AF, LDA, TAU,
$ WORK, N, WORK( N*N+1 ), LWORK-N*N, INFO )
*
* Q := Q - I
*
DO 10 I = 1, N
WORK( ( I-1 )*N+I ) = WORK( ( I-1 )*N+I ) - ONE
10 CONTINUE
*
SRZT02 = SLANGE( 'One-norm', N, N, WORK, N, RWORK ) /
$ ( SLAMCH( 'Epsilon' )*REAL( MAX( M, N ) ) )
RETURN
*
* End of SRZT02
*
END
SUBROUTINE SSPT01( UPLO, N, A, AFAC, IPIV, C, LDC, RWORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDC, N
REAL RESID
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
REAL A( * ), AFAC( * ), C( LDC, * ), RWORK( * )
* ..
*
* Purpose
* =======
*
* SSPT01 reconstructs a symmetric indefinite packed matrix A from its
* block L*D*L' or U*D*U' factorization and computes the residual
* norm( C - A ) / ( N * norm(A) * EPS ),
* where C is the reconstructed matrix and EPS is the machine epsilon.
*
* Arguments
* ==========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The number of rows and columns of the matrix A. N >= 0.
*
* A (input) REAL array, dimension (N*(N+1)/2)
* The original symmetric matrix A, stored as a packed
* triangular matrix.
*
* AFAC (input) REAL array, dimension (N*(N+1)/2)
* The factored form of the matrix A, stored as a packed
* triangular matrix. AFAC contains the block diagonal matrix D
* and the multipliers used to obtain the factor L or U from the
* block L*D*L' or U*D*U' factorization as computed by SSPTRF.
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices from SSPTRF.
*
* C (workspace) REAL array, dimension (LDC,N)
*
* LDC (integer) INTEGER
* The leading dimension of the array C. LDC >= max(1,N).
*
* RWORK (workspace) REAL array, dimension (N)
*
* RESID (output) REAL
* If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
* If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J, JC
REAL ANORM, EPS
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANSP, SLANSY
EXTERNAL LSAME, SLAMCH, SLANSP, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL SLAVSP, SLASET
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0.
*
IF( N.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Determine EPS and the norm of A.
*
EPS = SLAMCH( 'Epsilon' )
ANORM = SLANSP( '1', UPLO, N, A, RWORK )
*
* Initialize C to the identity matrix.
*
CALL SLASET( 'Full', N, N, ZERO, ONE, C, LDC )
*
* Call SLAVSP to form the product D * U' (or D * L' ).
*
CALL SLAVSP( UPLO, 'Transpose', 'Non-unit', N, N, AFAC, IPIV, C,
$ LDC, INFO )
*
* Call SLAVSP again to multiply by U ( or L ).
*
CALL SLAVSP( UPLO, 'No transpose', 'Unit', N, N, AFAC, IPIV, C,
$ LDC, INFO )
*
* Compute the difference C - A .
*
IF( LSAME( UPLO, 'U' ) ) THEN
JC = 0
DO 20 J = 1, N
DO 10 I = 1, J
C( I, J ) = C( I, J ) - A( JC+I )
10 CONTINUE
JC = JC + J
20 CONTINUE
ELSE
JC = 1
DO 40 J = 1, N
DO 30 I = J, N
C( I, J ) = C( I, J ) - A( JC+I-J )
30 CONTINUE
JC = JC + N - J + 1
40 CONTINUE
END IF
*
* Compute norm( C - A ) / ( N * norm(A) * EPS )
*
RESID = SLANSY( '1', UPLO, N, C, LDC, RWORK )
*
IF( ANORM.LE.ZERO ) THEN
IF( RESID.NE.ZERO )
$ RESID = ONE / EPS
ELSE
RESID = ( ( RESID / REAL( N ) ) / ANORM ) / EPS
END IF
*
RETURN
*
* End of SSPT01
*
END
SUBROUTINE SSYT01( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC,
$ RWORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDA, LDAFAC, LDC, N
REAL RESID
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
REAL A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ),
$ RWORK( * )
* ..
*
* Purpose
* =======
*
* SSYT01 reconstructs a symmetric indefinite matrix A from its
* block L*D*L' or U*D*U' factorization and computes the residual
* norm( C - A ) / ( N * norm(A) * EPS ),
* where C is the reconstructed matrix and EPS is the machine epsilon.
*
* Arguments
* ==========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The number of rows and columns of the matrix A. N >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The original symmetric matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N)
*
* AFAC (input) REAL array, dimension (LDAFAC,N)
* The factored form of the matrix A. AFAC contains the block
* diagonal matrix D and the multipliers used to obtain the
* factor L or U from the block L*D*L' or U*D*U' factorization
* as computed by SSYTRF.
*
* LDAFAC (input) INTEGER
* The leading dimension of the array AFAC. LDAFAC >= max(1,N).
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices from SSYTRF.
*
* C (workspace) REAL array, dimension (LDC,N)
*
* LDC (integer) INTEGER
* The leading dimension of the array C. LDC >= max(1,N).
*
* RWORK (workspace) REAL array, dimension (N)
*
* RESID (output) REAL
* If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
* If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
REAL ANORM, EPS
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANSY
EXTERNAL LSAME, SLAMCH, SLANSY
* ..
* .. External Subroutines ..
EXTERNAL SLAVSY, SLASET
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0.
*
IF( N.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Determine EPS and the norm of A.
*
EPS = SLAMCH( 'Epsilon' )
ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK )
*
* Initialize C to the identity matrix.
*
CALL SLASET( 'Full', N, N, ZERO, ONE, C, LDC )
*
* Call SLAVSY to form the product D * U' (or D * L' ).
*
CALL SLAVSY( UPLO, 'Transpose', 'Non-unit', N, N, AFAC, LDAFAC,
$ IPIV, C, LDC, INFO )
*
* Call SLAVSY again to multiply by U (or L ).
*
CALL SLAVSY( UPLO, 'No transpose', 'Unit', N, N, AFAC, LDAFAC,
$ IPIV, C, LDC, INFO )
*
* Compute the difference C - A .
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = 1, J
C( I, J ) = C( I, J ) - A( I, J )
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1, N
DO 30 I = J, N
C( I, J ) = C( I, J ) - A( I, J )
30 CONTINUE
40 CONTINUE
END IF
*
* Compute norm( C - A ) / ( N * norm(A) * EPS )
*
RESID = SLANSY( '1', UPLO, N, C, LDC, RWORK )
*
IF( ANORM.LE.ZERO ) THEN
IF( RESID.NE.ZERO )
$ RESID = ONE / EPS
ELSE
RESID = ( ( RESID / REAL( N ) ) / ANORM ) / EPS
END IF
*
RETURN
*
* End of SSYT01
*
END
SUBROUTINE STBT02( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, X,
$ LDX, B, LDB, WORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER KD, LDAB, LDB, LDX, N, NRHS
REAL RESID
* ..
* .. Array Arguments ..
REAL AB( LDAB, * ), B( LDB, * ), WORK( * ),
$ X( LDX, * )
* ..
*
* Purpose
* =======
*
* STBT02 computes the residual for the computed solution to a
* triangular system of linear equations A*x = b or A' *x = b when
* A is a triangular band matrix. Here A' is the transpose of A and
* x and b are N by NRHS matrices. The test ratio is the maximum over
* the number of right hand sides of
* norm(b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ),
* where op(A) denotes A or A' and EPS is the machine epsilon.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the operation applied to A.
* = 'N': A *x = b (No transpose)
* = 'T': A'*x = b (Transpose)
* = 'C': A'*x = b (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals or subdiagonals of the
* triangular band matrix A. KD >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrices X and B. NRHS >= 0.
*
* AB (input) REAL array, dimension (LDAB,N)
* The upper or lower triangular band matrix A, stored in the
* first kd+1 rows of the array. The j-th column of A is stored
* in the j-th column of the array AB as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* X (input) REAL array, dimension (LDX,NRHS)
* The computed solution vectors for the system of linear
* equations.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* B (input) REAL array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* WORK (workspace) REAL array, dimension (N)
*
* RESID (output) REAL
* The maximum over the number of right hand sides of
* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ).
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER J
REAL ANORM, BNORM, EPS, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SASUM, SLAMCH, SLANTB
EXTERNAL LSAME, SASUM, SLAMCH, SLANTB
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, STBMV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Compute the 1-norm of A or A'.
*
IF( LSAME( TRANS, 'N' ) ) THEN
ANORM = SLANTB( '1', UPLO, DIAG, N, KD, AB, LDAB, WORK )
ELSE
ANORM = SLANTB( 'I', UPLO, DIAG, N, KD, AB, LDAB, WORK )
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0.
*
EPS = SLAMCH( 'Epsilon' )
IF( ANORM.LE.ZERO ) THEN
RESID = ONE / EPS
RETURN
END IF
*
* Compute the maximum over the number of right hand sides of
* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ).
*
RESID = ZERO
DO 10 J = 1, NRHS
CALL SCOPY( N, X( 1, J ), 1, WORK, 1 )
CALL STBMV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, WORK, 1 )
CALL SAXPY( N, -ONE, B( 1, J ), 1, WORK, 1 )
BNORM = SASUM( N, WORK, 1 )
XNORM = SASUM( N, X( 1, J ), 1 )
IF( XNORM.LE.ZERO ) THEN
RESID = ONE / EPS
ELSE
RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) / EPS )
END IF
10 CONTINUE
*
RETURN
*
* End of STBT02
*
END
SUBROUTINE STBT03( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB,
$ SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK,
$ RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER KD, LDAB, LDB, LDX, N, NRHS
REAL RESID, SCALE, TSCAL
* ..
* .. Array Arguments ..
REAL AB( LDAB, * ), B( LDB, * ), CNORM( * ),
$ WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* STBT03 computes the residual for the solution to a scaled triangular
* system of equations A*x = s*b or A'*x = s*b when A is a
* triangular band matrix. Here A' is the transpose of A, s is a scalar,
* and x and b are N by NRHS matrices. The test ratio is the maximum
* over the number of right hand sides of
* norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ),
* where op(A) denotes A or A' and EPS is the machine epsilon.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the operation applied to A.
* = 'N': A *x = b (No transpose)
* = 'T': A'*x = b (Transpose)
* = 'C': A'*x = b (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals or subdiagonals of the
* triangular band matrix A. KD >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrices X and B. NRHS >= 0.
*
* AB (input) REAL array, dimension (LDAB,N)
* The upper or lower triangular band matrix A, stored in the
* first kd+1 rows of the array. The j-th column of A is stored
* in the j-th column of the array AB as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* SCALE (input) REAL
* The scaling factor s used in solving the triangular system.
*
* CNORM (input) REAL array, dimension (N)
* The 1-norms of the columns of A, not counting the diagonal.
*
* TSCAL (input) REAL
* The scaling factor used in computing the 1-norms in CNORM.
* CNORM actually contains the column norms of TSCAL*A.
*
* X (input) REAL array, dimension (LDX,NRHS)
* The computed solution vectors for the system of linear
* equations.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* B (input) REAL array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* WORK (workspace) REAL array, dimension (N)
*
* RESID (output) REAL
* The maximum over the number of right hand sides of
* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ).
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER IX, J
REAL BIGNUM, EPS, ERR, SMLNUM, TNORM, XNORM, XSCAL
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SLAMCH
EXTERNAL LSAME, ISAMAX, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, SLABAD, SSCAL, STBMV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, REAL
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
EPS = SLAMCH( 'Epsilon' )
SMLNUM = SLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
*
* Compute the norm of the triangular matrix A using the column
* norms already computed by SLATBS.
*
TNORM = ZERO
IF( LSAME( DIAG, 'N' ) ) THEN
IF( LSAME( UPLO, 'U' ) ) THEN
DO 10 J = 1, N
TNORM = MAX( TNORM, TSCAL*ABS( AB( KD+1, J ) )+
$ CNORM( J ) )
10 CONTINUE
ELSE
DO 20 J = 1, N
TNORM = MAX( TNORM, TSCAL*ABS( AB( 1, J ) )+CNORM( J ) )
20 CONTINUE
END IF
ELSE
DO 30 J = 1, N
TNORM = MAX( TNORM, TSCAL+CNORM( J ) )
30 CONTINUE
END IF
*
* Compute the maximum over the number of right hand sides of
* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ).
*
RESID = ZERO
DO 40 J = 1, NRHS
CALL SCOPY( N, X( 1, J ), 1, WORK, 1 )
IX = ISAMAX( N, WORK, 1 )
XNORM = MAX( ONE, ABS( X( IX, J ) ) )
XSCAL = ( ONE / XNORM ) / REAL( KD+1 )
CALL SSCAL( N, XSCAL, WORK, 1 )
CALL STBMV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, WORK, 1 )
CALL SAXPY( N, -SCALE*XSCAL, B( 1, J ), 1, WORK, 1 )
IX = ISAMAX( N, WORK, 1 )
ERR = TSCAL*ABS( WORK( IX ) )
IX = ISAMAX( N, X( 1, J ), 1 )
XNORM = ABS( X( IX, J ) )
IF( ERR*SMLNUM.LE.XNORM ) THEN
IF( XNORM.GT.ZERO )
$ ERR = ERR / XNORM
ELSE
IF( ERR.GT.ZERO )
$ ERR = ONE / EPS
END IF
IF( ERR*SMLNUM.LE.TNORM ) THEN
IF( TNORM.GT.ZERO )
$ ERR = ERR / TNORM
ELSE
IF( ERR.GT.ZERO )
$ ERR = ONE / EPS
END IF
RESID = MAX( RESID, ERR )
40 CONTINUE
*
RETURN
*
* End of STBT03
*
END
SUBROUTINE STBT05( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B,
$ LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER KD, LDAB, LDB, LDX, LDXACT, N, NRHS
* ..
* .. Array Arguments ..
REAL AB( LDAB, * ), B( LDB, * ), BERR( * ),
$ FERR( * ), RESLTS( * ), X( LDX, * ),
$ XACT( LDXACT, * )
* ..
*
* Purpose
* =======
*
* STBT05 tests the error bounds from iterative refinement for the
* computed solution to a system of equations A*X = B, where A is a
* triangular band matrix.
*
* RESLTS(1) = test of the error bound
* = norm(X - XACT) / ( norm(X) * FERR )
*
* A large value is returned if this ratio is not less than one.
*
* RESLTS(2) = residual from the iterative refinement routine
* = the maximum of BERR / ( NZ*EPS + (*) ), where
* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
* and NZ = max. number of nonzeros in any row of A, plus 1
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the form of the system of equations.
* = 'N': A * X = B (No transpose)
* = 'T': A'* X = B (Transpose)
* = 'C': A'* X = B (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* N (input) INTEGER
* The number of rows of the matrices X, B, and XACT, and the
* order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of super-diagonals of the matrix A if UPLO = 'U',
* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
*
* NRHS (input) INTEGER
* The number of columns of the matrices X, B, and XACT.
* NRHS >= 0.
*
* AB (input) REAL array, dimension (LDAB,N)
* The upper or lower triangular band matrix A, stored in the
* first kd+1 rows of the array. The j-th column of A is stored
* in the j-th column of the array AB as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
* If DIAG = 'U', the diagonal elements of A are not referenced
* and are assumed to be 1.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* B (input) REAL array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input) REAL array, dimension (LDX,NRHS)
* The computed solution vectors. Each vector is stored as a
* column of the matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* XACT (input) REAL array, dimension (LDX,NRHS)
* The exact solution vectors. Each vector is stored as a
* column of the matrix XACT.
*
* LDXACT (input) INTEGER
* The leading dimension of the array XACT. LDXACT >= max(1,N).
*
* FERR (input) REAL array, dimension (NRHS)
* The estimated forward error bounds for each solution vector
* X. If XTRUE is the true solution, FERR bounds the magnitude
* of the largest entry in (X - XTRUE) divided by the magnitude
* of the largest entry in X.
*
* BERR (input) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector (i.e., the smallest relative change in any entry of A
* or B that makes X an exact solution).
*
* RESLTS (output) REAL array, dimension (2)
* The maximum over the NRHS solution vectors of the ratios:
* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
* RESLTS(2) = BERR / ( NZ*EPS + (*) )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN, UNIT, UPPER
INTEGER I, IFU, IMAX, J, K, NZ
REAL AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SLAMCH
EXTERNAL LSAME, ISAMAX, SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0.
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESLTS( 1 ) = ZERO
RESLTS( 2 ) = ZERO
RETURN
END IF
*
EPS = SLAMCH( 'Epsilon' )
UNFL = SLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
UPPER = LSAME( UPLO, 'U' )
NOTRAN = LSAME( TRANS, 'N' )
UNIT = LSAME( DIAG, 'U' )
NZ = MIN( KD, N-1 ) + 1
*
* Test 1: Compute the maximum of
* norm(X - XACT) / ( norm(X) * FERR )
* over all the vectors X and XACT using the infinity-norm.
*
ERRBND = ZERO
DO 30 J = 1, NRHS
IMAX = ISAMAX( N, X( 1, J ), 1 )
XNORM = MAX( ABS( X( IMAX, J ) ), UNFL )
DIFF = ZERO
DO 10 I = 1, N
DIFF = MAX( DIFF, ABS( X( I, J )-XACT( I, J ) ) )
10 CONTINUE
*
IF( XNORM.GT.ONE ) THEN
GO TO 20
ELSE IF( DIFF.LE.OVFL*XNORM ) THEN
GO TO 20
ELSE
ERRBND = ONE / EPS
GO TO 30
END IF
*
20 CONTINUE
IF( DIFF / XNORM.LE.FERR( J ) ) THEN
ERRBND = MAX( ERRBND, ( DIFF / XNORM ) / FERR( J ) )
ELSE
ERRBND = ONE / EPS
END IF
30 CONTINUE
RESLTS( 1 ) = ERRBND
*
* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where
* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
*
IFU = 0
IF( UNIT )
$ IFU = 1
DO 90 K = 1, NRHS
DO 80 I = 1, N
TMP = ABS( B( I, K ) )
IF( UPPER ) THEN
IF( .NOT.NOTRAN ) THEN
DO 40 J = MAX( I-KD, 1 ), I - IFU
TMP = TMP + ABS( AB( KD+1-I+J, I ) )*
$ ABS( X( J, K ) )
40 CONTINUE
IF( UNIT )
$ TMP = TMP + ABS( X( I, K ) )
ELSE
IF( UNIT )
$ TMP = TMP + ABS( X( I, K ) )
DO 50 J = I + IFU, MIN( I+KD, N )
TMP = TMP + ABS( AB( KD+1+I-J, J ) )*
$ ABS( X( J, K ) )
50 CONTINUE
END IF
ELSE
IF( NOTRAN ) THEN
DO 60 J = MAX( I-KD, 1 ), I - IFU
TMP = TMP + ABS( AB( 1+I-J, J ) )*ABS( X( J, K ) )
60 CONTINUE
IF( UNIT )
$ TMP = TMP + ABS( X( I, K ) )
ELSE
IF( UNIT )
$ TMP = TMP + ABS( X( I, K ) )
DO 70 J = I + IFU, MIN( I+KD, N )
TMP = TMP + ABS( AB( 1+J-I, I ) )*ABS( X( J, K ) )
70 CONTINUE
END IF
END IF
IF( I.EQ.1 ) THEN
AXBI = TMP
ELSE
AXBI = MIN( AXBI, TMP )
END IF
80 CONTINUE
TMP = BERR( K ) / ( NZ*EPS+NZ*UNFL / MAX( AXBI, NZ*UNFL ) )
IF( K.EQ.1 ) THEN
RESLTS( 2 ) = TMP
ELSE
RESLTS( 2 ) = MAX( RESLTS( 2 ), TMP )
END IF
90 CONTINUE
*
RETURN
*
* End of STBT05
*
END
SUBROUTINE STBT06( RCOND, RCONDC, UPLO, DIAG, N, KD, AB, LDAB,
$ WORK, RAT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, UPLO
INTEGER KD, LDAB, N
REAL RAT, RCOND, RCONDC
* ..
* .. Array Arguments ..
REAL AB( LDAB, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* STBT06 computes a test ratio comparing RCOND (the reciprocal
* condition number of a triangular matrix A) and RCONDC, the estimate
* computed by STBCON. Information about the triangular matrix A is
* used if one estimate is zero and the other is non-zero to decide if
* underflow in the estimate is justified.
*
* Arguments
* =========
*
* RCOND (input) REAL
* The estimate of the reciprocal condition number obtained by
* forming the explicit inverse of the matrix A and computing
* RCOND = 1/( norm(A) * norm(inv(A)) ).
*
* RCONDC (input) REAL
* The estimate of the reciprocal condition number computed by
* STBCON.
*
* UPLO (input) CHARACTER
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* DIAG (input) CHARACTER
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals or subdiagonals of the
* triangular band matrix A. KD >= 0.
*
* AB (input) REAL array, dimension (LDAB,N)
* The upper or lower triangular band matrix A, stored in the
* first kd+1 rows of the array. The j-th column of A is stored
* in the j-th column of the array AB as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* WORK (workspace) REAL array, dimension (N)
*
* RAT (output) REAL
* The test ratio. If both RCOND and RCONDC are nonzero,
* RAT = MAX( RCOND, RCONDC )/MIN( RCOND, RCONDC ) - 1.
* If RAT = 0, the two estimates are exactly the same.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
REAL ANORM, BIGNUM, EPS, RMAX, RMIN, SMLNUM
* ..
* .. External Functions ..
REAL SLAMCH, SLANTB
EXTERNAL SLAMCH, SLANTB
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Subroutines ..
EXTERNAL SLABAD
* ..
* .. Executable Statements ..
*
EPS = SLAMCH( 'Epsilon' )
RMAX = MAX( RCOND, RCONDC )
RMIN = MIN( RCOND, RCONDC )
*
* Do the easy cases first.
*
IF( RMIN.LT.ZERO ) THEN
*
* Invalid value for RCOND or RCONDC, return 1/EPS.
*
RAT = ONE / EPS
*
ELSE IF( RMIN.GT.ZERO ) THEN
*
* Both estimates are positive, return RMAX/RMIN - 1.
*
RAT = RMAX / RMIN - ONE
*
ELSE IF( RMAX.EQ.ZERO ) THEN
*
* Both estimates zero.
*
RAT = ZERO
*
ELSE
*
* One estimate is zero, the other is non-zero. If the matrix is
* ill-conditioned, return the nonzero estimate multiplied by
* 1/EPS; if the matrix is badly scaled, return the nonzero
* estimate multiplied by BIGNUM/TMAX, where TMAX is the maximum
* element in absolute value in A.
*
SMLNUM = SLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
ANORM = SLANTB( 'M', UPLO, DIAG, N, KD, AB, LDAB, WORK )
*
RAT = RMAX*( MIN( BIGNUM / MAX( ONE, ANORM ), ONE / EPS ) )
END IF
*
RETURN
*
* End of STBT06
*
END
SUBROUTINE STPT01( UPLO, DIAG, N, AP, AINVP, RCOND, WORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, UPLO
INTEGER N
REAL RCOND, RESID
* ..
* .. Array Arguments ..
REAL AINVP( * ), AP( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* STPT01 computes the residual for a triangular matrix A times its
* inverse when A is stored in packed format:
* RESID = norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS ),
* where EPS is the machine epsilon.
*
* Arguments
* ==========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input) REAL array, dimension (N*(N+1)/2)
* The original upper or lower triangular matrix A, packed
* columnwise in a linear array. The j-th column of A is stored
* in the array AP as follows:
* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j;
* if UPLO = 'L',
* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n.
*
* AINVP (input/output) REAL array, dimension (N*(N+1)/2)
* On entry, the (triangular) inverse of the matrix A, packed
* columnwise in a linear array as in AP.
* On exit, the contents of AINVP are destroyed.
*
* RCOND (output) REAL
* The reciprocal condition number of A, computed as
* 1/(norm(A) * norm(AINV)).
*
* WORK (workspace) REAL array, dimension (N)
*
* RESID (output) REAL
* norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL UNITD
INTEGER J, JC
REAL AINVNM, ANORM, EPS
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANTP
EXTERNAL LSAME, SLAMCH, SLANTP
* ..
* .. External Subroutines ..
EXTERNAL STPMV
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0.
*
IF( N.LE.0 ) THEN
RCOND = ONE
RESID = ZERO
RETURN
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0.
*
EPS = SLAMCH( 'Epsilon' )
ANORM = SLANTP( '1', UPLO, DIAG, N, AP, WORK )
AINVNM = SLANTP( '1', UPLO, DIAG, N, AINVP, WORK )
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCOND = ZERO
RESID = ONE / EPS
RETURN
END IF
RCOND = ( ONE / ANORM ) / AINVNM
*
* Compute A * AINV, overwriting AINV.
*
UNITD = LSAME( DIAG, 'U' )
IF( LSAME( UPLO, 'U' ) ) THEN
JC = 1
DO 10 J = 1, N
IF( UNITD )
$ AINVP( JC+J-1 ) = ONE
*
* Form the j-th column of A*AINV
*
CALL STPMV( 'Upper', 'No transpose', DIAG, J, AP,
$ AINVP( JC ), 1 )
*
* Subtract 1 from the diagonal
*
AINVP( JC+J-1 ) = AINVP( JC+J-1 ) - ONE
JC = JC + J
10 CONTINUE
ELSE
JC = 1
DO 20 J = 1, N
IF( UNITD )
$ AINVP( JC ) = ONE
*
* Form the j-th column of A*AINV
*
CALL STPMV( 'Lower', 'No transpose', DIAG, N-J+1, AP( JC ),
$ AINVP( JC ), 1 )
*
* Subtract 1 from the diagonal
*
AINVP( JC ) = AINVP( JC ) - ONE
JC = JC + N - J + 1
20 CONTINUE
END IF
*
* Compute norm(A*AINV - I) / (N * norm(A) * norm(AINV) * EPS)
*
RESID = SLANTP( '1', UPLO, 'Non-unit', N, AINVP, WORK )
*
RESID = ( ( RESID*RCOND ) / REAL( N ) ) / EPS
*
RETURN
*
* End of STPT01
*
END
SUBROUTINE STPT02( UPLO, TRANS, DIAG, N, NRHS, AP, X, LDX, B, LDB,
$ WORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER LDB, LDX, N, NRHS
REAL RESID
* ..
* .. Array Arguments ..
REAL AP( * ), B( LDB, * ), WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* STPT02 computes the residual for the computed solution to a
* triangular system of linear equations A*x = b or A'*x = b when
* the triangular matrix A is stored in packed format. Here A' is the
* transpose of A and x and b are N by NRHS matrices. The test ratio is
* the maximum over the number of right hand sides of
* norm(b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ),
* where op(A) denotes A or A' and EPS is the machine epsilon.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the operation applied to A.
* = 'N': A *x = b (No transpose)
* = 'T': A'*x = b (Transpose)
* = 'C': A'*x = b (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* 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 matrices X and B. NRHS >= 0.
*
* AP (input) REAL array, dimension (N*(N+1)/2)
* The upper or lower triangular matrix A, packed columnwise in
* a linear array. The j-th column of A is stored in the array
* AP as follows:
* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j;
* if UPLO = 'L',
* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n.
*
* X (input) REAL array, dimension (LDX,NRHS)
* The computed solution vectors for the system of linear
* equations.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* B (input) REAL array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* WORK (workspace) REAL array, dimension (N)
*
* RESID (output) REAL
* The maximum over the number of right hand sides of
* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ).
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER J
REAL ANORM, BNORM, EPS, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SASUM, SLAMCH, SLANTP
EXTERNAL LSAME, SASUM, SLAMCH, SLANTP
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, STPMV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Compute the 1-norm of A or A'.
*
IF( LSAME( TRANS, 'N' ) ) THEN
ANORM = SLANTP( '1', UPLO, DIAG, N, AP, WORK )
ELSE
ANORM = SLANTP( 'I', UPLO, DIAG, N, AP, WORK )
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0.
*
EPS = SLAMCH( 'Epsilon' )
IF( ANORM.LE.ZERO ) THEN
RESID = ONE / EPS
RETURN
END IF
*
* Compute the maximum over the number of right hand sides of
* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ).
*
RESID = ZERO
DO 10 J = 1, NRHS
CALL SCOPY( N, X( 1, J ), 1, WORK, 1 )
CALL STPMV( UPLO, TRANS, DIAG, N, AP, WORK, 1 )
CALL SAXPY( N, -ONE, B( 1, J ), 1, WORK, 1 )
BNORM = SASUM( N, WORK, 1 )
XNORM = SASUM( N, X( 1, J ), 1 )
IF( XNORM.LE.ZERO ) THEN
RESID = ONE / EPS
ELSE
RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) / EPS )
END IF
10 CONTINUE
*
RETURN
*
* End of STPT02
*
END
SUBROUTINE STPT03( UPLO, TRANS, DIAG, N, NRHS, AP, SCALE, CNORM,
$ TSCAL, X, LDX, B, LDB, WORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER LDB, LDX, N, NRHS
REAL RESID, SCALE, TSCAL
* ..
* .. Array Arguments ..
REAL AP( * ), B( LDB, * ), CNORM( * ), WORK( * ),
$ X( LDX, * )
* ..
*
* Purpose
* =======
*
* STPT03 computes the residual for the solution to a scaled triangular
* system of equations A*x = s*b or A'*x = s*b when the triangular
* matrix A is stored in packed format. Here A' is the transpose of A,
* s is a scalar, and x and b are N by NRHS matrices. The test ratio is
* the maximum over the number of right hand sides of
* norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ),
* where op(A) denotes A or A' and EPS is the machine epsilon.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the operation applied to A.
* = 'N': A *x = s*b (No transpose)
* = 'T': A'*x = s*b (Transpose)
* = 'C': A'*x = s*b (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* 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 matrices X and B. NRHS >= 0.
*
* AP (input) REAL array, dimension (N*(N+1)/2)
* The upper or lower triangular matrix A, packed columnwise in
* a linear array. The j-th column of A is stored in the array
* AP as follows:
* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j;
* if UPLO = 'L',
* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n.
*
* SCALE (input) REAL
* The scaling factor s used in solving the triangular system.
*
* CNORM (input) REAL array, dimension (N)
* The 1-norms of the columns of A, not counting the diagonal.
*
* TSCAL (input) REAL
* The scaling factor used in computing the 1-norms in CNORM.
* CNORM actually contains the column norms of TSCAL*A.
*
* X (input) REAL array, dimension (LDX,NRHS)
* The computed solution vectors for the system of linear
* equations.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* B (input) REAL array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* WORK (workspace) REAL array, dimension (N)
*
* RESID (output) REAL
* The maximum over the number of right hand sides of
* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ).
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER IX, J, JJ
REAL BIGNUM, EPS, ERR, SMLNUM, TNORM, XNORM, XSCAL
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SLAMCH
EXTERNAL LSAME, ISAMAX, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, SLABAD, SSCAL, STPMV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, REAL
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0.
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
EPS = SLAMCH( 'Epsilon' )
SMLNUM = SLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
*
* Compute the norm of the triangular matrix A using the column
* norms already computed by SLATPS.
*
TNORM = ZERO
IF( LSAME( DIAG, 'N' ) ) THEN
IF( LSAME( UPLO, 'U' ) ) THEN
JJ = 1
DO 10 J = 1, N
TNORM = MAX( TNORM, TSCAL*ABS( AP( JJ ) )+CNORM( J ) )
JJ = JJ + J + 1
10 CONTINUE
ELSE
JJ = 1
DO 20 J = 1, N
TNORM = MAX( TNORM, TSCAL*ABS( AP( JJ ) )+CNORM( J ) )
JJ = JJ + N - J + 1
20 CONTINUE
END IF
ELSE
DO 30 J = 1, N
TNORM = MAX( TNORM, TSCAL+CNORM( J ) )
30 CONTINUE
END IF
*
* Compute the maximum over the number of right hand sides of
* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ).
*
RESID = ZERO
DO 40 J = 1, NRHS
CALL SCOPY( N, X( 1, J ), 1, WORK, 1 )
IX = ISAMAX( N, WORK, 1 )
XNORM = MAX( ONE, ABS( X( IX, J ) ) )
XSCAL = ( ONE / XNORM ) / REAL( N )
CALL SSCAL( N, XSCAL, WORK, 1 )
CALL STPMV( UPLO, TRANS, DIAG, N, AP, WORK, 1 )
CALL SAXPY( N, -SCALE*XSCAL, B( 1, J ), 1, WORK, 1 )
IX = ISAMAX( N, WORK, 1 )
ERR = TSCAL*ABS( WORK( IX ) )
IX = ISAMAX( N, X( 1, J ), 1 )
XNORM = ABS( X( IX, J ) )
IF( ERR*SMLNUM.LE.XNORM ) THEN
IF( XNORM.GT.ZERO )
$ ERR = ERR / XNORM
ELSE
IF( ERR.GT.ZERO )
$ ERR = ONE / EPS
END IF
IF( ERR*SMLNUM.LE.TNORM ) THEN
IF( TNORM.GT.ZERO )
$ ERR = ERR / TNORM
ELSE
IF( ERR.GT.ZERO )
$ ERR = ONE / EPS
END IF
RESID = MAX( RESID, ERR )
40 CONTINUE
*
RETURN
*
* End of STPT03
*
END
SUBROUTINE STPT05( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX,
$ XACT, LDXACT, FERR, BERR, RESLTS )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER LDB, LDX, LDXACT, N, NRHS
* ..
* .. Array Arguments ..
REAL AP( * ), B( LDB, * ), BERR( * ), FERR( * ),
$ RESLTS( * ), X( LDX, * ), XACT( LDXACT, * )
* ..
*
* Purpose
* =======
*
* STPT05 tests the error bounds from iterative refinement for the
* computed solution to a system of equations A*X = B, where A is a
* triangular matrix in packed storage format.
*
* RESLTS(1) = test of the error bound
* = norm(X - XACT) / ( norm(X) * FERR )
*
* A large value is returned if this ratio is not less than one.
*
* RESLTS(2) = residual from the iterative refinement routine
* = the maximum of BERR / ( (n+1)*EPS + (*) ), where
* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the form of the system of equations.
* = 'N': A * X = B (No transpose)
* = 'T': A'* X = B (Transpose)
* = 'C': A'* X = B (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* N (input) INTEGER
* The number of rows of the matrices X, B, and XACT, and the
* order of the matrix A. N >= 0.
*
* NRHS (input) INTEGER
* The number of columns of the matrices X, B, and XACT.
* NRHS >= 0.
*
* AP (input) REAL array, dimension (N*(N+1)/2)
* The upper or lower triangular matrix A, packed columnwise in
* a linear array. The j-th column of A is stored in the array
* AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
* If DIAG = 'U', the diagonal elements of A are not referenced
* and are assumed to be 1.
*
* B (input) REAL array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input) REAL array, dimension (LDX,NRHS)
* The computed solution vectors. Each vector is stored as a
* column of the matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* XACT (input) REAL array, dimension (LDX,NRHS)
* The exact solution vectors. Each vector is stored as a
* column of the matrix XACT.
*
* LDXACT (input) INTEGER
* The leading dimension of the array XACT. LDXACT >= max(1,N).
*
* FERR (input) REAL array, dimension (NRHS)
* The estimated forward error bounds for each solution vector
* X. If XTRUE is the true solution, FERR bounds the magnitude
* of the largest entry in (X - XTRUE) divided by the magnitude
* of the largest entry in X.
*
* BERR (input) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector (i.e., the smallest relative change in any entry of A
* or B that makes X an exact solution).
*
* RESLTS (output) REAL array, dimension (2)
* The maximum over the NRHS solution vectors of the ratios:
* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
* RESLTS(2) = BERR / ( (n+1)*EPS + (*) )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN, UNIT, UPPER
INTEGER I, IFU, IMAX, J, JC, K
REAL AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SLAMCH
EXTERNAL LSAME, ISAMAX, SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0.
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESLTS( 1 ) = ZERO
RESLTS( 2 ) = ZERO
RETURN
END IF
*
EPS = SLAMCH( 'Epsilon' )
UNFL = SLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
UPPER = LSAME( UPLO, 'U' )
NOTRAN = LSAME( TRANS, 'N' )
UNIT = LSAME( DIAG, 'U' )
*
* Test 1: Compute the maximum of
* norm(X - XACT) / ( norm(X) * FERR )
* over all the vectors X and XACT using the infinity-norm.
*
ERRBND = ZERO
DO 30 J = 1, NRHS
IMAX = ISAMAX( N, X( 1, J ), 1 )
XNORM = MAX( ABS( X( IMAX, J ) ), UNFL )
DIFF = ZERO
DO 10 I = 1, N
DIFF = MAX( DIFF, ABS( X( I, J )-XACT( I, J ) ) )
10 CONTINUE
*
IF( XNORM.GT.ONE ) THEN
GO TO 20
ELSE IF( DIFF.LE.OVFL*XNORM ) THEN
GO TO 20
ELSE
ERRBND = ONE / EPS
GO TO 30
END IF
*
20 CONTINUE
IF( DIFF / XNORM.LE.FERR( J ) ) THEN
ERRBND = MAX( ERRBND, ( DIFF / XNORM ) / FERR( J ) )
ELSE
ERRBND = ONE / EPS
END IF
30 CONTINUE
RESLTS( 1 ) = ERRBND
*
* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where
* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
*
IFU = 0
IF( UNIT )
$ IFU = 1
DO 90 K = 1, NRHS
DO 80 I = 1, N
TMP = ABS( B( I, K ) )
IF( UPPER ) THEN
JC = ( ( I-1 )*I ) / 2
IF( .NOT.NOTRAN ) THEN
DO 40 J = 1, I - IFU
TMP = TMP + ABS( AP( JC+J ) )*ABS( X( J, K ) )
40 CONTINUE
IF( UNIT )
$ TMP = TMP + ABS( X( I, K ) )
ELSE
JC = JC + I
IF( UNIT ) THEN
TMP = TMP + ABS( X( I, K ) )
JC = JC + I
END IF
DO 50 J = I + IFU, N
TMP = TMP + ABS( AP( JC ) )*ABS( X( J, K ) )
JC = JC + J
50 CONTINUE
END IF
ELSE
IF( NOTRAN ) THEN
JC = I
DO 60 J = 1, I - IFU
TMP = TMP + ABS( AP( JC ) )*ABS( X( J, K ) )
JC = JC + N - J
60 CONTINUE
IF( UNIT )
$ TMP = TMP + ABS( X( I, K ) )
ELSE
JC = ( I-1 )*( N-I ) + ( I*( I+1 ) ) / 2
IF( UNIT )
$ TMP = TMP + ABS( X( I, K ) )
DO 70 J = I + IFU, N
TMP = TMP + ABS( AP( JC+J-I ) )*ABS( X( J, K ) )
70 CONTINUE
END IF
END IF
IF( I.EQ.1 ) THEN
AXBI = TMP
ELSE
AXBI = MIN( AXBI, TMP )
END IF
80 CONTINUE
TMP = BERR( K ) / ( ( N+1 )*EPS+( N+1 )*UNFL /
$ MAX( AXBI, ( N+1 )*UNFL ) )
IF( K.EQ.1 ) THEN
RESLTS( 2 ) = TMP
ELSE
RESLTS( 2 ) = MAX( RESLTS( 2 ), TMP )
END IF
90 CONTINUE
*
RETURN
*
* End of STPT05
*
END
SUBROUTINE STPT06( RCOND, RCONDC, UPLO, DIAG, N, AP, WORK, RAT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, UPLO
INTEGER N
REAL RAT, RCOND, RCONDC
* ..
* .. Array Arguments ..
REAL AP( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* STPT06 computes a test ratio comparing RCOND (the reciprocal
* condition number of a triangular matrix A) and RCONDC, the estimate
* computed by STPCON. Information about the triangular matrix A is
* used if one estimate is zero and the other is non-zero to decide if
* underflow in the estimate is justified.
*
* Arguments
* =========
*
* RCOND (input) REAL
* The estimate of the reciprocal condition number obtained by
* forming the explicit inverse of the matrix A and computing
* RCOND = 1/( norm(A) * norm(inv(A)) ).
*
* RCONDC (input) REAL
* The estimate of the reciprocal condition number computed by
* STPCON.
*
* UPLO (input) CHARACTER
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* DIAG (input) CHARACTER
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input) REAL array, dimension (N*(N+1)/2)
* The upper or lower triangular matrix A, packed columnwise in
* a linear array. The j-th column of A is stored in the array
* AP as follows:
* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j;
* if UPLO = 'L',
* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n.
*
* WORK (workspace) REAL array, dimension (N)
*
* RAT (output) REAL
* The test ratio. If both RCOND and RCONDC are nonzero,
* RAT = MAX( RCOND, RCONDC )/MIN( RCOND, RCONDC ) - 1.
* If RAT = 0, the two estimates are exactly the same.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
REAL ANORM, BIGNUM, EPS, RMAX, RMIN, SMLNUM
* ..
* .. External Functions ..
REAL SLAMCH, SLANTP
EXTERNAL SLAMCH, SLANTP
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Subroutines ..
EXTERNAL SLABAD
* ..
* .. Executable Statements ..
*
EPS = SLAMCH( 'Epsilon' )
RMAX = MAX( RCOND, RCONDC )
RMIN = MIN( RCOND, RCONDC )
*
* Do the easy cases first.
*
IF( RMIN.LT.ZERO ) THEN
*
* Invalid value for RCOND or RCONDC, return 1/EPS.
*
RAT = ONE / EPS
*
ELSE IF( RMIN.GT.ZERO ) THEN
*
* Both estimates are positive, return RMAX/RMIN - 1.
*
RAT = RMAX / RMIN - ONE
*
ELSE IF( RMAX.EQ.ZERO ) THEN
*
* Both estimates zero.
*
RAT = ZERO
*
ELSE
*
* One estimate is zero, the other is non-zero. If the matrix is
* ill-conditioned, return the nonzero estimate multiplied by
* 1/EPS; if the matrix is badly scaled, return the nonzero
* estimate multiplied by BIGNUM/TMAX, where TMAX is the maximum
* element in absolute value in A.
*
SMLNUM = SLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
ANORM = SLANTP( 'M', UPLO, DIAG, N, AP, WORK )
*
RAT = RMAX*( MIN( BIGNUM / MAX( ONE, ANORM ), ONE / EPS ) )
END IF
*
RETURN
*
* End of STPT06
*
END
SUBROUTINE STRT01( UPLO, DIAG, N, A, LDA, AINV, LDAINV, RCOND,
$ WORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, UPLO
INTEGER LDA, LDAINV, N
REAL RCOND, RESID
* ..
* .. Array Arguments ..
REAL A( LDA, * ), AINV( LDAINV, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* STRT01 computes the residual for a triangular matrix A times its
* inverse:
* RESID = norm( A*AINV - I ) / ( N * norm(A) * norm(AINV) * EPS ),
* where EPS is the machine epsilon.
*
* Arguments
* ==========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The triangular matrix A. If UPLO = 'U', the leading n by n
* upper triangular part of the array A contains the upper
* triangular matrix, and the strictly lower triangular part of
* A is not referenced. If UPLO = 'L', the leading n by n lower
* triangular part of the array A contains the lower triangular
* matrix, and the strictly upper triangular part of A is not
* referenced. If DIAG = 'U', the diagonal elements of A are
* also not referenced and are assumed to be 1.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* AINV (input/output) REAL array, dimension (LDAINV,N)
* On entry, the (triangular) inverse of the matrix A, in the
* same storage format as A.
* On exit, the contents of AINV are destroyed.
*
* LDAINV (input) INTEGER
* The leading dimension of the array AINV. LDAINV >= max(1,N).
*
* RCOND (output) REAL
* The reciprocal condition number of A, computed as
* 1/(norm(A) * norm(AINV)).
*
* WORK (workspace) REAL array, dimension (N)
*
* RESID (output) REAL
* norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER J
REAL AINVNM, ANORM, EPS
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANTR
EXTERNAL LSAME, SLAMCH, SLANTR
* ..
* .. External Subroutines ..
EXTERNAL STRMV
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0
*
IF( N.LE.0 ) THEN
RCOND = ONE
RESID = ZERO
RETURN
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0.
*
EPS = SLAMCH( 'Epsilon' )
ANORM = SLANTR( '1', UPLO, DIAG, N, N, A, LDA, WORK )
AINVNM = SLANTR( '1', UPLO, DIAG, N, N, AINV, LDAINV, WORK )
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCOND = ZERO
RESID = ONE / EPS
RETURN
END IF
RCOND = ( ONE / ANORM ) / AINVNM
*
* Set the diagonal of AINV to 1 if AINV has unit diagonal.
*
IF( LSAME( DIAG, 'U' ) ) THEN
DO 10 J = 1, N
AINV( J, J ) = ONE
10 CONTINUE
END IF
*
* Compute A * AINV, overwriting AINV.
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
CALL STRMV( 'Upper', 'No transpose', DIAG, J, A, LDA,
$ AINV( 1, J ), 1 )
20 CONTINUE
ELSE
DO 30 J = 1, N
CALL STRMV( 'Lower', 'No transpose', DIAG, N-J+1, A( J, J ),
$ LDA, AINV( J, J ), 1 )
30 CONTINUE
END IF
*
* Subtract 1 from each diagonal element to form A*AINV - I.
*
DO 40 J = 1, N
AINV( J, J ) = AINV( J, J ) - ONE
40 CONTINUE
*
* Compute norm(A*AINV - I) / (N * norm(A) * norm(AINV) * EPS)
*
RESID = SLANTR( '1', UPLO, 'Non-unit', N, N, AINV, LDAINV, WORK )
*
RESID = ( ( RESID*RCOND ) / REAL( N ) ) / EPS
*
RETURN
*
* End of STRT01
*
END
SUBROUTINE STRT02( UPLO, TRANS, DIAG, N, NRHS, A, LDA, X, LDX, B,
$ LDB, WORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER LDA, LDB, LDX, N, NRHS
REAL RESID
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), WORK( * ),
$ X( LDX, * )
* ..
*
* Purpose
* =======
*
* STRT02 computes the residual for the computed solution to a
* triangular system of linear equations A*x = b or A'*x = b.
* Here A is a triangular matrix, A' is the transpose of A, and x and b
* are N by NRHS matrices. The test ratio is the maximum over the
* number of right hand sides of
* norm(b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ),
* where op(A) denotes A or A' and EPS is the machine epsilon.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the operation applied to A.
* = 'N': A *x = b (No transpose)
* = 'T': A'*x = b (Transpose)
* = 'C': A'*x = b (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* 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 matrices X and B. NRHS >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The triangular matrix A. If UPLO = 'U', the leading n by n
* upper triangular part of the array A contains the upper
* triangular matrix, and the strictly lower triangular part of
* A is not referenced. If UPLO = 'L', the leading n by n lower
* triangular part of the array A contains the lower triangular
* matrix, and the strictly upper triangular part of A is not
* referenced. If DIAG = 'U', the diagonal elements of A are
* also not referenced and are assumed to be 1.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* X (input) REAL array, dimension (LDX,NRHS)
* The computed solution vectors for the system of linear
* equations.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* B (input) REAL array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* WORK (workspace) REAL array, dimension (N)
*
* RESID (output) REAL
* The maximum over the number of right hand sides of
* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ).
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER J
REAL ANORM, BNORM, EPS, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SASUM, SLAMCH, SLANTR
EXTERNAL LSAME, SASUM, SLAMCH, SLANTR
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, STRMV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Compute the 1-norm of A or A'.
*
IF( LSAME( TRANS, 'N' ) ) THEN
ANORM = SLANTR( '1', UPLO, DIAG, N, N, A, LDA, WORK )
ELSE
ANORM = SLANTR( 'I', UPLO, DIAG, N, N, A, LDA, WORK )
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0.
*
EPS = SLAMCH( 'Epsilon' )
IF( ANORM.LE.ZERO ) THEN
RESID = ONE / EPS
RETURN
END IF
*
* Compute the maximum over the number of right hand sides of
* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS )
*
RESID = ZERO
DO 10 J = 1, NRHS
CALL SCOPY( N, X( 1, J ), 1, WORK, 1 )
CALL STRMV( UPLO, TRANS, DIAG, N, A, LDA, WORK, 1 )
CALL SAXPY( N, -ONE, B( 1, J ), 1, WORK, 1 )
BNORM = SASUM( N, WORK, 1 )
XNORM = SASUM( N, X( 1, J ), 1 )
IF( XNORM.LE.ZERO ) THEN
RESID = ONE / EPS
ELSE
RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) / EPS )
END IF
10 CONTINUE
*
RETURN
*
* End of STRT02
*
END
SUBROUTINE STRT03( UPLO, TRANS, DIAG, N, NRHS, A, LDA, SCALE,
$ CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER LDA, LDB, LDX, N, NRHS
REAL RESID, SCALE, TSCAL
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), CNORM( * ),
$ WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* STRT03 computes the residual for the solution to a scaled triangular
* system of equations A*x = s*b or A'*x = s*b.
* Here A is a triangular matrix, A' is the transpose of A, s is a
* scalar, and x and b are N by NRHS matrices. The test ratio is the
* maximum over the number of right hand sides of
* norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ),
* where op(A) denotes A or A' and EPS is the machine epsilon.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the operation applied to A.
* = 'N': A *x = s*b (No transpose)
* = 'T': A'*x = s*b (Transpose)
* = 'C': A'*x = s*b (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* 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 matrices X and B. NRHS >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The triangular matrix A. If UPLO = 'U', the leading n by n
* upper triangular part of the array A contains the upper
* triangular matrix, and the strictly lower triangular part of
* A is not referenced. If UPLO = 'L', the leading n by n lower
* triangular part of the array A contains the lower triangular
* matrix, and the strictly upper triangular part of A is not
* referenced. If DIAG = 'U', the diagonal elements of A are
* also not referenced and are assumed to be 1.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* SCALE (input) REAL
* The scaling factor s used in solving the triangular system.
*
* CNORM (input) REAL array, dimension (N)
* The 1-norms of the columns of A, not counting the diagonal.
*
* TSCAL (input) REAL
* The scaling factor used in computing the 1-norms in CNORM.
* CNORM actually contains the column norms of TSCAL*A.
*
* X (input) REAL array, dimension (LDX,NRHS)
* The computed solution vectors for the system of linear
* equations.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* B (input) REAL array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* WORK (workspace) REAL array, dimension (N)
*
* RESID (output) REAL
* The maximum over the number of right hand sides of
* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ).
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER IX, J
REAL BIGNUM, EPS, ERR, SMLNUM, TNORM, XNORM, XSCAL
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SLAMCH
EXTERNAL LSAME, ISAMAX, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SCOPY, SLABAD, SSCAL, STRMV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, REAL
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
EPS = SLAMCH( 'Epsilon' )
SMLNUM = SLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
*
* Compute the norm of the triangular matrix A using the column
* norms already computed by SLATRS.
*
TNORM = ZERO
IF( LSAME( DIAG, 'N' ) ) THEN
DO 10 J = 1, N
TNORM = MAX( TNORM, TSCAL*ABS( A( J, J ) )+CNORM( J ) )
10 CONTINUE
ELSE
DO 20 J = 1, N
TNORM = MAX( TNORM, TSCAL+CNORM( J ) )
20 CONTINUE
END IF
*
* Compute the maximum over the number of right hand sides of
* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ).
*
RESID = ZERO
DO 30 J = 1, NRHS
CALL SCOPY( N, X( 1, J ), 1, WORK, 1 )
IX = ISAMAX( N, WORK, 1 )
XNORM = MAX( ONE, ABS( X( IX, J ) ) )
XSCAL = ( ONE / XNORM ) / REAL( N )
CALL SSCAL( N, XSCAL, WORK, 1 )
CALL STRMV( UPLO, TRANS, DIAG, N, A, LDA, WORK, 1 )
CALL SAXPY( N, -SCALE*XSCAL, B( 1, J ), 1, WORK, 1 )
IX = ISAMAX( N, WORK, 1 )
ERR = TSCAL*ABS( WORK( IX ) )
IX = ISAMAX( N, X( 1, J ), 1 )
XNORM = ABS( X( IX, J ) )
IF( ERR*SMLNUM.LE.XNORM ) THEN
IF( XNORM.GT.ZERO )
$ ERR = ERR / XNORM
ELSE
IF( ERR.GT.ZERO )
$ ERR = ONE / EPS
END IF
IF( ERR*SMLNUM.LE.TNORM ) THEN
IF( TNORM.GT.ZERO )
$ ERR = ERR / TNORM
ELSE
IF( ERR.GT.ZERO )
$ ERR = ONE / EPS
END IF
RESID = MAX( RESID, ERR )
30 CONTINUE
*
RETURN
*
* End of STRT03
*
END
SUBROUTINE STRT05( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X,
$ LDX, XACT, LDXACT, FERR, BERR, RESLTS )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER LDA, LDB, LDX, LDXACT, N, NRHS
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ),
$ RESLTS( * ), X( LDX, * ), XACT( LDXACT, * )
* ..
*
* Purpose
* =======
*
* STRT05 tests the error bounds from iterative refinement for the
* computed solution to a system of equations A*X = B, where A is a
* triangular n by n matrix.
*
* RESLTS(1) = test of the error bound
* = norm(X - XACT) / ( norm(X) * FERR )
*
* A large value is returned if this ratio is not less than one.
*
* RESLTS(2) = residual from the iterative refinement routine
* = the maximum of BERR / ( (n+1)*EPS + (*) ), where
* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the form of the system of equations.
* = 'N': A * X = B (No transpose)
* = 'T': A'* X = B (Transpose)
* = 'C': A'* X = B (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* N (input) INTEGER
* The number of rows of the matrices X, B, and XACT, and the
* order of the matrix A. N >= 0.
*
* NRHS (input) INTEGER
* The number of columns of the matrices X, B, and XACT.
* NRHS >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The triangular matrix A. If UPLO = 'U', the leading n by n
* upper triangular part of the array A contains the upper
* triangular matrix, and the strictly lower triangular part of
* A is not referenced. If UPLO = 'L', the leading n by n lower
* triangular part of the array A contains the lower triangular
* matrix, and the strictly upper triangular part of A is not
* referenced. If DIAG = 'U', the diagonal elements of A are
* also not referenced and are assumed to be 1.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input) REAL array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input) REAL array, dimension (LDX,NRHS)
* The computed solution vectors. Each vector is stored as a
* column of the matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* XACT (input) REAL array, dimension (LDX,NRHS)
* The exact solution vectors. Each vector is stored as a
* column of the matrix XACT.
*
* LDXACT (input) INTEGER
* The leading dimension of the array XACT. LDXACT >= max(1,N).
*
* FERR (input) REAL array, dimension (NRHS)
* The estimated forward error bounds for each solution vector
* X. If XTRUE is the true solution, FERR bounds the magnitude
* of the largest entry in (X - XTRUE) divided by the magnitude
* of the largest entry in X.
*
* BERR (input) REAL array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector (i.e., the smallest relative change in any entry of A
* or B that makes X an exact solution).
*
* RESLTS (output) REAL array, dimension (2)
* The maximum over the NRHS solution vectors of the ratios:
* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
* RESLTS(2) = BERR / ( (n+1)*EPS + (*) )
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN, UNIT, UPPER
INTEGER I, IFU, IMAX, J, K
REAL AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ISAMAX
REAL SLAMCH
EXTERNAL LSAME, ISAMAX, SLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0.
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESLTS( 1 ) = ZERO
RESLTS( 2 ) = ZERO
RETURN
END IF
*
EPS = SLAMCH( 'Epsilon' )
UNFL = SLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
UPPER = LSAME( UPLO, 'U' )
NOTRAN = LSAME( TRANS, 'N' )
UNIT = LSAME( DIAG, 'U' )
*
* Test 1: Compute the maximum of
* norm(X - XACT) / ( norm(X) * FERR )
* over all the vectors X and XACT using the infinity-norm.
*
ERRBND = ZERO
DO 30 J = 1, NRHS
IMAX = ISAMAX( N, X( 1, J ), 1 )
XNORM = MAX( ABS( X( IMAX, J ) ), UNFL )
DIFF = ZERO
DO 10 I = 1, N
DIFF = MAX( DIFF, ABS( X( I, J )-XACT( I, J ) ) )
10 CONTINUE
*
IF( XNORM.GT.ONE ) THEN
GO TO 20
ELSE IF( DIFF.LE.OVFL*XNORM ) THEN
GO TO 20
ELSE
ERRBND = ONE / EPS
GO TO 30
END IF
*
20 CONTINUE
IF( DIFF / XNORM.LE.FERR( J ) ) THEN
ERRBND = MAX( ERRBND, ( DIFF / XNORM ) / FERR( J ) )
ELSE
ERRBND = ONE / EPS
END IF
30 CONTINUE
RESLTS( 1 ) = ERRBND
*
* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where
* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
*
IFU = 0
IF( UNIT )
$ IFU = 1
DO 90 K = 1, NRHS
DO 80 I = 1, N
TMP = ABS( B( I, K ) )
IF( UPPER ) THEN
IF( .NOT.NOTRAN ) THEN
DO 40 J = 1, I - IFU
TMP = TMP + ABS( A( J, I ) )*ABS( X( J, K ) )
40 CONTINUE
IF( UNIT )
$ TMP = TMP + ABS( X( I, K ) )
ELSE
IF( UNIT )
$ TMP = TMP + ABS( X( I, K ) )
DO 50 J = I + IFU, N
TMP = TMP + ABS( A( I, J ) )*ABS( X( J, K ) )
50 CONTINUE
END IF
ELSE
IF( NOTRAN ) THEN
DO 60 J = 1, I - IFU
TMP = TMP + ABS( A( I, J ) )*ABS( X( J, K ) )
60 CONTINUE
IF( UNIT )
$ TMP = TMP + ABS( X( I, K ) )
ELSE
IF( UNIT )
$ TMP = TMP + ABS( X( I, K ) )
DO 70 J = I + IFU, N
TMP = TMP + ABS( A( J, I ) )*ABS( X( J, K ) )
70 CONTINUE
END IF
END IF
IF( I.EQ.1 ) THEN
AXBI = TMP
ELSE
AXBI = MIN( AXBI, TMP )
END IF
80 CONTINUE
TMP = BERR( K ) / ( ( N+1 )*EPS+( N+1 )*UNFL /
$ MAX( AXBI, ( N+1 )*UNFL ) )
IF( K.EQ.1 ) THEN
RESLTS( 2 ) = TMP
ELSE
RESLTS( 2 ) = MAX( RESLTS( 2 ), TMP )
END IF
90 CONTINUE
*
RETURN
*
* End of STRT05
*
END
SUBROUTINE STRT06( RCOND, RCONDC, UPLO, DIAG, N, A, LDA, WORK,
$ RAT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, UPLO
INTEGER LDA, N
REAL RAT, RCOND, RCONDC
* ..
* .. Array Arguments ..
REAL A( LDA, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* STRT06 computes a test ratio comparing RCOND (the reciprocal
* condition number of a triangular matrix A) and RCONDC, the estimate
* computed by STRCON. Information about the triangular matrix A is
* used if one estimate is zero and the other is non-zero to decide if
* underflow in the estimate is justified.
*
* Arguments
* =========
*
* RCOND (input) REAL
* The estimate of the reciprocal condition number obtained by
* forming the explicit inverse of the matrix A and computing
* RCOND = 1/( norm(A) * norm(inv(A)) ).
*
* RCONDC (input) REAL
* The estimate of the reciprocal condition number computed by
* STRCON.
*
* UPLO (input) CHARACTER
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* DIAG (input) CHARACTER
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input) REAL array, dimension (LDA,N)
* The triangular matrix A. If UPLO = 'U', the leading n by n
* upper triangular part of the array A contains the upper
* triangular matrix, and the strictly lower triangular part of
* A is not referenced. If UPLO = 'L', the leading n by n lower
* triangular part of the array A contains the lower triangular
* matrix, and the strictly upper triangular part of A is not
* referenced. If DIAG = 'U', the diagonal elements of A are
* also not referenced and are assumed to be 1.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* WORK (workspace) REAL array, dimension (N)
*
* RAT (output) REAL
* The test ratio. If both RCOND and RCONDC are nonzero,
* RAT = MAX( RCOND, RCONDC )/MIN( RCOND, RCONDC ) - 1.
* If RAT = 0, the two estimates are exactly the same.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
REAL ANORM, BIGNUM, EPS, RMAX, RMIN, SMLNUM
* ..
* .. External Functions ..
REAL SLAMCH, SLANTR
EXTERNAL SLAMCH, SLANTR
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Subroutines ..
EXTERNAL SLABAD
* ..
* .. Executable Statements ..
*
EPS = SLAMCH( 'Epsilon' )
RMAX = MAX( RCOND, RCONDC )
RMIN = MIN( RCOND, RCONDC )
*
* Do the easy cases first.
*
IF( RMIN.LT.ZERO ) THEN
*
* Invalid value for RCOND or RCONDC, return 1/EPS.
*
RAT = ONE / EPS
*
ELSE IF( RMIN.GT.ZERO ) THEN
*
* Both estimates are positive, return RMAX/RMIN - 1.
*
RAT = RMAX / RMIN - ONE
*
ELSE IF( RMAX.EQ.ZERO ) THEN
*
* Both estimates zero.
*
RAT = ZERO
*
ELSE
*
* One estimate is zero, the other is non-zero. If the matrix is
* ill-conditioned, return the nonzero estimate multiplied by
* 1/EPS; if the matrix is badly scaled, return the nonzero
* estimate multiplied by BIGNUM/TMAX, where TMAX is the maximum
* element in absolute value in A.
*
SMLNUM = SLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
CALL SLABAD( SMLNUM, BIGNUM )
ANORM = SLANTR( 'M', UPLO, DIAG, N, N, A, LDA, WORK )
*
RAT = RMAX*( MIN( BIGNUM / MAX( ONE, ANORM ), ONE / EPS ) )
END IF
*
RETURN
*
* End of STRT06
*
END
REAL FUNCTION STZT01( M, N, A, AF, LDA, TAU, WORK,
$ LWORK )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), AF( LDA, * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* STZT01 returns
* || A - R*Q || / ( M * eps * ||A|| )
* for an upper trapezoidal A that was factored with STZRQF.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrices A and AF.
*
* N (input) INTEGER
* The number of columns of the matrices A and AF.
*
* A (input) REAL array, dimension (LDA,N)
* The original upper trapezoidal M by N matrix A.
*
* AF (input) REAL array, dimension (LDA,N)
* The output of STZRQF for input matrix A.
* The lower triangle is not referenced.
*
* LDA (input) INTEGER
* The leading dimension of the arrays A and AF.
*
* TAU (input) REAL array, dimension (M)
* Details of the Householder transformations as returned by
* STZRQF.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of the array WORK. LWORK >= m*n + m.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
INTEGER I, J
REAL NORMA
* ..
* .. Local Arrays ..
REAL RWORK( 1 )
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE
EXTERNAL SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SLATZM, SLASET, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, REAL
* ..
* .. Executable Statements ..
*
STZT01 = ZERO
*
IF( LWORK.LT.M*N+M ) THEN
CALL XERBLA( 'STZT01', 8 )
RETURN
END IF
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
NORMA = SLANGE( 'One-norm', M, N, A, LDA, RWORK )
*
* Copy upper triangle R
*
CALL SLASET( 'Full', M, N, ZERO, ZERO, WORK, M )
DO 20 J = 1, M
DO 10 I = 1, J
WORK( ( J-1 )*M+I ) = AF( I, J )
10 CONTINUE
20 CONTINUE
*
* R = R * P(1) * ... *P(m)
*
DO 30 I = 1, M
CALL SLATZM( 'Right', I, N-M+1, AF( I, M+1 ), LDA, TAU( I ),
$ WORK( ( I-1 )*M+1 ), WORK( M*M+1 ), M,
$ WORK( M*N+1 ) )
30 CONTINUE
*
* R = R - A
*
DO 40 I = 1, N
CALL SAXPY( M, -ONE, A( 1, I ), 1, WORK( ( I-1 )*M+1 ), 1 )
40 CONTINUE
*
STZT01 = SLANGE( 'One-norm', M, N, WORK, M, RWORK )
*
STZT01 = STZT01 / ( SLAMCH( 'Epsilon' )*REAL( MAX( M, N ) ) )
IF( NORMA.NE.ZERO )
$ STZT01 = STZT01 / NORMA
*
RETURN
*
* End of STZT01
*
END
REAL FUNCTION STZT02( M, N, AF, LDA, TAU, WORK,
$ LWORK )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LWORK, M, N
* ..
* .. Array Arguments ..
REAL AF( LDA, * ), TAU( * ), WORK( LWORK )
* ..
*
* Purpose
* =======
*
* STZT02 returns
* || I - Q'*Q || / ( M * eps)
* where the matrix Q is defined by the Householder transformations
* generated by STZRQF.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix AF.
*
* N (input) INTEGER
* The number of columns of the matrix AF.
*
* AF (input) REAL array, dimension (LDA,N)
* The output of STZRQF.
*
* LDA (input) INTEGER
* The leading dimension of the array AF.
*
* TAU (input) REAL array, dimension (M)
* Details of the Householder transformations as returned by
* STZRQF.
*
* WORK (workspace) REAL array, dimension (LWORK)
*
* LWORK (input) INTEGER
* length of WORK array. Must be >= N*N+N
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
INTEGER I
* ..
* .. Local Arrays ..
REAL RWORK( 1 )
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE
EXTERNAL SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SLATZM, SLASET, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, REAL
* ..
* .. Executable Statements ..
*
STZT02 = ZERO
*
IF( LWORK.LT.N*N+N ) THEN
CALL XERBLA( 'STZT02', 7 )
RETURN
END IF
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
* Q := I
*
CALL SLASET( 'Full', N, N, ZERO, ONE, WORK, N )
*
* Q := P(1) * ... * P(m) * Q
*
DO 10 I = M, 1, -1
CALL SLATZM( 'Left', N-M+1, N, AF( I, M+1 ), LDA, TAU( I ),
$ WORK( I ), WORK( M+1 ), N, WORK( N*N+1 ) )
10 CONTINUE
*
* Q := P(m) * ... * P(1) * Q
*
DO 20 I = 1, M
CALL SLATZM( 'Left', N-M+1, N, AF( I, M+1 ), LDA, TAU( I ),
$ WORK( I ), WORK( M+1 ), N, WORK( N*N+1 ) )
20 CONTINUE
*
* Q := Q - I
*
DO 30 I = 1, N
WORK( ( I-1 )*N+I ) = WORK( ( I-1 )*N+I ) - ONE
30 CONTINUE
*
STZT02 = SLANGE( 'One-norm', N, N, WORK, N, RWORK ) /
$ ( SLAMCH( 'Epsilon' )*REAL( MAX( M, N ) ) )
RETURN
*
* End of STZT02
*
END
SUBROUTINE XLAENV( ISPEC, NVALUE )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER ISPEC, NVALUE
* ..
*
* Purpose
* =======
*
* XLAENV sets certain machine- and problem-dependent quantities
* which will later be retrieved by ILAENV.
*
* Arguments
* =========
*
* ISPEC (input) INTEGER
* Specifies the parameter to be set in the COMMON array IPARMS.
* = 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
* = 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: another crossover point, for the multishift QR and QZ
* methods for nonsymmetric eigenvalue problems.
* = 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
*
* NVALUE (input) INTEGER
* The value of the parameter specified by ISPEC.
*
* =====================================================================
*
* .. Arrays in Common ..
INTEGER IPARMS( 100 )
* ..
* .. Common blocks ..
COMMON / CLAENV / IPARMS
* ..
* .. Save statement ..
SAVE / CLAENV /
* ..
* .. Executable Statements ..
*
IF( ISPEC.GE.1 .AND. ISPEC.LE.9 ) THEN
IPARMS( ISPEC ) = NVALUE
END IF
*
RETURN
*
* End of XLAENV
*
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/slin/Makefile_javasrc 0000644 0001750 0001750 00000003125 10616442122 025331 0 ustar osallou osallou .SUFFIXES: .f .java
ROOT=../../..
include $(ROOT)/make.def
BLAS=$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR)
LAPACK=$(ROOT)/$(LAPACK_DIR)/$(LAPACK_JAR)
SMATGEN=$(ROOT)/$(SMATGEN_DIR)/$(SMATGEN_JAR)
tester: $(BLAS) $(LAPACK) $(SMATGEN) $(OUTDIR)/Slintest.f2j util
/bin/rm -f `find $(OUTDIR) -name "*.class"`
mkdir -p $(JAVASRC_OUTDIR)
$(JAVAC) -classpath .:$(JAVASRC_OUTDIR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(SMATGEN):$(BLAS):$(LAPACK) -d $(JAVASRC_OUTDIR) $(OUTDIR)/$(SLINTEST_PDIR)/*.java
/bin/rm -f $(JAVASRC_OUTDIR)/$(SLINTEST_PDIR)/*.old
$(JAVAB) $(JAVASRC_OUTDIR)/$(SLINTEST_PDIR)/*.class
/bin/rm -f $(SLINTEST_JAR)
cd $(JAVASRC_OUTDIR); $(JAR) cvf ../$(SLINTEST_JAR) `find . -name "*.class"`
$(JAR) uvf $(SLINTEST_JAR) `find org -name "*.class"`
$(OUTDIR)/Slintest.f2j: slintest.f
$(MAKE) nojar
$(BLAS):
cd $(ROOT)/$(BLAS_DIR); $(MAKE) -f Makefile_javasrc
$(LAPACK):
cd $(ROOT)/$(LAPACK_DIR); $(MAKE) -f Makefile_javasrc
$(SMATGEN):
cd $(ROOT)/$(SMATGEN_DIR); $(MAKE) -f Makefile_javasrc
util:
cd $(ROOT)/$(UTIL_DIR); $(MAKE)
runtest: tester
$(JAVA) $(JFLAGS) -cp .:$(SLINTEST_JAR):$(SMATGEN):$(BLAS):$(LAPACK):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR) $(SLINTEST_PACKAGE).Schkaa < stest.in
verify: $(ROOT)/$(SLINTEST_IDX)
cd $(JAVASRC_OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:..:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(SMATGEN_DIR)/$(SMATGEN_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/../$(LAPACK_DIR)/$(LAPACK_JAR) $(VERIFY) $(SLINTEST_PDIR)/*.class
clean:
/bin/rm -rf *.java *.class *.f2j org $(JAVASRC_OUTDIR) $(OUTDIR) $(SLINTEST_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/slin/Makefile 0000644 0001750 0001750 00000003043 10616442122 023617 0 ustar osallou osallou .SUFFIXES: .f .java
ROOT=../../..
include $(ROOT)/make.def
BLAS=$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR)
LAPACK=$(ROOT)/$(LAPACK_DIR)/$(LAPACK_JAR)
SMATGEN=$(ROOT)/$(SMATGEN_DIR)/$(SMATGEN_JAR)
XERBLAFLAGS= -c .:$(ROOT)/$(BLAS_OBJ) -p $(ERR_PACKAGE)
F2JFLAGS=-c .:$(ROOT)/$(BLAS_OBJ):$(ROOT)/$(LAPACK_OBJ):$(ROOT)/$(SMATGEN_OBJ) -p $(SLINTEST_PACKAGE) -o $(OUTDIR) $(STATIC)
tester: $(BLAS) $(LAPACK) $(SMATGEN) $(ROOT)/$(SLINTEST_IDX) util
/bin/rm -f $(SLINTEST_JAR)
cd $(OUTDIR); $(JAR) cvf ../$(SLINTEST_JAR) `find . -name "*.class"`
$(JAR) uvf $(SLINTEST_JAR) `find org -name "*.class"`
nojar: $(BLAS) $(LAPACK) $(SMATGEN) $(ROOT)/$(SLINTEST_IDX) util
$(ROOT)/$(SLINTEST_IDX): slintest.f
$(F2J) $(XERBLAFLAGS) xerbla.f > /dev/null
$(F2J) $(F2JFLAGS) $< > /dev/null
$(BLAS):
cd $(ROOT)/$(BLAS_DIR); $(MAKE)
$(LAPACK):
cd $(ROOT)/$(LAPACK_DIR); $(MAKE)
$(SMATGEN):
cd $(ROOT)/$(SMATGEN_DIR); $(MAKE)
util:
cd $(ROOT)/$(UTIL_DIR); $(MAKE)
runtest: tester
$(JAVA) $(JFLAGS) -cp .:$(SLINTEST_JAR):$(SMATGEN):$(BLAS):$(LAPACK):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR) $(SLINTEST_PACKAGE).Schkaa < stest.in
srctest:
$(MAKE) -f Makefile_javasrc runtest
verify: $(ROOT)/$(SLINTEST_IDX)
cd $(OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:..:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(SMATGEN_DIR)/$(SMATGEN_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/../$(LAPACK_DIR)/$(LAPACK_JAR) $(VERIFY) $(SLINTEST_PDIR)/*.class
clean:
/bin/rm -rf *.java *.class *.f2j org $(JAVASRC_OUTDIR) $(OUTDIR) $(SLINTEST_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/slin/stest.in 0000644 0001750 0001750 00000003713 10616163241 023657 0 ustar osallou osallou Data file for testing REAL LAPACK linear eqn. routines
7 Number of values of M
0 1 2 3 5 10 50 Values of M (row dimension)
7 Number of values of N
0 1 2 3 5 10 50 Values of N (column dimension)
3 Number of values of NRHS
1 2 15 Values of NRHS (number of right hand sides)
5 Number of values of NB
1 3 3 3 20 Values of NB (the blocksize)
1 0 5 9 1 Values of NX (crossover point)
30.0 Threshold value of test ratio
T Put T to test the LAPACK routines
T Put T to test the driver routines
T Put T to test the error exits
SGE 11 List types on next line if 0 < NTYPES < 11
SGB 8 List types on next line if 0 < NTYPES < 8
SGT 12 List types on next line if 0 < NTYPES < 12
SPO 9 List types on next line if 0 < NTYPES < 9
SPP 9 List types on next line if 0 < NTYPES < 9
SPB 8 List types on next line if 0 < NTYPES < 8
SPT 12 List types on next line if 0 < NTYPES < 12
SSY 10 List types on next line if 0 < NTYPES < 10
SSP 10 List types on next line if 0 < NTYPES < 10
STR 18 List types on next line if 0 < NTYPES < 18
STP 18 List types on next line if 0 < NTYPES < 18
STB 17 List types on next line if 0 < NTYPES < 17
SQR 8 List types on next line if 0 < NTYPES < 8
SRQ 8 List types on next line if 0 < NTYPES < 8
SLQ 8 List types on next line if 0 < NTYPES < 8
SQL 8 List types on next line if 0 < NTYPES < 8
SQP 6 List types on next line if 0 < NTYPES < 6
STZ 3 List types on next line if 0 < NTYPES < 3
SLS 6 List types on next line if 0 < NTYPES < 6
SEQ
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/slin/xerbla.f 0000644 0001750 0001750 00000004623 10616163241 023612 0 ustar osallou osallou SUBROUTINE XERBLA( SRNAME, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*6 SRNAME
INTEGER INFO
* ..
*
* Purpose
* =======
*
* This is a special version of XERBLA to be used only as part of
* the test program for testing error exits from the LAPACK routines.
* Error messages are printed if INFO.NE.INFOT or if SRNAME.NE.SRMANT,
* where INFOT and SRNAMT are values stored in COMMON.
*
* Arguments
* =========
*
* SRNAME (input) CHARACTER*6
* The name of the subroutine calling XERBLA. This name should
* match the COMMON variable SRNAMT.
*
* INFO (input) INTEGER
* The error return code from the calling subroutine. INFO
* should equal the COMMON variable INFOT.
*
* Further Details
* ======= =======
*
* The following variables are passed via the common blocks INFOC and
* SRNAMC:
*
* INFOT INTEGER Expected integer return code
* NOUT INTEGER Unit number for printing error messages
* OK LOGICAL Set to .TRUE. if INFO = INFOT and
* SRNAME = SRNAMT, otherwise set to .FALSE.
* LERR LOGICAL Set to .TRUE., indicating that XERBLA was called
* SRNAMT CHARACTER*6 Expected name of calling subroutine
*
*
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
LERR = .TRUE.
IF( INFO.NE.INFOT ) THEN
IF( INFOT.NE.0 ) THEN
WRITE( NOUT, FMT = 9999 )SRNAMT, INFO, INFOT
ELSE
WRITE( NOUT, FMT = 9997 )SRNAME, INFO
END IF
OK = .FALSE.
END IF
IF( SRNAME.NE.SRNAMT ) THEN
WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT
OK = .FALSE.
END IF
RETURN
*
9999 FORMAT( ' *** XERBLA was called from ', A6, ' with INFO = ', I6,
$ ' instead of ', I2, ' ***' )
9998 FORMAT( ' *** XERBLA was called with SRNAME = ', A6,
$ ' instead of ', A6, ' ***' )
9997 FORMAT( ' *** On entry to ', A6, ' parameter number ', I6,
$ ' had an illegal value ***' )
*
* End of XERBLA
*
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/lin/ 0000755 0001750 0001750 00000000000 11734055025 022000 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/lin/lintest.f 0000644 0001750 0001750 00004463127 10616163237 023655 0 ustar osallou osallou SUBROUTINE ALADHD( IOUNIT, PATH )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER IOUNIT
* ..
*
* Purpose
* =======
*
* ALADHD prints header information for the driver routines test paths.
*
* Arguments
* =========
*
* IOUNIT (input) INTEGER
* The unit number to which the header information should be
* printed.
*
* PATH (input) CHARACTER*3
* The name of the path for which the header information is to
* be printed. Current paths are
* _GE: General matrices
* _GB: General band
* _GT: General Tridiagonal
* _PO: Symmetric or Hermitian positive definite
* _PP: Symmetric or Hermitian positive definite packed
* _PB: Symmetric or Hermitian positive definite band
* _PT: Symmetric or Hermitian positive definite tridiagonal
* _SY: Symmetric indefinite
* _SP: Symmetric indefinite packed
* _HE: (complex) Hermitian indefinite
* _HP: (complex) Hermitian indefinite packed
* The first character must be one of S, D, C, or Z (C or Z only
* if complex).
*
* .. Local Scalars ..
LOGICAL CORZ, SORD
CHARACTER C1, C3
CHARACTER*2 P2
CHARACTER*9 SYM
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Executable Statements ..
*
IF( IOUNIT.LE.0 )
$ RETURN
C1 = PATH( 1: 1 )
C3 = PATH( 3: 3 )
P2 = PATH( 2: 3 )
SORD = LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' )
CORZ = LSAME( C1, 'C' ) .OR. LSAME( C1, 'Z' )
IF( .NOT.( SORD .OR. CORZ ) )
$ RETURN
*
IF( LSAMEN( 2, P2, 'GE' ) ) THEN
*
* GE: General dense
*
WRITE( IOUNIT, FMT = 9999 )PATH
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9989 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9981 )1
WRITE( IOUNIT, FMT = 9980 )2
WRITE( IOUNIT, FMT = 9979 )3
WRITE( IOUNIT, FMT = 9978 )4
WRITE( IOUNIT, FMT = 9977 )5
WRITE( IOUNIT, FMT = 9976 )6
WRITE( IOUNIT, FMT = 9972 )7
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'GB' ) ) THEN
*
* GB: General band
*
WRITE( IOUNIT, FMT = 9998 )PATH
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9988 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9981 )1
WRITE( IOUNIT, FMT = 9980 )2
WRITE( IOUNIT, FMT = 9979 )3
WRITE( IOUNIT, FMT = 9978 )4
WRITE( IOUNIT, FMT = 9977 )5
WRITE( IOUNIT, FMT = 9976 )6
WRITE( IOUNIT, FMT = 9972 )7
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'GT' ) ) THEN
*
* GT: General tridiagonal
*
WRITE( IOUNIT, FMT = 9997 )PATH
WRITE( IOUNIT, FMT = 9987 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9981 )1
WRITE( IOUNIT, FMT = 9980 )2
WRITE( IOUNIT, FMT = 9979 )3
WRITE( IOUNIT, FMT = 9978 )4
WRITE( IOUNIT, FMT = 9977 )5
WRITE( IOUNIT, FMT = 9976 )6
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'PO' ) .OR. LSAMEN( 2, P2, 'PP' ) ) THEN
*
* PO: Positive definite full
* PP: Positive definite packed
*
IF( SORD ) THEN
SYM = 'Symmetric'
ELSE
SYM = 'Hermitian'
END IF
IF( LSAME( C3, 'O' ) ) THEN
WRITE( IOUNIT, FMT = 9996 )PATH, SYM
ELSE
WRITE( IOUNIT, FMT = 9995 )PATH, SYM
END IF
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9985 )PATH
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9975 )1
WRITE( IOUNIT, FMT = 9980 )2
WRITE( IOUNIT, FMT = 9979 )3
WRITE( IOUNIT, FMT = 9978 )4
WRITE( IOUNIT, FMT = 9977 )5
WRITE( IOUNIT, FMT = 9976 )6
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'PB' ) ) THEN
*
* PB: Positive definite band
*
IF( SORD ) THEN
WRITE( IOUNIT, FMT = 9994 )PATH, 'Symmetric'
ELSE
WRITE( IOUNIT, FMT = 9994 )PATH, 'Hermitian'
END IF
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9984 )PATH
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9975 )1
WRITE( IOUNIT, FMT = 9980 )2
WRITE( IOUNIT, FMT = 9979 )3
WRITE( IOUNIT, FMT = 9978 )4
WRITE( IOUNIT, FMT = 9977 )5
WRITE( IOUNIT, FMT = 9976 )6
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'PT' ) ) THEN
*
* PT: Positive definite tridiagonal
*
IF( SORD ) THEN
WRITE( IOUNIT, FMT = 9993 )PATH, 'Symmetric'
ELSE
WRITE( IOUNIT, FMT = 9993 )PATH, 'Hermitian'
END IF
WRITE( IOUNIT, FMT = 9986 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9973 )1
WRITE( IOUNIT, FMT = 9980 )2
WRITE( IOUNIT, FMT = 9979 )3
WRITE( IOUNIT, FMT = 9978 )4
WRITE( IOUNIT, FMT = 9977 )5
WRITE( IOUNIT, FMT = 9976 )6
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'SY' ) .OR. LSAMEN( 2, P2, 'SP' ) ) THEN
*
* SY: Symmetric indefinite full
* SP: Symmetric indefinite packed
*
IF( LSAME( C3, 'Y' ) ) THEN
WRITE( IOUNIT, FMT = 9992 )PATH, 'Symmetric'
ELSE
WRITE( IOUNIT, FMT = 9991 )PATH, 'Symmetric'
END IF
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
IF( SORD ) THEN
WRITE( IOUNIT, FMT = 9983 )
ELSE
WRITE( IOUNIT, FMT = 9982 )
END IF
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9974 )1
WRITE( IOUNIT, FMT = 9980 )2
WRITE( IOUNIT, FMT = 9979 )3
WRITE( IOUNIT, FMT = 9977 )4
WRITE( IOUNIT, FMT = 9978 )5
WRITE( IOUNIT, FMT = 9976 )6
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'HE' ) .OR. LSAMEN( 2, P2, 'HP' ) ) THEN
*
* HE: Hermitian indefinite full
* HP: Hermitian indefinite packed
*
IF( LSAME( C3, 'E' ) ) THEN
WRITE( IOUNIT, FMT = 9992 )PATH, 'Hermitian'
ELSE
WRITE( IOUNIT, FMT = 9991 )PATH, 'Hermitian'
END IF
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9983 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9974 )1
WRITE( IOUNIT, FMT = 9980 )2
WRITE( IOUNIT, FMT = 9979 )3
WRITE( IOUNIT, FMT = 9977 )4
WRITE( IOUNIT, FMT = 9978 )5
WRITE( IOUNIT, FMT = 9976 )6
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE
*
* Print error message if no header is available.
*
WRITE( IOUNIT, FMT = 9990 )PATH
END IF
*
* First line of header
*
9999 FORMAT( / 1X, A3, ' drivers: General dense matrices' )
9998 FORMAT( / 1X, A3, ' drivers: General band matrices' )
9997 FORMAT( / 1X, A3, ' drivers: General tridiagonal' )
9996 FORMAT( / 1X, A3, ' drivers: ', A9,
$ ' positive definite matrices' )
9995 FORMAT( / 1X, A3, ' drivers: ', A9,
$ ' positive definite packed matrices' )
9994 FORMAT( / 1X, A3, ' drivers: ', A9,
$ ' positive definite band matrices' )
9993 FORMAT( / 1X, A3, ' drivers: ', A9,
$ ' positive definite tridiagonal' )
9992 FORMAT( / 1X, A3, ' drivers: ', A9, ' indefinite matrices' )
9991 FORMAT( / 1X, A3, ' drivers: ', A9,
$ ' indefinite packed matrices' )
9990 FORMAT( / 1X, A3, ': No header available' )
*
* GE matrix types
*
9989 FORMAT( 4X, '1. Diagonal', 24X, '7. Last n/2 columns zero', / 4X,
$ '2. Upper triangular', 16X,
$ '8. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
$ '3. Lower triangular', 16X, '9. Random, CNDNUM = 0.1/EPS',
$ / 4X, '4. Random, CNDNUM = 2', 13X,
$ '10. Scaled near underflow', / 4X, '5. First column zero',
$ 14X, '11. Scaled near overflow', / 4X,
$ '6. Last column zero' )
*
* GB matrix types
*
9988 FORMAT( 4X, '1. Random, CNDNUM = 2', 14X,
$ '5. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
$ '2. First column zero', 15X, '6. Random, CNDNUM = 0.1/EPS',
$ / 4X, '3. Last column zero', 16X,
$ '7. Scaled near underflow', / 4X,
$ '4. Last n/2 columns zero', 11X, '8. Scaled near overflow' )
*
* GT matrix types
*
9987 FORMAT( ' Matrix types (1-6 have specified condition numbers):',
$ / 4X, '1. Diagonal', 24X, '7. Random, unspecified CNDNUM',
$ / 4X, '2. Random, CNDNUM = 2', 14X, '8. First column zero',
$ / 4X, '3. Random, CNDNUM = sqrt(0.1/EPS)', 2X,
$ '9. Last column zero', / 4X, '4. Random, CNDNUM = 0.1/EPS',
$ 7X, '10. Last n/2 columns zero', / 4X,
$ '5. Scaled near underflow', 10X,
$ '11. Scaled near underflow', / 4X,
$ '6. Scaled near overflow', 11X, '12. Scaled near overflow' )
*
* PT matrix types
*
9986 FORMAT( ' Matrix types (1-6 have specified condition numbers):',
$ / 4X, '1. Diagonal', 24X, '7. Random, unspecified CNDNUM',
$ / 4X, '2. Random, CNDNUM = 2', 14X,
$ '8. First row and column zero', / 4X,
$ '3. Random, CNDNUM = sqrt(0.1/EPS)', 2X,
$ '9. Last row and column zero', / 4X,
$ '4. Random, CNDNUM = 0.1/EPS', 7X,
$ '10. Middle row and column zero', / 4X,
$ '5. Scaled near underflow', 10X,
$ '11. Scaled near underflow', / 4X,
$ '6. Scaled near overflow', 11X, '12. Scaled near overflow' )
*
* PO, PP matrix types
*
9985 FORMAT( 4X, '1. Diagonal', 24X,
$ '6. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
$ '2. Random, CNDNUM = 2', 14X, '7. Random, CNDNUM = 0.1/EPS',
$ / 3X, '*3. First row and column zero', 7X,
$ '8. Scaled near underflow', / 3X,
$ '*4. Last row and column zero', 8X,
$ '9. Scaled near overflow', / 3X,
$ '*5. Middle row and column zero', / 3X,
$ '(* - tests error exits from ', A3,
$ 'TRF, no test ratios are computed)' )
*
* PB matrix types
*
9984 FORMAT( 4X, '1. Random, CNDNUM = 2', 14X,
$ '5. Random, CNDNUM = sqrt(0.1/EPS)', / 3X,
$ '*2. First row and column zero', 7X,
$ '6. Random, CNDNUM = 0.1/EPS', / 3X,
$ '*3. Last row and column zero', 8X,
$ '7. Scaled near underflow', / 3X,
$ '*4. Middle row and column zero', 6X,
$ '8. Scaled near overflow', / 3X,
$ '(* - tests error exits from ', A3,
$ 'TRF, no test ratios are computed)' )
*
* SSY, SSP, CHE, CHP matrix types
*
9983 FORMAT( 4X, '1. Diagonal', 24X,
$ '6. Last n/2 rows and columns zero', / 4X,
$ '2. Random, CNDNUM = 2', 14X,
$ '7. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
$ '3. First row and column zero', 7X,
$ '8. Random, CNDNUM = 0.1/EPS', / 4X,
$ '4. Last row and column zero', 8X,
$ '9. Scaled near underflow', / 4X,
$ '5. Middle row and column zero', 5X,
$ '10. Scaled near overflow' )
*
* CSY, CSP matrix types
*
9982 FORMAT( 4X, '1. Diagonal', 24X,
$ '7. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
$ '2. Random, CNDNUM = 2', 14X, '8. Random, CNDNUM = 0.1/EPS',
$ / 4X, '3. First row and column zero', 7X,
$ '9. Scaled near underflow', / 4X,
$ '4. Last row and column zero', 7X,
$ '10. Scaled near overflow', / 4X,
$ '5. Middle row and column zero', 5X,
$ '11. Block diagonal matrix', / 4X,
$ '6. Last n/2 rows and columns zero' )
*
* Test ratios
*
9981 FORMAT( 3X, I2, ': norm( L * U - A ) / ( N * norm(A) * EPS )' )
9980 FORMAT( 3X, I2, ': norm( B - A * X ) / ',
$ '( norm(A) * norm(X) * EPS )' )
9979 FORMAT( 3X, I2, ': norm( X - XACT ) / ',
$ '( norm(XACT) * CNDNUM * EPS )' )
9978 FORMAT( 3X, I2, ': norm( X - XACT ) / ',
$ '( norm(XACT) * (error bound) )' )
9977 FORMAT( 3X, I2, ': (backward error) / EPS' )
9976 FORMAT( 3X, I2, ': RCOND * CNDNUM - 1.0' )
9975 FORMAT( 3X, I2, ': norm( U'' * U - A ) / ( N * norm(A) * EPS )',
$ ', or', / 7X, 'norm( L * L'' - A ) / ( N * norm(A) * EPS )'
$ )
9974 FORMAT( 3X, I2, ': norm( U*D*U'' - A ) / ( N * norm(A) * EPS )',
$ ', or', / 7X, 'norm( L*D*L'' - A ) / ( N * norm(A) * EPS )'
$ )
9973 FORMAT( 3X, I2, ': norm( U''*D*U - A ) / ( N * norm(A) * EPS )',
$ ', or', / 7X, 'norm( L*D*L'' - A ) / ( N * norm(A) * EPS )'
$ )
9972 FORMAT( 3X, I2, ': abs( WORK(1) - RPVGRW ) /',
$ ' ( max( WORK(1), RPVGRW ) * EPS )' )
*
RETURN
*
* End of ALADHD
*
END
SUBROUTINE ALAERH( PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU,
$ N5, IMAT, NFAIL, NERRS, NOUT )
*
* -- LAPACK auxiliary test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
CHARACTER*6 SUBNAM
CHARACTER*( * ) OPTS
INTEGER IMAT, INFO, INFOE, KL, KU, M, N, N5, NERRS,
$ NFAIL, NOUT
* ..
*
* Purpose
* =======
*
* ALAERH is an error handler for the LAPACK routines. It prints the
* header if this is the first error message and prints the error code
* and form of recovery, if any. The character evaluations in this
* routine may make it slow, but it should not be called once the LAPACK
* routines are fully debugged.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name of subroutine SUBNAM.
*
* SUBNAM (input) CHARACTER*6
* The name of the subroutine that returned an error code.
*
* INFO (input) INTEGER
* The error code returned from routine SUBNAM.
*
* INFOE (input) INTEGER
* The expected error code from routine SUBNAM, if SUBNAM were
* error-free. If INFOE = 0, an error message is printed, but
* if INFOE.NE.0, we assume only the return code INFO is wrong.
*
* OPTS (input) CHARACTER*(*)
* The character options to the subroutine SUBNAM, 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'.
*
* M (input) INTEGER
* The matrix row dimension.
*
* N (input) INTEGER
* The matrix column dimension. Accessed only if PATH = xGE or
* xGB.
*
* KL (input) INTEGER
* The number of sub-diagonals of the matrix. Accessed only if
* PATH = xGB, xPB, or xTB. Also used for NRHS for PATH = xLS.
*
* KU (input) INTEGER
* The number of super-diagonals of the matrix. Accessed only
* if PATH = xGB.
*
* N5 (input) INTEGER
* A fifth integer parameter, may be the blocksize NB or the
* number of right hand sides NRHS.
*
* IMAT (input) INTEGER
* The matrix type.
*
* NFAIL (input) INTEGER
* The number of prior tests that did not pass the threshold;
* used to determine if the header should be printed.
*
* NERRS (input/output) INTEGER
* On entry, the number of errors already detected; used to
* determine if the header should be printed.
* On exit, NERRS is increased by 1.
*
* NOUT (input) INTEGER
* The unit number on which results are to be printed.
*
* =====================================================================
*
* .. Local Scalars ..
CHARACTER UPLO
CHARACTER*2 P2
CHARACTER*3 C3
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL ALADHD, ALAHD
* ..
* .. Executable Statements ..
*
IF( INFO.EQ.0 )
$ RETURN
P2 = PATH( 2: 3 )
C3 = SUBNAM( 4: 6 )
*
* Print the header if this is the first error message.
*
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) THEN
IF( LSAMEN( 3, C3, 'SV ' ) .OR. LSAMEN( 3, C3, 'SVX' ) ) THEN
CALL ALADHD( NOUT, PATH )
ELSE
CALL ALAHD( NOUT, PATH )
END IF
END IF
NERRS = NERRS + 1
*
* Print the message detailing the error and form of recovery,
* if any.
*
IF( LSAMEN( 2, P2, 'GE' ) ) THEN
*
* xGE: General matrices
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9988 )SUBNAM, INFO, INFOE, M, N, N5,
$ IMAT
ELSE
WRITE( NOUT, FMT = 9975 )SUBNAM, INFO, M, N, N5, IMAT
END IF
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9949 )
*
ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9984 )SUBNAM, INFO, INFOE, N, N5,
$ IMAT
ELSE
WRITE( NOUT, FMT = 9970 )SUBNAM, INFO, N, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9992 )SUBNAM, INFO, INFOE,
$ OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT
ELSE
WRITE( NOUT, FMT = 9997 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), N, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
*
WRITE( NOUT, FMT = 9971 )SUBNAM, INFO, N, N5, IMAT
*
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN
*
WRITE( NOUT, FMT = 9978 )SUBNAM, INFO, M, N, IMAT
*
ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN
*
WRITE( NOUT, FMT = 9969 )SUBNAM, INFO, OPTS( 1: 1 ), M,
$ IMAT
*
ELSE IF( LSAMEN( 3, C3, 'LS ' ) ) THEN
*
WRITE( NOUT, FMT = 9965 )SUBNAM, INFO, OPTS( 1: 1 ), M, N,
$ KL, N5, IMAT
*
ELSE IF( LSAMEN( 3, C3, 'LSX' ) .OR. LSAMEN( 3, C3, 'LSS' ) )
$ THEN
*
WRITE( NOUT, FMT = 9974 )SUBNAM, INFO, M, N, KL, N5, IMAT
*
ELSE
*
WRITE( NOUT, FMT = 9963 )SUBNAM, INFO, OPTS( 1: 1 ), M, N5,
$ IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'GB' ) ) THEN
*
* xGB: General band matrices
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9989 )SUBNAM, INFO, INFOE, M, N, KL,
$ KU, N5, IMAT
ELSE
WRITE( NOUT, FMT = 9976 )SUBNAM, INFO, M, N, KL, KU, N5,
$ IMAT
END IF
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9949 )
*
ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9986 )SUBNAM, INFO, INFOE, N, KL, KU,
$ N5, IMAT
ELSE
WRITE( NOUT, FMT = 9972 )SUBNAM, INFO, N, KL, KU, N5,
$ IMAT
END IF
*
ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9993 )SUBNAM, INFO, INFOE,
$ OPTS( 1: 1 ), OPTS( 2: 2 ), N, KL, KU, N5, IMAT
ELSE
WRITE( NOUT, FMT = 9998 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), N, KL, KU, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN
*
WRITE( NOUT, FMT = 9977 )SUBNAM, INFO, M, N, KL, KU, IMAT
*
ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN
*
WRITE( NOUT, FMT = 9968 )SUBNAM, INFO, OPTS( 1: 1 ), M, KL,
$ KU, IMAT
*
ELSE
*
WRITE( NOUT, FMT = 9964 )SUBNAM, INFO, OPTS( 1: 1 ), M, KL,
$ KU, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'GT' ) ) THEN
*
* xGT: General tridiagonal matrices
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9987 )SUBNAM, INFO, INFOE, N, IMAT
ELSE
WRITE( NOUT, FMT = 9973 )SUBNAM, INFO, N, IMAT
END IF
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9949 )
*
ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9984 )SUBNAM, INFO, INFOE, N, N5,
$ IMAT
ELSE
WRITE( NOUT, FMT = 9970 )SUBNAM, INFO, N, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9992 )SUBNAM, INFO, INFOE,
$ OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT
ELSE
WRITE( NOUT, FMT = 9997 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), N, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN
*
WRITE( NOUT, FMT = 9969 )SUBNAM, INFO, OPTS( 1: 1 ), M,
$ IMAT
*
ELSE
*
WRITE( NOUT, FMT = 9963 )SUBNAM, INFO, OPTS( 1: 1 ), M, N5,
$ IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'PO' ) ) THEN
*
* xPO: Symmetric or Hermitian positive definite matrices
*
UPLO = OPTS( 1: 1 )
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9980 )SUBNAM, INFO, INFOE, UPLO, M,
$ N5, IMAT
ELSE
WRITE( NOUT, FMT = 9956 )SUBNAM, INFO, UPLO, M, N5, IMAT
END IF
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9949 )
*
ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9979 )SUBNAM, INFO, INFOE, UPLO, N,
$ N5, IMAT
ELSE
WRITE( NOUT, FMT = 9955 )SUBNAM, INFO, UPLO, N, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9990 )SUBNAM, INFO, INFOE,
$ OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT
ELSE
WRITE( NOUT, FMT = 9995 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), N, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
*
WRITE( NOUT, FMT = 9956 )SUBNAM, INFO, UPLO, M, N5, IMAT
*
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) .OR.
$ LSAMEN( 3, C3, 'CON' ) ) THEN
*
WRITE( NOUT, FMT = 9960 )SUBNAM, INFO, UPLO, M, IMAT
*
ELSE
*
WRITE( NOUT, FMT = 9955 )SUBNAM, INFO, UPLO, M, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'SY' ) .OR. LSAMEN( 2, P2, 'HE' ) ) THEN
*
* xHE, or xSY: Symmetric or Hermitian indefinite matrices
*
UPLO = OPTS( 1: 1 )
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9980 )SUBNAM, INFO, INFOE, UPLO, M,
$ N5, IMAT
ELSE
WRITE( NOUT, FMT = 9956 )SUBNAM, INFO, UPLO, M, N5, IMAT
END IF
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9949 )
*
ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9979 )SUBNAM, INFO, INFOE, UPLO, N,
$ N5, IMAT
ELSE
WRITE( NOUT, FMT = 9955 )SUBNAM, INFO, UPLO, N, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9990 )SUBNAM, INFO, INFOE,
$ OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT
ELSE
WRITE( NOUT, FMT = 9995 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), N, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) .OR.
$ LSAMEN( 3, C3, 'TRI' ) .OR. LSAMEN( 3, C3, 'CON' ) )
$ THEN
*
WRITE( NOUT, FMT = 9960 )SUBNAM, INFO, UPLO, M, IMAT
*
ELSE
*
WRITE( NOUT, FMT = 9955 )SUBNAM, INFO, UPLO, M, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'PP' ) .OR. LSAMEN( 2, P2, 'SP' ) .OR.
$ LSAMEN( 2, P2, 'HP' ) ) THEN
*
* xPP, xHP, or xSP: Symmetric or Hermitian packed matrices
*
UPLO = OPTS( 1: 1 )
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9983 )SUBNAM, INFO, INFOE, UPLO, M,
$ IMAT
ELSE
WRITE( NOUT, FMT = 9960 )SUBNAM, INFO, UPLO, M, IMAT
END IF
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9949 )
*
ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9979 )SUBNAM, INFO, INFOE, UPLO, N,
$ N5, IMAT
ELSE
WRITE( NOUT, FMT = 9955 )SUBNAM, INFO, UPLO, N, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9990 )SUBNAM, INFO, INFOE,
$ OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT
ELSE
WRITE( NOUT, FMT = 9995 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), N, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) .OR.
$ LSAMEN( 3, C3, 'TRI' ) .OR. LSAMEN( 3, C3, 'CON' ) )
$ THEN
*
WRITE( NOUT, FMT = 9960 )SUBNAM, INFO, UPLO, M, IMAT
*
ELSE
*
WRITE( NOUT, FMT = 9955 )SUBNAM, INFO, UPLO, M, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'PB' ) ) THEN
*
* xPB: Symmetric (Hermitian) positive definite band matrix
*
UPLO = OPTS( 1: 1 )
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9982 )SUBNAM, INFO, INFOE, UPLO, M,
$ KL, N5, IMAT
ELSE
WRITE( NOUT, FMT = 9958 )SUBNAM, INFO, UPLO, M, KL, N5,
$ IMAT
END IF
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9949 )
*
ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9981 )SUBNAM, INFO, INFOE, UPLO, N,
$ KL, N5, IMAT
ELSE
WRITE( NOUT, FMT = 9957 )SUBNAM, INFO, UPLO, N, KL, N5,
$ IMAT
END IF
*
ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9991 )SUBNAM, INFO, INFOE,
$ OPTS( 1: 1 ), OPTS( 2: 2 ), N, KL, N5, IMAT
ELSE
WRITE( NOUT, FMT = 9996 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), N, KL, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) .OR.
$ LSAMEN( 3, C3, 'CON' ) ) THEN
*
WRITE( NOUT, FMT = 9959 )SUBNAM, INFO, UPLO, M, KL, IMAT
*
ELSE
*
WRITE( NOUT, FMT = 9957 )SUBNAM, INFO, UPLO, M, KL, N5,
$ IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'PT' ) ) THEN
*
* xPT: Positive definite tridiagonal matrices
*
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9987 )SUBNAM, INFO, INFOE, N, IMAT
ELSE
WRITE( NOUT, FMT = 9973 )SUBNAM, INFO, N, IMAT
END IF
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9949 )
*
ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9984 )SUBNAM, INFO, INFOE, N, N5,
$ IMAT
ELSE
WRITE( NOUT, FMT = 9970 )SUBNAM, INFO, N, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9994 )SUBNAM, INFO, INFOE,
$ OPTS( 1: 1 ), N, N5, IMAT
ELSE
WRITE( NOUT, FMT = 9999 )SUBNAM, INFO, OPTS( 1: 1 ), N,
$ N5, IMAT
END IF
*
ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN
*
IF( LSAME( SUBNAM( 1: 1 ), 'S' ) .OR.
$ LSAME( SUBNAM( 1: 1 ), 'D' ) ) THEN
WRITE( NOUT, FMT = 9973 )SUBNAM, INFO, M, IMAT
ELSE
WRITE( NOUT, FMT = 9969 )SUBNAM, INFO, OPTS( 1: 1 ), M,
$ IMAT
END IF
*
ELSE
*
WRITE( NOUT, FMT = 9963 )SUBNAM, INFO, OPTS( 1: 1 ), M, N5,
$ IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'TR' ) ) THEN
*
* xTR: Triangular matrix
*
IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
WRITE( NOUT, FMT = 9961 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), M, N5, IMAT
ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN
WRITE( NOUT, FMT = 9967 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), OPTS( 3: 3 ), M, IMAT
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATRS' ) ) THEN
WRITE( NOUT, FMT = 9952 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), OPTS( 3: 3 ), OPTS( 4: 4 ), M, IMAT
ELSE
WRITE( NOUT, FMT = 9953 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), OPTS( 3: 3 ), M, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'TP' ) ) THEN
*
* xTP: Triangular packed matrix
*
IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
WRITE( NOUT, FMT = 9962 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), M, IMAT
ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN
WRITE( NOUT, FMT = 9967 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), OPTS( 3: 3 ), M, IMAT
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATPS' ) ) THEN
WRITE( NOUT, FMT = 9952 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), OPTS( 3: 3 ), OPTS( 4: 4 ), M, IMAT
ELSE
WRITE( NOUT, FMT = 9953 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), OPTS( 3: 3 ), M, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'TB' ) ) THEN
*
* xTB: Triangular band matrix
*
IF( LSAMEN( 3, C3, 'CON' ) ) THEN
WRITE( NOUT, FMT = 9966 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), OPTS( 3: 3 ), M, KL, IMAT
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATBS' ) ) THEN
WRITE( NOUT, FMT = 9951 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), OPTS( 3: 3 ), OPTS( 4: 4 ), M, KL, IMAT
ELSE
WRITE( NOUT, FMT = 9954 )SUBNAM, INFO, OPTS( 1: 1 ),
$ OPTS( 2: 2 ), OPTS( 3: 3 ), M, KL, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'QR' ) ) THEN
*
* xQR: QR factorization
*
IF( LSAMEN( 3, C3, 'QRS' ) ) THEN
WRITE( NOUT, FMT = 9974 )SUBNAM, INFO, M, N, KL, N5, IMAT
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN
WRITE( NOUT, FMT = 9978 )SUBNAM, INFO, M, N, IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'LQ' ) ) THEN
*
* xLQ: LQ factorization
*
IF( LSAMEN( 3, C3, 'LQS' ) ) THEN
WRITE( NOUT, FMT = 9974 )SUBNAM, INFO, M, N, KL, N5, IMAT
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN
WRITE( NOUT, FMT = 9978 )SUBNAM, INFO, M, N, IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'QL' ) ) THEN
*
* xQL: QL factorization
*
IF( LSAMEN( 3, C3, 'QLS' ) ) THEN
WRITE( NOUT, FMT = 9974 )SUBNAM, INFO, M, N, KL, N5, IMAT
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN
WRITE( NOUT, FMT = 9978 )SUBNAM, INFO, M, N, IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'RQ' ) ) THEN
*
* xRQ: RQ factorization
*
IF( LSAMEN( 3, C3, 'RQS' ) ) THEN
WRITE( NOUT, FMT = 9974 )SUBNAM, INFO, M, N, KL, N5, IMAT
ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN
WRITE( NOUT, FMT = 9978 )SUBNAM, INFO, M, N, IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'LU' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9988 )SUBNAM, INFO, INFOE, M, N, N5,
$ IMAT
ELSE
WRITE( NOUT, FMT = 9975 )SUBNAM, INFO, M, N, N5, IMAT
END IF
*
ELSE IF( LSAMEN( 2, P2, 'CH' ) ) THEN
*
IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
WRITE( NOUT, FMT = 9985 )SUBNAM, INFO, INFOE, M, N5, IMAT
ELSE
WRITE( NOUT, FMT = 9971 )SUBNAM, INFO, M, N5, IMAT
END IF
*
ELSE
*
* Print a generic message if the path is unknown.
*
WRITE( NOUT, FMT = 9950 )SUBNAM, INFO
END IF
*
* Description of error message (alphabetical, left to right)
*
* SUBNAM, INFO, FACT, N, NRHS, IMAT
*
9999 FORMAT( ' *** Error code from ', A6, '=', I5, ', FACT=''', A1,
$ ''', N=', I5, ', NRHS=', I4, ', type ', I2 )
*
* SUBNAM, INFO, FACT, TRANS, N, KL, KU, NRHS, IMAT
*
9998 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> FACT=''',
$ A1, ''', TRANS=''', A1, ''', N=', I5, ', KL=', I5, ', KU=',
$ I5, ', NRHS=', I4, ', type ', I1 )
*
* SUBNAM, INFO, FACT, TRANS, N, NRHS, IMAT
*
9997 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> FACT=''',
$ A1, ''', TRANS=''', A1, ''', N =', I5, ', NRHS =', I4,
$ ', type ', I2 )
*
* SUBNAM, INFO, FACT, UPLO, N, KD, NRHS, IMAT
*
9996 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> FACT=''',
$ A1, ''', UPLO=''', A1, ''', N=', I5, ', KD=', I5, ', NRHS=',
$ I4, ', type ', I2 )
*
* SUBNAM, INFO, FACT, UPLO, N, NRHS, IMAT
*
9995 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> FACT=''',
$ A1, ''', UPLO=''', A1, ''', N =', I5, ', NRHS =', I4,
$ ', type ', I2 )
*
* SUBNAM, INFO, INFOE, FACT, N, NRHS, IMAT
*
9994 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, / ' ==> FACT=''', A1, ''', N =', I5, ', NRHS =', I4,
$ ', type ', I2 )
*
* SUBNAM, INFO, INFOE, FACT, TRANS, N, KL, KU, NRHS, IMAT
*
9993 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, / ' ==> FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5,
$ ', KL=', I5, ', KU=', I5, ', NRHS=', I4, ', type ', I1 )
*
* SUBNAM, INFO, INFOE, FACT, TRANS, N, NRHS, IMAT
*
9992 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, / ' ==> FACT=''', A1, ''', TRANS=''', A1, ''', N =', I5,
$ ', NRHS =', I4, ', type ', I2 )
*
* SUBNAM, INFO, INFOE, FACT, UPLO, N, KD, NRHS, IMAT
*
9991 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, / ' ==> FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5,
$ ', KD=', I5, ', NRHS=', I4, ', type ', I2 )
*
* SUBNAM, INFO, INFOE, FACT, UPLO, N, NRHS, IMAT
*
9990 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, / ' ==> FACT=''', A1, ''', UPLO=''', A1, ''', N =', I5,
$ ', NRHS =', I4, ', type ', I2 )
*
* SUBNAM, INFO, INFOE, M, N, KL, KU, NB, IMAT
*
9989 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, / ' ==> M = ', I5, ', N =', I5, ', KL =', I5, ', KU =',
$ I5, ', NB =', I4, ', type ', I2 )
*
* SUBNAM, INFO, INFOE, M, N, NB, IMAT
*
9988 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, / ' ==> M =', I5, ', N =', I5, ', NB =', I4, ', type ',
$ I2 )
*
* SUBNAM, INFO, INFOE, N, IMAT
*
9987 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, ' for N=', I5, ', type ', I2 )
*
* SUBNAM, INFO, INFOE, N, KL, KU, NRHS, IMAT
*
9986 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, / ' ==> N =', I5, ', KL =', I5, ', KU =', I5,
$ ', NRHS =', I4, ', type ', I2 )
*
* SUBNAM, INFO, INFOE, N, NB, IMAT
*
9985 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, / ' ==> N =', I5, ', NB =', I4, ', type ', I2 )
*
* SUBNAM, INFO, INFOE, N, NRHS, IMAT
*
9984 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, / ' ==> N =', I5, ', NRHS =', I4, ', type ', I2 )
*
* SUBNAM, INFO, INFOE, UPLO, N, IMAT
*
9983 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, / ' ==> UPLO = ''', A1, ''', N =', I5, ', type ', I2 )
*
* SUBNAM, INFO, INFOE, UPLO, N, KD, NB, IMAT
*
9982 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, / ' ==> UPLO = ''', A1, ''', N =', I5, ', KD =', I5,
$ ', NB =', I4, ', type ', I2 )
*
* SUBNAM, INFO, INFOE, UPLO, N, KD, NRHS, IMAT
*
9981 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, / ' ==> UPLO=''', A1, ''', N =', I5, ', KD =', I5,
$ ', NRHS =', I4, ', type ', I2 )
*
* SUBNAM, INFO, INFOE, UPLO, N, NB, IMAT
*
9980 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, / ' ==> UPLO = ''', A1, ''', N =', I5, ', NB =', I4,
$ ', type ', I2 )
*
* SUBNAM, INFO, INFOE, UPLO, N, NRHS, IMAT
*
9979 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
$ I2, / ' ==> UPLO = ''', A1, ''', N =', I5, ', NRHS =', I4,
$ ', type ', I2 )
*
* SUBNAM, INFO, M, N, IMAT
*
9978 FORMAT( ' *** Error code from ', A6, ' =', I5, ' for M =', I5,
$ ', N =', I5, ', type ', I2 )
*
* SUBNAM, INFO, M, N, KL, KU, IMAT
*
9977 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> M = ', I5,
$ ', N =', I5, ', KL =', I5, ', KU =', I5, ', type ', I2 )
*
* SUBNAM, INFO, M, N, KL, KU, NB, IMAT
*
9976 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> M = ', I5,
$ ', N =', I5, ', KL =', I5, ', KU =', I5, ', NB =', I4,
$ ', type ', I2 )
*
* SUBNAM, INFO, M, N, NB, IMAT
*
9975 FORMAT( ' *** Error code from ', A6, '=', I5, ' for M=', I5,
$ ', N=', I5, ', NB=', I4, ', type ', I2 )
*
* SUBNAM, INFO, M, N, NRHS, NB, IMAT
*
9974 FORMAT( ' *** Error code from ', A6, '=', I5, / ' ==> M =', I5,
$ ', N =', I5, ', NRHS =', I4, ', NB =', I4, ', type ', I2 )
*
* SUBNAM, INFO, N, IMAT
*
9973 FORMAT( ' *** Error code from ', A6, ' =', I5, ' for N =', I5,
$ ', type ', I2 )
*
* SUBNAM, INFO, N, KL, KU, NRHS, IMAT
*
9972 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> N =', I5,
$ ', KL =', I5, ', KU =', I5, ', NRHS =', I4, ', type ', I2 )
*
* SUBNAM, INFO, N, NB, IMAT
*
9971 FORMAT( ' *** Error code from ', A6, '=', I5, ' for N=', I5,
$ ', NB=', I4, ', type ', I2 )
*
* SUBNAM, INFO, N, NRHS, IMAT
*
9970 FORMAT( ' *** Error code from ', A6, ' =', I5, ' for N =', I5,
$ ', NRHS =', I4, ', type ', I2 )
*
* SUBNAM, INFO, NORM, N, IMAT
*
9969 FORMAT( ' *** Error code from ', A6, ' =', I5, ' for NORM = ''',
$ A1, ''', N =', I5, ', type ', I2 )
*
* SUBNAM, INFO, NORM, N, KL, KU, IMAT
*
9968 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> NORM =''',
$ A1, ''', N =', I5, ', KL =', I5, ', KU =', I5, ', type ',
$ I2 )
*
* SUBNAM, INFO, NORM, UPLO, DIAG, N, IMAT
*
9967 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> NORM=''',
$ A1, ''', UPLO =''', A1, ''', DIAG=''', A1, ''', N =', I5,
$ ', type ', I2 )
*
* SUBNAM, INFO, NORM, UPLO, DIAG, N, KD, IMAT
*
9966 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> NORM=''',
$ A1, ''', UPLO =''', A1, ''', DIAG=''', A1, ''', N=', I5,
$ ', KD=', I5, ', type ', I2 )
*
* SUBNAM, INFO, TRANS, M, N, NRHS, NB, IMAT
*
9965 FORMAT( ' *** Error code from ', A6, ' =', I5,
$ / ' ==> TRANS = ''', A1, ''', M =', I5, ', N =', I5,
$ ', NRHS =', I4, ', NB =', I4, ', type ', I2 )
*
* SUBNAM, INFO, TRANS, N, KL, KU, NRHS, IMAT
*
9964 FORMAT( ' *** Error code from ', A6, '=', I5, / ' ==> TRANS=''',
$ A1, ''', N =', I5, ', KL =', I5, ', KU =', I5, ', NRHS =',
$ I4, ', type ', I2 )
*
* SUBNAM, INFO, TRANS, N, NRHS, IMAT
*
9963 FORMAT( ' *** Error code from ', A6, ' =', I5,
$ / ' ==> TRANS = ''', A1, ''', N =', I5, ', NRHS =', I4,
$ ', type ', I2 )
*
* SUBNAM, INFO, UPLO, DIAG, N, IMAT
*
9962 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO=''',
$ A1, ''', DIAG =''', A1, ''', N =', I5, ', type ', I2 )
*
* SUBNAM, INFO, UPLO, DIAG, N, NB, IMAT
*
9961 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO=''',
$ A1, ''', DIAG =''', A1, ''', N =', I5, ', NB =', I4,
$ ', type ', I2 )
*
* SUBNAM, INFO, UPLO, N, IMAT
*
9960 FORMAT( ' *** Error code from ', A6, ' =', I5, ' for UPLO = ''',
$ A1, ''', N =', I5, ', type ', I2 )
*
* SUBNAM, INFO, UPLO, N, KD, IMAT
*
9959 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO = ''',
$ A1, ''', N =', I5, ', KD =', I5, ', type ', I2 )
*
* SUBNAM, INFO, UPLO, N, KD, NB, IMAT
*
9958 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO = ''',
$ A1, ''', N =', I5, ', KD =', I5, ', NB =', I4, ', type ',
$ I2 )
*
* SUBNAM, INFO, UPLO, N, KD, NRHS, IMAT
*
9957 FORMAT( ' *** Error code from ', A6, '=', I5, / ' ==> UPLO = ''',
$ A1, ''', N =', I5, ', KD =', I5, ', NRHS =', I4, ', type ',
$ I2 )
*
* SUBNAM, INFO, UPLO, N, NB, IMAT
*
9956 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO = ''',
$ A1, ''', N =', I5, ', NB =', I4, ', type ', I2 )
*
* SUBNAM, INFO, UPLO, N, NRHS, IMAT
*
9955 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO = ''',
$ A1, ''', N =', I5, ', NRHS =', I4, ', type ', I2 )
*
* SUBNAM, INFO, UPLO, TRANS, DIAG, N, KD, NRHS, IMAT
*
9954 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO=''',
$ A1, ''', TRANS=''', A1, ''', DIAG=''', A1, ''', N=', I5,
$ ', KD=', I5, ', NRHS=', I4, ', type ', I2 )
*
* SUBNAM, INFO, UPLO, TRANS, DIAG, N, NRHS, IMAT
*
9953 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO=''',
$ A1, ''', TRANS=''', A1, ''', DIAG=''', A1, ''', N =', I5,
$ ', NRHS =', I4, ', type ', I2 )
*
* SUBNAM, INFO, UPLO, TRANS, DIAG, NORMIN, N, IMAT
*
9952 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO=''',
$ A1, ''', TRANS=''', A1, ''', DIAG=''', A1, ''', NORMIN=''',
$ A1, ''', N =', I5, ', type ', I2 )
*
* SUBNAM, INFO, UPLO, TRANS, DIAG, NORMIN, N, KD, IMAT
*
9951 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO=''',
$ A1, ''', TRANS=''', A1, ''', DIAG=''', A1, ''', NORMIN=''',
$ A1, ''', N=', I5, ', KD=', I5, ', type ', I2 )
*
* Unknown type
*
9950 FORMAT( ' *** Error code from ', A6, ' =', I5 )
*
* What we do next
*
9949 FORMAT( ' ==> Doing only the condition estimate for this case' )
*
RETURN
*
* End of ALAERH
*
END
SUBROUTINE ALAESM( PATH, OK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL OK
CHARACTER*3 PATH
INTEGER NOUT
* ..
*
* Purpose
* =======
*
* ALAESM prints a summary of results from one of the -ERR- routines.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name.
*
* OK (input) LOGICAL
* The flag from CHKXER that indicates whether or not the tests
* of error exits passed.
*
* NOUT (input) INTEGER
* The unit number on which results are to be printed.
* NOUT >= 0.
*
* =====================================================================
*
* .. Executable Statements ..
*
IF( OK ) THEN
WRITE( NOUT, FMT = 9999 )PATH
ELSE
WRITE( NOUT, FMT = 9998 )PATH
END IF
*
9999 FORMAT( 1X, A3, ' routines passed the tests of the error exits'
$ )
9998 FORMAT( ' *** ', A3, ' routines failed the tests of the error ',
$ 'exits ***' )
RETURN
*
* End of ALAESM
*
END
SUBROUTINE ALAHD( IOUNIT, PATH )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER IOUNIT
* ..
*
* Purpose
* =======
*
* ALAHD prints header information for the different test paths.
*
* Arguments
* =========
*
* IOUNIT (input) INTEGER
* The unit number to which the header information should be
* printed.
*
* PATH (input) CHARACTER*3
* The name of the path for which the header information is to
* be printed. Current paths are
* _GE: General matrices
* _GB: General band
* _GT: General Tridiagonal
* _PO: Symmetric or Hermitian positive definite
* _PP: Symmetric or Hermitian positive definite packed
* _PB: Symmetric or Hermitian positive definite band
* _PT: Symmetric or Hermitian positive definite tridiagonal
* _SY: Symmetric indefinite
* _SP: Symmetric indefinite packed
* _HE: (complex) Hermitian indefinite
* _HP: (complex) Hermitian indefinite packed
* _TR: Triangular
* _TP: Triangular packed
* _TB: Triangular band
* _QR: QR (general matrices)
* _LQ: LQ (general matrices)
* _QL: QL (general matrices)
* _RQ: RQ (general matrices)
* _QP: QR with column pivoting
* _TZ: Trapezoidal
* _LS: Least Squares driver routines
* _LU: LU variants
* _CH: Cholesky variants
* _QS: QR variants
* The first character must be one of S, D, C, or Z (C or Z only
* if complex).
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL CORZ, SORD
CHARACTER C1, C3
CHARACTER*2 P2
CHARACTER*6 SUBNAM
CHARACTER*9 SYM
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Executable Statements ..
*
IF( IOUNIT.LE.0 )
$ RETURN
C1 = PATH( 1: 1 )
C3 = PATH( 3: 3 )
P2 = PATH( 2: 3 )
SORD = LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' )
CORZ = LSAME( C1, 'C' ) .OR. LSAME( C1, 'Z' )
IF( .NOT.( SORD .OR. CORZ ) )
$ RETURN
*
IF( LSAMEN( 2, P2, 'GE' ) ) THEN
*
* GE: General dense
*
WRITE( IOUNIT, FMT = 9999 )PATH
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9979 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9962 )1
WRITE( IOUNIT, FMT = 9961 )2
WRITE( IOUNIT, FMT = 9960 )3
WRITE( IOUNIT, FMT = 9959 )4
WRITE( IOUNIT, FMT = 9958 )5
WRITE( IOUNIT, FMT = 9957 )6
WRITE( IOUNIT, FMT = 9956 )7
WRITE( IOUNIT, FMT = 9955 )8
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'GB' ) ) THEN
*
* GB: General band
*
WRITE( IOUNIT, FMT = 9998 )PATH
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9978 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9962 )1
WRITE( IOUNIT, FMT = 9960 )2
WRITE( IOUNIT, FMT = 9959 )3
WRITE( IOUNIT, FMT = 9958 )4
WRITE( IOUNIT, FMT = 9957 )5
WRITE( IOUNIT, FMT = 9956 )6
WRITE( IOUNIT, FMT = 9955 )7
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'GT' ) ) THEN
*
* GT: General tridiagonal
*
WRITE( IOUNIT, FMT = 9997 )PATH
WRITE( IOUNIT, FMT = 9977 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9962 )1
WRITE( IOUNIT, FMT = 9960 )2
WRITE( IOUNIT, FMT = 9959 )3
WRITE( IOUNIT, FMT = 9958 )4
WRITE( IOUNIT, FMT = 9957 )5
WRITE( IOUNIT, FMT = 9956 )6
WRITE( IOUNIT, FMT = 9955 )7
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'PO' ) .OR. LSAMEN( 2, P2, 'PP' ) ) THEN
*
* PO: Positive definite full
* PP: Positive definite packed
*
IF( SORD ) THEN
SYM = 'Symmetric'
ELSE
SYM = 'Hermitian'
END IF
IF( LSAME( C3, 'O' ) ) THEN
WRITE( IOUNIT, FMT = 9996 )PATH, SYM
ELSE
WRITE( IOUNIT, FMT = 9995 )PATH, SYM
END IF
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9975 )PATH
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9954 )1
WRITE( IOUNIT, FMT = 9961 )2
WRITE( IOUNIT, FMT = 9960 )3
WRITE( IOUNIT, FMT = 9959 )4
WRITE( IOUNIT, FMT = 9958 )5
WRITE( IOUNIT, FMT = 9957 )6
WRITE( IOUNIT, FMT = 9956 )7
WRITE( IOUNIT, FMT = 9955 )8
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'PB' ) ) THEN
*
* PB: Positive definite band
*
IF( SORD ) THEN
WRITE( IOUNIT, FMT = 9994 )PATH, 'Symmetric'
ELSE
WRITE( IOUNIT, FMT = 9994 )PATH, 'Hermitian'
END IF
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9973 )PATH
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9954 )1
WRITE( IOUNIT, FMT = 9960 )2
WRITE( IOUNIT, FMT = 9959 )3
WRITE( IOUNIT, FMT = 9958 )4
WRITE( IOUNIT, FMT = 9957 )5
WRITE( IOUNIT, FMT = 9956 )6
WRITE( IOUNIT, FMT = 9955 )7
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'PT' ) ) THEN
*
* PT: Positive definite tridiagonal
*
IF( SORD ) THEN
WRITE( IOUNIT, FMT = 9993 )PATH, 'Symmetric'
ELSE
WRITE( IOUNIT, FMT = 9993 )PATH, 'Hermitian'
END IF
WRITE( IOUNIT, FMT = 9976 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9952 )1
WRITE( IOUNIT, FMT = 9960 )2
WRITE( IOUNIT, FMT = 9959 )3
WRITE( IOUNIT, FMT = 9958 )4
WRITE( IOUNIT, FMT = 9957 )5
WRITE( IOUNIT, FMT = 9956 )6
WRITE( IOUNIT, FMT = 9955 )7
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'SY' ) .OR. LSAMEN( 2, P2, 'SP' ) ) THEN
*
* SY: Symmetric indefinite full
* SP: Symmetric indefinite packed
*
IF( LSAME( C3, 'Y' ) ) THEN
WRITE( IOUNIT, FMT = 9992 )PATH, 'Symmetric'
ELSE
WRITE( IOUNIT, FMT = 9991 )PATH, 'Symmetric'
END IF
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
IF( SORD ) THEN
WRITE( IOUNIT, FMT = 9972 )
ELSE
WRITE( IOUNIT, FMT = 9971 )
END IF
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9953 )1
WRITE( IOUNIT, FMT = 9961 )2
WRITE( IOUNIT, FMT = 9960 )3
WRITE( IOUNIT, FMT = 9959 )4
WRITE( IOUNIT, FMT = 9958 )5
WRITE( IOUNIT, FMT = 9956 )6
WRITE( IOUNIT, FMT = 9957 )7
WRITE( IOUNIT, FMT = 9955 )8
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'HE' ) .OR. LSAMEN( 2, P2, 'HP' ) ) THEN
*
* HE: Hermitian indefinite full
* HP: Hermitian indefinite packed
*
IF( LSAME( C3, 'E' ) ) THEN
WRITE( IOUNIT, FMT = 9992 )PATH, 'Hermitian'
ELSE
WRITE( IOUNIT, FMT = 9991 )PATH, 'Hermitian'
END IF
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9972 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9953 )1
WRITE( IOUNIT, FMT = 9961 )2
WRITE( IOUNIT, FMT = 9960 )3
WRITE( IOUNIT, FMT = 9959 )4
WRITE( IOUNIT, FMT = 9958 )5
WRITE( IOUNIT, FMT = 9956 )6
WRITE( IOUNIT, FMT = 9957 )7
WRITE( IOUNIT, FMT = 9955 )8
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'TR' ) .OR. LSAMEN( 2, P2, 'TP' ) ) THEN
*
* TR: Triangular full
* TP: Triangular packed
*
IF( LSAME( C3, 'R' ) ) THEN
WRITE( IOUNIT, FMT = 9990 )PATH
SUBNAM = PATH( 1: 1 ) // 'LATRS'
ELSE
WRITE( IOUNIT, FMT = 9989 )PATH
SUBNAM = PATH( 1: 1 ) // 'LATPS'
END IF
WRITE( IOUNIT, FMT = 9966 )PATH
WRITE( IOUNIT, FMT = 9965 )SUBNAM
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9961 )1
WRITE( IOUNIT, FMT = 9960 )2
WRITE( IOUNIT, FMT = 9959 )3
WRITE( IOUNIT, FMT = 9958 )4
WRITE( IOUNIT, FMT = 9957 )5
WRITE( IOUNIT, FMT = 9956 )6
WRITE( IOUNIT, FMT = 9955 )7
WRITE( IOUNIT, FMT = 9951 )SUBNAM, 8
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'TB' ) ) THEN
*
* TB: Triangular band
*
WRITE( IOUNIT, FMT = 9988 )PATH
SUBNAM = PATH( 1: 1 ) // 'LATBS'
WRITE( IOUNIT, FMT = 9964 )PATH
WRITE( IOUNIT, FMT = 9963 )SUBNAM
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9960 )1
WRITE( IOUNIT, FMT = 9959 )2
WRITE( IOUNIT, FMT = 9958 )3
WRITE( IOUNIT, FMT = 9957 )4
WRITE( IOUNIT, FMT = 9956 )5
WRITE( IOUNIT, FMT = 9955 )6
WRITE( IOUNIT, FMT = 9951 )SUBNAM, 7
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'QR' ) ) THEN
*
* QR decomposition of rectangular matrices
*
WRITE( IOUNIT, FMT = 9987 )PATH, 'QR'
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9970 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9950 )1
WRITE( IOUNIT, FMT = 9946 )2
WRITE( IOUNIT, FMT = 9944 )3, 'M'
WRITE( IOUNIT, FMT = 9943 )4, 'M'
WRITE( IOUNIT, FMT = 9942 )5, 'M'
WRITE( IOUNIT, FMT = 9941 )6, 'M'
WRITE( IOUNIT, FMT = 9960 )7
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'LQ' ) ) THEN
*
* LQ decomposition of rectangular matrices
*
WRITE( IOUNIT, FMT = 9987 )PATH, 'LQ'
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9970 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9949 )1
WRITE( IOUNIT, FMT = 9945 )2
WRITE( IOUNIT, FMT = 9944 )3, 'N'
WRITE( IOUNIT, FMT = 9943 )4, 'N'
WRITE( IOUNIT, FMT = 9942 )5, 'N'
WRITE( IOUNIT, FMT = 9941 )6, 'N'
WRITE( IOUNIT, FMT = 9960 )7
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'QL' ) ) THEN
*
* QL decomposition of rectangular matrices
*
WRITE( IOUNIT, FMT = 9987 )PATH, 'QL'
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9970 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9948 )1
WRITE( IOUNIT, FMT = 9946 )2
WRITE( IOUNIT, FMT = 9944 )3, 'M'
WRITE( IOUNIT, FMT = 9943 )4, 'M'
WRITE( IOUNIT, FMT = 9942 )5, 'M'
WRITE( IOUNIT, FMT = 9941 )6, 'M'
WRITE( IOUNIT, FMT = 9960 )7
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'RQ' ) ) THEN
*
* RQ decomposition of rectangular matrices
*
WRITE( IOUNIT, FMT = 9987 )PATH, 'RQ'
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9970 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9947 )1
WRITE( IOUNIT, FMT = 9945 )2
WRITE( IOUNIT, FMT = 9944 )3, 'N'
WRITE( IOUNIT, FMT = 9943 )4, 'N'
WRITE( IOUNIT, FMT = 9942 )5, 'N'
WRITE( IOUNIT, FMT = 9941 )6, 'N'
WRITE( IOUNIT, FMT = 9960 )7
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'QP' ) ) THEN
*
* QR decomposition with column pivoting
*
WRITE( IOUNIT, FMT = 9986 )PATH
WRITE( IOUNIT, FMT = 9969 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9940 )1
WRITE( IOUNIT, FMT = 9939 )2
WRITE( IOUNIT, FMT = 9938 )3
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'TZ' ) ) THEN
*
* TZ: Trapezoidal
*
WRITE( IOUNIT, FMT = 9985 )PATH
WRITE( IOUNIT, FMT = 9968 )
WRITE( IOUNIT, FMT = 9929 )C1, C1
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
WRITE( IOUNIT, FMT = 9940 )1
WRITE( IOUNIT, FMT = 9937 )2
WRITE( IOUNIT, FMT = 9938 )3
WRITE( IOUNIT, FMT = 9940 )4
WRITE( IOUNIT, FMT = 9937 )5
WRITE( IOUNIT, FMT = 9938 )6
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'LS' ) ) THEN
*
* LS: Least Squares driver routines for
* LS, LSD, LSS, LSX and LSY.
*
WRITE( IOUNIT, FMT = 9984 )PATH
WRITE( IOUNIT, FMT = 9967 )
WRITE( IOUNIT, FMT = 9921 )C1, C1, C1, C1, C1
WRITE( IOUNIT, FMT = 9935 )1
WRITE( IOUNIT, FMT = 9931 )2
WRITE( IOUNIT, FMT = 9933 )3
WRITE( IOUNIT, FMT = 9935 )4
WRITE( IOUNIT, FMT = 9934 )5
WRITE( IOUNIT, FMT = 9932 )6
WRITE( IOUNIT, FMT = 9920 )
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'LU' ) ) THEN
*
* LU factorization variants
*
WRITE( IOUNIT, FMT = 9983 )PATH
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9979 )
WRITE( IOUNIT, FMT = '( '' Test ratio:'' )' )
WRITE( IOUNIT, FMT = 9962 )1
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'CH' ) ) THEN
*
* Cholesky factorization variants
*
WRITE( IOUNIT, FMT = 9982 )PATH
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9974 )
WRITE( IOUNIT, FMT = '( '' Test ratio:'' )' )
WRITE( IOUNIT, FMT = 9954 )1
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
ELSE IF( LSAMEN( 2, P2, 'QS' ) ) THEN
*
* QR factorization variants
*
WRITE( IOUNIT, FMT = 9981 )PATH
WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
WRITE( IOUNIT, FMT = 9970 )
WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
*
ELSE
*
* Print error message if no header is available.
*
WRITE( IOUNIT, FMT = 9980 )PATH
END IF
*
* First line of header
*
9999 FORMAT( / 1X, A3, ': General dense matrices' )
9998 FORMAT( / 1X, A3, ': General band matrices' )
9997 FORMAT( / 1X, A3, ': General tridiagonal' )
9996 FORMAT( / 1X, A3, ': ', A9, ' positive definite matrices' )
9995 FORMAT( / 1X, A3, ': ', A9, ' positive definite packed matrices'
$ )
9994 FORMAT( / 1X, A3, ': ', A9, ' positive definite band matrices' )
9993 FORMAT( / 1X, A3, ': ', A9, ' positive definite tridiagonal' )
9992 FORMAT( / 1X, A3, ': ', A9, ' indefinite matrices' )
9991 FORMAT( / 1X, A3, ': ', A9, ' indefinite packed matrices' )
9990 FORMAT( / 1X, A3, ': Triangular matrices' )
9989 FORMAT( / 1X, A3, ': Triangular packed matrices' )
9988 FORMAT( / 1X, A3, ': Triangular band matrices' )
9987 FORMAT( / 1X, A3, ': ', A2, ' factorization of general matrices'
$ )
9986 FORMAT( / 1X, A3, ': QR factorization with column pivoting' )
9985 FORMAT( / 1X, A3, ': RQ factorization of trapezoidal matrix' )
9984 FORMAT( / 1X, A3, ': Least squares driver routines' )
9983 FORMAT( / 1X, A3, ': LU factorization variants' )
9982 FORMAT( / 1X, A3, ': Cholesky factorization variants' )
9981 FORMAT( / 1X, A3, ': QR factorization variants' )
9980 FORMAT( / 1X, A3, ': No header available' )
*
* GE matrix types
*
9979 FORMAT( 4X, '1. Diagonal', 24X, '7. Last n/2 columns zero', / 4X,
$ '2. Upper triangular', 16X,
$ '8. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
$ '3. Lower triangular', 16X, '9. Random, CNDNUM = 0.1/EPS',
$ / 4X, '4. Random, CNDNUM = 2', 13X,
$ '10. Scaled near underflow', / 4X, '5. First column zero',
$ 14X, '11. Scaled near overflow', / 4X,
$ '6. Last column zero' )
*
* GB matrix types
*
9978 FORMAT( 4X, '1. Random, CNDNUM = 2', 14X,
$ '5. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
$ '2. First column zero', 15X, '6. Random, CNDNUM = .01/EPS',
$ / 4X, '3. Last column zero', 16X,
$ '7. Scaled near underflow', / 4X,
$ '4. Last n/2 columns zero', 11X, '8. Scaled near overflow' )
*
* GT matrix types
*
9977 FORMAT( ' Matrix types (1-6 have specified condition numbers):',
$ / 4X, '1. Diagonal', 24X, '7. Random, unspecified CNDNUM',
$ / 4X, '2. Random, CNDNUM = 2', 14X, '8. First column zero',
$ / 4X, '3. Random, CNDNUM = sqrt(0.1/EPS)', 2X,
$ '9. Last column zero', / 4X, '4. Random, CNDNUM = 0.1/EPS',
$ 7X, '10. Last n/2 columns zero', / 4X,
$ '5. Scaled near underflow', 10X,
$ '11. Scaled near underflow', / 4X,
$ '6. Scaled near overflow', 11X, '12. Scaled near overflow' )
*
* PT matrix types
*
9976 FORMAT( ' Matrix types (1-6 have specified condition numbers):',
$ / 4X, '1. Diagonal', 24X, '7. Random, unspecified CNDNUM',
$ / 4X, '2. Random, CNDNUM = 2', 14X,
$ '8. First row and column zero', / 4X,
$ '3. Random, CNDNUM = sqrt(0.1/EPS)', 2X,
$ '9. Last row and column zero', / 4X,
$ '4. Random, CNDNUM = 0.1/EPS', 7X,
$ '10. Middle row and column zero', / 4X,
$ '5. Scaled near underflow', 10X,
$ '11. Scaled near underflow', / 4X,
$ '6. Scaled near overflow', 11X, '12. Scaled near overflow' )
*
* PO, PP matrix types
*
9975 FORMAT( 4X, '1. Diagonal', 24X,
$ '6. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
$ '2. Random, CNDNUM = 2', 14X, '7. Random, CNDNUM = 0.1/EPS',
$ / 3X, '*3. First row and column zero', 7X,
$ '8. Scaled near underflow', / 3X,
$ '*4. Last row and column zero', 8X,
$ '9. Scaled near overflow', / 3X,
$ '*5. Middle row and column zero', / 3X,
$ '(* - tests error exits from ', A3,
$ 'TRF, no test ratios are computed)' )
*
* CH matrix types
*
9974 FORMAT( 4X, '1. Diagonal', 24X,
$ '6. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
$ '2. Random, CNDNUM = 2', 14X, '7. Random, CNDNUM = 0.1/EPS',
$ / 3X, '*3. First row and column zero', 7X,
$ '8. Scaled near underflow', / 3X,
$ '*4. Last row and column zero', 8X,
$ '9. Scaled near overflow', / 3X,
$ '*5. Middle row and column zero', / 3X,
$ '(* - tests error exits, no test ratios are computed)' )
*
* PB matrix types
*
9973 FORMAT( 4X, '1. Random, CNDNUM = 2', 14X,
$ '5. Random, CNDNUM = sqrt(0.1/EPS)', / 3X,
$ '*2. First row and column zero', 7X,
$ '6. Random, CNDNUM = 0.1/EPS', / 3X,
$ '*3. Last row and column zero', 8X,
$ '7. Scaled near underflow', / 3X,
$ '*4. Middle row and column zero', 6X,
$ '8. Scaled near overflow', / 3X,
$ '(* - tests error exits from ', A3,
$ 'TRF, no test ratios are computed)' )
*
* SSY, SSP, CHE, CHP matrix types
*
9972 FORMAT( 4X, '1. Diagonal', 24X,
$ '6. Last n/2 rows and columns zero', / 4X,
$ '2. Random, CNDNUM = 2', 14X,
$ '7. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
$ '3. First row and column zero', 7X,
$ '8. Random, CNDNUM = 0.1/EPS', / 4X,
$ '4. Last row and column zero', 8X,
$ '9. Scaled near underflow', / 4X,
$ '5. Middle row and column zero', 5X,
$ '10. Scaled near overflow' )
*
* CSY, CSP matrix types
*
9971 FORMAT( 4X, '1. Diagonal', 24X,
$ '7. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
$ '2. Random, CNDNUM = 2', 14X, '8. Random, CNDNUM = 0.1/EPS',
$ / 4X, '3. First row and column zero', 7X,
$ '9. Scaled near underflow', / 4X,
$ '4. Last row and column zero', 7X,
$ '10. Scaled near overflow', / 4X,
$ '5. Middle row and column zero', 5X,
$ '11. Block diagonal matrix', / 4X,
$ '6. Last n/2 rows and columns zero' )
*
* QR matrix types
*
9970 FORMAT( 4X, '1. Diagonal', 24X,
$ '5. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
$ '2. Upper triangular', 16X, '6. Random, CNDNUM = 0.1/EPS',
$ / 4X, '3. Lower triangular', 16X,
$ '7. Scaled near underflow', / 4X, '4. Random, CNDNUM = 2',
$ 14X, '8. Scaled near overflow' )
*
* QP matrix types
*
9969 FORMAT( ' Matrix types (2-6 have condition 1/EPS):', / 4X,
$ '1. Zero matrix', 21X, '4. First n/2 columns fixed', / 4X,
$ '2. One small eigenvalue', 12X, '5. Last n/2 columns fixed',
$ / 4X, '3. Geometric distribution', 10X,
$ '6. Every second column fixed' )
*
* TZ matrix types
*
9968 FORMAT( ' Matrix types (2-3 have condition 1/EPS):', / 4X,
$ '1. Zero matrix', / 4X, '2. One small eigenvalue', / 4X,
$ '3. Geometric distribution' )
*
* LS matrix types
*
9967 FORMAT( ' Matrix types (1-3: full rank, 4-6: rank deficient):',
$ / 4X, '1 and 4. Normal scaling', / 4X,
$ '2 and 5. Scaled near overflow', / 4X,
$ '3 and 6. Scaled near underflow' )
*
* TR, TP matrix types
*
9966 FORMAT( ' Matrix types for ', A3, ' routines:', / 4X,
$ '1. Diagonal', 24X, '6. Scaled near overflow', / 4X,
$ '2. Random, CNDNUM = 2', 14X, '7. Identity', / 4X,
$ '3. Random, CNDNUM = sqrt(0.1/EPS) ',
$ '8. Unit triangular, CNDNUM = 2', / 4X,
$ '4. Random, CNDNUM = 0.1/EPS', 8X,
$ '9. Unit, CNDNUM = sqrt(0.1/EPS)', / 4X,
$ '5. Scaled near underflow', 10X,
$ '10. Unit, CNDNUM = 0.1/EPS' )
9965 FORMAT( ' Special types for testing ', A6, ':', / 3X,
$ '11. Matrix elements are O(1), large right hand side', / 3X,
$ '12. First diagonal causes overflow,',
$ ' offdiagonal column norms < 1', / 3X,
$ '13. First diagonal causes overflow,',
$ ' offdiagonal column norms > 1', / 3X,
$ '14. Growth factor underflows, solution does not overflow',
$ / 3X, '15. Small diagonal causes gradual overflow', / 3X,
$ '16. One zero diagonal element', / 3X,
$ '17. Large offdiagonals cause overflow when adding a column'
$ , / 3X, '18. Unit triangular with large right hand side' )
*
* TB matrix types
*
9964 FORMAT( ' Matrix types for ', A3, ' routines:', / 4X,
$ '1. Random, CNDNUM = 2', 14X, '6. Identity', / 4X,
$ '2. Random, CNDNUM = sqrt(0.1/EPS) ',
$ '7. Unit triangular, CNDNUM = 2', / 4X,
$ '3. Random, CNDNUM = 0.1/EPS', 8X,
$ '8. Unit, CNDNUM = sqrt(0.1/EPS)', / 4X,
$ '4. Scaled near underflow', 11X,
$ '9. Unit, CNDNUM = 0.1/EPS', / 4X,
$ '5. Scaled near overflow' )
9963 FORMAT( ' Special types for testing ', A6, ':', / 3X,
$ '10. Matrix elements are O(1), large right hand side', / 3X,
$ '11. First diagonal causes overflow,',
$ ' offdiagonal column norms < 1', / 3X,
$ '12. First diagonal causes overflow,',
$ ' offdiagonal column norms > 1', / 3X,
$ '13. Growth factor underflows, solution does not overflow',
$ / 3X, '14. Small diagonal causes gradual overflow', / 3X,
$ '15. One zero diagonal element', / 3X,
$ '16. Large offdiagonals cause overflow when adding a column'
$ , / 3X, '17. Unit triangular with large right hand side' )
*
* Test ratios
*
9962 FORMAT( 3X, I2, ': norm( L * U - A ) / ( N * norm(A) * EPS )' )
9961 FORMAT( 3X, I2, ': norm( I - A*AINV ) / ',
$ '( N * norm(A) * norm(AINV) * EPS )' )
9960 FORMAT( 3X, I2, ': norm( B - A * X ) / ',
$ '( norm(A) * norm(X) * EPS )' )
9959 FORMAT( 3X, I2, ': norm( X - XACT ) / ',
$ '( norm(XACT) * CNDNUM * EPS )' )
9958 FORMAT( 3X, I2, ': norm( X - XACT ) / ',
$ '( norm(XACT) * CNDNUM * EPS ), refined' )
9957 FORMAT( 3X, I2, ': norm( X - XACT ) / ',
$ '( norm(XACT) * (error bound) )' )
9956 FORMAT( 3X, I2, ': (backward error) / EPS' )
9955 FORMAT( 3X, I2, ': RCOND * CNDNUM - 1.0' )
9954 FORMAT( 3X, I2, ': norm( U'' * U - A ) / ( N * norm(A) * EPS )',
$ ', or', / 7X, 'norm( L * L'' - A ) / ( N * norm(A) * EPS )'
$ )
9953 FORMAT( 3X, I2, ': norm( U*D*U'' - A ) / ( N * norm(A) * EPS )',
$ ', or', / 7X, 'norm( L*D*L'' - A ) / ( N * norm(A) * EPS )'
$ )
9952 FORMAT( 3X, I2, ': norm( U''*D*U - A ) / ( N * norm(A) * EPS )',
$ ', or', / 7X, 'norm( L*D*L'' - A ) / ( N * norm(A) * EPS )'
$ )
9951 FORMAT( ' Test ratio for ', A6, ':', / 3X, I2,
$ ': norm( s*b - A*x ) / ( norm(A) * norm(x) * EPS )' )
9950 FORMAT( 3X, I2, ': norm( R - Q'' * A ) / ( M * norm(A) * EPS )' )
9949 FORMAT( 3X, I2, ': norm( L - A * Q'' ) / ( N * norm(A) * EPS )' )
9948 FORMAT( 3X, I2, ': norm( L - Q'' * A ) / ( M * norm(A) * EPS )' )
9947 FORMAT( 3X, I2, ': norm( R - A * Q'' ) / ( N * norm(A) * EPS )' )
9946 FORMAT( 3X, I2, ': norm( I - Q''*Q ) / ( M * EPS )' )
9945 FORMAT( 3X, I2, ': norm( I - Q*Q'' ) / ( N * EPS )' )
9944 FORMAT( 3X, I2, ': norm( Q*C - Q*C ) / ', '( ', A1,
$ ' * norm(C) * EPS )' )
9943 FORMAT( 3X, I2, ': norm( C*Q - C*Q ) / ', '( ', A1,
$ ' * norm(C) * EPS )' )
9942 FORMAT( 3X, I2, ': norm( Q''*C - Q''*C )/ ', '( ', A1,
$ ' * norm(C) * EPS )' )
9941 FORMAT( 3X, I2, ': norm( C*Q'' - C*Q'' )/ ', '( ', A1,
$ ' * norm(C) * EPS )' )
9940 FORMAT( 3X, I2, ': norm(svd(A) - svd(R)) / ',
$ '( M * norm(svd(R)) * EPS )' )
9939 FORMAT( 3X, I2, ': norm( A*P - Q*R ) / ( M * norm(A) * EPS )'
$ )
9938 FORMAT( 3X, I2, ': norm( I - Q''*Q ) / ( M * EPS )' )
9937 FORMAT( 3X, I2, ': norm( A - R*Q ) / ( M * norm(A) * EPS )'
$ )
9936 FORMAT( ' Test ratios (1-2: ', A1, 'GELS, 3-6: ', A1,
$ 'GELSS, 7-10: ', A1, 'GELSX):' )
9935 FORMAT( 3X, I2, ': norm( B - A * X ) / ',
$ '( max(M,N) * norm(A) * norm(X) * EPS )' )
9934 FORMAT( 3X, I2, ': norm( (A*X-B)'' *A ) / ',
$ '( max(M,N,NRHS) * norm(A) * norm(B) * EPS )' )
9933 FORMAT( 3X, I2, ': norm(svd(A)-svd(R)) / ',
$ '( min(M,N) * norm(svd(R)) * EPS )' )
9932 FORMAT( 3X, I2, ': Check if X is in the row space of A or A''' )
9931 FORMAT( 3X, I2, ': norm( (A*X-B)'' *A ) / ',
$ '( max(M,N,NRHS) * norm(A) * norm(B) * EPS )', / 7X,
$ 'if TRANS=''N'' and M.GE.N or TRANS=''T'' and M.LT.N, ',
$ 'otherwise', / 7X,
$ 'check if X is in the row space of A or A'' ',
$ '(overdetermined case)' )
9930 FORMAT( 3X, ' 7-10: same as 3-6' )
9929 FORMAT( ' Test ratios (1-3: ', A1, 'TZRQF, 4-6: ', A1,
$ 'TZRZF):' )
9920 FORMAT( 3X, ' 7-10: same as 3-6', 3X, ' 11-14: same as 3-6',
$ 3X, ' 15-18: same as 3-6' )
9921 FORMAT( ' Test ratios:', / ' (1-2: ', A1, 'GELS, 3-6: ', A1,
$ 'GELSX, 7-10: ', A1, 'GELSY, 11-14: ', A1, 'GELSS, 15-18: ',
$ A1, 'GELSD)' )
*
RETURN
*
* End of ALAHD
*
END
SUBROUTINE ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NIN, NMATS, NOUT, NTYPES
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
* ..
*
* Purpose
* =======
*
* ALAREQ handles input for the LAPACK test program. It is called
* to evaluate the input line which requested NMATS matrix types for
* PATH. The flow of control is as follows:
*
* If NMATS = NTYPES then
* DOTYPE(1:NTYPES) = .TRUE.
* else
* Read the next input line for NMATS matrix types
* Set DOTYPE(I) = .TRUE. for each valid type I
* endif
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* An LAPACK path name for testing.
*
* NMATS (input) INTEGER
* The number of matrix types to be used in testing this path.
*
* DOTYPE (output) LOGICAL array, dimension (NTYPES)
* The vector of flags indicating if each type will be tested.
*
* NTYPES (input) INTEGER
* The maximum number of matrix types for this path.
*
* NIN (input) INTEGER
* The unit number for input. NIN >= 1.
*
* NOUT (input) INTEGER
* The unit number for output. NOUT >= 1.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL FIRSTT
CHARACTER C1
CHARACTER*10 INTSTR
CHARACTER*80 LINE
INTEGER I, I1, IC, J, K, LENP, NT
* ..
* .. Local Arrays ..
INTEGER NREQ( 100 )
* ..
* .. Intrinsic Functions ..
INTRINSIC LEN
* ..
* .. Data statements ..
DATA INTSTR / '0123456789' /
* ..
* .. Executable Statements ..
*
IF( NMATS.GE.NTYPES ) THEN
*
* Test everything if NMATS >= NTYPES.
*
DO 10 I = 1, NTYPES
DOTYPE( I ) = .TRUE.
10 CONTINUE
ELSE
DO 20 I = 1, NTYPES
DOTYPE( I ) = .FALSE.
20 CONTINUE
FIRSTT = .TRUE.
*
* Read a line of matrix types if 0 < NMATS < NTYPES.
*
IF( NMATS.GT.0 ) THEN
READ( NIN, FMT = '(A80)', END = 90 )LINE
LENP = LEN( LINE )
I = 0
DO 60 J = 1, NMATS
NREQ( J ) = 0
I1 = 0
30 CONTINUE
I = I + 1
IF( I.GT.LENP ) THEN
IF( J.EQ.NMATS .AND. I1.GT.0 ) THEN
GO TO 60
ELSE
WRITE( NOUT, FMT = 9995 )LINE
WRITE( NOUT, FMT = 9994 )NMATS
GO TO 80
END IF
END IF
IF( LINE( I: I ).NE.' ' .AND. LINE( I: I ).NE.',' ) THEN
I1 = I
C1 = LINE( I1: I1 )
*
* Check that a valid integer was read
*
DO 40 K = 1, 10
IF( C1.EQ.INTSTR( K: K ) ) THEN
IC = K - 1
GO TO 50
END IF
40 CONTINUE
WRITE( NOUT, FMT = 9996 )I, LINE
WRITE( NOUT, FMT = 9994 )NMATS
GO TO 80
50 CONTINUE
NREQ( J ) = 10*NREQ( J ) + IC
GO TO 30
ELSE IF( I1.GT.0 ) THEN
GO TO 60
ELSE
GO TO 30
END IF
60 CONTINUE
END IF
DO 70 I = 1, NMATS
NT = NREQ( I )
IF( NT.GT.0 .AND. NT.LE.NTYPES ) THEN
IF( DOTYPE( NT ) ) THEN
IF( FIRSTT )
$ WRITE( NOUT, FMT = * )
FIRSTT = .FALSE.
WRITE( NOUT, FMT = 9997 )NT, PATH
END IF
DOTYPE( NT ) = .TRUE.
ELSE
WRITE( NOUT, FMT = 9999 )PATH, NT, NTYPES
9999 FORMAT( ' *** Invalid type request for ', A3, ', type ',
$ I4, ': must satisfy 1 <= type <= ', I2 )
END IF
70 CONTINUE
80 CONTINUE
END IF
RETURN
*
90 CONTINUE
WRITE( NOUT, FMT = 9998 )PATH
9998 FORMAT( /' *** End of file reached when trying to read matrix ',
$ 'types for ', A3, /' *** Check that you are requesting the',
$ ' right number of types for each path', / )
9997 FORMAT( ' *** Warning: duplicate request of matrix type ', I2,
$ ' for ', A3 )
9996 FORMAT( //' *** Invalid integer value in column ', I2,
$ ' of input', ' line:', /A79 )
9995 FORMAT( //' *** Not enough matrix types on input line', /A79 )
9994 FORMAT( ' ==> Specify ', I4, ' matrix types on this line or ',
$ 'adjust NTYPES on previous line' )
WRITE( NOUT, FMT = * )
STOP
*
* End of ALAREQ
*
END
SUBROUTINE ALASUM( TYPE, NOUT, NFAIL, NRUN, NERRS )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 TYPE
INTEGER NFAIL, NOUT, NRUN, NERRS
* ..
*
* Purpose
* =======
*
* ALASUM prints a summary of results from one of the -CHK- routines.
*
* Arguments
* =========
*
* TYPE (input) CHARACTER*3
* The LAPACK path name.
*
* NOUT (input) INTEGER
* The unit number on which results are to be printed.
* NOUT >= 0.
*
* NFAIL (input) INTEGER
* The number of tests which did not pass the threshold ratio.
*
* NRUN (input) INTEGER
* The total number of tests.
*
* NERRS (input) INTEGER
* The number of error messages recorded.
*
* =====================================================================
*
* .. Executable Statements ..
*
IF( NFAIL.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )TYPE, NFAIL, NRUN
ELSE
WRITE( NOUT, FMT = 9998 )TYPE, NRUN
END IF
IF( NERRS.GT.0 ) THEN
WRITE( NOUT, FMT = 9997 )NERRS
END IF
*
9999 FORMAT( 1X, A3, ': ', I6, ' out of ', I6,
$ ' tests failed to pass the threshold' )
9998 FORMAT( /1X, 'All tests for ', A3,
$ ' routines passed the threshold (', I6, ' tests run)' )
9997 FORMAT( 6X, I6, ' error messages recorded' )
RETURN
*
* End of ALASUM
*
END
SUBROUTINE ALASVM( TYPE, NOUT, NFAIL, NRUN, NERRS )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 TYPE
INTEGER NFAIL, NOUT, NRUN, NERRS
* ..
*
* Purpose
* =======
*
* ALASVM prints a summary of results from one of the -DRV- routines.
*
* Arguments
* =========
*
* TYPE (input) CHARACTER*3
* The LAPACK path name.
*
* NOUT (input) INTEGER
* The unit number on which results are to be printed.
* NOUT >= 0.
*
* NFAIL (input) INTEGER
* The number of tests which did not pass the threshold ratio.
*
* NRUN (input) INTEGER
* The total number of tests.
*
* NERRS (input) INTEGER
* The number of error messages recorded.
*
* =====================================================================
*
* .. Executable Statements ..
*
IF( NFAIL.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )TYPE, NFAIL, NRUN
ELSE
WRITE( NOUT, FMT = 9998 )TYPE, NRUN
END IF
IF( NERRS.GT.0 ) THEN
WRITE( NOUT, FMT = 9997 )NERRS
END IF
*
9999 FORMAT( 1X, A3, ' drivers: ', I6, ' out of ', I6,
$ ' tests failed to pass the threshold' )
9998 FORMAT( /1X, 'All tests for ', A3, ' drivers passed the ',
$ 'threshold (', I6, ' tests run)' )
9997 FORMAT( 14X, I6, ' error messages recorded' )
RETURN
*
* End of ALASVM
*
END
SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
*
* Tests whether XERBLA has detected an error when it should.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* =====================================================================
*
* .. Scalar Arguments ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Executable Statements ..
IF( .NOT.LERR ) THEN
WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT
OK = .FALSE.
END IF
LERR = .FALSE.
RETURN
*
9999 FORMAT( ' *** Illegal value of parameter number ', I2,
$ ' not detected by ', A6, ' ***' )
*
* End of CHKXER.
*
END
PROGRAM DCHKAA
*
* -- LAPACK test routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* January 2007
*
* Purpose
* =======
*
* DCHKAA is the main test program for the DOUBLE PRECISION LAPACK
* linear equation routines
*
* The program must be driven by a short data file. The first 14 records
* specify problem dimensions and program options using list-directed
* input. The remaining lines specify the LAPACK test paths and the
* number of matrix types to use in testing. An annotated example of a
* data file can be obtained by deleting the first 3 characters from the
* following 36 lines:
* Data file for testing DOUBLE PRECISION LAPACK linear eqn. routines
* 7 Number of values of M
* 0 1 2 3 5 10 16 Values of M (row dimension)
* 7 Number of values of N
* 0 1 2 3 5 10 16 Values of N (column dimension)
* 1 Number of values of NRHS
* 2 Values of NRHS (number of right hand sides)
* 5 Number of values of NB
* 1 3 3 3 20 Values of NB (the blocksize)
* 1 0 5 9 1 Values of NX (crossover point)
* 20.0 Threshold value of test ratio
* T Put T to test the LAPACK routines
* T Put T to test the driver routines
* T Put T to test the error exits
* DGE 11 List types on next line if 0 < NTYPES < 11
* DGB 8 List types on next line if 0 < NTYPES < 8
* DGT 12 List types on next line if 0 < NTYPES < 12
* DPO 9 List types on next line if 0 < NTYPES < 9
* DPP 9 List types on next line if 0 < NTYPES < 9
* DPB 8 List types on next line if 0 < NTYPES < 8
* DPT 12 List types on next line if 0 < NTYPES < 12
* DSY 10 List types on next line if 0 < NTYPES < 10
* DSP 10 List types on next line if 0 < NTYPES < 10
* DTR 18 List types on next line if 0 < NTYPES < 18
* DTP 18 List types on next line if 0 < NTYPES < 18
* DTB 17 List types on next line if 0 < NTYPES < 17
* DQR 8 List types on next line if 0 < NTYPES < 8
* DRQ 8 List types on next line if 0 < NTYPES < 8
* DLQ 8 List types on next line if 0 < NTYPES < 8
* DQL 8 List types on next line if 0 < NTYPES < 8
* DQP 6 List types on next line if 0 < NTYPES < 6
* DTZ 3 List types on next line if 0 < NTYPES < 3
* DLS 6 List types on next line if 0 < NTYPES < 6
* DEQ
*
* Internal Parameters
* ===================
*
* NMAX INTEGER
* The maximum allowable value for N
*
* MAXIN INTEGER
* The number of different values that can be used for each of
* M, N, NRHS, NB, and NX
*
* MAXRHS INTEGER
* The maximum number of right hand sides
*
* NIN INTEGER
* The unit number for input
*
* NOUT INTEGER
* The unit number for output
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 132 )
INTEGER MAXIN
PARAMETER ( MAXIN = 12 )
INTEGER MAXRHS
PARAMETER ( MAXRHS = 16 )
INTEGER MATMAX
PARAMETER ( MATMAX = 30 )
INTEGER NIN, NOUT
PARAMETER ( NIN = 5, NOUT = 6 )
INTEGER KDMAX
PARAMETER ( KDMAX = NMAX+( NMAX+1 ) / 4 )
* ..
* .. Local Scalars ..
LOGICAL FATAL, TSTCHK, TSTDRV, TSTERR
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 PATH
CHARACTER*10 INTSTR
CHARACTER*72 ALINE
INTEGER I, IC, J, K, LA, LAFAC, LDA, NB, NM, NMATS, NN,
$ NNB, NNB2, NNS, NRHS, NTYPES,
$ VERS_MAJOR, VERS_MINOR, VERS_PATCH
DOUBLE PRECISION EPS, S1, S2, THREQ, THRESH
* ..
* .. Local Arrays ..
LOGICAL DOTYPE( MATMAX )
INTEGER IWORK( 25*NMAX ), MVAL( MAXIN ),
$ NBVAL( MAXIN ), NBVAL2( MAXIN ),
$ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN )
DOUBLE PRECISION A( ( KDMAX+1 )*NMAX, 7 ), B( NMAX*MAXRHS, 4 ),
$ RWORK( 5*NMAX+2*MAXRHS ), S( 2*NMAX ),
$ WORK( NMAX, NMAX+MAXRHS+30 )
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
DOUBLE PRECISION DLAMCH, DSECND
EXTERNAL LSAME, LSAMEN, DLAMCH, DSECND
* ..
* .. External Subroutines ..
EXTERNAL ALAREQ, DCHKEQ, DCHKGB, DCHKGE, DCHKGT, DCHKLQ,
$ DCHKPB, DCHKPO, DCHKPP, DCHKPT, DCHKQ3, DCHKQL,
$ DCHKQP, DCHKQR, DCHKRQ, DCHKSP, DCHKSY, DCHKTB,
$ DCHKTP, DCHKTR, DCHKTZ, DDRVGB, DDRVGE, DDRVGT,
$ DDRVLS, DDRVPB, DDRVPO, DDRVPP, DDRVPT, DDRVSP,
$ DDRVSY, ILAVER
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Arrays in Common ..
INTEGER IPARMS( 100 )
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
COMMON / CLAENV / IPARMS
* ..
* .. Data statements ..
DATA THREQ / 2.0D0 / , INTSTR / '0123456789' /
* ..
* .. Executable Statements ..
*
S1 = DSECND( )
LDA = NMAX
FATAL = .FALSE.
*
* Read a dummy line.
*
READ( NIN, FMT = * )
*
* Report values of parameters.
*
CALL ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH )
WRITE( NOUT, FMT = 9994 ) VERS_MAJOR, VERS_MINOR, VERS_PATCH
*
* Read the values of M
*
READ( NIN, FMT = * )NM
IF( NM.LT.1 ) THEN
WRITE( NOUT, FMT = 9996 )' NM ', NM, 1
NM = 0
FATAL = .TRUE.
ELSE IF( NM.GT.MAXIN ) THEN
WRITE( NOUT, FMT = 9995 )' NM ', NM, MAXIN
NM = 0
FATAL = .TRUE.
END IF
READ( NIN, FMT = * )( MVAL( I ), I = 1, NM )
DO 10 I = 1, NM
IF( MVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9996 )' M ', MVAL( I ), 0
FATAL = .TRUE.
ELSE IF( MVAL( I ).GT.NMAX ) THEN
WRITE( NOUT, FMT = 9995 )' M ', MVAL( I ), NMAX
FATAL = .TRUE.
END IF
10 CONTINUE
IF( NM.GT.0 )
$ WRITE( NOUT, FMT = 9993 )'M ', ( MVAL( I ), I = 1, NM )
*
* Read the values of N
*
READ( NIN, FMT = * )NN
IF( NN.LT.1 ) THEN
WRITE( NOUT, FMT = 9996 )' NN ', NN, 1
NN = 0
FATAL = .TRUE.
ELSE IF( NN.GT.MAXIN ) THEN
WRITE( NOUT, FMT = 9995 )' NN ', NN, MAXIN
NN = 0
FATAL = .TRUE.
END IF
READ( NIN, FMT = * )( NVAL( I ), I = 1, NN )
DO 20 I = 1, NN
IF( NVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9996 )' N ', NVAL( I ), 0
FATAL = .TRUE.
ELSE IF( NVAL( I ).GT.NMAX ) THEN
WRITE( NOUT, FMT = 9995 )' N ', NVAL( I ), NMAX
FATAL = .TRUE.
END IF
20 CONTINUE
IF( NN.GT.0 )
$ WRITE( NOUT, FMT = 9993 )'N ', ( NVAL( I ), I = 1, NN )
*
* Read the values of NRHS
*
READ( NIN, FMT = * )NNS
IF( NNS.LT.1 ) THEN
WRITE( NOUT, FMT = 9996 )' NNS', NNS, 1
NNS = 0
FATAL = .TRUE.
ELSE IF( NNS.GT.MAXIN ) THEN
WRITE( NOUT, FMT = 9995 )' NNS', NNS, MAXIN
NNS = 0
FATAL = .TRUE.
END IF
READ( NIN, FMT = * )( NSVAL( I ), I = 1, NNS )
DO 30 I = 1, NNS
IF( NSVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9996 )'NRHS', NSVAL( I ), 0
FATAL = .TRUE.
ELSE IF( NSVAL( I ).GT.MAXRHS ) THEN
WRITE( NOUT, FMT = 9995 )'NRHS', NSVAL( I ), MAXRHS
FATAL = .TRUE.
END IF
30 CONTINUE
IF( NNS.GT.0 )
$ WRITE( NOUT, FMT = 9993 )'NRHS', ( NSVAL( I ), I = 1, NNS )
*
* Read the values of NB
*
READ( NIN, FMT = * )NNB
IF( NNB.LT.1 ) THEN
WRITE( NOUT, FMT = 9996 )'NNB ', NNB, 1
NNB = 0
FATAL = .TRUE.
ELSE IF( NNB.GT.MAXIN ) THEN
WRITE( NOUT, FMT = 9995 )'NNB ', NNB, MAXIN
NNB = 0
FATAL = .TRUE.
END IF
READ( NIN, FMT = * )( NBVAL( I ), I = 1, NNB )
DO 40 I = 1, NNB
IF( NBVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9996 )' NB ', NBVAL( I ), 0
FATAL = .TRUE.
END IF
40 CONTINUE
IF( NNB.GT.0 )
$ WRITE( NOUT, FMT = 9993 )'NB ', ( NBVAL( I ), I = 1, NNB )
*
* Set NBVAL2 to be the set of unique values of NB
*
NNB2 = 0
DO 60 I = 1, NNB
NB = NBVAL( I )
DO 50 J = 1, NNB2
IF( NB.EQ.NBVAL2( J ) )
$ GO TO 60
50 CONTINUE
NNB2 = NNB2 + 1
NBVAL2( NNB2 ) = NB
60 CONTINUE
*
* Read the values of NX
*
READ( NIN, FMT = * )( NXVAL( I ), I = 1, NNB )
DO 70 I = 1, NNB
IF( NXVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9996 )' NX ', NXVAL( I ), 0
FATAL = .TRUE.
END IF
70 CONTINUE
IF( NNB.GT.0 )
$ WRITE( NOUT, FMT = 9993 )'NX ', ( NXVAL( I ), I = 1, NNB )
*
* Read the threshold value for the test ratios.
*
READ( NIN, FMT = * )THRESH
WRITE( NOUT, FMT = 9992 )THRESH
*
* Read the flag that indicates whether to test the LAPACK routines.
*
READ( NIN, FMT = * )TSTCHK
*
* Read the flag that indicates whether to test the driver routines.
*
READ( NIN, FMT = * )TSTDRV
*
* Read the flag that indicates whether to test the error exits.
*
READ( NIN, FMT = * )TSTERR
*
IF( FATAL ) THEN
WRITE( NOUT, FMT = 9999 )
STOP
END IF
*
* Calculate and print the machine dependent constants.
*
EPS = DLAMCH( 'Underflow threshold' )
WRITE( NOUT, FMT = 9991 )'underflow', EPS
EPS = DLAMCH( 'Overflow threshold' )
WRITE( NOUT, FMT = 9991 )'overflow ', EPS
EPS = DLAMCH( 'Epsilon' )
WRITE( NOUT, FMT = 9991 )'precision', EPS
WRITE( NOUT, FMT = * )
*
80 CONTINUE
*
* Read a test path and the number of matrix types to use.
*
READ( NIN, FMT = '(A72)', END = 140 )ALINE
PATH = ALINE( 1: 3 )
NMATS = MATMAX
I = 3
90 CONTINUE
I = I + 1
IF( I.GT.72 ) THEN
NMATS = MATMAX
GO TO 130
END IF
IF( ALINE( I: I ).EQ.' ' )
$ GO TO 90
NMATS = 0
100 CONTINUE
C1 = ALINE( I: I )
DO 110 K = 1, 10
IF( C1.EQ.INTSTR( K: K ) ) THEN
IC = K - 1
GO TO 120
END IF
110 CONTINUE
GO TO 130
120 CONTINUE
NMATS = NMATS*10 + IC
I = I + 1
IF( I.GT.72 )
$ GO TO 130
GO TO 100
130 CONTINUE
C1 = PATH( 1: 1 )
C2 = PATH( 2: 3 )
NRHS = NSVAL( 1 )
*
* Check first character for correct precision.
*
IF( .NOT.LSAME( C1, 'Double precision' ) ) THEN
WRITE( NOUT, FMT = 9990 )PATH
*
ELSE IF( NMATS.LE.0 ) THEN
*
* Check for a positive number of tests requested.
*
WRITE( NOUT, FMT = 9989 )PATH
*
ELSE IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
* GE: general matrices
*
NTYPES = 11
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL DCHKGE( DOTYPE, NM, MVAL, NN, NVAL, NNB2, NBVAL2, NNS,
$ NSVAL, THRESH, TSTERR, LDA, A( 1, 1 ),
$ A( 1, 2 ), A( 1, 3 ), B( 1, 1 ), B( 1, 2 ),
$ B( 1, 3 ), WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
IF( TSTDRV ) THEN
CALL DDRVGE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, LDA,
$ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B( 1, 1 ),
$ B( 1, 2 ), B( 1, 3 ), B( 1, 4 ), S, WORK,
$ RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
*
* GB: general banded matrices
*
LA = ( 2*KDMAX+1 )*NMAX
LAFAC = ( 3*KDMAX+1 )*NMAX
NTYPES = 8
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL DCHKGB( DOTYPE, NM, MVAL, NN, NVAL, NNB2, NBVAL2, NNS,
$ NSVAL, THRESH, TSTERR, A( 1, 1 ), LA,
$ A( 1, 3 ), LAFAC, B( 1, 1 ), B( 1, 2 ),
$ B( 1, 3 ), WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
IF( TSTDRV ) THEN
CALL DDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
$ A( 1, 1 ), LA, A( 1, 3 ), LAFAC, A( 1, 6 ),
$ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), B( 1, 4 ), S,
$ WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'GT' ) ) THEN
*
* GT: general tridiagonal matrices
*
NTYPES = 12
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL DCHKGT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
$ A( 1, 1 ), A( 1, 2 ), B( 1, 1 ), B( 1, 2 ),
$ B( 1, 3 ), WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
IF( TSTDRV ) THEN
CALL DDRVGT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
$ A( 1, 1 ), A( 1, 2 ), B( 1, 1 ), B( 1, 2 ),
$ B( 1, 3 ), WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'PO' ) ) THEN
*
* PO: positive definite matrices
*
NTYPES = 9
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL DCHKPO( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL,
$ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ),
$ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
$ WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
IF( TSTDRV ) THEN
CALL DDRVPO( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, LDA,
$ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B( 1, 1 ),
$ B( 1, 2 ), B( 1, 3 ), B( 1, 4 ), S, WORK,
$ RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'PP' ) ) THEN
*
* PP: positive definite packed matrices
*
NTYPES = 9
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL DCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
$ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
$ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK, RWORK,
$ IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
IF( TSTDRV ) THEN
CALL DDRVPP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, LDA,
$ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B( 1, 1 ),
$ B( 1, 2 ), B( 1, 3 ), B( 1, 4 ), S, WORK,
$ RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN
*
* PB: positive definite banded matrices
*
NTYPES = 8
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL DCHKPB( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL,
$ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ),
$ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
$ WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
IF( TSTDRV ) THEN
CALL DDRVPB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, LDA,
$ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B( 1, 1 ),
$ B( 1, 2 ), B( 1, 3 ), B( 1, 4 ), S, WORK,
$ RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'PT' ) ) THEN
*
* PT: positive definite tridiagonal matrices
*
NTYPES = 12
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL DCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
$ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B( 1, 1 ),
$ B( 1, 2 ), B( 1, 3 ), WORK, RWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
IF( TSTDRV ) THEN
CALL DDRVPT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
$ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B( 1, 1 ),
$ B( 1, 2 ), B( 1, 3 ), WORK, RWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'SY' ) ) THEN
*
* SY: symmetric indefinite matrices
*
NTYPES = 10
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL DCHKSY( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL,
$ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ),
$ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
$ WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
IF( TSTDRV ) THEN
CALL DDRVSY( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, LDA,
$ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B( 1, 1 ),
$ B( 1, 2 ), B( 1, 3 ), WORK, RWORK, IWORK,
$ NOUT )
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
* SP: symmetric indefinite packed matrices
*
NTYPES = 10
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL DCHKSP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
$ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
$ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK, RWORK,
$ IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
IF( TSTDRV ) THEN
CALL DDRVSP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, LDA,
$ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B( 1, 1 ),
$ B( 1, 2 ), B( 1, 3 ), WORK, RWORK, IWORK,
$ NOUT )
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'TR' ) ) THEN
*
* TR: triangular matrices
*
NTYPES = 18
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL DCHKTR( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL,
$ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ),
$ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK, RWORK,
$ IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'TP' ) ) THEN
*
* TP: triangular packed matrices
*
NTYPES = 18
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL DCHKTP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
$ LDA, A( 1, 1 ), A( 1, 2 ), B( 1, 1 ),
$ B( 1, 2 ), B( 1, 3 ), WORK, RWORK, IWORK,
$ NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
*
* TB: triangular banded matrices
*
NTYPES = 17
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL DCHKTB( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
$ LDA, A( 1, 1 ), A( 1, 2 ), B( 1, 1 ),
$ B( 1, 2 ), B( 1, 3 ), WORK, RWORK, IWORK,
$ NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'QR' ) ) THEN
*
* QR: QR factorization
*
NTYPES = 8
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL DCHKQR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
$ NRHS, THRESH, TSTERR, NMAX, A( 1, 1 ),
$ A( 1, 2 ), A( 1, 3 ), A( 1, 4 ), A( 1, 5 ),
$ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), B( 1, 4 ),
$ WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'LQ' ) ) THEN
*
* LQ: LQ factorization
*
NTYPES = 8
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL DCHKLQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
$ NRHS, THRESH, TSTERR, NMAX, A( 1, 1 ),
$ A( 1, 2 ), A( 1, 3 ), A( 1, 4 ), A( 1, 5 ),
$ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), B( 1, 4 ),
$ WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'QL' ) ) THEN
*
* QL: QL factorization
*
NTYPES = 8
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL DCHKQL( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
$ NRHS, THRESH, TSTERR, NMAX, A( 1, 1 ),
$ A( 1, 2 ), A( 1, 3 ), A( 1, 4 ), A( 1, 5 ),
$ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), B( 1, 4 ),
$ WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'RQ' ) ) THEN
*
* RQ: RQ factorization
*
NTYPES = 8
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL DCHKRQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
$ NRHS, THRESH, TSTERR, NMAX, A( 1, 1 ),
$ A( 1, 2 ), A( 1, 3 ), A( 1, 4 ), A( 1, 5 ),
$ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), B( 1, 4 ),
$ WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'QP' ) ) THEN
*
* QP: QR factorization with pivoting
*
NTYPES = 6
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL DCHKQP( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR,
$ A( 1, 1 ), A( 1, 2 ), B( 1, 1 ), B( 1, 2 ),
$ B( 1, 3 ), WORK, IWORK, NOUT )
CALL DCHKQ3( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
$ THRESH, A( 1, 1 ), A( 1, 2 ), B( 1, 1 ),
$ B( 1, 2 ), B( 1, 3 ), WORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'TZ' ) ) THEN
*
* TZ: Trapezoidal matrix
*
NTYPES = 3
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
CALL DCHKTZ( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR,
$ A( 1, 1 ), A( 1, 2 ), B( 1, 1 ), B( 1, 2 ),
$ B( 1, 3 ), WORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'LS' ) ) THEN
*
* LS: Least squares drivers
*
NTYPES = 6
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTDRV ) THEN
CALL DDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB,
$ NBVAL, NXVAL, THRESH, TSTERR, A( 1, 1 ),
$ A( 1, 2 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
$ RWORK, RWORK( NMAX+1 ), WORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
*
ELSE IF( LSAMEN( 2, C2, 'EQ' ) ) THEN
*
* EQ: Equilibration routines for general and positive definite
* matrices (THREQ should be between 2 and 10)
*
IF( TSTCHK ) THEN
CALL DCHKEQ( THREQ, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
ELSE
*
WRITE( NOUT, FMT = 9990 )PATH
END IF
*
* Go back to get another input line.
*
GO TO 80
*
* Branch to this line when the last record is read.
*
140 CONTINUE
CLOSE ( NIN )
S2 = DSECND( )
WRITE( NOUT, FMT = 9998 )
WRITE( NOUT, FMT = 9997 )S2 - S1
*
9999 FORMAT( / ' Execution not attempted due to input errors' )
9998 FORMAT( / ' End of tests' )
9997 FORMAT( ' Total time used = ', F12.2, ' seconds', / )
9996 FORMAT( ' Invalid input value: ', A4, '=', I6, '; must be >=',
$ I6 )
9995 FORMAT( ' Invalid input value: ', A4, '=', I6, '; must be <=',
$ I6 )
9994 FORMAT( ' Tests of the DOUBLE PRECISION LAPACK routines ',
$ / ' LAPACK VERSION ', I1, '.', I1, '.', I1,
$ / / ' The following parameter values will be used:' )
9993 FORMAT( 4X, A4, ': ', 10I6, / 11X, 10I6 )
9992 FORMAT( / ' Routines pass computational tests if test ratio is ',
$ 'less than', F8.2, / )
9991 FORMAT( ' Relative machine ', A, ' is taken to be', D16.6 )
9990 FORMAT( / 1X, A3, ': Unrecognized path name' )
9989 FORMAT( / 1X, A3, ' routines were not tested' )
9988 FORMAT( / 1X, A3, ' driver routines were not tested' )
*
* End of DCHKAA
*
END
SUBROUTINE DCHKEQ( THRESH, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER NOUT
DOUBLE PRECISION THRESH
* ..
*
* Purpose
* =======
*
* DCHKEQ tests DGEEQU, DGBEQU, DPOEQU, DPPEQU and DPBEQU
*
* Arguments
* =========
*
* THRESH (input) DOUBLE PRECISION
* Threshold for testing routines. Should be between 2 and 10.
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TEN
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D+0, TEN = 1.0D1 )
INTEGER NSZ, NSZB
PARAMETER ( NSZ = 5, NSZB = 3*NSZ-2 )
INTEGER NSZP, NPOW
PARAMETER ( NSZP = ( NSZ*( NSZ+1 ) ) / 2,
$ NPOW = 2*NSZ+1 )
* ..
* .. Local Scalars ..
LOGICAL OK
CHARACTER*3 PATH
INTEGER I, INFO, J, KL, KU, M, N
DOUBLE PRECISION CCOND, EPS, NORM, RATIO, RCMAX, RCMIN, RCOND
* ..
* .. Local Arrays ..
DOUBLE PRECISION A( NSZ, NSZ ), AB( NSZB, NSZ ), AP( NSZP ),
$ C( NSZ ), POW( NPOW ), R( NSZ ), RESLTS( 5 ),
$ RPOW( NPOW )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DGBEQU, DGEEQU, DPBEQU, DPOEQU, DPPEQU
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'EQ'
*
EPS = DLAMCH( 'P' )
DO 10 I = 1, 5
RESLTS( I ) = ZERO
10 CONTINUE
DO 20 I = 1, NPOW
POW( I ) = TEN**( I-1 )
RPOW( I ) = ONE / POW( I )
20 CONTINUE
*
* Test DGEEQU
*
DO 80 N = 0, NSZ
DO 70 M = 0, NSZ
*
DO 40 J = 1, NSZ
DO 30 I = 1, NSZ
IF( I.LE.M .AND. J.LE.N ) THEN
A( I, J ) = POW( I+J+1 )*( -1 )**( I+J )
ELSE
A( I, J ) = ZERO
END IF
30 CONTINUE
40 CONTINUE
*
CALL DGEEQU( M, N, A, NSZ, R, C, RCOND, CCOND, NORM, INFO )
*
IF( INFO.NE.0 ) THEN
RESLTS( 1 ) = ONE
ELSE
IF( N.NE.0 .AND. M.NE.0 ) THEN
RESLTS( 1 ) = MAX( RESLTS( 1 ),
$ ABS( ( RCOND-RPOW( M ) ) / RPOW( M ) ) )
RESLTS( 1 ) = MAX( RESLTS( 1 ),
$ ABS( ( CCOND-RPOW( N ) ) / RPOW( N ) ) )
RESLTS( 1 ) = MAX( RESLTS( 1 ),
$ ABS( ( NORM-POW( N+M+1 ) ) / POW( N+M+
$ 1 ) ) )
DO 50 I = 1, M
RESLTS( 1 ) = MAX( RESLTS( 1 ),
$ ABS( ( R( I )-RPOW( I+N+1 ) ) /
$ RPOW( I+N+1 ) ) )
50 CONTINUE
DO 60 J = 1, N
RESLTS( 1 ) = MAX( RESLTS( 1 ),
$ ABS( ( C( J )-POW( N-J+1 ) ) /
$ POW( N-J+1 ) ) )
60 CONTINUE
END IF
END IF
*
70 CONTINUE
80 CONTINUE
*
* Test with zero rows and columns
*
DO 90 J = 1, NSZ
A( MAX( NSZ-1, 1 ), J ) = ZERO
90 CONTINUE
CALL DGEEQU( NSZ, NSZ, A, NSZ, R, C, RCOND, CCOND, NORM, INFO )
IF( INFO.NE.MAX( NSZ-1, 1 ) )
$ RESLTS( 1 ) = ONE
*
DO 100 J = 1, NSZ
A( MAX( NSZ-1, 1 ), J ) = ONE
100 CONTINUE
DO 110 I = 1, NSZ
A( I, MAX( NSZ-1, 1 ) ) = ZERO
110 CONTINUE
CALL DGEEQU( NSZ, NSZ, A, NSZ, R, C, RCOND, CCOND, NORM, INFO )
IF( INFO.NE.NSZ+MAX( NSZ-1, 1 ) )
$ RESLTS( 1 ) = ONE
RESLTS( 1 ) = RESLTS( 1 ) / EPS
*
* Test DGBEQU
*
DO 250 N = 0, NSZ
DO 240 M = 0, NSZ
DO 230 KL = 0, MAX( M-1, 0 )
DO 220 KU = 0, MAX( N-1, 0 )
*
DO 130 J = 1, NSZ
DO 120 I = 1, NSZB
AB( I, J ) = ZERO
120 CONTINUE
130 CONTINUE
DO 150 J = 1, N
DO 140 I = 1, M
IF( I.LE.MIN( M, J+KL ) .AND. I.GE.
$ MAX( 1, J-KU ) .AND. J.LE.N ) THEN
AB( KU+1+I-J, J ) = POW( I+J+1 )*
$ ( -1 )**( I+J )
END IF
140 CONTINUE
150 CONTINUE
*
CALL DGBEQU( M, N, KL, KU, AB, NSZB, R, C, RCOND,
$ CCOND, NORM, INFO )
*
IF( INFO.NE.0 ) THEN
IF( .NOT.( ( N+KL.LT.M .AND. INFO.EQ.N+KL+1 ) .OR.
$ ( M+KU.LT.N .AND. INFO.EQ.2*M+KU+1 ) ) ) THEN
RESLTS( 2 ) = ONE
END IF
ELSE
IF( N.NE.0 .AND. M.NE.0 ) THEN
*
RCMIN = R( 1 )
RCMAX = R( 1 )
DO 160 I = 1, M
RCMIN = MIN( RCMIN, R( I ) )
RCMAX = MAX( RCMAX, R( I ) )
160 CONTINUE
RATIO = RCMIN / RCMAX
RESLTS( 2 ) = MAX( RESLTS( 2 ),
$ ABS( ( RCOND-RATIO ) / RATIO ) )
*
RCMIN = C( 1 )
RCMAX = C( 1 )
DO 170 J = 1, N
RCMIN = MIN( RCMIN, C( J ) )
RCMAX = MAX( RCMAX, C( J ) )
170 CONTINUE
RATIO = RCMIN / RCMAX
RESLTS( 2 ) = MAX( RESLTS( 2 ),
$ ABS( ( CCOND-RATIO ) / RATIO ) )
*
RESLTS( 2 ) = MAX( RESLTS( 2 ),
$ ABS( ( NORM-POW( N+M+1 ) ) /
$ POW( N+M+1 ) ) )
DO 190 I = 1, M
RCMAX = ZERO
DO 180 J = 1, N
IF( I.LE.J+KL .AND. I.GE.J-KU ) THEN
RATIO = ABS( R( I )*POW( I+J+1 )*
$ C( J ) )
RCMAX = MAX( RCMAX, RATIO )
END IF
180 CONTINUE
RESLTS( 2 ) = MAX( RESLTS( 2 ),
$ ABS( ONE-RCMAX ) )
190 CONTINUE
*
DO 210 J = 1, N
RCMAX = ZERO
DO 200 I = 1, M
IF( I.LE.J+KL .AND. I.GE.J-KU ) THEN
RATIO = ABS( R( I )*POW( I+J+1 )*
$ C( J ) )
RCMAX = MAX( RCMAX, RATIO )
END IF
200 CONTINUE
RESLTS( 2 ) = MAX( RESLTS( 2 ),
$ ABS( ONE-RCMAX ) )
210 CONTINUE
END IF
END IF
*
220 CONTINUE
230 CONTINUE
240 CONTINUE
250 CONTINUE
RESLTS( 2 ) = RESLTS( 2 ) / EPS
*
* Test DPOEQU
*
DO 290 N = 0, NSZ
*
DO 270 I = 1, NSZ
DO 260 J = 1, NSZ
IF( I.LE.N .AND. J.EQ.I ) THEN
A( I, J ) = POW( I+J+1 )*( -1 )**( I+J )
ELSE
A( I, J ) = ZERO
END IF
260 CONTINUE
270 CONTINUE
*
CALL DPOEQU( N, A, NSZ, R, RCOND, NORM, INFO )
*
IF( INFO.NE.0 ) THEN
RESLTS( 3 ) = ONE
ELSE
IF( N.NE.0 ) THEN
RESLTS( 3 ) = MAX( RESLTS( 3 ),
$ ABS( ( RCOND-RPOW( N ) ) / RPOW( N ) ) )
RESLTS( 3 ) = MAX( RESLTS( 3 ),
$ ABS( ( NORM-POW( 2*N+1 ) ) / POW( 2*N+
$ 1 ) ) )
DO 280 I = 1, N
RESLTS( 3 ) = MAX( RESLTS( 3 ),
$ ABS( ( R( I )-RPOW( I+1 ) ) / RPOW( I+
$ 1 ) ) )
280 CONTINUE
END IF
END IF
290 CONTINUE
A( MAX( NSZ-1, 1 ), MAX( NSZ-1, 1 ) ) = -ONE
CALL DPOEQU( NSZ, A, NSZ, R, RCOND, NORM, INFO )
IF( INFO.NE.MAX( NSZ-1, 1 ) )
$ RESLTS( 3 ) = ONE
RESLTS( 3 ) = RESLTS( 3 ) / EPS
*
* Test DPPEQU
*
DO 360 N = 0, NSZ
*
* Upper triangular packed storage
*
DO 300 I = 1, ( N*( N+1 ) ) / 2
AP( I ) = ZERO
300 CONTINUE
DO 310 I = 1, N
AP( ( I*( I+1 ) ) / 2 ) = POW( 2*I+1 )
310 CONTINUE
*
CALL DPPEQU( 'U', N, AP, R, RCOND, NORM, INFO )
*
IF( INFO.NE.0 ) THEN
RESLTS( 4 ) = ONE
ELSE
IF( N.NE.0 ) THEN
RESLTS( 4 ) = MAX( RESLTS( 4 ),
$ ABS( ( RCOND-RPOW( N ) ) / RPOW( N ) ) )
RESLTS( 4 ) = MAX( RESLTS( 4 ),
$ ABS( ( NORM-POW( 2*N+1 ) ) / POW( 2*N+
$ 1 ) ) )
DO 320 I = 1, N
RESLTS( 4 ) = MAX( RESLTS( 4 ),
$ ABS( ( R( I )-RPOW( I+1 ) ) / RPOW( I+
$ 1 ) ) )
320 CONTINUE
END IF
END IF
*
* Lower triangular packed storage
*
DO 330 I = 1, ( N*( N+1 ) ) / 2
AP( I ) = ZERO
330 CONTINUE
J = 1
DO 340 I = 1, N
AP( J ) = POW( 2*I+1 )
J = J + ( N-I+1 )
340 CONTINUE
*
CALL DPPEQU( 'L', N, AP, R, RCOND, NORM, INFO )
*
IF( INFO.NE.0 ) THEN
RESLTS( 4 ) = ONE
ELSE
IF( N.NE.0 ) THEN
RESLTS( 4 ) = MAX( RESLTS( 4 ),
$ ABS( ( RCOND-RPOW( N ) ) / RPOW( N ) ) )
RESLTS( 4 ) = MAX( RESLTS( 4 ),
$ ABS( ( NORM-POW( 2*N+1 ) ) / POW( 2*N+
$ 1 ) ) )
DO 350 I = 1, N
RESLTS( 4 ) = MAX( RESLTS( 4 ),
$ ABS( ( R( I )-RPOW( I+1 ) ) / RPOW( I+
$ 1 ) ) )
350 CONTINUE
END IF
END IF
*
360 CONTINUE
I = ( NSZ*( NSZ+1 ) ) / 2 - 2
AP( I ) = -ONE
CALL DPPEQU( 'L', NSZ, AP, R, RCOND, NORM, INFO )
IF( INFO.NE.MAX( NSZ-1, 1 ) )
$ RESLTS( 4 ) = ONE
RESLTS( 4 ) = RESLTS( 4 ) / EPS
*
* Test DPBEQU
*
DO 460 N = 0, NSZ
DO 450 KL = 0, MAX( N-1, 0 )
*
* Test upper triangular storage
*
DO 380 J = 1, NSZ
DO 370 I = 1, NSZB
AB( I, J ) = ZERO
370 CONTINUE
380 CONTINUE
DO 390 J = 1, N
AB( KL+1, J ) = POW( 2*J+1 )
390 CONTINUE
*
CALL DPBEQU( 'U', N, KL, AB, NSZB, R, RCOND, NORM, INFO )
*
IF( INFO.NE.0 ) THEN
RESLTS( 5 ) = ONE
ELSE
IF( N.NE.0 ) THEN
RESLTS( 5 ) = MAX( RESLTS( 5 ),
$ ABS( ( RCOND-RPOW( N ) ) / RPOW( N ) ) )
RESLTS( 5 ) = MAX( RESLTS( 5 ),
$ ABS( ( NORM-POW( 2*N+1 ) ) / POW( 2*N+
$ 1 ) ) )
DO 400 I = 1, N
RESLTS( 5 ) = MAX( RESLTS( 5 ),
$ ABS( ( R( I )-RPOW( I+1 ) ) /
$ RPOW( I+1 ) ) )
400 CONTINUE
END IF
END IF
IF( N.NE.0 ) THEN
AB( KL+1, MAX( N-1, 1 ) ) = -ONE
CALL DPBEQU( 'U', N, KL, AB, NSZB, R, RCOND, NORM, INFO )
IF( INFO.NE.MAX( N-1, 1 ) )
$ RESLTS( 5 ) = ONE
END IF
*
* Test lower triangular storage
*
DO 420 J = 1, NSZ
DO 410 I = 1, NSZB
AB( I, J ) = ZERO
410 CONTINUE
420 CONTINUE
DO 430 J = 1, N
AB( 1, J ) = POW( 2*J+1 )
430 CONTINUE
*
CALL DPBEQU( 'L', N, KL, AB, NSZB, R, RCOND, NORM, INFO )
*
IF( INFO.NE.0 ) THEN
RESLTS( 5 ) = ONE
ELSE
IF( N.NE.0 ) THEN
RESLTS( 5 ) = MAX( RESLTS( 5 ),
$ ABS( ( RCOND-RPOW( N ) ) / RPOW( N ) ) )
RESLTS( 5 ) = MAX( RESLTS( 5 ),
$ ABS( ( NORM-POW( 2*N+1 ) ) / POW( 2*N+
$ 1 ) ) )
DO 440 I = 1, N
RESLTS( 5 ) = MAX( RESLTS( 5 ),
$ ABS( ( R( I )-RPOW( I+1 ) ) /
$ RPOW( I+1 ) ) )
440 CONTINUE
END IF
END IF
IF( N.NE.0 ) THEN
AB( 1, MAX( N-1, 1 ) ) = -ONE
CALL DPBEQU( 'L', N, KL, AB, NSZB, R, RCOND, NORM, INFO )
IF( INFO.NE.MAX( N-1, 1 ) )
$ RESLTS( 5 ) = ONE
END IF
450 CONTINUE
460 CONTINUE
RESLTS( 5 ) = RESLTS( 5 ) / EPS
OK = ( RESLTS( 1 ).LE.THRESH ) .AND.
$ ( RESLTS( 2 ).LE.THRESH ) .AND.
$ ( RESLTS( 3 ).LE.THRESH ) .AND.
$ ( RESLTS( 4 ).LE.THRESH ) .AND. ( RESLTS( 5 ).LE.THRESH )
WRITE( NOUT, FMT = * )
IF( OK ) THEN
WRITE( NOUT, FMT = 9999 )PATH
ELSE
IF( RESLTS( 1 ).GT.THRESH )
$ WRITE( NOUT, FMT = 9998 )RESLTS( 1 ), THRESH
IF( RESLTS( 2 ).GT.THRESH )
$ WRITE( NOUT, FMT = 9997 )RESLTS( 2 ), THRESH
IF( RESLTS( 3 ).GT.THRESH )
$ WRITE( NOUT, FMT = 9996 )RESLTS( 3 ), THRESH
IF( RESLTS( 4 ).GT.THRESH )
$ WRITE( NOUT, FMT = 9995 )RESLTS( 4 ), THRESH
IF( RESLTS( 5 ).GT.THRESH )
$ WRITE( NOUT, FMT = 9994 )RESLTS( 5 ), THRESH
END IF
9999 FORMAT( 1X, 'All tests for ', A3,
$ ' routines passed the threshold' )
9998 FORMAT( ' DGEEQU failed test with value ', D10.3, ' exceeding',
$ ' threshold ', D10.3 )
9997 FORMAT( ' DGBEQU failed test with value ', D10.3, ' exceeding',
$ ' threshold ', D10.3 )
9996 FORMAT( ' DPOEQU failed test with value ', D10.3, ' exceeding',
$ ' threshold ', D10.3 )
9995 FORMAT( ' DPPEQU failed test with value ', D10.3, ' exceeding',
$ ' threshold ', D10.3 )
9994 FORMAT( ' DPBEQU failed test with value ', D10.3, ' exceeding',
$ ' threshold ', D10.3 )
RETURN
*
* End of DCHKEQ
*
END
SUBROUTINE DCHKGB( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS,
$ NSVAL, THRESH, TSTERR, A, LA, AFAC, LAFAC, B,
$ X, XACT, WORK, RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER LA, LAFAC, NM, NN, NNB, NNS, NOUT
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ),
$ NVAL( * )
DOUBLE PRECISION A( * ), AFAC( * ), B( * ), RWORK( * ),
$ WORK( * ), X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* DCHKGB tests DGBTRF, -TRS, -RFS, and -CON
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NNB (input) INTEGER
* The number of values of NB contained in the vector NBVAL.
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* A (workspace) DOUBLE PRECISION array, dimension (LA)
*
* LA (input) INTEGER
* The length of the array A. LA >= (KLMAX+KUMAX+1)*NMAX
* where KLMAX is the largest entry in the local array KLVAL,
* KUMAX is the largest entry in the local array KUVAL and
* NMAX is the largest entry in the input array NVAL.
*
* AFAC (workspace) DOUBLE PRECISION array, dimension (LAFAC)
*
* LAFAC (input) INTEGER
* The length of the array AFAC. LAFAC >= (2*KLMAX+KUMAX+1)*NMAX
* where KLMAX is the largest entry in the local array KLVAL,
* KUMAX is the largest entry in the local array KUVAL and
* NMAX is the largest entry in the input array NVAL.
*
* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
* where NSMAX is the largest entry in NSVAL.
*
* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
*
* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension
* (NMAX*max(3,NSMAX,NMAX))
*
* RWORK (workspace) DOUBLE PRECISION array, dimension
* (max(NMAX,2*NSMAX))
*
* IWORK (workspace) INTEGER array, dimension (2*NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
INTEGER NTYPES, NTESTS
PARAMETER ( NTYPES = 8, NTESTS = 7 )
INTEGER NBW, NTRAN
PARAMETER ( NBW = 4, NTRAN = 3 )
* ..
* .. Local Scalars ..
LOGICAL TRFCON, ZEROT
CHARACTER DIST, NORM, TRANS, TYPE, XTYPE
CHARACTER*3 PATH
INTEGER I, I1, I2, IKL, IKU, IM, IMAT, IN, INB, INFO,
$ IOFF, IRHS, ITRAN, IZERO, J, K, KL, KOFF, KU,
$ LDA, LDAFAC, LDB, M, MODE, N, NB, NERRS, NFAIL,
$ NIMAT, NKL, NKU, NRHS, NRUN
DOUBLE PRECISION AINVNM, ANORM, ANORMI, ANORMO, CNDNUM, RCOND,
$ RCONDC, RCONDI, RCONDO
* ..
* .. Local Arrays ..
CHARACTER TRANSS( NTRAN )
INTEGER ISEED( 4 ), ISEEDY( 4 ), KLVAL( NBW ),
$ KUVAL( NBW )
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Functions ..
DOUBLE PRECISION DGET06, DLANGB, DLANGE
EXTERNAL DGET06, DLANGB, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, DCOPY, DERRGE, DGBCON,
$ DGBRFS, DGBT01, DGBT02, DGBT05, DGBTRF, DGBTRS,
$ DGET04, DLACPY, DLARHS, DLASET, DLATB4, DLATMS,
$ XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 / ,
$ TRANSS / 'N', 'T', 'C' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'GB'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL DERRGE( PATH, NOUT )
INFOT = 0
CALL XLAENV( 2, 2 )
*
* Initialize the first value for the lower and upper bandwidths.
*
KLVAL( 1 ) = 0
KUVAL( 1 ) = 0
*
* Do for each value of M in MVAL
*
DO 160 IM = 1, NM
M = MVAL( IM )
*
* Set values to use for the lower bandwidth.
*
KLVAL( 2 ) = M + ( M+1 ) / 4
*
* KLVAL( 2 ) = MAX( M-1, 0 )
*
KLVAL( 3 ) = ( 3*M-1 ) / 4
KLVAL( 4 ) = ( M+1 ) / 4
*
* Do for each value of N in NVAL
*
DO 150 IN = 1, NN
N = NVAL( IN )
XTYPE = 'N'
*
* Set values to use for the upper bandwidth.
*
KUVAL( 2 ) = N + ( N+1 ) / 4
*
* KUVAL( 2 ) = MAX( N-1, 0 )
*
KUVAL( 3 ) = ( 3*N-1 ) / 4
KUVAL( 4 ) = ( N+1 ) / 4
*
* Set limits on the number of loop iterations.
*
NKL = MIN( M+1, 4 )
IF( N.EQ.0 )
$ NKL = 2
NKU = MIN( N+1, 4 )
IF( M.EQ.0 )
$ NKU = 2
NIMAT = NTYPES
IF( M.LE.0 .OR. N.LE.0 )
$ NIMAT = 1
*
DO 140 IKL = 1, NKL
*
* Do for KL = 0, (5*M+1)/4, (3M-1)/4, and (M+1)/4. This
* order makes it easier to skip redundant values for small
* values of M.
*
KL = KLVAL( IKL )
DO 130 IKU = 1, NKU
*
* Do for KU = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This
* order makes it easier to skip redundant values for
* small values of N.
*
KU = KUVAL( IKU )
*
* Check that A and AFAC are big enough to generate this
* matrix.
*
LDA = KL + KU + 1
LDAFAC = 2*KL + KU + 1
IF( ( LDA*N ).GT.LA .OR. ( LDAFAC*N ).GT.LAFAC ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
IF( N*( KL+KU+1 ).GT.LA ) THEN
WRITE( NOUT, FMT = 9999 )LA, M, N, KL, KU,
$ N*( KL+KU+1 )
NERRS = NERRS + 1
END IF
IF( N*( 2*KL+KU+1 ).GT.LAFAC ) THEN
WRITE( NOUT, FMT = 9998 )LAFAC, M, N, KL, KU,
$ N*( 2*KL+KU+1 )
NERRS = NERRS + 1
END IF
GO TO 130
END IF
*
DO 120 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 120
*
* Skip types 2, 3, or 4 if the matrix size is too
* small.
*
ZEROT = IMAT.GE.2 .AND. IMAT.LE.4
IF( ZEROT .AND. N.LT.IMAT-1 )
$ GO TO 120
*
IF( .NOT.ZEROT .OR. .NOT.DOTYPE( 1 ) ) THEN
*
* Set up parameters with DLATB4 and generate a
* test matrix with DLATMS.
*
CALL DLATB4( PATH, IMAT, M, N, TYPE, KL, KU,
$ ANORM, MODE, CNDNUM, DIST )
*
KOFF = MAX( 1, KU+2-N )
DO 20 I = 1, KOFF - 1
A( I ) = ZERO
20 CONTINUE
SRNAMT = 'DLATMS'
CALL DLATMS( M, N, DIST, ISEED, TYPE, RWORK,
$ MODE, CNDNUM, ANORM, KL, KU, 'Z',
$ A( KOFF ), LDA, WORK, INFO )
*
* Check the error code from DLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', M,
$ N, KL, KU, -1, IMAT, NFAIL,
$ NERRS, NOUT )
GO TO 120
END IF
ELSE IF( IZERO.GT.0 ) THEN
*
* Use the same matrix for types 3 and 4 as for
* type 2 by copying back the zeroed out column.
*
CALL DCOPY( I2-I1+1, B, 1, A( IOFF+I1 ), 1 )
END IF
*
* For types 2, 3, and 4, zero one or more columns of
* the matrix to test that INFO is returned correctly.
*
IZERO = 0
IF( ZEROT ) THEN
IF( IMAT.EQ.2 ) THEN
IZERO = 1
ELSE IF( IMAT.EQ.3 ) THEN
IZERO = MIN( M, N )
ELSE
IZERO = MIN( M, N ) / 2 + 1
END IF
IOFF = ( IZERO-1 )*LDA
IF( IMAT.LT.4 ) THEN
*
* Store the column to be zeroed out in B.
*
I1 = MAX( 1, KU+2-IZERO )
I2 = MIN( KL+KU+1, KU+1+( M-IZERO ) )
CALL DCOPY( I2-I1+1, A( IOFF+I1 ), 1, B, 1 )
*
DO 30 I = I1, I2
A( IOFF+I ) = ZERO
30 CONTINUE
ELSE
DO 50 J = IZERO, N
DO 40 I = MAX( 1, KU+2-J ),
$ MIN( KL+KU+1, KU+1+( M-J ) )
A( IOFF+I ) = ZERO
40 CONTINUE
IOFF = IOFF + LDA
50 CONTINUE
END IF
END IF
*
* These lines, if used in place of the calls in the
* loop over INB, cause the code to bomb on a Sun
* SPARCstation.
*
* ANORMO = DLANGB( 'O', N, KL, KU, A, LDA, RWORK )
* ANORMI = DLANGB( 'I', N, KL, KU, A, LDA, RWORK )
*
* Do for each blocksize in NBVAL
*
DO 110 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
*
* Compute the LU factorization of the band matrix.
*
IF( M.GT.0 .AND. N.GT.0 )
$ CALL DLACPY( 'Full', KL+KU+1, N, A, LDA,
$ AFAC( KL+1 ), LDAFAC )
SRNAMT = 'DGBTRF'
CALL DGBTRF( M, N, KL, KU, AFAC, LDAFAC, IWORK,
$ INFO )
*
* Check error code from DGBTRF.
*
IF( INFO.NE.IZERO )
$ CALL ALAERH( PATH, 'DGBTRF', INFO, IZERO,
$ ' ', M, N, KL, KU, NB, IMAT,
$ NFAIL, NERRS, NOUT )
TRFCON = .FALSE.
*
*+ TEST 1
* Reconstruct matrix from factors and compute
* residual.
*
CALL DGBT01( M, N, KL, KU, A, LDA, AFAC, LDAFAC,
$ IWORK, WORK, RESULT( 1 ) )
*
* Print information about the tests so far that
* did not pass the threshold.
*
IF( RESULT( 1 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9997 )M, N, KL, KU, NB,
$ IMAT, 1, RESULT( 1 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
*
* Skip the remaining tests if this is not the
* first block size or if M .ne. N.
*
IF( INB.GT.1 .OR. M.NE.N )
$ GO TO 110
*
ANORMO = DLANGB( 'O', N, KL, KU, A, LDA, RWORK )
ANORMI = DLANGB( 'I', N, KL, KU, A, LDA, RWORK )
*
IF( INFO.EQ.0 ) THEN
*
* Form the inverse of A so we can get a good
* estimate of CNDNUM = norm(A) * norm(inv(A)).
*
LDB = MAX( 1, N )
CALL DLASET( 'Full', N, N, ZERO, ONE, WORK,
$ LDB )
SRNAMT = 'DGBTRS'
CALL DGBTRS( 'No transpose', N, KL, KU, N,
$ AFAC, LDAFAC, IWORK, WORK, LDB,
$ INFO )
*
* Compute the 1-norm condition number of A.
*
AINVNM = DLANGE( 'O', N, N, WORK, LDB,
$ RWORK )
IF( ANORMO.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDO = ONE
ELSE
RCONDO = ( ONE / ANORMO ) / AINVNM
END IF
*
* Compute the infinity-norm condition number of
* A.
*
AINVNM = DLANGE( 'I', N, N, WORK, LDB,
$ RWORK )
IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDI = ONE
ELSE
RCONDI = ( ONE / ANORMI ) / AINVNM
END IF
ELSE
*
* Do only the condition estimate if INFO.NE.0.
*
TRFCON = .TRUE.
RCONDO = ZERO
RCONDI = ZERO
END IF
*
* Skip the solve tests if the matrix is singular.
*
IF( TRFCON )
$ GO TO 90
*
DO 80 IRHS = 1, NNS
NRHS = NSVAL( IRHS )
XTYPE = 'N'
*
DO 70 ITRAN = 1, NTRAN
TRANS = TRANSS( ITRAN )
IF( ITRAN.EQ.1 ) THEN
RCONDC = RCONDO
NORM = 'O'
ELSE
RCONDC = RCONDI
NORM = 'I'
END IF
*
*+ TEST 2:
* Solve and compute residual for A * X = B.
*
SRNAMT = 'DLARHS'
CALL DLARHS( PATH, XTYPE, ' ', TRANS, N,
$ N, KL, KU, NRHS, A, LDA,
$ XACT, LDB, B, LDB, ISEED,
$ INFO )
XTYPE = 'C'
CALL DLACPY( 'Full', N, NRHS, B, LDB, X,
$ LDB )
*
SRNAMT = 'DGBTRS'
CALL DGBTRS( TRANS, N, KL, KU, NRHS, AFAC,
$ LDAFAC, IWORK, X, LDB, INFO )
*
* Check error code from DGBTRS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DGBTRS', INFO, 0,
$ TRANS, N, N, KL, KU, -1,
$ IMAT, NFAIL, NERRS, NOUT )
*
CALL DLACPY( 'Full', N, NRHS, B, LDB,
$ WORK, LDB )
CALL DGBT02( TRANS, M, N, KL, KU, NRHS, A,
$ LDA, X, LDB, WORK, LDB,
$ RESULT( 2 ) )
*
*+ TEST 3:
* Check solution from generated exact
* solution.
*
CALL DGET04( N, NRHS, X, LDB, XACT, LDB,
$ RCONDC, RESULT( 3 ) )
*
*+ TESTS 4, 5, 6:
* Use iterative refinement to improve the
* solution.
*
SRNAMT = 'DGBRFS'
CALL DGBRFS( TRANS, N, KL, KU, NRHS, A,
$ LDA, AFAC, LDAFAC, IWORK, B,
$ LDB, X, LDB, RWORK,
$ RWORK( NRHS+1 ), WORK,
$ IWORK( N+1 ), INFO )
*
* Check error code from DGBRFS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DGBRFS', INFO, 0,
$ TRANS, N, N, KL, KU, NRHS,
$ IMAT, NFAIL, NERRS, NOUT )
*
CALL DGET04( N, NRHS, X, LDB, XACT, LDB,
$ RCONDC, RESULT( 4 ) )
CALL DGBT05( TRANS, N, KL, KU, NRHS, A,
$ LDA, B, LDB, X, LDB, XACT,
$ LDB, RWORK, RWORK( NRHS+1 ),
$ RESULT( 5 ) )
DO 60 K = 2, 6
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9996 )TRANS, N,
$ KL, KU, NRHS, IMAT, K,
$ RESULT( K )
NFAIL = NFAIL + 1
END IF
60 CONTINUE
NRUN = NRUN + 5
70 CONTINUE
80 CONTINUE
*
*+ TEST 7:
* Get an estimate of RCOND = 1/CNDNUM.
*
90 CONTINUE
DO 100 ITRAN = 1, 2
IF( ITRAN.EQ.1 ) THEN
ANORM = ANORMO
RCONDC = RCONDO
NORM = 'O'
ELSE
ANORM = ANORMI
RCONDC = RCONDI
NORM = 'I'
END IF
SRNAMT = 'DGBCON'
CALL DGBCON( NORM, N, KL, KU, AFAC, LDAFAC,
$ IWORK, ANORM, RCOND, WORK,
$ IWORK( N+1 ), INFO )
*
* Check error code from DGBCON.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DGBCON', INFO, 0,
$ NORM, N, N, KL, KU, -1, IMAT,
$ NFAIL, NERRS, NOUT )
*
RESULT( 7 ) = DGET06( RCOND, RCONDC )
*
* Print information about the tests that did
* not pass the threshold.
*
IF( RESULT( 7 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9995 )NORM, N, KL, KU,
$ IMAT, 7, RESULT( 7 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
100 CONTINUE
*
110 CONTINUE
120 CONTINUE
130 CONTINUE
140 CONTINUE
150 CONTINUE
160 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' *** In DCHKGB, LA=', I5, ' is too small for M=', I5,
$ ', N=', I5, ', KL=', I4, ', KU=', I4,
$ / ' ==> Increase LA to at least ', I5 )
9998 FORMAT( ' *** In DCHKGB, LAFAC=', I5, ' is too small for M=', I5,
$ ', N=', I5, ', KL=', I4, ', KU=', I4,
$ / ' ==> Increase LAFAC to at least ', I5 )
9997 FORMAT( ' M =', I5, ', N =', I5, ', KL=', I5, ', KU=', I5,
$ ', NB =', I4, ', type ', I1, ', test(', I1, ')=', G12.5 )
9996 FORMAT( ' TRANS=''', A1, ''', N=', I5, ', KL=', I5, ', KU=', I5,
$ ', NRHS=', I3, ', type ', I1, ', test(', I1, ')=', G12.5 )
9995 FORMAT( ' NORM =''', A1, ''', N=', I5, ', KL=', I5, ', KU=', I5,
$ ',', 10X, ' type ', I1, ', test(', I1, ')=', G12.5 )
*
RETURN
*
* End of DCHKGB
*
END
SUBROUTINE DCHKGE( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS,
$ NSVAL, THRESH, TSTERR, NMAX, A, AFAC, AINV, B,
$ X, XACT, WORK, RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* January 2007
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NM, NMAX, NN, NNB, NNS, NOUT
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ),
$ NVAL( * )
DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
$ RWORK( * ), WORK( * ), X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* DCHKGE tests DGETRF, -TRI, -TRS, -RFS, and -CON.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NNB (input) INTEGER
* The number of values of NB contained in the vector NBVAL.
*
* NBVAL (input) INTEGER array, dimension (NBVAL)
* The values of the blocksize NB.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for M or N, used in dimensioning
* the work arrays.
*
* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
* where NSMAX is the largest entry in NSVAL.
*
* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
*
* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension
* (NMAX*max(3,NSMAX))
*
* RWORK (workspace) DOUBLE PRECISION array, dimension
* (max(2*NMAX,2*NSMAX+NWORK))
*
* IWORK (workspace) INTEGER array, dimension (2*NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
INTEGER NTYPES
PARAMETER ( NTYPES = 11 )
INTEGER NTESTS
PARAMETER ( NTESTS = 8 )
INTEGER NTRAN
PARAMETER ( NTRAN = 3 )
* ..
* .. Local Scalars ..
LOGICAL TRFCON, ZEROT
CHARACTER DIST, NORM, TRANS, TYPE, XTYPE
CHARACTER*3 PATH
INTEGER I, IM, IMAT, IN, INB, INFO, IOFF, IRHS, ITRAN,
$ IZERO, K, KL, KU, LDA, LWORK, M, MODE, N, NB,
$ NERRS, NFAIL, NIMAT, NRHS, NRUN, NT
DOUBLE PRECISION AINVNM, ANORM, ANORMI, ANORMO, CNDNUM, DUMMY,
$ RCOND, RCONDC, RCONDI, RCONDO
* ..
* .. Local Arrays ..
CHARACTER TRANSS( NTRAN )
INTEGER ISEED( 4 ), ISEEDY( 4 )
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Functions ..
DOUBLE PRECISION DGET06, DLANGE
EXTERNAL DGET06, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, DERRGE, DGECON, DGERFS,
$ DGET01, DGET02, DGET03, DGET04, DGET07, DGETRF,
$ DGETRI, DGETRS, DLACPY, DLARHS, DLASET, DLATB4,
$ DLATMS, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 / ,
$ TRANSS / 'N', 'T', 'C' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'GE'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
CALL XLAENV( 1, 1 )
IF( TSTERR )
$ CALL DERRGE( PATH, NOUT )
INFOT = 0
CALL XLAENV( 2, 2 )
*
* Do for each value of M in MVAL
*
DO 120 IM = 1, NM
M = MVAL( IM )
LDA = MAX( 1, M )
*
* Do for each value of N in NVAL
*
DO 110 IN = 1, NN
N = NVAL( IN )
XTYPE = 'N'
NIMAT = NTYPES
IF( M.LE.0 .OR. N.LE.0 )
$ NIMAT = 1
*
DO 100 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 100
*
* Skip types 5, 6, or 7 if the matrix size is too small.
*
ZEROT = IMAT.GE.5 .AND. IMAT.LE.7
IF( ZEROT .AND. N.LT.IMAT-4 )
$ GO TO 100
*
* Set up parameters with DLATB4 and generate a test matrix
* with DLATMS.
*
CALL DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
*
SRNAMT = 'DLATMS'
CALL DLATMS( M, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, 'No packing', A, LDA,
$ WORK, INFO )
*
* Check error code from DLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', M, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 100
END IF
*
* For types 5-7, zero one or more columns of the matrix to
* test that INFO is returned correctly.
*
IF( ZEROT ) THEN
IF( IMAT.EQ.5 ) THEN
IZERO = 1
ELSE IF( IMAT.EQ.6 ) THEN
IZERO = MIN( M, N )
ELSE
IZERO = MIN( M, N ) / 2 + 1
END IF
IOFF = ( IZERO-1 )*LDA
IF( IMAT.LT.7 ) THEN
DO 20 I = 1, M
A( IOFF+I ) = ZERO
20 CONTINUE
ELSE
CALL DLASET( 'Full', M, N-IZERO+1, ZERO, ZERO,
$ A( IOFF+1 ), LDA )
END IF
ELSE
IZERO = 0
END IF
*
* These lines, if used in place of the calls in the DO 60
* loop, cause the code to bomb on a Sun SPARCstation.
*
* ANORMO = DLANGE( 'O', M, N, A, LDA, RWORK )
* ANORMI = DLANGE( 'I', M, N, A, LDA, RWORK )
*
* Do for each blocksize in NBVAL
*
DO 90 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
*
* Compute the LU factorization of the matrix.
*
CALL DLACPY( 'Full', M, N, A, LDA, AFAC, LDA )
SRNAMT = 'DGETRF'
CALL DGETRF( M, N, AFAC, LDA, IWORK, INFO )
*
* Check error code from DGETRF.
*
IF( INFO.NE.IZERO )
$ CALL ALAERH( PATH, 'DGETRF', INFO, IZERO, ' ', M,
$ N, -1, -1, NB, IMAT, NFAIL, NERRS,
$ NOUT )
TRFCON = .FALSE.
*
*+ TEST 1
* Reconstruct matrix from factors and compute residual.
*
CALL DLACPY( 'Full', M, N, AFAC, LDA, AINV, LDA )
CALL DGET01( M, N, A, LDA, AINV, LDA, IWORK, RWORK,
$ RESULT( 1 ) )
NT = 1
*
*+ TEST 2
* Form the inverse if the factorization was successful
* and compute the residual.
*
IF( M.EQ.N .AND. INFO.EQ.0 ) THEN
CALL DLACPY( 'Full', N, N, AFAC, LDA, AINV, LDA )
SRNAMT = 'DGETRI'
NRHS = NSVAL( 1 )
LWORK = NMAX*MAX( 3, NRHS )
CALL DGETRI( N, AINV, LDA, IWORK, WORK, LWORK,
$ INFO )
*
* Check error code from DGETRI.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DGETRI', INFO, 0, ' ', N, N,
$ -1, -1, NB, IMAT, NFAIL, NERRS,
$ NOUT )
*
* Compute the residual for the matrix times its
* inverse. Also compute the 1-norm condition number
* of A.
*
CALL DGET03( N, A, LDA, AINV, LDA, WORK, LDA,
$ RWORK, RCONDO, RESULT( 2 ) )
ANORMO = DLANGE( 'O', M, N, A, LDA, RWORK )
*
* Compute the infinity-norm condition number of A.
*
ANORMI = DLANGE( 'I', M, N, A, LDA, RWORK )
AINVNM = DLANGE( 'I', N, N, AINV, LDA, RWORK )
IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDI = ONE
ELSE
RCONDI = ( ONE / ANORMI ) / AINVNM
END IF
NT = 2
ELSE
*
* Do only the condition estimate if INFO > 0.
*
TRFCON = .TRUE.
ANORMO = DLANGE( 'O', M, N, A, LDA, RWORK )
ANORMI = DLANGE( 'I', M, N, A, LDA, RWORK )
RCONDO = ZERO
RCONDI = ZERO
END IF
*
* Print information about the tests so far that did not
* pass the threshold.
*
DO 30 K = 1, NT
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )M, N, NB, IMAT, K,
$ RESULT( K )
NFAIL = NFAIL + 1
END IF
30 CONTINUE
NRUN = NRUN + NT
*
* Skip the remaining tests if this is not the first
* block size or if M .ne. N. Skip the solve tests if
* the matrix is singular.
*
IF( INB.GT.1 .OR. M.NE.N )
$ GO TO 90
IF( TRFCON )
$ GO TO 70
*
DO 60 IRHS = 1, NNS
NRHS = NSVAL( IRHS )
XTYPE = 'N'
*
DO 50 ITRAN = 1, NTRAN
TRANS = TRANSS( ITRAN )
IF( ITRAN.EQ.1 ) THEN
RCONDC = RCONDO
ELSE
RCONDC = RCONDI
END IF
*
*+ TEST 3
* Solve and compute residual for A * X = B.
*
SRNAMT = 'DLARHS'
CALL DLARHS( PATH, XTYPE, ' ', TRANS, N, N, KL,
$ KU, NRHS, A, LDA, XACT, LDA, B,
$ LDA, ISEED, INFO )
XTYPE = 'C'
*
CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
SRNAMT = 'DGETRS'
CALL DGETRS( TRANS, N, NRHS, AFAC, LDA, IWORK,
$ X, LDA, INFO )
*
* Check error code from DGETRS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DGETRS', INFO, 0, TRANS,
$ N, N, -1, -1, NRHS, IMAT, NFAIL,
$ NERRS, NOUT )
*
CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK,
$ LDA )
CALL DGET02( TRANS, N, N, NRHS, A, LDA, X, LDA,
$ WORK, LDA, RWORK, RESULT( 3 ) )
*
*+ TEST 4
* Check solution from generated exact solution.
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 4 ) )
*
*+ TESTS 5, 6, and 7
* Use iterative refinement to improve the
* solution.
*
SRNAMT = 'DGERFS'
CALL DGERFS( TRANS, N, NRHS, A, LDA, AFAC, LDA,
$ IWORK, B, LDA, X, LDA, RWORK,
$ RWORK( NRHS+1 ), WORK,
$ IWORK( N+1 ), INFO )
*
* Check error code from DGERFS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DGERFS', INFO, 0, TRANS,
$ N, N, -1, -1, NRHS, IMAT, NFAIL,
$ NERRS, NOUT )
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 5 ) )
CALL DGET07( TRANS, N, NRHS, A, LDA, B, LDA, X,
$ LDA, XACT, LDA, RWORK,
$ RWORK( NRHS+1 ), RESULT( 6 ) )
*
* Print information about the tests that did not
* pass the threshold.
*
DO 40 K = 3, 7
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )TRANS, N, NRHS,
$ IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
40 CONTINUE
NRUN = NRUN + 5
50 CONTINUE
60 CONTINUE
*
*+ TEST 8
* Get an estimate of RCOND = 1/CNDNUM.
*
70 CONTINUE
DO 80 ITRAN = 1, 2
IF( ITRAN.EQ.1 ) THEN
ANORM = ANORMO
RCONDC = RCONDO
NORM = 'O'
ELSE
ANORM = ANORMI
RCONDC = RCONDI
NORM = 'I'
END IF
SRNAMT = 'DGECON'
CALL DGECON( NORM, N, AFAC, LDA, ANORM, RCOND,
$ WORK, IWORK( N+1 ), INFO )
*
* Check error code from DGECON.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DGECON', INFO, 0, NORM, N,
$ N, -1, -1, -1, IMAT, NFAIL, NERRS,
$ NOUT )
*
* This line is needed on a Sun SPARCstation.
*
DUMMY = RCOND
*
RESULT( 8 ) = DGET06( RCOND, RCONDC )
*
* Print information about the tests that did not pass
* the threshold.
*
IF( RESULT( 8 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9997 )NORM, N, IMAT, 8,
$ RESULT( 8 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
80 CONTINUE
90 CONTINUE
100 CONTINUE
110 CONTINUE
120 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' M = ', I5, ', N =', I5, ', NB =', I4, ', type ', I2,
$ ', test(', I2, ') =', G12.5 )
9998 FORMAT( ' TRANS=''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
$ I2, ', test(', I2, ') =', G12.5 )
9997 FORMAT( ' NORM =''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
$ ', test(', I2, ') =', G12.5 )
RETURN
*
* End of DCHKGE
*
END
SUBROUTINE DCHKGT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
$ A, AF, B, X, XACT, WORK, RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NN, NNS, NOUT
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
DOUBLE PRECISION A( * ), AF( * ), B( * ), RWORK( * ), WORK( * ),
$ X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* DCHKGT tests DGTTRF, -TRS, -RFS, and -CON
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* A (workspace) DOUBLE PRECISION array, dimension (NMAX*4)
*
* AF (workspace) DOUBLE PRECISION array, dimension (NMAX*4)
*
* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
* where NSMAX is the largest entry in NSVAL.
*
* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
*
* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension
* (NMAX*max(3,NSMAX))
*
* RWORK (workspace) DOUBLE PRECISION array, dimension
* (max(NMAX,2*NSMAX))
*
* IWORK (workspace) INTEGER array, dimension (2*NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
INTEGER NTYPES
PARAMETER ( NTYPES = 12 )
INTEGER NTESTS
PARAMETER ( NTESTS = 7 )
* ..
* .. Local Scalars ..
LOGICAL TRFCON, ZEROT
CHARACTER DIST, NORM, TRANS, TYPE
CHARACTER*3 PATH
INTEGER I, IMAT, IN, INFO, IRHS, ITRAN, IX, IZERO, J,
$ K, KL, KOFF, KU, LDA, M, MODE, N, NERRS, NFAIL,
$ NIMAT, NRHS, NRUN
DOUBLE PRECISION AINVNM, ANORM, COND, RCOND, RCONDC, RCONDI,
$ RCONDO
* ..
* .. Local Arrays ..
CHARACTER TRANSS( 3 )
INTEGER ISEED( 4 ), ISEEDY( 4 )
DOUBLE PRECISION RESULT( NTESTS ), Z( 3 )
* ..
* .. External Functions ..
DOUBLE PRECISION DASUM, DGET06, DLANGT
EXTERNAL DASUM, DGET06, DLANGT
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, DCOPY, DERRGE, DGET04,
$ DGTCON, DGTRFS, DGTT01, DGTT02, DGTT05, DGTTRF,
$ DGTTRS, DLACPY, DLAGTM, DLARNV, DLATB4, DLATMS,
$ DSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 0, 0, 0, 1 / , TRANSS / 'N', 'T',
$ 'C' /
* ..
* .. Executable Statements ..
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'GT'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL DERRGE( PATH, NOUT )
INFOT = 0
*
DO 110 IN = 1, NN
*
* Do for each value of N in NVAL.
*
N = NVAL( IN )
M = MAX( N-1, 0 )
LDA = MAX( 1, N )
NIMAT = NTYPES
IF( N.LE.0 )
$ NIMAT = 1
*
DO 100 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 100
*
* Set up parameters with DLATB4.
*
CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ COND, DIST )
*
ZEROT = IMAT.GE.8 .AND. IMAT.LE.10
IF( IMAT.LE.6 ) THEN
*
* Types 1-6: generate matrices of known condition number.
*
KOFF = MAX( 2-KU, 3-MAX( 1, N ) )
SRNAMT = 'DLATMS'
CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, COND,
$ ANORM, KL, KU, 'Z', AF( KOFF ), 3, WORK,
$ INFO )
*
* Check the error code from DLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', N, N, KL,
$ KU, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 100
END IF
IZERO = 0
*
IF( N.GT.1 ) THEN
CALL DCOPY( N-1, AF( 4 ), 3, A, 1 )
CALL DCOPY( N-1, AF( 3 ), 3, A( N+M+1 ), 1 )
END IF
CALL DCOPY( N, AF( 2 ), 3, A( M+1 ), 1 )
ELSE
*
* Types 7-12: generate tridiagonal matrices with
* unknown condition numbers.
*
IF( .NOT.ZEROT .OR. .NOT.DOTYPE( 7 ) ) THEN
*
* Generate a matrix with elements from [-1,1].
*
CALL DLARNV( 2, ISEED, N+2*M, A )
IF( ANORM.NE.ONE )
$ CALL DSCAL( N+2*M, ANORM, A, 1 )
ELSE IF( IZERO.GT.0 ) THEN
*
* Reuse the last matrix by copying back the zeroed out
* elements.
*
IF( IZERO.EQ.1 ) THEN
A( N ) = Z( 2 )
IF( N.GT.1 )
$ A( 1 ) = Z( 3 )
ELSE IF( IZERO.EQ.N ) THEN
A( 3*N-2 ) = Z( 1 )
A( 2*N-1 ) = Z( 2 )
ELSE
A( 2*N-2+IZERO ) = Z( 1 )
A( N-1+IZERO ) = Z( 2 )
A( IZERO ) = Z( 3 )
END IF
END IF
*
* If IMAT > 7, set one column of the matrix to 0.
*
IF( .NOT.ZEROT ) THEN
IZERO = 0
ELSE IF( IMAT.EQ.8 ) THEN
IZERO = 1
Z( 2 ) = A( N )
A( N ) = ZERO
IF( N.GT.1 ) THEN
Z( 3 ) = A( 1 )
A( 1 ) = ZERO
END IF
ELSE IF( IMAT.EQ.9 ) THEN
IZERO = N
Z( 1 ) = A( 3*N-2 )
Z( 2 ) = A( 2*N-1 )
A( 3*N-2 ) = ZERO
A( 2*N-1 ) = ZERO
ELSE
IZERO = ( N+1 ) / 2
DO 20 I = IZERO, N - 1
A( 2*N-2+I ) = ZERO
A( N-1+I ) = ZERO
A( I ) = ZERO
20 CONTINUE
A( 3*N-2 ) = ZERO
A( 2*N-1 ) = ZERO
END IF
END IF
*
*+ TEST 1
* Factor A as L*U and compute the ratio
* norm(L*U - A) / (n * norm(A) * EPS )
*
CALL DCOPY( N+2*M, A, 1, AF, 1 )
SRNAMT = 'DGTTRF'
CALL DGTTRF( N, AF, AF( M+1 ), AF( N+M+1 ), AF( N+2*M+1 ),
$ IWORK, INFO )
*
* Check error code from DGTTRF.
*
IF( INFO.NE.IZERO )
$ CALL ALAERH( PATH, 'DGTTRF', INFO, IZERO, ' ', N, N, 1,
$ 1, -1, IMAT, NFAIL, NERRS, NOUT )
TRFCON = INFO.NE.0
*
CALL DGTT01( N, A, A( M+1 ), A( N+M+1 ), AF, AF( M+1 ),
$ AF( N+M+1 ), AF( N+2*M+1 ), IWORK, WORK, LDA,
$ RWORK, RESULT( 1 ) )
*
* Print the test ratio if it is .GE. THRESH.
*
IF( RESULT( 1 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )N, IMAT, 1, RESULT( 1 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
*
DO 50 ITRAN = 1, 2
TRANS = TRANSS( ITRAN )
IF( ITRAN.EQ.1 ) THEN
NORM = 'O'
ELSE
NORM = 'I'
END IF
ANORM = DLANGT( NORM, N, A, A( M+1 ), A( N+M+1 ) )
*
IF( .NOT.TRFCON ) THEN
*
* Use DGTTRS to solve for one column at a time of inv(A)
* or inv(A^T), computing the maximum column sum as we
* go.
*
AINVNM = ZERO
DO 40 I = 1, N
DO 30 J = 1, N
X( J ) = ZERO
30 CONTINUE
X( I ) = ONE
CALL DGTTRS( TRANS, N, 1, AF, AF( M+1 ),
$ AF( N+M+1 ), AF( N+2*M+1 ), IWORK, X,
$ LDA, INFO )
AINVNM = MAX( AINVNM, DASUM( N, X, 1 ) )
40 CONTINUE
*
* Compute RCONDC = 1 / (norm(A) * norm(inv(A))
*
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDC = ONE
ELSE
RCONDC = ( ONE / ANORM ) / AINVNM
END IF
IF( ITRAN.EQ.1 ) THEN
RCONDO = RCONDC
ELSE
RCONDI = RCONDC
END IF
ELSE
RCONDC = ZERO
END IF
*
*+ TEST 7
* Estimate the reciprocal of the condition number of the
* matrix.
*
SRNAMT = 'DGTCON'
CALL DGTCON( NORM, N, AF, AF( M+1 ), AF( N+M+1 ),
$ AF( N+2*M+1 ), IWORK, ANORM, RCOND, WORK,
$ IWORK( N+1 ), INFO )
*
* Check error code from DGTCON.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DGTCON', INFO, 0, NORM, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
RESULT( 7 ) = DGET06( RCOND, RCONDC )
*
* Print the test ratio if it is .GE. THRESH.
*
IF( RESULT( 7 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9997 )NORM, N, IMAT, 7,
$ RESULT( 7 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
50 CONTINUE
*
* Skip the remaining tests if the matrix is singular.
*
IF( TRFCON )
$ GO TO 100
*
DO 90 IRHS = 1, NNS
NRHS = NSVAL( IRHS )
*
* Generate NRHS random solution vectors.
*
IX = 1
DO 60 J = 1, NRHS
CALL DLARNV( 2, ISEED, N, XACT( IX ) )
IX = IX + LDA
60 CONTINUE
*
DO 80 ITRAN = 1, 3
TRANS = TRANSS( ITRAN )
IF( ITRAN.EQ.1 ) THEN
RCONDC = RCONDO
ELSE
RCONDC = RCONDI
END IF
*
* Set the right hand side.
*
CALL DLAGTM( TRANS, N, NRHS, ONE, A, A( M+1 ),
$ A( N+M+1 ), XACT, LDA, ZERO, B, LDA )
*
*+ TEST 2
* Solve op(A) * X = B and compute the residual.
*
CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
SRNAMT = 'DGTTRS'
CALL DGTTRS( TRANS, N, NRHS, AF, AF( M+1 ),
$ AF( N+M+1 ), AF( N+2*M+1 ), IWORK, X,
$ LDA, INFO )
*
* Check error code from DGTTRS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DGTTRS', INFO, 0, TRANS, N, N,
$ -1, -1, NRHS, IMAT, NFAIL, NERRS,
$ NOUT )
*
CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
CALL DGTT02( TRANS, N, NRHS, A, A( M+1 ), A( N+M+1 ),
$ X, LDA, WORK, LDA, RWORK, RESULT( 2 ) )
*
*+ TEST 3
* Check solution from generated exact solution.
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
*
*+ TESTS 4, 5, and 6
* Use iterative refinement to improve the solution.
*
SRNAMT = 'DGTRFS'
CALL DGTRFS( TRANS, N, NRHS, A, A( M+1 ), A( N+M+1 ),
$ AF, AF( M+1 ), AF( N+M+1 ),
$ AF( N+2*M+1 ), IWORK, B, LDA, X, LDA,
$ RWORK, RWORK( NRHS+1 ), WORK,
$ IWORK( N+1 ), INFO )
*
* Check error code from DGTRFS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DGTRFS', INFO, 0, TRANS, N, N,
$ -1, -1, NRHS, IMAT, NFAIL, NERRS,
$ NOUT )
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 4 ) )
CALL DGTT05( TRANS, N, NRHS, A, A( M+1 ), A( N+M+1 ),
$ B, LDA, X, LDA, XACT, LDA, RWORK,
$ RWORK( NRHS+1 ), RESULT( 5 ) )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 70 K = 2, 6
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )TRANS, N, NRHS, IMAT,
$ K, RESULT( K )
NFAIL = NFAIL + 1
END IF
70 CONTINUE
NRUN = NRUN + 5
80 CONTINUE
90 CONTINUE
*
100 CONTINUE
110 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( 12X, 'N =', I5, ',', 10X, ' type ', I2, ', test(', I2,
$ ') = ', G12.5 )
9998 FORMAT( ' TRANS=''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
$ I2, ', test(', I2, ') = ', G12.5 )
9997 FORMAT( ' NORM =''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
$ ', test(', I2, ') = ', G12.5 )
RETURN
*
* End of DCHKGT
*
END
SUBROUTINE DCHKLQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
$ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AL, AC,
$ B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NM, NMAX, NN, NNB, NOUT, NRHS
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
$ NXVAL( * )
DOUBLE PRECISION A( * ), AC( * ), AF( * ), AL( * ), AQ( * ),
$ B( * ), RWORK( * ), TAU( * ), WORK( * ),
$ X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* DCHKLQ tests DGELQF, DORGLQ and DORMLQ.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* NRHS (input) INTEGER
* The number of right hand side vectors to be generated for
* each linear system.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for M or N, used in dimensioning
* the work arrays.
*
* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AQ (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AL (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* TAU (workspace) DOUBLE PRECISION array, dimension (NMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTESTS
PARAMETER ( NTESTS = 7 )
INTEGER NTYPES
PARAMETER ( NTYPES = 8 )
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
CHARACTER DIST, TYPE
CHARACTER*3 PATH
INTEGER I, IK, IM, IMAT, IN, INB, INFO, K, KL, KU, LDA,
$ LWORK, M, MINMN, MODE, N, NB, NERRS, NFAIL, NK,
$ NRUN, NT, NX
DOUBLE PRECISION ANORM, CNDNUM
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 )
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, DERRLQ, DGELQS, DGET02,
$ DLACPY, DLARHS, DLATB4, DLATMS, DLQT01, DLQT02,
$ DLQT03, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'LQ'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL DERRLQ( PATH, NOUT )
INFOT = 0
CALL XLAENV( 2, 2 )
*
LDA = NMAX
LWORK = NMAX*MAX( NMAX, NRHS )
*
* Do for each value of M in MVAL.
*
DO 70 IM = 1, NM
M = MVAL( IM )
*
* Do for each value of N in NVAL.
*
DO 60 IN = 1, NN
N = NVAL( IN )
MINMN = MIN( M, N )
DO 50 IMAT = 1, NTYPES
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 50
*
* Set up parameters with DLATB4 and generate a test matrix
* with DLATMS.
*
CALL DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
*
SRNAMT = 'DLATMS'
CALL DLATMS( M, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, 'No packing', A, LDA,
$ WORK, INFO )
*
* Check error code from DLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', M, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 50
END IF
*
* Set some values for K: the first value must be MINMN,
* corresponding to the call of DLQT01; other values are
* used in the calls of DLQT02, and must not exceed MINMN.
*
KVAL( 1 ) = MINMN
KVAL( 2 ) = 0
KVAL( 3 ) = 1
KVAL( 4 ) = MINMN / 2
IF( MINMN.EQ.0 ) THEN
NK = 1
ELSE IF( MINMN.EQ.1 ) THEN
NK = 2
ELSE IF( MINMN.LE.3 ) THEN
NK = 3
ELSE
NK = 4
END IF
*
* Do for each value of K in KVAL
*
DO 40 IK = 1, NK
K = KVAL( IK )
*
* Do for each pair of values (NB,NX) in NBVAL and NXVAL.
*
DO 30 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
NT = 2
IF( IK.EQ.1 ) THEN
*
* Test DGELQF
*
CALL DLQT01( M, N, A, AF, AQ, AL, LDA, TAU,
$ WORK, LWORK, RWORK, RESULT( 1 ) )
ELSE IF( M.LE.N ) THEN
*
* Test DORGLQ, using factorization
* returned by DLQT01
*
CALL DLQT02( M, N, K, A, AF, AQ, AL, LDA, TAU,
$ WORK, LWORK, RWORK, RESULT( 1 ) )
ELSE
RESULT( 1 ) = ZERO
RESULT( 2 ) = ZERO
END IF
IF( M.GE.K ) THEN
*
* Test DORMLQ, using factorization returned
* by DLQT01
*
CALL DLQT03( M, N, K, AF, AC, AL, AQ, LDA, TAU,
$ WORK, LWORK, RWORK, RESULT( 3 ) )
NT = NT + 4
*
* If M>=N and K=N, call DGELQS to solve a system
* with NRHS right hand sides and compute the
* residual.
*
IF( K.EQ.M .AND. INB.EQ.1 ) THEN
*
* Generate a solution and set the right
* hand side.
*
SRNAMT = 'DLARHS'
CALL DLARHS( PATH, 'New', 'Full',
$ 'No transpose', M, N, 0, 0,
$ NRHS, A, LDA, XACT, LDA, B, LDA,
$ ISEED, INFO )
*
CALL DLACPY( 'Full', M, NRHS, B, LDA, X,
$ LDA )
SRNAMT = 'DGELQS'
CALL DGELQS( M, N, NRHS, AF, LDA, TAU, X,
$ LDA, WORK, LWORK, INFO )
*
* Check error code from DGELQS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DGELQS', INFO, 0, ' ',
$ M, N, NRHS, -1, NB, IMAT,
$ NFAIL, NERRS, NOUT )
*
CALL DGET02( 'No transpose', M, N, NRHS, A,
$ LDA, X, LDA, B, LDA, RWORK,
$ RESULT( 7 ) )
NT = NT + 1
ELSE
RESULT( 7 ) = ZERO
END IF
ELSE
RESULT( 3 ) = ZERO
RESULT( 4 ) = ZERO
RESULT( 5 ) = ZERO
RESULT( 6 ) = ZERO
END IF
*
* Print information about the tests that did not
* pass the threshold.
*
DO 20 I = 1, NT
IF( RESULT( I ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )M, N, K, NB, NX,
$ IMAT, I, RESULT( I )
NFAIL = NFAIL + 1
END IF
20 CONTINUE
NRUN = NRUN + NT
30 CONTINUE
40 CONTINUE
50 CONTINUE
60 CONTINUE
70 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' M=', I5, ', N=', I5, ', K=', I5, ', NB=', I4, ', NX=',
$ I5, ', type ', I2, ', test(', I2, ')=', G12.5 )
RETURN
*
* End of DCHKLQ
*
END
SUBROUTINE DCHKPB( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
$ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
$ XACT, WORK, RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NMAX, NN, NNB, NNS, NOUT
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
$ RWORK( * ), WORK( * ), X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* DCHKPB tests DPBTRF, -TRS, -RFS, and -CON.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* NNB (input) INTEGER
* The number of values of NB contained in the vector NBVAL.
*
* NBVAL (input) INTEGER array, dimension (NBVAL)
* The values of the blocksize NB.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for N, used in dimensioning the
* work arrays.
*
* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
* where NSMAX is the largest entry in NSVAL.
*
* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
*
* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension
* (NMAX*max(3,NSMAX))
*
* RWORK (workspace) DOUBLE PRECISION array, dimension
* (max(NMAX,2*NSMAX))
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
INTEGER NTYPES, NTESTS
PARAMETER ( NTYPES = 8, NTESTS = 7 )
INTEGER NBW
PARAMETER ( NBW = 4 )
* ..
* .. Local Scalars ..
LOGICAL ZEROT
CHARACTER DIST, PACKIT, TYPE, UPLO, XTYPE
CHARACTER*3 PATH
INTEGER I, I1, I2, IKD, IMAT, IN, INB, INFO, IOFF,
$ IRHS, IUPLO, IW, IZERO, K, KD, KL, KOFF, KU,
$ LDA, LDAB, MODE, N, NB, NERRS, NFAIL, NIMAT,
$ NKD, NRHS, NRUN
DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCOND, RCONDC
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 ), ISEEDY( 4 ), KDVAL( NBW )
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Functions ..
DOUBLE PRECISION DGET06, DLANGE, DLANSB
EXTERNAL DGET06, DLANGE, DLANSB
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, DCOPY, DERRPO, DGET04,
$ DLACPY, DLARHS, DLASET, DLATB4, DLATMS, DPBCON,
$ DPBRFS, DPBT01, DPBT02, DPBT05, DPBTRF, DPBTRS,
$ DSWAP, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'PB'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL DERRPO( PATH, NOUT )
INFOT = 0
CALL XLAENV( 2, 2 )
KDVAL( 1 ) = 0
*
* Do for each value of N in NVAL
*
DO 90 IN = 1, NN
N = NVAL( IN )
LDA = MAX( N, 1 )
XTYPE = 'N'
*
* Set limits on the number of loop iterations.
*
NKD = MAX( 1, MIN( N, 4 ) )
NIMAT = NTYPES
IF( N.EQ.0 )
$ NIMAT = 1
*
KDVAL( 2 ) = N + ( N+1 ) / 4
KDVAL( 3 ) = ( 3*N-1 ) / 4
KDVAL( 4 ) = ( N+1 ) / 4
*
DO 80 IKD = 1, NKD
*
* Do for KD = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This order
* makes it easier to skip redundant values for small values
* of N.
*
KD = KDVAL( IKD )
LDAB = KD + 1
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 70 IUPLO = 1, 2
KOFF = 1
IF( IUPLO.EQ.1 ) THEN
UPLO = 'U'
KOFF = MAX( 1, KD+2-N )
PACKIT = 'Q'
ELSE
UPLO = 'L'
PACKIT = 'B'
END IF
*
DO 60 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 60
*
* Skip types 2, 3, or 4 if the matrix size is too small.
*
ZEROT = IMAT.GE.2 .AND. IMAT.LE.4
IF( ZEROT .AND. N.LT.IMAT-1 )
$ GO TO 60
*
IF( .NOT.ZEROT .OR. .NOT.DOTYPE( 1 ) ) THEN
*
* Set up parameters with DLATB4 and generate a test
* matrix with DLATMS.
*
CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM,
$ MODE, CNDNUM, DIST )
*
SRNAMT = 'DLATMS'
CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KD, KD, PACKIT,
$ A( KOFF ), LDAB, WORK, INFO )
*
* Check error code from DLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N,
$ N, KD, KD, -1, IMAT, NFAIL, NERRS,
$ NOUT )
GO TO 60
END IF
ELSE IF( IZERO.GT.0 ) THEN
*
* Use the same matrix for types 3 and 4 as for type
* 2 by copying back the zeroed out column,
*
IW = 2*LDA + 1
IF( IUPLO.EQ.1 ) THEN
IOFF = ( IZERO-1 )*LDAB + KD + 1
CALL DCOPY( IZERO-I1, WORK( IW ), 1,
$ A( IOFF-IZERO+I1 ), 1 )
IW = IW + IZERO - I1
CALL DCOPY( I2-IZERO+1, WORK( IW ), 1,
$ A( IOFF ), MAX( LDAB-1, 1 ) )
ELSE
IOFF = ( I1-1 )*LDAB + 1
CALL DCOPY( IZERO-I1, WORK( IW ), 1,
$ A( IOFF+IZERO-I1 ),
$ MAX( LDAB-1, 1 ) )
IOFF = ( IZERO-1 )*LDAB + 1
IW = IW + IZERO - I1
CALL DCOPY( I2-IZERO+1, WORK( IW ), 1,
$ A( IOFF ), 1 )
END IF
END IF
*
* For types 2-4, zero one row and column of the matrix
* to test that INFO is returned correctly.
*
IZERO = 0
IF( ZEROT ) THEN
IF( IMAT.EQ.2 ) THEN
IZERO = 1
ELSE IF( IMAT.EQ.3 ) THEN
IZERO = N
ELSE
IZERO = N / 2 + 1
END IF
*
* Save the zeroed out row and column in WORK(*,3)
*
IW = 2*LDA
DO 20 I = 1, MIN( 2*KD+1, N )
WORK( IW+I ) = ZERO
20 CONTINUE
IW = IW + 1
I1 = MAX( IZERO-KD, 1 )
I2 = MIN( IZERO+KD, N )
*
IF( IUPLO.EQ.1 ) THEN
IOFF = ( IZERO-1 )*LDAB + KD + 1
CALL DSWAP( IZERO-I1, A( IOFF-IZERO+I1 ), 1,
$ WORK( IW ), 1 )
IW = IW + IZERO - I1
CALL DSWAP( I2-IZERO+1, A( IOFF ),
$ MAX( LDAB-1, 1 ), WORK( IW ), 1 )
ELSE
IOFF = ( I1-1 )*LDAB + 1
CALL DSWAP( IZERO-I1, A( IOFF+IZERO-I1 ),
$ MAX( LDAB-1, 1 ), WORK( IW ), 1 )
IOFF = ( IZERO-1 )*LDAB + 1
IW = IW + IZERO - I1
CALL DSWAP( I2-IZERO+1, A( IOFF ), 1,
$ WORK( IW ), 1 )
END IF
END IF
*
* Do for each value of NB in NBVAL
*
DO 50 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
*
* Compute the L*L' or U'*U factorization of the band
* matrix.
*
CALL DLACPY( 'Full', KD+1, N, A, LDAB, AFAC, LDAB )
SRNAMT = 'DPBTRF'
CALL DPBTRF( UPLO, N, KD, AFAC, LDAB, INFO )
*
* Check error code from DPBTRF.
*
IF( INFO.NE.IZERO ) THEN
CALL ALAERH( PATH, 'DPBTRF', INFO, IZERO, UPLO,
$ N, N, KD, KD, NB, IMAT, NFAIL,
$ NERRS, NOUT )
GO TO 50
END IF
*
* Skip the tests if INFO is not 0.
*
IF( INFO.NE.0 )
$ GO TO 50
*
*+ TEST 1
* Reconstruct matrix from factors and compute
* residual.
*
CALL DLACPY( 'Full', KD+1, N, AFAC, LDAB, AINV,
$ LDAB )
CALL DPBT01( UPLO, N, KD, A, LDAB, AINV, LDAB,
$ RWORK, RESULT( 1 ) )
*
* Print the test ratio if it is .GE. THRESH.
*
IF( RESULT( 1 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )UPLO, N, KD, NB, IMAT,
$ 1, RESULT( 1 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
*
* Only do other tests if this is the first blocksize.
*
IF( INB.GT.1 )
$ GO TO 50
*
* Form the inverse of A so we can get a good estimate
* of RCONDC = 1/(norm(A) * norm(inv(A))).
*
CALL DLASET( 'Full', N, N, ZERO, ONE, AINV, LDA )
SRNAMT = 'DPBTRS'
CALL DPBTRS( UPLO, N, KD, N, AFAC, LDAB, AINV, LDA,
$ INFO )
*
* Compute RCONDC = 1/(norm(A) * norm(inv(A))).
*
ANORM = DLANSB( '1', UPLO, N, KD, A, LDAB, RWORK )
AINVNM = DLANGE( '1', N, N, AINV, LDA, RWORK )
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDC = ONE
ELSE
RCONDC = ( ONE / ANORM ) / AINVNM
END IF
*
DO 40 IRHS = 1, NNS
NRHS = NSVAL( IRHS )
*
*+ TEST 2
* Solve and compute residual for A * X = B.
*
SRNAMT = 'DLARHS'
CALL DLARHS( PATH, XTYPE, UPLO, ' ', N, N, KD,
$ KD, NRHS, A, LDAB, XACT, LDA, B,
$ LDA, ISEED, INFO )
CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
SRNAMT = 'DPBTRS'
CALL DPBTRS( UPLO, N, KD, NRHS, AFAC, LDAB, X,
$ LDA, INFO )
*
* Check error code from DPBTRS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DPBTRS', INFO, 0, UPLO,
$ N, N, KD, KD, NRHS, IMAT, NFAIL,
$ NERRS, NOUT )
*
CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK,
$ LDA )
CALL DPBT02( UPLO, N, KD, NRHS, A, LDAB, X, LDA,
$ WORK, LDA, RWORK, RESULT( 2 ) )
*
*+ TEST 3
* Check solution from generated exact solution.
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
*
*+ TESTS 4, 5, and 6
* Use iterative refinement to improve the solution.
*
SRNAMT = 'DPBRFS'
CALL DPBRFS( UPLO, N, KD, NRHS, A, LDAB, AFAC,
$ LDAB, B, LDA, X, LDA, RWORK,
$ RWORK( NRHS+1 ), WORK, IWORK,
$ INFO )
*
* Check error code from DPBRFS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DPBRFS', INFO, 0, UPLO,
$ N, N, KD, KD, NRHS, IMAT, NFAIL,
$ NERRS, NOUT )
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 4 ) )
CALL DPBT05( UPLO, N, KD, NRHS, A, LDAB, B, LDA,
$ X, LDA, XACT, LDA, RWORK,
$ RWORK( NRHS+1 ), RESULT( 5 ) )
*
* Print information about the tests that did not
* pass the threshold.
*
DO 30 K = 2, 6
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )UPLO, N, KD,
$ NRHS, IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
30 CONTINUE
NRUN = NRUN + 5
40 CONTINUE
*
*+ TEST 7
* Get an estimate of RCOND = 1/CNDNUM.
*
SRNAMT = 'DPBCON'
CALL DPBCON( UPLO, N, KD, AFAC, LDAB, ANORM, RCOND,
$ WORK, IWORK, INFO )
*
* Check error code from DPBCON.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DPBCON', INFO, 0, UPLO, N,
$ N, KD, KD, -1, IMAT, NFAIL, NERRS,
$ NOUT )
*
RESULT( 7 ) = DGET06( RCOND, RCONDC )
*
* Print the test ratio if it is .GE. THRESH.
*
IF( RESULT( 7 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9997 )UPLO, N, KD, IMAT, 7,
$ RESULT( 7 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
50 CONTINUE
60 CONTINUE
70 CONTINUE
80 CONTINUE
90 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' UPLO=''', A1, ''', N=', I5, ', KD=', I5, ', NB=', I4,
$ ', type ', I2, ', test ', I2, ', ratio= ', G12.5 )
9998 FORMAT( ' UPLO=''', A1, ''', N=', I5, ', KD=', I5, ', NRHS=', I3,
$ ', type ', I2, ', test(', I2, ') = ', G12.5 )
9997 FORMAT( ' UPLO=''', A1, ''', N=', I5, ', KD=', I5, ',', 10X,
$ ' type ', I2, ', test(', I2, ') = ', G12.5 )
RETURN
*
* End of DCHKPB
*
END
SUBROUTINE DCHKPO( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
$ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
$ XACT, WORK, RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NMAX, NN, NNB, NNS, NOUT
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
$ RWORK( * ), WORK( * ), X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* DCHKPO tests DPOTRF, -TRI, -TRS, -RFS, and -CON
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* NNB (input) INTEGER
* The number of values of NB contained in the vector NBVAL.
*
* NBVAL (input) INTEGER array, dimension (NBVAL)
* The values of the blocksize NB.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for N, used in dimensioning the
* work arrays.
*
* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
* where NSMAX is the largest entry in NSVAL.
*
* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
*
* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension
* (NMAX*max(3,NSMAX))
*
* RWORK (workspace) DOUBLE PRECISION array, dimension
* (max(NMAX,2*NSMAX))
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
INTEGER NTYPES
PARAMETER ( NTYPES = 9 )
INTEGER NTESTS
PARAMETER ( NTESTS = 8 )
* ..
* .. Local Scalars ..
LOGICAL ZEROT
CHARACTER DIST, TYPE, UPLO, XTYPE
CHARACTER*3 PATH
INTEGER I, IMAT, IN, INB, INFO, IOFF, IRHS, IUPLO,
$ IZERO, K, KL, KU, LDA, MODE, N, NB, NERRS,
$ NFAIL, NIMAT, NRHS, NRUN
DOUBLE PRECISION ANORM, CNDNUM, RCOND, RCONDC
* ..
* .. Local Arrays ..
CHARACTER UPLOS( 2 )
INTEGER ISEED( 4 ), ISEEDY( 4 )
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Functions ..
DOUBLE PRECISION DGET06, DLANSY
EXTERNAL DGET06, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, DERRPO, DGET04, DLACPY,
$ DLARHS, DLATB4, DLATMS, DPOCON, DPORFS, DPOT01,
$ DPOT02, DPOT03, DPOT05, DPOTRF, DPOTRI, DPOTRS,
$ XLAENV
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
DATA UPLOS / 'U', 'L' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'PO'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL DERRPO( PATH, NOUT )
INFOT = 0
CALL XLAENV( 2, 2 )
*
* Do for each value of N in NVAL
*
DO 120 IN = 1, NN
N = NVAL( IN )
LDA = MAX( N, 1 )
XTYPE = 'N'
NIMAT = NTYPES
IF( N.LE.0 )
$ NIMAT = 1
*
IZERO = 0
DO 110 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 110
*
* Skip types 3, 4, or 5 if the matrix size is too small.
*
ZEROT = IMAT.GE.3 .AND. IMAT.LE.5
IF( ZEROT .AND. N.LT.IMAT-2 )
$ GO TO 110
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 100 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
*
* Set up parameters with DLATB4 and generate a test matrix
* with DLATMS.
*
CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
*
SRNAMT = 'DLATMS'
CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
$ INFO )
*
* Check error code from DLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 100
END IF
*
* For types 3-5, zero one row and column of the matrix to
* test that INFO is returned correctly.
*
IF( ZEROT ) THEN
IF( IMAT.EQ.3 ) THEN
IZERO = 1
ELSE IF( IMAT.EQ.4 ) THEN
IZERO = N
ELSE
IZERO = N / 2 + 1
END IF
IOFF = ( IZERO-1 )*LDA
*
* Set row and column IZERO of A to 0.
*
IF( IUPLO.EQ.1 ) THEN
DO 20 I = 1, IZERO - 1
A( IOFF+I ) = ZERO
20 CONTINUE
IOFF = IOFF + IZERO
DO 30 I = IZERO, N
A( IOFF ) = ZERO
IOFF = IOFF + LDA
30 CONTINUE
ELSE
IOFF = IZERO
DO 40 I = 1, IZERO - 1
A( IOFF ) = ZERO
IOFF = IOFF + LDA
40 CONTINUE
IOFF = IOFF - IZERO
DO 50 I = IZERO, N
A( IOFF+I ) = ZERO
50 CONTINUE
END IF
ELSE
IZERO = 0
END IF
*
* Do for each value of NB in NBVAL
*
DO 90 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
*
* Compute the L*L' or U'*U factorization of the matrix.
*
CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
SRNAMT = 'DPOTRF'
CALL DPOTRF( UPLO, N, AFAC, LDA, INFO )
*
* Check error code from DPOTRF.
*
IF( INFO.NE.IZERO ) THEN
CALL ALAERH( PATH, 'DPOTRF', INFO, IZERO, UPLO, N,
$ N, -1, -1, NB, IMAT, NFAIL, NERRS,
$ NOUT )
GO TO 90
END IF
*
* Skip the tests if INFO is not 0.
*
IF( INFO.NE.0 )
$ GO TO 90
*
*+ TEST 1
* Reconstruct matrix from factors and compute residual.
*
CALL DLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
CALL DPOT01( UPLO, N, A, LDA, AINV, LDA, RWORK,
$ RESULT( 1 ) )
*
*+ TEST 2
* Form the inverse and compute the residual.
*
CALL DLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
SRNAMT = 'DPOTRI'
CALL DPOTRI( UPLO, N, AINV, LDA, INFO )
*
* Check error code from DPOTRI.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DPOTRI', INFO, 0, UPLO, N, N,
$ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
CALL DPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA,
$ RWORK, RCONDC, RESULT( 2 ) )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 60 K = 1, 2
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
$ RESULT( K )
NFAIL = NFAIL + 1
END IF
60 CONTINUE
NRUN = NRUN + 2
*
* Skip the rest of the tests unless this is the first
* blocksize.
*
IF( INB.NE.1 )
$ GO TO 90
*
DO 80 IRHS = 1, NNS
NRHS = NSVAL( IRHS )
*
*+ TEST 3
* Solve and compute residual for A * X = B .
*
SRNAMT = 'DLARHS'
CALL DLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
$ NRHS, A, LDA, XACT, LDA, B, LDA,
$ ISEED, INFO )
CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
SRNAMT = 'DPOTRS'
CALL DPOTRS( UPLO, N, NRHS, AFAC, LDA, X, LDA,
$ INFO )
*
* Check error code from DPOTRS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DPOTRS', INFO, 0, UPLO, N,
$ N, -1, -1, NRHS, IMAT, NFAIL,
$ NERRS, NOUT )
*
CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
CALL DPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
$ LDA, RWORK, RESULT( 3 ) )
*
*+ TEST 4
* Check solution from generated exact solution.
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 4 ) )
*
*+ TESTS 5, 6, and 7
* Use iterative refinement to improve the solution.
*
SRNAMT = 'DPORFS'
CALL DPORFS( UPLO, N, NRHS, A, LDA, AFAC, LDA, B,
$ LDA, X, LDA, RWORK, RWORK( NRHS+1 ),
$ WORK, IWORK, INFO )
*
* Check error code from DPORFS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DPORFS', INFO, 0, UPLO, N,
$ N, -1, -1, NRHS, IMAT, NFAIL,
$ NERRS, NOUT )
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 5 ) )
CALL DPOT05( UPLO, N, NRHS, A, LDA, B, LDA, X, LDA,
$ XACT, LDA, RWORK, RWORK( NRHS+1 ),
$ RESULT( 6 ) )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 70 K = 3, 7
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS,
$ IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
70 CONTINUE
NRUN = NRUN + 5
80 CONTINUE
*
*+ TEST 8
* Get an estimate of RCOND = 1/CNDNUM.
*
ANORM = DLANSY( '1', UPLO, N, A, LDA, RWORK )
SRNAMT = 'DPOCON'
CALL DPOCON( UPLO, N, AFAC, LDA, ANORM, RCOND, WORK,
$ IWORK, INFO )
*
* Check error code from DPOCON.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DPOCON', INFO, 0, UPLO, N, N,
$ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
RESULT( 8 ) = DGET06( RCOND, RCONDC )
*
* Print the test ratio if it is .GE. THRESH.
*
IF( RESULT( 8 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 8,
$ RESULT( 8 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
90 CONTINUE
100 CONTINUE
110 CONTINUE
120 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ',
$ I2, ', test ', I2, ', ratio =', G12.5 )
9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
$ I2, ', test(', I2, ') =', G12.5 )
9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
$ ', test(', I2, ') =', G12.5 )
RETURN
*
* End of DCHKPO
*
END
SUBROUTINE DCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
$ NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK,
$ IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NMAX, NN, NNS, NOUT
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
$ RWORK( * ), WORK( * ), X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* DCHKPP tests DPPTRF, -TRI, -TRS, -RFS, and -CON
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for N, used in dimensioning the
* work arrays.
*
* A (workspace) DOUBLE PRECISION array, dimension
* (NMAX*(NMAX+1)/2)
*
* AFAC (workspace) DOUBLE PRECISION array, dimension
* (NMAX*(NMAX+1)/2)
*
* AINV (workspace) DOUBLE PRECISION array, dimension
* (NMAX*(NMAX+1)/2)
*
* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
* where NSMAX is the largest entry in NSVAL.
*
* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
*
* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension
* (NMAX*max(3,NSMAX))
*
* RWORK (workspace) DOUBLE PRECISION array, dimension
* (max(NMAX,2*NSMAX))
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
INTEGER NTYPES
PARAMETER ( NTYPES = 9 )
INTEGER NTESTS
PARAMETER ( NTESTS = 8 )
* ..
* .. Local Scalars ..
LOGICAL ZEROT
CHARACTER DIST, PACKIT, TYPE, UPLO, XTYPE
CHARACTER*3 PATH
INTEGER I, IMAT, IN, INFO, IOFF, IRHS, IUPLO, IZERO, K,
$ KL, KU, LDA, MODE, N, NERRS, NFAIL, NIMAT, NPP,
$ NRHS, NRUN
DOUBLE PRECISION ANORM, CNDNUM, RCOND, RCONDC
* ..
* .. Local Arrays ..
CHARACTER PACKS( 2 ), UPLOS( 2 )
INTEGER ISEED( 4 ), ISEEDY( 4 )
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Functions ..
DOUBLE PRECISION DGET06, DLANSP
EXTERNAL DGET06, DLANSP
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, DCOPY, DERRPO, DGET04,
$ DLACPY, DLARHS, DLATB4, DLATMS, DPPCON, DPPRFS,
$ DPPT01, DPPT02, DPPT03, DPPT05, DPPTRF, DPPTRI,
$ DPPTRS
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
DATA UPLOS / 'U', 'L' / , PACKS / 'C', 'R' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'PP'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL DERRPO( PATH, NOUT )
INFOT = 0
*
* Do for each value of N in NVAL
*
DO 110 IN = 1, NN
N = NVAL( IN )
LDA = MAX( N, 1 )
XTYPE = 'N'
NIMAT = NTYPES
IF( N.LE.0 )
$ NIMAT = 1
*
DO 100 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 100
*
* Skip types 3, 4, or 5 if the matrix size is too small.
*
ZEROT = IMAT.GE.3 .AND. IMAT.LE.5
IF( ZEROT .AND. N.LT.IMAT-2 )
$ GO TO 100
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 90 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
PACKIT = PACKS( IUPLO )
*
* Set up parameters with DLATB4 and generate a test matrix
* with DLATMS.
*
CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
*
SRNAMT = 'DLATMS'
CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
$ INFO )
*
* Check error code from DLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 90
END IF
*
* For types 3-5, zero one row and column of the matrix to
* test that INFO is returned correctly.
*
IF( ZEROT ) THEN
IF( IMAT.EQ.3 ) THEN
IZERO = 1
ELSE IF( IMAT.EQ.4 ) THEN
IZERO = N
ELSE
IZERO = N / 2 + 1
END IF
*
* Set row and column IZERO of A to 0.
*
IF( IUPLO.EQ.1 ) THEN
IOFF = ( IZERO-1 )*IZERO / 2
DO 20 I = 1, IZERO - 1
A( IOFF+I ) = ZERO
20 CONTINUE
IOFF = IOFF + IZERO
DO 30 I = IZERO, N
A( IOFF ) = ZERO
IOFF = IOFF + I
30 CONTINUE
ELSE
IOFF = IZERO
DO 40 I = 1, IZERO - 1
A( IOFF ) = ZERO
IOFF = IOFF + N - I
40 CONTINUE
IOFF = IOFF - IZERO
DO 50 I = IZERO, N
A( IOFF+I ) = ZERO
50 CONTINUE
END IF
ELSE
IZERO = 0
END IF
*
* Compute the L*L' or U'*U factorization of the matrix.
*
NPP = N*( N+1 ) / 2
CALL DCOPY( NPP, A, 1, AFAC, 1 )
SRNAMT = 'DPPTRF'
CALL DPPTRF( UPLO, N, AFAC, INFO )
*
* Check error code from DPPTRF.
*
IF( INFO.NE.IZERO ) THEN
CALL ALAERH( PATH, 'DPPTRF', INFO, IZERO, UPLO, N, N,
$ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 90
END IF
*
* Skip the tests if INFO is not 0.
*
IF( INFO.NE.0 )
$ GO TO 90
*
*+ TEST 1
* Reconstruct matrix from factors and compute residual.
*
CALL DCOPY( NPP, AFAC, 1, AINV, 1 )
CALL DPPT01( UPLO, N, A, AINV, RWORK, RESULT( 1 ) )
*
*+ TEST 2
* Form the inverse and compute the residual.
*
CALL DCOPY( NPP, AFAC, 1, AINV, 1 )
SRNAMT = 'DPPTRI'
CALL DPPTRI( UPLO, N, AINV, INFO )
*
* Check error code from DPPTRI.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DPPTRI', INFO, 0, UPLO, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
CALL DPPT03( UPLO, N, A, AINV, WORK, LDA, RWORK, RCONDC,
$ RESULT( 2 ) )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 60 K = 1, 2
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )UPLO, N, IMAT, K,
$ RESULT( K )
NFAIL = NFAIL + 1
END IF
60 CONTINUE
NRUN = NRUN + 2
*
DO 80 IRHS = 1, NNS
NRHS = NSVAL( IRHS )
*
*+ TEST 3
* Solve and compute residual for A * X = B.
*
SRNAMT = 'DLARHS'
CALL DLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
$ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED,
$ INFO )
CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
SRNAMT = 'DPPTRS'
CALL DPPTRS( UPLO, N, NRHS, AFAC, X, LDA, INFO )
*
* Check error code from DPPTRS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DPPTRS', INFO, 0, UPLO, N, N,
$ -1, -1, NRHS, IMAT, NFAIL, NERRS,
$ NOUT )
*
CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
CALL DPPT02( UPLO, N, NRHS, A, X, LDA, WORK, LDA,
$ RWORK, RESULT( 3 ) )
*
*+ TEST 4
* Check solution from generated exact solution.
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 4 ) )
*
*+ TESTS 5, 6, and 7
* Use iterative refinement to improve the solution.
*
SRNAMT = 'DPPRFS'
CALL DPPRFS( UPLO, N, NRHS, A, AFAC, B, LDA, X, LDA,
$ RWORK, RWORK( NRHS+1 ), WORK, IWORK,
$ INFO )
*
* Check error code from DPPRFS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DPPRFS', INFO, 0, UPLO, N, N,
$ -1, -1, NRHS, IMAT, NFAIL, NERRS,
$ NOUT )
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 5 ) )
CALL DPPT05( UPLO, N, NRHS, A, B, LDA, X, LDA, XACT,
$ LDA, RWORK, RWORK( NRHS+1 ),
$ RESULT( 6 ) )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 70 K = 3, 7
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, IMAT,
$ K, RESULT( K )
NFAIL = NFAIL + 1
END IF
70 CONTINUE
NRUN = NRUN + 5
80 CONTINUE
*
*+ TEST 8
* Get an estimate of RCOND = 1/CNDNUM.
*
ANORM = DLANSP( '1', UPLO, N, A, RWORK )
SRNAMT = 'DPPCON'
CALL DPPCON( UPLO, N, AFAC, ANORM, RCOND, WORK, IWORK,
$ INFO )
*
* Check error code from DPPCON.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DPPCON', INFO, 0, UPLO, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
RESULT( 8 ) = DGET06( RCOND, RCONDC )
*
* Print the test ratio if greater than or equal to THRESH.
*
IF( RESULT( 8 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )UPLO, N, IMAT, 8,
$ RESULT( 8 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
90 CONTINUE
100 CONTINUE
110 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', type ', I2, ', test ',
$ I2, ', ratio =', G12.5 )
9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
$ I2, ', test(', I2, ') =', G12.5 )
RETURN
*
* End of DCHKPP
*
END
SUBROUTINE DCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
$ A, D, E, B, X, XACT, WORK, RWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NN, NNS, NOUT
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER NSVAL( * ), NVAL( * )
DOUBLE PRECISION A( * ), B( * ), D( * ), E( * ), RWORK( * ),
$ WORK( * ), X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* DCHKPT tests DPTTRF, -TRS, -RFS, and -CON
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* A (workspace) DOUBLE PRECISION array, dimension (NMAX*2)
*
* D (workspace) DOUBLE PRECISION array, dimension (NMAX*2)
*
* E (workspace) DOUBLE PRECISION array, dimension (NMAX*2)
*
* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
* where NSMAX is the largest entry in NSVAL.
*
* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
*
* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension
* (NMAX*max(3,NSMAX))
*
* RWORK (workspace) DOUBLE PRECISION array, dimension
* (max(NMAX,2*NSMAX))
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
INTEGER NTYPES
PARAMETER ( NTYPES = 12 )
INTEGER NTESTS
PARAMETER ( NTESTS = 7 )
* ..
* .. Local Scalars ..
LOGICAL ZEROT
CHARACTER DIST, TYPE
CHARACTER*3 PATH
INTEGER I, IA, IMAT, IN, INFO, IRHS, IX, IZERO, J, K,
$ KL, KU, LDA, MODE, N, NERRS, NFAIL, NIMAT,
$ NRHS, NRUN
DOUBLE PRECISION AINVNM, ANORM, COND, DMAX, RCOND, RCONDC
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 ), ISEEDY( 4 )
DOUBLE PRECISION RESULT( NTESTS ), Z( 3 )
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DASUM, DGET06, DLANST
EXTERNAL IDAMAX, DASUM, DGET06, DLANST
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, DCOPY, DERRGT, DGET04,
$ DLACPY, DLAPTM, DLARNV, DLATB4, DLATMS, DPTCON,
$ DPTRFS, DPTT01, DPTT02, DPTT05, DPTTRF, DPTTRS,
$ DSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 0, 0, 0, 1 /
* ..
* .. Executable Statements ..
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'PT'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL DERRGT( PATH, NOUT )
INFOT = 0
*
DO 110 IN = 1, NN
*
* Do for each value of N in NVAL.
*
N = NVAL( IN )
LDA = MAX( 1, N )
NIMAT = NTYPES
IF( N.LE.0 )
$ NIMAT = 1
*
DO 100 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( N.GT.0 .AND. .NOT.DOTYPE( IMAT ) )
$ GO TO 100
*
* Set up parameters with DLATB4.
*
CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ COND, DIST )
*
ZEROT = IMAT.GE.8 .AND. IMAT.LE.10
IF( IMAT.LE.6 ) THEN
*
* Type 1-6: generate a symmetric tridiagonal matrix of
* known condition number in lower triangular band storage.
*
SRNAMT = 'DLATMS'
CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, COND,
$ ANORM, KL, KU, 'B', A, 2, WORK, INFO )
*
* Check the error code from DLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', N, N, KL,
$ KU, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 100
END IF
IZERO = 0
*
* Copy the matrix to D and E.
*
IA = 1
DO 20 I = 1, N - 1
D( I ) = A( IA )
E( I ) = A( IA+1 )
IA = IA + 2
20 CONTINUE
IF( N.GT.0 )
$ D( N ) = A( IA )
ELSE
*
* Type 7-12: generate a diagonally dominant matrix with
* unknown condition number in the vectors D and E.
*
IF( .NOT.ZEROT .OR. .NOT.DOTYPE( 7 ) ) THEN
*
* Let D and E have values from [-1,1].
*
CALL DLARNV( 2, ISEED, N, D )
CALL DLARNV( 2, ISEED, N-1, E )
*
* Make the tridiagonal matrix diagonally dominant.
*
IF( N.EQ.1 ) THEN
D( 1 ) = ABS( D( 1 ) )
ELSE
D( 1 ) = ABS( D( 1 ) ) + ABS( E( 1 ) )
D( N ) = ABS( D( N ) ) + ABS( E( N-1 ) )
DO 30 I = 2, N - 1
D( I ) = ABS( D( I ) ) + ABS( E( I ) ) +
$ ABS( E( I-1 ) )
30 CONTINUE
END IF
*
* Scale D and E so the maximum element is ANORM.
*
IX = IDAMAX( N, D, 1 )
DMAX = D( IX )
CALL DSCAL( N, ANORM / DMAX, D, 1 )
CALL DSCAL( N-1, ANORM / DMAX, E, 1 )
*
ELSE IF( IZERO.GT.0 ) THEN
*
* Reuse the last matrix by copying back the zeroed out
* elements.
*
IF( IZERO.EQ.1 ) THEN
D( 1 ) = Z( 2 )
IF( N.GT.1 )
$ E( 1 ) = Z( 3 )
ELSE IF( IZERO.EQ.N ) THEN
E( N-1 ) = Z( 1 )
D( N ) = Z( 2 )
ELSE
E( IZERO-1 ) = Z( 1 )
D( IZERO ) = Z( 2 )
E( IZERO ) = Z( 3 )
END IF
END IF
*
* For types 8-10, set one row and column of the matrix to
* zero.
*
IZERO = 0
IF( IMAT.EQ.8 ) THEN
IZERO = 1
Z( 2 ) = D( 1 )
D( 1 ) = ZERO
IF( N.GT.1 ) THEN
Z( 3 ) = E( 1 )
E( 1 ) = ZERO
END IF
ELSE IF( IMAT.EQ.9 ) THEN
IZERO = N
IF( N.GT.1 ) THEN
Z( 1 ) = E( N-1 )
E( N-1 ) = ZERO
END IF
Z( 2 ) = D( N )
D( N ) = ZERO
ELSE IF( IMAT.EQ.10 ) THEN
IZERO = ( N+1 ) / 2
IF( IZERO.GT.1 ) THEN
Z( 1 ) = E( IZERO-1 )
E( IZERO-1 ) = ZERO
Z( 3 ) = E( IZERO )
E( IZERO ) = ZERO
END IF
Z( 2 ) = D( IZERO )
D( IZERO ) = ZERO
END IF
END IF
*
CALL DCOPY( N, D, 1, D( N+1 ), 1 )
IF( N.GT.1 )
$ CALL DCOPY( N-1, E, 1, E( N+1 ), 1 )
*
*+ TEST 1
* Factor A as L*D*L' and compute the ratio
* norm(L*D*L' - A) / (n * norm(A) * EPS )
*
CALL DPTTRF( N, D( N+1 ), E( N+1 ), INFO )
*
* Check error code from DPTTRF.
*
IF( INFO.NE.IZERO ) THEN
CALL ALAERH( PATH, 'DPTTRF', INFO, IZERO, ' ', N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 100
END IF
*
IF( INFO.GT.0 ) THEN
RCONDC = ZERO
GO TO 90
END IF
*
CALL DPTT01( N, D, E, D( N+1 ), E( N+1 ), WORK,
$ RESULT( 1 ) )
*
* Print the test ratio if greater than or equal to THRESH.
*
IF( RESULT( 1 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )N, IMAT, 1, RESULT( 1 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
*
* Compute RCONDC = 1 / (norm(A) * norm(inv(A))
*
* Compute norm(A).
*
ANORM = DLANST( '1', N, D, E )
*
* Use DPTTRS to solve for one column at a time of inv(A),
* computing the maximum column sum as we go.
*
AINVNM = ZERO
DO 50 I = 1, N
DO 40 J = 1, N
X( J ) = ZERO
40 CONTINUE
X( I ) = ONE
CALL DPTTRS( N, 1, D( N+1 ), E( N+1 ), X, LDA, INFO )
AINVNM = MAX( AINVNM, DASUM( N, X, 1 ) )
50 CONTINUE
RCONDC = ONE / MAX( ONE, ANORM*AINVNM )
*
DO 80 IRHS = 1, NNS
NRHS = NSVAL( IRHS )
*
* Generate NRHS random solution vectors.
*
IX = 1
DO 60 J = 1, NRHS
CALL DLARNV( 2, ISEED, N, XACT( IX ) )
IX = IX + LDA
60 CONTINUE
*
* Set the right hand side.
*
CALL DLAPTM( N, NRHS, ONE, D, E, XACT, LDA, ZERO, B,
$ LDA )
*
*+ TEST 2
* Solve A*x = b and compute the residual.
*
CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
CALL DPTTRS( N, NRHS, D( N+1 ), E( N+1 ), X, LDA, INFO )
*
* Check error code from DPTTRS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DPTTRS', INFO, 0, ' ', N, N, -1,
$ -1, NRHS, IMAT, NFAIL, NERRS, NOUT )
*
CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
CALL DPTT02( N, NRHS, D, E, X, LDA, WORK, LDA,
$ RESULT( 2 ) )
*
*+ TEST 3
* Check solution from generated exact solution.
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
*
*+ TESTS 4, 5, and 6
* Use iterative refinement to improve the solution.
*
SRNAMT = 'DPTRFS'
CALL DPTRFS( N, NRHS, D, E, D( N+1 ), E( N+1 ), B, LDA,
$ X, LDA, RWORK, RWORK( NRHS+1 ), WORK, INFO )
*
* Check error code from DPTRFS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DPTRFS', INFO, 0, ' ', N, N, -1,
$ -1, NRHS, IMAT, NFAIL, NERRS, NOUT )
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 4 ) )
CALL DPTT05( N, NRHS, D, E, B, LDA, X, LDA, XACT, LDA,
$ RWORK, RWORK( NRHS+1 ), RESULT( 5 ) )
*
* Print information about the tests that did not pass the
* threshold.
*
DO 70 K = 2, 6
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )N, NRHS, IMAT, K,
$ RESULT( K )
NFAIL = NFAIL + 1
END IF
70 CONTINUE
NRUN = NRUN + 5
80 CONTINUE
*
*+ TEST 7
* Estimate the reciprocal of the condition number of the
* matrix.
*
90 CONTINUE
SRNAMT = 'DPTCON'
CALL DPTCON( N, D( N+1 ), E( N+1 ), ANORM, RCOND, RWORK,
$ INFO )
*
* Check error code from DPTCON.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DPTCON', INFO, 0, ' ', N, N, -1, -1,
$ -1, IMAT, NFAIL, NERRS, NOUT )
*
RESULT( 7 ) = DGET06( RCOND, RCONDC )
*
* Print the test ratio if greater than or equal to THRESH.
*
IF( RESULT( 7 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )N, IMAT, 7, RESULT( 7 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
100 CONTINUE
110 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' N =', I5, ', type ', I2, ', test ', I2, ', ratio = ',
$ G12.5 )
9998 FORMAT( ' N =', I5, ', NRHS=', I3, ', type ', I2, ', test(', I2,
$ ') = ', G12.5 )
RETURN
*
* End of DCHKPT
*
END
SUBROUTINE DCHKQ3( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
$ THRESH, A, COPYA, S, COPYS, TAU, WORK, IWORK,
$ NOUT )
*
* -- LAPACK test routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* January 2007
*
* .. Scalar Arguments ..
INTEGER NM, NN, NNB, NOUT
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
$ NXVAL( * )
DOUBLE PRECISION A( * ), COPYA( * ), COPYS( * ), S( * ),
$ TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DCHKQ3 tests DGEQP3.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* A (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX)
* where MMAX is the maximum value of M in MVAL and NMAX is the
* maximum value of N in NVAL.
*
* COPYA (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX)
*
* S (workspace) DOUBLE PRECISION array, dimension
* (min(MMAX,NMAX))
*
* COPYS (workspace) DOUBLE PRECISION array, dimension
* (min(MMAX,NMAX))
*
* TAU (workspace) DOUBLE PRECISION array, dimension (MMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension
* (MMAX*NMAX + 4*NMAX + MMAX)
*
* IWORK (workspace) INTEGER array, dimension (2*NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTYPES
PARAMETER ( NTYPES = 6 )
INTEGER NTESTS
PARAMETER ( NTESTS = 3 )
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
CHARACTER*3 PATH
INTEGER I, IHIGH, ILOW, IM, IMODE, IN, INB, INFO,
$ ISTEP, K, LDA, LW, LWORK, M, MNMIN, MODE, N,
$ NB, NERRS, NFAIL, NRUN, NX
DOUBLE PRECISION EPS
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 ), ISEEDY( 4 )
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DQPT01, DQRT11, DQRT12
EXTERNAL DLAMCH, DQPT01, DQRT11, DQRT12
* ..
* .. External Subroutines ..
EXTERNAL ALAHD, ALASUM, DGEQP3, DLACPY, DLAORD, DLASET,
$ DLATMS, ICOPY, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, IOUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, IOUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'Q3'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
EPS = DLAMCH( 'Epsilon' )
INFOT = 0
*
DO 90 IM = 1, NM
*
* Do for each value of M in MVAL.
*
M = MVAL( IM )
LDA = MAX( 1, M )
*
DO 80 IN = 1, NN
*
* Do for each value of N in NVAL.
*
N = NVAL( IN )
MNMIN = MIN( M, N )
LWORK = MAX( 1, M*MAX( M, N )+4*MNMIN+MAX( M, N ),
$ M*N + 2*MNMIN + 4*N )
*
DO 70 IMODE = 1, NTYPES
IF( .NOT.DOTYPE( IMODE ) )
$ GO TO 70
*
* Do for each type of matrix
* 1: zero matrix
* 2: one small singular value
* 3: geometric distribution of singular values
* 4: first n/2 columns fixed
* 5: last n/2 columns fixed
* 6: every second column fixed
*
MODE = IMODE
IF( IMODE.GT.3 )
$ MODE = 1
*
* Generate test matrix of size m by n using
* singular value distribution indicated by `mode'.
*
DO 20 I = 1, N
IWORK( I ) = 0
20 CONTINUE
IF( IMODE.EQ.1 ) THEN
CALL DLASET( 'Full', M, N, ZERO, ZERO, COPYA, LDA )
DO 30 I = 1, MNMIN
COPYS( I ) = ZERO
30 CONTINUE
ELSE
CALL DLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', COPYS,
$ MODE, ONE / EPS, ONE, M, N, 'No packing',
$ COPYA, LDA, WORK, INFO )
IF( IMODE.GE.4 ) THEN
IF( IMODE.EQ.4 ) THEN
ILOW = 1
ISTEP = 1
IHIGH = MAX( 1, N / 2 )
ELSE IF( IMODE.EQ.5 ) THEN
ILOW = MAX( 1, N / 2 )
ISTEP = 1
IHIGH = N
ELSE IF( IMODE.EQ.6 ) THEN
ILOW = 1
ISTEP = 2
IHIGH = N
END IF
DO 40 I = ILOW, IHIGH, ISTEP
IWORK( I ) = 1
40 CONTINUE
END IF
CALL DLAORD( 'Decreasing', MNMIN, COPYS, 1 )
END IF
*
DO 60 INB = 1, NNB
*
* Do for each pair of values (NB,NX) in NBVAL and NXVAL.
*
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
*
* Get a working copy of COPYA into A and a copy of
* vector IWORK.
*
CALL DLACPY( 'All', M, N, COPYA, LDA, A, LDA )
CALL ICOPY( N, IWORK( 1 ), 1, IWORK( N+1 ), 1 )
*
* Compute the QR factorization with pivoting of A
*
LW = MAX( 1, 2*N+NB*( N+1 ) )
*
* Compute the QP3 factorization of A
*
SRNAMT = 'DGEQP3'
CALL DGEQP3( M, N, A, LDA, IWORK( N+1 ), TAU, WORK,
$ LW, INFO )
*
* Compute norm(svd(a) - svd(r))
*
RESULT( 1 ) = DQRT12( M, N, A, LDA, COPYS, WORK,
$ LWORK )
*
* Compute norm( A*P - Q*R )
*
RESULT( 2 ) = DQPT01( M, N, MNMIN, COPYA, A, LDA, TAU,
$ IWORK( N+1 ), WORK, LWORK )
*
* Compute Q'*Q
*
RESULT( 3 ) = DQRT11( M, MNMIN, A, LDA, TAU, WORK,
$ LWORK )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 50 K = 1, NTESTS
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )'DGEQP3', M, N, NB,
$ IMODE, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
50 CONTINUE
NRUN = NRUN + NTESTS
*
60 CONTINUE
70 CONTINUE
80 CONTINUE
90 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( 1X, A6, ' M =', I5, ', N =', I5, ', NB =', I4, ', type ',
$ I2, ', test ', I2, ', ratio =', G12.5 )
*
* End of DCHKQ3
*
END
SUBROUTINE DCHKQL( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
$ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AL, AC,
$ B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NM, NMAX, NN, NNB, NOUT, NRHS
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
$ NXVAL( * )
DOUBLE PRECISION A( * ), AC( * ), AF( * ), AL( * ), AQ( * ),
$ B( * ), RWORK( * ), TAU( * ), WORK( * ),
$ X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* DCHKQL tests DGEQLF, DORGQL and DORMQL.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* NRHS (input) INTEGER
* The number of right hand side vectors to be generated for
* each linear system.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for M or N, used in dimensioning
* the work arrays.
*
* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AQ (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AL (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* TAU (workspace) DOUBLE PRECISION array, dimension (NMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTESTS
PARAMETER ( NTESTS = 7 )
INTEGER NTYPES
PARAMETER ( NTYPES = 8 )
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
CHARACTER DIST, TYPE
CHARACTER*3 PATH
INTEGER I, IK, IM, IMAT, IN, INB, INFO, K, KL, KU, LDA,
$ LWORK, M, MINMN, MODE, N, NB, NERRS, NFAIL, NK,
$ NRUN, NT, NX
DOUBLE PRECISION ANORM, CNDNUM
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 )
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, DERRQL, DGEQLS, DGET02,
$ DLACPY, DLARHS, DLATB4, DLATMS, DQLT01, DQLT02,
$ DQLT03, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'QL'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL DERRQL( PATH, NOUT )
INFOT = 0
CALL XLAENV( 2, 2 )
*
LDA = NMAX
LWORK = NMAX*MAX( NMAX, NRHS )
*
* Do for each value of M in MVAL.
*
DO 70 IM = 1, NM
M = MVAL( IM )
*
* Do for each value of N in NVAL.
*
DO 60 IN = 1, NN
N = NVAL( IN )
MINMN = MIN( M, N )
DO 50 IMAT = 1, NTYPES
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 50
*
* Set up parameters with DLATB4 and generate a test matrix
* with DLATMS.
*
CALL DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
*
SRNAMT = 'DLATMS'
CALL DLATMS( M, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, 'No packing', A, LDA,
$ WORK, INFO )
*
* Check error code from DLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', M, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 50
END IF
*
* Set some values for K: the first value must be MINMN,
* corresponding to the call of DQLT01; other values are
* used in the calls of DQLT02, and must not exceed MINMN.
*
KVAL( 1 ) = MINMN
KVAL( 2 ) = 0
KVAL( 3 ) = 1
KVAL( 4 ) = MINMN / 2
IF( MINMN.EQ.0 ) THEN
NK = 1
ELSE IF( MINMN.EQ.1 ) THEN
NK = 2
ELSE IF( MINMN.LE.3 ) THEN
NK = 3
ELSE
NK = 4
END IF
*
* Do for each value of K in KVAL
*
DO 40 IK = 1, NK
K = KVAL( IK )
*
* Do for each pair of values (NB,NX) in NBVAL and NXVAL.
*
DO 30 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
NT = 2
IF( IK.EQ.1 ) THEN
*
* Test DGEQLF
*
CALL DQLT01( M, N, A, AF, AQ, AL, LDA, TAU,
$ WORK, LWORK, RWORK, RESULT( 1 ) )
ELSE IF( M.GE.N ) THEN
*
* Test DORGQL, using factorization
* returned by DQLT01
*
CALL DQLT02( M, N, K, A, AF, AQ, AL, LDA, TAU,
$ WORK, LWORK, RWORK, RESULT( 1 ) )
ELSE
RESULT( 1 ) = ZERO
RESULT( 2 ) = ZERO
END IF
IF( M.GE.K ) THEN
*
* Test DORMQL, using factorization returned
* by DQLT01
*
CALL DQLT03( M, N, K, AF, AC, AL, AQ, LDA, TAU,
$ WORK, LWORK, RWORK, RESULT( 3 ) )
NT = NT + 4
*
* If M>=N and K=N, call DGEQLS to solve a system
* with NRHS right hand sides and compute the
* residual.
*
IF( K.EQ.N .AND. INB.EQ.1 ) THEN
*
* Generate a solution and set the right
* hand side.
*
SRNAMT = 'DLARHS'
CALL DLARHS( PATH, 'New', 'Full',
$ 'No transpose', M, N, 0, 0,
$ NRHS, A, LDA, XACT, LDA, B, LDA,
$ ISEED, INFO )
*
CALL DLACPY( 'Full', M, NRHS, B, LDA, X,
$ LDA )
SRNAMT = 'DGEQLS'
CALL DGEQLS( M, N, NRHS, AF, LDA, TAU, X,
$ LDA, WORK, LWORK, INFO )
*
* Check error code from DGEQLS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DGEQLS', INFO, 0, ' ',
$ M, N, NRHS, -1, NB, IMAT,
$ NFAIL, NERRS, NOUT )
*
CALL DGET02( 'No transpose', M, N, NRHS, A,
$ LDA, X( M-N+1 ), LDA, B, LDA,
$ RWORK, RESULT( 7 ) )
NT = NT + 1
ELSE
RESULT( 7 ) = ZERO
END IF
ELSE
RESULT( 3 ) = ZERO
RESULT( 4 ) = ZERO
RESULT( 5 ) = ZERO
RESULT( 6 ) = ZERO
END IF
*
* Print information about the tests that did not
* pass the threshold.
*
DO 20 I = 1, NT
IF( RESULT( I ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )M, N, K, NB, NX,
$ IMAT, I, RESULT( I )
NFAIL = NFAIL + 1
END IF
20 CONTINUE
NRUN = NRUN + NT
30 CONTINUE
40 CONTINUE
50 CONTINUE
60 CONTINUE
70 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' M=', I5, ', N=', I5, ', K=', I5, ', NB=', I4, ', NX=',
$ I5, ', type ', I2, ', test(', I2, ')=', G12.5 )
RETURN
*
* End of DCHKQL
*
END
SUBROUTINE DCHKQP( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A,
$ COPYA, S, COPYS, TAU, WORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* January 2007
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NM, NN, NOUT
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), MVAL( * ), NVAL( * )
DOUBLE PRECISION A( * ), COPYA( * ), COPYS( * ), S( * ),
$ TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DCHKQP tests DGEQPF.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* A (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX)
* where MMAX is the maximum value of M in MVAL and NMAX is the
* maximum value of N in NVAL.
*
* COPYA (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX)
*
* S (workspace) DOUBLE PRECISION array, dimension
* (min(MMAX,NMAX))
*
* COPYS (workspace) DOUBLE PRECISION array, dimension
* (min(MMAX,NMAX))
*
* TAU (workspace) DOUBLE PRECISION array, dimension (MMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension
* (MMAX*NMAX + 4*NMAX + MMAX)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTYPES
PARAMETER ( NTYPES = 6 )
INTEGER NTESTS
PARAMETER ( NTESTS = 3 )
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
CHARACTER*3 PATH
INTEGER I, IHIGH, ILOW, IM, IMODE, IN, INFO, ISTEP, K,
$ LDA, LWORK, M, MNMIN, MODE, N, NERRS, NFAIL,
$ NRUN
DOUBLE PRECISION EPS
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 ), ISEEDY( 4 )
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DQPT01, DQRT11, DQRT12
EXTERNAL DLAMCH, DQPT01, DQRT11, DQRT12
* ..
* .. External Subroutines ..
EXTERNAL ALAHD, ALASUM, DERRQP, DGEQPF, DLACPY, DLAORD,
$ DLASET, DLATMS
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, IOUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, IOUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'QP'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
EPS = DLAMCH( 'Epsilon' )
*
* Test the error exits
*
IF( TSTERR )
$ CALL DERRQP( PATH, NOUT )
INFOT = 0
*
DO 80 IM = 1, NM
*
* Do for each value of M in MVAL.
*
M = MVAL( IM )
LDA = MAX( 1, M )
*
DO 70 IN = 1, NN
*
* Do for each value of N in NVAL.
*
N = NVAL( IN )
MNMIN = MIN( M, N )
LWORK = MAX( 1, M*MAX( M, N ) + 4*MNMIN + MAX( M, N ),
$ M*N + 2*MNMIN + 4*N )
*
DO 60 IMODE = 1, NTYPES
IF( .NOT.DOTYPE( IMODE ) )
$ GO TO 60
*
* Do for each type of matrix
* 1: zero matrix
* 2: one small singular value
* 3: geometric distribution of singular values
* 4: first n/2 columns fixed
* 5: last n/2 columns fixed
* 6: every second column fixed
*
MODE = IMODE
IF( IMODE.GT.3 )
$ MODE = 1
*
* Generate test matrix of size m by n using
* singular value distribution indicated by `mode'.
*
DO 20 I = 1, N
IWORK( I ) = 0
20 CONTINUE
IF( IMODE.EQ.1 ) THEN
CALL DLASET( 'Full', M, N, ZERO, ZERO, COPYA, LDA )
DO 30 I = 1, MNMIN
COPYS( I ) = ZERO
30 CONTINUE
ELSE
CALL DLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', COPYS,
$ MODE, ONE / EPS, ONE, M, N, 'No packing',
$ COPYA, LDA, WORK, INFO )
IF( IMODE.GE.4 ) THEN
IF( IMODE.EQ.4 ) THEN
ILOW = 1
ISTEP = 1
IHIGH = MAX( 1, N / 2 )
ELSE IF( IMODE.EQ.5 ) THEN
ILOW = MAX( 1, N / 2 )
ISTEP = 1
IHIGH = N
ELSE IF( IMODE.EQ.6 ) THEN
ILOW = 1
ISTEP = 2
IHIGH = N
END IF
DO 40 I = ILOW, IHIGH, ISTEP
IWORK( I ) = 1
40 CONTINUE
END IF
CALL DLAORD( 'Decreasing', MNMIN, COPYS, 1 )
END IF
*
* Save A and its singular values
*
CALL DLACPY( 'All', M, N, COPYA, LDA, A, LDA )
*
* Compute the QR factorization with pivoting of A
*
SRNAMT = 'DGEQPF'
CALL DGEQPF( M, N, A, LDA, IWORK, TAU, WORK, INFO )
*
* Compute norm(svd(a) - svd(r))
*
RESULT( 1 ) = DQRT12( M, N, A, LDA, COPYS, WORK, LWORK )
*
* Compute norm( A*P - Q*R )
*
RESULT( 2 ) = DQPT01( M, N, MNMIN, COPYA, A, LDA, TAU,
$ IWORK, WORK, LWORK )
*
* Compute Q'*Q
*
RESULT( 3 ) = DQRT11( M, MNMIN, A, LDA, TAU, WORK,
$ LWORK )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 50 K = 1, 3
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )M, N, IMODE, K,
$ RESULT( K )
NFAIL = NFAIL + 1
END IF
50 CONTINUE
NRUN = NRUN + 3
60 CONTINUE
70 CONTINUE
80 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' M =', I5, ', N =', I5, ', type ', I2, ', test ', I2,
$ ', ratio =', G12.5 )
*
* End of DCHKQP
*
END
SUBROUTINE DCHKQR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
$ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC,
$ B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NM, NMAX, NN, NNB, NOUT, NRHS
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
$ NXVAL( * )
DOUBLE PRECISION A( * ), AC( * ), AF( * ), AQ( * ), AR( * ),
$ B( * ), RWORK( * ), TAU( * ), WORK( * ),
$ X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* DCHKQR tests DGEQRF, DORGQR and DORMQR.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* NRHS (input) INTEGER
* The number of right hand side vectors to be generated for
* each linear system.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for M or N, used in dimensioning
* the work arrays.
*
* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AQ (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AR (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* TAU (workspace) DOUBLE PRECISION array, dimension (NMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTESTS
PARAMETER ( NTESTS = 7 )
INTEGER NTYPES
PARAMETER ( NTYPES = 8 )
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
CHARACTER DIST, TYPE
CHARACTER*3 PATH
INTEGER I, IK, IM, IMAT, IN, INB, INFO, K, KL, KU, LDA,
$ LWORK, M, MINMN, MODE, N, NB, NERRS, NFAIL, NK,
$ NRUN, NT, NX
DOUBLE PRECISION ANORM, CNDNUM
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 )
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, DERRQR, DGEQRS, DGET02,
$ DLACPY, DLARHS, DLATB4, DLATMS, DQRT01, DQRT02,
$ DQRT03, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'QR'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL DERRQR( PATH, NOUT )
INFOT = 0
CALL XLAENV( 2, 2 )
*
LDA = NMAX
LWORK = NMAX*MAX( NMAX, NRHS )
*
* Do for each value of M in MVAL.
*
DO 70 IM = 1, NM
M = MVAL( IM )
*
* Do for each value of N in NVAL.
*
DO 60 IN = 1, NN
N = NVAL( IN )
MINMN = MIN( M, N )
DO 50 IMAT = 1, NTYPES
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 50
*
* Set up parameters with DLATB4 and generate a test matrix
* with DLATMS.
*
CALL DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
*
SRNAMT = 'DLATMS'
CALL DLATMS( M, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, 'No packing', A, LDA,
$ WORK, INFO )
*
* Check error code from DLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', M, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 50
END IF
*
* Set some values for K: the first value must be MINMN,
* corresponding to the call of DQRT01; other values are
* used in the calls of DQRT02, and must not exceed MINMN.
*
KVAL( 1 ) = MINMN
KVAL( 2 ) = 0
KVAL( 3 ) = 1
KVAL( 4 ) = MINMN / 2
IF( MINMN.EQ.0 ) THEN
NK = 1
ELSE IF( MINMN.EQ.1 ) THEN
NK = 2
ELSE IF( MINMN.LE.3 ) THEN
NK = 3
ELSE
NK = 4
END IF
*
* Do for each value of K in KVAL
*
DO 40 IK = 1, NK
K = KVAL( IK )
*
* Do for each pair of values (NB,NX) in NBVAL and NXVAL.
*
DO 30 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
NT = 2
IF( IK.EQ.1 ) THEN
*
* Test DGEQRF
*
CALL DQRT01( M, N, A, AF, AQ, AR, LDA, TAU,
$ WORK, LWORK, RWORK, RESULT( 1 ) )
ELSE IF( M.GE.N ) THEN
*
* Test DORGQR, using factorization
* returned by DQRT01
*
CALL DQRT02( M, N, K, A, AF, AQ, AR, LDA, TAU,
$ WORK, LWORK, RWORK, RESULT( 1 ) )
ELSE
RESULT( 1 ) = ZERO
RESULT( 2 ) = ZERO
END IF
IF( M.GE.K ) THEN
*
* Test DORMQR, using factorization returned
* by DQRT01
*
CALL DQRT03( M, N, K, AF, AC, AR, AQ, LDA, TAU,
$ WORK, LWORK, RWORK, RESULT( 3 ) )
NT = NT + 4
*
* If M>=N and K=N, call DGEQRS to solve a system
* with NRHS right hand sides and compute the
* residual.
*
IF( K.EQ.N .AND. INB.EQ.1 ) THEN
*
* Generate a solution and set the right
* hand side.
*
SRNAMT = 'DLARHS'
CALL DLARHS( PATH, 'New', 'Full',
$ 'No transpose', M, N, 0, 0,
$ NRHS, A, LDA, XACT, LDA, B, LDA,
$ ISEED, INFO )
*
CALL DLACPY( 'Full', M, NRHS, B, LDA, X,
$ LDA )
SRNAMT = 'DGEQRS'
CALL DGEQRS( M, N, NRHS, AF, LDA, TAU, X,
$ LDA, WORK, LWORK, INFO )
*
* Check error code from DGEQRS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DGEQRS', INFO, 0, ' ',
$ M, N, NRHS, -1, NB, IMAT,
$ NFAIL, NERRS, NOUT )
*
CALL DGET02( 'No transpose', M, N, NRHS, A,
$ LDA, X, LDA, B, LDA, RWORK,
$ RESULT( 7 ) )
NT = NT + 1
ELSE
RESULT( 7 ) = ZERO
END IF
ELSE
RESULT( 3 ) = ZERO
RESULT( 4 ) = ZERO
RESULT( 5 ) = ZERO
RESULT( 6 ) = ZERO
END IF
*
* Print information about the tests that did not
* pass the threshold.
*
DO 20 I = 1, NT
IF( RESULT( I ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )M, N, K, NB, NX,
$ IMAT, I, RESULT( I )
NFAIL = NFAIL + 1
END IF
20 CONTINUE
NRUN = NRUN + NT
30 CONTINUE
40 CONTINUE
50 CONTINUE
60 CONTINUE
70 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' M=', I5, ', N=', I5, ', K=', I5, ', NB=', I4, ', NX=',
$ I5, ', type ', I2, ', test(', I2, ')=', G12.5 )
RETURN
*
* End of DCHKQR
*
END
SUBROUTINE DCHKRQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
$ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC,
$ B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NM, NMAX, NN, NNB, NOUT, NRHS
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
$ NXVAL( * )
DOUBLE PRECISION A( * ), AC( * ), AF( * ), AQ( * ), AR( * ),
$ B( * ), RWORK( * ), TAU( * ), WORK( * ),
$ X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* DCHKRQ tests DGERQF, DORGRQ and DORMRQ.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* NRHS (input) INTEGER
* The number of right hand side vectors to be generated for
* each linear system.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for M or N, used in dimensioning
* the work arrays.
*
* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AQ (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AR (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* TAU (workspace) DOUBLE PRECISION array, dimension (NMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTESTS
PARAMETER ( NTESTS = 7 )
INTEGER NTYPES
PARAMETER ( NTYPES = 8 )
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
CHARACTER DIST, TYPE
CHARACTER*3 PATH
INTEGER I, IK, IM, IMAT, IN, INB, INFO, K, KL, KU, LDA,
$ LWORK, M, MINMN, MODE, N, NB, NERRS, NFAIL, NK,
$ NRUN, NT, NX
DOUBLE PRECISION ANORM, CNDNUM
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 )
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, DERRRQ, DGERQS, DGET02,
$ DLACPY, DLARHS, DLATB4, DLATMS, DRQT01, DRQT02,
$ DRQT03, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'RQ'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL DERRRQ( PATH, NOUT )
INFOT = 0
CALL XLAENV( 2, 2 )
*
LDA = NMAX
LWORK = NMAX*MAX( NMAX, NRHS )
*
* Do for each value of M in MVAL.
*
DO 70 IM = 1, NM
M = MVAL( IM )
*
* Do for each value of N in NVAL.
*
DO 60 IN = 1, NN
N = NVAL( IN )
MINMN = MIN( M, N )
DO 50 IMAT = 1, NTYPES
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 50
*
* Set up parameters with DLATB4 and generate a test matrix
* with DLATMS.
*
CALL DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
*
SRNAMT = 'DLATMS'
CALL DLATMS( M, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, 'No packing', A, LDA,
$ WORK, INFO )
*
* Check error code from DLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', M, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 50
END IF
*
* Set some values for K: the first value must be MINMN,
* corresponding to the call of DRQT01; other values are
* used in the calls of DRQT02, and must not exceed MINMN.
*
KVAL( 1 ) = MINMN
KVAL( 2 ) = 0
KVAL( 3 ) = 1
KVAL( 4 ) = MINMN / 2
IF( MINMN.EQ.0 ) THEN
NK = 1
ELSE IF( MINMN.EQ.1 ) THEN
NK = 2
ELSE IF( MINMN.LE.3 ) THEN
NK = 3
ELSE
NK = 4
END IF
*
* Do for each value of K in KVAL
*
DO 40 IK = 1, NK
K = KVAL( IK )
*
* Do for each pair of values (NB,NX) in NBVAL and NXVAL.
*
DO 30 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
NT = 2
IF( IK.EQ.1 ) THEN
*
* Test DGERQF
*
CALL DRQT01( M, N, A, AF, AQ, AR, LDA, TAU,
$ WORK, LWORK, RWORK, RESULT( 1 ) )
ELSE IF( M.LE.N ) THEN
*
* Test DORGRQ, using factorization
* returned by DRQT01
*
CALL DRQT02( M, N, K, A, AF, AQ, AR, LDA, TAU,
$ WORK, LWORK, RWORK, RESULT( 1 ) )
ELSE
RESULT( 1 ) = ZERO
RESULT( 2 ) = ZERO
END IF
IF( M.GE.K ) THEN
*
* Test DORMRQ, using factorization returned
* by DRQT01
*
CALL DRQT03( M, N, K, AF, AC, AR, AQ, LDA, TAU,
$ WORK, LWORK, RWORK, RESULT( 3 ) )
NT = NT + 4
*
* If M>=N and K=N, call DGERQS to solve a system
* with NRHS right hand sides and compute the
* residual.
*
IF( K.EQ.M .AND. INB.EQ.1 ) THEN
*
* Generate a solution and set the right
* hand side.
*
SRNAMT = 'DLARHS'
CALL DLARHS( PATH, 'New', 'Full',
$ 'No transpose', M, N, 0, 0,
$ NRHS, A, LDA, XACT, LDA, B, LDA,
$ ISEED, INFO )
*
CALL DLACPY( 'Full', M, NRHS, B, LDA,
$ X( N-M+1 ), LDA )
SRNAMT = 'DGERQS'
CALL DGERQS( M, N, NRHS, AF, LDA, TAU, X,
$ LDA, WORK, LWORK, INFO )
*
* Check error code from DGERQS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DGERQS', INFO, 0, ' ',
$ M, N, NRHS, -1, NB, IMAT,
$ NFAIL, NERRS, NOUT )
*
CALL DGET02( 'No transpose', M, N, NRHS, A,
$ LDA, X, LDA, B, LDA, RWORK,
$ RESULT( 7 ) )
NT = NT + 1
ELSE
RESULT( 7 ) = ZERO
END IF
ELSE
RESULT( 3 ) = ZERO
RESULT( 4 ) = ZERO
RESULT( 5 ) = ZERO
RESULT( 6 ) = ZERO
END IF
*
* Print information about the tests that did not
* pass the threshold.
*
DO 20 I = 1, NT
IF( RESULT( I ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )M, N, K, NB, NX,
$ IMAT, I, RESULT( I )
NFAIL = NFAIL + 1
END IF
20 CONTINUE
NRUN = NRUN + NT
30 CONTINUE
40 CONTINUE
50 CONTINUE
60 CONTINUE
70 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' M=', I5, ', N=', I5, ', K=', I5, ', NB=', I4, ', NX=',
$ I5, ', type ', I2, ', test(', I2, ')=', G12.5 )
RETURN
*
* End of DCHKRQ
*
END
SUBROUTINE DCHKSP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
$ NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK,
$ IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NMAX, NN, NNS, NOUT
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
$ RWORK( * ), WORK( * ), X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* DCHKSP tests DSPTRF, -TRI, -TRS, -RFS, and -CON
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for N, used in dimensioning the
* work arrays.
*
* A (workspace) DOUBLE PRECISION array, dimension
* (NMAX*(NMAX+1)/2)
*
* AFAC (workspace) DOUBLE PRECISION array, dimension
* (NMAX*(NMAX+1)/2)
*
* AINV (workspace) DOUBLE PRECISION array, dimension
* (NMAX*(NMAX+1)/2)
*
* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
* where NSMAX is the largest entry in NSVAL.
*
* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
*
* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension
* (NMAX*max(2,NSMAX))
*
* RWORK (workspace) DOUBLE PRECISION array,
* dimension (NMAX+2*NSMAX)
*
* IWORK (workspace) INTEGER array, dimension (2*NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
INTEGER NTYPES
PARAMETER ( NTYPES = 10 )
INTEGER NTESTS
PARAMETER ( NTESTS = 8 )
* ..
* .. Local Scalars ..
LOGICAL TRFCON, ZEROT
CHARACTER DIST, PACKIT, TYPE, UPLO, XTYPE
CHARACTER*3 PATH
INTEGER I, I1, I2, IMAT, IN, INFO, IOFF, IRHS, IUPLO,
$ IZERO, J, K, KL, KU, LDA, MODE, N, NERRS,
$ NFAIL, NIMAT, NPP, NRHS, NRUN, NT
DOUBLE PRECISION ANORM, CNDNUM, RCOND, RCONDC
* ..
* .. Local Arrays ..
CHARACTER UPLOS( 2 )
INTEGER ISEED( 4 ), ISEEDY( 4 )
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DGET06, DLANSP
EXTERNAL LSAME, DGET06, DLANSP
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, DCOPY, DERRSY, DGET04,
$ DLACPY, DLARHS, DLATB4, DLATMS, DPPT02, DPPT03,
$ DPPT05, DSPCON, DSPRFS, DSPT01, DSPTRF, DSPTRI,
$ DSPTRS
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
DATA UPLOS / 'U', 'L' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'SP'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL DERRSY( PATH, NOUT )
INFOT = 0
*
* Do for each value of N in NVAL
*
DO 170 IN = 1, NN
N = NVAL( IN )
LDA = MAX( N, 1 )
XTYPE = 'N'
NIMAT = NTYPES
IF( N.LE.0 )
$ NIMAT = 1
*
IZERO = 0
DO 160 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 160
*
* Skip types 3, 4, 5, or 6 if the matrix size is too small.
*
ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
IF( ZEROT .AND. N.LT.IMAT-2 )
$ GO TO 160
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 150 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
IF( LSAME( UPLO, 'U' ) ) THEN
PACKIT = 'C'
ELSE
PACKIT = 'R'
END IF
*
* Set up parameters with DLATB4 and generate a test matrix
* with DLATMS.
*
CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
*
SRNAMT = 'DLATMS'
CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
$ INFO )
*
* Check error code from DLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 150
END IF
*
* For types 3-6, zero one or more rows and columns of
* the matrix to test that INFO is returned correctly.
*
IF( ZEROT ) THEN
IF( IMAT.EQ.3 ) THEN
IZERO = 1
ELSE IF( IMAT.EQ.4 ) THEN
IZERO = N
ELSE
IZERO = N / 2 + 1
END IF
*
IF( IMAT.LT.6 ) THEN
*
* Set row and column IZERO to zero.
*
IF( IUPLO.EQ.1 ) THEN
IOFF = ( IZERO-1 )*IZERO / 2
DO 20 I = 1, IZERO - 1
A( IOFF+I ) = ZERO
20 CONTINUE
IOFF = IOFF + IZERO
DO 30 I = IZERO, N
A( IOFF ) = ZERO
IOFF = IOFF + I
30 CONTINUE
ELSE
IOFF = IZERO
DO 40 I = 1, IZERO - 1
A( IOFF ) = ZERO
IOFF = IOFF + N - I
40 CONTINUE
IOFF = IOFF - IZERO
DO 50 I = IZERO, N
A( IOFF+I ) = ZERO
50 CONTINUE
END IF
ELSE
IOFF = 0
IF( IUPLO.EQ.1 ) THEN
*
* Set the first IZERO rows and columns to zero.
*
DO 70 J = 1, N
I2 = MIN( J, IZERO )
DO 60 I = 1, I2
A( IOFF+I ) = ZERO
60 CONTINUE
IOFF = IOFF + J
70 CONTINUE
ELSE
*
* Set the last IZERO rows and columns to zero.
*
DO 90 J = 1, N
I1 = MAX( J, IZERO )
DO 80 I = I1, N
A( IOFF+I ) = ZERO
80 CONTINUE
IOFF = IOFF + N - J
90 CONTINUE
END IF
END IF
ELSE
IZERO = 0
END IF
*
* Compute the L*D*L' or U*D*U' factorization of the matrix.
*
NPP = N*( N+1 ) / 2
CALL DCOPY( NPP, A, 1, AFAC, 1 )
SRNAMT = 'DSPTRF'
CALL DSPTRF( UPLO, N, AFAC, IWORK, INFO )
*
* Adjust the expected value of INFO to account for
* pivoting.
*
K = IZERO
IF( K.GT.0 ) THEN
100 CONTINUE
IF( IWORK( K ).LT.0 ) THEN
IF( IWORK( K ).NE.-K ) THEN
K = -IWORK( K )
GO TO 100
END IF
ELSE IF( IWORK( K ).NE.K ) THEN
K = IWORK( K )
GO TO 100
END IF
END IF
*
* Check error code from DSPTRF.
*
IF( INFO.NE.K )
$ CALL ALAERH( PATH, 'DSPTRF', INFO, K, UPLO, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
IF( INFO.NE.0 ) THEN
TRFCON = .TRUE.
ELSE
TRFCON = .FALSE.
END IF
*
*+ TEST 1
* Reconstruct matrix from factors and compute residual.
*
CALL DSPT01( UPLO, N, A, AFAC, IWORK, AINV, LDA, RWORK,
$ RESULT( 1 ) )
NT = 1
*
*+ TEST 2
* Form the inverse and compute the residual.
*
IF( .NOT.TRFCON ) THEN
CALL DCOPY( NPP, AFAC, 1, AINV, 1 )
SRNAMT = 'DSPTRI'
CALL DSPTRI( UPLO, N, AINV, IWORK, WORK, INFO )
*
* Check error code from DSPTRI.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DSPTRI', INFO, 0, UPLO, N, N,
$ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
CALL DPPT03( UPLO, N, A, AINV, WORK, LDA, RWORK,
$ RCONDC, RESULT( 2 ) )
NT = 2
END IF
*
* Print information about the tests that did not pass
* the threshold.
*
DO 110 K = 1, NT
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )UPLO, N, IMAT, K,
$ RESULT( K )
NFAIL = NFAIL + 1
END IF
110 CONTINUE
NRUN = NRUN + NT
*
* Do only the condition estimate if INFO is not 0.
*
IF( TRFCON ) THEN
RCONDC = ZERO
GO TO 140
END IF
*
DO 130 IRHS = 1, NNS
NRHS = NSVAL( IRHS )
*
*+ TEST 3
* Solve and compute residual for A * X = B.
*
SRNAMT = 'DLARHS'
CALL DLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
$ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED,
$ INFO )
CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
SRNAMT = 'DSPTRS'
CALL DSPTRS( UPLO, N, NRHS, AFAC, IWORK, X, LDA,
$ INFO )
*
* Check error code from DSPTRS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DSPTRS', INFO, 0, UPLO, N, N,
$ -1, -1, NRHS, IMAT, NFAIL, NERRS,
$ NOUT )
*
CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
CALL DPPT02( UPLO, N, NRHS, A, X, LDA, WORK, LDA,
$ RWORK, RESULT( 3 ) )
*
*+ TEST 4
* Check solution from generated exact solution.
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 4 ) )
*
*+ TESTS 5, 6, and 7
* Use iterative refinement to improve the solution.
*
SRNAMT = 'DSPRFS'
CALL DSPRFS( UPLO, N, NRHS, A, AFAC, IWORK, B, LDA, X,
$ LDA, RWORK, RWORK( NRHS+1 ), WORK,
$ IWORK( N+1 ), INFO )
*
* Check error code from DSPRFS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DSPRFS', INFO, 0, UPLO, N, N,
$ -1, -1, NRHS, IMAT, NFAIL, NERRS,
$ NOUT )
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 5 ) )
CALL DPPT05( UPLO, N, NRHS, A, B, LDA, X, LDA, XACT,
$ LDA, RWORK, RWORK( NRHS+1 ),
$ RESULT( 6 ) )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 120 K = 3, 7
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, IMAT,
$ K, RESULT( K )
NFAIL = NFAIL + 1
END IF
120 CONTINUE
NRUN = NRUN + 5
130 CONTINUE
*
*+ TEST 8
* Get an estimate of RCOND = 1/CNDNUM.
*
140 CONTINUE
ANORM = DLANSP( '1', UPLO, N, A, RWORK )
SRNAMT = 'DSPCON'
CALL DSPCON( UPLO, N, AFAC, IWORK, ANORM, RCOND, WORK,
$ IWORK( N+1 ), INFO )
*
* Check error code from DSPCON.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DSPCON', INFO, 0, UPLO, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
RESULT( 8 ) = DGET06( RCOND, RCONDC )
*
* Print the test ratio if it is .GE. THRESH.
*
IF( RESULT( 8 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )UPLO, N, IMAT, 8,
$ RESULT( 8 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
150 CONTINUE
160 CONTINUE
170 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', type ', I2, ', test ',
$ I2, ', ratio =', G12.5 )
9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
$ I2, ', test(', I2, ') =', G12.5 )
RETURN
*
* End of DCHKSP
*
END
SUBROUTINE DCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
$ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
$ XACT, WORK, RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NMAX, NN, NNB, NNS, NOUT
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
$ RWORK( * ), WORK( * ), X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* DCHKSY tests DSYTRF, -TRI, -TRS, -RFS, and -CON.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* NNB (input) INTEGER
* The number of values of NB contained in the vector NBVAL.
*
* NBVAL (input) INTEGER array, dimension (NBVAL)
* The values of the blocksize NB.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for N, used in dimensioning the
* work arrays.
*
* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
* where NSMAX is the largest entry in NSVAL.
*
* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
*
* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension
* (NMAX*max(3,NSMAX))
*
* RWORK (workspace) DOUBLE PRECISION array, dimension
* (max(NMAX,2*NSMAX))
*
* IWORK (workspace) INTEGER array, dimension (2*NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
INTEGER NTYPES
PARAMETER ( NTYPES = 10 )
INTEGER NTESTS
PARAMETER ( NTESTS = 8 )
* ..
* .. Local Scalars ..
LOGICAL TRFCON, ZEROT
CHARACTER DIST, TYPE, UPLO, XTYPE
CHARACTER*3 PATH
INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
$ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE,
$ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT
DOUBLE PRECISION ANORM, CNDNUM, RCOND, RCONDC
* ..
* .. Local Arrays ..
CHARACTER UPLOS( 2 )
INTEGER ISEED( 4 ), ISEEDY( 4 )
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Functions ..
DOUBLE PRECISION DGET06, DLANSY
EXTERNAL DGET06, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, DERRSY, DGET04, DLACPY,
$ DLARHS, DLATB4, DLATMS, DPOT02, DPOT03, DPOT05,
$ DSYCON, DSYRFS, DSYT01, DSYTRF, DSYTRI, DSYTRS,
$ XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
DATA UPLOS / 'U', 'L' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'SY'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL DERRSY( PATH, NOUT )
INFOT = 0
CALL XLAENV( 2, 2 )
*
* Do for each value of N in NVAL
*
DO 180 IN = 1, NN
N = NVAL( IN )
LDA = MAX( N, 1 )
XTYPE = 'N'
NIMAT = NTYPES
IF( N.LE.0 )
$ NIMAT = 1
*
IZERO = 0
DO 170 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 170
*
* Skip types 3, 4, 5, or 6 if the matrix size is too small.
*
ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
IF( ZEROT .AND. N.LT.IMAT-2 )
$ GO TO 170
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 160 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
*
* Set up parameters with DLATB4 and generate a test matrix
* with DLATMS.
*
CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
*
SRNAMT = 'DLATMS'
CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
$ INFO )
*
* Check error code from DLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 160
END IF
*
* For types 3-6, zero one or more rows and columns of
* the matrix to test that INFO is returned correctly.
*
IF( ZEROT ) THEN
IF( IMAT.EQ.3 ) THEN
IZERO = 1
ELSE IF( IMAT.EQ.4 ) THEN
IZERO = N
ELSE
IZERO = N / 2 + 1
END IF
*
IF( IMAT.LT.6 ) THEN
*
* Set row and column IZERO to zero.
*
IF( IUPLO.EQ.1 ) THEN
IOFF = ( IZERO-1 )*LDA
DO 20 I = 1, IZERO - 1
A( IOFF+I ) = ZERO
20 CONTINUE
IOFF = IOFF + IZERO
DO 30 I = IZERO, N
A( IOFF ) = ZERO
IOFF = IOFF + LDA
30 CONTINUE
ELSE
IOFF = IZERO
DO 40 I = 1, IZERO - 1
A( IOFF ) = ZERO
IOFF = IOFF + LDA
40 CONTINUE
IOFF = IOFF - IZERO
DO 50 I = IZERO, N
A( IOFF+I ) = ZERO
50 CONTINUE
END IF
ELSE
IOFF = 0
IF( IUPLO.EQ.1 ) THEN
*
* Set the first IZERO rows and columns to zero.
*
DO 70 J = 1, N
I2 = MIN( J, IZERO )
DO 60 I = 1, I2
A( IOFF+I ) = ZERO
60 CONTINUE
IOFF = IOFF + LDA
70 CONTINUE
ELSE
*
* Set the last IZERO rows and columns to zero.
*
DO 90 J = 1, N
I1 = MAX( J, IZERO )
DO 80 I = I1, N
A( IOFF+I ) = ZERO
80 CONTINUE
IOFF = IOFF + LDA
90 CONTINUE
END IF
END IF
ELSE
IZERO = 0
END IF
*
* Do for each value of NB in NBVAL
*
DO 150 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
*
* Compute the L*D*L' or U*D*U' factorization of the
* matrix.
*
CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
LWORK = MAX( 2, NB )*LDA
SRNAMT = 'DSYTRF'
CALL DSYTRF( UPLO, N, AFAC, LDA, IWORK, AINV, LWORK,
$ INFO )
*
* Adjust the expected value of INFO to account for
* pivoting.
*
K = IZERO
IF( K.GT.0 ) THEN
100 CONTINUE
IF( IWORK( K ).LT.0 ) THEN
IF( IWORK( K ).NE.-K ) THEN
K = -IWORK( K )
GO TO 100
END IF
ELSE IF( IWORK( K ).NE.K ) THEN
K = IWORK( K )
GO TO 100
END IF
END IF
*
* Check error code from DSYTRF.
*
IF( INFO.NE.K )
$ CALL ALAERH( PATH, 'DSYTRF', INFO, K, UPLO, N, N,
$ -1, -1, NB, IMAT, NFAIL, NERRS, NOUT )
IF( INFO.NE.0 ) THEN
TRFCON = .TRUE.
ELSE
TRFCON = .FALSE.
END IF
*
*+ TEST 1
* Reconstruct matrix from factors and compute residual.
*
CALL DSYT01( UPLO, N, A, LDA, AFAC, LDA, IWORK, AINV,
$ LDA, RWORK, RESULT( 1 ) )
NT = 1
*
*+ TEST 2
* Form the inverse and compute the residual.
*
IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN
CALL DLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
SRNAMT = 'DSYTRI'
CALL DSYTRI( UPLO, N, AINV, LDA, IWORK, WORK,
$ INFO )
*
* Check error code from DSYTRI.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DSYTRI', INFO, -1, UPLO, N,
$ N, -1, -1, -1, IMAT, NFAIL, NERRS,
$ NOUT )
*
CALL DPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA,
$ RWORK, RCONDC, RESULT( 2 ) )
NT = 2
END IF
*
* Print information about the tests that did not pass
* the threshold.
*
DO 110 K = 1, NT
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
$ RESULT( K )
NFAIL = NFAIL + 1
END IF
110 CONTINUE
NRUN = NRUN + NT
*
* Skip the other tests if this is not the first block
* size.
*
IF( INB.GT.1 )
$ GO TO 150
*
* Do only the condition estimate if INFO is not 0.
*
IF( TRFCON ) THEN
RCONDC = ZERO
GO TO 140
END IF
*
DO 130 IRHS = 1, NNS
NRHS = NSVAL( IRHS )
*
*+ TEST 3
* Solve and compute residual for A * X = B.
*
SRNAMT = 'DLARHS'
CALL DLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
$ NRHS, A, LDA, XACT, LDA, B, LDA,
$ ISEED, INFO )
CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
SRNAMT = 'DSYTRS'
CALL DSYTRS( UPLO, N, NRHS, AFAC, LDA, IWORK, X,
$ LDA, INFO )
*
* Check error code from DSYTRS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DSYTRS', INFO, 0, UPLO, N,
$ N, -1, -1, NRHS, IMAT, NFAIL,
$ NERRS, NOUT )
*
CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
CALL DPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
$ LDA, RWORK, RESULT( 3 ) )
*
*+ TEST 4
* Check solution from generated exact solution.
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 4 ) )
*
*+ TESTS 5, 6, and 7
* Use iterative refinement to improve the solution.
*
SRNAMT = 'DSYRFS'
CALL DSYRFS( UPLO, N, NRHS, A, LDA, AFAC, LDA,
$ IWORK, B, LDA, X, LDA, RWORK,
$ RWORK( NRHS+1 ), WORK, IWORK( N+1 ),
$ INFO )
*
* Check error code from DSYRFS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DSYRFS', INFO, 0, UPLO, N,
$ N, -1, -1, NRHS, IMAT, NFAIL,
$ NERRS, NOUT )
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 5 ) )
CALL DPOT05( UPLO, N, NRHS, A, LDA, B, LDA, X, LDA,
$ XACT, LDA, RWORK, RWORK( NRHS+1 ),
$ RESULT( 6 ) )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 120 K = 3, 7
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS,
$ IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
120 CONTINUE
NRUN = NRUN + 5
130 CONTINUE
*
*+ TEST 8
* Get an estimate of RCOND = 1/CNDNUM.
*
140 CONTINUE
ANORM = DLANSY( '1', UPLO, N, A, LDA, RWORK )
SRNAMT = 'DSYCON'
CALL DSYCON( UPLO, N, AFAC, LDA, IWORK, ANORM, RCOND,
$ WORK, IWORK( N+1 ), INFO )
*
* Check error code from DSYCON.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DSYCON', INFO, 0, UPLO, N, N,
$ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
RESULT( 8 ) = DGET06( RCOND, RCONDC )
*
* Print information about the tests that did not pass
* the threshold.
*
IF( RESULT( 8 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 8,
$ RESULT( 8 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
150 CONTINUE
*
160 CONTINUE
170 CONTINUE
180 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ',
$ I2, ', test ', I2, ', ratio =', G12.5 )
9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
$ I2, ', test(', I2, ') =', G12.5 )
9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
$ ', test(', I2, ') =', G12.5 )
RETURN
*
* End of DCHKSY
*
END
SUBROUTINE DCHKTB( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
$ NMAX, AB, AINV, B, X, XACT, WORK, RWORK, IWORK,
$ NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NMAX, NN, NNS, NOUT
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
DOUBLE PRECISION AB( * ), AINV( * ), B( * ), RWORK( * ),
$ WORK( * ), X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* DCHKTB tests DTBTRS, -RFS, and -CON, and DLATBS.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The leading dimension of the work arrays.
* NMAX >= the maximum value of N in NVAL.
*
* AB (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
* where NSMAX is the largest entry in NSVAL.
*
* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
*
* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension
* (NMAX*max(3,NSMAX))
*
* RWORK (workspace) DOUBLE PRECISION array, dimension
* (max(NMAX,2*NSMAX))
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTYPE1, NTYPES
PARAMETER ( NTYPE1 = 9, NTYPES = 17 )
INTEGER NTESTS
PARAMETER ( NTESTS = 8 )
INTEGER NTRAN
PARAMETER ( NTRAN = 3 )
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
CHARACTER DIAG, NORM, TRANS, UPLO, XTYPE
CHARACTER*3 PATH
INTEGER I, IDIAG, IK, IMAT, IN, INFO, IRHS, ITRAN,
$ IUPLO, J, K, KD, LDA, LDAB, N, NERRS, NFAIL,
$ NIMAT, NIMAT2, NK, NRHS, NRUN
DOUBLE PRECISION AINVNM, ANORM, RCOND, RCONDC, RCONDI, RCONDO,
$ SCALE
* ..
* .. Local Arrays ..
CHARACTER TRANSS( NTRAN ), UPLOS( 2 )
INTEGER ISEED( 4 ), ISEEDY( 4 )
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLANTB, DLANTR
EXTERNAL LSAME, DLANTB, DLANTR
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, DCOPY, DERRTR, DGET04,
$ DLACPY, DLARHS, DLASET, DLATBS, DLATTB, DTBCON,
$ DTBRFS, DTBSV, DTBT02, DTBT03, DTBT05, DTBT06,
$ DTBTRS
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, IOUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, IOUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
DATA UPLOS / 'U', 'L' / , TRANSS / 'N', 'T', 'C' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'TB'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL DERRTR( PATH, NOUT )
INFOT = 0
*
DO 140 IN = 1, NN
*
* Do for each value of N in NVAL
*
N = NVAL( IN )
LDA = MAX( 1, N )
XTYPE = 'N'
NIMAT = NTYPE1
NIMAT2 = NTYPES
IF( N.LE.0 ) THEN
NIMAT = 1
NIMAT2 = NTYPE1 + 1
END IF
*
NK = MIN( N+1, 4 )
DO 130 IK = 1, NK
*
* Do for KD = 0, N, (3N-1)/4, and (N+1)/4. This order makes
* it easier to skip redundant values for small values of N.
*
IF( IK.EQ.1 ) THEN
KD = 0
ELSE IF( IK.EQ.2 ) THEN
KD = MAX( N, 0 )
ELSE IF( IK.EQ.3 ) THEN
KD = ( 3*N-1 ) / 4
ELSE IF( IK.EQ.4 ) THEN
KD = ( N+1 ) / 4
END IF
LDAB = KD + 1
*
DO 90 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 90
*
DO 80 IUPLO = 1, 2
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
UPLO = UPLOS( IUPLO )
*
* Call DLATTB to generate a triangular test matrix.
*
SRNAMT = 'DLATTB'
CALL DLATTB( IMAT, UPLO, 'No transpose', DIAG, ISEED,
$ N, KD, AB, LDAB, X, WORK, INFO )
*
* Set IDIAG = 1 for non-unit matrices, 2 for unit.
*
IF( LSAME( DIAG, 'N' ) ) THEN
IDIAG = 1
ELSE
IDIAG = 2
END IF
*
* Form the inverse of A so we can get a good estimate
* of RCONDC = 1/(norm(A) * norm(inv(A))).
*
CALL DLASET( 'Full', N, N, ZERO, ONE, AINV, LDA )
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
CALL DTBSV( UPLO, 'No transpose', DIAG, J, KD,
$ AB, LDAB, AINV( ( J-1 )*LDA+1 ), 1 )
20 CONTINUE
ELSE
DO 30 J = 1, N
CALL DTBSV( UPLO, 'No transpose', DIAG, N-J+1,
$ KD, AB( ( J-1 )*LDAB+1 ), LDAB,
$ AINV( ( J-1 )*LDA+J ), 1 )
30 CONTINUE
END IF
*
* Compute the 1-norm condition number of A.
*
ANORM = DLANTB( '1', UPLO, DIAG, N, KD, AB, LDAB,
$ RWORK )
AINVNM = DLANTR( '1', UPLO, DIAG, N, N, AINV, LDA,
$ RWORK )
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDO = ONE
ELSE
RCONDO = ( ONE / ANORM ) / AINVNM
END IF
*
* Compute the infinity-norm condition number of A.
*
ANORM = DLANTB( 'I', UPLO, DIAG, N, KD, AB, LDAB,
$ RWORK )
AINVNM = DLANTR( 'I', UPLO, DIAG, N, N, AINV, LDA,
$ RWORK )
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDI = ONE
ELSE
RCONDI = ( ONE / ANORM ) / AINVNM
END IF
*
DO 60 IRHS = 1, NNS
NRHS = NSVAL( IRHS )
XTYPE = 'N'
*
DO 50 ITRAN = 1, NTRAN
*
* Do for op(A) = A, A**T, or A**H.
*
TRANS = TRANSS( ITRAN )
IF( ITRAN.EQ.1 ) THEN
NORM = 'O'
RCONDC = RCONDO
ELSE
NORM = 'I'
RCONDC = RCONDI
END IF
*
*+ TEST 1
* Solve and compute residual for op(A)*x = b.
*
SRNAMT = 'DLARHS'
CALL DLARHS( PATH, XTYPE, UPLO, TRANS, N, N, KD,
$ IDIAG, NRHS, AB, LDAB, XACT, LDA,
$ B, LDA, ISEED, INFO )
XTYPE = 'C'
CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
SRNAMT = 'DTBTRS'
CALL DTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB,
$ LDAB, X, LDA, INFO )
*
* Check error code from DTBTRS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DTBTRS', INFO, 0,
$ UPLO // TRANS // DIAG, N, N, KD,
$ KD, NRHS, IMAT, NFAIL, NERRS,
$ NOUT )
*
CALL DTBT02( UPLO, TRANS, DIAG, N, KD, NRHS, AB,
$ LDAB, X, LDA, B, LDA, WORK,
$ RESULT( 1 ) )
*
*+ TEST 2
* Check solution from generated exact solution.
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 2 ) )
*
*+ TESTS 3, 4, and 5
* Use iterative refinement to improve the solution
* and compute error bounds.
*
SRNAMT = 'DTBRFS'
CALL DTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB,
$ LDAB, B, LDA, X, LDA, RWORK,
$ RWORK( NRHS+1 ), WORK, IWORK,
$ INFO )
*
* Check error code from DTBRFS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DTBRFS', INFO, 0,
$ UPLO // TRANS // DIAG, N, N, KD,
$ KD, NRHS, IMAT, NFAIL, NERRS,
$ NOUT )
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
CALL DTBT05( UPLO, TRANS, DIAG, N, KD, NRHS, AB,
$ LDAB, B, LDA, X, LDA, XACT, LDA,
$ RWORK, RWORK( NRHS+1 ),
$ RESULT( 4 ) )
*
* Print information about the tests that did not
* pass the threshold.
*
DO 40 K = 1, 5
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )UPLO, TRANS,
$ DIAG, N, KD, NRHS, IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
40 CONTINUE
NRUN = NRUN + 5
50 CONTINUE
60 CONTINUE
*
*+ TEST 6
* Get an estimate of RCOND = 1/CNDNUM.
*
DO 70 ITRAN = 1, 2
IF( ITRAN.EQ.1 ) THEN
NORM = 'O'
RCONDC = RCONDO
ELSE
NORM = 'I'
RCONDC = RCONDI
END IF
SRNAMT = 'DTBCON'
CALL DTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB,
$ RCOND, WORK, IWORK, INFO )
*
* Check error code from DTBCON.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DTBCON', INFO, 0,
$ NORM // UPLO // DIAG, N, N, KD, KD,
$ -1, IMAT, NFAIL, NERRS, NOUT )
*
CALL DTBT06( RCOND, RCONDC, UPLO, DIAG, N, KD, AB,
$ LDAB, RWORK, RESULT( 6 ) )
*
* Print information about the tests that did not pass
* the threshold.
*
IF( RESULT( 6 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 ) 'DTBCON', NORM, UPLO,
$ DIAG, N, KD, IMAT, 6, RESULT( 6 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
70 CONTINUE
80 CONTINUE
90 CONTINUE
*
* Use pathological test matrices to test DLATBS.
*
DO 120 IMAT = NTYPE1 + 1, NIMAT2
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 120
*
DO 110 IUPLO = 1, 2
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
UPLO = UPLOS( IUPLO )
DO 100 ITRAN = 1, NTRAN
*
* Do for op(A) = A, A**T, and A**H.
*
TRANS = TRANSS( ITRAN )
*
* Call DLATTB to generate a triangular test matrix.
*
SRNAMT = 'DLATTB'
CALL DLATTB( IMAT, UPLO, TRANS, DIAG, ISEED, N, KD,
$ AB, LDAB, X, WORK, INFO )
*
*+ TEST 7
* Solve the system op(A)*x = b
*
SRNAMT = 'DLATBS'
CALL DCOPY( N, X, 1, B, 1 )
CALL DLATBS( UPLO, TRANS, DIAG, 'N', N, KD, AB,
$ LDAB, B, SCALE, RWORK, INFO )
*
* Check error code from DLATBS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DLATBS', INFO, 0,
$ UPLO // TRANS // DIAG // 'N', N, N,
$ KD, KD, -1, IMAT, NFAIL, NERRS,
$ NOUT )
*
CALL DTBT03( UPLO, TRANS, DIAG, N, KD, 1, AB, LDAB,
$ SCALE, RWORK, ONE, B, LDA, X, LDA,
$ WORK, RESULT( 7 ) )
*
*+ TEST 8
* Solve op(A)*x = b again with NORMIN = 'Y'.
*
CALL DCOPY( N, X, 1, B, 1 )
CALL DLATBS( UPLO, TRANS, DIAG, 'Y', N, KD, AB,
$ LDAB, B, SCALE, RWORK, INFO )
*
* Check error code from DLATBS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DLATBS', INFO, 0,
$ UPLO // TRANS // DIAG // 'Y', N, N,
$ KD, KD, -1, IMAT, NFAIL, NERRS,
$ NOUT )
*
CALL DTBT03( UPLO, TRANS, DIAG, N, KD, 1, AB, LDAB,
$ SCALE, RWORK, ONE, B, LDA, X, LDA,
$ WORK, RESULT( 8 ) )
*
* Print information about the tests that did not pass
* the threshold.
*
IF( RESULT( 7 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9997 )'DLATBS', UPLO, TRANS,
$ DIAG, 'N', N, KD, IMAT, 7, RESULT( 7 )
NFAIL = NFAIL + 1
END IF
IF( RESULT( 8 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9997 )'DLATBS', UPLO, TRANS,
$ DIAG, 'Y', N, KD, IMAT, 8, RESULT( 8 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 2
100 CONTINUE
110 CONTINUE
120 CONTINUE
130 CONTINUE
140 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' UPLO=''', A1, ''', TRANS=''', A1, ''',
$ DIAG=''', A1, ''', N=', I5, ', KD=', I5, ', NRHS=', I5,
$ ', type ', I2, ', test(', I2, ')=', G12.5 )
9998 FORMAT( 1X, A6, '( ''', A1, ''', ''', A1, ''', ''', A1, ''',',
$ I5, ',', I5, ', ... ), type ', I2, ', test(', I2, ')=',
$ G12.5 )
9997 FORMAT( 1X, A6, '( ''', A1, ''', ''', A1, ''', ''', A1, ''', ''',
$ A1, ''',', I5, ',', I5, ', ... ), type ', I2, ', test(',
$ I1, ')=', G12.5 )
RETURN
*
* End of DCHKTB
*
END
SUBROUTINE DCHKTP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
$ NMAX, AP, AINVP, B, X, XACT, WORK, RWORK,
$ IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NMAX, NN, NNS, NOUT
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
DOUBLE PRECISION AINVP( * ), AP( * ), B( * ), RWORK( * ),
$ WORK( * ), X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* DCHKTP tests DTPTRI, -TRS, -RFS, and -CON, and DLATPS
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The leading dimension of the work arrays. NMAX >= the
* maximumm value of N in NVAL.
*
* AP (workspace) DOUBLE PRECISION array, dimension
* (NMAX*(NMAX+1)/2)
*
* AINVP (workspace) DOUBLE PRECISION array, dimension
* (NMAX*(NMAX+1)/2)
*
* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
* where NSMAX is the largest entry in NSVAL.
*
* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
*
* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension
* (NMAX*max(3,NSMAX))
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* RWORK (workspace) DOUBLE PRECISION array, dimension
* (max(NMAX,2*NSMAX))
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTYPE1, NTYPES
PARAMETER ( NTYPE1 = 10, NTYPES = 18 )
INTEGER NTESTS
PARAMETER ( NTESTS = 9 )
INTEGER NTRAN
PARAMETER ( NTRAN = 3 )
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
CHARACTER DIAG, NORM, TRANS, UPLO, XTYPE
CHARACTER*3 PATH
INTEGER I, IDIAG, IMAT, IN, INFO, IRHS, ITRAN, IUPLO,
$ K, LAP, LDA, N, NERRS, NFAIL, NRHS, NRUN
DOUBLE PRECISION AINVNM, ANORM, RCOND, RCONDC, RCONDI, RCONDO,
$ SCALE
* ..
* .. Local Arrays ..
CHARACTER TRANSS( NTRAN ), UPLOS( 2 )
INTEGER ISEED( 4 ), ISEEDY( 4 )
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLANTP
EXTERNAL LSAME, DLANTP
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, DCOPY, DERRTR, DGET04,
$ DLACPY, DLARHS, DLATPS, DLATTP, DTPCON, DTPRFS,
$ DTPT01, DTPT02, DTPT03, DTPT05, DTPT06, DTPTRI,
$ DTPTRS
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, IOUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, IOUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
DATA UPLOS / 'U', 'L' / , TRANSS / 'N', 'T', 'C' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'TP'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL DERRTR( PATH, NOUT )
INFOT = 0
*
DO 110 IN = 1, NN
*
* Do for each value of N in NVAL
*
N = NVAL( IN )
LDA = MAX( 1, N )
LAP = LDA*( LDA+1 ) / 2
XTYPE = 'N'
*
DO 70 IMAT = 1, NTYPE1
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 70
*
DO 60 IUPLO = 1, 2
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
UPLO = UPLOS( IUPLO )
*
* Call DLATTP to generate a triangular test matrix.
*
SRNAMT = 'DLATTP'
CALL DLATTP( IMAT, UPLO, 'No transpose', DIAG, ISEED, N,
$ AP, X, WORK, INFO )
*
* Set IDIAG = 1 for non-unit matrices, 2 for unit.
*
IF( LSAME( DIAG, 'N' ) ) THEN
IDIAG = 1
ELSE
IDIAG = 2
END IF
*
*+ TEST 1
* Form the inverse of A.
*
IF( N.GT.0 )
$ CALL DCOPY( LAP, AP, 1, AINVP, 1 )
SRNAMT = 'DTPTRI'
CALL DTPTRI( UPLO, DIAG, N, AINVP, INFO )
*
* Check error code from DTPTRI.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DTPTRI', INFO, 0, UPLO // DIAG, N,
$ N, -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
* Compute the infinity-norm condition number of A.
*
ANORM = DLANTP( 'I', UPLO, DIAG, N, AP, RWORK )
AINVNM = DLANTP( 'I', UPLO, DIAG, N, AINVP, RWORK )
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDI = ONE
ELSE
RCONDI = ( ONE / ANORM ) / AINVNM
END IF
*
* Compute the residual for the triangular matrix times its
* inverse. Also compute the 1-norm condition number of A.
*
CALL DTPT01( UPLO, DIAG, N, AP, AINVP, RCONDO, RWORK,
$ RESULT( 1 ) )
*
* Print the test ratio if it is .GE. THRESH.
*
IF( RESULT( 1 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )UPLO, DIAG, N, IMAT, 1,
$ RESULT( 1 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
*
DO 40 IRHS = 1, NNS
NRHS = NSVAL( IRHS )
XTYPE = 'N'
*
DO 30 ITRAN = 1, NTRAN
*
* Do for op(A) = A, A**T, or A**H.
*
TRANS = TRANSS( ITRAN )
IF( ITRAN.EQ.1 ) THEN
NORM = 'O'
RCONDC = RCONDO
ELSE
NORM = 'I'
RCONDC = RCONDI
END IF
*
*+ TEST 2
* Solve and compute residual for op(A)*x = b.
*
SRNAMT = 'DLARHS'
CALL DLARHS( PATH, XTYPE, UPLO, TRANS, N, N, 0,
$ IDIAG, NRHS, AP, LAP, XACT, LDA, B,
$ LDA, ISEED, INFO )
XTYPE = 'C'
CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
SRNAMT = 'DTPTRS'
CALL DTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, X,
$ LDA, INFO )
*
* Check error code from DTPTRS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DTPTRS', INFO, 0,
$ UPLO // TRANS // DIAG, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
CALL DTPT02( UPLO, TRANS, DIAG, N, NRHS, AP, X,
$ LDA, B, LDA, WORK, RESULT( 2 ) )
*
*+ TEST 3
* Check solution from generated exact solution.
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
*
*+ TESTS 4, 5, and 6
* Use iterative refinement to improve the solution and
* compute error bounds.
*
SRNAMT = 'DTPRFS'
CALL DTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B,
$ LDA, X, LDA, RWORK, RWORK( NRHS+1 ),
$ WORK, IWORK, INFO )
*
* Check error code from DTPRFS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DTPRFS', INFO, 0,
$ UPLO // TRANS // DIAG, N, N, -1,
$ -1, NRHS, IMAT, NFAIL, NERRS,
$ NOUT )
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 4 ) )
CALL DTPT05( UPLO, TRANS, DIAG, N, NRHS, AP, B,
$ LDA, X, LDA, XACT, LDA, RWORK,
$ RWORK( NRHS+1 ), RESULT( 5 ) )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 20 K = 2, 6
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )UPLO, TRANS, DIAG,
$ N, NRHS, IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
20 CONTINUE
NRUN = NRUN + 5
30 CONTINUE
40 CONTINUE
*
*+ TEST 7
* Get an estimate of RCOND = 1/CNDNUM.
*
DO 50 ITRAN = 1, 2
IF( ITRAN.EQ.1 ) THEN
NORM = 'O'
RCONDC = RCONDO
ELSE
NORM = 'I'
RCONDC = RCONDI
END IF
*
SRNAMT = 'DTPCON'
CALL DTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK,
$ IWORK, INFO )
*
* Check error code from DTPCON.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DTPCON', INFO, 0,
$ NORM // UPLO // DIAG, N, N, -1, -1,
$ -1, IMAT, NFAIL, NERRS, NOUT )
*
CALL DTPT06( RCOND, RCONDC, UPLO, DIAG, N, AP, RWORK,
$ RESULT( 7 ) )
*
* Print the test ratio if it is .GE. THRESH.
*
IF( RESULT( 7 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9997 ) 'DTPCON', NORM, UPLO,
$ DIAG, N, IMAT, 7, RESULT( 7 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
50 CONTINUE
60 CONTINUE
70 CONTINUE
*
* Use pathological test matrices to test DLATPS.
*
DO 100 IMAT = NTYPE1 + 1, NTYPES
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 100
*
DO 90 IUPLO = 1, 2
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
UPLO = UPLOS( IUPLO )
DO 80 ITRAN = 1, NTRAN
*
* Do for op(A) = A, A**T, or A**H.
*
TRANS = TRANSS( ITRAN )
*
* Call DLATTP to generate a triangular test matrix.
*
SRNAMT = 'DLATTP'
CALL DLATTP( IMAT, UPLO, TRANS, DIAG, ISEED, N, AP, X,
$ WORK, INFO )
*
*+ TEST 8
* Solve the system op(A)*x = b.
*
SRNAMT = 'DLATPS'
CALL DCOPY( N, X, 1, B, 1 )
CALL DLATPS( UPLO, TRANS, DIAG, 'N', N, AP, B, SCALE,
$ RWORK, INFO )
*
* Check error code from DLATPS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DLATPS', INFO, 0,
$ UPLO // TRANS // DIAG // 'N', N, N,
$ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
CALL DTPT03( UPLO, TRANS, DIAG, N, 1, AP, SCALE,
$ RWORK, ONE, B, LDA, X, LDA, WORK,
$ RESULT( 8 ) )
*
*+ TEST 9
* Solve op(A)*x = b again with NORMIN = 'Y'.
*
CALL DCOPY( N, X, 1, B( N+1 ), 1 )
CALL DLATPS( UPLO, TRANS, DIAG, 'Y', N, AP, B( N+1 ),
$ SCALE, RWORK, INFO )
*
* Check error code from DLATPS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DLATPS', INFO, 0,
$ UPLO // TRANS // DIAG // 'Y', N, N,
$ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
CALL DTPT03( UPLO, TRANS, DIAG, N, 1, AP, SCALE,
$ RWORK, ONE, B( N+1 ), LDA, X, LDA, WORK,
$ RESULT( 9 ) )
*
* Print information about the tests that did not pass
* the threshold.
*
IF( RESULT( 8 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9996 )'DLATPS', UPLO, TRANS,
$ DIAG, 'N', N, IMAT, 8, RESULT( 8 )
NFAIL = NFAIL + 1
END IF
IF( RESULT( 9 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9996 )'DLATPS', UPLO, TRANS,
$ DIAG, 'Y', N, IMAT, 9, RESULT( 9 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 2
80 CONTINUE
90 CONTINUE
100 CONTINUE
110 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' UPLO=''', A1, ''', DIAG=''', A1, ''', N=', I5,
$ ', type ', I2, ', test(', I2, ')= ', G12.5 )
9998 FORMAT( ' UPLO=''', A1, ''', TRANS=''', A1, ''', DIAG=''', A1,
$ ''', N=', I5, ''', NRHS=', I5, ', type ', I2, ', test(',
$ I2, ')= ', G12.5 )
9997 FORMAT( 1X, A6, '( ''', A1, ''', ''', A1, ''', ''', A1, ''',',
$ I5, ', ... ), type ', I2, ', test(', I2, ')=', G12.5 )
9996 FORMAT( 1X, A6, '( ''', A1, ''', ''', A1, ''', ''', A1, ''', ''',
$ A1, ''',', I5, ', ... ), type ', I2, ', test(', I2, ')=',
$ G12.5 )
RETURN
*
* End of DCHKTP
*
END
SUBROUTINE DCHKTR( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
$ THRESH, TSTERR, NMAX, A, AINV, B, X, XACT,
$ WORK, RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NMAX, NN, NNB, NNS, NOUT
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
DOUBLE PRECISION A( * ), AINV( * ), B( * ), RWORK( * ),
$ WORK( * ), X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* DCHKTR tests DTRTRI, -TRS, -RFS, and -CON, and DLATRS
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NNB (input) INTEGER
* The number of values of NB contained in the vector NBVAL.
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The leading dimension of the work arrays.
* NMAX >= the maximum value of N in NVAL.
*
* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
* where NSMAX is the largest entry in NSVAL.
*
* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
*
* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension
* (NMAX*max(3,NSMAX))
*
* RWORK (workspace) DOUBLE PRECISION array, dimension
* (max(NMAX,2*NSMAX))
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTYPE1, NTYPES
PARAMETER ( NTYPE1 = 10, NTYPES = 18 )
INTEGER NTESTS
PARAMETER ( NTESTS = 9 )
INTEGER NTRAN
PARAMETER ( NTRAN = 3 )
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
CHARACTER DIAG, NORM, TRANS, UPLO, XTYPE
CHARACTER*3 PATH
INTEGER I, IDIAG, IMAT, IN, INB, INFO, IRHS, ITRAN,
$ IUPLO, K, LDA, N, NB, NERRS, NFAIL, NRHS, NRUN
DOUBLE PRECISION AINVNM, ANORM, DUMMY, RCOND, RCONDC, RCONDI,
$ RCONDO, SCALE
* ..
* .. Local Arrays ..
CHARACTER TRANSS( NTRAN ), UPLOS( 2 )
INTEGER ISEED( 4 ), ISEEDY( 4 )
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLANTR
EXTERNAL LSAME, DLANTR
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, DCOPY, DERRTR, DGET04,
$ DLACPY, DLARHS, DLATRS, DLATTR, DTRCON, DTRRFS,
$ DTRT01, DTRT02, DTRT03, DTRT05, DTRT06, DTRTRI,
$ DTRTRS, XLAENV
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, IOUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, IOUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
DATA UPLOS / 'U', 'L' / , TRANSS / 'N', 'T', 'C' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'TR'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL DERRTR( PATH, NOUT )
INFOT = 0
CALL XLAENV( 2, 2 )
*
DO 120 IN = 1, NN
*
* Do for each value of N in NVAL
*
N = NVAL( IN )
LDA = MAX( 1, N )
XTYPE = 'N'
*
DO 80 IMAT = 1, NTYPE1
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 80
*
DO 70 IUPLO = 1, 2
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
UPLO = UPLOS( IUPLO )
*
* Call DLATTR to generate a triangular test matrix.
*
SRNAMT = 'DLATTR'
CALL DLATTR( IMAT, UPLO, 'No transpose', DIAG, ISEED, N,
$ A, LDA, X, WORK, INFO )
*
* Set IDIAG = 1 for non-unit matrices, 2 for unit.
*
IF( LSAME( DIAG, 'N' ) ) THEN
IDIAG = 1
ELSE
IDIAG = 2
END IF
*
DO 60 INB = 1, NNB
*
* Do for each blocksize in NBVAL
*
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
*
*+ TEST 1
* Form the inverse of A.
*
CALL DLACPY( UPLO, N, N, A, LDA, AINV, LDA )
SRNAMT = 'DTRTRI'
CALL DTRTRI( UPLO, DIAG, N, AINV, LDA, INFO )
*
* Check error code from DTRTRI.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DTRTRI', INFO, 0, UPLO // DIAG,
$ N, N, -1, -1, NB, IMAT, NFAIL, NERRS,
$ NOUT )
*
* Compute the infinity-norm condition number of A.
*
ANORM = DLANTR( 'I', UPLO, DIAG, N, N, A, LDA, RWORK )
AINVNM = DLANTR( 'I', UPLO, DIAG, N, N, AINV, LDA,
$ RWORK )
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDI = ONE
ELSE
RCONDI = ( ONE / ANORM ) / AINVNM
END IF
*
* Compute the residual for the triangular matrix times
* its inverse. Also compute the 1-norm condition number
* of A.
*
CALL DTRT01( UPLO, DIAG, N, A, LDA, AINV, LDA, RCONDO,
$ RWORK, RESULT( 1 ) )
*
* Print the test ratio if it is .GE. THRESH.
*
IF( RESULT( 1 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )UPLO, DIAG, N, NB, IMAT,
$ 1, RESULT( 1 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
*
* Skip remaining tests if not the first block size.
*
IF( INB.NE.1 )
$ GO TO 60
*
DO 40 IRHS = 1, NNS
NRHS = NSVAL( IRHS )
XTYPE = 'N'
*
DO 30 ITRAN = 1, NTRAN
*
* Do for op(A) = A, A**T, or A**H.
*
TRANS = TRANSS( ITRAN )
IF( ITRAN.EQ.1 ) THEN
NORM = 'O'
RCONDC = RCONDO
ELSE
NORM = 'I'
RCONDC = RCONDI
END IF
*
*+ TEST 2
* Solve and compute residual for op(A)*x = b.
*
SRNAMT = 'DLARHS'
CALL DLARHS( PATH, XTYPE, UPLO, TRANS, N, N, 0,
$ IDIAG, NRHS, A, LDA, XACT, LDA, B,
$ LDA, ISEED, INFO )
XTYPE = 'C'
CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
SRNAMT = 'DTRTRS'
CALL DTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA,
$ X, LDA, INFO )
*
* Check error code from DTRTRS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DTRTRS', INFO, 0,
$ UPLO // TRANS // DIAG, N, N, -1,
$ -1, NRHS, IMAT, NFAIL, NERRS,
$ NOUT )
*
* This line is needed on a Sun SPARCstation.
*
IF( N.GT.0 )
$ DUMMY = A( 1 )
*
CALL DTRT02( UPLO, TRANS, DIAG, N, NRHS, A, LDA,
$ X, LDA, B, LDA, WORK, RESULT( 2 ) )
*
*+ TEST 3
* Check solution from generated exact solution.
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
*
*+ TESTS 4, 5, and 6
* Use iterative refinement to improve the solution
* and compute error bounds.
*
SRNAMT = 'DTRRFS'
CALL DTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA,
$ B, LDA, X, LDA, RWORK,
$ RWORK( NRHS+1 ), WORK, IWORK,
$ INFO )
*
* Check error code from DTRRFS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DTRRFS', INFO, 0,
$ UPLO // TRANS // DIAG, N, N, -1,
$ -1, NRHS, IMAT, NFAIL, NERRS,
$ NOUT )
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 4 ) )
CALL DTRT05( UPLO, TRANS, DIAG, N, NRHS, A, LDA,
$ B, LDA, X, LDA, XACT, LDA, RWORK,
$ RWORK( NRHS+1 ), RESULT( 5 ) )
*
* Print information about the tests that did not
* pass the threshold.
*
DO 20 K = 2, 6
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )UPLO, TRANS,
$ DIAG, N, NRHS, IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
20 CONTINUE
NRUN = NRUN + 5
30 CONTINUE
40 CONTINUE
*
*+ TEST 7
* Get an estimate of RCOND = 1/CNDNUM.
*
DO 50 ITRAN = 1, 2
IF( ITRAN.EQ.1 ) THEN
NORM = 'O'
RCONDC = RCONDO
ELSE
NORM = 'I'
RCONDC = RCONDI
END IF
SRNAMT = 'DTRCON'
CALL DTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND,
$ WORK, IWORK, INFO )
*
* Check error code from DTRCON.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DTRCON', INFO, 0,
$ NORM // UPLO // DIAG, N, N, -1, -1,
$ -1, IMAT, NFAIL, NERRS, NOUT )
*
CALL DTRT06( RCOND, RCONDC, UPLO, DIAG, N, A, LDA,
$ RWORK, RESULT( 7 ) )
*
* Print the test ratio if it is .GE. THRESH.
*
IF( RESULT( 7 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9997 )NORM, UPLO, N, IMAT,
$ 7, RESULT( 7 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
50 CONTINUE
60 CONTINUE
70 CONTINUE
80 CONTINUE
*
* Use pathological test matrices to test DLATRS.
*
DO 110 IMAT = NTYPE1 + 1, NTYPES
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 110
*
DO 100 IUPLO = 1, 2
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
UPLO = UPLOS( IUPLO )
DO 90 ITRAN = 1, NTRAN
*
* Do for op(A) = A, A**T, and A**H.
*
TRANS = TRANSS( ITRAN )
*
* Call DLATTR to generate a triangular test matrix.
*
SRNAMT = 'DLATTR'
CALL DLATTR( IMAT, UPLO, TRANS, DIAG, ISEED, N, A,
$ LDA, X, WORK, INFO )
*
*+ TEST 8
* Solve the system op(A)*x = b.
*
SRNAMT = 'DLATRS'
CALL DCOPY( N, X, 1, B, 1 )
CALL DLATRS( UPLO, TRANS, DIAG, 'N', N, A, LDA, B,
$ SCALE, RWORK, INFO )
*
* Check error code from DLATRS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DLATRS', INFO, 0,
$ UPLO // TRANS // DIAG // 'N', N, N,
$ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
CALL DTRT03( UPLO, TRANS, DIAG, N, 1, A, LDA, SCALE,
$ RWORK, ONE, B, LDA, X, LDA, WORK,
$ RESULT( 8 ) )
*
*+ TEST 9
* Solve op(A)*X = b again with NORMIN = 'Y'.
*
CALL DCOPY( N, X, 1, B( N+1 ), 1 )
CALL DLATRS( UPLO, TRANS, DIAG, 'Y', N, A, LDA,
$ B( N+1 ), SCALE, RWORK, INFO )
*
* Check error code from DLATRS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DLATRS', INFO, 0,
$ UPLO // TRANS // DIAG // 'Y', N, N,
$ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
CALL DTRT03( UPLO, TRANS, DIAG, N, 1, A, LDA, SCALE,
$ RWORK, ONE, B( N+1 ), LDA, X, LDA, WORK,
$ RESULT( 9 ) )
*
* Print information about the tests that did not pass
* the threshold.
*
IF( RESULT( 8 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9996 )'DLATRS', UPLO, TRANS,
$ DIAG, 'N', N, IMAT, 8, RESULT( 8 )
NFAIL = NFAIL + 1
END IF
IF( RESULT( 9 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9996 )'DLATRS', UPLO, TRANS,
$ DIAG, 'Y', N, IMAT, 9, RESULT( 9 )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 2
90 CONTINUE
100 CONTINUE
110 CONTINUE
120 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' UPLO=''', A1, ''', DIAG=''', A1, ''', N=', I5, ', NB=',
$ I4, ', type ', I2, ', test(', I2, ')= ', G12.5 )
9998 FORMAT( ' UPLO=''', A1, ''', TRANS=''', A1, ''', DIAG=''', A1,
$ ''', N=', I5, ', NB=', I4, ', type ', I2, ',
$ test(', I2, ')= ', G12.5 )
9997 FORMAT( ' NORM=''', A1, ''', UPLO =''', A1, ''', N=', I5, ',',
$ 11X, ' type ', I2, ', test(', I2, ')=', G12.5 )
9996 FORMAT( 1X, A6, '( ''', A1, ''', ''', A1, ''', ''', A1, ''', ''',
$ A1, ''',', I5, ', ... ), type ', I2, ', test(', I2, ')=',
$ G12.5 )
RETURN
*
* End of DCHKTR
*
END
SUBROUTINE DCHKTZ( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A,
$ COPYA, S, COPYS, TAU, WORK, NOUT )
*
* -- LAPACK test routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* January 2007
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NM, NN, NOUT
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER MVAL( * ), NVAL( * )
DOUBLE PRECISION A( * ), COPYA( * ), COPYS( * ), S( * ),
$ TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DCHKTZ tests DTZRQF and STZRZF.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* A (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX)
* where MMAX is the maximum value of M in MVAL and NMAX is the
* maximum value of N in NVAL.
*
* COPYA (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX)
*
* S (workspace) DOUBLE PRECISION array, dimension
* (min(MMAX,NMAX))
*
* COPYS (workspace) DOUBLE PRECISION array, dimension
* (min(MMAX,NMAX))
*
* TAU (workspace) DOUBLE PRECISION array, dimension (MMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension
* (MMAX*NMAX + 4*NMAX + MMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTYPES
PARAMETER ( NTYPES = 3 )
INTEGER NTESTS
PARAMETER ( NTESTS = 6 )
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
CHARACTER*3 PATH
INTEGER I, IM, IMODE, IN, INFO, K, LDA, LWORK, M,
$ MNMIN, MODE, N, NERRS, NFAIL, NRUN
DOUBLE PRECISION EPS
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 ), ISEEDY( 4 )
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DQRT12, DRZT01, DRZT02, DTZT01, DTZT02
EXTERNAL DLAMCH, DQRT12, DRZT01, DRZT02, DTZT01, DTZT02
* ..
* .. External Subroutines ..
EXTERNAL ALAHD, ALASUM, DERRTZ, DGEQR2, DLACPY, DLAORD,
$ DLASET, DLATMS, DTZRQF, DTZRZF
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, IOUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, IOUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'TZ'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
EPS = DLAMCH( 'Epsilon' )
*
* Test the error exits
*
IF( TSTERR )
$ CALL DERRTZ( PATH, NOUT )
INFOT = 0
*
DO 70 IM = 1, NM
*
* Do for each value of M in MVAL.
*
M = MVAL( IM )
LDA = MAX( 1, M )
*
DO 60 IN = 1, NN
*
* Do for each value of N in NVAL for which M .LE. N.
*
N = NVAL( IN )
MNMIN = MIN( M, N )
LWORK = MAX( 1, N*N+4*M+N, M*N+2*MNMIN+4*N )
*
IF( M.LE.N ) THEN
DO 50 IMODE = 1, NTYPES
IF( .NOT.DOTYPE( IMODE ) )
$ GO TO 50
*
* Do for each type of singular value distribution.
* 0: zero matrix
* 1: one small singular value
* 2: exponential distribution
*
MODE = IMODE - 1
*
* Test DTZRQF
*
* Generate test matrix of size m by n using
* singular value distribution indicated by `mode'.
*
IF( MODE.EQ.0 ) THEN
CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA )
DO 20 I = 1, MNMIN
COPYS( I ) = ZERO
20 CONTINUE
ELSE
CALL DLATMS( M, N, 'Uniform', ISEED,
$ 'Nonsymmetric', COPYS, IMODE,
$ ONE / EPS, ONE, M, N, 'No packing', A,
$ LDA, WORK, INFO )
CALL DGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ),
$ INFO )
CALL DLASET( 'Lower', M-1, N, ZERO, ZERO, A( 2 ),
$ LDA )
CALL DLAORD( 'Decreasing', MNMIN, COPYS, 1 )
END IF
*
* Save A and its singular values
*
CALL DLACPY( 'All', M, N, A, LDA, COPYA, LDA )
*
* Call DTZRQF to reduce the upper trapezoidal matrix to
* upper triangular form.
*
SRNAMT = 'DTZRQF'
CALL DTZRQF( M, N, A, LDA, TAU, INFO )
*
* Compute norm(svd(a) - svd(r))
*
RESULT( 1 ) = DQRT12( M, M, A, LDA, COPYS, WORK,
$ LWORK )
*
* Compute norm( A - R*Q )
*
RESULT( 2 ) = DTZT01( M, N, COPYA, A, LDA, TAU, WORK,
$ LWORK )
*
* Compute norm(Q'*Q - I).
*
RESULT( 3 ) = DTZT02( M, N, A, LDA, TAU, WORK, LWORK )
*
* Test DTZRZF
*
* Generate test matrix of size m by n using
* singular value distribution indicated by `mode'.
*
IF( MODE.EQ.0 ) THEN
CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA )
DO 30 I = 1, MNMIN
COPYS( I ) = ZERO
30 CONTINUE
ELSE
CALL DLATMS( M, N, 'Uniform', ISEED,
$ 'Nonsymmetric', COPYS, IMODE,
$ ONE / EPS, ONE, M, N, 'No packing', A,
$ LDA, WORK, INFO )
CALL DGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ),
$ INFO )
CALL DLASET( 'Lower', M-1, N, ZERO, ZERO, A( 2 ),
$ LDA )
CALL DLAORD( 'Decreasing', MNMIN, COPYS, 1 )
END IF
*
* Save A and its singular values
*
CALL DLACPY( 'All', M, N, A, LDA, COPYA, LDA )
*
* Call DTZRZF to reduce the upper trapezoidal matrix to
* upper triangular form.
*
SRNAMT = 'DTZRZF'
CALL DTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* Compute norm(svd(a) - svd(r))
*
RESULT( 4 ) = DQRT12( M, M, A, LDA, COPYS, WORK,
$ LWORK )
*
* Compute norm( A - R*Q )
*
RESULT( 5 ) = DRZT01( M, N, COPYA, A, LDA, TAU, WORK,
$ LWORK )
*
* Compute norm(Q'*Q - I).
*
RESULT( 6 ) = DRZT02( M, N, A, LDA, TAU, WORK, LWORK )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 40 K = 1, 6
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )M, N, IMODE, K,
$ RESULT( K )
NFAIL = NFAIL + 1
END IF
40 CONTINUE
NRUN = NRUN + 6
50 CONTINUE
END IF
60 CONTINUE
70 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' M =', I5, ', N =', I5, ', type ', I2, ', test ', I2,
$ ', ratio =', G12.5 )
*
* End if DCHKTZ
*
END
SUBROUTINE DDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA,
$ AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK,
$ RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER LA, LAFB, NN, NOUT, NRHS
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NVAL( * )
DOUBLE PRECISION A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ),
$ RWORK( * ), S( * ), WORK( * ), X( * ),
$ XACT( * )
* ..
*
* Purpose
* =======
*
* DDRVGB tests the driver routines DGBSV and -SVX.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NRHS (input) INTEGER
* The number of right hand side vectors to be generated for
* each linear system.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* A (workspace) DOUBLE PRECISION array, dimension (LA)
*
* LA (input) INTEGER
* The length of the array A. LA >= (2*NMAX-1)*NMAX
* where NMAX is the largest entry in NVAL.
*
* AFB (workspace) DOUBLE PRECISION array, dimension (LAFB)
*
* LAFB (input) INTEGER
* The length of the array AFB. LAFB >= (3*NMAX-2)*NMAX
* where NMAX is the largest entry in NVAL.
*
* ASAV (workspace) DOUBLE PRECISION array, dimension (LA)
*
* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* BSAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* S (workspace) DOUBLE PRECISION array, dimension (2*NMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension
* (NMAX*max(3,NRHS,NMAX))
*
* RWORK (workspace) DOUBLE PRECISION array, dimension
* (max(NMAX,2*NRHS))
*
* IWORK (workspace) INTEGER array, dimension (2*NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
INTEGER NTYPES
PARAMETER ( NTYPES = 8 )
INTEGER NTESTS
PARAMETER ( NTESTS = 7 )
INTEGER NTRAN
PARAMETER ( NTRAN = 3 )
* ..
* .. Local Scalars ..
LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT
CHARACTER DIST, EQUED, FACT, TRANS, TYPE, XTYPE
CHARACTER*3 PATH
INTEGER I, I1, I2, IEQUED, IFACT, IKL, IKU, IMAT, IN,
$ INFO, IOFF, ITRAN, IZERO, J, K, K1, KL, KU,
$ LDA, LDAFB, LDB, MODE, N, NB, NBMIN, NERRS,
$ NFACT, NFAIL, NIMAT, NKL, NKU, NRUN, NT
DOUBLE PRECISION AINVNM, AMAX, ANORM, ANORMI, ANORMO, ANRMPV,
$ CNDNUM, COLCND, RCOND, RCONDC, RCONDI, RCONDO,
$ ROLDC, ROLDI, ROLDO, ROWCND, RPVGRW
* ..
* .. Local Arrays ..
CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN )
INTEGER ISEED( 4 ), ISEEDY( 4 )
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DGET06, DLAMCH, DLANGB, DLANGE, DLANTB
EXTERNAL LSAME, DGET06, DLAMCH, DLANGB, DLANGE, DLANTB
* ..
* .. External Subroutines ..
EXTERNAL ALADHD, ALAERH, ALASVM, DERRVX, DGBEQU, DGBSV,
$ DGBSVX, DGBT01, DGBT02, DGBT05, DGBTRF, DGBTRS,
$ DGET04, DLACPY, DLAQGB, DLARHS, DLASET, DLATB4,
$ DLATMS, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
DATA TRANSS / 'N', 'T', 'C' /
DATA FACTS / 'F', 'N', 'E' /
DATA EQUEDS / 'N', 'R', 'C', 'B' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'GB'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL DERRVX( PATH, NOUT )
INFOT = 0
*
* Set the block size and minimum block size for testing.
*
NB = 1
NBMIN = 2
CALL XLAENV( 1, NB )
CALL XLAENV( 2, NBMIN )
*
* Do for each value of N in NVAL
*
DO 150 IN = 1, NN
N = NVAL( IN )
LDB = MAX( N, 1 )
XTYPE = 'N'
*
* Set limits on the number of loop iterations.
*
NKL = MAX( 1, MIN( N, 4 ) )
IF( N.EQ.0 )
$ NKL = 1
NKU = NKL
NIMAT = NTYPES
IF( N.LE.0 )
$ NIMAT = 1
*
DO 140 IKL = 1, NKL
*
* Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes
* it easier to skip redundant values for small values of N.
*
IF( IKL.EQ.1 ) THEN
KL = 0
ELSE IF( IKL.EQ.2 ) THEN
KL = MAX( N-1, 0 )
ELSE IF( IKL.EQ.3 ) THEN
KL = ( 3*N-1 ) / 4
ELSE IF( IKL.EQ.4 ) THEN
KL = ( N+1 ) / 4
END IF
DO 130 IKU = 1, NKU
*
* Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order
* makes it easier to skip redundant values for small
* values of N.
*
IF( IKU.EQ.1 ) THEN
KU = 0
ELSE IF( IKU.EQ.2 ) THEN
KU = MAX( N-1, 0 )
ELSE IF( IKU.EQ.3 ) THEN
KU = ( 3*N-1 ) / 4
ELSE IF( IKU.EQ.4 ) THEN
KU = ( N+1 ) / 4
END IF
*
* Check that A and AFB are big enough to generate this
* matrix.
*
LDA = KL + KU + 1
LDAFB = 2*KL + KU + 1
IF( LDA*N.GT.LA .OR. LDAFB*N.GT.LAFB ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
IF( LDA*N.GT.LA ) THEN
WRITE( NOUT, FMT = 9999 )LA, N, KL, KU,
$ N*( KL+KU+1 )
NERRS = NERRS + 1
END IF
IF( LDAFB*N.GT.LAFB ) THEN
WRITE( NOUT, FMT = 9998 )LAFB, N, KL, KU,
$ N*( 2*KL+KU+1 )
NERRS = NERRS + 1
END IF
GO TO 130
END IF
*
DO 120 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 120
*
* Skip types 2, 3, or 4 if the matrix is too small.
*
ZEROT = IMAT.GE.2 .AND. IMAT.LE.4
IF( ZEROT .AND. N.LT.IMAT-1 )
$ GO TO 120
*
* Set up parameters with DLATB4 and generate a
* test matrix with DLATMS.
*
CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM,
$ MODE, CNDNUM, DIST )
RCONDC = ONE / CNDNUM
*
SRNAMT = 'DLATMS'
CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, 'Z', A, LDA, WORK,
$ INFO )
*
* Check the error code from DLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', N, N,
$ KL, KU, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 120
END IF
*
* For types 2, 3, and 4, zero one or more columns of
* the matrix to test that INFO is returned correctly.
*
IZERO = 0
IF( ZEROT ) THEN
IF( IMAT.EQ.2 ) THEN
IZERO = 1
ELSE IF( IMAT.EQ.3 ) THEN
IZERO = N
ELSE
IZERO = N / 2 + 1
END IF
IOFF = ( IZERO-1 )*LDA
IF( IMAT.LT.4 ) THEN
I1 = MAX( 1, KU+2-IZERO )
I2 = MIN( KL+KU+1, KU+1+( N-IZERO ) )
DO 20 I = I1, I2
A( IOFF+I ) = ZERO
20 CONTINUE
ELSE
DO 40 J = IZERO, N
DO 30 I = MAX( 1, KU+2-J ),
$ MIN( KL+KU+1, KU+1+( N-J ) )
A( IOFF+I ) = ZERO
30 CONTINUE
IOFF = IOFF + LDA
40 CONTINUE
END IF
END IF
*
* Save a copy of the matrix A in ASAV.
*
CALL DLACPY( 'Full', KL+KU+1, N, A, LDA, ASAV, LDA )
*
DO 110 IEQUED = 1, 4
EQUED = EQUEDS( IEQUED )
IF( IEQUED.EQ.1 ) THEN
NFACT = 3
ELSE
NFACT = 1
END IF
*
DO 100 IFACT = 1, NFACT
FACT = FACTS( IFACT )
PREFAC = LSAME( FACT, 'F' )
NOFACT = LSAME( FACT, 'N' )
EQUIL = LSAME( FACT, 'E' )
*
IF( ZEROT ) THEN
IF( PREFAC )
$ GO TO 100
RCONDO = ZERO
RCONDI = ZERO
*
ELSE IF( .NOT.NOFACT ) THEN
*
* Compute the condition number for comparison
* with the value returned by DGESVX (FACT =
* 'N' reuses the condition number from the
* previous iteration with FACT = 'F').
*
CALL DLACPY( 'Full', KL+KU+1, N, ASAV, LDA,
$ AFB( KL+1 ), LDAFB )
IF( EQUIL .OR. IEQUED.GT.1 ) THEN
*
* Compute row and column scale factors to
* equilibrate the matrix A.
*
CALL DGBEQU( N, N, KL, KU, AFB( KL+1 ),
$ LDAFB, S, S( N+1 ), ROWCND,
$ COLCND, AMAX, INFO )
IF( INFO.EQ.0 .AND. N.GT.0 ) THEN
IF( LSAME( EQUED, 'R' ) ) THEN
ROWCND = ZERO
COLCND = ONE
ELSE IF( LSAME( EQUED, 'C' ) ) THEN
ROWCND = ONE
COLCND = ZERO
ELSE IF( LSAME( EQUED, 'B' ) ) THEN
ROWCND = ZERO
COLCND = ZERO
END IF
*
* Equilibrate the matrix.
*
CALL DLAQGB( N, N, KL, KU, AFB( KL+1 ),
$ LDAFB, S, S( N+1 ),
$ ROWCND, COLCND, AMAX,
$ EQUED )
END IF
END IF
*
* Save the condition number of the
* non-equilibrated system for use in DGET04.
*
IF( EQUIL ) THEN
ROLDO = RCONDO
ROLDI = RCONDI
END IF
*
* Compute the 1-norm and infinity-norm of A.
*
ANORMO = DLANGB( '1', N, KL, KU, AFB( KL+1 ),
$ LDAFB, RWORK )
ANORMI = DLANGB( 'I', N, KL, KU, AFB( KL+1 ),
$ LDAFB, RWORK )
*
* Factor the matrix A.
*
CALL DGBTRF( N, N, KL, KU, AFB, LDAFB, IWORK,
$ INFO )
*
* Form the inverse of A.
*
CALL DLASET( 'Full', N, N, ZERO, ONE, WORK,
$ LDB )
SRNAMT = 'DGBTRS'
CALL DGBTRS( 'No transpose', N, KL, KU, N,
$ AFB, LDAFB, IWORK, WORK, LDB,
$ INFO )
*
* Compute the 1-norm condition number of A.
*
AINVNM = DLANGE( '1', N, N, WORK, LDB,
$ RWORK )
IF( ANORMO.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDO = ONE
ELSE
RCONDO = ( ONE / ANORMO ) / AINVNM
END IF
*
* Compute the infinity-norm condition number
* of A.
*
AINVNM = DLANGE( 'I', N, N, WORK, LDB,
$ RWORK )
IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDI = ONE
ELSE
RCONDI = ( ONE / ANORMI ) / AINVNM
END IF
END IF
*
DO 90 ITRAN = 1, NTRAN
*
* Do for each value of TRANS.
*
TRANS = TRANSS( ITRAN )
IF( ITRAN.EQ.1 ) THEN
RCONDC = RCONDO
ELSE
RCONDC = RCONDI
END IF
*
* Restore the matrix A.
*
CALL DLACPY( 'Full', KL+KU+1, N, ASAV, LDA,
$ A, LDA )
*
* Form an exact solution and set the right hand
* side.
*
SRNAMT = 'DLARHS'
CALL DLARHS( PATH, XTYPE, 'Full', TRANS, N,
$ N, KL, KU, NRHS, A, LDA, XACT,
$ LDB, B, LDB, ISEED, INFO )
XTYPE = 'C'
CALL DLACPY( 'Full', N, NRHS, B, LDB, BSAV,
$ LDB )
*
IF( NOFACT .AND. ITRAN.EQ.1 ) THEN
*
* --- Test DGBSV ---
*
* Compute the LU factorization of the matrix
* and solve the system.
*
CALL DLACPY( 'Full', KL+KU+1, N, A, LDA,
$ AFB( KL+1 ), LDAFB )
CALL DLACPY( 'Full', N, NRHS, B, LDB, X,
$ LDB )
*
SRNAMT = 'DGBSV '
CALL DGBSV( N, KL, KU, NRHS, AFB, LDAFB,
$ IWORK, X, LDB, INFO )
*
* Check error code from DGBSV .
*
IF( INFO.NE.IZERO )
$ CALL ALAERH( PATH, 'DGBSV ', INFO,
$ IZERO, ' ', N, N, KL, KU,
$ NRHS, IMAT, NFAIL, NERRS,
$ NOUT )
*
* Reconstruct matrix from factors and
* compute residual.
*
CALL DGBT01( N, N, KL, KU, A, LDA, AFB,
$ LDAFB, IWORK, WORK,
$ RESULT( 1 ) )
NT = 1
IF( IZERO.EQ.0 ) THEN
*
* Compute residual of the computed
* solution.
*
CALL DLACPY( 'Full', N, NRHS, B, LDB,
$ WORK, LDB )
CALL DGBT02( 'No transpose', N, N, KL,
$ KU, NRHS, A, LDA, X, LDB,
$ WORK, LDB, RESULT( 2 ) )
*
* Check solution from generated exact
* solution.
*
CALL DGET04( N, NRHS, X, LDB, XACT,
$ LDB, RCONDC, RESULT( 3 ) )
NT = 3
END IF
*
* Print information about the tests that did
* not pass the threshold.
*
DO 50 K = 1, NT
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
WRITE( NOUT, FMT = 9997 )'DGBSV ',
$ N, KL, KU, IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
50 CONTINUE
NRUN = NRUN + NT
END IF
*
* --- Test DGBSVX ---
*
IF( .NOT.PREFAC )
$ CALL DLASET( 'Full', 2*KL+KU+1, N, ZERO,
$ ZERO, AFB, LDAFB )
CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, X,
$ LDB )
IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN
*
* Equilibrate the matrix if FACT = 'F' and
* EQUED = 'R', 'C', or 'B'.
*
CALL DLAQGB( N, N, KL, KU, A, LDA, S,
$ S( N+1 ), ROWCND, COLCND,
$ AMAX, EQUED )
END IF
*
* Solve the system and compute the condition
* number and error bounds using DGBSVX.
*
SRNAMT = 'DGBSVX'
CALL DGBSVX( FACT, TRANS, N, KL, KU, NRHS, A,
$ LDA, AFB, LDAFB, IWORK, EQUED,
$ S, S( N+1 ), B, LDB, X, LDB,
$ RCOND, RWORK, RWORK( NRHS+1 ),
$ WORK, IWORK( N+1 ), INFO )
*
* Check the error code from DGBSVX.
*
IF( INFO.NE.IZERO )
$ CALL ALAERH( PATH, 'DGBSVX', INFO, IZERO,
$ FACT // TRANS, N, N, KL, KU,
$ NRHS, IMAT, NFAIL, NERRS,
$ NOUT )
*
* Compare WORK(1) from DGBSVX with the computed
* reciprocal pivot growth factor RPVGRW
*
IF( INFO.NE.0 ) THEN
ANRMPV = ZERO
DO 70 J = 1, INFO
DO 60 I = MAX( KU+2-J, 1 ),
$ MIN( N+KU+1-J, KL+KU+1 )
ANRMPV = MAX( ANRMPV,
$ ABS( A( I+( J-1 )*LDA ) ) )
60 CONTINUE
70 CONTINUE
RPVGRW = DLANTB( 'M', 'U', 'N', INFO,
$ MIN( INFO-1, KL+KU ),
$ AFB( MAX( 1, KL+KU+2-INFO ) ),
$ LDAFB, WORK )
IF( RPVGRW.EQ.ZERO ) THEN
RPVGRW = ONE
ELSE
RPVGRW = ANRMPV / RPVGRW
END IF
ELSE
RPVGRW = DLANTB( 'M', 'U', 'N', N, KL+KU,
$ AFB, LDAFB, WORK )
IF( RPVGRW.EQ.ZERO ) THEN
RPVGRW = ONE
ELSE
RPVGRW = DLANGB( 'M', N, KL, KU, A,
$ LDA, WORK ) / RPVGRW
END IF
END IF
RESULT( 7 ) = ABS( RPVGRW-WORK( 1 ) ) /
$ MAX( WORK( 1 ), RPVGRW ) /
$ DLAMCH( 'E' )
*
IF( .NOT.PREFAC ) THEN
*
* Reconstruct matrix from factors and
* compute residual.
*
CALL DGBT01( N, N, KL, KU, A, LDA, AFB,
$ LDAFB, IWORK, WORK,
$ RESULT( 1 ) )
K1 = 1
ELSE
K1 = 2
END IF
*
IF( INFO.EQ.0 ) THEN
TRFCON = .FALSE.
*
* Compute residual of the computed solution.
*
CALL DLACPY( 'Full', N, NRHS, BSAV, LDB,
$ WORK, LDB )
CALL DGBT02( TRANS, N, N, KL, KU, NRHS,
$ ASAV, LDA, X, LDB, WORK, LDB,
$ RESULT( 2 ) )
*
* Check solution from generated exact
* solution.
*
IF( NOFACT .OR. ( PREFAC .AND.
$ LSAME( EQUED, 'N' ) ) ) THEN
CALL DGET04( N, NRHS, X, LDB, XACT,
$ LDB, RCONDC, RESULT( 3 ) )
ELSE
IF( ITRAN.EQ.1 ) THEN
ROLDC = ROLDO
ELSE
ROLDC = ROLDI
END IF
CALL DGET04( N, NRHS, X, LDB, XACT,
$ LDB, ROLDC, RESULT( 3 ) )
END IF
*
* Check the error bounds from iterative
* refinement.
*
CALL DGBT05( TRANS, N, KL, KU, NRHS, ASAV,
$ LDA, B, LDB, X, LDB, XACT,
$ LDB, RWORK, RWORK( NRHS+1 ),
$ RESULT( 4 ) )
ELSE
TRFCON = .TRUE.
END IF
*
* Compare RCOND from DGBSVX with the computed
* value in RCONDC.
*
RESULT( 6 ) = DGET06( RCOND, RCONDC )
*
* Print information about the tests that did
* not pass the threshold.
*
IF( .NOT.TRFCON ) THEN
DO 80 K = K1, NTESTS
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
IF( PREFAC ) THEN
WRITE( NOUT, FMT = 9995 )
$ 'DGBSVX', FACT, TRANS, N, KL,
$ KU, EQUED, IMAT, K,
$ RESULT( K )
ELSE
WRITE( NOUT, FMT = 9996 )
$ 'DGBSVX', FACT, TRANS, N, KL,
$ KU, IMAT, K, RESULT( K )
END IF
NFAIL = NFAIL + 1
END IF
80 CONTINUE
NRUN = NRUN + 7 - K1
ELSE
IF( RESULT( 1 ).GE.THRESH .AND. .NOT.
$ PREFAC ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
IF( PREFAC ) THEN
WRITE( NOUT, FMT = 9995 )'DGBSVX',
$ FACT, TRANS, N, KL, KU, EQUED,
$ IMAT, 1, RESULT( 1 )
ELSE
WRITE( NOUT, FMT = 9996 )'DGBSVX',
$ FACT, TRANS, N, KL, KU, IMAT, 1,
$ RESULT( 1 )
END IF
NFAIL = NFAIL + 1
NRUN = NRUN + 1
END IF
IF( RESULT( 6 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
IF( PREFAC ) THEN
WRITE( NOUT, FMT = 9995 )'DGBSVX',
$ FACT, TRANS, N, KL, KU, EQUED,
$ IMAT, 6, RESULT( 6 )
ELSE
WRITE( NOUT, FMT = 9996 )'DGBSVX',
$ FACT, TRANS, N, KL, KU, IMAT, 6,
$ RESULT( 6 )
END IF
NFAIL = NFAIL + 1
NRUN = NRUN + 1
END IF
IF( RESULT( 7 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
IF( PREFAC ) THEN
WRITE( NOUT, FMT = 9995 )'DGBSVX',
$ FACT, TRANS, N, KL, KU, EQUED,
$ IMAT, 7, RESULT( 7 )
ELSE
WRITE( NOUT, FMT = 9996 )'DGBSVX',
$ FACT, TRANS, N, KL, KU, IMAT, 7,
$ RESULT( 7 )
END IF
NFAIL = NFAIL + 1
NRUN = NRUN + 1
END IF
*
END IF
90 CONTINUE
100 CONTINUE
110 CONTINUE
120 CONTINUE
130 CONTINUE
140 CONTINUE
150 CONTINUE
*
* Print a summary of the results.
*
CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' *** In DDRVGB, LA=', I5, ' is too small for N=', I5,
$ ', KU=', I5, ', KL=', I5, / ' ==> Increase LA to at least ',
$ I5 )
9998 FORMAT( ' *** In DDRVGB, LAFB=', I5, ' is too small for N=', I5,
$ ', KU=', I5, ', KL=', I5, /
$ ' ==> Increase LAFB to at least ', I5 )
9997 FORMAT( 1X, A6, ', N=', I5, ', KL=', I5, ', KU=', I5, ', type ',
$ I1, ', test(', I1, ')=', G12.5 )
9996 FORMAT( 1X, A6, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',',
$ I5, ',...), type ', I1, ', test(', I1, ')=', G12.5 )
9995 FORMAT( 1X, A6, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',',
$ I5, ',...), EQUED=''', A1, ''', type ', I1, ', test(', I1,
$ ')=', G12.5 )
*
RETURN
*
* End of DDRVGB
*
END
SUBROUTINE DDRVGE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
$ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK,
$ RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NMAX, NN, NOUT, NRHS
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NVAL( * )
DOUBLE PRECISION A( * ), AFAC( * ), ASAV( * ), B( * ),
$ BSAV( * ), RWORK( * ), S( * ), WORK( * ),
$ X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* DDRVGE tests the driver routines DGESV and -SVX.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NRHS (input) INTEGER
* The number of right hand side vectors to be generated for
* each linear system.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for N, used in dimensioning the
* work arrays.
*
* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* ASAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* BSAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* S (workspace) DOUBLE PRECISION array, dimension (2*NMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension
* (NMAX*max(3,NRHS))
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (2*NRHS+NMAX)
*
* IWORK (workspace) INTEGER array, dimension (2*NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
INTEGER NTYPES
PARAMETER ( NTYPES = 11 )
INTEGER NTESTS
PARAMETER ( NTESTS = 7 )
INTEGER NTRAN
PARAMETER ( NTRAN = 3 )
* ..
* .. Local Scalars ..
LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT
CHARACTER DIST, EQUED, FACT, TRANS, TYPE, XTYPE
CHARACTER*3 PATH
INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, ITRAN,
$ IZERO, K, K1, KL, KU, LDA, LWORK, MODE, N, NB,
$ NBMIN, NERRS, NFACT, NFAIL, NIMAT, NRUN, NT
DOUBLE PRECISION AINVNM, AMAX, ANORM, ANORMI, ANORMO, CNDNUM,
$ COLCND, RCOND, RCONDC, RCONDI, RCONDO, ROLDC,
$ ROLDI, ROLDO, ROWCND, RPVGRW
* ..
* .. Local Arrays ..
CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN )
INTEGER ISEED( 4 ), ISEEDY( 4 )
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DGET06, DLAMCH, DLANGE, DLANTR
EXTERNAL LSAME, DGET06, DLAMCH, DLANGE, DLANTR
* ..
* .. External Subroutines ..
EXTERNAL ALADHD, ALAERH, ALASVM, DERRVX, DGEEQU, DGESV,
$ DGESVX, DGET01, DGET02, DGET04, DGET07, DGETRF,
$ DGETRI, DLACPY, DLAQGE, DLARHS, DLASET, DLATB4,
$ DLATMS, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
DATA TRANSS / 'N', 'T', 'C' /
DATA FACTS / 'F', 'N', 'E' /
DATA EQUEDS / 'N', 'R', 'C', 'B' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'GE'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL DERRVX( PATH, NOUT )
INFOT = 0
*
* Set the block size and minimum block size for testing.
*
NB = 1
NBMIN = 2
CALL XLAENV( 1, NB )
CALL XLAENV( 2, NBMIN )
*
* Do for each value of N in NVAL
*
DO 90 IN = 1, NN
N = NVAL( IN )
LDA = MAX( N, 1 )
XTYPE = 'N'
NIMAT = NTYPES
IF( N.LE.0 )
$ NIMAT = 1
*
DO 80 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 80
*
* Skip types 5, 6, or 7 if the matrix size is too small.
*
ZEROT = IMAT.GE.5 .AND. IMAT.LE.7
IF( ZEROT .AND. N.LT.IMAT-4 )
$ GO TO 80
*
* Set up parameters with DLATB4 and generate a test matrix
* with DLATMS.
*
CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
RCONDC = ONE / CNDNUM
*
SRNAMT = 'DLATMS'
CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, CNDNUM,
$ ANORM, KL, KU, 'No packing', A, LDA, WORK,
$ INFO )
*
* Check error code from DLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', N, N, -1, -1,
$ -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 80
END IF
*
* For types 5-7, zero one or more columns of the matrix to
* test that INFO is returned correctly.
*
IF( ZEROT ) THEN
IF( IMAT.EQ.5 ) THEN
IZERO = 1
ELSE IF( IMAT.EQ.6 ) THEN
IZERO = N
ELSE
IZERO = N / 2 + 1
END IF
IOFF = ( IZERO-1 )*LDA
IF( IMAT.LT.7 ) THEN
DO 20 I = 1, N
A( IOFF+I ) = ZERO
20 CONTINUE
ELSE
CALL DLASET( 'Full', N, N-IZERO+1, ZERO, ZERO,
$ A( IOFF+1 ), LDA )
END IF
ELSE
IZERO = 0
END IF
*
* Save a copy of the matrix A in ASAV.
*
CALL DLACPY( 'Full', N, N, A, LDA, ASAV, LDA )
*
DO 70 IEQUED = 1, 4
EQUED = EQUEDS( IEQUED )
IF( IEQUED.EQ.1 ) THEN
NFACT = 3
ELSE
NFACT = 1
END IF
*
DO 60 IFACT = 1, NFACT
FACT = FACTS( IFACT )
PREFAC = LSAME( FACT, 'F' )
NOFACT = LSAME( FACT, 'N' )
EQUIL = LSAME( FACT, 'E' )
*
IF( ZEROT ) THEN
IF( PREFAC )
$ GO TO 60
RCONDO = ZERO
RCONDI = ZERO
*
ELSE IF( .NOT.NOFACT ) THEN
*
* Compute the condition number for comparison with
* the value returned by DGESVX (FACT = 'N' reuses
* the condition number from the previous iteration
* with FACT = 'F').
*
CALL DLACPY( 'Full', N, N, ASAV, LDA, AFAC, LDA )
IF( EQUIL .OR. IEQUED.GT.1 ) THEN
*
* Compute row and column scale factors to
* equilibrate the matrix A.
*
CALL DGEEQU( N, N, AFAC, LDA, S, S( N+1 ),
$ ROWCND, COLCND, AMAX, INFO )
IF( INFO.EQ.0 .AND. N.GT.0 ) THEN
IF( LSAME( EQUED, 'R' ) ) THEN
ROWCND = ZERO
COLCND = ONE
ELSE IF( LSAME( EQUED, 'C' ) ) THEN
ROWCND = ONE
COLCND = ZERO
ELSE IF( LSAME( EQUED, 'B' ) ) THEN
ROWCND = ZERO
COLCND = ZERO
END IF
*
* Equilibrate the matrix.
*
CALL DLAQGE( N, N, AFAC, LDA, S, S( N+1 ),
$ ROWCND, COLCND, AMAX, EQUED )
END IF
END IF
*
* Save the condition number of the non-equilibrated
* system for use in DGET04.
*
IF( EQUIL ) THEN
ROLDO = RCONDO
ROLDI = RCONDI
END IF
*
* Compute the 1-norm and infinity-norm of A.
*
ANORMO = DLANGE( '1', N, N, AFAC, LDA, RWORK )
ANORMI = DLANGE( 'I', N, N, AFAC, LDA, RWORK )
*
* Factor the matrix A.
*
CALL DGETRF( N, N, AFAC, LDA, IWORK, INFO )
*
* Form the inverse of A.
*
CALL DLACPY( 'Full', N, N, AFAC, LDA, A, LDA )
LWORK = NMAX*MAX( 3, NRHS )
CALL DGETRI( N, A, LDA, IWORK, WORK, LWORK, INFO )
*
* Compute the 1-norm condition number of A.
*
AINVNM = DLANGE( '1', N, N, A, LDA, RWORK )
IF( ANORMO.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDO = ONE
ELSE
RCONDO = ( ONE / ANORMO ) / AINVNM
END IF
*
* Compute the infinity-norm condition number of A.
*
AINVNM = DLANGE( 'I', N, N, A, LDA, RWORK )
IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDI = ONE
ELSE
RCONDI = ( ONE / ANORMI ) / AINVNM
END IF
END IF
*
DO 50 ITRAN = 1, NTRAN
*
* Do for each value of TRANS.
*
TRANS = TRANSS( ITRAN )
IF( ITRAN.EQ.1 ) THEN
RCONDC = RCONDO
ELSE
RCONDC = RCONDI
END IF
*
* Restore the matrix A.
*
CALL DLACPY( 'Full', N, N, ASAV, LDA, A, LDA )
*
* Form an exact solution and set the right hand side.
*
SRNAMT = 'DLARHS'
CALL DLARHS( PATH, XTYPE, 'Full', TRANS, N, N, KL,
$ KU, NRHS, A, LDA, XACT, LDA, B, LDA,
$ ISEED, INFO )
XTYPE = 'C'
CALL DLACPY( 'Full', N, NRHS, B, LDA, BSAV, LDA )
*
IF( NOFACT .AND. ITRAN.EQ.1 ) THEN
*
* --- Test DGESV ---
*
* Compute the LU factorization of the matrix and
* solve the system.
*
CALL DLACPY( 'Full', N, N, A, LDA, AFAC, LDA )
CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
SRNAMT = 'DGESV '
CALL DGESV( N, NRHS, AFAC, LDA, IWORK, X, LDA,
$ INFO )
*
* Check error code from DGESV .
*
IF( INFO.NE.IZERO )
$ CALL ALAERH( PATH, 'DGESV ', INFO, IZERO,
$ ' ', N, N, -1, -1, NRHS, IMAT,
$ NFAIL, NERRS, NOUT )
*
* Reconstruct matrix from factors and compute
* residual.
*
CALL DGET01( N, N, A, LDA, AFAC, LDA, IWORK,
$ RWORK, RESULT( 1 ) )
NT = 1
IF( IZERO.EQ.0 ) THEN
*
* Compute residual of the computed solution.
*
CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK,
$ LDA )
CALL DGET02( 'No transpose', N, N, NRHS, A,
$ LDA, X, LDA, WORK, LDA, RWORK,
$ RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA,
$ RCONDC, RESULT( 3 ) )
NT = 3
END IF
*
* Print information about the tests that did not
* pass the threshold.
*
DO 30 K = 1, NT
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )'DGESV ', N,
$ IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
30 CONTINUE
NRUN = NRUN + NT
END IF
*
* --- Test DGESVX ---
*
IF( .NOT.PREFAC )
$ CALL DLASET( 'Full', N, N, ZERO, ZERO, AFAC,
$ LDA )
CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA )
IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN
*
* Equilibrate the matrix if FACT = 'F' and
* EQUED = 'R', 'C', or 'B'.
*
CALL DLAQGE( N, N, A, LDA, S, S( N+1 ), ROWCND,
$ COLCND, AMAX, EQUED )
END IF
*
* Solve the system and compute the condition number
* and error bounds using DGESVX.
*
SRNAMT = 'DGESVX'
CALL DGESVX( FACT, TRANS, N, NRHS, A, LDA, AFAC,
$ LDA, IWORK, EQUED, S, S( N+1 ), B,
$ LDA, X, LDA, RCOND, RWORK,
$ RWORK( NRHS+1 ), WORK, IWORK( N+1 ),
$ INFO )
*
* Check the error code from DGESVX.
*
IF( INFO.NE.IZERO )
$ CALL ALAERH( PATH, 'DGESVX', INFO, IZERO,
$ FACT // TRANS, N, N, -1, -1, NRHS,
$ IMAT, NFAIL, NERRS, NOUT )
*
* Compare WORK(1) from DGESVX with the computed
* reciprocal pivot growth factor RPVGRW
*
IF( INFO.NE.0 ) THEN
RPVGRW = DLANTR( 'M', 'U', 'N', INFO, INFO,
$ AFAC, LDA, WORK )
IF( RPVGRW.EQ.ZERO ) THEN
RPVGRW = ONE
ELSE
RPVGRW = DLANGE( 'M', N, INFO, A, LDA,
$ WORK ) / RPVGRW
END IF
ELSE
RPVGRW = DLANTR( 'M', 'U', 'N', N, N, AFAC, LDA,
$ WORK )
IF( RPVGRW.EQ.ZERO ) THEN
RPVGRW = ONE
ELSE
RPVGRW = DLANGE( 'M', N, N, A, LDA, WORK ) /
$ RPVGRW
END IF
END IF
RESULT( 7 ) = ABS( RPVGRW-WORK( 1 ) ) /
$ MAX( WORK( 1 ), RPVGRW ) /
$ DLAMCH( 'E' )
*
IF( .NOT.PREFAC ) THEN
*
* Reconstruct matrix from factors and compute
* residual.
*
CALL DGET01( N, N, A, LDA, AFAC, LDA, IWORK,
$ RWORK( 2*NRHS+1 ), RESULT( 1 ) )
K1 = 1
ELSE
K1 = 2
END IF
*
IF( INFO.EQ.0 ) THEN
TRFCON = .FALSE.
*
* Compute residual of the computed solution.
*
CALL DLACPY( 'Full', N, NRHS, BSAV, LDA, WORK,
$ LDA )
CALL DGET02( TRANS, N, N, NRHS, ASAV, LDA, X,
$ LDA, WORK, LDA, RWORK( 2*NRHS+1 ),
$ RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED,
$ 'N' ) ) ) THEN
CALL DGET04( N, NRHS, X, LDA, XACT, LDA,
$ RCONDC, RESULT( 3 ) )
ELSE
IF( ITRAN.EQ.1 ) THEN
ROLDC = ROLDO
ELSE
ROLDC = ROLDI
END IF
CALL DGET04( N, NRHS, X, LDA, XACT, LDA,
$ ROLDC, RESULT( 3 ) )
END IF
*
* Check the error bounds from iterative
* refinement.
*
CALL DGET07( TRANS, N, NRHS, ASAV, LDA, B, LDA,
$ X, LDA, XACT, LDA, RWORK,
$ RWORK( NRHS+1 ), RESULT( 4 ) )
ELSE
TRFCON = .TRUE.
END IF
*
* Compare RCOND from DGESVX with the computed value
* in RCONDC.
*
RESULT( 6 ) = DGET06( RCOND, RCONDC )
*
* Print information about the tests that did not pass
* the threshold.
*
IF( .NOT.TRFCON ) THEN
DO 40 K = K1, NTESTS
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
IF( PREFAC ) THEN
WRITE( NOUT, FMT = 9997 )'DGESVX',
$ FACT, TRANS, N, EQUED, IMAT, K,
$ RESULT( K )
ELSE
WRITE( NOUT, FMT = 9998 )'DGESVX',
$ FACT, TRANS, N, IMAT, K, RESULT( K )
END IF
NFAIL = NFAIL + 1
END IF
40 CONTINUE
NRUN = NRUN + 7 - K1
ELSE
IF( RESULT( 1 ).GE.THRESH .AND. .NOT.PREFAC )
$ THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
IF( PREFAC ) THEN
WRITE( NOUT, FMT = 9997 )'DGESVX', FACT,
$ TRANS, N, EQUED, IMAT, 1, RESULT( 1 )
ELSE
WRITE( NOUT, FMT = 9998 )'DGESVX', FACT,
$ TRANS, N, IMAT, 1, RESULT( 1 )
END IF
NFAIL = NFAIL + 1
NRUN = NRUN + 1
END IF
IF( RESULT( 6 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
IF( PREFAC ) THEN
WRITE( NOUT, FMT = 9997 )'DGESVX', FACT,
$ TRANS, N, EQUED, IMAT, 6, RESULT( 6 )
ELSE
WRITE( NOUT, FMT = 9998 )'DGESVX', FACT,
$ TRANS, N, IMAT, 6, RESULT( 6 )
END IF
NFAIL = NFAIL + 1
NRUN = NRUN + 1
END IF
IF( RESULT( 7 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
IF( PREFAC ) THEN
WRITE( NOUT, FMT = 9997 )'DGESVX', FACT,
$ TRANS, N, EQUED, IMAT, 7, RESULT( 7 )
ELSE
WRITE( NOUT, FMT = 9998 )'DGESVX', FACT,
$ TRANS, N, IMAT, 7, RESULT( 7 )
END IF
NFAIL = NFAIL + 1
NRUN = NRUN + 1
END IF
*
END IF
*
50 CONTINUE
60 CONTINUE
70 CONTINUE
80 CONTINUE
90 CONTINUE
*
* Print a summary of the results.
*
CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( 1X, A6, ', N =', I5, ', type ', I2, ', test(', I2, ') =',
$ G12.5 )
9998 FORMAT( 1X, A6, ', FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5,
$ ', type ', I2, ', test(', I1, ')=', G12.5 )
9997 FORMAT( 1X, A6, ', FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5,
$ ', EQUED=''', A1, ''', type ', I2, ', test(', I1, ')=',
$ G12.5 )
RETURN
*
* End of DDRVGE
*
END
SUBROUTINE DDRVGT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, AF,
$ B, X, XACT, WORK, RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NN, NOUT, NRHS
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NVAL( * )
DOUBLE PRECISION A( * ), AF( * ), B( * ), RWORK( * ), WORK( * ),
$ X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* DDRVGT tests DGTSV and -SVX.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* A (workspace) DOUBLE PRECISION array, dimension (NMAX*4)
*
* AF (workspace) DOUBLE PRECISION array, dimension (NMAX*4)
*
* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* WORK (workspace) DOUBLE PRECISION array, dimension
* (NMAX*max(3,NRHS))
*
* RWORK (workspace) DOUBLE PRECISION array, dimension
* (max(NMAX,2*NRHS))
*
* IWORK (workspace) INTEGER array, dimension (2*NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
INTEGER NTYPES
PARAMETER ( NTYPES = 12 )
INTEGER NTESTS
PARAMETER ( NTESTS = 6 )
* ..
* .. Local Scalars ..
LOGICAL TRFCON, ZEROT
CHARACTER DIST, FACT, TRANS, TYPE
CHARACTER*3 PATH
INTEGER I, IFACT, IMAT, IN, INFO, ITRAN, IX, IZERO, J,
$ K, K1, KL, KOFF, KU, LDA, M, MODE, N, NERRS,
$ NFAIL, NIMAT, NRUN, NT
DOUBLE PRECISION AINVNM, ANORM, ANORMI, ANORMO, COND, RCOND,
$ RCONDC, RCONDI, RCONDO
* ..
* .. Local Arrays ..
CHARACTER TRANSS( 3 )
INTEGER ISEED( 4 ), ISEEDY( 4 )
DOUBLE PRECISION RESULT( NTESTS ), Z( 3 )
* ..
* .. External Functions ..
DOUBLE PRECISION DASUM, DGET06, DLANGT
EXTERNAL DASUM, DGET06, DLANGT
* ..
* .. External Subroutines ..
EXTERNAL ALADHD, ALAERH, ALASVM, DCOPY, DERRVX, DGET04,
$ DGTSV, DGTSVX, DGTT01, DGTT02, DGTT05, DGTTRF,
$ DGTTRS, DLACPY, DLAGTM, DLARNV, DLASET, DLATB4,
$ DLATMS, DSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 0, 0, 0, 1 / , TRANSS / 'N', 'T',
$ 'C' /
* ..
* .. Executable Statements ..
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'GT'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL DERRVX( PATH, NOUT )
INFOT = 0
*
DO 140 IN = 1, NN
*
* Do for each value of N in NVAL.
*
N = NVAL( IN )
M = MAX( N-1, 0 )
LDA = MAX( 1, N )
NIMAT = NTYPES
IF( N.LE.0 )
$ NIMAT = 1
*
DO 130 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 130
*
* Set up parameters with DLATB4.
*
CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ COND, DIST )
*
ZEROT = IMAT.GE.8 .AND. IMAT.LE.10
IF( IMAT.LE.6 ) THEN
*
* Types 1-6: generate matrices of known condition number.
*
KOFF = MAX( 2-KU, 3-MAX( 1, N ) )
SRNAMT = 'DLATMS'
CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, COND,
$ ANORM, KL, KU, 'Z', AF( KOFF ), 3, WORK,
$ INFO )
*
* Check the error code from DLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', N, N, KL,
$ KU, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 130
END IF
IZERO = 0
*
IF( N.GT.1 ) THEN
CALL DCOPY( N-1, AF( 4 ), 3, A, 1 )
CALL DCOPY( N-1, AF( 3 ), 3, A( N+M+1 ), 1 )
END IF
CALL DCOPY( N, AF( 2 ), 3, A( M+1 ), 1 )
ELSE
*
* Types 7-12: generate tridiagonal matrices with
* unknown condition numbers.
*
IF( .NOT.ZEROT .OR. .NOT.DOTYPE( 7 ) ) THEN
*
* Generate a matrix with elements from [-1,1].
*
CALL DLARNV( 2, ISEED, N+2*M, A )
IF( ANORM.NE.ONE )
$ CALL DSCAL( N+2*M, ANORM, A, 1 )
ELSE IF( IZERO.GT.0 ) THEN
*
* Reuse the last matrix by copying back the zeroed out
* elements.
*
IF( IZERO.EQ.1 ) THEN
A( N ) = Z( 2 )
IF( N.GT.1 )
$ A( 1 ) = Z( 3 )
ELSE IF( IZERO.EQ.N ) THEN
A( 3*N-2 ) = Z( 1 )
A( 2*N-1 ) = Z( 2 )
ELSE
A( 2*N-2+IZERO ) = Z( 1 )
A( N-1+IZERO ) = Z( 2 )
A( IZERO ) = Z( 3 )
END IF
END IF
*
* If IMAT > 7, set one column of the matrix to 0.
*
IF( .NOT.ZEROT ) THEN
IZERO = 0
ELSE IF( IMAT.EQ.8 ) THEN
IZERO = 1
Z( 2 ) = A( N )
A( N ) = ZERO
IF( N.GT.1 ) THEN
Z( 3 ) = A( 1 )
A( 1 ) = ZERO
END IF
ELSE IF( IMAT.EQ.9 ) THEN
IZERO = N
Z( 1 ) = A( 3*N-2 )
Z( 2 ) = A( 2*N-1 )
A( 3*N-2 ) = ZERO
A( 2*N-1 ) = ZERO
ELSE
IZERO = ( N+1 ) / 2
DO 20 I = IZERO, N - 1
A( 2*N-2+I ) = ZERO
A( N-1+I ) = ZERO
A( I ) = ZERO
20 CONTINUE
A( 3*N-2 ) = ZERO
A( 2*N-1 ) = ZERO
END IF
END IF
*
DO 120 IFACT = 1, 2
IF( IFACT.EQ.1 ) THEN
FACT = 'F'
ELSE
FACT = 'N'
END IF
*
* Compute the condition number for comparison with
* the value returned by DGTSVX.
*
IF( ZEROT ) THEN
IF( IFACT.EQ.1 )
$ GO TO 120
RCONDO = ZERO
RCONDI = ZERO
*
ELSE IF( IFACT.EQ.1 ) THEN
CALL DCOPY( N+2*M, A, 1, AF, 1 )
*
* Compute the 1-norm and infinity-norm of A.
*
ANORMO = DLANGT( '1', N, A, A( M+1 ), A( N+M+1 ) )
ANORMI = DLANGT( 'I', N, A, A( M+1 ), A( N+M+1 ) )
*
* Factor the matrix A.
*
CALL DGTTRF( N, AF, AF( M+1 ), AF( N+M+1 ),
$ AF( N+2*M+1 ), IWORK, INFO )
*
* Use DGTTRS to solve for one column at a time of
* inv(A), computing the maximum column sum as we go.
*
AINVNM = ZERO
DO 40 I = 1, N
DO 30 J = 1, N
X( J ) = ZERO
30 CONTINUE
X( I ) = ONE
CALL DGTTRS( 'No transpose', N, 1, AF, AF( M+1 ),
$ AF( N+M+1 ), AF( N+2*M+1 ), IWORK, X,
$ LDA, INFO )
AINVNM = MAX( AINVNM, DASUM( N, X, 1 ) )
40 CONTINUE
*
* Compute the 1-norm condition number of A.
*
IF( ANORMO.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDO = ONE
ELSE
RCONDO = ( ONE / ANORMO ) / AINVNM
END IF
*
* Use DGTTRS to solve for one column at a time of
* inv(A'), computing the maximum column sum as we go.
*
AINVNM = ZERO
DO 60 I = 1, N
DO 50 J = 1, N
X( J ) = ZERO
50 CONTINUE
X( I ) = ONE
CALL DGTTRS( 'Transpose', N, 1, AF, AF( M+1 ),
$ AF( N+M+1 ), AF( N+2*M+1 ), IWORK, X,
$ LDA, INFO )
AINVNM = MAX( AINVNM, DASUM( N, X, 1 ) )
60 CONTINUE
*
* Compute the infinity-norm condition number of A.
*
IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDI = ONE
ELSE
RCONDI = ( ONE / ANORMI ) / AINVNM
END IF
END IF
*
DO 110 ITRAN = 1, 3
TRANS = TRANSS( ITRAN )
IF( ITRAN.EQ.1 ) THEN
RCONDC = RCONDO
ELSE
RCONDC = RCONDI
END IF
*
* Generate NRHS random solution vectors.
*
IX = 1
DO 70 J = 1, NRHS
CALL DLARNV( 2, ISEED, N, XACT( IX ) )
IX = IX + LDA
70 CONTINUE
*
* Set the right hand side.
*
CALL DLAGTM( TRANS, N, NRHS, ONE, A, A( M+1 ),
$ A( N+M+1 ), XACT, LDA, ZERO, B, LDA )
*
IF( IFACT.EQ.2 .AND. ITRAN.EQ.1 ) THEN
*
* --- Test DGTSV ---
*
* Solve the system using Gaussian elimination with
* partial pivoting.
*
CALL DCOPY( N+2*M, A, 1, AF, 1 )
CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
SRNAMT = 'DGTSV '
CALL DGTSV( N, NRHS, AF, AF( M+1 ), AF( N+M+1 ), X,
$ LDA, INFO )
*
* Check error code from DGTSV .
*
IF( INFO.NE.IZERO )
$ CALL ALAERH( PATH, 'DGTSV ', INFO, IZERO, ' ',
$ N, N, 1, 1, NRHS, IMAT, NFAIL,
$ NERRS, NOUT )
NT = 1
IF( IZERO.EQ.0 ) THEN
*
* Check residual of computed solution.
*
CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK,
$ LDA )
CALL DGTT02( TRANS, N, NRHS, A, A( M+1 ),
$ A( N+M+1 ), X, LDA, WORK, LDA,
$ RWORK, RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
NT = 3
END IF
*
* Print information about the tests that did not pass
* the threshold.
*
DO 80 K = 2, NT
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )'DGTSV ', N, IMAT,
$ K, RESULT( K )
NFAIL = NFAIL + 1
END IF
80 CONTINUE
NRUN = NRUN + NT - 1
END IF
*
* --- Test DGTSVX ---
*
IF( IFACT.GT.1 ) THEN
*
* Initialize AF to zero.
*
DO 90 I = 1, 3*N - 2
AF( I ) = ZERO
90 CONTINUE
END IF
CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA )
*
* Solve the system and compute the condition number and
* error bounds using DGTSVX.
*
SRNAMT = 'DGTSVX'
CALL DGTSVX( FACT, TRANS, N, NRHS, A, A( M+1 ),
$ A( N+M+1 ), AF, AF( M+1 ), AF( N+M+1 ),
$ AF( N+2*M+1 ), IWORK, B, LDA, X, LDA,
$ RCOND, RWORK, RWORK( NRHS+1 ), WORK,
$ IWORK( N+1 ), INFO )
*
* Check the error code from DGTSVX.
*
IF( INFO.NE.IZERO )
$ CALL ALAERH( PATH, 'DGTSVX', INFO, IZERO,
$ FACT // TRANS, N, N, 1, 1, NRHS, IMAT,
$ NFAIL, NERRS, NOUT )
*
IF( IFACT.GE.2 ) THEN
*
* Reconstruct matrix from factors and compute
* residual.
*
CALL DGTT01( N, A, A( M+1 ), A( N+M+1 ), AF,
$ AF( M+1 ), AF( N+M+1 ), AF( N+2*M+1 ),
$ IWORK, WORK, LDA, RWORK, RESULT( 1 ) )
K1 = 1
ELSE
K1 = 2
END IF
*
IF( INFO.EQ.0 ) THEN
TRFCON = .FALSE.
*
* Check residual of computed solution.
*
CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
CALL DGTT02( TRANS, N, NRHS, A, A( M+1 ),
$ A( N+M+1 ), X, LDA, WORK, LDA, RWORK,
$ RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
*
* Check the error bounds from iterative refinement.
*
CALL DGTT05( TRANS, N, NRHS, A, A( M+1 ),
$ A( N+M+1 ), B, LDA, X, LDA, XACT, LDA,
$ RWORK, RWORK( NRHS+1 ), RESULT( 4 ) )
NT = 5
END IF
*
* Print information about the tests that did not pass
* the threshold.
*
DO 100 K = K1, NT
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )'DGTSVX', FACT, TRANS,
$ N, IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
100 CONTINUE
*
* Check the reciprocal of the condition number.
*
RESULT( 6 ) = DGET06( RCOND, RCONDC )
IF( RESULT( 6 ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )'DGTSVX', FACT, TRANS, N,
$ IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + NT - K1 + 2
*
110 CONTINUE
120 CONTINUE
130 CONTINUE
140 CONTINUE
*
* Print a summary of the results.
*
CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( 1X, A6, ', N =', I5, ', type ', I2, ', test ', I2,
$ ', ratio = ', G12.5 )
9998 FORMAT( 1X, A6, ', FACT=''', A1, ''', TRANS=''', A1, ''', N =',
$ I5, ', type ', I2, ', test ', I2, ', ratio = ', G12.5 )
RETURN
*
* End of DDRVGT
*
END
SUBROUTINE DDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB,
$ NBVAL, NXVAL, THRESH, TSTERR, A, COPYA, B,
$ COPYB, C, S, COPYS, WORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* January 2007
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NM, NN, NNB, NNS, NOUT
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ),
$ NVAL( * ), NXVAL( * )
DOUBLE PRECISION A( * ), B( * ), C( * ), COPYA( * ), COPYB( * ),
$ COPYS( * ), S( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DDRVLS tests the least squares driver routines DGELS, DGELSS, DGELSX,
* DGELSY and DGELSD.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
* The matrix of type j is generated as follows:
* j=1: A = U*D*V where U and V are random orthogonal matrices
* and D has random entries (> 0.1) taken from a uniform
* distribution (0,1). A is full rank.
* j=2: The same of 1, but A is scaled up.
* j=3: The same of 1, but A is scaled down.
* j=4: A = U*D*V where U and V are random orthogonal matrices
* and D has 3*min(M,N)/4 random entries (> 0.1) taken
* from a uniform distribution (0,1) and the remaining
* entries set to 0. A is rank-deficient.
* j=5: The same of 4, but A is scaled up.
* j=6: The same of 5, but A is scaled down.
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NNS (input) INTEGER
* The number of values of NRHS contained in the vector NSVAL.
*
* NSVAL (input) INTEGER array, dimension (NNS)
* The values of the number of right hand sides NRHS.
*
* NNB (input) INTEGER
* The number of values of NB and NX contained in the
* vectors NBVAL and NXVAL. The blocking parameters are used
* in pairs (NB,NX).
*
* NBVAL (input) INTEGER array, dimension (NNB)
* The values of the blocksize NB.
*
* NXVAL (input) INTEGER array, dimension (NNB)
* The values of the crossover point NX.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* A (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX)
* where MMAX is the maximum value of M in MVAL and NMAX is the
* maximum value of N in NVAL.
*
* COPYA (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX)
*
* B (workspace) DOUBLE PRECISION array, dimension (MMAX*NSMAX)
* where MMAX is the maximum value of M in MVAL and NSMAX is the
* maximum value of NRHS in NSVAL.
*
* COPYB (workspace) DOUBLE PRECISION array, dimension (MMAX*NSMAX)
*
* C (workspace) DOUBLE PRECISION array, dimension (MMAX*NSMAX)
*
* S (workspace) DOUBLE PRECISION array, dimension
* (min(MMAX,NMAX))
*
* COPYS (workspace) DOUBLE PRECISION array, dimension
* (min(MMAX,NMAX))
*
* WORK (workspace) DOUBLE PRECISION array,
* dimension (MMAX*NMAX + 4*NMAX + MMAX).
*
* IWORK (workspace) INTEGER array, dimension (15*NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTESTS
PARAMETER ( NTESTS = 18 )
INTEGER SMLSIZ
PARAMETER ( SMLSIZ = 25 )
DOUBLE PRECISION ONE, TWO, ZERO
PARAMETER ( ONE = 1.0D0, TWO = 2.0D0, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
CHARACTER TRANS
CHARACTER*3 PATH
INTEGER CRANK, I, IM, IN, INB, INFO, INS, IRANK,
$ ISCALE, ITRAN, ITYPE, J, K, LDA, LDB, LDWORK,
$ LWLSY, LWORK, M, MNMIN, N, NB, NCOLS, NERRS,
$ NFAIL, NLVL, NRHS, NROWS, NRUN, RANK
DOUBLE PRECISION EPS, NORMA, NORMB, RCOND
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 ), ISEEDY( 4 )
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Functions ..
DOUBLE PRECISION DASUM, DLAMCH, DQRT12, DQRT14, DQRT17
EXTERNAL DASUM, DLAMCH, DQRT12, DQRT14, DQRT17
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASVM, DAXPY, DERRLS, DGELS,
$ DGELSD, DGELSS, DGELSX, DGELSY, DGEMM, DLACPY,
$ DLARNV, DLASRT, DQRT13, DQRT15, DQRT16, DSCAL,
$ XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, INT, LOG, MAX, MIN, SQRT
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, IOUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, IOUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'LS'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
EPS = DLAMCH( 'Epsilon' )
*
* Threshold for rank estimation
*
RCOND = SQRT( EPS ) - ( SQRT( EPS )-EPS ) / 2
*
* Test the error exits
*
CALL XLAENV( 2, 2 )
CALL XLAENV( 9, SMLSIZ )
IF( TSTERR )
$ CALL DERRLS( PATH, NOUT )
*
* Print the header if NM = 0 or NN = 0 and THRESH = 0.
*
IF( ( NM.EQ.0 .OR. NN.EQ.0 ) .AND. THRESH.EQ.ZERO )
$ CALL ALAHD( NOUT, PATH )
INFOT = 0
CALL XLAENV( 2, 2 )
CALL XLAENV( 9, SMLSIZ )
*
DO 150 IM = 1, NM
M = MVAL( IM )
LDA = MAX( 1, M )
*
DO 140 IN = 1, NN
N = NVAL( IN )
MNMIN = MIN( M, N )
LDB = MAX( 1, M, N )
*
DO 130 INS = 1, NNS
NRHS = NSVAL( INS )
NLVL = MAX( INT( LOG( MAX( ONE, DBLE( MNMIN ) ) /
$ DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1, 0 )
LWORK = MAX( 1, ( M+NRHS )*( N+2 ), ( N+NRHS )*( M+2 ),
$ M*N+4*MNMIN+MAX( M, N ), 12*MNMIN+2*MNMIN*SMLSIZ+
$ 8*MNMIN*NLVL+MNMIN*NRHS+(SMLSIZ+1)**2 )
*
DO 120 IRANK = 1, 2
DO 110 ISCALE = 1, 3
ITYPE = ( IRANK-1 )*3 + ISCALE
IF( .NOT.DOTYPE( ITYPE ) )
$ GO TO 110
*
IF( IRANK.EQ.1 ) THEN
*
* Test DGELS
*
* Generate a matrix of scaling type ISCALE
*
CALL DQRT13( ISCALE, M, N, COPYA, LDA, NORMA,
$ ISEED )
DO 40 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
CALL XLAENV( 3, NXVAL( INB ) )
*
DO 30 ITRAN = 1, 2
IF( ITRAN.EQ.1 ) THEN
TRANS = 'N'
NROWS = M
NCOLS = N
ELSE
TRANS = 'T'
NROWS = N
NCOLS = M
END IF
LDWORK = MAX( 1, NCOLS )
*
* Set up a consistent rhs
*
IF( NCOLS.GT.0 ) THEN
CALL DLARNV( 2, ISEED, NCOLS*NRHS,
$ WORK )
CALL DSCAL( NCOLS*NRHS,
$ ONE / DBLE( NCOLS ), WORK,
$ 1 )
END IF
CALL DGEMM( TRANS, 'No transpose', NROWS,
$ NRHS, NCOLS, ONE, COPYA, LDA,
$ WORK, LDWORK, ZERO, B, LDB )
CALL DLACPY( 'Full', NROWS, NRHS, B, LDB,
$ COPYB, LDB )
*
* Solve LS or overdetermined system
*
IF( M.GT.0 .AND. N.GT.0 ) THEN
CALL DLACPY( 'Full', M, N, COPYA, LDA,
$ A, LDA )
CALL DLACPY( 'Full', NROWS, NRHS,
$ COPYB, LDB, B, LDB )
END IF
SRNAMT = 'DGELS '
CALL DGELS( TRANS, M, N, NRHS, A, LDA, B,
$ LDB, WORK, LWORK, INFO )
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DGELS ', INFO, 0,
$ TRANS, M, N, NRHS, -1, NB,
$ ITYPE, NFAIL, NERRS,
$ NOUT )
*
* Check correctness of results
*
LDWORK = MAX( 1, NROWS )
IF( NROWS.GT.0 .AND. NRHS.GT.0 )
$ CALL DLACPY( 'Full', NROWS, NRHS,
$ COPYB, LDB, C, LDB )
CALL DQRT16( TRANS, M, N, NRHS, COPYA,
$ LDA, B, LDB, C, LDB, WORK,
$ RESULT( 1 ) )
*
IF( ( ITRAN.EQ.1 .AND. M.GE.N ) .OR.
$ ( ITRAN.EQ.2 .AND. M.LT.N ) ) THEN
*
* Solving LS system
*
RESULT( 2 ) = DQRT17( TRANS, 1, M, N,
$ NRHS, COPYA, LDA, B, LDB,
$ COPYB, LDB, C, WORK,
$ LWORK )
ELSE
*
* Solving overdetermined system
*
RESULT( 2 ) = DQRT14( TRANS, M, N,
$ NRHS, COPYA, LDA, B, LDB,
$ WORK, LWORK )
END IF
*
* Print information about the tests that
* did not pass the threshold.
*
DO 20 K = 1, 2
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )TRANS, M,
$ N, NRHS, NB, ITYPE, K,
$ RESULT( K )
NFAIL = NFAIL + 1
END IF
20 CONTINUE
NRUN = NRUN + 2
30 CONTINUE
40 CONTINUE
END IF
*
* Generate a matrix of scaling type ISCALE and rank
* type IRANK.
*
CALL DQRT15( ISCALE, IRANK, M, N, NRHS, COPYA, LDA,
$ COPYB, LDB, COPYS, RANK, NORMA, NORMB,
$ ISEED, WORK, LWORK )
*
* workspace used: MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M)
*
* Initialize vector IWORK.
*
DO 50 J = 1, N
IWORK( J ) = 0
50 CONTINUE
LDWORK = MAX( 1, M )
*
* Test DGELSX
*
* DGELSX: Compute the minimum-norm solution X
* to min( norm( A * X - B ) ) using a complete
* orthogonal factorization.
*
CALL DLACPY( 'Full', M, N, COPYA, LDA, A, LDA )
CALL DLACPY( 'Full', M, NRHS, COPYB, LDB, B, LDB )
*
SRNAMT = 'DGELSX'
CALL DGELSX( M, N, NRHS, A, LDA, B, LDB, IWORK,
$ RCOND, CRANK, WORK, INFO )
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DGELSX', INFO, 0, ' ', M, N,
$ NRHS, -1, NB, ITYPE, NFAIL, NERRS,
$ NOUT )
*
* workspace used: MAX( MNMIN+3*N, 2*MNMIN+NRHS )
*
* Test 3: Compute relative error in svd
* workspace: M*N + 4*MIN(M,N) + MAX(M,N)
*
RESULT( 3 ) = DQRT12( CRANK, CRANK, A, LDA, COPYS,
$ WORK, LWORK )
*
* Test 4: Compute error in solution
* workspace: M*NRHS + M
*
CALL DLACPY( 'Full', M, NRHS, COPYB, LDB, WORK,
$ LDWORK )
CALL DQRT16( 'No transpose', M, N, NRHS, COPYA,
$ LDA, B, LDB, WORK, LDWORK,
$ WORK( M*NRHS+1 ), RESULT( 4 ) )
*
* Test 5: Check norm of r'*A
* workspace: NRHS*(M+N)
*
RESULT( 5 ) = ZERO
IF( M.GT.CRANK )
$ RESULT( 5 ) = DQRT17( 'No transpose', 1, M, N,
$ NRHS, COPYA, LDA, B, LDB, COPYB,
$ LDB, C, WORK, LWORK )
*
* Test 6: Check if x is in the rowspace of A
* workspace: (M+NRHS)*(N+2)
*
RESULT( 6 ) = ZERO
*
IF( N.GT.CRANK )
$ RESULT( 6 ) = DQRT14( 'No transpose', M, N,
$ NRHS, COPYA, LDA, B, LDB, WORK,
$ LWORK )
*
* Print information about the tests that did not
* pass the threshold.
*
DO 60 K = 3, 6
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )M, N, NRHS, NB,
$ ITYPE, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
60 CONTINUE
NRUN = NRUN + 4
*
* Loop for testing different block sizes.
*
DO 100 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
CALL XLAENV( 3, NXVAL( INB ) )
*
* Test DGELSY
*
* DGELSY: Compute the minimum-norm solution X
* to min( norm( A * X - B ) )
* using the rank-revealing orthogonal
* factorization.
*
* Initialize vector IWORK.
*
DO 70 J = 1, N
IWORK( J ) = 0
70 CONTINUE
*
* Set LWLSY to the adequate value.
*
LWLSY = MAX( 1, MNMIN+2*N+NB*( N+1 ),
$ 2*MNMIN+NB*NRHS )
*
CALL DLACPY( 'Full', M, N, COPYA, LDA, A, LDA )
CALL DLACPY( 'Full', M, NRHS, COPYB, LDB, B,
$ LDB )
*
SRNAMT = 'DGELSY'
CALL DGELSY( M, N, NRHS, A, LDA, B, LDB, IWORK,
$ RCOND, CRANK, WORK, LWLSY, INFO )
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DGELSY', INFO, 0, ' ', M,
$ N, NRHS, -1, NB, ITYPE, NFAIL,
$ NERRS, NOUT )
*
* Test 7: Compute relative error in svd
* workspace: M*N + 4*MIN(M,N) + MAX(M,N)
*
RESULT( 7 ) = DQRT12( CRANK, CRANK, A, LDA,
$ COPYS, WORK, LWORK )
*
* Test 8: Compute error in solution
* workspace: M*NRHS + M
*
CALL DLACPY( 'Full', M, NRHS, COPYB, LDB, WORK,
$ LDWORK )
CALL DQRT16( 'No transpose', M, N, NRHS, COPYA,
$ LDA, B, LDB, WORK, LDWORK,
$ WORK( M*NRHS+1 ), RESULT( 8 ) )
*
* Test 9: Check norm of r'*A
* workspace: NRHS*(M+N)
*
RESULT( 9 ) = ZERO
IF( M.GT.CRANK )
$ RESULT( 9 ) = DQRT17( 'No transpose', 1, M,
$ N, NRHS, COPYA, LDA, B, LDB,
$ COPYB, LDB, C, WORK, LWORK )
*
* Test 10: Check if x is in the rowspace of A
* workspace: (M+NRHS)*(N+2)
*
RESULT( 10 ) = ZERO
*
IF( N.GT.CRANK )
$ RESULT( 10 ) = DQRT14( 'No transpose', M, N,
$ NRHS, COPYA, LDA, B, LDB,
$ WORK, LWORK )
*
* Test DGELSS
*
* DGELSS: Compute the minimum-norm solution X
* to min( norm( A * X - B ) )
* using the SVD.
*
CALL DLACPY( 'Full', M, N, COPYA, LDA, A, LDA )
CALL DLACPY( 'Full', M, NRHS, COPYB, LDB, B,
$ LDB )
SRNAMT = 'DGELSS'
CALL DGELSS( M, N, NRHS, A, LDA, B, LDB, S,
$ RCOND, CRANK, WORK, LWORK, INFO )
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DGELSS', INFO, 0, ' ', M,
$ N, NRHS, -1, NB, ITYPE, NFAIL,
$ NERRS, NOUT )
*
* workspace used: 3*min(m,n) +
* max(2*min(m,n),nrhs,max(m,n))
*
* Test 11: Compute relative error in svd
*
IF( RANK.GT.0 ) THEN
CALL DAXPY( MNMIN, -ONE, COPYS, 1, S, 1 )
RESULT( 11 ) = DASUM( MNMIN, S, 1 ) /
$ DASUM( MNMIN, COPYS, 1 ) /
$ ( EPS*DBLE( MNMIN ) )
ELSE
RESULT( 11 ) = ZERO
END IF
*
* Test 12: Compute error in solution
*
CALL DLACPY( 'Full', M, NRHS, COPYB, LDB, WORK,
$ LDWORK )
CALL DQRT16( 'No transpose', M, N, NRHS, COPYA,
$ LDA, B, LDB, WORK, LDWORK,
$ WORK( M*NRHS+1 ), RESULT( 12 ) )
*
* Test 13: Check norm of r'*A
*
RESULT( 13 ) = ZERO
IF( M.GT.CRANK )
$ RESULT( 13 ) = DQRT17( 'No transpose', 1, M,
$ N, NRHS, COPYA, LDA, B, LDB,
$ COPYB, LDB, C, WORK, LWORK )
*
* Test 14: Check if x is in the rowspace of A
*
RESULT( 14 ) = ZERO
IF( N.GT.CRANK )
$ RESULT( 14 ) = DQRT14( 'No transpose', M, N,
$ NRHS, COPYA, LDA, B, LDB,
$ WORK, LWORK )
*
* Test DGELSD
*
* DGELSD: Compute the minimum-norm solution X
* to min( norm( A * X - B ) ) using a
* divide and conquer SVD.
*
* Initialize vector IWORK.
*
DO 80 J = 1, N
IWORK( J ) = 0
80 CONTINUE
*
CALL DLACPY( 'Full', M, N, COPYA, LDA, A, LDA )
CALL DLACPY( 'Full', M, NRHS, COPYB, LDB, B,
$ LDB )
*
SRNAMT = 'DGELSD'
CALL DGELSD( M, N, NRHS, A, LDA, B, LDB, S,
$ RCOND, CRANK, WORK, LWORK, IWORK,
$ INFO )
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'DGELSD', INFO, 0, ' ', M,
$ N, NRHS, -1, NB, ITYPE, NFAIL,
$ NERRS, NOUT )
*
* Test 15: Compute relative error in svd
*
IF( RANK.GT.0 ) THEN
CALL DAXPY( MNMIN, -ONE, COPYS, 1, S, 1 )
RESULT( 15 ) = DASUM( MNMIN, S, 1 ) /
$ DASUM( MNMIN, COPYS, 1 ) /
$ ( EPS*DBLE( MNMIN ) )
ELSE
RESULT( 15 ) = ZERO
END IF
*
* Test 16: Compute error in solution
*
CALL DLACPY( 'Full', M, NRHS, COPYB, LDB, WORK,
$ LDWORK )
CALL DQRT16( 'No transpose', M, N, NRHS, COPYA,
$ LDA, B, LDB, WORK, LDWORK,
$ WORK( M*NRHS+1 ), RESULT( 16 ) )
*
* Test 17: Check norm of r'*A
*
RESULT( 17 ) = ZERO
IF( M.GT.CRANK )
$ RESULT( 17 ) = DQRT17( 'No transpose', 1, M,
$ N, NRHS, COPYA, LDA, B, LDB,
$ COPYB, LDB, C, WORK, LWORK )
*
* Test 18: Check if x is in the rowspace of A
*
RESULT( 18 ) = ZERO
IF( N.GT.CRANK )
$ RESULT( 18 ) = DQRT14( 'No transpose', M, N,
$ NRHS, COPYA, LDA, B, LDB,
$ WORK, LWORK )
*
* Print information about the tests that did not
* pass the threshold.
*
DO 90 K = 7, NTESTS
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )M, N, NRHS, NB,
$ ITYPE, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
90 CONTINUE
NRUN = NRUN + 12
*
100 CONTINUE
110 CONTINUE
120 CONTINUE
130 CONTINUE
140 CONTINUE
150 CONTINUE
*
* Print a summary of the results.
*
CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' TRANS=''', A1, ''', M=', I5, ', N=', I5, ', NRHS=', I4,
$ ', NB=', I4, ', type', I2, ', test(', I2, ')=', G12.5 )
9998 FORMAT( ' M=', I5, ', N=', I5, ', NRHS=', I4, ', NB=', I4,
$ ', type', I2, ', test(', I2, ')=', G12.5 )
RETURN
*
* End of DDRVLS
*
END
SUBROUTINE DDRVPB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
$ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK,
$ RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NMAX, NN, NOUT, NRHS
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NVAL( * )
DOUBLE PRECISION A( * ), AFAC( * ), ASAV( * ), B( * ),
$ BSAV( * ), RWORK( * ), S( * ), WORK( * ),
$ X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* DDRVPB tests the driver routines DPBSV and -SVX.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* NRHS (input) INTEGER
* The number of right hand side vectors to be generated for
* each linear system.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for N, used in dimensioning the
* work arrays.
*
* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* ASAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* BSAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* S (workspace) DOUBLE PRECISION array, dimension (NMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension
* (NMAX*max(3,NRHS))
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
INTEGER NTYPES, NTESTS
PARAMETER ( NTYPES = 8, NTESTS = 6 )
INTEGER NBW
PARAMETER ( NBW = 4 )
* ..
* .. Local Scalars ..
LOGICAL EQUIL, NOFACT, PREFAC, ZEROT
CHARACTER DIST, EQUED, FACT, PACKIT, TYPE, UPLO, XTYPE
CHARACTER*3 PATH
INTEGER I, I1, I2, IEQUED, IFACT, IKD, IMAT, IN, INFO,
$ IOFF, IUPLO, IW, IZERO, K, K1, KD, KL, KOFF,
$ KU, LDA, LDAB, MODE, N, NB, NBMIN, NERRS,
$ NFACT, NFAIL, NIMAT, NKD, NRUN, NT
DOUBLE PRECISION AINVNM, AMAX, ANORM, CNDNUM, RCOND, RCONDC,
$ ROLDC, SCOND
* ..
* .. Local Arrays ..
CHARACTER EQUEDS( 2 ), FACTS( 3 )
INTEGER ISEED( 4 ), ISEEDY( 4 ), KDVAL( NBW )
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DGET06, DLANGE, DLANSB
EXTERNAL LSAME, DGET06, DLANGE, DLANSB
* ..
* .. External Subroutines ..
EXTERNAL ALADHD, ALAERH, ALASVM, DCOPY, DERRVX, DGET04,
$ DLACPY, DLAQSB, DLARHS, DLASET, DLATB4, DLATMS,
$ DPBEQU, DPBSV, DPBSVX, DPBT01, DPBT02, DPBT05,
$ DPBTRF, DPBTRS, DSWAP, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
DATA FACTS / 'F', 'N', 'E' /
DATA EQUEDS / 'N', 'Y' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'PB'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL DERRVX( PATH, NOUT )
INFOT = 0
KDVAL( 1 ) = 0
*
* Set the block size and minimum block size for testing.
*
NB = 1
NBMIN = 2
CALL XLAENV( 1, NB )
CALL XLAENV( 2, NBMIN )
*
* Do for each value of N in NVAL
*
DO 110 IN = 1, NN
N = NVAL( IN )
LDA = MAX( N, 1 )
XTYPE = 'N'
*
* Set limits on the number of loop iterations.
*
NKD = MAX( 1, MIN( N, 4 ) )
NIMAT = NTYPES
IF( N.EQ.0 )
$ NIMAT = 1
*
KDVAL( 2 ) = N + ( N+1 ) / 4
KDVAL( 3 ) = ( 3*N-1 ) / 4
KDVAL( 4 ) = ( N+1 ) / 4
*
DO 100 IKD = 1, NKD
*
* Do for KD = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This order
* makes it easier to skip redundant values for small values
* of N.
*
KD = KDVAL( IKD )
LDAB = KD + 1
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 90 IUPLO = 1, 2
KOFF = 1
IF( IUPLO.EQ.1 ) THEN
UPLO = 'U'
PACKIT = 'Q'
KOFF = MAX( 1, KD+2-N )
ELSE
UPLO = 'L'
PACKIT = 'B'
END IF
*
DO 80 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 80
*
* Skip types 2, 3, or 4 if the matrix size is too small.
*
ZEROT = IMAT.GE.2 .AND. IMAT.LE.4
IF( ZEROT .AND. N.LT.IMAT-1 )
$ GO TO 80
*
IF( .NOT.ZEROT .OR. .NOT.DOTYPE( 1 ) ) THEN
*
* Set up parameters with DLATB4 and generate a test
* matrix with DLATMS.
*
CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM,
$ MODE, CNDNUM, DIST )
*
SRNAMT = 'DLATMS'
CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KD, KD, PACKIT,
$ A( KOFF ), LDAB, WORK, INFO )
*
* Check error code from DLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N,
$ N, -1, -1, -1, IMAT, NFAIL, NERRS,
$ NOUT )
GO TO 80
END IF
ELSE IF( IZERO.GT.0 ) THEN
*
* Use the same matrix for types 3 and 4 as for type
* 2 by copying back the zeroed out column,
*
IW = 2*LDA + 1
IF( IUPLO.EQ.1 ) THEN
IOFF = ( IZERO-1 )*LDAB + KD + 1
CALL DCOPY( IZERO-I1, WORK( IW ), 1,
$ A( IOFF-IZERO+I1 ), 1 )
IW = IW + IZERO - I1
CALL DCOPY( I2-IZERO+1, WORK( IW ), 1,
$ A( IOFF ), MAX( LDAB-1, 1 ) )
ELSE
IOFF = ( I1-1 )*LDAB + 1
CALL DCOPY( IZERO-I1, WORK( IW ), 1,
$ A( IOFF+IZERO-I1 ),
$ MAX( LDAB-1, 1 ) )
IOFF = ( IZERO-1 )*LDAB + 1
IW = IW + IZERO - I1
CALL DCOPY( I2-IZERO+1, WORK( IW ), 1,
$ A( IOFF ), 1 )
END IF
END IF
*
* For types 2-4, zero one row and column of the matrix
* to test that INFO is returned correctly.
*
IZERO = 0
IF( ZEROT ) THEN
IF( IMAT.EQ.2 ) THEN
IZERO = 1
ELSE IF( IMAT.EQ.3 ) THEN
IZERO = N
ELSE
IZERO = N / 2 + 1
END IF
*
* Save the zeroed out row and column in WORK(*,3)
*
IW = 2*LDA
DO 20 I = 1, MIN( 2*KD+1, N )
WORK( IW+I ) = ZERO
20 CONTINUE
IW = IW + 1
I1 = MAX( IZERO-KD, 1 )
I2 = MIN( IZERO+KD, N )
*
IF( IUPLO.EQ.1 ) THEN
IOFF = ( IZERO-1 )*LDAB + KD + 1
CALL DSWAP( IZERO-I1, A( IOFF-IZERO+I1 ), 1,
$ WORK( IW ), 1 )
IW = IW + IZERO - I1
CALL DSWAP( I2-IZERO+1, A( IOFF ),
$ MAX( LDAB-1, 1 ), WORK( IW ), 1 )
ELSE
IOFF = ( I1-1 )*LDAB + 1
CALL DSWAP( IZERO-I1, A( IOFF+IZERO-I1 ),
$ MAX( LDAB-1, 1 ), WORK( IW ), 1 )
IOFF = ( IZERO-1 )*LDAB + 1
IW = IW + IZERO - I1
CALL DSWAP( I2-IZERO+1, A( IOFF ), 1,
$ WORK( IW ), 1 )
END IF
END IF
*
* Save a copy of the matrix A in ASAV.
*
CALL DLACPY( 'Full', KD+1, N, A, LDAB, ASAV, LDAB )
*
DO 70 IEQUED = 1, 2
EQUED = EQUEDS( IEQUED )
IF( IEQUED.EQ.1 ) THEN
NFACT = 3
ELSE
NFACT = 1
END IF
*
DO 60 IFACT = 1, NFACT
FACT = FACTS( IFACT )
PREFAC = LSAME( FACT, 'F' )
NOFACT = LSAME( FACT, 'N' )
EQUIL = LSAME( FACT, 'E' )
*
IF( ZEROT ) THEN
IF( PREFAC )
$ GO TO 60
RCONDC = ZERO
*
ELSE IF( .NOT.LSAME( FACT, 'N' ) ) THEN
*
* Compute the condition number for comparison
* with the value returned by DPBSVX (FACT =
* 'N' reuses the condition number from the
* previous iteration with FACT = 'F').
*
CALL DLACPY( 'Full', KD+1, N, ASAV, LDAB,
$ AFAC, LDAB )
IF( EQUIL .OR. IEQUED.GT.1 ) THEN
*
* Compute row and column scale factors to
* equilibrate the matrix A.
*
CALL DPBEQU( UPLO, N, KD, AFAC, LDAB, S,
$ SCOND, AMAX, INFO )
IF( INFO.EQ.0 .AND. N.GT.0 ) THEN
IF( IEQUED.GT.1 )
$ SCOND = ZERO
*
* Equilibrate the matrix.
*
CALL DLAQSB( UPLO, N, KD, AFAC, LDAB,
$ S, SCOND, AMAX, EQUED )
END IF
END IF
*
* Save the condition number of the
* non-equilibrated system for use in DGET04.
*
IF( EQUIL )
$ ROLDC = RCONDC
*
* Compute the 1-norm of A.
*
ANORM = DLANSB( '1', UPLO, N, KD, AFAC, LDAB,
$ RWORK )
*
* Factor the matrix A.
*
CALL DPBTRF( UPLO, N, KD, AFAC, LDAB, INFO )
*
* Form the inverse of A.
*
CALL DLASET( 'Full', N, N, ZERO, ONE, A,
$ LDA )
SRNAMT = 'DPBTRS'
CALL DPBTRS( UPLO, N, KD, N, AFAC, LDAB, A,
$ LDA, INFO )
*
* Compute the 1-norm condition number of A.
*
AINVNM = DLANGE( '1', N, N, A, LDA, RWORK )
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDC = ONE
ELSE
RCONDC = ( ONE / ANORM ) / AINVNM
END IF
END IF
*
* Restore the matrix A.
*
CALL DLACPY( 'Full', KD+1, N, ASAV, LDAB, A,
$ LDAB )
*
* Form an exact solution and set the right hand
* side.
*
SRNAMT = 'DLARHS'
CALL DLARHS( PATH, XTYPE, UPLO, ' ', N, N, KD,
$ KD, NRHS, A, LDAB, XACT, LDA, B,
$ LDA, ISEED, INFO )
XTYPE = 'C'
CALL DLACPY( 'Full', N, NRHS, B, LDA, BSAV,
$ LDA )
*
IF( NOFACT ) THEN
*
* --- Test DPBSV ---
*
* Compute the L*L' or U'*U factorization of the
* matrix and solve the system.
*
CALL DLACPY( 'Full', KD+1, N, A, LDAB, AFAC,
$ LDAB )
CALL DLACPY( 'Full', N, NRHS, B, LDA, X,
$ LDA )
*
SRNAMT = 'DPBSV '
CALL DPBSV( UPLO, N, KD, NRHS, AFAC, LDAB, X,
$ LDA, INFO )
*
* Check error code from DPBSV .
*
IF( INFO.NE.IZERO ) THEN
CALL ALAERH( PATH, 'DPBSV ', INFO, IZERO,
$ UPLO, N, N, KD, KD, NRHS,
$ IMAT, NFAIL, NERRS, NOUT )
GO TO 40
ELSE IF( INFO.NE.0 ) THEN
GO TO 40
END IF
*
* Reconstruct matrix from factors and compute
* residual.
*
CALL DPBT01( UPLO, N, KD, A, LDAB, AFAC,
$ LDAB, RWORK, RESULT( 1 ) )
*
* Compute residual of the computed solution.
*
CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK,
$ LDA )
CALL DPBT02( UPLO, N, KD, NRHS, A, LDAB, X,
$ LDA, WORK, LDA, RWORK,
$ RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA,
$ RCONDC, RESULT( 3 ) )
NT = 3
*
* Print information about the tests that did
* not pass the threshold.
*
DO 30 K = 1, NT
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )'DPBSV ',
$ UPLO, N, KD, IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
30 CONTINUE
NRUN = NRUN + NT
40 CONTINUE
END IF
*
* --- Test DPBSVX ---
*
IF( .NOT.PREFAC )
$ CALL DLASET( 'Full', KD+1, N, ZERO, ZERO,
$ AFAC, LDAB )
CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, X,
$ LDA )
IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN
*
* Equilibrate the matrix if FACT='F' and
* EQUED='Y'
*
CALL DLAQSB( UPLO, N, KD, A, LDAB, S, SCOND,
$ AMAX, EQUED )
END IF
*
* Solve the system and compute the condition
* number and error bounds using DPBSVX.
*
SRNAMT = 'DPBSVX'
CALL DPBSVX( FACT, UPLO, N, KD, NRHS, A, LDAB,
$ AFAC, LDAB, EQUED, S, B, LDA, X,
$ LDA, RCOND, RWORK, RWORK( NRHS+1 ),
$ WORK, IWORK, INFO )
*
* Check the error code from DPBSVX.
*
IF( INFO.NE.IZERO ) THEN
CALL ALAERH( PATH, 'DPBSVX', INFO, IZERO,
$ FACT // UPLO, N, N, KD, KD,
$ NRHS, IMAT, NFAIL, NERRS, NOUT )
GO TO 60
END IF
*
IF( INFO.EQ.0 ) THEN
IF( .NOT.PREFAC ) THEN
*
* Reconstruct matrix from factors and
* compute residual.
*
CALL DPBT01( UPLO, N, KD, A, LDAB, AFAC,
$ LDAB, RWORK( 2*NRHS+1 ),
$ RESULT( 1 ) )
K1 = 1
ELSE
K1 = 2
END IF
*
* Compute residual of the computed solution.
*
CALL DLACPY( 'Full', N, NRHS, BSAV, LDA,
$ WORK, LDA )
CALL DPBT02( UPLO, N, KD, NRHS, ASAV, LDAB,
$ X, LDA, WORK, LDA,
$ RWORK( 2*NRHS+1 ), RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED,
$ 'N' ) ) ) THEN
CALL DGET04( N, NRHS, X, LDA, XACT, LDA,
$ RCONDC, RESULT( 3 ) )
ELSE
CALL DGET04( N, NRHS, X, LDA, XACT, LDA,
$ ROLDC, RESULT( 3 ) )
END IF
*
* Check the error bounds from iterative
* refinement.
*
CALL DPBT05( UPLO, N, KD, NRHS, ASAV, LDAB,
$ B, LDA, X, LDA, XACT, LDA,
$ RWORK, RWORK( NRHS+1 ),
$ RESULT( 4 ) )
ELSE
K1 = 6
END IF
*
* Compare RCOND from DPBSVX with the computed
* value in RCONDC.
*
RESULT( 6 ) = DGET06( RCOND, RCONDC )
*
* Print information about the tests that did not
* pass the threshold.
*
DO 50 K = K1, 6
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
IF( PREFAC ) THEN
WRITE( NOUT, FMT = 9997 )'DPBSVX',
$ FACT, UPLO, N, KD, EQUED, IMAT, K,
$ RESULT( K )
ELSE
WRITE( NOUT, FMT = 9998 )'DPBSVX',
$ FACT, UPLO, N, KD, IMAT, K,
$ RESULT( K )
END IF
NFAIL = NFAIL + 1
END IF
50 CONTINUE
NRUN = NRUN + 7 - K1
60 CONTINUE
70 CONTINUE
80 CONTINUE
90 CONTINUE
100 CONTINUE
110 CONTINUE
*
* Print a summary of the results.
*
CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( 1X, A6, ', UPLO=''', A1, ''', N =', I5, ', KD =', I5,
$ ', type ', I1, ', test(', I1, ')=', G12.5 )
9998 FORMAT( 1X, A6, '( ''', A1, ''', ''', A1, ''', ', I5, ', ', I5,
$ ', ... ), type ', I1, ', test(', I1, ')=', G12.5 )
9997 FORMAT( 1X, A6, '( ''', A1, ''', ''', A1, ''', ', I5, ', ', I5,
$ ', ... ), EQUED=''', A1, ''', type ', I1, ', test(', I1,
$ ')=', G12.5 )
RETURN
*
* End of DDRVPB
*
END
SUBROUTINE DDRVPO( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
$ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK,
$ RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NMAX, NN, NOUT, NRHS
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NVAL( * )
DOUBLE PRECISION A( * ), AFAC( * ), ASAV( * ), B( * ),
$ BSAV( * ), RWORK( * ), S( * ), WORK( * ),
$ X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* DDRVPO tests the driver routines DPOSV and -SVX.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* NRHS (input) INTEGER
* The number of right hand side vectors to be generated for
* each linear system.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for N, used in dimensioning the
* work arrays.
*
* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* ASAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* BSAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* S (workspace) DOUBLE PRECISION array, dimension (NMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension
* (NMAX*max(3,NRHS))
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
INTEGER NTYPES
PARAMETER ( NTYPES = 9 )
INTEGER NTESTS
PARAMETER ( NTESTS = 6 )
* ..
* .. Local Scalars ..
LOGICAL EQUIL, NOFACT, PREFAC, ZEROT
CHARACTER DIST, EQUED, FACT, TYPE, UPLO, XTYPE
CHARACTER*3 PATH
INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
$ IZERO, K, K1, KL, KU, LDA, MODE, N, NB, NBMIN,
$ NERRS, NFACT, NFAIL, NIMAT, NRUN, NT
DOUBLE PRECISION AINVNM, AMAX, ANORM, CNDNUM, RCOND, RCONDC,
$ ROLDC, SCOND
* ..
* .. Local Arrays ..
CHARACTER EQUEDS( 2 ), FACTS( 3 ), UPLOS( 2 )
INTEGER ISEED( 4 ), ISEEDY( 4 )
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DGET06, DLANSY
EXTERNAL LSAME, DGET06, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL ALADHD, ALAERH, ALASVM, DERRVX, DGET04, DLACPY,
$ DLAQSY, DLARHS, DLASET, DLATB4, DLATMS, DPOEQU,
$ DPOSV, DPOSVX, DPOT01, DPOT02, DPOT05, DPOTRF,
$ DPOTRI, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
DATA UPLOS / 'U', 'L' /
DATA FACTS / 'F', 'N', 'E' /
DATA EQUEDS / 'N', 'Y' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'PO'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL DERRVX( PATH, NOUT )
INFOT = 0
*
* Set the block size and minimum block size for testing.
*
NB = 1
NBMIN = 2
CALL XLAENV( 1, NB )
CALL XLAENV( 2, NBMIN )
*
* Do for each value of N in NVAL
*
DO 130 IN = 1, NN
N = NVAL( IN )
LDA = MAX( N, 1 )
XTYPE = 'N'
NIMAT = NTYPES
IF( N.LE.0 )
$ NIMAT = 1
*
DO 120 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 120
*
* Skip types 3, 4, or 5 if the matrix size is too small.
*
ZEROT = IMAT.GE.3 .AND. IMAT.LE.5
IF( ZEROT .AND. N.LT.IMAT-2 )
$ GO TO 120
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 110 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
*
* Set up parameters with DLATB4 and generate a test matrix
* with DLATMS.
*
CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
*
SRNAMT = 'DLATMS'
CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
$ INFO )
*
* Check error code from DLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 110
END IF
*
* For types 3-5, zero one row and column of the matrix to
* test that INFO is returned correctly.
*
IF( ZEROT ) THEN
IF( IMAT.EQ.3 ) THEN
IZERO = 1
ELSE IF( IMAT.EQ.4 ) THEN
IZERO = N
ELSE
IZERO = N / 2 + 1
END IF
IOFF = ( IZERO-1 )*LDA
*
* Set row and column IZERO of A to 0.
*
IF( IUPLO.EQ.1 ) THEN
DO 20 I = 1, IZERO - 1
A( IOFF+I ) = ZERO
20 CONTINUE
IOFF = IOFF + IZERO
DO 30 I = IZERO, N
A( IOFF ) = ZERO
IOFF = IOFF + LDA
30 CONTINUE
ELSE
IOFF = IZERO
DO 40 I = 1, IZERO - 1
A( IOFF ) = ZERO
IOFF = IOFF + LDA
40 CONTINUE
IOFF = IOFF - IZERO
DO 50 I = IZERO, N
A( IOFF+I ) = ZERO
50 CONTINUE
END IF
ELSE
IZERO = 0
END IF
*
* Save a copy of the matrix A in ASAV.
*
CALL DLACPY( UPLO, N, N, A, LDA, ASAV, LDA )
*
DO 100 IEQUED = 1, 2
EQUED = EQUEDS( IEQUED )
IF( IEQUED.EQ.1 ) THEN
NFACT = 3
ELSE
NFACT = 1
END IF
*
DO 90 IFACT = 1, NFACT
FACT = FACTS( IFACT )
PREFAC = LSAME( FACT, 'F' )
NOFACT = LSAME( FACT, 'N' )
EQUIL = LSAME( FACT, 'E' )
*
IF( ZEROT ) THEN
IF( PREFAC )
$ GO TO 90
RCONDC = ZERO
*
ELSE IF( .NOT.LSAME( FACT, 'N' ) ) THEN
*
* Compute the condition number for comparison with
* the value returned by DPOSVX (FACT = 'N' reuses
* the condition number from the previous iteration
* with FACT = 'F').
*
CALL DLACPY( UPLO, N, N, ASAV, LDA, AFAC, LDA )
IF( EQUIL .OR. IEQUED.GT.1 ) THEN
*
* Compute row and column scale factors to
* equilibrate the matrix A.
*
CALL DPOEQU( N, AFAC, LDA, S, SCOND, AMAX,
$ INFO )
IF( INFO.EQ.0 .AND. N.GT.0 ) THEN
IF( IEQUED.GT.1 )
$ SCOND = ZERO
*
* Equilibrate the matrix.
*
CALL DLAQSY( UPLO, N, AFAC, LDA, S, SCOND,
$ AMAX, EQUED )
END IF
END IF
*
* Save the condition number of the
* non-equilibrated system for use in DGET04.
*
IF( EQUIL )
$ ROLDC = RCONDC
*
* Compute the 1-norm of A.
*
ANORM = DLANSY( '1', UPLO, N, AFAC, LDA, RWORK )
*
* Factor the matrix A.
*
CALL DPOTRF( UPLO, N, AFAC, LDA, INFO )
*
* Form the inverse of A.
*
CALL DLACPY( UPLO, N, N, AFAC, LDA, A, LDA )
CALL DPOTRI( UPLO, N, A, LDA, INFO )
*
* Compute the 1-norm condition number of A.
*
AINVNM = DLANSY( '1', UPLO, N, A, LDA, RWORK )
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDC = ONE
ELSE
RCONDC = ( ONE / ANORM ) / AINVNM
END IF
END IF
*
* Restore the matrix A.
*
CALL DLACPY( UPLO, N, N, ASAV, LDA, A, LDA )
*
* Form an exact solution and set the right hand side.
*
SRNAMT = 'DLARHS'
CALL DLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
$ NRHS, A, LDA, XACT, LDA, B, LDA,
$ ISEED, INFO )
XTYPE = 'C'
CALL DLACPY( 'Full', N, NRHS, B, LDA, BSAV, LDA )
*
IF( NOFACT ) THEN
*
* --- Test DPOSV ---
*
* Compute the L*L' or U'*U factorization of the
* matrix and solve the system.
*
CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
SRNAMT = 'DPOSV '
CALL DPOSV( UPLO, N, NRHS, AFAC, LDA, X, LDA,
$ INFO )
*
* Check error code from DPOSV .
*
IF( INFO.NE.IZERO ) THEN
CALL ALAERH( PATH, 'DPOSV ', INFO, IZERO,
$ UPLO, N, N, -1, -1, NRHS, IMAT,
$ NFAIL, NERRS, NOUT )
GO TO 70
ELSE IF( INFO.NE.0 ) THEN
GO TO 70
END IF
*
* Reconstruct matrix from factors and compute
* residual.
*
CALL DPOT01( UPLO, N, A, LDA, AFAC, LDA, RWORK,
$ RESULT( 1 ) )
*
* Compute residual of the computed solution.
*
CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK,
$ LDA )
CALL DPOT02( UPLO, N, NRHS, A, LDA, X, LDA,
$ WORK, LDA, RWORK, RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
NT = 3
*
* Print information about the tests that did not
* pass the threshold.
*
DO 60 K = 1, NT
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )'DPOSV ', UPLO,
$ N, IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
60 CONTINUE
NRUN = NRUN + NT
70 CONTINUE
END IF
*
* --- Test DPOSVX ---
*
IF( .NOT.PREFAC )
$ CALL DLASET( UPLO, N, N, ZERO, ZERO, AFAC, LDA )
CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA )
IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN
*
* Equilibrate the matrix if FACT='F' and
* EQUED='Y'.
*
CALL DLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX,
$ EQUED )
END IF
*
* Solve the system and compute the condition number
* and error bounds using DPOSVX.
*
SRNAMT = 'DPOSVX'
CALL DPOSVX( FACT, UPLO, N, NRHS, A, LDA, AFAC,
$ LDA, EQUED, S, B, LDA, X, LDA, RCOND,
$ RWORK, RWORK( NRHS+1 ), WORK, IWORK,
$ INFO )
*
* Check the error code from DPOSVX.
*
IF( INFO.NE.IZERO ) THEN
CALL ALAERH( PATH, 'DPOSVX', INFO, IZERO,
$ FACT // UPLO, N, N, -1, -1, NRHS,
$ IMAT, NFAIL, NERRS, NOUT )
GO TO 90
END IF
*
IF( INFO.EQ.0 ) THEN
IF( .NOT.PREFAC ) THEN
*
* Reconstruct matrix from factors and compute
* residual.
*
CALL DPOT01( UPLO, N, A, LDA, AFAC, LDA,
$ RWORK( 2*NRHS+1 ), RESULT( 1 ) )
K1 = 1
ELSE
K1 = 2
END IF
*
* Compute residual of the computed solution.
*
CALL DLACPY( 'Full', N, NRHS, BSAV, LDA, WORK,
$ LDA )
CALL DPOT02( UPLO, N, NRHS, ASAV, LDA, X, LDA,
$ WORK, LDA, RWORK( 2*NRHS+1 ),
$ RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED,
$ 'N' ) ) ) THEN
CALL DGET04( N, NRHS, X, LDA, XACT, LDA,
$ RCONDC, RESULT( 3 ) )
ELSE
CALL DGET04( N, NRHS, X, LDA, XACT, LDA,
$ ROLDC, RESULT( 3 ) )
END IF
*
* Check the error bounds from iterative
* refinement.
*
CALL DPOT05( UPLO, N, NRHS, ASAV, LDA, B, LDA,
$ X, LDA, XACT, LDA, RWORK,
$ RWORK( NRHS+1 ), RESULT( 4 ) )
ELSE
K1 = 6
END IF
*
* Compare RCOND from DPOSVX with the computed value
* in RCONDC.
*
RESULT( 6 ) = DGET06( RCOND, RCONDC )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 80 K = K1, 6
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
IF( PREFAC ) THEN
WRITE( NOUT, FMT = 9997 )'DPOSVX', FACT,
$ UPLO, N, EQUED, IMAT, K, RESULT( K )
ELSE
WRITE( NOUT, FMT = 9998 )'DPOSVX', FACT,
$ UPLO, N, IMAT, K, RESULT( K )
END IF
NFAIL = NFAIL + 1
END IF
80 CONTINUE
NRUN = NRUN + 7 - K1
90 CONTINUE
100 CONTINUE
110 CONTINUE
120 CONTINUE
130 CONTINUE
*
* Print a summary of the results.
*
CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( 1X, A6, ', UPLO=''', A1, ''', N =', I5, ', type ', I1,
$ ', test(', I1, ')=', G12.5 )
9998 FORMAT( 1X, A6, ', FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5,
$ ', type ', I1, ', test(', I1, ')=', G12.5 )
9997 FORMAT( 1X, A6, ', FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5,
$ ', EQUED=''', A1, ''', type ', I1, ', test(', I1, ') =',
$ G12.5 )
RETURN
*
* End of DDRVPO
*
END
SUBROUTINE DDRVPP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
$ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK,
$ RWORK, IWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NMAX, NN, NOUT, NRHS
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NVAL( * )
DOUBLE PRECISION A( * ), AFAC( * ), ASAV( * ), B( * ),
$ BSAV( * ), RWORK( * ), S( * ), WORK( * ),
$ X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* DDRVPP tests the driver routines DPPSV and -SVX.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* NRHS (input) INTEGER
* The number of right hand side vectors to be generated for
* each linear system.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for N, used in dimensioning the
* work arrays.
*
* A (workspace) DOUBLE PRECISION array, dimension
* (NMAX*(NMAX+1)/2)
*
* AFAC (workspace) DOUBLE PRECISION array, dimension
* (NMAX*(NMAX+1)/2)
*
* ASAV (workspace) DOUBLE PRECISION array, dimension
* (NMAX*(NMAX+1)/2)
*
* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* BSAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* S (workspace) DOUBLE PRECISION array, dimension (NMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension
* (NMAX*max(3,NRHS))
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
INTEGER NTYPES
PARAMETER ( NTYPES = 9 )
INTEGER NTESTS
PARAMETER ( NTESTS = 6 )
* ..
* .. Local Scalars ..
LOGICAL EQUIL, NOFACT, PREFAC, ZEROT
CHARACTER DIST, EQUED, FACT, PACKIT, TYPE, UPLO, XTYPE
CHARACTER*3 PATH
INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
$ IZERO, K, K1, KL, KU, LDA, MODE, N, NERRS,
$ NFACT, NFAIL, NIMAT, NPP, NRUN, NT
DOUBLE PRECISION AINVNM, AMAX, ANORM, CNDNUM, RCOND, RCONDC,
$ ROLDC, SCOND
* ..
* .. Local Arrays ..
CHARACTER EQUEDS( 2 ), FACTS( 3 ), PACKS( 2 ), UPLOS( 2 )
INTEGER ISEED( 4 ), ISEEDY( 4 )
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DGET06, DLANSP
EXTERNAL LSAME, DGET06, DLANSP
* ..
* .. External Subroutines ..
EXTERNAL ALADHD, ALAERH, ALASVM, DCOPY, DERRVX, DGET04,
$ DLACPY, DLAQSP, DLARHS, DLASET, DLATB4, DLATMS,
$ DPPEQU, DPPSV, DPPSVX, DPPT01, DPPT02, DPPT05,
$ DPPTRF, DPPTRI
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N', 'E' / ,
$ PACKS / 'C', 'R' / , EQUEDS / 'N', 'Y' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'PP'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL DERRVX( PATH, NOUT )
INFOT = 0
*
* Do for each value of N in NVAL
*
DO 140 IN = 1, NN
N = NVAL( IN )
LDA = MAX( N, 1 )
NPP = N*( N+1 ) / 2
XTYPE = 'N'
NIMAT = NTYPES
IF( N.LE.0 )
$ NIMAT = 1
*
DO 130 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 130
*
* Skip types 3, 4, or 5 if the matrix size is too small.
*
ZEROT = IMAT.GE.3 .AND. IMAT.LE.5
IF( ZEROT .AND. N.LT.IMAT-2 )
$ GO TO 130
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 120 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
PACKIT = PACKS( IUPLO )
*
* Set up parameters with DLATB4 and generate a test matrix
* with DLATMS.
*
CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
RCONDC = ONE / CNDNUM
*
SRNAMT = 'DLATMS'
CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
$ INFO )
*
* Check error code from DLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 120
END IF
*
* For types 3-5, zero one row and column of the matrix to
* test that INFO is returned correctly.
*
IF( ZEROT ) THEN
IF( IMAT.EQ.3 ) THEN
IZERO = 1
ELSE IF( IMAT.EQ.4 ) THEN
IZERO = N
ELSE
IZERO = N / 2 + 1
END IF
*
* Set row and column IZERO of A to 0.
*
IF( IUPLO.EQ.1 ) THEN
IOFF = ( IZERO-1 )*IZERO / 2
DO 20 I = 1, IZERO - 1
A( IOFF+I ) = ZERO
20 CONTINUE
IOFF = IOFF + IZERO
DO 30 I = IZERO, N
A( IOFF ) = ZERO
IOFF = IOFF + I
30 CONTINUE
ELSE
IOFF = IZERO
DO 40 I = 1, IZERO - 1
A( IOFF ) = ZERO
IOFF = IOFF + N - I
40 CONTINUE
IOFF = IOFF - IZERO
DO 50 I = IZERO, N
A( IOFF+I ) = ZERO
50 CONTINUE
END IF
ELSE
IZERO = 0
END IF
*
* Save a copy of the matrix A in ASAV.
*
CALL DCOPY( NPP, A, 1, ASAV, 1 )
*
DO 110 IEQUED = 1, 2
EQUED = EQUEDS( IEQUED )
IF( IEQUED.EQ.1 ) THEN
NFACT = 3
ELSE
NFACT = 1
END IF
*
DO 100 IFACT = 1, NFACT
FACT = FACTS( IFACT )
PREFAC = LSAME( FACT, 'F' )
NOFACT = LSAME( FACT, 'N' )
EQUIL = LSAME( FACT, 'E' )
*
IF( ZEROT ) THEN
IF( PREFAC )
$ GO TO 100
RCONDC = ZERO
*
ELSE IF( .NOT.LSAME( FACT, 'N' ) ) THEN
*
* Compute the condition number for comparison with
* the value returned by DPPSVX (FACT = 'N' reuses
* the condition number from the previous iteration
* with FACT = 'F').
*
CALL DCOPY( NPP, ASAV, 1, AFAC, 1 )
IF( EQUIL .OR. IEQUED.GT.1 ) THEN
*
* Compute row and column scale factors to
* equilibrate the matrix A.
*
CALL DPPEQU( UPLO, N, AFAC, S, SCOND, AMAX,
$ INFO )
IF( INFO.EQ.0 .AND. N.GT.0 ) THEN
IF( IEQUED.GT.1 )
$ SCOND = ZERO
*
* Equilibrate the matrix.
*
CALL DLAQSP( UPLO, N, AFAC, S, SCOND,
$ AMAX, EQUED )
END IF
END IF
*
* Save the condition number of the
* non-equilibrated system for use in DGET04.
*
IF( EQUIL )
$ ROLDC = RCONDC
*
* Compute the 1-norm of A.
*
ANORM = DLANSP( '1', UPLO, N, AFAC, RWORK )
*
* Factor the matrix A.
*
CALL DPPTRF( UPLO, N, AFAC, INFO )
*
* Form the inverse of A.
*
CALL DCOPY( NPP, AFAC, 1, A, 1 )
CALL DPPTRI( UPLO, N, A, INFO )
*
* Compute the 1-norm condition number of A.
*
AINVNM = DLANSP( '1', UPLO, N, A, RWORK )
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDC = ONE
ELSE
RCONDC = ( ONE / ANORM ) / AINVNM
END IF
END IF
*
* Restore the matrix A.
*
CALL DCOPY( NPP, ASAV, 1, A, 1 )
*
* Form an exact solution and set the right hand side.
*
SRNAMT = 'DLARHS'
CALL DLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
$ NRHS, A, LDA, XACT, LDA, B, LDA,
$ ISEED, INFO )
XTYPE = 'C'
CALL DLACPY( 'Full', N, NRHS, B, LDA, BSAV, LDA )
*
IF( NOFACT ) THEN
*
* --- Test DPPSV ---
*
* Compute the L*L' or U'*U factorization of the
* matrix and solve the system.
*
CALL DCOPY( NPP, A, 1, AFAC, 1 )
CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
SRNAMT = 'DPPSV '
CALL DPPSV( UPLO, N, NRHS, AFAC, X, LDA, INFO )
*
* Check error code from DPPSV .
*
IF( INFO.NE.IZERO ) THEN
CALL ALAERH( PATH, 'DPPSV ', INFO, IZERO,
$ UPLO, N, N, -1, -1, NRHS, IMAT,
$ NFAIL, NERRS, NOUT )
GO TO 70
ELSE IF( INFO.NE.0 ) THEN
GO TO 70
END IF
*
* Reconstruct matrix from factors and compute
* residual.
*
CALL DPPT01( UPLO, N, A, AFAC, RWORK,
$ RESULT( 1 ) )
*
* Compute residual of the computed solution.
*
CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK,
$ LDA )
CALL DPPT02( UPLO, N, NRHS, A, X, LDA, WORK,
$ LDA, RWORK, RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
NT = 3
*
* Print information about the tests that did not
* pass the threshold.
*
DO 60 K = 1, NT
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )'DPPSV ', UPLO,
$ N, IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
60 CONTINUE
NRUN = NRUN + NT
70 CONTINUE
END IF
*
* --- Test DPPSVX ---
*
IF( .NOT.PREFAC .AND. NPP.GT.0 )
$ CALL DLASET( 'Full', NPP, 1, ZERO, ZERO, AFAC,
$ NPP )
CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA )
IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN
*
* Equilibrate the matrix if FACT='F' and
* EQUED='Y'.
*
CALL DLAQSP( UPLO, N, A, S, SCOND, AMAX, EQUED )
END IF
*
* Solve the system and compute the condition number
* and error bounds using DPPSVX.
*
SRNAMT = 'DPPSVX'
CALL DPPSVX( FACT, UPLO, N, NRHS, A, AFAC, EQUED,
$ S, B, LDA, X, LDA, RCOND, RWORK,
$ RWORK( NRHS+1 ), WORK, IWORK, INFO )
*
* Check the error code from DPPSVX.
*
IF( INFO.NE.IZERO ) THEN
CALL ALAERH( PATH, 'DPPSVX', INFO, IZERO,
$ FACT // UPLO, N, N, -1, -1, NRHS,
$ IMAT, NFAIL, NERRS, NOUT )
GO TO 90
END IF
*
IF( INFO.EQ.0 ) THEN
IF( .NOT.PREFAC ) THEN
*
* Reconstruct matrix from factors and compute
* residual.
*
CALL DPPT01( UPLO, N, A, AFAC,
$ RWORK( 2*NRHS+1 ), RESULT( 1 ) )
K1 = 1
ELSE
K1 = 2
END IF
*
* Compute residual of the computed solution.
*
CALL DLACPY( 'Full', N, NRHS, BSAV, LDA, WORK,
$ LDA )
CALL DPPT02( UPLO, N, NRHS, ASAV, X, LDA, WORK,
$ LDA, RWORK( 2*NRHS+1 ),
$ RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED,
$ 'N' ) ) ) THEN
CALL DGET04( N, NRHS, X, LDA, XACT, LDA,
$ RCONDC, RESULT( 3 ) )
ELSE
CALL DGET04( N, NRHS, X, LDA, XACT, LDA,
$ ROLDC, RESULT( 3 ) )
END IF
*
* Check the error bounds from iterative
* refinement.
*
CALL DPPT05( UPLO, N, NRHS, ASAV, B, LDA, X,
$ LDA, XACT, LDA, RWORK,
$ RWORK( NRHS+1 ), RESULT( 4 ) )
ELSE
K1 = 6
END IF
*
* Compare RCOND from DPPSVX with the computed value
* in RCONDC.
*
RESULT( 6 ) = DGET06( RCOND, RCONDC )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 80 K = K1, 6
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
IF( PREFAC ) THEN
WRITE( NOUT, FMT = 9997 )'DPPSVX', FACT,
$ UPLO, N, EQUED, IMAT, K, RESULT( K )
ELSE
WRITE( NOUT, FMT = 9998 )'DPPSVX', FACT,
$ UPLO, N, IMAT, K, RESULT( K )
END IF
NFAIL = NFAIL + 1
END IF
80 CONTINUE
NRUN = NRUN + 7 - K1
90 CONTINUE
100 CONTINUE
110 CONTINUE
120 CONTINUE
130 CONTINUE
140 CONTINUE
*
* Print a summary of the results.
*
CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( 1X, A6, ', UPLO=''', A1, ''', N =', I5, ', type ', I1,
$ ', test(', I1, ')=', G12.5 )
9998 FORMAT( 1X, A6, ', FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5,
$ ', type ', I1, ', test(', I1, ')=', G12.5 )
9997 FORMAT( 1X, A6, ', FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5,
$ ', EQUED=''', A1, ''', type ', I1, ', test(', I1, ')=',
$ G12.5 )
RETURN
*
* End of DDRVPP
*
END
SUBROUTINE DDRVPT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, D,
$ E, B, X, XACT, WORK, RWORK, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NN, NOUT, NRHS
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER NVAL( * )
DOUBLE PRECISION A( * ), B( * ), D( * ), E( * ), RWORK( * ),
$ WORK( * ), X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* DDRVPT tests DPTSV and -SVX.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* NRHS (input) INTEGER
* The number of right hand side vectors to be generated for
* each linear system.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* A (workspace) DOUBLE PRECISION array, dimension (NMAX*2)
*
* D (workspace) DOUBLE PRECISION array, dimension (NMAX*2)
*
* E (workspace) DOUBLE PRECISION array, dimension (NMAX*2)
*
* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* WORK (workspace) DOUBLE PRECISION array, dimension
* (NMAX*max(3,NRHS))
*
* RWORK (workspace) DOUBLE PRECISION array, dimension
* (max(NMAX,2*NRHS))
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
INTEGER NTYPES
PARAMETER ( NTYPES = 12 )
INTEGER NTESTS
PARAMETER ( NTESTS = 6 )
* ..
* .. Local Scalars ..
LOGICAL ZEROT
CHARACTER DIST, FACT, TYPE
CHARACTER*3 PATH
INTEGER I, IA, IFACT, IMAT, IN, INFO, IX, IZERO, J, K,
$ K1, KL, KU, LDA, MODE, N, NERRS, NFAIL, NIMAT,
$ NRUN, NT
DOUBLE PRECISION AINVNM, ANORM, COND, DMAX, RCOND, RCONDC
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 ), ISEEDY( 4 )
DOUBLE PRECISION RESULT( NTESTS ), Z( 3 )
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DASUM, DGET06, DLANST
EXTERNAL IDAMAX, DASUM, DGET06, DLANST
* ..
* .. External Subroutines ..
EXTERNAL ALADHD, ALAERH, ALASVM, DCOPY, DERRVX, DGET04,
$ DLACPY, DLAPTM, DLARNV, DLASET, DLATB4, DLATMS,
$ DPTSV, DPTSVX, DPTT01, DPTT02, DPTT05, DPTTRF,
$ DPTTRS, DSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEEDY / 0, 0, 0, 1 /
* ..
* .. Executable Statements ..
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'PT'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL DERRVX( PATH, NOUT )
INFOT = 0
*
DO 120 IN = 1, NN
*
* Do for each value of N in NVAL.
*
N = NVAL( IN )
LDA = MAX( 1, N )
NIMAT = NTYPES
IF( N.LE.0 )
$ NIMAT = 1
*
DO 110 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( N.GT.0 .AND. .NOT.DOTYPE( IMAT ) )
$ GO TO 110
*
* Set up parameters with DLATB4.
*
CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ COND, DIST )
*
ZEROT = IMAT.GE.8 .AND. IMAT.LE.10
IF( IMAT.LE.6 ) THEN
*
* Type 1-6: generate a symmetric tridiagonal matrix of
* known condition number in lower triangular band storage.
*
SRNAMT = 'DLATMS'
CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, COND,
$ ANORM, KL, KU, 'B', A, 2, WORK, INFO )
*
* Check the error code from DLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', N, N, KL,
$ KU, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 110
END IF
IZERO = 0
*
* Copy the matrix to D and E.
*
IA = 1
DO 20 I = 1, N - 1
D( I ) = A( IA )
E( I ) = A( IA+1 )
IA = IA + 2
20 CONTINUE
IF( N.GT.0 )
$ D( N ) = A( IA )
ELSE
*
* Type 7-12: generate a diagonally dominant matrix with
* unknown condition number in the vectors D and E.
*
IF( .NOT.ZEROT .OR. .NOT.DOTYPE( 7 ) ) THEN
*
* Let D and E have values from [-1,1].
*
CALL DLARNV( 2, ISEED, N, D )
CALL DLARNV( 2, ISEED, N-1, E )
*
* Make the tridiagonal matrix diagonally dominant.
*
IF( N.EQ.1 ) THEN
D( 1 ) = ABS( D( 1 ) )
ELSE
D( 1 ) = ABS( D( 1 ) ) + ABS( E( 1 ) )
D( N ) = ABS( D( N ) ) + ABS( E( N-1 ) )
DO 30 I = 2, N - 1
D( I ) = ABS( D( I ) ) + ABS( E( I ) ) +
$ ABS( E( I-1 ) )
30 CONTINUE
END IF
*
* Scale D and E so the maximum element is ANORM.
*
IX = IDAMAX( N, D, 1 )
DMAX = D( IX )
CALL DSCAL( N, ANORM / DMAX, D, 1 )
IF( N.GT.1 )
$ CALL DSCAL( N-1, ANORM / DMAX, E, 1 )
*
ELSE IF( IZERO.GT.0 ) THEN
*
* Reuse the last matrix by copying back the zeroed out
* elements.
*
IF( IZERO.EQ.1 ) THEN
D( 1 ) = Z( 2 )
IF( N.GT.1 )
$ E( 1 ) = Z( 3 )
ELSE IF( IZERO.EQ.N ) THEN
E( N-1 ) = Z( 1 )
D( N ) = Z( 2 )
ELSE
E( IZERO-1 ) = Z( 1 )
D( IZERO ) = Z( 2 )
E( IZERO ) = Z( 3 )
END IF
END IF
*
* For types 8-10, set one row and column of the matrix to
* zero.
*
IZERO = 0
IF( IMAT.EQ.8 ) THEN
IZERO = 1
Z( 2 ) = D( 1 )
D( 1 ) = ZERO
IF( N.GT.1 ) THEN
Z( 3 ) = E( 1 )
E( 1 ) = ZERO
END IF
ELSE IF( IMAT.EQ.9 ) THEN
IZERO = N
IF( N.GT.1 ) THEN
Z( 1 ) = E( N-1 )
E( N-1 ) = ZERO
END IF
Z( 2 ) = D( N )
D( N ) = ZERO
ELSE IF( IMAT.EQ.10 ) THEN
IZERO = ( N+1 ) / 2
IF( IZERO.GT.1 ) THEN
Z( 1 ) = E( IZERO-1 )
Z( 3 ) = E( IZERO )
E( IZERO-1 ) = ZERO
E( IZERO ) = ZERO
END IF
Z( 2 ) = D( IZERO )
D( IZERO ) = ZERO
END IF
END IF
*
* Generate NRHS random solution vectors.
*
IX = 1
DO 40 J = 1, NRHS
CALL DLARNV( 2, ISEED, N, XACT( IX ) )
IX = IX + LDA
40 CONTINUE
*
* Set the right hand side.
*
CALL DLAPTM( N, NRHS, ONE, D, E, XACT, LDA, ZERO, B, LDA )
*
DO 100 IFACT = 1, 2
IF( IFACT.EQ.1 ) THEN
FACT = 'F'
ELSE
FACT = 'N'
END IF
*
* Compute the condition number for comparison with
* the value returned by DPTSVX.
*
IF( ZEROT ) THEN
IF( IFACT.EQ.1 )
$ GO TO 100
RCONDC = ZERO
*
ELSE IF( IFACT.EQ.1 ) THEN
*
* Compute the 1-norm of A.
*
ANORM = DLANST( '1', N, D, E )
*
CALL DCOPY( N, D, 1, D( N+1 ), 1 )
IF( N.GT.1 )
$ CALL DCOPY( N-1, E, 1, E( N+1 ), 1 )
*
* Factor the matrix A.
*
CALL DPTTRF( N, D( N+1 ), E( N+1 ), INFO )
*
* Use DPTTRS to solve for one column at a time of
* inv(A), computing the maximum column sum as we go.
*
AINVNM = ZERO
DO 60 I = 1, N
DO 50 J = 1, N
X( J ) = ZERO
50 CONTINUE
X( I ) = ONE
CALL DPTTRS( N, 1, D( N+1 ), E( N+1 ), X, LDA,
$ INFO )
AINVNM = MAX( AINVNM, DASUM( N, X, 1 ) )
60 CONTINUE
*
* Compute the 1-norm condition number of A.
*
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDC = ONE
ELSE
RCONDC = ( ONE / ANORM ) / AINVNM
END IF
END IF
*
IF( IFACT.EQ.2 ) THEN
*
* --- Test DPTSV --
*
CALL DCOPY( N, D, 1, D( N+1 ), 1 )
IF( N.GT.1 )
$ CALL DCOPY( N-1, E, 1, E( N+1 ), 1 )
CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
* Factor A as L*D*L' and solve the system A*X = B.
*
SRNAMT = 'DPTSV '
CALL DPTSV( N, NRHS, D( N+1 ), E( N+1 ), X, LDA,
$ INFO )
*
* Check error code from DPTSV .
*
IF( INFO.NE.IZERO )
$ CALL ALAERH( PATH, 'DPTSV ', INFO, IZERO, ' ', N,
$ N, 1, 1, NRHS, IMAT, NFAIL, NERRS,
$ NOUT )
NT = 0
IF( IZERO.EQ.0 ) THEN
*
* Check the factorization by computing the ratio
* norm(L*D*L' - A) / (n * norm(A) * EPS )
*
CALL DPTT01( N, D, E, D( N+1 ), E( N+1 ), WORK,
$ RESULT( 1 ) )
*
* Compute the residual in the solution.
*
CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
CALL DPTT02( N, NRHS, D, E, X, LDA, WORK, LDA,
$ RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
NT = 3
END IF
*
* Print information about the tests that did not pass
* the threshold.
*
DO 70 K = 1, NT
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )'DPTSV ', N, IMAT, K,
$ RESULT( K )
NFAIL = NFAIL + 1
END IF
70 CONTINUE
NRUN = NRUN + NT
END IF
*
* --- Test DPTSVX ---
*
IF( IFACT.GT.1 ) THEN
*
* Initialize D( N+1:2*N ) and E( N+1:2*N ) to zero.
*
DO 80 I = 1, N - 1
D( N+I ) = ZERO
E( N+I ) = ZERO
80 CONTINUE
IF( N.GT.0 )
$ D( N+N ) = ZERO
END IF
*
CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA )
*
* Solve the system and compute the condition number and
* error bounds using DPTSVX.
*
SRNAMT = 'DPTSVX'
CALL DPTSVX( FACT, N, NRHS, D, E, D( N+1 ), E( N+1 ), B,
$ LDA, X, LDA, RCOND, RWORK, RWORK( NRHS+1 ),
$ WORK, INFO )
*
* Check the error code from DPTSVX.
*
IF( INFO.NE.IZERO )
$ CALL ALAERH( PATH, 'DPTSVX', INFO, IZERO, FACT, N, N,
$ 1, 1, NRHS, IMAT, NFAIL, NERRS, NOUT )
IF( IZERO.EQ.0 ) THEN
IF( IFACT.EQ.2 ) THEN
*
* Check the factorization by computing the ratio
* norm(L*D*L' - A) / (n * norm(A) * EPS )
*
K1 = 1
CALL DPTT01( N, D, E, D( N+1 ), E( N+1 ), WORK,
$ RESULT( 1 ) )
ELSE
K1 = 2
END IF
*
* Compute the residual in the solution.
*
CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
CALL DPTT02( N, NRHS, D, E, X, LDA, WORK, LDA,
$ RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
*
* Check error bounds from iterative refinement.
*
CALL DPTT05( N, NRHS, D, E, B, LDA, X, LDA, XACT, LDA,
$ RWORK, RWORK( NRHS+1 ), RESULT( 4 ) )
ELSE
K1 = 6
END IF
*
* Check the reciprocal of the condition number.
*
RESULT( 6 ) = DGET06( RCOND, RCONDC )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 90 K = K1, 6
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )'DPTSVX', FACT, N, IMAT,
$ K, RESULT( K )
NFAIL = NFAIL + 1
END IF
90 CONTINUE
NRUN = NRUN + 7 - K1
100 CONTINUE
110 CONTINUE
120 CONTINUE
*
* Print a summary of the results.
*
CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( 1X, A6, ', N =', I5, ', type ', I2, ', test ', I2,
$ ', ratio = ', G12.5 )
9998 FORMAT( 1X, A6, ', FACT=''', A1, ''', N =', I5, ', type ', I2,
$ ', test ', I2, ', ratio = ', G12.5 )
RETURN
*
* End of DDRVPT
*
END
SUBROUTINE DDRVSP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
$ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK,
$ NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NMAX, NN, NOUT, NRHS
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NVAL( * )
DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
$ RWORK( * ), WORK( * ), X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* DDRVSP tests the driver routines DSPSV and -SVX.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* NRHS (input) INTEGER
* The number of right hand side vectors to be generated for
* each linear system.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for N, used in dimensioning the
* work arrays.
*
* A (workspace) DOUBLE PRECISION array, dimension
* (NMAX*(NMAX+1)/2)
*
* AFAC (workspace) DOUBLE PRECISION array, dimension
* (NMAX*(NMAX+1)/2)
*
* AINV (workspace) DOUBLE PRECISION array, dimension
* (NMAX*(NMAX+1)/2)
*
* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* WORK (workspace) DOUBLE PRECISION array, dimension
* (NMAX*max(2,NRHS))
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
*
* IWORK (workspace) INTEGER array, dimension (2*NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
INTEGER NTYPES, NTESTS
PARAMETER ( NTYPES = 10, NTESTS = 6 )
INTEGER NFACT
PARAMETER ( NFACT = 2 )
* ..
* .. Local Scalars ..
LOGICAL ZEROT
CHARACTER DIST, FACT, PACKIT, TYPE, UPLO, XTYPE
CHARACTER*3 PATH
INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
$ IZERO, J, K, K1, KL, KU, LDA, LWORK, MODE, N,
$ NERRS, NFAIL, NIMAT, NPP, NRUN, NT
DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCOND, RCONDC
* ..
* .. Local Arrays ..
CHARACTER FACTS( NFACT )
INTEGER ISEED( 4 ), ISEEDY( 4 )
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Functions ..
DOUBLE PRECISION DGET06, DLANSP
EXTERNAL DGET06, DLANSP
* ..
* .. External Subroutines ..
EXTERNAL ALADHD, ALAERH, ALASVM, DCOPY, DERRVX, DGET04,
$ DLACPY, DLARHS, DLASET, DLATB4, DLATMS, DPPT02,
$ DPPT05, DSPSV, DSPSVX, DSPT01, DSPTRF, DSPTRI
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
DATA FACTS / 'F', 'N' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'SP'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
LWORK = MAX( 2*NMAX, NMAX*NRHS )
*
* Test the error exits
*
IF( TSTERR )
$ CALL DERRVX( PATH, NOUT )
INFOT = 0
*
* Do for each value of N in NVAL
*
DO 180 IN = 1, NN
N = NVAL( IN )
LDA = MAX( N, 1 )
NPP = N*( N+1 ) / 2
XTYPE = 'N'
NIMAT = NTYPES
IF( N.LE.0 )
$ NIMAT = 1
*
DO 170 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 170
*
* Skip types 3, 4, 5, or 6 if the matrix size is too small.
*
ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
IF( ZEROT .AND. N.LT.IMAT-2 )
$ GO TO 170
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 160 IUPLO = 1, 2
IF( IUPLO.EQ.1 ) THEN
UPLO = 'U'
PACKIT = 'C'
ELSE
UPLO = 'L'
PACKIT = 'R'
END IF
*
* Set up parameters with DLATB4 and generate a test matrix
* with DLATMS.
*
CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
*
SRNAMT = 'DLATMS'
CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
$ INFO )
*
* Check error code from DLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 160
END IF
*
* For types 3-6, zero one or more rows and columns of the
* matrix to test that INFO is returned correctly.
*
IF( ZEROT ) THEN
IF( IMAT.EQ.3 ) THEN
IZERO = 1
ELSE IF( IMAT.EQ.4 ) THEN
IZERO = N
ELSE
IZERO = N / 2 + 1
END IF
*
IF( IMAT.LT.6 ) THEN
*
* Set row and column IZERO to zero.
*
IF( IUPLO.EQ.1 ) THEN
IOFF = ( IZERO-1 )*IZERO / 2
DO 20 I = 1, IZERO - 1
A( IOFF+I ) = ZERO
20 CONTINUE
IOFF = IOFF + IZERO
DO 30 I = IZERO, N
A( IOFF ) = ZERO
IOFF = IOFF + I
30 CONTINUE
ELSE
IOFF = IZERO
DO 40 I = 1, IZERO - 1
A( IOFF ) = ZERO
IOFF = IOFF + N - I
40 CONTINUE
IOFF = IOFF - IZERO
DO 50 I = IZERO, N
A( IOFF+I ) = ZERO
50 CONTINUE
END IF
ELSE
IOFF = 0
IF( IUPLO.EQ.1 ) THEN
*
* Set the first IZERO rows and columns to zero.
*
DO 70 J = 1, N
I2 = MIN( J, IZERO )
DO 60 I = 1, I2
A( IOFF+I ) = ZERO
60 CONTINUE
IOFF = IOFF + J
70 CONTINUE
ELSE
*
* Set the last IZERO rows and columns to zero.
*
DO 90 J = 1, N
I1 = MAX( J, IZERO )
DO 80 I = I1, N
A( IOFF+I ) = ZERO
80 CONTINUE
IOFF = IOFF + N - J
90 CONTINUE
END IF
END IF
ELSE
IZERO = 0
END IF
*
DO 150 IFACT = 1, NFACT
*
* Do first for FACT = 'F', then for other values.
*
FACT = FACTS( IFACT )
*
* Compute the condition number for comparison with
* the value returned by DSPSVX.
*
IF( ZEROT ) THEN
IF( IFACT.EQ.1 )
$ GO TO 150
RCONDC = ZERO
*
ELSE IF( IFACT.EQ.1 ) THEN
*
* Compute the 1-norm of A.
*
ANORM = DLANSP( '1', UPLO, N, A, RWORK )
*
* Factor the matrix A.
*
CALL DCOPY( NPP, A, 1, AFAC, 1 )
CALL DSPTRF( UPLO, N, AFAC, IWORK, INFO )
*
* Compute inv(A) and take its norm.
*
CALL DCOPY( NPP, AFAC, 1, AINV, 1 )
CALL DSPTRI( UPLO, N, AINV, IWORK, WORK, INFO )
AINVNM = DLANSP( '1', UPLO, N, AINV, RWORK )
*
* Compute the 1-norm condition number of A.
*
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDC = ONE
ELSE
RCONDC = ( ONE / ANORM ) / AINVNM
END IF
END IF
*
* Form an exact solution and set the right hand side.
*
SRNAMT = 'DLARHS'
CALL DLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
$ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED,
$ INFO )
XTYPE = 'C'
*
* --- Test DSPSV ---
*
IF( IFACT.EQ.2 ) THEN
CALL DCOPY( NPP, A, 1, AFAC, 1 )
CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
* Factor the matrix and solve the system using DSPSV.
*
SRNAMT = 'DSPSV '
CALL DSPSV( UPLO, N, NRHS, AFAC, IWORK, X, LDA,
$ INFO )
*
* Adjust the expected value of INFO to account for
* pivoting.
*
K = IZERO
IF( K.GT.0 ) THEN
100 CONTINUE
IF( IWORK( K ).LT.0 ) THEN
IF( IWORK( K ).NE.-K ) THEN
K = -IWORK( K )
GO TO 100
END IF
ELSE IF( IWORK( K ).NE.K ) THEN
K = IWORK( K )
GO TO 100
END IF
END IF
*
* Check error code from DSPSV .
*
IF( INFO.NE.K ) THEN
CALL ALAERH( PATH, 'DSPSV ', INFO, K, UPLO, N,
$ N, -1, -1, NRHS, IMAT, NFAIL,
$ NERRS, NOUT )
GO TO 120
ELSE IF( INFO.NE.0 ) THEN
GO TO 120
END IF
*
* Reconstruct matrix from factors and compute
* residual.
*
CALL DSPT01( UPLO, N, A, AFAC, IWORK, AINV, LDA,
$ RWORK, RESULT( 1 ) )
*
* Compute residual of the computed solution.
*
CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
CALL DPPT02( UPLO, N, NRHS, A, X, LDA, WORK, LDA,
$ RWORK, RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
NT = 3
*
* Print information about the tests that did not pass
* the threshold.
*
DO 110 K = 1, NT
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )'DSPSV ', UPLO, N,
$ IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
110 CONTINUE
NRUN = NRUN + NT
120 CONTINUE
END IF
*
* --- Test DSPSVX ---
*
IF( IFACT.EQ.2 .AND. NPP.GT.0 )
$ CALL DLASET( 'Full', NPP, 1, ZERO, ZERO, AFAC,
$ NPP )
CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA )
*
* Solve the system and compute the condition number and
* error bounds using DSPSVX.
*
SRNAMT = 'DSPSVX'
CALL DSPSVX( FACT, UPLO, N, NRHS, A, AFAC, IWORK, B,
$ LDA, X, LDA, RCOND, RWORK,
$ RWORK( NRHS+1 ), WORK, IWORK( N+1 ),
$ INFO )
*
* Adjust the expected value of INFO to account for
* pivoting.
*
K = IZERO
IF( K.GT.0 ) THEN
130 CONTINUE
IF( IWORK( K ).LT.0 ) THEN
IF( IWORK( K ).NE.-K ) THEN
K = -IWORK( K )
GO TO 130
END IF
ELSE IF( IWORK( K ).NE.K ) THEN
K = IWORK( K )
GO TO 130
END IF
END IF
*
* Check the error code from DSPSVX.
*
IF( INFO.NE.K ) THEN
CALL ALAERH( PATH, 'DSPSVX', INFO, K, FACT // UPLO,
$ N, N, -1, -1, NRHS, IMAT, NFAIL,
$ NERRS, NOUT )
GO TO 150
END IF
*
IF( INFO.EQ.0 ) THEN
IF( IFACT.GE.2 ) THEN
*
* Reconstruct matrix from factors and compute
* residual.
*
CALL DSPT01( UPLO, N, A, AFAC, IWORK, AINV, LDA,
$ RWORK( 2*NRHS+1 ), RESULT( 1 ) )
K1 = 1
ELSE
K1 = 2
END IF
*
* Compute residual of the computed solution.
*
CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
CALL DPPT02( UPLO, N, NRHS, A, X, LDA, WORK, LDA,
$ RWORK( 2*NRHS+1 ), RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
*
* Check the error bounds from iterative refinement.
*
CALL DPPT05( UPLO, N, NRHS, A, B, LDA, X, LDA,
$ XACT, LDA, RWORK, RWORK( NRHS+1 ),
$ RESULT( 4 ) )
ELSE
K1 = 6
END IF
*
* Compare RCOND from DSPSVX with the computed value
* in RCONDC.
*
RESULT( 6 ) = DGET06( RCOND, RCONDC )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 140 K = K1, 6
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )'DSPSVX', FACT, UPLO,
$ N, IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
140 CONTINUE
NRUN = NRUN + 7 - K1
*
150 CONTINUE
*
160 CONTINUE
170 CONTINUE
180 CONTINUE
*
* Print a summary of the results.
*
CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( 1X, A6, ', UPLO=''', A1, ''', N =', I5, ', type ', I2,
$ ', test ', I2, ', ratio =', G12.5 )
9998 FORMAT( 1X, A6, ', FACT=''', A1, ''', UPLO=''', A1, ''', N =', I5,
$ ', type ', I2, ', test ', I2, ', ratio =', G12.5 )
RETURN
*
* End of DDRVSP
*
END
SUBROUTINE DDRVSY( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
$ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK,
$ NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NMAX, NN, NOUT, NRHS
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), NVAL( * )
DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
$ RWORK( * ), WORK( * ), X( * ), XACT( * )
* ..
*
* Purpose
* =======
*
* DDRVSY tests the driver routines DSYSV and -SVX.
*
* Arguments
* =========
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* The matrix types to be used for testing. Matrices of type j
* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix dimension N.
*
* NRHS (input) INTEGER
* The number of right hand side vectors to be generated for
* each linear system.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NMAX (input) INTEGER
* The maximum value permitted for N, used in dimensioning the
* work arrays.
*
* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
*
* WORK (workspace) DOUBLE PRECISION array, dimension
* (NMAX*max(2,NRHS))
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
*
* IWORK (workspace) INTEGER array, dimension (2*NMAX)
*
* NOUT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
INTEGER NTYPES, NTESTS
PARAMETER ( NTYPES = 10, NTESTS = 6 )
INTEGER NFACT
PARAMETER ( NFACT = 2 )
* ..
* .. Local Scalars ..
LOGICAL ZEROT
CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
CHARACTER*3 PATH
INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
$ IZERO, J, K, K1, KL, KU, LDA, LWORK, MODE, N,
$ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCOND, RCONDC
* ..
* .. Local Arrays ..
CHARACTER FACTS( NFACT ), UPLOS( 2 )
INTEGER ISEED( 4 ), ISEEDY( 4 )
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Functions ..
DOUBLE PRECISION DGET06, DLANSY
EXTERNAL DGET06, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL ALADHD, ALAERH, ALASVM, DERRVX, DGET04, DLACPY,
$ DLARHS, DLASET, DLATB4, DLATMS, DPOT02, DPOT05,
$ DSYSV, DSYSVX, DSYT01, DSYTRF, DSYTRI, XLAENV
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Data statements ..
DATA ISEEDY / 1988, 1989, 1990, 1991 /
DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' /
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'SY'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
LWORK = MAX( 2*NMAX, NMAX*NRHS )
*
* Test the error exits
*
IF( TSTERR )
$ CALL DERRVX( PATH, NOUT )
INFOT = 0
*
* Set the block size and minimum block size for testing.
*
NB = 1
NBMIN = 2
CALL XLAENV( 1, NB )
CALL XLAENV( 2, NBMIN )
*
* Do for each value of N in NVAL
*
DO 180 IN = 1, NN
N = NVAL( IN )
LDA = MAX( N, 1 )
XTYPE = 'N'
NIMAT = NTYPES
IF( N.LE.0 )
$ NIMAT = 1
*
DO 170 IMAT = 1, NIMAT
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 170
*
* Skip types 3, 4, 5, or 6 if the matrix size is too small.
*
ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
IF( ZEROT .AND. N.LT.IMAT-2 )
$ GO TO 170
*
* Do first for UPLO = 'U', then for UPLO = 'L'
*
DO 160 IUPLO = 1, 2
UPLO = UPLOS( IUPLO )
*
* Set up parameters with DLATB4 and generate a test matrix
* with DLATMS.
*
CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
*
SRNAMT = 'DLATMS'
CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
$ INFO )
*
* Check error code from DLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 160
END IF
*
* For types 3-6, zero one or more rows and columns of the
* matrix to test that INFO is returned correctly.
*
IF( ZEROT ) THEN
IF( IMAT.EQ.3 ) THEN
IZERO = 1
ELSE IF( IMAT.EQ.4 ) THEN
IZERO = N
ELSE
IZERO = N / 2 + 1
END IF
*
IF( IMAT.LT.6 ) THEN
*
* Set row and column IZERO to zero.
*
IF( IUPLO.EQ.1 ) THEN
IOFF = ( IZERO-1 )*LDA
DO 20 I = 1, IZERO - 1
A( IOFF+I ) = ZERO
20 CONTINUE
IOFF = IOFF + IZERO
DO 30 I = IZERO, N
A( IOFF ) = ZERO
IOFF = IOFF + LDA
30 CONTINUE
ELSE
IOFF = IZERO
DO 40 I = 1, IZERO - 1
A( IOFF ) = ZERO
IOFF = IOFF + LDA
40 CONTINUE
IOFF = IOFF - IZERO
DO 50 I = IZERO, N
A( IOFF+I ) = ZERO
50 CONTINUE
END IF
ELSE
IOFF = 0
IF( IUPLO.EQ.1 ) THEN
*
* Set the first IZERO rows and columns to zero.
*
DO 70 J = 1, N
I2 = MIN( J, IZERO )
DO 60 I = 1, I2
A( IOFF+I ) = ZERO
60 CONTINUE
IOFF = IOFF + LDA
70 CONTINUE
ELSE
*
* Set the last IZERO rows and columns to zero.
*
DO 90 J = 1, N
I1 = MAX( J, IZERO )
DO 80 I = I1, N
A( IOFF+I ) = ZERO
80 CONTINUE
IOFF = IOFF + LDA
90 CONTINUE
END IF
END IF
ELSE
IZERO = 0
END IF
*
DO 150 IFACT = 1, NFACT
*
* Do first for FACT = 'F', then for other values.
*
FACT = FACTS( IFACT )
*
* Compute the condition number for comparison with
* the value returned by DSYSVX.
*
IF( ZEROT ) THEN
IF( IFACT.EQ.1 )
$ GO TO 150
RCONDC = ZERO
*
ELSE IF( IFACT.EQ.1 ) THEN
*
* Compute the 1-norm of A.
*
ANORM = DLANSY( '1', UPLO, N, A, LDA, RWORK )
*
* Factor the matrix A.
*
CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
CALL DSYTRF( UPLO, N, AFAC, LDA, IWORK, WORK,
$ LWORK, INFO )
*
* Compute inv(A) and take its norm.
*
CALL DLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
CALL DSYTRI( UPLO, N, AINV, LDA, IWORK, WORK,
$ INFO )
AINVNM = DLANSY( '1', UPLO, N, AINV, LDA, RWORK )
*
* Compute the 1-norm condition number of A.
*
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCONDC = ONE
ELSE
RCONDC = ( ONE / ANORM ) / AINVNM
END IF
END IF
*
* Form an exact solution and set the right hand side.
*
SRNAMT = 'DLARHS'
CALL DLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
$ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED,
$ INFO )
XTYPE = 'C'
*
* --- Test DSYSV ---
*
IF( IFACT.EQ.2 ) THEN
CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
* Factor the matrix and solve the system using DSYSV.
*
SRNAMT = 'DSYSV '
CALL DSYSV( UPLO, N, NRHS, AFAC, LDA, IWORK, X,
$ LDA, WORK, LWORK, INFO )
*
* Adjust the expected value of INFO to account for
* pivoting.
*
K = IZERO
IF( K.GT.0 ) THEN
100 CONTINUE
IF( IWORK( K ).LT.0 ) THEN
IF( IWORK( K ).NE.-K ) THEN
K = -IWORK( K )
GO TO 100
END IF
ELSE IF( IWORK( K ).NE.K ) THEN
K = IWORK( K )
GO TO 100
END IF
END IF
*
* Check error code from DSYSV .
*
IF( INFO.NE.K ) THEN
CALL ALAERH( PATH, 'DSYSV ', INFO, K, UPLO, N,
$ N, -1, -1, NRHS, IMAT, NFAIL,
$ NERRS, NOUT )
GO TO 120
ELSE IF( INFO.NE.0 ) THEN
GO TO 120
END IF
*
* Reconstruct matrix from factors and compute
* residual.
*
CALL DSYT01( UPLO, N, A, LDA, AFAC, LDA, IWORK,
$ AINV, LDA, RWORK, RESULT( 1 ) )
*
* Compute residual of the computed solution.
*
CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
CALL DPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
$ LDA, RWORK, RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
NT = 3
*
* Print information about the tests that did not pass
* the threshold.
*
DO 110 K = 1, NT
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )'DSYSV ', UPLO, N,
$ IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
110 CONTINUE
NRUN = NRUN + NT
120 CONTINUE
END IF
*
* --- Test DSYSVX ---
*
IF( IFACT.EQ.2 )
$ CALL DLASET( UPLO, N, N, ZERO, ZERO, AFAC, LDA )
CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA )
*
* Solve the system and compute the condition number and
* error bounds using DSYSVX.
*
SRNAMT = 'DSYSVX'
CALL DSYSVX( FACT, UPLO, N, NRHS, A, LDA, AFAC, LDA,
$ IWORK, B, LDA, X, LDA, RCOND, RWORK,
$ RWORK( NRHS+1 ), WORK, LWORK,
$ IWORK( N+1 ), INFO )
*
* Adjust the expected value of INFO to account for
* pivoting.
*
K = IZERO
IF( K.GT.0 ) THEN
130 CONTINUE
IF( IWORK( K ).LT.0 ) THEN
IF( IWORK( K ).NE.-K ) THEN
K = -IWORK( K )
GO TO 130
END IF
ELSE IF( IWORK( K ).NE.K ) THEN
K = IWORK( K )
GO TO 130
END IF
END IF
*
* Check the error code from DSYSVX.
*
IF( INFO.NE.K ) THEN
CALL ALAERH( PATH, 'DSYSVX', INFO, K, FACT // UPLO,
$ N, N, -1, -1, NRHS, IMAT, NFAIL,
$ NERRS, NOUT )
GO TO 150
END IF
*
IF( INFO.EQ.0 ) THEN
IF( IFACT.GE.2 ) THEN
*
* Reconstruct matrix from factors and compute
* residual.
*
CALL DSYT01( UPLO, N, A, LDA, AFAC, LDA, IWORK,
$ AINV, LDA, RWORK( 2*NRHS+1 ),
$ RESULT( 1 ) )
K1 = 1
ELSE
K1 = 2
END IF
*
* Compute residual of the computed solution.
*
CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
CALL DPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
$ LDA, RWORK( 2*NRHS+1 ), RESULT( 2 ) )
*
* Check solution from generated exact solution.
*
CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
$ RESULT( 3 ) )
*
* Check the error bounds from iterative refinement.
*
CALL DPOT05( UPLO, N, NRHS, A, LDA, B, LDA, X, LDA,
$ XACT, LDA, RWORK, RWORK( NRHS+1 ),
$ RESULT( 4 ) )
ELSE
K1 = 6
END IF
*
* Compare RCOND from DSYSVX with the computed value
* in RCONDC.
*
RESULT( 6 ) = DGET06( RCOND, RCONDC )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 140 K = K1, 6
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALADHD( NOUT, PATH )
WRITE( NOUT, FMT = 9998 )'DSYSVX', FACT, UPLO,
$ N, IMAT, K, RESULT( K )
NFAIL = NFAIL + 1
END IF
140 CONTINUE
NRUN = NRUN + 7 - K1
*
150 CONTINUE
*
160 CONTINUE
170 CONTINUE
180 CONTINUE
*
* Print a summary of the results.
*
CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( 1X, A6, ', UPLO=''', A1, ''', N =', I5, ', type ', I2,
$ ', test ', I2, ', ratio =', G12.5 )
9998 FORMAT( 1X, A6, ', FACT=''', A1, ''', UPLO=''', A1, ''', N =', I5,
$ ', type ', I2, ', test ', I2, ', ratio =', G12.5 )
RETURN
*
* End of DDRVSY
*
END
SUBROUTINE DERRGE( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* DERRGE tests the error exits for the DOUBLE PRECISION routines
* for general matrices.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX, LW
PARAMETER ( NMAX = 4, LW = 3*NMAX )
* ..
* .. Local Scalars ..
CHARACTER*2 C2
INTEGER I, INFO, J
DOUBLE PRECISION ANRM, CCOND, RCOND
* ..
* .. Local Arrays ..
INTEGER IP( NMAX ), IW( NMAX )
DOUBLE PRECISION A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
$ R1( NMAX ), R2( NMAX ), W( LW ), X( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, DGBCON, DGBEQU, DGBRFS, DGBTF2,
$ DGBTRF, DGBTRS, DGECON, DGEEQU, DGERFS, DGETF2,
$ DGETRF, DGETRI, DGETRS
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
C2 = PATH( 2: 3 )
*
* Set the variables to innocuous values.
*
DO 20 J = 1, NMAX
DO 10 I = 1, NMAX
A( I, J ) = 1.D0 / DBLE( I+J )
AF( I, J ) = 1.D0 / DBLE( I+J )
10 CONTINUE
B( J ) = 0.D0
R1( J ) = 0.D0
R2( J ) = 0.D0
W( J ) = 0.D0
X( J ) = 0.D0
IP( J ) = J
IW( J ) = J
20 CONTINUE
OK = .TRUE.
*
IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
* Test error exits of the routines that use the LU decomposition
* of a general matrix.
*
* DGETRF
*
SRNAMT = 'DGETRF'
INFOT = 1
CALL DGETRF( -1, 0, A, 1, IP, INFO )
CALL CHKXER( 'DGETRF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGETRF( 0, -1, A, 1, IP, INFO )
CALL CHKXER( 'DGETRF', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGETRF( 2, 1, A, 1, IP, INFO )
CALL CHKXER( 'DGETRF', INFOT, NOUT, LERR, OK )
*
* DGETF2
*
SRNAMT = 'DGETF2'
INFOT = 1
CALL DGETF2( -1, 0, A, 1, IP, INFO )
CALL CHKXER( 'DGETF2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGETF2( 0, -1, A, 1, IP, INFO )
CALL CHKXER( 'DGETF2', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGETF2( 2, 1, A, 1, IP, INFO )
CALL CHKXER( 'DGETF2', INFOT, NOUT, LERR, OK )
*
* DGETRI
*
SRNAMT = 'DGETRI'
INFOT = 1
CALL DGETRI( -1, A, 1, IP, W, LW, INFO )
CALL CHKXER( 'DGETRI', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGETRI( 2, A, 1, IP, W, LW, INFO )
CALL CHKXER( 'DGETRI', INFOT, NOUT, LERR, OK )
*
* DGETRS
*
SRNAMT = 'DGETRS'
INFOT = 1
CALL DGETRS( '/', 0, 0, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'DGETRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGETRS( 'N', -1, 0, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'DGETRS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGETRS( 'N', 0, -1, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'DGETRS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGETRS( 'N', 2, 1, A, 1, IP, B, 2, INFO )
CALL CHKXER( 'DGETRS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DGETRS( 'N', 2, 1, A, 2, IP, B, 1, INFO )
CALL CHKXER( 'DGETRS', INFOT, NOUT, LERR, OK )
*
* DGERFS
*
SRNAMT = 'DGERFS'
INFOT = 1
CALL DGERFS( '/', 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'DGERFS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGERFS( 'N', -1, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2,
$ W, IW, INFO )
CALL CHKXER( 'DGERFS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGERFS( 'N', 0, -1, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2,
$ W, IW, INFO )
CALL CHKXER( 'DGERFS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGERFS( 'N', 2, 1, A, 1, AF, 2, IP, B, 2, X, 2, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'DGERFS', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DGERFS( 'N', 2, 1, A, 2, AF, 1, IP, B, 2, X, 2, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'DGERFS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DGERFS( 'N', 2, 1, A, 2, AF, 2, IP, B, 1, X, 2, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'DGERFS', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DGERFS( 'N', 2, 1, A, 2, AF, 2, IP, B, 2, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'DGERFS', INFOT, NOUT, LERR, OK )
*
* DGECON
*
SRNAMT = 'DGECON'
INFOT = 1
CALL DGECON( '/', 0, A, 1, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'DGECON', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGECON( '1', -1, A, 1, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'DGECON', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGECON( '1', 2, A, 1, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'DGECON', INFOT, NOUT, LERR, OK )
*
* DGEEQU
*
SRNAMT = 'DGEEQU'
INFOT = 1
CALL DGEEQU( -1, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO )
CALL CHKXER( 'DGEEQU', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGEEQU( 0, -1, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO )
CALL CHKXER( 'DGEEQU', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGEEQU( 2, 2, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO )
CALL CHKXER( 'DGEEQU', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
*
* Test error exits of the routines that use the LU decomposition
* of a general band matrix.
*
* DGBTRF
*
SRNAMT = 'DGBTRF'
INFOT = 1
CALL DGBTRF( -1, 0, 0, 0, A, 1, IP, INFO )
CALL CHKXER( 'DGBTRF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGBTRF( 0, -1, 0, 0, A, 1, IP, INFO )
CALL CHKXER( 'DGBTRF', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGBTRF( 1, 1, -1, 0, A, 1, IP, INFO )
CALL CHKXER( 'DGBTRF', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGBTRF( 1, 1, 0, -1, A, 1, IP, INFO )
CALL CHKXER( 'DGBTRF', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DGBTRF( 2, 2, 1, 1, A, 3, IP, INFO )
CALL CHKXER( 'DGBTRF', INFOT, NOUT, LERR, OK )
*
* DGBTF2
*
SRNAMT = 'DGBTF2'
INFOT = 1
CALL DGBTF2( -1, 0, 0, 0, A, 1, IP, INFO )
CALL CHKXER( 'DGBTF2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGBTF2( 0, -1, 0, 0, A, 1, IP, INFO )
CALL CHKXER( 'DGBTF2', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGBTF2( 1, 1, -1, 0, A, 1, IP, INFO )
CALL CHKXER( 'DGBTF2', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGBTF2( 1, 1, 0, -1, A, 1, IP, INFO )
CALL CHKXER( 'DGBTF2', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DGBTF2( 2, 2, 1, 1, A, 3, IP, INFO )
CALL CHKXER( 'DGBTF2', INFOT, NOUT, LERR, OK )
*
* DGBTRS
*
SRNAMT = 'DGBTRS'
INFOT = 1
CALL DGBTRS( '/', 0, 0, 0, 1, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'DGBTRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGBTRS( 'N', -1, 0, 0, 1, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'DGBTRS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGBTRS( 'N', 1, -1, 0, 1, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'DGBTRS', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGBTRS( 'N', 1, 0, -1, 1, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'DGBTRS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGBTRS( 'N', 1, 0, 0, -1, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'DGBTRS', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DGBTRS( 'N', 2, 1, 1, 1, A, 3, IP, B, 2, INFO )
CALL CHKXER( 'DGBTRS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DGBTRS( 'N', 2, 0, 0, 1, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'DGBTRS', INFOT, NOUT, LERR, OK )
*
* DGBRFS
*
SRNAMT = 'DGBRFS'
INFOT = 1
CALL DGBRFS( '/', 0, 0, 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1,
$ R2, W, IW, INFO )
CALL CHKXER( 'DGBRFS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGBRFS( 'N', -1, 0, 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1,
$ R2, W, IW, INFO )
CALL CHKXER( 'DGBRFS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGBRFS( 'N', 1, -1, 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1,
$ R2, W, IW, INFO )
CALL CHKXER( 'DGBRFS', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGBRFS( 'N', 1, 0, -1, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1,
$ R2, W, IW, INFO )
CALL CHKXER( 'DGBRFS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGBRFS( 'N', 1, 0, 0, -1, A, 1, AF, 1, IP, B, 1, X, 1, R1,
$ R2, W, IW, INFO )
CALL CHKXER( 'DGBRFS', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DGBRFS( 'N', 2, 1, 1, 1, A, 2, AF, 4, IP, B, 2, X, 2, R1,
$ R2, W, IW, INFO )
CALL CHKXER( 'DGBRFS', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DGBRFS( 'N', 2, 1, 1, 1, A, 3, AF, 3, IP, B, 2, X, 2, R1,
$ R2, W, IW, INFO )
CALL CHKXER( 'DGBRFS', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DGBRFS( 'N', 2, 0, 0, 1, A, 1, AF, 1, IP, B, 1, X, 2, R1,
$ R2, W, IW, INFO )
CALL CHKXER( 'DGBRFS', INFOT, NOUT, LERR, OK )
INFOT = 14
CALL DGBRFS( 'N', 2, 0, 0, 1, A, 1, AF, 1, IP, B, 2, X, 1, R1,
$ R2, W, IW, INFO )
CALL CHKXER( 'DGBRFS', INFOT, NOUT, LERR, OK )
*
* DGBCON
*
SRNAMT = 'DGBCON'
INFOT = 1
CALL DGBCON( '/', 0, 0, 0, A, 1, IP, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'DGBCON', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGBCON( '1', -1, 0, 0, A, 1, IP, ANRM, RCOND, W, IW,
$ INFO )
CALL CHKXER( 'DGBCON', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGBCON( '1', 1, -1, 0, A, 1, IP, ANRM, RCOND, W, IW,
$ INFO )
CALL CHKXER( 'DGBCON', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGBCON( '1', 1, 0, -1, A, 1, IP, ANRM, RCOND, W, IW,
$ INFO )
CALL CHKXER( 'DGBCON', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DGBCON( '1', 2, 1, 1, A, 3, IP, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'DGBCON', INFOT, NOUT, LERR, OK )
*
* DGBEQU
*
SRNAMT = 'DGBEQU'
INFOT = 1
CALL DGBEQU( -1, 0, 0, 0, A, 1, R1, R2, RCOND, CCOND, ANRM,
$ INFO )
CALL CHKXER( 'DGBEQU', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGBEQU( 0, -1, 0, 0, A, 1, R1, R2, RCOND, CCOND, ANRM,
$ INFO )
CALL CHKXER( 'DGBEQU', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGBEQU( 1, 1, -1, 0, A, 1, R1, R2, RCOND, CCOND, ANRM,
$ INFO )
CALL CHKXER( 'DGBEQU', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGBEQU( 1, 1, 0, -1, A, 1, R1, R2, RCOND, CCOND, ANRM,
$ INFO )
CALL CHKXER( 'DGBEQU', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DGBEQU( 2, 2, 1, 1, A, 2, R1, R2, RCOND, CCOND, ANRM,
$ INFO )
CALL CHKXER( 'DGBEQU', INFOT, NOUT, LERR, OK )
END IF
*
* Print a summary line.
*
CALL ALAESM( PATH, OK, NOUT )
*
RETURN
*
* End of DERRGE
*
END
SUBROUTINE DERRGT( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* DERRGT tests the error exits for the DOUBLE PRECISION tridiagonal
* routines.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 2 )
* ..
* .. Local Scalars ..
CHARACTER*2 C2
INTEGER INFO
DOUBLE PRECISION ANORM, RCOND
* ..
* .. Local Arrays ..
INTEGER IP( NMAX ), IW( NMAX )
DOUBLE PRECISION B( NMAX ), C( NMAX ), CF( NMAX ), D( NMAX ),
$ DF( NMAX ), E( NMAX ), EF( NMAX ), F( NMAX ),
$ R1( NMAX ), R2( NMAX ), W( NMAX ), X( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, DGTCON, DGTRFS, DGTTRF, DGTTRS,
$ DPTCON, DPTRFS, DPTTRF, DPTTRS
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
C2 = PATH( 2: 3 )
D( 1 ) = 1.D0
D( 2 ) = 2.D0
DF( 1 ) = 1.D0
DF( 2 ) = 2.D0
E( 1 ) = 3.D0
E( 2 ) = 4.D0
EF( 1 ) = 3.D0
EF( 2 ) = 4.D0
ANORM = 1.0D0
OK = .TRUE.
*
IF( LSAMEN( 2, C2, 'GT' ) ) THEN
*
* Test error exits for the general tridiagonal routines.
*
* DGTTRF
*
SRNAMT = 'DGTTRF'
INFOT = 1
CALL DGTTRF( -1, C, D, E, F, IP, INFO )
CALL CHKXER( 'DGTTRF', INFOT, NOUT, LERR, OK )
*
* DGTTRS
*
SRNAMT = 'DGTTRS'
INFOT = 1
CALL DGTTRS( '/', 0, 0, C, D, E, F, IP, X, 1, INFO )
CALL CHKXER( 'DGTTRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGTTRS( 'N', -1, 0, C, D, E, F, IP, X, 1, INFO )
CALL CHKXER( 'DGTTRS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGTTRS( 'N', 0, -1, C, D, E, F, IP, X, 1, INFO )
CALL CHKXER( 'DGTTRS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DGTTRS( 'N', 2, 1, C, D, E, F, IP, X, 1, INFO )
CALL CHKXER( 'DGTTRS', INFOT, NOUT, LERR, OK )
*
* DGTRFS
*
SRNAMT = 'DGTRFS'
INFOT = 1
CALL DGTRFS( '/', 0, 0, C, D, E, CF, DF, EF, F, IP, B, 1, X, 1,
$ R1, R2, W, IW, INFO )
CALL CHKXER( 'DGTRFS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGTRFS( 'N', -1, 0, C, D, E, CF, DF, EF, F, IP, B, 1, X,
$ 1, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGTRFS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGTRFS( 'N', 0, -1, C, D, E, CF, DF, EF, F, IP, B, 1, X,
$ 1, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGTRFS', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL DGTRFS( 'N', 2, 1, C, D, E, CF, DF, EF, F, IP, B, 1, X, 2,
$ R1, R2, W, IW, INFO )
CALL CHKXER( 'DGTRFS', INFOT, NOUT, LERR, OK )
INFOT = 15
CALL DGTRFS( 'N', 2, 1, C, D, E, CF, DF, EF, F, IP, B, 2, X, 1,
$ R1, R2, W, IW, INFO )
CALL CHKXER( 'DGTRFS', INFOT, NOUT, LERR, OK )
*
* DGTCON
*
SRNAMT = 'DGTCON'
INFOT = 1
CALL DGTCON( '/', 0, C, D, E, F, IP, ANORM, RCOND, W, IW,
$ INFO )
CALL CHKXER( 'DGTCON', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGTCON( 'I', -1, C, D, E, F, IP, ANORM, RCOND, W, IW,
$ INFO )
CALL CHKXER( 'DGTCON', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DGTCON( 'I', 0, C, D, E, F, IP, -ANORM, RCOND, W, IW,
$ INFO )
CALL CHKXER( 'DGTCON', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'PT' ) ) THEN
*
* Test error exits for the positive definite tridiagonal
* routines.
*
* DPTTRF
*
SRNAMT = 'DPTTRF'
INFOT = 1
CALL DPTTRF( -1, D, E, INFO )
CALL CHKXER( 'DPTTRF', INFOT, NOUT, LERR, OK )
*
* DPTTRS
*
SRNAMT = 'DPTTRS'
INFOT = 1
CALL DPTTRS( -1, 0, D, E, X, 1, INFO )
CALL CHKXER( 'DPTTRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DPTTRS( 0, -1, D, E, X, 1, INFO )
CALL CHKXER( 'DPTTRS', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DPTTRS( 2, 1, D, E, X, 1, INFO )
CALL CHKXER( 'DPTTRS', INFOT, NOUT, LERR, OK )
*
* DPTRFS
*
SRNAMT = 'DPTRFS'
INFOT = 1
CALL DPTRFS( -1, 0, D, E, DF, EF, B, 1, X, 1, R1, R2, W, INFO )
CALL CHKXER( 'DPTRFS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DPTRFS( 0, -1, D, E, DF, EF, B, 1, X, 1, R1, R2, W, INFO )
CALL CHKXER( 'DPTRFS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DPTRFS( 2, 1, D, E, DF, EF, B, 1, X, 2, R1, R2, W, INFO )
CALL CHKXER( 'DPTRFS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DPTRFS( 2, 1, D, E, DF, EF, B, 2, X, 1, R1, R2, W, INFO )
CALL CHKXER( 'DPTRFS', INFOT, NOUT, LERR, OK )
*
* DPTCON
*
SRNAMT = 'DPTCON'
INFOT = 1
CALL DPTCON( -1, D, E, ANORM, RCOND, W, INFO )
CALL CHKXER( 'DPTCON', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DPTCON( 0, D, E, -ANORM, RCOND, W, INFO )
CALL CHKXER( 'DPTCON', INFOT, NOUT, LERR, OK )
END IF
*
* Print a summary line.
*
CALL ALAESM( PATH, OK, NOUT )
*
RETURN
*
* End of DERRGT
*
END
SUBROUTINE DERRLQ( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* DERRLQ tests the error exits for the DOUBLE PRECISION routines
* that use the LQ decomposition of a general matrix.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 2 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
* ..
* .. Local Arrays ..
DOUBLE PRECISION A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
$ W( NMAX ), X( NMAX )
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, DGELQ2, DGELQF, DGELQS, DORGL2,
$ DORGLQ, DORML2, DORMLQ
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
*
* Set the variables to innocuous values.
*
DO 20 J = 1, NMAX
DO 10 I = 1, NMAX
A( I, J ) = 1.D0 / DBLE( I+J )
AF( I, J ) = 1.D0 / DBLE( I+J )
10 CONTINUE
B( J ) = 0.D0
W( J ) = 0.D0
X( J ) = 0.D0
20 CONTINUE
OK = .TRUE.
*
* Error exits for LQ factorization
*
* DGELQF
*
SRNAMT = 'DGELQF'
INFOT = 1
CALL DGELQF( -1, 0, A, 1, B, W, 1, INFO )
CALL CHKXER( 'DGELQF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGELQF( 0, -1, A, 1, B, W, 1, INFO )
CALL CHKXER( 'DGELQF', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGELQF( 2, 1, A, 1, B, W, 2, INFO )
CALL CHKXER( 'DGELQF', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DGELQF( 2, 1, A, 2, B, W, 1, INFO )
CALL CHKXER( 'DGELQF', INFOT, NOUT, LERR, OK )
*
* DGELQ2
*
SRNAMT = 'DGELQ2'
INFOT = 1
CALL DGELQ2( -1, 0, A, 1, B, W, INFO )
CALL CHKXER( 'DGELQ2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGELQ2( 0, -1, A, 1, B, W, INFO )
CALL CHKXER( 'DGELQ2', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGELQ2( 2, 1, A, 1, B, W, INFO )
CALL CHKXER( 'DGELQ2', INFOT, NOUT, LERR, OK )
*
* DGELQS
*
SRNAMT = 'DGELQS'
INFOT = 1
CALL DGELQS( -1, 0, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGELQS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGELQS( 0, -1, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGELQS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGELQS( 2, 1, 0, A, 2, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGELQS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGELQS( 0, 0, -1, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGELQS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGELQS( 2, 2, 0, A, 1, X, B, 2, W, 1, INFO )
CALL CHKXER( 'DGELQS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DGELQS( 1, 2, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGELQS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DGELQS( 1, 1, 2, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGELQS', INFOT, NOUT, LERR, OK )
*
* DORGLQ
*
SRNAMT = 'DORGLQ'
INFOT = 1
CALL DORGLQ( -1, 0, 0, A, 1, X, W, 1, INFO )
CALL CHKXER( 'DORGLQ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORGLQ( 0, -1, 0, A, 1, X, W, 1, INFO )
CALL CHKXER( 'DORGLQ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORGLQ( 2, 1, 0, A, 2, X, W, 2, INFO )
CALL CHKXER( 'DORGLQ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORGLQ( 0, 0, -1, A, 1, X, W, 1, INFO )
CALL CHKXER( 'DORGLQ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORGLQ( 1, 1, 2, A, 1, X, W, 1, INFO )
CALL CHKXER( 'DORGLQ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORGLQ( 2, 2, 0, A, 1, X, W, 2, INFO )
CALL CHKXER( 'DORGLQ', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DORGLQ( 2, 2, 0, A, 2, X, W, 1, INFO )
CALL CHKXER( 'DORGLQ', INFOT, NOUT, LERR, OK )
*
* DORGL2
*
SRNAMT = 'DORGL2'
INFOT = 1
CALL DORGL2( -1, 0, 0, A, 1, X, W, INFO )
CALL CHKXER( 'DORGL2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORGL2( 0, -1, 0, A, 1, X, W, INFO )
CALL CHKXER( 'DORGL2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORGL2( 2, 1, 0, A, 2, X, W, INFO )
CALL CHKXER( 'DORGL2', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORGL2( 0, 0, -1, A, 1, X, W, INFO )
CALL CHKXER( 'DORGL2', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORGL2( 1, 1, 2, A, 1, X, W, INFO )
CALL CHKXER( 'DORGL2', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORGL2( 2, 2, 0, A, 1, X, W, INFO )
CALL CHKXER( 'DORGL2', INFOT, NOUT, LERR, OK )
*
* DORMLQ
*
SRNAMT = 'DORMLQ'
INFOT = 1
CALL DORMLQ( '/', 'N', 0, 0, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMLQ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORMLQ( 'L', '/', 0, 0, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMLQ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORMLQ( 'L', 'N', -1, 0, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMLQ', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DORMLQ( 'L', 'N', 0, -1, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMLQ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORMLQ( 'L', 'N', 0, 0, -1, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMLQ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORMLQ( 'L', 'N', 0, 1, 1, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMLQ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORMLQ( 'R', 'N', 1, 0, 1, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMLQ', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DORMLQ( 'L', 'N', 2, 0, 2, A, 1, X, AF, 2, W, 1, INFO )
CALL CHKXER( 'DORMLQ', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DORMLQ( 'R', 'N', 0, 2, 2, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMLQ', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DORMLQ( 'L', 'N', 2, 1, 0, A, 2, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMLQ', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DORMLQ( 'L', 'N', 1, 2, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMLQ', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DORMLQ( 'R', 'N', 2, 1, 0, A, 1, X, AF, 2, W, 1, INFO )
CALL CHKXER( 'DORMLQ', INFOT, NOUT, LERR, OK )
*
* DORML2
*
SRNAMT = 'DORML2'
INFOT = 1
CALL DORML2( '/', 'N', 0, 0, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORML2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORML2( 'L', '/', 0, 0, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORML2', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORML2( 'L', 'N', -1, 0, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORML2', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DORML2( 'L', 'N', 0, -1, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORML2', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORML2( 'L', 'N', 0, 0, -1, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORML2', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORML2( 'L', 'N', 0, 1, 1, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORML2', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORML2( 'R', 'N', 1, 0, 1, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORML2', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DORML2( 'L', 'N', 2, 1, 2, A, 1, X, AF, 2, W, INFO )
CALL CHKXER( 'DORML2', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DORML2( 'R', 'N', 1, 2, 2, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORML2', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DORML2( 'L', 'N', 2, 1, 0, A, 2, X, AF, 1, W, INFO )
CALL CHKXER( 'DORML2', INFOT, NOUT, LERR, OK )
*
* Print a summary line.
*
CALL ALAESM( PATH, OK, NOUT )
*
RETURN
*
* End of DERRLQ
*
END
SUBROUTINE DERRLS( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* DERRLS tests the error exits for the DOUBLE PRECISION least squares
* driver routines (DGELS, SGELSS, SGELSX, SGELSY, SGELSD).
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 2 )
* ..
* .. Local Scalars ..
CHARACTER*2 C2
INTEGER INFO, IRNK
DOUBLE PRECISION RCOND
* ..
* .. Local Arrays ..
INTEGER IP( NMAX )
DOUBLE PRECISION A( NMAX, NMAX ), B( NMAX, NMAX ), S( NMAX ),
$ W( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, DGELS, DGELSD, DGELSS, DGELSX,
$ DGELSY
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
C2 = PATH( 2: 3 )
A( 1, 1 ) = 1.0D+0
A( 1, 2 ) = 2.0D+0
A( 2, 2 ) = 3.0D+0
A( 2, 1 ) = 4.0D+0
OK = .TRUE.
*
IF( LSAMEN( 2, C2, 'LS' ) ) THEN
*
* Test error exits for the least squares driver routines.
*
* DGELS
*
SRNAMT = 'DGELS '
INFOT = 1
CALL DGELS( '/', 0, 0, 0, A, 1, B, 1, W, 1, INFO )
CALL CHKXER( 'DGELS ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGELS( 'N', -1, 0, 0, A, 1, B, 1, W, 1, INFO )
CALL CHKXER( 'DGELS ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGELS( 'N', 0, -1, 0, A, 1, B, 1, W, 1, INFO )
CALL CHKXER( 'DGELS ', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGELS( 'N', 0, 0, -1, A, 1, B, 1, W, 1, INFO )
CALL CHKXER( 'DGELS ', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DGELS( 'N', 2, 0, 0, A, 1, B, 2, W, 2, INFO )
CALL CHKXER( 'DGELS ', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DGELS( 'N', 2, 0, 0, A, 2, B, 1, W, 2, INFO )
CALL CHKXER( 'DGELS ', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DGELS( 'N', 1, 1, 0, A, 1, B, 1, W, 1, INFO )
CALL CHKXER( 'DGELS ', INFOT, NOUT, LERR, OK )
*
* DGELSS
*
SRNAMT = 'DGELSS'
INFOT = 1
CALL DGELSS( -1, 0, 0, A, 1, B, 1, S, RCOND, IRNK, W, 1, INFO )
CALL CHKXER( 'DGELSS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGELSS( 0, -1, 0, A, 1, B, 1, S, RCOND, IRNK, W, 1, INFO )
CALL CHKXER( 'DGELSS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGELSS( 0, 0, -1, A, 1, B, 1, S, RCOND, IRNK, W, 1, INFO )
CALL CHKXER( 'DGELSS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGELSS( 2, 0, 0, A, 1, B, 2, S, RCOND, IRNK, W, 2, INFO )
CALL CHKXER( 'DGELSS', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DGELSS( 2, 0, 0, A, 2, B, 1, S, RCOND, IRNK, W, 2, INFO )
CALL CHKXER( 'DGELSS', INFOT, NOUT, LERR, OK )
*
* DGELSX
*
SRNAMT = 'DGELSX'
INFOT = 1
CALL DGELSX( -1, 0, 0, A, 1, B, 1, IP, RCOND, IRNK, W, INFO )
CALL CHKXER( 'DGELSX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGELSX( 0, -1, 0, A, 1, B, 1, IP, RCOND, IRNK, W, INFO )
CALL CHKXER( 'DGELSX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGELSX( 0, 0, -1, A, 1, B, 1, IP, RCOND, IRNK, W, INFO )
CALL CHKXER( 'DGELSX', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGELSX( 2, 0, 0, A, 1, B, 2, IP, RCOND, IRNK, W, INFO )
CALL CHKXER( 'DGELSX', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DGELSX( 2, 0, 0, A, 2, B, 1, IP, RCOND, IRNK, W, INFO )
CALL CHKXER( 'DGELSX', INFOT, NOUT, LERR, OK )
*
* DGELSY
*
SRNAMT = 'DGELSY'
INFOT = 1
CALL DGELSY( -1, 0, 0, A, 1, B, 1, IP, RCOND, IRNK, W, 10,
$ INFO )
CALL CHKXER( 'DGELSY', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGELSY( 0, -1, 0, A, 1, B, 1, IP, RCOND, IRNK, W, 10,
$ INFO )
CALL CHKXER( 'DGELSY', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGELSY( 0, 0, -1, A, 1, B, 1, IP, RCOND, IRNK, W, 10,
$ INFO )
CALL CHKXER( 'DGELSY', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGELSY( 2, 0, 0, A, 1, B, 2, IP, RCOND, IRNK, W, 10,
$ INFO )
CALL CHKXER( 'DGELSY', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DGELSY( 2, 0, 0, A, 2, B, 1, IP, RCOND, IRNK, W, 10,
$ INFO )
CALL CHKXER( 'DGELSY', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DGELSY( 2, 2, 1, A, 2, B, 2, IP, RCOND, IRNK, W, 1, INFO )
CALL CHKXER( 'DGELSY', INFOT, NOUT, LERR, OK )
*
* DGELSD
*
SRNAMT = 'DGELSD'
INFOT = 1
CALL DGELSD( -1, 0, 0, A, 1, B, 1, S, RCOND, IRNK, W, 10, IP,
$ INFO )
CALL CHKXER( 'DGELSD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGELSD( 0, -1, 0, A, 1, B, 1, S, RCOND, IRNK, W, 10, IP,
$ INFO )
CALL CHKXER( 'DGELSD', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGELSD( 0, 0, -1, A, 1, B, 1, S, RCOND, IRNK, W, 10, IP,
$ INFO )
CALL CHKXER( 'DGELSD', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGELSD( 2, 0, 0, A, 1, B, 2, S, RCOND, IRNK, W, 10, IP,
$ INFO )
CALL CHKXER( 'DGELSD', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DGELSD( 2, 0, 0, A, 2, B, 1, S, RCOND, IRNK, W, 10, IP,
$ INFO )
CALL CHKXER( 'DGELSD', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DGELSD( 2, 2, 1, A, 2, B, 2, S, RCOND, IRNK, W, 1, IP,
$ INFO )
CALL CHKXER( 'DGELSD', INFOT, NOUT, LERR, OK )
END IF
*
* Print a summary line.
*
CALL ALAESM( PATH, OK, NOUT )
*
RETURN
*
* End of DERRLS
*
END
SUBROUTINE DERRPO( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* DERRPO tests the error exits for the DOUBLE PRECISION routines
* for symmetric positive definite matrices.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 4 )
* ..
* .. Local Scalars ..
CHARACTER*2 C2
INTEGER I, INFO, J
DOUBLE PRECISION ANRM, RCOND
* ..
* .. Local Arrays ..
INTEGER IW( NMAX )
DOUBLE PRECISION A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
$ R1( NMAX ), R2( NMAX ), W( 3*NMAX ), X( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, DPBCON, DPBEQU, DPBRFS, DPBTF2,
$ DPBTRF, DPBTRS, DPOCON, DPOEQU, DPORFS, DPOTF2,
$ DPOTRF, DPOTRI, DPOTRS, DPPCON, DPPEQU, DPPRFS,
$ DPPTRF, DPPTRI, DPPTRS
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
C2 = PATH( 2: 3 )
*
* Set the variables to innocuous values.
*
DO 20 J = 1, NMAX
DO 10 I = 1, NMAX
A( I, J ) = 1.D0 / DBLE( I+J )
AF( I, J ) = 1.D0 / DBLE( I+J )
10 CONTINUE
B( J ) = 0.D0
R1( J ) = 0.D0
R2( J ) = 0.D0
W( J ) = 0.D0
X( J ) = 0.D0
IW( J ) = J
20 CONTINUE
OK = .TRUE.
*
IF( LSAMEN( 2, C2, 'PO' ) ) THEN
*
* Test error exits of the routines that use the Cholesky
* decomposition of a symmetric positive definite matrix.
*
* DPOTRF
*
SRNAMT = 'DPOTRF'
INFOT = 1
CALL DPOTRF( '/', 0, A, 1, INFO )
CALL CHKXER( 'DPOTRF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DPOTRF( 'U', -1, A, 1, INFO )
CALL CHKXER( 'DPOTRF', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DPOTRF( 'U', 2, A, 1, INFO )
CALL CHKXER( 'DPOTRF', INFOT, NOUT, LERR, OK )
*
* DPOTF2
*
SRNAMT = 'DPOTF2'
INFOT = 1
CALL DPOTF2( '/', 0, A, 1, INFO )
CALL CHKXER( 'DPOTF2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DPOTF2( 'U', -1, A, 1, INFO )
CALL CHKXER( 'DPOTF2', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DPOTF2( 'U', 2, A, 1, INFO )
CALL CHKXER( 'DPOTF2', INFOT, NOUT, LERR, OK )
*
* DPOTRI
*
SRNAMT = 'DPOTRI'
INFOT = 1
CALL DPOTRI( '/', 0, A, 1, INFO )
CALL CHKXER( 'DPOTRI', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DPOTRI( 'U', -1, A, 1, INFO )
CALL CHKXER( 'DPOTRI', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DPOTRI( 'U', 2, A, 1, INFO )
CALL CHKXER( 'DPOTRI', INFOT, NOUT, LERR, OK )
*
* DPOTRS
*
SRNAMT = 'DPOTRS'
INFOT = 1
CALL DPOTRS( '/', 0, 0, A, 1, B, 1, INFO )
CALL CHKXER( 'DPOTRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DPOTRS( 'U', -1, 0, A, 1, B, 1, INFO )
CALL CHKXER( 'DPOTRS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DPOTRS( 'U', 0, -1, A, 1, B, 1, INFO )
CALL CHKXER( 'DPOTRS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DPOTRS( 'U', 2, 1, A, 1, B, 2, INFO )
CALL CHKXER( 'DPOTRS', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DPOTRS( 'U', 2, 1, A, 2, B, 1, INFO )
CALL CHKXER( 'DPOTRS', INFOT, NOUT, LERR, OK )
*
* DPORFS
*
SRNAMT = 'DPORFS'
INFOT = 1
CALL DPORFS( '/', 0, 0, A, 1, AF, 1, B, 1, X, 1, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'DPORFS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DPORFS( 'U', -1, 0, A, 1, AF, 1, B, 1, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'DPORFS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DPORFS( 'U', 0, -1, A, 1, AF, 1, B, 1, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'DPORFS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DPORFS( 'U', 2, 1, A, 1, AF, 2, B, 2, X, 2, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'DPORFS', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DPORFS( 'U', 2, 1, A, 2, AF, 1, B, 2, X, 2, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'DPORFS', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DPORFS( 'U', 2, 1, A, 2, AF, 2, B, 1, X, 2, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'DPORFS', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DPORFS( 'U', 2, 1, A, 2, AF, 2, B, 2, X, 1, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'DPORFS', INFOT, NOUT, LERR, OK )
*
* DPOCON
*
SRNAMT = 'DPOCON'
INFOT = 1
CALL DPOCON( '/', 0, A, 1, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'DPOCON', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DPOCON( 'U', -1, A, 1, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'DPOCON', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DPOCON( 'U', 2, A, 1, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'DPOCON', INFOT, NOUT, LERR, OK )
*
* DPOEQU
*
SRNAMT = 'DPOEQU'
INFOT = 1
CALL DPOEQU( -1, A, 1, R1, RCOND, ANRM, INFO )
CALL CHKXER( 'DPOEQU', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DPOEQU( 2, A, 1, R1, RCOND, ANRM, INFO )
CALL CHKXER( 'DPOEQU', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'PP' ) ) THEN
*
* Test error exits of the routines that use the Cholesky
* decomposition of a symmetric positive definite packed matrix.
*
* DPPTRF
*
SRNAMT = 'DPPTRF'
INFOT = 1
CALL DPPTRF( '/', 0, A, INFO )
CALL CHKXER( 'DPPTRF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DPPTRF( 'U', -1, A, INFO )
CALL CHKXER( 'DPPTRF', INFOT, NOUT, LERR, OK )
*
* DPPTRI
*
SRNAMT = 'DPPTRI'
INFOT = 1
CALL DPPTRI( '/', 0, A, INFO )
CALL CHKXER( 'DPPTRI', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DPPTRI( 'U', -1, A, INFO )
CALL CHKXER( 'DPPTRI', INFOT, NOUT, LERR, OK )
*
* DPPTRS
*
SRNAMT = 'DPPTRS'
INFOT = 1
CALL DPPTRS( '/', 0, 0, A, B, 1, INFO )
CALL CHKXER( 'DPPTRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DPPTRS( 'U', -1, 0, A, B, 1, INFO )
CALL CHKXER( 'DPPTRS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DPPTRS( 'U', 0, -1, A, B, 1, INFO )
CALL CHKXER( 'DPPTRS', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DPPTRS( 'U', 2, 1, A, B, 1, INFO )
CALL CHKXER( 'DPPTRS', INFOT, NOUT, LERR, OK )
*
* DPPRFS
*
SRNAMT = 'DPPRFS'
INFOT = 1
CALL DPPRFS( '/', 0, 0, A, AF, B, 1, X, 1, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'DPPRFS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DPPRFS( 'U', -1, 0, A, AF, B, 1, X, 1, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'DPPRFS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DPPRFS( 'U', 0, -1, A, AF, B, 1, X, 1, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'DPPRFS', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DPPRFS( 'U', 2, 1, A, AF, B, 1, X, 2, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'DPPRFS', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DPPRFS( 'U', 2, 1, A, AF, B, 2, X, 1, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'DPPRFS', INFOT, NOUT, LERR, OK )
*
* DPPCON
*
SRNAMT = 'DPPCON'
INFOT = 1
CALL DPPCON( '/', 0, A, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'DPPCON', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DPPCON( 'U', -1, A, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'DPPCON', INFOT, NOUT, LERR, OK )
*
* DPPEQU
*
SRNAMT = 'DPPEQU'
INFOT = 1
CALL DPPEQU( '/', 0, A, R1, RCOND, ANRM, INFO )
CALL CHKXER( 'DPPEQU', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DPPEQU( 'U', -1, A, R1, RCOND, ANRM, INFO )
CALL CHKXER( 'DPPEQU', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN
*
* Test error exits of the routines that use the Cholesky
* decomposition of a symmetric positive definite band matrix.
*
* DPBTRF
*
SRNAMT = 'DPBTRF'
INFOT = 1
CALL DPBTRF( '/', 0, 0, A, 1, INFO )
CALL CHKXER( 'DPBTRF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DPBTRF( 'U', -1, 0, A, 1, INFO )
CALL CHKXER( 'DPBTRF', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DPBTRF( 'U', 1, -1, A, 1, INFO )
CALL CHKXER( 'DPBTRF', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DPBTRF( 'U', 2, 1, A, 1, INFO )
CALL CHKXER( 'DPBTRF', INFOT, NOUT, LERR, OK )
*
* DPBTF2
*
SRNAMT = 'DPBTF2'
INFOT = 1
CALL DPBTF2( '/', 0, 0, A, 1, INFO )
CALL CHKXER( 'DPBTF2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DPBTF2( 'U', -1, 0, A, 1, INFO )
CALL CHKXER( 'DPBTF2', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DPBTF2( 'U', 1, -1, A, 1, INFO )
CALL CHKXER( 'DPBTF2', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DPBTF2( 'U', 2, 1, A, 1, INFO )
CALL CHKXER( 'DPBTF2', INFOT, NOUT, LERR, OK )
*
* DPBTRS
*
SRNAMT = 'DPBTRS'
INFOT = 1
CALL DPBTRS( '/', 0, 0, 0, A, 1, B, 1, INFO )
CALL CHKXER( 'DPBTRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DPBTRS( 'U', -1, 0, 0, A, 1, B, 1, INFO )
CALL CHKXER( 'DPBTRS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DPBTRS( 'U', 1, -1, 0, A, 1, B, 1, INFO )
CALL CHKXER( 'DPBTRS', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DPBTRS( 'U', 0, 0, -1, A, 1, B, 1, INFO )
CALL CHKXER( 'DPBTRS', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DPBTRS( 'U', 2, 1, 1, A, 1, B, 1, INFO )
CALL CHKXER( 'DPBTRS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DPBTRS( 'U', 2, 0, 1, A, 1, B, 1, INFO )
CALL CHKXER( 'DPBTRS', INFOT, NOUT, LERR, OK )
*
* DPBRFS
*
SRNAMT = 'DPBRFS'
INFOT = 1
CALL DPBRFS( '/', 0, 0, 0, A, 1, AF, 1, B, 1, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'DPBRFS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DPBRFS( 'U', -1, 0, 0, A, 1, AF, 1, B, 1, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'DPBRFS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DPBRFS( 'U', 1, -1, 0, A, 1, AF, 1, B, 1, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'DPBRFS', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DPBRFS( 'U', 0, 0, -1, A, 1, AF, 1, B, 1, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'DPBRFS', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DPBRFS( 'U', 2, 1, 1, A, 1, AF, 2, B, 2, X, 2, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'DPBRFS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DPBRFS( 'U', 2, 1, 1, A, 2, AF, 1, B, 2, X, 2, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'DPBRFS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DPBRFS( 'U', 2, 0, 1, A, 1, AF, 1, B, 1, X, 2, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'DPBRFS', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DPBRFS( 'U', 2, 0, 1, A, 1, AF, 1, B, 2, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'DPBRFS', INFOT, NOUT, LERR, OK )
*
* DPBCON
*
SRNAMT = 'DPBCON'
INFOT = 1
CALL DPBCON( '/', 0, 0, A, 1, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'DPBCON', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DPBCON( 'U', -1, 0, A, 1, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'DPBCON', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DPBCON( 'U', 1, -1, A, 1, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'DPBCON', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DPBCON( 'U', 2, 1, A, 1, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'DPBCON', INFOT, NOUT, LERR, OK )
*
* DPBEQU
*
SRNAMT = 'DPBEQU'
INFOT = 1
CALL DPBEQU( '/', 0, 0, A, 1, R1, RCOND, ANRM, INFO )
CALL CHKXER( 'DPBEQU', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DPBEQU( 'U', -1, 0, A, 1, R1, RCOND, ANRM, INFO )
CALL CHKXER( 'DPBEQU', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DPBEQU( 'U', 1, -1, A, 1, R1, RCOND, ANRM, INFO )
CALL CHKXER( 'DPBEQU', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DPBEQU( 'U', 2, 1, A, 1, R1, RCOND, ANRM, INFO )
CALL CHKXER( 'DPBEQU', INFOT, NOUT, LERR, OK )
END IF
*
* Print a summary line.
*
CALL ALAESM( PATH, OK, NOUT )
*
RETURN
*
* End of DERRPO
*
END
SUBROUTINE DERRQL( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* DERRQL tests the error exits for the DOUBLE PRECISION routines
* that use the QL decomposition of a general matrix.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 2 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
* ..
* .. Local Arrays ..
DOUBLE PRECISION A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
$ W( NMAX ), X( NMAX )
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, DGEQL2, DGEQLF, DGEQLS, DORG2L,
$ DORGQL, DORM2L, DORMQL
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
*
* Set the variables to innocuous values.
*
DO 20 J = 1, NMAX
DO 10 I = 1, NMAX
A( I, J ) = 1.D0 / DBLE( I+J )
AF( I, J ) = 1.D0 / DBLE( I+J )
10 CONTINUE
B( J ) = 0.D0
W( J ) = 0.D0
X( J ) = 0.D0
20 CONTINUE
OK = .TRUE.
*
* Error exits for QL factorization
*
* DGEQLF
*
SRNAMT = 'DGEQLF'
INFOT = 1
CALL DGEQLF( -1, 0, A, 1, B, W, 1, INFO )
CALL CHKXER( 'DGEQLF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGEQLF( 0, -1, A, 1, B, W, 1, INFO )
CALL CHKXER( 'DGEQLF', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGEQLF( 2, 1, A, 1, B, W, 1, INFO )
CALL CHKXER( 'DGEQLF', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DGEQLF( 1, 2, A, 1, B, W, 1, INFO )
CALL CHKXER( 'DGEQLF', INFOT, NOUT, LERR, OK )
*
* DGEQL2
*
SRNAMT = 'DGEQL2'
INFOT = 1
CALL DGEQL2( -1, 0, A, 1, B, W, INFO )
CALL CHKXER( 'DGEQL2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGEQL2( 0, -1, A, 1, B, W, INFO )
CALL CHKXER( 'DGEQL2', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGEQL2( 2, 1, A, 1, B, W, INFO )
CALL CHKXER( 'DGEQL2', INFOT, NOUT, LERR, OK )
*
* DGEQLS
*
SRNAMT = 'DGEQLS'
INFOT = 1
CALL DGEQLS( -1, 0, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGEQLS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGEQLS( 0, -1, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGEQLS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGEQLS( 1, 2, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGEQLS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGEQLS( 0, 0, -1, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGEQLS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGEQLS( 2, 1, 0, A, 1, X, B, 2, W, 1, INFO )
CALL CHKXER( 'DGEQLS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DGEQLS( 2, 1, 0, A, 2, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGEQLS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DGEQLS( 1, 1, 2, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGEQLS', INFOT, NOUT, LERR, OK )
*
* DORGQL
*
SRNAMT = 'DORGQL'
INFOT = 1
CALL DORGQL( -1, 0, 0, A, 1, X, W, 1, INFO )
CALL CHKXER( 'DORGQL', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORGQL( 0, -1, 0, A, 1, X, W, 1, INFO )
CALL CHKXER( 'DORGQL', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORGQL( 1, 2, 0, A, 1, X, W, 2, INFO )
CALL CHKXER( 'DORGQL', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORGQL( 0, 0, -1, A, 1, X, W, 1, INFO )
CALL CHKXER( 'DORGQL', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORGQL( 1, 1, 2, A, 1, X, W, 1, INFO )
CALL CHKXER( 'DORGQL', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORGQL( 2, 1, 0, A, 1, X, W, 1, INFO )
CALL CHKXER( 'DORGQL', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DORGQL( 2, 2, 0, A, 2, X, W, 1, INFO )
CALL CHKXER( 'DORGQL', INFOT, NOUT, LERR, OK )
*
* DORG2L
*
SRNAMT = 'DORG2L'
INFOT = 1
CALL DORG2L( -1, 0, 0, A, 1, X, W, INFO )
CALL CHKXER( 'DORG2L', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORG2L( 0, -1, 0, A, 1, X, W, INFO )
CALL CHKXER( 'DORG2L', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORG2L( 1, 2, 0, A, 1, X, W, INFO )
CALL CHKXER( 'DORG2L', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORG2L( 0, 0, -1, A, 1, X, W, INFO )
CALL CHKXER( 'DORG2L', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORG2L( 2, 1, 2, A, 2, X, W, INFO )
CALL CHKXER( 'DORG2L', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORG2L( 2, 1, 0, A, 1, X, W, INFO )
CALL CHKXER( 'DORG2L', INFOT, NOUT, LERR, OK )
*
* DORMQL
*
SRNAMT = 'DORMQL'
INFOT = 1
CALL DORMQL( '/', 'N', 0, 0, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMQL', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORMQL( 'L', '/', 0, 0, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMQL', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORMQL( 'L', 'N', -1, 0, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMQL', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DORMQL( 'L', 'N', 0, -1, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMQL', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORMQL( 'L', 'N', 0, 0, -1, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMQL', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORMQL( 'L', 'N', 0, 1, 1, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMQL', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORMQL( 'R', 'N', 1, 0, 1, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMQL', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DORMQL( 'L', 'N', 2, 1, 0, A, 1, X, AF, 2, W, 1, INFO )
CALL CHKXER( 'DORMQL', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DORMQL( 'R', 'N', 1, 2, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMQL', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DORMQL( 'L', 'N', 2, 1, 0, A, 2, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMQL', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DORMQL( 'L', 'N', 1, 2, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMQL', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DORMQL( 'R', 'N', 2, 1, 0, A, 1, X, AF, 2, W, 1, INFO )
CALL CHKXER( 'DORMQL', INFOT, NOUT, LERR, OK )
*
* DORM2L
*
SRNAMT = 'DORM2L'
INFOT = 1
CALL DORM2L( '/', 'N', 0, 0, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORM2L', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORM2L( 'L', '/', 0, 0, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORM2L', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORM2L( 'L', 'N', -1, 0, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORM2L', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DORM2L( 'L', 'N', 0, -1, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORM2L', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORM2L( 'L', 'N', 0, 0, -1, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORM2L', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORM2L( 'L', 'N', 0, 1, 1, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORM2L', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORM2L( 'R', 'N', 1, 0, 1, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORM2L', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DORM2L( 'L', 'N', 2, 1, 0, A, 1, X, AF, 2, W, INFO )
CALL CHKXER( 'DORM2L', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DORM2L( 'R', 'N', 1, 2, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORM2L', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DORM2L( 'L', 'N', 2, 1, 0, A, 2, X, AF, 1, W, INFO )
CALL CHKXER( 'DORM2L', INFOT, NOUT, LERR, OK )
*
* Print a summary line.
*
CALL ALAESM( PATH, OK, NOUT )
*
RETURN
*
* End of DERRQL
*
END
SUBROUTINE DERRQP( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* DERRQP tests the error exits for DGEQPF and DGEQP3.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 3 )
* ..
* .. Local Scalars ..
CHARACTER*2 C2
INTEGER INFO, LW
* ..
* .. Local Arrays ..
INTEGER IP( NMAX )
DOUBLE PRECISION A( NMAX, NMAX ), TAU( NMAX ), W( 3*NMAX+1 )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, DGEQP3, DGEQPF
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
C2 = PATH( 2: 3 )
LW = 3*NMAX + 1
A( 1, 1 ) = 1.0D+0
A( 1, 2 ) = 2.0D+0
A( 2, 2 ) = 3.0D+0
A( 2, 1 ) = 4.0D+0
OK = .TRUE.
*
IF( LSAMEN( 2, C2, 'QP' ) ) THEN
*
* Test error exits for QR factorization with pivoting
*
* DGEQPF
*
SRNAMT = 'DGEQPF'
INFOT = 1
CALL DGEQPF( -1, 0, A, 1, IP, TAU, W, INFO )
CALL CHKXER( 'DGEQPF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGEQPF( 0, -1, A, 1, IP, TAU, W, INFO )
CALL CHKXER( 'DGEQPF', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGEQPF( 2, 0, A, 1, IP, TAU, W, INFO )
CALL CHKXER( 'DGEQPF', INFOT, NOUT, LERR, OK )
*
* DGEQP3
*
SRNAMT = 'DGEQP3'
INFOT = 1
CALL DGEQP3( -1, 0, A, 1, IP, TAU, W, LW, INFO )
CALL CHKXER( 'DGEQP3', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGEQP3( 1, -1, A, 1, IP, TAU, W, LW, INFO )
CALL CHKXER( 'DGEQP3', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGEQP3( 2, 3, A, 1, IP, TAU, W, LW, INFO )
CALL CHKXER( 'DGEQP3', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DGEQP3( 2, 2, A, 2, IP, TAU, W, LW-10, INFO )
CALL CHKXER( 'DGEQP3', INFOT, NOUT, LERR, OK )
END IF
*
* Print a summary line.
*
CALL ALAESM( PATH, OK, NOUT )
*
RETURN
*
* End of DERRQP
*
END
SUBROUTINE DERRQR( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* DERRQR tests the error exits for the DOUBLE PRECISION routines
* that use the QR decomposition of a general matrix.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 2 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
* ..
* .. Local Arrays ..
DOUBLE PRECISION A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
$ W( NMAX ), X( NMAX )
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, DGEQR2, DGEQRF, DGEQRS, DORG2R,
$ DORGQR, DORM2R, DORMQR
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
*
* Set the variables to innocuous values.
*
DO 20 J = 1, NMAX
DO 10 I = 1, NMAX
A( I, J ) = 1.D0 / DBLE( I+J )
AF( I, J ) = 1.D0 / DBLE( I+J )
10 CONTINUE
B( J ) = 0.D0
W( J ) = 0.D0
X( J ) = 0.D0
20 CONTINUE
OK = .TRUE.
*
* Error exits for QR factorization
*
* DGEQRF
*
SRNAMT = 'DGEQRF'
INFOT = 1
CALL DGEQRF( -1, 0, A, 1, B, W, 1, INFO )
CALL CHKXER( 'DGEQRF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGEQRF( 0, -1, A, 1, B, W, 1, INFO )
CALL CHKXER( 'DGEQRF', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGEQRF( 2, 1, A, 1, B, W, 1, INFO )
CALL CHKXER( 'DGEQRF', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DGEQRF( 1, 2, A, 1, B, W, 1, INFO )
CALL CHKXER( 'DGEQRF', INFOT, NOUT, LERR, OK )
*
* DGEQR2
*
SRNAMT = 'DGEQR2'
INFOT = 1
CALL DGEQR2( -1, 0, A, 1, B, W, INFO )
CALL CHKXER( 'DGEQR2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGEQR2( 0, -1, A, 1, B, W, INFO )
CALL CHKXER( 'DGEQR2', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGEQR2( 2, 1, A, 1, B, W, INFO )
CALL CHKXER( 'DGEQR2', INFOT, NOUT, LERR, OK )
*
* DGEQRS
*
SRNAMT = 'DGEQRS'
INFOT = 1
CALL DGEQRS( -1, 0, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGEQRS( 0, -1, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGEQRS( 1, 2, 0, A, 2, X, B, 2, W, 1, INFO )
CALL CHKXER( 'DGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGEQRS( 0, 0, -1, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGEQRS( 2, 1, 0, A, 1, X, B, 2, W, 1, INFO )
CALL CHKXER( 'DGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DGEQRS( 2, 1, 0, A, 2, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGEQRS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DGEQRS( 1, 1, 2, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGEQRS', INFOT, NOUT, LERR, OK )
*
* DORGQR
*
SRNAMT = 'DORGQR'
INFOT = 1
CALL DORGQR( -1, 0, 0, A, 1, X, W, 1, INFO )
CALL CHKXER( 'DORGQR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORGQR( 0, -1, 0, A, 1, X, W, 1, INFO )
CALL CHKXER( 'DORGQR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORGQR( 1, 2, 0, A, 1, X, W, 2, INFO )
CALL CHKXER( 'DORGQR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORGQR( 0, 0, -1, A, 1, X, W, 1, INFO )
CALL CHKXER( 'DORGQR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORGQR( 1, 1, 2, A, 1, X, W, 1, INFO )
CALL CHKXER( 'DORGQR', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORGQR( 2, 2, 0, A, 1, X, W, 2, INFO )
CALL CHKXER( 'DORGQR', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DORGQR( 2, 2, 0, A, 2, X, W, 1, INFO )
CALL CHKXER( 'DORGQR', INFOT, NOUT, LERR, OK )
*
* DORG2R
*
SRNAMT = 'DORG2R'
INFOT = 1
CALL DORG2R( -1, 0, 0, A, 1, X, W, INFO )
CALL CHKXER( 'DORG2R', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORG2R( 0, -1, 0, A, 1, X, W, INFO )
CALL CHKXER( 'DORG2R', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORG2R( 1, 2, 0, A, 1, X, W, INFO )
CALL CHKXER( 'DORG2R', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORG2R( 0, 0, -1, A, 1, X, W, INFO )
CALL CHKXER( 'DORG2R', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORG2R( 2, 1, 2, A, 2, X, W, INFO )
CALL CHKXER( 'DORG2R', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORG2R( 2, 1, 0, A, 1, X, W, INFO )
CALL CHKXER( 'DORG2R', INFOT, NOUT, LERR, OK )
*
* DORMQR
*
SRNAMT = 'DORMQR'
INFOT = 1
CALL DORMQR( '/', 'N', 0, 0, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMQR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORMQR( 'L', '/', 0, 0, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMQR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORMQR( 'L', 'N', -1, 0, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMQR', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DORMQR( 'L', 'N', 0, -1, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMQR', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORMQR( 'L', 'N', 0, 0, -1, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMQR', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORMQR( 'L', 'N', 0, 1, 1, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMQR', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORMQR( 'R', 'N', 1, 0, 1, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMQR', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DORMQR( 'L', 'N', 2, 1, 0, A, 1, X, AF, 2, W, 1, INFO )
CALL CHKXER( 'DORMQR', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DORMQR( 'R', 'N', 1, 2, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMQR', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DORMQR( 'L', 'N', 2, 1, 0, A, 2, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMQR', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DORMQR( 'L', 'N', 1, 2, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMQR', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DORMQR( 'R', 'N', 2, 1, 0, A, 1, X, AF, 2, W, 1, INFO )
CALL CHKXER( 'DORMQR', INFOT, NOUT, LERR, OK )
*
* DORM2R
*
SRNAMT = 'DORM2R'
INFOT = 1
CALL DORM2R( '/', 'N', 0, 0, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORM2R', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORM2R( 'L', '/', 0, 0, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORM2R', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORM2R( 'L', 'N', -1, 0, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORM2R', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DORM2R( 'L', 'N', 0, -1, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORM2R', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORM2R( 'L', 'N', 0, 0, -1, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORM2R', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORM2R( 'L', 'N', 0, 1, 1, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORM2R', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORM2R( 'R', 'N', 1, 0, 1, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORM2R', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DORM2R( 'L', 'N', 2, 1, 0, A, 1, X, AF, 2, W, INFO )
CALL CHKXER( 'DORM2R', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DORM2R( 'R', 'N', 1, 2, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORM2R', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DORM2R( 'L', 'N', 2, 1, 0, A, 2, X, AF, 1, W, INFO )
CALL CHKXER( 'DORM2R', INFOT, NOUT, LERR, OK )
*
* Print a summary line.
*
CALL ALAESM( PATH, OK, NOUT )
*
RETURN
*
* End of DERRQR
*
END
SUBROUTINE DERRRQ( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* DERRRQ tests the error exits for the DOUBLE PRECISION routines
* that use the RQ decomposition of a general matrix.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 2 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
* ..
* .. Local Arrays ..
DOUBLE PRECISION A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
$ W( NMAX ), X( NMAX )
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, DGERQ2, DGERQF, DGERQS, DORGR2,
$ DORGRQ, DORMR2, DORMRQ
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
*
* Set the variables to innocuous values.
*
DO 20 J = 1, NMAX
DO 10 I = 1, NMAX
A( I, J ) = 1.D0 / DBLE( I+J )
AF( I, J ) = 1.D0 / DBLE( I+J )
10 CONTINUE
B( J ) = 0.D0
W( J ) = 0.D0
X( J ) = 0.D0
20 CONTINUE
OK = .TRUE.
*
* Error exits for RQ factorization
*
* DGERQF
*
SRNAMT = 'DGERQF'
INFOT = 1
CALL DGERQF( -1, 0, A, 1, B, W, 1, INFO )
CALL CHKXER( 'DGERQF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGERQF( 0, -1, A, 1, B, W, 1, INFO )
CALL CHKXER( 'DGERQF', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGERQF( 2, 1, A, 1, B, W, 2, INFO )
CALL CHKXER( 'DGERQF', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DGERQF( 2, 1, A, 2, B, W, 1, INFO )
CALL CHKXER( 'DGERQF', INFOT, NOUT, LERR, OK )
*
* DGERQ2
*
SRNAMT = 'DGERQ2'
INFOT = 1
CALL DGERQ2( -1, 0, A, 1, B, W, INFO )
CALL CHKXER( 'DGERQ2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGERQ2( 0, -1, A, 1, B, W, INFO )
CALL CHKXER( 'DGERQ2', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGERQ2( 2, 1, A, 1, B, W, INFO )
CALL CHKXER( 'DGERQ2', INFOT, NOUT, LERR, OK )
*
* DGERQS
*
SRNAMT = 'DGERQS'
INFOT = 1
CALL DGERQS( -1, 0, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGERQS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGERQS( 0, -1, 0, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGERQS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGERQS( 2, 1, 0, A, 2, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGERQS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGERQS( 0, 0, -1, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGERQS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGERQS( 2, 2, 0, A, 1, X, B, 2, W, 1, INFO )
CALL CHKXER( 'DGERQS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DGERQS( 2, 2, 0, A, 2, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGERQS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DGERQS( 1, 1, 2, A, 1, X, B, 1, W, 1, INFO )
CALL CHKXER( 'DGERQS', INFOT, NOUT, LERR, OK )
*
* DORGRQ
*
SRNAMT = 'DORGRQ'
INFOT = 1
CALL DORGRQ( -1, 0, 0, A, 1, X, W, 1, INFO )
CALL CHKXER( 'DORGRQ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORGRQ( 0, -1, 0, A, 1, X, W, 1, INFO )
CALL CHKXER( 'DORGRQ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORGRQ( 2, 1, 0, A, 2, X, W, 2, INFO )
CALL CHKXER( 'DORGRQ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORGRQ( 0, 0, -1, A, 1, X, W, 1, INFO )
CALL CHKXER( 'DORGRQ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORGRQ( 1, 2, 2, A, 1, X, W, 1, INFO )
CALL CHKXER( 'DORGRQ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORGRQ( 2, 2, 0, A, 1, X, W, 2, INFO )
CALL CHKXER( 'DORGRQ', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DORGRQ( 2, 2, 0, A, 2, X, W, 1, INFO )
CALL CHKXER( 'DORGRQ', INFOT, NOUT, LERR, OK )
*
* DORGR2
*
SRNAMT = 'DORGR2'
INFOT = 1
CALL DORGR2( -1, 0, 0, A, 1, X, W, INFO )
CALL CHKXER( 'DORGR2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORGR2( 0, -1, 0, A, 1, X, W, INFO )
CALL CHKXER( 'DORGR2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORGR2( 2, 1, 0, A, 2, X, W, INFO )
CALL CHKXER( 'DORGR2', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORGR2( 0, 0, -1, A, 1, X, W, INFO )
CALL CHKXER( 'DORGR2', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORGR2( 1, 2, 2, A, 2, X, W, INFO )
CALL CHKXER( 'DORGR2', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORGR2( 2, 2, 0, A, 1, X, W, INFO )
CALL CHKXER( 'DORGR2', INFOT, NOUT, LERR, OK )
*
* DORMRQ
*
SRNAMT = 'DORMRQ'
INFOT = 1
CALL DORMRQ( '/', 'N', 0, 0, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMRQ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORMRQ( 'L', '/', 0, 0, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMRQ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORMRQ( 'L', 'N', -1, 0, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMRQ', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DORMRQ( 'L', 'N', 0, -1, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMRQ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORMRQ( 'L', 'N', 0, 0, -1, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMRQ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORMRQ( 'L', 'N', 0, 1, 1, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMRQ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORMRQ( 'R', 'N', 1, 0, 1, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMRQ', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DORMRQ( 'L', 'N', 2, 1, 2, A, 1, X, AF, 2, W, 1, INFO )
CALL CHKXER( 'DORMRQ', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DORMRQ( 'R', 'N', 1, 2, 2, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMRQ', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DORMRQ( 'L', 'N', 2, 1, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMRQ', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DORMRQ( 'L', 'N', 1, 2, 0, A, 1, X, AF, 1, W, 1, INFO )
CALL CHKXER( 'DORMRQ', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DORMRQ( 'R', 'N', 2, 1, 0, A, 1, X, AF, 2, W, 1, INFO )
CALL CHKXER( 'DORMRQ', INFOT, NOUT, LERR, OK )
*
* DORMR2
*
SRNAMT = 'DORMR2'
INFOT = 1
CALL DORMR2( '/', 'N', 0, 0, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORMR2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORMR2( 'L', '/', 0, 0, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORMR2', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORMR2( 'L', 'N', -1, 0, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORMR2', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DORMR2( 'L', 'N', 0, -1, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORMR2', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORMR2( 'L', 'N', 0, 0, -1, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORMR2', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORMR2( 'L', 'N', 0, 1, 1, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORMR2', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORMR2( 'R', 'N', 1, 0, 1, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORMR2', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DORMR2( 'L', 'N', 2, 1, 2, A, 1, X, AF, 2, W, INFO )
CALL CHKXER( 'DORMR2', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DORMR2( 'R', 'N', 1, 2, 2, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORMR2', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DORMR2( 'L', 'N', 2, 1, 0, A, 1, X, AF, 1, W, INFO )
CALL CHKXER( 'DORMR2', INFOT, NOUT, LERR, OK )
*
* Print a summary line.
*
CALL ALAESM( PATH, OK, NOUT )
*
RETURN
*
* End of DERRRQ
*
END
SUBROUTINE DERRSY( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* DERRSY tests the error exits for the DOUBLE PRECISION routines
* for symmetric indefinite matrices.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 4 )
* ..
* .. Local Scalars ..
CHARACTER*2 C2
INTEGER I, INFO, J
DOUBLE PRECISION ANRM, RCOND
* ..
* .. Local Arrays ..
INTEGER IP( NMAX ), IW( NMAX )
DOUBLE PRECISION A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
$ R1( NMAX ), R2( NMAX ), W( 3*NMAX ), X( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, DSPCON, DSPRFS, DSPTRF, DSPTRI,
$ DSPTRS, DSYCON, DSYRFS, DSYTF2, DSYTRF, DSYTRI,
$ DSYTRS
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
C2 = PATH( 2: 3 )
*
* Set the variables to innocuous values.
*
DO 20 J = 1, NMAX
DO 10 I = 1, NMAX
A( I, J ) = 1.D0 / DBLE( I+J )
AF( I, J ) = 1.D0 / DBLE( I+J )
10 CONTINUE
B( J ) = 0.D0
R1( J ) = 0.D0
R2( J ) = 0.D0
W( J ) = 0.D0
X( J ) = 0.D0
IP( J ) = J
IW( J ) = J
20 CONTINUE
ANRM = 1.0D0
RCOND = 1.0D0
OK = .TRUE.
*
IF( LSAMEN( 2, C2, 'SY' ) ) THEN
*
* Test error exits of the routines that use the Bunch-Kaufman
* factorization of a symmetric indefinite matrix.
*
* DSYTRF
*
SRNAMT = 'DSYTRF'
INFOT = 1
CALL DSYTRF( '/', 0, A, 1, IP, W, 1, INFO )
CALL CHKXER( 'DSYTRF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSYTRF( 'U', -1, A, 1, IP, W, 1, INFO )
CALL CHKXER( 'DSYTRF', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DSYTRF( 'U', 2, A, 1, IP, W, 4, INFO )
CALL CHKXER( 'DSYTRF', INFOT, NOUT, LERR, OK )
*
* DSYTF2
*
SRNAMT = 'DSYTF2'
INFOT = 1
CALL DSYTF2( '/', 0, A, 1, IP, INFO )
CALL CHKXER( 'DSYTF2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSYTF2( 'U', -1, A, 1, IP, INFO )
CALL CHKXER( 'DSYTF2', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DSYTF2( 'U', 2, A, 1, IP, INFO )
CALL CHKXER( 'DSYTF2', INFOT, NOUT, LERR, OK )
*
* DSYTRI
*
SRNAMT = 'DSYTRI'
INFOT = 1
CALL DSYTRI( '/', 0, A, 1, IP, W, INFO )
CALL CHKXER( 'DSYTRI', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSYTRI( 'U', -1, A, 1, IP, W, INFO )
CALL CHKXER( 'DSYTRI', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DSYTRI( 'U', 2, A, 1, IP, W, INFO )
CALL CHKXER( 'DSYTRI', INFOT, NOUT, LERR, OK )
*
* DSYTRS
*
SRNAMT = 'DSYTRS'
INFOT = 1
CALL DSYTRS( '/', 0, 0, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'DSYTRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSYTRS( 'U', -1, 0, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'DSYTRS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSYTRS( 'U', 0, -1, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'DSYTRS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DSYTRS( 'U', 2, 1, A, 1, IP, B, 2, INFO )
CALL CHKXER( 'DSYTRS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DSYTRS( 'U', 2, 1, A, 2, IP, B, 1, INFO )
CALL CHKXER( 'DSYTRS', INFOT, NOUT, LERR, OK )
*
* DSYRFS
*
SRNAMT = 'DSYRFS'
INFOT = 1
CALL DSYRFS( '/', 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'DSYRFS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSYRFS( 'U', -1, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2,
$ W, IW, INFO )
CALL CHKXER( 'DSYRFS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSYRFS( 'U', 0, -1, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2,
$ W, IW, INFO )
CALL CHKXER( 'DSYRFS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DSYRFS( 'U', 2, 1, A, 1, AF, 2, IP, B, 2, X, 2, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'DSYRFS', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DSYRFS( 'U', 2, 1, A, 2, AF, 1, IP, B, 2, X, 2, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'DSYRFS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DSYRFS( 'U', 2, 1, A, 2, AF, 2, IP, B, 1, X, 2, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'DSYRFS', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DSYRFS( 'U', 2, 1, A, 2, AF, 2, IP, B, 2, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'DSYRFS', INFOT, NOUT, LERR, OK )
*
* DSYCON
*
SRNAMT = 'DSYCON'
INFOT = 1
CALL DSYCON( '/', 0, A, 1, IP, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'DSYCON', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSYCON( 'U', -1, A, 1, IP, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'DSYCON', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DSYCON( 'U', 2, A, 1, IP, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'DSYCON', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DSYCON( 'U', 1, A, 1, IP, -1.0D0, RCOND, W, IW, INFO )
CALL CHKXER( 'DSYCON', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
* Test error exits of the routines that use the Bunch-Kaufman
* factorization of a symmetric indefinite packed matrix.
*
* DSPTRF
*
SRNAMT = 'DSPTRF'
INFOT = 1
CALL DSPTRF( '/', 0, A, IP, INFO )
CALL CHKXER( 'DSPTRF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSPTRF( 'U', -1, A, IP, INFO )
CALL CHKXER( 'DSPTRF', INFOT, NOUT, LERR, OK )
*
* DSPTRI
*
SRNAMT = 'DSPTRI'
INFOT = 1
CALL DSPTRI( '/', 0, A, IP, W, INFO )
CALL CHKXER( 'DSPTRI', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSPTRI( 'U', -1, A, IP, W, INFO )
CALL CHKXER( 'DSPTRI', INFOT, NOUT, LERR, OK )
*
* DSPTRS
*
SRNAMT = 'DSPTRS'
INFOT = 1
CALL DSPTRS( '/', 0, 0, A, IP, B, 1, INFO )
CALL CHKXER( 'DSPTRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSPTRS( 'U', -1, 0, A, IP, B, 1, INFO )
CALL CHKXER( 'DSPTRS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSPTRS( 'U', 0, -1, A, IP, B, 1, INFO )
CALL CHKXER( 'DSPTRS', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DSPTRS( 'U', 2, 1, A, IP, B, 1, INFO )
CALL CHKXER( 'DSPTRS', INFOT, NOUT, LERR, OK )
*
* DSPRFS
*
SRNAMT = 'DSPRFS'
INFOT = 1
CALL DSPRFS( '/', 0, 0, A, AF, IP, B, 1, X, 1, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'DSPRFS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSPRFS( 'U', -1, 0, A, AF, IP, B, 1, X, 1, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'DSPRFS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSPRFS( 'U', 0, -1, A, AF, IP, B, 1, X, 1, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'DSPRFS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DSPRFS( 'U', 2, 1, A, AF, IP, B, 1, X, 2, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'DSPRFS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DSPRFS( 'U', 2, 1, A, AF, IP, B, 2, X, 1, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'DSPRFS', INFOT, NOUT, LERR, OK )
*
* DSPCON
*
SRNAMT = 'DSPCON'
INFOT = 1
CALL DSPCON( '/', 0, A, IP, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'DSPCON', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSPCON( 'U', -1, A, IP, ANRM, RCOND, W, IW, INFO )
CALL CHKXER( 'DSPCON', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DSPCON( 'U', 1, A, IP, -1.0D0, RCOND, W, IW, INFO )
CALL CHKXER( 'DSPCON', INFOT, NOUT, LERR, OK )
END IF
*
* Print a summary line.
*
CALL ALAESM( PATH, OK, NOUT )
*
RETURN
*
* End of DERRSY
*
END
SUBROUTINE DERRTR( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* DERRTR tests the error exits for the DOUBLE PRECISION triangular
* routines.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 2 )
* ..
* .. Local Scalars ..
CHARACTER*2 C2
INTEGER INFO
DOUBLE PRECISION RCOND, SCALE
* ..
* .. Local Arrays ..
INTEGER IW( NMAX )
DOUBLE PRECISION A( NMAX, NMAX ), B( NMAX ), R1( NMAX ),
$ R2( NMAX ), W( NMAX ), X( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, DLATBS, DLATPS, DLATRS, DTBCON,
$ DTBRFS, DTBTRS, DTPCON, DTPRFS, DTPTRI, DTPTRS,
$ DTRCON, DTRRFS, DTRTI2, DTRTRI, DTRTRS
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
C2 = PATH( 2: 3 )
A( 1, 1 ) = 1.D0
A( 1, 2 ) = 2.D0
A( 2, 2 ) = 3.D0
A( 2, 1 ) = 4.D0
OK = .TRUE.
*
IF( LSAMEN( 2, C2, 'TR' ) ) THEN
*
* Test error exits for the general triangular routines.
*
* DTRTRI
*
SRNAMT = 'DTRTRI'
INFOT = 1
CALL DTRTRI( '/', 'N', 0, A, 1, INFO )
CALL CHKXER( 'DTRTRI', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTRTRI( 'U', '/', 0, A, 1, INFO )
CALL CHKXER( 'DTRTRI', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DTRTRI( 'U', 'N', -1, A, 1, INFO )
CALL CHKXER( 'DTRTRI', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTRTRI( 'U', 'N', 2, A, 1, INFO )
CALL CHKXER( 'DTRTRI', INFOT, NOUT, LERR, OK )
*
* DTRTI2
*
SRNAMT = 'DTRTI2'
INFOT = 1
CALL DTRTI2( '/', 'N', 0, A, 1, INFO )
CALL CHKXER( 'DTRTI2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTRTI2( 'U', '/', 0, A, 1, INFO )
CALL CHKXER( 'DTRTI2', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DTRTI2( 'U', 'N', -1, A, 1, INFO )
CALL CHKXER( 'DTRTI2', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTRTI2( 'U', 'N', 2, A, 1, INFO )
CALL CHKXER( 'DTRTI2', INFOT, NOUT, LERR, OK )
*
* DTRTRS
*
SRNAMT = 'DTRTRS'
INFOT = 1
CALL DTRTRS( '/', 'N', 'N', 0, 0, A, 1, X, 1, INFO )
CALL CHKXER( 'DTRTRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTRTRS( 'U', '/', 'N', 0, 0, A, 1, X, 1, INFO )
CALL CHKXER( 'DTRTRS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DTRTRS( 'U', 'N', '/', 0, 0, A, 1, X, 1, INFO )
CALL CHKXER( 'DTRTRS', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DTRTRS( 'U', 'N', 'N', -1, 0, A, 1, X, 1, INFO )
CALL CHKXER( 'DTRTRS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTRTRS( 'U', 'N', 'N', 0, -1, A, 1, X, 1, INFO )
CALL CHKXER( 'DTRTRS', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DTRTRS( 'U', 'N', 'N', 2, 1, A, 1, X, 2, INFO )
CALL CHKXER( 'DTRTRS', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DTRTRS( 'U', 'N', 'N', 2, 1, A, 2, X, 1, INFO )
CALL CHKXER( 'DTRTRS', INFOT, NOUT, LERR, OK )
*
* DTRRFS
*
SRNAMT = 'DTRRFS'
INFOT = 1
CALL DTRRFS( '/', 'N', 'N', 0, 0, A, 1, B, 1, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'DTRRFS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTRRFS( 'U', '/', 'N', 0, 0, A, 1, B, 1, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'DTRRFS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DTRRFS( 'U', 'N', '/', 0, 0, A, 1, B, 1, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'DTRRFS', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DTRRFS( 'U', 'N', 'N', -1, 0, A, 1, B, 1, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'DTRRFS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTRRFS( 'U', 'N', 'N', 0, -1, A, 1, B, 1, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'DTRRFS', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DTRRFS( 'U', 'N', 'N', 2, 1, A, 1, B, 2, X, 2, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'DTRRFS', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DTRRFS( 'U', 'N', 'N', 2, 1, A, 2, B, 1, X, 2, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'DTRRFS', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DTRRFS( 'U', 'N', 'N', 2, 1, A, 2, B, 2, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'DTRRFS', INFOT, NOUT, LERR, OK )
*
* DTRCON
*
SRNAMT = 'DTRCON'
INFOT = 1
CALL DTRCON( '/', 'U', 'N', 0, A, 1, RCOND, W, IW, INFO )
CALL CHKXER( 'DTRCON', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTRCON( '1', '/', 'N', 0, A, 1, RCOND, W, IW, INFO )
CALL CHKXER( 'DTRCON', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DTRCON( '1', 'U', '/', 0, A, 1, RCOND, W, IW, INFO )
CALL CHKXER( 'DTRCON', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DTRCON( '1', 'U', 'N', -1, A, 1, RCOND, W, IW, INFO )
CALL CHKXER( 'DTRCON', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DTRCON( '1', 'U', 'N', 2, A, 1, RCOND, W, IW, INFO )
CALL CHKXER( 'DTRCON', INFOT, NOUT, LERR, OK )
*
* DLATRS
*
SRNAMT = 'DLATRS'
INFOT = 1
CALL DLATRS( '/', 'N', 'N', 'N', 0, A, 1, X, SCALE, W, INFO )
CALL CHKXER( 'DLATRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DLATRS( 'U', '/', 'N', 'N', 0, A, 1, X, SCALE, W, INFO )
CALL CHKXER( 'DLATRS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DLATRS( 'U', 'N', '/', 'N', 0, A, 1, X, SCALE, W, INFO )
CALL CHKXER( 'DLATRS', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DLATRS( 'U', 'N', 'N', '/', 0, A, 1, X, SCALE, W, INFO )
CALL CHKXER( 'DLATRS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DLATRS( 'U', 'N', 'N', 'N', -1, A, 1, X, SCALE, W, INFO )
CALL CHKXER( 'DLATRS', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DLATRS( 'U', 'N', 'N', 'N', 2, A, 1, X, SCALE, W, INFO )
CALL CHKXER( 'DLATRS', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'TP' ) ) THEN
*
* Test error exits for the packed triangular routines.
*
* DTPTRI
*
SRNAMT = 'DTPTRI'
INFOT = 1
CALL DTPTRI( '/', 'N', 0, A, INFO )
CALL CHKXER( 'DTPTRI', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTPTRI( 'U', '/', 0, A, INFO )
CALL CHKXER( 'DTPTRI', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DTPTRI( 'U', 'N', -1, A, INFO )
CALL CHKXER( 'DTPTRI', INFOT, NOUT, LERR, OK )
*
* DTPTRS
*
SRNAMT = 'DTPTRS'
INFOT = 1
CALL DTPTRS( '/', 'N', 'N', 0, 0, A, X, 1, INFO )
CALL CHKXER( 'DTPTRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTPTRS( 'U', '/', 'N', 0, 0, A, X, 1, INFO )
CALL CHKXER( 'DTPTRS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DTPTRS( 'U', 'N', '/', 0, 0, A, X, 1, INFO )
CALL CHKXER( 'DTPTRS', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DTPTRS( 'U', 'N', 'N', -1, 0, A, X, 1, INFO )
CALL CHKXER( 'DTPTRS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTPTRS( 'U', 'N', 'N', 0, -1, A, X, 1, INFO )
CALL CHKXER( 'DTPTRS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DTPTRS( 'U', 'N', 'N', 2, 1, A, X, 1, INFO )
CALL CHKXER( 'DTPTRS', INFOT, NOUT, LERR, OK )
*
* DTPRFS
*
SRNAMT = 'DTPRFS'
INFOT = 1
CALL DTPRFS( '/', 'N', 'N', 0, 0, A, B, 1, X, 1, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'DTPRFS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTPRFS( 'U', '/', 'N', 0, 0, A, B, 1, X, 1, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'DTPRFS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DTPRFS( 'U', 'N', '/', 0, 0, A, B, 1, X, 1, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'DTPRFS', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DTPRFS( 'U', 'N', 'N', -1, 0, A, B, 1, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'DTPRFS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTPRFS( 'U', 'N', 'N', 0, -1, A, B, 1, X, 1, R1, R2, W,
$ IW, INFO )
CALL CHKXER( 'DTPRFS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DTPRFS( 'U', 'N', 'N', 2, 1, A, B, 1, X, 2, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'DTPRFS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DTPRFS( 'U', 'N', 'N', 2, 1, A, B, 2, X, 1, R1, R2, W, IW,
$ INFO )
CALL CHKXER( 'DTPRFS', INFOT, NOUT, LERR, OK )
*
* DTPCON
*
SRNAMT = 'DTPCON'
INFOT = 1
CALL DTPCON( '/', 'U', 'N', 0, A, RCOND, W, IW, INFO )
CALL CHKXER( 'DTPCON', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTPCON( '1', '/', 'N', 0, A, RCOND, W, IW, INFO )
CALL CHKXER( 'DTPCON', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DTPCON( '1', 'U', '/', 0, A, RCOND, W, IW, INFO )
CALL CHKXER( 'DTPCON', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DTPCON( '1', 'U', 'N', -1, A, RCOND, W, IW, INFO )
CALL CHKXER( 'DTPCON', INFOT, NOUT, LERR, OK )
*
* DLATPS
*
SRNAMT = 'DLATPS'
INFOT = 1
CALL DLATPS( '/', 'N', 'N', 'N', 0, A, X, SCALE, W, INFO )
CALL CHKXER( 'DLATPS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DLATPS( 'U', '/', 'N', 'N', 0, A, X, SCALE, W, INFO )
CALL CHKXER( 'DLATPS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DLATPS( 'U', 'N', '/', 'N', 0, A, X, SCALE, W, INFO )
CALL CHKXER( 'DLATPS', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DLATPS( 'U', 'N', 'N', '/', 0, A, X, SCALE, W, INFO )
CALL CHKXER( 'DLATPS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DLATPS( 'U', 'N', 'N', 'N', -1, A, X, SCALE, W, INFO )
CALL CHKXER( 'DLATPS', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
*
* Test error exits for the banded triangular routines.
*
* DTBTRS
*
SRNAMT = 'DTBTRS'
INFOT = 1
CALL DTBTRS( '/', 'N', 'N', 0, 0, 0, A, 1, X, 1, INFO )
CALL CHKXER( 'DTBTRS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTBTRS( 'U', '/', 'N', 0, 0, 0, A, 1, X, 1, INFO )
CALL CHKXER( 'DTBTRS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DTBTRS( 'U', 'N', '/', 0, 0, 0, A, 1, X, 1, INFO )
CALL CHKXER( 'DTBTRS', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DTBTRS( 'U', 'N', 'N', -1, 0, 0, A, 1, X, 1, INFO )
CALL CHKXER( 'DTBTRS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTBTRS( 'U', 'N', 'N', 0, -1, 0, A, 1, X, 1, INFO )
CALL CHKXER( 'DTBTRS', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DTBTRS( 'U', 'N', 'N', 0, 0, -1, A, 1, X, 1, INFO )
CALL CHKXER( 'DTBTRS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DTBTRS( 'U', 'N', 'N', 2, 1, 1, A, 1, X, 2, INFO )
CALL CHKXER( 'DTBTRS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DTBTRS( 'U', 'N', 'N', 2, 0, 1, A, 1, X, 1, INFO )
CALL CHKXER( 'DTBTRS', INFOT, NOUT, LERR, OK )
*
* DTBRFS
*
SRNAMT = 'DTBRFS'
INFOT = 1
CALL DTBRFS( '/', 'N', 'N', 0, 0, 0, A, 1, B, 1, X, 1, R1, R2,
$ W, IW, INFO )
CALL CHKXER( 'DTBRFS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTBRFS( 'U', '/', 'N', 0, 0, 0, A, 1, B, 1, X, 1, R1, R2,
$ W, IW, INFO )
CALL CHKXER( 'DTBRFS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DTBRFS( 'U', 'N', '/', 0, 0, 0, A, 1, B, 1, X, 1, R1, R2,
$ W, IW, INFO )
CALL CHKXER( 'DTBRFS', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DTBRFS( 'U', 'N', 'N', -1, 0, 0, A, 1, B, 1, X, 1, R1, R2,
$ W, IW, INFO )
CALL CHKXER( 'DTBRFS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTBRFS( 'U', 'N', 'N', 0, -1, 0, A, 1, B, 1, X, 1, R1, R2,
$ W, IW, INFO )
CALL CHKXER( 'DTBRFS', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DTBRFS( 'U', 'N', 'N', 0, 0, -1, A, 1, B, 1, X, 1, R1, R2,
$ W, IW, INFO )
CALL CHKXER( 'DTBRFS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DTBRFS( 'U', 'N', 'N', 2, 1, 1, A, 1, B, 2, X, 2, R1, R2,
$ W, IW, INFO )
CALL CHKXER( 'DTBRFS', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DTBRFS( 'U', 'N', 'N', 2, 1, 1, A, 2, B, 1, X, 2, R1, R2,
$ W, IW, INFO )
CALL CHKXER( 'DTBRFS', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DTBRFS( 'U', 'N', 'N', 2, 1, 1, A, 2, B, 2, X, 1, R1, R2,
$ W, IW, INFO )
CALL CHKXER( 'DTBRFS', INFOT, NOUT, LERR, OK )
*
* DTBCON
*
SRNAMT = 'DTBCON'
INFOT = 1
CALL DTBCON( '/', 'U', 'N', 0, 0, A, 1, RCOND, W, IW, INFO )
CALL CHKXER( 'DTBCON', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTBCON( '1', '/', 'N', 0, 0, A, 1, RCOND, W, IW, INFO )
CALL CHKXER( 'DTBCON', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DTBCON( '1', 'U', '/', 0, 0, A, 1, RCOND, W, IW, INFO )
CALL CHKXER( 'DTBCON', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DTBCON( '1', 'U', 'N', -1, 0, A, 1, RCOND, W, IW, INFO )
CALL CHKXER( 'DTBCON', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTBCON( '1', 'U', 'N', 0, -1, A, 1, RCOND, W, IW, INFO )
CALL CHKXER( 'DTBCON', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DTBCON( '1', 'U', 'N', 2, 1, A, 1, RCOND, W, IW, INFO )
CALL CHKXER( 'DTBCON', INFOT, NOUT, LERR, OK )
*
* DLATBS
*
SRNAMT = 'DLATBS'
INFOT = 1
CALL DLATBS( '/', 'N', 'N', 'N', 0, 0, A, 1, X, SCALE, W,
$ INFO )
CALL CHKXER( 'DLATBS', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DLATBS( 'U', '/', 'N', 'N', 0, 0, A, 1, X, SCALE, W,
$ INFO )
CALL CHKXER( 'DLATBS', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DLATBS( 'U', 'N', '/', 'N', 0, 0, A, 1, X, SCALE, W,
$ INFO )
CALL CHKXER( 'DLATBS', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DLATBS( 'U', 'N', 'N', '/', 0, 0, A, 1, X, SCALE, W,
$ INFO )
CALL CHKXER( 'DLATBS', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DLATBS( 'U', 'N', 'N', 'N', -1, 0, A, 1, X, SCALE, W,
$ INFO )
CALL CHKXER( 'DLATBS', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DLATBS( 'U', 'N', 'N', 'N', 1, -1, A, 1, X, SCALE, W,
$ INFO )
CALL CHKXER( 'DLATBS', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DLATBS( 'U', 'N', 'N', 'N', 2, 1, A, 1, X, SCALE, W,
$ INFO )
CALL CHKXER( 'DLATBS', INFOT, NOUT, LERR, OK )
END IF
*
* Print a summary line.
*
CALL ALAESM( PATH, OK, NOUT )
*
RETURN
*
* End of DERRTR
*
END
SUBROUTINE DERRTZ( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* DERRTZ tests the error exits for DTZRQF and STZRZF.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 2 )
* ..
* .. Local Scalars ..
CHARACTER*2 C2
INTEGER INFO
* ..
* .. Local Arrays ..
DOUBLE PRECISION A( NMAX, NMAX ), TAU( NMAX ), W( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, DTZRQF, DTZRZF
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
C2 = PATH( 2: 3 )
A( 1, 1 ) = 1.D+0
A( 1, 2 ) = 2.D+0
A( 2, 2 ) = 3.D+0
A( 2, 1 ) = 4.D+0
W( 1 ) = 0.0D+0
W( 2 ) = 0.0D+0
OK = .TRUE.
*
IF( LSAMEN( 2, C2, 'TZ' ) ) THEN
*
* Test error exits for the trapezoidal routines.
*
* DTZRQF
*
SRNAMT = 'DTZRQF'
INFOT = 1
CALL DTZRQF( -1, 0, A, 1, TAU, INFO )
CALL CHKXER( 'DTZRQF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTZRQF( 1, 0, A, 1, TAU, INFO )
CALL CHKXER( 'DTZRQF', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DTZRQF( 2, 2, A, 1, TAU, INFO )
CALL CHKXER( 'DTZRQF', INFOT, NOUT, LERR, OK )
*
* DTZRZF
*
SRNAMT = 'DTZRZF'
INFOT = 1
CALL DTZRZF( -1, 0, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'DTZRZF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTZRZF( 1, 0, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'DTZRZF', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DTZRZF( 2, 2, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'DTZRZF', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DTZRZF( 2, 2, A, 2, TAU, W, 1, INFO )
CALL CHKXER( 'DTZRZF', INFOT, NOUT, LERR, OK )
END IF
*
* Print a summary line.
*
CALL ALAESM( PATH, OK, NOUT )
*
RETURN
*
* End of DERRTZ
*
END
SUBROUTINE DERRVX( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* January 2007
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* DERRVX tests the error exits for the DOUBLE PRECISION driver routines
* for solving linear systems of equations.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 4 )
* ..
* .. Local Scalars ..
CHARACTER EQ
CHARACTER*2 C2
INTEGER I, INFO, J
DOUBLE PRECISION RCOND
* ..
* .. Local Arrays ..
INTEGER IP( NMAX ), IW( NMAX )
DOUBLE PRECISION A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
$ C( NMAX ), R( NMAX ), R1( NMAX ), R2( NMAX ),
$ W( 2*NMAX ), X( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL CHKXER, DGBSV, DGBSVX, DGESV, DGESVX, DGTSV,
$ DGTSVX, DPBSV, DPBSVX, DPOSV, DPOSVX, DPPSV,
$ DPPSVX, DPTSV, DPTSVX, DSPSV, DSPSVX, DSYSV,
$ DSYSVX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
C2 = PATH( 2: 3 )
*
* Set the variables to innocuous values.
*
DO 20 J = 1, NMAX
DO 10 I = 1, NMAX
A( I, J ) = 1.D0 / DBLE( I+J )
AF( I, J ) = 1.D0 / DBLE( I+J )
10 CONTINUE
B( J ) = 0.D0
R1( J ) = 0.D0
R2( J ) = 0.D0
W( J ) = 0.D0
X( J ) = 0.D0
C( J ) = 0.D0
R( J ) = 0.D0
IP( J ) = J
20 CONTINUE
EQ = ' '
OK = .TRUE.
*
IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
* DGESV
*
SRNAMT = 'DGESV '
INFOT = 1
CALL DGESV( -1, 0, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'DGESV ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGESV( 0, -1, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'DGESV ', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGESV( 2, 1, A, 1, IP, B, 2, INFO )
CALL CHKXER( 'DGESV ', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DGESV( 2, 1, A, 2, IP, B, 1, INFO )
CALL CHKXER( 'DGESV ', INFOT, NOUT, LERR, OK )
*
* DGESVX
*
SRNAMT = 'DGESVX'
INFOT = 1
CALL DGESVX( '/', 'N', 0, 0, A, 1, AF, 1, IP, EQ, R, C, B, 1,
$ X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGESVX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGESVX( 'N', '/', 0, 0, A, 1, AF, 1, IP, EQ, R, C, B, 1,
$ X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGESVX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGESVX( 'N', 'N', -1, 0, A, 1, AF, 1, IP, EQ, R, C, B, 1,
$ X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGESVX', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGESVX( 'N', 'N', 0, -1, A, 1, AF, 1, IP, EQ, R, C, B, 1,
$ X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGESVX', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DGESVX( 'N', 'N', 2, 1, A, 1, AF, 2, IP, EQ, R, C, B, 2,
$ X, 2, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGESVX', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DGESVX( 'N', 'N', 2, 1, A, 2, AF, 1, IP, EQ, R, C, B, 2,
$ X, 2, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGESVX', INFOT, NOUT, LERR, OK )
INFOT = 10
EQ = '/'
CALL DGESVX( 'F', 'N', 0, 0, A, 1, AF, 1, IP, EQ, R, C, B, 1,
$ X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGESVX', INFOT, NOUT, LERR, OK )
INFOT = 11
EQ = 'R'
CALL DGESVX( 'F', 'N', 1, 0, A, 1, AF, 1, IP, EQ, R, C, B, 1,
$ X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGESVX', INFOT, NOUT, LERR, OK )
INFOT = 12
EQ = 'C'
CALL DGESVX( 'F', 'N', 1, 0, A, 1, AF, 1, IP, EQ, R, C, B, 1,
$ X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGESVX', INFOT, NOUT, LERR, OK )
INFOT = 14
CALL DGESVX( 'N', 'N', 2, 1, A, 2, AF, 2, IP, EQ, R, C, B, 1,
$ X, 2, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGESVX', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL DGESVX( 'N', 'N', 2, 1, A, 2, AF, 2, IP, EQ, R, C, B, 2,
$ X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGESVX', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
*
* DGBSV
*
SRNAMT = 'DGBSV '
INFOT = 1
CALL DGBSV( -1, 0, 0, 0, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'DGBSV ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGBSV( 1, -1, 0, 0, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'DGBSV ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGBSV( 1, 0, -1, 0, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'DGBSV ', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGBSV( 0, 0, 0, -1, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'DGBSV ', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DGBSV( 1, 1, 1, 0, A, 3, IP, B, 1, INFO )
CALL CHKXER( 'DGBSV ', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DGBSV( 2, 0, 0, 0, A, 1, IP, B, 1, INFO )
CALL CHKXER( 'DGBSV ', INFOT, NOUT, LERR, OK )
*
* DGBSVX
*
SRNAMT = 'DGBSVX'
INFOT = 1
CALL DGBSVX( '/', 'N', 0, 0, 0, 0, A, 1, AF, 1, IP, EQ, R, C,
$ B, 1, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGBSVX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGBSVX( 'N', '/', 0, 0, 0, 0, A, 1, AF, 1, IP, EQ, R, C,
$ B, 1, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGBSVX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGBSVX( 'N', 'N', -1, 0, 0, 0, A, 1, AF, 1, IP, EQ, R, C,
$ B, 1, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGBSVX', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGBSVX( 'N', 'N', 1, -1, 0, 0, A, 1, AF, 1, IP, EQ, R, C,
$ B, 1, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGBSVX', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGBSVX( 'N', 'N', 1, 0, -1, 0, A, 1, AF, 1, IP, EQ, R, C,
$ B, 1, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGBSVX', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DGBSVX( 'N', 'N', 0, 0, 0, -1, A, 1, AF, 1, IP, EQ, R, C,
$ B, 1, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGBSVX', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DGBSVX( 'N', 'N', 1, 1, 1, 0, A, 2, AF, 4, IP, EQ, R, C,
$ B, 1, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGBSVX', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DGBSVX( 'N', 'N', 1, 1, 1, 0, A, 3, AF, 3, IP, EQ, R, C,
$ B, 1, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGBSVX', INFOT, NOUT, LERR, OK )
INFOT = 12
EQ = '/'
CALL DGBSVX( 'F', 'N', 0, 0, 0, 0, A, 1, AF, 1, IP, EQ, R, C,
$ B, 1, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGBSVX', INFOT, NOUT, LERR, OK )
INFOT = 13
EQ = 'R'
CALL DGBSVX( 'F', 'N', 1, 0, 0, 0, A, 1, AF, 1, IP, EQ, R, C,
$ B, 1, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGBSVX', INFOT, NOUT, LERR, OK )
INFOT = 14
EQ = 'C'
CALL DGBSVX( 'F', 'N', 1, 0, 0, 0, A, 1, AF, 1, IP, EQ, R, C,
$ B, 1, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGBSVX', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL DGBSVX( 'N', 'N', 2, 0, 0, 0, A, 1, AF, 1, IP, EQ, R, C,
$ B, 1, X, 2, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGBSVX', INFOT, NOUT, LERR, OK )
INFOT = 18
CALL DGBSVX( 'N', 'N', 2, 0, 0, 0, A, 1, AF, 1, IP, EQ, R, C,
$ B, 2, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGBSVX', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'GT' ) ) THEN
*
* DGTSV
*
SRNAMT = 'DGTSV '
INFOT = 1
CALL DGTSV( -1, 0, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B, 1,
$ INFO )
CALL CHKXER( 'DGTSV ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGTSV( 0, -1, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B, 1,
$ INFO )
CALL CHKXER( 'DGTSV ', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DGTSV( 2, 0, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B, 1, INFO )
CALL CHKXER( 'DGTSV ', INFOT, NOUT, LERR, OK )
*
* DGTSVX
*
SRNAMT = 'DGTSVX'
INFOT = 1
CALL DGTSVX( '/', 'N', 0, 0, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
$ AF( 1, 1 ), AF( 1, 2 ), AF( 1, 3 ), AF( 1, 4 ),
$ IP, B, 1, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGTSVX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGTSVX( 'N', '/', 0, 0, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
$ AF( 1, 1 ), AF( 1, 2 ), AF( 1, 3 ), AF( 1, 4 ),
$ IP, B, 1, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGTSVX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGTSVX( 'N', 'N', -1, 0, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
$ AF( 1, 1 ), AF( 1, 2 ), AF( 1, 3 ), AF( 1, 4 ),
$ IP, B, 1, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGTSVX', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGTSVX( 'N', 'N', 0, -1, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
$ AF( 1, 1 ), AF( 1, 2 ), AF( 1, 3 ), AF( 1, 4 ),
$ IP, B, 1, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGTSVX', INFOT, NOUT, LERR, OK )
INFOT = 14
CALL DGTSVX( 'N', 'N', 2, 0, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
$ AF( 1, 1 ), AF( 1, 2 ), AF( 1, 3 ), AF( 1, 4 ),
$ IP, B, 1, X, 2, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGTSVX', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL DGTSVX( 'N', 'N', 2, 0, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
$ AF( 1, 1 ), AF( 1, 2 ), AF( 1, 3 ), AF( 1, 4 ),
$ IP, B, 2, X, 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DGTSVX', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'PO' ) ) THEN
*
* DPOSV
*
SRNAMT = 'DPOSV '
INFOT = 1
CALL DPOSV( '/', 0, 0, A, 1, B, 1, INFO )
CALL CHKXER( 'DPOSV ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DPOSV( 'U', -1, 0, A, 1, B, 1, INFO )
CALL CHKXER( 'DPOSV ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DPOSV( 'U', 0, -1, A, 1, B, 1, INFO )
CALL CHKXER( 'DPOSV ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DPOSV( 'U', 2, 0, A, 1, B, 2, INFO )
CALL CHKXER( 'DPOSV ', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DPOSV( 'U', 2, 0, A, 2, B, 1, INFO )
CALL CHKXER( 'DPOSV ', INFOT, NOUT, LERR, OK )
*
* DPOSVX
*
SRNAMT = 'DPOSVX'
INFOT = 1
CALL DPOSVX( '/', 'U', 0, 0, A, 1, AF, 1, EQ, C, B, 1, X, 1,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DPOSVX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DPOSVX( 'N', '/', 0, 0, A, 1, AF, 1, EQ, C, B, 1, X, 1,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DPOSVX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DPOSVX( 'N', 'U', -1, 0, A, 1, AF, 1, EQ, C, B, 1, X, 1,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DPOSVX', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DPOSVX( 'N', 'U', 0, -1, A, 1, AF, 1, EQ, C, B, 1, X, 1,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DPOSVX', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DPOSVX( 'N', 'U', 2, 0, A, 1, AF, 2, EQ, C, B, 2, X, 2,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DPOSVX', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DPOSVX( 'N', 'U', 2, 0, A, 2, AF, 1, EQ, C, B, 2, X, 2,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DPOSVX', INFOT, NOUT, LERR, OK )
INFOT = 9
EQ = '/'
CALL DPOSVX( 'F', 'U', 0, 0, A, 1, AF, 1, EQ, C, B, 1, X, 1,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DPOSVX', INFOT, NOUT, LERR, OK )
INFOT = 10
EQ = 'Y'
CALL DPOSVX( 'F', 'U', 1, 0, A, 1, AF, 1, EQ, C, B, 1, X, 1,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DPOSVX', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DPOSVX( 'N', 'U', 2, 0, A, 2, AF, 2, EQ, C, B, 1, X, 2,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DPOSVX', INFOT, NOUT, LERR, OK )
INFOT = 14
CALL DPOSVX( 'N', 'U', 2, 0, A, 2, AF, 2, EQ, C, B, 2, X, 1,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DPOSVX', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'PP' ) ) THEN
*
* DPPSV
*
SRNAMT = 'DPPSV '
INFOT = 1
CALL DPPSV( '/', 0, 0, A, B, 1, INFO )
CALL CHKXER( 'DPPSV ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DPPSV( 'U', -1, 0, A, B, 1, INFO )
CALL CHKXER( 'DPPSV ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DPPSV( 'U', 0, -1, A, B, 1, INFO )
CALL CHKXER( 'DPPSV ', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DPPSV( 'U', 2, 0, A, B, 1, INFO )
CALL CHKXER( 'DPPSV ', INFOT, NOUT, LERR, OK )
*
* DPPSVX
*
SRNAMT = 'DPPSVX'
INFOT = 1
CALL DPPSVX( '/', 'U', 0, 0, A, AF, EQ, C, B, 1, X, 1, RCOND,
$ R1, R2, W, IW, INFO )
CALL CHKXER( 'DPPSVX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DPPSVX( 'N', '/', 0, 0, A, AF, EQ, C, B, 1, X, 1, RCOND,
$ R1, R2, W, IW, INFO )
CALL CHKXER( 'DPPSVX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DPPSVX( 'N', 'U', -1, 0, A, AF, EQ, C, B, 1, X, 1, RCOND,
$ R1, R2, W, IW, INFO )
CALL CHKXER( 'DPPSVX', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DPPSVX( 'N', 'U', 0, -1, A, AF, EQ, C, B, 1, X, 1, RCOND,
$ R1, R2, W, IW, INFO )
CALL CHKXER( 'DPPSVX', INFOT, NOUT, LERR, OK )
INFOT = 7
EQ = '/'
CALL DPPSVX( 'F', 'U', 0, 0, A, AF, EQ, C, B, 1, X, 1, RCOND,
$ R1, R2, W, IW, INFO )
CALL CHKXER( 'DPPSVX', INFOT, NOUT, LERR, OK )
INFOT = 8
EQ = 'Y'
CALL DPPSVX( 'F', 'U', 1, 0, A, AF, EQ, C, B, 1, X, 1, RCOND,
$ R1, R2, W, IW, INFO )
CALL CHKXER( 'DPPSVX', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DPPSVX( 'N', 'U', 2, 0, A, AF, EQ, C, B, 1, X, 2, RCOND,
$ R1, R2, W, IW, INFO )
CALL CHKXER( 'DPPSVX', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DPPSVX( 'N', 'U', 2, 0, A, AF, EQ, C, B, 2, X, 1, RCOND,
$ R1, R2, W, IW, INFO )
CALL CHKXER( 'DPPSVX', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN
*
* DPBSV
*
SRNAMT = 'DPBSV '
INFOT = 1
CALL DPBSV( '/', 0, 0, 0, A, 1, B, 1, INFO )
CALL CHKXER( 'DPBSV ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DPBSV( 'U', -1, 0, 0, A, 1, B, 1, INFO )
CALL CHKXER( 'DPBSV ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DPBSV( 'U', 1, -1, 0, A, 1, B, 1, INFO )
CALL CHKXER( 'DPBSV ', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DPBSV( 'U', 0, 0, -1, A, 1, B, 1, INFO )
CALL CHKXER( 'DPBSV ', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DPBSV( 'U', 1, 1, 0, A, 1, B, 2, INFO )
CALL CHKXER( 'DPBSV ', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DPBSV( 'U', 2, 0, 0, A, 1, B, 1, INFO )
CALL CHKXER( 'DPBSV ', INFOT, NOUT, LERR, OK )
*
* DPBSVX
*
SRNAMT = 'DPBSVX'
INFOT = 1
CALL DPBSVX( '/', 'U', 0, 0, 0, A, 1, AF, 1, EQ, C, B, 1, X, 1,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DPBSVX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DPBSVX( 'N', '/', 0, 0, 0, A, 1, AF, 1, EQ, C, B, 1, X, 1,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DPBSVX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DPBSVX( 'N', 'U', -1, 0, 0, A, 1, AF, 1, EQ, C, B, 1, X,
$ 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DPBSVX', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DPBSVX( 'N', 'U', 1, -1, 0, A, 1, AF, 1, EQ, C, B, 1, X,
$ 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DPBSVX', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DPBSVX( 'N', 'U', 0, 0, -1, A, 1, AF, 1, EQ, C, B, 1, X,
$ 1, RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DPBSVX', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DPBSVX( 'N', 'U', 1, 1, 0, A, 1, AF, 2, EQ, C, B, 2, X, 2,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DPBSVX', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DPBSVX( 'N', 'U', 1, 1, 0, A, 2, AF, 1, EQ, C, B, 2, X, 2,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DPBSVX', INFOT, NOUT, LERR, OK )
INFOT = 10
EQ = '/'
CALL DPBSVX( 'F', 'U', 0, 0, 0, A, 1, AF, 1, EQ, C, B, 1, X, 1,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DPBSVX', INFOT, NOUT, LERR, OK )
INFOT = 11
EQ = 'Y'
CALL DPBSVX( 'F', 'U', 1, 0, 0, A, 1, AF, 1, EQ, C, B, 1, X, 1,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DPBSVX', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL DPBSVX( 'N', 'U', 2, 0, 0, A, 1, AF, 1, EQ, C, B, 1, X, 2,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DPBSVX', INFOT, NOUT, LERR, OK )
INFOT = 15
CALL DPBSVX( 'N', 'U', 2, 0, 0, A, 1, AF, 1, EQ, C, B, 2, X, 1,
$ RCOND, R1, R2, W, IW, INFO )
CALL CHKXER( 'DPBSVX', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'PT' ) ) THEN
*
* DPTSV
*
SRNAMT = 'DPTSV '
INFOT = 1
CALL DPTSV( -1, 0, A( 1, 1 ), A( 1, 2 ), B, 1, INFO )
CALL CHKXER( 'DPTSV ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DPTSV( 0, -1, A( 1, 1 ), A( 1, 2 ), B, 1, INFO )
CALL CHKXER( 'DPTSV ', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DPTSV( 2, 0, A( 1, 1 ), A( 1, 2 ), B, 1, INFO )
CALL CHKXER( 'DPTSV ', INFOT, NOUT, LERR, OK )
*
* DPTSVX
*
SRNAMT = 'DPTSVX'
INFOT = 1
CALL DPTSVX( '/', 0, 0, A( 1, 1 ), A( 1, 2 ), AF( 1, 1 ),
$ AF( 1, 2 ), B, 1, X, 1, RCOND, R1, R2, W, INFO )
CALL CHKXER( 'DPTSVX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DPTSVX( 'N', -1, 0, A( 1, 1 ), A( 1, 2 ), AF( 1, 1 ),
$ AF( 1, 2 ), B, 1, X, 1, RCOND, R1, R2, W, INFO )
CALL CHKXER( 'DPTSVX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DPTSVX( 'N', 0, -1, A( 1, 1 ), A( 1, 2 ), AF( 1, 1 ),
$ AF( 1, 2 ), B, 1, X, 1, RCOND, R1, R2, W, INFO )
CALL CHKXER( 'DPTSVX', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DPTSVX( 'N', 2, 0, A( 1, 1 ), A( 1, 2 ), AF( 1, 1 ),
$ AF( 1, 2 ), B, 1, X, 2, RCOND, R1, R2, W, INFO )
CALL CHKXER( 'DPTSVX', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DPTSVX( 'N', 2, 0, A( 1, 1 ), A( 1, 2 ), AF( 1, 1 ),
$ AF( 1, 2 ), B, 2, X, 1, RCOND, R1, R2, W, INFO )
CALL CHKXER( 'DPTSVX', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SY' ) ) THEN
*
* DSYSV
*
SRNAMT = 'DSYSV '
INFOT = 1
CALL DSYSV( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'DSYSV ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSYSV( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'DSYSV ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSYSV( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'DSYSV ', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DSYSV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'DSYSV ', INFOT, NOUT, LERR, OK )
*
* DSYSVX
*
SRNAMT = 'DSYSVX'
INFOT = 1
CALL DSYSVX( '/', 'U', 0, 0, A, 1, AF, 1, IP, B, 1, X, 1,
$ RCOND, R1, R2, W, 1, IW, INFO )
CALL CHKXER( 'DSYSVX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSYSVX( 'N', '/', 0, 0, A, 1, AF, 1, IP, B, 1, X, 1,
$ RCOND, R1, R2, W, 1, IW, INFO )
CALL CHKXER( 'DSYSVX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSYSVX( 'N', 'U', -1, 0, A, 1, AF, 1, IP, B, 1, X, 1,
$ RCOND, R1, R2, W, 1, IW, INFO )
CALL CHKXER( 'DSYSVX', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DSYSVX( 'N', 'U', 0, -1, A, 1, AF, 1, IP, B, 1, X, 1,
$ RCOND, R1, R2, W, 1, IW, INFO )
CALL CHKXER( 'DSYSVX', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DSYSVX( 'N', 'U', 2, 0, A, 1, AF, 2, IP, B, 2, X, 2,
$ RCOND, R1, R2, W, 4, IW, INFO )
CALL CHKXER( 'DSYSVX', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DSYSVX( 'N', 'U', 2, 0, A, 2, AF, 1, IP, B, 2, X, 2,
$ RCOND, R1, R2, W, 4, IW, INFO )
CALL CHKXER( 'DSYSVX', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DSYSVX( 'N', 'U', 2, 0, A, 2, AF, 2, IP, B, 1, X, 2,
$ RCOND, R1, R2, W, 4, IW, INFO )
CALL CHKXER( 'DSYSVX', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL DSYSVX( 'N', 'U', 2, 0, A, 2, AF, 2, IP, B, 2, X, 1,
$ RCOND, R1, R2, W, 4, IW, INFO )
CALL CHKXER( 'DSYSVX', INFOT, NOUT, LERR, OK )
INFOT = 18
CALL DSYSVX( 'N', 'U', 2, 0, A, 2, AF, 2, IP, B, 2, X, 2,
$ RCOND, R1, R2, W, 3, IW, INFO )
CALL CHKXER( 'DSYSVX', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
* DSPSV
*
SRNAMT = 'DSPSV '
INFOT = 1
CALL DSPSV( '/', 0, 0, A, IP, B, 1, INFO )
CALL CHKXER( 'DSPSV ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSPSV( 'U', -1, 0, A, IP, B, 1, INFO )
CALL CHKXER( 'DSPSV ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSPSV( 'U', 0, -1, A, IP, B, 1, INFO )
CALL CHKXER( 'DSPSV ', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DSPSV( 'U', 2, 0, A, IP, B, 1, INFO )
CALL CHKXER( 'DSPSV ', INFOT, NOUT, LERR, OK )
*
* DSPSVX
*
SRNAMT = 'DSPSVX'
INFOT = 1
CALL DSPSVX( '/', 'U', 0, 0, A, AF, IP, B, 1, X, 1, RCOND, R1,
$ R2, W, IW, INFO )
CALL CHKXER( 'DSPSVX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSPSVX( 'N', '/', 0, 0, A, AF, IP, B, 1, X, 1, RCOND, R1,
$ R2, W, IW, INFO )
CALL CHKXER( 'DSPSVX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSPSVX( 'N', 'U', -1, 0, A, AF, IP, B, 1, X, 1, RCOND, R1,
$ R2, W, IW, INFO )
CALL CHKXER( 'DSPSVX', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DSPSVX( 'N', 'U', 0, -1, A, AF, IP, B, 1, X, 1, RCOND, R1,
$ R2, W, IW, INFO )
CALL CHKXER( 'DSPSVX', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DSPSVX( 'N', 'U', 2, 0, A, AF, IP, B, 1, X, 2, RCOND, R1,
$ R2, W, IW, INFO )
CALL CHKXER( 'DSPSVX', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DSPSVX( 'N', 'U', 2, 0, A, AF, IP, B, 2, X, 1, RCOND, R1,
$ R2, W, IW, INFO )
CALL CHKXER( 'DSPSVX', INFOT, NOUT, LERR, OK )
END IF
*
* Print a summary line.
*
IF( OK ) THEN
WRITE( NOUT, FMT = 9999 )PATH
ELSE
WRITE( NOUT, FMT = 9998 )PATH
END IF
*
9999 FORMAT( 1X, A3, ' drivers passed the tests of the error exits' )
9998 FORMAT( ' *** ', A3, ' drivers failed the tests of the error ',
$ 'exits ***' )
*
RETURN
*
* End of DERRVX
*
END
SUBROUTINE DGBT01( M, N, KL, KU, A, LDA, AFAC, LDAFAC, IPIV, WORK,
$ RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KL, KU, LDA, LDAFAC, M, N
DOUBLE PRECISION RESID
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGBT01 reconstructs a band matrix A from its L*U factorization and
* computes the residual:
* norm(L*U - A) / ( N * norm(A) * EPS ),
* where EPS is the machine epsilon.
*
* The expression L*U - A is computed one column at a time, so A and
* AFAC are not modified.
*
* 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.
*
* KL (input) INTEGER
* The number of subdiagonals within the band of A. KL >= 0.
*
* KU (input) INTEGER
* The number of superdiagonals within the band of A. KU >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* The original matrix A in band storage, stored in rows 1 to
* KL+KU+1.
*
* LDA (input) INTEGER.
* The leading dimension of the array A. LDA >= max(1,KL+KU+1).
*
* AFAC (input) DOUBLE PRECISION array, dimension (LDAFAC,N)
* The factored form of the matrix A. AFAC contains the banded
* factors L and U from the L*U factorization, as computed by
* DGBTRF. U is stored as an upper triangular band matrix with
* KL+KU superdiagonals in rows 1 to KL+KU+1, and the
* multipliers used during the factorization are stored in rows
* KL+KU+2 to 2*KL+KU+1. See DGBTRF for further details.
*
* LDAFAC (input) INTEGER
* The leading dimension of the array AFAC.
* LDAFAC >= max(1,2*KL*KU+1).
*
* IPIV (input) INTEGER array, dimension (min(M,N))
* The pivot indices from DGBTRF.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (2*KL+KU+1)
*
* RESID (output) DOUBLE PRECISION
* norm(L*U - A) / ( N * norm(A) * EPS )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, I1, I2, IL, IP, IW, J, JL, JU, JUA, KD, LENJ
DOUBLE PRECISION ANORM, EPS, T
* ..
* .. External Functions ..
DOUBLE PRECISION DASUM, DLAMCH
EXTERNAL DASUM, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick exit if M = 0 or N = 0.
*
RESID = ZERO
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
* Determine EPS and the norm of A.
*
EPS = DLAMCH( 'Epsilon' )
KD = KU + 1
ANORM = ZERO
DO 10 J = 1, N
I1 = MAX( KD+1-J, 1 )
I2 = MIN( KD+M-J, KL+KD )
IF( I2.GE.I1 )
$ ANORM = MAX( ANORM, DASUM( I2-I1+1, A( I1, J ), 1 ) )
10 CONTINUE
*
* Compute one column at a time of L*U - A.
*
KD = KL + KU + 1
DO 40 J = 1, N
*
* Copy the J-th column of U to WORK.
*
JU = MIN( KL+KU, J-1 )
JL = MIN( KL, M-J )
LENJ = MIN( M, J ) - J + JU + 1
IF( LENJ.GT.0 ) THEN
CALL DCOPY( LENJ, AFAC( KD-JU, J ), 1, WORK, 1 )
DO 20 I = LENJ + 1, JU + JL + 1
WORK( I ) = ZERO
20 CONTINUE
*
* Multiply by the unit lower triangular matrix L. Note that L
* is stored as a product of transformations and permutations.
*
DO 30 I = MIN( M-1, J ), J - JU, -1
IL = MIN( KL, M-I )
IF( IL.GT.0 ) THEN
IW = I - J + JU + 1
T = WORK( IW )
CALL DAXPY( IL, T, AFAC( KD+1, I ), 1, WORK( IW+1 ),
$ 1 )
IP = IPIV( I )
IF( I.NE.IP ) THEN
IP = IP - J + JU + 1
WORK( IW ) = WORK( IP )
WORK( IP ) = T
END IF
END IF
30 CONTINUE
*
* Subtract the corresponding column of A.
*
JUA = MIN( JU, KU )
IF( JUA+JL+1.GT.0 )
$ CALL DAXPY( JUA+JL+1, -ONE, A( KU+1-JUA, J ), 1,
$ WORK( JU+1-JUA ), 1 )
*
* Compute the 1-norm of the column.
*
RESID = MAX( RESID, DASUM( JU+JL+1, WORK, 1 ) )
END IF
40 CONTINUE
*
* Compute norm( L*U - A ) / ( N * norm(A) * EPS )
*
IF( ANORM.LE.ZERO ) THEN
IF( RESID.NE.ZERO )
$ RESID = ONE / EPS
ELSE
RESID = ( ( RESID / DBLE( N ) ) / ANORM ) / EPS
END IF
*
RETURN
*
* End of DGBT01
*
END
SUBROUTINE DGBT02( TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B,
$ LDB, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER KL, KU, LDA, LDB, LDX, M, N, NRHS
DOUBLE PRECISION RESID
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* DGBT02 computes the residual for a solution of a banded system of
* equations A*x = b or A'*x = b:
* RESID = norm( B - A*X ) / ( norm(A) * norm(X) * EPS).
* where EPS is the machine precision.
*
* Arguments
* =========
*
* TRANS (input) CHARACTER*1
* Specifies the form of the system of equations:
* = 'N': A *x = b
* = 'T': A'*x = b, where A' is the transpose of A
* = 'C': A'*x = b, where A' is the transpose of A
*
* 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.
*
* KL (input) INTEGER
* The number of subdiagonals within the band of A. KL >= 0.
*
* KU (input) INTEGER
* The number of superdiagonals within the band of A. KU >= 0.
*
* NRHS (input) INTEGER
* The number of columns of B. NRHS >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The original matrix A in band storage, stored in rows 1 to
* KL+KU+1.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,KL+KU+1).
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The computed solution vectors for the system of linear
* equations.
*
* LDX (input) INTEGER
* The leading dimension of the array X. If TRANS = 'N',
* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the right hand side vectors for the system of
* linear equations.
* On exit, B is overwritten with the difference B - A*X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. IF TRANS = 'N',
* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N).
*
* RESID (output) DOUBLE PRECISION
* The maximum over the number of right hand sides of
* norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I1, I2, J, KD, N1
DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DASUM, DLAMCH
EXTERNAL LSAME, DASUM, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DGBMV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick return if N = 0 pr NRHS = 0
*
IF( M.LE.0 .OR. N.LE.0 .OR. NRHS.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0.
*
EPS = DLAMCH( 'Epsilon' )
KD = KU + 1
ANORM = ZERO
DO 10 J = 1, N
I1 = MAX( KD+1-J, 1 )
I2 = MIN( KD+M-J, KL+KD )
ANORM = MAX( ANORM, DASUM( I2-I1+1, A( I1, J ), 1 ) )
10 CONTINUE
IF( ANORM.LE.ZERO ) THEN
RESID = ONE / EPS
RETURN
END IF
*
IF( LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) ) THEN
N1 = N
ELSE
N1 = M
END IF
*
* Compute B - A*X (or B - A'*X )
*
DO 20 J = 1, NRHS
CALL DGBMV( TRANS, M, N, KL, KU, -ONE, A, LDA, X( 1, J ), 1,
$ ONE, B( 1, J ), 1 )
20 CONTINUE
*
* Compute the maximum over the number of right hand sides of
* norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
*
RESID = ZERO
DO 30 J = 1, NRHS
BNORM = DASUM( N1, B( 1, J ), 1 )
XNORM = DASUM( N1, X( 1, J ), 1 )
IF( XNORM.LE.ZERO ) THEN
RESID = ONE / EPS
ELSE
RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) / EPS )
END IF
30 CONTINUE
*
RETURN
*
* End of DGBT02
*
END
SUBROUTINE DGBT05( TRANS, N, KL, KU, NRHS, AB, LDAB, B, LDB, X,
$ LDX, XACT, LDXACT, FERR, BERR, RESLTS )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER KL, KU, LDAB, LDB, LDX, LDXACT, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ), BERR( * ),
$ FERR( * ), RESLTS( * ), X( LDX, * ),
$ XACT( LDXACT, * )
* ..
*
* Purpose
* =======
*
* DGBT05 tests the error bounds from iterative refinement for the
* computed solution to a system of equations op(A)*X = B, where A is a
* general band matrix of order n with kl subdiagonals and ku
* superdiagonals and op(A) = A or A**T, depending on TRANS.
*
* RESLTS(1) = test of the error bound
* = norm(X - XACT) / ( norm(X) * FERR )
*
* A large value is returned if this ratio is not less than one.
*
* RESLTS(2) = residual from the iterative refinement routine
* = the maximum of BERR / ( NZ*EPS + (*) ), where
* (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i )
* and NZ = max. number of nonzeros in any row of A, plus 1
*
* 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**H * X = B (Conjugate transpose = Transpose)
*
* N (input) INTEGER
* The number of rows of the matrices X, B, and XACT, and the
* order of the matrix A. N >= 0.
*
* KL (input) INTEGER
* The number of subdiagonals within the band of A. KL >= 0.
*
* KU (input) INTEGER
* The number of superdiagonals within the band of A. KU >= 0.
*
* NRHS (input) INTEGER
* The number of columns of the matrices X, B, and XACT.
* NRHS >= 0.
*
* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
* The original band matrix A, stored in rows 1 to KL+KU+1.
* The j-th column of A is stored in the j-th column of the
* array AB as follows:
* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KL+KU+1.
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The computed solution vectors. Each vector is stored as a
* column of the matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* XACT (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The exact solution vectors. Each vector is stored as a
* column of the matrix XACT.
*
* LDXACT (input) INTEGER
* The leading dimension of the array XACT. LDXACT >= max(1,N).
*
* FERR (input) DOUBLE PRECISION array, dimension (NRHS)
* The estimated forward error bounds for each solution vector
* X. If XTRUE is the true solution, FERR bounds the magnitude
* of the largest entry in (X - XTRUE) divided by the magnitude
* of the largest entry in X.
*
* BERR (input) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector (i.e., the smallest relative change in any entry of A
* or B that makes X an exact solution).
*
* RESLTS (output) DOUBLE PRECISION array, dimension (2)
* The maximum over the NRHS solution vectors of the ratios:
* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
* RESLTS(2) = BERR / ( NZ*EPS + (*) )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN
INTEGER I, IMAX, J, K, NZ
DOUBLE PRECISION AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, IDAMAX, DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0.
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESLTS( 1 ) = ZERO
RESLTS( 2 ) = ZERO
RETURN
END IF
*
EPS = DLAMCH( 'Epsilon' )
UNFL = DLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
NOTRAN = LSAME( TRANS, 'N' )
NZ = MIN( KL+KU+2, N+1 )
*
* Test 1: Compute the maximum of
* norm(X - XACT) / ( norm(X) * FERR )
* over all the vectors X and XACT using the infinity-norm.
*
ERRBND = ZERO
DO 30 J = 1, NRHS
IMAX = IDAMAX( N, X( 1, J ), 1 )
XNORM = MAX( ABS( X( IMAX, J ) ), UNFL )
DIFF = ZERO
DO 10 I = 1, N
DIFF = MAX( DIFF, ABS( X( I, J )-XACT( I, J ) ) )
10 CONTINUE
*
IF( XNORM.GT.ONE ) THEN
GO TO 20
ELSE IF( DIFF.LE.OVFL*XNORM ) THEN
GO TO 20
ELSE
ERRBND = ONE / EPS
GO TO 30
END IF
*
20 CONTINUE
IF( DIFF / XNORM.LE.FERR( J ) ) THEN
ERRBND = MAX( ERRBND, ( DIFF / XNORM ) / FERR( J ) )
ELSE
ERRBND = ONE / EPS
END IF
30 CONTINUE
RESLTS( 1 ) = ERRBND
*
* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where
* (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i )
*
DO 70 K = 1, NRHS
DO 60 I = 1, N
TMP = ABS( B( I, K ) )
IF( NOTRAN ) THEN
DO 40 J = MAX( I-KL, 1 ), MIN( I+KU, N )
TMP = TMP + ABS( AB( KU+1+I-J, J ) )*ABS( X( J, K ) )
40 CONTINUE
ELSE
DO 50 J = MAX( I-KU, 1 ), MIN( I+KL, N )
TMP = TMP + ABS( AB( KU+1+J-I, I ) )*ABS( X( J, K ) )
50 CONTINUE
END IF
IF( I.EQ.1 ) THEN
AXBI = TMP
ELSE
AXBI = MIN( AXBI, TMP )
END IF
60 CONTINUE
TMP = BERR( K ) / ( NZ*EPS+NZ*UNFL / MAX( AXBI, NZ*UNFL ) )
IF( K.EQ.1 ) THEN
RESLTS( 2 ) = TMP
ELSE
RESLTS( 2 ) = MAX( RESLTS( 2 ), TMP )
END IF
70 CONTINUE
*
RETURN
*
* End of DGBT05
*
END
SUBROUTINE DGELQS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* Compute a minimum-norm solution
* min || A*X - B ||
* using the LQ factorization
* A = L*Q
* computed by DGELQF.
*
* 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 >= M >= 0.
*
* NRHS (input) INTEGER
* The number of columns of B. NRHS >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* Details of the LQ factorization of the original matrix A as
* returned by DGELQF.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= M.
*
* TAU (input) DOUBLE PRECISION array, dimension (M)
* Details of the orthogonal matrix Q.
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the m-by-nrhs right hand side matrix B.
* On exit, the n-by-nrhs solution matrix X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= N.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of the array WORK. LWORK must be at least NRHS,
* and should be at least NRHS*NB, where NB is the block size
* for this environment.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. External Subroutines ..
EXTERNAL DLASET, DORMLQ, DTRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. M.GT.N ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LWORK.LT.1 .OR. LWORK.LT.NRHS .AND. M.GT.0 .AND. N.GT.0 )
$ THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGELQS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 .OR. M.EQ.0 )
$ RETURN
*
* Solve L*X = B(1:m,:)
*
CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', M, NRHS,
$ ONE, A, LDA, B, LDB )
*
* Set B(m+1:n,:) to zero
*
IF( M.LT.N )
$ CALL DLASET( 'Full', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB )
*
* B := Q' * B
*
CALL DORMLQ( 'Left', 'Transpose', N, NRHS, M, A, LDA, TAU, B, LDB,
$ WORK, LWORK, INFO )
*
RETURN
*
* End of DGELQS
*
END
SUBROUTINE DGEQLS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* Solve the least squares problem
* min || A*X - B ||
* using the QL factorization
* A = Q*L
* computed by DGEQLF.
*
* 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. M >= N >= 0.
*
* NRHS (input) INTEGER
* The number of columns of B. NRHS >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* Details of the QL factorization of the original matrix A as
* returned by DGEQLF.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= M.
*
* TAU (input) DOUBLE PRECISION array, dimension (N)
* Details of the orthogonal matrix Q.
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the m-by-nrhs right hand side matrix B.
* On exit, the n-by-nrhs solution matrix X, stored in rows
* m-n+1:m.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= M.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of the array WORK. LWORK must be at least NRHS,
* and should be at least NRHS*NB, where NB is the block size
* for this environment.
*
* 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 )
* ..
* .. External Subroutines ..
EXTERNAL DORMQL, DTRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
INFO = -8
ELSE IF( LWORK.LT.1 .OR. LWORK.LT.NRHS .AND. M.GT.0 .AND. N.GT.0 )
$ THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGEQLS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 .OR. M.EQ.0 )
$ RETURN
*
* B := Q' * B
*
CALL DORMQL( 'Left', 'Transpose', M, NRHS, N, A, LDA, TAU, B, LDB,
$ WORK, LWORK, INFO )
*
* Solve L*X = B(m-n+1:m,:)
*
CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', N, NRHS,
$ ONE, A( M-N+1, 1 ), LDA, B( M-N+1, 1 ), LDB )
*
RETURN
*
* End of DGEQLS
*
END
SUBROUTINE DGEQRS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* Solve the least squares problem
* min || A*X - B ||
* using the QR factorization
* A = Q*R
* computed by DGEQRF.
*
* 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. M >= N >= 0.
*
* NRHS (input) INTEGER
* The number of columns of B. NRHS >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* Details of the QR factorization of the original matrix A as
* returned by DGEQRF.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= M.
*
* TAU (input) DOUBLE PRECISION array, dimension (N)
* Details of the orthogonal matrix Q.
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the m-by-nrhs right hand side matrix B.
* On exit, the n-by-nrhs solution matrix X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= M.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of the array WORK. LWORK must be at least NRHS,
* and should be at least NRHS*NB, where NB is the block size
* for this environment.
*
* 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 )
* ..
* .. External Subroutines ..
EXTERNAL DORMQR, DTRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
INFO = -8
ELSE IF( LWORK.LT.1 .OR. LWORK.LT.NRHS .AND. M.GT.0 .AND. N.GT.0 )
$ THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGEQRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 .OR. M.EQ.0 )
$ RETURN
*
* B := Q' * B
*
CALL DORMQR( 'Left', 'Transpose', M, NRHS, N, A, LDA, TAU, B, LDB,
$ WORK, LWORK, INFO )
*
* Solve R*X = B(1:n,:)
*
CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, NRHS,
$ ONE, A, LDA, B, LDB )
*
RETURN
*
* End of DGEQRS
*
END
SUBROUTINE DGERQS( M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK,
$ INFO )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* Compute a minimum-norm solution
* min || A*X - B ||
* using the RQ factorization
* A = R*Q
* computed by DGERQF.
*
* 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 >= M >= 0.
*
* NRHS (input) INTEGER
* The number of columns of B. NRHS >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* Details of the RQ factorization of the original matrix A as
* returned by DGERQF.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= M.
*
* TAU (input) DOUBLE PRECISION array, dimension (M)
* Details of the orthogonal matrix Q.
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the right hand side vectors for the linear system.
* On exit, the solution vectors X. Each solution vector
* is contained in rows 1:N of a column of B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of the array WORK. LWORK must be at least NRHS,
* and should be at least NRHS*NB, where NB is the block size
* for this environment.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. External Subroutines ..
EXTERNAL DLASET, DORMRQ, DTRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. M.GT.N ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LWORK.LT.1 .OR. LWORK.LT.NRHS .AND. M.GT.0 .AND. N.GT.0 )
$ THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGERQS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 .OR. M.EQ.0 )
$ RETURN
*
* Solve R*X = B(n-m+1:n,:)
*
CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', M, NRHS,
$ ONE, A( 1, N-M+1 ), LDA, B( N-M+1, 1 ), LDB )
*
* Set B(1:n-m,:) to zero
*
CALL DLASET( 'Full', N-M, NRHS, ZERO, ZERO, B, LDB )
*
* B := Q' * B
*
CALL DORMRQ( 'Left', 'Transpose', N, NRHS, M, A, LDA, TAU, B, LDB,
$ WORK, LWORK, INFO )
*
RETURN
*
* End of DGERQS
*
END
SUBROUTINE DGET01( M, N, A, LDA, AFAC, LDAFAC, IPIV, RWORK,
$ RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDAFAC, M, N
DOUBLE PRECISION RESID
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), RWORK( * )
* ..
*
* Purpose
* =======
*
* DGET01 reconstructs a matrix A from its L*U factorization and
* computes the residual
* norm(L*U - A) / ( N * norm(A) * EPS ),
* where EPS is the machine epsilon.
*
* 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) DOUBLE PRECISION array, dimension (LDA,N)
* The original M x N matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* AFAC (input/output) DOUBLE PRECISION array, dimension (LDAFAC,N)
* The factored form of the matrix A. AFAC contains the factors
* L and U from the L*U factorization as computed by DGETRF.
* Overwritten with the reconstructed matrix, and then with the
* difference L*U - A.
*
* LDAFAC (input) INTEGER
* The leading dimension of the array AFAC. LDAFAC >= max(1,M).
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices from DGETRF.
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (M)
*
* RESID (output) DOUBLE PRECISION
* norm(L*U - A) / ( N * norm(A) * EPS )
*
* =====================================================================
*
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, K
DOUBLE PRECISION ANORM, EPS, T
* ..
* .. External Functions ..
DOUBLE PRECISION DDOT, DLAMCH, DLANGE
EXTERNAL DDOT, DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DGEMV, DLASWP, DSCAL, DTRMV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MIN
* ..
* .. Executable Statements ..
*
* Quick exit if M = 0 or N = 0.
*
IF( M.LE.0 .OR. N.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Determine EPS and the norm of A.
*
EPS = DLAMCH( 'Epsilon' )
ANORM = DLANGE( '1', M, N, A, LDA, RWORK )
*
* Compute the product L*U and overwrite AFAC with the result.
* A column at a time of the product is obtained, starting with
* column N.
*
DO 10 K = N, 1, -1
IF( K.GT.M ) THEN
CALL DTRMV( 'Lower', 'No transpose', 'Unit', M, AFAC,
$ LDAFAC, AFAC( 1, K ), 1 )
ELSE
*
* Compute elements (K+1:M,K)
*
T = AFAC( K, K )
IF( K+1.LE.M ) THEN
CALL DSCAL( M-K, T, AFAC( K+1, K ), 1 )
CALL DGEMV( 'No transpose', M-K, K-1, ONE,
$ AFAC( K+1, 1 ), LDAFAC, AFAC( 1, K ), 1, ONE,
$ AFAC( K+1, K ), 1 )
END IF
*
* Compute the (K,K) element
*
AFAC( K, K ) = T + DDOT( K-1, AFAC( K, 1 ), LDAFAC,
$ AFAC( 1, K ), 1 )
*
* Compute elements (1:K-1,K)
*
CALL DTRMV( 'Lower', 'No transpose', 'Unit', K-1, AFAC,
$ LDAFAC, AFAC( 1, K ), 1 )
END IF
10 CONTINUE
CALL DLASWP( N, AFAC, LDAFAC, 1, MIN( M, N ), IPIV, -1 )
*
* Compute the difference L*U - A and store in AFAC.
*
DO 30 J = 1, N
DO 20 I = 1, M
AFAC( I, J ) = AFAC( I, J ) - A( I, J )
20 CONTINUE
30 CONTINUE
*
* Compute norm( L*U - A ) / ( N * norm(A) * EPS )
*
RESID = DLANGE( '1', M, N, AFAC, LDAFAC, RWORK )
*
IF( ANORM.LE.ZERO ) THEN
IF( RESID.NE.ZERO )
$ RESID = ONE / EPS
ELSE
RESID = ( ( RESID / DBLE( N ) ) / ANORM ) / EPS
END IF
*
RETURN
*
* End of DGET01
*
END
SUBROUTINE DGET02( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB,
$ RWORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER LDA, LDB, LDX, M, N, NRHS
DOUBLE PRECISION RESID
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), RWORK( * ),
$ X( LDX, * )
* ..
*
* Purpose
* =======
*
* DGET02 computes the residual for a solution of a system of linear
* equations A*x = b or A'*x = b:
* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ),
* where EPS is the machine epsilon.
*
* Arguments
* =========
*
* TRANS (input) CHARACTER*1
* Specifies the form of the system of equations:
* = 'N': A *x = b
* = 'T': A'*x = b, where A' is the transpose of A
* = 'C': A'*x = b, where A' is the transpose of A
*
* 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.
*
* NRHS (input) INTEGER
* The number of columns of B, the matrix of right hand sides.
* NRHS >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The original M x N matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The computed solution vectors for the system of linear
* equations.
*
* LDX (input) INTEGER
* The leading dimension of the array X. If TRANS = 'N',
* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the right hand side vectors for the system of
* linear equations.
* On exit, B is overwritten with the difference B - A*X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. IF TRANS = 'N',
* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N).
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (M)
*
* RESID (output) DOUBLE PRECISION
* The maximum over the number of right hand sides of
* norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER J, N1, N2
DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DASUM, DLAMCH, DLANGE
EXTERNAL LSAME, DASUM, DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DGEMM
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Quick exit if M = 0 or N = 0 or NRHS = 0
*
IF( M.LE.0 .OR. N.LE.0 .OR. NRHS.EQ.0 ) THEN
RESID = ZERO
RETURN
END IF
*
IF( LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) ) THEN
N1 = N
N2 = M
ELSE
N1 = M
N2 = N
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0.
*
EPS = DLAMCH( 'Epsilon' )
ANORM = DLANGE( '1', N1, N2, A, LDA, RWORK )
IF( ANORM.LE.ZERO ) THEN
RESID = ONE / EPS
RETURN
END IF
*
* Compute B - A*X (or B - A'*X ) and store in B.
*
CALL DGEMM( TRANS, 'No transpose', N1, NRHS, N2, -ONE, A, LDA, X,
$ LDX, ONE, B, LDB )
*
* Compute the maximum over the number of right hand sides of
* norm(B - A*X) / ( norm(A) * norm(X) * EPS ) .
*
RESID = ZERO
DO 10 J = 1, NRHS
BNORM = DASUM( N1, B( 1, J ), 1 )
XNORM = DASUM( N2, X( 1, J ), 1 )
IF( XNORM.LE.ZERO ) THEN
RESID = ONE / EPS
ELSE
RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) / EPS )
END IF
10 CONTINUE
*
RETURN
*
* End of DGET02
*
END
SUBROUTINE DGET03( N, A, LDA, AINV, LDAINV, WORK, LDWORK, RWORK,
$ RCOND, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDAINV, LDWORK, N
DOUBLE PRECISION RCOND, RESID
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), AINV( LDAINV, * ), RWORK( * ),
$ WORK( LDWORK, * )
* ..
*
* Purpose
* =======
*
* DGET03 computes the residual for a general matrix times its inverse:
* norm( I - AINV*A ) / ( N * norm(A) * norm(AINV) * EPS ),
* where EPS is the machine epsilon.
*
* Arguments
* ==========
*
* N (input) INTEGER
* The number of rows and columns of the matrix A. N >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The original N x N matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* AINV (input) DOUBLE PRECISION array, dimension (LDAINV,N)
* The inverse of the matrix A.
*
* LDAINV (input) INTEGER
* The leading dimension of the array AINV. LDAINV >= max(1,N).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,N)
*
* LDWORK (input) INTEGER
* The leading dimension of the array WORK. LDWORK >= max(1,N).
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* RCOND (output) DOUBLE PRECISION
* The reciprocal of the condition number of A, computed as
* ( 1/norm(A) ) / norm(AINV).
*
* RESID (output) DOUBLE PRECISION
* norm(I - AINV*A) / ( N * norm(A) * norm(AINV) * EPS )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I
DOUBLE PRECISION AINVNM, ANORM, EPS
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DGEMM
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0.
*
IF( N.LE.0 ) THEN
RCOND = ONE
RESID = ZERO
RETURN
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0.
*
EPS = DLAMCH( 'Epsilon' )
ANORM = DLANGE( '1', N, N, A, LDA, RWORK )
AINVNM = DLANGE( '1', N, N, AINV, LDAINV, RWORK )
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCOND = ZERO
RESID = ONE / EPS
RETURN
END IF
RCOND = ( ONE / ANORM ) / AINVNM
*
* Compute I - A * AINV
*
CALL DGEMM( 'No transpose', 'No transpose', N, N, N, -ONE, AINV,
$ LDAINV, A, LDA, ZERO, WORK, LDWORK )
DO 10 I = 1, N
WORK( I, I ) = ONE + WORK( I, I )
10 CONTINUE
*
* Compute norm(I - AINV*A) / (N * norm(A) * norm(AINV) * EPS)
*
RESID = DLANGE( '1', N, N, WORK, LDWORK, RWORK )
*
RESID = ( ( RESID*RCOND ) / EPS ) / DBLE( N )
*
RETURN
*
* End of DGET03
*
END
SUBROUTINE DGET04( N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDX, LDXACT, N, NRHS
DOUBLE PRECISION RCOND, RESID
* ..
* .. Array Arguments ..
DOUBLE PRECISION X( LDX, * ), XACT( LDXACT, * )
* ..
*
* Purpose
* =======
*
* DGET04 computes the difference between a computed solution and the
* true solution to a system of linear equations.
*
* RESID = ( norm(X-XACT) * RCOND ) / ( norm(XACT) * EPS ),
* where RCOND is the reciprocal of the condition number and EPS is the
* machine epsilon.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of rows of the matrices X and XACT. N >= 0.
*
* NRHS (input) INTEGER
* The number of columns of the matrices X and XACT. NRHS >= 0.
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The computed solution vectors. Each vector is stored as a
* column of the matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* XACT (input) DOUBLE PRECISION array, dimension( LDX, NRHS )
* The exact solution vectors. Each vector is stored as a
* column of the matrix XACT.
*
* LDXACT (input) INTEGER
* The leading dimension of the array XACT. LDXACT >= max(1,N).
*
* RCOND (input) DOUBLE PRECISION
* The reciprocal of the condition number of the coefficient
* matrix in the system of equations.
*
* RESID (output) DOUBLE PRECISION
* The maximum over the NRHS solution vectors of
* ( norm(X-XACT) * RCOND ) / ( norm(XACT) * EPS )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, IX, J
DOUBLE PRECISION DIFFNM, EPS, XNORM
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL IDAMAX, DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0.
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Exit with RESID = 1/EPS if RCOND is invalid.
*
EPS = DLAMCH( 'Epsilon' )
IF( RCOND.LT.ZERO ) THEN
RESID = 1.0D0 / EPS
RETURN
END IF
*
* Compute the maximum of
* norm(X - XACT) / ( norm(XACT) * EPS )
* over all the vectors X and XACT .
*
RESID = ZERO
DO 20 J = 1, NRHS
IX = IDAMAX( N, XACT( 1, J ), 1 )
XNORM = ABS( XACT( IX, J ) )
DIFFNM = ZERO
DO 10 I = 1, N
DIFFNM = MAX( DIFFNM, ABS( X( I, J )-XACT( I, J ) ) )
10 CONTINUE
IF( XNORM.LE.ZERO ) THEN
IF( DIFFNM.GT.ZERO )
$ RESID = 1.0D0 / EPS
ELSE
RESID = MAX( RESID, ( DIFFNM / XNORM )*RCOND )
END IF
20 CONTINUE
IF( RESID*EPS.LT.1.0D0 )
$ RESID = RESID / EPS
*
RETURN
*
* End of DGET04
*
END
DOUBLE PRECISION FUNCTION DGET06( RCOND, RCONDC )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
DOUBLE PRECISION RCOND, RCONDC
* ..
*
* Purpose
* =======
*
* DGET06 computes a test ratio to compare two values for RCOND.
*
* Arguments
* ==========
*
* RCOND (input) DOUBLE PRECISION
* The estimate of the reciprocal of the condition number of A,
* as computed by DGECON.
*
* RCONDC (input) DOUBLE PRECISION
* The reciprocal of the condition number of A, computed as
* ( 1/norm(A) ) / norm(inv(A)).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION EPS, RAT
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
EPS = DLAMCH( 'Epsilon' )
IF( RCOND.GT.ZERO ) THEN
IF( RCONDC.GT.ZERO ) THEN
RAT = MAX( RCOND, RCONDC ) / MIN( RCOND, RCONDC ) -
$ ( ONE-EPS )
ELSE
RAT = RCOND / EPS
END IF
ELSE
IF( RCONDC.GT.ZERO ) THEN
RAT = RCONDC / EPS
ELSE
RAT = ZERO
END IF
END IF
DGET06 = RAT
RETURN
*
* End of DGET06
*
END
SUBROUTINE DGET07( TRANS, N, NRHS, A, LDA, B, LDB, X, LDX, XACT,
$ LDXACT, FERR, BERR, RESLTS )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER LDA, LDB, LDX, LDXACT, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ),
$ RESLTS( * ), X( LDX, * ), XACT( LDXACT, * )
* ..
*
* Purpose
* =======
*
* DGET07 tests the error bounds from iterative refinement for the
* computed solution to a system of equations op(A)*X = B, where A is a
* general n by n matrix and op(A) = A or A**T, depending on TRANS.
*
* RESLTS(1) = test of the error bound
* = norm(X - XACT) / ( norm(X) * FERR )
*
* A large value is returned if this ratio is not less than one.
*
* RESLTS(2) = residual from the iterative refinement routine
* = the maximum of BERR / ( (n+1)*EPS + (*) ), where
* (*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i )
*
* 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**H * X = B (Conjugate transpose = Transpose)
*
* N (input) INTEGER
* The number of rows of the matrices X and XACT. N >= 0.
*
* NRHS (input) INTEGER
* The number of columns of the matrices X and XACT. NRHS >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The original n by n matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The computed solution vectors. Each vector is stored as a
* column of the matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* XACT (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The exact solution vectors. Each vector is stored as a
* column of the matrix XACT.
*
* LDXACT (input) INTEGER
* The leading dimension of the array XACT. LDXACT >= max(1,N).
*
* FERR (input) DOUBLE PRECISION array, dimension (NRHS)
* The estimated forward error bounds for each solution vector
* X. If XTRUE is the true solution, FERR bounds the magnitude
* of the largest entry in (X - XTRUE) divided by the magnitude
* of the largest entry in X.
*
* BERR (input) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector (i.e., the smallest relative change in any entry of A
* or B that makes X an exact solution).
*
* RESLTS (output) DOUBLE PRECISION array, dimension (2)
* The maximum over the NRHS solution vectors of the ratios:
* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
* RESLTS(2) = BERR / ( (n+1)*EPS + (*) )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN
INTEGER I, IMAX, J, K
DOUBLE PRECISION AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, IDAMAX, DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0.
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESLTS( 1 ) = ZERO
RESLTS( 2 ) = ZERO
RETURN
END IF
*
EPS = DLAMCH( 'Epsilon' )
UNFL = DLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
NOTRAN = LSAME( TRANS, 'N' )
*
* Test 1: Compute the maximum of
* norm(X - XACT) / ( norm(X) * FERR )
* over all the vectors X and XACT using the infinity-norm.
*
ERRBND = ZERO
DO 30 J = 1, NRHS
IMAX = IDAMAX( N, X( 1, J ), 1 )
XNORM = MAX( ABS( X( IMAX, J ) ), UNFL )
DIFF = ZERO
DO 10 I = 1, N
DIFF = MAX( DIFF, ABS( X( I, J )-XACT( I, J ) ) )
10 CONTINUE
*
IF( XNORM.GT.ONE ) THEN
GO TO 20
ELSE IF( DIFF.LE.OVFL*XNORM ) THEN
GO TO 20
ELSE
ERRBND = ONE / EPS
GO TO 30
END IF
*
20 CONTINUE
IF( DIFF / XNORM.LE.FERR( J ) ) THEN
ERRBND = MAX( ERRBND, ( DIFF / XNORM ) / FERR( J ) )
ELSE
ERRBND = ONE / EPS
END IF
30 CONTINUE
RESLTS( 1 ) = ERRBND
*
* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where
* (*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i )
*
DO 70 K = 1, NRHS
DO 60 I = 1, N
TMP = ABS( B( I, K ) )
IF( NOTRAN ) THEN
DO 40 J = 1, N
TMP = TMP + ABS( A( I, J ) )*ABS( X( J, K ) )
40 CONTINUE
ELSE
DO 50 J = 1, N
TMP = TMP + ABS( A( J, I ) )*ABS( X( J, K ) )
50 CONTINUE
END IF
IF( I.EQ.1 ) THEN
AXBI = TMP
ELSE
AXBI = MIN( AXBI, TMP )
END IF
60 CONTINUE
TMP = BERR( K ) / ( ( N+1 )*EPS+( N+1 )*UNFL /
$ MAX( AXBI, ( N+1 )*UNFL ) )
IF( K.EQ.1 ) THEN
RESLTS( 2 ) = TMP
ELSE
RESLTS( 2 ) = MAX( RESLTS( 2 ), TMP )
END IF
70 CONTINUE
*
RETURN
*
* End of DGET07
*
END
SUBROUTINE DGTT01( N, DL, D, DU, DLF, DF, DUF, DU2, IPIV, WORK,
$ LDWORK, RWORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDWORK, N
DOUBLE PRECISION RESID
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION D( * ), DF( * ), DL( * ), DLF( * ), DU( * ),
$ DU2( * ), DUF( * ), RWORK( * ),
$ WORK( LDWORK, * )
* ..
*
* Purpose
* =======
*
* DGTT01 reconstructs a tridiagonal matrix A from its LU factorization
* and computes the residual
* norm(L*U - A) / ( norm(A) * EPS ),
* where EPS is the machine epsilon.
*
* Arguments
* =========
*
* N (input) INTEGTER
* The order of the matrix A. N >= 0.
*
* DL (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) sub-diagonal elements of A.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The diagonal elements of A.
*
* DU (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) super-diagonal elements of A.
*
* DLF (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) multipliers that define the matrix L from the
* LU factorization of A.
*
* DF (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the upper triangular matrix U from
* the LU factorization of A.
*
* DUF (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) elements of the first super-diagonal of U.
*
* DU2F (input) DOUBLE PRECISION array, dimension (N-2)
* The (n-2) elements of the second super-diagonal of U.
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices; for 1 <= i <= n, row i of the matrix was
* interchanged with row IPIV(i). IPIV(i) will always be either
* i or i+1; IPIV(i) = i indicates a row interchange was not
* required.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,N)
*
* LDWORK (input) INTEGER
* The leading dimension of the array WORK. LDWORK >= max(1,N).
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* RESID (output) DOUBLE PRECISION
* The scaled residual: norm(L*U - A) / (norm(A) * EPS)
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, IP, J, LASTJ
DOUBLE PRECISION ANORM, EPS, LI
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGT, DLANHS
EXTERNAL DLAMCH, DLANGT, DLANHS
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DSWAP
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
EPS = DLAMCH( 'Epsilon' )
*
* Copy the matrix U to WORK.
*
DO 20 J = 1, N
DO 10 I = 1, N
WORK( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
DO 30 I = 1, N
IF( I.EQ.1 ) THEN
WORK( I, I ) = DF( I )
IF( N.GE.2 )
$ WORK( I, I+1 ) = DUF( I )
IF( N.GE.3 )
$ WORK( I, I+2 ) = DU2( I )
ELSE IF( I.EQ.N ) THEN
WORK( I, I ) = DF( I )
ELSE
WORK( I, I ) = DF( I )
WORK( I, I+1 ) = DUF( I )
IF( I.LT.N-1 )
$ WORK( I, I+2 ) = DU2( I )
END IF
30 CONTINUE
*
* Multiply on the left by L.
*
LASTJ = N
DO 40 I = N - 1, 1, -1
LI = DLF( I )
CALL DAXPY( LASTJ-I+1, LI, WORK( I, I ), LDWORK,
$ WORK( I+1, I ), LDWORK )
IP = IPIV( I )
IF( IP.EQ.I ) THEN
LASTJ = MIN( I+2, N )
ELSE
CALL DSWAP( LASTJ-I+1, WORK( I, I ), LDWORK, WORK( I+1, I ),
$ LDWORK )
END IF
40 CONTINUE
*
* Subtract the matrix A.
*
WORK( 1, 1 ) = WORK( 1, 1 ) - D( 1 )
IF( N.GT.1 ) THEN
WORK( 1, 2 ) = WORK( 1, 2 ) - DU( 1 )
WORK( N, N-1 ) = WORK( N, N-1 ) - DL( N-1 )
WORK( N, N ) = WORK( N, N ) - D( N )
DO 50 I = 2, N - 1
WORK( I, I-1 ) = WORK( I, I-1 ) - DL( I-1 )
WORK( I, I ) = WORK( I, I ) - D( I )
WORK( I, I+1 ) = WORK( I, I+1 ) - DU( I )
50 CONTINUE
END IF
*
* Compute the 1-norm of the tridiagonal matrix A.
*
ANORM = DLANGT( '1', N, DL, D, DU )
*
* Compute the 1-norm of WORK, which is only guaranteed to be
* upper Hessenberg.
*
RESID = DLANHS( '1', N, WORK, LDWORK, RWORK )
*
* Compute norm(L*U - A) / (norm(A) * EPS)
*
IF( ANORM.LE.ZERO ) THEN
IF( RESID.NE.ZERO )
$ RESID = ONE / EPS
ELSE
RESID = ( RESID / ANORM ) / EPS
END IF
*
RETURN
*
* End of DGTT01
*
END
SUBROUTINE DGTT02( TRANS, N, NRHS, DL, D, DU, X, LDX, B, LDB,
$ RWORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER LDB, LDX, N, NRHS
DOUBLE PRECISION RESID
* ..
* .. Array Arguments ..
DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ),
$ RWORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* DGTT02 computes the residual for the solution to a tridiagonal
* system of equations:
* RESID = norm(B - op(A)*X) / (norm(A) * norm(X) * EPS),
* where EPS is the machine epsilon.
*
* Arguments
* =========
*
* TRANS (input) CHARACTER
* Specifies the form of the residual.
* = 'N': B - A * X (No transpose)
* = 'T': B - A'* X (Transpose)
* = 'C': B - A'* X (Conjugate transpose = Transpose)
*
* N (input) INTEGTER
* 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 matrices B and X. NRHS >= 0.
*
* DL (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) sub-diagonal elements of A.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The diagonal elements of A.
*
* DU (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) super-diagonal elements of A.
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The computed solution vectors X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the right hand side vectors for the system of
* linear equations.
* On exit, B is overwritten with the difference B - op(A)*X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* RESID (output) DOUBLE PRECISION
* norm(B - op(A)*X) / (norm(A) * norm(X) * EPS)
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER J
DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DASUM, DLAMCH, DLANGT
EXTERNAL LSAME, DASUM, DLAMCH, DLANGT
* ..
* .. External Subroutines ..
EXTERNAL DLAGTM
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0
*
RESID = ZERO
IF( N.LE.0 .OR. NRHS.EQ.0 )
$ RETURN
*
* Compute the maximum over the number of right hand sides of
* norm(B - op(A)*X) / ( norm(A) * norm(X) * EPS ).
*
IF( LSAME( TRANS, 'N' ) ) THEN
ANORM = DLANGT( '1', N, DL, D, DU )
ELSE
ANORM = DLANGT( 'I', N, DL, D, DU )
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0.
*
EPS = DLAMCH( 'Epsilon' )
IF( ANORM.LE.ZERO ) THEN
RESID = ONE / EPS
RETURN
END IF
*
* Compute B - op(A)*X.
*
CALL DLAGTM( TRANS, N, NRHS, -ONE, DL, D, DU, X, LDX, ONE, B,
$ LDB )
*
DO 10 J = 1, NRHS
BNORM = DASUM( N, B( 1, J ), 1 )
XNORM = DASUM( N, X( 1, J ), 1 )
IF( XNORM.LE.ZERO ) THEN
RESID = ONE / EPS
ELSE
RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) / EPS )
END IF
10 CONTINUE
*
RETURN
*
* End of DGTT02
*
END
SUBROUTINE DGTT05( TRANS, N, NRHS, DL, D, DU, B, LDB, X, LDX,
$ XACT, LDXACT, FERR, BERR, RESLTS )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER LDB, LDX, LDXACT, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DL( * ),
$ DU( * ), FERR( * ), RESLTS( * ), X( LDX, * ),
$ XACT( LDXACT, * )
* ..
*
* Purpose
* =======
*
* DGTT05 tests the error bounds from iterative refinement for the
* computed solution to a system of equations A*X = B, where A is a
* general tridiagonal matrix of order n and op(A) = A or A**T,
* depending on TRANS.
*
* RESLTS(1) = test of the error bound
* = norm(X - XACT) / ( norm(X) * FERR )
*
* A large value is returned if this ratio is not less than one.
*
* RESLTS(2) = residual from the iterative refinement routine
* = the maximum of BERR / ( NZ*EPS + (*) ), where
* (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i )
* and NZ = max. number of nonzeros in any row of A, plus 1
*
* 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**H * X = B (Conjugate transpose = Transpose)
*
* N (input) INTEGER
* The number of rows of the matrices X and XACT. N >= 0.
*
* NRHS (input) INTEGER
* The number of columns of the matrices X and XACT. NRHS >= 0.
*
* DL (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) sub-diagonal elements of A.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The diagonal elements of A.
*
* DU (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) super-diagonal elements of A.
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The computed solution vectors. Each vector is stored as a
* column of the matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* XACT (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The exact solution vectors. Each vector is stored as a
* column of the matrix XACT.
*
* LDXACT (input) INTEGER
* The leading dimension of the array XACT. LDXACT >= max(1,N).
*
* FERR (input) DOUBLE PRECISION array, dimension (NRHS)
* The estimated forward error bounds for each solution vector
* X. If XTRUE is the true solution, FERR bounds the magnitude
* of the largest entry in (X - XTRUE) divided by the magnitude
* of the largest entry in X.
*
* BERR (input) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector (i.e., the smallest relative change in any entry of A
* or B that makes X an exact solution).
*
* RESLTS (output) DOUBLE PRECISION array, dimension (2)
* The maximum over the NRHS solution vectors of the ratios:
* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
* RESLTS(2) = BERR / ( NZ*EPS + (*) )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN
INTEGER I, IMAX, J, K, NZ
DOUBLE PRECISION AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, IDAMAX, DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0.
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESLTS( 1 ) = ZERO
RESLTS( 2 ) = ZERO
RETURN
END IF
*
EPS = DLAMCH( 'Epsilon' )
UNFL = DLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
NOTRAN = LSAME( TRANS, 'N' )
NZ = 4
*
* Test 1: Compute the maximum of
* norm(X - XACT) / ( norm(X) * FERR )
* over all the vectors X and XACT using the infinity-norm.
*
ERRBND = ZERO
DO 30 J = 1, NRHS
IMAX = IDAMAX( N, X( 1, J ), 1 )
XNORM = MAX( ABS( X( IMAX, J ) ), UNFL )
DIFF = ZERO
DO 10 I = 1, N
DIFF = MAX( DIFF, ABS( X( I, J )-XACT( I, J ) ) )
10 CONTINUE
*
IF( XNORM.GT.ONE ) THEN
GO TO 20
ELSE IF( DIFF.LE.OVFL*XNORM ) THEN
GO TO 20
ELSE
ERRBND = ONE / EPS
GO TO 30
END IF
*
20 CONTINUE
IF( DIFF / XNORM.LE.FERR( J ) ) THEN
ERRBND = MAX( ERRBND, ( DIFF / XNORM ) / FERR( J ) )
ELSE
ERRBND = ONE / EPS
END IF
30 CONTINUE
RESLTS( 1 ) = ERRBND
*
* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where
* (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i )
*
DO 60 K = 1, NRHS
IF( NOTRAN ) THEN
IF( N.EQ.1 ) THEN
AXBI = ABS( B( 1, K ) ) + ABS( D( 1 )*X( 1, K ) )
ELSE
AXBI = ABS( B( 1, K ) ) + ABS( D( 1 )*X( 1, K ) ) +
$ ABS( DU( 1 )*X( 2, K ) )
DO 40 I = 2, N - 1
TMP = ABS( B( I, K ) ) + ABS( DL( I-1 )*X( I-1, K ) )
$ + ABS( D( I )*X( I, K ) ) +
$ ABS( DU( I )*X( I+1, K ) )
AXBI = MIN( AXBI, TMP )
40 CONTINUE
TMP = ABS( B( N, K ) ) + ABS( DL( N-1 )*X( N-1, K ) ) +
$ ABS( D( N )*X( N, K ) )
AXBI = MIN( AXBI, TMP )
END IF
ELSE
IF( N.EQ.1 ) THEN
AXBI = ABS( B( 1, K ) ) + ABS( D( 1 )*X( 1, K ) )
ELSE
AXBI = ABS( B( 1, K ) ) + ABS( D( 1 )*X( 1, K ) ) +
$ ABS( DL( 1 )*X( 2, K ) )
DO 50 I = 2, N - 1
TMP = ABS( B( I, K ) ) + ABS( DU( I-1 )*X( I-1, K ) )
$ + ABS( D( I )*X( I, K ) ) +
$ ABS( DL( I )*X( I+1, K ) )
AXBI = MIN( AXBI, TMP )
50 CONTINUE
TMP = ABS( B( N, K ) ) + ABS( DU( N-1 )*X( N-1, K ) ) +
$ ABS( D( N )*X( N, K ) )
AXBI = MIN( AXBI, TMP )
END IF
END IF
TMP = BERR( K ) / ( NZ*EPS+NZ*UNFL / MAX( AXBI, NZ*UNFL ) )
IF( K.EQ.1 ) THEN
RESLTS( 2 ) = TMP
ELSE
RESLTS( 2 ) = MAX( RESLTS( 2 ), TMP )
END IF
60 CONTINUE
*
RETURN
*
* End of DGTT05
*
END
SUBROUTINE DLAORD( JOB, N, X, INCX )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOB
INTEGER INCX, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION X( * )
* ..
*
* Purpose
* =======
*
* DLAORD sorts the elements of a vector x in increasing or decreasing
* order.
*
* Arguments
* =========
*
* JOB (input) CHARACTER
* = 'I': Sort in increasing order
* = 'D': Sort in decreasing order
*
* N (input) INTEGER
* The length of the vector X.
*
* X (input/output) DOUBLE PRECISION array, dimension
* (1+(N-1)*INCX)
* On entry, the vector of length n to be sorted.
* On exit, the vector x is sorted in the prescribed order.
*
* INCX (input) INTEGER
* The spacing between successive elements of X. INCX >= 0.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, INC, IX, IXNEXT
DOUBLE PRECISION TEMP
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
INC = ABS( INCX )
IF( LSAME( JOB, 'I' ) ) THEN
*
* Sort in increasing order
*
DO 20 I = 2, N
IX = 1 + ( I-1 )*INC
10 CONTINUE
IF( IX.EQ.1 )
$ GO TO 20
IXNEXT = IX - INC
IF( X( IX ).GT.X( IXNEXT ) ) THEN
GO TO 20
ELSE
TEMP = X( IX )
X( IX ) = X( IXNEXT )
X( IXNEXT ) = TEMP
END IF
IX = IXNEXT
GO TO 10
20 CONTINUE
*
ELSE IF( LSAME( JOB, 'D' ) ) THEN
*
* Sort in decreasing order
*
DO 40 I = 2, N
IX = 1 + ( I-1 )*INC
30 CONTINUE
IF( IX.EQ.1 )
$ GO TO 40
IXNEXT = IX - INC
IF( X( IX ).LT.X( IXNEXT ) ) THEN
GO TO 40
ELSE
TEMP = X( IX )
X( IX ) = X( IXNEXT )
X( IXNEXT ) = TEMP
END IF
IX = IXNEXT
GO TO 30
40 CONTINUE
END IF
RETURN
*
* End of DLAORD
*
END
SUBROUTINE DLAPTM( N, NRHS, ALPHA, D, E, X, LDX, BETA, B, LDB )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDB, LDX, N, NRHS
DOUBLE PRECISION ALPHA, BETA
* ..
* .. Array Arguments ..
DOUBLE PRECISION B( LDB, * ), D( * ), E( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* DLAPTM multiplies an N by NRHS matrix X by a symmetric tridiagonal
* matrix A and stores the result in a matrix B. The operation has the
* form
*
* B := alpha * A * X + beta * B
*
* where alpha may be either 1. or -1. and beta may be 0., 1., or -1.
*
* Arguments
* =========
*
* 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 matrices X and B.
*
* ALPHA (input) DOUBLE PRECISION
* The scalar alpha. ALPHA must be 1. or -1.; otherwise,
* it is assumed to be 0.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the tridiagonal matrix A.
*
* E (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) subdiagonal or superdiagonal elements of A.
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The N by NRHS matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(N,1).
*
* BETA (input) DOUBLE PRECISION
* The scalar beta. BETA must be 0., 1., or -1.; otherwise,
* it is assumed to be 1.
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the N by NRHS matrix B.
* On exit, B is overwritten by the matrix expression
* B := alpha * A * X + beta * B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(N,1).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 )
$ RETURN
*
* Multiply B by BETA if BETA.NE.1.
*
IF( BETA.EQ.ZERO ) THEN
DO 20 J = 1, NRHS
DO 10 I = 1, N
B( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
ELSE IF( BETA.EQ.-ONE ) THEN
DO 40 J = 1, NRHS
DO 30 I = 1, N
B( I, J ) = -B( I, J )
30 CONTINUE
40 CONTINUE
END IF
*
IF( ALPHA.EQ.ONE ) THEN
*
* Compute B := B + A*X
*
DO 60 J = 1, NRHS
IF( N.EQ.1 ) THEN
B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J )
ELSE
B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) +
$ E( 1 )*X( 2, J )
B( N, J ) = B( N, J ) + E( N-1 )*X( N-1, J ) +
$ D( N )*X( N, J )
DO 50 I = 2, N - 1
B( I, J ) = B( I, J ) + E( I-1 )*X( I-1, J ) +
$ D( I )*X( I, J ) + E( I )*X( I+1, J )
50 CONTINUE
END IF
60 CONTINUE
ELSE IF( ALPHA.EQ.-ONE ) THEN
*
* Compute B := B - A*X
*
DO 80 J = 1, NRHS
IF( N.EQ.1 ) THEN
B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J )
ELSE
B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) -
$ E( 1 )*X( 2, J )
B( N, J ) = B( N, J ) - E( N-1 )*X( N-1, J ) -
$ D( N )*X( N, J )
DO 70 I = 2, N - 1
B( I, J ) = B( I, J ) - E( I-1 )*X( I-1, J ) -
$ D( I )*X( I, J ) - E( I )*X( I+1, J )
70 CONTINUE
END IF
80 CONTINUE
END IF
RETURN
*
* End of DLAPTM
*
END
SUBROUTINE DLARHS( PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS,
$ A, LDA, X, LDX, B, LDB, ISEED, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS, UPLO, XTYPE
CHARACTER*3 PATH
INTEGER INFO, KL, KU, LDA, LDB, LDX, M, N, NRHS
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* DLARHS chooses a set of NRHS random solution vectors and sets
* up the right hand sides for the linear system
* op( A ) * X = B,
* where op( A ) may be A or A' (transpose of A).
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The type of the real matrix A. PATH may be given in any
* combination of upper and lower case. Valid types include
* xGE: General m x n matrix
* xGB: General banded matrix
* xPO: Symmetric positive definite, 2-D storage
* xPP: Symmetric positive definite packed
* xPB: Symmetric positive definite banded
* xSY: Symmetric indefinite, 2-D storage
* xSP: Symmetric indefinite packed
* xSB: Symmetric indefinite banded
* xTR: Triangular
* xTP: Triangular packed
* xTB: Triangular banded
* xQR: General m x n matrix
* xLQ: General m x n matrix
* xQL: General m x n matrix
* xRQ: General m x n matrix
* where the leading character indicates the precision.
*
* XTYPE (input) CHARACTER*1
* Specifies how the exact solution X will be determined:
* = 'N': New solution; generate a random X.
* = 'C': Computed; use value of X on entry.
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* matrix A is stored, if A is symmetric.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the operation applied to the matrix A.
* = 'N': System is A * x = b
* = 'T': System is A'* x = b
* = 'C': System is A'* x = b
*
* M (input) INTEGER
* The number or rows of the matrix A. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix A. N >= 0.
*
* KL (input) INTEGER
* Used only if A is a band matrix; specifies the number of
* subdiagonals of A if A is a general band matrix or if A is
* symmetric or triangular and UPLO = 'L'; specifies the number
* of superdiagonals of A if A is symmetric or triangular and
* UPLO = 'U'. 0 <= KL <= M-1.
*
* KU (input) INTEGER
* Used only if A is a general band matrix or if A is
* triangular.
*
* If PATH = xGB, specifies the number of superdiagonals of A,
* and 0 <= KU <= N-1.
*
* If PATH = xTR, xTP, or xTB, specifies whether or not the
* matrix has unit diagonal:
* = 1: matrix has non-unit diagonal (default)
* = 2: matrix has unit diagonal
*
* NRHS (input) INTEGER
* The number of right hand side vectors in the system A*X = B.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The test matrix whose type is given by PATH.
*
* LDA (input) INTEGER
* The leading dimension of the array A.
* If PATH = xGB, LDA >= KL+KU+1.
* If PATH = xPB, xSB, xHB, or xTB, LDA >= KL+1.
* Otherwise, LDA >= max(1,M).
*
* X (input or output) DOUBLE PRECISION array, dimension(LDX,NRHS)
* On entry, if XTYPE = 'C' (for 'Computed'), then X contains
* the exact solution to the system of linear equations.
* On exit, if XTYPE = 'N' (for 'New'), then X is initialized
* with random values.
*
* LDX (input) INTEGER
* The leading dimension of the array X. If TRANS = 'N',
* LDX >= max(1,N); if TRANS = 'T', LDX >= max(1,M).
*
* B (output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The right hand side vector(s) for the system of equations,
* computed from B = op(A) * X, where op(A) is determined by
* TRANS.
*
* LDB (input) INTEGER
* The leading dimension of the array B. If TRANS = 'N',
* LDB >= max(1,M); if TRANS = 'T', LDB >= max(1,N).
*
* ISEED (input/output) INTEGER array, dimension (4)
* The seed vector for the random number generator (used in
* DLATMS). Modified on exit.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL BAND, GEN, NOTRAN, QRS, SYM, TRAN, TRI
CHARACTER C1, DIAG
CHARACTER*2 C2
INTEGER J, MB, NX
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL DGBMV, DGEMM, DLACPY, DLARNV, DSBMV, DSPMV,
$ DSYMM, DTBMV, DTPMV, DTRMM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
C1 = PATH( 1: 1 )
C2 = PATH( 2: 3 )
TRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
NOTRAN = .NOT.TRAN
GEN = LSAME( PATH( 2: 2 ), 'G' )
QRS = LSAME( PATH( 2: 2 ), 'Q' ) .OR. LSAME( PATH( 3: 3 ), 'Q' )
SYM = LSAME( PATH( 2: 2 ), 'P' ) .OR. LSAME( PATH( 2: 2 ), 'S' )
TRI = LSAME( PATH( 2: 2 ), 'T' )
BAND = LSAME( PATH( 3: 3 ), 'B' )
IF( .NOT.LSAME( C1, 'Double precision' ) ) THEN
INFO = -1
ELSE IF( .NOT.( LSAME( XTYPE, 'N' ) .OR. LSAME( XTYPE, 'C' ) ) )
$ THEN
INFO = -2
ELSE IF( ( SYM .OR. TRI ) .AND. .NOT.
$ ( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) THEN
INFO = -3
ELSE IF( ( GEN .OR. QRS ) .AND. .NOT.
$ ( TRAN .OR. LSAME( TRANS, 'N' ) ) ) THEN
INFO = -4
ELSE IF( M.LT.0 ) THEN
INFO = -5
ELSE IF( N.LT.0 ) THEN
INFO = -6
ELSE IF( BAND .AND. KL.LT.0 ) THEN
INFO = -7
ELSE IF( BAND .AND. KU.LT.0 ) THEN
INFO = -8
ELSE IF( NRHS.LT.0 ) THEN
INFO = -9
ELSE IF( ( .NOT.BAND .AND. LDA.LT.MAX( 1, M ) ) .OR.
$ ( BAND .AND. ( SYM .OR. TRI ) .AND. LDA.LT.KL+1 ) .OR.
$ ( BAND .AND. GEN .AND. LDA.LT.KL+KU+1 ) ) THEN
INFO = -11
ELSE IF( ( NOTRAN .AND. LDX.LT.MAX( 1, N ) ) .OR.
$ ( TRAN .AND. LDX.LT.MAX( 1, M ) ) ) THEN
INFO = -13
ELSE IF( ( NOTRAN .AND. LDB.LT.MAX( 1, M ) ) .OR.
$ ( TRAN .AND. LDB.LT.MAX( 1, N ) ) ) THEN
INFO = -15
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLARHS', -INFO )
RETURN
END IF
*
* Initialize X to NRHS random vectors unless XTYPE = 'C'.
*
IF( TRAN ) THEN
NX = M
MB = N
ELSE
NX = N
MB = M
END IF
IF( .NOT.LSAME( XTYPE, 'C' ) ) THEN
DO 10 J = 1, NRHS
CALL DLARNV( 2, ISEED, N, X( 1, J ) )
10 CONTINUE
END IF
*
* Multiply X by op( A ) using an appropriate
* matrix multiply routine.
*
IF( LSAMEN( 2, C2, 'GE' ) .OR. LSAMEN( 2, C2, 'QR' ) .OR.
$ LSAMEN( 2, C2, 'LQ' ) .OR. LSAMEN( 2, C2, 'QL' ) .OR.
$ LSAMEN( 2, C2, 'RQ' ) ) THEN
*
* General matrix
*
CALL DGEMM( TRANS, 'N', MB, NRHS, NX, ONE, A, LDA, X, LDX,
$ ZERO, B, LDB )
*
ELSE IF( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'SY' ) ) THEN
*
* Symmetric matrix, 2-D storage
*
CALL DSYMM( 'Left', UPLO, N, NRHS, ONE, A, LDA, X, LDX, ZERO,
$ B, LDB )
*
ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
*
* General matrix, band storage
*
DO 20 J = 1, NRHS
CALL DGBMV( TRANS, MB, NX, KL, KU, ONE, A, LDA, X( 1, J ),
$ 1, ZERO, B( 1, J ), 1 )
20 CONTINUE
*
ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN
*
* Symmetric matrix, band storage
*
DO 30 J = 1, NRHS
CALL DSBMV( UPLO, N, KL, ONE, A, LDA, X( 1, J ), 1, ZERO,
$ B( 1, J ), 1 )
30 CONTINUE
*
ELSE IF( LSAMEN( 2, C2, 'PP' ) .OR. LSAMEN( 2, C2, 'SP' ) ) THEN
*
* Symmetric matrix, packed storage
*
DO 40 J = 1, NRHS
CALL DSPMV( UPLO, N, ONE, A, X( 1, J ), 1, ZERO, B( 1, J ),
$ 1 )
40 CONTINUE
*
ELSE IF( LSAMEN( 2, C2, 'TR' ) ) THEN
*
* Triangular matrix. Note that for triangular matrices,
* KU = 1 => non-unit triangular
* KU = 2 => unit triangular
*
CALL DLACPY( 'Full', N, NRHS, X, LDX, B, LDB )
IF( KU.EQ.2 ) THEN
DIAG = 'U'
ELSE
DIAG = 'N'
END IF
CALL DTRMM( 'Left', UPLO, TRANS, DIAG, N, NRHS, ONE, A, LDA, B,
$ LDB )
*
ELSE IF( LSAMEN( 2, C2, 'TP' ) ) THEN
*
* Triangular matrix, packed storage
*
CALL DLACPY( 'Full', N, NRHS, X, LDX, B, LDB )
IF( KU.EQ.2 ) THEN
DIAG = 'U'
ELSE
DIAG = 'N'
END IF
DO 50 J = 1, NRHS
CALL DTPMV( UPLO, TRANS, DIAG, N, A, B( 1, J ), 1 )
50 CONTINUE
*
ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
*
* Triangular matrix, banded storage
*
CALL DLACPY( 'Full', N, NRHS, X, LDX, B, LDB )
IF( KU.EQ.2 ) THEN
DIAG = 'U'
ELSE
DIAG = 'N'
END IF
DO 60 J = 1, NRHS
CALL DTBMV( UPLO, TRANS, DIAG, N, KL, A, LDA, B( 1, J ), 1 )
60 CONTINUE
*
ELSE
*
* If PATH is none of the above, return with an error code.
*
INFO = -1
CALL XERBLA( 'DLARHS', -INFO )
END IF
*
RETURN
*
* End of DLARHS
*
END
SUBROUTINE DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIST, TYPE
CHARACTER*3 PATH
INTEGER IMAT, KL, KU, M, MODE, N
DOUBLE PRECISION ANORM, CNDNUM
* ..
*
* Purpose
* =======
*
* DLATB4 sets parameters for the matrix generator based on the type of
* matrix to be generated.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name.
*
* IMAT (input) INTEGER
* An integer key describing which matrix to generate for this
* path.
*
* M (input) INTEGER
* The number of rows in the matrix to be generated.
*
* N (input) INTEGER
* The number of columns in the matrix to be generated.
*
* TYPE (output) CHARACTER*1
* The type of the matrix to be generated:
* = 'S': symmetric matrix
* = 'P': symmetric positive (semi)definite matrix
* = 'N': nonsymmetric matrix
*
* KL (output) INTEGER
* The lower band width of the matrix to be generated.
*
* KU (output) INTEGER
* The upper band width of the matrix to be generated.
*
* ANORM (output) DOUBLE PRECISION
* The desired norm of the matrix to be generated. The diagonal
* matrix of singular values or eigenvalues is scaled by this
* value.
*
* MODE (output) INTEGER
* A key indicating how to choose the vector of eigenvalues.
*
* CNDNUM (output) DOUBLE PRECISION
* The desired condition number.
*
* DIST (output) CHARACTER*1
* The type of distribution to be used by the random number
* generator.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION SHRINK, TENTH
PARAMETER ( SHRINK = 0.25D0, TENTH = 0.1D+0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL FIRST
CHARACTER*2 C2
INTEGER MAT
DOUBLE PRECISION BADC1, BADC2, EPS, LARGE, SMALL
* ..
* .. External Functions ..
LOGICAL LSAMEN
DOUBLE PRECISION DLAMCH
EXTERNAL LSAMEN, DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. External Subroutines ..
EXTERNAL DLABAD
* ..
* .. Save statement ..
SAVE EPS, SMALL, LARGE, BADC1, BADC2, FIRST
* ..
* .. Data statements ..
DATA FIRST / .TRUE. /
* ..
* .. Executable Statements ..
*
* Set some constants for use in the subroutine.
*
IF( FIRST ) THEN
FIRST = .FALSE.
EPS = DLAMCH( 'Precision' )
BADC2 = TENTH / EPS
BADC1 = SQRT( BADC2 )
SMALL = DLAMCH( 'Safe minimum' )
LARGE = ONE / SMALL
*
* If it looks like we're on a Cray, take the square root of
* SMALL and LARGE to avoid overflow and underflow problems.
*
CALL DLABAD( SMALL, LARGE )
SMALL = SHRINK*( SMALL / EPS )
LARGE = ONE / SMALL
END IF
*
C2 = PATH( 2: 3 )
*
* Set some parameters we don't plan to change.
*
DIST = 'S'
MODE = 3
*
IF( LSAMEN( 2, C2, 'QR' ) .OR. LSAMEN( 2, C2, 'LQ' ) .OR.
$ LSAMEN( 2, C2, 'QL' ) .OR. LSAMEN( 2, C2, 'RQ' ) ) THEN
*
* xQR, xLQ, xQL, xRQ: Set parameters to generate a general
* M x N matrix.
*
* Set TYPE, the type of matrix to be generated.
*
TYPE = 'N'
*
* Set the lower and upper bandwidths.
*
IF( IMAT.EQ.1 ) THEN
KL = 0
KU = 0
ELSE IF( IMAT.EQ.2 ) THEN
KL = 0
KU = MAX( N-1, 0 )
ELSE IF( IMAT.EQ.3 ) THEN
KL = MAX( M-1, 0 )
KU = 0
ELSE
KL = MAX( M-1, 0 )
KU = MAX( N-1, 0 )
END IF
*
* Set the condition number and norm.
*
IF( IMAT.EQ.5 ) THEN
CNDNUM = BADC1
ELSE IF( IMAT.EQ.6 ) THEN
CNDNUM = BADC2
ELSE
CNDNUM = TWO
END IF
*
IF( IMAT.EQ.7 ) THEN
ANORM = SMALL
ELSE IF( IMAT.EQ.8 ) THEN
ANORM = LARGE
ELSE
ANORM = ONE
END IF
*
ELSE IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
* xGE: Set parameters to generate a general M x N matrix.
*
* Set TYPE, the type of matrix to be generated.
*
TYPE = 'N'
*
* Set the lower and upper bandwidths.
*
IF( IMAT.EQ.1 ) THEN
KL = 0
KU = 0
ELSE IF( IMAT.EQ.2 ) THEN
KL = 0
KU = MAX( N-1, 0 )
ELSE IF( IMAT.EQ.3 ) THEN
KL = MAX( M-1, 0 )
KU = 0
ELSE
KL = MAX( M-1, 0 )
KU = MAX( N-1, 0 )
END IF
*
* Set the condition number and norm.
*
IF( IMAT.EQ.8 ) THEN
CNDNUM = BADC1
ELSE IF( IMAT.EQ.9 ) THEN
CNDNUM = BADC2
ELSE
CNDNUM = TWO
END IF
*
IF( IMAT.EQ.10 ) THEN
ANORM = SMALL
ELSE IF( IMAT.EQ.11 ) THEN
ANORM = LARGE
ELSE
ANORM = ONE
END IF
*
ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
*
* xGB: Set parameters to generate a general banded matrix.
*
* Set TYPE, the type of matrix to be generated.
*
TYPE = 'N'
*
* Set the condition number and norm.
*
IF( IMAT.EQ.5 ) THEN
CNDNUM = BADC1
ELSE IF( IMAT.EQ.6 ) THEN
CNDNUM = TENTH*BADC2
ELSE
CNDNUM = TWO
END IF
*
IF( IMAT.EQ.7 ) THEN
ANORM = SMALL
ELSE IF( IMAT.EQ.8 ) THEN
ANORM = LARGE
ELSE
ANORM = ONE
END IF
*
ELSE IF( LSAMEN( 2, C2, 'GT' ) ) THEN
*
* xGT: Set parameters to generate a general tridiagonal matrix.
*
* Set TYPE, the type of matrix to be generated.
*
TYPE = 'N'
*
* Set the lower and upper bandwidths.
*
IF( IMAT.EQ.1 ) THEN
KL = 0
ELSE
KL = 1
END IF
KU = KL
*
* Set the condition number and norm.
*
IF( IMAT.EQ.3 ) THEN
CNDNUM = BADC1
ELSE IF( IMAT.EQ.4 ) THEN
CNDNUM = BADC2
ELSE
CNDNUM = TWO
END IF
*
IF( IMAT.EQ.5 .OR. IMAT.EQ.11 ) THEN
ANORM = SMALL
ELSE IF( IMAT.EQ.6 .OR. IMAT.EQ.12 ) THEN
ANORM = LARGE
ELSE
ANORM = ONE
END IF
*
ELSE IF( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'PP' ) .OR.
$ LSAMEN( 2, C2, 'SY' ) .OR. LSAMEN( 2, C2, 'SP' ) ) THEN
*
* xPO, xPP, xSY, xSP: Set parameters to generate a
* symmetric matrix.
*
* Set TYPE, the type of matrix to be generated.
*
TYPE = C2( 1: 1 )
*
* Set the lower and upper bandwidths.
*
IF( IMAT.EQ.1 ) THEN
KL = 0
ELSE
KL = MAX( N-1, 0 )
END IF
KU = KL
*
* Set the condition number and norm.
*
IF( IMAT.EQ.6 ) THEN
CNDNUM = BADC1
ELSE IF( IMAT.EQ.7 ) THEN
CNDNUM = BADC2
ELSE
CNDNUM = TWO
END IF
*
IF( IMAT.EQ.8 ) THEN
ANORM = SMALL
ELSE IF( IMAT.EQ.9 ) THEN
ANORM = LARGE
ELSE
ANORM = ONE
END IF
*
ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN
*
* xPB: Set parameters to generate a symmetric band matrix.
*
* Set TYPE, the type of matrix to be generated.
*
TYPE = 'P'
*
* Set the norm and condition number.
*
IF( IMAT.EQ.5 ) THEN
CNDNUM = BADC1
ELSE IF( IMAT.EQ.6 ) THEN
CNDNUM = BADC2
ELSE
CNDNUM = TWO
END IF
*
IF( IMAT.EQ.7 ) THEN
ANORM = SMALL
ELSE IF( IMAT.EQ.8 ) THEN
ANORM = LARGE
ELSE
ANORM = ONE
END IF
*
ELSE IF( LSAMEN( 2, C2, 'PT' ) ) THEN
*
* xPT: Set parameters to generate a symmetric positive definite
* tridiagonal matrix.
*
TYPE = 'P'
IF( IMAT.EQ.1 ) THEN
KL = 0
ELSE
KL = 1
END IF
KU = KL
*
* Set the condition number and norm.
*
IF( IMAT.EQ.3 ) THEN
CNDNUM = BADC1
ELSE IF( IMAT.EQ.4 ) THEN
CNDNUM = BADC2
ELSE
CNDNUM = TWO
END IF
*
IF( IMAT.EQ.5 .OR. IMAT.EQ.11 ) THEN
ANORM = SMALL
ELSE IF( IMAT.EQ.6 .OR. IMAT.EQ.12 ) THEN
ANORM = LARGE
ELSE
ANORM = ONE
END IF
*
ELSE IF( LSAMEN( 2, C2, 'TR' ) .OR. LSAMEN( 2, C2, 'TP' ) ) THEN
*
* xTR, xTP: Set parameters to generate a triangular matrix
*
* Set TYPE, the type of matrix to be generated.
*
TYPE = 'N'
*
* Set the lower and upper bandwidths.
*
MAT = ABS( IMAT )
IF( MAT.EQ.1 .OR. MAT.EQ.7 ) THEN
KL = 0
KU = 0
ELSE IF( IMAT.LT.0 ) THEN
KL = MAX( N-1, 0 )
KU = 0
ELSE
KL = 0
KU = MAX( N-1, 0 )
END IF
*
* Set the condition number and norm.
*
IF( MAT.EQ.3 .OR. MAT.EQ.9 ) THEN
CNDNUM = BADC1
ELSE IF( MAT.EQ.4 ) THEN
CNDNUM = BADC2
ELSE IF( MAT.EQ.10 ) THEN
CNDNUM = BADC2
ELSE
CNDNUM = TWO
END IF
*
IF( MAT.EQ.5 ) THEN
ANORM = SMALL
ELSE IF( MAT.EQ.6 ) THEN
ANORM = LARGE
ELSE
ANORM = ONE
END IF
*
ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
*
* xTB: Set parameters to generate a triangular band matrix.
*
* Set TYPE, the type of matrix to be generated.
*
TYPE = 'N'
*
* Set the norm and condition number.
*
IF( IMAT.EQ.2 .OR. IMAT.EQ.8 ) THEN
CNDNUM = BADC1
ELSE IF( IMAT.EQ.3 .OR. IMAT.EQ.9 ) THEN
CNDNUM = BADC2
ELSE
CNDNUM = TWO
END IF
*
IF( IMAT.EQ.4 ) THEN
ANORM = SMALL
ELSE IF( IMAT.EQ.5 ) THEN
ANORM = LARGE
ELSE
ANORM = ONE
END IF
END IF
IF( N.LE.1 )
$ CNDNUM = ONE
*
RETURN
*
* End of DLATB4
*
END
SUBROUTINE DLATTB( IMAT, UPLO, TRANS, DIAG, ISEED, N, KD, AB,
$ LDAB, B, WORK, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER IMAT, INFO, KD, LDAB, N
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
DOUBLE PRECISION AB( LDAB, * ), B( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLATTB generates a triangular test matrix in 2-dimensional storage.
* IMAT and UPLO uniquely specify the properties of the test matrix,
* which is returned in the array A.
*
* Arguments
* =========
*
* IMAT (input) INTEGER
* An integer key describing which matrix to generate for this
* path.
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A will be upper or lower
* triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies whether the matrix or its transpose will be used.
* = 'N': No transpose
* = 'T': Transpose
* = 'C': Conjugate transpose (= transpose)
*
* DIAG (output) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* ISEED (input/output) INTEGER array, dimension (4)
* The seed vector for the random number generator (used in
* DLATMS). Modified on exit.
*
* N (input) INTEGER
* The order of the matrix to be generated.
*
* KD (input) INTEGER
* The number of superdiagonals or subdiagonals of the banded
* triangular matrix A. KD >= 0.
*
* AB (output) DOUBLE PRECISION array, dimension (LDAB,N)
* The upper or lower triangular banded matrix A, stored in the
* first KD+1 rows of AB. Let j be a column of A, 1<=j<=n.
* If UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j.
* If UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* B (workspace) DOUBLE PRECISION array, dimension (N)
*
* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, TWO, ZERO
PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
CHARACTER DIST, PACKIT, TYPE
CHARACTER*3 PATH
INTEGER I, IOFF, IY, J, JCOUNT, KL, KU, LENJ, MODE
DOUBLE PRECISION ANORM, BIGNUM, BNORM, BSCAL, CNDNUM, PLUS1,
$ PLUS2, REXP, SFAC, SMLNUM, STAR1, TEXP, TLEFT,
$ TNORM, TSCAL, ULP, UNFL
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH, DLARND
EXTERNAL LSAME, IDAMAX, DLAMCH, DLARND
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLABAD, DLARNV, DLATB4, DLATMS, DSCAL,
$ DSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT
* ..
* .. Executable Statements ..
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'TB'
UNFL = DLAMCH( 'Safe minimum' )
ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
SMLNUM = UNFL
BIGNUM = ( ONE-ULP ) / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
IF( ( IMAT.GE.6 .AND. IMAT.LE.9 ) .OR. IMAT.EQ.17 ) THEN
DIAG = 'U'
ELSE
DIAG = 'N'
END IF
INFO = 0
*
* Quick return if N.LE.0.
*
IF( N.LE.0 )
$ RETURN
*
* Call DLATB4 to set parameters for SLATMS.
*
UPPER = LSAME( UPLO, 'U' )
IF( UPPER ) THEN
CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
KU = KD
IOFF = 1 + MAX( 0, KD-N+1 )
KL = 0
PACKIT = 'Q'
ELSE
CALL DLATB4( PATH, -IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
KL = KD
IOFF = 1
KU = 0
PACKIT = 'B'
END IF
*
* IMAT <= 5: Non-unit triangular matrix
*
IF( IMAT.LE.5 ) THEN
CALL DLATMS( N, N, DIST, ISEED, TYPE, B, MODE, CNDNUM, ANORM,
$ KL, KU, PACKIT, AB( IOFF, 1 ), LDAB, WORK, INFO )
*
* IMAT > 5: Unit triangular matrix
* The diagonal is deliberately set to something other than 1.
*
* IMAT = 6: Matrix is the identity
*
ELSE IF( IMAT.EQ.6 ) THEN
IF( UPPER ) THEN
DO 20 J = 1, N
DO 10 I = MAX( 1, KD+2-J ), KD
AB( I, J ) = ZERO
10 CONTINUE
AB( KD+1, J ) = J
20 CONTINUE
ELSE
DO 40 J = 1, N
AB( 1, J ) = J
DO 30 I = 2, MIN( KD+1, N-J+1 )
AB( I, J ) = ZERO
30 CONTINUE
40 CONTINUE
END IF
*
* IMAT > 6: Non-trivial unit triangular matrix
*
* A unit triangular matrix T with condition CNDNUM is formed.
* In this version, T only has bandwidth 2, the rest of it is zero.
*
ELSE IF( IMAT.LE.9 ) THEN
TNORM = SQRT( CNDNUM )
*
* Initialize AB to zero.
*
IF( UPPER ) THEN
DO 60 J = 1, N
DO 50 I = MAX( 1, KD+2-J ), KD
AB( I, J ) = ZERO
50 CONTINUE
AB( KD+1, J ) = DBLE( J )
60 CONTINUE
ELSE
DO 80 J = 1, N
DO 70 I = 2, MIN( KD+1, N-J+1 )
AB( I, J ) = ZERO
70 CONTINUE
AB( 1, J ) = DBLE( J )
80 CONTINUE
END IF
*
* Special case: T is tridiagonal. Set every other offdiagonal
* so that the matrix has norm TNORM+1.
*
IF( KD.EQ.1 ) THEN
IF( UPPER ) THEN
AB( 1, 2 ) = SIGN( TNORM, DLARND( 2, ISEED ) )
LENJ = ( N-3 ) / 2
CALL DLARNV( 2, ISEED, LENJ, WORK )
DO 90 J = 1, LENJ
AB( 1, 2*( J+1 ) ) = TNORM*WORK( J )
90 CONTINUE
ELSE
AB( 2, 1 ) = SIGN( TNORM, DLARND( 2, ISEED ) )
LENJ = ( N-3 ) / 2
CALL DLARNV( 2, ISEED, LENJ, WORK )
DO 100 J = 1, LENJ
AB( 2, 2*J+1 ) = TNORM*WORK( J )
100 CONTINUE
END IF
ELSE IF( KD.GT.1 ) THEN
*
* Form a unit triangular matrix T with condition CNDNUM. T is
* given by
* | 1 + * |
* | 1 + |
* T = | 1 + * |
* | 1 + |
* | 1 + * |
* | 1 + |
* | . . . |
* Each element marked with a '*' is formed by taking the product
* of the adjacent elements marked with '+'. The '*'s can be
* chosen freely, and the '+'s are chosen so that the inverse of
* T will have elements of the same magnitude as T.
*
* The two offdiagonals of T are stored in WORK.
*
STAR1 = SIGN( TNORM, DLARND( 2, ISEED ) )
SFAC = SQRT( TNORM )
PLUS1 = SIGN( SFAC, DLARND( 2, ISEED ) )
DO 110 J = 1, N, 2
PLUS2 = STAR1 / PLUS1
WORK( J ) = PLUS1
WORK( N+J ) = STAR1
IF( J+1.LE.N ) THEN
WORK( J+1 ) = PLUS2
WORK( N+J+1 ) = ZERO
PLUS1 = STAR1 / PLUS2
*
* Generate a new *-value with norm between sqrt(TNORM)
* and TNORM.
*
REXP = DLARND( 2, ISEED )
IF( REXP.LT.ZERO ) THEN
STAR1 = -SFAC**( ONE-REXP )
ELSE
STAR1 = SFAC**( ONE+REXP )
END IF
END IF
110 CONTINUE
*
* Copy the tridiagonal T to AB.
*
IF( UPPER ) THEN
CALL DCOPY( N-1, WORK, 1, AB( KD, 2 ), LDAB )
CALL DCOPY( N-2, WORK( N+1 ), 1, AB( KD-1, 3 ), LDAB )
ELSE
CALL DCOPY( N-1, WORK, 1, AB( 2, 1 ), LDAB )
CALL DCOPY( N-2, WORK( N+1 ), 1, AB( 3, 1 ), LDAB )
END IF
END IF
*
* IMAT > 9: Pathological test cases. These triangular matrices
* are badly scaled or badly conditioned, so when used in solving a
* triangular system they may cause overflow in the solution vector.
*
ELSE IF( IMAT.EQ.10 ) THEN
*
* Type 10: Generate a triangular matrix with elements between
* -1 and 1. Give the diagonal norm 2 to make it well-conditioned.
* Make the right hand side large so that it requires scaling.
*
IF( UPPER ) THEN
DO 120 J = 1, N
LENJ = MIN( J, KD+1 )
CALL DLARNV( 2, ISEED, LENJ, AB( KD+2-LENJ, J ) )
AB( KD+1, J ) = SIGN( TWO, AB( KD+1, J ) )
120 CONTINUE
ELSE
DO 130 J = 1, N
LENJ = MIN( N-J+1, KD+1 )
IF( LENJ.GT.0 )
$ CALL DLARNV( 2, ISEED, LENJ, AB( 1, J ) )
AB( 1, J ) = SIGN( TWO, AB( 1, J ) )
130 CONTINUE
END IF
*
* Set the right hand side so that the largest value is BIGNUM.
*
CALL DLARNV( 2, ISEED, N, B )
IY = IDAMAX( N, B, 1 )
BNORM = ABS( B( IY ) )
BSCAL = BIGNUM / MAX( ONE, BNORM )
CALL DSCAL( N, BSCAL, B, 1 )
*
ELSE IF( IMAT.EQ.11 ) THEN
*
* Type 11: Make the first diagonal element in the solve small to
* cause immediate overflow when dividing by T(j,j).
* In type 11, the offdiagonal elements are small (CNORM(j) < 1).
*
CALL DLARNV( 2, ISEED, N, B )
TSCAL = ONE / DBLE( KD+1 )
IF( UPPER ) THEN
DO 140 J = 1, N
LENJ = MIN( J, KD+1 )
CALL DLARNV( 2, ISEED, LENJ, AB( KD+2-LENJ, J ) )
CALL DSCAL( LENJ-1, TSCAL, AB( KD+2-LENJ, J ), 1 )
AB( KD+1, J ) = SIGN( ONE, AB( KD+1, J ) )
140 CONTINUE
AB( KD+1, N ) = SMLNUM*AB( KD+1, N )
ELSE
DO 150 J = 1, N
LENJ = MIN( N-J+1, KD+1 )
CALL DLARNV( 2, ISEED, LENJ, AB( 1, J ) )
IF( LENJ.GT.1 )
$ CALL DSCAL( LENJ-1, TSCAL, AB( 2, J ), 1 )
AB( 1, J ) = SIGN( ONE, AB( 1, J ) )
150 CONTINUE
AB( 1, 1 ) = SMLNUM*AB( 1, 1 )
END IF
*
ELSE IF( IMAT.EQ.12 ) THEN
*
* Type 12: Make the first diagonal element in the solve small to
* cause immediate overflow when dividing by T(j,j).
* In type 12, the offdiagonal elements are O(1) (CNORM(j) > 1).
*
CALL DLARNV( 2, ISEED, N, B )
IF( UPPER ) THEN
DO 160 J = 1, N
LENJ = MIN( J, KD+1 )
CALL DLARNV( 2, ISEED, LENJ, AB( KD+2-LENJ, J ) )
AB( KD+1, J ) = SIGN( ONE, AB( KD+1, J ) )
160 CONTINUE
AB( KD+1, N ) = SMLNUM*AB( KD+1, N )
ELSE
DO 170 J = 1, N
LENJ = MIN( N-J+1, KD+1 )
CALL DLARNV( 2, ISEED, LENJ, AB( 1, J ) )
AB( 1, J ) = SIGN( ONE, AB( 1, J ) )
170 CONTINUE
AB( 1, 1 ) = SMLNUM*AB( 1, 1 )
END IF
*
ELSE IF( IMAT.EQ.13 ) THEN
*
* Type 13: T is diagonal with small numbers on the diagonal to
* make the growth factor underflow, but a small right hand side
* chosen so that the solution does not overflow.
*
IF( UPPER ) THEN
JCOUNT = 1
DO 190 J = N, 1, -1
DO 180 I = MAX( 1, KD+1-( J-1 ) ), KD
AB( I, J ) = ZERO
180 CONTINUE
IF( JCOUNT.LE.2 ) THEN
AB( KD+1, J ) = SMLNUM
ELSE
AB( KD+1, J ) = ONE
END IF
JCOUNT = JCOUNT + 1
IF( JCOUNT.GT.4 )
$ JCOUNT = 1
190 CONTINUE
ELSE
JCOUNT = 1
DO 210 J = 1, N
DO 200 I = 2, MIN( N-J+1, KD+1 )
AB( I, J ) = ZERO
200 CONTINUE
IF( JCOUNT.LE.2 ) THEN
AB( 1, J ) = SMLNUM
ELSE
AB( 1, J ) = ONE
END IF
JCOUNT = JCOUNT + 1
IF( JCOUNT.GT.4 )
$ JCOUNT = 1
210 CONTINUE
END IF
*
* Set the right hand side alternately zero and small.
*
IF( UPPER ) THEN
B( 1 ) = ZERO
DO 220 I = N, 2, -2
B( I ) = ZERO
B( I-1 ) = SMLNUM
220 CONTINUE
ELSE
B( N ) = ZERO
DO 230 I = 1, N - 1, 2
B( I ) = ZERO
B( I+1 ) = SMLNUM
230 CONTINUE
END IF
*
ELSE IF( IMAT.EQ.14 ) THEN
*
* Type 14: Make the diagonal elements small to cause gradual
* overflow when dividing by T(j,j). To control the amount of
* scaling needed, the matrix is bidiagonal.
*
TEXP = ONE / DBLE( KD+1 )
TSCAL = SMLNUM**TEXP
CALL DLARNV( 2, ISEED, N, B )
IF( UPPER ) THEN
DO 250 J = 1, N
DO 240 I = MAX( 1, KD+2-J ), KD
AB( I, J ) = ZERO
240 CONTINUE
IF( J.GT.1 .AND. KD.GT.0 )
$ AB( KD, J ) = -ONE
AB( KD+1, J ) = TSCAL
250 CONTINUE
B( N ) = ONE
ELSE
DO 270 J = 1, N
DO 260 I = 3, MIN( N-J+1, KD+1 )
AB( I, J ) = ZERO
260 CONTINUE
IF( J.LT.N .AND. KD.GT.0 )
$ AB( 2, J ) = -ONE
AB( 1, J ) = TSCAL
270 CONTINUE
B( 1 ) = ONE
END IF
*
ELSE IF( IMAT.EQ.15 ) THEN
*
* Type 15: One zero diagonal element.
*
IY = N / 2 + 1
IF( UPPER ) THEN
DO 280 J = 1, N
LENJ = MIN( J, KD+1 )
CALL DLARNV( 2, ISEED, LENJ, AB( KD+2-LENJ, J ) )
IF( J.NE.IY ) THEN
AB( KD+1, J ) = SIGN( TWO, AB( KD+1, J ) )
ELSE
AB( KD+1, J ) = ZERO
END IF
280 CONTINUE
ELSE
DO 290 J = 1, N
LENJ = MIN( N-J+1, KD+1 )
CALL DLARNV( 2, ISEED, LENJ, AB( 1, J ) )
IF( J.NE.IY ) THEN
AB( 1, J ) = SIGN( TWO, AB( 1, J ) )
ELSE
AB( 1, J ) = ZERO
END IF
290 CONTINUE
END IF
CALL DLARNV( 2, ISEED, N, B )
CALL DSCAL( N, TWO, B, 1 )
*
ELSE IF( IMAT.EQ.16 ) THEN
*
* Type 16: Make the offdiagonal elements large to cause overflow
* when adding a column of T. In the non-transposed case, the
* matrix is constructed to cause overflow when adding a column in
* every other step.
*
TSCAL = UNFL / ULP
TSCAL = ( ONE-ULP ) / TSCAL
DO 310 J = 1, N
DO 300 I = 1, KD + 1
AB( I, J ) = ZERO
300 CONTINUE
310 CONTINUE
TEXP = ONE
IF( KD.GT.0 ) THEN
IF( UPPER ) THEN
DO 330 J = N, 1, -KD
DO 320 I = J, MAX( 1, J-KD+1 ), -2
AB( 1+( J-I ), I ) = -TSCAL / DBLE( KD+2 )
AB( KD+1, I ) = ONE
B( I ) = TEXP*( ONE-ULP )
IF( I.GT.MAX( 1, J-KD+1 ) ) THEN
AB( 2+( J-I ), I-1 ) = -( TSCAL / DBLE( KD+2 ) )
$ / DBLE( KD+3 )
AB( KD+1, I-1 ) = ONE
B( I-1 ) = TEXP*DBLE( ( KD+1 )*( KD+1 )+KD )
END IF
TEXP = TEXP*TWO
320 CONTINUE
B( MAX( 1, J-KD+1 ) ) = ( DBLE( KD+2 ) /
$ DBLE( KD+3 ) )*TSCAL
330 CONTINUE
ELSE
DO 350 J = 1, N, KD
TEXP = ONE
LENJ = MIN( KD+1, N-J+1 )
DO 340 I = J, MIN( N, J+KD-1 ), 2
AB( LENJ-( I-J ), J ) = -TSCAL / DBLE( KD+2 )
AB( 1, J ) = ONE
B( J ) = TEXP*( ONE-ULP )
IF( I.LT.MIN( N, J+KD-1 ) ) THEN
AB( LENJ-( I-J+1 ), I+1 ) = -( TSCAL /
$ DBLE( KD+2 ) ) / DBLE( KD+3 )
AB( 1, I+1 ) = ONE
B( I+1 ) = TEXP*DBLE( ( KD+1 )*( KD+1 )+KD )
END IF
TEXP = TEXP*TWO
340 CONTINUE
B( MIN( N, J+KD-1 ) ) = ( DBLE( KD+2 ) /
$ DBLE( KD+3 ) )*TSCAL
350 CONTINUE
END IF
ELSE
DO 360 J = 1, N
AB( 1, J ) = ONE
B( J ) = DBLE( J )
360 CONTINUE
END IF
*
ELSE IF( IMAT.EQ.17 ) THEN
*
* Type 17: Generate a unit triangular matrix with elements
* between -1 and 1, and make the right hand side large so that it
* requires scaling.
*
IF( UPPER ) THEN
DO 370 J = 1, N
LENJ = MIN( J-1, KD )
CALL DLARNV( 2, ISEED, LENJ, AB( KD+1-LENJ, J ) )
AB( KD+1, J ) = DBLE( J )
370 CONTINUE
ELSE
DO 380 J = 1, N
LENJ = MIN( N-J, KD )
IF( LENJ.GT.0 )
$ CALL DLARNV( 2, ISEED, LENJ, AB( 2, J ) )
AB( 1, J ) = DBLE( J )
380 CONTINUE
END IF
*
* Set the right hand side so that the largest value is BIGNUM.
*
CALL DLARNV( 2, ISEED, N, B )
IY = IDAMAX( N, B, 1 )
BNORM = ABS( B( IY ) )
BSCAL = BIGNUM / MAX( ONE, BNORM )
CALL DSCAL( N, BSCAL, B, 1 )
*
ELSE IF( IMAT.EQ.18 ) THEN
*
* Type 18: Generate a triangular matrix with elements between
* BIGNUM/KD and BIGNUM so that at least one of the column
* norms will exceed BIGNUM.
*
TLEFT = BIGNUM / MAX( ONE, DBLE( KD ) )
TSCAL = BIGNUM*( DBLE( KD ) / DBLE( KD+1 ) )
IF( UPPER ) THEN
DO 400 J = 1, N
LENJ = MIN( J, KD+1 )
CALL DLARNV( 2, ISEED, LENJ, AB( KD+2-LENJ, J ) )
DO 390 I = KD + 2 - LENJ, KD + 1
AB( I, J ) = SIGN( TLEFT, AB( I, J ) ) +
$ TSCAL*AB( I, J )
390 CONTINUE
400 CONTINUE
ELSE
DO 420 J = 1, N
LENJ = MIN( N-J+1, KD+1 )
CALL DLARNV( 2, ISEED, LENJ, AB( 1, J ) )
DO 410 I = 1, LENJ
AB( I, J ) = SIGN( TLEFT, AB( I, J ) ) +
$ TSCAL*AB( I, J )
410 CONTINUE
420 CONTINUE
END IF
CALL DLARNV( 2, ISEED, N, B )
CALL DSCAL( N, TWO, B, 1 )
END IF
*
* Flip the matrix if the transpose will be used.
*
IF( .NOT.LSAME( TRANS, 'N' ) ) THEN
IF( UPPER ) THEN
DO 430 J = 1, N / 2
LENJ = MIN( N-2*J+1, KD+1 )
CALL DSWAP( LENJ, AB( KD+1, J ), LDAB-1,
$ AB( KD+2-LENJ, N-J+1 ), -1 )
430 CONTINUE
ELSE
DO 440 J = 1, N / 2
LENJ = MIN( N-2*J+1, KD+1 )
CALL DSWAP( LENJ, AB( 1, J ), 1, AB( LENJ, N-J+2-LENJ ),
$ -LDAB+1 )
440 CONTINUE
END IF
END IF
*
RETURN
*
* End of DLATTB
*
END
SUBROUTINE DLATTP( IMAT, UPLO, TRANS, DIAG, ISEED, N, A, B, WORK,
$ INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER IMAT, INFO, N
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
DOUBLE PRECISION A( * ), B( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLATTP generates a triangular test matrix in packed storage.
* IMAT and UPLO uniquely specify the properties of the test
* matrix, which is returned in the array AP.
*
* Arguments
* =========
*
* IMAT (input) INTEGER
* An integer key describing which matrix to generate for this
* path.
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A will be upper or lower
* triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies whether the matrix or its transpose will be used.
* = 'N': No transpose
* = 'T': Transpose
* = 'C': Conjugate transpose (= Transpose)
*
* DIAG (output) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* ISEED (input/output) INTEGER array, dimension (4)
* The seed vector for the random number generator (used in
* DLATMS). Modified on exit.
*
* N (input) INTEGER
* The order of the matrix to be generated.
*
* A (output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The upper or lower triangular matrix A, packed columnwise in
* a linear array. The j-th column of A is stored in the array
* AP as follows:
* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j;
* if UPLO = 'L',
* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n.
*
* B (output) DOUBLE PRECISION array, dimension (N)
* The right hand side vector, if IMAT > 10.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, TWO, ZERO
PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
CHARACTER DIST, PACKIT, TYPE
CHARACTER*3 PATH
INTEGER I, IY, J, JC, JCNEXT, JCOUNT, JJ, JL, JR, JX,
$ KL, KU, MODE
DOUBLE PRECISION ANORM, BIGNUM, BNORM, BSCAL, C, CNDNUM, PLUS1,
$ PLUS2, RA, RB, REXP, S, SFAC, SMLNUM, STAR1,
$ STEMP, T, TEXP, TLEFT, TSCAL, ULP, UNFL, X, Y,
$ Z
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH, DLARND
EXTERNAL LSAME, IDAMAX, DLAMCH, DLARND
* ..
* .. External Subroutines ..
EXTERNAL DLABAD, DLARNV, DLATB4, DLATMS, DROT, DROTG,
$ DSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, SIGN, SQRT
* ..
* .. Executable Statements ..
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'TP'
UNFL = DLAMCH( 'Safe minimum' )
ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
SMLNUM = UNFL
BIGNUM = ( ONE-ULP ) / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
IF( ( IMAT.GE.7 .AND. IMAT.LE.10 ) .OR. IMAT.EQ.18 ) THEN
DIAG = 'U'
ELSE
DIAG = 'N'
END IF
INFO = 0
*
* Quick return if N.LE.0.
*
IF( N.LE.0 )
$ RETURN
*
* Call DLATB4 to set parameters for SLATMS.
*
UPPER = LSAME( UPLO, 'U' )
IF( UPPER ) THEN
CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
PACKIT = 'C'
ELSE
CALL DLATB4( PATH, -IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
PACKIT = 'R'
END IF
*
* IMAT <= 6: Non-unit triangular matrix
*
IF( IMAT.LE.6 ) THEN
CALL DLATMS( N, N, DIST, ISEED, TYPE, B, MODE, CNDNUM, ANORM,
$ KL, KU, PACKIT, A, N, WORK, INFO )
*
* IMAT > 6: Unit triangular matrix
* The diagonal is deliberately set to something other than 1.
*
* IMAT = 7: Matrix is the identity
*
ELSE IF( IMAT.EQ.7 ) THEN
IF( UPPER ) THEN
JC = 1
DO 20 J = 1, N
DO 10 I = 1, J - 1
A( JC+I-1 ) = ZERO
10 CONTINUE
A( JC+J-1 ) = J
JC = JC + J
20 CONTINUE
ELSE
JC = 1
DO 40 J = 1, N
A( JC ) = J
DO 30 I = J + 1, N
A( JC+I-J ) = ZERO
30 CONTINUE
JC = JC + N - J + 1
40 CONTINUE
END IF
*
* IMAT > 7: Non-trivial unit triangular matrix
*
* Generate a unit triangular matrix T with condition CNDNUM by
* forming a triangular matrix with known singular values and
* filling in the zero entries with Givens rotations.
*
ELSE IF( IMAT.LE.10 ) THEN
IF( UPPER ) THEN
JC = 0
DO 60 J = 1, N
DO 50 I = 1, J - 1
A( JC+I ) = ZERO
50 CONTINUE
A( JC+J ) = J
JC = JC + J
60 CONTINUE
ELSE
JC = 1
DO 80 J = 1, N
A( JC ) = J
DO 70 I = J + 1, N
A( JC+I-J ) = ZERO
70 CONTINUE
JC = JC + N - J + 1
80 CONTINUE
END IF
*
* Since the trace of a unit triangular matrix is 1, the product
* of its singular values must be 1. Let s = sqrt(CNDNUM),
* x = sqrt(s) - 1/sqrt(s), y = sqrt(2/(n-2))*x, and z = x**2.
* The following triangular matrix has singular values s, 1, 1,
* ..., 1, 1/s:
*
* 1 y y y ... y y z
* 1 0 0 ... 0 0 y
* 1 0 ... 0 0 y
* . ... . . .
* . . . .
* 1 0 y
* 1 y
* 1
*
* To fill in the zeros, we first multiply by a matrix with small
* condition number of the form
*
* 1 0 0 0 0 ...
* 1 + * 0 0 ...
* 1 + 0 0 0
* 1 + * 0 0
* 1 + 0 0
* ...
* 1 + 0
* 1 0
* 1
*
* Each element marked with a '*' is formed by taking the product
* of the adjacent elements marked with '+'. The '*'s can be
* chosen freely, and the '+'s are chosen so that the inverse of
* T will have elements of the same magnitude as T. If the *'s in
* both T and inv(T) have small magnitude, T is well conditioned.
* The two offdiagonals of T are stored in WORK.
*
* The product of these two matrices has the form
*
* 1 y y y y y . y y z
* 1 + * 0 0 . 0 0 y
* 1 + 0 0 . 0 0 y
* 1 + * . . . .
* 1 + . . . .
* . . . . .
* . . . .
* 1 + y
* 1 y
* 1
*
* Now we multiply by Givens rotations, using the fact that
*
* [ c s ] [ 1 w ] [ -c -s ] = [ 1 -w ]
* [ -s c ] [ 0 1 ] [ s -c ] [ 0 1 ]
* and
* [ -c -s ] [ 1 0 ] [ c s ] = [ 1 0 ]
* [ s -c ] [ w 1 ] [ -s c ] [ -w 1 ]
*
* where c = w / sqrt(w**2+4) and s = 2 / sqrt(w**2+4).
*
STAR1 = 0.25D0
SFAC = 0.5D0
PLUS1 = SFAC
DO 90 J = 1, N, 2
PLUS2 = STAR1 / PLUS1
WORK( J ) = PLUS1
WORK( N+J ) = STAR1
IF( J+1.LE.N ) THEN
WORK( J+1 ) = PLUS2
WORK( N+J+1 ) = ZERO
PLUS1 = STAR1 / PLUS2
REXP = DLARND( 2, ISEED )
STAR1 = STAR1*( SFAC**REXP )
IF( REXP.LT.ZERO ) THEN
STAR1 = -SFAC**( ONE-REXP )
ELSE
STAR1 = SFAC**( ONE+REXP )
END IF
END IF
90 CONTINUE
*
X = SQRT( CNDNUM ) - ONE / SQRT( CNDNUM )
IF( N.GT.2 ) THEN
Y = SQRT( TWO / DBLE( N-2 ) )*X
ELSE
Y = ZERO
END IF
Z = X*X
*
IF( UPPER ) THEN
*
* Set the upper triangle of A with a unit triangular matrix
* of known condition number.
*
JC = 1
DO 100 J = 2, N
A( JC+1 ) = Y
IF( J.GT.2 )
$ A( JC+J-1 ) = WORK( J-2 )
IF( J.GT.3 )
$ A( JC+J-2 ) = WORK( N+J-3 )
JC = JC + J
100 CONTINUE
JC = JC - N
A( JC+1 ) = Z
DO 110 J = 2, N - 1
A( JC+J ) = Y
110 CONTINUE
ELSE
*
* Set the lower triangle of A with a unit triangular matrix
* of known condition number.
*
DO 120 I = 2, N - 1
A( I ) = Y
120 CONTINUE
A( N ) = Z
JC = N + 1
DO 130 J = 2, N - 1
A( JC+1 ) = WORK( J-1 )
IF( J.LT.N-1 )
$ A( JC+2 ) = WORK( N+J-1 )
A( JC+N-J ) = Y
JC = JC + N - J + 1
130 CONTINUE
END IF
*
* Fill in the zeros using Givens rotations
*
IF( UPPER ) THEN
JC = 1
DO 150 J = 1, N - 1
JCNEXT = JC + J
RA = A( JCNEXT+J-1 )
RB = TWO
CALL DROTG( RA, RB, C, S )
*
* Multiply by [ c s; -s c] on the left.
*
IF( N.GT.J+1 ) THEN
JX = JCNEXT + J
DO 140 I = J + 2, N
STEMP = C*A( JX+J ) + S*A( JX+J+1 )
A( JX+J+1 ) = -S*A( JX+J ) + C*A( JX+J+1 )
A( JX+J ) = STEMP
JX = JX + I
140 CONTINUE
END IF
*
* Multiply by [-c -s; s -c] on the right.
*
IF( J.GT.1 )
$ CALL DROT( J-1, A( JCNEXT ), 1, A( JC ), 1, -C, -S )
*
* Negate A(J,J+1).
*
A( JCNEXT+J-1 ) = -A( JCNEXT+J-1 )
JC = JCNEXT
150 CONTINUE
ELSE
JC = 1
DO 170 J = 1, N - 1
JCNEXT = JC + N - J + 1
RA = A( JC+1 )
RB = TWO
CALL DROTG( RA, RB, C, S )
*
* Multiply by [ c -s; s c] on the right.
*
IF( N.GT.J+1 )
$ CALL DROT( N-J-1, A( JCNEXT+1 ), 1, A( JC+2 ), 1, C,
$ -S )
*
* Multiply by [-c s; -s -c] on the left.
*
IF( J.GT.1 ) THEN
JX = 1
DO 160 I = 1, J - 1
STEMP = -C*A( JX+J-I ) + S*A( JX+J-I+1 )
A( JX+J-I+1 ) = -S*A( JX+J-I ) - C*A( JX+J-I+1 )
A( JX+J-I ) = STEMP
JX = JX + N - I + 1
160 CONTINUE
END IF
*
* Negate A(J+1,J).
*
A( JC+1 ) = -A( JC+1 )
JC = JCNEXT
170 CONTINUE
END IF
*
* IMAT > 10: Pathological test cases. These triangular matrices
* are badly scaled or badly conditioned, so when used in solving a
* triangular system they may cause overflow in the solution vector.
*
ELSE IF( IMAT.EQ.11 ) THEN
*
* Type 11: Generate a triangular matrix with elements between
* -1 and 1. Give the diagonal norm 2 to make it well-conditioned.
* Make the right hand side large so that it requires scaling.
*
IF( UPPER ) THEN
JC = 1
DO 180 J = 1, N
CALL DLARNV( 2, ISEED, J, A( JC ) )
A( JC+J-1 ) = SIGN( TWO, A( JC+J-1 ) )
JC = JC + J
180 CONTINUE
ELSE
JC = 1
DO 190 J = 1, N
CALL DLARNV( 2, ISEED, N-J+1, A( JC ) )
A( JC ) = SIGN( TWO, A( JC ) )
JC = JC + N - J + 1
190 CONTINUE
END IF
*
* Set the right hand side so that the largest value is BIGNUM.
*
CALL DLARNV( 2, ISEED, N, B )
IY = IDAMAX( N, B, 1 )
BNORM = ABS( B( IY ) )
BSCAL = BIGNUM / MAX( ONE, BNORM )
CALL DSCAL( N, BSCAL, B, 1 )
*
ELSE IF( IMAT.EQ.12 ) THEN
*
* Type 12: Make the first diagonal element in the solve small to
* cause immediate overflow when dividing by T(j,j).
* In type 12, the offdiagonal elements are small (CNORM(j) < 1).
*
CALL DLARNV( 2, ISEED, N, B )
TSCAL = ONE / MAX( ONE, DBLE( N-1 ) )
IF( UPPER ) THEN
JC = 1
DO 200 J = 1, N
CALL DLARNV( 2, ISEED, J-1, A( JC ) )
CALL DSCAL( J-1, TSCAL, A( JC ), 1 )
A( JC+J-1 ) = SIGN( ONE, DLARND( 2, ISEED ) )
JC = JC + J
200 CONTINUE
A( N*( N+1 ) / 2 ) = SMLNUM
ELSE
JC = 1
DO 210 J = 1, N
CALL DLARNV( 2, ISEED, N-J, A( JC+1 ) )
CALL DSCAL( N-J, TSCAL, A( JC+1 ), 1 )
A( JC ) = SIGN( ONE, DLARND( 2, ISEED ) )
JC = JC + N - J + 1
210 CONTINUE
A( 1 ) = SMLNUM
END IF
*
ELSE IF( IMAT.EQ.13 ) THEN
*
* Type 13: Make the first diagonal element in the solve small to
* cause immediate overflow when dividing by T(j,j).
* In type 13, the offdiagonal elements are O(1) (CNORM(j) > 1).
*
CALL DLARNV( 2, ISEED, N, B )
IF( UPPER ) THEN
JC = 1
DO 220 J = 1, N
CALL DLARNV( 2, ISEED, J-1, A( JC ) )
A( JC+J-1 ) = SIGN( ONE, DLARND( 2, ISEED ) )
JC = JC + J
220 CONTINUE
A( N*( N+1 ) / 2 ) = SMLNUM
ELSE
JC = 1
DO 230 J = 1, N
CALL DLARNV( 2, ISEED, N-J, A( JC+1 ) )
A( JC ) = SIGN( ONE, DLARND( 2, ISEED ) )
JC = JC + N - J + 1
230 CONTINUE
A( 1 ) = SMLNUM
END IF
*
ELSE IF( IMAT.EQ.14 ) THEN
*
* Type 14: T is diagonal with small numbers on the diagonal to
* make the growth factor underflow, but a small right hand side
* chosen so that the solution does not overflow.
*
IF( UPPER ) THEN
JCOUNT = 1
JC = ( N-1 )*N / 2 + 1
DO 250 J = N, 1, -1
DO 240 I = 1, J - 1
A( JC+I-1 ) = ZERO
240 CONTINUE
IF( JCOUNT.LE.2 ) THEN
A( JC+J-1 ) = SMLNUM
ELSE
A( JC+J-1 ) = ONE
END IF
JCOUNT = JCOUNT + 1
IF( JCOUNT.GT.4 )
$ JCOUNT = 1
JC = JC - J + 1
250 CONTINUE
ELSE
JCOUNT = 1
JC = 1
DO 270 J = 1, N
DO 260 I = J + 1, N
A( JC+I-J ) = ZERO
260 CONTINUE
IF( JCOUNT.LE.2 ) THEN
A( JC ) = SMLNUM
ELSE
A( JC ) = ONE
END IF
JCOUNT = JCOUNT + 1
IF( JCOUNT.GT.4 )
$ JCOUNT = 1
JC = JC + N - J + 1
270 CONTINUE
END IF
*
* Set the right hand side alternately zero and small.
*
IF( UPPER ) THEN
B( 1 ) = ZERO
DO 280 I = N, 2, -2
B( I ) = ZERO
B( I-1 ) = SMLNUM
280 CONTINUE
ELSE
B( N ) = ZERO
DO 290 I = 1, N - 1, 2
B( I ) = ZERO
B( I+1 ) = SMLNUM
290 CONTINUE
END IF
*
ELSE IF( IMAT.EQ.15 ) THEN
*
* Type 15: Make the diagonal elements small to cause gradual
* overflow when dividing by T(j,j). To control the amount of
* scaling needed, the matrix is bidiagonal.
*
TEXP = ONE / MAX( ONE, DBLE( N-1 ) )
TSCAL = SMLNUM**TEXP
CALL DLARNV( 2, ISEED, N, B )
IF( UPPER ) THEN
JC = 1
DO 310 J = 1, N
DO 300 I = 1, J - 2
A( JC+I-1 ) = ZERO
300 CONTINUE
IF( J.GT.1 )
$ A( JC+J-2 ) = -ONE
A( JC+J-1 ) = TSCAL
JC = JC + J
310 CONTINUE
B( N ) = ONE
ELSE
JC = 1
DO 330 J = 1, N
DO 320 I = J + 2, N
A( JC+I-J ) = ZERO
320 CONTINUE
IF( J.LT.N )
$ A( JC+1 ) = -ONE
A( JC ) = TSCAL
JC = JC + N - J + 1
330 CONTINUE
B( 1 ) = ONE
END IF
*
ELSE IF( IMAT.EQ.16 ) THEN
*
* Type 16: One zero diagonal element.
*
IY = N / 2 + 1
IF( UPPER ) THEN
JC = 1
DO 340 J = 1, N
CALL DLARNV( 2, ISEED, J, A( JC ) )
IF( J.NE.IY ) THEN
A( JC+J-1 ) = SIGN( TWO, A( JC+J-1 ) )
ELSE
A( JC+J-1 ) = ZERO
END IF
JC = JC + J
340 CONTINUE
ELSE
JC = 1
DO 350 J = 1, N
CALL DLARNV( 2, ISEED, N-J+1, A( JC ) )
IF( J.NE.IY ) THEN
A( JC ) = SIGN( TWO, A( JC ) )
ELSE
A( JC ) = ZERO
END IF
JC = JC + N - J + 1
350 CONTINUE
END IF
CALL DLARNV( 2, ISEED, N, B )
CALL DSCAL( N, TWO, B, 1 )
*
ELSE IF( IMAT.EQ.17 ) THEN
*
* Type 17: Make the offdiagonal elements large to cause overflow
* when adding a column of T. In the non-transposed case, the
* matrix is constructed to cause overflow when adding a column in
* every other step.
*
TSCAL = UNFL / ULP
TSCAL = ( ONE-ULP ) / TSCAL
DO 360 J = 1, N*( N+1 ) / 2
A( J ) = ZERO
360 CONTINUE
TEXP = ONE
IF( UPPER ) THEN
JC = ( N-1 )*N / 2 + 1
DO 370 J = N, 2, -2
A( JC ) = -TSCAL / DBLE( N+1 )
A( JC+J-1 ) = ONE
B( J ) = TEXP*( ONE-ULP )
JC = JC - J + 1
A( JC ) = -( TSCAL / DBLE( N+1 ) ) / DBLE( N+2 )
A( JC+J-2 ) = ONE
B( J-1 ) = TEXP*DBLE( N*N+N-1 )
TEXP = TEXP*TWO
JC = JC - J + 2
370 CONTINUE
B( 1 ) = ( DBLE( N+1 ) / DBLE( N+2 ) )*TSCAL
ELSE
JC = 1
DO 380 J = 1, N - 1, 2
A( JC+N-J ) = -TSCAL / DBLE( N+1 )
A( JC ) = ONE
B( J ) = TEXP*( ONE-ULP )
JC = JC + N - J + 1
A( JC+N-J-1 ) = -( TSCAL / DBLE( N+1 ) ) / DBLE( N+2 )
A( JC ) = ONE
B( J+1 ) = TEXP*DBLE( N*N+N-1 )
TEXP = TEXP*TWO
JC = JC + N - J
380 CONTINUE
B( N ) = ( DBLE( N+1 ) / DBLE( N+2 ) )*TSCAL
END IF
*
ELSE IF( IMAT.EQ.18 ) THEN
*
* Type 18: Generate a unit triangular matrix with elements
* between -1 and 1, and make the right hand side large so that it
* requires scaling.
*
IF( UPPER ) THEN
JC = 1
DO 390 J = 1, N
CALL DLARNV( 2, ISEED, J-1, A( JC ) )
A( JC+J-1 ) = ZERO
JC = JC + J
390 CONTINUE
ELSE
JC = 1
DO 400 J = 1, N
IF( J.LT.N )
$ CALL DLARNV( 2, ISEED, N-J, A( JC+1 ) )
A( JC ) = ZERO
JC = JC + N - J + 1
400 CONTINUE
END IF
*
* Set the right hand side so that the largest value is BIGNUM.
*
CALL DLARNV( 2, ISEED, N, B )
IY = IDAMAX( N, B, 1 )
BNORM = ABS( B( IY ) )
BSCAL = BIGNUM / MAX( ONE, BNORM )
CALL DSCAL( N, BSCAL, B, 1 )
*
ELSE IF( IMAT.EQ.19 ) THEN
*
* Type 19: Generate a triangular matrix with elements between
* BIGNUM/(n-1) and BIGNUM so that at least one of the column
* norms will exceed BIGNUM.
*
TLEFT = BIGNUM / MAX( ONE, DBLE( N-1 ) )
TSCAL = BIGNUM*( DBLE( N-1 ) / MAX( ONE, DBLE( N ) ) )
IF( UPPER ) THEN
JC = 1
DO 420 J = 1, N
CALL DLARNV( 2, ISEED, J, A( JC ) )
DO 410 I = 1, J
A( JC+I-1 ) = SIGN( TLEFT, A( JC+I-1 ) ) +
$ TSCAL*A( JC+I-1 )
410 CONTINUE
JC = JC + J
420 CONTINUE
ELSE
JC = 1
DO 440 J = 1, N
CALL DLARNV( 2, ISEED, N-J+1, A( JC ) )
DO 430 I = J, N
A( JC+I-J ) = SIGN( TLEFT, A( JC+I-J ) ) +
$ TSCAL*A( JC+I-J )
430 CONTINUE
JC = JC + N - J + 1
440 CONTINUE
END IF
CALL DLARNV( 2, ISEED, N, B )
CALL DSCAL( N, TWO, B, 1 )
END IF
*
* Flip the matrix across its counter-diagonal if the transpose will
* be used.
*
IF( .NOT.LSAME( TRANS, 'N' ) ) THEN
IF( UPPER ) THEN
JJ = 1
JR = N*( N+1 ) / 2
DO 460 J = 1, N / 2
JL = JJ
DO 450 I = J, N - J
T = A( JR-I+J )
A( JR-I+J ) = A( JL )
A( JL ) = T
JL = JL + I
450 CONTINUE
JJ = JJ + J + 1
JR = JR - ( N-J+1 )
460 CONTINUE
ELSE
JL = 1
JJ = N*( N+1 ) / 2
DO 480 J = 1, N / 2
JR = JJ
DO 470 I = J, N - J
T = A( JL+I-J )
A( JL+I-J ) = A( JR )
A( JR ) = T
JR = JR - I
470 CONTINUE
JL = JL + N - J + 1
JJ = JJ - J - 1
480 CONTINUE
END IF
END IF
*
RETURN
*
* End of DLATTP
*
END
SUBROUTINE DLATTR( IMAT, UPLO, TRANS, DIAG, ISEED, N, A, LDA, B,
$ WORK, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER IMAT, INFO, LDA, N
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
DOUBLE PRECISION A( LDA, * ), B( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLATTR generates a triangular test matrix.
* IMAT and UPLO uniquely specify the properties of the test
* matrix, which is returned in the array A.
*
* Arguments
* =========
*
* IMAT (input) INTEGER
* An integer key describing which matrix to generate for this
* path.
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A will be upper or lower
* triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies whether the matrix or its transpose will be used.
* = 'N': No transpose
* = 'T': Transpose
* = 'C': Conjugate transpose (= Transpose)
*
* DIAG (output) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* ISEED (input/output) INTEGER array, dimension (4)
* The seed vector for the random number generator (used in
* DLATMS). Modified on exit.
*
* N (input) INTEGER
* The order of the matrix to be generated.
*
* A (output) DOUBLE PRECISION array, dimension (LDA,N)
* The triangular matrix A. If UPLO = 'U', the leading n by n
* upper triangular part of the array A contains the upper
* triangular matrix, and the strictly lower triangular part of
* A is not referenced. If UPLO = 'L', the leading n by n lower
* triangular part of the array A contains the lower triangular
* matrix, and the strictly upper triangular part of A is not
* referenced. If DIAG = 'U', the diagonal elements of A are
* set so that A(k,k) = k for 1 <= k <= n.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (output) DOUBLE PRECISION array, dimension (N)
* The right hand side vector, if IMAT > 10.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, TWO, ZERO
PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
CHARACTER DIST, TYPE
CHARACTER*3 PATH
INTEGER I, IY, J, JCOUNT, KL, KU, MODE
DOUBLE PRECISION ANORM, BIGNUM, BNORM, BSCAL, C, CNDNUM, PLUS1,
$ PLUS2, RA, RB, REXP, S, SFAC, SMLNUM, STAR1,
$ TEXP, TLEFT, TSCAL, ULP, UNFL, X, Y, Z
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH, DLARND
EXTERNAL LSAME, IDAMAX, DLAMCH, DLARND
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLABAD, DLARNV, DLATB4, DLATMS, DROT,
$ DROTG, DSCAL, DSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, SIGN, SQRT
* ..
* .. Executable Statements ..
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'TR'
UNFL = DLAMCH( 'Safe minimum' )
ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
SMLNUM = UNFL
BIGNUM = ( ONE-ULP ) / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
IF( ( IMAT.GE.7 .AND. IMAT.LE.10 ) .OR. IMAT.EQ.18 ) THEN
DIAG = 'U'
ELSE
DIAG = 'N'
END IF
INFO = 0
*
* Quick return if N.LE.0.
*
IF( N.LE.0 )
$ RETURN
*
* Call DLATB4 to set parameters for SLATMS.
*
UPPER = LSAME( UPLO, 'U' )
IF( UPPER ) THEN
CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
ELSE
CALL DLATB4( PATH, -IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
END IF
*
* IMAT <= 6: Non-unit triangular matrix
*
IF( IMAT.LE.6 ) THEN
CALL DLATMS( N, N, DIST, ISEED, TYPE, B, MODE, CNDNUM, ANORM,
$ KL, KU, 'No packing', A, LDA, WORK, INFO )
*
* IMAT > 6: Unit triangular matrix
* The diagonal is deliberately set to something other than 1.
*
* IMAT = 7: Matrix is the identity
*
ELSE IF( IMAT.EQ.7 ) THEN
IF( UPPER ) THEN
DO 20 J = 1, N
DO 10 I = 1, J - 1
A( I, J ) = ZERO
10 CONTINUE
A( J, J ) = J
20 CONTINUE
ELSE
DO 40 J = 1, N
A( J, J ) = J
DO 30 I = J + 1, N
A( I, J ) = ZERO
30 CONTINUE
40 CONTINUE
END IF
*
* IMAT > 7: Non-trivial unit triangular matrix
*
* Generate a unit triangular matrix T with condition CNDNUM by
* forming a triangular matrix with known singular values and
* filling in the zero entries with Givens rotations.
*
ELSE IF( IMAT.LE.10 ) THEN
IF( UPPER ) THEN
DO 60 J = 1, N
DO 50 I = 1, J - 1
A( I, J ) = ZERO
50 CONTINUE
A( J, J ) = J
60 CONTINUE
ELSE
DO 80 J = 1, N
A( J, J ) = J
DO 70 I = J + 1, N
A( I, J ) = ZERO
70 CONTINUE
80 CONTINUE
END IF
*
* Since the trace of a unit triangular matrix is 1, the product
* of its singular values must be 1. Let s = sqrt(CNDNUM),
* x = sqrt(s) - 1/sqrt(s), y = sqrt(2/(n-2))*x, and z = x**2.
* The following triangular matrix has singular values s, 1, 1,
* ..., 1, 1/s:
*
* 1 y y y ... y y z
* 1 0 0 ... 0 0 y
* 1 0 ... 0 0 y
* . ... . . .
* . . . .
* 1 0 y
* 1 y
* 1
*
* To fill in the zeros, we first multiply by a matrix with small
* condition number of the form
*
* 1 0 0 0 0 ...
* 1 + * 0 0 ...
* 1 + 0 0 0
* 1 + * 0 0
* 1 + 0 0
* ...
* 1 + 0
* 1 0
* 1
*
* Each element marked with a '*' is formed by taking the product
* of the adjacent elements marked with '+'. The '*'s can be
* chosen freely, and the '+'s are chosen so that the inverse of
* T will have elements of the same magnitude as T. If the *'s in
* both T and inv(T) have small magnitude, T is well conditioned.
* The two offdiagonals of T are stored in WORK.
*
* The product of these two matrices has the form
*
* 1 y y y y y . y y z
* 1 + * 0 0 . 0 0 y
* 1 + 0 0 . 0 0 y
* 1 + * . . . .
* 1 + . . . .
* . . . . .
* . . . .
* 1 + y
* 1 y
* 1
*
* Now we multiply by Givens rotations, using the fact that
*
* [ c s ] [ 1 w ] [ -c -s ] = [ 1 -w ]
* [ -s c ] [ 0 1 ] [ s -c ] [ 0 1 ]
* and
* [ -c -s ] [ 1 0 ] [ c s ] = [ 1 0 ]
* [ s -c ] [ w 1 ] [ -s c ] [ -w 1 ]
*
* where c = w / sqrt(w**2+4) and s = 2 / sqrt(w**2+4).
*
STAR1 = 0.25D0
SFAC = 0.5D0
PLUS1 = SFAC
DO 90 J = 1, N, 2
PLUS2 = STAR1 / PLUS1
WORK( J ) = PLUS1
WORK( N+J ) = STAR1
IF( J+1.LE.N ) THEN
WORK( J+1 ) = PLUS2
WORK( N+J+1 ) = ZERO
PLUS1 = STAR1 / PLUS2
REXP = DLARND( 2, ISEED )
STAR1 = STAR1*( SFAC**REXP )
IF( REXP.LT.ZERO ) THEN
STAR1 = -SFAC**( ONE-REXP )
ELSE
STAR1 = SFAC**( ONE+REXP )
END IF
END IF
90 CONTINUE
*
X = SQRT( CNDNUM ) - 1 / SQRT( CNDNUM )
IF( N.GT.2 ) THEN
Y = SQRT( 2.D0 / ( N-2 ) )*X
ELSE
Y = ZERO
END IF
Z = X*X
*
IF( UPPER ) THEN
IF( N.GT.3 ) THEN
CALL DCOPY( N-3, WORK, 1, A( 2, 3 ), LDA+1 )
IF( N.GT.4 )
$ CALL DCOPY( N-4, WORK( N+1 ), 1, A( 2, 4 ), LDA+1 )
END IF
DO 100 J = 2, N - 1
A( 1, J ) = Y
A( J, N ) = Y
100 CONTINUE
A( 1, N ) = Z
ELSE
IF( N.GT.3 ) THEN
CALL DCOPY( N-3, WORK, 1, A( 3, 2 ), LDA+1 )
IF( N.GT.4 )
$ CALL DCOPY( N-4, WORK( N+1 ), 1, A( 4, 2 ), LDA+1 )
END IF
DO 110 J = 2, N - 1
A( J, 1 ) = Y
A( N, J ) = Y
110 CONTINUE
A( N, 1 ) = Z
END IF
*
* Fill in the zeros using Givens rotations.
*
IF( UPPER ) THEN
DO 120 J = 1, N - 1
RA = A( J, J+1 )
RB = 2.0D0
CALL DROTG( RA, RB, C, S )
*
* Multiply by [ c s; -s c] on the left.
*
IF( N.GT.J+1 )
$ CALL DROT( N-J-1, A( J, J+2 ), LDA, A( J+1, J+2 ),
$ LDA, C, S )
*
* Multiply by [-c -s; s -c] on the right.
*
IF( J.GT.1 )
$ CALL DROT( J-1, A( 1, J+1 ), 1, A( 1, J ), 1, -C, -S )
*
* Negate A(J,J+1).
*
A( J, J+1 ) = -A( J, J+1 )
120 CONTINUE
ELSE
DO 130 J = 1, N - 1
RA = A( J+1, J )
RB = 2.0D0
CALL DROTG( RA, RB, C, S )
*
* Multiply by [ c -s; s c] on the right.
*
IF( N.GT.J+1 )
$ CALL DROT( N-J-1, A( J+2, J+1 ), 1, A( J+2, J ), 1, C,
$ -S )
*
* Multiply by [-c s; -s -c] on the left.
*
IF( J.GT.1 )
$ CALL DROT( J-1, A( J, 1 ), LDA, A( J+1, 1 ), LDA, -C,
$ S )
*
* Negate A(J+1,J).
*
A( J+1, J ) = -A( J+1, J )
130 CONTINUE
END IF
*
* IMAT > 10: Pathological test cases. These triangular matrices
* are badly scaled or badly conditioned, so when used in solving a
* triangular system they may cause overflow in the solution vector.
*
ELSE IF( IMAT.EQ.11 ) THEN
*
* Type 11: Generate a triangular matrix with elements between
* -1 and 1. Give the diagonal norm 2 to make it well-conditioned.
* Make the right hand side large so that it requires scaling.
*
IF( UPPER ) THEN
DO 140 J = 1, N
CALL DLARNV( 2, ISEED, J, A( 1, J ) )
A( J, J ) = SIGN( TWO, A( J, J ) )
140 CONTINUE
ELSE
DO 150 J = 1, N
CALL DLARNV( 2, ISEED, N-J+1, A( J, J ) )
A( J, J ) = SIGN( TWO, A( J, J ) )
150 CONTINUE
END IF
*
* Set the right hand side so that the largest value is BIGNUM.
*
CALL DLARNV( 2, ISEED, N, B )
IY = IDAMAX( N, B, 1 )
BNORM = ABS( B( IY ) )
BSCAL = BIGNUM / MAX( ONE, BNORM )
CALL DSCAL( N, BSCAL, B, 1 )
*
ELSE IF( IMAT.EQ.12 ) THEN
*
* Type 12: Make the first diagonal element in the solve small to
* cause immediate overflow when dividing by T(j,j).
* In type 12, the offdiagonal elements are small (CNORM(j) < 1).
*
CALL DLARNV( 2, ISEED, N, B )
TSCAL = ONE / MAX( ONE, DBLE( N-1 ) )
IF( UPPER ) THEN
DO 160 J = 1, N
CALL DLARNV( 2, ISEED, J, A( 1, J ) )
CALL DSCAL( J-1, TSCAL, A( 1, J ), 1 )
A( J, J ) = SIGN( ONE, A( J, J ) )
160 CONTINUE
A( N, N ) = SMLNUM*A( N, N )
ELSE
DO 170 J = 1, N
CALL DLARNV( 2, ISEED, N-J+1, A( J, J ) )
IF( N.GT.J )
$ CALL DSCAL( N-J, TSCAL, A( J+1, J ), 1 )
A( J, J ) = SIGN( ONE, A( J, J ) )
170 CONTINUE
A( 1, 1 ) = SMLNUM*A( 1, 1 )
END IF
*
ELSE IF( IMAT.EQ.13 ) THEN
*
* Type 13: Make the first diagonal element in the solve small to
* cause immediate overflow when dividing by T(j,j).
* In type 13, the offdiagonal elements are O(1) (CNORM(j) > 1).
*
CALL DLARNV( 2, ISEED, N, B )
IF( UPPER ) THEN
DO 180 J = 1, N
CALL DLARNV( 2, ISEED, J, A( 1, J ) )
A( J, J ) = SIGN( ONE, A( J, J ) )
180 CONTINUE
A( N, N ) = SMLNUM*A( N, N )
ELSE
DO 190 J = 1, N
CALL DLARNV( 2, ISEED, N-J+1, A( J, J ) )
A( J, J ) = SIGN( ONE, A( J, J ) )
190 CONTINUE
A( 1, 1 ) = SMLNUM*A( 1, 1 )
END IF
*
ELSE IF( IMAT.EQ.14 ) THEN
*
* Type 14: T is diagonal with small numbers on the diagonal to
* make the growth factor underflow, but a small right hand side
* chosen so that the solution does not overflow.
*
IF( UPPER ) THEN
JCOUNT = 1
DO 210 J = N, 1, -1
DO 200 I = 1, J - 1
A( I, J ) = ZERO
200 CONTINUE
IF( JCOUNT.LE.2 ) THEN
A( J, J ) = SMLNUM
ELSE
A( J, J ) = ONE
END IF
JCOUNT = JCOUNT + 1
IF( JCOUNT.GT.4 )
$ JCOUNT = 1
210 CONTINUE
ELSE
JCOUNT = 1
DO 230 J = 1, N
DO 220 I = J + 1, N
A( I, J ) = ZERO
220 CONTINUE
IF( JCOUNT.LE.2 ) THEN
A( J, J ) = SMLNUM
ELSE
A( J, J ) = ONE
END IF
JCOUNT = JCOUNT + 1
IF( JCOUNT.GT.4 )
$ JCOUNT = 1
230 CONTINUE
END IF
*
* Set the right hand side alternately zero and small.
*
IF( UPPER ) THEN
B( 1 ) = ZERO
DO 240 I = N, 2, -2
B( I ) = ZERO
B( I-1 ) = SMLNUM
240 CONTINUE
ELSE
B( N ) = ZERO
DO 250 I = 1, N - 1, 2
B( I ) = ZERO
B( I+1 ) = SMLNUM
250 CONTINUE
END IF
*
ELSE IF( IMAT.EQ.15 ) THEN
*
* Type 15: Make the diagonal elements small to cause gradual
* overflow when dividing by T(j,j). To control the amount of
* scaling needed, the matrix is bidiagonal.
*
TEXP = ONE / MAX( ONE, DBLE( N-1 ) )
TSCAL = SMLNUM**TEXP
CALL DLARNV( 2, ISEED, N, B )
IF( UPPER ) THEN
DO 270 J = 1, N
DO 260 I = 1, J - 2
A( I, J ) = 0.D0
260 CONTINUE
IF( J.GT.1 )
$ A( J-1, J ) = -ONE
A( J, J ) = TSCAL
270 CONTINUE
B( N ) = ONE
ELSE
DO 290 J = 1, N
DO 280 I = J + 2, N
A( I, J ) = 0.D0
280 CONTINUE
IF( J.LT.N )
$ A( J+1, J ) = -ONE
A( J, J ) = TSCAL
290 CONTINUE
B( 1 ) = ONE
END IF
*
ELSE IF( IMAT.EQ.16 ) THEN
*
* Type 16: One zero diagonal element.
*
IY = N / 2 + 1
IF( UPPER ) THEN
DO 300 J = 1, N
CALL DLARNV( 2, ISEED, J, A( 1, J ) )
IF( J.NE.IY ) THEN
A( J, J ) = SIGN( TWO, A( J, J ) )
ELSE
A( J, J ) = ZERO
END IF
300 CONTINUE
ELSE
DO 310 J = 1, N
CALL DLARNV( 2, ISEED, N-J+1, A( J, J ) )
IF( J.NE.IY ) THEN
A( J, J ) = SIGN( TWO, A( J, J ) )
ELSE
A( J, J ) = ZERO
END IF
310 CONTINUE
END IF
CALL DLARNV( 2, ISEED, N, B )
CALL DSCAL( N, TWO, B, 1 )
*
ELSE IF( IMAT.EQ.17 ) THEN
*
* Type 17: Make the offdiagonal elements large to cause overflow
* when adding a column of T. In the non-transposed case, the
* matrix is constructed to cause overflow when adding a column in
* every other step.
*
TSCAL = UNFL / ULP
TSCAL = ( ONE-ULP ) / TSCAL
DO 330 J = 1, N
DO 320 I = 1, N
A( I, J ) = 0.D0
320 CONTINUE
330 CONTINUE
TEXP = ONE
IF( UPPER ) THEN
DO 340 J = N, 2, -2
A( 1, J ) = -TSCAL / DBLE( N+1 )
A( J, J ) = ONE
B( J ) = TEXP*( ONE-ULP )
A( 1, J-1 ) = -( TSCAL / DBLE( N+1 ) ) / DBLE( N+2 )
A( J-1, J-1 ) = ONE
B( J-1 ) = TEXP*DBLE( N*N+N-1 )
TEXP = TEXP*2.D0
340 CONTINUE
B( 1 ) = ( DBLE( N+1 ) / DBLE( N+2 ) )*TSCAL
ELSE
DO 350 J = 1, N - 1, 2
A( N, J ) = -TSCAL / DBLE( N+1 )
A( J, J ) = ONE
B( J ) = TEXP*( ONE-ULP )
A( N, J+1 ) = -( TSCAL / DBLE( N+1 ) ) / DBLE( N+2 )
A( J+1, J+1 ) = ONE
B( J+1 ) = TEXP*DBLE( N*N+N-1 )
TEXP = TEXP*2.D0
350 CONTINUE
B( N ) = ( DBLE( N+1 ) / DBLE( N+2 ) )*TSCAL
END IF
*
ELSE IF( IMAT.EQ.18 ) THEN
*
* Type 18: Generate a unit triangular matrix with elements
* between -1 and 1, and make the right hand side large so that it
* requires scaling.
*
IF( UPPER ) THEN
DO 360 J = 1, N
CALL DLARNV( 2, ISEED, J-1, A( 1, J ) )
A( J, J ) = ZERO
360 CONTINUE
ELSE
DO 370 J = 1, N
IF( J.LT.N )
$ CALL DLARNV( 2, ISEED, N-J, A( J+1, J ) )
A( J, J ) = ZERO
370 CONTINUE
END IF
*
* Set the right hand side so that the largest value is BIGNUM.
*
CALL DLARNV( 2, ISEED, N, B )
IY = IDAMAX( N, B, 1 )
BNORM = ABS( B( IY ) )
BSCAL = BIGNUM / MAX( ONE, BNORM )
CALL DSCAL( N, BSCAL, B, 1 )
*
ELSE IF( IMAT.EQ.19 ) THEN
*
* Type 19: Generate a triangular matrix with elements between
* BIGNUM/(n-1) and BIGNUM so that at least one of the column
* norms will exceed BIGNUM.
* 1/3/91: DLATRS no longer can handle this case
*
TLEFT = BIGNUM / MAX( ONE, DBLE( N-1 ) )
TSCAL = BIGNUM*( DBLE( N-1 ) / MAX( ONE, DBLE( N ) ) )
IF( UPPER ) THEN
DO 390 J = 1, N
CALL DLARNV( 2, ISEED, J, A( 1, J ) )
DO 380 I = 1, J
A( I, J ) = SIGN( TLEFT, A( I, J ) ) + TSCAL*A( I, J )
380 CONTINUE
390 CONTINUE
ELSE
DO 410 J = 1, N
CALL DLARNV( 2, ISEED, N-J+1, A( J, J ) )
DO 400 I = J, N
A( I, J ) = SIGN( TLEFT, A( I, J ) ) + TSCAL*A( I, J )
400 CONTINUE
410 CONTINUE
END IF
CALL DLARNV( 2, ISEED, N, B )
CALL DSCAL( N, TWO, B, 1 )
END IF
*
* Flip the matrix if the transpose will be used.
*
IF( .NOT.LSAME( TRANS, 'N' ) ) THEN
IF( UPPER ) THEN
DO 420 J = 1, N / 2
CALL DSWAP( N-2*J+1, A( J, J ), LDA, A( J+1, N-J+1 ),
$ -1 )
420 CONTINUE
ELSE
DO 430 J = 1, N / 2
CALL DSWAP( N-2*J+1, A( J, J ), 1, A( N-J+1, J+1 ),
$ -LDA )
430 CONTINUE
END IF
END IF
*
RETURN
*
* End of DLATTR
*
END
SUBROUTINE DLAVSP( UPLO, TRANS, DIAG, N, NRHS, A, IPIV, B, LDB,
$ INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION A( * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* DLAVSP performs one of the matrix-vector operations
* x := A*x or x := A'*x,
* where x is an N element vector and A is one of the factors
* from the block U*D*U' or L*D*L' factorization computed by DSPTRF.
*
* If TRANS = 'N', multiplies by U or U * D (or L or L * D)
* If TRANS = 'T', multiplies by U' or D * U' (or L' or D * L' )
* If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L' )
*
* Arguments
* ==========
*
* UPLO (input) CHARACTER*1
* Specifies whether the factor stored in A is upper or lower
* triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the operation to be performed:
* = 'N': x := A*x
* = 'T': x := A'*x
* = 'C': x := A'*x
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the diagonal blocks are unit
* matrices. If the diagonal blocks are assumed to be unit,
* then A = U or A = L, otherwise A = U*D or A = L*D.
* = 'U': Diagonal blocks are assumed to be unit matrices.
* = 'N': Diagonal blocks are assumed to be non-unit matrices.
*
* N (input) INTEGER
* The number of rows and columns of the matrix A. N >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of vectors
* x to be multiplied by A. NRHS >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The block diagonal matrix D and the multipliers used to
* obtain the factor U or L, stored as a packed triangular
* matrix as computed by DSPTRF.
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices from DSPTRF.
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, B contains NRHS vectors of length N.
* On exit, B is overwritten with the product A * B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT
INTEGER J, K, KC, KCNEXT, KP
DOUBLE PRECISION D11, D12, D21, D22, T1, T2
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DGEMV, DGER, DSCAL, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* 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( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAVSP ', -INFO )
RETURN
END IF
*
* Quick return if possible.
*
IF( N.EQ.0 )
$ RETURN
*
NOUNIT = LSAME( DIAG, 'N' )
*------------------------------------------
*
* Compute B := A * B (No transpose)
*
*------------------------------------------
IF( LSAME( TRANS, 'N' ) ) THEN
*
* Compute B := U*B
* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Loop forward applying the transformations.
*
K = 1
KC = 1
10 CONTINUE
IF( K.GT.N )
$ GO TO 30
*
* 1 x 1 pivot block
*
IF( IPIV( K ).GT.0 ) THEN
*
* Multiply by the diagonal element if forming U * D.
*
IF( NOUNIT )
$ CALL DSCAL( NRHS, A( KC+K-1 ), B( K, 1 ), LDB )
*
* Multiply by P(K) * inv(U(K)) if K > 1.
*
IF( K.GT.1 ) THEN
*
* Apply the transformation.
*
CALL DGER( K-1, NRHS, ONE, A( KC ), 1, B( K, 1 ), LDB,
$ B( 1, 1 ), LDB )
*
* Interchange if P(K) != I.
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
END IF
KC = KC + K
K = K + 1
ELSE
*
* 2 x 2 pivot block
*
KCNEXT = KC + K
*
* Multiply by the diagonal block if forming U * D.
*
IF( NOUNIT ) THEN
D11 = A( KCNEXT-1 )
D22 = A( KCNEXT+K )
D12 = A( KCNEXT+K-1 )
D21 = D12
DO 20 J = 1, NRHS
T1 = B( K, J )
T2 = B( K+1, J )
B( K, J ) = D11*T1 + D12*T2
B( K+1, J ) = D21*T1 + D22*T2
20 CONTINUE
END IF
*
* Multiply by P(K) * inv(U(K)) if K > 1.
*
IF( K.GT.1 ) THEN
*
* Apply the transformations.
*
CALL DGER( K-1, NRHS, ONE, A( KC ), 1, B( K, 1 ), LDB,
$ B( 1, 1 ), LDB )
CALL DGER( K-1, NRHS, ONE, A( KCNEXT ), 1,
$ B( K+1, 1 ), LDB, B( 1, 1 ), LDB )
*
* Interchange if P(K) != I.
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
END IF
KC = KCNEXT + K + 1
K = K + 2
END IF
GO TO 10
30 CONTINUE
*
* Compute B := L*B
* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) .
*
ELSE
*
* Loop backward applying the transformations to B.
*
K = N
KC = N*( N+1 ) / 2 + 1
40 CONTINUE
IF( K.LT.1 )
$ GO TO 60
KC = KC - ( N-K+1 )
*
* Test the pivot index. If greater than zero, a 1 x 1
* pivot was used, otherwise a 2 x 2 pivot was used.
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 pivot block:
*
* Multiply by the diagonal element if forming L * D.
*
IF( NOUNIT )
$ CALL DSCAL( NRHS, A( KC ), B( K, 1 ), LDB )
*
* Multiply by P(K) * inv(L(K)) if K < N.
*
IF( K.NE.N ) THEN
KP = IPIV( K )
*
* Apply the transformation.
*
CALL DGER( N-K, NRHS, ONE, A( KC+1 ), 1, B( K, 1 ),
$ LDB, B( K+1, 1 ), LDB )
*
* Interchange if a permutation was applied at the
* K-th step of the factorization.
*
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
END IF
K = K - 1
*
ELSE
*
* 2 x 2 pivot block:
*
KCNEXT = KC - ( N-K+2 )
*
* Multiply by the diagonal block if forming L * D.
*
IF( NOUNIT ) THEN
D11 = A( KCNEXT )
D22 = A( KC )
D21 = A( KCNEXT+1 )
D12 = D21
DO 50 J = 1, NRHS
T1 = B( K-1, J )
T2 = B( K, J )
B( K-1, J ) = D11*T1 + D12*T2
B( K, J ) = D21*T1 + D22*T2
50 CONTINUE
END IF
*
* Multiply by P(K) * inv(L(K)) if K < N.
*
IF( K.NE.N ) THEN
*
* Apply the transformation.
*
CALL DGER( N-K, NRHS, ONE, A( KC+1 ), 1, B( K, 1 ),
$ LDB, B( K+1, 1 ), LDB )
CALL DGER( N-K, NRHS, ONE, A( KCNEXT+2 ), 1,
$ B( K-1, 1 ), LDB, B( K+1, 1 ), LDB )
*
* Interchange if a permutation was applied at the
* K-th step of the factorization.
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
END IF
KC = KCNEXT
K = K - 2
END IF
GO TO 40
60 CONTINUE
END IF
*----------------------------------------
*
* Compute B := A' * B (transpose)
*
*----------------------------------------
ELSE
*
* Form B := U'*B
* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
* and U' = inv(U'(1))*P(1)* ... *inv(U'(m))*P(m)
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Loop backward applying the transformations.
*
K = N
KC = N*( N+1 ) / 2 + 1
70 CONTINUE
IF( K.LT.1 )
$ GO TO 90
KC = KC - K
*
* 1 x 1 pivot block.
*
IF( IPIV( K ).GT.0 ) THEN
IF( K.GT.1 ) THEN
*
* Interchange if P(K) != I.
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
* Apply the transformation
*
CALL DGEMV( 'Transpose', K-1, NRHS, ONE, B, LDB,
$ A( KC ), 1, ONE, B( K, 1 ), LDB )
END IF
IF( NOUNIT )
$ CALL DSCAL( NRHS, A( KC+K-1 ), B( K, 1 ), LDB )
K = K - 1
*
* 2 x 2 pivot block.
*
ELSE
KCNEXT = KC - ( K-1 )
IF( K.GT.2 ) THEN
*
* Interchange if P(K) != I.
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K-1 )
$ CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ),
$ LDB )
*
* Apply the transformations
*
CALL DGEMV( 'Transpose', K-2, NRHS, ONE, B, LDB,
$ A( KC ), 1, ONE, B( K, 1 ), LDB )
CALL DGEMV( 'Transpose', K-2, NRHS, ONE, B, LDB,
$ A( KCNEXT ), 1, ONE, B( K-1, 1 ), LDB )
END IF
*
* Multiply by the diagonal block if non-unit.
*
IF( NOUNIT ) THEN
D11 = A( KC-1 )
D22 = A( KC+K-1 )
D12 = A( KC+K-2 )
D21 = D12
DO 80 J = 1, NRHS
T1 = B( K-1, J )
T2 = B( K, J )
B( K-1, J ) = D11*T1 + D12*T2
B( K, J ) = D21*T1 + D22*T2
80 CONTINUE
END IF
KC = KCNEXT
K = K - 2
END IF
GO TO 70
90 CONTINUE
*
* Form B := L'*B
* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m))
* and L' = inv(L(m))*P(m)* ... *inv(L(1))*P(1)
*
ELSE
*
* Loop forward applying the L-transformations.
*
K = 1
KC = 1
100 CONTINUE
IF( K.GT.N )
$ GO TO 120
*
* 1 x 1 pivot block
*
IF( IPIV( K ).GT.0 ) THEN
IF( K.LT.N ) THEN
*
* Interchange if P(K) != I.
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
* Apply the transformation
*
CALL DGEMV( 'Transpose', N-K, NRHS, ONE, B( K+1, 1 ),
$ LDB, A( KC+1 ), 1, ONE, B( K, 1 ), LDB )
END IF
IF( NOUNIT )
$ CALL DSCAL( NRHS, A( KC ), B( K, 1 ), LDB )
KC = KC + N - K + 1
K = K + 1
*
* 2 x 2 pivot block.
*
ELSE
KCNEXT = KC + N - K + 1
IF( K.LT.N-1 ) THEN
*
* Interchange if P(K) != I.
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K+1 )
$ CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ),
$ LDB )
*
* Apply the transformation
*
CALL DGEMV( 'Transpose', N-K-1, NRHS, ONE,
$ B( K+2, 1 ), LDB, A( KCNEXT+1 ), 1, ONE,
$ B( K+1, 1 ), LDB )
CALL DGEMV( 'Transpose', N-K-1, NRHS, ONE,
$ B( K+2, 1 ), LDB, A( KC+2 ), 1, ONE,
$ B( K, 1 ), LDB )
END IF
*
* Multiply by the diagonal block if non-unit.
*
IF( NOUNIT ) THEN
D11 = A( KC )
D22 = A( KCNEXT )
D21 = A( KC+1 )
D12 = D21
DO 110 J = 1, NRHS
T1 = B( K, J )
T2 = B( K+1, J )
B( K, J ) = D11*T1 + D12*T2
B( K+1, J ) = D21*T1 + D22*T2
110 CONTINUE
END IF
KC = KCNEXT + ( N-K )
K = K + 2
END IF
GO TO 100
120 CONTINUE
END IF
*
END IF
RETURN
*
* End of DLAVSP
*
END
SUBROUTINE DLAVSY( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B,
$ LDB, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* DLAVSY performs one of the matrix-vector operations
* x := A*x or x := A'*x,
* where x is an N element vector and A is one of the factors
* from the block U*D*U' or L*D*L' factorization computed by DSYTRF.
*
* If TRANS = 'N', multiplies by U or U * D (or L or L * D)
* If TRANS = 'T', multiplies by U' or D * U' (or L' or D * L')
* If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L')
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the factor stored in A is upper or lower
* triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the operation to be performed:
* = 'N': x := A*x
* = 'T': x := A'*x
* = 'C': x := A'*x
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the diagonal blocks are unit
* matrices. If the diagonal blocks are assumed to be unit,
* then A = U or A = L, otherwise A = U*D or A = L*D.
* = 'U': Diagonal blocks are assumed to be unit matrices.
* = 'N': Diagonal blocks are assumed to be non-unit matrices.
*
* N (input) INTEGER
* The number of rows and columns of the matrix A. N >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of vectors
* x to be multiplied by A. NRHS >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The block diagonal matrix D and the multipliers used to
* obtain the factor U or L as computed by DSYTRF.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices from DSYTRF.
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, B contains NRHS vectors of length N.
* On exit, B is overwritten with the product A * B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT
INTEGER J, K, KP
DOUBLE PRECISION D11, D12, D21, D22, T1, T2
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DGEMV, DGER, DSCAL, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* 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( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAVSY ', -INFO )
RETURN
END IF
*
* Quick return if possible.
*
IF( N.EQ.0 )
$ RETURN
*
NOUNIT = LSAME( DIAG, 'N' )
*------------------------------------------
*
* Compute B := A * B (No transpose)
*
*------------------------------------------
IF( LSAME( TRANS, 'N' ) ) THEN
*
* Compute B := U*B
* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Loop forward applying the transformations.
*
K = 1
10 CONTINUE
IF( K.GT.N )
$ GO TO 30
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 pivot block
*
* Multiply by the diagonal element if forming U * D.
*
IF( NOUNIT )
$ CALL DSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
*
* Multiply by P(K) * inv(U(K)) if K > 1.
*
IF( K.GT.1 ) THEN
*
* Apply the transformation.
*
CALL DGER( K-1, NRHS, ONE, A( 1, K ), 1, B( K, 1 ),
$ LDB, B( 1, 1 ), LDB )
*
* Interchange if P(K) .ne. I.
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
END IF
K = K + 1
ELSE
*
* 2 x 2 pivot block
*
* Multiply by the diagonal block if forming U * D.
*
IF( NOUNIT ) THEN
D11 = A( K, K )
D22 = A( K+1, K+1 )
D12 = A( K, K+1 )
D21 = D12
DO 20 J = 1, NRHS
T1 = B( K, J )
T2 = B( K+1, J )
B( K, J ) = D11*T1 + D12*T2
B( K+1, J ) = D21*T1 + D22*T2
20 CONTINUE
END IF
*
* Multiply by P(K) * inv(U(K)) if K > 1.
*
IF( K.GT.1 ) THEN
*
* Apply the transformations.
*
CALL DGER( K-1, NRHS, ONE, A( 1, K ), 1, B( K, 1 ),
$ LDB, B( 1, 1 ), LDB )
CALL DGER( K-1, NRHS, ONE, A( 1, K+1 ), 1,
$ B( K+1, 1 ), LDB, B( 1, 1 ), LDB )
*
* Interchange if P(K) .ne. I.
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
END IF
K = K + 2
END IF
GO TO 10
30 CONTINUE
*
* Compute B := L*B
* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) .
*
ELSE
*
* Loop backward applying the transformations to B.
*
K = N
40 CONTINUE
IF( K.LT.1 )
$ GO TO 60
*
* Test the pivot index. If greater than zero, a 1 x 1
* pivot was used, otherwise a 2 x 2 pivot was used.
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 pivot block:
*
* Multiply by the diagonal element if forming L * D.
*
IF( NOUNIT )
$ CALL DSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
*
* Multiply by P(K) * inv(L(K)) if K < N.
*
IF( K.NE.N ) THEN
KP = IPIV( K )
*
* Apply the transformation.
*
CALL DGER( N-K, NRHS, ONE, A( K+1, K ), 1, B( K, 1 ),
$ LDB, B( K+1, 1 ), LDB )
*
* Interchange if a permutation was applied at the
* K-th step of the factorization.
*
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
END IF
K = K - 1
*
ELSE
*
* 2 x 2 pivot block:
*
* Multiply by the diagonal block if forming L * D.
*
IF( NOUNIT ) THEN
D11 = A( K-1, K-1 )
D22 = A( K, K )
D21 = A( K, K-1 )
D12 = D21
DO 50 J = 1, NRHS
T1 = B( K-1, J )
T2 = B( K, J )
B( K-1, J ) = D11*T1 + D12*T2
B( K, J ) = D21*T1 + D22*T2
50 CONTINUE
END IF
*
* Multiply by P(K) * inv(L(K)) if K < N.
*
IF( K.NE.N ) THEN
*
* Apply the transformation.
*
CALL DGER( N-K, NRHS, ONE, A( K+1, K ), 1, B( K, 1 ),
$ LDB, B( K+1, 1 ), LDB )
CALL DGER( N-K, NRHS, ONE, A( K+1, K-1 ), 1,
$ B( K-1, 1 ), LDB, B( K+1, 1 ), LDB )
*
* Interchange if a permutation was applied at the
* K-th step of the factorization.
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
END IF
K = K - 2
END IF
GO TO 40
60 CONTINUE
END IF
*----------------------------------------
*
* Compute B := A' * B (transpose)
*
*----------------------------------------
ELSE
*
* Form B := U'*B
* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
* and U' = inv(U'(1))*P(1)* ... *inv(U'(m))*P(m)
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Loop backward applying the transformations.
*
K = N
70 CONTINUE
IF( K.LT.1 )
$ GO TO 90
*
* 1 x 1 pivot block.
*
IF( IPIV( K ).GT.0 ) THEN
IF( K.GT.1 ) THEN
*
* Interchange if P(K) .ne. I.
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
* Apply the transformation
*
CALL DGEMV( 'Transpose', K-1, NRHS, ONE, B, LDB,
$ A( 1, K ), 1, ONE, B( K, 1 ), LDB )
END IF
IF( NOUNIT )
$ CALL DSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
K = K - 1
*
* 2 x 2 pivot block.
*
ELSE
IF( K.GT.2 ) THEN
*
* Interchange if P(K) .ne. I.
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K-1 )
$ CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ),
$ LDB )
*
* Apply the transformations
*
CALL DGEMV( 'Transpose', K-2, NRHS, ONE, B, LDB,
$ A( 1, K ), 1, ONE, B( K, 1 ), LDB )
CALL DGEMV( 'Transpose', K-2, NRHS, ONE, B, LDB,
$ A( 1, K-1 ), 1, ONE, B( K-1, 1 ), LDB )
END IF
*
* Multiply by the diagonal block if non-unit.
*
IF( NOUNIT ) THEN
D11 = A( K-1, K-1 )
D22 = A( K, K )
D12 = A( K-1, K )
D21 = D12
DO 80 J = 1, NRHS
T1 = B( K-1, J )
T2 = B( K, J )
B( K-1, J ) = D11*T1 + D12*T2
B( K, J ) = D21*T1 + D22*T2
80 CONTINUE
END IF
K = K - 2
END IF
GO TO 70
90 CONTINUE
*
* Form B := L'*B
* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m))
* and L' = inv(L'(m))*P(m)* ... *inv(L'(1))*P(1)
*
ELSE
*
* Loop forward applying the L-transformations.
*
K = 1
100 CONTINUE
IF( K.GT.N )
$ GO TO 120
*
* 1 x 1 pivot block
*
IF( IPIV( K ).GT.0 ) THEN
IF( K.LT.N ) THEN
*
* Interchange if P(K) .ne. I.
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
* Apply the transformation
*
CALL DGEMV( 'Transpose', N-K, NRHS, ONE, B( K+1, 1 ),
$ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB )
END IF
IF( NOUNIT )
$ CALL DSCAL( NRHS, A( K, K ), B( K, 1 ), LDB )
K = K + 1
*
* 2 x 2 pivot block.
*
ELSE
IF( K.LT.N-1 ) THEN
*
* Interchange if P(K) .ne. I.
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K+1 )
$ CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ),
$ LDB )
*
* Apply the transformation
*
CALL DGEMV( 'Transpose', N-K-1, NRHS, ONE,
$ B( K+2, 1 ), LDB, A( K+2, K+1 ), 1, ONE,
$ B( K+1, 1 ), LDB )
CALL DGEMV( 'Transpose', N-K-1, NRHS, ONE,
$ B( K+2, 1 ), LDB, A( K+2, K ), 1, ONE,
$ B( K, 1 ), LDB )
END IF
*
* Multiply by the diagonal block if non-unit.
*
IF( NOUNIT ) THEN
D11 = A( K, K )
D22 = A( K+1, K+1 )
D21 = A( K+1, K )
D12 = D21
DO 110 J = 1, NRHS
T1 = B( K, J )
T2 = B( K+1, J )
B( K, J ) = D11*T1 + D12*T2
B( K+1, J ) = D21*T1 + D22*T2
110 CONTINUE
END IF
K = K + 2
END IF
GO TO 100
120 CONTINUE
END IF
*
END IF
RETURN
*
* End of DLAVSY
*
END
SUBROUTINE DLQT01( M, N, A, AF, Q, L, LDA, TAU, WORK, LWORK,
$ RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), L( LDA, * ),
$ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* DLQT01 tests DGELQF, which computes the LQ factorization of an m-by-n
* matrix A, and partially tests DORGLQ which forms the n-by-n
* orthogonal matrix Q.
*
* DLQT01 compares L with A*Q', and checks that Q is orthogonal.
*
* 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) DOUBLE PRECISION array, dimension (LDA,N)
* The m-by-n matrix A.
*
* AF (output) DOUBLE PRECISION array, dimension (LDA,N)
* Details of the LQ factorization of A, as returned by DGELQF.
* See DGELQF for further details.
*
* Q (output) DOUBLE PRECISION array, dimension (LDA,N)
* The n-by-n orthogonal matrix Q.
*
* L (workspace) DOUBLE PRECISION array, dimension (LDA,max(M,N))
*
* LDA (input) INTEGER
* The leading dimension of the arrays A, AF, Q and L.
* LDA >= max(M,N).
*
* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
* The scalar factors of the elementary reflectors, as returned
* by DGELQF.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (max(M,N))
*
* RESULT (output) DOUBLE PRECISION array, dimension (2)
* The test ratios:
* RESULT(1) = norm( L - A*Q' ) / ( N * norm(A) * EPS )
* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION ROGUE
PARAMETER ( ROGUE = -1.0D+10 )
* ..
* .. Local Scalars ..
INTEGER INFO, MINMN
DOUBLE PRECISION ANORM, EPS, RESID
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
EXTERNAL DLAMCH, DLANGE, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DGELQF, DGEMM, DLACPY, DLASET, DORGLQ, DSYRK
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Scalars in Common ..
CHARACTER*6 SRNAMT
* ..
* .. Common blocks ..
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
MINMN = MIN( M, N )
EPS = DLAMCH( 'Epsilon' )
*
* Copy the matrix A to the array AF.
*
CALL DLACPY( 'Full', M, N, A, LDA, AF, LDA )
*
* Factorize the matrix A in the array AF.
*
SRNAMT = 'DGELQF'
CALL DGELQF( M, N, AF, LDA, TAU, WORK, LWORK, INFO )
*
* Copy details of Q
*
CALL DLASET( 'Full', N, N, ROGUE, ROGUE, Q, LDA )
IF( N.GT.1 )
$ CALL DLACPY( 'Upper', M, N-1, AF( 1, 2 ), LDA, Q( 1, 2 ), LDA )
*
* Generate the n-by-n matrix Q
*
SRNAMT = 'DORGLQ'
CALL DORGLQ( N, N, MINMN, Q, LDA, TAU, WORK, LWORK, INFO )
*
* Copy L
*
CALL DLASET( 'Full', M, N, ZERO, ZERO, L, LDA )
CALL DLACPY( 'Lower', M, N, AF, LDA, L, LDA )
*
* Compute L - A*Q'
*
CALL DGEMM( 'No transpose', 'Transpose', M, N, N, -ONE, A, LDA, Q,
$ LDA, ONE, L, LDA )
*
* Compute norm( L - Q'*A ) / ( N * norm(A) * EPS ) .
*
ANORM = DLANGE( '1', M, N, A, LDA, RWORK )
RESID = DLANGE( '1', M, N, L, LDA, RWORK )
IF( ANORM.GT.ZERO ) THEN
RESULT( 1 ) = ( ( RESID / DBLE( MAX( 1, N ) ) ) / ANORM ) / EPS
ELSE
RESULT( 1 ) = ZERO
END IF
*
* Compute I - Q*Q'
*
CALL DLASET( 'Full', N, N, ZERO, ONE, L, LDA )
CALL DSYRK( 'Upper', 'No transpose', N, N, -ONE, Q, LDA, ONE, L,
$ LDA )
*
* Compute norm( I - Q*Q' ) / ( N * EPS ) .
*
RESID = DLANSY( '1', 'Upper', N, L, LDA, RWORK )
*
RESULT( 2 ) = ( RESID / DBLE( MAX( 1, N ) ) ) / EPS
*
RETURN
*
* End of DLQT01
*
END
SUBROUTINE DLQT02( M, N, K, A, AF, Q, L, LDA, TAU, WORK, LWORK,
$ RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), L( LDA, * ),
$ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* DLQT02 tests DORGLQ, which generates an m-by-n matrix Q with
* orthonornmal rows that is defined as the product of k elementary
* reflectors.
*
* Given the LQ factorization of an m-by-n matrix A, DLQT02 generates
* the orthogonal matrix Q defined by the factorization of the first k
* rows of A; it compares L(1:k,1:m) with A(1:k,1:n)*Q(1:m,1:n)', and
* checks that the rows of Q are orthonormal.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix Q to be generated. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix Q to be generated.
* N >= M >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* matrix Q. M >= K >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The m-by-n matrix A which was factorized by DLQT01.
*
* AF (input) DOUBLE PRECISION array, dimension (LDA,N)
* Details of the LQ factorization of A, as returned by DGELQF.
* See DGELQF for further details.
*
* Q (workspace) DOUBLE PRECISION array, dimension (LDA,N)
*
* L (workspace) DOUBLE PRECISION array, dimension (LDA,M)
*
* LDA (input) INTEGER
* The leading dimension of the arrays A, AF, Q and L. LDA >= N.
*
* TAU (input) DOUBLE PRECISION array, dimension (M)
* The scalar factors of the elementary reflectors corresponding
* to the LQ factorization in AF.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (M)
*
* RESULT (output) DOUBLE PRECISION array, dimension (2)
* The test ratios:
* RESULT(1) = norm( L - A*Q' ) / ( N * norm(A) * EPS )
* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION ROGUE
PARAMETER ( ROGUE = -1.0D+10 )
* ..
* .. Local Scalars ..
INTEGER INFO
DOUBLE PRECISION ANORM, EPS, RESID
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
EXTERNAL DLAMCH, DLANGE, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLACPY, DLASET, DORGLQ, DSYRK
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX
* ..
* .. Scalars in Common ..
CHARACTER*6 SRNAMT
* ..
* .. Common blocks ..
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
EPS = DLAMCH( 'Epsilon' )
*
* Copy the first k rows of the factorization to the array Q
*
CALL DLASET( 'Full', M, N, ROGUE, ROGUE, Q, LDA )
CALL DLACPY( 'Upper', K, N-1, AF( 1, 2 ), LDA, Q( 1, 2 ), LDA )
*
* Generate the first n columns of the matrix Q
*
SRNAMT = 'DORGLQ'
CALL DORGLQ( M, N, K, Q, LDA, TAU, WORK, LWORK, INFO )
*
* Copy L(1:k,1:m)
*
CALL DLASET( 'Full', K, M, ZERO, ZERO, L, LDA )
CALL DLACPY( 'Lower', K, M, AF, LDA, L, LDA )
*
* Compute L(1:k,1:m) - A(1:k,1:n) * Q(1:m,1:n)'
*
CALL DGEMM( 'No transpose', 'Transpose', K, M, N, -ONE, A, LDA, Q,
$ LDA, ONE, L, LDA )
*
* Compute norm( L - A*Q' ) / ( N * norm(A) * EPS ) .
*
ANORM = DLANGE( '1', K, N, A, LDA, RWORK )
RESID = DLANGE( '1', K, M, L, LDA, RWORK )
IF( ANORM.GT.ZERO ) THEN
RESULT( 1 ) = ( ( RESID / DBLE( MAX( 1, N ) ) ) / ANORM ) / EPS
ELSE
RESULT( 1 ) = ZERO
END IF
*
* Compute I - Q*Q'
*
CALL DLASET( 'Full', M, M, ZERO, ONE, L, LDA )
CALL DSYRK( 'Upper', 'No transpose', M, N, -ONE, Q, LDA, ONE, L,
$ LDA )
*
* Compute norm( I - Q*Q' ) / ( N * EPS ) .
*
RESID = DLANSY( '1', 'Upper', M, L, LDA, RWORK )
*
RESULT( 2 ) = ( RESID / DBLE( MAX( 1, N ) ) ) / EPS
*
RETURN
*
* End of DLQT02
*
END
SUBROUTINE DLQT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK,
$ RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AF( LDA, * ), C( LDA, * ), CC( LDA, * ),
$ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* DLQT03 tests DORMLQ, which computes Q*C, Q'*C, C*Q or C*Q'.
*
* DLQT03 compares the results of a call to DORMLQ with the results of
* forming Q explicitly by a call to DORGLQ and then performing matrix
* multiplication by a call to DGEMM.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows or columns of the matrix C; C is n-by-m if
* Q is applied from the left, or m-by-n if Q is applied from
* the right. M >= 0.
*
* N (input) INTEGER
* The order of the orthogonal matrix Q. N >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* orthogonal matrix Q. N >= K >= 0.
*
* AF (input) DOUBLE PRECISION array, dimension (LDA,N)
* Details of the LQ factorization of an m-by-n matrix, as
* returned by DGELQF. See SGELQF for further details.
*
* C (workspace) DOUBLE PRECISION array, dimension (LDA,N)
*
* CC (workspace) DOUBLE PRECISION array, dimension (LDA,N)
*
* Q (workspace) DOUBLE PRECISION array, dimension (LDA,N)
*
* LDA (input) INTEGER
* The leading dimension of the arrays AF, C, CC, and Q.
*
* TAU (input) DOUBLE PRECISION array, dimension (min(M,N))
* The scalar factors of the elementary reflectors corresponding
* to the LQ factorization in AF.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of WORK. LWORK must be at least M, and should be
* M*NB, where NB is the blocksize for this environment.
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (M)
*
* RESULT (output) DOUBLE PRECISION array, dimension (4)
* The test ratios compare two techniques for multiplying a
* random matrix C by an n-by-n orthogonal matrix Q.
* RESULT(1) = norm( Q*C - Q*C ) / ( N * norm(C) * EPS )
* RESULT(2) = norm( C*Q - C*Q ) / ( N * norm(C) * EPS )
* RESULT(3) = norm( Q'*C - Q'*C )/ ( N * norm(C) * EPS )
* RESULT(4) = norm( C*Q' - C*Q' )/ ( N * norm(C) * EPS )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION ROGUE
PARAMETER ( ROGUE = -1.0D+10 )
* ..
* .. Local Scalars ..
CHARACTER SIDE, TRANS
INTEGER INFO, ISIDE, ITRANS, J, MC, NC
DOUBLE PRECISION CNORM, EPS, RESID
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL LSAME, DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLACPY, DLARNV, DLASET, DORGLQ, DORMLQ
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 )
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX
* ..
* .. Scalars in Common ..
CHARACTER*6 SRNAMT
* ..
* .. Common blocks ..
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEED / 1988, 1989, 1990, 1991 /
* ..
* .. Executable Statements ..
*
EPS = DLAMCH( 'Epsilon' )
*
* Copy the first k rows of the factorization to the array Q
*
CALL DLASET( 'Full', N, N, ROGUE, ROGUE, Q, LDA )
CALL DLACPY( 'Upper', K, N-1, AF( 1, 2 ), LDA, Q( 1, 2 ), LDA )
*
* Generate the n-by-n matrix Q
*
SRNAMT = 'DORGLQ'
CALL DORGLQ( N, N, K, Q, LDA, TAU, WORK, LWORK, INFO )
*
DO 30 ISIDE = 1, 2
IF( ISIDE.EQ.1 ) THEN
SIDE = 'L'
MC = N
NC = M
ELSE
SIDE = 'R'
MC = M
NC = N
END IF
*
* Generate MC by NC matrix C
*
DO 10 J = 1, NC
CALL DLARNV( 2, ISEED, MC, C( 1, J ) )
10 CONTINUE
CNORM = DLANGE( '1', MC, NC, C, LDA, RWORK )
IF( CNORM.EQ.0.0D0 )
$ CNORM = ONE
*
DO 20 ITRANS = 1, 2
IF( ITRANS.EQ.1 ) THEN
TRANS = 'N'
ELSE
TRANS = 'T'
END IF
*
* Copy C
*
CALL DLACPY( 'Full', MC, NC, C, LDA, CC, LDA )
*
* Apply Q or Q' to C
*
SRNAMT = 'DORMLQ'
CALL DORMLQ( SIDE, TRANS, MC, NC, K, AF, LDA, TAU, CC, LDA,
$ WORK, LWORK, INFO )
*
* Form explicit product and subtract
*
IF( LSAME( SIDE, 'L' ) ) THEN
CALL DGEMM( TRANS, 'No transpose', MC, NC, MC, -ONE, Q,
$ LDA, C, LDA, ONE, CC, LDA )
ELSE
CALL DGEMM( 'No transpose', TRANS, MC, NC, NC, -ONE, C,
$ LDA, Q, LDA, ONE, CC, LDA )
END IF
*
* Compute error in the difference
*
RESID = DLANGE( '1', MC, NC, CC, LDA, RWORK )
RESULT( ( ISIDE-1 )*2+ITRANS ) = RESID /
$ ( DBLE( MAX( 1, N ) )*CNORM*EPS )
*
20 CONTINUE
30 CONTINUE
*
RETURN
*
* End of DLQT03
*
END
SUBROUTINE DPBT01( UPLO, N, KD, A, LDA, AFAC, LDAFAC, RWORK,
$ RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER KD, LDA, LDAFAC, N
DOUBLE PRECISION RESID
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), RWORK( * )
* ..
*
* Purpose
* =======
*
* DPBT01 reconstructs a symmetric positive definite band matrix A from
* its L*L' or U'*U factorization and computes the residual
* norm( L*L' - A ) / ( N * norm(A) * EPS ) or
* norm( U'*U - A ) / ( N * norm(A) * EPS ),
* where EPS is the machine epsilon, L' is the conjugate transpose of
* L, and U' is the conjugate transpose of U.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The number of rows and columns of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of super-diagonals of the matrix A if UPLO = 'U',
* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The original symmetric band matrix A. If UPLO = 'U', the
* upper triangular part of A is stored as a band matrix; if
* UPLO = 'L', the lower triangular part of A is stored. The
* columns of the appropriate triangle are stored in the columns
* of A and the diagonals of the triangle are stored in the rows
* of A. See DPBTRF for further details.
*
* LDA (input) INTEGER.
* The leading dimension of the array A. LDA >= max(1,KD+1).
*
* AFAC (input) DOUBLE PRECISION array, dimension (LDAFAC,N)
* The factored form of the matrix A. AFAC contains the factor
* L or U from the L*L' or U'*U factorization in band storage
* format, as computed by DPBTRF.
*
* LDAFAC (input) INTEGER
* The leading dimension of the array AFAC.
* LDAFAC >= max(1,KD+1).
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* RESID (output) DOUBLE PRECISION
* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS )
* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS )
*
* =====================================================================
*
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, K, KC, KLEN, ML, MU
DOUBLE PRECISION ANORM, EPS, T
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DDOT, DLAMCH, DLANSB
EXTERNAL LSAME, DDOT, DLAMCH, DLANSB
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, DSYR, DTRMV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0.
*
IF( N.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0.
*
EPS = DLAMCH( 'Epsilon' )
ANORM = DLANSB( '1', UPLO, N, KD, A, LDA, RWORK )
IF( ANORM.LE.ZERO ) THEN
RESID = ONE / EPS
RETURN
END IF
*
* Compute the product U'*U, overwriting U.
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 10 K = N, 1, -1
KC = MAX( 1, KD+2-K )
KLEN = KD + 1 - KC
*
* Compute the (K,K) element of the result.
*
T = DDOT( KLEN+1, AFAC( KC, K ), 1, AFAC( KC, K ), 1 )
AFAC( KD+1, K ) = T
*
* Compute the rest of column K.
*
IF( KLEN.GT.0 )
$ CALL DTRMV( 'Upper', 'Transpose', 'Non-unit', KLEN,
$ AFAC( KD+1, K-KLEN ), LDAFAC-1,
$ AFAC( KC, K ), 1 )
*
10 CONTINUE
*
* UPLO = 'L': Compute the product L*L', overwriting L.
*
ELSE
DO 20 K = N, 1, -1
KLEN = MIN( KD, N-K )
*
* Add a multiple of column K of the factor L to each of
* columns K+1 through N.
*
IF( KLEN.GT.0 )
$ CALL DSYR( 'Lower', KLEN, ONE, AFAC( 2, K ), 1,
$ AFAC( 1, K+1 ), LDAFAC-1 )
*
* Scale column K by the diagonal element.
*
T = AFAC( 1, K )
CALL DSCAL( KLEN+1, T, AFAC( 1, K ), 1 )
*
20 CONTINUE
END IF
*
* Compute the difference L*L' - A or U'*U - A.
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 40 J = 1, N
MU = MAX( 1, KD+2-J )
DO 30 I = MU, KD + 1
AFAC( I, J ) = AFAC( I, J ) - A( I, J )
30 CONTINUE
40 CONTINUE
ELSE
DO 60 J = 1, N
ML = MIN( KD+1, N-J+1 )
DO 50 I = 1, ML
AFAC( I, J ) = AFAC( I, J ) - A( I, J )
50 CONTINUE
60 CONTINUE
END IF
*
* Compute norm( L*L' - A ) / ( N * norm(A) * EPS )
*
RESID = DLANSB( 'I', UPLO, N, KD, AFAC, LDAFAC, RWORK )
*
RESID = ( ( RESID / DBLE( N ) ) / ANORM ) / EPS
*
RETURN
*
* End of DPBT01
*
END
SUBROUTINE DPBT02( UPLO, N, KD, NRHS, A, LDA, X, LDX, B, LDB,
$ RWORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER KD, LDA, LDB, LDX, N, NRHS
DOUBLE PRECISION RESID
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), RWORK( * ),
$ X( LDX, * )
* ..
*
* Purpose
* =======
*
* DPBT02 computes the residual for a solution of a symmetric banded
* system of equations A*x = b:
* RESID = norm( B - A*X ) / ( norm(A) * norm(X) * EPS)
* where EPS is the machine precision.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The number of rows and columns of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of super-diagonals of the matrix A if UPLO = 'U',
* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The original symmetric band matrix A. If UPLO = 'U', the
* upper triangular part of A is stored as a band matrix; if
* UPLO = 'L', the lower triangular part of A is stored. The
* columns of the appropriate triangle are stored in the columns
* of A and the diagonals of the triangle are stored in the rows
* of A. See DPBTRF for further details.
*
* LDA (input) INTEGER.
* The leading dimension of the array A. LDA >= max(1,KD+1).
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The computed solution vectors for the system of linear
* equations.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the right hand side vectors for the system of
* linear equations.
* On exit, B is overwritten with the difference B - A*X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* RESID (output) DOUBLE PRECISION
* The maximum over the number of right hand sides of
* norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER J
DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
* ..
* .. External Functions ..
DOUBLE PRECISION DASUM, DLAMCH, DLANSB
EXTERNAL DASUM, DLAMCH, DLANSB
* ..
* .. External Subroutines ..
EXTERNAL DSBMV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0.
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0.
*
EPS = DLAMCH( 'Epsilon' )
ANORM = DLANSB( '1', UPLO, N, KD, A, LDA, RWORK )
IF( ANORM.LE.ZERO ) THEN
RESID = ONE / EPS
RETURN
END IF
*
* Compute B - A*X
*
DO 10 J = 1, NRHS
CALL DSBMV( UPLO, N, KD, -ONE, A, LDA, X( 1, J ), 1, ONE,
$ B( 1, J ), 1 )
10 CONTINUE
*
* Compute the maximum over the number of right hand sides of
* norm( B - A*X ) / ( norm(A) * norm(X) * EPS )
*
RESID = ZERO
DO 20 J = 1, NRHS
BNORM = DASUM( N, B( 1, J ), 1 )
XNORM = DASUM( N, X( 1, J ), 1 )
IF( XNORM.LE.ZERO ) THEN
RESID = ONE / EPS
ELSE
RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) / EPS )
END IF
20 CONTINUE
*
RETURN
*
* End of DPBT02
*
END
SUBROUTINE DPBT05( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX,
$ XACT, LDXACT, FERR, BERR, RESLTS )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER KD, LDAB, LDB, LDX, LDXACT, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ), BERR( * ),
$ FERR( * ), RESLTS( * ), X( LDX, * ),
$ XACT( LDXACT, * )
* ..
*
* Purpose
* =======
*
* DPBT05 tests the error bounds from iterative refinement for the
* computed solution to a system of equations A*X = B, where A is a
* symmetric band matrix.
*
* RESLTS(1) = test of the error bound
* = norm(X - XACT) / ( norm(X) * FERR )
*
* A large value is returned if this ratio is not less than one.
*
* RESLTS(2) = residual from the iterative refinement routine
* = the maximum of BERR / ( NZ*EPS + (*) ), where
* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
* and NZ = max. number of nonzeros in any row of A, plus 1
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The number of rows of the matrices X, B, and XACT, and the
* order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of super-diagonals of the matrix A if UPLO = 'U',
* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
*
* NRHS (input) INTEGER
* The number of columns of the matrices X, B, and XACT.
* NRHS >= 0.
*
* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
* The upper or lower triangle of the symmetric band matrix A,
* stored in the first KD+1 rows of the array. The j-th column
* of A is stored in the j-th column of the array AB as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The computed solution vectors. Each vector is stored as a
* column of the matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* XACT (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The exact solution vectors. Each vector is stored as a
* column of the matrix XACT.
*
* LDXACT (input) INTEGER
* The leading dimension of the array XACT. LDXACT >= max(1,N).
*
* FERR (input) DOUBLE PRECISION array, dimension (NRHS)
* The estimated forward error bounds for each solution vector
* X. If XTRUE is the true solution, FERR bounds the magnitude
* of the largest entry in (X - XTRUE) divided by the magnitude
* of the largest entry in X.
*
* BERR (input) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector (i.e., the smallest relative change in any entry of A
* or B that makes X an exact solution).
*
* RESLTS (output) DOUBLE PRECISION array, dimension (2)
* The maximum over the NRHS solution vectors of the ratios:
* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
* RESLTS(2) = BERR / ( NZ*EPS + (*) )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, IMAX, J, K, NZ
DOUBLE PRECISION AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, IDAMAX, DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0.
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESLTS( 1 ) = ZERO
RESLTS( 2 ) = ZERO
RETURN
END IF
*
EPS = DLAMCH( 'Epsilon' )
UNFL = DLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
UPPER = LSAME( UPLO, 'U' )
NZ = 2*MAX( KD, N-1 ) + 1
*
* Test 1: Compute the maximum of
* norm(X - XACT) / ( norm(X) * FERR )
* over all the vectors X and XACT using the infinity-norm.
*
ERRBND = ZERO
DO 30 J = 1, NRHS
IMAX = IDAMAX( N, X( 1, J ), 1 )
XNORM = MAX( ABS( X( IMAX, J ) ), UNFL )
DIFF = ZERO
DO 10 I = 1, N
DIFF = MAX( DIFF, ABS( X( I, J )-XACT( I, J ) ) )
10 CONTINUE
*
IF( XNORM.GT.ONE ) THEN
GO TO 20
ELSE IF( DIFF.LE.OVFL*XNORM ) THEN
GO TO 20
ELSE
ERRBND = ONE / EPS
GO TO 30
END IF
*
20 CONTINUE
IF( DIFF / XNORM.LE.FERR( J ) ) THEN
ERRBND = MAX( ERRBND, ( DIFF / XNORM ) / FERR( J ) )
ELSE
ERRBND = ONE / EPS
END IF
30 CONTINUE
RESLTS( 1 ) = ERRBND
*
* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where
* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
*
DO 90 K = 1, NRHS
DO 80 I = 1, N
TMP = ABS( B( I, K ) )
IF( UPPER ) THEN
DO 40 J = MAX( I-KD, 1 ), I
TMP = TMP + ABS( AB( KD+1-I+J, I ) )*ABS( X( J, K ) )
40 CONTINUE
DO 50 J = I + 1, MIN( I+KD, N )
TMP = TMP + ABS( AB( KD+1+I-J, J ) )*ABS( X( J, K ) )
50 CONTINUE
ELSE
DO 60 J = MAX( I-KD, 1 ), I - 1
TMP = TMP + ABS( AB( 1+I-J, J ) )*ABS( X( J, K ) )
60 CONTINUE
DO 70 J = I, MIN( I+KD, N )
TMP = TMP + ABS( AB( 1+J-I, I ) )*ABS( X( J, K ) )
70 CONTINUE
END IF
IF( I.EQ.1 ) THEN
AXBI = TMP
ELSE
AXBI = MIN( AXBI, TMP )
END IF
80 CONTINUE
TMP = BERR( K ) / ( NZ*EPS+NZ*UNFL / MAX( AXBI, NZ*UNFL ) )
IF( K.EQ.1 ) THEN
RESLTS( 2 ) = TMP
ELSE
RESLTS( 2 ) = MAX( RESLTS( 2 ), TMP )
END IF
90 CONTINUE
*
RETURN
*
* End of DPBT05
*
END
SUBROUTINE DPOT01( UPLO, N, A, LDA, AFAC, LDAFAC, RWORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDA, LDAFAC, N
DOUBLE PRECISION RESID
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), RWORK( * )
* ..
*
* Purpose
* =======
*
* DPOT01 reconstructs a symmetric positive definite matrix A from
* its L*L' or U'*U factorization and computes the residual
* norm( L*L' - A ) / ( N * norm(A) * EPS ) or
* norm( U'*U - A ) / ( N * norm(A) * EPS ),
* where EPS is the machine epsilon.
*
* Arguments
* ==========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The number of rows and columns of the matrix A. N >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The original symmetric matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N)
*
* AFAC (input/output) DOUBLE PRECISION array, dimension (LDAFAC,N)
* On entry, the factor L or U from the L*L' or U'*U
* factorization of A.
* Overwritten with the reconstructed matrix, and then with the
* difference L*L' - A (or U'*U - A).
*
* LDAFAC (input) INTEGER
* The leading dimension of the array AFAC. LDAFAC >= max(1,N).
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* RESID (output) DOUBLE PRECISION
* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS )
* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, K
DOUBLE PRECISION ANORM, EPS, T
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DDOT, DLAMCH, DLANSY
EXTERNAL LSAME, DDOT, DLAMCH, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, DSYR, DTRMV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0.
*
IF( N.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0.
*
EPS = DLAMCH( 'Epsilon' )
ANORM = DLANSY( '1', UPLO, N, A, LDA, RWORK )
IF( ANORM.LE.ZERO ) THEN
RESID = ONE / EPS
RETURN
END IF
*
* Compute the product U'*U, overwriting U.
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 10 K = N, 1, -1
*
* Compute the (K,K) element of the result.
*
T = DDOT( K, AFAC( 1, K ), 1, AFAC( 1, K ), 1 )
AFAC( K, K ) = T
*
* Compute the rest of column K.
*
CALL DTRMV( 'Upper', 'Transpose', 'Non-unit', K-1, AFAC,
$ LDAFAC, AFAC( 1, K ), 1 )
*
10 CONTINUE
*
* Compute the product L*L', overwriting L.
*
ELSE
DO 20 K = N, 1, -1
*
* Add a multiple of column K of the factor L to each of
* columns K+1 through N.
*
IF( K+1.LE.N )
$ CALL DSYR( 'Lower', N-K, ONE, AFAC( K+1, K ), 1,
$ AFAC( K+1, K+1 ), LDAFAC )
*
* Scale column K by the diagonal element.
*
T = AFAC( K, K )
CALL DSCAL( N-K+1, T, AFAC( K, K ), 1 )
*
20 CONTINUE
END IF
*
* Compute the difference L*L' - A (or U'*U - A).
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 40 J = 1, N
DO 30 I = 1, J
AFAC( I, J ) = AFAC( I, J ) - A( I, J )
30 CONTINUE
40 CONTINUE
ELSE
DO 60 J = 1, N
DO 50 I = J, N
AFAC( I, J ) = AFAC( I, J ) - A( I, J )
50 CONTINUE
60 CONTINUE
END IF
*
* Compute norm( L*U - A ) / ( N * norm(A) * EPS )
*
RESID = DLANSY( '1', UPLO, N, AFAC, LDAFAC, RWORK )
*
RESID = ( ( RESID / DBLE( N ) ) / ANORM ) / EPS
*
RETURN
*
* End of DPOT01
*
END
SUBROUTINE DPOT02( UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK,
$ RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDA, LDB, LDX, N, NRHS
DOUBLE PRECISION RESID
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), RWORK( * ),
$ X( LDX, * )
* ..
*
* Purpose
* =======
*
* DPOT02 computes the residual for the solution of a symmetric system
* of linear equations A*x = b:
*
* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ),
*
* where EPS is the machine epsilon.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The number of rows and columns of the matrix A. N >= 0.
*
* NRHS (input) INTEGER
* The number of columns of B, the matrix of right hand sides.
* NRHS >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The original symmetric matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N)
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The computed solution vectors for the system of linear
* equations.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the right hand side vectors for the system of
* linear equations.
* On exit, B is overwritten with the difference B - A*X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* RESID (output) DOUBLE PRECISION
* The maximum over the number of right hand sides of
* norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER J
DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
* ..
* .. External Functions ..
DOUBLE PRECISION DASUM, DLAMCH, DLANSY
EXTERNAL DASUM, DLAMCH, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DSYMM
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0.
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0.
*
EPS = DLAMCH( 'Epsilon' )
ANORM = DLANSY( '1', UPLO, N, A, LDA, RWORK )
IF( ANORM.LE.ZERO ) THEN
RESID = ONE / EPS
RETURN
END IF
*
* Compute B - A*X
*
CALL DSYMM( 'Left', UPLO, N, NRHS, -ONE, A, LDA, X, LDX, ONE, B,
$ LDB )
*
* Compute the maximum over the number of right hand sides of
* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) .
*
RESID = ZERO
DO 10 J = 1, NRHS
BNORM = DASUM( N, B( 1, J ), 1 )
XNORM = DASUM( N, X( 1, J ), 1 )
IF( XNORM.LE.ZERO ) THEN
RESID = ONE / EPS
ELSE
RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) / EPS )
END IF
10 CONTINUE
*
RETURN
*
* End of DPOT02
*
END
SUBROUTINE DPOT03( UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK,
$ RWORK, RCOND, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDA, LDAINV, LDWORK, N
DOUBLE PRECISION RCOND, RESID
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), AINV( LDAINV, * ), RWORK( * ),
$ WORK( LDWORK, * )
* ..
*
* Purpose
* =======
*
* DPOT03 computes the residual for a symmetric matrix times its
* inverse:
* norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ),
* where EPS is the machine epsilon.
*
* Arguments
* ==========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The number of rows and columns of the matrix A. N >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The original symmetric matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N)
*
* AINV (input/output) DOUBLE PRECISION array, dimension (LDAINV,N)
* On entry, the inverse of the matrix A, stored as a symmetric
* matrix in the same format as A.
* In this version, AINV is expanded into a full matrix and
* multiplied by A, so the opposing triangle of AINV will be
* changed; i.e., if the upper triangular part of AINV is
* stored, the lower triangular part will be used as work space.
*
* LDAINV (input) INTEGER
* The leading dimension of the array AINV. LDAINV >= max(1,N).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,N)
*
* LDWORK (input) INTEGER
* The leading dimension of the array WORK. LDWORK >= max(1,N).
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* RCOND (output) DOUBLE PRECISION
* The reciprocal of the condition number of A, computed as
* ( 1/norm(A) ) / norm(AINV).
*
* RESID (output) DOUBLE PRECISION
* norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION AINVNM, ANORM, EPS
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
EXTERNAL LSAME, DLAMCH, DLANGE, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DSYMM
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0.
*
IF( N.LE.0 ) THEN
RCOND = ONE
RESID = ZERO
RETURN
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0.
*
EPS = DLAMCH( 'Epsilon' )
ANORM = DLANSY( '1', UPLO, N, A, LDA, RWORK )
AINVNM = DLANSY( '1', UPLO, N, AINV, LDAINV, RWORK )
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCOND = ZERO
RESID = ONE / EPS
RETURN
END IF
RCOND = ( ONE / ANORM ) / AINVNM
*
* Expand AINV into a full matrix and call DSYMM to multiply
* AINV on the left by A.
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = 1, J - 1
AINV( J, I ) = AINV( I, J )
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1, N
DO 30 I = J + 1, N
AINV( J, I ) = AINV( I, J )
30 CONTINUE
40 CONTINUE
END IF
CALL DSYMM( 'Left', UPLO, N, N, -ONE, A, LDA, AINV, LDAINV, ZERO,
$ WORK, LDWORK )
*
* Add the identity matrix to WORK .
*
DO 50 I = 1, N
WORK( I, I ) = WORK( I, I ) + ONE
50 CONTINUE
*
* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS)
*
RESID = DLANGE( '1', N, N, WORK, LDWORK, RWORK )
*
RESID = ( ( RESID*RCOND ) / EPS ) / DBLE( N )
*
RETURN
*
* End of DPOT03
*
END
SUBROUTINE DPOT05( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, XACT,
$ LDXACT, FERR, BERR, RESLTS )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDA, LDB, LDX, LDXACT, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ),
$ RESLTS( * ), X( LDX, * ), XACT( LDXACT, * )
* ..
*
* Purpose
* =======
*
* DPOT05 tests the error bounds from iterative refinement for the
* computed solution to a system of equations A*X = B, where A is a
* symmetric n by n matrix.
*
* RESLTS(1) = test of the error bound
* = norm(X - XACT) / ( norm(X) * FERR )
*
* A large value is returned if this ratio is not less than one.
*
* RESLTS(2) = residual from the iterative refinement routine
* = the maximum of BERR / ( (n+1)*EPS + (*) ), where
* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The number of rows of the matrices X, B, and XACT, and the
* order of the matrix A. N >= 0.
*
* NRHS (input) INTEGER
* The number of columns of the matrices X, B, and XACT.
* NRHS >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The symmetric matrix A. If UPLO = 'U', the leading n by n
* upper triangular part of A contains the upper triangular part
* of the matrix A, and the strictly lower triangular part of A
* is not referenced. If UPLO = 'L', the leading n by n lower
* triangular part of A contains the lower triangular part of
* the matrix A, and the strictly upper triangular part of A is
* not referenced.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The computed solution vectors. Each vector is stored as a
* column of the matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* XACT (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The exact solution vectors. Each vector is stored as a
* column of the matrix XACT.
*
* LDXACT (input) INTEGER
* The leading dimension of the array XACT. LDXACT >= max(1,N).
*
* FERR (input) DOUBLE PRECISION array, dimension (NRHS)
* The estimated forward error bounds for each solution vector
* X. If XTRUE is the true solution, FERR bounds the magnitude
* of the largest entry in (X - XTRUE) divided by the magnitude
* of the largest entry in X.
*
* BERR (input) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector (i.e., the smallest relative change in any entry of A
* or B that makes X an exact solution).
*
* RESLTS (output) DOUBLE PRECISION array, dimension (2)
* The maximum over the NRHS solution vectors of the ratios:
* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
* RESLTS(2) = BERR / ( (n+1)*EPS + (*) )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, IMAX, J, K
DOUBLE PRECISION AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, IDAMAX, DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0.
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESLTS( 1 ) = ZERO
RESLTS( 2 ) = ZERO
RETURN
END IF
*
EPS = DLAMCH( 'Epsilon' )
UNFL = DLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
UPPER = LSAME( UPLO, 'U' )
*
* Test 1: Compute the maximum of
* norm(X - XACT) / ( norm(X) * FERR )
* over all the vectors X and XACT using the infinity-norm.
*
ERRBND = ZERO
DO 30 J = 1, NRHS
IMAX = IDAMAX( N, X( 1, J ), 1 )
XNORM = MAX( ABS( X( IMAX, J ) ), UNFL )
DIFF = ZERO
DO 10 I = 1, N
DIFF = MAX( DIFF, ABS( X( I, J )-XACT( I, J ) ) )
10 CONTINUE
*
IF( XNORM.GT.ONE ) THEN
GO TO 20
ELSE IF( DIFF.LE.OVFL*XNORM ) THEN
GO TO 20
ELSE
ERRBND = ONE / EPS
GO TO 30
END IF
*
20 CONTINUE
IF( DIFF / XNORM.LE.FERR( J ) ) THEN
ERRBND = MAX( ERRBND, ( DIFF / XNORM ) / FERR( J ) )
ELSE
ERRBND = ONE / EPS
END IF
30 CONTINUE
RESLTS( 1 ) = ERRBND
*
* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where
* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
*
DO 90 K = 1, NRHS
DO 80 I = 1, N
TMP = ABS( B( I, K ) )
IF( UPPER ) THEN
DO 40 J = 1, I
TMP = TMP + ABS( A( J, I ) )*ABS( X( J, K ) )
40 CONTINUE
DO 50 J = I + 1, N
TMP = TMP + ABS( A( I, J ) )*ABS( X( J, K ) )
50 CONTINUE
ELSE
DO 60 J = 1, I - 1
TMP = TMP + ABS( A( I, J ) )*ABS( X( J, K ) )
60 CONTINUE
DO 70 J = I, N
TMP = TMP + ABS( A( J, I ) )*ABS( X( J, K ) )
70 CONTINUE
END IF
IF( I.EQ.1 ) THEN
AXBI = TMP
ELSE
AXBI = MIN( AXBI, TMP )
END IF
80 CONTINUE
TMP = BERR( K ) / ( ( N+1 )*EPS+( N+1 )*UNFL /
$ MAX( AXBI, ( N+1 )*UNFL ) )
IF( K.EQ.1 ) THEN
RESLTS( 2 ) = TMP
ELSE
RESLTS( 2 ) = MAX( RESLTS( 2 ), TMP )
END IF
90 CONTINUE
*
RETURN
*
* End of DPOT05
*
END
SUBROUTINE DPPT01( UPLO, N, A, AFAC, RWORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER N
DOUBLE PRECISION RESID
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( * ), AFAC( * ), RWORK( * )
* ..
*
* Purpose
* =======
*
* DPPT01 reconstructs a symmetric positive definite packed matrix A
* from its L*L' or U'*U factorization and computes the residual
* norm( L*L' - A ) / ( N * norm(A) * EPS ) or
* norm( U'*U - A ) / ( N * norm(A) * EPS ),
* where EPS is the machine epsilon.
*
* Arguments
* ==========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The number of rows and columns of the matrix A. N >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The original symmetric matrix A, stored as a packed
* triangular matrix.
*
* AFAC (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* On entry, the factor L or U from the L*L' or U'*U
* factorization of A, stored as a packed triangular matrix.
* Overwritten with the reconstructed matrix, and then with the
* difference L*L' - A (or U'*U - A).
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* RESID (output) DOUBLE PRECISION
* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS )
* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, K, KC, NPP
DOUBLE PRECISION ANORM, EPS, T
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DDOT, DLAMCH, DLANSP
EXTERNAL LSAME, DDOT, DLAMCH, DLANSP
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, DSPR, DTPMV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0
*
IF( N.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0.
*
EPS = DLAMCH( 'Epsilon' )
ANORM = DLANSP( '1', UPLO, N, A, RWORK )
IF( ANORM.LE.ZERO ) THEN
RESID = ONE / EPS
RETURN
END IF
*
* Compute the product U'*U, overwriting U.
*
IF( LSAME( UPLO, 'U' ) ) THEN
KC = ( N*( N-1 ) ) / 2 + 1
DO 10 K = N, 1, -1
*
* Compute the (K,K) element of the result.
*
T = DDOT( K, AFAC( KC ), 1, AFAC( KC ), 1 )
AFAC( KC+K-1 ) = T
*
* Compute the rest of column K.
*
IF( K.GT.1 ) THEN
CALL DTPMV( 'Upper', 'Transpose', 'Non-unit', K-1, AFAC,
$ AFAC( KC ), 1 )
KC = KC - ( K-1 )
END IF
10 CONTINUE
*
* Compute the product L*L', overwriting L.
*
ELSE
KC = ( N*( N+1 ) ) / 2
DO 20 K = N, 1, -1
*
* Add a multiple of column K of the factor L to each of
* columns K+1 through N.
*
IF( K.LT.N )
$ CALL DSPR( 'Lower', N-K, ONE, AFAC( KC+1 ), 1,
$ AFAC( KC+N-K+1 ) )
*
* Scale column K by the diagonal element.
*
T = AFAC( KC )
CALL DSCAL( N-K+1, T, AFAC( KC ), 1 )
*
KC = KC - ( N-K+2 )
20 CONTINUE
END IF
*
* Compute the difference L*L' - A (or U'*U - A).
*
NPP = N*( N+1 ) / 2
DO 30 I = 1, NPP
AFAC( I ) = AFAC( I ) - A( I )
30 CONTINUE
*
* Compute norm( L*U - A ) / ( N * norm(A) * EPS )
*
RESID = DLANSP( '1', UPLO, N, AFAC, RWORK )
*
RESID = ( ( RESID / DBLE( N ) ) / ANORM ) / EPS
*
RETURN
*
* End of DPPT01
*
END
SUBROUTINE DPPT02( UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK,
$ RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDB, LDX, N, NRHS
DOUBLE PRECISION RESID
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( * ), B( LDB, * ), RWORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* DPPT02 computes the residual in the solution of a symmetric system
* of linear equations A*x = b when packed storage is used for the
* coefficient matrix. The ratio computed is
*
* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS),
*
* where EPS is the machine precision.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The number of rows and columns of the matrix A. N >= 0.
*
* NRHS (input) INTEGER
* The number of columns of B, the matrix of right hand sides.
* NRHS >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The original symmetric matrix A, stored as a packed
* triangular matrix.
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The computed solution vectors for the system of linear
* equations.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the right hand side vectors for the system of
* linear equations.
* On exit, B is overwritten with the difference B - A*X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* RESID (output) DOUBLE PRECISION
* The maximum over the number of right hand sides of
* norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER J
DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
* ..
* .. External Functions ..
DOUBLE PRECISION DASUM, DLAMCH, DLANSP
EXTERNAL DASUM, DLAMCH, DLANSP
* ..
* .. External Subroutines ..
EXTERNAL DSPMV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0.
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0.
*
EPS = DLAMCH( 'Epsilon' )
ANORM = DLANSP( '1', UPLO, N, A, RWORK )
IF( ANORM.LE.ZERO ) THEN
RESID = ONE / EPS
RETURN
END IF
*
* Compute B - A*X for the matrix of right hand sides B.
*
DO 10 J = 1, NRHS
CALL DSPMV( UPLO, N, -ONE, A, X( 1, J ), 1, ONE, B( 1, J ), 1 )
10 CONTINUE
*
* Compute the maximum over the number of right hand sides of
* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) .
*
RESID = ZERO
DO 20 J = 1, NRHS
BNORM = DASUM( N, B( 1, J ), 1 )
XNORM = DASUM( N, X( 1, J ), 1 )
IF( XNORM.LE.ZERO ) THEN
RESID = ONE / EPS
ELSE
RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) / EPS )
END IF
20 CONTINUE
*
RETURN
*
* End of DPPT02
*
END
SUBROUTINE DPPT03( UPLO, N, A, AINV, WORK, LDWORK, RWORK, RCOND,
$ RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDWORK, N
DOUBLE PRECISION RCOND, RESID
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( * ), AINV( * ), RWORK( * ),
$ WORK( LDWORK, * )
* ..
*
* Purpose
* =======
*
* DPPT03 computes the residual for a symmetric packed matrix times its
* inverse:
* norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ),
* where EPS is the machine epsilon.
*
* Arguments
* ==========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The number of rows and columns of the matrix A. N >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The original symmetric matrix A, stored as a packed
* triangular matrix.
*
* AINV (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The (symmetric) inverse of the matrix A, stored as a packed
* triangular matrix.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,N)
*
* LDWORK (input) INTEGER
* The leading dimension of the array WORK. LDWORK >= max(1,N).
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* RCOND (output) DOUBLE PRECISION
* The reciprocal of the condition number of A, computed as
* ( 1/norm(A) ) / norm(AINV).
*
* RESID (output) DOUBLE PRECISION
* norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, JJ
DOUBLE PRECISION AINVNM, ANORM, EPS
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANGE, DLANSP
EXTERNAL LSAME, DLAMCH, DLANGE, DLANSP
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DSPMV
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0.
*
IF( N.LE.0 ) THEN
RCOND = ONE
RESID = ZERO
RETURN
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0.
*
EPS = DLAMCH( 'Epsilon' )
ANORM = DLANSP( '1', UPLO, N, A, RWORK )
AINVNM = DLANSP( '1', UPLO, N, AINV, RWORK )
IF( ANORM.LE.ZERO .OR. AINVNM.EQ.ZERO ) THEN
RCOND = ZERO
RESID = ONE / EPS
RETURN
END IF
RCOND = ( ONE / ANORM ) / AINVNM
*
* UPLO = 'U':
* Copy the leading N-1 x N-1 submatrix of AINV to WORK(1:N,2:N) and
* expand it to a full matrix, then multiply by A one column at a
* time, moving the result one column to the left.
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Copy AINV
*
JJ = 1
DO 10 J = 1, N - 1
CALL DCOPY( J, AINV( JJ ), 1, WORK( 1, J+1 ), 1 )
CALL DCOPY( J-1, AINV( JJ ), 1, WORK( J, 2 ), LDWORK )
JJ = JJ + J
10 CONTINUE
JJ = ( ( N-1 )*N ) / 2 + 1
CALL DCOPY( N-1, AINV( JJ ), 1, WORK( N, 2 ), LDWORK )
*
* Multiply by A
*
DO 20 J = 1, N - 1
CALL DSPMV( 'Upper', N, -ONE, A, WORK( 1, J+1 ), 1, ZERO,
$ WORK( 1, J ), 1 )
20 CONTINUE
CALL DSPMV( 'Upper', N, -ONE, A, AINV( JJ ), 1, ZERO,
$ WORK( 1, N ), 1 )
*
* UPLO = 'L':
* Copy the trailing N-1 x N-1 submatrix of AINV to WORK(1:N,1:N-1)
* and multiply by A, moving each column to the right.
*
ELSE
*
* Copy AINV
*
CALL DCOPY( N-1, AINV( 2 ), 1, WORK( 1, 1 ), LDWORK )
JJ = N + 1
DO 30 J = 2, N
CALL DCOPY( N-J+1, AINV( JJ ), 1, WORK( J, J-1 ), 1 )
CALL DCOPY( N-J, AINV( JJ+1 ), 1, WORK( J, J ), LDWORK )
JJ = JJ + N - J + 1
30 CONTINUE
*
* Multiply by A
*
DO 40 J = N, 2, -1
CALL DSPMV( 'Lower', N, -ONE, A, WORK( 1, J-1 ), 1, ZERO,
$ WORK( 1, J ), 1 )
40 CONTINUE
CALL DSPMV( 'Lower', N, -ONE, A, AINV( 1 ), 1, ZERO,
$ WORK( 1, 1 ), 1 )
*
END IF
*
* Add the identity matrix to WORK .
*
DO 50 I = 1, N
WORK( I, I ) = WORK( I, I ) + ONE
50 CONTINUE
*
* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS)
*
RESID = DLANGE( '1', N, N, WORK, LDWORK, RWORK )
*
RESID = ( ( RESID*RCOND ) / EPS ) / DBLE( N )
*
RETURN
*
* End of DPPT03
*
END
SUBROUTINE DPPT05( UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT,
$ LDXACT, FERR, BERR, RESLTS )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDB, LDX, LDXACT, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP( * ), B( LDB, * ), BERR( * ), FERR( * ),
$ RESLTS( * ), X( LDX, * ), XACT( LDXACT, * )
* ..
*
* Purpose
* =======
*
* DPPT05 tests the error bounds from iterative refinement for the
* computed solution to a system of equations A*X = B, where A is a
* symmetric matrix in packed storage format.
*
* RESLTS(1) = test of the error bound
* = norm(X - XACT) / ( norm(X) * FERR )
*
* A large value is returned if this ratio is not less than one.
*
* RESLTS(2) = residual from the iterative refinement routine
* = the maximum of BERR / ( (n+1)*EPS + (*) ), where
* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The number of rows of the matrices X, B, and XACT, and the
* order of the matrix A. N >= 0.
*
* NRHS (input) INTEGER
* The number of columns of the matrices X, B, and XACT.
* NRHS >= 0.
*
* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The upper or lower triangle of the symmetric matrix A, packed
* columnwise in a linear array. The j-th column of A is stored
* in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The computed solution vectors. Each vector is stored as a
* column of the matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* XACT (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The exact solution vectors. Each vector is stored as a
* column of the matrix XACT.
*
* LDXACT (input) INTEGER
* The leading dimension of the array XACT. LDXACT >= max(1,N).
*
* FERR (input) DOUBLE PRECISION array, dimension (NRHS)
* The estimated forward error bounds for each solution vector
* X. If XTRUE is the true solution, FERR bounds the magnitude
* of the largest entry in (X - XTRUE) divided by the magnitude
* of the largest entry in X.
*
* BERR (input) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector (i.e., the smallest relative change in any entry of A
* or B that makes X an exact solution).
*
* RESLTS (output) DOUBLE PRECISION array, dimension (2)
* The maximum over the NRHS solution vectors of the ratios:
* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
* RESLTS(2) = BERR / ( (n+1)*EPS + (*) )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, IMAX, J, JC, K
DOUBLE PRECISION AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, IDAMAX, DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0.
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESLTS( 1 ) = ZERO
RESLTS( 2 ) = ZERO
RETURN
END IF
*
EPS = DLAMCH( 'Epsilon' )
UNFL = DLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
UPPER = LSAME( UPLO, 'U' )
*
* Test 1: Compute the maximum of
* norm(X - XACT) / ( norm(X) * FERR )
* over all the vectors X and XACT using the infinity-norm.
*
ERRBND = ZERO
DO 30 J = 1, NRHS
IMAX = IDAMAX( N, X( 1, J ), 1 )
XNORM = MAX( ABS( X( IMAX, J ) ), UNFL )
DIFF = ZERO
DO 10 I = 1, N
DIFF = MAX( DIFF, ABS( X( I, J )-XACT( I, J ) ) )
10 CONTINUE
*
IF( XNORM.GT.ONE ) THEN
GO TO 20
ELSE IF( DIFF.LE.OVFL*XNORM ) THEN
GO TO 20
ELSE
ERRBND = ONE / EPS
GO TO 30
END IF
*
20 CONTINUE
IF( DIFF / XNORM.LE.FERR( J ) ) THEN
ERRBND = MAX( ERRBND, ( DIFF / XNORM ) / FERR( J ) )
ELSE
ERRBND = ONE / EPS
END IF
30 CONTINUE
RESLTS( 1 ) = ERRBND
*
* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where
* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
*
DO 90 K = 1, NRHS
DO 80 I = 1, N
TMP = ABS( B( I, K ) )
IF( UPPER ) THEN
JC = ( ( I-1 )*I ) / 2
DO 40 J = 1, I
TMP = TMP + ABS( AP( JC+J ) )*ABS( X( J, K ) )
40 CONTINUE
JC = JC + I
DO 50 J = I + 1, N
TMP = TMP + ABS( AP( JC ) )*ABS( X( J, K ) )
JC = JC + J
50 CONTINUE
ELSE
JC = I
DO 60 J = 1, I - 1
TMP = TMP + ABS( AP( JC ) )*ABS( X( J, K ) )
JC = JC + N - J
60 CONTINUE
DO 70 J = I, N
TMP = TMP + ABS( AP( JC+J-I ) )*ABS( X( J, K ) )
70 CONTINUE
END IF
IF( I.EQ.1 ) THEN
AXBI = TMP
ELSE
AXBI = MIN( AXBI, TMP )
END IF
80 CONTINUE
TMP = BERR( K ) / ( ( N+1 )*EPS+( N+1 )*UNFL /
$ MAX( AXBI, ( N+1 )*UNFL ) )
IF( K.EQ.1 ) THEN
RESLTS( 2 ) = TMP
ELSE
RESLTS( 2 ) = MAX( RESLTS( 2 ), TMP )
END IF
90 CONTINUE
*
RETURN
*
* End of DPPT05
*
END
SUBROUTINE DPTT01( N, D, E, DF, EF, WORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER N
DOUBLE PRECISION RESID
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), DF( * ), E( * ), EF( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DPTT01 reconstructs a tridiagonal matrix A from its L*D*L'
* factorization and computes the residual
* norm(L*D*L' - A) / ( n * norm(A) * EPS ),
* where EPS is the machine epsilon.
*
* Arguments
* =========
*
* N (input) INTEGTER
* The order of the matrix A.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the tridiagonal matrix A.
*
* E (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) subdiagonal elements of the tridiagonal matrix A.
*
* DF (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the factor L from the L*D*L'
* factorization of A.
*
* EF (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) subdiagonal elements of the factor L from the
* L*D*L' factorization of A.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
*
* RESID (output) DOUBLE PRECISION
* norm(L*D*L' - A) / (n * norm(A) * EPS)
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I
DOUBLE PRECISION ANORM, DE, EPS
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
EPS = DLAMCH( 'Epsilon' )
*
* Construct the difference L*D*L' - A.
*
WORK( 1 ) = DF( 1 ) - D( 1 )
DO 10 I = 1, N - 1
DE = DF( I )*EF( I )
WORK( N+I ) = DE - E( I )
WORK( 1+I ) = DE*EF( I ) + DF( I+1 ) - D( I+1 )
10 CONTINUE
*
* Compute the 1-norms of the tridiagonal matrices A and WORK.
*
IF( N.EQ.1 ) THEN
ANORM = D( 1 )
RESID = ABS( WORK( 1 ) )
ELSE
ANORM = MAX( D( 1 )+ABS( E( 1 ) ), D( N )+ABS( E( N-1 ) ) )
RESID = MAX( ABS( WORK( 1 ) )+ABS( WORK( N+1 ) ),
$ ABS( WORK( N ) )+ABS( WORK( 2*N-1 ) ) )
DO 20 I = 2, N - 1
ANORM = MAX( ANORM, D( I )+ABS( E( I ) )+ABS( E( I-1 ) ) )
RESID = MAX( RESID, ABS( WORK( I ) )+ABS( WORK( N+I-1 ) )+
$ ABS( WORK( N+I ) ) )
20 CONTINUE
END IF
*
* Compute norm(L*D*L' - A) / (n * norm(A) * EPS)
*
IF( ANORM.LE.ZERO ) THEN
IF( RESID.NE.ZERO )
$ RESID = ONE / EPS
ELSE
RESID = ( ( RESID / DBLE( N ) ) / ANORM ) / EPS
END IF
*
RETURN
*
* End of DPTT01
*
END
SUBROUTINE DPTT02( N, NRHS, D, E, X, LDX, B, LDB, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDB, LDX, N, NRHS
DOUBLE PRECISION RESID
* ..
* .. Array Arguments ..
DOUBLE PRECISION B( LDB, * ), D( * ), E( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* DPTT02 computes the residual for the solution to a symmetric
* tridiagonal system of equations:
* RESID = norm(B - A*X) / (norm(A) * norm(X) * EPS),
* where EPS is the machine epsilon.
*
* Arguments
* =========
*
* N (input) INTEGTER
* The order of the matrix A.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrices B and X. NRHS >= 0.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the tridiagonal matrix A.
*
* E (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) subdiagonal elements of the tridiagonal matrix A.
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The n by nrhs matrix of solution vectors X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the n by nrhs matrix of right hand side vectors B.
* On exit, B is overwritten with the difference B - A*X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* RESID (output) DOUBLE PRECISION
* norm(B - A*X) / (norm(A) * norm(X) * EPS)
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER J
DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
* ..
* .. External Functions ..
DOUBLE PRECISION DASUM, DLAMCH, DLANST
EXTERNAL DASUM, DLAMCH, DLANST
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. External Subroutines ..
EXTERNAL DLAPTM
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Compute the 1-norm of the tridiagonal matrix A.
*
ANORM = DLANST( '1', N, D, E )
*
* Exit with RESID = 1/EPS if ANORM = 0.
*
EPS = DLAMCH( 'Epsilon' )
IF( ANORM.LE.ZERO ) THEN
RESID = ONE / EPS
RETURN
END IF
*
* Compute B - A*X.
*
CALL DLAPTM( N, NRHS, -ONE, D, E, X, LDX, ONE, B, LDB )
*
* Compute the maximum over the number of right hand sides of
* norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
*
RESID = ZERO
DO 10 J = 1, NRHS
BNORM = DASUM( N, B( 1, J ), 1 )
XNORM = DASUM( N, X( 1, J ), 1 )
IF( XNORM.LE.ZERO ) THEN
RESID = ONE / EPS
ELSE
RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) / EPS )
END IF
10 CONTINUE
*
RETURN
*
* End of DPTT02
*
END
SUBROUTINE DPTT05( N, NRHS, D, E, B, LDB, X, LDX, XACT, LDXACT,
$ FERR, BERR, RESLTS )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDB, LDX, LDXACT, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), E( * ),
$ FERR( * ), RESLTS( * ), X( LDX, * ),
$ XACT( LDXACT, * )
* ..
*
* Purpose
* =======
*
* DPTT05 tests the error bounds from iterative refinement for the
* computed solution to a system of equations A*X = B, where A is a
* symmetric tridiagonal matrix of order n.
*
* RESLTS(1) = test of the error bound
* = norm(X - XACT) / ( norm(X) * FERR )
*
* A large value is returned if this ratio is not less than one.
*
* RESLTS(2) = residual from the iterative refinement routine
* = the maximum of BERR / ( NZ*EPS + (*) ), where
* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
* and NZ = max. number of nonzeros in any row of A, plus 1
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of rows of the matrices X, B, and XACT, and the
* order of the matrix A. N >= 0.
*
* NRHS (input) INTEGER
* The number of columns of the matrices X, B, and XACT.
* NRHS >= 0.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the tridiagonal matrix A.
*
* E (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) subdiagonal elements of the tridiagonal matrix A.
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The computed solution vectors. Each vector is stored as a
* column of the matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* XACT (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The exact solution vectors. Each vector is stored as a
* column of the matrix XACT.
*
* LDXACT (input) INTEGER
* The leading dimension of the array XACT. LDXACT >= max(1,N).
*
* FERR (input) DOUBLE PRECISION array, dimension (NRHS)
* The estimated forward error bounds for each solution vector
* X. If XTRUE is the true solution, FERR bounds the magnitude
* of the largest entry in (X - XTRUE) divided by the magnitude
* of the largest entry in X.
*
* BERR (input) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector (i.e., the smallest relative change in any entry of A
* or B that makes X an exact solution).
*
* RESLTS (output) DOUBLE PRECISION array, dimension (2)
* The maximum over the NRHS solution vectors of the ratios:
* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
* RESLTS(2) = BERR / ( NZ*EPS + (*) )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, IMAX, J, K, NZ
DOUBLE PRECISION AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL IDAMAX, DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0.
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESLTS( 1 ) = ZERO
RESLTS( 2 ) = ZERO
RETURN
END IF
*
EPS = DLAMCH( 'Epsilon' )
UNFL = DLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
NZ = 4
*
* Test 1: Compute the maximum of
* norm(X - XACT) / ( norm(X) * FERR )
* over all the vectors X and XACT using the infinity-norm.
*
ERRBND = ZERO
DO 30 J = 1, NRHS
IMAX = IDAMAX( N, X( 1, J ), 1 )
XNORM = MAX( ABS( X( IMAX, J ) ), UNFL )
DIFF = ZERO
DO 10 I = 1, N
DIFF = MAX( DIFF, ABS( X( I, J )-XACT( I, J ) ) )
10 CONTINUE
*
IF( XNORM.GT.ONE ) THEN
GO TO 20
ELSE IF( DIFF.LE.OVFL*XNORM ) THEN
GO TO 20
ELSE
ERRBND = ONE / EPS
GO TO 30
END IF
*
20 CONTINUE
IF( DIFF / XNORM.LE.FERR( J ) ) THEN
ERRBND = MAX( ERRBND, ( DIFF / XNORM ) / FERR( J ) )
ELSE
ERRBND = ONE / EPS
END IF
30 CONTINUE
RESLTS( 1 ) = ERRBND
*
* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where
* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
*
DO 50 K = 1, NRHS
IF( N.EQ.1 ) THEN
AXBI = ABS( B( 1, K ) ) + ABS( D( 1 )*X( 1, K ) )
ELSE
AXBI = ABS( B( 1, K ) ) + ABS( D( 1 )*X( 1, K ) ) +
$ ABS( E( 1 )*X( 2, K ) )
DO 40 I = 2, N - 1
TMP = ABS( B( I, K ) ) + ABS( E( I-1 )*X( I-1, K ) ) +
$ ABS( D( I )*X( I, K ) ) + ABS( E( I )*X( I+1, K ) )
AXBI = MIN( AXBI, TMP )
40 CONTINUE
TMP = ABS( B( N, K ) ) + ABS( E( N-1 )*X( N-1, K ) ) +
$ ABS( D( N )*X( N, K ) )
AXBI = MIN( AXBI, TMP )
END IF
TMP = BERR( K ) / ( NZ*EPS+NZ*UNFL / MAX( AXBI, NZ*UNFL ) )
IF( K.EQ.1 ) THEN
RESLTS( 2 ) = TMP
ELSE
RESLTS( 2 ) = MAX( RESLTS( 2 ), TMP )
END IF
50 CONTINUE
*
RETURN
*
* End of DPTT05
*
END
SUBROUTINE DQLT01( M, N, A, AF, Q, L, LDA, TAU, WORK, LWORK,
$ RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), L( LDA, * ),
$ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* DQLT01 tests DGEQLF, which computes the QL factorization of an m-by-n
* matrix A, and partially tests DORGQL which forms the m-by-m
* orthogonal matrix Q.
*
* DQLT01 compares L with Q'*A, and checks that Q is orthogonal.
*
* 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) DOUBLE PRECISION array, dimension (LDA,N)
* The m-by-n matrix A.
*
* AF (output) DOUBLE PRECISION array, dimension (LDA,N)
* Details of the QL factorization of A, as returned by DGEQLF.
* See DGEQLF for further details.
*
* Q (output) DOUBLE PRECISION array, dimension (LDA,M)
* The m-by-m orthogonal matrix Q.
*
* L (workspace) DOUBLE PRECISION array, dimension (LDA,max(M,N))
*
* LDA (input) INTEGER
* The leading dimension of the arrays A, AF, Q and R.
* LDA >= max(M,N).
*
* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
* The scalar factors of the elementary reflectors, as returned
* by DGEQLF.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (M)
*
* RESULT (output) DOUBLE PRECISION array, dimension (2)
* The test ratios:
* RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS )
* RESULT(2) = norm( I - Q'*Q ) / ( M * EPS )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION ROGUE
PARAMETER ( ROGUE = -1.0D+10 )
* ..
* .. Local Scalars ..
INTEGER INFO, MINMN
DOUBLE PRECISION ANORM, EPS, RESID
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
EXTERNAL DLAMCH, DLANGE, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DGEQLF, DLACPY, DLASET, DORGQL, DSYRK
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Scalars in Common ..
CHARACTER*6 SRNAMT
* ..
* .. Common blocks ..
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
MINMN = MIN( M, N )
EPS = DLAMCH( 'Epsilon' )
*
* Copy the matrix A to the array AF.
*
CALL DLACPY( 'Full', M, N, A, LDA, AF, LDA )
*
* Factorize the matrix A in the array AF.
*
SRNAMT = 'DGEQLF'
CALL DGEQLF( M, N, AF, LDA, TAU, WORK, LWORK, INFO )
*
* Copy details of Q
*
CALL DLASET( 'Full', M, M, ROGUE, ROGUE, Q, LDA )
IF( M.GE.N ) THEN
IF( N.LT.M .AND. N.GT.0 )
$ CALL DLACPY( 'Full', M-N, N, AF, LDA, Q( 1, M-N+1 ), LDA )
IF( N.GT.1 )
$ CALL DLACPY( 'Upper', N-1, N-1, AF( M-N+1, 2 ), LDA,
$ Q( M-N+1, M-N+2 ), LDA )
ELSE
IF( M.GT.1 )
$ CALL DLACPY( 'Upper', M-1, M-1, AF( 1, N-M+2 ), LDA,
$ Q( 1, 2 ), LDA )
END IF
*
* Generate the m-by-m matrix Q
*
SRNAMT = 'DORGQL'
CALL DORGQL( M, M, MINMN, Q, LDA, TAU, WORK, LWORK, INFO )
*
* Copy L
*
CALL DLASET( 'Full', M, N, ZERO, ZERO, L, LDA )
IF( M.GE.N ) THEN
IF( N.GT.0 )
$ CALL DLACPY( 'Lower', N, N, AF( M-N+1, 1 ), LDA,
$ L( M-N+1, 1 ), LDA )
ELSE
IF( N.GT.M .AND. M.GT.0 )
$ CALL DLACPY( 'Full', M, N-M, AF, LDA, L, LDA )
IF( M.GT.0 )
$ CALL DLACPY( 'Lower', M, M, AF( 1, N-M+1 ), LDA,
$ L( 1, N-M+1 ), LDA )
END IF
*
* Compute L - Q'*A
*
CALL DGEMM( 'Transpose', 'No transpose', M, N, M, -ONE, Q, LDA, A,
$ LDA, ONE, L, LDA )
*
* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) .
*
ANORM = DLANGE( '1', M, N, A, LDA, RWORK )
RESID = DLANGE( '1', M, N, L, LDA, RWORK )
IF( ANORM.GT.ZERO ) THEN
RESULT( 1 ) = ( ( RESID / DBLE( MAX( 1, M ) ) ) / ANORM ) / EPS
ELSE
RESULT( 1 ) = ZERO
END IF
*
* Compute I - Q'*Q
*
CALL DLASET( 'Full', M, M, ZERO, ONE, L, LDA )
CALL DSYRK( 'Upper', 'Transpose', M, M, -ONE, Q, LDA, ONE, L,
$ LDA )
*
* Compute norm( I - Q'*Q ) / ( M * EPS ) .
*
RESID = DLANSY( '1', 'Upper', M, L, LDA, RWORK )
*
RESULT( 2 ) = ( RESID / DBLE( MAX( 1, M ) ) ) / EPS
*
RETURN
*
* End of DQLT01
*
END
SUBROUTINE DQLT02( M, N, K, A, AF, Q, L, LDA, TAU, WORK, LWORK,
$ RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), L( LDA, * ),
$ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* DQLT02 tests DORGQL, which generates an m-by-n matrix Q with
* orthonornmal columns that is defined as the product of k elementary
* reflectors.
*
* Given the QL factorization of an m-by-n matrix A, DQLT02 generates
* the orthogonal matrix Q defined by the factorization of the last k
* columns of A; it compares L(m-n+1:m,n-k+1:n) with
* Q(1:m,m-n+1:m)'*A(1:m,n-k+1:n), and checks that the columns of Q are
* orthonormal.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix Q to be generated. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix Q to be generated.
* M >= N >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* matrix Q. N >= K >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The m-by-n matrix A which was factorized by DQLT01.
*
* AF (input) DOUBLE PRECISION array, dimension (LDA,N)
* Details of the QL factorization of A, as returned by DGEQLF.
* See DGEQLF for further details.
*
* Q (workspace) DOUBLE PRECISION array, dimension (LDA,N)
*
* L (workspace) DOUBLE PRECISION array, dimension (LDA,N)
*
* LDA (input) INTEGER
* The leading dimension of the arrays A, AF, Q and L. LDA >= M.
*
* TAU (input) DOUBLE PRECISION array, dimension (N)
* The scalar factors of the elementary reflectors corresponding
* to the QL factorization in AF.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (M)
*
* RESULT (output) DOUBLE PRECISION array, dimension (2)
* The test ratios:
* RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS )
* RESULT(2) = norm( I - Q'*Q ) / ( M * EPS )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION ROGUE
PARAMETER ( ROGUE = -1.0D+10 )
* ..
* .. Local Scalars ..
INTEGER INFO
DOUBLE PRECISION ANORM, EPS, RESID
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
EXTERNAL DLAMCH, DLANGE, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLACPY, DLASET, DORGQL, DSYRK
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX
* ..
* .. Scalars in Common ..
CHARACTER*6 SRNAMT
* ..
* .. Common blocks ..
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
RESULT( 1 ) = ZERO
RESULT( 2 ) = ZERO
RETURN
END IF
*
EPS = DLAMCH( 'Epsilon' )
*
* Copy the last k columns of the factorization to the array Q
*
CALL DLASET( 'Full', M, N, ROGUE, ROGUE, Q, LDA )
IF( K.LT.M )
$ CALL DLACPY( 'Full', M-K, K, AF( 1, N-K+1 ), LDA,
$ Q( 1, N-K+1 ), LDA )
IF( K.GT.1 )
$ CALL DLACPY( 'Upper', K-1, K-1, AF( M-K+1, N-K+2 ), LDA,
$ Q( M-K+1, N-K+2 ), LDA )
*
* Generate the last n columns of the matrix Q
*
SRNAMT = 'DORGQL'
CALL DORGQL( M, N, K, Q, LDA, TAU( N-K+1 ), WORK, LWORK, INFO )
*
* Copy L(m-n+1:m,n-k+1:n)
*
CALL DLASET( 'Full', N, K, ZERO, ZERO, L( M-N+1, N-K+1 ), LDA )
CALL DLACPY( 'Lower', K, K, AF( M-K+1, N-K+1 ), LDA,
$ L( M-K+1, N-K+1 ), LDA )
*
* Compute L(m-n+1:m,n-k+1:n) - Q(1:m,m-n+1:m)' * A(1:m,n-k+1:n)
*
CALL DGEMM( 'Transpose', 'No transpose', N, K, M, -ONE, Q, LDA,
$ A( 1, N-K+1 ), LDA, ONE, L( M-N+1, N-K+1 ), LDA )
*
* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) .
*
ANORM = DLANGE( '1', M, K, A( 1, N-K+1 ), LDA, RWORK )
RESID = DLANGE( '1', N, K, L( M-N+1, N-K+1 ), LDA, RWORK )
IF( ANORM.GT.ZERO ) THEN
RESULT( 1 ) = ( ( RESID / DBLE( MAX( 1, M ) ) ) / ANORM ) / EPS
ELSE
RESULT( 1 ) = ZERO
END IF
*
* Compute I - Q'*Q
*
CALL DLASET( 'Full', N, N, ZERO, ONE, L, LDA )
CALL DSYRK( 'Upper', 'Transpose', N, M, -ONE, Q, LDA, ONE, L,
$ LDA )
*
* Compute norm( I - Q'*Q ) / ( M * EPS ) .
*
RESID = DLANSY( '1', 'Upper', N, L, LDA, RWORK )
*
RESULT( 2 ) = ( RESID / DBLE( MAX( 1, M ) ) ) / EPS
*
RETURN
*
* End of DQLT02
*
END
SUBROUTINE DQLT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK,
$ RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AF( LDA, * ), C( LDA, * ), CC( LDA, * ),
$ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* DQLT03 tests DORMQL, which computes Q*C, Q'*C, C*Q or C*Q'.
*
* DQLT03 compares the results of a call to DORMQL with the results of
* forming Q explicitly by a call to DORGQL and then performing matrix
* multiplication by a call to DGEMM.
*
* Arguments
* =========
*
* M (input) INTEGER
* The order of the orthogonal matrix Q. M >= 0.
*
* N (input) INTEGER
* The number of rows or columns of the matrix C; C is m-by-n if
* Q is applied from the left, or n-by-m if Q is applied from
* the right. N >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* orthogonal matrix Q. M >= K >= 0.
*
* AF (input) DOUBLE PRECISION array, dimension (LDA,N)
* Details of the QL factorization of an m-by-n matrix, as
* returned by DGEQLF. See SGEQLF for further details.
*
* C (workspace) DOUBLE PRECISION array, dimension (LDA,N)
*
* CC (workspace) DOUBLE PRECISION array, dimension (LDA,N)
*
* Q (workspace) DOUBLE PRECISION array, dimension (LDA,M)
*
* LDA (input) INTEGER
* The leading dimension of the arrays AF, C, CC, and Q.
*
* TAU (input) DOUBLE PRECISION array, dimension (min(M,N))
* The scalar factors of the elementary reflectors corresponding
* to the QL factorization in AF.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of WORK. LWORK must be at least M, and should be
* M*NB, where NB is the blocksize for this environment.
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (M)
*
* RESULT (output) DOUBLE PRECISION array, dimension (4)
* The test ratios compare two techniques for multiplying a
* random matrix C by an m-by-m orthogonal matrix Q.
* RESULT(1) = norm( Q*C - Q*C ) / ( M * norm(C) * EPS )
* RESULT(2) = norm( C*Q - C*Q ) / ( M * norm(C) * EPS )
* RESULT(3) = norm( Q'*C - Q'*C )/ ( M * norm(C) * EPS )
* RESULT(4) = norm( C*Q' - C*Q' )/ ( M * norm(C) * EPS )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
DOUBLE PRECISION ROGUE
PARAMETER ( ROGUE = -1.0D+10 )
* ..
* .. Local Scalars ..
CHARACTER SIDE, TRANS
INTEGER INFO, ISIDE, ITRANS, J, MC, MINMN, NC
DOUBLE PRECISION CNORM, EPS, RESID
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL LSAME, DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLACPY, DLARNV, DLASET, DORGQL, DORMQL
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 )
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Scalars in Common ..
CHARACTER*6 SRNAMT
* ..
* .. Common blocks ..
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEED / 1988, 1989, 1990, 1991 /
* ..
* .. Executable Statements ..
*
EPS = DLAMCH( 'Epsilon' )
MINMN = MIN( M, N )
*
* Quick return if possible
*
IF( MINMN.EQ.0 ) THEN
RESULT( 1 ) = ZERO
RESULT( 2 ) = ZERO
RESULT( 3 ) = ZERO
RESULT( 4 ) = ZERO
RETURN
END IF
*
* Copy the last k columns of the factorization to the array Q
*
CALL DLASET( 'Full', M, M, ROGUE, ROGUE, Q, LDA )
IF( K.GT.0 .AND. M.GT.K )
$ CALL DLACPY( 'Full', M-K, K, AF( 1, N-K+1 ), LDA,
$ Q( 1, M-K+1 ), LDA )
IF( K.GT.1 )
$ CALL DLACPY( 'Upper', K-1, K-1, AF( M-K+1, N-K+2 ), LDA,
$ Q( M-K+1, M-K+2 ), LDA )
*
* Generate the m-by-m matrix Q
*
SRNAMT = 'DORGQL'
CALL DORGQL( M, M, K, Q, LDA, TAU( MINMN-K+1 ), WORK, LWORK,
$ INFO )
*
DO 30 ISIDE = 1, 2
IF( ISIDE.EQ.1 ) THEN
SIDE = 'L'
MC = M
NC = N
ELSE
SIDE = 'R'
MC = N
NC = M
END IF
*
* Generate MC by NC matrix C
*
DO 10 J = 1, NC
CALL DLARNV( 2, ISEED, MC, C( 1, J ) )
10 CONTINUE
CNORM = DLANGE( '1', MC, NC, C, LDA, RWORK )
IF( CNORM.EQ.0.0D0 )
$ CNORM = ONE
*
DO 20 ITRANS = 1, 2
IF( ITRANS.EQ.1 ) THEN
TRANS = 'N'
ELSE
TRANS = 'T'
END IF
*
* Copy C
*
CALL DLACPY( 'Full', MC, NC, C, LDA, CC, LDA )
*
* Apply Q or Q' to C
*
SRNAMT = 'DORMQL'
IF( K.GT.0 )
$ CALL DORMQL( SIDE, TRANS, MC, NC, K, AF( 1, N-K+1 ), LDA,
$ TAU( MINMN-K+1 ), CC, LDA, WORK, LWORK,
$ INFO )
*
* Form explicit product and subtract
*
IF( LSAME( SIDE, 'L' ) ) THEN
CALL DGEMM( TRANS, 'No transpose', MC, NC, MC, -ONE, Q,
$ LDA, C, LDA, ONE, CC, LDA )
ELSE
CALL DGEMM( 'No transpose', TRANS, MC, NC, NC, -ONE, C,
$ LDA, Q, LDA, ONE, CC, LDA )
END IF
*
* Compute error in the difference
*
RESID = DLANGE( '1', MC, NC, CC, LDA, RWORK )
RESULT( ( ISIDE-1 )*2+ITRANS ) = RESID /
$ ( DBLE( MAX( 1, M ) )*CNORM*EPS )
*
20 CONTINUE
30 CONTINUE
*
RETURN
*
* End of DQLT03
*
END
DOUBLE PRECISION FUNCTION DQPT01( M, N, K, A, AF, LDA, TAU, JPVT,
$ WORK, LWORK )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
INTEGER JPVT( * )
DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* DQPT01 tests the QR-factorization with pivoting of a matrix A. The
* array AF contains the (possibly partial) QR-factorization of A, where
* the upper triangle of AF(1:k,1:k) is a partial triangular factor,
* the entries below the diagonal in the first k columns are the
* Householder vectors, and the rest of AF contains a partially updated
* matrix.
*
* This function returns ||A*P - Q*R||/(||norm(A)||*eps*M)
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrices A and AF.
*
* N (input) INTEGER
* The number of columns of the matrices A and AF.
*
* K (input) INTEGER
* The number of columns of AF that have been reduced
* to upper triangular form.
*
* A (input) DOUBLE PRECISION array, dimension (LDA, N)
* The original matrix A.
*
* AF (input) DOUBLE PRECISION array, dimension (LDA,N)
* The (possibly partial) output of DGEQPF. The upper triangle
* of AF(1:k,1:k) is a partial triangular factor, the entries
* below the diagonal in the first k columns are the Householder
* vectors, and the rest of AF contains a partially updated
* matrix.
*
* LDA (input) INTEGER
* The leading dimension of the arrays A and AF.
*
* TAU (input) DOUBLE PRECISION array, dimension (K)
* Details of the Householder transformations as returned by
* DGEQPF.
*
* JPVT (input) INTEGER array, dimension (N)
* Pivot information as returned by DGEQPF.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of the array WORK. LWORK >= M*N+N.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
DOUBLE PRECISION NORMA
* ..
* .. Local Arrays ..
DOUBLE PRECISION RWORK( 1 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DORMQR, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
DQPT01 = ZERO
*
* Test if there is enough workspace
*
IF( LWORK.LT.M*N+N ) THEN
CALL XERBLA( 'DQPT01', 10 )
RETURN
END IF
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
NORMA = DLANGE( 'One-norm', M, N, A, LDA, RWORK )
*
DO 30 J = 1, K
DO 10 I = 1, MIN( J, M )
WORK( ( J-1 )*M+I ) = AF( I, J )
10 CONTINUE
DO 20 I = J + 1, M
WORK( ( J-1 )*M+I ) = ZERO
20 CONTINUE
30 CONTINUE
DO 40 J = K + 1, N
CALL DCOPY( M, AF( 1, J ), 1, WORK( ( J-1 )*M+1 ), 1 )
40 CONTINUE
*
CALL DORMQR( 'Left', 'No transpose', M, N, K, AF, LDA, TAU, WORK,
$ M, WORK( M*N+1 ), LWORK-M*N, INFO )
*
DO 50 J = 1, N
*
* Compare i-th column of QR and jpvt(i)-th column of A
*
CALL DAXPY( M, -ONE, A( 1, JPVT( J ) ), 1, WORK( ( J-1 )*M+1 ),
$ 1 )
50 CONTINUE
*
DQPT01 = DLANGE( 'One-norm', M, N, WORK, M, RWORK ) /
$ ( DBLE( MAX( M, N ) )*DLAMCH( 'Epsilon' ) )
IF( NORMA.NE.ZERO )
$ DQPT01 = DQPT01 / NORMA
*
RETURN
*
* End of DQPT01
*
END
SUBROUTINE DQRT01( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK,
$ RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), Q( LDA, * ),
$ R( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* DQRT01 tests DGEQRF, which computes the QR factorization of an m-by-n
* matrix A, and partially tests DORGQR which forms the m-by-m
* orthogonal matrix Q.
*
* DQRT01 compares R with Q'*A, and checks that Q is orthogonal.
*
* 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) DOUBLE PRECISION array, dimension (LDA,N)
* The m-by-n matrix A.
*
* AF (output) DOUBLE PRECISION array, dimension (LDA,N)
* Details of the QR factorization of A, as returned by DGEQRF.
* See DGEQRF for further details.
*
* Q (output) DOUBLE PRECISION array, dimension (LDA,M)
* The m-by-m orthogonal matrix Q.
*
* R (workspace) DOUBLE PRECISION array, dimension (LDA,max(M,N))
*
* LDA (input) INTEGER
* The leading dimension of the arrays A, AF, Q and R.
* LDA >= max(M,N).
*
* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
* The scalar factors of the elementary reflectors, as returned
* by DGEQRF.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (M)
*
* RESULT (output) DOUBLE PRECISION array, dimension (2)
* The test ratios:
* RESULT(1) = norm( R - Q'*A ) / ( M * norm(A) * EPS )
* RESULT(2) = norm( I - Q'*Q ) / ( M * EPS )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION ROGUE
PARAMETER ( ROGUE = -1.0D+10 )
* ..
* .. Local Scalars ..
INTEGER INFO, MINMN
DOUBLE PRECISION ANORM, EPS, RESID
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
EXTERNAL DLAMCH, DLANGE, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DGEQRF, DLACPY, DLASET, DORGQR, DSYRK
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Scalars in Common ..
CHARACTER*6 SRNAMT
* ..
* .. Common blocks ..
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
MINMN = MIN( M, N )
EPS = DLAMCH( 'Epsilon' )
*
* Copy the matrix A to the array AF.
*
CALL DLACPY( 'Full', M, N, A, LDA, AF, LDA )
*
* Factorize the matrix A in the array AF.
*
SRNAMT = 'DGEQRF'
CALL DGEQRF( M, N, AF, LDA, TAU, WORK, LWORK, INFO )
*
* Copy details of Q
*
CALL DLASET( 'Full', M, M, ROGUE, ROGUE, Q, LDA )
CALL DLACPY( 'Lower', M-1, N, AF( 2, 1 ), LDA, Q( 2, 1 ), LDA )
*
* Generate the m-by-m matrix Q
*
SRNAMT = 'DORGQR'
CALL DORGQR( M, M, MINMN, Q, LDA, TAU, WORK, LWORK, INFO )
*
* Copy R
*
CALL DLASET( 'Full', M, N, ZERO, ZERO, R, LDA )
CALL DLACPY( 'Upper', M, N, AF, LDA, R, LDA )
*
* Compute R - Q'*A
*
CALL DGEMM( 'Transpose', 'No transpose', M, N, M, -ONE, Q, LDA, A,
$ LDA, ONE, R, LDA )
*
* Compute norm( R - Q'*A ) / ( M * norm(A) * EPS ) .
*
ANORM = DLANGE( '1', M, N, A, LDA, RWORK )
RESID = DLANGE( '1', M, N, R, LDA, RWORK )
IF( ANORM.GT.ZERO ) THEN
RESULT( 1 ) = ( ( RESID / DBLE( MAX( 1, M ) ) ) / ANORM ) / EPS
ELSE
RESULT( 1 ) = ZERO
END IF
*
* Compute I - Q'*Q
*
CALL DLASET( 'Full', M, M, ZERO, ONE, R, LDA )
CALL DSYRK( 'Upper', 'Transpose', M, M, -ONE, Q, LDA, ONE, R,
$ LDA )
*
* Compute norm( I - Q'*Q ) / ( M * EPS ) .
*
RESID = DLANSY( '1', 'Upper', M, R, LDA, RWORK )
*
RESULT( 2 ) = ( RESID / DBLE( MAX( 1, M ) ) ) / EPS
*
RETURN
*
* End of DQRT01
*
END
SUBROUTINE DQRT02( M, N, K, A, AF, Q, R, LDA, TAU, WORK, LWORK,
$ RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), Q( LDA, * ),
$ R( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* DQRT02 tests DORGQR, which generates an m-by-n matrix Q with
* orthonornmal columns that is defined as the product of k elementary
* reflectors.
*
* Given the QR factorization of an m-by-n matrix A, DQRT02 generates
* the orthogonal matrix Q defined by the factorization of the first k
* columns of A; it compares R(1:n,1:k) with Q(1:m,1:n)'*A(1:m,1:k),
* and checks that the columns of Q are orthonormal.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix Q to be generated. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix Q to be generated.
* M >= N >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* matrix Q. N >= K >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The m-by-n matrix A which was factorized by DQRT01.
*
* AF (input) DOUBLE PRECISION array, dimension (LDA,N)
* Details of the QR factorization of A, as returned by DGEQRF.
* See DGEQRF for further details.
*
* Q (workspace) DOUBLE PRECISION array, dimension (LDA,N)
*
* R (workspace) DOUBLE PRECISION array, dimension (LDA,N)
*
* LDA (input) INTEGER
* The leading dimension of the arrays A, AF, Q and R. LDA >= M.
*
* TAU (input) DOUBLE PRECISION array, dimension (N)
* The scalar factors of the elementary reflectors corresponding
* to the QR factorization in AF.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (M)
*
* RESULT (output) DOUBLE PRECISION array, dimension (2)
* The test ratios:
* RESULT(1) = norm( R - Q'*A ) / ( M * norm(A) * EPS )
* RESULT(2) = norm( I - Q'*Q ) / ( M * EPS )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION ROGUE
PARAMETER ( ROGUE = -1.0D+10 )
* ..
* .. Local Scalars ..
INTEGER INFO
DOUBLE PRECISION ANORM, EPS, RESID
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
EXTERNAL DLAMCH, DLANGE, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLACPY, DLASET, DORGQR, DSYRK
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX
* ..
* .. Scalars in Common ..
CHARACTER*6 SRNAMT
* ..
* .. Common blocks ..
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
EPS = DLAMCH( 'Epsilon' )
*
* Copy the first k columns of the factorization to the array Q
*
CALL DLASET( 'Full', M, N, ROGUE, ROGUE, Q, LDA )
CALL DLACPY( 'Lower', M-1, K, AF( 2, 1 ), LDA, Q( 2, 1 ), LDA )
*
* Generate the first n columns of the matrix Q
*
SRNAMT = 'DORGQR'
CALL DORGQR( M, N, K, Q, LDA, TAU, WORK, LWORK, INFO )
*
* Copy R(1:n,1:k)
*
CALL DLASET( 'Full', N, K, ZERO, ZERO, R, LDA )
CALL DLACPY( 'Upper', N, K, AF, LDA, R, LDA )
*
* Compute R(1:n,1:k) - Q(1:m,1:n)' * A(1:m,1:k)
*
CALL DGEMM( 'Transpose', 'No transpose', N, K, M, -ONE, Q, LDA, A,
$ LDA, ONE, R, LDA )
*
* Compute norm( R - Q'*A ) / ( M * norm(A) * EPS ) .
*
ANORM = DLANGE( '1', M, K, A, LDA, RWORK )
RESID = DLANGE( '1', N, K, R, LDA, RWORK )
IF( ANORM.GT.ZERO ) THEN
RESULT( 1 ) = ( ( RESID / DBLE( MAX( 1, M ) ) ) / ANORM ) / EPS
ELSE
RESULT( 1 ) = ZERO
END IF
*
* Compute I - Q'*Q
*
CALL DLASET( 'Full', N, N, ZERO, ONE, R, LDA )
CALL DSYRK( 'Upper', 'Transpose', N, M, -ONE, Q, LDA, ONE, R,
$ LDA )
*
* Compute norm( I - Q'*Q ) / ( M * EPS ) .
*
RESID = DLANSY( '1', 'Upper', N, R, LDA, RWORK )
*
RESULT( 2 ) = ( RESID / DBLE( MAX( 1, M ) ) ) / EPS
*
RETURN
*
* End of DQRT02
*
END
SUBROUTINE DQRT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK,
$ RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AF( LDA, * ), C( LDA, * ), CC( LDA, * ),
$ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* DQRT03 tests DORMQR, which computes Q*C, Q'*C, C*Q or C*Q'.
*
* DQRT03 compares the results of a call to DORMQR with the results of
* forming Q explicitly by a call to DORGQR and then performing matrix
* multiplication by a call to DGEMM.
*
* Arguments
* =========
*
* M (input) INTEGER
* The order of the orthogonal matrix Q. M >= 0.
*
* N (input) INTEGER
* The number of rows or columns of the matrix C; C is m-by-n if
* Q is applied from the left, or n-by-m if Q is applied from
* the right. N >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* orthogonal matrix Q. M >= K >= 0.
*
* AF (input) DOUBLE PRECISION array, dimension (LDA,N)
* Details of the QR factorization of an m-by-n matrix, as
* returnedby DGEQRF. See SGEQRF for further details.
*
* C (workspace) DOUBLE PRECISION array, dimension (LDA,N)
*
* CC (workspace) DOUBLE PRECISION array, dimension (LDA,N)
*
* Q (workspace) DOUBLE PRECISION array, dimension (LDA,M)
*
* LDA (input) INTEGER
* The leading dimension of the arrays AF, C, CC, and Q.
*
* TAU (input) DOUBLE PRECISION array, dimension (min(M,N))
* The scalar factors of the elementary reflectors corresponding
* to the QR factorization in AF.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of WORK. LWORK must be at least M, and should be
* M*NB, where NB is the blocksize for this environment.
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (M)
*
* RESULT (output) DOUBLE PRECISION array, dimension (4)
* The test ratios compare two techniques for multiplying a
* random matrix C by an m-by-m orthogonal matrix Q.
* RESULT(1) = norm( Q*C - Q*C ) / ( M * norm(C) * EPS )
* RESULT(2) = norm( C*Q - C*Q ) / ( M * norm(C) * EPS )
* RESULT(3) = norm( Q'*C - Q'*C )/ ( M * norm(C) * EPS )
* RESULT(4) = norm( C*Q' - C*Q' )/ ( M * norm(C) * EPS )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION ROGUE
PARAMETER ( ROGUE = -1.0D+10 )
* ..
* .. Local Scalars ..
CHARACTER SIDE, TRANS
INTEGER INFO, ISIDE, ITRANS, J, MC, NC
DOUBLE PRECISION CNORM, EPS, RESID
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL LSAME, DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLACPY, DLARNV, DLASET, DORGQR, DORMQR
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 )
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX
* ..
* .. Scalars in Common ..
CHARACTER*6 SRNAMT
* ..
* .. Common blocks ..
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEED / 1988, 1989, 1990, 1991 /
* ..
* .. Executable Statements ..
*
EPS = DLAMCH( 'Epsilon' )
*
* Copy the first k columns of the factorization to the array Q
*
CALL DLASET( 'Full', M, M, ROGUE, ROGUE, Q, LDA )
CALL DLACPY( 'Lower', M-1, K, AF( 2, 1 ), LDA, Q( 2, 1 ), LDA )
*
* Generate the m-by-m matrix Q
*
SRNAMT = 'DORGQR'
CALL DORGQR( M, M, K, Q, LDA, TAU, WORK, LWORK, INFO )
*
DO 30 ISIDE = 1, 2
IF( ISIDE.EQ.1 ) THEN
SIDE = 'L'
MC = M
NC = N
ELSE
SIDE = 'R'
MC = N
NC = M
END IF
*
* Generate MC by NC matrix C
*
DO 10 J = 1, NC
CALL DLARNV( 2, ISEED, MC, C( 1, J ) )
10 CONTINUE
CNORM = DLANGE( '1', MC, NC, C, LDA, RWORK )
IF( CNORM.EQ.0.0D0 )
$ CNORM = ONE
*
DO 20 ITRANS = 1, 2
IF( ITRANS.EQ.1 ) THEN
TRANS = 'N'
ELSE
TRANS = 'T'
END IF
*
* Copy C
*
CALL DLACPY( 'Full', MC, NC, C, LDA, CC, LDA )
*
* Apply Q or Q' to C
*
SRNAMT = 'DORMQR'
CALL DORMQR( SIDE, TRANS, MC, NC, K, AF, LDA, TAU, CC, LDA,
$ WORK, LWORK, INFO )
*
* Form explicit product and subtract
*
IF( LSAME( SIDE, 'L' ) ) THEN
CALL DGEMM( TRANS, 'No transpose', MC, NC, MC, -ONE, Q,
$ LDA, C, LDA, ONE, CC, LDA )
ELSE
CALL DGEMM( 'No transpose', TRANS, MC, NC, NC, -ONE, C,
$ LDA, Q, LDA, ONE, CC, LDA )
END IF
*
* Compute error in the difference
*
RESID = DLANGE( '1', MC, NC, CC, LDA, RWORK )
RESULT( ( ISIDE-1 )*2+ITRANS ) = RESID /
$ ( DBLE( MAX( 1, M ) )*CNORM*EPS )
*
20 CONTINUE
30 CONTINUE
*
RETURN
*
* End of DQRT03
*
END
DOUBLE PRECISION FUNCTION DQRT11( M, K, A, LDA, TAU, WORK, LWORK )
*
* -- LAPACK routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER K, LDA, LWORK, M
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK )
* ..
*
* Purpose
* =======
*
* DQRT11 computes the test ratio
*
* || Q'*Q - I || / (eps * m)
*
* where the orthogonal matrix Q is represented as a product of
* elementary transformations. Each transformation has the form
*
* H(k) = I - tau(k) v(k) v(k)'
*
* where tau(k) is stored in TAU(k) and v(k) is an m-vector of the form
* [ 0 ... 0 1 x(k) ]', where x(k) is a vector of length m-k stored
* in A(k+1:m,k).
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix A.
*
* K (input) INTEGER
* The number of columns of A whose subdiagonal entries
* contain information about orthogonal transformations.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,K)
* The (possibly partial) output of a QR reduction routine.
*
* LDA (input) INTEGER
* The leading dimension of the array A.
*
* TAU (input) DOUBLE PRECISION array, dimension (K)
* The scaling factors tau for the elementary transformations as
* computed by the QR factorization routine.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of the array WORK. LWORK >= M*M + M.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
INTEGER INFO, J
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DLASET, DORM2R, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Local Arrays ..
DOUBLE PRECISION RDUMMY( 1 )
* ..
* .. Executable Statements ..
*
DQRT11 = ZERO
*
* Test for sufficient workspace
*
IF( LWORK.LT.M*M+M ) THEN
CALL XERBLA( 'DQRT11', 7 )
RETURN
END IF
*
* Quick return if possible
*
IF( M.LE.0 )
$ RETURN
*
CALL DLASET( 'Full', M, M, ZERO, ONE, WORK, M )
*
* Form Q
*
CALL DORM2R( 'Left', 'No transpose', M, M, K, A, LDA, TAU, WORK,
$ M, WORK( M*M+1 ), INFO )
*
* Form Q'*Q
*
CALL DORM2R( 'Left', 'Transpose', M, M, K, A, LDA, TAU, WORK, M,
$ WORK( M*M+1 ), INFO )
*
DO 10 J = 1, M
WORK( ( J-1 )*M+J ) = WORK( ( J-1 )*M+J ) - ONE
10 CONTINUE
*
DQRT11 = DLANGE( 'One-norm', M, M, WORK, M, RDUMMY ) /
$ ( DBLE( M )*DLAMCH( 'Epsilon' ) )
*
RETURN
*
* End of DQRT11
*
END
DOUBLE PRECISION FUNCTION DQRT12( M, N, A, LDA, S, WORK, LWORK )
*
* -- LAPACK test routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* January 2007
*
* .. Scalar Arguments ..
INTEGER LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), S( * ), WORK( LWORK )
* ..
*
* Purpose
* =======
*
* DQRT12 computes the singular values `svlues' of the upper trapezoid
* of A(1:M,1:N) and returns the ratio
*
* || s - svlues||/(||svlues||*eps*max(M,N))
*
* 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. Only the upper trapezoid is referenced.
*
* LDA (input) INTEGER
* The leading dimension of the array A.
*
* S (input) DOUBLE PRECISION array, dimension (min(M,N))
* The singular values of the matrix A.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of the array WORK. LWORK >= max(M*N + 4*min(M,N) +
* max(M,N), M*N+2*MIN( M, N )+4*N).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, ISCL, J, MN
DOUBLE PRECISION ANRM, BIGNUM, NRMSVL, SMLNUM
* ..
* .. External Functions ..
DOUBLE PRECISION DASUM, DLAMCH, DLANGE, DNRM2
EXTERNAL DASUM, DLAMCH, DLANGE, DNRM2
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DBDSQR, DGEBD2, DLABAD, DLASCL, DLASET,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Local Arrays ..
DOUBLE PRECISION DUMMY( 1 )
* ..
* .. Executable Statements ..
*
DQRT12 = ZERO
*
* Test that enough workspace is supplied
*
IF( LWORK.LT.MAX( M*N+4*MIN( M, N )+MAX( M, N ),
$ M*N+2*MIN( M, N )+4*N) ) THEN
CALL XERBLA( 'DQRT12', 7 )
RETURN
END IF
*
* Quick return if possible
*
MN = MIN( M, N )
IF( MN.LE.ZERO )
$ RETURN
*
NRMSVL = DNRM2( MN, S, 1 )
*
* Copy upper triangle of A into work
*
CALL DLASET( 'Full', M, N, ZERO, ZERO, WORK, M )
DO 20 J = 1, N
DO 10 I = 1, MIN( J, M )
WORK( ( J-1 )*M+I ) = A( I, J )
10 CONTINUE
20 CONTINUE
*
* Get machine parameters
*
SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' )
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
*
* Scale work if max entry outside range [SMLNUM,BIGNUM]
*
ANRM = DLANGE( 'M', M, N, WORK, M, DUMMY )
ISCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, WORK, M, INFO )
ISCL = 1
ELSE IF( ANRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM
*
CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, WORK, M, INFO )
ISCL = 1
END IF
*
IF( ANRM.NE.ZERO ) THEN
*
* Compute SVD of work
*
CALL DGEBD2( M, N, WORK, M, WORK( M*N+1 ), WORK( M*N+MN+1 ),
$ WORK( M*N+2*MN+1 ), WORK( M*N+3*MN+1 ),
$ WORK( M*N+4*MN+1 ), INFO )
CALL DBDSQR( 'Upper', MN, 0, 0, 0, WORK( M*N+1 ),
$ WORK( M*N+MN+1 ), DUMMY, MN, DUMMY, 1, DUMMY, MN,
$ WORK( M*N+2*MN+1 ), INFO )
*
IF( ISCL.EQ.1 ) THEN
IF( ANRM.GT.BIGNUM ) THEN
CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MN, 1,
$ WORK( M*N+1 ), MN, INFO )
END IF
IF( ANRM.LT.SMLNUM ) THEN
CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MN, 1,
$ WORK( M*N+1 ), MN, INFO )
END IF
END IF
*
ELSE
*
DO 30 I = 1, MN
WORK( M*N+I ) = ZERO
30 CONTINUE
END IF
*
* Compare s and singular values of work
*
CALL DAXPY( MN, -ONE, S, 1, WORK( M*N+1 ), 1 )
DQRT12 = DASUM( MN, WORK( M*N+1 ), 1 ) /
$ ( DLAMCH( 'Epsilon' )*DBLE( MAX( M, N ) ) )
IF( NRMSVL.NE.ZERO )
$ DQRT12 = DQRT12 / NRMSVL
*
RETURN
*
* End of DQRT12
*
END
SUBROUTINE DQRT13( SCALE, M, N, A, LDA, NORMA, ISEED )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, M, N, SCALE
DOUBLE PRECISION NORMA
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
DOUBLE PRECISION A( LDA, * )
* ..
*
* Purpose
* =======
*
* DQRT13 generates a full-rank matrix that may be scaled to have large
* or small norm.
*
* Arguments
* =========
*
* SCALE (input) INTEGER
* SCALE = 1: normally scaled matrix
* SCALE = 2: matrix scaled up
* SCALE = 3: matrix scaled down
*
* M (input) INTEGER
* The number of rows of the matrix A.
*
* N (input) INTEGER
* The number of columns of A.
*
* A (output) DOUBLE PRECISION array, dimension (LDA,N)
* The M-by-N matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A.
*
* NORMA (output) DOUBLE PRECISION
* The one-norm of A.
*
* ISEED (input/output) integer array, dimension (4)
* Seed for random number generator
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
* ..
* .. Local Scalars ..
INTEGER INFO, J
DOUBLE PRECISION BIGNUM, SMLNUM
* ..
* .. External Functions ..
DOUBLE PRECISION DASUM, DLAMCH, DLANGE
EXTERNAL DASUM, DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DLABAD, DLARNV, DLASCL
* ..
* .. Intrinsic Functions ..
INTRINSIC SIGN
* ..
* .. Local Arrays ..
DOUBLE PRECISION DUMMY( 1 )
* ..
* .. Executable Statements ..
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
* benign matrix
*
DO 10 J = 1, N
CALL DLARNV( 2, ISEED, M, A( 1, J ) )
IF( J.LE.M ) THEN
A( J, J ) = A( J, J ) + SIGN( DASUM( M, A( 1, J ), 1 ),
$ A( J, J ) )
END IF
10 CONTINUE
*
* scaled versions
*
IF( SCALE.NE.1 ) THEN
NORMA = DLANGE( 'Max', M, N, A, LDA, DUMMY )
SMLNUM = DLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
SMLNUM = SMLNUM / DLAMCH( 'Epsilon' )
BIGNUM = ONE / SMLNUM
*
IF( SCALE.EQ.2 ) THEN
*
* matrix scaled up
*
CALL DLASCL( 'General', 0, 0, NORMA, BIGNUM, M, N, A, LDA,
$ INFO )
ELSE IF( SCALE.EQ.3 ) THEN
*
* matrix scaled down
*
CALL DLASCL( 'General', 0, 0, NORMA, SMLNUM, M, N, A, LDA,
$ INFO )
END IF
END IF
*
NORMA = DLANGE( 'One-norm', M, N, A, LDA, DUMMY )
RETURN
*
* End of DQRT13
*
END
DOUBLE PRECISION FUNCTION DQRT14( TRANS, M, N, NRHS, A, LDA, X,
$ LDX, WORK, LWORK )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER LDA, LDX, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), WORK( LWORK ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* DQRT14 checks whether X is in the row space of A or A'. It does so
* by scaling both X and A such that their norms are in the range
* [sqrt(eps), 1/sqrt(eps)], then computing a QR factorization of [A,X]
* (if TRANS = 'T') or an LQ factorization of [A',X]' (if TRANS = 'N'),
* and returning the norm of the trailing triangle, scaled by
* MAX(M,N,NRHS)*eps.
*
* Arguments
* =========
*
* TRANS (input) CHARACTER*1
* = 'N': No transpose, check for X in the row space of A
* = 'T': Transpose, check for X in the row space of A'.
*
* M (input) INTEGER
* The number of rows of the matrix A.
*
* N (input) INTEGER
* The number of columns of the matrix A.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of X.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The M-by-N matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A.
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* If TRANS = 'N', the N-by-NRHS matrix X.
* IF TRANS = 'T', the M-by-NRHS matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X.
*
* WORK (workspace) DOUBLE PRECISION array dimension (LWORK)
*
* LWORK (input) INTEGER
* length of workspace array required
* If TRANS = 'N', LWORK >= (M+NRHS)*(N+2);
* if TRANS = 'T', LWORK >= (N+NRHS)*(M+2).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL TPSD
INTEGER I, INFO, J, LDWORK
DOUBLE PRECISION ANRM, ERR, XNRM
* ..
* .. Local Arrays ..
DOUBLE PRECISION RWORK( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL LSAME, DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DGELQ2, DGEQR2, DLACPY, DLASCL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
DQRT14 = ZERO
IF( LSAME( TRANS, 'N' ) ) THEN
LDWORK = M + NRHS
TPSD = .FALSE.
IF( LWORK.LT.( M+NRHS )*( N+2 ) ) THEN
CALL XERBLA( 'DQRT14', 10 )
RETURN
ELSE IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RETURN
END IF
ELSE IF( LSAME( TRANS, 'T' ) ) THEN
LDWORK = M
TPSD = .TRUE.
IF( LWORK.LT.( N+NRHS )*( M+2 ) ) THEN
CALL XERBLA( 'DQRT14', 10 )
RETURN
ELSE IF( M.LE.0 .OR. NRHS.LE.0 ) THEN
RETURN
END IF
ELSE
CALL XERBLA( 'DQRT14', 1 )
RETURN
END IF
*
* Copy and scale A
*
CALL DLACPY( 'All', M, N, A, LDA, WORK, LDWORK )
ANRM = DLANGE( 'M', M, N, WORK, LDWORK, RWORK )
IF( ANRM.NE.ZERO )
$ CALL DLASCL( 'G', 0, 0, ANRM, ONE, M, N, WORK, LDWORK, INFO )
*
* Copy X or X' into the right place and scale it
*
IF( TPSD ) THEN
*
* Copy X into columns n+1:n+nrhs of work
*
CALL DLACPY( 'All', M, NRHS, X, LDX, WORK( N*LDWORK+1 ),
$ LDWORK )
XNRM = DLANGE( 'M', M, NRHS, WORK( N*LDWORK+1 ), LDWORK,
$ RWORK )
IF( XNRM.NE.ZERO )
$ CALL DLASCL( 'G', 0, 0, XNRM, ONE, M, NRHS,
$ WORK( N*LDWORK+1 ), LDWORK, INFO )
ANRM = DLANGE( 'One-norm', M, N+NRHS, WORK, LDWORK, RWORK )
*
* Compute QR factorization of X
*
CALL DGEQR2( M, N+NRHS, WORK, LDWORK,
$ WORK( LDWORK*( N+NRHS )+1 ),
$ WORK( LDWORK*( N+NRHS )+MIN( M, N+NRHS )+1 ),
$ INFO )
*
* Compute largest entry in upper triangle of
* work(n+1:m,n+1:n+nrhs)
*
ERR = ZERO
DO 20 J = N + 1, N + NRHS
DO 10 I = N + 1, MIN( M, J )
ERR = MAX( ERR, ABS( WORK( I+( J-1 )*M ) ) )
10 CONTINUE
20 CONTINUE
*
ELSE
*
* Copy X' into rows m+1:m+nrhs of work
*
DO 40 I = 1, N
DO 30 J = 1, NRHS
WORK( M+J+( I-1 )*LDWORK ) = X( I, J )
30 CONTINUE
40 CONTINUE
*
XNRM = DLANGE( 'M', NRHS, N, WORK( M+1 ), LDWORK, RWORK )
IF( XNRM.NE.ZERO )
$ CALL DLASCL( 'G', 0, 0, XNRM, ONE, NRHS, N, WORK( M+1 ),
$ LDWORK, INFO )
*
* Compute LQ factorization of work
*
CALL DGELQ2( LDWORK, N, WORK, LDWORK, WORK( LDWORK*N+1 ),
$ WORK( LDWORK*( N+1 )+1 ), INFO )
*
* Compute largest entry in lower triangle in
* work(m+1:m+nrhs,m+1:n)
*
ERR = ZERO
DO 60 J = M + 1, N
DO 50 I = J, LDWORK
ERR = MAX( ERR, ABS( WORK( I+( J-1 )*LDWORK ) ) )
50 CONTINUE
60 CONTINUE
*
END IF
*
DQRT14 = ERR / ( DBLE( MAX( M, N, NRHS ) )*DLAMCH( 'Epsilon' ) )
*
RETURN
*
* End of DQRT14
*
END
SUBROUTINE DQRT15( SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S,
$ RANK, NORMA, NORMB, ISEED, WORK, LWORK )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDB, LWORK, M, N, NRHS, RANK, RKSEL, SCALE
DOUBLE PRECISION NORMA, NORMB
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( LWORK )
* ..
*
* Purpose
* =======
*
* DQRT15 generates a matrix with full or deficient rank and of various
* norms.
*
* Arguments
* =========
*
* SCALE (input) INTEGER
* SCALE = 1: normally scaled matrix
* SCALE = 2: matrix scaled up
* SCALE = 3: matrix scaled down
*
* RKSEL (input) INTEGER
* RKSEL = 1: full rank matrix
* RKSEL = 2: rank-deficient matrix
*
* M (input) INTEGER
* The number of rows of the matrix A.
*
* N (input) INTEGER
* The number of columns of A.
*
* NRHS (input) INTEGER
* The number of columns of B.
*
* A (output) DOUBLE PRECISION array, dimension (LDA,N)
* The M-by-N matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A.
*
* B (output) DOUBLE PRECISION array, dimension (LDB, NRHS)
* A matrix that is in the range space of matrix A.
*
* LDB (input) INTEGER
* The leading dimension of the array B.
*
* S (output) DOUBLE PRECISION array, dimension MIN(M,N)
* Singular values of A.
*
* RANK (output) INTEGER
* number of nonzero singular values of A.
*
* NORMA (output) DOUBLE PRECISION
* one-norm of A.
*
* NORMB (output) DOUBLE PRECISION
* one-norm of B.
*
* ISEED (input/output) integer array, dimension (4)
* seed for random number generator.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* length of work space required.
* LWORK >= MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M)
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, SVMIN
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ SVMIN = 0.1D0 )
* ..
* .. Local Scalars ..
INTEGER INFO, J, MN
DOUBLE PRECISION BIGNUM, EPS, SMLNUM, TEMP
* ..
* .. Local Arrays ..
DOUBLE PRECISION DUMMY( 1 )
* ..
* .. External Functions ..
DOUBLE PRECISION DASUM, DLAMCH, DLANGE, DLARND, DNRM2
EXTERNAL DASUM, DLAMCH, DLANGE, DLARND, DNRM2
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLAORD, DLARF, DLARNV, DLAROR, DLASCL,
$ DLASET, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
MN = MIN( M, N )
IF( LWORK.LT.MAX( M+MN, MN*NRHS, 2*N+M ) ) THEN
CALL XERBLA( 'DQRT15', 16 )
RETURN
END IF
*
SMLNUM = DLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
EPS = DLAMCH( 'Epsilon' )
SMLNUM = ( SMLNUM / EPS ) / EPS
BIGNUM = ONE / SMLNUM
*
* Determine rank and (unscaled) singular values
*
IF( RKSEL.EQ.1 ) THEN
RANK = MN
ELSE IF( RKSEL.EQ.2 ) THEN
RANK = ( 3*MN ) / 4
DO 10 J = RANK + 1, MN
S( J ) = ZERO
10 CONTINUE
ELSE
CALL XERBLA( 'DQRT15', 2 )
END IF
*
IF( RANK.GT.0 ) THEN
*
* Nontrivial case
*
S( 1 ) = ONE
DO 30 J = 2, RANK
20 CONTINUE
TEMP = DLARND( 1, ISEED )
IF( TEMP.GT.SVMIN ) THEN
S( J ) = ABS( TEMP )
ELSE
GO TO 20
END IF
30 CONTINUE
CALL DLAORD( 'Decreasing', RANK, S, 1 )
*
* Generate 'rank' columns of a random orthogonal matrix in A
*
CALL DLARNV( 2, ISEED, M, WORK )
CALL DSCAL( M, ONE / DNRM2( M, WORK, 1 ), WORK, 1 )
CALL DLASET( 'Full', M, RANK, ZERO, ONE, A, LDA )
CALL DLARF( 'Left', M, RANK, WORK, 1, TWO, A, LDA,
$ WORK( M+1 ) )
*
* workspace used: m+mn
*
* Generate consistent rhs in the range space of A
*
CALL DLARNV( 2, ISEED, RANK*NRHS, WORK )
CALL DGEMM( 'No transpose', 'No transpose', M, NRHS, RANK, ONE,
$ A, LDA, WORK, RANK, ZERO, B, LDB )
*
* work space used: <= mn *nrhs
*
* generate (unscaled) matrix A
*
DO 40 J = 1, RANK
CALL DSCAL( M, S( J ), A( 1, J ), 1 )
40 CONTINUE
IF( RANK.LT.N )
$ CALL DLASET( 'Full', M, N-RANK, ZERO, ZERO, A( 1, RANK+1 ),
$ LDA )
CALL DLAROR( 'Right', 'No initialization', M, N, A, LDA, ISEED,
$ WORK, INFO )
*
ELSE
*
* work space used 2*n+m
*
* Generate null matrix and rhs
*
DO 50 J = 1, MN
S( J ) = ZERO
50 CONTINUE
CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA )
CALL DLASET( 'Full', M, NRHS, ZERO, ZERO, B, LDB )
*
END IF
*
* Scale the matrix
*
IF( SCALE.NE.1 ) THEN
NORMA = DLANGE( 'Max', M, N, A, LDA, DUMMY )
IF( NORMA.NE.ZERO ) THEN
IF( SCALE.EQ.2 ) THEN
*
* matrix scaled up
*
CALL DLASCL( 'General', 0, 0, NORMA, BIGNUM, M, N, A,
$ LDA, INFO )
CALL DLASCL( 'General', 0, 0, NORMA, BIGNUM, MN, 1, S,
$ MN, INFO )
CALL DLASCL( 'General', 0, 0, NORMA, BIGNUM, M, NRHS, B,
$ LDB, INFO )
ELSE IF( SCALE.EQ.3 ) THEN
*
* matrix scaled down
*
CALL DLASCL( 'General', 0, 0, NORMA, SMLNUM, M, N, A,
$ LDA, INFO )
CALL DLASCL( 'General', 0, 0, NORMA, SMLNUM, MN, 1, S,
$ MN, INFO )
CALL DLASCL( 'General', 0, 0, NORMA, SMLNUM, M, NRHS, B,
$ LDB, INFO )
ELSE
CALL XERBLA( 'DQRT15', 1 )
RETURN
END IF
END IF
END IF
*
NORMA = DASUM( MN, S, 1 )
NORMB = DLANGE( 'One-norm', M, NRHS, B, LDB, DUMMY )
*
RETURN
*
* End of DQRT15
*
END
SUBROUTINE DQRT16( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB,
$ RWORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER LDA, LDB, LDX, M, N, NRHS
DOUBLE PRECISION RESID
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), RWORK( * ),
$ X( LDX, * )
* ..
*
* Purpose
* =======
*
* DQRT16 computes the residual for a solution of a system of linear
* equations A*x = b or A'*x = b:
* RESID = norm(B - A*X) / ( max(m,n) * norm(A) * norm(X) * EPS ),
* where EPS is the machine epsilon.
*
* Arguments
* =========
*
* TRANS (input) CHARACTER*1
* Specifies the form of the system of equations:
* = 'N': A *x = b
* = 'T': A'*x = b, where A' is the transpose of A
* = 'C': A'*x = b, where A' is the transpose of A
*
* 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.
*
* NRHS (input) INTEGER
* The number of columns of B, the matrix of right hand sides.
* NRHS >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The original M x N matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The computed solution vectors for the system of linear
* equations.
*
* LDX (input) INTEGER
* The leading dimension of the array X. If TRANS = 'N',
* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the right hand side vectors for the system of
* linear equations.
* On exit, B is overwritten with the difference B - A*X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. IF TRANS = 'N',
* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N).
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (M)
*
* RESID (output) DOUBLE PRECISION
* The maximum over the number of right hand sides of
* norm(B - A*X) / ( max(m,n) * norm(A) * norm(X) * EPS ).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER J, N1, N2
DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DASUM, DLAMCH, DLANGE
EXTERNAL LSAME, DASUM, DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DGEMM
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Quick exit if M = 0 or N = 0 or NRHS = 0
*
IF( M.LE.0 .OR. N.LE.0 .OR. NRHS.EQ.0 ) THEN
RESID = ZERO
RETURN
END IF
*
IF( LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) ) THEN
ANORM = DLANGE( 'I', M, N, A, LDA, RWORK )
N1 = N
N2 = M
ELSE
ANORM = DLANGE( '1', M, N, A, LDA, RWORK )
N1 = M
N2 = N
END IF
*
EPS = DLAMCH( 'Epsilon' )
*
* Compute B - A*X (or B - A'*X ) and store in B.
*
CALL DGEMM( TRANS, 'No transpose', N1, NRHS, N2, -ONE, A, LDA, X,
$ LDX, ONE, B, LDB )
*
* Compute the maximum over the number of right hand sides of
* norm(B - A*X) / ( max(m,n) * norm(A) * norm(X) * EPS ) .
*
RESID = ZERO
DO 10 J = 1, NRHS
BNORM = DASUM( N1, B( 1, J ), 1 )
XNORM = DASUM( N2, X( 1, J ), 1 )
IF( ANORM.EQ.ZERO .AND. BNORM.EQ.ZERO ) THEN
RESID = ZERO
ELSE IF( ANORM.LE.ZERO .OR. XNORM.LE.ZERO ) THEN
RESID = ONE / EPS
ELSE
RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) /
$ ( MAX( M, N )*EPS ) )
END IF
10 CONTINUE
*
RETURN
*
* End of DQRT16
*
END
DOUBLE PRECISION FUNCTION DQRT17( TRANS, IRESID, M, N, NRHS, A,
$ LDA, X, LDX, B, LDB, C, WORK, LWORK )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER IRESID, LDA, LDB, LDX, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDB, * ),
$ WORK( LWORK ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* DQRT17 computes the ratio
*
* || R'*op(A) ||/(||A||*alpha*max(M,N,NRHS)*eps)
*
* where R = op(A)*X - B, op(A) is A or A', and
*
* alpha = ||B|| if IRESID = 1 (zero-residual problem)
* alpha = ||R|| if IRESID = 2 (otherwise).
*
* Arguments
* =========
*
* TRANS (input) CHARACTER*1
* Specifies whether or not the transpose of A is used.
* = 'N': No transpose, op(A) = A.
* = 'T': Transpose, op(A) = A'.
*
* IRESID (input) INTEGER
* IRESID = 1 indicates zero-residual problem.
* IRESID = 2 indicates non-zero residual.
*
* M (input) INTEGER
* The number of rows of the matrix A.
* If TRANS = 'N', the number of rows of the matrix B.
* If TRANS = 'T', the number of rows of the matrix X.
*
* N (input) INTEGER
* The number of columns of the matrix A.
* If TRANS = 'N', the number of rows of the matrix X.
* If TRANS = 'T', the number of rows of the matrix B.
*
* NRHS (input) INTEGER
* The number of columns of the matrices X and B.
*
* 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 >= M.
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* If TRANS = 'N', the n-by-nrhs matrix X.
* If TRANS = 'T', the m-by-nrhs matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X.
* If TRANS = 'N', LDX >= N.
* If TRANS = 'T', LDX >= M.
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* If TRANS = 'N', the m-by-nrhs matrix B.
* If TRANS = 'T', the n-by-nrhs matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B.
* If TRANS = 'N', LDB >= M.
* If TRANS = 'T', LDB >= N.
*
* C (workspace) DOUBLE PRECISION array, dimension (LDB,NRHS)
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of the array WORK. LWORK >= NRHS*(M+N).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
INTEGER INFO, ISCL, NCOLS, NROWS
DOUBLE PRECISION BIGNUM, ERR, NORMA, NORMB, NORMRS, NORMX,
$ SMLNUM
* ..
* .. Local Arrays ..
DOUBLE PRECISION RWORK( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL LSAME, DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLACPY, DLASCL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX
* ..
* .. Executable Statements ..
*
DQRT17 = ZERO
*
IF( LSAME( TRANS, 'N' ) ) THEN
NROWS = M
NCOLS = N
ELSE IF( LSAME( TRANS, 'T' ) ) THEN
NROWS = N
NCOLS = M
ELSE
CALL XERBLA( 'DQRT17', 1 )
RETURN
END IF
*
IF( LWORK.LT.NCOLS*NRHS ) THEN
CALL XERBLA( 'DQRT17', 13 )
RETURN
END IF
*
IF( M.LE.0 .OR. N.LE.0 .OR. NRHS.LE.0 ) THEN
RETURN
END IF
*
NORMA = DLANGE( 'One-norm', M, N, A, LDA, RWORK )
SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
BIGNUM = ONE / SMLNUM
ISCL = 0
*
* compute residual and scale it
*
CALL DLACPY( 'All', NROWS, NRHS, B, LDB, C, LDB )
CALL DGEMM( TRANS, 'No transpose', NROWS, NRHS, NCOLS, -ONE, A,
$ LDA, X, LDX, ONE, C, LDB )
NORMRS = DLANGE( 'Max', NROWS, NRHS, C, LDB, RWORK )
IF( NORMRS.GT.SMLNUM ) THEN
ISCL = 1
CALL DLASCL( 'General', 0, 0, NORMRS, ONE, NROWS, NRHS, C, LDB,
$ INFO )
END IF
*
* compute R'*A
*
CALL DGEMM( 'Transpose', TRANS, NRHS, NCOLS, NROWS, ONE, C, LDB,
$ A, LDA, ZERO, WORK, NRHS )
*
* compute and properly scale error
*
ERR = DLANGE( 'One-norm', NRHS, NCOLS, WORK, NRHS, RWORK )
IF( NORMA.NE.ZERO )
$ ERR = ERR / NORMA
*
IF( ISCL.EQ.1 )
$ ERR = ERR*NORMRS
*
IF( IRESID.EQ.1 ) THEN
NORMB = DLANGE( 'One-norm', NROWS, NRHS, B, LDB, RWORK )
IF( NORMB.NE.ZERO )
$ ERR = ERR / NORMB
ELSE
NORMX = DLANGE( 'One-norm', NCOLS, NRHS, X, LDX, RWORK )
IF( NORMX.NE.ZERO )
$ ERR = ERR / NORMX
END IF
*
DQRT17 = ERR / ( DLAMCH( 'Epsilon' )*DBLE( MAX( M, N, NRHS ) ) )
RETURN
*
* End of DQRT17
*
END
SUBROUTINE DRQT01( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK,
$ RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), Q( LDA, * ),
$ R( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* DRQT01 tests DGERQF, which computes the RQ factorization of an m-by-n
* matrix A, and partially tests DORGRQ which forms the n-by-n
* orthogonal matrix Q.
*
* DRQT01 compares R with A*Q', and checks that Q is orthogonal.
*
* 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) DOUBLE PRECISION array, dimension (LDA,N)
* The m-by-n matrix A.
*
* AF (output) DOUBLE PRECISION array, dimension (LDA,N)
* Details of the RQ factorization of A, as returned by DGERQF.
* See DGERQF for further details.
*
* Q (output) DOUBLE PRECISION array, dimension (LDA,N)
* The n-by-n orthogonal matrix Q.
*
* R (workspace) DOUBLE PRECISION array, dimension (LDA,max(M,N))
*
* LDA (input) INTEGER
* The leading dimension of the arrays A, AF, Q and L.
* LDA >= max(M,N).
*
* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
* The scalar factors of the elementary reflectors, as returned
* by DGERQF.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (max(M,N))
*
* RESULT (output) DOUBLE PRECISION array, dimension (2)
* The test ratios:
* RESULT(1) = norm( R - A*Q' ) / ( N * norm(A) * EPS )
* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION ROGUE
PARAMETER ( ROGUE = -1.0D+10 )
* ..
* .. Local Scalars ..
INTEGER INFO, MINMN
DOUBLE PRECISION ANORM, EPS, RESID
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
EXTERNAL DLAMCH, DLANGE, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DGERQF, DLACPY, DLASET, DORGRQ, DSYRK
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Scalars in Common ..
CHARACTER*6 SRNAMT
* ..
* .. Common blocks ..
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
MINMN = MIN( M, N )
EPS = DLAMCH( 'Epsilon' )
*
* Copy the matrix A to the array AF.
*
CALL DLACPY( 'Full', M, N, A, LDA, AF, LDA )
*
* Factorize the matrix A in the array AF.
*
SRNAMT = 'DGERQF'
CALL DGERQF( M, N, AF, LDA, TAU, WORK, LWORK, INFO )
*
* Copy details of Q
*
CALL DLASET( 'Full', N, N, ROGUE, ROGUE, Q, LDA )
IF( M.LE.N ) THEN
IF( M.GT.0 .AND. M.LT.N )
$ CALL DLACPY( 'Full', M, N-M, AF, LDA, Q( N-M+1, 1 ), LDA )
IF( M.GT.1 )
$ CALL DLACPY( 'Lower', M-1, M-1, AF( 2, N-M+1 ), LDA,
$ Q( N-M+2, N-M+1 ), LDA )
ELSE
IF( N.GT.1 )
$ CALL DLACPY( 'Lower', N-1, N-1, AF( M-N+2, 1 ), LDA,
$ Q( 2, 1 ), LDA )
END IF
*
* Generate the n-by-n matrix Q
*
SRNAMT = 'DORGRQ'
CALL DORGRQ( N, N, MINMN, Q, LDA, TAU, WORK, LWORK, INFO )
*
* Copy R
*
CALL DLASET( 'Full', M, N, ZERO, ZERO, R, LDA )
IF( M.LE.N ) THEN
IF( M.GT.0 )
$ CALL DLACPY( 'Upper', M, M, AF( 1, N-M+1 ), LDA,
$ R( 1, N-M+1 ), LDA )
ELSE
IF( M.GT.N .AND. N.GT.0 )
$ CALL DLACPY( 'Full', M-N, N, AF, LDA, R, LDA )
IF( N.GT.0 )
$ CALL DLACPY( 'Upper', N, N, AF( M-N+1, 1 ), LDA,
$ R( M-N+1, 1 ), LDA )
END IF
*
* Compute R - A*Q'
*
CALL DGEMM( 'No transpose', 'Transpose', M, N, N, -ONE, A, LDA, Q,
$ LDA, ONE, R, LDA )
*
* Compute norm( R - Q'*A ) / ( N * norm(A) * EPS ) .
*
ANORM = DLANGE( '1', M, N, A, LDA, RWORK )
RESID = DLANGE( '1', M, N, R, LDA, RWORK )
IF( ANORM.GT.ZERO ) THEN
RESULT( 1 ) = ( ( RESID / DBLE( MAX( 1, N ) ) ) / ANORM ) / EPS
ELSE
RESULT( 1 ) = ZERO
END IF
*
* Compute I - Q*Q'
*
CALL DLASET( 'Full', N, N, ZERO, ONE, R, LDA )
CALL DSYRK( 'Upper', 'No transpose', N, N, -ONE, Q, LDA, ONE, R,
$ LDA )
*
* Compute norm( I - Q*Q' ) / ( N * EPS ) .
*
RESID = DLANSY( '1', 'Upper', N, R, LDA, RWORK )
*
RESULT( 2 ) = ( RESID / DBLE( MAX( 1, N ) ) ) / EPS
*
RETURN
*
* End of DRQT01
*
END
SUBROUTINE DRQT02( M, N, K, A, AF, Q, R, LDA, TAU, WORK, LWORK,
$ RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), Q( LDA, * ),
$ R( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* DRQT02 tests DORGRQ, which generates an m-by-n matrix Q with
* orthonornmal rows that is defined as the product of k elementary
* reflectors.
*
* Given the RQ factorization of an m-by-n matrix A, DRQT02 generates
* the orthogonal matrix Q defined by the factorization of the last k
* rows of A; it compares R(m-k+1:m,n-m+1:n) with
* A(m-k+1:m,1:n)*Q(n-m+1:n,1:n)', and checks that the rows of Q are
* orthonormal.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix Q to be generated. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix Q to be generated.
* N >= M >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* matrix Q. M >= K >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The m-by-n matrix A which was factorized by DRQT01.
*
* AF (input) DOUBLE PRECISION array, dimension (LDA,N)
* Details of the RQ factorization of A, as returned by DGERQF.
* See DGERQF for further details.
*
* Q (workspace) DOUBLE PRECISION array, dimension (LDA,N)
*
* R (workspace) DOUBLE PRECISION array, dimension (LDA,M)
*
* LDA (input) INTEGER
* The leading dimension of the arrays A, AF, Q and L. LDA >= N.
*
* TAU (input) DOUBLE PRECISION array, dimension (M)
* The scalar factors of the elementary reflectors corresponding
* to the RQ factorization in AF.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (M)
*
* RESULT (output) DOUBLE PRECISION array, dimension (2)
* The test ratios:
* RESULT(1) = norm( R - A*Q' ) / ( N * norm(A) * EPS )
* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION ROGUE
PARAMETER ( ROGUE = -1.0D+10 )
* ..
* .. Local Scalars ..
INTEGER INFO
DOUBLE PRECISION ANORM, EPS, RESID
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
EXTERNAL DLAMCH, DLANGE, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLACPY, DLASET, DORGRQ, DSYRK
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX
* ..
* .. Scalars in Common ..
CHARACTER*6 SRNAMT
* ..
* .. Common blocks ..
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
RESULT( 1 ) = ZERO
RESULT( 2 ) = ZERO
RETURN
END IF
*
EPS = DLAMCH( 'Epsilon' )
*
* Copy the last k rows of the factorization to the array Q
*
CALL DLASET( 'Full', M, N, ROGUE, ROGUE, Q, LDA )
IF( K.LT.N )
$ CALL DLACPY( 'Full', K, N-K, AF( M-K+1, 1 ), LDA,
$ Q( M-K+1, 1 ), LDA )
IF( K.GT.1 )
$ CALL DLACPY( 'Lower', K-1, K-1, AF( M-K+2, N-K+1 ), LDA,
$ Q( M-K+2, N-K+1 ), LDA )
*
* Generate the last n rows of the matrix Q
*
SRNAMT = 'DORGRQ'
CALL DORGRQ( M, N, K, Q, LDA, TAU( M-K+1 ), WORK, LWORK, INFO )
*
* Copy R(m-k+1:m,n-m+1:n)
*
CALL DLASET( 'Full', K, M, ZERO, ZERO, R( M-K+1, N-M+1 ), LDA )
CALL DLACPY( 'Upper', K, K, AF( M-K+1, N-K+1 ), LDA,
$ R( M-K+1, N-K+1 ), LDA )
*
* Compute R(m-k+1:m,n-m+1:n) - A(m-k+1:m,1:n) * Q(n-m+1:n,1:n)'
*
CALL DGEMM( 'No transpose', 'Transpose', K, M, N, -ONE,
$ A( M-K+1, 1 ), LDA, Q, LDA, ONE, R( M-K+1, N-M+1 ),
$ LDA )
*
* Compute norm( R - A*Q' ) / ( N * norm(A) * EPS ) .
*
ANORM = DLANGE( '1', K, N, A( M-K+1, 1 ), LDA, RWORK )
RESID = DLANGE( '1', K, M, R( M-K+1, N-M+1 ), LDA, RWORK )
IF( ANORM.GT.ZERO ) THEN
RESULT( 1 ) = ( ( RESID / DBLE( MAX( 1, N ) ) ) / ANORM ) / EPS
ELSE
RESULT( 1 ) = ZERO
END IF
*
* Compute I - Q*Q'
*
CALL DLASET( 'Full', M, M, ZERO, ONE, R, LDA )
CALL DSYRK( 'Upper', 'No transpose', M, N, -ONE, Q, LDA, ONE, R,
$ LDA )
*
* Compute norm( I - Q*Q' ) / ( N * EPS ) .
*
RESID = DLANSY( '1', 'Upper', M, R, LDA, RWORK )
*
RESULT( 2 ) = ( RESID / DBLE( MAX( 1, N ) ) ) / EPS
*
RETURN
*
* End of DRQT02
*
END
SUBROUTINE DRQT03( M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK,
$ RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AF( LDA, * ), C( LDA, * ), CC( LDA, * ),
$ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* DRQT03 tests DORMRQ, which computes Q*C, Q'*C, C*Q or C*Q'.
*
* DRQT03 compares the results of a call to DORMRQ with the results of
* forming Q explicitly by a call to DORGRQ and then performing matrix
* multiplication by a call to DGEMM.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows or columns of the matrix C; C is n-by-m if
* Q is applied from the left, or m-by-n if Q is applied from
* the right. M >= 0.
*
* N (input) INTEGER
* The order of the orthogonal matrix Q. N >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* orthogonal matrix Q. N >= K >= 0.
*
* AF (input) DOUBLE PRECISION array, dimension (LDA,N)
* Details of the RQ factorization of an m-by-n matrix, as
* returned by DGERQF. See SGERQF for further details.
*
* C (workspace) DOUBLE PRECISION array, dimension (LDA,N)
*
* CC (workspace) DOUBLE PRECISION array, dimension (LDA,N)
*
* Q (workspace) DOUBLE PRECISION array, dimension (LDA,N)
*
* LDA (input) INTEGER
* The leading dimension of the arrays AF, C, CC, and Q.
*
* TAU (input) DOUBLE PRECISION array, dimension (min(M,N))
* The scalar factors of the elementary reflectors corresponding
* to the RQ factorization in AF.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of WORK. LWORK must be at least M, and should be
* M*NB, where NB is the blocksize for this environment.
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (M)
*
* RESULT (output) DOUBLE PRECISION array, dimension (4)
* The test ratios compare two techniques for multiplying a
* random matrix C by an n-by-n orthogonal matrix Q.
* RESULT(1) = norm( Q*C - Q*C ) / ( N * norm(C) * EPS )
* RESULT(2) = norm( C*Q - C*Q ) / ( N * norm(C) * EPS )
* RESULT(3) = norm( Q'*C - Q'*C )/ ( N * norm(C) * EPS )
* RESULT(4) = norm( C*Q' - C*Q' )/ ( N * norm(C) * EPS )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
DOUBLE PRECISION ROGUE
PARAMETER ( ROGUE = -1.0D+10 )
* ..
* .. Local Scalars ..
CHARACTER SIDE, TRANS
INTEGER INFO, ISIDE, ITRANS, J, MC, MINMN, NC
DOUBLE PRECISION CNORM, EPS, RESID
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL LSAME, DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLACPY, DLARNV, DLASET, DORGRQ, DORMRQ
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 )
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Scalars in Common ..
CHARACTER*6 SRNAMT
* ..
* .. Common blocks ..
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA ISEED / 1988, 1989, 1990, 1991 /
* ..
* .. Executable Statements ..
*
EPS = DLAMCH( 'Epsilon' )
MINMN = MIN( M, N )
*
* Quick return if possible
*
IF( MINMN.EQ.0 ) THEN
RESULT( 1 ) = ZERO
RESULT( 2 ) = ZERO
RESULT( 3 ) = ZERO
RESULT( 4 ) = ZERO
RETURN
END IF
*
* Copy the last k rows of the factorization to the array Q
*
CALL DLASET( 'Full', N, N, ROGUE, ROGUE, Q, LDA )
IF( K.GT.0 .AND. N.GT.K )
$ CALL DLACPY( 'Full', K, N-K, AF( M-K+1, 1 ), LDA,
$ Q( N-K+1, 1 ), LDA )
IF( K.GT.1 )
$ CALL DLACPY( 'Lower', K-1, K-1, AF( M-K+2, N-K+1 ), LDA,
$ Q( N-K+2, N-K+1 ), LDA )
*
* Generate the n-by-n matrix Q
*
SRNAMT = 'DORGRQ'
CALL DORGRQ( N, N, K, Q, LDA, TAU( MINMN-K+1 ), WORK, LWORK,
$ INFO )
*
DO 30 ISIDE = 1, 2
IF( ISIDE.EQ.1 ) THEN
SIDE = 'L'
MC = N
NC = M
ELSE
SIDE = 'R'
MC = M
NC = N
END IF
*
* Generate MC by NC matrix C
*
DO 10 J = 1, NC
CALL DLARNV( 2, ISEED, MC, C( 1, J ) )
10 CONTINUE
CNORM = DLANGE( '1', MC, NC, C, LDA, RWORK )
IF( CNORM.EQ.0.0D0 )
$ CNORM = ONE
*
DO 20 ITRANS = 1, 2
IF( ITRANS.EQ.1 ) THEN
TRANS = 'N'
ELSE
TRANS = 'T'
END IF
*
* Copy C
*
CALL DLACPY( 'Full', MC, NC, C, LDA, CC, LDA )
*
* Apply Q or Q' to C
*
SRNAMT = 'DORMRQ'
IF( K.GT.0 )
$ CALL DORMRQ( SIDE, TRANS, MC, NC, K, AF( M-K+1, 1 ), LDA,
$ TAU( MINMN-K+1 ), CC, LDA, WORK, LWORK,
$ INFO )
*
* Form explicit product and subtract
*
IF( LSAME( SIDE, 'L' ) ) THEN
CALL DGEMM( TRANS, 'No transpose', MC, NC, MC, -ONE, Q,
$ LDA, C, LDA, ONE, CC, LDA )
ELSE
CALL DGEMM( 'No transpose', TRANS, MC, NC, NC, -ONE, C,
$ LDA, Q, LDA, ONE, CC, LDA )
END IF
*
* Compute error in the difference
*
RESID = DLANGE( '1', MC, NC, CC, LDA, RWORK )
RESULT( ( ISIDE-1 )*2+ITRANS ) = RESID /
$ ( DBLE( MAX( 1, N ) )*CNORM*EPS )
*
20 CONTINUE
30 CONTINUE
*
RETURN
*
* End of DRQT03
*
END
DOUBLE PRECISION FUNCTION DRZT01( M, N, A, AF, LDA, TAU, WORK,
$ LWORK )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* DRZT01 returns
* || A - R*Q || / ( M * eps * ||A|| )
* for an upper trapezoidal A that was factored with DTZRZF.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrices A and AF.
*
* N (input) INTEGER
* The number of columns of the matrices A and AF.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The original upper trapezoidal M by N matrix A.
*
* AF (input) DOUBLE PRECISION array, dimension (LDA,N)
* The output of DTZRZF for input matrix A.
* The lower triangle is not referenced.
*
* LDA (input) INTEGER
* The leading dimension of the arrays A and AF.
*
* TAU (input) DOUBLE PRECISION array, dimension (M)
* Details of the Householder transformations as returned by
* DTZRZF.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of the array WORK. LWORK >= m*n + m*nb.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
DOUBLE PRECISION NORMA
* ..
* .. Local Arrays ..
DOUBLE PRECISION RWORK( 1 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DLASET, DORMRZ, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX
* ..
* .. Executable Statements ..
*
DRZT01 = ZERO
*
IF( LWORK.LT.M*N+M ) THEN
CALL XERBLA( 'DRZT01', 8 )
RETURN
END IF
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
NORMA = DLANGE( 'One-norm', M, N, A, LDA, RWORK )
*
* Copy upper triangle R
*
CALL DLASET( 'Full', M, N, ZERO, ZERO, WORK, M )
DO 20 J = 1, M
DO 10 I = 1, J
WORK( ( J-1 )*M+I ) = AF( I, J )
10 CONTINUE
20 CONTINUE
*
* R = R * P(1) * ... *P(m)
*
CALL DORMRZ( 'Right', 'No tranpose', M, N, M, N-M, AF, LDA, TAU,
$ WORK, M, WORK( M*N+1 ), LWORK-M*N, INFO )
*
* R = R - A
*
DO 30 I = 1, N
CALL DAXPY( M, -ONE, A( 1, I ), 1, WORK( ( I-1 )*M+1 ), 1 )
30 CONTINUE
*
DRZT01 = DLANGE( 'One-norm', M, N, WORK, M, RWORK )
*
DRZT01 = DRZT01 / ( DLAMCH( 'Epsilon' )*DBLE( MAX( M, N ) ) )
IF( NORMA.NE.ZERO )
$ DRZT01 = DRZT01 / NORMA
*
RETURN
*
* End of DRZT01
*
END
DOUBLE PRECISION FUNCTION DRZT02( M, N, AF, LDA, TAU, WORK,
$ LWORK )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AF( LDA, * ), TAU( * ), WORK( LWORK )
* ..
*
* Purpose
* =======
*
* DRZT02 returns
* || I - Q'*Q || / ( M * eps)
* where the matrix Q is defined by the Householder transformations
* generated by DTZRZF.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix AF.
*
* N (input) INTEGER
* The number of columns of the matrix AF.
*
* AF (input) DOUBLE PRECISION array, dimension (LDA,N)
* The output of DTZRZF.
*
* LDA (input) INTEGER
* The leading dimension of the array AF.
*
* TAU (input) DOUBLE PRECISION array, dimension (M)
* Details of the Householder transformations as returned by
* DTZRZF.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* length of WORK array. LWORK >= N*N+N*NB.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO
* ..
* .. Local Arrays ..
DOUBLE PRECISION RWORK( 1 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DLASET, DORMRZ, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX
* ..
* .. Executable Statements ..
*
DRZT02 = ZERO
*
IF( LWORK.LT.N*N+N ) THEN
CALL XERBLA( 'DRZT02', 7 )
RETURN
END IF
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
* Q := I
*
CALL DLASET( 'Full', N, N, ZERO, ONE, WORK, N )
*
* Q := P(1) * ... * P(m) * Q
*
CALL DORMRZ( 'Left', 'No transpose', N, N, M, N-M, AF, LDA, TAU,
$ WORK, N, WORK( N*N+1 ), LWORK-N*N, INFO )
*
* Q := P(m) * ... * P(1) * Q
*
CALL DORMRZ( 'Left', 'Transpose', N, N, M, N-M, AF, LDA, TAU,
$ WORK, N, WORK( N*N+1 ), LWORK-N*N, INFO )
*
* Q := Q - I
*
DO 10 I = 1, N
WORK( ( I-1 )*N+I ) = WORK( ( I-1 )*N+I ) - ONE
10 CONTINUE
*
DRZT02 = DLANGE( 'One-norm', N, N, WORK, N, RWORK ) /
$ ( DLAMCH( 'Epsilon' )*DBLE( MAX( M, N ) ) )
RETURN
*
* End of DRZT02
*
END
SUBROUTINE DSPT01( UPLO, N, A, AFAC, IPIV, C, LDC, RWORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDC, N
DOUBLE PRECISION RESID
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION A( * ), AFAC( * ), C( LDC, * ), RWORK( * )
* ..
*
* Purpose
* =======
*
* DSPT01 reconstructs a symmetric indefinite packed matrix A from its
* block L*D*L' or U*D*U' factorization and computes the residual
* norm( C - A ) / ( N * norm(A) * EPS ),
* where C is the reconstructed matrix and EPS is the machine epsilon.
*
* Arguments
* ==========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The number of rows and columns of the matrix A. N >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The original symmetric matrix A, stored as a packed
* triangular matrix.
*
* AFAC (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The factored form of the matrix A, stored as a packed
* triangular matrix. AFAC contains the block diagonal matrix D
* and the multipliers used to obtain the factor L or U from the
* block L*D*L' or U*D*U' factorization as computed by DSPTRF.
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices from DSPTRF.
*
* C (workspace) DOUBLE PRECISION array, dimension (LDC,N)
*
* LDC (integer) INTEGER
* The leading dimension of the array C. LDC >= max(1,N).
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* RESID (output) DOUBLE PRECISION
* If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
* If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J, JC
DOUBLE PRECISION ANORM, EPS
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANSP, DLANSY
EXTERNAL LSAME, DLAMCH, DLANSP, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DLASET, DLAVSP
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0.
*
IF( N.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Determine EPS and the norm of A.
*
EPS = DLAMCH( 'Epsilon' )
ANORM = DLANSP( '1', UPLO, N, A, RWORK )
*
* Initialize C to the identity matrix.
*
CALL DLASET( 'Full', N, N, ZERO, ONE, C, LDC )
*
* Call DLAVSP to form the product D * U' (or D * L' ).
*
CALL DLAVSP( UPLO, 'Transpose', 'Non-unit', N, N, AFAC, IPIV, C,
$ LDC, INFO )
*
* Call DLAVSP again to multiply by U ( or L ).
*
CALL DLAVSP( UPLO, 'No transpose', 'Unit', N, N, AFAC, IPIV, C,
$ LDC, INFO )
*
* Compute the difference C - A .
*
IF( LSAME( UPLO, 'U' ) ) THEN
JC = 0
DO 20 J = 1, N
DO 10 I = 1, J
C( I, J ) = C( I, J ) - A( JC+I )
10 CONTINUE
JC = JC + J
20 CONTINUE
ELSE
JC = 1
DO 40 J = 1, N
DO 30 I = J, N
C( I, J ) = C( I, J ) - A( JC+I-J )
30 CONTINUE
JC = JC + N - J + 1
40 CONTINUE
END IF
*
* Compute norm( C - A ) / ( N * norm(A) * EPS )
*
RESID = DLANSY( '1', UPLO, N, C, LDC, RWORK )
*
IF( ANORM.LE.ZERO ) THEN
IF( RESID.NE.ZERO )
$ RESID = ONE / EPS
ELSE
RESID = ( ( RESID / DBLE( N ) ) / ANORM ) / EPS
END IF
*
RETURN
*
* End of DSPT01
*
END
SUBROUTINE DSYT01( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC,
$ RWORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDA, LDAFAC, LDC, N
DOUBLE PRECISION RESID
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ),
$ RWORK( * )
* ..
*
* Purpose
* =======
*
* DSYT01 reconstructs a symmetric indefinite matrix A from its
* block L*D*L' or U*D*U' factorization and computes the residual
* norm( C - A ) / ( N * norm(A) * EPS ),
* where C is the reconstructed matrix and EPS is the machine epsilon.
*
* Arguments
* ==========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The number of rows and columns of the matrix A. N >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The original symmetric matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N)
*
* AFAC (input) DOUBLE PRECISION array, dimension (LDAFAC,N)
* The factored form of the matrix A. AFAC contains the block
* diagonal matrix D and the multipliers used to obtain the
* factor L or U from the block L*D*L' or U*D*U' factorization
* as computed by DSYTRF.
*
* LDAFAC (input) INTEGER
* The leading dimension of the array AFAC. LDAFAC >= max(1,N).
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices from DSYTRF.
*
* C (workspace) DOUBLE PRECISION array, dimension (LDC,N)
*
* LDC (integer) INTEGER
* The leading dimension of the array C. LDC >= max(1,N).
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* RESID (output) DOUBLE PRECISION
* If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
* If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
DOUBLE PRECISION ANORM, EPS
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANSY
EXTERNAL LSAME, DLAMCH, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DLASET, DLAVSY
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0.
*
IF( N.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Determine EPS and the norm of A.
*
EPS = DLAMCH( 'Epsilon' )
ANORM = DLANSY( '1', UPLO, N, A, LDA, RWORK )
*
* Initialize C to the identity matrix.
*
CALL DLASET( 'Full', N, N, ZERO, ONE, C, LDC )
*
* Call DLAVSY to form the product D * U' (or D * L' ).
*
CALL DLAVSY( UPLO, 'Transpose', 'Non-unit', N, N, AFAC, LDAFAC,
$ IPIV, C, LDC, INFO )
*
* Call DLAVSY again to multiply by U (or L ).
*
CALL DLAVSY( UPLO, 'No transpose', 'Unit', N, N, AFAC, LDAFAC,
$ IPIV, C, LDC, INFO )
*
* Compute the difference C - A .
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = 1, J
C( I, J ) = C( I, J ) - A( I, J )
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1, N
DO 30 I = J, N
C( I, J ) = C( I, J ) - A( I, J )
30 CONTINUE
40 CONTINUE
END IF
*
* Compute norm( C - A ) / ( N * norm(A) * EPS )
*
RESID = DLANSY( '1', UPLO, N, C, LDC, RWORK )
*
IF( ANORM.LE.ZERO ) THEN
IF( RESID.NE.ZERO )
$ RESID = ONE / EPS
ELSE
RESID = ( ( RESID / DBLE( N ) ) / ANORM ) / EPS
END IF
*
RETURN
*
* End of DSYT01
*
END
SUBROUTINE DTBT02( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, X,
$ LDX, B, LDB, WORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER KD, LDAB, LDB, LDX, N, NRHS
DOUBLE PRECISION RESID
* ..
* .. Array Arguments ..
DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ), WORK( * ),
$ X( LDX, * )
* ..
*
* Purpose
* =======
*
* DTBT02 computes the residual for the computed solution to a
* triangular system of linear equations A*x = b or A' *x = b when
* A is a triangular band matrix. Here A' is the transpose of A and
* x and b are N by NRHS matrices. The test ratio is the maximum over
* the number of right hand sides of
* norm(b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ),
* where op(A) denotes A or A' and EPS is the machine epsilon.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the operation applied to A.
* = 'N': A *x = b (No transpose)
* = 'T': A'*x = b (Transpose)
* = 'C': A'*x = b (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals or subdiagonals of the
* triangular band matrix A. KD >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrices X and B. NRHS >= 0.
*
* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
* The upper or lower triangular band matrix A, stored in the
* first kd+1 rows of the array. The j-th column of A is stored
* in the j-th column of the array AB as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The computed solution vectors for the system of linear
* equations.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* RESID (output) DOUBLE PRECISION
* The maximum over the number of right hand sides of
* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER J
DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DASUM, DLAMCH, DLANTB
EXTERNAL LSAME, DASUM, DLAMCH, DLANTB
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DTBMV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Compute the 1-norm of A or A'.
*
IF( LSAME( TRANS, 'N' ) ) THEN
ANORM = DLANTB( '1', UPLO, DIAG, N, KD, AB, LDAB, WORK )
ELSE
ANORM = DLANTB( 'I', UPLO, DIAG, N, KD, AB, LDAB, WORK )
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0.
*
EPS = DLAMCH( 'Epsilon' )
IF( ANORM.LE.ZERO ) THEN
RESID = ONE / EPS
RETURN
END IF
*
* Compute the maximum over the number of right hand sides of
* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ).
*
RESID = ZERO
DO 10 J = 1, NRHS
CALL DCOPY( N, X( 1, J ), 1, WORK, 1 )
CALL DTBMV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, WORK, 1 )
CALL DAXPY( N, -ONE, B( 1, J ), 1, WORK, 1 )
BNORM = DASUM( N, WORK, 1 )
XNORM = DASUM( N, X( 1, J ), 1 )
IF( XNORM.LE.ZERO ) THEN
RESID = ONE / EPS
ELSE
RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) / EPS )
END IF
10 CONTINUE
*
RETURN
*
* End of DTBT02
*
END
SUBROUTINE DTBT03( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB,
$ SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK,
$ RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER KD, LDAB, LDB, LDX, N, NRHS
DOUBLE PRECISION RESID, SCALE, TSCAL
* ..
* .. Array Arguments ..
DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ), CNORM( * ),
$ WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* DTBT03 computes the residual for the solution to a scaled triangular
* system of equations A*x = s*b or A'*x = s*b when A is a
* triangular band matrix. Here A' is the transpose of A, s is a scalar,
* and x and b are N by NRHS matrices. The test ratio is the maximum
* over the number of right hand sides of
* norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ),
* where op(A) denotes A or A' and EPS is the machine epsilon.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the operation applied to A.
* = 'N': A *x = b (No transpose)
* = 'T': A'*x = b (Transpose)
* = 'C': A'*x = b (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals or subdiagonals of the
* triangular band matrix A. KD >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrices X and B. NRHS >= 0.
*
* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
* The upper or lower triangular band matrix A, stored in the
* first kd+1 rows of the array. The j-th column of A is stored
* in the j-th column of the array AB as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* SCALE (input) DOUBLE PRECISION
* The scaling factor s used in solving the triangular system.
*
* CNORM (input) DOUBLE PRECISION array, dimension (N)
* The 1-norms of the columns of A, not counting the diagonal.
*
* TSCAL (input) DOUBLE PRECISION
* The scaling factor used in computing the 1-norms in CNORM.
* CNORM actually contains the column norms of TSCAL*A.
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The computed solution vectors for the system of linear
* equations.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* RESID (output) DOUBLE PRECISION
* The maximum over the number of right hand sides of
* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER IX, J
DOUBLE PRECISION BIGNUM, EPS, ERR, SMLNUM, TNORM, XNORM, XSCAL
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, IDAMAX, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DLABAD, DSCAL, DTBMV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
EPS = DLAMCH( 'Epsilon' )
SMLNUM = DLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
*
* Compute the norm of the triangular matrix A using the column
* norms already computed by DLATBS.
*
TNORM = ZERO
IF( LSAME( DIAG, 'N' ) ) THEN
IF( LSAME( UPLO, 'U' ) ) THEN
DO 10 J = 1, N
TNORM = MAX( TNORM, TSCAL*ABS( AB( KD+1, J ) )+
$ CNORM( J ) )
10 CONTINUE
ELSE
DO 20 J = 1, N
TNORM = MAX( TNORM, TSCAL*ABS( AB( 1, J ) )+CNORM( J ) )
20 CONTINUE
END IF
ELSE
DO 30 J = 1, N
TNORM = MAX( TNORM, TSCAL+CNORM( J ) )
30 CONTINUE
END IF
*
* Compute the maximum over the number of right hand sides of
* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ).
*
RESID = ZERO
DO 40 J = 1, NRHS
CALL DCOPY( N, X( 1, J ), 1, WORK, 1 )
IX = IDAMAX( N, WORK, 1 )
XNORM = MAX( ONE, ABS( X( IX, J ) ) )
XSCAL = ( ONE / XNORM ) / DBLE( KD+1 )
CALL DSCAL( N, XSCAL, WORK, 1 )
CALL DTBMV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, WORK, 1 )
CALL DAXPY( N, -SCALE*XSCAL, B( 1, J ), 1, WORK, 1 )
IX = IDAMAX( N, WORK, 1 )
ERR = TSCAL*ABS( WORK( IX ) )
IX = IDAMAX( N, X( 1, J ), 1 )
XNORM = ABS( X( IX, J ) )
IF( ERR*SMLNUM.LE.XNORM ) THEN
IF( XNORM.GT.ZERO )
$ ERR = ERR / XNORM
ELSE
IF( ERR.GT.ZERO )
$ ERR = ONE / EPS
END IF
IF( ERR*SMLNUM.LE.TNORM ) THEN
IF( TNORM.GT.ZERO )
$ ERR = ERR / TNORM
ELSE
IF( ERR.GT.ZERO )
$ ERR = ONE / EPS
END IF
RESID = MAX( RESID, ERR )
40 CONTINUE
*
RETURN
*
* End of DTBT03
*
END
SUBROUTINE DTBT05( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B,
$ LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER KD, LDAB, LDB, LDX, LDXACT, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ), BERR( * ),
$ FERR( * ), RESLTS( * ), X( LDX, * ),
$ XACT( LDXACT, * )
* ..
*
* Purpose
* =======
*
* DTBT05 tests the error bounds from iterative refinement for the
* computed solution to a system of equations A*X = B, where A is a
* triangular band matrix.
*
* RESLTS(1) = test of the error bound
* = norm(X - XACT) / ( norm(X) * FERR )
*
* A large value is returned if this ratio is not less than one.
*
* RESLTS(2) = residual from the iterative refinement routine
* = the maximum of BERR / ( NZ*EPS + (*) ), where
* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
* and NZ = max. number of nonzeros in any row of A, plus 1
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the form of the system of equations.
* = 'N': A * X = B (No transpose)
* = 'T': A'* X = B (Transpose)
* = 'C': A'* X = B (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* N (input) INTEGER
* The number of rows of the matrices X, B, and XACT, and the
* order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of super-diagonals of the matrix A if UPLO = 'U',
* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
*
* NRHS (input) INTEGER
* The number of columns of the matrices X, B, and XACT.
* NRHS >= 0.
*
* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
* The upper or lower triangular band matrix A, stored in the
* first kd+1 rows of the array. The j-th column of A is stored
* in the j-th column of the array AB as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
* If DIAG = 'U', the diagonal elements of A are not referenced
* and are assumed to be 1.
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The computed solution vectors. Each vector is stored as a
* column of the matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* XACT (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The exact solution vectors. Each vector is stored as a
* column of the matrix XACT.
*
* LDXACT (input) INTEGER
* The leading dimension of the array XACT. LDXACT >= max(1,N).
*
* FERR (input) DOUBLE PRECISION array, dimension (NRHS)
* The estimated forward error bounds for each solution vector
* X. If XTRUE is the true solution, FERR bounds the magnitude
* of the largest entry in (X - XTRUE) divided by the magnitude
* of the largest entry in X.
*
* BERR (input) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector (i.e., the smallest relative change in any entry of A
* or B that makes X an exact solution).
*
* RESLTS (output) DOUBLE PRECISION array, dimension (2)
* The maximum over the NRHS solution vectors of the ratios:
* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
* RESLTS(2) = BERR / ( NZ*EPS + (*) )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN, UNIT, UPPER
INTEGER I, IFU, IMAX, J, K, NZ
DOUBLE PRECISION AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, IDAMAX, DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0.
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESLTS( 1 ) = ZERO
RESLTS( 2 ) = ZERO
RETURN
END IF
*
EPS = DLAMCH( 'Epsilon' )
UNFL = DLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
UPPER = LSAME( UPLO, 'U' )
NOTRAN = LSAME( TRANS, 'N' )
UNIT = LSAME( DIAG, 'U' )
NZ = MIN( KD, N-1 ) + 1
*
* Test 1: Compute the maximum of
* norm(X - XACT) / ( norm(X) * FERR )
* over all the vectors X and XACT using the infinity-norm.
*
ERRBND = ZERO
DO 30 J = 1, NRHS
IMAX = IDAMAX( N, X( 1, J ), 1 )
XNORM = MAX( ABS( X( IMAX, J ) ), UNFL )
DIFF = ZERO
DO 10 I = 1, N
DIFF = MAX( DIFF, ABS( X( I, J )-XACT( I, J ) ) )
10 CONTINUE
*
IF( XNORM.GT.ONE ) THEN
GO TO 20
ELSE IF( DIFF.LE.OVFL*XNORM ) THEN
GO TO 20
ELSE
ERRBND = ONE / EPS
GO TO 30
END IF
*
20 CONTINUE
IF( DIFF / XNORM.LE.FERR( J ) ) THEN
ERRBND = MAX( ERRBND, ( DIFF / XNORM ) / FERR( J ) )
ELSE
ERRBND = ONE / EPS
END IF
30 CONTINUE
RESLTS( 1 ) = ERRBND
*
* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where
* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
*
IFU = 0
IF( UNIT )
$ IFU = 1
DO 90 K = 1, NRHS
DO 80 I = 1, N
TMP = ABS( B( I, K ) )
IF( UPPER ) THEN
IF( .NOT.NOTRAN ) THEN
DO 40 J = MAX( I-KD, 1 ), I - IFU
TMP = TMP + ABS( AB( KD+1-I+J, I ) )*
$ ABS( X( J, K ) )
40 CONTINUE
IF( UNIT )
$ TMP = TMP + ABS( X( I, K ) )
ELSE
IF( UNIT )
$ TMP = TMP + ABS( X( I, K ) )
DO 50 J = I + IFU, MIN( I+KD, N )
TMP = TMP + ABS( AB( KD+1+I-J, J ) )*
$ ABS( X( J, K ) )
50 CONTINUE
END IF
ELSE
IF( NOTRAN ) THEN
DO 60 J = MAX( I-KD, 1 ), I - IFU
TMP = TMP + ABS( AB( 1+I-J, J ) )*ABS( X( J, K ) )
60 CONTINUE
IF( UNIT )
$ TMP = TMP + ABS( X( I, K ) )
ELSE
IF( UNIT )
$ TMP = TMP + ABS( X( I, K ) )
DO 70 J = I + IFU, MIN( I+KD, N )
TMP = TMP + ABS( AB( 1+J-I, I ) )*ABS( X( J, K ) )
70 CONTINUE
END IF
END IF
IF( I.EQ.1 ) THEN
AXBI = TMP
ELSE
AXBI = MIN( AXBI, TMP )
END IF
80 CONTINUE
TMP = BERR( K ) / ( NZ*EPS+NZ*UNFL / MAX( AXBI, NZ*UNFL ) )
IF( K.EQ.1 ) THEN
RESLTS( 2 ) = TMP
ELSE
RESLTS( 2 ) = MAX( RESLTS( 2 ), TMP )
END IF
90 CONTINUE
*
RETURN
*
* End of DTBT05
*
END
SUBROUTINE DTBT06( RCOND, RCONDC, UPLO, DIAG, N, KD, AB, LDAB,
$ WORK, RAT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, UPLO
INTEGER KD, LDAB, N
DOUBLE PRECISION RAT, RCOND, RCONDC
* ..
* .. Array Arguments ..
DOUBLE PRECISION AB( LDAB, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DTBT06 computes a test ratio comparing RCOND (the reciprocal
* condition number of a triangular matrix A) and RCONDC, the estimate
* computed by DTBCON. Information about the triangular matrix A is
* used if one estimate is zero and the other is non-zero to decide if
* underflow in the estimate is justified.
*
* Arguments
* =========
*
* RCOND (input) DOUBLE PRECISION
* The estimate of the reciprocal condition number obtained by
* forming the explicit inverse of the matrix A and computing
* RCOND = 1/( norm(A) * norm(inv(A)) ).
*
* RCONDC (input) DOUBLE PRECISION
* The estimate of the reciprocal condition number computed by
* DTBCON.
*
* UPLO (input) CHARACTER
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* DIAG (input) CHARACTER
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* KD (input) INTEGER
* The number of superdiagonals or subdiagonals of the
* triangular band matrix A. KD >= 0.
*
* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
* The upper or lower triangular band matrix A, stored in the
* first kd+1 rows of the array. The j-th column of A is stored
* in the j-th column of the array AB as follows:
* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*
* LDAB (input) INTEGER
* The leading dimension of the array AB. LDAB >= KD+1.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* RAT (output) DOUBLE PRECISION
* The test ratio. If both RCOND and RCONDC are nonzero,
* RAT = MAX( RCOND, RCONDC )/MIN( RCOND, RCONDC ) - 1.
* If RAT = 0, the two estimates are exactly the same.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION ANORM, BIGNUM, EPS, RMAX, RMIN, SMLNUM
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANTB
EXTERNAL DLAMCH, DLANTB
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Subroutines ..
EXTERNAL DLABAD
* ..
* .. Executable Statements ..
*
EPS = DLAMCH( 'Epsilon' )
RMAX = MAX( RCOND, RCONDC )
RMIN = MIN( RCOND, RCONDC )
*
* Do the easy cases first.
*
IF( RMIN.LT.ZERO ) THEN
*
* Invalid value for RCOND or RCONDC, return 1/EPS.
*
RAT = ONE / EPS
*
ELSE IF( RMIN.GT.ZERO ) THEN
*
* Both estimates are positive, return RMAX/RMIN - 1.
*
RAT = RMAX / RMIN - ONE
*
ELSE IF( RMAX.EQ.ZERO ) THEN
*
* Both estimates zero.
*
RAT = ZERO
*
ELSE
*
* One estimate is zero, the other is non-zero. If the matrix is
* ill-conditioned, return the nonzero estimate multiplied by
* 1/EPS; if the matrix is badly scaled, return the nonzero
* estimate multiplied by BIGNUM/TMAX, where TMAX is the maximum
* element in absolute value in A.
*
SMLNUM = DLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
ANORM = DLANTB( 'M', UPLO, DIAG, N, KD, AB, LDAB, WORK )
*
RAT = RMAX*( MIN( BIGNUM / MAX( ONE, ANORM ), ONE / EPS ) )
END IF
*
RETURN
*
* End of DTBT06
*
END
SUBROUTINE DTPT01( UPLO, DIAG, N, AP, AINVP, RCOND, WORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, UPLO
INTEGER N
DOUBLE PRECISION RCOND, RESID
* ..
* .. Array Arguments ..
DOUBLE PRECISION AINVP( * ), AP( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DTPT01 computes the residual for a triangular matrix A times its
* inverse when A is stored in packed format:
* RESID = norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS ),
* where EPS is the machine epsilon.
*
* Arguments
* ==========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The original upper or lower triangular matrix A, packed
* columnwise in a linear array. The j-th column of A is stored
* in the array AP as follows:
* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j;
* if UPLO = 'L',
* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n.
*
* AINVP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* On entry, the (triangular) inverse of the matrix A, packed
* columnwise in a linear array as in AP.
* On exit, the contents of AINVP are destroyed.
*
* RCOND (output) DOUBLE PRECISION
* The reciprocal condition number of A, computed as
* 1/(norm(A) * norm(AINV)).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* RESID (output) DOUBLE PRECISION
* norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UNITD
INTEGER J, JC
DOUBLE PRECISION AINVNM, ANORM, EPS
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANTP
EXTERNAL LSAME, DLAMCH, DLANTP
* ..
* .. External Subroutines ..
EXTERNAL DTPMV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0.
*
IF( N.LE.0 ) THEN
RCOND = ONE
RESID = ZERO
RETURN
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0.
*
EPS = DLAMCH( 'Epsilon' )
ANORM = DLANTP( '1', UPLO, DIAG, N, AP, WORK )
AINVNM = DLANTP( '1', UPLO, DIAG, N, AINVP, WORK )
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCOND = ZERO
RESID = ONE / EPS
RETURN
END IF
RCOND = ( ONE / ANORM ) / AINVNM
*
* Compute A * AINV, overwriting AINV.
*
UNITD = LSAME( DIAG, 'U' )
IF( LSAME( UPLO, 'U' ) ) THEN
JC = 1
DO 10 J = 1, N
IF( UNITD )
$ AINVP( JC+J-1 ) = ONE
*
* Form the j-th column of A*AINV
*
CALL DTPMV( 'Upper', 'No transpose', DIAG, J, AP,
$ AINVP( JC ), 1 )
*
* Subtract 1 from the diagonal
*
AINVP( JC+J-1 ) = AINVP( JC+J-1 ) - ONE
JC = JC + J
10 CONTINUE
ELSE
JC = 1
DO 20 J = 1, N
IF( UNITD )
$ AINVP( JC ) = ONE
*
* Form the j-th column of A*AINV
*
CALL DTPMV( 'Lower', 'No transpose', DIAG, N-J+1, AP( JC ),
$ AINVP( JC ), 1 )
*
* Subtract 1 from the diagonal
*
AINVP( JC ) = AINVP( JC ) - ONE
JC = JC + N - J + 1
20 CONTINUE
END IF
*
* Compute norm(A*AINV - I) / (N * norm(A) * norm(AINV) * EPS)
*
RESID = DLANTP( '1', UPLO, 'Non-unit', N, AINVP, WORK )
*
RESID = ( ( RESID*RCOND ) / DBLE( N ) ) / EPS
*
RETURN
*
* End of DTPT01
*
END
SUBROUTINE DTPT02( UPLO, TRANS, DIAG, N, NRHS, AP, X, LDX, B, LDB,
$ WORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER LDB, LDX, N, NRHS
DOUBLE PRECISION RESID
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP( * ), B( LDB, * ), WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* DTPT02 computes the residual for the computed solution to a
* triangular system of linear equations A*x = b or A'*x = b when
* the triangular matrix A is stored in packed format. Here A' is the
* transpose of A and x and b are N by NRHS matrices. The test ratio is
* the maximum over the number of right hand sides of
* norm(b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ),
* where op(A) denotes A or A' and EPS is the machine epsilon.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the operation applied to A.
* = 'N': A *x = b (No transpose)
* = 'T': A'*x = b (Transpose)
* = 'C': A'*x = b (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* 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 matrices X and B. NRHS >= 0.
*
* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The upper or lower triangular matrix A, packed columnwise in
* a linear array. The j-th column of A is stored in the array
* AP as follows:
* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j;
* if UPLO = 'L',
* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n.
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The computed solution vectors for the system of linear
* equations.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* RESID (output) DOUBLE PRECISION
* The maximum over the number of right hand sides of
* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER J
DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DASUM, DLAMCH, DLANTP
EXTERNAL LSAME, DASUM, DLAMCH, DLANTP
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DTPMV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Compute the 1-norm of A or A'.
*
IF( LSAME( TRANS, 'N' ) ) THEN
ANORM = DLANTP( '1', UPLO, DIAG, N, AP, WORK )
ELSE
ANORM = DLANTP( 'I', UPLO, DIAG, N, AP, WORK )
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0.
*
EPS = DLAMCH( 'Epsilon' )
IF( ANORM.LE.ZERO ) THEN
RESID = ONE / EPS
RETURN
END IF
*
* Compute the maximum over the number of right hand sides of
* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ).
*
RESID = ZERO
DO 10 J = 1, NRHS
CALL DCOPY( N, X( 1, J ), 1, WORK, 1 )
CALL DTPMV( UPLO, TRANS, DIAG, N, AP, WORK, 1 )
CALL DAXPY( N, -ONE, B( 1, J ), 1, WORK, 1 )
BNORM = DASUM( N, WORK, 1 )
XNORM = DASUM( N, X( 1, J ), 1 )
IF( XNORM.LE.ZERO ) THEN
RESID = ONE / EPS
ELSE
RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) / EPS )
END IF
10 CONTINUE
*
RETURN
*
* End of DTPT02
*
END
SUBROUTINE DTPT03( UPLO, TRANS, DIAG, N, NRHS, AP, SCALE, CNORM,
$ TSCAL, X, LDX, B, LDB, WORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER LDB, LDX, N, NRHS
DOUBLE PRECISION RESID, SCALE, TSCAL
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP( * ), B( LDB, * ), CNORM( * ), WORK( * ),
$ X( LDX, * )
* ..
*
* Purpose
* =======
*
* DTPT03 computes the residual for the solution to a scaled triangular
* system of equations A*x = s*b or A'*x = s*b when the triangular
* matrix A is stored in packed format. Here A' is the transpose of A,
* s is a scalar, and x and b are N by NRHS matrices. The test ratio is
* the maximum over the number of right hand sides of
* norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ),
* where op(A) denotes A or A' and EPS is the machine epsilon.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the operation applied to A.
* = 'N': A *x = s*b (No transpose)
* = 'T': A'*x = s*b (Transpose)
* = 'C': A'*x = s*b (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* 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 matrices X and B. NRHS >= 0.
*
* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The upper or lower triangular matrix A, packed columnwise in
* a linear array. The j-th column of A is stored in the array
* AP as follows:
* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j;
* if UPLO = 'L',
* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n.
*
* SCALE (input) DOUBLE PRECISION
* The scaling factor s used in solving the triangular system.
*
* CNORM (input) DOUBLE PRECISION array, dimension (N)
* The 1-norms of the columns of A, not counting the diagonal.
*
* TSCAL (input) DOUBLE PRECISION
* The scaling factor used in computing the 1-norms in CNORM.
* CNORM actually contains the column norms of TSCAL*A.
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The computed solution vectors for the system of linear
* equations.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* RESID (output) DOUBLE PRECISION
* The maximum over the number of right hand sides of
* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER IX, J, JJ
DOUBLE PRECISION BIGNUM, EPS, ERR, SMLNUM, TNORM, XNORM, XSCAL
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, IDAMAX, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DLABAD, DSCAL, DTPMV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0.
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
EPS = DLAMCH( 'Epsilon' )
SMLNUM = DLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
*
* Compute the norm of the triangular matrix A using the column
* norms already computed by DLATPS.
*
TNORM = ZERO
IF( LSAME( DIAG, 'N' ) ) THEN
IF( LSAME( UPLO, 'U' ) ) THEN
JJ = 1
DO 10 J = 1, N
TNORM = MAX( TNORM, TSCAL*ABS( AP( JJ ) )+CNORM( J ) )
JJ = JJ + J + 1
10 CONTINUE
ELSE
JJ = 1
DO 20 J = 1, N
TNORM = MAX( TNORM, TSCAL*ABS( AP( JJ ) )+CNORM( J ) )
JJ = JJ + N - J + 1
20 CONTINUE
END IF
ELSE
DO 30 J = 1, N
TNORM = MAX( TNORM, TSCAL+CNORM( J ) )
30 CONTINUE
END IF
*
* Compute the maximum over the number of right hand sides of
* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ).
*
RESID = ZERO
DO 40 J = 1, NRHS
CALL DCOPY( N, X( 1, J ), 1, WORK, 1 )
IX = IDAMAX( N, WORK, 1 )
XNORM = MAX( ONE, ABS( X( IX, J ) ) )
XSCAL = ( ONE / XNORM ) / DBLE( N )
CALL DSCAL( N, XSCAL, WORK, 1 )
CALL DTPMV( UPLO, TRANS, DIAG, N, AP, WORK, 1 )
CALL DAXPY( N, -SCALE*XSCAL, B( 1, J ), 1, WORK, 1 )
IX = IDAMAX( N, WORK, 1 )
ERR = TSCAL*ABS( WORK( IX ) )
IX = IDAMAX( N, X( 1, J ), 1 )
XNORM = ABS( X( IX, J ) )
IF( ERR*SMLNUM.LE.XNORM ) THEN
IF( XNORM.GT.ZERO )
$ ERR = ERR / XNORM
ELSE
IF( ERR.GT.ZERO )
$ ERR = ONE / EPS
END IF
IF( ERR*SMLNUM.LE.TNORM ) THEN
IF( TNORM.GT.ZERO )
$ ERR = ERR / TNORM
ELSE
IF( ERR.GT.ZERO )
$ ERR = ONE / EPS
END IF
RESID = MAX( RESID, ERR )
40 CONTINUE
*
RETURN
*
* End of DTPT03
*
END
SUBROUTINE DTPT05( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX,
$ XACT, LDXACT, FERR, BERR, RESLTS )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER LDB, LDX, LDXACT, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP( * ), B( LDB, * ), BERR( * ), FERR( * ),
$ RESLTS( * ), X( LDX, * ), XACT( LDXACT, * )
* ..
*
* Purpose
* =======
*
* DTPT05 tests the error bounds from iterative refinement for the
* computed solution to a system of equations A*X = B, where A is a
* triangular matrix in packed storage format.
*
* RESLTS(1) = test of the error bound
* = norm(X - XACT) / ( norm(X) * FERR )
*
* A large value is returned if this ratio is not less than one.
*
* RESLTS(2) = residual from the iterative refinement routine
* = the maximum of BERR / ( (n+1)*EPS + (*) ), where
* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the form of the system of equations.
* = 'N': A * X = B (No transpose)
* = 'T': A'* X = B (Transpose)
* = 'C': A'* X = B (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* N (input) INTEGER
* The number of rows of the matrices X, B, and XACT, and the
* order of the matrix A. N >= 0.
*
* NRHS (input) INTEGER
* The number of columns of the matrices X, B, and XACT.
* NRHS >= 0.
*
* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The upper or lower triangular matrix A, packed columnwise in
* a linear array. The j-th column of A is stored in the array
* AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
* If DIAG = 'U', the diagonal elements of A are not referenced
* and are assumed to be 1.
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The computed solution vectors. Each vector is stored as a
* column of the matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* XACT (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The exact solution vectors. Each vector is stored as a
* column of the matrix XACT.
*
* LDXACT (input) INTEGER
* The leading dimension of the array XACT. LDXACT >= max(1,N).
*
* FERR (input) DOUBLE PRECISION array, dimension (NRHS)
* The estimated forward error bounds for each solution vector
* X. If XTRUE is the true solution, FERR bounds the magnitude
* of the largest entry in (X - XTRUE) divided by the magnitude
* of the largest entry in X.
*
* BERR (input) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector (i.e., the smallest relative change in any entry of A
* or B that makes X an exact solution).
*
* RESLTS (output) DOUBLE PRECISION array, dimension (2)
* The maximum over the NRHS solution vectors of the ratios:
* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
* RESLTS(2) = BERR / ( (n+1)*EPS + (*) )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN, UNIT, UPPER
INTEGER I, IFU, IMAX, J, JC, K
DOUBLE PRECISION AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, IDAMAX, DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0.
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESLTS( 1 ) = ZERO
RESLTS( 2 ) = ZERO
RETURN
END IF
*
EPS = DLAMCH( 'Epsilon' )
UNFL = DLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
UPPER = LSAME( UPLO, 'U' )
NOTRAN = LSAME( TRANS, 'N' )
UNIT = LSAME( DIAG, 'U' )
*
* Test 1: Compute the maximum of
* norm(X - XACT) / ( norm(X) * FERR )
* over all the vectors X and XACT using the infinity-norm.
*
ERRBND = ZERO
DO 30 J = 1, NRHS
IMAX = IDAMAX( N, X( 1, J ), 1 )
XNORM = MAX( ABS( X( IMAX, J ) ), UNFL )
DIFF = ZERO
DO 10 I = 1, N
DIFF = MAX( DIFF, ABS( X( I, J )-XACT( I, J ) ) )
10 CONTINUE
*
IF( XNORM.GT.ONE ) THEN
GO TO 20
ELSE IF( DIFF.LE.OVFL*XNORM ) THEN
GO TO 20
ELSE
ERRBND = ONE / EPS
GO TO 30
END IF
*
20 CONTINUE
IF( DIFF / XNORM.LE.FERR( J ) ) THEN
ERRBND = MAX( ERRBND, ( DIFF / XNORM ) / FERR( J ) )
ELSE
ERRBND = ONE / EPS
END IF
30 CONTINUE
RESLTS( 1 ) = ERRBND
*
* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where
* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
*
IFU = 0
IF( UNIT )
$ IFU = 1
DO 90 K = 1, NRHS
DO 80 I = 1, N
TMP = ABS( B( I, K ) )
IF( UPPER ) THEN
JC = ( ( I-1 )*I ) / 2
IF( .NOT.NOTRAN ) THEN
DO 40 J = 1, I - IFU
TMP = TMP + ABS( AP( JC+J ) )*ABS( X( J, K ) )
40 CONTINUE
IF( UNIT )
$ TMP = TMP + ABS( X( I, K ) )
ELSE
JC = JC + I
IF( UNIT ) THEN
TMP = TMP + ABS( X( I, K ) )
JC = JC + I
END IF
DO 50 J = I + IFU, N
TMP = TMP + ABS( AP( JC ) )*ABS( X( J, K ) )
JC = JC + J
50 CONTINUE
END IF
ELSE
IF( NOTRAN ) THEN
JC = I
DO 60 J = 1, I - IFU
TMP = TMP + ABS( AP( JC ) )*ABS( X( J, K ) )
JC = JC + N - J
60 CONTINUE
IF( UNIT )
$ TMP = TMP + ABS( X( I, K ) )
ELSE
JC = ( I-1 )*( N-I ) + ( I*( I+1 ) ) / 2
IF( UNIT )
$ TMP = TMP + ABS( X( I, K ) )
DO 70 J = I + IFU, N
TMP = TMP + ABS( AP( JC+J-I ) )*ABS( X( J, K ) )
70 CONTINUE
END IF
END IF
IF( I.EQ.1 ) THEN
AXBI = TMP
ELSE
AXBI = MIN( AXBI, TMP )
END IF
80 CONTINUE
TMP = BERR( K ) / ( ( N+1 )*EPS+( N+1 )*UNFL /
$ MAX( AXBI, ( N+1 )*UNFL ) )
IF( K.EQ.1 ) THEN
RESLTS( 2 ) = TMP
ELSE
RESLTS( 2 ) = MAX( RESLTS( 2 ), TMP )
END IF
90 CONTINUE
*
RETURN
*
* End of DTPT05
*
END
SUBROUTINE DTPT06( RCOND, RCONDC, UPLO, DIAG, N, AP, WORK, RAT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, UPLO
INTEGER N
DOUBLE PRECISION RAT, RCOND, RCONDC
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DTPT06 computes a test ratio comparing RCOND (the reciprocal
* condition number of a triangular matrix A) and RCONDC, the estimate
* computed by DTPCON. Information about the triangular matrix A is
* used if one estimate is zero and the other is non-zero to decide if
* underflow in the estimate is justified.
*
* Arguments
* =========
*
* RCOND (input) DOUBLE PRECISION
* The estimate of the reciprocal condition number obtained by
* forming the explicit inverse of the matrix A and computing
* RCOND = 1/( norm(A) * norm(inv(A)) ).
*
* RCONDC (input) DOUBLE PRECISION
* The estimate of the reciprocal condition number computed by
* DTPCON.
*
* UPLO (input) CHARACTER
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* DIAG (input) CHARACTER
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The upper or lower triangular matrix A, packed columnwise in
* a linear array. The j-th column of A is stored in the array
* AP as follows:
* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j;
* if UPLO = 'L',
* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* RAT (output) DOUBLE PRECISION
* The test ratio. If both RCOND and RCONDC are nonzero,
* RAT = MAX( RCOND, RCONDC )/MIN( RCOND, RCONDC ) - 1.
* If RAT = 0, the two estimates are exactly the same.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION ANORM, BIGNUM, EPS, RMAX, RMIN, SMLNUM
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANTP
EXTERNAL DLAMCH, DLANTP
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Subroutines ..
EXTERNAL DLABAD
* ..
* .. Executable Statements ..
*
EPS = DLAMCH( 'Epsilon' )
RMAX = MAX( RCOND, RCONDC )
RMIN = MIN( RCOND, RCONDC )
*
* Do the easy cases first.
*
IF( RMIN.LT.ZERO ) THEN
*
* Invalid value for RCOND or RCONDC, return 1/EPS.
*
RAT = ONE / EPS
*
ELSE IF( RMIN.GT.ZERO ) THEN
*
* Both estimates are positive, return RMAX/RMIN - 1.
*
RAT = RMAX / RMIN - ONE
*
ELSE IF( RMAX.EQ.ZERO ) THEN
*
* Both estimates zero.
*
RAT = ZERO
*
ELSE
*
* One estimate is zero, the other is non-zero. If the matrix is
* ill-conditioned, return the nonzero estimate multiplied by
* 1/EPS; if the matrix is badly scaled, return the nonzero
* estimate multiplied by BIGNUM/TMAX, where TMAX is the maximum
* element in absolute value in A.
*
SMLNUM = DLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
ANORM = DLANTP( 'M', UPLO, DIAG, N, AP, WORK )
*
RAT = RMAX*( MIN( BIGNUM / MAX( ONE, ANORM ), ONE / EPS ) )
END IF
*
RETURN
*
* End of DTPT06
*
END
SUBROUTINE DTRT01( UPLO, DIAG, N, A, LDA, AINV, LDAINV, RCOND,
$ WORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, UPLO
INTEGER LDA, LDAINV, N
DOUBLE PRECISION RCOND, RESID
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), AINV( LDAINV, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DTRT01 computes the residual for a triangular matrix A times its
* inverse:
* RESID = norm( A*AINV - I ) / ( N * norm(A) * norm(AINV) * EPS ),
* where EPS is the machine epsilon.
*
* Arguments
* ==========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The triangular matrix A. If UPLO = 'U', the leading n by n
* upper triangular part of the array A contains the upper
* triangular matrix, and the strictly lower triangular part of
* A is not referenced. If UPLO = 'L', the leading n by n lower
* triangular part of the array A contains the lower triangular
* matrix, and the strictly upper triangular part of A is not
* referenced. If DIAG = 'U', the diagonal elements of A are
* also not referenced and are assumed to be 1.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* AINV (input/output) DOUBLE PRECISION array, dimension (LDAINV,N)
* On entry, the (triangular) inverse of the matrix A, in the
* same storage format as A.
* On exit, the contents of AINV are destroyed.
*
* LDAINV (input) INTEGER
* The leading dimension of the array AINV. LDAINV >= max(1,N).
*
* RCOND (output) DOUBLE PRECISION
* The reciprocal condition number of A, computed as
* 1/(norm(A) * norm(AINV)).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* RESID (output) DOUBLE PRECISION
* norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER J
DOUBLE PRECISION AINVNM, ANORM, EPS
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANTR
EXTERNAL LSAME, DLAMCH, DLANTR
* ..
* .. External Subroutines ..
EXTERNAL DTRMV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0
*
IF( N.LE.0 ) THEN
RCOND = ONE
RESID = ZERO
RETURN
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0.
*
EPS = DLAMCH( 'Epsilon' )
ANORM = DLANTR( '1', UPLO, DIAG, N, N, A, LDA, WORK )
AINVNM = DLANTR( '1', UPLO, DIAG, N, N, AINV, LDAINV, WORK )
IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
RCOND = ZERO
RESID = ONE / EPS
RETURN
END IF
RCOND = ( ONE / ANORM ) / AINVNM
*
* Set the diagonal of AINV to 1 if AINV has unit diagonal.
*
IF( LSAME( DIAG, 'U' ) ) THEN
DO 10 J = 1, N
AINV( J, J ) = ONE
10 CONTINUE
END IF
*
* Compute A * AINV, overwriting AINV.
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
CALL DTRMV( 'Upper', 'No transpose', DIAG, J, A, LDA,
$ AINV( 1, J ), 1 )
20 CONTINUE
ELSE
DO 30 J = 1, N
CALL DTRMV( 'Lower', 'No transpose', DIAG, N-J+1, A( J, J ),
$ LDA, AINV( J, J ), 1 )
30 CONTINUE
END IF
*
* Subtract 1 from each diagonal element to form A*AINV - I.
*
DO 40 J = 1, N
AINV( J, J ) = AINV( J, J ) - ONE
40 CONTINUE
*
* Compute norm(A*AINV - I) / (N * norm(A) * norm(AINV) * EPS)
*
RESID = DLANTR( '1', UPLO, 'Non-unit', N, N, AINV, LDAINV, WORK )
*
RESID = ( ( RESID*RCOND ) / DBLE( N ) ) / EPS
*
RETURN
*
* End of DTRT01
*
END
SUBROUTINE DTRT02( UPLO, TRANS, DIAG, N, NRHS, A, LDA, X, LDX, B,
$ LDB, WORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER LDA, LDB, LDX, N, NRHS
DOUBLE PRECISION RESID
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ),
$ X( LDX, * )
* ..
*
* Purpose
* =======
*
* DTRT02 computes the residual for the computed solution to a
* triangular system of linear equations A*x = b or A'*x = b.
* Here A is a triangular matrix, A' is the transpose of A, and x and b
* are N by NRHS matrices. The test ratio is the maximum over the
* number of right hand sides of
* norm(b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ),
* where op(A) denotes A or A' and EPS is the machine epsilon.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the operation applied to A.
* = 'N': A *x = b (No transpose)
* = 'T': A'*x = b (Transpose)
* = 'C': A'*x = b (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* 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 matrices X and B. NRHS >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The triangular matrix A. If UPLO = 'U', the leading n by n
* upper triangular part of the array A contains the upper
* triangular matrix, and the strictly lower triangular part of
* A is not referenced. If UPLO = 'L', the leading n by n lower
* triangular part of the array A contains the lower triangular
* matrix, and the strictly upper triangular part of A is not
* referenced. If DIAG = 'U', the diagonal elements of A are
* also not referenced and are assumed to be 1.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The computed solution vectors for the system of linear
* equations.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* RESID (output) DOUBLE PRECISION
* The maximum over the number of right hand sides of
* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER J
DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DASUM, DLAMCH, DLANTR
EXTERNAL LSAME, DASUM, DLAMCH, DLANTR
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DTRMV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Compute the 1-norm of A or A'.
*
IF( LSAME( TRANS, 'N' ) ) THEN
ANORM = DLANTR( '1', UPLO, DIAG, N, N, A, LDA, WORK )
ELSE
ANORM = DLANTR( 'I', UPLO, DIAG, N, N, A, LDA, WORK )
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0.
*
EPS = DLAMCH( 'Epsilon' )
IF( ANORM.LE.ZERO ) THEN
RESID = ONE / EPS
RETURN
END IF
*
* Compute the maximum over the number of right hand sides of
* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS )
*
RESID = ZERO
DO 10 J = 1, NRHS
CALL DCOPY( N, X( 1, J ), 1, WORK, 1 )
CALL DTRMV( UPLO, TRANS, DIAG, N, A, LDA, WORK, 1 )
CALL DAXPY( N, -ONE, B( 1, J ), 1, WORK, 1 )
BNORM = DASUM( N, WORK, 1 )
XNORM = DASUM( N, X( 1, J ), 1 )
IF( XNORM.LE.ZERO ) THEN
RESID = ONE / EPS
ELSE
RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) / EPS )
END IF
10 CONTINUE
*
RETURN
*
* End of DTRT02
*
END
SUBROUTINE DTRT03( UPLO, TRANS, DIAG, N, NRHS, A, LDA, SCALE,
$ CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER LDA, LDB, LDX, N, NRHS
DOUBLE PRECISION RESID, SCALE, TSCAL
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), CNORM( * ),
$ WORK( * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* DTRT03 computes the residual for the solution to a scaled triangular
* system of equations A*x = s*b or A'*x = s*b.
* Here A is a triangular matrix, A' is the transpose of A, s is a
* scalar, and x and b are N by NRHS matrices. The test ratio is the
* maximum over the number of right hand sides of
* norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ),
* where op(A) denotes A or A' and EPS is the machine epsilon.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the operation applied to A.
* = 'N': A *x = s*b (No transpose)
* = 'T': A'*x = s*b (Transpose)
* = 'C': A'*x = s*b (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* 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 matrices X and B. NRHS >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The triangular matrix A. If UPLO = 'U', the leading n by n
* upper triangular part of the array A contains the upper
* triangular matrix, and the strictly lower triangular part of
* A is not referenced. If UPLO = 'L', the leading n by n lower
* triangular part of the array A contains the lower triangular
* matrix, and the strictly upper triangular part of A is not
* referenced. If DIAG = 'U', the diagonal elements of A are
* also not referenced and are assumed to be 1.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* SCALE (input) DOUBLE PRECISION
* The scaling factor s used in solving the triangular system.
*
* CNORM (input) DOUBLE PRECISION array, dimension (N)
* The 1-norms of the columns of A, not counting the diagonal.
*
* TSCAL (input) DOUBLE PRECISION
* The scaling factor used in computing the 1-norms in CNORM.
* CNORM actually contains the column norms of TSCAL*A.
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The computed solution vectors for the system of linear
* equations.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* RESID (output) DOUBLE PRECISION
* The maximum over the number of right hand sides of
* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER IX, J
DOUBLE PRECISION BIGNUM, EPS, ERR, SMLNUM, TNORM, XNORM, XSCAL
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, IDAMAX, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DLABAD, DSCAL, DTRMV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
EPS = DLAMCH( 'Epsilon' )
SMLNUM = DLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
*
* Compute the norm of the triangular matrix A using the column
* norms already computed by DLATRS.
*
TNORM = ZERO
IF( LSAME( DIAG, 'N' ) ) THEN
DO 10 J = 1, N
TNORM = MAX( TNORM, TSCAL*ABS( A( J, J ) )+CNORM( J ) )
10 CONTINUE
ELSE
DO 20 J = 1, N
TNORM = MAX( TNORM, TSCAL+CNORM( J ) )
20 CONTINUE
END IF
*
* Compute the maximum over the number of right hand sides of
* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ).
*
RESID = ZERO
DO 30 J = 1, NRHS
CALL DCOPY( N, X( 1, J ), 1, WORK, 1 )
IX = IDAMAX( N, WORK, 1 )
XNORM = MAX( ONE, ABS( X( IX, J ) ) )
XSCAL = ( ONE / XNORM ) / DBLE( N )
CALL DSCAL( N, XSCAL, WORK, 1 )
CALL DTRMV( UPLO, TRANS, DIAG, N, A, LDA, WORK, 1 )
CALL DAXPY( N, -SCALE*XSCAL, B( 1, J ), 1, WORK, 1 )
IX = IDAMAX( N, WORK, 1 )
ERR = TSCAL*ABS( WORK( IX ) )
IX = IDAMAX( N, X( 1, J ), 1 )
XNORM = ABS( X( IX, J ) )
IF( ERR*SMLNUM.LE.XNORM ) THEN
IF( XNORM.GT.ZERO )
$ ERR = ERR / XNORM
ELSE
IF( ERR.GT.ZERO )
$ ERR = ONE / EPS
END IF
IF( ERR*SMLNUM.LE.TNORM ) THEN
IF( TNORM.GT.ZERO )
$ ERR = ERR / TNORM
ELSE
IF( ERR.GT.ZERO )
$ ERR = ONE / EPS
END IF
RESID = MAX( RESID, ERR )
30 CONTINUE
*
RETURN
*
* End of DTRT03
*
END
SUBROUTINE DTRT05( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X,
$ LDX, XACT, LDXACT, FERR, BERR, RESLTS )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER LDA, LDB, LDX, LDXACT, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ),
$ RESLTS( * ), X( LDX, * ), XACT( LDXACT, * )
* ..
*
* Purpose
* =======
*
* DTRT05 tests the error bounds from iterative refinement for the
* computed solution to a system of equations A*X = B, where A is a
* triangular n by n matrix.
*
* RESLTS(1) = test of the error bound
* = norm(X - XACT) / ( norm(X) * FERR )
*
* A large value is returned if this ratio is not less than one.
*
* RESLTS(2) = residual from the iterative refinement routine
* = the maximum of BERR / ( (n+1)*EPS + (*) ), where
* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the form of the system of equations.
* = 'N': A * X = B (No transpose)
* = 'T': A'* X = B (Transpose)
* = 'C': A'* X = B (Conjugate transpose = Transpose)
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* N (input) INTEGER
* The number of rows of the matrices X, B, and XACT, and the
* order of the matrix A. N >= 0.
*
* NRHS (input) INTEGER
* The number of columns of the matrices X, B, and XACT.
* NRHS >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The triangular matrix A. If UPLO = 'U', the leading n by n
* upper triangular part of the array A contains the upper
* triangular matrix, and the strictly lower triangular part of
* A is not referenced. If UPLO = 'L', the leading n by n lower
* triangular part of the array A contains the lower triangular
* matrix, and the strictly upper triangular part of A is not
* referenced. If DIAG = 'U', the diagonal elements of A are
* also not referenced and are assumed to be 1.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The right hand side vectors for the system of linear
* equations.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The computed solution vectors. Each vector is stored as a
* column of the matrix X.
*
* LDX (input) INTEGER
* The leading dimension of the array X. LDX >= max(1,N).
*
* XACT (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The exact solution vectors. Each vector is stored as a
* column of the matrix XACT.
*
* LDXACT (input) INTEGER
* The leading dimension of the array XACT. LDXACT >= max(1,N).
*
* FERR (input) DOUBLE PRECISION array, dimension (NRHS)
* The estimated forward error bounds for each solution vector
* X. If XTRUE is the true solution, FERR bounds the magnitude
* of the largest entry in (X - XTRUE) divided by the magnitude
* of the largest entry in X.
*
* BERR (input) DOUBLE PRECISION array, dimension (NRHS)
* The componentwise relative backward error of each solution
* vector (i.e., the smallest relative change in any entry of A
* or B that makes X an exact solution).
*
* RESLTS (output) DOUBLE PRECISION array, dimension (2)
* The maximum over the NRHS solution vectors of the ratios:
* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
* RESLTS(2) = BERR / ( (n+1)*EPS + (*) )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN, UNIT, UPPER
INTEGER I, IFU, IMAX, J, K
DOUBLE PRECISION AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, IDAMAX, DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick exit if N = 0 or NRHS = 0.
*
IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
RESLTS( 1 ) = ZERO
RESLTS( 2 ) = ZERO
RETURN
END IF
*
EPS = DLAMCH( 'Epsilon' )
UNFL = DLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
UPPER = LSAME( UPLO, 'U' )
NOTRAN = LSAME( TRANS, 'N' )
UNIT = LSAME( DIAG, 'U' )
*
* Test 1: Compute the maximum of
* norm(X - XACT) / ( norm(X) * FERR )
* over all the vectors X and XACT using the infinity-norm.
*
ERRBND = ZERO
DO 30 J = 1, NRHS
IMAX = IDAMAX( N, X( 1, J ), 1 )
XNORM = MAX( ABS( X( IMAX, J ) ), UNFL )
DIFF = ZERO
DO 10 I = 1, N
DIFF = MAX( DIFF, ABS( X( I, J )-XACT( I, J ) ) )
10 CONTINUE
*
IF( XNORM.GT.ONE ) THEN
GO TO 20
ELSE IF( DIFF.LE.OVFL*XNORM ) THEN
GO TO 20
ELSE
ERRBND = ONE / EPS
GO TO 30
END IF
*
20 CONTINUE
IF( DIFF / XNORM.LE.FERR( J ) ) THEN
ERRBND = MAX( ERRBND, ( DIFF / XNORM ) / FERR( J ) )
ELSE
ERRBND = ONE / EPS
END IF
30 CONTINUE
RESLTS( 1 ) = ERRBND
*
* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where
* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
*
IFU = 0
IF( UNIT )
$ IFU = 1
DO 90 K = 1, NRHS
DO 80 I = 1, N
TMP = ABS( B( I, K ) )
IF( UPPER ) THEN
IF( .NOT.NOTRAN ) THEN
DO 40 J = 1, I - IFU
TMP = TMP + ABS( A( J, I ) )*ABS( X( J, K ) )
40 CONTINUE
IF( UNIT )
$ TMP = TMP + ABS( X( I, K ) )
ELSE
IF( UNIT )
$ TMP = TMP + ABS( X( I, K ) )
DO 50 J = I + IFU, N
TMP = TMP + ABS( A( I, J ) )*ABS( X( J, K ) )
50 CONTINUE
END IF
ELSE
IF( NOTRAN ) THEN
DO 60 J = 1, I - IFU
TMP = TMP + ABS( A( I, J ) )*ABS( X( J, K ) )
60 CONTINUE
IF( UNIT )
$ TMP = TMP + ABS( X( I, K ) )
ELSE
IF( UNIT )
$ TMP = TMP + ABS( X( I, K ) )
DO 70 J = I + IFU, N
TMP = TMP + ABS( A( J, I ) )*ABS( X( J, K ) )
70 CONTINUE
END IF
END IF
IF( I.EQ.1 ) THEN
AXBI = TMP
ELSE
AXBI = MIN( AXBI, TMP )
END IF
80 CONTINUE
TMP = BERR( K ) / ( ( N+1 )*EPS+( N+1 )*UNFL /
$ MAX( AXBI, ( N+1 )*UNFL ) )
IF( K.EQ.1 ) THEN
RESLTS( 2 ) = TMP
ELSE
RESLTS( 2 ) = MAX( RESLTS( 2 ), TMP )
END IF
90 CONTINUE
*
RETURN
*
* End of DTRT05
*
END
SUBROUTINE DTRT06( RCOND, RCONDC, UPLO, DIAG, N, A, LDA, WORK,
$ RAT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, UPLO
INTEGER LDA, N
DOUBLE PRECISION RAT, RCOND, RCONDC
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DTRT06 computes a test ratio comparing RCOND (the reciprocal
* condition number of a triangular matrix A) and RCONDC, the estimate
* computed by DTRCON. Information about the triangular matrix A is
* used if one estimate is zero and the other is non-zero to decide if
* underflow in the estimate is justified.
*
* Arguments
* =========
*
* RCOND (input) DOUBLE PRECISION
* The estimate of the reciprocal condition number obtained by
* forming the explicit inverse of the matrix A and computing
* RCOND = 1/( norm(A) * norm(inv(A)) ).
*
* RCONDC (input) DOUBLE PRECISION
* The estimate of the reciprocal condition number computed by
* DTRCON.
*
* UPLO (input) CHARACTER
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* DIAG (input) CHARACTER
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The triangular matrix A. If UPLO = 'U', the leading n by n
* upper triangular part of the array A contains the upper
* triangular matrix, and the strictly lower triangular part of
* A is not referenced. If UPLO = 'L', the leading n by n lower
* triangular part of the array A contains the lower triangular
* matrix, and the strictly upper triangular part of A is not
* referenced. If DIAG = 'U', the diagonal elements of A are
* also not referenced and are assumed to be 1.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* RAT (output) DOUBLE PRECISION
* The test ratio. If both RCOND and RCONDC are nonzero,
* RAT = MAX( RCOND, RCONDC )/MIN( RCOND, RCONDC ) - 1.
* If RAT = 0, the two estimates are exactly the same.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION ANORM, BIGNUM, EPS, RMAX, RMIN, SMLNUM
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANTR
EXTERNAL DLAMCH, DLANTR
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Subroutines ..
EXTERNAL DLABAD
* ..
* .. Executable Statements ..
*
EPS = DLAMCH( 'Epsilon' )
RMAX = MAX( RCOND, RCONDC )
RMIN = MIN( RCOND, RCONDC )
*
* Do the easy cases first.
*
IF( RMIN.LT.ZERO ) THEN
*
* Invalid value for RCOND or RCONDC, return 1/EPS.
*
RAT = ONE / EPS
*
ELSE IF( RMIN.GT.ZERO ) THEN
*
* Both estimates are positive, return RMAX/RMIN - 1.
*
RAT = RMAX / RMIN - ONE
*
ELSE IF( RMAX.EQ.ZERO ) THEN
*
* Both estimates zero.
*
RAT = ZERO
*
ELSE
*
* One estimate is zero, the other is non-zero. If the matrix is
* ill-conditioned, return the nonzero estimate multiplied by
* 1/EPS; if the matrix is badly scaled, return the nonzero
* estimate multiplied by BIGNUM/TMAX, where TMAX is the maximum
* element in absolute value in A.
*
SMLNUM = DLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
ANORM = DLANTR( 'M', UPLO, DIAG, N, N, A, LDA, WORK )
*
RAT = RMAX*( MIN( BIGNUM / MAX( ONE, ANORM ), ONE / EPS ) )
END IF
*
RETURN
*
* End of DTRT06
*
END
DOUBLE PRECISION FUNCTION DTZT01( M, N, A, AF, LDA, TAU, WORK,
$ LWORK )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* DTZT01 returns
* || A - R*Q || / ( M * eps * ||A|| )
* for an upper trapezoidal A that was factored with DTZRQF.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrices A and AF.
*
* N (input) INTEGER
* The number of columns of the matrices A and AF.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The original upper trapezoidal M by N matrix A.
*
* AF (input) DOUBLE PRECISION array, dimension (LDA,N)
* The output of DTZRQF for input matrix A.
* The lower triangle is not referenced.
*
* LDA (input) INTEGER
* The leading dimension of the arrays A and AF.
*
* TAU (input) DOUBLE PRECISION array, dimension (M)
* Details of the Householder transformations as returned by
* DTZRQF.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of the array WORK. LWORK >= m*n + m.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION NORMA
* ..
* .. Local Arrays ..
DOUBLE PRECISION RWORK( 1 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DLASET, DLATZM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX
* ..
* .. Executable Statements ..
*
DTZT01 = ZERO
*
IF( LWORK.LT.M*N+M ) THEN
CALL XERBLA( 'DTZT01', 8 )
RETURN
END IF
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
NORMA = DLANGE( 'One-norm', M, N, A, LDA, RWORK )
*
* Copy upper triangle R
*
CALL DLASET( 'Full', M, N, ZERO, ZERO, WORK, M )
DO 20 J = 1, M
DO 10 I = 1, J
WORK( ( J-1 )*M+I ) = AF( I, J )
10 CONTINUE
20 CONTINUE
*
* R = R * P(1) * ... *P(m)
*
DO 30 I = 1, M
CALL DLATZM( 'Right', I, N-M+1, AF( I, M+1 ), LDA, TAU( I ),
$ WORK( ( I-1 )*M+1 ), WORK( M*M+1 ), M,
$ WORK( M*N+1 ) )
30 CONTINUE
*
* R = R - A
*
DO 40 I = 1, N
CALL DAXPY( M, -ONE, A( 1, I ), 1, WORK( ( I-1 )*M+1 ), 1 )
40 CONTINUE
*
DTZT01 = DLANGE( 'One-norm', M, N, WORK, M, RWORK )
*
DTZT01 = DTZT01 / ( DLAMCH( 'Epsilon' )*DBLE( MAX( M, N ) ) )
IF( NORMA.NE.ZERO )
$ DTZT01 = DTZT01 / NORMA
*
RETURN
*
* End of DTZT01
*
END
DOUBLE PRECISION FUNCTION DTZT02( M, N, AF, LDA, TAU, WORK,
$ LWORK )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AF( LDA, * ), TAU( * ), WORK( LWORK )
* ..
*
* Purpose
* =======
*
* DTZT02 returns
* || I - Q'*Q || / ( M * eps)
* where the matrix Q is defined by the Householder transformations
* generated by DTZRQF.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix AF.
*
* N (input) INTEGER
* The number of columns of the matrix AF.
*
* AF (input) DOUBLE PRECISION array, dimension (LDA,N)
* The output of DTZRQF.
*
* LDA (input) INTEGER
* The leading dimension of the array AF.
*
* TAU (input) DOUBLE PRECISION array, dimension (M)
* Details of the Householder transformations as returned by
* DTZRQF.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* length of WORK array. Must be >= N*N+N
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
INTEGER I
* ..
* .. Local Arrays ..
DOUBLE PRECISION RWORK( 1 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DLASET, DLATZM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX
* ..
* .. Executable Statements ..
*
DTZT02 = ZERO
*
IF( LWORK.LT.N*N+N ) THEN
CALL XERBLA( 'DTZT02', 7 )
RETURN
END IF
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
* Q := I
*
CALL DLASET( 'Full', N, N, ZERO, ONE, WORK, N )
*
* Q := P(1) * ... * P(m) * Q
*
DO 10 I = M, 1, -1
CALL DLATZM( 'Left', N-M+1, N, AF( I, M+1 ), LDA, TAU( I ),
$ WORK( I ), WORK( M+1 ), N, WORK( N*N+1 ) )
10 CONTINUE
*
* Q := P(m) * ... * P(1) * Q
*
DO 20 I = 1, M
CALL DLATZM( 'Left', N-M+1, N, AF( I, M+1 ), LDA, TAU( I ),
$ WORK( I ), WORK( M+1 ), N, WORK( N*N+1 ) )
20 CONTINUE
*
* Q := Q - I
*
DO 30 I = 1, N
WORK( ( I-1 )*N+I ) = WORK( ( I-1 )*N+I ) - ONE
30 CONTINUE
*
DTZT02 = DLANGE( 'One-norm', N, N, WORK, N, RWORK ) /
$ ( DLAMCH( 'Epsilon' )*DBLE( MAX( M, N ) ) )
RETURN
*
* End of DTZT02
*
END
SUBROUTINE ICOPY( N, SX, INCX, SY, INCY )
*
* -- LAPACK auxiliary test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INCX, INCY, N
* ..
* .. Array Arguments ..
INTEGER SX( * ), SY( * )
* ..
*
* Purpose
* =======
*
* ICOPY copies an integer vector x to an integer vector y.
* Uses unrolled loops for increments equal to 1.
*
* Arguments
* =========
*
* N (input) INTEGER
* The length of the vectors SX and SY.
*
* SX (input) INTEGER array, dimension (1+(N-1)*abs(INCX))
* The vector X.
*
* INCX (input) INTEGER
* The spacing between consecutive elements of SX.
*
* SY (output) INTEGER array, dimension (1+(N-1)*abs(INCY))
* The vector Y.
*
* INCY (input) INTEGER
* The spacing between consecutive elements of SY.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, IX, IY, M, MP1
* ..
* .. Intrinsic Functions ..
INTRINSIC MOD
* ..
* .. Executable Statements ..
*
IF( N.LE.0 )
$ RETURN
IF( INCX.EQ.1 .AND. INCY.EQ.1 )
$ GO TO 20
*
* 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 10 I = 1, N
SY( IY ) = SX( IX )
IX = IX + INCX
IY = IY + INCY
10 CONTINUE
RETURN
*
* Code for both increments equal to 1
*
* Clean-up loop
*
20 CONTINUE
M = MOD( N, 7 )
IF( M.EQ.0 )
$ GO TO 40
DO 30 I = 1, M
SY( I ) = SX( I )
30 CONTINUE
IF( N.LT.7 )
$ RETURN
40 CONTINUE
MP1 = M + 1
DO 50 I = MP1, N, 7
SY( I ) = SX( I )
SY( I+1 ) = SX( I+1 )
SY( I+2 ) = SX( I+2 )
SY( I+3 ) = SX( I+3 )
SY( I+4 ) = SX( I+4 )
SY( I+5 ) = SX( I+5 )
SY( I+6 ) = SX( I+6 )
50 CONTINUE
RETURN
*
* End of ICOPY
*
END
INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3,
$ N4 )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*( * ) NAME, OPTS
INTEGER ISPEC, N1, N2, N3, N4
* ..
*
* Purpose
* =======
*
* ILAENV returns problem-dependent parameters for the local
* environment. See ISPEC for a description of the parameters.
*
* In this version, the problem-dependent parameters are contained in
* the integer array IPARMS in the common block CLAENV and the value
* with index ISPEC is copied to ILAENV. This version of ILAENV is
* to be used in conjunction with XLAENV in TESTING and TIMING.
*
* 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
* = 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 and QZ methods
* for nonsymmetric eigenvalue problems.
* = 9: maximum size of the subproblems at the bottom of the
* computation tree in the divide-and-conquer algorithm
* =10: ieee NaN arithmetic can be trusted not to trap
* =11: infinity arithmetic can be trusted not to trap
*
* Other specifications (up to 100) can be added later.
*
* NAME (input) CHARACTER*(*)
* The name of the calling subroutine.
*
* 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.
*
* (ILAENV) (output) INTEGER
* >= 0: the value of the parameter specified by ISPEC
* < 0: if ILAENV = -k, the k-th argument had an illegal value.
*
* 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 )
*
* =====================================================================
*
* .. Intrinsic Functions ..
INTRINSIC INT, MIN, REAL
* ..
* .. External Functions ..
INTEGER IEEECK
EXTERNAL IEEECK
* ..
* .. Arrays in Common ..
INTEGER IPARMS( 100 )
* ..
* .. Common blocks ..
COMMON / CLAENV / IPARMS
* ..
* .. Save statement ..
SAVE / CLAENV /
* ..
* .. Executable Statements ..
*
IF( ISPEC.GE.1 .AND. ISPEC.LE.5 ) THEN
*
* Return a value from the common block.
*
ILAENV = IPARMS( ISPEC )
*
ELSE IF( ISPEC.EQ.6 ) THEN
*
* Compute SVD crossover point.
*
ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 )
*
ELSE IF( ISPEC.GE.7 .AND. ISPEC.LE.9 ) THEN
*
* Return a value from the common block.
*
ILAENV = IPARMS( ISPEC )
*
ELSE IF( ISPEC.EQ.10 ) THEN
*
* IEEE NaN arithmetic can be trusted not to trap
*
C ILAENV = 0
ILAENV = 1
IF( ILAENV.EQ.1 ) THEN
ILAENV = IEEECK( 0, 0.0, 1.0 )
END IF
*
ELSE IF( ISPEC.EQ.11 ) THEN
*
* Infinity arithmetic can be trusted not to trap
*
C ILAENV = 0
ILAENV = 1
IF( ILAENV.EQ.1 ) THEN
ILAENV = IEEECK( 1, 0.0, 1.0 )
END IF
*
ELSE
*
* Invalid value for ISPEC
*
ILAENV = -1
END IF
*
RETURN
*
* End of ILAENV
*
END
SUBROUTINE XLAENV( ISPEC, NVALUE )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER ISPEC, NVALUE
* ..
*
* Purpose
* =======
*
* XLAENV sets certain machine- and problem-dependent quantities
* which will later be retrieved by ILAENV.
*
* Arguments
* =========
*
* ISPEC (input) INTEGER
* Specifies the parameter to be set in the COMMON array IPARMS.
* = 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
* = 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: another crossover point, for the multishift QR and QZ
* methods for nonsymmetric eigenvalue problems.
* = 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
*
* NVALUE (input) INTEGER
* The value of the parameter specified by ISPEC.
*
* =====================================================================
*
* .. Arrays in Common ..
INTEGER IPARMS( 100 )
* ..
* .. Common blocks ..
COMMON / CLAENV / IPARMS
* ..
* .. Save statement ..
SAVE / CLAENV /
* ..
* .. Executable Statements ..
*
IF( ISPEC.GE.1 .AND. ISPEC.LE.9 ) THEN
IPARMS( ISPEC ) = NVALUE
END IF
*
RETURN
*
* End of XLAENV
*
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/lin/Makefile_javasrc 0000644 0001750 0001750 00000003075 10616163237 025161 0 ustar osallou osallou .SUFFIXES: .f .java
ROOT=../../..
include $(ROOT)/make.def
BLAS=$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR)
LAPACK=$(ROOT)/$(LAPACK_DIR)/$(LAPACK_JAR)
MATGEN=$(ROOT)/$(MATGEN_DIR)/$(MATGEN_JAR)
tester: $(BLAS) $(LAPACK) $(MATGEN) $(OUTDIR)/Lintest.f2j util
/bin/rm -f `find $(OUTDIR) -name "*.class"`
mkdir -p $(JAVASRC_OUTDIR)
$(JAVAC) -classpath .:$(JAVASRC_OUTDIR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(MATGEN):$(BLAS):$(LAPACK) -d $(JAVASRC_OUTDIR) $(OUTDIR)/$(LINTEST_PDIR)/*.java
/bin/rm -f $(JAVASRC_OUTDIR)/$(LINTEST_PDIR)/*.old
$(JAVAB) $(JAVASRC_OUTDIR)/$(LINTEST_PDIR)/*.class
/bin/rm -f $(LINTEST_JAR)
cd $(JAVASRC_OUTDIR); $(JAR) cvf ../$(LINTEST_JAR) `find . -name "*.class"`
$(JAR) uvf $(LINTEST_JAR) `find org -name "*.class"`
$(OUTDIR)/Lintest.f2j: lintest.f
$(MAKE) nojar
$(BLAS):
cd $(ROOT)/$(BLAS_DIR); $(MAKE) -f Makefile_javasrc
$(LAPACK):
cd $(ROOT)/$(LAPACK_DIR); $(MAKE) -f Makefile_javasrc
$(MATGEN):
cd $(ROOT)/$(MATGEN_DIR); $(MAKE) -f Makefile_javasrc
util:
cd $(ROOT)/$(UTIL_DIR); $(MAKE)
runtest: tester
$(JAVA) $(JFLAGS) -cp .:$(LINTEST_JAR):$(MATGEN):$(BLAS):$(LAPACK):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR) $(LINTEST_PACKAGE).Dchkaa < dtest.in
verify: $(ROOT)/$(LINTEST_IDX)
cd $(JAVASRC_OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:..:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(MATGEN_DIR)/$(MATGEN_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/../$(LAPACK_DIR)/$(LAPACK_JAR) $(VERIFY) $(LINTEST_PDIR)/*.class
clean:
/bin/rm -rf *.java *.class *.f2j org $(JAVASRC_OUTDIR) $(OUTDIR) $(LINTEST_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/lin/Makefile 0000644 0001750 0001750 00000003013 10616163237 023440 0 ustar osallou osallou .SUFFIXES: .f .java
ROOT=../../..
include $(ROOT)/make.def
BLAS=$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR)
LAPACK=$(ROOT)/$(LAPACK_DIR)/$(LAPACK_JAR)
MATGEN=$(ROOT)/$(MATGEN_DIR)/$(MATGEN_JAR)
XERBLAFLAGS= -c .:$(ROOT)/$(BLAS_OBJ) -p $(ERR_PACKAGE)
F2JFLAGS=-c .:$(ROOT)/$(BLAS_OBJ):$(ROOT)/$(LAPACK_OBJ):$(ROOT)/$(MATGEN_OBJ) -p $(LINTEST_PACKAGE) -o $(OUTDIR) $(STATIC)
tester: $(BLAS) $(LAPACK) $(MATGEN) $(ROOT)/$(LINTEST_IDX) util
/bin/rm -f $(LINTEST_JAR)
cd $(OUTDIR); $(JAR) cvf ../$(LINTEST_JAR) `find . -name "*.class"`
$(JAR) uvf $(LINTEST_JAR) `find org -name "*.class"`
nojar: $(BLAS) $(LAPACK) $(MATGEN) $(ROOT)/$(LINTEST_IDX) util
$(ROOT)/$(LINTEST_IDX): lintest.f
$(F2J) $(XERBLAFLAGS) xerbla.f > /dev/null
$(F2J) $(F2JFLAGS) $< > /dev/null
$(BLAS):
cd $(ROOT)/$(BLAS_DIR); $(MAKE)
$(LAPACK):
cd $(ROOT)/$(LAPACK_DIR); $(MAKE)
$(MATGEN):
cd $(ROOT)/$(MATGEN_DIR); $(MAKE)
util:
cd $(ROOT)/$(UTIL_DIR); $(MAKE)
runtest: tester
$(JAVA) $(JFLAGS) -cp .:$(LINTEST_JAR):$(MATGEN):$(BLAS):$(LAPACK):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR) $(LINTEST_PACKAGE).Dchkaa < dtest.in
srctest:
$(MAKE) -f Makefile_javasrc runtest
verify: $(ROOT)/$(LINTEST_IDX)
cd $(OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:..:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(MATGEN_DIR)/$(MATGEN_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/../$(LAPACK_DIR)/$(LAPACK_JAR) $(VERIFY) $(LINTEST_PDIR)/*.class
clean:
/bin/rm -rf *.java *.class *.f2j org $(JAVASRC_OUTDIR) $(OUTDIR) $(LINTEST_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/lin/dtest.in 0000644 0001750 0001750 00000003727 10616163237 023467 0 ustar osallou osallou Data file for testing DOUBLE PRECISION LAPACK linear eqn. routines
7 Number of values of M
0 1 2 3 5 10 50 Values of M (row dimension)
7 Number of values of N
0 1 2 3 5 10 50 Values of N (column dimension)
3 Number of values of NRHS
1 2 15 Values of NRHS (number of right hand sides)
5 Number of values of NB
1 3 3 3 20 Values of NB (the blocksize)
1 0 5 9 1 Values of NX (crossover point)
30.0 Threshold value of test ratio
T Put T to test the LAPACK routines
T Put T to test the driver routines
T Put T to test the error exits
DGE 11 List types on next line if 0 < NTYPES < 11
DGB 8 List types on next line if 0 < NTYPES < 8
DGT 12 List types on next line if 0 < NTYPES < 12
DPO 9 List types on next line if 0 < NTYPES < 9
DPP 9 List types on next line if 0 < NTYPES < 9
DPB 8 List types on next line if 0 < NTYPES < 8
DPT 12 List types on next line if 0 < NTYPES < 12
DSY 10 List types on next line if 0 < NTYPES < 10
DSP 10 List types on next line if 0 < NTYPES < 10
DTR 18 List types on next line if 0 < NTYPES < 18
DTP 18 List types on next line if 0 < NTYPES < 18
DTB 17 List types on next line if 0 < NTYPES < 17
DQR 8 List types on next line if 0 < NTYPES < 8
DRQ 8 List types on next line if 0 < NTYPES < 8
DLQ 8 List types on next line if 0 < NTYPES < 8
DQL 8 List types on next line if 0 < NTYPES < 8
DQP 6 List types on next line if 0 < NTYPES < 6
DTZ 3 List types on next line if 0 < NTYPES < 3
DLS 6 List types on next line if 0 < NTYPES < 6
DEQ
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/lin/xerbla.f 0000644 0001750 0001750 00000004623 10616163237 023434 0 ustar osallou osallou SUBROUTINE XERBLA( SRNAME, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*6 SRNAME
INTEGER INFO
* ..
*
* Purpose
* =======
*
* This is a special version of XERBLA to be used only as part of
* the test program for testing error exits from the LAPACK routines.
* Error messages are printed if INFO.NE.INFOT or if SRNAME.NE.SRMANT,
* where INFOT and SRNAMT are values stored in COMMON.
*
* Arguments
* =========
*
* SRNAME (input) CHARACTER*6
* The name of the subroutine calling XERBLA. This name should
* match the COMMON variable SRNAMT.
*
* INFO (input) INTEGER
* The error return code from the calling subroutine. INFO
* should equal the COMMON variable INFOT.
*
* Further Details
* ======= =======
*
* The following variables are passed via the common blocks INFOC and
* SRNAMC:
*
* INFOT INTEGER Expected integer return code
* NOUT INTEGER Unit number for printing error messages
* OK LOGICAL Set to .TRUE. if INFO = INFOT and
* SRNAME = SRNAMT, otherwise set to .FALSE.
* LERR LOGICAL Set to .TRUE., indicating that XERBLA was called
* SRNAMT CHARACTER*6 Expected name of calling subroutine
*
*
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
LERR = .TRUE.
IF( INFO.NE.INFOT ) THEN
IF( INFOT.NE.0 ) THEN
WRITE( NOUT, FMT = 9999 )SRNAMT, INFO, INFOT
ELSE
WRITE( NOUT, FMT = 9997 )SRNAME, INFO
END IF
OK = .FALSE.
END IF
IF( SRNAME.NE.SRNAMT ) THEN
WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT
OK = .FALSE.
END IF
RETURN
*
9999 FORMAT( ' *** XERBLA was called from ', A6, ' with INFO = ', I6,
$ ' instead of ', I2, ' ***' )
9998 FORMAT( ' *** XERBLA was called with SRNAME = ', A6,
$ ' instead of ', A6, ' ***' )
9997 FORMAT( ' *** On entry to ', A6, ' parameter number ', I6,
$ ' had an illegal value ***' )
*
* End of XERBLA
*
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/smatgen/ 0000755 0001750 0001750 00000000000 11734055026 022655 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/smatgen/Makefile_javasrc 0000644 0001750 0001750 00000002316 10616442122 026023 0 ustar osallou osallou .SUFFIXES: .f .java
ROOT=../../..
include $(ROOT)/make.def
BLAS=$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR)
LAPACK=$(ROOT)/$(LAPACK_DIR)/$(LAPACK_JAR)
tester: $(BLAS) $(LAPACK) $(OUTDIR)/Smatgen.f2j
/bin/rm -f `find $(OUTDIR) -name "*.class"`
mkdir -p $(JAVASRC_OUTDIR)
$(JAVAC) -classpath $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/$(LAPACK_DIR)/$(LAPACK_JAR) -d $(JAVASRC_OUTDIR) $(OUTDIR)/$(SMATGEN_PDIR)/*.java
/bin/rm -f $(JAVASRC_OUTDIR)/$(SMATGEN_PDIR)/*.old
$(JAVAB) $(JAVASRC_OUTDIR)/$(SMATGEN_PDIR)/*.class
/bin/rm -f $(SMATGEN_JAR)
cd $(JAVASRC_OUTDIR); $(JAR) cvf ../$(SMATGEN_JAR) `find . -name "*.class"`
$(OUTDIR)/Smatgen.f2j: smatgen.f
$(MAKE) nojar
$(BLAS):
cd $(ROOT)/$(BLAS_DIR); $(MAKE) -f Makefile_javasrc
$(LAPACK):
cd $(ROOT)/$(LAPACK_DIR); $(MAKE) -f Makefile_javasrc
verify: $(ROOT)/$(SMATGEN_IDX)
cd $(JAVASRC_OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/../$(LAPACK_DIR)/$(LAPACK_JAR) $(VERIFY) $(SMATGEN_PDIR)/*.class
clean:
/bin/rm -rf *.java *.class *.f2j $(JAVASRC_OUTDIR) $(OUTDIR) $(SMATGEN_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/smatgen/Makefile 0000644 0001750 0001750 00000001776 10616442122 024323 0 ustar osallou osallou .SUFFIXES: .f .java
ROOT=../../..
include $(ROOT)/make.def
BLAS=$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR)
LAPACK=$(ROOT)/$(LAPACK_DIR)/$(LAPACK_JAR)
F2JFLAGS=-c .:$(ROOT)/$(BLAS_OBJ):$(ROOT)/$(ERR_OBJ):$(ROOT)/$(LAPACK_OBJ) -p $(SMATGEN_PACKAGE) -o $(OUTDIR) $(STATIC)
tester: $(BLAS) $(LAPACK) $(ROOT)/$(SMATGEN_IDX)
/bin/rm -f $(SMATGEN_JAR)
cd $(OUTDIR); $(JAR) cvf ../$(SMATGEN_JAR) `find . -name "*.class"`
nojar: $(BLAS) $(LAPACK) $(ROOT)/$(SMATGEN_IDX)
javasrc:
$(MAKE) -f Makefile_javasrc
$(ROOT)/$(SMATGEN_IDX): smatgen.f
$(F2J) $(F2JFLAGS) $< > /dev/null
$(BLAS):
cd $(ROOT)/$(BLAS_DIR); $(MAKE)
$(LAPACK):
cd $(ROOT)/$(LAPACK_DIR); $(MAKE)
verify: $(ROOT)/$(SMATGEN_IDX)
cd $(OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/../$(LAPACK_DIR)/$(LAPACK_JAR) $(VERIFY) $(SMATGEN_PDIR)/*.class
clean:
/bin/rm -rf *.java *.class *.f2j $(JAVASRC_OUTDIR) $(OUTDIR) $(SMATGEN_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/smatgen/smatgen.f 0000644 0001750 0001750 00000545771 10616163241 024502 0 ustar osallou osallou SUBROUTINE SLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO )
*
* -- LAPACK auxiliary test routine (version 3.1)
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, KL, KU, LDA, M, N
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
REAL A( LDA, * ), D( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SLAGGE generates a real general m by n matrix A, by pre- and post-
* multiplying a real diagonal matrix D with random orthogonal matrices:
* A = U*D*V. The lower and upper bandwidths may then be reduced to
* kl and ku by additional orthogonal transformations.
*
* 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.
*
* KL (input) INTEGER
* The number of nonzero subdiagonals within the band of A.
* 0 <= KL <= M-1.
*
* KU (input) INTEGER
* The number of nonzero superdiagonals within the band of A.
* 0 <= KU <= N-1.
*
* D (input) REAL array, dimension (min(M,N))
* The diagonal elements of the diagonal matrix D.
*
* A (output) REAL array, dimension (LDA,N)
* The generated m by n matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= M.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry, the seed of the random number generator; the array
* elements must be between 0 and 4095, and ISEED(4) must be
* odd.
* On exit, the seed is updated.
*
* WORK (workspace) REAL array, dimension (M+N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
REAL TAU, WA, WB, WN
* ..
* .. External Subroutines ..
EXTERNAL SGEMV, SGER, SLARNV, SSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SIGN
* ..
* .. External Functions ..
REAL SNRM2
EXTERNAL SNRM2
* ..
* .. 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( KL.LT.0 .OR. KL.GT.M-1 ) THEN
INFO = -3
ELSE IF( KU.LT.0 .OR. KU.GT.N-1 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -7
END IF
IF( INFO.LT.0 ) THEN
CALL XERBLA( 'SLAGGE', -INFO )
RETURN
END IF
*
* initialize A to diagonal matrix
*
DO 20 J = 1, N
DO 10 I = 1, M
A( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
DO 30 I = 1, MIN( M, N )
A( I, I ) = D( I )
30 CONTINUE
*
* pre- and post-multiply A by random orthogonal matrices
*
DO 40 I = MIN( M, N ), 1, -1
IF( I.LT.M ) THEN
*
* generate random reflection
*
CALL SLARNV( 3, ISEED, M-I+1, WORK )
WN = SNRM2( M-I+1, WORK, 1 )
WA = SIGN( WN, WORK( 1 ) )
IF( WN.EQ.ZERO ) THEN
TAU = ZERO
ELSE
WB = WORK( 1 ) + WA
CALL SSCAL( M-I, ONE / WB, WORK( 2 ), 1 )
WORK( 1 ) = ONE
TAU = WB / WA
END IF
*
* multiply A(i:m,i:n) by random reflection from the left
*
CALL SGEMV( 'Transpose', M-I+1, N-I+1, ONE, A( I, I ), LDA,
$ WORK, 1, ZERO, WORK( M+1 ), 1 )
CALL SGER( M-I+1, N-I+1, -TAU, WORK, 1, WORK( M+1 ), 1,
$ A( I, I ), LDA )
END IF
IF( I.LT.N ) THEN
*
* generate random reflection
*
CALL SLARNV( 3, ISEED, N-I+1, WORK )
WN = SNRM2( N-I+1, WORK, 1 )
WA = SIGN( WN, WORK( 1 ) )
IF( WN.EQ.ZERO ) THEN
TAU = ZERO
ELSE
WB = WORK( 1 ) + WA
CALL SSCAL( N-I, ONE / WB, WORK( 2 ), 1 )
WORK( 1 ) = ONE
TAU = WB / WA
END IF
*
* multiply A(i:m,i:n) by random reflection from the right
*
CALL SGEMV( 'No transpose', M-I+1, N-I+1, ONE, A( I, I ),
$ LDA, WORK, 1, ZERO, WORK( N+1 ), 1 )
CALL SGER( M-I+1, N-I+1, -TAU, WORK( N+1 ), 1, WORK, 1,
$ A( I, I ), LDA )
END IF
40 CONTINUE
*
* Reduce number of subdiagonals to KL and number of superdiagonals
* to KU
*
DO 70 I = 1, MAX( M-1-KL, N-1-KU )
IF( KL.LE.KU ) THEN
*
* annihilate subdiagonal elements first (necessary if KL = 0)
*
IF( I.LE.MIN( M-1-KL, N ) ) THEN
*
* generate reflection to annihilate A(kl+i+1:m,i)
*
WN = SNRM2( M-KL-I+1, A( KL+I, I ), 1 )
WA = SIGN( WN, A( KL+I, I ) )
IF( WN.EQ.ZERO ) THEN
TAU = ZERO
ELSE
WB = A( KL+I, I ) + WA
CALL SSCAL( M-KL-I, ONE / WB, A( KL+I+1, I ), 1 )
A( KL+I, I ) = ONE
TAU = WB / WA
END IF
*
* apply reflection to A(kl+i:m,i+1:n) from the left
*
CALL SGEMV( 'Transpose', M-KL-I+1, N-I, ONE,
$ A( KL+I, I+1 ), LDA, A( KL+I, I ), 1, ZERO,
$ WORK, 1 )
CALL SGER( M-KL-I+1, N-I, -TAU, A( KL+I, I ), 1, WORK, 1,
$ A( KL+I, I+1 ), LDA )
A( KL+I, I ) = -WA
END IF
*
IF( I.LE.MIN( N-1-KU, M ) ) THEN
*
* generate reflection to annihilate A(i,ku+i+1:n)
*
WN = SNRM2( N-KU-I+1, A( I, KU+I ), LDA )
WA = SIGN( WN, A( I, KU+I ) )
IF( WN.EQ.ZERO ) THEN
TAU = ZERO
ELSE
WB = A( I, KU+I ) + WA
CALL SSCAL( N-KU-I, ONE / WB, A( I, KU+I+1 ), LDA )
A( I, KU+I ) = ONE
TAU = WB / WA
END IF
*
* apply reflection to A(i+1:m,ku+i:n) from the right
*
CALL SGEMV( 'No transpose', M-I, N-KU-I+1, ONE,
$ A( I+1, KU+I ), LDA, A( I, KU+I ), LDA, ZERO,
$ WORK, 1 )
CALL SGER( M-I, N-KU-I+1, -TAU, WORK, 1, A( I, KU+I ),
$ LDA, A( I+1, KU+I ), LDA )
A( I, KU+I ) = -WA
END IF
ELSE
*
* annihilate superdiagonal elements first (necessary if
* KU = 0)
*
IF( I.LE.MIN( N-1-KU, M ) ) THEN
*
* generate reflection to annihilate A(i,ku+i+1:n)
*
WN = SNRM2( N-KU-I+1, A( I, KU+I ), LDA )
WA = SIGN( WN, A( I, KU+I ) )
IF( WN.EQ.ZERO ) THEN
TAU = ZERO
ELSE
WB = A( I, KU+I ) + WA
CALL SSCAL( N-KU-I, ONE / WB, A( I, KU+I+1 ), LDA )
A( I, KU+I ) = ONE
TAU = WB / WA
END IF
*
* apply reflection to A(i+1:m,ku+i:n) from the right
*
CALL SGEMV( 'No transpose', M-I, N-KU-I+1, ONE,
$ A( I+1, KU+I ), LDA, A( I, KU+I ), LDA, ZERO,
$ WORK, 1 )
CALL SGER( M-I, N-KU-I+1, -TAU, WORK, 1, A( I, KU+I ),
$ LDA, A( I+1, KU+I ), LDA )
A( I, KU+I ) = -WA
END IF
*
IF( I.LE.MIN( M-1-KL, N ) ) THEN
*
* generate reflection to annihilate A(kl+i+1:m,i)
*
WN = SNRM2( M-KL-I+1, A( KL+I, I ), 1 )
WA = SIGN( WN, A( KL+I, I ) )
IF( WN.EQ.ZERO ) THEN
TAU = ZERO
ELSE
WB = A( KL+I, I ) + WA
CALL SSCAL( M-KL-I, ONE / WB, A( KL+I+1, I ), 1 )
A( KL+I, I ) = ONE
TAU = WB / WA
END IF
*
* apply reflection to A(kl+i:m,i+1:n) from the left
*
CALL SGEMV( 'Transpose', M-KL-I+1, N-I, ONE,
$ A( KL+I, I+1 ), LDA, A( KL+I, I ), 1, ZERO,
$ WORK, 1 )
CALL SGER( M-KL-I+1, N-I, -TAU, A( KL+I, I ), 1, WORK, 1,
$ A( KL+I, I+1 ), LDA )
A( KL+I, I ) = -WA
END IF
END IF
*
DO 50 J = KL + I + 1, M
A( J, I ) = ZERO
50 CONTINUE
*
DO 60 J = KU + I + 1, N
A( I, J ) = ZERO
60 CONTINUE
70 CONTINUE
RETURN
*
* End of SLAGGE
*
END
SUBROUTINE SLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO )
*
* -- LAPACK auxiliary test routine (version 3.1)
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, N
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
REAL A( LDA, * ), D( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SLAGSY generates a real symmetric matrix A, by pre- and post-
* multiplying a real diagonal matrix D with a random orthogonal matrix:
* A = U*D*U'. The semi-bandwidth may then be reduced to k by additional
* orthogonal transformations.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* K (input) INTEGER
* The number of nonzero subdiagonals within the band of A.
* 0 <= K <= N-1.
*
* D (input) REAL array, dimension (N)
* The diagonal elements of the diagonal matrix D.
*
* A (output) REAL array, dimension (LDA,N)
* The generated n by n symmetric matrix A (the full matrix is
* stored).
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= N.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry, the seed of the random number generator; the array
* elements must be between 0 and 4095, and ISEED(4) must be
* odd.
* On exit, the seed is updated.
*
* WORK (workspace) REAL array, dimension (2*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, HALF
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, HALF = 0.5E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
REAL ALPHA, TAU, WA, WB, WN
* ..
* .. External Subroutines ..
EXTERNAL SAXPY, SGEMV, SGER, SLARNV, SSCAL, SSYMV,
$ SSYR2, XERBLA
* ..
* .. External Functions ..
REAL SDOT, SNRM2
EXTERNAL SDOT, SNRM2
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SIGN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( K.LT.0 .OR. K.GT.N-1 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
END IF
IF( INFO.LT.0 ) THEN
CALL XERBLA( 'SLAGSY', -INFO )
RETURN
END IF
*
* initialize lower triangle of A to diagonal matrix
*
DO 20 J = 1, N
DO 10 I = J + 1, N
A( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
DO 30 I = 1, N
A( I, I ) = D( I )
30 CONTINUE
*
* Generate lower triangle of symmetric matrix
*
DO 40 I = N - 1, 1, -1
*
* generate random reflection
*
CALL SLARNV( 3, ISEED, N-I+1, WORK )
WN = SNRM2( N-I+1, WORK, 1 )
WA = SIGN( WN, WORK( 1 ) )
IF( WN.EQ.ZERO ) THEN
TAU = ZERO
ELSE
WB = WORK( 1 ) + WA
CALL SSCAL( N-I, ONE / WB, WORK( 2 ), 1 )
WORK( 1 ) = ONE
TAU = WB / WA
END IF
*
* apply random reflection to A(i:n,i:n) from the left
* and the right
*
* compute y := tau * A * u
*
CALL SSYMV( 'Lower', N-I+1, TAU, A( I, I ), LDA, WORK, 1, ZERO,
$ WORK( N+1 ), 1 )
*
* compute v := y - 1/2 * tau * ( y, u ) * u
*
ALPHA = -HALF*TAU*SDOT( N-I+1, WORK( N+1 ), 1, WORK, 1 )
CALL SAXPY( N-I+1, ALPHA, WORK, 1, WORK( N+1 ), 1 )
*
* apply the transformation as a rank-2 update to A(i:n,i:n)
*
CALL SSYR2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1,
$ A( I, I ), LDA )
40 CONTINUE
*
* Reduce number of subdiagonals to K
*
DO 60 I = 1, N - 1 - K
*
* generate reflection to annihilate A(k+i+1:n,i)
*
WN = SNRM2( N-K-I+1, A( K+I, I ), 1 )
WA = SIGN( WN, A( K+I, I ) )
IF( WN.EQ.ZERO ) THEN
TAU = ZERO
ELSE
WB = A( K+I, I ) + WA
CALL SSCAL( N-K-I, ONE / WB, A( K+I+1, I ), 1 )
A( K+I, I ) = ONE
TAU = WB / WA
END IF
*
* apply reflection to A(k+i:n,i+1:k+i-1) from the left
*
CALL SGEMV( 'Transpose', N-K-I+1, K-1, ONE, A( K+I, I+1 ), LDA,
$ A( K+I, I ), 1, ZERO, WORK, 1 )
CALL SGER( N-K-I+1, K-1, -TAU, A( K+I, I ), 1, WORK, 1,
$ A( K+I, I+1 ), LDA )
*
* apply reflection to A(k+i:n,k+i:n) from the left and the right
*
* compute y := tau * A * u
*
CALL SSYMV( 'Lower', N-K-I+1, TAU, A( K+I, K+I ), LDA,
$ A( K+I, I ), 1, ZERO, WORK, 1 )
*
* compute v := y - 1/2 * tau * ( y, u ) * u
*
ALPHA = -HALF*TAU*SDOT( N-K-I+1, WORK, 1, A( K+I, I ), 1 )
CALL SAXPY( N-K-I+1, ALPHA, A( K+I, I ), 1, WORK, 1 )
*
* apply symmetric rank-2 update to A(k+i:n,k+i:n)
*
CALL SSYR2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1,
$ A( K+I, K+I ), LDA )
*
A( K+I, I ) = -WA
DO 50 J = K + I + 1, N
A( J, I ) = ZERO
50 CONTINUE
60 CONTINUE
*
* Store full symmetric matrix
*
DO 80 J = 1, N
DO 70 I = J + 1, N
A( J, I ) = A( I, J )
70 CONTINUE
80 CONTINUE
RETURN
*
* End of SLAGSY
*
END
SUBROUTINE SLAKF2( M, N, A, LDA, B, D, E, Z, LDZ )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDZ, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDA, * ), D( LDA, * ),
$ E( LDA, * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* Form the 2*M*N by 2*M*N matrix
*
* Z = [ kron(In, A) -kron(B', Im) ]
* [ kron(In, D) -kron(E', Im) ],
*
* where In is the identity matrix of size n and X' is the transpose
* of X. kron(X, Y) is the Kronecker product between the matrices X
* and Y.
*
* Arguments
* =========
*
* M (input) INTEGER
* Size of matrix, must be >= 1.
*
* N (input) INTEGER
* Size of matrix, must be >= 1.
*
* A (input) REAL, dimension ( LDA, M )
* The matrix A in the output matrix Z.
*
* LDA (input) INTEGER
* The leading dimension of A, B, D, and E. ( LDA >= M+N )
*
* B (input) REAL, dimension ( LDA, N )
* D (input) REAL, dimension ( LDA, M )
* E (input) REAL, dimension ( LDA, N )
* The matrices used in forming the output matrix Z.
*
* Z (output) REAL, dimension ( LDZ, 2*M*N )
* The resultant Kronecker M*N*2 by M*N*2 matrix (see above.)
*
* LDZ (input) INTEGER
* The leading dimension of Z. ( LDZ >= 2*M*N )
*
* ====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, IK, J, JK, L, MN, MN2
* ..
* .. External Subroutines ..
EXTERNAL SLASET
* ..
* .. Executable Statements ..
*
* Initialize Z
*
MN = M*N
MN2 = 2*MN
CALL SLASET( 'Full', MN2, MN2, ZERO, ZERO, Z, LDZ )
*
IK = 1
DO 50 L = 1, N
*
* form kron(In, A)
*
DO 20 I = 1, M
DO 10 J = 1, M
Z( IK+I-1, IK+J-1 ) = A( I, J )
10 CONTINUE
20 CONTINUE
*
* form kron(In, D)
*
DO 40 I = 1, M
DO 30 J = 1, M
Z( IK+MN+I-1, IK+J-1 ) = D( I, J )
30 CONTINUE
40 CONTINUE
*
IK = IK + M
50 CONTINUE
*
IK = 1
DO 90 L = 1, N
JK = MN + 1
*
DO 80 J = 1, N
*
* form -kron(B', Im)
*
DO 60 I = 1, M
Z( IK+I-1, JK+I-1 ) = -B( J, L )
60 CONTINUE
*
* form -kron(E', Im)
*
DO 70 I = 1, M
Z( IK+MN+I-1, JK+I-1 ) = -E( J, L )
70 CONTINUE
*
JK = JK + M
80 CONTINUE
*
IK = IK + M
90 CONTINUE
*
RETURN
*
* End of SLAKF2
*
END
REAL FUNCTION SLARAN( ISEED )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Array Arguments ..
INTEGER ISEED( 4 )
* ..
*
* Purpose
* =======
*
* SLARAN returns a random real number from a uniform (0,1)
* distribution.
*
* Arguments
* =========
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry, the seed of the random number generator; the array
* elements must be between 0 and 4095, and ISEED(4) must be
* odd.
* On exit, the seed is updated.
*
* Further Details
* ===============
*
* This routine uses a multiplicative congruential method with modulus
* 2**48 and multiplier 33952834046453 (see G.S.Fishman,
* 'Multiplicative congruential random number generators with modulus
* 2**b: an exhaustive analysis for b = 32 and a partial analysis for
* b = 48', Math. Comp. 189, pp 331-344, 1990).
*
* 48-bit integers are stored in 4 integer array elements with 12 bits
* per element. Hence the routine is portable across machines with
* integers of 32 bits or more.
*
* =====================================================================
*
* .. Parameters ..
INTEGER M1, M2, M3, M4
PARAMETER ( M1 = 494, M2 = 322, M3 = 2508, M4 = 2549 )
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
INTEGER IPW2
REAL R
PARAMETER ( IPW2 = 4096, R = ONE / IPW2 )
* ..
* .. Local Scalars ..
INTEGER IT1, IT2, IT3, IT4
REAL RNDOUT
* ..
* .. Intrinsic Functions ..
INTRINSIC MOD, REAL
* ..
* .. Executable Statements ..
10 CONTINUE
*
* multiply the seed by the multiplier modulo 2**48
*
IT4 = ISEED( 4 )*M4
IT3 = IT4 / IPW2
IT4 = IT4 - IPW2*IT3
IT3 = IT3 + ISEED( 3 )*M4 + ISEED( 4 )*M3
IT2 = IT3 / IPW2
IT3 = IT3 - IPW2*IT2
IT2 = IT2 + ISEED( 2 )*M4 + ISEED( 3 )*M3 + ISEED( 4 )*M2
IT1 = IT2 / IPW2
IT2 = IT2 - IPW2*IT1
IT1 = IT1 + ISEED( 1 )*M4 + ISEED( 2 )*M3 + ISEED( 3 )*M2 +
$ ISEED( 4 )*M1
IT1 = MOD( IT1, IPW2 )
*
* return updated seed
*
ISEED( 1 ) = IT1
ISEED( 2 ) = IT2
ISEED( 3 ) = IT3
ISEED( 4 ) = IT4
*
* convert 48-bit integer to a real number in the interval (0,1)
*
RNDOUT = R*( REAL( IT1 )+R*( REAL( IT2 )+R*( REAL( IT3 )+R*
$ ( REAL( IT4 ) ) ) ) )
*
IF (RNDOUT.EQ.1.0) THEN
* If a real number has n bits of precision, and the first
* n bits of the 48-bit integer above happen to be all 1 (which
* will occur about once every 2**n calls), then SLARAN will
* be rounded to exactly 1.0. In IEEE single precision arithmetic,
* this will happen relatively often since n = 24.
* Since SLARAN is not supposed to return exactly 0.0 or 1.0
* (and some callers of SLARAN, such as CLARND, depend on that),
* the statistically correct thing to do in this situation is
* simply to iterate again.
* N.B. the case SLARAN = 0.0 should not be possible.
*
GOTO 10
END IF
*
SLARAN = RNDOUT
RETURN
*
* End of SLARAN
*
END
SUBROUTINE SLARGE( N, A, LDA, ISEED, WORK, INFO )
*
* -- LAPACK auxiliary test routine (version 3.1)
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
REAL A( LDA, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SLARGE pre- and post-multiplies a real general n by n matrix A
* with a random orthogonal matrix: A = U*D*U'.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the original n by n matrix A.
* On exit, A is overwritten by U*A*U' for some random
* orthogonal matrix U.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= N.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry, the seed of the random number generator; the array
* elements must be between 0 and 4095, and ISEED(4) must be
* odd.
* On exit, the seed is updated.
*
* WORK (workspace) REAL array, dimension (2*N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I
REAL TAU, WA, WB, WN
* ..
* .. External Subroutines ..
EXTERNAL SGEMV, SGER, SLARNV, SSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SIGN
* ..
* .. External Functions ..
REAL SNRM2
EXTERNAL SNRM2
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -3
END IF
IF( INFO.LT.0 ) THEN
CALL XERBLA( 'SLARGE', -INFO )
RETURN
END IF
*
* pre- and post-multiply A by random orthogonal matrix
*
DO 10 I = N, 1, -1
*
* generate random reflection
*
CALL SLARNV( 3, ISEED, N-I+1, WORK )
WN = SNRM2( N-I+1, WORK, 1 )
WA = SIGN( WN, WORK( 1 ) )
IF( WN.EQ.ZERO ) THEN
TAU = ZERO
ELSE
WB = WORK( 1 ) + WA
CALL SSCAL( N-I, ONE / WB, WORK( 2 ), 1 )
WORK( 1 ) = ONE
TAU = WB / WA
END IF
*
* multiply A(i:n,1:n) by random reflection from the left
*
CALL SGEMV( 'Transpose', N-I+1, N, ONE, A( I, 1 ), LDA, WORK,
$ 1, ZERO, WORK( N+1 ), 1 )
CALL SGER( N-I+1, N, -TAU, WORK, 1, WORK( N+1 ), 1, A( I, 1 ),
$ LDA )
*
* multiply A(1:n,i:n) by random reflection from the right
*
CALL SGEMV( 'No transpose', N, N-I+1, ONE, A( 1, I ), LDA,
$ WORK, 1, ZERO, WORK( N+1 ), 1 )
CALL SGER( N, N-I+1, -TAU, WORK( N+1 ), 1, WORK, 1, A( 1, I ),
$ LDA )
10 CONTINUE
RETURN
*
* End of SLARGE
*
END
REAL FUNCTION SLARND( IDIST, ISEED )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IDIST
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
* ..
*
* Purpose
* =======
*
* SLARND returns a random real number from a uniform or normal
* distribution.
*
* Arguments
* =========
*
* IDIST (input) INTEGER
* Specifies the distribution of the random numbers:
* = 1: uniform (0,1)
* = 2: uniform (-1,1)
* = 3: normal (0,1)
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry, the seed of the random number generator; the array
* elements must be between 0 and 4095, and ISEED(4) must be
* odd.
* On exit, the seed is updated.
*
* Further Details
* ===============
*
* This routine calls the auxiliary routine SLARAN to generate a random
* real number from a uniform (0,1) distribution. The Box-Muller method
* is used to transform numbers from a uniform to a normal distribution.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, TWO
PARAMETER ( ONE = 1.0E+0, TWO = 2.0E+0 )
REAL TWOPI
PARAMETER ( TWOPI = 6.2831853071795864769252867663E+0 )
* ..
* .. Local Scalars ..
REAL T1, T2
* ..
* .. External Functions ..
REAL SLARAN
EXTERNAL SLARAN
* ..
* .. Intrinsic Functions ..
INTRINSIC COS, LOG, SQRT
* ..
* .. Executable Statements ..
*
* Generate a real random number from a uniform (0,1) distribution
*
T1 = SLARAN( ISEED )
*
IF( IDIST.EQ.1 ) THEN
*
* uniform (0,1)
*
SLARND = T1
ELSE IF( IDIST.EQ.2 ) THEN
*
* uniform (-1,1)
*
SLARND = TWO*T1 - ONE
ELSE IF( IDIST.EQ.3 ) THEN
*
* normal (0,1)
*
T2 = SLARAN( ISEED )
SLARND = SQRT( -TWO*LOG( T1 ) )*COS( TWOPI*T2 )
END IF
RETURN
*
* End of SLARND
*
END
SUBROUTINE SLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO )
*
* -- LAPACK auxiliary test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER INIT, SIDE
INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
REAL A( LDA, * ), X( * )
* ..
*
* Purpose
* =======
*
* SLAROR pre- or post-multiplies an M by N matrix A by a random
* orthogonal matrix U, overwriting A. A may optionally be initialized
* to the identity matrix before multiplying by U. U is generated using
* the method of G.W. Stewart (SIAM J. Numer. Anal. 17, 1980, 403-409).
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* Specifies whether A is multiplied on the left or right by U.
* = 'L': Multiply A on the left (premultiply) by U
* = 'R': Multiply A on the right (postmultiply) by U'
* = 'C' or 'T': Multiply A on the left by U and the right
* by U' (Here, U' means U-transpose.)
*
* INIT (input) CHARACTER*1
* Specifies whether or not A should be initialized to the
* identity matrix.
* = 'I': Initialize A to (a section of) the identity matrix
* before applying U.
* = 'N': No initialization. Apply U to the input matrix A.
*
* INIT = 'I' may be used to generate square or rectangular
* orthogonal matrices:
*
* For M = N and SIDE = 'L' or 'R', the rows will be orthogonal
* to each other, as will the columns.
*
* If M < N, SIDE = 'R' produces a dense matrix whose rows are
* orthogonal and whose columns are not, while SIDE = 'L'
* produces a matrix whose rows are orthogonal, and whose first
* M columns are orthogonal, and whose remaining columns are
* zero.
*
* If M > N, SIDE = 'L' produces a dense matrix whose columns
* are orthogonal and whose rows are not, while SIDE = 'R'
* produces a matrix whose columns are orthogonal, and whose
* first M rows are orthogonal, and whose remaining rows are
* zero.
*
* M (input) INTEGER
* The number of rows of A.
*
* N (input) INTEGER
* The number of columns of A.
*
* A (input/output) REAL array, dimension (LDA, N)
* On entry, the array A.
* On exit, overwritten by U A ( if SIDE = 'L' ),
* or by A U ( if SIDE = 'R' ),
* or by U A U' ( if SIDE = 'C' or 'T').
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The array elements should be between 0 and 4095;
* if not they will be reduced mod 4096. Also, ISEED(4) must
* be odd. The random number generator uses a linear
* congruential sequence limited to small integers, and so
* should produce machine independent random numbers. The
* values of ISEED are changed on exit, and can be used in the
* next call to SLAROR to continue the same random number
* sequence.
*
* X (workspace) REAL array, dimension (3*MAX( M, N ))
* Workspace of length
* 2*M + N if SIDE = 'L',
* 2*N + M if SIDE = 'R',
* 3*N if SIDE = 'C' or 'T'.
*
* INFO (output) INTEGER
* An error flag. It is set to:
* = 0: normal return
* < 0: if INFO = -k, the k-th argument had an illegal value
* = 1: if the random numbers generated by SLARND are bad.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TOOSML
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0,
$ TOOSML = 1.0E-20 )
* ..
* .. Local Scalars ..
INTEGER IROW, ITYPE, IXFRM, J, JCOL, KBEG, NXFRM
REAL FACTOR, XNORM, XNORMS
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLARND, SNRM2
EXTERNAL LSAME, SLARND, SNRM2
* ..
* .. External Subroutines ..
EXTERNAL SGEMV, SGER, SLASET, SSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SIGN
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 .OR. M.EQ.0 )
$ RETURN
*
ITYPE = 0
IF( LSAME( SIDE, 'L' ) ) THEN
ITYPE = 1
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
ITYPE = 2
ELSE IF( LSAME( SIDE, 'C' ) .OR. LSAME( SIDE, 'T' ) ) THEN
ITYPE = 3
END IF
*
* Check for argument errors.
*
INFO = 0
IF( ITYPE.EQ.0 ) THEN
INFO = -1
ELSE IF( M.LT.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.3 .AND. N.NE.M ) ) THEN
INFO = -4
ELSE IF( LDA.LT.M ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLAROR', -INFO )
RETURN
END IF
*
IF( ITYPE.EQ.1 ) THEN
NXFRM = M
ELSE
NXFRM = N
END IF
*
* Initialize A to the identity matrix if desired
*
IF( LSAME( INIT, 'I' ) )
$ CALL SLASET( 'Full', M, N, ZERO, ONE, A, LDA )
*
* If no rotation possible, multiply by random +/-1
*
* Compute rotation by computing Householder transformations
* H(2), H(3), ..., H(nhouse)
*
DO 10 J = 1, NXFRM
X( J ) = ZERO
10 CONTINUE
*
DO 30 IXFRM = 2, NXFRM
KBEG = NXFRM - IXFRM + 1
*
* Generate independent normal( 0, 1 ) random numbers
*
DO 20 J = KBEG, NXFRM
X( J ) = SLARND( 3, ISEED )
20 CONTINUE
*
* Generate a Householder transformation from the random vector X
*
XNORM = SNRM2( IXFRM, X( KBEG ), 1 )
XNORMS = SIGN( XNORM, X( KBEG ) )
X( KBEG+NXFRM ) = SIGN( ONE, -X( KBEG ) )
FACTOR = XNORMS*( XNORMS+X( KBEG ) )
IF( ABS( FACTOR ).LT.TOOSML ) THEN
INFO = 1
CALL XERBLA( 'SLAROR', INFO )
RETURN
ELSE
FACTOR = ONE / FACTOR
END IF
X( KBEG ) = X( KBEG ) + XNORMS
*
* Apply Householder transformation to A
*
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.3 ) THEN
*
* Apply H(k) from the left.
*
CALL SGEMV( 'T', IXFRM, N, ONE, A( KBEG, 1 ), LDA,
$ X( KBEG ), 1, ZERO, X( 2*NXFRM+1 ), 1 )
CALL SGER( IXFRM, N, -FACTOR, X( KBEG ), 1, X( 2*NXFRM+1 ),
$ 1, A( KBEG, 1 ), LDA )
*
END IF
*
IF( ITYPE.EQ.2 .OR. ITYPE.EQ.3 ) THEN
*
* Apply H(k) from the right.
*
CALL SGEMV( 'N', M, IXFRM, ONE, A( 1, KBEG ), LDA,
$ X( KBEG ), 1, ZERO, X( 2*NXFRM+1 ), 1 )
CALL SGER( M, IXFRM, -FACTOR, X( 2*NXFRM+1 ), 1, X( KBEG ),
$ 1, A( 1, KBEG ), LDA )
*
END IF
30 CONTINUE
*
X( 2*NXFRM ) = SIGN( ONE, SLARND( 3, ISEED ) )
*
* Scale the matrix A by D.
*
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.3 ) THEN
DO 40 IROW = 1, M
CALL SSCAL( N, X( NXFRM+IROW ), A( IROW, 1 ), LDA )
40 CONTINUE
END IF
*
IF( ITYPE.EQ.2 .OR. ITYPE.EQ.3 ) THEN
DO 50 JCOL = 1, N
CALL SSCAL( M, X( NXFRM+JCOL ), A( 1, JCOL ), 1 )
50 CONTINUE
END IF
RETURN
*
* End of SLAROR
*
END
SUBROUTINE SLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT,
$ XRIGHT )
*
* -- LAPACK auxiliary test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL LLEFT, LRIGHT, LROWS
INTEGER LDA, NL
REAL C, S, XLEFT, XRIGHT
* ..
* .. Array Arguments ..
REAL A( * )
* ..
*
* Purpose
* =======
*
* SLAROT applies a (Givens) rotation to two adjacent rows or
* columns, where one element of the first and/or last column/row
* November 2006
* for use on matrices stored in some format other than GE, so
* that elements of the matrix may be used or modified for which
* no array element is provided.
*
* One example is a symmetric matrix in SB format (bandwidth=4), for
* which UPLO='L': Two adjacent rows will have the format:
*
* row j: * * * * * . . . .
* row j+1: * * * * * . . . .
*
* '*' indicates elements for which storage is provided,
* '.' indicates elements for which no storage is provided, but
* are not necessarily zero; their values are determined by
* symmetry. ' ' indicates elements which are necessarily zero,
* and have no storage provided.
*
* Those columns which have two '*'s can be handled by SROT.
* Those columns which have no '*'s can be ignored, since as long
* as the Givens rotations are carefully applied to preserve
* symmetry, their values are determined.
* Those columns which have one '*' have to be handled separately,
* by using separate variables "p" and "q":
*
* row j: * * * * * p . . .
* row j+1: q * * * * * . . . .
*
* The element p would have to be set correctly, then that column
* is rotated, setting p to its new value. The next call to
* SLAROT would rotate columns j and j+1, using p, and restore
* symmetry. The element q would start out being zero, and be
* made non-zero by the rotation. Later, rotations would presumably
* be chosen to zero q out.
*
* Typical Calling Sequences: rotating the i-th and (i+1)-st rows.
* ------- ------- ---------
*
* General dense matrix:
*
* CALL SLAROT(.TRUE.,.FALSE.,.FALSE., N, C,S,
* A(i,1),LDA, DUMMY, DUMMY)
*
* General banded matrix in GB format:
*
* j = MAX(1, i-KL )
* NL = MIN( N, i+KU+1 ) + 1-j
* CALL SLAROT( .TRUE., i-KL.GE.1, i+KU.LT.N, NL, C,S,
* A(KU+i+1-j,j),LDA-1, XLEFT, XRIGHT )
*
* [ note that i+1-j is just MIN(i,KL+1) ]
*
* Symmetric banded matrix in SY format, bandwidth K,
* lower triangle only:
*
* j = MAX(1, i-K )
* NL = MIN( K+1, i ) + 1
* CALL SLAROT( .TRUE., i-K.GE.1, .TRUE., NL, C,S,
* A(i,j), LDA, XLEFT, XRIGHT )
*
* Same, but upper triangle only:
*
* NL = MIN( K+1, N-i ) + 1
* CALL SLAROT( .TRUE., .TRUE., i+K.LT.N, NL, C,S,
* A(i,i), LDA, XLEFT, XRIGHT )
*
* Symmetric banded matrix in SB format, bandwidth K,
* lower triangle only:
*
* [ same as for SY, except:]
* . . . .
* A(i+1-j,j), LDA-1, XLEFT, XRIGHT )
*
* [ note that i+1-j is just MIN(i,K+1) ]
*
* Same, but upper triangle only:
* . . .
* A(K+1,i), LDA-1, XLEFT, XRIGHT )
*
* Rotating columns is just the transpose of rotating rows, except
* for GB and SB: (rotating columns i and i+1)
*
* GB:
* j = MAX(1, i-KU )
* NL = MIN( N, i+KL+1 ) + 1-j
* CALL SLAROT( .TRUE., i-KU.GE.1, i+KL.LT.N, NL, C,S,
* A(KU+j+1-i,i),LDA-1, XTOP, XBOTTM )
*
* [note that KU+j+1-i is just MAX(1,KU+2-i)]
*
* SB: (upper triangle)
*
* . . . . . .
* A(K+j+1-i,i),LDA-1, XTOP, XBOTTM )
*
* SB: (lower triangle)
*
* . . . . . .
* A(1,i),LDA-1, XTOP, XBOTTM )
*
* Arguments
* =========
*
* LROWS - LOGICAL
* If .TRUE., then SLAROT will rotate two rows. If .FALSE.,
* then it will rotate two columns.
* Not modified.
*
* LLEFT - LOGICAL
* If .TRUE., then XLEFT will be used instead of the
* corresponding element of A for the first element in the
* second row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.)
* If .FALSE., then the corresponding element of A will be
* used.
* Not modified.
*
* LRIGHT - LOGICAL
* If .TRUE., then XRIGHT will be used instead of the
* corresponding element of A for the last element in the
* first row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) If
* .FALSE., then the corresponding element of A will be used.
* Not modified.
*
* NL - INTEGER
* The length of the rows (if LROWS=.TRUE.) or columns (if
* LROWS=.FALSE.) to be rotated. If XLEFT and/or XRIGHT are
* used, the columns/rows they are in should be included in
* NL, e.g., if LLEFT = LRIGHT = .TRUE., then NL must be at
* least 2. The number of rows/columns to be rotated
* exclusive of those involving XLEFT and/or XRIGHT may
* not be negative, i.e., NL minus how many of LLEFT and
* LRIGHT are .TRUE. must be at least zero; if not, XERBLA
* will be called.
* Not modified.
*
* C, S - REAL
* Specify the Givens rotation to be applied. If LROWS is
* true, then the matrix ( c s )
* (-s c ) is applied from the left;
* if false, then the transpose thereof is applied from the
* right. For a Givens rotation, C**2 + S**2 should be 1,
* but this is not checked.
* Not modified.
*
* A - REAL array.
* The array containing the rows/columns to be rotated. The
* first element of A should be the upper left element to
* be rotated.
* Read and modified.
*
* LDA - INTEGER
* The "effective" leading dimension of A. If A contains
* a matrix stored in GE or SY format, then this is just
* the leading dimension of A as dimensioned in the calling
* routine. If A contains a matrix stored in band (GB or SB)
* format, then this should be *one less* than the leading
* dimension used in the calling routine. Thus, if
* A were dimensioned A(LDA,*) in SLAROT, then A(1,j) would
* be the j-th element in the first of the two rows
* to be rotated, and A(2,j) would be the j-th in the second,
* regardless of how the array may be stored in the calling
* routine. [A cannot, however, actually be dimensioned thus,
* since for band format, the row number may exceed LDA, which
* is not legal FORTRAN.]
* If LROWS=.TRUE., then LDA must be at least 1, otherwise
* it must be at least NL minus the number of .TRUE. values
* in XLEFT and XRIGHT.
* Not modified.
*
* XLEFT - REAL
* If LLEFT is .TRUE., then XLEFT will be used and modified
* instead of A(2,1) (if LROWS=.TRUE.) or A(1,2)
* (if LROWS=.FALSE.).
* Read and modified.
*
* XRIGHT - REAL
* If LRIGHT is .TRUE., then XRIGHT will be used and modified
* instead of A(1,NL) (if LROWS=.TRUE.) or A(NL,1)
* (if LROWS=.FALSE.).
* Read and modified.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER IINC, INEXT, IX, IY, IYT, NT
* ..
* .. Local Arrays ..
REAL XT( 2 ), YT( 2 )
* ..
* .. External Subroutines ..
EXTERNAL SROT, XERBLA
* ..
* .. Executable Statements ..
*
* Set up indices, arrays for ends
*
IF( LROWS ) THEN
IINC = LDA
INEXT = 1
ELSE
IINC = 1
INEXT = LDA
END IF
*
IF( LLEFT ) THEN
NT = 1
IX = 1 + IINC
IY = 2 + LDA
XT( 1 ) = A( 1 )
YT( 1 ) = XLEFT
ELSE
NT = 0
IX = 1
IY = 1 + INEXT
END IF
*
IF( LRIGHT ) THEN
IYT = 1 + INEXT + ( NL-1 )*IINC
NT = NT + 1
XT( NT ) = XRIGHT
YT( NT ) = A( IYT )
END IF
*
* Check for errors
*
IF( NL.LT.NT ) THEN
CALL XERBLA( 'SLAROT', 4 )
RETURN
END IF
IF( LDA.LE.0 .OR. ( .NOT.LROWS .AND. LDA.LT.NL-NT ) ) THEN
CALL XERBLA( 'SLAROT', 8 )
RETURN
END IF
*
* Rotate
*
CALL SROT( NL-NT, A( IX ), IINC, A( IY ), IINC, C, S )
CALL SROT( NT, XT, 1, YT, 1, C, S )
*
* Stuff values back into XLEFT, XRIGHT, etc.
*
IF( LLEFT ) THEN
A( 1 ) = XT( 1 )
XLEFT = YT( 1 )
END IF
*
IF( LRIGHT ) THEN
XRIGHT = XT( NT )
A( IYT ) = YT( NT )
END IF
*
RETURN
*
* End of SLAROT
*
END
SUBROUTINE SLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO )
*
* -- LAPACK auxiliary test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IDIST, INFO, IRSIGN, MODE, N
REAL COND
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
REAL D( * )
* ..
*
* Purpose
* =======
*
* SLATM1 computes the entries of D(1..N) as specified by
* MODE, COND and IRSIGN. IDIST and ISEED determine the generation
* of random numbers. SLATM1 is called by SLATMR to generate
* random test matrices for LAPACK programs.
*
* Arguments
* =========
*
* MODE - INTEGER
* On entry describes how D is to be computed:
* MODE = 0 means do not change D.
* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND
* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND
* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1))
* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
* MODE = 5 sets D to random numbers in the range
* ( 1/COND , 1 ) such that their logarithms
* are uniformly distributed.
* MODE = 6 set D to random numbers from same distribution
* as the rest of the matrix.
* MODE < 0 has the same meaning as ABS(MODE), except that
* the order of the elements of D is reversed.
* Thus if MODE is positive, D has entries ranging from
* 1 to 1/COND, if negative, from 1/COND to 1,
* Not modified.
*
* COND - REAL
* On entry, used as described under MODE above.
* If used, it must be >= 1. Not modified.
*
* IRSIGN - INTEGER
* On entry, if MODE neither -6, 0 nor 6, determines sign of
* entries of D
* 0 => leave entries of D unchanged
* 1 => multiply each entry of D by 1 or -1 with probability .5
*
* IDIST - CHARACTER*1
* On entry, IDIST specifies the type of distribution to be
* used to generate a random matrix .
* 1 => UNIFORM( 0, 1 )
* 2 => UNIFORM( -1, 1 )
* 3 => NORMAL( 0, 1 )
* Not modified.
*
* ISEED - INTEGER array, dimension ( 4 )
* On entry ISEED specifies the seed of the random number
* generator. The random number generator uses a
* linear congruential sequence limited to small
* integers, and so should produce machine independent
* random numbers. The values of ISEED are changed on
* exit, and can be used in the next call to SLATM1
* to continue the same random number sequence.
* Changed on exit.
*
* D - REAL array, dimension ( MIN( M , N ) )
* Array to be computed according to MODE, COND and IRSIGN.
* May be changed on exit if MODE is nonzero.
*
* N - INTEGER
* Number of entries of D. Not modified.
*
* INFO - INTEGER
* 0 => normal termination
* -1 => if MODE not in range -6 to 6
* -2 => if MODE neither -6, 0 nor 6, and
* IRSIGN neither 0 nor 1
* -3 => if MODE neither -6, 0 nor 6 and COND less than 1
* -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 3
* -7 => if N negative
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E0 )
REAL HALF
PARAMETER ( HALF = 0.5E0 )
* ..
* .. Local Scalars ..
INTEGER I
REAL ALPHA, TEMP
* ..
* .. External Functions ..
REAL SLARAN
EXTERNAL SLARAN
* ..
* .. External Subroutines ..
EXTERNAL SLARNV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, EXP, LOG, REAL
* ..
* .. Executable Statements ..
*
* Decode and Test the input parameters. Initialize flags & seed.
*
INFO = 0
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Set INFO if an error
*
IF( MODE.LT.-6 .OR. MODE.GT.6 ) THEN
INFO = -1
ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
$ ( IRSIGN.NE.0 .AND. IRSIGN.NE.1 ) ) THEN
INFO = -2
ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
$ COND.LT.ONE ) THEN
INFO = -3
ELSE IF( ( MODE.EQ.6 .OR. MODE.EQ.-6 ) .AND.
$ ( IDIST.LT.1 .OR. IDIST.GT.3 ) ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -7
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLATM1', -INFO )
RETURN
END IF
*
* Compute D according to COND and MODE
*
IF( MODE.NE.0 ) THEN
GO TO ( 10, 30, 50, 70, 90, 110 )ABS( MODE )
*
* One large D value:
*
10 CONTINUE
DO 20 I = 1, N
D( I ) = ONE / COND
20 CONTINUE
D( 1 ) = ONE
GO TO 120
*
* One small D value:
*
30 CONTINUE
DO 40 I = 1, N
D( I ) = ONE
40 CONTINUE
D( N ) = ONE / COND
GO TO 120
*
* Exponentially distributed D values:
*
50 CONTINUE
D( 1 ) = ONE
IF( N.GT.1 ) THEN
ALPHA = COND**( -ONE / REAL( N-1 ) )
DO 60 I = 2, N
D( I ) = ALPHA**( I-1 )
60 CONTINUE
END IF
GO TO 120
*
* Arithmetically distributed D values:
*
70 CONTINUE
D( 1 ) = ONE
IF( N.GT.1 ) THEN
TEMP = ONE / COND
ALPHA = ( ONE-TEMP ) / REAL( N-1 )
DO 80 I = 2, N
D( I ) = REAL( N-I )*ALPHA + TEMP
80 CONTINUE
END IF
GO TO 120
*
* Randomly distributed D values on ( 1/COND , 1):
*
90 CONTINUE
ALPHA = LOG( ONE / COND )
DO 100 I = 1, N
D( I ) = EXP( ALPHA*SLARAN( ISEED ) )
100 CONTINUE
GO TO 120
*
* Randomly distributed D values from IDIST
*
110 CONTINUE
CALL SLARNV( IDIST, ISEED, N, D )
*
120 CONTINUE
*
* If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign
* random signs to D
*
IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
$ IRSIGN.EQ.1 ) THEN
DO 130 I = 1, N
TEMP = SLARAN( ISEED )
IF( TEMP.GT.HALF )
$ D( I ) = -D( I )
130 CONTINUE
END IF
*
* Reverse if MODE < 0
*
IF( MODE.LT.0 ) THEN
DO 140 I = 1, N / 2
TEMP = D( I )
D( I ) = D( N+1-I )
D( N+1-I ) = TEMP
140 CONTINUE
END IF
*
END IF
*
RETURN
*
* End of SLATM1
*
END
REAL FUNCTION SLATM2( M, N, I, J, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE )
*
* -- LAPACK auxiliary test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
*
INTEGER I, IDIST, IGRADE, IPVTNG, J, KL, KU, M, N
REAL SPARSE
* ..
*
* .. Array Arguments ..
*
INTEGER ISEED( 4 ), IWORK( * )
REAL D( * ), DL( * ), DR( * )
* ..
*
* Purpose
* =======
*
* SLATM2 returns the (I,J) entry of a random matrix of dimension
* (M, N) described by the other paramters. It is called by the
* SLATMR routine in order to build random test matrices. No error
* checking on parameters is done, because this routine is called in
* a tight loop by SLATMR which has already checked the parameters.
*
* Use of SLATM2 differs from SLATM3 in the order in which the random
* number generator is called to fill in random matrix entries.
* With SLATM2, the generator is called to fill in the pivoted matrix
* columnwise. With SLATM3, the generator is called to fill in the
* matrix columnwise, after which it is pivoted. Thus, SLATM3 can
* be used to construct random matrices which differ only in their
* order of rows and/or columns. SLATM2 is used to construct band
* matrices while avoiding calling the random number generator for
* entries outside the band (and therefore generating random numbers
*
* The matrix whose (I,J) entry is returned is constructed as
* follows (this routine only computes one entry):
*
* If I is outside (1..M) or J is outside (1..N), return zero
* (this is convenient for generating matrices in band format).
*
* Generate a matrix A with random entries of distribution IDIST.
*
* Set the diagonal to D.
*
* Grade the matrix, if desired, from the left (by DL) and/or
* from the right (by DR or DL) as specified by IGRADE.
*
* Permute, if desired, the rows and/or columns as specified by
* IPVTNG and IWORK.
*
* Band the matrix to have lower bandwidth KL and upper
* bandwidth KU.
*
* Set random entries to zero as specified by SPARSE.
*
* Arguments
* =========
*
* M - INTEGER
* Number of rows of matrix. Not modified.
*
* N - INTEGER
* Number of columns of matrix. Not modified.
*
* I - INTEGER
* Row of entry to be returned. Not modified.
*
* J - INTEGER
* Column of entry to be returned. Not modified.
*
* KL - INTEGER
* Lower bandwidth. Not modified.
*
* KU - INTEGER
* Upper bandwidth. Not modified.
*
* IDIST - INTEGER
* On entry, IDIST specifies the type of distribution to be
* used to generate a random matrix .
* 1 => UNIFORM( 0, 1 )
* 2 => UNIFORM( -1, 1 )
* 3 => NORMAL( 0, 1 )
* Not modified.
*
* ISEED - INTEGER array of dimension ( 4 )
* Seed for random number generator.
* Changed on exit.
*
* D - REAL array of dimension ( MIN( I , J ) )
* Diagonal entries of matrix. Not modified.
*
* IGRADE - INTEGER
* Specifies grading of matrix as follows:
* 0 => no grading
* 1 => matrix premultiplied by diag( DL )
* 2 => matrix postmultiplied by diag( DR )
* 3 => matrix premultiplied by diag( DL ) and
* postmultiplied by diag( DR )
* 4 => matrix premultiplied by diag( DL ) and
* postmultiplied by inv( diag( DL ) )
* 5 => matrix premultiplied by diag( DL ) and
* postmultiplied by diag( DL )
* Not modified.
*
* DL - REAL array ( I or J, as appropriate )
* Left scale factors for grading matrix. Not modified.
*
* DR - REAL array ( I or J, as appropriate )
* Right scale factors for grading matrix. Not modified.
*
* IPVTNG - INTEGER
* On entry specifies pivoting permutations as follows:
* 0 => none.
* 1 => row pivoting.
* 2 => column pivoting.
* 3 => full pivoting, i.e., on both sides.
* Not modified.
*
* IWORK - INTEGER array ( I or J, as appropriate )
* This array specifies the permutation used. The
* row (or column) in position K was originally in
* position IWORK( K ).
* This differs from IWORK for SLATM3. Not modified.
*
* SPARSE - REAL between 0. and 1.
* On entry specifies the sparsity of the matrix
* if sparse matix is to be generated.
* SPARSE should lie between 0 and 1.
* A uniform ( 0, 1 ) random number x is generated and
* compared to SPARSE; if x is larger the matrix entry
* is unchanged and if x is smaller the entry is set
* to zero. Thus on the average a fraction SPARSE of the
* entries will be set to zero.
* Not modified.
*
* =====================================================================
*
* .. Parameters ..
*
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
* ..
*
* .. Local Scalars ..
*
INTEGER ISUB, JSUB
REAL TEMP
* ..
*
* .. External Functions ..
*
REAL SLARAN, SLARND
EXTERNAL SLARAN, SLARND
* ..
*
*-----------------------------------------------------------------------
*
* .. Executable Statements ..
*
*
* Check for I and J in range
*
IF( I.LT.1 .OR. I.GT.M .OR. J.LT.1 .OR. J.GT.N ) THEN
SLATM2 = ZERO
RETURN
END IF
*
* Check for banding
*
IF( J.GT.I+KU .OR. J.LT.I-KL ) THEN
SLATM2 = ZERO
RETURN
END IF
*
* Check for sparsity
*
IF( SPARSE.GT.ZERO ) THEN
IF( SLARAN( ISEED ).LT.SPARSE ) THEN
SLATM2 = ZERO
RETURN
END IF
END IF
*
* Compute subscripts depending on IPVTNG
*
IF( IPVTNG.EQ.0 ) THEN
ISUB = I
JSUB = J
ELSE IF( IPVTNG.EQ.1 ) THEN
ISUB = IWORK( I )
JSUB = J
ELSE IF( IPVTNG.EQ.2 ) THEN
ISUB = I
JSUB = IWORK( J )
ELSE IF( IPVTNG.EQ.3 ) THEN
ISUB = IWORK( I )
JSUB = IWORK( J )
END IF
*
* Compute entry and grade it according to IGRADE
*
IF( ISUB.EQ.JSUB ) THEN
TEMP = D( ISUB )
ELSE
TEMP = SLARND( IDIST, ISEED )
END IF
IF( IGRADE.EQ.1 ) THEN
TEMP = TEMP*DL( ISUB )
ELSE IF( IGRADE.EQ.2 ) THEN
TEMP = TEMP*DR( JSUB )
ELSE IF( IGRADE.EQ.3 ) THEN
TEMP = TEMP*DL( ISUB )*DR( JSUB )
ELSE IF( IGRADE.EQ.4 .AND. ISUB.NE.JSUB ) THEN
TEMP = TEMP*DL( ISUB ) / DL( JSUB )
ELSE IF( IGRADE.EQ.5 ) THEN
TEMP = TEMP*DL( ISUB )*DL( JSUB )
END IF
SLATM2 = TEMP
RETURN
*
* End of SLATM2
*
END
REAL FUNCTION SLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
$ SPARSE )
*
* -- LAPACK auxiliary test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
*
INTEGER I, IDIST, IGRADE, IPVTNG, ISUB, J, JSUB, KL,
$ KU, M, N
REAL SPARSE
* ..
*
* .. Array Arguments ..
*
INTEGER ISEED( 4 ), IWORK( * )
REAL D( * ), DL( * ), DR( * )
* ..
*
* Purpose
* =======
*
* SLATM3 returns the (ISUB,JSUB) entry of a random matrix of
* dimension (M, N) described by the other paramters. (ISUB,JSUB)
* is the final position of the (I,J) entry after pivoting
* according to IPVTNG and IWORK. SLATM3 is called by the
* SLATMR routine in order to build random test matrices. No error
* checking on parameters is done, because this routine is called in
* a tight loop by SLATMR which has already checked the parameters.
*
* Use of SLATM3 differs from SLATM2 in the order in which the random
* number generator is called to fill in random matrix entries.
* With SLATM2, the generator is called to fill in the pivoted matrix
* columnwise. With SLATM3, the generator is called to fill in the
* matrix columnwise, after which it is pivoted. Thus, SLATM3 can
* be used to construct random matrices which differ only in their
* order of rows and/or columns. SLATM2 is used to construct band
* matrices while avoiding calling the random number generator for
* entries outside the band (and therefore generating random numbers
* in different orders for different pivot orders).
*
* The matrix whose (ISUB,JSUB) entry is returned is constructed as
* follows (this routine only computes one entry):
*
* If ISUB is outside (1..M) or JSUB is outside (1..N), return zero
* (this is convenient for generating matrices in band format).
*
* Generate a matrix A with random entries of distribution IDIST.
*
* Set the diagonal to D.
*
* Grade the matrix, if desired, from the left (by DL) and/or
* from the right (by DR or DL) as specified by IGRADE.
*
* Permute, if desired, the rows and/or columns as specified by
* IPVTNG and IWORK.
*
* Band the matrix to have lower bandwidth KL and upper
* bandwidth KU.
*
* Set random entries to zero as specified by SPARSE.
*
* Arguments
* =========
*
* M - INTEGER
* Number of rows of matrix. Not modified.
*
* N - INTEGER
* Number of columns of matrix. Not modified.
*
* I - INTEGER
* Row of unpivoted entry to be returned. Not modified.
*
* J - INTEGER
* Column of unpivoted entry to be returned. Not modified.
*
* ISUB - INTEGER
* Row of pivoted entry to be returned. Changed on exit.
*
* JSUB - INTEGER
* Column of pivoted entry to be returned. Changed on exit.
*
* KL - INTEGER
* Lower bandwidth. Not modified.
*
* KU - INTEGER
* Upper bandwidth. Not modified.
*
* IDIST - INTEGER
* On entry, IDIST specifies the type of distribution to be
* used to generate a random matrix .
* 1 => UNIFORM( 0, 1 )
* 2 => UNIFORM( -1, 1 )
* 3 => NORMAL( 0, 1 )
* Not modified.
*
* ISEED - INTEGER array of dimension ( 4 )
* Seed for random number generator.
* Changed on exit.
*
* D - REAL array of dimension ( MIN( I , J ) )
* Diagonal entries of matrix. Not modified.
*
* IGRADE - INTEGER
* Specifies grading of matrix as follows:
* 0 => no grading
* 1 => matrix premultiplied by diag( DL )
* 2 => matrix postmultiplied by diag( DR )
* 3 => matrix premultiplied by diag( DL ) and
* postmultiplied by diag( DR )
* 4 => matrix premultiplied by diag( DL ) and
* postmultiplied by inv( diag( DL ) )
* 5 => matrix premultiplied by diag( DL ) and
* postmultiplied by diag( DL )
* Not modified.
*
* DL - REAL array ( I or J, as appropriate )
* Left scale factors for grading matrix. Not modified.
*
* DR - REAL array ( I or J, as appropriate )
* Right scale factors for grading matrix. Not modified.
*
* IPVTNG - INTEGER
* On entry specifies pivoting permutations as follows:
* 0 => none.
* 1 => row pivoting.
* 2 => column pivoting.
* 3 => full pivoting, i.e., on both sides.
* Not modified.
*
* IWORK - INTEGER array ( I or J, as appropriate )
* This array specifies the permutation used. The
* row (or column) originally in position K is in
* position IWORK( K ) after pivoting.
* This differs from IWORK for SLATM2. Not modified.
*
* SPARSE - REAL between 0. and 1.
* On entry specifies the sparsity of the matrix
* if sparse matix is to be generated.
* SPARSE should lie between 0 and 1.
* A uniform ( 0, 1 ) random number x is generated and
* compared to SPARSE; if x is larger the matrix entry
* is unchanged and if x is smaller the entry is set
* to zero. Thus on the average a fraction SPARSE of the
* entries will be set to zero.
* Not modified.
*
* =====================================================================
*
* .. Parameters ..
*
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
* ..
*
* .. Local Scalars ..
*
REAL TEMP
* ..
*
* .. External Functions ..
*
REAL SLARAN, SLARND
EXTERNAL SLARAN, SLARND
* ..
*
*-----------------------------------------------------------------------
*
* .. Executable Statements ..
*
*
* Check for I and J in range
*
IF( I.LT.1 .OR. I.GT.M .OR. J.LT.1 .OR. J.GT.N ) THEN
ISUB = I
JSUB = J
SLATM3 = ZERO
RETURN
END IF
*
* Compute subscripts depending on IPVTNG
*
IF( IPVTNG.EQ.0 ) THEN
ISUB = I
JSUB = J
ELSE IF( IPVTNG.EQ.1 ) THEN
ISUB = IWORK( I )
JSUB = J
ELSE IF( IPVTNG.EQ.2 ) THEN
ISUB = I
JSUB = IWORK( J )
ELSE IF( IPVTNG.EQ.3 ) THEN
ISUB = IWORK( I )
JSUB = IWORK( J )
END IF
*
* Check for banding
*
IF( JSUB.GT.ISUB+KU .OR. JSUB.LT.ISUB-KL ) THEN
SLATM3 = ZERO
RETURN
END IF
*
* Check for sparsity
*
IF( SPARSE.GT.ZERO ) THEN
IF( SLARAN( ISEED ).LT.SPARSE ) THEN
SLATM3 = ZERO
RETURN
END IF
END IF
*
* Compute entry and grade it according to IGRADE
*
IF( I.EQ.J ) THEN
TEMP = D( I )
ELSE
TEMP = SLARND( IDIST, ISEED )
END IF
IF( IGRADE.EQ.1 ) THEN
TEMP = TEMP*DL( I )
ELSE IF( IGRADE.EQ.2 ) THEN
TEMP = TEMP*DR( J )
ELSE IF( IGRADE.EQ.3 ) THEN
TEMP = TEMP*DL( I )*DR( J )
ELSE IF( IGRADE.EQ.4 .AND. I.NE.J ) THEN
TEMP = TEMP*DL( I ) / DL( J )
ELSE IF( IGRADE.EQ.5 ) THEN
TEMP = TEMP*DL( I )*DL( J )
END IF
SLATM3 = TEMP
RETURN
*
* End of SLATM3
*
END
SUBROUTINE SLATM5( PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD,
$ E, LDE, F, LDF, R, LDR, L, LDL, ALPHA, QBLCKA,
$ QBLCKB )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDB, LDC, LDD, LDE, LDF, LDL, LDR, M, N,
$ PRTYPE, QBLCKA, QBLCKB
REAL ALPHA
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDB, * ), C( LDC, * ),
$ D( LDD, * ), E( LDE, * ), F( LDF, * ),
$ L( LDL, * ), R( LDR, * )
* ..
*
* Purpose
* =======
*
* SLATM5 generates matrices involved in the Generalized Sylvester
* equation:
*
* A * R - L * B = C
* D * R - L * E = F
*
* They also satisfy (the diagonalization condition)
*
* [ I -L ] ( [ A -C ], [ D -F ] ) [ I R ] = ( [ A ], [ D ] )
* [ I ] ( [ B ] [ E ] ) [ I ] ( [ B ] [ E ] )
*
*
* Arguments
* =========
*
* PRTYPE (input) INTEGER
* "Points" to a certian type of the matrices to generate
* (see futher details).
*
* M (input) INTEGER
* Specifies the order of A and D and the number of rows in
* C, F, R and L.
*
* N (input) INTEGER
* Specifies the order of B and E and the number of columns in
* C, F, R and L.
*
* A (output) REAL array, dimension (LDA, M).
* On exit A M-by-M is initialized according to PRTYPE.
*
* LDA (input) INTEGER
* The leading dimension of A.
*
* B (output) REAL array, dimension (LDB, N).
* On exit B N-by-N is initialized according to PRTYPE.
*
* LDB (input) INTEGER
* The leading dimension of B.
*
* C (output) REAL array, dimension (LDC, N).
* On exit C M-by-N is initialized according to PRTYPE.
*
* LDC (input) INTEGER
* The leading dimension of C.
*
* D (output) REAL array, dimension (LDD, M).
* On exit D M-by-M is initialized according to PRTYPE.
*
* LDD (input) INTEGER
* The leading dimension of D.
*
* E (output) REAL array, dimension (LDE, N).
* On exit E N-by-N is initialized according to PRTYPE.
*
* LDE (input) INTEGER
* The leading dimension of E.
*
* F (output) REAL array, dimension (LDF, N).
* On exit F M-by-N is initialized according to PRTYPE.
*
* LDF (input) INTEGER
* The leading dimension of F.
*
* R (output) REAL array, dimension (LDR, N).
* On exit R M-by-N is initialized according to PRTYPE.
*
* LDR (input) INTEGER
* The leading dimension of R.
*
* L (output) REAL array, dimension (LDL, N).
* On exit L M-by-N is initialized according to PRTYPE.
*
* LDL (input) INTEGER
* The leading dimension of L.
*
* ALPHA (input) REAL
* Parameter used in generating PRTYPE = 1 and 5 matrices.
*
* QBLCKA (input) INTEGER
* When PRTYPE = 3, specifies the distance between 2-by-2
* blocks on the diagonal in A. Otherwise, QBLCKA is not
* referenced. QBLCKA > 1.
*
* QBLCKB (input) INTEGER
* When PRTYPE = 3, specifies the distance between 2-by-2
* blocks on the diagonal in B. Otherwise, QBLCKB is not
* referenced. QBLCKB > 1.
*
*
* Further Details
* ===============
*
* PRTYPE = 1: A and B are Jordan blocks, D and E are identity matrices
*
* A : if (i == j) then A(i, j) = 1.0
* if (j == i + 1) then A(i, j) = -1.0
* else A(i, j) = 0.0, i, j = 1...M
*
* B : if (i == j) then B(i, j) = 1.0 - ALPHA
* if (j == i + 1) then B(i, j) = 1.0
* else B(i, j) = 0.0, i, j = 1...N
*
* D : if (i == j) then D(i, j) = 1.0
* else D(i, j) = 0.0, i, j = 1...M
*
* E : if (i == j) then E(i, j) = 1.0
* else E(i, j) = 0.0, i, j = 1...N
*
* L = R are chosen from [-10...10],
* which specifies the right hand sides (C, F).
*
* PRTYPE = 2 or 3: Triangular and/or quasi- triangular.
*
* A : if (i <= j) then A(i, j) = [-1...1]
* else A(i, j) = 0.0, i, j = 1...M
*
* if (PRTYPE = 3) then
* A(k + 1, k + 1) = A(k, k)
* A(k + 1, k) = [-1...1]
* sign(A(k, k + 1) = -(sin(A(k + 1, k))
* k = 1, M - 1, QBLCKA
*
* B : if (i <= j) then B(i, j) = [-1...1]
* else B(i, j) = 0.0, i, j = 1...N
*
* if (PRTYPE = 3) then
* B(k + 1, k + 1) = B(k, k)
* B(k + 1, k) = [-1...1]
* sign(B(k, k + 1) = -(sign(B(k + 1, k))
* k = 1, N - 1, QBLCKB
*
* D : if (i <= j) then D(i, j) = [-1...1].
* else D(i, j) = 0.0, i, j = 1...M
*
*
* E : if (i <= j) then D(i, j) = [-1...1]
* else E(i, j) = 0.0, i, j = 1...N
*
* L, R are chosen from [-10...10],
* which specifies the right hand sides (C, F).
*
* PRTYPE = 4 Full
* A(i, j) = [-10...10]
* D(i, j) = [-1...1] i,j = 1...M
* B(i, j) = [-10...10]
* E(i, j) = [-1...1] i,j = 1...N
* R(i, j) = [-10...10]
* L(i, j) = [-1...1] i = 1..M ,j = 1...N
*
* L, R specifies the right hand sides (C, F).
*
* PRTYPE = 5 special case common and/or close eigs.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO, TWENTY, HALF, TWO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0, TWENTY = 2.0E+1,
$ HALF = 0.5E+0, TWO = 2.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, K
REAL IMEPS, REEPS
* ..
* .. Intrinsic Functions ..
INTRINSIC MOD, REAL, SIN
* ..
* .. External Subroutines ..
EXTERNAL SGEMM
* ..
* .. Executable Statements ..
*
IF( PRTYPE.EQ.1 ) THEN
DO 20 I = 1, M
DO 10 J = 1, M
IF( I.EQ.J ) THEN
A( I, J ) = ONE
D( I, J ) = ONE
ELSE IF( I.EQ.J-1 ) THEN
A( I, J ) = -ONE
D( I, J ) = ZERO
ELSE
A( I, J ) = ZERO
D( I, J ) = ZERO
END IF
10 CONTINUE
20 CONTINUE
*
DO 40 I = 1, N
DO 30 J = 1, N
IF( I.EQ.J ) THEN
B( I, J ) = ONE - ALPHA
E( I, J ) = ONE
ELSE IF( I.EQ.J-1 ) THEN
B( I, J ) = ONE
E( I, J ) = ZERO
ELSE
B( I, J ) = ZERO
E( I, J ) = ZERO
END IF
30 CONTINUE
40 CONTINUE
*
DO 60 I = 1, M
DO 50 J = 1, N
R( I, J ) = ( HALF-SIN( REAL( I / J ) ) )*TWENTY
L( I, J ) = R( I, J )
50 CONTINUE
60 CONTINUE
*
ELSE IF( PRTYPE.EQ.2 .OR. PRTYPE.EQ.3 ) THEN
DO 80 I = 1, M
DO 70 J = 1, M
IF( I.LE.J ) THEN
A( I, J ) = ( HALF-SIN( REAL( I ) ) )*TWO
D( I, J ) = ( HALF-SIN( REAL( I*J ) ) )*TWO
ELSE
A( I, J ) = ZERO
D( I, J ) = ZERO
END IF
70 CONTINUE
80 CONTINUE
*
DO 100 I = 1, N
DO 90 J = 1, N
IF( I.LE.J ) THEN
B( I, J ) = ( HALF-SIN( REAL( I+J ) ) )*TWO
E( I, J ) = ( HALF-SIN( REAL( J ) ) )*TWO
ELSE
B( I, J ) = ZERO
E( I, J ) = ZERO
END IF
90 CONTINUE
100 CONTINUE
*
DO 120 I = 1, M
DO 110 J = 1, N
R( I, J ) = ( HALF-SIN( REAL( I*J ) ) )*TWENTY
L( I, J ) = ( HALF-SIN( REAL( I+J ) ) )*TWENTY
110 CONTINUE
120 CONTINUE
*
IF( PRTYPE.EQ.3 ) THEN
IF( QBLCKA.LE.1 )
$ QBLCKA = 2
DO 130 K = 1, M - 1, QBLCKA
A( K+1, K+1 ) = A( K, K )
A( K+1, K ) = -SIN( A( K, K+1 ) )
130 CONTINUE
*
IF( QBLCKB.LE.1 )
$ QBLCKB = 2
DO 140 K = 1, N - 1, QBLCKB
B( K+1, K+1 ) = B( K, K )
B( K+1, K ) = -SIN( B( K, K+1 ) )
140 CONTINUE
END IF
*
ELSE IF( PRTYPE.EQ.4 ) THEN
DO 160 I = 1, M
DO 150 J = 1, M
A( I, J ) = ( HALF-SIN( REAL( I*J ) ) )*TWENTY
D( I, J ) = ( HALF-SIN( REAL( I+J ) ) )*TWO
150 CONTINUE
160 CONTINUE
*
DO 180 I = 1, N
DO 170 J = 1, N
B( I, J ) = ( HALF-SIN( REAL( I+J ) ) )*TWENTY
E( I, J ) = ( HALF-SIN( REAL( I*J ) ) )*TWO
170 CONTINUE
180 CONTINUE
*
DO 200 I = 1, M
DO 190 J = 1, N
R( I, J ) = ( HALF-SIN( REAL( J / I ) ) )*TWENTY
L( I, J ) = ( HALF-SIN( REAL( I*J ) ) )*TWO
190 CONTINUE
200 CONTINUE
*
ELSE IF( PRTYPE.GE.5 ) THEN
REEPS = HALF*TWO*TWENTY / ALPHA
IMEPS = ( HALF-TWO ) / ALPHA
DO 220 I = 1, M
DO 210 J = 1, N
R( I, J ) = ( HALF-SIN( REAL( I*J ) ) )*ALPHA / TWENTY
L( I, J ) = ( HALF-SIN( REAL( I+J ) ) )*ALPHA / TWENTY
210 CONTINUE
220 CONTINUE
*
DO 230 I = 1, M
D( I, I ) = ONE
230 CONTINUE
*
DO 240 I = 1, M
IF( I.LE.4 ) THEN
A( I, I ) = ONE
IF( I.GT.2 )
$ A( I, I ) = ONE + REEPS
IF( MOD( I, 2 ).NE.0 .AND. I.LT.M ) THEN
A( I, I+1 ) = IMEPS
ELSE IF( I.GT.1 ) THEN
A( I, I-1 ) = -IMEPS
END IF
ELSE IF( I.LE.8 ) THEN
IF( I.LE.6 ) THEN
A( I, I ) = REEPS
ELSE
A( I, I ) = -REEPS
END IF
IF( MOD( I, 2 ).NE.0 .AND. I.LT.M ) THEN
A( I, I+1 ) = ONE
ELSE IF( I.GT.1 ) THEN
A( I, I-1 ) = -ONE
END IF
ELSE
A( I, I ) = ONE
IF( MOD( I, 2 ).NE.0 .AND. I.LT.M ) THEN
A( I, I+1 ) = IMEPS*2
ELSE IF( I.GT.1 ) THEN
A( I, I-1 ) = -IMEPS*2
END IF
END IF
240 CONTINUE
*
DO 250 I = 1, N
E( I, I ) = ONE
IF( I.LE.4 ) THEN
B( I, I ) = -ONE
IF( I.GT.2 )
$ B( I, I ) = ONE - REEPS
IF( MOD( I, 2 ).NE.0 .AND. I.LT.N ) THEN
B( I, I+1 ) = IMEPS
ELSE IF( I.GT.1 ) THEN
B( I, I-1 ) = -IMEPS
END IF
ELSE IF( I.LE.8 ) THEN
IF( I.LE.6 ) THEN
B( I, I ) = REEPS
ELSE
B( I, I ) = -REEPS
END IF
IF( MOD( I, 2 ).NE.0 .AND. I.LT.N ) THEN
B( I, I+1 ) = ONE + IMEPS
ELSE IF( I.GT.1 ) THEN
B( I, I-1 ) = -ONE - IMEPS
END IF
ELSE
B( I, I ) = ONE - REEPS
IF( MOD( I, 2 ).NE.0 .AND. I.LT.N ) THEN
B( I, I+1 ) = IMEPS*2
ELSE IF( I.GT.1 ) THEN
B( I, I-1 ) = -IMEPS*2
END IF
END IF
250 CONTINUE
END IF
*
* Compute rhs (C, F)
*
CALL SGEMM( 'N', 'N', M, N, M, ONE, A, LDA, R, LDR, ZERO, C, LDC )
CALL SGEMM( 'N', 'N', M, N, N, -ONE, L, LDL, B, LDB, ONE, C, LDC )
CALL SGEMM( 'N', 'N', M, N, M, ONE, D, LDD, R, LDR, ZERO, F, LDF )
CALL SGEMM( 'N', 'N', M, N, N, -ONE, L, LDL, E, LDE, ONE, F, LDF )
*
* End of SLATM5
*
END
SUBROUTINE SLATM6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA,
$ BETA, WX, WY, S, DIF )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDX, LDY, N, TYPE
REAL ALPHA, BETA, WX, WY
* ..
* .. Array Arguments ..
REAL A( LDA, * ), B( LDA, * ), DIF( * ), S( * ),
$ X( LDX, * ), Y( LDY, * )
* ..
*
* Purpose
* =======
*
* SLATM6 generates test matrices for the generalized eigenvalue
* problem, their corresponding right and left eigenvector matrices,
* and also reciprocal condition numbers for all eigenvalues and
* the reciprocal condition numbers of eigenvectors corresponding to
* the 1th and 5th eigenvalues.
*
* Test Matrices
* =============
*
* Two kinds of test matrix pairs
*
* (A, B) = inverse(YH) * (Da, Db) * inverse(X)
*
* are used in the tests:
*
* Type 1:
* Da = 1+a 0 0 0 0 Db = 1 0 0 0 0
* 0 2+a 0 0 0 0 1 0 0 0
* 0 0 3+a 0 0 0 0 1 0 0
* 0 0 0 4+a 0 0 0 0 1 0
* 0 0 0 0 5+a , 0 0 0 0 1 , and
*
* Type 2:
* Da = 1 -1 0 0 0 Db = 1 0 0 0 0
* 1 1 0 0 0 0 1 0 0 0
* 0 0 1 0 0 0 0 1 0 0
* 0 0 0 1+a 1+b 0 0 0 1 0
* 0 0 0 -1-b 1+a , 0 0 0 0 1 .
*
* In both cases the same inverse(YH) and inverse(X) are used to compute
* (A, B), giving the exact eigenvectors to (A,B) as (YH, X):
*
* YH: = 1 0 -y y -y X = 1 0 -x -x x
* 0 1 -y y -y 0 1 x -x -x
* 0 0 1 0 0 0 0 1 0 0
* 0 0 0 1 0 0 0 0 1 0
* 0 0 0 0 1, 0 0 0 0 1 ,
*
* where a, b, x and y will have all values independently of each other.
*
* Arguments
* =========
*
* TYPE (input) INTEGER
* Specifies the problem type (see futher details).
*
* N (input) INTEGER
* Size of the matrices A and B.
*
* A (output) REAL array, dimension (LDA, N).
* On exit A N-by-N is initialized according to TYPE.
*
* LDA (input) INTEGER
* The leading dimension of A and of B.
*
* B (output) REAL array, dimension (LDA, N).
* On exit B N-by-N is initialized according to TYPE.
*
* X (output) REAL array, dimension (LDX, N).
* On exit X is the N-by-N matrix of right eigenvectors.
*
* LDX (input) INTEGER
* The leading dimension of X.
*
* Y (output) REAL array, dimension (LDY, N).
* On exit Y is the N-by-N matrix of left eigenvectors.
*
* LDY (input) INTEGER
* The leading dimension of Y.
*
* ALPHA (input) REAL
* BETA (input) REAL
* Weighting constants for matrix A.
*
* WX (input) REAL
* Constant for right eigenvector matrix.
*
* WY (input) REAL
* Constant for left eigenvector matrix.
*
* S (output) REAL array, dimension (N)
* S(i) is the reciprocal condition number for eigenvalue i.
*
* DIF (output) REAL array, dimension (N)
* DIF(i) is the reciprocal condition number for eigenvector i.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO, THREE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0,
$ THREE = 3.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
* ..
* .. Local Arrays ..
REAL WORK( 100 ), Z( 12, 12 )
* ..
* .. Intrinsic Functions ..
INTRINSIC REAL, SQRT
* ..
* .. External Subroutines ..
EXTERNAL SGESVD, SLACPY, SLAKF2
* ..
* .. Executable Statements ..
*
* Generate test problem ...
* (Da, Db) ...
*
DO 20 I = 1, N
DO 10 J = 1, N
*
IF( I.EQ.J ) THEN
A( I, I ) = REAL( I ) + ALPHA
B( I, I ) = ONE
ELSE
A( I, J ) = ZERO
B( I, J ) = ZERO
END IF
*
10 CONTINUE
20 CONTINUE
*
* Form X and Y
*
CALL SLACPY( 'F', N, N, B, LDA, Y, LDY )
Y( 3, 1 ) = -WY
Y( 4, 1 ) = WY
Y( 5, 1 ) = -WY
Y( 3, 2 ) = -WY
Y( 4, 2 ) = WY
Y( 5, 2 ) = -WY
*
CALL SLACPY( 'F', N, N, B, LDA, X, LDX )
X( 1, 3 ) = -WX
X( 1, 4 ) = -WX
X( 1, 5 ) = WX
X( 2, 3 ) = WX
X( 2, 4 ) = -WX
X( 2, 5 ) = -WX
*
* Form (A, B)
*
B( 1, 3 ) = WX + WY
B( 2, 3 ) = -WX + WY
B( 1, 4 ) = WX - WY
B( 2, 4 ) = WX - WY
B( 1, 5 ) = -WX + WY
B( 2, 5 ) = WX + WY
IF( TYPE.EQ.1 ) THEN
A( 1, 3 ) = WX*A( 1, 1 ) + WY*A( 3, 3 )
A( 2, 3 ) = -WX*A( 2, 2 ) + WY*A( 3, 3 )
A( 1, 4 ) = WX*A( 1, 1 ) - WY*A( 4, 4 )
A( 2, 4 ) = WX*A( 2, 2 ) - WY*A( 4, 4 )
A( 1, 5 ) = -WX*A( 1, 1 ) + WY*A( 5, 5 )
A( 2, 5 ) = WX*A( 2, 2 ) + WY*A( 5, 5 )
ELSE IF( TYPE.EQ.2 ) THEN
A( 1, 3 ) = TWO*WX + WY
A( 2, 3 ) = WY
A( 1, 4 ) = -WY*( TWO+ALPHA+BETA )
A( 2, 4 ) = TWO*WX - WY*( TWO+ALPHA+BETA )
A( 1, 5 ) = -TWO*WX + WY*( ALPHA-BETA )
A( 2, 5 ) = WY*( ALPHA-BETA )
A( 1, 1 ) = ONE
A( 1, 2 ) = -ONE
A( 2, 1 ) = ONE
A( 2, 2 ) = A( 1, 1 )
A( 3, 3 ) = ONE
A( 4, 4 ) = ONE + ALPHA
A( 4, 5 ) = ONE + BETA
A( 5, 4 ) = -A( 4, 5 )
A( 5, 5 ) = A( 4, 4 )
END IF
*
* Compute condition numbers
*
IF( TYPE.EQ.1 ) THEN
*
S( 1 ) = ONE / SQRT( ( ONE+THREE*WY*WY ) /
$ ( ONE+A( 1, 1 )*A( 1, 1 ) ) )
S( 2 ) = ONE / SQRT( ( ONE+THREE*WY*WY ) /
$ ( ONE+A( 2, 2 )*A( 2, 2 ) ) )
S( 3 ) = ONE / SQRT( ( ONE+TWO*WX*WX ) /
$ ( ONE+A( 3, 3 )*A( 3, 3 ) ) )
S( 4 ) = ONE / SQRT( ( ONE+TWO*WX*WX ) /
$ ( ONE+A( 4, 4 )*A( 4, 4 ) ) )
S( 5 ) = ONE / SQRT( ( ONE+TWO*WX*WX ) /
$ ( ONE+A( 5, 5 )*A( 5, 5 ) ) )
*
CALL SLAKF2( 1, 4, A, LDA, A( 2, 2 ), B, B( 2, 2 ), Z, 12 )
CALL SGESVD( 'N', 'N', 8, 8, Z, 12, WORK, WORK( 9 ), 1,
$ WORK( 10 ), 1, WORK( 11 ), 40, INFO )
DIF( 1 ) = WORK( 8 )
*
CALL SLAKF2( 4, 1, A, LDA, A( 5, 5 ), B, B( 5, 5 ), Z, 12 )
CALL SGESVD( 'N', 'N', 8, 8, Z, 12, WORK, WORK( 9 ), 1,
$ WORK( 10 ), 1, WORK( 11 ), 40, INFO )
DIF( 5 ) = WORK( 8 )
*
ELSE IF( TYPE.EQ.2 ) THEN
*
S( 1 ) = ONE / SQRT( ONE / THREE+WY*WY )
S( 2 ) = S( 1 )
S( 3 ) = ONE / SQRT( ONE / TWO+WX*WX )
S( 4 ) = ONE / SQRT( ( ONE+TWO*WX*WX ) /
$ ( ONE+( ONE+ALPHA )*( ONE+ALPHA )+( ONE+BETA )*( ONE+
$ BETA ) ) )
S( 5 ) = S( 4 )
*
CALL SLAKF2( 2, 3, A, LDA, A( 3, 3 ), B, B( 3, 3 ), Z, 12 )
CALL SGESVD( 'N', 'N', 12, 12, Z, 12, WORK, WORK( 13 ), 1,
$ WORK( 14 ), 1, WORK( 15 ), 60, INFO )
DIF( 1 ) = WORK( 12 )
*
CALL SLAKF2( 3, 2, A, LDA, A( 4, 4 ), B, B( 4, 4 ), Z, 12 )
CALL SGESVD( 'N', 'N', 12, 12, Z, 12, WORK, WORK( 13 ), 1,
$ WORK( 14 ), 1, WORK( 15 ), 60, INFO )
DIF( 5 ) = WORK( 12 )
*
END IF
*
RETURN
*
* End of SLATM6
*
END
SUBROUTINE SLATME( N, DIST, ISEED, D, MODE, COND, DMAX, EI, RSIGN,
$ UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, A,
$ LDA, WORK, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIST, RSIGN, SIM, UPPER
INTEGER INFO, KL, KU, LDA, MODE, MODES, N
REAL ANORM, COND, CONDS, DMAX
* ..
* .. Array Arguments ..
CHARACTER EI( * )
INTEGER ISEED( 4 )
REAL A( LDA, * ), D( * ), DS( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SLATME generates random non-symmetric square matrices with
* specified eigenvalues for testing LAPACK programs.
*
* SLATME operates by applying the following sequence of
* operations:
*
* 1. Set the diagonal to D, where D may be input or
* computed according to MODE, COND, DMAX, and RSIGN
* as described below.
*
* 2. If complex conjugate pairs are desired (MODE=0 and EI(1)='R',
* or MODE=5), certain pairs of adjacent elements of D are
* interpreted as the real and complex parts of a complex
* conjugate pair; A thus becomes block diagonal, with 1x1
* and 2x2 blocks.
*
* 3. If UPPER='T', the upper triangle of A is set to random values
* out of distribution DIST.
*
* 4. If SIM='T', A is multiplied on the left by a random matrix
* X, whose singular values are specified by DS, MODES, and
* CONDS, and on the right by X inverse.
*
* 5. If KL < N-1, the lower bandwidth is reduced to KL using
* Householder transformations. If KU < N-1, the upper
* bandwidth is reduced to KU.
*
* 6. If ANORM is not negative, the matrix is scaled to have
* maximum-element-norm ANORM.
*
* (Note: since the matrix cannot be reduced beyond Hessenberg form,
* no packing options are available.)
*
* Arguments
* =========
*
* N - INTEGER
* The number of columns (or rows) of A. Not modified.
*
* DIST - CHARACTER*1
* On entry, DIST specifies the type of distribution to be used
* to generate the random eigen-/singular values, and for the
* upper triangle (see UPPER).
* 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform )
* 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric )
* 'N' => NORMAL( 0, 1 ) ( 'N' for normal )
* Not modified.
*
* ISEED - INTEGER array, dimension ( 4 )
* On entry ISEED specifies the seed of the random number
* generator. They should lie between 0 and 4095 inclusive,
* and ISEED(4) should be odd. The random number generator
* uses a linear congruential sequence limited to small
* integers, and so should produce machine independent
* random numbers. The values of ISEED are changed on
* exit, and can be used in the next call to SLATME
* to continue the same random number sequence.
* Changed on exit.
*
* D - REAL array, dimension ( N )
* This array is used to specify the eigenvalues of A. If
* MODE=0, then D is assumed to contain the eigenvalues (but
* see the description of EI), otherwise they will be
* computed according to MODE, COND, DMAX, and RSIGN and
* placed in D.
* Modified if MODE is nonzero.
*
* MODE - INTEGER
* On entry this describes how the eigenvalues are to
* be specified:
* MODE = 0 means use D (with EI) as input
* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND
* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND
* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1))
* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
* MODE = 5 sets D to random numbers in the range
* ( 1/COND , 1 ) such that their logarithms
* are uniformly distributed. Each odd-even pair
* of elements will be either used as two real
* eigenvalues or as the real and imaginary part
* of a complex conjugate pair of eigenvalues;
* the choice of which is done is random, with
* 50-50 probability, for each pair.
* MODE = 6 set D to random numbers from same distribution
* as the rest of the matrix.
* MODE < 0 has the same meaning as ABS(MODE), except that
* the order of the elements of D is reversed.
* Thus if MODE is between 1 and 4, D has entries ranging
* from 1 to 1/COND, if between -1 and -4, D has entries
* ranging from 1/COND to 1,
* Not modified.
*
* COND - REAL
* On entry, this is used as described under MODE above.
* If used, it must be >= 1. Not modified.
*
* DMAX - REAL
* If MODE is neither -6, 0 nor 6, the contents of D, as
* computed according to MODE and COND, will be scaled by
* DMAX / max(abs(D(i))). Note that DMAX need not be
* positive: if DMAX is negative (or zero), D will be
* scaled by a negative number (or zero).
* Not modified.
*
* EI - CHARACTER*1 array, dimension ( N )
* If MODE is 0, and EI(1) is not ' ' (space character),
* this array specifies which elements of D (on input) are
* real eigenvalues and which are the real and imaginary parts
* of a complex conjugate pair of eigenvalues. The elements
* of EI may then only have the values 'R' and 'I'. If
* EI(j)='R' and EI(j+1)='I', then the j-th eigenvalue is
* CMPLX( D(j) , D(j+1) ), and the (j+1)-th is the complex
* conjugate thereof. If EI(j)=EI(j+1)='R', then the j-th
* eigenvalue is D(j) (i.e., real). EI(1) may not be 'I',
* nor may two adjacent elements of EI both have the value 'I'.
* If MODE is not 0, then EI is ignored. If MODE is 0 and
* EI(1)=' ', then the eigenvalues will all be real.
* Not modified.
*
* RSIGN - CHARACTER*1
* If MODE is not 0, 6, or -6, and RSIGN='T', then the
* elements of D, as computed according to MODE and COND, will
* be multiplied by a random sign (+1 or -1). If RSIGN='F',
* they will not be. RSIGN may only have the values 'T' or
* 'F'.
* Not modified.
*
* UPPER - CHARACTER*1
* If UPPER='T', then the elements of A above the diagonal
* (and above the 2x2 diagonal blocks, if A has complex
* eigenvalues) will be set to random numbers out of DIST.
* If UPPER='F', they will not. UPPER may only have the
* values 'T' or 'F'.
* Not modified.
*
* SIM - CHARACTER*1
* If SIM='T', then A will be operated on by a "similarity
* transform", i.e., multiplied on the left by a matrix X and
* on the right by X inverse. X = U S V, where U and V are
* random unitary matrices and S is a (diagonal) matrix of
* singular values specified by DS, MODES, and CONDS. If
* SIM='F', then A will not be transformed.
* Not modified.
*
* DS - REAL array, dimension ( N )
* This array is used to specify the singular values of X,
* in the same way that D specifies the eigenvalues of A.
* If MODE=0, the DS contains the singular values, which
* may not be zero.
* Modified if MODE is nonzero.
*
* MODES - INTEGER
* CONDS - REAL
* Same as MODE and COND, but for specifying the diagonal
* of S. MODES=-6 and +6 are not allowed (since they would
* result in randomly ill-conditioned eigenvalues.)
*
* KL - INTEGER
* This specifies the lower bandwidth of the matrix. KL=1
* specifies upper Hessenberg form. If KL is at least N-1,
* then A will have full lower bandwidth. KL must be at
* least 1.
* Not modified.
*
* KU - INTEGER
* This specifies the upper bandwidth of the matrix. KU=1
* specifies lower Hessenberg form. If KU is at least N-1,
* then A will have full upper bandwidth; if KU and KL
* are both at least N-1, then A will be dense. Only one of
* KU and KL may be less than N-1. KU must be at least 1.
* Not modified.
*
* ANORM - REAL
* If ANORM is not negative, then A will be scaled by a non-
* negative real number to make the maximum-element-norm of A
* to be ANORM.
* Not modified.
*
* A - REAL array, dimension ( LDA, N )
* On exit A is the desired test matrix.
* Modified.
*
* LDA - INTEGER
* LDA specifies the first dimension of A as declared in the
* calling program. LDA must be at least N.
* Not modified.
*
* WORK - REAL array, dimension ( 3*N )
* Workspace.
* Modified.
*
* INFO - INTEGER
* Error code. On exit, INFO will be set to one of the
* following values:
* 0 => normal return
* -1 => N negative
* -2 => DIST illegal string
* -5 => MODE not in range -6 to 6
* -6 => COND less than 1.0, and MODE neither -6, 0 nor 6
* -8 => EI(1) is not ' ' or 'R', EI(j) is not 'R' or 'I', or
* two adjacent elements of EI are 'I'.
* -9 => RSIGN is not 'T' or 'F'
* -10 => UPPER is not 'T' or 'F'
* -11 => SIM is not 'T' or 'F'
* -12 => MODES=0 and DS has a zero singular value.
* -13 => MODES is not in the range -5 to 5.
* -14 => MODES is nonzero and CONDS is less than 1.
* -15 => KL is less than 1.
* -16 => KU is less than 1, or KL and KU are both less than
* N-1.
* -19 => LDA is less than N.
* 1 => Error return from SLATM1 (computing D)
* 2 => Cannot scale to DMAX (max. eigenvalue is 0)
* 3 => Error return from SLATM1 (computing DS)
* 4 => Error return from SLARGE
* 5 => Zero singular value from SLATM1.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
REAL ONE
PARAMETER ( ONE = 1.0E0 )
REAL HALF
PARAMETER ( HALF = 1.0E0 / 2.0E0 )
* ..
* .. Local Scalars ..
LOGICAL BADEI, BADS, USEEI
INTEGER I, IC, ICOLS, IDIST, IINFO, IR, IROWS, IRSIGN,
$ ISIM, IUPPER, J, JC, JCR, JR
REAL ALPHA, TAU, TEMP, XNORMS
* ..
* .. Local Arrays ..
REAL TEMPA( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLANGE, SLARAN
EXTERNAL LSAME, SLANGE, SLARAN
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMV, SGER, SLARFG, SLARGE, SLARNV,
$ SLATM1, SLASET, SSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MOD
* ..
* .. Executable Statements ..
*
* 1) Decode and Test the input parameters.
* Initialize flags & seed.
*
INFO = 0
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Decode DIST
*
IF( LSAME( DIST, 'U' ) ) THEN
IDIST = 1
ELSE IF( LSAME( DIST, 'S' ) ) THEN
IDIST = 2
ELSE IF( LSAME( DIST, 'N' ) ) THEN
IDIST = 3
ELSE
IDIST = -1
END IF
*
* Check EI
*
USEEI = .TRUE.
BADEI = .FALSE.
IF( LSAME( EI( 1 ), ' ' ) .OR. MODE.NE.0 ) THEN
USEEI = .FALSE.
ELSE
IF( LSAME( EI( 1 ), 'R' ) ) THEN
DO 10 J = 2, N
IF( LSAME( EI( J ), 'I' ) ) THEN
IF( LSAME( EI( J-1 ), 'I' ) )
$ BADEI = .TRUE.
ELSE
IF( .NOT.LSAME( EI( J ), 'R' ) )
$ BADEI = .TRUE.
END IF
10 CONTINUE
ELSE
BADEI = .TRUE.
END IF
END IF
*
* Decode RSIGN
*
IF( LSAME( RSIGN, 'T' ) ) THEN
IRSIGN = 1
ELSE IF( LSAME( RSIGN, 'F' ) ) THEN
IRSIGN = 0
ELSE
IRSIGN = -1
END IF
*
* Decode UPPER
*
IF( LSAME( UPPER, 'T' ) ) THEN
IUPPER = 1
ELSE IF( LSAME( UPPER, 'F' ) ) THEN
IUPPER = 0
ELSE
IUPPER = -1
END IF
*
* Decode SIM
*
IF( LSAME( SIM, 'T' ) ) THEN
ISIM = 1
ELSE IF( LSAME( SIM, 'F' ) ) THEN
ISIM = 0
ELSE
ISIM = -1
END IF
*
* Check DS, if MODES=0 and ISIM=1
*
BADS = .FALSE.
IF( MODES.EQ.0 .AND. ISIM.EQ.1 ) THEN
DO 20 J = 1, N
IF( DS( J ).EQ.ZERO )
$ BADS = .TRUE.
20 CONTINUE
END IF
*
* Set INFO if an error
*
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( IDIST.EQ.-1 ) THEN
INFO = -2
ELSE IF( ABS( MODE ).GT.6 ) THEN
INFO = -5
ELSE IF( ( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) .AND. COND.LT.ONE )
$ THEN
INFO = -6
ELSE IF( BADEI ) THEN
INFO = -8
ELSE IF( IRSIGN.EQ.-1 ) THEN
INFO = -9
ELSE IF( IUPPER.EQ.-1 ) THEN
INFO = -10
ELSE IF( ISIM.EQ.-1 ) THEN
INFO = -11
ELSE IF( BADS ) THEN
INFO = -12
ELSE IF( ISIM.EQ.1 .AND. ABS( MODES ).GT.5 ) THEN
INFO = -13
ELSE IF( ISIM.EQ.1 .AND. MODES.NE.0 .AND. CONDS.LT.ONE ) THEN
INFO = -14
ELSE IF( KL.LT.1 ) THEN
INFO = -15
ELSE IF( KU.LT.1 .OR. ( KU.LT.N-1 .AND. KL.LT.N-1 ) ) THEN
INFO = -16
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -19
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLATME', -INFO )
RETURN
END IF
*
* Initialize random number generator
*
DO 30 I = 1, 4
ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 )
30 CONTINUE
*
IF( MOD( ISEED( 4 ), 2 ).NE.1 )
$ ISEED( 4 ) = ISEED( 4 ) + 1
*
* 2) Set up diagonal of A
*
* Compute D according to COND and MODE
*
CALL SLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 1
RETURN
END IF
IF( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) THEN
*
* Scale by DMAX
*
TEMP = ABS( D( 1 ) )
DO 40 I = 2, N
TEMP = MAX( TEMP, ABS( D( I ) ) )
40 CONTINUE
*
IF( TEMP.GT.ZERO ) THEN
ALPHA = DMAX / TEMP
ELSE IF( DMAX.NE.ZERO ) THEN
INFO = 2
RETURN
ELSE
ALPHA = ZERO
END IF
*
CALL SSCAL( N, ALPHA, D, 1 )
*
END IF
*
CALL SLASET( 'Full', N, N, ZERO, ZERO, A, LDA )
CALL SCOPY( N, D, 1, A, LDA+1 )
*
* Set up complex conjugate pairs
*
IF( MODE.EQ.0 ) THEN
IF( USEEI ) THEN
DO 50 J = 2, N
IF( LSAME( EI( J ), 'I' ) ) THEN
A( J-1, J ) = A( J, J )
A( J, J-1 ) = -A( J, J )
A( J, J ) = A( J-1, J-1 )
END IF
50 CONTINUE
END IF
*
ELSE IF( ABS( MODE ).EQ.5 ) THEN
*
DO 60 J = 2, N, 2
IF( SLARAN( ISEED ).GT.HALF ) THEN
A( J-1, J ) = A( J, J )
A( J, J-1 ) = -A( J, J )
A( J, J ) = A( J-1, J-1 )
END IF
60 CONTINUE
END IF
*
* 3) If UPPER='T', set upper triangle of A to random numbers.
* (but don't modify the corners of 2x2 blocks.)
*
IF( IUPPER.NE.0 ) THEN
DO 70 JC = 2, N
IF( A( JC-1, JC ).NE.ZERO ) THEN
JR = JC - 2
ELSE
JR = JC - 1
END IF
CALL SLARNV( IDIST, ISEED, JR, A( 1, JC ) )
70 CONTINUE
END IF
*
* 4) If SIM='T', apply similarity transformation.
*
* -1
* Transform is X A X , where X = U S V, thus
*
* it is U S V A V' (1/S) U'
*
IF( ISIM.NE.0 ) THEN
*
* Compute S (singular values of the eigenvector matrix)
* according to CONDS and MODES
*
CALL SLATM1( MODES, CONDS, 0, 0, ISEED, DS, N, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 3
RETURN
END IF
*
* Multiply by V and V'
*
CALL SLARGE( N, A, LDA, ISEED, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 4
RETURN
END IF
*
* Multiply by S and (1/S)
*
DO 80 J = 1, N
CALL SSCAL( N, DS( J ), A( J, 1 ), LDA )
IF( DS( J ).NE.ZERO ) THEN
CALL SSCAL( N, ONE / DS( J ), A( 1, J ), 1 )
ELSE
INFO = 5
RETURN
END IF
80 CONTINUE
*
* Multiply by U and U'
*
CALL SLARGE( N, A, LDA, ISEED, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 4
RETURN
END IF
END IF
*
* 5) Reduce the bandwidth.
*
IF( KL.LT.N-1 ) THEN
*
* Reduce bandwidth -- kill column
*
DO 90 JCR = KL + 1, N - 1
IC = JCR - KL
IROWS = N + 1 - JCR
ICOLS = N + KL - JCR
*
CALL SCOPY( IROWS, A( JCR, IC ), 1, WORK, 1 )
XNORMS = WORK( 1 )
CALL SLARFG( IROWS, XNORMS, WORK( 2 ), 1, TAU )
WORK( 1 ) = ONE
*
CALL SGEMV( 'T', IROWS, ICOLS, ONE, A( JCR, IC+1 ), LDA,
$ WORK, 1, ZERO, WORK( IROWS+1 ), 1 )
CALL SGER( IROWS, ICOLS, -TAU, WORK, 1, WORK( IROWS+1 ), 1,
$ A( JCR, IC+1 ), LDA )
*
CALL SGEMV( 'N', N, IROWS, ONE, A( 1, JCR ), LDA, WORK, 1,
$ ZERO, WORK( IROWS+1 ), 1 )
CALL SGER( N, IROWS, -TAU, WORK( IROWS+1 ), 1, WORK, 1,
$ A( 1, JCR ), LDA )
*
A( JCR, IC ) = XNORMS
CALL SLASET( 'Full', IROWS-1, 1, ZERO, ZERO, A( JCR+1, IC ),
$ LDA )
90 CONTINUE
ELSE IF( KU.LT.N-1 ) THEN
*
* Reduce upper bandwidth -- kill a row at a time.
*
DO 100 JCR = KU + 1, N - 1
IR = JCR - KU
IROWS = N + KU - JCR
ICOLS = N + 1 - JCR
*
CALL SCOPY( ICOLS, A( IR, JCR ), LDA, WORK, 1 )
XNORMS = WORK( 1 )
CALL SLARFG( ICOLS, XNORMS, WORK( 2 ), 1, TAU )
WORK( 1 ) = ONE
*
CALL SGEMV( 'N', IROWS, ICOLS, ONE, A( IR+1, JCR ), LDA,
$ WORK, 1, ZERO, WORK( ICOLS+1 ), 1 )
CALL SGER( IROWS, ICOLS, -TAU, WORK( ICOLS+1 ), 1, WORK, 1,
$ A( IR+1, JCR ), LDA )
*
CALL SGEMV( 'C', ICOLS, N, ONE, A( JCR, 1 ), LDA, WORK, 1,
$ ZERO, WORK( ICOLS+1 ), 1 )
CALL SGER( ICOLS, N, -TAU, WORK, 1, WORK( ICOLS+1 ), 1,
$ A( JCR, 1 ), LDA )
*
A( IR, JCR ) = XNORMS
CALL SLASET( 'Full', 1, ICOLS-1, ZERO, ZERO, A( IR, JCR+1 ),
$ LDA )
100 CONTINUE
END IF
*
* Scale the matrix to have norm ANORM
*
IF( ANORM.GE.ZERO ) THEN
TEMP = SLANGE( 'M', N, N, A, LDA, TEMPA )
IF( TEMP.GT.ZERO ) THEN
ALPHA = ANORM / TEMP
DO 110 J = 1, N
CALL SSCAL( N, ALPHA, A( 1, J ), 1 )
110 CONTINUE
END IF
END IF
*
RETURN
*
* End of SLATME
*
END
SUBROUTINE SLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX,
$ RSIGN, GRADE, DL, MODEL, CONDL, DR, MODER,
$ CONDR, PIVTNG, IPIVOT, KL, KU, SPARSE, ANORM,
$ PACK, A, LDA, IWORK, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIST, GRADE, PACK, PIVTNG, RSIGN, SYM
INTEGER INFO, KL, KU, LDA, M, MODE, MODEL, MODER, N
REAL ANORM, COND, CONDL, CONDR, DMAX, SPARSE
* ..
* .. Array Arguments ..
INTEGER IPIVOT( * ), ISEED( 4 ), IWORK( * )
REAL A( LDA, * ), D( * ), DL( * ), DR( * )
* ..
*
* Purpose
* =======
*
* SLATMR generates random matrices of various types for testing
* LAPACK programs.
*
* SLATMR operates by applying the following sequence of
* operations:
*
* Generate a matrix A with random entries of distribution DIST
* which is symmetric if SYM='S', and nonsymmetric
* if SYM='N'.
*
* Set the diagonal to D, where D may be input or
* computed according to MODE, COND, DMAX and RSIGN
* as described below.
*
* Grade the matrix, if desired, from the left and/or right
* as specified by GRADE. The inputs DL, MODEL, CONDL, DR,
* MODER and CONDR also determine the grading as described
* below.
*
* Permute, if desired, the rows and/or columns as specified by
* PIVTNG and IPIVOT.
*
* Set random entries to zero, if desired, to get a random sparse
* matrix as specified by SPARSE.
*
* Make A a band matrix, if desired, by zeroing out the matrix
* outside a band of lower bandwidth KL and upper bandwidth KU.
*
* Scale A, if desired, to have maximum entry ANORM.
*
* Pack the matrix if desired. Options specified by PACK are:
* no packing
* zero out upper half (if symmetric)
* zero out lower half (if symmetric)
* store the upper half columnwise (if symmetric or
* square upper triangular)
* store the lower half columnwise (if symmetric or
* square lower triangular)
* same as upper half rowwise if symmetric
* store the lower triangle in banded format (if symmetric)
* store the upper triangle in banded format (if symmetric)
* store the entire matrix in banded format
*
* Note: If two calls to SLATMR differ only in the PACK parameter,
* they will generate mathematically equivalent matrices.
*
* If two calls to SLATMR both have full bandwidth (KL = M-1
* and KU = N-1), and differ only in the PIVTNG and PACK
* parameters, then the matrices generated will differ only
* in the order of the rows and/or columns, and otherwise
* contain the same data. This consistency cannot be and
* is not maintained with less than full bandwidth.
*
* Arguments
* =========
*
* M - INTEGER
* Number of rows of A. Not modified.
*
* N - INTEGER
* Number of columns of A. Not modified.
*
* DIST - CHARACTER*1
* On entry, DIST specifies the type of distribution to be used
* to generate a random matrix .
* 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform )
* 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric )
* 'N' => NORMAL( 0, 1 ) ( 'N' for normal )
* Not modified.
*
* ISEED - INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. They should lie between 0 and 4095 inclusive,
* and ISEED(4) should be odd. The random number generator
* uses a linear congruential sequence limited to small
* integers, and so should produce machine independent
* random numbers. The values of ISEED are changed on
* exit, and can be used in the next call to SLATMR
* to continue the same random number sequence.
* Changed on exit.
*
* SYM - CHARACTER*1
* If SYM='S' or 'H', generated matrix is symmetric.
* If SYM='N', generated matrix is nonsymmetric.
* Not modified.
*
* D - REAL array, dimension (min(M,N))
* On entry this array specifies the diagonal entries
* of the diagonal of A. D may either be specified
* on entry, or set according to MODE and COND as described
* below. May be changed on exit if MODE is nonzero.
*
* MODE - INTEGER
* On entry describes how D is to be used:
* MODE = 0 means use D as input
* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND
* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND
* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1))
* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
* MODE = 5 sets D to random numbers in the range
* ( 1/COND , 1 ) such that their logarithms
* are uniformly distributed.
* MODE = 6 set D to random numbers from same distribution
* as the rest of the matrix.
* MODE < 0 has the same meaning as ABS(MODE), except that
* the order of the elements of D is reversed.
* Thus if MODE is positive, D has entries ranging from
* 1 to 1/COND, if negative, from 1/COND to 1,
* Not modified.
*
* COND - REAL
* On entry, used as described under MODE above.
* If used, it must be >= 1. Not modified.
*
* DMAX - REAL
* If MODE neither -6, 0 nor 6, the diagonal is scaled by
* DMAX / max(abs(D(i))), so that maximum absolute entry
* of diagonal is abs(DMAX). If DMAX is negative (or zero),
* diagonal will be scaled by a negative number (or zero).
*
* RSIGN - CHARACTER*1
* If MODE neither -6, 0 nor 6, specifies sign of diagonal
* as follows:
* 'T' => diagonal entries are multiplied by 1 or -1
* with probability .5
* 'F' => diagonal unchanged
* Not modified.
*
* GRADE - CHARACTER*1
* Specifies grading of matrix as follows:
* 'N' => no grading
* 'L' => matrix premultiplied by diag( DL )
* (only if matrix nonsymmetric)
* 'R' => matrix postmultiplied by diag( DR )
* (only if matrix nonsymmetric)
* 'B' => matrix premultiplied by diag( DL ) and
* postmultiplied by diag( DR )
* (only if matrix nonsymmetric)
* 'S' or 'H' => matrix premultiplied by diag( DL ) and
* postmultiplied by diag( DL )
* ('S' for symmetric, or 'H' for Hermitian)
* 'E' => matrix premultiplied by diag( DL ) and
* postmultiplied by inv( diag( DL ) )
* ( 'E' for eigenvalue invariance)
* (only if matrix nonsymmetric)
* Note: if GRADE='E', then M must equal N.
* Not modified.
*
* DL - REAL array, dimension (M)
* If MODEL=0, then on entry this array specifies the diagonal
* entries of a diagonal matrix used as described under GRADE
* above. If MODEL is not zero, then DL will be set according
* to MODEL and CONDL, analogous to the way D is set according
* to MODE and COND (except there is no DMAX parameter for DL).
* If GRADE='E', then DL cannot have zero entries.
* Not referenced if GRADE = 'N' or 'R'. Changed on exit.
*
* MODEL - INTEGER
* This specifies how the diagonal array DL is to be computed,
* just as MODE specifies how D is to be computed.
* Not modified.
*
* CONDL - REAL
* When MODEL is not zero, this specifies the condition number
* of the computed DL. Not modified.
*
* DR - REAL array, dimension (N)
* If MODER=0, then on entry this array specifies the diagonal
* entries of a diagonal matrix used as described under GRADE
* above. If MODER is not zero, then DR will be set according
* to MODER and CONDR, analogous to the way D is set according
* to MODE and COND (except there is no DMAX parameter for DR).
* Not referenced if GRADE = 'N', 'L', 'H', 'S' or 'E'.
* Changed on exit.
*
* MODER - INTEGER
* This specifies how the diagonal array DR is to be computed,
* just as MODE specifies how D is to be computed.
* Not modified.
*
* CONDR - REAL
* When MODER is not zero, this specifies the condition number
* of the computed DR. Not modified.
*
* PIVTNG - CHARACTER*1
* On entry specifies pivoting permutations as follows:
* 'N' or ' ' => none.
* 'L' => left or row pivoting (matrix must be nonsymmetric).
* 'R' => right or column pivoting (matrix must be
* nonsymmetric).
* 'B' or 'F' => both or full pivoting, i.e., on both sides.
* In this case, M must equal N
*
* If two calls to SLATMR both have full bandwidth (KL = M-1
* and KU = N-1), and differ only in the PIVTNG and PACK
* parameters, then the matrices generated will differ only
* in the order of the rows and/or columns, and otherwise
* contain the same data. This consistency cannot be
* maintained with less than full bandwidth.
*
* IPIVOT - INTEGER array, dimension (N or M)
* This array specifies the permutation used. After the
* basic matrix is generated, the rows, columns, or both
* are permuted. If, say, row pivoting is selected, SLATMR
* starts with the *last* row and interchanges the M-th and
* IPIVOT(M)-th rows, then moves to the next-to-last row,
* interchanging the (M-1)-th and the IPIVOT(M-1)-th rows,
* and so on. In terms of "2-cycles", the permutation is
* (1 IPIVOT(1)) (2 IPIVOT(2)) ... (M IPIVOT(M))
* where the rightmost cycle is applied first. This is the
* *inverse* of the effect of pivoting in LINPACK. The idea
* is that factoring (with pivoting) an identity matrix
* which has been inverse-pivoted in this way should
* result in a pivot vector identical to IPIVOT.
* Not referenced if PIVTNG = 'N'. Not modified.
*
* SPARSE - REAL
* On entry specifies the sparsity of the matrix if a sparse
* matrix is to be generated. SPARSE should lie between
* 0 and 1. To generate a sparse matrix, for each matrix entry
* a uniform ( 0, 1 ) random number x is generated and
* compared to SPARSE; if x is larger the matrix entry
* is unchanged and if x is smaller the entry is set
* to zero. Thus on the average a fraction SPARSE of the
* entries will be set to zero.
* Not modified.
*
* KL - INTEGER
* On entry specifies the lower bandwidth of the matrix. For
* example, KL=0 implies upper triangular, KL=1 implies upper
* Hessenberg, and KL at least M-1 implies the matrix is not
* banded. Must equal KU if matrix is symmetric.
* Not modified.
*
* KU - INTEGER
* On entry specifies the upper bandwidth of the matrix. For
* example, KU=0 implies lower triangular, KU=1 implies lower
* Hessenberg, and KU at least N-1 implies the matrix is not
* banded. Must equal KL if matrix is symmetric.
* Not modified.
*
* ANORM - REAL
* On entry specifies maximum entry of output matrix
* (output matrix will by multiplied by a constant so that
* its largest absolute entry equal ANORM)
* if ANORM is nonnegative. If ANORM is negative no scaling
* is done. Not modified.
*
* PACK - CHARACTER*1
* On entry specifies packing of matrix as follows:
* 'N' => no packing
* 'U' => zero out all subdiagonal entries (if symmetric)
* 'L' => zero out all superdiagonal entries (if symmetric)
* 'C' => store the upper triangle columnwise
* (only if matrix symmetric or square upper triangular)
* 'R' => store the lower triangle columnwise
* (only if matrix symmetric or square lower triangular)
* (same as upper half rowwise if symmetric)
* 'B' => store the lower triangle in band storage scheme
* (only if matrix symmetric)
* 'Q' => store the upper triangle in band storage scheme
* (only if matrix symmetric)
* 'Z' => store the entire matrix in band storage scheme
* (pivoting can be provided for by using this
* option to store A in the trailing rows of
* the allocated storage)
*
* Using these options, the various LAPACK packed and banded
* storage schemes can be obtained:
* GB - use 'Z'
* PB, SB or TB - use 'B' or 'Q'
* PP, SP or TP - use 'C' or 'R'
*
* If two calls to SLATMR differ only in the PACK parameter,
* they will generate mathematically equivalent matrices.
* Not modified.
*
* A - REAL array, dimension (LDA,N)
* On exit A is the desired test matrix. Only those
* entries of A which are significant on output
* will be referenced (even if A is in packed or band
* storage format). The 'unoccupied corners' of A in
* band format will be zeroed out.
*
* LDA - INTEGER
* on entry LDA specifies the first dimension of A as
* declared in the calling program.
* If PACK='N', 'U' or 'L', LDA must be at least max ( 1, M ).
* If PACK='C' or 'R', LDA must be at least 1.
* If PACK='B', or 'Q', LDA must be MIN ( KU+1, N )
* If PACK='Z', LDA must be at least KUU+KLL+1, where
* KUU = MIN ( KU, N-1 ) and KLL = MIN ( KL, N-1 )
* Not modified.
*
* IWORK - INTEGER array, dimension ( N or M)
* Workspace. Not referenced if PIVTNG = 'N'. Changed on exit.
*
* INFO - INTEGER
* Error parameter on exit:
* 0 => normal return
* -1 => M negative or unequal to N and SYM='S' or 'H'
* -2 => N negative
* -3 => DIST illegal string
* -5 => SYM illegal string
* -7 => MODE not in range -6 to 6
* -8 => COND less than 1.0, and MODE neither -6, 0 nor 6
* -10 => MODE neither -6, 0 nor 6 and RSIGN illegal string
* -11 => GRADE illegal string, or GRADE='E' and
* M not equal to N, or GRADE='L', 'R', 'B' or 'E' and
* SYM = 'S' or 'H'
* -12 => GRADE = 'E' and DL contains zero
* -13 => MODEL not in range -6 to 6 and GRADE= 'L', 'B', 'H',
* 'S' or 'E'
* -14 => CONDL less than 1.0, GRADE='L', 'B', 'H', 'S' or 'E',
* and MODEL neither -6, 0 nor 6
* -16 => MODER not in range -6 to 6 and GRADE= 'R' or 'B'
* -17 => CONDR less than 1.0, GRADE='R' or 'B', and
* MODER neither -6, 0 nor 6
* -18 => PIVTNG illegal string, or PIVTNG='B' or 'F' and
* M not equal to N, or PIVTNG='L' or 'R' and SYM='S'
* or 'H'
* -19 => IPIVOT contains out of range number and
* PIVTNG not equal to 'N'
* -20 => KL negative
* -21 => KU negative, or SYM='S' or 'H' and KU not equal to KL
* -22 => SPARSE not in range 0. to 1.
* -24 => PACK illegal string, or PACK='U', 'L', 'B' or 'Q'
* and SYM='N', or PACK='C' and SYM='N' and either KL
* not equal to 0 or N not equal to M, or PACK='R' and
* SYM='N', and either KU not equal to 0 or N not equal
* to M
* -26 => LDA too small
* 1 => Error return from SLATM1 (computing D)
* 2 => Cannot scale diagonal to DMAX (max. entry is 0)
* 3 => Error return from SLATM1 (computing DL)
* 4 => Error return from SLATM1 (computing DR)
* 5 => ANORM is positive, but matrix constructed prior to
* attempting to scale it to have norm ANORM, is zero
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
REAL ONE
PARAMETER ( ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL BADPVT, DZERO, FULBND
INTEGER I, IDIST, IGRADE, IISUB, IPACK, IPVTNG, IRSIGN,
$ ISUB, ISYM, J, JJSUB, JSUB, K, KLL, KUU, MNMIN,
$ MNSUB, MXSUB, NPVTS
REAL ALPHA, ONORM, TEMP
* ..
* .. Local Arrays ..
REAL TEMPA( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLANGB, SLANGE, SLANSB, SLANSP, SLANSY, SLATM2,
$ SLATM3
EXTERNAL LSAME, SLANGB, SLANGE, SLANSB, SLANSP, SLANSY,
$ SLATM2, SLATM3
* ..
* .. External Subroutines ..
EXTERNAL SLATM1, SSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, MOD
* ..
* .. Executable Statements ..
*
* 1) Decode and Test the input parameters.
* Initialize flags & seed.
*
INFO = 0
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
* Decode DIST
*
IF( LSAME( DIST, 'U' ) ) THEN
IDIST = 1
ELSE IF( LSAME( DIST, 'S' ) ) THEN
IDIST = 2
ELSE IF( LSAME( DIST, 'N' ) ) THEN
IDIST = 3
ELSE
IDIST = -1
END IF
*
* Decode SYM
*
IF( LSAME( SYM, 'S' ) ) THEN
ISYM = 0
ELSE IF( LSAME( SYM, 'N' ) ) THEN
ISYM = 1
ELSE IF( LSAME( SYM, 'H' ) ) THEN
ISYM = 0
ELSE
ISYM = -1
END IF
*
* Decode RSIGN
*
IF( LSAME( RSIGN, 'F' ) ) THEN
IRSIGN = 0
ELSE IF( LSAME( RSIGN, 'T' ) ) THEN
IRSIGN = 1
ELSE
IRSIGN = -1
END IF
*
* Decode PIVTNG
*
IF( LSAME( PIVTNG, 'N' ) ) THEN
IPVTNG = 0
ELSE IF( LSAME( PIVTNG, ' ' ) ) THEN
IPVTNG = 0
ELSE IF( LSAME( PIVTNG, 'L' ) ) THEN
IPVTNG = 1
NPVTS = M
ELSE IF( LSAME( PIVTNG, 'R' ) ) THEN
IPVTNG = 2
NPVTS = N
ELSE IF( LSAME( PIVTNG, 'B' ) ) THEN
IPVTNG = 3
NPVTS = MIN( N, M )
ELSE IF( LSAME( PIVTNG, 'F' ) ) THEN
IPVTNG = 3
NPVTS = MIN( N, M )
ELSE
IPVTNG = -1
END IF
*
* Decode GRADE
*
IF( LSAME( GRADE, 'N' ) ) THEN
IGRADE = 0
ELSE IF( LSAME( GRADE, 'L' ) ) THEN
IGRADE = 1
ELSE IF( LSAME( GRADE, 'R' ) ) THEN
IGRADE = 2
ELSE IF( LSAME( GRADE, 'B' ) ) THEN
IGRADE = 3
ELSE IF( LSAME( GRADE, 'E' ) ) THEN
IGRADE = 4
ELSE IF( LSAME( GRADE, 'H' ) .OR. LSAME( GRADE, 'S' ) ) THEN
IGRADE = 5
ELSE
IGRADE = -1
END IF
*
* Decode PACK
*
IF( LSAME( PACK, 'N' ) ) THEN
IPACK = 0
ELSE IF( LSAME( PACK, 'U' ) ) THEN
IPACK = 1
ELSE IF( LSAME( PACK, 'L' ) ) THEN
IPACK = 2
ELSE IF( LSAME( PACK, 'C' ) ) THEN
IPACK = 3
ELSE IF( LSAME( PACK, 'R' ) ) THEN
IPACK = 4
ELSE IF( LSAME( PACK, 'B' ) ) THEN
IPACK = 5
ELSE IF( LSAME( PACK, 'Q' ) ) THEN
IPACK = 6
ELSE IF( LSAME( PACK, 'Z' ) ) THEN
IPACK = 7
ELSE
IPACK = -1
END IF
*
* Set certain internal parameters
*
MNMIN = MIN( M, N )
KLL = MIN( KL, M-1 )
KUU = MIN( KU, N-1 )
*
* If inv(DL) is used, check to see if DL has a zero entry.
*
DZERO = .FALSE.
IF( IGRADE.EQ.4 .AND. MODEL.EQ.0 ) THEN
DO 10 I = 1, M
IF( DL( I ).EQ.ZERO )
$ DZERO = .TRUE.
10 CONTINUE
END IF
*
* Check values in IPIVOT
*
BADPVT = .FALSE.
IF( IPVTNG.GT.0 ) THEN
DO 20 J = 1, NPVTS
IF( IPIVOT( J ).LE.0 .OR. IPIVOT( J ).GT.NPVTS )
$ BADPVT = .TRUE.
20 CONTINUE
END IF
*
* Set INFO if an error
*
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( M.NE.N .AND. ISYM.EQ.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( IDIST.EQ.-1 ) THEN
INFO = -3
ELSE IF( ISYM.EQ.-1 ) THEN
INFO = -5
ELSE IF( MODE.LT.-6 .OR. MODE.GT.6 ) THEN
INFO = -7
ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
$ COND.LT.ONE ) THEN
INFO = -8
ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
$ IRSIGN.EQ.-1 ) THEN
INFO = -10
ELSE IF( IGRADE.EQ.-1 .OR. ( IGRADE.EQ.4 .AND. M.NE.N ) .OR.
$ ( ( IGRADE.GE.1 .AND. IGRADE.LE.4 ) .AND. ISYM.EQ.0 ) )
$ THEN
INFO = -11
ELSE IF( IGRADE.EQ.4 .AND. DZERO ) THEN
INFO = -12
ELSE IF( ( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR.
$ IGRADE.EQ.5 ) .AND. ( MODEL.LT.-6 .OR. MODEL.GT.6 ) )
$ THEN
INFO = -13
ELSE IF( ( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR.
$ IGRADE.EQ.5 ) .AND. ( MODEL.NE.-6 .AND. MODEL.NE.0 .AND.
$ MODEL.NE.6 ) .AND. CONDL.LT.ONE ) THEN
INFO = -14
ELSE IF( ( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) .AND.
$ ( MODER.LT.-6 .OR. MODER.GT.6 ) ) THEN
INFO = -16
ELSE IF( ( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) .AND.
$ ( MODER.NE.-6 .AND. MODER.NE.0 .AND. MODER.NE.6 ) .AND.
$ CONDR.LT.ONE ) THEN
INFO = -17
ELSE IF( IPVTNG.EQ.-1 .OR. ( IPVTNG.EQ.3 .AND. M.NE.N ) .OR.
$ ( ( IPVTNG.EQ.1 .OR. IPVTNG.EQ.2 ) .AND. ISYM.EQ.0 ) )
$ THEN
INFO = -18
ELSE IF( IPVTNG.NE.0 .AND. BADPVT ) THEN
INFO = -19
ELSE IF( KL.LT.0 ) THEN
INFO = -20
ELSE IF( KU.LT.0 .OR. ( ISYM.EQ.0 .AND. KL.NE.KU ) ) THEN
INFO = -21
ELSE IF( SPARSE.LT.ZERO .OR. SPARSE.GT.ONE ) THEN
INFO = -22
ELSE IF( IPACK.EQ.-1 .OR. ( ( IPACK.EQ.1 .OR. IPACK.EQ.2 .OR.
$ IPACK.EQ.5 .OR. IPACK.EQ.6 ) .AND. ISYM.EQ.1 ) .OR.
$ ( IPACK.EQ.3 .AND. ISYM.EQ.1 .AND. ( KL.NE.0 .OR. M.NE.
$ N ) ) .OR. ( IPACK.EQ.4 .AND. ISYM.EQ.1 .AND. ( KU.NE.
$ 0 .OR. M.NE.N ) ) ) THEN
INFO = -24
ELSE IF( ( ( IPACK.EQ.0 .OR. IPACK.EQ.1 .OR. IPACK.EQ.2 ) .AND.
$ LDA.LT.MAX( 1, M ) ) .OR. ( ( IPACK.EQ.3 .OR. IPACK.EQ.
$ 4 ) .AND. LDA.LT.1 ) .OR. ( ( IPACK.EQ.5 .OR. IPACK.EQ.
$ 6 ) .AND. LDA.LT.KUU+1 ) .OR.
$ ( IPACK.EQ.7 .AND. LDA.LT.KLL+KUU+1 ) ) THEN
INFO = -26
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLATMR', -INFO )
RETURN
END IF
*
* Decide if we can pivot consistently
*
FULBND = .FALSE.
IF( KUU.EQ.N-1 .AND. KLL.EQ.M-1 )
$ FULBND = .TRUE.
*
* Initialize random number generator
*
DO 30 I = 1, 4
ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 )
30 CONTINUE
*
ISEED( 4 ) = 2*( ISEED( 4 ) / 2 ) + 1
*
* 2) Set up D, DL, and DR, if indicated.
*
* Compute D according to COND and MODE
*
CALL SLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, MNMIN, INFO )
IF( INFO.NE.0 ) THEN
INFO = 1
RETURN
END IF
IF( MODE.NE.0 .AND. MODE.NE.-6 .AND. MODE.NE.6 ) THEN
*
* Scale by DMAX
*
TEMP = ABS( D( 1 ) )
DO 40 I = 2, MNMIN
TEMP = MAX( TEMP, ABS( D( I ) ) )
40 CONTINUE
IF( TEMP.EQ.ZERO .AND. DMAX.NE.ZERO ) THEN
INFO = 2
RETURN
END IF
IF( TEMP.NE.ZERO ) THEN
ALPHA = DMAX / TEMP
ELSE
ALPHA = ONE
END IF
DO 50 I = 1, MNMIN
D( I ) = ALPHA*D( I )
50 CONTINUE
*
END IF
*
* Compute DL if grading set
*
IF( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR. IGRADE.EQ.
$ 5 ) THEN
CALL SLATM1( MODEL, CONDL, 0, IDIST, ISEED, DL, M, INFO )
IF( INFO.NE.0 ) THEN
INFO = 3
RETURN
END IF
END IF
*
* Compute DR if grading set
*
IF( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) THEN
CALL SLATM1( MODER, CONDR, 0, IDIST, ISEED, DR, N, INFO )
IF( INFO.NE.0 ) THEN
INFO = 4
RETURN
END IF
END IF
*
* 3) Generate IWORK if pivoting
*
IF( IPVTNG.GT.0 ) THEN
DO 60 I = 1, NPVTS
IWORK( I ) = I
60 CONTINUE
IF( FULBND ) THEN
DO 70 I = 1, NPVTS
K = IPIVOT( I )
J = IWORK( I )
IWORK( I ) = IWORK( K )
IWORK( K ) = J
70 CONTINUE
ELSE
DO 80 I = NPVTS, 1, -1
K = IPIVOT( I )
J = IWORK( I )
IWORK( I ) = IWORK( K )
IWORK( K ) = J
80 CONTINUE
END IF
END IF
*
* 4) Generate matrices for each kind of PACKing
* Always sweep matrix columnwise (if symmetric, upper
* half only) so that matrix generated does not depend
* on PACK
*
IF( FULBND ) THEN
*
* Use SLATM3 so matrices generated with differing PIVOTing only
* differ only in the order of their rows and/or columns.
*
IF( IPACK.EQ.0 ) THEN
IF( ISYM.EQ.0 ) THEN
DO 100 J = 1, N
DO 90 I = 1, J
TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
A( ISUB, JSUB ) = TEMP
A( JSUB, ISUB ) = TEMP
90 CONTINUE
100 CONTINUE
ELSE IF( ISYM.EQ.1 ) THEN
DO 120 J = 1, N
DO 110 I = 1, M
TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
A( ISUB, JSUB ) = TEMP
110 CONTINUE
120 CONTINUE
END IF
*
ELSE IF( IPACK.EQ.1 ) THEN
*
DO 140 J = 1, N
DO 130 I = 1, J
TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
$ SPARSE )
MNSUB = MIN( ISUB, JSUB )
MXSUB = MAX( ISUB, JSUB )
A( MNSUB, MXSUB ) = TEMP
IF( MNSUB.NE.MXSUB )
$ A( MXSUB, MNSUB ) = ZERO
130 CONTINUE
140 CONTINUE
*
ELSE IF( IPACK.EQ.2 ) THEN
*
DO 160 J = 1, N
DO 150 I = 1, J
TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
$ SPARSE )
MNSUB = MIN( ISUB, JSUB )
MXSUB = MAX( ISUB, JSUB )
A( MXSUB, MNSUB ) = TEMP
IF( MNSUB.NE.MXSUB )
$ A( MNSUB, MXSUB ) = ZERO
150 CONTINUE
160 CONTINUE
*
ELSE IF( IPACK.EQ.3 ) THEN
*
DO 180 J = 1, N
DO 170 I = 1, J
TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
$ SPARSE )
*
* Compute K = location of (ISUB,JSUB) entry in packed
* array
*
MNSUB = MIN( ISUB, JSUB )
MXSUB = MAX( ISUB, JSUB )
K = MXSUB*( MXSUB-1 ) / 2 + MNSUB
*
* Convert K to (IISUB,JJSUB) location
*
JJSUB = ( K-1 ) / LDA + 1
IISUB = K - LDA*( JJSUB-1 )
*
A( IISUB, JJSUB ) = TEMP
170 CONTINUE
180 CONTINUE
*
ELSE IF( IPACK.EQ.4 ) THEN
*
DO 200 J = 1, N
DO 190 I = 1, J
TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
$ SPARSE )
*
* Compute K = location of (I,J) entry in packed array
*
MNSUB = MIN( ISUB, JSUB )
MXSUB = MAX( ISUB, JSUB )
IF( MNSUB.EQ.1 ) THEN
K = MXSUB
ELSE
K = N*( N+1 ) / 2 - ( N-MNSUB+1 )*( N-MNSUB+2 ) /
$ 2 + MXSUB - MNSUB + 1
END IF
*
* Convert K to (IISUB,JJSUB) location
*
JJSUB = ( K-1 ) / LDA + 1
IISUB = K - LDA*( JJSUB-1 )
*
A( IISUB, JJSUB ) = TEMP
190 CONTINUE
200 CONTINUE
*
ELSE IF( IPACK.EQ.5 ) THEN
*
DO 220 J = 1, N
DO 210 I = J - KUU, J
IF( I.LT.1 ) THEN
A( J-I+1, I+N ) = ZERO
ELSE
TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
MNSUB = MIN( ISUB, JSUB )
MXSUB = MAX( ISUB, JSUB )
A( MXSUB-MNSUB+1, MNSUB ) = TEMP
END IF
210 CONTINUE
220 CONTINUE
*
ELSE IF( IPACK.EQ.6 ) THEN
*
DO 240 J = 1, N
DO 230 I = J - KUU, J
TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
$ SPARSE )
MNSUB = MIN( ISUB, JSUB )
MXSUB = MAX( ISUB, JSUB )
A( MNSUB-MXSUB+KUU+1, MXSUB ) = TEMP
230 CONTINUE
240 CONTINUE
*
ELSE IF( IPACK.EQ.7 ) THEN
*
IF( ISYM.EQ.0 ) THEN
DO 260 J = 1, N
DO 250 I = J - KUU, J
TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
MNSUB = MIN( ISUB, JSUB )
MXSUB = MAX( ISUB, JSUB )
A( MNSUB-MXSUB+KUU+1, MXSUB ) = TEMP
IF( I.LT.1 )
$ A( J-I+1+KUU, I+N ) = ZERO
IF( I.GE.1 .AND. MNSUB.NE.MXSUB )
$ A( MXSUB-MNSUB+1+KUU, MNSUB ) = TEMP
250 CONTINUE
260 CONTINUE
ELSE IF( ISYM.EQ.1 ) THEN
DO 280 J = 1, N
DO 270 I = J - KUU, J + KLL
TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
A( ISUB-JSUB+KUU+1, JSUB ) = TEMP
270 CONTINUE
280 CONTINUE
END IF
*
END IF
*
ELSE
*
* Use SLATM2
*
IF( IPACK.EQ.0 ) THEN
IF( ISYM.EQ.0 ) THEN
DO 300 J = 1, N
DO 290 I = 1, J
A( I, J ) = SLATM2( M, N, I, J, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
A( J, I ) = A( I, J )
290 CONTINUE
300 CONTINUE
ELSE IF( ISYM.EQ.1 ) THEN
DO 320 J = 1, N
DO 310 I = 1, M
A( I, J ) = SLATM2( M, N, I, J, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
310 CONTINUE
320 CONTINUE
END IF
*
ELSE IF( IPACK.EQ.1 ) THEN
*
DO 340 J = 1, N
DO 330 I = 1, J
A( I, J ) = SLATM2( M, N, I, J, KL, KU, IDIST, ISEED,
$ D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE )
IF( I.NE.J )
$ A( J, I ) = ZERO
330 CONTINUE
340 CONTINUE
*
ELSE IF( IPACK.EQ.2 ) THEN
*
DO 360 J = 1, N
DO 350 I = 1, J
A( J, I ) = SLATM2( M, N, I, J, KL, KU, IDIST, ISEED,
$ D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE )
IF( I.NE.J )
$ A( I, J ) = ZERO
350 CONTINUE
360 CONTINUE
*
ELSE IF( IPACK.EQ.3 ) THEN
*
ISUB = 0
JSUB = 1
DO 380 J = 1, N
DO 370 I = 1, J
ISUB = ISUB + 1
IF( ISUB.GT.LDA ) THEN
ISUB = 1
JSUB = JSUB + 1
END IF
A( ISUB, JSUB ) = SLATM2( M, N, I, J, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
370 CONTINUE
380 CONTINUE
*
ELSE IF( IPACK.EQ.4 ) THEN
*
IF( ISYM.EQ.0 ) THEN
DO 400 J = 1, N
DO 390 I = 1, J
*
* Compute K = location of (I,J) entry in packed array
*
IF( I.EQ.1 ) THEN
K = J
ELSE
K = N*( N+1 ) / 2 - ( N-I+1 )*( N-I+2 ) / 2 +
$ J - I + 1
END IF
*
* Convert K to (ISUB,JSUB) location
*
JSUB = ( K-1 ) / LDA + 1
ISUB = K - LDA*( JSUB-1 )
*
A( ISUB, JSUB ) = SLATM2( M, N, I, J, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL, DR,
$ IPVTNG, IWORK, SPARSE )
390 CONTINUE
400 CONTINUE
ELSE
ISUB = 0
JSUB = 1
DO 420 J = 1, N
DO 410 I = J, M
ISUB = ISUB + 1
IF( ISUB.GT.LDA ) THEN
ISUB = 1
JSUB = JSUB + 1
END IF
A( ISUB, JSUB ) = SLATM2( M, N, I, J, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL, DR,
$ IPVTNG, IWORK, SPARSE )
410 CONTINUE
420 CONTINUE
END IF
*
ELSE IF( IPACK.EQ.5 ) THEN
*
DO 440 J = 1, N
DO 430 I = J - KUU, J
IF( I.LT.1 ) THEN
A( J-I+1, I+N ) = ZERO
ELSE
A( J-I+1, I ) = SLATM2( M, N, I, J, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
END IF
430 CONTINUE
440 CONTINUE
*
ELSE IF( IPACK.EQ.6 ) THEN
*
DO 460 J = 1, N
DO 450 I = J - KUU, J
A( I-J+KUU+1, J ) = SLATM2( M, N, I, J, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
450 CONTINUE
460 CONTINUE
*
ELSE IF( IPACK.EQ.7 ) THEN
*
IF( ISYM.EQ.0 ) THEN
DO 480 J = 1, N
DO 470 I = J - KUU, J
A( I-J+KUU+1, J ) = SLATM2( M, N, I, J, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL,
$ DR, IPVTNG, IWORK, SPARSE )
IF( I.LT.1 )
$ A( J-I+1+KUU, I+N ) = ZERO
IF( I.GE.1 .AND. I.NE.J )
$ A( J-I+1+KUU, I ) = A( I-J+KUU+1, J )
470 CONTINUE
480 CONTINUE
ELSE IF( ISYM.EQ.1 ) THEN
DO 500 J = 1, N
DO 490 I = J - KUU, J + KLL
A( I-J+KUU+1, J ) = SLATM2( M, N, I, J, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL,
$ DR, IPVTNG, IWORK, SPARSE )
490 CONTINUE
500 CONTINUE
END IF
*
END IF
*
END IF
*
* 5) Scaling the norm
*
IF( IPACK.EQ.0 ) THEN
ONORM = SLANGE( 'M', M, N, A, LDA, TEMPA )
ELSE IF( IPACK.EQ.1 ) THEN
ONORM = SLANSY( 'M', 'U', N, A, LDA, TEMPA )
ELSE IF( IPACK.EQ.2 ) THEN
ONORM = SLANSY( 'M', 'L', N, A, LDA, TEMPA )
ELSE IF( IPACK.EQ.3 ) THEN
ONORM = SLANSP( 'M', 'U', N, A, TEMPA )
ELSE IF( IPACK.EQ.4 ) THEN
ONORM = SLANSP( 'M', 'L', N, A, TEMPA )
ELSE IF( IPACK.EQ.5 ) THEN
ONORM = SLANSB( 'M', 'L', N, KLL, A, LDA, TEMPA )
ELSE IF( IPACK.EQ.6 ) THEN
ONORM = SLANSB( 'M', 'U', N, KUU, A, LDA, TEMPA )
ELSE IF( IPACK.EQ.7 ) THEN
ONORM = SLANGB( 'M', N, KLL, KUU, A, LDA, TEMPA )
END IF
*
IF( ANORM.GE.ZERO ) THEN
*
IF( ANORM.GT.ZERO .AND. ONORM.EQ.ZERO ) THEN
*
* Desired scaling impossible
*
INFO = 5
RETURN
*
ELSE IF( ( ANORM.GT.ONE .AND. ONORM.LT.ONE ) .OR.
$ ( ANORM.LT.ONE .AND. ONORM.GT.ONE ) ) THEN
*
* Scale carefully to avoid over / underflow
*
IF( IPACK.LE.2 ) THEN
DO 510 J = 1, N
CALL SSCAL( M, ONE / ONORM, A( 1, J ), 1 )
CALL SSCAL( M, ANORM, A( 1, J ), 1 )
510 CONTINUE
*
ELSE IF( IPACK.EQ.3 .OR. IPACK.EQ.4 ) THEN
*
CALL SSCAL( N*( N+1 ) / 2, ONE / ONORM, A, 1 )
CALL SSCAL( N*( N+1 ) / 2, ANORM, A, 1 )
*
ELSE IF( IPACK.GE.5 ) THEN
*
DO 520 J = 1, N
CALL SSCAL( KLL+KUU+1, ONE / ONORM, A( 1, J ), 1 )
CALL SSCAL( KLL+KUU+1, ANORM, A( 1, J ), 1 )
520 CONTINUE
*
END IF
*
ELSE
*
* Scale straightforwardly
*
IF( IPACK.LE.2 ) THEN
DO 530 J = 1, N
CALL SSCAL( M, ANORM / ONORM, A( 1, J ), 1 )
530 CONTINUE
*
ELSE IF( IPACK.EQ.3 .OR. IPACK.EQ.4 ) THEN
*
CALL SSCAL( N*( N+1 ) / 2, ANORM / ONORM, A, 1 )
*
ELSE IF( IPACK.GE.5 ) THEN
*
DO 540 J = 1, N
CALL SSCAL( KLL+KUU+1, ANORM / ONORM, A( 1, J ), 1 )
540 CONTINUE
END IF
*
END IF
*
END IF
*
* End of SLATMR
*
END
SUBROUTINE SLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX,
$ KL, KU, PACK, A, LDA, WORK, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIST, PACK, SYM
INTEGER INFO, KL, KU, LDA, M, MODE, N
REAL COND, DMAX
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
REAL A( LDA, * ), D( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* SLATMS generates random matrices with specified singular values
* (or symmetric/hermitian with specified eigenvalues)
* for testing LAPACK programs.
*
* SLATMS operates by applying the following sequence of
* operations:
*
* Set the diagonal to D, where D may be input or
* computed according to MODE, COND, DMAX, and SYM
* as described below.
*
* Generate a matrix with the appropriate band structure, by one
* of two methods:
*
* Method A:
* Generate a dense M x N matrix by multiplying D on the left
* and the right by random unitary matrices, then:
*
* Reduce the bandwidth according to KL and KU, using
* Householder transformations.
*
* Method B:
* Convert the bandwidth-0 (i.e., diagonal) matrix to a
* bandwidth-1 matrix using Givens rotations, "chasing"
* out-of-band elements back, much as in QR; then
* convert the bandwidth-1 to a bandwidth-2 matrix, etc.
* Note that for reasonably small bandwidths (relative to
* M and N) this requires less storage, as a dense matrix
* is not generated. Also, for symmetric matrices, only
* one triangle is generated.
*
* Method A is chosen if the bandwidth is a large fraction of the
* order of the matrix, and LDA is at least M (so a dense
* matrix can be stored.) Method B is chosen if the bandwidth
* is small (< 1/2 N for symmetric, < .3 N+M for
* non-symmetric), or LDA is less than M and not less than the
* bandwidth.
*
* Pack the matrix if desired. Options specified by PACK are:
* no packing
* zero out upper half (if symmetric)
* zero out lower half (if symmetric)
* store the upper half columnwise (if symmetric or upper
* triangular)
* store the lower half columnwise (if symmetric or lower
* triangular)
* store the lower triangle in banded format (if symmetric
* or lower triangular)
* store the upper triangle in banded format (if symmetric
* or upper triangular)
* store the entire matrix in banded format
* If Method B is chosen, and band format is specified, then the
* matrix will be generated in the band format, so no repacking
* will be necessary.
*
* Arguments
* =========
*
* M - INTEGER
* The number of rows of A. Not modified.
*
* N - INTEGER
* The number of columns of A. Not modified.
*
* DIST - CHARACTER*1
* On entry, DIST specifies the type of distribution to be used
* to generate the random eigen-/singular values.
* 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform )
* 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric )
* 'N' => NORMAL( 0, 1 ) ( 'N' for normal )
* Not modified.
*
* ISEED - INTEGER array, dimension ( 4 )
* On entry ISEED specifies the seed of the random number
* generator. They should lie between 0 and 4095 inclusive,
* and ISEED(4) should be odd. The random number generator
* uses a linear congruential sequence limited to small
* integers, and so should produce machine independent
* random numbers. The values of ISEED are changed on
* exit, and can be used in the next call to SLATMS
* to continue the same random number sequence.
* Changed on exit.
*
* SYM - CHARACTER*1
* If SYM='S' or 'H', the generated matrix is symmetric, with
* eigenvalues specified by D, COND, MODE, and DMAX; they
* may be positive, negative, or zero.
* If SYM='P', the generated matrix is symmetric, with
* eigenvalues (= singular values) specified by D, COND,
* MODE, and DMAX; they will not be negative.
* If SYM='N', the generated matrix is nonsymmetric, with
* singular values specified by D, COND, MODE, and DMAX;
* they will not be negative.
* Not modified.
*
* D - REAL array, dimension ( MIN( M , N ) )
* This array is used to specify the singular values or
* eigenvalues of A (see SYM, above.) If MODE=0, then D is
* assumed to contain the singular/eigenvalues, otherwise
* they will be computed according to MODE, COND, and DMAX,
* and placed in D.
* Modified if MODE is nonzero.
*
* MODE - INTEGER
* On entry this describes how the singular/eigenvalues are to
* be specified:
* MODE = 0 means use D as input
* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND
* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND
* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1))
* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
* MODE = 5 sets D to random numbers in the range
* ( 1/COND , 1 ) such that their logarithms
* are uniformly distributed.
* MODE = 6 set D to random numbers from same distribution
* as the rest of the matrix.
* MODE < 0 has the same meaning as ABS(MODE), except that
* the order of the elements of D is reversed.
* Thus if MODE is positive, D has entries ranging from
* 1 to 1/COND, if negative, from 1/COND to 1,
* If SYM='S' or 'H', and MODE is neither 0, 6, nor -6, then
* the elements of D will also be multiplied by a random
* sign (i.e., +1 or -1.)
* Not modified.
*
* COND - REAL
* On entry, this is used as described under MODE above.
* If used, it must be >= 1. Not modified.
*
* DMAX - REAL
* If MODE is neither -6, 0 nor 6, the contents of D, as
* computed according to MODE and COND, will be scaled by
* DMAX / max(abs(D(i))); thus, the maximum absolute eigen- or
* singular value (which is to say the norm) will be abs(DMAX).
* Note that DMAX need not be positive: if DMAX is negative
* (or zero), D will be scaled by a negative number (or zero).
* Not modified.
*
* KL - INTEGER
* This specifies the lower bandwidth of the matrix. For
* example, KL=0 implies upper triangular, KL=1 implies upper
* Hessenberg, and KL being at least M-1 means that the matrix
* has full lower bandwidth. KL must equal KU if the matrix
* is symmetric.
* Not modified.
*
* KU - INTEGER
* This specifies the upper bandwidth of the matrix. For
* example, KU=0 implies lower triangular, KU=1 implies lower
* Hessenberg, and KU being at least N-1 means that the matrix
* has full upper bandwidth. KL must equal KU if the matrix
* is symmetric.
* Not modified.
*
* PACK - CHARACTER*1
* This specifies packing of matrix as follows:
* 'N' => no packing
* 'U' => zero out all subdiagonal entries (if symmetric)
* 'L' => zero out all superdiagonal entries (if symmetric)
* 'C' => store the upper triangle columnwise
* (only if the matrix is symmetric or upper triangular)
* 'R' => store the lower triangle columnwise
* (only if the matrix is symmetric or lower triangular)
* 'B' => store the lower triangle in band storage scheme
* (only if matrix symmetric or lower triangular)
* 'Q' => store the upper triangle in band storage scheme
* (only if matrix symmetric or upper triangular)
* 'Z' => store the entire matrix in band storage scheme
* (pivoting can be provided for by using this
* option to store A in the trailing rows of
* the allocated storage)
*
* Using these options, the various LAPACK packed and banded
* storage schemes can be obtained:
* GB - use 'Z'
* PB, SB or TB - use 'B' or 'Q'
* PP, SP or TP - use 'C' or 'R'
*
* If two calls to SLATMS differ only in the PACK parameter,
* they will generate mathematically equivalent matrices.
* Not modified.
*
* A - REAL array, dimension ( LDA, N )
* On exit A is the desired test matrix. A is first generated
* in full (unpacked) form, and then packed, if so specified
* by PACK. Thus, the first M elements of the first N
* columns will always be modified. If PACK specifies a
* packed or banded storage scheme, all LDA elements of the
* first N columns will be modified; the elements of the
* array which do not correspond to elements of the generated
* matrix are set to zero.
* Modified.
*
* LDA - INTEGER
* LDA specifies the first dimension of A as declared in the
* calling program. If PACK='N', 'U', 'L', 'C', or 'R', then
* LDA must be at least M. If PACK='B' or 'Q', then LDA must
* be at least MIN( KL, M-1) (which is equal to MIN(KU,N-1)).
* If PACK='Z', LDA must be large enough to hold the packed
* array: MIN( KU, N-1) + MIN( KL, M-1) + 1.
* Not modified.
*
* WORK - REAL array, dimension ( 3*MAX( N , M ) )
* Workspace.
* Modified.
*
* INFO - INTEGER
* Error code. On exit, INFO will be set to one of the
* following values:
* 0 => normal return
* -1 => M negative or unequal to N and SYM='S', 'H', or 'P'
* -2 => N negative
* -3 => DIST illegal string
* -5 => SYM illegal string
* -7 => MODE not in range -6 to 6
* -8 => COND less than 1.0, and MODE neither -6, 0 nor 6
* -10 => KL negative
* -11 => KU negative, or SYM='S' or 'H' and KU not equal to KL
* -12 => PACK illegal string, or PACK='U' or 'L', and SYM='N';
* or PACK='C' or 'Q' and SYM='N' and KL is not zero;
* or PACK='R' or 'B' and SYM='N' and KU is not zero;
* or PACK='U', 'L', 'C', 'R', 'B', or 'Q', and M is not
* N.
* -14 => LDA is less than M, or PACK='Z' and LDA is less than
* MIN(KU,N-1) + MIN(KL,M-1) + 1.
* 1 => Error return from SLATM1
* 2 => Cannot scale to DMAX (max. sing. value is 0)
* 3 => Error return from SLAGGE or SLAGSY
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
REAL ONE
PARAMETER ( ONE = 1.0E0 )
REAL TWOPI
PARAMETER ( TWOPI = 6.2831853071795864769252867663E+0 )
* ..
* .. Local Scalars ..
LOGICAL GIVENS, ILEXTR, ILTEMP, TOPDWN
INTEGER I, IC, ICOL, IDIST, IENDCH, IINFO, IL, ILDA,
$ IOFFG, IOFFST, IPACK, IPACKG, IR, IR1, IR2,
$ IROW, IRSIGN, ISKEW, ISYM, ISYMPK, J, JC, JCH,
$ JKL, JKU, JR, K, LLB, MINLDA, MNMIN, MR, NC,
$ UUB
REAL ALPHA, ANGLE, C, DUMMY, EXTRA, S, TEMP
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLARND
EXTERNAL LSAME, SLARND
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLAGGE, SLAGSY, SLAROT, SLARTG, SLATM1,
$ SLASET, SSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, COS, MAX, MIN, MOD, REAL, SIN
* ..
* .. Executable Statements ..
*
* 1) Decode and Test the input parameters.
* Initialize flags & seed.
*
INFO = 0
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
* Decode DIST
*
IF( LSAME( DIST, 'U' ) ) THEN
IDIST = 1
ELSE IF( LSAME( DIST, 'S' ) ) THEN
IDIST = 2
ELSE IF( LSAME( DIST, 'N' ) ) THEN
IDIST = 3
ELSE
IDIST = -1
END IF
*
* Decode SYM
*
IF( LSAME( SYM, 'N' ) ) THEN
ISYM = 1
IRSIGN = 0
ELSE IF( LSAME( SYM, 'P' ) ) THEN
ISYM = 2
IRSIGN = 0
ELSE IF( LSAME( SYM, 'S' ) ) THEN
ISYM = 2
IRSIGN = 1
ELSE IF( LSAME( SYM, 'H' ) ) THEN
ISYM = 2
IRSIGN = 1
ELSE
ISYM = -1
END IF
*
* Decode PACK
*
ISYMPK = 0
IF( LSAME( PACK, 'N' ) ) THEN
IPACK = 0
ELSE IF( LSAME( PACK, 'U' ) ) THEN
IPACK = 1
ISYMPK = 1
ELSE IF( LSAME( PACK, 'L' ) ) THEN
IPACK = 2
ISYMPK = 1
ELSE IF( LSAME( PACK, 'C' ) ) THEN
IPACK = 3
ISYMPK = 2
ELSE IF( LSAME( PACK, 'R' ) ) THEN
IPACK = 4
ISYMPK = 3
ELSE IF( LSAME( PACK, 'B' ) ) THEN
IPACK = 5
ISYMPK = 3
ELSE IF( LSAME( PACK, 'Q' ) ) THEN
IPACK = 6
ISYMPK = 2
ELSE IF( LSAME( PACK, 'Z' ) ) THEN
IPACK = 7
ELSE
IPACK = -1
END IF
*
* Set certain internal parameters
*
MNMIN = MIN( M, N )
LLB = MIN( KL, M-1 )
UUB = MIN( KU, N-1 )
MR = MIN( M, N+LLB )
NC = MIN( N, M+UUB )
*
IF( IPACK.EQ.5 .OR. IPACK.EQ.6 ) THEN
MINLDA = UUB + 1
ELSE IF( IPACK.EQ.7 ) THEN
MINLDA = LLB + UUB + 1
ELSE
MINLDA = M
END IF
*
* Use Givens rotation method if bandwidth small enough,
* or if LDA is too small to store the matrix unpacked.
*
GIVENS = .FALSE.
IF( ISYM.EQ.1 ) THEN
IF( REAL( LLB+UUB ).LT.0.3*REAL( MAX( 1, MR+NC ) ) )
$ GIVENS = .TRUE.
ELSE
IF( 2*LLB.LT.M )
$ GIVENS = .TRUE.
END IF
IF( LDA.LT.M .AND. LDA.GE.MINLDA )
$ GIVENS = .TRUE.
*
* Set INFO if an error
*
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( M.NE.N .AND. ISYM.NE.1 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( IDIST.EQ.-1 ) THEN
INFO = -3
ELSE IF( ISYM.EQ.-1 ) THEN
INFO = -5
ELSE IF( ABS( MODE ).GT.6 ) THEN
INFO = -7
ELSE IF( ( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) .AND. COND.LT.ONE )
$ THEN
INFO = -8
ELSE IF( KL.LT.0 ) THEN
INFO = -10
ELSE IF( KU.LT.0 .OR. ( ISYM.NE.1 .AND. KL.NE.KU ) ) THEN
INFO = -11
ELSE IF( IPACK.EQ.-1 .OR. ( ISYMPK.EQ.1 .AND. ISYM.EQ.1 ) .OR.
$ ( ISYMPK.EQ.2 .AND. ISYM.EQ.1 .AND. KL.GT.0 ) .OR.
$ ( ISYMPK.EQ.3 .AND. ISYM.EQ.1 .AND. KU.GT.0 ) .OR.
$ ( ISYMPK.NE.0 .AND. M.NE.N ) ) THEN
INFO = -12
ELSE IF( LDA.LT.MAX( 1, MINLDA ) ) THEN
INFO = -14
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLATMS', -INFO )
RETURN
END IF
*
* Initialize random number generator
*
DO 10 I = 1, 4
ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 )
10 CONTINUE
*
IF( MOD( ISEED( 4 ), 2 ).NE.1 )
$ ISEED( 4 ) = ISEED( 4 ) + 1
*
* 2) Set up D if indicated.
*
* Compute D according to COND and MODE
*
CALL SLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, MNMIN, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 1
RETURN
END IF
*
* Choose Top-Down if D is (apparently) increasing,
* Bottom-Up if D is (apparently) decreasing.
*
IF( ABS( D( 1 ) ).LE.ABS( D( MNMIN ) ) ) THEN
TOPDWN = .TRUE.
ELSE
TOPDWN = .FALSE.
END IF
*
IF( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) THEN
*
* Scale by DMAX
*
TEMP = ABS( D( 1 ) )
DO 20 I = 2, MNMIN
TEMP = MAX( TEMP, ABS( D( I ) ) )
20 CONTINUE
*
IF( TEMP.GT.ZERO ) THEN
ALPHA = DMAX / TEMP
ELSE
INFO = 2
RETURN
END IF
*
CALL SSCAL( MNMIN, ALPHA, D, 1 )
*
END IF
*
* 3) Generate Banded Matrix using Givens rotations.
* Also the special case of UUB=LLB=0
*
* Compute Addressing constants to cover all
* storage formats. Whether GE, SY, GB, or SB,
* upper or lower triangle or both,
* the (i,j)-th element is in
* A( i - ISKEW*j + IOFFST, j )
*
IF( IPACK.GT.4 ) THEN
ILDA = LDA - 1
ISKEW = 1
IF( IPACK.GT.5 ) THEN
IOFFST = UUB + 1
ELSE
IOFFST = 1
END IF
ELSE
ILDA = LDA
ISKEW = 0
IOFFST = 0
END IF
*
* IPACKG is the format that the matrix is generated in. If this is
* different from IPACK, then the matrix must be repacked at the
* end. It also signals how to compute the norm, for scaling.
*
IPACKG = 0
CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
*
* Diagonal Matrix -- We are done, unless it
* is to be stored SP/PP/TP (PACK='R' or 'C')
*
IF( LLB.EQ.0 .AND. UUB.EQ.0 ) THEN
CALL SCOPY( MNMIN, D, 1, A( 1-ISKEW+IOFFST, 1 ), ILDA+1 )
IF( IPACK.LE.2 .OR. IPACK.GE.5 )
$ IPACKG = IPACK
*
ELSE IF( GIVENS ) THEN
*
* Check whether to use Givens rotations,
* Householder transformations, or nothing.
*
IF( ISYM.EQ.1 ) THEN
*
* Non-symmetric -- A = U D V
*
IF( IPACK.GT.4 ) THEN
IPACKG = IPACK
ELSE
IPACKG = 0
END IF
*
CALL SCOPY( MNMIN, D, 1, A( 1-ISKEW+IOFFST, 1 ), ILDA+1 )
*
IF( TOPDWN ) THEN
JKL = 0
DO 50 JKU = 1, UUB
*
* Transform from bandwidth JKL, JKU-1 to JKL, JKU
*
* Last row actually rotated is M
* Last column actually rotated is MIN( M+JKU, N )
*
DO 40 JR = 1, MIN( M+JKU, N ) + JKL - 1
EXTRA = ZERO
ANGLE = TWOPI*SLARND( 1, ISEED )
C = COS( ANGLE )
S = SIN( ANGLE )
ICOL = MAX( 1, JR-JKL )
IF( JR.LT.M ) THEN
IL = MIN( N, JR+JKU ) + 1 - ICOL
CALL SLAROT( .TRUE., JR.GT.JKL, .FALSE., IL, C,
$ S, A( JR-ISKEW*ICOL+IOFFST, ICOL ),
$ ILDA, EXTRA, DUMMY )
END IF
*
* Chase "EXTRA" back up
*
IR = JR
IC = ICOL
DO 30 JCH = JR - JKL, 1, -JKL - JKU
IF( IR.LT.M ) THEN
CALL SLARTG( A( IR+1-ISKEW*( IC+1 )+IOFFST,
$ IC+1 ), EXTRA, C, S, DUMMY )
END IF
IROW = MAX( 1, JCH-JKU )
IL = IR + 2 - IROW
TEMP = ZERO
ILTEMP = JCH.GT.JKU
CALL SLAROT( .FALSE., ILTEMP, .TRUE., IL, C, -S,
$ A( IROW-ISKEW*IC+IOFFST, IC ),
$ ILDA, TEMP, EXTRA )
IF( ILTEMP ) THEN
CALL SLARTG( A( IROW+1-ISKEW*( IC+1 )+IOFFST,
$ IC+1 ), TEMP, C, S, DUMMY )
ICOL = MAX( 1, JCH-JKU-JKL )
IL = IC + 2 - ICOL
EXTRA = ZERO
CALL SLAROT( .TRUE., JCH.GT.JKU+JKL, .TRUE.,
$ IL, C, -S, A( IROW-ISKEW*ICOL+
$ IOFFST, ICOL ), ILDA, EXTRA,
$ TEMP )
IC = ICOL
IR = IROW
END IF
30 CONTINUE
40 CONTINUE
50 CONTINUE
*
JKU = UUB
DO 80 JKL = 1, LLB
*
* Transform from bandwidth JKL-1, JKU to JKL, JKU
*
DO 70 JC = 1, MIN( N+JKL, M ) + JKU - 1
EXTRA = ZERO
ANGLE = TWOPI*SLARND( 1, ISEED )
C = COS( ANGLE )
S = SIN( ANGLE )
IROW = MAX( 1, JC-JKU )
IF( JC.LT.N ) THEN
IL = MIN( M, JC+JKL ) + 1 - IROW
CALL SLAROT( .FALSE., JC.GT.JKU, .FALSE., IL, C,
$ S, A( IROW-ISKEW*JC+IOFFST, JC ),
$ ILDA, EXTRA, DUMMY )
END IF
*
* Chase "EXTRA" back up
*
IC = JC
IR = IROW
DO 60 JCH = JC - JKU, 1, -JKL - JKU
IF( IC.LT.N ) THEN
CALL SLARTG( A( IR+1-ISKEW*( IC+1 )+IOFFST,
$ IC+1 ), EXTRA, C, S, DUMMY )
END IF
ICOL = MAX( 1, JCH-JKL )
IL = IC + 2 - ICOL
TEMP = ZERO
ILTEMP = JCH.GT.JKL
CALL SLAROT( .TRUE., ILTEMP, .TRUE., IL, C, -S,
$ A( IR-ISKEW*ICOL+IOFFST, ICOL ),
$ ILDA, TEMP, EXTRA )
IF( ILTEMP ) THEN
CALL SLARTG( A( IR+1-ISKEW*( ICOL+1 )+IOFFST,
$ ICOL+1 ), TEMP, C, S, DUMMY )
IROW = MAX( 1, JCH-JKL-JKU )
IL = IR + 2 - IROW
EXTRA = ZERO
CALL SLAROT( .FALSE., JCH.GT.JKL+JKU, .TRUE.,
$ IL, C, -S, A( IROW-ISKEW*ICOL+
$ IOFFST, ICOL ), ILDA, EXTRA,
$ TEMP )
IC = ICOL
IR = IROW
END IF
60 CONTINUE
70 CONTINUE
80 CONTINUE
*
ELSE
*
* Bottom-Up -- Start at the bottom right.
*
JKL = 0
DO 110 JKU = 1, UUB
*
* Transform from bandwidth JKL, JKU-1 to JKL, JKU
*
* First row actually rotated is M
* First column actually rotated is MIN( M+JKU, N )
*
IENDCH = MIN( M, N+JKL ) - 1
DO 100 JC = MIN( M+JKU, N ) - 1, 1 - JKL, -1
EXTRA = ZERO
ANGLE = TWOPI*SLARND( 1, ISEED )
C = COS( ANGLE )
S = SIN( ANGLE )
IROW = MAX( 1, JC-JKU+1 )
IF( JC.GT.0 ) THEN
IL = MIN( M, JC+JKL+1 ) + 1 - IROW
CALL SLAROT( .FALSE., .FALSE., JC+JKL.LT.M, IL,
$ C, S, A( IROW-ISKEW*JC+IOFFST,
$ JC ), ILDA, DUMMY, EXTRA )
END IF
*
* Chase "EXTRA" back down
*
IC = JC
DO 90 JCH = JC + JKL, IENDCH, JKL + JKU
ILEXTR = IC.GT.0
IF( ILEXTR ) THEN
CALL SLARTG( A( JCH-ISKEW*IC+IOFFST, IC ),
$ EXTRA, C, S, DUMMY )
END IF
IC = MAX( 1, IC )
ICOL = MIN( N-1, JCH+JKU )
ILTEMP = JCH + JKU.LT.N
TEMP = ZERO
CALL SLAROT( .TRUE., ILEXTR, ILTEMP, ICOL+2-IC,
$ C, S, A( JCH-ISKEW*IC+IOFFST, IC ),
$ ILDA, EXTRA, TEMP )
IF( ILTEMP ) THEN
CALL SLARTG( A( JCH-ISKEW*ICOL+IOFFST,
$ ICOL ), TEMP, C, S, DUMMY )
IL = MIN( IENDCH, JCH+JKL+JKU ) + 2 - JCH
EXTRA = ZERO
CALL SLAROT( .FALSE., .TRUE.,
$ JCH+JKL+JKU.LE.IENDCH, IL, C, S,
$ A( JCH-ISKEW*ICOL+IOFFST,
$ ICOL ), ILDA, TEMP, EXTRA )
IC = ICOL
END IF
90 CONTINUE
100 CONTINUE
110 CONTINUE
*
JKU = UUB
DO 140 JKL = 1, LLB
*
* Transform from bandwidth JKL-1, JKU to JKL, JKU
*
* First row actually rotated is MIN( N+JKL, M )
* First column actually rotated is N
*
IENDCH = MIN( N, M+JKU ) - 1
DO 130 JR = MIN( N+JKL, M ) - 1, 1 - JKU, -1
EXTRA = ZERO
ANGLE = TWOPI*SLARND( 1, ISEED )
C = COS( ANGLE )
S = SIN( ANGLE )
ICOL = MAX( 1, JR-JKL+1 )
IF( JR.GT.0 ) THEN
IL = MIN( N, JR+JKU+1 ) + 1 - ICOL
CALL SLAROT( .TRUE., .FALSE., JR+JKU.LT.N, IL,
$ C, S, A( JR-ISKEW*ICOL+IOFFST,
$ ICOL ), ILDA, DUMMY, EXTRA )
END IF
*
* Chase "EXTRA" back down
*
IR = JR
DO 120 JCH = JR + JKU, IENDCH, JKL + JKU
ILEXTR = IR.GT.0
IF( ILEXTR ) THEN
CALL SLARTG( A( IR-ISKEW*JCH+IOFFST, JCH ),
$ EXTRA, C, S, DUMMY )
END IF
IR = MAX( 1, IR )
IROW = MIN( M-1, JCH+JKL )
ILTEMP = JCH + JKL.LT.M
TEMP = ZERO
CALL SLAROT( .FALSE., ILEXTR, ILTEMP, IROW+2-IR,
$ C, S, A( IR-ISKEW*JCH+IOFFST,
$ JCH ), ILDA, EXTRA, TEMP )
IF( ILTEMP ) THEN
CALL SLARTG( A( IROW-ISKEW*JCH+IOFFST, JCH ),
$ TEMP, C, S, DUMMY )
IL = MIN( IENDCH, JCH+JKL+JKU ) + 2 - JCH
EXTRA = ZERO
CALL SLAROT( .TRUE., .TRUE.,
$ JCH+JKL+JKU.LE.IENDCH, IL, C, S,
$ A( IROW-ISKEW*JCH+IOFFST, JCH ),
$ ILDA, TEMP, EXTRA )
IR = IROW
END IF
120 CONTINUE
130 CONTINUE
140 CONTINUE
END IF
*
ELSE
*
* Symmetric -- A = U D U'
*
IPACKG = IPACK
IOFFG = IOFFST
*
IF( TOPDWN ) THEN
*
* Top-Down -- Generate Upper triangle only
*
IF( IPACK.GE.5 ) THEN
IPACKG = 6
IOFFG = UUB + 1
ELSE
IPACKG = 1
END IF
CALL SCOPY( MNMIN, D, 1, A( 1-ISKEW+IOFFG, 1 ), ILDA+1 )
*
DO 170 K = 1, UUB
DO 160 JC = 1, N - 1
IROW = MAX( 1, JC-K )
IL = MIN( JC+1, K+2 )
EXTRA = ZERO
TEMP = A( JC-ISKEW*( JC+1 )+IOFFG, JC+1 )
ANGLE = TWOPI*SLARND( 1, ISEED )
C = COS( ANGLE )
S = SIN( ANGLE )
CALL SLAROT( .FALSE., JC.GT.K, .TRUE., IL, C, S,
$ A( IROW-ISKEW*JC+IOFFG, JC ), ILDA,
$ EXTRA, TEMP )
CALL SLAROT( .TRUE., .TRUE., .FALSE.,
$ MIN( K, N-JC )+1, C, S,
$ A( ( 1-ISKEW )*JC+IOFFG, JC ), ILDA,
$ TEMP, DUMMY )
*
* Chase EXTRA back up the matrix
*
ICOL = JC
DO 150 JCH = JC - K, 1, -K
CALL SLARTG( A( JCH+1-ISKEW*( ICOL+1 )+IOFFG,
$ ICOL+1 ), EXTRA, C, S, DUMMY )
TEMP = A( JCH-ISKEW*( JCH+1 )+IOFFG, JCH+1 )
CALL SLAROT( .TRUE., .TRUE., .TRUE., K+2, C, -S,
$ A( ( 1-ISKEW )*JCH+IOFFG, JCH ),
$ ILDA, TEMP, EXTRA )
IROW = MAX( 1, JCH-K )
IL = MIN( JCH+1, K+2 )
EXTRA = ZERO
CALL SLAROT( .FALSE., JCH.GT.K, .TRUE., IL, C,
$ -S, A( IROW-ISKEW*JCH+IOFFG, JCH ),
$ ILDA, EXTRA, TEMP )
ICOL = JCH
150 CONTINUE
160 CONTINUE
170 CONTINUE
*
* If we need lower triangle, copy from upper. Note that
* the order of copying is chosen to work for 'q' -> 'b'
*
IF( IPACK.NE.IPACKG .AND. IPACK.NE.3 ) THEN
DO 190 JC = 1, N
IROW = IOFFST - ISKEW*JC
DO 180 JR = JC, MIN( N, JC+UUB )
A( JR+IROW, JC ) = A( JC-ISKEW*JR+IOFFG, JR )
180 CONTINUE
190 CONTINUE
IF( IPACK.EQ.5 ) THEN
DO 210 JC = N - UUB + 1, N
DO 200 JR = N + 2 - JC, UUB + 1
A( JR, JC ) = ZERO
200 CONTINUE
210 CONTINUE
END IF
IF( IPACKG.EQ.6 ) THEN
IPACKG = IPACK
ELSE
IPACKG = 0
END IF
END IF
ELSE
*
* Bottom-Up -- Generate Lower triangle only
*
IF( IPACK.GE.5 ) THEN
IPACKG = 5
IF( IPACK.EQ.6 )
$ IOFFG = 1
ELSE
IPACKG = 2
END IF
CALL SCOPY( MNMIN, D, 1, A( 1-ISKEW+IOFFG, 1 ), ILDA+1 )
*
DO 240 K = 1, UUB
DO 230 JC = N - 1, 1, -1
IL = MIN( N+1-JC, K+2 )
EXTRA = ZERO
TEMP = A( 1+( 1-ISKEW )*JC+IOFFG, JC )
ANGLE = TWOPI*SLARND( 1, ISEED )
C = COS( ANGLE )
S = -SIN( ANGLE )
CALL SLAROT( .FALSE., .TRUE., N-JC.GT.K, IL, C, S,
$ A( ( 1-ISKEW )*JC+IOFFG, JC ), ILDA,
$ TEMP, EXTRA )
ICOL = MAX( 1, JC-K+1 )
CALL SLAROT( .TRUE., .FALSE., .TRUE., JC+2-ICOL, C,
$ S, A( JC-ISKEW*ICOL+IOFFG, ICOL ),
$ ILDA, DUMMY, TEMP )
*
* Chase EXTRA back down the matrix
*
ICOL = JC
DO 220 JCH = JC + K, N - 1, K
CALL SLARTG( A( JCH-ISKEW*ICOL+IOFFG, ICOL ),
$ EXTRA, C, S, DUMMY )
TEMP = A( 1+( 1-ISKEW )*JCH+IOFFG, JCH )
CALL SLAROT( .TRUE., .TRUE., .TRUE., K+2, C, S,
$ A( JCH-ISKEW*ICOL+IOFFG, ICOL ),
$ ILDA, EXTRA, TEMP )
IL = MIN( N+1-JCH, K+2 )
EXTRA = ZERO
CALL SLAROT( .FALSE., .TRUE., N-JCH.GT.K, IL, C,
$ S, A( ( 1-ISKEW )*JCH+IOFFG, JCH ),
$ ILDA, TEMP, EXTRA )
ICOL = JCH
220 CONTINUE
230 CONTINUE
240 CONTINUE
*
* If we need upper triangle, copy from lower. Note that
* the order of copying is chosen to work for 'b' -> 'q'
*
IF( IPACK.NE.IPACKG .AND. IPACK.NE.4 ) THEN
DO 260 JC = N, 1, -1
IROW = IOFFST - ISKEW*JC
DO 250 JR = JC, MAX( 1, JC-UUB ), -1
A( JR+IROW, JC ) = A( JC-ISKEW*JR+IOFFG, JR )
250 CONTINUE
260 CONTINUE
IF( IPACK.EQ.6 ) THEN
DO 280 JC = 1, UUB
DO 270 JR = 1, UUB + 1 - JC
A( JR, JC ) = ZERO
270 CONTINUE
280 CONTINUE
END IF
IF( IPACKG.EQ.5 ) THEN
IPACKG = IPACK
ELSE
IPACKG = 0
END IF
END IF
END IF
END IF
*
ELSE
*
* 4) Generate Banded Matrix by first
* Rotating by random Unitary matrices,
* then reducing the bandwidth using Householder
* transformations.
*
* Note: we should get here only if LDA .ge. N
*
IF( ISYM.EQ.1 ) THEN
*
* Non-symmetric -- A = U D V
*
CALL SLAGGE( MR, NC, LLB, UUB, D, A, LDA, ISEED, WORK,
$ IINFO )
ELSE
*
* Symmetric -- A = U D U'
*
CALL SLAGSY( M, LLB, D, A, LDA, ISEED, WORK, IINFO )
*
END IF
IF( IINFO.NE.0 ) THEN
INFO = 3
RETURN
END IF
END IF
*
* 5) Pack the matrix
*
IF( IPACK.NE.IPACKG ) THEN
IF( IPACK.EQ.1 ) THEN
*
* 'U' -- Upper triangular, not packed
*
DO 300 J = 1, M
DO 290 I = J + 1, M
A( I, J ) = ZERO
290 CONTINUE
300 CONTINUE
*
ELSE IF( IPACK.EQ.2 ) THEN
*
* 'L' -- Lower triangular, not packed
*
DO 320 J = 2, M
DO 310 I = 1, J - 1
A( I, J ) = ZERO
310 CONTINUE
320 CONTINUE
*
ELSE IF( IPACK.EQ.3 ) THEN
*
* 'C' -- Upper triangle packed Columnwise.
*
ICOL = 1
IROW = 0
DO 340 J = 1, M
DO 330 I = 1, J
IROW = IROW + 1
IF( IROW.GT.LDA ) THEN
IROW = 1
ICOL = ICOL + 1
END IF
A( IROW, ICOL ) = A( I, J )
330 CONTINUE
340 CONTINUE
*
ELSE IF( IPACK.EQ.4 ) THEN
*
* 'R' -- Lower triangle packed Columnwise.
*
ICOL = 1
IROW = 0
DO 360 J = 1, M
DO 350 I = J, M
IROW = IROW + 1
IF( IROW.GT.LDA ) THEN
IROW = 1
ICOL = ICOL + 1
END IF
A( IROW, ICOL ) = A( I, J )
350 CONTINUE
360 CONTINUE
*
ELSE IF( IPACK.GE.5 ) THEN
*
* 'B' -- The lower triangle is packed as a band matrix.
* 'Q' -- The upper triangle is packed as a band matrix.
* 'Z' -- The whole matrix is packed as a band matrix.
*
IF( IPACK.EQ.5 )
$ UUB = 0
IF( IPACK.EQ.6 )
$ LLB = 0
*
DO 380 J = 1, UUB
DO 370 I = MIN( J+LLB, M ), 1, -1
A( I-J+UUB+1, J ) = A( I, J )
370 CONTINUE
380 CONTINUE
*
DO 400 J = UUB + 2, N
DO 390 I = J - UUB, MIN( J+LLB, M )
A( I-J+UUB+1, J ) = A( I, J )
390 CONTINUE
400 CONTINUE
END IF
*
* If packed, zero out extraneous elements.
*
* Symmetric/Triangular Packed --
* zero out everything after A(IROW,ICOL)
*
IF( IPACK.EQ.3 .OR. IPACK.EQ.4 ) THEN
DO 420 JC = ICOL, M
DO 410 JR = IROW + 1, LDA
A( JR, JC ) = ZERO
410 CONTINUE
IROW = 0
420 CONTINUE
*
ELSE IF( IPACK.GE.5 ) THEN
*
* Packed Band --
* 1st row is now in A( UUB+2-j, j), zero above it
* m-th row is now in A( M+UUB-j,j), zero below it
* last non-zero diagonal is now in A( UUB+LLB+1,j ),
* zero below it, too.
*
IR1 = UUB + LLB + 2
IR2 = UUB + M + 2
DO 450 JC = 1, N
DO 430 JR = 1, UUB + 1 - JC
A( JR, JC ) = ZERO
430 CONTINUE
DO 440 JR = MAX( 1, MIN( IR1, IR2-JC ) ), LDA
A( JR, JC ) = ZERO
440 CONTINUE
450 CONTINUE
END IF
END IF
*
RETURN
*
* End of SLATMS
*
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/blas3/ 0000755 0001750 0001750 00000000000 11734055023 022220 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/blas3/dblat3.in 0000644 0001750 0001750 00000001562 10616163233 023726 0 ustar osallou osallou 'dblat3.out' NAME OF SUMMARY OUTPUT FILE
6 UNIT NUMBER OF SUMMARY FILE
'DBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE
-1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
F LOGICAL FLAG, T TO STOP ON FAILURES.
T LOGICAL FLAG, T TO TEST ERROR EXITS.
16.0 THRESHOLD VALUE OF TEST RATIO
6 NUMBER OF VALUES OF N
0 1 2 3 5 9 VALUES OF N
3 NUMBER OF VALUES OF ALPHA
0.0 1.0 0.7 VALUES OF ALPHA
3 NUMBER OF VALUES OF BETA
0.0 1.0 1.3 VALUES OF BETA
DGEMM T PUT F FOR NO TEST. SAME COLUMNS.
DSYMM T PUT F FOR NO TEST. SAME COLUMNS.
DTRMM T PUT F FOR NO TEST. SAME COLUMNS.
DTRSM T PUT F FOR NO TEST. SAME COLUMNS.
DSYRK T PUT F FOR NO TEST. SAME COLUMNS.
DSYR2K T PUT F FOR NO TEST. SAME COLUMNS.
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/blas3/Makefile_javasrc 0000644 0001750 0001750 00000002634 10616163233 025377 0 ustar osallou osallou .SUFFIXES: .f .java
ROOT=../../..
include $(ROOT)/make.def
tester: $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(BLAS3TEST_IDX) $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
/bin/rm -f `find $(OUTDIR) -name "*.class"`
mkdir -p $(JAVASRC_OUTDIR)
$(JAVAC) -classpath .:$(JAVASRC_OUTDIR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) -d $(JAVASRC_OUTDIR) $(OUTDIR)/$(BLASTEST_PDIR)/*.java
/bin/rm -f $(JAVASRC_OUTDIR)/$(BLASTEST_PDIR)/*.old
$(JAVAB) $(JAVASRC_OUTDIR)/$(BLASTEST_PDIR)/*.class
/bin/rm -f $(BLAS3TEST_JAR)
cd $(JAVASRC_OUTDIR); $(JAR) cvf ../$(BLAS3TEST_JAR) `find . -name "*.class"`
$(JAR) uvf $(BLAS3TEST_JAR) `find org -name "*.class"`
$(ROOT)/$(BLAS3TEST_IDX): dblat3.f
$(MAKE) nojar
$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):
cd $(ROOT)/$(BLAS_DIR); $(MAKE) -f Makefile_javasrc
$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):
cd $(ROOT)/$(UTIL_DIR); $(MAKE)
runtest: tester
$(JAVA) $(JFLAGS) -cp .:$(BLAS3TEST_JAR):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR) $(BLASTEST_PACKAGE).Dblat3 < dblat3.in
verify: $(ROOT)/$(BLAS3TEST_IDX)
cd $(JAVASRC_OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:..:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR) $(VERIFY) $(BLASTEST_PDIR)/*.class
clean:
/bin/rm -rf *.java *.class *.f2j org $(OUTDIR) $(JAVASRC_OUTDIR) $(BLAS3TEST_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/blas3/Makefile 0000644 0001750 0001750 00000002527 10616163233 023667 0 ustar osallou osallou .SUFFIXES: .f .java
ROOT=../../..
include $(ROOT)/make.def
XERBLAFLAGS= -c .:$(ROOT)/$(BLAS_OBJ) -p $(ERR_PACKAGE)
F2JFLAGS=-c .:$(ROOT)/$(BLAS_OBJ) -p $(BLASTEST_PACKAGE) -o $(OUTDIR) $(STATIC)
tester: $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(BLAS3TEST_IDX) $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
/bin/rm -f $(BLAS3TEST_JAR)
cd $(OUTDIR); $(JAR) cvf ../$(BLAS3TEST_JAR) `find . -name "*.class"`
$(JAR) uvf $(BLAS3TEST_JAR) `find org -name "*.class"`
nojar: $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(BLAS3TEST_IDX) $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
$(ROOT)/$(BLAS3TEST_IDX): dblat3.f
$(F2J) $(XERBLAFLAGS) xerbla.f > /dev/null
$(F2J) $(F2JFLAGS) $< > /dev/null
$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):
cd $(ROOT)/$(BLAS_DIR); $(MAKE)
$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):
cd $(ROOT)/$(UTIL_DIR); $(MAKE)
runtest: tester
$(JAVA) $(JFLAGS) -cp .:$(BLAS3TEST_JAR):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR) $(BLASTEST_PACKAGE).Dblat3 < dblat3.in
srctest:
$(MAKE) -f Makefile_javasrc
verify: $(ROOT)/$(BLAS3TEST_IDX)
cd $(OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:..:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR) $(VERIFY) $(BLASTEST_PDIR)/*.class
clean:
/bin/rm -rf *.java *.class *.f2j org $(OUTDIR) $(JAVASRC_OUTDIR) $(BLAS3TEST_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/blas3/dblat3.f 0000644 0001750 0001750 00000306641 10616163233 023553 0 ustar osallou osallou PROGRAM DBLAT3
*
* Test program for the DOUBLE PRECISION Level 3 Blas.
*
* The program must be driven by a short data file. The first 14 records
* of the file are read using list-directed input, the last 6 records
* are read using the format ( A6, L2 ). An annotated example of a data
* file can be obtained by deleting the first 3 characters from the
* following 20 lines:
* 'dblat3.out' NAME OF SUMMARY OUTPUT FILE
* 6 UNIT NUMBER OF SUMMARY FILE
* 'DBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE
* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
* F LOGICAL FLAG, T TO STOP ON FAILURES.
* T LOGICAL FLAG, T TO TEST ERROR EXITS.
* 16.0 THRESHOLD VALUE OF TEST RATIO
* 6 NUMBER OF VALUES OF N
* 0 1 2 3 5 9 VALUES OF N
* 3 NUMBER OF VALUES OF ALPHA
* 0.0 1.0 0.7 VALUES OF ALPHA
* 3 NUMBER OF VALUES OF BETA
* 0.0 1.0 1.3 VALUES OF BETA
* DGEMM T PUT F FOR NO TEST. SAME COLUMNS.
* DSYMM T PUT F FOR NO TEST. SAME COLUMNS.
* DTRMM T PUT F FOR NO TEST. SAME COLUMNS.
* DTRSM T PUT F FOR NO TEST. SAME COLUMNS.
* DSYRK T PUT F FOR NO TEST. SAME COLUMNS.
* DSYR2K T PUT F FOR NO TEST. SAME COLUMNS.
*
* See:
*
* Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S.
* A Set of Level 3 Basic Linear Algebra Subprograms.
*
* Technical Memorandum No.88 (Revision 1), Mathematics and
* Computer Science Division, Argonne National Laboratory, 9700
* South Cass Avenue, Argonne, Illinois 60439, US.
*
* -- 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.
*
* 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers
* can be run multiple times without deleting generated
* output files (susan)
*
* .. Parameters ..
INTEGER NIN
PARAMETER ( NIN = 5 )
INTEGER NSUBS
PARAMETER ( NSUBS = 6 )
DOUBLE PRECISION ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
INTEGER NMAX
PARAMETER ( NMAX = 65 )
INTEGER NIDMAX, NALMAX, NBEMAX
PARAMETER ( NIDMAX = 9, NALMAX = 7, NBEMAX = 7 )
* .. Local Scalars ..
DOUBLE PRECISION EPS, ERR, THRESH
INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA
LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
$ TSTERR
CHARACTER*1 TRANSA, TRANSB
CHARACTER*6 SNAMET
CHARACTER*32 SNAPS, SUMMRY
* .. Local Arrays ..
DOUBLE PRECISION AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ),
$ ALF( NALMAX ), AS( NMAX*NMAX ),
$ BB( NMAX*NMAX ), BET( NBEMAX ),
$ BS( NMAX*NMAX ), C( NMAX, NMAX ),
$ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ),
$ G( NMAX ), W( 2*NMAX )
INTEGER IDIM( NIDMAX )
LOGICAL LTEST( NSUBS )
CHARACTER*6 SNAMES( NSUBS )
* .. External Functions ..
DOUBLE PRECISION DDIFF
LOGICAL LDE
EXTERNAL DDIFF, LDE
* .. External Subroutines ..
EXTERNAL DCHK1, DCHK2, DCHK3, DCHK4, DCHK5, DCHKE, DMMCH
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
COMMON /SRNAMC/SRNAMT
* .. Data statements ..
DATA SNAMES/'DGEMM ', 'DSYMM ', 'DTRMM ', 'DTRSM ',
$ 'DSYRK ', 'DSYR2K'/
* .. Executable Statements ..
*
* Read name and unit number for summary output file and open file.
*
READ( NIN, FMT = * )SUMMRY
READ( NIN, FMT = * )NOUT
OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' )
NOUTC = NOUT
*
* Read name and unit number for snapshot output file and open file.
*
READ( NIN, FMT = * )SNAPS
READ( NIN, FMT = * )NTRA
TRACE = NTRA.GE.0
IF( TRACE )THEN
OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' )
END IF
* Read the flag that directs rewinding of the snapshot file.
READ( NIN, FMT = * )REWI
REWI = REWI.AND.TRACE
* Read the flag that directs stopping on any failure.
READ( NIN, FMT = * )SFATAL
* Read the flag that indicates whether error exits are to be tested.
READ( NIN, FMT = * )TSTERR
* Read the threshold value of the test ratio
READ( NIN, FMT = * )THRESH
*
* Read and check the parameter values for the tests.
*
* Values of N
READ( NIN, FMT = * )NIDIM
IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN
WRITE( NOUT, FMT = 9997 )'N', NIDMAX
GO TO 220
END IF
READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM )
DO 10 I = 1, NIDIM
IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN
WRITE( NOUT, FMT = 9996 )NMAX
GO TO 220
END IF
10 CONTINUE
* Values of ALPHA
READ( NIN, FMT = * )NALF
IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN
WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX
GO TO 220
END IF
READ( NIN, FMT = * )( ALF( I ), I = 1, NALF )
* Values of BETA
READ( NIN, FMT = * )NBET
IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN
WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX
GO TO 220
END IF
READ( NIN, FMT = * )( BET( I ), I = 1, NBET )
*
* Report values of parameters.
*
WRITE( NOUT, FMT = 9995 )
WRITE( NOUT, FMT = 9994 )( IDIM( I ), I = 1, NIDIM )
WRITE( NOUT, FMT = 9993 )( ALF( I ), I = 1, NALF )
WRITE( NOUT, FMT = 9992 )( BET( I ), I = 1, NBET )
IF( .NOT.TSTERR )THEN
WRITE( NOUT, FMT = * )
WRITE( NOUT, FMT = 9984 )
END IF
WRITE( NOUT, FMT = * )
WRITE( NOUT, FMT = 9999 )THRESH
WRITE( NOUT, FMT = * )
*
* Read names of subroutines and flags which indicate
* whether they are to be tested.
*
DO 20 I = 1, NSUBS
LTEST( I ) = .FALSE.
20 CONTINUE
30 READ( NIN, FMT = 9988, END = 60 )SNAMET, LTESTT
DO 40 I = 1, NSUBS
IF( SNAMET.EQ.SNAMES( I ) )
$ GO TO 50
40 CONTINUE
WRITE( NOUT, FMT = 9990 )SNAMET
STOP
50 LTEST( I ) = LTESTT
GO TO 30
*
60 CONTINUE
CLOSE ( NIN )
*
* Compute EPS (the machine precision).
*
EPS = ONE
70 CONTINUE
IF( DDIFF( ONE + EPS, ONE ).EQ.ZERO )
$ GO TO 80
EPS = HALF*EPS
GO TO 70
80 CONTINUE
EPS = EPS + EPS
WRITE( NOUT, FMT = 9998 )EPS
*
* Check the reliability of DMMCH using exact data.
*
N = MIN( 32, NMAX )
DO 100 J = 1, N
DO 90 I = 1, N
AB( I, J ) = MAX( I - J + 1, 0 )
90 CONTINUE
AB( J, NMAX + 1 ) = J
AB( 1, NMAX + J ) = J
C( J, 1 ) = ZERO
100 CONTINUE
DO 110 J = 1, N
CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3
110 CONTINUE
* CC holds the exact result. On exit from DMMCH CT holds
* the result computed by DMMCH.
TRANSA = 'N'
TRANSB = 'N'
CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
$ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
$ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
SAME = LDE( CC, CT, N )
IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
STOP
END IF
TRANSB = 'T'
CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
$ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
$ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
SAME = LDE( CC, CT, N )
IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
STOP
END IF
DO 120 J = 1, N
AB( J, NMAX + 1 ) = N - J + 1
AB( 1, NMAX + J ) = N - J + 1
120 CONTINUE
DO 130 J = 1, N
CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 -
$ ( ( J + 1 )*J*( J - 1 ) )/3
130 CONTINUE
TRANSA = 'T'
TRANSB = 'N'
CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
$ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
$ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
SAME = LDE( CC, CT, N )
IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
STOP
END IF
TRANSB = 'T'
CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
$ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
$ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
SAME = LDE( CC, CT, N )
IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
STOP
END IF
*
* Test each subroutine in turn.
*
DO 200 ISNUM = 1, NSUBS
WRITE( NOUT, FMT = * )
IF( .NOT.LTEST( ISNUM ) )THEN
* Subprogram is not to be tested.
WRITE( NOUT, FMT = 9987 )SNAMES( ISNUM )
ELSE
SRNAMT = SNAMES( ISNUM )
* Test error exits.
IF( TSTERR )THEN
CALL DCHKE( ISNUM, SNAMES( ISNUM ), NOUT )
WRITE( NOUT, FMT = * )
END IF
* Test computations.
INFOT = 0
OK = .TRUE.
FATAL = .FALSE.
GO TO ( 140, 150, 160, 160, 170, 180 )ISNUM
* Test DGEMM, 01.
140 CALL DCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
$ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
$ CC, CS, CT, G )
GO TO 190
* Test DSYMM, 02.
150 CALL DCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
$ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
$ CC, CS, CT, G )
GO TO 190
* Test DTRMM, 03, DTRSM, 04.
160 CALL DCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB,
$ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C )
GO TO 190
* Test DSYRK, 05.
170 CALL DCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
$ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
$ CC, CS, CT, G )
GO TO 190
* Test DSYR2K, 06.
180 CALL DCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
$ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W )
GO TO 190
*
190 IF( FATAL.AND.SFATAL )
$ GO TO 210
END IF
200 CONTINUE
WRITE( NOUT, FMT = 9986 )
GO TO 230
*
210 CONTINUE
WRITE( NOUT, FMT = 9985 )
GO TO 230
*
220 CONTINUE
WRITE( NOUT, FMT = 9991 )
*
230 CONTINUE
IF( TRACE )
$ CLOSE ( NTRA )
CLOSE ( NOUT )
STOP
*
9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES',
$ 'S THAN', F8.2 )
9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, D9.1 )
9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ',
$ 'THAN ', I2 )
9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 )
9995 FORMAT( ' TESTS OF THE DOUBLE PRECISION LEVEL 3 BLAS', //' THE F',
$ 'OLLOWING PARAMETER VALUES WILL BE USED:' )
9994 FORMAT( ' FOR N ', 9I6 )
9993 FORMAT( ' FOR ALPHA ', 7F6.1 )
9992 FORMAT( ' FOR BETA ', 7F6.1 )
9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
$ /' ******* TESTS ABANDONED *******' )
9990 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T',
$ 'ESTS ABANDONED *******' )
9989 FORMAT( ' ERROR IN DMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
$ 'ATED WRONGLY.', /' DMMCH WAS CALLED WITH TRANSA = ', A1,
$ ' AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ',
$ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ',
$ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ',
$ '*******' )
9988 FORMAT( A6, L2 )
9987 FORMAT( 1X, A6, ' WAS NOT TESTED' )
9986 FORMAT( /' END OF TESTS' )
9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
*
* End of DBLAT3.
*
END
SUBROUTINE DCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
$ A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
*
* Tests DGEMM.
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- 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.
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* .. Scalar Arguments ..
DOUBLE PRECISION EPS, THRESH
INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
LOGICAL FATAL, REWI, TRACE
CHARACTER*6 SNAME
* .. Array Arguments ..
DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), B( NMAX, NMAX ),
$ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
$ C( NMAX, NMAX ), CC( NMAX*NMAX ),
$ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
INTEGER IDIM( NIDIM )
* .. Local Scalars ..
DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX
INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA,
$ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M,
$ MA, MB, MS, N, NA, NARGS, NB, NC, NS
LOGICAL NULL, RESET, SAME, TRANA, TRANB
CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB
CHARACTER*3 ICH
* .. Local Arrays ..
LOGICAL ISAME( 13 )
* .. External Functions ..
LOGICAL LDE, LDERES
EXTERNAL LDE, LDERES
* .. External Subroutines ..
EXTERNAL DGEMM, DMAKE, DMMCH
* .. Intrinsic Functions ..
INTRINSIC MAX
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
* .. Data statements ..
DATA ICH/'NTC'/
* .. Executable Statements ..
*
NARGS = 13
NC = 0
RESET = .TRUE.
ERRMAX = ZERO
*
DO 110 IM = 1, NIDIM
M = IDIM( IM )
*
DO 100 IN = 1, NIDIM
N = IDIM( IN )
* Set LDC to 1 more than minimum value if room.
LDC = M
IF( LDC.LT.NMAX )
$ LDC = LDC + 1
* Skip tests if not enough room.
IF( LDC.GT.NMAX )
$ GO TO 100
LCC = LDC*N
NULL = N.LE.0.OR.M.LE.0
*
DO 90 IK = 1, NIDIM
K = IDIM( IK )
*
DO 80 ICA = 1, 3
TRANSA = ICH( ICA: ICA )
TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
*
IF( TRANA )THEN
MA = K
NA = M
ELSE
MA = M
NA = K
END IF
* Set LDA to 1 more than minimum value if room.
LDA = MA
IF( LDA.LT.NMAX )
$ LDA = LDA + 1
* Skip tests if not enough room.
IF( LDA.GT.NMAX )
$ GO TO 80
LAA = LDA*NA
*
* Generate the matrix A.
*
CALL DMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA,
$ RESET, ZERO )
*
DO 70 ICB = 1, 3
TRANSB = ICH( ICB: ICB )
TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
*
IF( TRANB )THEN
MB = N
NB = K
ELSE
MB = K
NB = N
END IF
* Set LDB to 1 more than minimum value if room.
LDB = MB
IF( LDB.LT.NMAX )
$ LDB = LDB + 1
* Skip tests if not enough room.
IF( LDB.GT.NMAX )
$ GO TO 70
LBB = LDB*NB
*
* Generate the matrix B.
*
CALL DMAKE( 'GE', ' ', ' ', MB, NB, B, NMAX, BB,
$ LDB, RESET, ZERO )
*
DO 60 IA = 1, NALF
ALPHA = ALF( IA )
*
DO 50 IB = 1, NBET
BETA = BET( IB )
*
* Generate the matrix C.
*
CALL DMAKE( 'GE', ' ', ' ', M, N, C, NMAX,
$ CC, LDC, RESET, ZERO )
*
NC = NC + 1
*
* Save every datum before calling the
* subroutine.
*
TRANAS = TRANSA
TRANBS = TRANSB
MS = M
NS = N
KS = K
ALS = ALPHA
DO 10 I = 1, LAA
AS( I ) = AA( I )
10 CONTINUE
LDAS = LDA
DO 20 I = 1, LBB
BS( I ) = BB( I )
20 CONTINUE
LDBS = LDB
BLS = BETA
DO 30 I = 1, LCC
CS( I ) = CC( I )
30 CONTINUE
LDCS = LDC
*
* Call the subroutine.
*
IF( TRACE )
$ WRITE( NTRA, FMT = 9995 )NC, SNAME,
$ TRANSA, TRANSB, M, N, K, ALPHA, LDA, LDB,
$ BETA, LDC
IF( REWI )
$ REWIND NTRA
CALL DGEMM( TRANSA, TRANSB, M, N, K, ALPHA,
$ AA, LDA, BB, LDB, BETA, CC, LDC )
*
* Check if error-exit was taken incorrectly.
*
IF( .NOT.OK )THEN
WRITE( NOUT, FMT = 9994 )
FATAL = .TRUE.
GO TO 120
END IF
*
* See what data changed inside subroutines.
*
ISAME( 1 ) = TRANSA.EQ.TRANAS
ISAME( 2 ) = TRANSB.EQ.TRANBS
ISAME( 3 ) = MS.EQ.M
ISAME( 4 ) = NS.EQ.N
ISAME( 5 ) = KS.EQ.K
ISAME( 6 ) = ALS.EQ.ALPHA
ISAME( 7 ) = LDE( AS, AA, LAA )
ISAME( 8 ) = LDAS.EQ.LDA
ISAME( 9 ) = LDE( BS, BB, LBB )
ISAME( 10 ) = LDBS.EQ.LDB
ISAME( 11 ) = BLS.EQ.BETA
IF( NULL )THEN
ISAME( 12 ) = LDE( CS, CC, LCC )
ELSE
ISAME( 12 ) = LDERES( 'GE', ' ', M, N, CS,
$ CC, LDC )
END IF
ISAME( 13 ) = LDCS.EQ.LDC
*
* If data was incorrectly changed, report
* and return.
*
SAME = .TRUE.
DO 40 I = 1, NARGS
SAME = SAME.AND.ISAME( I )
IF( .NOT.ISAME( I ) )
$ WRITE( NOUT, FMT = 9998 )I
40 CONTINUE
IF( .NOT.SAME )THEN
FATAL = .TRUE.
GO TO 120
END IF
*
IF( .NOT.NULL )THEN
*
* Check the result.
*
CALL DMMCH( TRANSA, TRANSB, M, N, K,
$ ALPHA, A, NMAX, B, NMAX, BETA,
$ C, NMAX, CT, G, CC, LDC, EPS,
$ ERR, FATAL, NOUT, .TRUE. )
ERRMAX = MAX( ERRMAX, ERR )
* If got really bad answer, report and
* return.
IF( FATAL )
$ GO TO 120
END IF
*
50 CONTINUE
*
60 CONTINUE
*
70 CONTINUE
*
80 CONTINUE
*
90 CONTINUE
*
100 CONTINUE
*
110 CONTINUE
*
* Report result.
*
IF( ERRMAX.LT.THRESH )THEN
WRITE( NOUT, FMT = 9999 )SNAME, NC
ELSE
WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
END IF
GO TO 130
*
120 CONTINUE
WRITE( NOUT, FMT = 9996 )SNAME
WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, TRANSB, M, N, K,
$ ALPHA, LDA, LDB, BETA, LDC
*
130 CONTINUE
RETURN
*
9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
$ 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
$ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
$ ' - SUSPECT *******' )
9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',''', A1, ''',',
$ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ',
$ 'C,', I3, ').' )
9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
* End of DCHK1.
*
END
SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
$ A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
*
* Tests DSYMM.
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- 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.
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* .. Scalar Arguments ..
DOUBLE PRECISION EPS, THRESH
INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
LOGICAL FATAL, REWI, TRACE
CHARACTER*6 SNAME
* .. Array Arguments ..
DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), B( NMAX, NMAX ),
$ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
$ C( NMAX, NMAX ), CC( NMAX*NMAX ),
$ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
INTEGER IDIM( NIDIM )
* .. Local Scalars ..
DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX
INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC,
$ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA,
$ NARGS, NC, NS
LOGICAL LEFT, NULL, RESET, SAME
CHARACTER*1 SIDE, SIDES, UPLO, UPLOS
CHARACTER*2 ICHS, ICHU
* .. Local Arrays ..
LOGICAL ISAME( 13 )
* .. External Functions ..
LOGICAL LDE, LDERES
EXTERNAL LDE, LDERES
* .. External Subroutines ..
EXTERNAL DMAKE, DMMCH, DSYMM
* .. Intrinsic Functions ..
INTRINSIC MAX
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
* .. Data statements ..
DATA ICHS/'LR'/, ICHU/'UL'/
* .. Executable Statements ..
*
NARGS = 12
NC = 0
RESET = .TRUE.
ERRMAX = ZERO
*
DO 100 IM = 1, NIDIM
M = IDIM( IM )
*
DO 90 IN = 1, NIDIM
N = IDIM( IN )
* Set LDC to 1 more than minimum value if room.
LDC = M
IF( LDC.LT.NMAX )
$ LDC = LDC + 1
* Skip tests if not enough room.
IF( LDC.GT.NMAX )
$ GO TO 90
LCC = LDC*N
NULL = N.LE.0.OR.M.LE.0
*
* Set LDB to 1 more than minimum value if room.
LDB = M
IF( LDB.LT.NMAX )
$ LDB = LDB + 1
* Skip tests if not enough room.
IF( LDB.GT.NMAX )
$ GO TO 90
LBB = LDB*N
*
* Generate the matrix B.
*
CALL DMAKE( 'GE', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET,
$ ZERO )
*
DO 80 ICS = 1, 2
SIDE = ICHS( ICS: ICS )
LEFT = SIDE.EQ.'L'
*
IF( LEFT )THEN
NA = M
ELSE
NA = N
END IF
* Set LDA to 1 more than minimum value if room.
LDA = NA
IF( LDA.LT.NMAX )
$ LDA = LDA + 1
* Skip tests if not enough room.
IF( LDA.GT.NMAX )
$ GO TO 80
LAA = LDA*NA
*
DO 70 ICU = 1, 2
UPLO = ICHU( ICU: ICU )
*
* Generate the symmetric matrix A.
*
CALL DMAKE( 'SY', UPLO, ' ', NA, NA, A, NMAX, AA, LDA,
$ RESET, ZERO )
*
DO 60 IA = 1, NALF
ALPHA = ALF( IA )
*
DO 50 IB = 1, NBET
BETA = BET( IB )
*
* Generate the matrix C.
*
CALL DMAKE( 'GE', ' ', ' ', M, N, C, NMAX, CC,
$ LDC, RESET, ZERO )
*
NC = NC + 1
*
* Save every datum before calling the
* subroutine.
*
SIDES = SIDE
UPLOS = UPLO
MS = M
NS = N
ALS = ALPHA
DO 10 I = 1, LAA
AS( I ) = AA( I )
10 CONTINUE
LDAS = LDA
DO 20 I = 1, LBB
BS( I ) = BB( I )
20 CONTINUE
LDBS = LDB
BLS = BETA
DO 30 I = 1, LCC
CS( I ) = CC( I )
30 CONTINUE
LDCS = LDC
*
* Call the subroutine.
*
IF( TRACE )
$ WRITE( NTRA, FMT = 9995 )NC, SNAME, SIDE,
$ UPLO, M, N, ALPHA, LDA, LDB, BETA, LDC
IF( REWI )
$ REWIND NTRA
CALL DSYMM( SIDE, UPLO, M, N, ALPHA, AA, LDA,
$ BB, LDB, BETA, CC, LDC )
*
* Check if error-exit was taken incorrectly.
*
IF( .NOT.OK )THEN
WRITE( NOUT, FMT = 9994 )
FATAL = .TRUE.
GO TO 110
END IF
*
* See what data changed inside subroutines.
*
ISAME( 1 ) = SIDES.EQ.SIDE
ISAME( 2 ) = UPLOS.EQ.UPLO
ISAME( 3 ) = MS.EQ.M
ISAME( 4 ) = NS.EQ.N
ISAME( 5 ) = ALS.EQ.ALPHA
ISAME( 6 ) = LDE( AS, AA, LAA )
ISAME( 7 ) = LDAS.EQ.LDA
ISAME( 8 ) = LDE( BS, BB, LBB )
ISAME( 9 ) = LDBS.EQ.LDB
ISAME( 10 ) = BLS.EQ.BETA
IF( NULL )THEN
ISAME( 11 ) = LDE( CS, CC, LCC )
ELSE
ISAME( 11 ) = LDERES( 'GE', ' ', M, N, CS,
$ CC, LDC )
END IF
ISAME( 12 ) = LDCS.EQ.LDC
*
* If data was incorrectly changed, report and
* return.
*
SAME = .TRUE.
DO 40 I = 1, NARGS
SAME = SAME.AND.ISAME( I )
IF( .NOT.ISAME( I ) )
$ WRITE( NOUT, FMT = 9998 )I
40 CONTINUE
IF( .NOT.SAME )THEN
FATAL = .TRUE.
GO TO 110
END IF
*
IF( .NOT.NULL )THEN
*
* Check the result.
*
IF( LEFT )THEN
CALL DMMCH( 'N', 'N', M, N, M, ALPHA, A,
$ NMAX, B, NMAX, BETA, C, NMAX,
$ CT, G, CC, LDC, EPS, ERR,
$ FATAL, NOUT, .TRUE. )
ELSE
CALL DMMCH( 'N', 'N', M, N, N, ALPHA, B,
$ NMAX, A, NMAX, BETA, C, NMAX,
$ CT, G, CC, LDC, EPS, ERR,
$ FATAL, NOUT, .TRUE. )
END IF
ERRMAX = MAX( ERRMAX, ERR )
* If got really bad answer, report and
* return.
IF( FATAL )
$ GO TO 110
END IF
*
50 CONTINUE
*
60 CONTINUE
*
70 CONTINUE
*
80 CONTINUE
*
90 CONTINUE
*
100 CONTINUE
*
* Report result.
*
IF( ERRMAX.LT.THRESH )THEN
WRITE( NOUT, FMT = 9999 )SNAME, NC
ELSE
WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
END IF
GO TO 120
*
110 CONTINUE
WRITE( NOUT, FMT = 9996 )SNAME
WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, M, N, ALPHA, LDA,
$ LDB, BETA, LDC
*
120 CONTINUE
RETURN
*
9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
$ 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
$ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
$ ' - SUSPECT *******' )
9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
9995 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
$ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ',
$ ' .' )
9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
* End of DCHK2.
*
END
SUBROUTINE DCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$ FATAL, NIDIM, IDIM, NALF, ALF, NMAX, A, AA, AS,
$ B, BB, BS, CT, G, C )
*
* Tests DTRMM and DTRSM.
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- 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.
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* .. Scalar Arguments ..
DOUBLE PRECISION EPS, THRESH
INTEGER NALF, NIDIM, NMAX, NOUT, NTRA
LOGICAL FATAL, REWI, TRACE
CHARACTER*6 SNAME
* .. Array Arguments ..
DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), B( NMAX, NMAX ),
$ BB( NMAX*NMAX ), BS( NMAX*NMAX ),
$ C( NMAX, NMAX ), CT( NMAX ), G( NMAX )
INTEGER IDIM( NIDIM )
* .. Local Scalars ..
DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX
INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB,
$ LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC,
$ NS
LOGICAL LEFT, NULL, RESET, SAME
CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO,
$ UPLOS
CHARACTER*2 ICHD, ICHS, ICHU
CHARACTER*3 ICHT
* .. Local Arrays ..
LOGICAL ISAME( 13 )
* .. External Functions ..
LOGICAL LDE, LDERES
EXTERNAL LDE, LDERES
* .. External Subroutines ..
EXTERNAL DMAKE, DMMCH, DTRMM, DTRSM
* .. Intrinsic Functions ..
INTRINSIC MAX
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
* .. Data statements ..
DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/, ICHS/'LR'/
* .. Executable Statements ..
*
NARGS = 11
NC = 0
RESET = .TRUE.
ERRMAX = ZERO
* Set up zero matrix for DMMCH.
DO 20 J = 1, NMAX
DO 10 I = 1, NMAX
C( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
*
DO 140 IM = 1, NIDIM
M = IDIM( IM )
*
DO 130 IN = 1, NIDIM
N = IDIM( IN )
* Set LDB to 1 more than minimum value if room.
LDB = M
IF( LDB.LT.NMAX )
$ LDB = LDB + 1
* Skip tests if not enough room.
IF( LDB.GT.NMAX )
$ GO TO 130
LBB = LDB*N
NULL = M.LE.0.OR.N.LE.0
*
DO 120 ICS = 1, 2
SIDE = ICHS( ICS: ICS )
LEFT = SIDE.EQ.'L'
IF( LEFT )THEN
NA = M
ELSE
NA = N
END IF
* Set LDA to 1 more than minimum value if room.
LDA = NA
IF( LDA.LT.NMAX )
$ LDA = LDA + 1
* Skip tests if not enough room.
IF( LDA.GT.NMAX )
$ GO TO 130
LAA = LDA*NA
*
DO 110 ICU = 1, 2
UPLO = ICHU( ICU: ICU )
*
DO 100 ICT = 1, 3
TRANSA = ICHT( ICT: ICT )
*
DO 90 ICD = 1, 2
DIAG = ICHD( ICD: ICD )
*
DO 80 IA = 1, NALF
ALPHA = ALF( IA )
*
* Generate the matrix A.
*
CALL DMAKE( 'TR', UPLO, DIAG, NA, NA, A,
$ NMAX, AA, LDA, RESET, ZERO )
*
* Generate the matrix B.
*
CALL DMAKE( 'GE', ' ', ' ', M, N, B, NMAX,
$ BB, LDB, RESET, ZERO )
*
NC = NC + 1
*
* Save every datum before calling the
* subroutine.
*
SIDES = SIDE
UPLOS = UPLO
TRANAS = TRANSA
DIAGS = DIAG
MS = M
NS = N
ALS = ALPHA
DO 30 I = 1, LAA
AS( I ) = AA( I )
30 CONTINUE
LDAS = LDA
DO 40 I = 1, LBB
BS( I ) = BB( I )
40 CONTINUE
LDBS = LDB
*
* Call the subroutine.
*
IF( SNAME( 4: 5 ).EQ.'MM' )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9995 )NC, SNAME,
$ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,
$ LDA, LDB
IF( REWI )
$ REWIND NTRA
CALL DTRMM( SIDE, UPLO, TRANSA, DIAG, M,
$ N, ALPHA, AA, LDA, BB, LDB )
ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9995 )NC, SNAME,
$ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,
$ LDA, LDB
IF( REWI )
$ REWIND NTRA
CALL DTRSM( SIDE, UPLO, TRANSA, DIAG, M,
$ N, ALPHA, AA, LDA, BB, LDB )
END IF
*
* Check if error-exit was taken incorrectly.
*
IF( .NOT.OK )THEN
WRITE( NOUT, FMT = 9994 )
FATAL = .TRUE.
GO TO 150
END IF
*
* See what data changed inside subroutines.
*
ISAME( 1 ) = SIDES.EQ.SIDE
ISAME( 2 ) = UPLOS.EQ.UPLO
ISAME( 3 ) = TRANAS.EQ.TRANSA
ISAME( 4 ) = DIAGS.EQ.DIAG
ISAME( 5 ) = MS.EQ.M
ISAME( 6 ) = NS.EQ.N
ISAME( 7 ) = ALS.EQ.ALPHA
ISAME( 8 ) = LDE( AS, AA, LAA )
ISAME( 9 ) = LDAS.EQ.LDA
IF( NULL )THEN
ISAME( 10 ) = LDE( BS, BB, LBB )
ELSE
ISAME( 10 ) = LDERES( 'GE', ' ', M, N, BS,
$ BB, LDB )
END IF
ISAME( 11 ) = LDBS.EQ.LDB
*
* If data was incorrectly changed, report and
* return.
*
SAME = .TRUE.
DO 50 I = 1, NARGS
SAME = SAME.AND.ISAME( I )
IF( .NOT.ISAME( I ) )
$ WRITE( NOUT, FMT = 9998 )I
50 CONTINUE
IF( .NOT.SAME )THEN
FATAL = .TRUE.
GO TO 150
END IF
*
IF( .NOT.NULL )THEN
IF( SNAME( 4: 5 ).EQ.'MM' )THEN
*
* Check the result.
*
IF( LEFT )THEN
CALL DMMCH( TRANSA, 'N', M, N, M,
$ ALPHA, A, NMAX, B, NMAX,
$ ZERO, C, NMAX, CT, G,
$ BB, LDB, EPS, ERR,
$ FATAL, NOUT, .TRUE. )
ELSE
CALL DMMCH( 'N', TRANSA, M, N, N,
$ ALPHA, B, NMAX, A, NMAX,
$ ZERO, C, NMAX, CT, G,
$ BB, LDB, EPS, ERR,
$ FATAL, NOUT, .TRUE. )
END IF
ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN
*
* Compute approximation to original
* matrix.
*
DO 70 J = 1, N
DO 60 I = 1, M
C( I, J ) = BB( I + ( J - 1 )*
$ LDB )
BB( I + ( J - 1 )*LDB ) = ALPHA*
$ B( I, J )
60 CONTINUE
70 CONTINUE
*
IF( LEFT )THEN
CALL DMMCH( TRANSA, 'N', M, N, M,
$ ONE, A, NMAX, C, NMAX,
$ ZERO, B, NMAX, CT, G,
$ BB, LDB, EPS, ERR,
$ FATAL, NOUT, .FALSE. )
ELSE
CALL DMMCH( 'N', TRANSA, M, N, N,
$ ONE, C, NMAX, A, NMAX,
$ ZERO, B, NMAX, CT, G,
$ BB, LDB, EPS, ERR,
$ FATAL, NOUT, .FALSE. )
END IF
END IF
ERRMAX = MAX( ERRMAX, ERR )
* If got really bad answer, report and
* return.
IF( FATAL )
$ GO TO 150
END IF
*
80 CONTINUE
*
90 CONTINUE
*
100 CONTINUE
*
110 CONTINUE
*
120 CONTINUE
*
130 CONTINUE
*
140 CONTINUE
*
* Report result.
*
IF( ERRMAX.LT.THRESH )THEN
WRITE( NOUT, FMT = 9999 )SNAME, NC
ELSE
WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
END IF
GO TO 160
*
150 CONTINUE
WRITE( NOUT, FMT = 9996 )SNAME
WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, TRANSA, DIAG, M,
$ N, ALPHA, LDA, LDB
*
160 CONTINUE
RETURN
*
9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
$ 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
$ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
$ ' - SUSPECT *******' )
9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
9995 FORMAT( 1X, I6, ': ', A6, '(', 4( '''', A1, ''',' ), 2( I3, ',' ),
$ F4.1, ', A,', I3, ', B,', I3, ') .' )
9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
* End of DCHK3.
*
END
SUBROUTINE DCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
$ A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
*
* Tests DSYRK.
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- 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.
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* .. Scalar Arguments ..
DOUBLE PRECISION EPS, THRESH
INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
LOGICAL FATAL, REWI, TRACE
CHARACTER*6 SNAME
* .. Array Arguments ..
DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), B( NMAX, NMAX ),
$ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
$ C( NMAX, NMAX ), CC( NMAX*NMAX ),
$ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
INTEGER IDIM( NIDIM )
* .. Local Scalars ..
DOUBLE PRECISION ALPHA, ALS, BETA, BETS, ERR, ERRMAX
INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS,
$ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA,
$ NARGS, NC, NS
LOGICAL NULL, RESET, SAME, TRAN, UPPER
CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS
CHARACTER*2 ICHU
CHARACTER*3 ICHT
* .. Local Arrays ..
LOGICAL ISAME( 13 )
* .. External Functions ..
LOGICAL LDE, LDERES
EXTERNAL LDE, LDERES
* .. External Subroutines ..
EXTERNAL DMAKE, DMMCH, DSYRK
* .. Intrinsic Functions ..
INTRINSIC MAX
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
* .. Data statements ..
DATA ICHT/'NTC'/, ICHU/'UL'/
* .. Executable Statements ..
*
NARGS = 10
NC = 0
RESET = .TRUE.
ERRMAX = ZERO
*
DO 100 IN = 1, NIDIM
N = IDIM( IN )
* Set LDC to 1 more than minimum value if room.
LDC = N
IF( LDC.LT.NMAX )
$ LDC = LDC + 1
* Skip tests if not enough room.
IF( LDC.GT.NMAX )
$ GO TO 100
LCC = LDC*N
NULL = N.LE.0
*
DO 90 IK = 1, NIDIM
K = IDIM( IK )
*
DO 80 ICT = 1, 3
TRANS = ICHT( ICT: ICT )
TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
IF( TRAN )THEN
MA = K
NA = N
ELSE
MA = N
NA = K
END IF
* Set LDA to 1 more than minimum value if room.
LDA = MA
IF( LDA.LT.NMAX )
$ LDA = LDA + 1
* Skip tests if not enough room.
IF( LDA.GT.NMAX )
$ GO TO 80
LAA = LDA*NA
*
* Generate the matrix A.
*
CALL DMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA,
$ RESET, ZERO )
*
DO 70 ICU = 1, 2
UPLO = ICHU( ICU: ICU )
UPPER = UPLO.EQ.'U'
*
DO 60 IA = 1, NALF
ALPHA = ALF( IA )
*
DO 50 IB = 1, NBET
BETA = BET( IB )
*
* Generate the matrix C.
*
CALL DMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC,
$ LDC, RESET, ZERO )
*
NC = NC + 1
*
* Save every datum before calling the subroutine.
*
UPLOS = UPLO
TRANSS = TRANS
NS = N
KS = K
ALS = ALPHA
DO 10 I = 1, LAA
AS( I ) = AA( I )
10 CONTINUE
LDAS = LDA
BETS = BETA
DO 20 I = 1, LCC
CS( I ) = CC( I )
20 CONTINUE
LDCS = LDC
*
* Call the subroutine.
*
IF( TRACE )
$ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO,
$ TRANS, N, K, ALPHA, LDA, BETA, LDC
IF( REWI )
$ REWIND NTRA
CALL DSYRK( UPLO, TRANS, N, K, ALPHA, AA, LDA,
$ BETA, CC, LDC )
*
* Check if error-exit was taken incorrectly.
*
IF( .NOT.OK )THEN
WRITE( NOUT, FMT = 9993 )
FATAL = .TRUE.
GO TO 120
END IF
*
* See what data changed inside subroutines.
*
ISAME( 1 ) = UPLOS.EQ.UPLO
ISAME( 2 ) = TRANSS.EQ.TRANS
ISAME( 3 ) = NS.EQ.N
ISAME( 4 ) = KS.EQ.K
ISAME( 5 ) = ALS.EQ.ALPHA
ISAME( 6 ) = LDE( AS, AA, LAA )
ISAME( 7 ) = LDAS.EQ.LDA
ISAME( 8 ) = BETS.EQ.BETA
IF( NULL )THEN
ISAME( 9 ) = LDE( CS, CC, LCC )
ELSE
ISAME( 9 ) = LDERES( 'SY', UPLO, N, N, CS,
$ CC, LDC )
END IF
ISAME( 10 ) = LDCS.EQ.LDC
*
* If data was incorrectly changed, report and
* return.
*
SAME = .TRUE.
DO 30 I = 1, NARGS
SAME = SAME.AND.ISAME( I )
IF( .NOT.ISAME( I ) )
$ WRITE( NOUT, FMT = 9998 )I
30 CONTINUE
IF( .NOT.SAME )THEN
FATAL = .TRUE.
GO TO 120
END IF
*
IF( .NOT.NULL )THEN
*
* Check the result column by column.
*
JC = 1
DO 40 J = 1, N
IF( UPPER )THEN
JJ = 1
LJ = J
ELSE
JJ = J
LJ = N - J + 1
END IF
IF( TRAN )THEN
CALL DMMCH( 'T', 'N', LJ, 1, K, ALPHA,
$ A( 1, JJ ), NMAX,
$ A( 1, J ), NMAX, BETA,
$ C( JJ, J ), NMAX, CT, G,
$ CC( JC ), LDC, EPS, ERR,
$ FATAL, NOUT, .TRUE. )
ELSE
CALL DMMCH( 'N', 'T', LJ, 1, K, ALPHA,
$ A( JJ, 1 ), NMAX,
$ A( J, 1 ), NMAX, BETA,
$ C( JJ, J ), NMAX, CT, G,
$ CC( JC ), LDC, EPS, ERR,
$ FATAL, NOUT, .TRUE. )
END IF
IF( UPPER )THEN
JC = JC + LDC
ELSE
JC = JC + LDC + 1
END IF
ERRMAX = MAX( ERRMAX, ERR )
* If got really bad answer, report and
* return.
IF( FATAL )
$ GO TO 110
40 CONTINUE
END IF
*
50 CONTINUE
*
60 CONTINUE
*
70 CONTINUE
*
80 CONTINUE
*
90 CONTINUE
*
100 CONTINUE
*
* Report result.
*
IF( ERRMAX.LT.THRESH )THEN
WRITE( NOUT, FMT = 9999 )SNAME, NC
ELSE
WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
END IF
GO TO 130
*
110 CONTINUE
IF( N.GT.1 )
$ WRITE( NOUT, FMT = 9995 )J
*
120 CONTINUE
WRITE( NOUT, FMT = 9996 )SNAME
WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA,
$ LDA, BETA, LDC
*
130 CONTINUE
RETURN
*
9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
$ 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
$ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
$ ' - SUSPECT *******' )
9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
$ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' )
9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
* End of DCHK4.
*
END
SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
$ AB, AA, AS, BB, BS, C, CC, CS, CT, G, W )
*
* Tests DSYR2K.
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- 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.
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* .. Scalar Arguments ..
DOUBLE PRECISION EPS, THRESH
INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
LOGICAL FATAL, REWI, TRACE
CHARACTER*6 SNAME
* .. Array Arguments ..
DOUBLE PRECISION AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ),
$ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ),
$ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ),
$ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ),
$ G( NMAX ), W( 2*NMAX )
INTEGER IDIM( NIDIM )
* .. Local Scalars ..
DOUBLE PRECISION ALPHA, ALS, BETA, BETS, ERR, ERRMAX
INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB,
$ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS,
$ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS
LOGICAL NULL, RESET, SAME, TRAN, UPPER
CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS
CHARACTER*2 ICHU
CHARACTER*3 ICHT
* .. Local Arrays ..
LOGICAL ISAME( 13 )
* .. External Functions ..
LOGICAL LDE, LDERES
EXTERNAL LDE, LDERES
* .. External Subroutines ..
EXTERNAL DMAKE, DMMCH, DSYR2K
* .. Intrinsic Functions ..
INTRINSIC MAX
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
* .. Data statements ..
DATA ICHT/'NTC'/, ICHU/'UL'/
* .. Executable Statements ..
*
NARGS = 12
NC = 0
RESET = .TRUE.
ERRMAX = ZERO
*
DO 130 IN = 1, NIDIM
N = IDIM( IN )
* Set LDC to 1 more than minimum value if room.
LDC = N
IF( LDC.LT.NMAX )
$ LDC = LDC + 1
* Skip tests if not enough room.
IF( LDC.GT.NMAX )
$ GO TO 130
LCC = LDC*N
NULL = N.LE.0
*
DO 120 IK = 1, NIDIM
K = IDIM( IK )
*
DO 110 ICT = 1, 3
TRANS = ICHT( ICT: ICT )
TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
IF( TRAN )THEN
MA = K
NA = N
ELSE
MA = N
NA = K
END IF
* Set LDA to 1 more than minimum value if room.
LDA = MA
IF( LDA.LT.NMAX )
$ LDA = LDA + 1
* Skip tests if not enough room.
IF( LDA.GT.NMAX )
$ GO TO 110
LAA = LDA*NA
*
* Generate the matrix A.
*
IF( TRAN )THEN
CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB, 2*NMAX, AA,
$ LDA, RESET, ZERO )
ELSE
CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB, NMAX, AA, LDA,
$ RESET, ZERO )
END IF
*
* Generate the matrix B.
*
LDB = LDA
LBB = LAA
IF( TRAN )THEN
CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB( K + 1 ),
$ 2*NMAX, BB, LDB, RESET, ZERO )
ELSE
CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB( K*NMAX + 1 ),
$ NMAX, BB, LDB, RESET, ZERO )
END IF
*
DO 100 ICU = 1, 2
UPLO = ICHU( ICU: ICU )
UPPER = UPLO.EQ.'U'
*
DO 90 IA = 1, NALF
ALPHA = ALF( IA )
*
DO 80 IB = 1, NBET
BETA = BET( IB )
*
* Generate the matrix C.
*
CALL DMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC,
$ LDC, RESET, ZERO )
*
NC = NC + 1
*
* Save every datum before calling the subroutine.
*
UPLOS = UPLO
TRANSS = TRANS
NS = N
KS = K
ALS = ALPHA
DO 10 I = 1, LAA
AS( I ) = AA( I )
10 CONTINUE
LDAS = LDA
DO 20 I = 1, LBB
BS( I ) = BB( I )
20 CONTINUE
LDBS = LDB
BETS = BETA
DO 30 I = 1, LCC
CS( I ) = CC( I )
30 CONTINUE
LDCS = LDC
*
* Call the subroutine.
*
IF( TRACE )
$ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO,
$ TRANS, N, K, ALPHA, LDA, LDB, BETA, LDC
IF( REWI )
$ REWIND NTRA
CALL DSYR2K( UPLO, TRANS, N, K, ALPHA, AA, LDA,
$ BB, LDB, BETA, CC, LDC )
*
* Check if error-exit was taken incorrectly.
*
IF( .NOT.OK )THEN
WRITE( NOUT, FMT = 9993 )
FATAL = .TRUE.
GO TO 150
END IF
*
* See what data changed inside subroutines.
*
ISAME( 1 ) = UPLOS.EQ.UPLO
ISAME( 2 ) = TRANSS.EQ.TRANS
ISAME( 3 ) = NS.EQ.N
ISAME( 4 ) = KS.EQ.K
ISAME( 5 ) = ALS.EQ.ALPHA
ISAME( 6 ) = LDE( AS, AA, LAA )
ISAME( 7 ) = LDAS.EQ.LDA
ISAME( 8 ) = LDE( BS, BB, LBB )
ISAME( 9 ) = LDBS.EQ.LDB
ISAME( 10 ) = BETS.EQ.BETA
IF( NULL )THEN
ISAME( 11 ) = LDE( CS, CC, LCC )
ELSE
ISAME( 11 ) = LDERES( 'SY', UPLO, N, N, CS,
$ CC, LDC )
END IF
ISAME( 12 ) = LDCS.EQ.LDC
*
* If data was incorrectly changed, report and
* return.
*
SAME = .TRUE.
DO 40 I = 1, NARGS
SAME = SAME.AND.ISAME( I )
IF( .NOT.ISAME( I ) )
$ WRITE( NOUT, FMT = 9998 )I
40 CONTINUE
IF( .NOT.SAME )THEN
FATAL = .TRUE.
GO TO 150
END IF
*
IF( .NOT.NULL )THEN
*
* Check the result column by column.
*
JJAB = 1
JC = 1
DO 70 J = 1, N
IF( UPPER )THEN
JJ = 1
LJ = J
ELSE
JJ = J
LJ = N - J + 1
END IF
IF( TRAN )THEN
DO 50 I = 1, K
W( I ) = AB( ( J - 1 )*2*NMAX + K +
$ I )
W( K + I ) = AB( ( J - 1 )*2*NMAX +
$ I )
50 CONTINUE
CALL DMMCH( 'T', 'N', LJ, 1, 2*K,
$ ALPHA, AB( JJAB ), 2*NMAX,
$ W, 2*NMAX, BETA,
$ C( JJ, J ), NMAX, CT, G,
$ CC( JC ), LDC, EPS, ERR,
$ FATAL, NOUT, .TRUE. )
ELSE
DO 60 I = 1, K
W( I ) = AB( ( K + I - 1 )*NMAX +
$ J )
W( K + I ) = AB( ( I - 1 )*NMAX +
$ J )
60 CONTINUE
CALL DMMCH( 'N', 'N', LJ, 1, 2*K,
$ ALPHA, AB( JJ ), NMAX, W,
$ 2*NMAX, BETA, C( JJ, J ),
$ NMAX, CT, G, CC( JC ), LDC,
$ EPS, ERR, FATAL, NOUT,
$ .TRUE. )
END IF
IF( UPPER )THEN
JC = JC + LDC
ELSE
JC = JC + LDC + 1
IF( TRAN )
$ JJAB = JJAB + 2*NMAX
END IF
ERRMAX = MAX( ERRMAX, ERR )
* If got really bad answer, report and
* return.
IF( FATAL )
$ GO TO 140
70 CONTINUE
END IF
*
80 CONTINUE
*
90 CONTINUE
*
100 CONTINUE
*
110 CONTINUE
*
120 CONTINUE
*
130 CONTINUE
*
* Report result.
*
IF( ERRMAX.LT.THRESH )THEN
WRITE( NOUT, FMT = 9999 )SNAME, NC
ELSE
WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
END IF
GO TO 160
*
140 CONTINUE
IF( N.GT.1 )
$ WRITE( NOUT, FMT = 9995 )J
*
150 CONTINUE
WRITE( NOUT, FMT = 9996 )SNAME
WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA,
$ LDA, LDB, BETA, LDC
*
160 CONTINUE
RETURN
*
9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
$ 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
$ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
$ ' - SUSPECT *******' )
9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
$ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ',
$ ' .' )
9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
* End of DCHK5.
*
END
SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT )
*
* Tests the error exits from the Level 3 Blas.
* Requires a special version of the error-handling routine XERBLA.
* A, B and C should not need to be defined.
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- 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.
*
* 3-19-92: Initialize ALPHA and BETA (eca)
* 3-19-92: Fix argument 12 in calls to SSYMM with INFOT = 9 (eca)
*
* .. Scalar Arguments ..
INTEGER ISNUM, NOUT
CHARACTER*6 SRNAMT
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
* .. Parameters ..
DOUBLE PRECISION ONE, TWO
PARAMETER ( ONE = 1.0D0, TWO = 2.0D0 )
* .. Local Scalars ..
DOUBLE PRECISION ALPHA, BETA
* .. Local Arrays ..
DOUBLE PRECISION A( 2, 1 ), B( 2, 1 ), C( 2, 1 )
* .. External Subroutines ..
EXTERNAL CHKXER, DGEMM, DSYMM, DSYR2K, DSYRK, DTRMM,
$ DTRSM
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
* .. Executable Statements ..
* OK is set to .FALSE. by the special version of XERBLA or by CHKXER
* if anything is wrong.
OK = .TRUE.
* LERR is set to .TRUE. by the special version of XERBLA each time
* it is called, and is then tested and re-set by CHKXER.
LERR = .FALSE.
*
* Initialize ALPHA and BETA.
*
ALPHA = ONE
BETA = TWO
*
GO TO ( 10, 20, 30, 40, 50, 60 )ISNUM
10 INFOT = 1
CALL DGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 1
CALL DGEMM( '/', 'T', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGEMM( 'N', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGEMM( 'T', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGEMM( 'N', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGEMM( 'N', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGEMM( 'T', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGEMM( 'T', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGEMM( 'N', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGEMM( 'N', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGEMM( 'T', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGEMM( 'T', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGEMM( 'N', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGEMM( 'N', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGEMM( 'T', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGEMM( 'T', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DGEMM( 'T', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DGEMM( 'N', 'N', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DGEMM( 'N', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DGEMM( 'T', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 13
CALL DGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 13
CALL DGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 13
CALL DGEMM( 'T', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 13
CALL DGEMM( 'T', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 70
20 INFOT = 1
CALL DSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSYMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSYMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSYMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSYMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSYMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DSYMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DSYMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DSYMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DSYMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DSYMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DSYMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DSYMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 70
30 INFOT = 1
CALL DTRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTRMM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DTRMM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DTRMM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTRMM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTRMM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTRMM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTRMM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTRMM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTRMM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTRMM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTRMM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DTRMM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DTRMM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DTRMM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DTRMM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DTRMM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DTRMM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DTRMM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DTRMM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DTRMM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DTRMM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DTRMM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DTRMM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DTRMM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DTRMM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DTRMM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DTRMM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 70
40 INFOT = 1
CALL DTRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTRSM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DTRSM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DTRSM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTRSM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTRSM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTRSM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTRSM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTRSM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTRSM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTRSM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTRSM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DTRSM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DTRSM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DTRSM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DTRSM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DTRSM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DTRSM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DTRSM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DTRSM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DTRSM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DTRSM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DTRSM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DTRSM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DTRSM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DTRSM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DTRSM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DTRSM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 70
50 INFOT = 1
CALL DSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSYRK( 'U', '/', 0, 0, ALPHA, A, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSYRK( 'U', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSYRK( 'U', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSYRK( 'L', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSYRK( 'L', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DSYRK( 'U', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DSYRK( 'U', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DSYRK( 'L', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DSYRK( 'L', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DSYRK( 'U', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DSYRK( 'U', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DSYRK( 'L', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DSYRK( 'L', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DSYRK( 'U', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DSYRK( 'U', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DSYRK( 'L', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DSYRK( 'L', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 70
60 INFOT = 1
CALL DSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSYR2K( 'U', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSYR2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSYR2K( 'U', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSYR2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSYR2K( 'L', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DSYR2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DSYR2K( 'U', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DSYR2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DSYR2K( 'L', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DSYR2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DSYR2K( 'U', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DSYR2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DSYR2K( 'L', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DSYR2K( 'U', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DSYR2K( 'L', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DSYR2K( 'U', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
*
70 IF( OK )THEN
WRITE( NOUT, FMT = 9999 )SRNAMT
ELSE
WRITE( NOUT, FMT = 9998 )SRNAMT
END IF
RETURN
*
9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' )
9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****',
$ '**' )
*
* End of DCHKE.
*
END
SUBROUTINE DMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET,
$ TRANSL )
*
* Generates values for an M by N matrix A.
* Stores the values in the array AA in the data structure required
* by the routine, with unwanted elements set to rogue value.
*
* TYPE is 'GE', 'SY' or 'TR'.
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- 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.
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
DOUBLE PRECISION ROGUE
PARAMETER ( ROGUE = -1.0D10 )
* .. Scalar Arguments ..
DOUBLE PRECISION TRANSL
INTEGER LDA, M, N, NMAX
LOGICAL RESET
CHARACTER*1 DIAG, UPLO
CHARACTER*2 TYPE
* .. Array Arguments ..
DOUBLE PRECISION A( NMAX, * ), AA( * )
* .. Local Scalars ..
INTEGER I, IBEG, IEND, J
LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER
* .. External Functions ..
DOUBLE PRECISION DBEG
EXTERNAL DBEG
* .. Executable Statements ..
GEN = TYPE.EQ.'GE'
SYM = TYPE.EQ.'SY'
TRI = TYPE.EQ.'TR'
UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U'
LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L'
UNIT = TRI.AND.DIAG.EQ.'U'
*
* Generate data in array A.
*
DO 20 J = 1, N
DO 10 I = 1, M
IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) )
$ THEN
A( I, J ) = DBEG( RESET ) + TRANSL
IF( I.NE.J )THEN
* Set some elements to zero
IF( N.GT.3.AND.J.EQ.N/2 )
$ A( I, J ) = ZERO
IF( SYM )THEN
A( J, I ) = A( I, J )
ELSE IF( TRI )THEN
A( J, I ) = ZERO
END IF
END IF
END IF
10 CONTINUE
IF( TRI )
$ A( J, J ) = A( J, J ) + ONE
IF( UNIT )
$ A( J, J ) = ONE
20 CONTINUE
*
* Store elements in array AS in data structure required by routine.
*
IF( TYPE.EQ.'GE' )THEN
DO 50 J = 1, N
DO 30 I = 1, M
AA( I + ( J - 1 )*LDA ) = A( I, J )
30 CONTINUE
DO 40 I = M + 1, LDA
AA( I + ( J - 1 )*LDA ) = ROGUE
40 CONTINUE
50 CONTINUE
ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN
DO 90 J = 1, N
IF( UPPER )THEN
IBEG = 1
IF( UNIT )THEN
IEND = J - 1
ELSE
IEND = J
END IF
ELSE
IF( UNIT )THEN
IBEG = J + 1
ELSE
IBEG = J
END IF
IEND = N
END IF
DO 60 I = 1, IBEG - 1
AA( I + ( J - 1 )*LDA ) = ROGUE
60 CONTINUE
DO 70 I = IBEG, IEND
AA( I + ( J - 1 )*LDA ) = A( I, J )
70 CONTINUE
DO 80 I = IEND + 1, LDA
AA( I + ( J - 1 )*LDA ) = ROGUE
80 CONTINUE
90 CONTINUE
END IF
RETURN
*
* End of DMAKE.
*
END
SUBROUTINE DMMCH( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB,
$ BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL,
$ NOUT, MV )
*
* Checks the results of the computational tests.
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- 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.
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA, BETA, EPS, ERR
INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT
LOGICAL FATAL, MV
CHARACTER*1 TRANSA, TRANSB
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ),
$ CC( LDCC, * ), CT( * ), G( * )
* .. Local Scalars ..
DOUBLE PRECISION ERRI
INTEGER I, J, K
LOGICAL TRANA, TRANB
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* .. Executable Statements ..
TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
*
* Compute expected result, one column at a time, in CT using data
* in A, B and C.
* Compute gauges in G.
*
DO 120 J = 1, N
*
DO 10 I = 1, M
CT( I ) = ZERO
G( I ) = ZERO
10 CONTINUE
IF( .NOT.TRANA.AND..NOT.TRANB )THEN
DO 30 K = 1, KK
DO 20 I = 1, M
CT( I ) = CT( I ) + A( I, K )*B( K, J )
G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( K, J ) )
20 CONTINUE
30 CONTINUE
ELSE IF( TRANA.AND..NOT.TRANB )THEN
DO 50 K = 1, KK
DO 40 I = 1, M
CT( I ) = CT( I ) + A( K, I )*B( K, J )
G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( K, J ) )
40 CONTINUE
50 CONTINUE
ELSE IF( .NOT.TRANA.AND.TRANB )THEN
DO 70 K = 1, KK
DO 60 I = 1, M
CT( I ) = CT( I ) + A( I, K )*B( J, K )
G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( J, K ) )
60 CONTINUE
70 CONTINUE
ELSE IF( TRANA.AND.TRANB )THEN
DO 90 K = 1, KK
DO 80 I = 1, M
CT( I ) = CT( I ) + A( K, I )*B( J, K )
G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( J, K ) )
80 CONTINUE
90 CONTINUE
END IF
DO 100 I = 1, M
CT( I ) = ALPHA*CT( I ) + BETA*C( I, J )
G( I ) = ABS( ALPHA )*G( I ) + ABS( BETA )*ABS( C( I, J ) )
100 CONTINUE
*
* Compute the error ratio for this result.
*
ERR = ZERO
DO 110 I = 1, M
ERRI = ABS( CT( I ) - CC( I, J ) )/EPS
IF( G( I ).NE.ZERO )
$ ERRI = ERRI/G( I )
ERR = MAX( ERR, ERRI )
IF( ERR*SQRT( EPS ).GE.ONE )
$ GO TO 130
110 CONTINUE
*
120 CONTINUE
*
* If the loop completes, all results are at least half accurate.
GO TO 150
*
* Report fatal error.
*
130 FATAL = .TRUE.
WRITE( NOUT, FMT = 9999 )
DO 140 I = 1, M
IF( MV )THEN
WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J )
ELSE
WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I )
END IF
140 CONTINUE
IF( N.GT.1 )
$ WRITE( NOUT, FMT = 9997 )J
*
150 CONTINUE
RETURN
*
9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
$ 'F ACCURATE *******', /' EXPECTED RESULT COMPU',
$ 'TED RESULT' )
9998 FORMAT( 1X, I7, 2G18.6 )
9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
*
* End of DMMCH.
*
END
LOGICAL FUNCTION LDE( RI, RJ, LR )
*
* Tests if two arrays are identical.
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- 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.
*
* .. Scalar Arguments ..
INTEGER LR
* .. Array Arguments ..
DOUBLE PRECISION RI( * ), RJ( * )
* .. Local Scalars ..
INTEGER I
* .. Executable Statements ..
DO 10 I = 1, LR
IF( RI( I ).NE.RJ( I ) )
$ GO TO 20
10 CONTINUE
LDE = .TRUE.
GO TO 30
20 CONTINUE
LDE = .FALSE.
30 RETURN
*
* End of LDE.
*
END
LOGICAL FUNCTION LDERES( TYPE, UPLO, M, N, AA, AS, LDA )
*
* Tests if selected elements in two arrays are equal.
*
* TYPE is 'GE' or 'SY'.
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- 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.
*
* .. Scalar Arguments ..
INTEGER LDA, M, N
CHARACTER*1 UPLO
CHARACTER*2 TYPE
* .. Array Arguments ..
DOUBLE PRECISION AA( LDA, * ), AS( LDA, * )
* .. Local Scalars ..
INTEGER I, IBEG, IEND, J
LOGICAL UPPER
* .. Executable Statements ..
UPPER = UPLO.EQ.'U'
IF( TYPE.EQ.'GE' )THEN
DO 20 J = 1, N
DO 10 I = M + 1, LDA
IF( AA( I, J ).NE.AS( I, J ) )
$ GO TO 70
10 CONTINUE
20 CONTINUE
ELSE IF( TYPE.EQ.'SY' )THEN
DO 50 J = 1, N
IF( UPPER )THEN
IBEG = 1
IEND = J
ELSE
IBEG = J
IEND = N
END IF
DO 30 I = 1, IBEG - 1
IF( AA( I, J ).NE.AS( I, J ) )
$ GO TO 70
30 CONTINUE
DO 40 I = IEND + 1, LDA
IF( AA( I, J ).NE.AS( I, J ) )
$ GO TO 70
40 CONTINUE
50 CONTINUE
END IF
*
60 CONTINUE
LDERES = .TRUE.
GO TO 80
70 CONTINUE
LDERES = .FALSE.
80 RETURN
*
* End of LDERES.
*
END
DOUBLE PRECISION FUNCTION DBEG( RESET )
*
* Generates random numbers uniformly distributed between -0.5 and 0.5.
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- 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.
*
* .. Scalar Arguments ..
LOGICAL RESET
* .. Local Scalars ..
INTEGER I, IC, MI
* .. Save statement ..
SAVE I, IC, MI
* .. Executable Statements ..
IF( RESET )THEN
* Initialize local variables.
MI = 891
I = 7
IC = 0
RESET = .FALSE.
END IF
*
* The sequence of values of I is bounded between 1 and 999.
* If initial I = 1,2,3,6,7 or 9, the period will be 50.
* If initial I = 4 or 8, the period will be 25.
* If initial I = 5, the period will be 10.
* IC is used to break up the period by skipping 1 value of I in 6.
*
IC = IC + 1
10 I = I*MI
I = I - 1000*( I/1000 )
IF( IC.GE.5 )THEN
IC = 0
GO TO 10
END IF
DBEG = ( I - 500 )/1001.0D0
RETURN
*
* End of DBEG.
*
END
DOUBLE PRECISION FUNCTION DDIFF( X, Y )
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- 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.
*
* .. Scalar Arguments ..
DOUBLE PRECISION X, Y
* .. Executable Statements ..
DDIFF = X - Y
RETURN
*
* End of DDIFF.
*
END
SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
*
* Tests whether XERBLA has detected an error when it should.
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- 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.
*
* .. Scalar Arguments ..
INTEGER INFOT, NOUT
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
* .. Executable Statements ..
IF( .NOT.LERR )THEN
WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT
OK = .FALSE.
END IF
LERR = .FALSE.
RETURN
*
9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D',
$ 'ETECTED BY ', A6, ' *****' )
*
* End of CHKXER.
*
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/blas3/xerbla.f 0000644 0001750 0001750 00000003551 10616163233 023651 0 ustar osallou osallou SUBROUTINE XERBLA( SRNAME, INFO )
*
* f2j NOTE: this is compiled separately from dblat2.f because
* it needs to be in package org.netlib.err while the rest of
* dblat2.f routines should be in org.netlib.blas.testing.
*
* This is a special version of XERBLA to be used only as part of
* the test program for testing error exits from the Level 3 BLAS
* routines.
*
* XERBLA is an error handler for the Level 3 BLAS routines.
*
* It is called by the Level 3 BLAS routines if an input parameter is
* invalid.
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- 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.
*
* .. Scalar Arguments ..
INTEGER INFO
CHARACTER*6 SRNAME
* .. Scalars in Common ..
INTEGER INFOT, NOUT
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUT, OK, LERR
COMMON /SRNAMC/SRNAMT
* .. Executable Statements ..
LERR = .TRUE.
IF( INFO.NE.INFOT )THEN
IF( INFOT.NE.0 )THEN
WRITE( NOUT, FMT = 9999 )INFO, INFOT
ELSE
WRITE( NOUT, FMT = 9997 )INFO
END IF
OK = .FALSE.
END IF
IF( SRNAME.NE.SRNAMT )THEN
WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT
OK = .FALSE.
END IF
RETURN
*
9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD',
$ ' OF ', I2, ' *******' )
9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE',
$ 'AD OF ', A6, ' *******' )
9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6,
$ ' *******' )
*
* End of XERBLA
*
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/sblas2/ 0000755 0001750 0001750 00000000000 11734055025 022404 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/sblas2/Makefile_javasrc 0000644 0001750 0001750 00000002650 10616442122 025554 0 ustar osallou osallou .SUFFIXES: .f .java
ROOT=../../..
include $(ROOT)/make.def
tester: $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(SBLAS2TEST_IDX) $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
/bin/rm -f `find $(OUTDIR) -name "*.class"`
mkdir -p $(JAVASRC_OUTDIR)
$(JAVAC) -classpath .:$(JAVASRC_OUTDIR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) -d $(JAVASRC_OUTDIR) $(OUTDIR)/$(SBLASTEST_PDIR)/*.java
/bin/rm -f $(JAVASRC_OUTDIR)/$(SBLASTEST_PDIR)/*.old
$(JAVAB) $(JAVASRC_OUTDIR)/$(SBLASTEST_PDIR)/*.class
/bin/rm -f $(SBLAS2TEST_JAR)
cd $(JAVASRC_OUTDIR); $(JAR) cvf ../$(SBLAS2TEST_JAR) `find . -name "*.class"`
$(JAR) uvf $(SBLAS2TEST_JAR) `find org -name "*.class"`
$(ROOT)/$(SBLAS2TEST_IDX): sblat2.f
$(MAKE) nojar
$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):
cd $(ROOT)/$(BLAS_DIR); $(MAKE) -f Makefile_javasrc
$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):
cd $(ROOT)/$(UTIL_DIR); $(MAKE)
runtest: tester
$(JAVA) $(JFLAGS) -cp .:$(SBLAS2TEST_JAR):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR) $(SBLASTEST_PACKAGE).Sblat2 < sblat2.in
verify: $(ROOT)/$(SBLAS2TEST_IDX)
cd $(JAVASRC_OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:..:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR) $(VERIFY) $(SBLASTEST_PDIR)/*.class
clean:
/bin/rm -rf *.java *.class *.f2j org $(OUTDIR) $(JAVASRC_OUTDIR) $(SBLAS2TEST_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/sblas2/sblat2.f 0000644 0001750 0001750 00000326507 10616163240 023754 0 ustar osallou osallou PROGRAM SBLAT2
*
* Test program for the REAL Level 2 Blas.
*
* The program must be driven by a short data file. The first 18 records
* of the file are read using list-directed input, the last 16 records
* are read using the format ( A6, L2 ). An annotated example of a data
* file can be obtained by deleting the first 3 characters from the
* following 34 lines:
* 'sblat2.out' NAME OF SUMMARY OUTPUT FILE
* 6 UNIT NUMBER OF SUMMARY FILE
* 'SBLAT2.SNAP' NAME OF SNAPSHOT OUTPUT FILE
* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
* F LOGICAL FLAG, T TO STOP ON FAILURES.
* T LOGICAL FLAG, T TO TEST ERROR EXITS.
* 16.0 THRESHOLD VALUE OF TEST RATIO
* 6 NUMBER OF VALUES OF N
* 0 1 2 3 5 9 VALUES OF N
* 4 NUMBER OF VALUES OF K
* 0 1 2 4 VALUES OF K
* 4 NUMBER OF VALUES OF INCX AND INCY
* 1 2 -1 -2 VALUES OF INCX AND INCY
* 3 NUMBER OF VALUES OF ALPHA
* 0.0 1.0 0.7 VALUES OF ALPHA
* 3 NUMBER OF VALUES OF BETA
* 0.0 1.0 0.9 VALUES OF BETA
* SGEMV T PUT F FOR NO TEST. SAME COLUMNS.
* SGBMV T PUT F FOR NO TEST. SAME COLUMNS.
* SSYMV T PUT F FOR NO TEST. SAME COLUMNS.
* SSBMV T PUT F FOR NO TEST. SAME COLUMNS.
* SSPMV T PUT F FOR NO TEST. SAME COLUMNS.
* STRMV T PUT F FOR NO TEST. SAME COLUMNS.
* STBMV T PUT F FOR NO TEST. SAME COLUMNS.
* STPMV T PUT F FOR NO TEST. SAME COLUMNS.
* STRSV T PUT F FOR NO TEST. SAME COLUMNS.
* STBSV T PUT F FOR NO TEST. SAME COLUMNS.
* STPSV T PUT F FOR NO TEST. SAME COLUMNS.
* SGER T PUT F FOR NO TEST. SAME COLUMNS.
* SSYR T PUT F FOR NO TEST. SAME COLUMNS.
* SSPR T PUT F FOR NO TEST. SAME COLUMNS.
* SSYR2 T PUT F FOR NO TEST. SAME COLUMNS.
* SSPR2 T PUT F FOR NO TEST. SAME COLUMNS.
*
* See:
*
* Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J..
* An extended set of Fortran Basic Linear Algebra Subprograms.
*
* Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics
* and Computer Science Division, Argonne National Laboratory,
* 9700 South Cass Avenue, Argonne, Illinois 60439, US.
*
* Or
*
* NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms
* Group Ltd., NAG Central Office, 256 Banbury Road, Oxford
* OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st
* Street, Suite 100, Downers Grove, Illinois 60515-1263, USA.
*
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers
* can be run multiple times without deleting generated
* output files (susan)
*
* .. Parameters ..
INTEGER NIN
PARAMETER ( NIN = 5 )
INTEGER NSUBS
PARAMETER ( NSUBS = 16 )
REAL ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 )
INTEGER NMAX, INCMAX
PARAMETER ( NMAX = 65, INCMAX = 2 )
INTEGER NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX
PARAMETER ( NINMAX = 7, NIDMAX = 9, NKBMAX = 7,
$ NALMAX = 7, NBEMAX = 7 )
* .. Local Scalars ..
REAL EPS, ERR, THRESH
INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, NKB,
$ NOUT, NTRA
LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
$ TSTERR
CHARACTER*1 TRANS
CHARACTER*6 SNAMET
CHARACTER*32 SNAPS, SUMMRY
* .. Local Arrays ..
REAL A( NMAX, NMAX ), AA( NMAX*NMAX ),
$ ALF( NALMAX ), AS( NMAX*NMAX ), BET( NBEMAX ),
$ G( NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
$ XX( NMAX*INCMAX ), Y( NMAX ),
$ YS( NMAX*INCMAX ), YT( NMAX ),
$ YY( NMAX*INCMAX ), Z( 2*NMAX )
INTEGER IDIM( NIDMAX ), INC( NINMAX ), KB( NKBMAX )
LOGICAL LTEST( NSUBS )
CHARACTER*6 SNAMES( NSUBS )
* .. External Functions ..
REAL SDIFF
LOGICAL LSE
EXTERNAL SDIFF, LSE
* .. External Subroutines ..
EXTERNAL SCHK1, SCHK2, SCHK3, SCHK4, SCHK5, SCHK6,
$ SCHKE, SMVCH
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
COMMON /SRNAMC/SRNAMT
* .. Data statements ..
DATA SNAMES/'SGEMV ', 'SGBMV ', 'SSYMV ', 'SSBMV ',
$ 'SSPMV ', 'STRMV ', 'STBMV ', 'STPMV ',
$ 'STRSV ', 'STBSV ', 'STPSV ', 'SGER ',
$ 'SSYR ', 'SSPR ', 'SSYR2 ', 'SSPR2 '/
* .. Executable Statements ..
*
* Read name and unit number for summary output file and open file.
*
READ( NIN, FMT = * )SUMMRY
READ( NIN, FMT = * )NOUT
OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' )
NOUTC = NOUT
*
* Read name and unit number for snapshot output file and open file.
*
READ( NIN, FMT = * )SNAPS
READ( NIN, FMT = * )NTRA
TRACE = NTRA.GE.0
IF( TRACE )THEN
OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' )
END IF
* Read the flag that directs rewinding of the snapshot file.
READ( NIN, FMT = * )REWI
REWI = REWI.AND.TRACE
* Read the flag that directs stopping on any failure.
READ( NIN, FMT = * )SFATAL
* Read the flag that indicates whether error exits are to be tested.
READ( NIN, FMT = * )TSTERR
* Read the threshold value of the test ratio
READ( NIN, FMT = * )THRESH
*
* Read and check the parameter values for the tests.
*
* Values of N
READ( NIN, FMT = * )NIDIM
IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN
WRITE( NOUT, FMT = 9997 )'N', NIDMAX
GO TO 230
END IF
READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM )
DO 10 I = 1, NIDIM
IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN
WRITE( NOUT, FMT = 9996 )NMAX
GO TO 230
END IF
10 CONTINUE
* Values of K
READ( NIN, FMT = * )NKB
IF( NKB.LT.1.OR.NKB.GT.NKBMAX )THEN
WRITE( NOUT, FMT = 9997 )'K', NKBMAX
GO TO 230
END IF
READ( NIN, FMT = * )( KB( I ), I = 1, NKB )
DO 20 I = 1, NKB
IF( KB( I ).LT.0 )THEN
WRITE( NOUT, FMT = 9995 )
GO TO 230
END IF
20 CONTINUE
* Values of INCX and INCY
READ( NIN, FMT = * )NINC
IF( NINC.LT.1.OR.NINC.GT.NINMAX )THEN
WRITE( NOUT, FMT = 9997 )'INCX AND INCY', NINMAX
GO TO 230
END IF
READ( NIN, FMT = * )( INC( I ), I = 1, NINC )
DO 30 I = 1, NINC
IF( INC( I ).EQ.0.OR.ABS( INC( I ) ).GT.INCMAX )THEN
WRITE( NOUT, FMT = 9994 )INCMAX
GO TO 230
END IF
30 CONTINUE
* Values of ALPHA
READ( NIN, FMT = * )NALF
IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN
WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX
GO TO 230
END IF
READ( NIN, FMT = * )( ALF( I ), I = 1, NALF )
* Values of BETA
READ( NIN, FMT = * )NBET
IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN
WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX
GO TO 230
END IF
READ( NIN, FMT = * )( BET( I ), I = 1, NBET )
*
* Report values of parameters.
*
WRITE( NOUT, FMT = 9993 )
WRITE( NOUT, FMT = 9992 )( IDIM( I ), I = 1, NIDIM )
WRITE( NOUT, FMT = 9991 )( KB( I ), I = 1, NKB )
WRITE( NOUT, FMT = 9990 )( INC( I ), I = 1, NINC )
WRITE( NOUT, FMT = 9989 )( ALF( I ), I = 1, NALF )
WRITE( NOUT, FMT = 9988 )( BET( I ), I = 1, NBET )
IF( .NOT.TSTERR )THEN
WRITE( NOUT, FMT = * )
WRITE( NOUT, FMT = 9980 )
END IF
WRITE( NOUT, FMT = * )
WRITE( NOUT, FMT = 9999 )THRESH
WRITE( NOUT, FMT = * )
*
* Read names of subroutines and flags which indicate
* whether they are to be tested.
*
DO 40 I = 1, NSUBS
LTEST( I ) = .FALSE.
40 CONTINUE
50 READ( NIN, FMT = 9984, END = 80 )SNAMET, LTESTT
DO 60 I = 1, NSUBS
IF( SNAMET.EQ.SNAMES( I ) )
$ GO TO 70
60 CONTINUE
WRITE( NOUT, FMT = 9986 )SNAMET
STOP
70 LTEST( I ) = LTESTT
GO TO 50
*
80 CONTINUE
CLOSE ( NIN )
*
* Compute EPS (the machine precision).
*
EPS = ONE
90 CONTINUE
IF( SDIFF( ONE + EPS, ONE ).EQ.ZERO )
$ GO TO 100
EPS = HALF*EPS
GO TO 90
100 CONTINUE
EPS = EPS + EPS
WRITE( NOUT, FMT = 9998 )EPS
*
* Check the reliability of SMVCH using exact data.
*
N = MIN( 32, NMAX )
DO 120 J = 1, N
DO 110 I = 1, N
A( I, J ) = MAX( I - J + 1, 0 )
110 CONTINUE
X( J ) = J
Y( J ) = ZERO
120 CONTINUE
DO 130 J = 1, N
YY( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3
130 CONTINUE
* YY holds the exact result. On exit from SMVCH YT holds
* the result computed by SMVCH.
TRANS = 'N'
CALL SMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G,
$ YY, EPS, ERR, FATAL, NOUT, .TRUE. )
SAME = LSE( YY, YT, N )
IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR
STOP
END IF
TRANS = 'T'
CALL SMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G,
$ YY, EPS, ERR, FATAL, NOUT, .TRUE. )
SAME = LSE( YY, YT, N )
IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR
STOP
END IF
*
* Test each subroutine in turn.
*
DO 210 ISNUM = 1, NSUBS
WRITE( NOUT, FMT = * )
IF( .NOT.LTEST( ISNUM ) )THEN
* Subprogram is not to be tested.
WRITE( NOUT, FMT = 9983 )SNAMES( ISNUM )
ELSE
SRNAMT = SNAMES( ISNUM )
* Test error exits.
IF( TSTERR )THEN
CALL SCHKE( ISNUM, SNAMES( ISNUM ), NOUT )
WRITE( NOUT, FMT = * )
END IF
* Test computations.
INFOT = 0
OK = .TRUE.
FATAL = .FALSE.
GO TO ( 140, 140, 150, 150, 150, 160, 160,
$ 160, 160, 160, 160, 170, 180, 180,
$ 190, 190 )ISNUM
* Test SGEMV, 01, and SGBMV, 02.
140 CALL SCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF,
$ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS,
$ X, XX, XS, Y, YY, YS, YT, G )
GO TO 200
* Test SSYMV, 03, SSBMV, 04, and SSPMV, 05.
150 CALL SCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF,
$ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS,
$ X, XX, XS, Y, YY, YS, YT, G )
GO TO 200
* Test STRMV, 06, STBMV, 07, STPMV, 08,
* STRSV, 09, STBSV, 10, and STPSV, 11.
160 CALL SCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC,
$ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z )
GO TO 200
* Test SGER, 12.
170 CALL SCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
$ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
$ YT, G, Z )
GO TO 200
* Test SSYR, 13, and SSPR, 14.
180 CALL SCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
$ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
$ YT, G, Z )
GO TO 200
* Test SSYR2, 15, and SSPR2, 16.
190 CALL SCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
$ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
$ YT, G, Z )
*
200 IF( FATAL.AND.SFATAL )
$ GO TO 220
END IF
210 CONTINUE
WRITE( NOUT, FMT = 9982 )
GO TO 240
*
220 CONTINUE
WRITE( NOUT, FMT = 9981 )
GO TO 240
*
230 CONTINUE
WRITE( NOUT, FMT = 9987 )
*
240 CONTINUE
IF( TRACE )
$ CLOSE ( NTRA )
CLOSE ( NOUT )
STOP
*
9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES',
$ 'S THAN', F8.2 )
9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 )
9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ',
$ 'THAN ', I2 )
9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 )
9995 FORMAT( ' VALUE OF K IS LESS THAN 0' )
9994 FORMAT( ' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ',
$ I2 )
9993 FORMAT( ' TESTS OF THE REAL LEVEL 2 BLAS', //' THE F',
$ 'OLLOWING PARAMETER VALUES WILL BE USED:' )
9992 FORMAT( ' FOR N ', 9I6 )
9991 FORMAT( ' FOR K ', 7I6 )
9990 FORMAT( ' FOR INCX AND INCY ', 7I6 )
9989 FORMAT( ' FOR ALPHA ', 7F6.1 )
9988 FORMAT( ' FOR BETA ', 7F6.1 )
9987 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
$ /' ******* TESTS ABANDONED *******' )
9986 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T',
$ 'ESTS ABANDONED *******' )
9985 FORMAT( ' ERROR IN SMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
$ 'ATED WRONGLY.', /' SMVCH WAS CALLED WITH TRANS = ', A1,
$ ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '.', /
$ ' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.'
$ , /' ******* TESTS ABANDONED *******' )
9984 FORMAT( A6, L2 )
9983 FORMAT( 1X, A6, ' WAS NOT TESTED' )
9982 FORMAT( /' END OF TESTS' )
9981 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
*
* End of SBLAT2.
*
END
SUBROUTINE SCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET,
$ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX,
$ XS, Y, YY, YS, YT, G )
*
* Tests SGEMV and SGBMV.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Parameters ..
REAL ZERO, HALF
PARAMETER ( ZERO = 0.0, HALF = 0.5 )
* .. Scalar Arguments ..
REAL EPS, THRESH
INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
$ NOUT, NTRA
LOGICAL FATAL, REWI, TRACE
CHARACTER*6 SNAME
* .. Array Arguments ..
REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ),
$ X( NMAX ), XS( NMAX*INCMAX ),
$ XX( NMAX*INCMAX ), Y( NMAX ),
$ YS( NMAX*INCMAX ), YT( NMAX ),
$ YY( NMAX*INCMAX )
INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
* .. Local Scalars ..
REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL
INTEGER I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY,
$ INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA,
$ LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK,
$ NL, NS
LOGICAL BANDED, FULL, NULL, RESET, SAME, TRAN
CHARACTER*1 TRANS, TRANSS
CHARACTER*3 ICH
* .. Local Arrays ..
LOGICAL ISAME( 13 )
* .. External Functions ..
LOGICAL LSE, LSERES
EXTERNAL LSE, LSERES
* .. External Subroutines ..
EXTERNAL SGBMV, SGEMV, SMAKE, SMVCH
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
* .. Data statements ..
DATA ICH/'NTC'/
* .. Executable Statements ..
FULL = SNAME( 3: 3 ).EQ.'E'
BANDED = SNAME( 3: 3 ).EQ.'B'
* Define the number of arguments.
IF( FULL )THEN
NARGS = 11
ELSE IF( BANDED )THEN
NARGS = 13
END IF
*
NC = 0
RESET = .TRUE.
ERRMAX = ZERO
*
DO 120 IN = 1, NIDIM
N = IDIM( IN )
ND = N/2 + 1
*
DO 110 IM = 1, 2
IF( IM.EQ.1 )
$ M = MAX( N - ND, 0 )
IF( IM.EQ.2 )
$ M = MIN( N + ND, NMAX )
*
IF( BANDED )THEN
NK = NKB
ELSE
NK = 1
END IF
DO 100 IKU = 1, NK
IF( BANDED )THEN
KU = KB( IKU )
KL = MAX( KU - 1, 0 )
ELSE
KU = N - 1
KL = M - 1
END IF
* Set LDA to 1 more than minimum value if room.
IF( BANDED )THEN
LDA = KL + KU + 1
ELSE
LDA = M
END IF
IF( LDA.LT.NMAX )
$ LDA = LDA + 1
* Skip tests if not enough room.
IF( LDA.GT.NMAX )
$ GO TO 100
LAA = LDA*N
NULL = N.LE.0.OR.M.LE.0
*
* Generate the matrix A.
*
TRANSL = ZERO
CALL SMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, AA,
$ LDA, KL, KU, RESET, TRANSL )
*
DO 90 IC = 1, 3
TRANS = ICH( IC: IC )
TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
*
IF( TRAN )THEN
ML = N
NL = M
ELSE
ML = M
NL = N
END IF
*
DO 80 IX = 1, NINC
INCX = INC( IX )
LX = ABS( INCX )*NL
*
* Generate the vector X.
*
TRANSL = HALF
CALL SMAKE( 'GE', ' ', ' ', 1, NL, X, 1, XX,
$ ABS( INCX ), 0, NL - 1, RESET, TRANSL )
IF( NL.GT.1 )THEN
X( NL/2 ) = ZERO
XX( 1 + ABS( INCX )*( NL/2 - 1 ) ) = ZERO
END IF
*
DO 70 IY = 1, NINC
INCY = INC( IY )
LY = ABS( INCY )*ML
*
DO 60 IA = 1, NALF
ALPHA = ALF( IA )
*
DO 50 IB = 1, NBET
BETA = BET( IB )
*
* Generate the vector Y.
*
TRANSL = ZERO
CALL SMAKE( 'GE', ' ', ' ', 1, ML, Y, 1,
$ YY, ABS( INCY ), 0, ML - 1,
$ RESET, TRANSL )
*
NC = NC + 1
*
* Save every datum before calling the
* subroutine.
*
TRANSS = TRANS
MS = M
NS = N
KLS = KL
KUS = KU
ALS = ALPHA
DO 10 I = 1, LAA
AS( I ) = AA( I )
10 CONTINUE
LDAS = LDA
DO 20 I = 1, LX
XS( I ) = XX( I )
20 CONTINUE
INCXS = INCX
BLS = BETA
DO 30 I = 1, LY
YS( I ) = YY( I )
30 CONTINUE
INCYS = INCY
*
* Call the subroutine.
*
IF( FULL )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9994 )NC, SNAME,
$ TRANS, M, N, ALPHA, LDA, INCX, BETA,
$ INCY
IF( REWI )
$ REWIND NTRA
CALL SGEMV( TRANS, M, N, ALPHA, AA,
$ LDA, XX, INCX, BETA, YY,
$ INCY )
ELSE IF( BANDED )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9995 )NC, SNAME,
$ TRANS, M, N, KL, KU, ALPHA, LDA,
$ INCX, BETA, INCY
IF( REWI )
$ REWIND NTRA
CALL SGBMV( TRANS, M, N, KL, KU, ALPHA,
$ AA, LDA, XX, INCX, BETA,
$ YY, INCY )
END IF
*
* Check if error-exit was taken incorrectly.
*
IF( .NOT.OK )THEN
WRITE( NOUT, FMT = 9993 )
FATAL = .TRUE.
GO TO 130
END IF
*
* See what data changed inside subroutines.
*
ISAME( 1 ) = TRANS.EQ.TRANSS
ISAME( 2 ) = MS.EQ.M
ISAME( 3 ) = NS.EQ.N
IF( FULL )THEN
ISAME( 4 ) = ALS.EQ.ALPHA
ISAME( 5 ) = LSE( AS, AA, LAA )
ISAME( 6 ) = LDAS.EQ.LDA
ISAME( 7 ) = LSE( XS, XX, LX )
ISAME( 8 ) = INCXS.EQ.INCX
ISAME( 9 ) = BLS.EQ.BETA
IF( NULL )THEN
ISAME( 10 ) = LSE( YS, YY, LY )
ELSE
ISAME( 10 ) = LSERES( 'GE', ' ', 1,
$ ML, YS, YY,
$ ABS( INCY ) )
END IF
ISAME( 11 ) = INCYS.EQ.INCY
ELSE IF( BANDED )THEN
ISAME( 4 ) = KLS.EQ.KL
ISAME( 5 ) = KUS.EQ.KU
ISAME( 6 ) = ALS.EQ.ALPHA
ISAME( 7 ) = LSE( AS, AA, LAA )
ISAME( 8 ) = LDAS.EQ.LDA
ISAME( 9 ) = LSE( XS, XX, LX )
ISAME( 10 ) = INCXS.EQ.INCX
ISAME( 11 ) = BLS.EQ.BETA
IF( NULL )THEN
ISAME( 12 ) = LSE( YS, YY, LY )
ELSE
ISAME( 12 ) = LSERES( 'GE', ' ', 1,
$ ML, YS, YY,
$ ABS( INCY ) )
END IF
ISAME( 13 ) = INCYS.EQ.INCY
END IF
*
* If data was incorrectly changed, report
* and return.
*
SAME = .TRUE.
DO 40 I = 1, NARGS
SAME = SAME.AND.ISAME( I )
IF( .NOT.ISAME( I ) )
$ WRITE( NOUT, FMT = 9998 )I
40 CONTINUE
IF( .NOT.SAME )THEN
FATAL = .TRUE.
GO TO 130
END IF
*
IF( .NOT.NULL )THEN
*
* Check the result.
*
CALL SMVCH( TRANS, M, N, ALPHA, A,
$ NMAX, X, INCX, BETA, Y,
$ INCY, YT, G, YY, EPS, ERR,
$ FATAL, NOUT, .TRUE. )
ERRMAX = MAX( ERRMAX, ERR )
* If got really bad answer, report and
* return.
IF( FATAL )
$ GO TO 130
ELSE
* Avoid repeating tests with M.le.0 or
* N.le.0.
GO TO 110
END IF
*
50 CONTINUE
*
60 CONTINUE
*
70 CONTINUE
*
80 CONTINUE
*
90 CONTINUE
*
100 CONTINUE
*
110 CONTINUE
*
120 CONTINUE
*
* Report result.
*
IF( ERRMAX.LT.THRESH )THEN
WRITE( NOUT, FMT = 9999 )SNAME, NC
ELSE
WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
END IF
GO TO 140
*
130 CONTINUE
WRITE( NOUT, FMT = 9996 )SNAME
IF( FULL )THEN
WRITE( NOUT, FMT = 9994 )NC, SNAME, TRANS, M, N, ALPHA, LDA,
$ INCX, BETA, INCY
ELSE IF( BANDED )THEN
WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANS, M, N, KL, KU,
$ ALPHA, LDA, INCX, BETA, INCY
END IF
*
140 CONTINUE
RETURN
*
9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
$ 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
$ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
$ ' - SUSPECT *******' )
9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 4( I3, ',' ), F4.1,
$ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, ') .' )
9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), F4.1,
$ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2,
$ ') .' )
9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
* End of SCHK1.
*
END
SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET,
$ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX,
$ XS, Y, YY, YS, YT, G )
*
* Tests SSYMV, SSBMV and SSPMV.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Parameters ..
REAL ZERO, HALF
PARAMETER ( ZERO = 0.0, HALF = 0.5 )
* .. Scalar Arguments ..
REAL EPS, THRESH
INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
$ NOUT, NTRA
LOGICAL FATAL, REWI, TRACE
CHARACTER*6 SNAME
* .. Array Arguments ..
REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ),
$ X( NMAX ), XS( NMAX*INCMAX ),
$ XX( NMAX*INCMAX ), Y( NMAX ),
$ YS( NMAX*INCMAX ), YT( NMAX ),
$ YY( NMAX*INCMAX )
INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
* .. Local Scalars ..
REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL
INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY,
$ INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY,
$ N, NARGS, NC, NK, NS
LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME
CHARACTER*1 UPLO, UPLOS
CHARACTER*2 ICH
* .. Local Arrays ..
LOGICAL ISAME( 13 )
* .. External Functions ..
LOGICAL LSE, LSERES
EXTERNAL LSE, LSERES
* .. External Subroutines ..
EXTERNAL SMAKE, SMVCH, SSBMV, SSPMV, SSYMV
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
* .. Data statements ..
DATA ICH/'UL'/
* .. Executable Statements ..
FULL = SNAME( 3: 3 ).EQ.'Y'
BANDED = SNAME( 3: 3 ).EQ.'B'
PACKED = SNAME( 3: 3 ).EQ.'P'
* Define the number of arguments.
IF( FULL )THEN
NARGS = 10
ELSE IF( BANDED )THEN
NARGS = 11
ELSE IF( PACKED )THEN
NARGS = 9
END IF
*
NC = 0
RESET = .TRUE.
ERRMAX = ZERO
*
DO 110 IN = 1, NIDIM
N = IDIM( IN )
*
IF( BANDED )THEN
NK = NKB
ELSE
NK = 1
END IF
DO 100 IK = 1, NK
IF( BANDED )THEN
K = KB( IK )
ELSE
K = N - 1
END IF
* Set LDA to 1 more than minimum value if room.
IF( BANDED )THEN
LDA = K + 1
ELSE
LDA = N
END IF
IF( LDA.LT.NMAX )
$ LDA = LDA + 1
* Skip tests if not enough room.
IF( LDA.GT.NMAX )
$ GO TO 100
IF( PACKED )THEN
LAA = ( N*( N + 1 ) )/2
ELSE
LAA = LDA*N
END IF
NULL = N.LE.0
*
DO 90 IC = 1, 2
UPLO = ICH( IC: IC )
*
* Generate the matrix A.
*
TRANSL = ZERO
CALL SMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, AA,
$ LDA, K, K, RESET, TRANSL )
*
DO 80 IX = 1, NINC
INCX = INC( IX )
LX = ABS( INCX )*N
*
* Generate the vector X.
*
TRANSL = HALF
CALL SMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX,
$ ABS( INCX ), 0, N - 1, RESET, TRANSL )
IF( N.GT.1 )THEN
X( N/2 ) = ZERO
XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
END IF
*
DO 70 IY = 1, NINC
INCY = INC( IY )
LY = ABS( INCY )*N
*
DO 60 IA = 1, NALF
ALPHA = ALF( IA )
*
DO 50 IB = 1, NBET
BETA = BET( IB )
*
* Generate the vector Y.
*
TRANSL = ZERO
CALL SMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY,
$ ABS( INCY ), 0, N - 1, RESET,
$ TRANSL )
*
NC = NC + 1
*
* Save every datum before calling the
* subroutine.
*
UPLOS = UPLO
NS = N
KS = K
ALS = ALPHA
DO 10 I = 1, LAA
AS( I ) = AA( I )
10 CONTINUE
LDAS = LDA
DO 20 I = 1, LX
XS( I ) = XX( I )
20 CONTINUE
INCXS = INCX
BLS = BETA
DO 30 I = 1, LY
YS( I ) = YY( I )
30 CONTINUE
INCYS = INCY
*
* Call the subroutine.
*
IF( FULL )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9993 )NC, SNAME,
$ UPLO, N, ALPHA, LDA, INCX, BETA, INCY
IF( REWI )
$ REWIND NTRA
CALL SSYMV( UPLO, N, ALPHA, AA, LDA, XX,
$ INCX, BETA, YY, INCY )
ELSE IF( BANDED )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9994 )NC, SNAME,
$ UPLO, N, K, ALPHA, LDA, INCX, BETA,
$ INCY
IF( REWI )
$ REWIND NTRA
CALL SSBMV( UPLO, N, K, ALPHA, AA, LDA,
$ XX, INCX, BETA, YY, INCY )
ELSE IF( PACKED )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9995 )NC, SNAME,
$ UPLO, N, ALPHA, INCX, BETA, INCY
IF( REWI )
$ REWIND NTRA
CALL SSPMV( UPLO, N, ALPHA, AA, XX, INCX,
$ BETA, YY, INCY )
END IF
*
* Check if error-exit was taken incorrectly.
*
IF( .NOT.OK )THEN
WRITE( NOUT, FMT = 9992 )
FATAL = .TRUE.
GO TO 120
END IF
*
* See what data changed inside subroutines.
*
ISAME( 1 ) = UPLO.EQ.UPLOS
ISAME( 2 ) = NS.EQ.N
IF( FULL )THEN
ISAME( 3 ) = ALS.EQ.ALPHA
ISAME( 4 ) = LSE( AS, AA, LAA )
ISAME( 5 ) = LDAS.EQ.LDA
ISAME( 6 ) = LSE( XS, XX, LX )
ISAME( 7 ) = INCXS.EQ.INCX
ISAME( 8 ) = BLS.EQ.BETA
IF( NULL )THEN
ISAME( 9 ) = LSE( YS, YY, LY )
ELSE
ISAME( 9 ) = LSERES( 'GE', ' ', 1, N,
$ YS, YY, ABS( INCY ) )
END IF
ISAME( 10 ) = INCYS.EQ.INCY
ELSE IF( BANDED )THEN
ISAME( 3 ) = KS.EQ.K
ISAME( 4 ) = ALS.EQ.ALPHA
ISAME( 5 ) = LSE( AS, AA, LAA )
ISAME( 6 ) = LDAS.EQ.LDA
ISAME( 7 ) = LSE( XS, XX, LX )
ISAME( 8 ) = INCXS.EQ.INCX
ISAME( 9 ) = BLS.EQ.BETA
IF( NULL )THEN
ISAME( 10 ) = LSE( YS, YY, LY )
ELSE
ISAME( 10 ) = LSERES( 'GE', ' ', 1, N,
$ YS, YY, ABS( INCY ) )
END IF
ISAME( 11 ) = INCYS.EQ.INCY
ELSE IF( PACKED )THEN
ISAME( 3 ) = ALS.EQ.ALPHA
ISAME( 4 ) = LSE( AS, AA, LAA )
ISAME( 5 ) = LSE( XS, XX, LX )
ISAME( 6 ) = INCXS.EQ.INCX
ISAME( 7 ) = BLS.EQ.BETA
IF( NULL )THEN
ISAME( 8 ) = LSE( YS, YY, LY )
ELSE
ISAME( 8 ) = LSERES( 'GE', ' ', 1, N,
$ YS, YY, ABS( INCY ) )
END IF
ISAME( 9 ) = INCYS.EQ.INCY
END IF
*
* If data was incorrectly changed, report and
* return.
*
SAME = .TRUE.
DO 40 I = 1, NARGS
SAME = SAME.AND.ISAME( I )
IF( .NOT.ISAME( I ) )
$ WRITE( NOUT, FMT = 9998 )I
40 CONTINUE
IF( .NOT.SAME )THEN
FATAL = .TRUE.
GO TO 120
END IF
*
IF( .NOT.NULL )THEN
*
* Check the result.
*
CALL SMVCH( 'N', N, N, ALPHA, A, NMAX, X,
$ INCX, BETA, Y, INCY, YT, G,
$ YY, EPS, ERR, FATAL, NOUT,
$ .TRUE. )
ERRMAX = MAX( ERRMAX, ERR )
* If got really bad answer, report and
* return.
IF( FATAL )
$ GO TO 120
ELSE
* Avoid repeating tests with N.le.0
GO TO 110
END IF
*
50 CONTINUE
*
60 CONTINUE
*
70 CONTINUE
*
80 CONTINUE
*
90 CONTINUE
*
100 CONTINUE
*
110 CONTINUE
*
* Report result.
*
IF( ERRMAX.LT.THRESH )THEN
WRITE( NOUT, FMT = 9999 )SNAME, NC
ELSE
WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
END IF
GO TO 130
*
120 CONTINUE
WRITE( NOUT, FMT = 9996 )SNAME
IF( FULL )THEN
WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, LDA, INCX,
$ BETA, INCY
ELSE IF( BANDED )THEN
WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, K, ALPHA, LDA,
$ INCX, BETA, INCY
ELSE IF( PACKED )THEN
WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, N, ALPHA, INCX,
$ BETA, INCY
END IF
*
130 CONTINUE
RETURN
*
9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
$ 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
$ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
$ ' - SUSPECT *******' )
9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', AP',
$ ', X,', I2, ',', F4.1, ', Y,', I2, ') .' )
9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), F4.1,
$ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2,
$ ') .' )
9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', A,',
$ I3, ', X,', I2, ',', F4.1, ', Y,', I2, ') .' )
9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
* End of SCHK2.
*
END
SUBROUTINE SCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$ FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX,
$ INCMAX, A, AA, AS, X, XX, XS, XT, G, Z )
*
* Tests STRMV, STBMV, STPMV, STRSV, STBSV and STPSV.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Parameters ..
REAL ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 )
* .. Scalar Arguments ..
REAL EPS, THRESH
INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA
LOGICAL FATAL, REWI, TRACE
CHARACTER*6 SNAME
* .. Array Arguments ..
REAL A( NMAX, NMAX ), AA( NMAX*NMAX ),
$ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
$ XS( NMAX*INCMAX ), XT( NMAX ),
$ XX( NMAX*INCMAX ), Z( NMAX )
INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
* .. Local Scalars ..
REAL ERR, ERRMAX, TRANSL
INTEGER I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K,
$ KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS
LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME
CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS
CHARACTER*2 ICHD, ICHU
CHARACTER*3 ICHT
* .. Local Arrays ..
LOGICAL ISAME( 13 )
* .. External Functions ..
LOGICAL LSE, LSERES
EXTERNAL LSE, LSERES
* .. External Subroutines ..
EXTERNAL SMAKE, SMVCH, STBMV, STBSV, STPMV, STPSV,
$ STRMV, STRSV
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
* .. Data statements ..
DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/
* .. Executable Statements ..
FULL = SNAME( 3: 3 ).EQ.'R'
BANDED = SNAME( 3: 3 ).EQ.'B'
PACKED = SNAME( 3: 3 ).EQ.'P'
* Define the number of arguments.
IF( FULL )THEN
NARGS = 8
ELSE IF( BANDED )THEN
NARGS = 9
ELSE IF( PACKED )THEN
NARGS = 7
END IF
*
NC = 0
RESET = .TRUE.
ERRMAX = ZERO
* Set up zero vector for SMVCH.
DO 10 I = 1, NMAX
Z( I ) = ZERO
10 CONTINUE
*
DO 110 IN = 1, NIDIM
N = IDIM( IN )
*
IF( BANDED )THEN
NK = NKB
ELSE
NK = 1
END IF
DO 100 IK = 1, NK
IF( BANDED )THEN
K = KB( IK )
ELSE
K = N - 1
END IF
* Set LDA to 1 more than minimum value if room.
IF( BANDED )THEN
LDA = K + 1
ELSE
LDA = N
END IF
IF( LDA.LT.NMAX )
$ LDA = LDA + 1
* Skip tests if not enough room.
IF( LDA.GT.NMAX )
$ GO TO 100
IF( PACKED )THEN
LAA = ( N*( N + 1 ) )/2
ELSE
LAA = LDA*N
END IF
NULL = N.LE.0
*
DO 90 ICU = 1, 2
UPLO = ICHU( ICU: ICU )
*
DO 80 ICT = 1, 3
TRANS = ICHT( ICT: ICT )
*
DO 70 ICD = 1, 2
DIAG = ICHD( ICD: ICD )
*
* Generate the matrix A.
*
TRANSL = ZERO
CALL SMAKE( SNAME( 2: 3 ), UPLO, DIAG, N, N, A,
$ NMAX, AA, LDA, K, K, RESET, TRANSL )
*
DO 60 IX = 1, NINC
INCX = INC( IX )
LX = ABS( INCX )*N
*
* Generate the vector X.
*
TRANSL = HALF
CALL SMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX,
$ ABS( INCX ), 0, N - 1, RESET,
$ TRANSL )
IF( N.GT.1 )THEN
X( N/2 ) = ZERO
XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
END IF
*
NC = NC + 1
*
* Save every datum before calling the subroutine.
*
UPLOS = UPLO
TRANSS = TRANS
DIAGS = DIAG
NS = N
KS = K
DO 20 I = 1, LAA
AS( I ) = AA( I )
20 CONTINUE
LDAS = LDA
DO 30 I = 1, LX
XS( I ) = XX( I )
30 CONTINUE
INCXS = INCX
*
* Call the subroutine.
*
IF( SNAME( 4: 5 ).EQ.'MV' )THEN
IF( FULL )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9993 )NC, SNAME,
$ UPLO, TRANS, DIAG, N, LDA, INCX
IF( REWI )
$ REWIND NTRA
CALL STRMV( UPLO, TRANS, DIAG, N, AA, LDA,
$ XX, INCX )
ELSE IF( BANDED )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9994 )NC, SNAME,
$ UPLO, TRANS, DIAG, N, K, LDA, INCX
IF( REWI )
$ REWIND NTRA
CALL STBMV( UPLO, TRANS, DIAG, N, K, AA,
$ LDA, XX, INCX )
ELSE IF( PACKED )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9995 )NC, SNAME,
$ UPLO, TRANS, DIAG, N, INCX
IF( REWI )
$ REWIND NTRA
CALL STPMV( UPLO, TRANS, DIAG, N, AA, XX,
$ INCX )
END IF
ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN
IF( FULL )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9993 )NC, SNAME,
$ UPLO, TRANS, DIAG, N, LDA, INCX
IF( REWI )
$ REWIND NTRA
CALL STRSV( UPLO, TRANS, DIAG, N, AA, LDA,
$ XX, INCX )
ELSE IF( BANDED )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9994 )NC, SNAME,
$ UPLO, TRANS, DIAG, N, K, LDA, INCX
IF( REWI )
$ REWIND NTRA
CALL STBSV( UPLO, TRANS, DIAG, N, K, AA,
$ LDA, XX, INCX )
ELSE IF( PACKED )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9995 )NC, SNAME,
$ UPLO, TRANS, DIAG, N, INCX
IF( REWI )
$ REWIND NTRA
CALL STPSV( UPLO, TRANS, DIAG, N, AA, XX,
$ INCX )
END IF
END IF
*
* Check if error-exit was taken incorrectly.
*
IF( .NOT.OK )THEN
WRITE( NOUT, FMT = 9992 )
FATAL = .TRUE.
GO TO 120
END IF
*
* See what data changed inside subroutines.
*
ISAME( 1 ) = UPLO.EQ.UPLOS
ISAME( 2 ) = TRANS.EQ.TRANSS
ISAME( 3 ) = DIAG.EQ.DIAGS
ISAME( 4 ) = NS.EQ.N
IF( FULL )THEN
ISAME( 5 ) = LSE( AS, AA, LAA )
ISAME( 6 ) = LDAS.EQ.LDA
IF( NULL )THEN
ISAME( 7 ) = LSE( XS, XX, LX )
ELSE
ISAME( 7 ) = LSERES( 'GE', ' ', 1, N, XS,
$ XX, ABS( INCX ) )
END IF
ISAME( 8 ) = INCXS.EQ.INCX
ELSE IF( BANDED )THEN
ISAME( 5 ) = KS.EQ.K
ISAME( 6 ) = LSE( AS, AA, LAA )
ISAME( 7 ) = LDAS.EQ.LDA
IF( NULL )THEN
ISAME( 8 ) = LSE( XS, XX, LX )
ELSE
ISAME( 8 ) = LSERES( 'GE', ' ', 1, N, XS,
$ XX, ABS( INCX ) )
END IF
ISAME( 9 ) = INCXS.EQ.INCX
ELSE IF( PACKED )THEN
ISAME( 5 ) = LSE( AS, AA, LAA )
IF( NULL )THEN
ISAME( 6 ) = LSE( XS, XX, LX )
ELSE
ISAME( 6 ) = LSERES( 'GE', ' ', 1, N, XS,
$ XX, ABS( INCX ) )
END IF
ISAME( 7 ) = INCXS.EQ.INCX
END IF
*
* If data was incorrectly changed, report and
* return.
*
SAME = .TRUE.
DO 40 I = 1, NARGS
SAME = SAME.AND.ISAME( I )
IF( .NOT.ISAME( I ) )
$ WRITE( NOUT, FMT = 9998 )I
40 CONTINUE
IF( .NOT.SAME )THEN
FATAL = .TRUE.
GO TO 120
END IF
*
IF( .NOT.NULL )THEN
IF( SNAME( 4: 5 ).EQ.'MV' )THEN
*
* Check the result.
*
CALL SMVCH( TRANS, N, N, ONE, A, NMAX, X,
$ INCX, ZERO, Z, INCX, XT, G,
$ XX, EPS, ERR, FATAL, NOUT,
$ .TRUE. )
ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN
*
* Compute approximation to original vector.
*
DO 50 I = 1, N
Z( I ) = XX( 1 + ( I - 1 )*
$ ABS( INCX ) )
XX( 1 + ( I - 1 )*ABS( INCX ) )
$ = X( I )
50 CONTINUE
CALL SMVCH( TRANS, N, N, ONE, A, NMAX, Z,
$ INCX, ZERO, X, INCX, XT, G,
$ XX, EPS, ERR, FATAL, NOUT,
$ .FALSE. )
END IF
ERRMAX = MAX( ERRMAX, ERR )
* If got really bad answer, report and return.
IF( FATAL )
$ GO TO 120
ELSE
* Avoid repeating tests with N.le.0.
GO TO 110
END IF
*
60 CONTINUE
*
70 CONTINUE
*
80 CONTINUE
*
90 CONTINUE
*
100 CONTINUE
*
110 CONTINUE
*
* Report result.
*
IF( ERRMAX.LT.THRESH )THEN
WRITE( NOUT, FMT = 9999 )SNAME, NC
ELSE
WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
END IF
GO TO 130
*
120 CONTINUE
WRITE( NOUT, FMT = 9996 )SNAME
IF( FULL )THEN
WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, DIAG, N, LDA,
$ INCX
ELSE IF( BANDED )THEN
WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, DIAG, N, K,
$ LDA, INCX
ELSE IF( PACKED )THEN
WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, TRANS, DIAG, N, INCX
END IF
*
130 CONTINUE
RETURN
*
9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
$ 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
$ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
$ ' - SUSPECT *******' )
9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
9995 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', AP, ',
$ 'X,', I2, ') .' )
9994 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), 2( I3, ',' ),
$ ' A,', I3, ', X,', I2, ') .' )
9993 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', A,',
$ I3, ', X,', I2, ') .' )
9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
* End of SCHK3.
*
END
SUBROUTINE SCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
$ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
$ Z )
*
* Tests SGER.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Parameters ..
REAL ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 )
* .. Scalar Arguments ..
REAL EPS, THRESH
INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
LOGICAL FATAL, REWI, TRACE
CHARACTER*6 SNAME
* .. Array Arguments ..
REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
$ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
$ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
$ YY( NMAX*INCMAX ), Z( NMAX )
INTEGER IDIM( NIDIM ), INC( NINC )
* .. Local Scalars ..
REAL ALPHA, ALS, ERR, ERRMAX, TRANSL
INTEGER I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX,
$ IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS,
$ NC, ND, NS
LOGICAL NULL, RESET, SAME
* .. Local Arrays ..
REAL W( 1 )
LOGICAL ISAME( 13 )
* .. External Functions ..
LOGICAL LSE, LSERES
EXTERNAL LSE, LSERES
* .. External Subroutines ..
EXTERNAL SGER, SMAKE, SMVCH
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
* .. Executable Statements ..
* Define the number of arguments.
NARGS = 9
*
NC = 0
RESET = .TRUE.
ERRMAX = ZERO
*
DO 120 IN = 1, NIDIM
N = IDIM( IN )
ND = N/2 + 1
*
DO 110 IM = 1, 2
IF( IM.EQ.1 )
$ M = MAX( N - ND, 0 )
IF( IM.EQ.2 )
$ M = MIN( N + ND, NMAX )
*
* Set LDA to 1 more than minimum value if room.
LDA = M
IF( LDA.LT.NMAX )
$ LDA = LDA + 1
* Skip tests if not enough room.
IF( LDA.GT.NMAX )
$ GO TO 110
LAA = LDA*N
NULL = N.LE.0.OR.M.LE.0
*
DO 100 IX = 1, NINC
INCX = INC( IX )
LX = ABS( INCX )*M
*
* Generate the vector X.
*
TRANSL = HALF
CALL SMAKE( 'GE', ' ', ' ', 1, M, X, 1, XX, ABS( INCX ),
$ 0, M - 1, RESET, TRANSL )
IF( M.GT.1 )THEN
X( M/2 ) = ZERO
XX( 1 + ABS( INCX )*( M/2 - 1 ) ) = ZERO
END IF
*
DO 90 IY = 1, NINC
INCY = INC( IY )
LY = ABS( INCY )*N
*
* Generate the vector Y.
*
TRANSL = ZERO
CALL SMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY,
$ ABS( INCY ), 0, N - 1, RESET, TRANSL )
IF( N.GT.1 )THEN
Y( N/2 ) = ZERO
YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO
END IF
*
DO 80 IA = 1, NALF
ALPHA = ALF( IA )
*
* Generate the matrix A.
*
TRANSL = ZERO
CALL SMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX,
$ AA, LDA, M - 1, N - 1, RESET, TRANSL )
*
NC = NC + 1
*
* Save every datum before calling the subroutine.
*
MS = M
NS = N
ALS = ALPHA
DO 10 I = 1, LAA
AS( I ) = AA( I )
10 CONTINUE
LDAS = LDA
DO 20 I = 1, LX
XS( I ) = XX( I )
20 CONTINUE
INCXS = INCX
DO 30 I = 1, LY
YS( I ) = YY( I )
30 CONTINUE
INCYS = INCY
*
* Call the subroutine.
*
IF( TRACE )
$ WRITE( NTRA, FMT = 9994 )NC, SNAME, M, N,
$ ALPHA, INCX, INCY, LDA
IF( REWI )
$ REWIND NTRA
CALL SGER( M, N, ALPHA, XX, INCX, YY, INCY, AA,
$ LDA )
*
* Check if error-exit was taken incorrectly.
*
IF( .NOT.OK )THEN
WRITE( NOUT, FMT = 9993 )
FATAL = .TRUE.
GO TO 140
END IF
*
* See what data changed inside subroutine.
*
ISAME( 1 ) = MS.EQ.M
ISAME( 2 ) = NS.EQ.N
ISAME( 3 ) = ALS.EQ.ALPHA
ISAME( 4 ) = LSE( XS, XX, LX )
ISAME( 5 ) = INCXS.EQ.INCX
ISAME( 6 ) = LSE( YS, YY, LY )
ISAME( 7 ) = INCYS.EQ.INCY
IF( NULL )THEN
ISAME( 8 ) = LSE( AS, AA, LAA )
ELSE
ISAME( 8 ) = LSERES( 'GE', ' ', M, N, AS, AA,
$ LDA )
END IF
ISAME( 9 ) = LDAS.EQ.LDA
*
* If data was incorrectly changed, report and return.
*
SAME = .TRUE.
DO 40 I = 1, NARGS
SAME = SAME.AND.ISAME( I )
IF( .NOT.ISAME( I ) )
$ WRITE( NOUT, FMT = 9998 )I
40 CONTINUE
IF( .NOT.SAME )THEN
FATAL = .TRUE.
GO TO 140
END IF
*
IF( .NOT.NULL )THEN
*
* Check the result column by column.
*
IF( INCX.GT.0 )THEN
DO 50 I = 1, M
Z( I ) = X( I )
50 CONTINUE
ELSE
DO 60 I = 1, M
Z( I ) = X( M - I + 1 )
60 CONTINUE
END IF
DO 70 J = 1, N
IF( INCY.GT.0 )THEN
W( 1 ) = Y( J )
ELSE
W( 1 ) = Y( N - J + 1 )
END IF
CALL SMVCH( 'N', M, 1, ALPHA, Z, NMAX, W, 1,
$ ONE, A( 1, J ), 1, YT, G,
$ AA( 1 + ( J - 1 )*LDA ), EPS,
$ ERR, FATAL, NOUT, .TRUE. )
ERRMAX = MAX( ERRMAX, ERR )
* If got really bad answer, report and return.
IF( FATAL )
$ GO TO 130
70 CONTINUE
ELSE
* Avoid repeating tests with M.le.0 or N.le.0.
GO TO 110
END IF
*
80 CONTINUE
*
90 CONTINUE
*
100 CONTINUE
*
110 CONTINUE
*
120 CONTINUE
*
* Report result.
*
IF( ERRMAX.LT.THRESH )THEN
WRITE( NOUT, FMT = 9999 )SNAME, NC
ELSE
WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
END IF
GO TO 150
*
130 CONTINUE
WRITE( NOUT, FMT = 9995 )J
*
140 CONTINUE
WRITE( NOUT, FMT = 9996 )SNAME
WRITE( NOUT, FMT = 9994 )NC, SNAME, M, N, ALPHA, INCX, INCY, LDA
*
150 CONTINUE
RETURN
*
9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
$ 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
$ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
$ ' - SUSPECT *******' )
9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
9994 FORMAT( 1X, I6, ': ', A6, '(', 2( I3, ',' ), F4.1, ', X,', I2,
$ ', Y,', I2, ', A,', I3, ') .' )
9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
* End of SCHK4.
*
END
SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
$ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
$ Z )
*
* Tests SSYR and SSPR.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Parameters ..
REAL ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 )
* .. Scalar Arguments ..
REAL EPS, THRESH
INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
LOGICAL FATAL, REWI, TRACE
CHARACTER*6 SNAME
* .. Array Arguments ..
REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
$ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
$ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
$ YY( NMAX*INCMAX ), Z( NMAX )
INTEGER IDIM( NIDIM ), INC( NINC )
* .. Local Scalars ..
REAL ALPHA, ALS, ERR, ERRMAX, TRANSL
INTEGER I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA,
$ LDA, LDAS, LJ, LX, N, NARGS, NC, NS
LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER
CHARACTER*1 UPLO, UPLOS
CHARACTER*2 ICH
* .. Local Arrays ..
REAL W( 1 )
LOGICAL ISAME( 13 )
* .. External Functions ..
LOGICAL LSE, LSERES
EXTERNAL LSE, LSERES
* .. External Subroutines ..
EXTERNAL SMAKE, SMVCH, SSPR, SSYR
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
* .. Data statements ..
DATA ICH/'UL'/
* .. Executable Statements ..
FULL = SNAME( 3: 3 ).EQ.'Y'
PACKED = SNAME( 3: 3 ).EQ.'P'
* Define the number of arguments.
IF( FULL )THEN
NARGS = 7
ELSE IF( PACKED )THEN
NARGS = 6
END IF
*
NC = 0
RESET = .TRUE.
ERRMAX = ZERO
*
DO 100 IN = 1, NIDIM
N = IDIM( IN )
* Set LDA to 1 more than minimum value if room.
LDA = N
IF( LDA.LT.NMAX )
$ LDA = LDA + 1
* Skip tests if not enough room.
IF( LDA.GT.NMAX )
$ GO TO 100
IF( PACKED )THEN
LAA = ( N*( N + 1 ) )/2
ELSE
LAA = LDA*N
END IF
*
DO 90 IC = 1, 2
UPLO = ICH( IC: IC )
UPPER = UPLO.EQ.'U'
*
DO 80 IX = 1, NINC
INCX = INC( IX )
LX = ABS( INCX )*N
*
* Generate the vector X.
*
TRANSL = HALF
CALL SMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ),
$ 0, N - 1, RESET, TRANSL )
IF( N.GT.1 )THEN
X( N/2 ) = ZERO
XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
END IF
*
DO 70 IA = 1, NALF
ALPHA = ALF( IA )
NULL = N.LE.0.OR.ALPHA.EQ.ZERO
*
* Generate the matrix A.
*
TRANSL = ZERO
CALL SMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX,
$ AA, LDA, N - 1, N - 1, RESET, TRANSL )
*
NC = NC + 1
*
* Save every datum before calling the subroutine.
*
UPLOS = UPLO
NS = N
ALS = ALPHA
DO 10 I = 1, LAA
AS( I ) = AA( I )
10 CONTINUE
LDAS = LDA
DO 20 I = 1, LX
XS( I ) = XX( I )
20 CONTINUE
INCXS = INCX
*
* Call the subroutine.
*
IF( FULL )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N,
$ ALPHA, INCX, LDA
IF( REWI )
$ REWIND NTRA
CALL SSYR( UPLO, N, ALPHA, XX, INCX, AA, LDA )
ELSE IF( PACKED )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N,
$ ALPHA, INCX
IF( REWI )
$ REWIND NTRA
CALL SSPR( UPLO, N, ALPHA, XX, INCX, AA )
END IF
*
* Check if error-exit was taken incorrectly.
*
IF( .NOT.OK )THEN
WRITE( NOUT, FMT = 9992 )
FATAL = .TRUE.
GO TO 120
END IF
*
* See what data changed inside subroutines.
*
ISAME( 1 ) = UPLO.EQ.UPLOS
ISAME( 2 ) = NS.EQ.N
ISAME( 3 ) = ALS.EQ.ALPHA
ISAME( 4 ) = LSE( XS, XX, LX )
ISAME( 5 ) = INCXS.EQ.INCX
IF( NULL )THEN
ISAME( 6 ) = LSE( AS, AA, LAA )
ELSE
ISAME( 6 ) = LSERES( SNAME( 2: 3 ), UPLO, N, N, AS,
$ AA, LDA )
END IF
IF( .NOT.PACKED )THEN
ISAME( 7 ) = LDAS.EQ.LDA
END IF
*
* If data was incorrectly changed, report and return.
*
SAME = .TRUE.
DO 30 I = 1, NARGS
SAME = SAME.AND.ISAME( I )
IF( .NOT.ISAME( I ) )
$ WRITE( NOUT, FMT = 9998 )I
30 CONTINUE
IF( .NOT.SAME )THEN
FATAL = .TRUE.
GO TO 120
END IF
*
IF( .NOT.NULL )THEN
*
* Check the result column by column.
*
IF( INCX.GT.0 )THEN
DO 40 I = 1, N
Z( I ) = X( I )
40 CONTINUE
ELSE
DO 50 I = 1, N
Z( I ) = X( N - I + 1 )
50 CONTINUE
END IF
JA = 1
DO 60 J = 1, N
W( 1 ) = Z( J )
IF( UPPER )THEN
JJ = 1
LJ = J
ELSE
JJ = J
LJ = N - J + 1
END IF
CALL SMVCH( 'N', LJ, 1, ALPHA, Z( JJ ), LJ, W,
$ 1, ONE, A( JJ, J ), 1, YT, G,
$ AA( JA ), EPS, ERR, FATAL, NOUT,
$ .TRUE. )
IF( FULL )THEN
IF( UPPER )THEN
JA = JA + LDA
ELSE
JA = JA + LDA + 1
END IF
ELSE
JA = JA + LJ
END IF
ERRMAX = MAX( ERRMAX, ERR )
* If got really bad answer, report and return.
IF( FATAL )
$ GO TO 110
60 CONTINUE
ELSE
* Avoid repeating tests if N.le.0.
IF( N.LE.0 )
$ GO TO 100
END IF
*
70 CONTINUE
*
80 CONTINUE
*
90 CONTINUE
*
100 CONTINUE
*
* Report result.
*
IF( ERRMAX.LT.THRESH )THEN
WRITE( NOUT, FMT = 9999 )SNAME, NC
ELSE
WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
END IF
GO TO 130
*
110 CONTINUE
WRITE( NOUT, FMT = 9995 )J
*
120 CONTINUE
WRITE( NOUT, FMT = 9996 )SNAME
IF( FULL )THEN
WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX, LDA
ELSE IF( PACKED )THEN
WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, ALPHA, INCX
END IF
*
130 CONTINUE
RETURN
*
9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
$ 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
$ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
$ ' - SUSPECT *******' )
9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,',
$ I2, ', AP) .' )
9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,',
$ I2, ', A,', I3, ') .' )
9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
* End of SCHK5.
*
END
SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
$ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
$ Z )
*
* Tests SSYR2 and SSPR2.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Parameters ..
REAL ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 )
* .. Scalar Arguments ..
REAL EPS, THRESH
INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
LOGICAL FATAL, REWI, TRACE
CHARACTER*6 SNAME
* .. Array Arguments ..
REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
$ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
$ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
$ YY( NMAX*INCMAX ), Z( NMAX, 2 )
INTEGER IDIM( NIDIM ), INC( NINC )
* .. Local Scalars ..
REAL ALPHA, ALS, ERR, ERRMAX, TRANSL
INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX,
$ IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N,
$ NARGS, NC, NS
LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER
CHARACTER*1 UPLO, UPLOS
CHARACTER*2 ICH
* .. Local Arrays ..
REAL W( 2 )
LOGICAL ISAME( 13 )
* .. External Functions ..
LOGICAL LSE, LSERES
EXTERNAL LSE, LSERES
* .. External Subroutines ..
EXTERNAL SMAKE, SMVCH, SSPR2, SSYR2
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
* .. Data statements ..
DATA ICH/'UL'/
* .. Executable Statements ..
FULL = SNAME( 3: 3 ).EQ.'Y'
PACKED = SNAME( 3: 3 ).EQ.'P'
* Define the number of arguments.
IF( FULL )THEN
NARGS = 9
ELSE IF( PACKED )THEN
NARGS = 8
END IF
*
NC = 0
RESET = .TRUE.
ERRMAX = ZERO
*
DO 140 IN = 1, NIDIM
N = IDIM( IN )
* Set LDA to 1 more than minimum value if room.
LDA = N
IF( LDA.LT.NMAX )
$ LDA = LDA + 1
* Skip tests if not enough room.
IF( LDA.GT.NMAX )
$ GO TO 140
IF( PACKED )THEN
LAA = ( N*( N + 1 ) )/2
ELSE
LAA = LDA*N
END IF
*
DO 130 IC = 1, 2
UPLO = ICH( IC: IC )
UPPER = UPLO.EQ.'U'
*
DO 120 IX = 1, NINC
INCX = INC( IX )
LX = ABS( INCX )*N
*
* Generate the vector X.
*
TRANSL = HALF
CALL SMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ),
$ 0, N - 1, RESET, TRANSL )
IF( N.GT.1 )THEN
X( N/2 ) = ZERO
XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
END IF
*
DO 110 IY = 1, NINC
INCY = INC( IY )
LY = ABS( INCY )*N
*
* Generate the vector Y.
*
TRANSL = ZERO
CALL SMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY,
$ ABS( INCY ), 0, N - 1, RESET, TRANSL )
IF( N.GT.1 )THEN
Y( N/2 ) = ZERO
YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO
END IF
*
DO 100 IA = 1, NALF
ALPHA = ALF( IA )
NULL = N.LE.0.OR.ALPHA.EQ.ZERO
*
* Generate the matrix A.
*
TRANSL = ZERO
CALL SMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A,
$ NMAX, AA, LDA, N - 1, N - 1, RESET,
$ TRANSL )
*
NC = NC + 1
*
* Save every datum before calling the subroutine.
*
UPLOS = UPLO
NS = N
ALS = ALPHA
DO 10 I = 1, LAA
AS( I ) = AA( I )
10 CONTINUE
LDAS = LDA
DO 20 I = 1, LX
XS( I ) = XX( I )
20 CONTINUE
INCXS = INCX
DO 30 I = 1, LY
YS( I ) = YY( I )
30 CONTINUE
INCYS = INCY
*
* Call the subroutine.
*
IF( FULL )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N,
$ ALPHA, INCX, INCY, LDA
IF( REWI )
$ REWIND NTRA
CALL SSYR2( UPLO, N, ALPHA, XX, INCX, YY, INCY,
$ AA, LDA )
ELSE IF( PACKED )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N,
$ ALPHA, INCX, INCY
IF( REWI )
$ REWIND NTRA
CALL SSPR2( UPLO, N, ALPHA, XX, INCX, YY, INCY,
$ AA )
END IF
*
* Check if error-exit was taken incorrectly.
*
IF( .NOT.OK )THEN
WRITE( NOUT, FMT = 9992 )
FATAL = .TRUE.
GO TO 160
END IF
*
* See what data changed inside subroutines.
*
ISAME( 1 ) = UPLO.EQ.UPLOS
ISAME( 2 ) = NS.EQ.N
ISAME( 3 ) = ALS.EQ.ALPHA
ISAME( 4 ) = LSE( XS, XX, LX )
ISAME( 5 ) = INCXS.EQ.INCX
ISAME( 6 ) = LSE( YS, YY, LY )
ISAME( 7 ) = INCYS.EQ.INCY
IF( NULL )THEN
ISAME( 8 ) = LSE( AS, AA, LAA )
ELSE
ISAME( 8 ) = LSERES( SNAME( 2: 3 ), UPLO, N, N,
$ AS, AA, LDA )
END IF
IF( .NOT.PACKED )THEN
ISAME( 9 ) = LDAS.EQ.LDA
END IF
*
* If data was incorrectly changed, report and return.
*
SAME = .TRUE.
DO 40 I = 1, NARGS
SAME = SAME.AND.ISAME( I )
IF( .NOT.ISAME( I ) )
$ WRITE( NOUT, FMT = 9998 )I
40 CONTINUE
IF( .NOT.SAME )THEN
FATAL = .TRUE.
GO TO 160
END IF
*
IF( .NOT.NULL )THEN
*
* Check the result column by column.
*
IF( INCX.GT.0 )THEN
DO 50 I = 1, N
Z( I, 1 ) = X( I )
50 CONTINUE
ELSE
DO 60 I = 1, N
Z( I, 1 ) = X( N - I + 1 )
60 CONTINUE
END IF
IF( INCY.GT.0 )THEN
DO 70 I = 1, N
Z( I, 2 ) = Y( I )
70 CONTINUE
ELSE
DO 80 I = 1, N
Z( I, 2 ) = Y( N - I + 1 )
80 CONTINUE
END IF
JA = 1
DO 90 J = 1, N
W( 1 ) = Z( J, 2 )
W( 2 ) = Z( J, 1 )
IF( UPPER )THEN
JJ = 1
LJ = J
ELSE
JJ = J
LJ = N - J + 1
END IF
CALL SMVCH( 'N', LJ, 2, ALPHA, Z( JJ, 1 ),
$ NMAX, W, 1, ONE, A( JJ, J ), 1,
$ YT, G, AA( JA ), EPS, ERR, FATAL,
$ NOUT, .TRUE. )
IF( FULL )THEN
IF( UPPER )THEN
JA = JA + LDA
ELSE
JA = JA + LDA + 1
END IF
ELSE
JA = JA + LJ
END IF
ERRMAX = MAX( ERRMAX, ERR )
* If got really bad answer, report and return.
IF( FATAL )
$ GO TO 150
90 CONTINUE
ELSE
* Avoid repeating tests with N.le.0.
IF( N.LE.0 )
$ GO TO 140
END IF
*
100 CONTINUE
*
110 CONTINUE
*
120 CONTINUE
*
130 CONTINUE
*
140 CONTINUE
*
* Report result.
*
IF( ERRMAX.LT.THRESH )THEN
WRITE( NOUT, FMT = 9999 )SNAME, NC
ELSE
WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
END IF
GO TO 170
*
150 CONTINUE
WRITE( NOUT, FMT = 9995 )J
*
160 CONTINUE
WRITE( NOUT, FMT = 9996 )SNAME
IF( FULL )THEN
WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX,
$ INCY, LDA
ELSE IF( PACKED )THEN
WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, ALPHA, INCX, INCY
END IF
*
170 CONTINUE
RETURN
*
9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
$ 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
$ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
$ ' - SUSPECT *******' )
9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,',
$ I2, ', Y,', I2, ', AP) .' )
9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,',
$ I2, ', Y,', I2, ', A,', I3, ') .' )
9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
* End of SCHK6.
*
END
SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT )
*
* Tests the error exits from the Level 2 Blas.
* Requires a special version of the error-handling routine XERBLA.
* ALPHA, BETA, A, X and Y should not need to be defined.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Scalar Arguments ..
INTEGER ISNUM, NOUT
CHARACTER*6 SRNAMT
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
* .. Local Scalars ..
REAL ALPHA, BETA
* .. Local Arrays ..
REAL A( 1, 1 ), X( 1 ), Y( 1 )
* .. External Subroutines ..
EXTERNAL CHKXER, SGBMV, SGEMV, SGER, SSBMV, SSPMV, SSPR,
$ SSPR2, SSYMV, SSYR, SSYR2, STBMV, STBSV, STPMV,
$ STPSV, STRMV, STRSV
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
* .. Executable Statements ..
* OK is set to .FALSE. by the special version of XERBLA or by CHKXER
* if anything is wrong.
OK = .TRUE.
* LERR is set to .TRUE. by the special version of XERBLA each time
* it is called, and is then tested and re-set by CHKXER.
LERR = .FALSE.
GO TO ( 10, 20, 30, 40, 50, 60, 70, 80,
$ 90, 100, 110, 120, 130, 140, 150,
$ 160 )ISNUM
10 INFOT = 1
CALL SGEMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGEMV( 'N', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGEMV( 'N', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SGEMV( 'N', 2, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SGEMV( 'N', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL SGEMV( 'N', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 170
20 INFOT = 1
CALL SGBMV( '/', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGBMV( 'N', -1, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGBMV( 'N', 0, -1, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGBMV( 'N', 0, 0, -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGBMV( 'N', 2, 0, 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SGBMV( 'N', 0, 0, 1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 13
CALL SGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 170
30 INFOT = 1
CALL SSYMV( '/', 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSYMV( 'U', -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SSYMV( 'U', 2, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SSYMV( 'U', 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SSYMV( 'U', 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 170
40 INFOT = 1
CALL SSBMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSBMV( 'U', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SSBMV( 'U', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SSBMV( 'U', 0, 1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SSBMV( 'U', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 11
CALL SSBMV( 'U', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 170
50 INFOT = 1
CALL SSPMV( '/', 0, ALPHA, A, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSPMV( 'U', -1, ALPHA, A, X, 1, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SSPMV( 'U', 0, ALPHA, A, X, 0, BETA, Y, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SSPMV( 'U', 0, ALPHA, A, X, 1, BETA, Y, 0 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 170
60 INFOT = 1
CALL STRMV( '/', 'N', 'N', 0, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STRMV( 'U', '/', 'N', 0, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL STRMV( 'U', 'N', '/', 0, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL STRMV( 'U', 'N', 'N', -1, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL STRMV( 'U', 'N', 'N', 2, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 8
CALL STRMV( 'U', 'N', 'N', 0, A, 1, X, 0 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 170
70 INFOT = 1
CALL STBMV( '/', 'N', 'N', 0, 0, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STBMV( 'U', '/', 'N', 0, 0, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL STBMV( 'U', 'N', '/', 0, 0, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL STBMV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STBMV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL STBMV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL STBMV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 170
80 INFOT = 1
CALL STPMV( '/', 'N', 'N', 0, A, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STPMV( 'U', '/', 'N', 0, A, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL STPMV( 'U', 'N', '/', 0, A, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL STPMV( 'U', 'N', 'N', -1, A, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL STPMV( 'U', 'N', 'N', 0, A, X, 0 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 170
90 INFOT = 1
CALL STRSV( '/', 'N', 'N', 0, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STRSV( 'U', '/', 'N', 0, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL STRSV( 'U', 'N', '/', 0, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL STRSV( 'U', 'N', 'N', -1, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 6
CALL STRSV( 'U', 'N', 'N', 2, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 8
CALL STRSV( 'U', 'N', 'N', 0, A, 1, X, 0 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 170
100 INFOT = 1
CALL STBSV( '/', 'N', 'N', 0, 0, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STBSV( 'U', '/', 'N', 0, 0, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL STBSV( 'U', 'N', '/', 0, 0, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL STBSV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL STBSV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL STBSV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL STBSV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 170
110 INFOT = 1
CALL STPSV( '/', 'N', 'N', 0, A, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STPSV( 'U', '/', 'N', 0, A, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 3
CALL STPSV( 'U', 'N', '/', 0, A, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 4
CALL STPSV( 'U', 'N', 'N', -1, A, X, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL STPSV( 'U', 'N', 'N', 0, A, X, 0 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 170
120 INFOT = 1
CALL SGER( -1, 0, ALPHA, X, 1, Y, 1, A, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGER( 0, -1, ALPHA, X, 1, Y, 1, A, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGER( 0, 0, ALPHA, X, 0, Y, 1, A, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SGER( 0, 0, ALPHA, X, 1, Y, 0, A, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SGER( 2, 0, ALPHA, X, 1, Y, 1, A, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 170
130 INFOT = 1
CALL SSYR( '/', 0, ALPHA, X, 1, A, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSYR( 'U', -1, ALPHA, X, 1, A, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SSYR( 'U', 0, ALPHA, X, 0, A, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SSYR( 'U', 2, ALPHA, X, 1, A, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 170
140 INFOT = 1
CALL SSPR( '/', 0, ALPHA, X, 1, A )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSPR( 'U', -1, ALPHA, X, 1, A )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SSPR( 'U', 0, ALPHA, X, 0, A )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 170
150 INFOT = 1
CALL SSYR2( '/', 0, ALPHA, X, 1, Y, 1, A, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSYR2( 'U', -1, ALPHA, X, 1, Y, 1, A, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SSYR2( 'U', 0, ALPHA, X, 0, Y, 1, A, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SSYR2( 'U', 0, ALPHA, X, 1, Y, 0, A, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SSYR2( 'U', 2, ALPHA, X, 1, Y, 1, A, 1 )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
GO TO 170
160 INFOT = 1
CALL SSPR2( '/', 0, ALPHA, X, 1, Y, 1, A )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SSPR2( 'U', -1, ALPHA, X, 1, Y, 1, A )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SSPR2( 'U', 0, ALPHA, X, 0, Y, 1, A )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SSPR2( 'U', 0, ALPHA, X, 1, Y, 0, A )
CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
*
170 IF( OK )THEN
WRITE( NOUT, FMT = 9999 )SRNAMT
ELSE
WRITE( NOUT, FMT = 9998 )SRNAMT
END IF
RETURN
*
9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' )
9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****',
$ '**' )
*
* End of SCHKE.
*
END
SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL,
$ KU, RESET, TRANSL )
*
* Generates values for an M by N matrix A within the bandwidth
* defined by KL and KU.
* Stores the values in the array AA in the data structure required
* by the routine, with unwanted elements set to rogue value.
*
* TYPE is 'GE', 'GB', 'SY', 'SB', 'SP', 'TR', 'TB' OR 'TP'.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0, ONE = 1.0 )
REAL ROGUE
PARAMETER ( ROGUE = -1.0E10 )
* .. Scalar Arguments ..
REAL TRANSL
INTEGER KL, KU, LDA, M, N, NMAX
LOGICAL RESET
CHARACTER*1 DIAG, UPLO
CHARACTER*2 TYPE
* .. Array Arguments ..
REAL A( NMAX, * ), AA( * )
* .. Local Scalars ..
INTEGER I, I1, I2, I3, IBEG, IEND, IOFF, J, KK
LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER
* .. External Functions ..
REAL SBEG
EXTERNAL SBEG
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* .. Executable Statements ..
GEN = TYPE( 1: 1 ).EQ.'G'
SYM = TYPE( 1: 1 ).EQ.'S'
TRI = TYPE( 1: 1 ).EQ.'T'
UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U'
LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L'
UNIT = TRI.AND.DIAG.EQ.'U'
*
* Generate data in array A.
*
DO 20 J = 1, N
DO 10 I = 1, M
IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) )
$ THEN
IF( ( I.LE.J.AND.J - I.LE.KU ).OR.
$ ( I.GE.J.AND.I - J.LE.KL ) )THEN
A( I, J ) = SBEG( RESET ) + TRANSL
ELSE
A( I, J ) = ZERO
END IF
IF( I.NE.J )THEN
IF( SYM )THEN
A( J, I ) = A( I, J )
ELSE IF( TRI )THEN
A( J, I ) = ZERO
END IF
END IF
END IF
10 CONTINUE
IF( TRI )
$ A( J, J ) = A( J, J ) + ONE
IF( UNIT )
$ A( J, J ) = ONE
20 CONTINUE
*
* Store elements in array AS in data structure required by routine.
*
IF( TYPE.EQ.'GE' )THEN
DO 50 J = 1, N
DO 30 I = 1, M
AA( I + ( J - 1 )*LDA ) = A( I, J )
30 CONTINUE
DO 40 I = M + 1, LDA
AA( I + ( J - 1 )*LDA ) = ROGUE
40 CONTINUE
50 CONTINUE
ELSE IF( TYPE.EQ.'GB' )THEN
DO 90 J = 1, N
DO 60 I1 = 1, KU + 1 - J
AA( I1 + ( J - 1 )*LDA ) = ROGUE
60 CONTINUE
DO 70 I2 = I1, MIN( KL + KU + 1, KU + 1 + M - J )
AA( I2 + ( J - 1 )*LDA ) = A( I2 + J - KU - 1, J )
70 CONTINUE
DO 80 I3 = I2, LDA
AA( I3 + ( J - 1 )*LDA ) = ROGUE
80 CONTINUE
90 CONTINUE
ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN
DO 130 J = 1, N
IF( UPPER )THEN
IBEG = 1
IF( UNIT )THEN
IEND = J - 1
ELSE
IEND = J
END IF
ELSE
IF( UNIT )THEN
IBEG = J + 1
ELSE
IBEG = J
END IF
IEND = N
END IF
DO 100 I = 1, IBEG - 1
AA( I + ( J - 1 )*LDA ) = ROGUE
100 CONTINUE
DO 110 I = IBEG, IEND
AA( I + ( J - 1 )*LDA ) = A( I, J )
110 CONTINUE
DO 120 I = IEND + 1, LDA
AA( I + ( J - 1 )*LDA ) = ROGUE
120 CONTINUE
130 CONTINUE
ELSE IF( TYPE.EQ.'SB'.OR.TYPE.EQ.'TB' )THEN
DO 170 J = 1, N
IF( UPPER )THEN
KK = KL + 1
IBEG = MAX( 1, KL + 2 - J )
IF( UNIT )THEN
IEND = KL
ELSE
IEND = KL + 1
END IF
ELSE
KK = 1
IF( UNIT )THEN
IBEG = 2
ELSE
IBEG = 1
END IF
IEND = MIN( KL + 1, 1 + M - J )
END IF
DO 140 I = 1, IBEG - 1
AA( I + ( J - 1 )*LDA ) = ROGUE
140 CONTINUE
DO 150 I = IBEG, IEND
AA( I + ( J - 1 )*LDA ) = A( I + J - KK, J )
150 CONTINUE
DO 160 I = IEND + 1, LDA
AA( I + ( J - 1 )*LDA ) = ROGUE
160 CONTINUE
170 CONTINUE
ELSE IF( TYPE.EQ.'SP'.OR.TYPE.EQ.'TP' )THEN
IOFF = 0
DO 190 J = 1, N
IF( UPPER )THEN
IBEG = 1
IEND = J
ELSE
IBEG = J
IEND = N
END IF
DO 180 I = IBEG, IEND
IOFF = IOFF + 1
AA( IOFF ) = A( I, J )
IF( I.EQ.J )THEN
IF( UNIT )
$ AA( IOFF ) = ROGUE
END IF
180 CONTINUE
190 CONTINUE
END IF
RETURN
*
* End of SMAKE.
*
END
SUBROUTINE SMVCH( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y,
$ INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV )
*
* Checks the results of the computational tests.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0, ONE = 1.0 )
* .. Scalar Arguments ..
REAL ALPHA, BETA, EPS, ERR
INTEGER INCX, INCY, M, N, NMAX, NOUT
LOGICAL FATAL, MV
CHARACTER*1 TRANS
* .. Array Arguments ..
REAL A( NMAX, * ), G( * ), X( * ), Y( * ), YT( * ),
$ YY( * )
* .. Local Scalars ..
REAL ERRI
INTEGER I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL
LOGICAL TRAN
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* .. Executable Statements ..
TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
IF( TRAN )THEN
ML = N
NL = M
ELSE
ML = M
NL = N
END IF
IF( INCX.LT.0 )THEN
KX = NL
INCXL = -1
ELSE
KX = 1
INCXL = 1
END IF
IF( INCY.LT.0 )THEN
KY = ML
INCYL = -1
ELSE
KY = 1
INCYL = 1
END IF
*
* Compute expected result in YT using data in A, X and Y.
* Compute gauges in G.
*
IY = KY
DO 30 I = 1, ML
YT( IY ) = ZERO
G( IY ) = ZERO
JX = KX
IF( TRAN )THEN
DO 10 J = 1, NL
YT( IY ) = YT( IY ) + A( J, I )*X( JX )
G( IY ) = G( IY ) + ABS( A( J, I )*X( JX ) )
JX = JX + INCXL
10 CONTINUE
ELSE
DO 20 J = 1, NL
YT( IY ) = YT( IY ) + A( I, J )*X( JX )
G( IY ) = G( IY ) + ABS( A( I, J )*X( JX ) )
JX = JX + INCXL
20 CONTINUE
END IF
YT( IY ) = ALPHA*YT( IY ) + BETA*Y( IY )
G( IY ) = ABS( ALPHA )*G( IY ) + ABS( BETA*Y( IY ) )
IY = IY + INCYL
30 CONTINUE
*
* Compute the error ratio for this result.
*
ERR = ZERO
DO 40 I = 1, ML
ERRI = ABS( YT( I ) - YY( 1 + ( I - 1 )*ABS( INCY ) ) )/EPS
IF( G( I ).NE.ZERO )
$ ERRI = ERRI/G( I )
ERR = MAX( ERR, ERRI )
IF( ERR*SQRT( EPS ).GE.ONE )
$ GO TO 50
40 CONTINUE
* If the loop completes, all results are at least half accurate.
GO TO 70
*
* Report fatal error.
*
50 FATAL = .TRUE.
WRITE( NOUT, FMT = 9999 )
DO 60 I = 1, ML
IF( MV )THEN
WRITE( NOUT, FMT = 9998 )I, YT( I ),
$ YY( 1 + ( I - 1 )*ABS( INCY ) )
ELSE
WRITE( NOUT, FMT = 9998 )I,
$ YY( 1 + ( I - 1 )*ABS( INCY ) ), YT(I)
END IF
60 CONTINUE
*
70 CONTINUE
RETURN
*
9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
$ 'F ACCURATE *******', /' EXPECTED RESULT COMPU',
$ 'TED RESULT' )
9998 FORMAT( 1X, I7, 2G18.6 )
*
* End of SMVCH.
*
END
LOGICAL FUNCTION LSE( RI, RJ, LR )
*
* Tests if two arrays are identical.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Scalar Arguments ..
INTEGER LR
* .. Array Arguments ..
REAL RI( * ), RJ( * )
* .. Local Scalars ..
INTEGER I
* .. Executable Statements ..
DO 10 I = 1, LR
IF( RI( I ).NE.RJ( I ) )
$ GO TO 20
10 CONTINUE
LSE = .TRUE.
GO TO 30
20 CONTINUE
LSE = .FALSE.
30 RETURN
*
* End of LSE.
*
END
LOGICAL FUNCTION LSERES( TYPE, UPLO, M, N, AA, AS, LDA )
*
* Tests if selected elements in two arrays are equal.
*
* TYPE is 'GE', 'SY' or 'SP'.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Scalar Arguments ..
INTEGER LDA, M, N
CHARACTER*1 UPLO
CHARACTER*2 TYPE
* .. Array Arguments ..
REAL AA( LDA, * ), AS( LDA, * )
* .. Local Scalars ..
INTEGER I, IBEG, IEND, J
LOGICAL UPPER
* .. Executable Statements ..
UPPER = UPLO.EQ.'U'
IF( TYPE.EQ.'GE' )THEN
DO 20 J = 1, N
DO 10 I = M + 1, LDA
IF( AA( I, J ).NE.AS( I, J ) )
$ GO TO 70
10 CONTINUE
20 CONTINUE
ELSE IF( TYPE.EQ.'SY' )THEN
DO 50 J = 1, N
IF( UPPER )THEN
IBEG = 1
IEND = J
ELSE
IBEG = J
IEND = N
END IF
DO 30 I = 1, IBEG - 1
IF( AA( I, J ).NE.AS( I, J ) )
$ GO TO 70
30 CONTINUE
DO 40 I = IEND + 1, LDA
IF( AA( I, J ).NE.AS( I, J ) )
$ GO TO 70
40 CONTINUE
50 CONTINUE
END IF
*
60 CONTINUE
LSERES = .TRUE.
GO TO 80
70 CONTINUE
LSERES = .FALSE.
80 RETURN
*
* End of LSERES.
*
END
REAL FUNCTION SBEG( RESET )
*
* Generates random numbers uniformly distributed between -0.5 and 0.5.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Scalar Arguments ..
LOGICAL RESET
* .. Local Scalars ..
INTEGER I, IC, MI
* .. Save statement ..
SAVE I, IC, MI
* .. Intrinsic Functions ..
INTRINSIC REAL
* .. Executable Statements ..
IF( RESET )THEN
* Initialize local variables.
MI = 891
I = 7
IC = 0
RESET = .FALSE.
END IF
*
* The sequence of values of I is bounded between 1 and 999.
* If initial I = 1,2,3,6,7 or 9, the period will be 50.
* If initial I = 4 or 8, the period will be 25.
* If initial I = 5, the period will be 10.
* IC is used to break up the period by skipping 1 value of I in 6.
*
IC = IC + 1
10 I = I*MI
I = I - 1000*( I/1000 )
IF( IC.GE.5 )THEN
IC = 0
GO TO 10
END IF
SBEG = REAL( I - 500 )/1001.0
RETURN
*
* End of SBEG.
*
END
REAL FUNCTION SDIFF( X, Y )
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
*
* .. Scalar Arguments ..
REAL X, Y
* .. Executable Statements ..
SDIFF = X - Y
RETURN
*
* End of SDIFF.
*
END
SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
*
* Tests whether XERBLA has detected an error when it should.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Scalar Arguments ..
INTEGER INFOT, NOUT
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
* .. Executable Statements ..
IF( .NOT.LERR )THEN
WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT
OK = .FALSE.
END IF
LERR = .FALSE.
RETURN
*
9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D',
$ 'ETECTED BY ', A6, ' *****' )
*
* End of CHKXER.
*
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/sblas2/sblat2.in 0000644 0001750 0001750 00000002672 10616163240 024127 0 ustar osallou osallou 'sblat2.out' NAME OF SUMMARY OUTPUT FILE
6 UNIT NUMBER OF SUMMARY FILE
'SBLAT2.SNAP' NAME OF SNAPSHOT OUTPUT FILE
-1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
F LOGICAL FLAG, T TO STOP ON FAILURES.
T LOGICAL FLAG, T TO TEST ERROR EXITS.
16.0 THRESHOLD VALUE OF TEST RATIO
6 NUMBER OF VALUES OF N
0 1 2 3 5 9 VALUES OF N
4 NUMBER OF VALUES OF K
0 1 2 4 VALUES OF K
4 NUMBER OF VALUES OF INCX AND INCY
1 2 -1 -2 VALUES OF INCX AND INCY
3 NUMBER OF VALUES OF ALPHA
0.0 1.0 0.7 VALUES OF ALPHA
3 NUMBER OF VALUES OF BETA
0.0 1.0 0.9 VALUES OF BETA
SGEMV T PUT F FOR NO TEST. SAME COLUMNS.
SGBMV T PUT F FOR NO TEST. SAME COLUMNS.
SSYMV T PUT F FOR NO TEST. SAME COLUMNS.
SSBMV T PUT F FOR NO TEST. SAME COLUMNS.
SSPMV T PUT F FOR NO TEST. SAME COLUMNS.
STRMV T PUT F FOR NO TEST. SAME COLUMNS.
STBMV T PUT F FOR NO TEST. SAME COLUMNS.
STPMV T PUT F FOR NO TEST. SAME COLUMNS.
STRSV T PUT F FOR NO TEST. SAME COLUMNS.
STBSV T PUT F FOR NO TEST. SAME COLUMNS.
STPSV T PUT F FOR NO TEST. SAME COLUMNS.
SGER T PUT F FOR NO TEST. SAME COLUMNS.
SSYR T PUT F FOR NO TEST. SAME COLUMNS.
SSPR T PUT F FOR NO TEST. SAME COLUMNS.
SSYR2 T PUT F FOR NO TEST. SAME COLUMNS.
SSPR2 T PUT F FOR NO TEST. SAME COLUMNS.
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/sblas2/Makefile 0000644 0001750 0001750 00000002545 10616442122 024046 0 ustar osallou osallou .SUFFIXES: .f .java
ROOT=../../..
include $(ROOT)/make.def
XERBLAFLAGS= -c .:$(ROOT)/$(BLAS_OBJ) -p $(ERR_PACKAGE)
F2JFLAGS=-c .:$(ROOT)/$(BLAS_OBJ) -p $(SBLASTEST_PACKAGE) -o $(OUTDIR) $(STATIC)
tester: $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(SBLAS2TEST_IDX) $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
/bin/rm -f $(SBLAS2TEST_JAR)
cd $(OUTDIR); $(JAR) cvf0 ../$(SBLAS2TEST_JAR) `find . -name "*.class"`
$(JAR) uvf0 $(SBLAS2TEST_JAR) `find org -name "*.class"`
nojar: $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(SBLAS2TEST_IDX) $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
$(ROOT)/$(SBLAS2TEST_IDX): sblat2.f
$(F2J) $(XERBLAFLAGS) xerbla.f > /dev/null
$(F2J) $(F2JFLAGS) $< > /dev/null
$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):
cd $(ROOT)/$(BLAS_DIR); $(MAKE)
$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):
cd $(ROOT)/$(UTIL_DIR); $(MAKE)
runtest: tester
$(JAVA) $(JFLAGS) -cp .:$(SBLAS2TEST_JAR):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR) $(SBLASTEST_PACKAGE).Sblat2 < sblat2.in
srctest:
$(MAKE) -f Makefile_javasrc
verify: $(ROOT)/$(SBLAS2TEST_IDX)
cd $(OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:..:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR) $(VERIFY) $(SBLASTEST_PDIR)/*.class
clean:
/bin/rm -rf *.java *.class *.f2j org $(OUTDIR) $(JAVASRC_OUTDIR) $(SBLAS2TEST_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/sblas2/xerbla.f 0000644 0001750 0001750 00000003400 10616163240 024022 0 ustar osallou osallou SUBROUTINE XERBLA( SRNAME, INFO )
*
* f2j NOTE: this is compiled separately from dblat2.f because
* it needs to be in package org.netlib.err while the rest of
* dblat2.f routines should be in org.netlib.blas.testing.
*
* This is a special version of XERBLA to be used only as part of
* the test program for testing error exits from the Level 2 BLAS
* routines.
*
* XERBLA is an error handler for the Level 2 BLAS routines.
*
* It is called by the Level 2 BLAS routines if an input parameter is
* invalid.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Scalar Arguments ..
INTEGER INFO
CHARACTER*6 SRNAME
* .. Scalars in Common ..
INTEGER INFOT, NOUT
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUT, OK, LERR
COMMON /SRNAMC/SRNAMT
* .. Executable Statements ..
LERR = .TRUE.
IF( INFO.NE.INFOT )THEN
IF( INFOT.NE.0 )THEN
WRITE( NOUT, FMT = 9999 )INFO, INFOT
ELSE
WRITE( NOUT, FMT = 9997 )INFO
END IF
OK = .FALSE.
END IF
IF( SRNAME.NE.SRNAMT )THEN
WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT
OK = .FALSE.
END IF
RETURN
*
9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD',
$ ' OF ', I2, ' *******' )
9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE',
$ 'AD OF ', A6, ' *******' )
9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6,
$ ' *******' )
*
* End of XERBLA
*
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/eig/ 0000755 0001750 0001750 00000000000 11734055025 021762 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/eig/dgd.in 0000644 0001750 0001750 00000010456 10616163234 023056 0 ustar osallou osallou DGS Data for the Real Nonsymmetric Schur Form Driver
5 Number of matrix dimensions
2 6 10 12 20 30 Matrix dimensions
1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
10 Threshold for test ratios
.TRUE. Put T to test the error exits
0 Code to interpret the seed
DGS 26 Test all 26 matrix types
DGV Data for the Real Nonsymmetric Eigenvalue Problem Driver
6 Number of matrix dimensions
2 6 8 10 15 20 Matrix dimensions
1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
10 Threshold value
.TRUE. Put T to test the error exits
0 Code to interpret the seed
DGV 26 Test all 26 matrix types
DGX Data for the Real Nonsymmetric Schur Form Expert Driver
2 Largest matrix dimension (0 <= NSIZE <= 5)
1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
10 Threshold for test ratios
.TRUE. Put T to test the error exits
0 Code to interpret the seed
DGX Data for the Real Nonsymmetric Schur Form Expert Driver
0 Largest matrix dimension
1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
10 Threshold for test ratios
.TRUE. Put T to test the error exits
0 Code to interpret the seed
4
2
8.0000D+00 4.0000D+00 -1.3000D+01 4.0000D+00 Input matrix A
0.0000D+00 7.0000D+00 -2.4000D+01 -3.0000D+00
0.0000D+00 0.0000D+00 3.0000D+00 -5.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 1.6000D+01
9.0000D+00 -1.0000D+00 1.0000D+00 -6.0000D+00 Input matrix B
0.0000D+00 4.0000D+00 1.6000D+01 -2.4000D+01
0.0000D+00 0.0000D+00 -1.1000D+01 6.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 4.0000D+00
2.5901D-01 1.7592D+00 Condition #'s for cluster selected from lower 2x2
4
2
1.0000D+00 2.0000D+00 3.0000D+00 4.0000D+00 Input matrix A
0.0000D+00 5.0000D+00 6.0000D+00 7.0000D+00
0.0000D+00 0.0000D+00 8.0000D+00 9.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+01
-1.0000D+00 -1.0000D+00 -1.0000D+00 -1.0000D+00 Input matrix B
0.0000D+00 -1.0000D+00 -1.0000D+00 -1.0000D+00
0.0000D+00 0.0000D+00 1.0000D+00 -1.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
9.8173D-01 6.3649D-01 Condition #'s for cluster selected from lower 2x2
0
DXV Data for the Real Nonsymmetric Eigenvalue Expert Driver
5 Largest matrix dimension
1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
10 Threshold for test ratios
.TRUE. Put T to test the error exits
0 Code to interpret the seed
DXV Data for the Real Nonsymmetric Eigenvalue Expert Driver
0 Largest matrix dimension
1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
10 Threshold for test ratios
.TRUE. Put T to test the error exits
0 Code to interpret the seed
4
8.0000D+00 4.0000D+00 -1.3000D+01 4.0000D+00 Input matrix A
0.0000D+00 7.0000D+00 -2.4000D+01 -3.0000D+00
0.0000D+00 0.0000D+00 3.0000D+00 -5.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 1.6000D+01
9.0000D+00 -1.0000D+00 1.0000D+00 -6.0000D+00 Input matrix B
0.0000D+00 4.0000D+00 1.6000D+01 -2.4000D+01
0.0000D+00 0.0000D+00 -1.1000D+01 6.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 4.0000D+00
3.1476D+00 2.5286D+00 4.2241D+00 3.4160D+00 eigenvalue condition #'s
6.7340D-01 1.1380D+00 3.5424D+00 9.5917D-01 eigenvector condition #'s
4
1.0000D+00 2.0000D+00 3.0000D+00 4.0000D+00 Input matrix A
0.0000D+00 5.0000D+00 6.0000D+00 7.0000D+00
0.0000D+00 0.0000D+00 8.0000D+00 9.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+01
-1.0000D+00 -1.0000D+00 -1.0000D+00 -1.0000D+00 Input matrix B
0.0000D+00 -1.0000D+00 -1.0000D+00 -1.0000D+00
0.0000D+00 0.0000D+00 1.0000D+00 -1.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
1.3639D+00 4.0417D+00 6.4089D-01 6.8030D-01 eigenvalue condition #'s
7.6064D-01 8.4964D-01 1.1222D-01 1.1499D-01 eigenvector condition #'s
0
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/eig/dgbal.in 0000644 0001750 0001750 00000036213 10616163234 023370 0 ustar osallou osallou DGL: Tests DGGBAL
6
0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.3000D+01 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.4000D+01 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.5000D+01 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.6000D+01
0.6000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.5000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.4000D+01 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.3000D+01 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.2000D+01 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
1 1
0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.3000D+01 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.4000D+01 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.5000D+01 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.6000D+01
0.6000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.5000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.4000D+01 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.3000D+01 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.2000D+01 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01 0.6000D+01
0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01 0.6000D+01
6
0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.1000D+01 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.1000D+01 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01
0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
1 1
0.1000D+01 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.1000D+01 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
0.1000D+01 0.2000D+01 0.3000D+01 0.3000D+01 0.2000D+01 0.1000D+01
0.1000D+01 0.2000D+01 0.3000D+01 0.3000D+01 0.2000D+01 0.1000D+01
6
0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.1000D+01 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.1000D+01 0.2000D+01 0.3000D+01 0.0000D+00 0.0000D+00 0.0000D+00
0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.0000D+00 0.0000D+00
0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01 0.0000D+00
0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01 0.6000D+01
0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.1000D+01 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.1000D+01 0.2000D+01 0.3000D+01 0.0000D+00 0.0000D+00 0.0000D+00
0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.0000D+00 0.0000D+00
0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01 0.0000D+00
0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01 0.6000D+01
1 1
0.6000D+01 0.5000D+01 0.4000D+01 0.3000D+01 0.2000D+01 0.1000D+01
0.0000D+00 0.5000D+01 0.4000D+01 0.3000D+01 0.2000D+01 0.1000D+01
0.0000D+00 0.0000D+00 0.4000D+01 0.3000D+01 0.2000D+01 0.1000D+01
0.0000D+00 0.0000D+00 0.0000D+00 0.3000D+01 0.2000D+01 0.1000D+01
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.2000D+01 0.1000D+01
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
0.6000D+01 0.5000D+01 0.4000D+01 0.3000D+01 0.2000D+01 0.1000D+01
0.0000D+00 0.5000D+01 0.4000D+01 0.3000D+01 0.2000D+01 0.1000D+01
0.0000D+00 0.0000D+00 0.4000D+01 0.3000D+01 0.2000D+01 0.1000D+01
0.0000D+00 0.0000D+00 0.0000D+00 0.3000D+01 0.2000D+01 0.1000D+01
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.2000D+01 0.1000D+01
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
0.1000D+01 0.2000D+01 0.3000D+01 0.3000D+01 0.2000D+01 0.1000D+01
0.1000D+01 0.2000D+01 0.3000D+01 0.3000D+01 0.2000D+01 0.1000D+01
5
0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.1000D+01 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00
0.1000D+01 0.2000D+01 0.3000D+01 0.0000D+00 0.0000D+00
0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.0000D+00
0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01
0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
1 1
0.5000D+01 0.4000D+01 0.3000D+01 0.2000D+01 0.1000D+01
0.0000D+00 0.4000D+01 0.3000D+01 0.2000D+01 0.1000D+01
0.0000D+00 0.0000D+00 0.3000D+01 0.2000D+01 0.1000D+01
0.0000D+00 0.0000D+00 0.0000D+00 0.2000D+01 0.1000D+01
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
0.1000D+01 0.2000D+01 0.3000D+01 0.2000D+01 0.1000D+01
0.1000D+01 0.2000D+01 0.3000D+01 0.2000D+01 0.1000D+01
6
0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11
0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11
0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
1 6
0.1000D-03 0.1000D+05 0.1000D+04 0.1000D+02 0.1000D+00 0.1000D-01
0.1000D-02 0.1000D-04 0.1000D+05 0.1000D+03 0.1000D+01 0.1000D+00
0.1000D+00 0.1000D-02 0.1000D-03 0.1000D+05 0.1000D+03 0.1000D+02
0.1000D+02 0.1000D+00 0.1000D-01 0.1000D-03 0.1000D+05 0.1000D+04
0.1000D+03 0.1000D+01 0.1000D+00 0.1000D-02 0.1000D-04 0.1000D+05
0.1000D+05 0.1000D+03 0.1000D+02 0.1000D+00 0.1000D-02 0.1000D-03
0.1000D-03 0.1000D+05 0.1000D+04 0.1000D+02 0.1000D+00 0.1000D-01
0.1000D-02 0.1000D-04 0.1000D+05 0.1000D+03 0.1000D+01 0.1000D+00
0.1000D+00 0.1000D-02 0.1000D-03 0.1000D+05 0.1000D+03 0.1000D+02
0.1000D+02 0.1000D+00 0.1000D-01 0.1000D-03 0.1000D+05 0.1000D+04
0.1000D+03 0.1000D+01 0.1000D+00 0.1000D-02 0.1000D-04 0.1000D+05
0.1000D+05 0.1000D+03 0.1000D+02 0.1000D+00 0.1000D-02 0.1000D-03
0.1000D-05 0.1000D-04 0.1000D-02 0.1000D+00 0.1000D+01 0.1000D+03
0.1000D+03 0.1000D+01 0.1000D+00 0.1000D-02 0.1000D-04 0.1000D-05
6
0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D-05 0.1000D+07
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D-05 0.1000D-05
0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+07 0.1000D+07
0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D-05 0.1000D+07
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D-05 0.1000D-05
0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+07 0.1000D+07
4 6
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D-04 0.1000D+04 0.1000D+00
0.0000D+00 0.1000D+01 0.1000D+01 0.1000D-04 0.1000D+04 0.1000D+00
0.0000D+00 0.0000D+00 0.1000D+01 0.1000D-04 0.1000D+04 0.1000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D-03 0.1000D+05
0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+05 0.1000D+01 0.1000D-03
0.0000D+00 0.0000D+00 0.0000D+00 0.1000D-03 0.1000D+05 0.1000D+01
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D-04 0.1000D+04 0.1000D+00
0.0000D+00 0.1000D+01 0.1000D+01 0.1000D-04 0.1000D+04 0.1000D+00
0.0000D+00 0.0000D+00 0.1000D+01 0.1000D-04 0.1000D+04 0.1000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D-03 0.1000D+05
0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+05 0.1000D+01 0.1000D-03
0.0000D+00 0.0000D+00 0.0000D+00 0.1000D-03 0.1000D+05 0.1000D+01
0.4000D+01 0.4000D+01 0.4000D+01 0.1000D+00 0.1000D+04 0.1000D-04
0.2000D+01 0.3000D+01 0.4000D+01 0.1000D-04 0.1000D+04 0.1000D+00
7
0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01
0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01
0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01
0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00
0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.1000D+01
0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01
0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01
0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01
0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01
0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00
0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.1000D+01
0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01
3 5
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01
0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01
0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01
0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01
0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
0.1000D+01
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.1000D+01
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01
0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01
0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01
0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01
0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
0.1000D+01
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.1000D+01
0.3000D+01 0.2000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.6000D+01
0.5000D+01
0.1000D+01 0.3000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.2000D+01
0.2000D+01
6
-0.2000D+02 -0.1000D+05 -0.2000D+01 -0.1000D+07 -0.1000D+02 -0.2000D+06
0.6000D-02 0.4000D+01 0.6000D-03 0.2000D+03 0.3000D-02 0.3000D+02
-0.2000D+00 -0.3000D+03 -0.4000D-01 -0.1000D+05 0.0000D+00 0.3000D+04
0.6000D-04 0.4000D-01 0.9000D-05 0.9000D+01 0.3000D-04 0.5000D+00
0.6000D-01 0.5000D+02 0.8000D-02 -0.4000D+04 0.8000D-01 0.0000D+00
0.0000D+00 0.1000D+04 0.7000D+00 -0.2000D+06 0.1300D+02 -0.6000D+05
-0.2000D+02 -0.1000D+05 0.2000D+01 -0.2000D+07 0.1000D+02 -0.1000D+06
0.5000D-02 0.3000D+01 -0.2000D-03 0.4000D+03 -0.1000D-02 0.3000D+02
0.0000D+00 -0.1000D+03 -0.8000D-01 0.2000D+05 -0.4000D+00 0.0000D+00
0.5000D-04 0.3000D-01 0.2000D-05 0.4000D+01 0.2000D-04 0.1000D+00
0.4000D-01 0.3000D+02 -0.1000D-02 0.3000D+04 -0.1000D-01 0.6000D+03
-0.1000D+01 0.0000D+00 0.4000D+00 -0.1000D+06 0.4000D+01 0.2000D+05
1 6
-0.2000D+00 -0.1000D+01 -0.2000D+00 -0.1000D+01 -0.1000D+01 -0.2000D+01
0.6000D+00 0.4000D+01 0.6000D+00 0.2000D+01 0.3000D+01 0.3000D+01
-0.2000D+00 -0.3000D+01 -0.4000D+00 -0.1000D+01 0.0000D+00 0.3000D+01
0.6000D+00 0.4000D+01 0.9000D+00 0.9000D+01 0.3000D+01 0.5000D+01
0.6000D+00 0.5000D+01 0.8000D+00 -0.4000D+01 0.8000D+01 0.0000D+00
0.0000D+00 0.1000D+01 0.7000D+00 -0.2000D+01 0.1300D+02 -0.6000D+01
-0.2000D+00 -0.1000D+01 0.2000D+00 -0.2000D+01 0.1000D+01 -0.1000D+01
0.5000D+00 0.3000D+01 -0.2000D+00 0.4000D+01 -0.1000D+01 0.3000D+01
0.0000D+00 -0.1000D+01 -0.8000D+00 0.2000D+01 -0.4000D+01 0.0000D+00
0.5000D+00 0.3000D+01 0.2000D+00 0.4000D+01 0.2000D+01 0.1000D+01
0.4000D+00 0.3000D+01 -0.1000D+00 0.3000D+01 -0.1000D+01 0.6000D+01
-0.1000D+00 0.0000D+00 0.4000D+00 -0.1000D+01 0.4000D+01 0.2000D+01
0.1000D-02 0.1000D+02 0.1000D+00 0.1000D+04 0.1000D+01 0.1000D-01
0.1000D+02 0.1000D+00 0.1000D+03 0.1000D-02 0.1000D+03 0.1000D-01
0
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/eig/dbb.in 0000644 0001750 0001750 00000001222 10616163234 023036 0 ustar osallou osallou DBB: Data file for testing banded Singular Value Decomposition routines
20 Number of values of M
0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 10 10 16 16 Values of M
0 1 2 3 0 1 2 3 0 1 2 3 0 1 2 3 10 16 10 16 Values of N
5 Number of values of K
0 1 2 3 16 Values of K (band width)
2 Number of values of NRHS
1 2 Values of NRHS
20.0 Threshold value
F Put T to test the error exits
1 Code to interpret the seed
DBB 15
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/eig/Makefile_javasrc 0000644 0001750 0001750 00000003213 10616163234 025132 0 ustar osallou osallou .PHONY: DUMMY
.SUFFIXES: .f .java
ROOT=../../..
include $(ROOT)/make.def
BLAS=$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR)
LAPACK=$(ROOT)/$(LAPACK_DIR)/$(LAPACK_JAR)
MATGEN=$(ROOT)/$(MATGEN_DIR)/$(MATGEN_JAR)
tester: $(BLAS) $(LAPACK) $(MATGEN) $(OUTDIR)/Eigtest.f2j util
/bin/rm -f `find $(OUTDIR) -name "*.class"`
mkdir -p $(JAVASRC_OUTDIR)
$(JAVAC) -classpath .:$(JAVASRC_OUTDIR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(MATGEN):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/$(LAPACK_DIR)/$(LAPACK_JAR) -d $(JAVASRC_OUTDIR) $(OUTDIR)/$(EIGTEST_PDIR)/*.java
/bin/rm -f $(JAVASRC_OUTDIR)/$(EIGTEST_PDIR)/*.old
$(JAVAB) $(JAVASRC_OUTDIR)/$(EIGTEST_PDIR)/*.class
/bin/rm -f $(EIGTEST_JAR)
cd $(JAVASRC_OUTDIR); $(JAR) cvf ../$(EIGTEST_JAR) `find . -name "*.class"`
$(JAR) uvf $(EIGTEST_JAR) `find org -name "*.class"`
$(OUTDIR)/Eigtest.f2j: eigtest.f
$(MAKE) nojar
$(BLAS):
cd $(ROOT)/$(BLAS_DIR); $(MAKE) -f Makefile_javasrc
$(LAPACK):
cd $(ROOT)/$(LAPACK_DIR); $(MAKE) -f Makefile_javasrc
$(MATGEN):
cd $(ROOT)/$(MATGEN_DIR); $(MAKE) -f Makefile_javasrc
util:
cd $(ROOT)/$(UTIL_DIR); $(MAKE)
runtest: tester *.in
*.in: DUMMY
$(JAVA) $(JFLAGS) -cp .:$(EIGTEST_JAR):$(MATGEN):$(BLAS):$(LAPACK):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR) $(EIGTEST_PACKAGE).Dchkee < $@
verify: $(ROOT)/$(EIGTEST_IDX)
cd $(JAVASRC_OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:..:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(MATGEN_DIR)/$(MATGEN_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/../$(LAPACK_DIR)/$(LAPACK_JAR) $(VERIFY) $(EIGTEST_PDIR)/*.class
clean:
/bin/rm -rf *.java *.class *.f2j org $(JAVASRC_OUTDIR) $(OUTDIR) $(EIGTEST_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/eig/nep.in 0000644 0001750 0001750 00000002132 10616163237 023075 0 ustar osallou osallou NEP: Data file for testing Nonsymmetric Eigenvalue Problem routines
7 Number of values of N
0 1 2 3 5 10 16 Values of N (dimension)
5 Number of values of NB, NBMIN, NX, INMIN, IN WIN, INIBL, ISHFTS, and IACC22
1 3 3 3 20 Values of NB (blocksize)
2 2 2 2 2 Values of NBMIN (minimum blocksize)
1 0 5 9 1 Values of NX (crossover point)
11 12 11 15 11 Values of INMIN (LAHQR vs TTQRE crossover point, >= 11)
2 3 5 3 2 Values of INWIN (recommended deflation window size)
0 5 7 3 200 Values of INIBL (nibble crossover point)
1 2 4 2 1 Values of ISHFTS (number of simultaneous shifts)
0 1 2 0 1 Values of IACC22 (select structured matrix multiply: 0, 1 or 2)
20.0 Threshold value
T Put T to test the error exits
1 Code to interpret the seed
NEP 21
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/eig/Makefile 0000644 0001750 0001750 00000003126 10616163234 023424 0 ustar osallou osallou .PHONY: DUMMY
.SUFFIXES: .f .java
ROOT=../../..
include $(ROOT)/make.def
BLAS=$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR)
LAPACK=$(ROOT)/$(LAPACK_DIR)/$(LAPACK_JAR)
MATGEN=$(ROOT)/$(MATGEN_DIR)/$(MATGEN_JAR)
XERBLAFLAGS= -c .:$(ROOT)/$(BLAS_OBJ) -p $(ERR_PACKAGE)
F2JFLAGS=-c .:$(ROOT)/$(BLAS_OBJ):$(ROOT)/$(LAPACK_OBJ):$(ROOT)/$(MATGEN_OBJ) -p $(EIGTEST_PACKAGE) -o $(OUTDIR) $(STATIC)
tester: $(BLAS) $(LAPACK) $(MATGEN) $(OUTDIR)/Eigtest.f2j util
/bin/rm -f $(EIGTEST_JAR)
cd $(OUTDIR); $(JAR) cvf ../$(EIGTEST_JAR) `find . -name "*.class"`
$(JAR) uvf $(EIGTEST_JAR) `find org -name "*.class"`
nojar: $(BLAS) $(LAPACK) $(MATGEN) $(OUTDIR)/Eigtest.f2j util
$(OUTDIR)/Eigtest.f2j: eigtest.f
$(F2J) $(XERBLAFLAGS) xerbla.f > /dev/null
$(F2J) $(F2JFLAGS) $< > /dev/null
$(BLAS):
cd $(ROOT)/$(BLAS_DIR); $(MAKE)
$(LAPACK):
cd $(ROOT)/$(LAPACK_DIR); $(MAKE)
$(MATGEN):
cd $(ROOT)/$(MATGEN_DIR); $(MAKE)
util:
cd $(ROOT)/$(UTIL_DIR); $(MAKE)
runtest: tester *.in
srctest:
$(MAKE) -f Makefile_javasrc runtest
verify: $(ROOT)/$(EIGTEST_IDX)
cd $(OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:..:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(MATGEN_DIR)/$(MATGEN_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/../$(LAPACK_DIR)/$(LAPACK_JAR) $(VERIFY) $(EIGTEST_PDIR)/*.class
*.in: DUMMY
$(JAVA) $(JFLAGS) -cp .:$(EIGTEST_JAR):$(MATGEN):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/$(LAPACK_DIR)/$(LAPACK_JAR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR) $(EIGTEST_PACKAGE).Dchkee < $@
clean:
/bin/rm -rf *.java *.class *.f2j org $(JAVASRC_OUTDIR) $(OUTDIR) $(EIGTEST_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/eig/gsv.in 0000644 0001750 0001750 00000001031 10616163237 023107 0 ustar osallou osallou GSV: Data file for testing Generalized SVD routines
8 Number of values of M, P, N
0 5 9 10 20 12 12 40 Values of M (row dimension)
4 0 12 14 10 10 20 15 Values of P (row dimension)
3 10 15 12 8 20 8 20 Values of N (column dimension)
20.0 Threshold value of test ratio
T Put T to test the error exits
1 Code to interpret the seed
GSV 8 List types on next line if 0 < NTYPES < 8
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/eig/dgg.in 0000644 0001750 0001750 00000001563 10616163234 023060 0 ustar osallou osallou DGG: Data file for testing Nonsymmetric Eigenvalue Problem routines
7 Number of values of N
0 1 2 3 5 10 16 Values of N (dimension)
4 Number of parameter values
1 1 2 2 Values of NB (blocksize)
40 40 2 2 Values of NBMIN (minimum blocksize)
2 4 2 4 Values of NSHIFT (no. of shifts)
40 40 2 2 Values of MAXB (multishift crossover pt)
40 40 2 2 Values of NBCOL (minimum col. dimension)
20.0 Threshold value
T Put T to test the LAPACK routines
T Put T to test the driver routines
T Put T to test the error exits
1 Code to interpret the seed
DGG 26
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/eig/dsb.in 0000644 0001750 0001750 00000000735 10616163234 023067 0 ustar osallou osallou DSB: Data file for testing Symmetric Eigenvalue Problem routines
2 Number of values of N
5 20 Values of N (dimension)
5 Number of values of K
0 1 2 5 16 Values of K (band width)
20.0 Threshold value
T Put T to test the error exits
1 Code to interpret the seed
DSB 15
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/eig/glm.in 0000644 0001750 0001750 00000001105 10616163234 023066 0 ustar osallou osallou GLM: Data file for testing Generalized Linear Regression Model routines
6 Number of values of M, P, and N
0 5 8 15 20 40 Values of M (row dimension)
9 0 15 12 15 30 Values of P (row dimension)
5 5 10 25 30 40 Values of N (col dimension), M <= N <= M+P
20.0 Threshold value of test ratio
T Put T to test the error exits
1 Code to interpret the seed
GLM 8 List types on next line if 0 < NTYPES < 8
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/eig/dec.in 0000644 0001750 0001750 00000150725 10616163234 023057 0 ustar osallou osallou DEC Key indicating type of input
20.0 Threshold value for test ratios
8 2 7
1.0D+00 1.0D+00 1.1D+00 1.3D+00 2.0D+00 3.0D+00 -4.7D+00 3.3D+00
-1.0D+00 1.0D+00 3.7D+00 7.9D+00 4.0D+00 5.3D+00 3.3D+00 -9.0D-01
0.0D+00 0.0D+00 2.0D+00 -3.0D+00 3.4D+00 6.5D+00 5.2D+00 1.8D+00
0.0D+00 0.0D+00 4.0D+00 2.0D+00 -5.3D+00 -8.9D+00 -2.0D-01 -5.0D-01
0.0D+00 0.0D+00 0.0D+00 0.0D+00 4.2D+00 2.0D+00 3.3D+00 2.3D+00
0.0D+00 0.0D+00 0.0D+00 0.0D+00 -3.7D+00 4.2D+00 9.9D+00 8.8D+00
0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 9.9D+00 8.8D+00
0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.9D+00 9.9D+00
8 7 2
1.0D+00 1.0D+00 1.1D+00 1.3D+00 2.0D+00 3.0D+00 -4.7D+00 3.3D+00
-1.0D+00 1.0D+00 3.7D+00 7.9D+00 4.0D+00 5.3D+00 3.3D+00 -9.0D-01
0.0D+00 0.0D+00 2.0D+00 -3.0D+00 3.4D+00 6.5D+00 5.2D+00 1.8D+00
0.0D+00 0.0D+00 4.0D+00 2.0D+00 -5.3D+00 -8.9D+00 -2.0D-01 -5.0D-01
0.0D+00 0.0D+00 0.0D+00 0.0D+00 4.2D+00 2.0D+00 3.3D+00 2.3D+00
0.0D+00 0.0D+00 0.0D+00 0.0D+00 -3.7D+00 4.2D+00 9.9D+00 8.8D+00
0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 9.9D+00 8.8D+00
0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.9D+00 9.9D+00
8 1 7
1.0D+00 1.0D+00 1.1D+00 1.3D+00 2.0D+00 3.0D+00 -4.7D+00 3.3D+00
0.0D+00 1.0D+00 3.7D+00 7.9D+00 4.0D+00 5.3D+00 3.3D+00 -9.0D-01
0.0D+00 0.0D+00 2.0D+00 -3.0D+00 3.4D+00 6.5D+00 5.2D+00 1.8D+00
0.0D+00 0.0D+00 4.0D+00 2.0D+00 -5.3D+00 -8.9D+00 -2.0D-01 -5.0D-01
0.0D+00 0.0D+00 0.0D+00 0.0D+00 4.2D+00 2.0D+00 3.3D+00 2.3D+00
0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 4.2D+00 9.9D+00 8.8D+00
0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 9.9D+00 8.8D+00
0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.9D+00 9.9D+00
8 8 2
1.0D+00 1.0D+00 1.1D+00 1.3D+00 2.0D+00 3.0D+00 -4.7D+00 3.3D+00
-1.1D+00 1.0D+00 3.7D+00 7.9D+00 4.0D+00 5.3D+00 3.3D+00 -9.0D-01
0.0D+00 0.0D+00 2.0D+00 -3.0D+00 3.4D+00 6.5D+00 5.2D+00 1.8D+00
0.0D+00 0.0D+00 0.0D+00 2.0D+00 -5.3D+00 -8.9D+00 -2.0D-01 -5.0D-01
0.0D+00 0.0D+00 0.0D+00 0.0D+00 4.2D+00 2.0D+00 3.3D+00 2.3D+00
0.0D+00 0.0D+00 0.0D+00 0.0D+00 -3.7D+00 4.2D+00 9.9D+00 8.8D+00
0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 9.9D+00 8.8D+00
0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 9.9D+00
7 2 7
1.1D+00 1.0D-16 2.7D+00 3.3D+00 2.3D+00 3.4D+00 5.6D+00
-1.0D-16 1.1D+00 4.2D+00 5.1D+00 -1.0D-01 -2.0D-01 -3.0D-01
0.0D+00 0.0D+00 2.3D+00 1.0D+00 1.0D+02 1.0D+03 1.0D+02
0.0D+00 0.0D+00 0.0D+00 3.9D+00 3.2D+00 6.5D+00 3.2D+00
0.0D+00 0.0D+00 0.0D+00 -9.0D-01 3.9D+00 6.3D+00 3.0D+00
0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 6.3D+00 3.0D+00
0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.0D-01 6.3D+00
7 2 7
1.1D+00 1.0D-16 2.7D+00 3.3D+00 2.3D+00 3.4D+00 5.6D+00
-1.0D-16 1.1D+00 4.2D+00 5.1D+00 -1.0D-01 -2.0D-01 -3.0D-01
0.0D+00 0.0D+00 2.3D+00 1.0D+00 1.0D+02 1.0D+03 1.0D+02
0.0D+00 0.0D+00 0.0D+00 3.9D+00 3.2D-15 6.5D+00 3.2D+00
0.0D+00 0.0D+00 0.0D+00 -9.0D-16 3.9D+00 6.3D+00 3.0D+00
0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 6.3D+00 3.0D+00
0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 6.4D+00
7 2 7
1.1D+00 1.0D-16 2.7D+00 3.3D+00 2.3D+00 3.4D+00 5.6D+00
-1.0D-16 1.1D+00 4.2D+00 5.1D+00 -1.0D-01 -2.0D-01 -3.0D-01
0.0D+00 0.0D+00 2.3D+00 1.0D+00 1.0D+02 1.0D+03 1.0D+02
0.0D+00 0.0D+00 0.0D+00 3.9D+00 3.2D-15 6.5D+00 3.2D+00
0.0D+00 0.0D+00 0.0D+00 -9.0D-16 3.9D+00 6.3D+00 3.0D+00
0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 6.3D+00 3.0D+00
0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.0D-21 6.3D+00
7 1 7
1.1D+00 1.0D-16 2.7D+00 3.3D+00 2.3D+00 3.4D+00 5.6D+00
0.0D+00 1.1D+00 4.2D+00 5.1D+00 -1.0D-01 -2.0D-01 -3.0D-01
0.0D+00 0.0D+00 2.3D+00 1.0D+00 1.0D+02 1.0D+03 1.0D+02
0.0D+00 0.0D+00 0.0D+00 3.9D+00 3.2D-15 6.5D+00 3.2D+00
0.0D+00 0.0D+00 0.0D+00 -9.0D-16 3.9D+00 6.3D+00 3.0D+00
0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 6.3D+00 3.0D+00
0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.0D-21 6.3D+00
7 1 7
1.1D+00 -1.1D+00 2.7D+00 3.3D+00 2.3D+00 3.4D+00 5.6D+00
2.3D+00 1.1D+00 4.2D+00 5.1D+00 -1.0D-01 -2.0D-01 -3.0D-01
0.0D+00 0.0D+00 2.3D+00 1.0D+00 1.0D+02 1.0D+03 1.0D+02
0.0D+00 0.0D+00 0.0D+00 3.9D+00 3.2D+00 6.5D+00 3.2D+00
0.0D+00 0.0D+00 0.0D+00 -9.0D-21 3.9D+00 6.3D+00 3.0D+00
0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 6.3D+00 3.0D-20
0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.0D-21 6.3D+00
7 7 2
6.3D+00 3.0D+00 2.7D+00 3.3D+00 2.3D+00 3.4D+00 5.6D+00
-9.0D-01 6.3D+00 4.2D+00 5.1D+00 -1.0D-01 -2.0D-01 -3.0D-01
0.0D+00 0.0D+00 2.3D+00 1.0D+00 1.0D+02 1.0D+03 1.0D+02
0.0D+00 0.0D+00 0.0D+00 3.9D+00 3.2D+00 6.5D+00 3.2D+00
0.0D+00 0.0D+00 0.0D+00 0.0D+00 3.8D+00 6.3D+00 3.0D+00
0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 1.1D+00 1.4D-20
0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -1.6D-20 1.1D+00
7 7 2
6.3D+00 3.0D+00 2.7D+00 3.3D+00 2.3D+00 3.4D+00 5.6D+00
-9.0D-01 6.3D+00 4.2D+00 5.1D+00 -1.0D-01 -2.0D-01 -3.0D-01
0.0D+00 0.0D+00 2.3D+00 1.0D+00 1.0D+02 1.0D+03 1.0D+02
0.0D+00 0.0D+00 0.0D+00 3.9D+00 3.2D+00 6.5D+00 3.2D+00
0.0D+00 0.0D+00 0.0D+00 -9.0D-01 3.9D+00 6.3D+00 3.0D+00
0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 1.1D+00 1.4D-20
0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -1.6D-20 1.1D+00
7 7 2
1.1D+00 1.0D-16 2.7D+00 3.3D+00 2.3D+00 3.4D+00 5.6D+00
-1.0D-16 1.1D+00 4.2D+00 5.1D+00 -1.0D-01 -2.0D-01 -3.0D-01
0.0D+00 0.0D+00 2.3D+00 1.0D+00 1.0D+02 1.0D+03 1.0D+02
0.0D+00 0.0D+00 0.0D+00 3.9D+00 3.2D-15 6.5D+00 3.2D+00
0.0D+00 0.0D+00 0.0D+00 -9.0D-16 3.9D+00 6.3D+00 3.0D+00
0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 6.3D+00 3.0D+00
0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.0D-21 6.3D+00
7 7 1
1.1D+00 1.0D-16 2.7D+06 3.3D+00 2.3D+00 3.4D+00 5.6D+00
0.0D+00 1.1D+00 4.2D+06 5.1D+00 -1.0D-01 -2.0D-01 -3.0D-01
0.0D+00 0.0D+00 2.3D+00 1.0D+07 1.0D+08 1.0D+03 1.0D+02
0.0D+00 0.0D+00 0.0D+00 3.9D+00 3.2D-15 6.5D+04 3.2D+00
0.0D+00 0.0D+00 0.0D+00 -9.0D-16 3.9D+00 6.3D+03 3.0D+05
0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 6.3D+00 3.0D+00
0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.0D-21 6.3D+00
8 8 1
1.1D+00 -1.0D-16 2.7D+06 2.3D+04 3.3D+00 2.3D+00 3.4D+00 5.6D+00
1.0D-16 1.1D+00 4.2D+06 -1.0D-01 5.1D+00 -1.0D-01 -2.0D-01 -3.0D-01
0.0D+00 0.0D+00 2.3D+00 1.1D-16 1.0D+07 1.0D+08 1.0D+03 1.0D+02
0.0D+00 0.0D+00 -1.1D-13 2.3D+00 1.0D+07 1.0D+08 1.0D+03 1.0D+02
0.0D+00 0.0D+00 0.0D+00 0.0D+00 3.9D+00 3.2D-15 6.5D+04 3.2D+00
0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.0D-16 3.9D+00 6.3D+03 3.0D+05
0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 6.3D+00 3.0D-20
0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.0D-21 6.3D+00
0 0 0
1
0.0000D+00
0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
1
1.0000D+00
1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
2
0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
2
3.0000D+00 2.0000D+00
2.0000D+00 3.0000D+00
1.0000D+00 0.0000D+00 1.0000D+00 4.0000D+00
5.0000D+00 0.0000D+00 1.0000D+00 4.0000D+00
2
3.0000D+00 -2.0000D+00
2.0000D+00 3.0000D+00
3.0000D+00 2.0000D+00 1.0000D+00 4.0000D+00
3.0000D+00 -2.0000D+00 1.0000D+00 4.0000D+00
6
1.0000D-07 -1.0000D-07 1.0000D+00 1.1000D+00 2.3000D+00 3.7000D+00
3.0000D-07 1.0000D-07 1.0000D+00 1.0000D+00 -1.3000D+00 -7.7000D+00
0.0000D+00 0.0000D+00 3.0000D-07 1.0000D-07 2.2000D+00 3.3000D+00
0.0000D+00 0.0000D+00 -1.0000D-07 3.0000D-07 1.8000D+00 1.6000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 4.0000D-06 5.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 3.0000D+00 4.0000D-06
-3.8730D+00 0.0000D+00 6.9855D-01 2.2823D+00
1.0000D-07 1.7321D-07 9.7611D-08 5.0060D-14
1.0000D-07 -1.7321D-07 9.7611D-08 5.0060D-14
3.0000D-07 1.0000D-07 1.0000D-07 9.4094D-14
3.0000D-07 -1.0000D-07 1.0000D-07 9.4094D-14
3.8730D+00 0.0000D+00 4.0659D-01 1.5283D+00
4
7.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
-1.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
-1.0000D+00 1.0000D+00 5.0000D+00 -3.0000D+00
1.0000D+00 -1.0000D+00 3.0000D+00 3.0000D+00
3.9603D+00 4.0425D-02 1.1244D-05 3.1179D-05
3.9603D+00 -4.0425D-02 1.1244D-05 3.1179D-05
4.0397D+00 3.8854D-02 1.0807D-05 2.9981D-05
4.0397D+00 -3.8854D-02 1.0807D-05 2.9981D-05
5
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
0.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
0.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
0.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
0.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
5
1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
1.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
1.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
1.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
1.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
1.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
6
1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
6
1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
6
1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 2.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 3.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 4.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 5.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 6.0000D+00
1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
2.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
3.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
4.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
5.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
6.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
4
9.4480D-01 6.7670D-01 6.9080D-01 5.9650D-01
5.8760D-01 8.6420D-01 6.7690D-01 7.2600D-02
7.2560D-01 1.9430D-01 9.6870D-01 2.8310D-01
2.8490D-01 5.8000D-02 4.8450D-01 7.3610D-01
2.4326D-01 2.1409D-01 8.7105D-01 3.5073D-01
2.4326D-01 -2.1409D-01 8.7105D-01 3.5073D-01
7.4091D-01 0.0000D+00 9.8194D-01 4.6989D-01
2.2864D+00 0.0000D+00 9.7723D-01 1.5455D+00
6
5.0410D-01 6.6520D-01 7.7190D-01 6.3870D-01 5.9550D-01 6.1310D-01
1.5740D-01 3.7340D-01 5.9840D-01 1.5470D-01 9.4270D-01 6.5900D-02
4.4170D-01 7.2300D-02 1.5440D-01 5.4920D-01 8.7000D-03 3.0040D-01
2.0080D-01 6.0800D-01 3.0340D-01 8.4390D-01 2.3900D-01 5.7680D-01
9.3610D-01 7.4130D-01 1.4440D-01 1.7860D-01 1.4280D-01 7.2630D-01
5.5990D-01 9.3360D-01 7.8000D-02 4.0930D-01 6.7140D-01 5.6170D-01
-5.2278D-01 0.0000D+00 2.7888D-01 1.1793D-01
-3.5380D-01 0.0000D+00 3.5427D-01 6.8911D-02
-8.0876D-03 0.0000D+00 3.4558D-01 1.3489D-01
3.4760D-01 3.0525D-01 5.4661D-01 1.7729D-01
3.4760D-01 -3.0525D-01 5.4661D-01 1.7729D-01
2.7698D+00 0.0000D+00 9.6635D-01 1.8270D+00
5
2.0000D-03 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 1.0000D-03 1.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 -1.0000D-03 1.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 -2.0000D-03 1.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
-2.0000D-03 0.0000D+00 2.4000D-11 2.3952D-11
-1.0000D-03 0.0000D+00 6.0000D-12 5.9940D-12
0.0000D+00 0.0000D+00 4.0000D-12 3.9920D-12
1.0000D-03 0.0000D+00 6.0000D-12 5.9940D-12
2.0000D-03 0.0000D+00 2.4000D-11 2.3952D-11
10
4.8630D-01 9.1260D-01 2.1900D-02 6.0110D-01 1.4050D-01 2.0840D-01
8.2640D-01 8.4410D-01 3.1420D-01 8.6750D-01
7.1500D-01 2.6480D-01 8.8510D-01 2.6150D-01 5.9520D-01 4.7800D-01
7.6730D-01 4.6110D-01 5.7320D-01 7.7000D-03
2.1210D-01 5.5080D-01 5.2350D-01 3.0810D-01 6.6020D-01 2.8900D-01
2.3140D-01 2.2790D-01 9.6600D-02 1.0910D-01
7.1510D-01 8.5790D-01 5.7710D-01 5.1140D-01 1.9010D-01 9.0810D-01
6.0090D-01 7.1980D-01 1.0640D-01 8.6840D-01
5.6800D-01 2.8100D-02 4.0140D-01 6.3150D-01 1.1480D-01 7.5800D-02
9.4230D-01 7.2030D-01 3.6850D-01 1.7430D-01
7.7210D-01 3.0280D-01 5.5640D-01 9.9980D-01 3.6520D-01 5.2580D-01
3.7030D-01 6.7790D-01 9.9350D-01 5.0270D-01
7.3960D-01 4.5600D-02 7.4740D-01 9.2880D-01 2.2000D-03 8.2600D-02
3.6340D-01 4.9120D-01 9.4050D-01 3.8910D-01
5.6370D-01 8.5540D-01 3.2100D-02 2.6380D-01 3.6090D-01 6.4970D-01
8.4690D-01 9.3500D-01 3.7000D-02 2.9170D-01
8.6560D-01 6.3270D-01 3.5620D-01 6.3560D-01 2.7360D-01 6.5120D-01
1.0220D-01 2.8880D-01 5.7620D-01 4.0790D-01
5.3320D-01 4.1210D-01 7.2870D-01 2.3110D-01 6.8300D-01 7.3860D-01
8.1800D-01 9.8150D-01 8.0550D-01 2.5660D-01
-4.6121D-01 7.2657D-01 4.7781D-01 1.5842D-01
-4.6121D-01 -7.2657D-01 4.7781D-01 1.5842D-01
-4.5164D-01 0.0000D+00 4.6034D-01 1.9931D-01
-1.4922D-01 4.8255D-01 4.7500D-01 9.1686D-02
-1.4922D-01 -4.8255D-01 4.7500D-01 9.1686D-02
3.3062D-02 0.0000D+00 2.9729D-01 8.2469D-02
3.0849D-01 1.1953D-01 4.2947D-01 3.9688D-02
3.0849D-01 -1.1953D-01 4.2947D-01 3.9688D-02
5.4509D-01 0.0000D+00 7.0777D-01 1.5033D-01
5.0352D+00 0.0000D+00 9.7257D-01 3.5548D+00
4
-3.8730D-01 3.6560D-01 3.1200D-02 -5.8340D-01
5.5230D-01 -1.1854D+00 9.8330D-01 7.6670D-01
1.6746D+00 -1.9900D-02 -1.8293D+00 5.7180D-01
-5.2500D-01 3.5340D-01 -2.7210D-01 -8.8300D-02
-1.8952D+00 7.5059D-01 8.1913D-01 7.7090D-01
-1.8952D+00 -7.5059D-01 8.1913D-01 7.7090D-01
-9.5162D-02 0.0000D+00 8.0499D-01 4.9037D-01
3.9520D-01 0.0000D+00 9.8222D-01 4.9037D-01
6
-1.0777D+00 1.7027D+00 2.6510D-01 8.5160D-01 1.0121D+00 2.5710D-01
-1.3400D-02 3.9030D-01 -1.2680D+00 2.7530D-01 -3.2350D-01 -1.3844D+00
1.5230D-01 3.0680D-01 8.7330D-01 -3.3410D-01 -4.8310D-01 -1.5416D+00
1.4470D-01 -6.0570D-01 3.1900D-02 -1.0905D+00 -8.3700D-02 6.2410D-01
-7.6510D-01 -1.7889D+00 -1.5069D+00 -6.0210D-01 5.2170D-01 6.4700D-01
8.1940D-01 2.1100D-01 5.4320D-01 7.5610D-01 1.7130D-01 5.5400D-01
-1.7029D+00 0.0000D+00 6.7909D-01 6.7220D-01
-1.0307D+00 0.0000D+00 7.2671D-01 2.0436D-01
2.8487D-01 1.2101D+00 3.9757D-01 4.9797D-01
2.8487D-01 -1.2101D+00 3.9757D-01 4.9797D-01
1.1675D+00 4.6631D-01 4.2334D-01 1.9048D-01
1.1675D+00 -4.6631D-01 4.2334D-01 1.9048D-01
10
-1.0639D+00 1.6120D-01 1.5620D-01 3.4360D-01 -6.7480D-01 1.6598D+00
6.4650D-01 -7.8630D-01 -2.6100D-01 7.0190D-01
-8.4400D-01 -2.2439D+00 1.8800D+00 -1.0005D+00 7.4500D-02 -1.6156D+00
2.8220D-01 8.5600D-01 1.3497D+00 -1.5883D+00
1.5988D+00 1.1758D+00 1.2398D+00 1.1173D+00 2.1500D-01 4.3140D-01
1.8500D-01 7.9470D-01 6.6260D-01 8.6460D-01
-2.2960D-01 1.2442D+00 2.3242D+00 -5.0690D-01 -7.5160D-01 -5.4370D-01
-2.5990D-01 1.2830D+00 -1.1067D+00 -1.1150D-01
-3.6040D-01 4.0420D-01 6.1240D-01 -1.2164D+00 -9.4650D-01 -3.1460D-01
1.8310D-01 7.3710D-01 1.4278D+00 2.9220D-01
4.6150D-01 3.8740D-01 -4.2900D-02 -9.3600D-01 7.1160D-01 -8.2590D-01
-1.7640D+00 -9.4660D-01 1.8202D+00 -2.5480D-01
1.2934D+00 -9.7550D-01 6.7480D-01 -1.0481D+00 -1.8442D+00 -5.4600D-02
7.4050D-01 6.1000D-03 1.2430D+00 -1.8490D-01
-3.4710D-01 -9.5800D-01 1.6530D-01 9.1300D-02 -5.2010D-01 -1.1832D+00
8.5410D-01 -2.3200D-01 -1.6155D+00 5.5180D-01
1.0190D+00 -6.8240D-01 8.0850D-01 2.5950D-01 -3.7580D-01 -1.8825D+00
1.6473D+00 -6.5920D-01 8.0250D-01 -4.9000D-03
1.2670D+00 -4.2400D-02 8.9570D-01 -1.6770D-01 1.4620D-01 9.8800D-01
-2.3170D-01 -1.4483D+00 -5.8200D-02 1.9700D-02
-2.6992D+00 9.0387D-01 6.4005D-01 4.1615D-01
-2.6992D+00 -9.0387D-01 6.4005D-01 4.1615D-01
-2.4366D+00 0.0000D+00 6.9083D-01 2.5476D-01
-1.2882D+00 8.8930D-01 5.3435D-01 6.0878D-01
-1.2882D+00 -8.8930D-01 5.3435D-01 6.0878D-01
9.0275D-01 0.0000D+00 2.9802D-01 4.7530D-01
9.0442D-01 2.5661D+00 7.3193D-01 6.2016D-01
9.0442D-01 -2.5661D+00 7.3193D-01 6.2016D-01
1.6774D+00 0.0000D+00 3.0743D-01 4.1726D-01
3.0060D+00 0.0000D+00 8.5623D-01 4.3175D-01
4
-1.2298D+00 -2.3142D+00 -6.9800D-02 1.0523D+00
2.0390D-01 -1.2298D+00 8.0500D-02 9.7860D-01
0.0000D+00 0.0000D+00 2.5600D-01 -8.9100D-01
0.0000D+00 0.0000D+00 2.7480D-01 2.5600D-01
-1.2298D+00 6.8692D-01 4.7136D-01 7.1772D-01
-1.2298D+00 -6.8692D-01 4.7136D-01 7.1772D-01
2.5600D-01 4.9482D-01 8.0960D-01 5.1408D-01
2.5600D-01 -4.9482D-01 8.0960D-01 5.1408D-01
6
5.9930D-01 1.9372D+00 -1.6160D-01 -1.4602D+00 6.0180D-01 2.7120D+00
-2.2049D+00 5.9930D-01 -1.0679D+00 1.9405D+00 -1.4400D+00 -2.2110D-01
0.0000D+00 0.0000D+00 -2.4567D+00 -6.8650D-01 -1.9101D+00 6.4960D-01
0.0000D+00 0.0000D+00 0.0000D+00 7.3620D-01 3.9700D-01 -1.5190D-01
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 -1.0034D+00 1.1954D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 -1.3400D-01 -1.0034D+00
-2.4567D+00 0.0000D+00 4.7091D-01 8.5788D-01
-1.0034D+00 4.0023D-01 3.6889D-01 1.8909D-01
-1.0034D+00 -4.0023D-01 3.6889D-01 1.8909D-01
5.9930D-01 2.0667D+00 5.8849D-01 1.3299D+00
5.9930D-01 -2.0667D+00 5.8849D-01 1.3299D+00
7.3620D-01 0.0000D+00 6.0845D-01 9.6725D-01
4
1.0000D-04 1.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 -1.0000D-04 1.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 1.0000D-02 1.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 -5.0000D-03
-5.0000D-03 0.0000D+00 3.7485D-07 3.6932D-07
-1.0000D-04 0.0000D+00 9.8979D-09 9.8493D-09
1.0000D-04 0.0000D+00 1.0098D-08 1.0046D-08
1.0000D-02 0.0000D+00 1.4996D-06 1.4773D-06
3
2.0000D-06 1.0000D+00 -2.0000D+00
1.0000D-06 -2.0000D+00 4.0000D+00
0.0000D+00 1.0000D+00 -2.0000D+00
-4.0000D+00 0.0000D+00 7.3030D-01 4.0000D+00
0.0000D+00 0.0000D+00 7.2801D-01 1.3726D-06
2.2096D-06 0.0000D+00 8.2763D-01 2.2096D-06
6
2.4080D-01 6.5530D-01 9.1660D-01 5.0300D-02 2.8490D-01 2.4080D-01
6.9070D-01 9.7000D-01 1.4020D-01 5.7820D-01 6.7670D-01 6.9070D-01
1.0620D-01 3.8000D-02 7.0540D-01 2.4320D-01 8.6420D-01 1.0620D-01
2.6400D-01 9.8800D-02 1.7800D-02 9.4480D-01 1.9430D-01 2.6400D-01
7.0340D-01 2.5600D-01 2.6110D-01 5.8760D-01 5.8000D-02 7.0340D-01
4.0210D-01 5.5980D-01 1.3580D-01 7.2560D-01 6.9080D-01 4.0210D-01
-3.4008D-01 3.2133D-01 5.7839D-01 2.0310D-01
-3.4008D-01 -3.2133D-01 5.7839D-01 2.0310D-01
-1.6998D-07 0.0000D+00 4.9641D-01 2.1574D-01
7.2311D-01 5.9389D-02 7.0039D-01 4.1945D-02
7.2311D-01 -5.9389D-02 7.0039D-01 4.1945D-02
2.5551D+00 0.0000D+00 9.2518D-01 1.7390D+00
6
3.4800D+00 -2.9900D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
-4.9000D-01 2.4800D+00 -1.9900D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 -4.9000D-01 1.4800D+00 -9.9000D-01 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 -9.9000D-01 1.4800D+00 -4.9000D-01 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 -1.9900D+00 2.4800D+00 -4.9000D-01
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 -2.9900D+00 3.4800D+00
1.3034D-02 0.0000D+00 7.5301D-01 6.0533D-01
1.1294D+00 0.0000D+00 6.0479D-01 2.8613D-01
2.0644D+00 0.0000D+00 5.4665D-01 1.7376D-01
2.8388D+00 0.0000D+00 4.2771D-01 3.0915D-01
4.3726D+00 0.0000D+00 6.6370D-01 7.6443D-02
4.4618D+00 0.0000D+00 5.7388D-01 8.9227D-02
6
0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
1.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00
-1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
-1.7321D+00 0.0000D+00 8.6603D-01 7.2597D-01
-1.0000D+00 0.0000D+00 5.0000D-01 2.6417D-01
0.0000D+00 0.0000D+00 2.9582D-31 1.4600D-07
0.0000D+00 0.0000D+00 2.9582D-31 6.2446D-08
1.0000D+00 0.0000D+00 5.0000D-01 2.6417D-01
1.7321D+00 0.0000D+00 8.6603D-01 3.7896D-01
6
3.5345D-01 9.3023D-01 7.4679D-02 -1.0059D-02 4.6698D-02 -4.3480D-02
9.3545D-01 -3.5147D-01 -2.8216D-02 3.8008D-03 -1.7644D-02 1.6428D-02
0.0000D+00 -1.0555D-01 7.5211D-01 -1.0131D-01 4.7030D-01 -4.3789D-01
0.0000D+00 0.0000D+00 6.5419D-01 1.1779D-01 -5.4678D-01 5.0911D-01
0.0000D+00 0.0000D+00 0.0000D+00 -9.8780D-01 -1.1398D-01 1.0612D-01
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 6.8144D-01 7.3187D-01
-9.9980D-01 1.9645D-02 1.0000D+00 3.9290D-02
-9.9980D-01 -1.9645D-02 1.0000D+00 3.9290D-02
7.4539D-01 6.6663D-01 1.0000D+00 5.2120D-01
7.4539D-01 -6.6663D-01 1.0000D+00 5.2120D-01
9.9929D-01 3.7545D-02 1.0000D+00 7.5089D-02
9.9929D-01 -3.7545D-02 1.0000D+00 7.5089D-02
6
1.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
5.0000D-01 3.3330D-01 2.5000D-01 2.0000D-01 1.6670D-01 1.4290D-01
3.3330D-01 2.5000D-01 2.0000D-01 1.6670D-01 1.4290D-01 1.2500D-01
2.5000D-01 2.0000D-01 1.6670D-01 1.4290D-01 1.2500D-01 1.1110D-01
2.0000D-01 1.6670D-01 1.4290D-01 1.2500D-01 1.1110D-01 1.0000D-01
1.6670D-01 1.4290D-01 1.2500D-01 1.1110D-01 1.0000D-01 9.0900D-02
-2.2135D-01 0.0000D+00 4.0841D-01 1.6605D-01
-3.1956D-02 0.0000D+00 3.7927D-01 3.0531D-02
-8.5031D-04 0.0000D+00 6.2793D-01 7.8195D-04
-5.8584D-05 0.0000D+00 8.1156D-01 7.2478D-05
1.3895D-05 0.0000D+00 9.7087D-01 7.2478D-05
2.1324D+00 0.0000D+00 8.4325D-01 1.8048D+00
12
1.2000D+01 1.1000D+01 1.0000D+01 9.0000D+00 8.0000D+00 7.0000D+00
6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
1.1000D+01 1.1000D+01 1.0000D+01 9.0000D+00 8.0000D+00 7.0000D+00
6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
0.0000D+00 1.0000D+01 1.0000D+01 9.0000D+00 8.0000D+00 7.0000D+00
6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
0.0000D+00 0.0000D+00 9.0000D+00 9.0000D+00 8.0000D+00 7.0000D+00
6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 8.0000D+00 8.0000D+00 7.0000D+00
6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 7.0000D+00 7.0000D+00
6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 6.0000D+00
6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
5.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 4.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 3.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 2.0000D+00 2.0000D+00 1.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
-2.8234D-02 0.0000D+00 2.8690D-06 3.2094D-06
7.2587D-02 9.0746D-02 1.5885D-06 9.9934D-07
7.2587D-02 -9.0746D-02 1.5885D-06 9.9934D-07
1.8533D-01 0.0000D+00 6.5757D-07 7.8673D-07
2.8828D-01 0.0000D+00 1.8324D-06 2.0796D-06
6.4315D-01 0.0000D+00 6.8640D-05 6.1058D-05
1.5539D+00 0.0000D+00 4.6255D-03 6.4028D-03
3.5119D+00 0.0000D+00 1.4447D-01 1.9470D-01
6.9615D+00 0.0000D+00 5.8447D-01 1.2016D+00
1.2311D+01 0.0000D+00 3.1823D-01 1.4273D+00
2.0199D+01 0.0000D+00 2.0079D-01 2.4358D+00
3.2229D+01 0.0000D+00 3.0424D-01 5.6865D+00
6
0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
5.0000D+00 0.0000D+00 2.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 4.0000D+00 0.0000D+00 3.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 3.0000D+00 0.0000D+00 4.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 2.0000D+00 0.0000D+00 5.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
-5.0000D+00 0.0000D+00 8.2295D-01 1.2318D+00
-3.0000D+00 0.0000D+00 7.2281D-01 7.5970D-01
-1.0000D+00 0.0000D+00 6.2854D-01 6.9666D-01
1.0000D+00 0.0000D+00 6.2854D-01 6.9666D-01
3.0000D+00 0.0000D+00 7.2281D-01 7.5970D-01
5.0000D+00 0.0000D+00 8.2295D-01 1.2318D+00
6
1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
-1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
-1.0000D+00 -1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
-1.0000D+00 -1.0000D+00 -1.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00
-1.0000D+00 -1.0000D+00 -1.0000D+00 -1.0000D+00 1.0000D+00 1.0000D+00
-1.0000D+00 -1.0000D+00 -1.0000D+00 -1.0000D+00 -1.0000D+00 1.0000D+00
8.0298D-02 2.4187D+00 8.9968D-01 1.5236D+00
8.0298D-02 -2.4187D+00 8.9968D-01 1.5236D+00
1.4415D+00 6.2850D-01 9.6734D-01 4.2793D-01
1.4415D+00 -6.2850D-01 9.6734D-01 4.2793D-01
1.4782D+00 1.5638D-01 9.7605D-01 2.2005D-01
1.4782D+00 -1.5638D-01 9.7605D-01 2.2005D-01
6
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
0.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00
1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00
0.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
-3.5343D-02 7.4812D-01 3.9345D-01 1.8415D-01
-3.5343D-02 -7.4812D-01 3.9345D-01 1.8415D-01
5.8440D-07 0.0000D+00 2.8868D-01 1.7003D-01
6.4087D-01 7.2822D-01 4.5013D-01 2.9425D-01
6.4087D-01 -7.2822D-01 4.5013D-01 2.9425D-01
3.7889D+00 0.0000D+00 9.6305D-01 2.2469D+00
6
1.0000D+00 4.0112D+00 1.2750D+01 4.0213D+01 1.2656D+02 3.9788D+02
1.0000D+00 3.2616D+00 1.0629D+01 3.3342D+01 1.0479D+02 3.2936D+02
1.0000D+00 3.1500D+00 9.8006D+00 3.0630D+01 9.6164D+01 3.0215D+02
1.0000D+00 3.2755D+00 1.0420D+01 3.2957D+01 1.0374D+02 3.2616D+02
1.0000D+00 2.8214D+00 8.4558D+00 2.6296D+01 8.2443D+01 2.5893D+02
1.0000D+00 2.6406D+00 8.3565D+00 2.6558D+01 8.3558D+01 2.6268D+02
-5.3220D-01 0.0000D+00 5.3287D-01 3.8557D-01
-1.0118D-01 0.0000D+00 7.2342D-01 9.1303D-02
-9.8749D-03 0.0000D+00 7.3708D-01 1.1032D-02
2.9861D-03 0.0000D+00 4.4610D-01 1.2861D-02
1.8075D-01 0.0000D+00 4.2881D-01 1.7378D-01
3.9260D+02 0.0000D+00 4.8057D-01 3.9201D+02
8
0.0000D+00 4.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00
1.0000D+00 0.0000D+00 4.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00
0.0000D+00 1.0000D+00 0.0000D+00 4.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 4.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 4.0000D+00
0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
4.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
0.0000D+00 4.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
1.0000D+00 0.0000D+00
-3.7588D+00 0.0000D+00 1.2253D-01 1.2978D-01
-3.0642D+00 0.0000D+00 4.9811D-02 8.0162D-02
-2.0000D+00 0.0000D+00 3.6914D-02 8.2942D-02
-6.9459D-01 0.0000D+00 3.3328D-02 1.3738D-01
6.9459D-01 0.0000D+00 3.3328D-02 1.1171D-01
2.0000D+00 0.0000D+00 3.6914D-02 7.2156D-02
3.0642D+00 0.0000D+00 4.9811D-02 6.8352D-02
3.7588D+00 0.0000D+00 1.2253D-01 1.1527D-01
6
8.5000D+00 -1.0472D+01 2.8944D+00 -1.5279D+00 1.1056D+00 -5.0000D-01
2.6180D+00 -1.1708D+00 -2.0000D+00 8.9440D-01 -6.1800D-01 2.7640D-01
-7.2360D-01 2.0000D+00 -1.7080D-01 -1.6180D+00 8.9440D-01 -3.8200D-01
3.8200D-01 -8.9440D-01 1.6180D+00 1.7080D-01 -2.0000D+00 7.2360D-01
-2.7640D-01 6.1800D-01 -8.9440D-01 2.0000D+00 1.1708D+00 -2.6180D+00
5.0000D-01 -1.1056D+00 1.5279D+00 -2.8944D+00 1.0472D+01 -8.5000D+00
-5.8930D-01 0.0000D+00 1.7357D-04 2.8157D-04
-2.7627D-01 4.9852D-01 1.7486D-04 1.6704D-04
-2.7627D-01 -4.9852D-01 1.7486D-04 1.6704D-04
2.7509D-01 5.0059D-01 1.7635D-04 1.6828D-04
2.7509D-01 -5.0059D-01 1.7635D-04 1.6828D-04
5.9167D-01 0.0000D+00 1.7623D-04 3.0778D-04
4
4.0000D+00 -5.0000D+00 0.0000D+00 3.0000D+00
0.0000D+00 4.0000D+00 -3.0000D+00 -5.0000D+00
5.0000D+00 -3.0000D+00 4.0000D+00 0.0000D+00
3.0000D+00 0.0000D+00 5.0000D+00 4.0000D+00
1.0000D+00 5.0000D+00 1.0000D+00 4.3333D+00
1.0000D+00 -5.0000D+00 1.0000D+00 4.3333D+00
2.0000D+00 0.0000D+00 1.0000D+00 4.3333D+00
1.2000D+01 0.0000D+00 1.0000D+00 9.1250D+00
5
1.5000D+01 1.1000D+01 6.0000D+00 -9.0000D+00 -1.5000D+01
1.0000D+00 3.0000D+00 9.0000D+00 -3.0000D+00 -8.0000D+00
7.0000D+00 6.0000D+00 6.0000D+00 -3.0000D+00 -1.1000D+01
7.0000D+00 7.0000D+00 5.0000D+00 -3.0000D+00 -1.1000D+01
1.7000D+01 1.2000D+01 5.0000D+00 -1.0000D+01 -1.6000D+01
-9.9999D-01 0.0000D+00 2.1768D-01 5.2263D-01
1.4980D+00 3.5752D+00 3.9966D-04 6.0947D-03
1.4980D+00 -3.5752D+00 3.9966D-04 6.0947D-03
1.5020D+00 3.5662D+00 3.9976D-04 6.0960D-03
1.5020D+00 -3.5662D+00 3.9976D-04 6.0960D-03
6
-9.0000D+00 2.1000D+01 -1.5000D+01 4.0000D+00 2.0000D+00 0.0000D+00
-1.0000D+01 2.1000D+01 -1.4000D+01 4.0000D+00 2.0000D+00 0.0000D+00
-8.0000D+00 1.6000D+01 -1.1000D+01 4.0000D+00 2.0000D+00 0.0000D+00
-6.0000D+00 1.2000D+01 -9.0000D+00 3.0000D+00 3.0000D+00 0.0000D+00
-4.0000D+00 8.0000D+00 -6.0000D+00 0.0000D+00 5.0000D+00 0.0000D+00
-2.0000D+00 4.0000D+00 -3.0000D+00 0.0000D+00 1.0000D+00 3.0000D+00
1.0000D+00 6.2559D-04 6.4875D-05 5.0367D-04
1.0000D+00 -6.2559D-04 6.4875D-05 5.0367D-04
2.0000D+00 1.0001D+00 5.4076D-02 2.3507D-01
2.0000D+00 -1.0001D+00 5.4076D-02 2.3507D-01
3.0000D+00 0.0000D+00 8.6149D-01 5.4838D-07
3.0000D+00 0.0000D+00 1.2425D-01 1.2770D-06
10
1.0000D+00 1.0000D+00 1.0000D+00 -2.0000D+00 1.0000D+00 -1.0000D+00
2.0000D+00 -2.0000D+00 4.0000D+00 -3.0000D+00
-1.0000D+00 2.0000D+00 3.0000D+00 -4.0000D+00 2.0000D+00 -2.0000D+00
4.0000D+00 -4.0000D+00 8.0000D+00 -6.0000D+00
-1.0000D+00 0.0000D+00 5.0000D+00 -5.0000D+00 3.0000D+00 -3.0000D+00
6.0000D+00 -6.0000D+00 1.2000D+01 -9.0000D+00
-1.0000D+00 0.0000D+00 3.0000D+00 -4.0000D+00 4.0000D+00 -4.0000D+00
8.0000D+00 -8.0000D+00 1.6000D+01 -1.2000D+01
-1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 5.0000D+00 -4.0000D+00
1.0000D+01 -1.0000D+01 2.0000D+01 -1.5000D+01
-1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 2.0000D+00 -2.0000D+00
1.2000D+01 -1.2000D+01 2.4000D+01 -1.8000D+01
-1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 2.0000D+00 -5.0000D+00
1.5000D+01 -1.3000D+01 2.8000D+01 -2.1000D+01
-1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 2.0000D+00 -5.0000D+00
1.2000D+01 -1.1000D+01 3.2000D+01 -2.4000D+01
-1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 2.0000D+00 -5.0000D+00
1.2000D+01 -1.4000D+01 3.7000D+01 -2.6000D+01
-1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 2.0000D+00 -5.0000D+00
1.2000D+01 -1.4000D+01 3.6000D+01 -2.5000D+01
1.0000D+00 0.0000D+00 3.6037D-02 7.9613D-02
1.9867D+00 0.0000D+00 7.4283D-05 7.4025D-06
2.0000D+00 2.5052D-03 1.4346D-04 6.7839D-07
2.0000D+00 -2.5052D-03 1.4346D-04 6.7839D-07
2.0067D+00 1.1763D-02 6.7873D-05 5.7496D-06
2.0067D+00 -1.1763D-02 6.7873D-05 5.7496D-06
2.9970D+00 0.0000D+00 9.2779D-05 2.6519D-06
3.0000D+00 8.7028D-04 2.7358D-04 1.9407D-07
3.0000D+00 -8.7028D-04 2.7358D-04 1.9407D-07
3.0030D+00 0.0000D+00 9.2696D-05 2.6477D-06
0
1 1
1
0.00000D+00
1.00000D+00 0.00000D+00
1 1
1
1.00000D+00
1.00000D+00 1.00000D+00
6 3
4 5 6
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
1.00000D+00 4.43734D-31
6 3
4 5 6
1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
1.00000D+00 1.19209D-07
6 3
4 5 6
1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
4.01235D-36 3.20988D-36
6 3
4 5 6
1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00
4.01235D-36 3.20988D-36
6 3
4 5 6
1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 2.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 3.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 4.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 5.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 6.00000D+00
1.00000D+00 1.00000D+00
2 1
1
1.00000D+00 2.00000D+00
0.00000D+00 3.00000D+00
7.07107D-01 2.00000D+00
4 2
1 2
8.52400D-01 5.61100D-01 7.04300D-01 9.54000D-01
2.79800D-01 7.21600D-01 9.61300D-01 3.58200D-01
7.08100D-01 4.09400D-01 2.25000D-01 9.51800D-01
5.54300D-01 5.22000D-01 6.86000D-01 3.07000D-02
7.22196D-01 4.63943D-01
7 6
1 2 3 4 5 6
7.81800D-01 5.65700D-01 7.62100D-01 7.43600D-01 2.55300D-01 4.10000D-01
1.34000D-02
6.45800D-01 2.66600D-01 5.51000D-01 8.31800D-01 9.27100D-01 6.20900D-01
7.83900D-01
1.31600D-01 4.91400D-01 1.77100D-01 1.96400D-01 1.08500D-01 9.27000D-01
2.24700D-01
6.41000D-01 4.68900D-01 9.65900D-01 8.88400D-01 3.76900D-01 9.67300D-01
6.18300D-01
8.38200D-01 8.74300D-01 4.50700D-01 9.44200D-01 7.75500D-01 9.67600D-01
7.83100D-01
3.25900D-01 7.38900D-01 8.30200D-01 4.52100D-01 3.01500D-01 2.13300D-01
8.43400D-01
5.24400D-01 5.01600D-01 7.52900D-01 3.83800D-01 8.47900D-01 9.12800D-01
5.77000D-01
9.43220D-01 3.20530D+00
4 2
2 3
-9.85900D-01 1.47840D+00 -1.33600D-01 -2.95970D+00
-4.33700D-01 -6.54000D-01 -7.15500D-01 1.23760D+00
-7.36300D-01 -1.97680D+00 -1.95100D-01 3.43200D-01
6.41400D-01 -1.40880D+00 6.39400D-01 8.58000D-02
5.22869D-01 5.45530D-01
7 5
1 2 3 4 5
2.72840D+00 2.15200D-01 -1.05200D+00 -2.44600D-01 -6.53000D-02 3.90500D-01
1.40980D+00
9.75300D-01 6.51500D-01 -4.76200D-01 5.42100D-01 6.20900D-01 4.75900D-01
-1.44930D+00
-9.05200D-01 1.79000D-01 -7.08600D-01 4.62100D-01 1.05800D+00 2.24260D+00
1.58260D+00
-7.17900D-01 -2.53400D-01 -4.73900D-01 -1.08100D+00 4.13800D-01 -9.50000D-02
1.45300D-01
-1.37990D+00 -1.06490D+00 1.25580D+00 7.80100D-01 -6.40500D-01 -8.61000D-02
8.30000D-02
2.84900D-01 -1.29900D-01 4.80000D-02 -2.58600D-01 4.18900D-01 1.37680D+00
8.20800D-01
-5.44200D-01 9.74900D-01 9.55800D-01 1.23700D-01 1.09020D+00 -1.40600D-01
1.90960D+00
6.04729D-01 9.00391D-01
6 4
3 4 5 6
0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00
1.00000D-06 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 5.00000D-01
4.89525D-05 4.56492D-05
8 4
1 2 3 4
1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 1.00000D+01 0.00000D+00
1.00000D+01 0.00000D+00
0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 1.00000D+01
1.00000D+01 0.00000D+00
0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 1.00000D+01
1.00000D+01 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 1.00000D+01
0.00000D+00 1.00000D+01
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 5.00000D-01 1.00000D+00
0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 5.00000D-01
1.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
5.00000D-01 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 5.00000D-01
9.56158D-05 4.14317D-05
9 3
1 2 3
1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
7.50000D-01 1.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 7.50000D-01 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 7.50000D-01
1.00000D+00 5.55801D-07
10 4
1 2 3 4
1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
8.75000D-01 1.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 8.75000D-01 1.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 8.75000D-01 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 8.75000D-01
1.00000D+00 1.16972D-10
12 6
1 2 3 4 5 6
1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
1.00000D+01 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 1.00000D+01 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 1.00000D+01 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+01 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+01 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+01
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
9.37500D-01 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 9.37500D-01 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 9.37500D-01 1.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 9.37500D-01 1.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 9.37500D-01 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 9.37500D-01
1.85655D-10 2.20147D-16
12 7
6 7 8 9 10 11 12
1.20000D+01 1.10000D+01 1.00000D+01 9.00000D+00 8.00000D+00 7.00000D+00
6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
1.10000D+01 1.10000D+01 1.00000D+01 9.00000D+00 8.00000D+00 7.00000D+00
6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
0.00000D+00 1.00000D+01 1.00000D+01 9.00000D+00 8.00000D+00 7.00000D+00
6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
0.00000D+00 0.00000D+00 9.00000D+00 9.00000D+00 8.00000D+00 7.00000D+00
6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 8.00000D+00 8.00000D+00 7.00000D+00
6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 7.00000D+00 7.00000D+00
6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 6.00000D+00
6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
5.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 4.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 3.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 2.00000D+00 2.00000D+00 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00
6.92558D-05 5.52606D-05
3 1
1
2.00000D-06 1.00000D+00 -2.00000D+00
1.00000D-06 -2.00000D+00 4.00000D+00
0.00000D+00 1.00000D+00 -2.00000D+00
7.30297D-01 4.00000D+00
5 1
3
2.00000D-03 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 1.00000D-03 1.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 -1.00000D-03 1.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 -2.00000D-03 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
3.99999D-12 3.99201D-12
6 4
1 2 3 5
1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
1.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00
1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00
1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00
2.93294D-01 1.63448D-01
6 2
3 4
0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
1.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 1.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 1.00000D+00
-1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00
3.97360D-01 3.58295D-01
6 3
3 4 5
1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00
5.00000D-01 3.33300D-01 2.50000D-01 2.00000D-01 1.66700D-01 1.42900D-01
3.33300D-01 2.50000D-01 2.00000D-01 1.66700D-01 1.42900D-01 1.25000D-01
2.50000D-01 2.00000D-01 1.66700D-01 1.42900D-01 1.25000D-01 1.11100D-01
2.00000D-01 1.66700D-01 1.42900D-01 1.25000D-01 1.11100D-01 1.00000D-01
1.66700D-01 1.42900D-01 1.25000D-01 1.11100D-01 1.00000D-01 9.09000D-02
7.28934D-01 1.24624D-02
5 1
1
1.50000D+01 1.10000D+01 6.00000D+00 -9.00000D+00 -1.50000D+01
1.00000D+00 3.00000D+00 9.00000D+00 -3.00000D+00 -8.00000D+00
7.00000D+00 6.00000D+00 6.00000D+00 -3.00000D+00 -1.10000D+01
7.00000D+00 7.00000D+00 5.00000D+00 -3.00000D+00 -1.10000D+01
1.70000D+01 1.20000D+01 5.00000D+00 -1.00000D+01 -1.60000D+01
2.17680D-01 5.22626D-01
6 2
1 2
-9.00000D+00 2.10000D+01 -1.50000D+01 4.00000D+00 2.00000D+00 0.00000D+00
-1.00000D+01 2.10000D+01 -1.40000D+01 4.00000D+00 2.00000D+00 0.00000D+00
-8.00000D+00 1.60000D+01 -1.10000D+01 4.00000D+00 2.00000D+00 0.00000D+00
-6.00000D+00 1.20000D+01 -9.00000D+00 3.00000D+00 3.00000D+00 0.00000D+00
-4.00000D+00 8.00000D+00 -6.00000D+00 0.00000D+00 5.00000D+00 0.00000D+00
-2.00000D+00 4.00000D+00 -3.00000D+00 0.00000D+00 1.00000D+00 3.00000D+00
6.78904D-02 4.22005D-02
10 1
1
1.00000D+00 1.00000D+00 1.00000D+00 -2.00000D+00 1.00000D+00 -1.00000D+00
2.00000D+00 -2.00000D+00 4.00000D+00 -3.00000D+00
-1.00000D+00 2.00000D+00 3.00000D+00 -4.00000D+00 2.00000D+00 -2.00000D+00
4.00000D+00 -4.00000D+00 8.00000D+00 -6.00000D+00
-1.00000D+00 0.00000D+00 5.00000D+00 -5.00000D+00 3.00000D+00 -3.00000D+00
6.00000D+00 -6.00000D+00 1.20000D+01 -9.00000D+00
-1.00000D+00 0.00000D+00 3.00000D+00 -4.00000D+00 4.00000D+00 -4.00000D+00
8.00000D+00 -8.00000D+00 1.60000D+01 -1.20000D+01
-1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 5.00000D+00 -4.00000D+00
1.00000D+01 -1.00000D+01 2.00000D+01 -1.50000D+01
-1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 2.00000D+00 -2.00000D+00
1.20000D+01 -1.20000D+01 2.40000D+01 -1.80000D+01
-1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 2.00000D+00 -5.00000D+00
1.50000D+01 -1.30000D+01 2.80000D+01 -2.10000D+01
-1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 2.00000D+00 -5.00000D+00
1.20000D+01 -1.10000D+01 3.20000D+01 -2.40000D+01
-1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 2.00000D+00 -5.00000D+00
1.20000D+01 -1.40000D+01 3.70000D+01 -2.60000D+01
-1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 2.00000D+00 -5.00000D+00
1.20000D+01 -1.40000D+01 3.60000D+01 -2.50000D+01
3.60372D-02 7.96134D-02
0 0
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/eig/svd.in 0000644 0001750 0001750 00000001740 10616163237 023113 0 ustar osallou osallou SVD: Data file for testing Singular Value Decomposition routines
19 Number of values of M
0 0 0 1 1 1 2 2 3 3 3 10 10 16 16 30 30 40 40 Values of M
0 1 3 0 1 2 0 1 0 1 3 10 16 10 16 30 40 30 40 Values of N
5 Number of parameter values
1 3 3 3 20 Values of NB (blocksize)
2 2 2 2 2 Values of NBMIN (minimum blocksize)
1 0 5 9 1 Values of NX (crossover point)
2 0 2 2 2 Values of NRHS
35.0 Threshold value
T Put T to test the LAPACK routines
T Put T to test the driver routines
T Put T to test the error exits
1 Code to interpret the seed
SVD 16
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/eig/dbak.in 0000644 0001750 0001750 00000013547 10616163234 023225 0 ustar osallou osallou DBK: Tests DGEBAK
5 1 1
0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01
0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
5 1 1
0.1000D+01 0.2000D+01 0.3000D+01 0.2000D+01 0.1000D+01
0.1000D+01 0.1000D+01 0.1000D+01 -0.6667D+00 -0.4167D-01
0.0000D+00 -0.2500D+00 -0.6667D+00 0.1000D+01 0.1667D+00
0.0000D+00 0.0000D+00 0.2222D+00 -0.1000D+01 -0.5000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.5000D+00 0.1000D+01
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 -0.1000D+01
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 -0.1000D+01
0.0000D+00 0.0000D+00 0.0000D+00 0.5000D+00 0.1000D+01
0.0000D+00 0.0000D+00 0.2222D+00 -0.1000D+01 -0.5000D+00
0.0000D+00 -0.2500D+00 -0.6667D+00 0.1000D+01 0.1667D+00
0.1000D+01 0.1000D+01 0.1000D+01 -0.6667D+00 -0.4167D-01
5 1 1
0.1000D+01 0.2000D+01 0.3000D+01 0.2000D+01 0.1000D+01
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.0000D+00 -0.6000D-17 -0.6000D-17 -0.6000D-17 -0.6000D-17
0.0000D+00 0.0000D+00 0.3600D-34 0.3600D-34 0.3600D-34
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.3600D-34 0.3600D-34 0.3600D-34
0.0000D+00 -0.6000D-17 -0.6000D-17 -0.6000D-17 -0.6000D-17
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
6 4 6
0.4000D+01 0.3000D+01 0.5000D+01 0.1000D+03 0.1000D+00 0.1000D+01
0.1000D+01 0.1336D-05 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.0000D+00 0.1000D+01 0.0000D+00 -0.3001D-10 -0.3252D-04 0.1305D-01
0.0000D+00 0.0000D+00 -0.8330D-02 0.8929D-09 -0.6712D-04 0.6687D-04
0.0000D+00 0.0000D+00 0.0000D+00 -0.4455D-05 -0.3355D-02 0.3345D-02
0.0000D+00 0.0000D+00 0.0000D+00 0.4455D-06 -0.3356D-01 0.3344D-01
0.0000D+00 0.0000D+00 0.0000D+00 0.4411D-09 0.1011D+00 0.1008D+00
0.0000D+00 0.0000D+00 0.0000D+00 -0.4455D-03 -0.3355D+00 0.3345D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.4455D-07 -0.3356D-02 0.3344D-02
0.0000D+00 0.1000D+01 0.0000D+00 -0.3001D-10 -0.3252D-04 0.1305D-01
0.1000D+01 0.1336D-05 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.0000D+00 0.0000D+00 -0.8330D-02 0.8929D-09 -0.6712D-04 0.6687D-04
0.0000D+00 0.0000D+00 0.0000D+00 0.4411D-09 0.1011D+00 0.1008D+00
5 1 5
0.1000D+03 0.1000D+00 0.1000D-01 0.1000D+01 0.1000D+02
0.1366D-03 -0.6829D-04 0.1252D-03 0.1000D+01 0.1950D-14
0.1000D+01 0.1000D+01 -0.2776D-16 0.3601D-05 -0.6073D-17
0.2736D+00 -0.1363D+00 0.2503D+00 -0.3322D-05 -0.2000D-02
0.6909D-02 -0.3443D-02 0.6196D-02 0.1666D-01 0.1000D+01
0.3899D+00 -0.2033D+00 -0.3420D+00 -0.1000D-02 0.6000D-14
0.1366D-01 -0.6829D-02 0.1252D-01 0.1000D+03 0.1950D-12
0.1000D+00 0.1000D+00 -0.2776D-17 0.3601D-06 -0.6073D-18
0.2736D-02 -0.1363D-02 0.2503D-02 -0.3322D-07 -0.2000D-04
0.6909D-02 -0.3443D-02 0.6196D-02 0.1666D-01 0.1000D+01
0.3899D+01 -0.2033D+01 -0.3420D+01 -0.1000D-01 0.6000D-13
6 2 5
0.3000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.4000D+01
0.1000D+01 0.1000D+01 0.2776D-15 -0.2405D-16 0.0000D+00 0.1000D+01
0.0000D+00 0.7500D+00 0.1000D+01 0.8520D-01 0.0000D+00 -0.1520D-16
0.0000D+00 0.7500D+00 -0.8093D+00 0.1000D+01 0.0000D+00 -0.1520D-16
0.0000D+00 0.7500D+00 -0.9533D-01 -0.5426D+00 0.1000D+01 -0.1520D-16
0.0000D+00 0.7500D+00 -0.9533D-01 -0.5426D+00 -0.1000D+01 -0.1520D-16
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.4559D-16
0.0000D+00 0.7500D+00 -0.8093D+00 0.1000D+01 0.0000D+00 -0.1520D-16
0.0000D+00 0.7500D+00 0.1000D+01 0.8520D-01 0.0000D+00 -0.1520D-16
0.1000D+01 0.1000D+01 0.2776D-15 -0.2405D-16 0.0000D+00 0.1000D+01
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.4559D-16
0.0000D+00 0.7500D+00 -0.9533D-01 -0.5426D+00 -0.1000D+01 -0.1520D-16
0.0000D+00 0.7500D+00 -0.9533D-01 -0.5426D+00 0.1000D+01 -0.1520D-16
7 2 5
0.3000D+01 0.1000D-02 0.1000D-01 0.1000D+02 0.1000D+00 0.1000D+01
0.6000D+01
0.1000D+01 -0.1105D-01 0.3794D-01 -0.9378D-01 -0.3481D-01 0.4465D+00
-0.3602D-01
0.0000D+00 -0.4556D+00 -0.4545D+00 0.1000D+01 0.4639D+00 -0.6512D+00
0.4781D+00
0.0000D+00 -0.2734D+00 -0.7946D+00 0.6303D+00 0.1000D+01 -0.6279D+00
0.1000D+01
0.0000D+00 0.1000D+01 -0.6939D-17 0.4259D-01 -0.6495D+00 -0.5581D+00
-0.6452D+00
0.0000D+00 -0.3904D+00 -0.4029D+00 -0.1685D+00 -0.9429D+00 0.1000D+01
-0.9371D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 -0.2558D+00
0.3308D-03
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
-0.1985D-02
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 -0.2558D+00
0.3308D-03
0.0000D+00 -0.4556D-03 -0.4545D-03 0.1000D-02 0.4639D-03 -0.6512D-03
0.4781D-03
0.1000D+01 -0.1105D-01 0.3794D-01 -0.9378D-01 -0.3481D-01 0.4465D+00
-0.3602D-01
0.0000D+00 0.1000D+02 -0.6939D-16 0.4259D+00 -0.6495D+01 -0.5581D+01
-0.6452D+01
0.0000D+00 -0.3904D-01 -0.4029D-01 -0.1685D-01 -0.9429D-01 0.1000D+00
-0.9371D-01
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
-0.1985D-02
0.0000D+00 -0.2734D-02 -0.7946D-02 0.6303D-02 0.1000D-01 -0.6279D-02
0.1000D-01
0 0 0
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/eig/eigtest.f 0000644 0001750 0001750 00005217140 10616163234 023607 0 ustar osallou osallou SUBROUTINE ALAHDG( IOUNIT, PATH )
*
* -- LAPACK test routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER IOUNIT
* ..
*
* Purpose
* =======
*
* ALAHDG prints header information for the different test paths.
*
* Arguments
* =========
*
* IOUNIT (input) INTEGER
* The unit number to which the header information should be
* printed.
*
* PATH (input) CHARACTER*3
* The name of the path for which the header information is to
* be printed. Current paths are
* GQR: GQR (general matrices)
* GRQ: GRQ (general matrices)
* LSE: LSE Problem
* GLM: GLM Problem
* GSV: Generalized Singular Value Decomposition
*
* =====================================================================
*
* .. Local Scalars ..
CHARACTER*3 C2
INTEGER ITYPE
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. Executable Statements ..
*
IF( IOUNIT.LE.0 )
$ RETURN
C2 = PATH( 1: 3 )
*
* First line describing matrices in this path
*
IF( LSAMEN( 3, C2, 'GQR' ) ) THEN
ITYPE = 1
WRITE( IOUNIT, FMT = 9991 )PATH
ELSE IF( LSAMEN( 3, C2, 'GRQ' ) ) THEN
ITYPE = 2
WRITE( IOUNIT, FMT = 9992 )PATH
ELSE IF( LSAMEN( 3, C2, 'LSE' ) ) THEN
ITYPE = 3
WRITE( IOUNIT, FMT = 9993 )PATH
ELSE IF( LSAMEN( 3, C2, 'GLM' ) ) THEN
ITYPE = 4
WRITE( IOUNIT, FMT = 9994 )PATH
ELSE IF( LSAMEN( 3, C2, 'GSV' ) ) THEN
ITYPE = 5
WRITE( IOUNIT, FMT = 9995 )PATH
END IF
*
* Matrix types
*
WRITE( IOUNIT, FMT = 9999 )'Matrix types: '
*
IF( ITYPE.EQ.1 )THEN
WRITE( IOUNIT, FMT = 9950 )1
WRITE( IOUNIT, FMT = 9952 )2
WRITE( IOUNIT, FMT = 9954 )3
WRITE( IOUNIT, FMT = 9955 )4
WRITE( IOUNIT, FMT = 9956 )5
WRITE( IOUNIT, FMT = 9957 )6
WRITE( IOUNIT, FMT = 9961 )7
WRITE( IOUNIT, FMT = 9962 )8
ELSE IF( ITYPE.EQ.2 )THEN
WRITE( IOUNIT, FMT = 9951 )1
WRITE( IOUNIT, FMT = 9953 )2
WRITE( IOUNIT, FMT = 9954 )3
WRITE( IOUNIT, FMT = 9955 )4
WRITE( IOUNIT, FMT = 9956 )5
WRITE( IOUNIT, FMT = 9957 )6
WRITE( IOUNIT, FMT = 9961 )7
WRITE( IOUNIT, FMT = 9962 )8
ELSE IF( ITYPE.EQ.3 )THEN
WRITE( IOUNIT, FMT = 9950 )1
WRITE( IOUNIT, FMT = 9952 )2
WRITE( IOUNIT, FMT = 9954 )3
WRITE( IOUNIT, FMT = 9955 )4
WRITE( IOUNIT, FMT = 9955 )5
WRITE( IOUNIT, FMT = 9955 )6
WRITE( IOUNIT, FMT = 9955 )7
WRITE( IOUNIT, FMT = 9955 )8
ELSE IF( ITYPE.EQ.4 )THEN
WRITE( IOUNIT, FMT = 9951 )1
WRITE( IOUNIT, FMT = 9953 )2
WRITE( IOUNIT, FMT = 9954 )3
WRITE( IOUNIT, FMT = 9955 )4
WRITE( IOUNIT, FMT = 9955 )5
WRITE( IOUNIT, FMT = 9955 )6
WRITE( IOUNIT, FMT = 9955 )7
WRITE( IOUNIT, FMT = 9955 )8
ELSE IF( ITYPE.EQ.5 )THEN
WRITE( IOUNIT, FMT = 9950 )1
WRITE( IOUNIT, FMT = 9952 )2
WRITE( IOUNIT, FMT = 9954 )3
WRITE( IOUNIT, FMT = 9955 )4
WRITE( IOUNIT, FMT = 9956 )5
WRITE( IOUNIT, FMT = 9957 )6
WRITE( IOUNIT, FMT = 9959 )7
WRITE( IOUNIT, FMT = 9960 )8
END IF
*
* Tests performed
*
WRITE( IOUNIT, FMT = 9999 )'Test ratios: '
*
IF( ITYPE.EQ.1 ) THEN
*
* GQR decomposition of rectangular matrices
*
WRITE( IOUNIT, FMT = 9930 )1
WRITE( IOUNIT, FMT = 9931 )2
WRITE( IOUNIT, FMT = 9932 )3
WRITE( IOUNIT, FMT = 9933 )4
ELSE IF( ITYPE.EQ.2 ) THEN
*
* GRQ decomposition of rectangular matrices
*
WRITE( IOUNIT, FMT = 9934 )1
WRITE( IOUNIT, FMT = 9935 )2
WRITE( IOUNIT, FMT = 9932 )3
WRITE( IOUNIT, FMT = 9933 )4
ELSE IF( ITYPE.EQ.3 ) THEN
*
* LSE Problem
*
WRITE( IOUNIT, FMT = 9937 )1
WRITE( IOUNIT, FMT = 9938 )2
ELSE IF( ITYPE.EQ.4 ) THEN
*
* GLM Problem
*
WRITE( IOUNIT, FMT = 9939 )1
ELSE IF( ITYPE.EQ.5 ) THEN
*
* GSVD
*
WRITE( IOUNIT, FMT = 9940 )1
WRITE( IOUNIT, FMT = 9941 )2
WRITE( IOUNIT, FMT = 9942 )3
WRITE( IOUNIT, FMT = 9943 )4
WRITE( IOUNIT, FMT = 9944 )5
END IF
*
9999 FORMAT( 1X, A )
9991 FORMAT( / 1X, A3, ': GQR factorization of general matrices' )
9992 FORMAT( / 1X, A3, ': GRQ factorization of general matrices' )
9993 FORMAT( / 1X, A3, ': LSE Problem' )
9994 FORMAT( / 1X, A3, ': GLM Problem' )
9995 FORMAT( / 1X, A3, ': Generalized Singular Value Decomposition' )
*
9950 FORMAT( 3X, I2, ': A-diagonal matrix B-upper triangular' )
9951 FORMAT( 3X, I2, ': A-diagonal matrix B-lower triangular' )
9952 FORMAT( 3X, I2, ': A-upper triangular B-upper triangular' )
9953 FORMAT( 3X, I2, ': A-lower triangular B-diagonal triangular' )
9954 FORMAT( 3X, I2, ': A-lower triangular B-upper triangular' )
*
9955 FORMAT( 3X, I2, ': Random matrices cond(A)=100, cond(B)=10,' )
*
9956 FORMAT( 3X, I2, ': Random matrices cond(A)= sqrt( 0.1/EPS ) ',
$ 'cond(B)= sqrt( 0.1/EPS )' )
9957 FORMAT( 3X, I2, ': Random matrices cond(A)= 0.1/EPS ',
$ 'cond(B)= 0.1/EPS' )
9959 FORMAT( 3X, I2, ': Random matrices cond(A)= sqrt( 0.1/EPS ) ',
$ 'cond(B)= 0.1/EPS ' )
9960 FORMAT( 3X, I2, ': Random matrices cond(A)= 0.1/EPS ',
$ 'cond(B)= sqrt( 0.1/EPS )' )
*
9961 FORMAT( 3X, I2, ': Matrix scaled near underflow limit' )
9962 FORMAT( 3X, I2, ': Matrix scaled near overflow limit' )
*
*
* GQR test ratio
*
9930 FORMAT( 3X, I2, ': norm( R - Q'' * A ) / ( min( N, M )*norm( A )',
$ '* EPS )' )
9931 FORMAT( 3X, I2, ': norm( T * Z - Q'' * B ) / ( min(P,N)*norm(B)',
$ '* EPS )' )
9932 FORMAT( 3X, I2, ': norm( I - Q''*Q ) / ( N * EPS )' )
9933 FORMAT( 3X, I2, ': norm( I - Z''*Z ) / ( P * EPS )' )
*
* GRQ test ratio
*
9934 FORMAT( 3X, I2, ': norm( R - A * Q'' ) / ( min( N,M )*norm(A) * ',
$ 'EPS )' )
9935 FORMAT( 3X, I2, ': norm( T * Q - Z'' * B ) / ( min( P,N ) * nor',
$ 'm(B)*EPS )' )
*
* LSE test ratio
*
9937 FORMAT( 3X, I2, ': norm( A*x - c ) / ( norm(A)*norm(x) * EPS )' )
9938 FORMAT( 3X, I2, ': norm( B*x - d ) / ( norm(B)*norm(x) * EPS )' )
*
* GLM test ratio
*
9939 FORMAT( 3X, I2, ': norm( d - A*x - B*y ) / ( (norm(A)+norm(B) )*',
$ '(norm(x)+norm(y))*EPS )' )
*
* GSVD test ratio
*
9940 FORMAT( 3X, I2, ': norm( U'' * A * Q - D1 * R ) / ( min( M, N )*',
$ 'norm( A ) * EPS )' )
9941 FORMAT( 3X, I2, ': norm( V'' * B * Q - D2 * R ) / ( min( P, N )*',
$ 'norm( B ) * EPS )' )
9942 FORMAT( 3X, I2, ': norm( I - U''*U ) / ( M * EPS )' )
9943 FORMAT( 3X, I2, ': norm( I - V''*V ) / ( P * EPS )' )
9944 FORMAT( 3X, I2, ': norm( I - Q''*Q ) / ( N * EPS )' )
RETURN
*
* End of ALAHDG
*
END
SUBROUTINE ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NIN, NMATS, NOUT, NTYPES
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
* ..
*
* Purpose
* =======
*
* ALAREQ handles input for the LAPACK test program. It is called
* to evaluate the input line which requested NMATS matrix types for
* PATH. The flow of control is as follows:
*
* If NMATS = NTYPES then
* DOTYPE(1:NTYPES) = .TRUE.
* else
* Read the next input line for NMATS matrix types
* Set DOTYPE(I) = .TRUE. for each valid type I
* endif
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* An LAPACK path name for testing.
*
* NMATS (input) INTEGER
* The number of matrix types to be used in testing this path.
*
* DOTYPE (output) LOGICAL array, dimension (NTYPES)
* The vector of flags indicating if each type will be tested.
*
* NTYPES (input) INTEGER
* The maximum number of matrix types for this path.
*
* NIN (input) INTEGER
* The unit number for input. NIN >= 1.
*
* NOUT (input) INTEGER
* The unit number for output. NOUT >= 1.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL FIRSTT
CHARACTER C1
CHARACTER*10 INTSTR
CHARACTER*80 LINE
INTEGER I, I1, IC, J, K, LENP, NT
* ..
* .. Local Arrays ..
INTEGER NREQ( 100 )
* ..
* .. Intrinsic Functions ..
INTRINSIC LEN
* ..
* .. Data statements ..
DATA INTSTR / '0123456789' /
* ..
* .. Executable Statements ..
*
IF( NMATS.GE.NTYPES ) THEN
*
* Test everything if NMATS >= NTYPES.
*
DO 10 I = 1, NTYPES
DOTYPE( I ) = .TRUE.
10 CONTINUE
ELSE
DO 20 I = 1, NTYPES
DOTYPE( I ) = .FALSE.
20 CONTINUE
FIRSTT = .TRUE.
*
* Read a line of matrix types if 0 < NMATS < NTYPES.
*
IF( NMATS.GT.0 ) THEN
READ( NIN, FMT = '(A80)', END = 90 )LINE
LENP = LEN( LINE )
I = 0
DO 60 J = 1, NMATS
NREQ( J ) = 0
I1 = 0
30 CONTINUE
I = I + 1
IF( I.GT.LENP ) THEN
IF( J.EQ.NMATS .AND. I1.GT.0 ) THEN
GO TO 60
ELSE
WRITE( NOUT, FMT = 9995 )LINE
WRITE( NOUT, FMT = 9994 )NMATS
GO TO 80
END IF
END IF
IF( LINE( I: I ).NE.' ' .AND. LINE( I: I ).NE.',' ) THEN
I1 = I
C1 = LINE( I1: I1 )
*
* Check that a valid integer was read
*
DO 40 K = 1, 10
IF( C1.EQ.INTSTR( K: K ) ) THEN
IC = K - 1
GO TO 50
END IF
40 CONTINUE
WRITE( NOUT, FMT = 9996 )I, LINE
WRITE( NOUT, FMT = 9994 )NMATS
GO TO 80
50 CONTINUE
NREQ( J ) = 10*NREQ( J ) + IC
GO TO 30
ELSE IF( I1.GT.0 ) THEN
GO TO 60
ELSE
GO TO 30
END IF
60 CONTINUE
END IF
DO 70 I = 1, NMATS
NT = NREQ( I )
IF( NT.GT.0 .AND. NT.LE.NTYPES ) THEN
IF( DOTYPE( NT ) ) THEN
IF( FIRSTT )
$ WRITE( NOUT, FMT = * )
FIRSTT = .FALSE.
WRITE( NOUT, FMT = 9997 )NT, PATH
END IF
DOTYPE( NT ) = .TRUE.
ELSE
WRITE( NOUT, FMT = 9999 )PATH, NT, NTYPES
9999 FORMAT( ' *** Invalid type request for ', A3, ', type ',
$ I4, ': must satisfy 1 <= type <= ', I2 )
END IF
70 CONTINUE
80 CONTINUE
END IF
RETURN
*
90 CONTINUE
WRITE( NOUT, FMT = 9998 )PATH
9998 FORMAT( /' *** End of file reached when trying to read matrix ',
$ 'types for ', A3, /' *** Check that you are requesting the',
$ ' right number of types for each path', / )
9997 FORMAT( ' *** Warning: duplicate request of matrix type ', I2,
$ ' for ', A3 )
9996 FORMAT( //' *** Invalid integer value in column ', I2,
$ ' of input', ' line:', /A79 )
9995 FORMAT( //' *** Not enough matrix types on input line', /A79 )
9994 FORMAT( ' ==> Specify ', I4, ' matrix types on this line or ',
$ 'adjust NTYPES on previous line' )
WRITE( NOUT, FMT = * )
STOP
*
* End of ALAREQ
*
END
SUBROUTINE ALASUM( TYPE, NOUT, NFAIL, NRUN, NERRS )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 TYPE
INTEGER NFAIL, NOUT, NRUN, NERRS
* ..
*
* Purpose
* =======
*
* ALASUM prints a summary of results from one of the -CHK- routines.
*
* Arguments
* =========
*
* TYPE (input) CHARACTER*3
* The LAPACK path name.
*
* NOUT (input) INTEGER
* The unit number on which results are to be printed.
* NOUT >= 0.
*
* NFAIL (input) INTEGER
* The number of tests which did not pass the threshold ratio.
*
* NRUN (input) INTEGER
* The total number of tests.
*
* NERRS (input) INTEGER
* The number of error messages recorded.
*
* =====================================================================
*
* .. Executable Statements ..
*
IF( NFAIL.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )TYPE, NFAIL, NRUN
ELSE
WRITE( NOUT, FMT = 9998 )TYPE, NRUN
END IF
IF( NERRS.GT.0 ) THEN
WRITE( NOUT, FMT = 9997 )NERRS
END IF
*
9999 FORMAT( 1X, A3, ': ', I6, ' out of ', I6,
$ ' tests failed to pass the threshold' )
9998 FORMAT( /1X, 'All tests for ', A3,
$ ' routines passed the threshold (', I6, ' tests run)' )
9997 FORMAT( 6X, I6, ' error messages recorded' )
RETURN
*
* End of ALASUM
*
END
SUBROUTINE ALASVM( TYPE, NOUT, NFAIL, NRUN, NERRS )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 TYPE
INTEGER NFAIL, NOUT, NRUN, NERRS
* ..
*
* Purpose
* =======
*
* ALASVM prints a summary of results from one of the -DRV- routines.
*
* Arguments
* =========
*
* TYPE (input) CHARACTER*3
* The LAPACK path name.
*
* NOUT (input) INTEGER
* The unit number on which results are to be printed.
* NOUT >= 0.
*
* NFAIL (input) INTEGER
* The number of tests which did not pass the threshold ratio.
*
* NRUN (input) INTEGER
* The total number of tests.
*
* NERRS (input) INTEGER
* The number of error messages recorded.
*
* =====================================================================
*
* .. Executable Statements ..
*
IF( NFAIL.GT.0 ) THEN
WRITE( NOUT, FMT = 9999 )TYPE, NFAIL, NRUN
ELSE
WRITE( NOUT, FMT = 9998 )TYPE, NRUN
END IF
IF( NERRS.GT.0 ) THEN
WRITE( NOUT, FMT = 9997 )NERRS
END IF
*
9999 FORMAT( 1X, A3, ' drivers: ', I6, ' out of ', I6,
$ ' tests failed to pass the threshold' )
9998 FORMAT( /1X, 'All tests for ', A3, ' drivers passed the ',
$ 'threshold (', I6, ' tests run)' )
9997 FORMAT( 14X, I6, ' error messages recorded' )
RETURN
*
* End of ALASVM
*
END
SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
*
* Tests whether XERBLA has detected an error when it should.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Scalar Arguments ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Executable Statements ..
IF( .NOT.LERR ) THEN
WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT
OK = .FALSE.
END IF
LERR = .FALSE.
RETURN
*
9999 FORMAT( ' *** Illegal value of parameter number ', I2,
$ ' not detected by ', A6, ' ***' )
*
* End of CHKXER.
*
END
SUBROUTINE DBDT01( M, N, KD, A, LDA, Q, LDQ, D, E, PT, LDPT, WORK,
$ RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KD, LDA, LDPT, LDQ, M, N
DOUBLE PRECISION RESID
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), PT( LDPT, * ),
$ Q( LDQ, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DBDT01 reconstructs a general matrix A from its bidiagonal form
* A = Q * B * P'
* where Q (m by min(m,n)) and P' (min(m,n) by n) are orthogonal
* matrices and B is bidiagonal.
*
* The test ratio to test the reduction is
* RESID = norm( A - Q * B * PT ) / ( n * norm(A) * EPS )
* where PT = P' and EPS is the machine precision.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrices A and Q.
*
* N (input) INTEGER
* The number of columns of the matrices A and P'.
*
* KD (input) INTEGER
* If KD = 0, B is diagonal and the array E is not referenced.
* If KD = 1, the reduction was performed by xGEBRD; B is upper
* bidiagonal if M >= N, and lower bidiagonal if M < N.
* If KD = -1, the reduction was performed by xGBBRD; B is
* always upper bidiagonal.
*
* 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).
*
* Q (input) DOUBLE PRECISION array, dimension (LDQ,N)
* The m by min(m,n) orthogonal matrix Q in the reduction
* A = Q * B * P'.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,M).
*
* D (input) DOUBLE PRECISION array, dimension (min(M,N))
* The diagonal elements of the bidiagonal matrix B.
*
* E (input) DOUBLE PRECISION array, dimension (min(M,N)-1)
* The superdiagonal elements of the bidiagonal matrix B if
* m >= n, or the subdiagonal elements of B if m < n.
*
* PT (input) DOUBLE PRECISION array, dimension (LDPT,N)
* The min(m,n) by n orthogonal matrix P' in the reduction
* A = Q * B * P'.
*
* LDPT (input) INTEGER
* The leading dimension of the array PT.
* LDPT >= max(1,min(M,N)).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (M+N)
*
* RESID (output) DOUBLE PRECISION
* The test ratio: norm(A - Q * B * P') / ( n * norm(A) * EPS )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION ANORM, EPS
* ..
* .. External Functions ..
DOUBLE PRECISION DASUM, DLAMCH, DLANGE
EXTERNAL DASUM, DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 ) THEN
RESID = ZERO
RETURN
END IF
*
* Compute A - Q * B * P' one column at a time.
*
RESID = ZERO
IF( KD.NE.0 ) THEN
*
* B is bidiagonal.
*
IF( KD.NE.0 .AND. M.GE.N ) THEN
*
* B is upper bidiagonal and M >= N.
*
DO 20 J = 1, N
CALL DCOPY( M, A( 1, J ), 1, WORK, 1 )
DO 10 I = 1, N - 1
WORK( M+I ) = D( I )*PT( I, J ) + E( I )*PT( I+1, J )
10 CONTINUE
WORK( M+N ) = D( N )*PT( N, J )
CALL DGEMV( 'No transpose', M, N, -ONE, Q, LDQ,
$ WORK( M+1 ), 1, ONE, WORK, 1 )
RESID = MAX( RESID, DASUM( M, WORK, 1 ) )
20 CONTINUE
ELSE IF( KD.LT.0 ) THEN
*
* B is upper bidiagonal and M < N.
*
DO 40 J = 1, N
CALL DCOPY( M, A( 1, J ), 1, WORK, 1 )
DO 30 I = 1, M - 1
WORK( M+I ) = D( I )*PT( I, J ) + E( I )*PT( I+1, J )
30 CONTINUE
WORK( M+M ) = D( M )*PT( M, J )
CALL DGEMV( 'No transpose', M, M, -ONE, Q, LDQ,
$ WORK( M+1 ), 1, ONE, WORK, 1 )
RESID = MAX( RESID, DASUM( M, WORK, 1 ) )
40 CONTINUE
ELSE
*
* B is lower bidiagonal.
*
DO 60 J = 1, N
CALL DCOPY( M, A( 1, J ), 1, WORK, 1 )
WORK( M+1 ) = D( 1 )*PT( 1, J )
DO 50 I = 2, M
WORK( M+I ) = E( I-1 )*PT( I-1, J ) +
$ D( I )*PT( I, J )
50 CONTINUE
CALL DGEMV( 'No transpose', M, M, -ONE, Q, LDQ,
$ WORK( M+1 ), 1, ONE, WORK, 1 )
RESID = MAX( RESID, DASUM( M, WORK, 1 ) )
60 CONTINUE
END IF
ELSE
*
* B is diagonal.
*
IF( M.GE.N ) THEN
DO 80 J = 1, N
CALL DCOPY( M, A( 1, J ), 1, WORK, 1 )
DO 70 I = 1, N
WORK( M+I ) = D( I )*PT( I, J )
70 CONTINUE
CALL DGEMV( 'No transpose', M, N, -ONE, Q, LDQ,
$ WORK( M+1 ), 1, ONE, WORK, 1 )
RESID = MAX( RESID, DASUM( M, WORK, 1 ) )
80 CONTINUE
ELSE
DO 100 J = 1, N
CALL DCOPY( M, A( 1, J ), 1, WORK, 1 )
DO 90 I = 1, M
WORK( M+I ) = D( I )*PT( I, J )
90 CONTINUE
CALL DGEMV( 'No transpose', M, M, -ONE, Q, LDQ,
$ WORK( M+1 ), 1, ONE, WORK, 1 )
RESID = MAX( RESID, DASUM( M, WORK, 1 ) )
100 CONTINUE
END IF
END IF
*
* Compute norm(A - Q * B * P') / ( n * norm(A) * EPS )
*
ANORM = DLANGE( '1', M, N, A, LDA, WORK )
EPS = DLAMCH( 'Precision' )
*
IF( ANORM.LE.ZERO ) THEN
IF( RESID.NE.ZERO )
$ RESID = ONE / EPS
ELSE
IF( ANORM.GE.RESID ) THEN
RESID = ( RESID / ANORM ) / ( DBLE( N )*EPS )
ELSE
IF( ANORM.LT.ONE ) THEN
RESID = ( MIN( RESID, DBLE( N )*ANORM ) / ANORM ) /
$ ( DBLE( N )*EPS )
ELSE
RESID = MIN( RESID / ANORM, DBLE( N ) ) /
$ ( DBLE( N )*EPS )
END IF
END IF
END IF
*
RETURN
*
* End of DBDT01
*
END
SUBROUTINE DBDT02( M, N, B, LDB, C, LDC, U, LDU, WORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDB, LDC, LDU, M, N
DOUBLE PRECISION RESID
* ..
* .. Array Arguments ..
DOUBLE PRECISION B( LDB, * ), C( LDC, * ), U( LDU, * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* DBDT02 tests the change of basis C = U' * B by computing the residual
*
* RESID = norm( B - U * C ) / ( max(m,n) * norm(B) * EPS ),
*
* where B and C are M by N matrices, U is an M by M orthogonal matrix,
* and EPS is the machine precision.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrices B and C and the order of
* the matrix Q.
*
* N (input) INTEGER
* The number of columns of the matrices B and C.
*
* B (input) DOUBLE PRECISION array, dimension (LDB,N)
* The m by n matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,M).
*
* C (input) DOUBLE PRECISION array, dimension (LDC,N)
* The m by n matrix C, assumed to contain U' * B.
*
* LDC (input) INTEGER
* The leading dimension of the array C. LDC >= max(1,M).
*
* U (input) DOUBLE PRECISION array, dimension (LDU,M)
* The m by m orthogonal matrix U.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= max(1,M).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (M)
*
* RESID (output) DOUBLE PRECISION
* RESID = norm( B - U * C ) / ( max(m,n) * norm(B) * EPS ),
*
* ======================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER J
DOUBLE PRECISION BNORM, EPS, REALMN
* ..
* .. External Functions ..
DOUBLE PRECISION DASUM, DLAMCH, DLANGE
EXTERNAL DASUM, DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
RESID = ZERO
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
REALMN = DBLE( MAX( M, N ) )
EPS = DLAMCH( 'Precision' )
*
* Compute norm( B - U * C )
*
DO 10 J = 1, N
CALL DCOPY( M, B( 1, J ), 1, WORK, 1 )
CALL DGEMV( 'No transpose', M, M, -ONE, U, LDU, C( 1, J ), 1,
$ ONE, WORK, 1 )
RESID = MAX( RESID, DASUM( M, WORK, 1 ) )
10 CONTINUE
*
* Compute norm of B.
*
BNORM = DLANGE( '1', M, N, B, LDB, WORK )
*
IF( BNORM.LE.ZERO ) THEN
IF( RESID.NE.ZERO )
$ RESID = ONE / EPS
ELSE
IF( BNORM.GE.RESID ) THEN
RESID = ( RESID / BNORM ) / ( REALMN*EPS )
ELSE
IF( BNORM.LT.ONE ) THEN
RESID = ( MIN( RESID, REALMN*BNORM ) / BNORM ) /
$ ( REALMN*EPS )
ELSE
RESID = MIN( RESID / BNORM, REALMN ) / ( REALMN*EPS )
END IF
END IF
END IF
RETURN
*
* End of DBDT02
*
END
SUBROUTINE DBDT03( UPLO, N, KD, D, E, U, LDU, S, VT, LDVT, WORK,
$ RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER KD, LDU, LDVT, N
DOUBLE PRECISION RESID
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * ), S( * ), U( LDU, * ),
$ VT( LDVT, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DBDT03 reconstructs a bidiagonal matrix B from its SVD:
* S = U' * B * V
* where U and V are orthogonal matrices and S is diagonal.
*
* The test ratio to test the singular value decomposition is
* RESID = norm( B - U * S * VT ) / ( n * norm(B) * EPS )
* where VT = V' and EPS is the machine precision.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix B is upper or lower bidiagonal.
* = 'U': Upper bidiagonal
* = 'L': Lower bidiagonal
*
* N (input) INTEGER
* The order of the matrix B.
*
* KD (input) INTEGER
* The bandwidth of the bidiagonal matrix B. If KD = 1, the
* matrix B is bidiagonal, and if KD = 0, B is diagonal and E is
* not referenced. If KD is greater than 1, it is assumed to be
* 1, and if KD is less than 0, it is assumed to be 0.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the bidiagonal matrix B.
*
* E (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) superdiagonal elements of the bidiagonal matrix B
* if UPLO = 'U', or the (n-1) subdiagonal elements of B if
* UPLO = 'L'.
*
* U (input) DOUBLE PRECISION array, dimension (LDU,N)
* The n by n orthogonal matrix U in the reduction B = U'*A*P.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= max(1,N)
*
* S (input) DOUBLE PRECISION array, dimension (N)
* The singular values from the SVD of B, sorted in decreasing
* order.
*
* VT (input) DOUBLE PRECISION array, dimension (LDVT,N)
* The n by n orthogonal matrix V' in the reduction
* B = U * S * V'.
*
* LDVT (input) INTEGER
* The leading dimension of the array VT.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
*
* RESID (output) DOUBLE PRECISION
* The test ratio: norm(B - U * S * V') / ( n * norm(A) * EPS )
*
* ======================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION BNORM, EPS
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DASUM, DLAMCH
EXTERNAL LSAME, IDAMAX, DASUM, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DGEMV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
RESID = ZERO
IF( N.LE.0 )
$ RETURN
*
* Compute B - U * S * V' one column at a time.
*
BNORM = ZERO
IF( KD.GE.1 ) THEN
*
* B is bidiagonal.
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* B is upper bidiagonal.
*
DO 20 J = 1, N
DO 10 I = 1, N
WORK( N+I ) = S( I )*VT( I, J )
10 CONTINUE
CALL DGEMV( 'No transpose', N, N, -ONE, U, LDU,
$ WORK( N+1 ), 1, ZERO, WORK, 1 )
WORK( J ) = WORK( J ) + D( J )
IF( J.GT.1 ) THEN
WORK( J-1 ) = WORK( J-1 ) + E( J-1 )
BNORM = MAX( BNORM, ABS( D( J ) )+ABS( E( J-1 ) ) )
ELSE
BNORM = MAX( BNORM, ABS( D( J ) ) )
END IF
RESID = MAX( RESID, DASUM( N, WORK, 1 ) )
20 CONTINUE
ELSE
*
* B is lower bidiagonal.
*
DO 40 J = 1, N
DO 30 I = 1, N
WORK( N+I ) = S( I )*VT( I, J )
30 CONTINUE
CALL DGEMV( 'No transpose', N, N, -ONE, U, LDU,
$ WORK( N+1 ), 1, ZERO, WORK, 1 )
WORK( J ) = WORK( J ) + D( J )
IF( J.LT.N ) THEN
WORK( J+1 ) = WORK( J+1 ) + E( J )
BNORM = MAX( BNORM, ABS( D( J ) )+ABS( E( J ) ) )
ELSE
BNORM = MAX( BNORM, ABS( D( J ) ) )
END IF
RESID = MAX( RESID, DASUM( N, WORK, 1 ) )
40 CONTINUE
END IF
ELSE
*
* B is diagonal.
*
DO 60 J = 1, N
DO 50 I = 1, N
WORK( N+I ) = S( I )*VT( I, J )
50 CONTINUE
CALL DGEMV( 'No transpose', N, N, -ONE, U, LDU, WORK( N+1 ),
$ 1, ZERO, WORK, 1 )
WORK( J ) = WORK( J ) + D( J )
RESID = MAX( RESID, DASUM( N, WORK, 1 ) )
60 CONTINUE
J = IDAMAX( N, D, 1 )
BNORM = ABS( D( J ) )
END IF
*
* Compute norm(B - U * S * V') / ( n * norm(B) * EPS )
*
EPS = DLAMCH( 'Precision' )
*
IF( BNORM.LE.ZERO ) THEN
IF( RESID.NE.ZERO )
$ RESID = ONE / EPS
ELSE
IF( BNORM.GE.RESID ) THEN
RESID = ( RESID / BNORM ) / ( DBLE( N )*EPS )
ELSE
IF( BNORM.LT.ONE ) THEN
RESID = ( MIN( RESID, DBLE( N )*BNORM ) / BNORM ) /
$ ( DBLE( N )*EPS )
ELSE
RESID = MIN( RESID / BNORM, DBLE( N ) ) /
$ ( DBLE( N )*EPS )
END IF
END IF
END IF
*
RETURN
*
* End of DBDT03
*
END
SUBROUTINE DCHKBB( NSIZES, MVAL, NVAL, NWDTHS, KK, NTYPES, DOTYPE,
$ NRHS, ISEED, THRESH, NOUNIT, A, LDA, AB, LDAB,
$ BD, BE, Q, LDQ, P, LDP, C, LDC, CC, WORK,
$ LWORK, RESULT, INFO )
*
* -- LAPACK test routine (release 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDAB, LDC, LDP, LDQ, LWORK, NOUNIT,
$ NRHS, NSIZES, NTYPES, NWDTHS
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER ISEED( 4 ), KK( * ), MVAL( * ), NVAL( * )
DOUBLE PRECISION A( LDA, * ), AB( LDAB, * ), BD( * ), BE( * ),
$ C( LDC, * ), CC( LDC, * ), P( LDP, * ),
$ Q( LDQ, * ), RESULT( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DCHKBB tests the reduction of a general real rectangular band
* matrix to bidiagonal form.
*
* DGBBRD factors a general band matrix A as Q B P* , where * means
* transpose, B is upper bidiagonal, and Q and P are orthogonal;
* DGBBRD can also overwrite a given matrix C with Q* C .
*
* For each pair of matrix dimensions (M,N) and each selected matrix
* type, an M by N matrix A and an M by NRHS matrix C are generated.
* The problem dimensions are as follows
* A: M x N
* Q: M x M
* P: N x N
* B: min(M,N) x min(M,N)
* C: M x NRHS
*
* For each generated matrix, 4 tests are performed:
*
* (1) | A - Q B PT | / ( |A| max(M,N) ulp ), PT = P'
*
* (2) | I - Q' Q | / ( M ulp )
*
* (3) | I - PT PT' | / ( N ulp )
*
* (4) | Y - Q' C | / ( |Y| max(M,NRHS) ulp ), where Y = Q' C.
*
* The "types" are specified by a logical array DOTYPE( 1:NTYPES );
* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
* Currently, the list of possible types is:
*
* The possible matrix types are
*
* (1) The zero matrix.
* (2) The identity matrix.
*
* (3) A diagonal matrix with evenly spaced entries
* 1, ..., ULP and random signs.
* (ULP = (first number larger than 1) - 1 )
* (4) A diagonal matrix with geometrically spaced entries
* 1, ..., ULP and random signs.
* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
* and random signs.
*
* (6) Same as (3), but multiplied by SQRT( overflow threshold )
* (7) Same as (3), but multiplied by SQRT( underflow threshold )
*
* (8) A matrix of the form U D V, where U and V are orthogonal and
* D has evenly spaced entries 1, ..., ULP with random signs
* on the diagonal.
*
* (9) A matrix of the form U D V, where U and V are orthogonal and
* D has geometrically spaced entries 1, ..., ULP with random
* signs on the diagonal.
*
* (10) A matrix of the form U D V, where U and V are orthogonal and
* D has "clustered" entries 1, ULP,..., ULP with random
* signs on the diagonal.
*
* (11) Same as (8), but multiplied by SQRT( overflow threshold )
* (12) Same as (8), but multiplied by SQRT( underflow threshold )
*
* (13) Rectangular matrix with random entries chosen from (-1,1).
* (14) Same as (13), but multiplied by SQRT( overflow threshold )
* (15) Same as (13), but multiplied by SQRT( underflow threshold )
*
* Arguments
* =========
*
* NSIZES (input) INTEGER
* The number of values of M and N contained in the vectors
* MVAL and NVAL. The matrix sizes are used in pairs (M,N).
* If NSIZES is zero, DCHKBB does nothing. NSIZES must be at
* least zero.
*
* MVAL (input) INTEGER array, dimension (NSIZES)
* The values of the matrix row dimension M.
*
* NVAL (input) INTEGER array, dimension (NSIZES)
* The values of the matrix column dimension N.
*
* NWDTHS (input) INTEGER
* The number of bandwidths to use. If it is zero,
* DCHKBB does nothing. It must be at least zero.
*
* KK (input) INTEGER array, dimension (NWDTHS)
* An array containing the bandwidths to be used for the band
* matrices. The values must be at least zero.
*
* NTYPES (input) INTEGER
* The number of elements in DOTYPE. If it is zero, DCHKBB
* does nothing. It must be at least zero. If it is MAXTYP+1
* and NSIZES is 1, then an additional type, MAXTYP+1 is
* defined, which is to use whatever matrix is in A. This
* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
* DOTYPE(MAXTYP+1) is .TRUE. .
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* If DOTYPE(j) is .TRUE., then for each size in NN a
* matrix of that size and of type j will be generated.
* If NTYPES is smaller than the maximum number of types
* defined (PARAMETER MAXTYP), then types NTYPES+1 through
* MAXTYP will not be generated. If NTYPES is larger
* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
* will be ignored.
*
* NRHS (input) INTEGER
* The number of columns in the "right-hand side" matrix C.
* If NRHS = 0, then the operations on the right-hand side will
* not be tested. NRHS must be at least 0.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The array elements should be between 0 and 4095;
* if not they will be reduced mod 4096. Also, ISEED(4) must
* be odd. The random number generator uses a linear
* congruential sequence limited to small integers, and so
* should produce machine independent random numbers. The
* values of ISEED are changed on exit, and can be used in the
* next call to DCHKBB to continue the same random number
* sequence.
*
* THRESH (input) DOUBLE PRECISION
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error
* is scaled to be O(1), so THRESH should be a reasonably
* small multiple of 1, e.g., 10 or 100. In particular,
* it should not depend on the precision (single vs. double)
* or the size of the matrix. It must be at least zero.
*
* NOUNIT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns IINFO not equal to 0.)
*
* A (input/workspace) DOUBLE PRECISION array, dimension
* (LDA, max(NN))
* Used to hold the matrix A.
*
* LDA (input) INTEGER
* The leading dimension of A. It must be at least 1
* and at least max( NN ).
*
* AB (workspace) DOUBLE PRECISION array, dimension (LDAB, max(NN))
* Used to hold A in band storage format.
*
* LDAB (input) INTEGER
* The leading dimension of AB. It must be at least 2 (not 1!)
* and at least max( KK )+1.
*
* BD (workspace) DOUBLE PRECISION array, dimension (max(NN))
* Used to hold the diagonal of the bidiagonal matrix computed
* by DGBBRD.
*
* BE (workspace) DOUBLE PRECISION array, dimension (max(NN))
* Used to hold the off-diagonal of the bidiagonal matrix
* computed by DGBBRD.
*
* Q (workspace) DOUBLE PRECISION array, dimension (LDQ, max(NN))
* Used to hold the orthogonal matrix Q computed by DGBBRD.
*
* LDQ (input) INTEGER
* The leading dimension of Q. It must be at least 1
* and at least max( NN ).
*
* P (workspace) DOUBLE PRECISION array, dimension (LDP, max(NN))
* Used to hold the orthogonal matrix P computed by DGBBRD.
*
* LDP (input) INTEGER
* The leading dimension of P. It must be at least 1
* and at least max( NN ).
*
* C (workspace) DOUBLE PRECISION array, dimension (LDC, max(NN))
* Used to hold the matrix C updated by DGBBRD.
*
* LDC (input) INTEGER
* The leading dimension of U. It must be at least 1
* and at least max( NN ).
*
* CC (workspace) DOUBLE PRECISION array, dimension (LDC, max(NN))
* Used to hold a copy of the matrix C.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The number of entries in WORK. This must be at least
* max( LDA+1, max(NN)+1 )*max(NN).
*
* RESULT (output) DOUBLE PRECISION array, dimension (4)
* The values computed by the tests described above.
* The values are currently limited to 1/ulp, to avoid
* overflow.
*
* INFO (output) INTEGER
* If 0, then everything ran OK.
*
*-----------------------------------------------------------------------
*
* Some Local Variables and Parameters:
* ---- ----- --------- --- ----------
* ZERO, ONE Real 0 and 1.
* MAXTYP The number of types defined.
* NTEST The number of tests performed, or which can
* be performed so far, for the current matrix.
* NTESTT The total number of tests performed so far.
* NMAX Largest value in NN.
* NMATS The number of matrices generated so far.
* NERRS The number of tests which have exceeded THRESH
* so far.
* COND, IMODE Values to be passed to the matrix generators.
* ANORM Norm of A; passed to matrix generators.
*
* OVFL, UNFL Overflow and underflow thresholds.
* ULP, ULPINV Finest relative precision and its inverse.
* RTOVFL, RTUNFL Square roots of the previous 2 values.
* The following four arrays decode JTYPE:
* KTYPE(j) The general type (1-10) for type "j".
* KMODE(j) The MODE value to be passed to the matrix
* generator for type "j".
* KMAGN(j) The order of magnitude ( O(1),
* O(overflow^(1/2) ), O(underflow^(1/2) )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 15 )
* ..
* .. Local Scalars ..
LOGICAL BADMM, BADNN, BADNNB
INTEGER I, IINFO, IMODE, ITYPE, J, JCOL, JR, JSIZE,
$ JTYPE, JWIDTH, K, KL, KMAX, KU, M, MMAX, MNMAX,
$ MNMIN, MTYPES, N, NERRS, NMATS, NMAX, NTEST,
$ NTESTT
DOUBLE PRECISION AMNINV, ANORM, COND, OVFL, RTOVFL, RTUNFL, ULP,
$ ULPINV, UNFL
* ..
* .. Local Arrays ..
INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KMAGN( MAXTYP ),
$ KMODE( MAXTYP ), KTYPE( MAXTYP )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DBDT01, DBDT02, DGBBRD, DLACPY, DLAHD2, DLASET,
$ DLASUM, DLATMR, DLATMS, DORT01, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN, SQRT
* ..
* .. Data statements ..
DATA KTYPE / 1, 2, 5*4, 5*6, 3*9 /
DATA KMAGN / 2*1, 3*1, 2, 3, 3*1, 2, 3, 1, 2, 3 /
DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
$ 0, 0 /
* ..
* .. Executable Statements ..
*
* Check for errors
*
NTESTT = 0
INFO = 0
*
* Important constants
*
BADMM = .FALSE.
BADNN = .FALSE.
MMAX = 1
NMAX = 1
MNMAX = 1
DO 10 J = 1, NSIZES
MMAX = MAX( MMAX, MVAL( J ) )
IF( MVAL( J ).LT.0 )
$ BADMM = .TRUE.
NMAX = MAX( NMAX, NVAL( J ) )
IF( NVAL( J ).LT.0 )
$ BADNN = .TRUE.
MNMAX = MAX( MNMAX, MIN( MVAL( J ), NVAL( J ) ) )
10 CONTINUE
*
BADNNB = .FALSE.
KMAX = 0
DO 20 J = 1, NWDTHS
KMAX = MAX( KMAX, KK( J ) )
IF( KK( J ).LT.0 )
$ BADNNB = .TRUE.
20 CONTINUE
*
* Check for errors
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADMM ) THEN
INFO = -2
ELSE IF( BADNN ) THEN
INFO = -3
ELSE IF( NWDTHS.LT.0 ) THEN
INFO = -4
ELSE IF( BADNNB ) THEN
INFO = -5
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -6
ELSE IF( NRHS.LT.0 ) THEN
INFO = -8
ELSE IF( LDA.LT.NMAX ) THEN
INFO = -13
ELSE IF( LDAB.LT.2*KMAX+1 ) THEN
INFO = -15
ELSE IF( LDQ.LT.NMAX ) THEN
INFO = -19
ELSE IF( LDP.LT.NMAX ) THEN
INFO = -21
ELSE IF( LDC.LT.NMAX ) THEN
INFO = -23
ELSE IF( ( MAX( LDA, NMAX )+1 )*NMAX.GT.LWORK ) THEN
INFO = -26
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DCHKBB', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 .OR. NWDTHS.EQ.0 )
$ RETURN
*
* More Important constants
*
UNFL = DLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
ULPINV = ONE / ULP
RTUNFL = SQRT( UNFL )
RTOVFL = SQRT( OVFL )
*
* Loop over sizes, widths, types
*
NERRS = 0
NMATS = 0
*
DO 160 JSIZE = 1, NSIZES
M = MVAL( JSIZE )
N = NVAL( JSIZE )
MNMIN = MIN( M, N )
AMNINV = ONE / DBLE( MAX( 1, M, N ) )
*
DO 150 JWIDTH = 1, NWDTHS
K = KK( JWIDTH )
IF( K.GE.M .AND. K.GE.N )
$ GO TO 150
KL = MAX( 0, MIN( M-1, K ) )
KU = MAX( 0, MIN( N-1, K ) )
*
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
DO 140 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 140
NMATS = NMATS + 1
NTEST = 0
*
DO 30 J = 1, 4
IOLDSD( J ) = ISEED( J )
30 CONTINUE
*
* Compute "A".
*
* Control parameters:
*
* KMAGN KMODE KTYPE
* =1 O(1) clustered 1 zero
* =2 large clustered 2 identity
* =3 small exponential (none)
* =4 arithmetic diagonal, (w/ singular values)
* =5 random log (none)
* =6 random nonhermitian, w/ singular values
* =7 (none)
* =8 (none)
* =9 random nonhermitian
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 90
*
ITYPE = KTYPE( JTYPE )
IMODE = KMODE( JTYPE )
*
* Compute norm
*
GO TO ( 40, 50, 60 )KMAGN( JTYPE )
*
40 CONTINUE
ANORM = ONE
GO TO 70
*
50 CONTINUE
ANORM = ( RTOVFL*ULP )*AMNINV
GO TO 70
*
60 CONTINUE
ANORM = RTUNFL*MAX( M, N )*ULPINV
GO TO 70
*
70 CONTINUE
*
CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
CALL DLASET( 'Full', LDAB, N, ZERO, ZERO, AB, LDAB )
IINFO = 0
COND = ULPINV
*
* Special Matrices -- Identity & Jordan block
*
* Zero
*
IF( ITYPE.EQ.1 ) THEN
IINFO = 0
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Identity
*
DO 80 JCOL = 1, N
A( JCOL, JCOL ) = ANORM
80 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Diagonal Matrix, singular values specified
*
CALL DLATMS( M, N, 'S', ISEED, 'N', WORK, IMODE, COND,
$ ANORM, 0, 0, 'N', A, LDA, WORK( M+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.6 ) THEN
*
* Nonhermitian, singular values specified
*
CALL DLATMS( M, N, 'S', ISEED, 'N', WORK, IMODE, COND,
$ ANORM, KL, KU, 'N', A, LDA, WORK( M+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.9 ) THEN
*
* Nonhermitian, random entries
*
CALL DLATMR( M, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, KL,
$ KU, ZERO, ANORM, 'N', A, LDA, IDUMMA,
$ IINFO )
*
ELSE
*
IINFO = 1
END IF
*
* Generate Right-Hand Side
*
CALL DLATMR( M, NRHS, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( M+1 ), 1, ONE,
$ WORK( 2*M+1 ), 1, ONE, 'N', IDUMMA, M, NRHS,
$ ZERO, ONE, 'NO', C, LDC, IDUMMA, IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
90 CONTINUE
*
* Copy A to band storage.
*
DO 110 J = 1, N
DO 100 I = MAX( 1, J-KU ), MIN( M, J+KL )
AB( KU+1+I-J, J ) = A( I, J )
100 CONTINUE
110 CONTINUE
*
* Copy C
*
CALL DLACPY( 'Full', M, NRHS, C, LDC, CC, LDC )
*
* Call DGBBRD to compute B, Q and P, and to update C.
*
CALL DGBBRD( 'B', M, N, NRHS, KL, KU, AB, LDAB, BD, BE,
$ Q, LDQ, P, LDP, CC, LDC, WORK, IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DGBBRD', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 1 ) = ULPINV
GO TO 120
END IF
END IF
*
* Test 1: Check the decomposition A := Q * B * P'
* 2: Check the orthogonality of Q
* 3: Check the orthogonality of P
* 4: Check the computation of Q' * C
*
CALL DBDT01( M, N, -1, A, LDA, Q, LDQ, BD, BE, P, LDP,
$ WORK, RESULT( 1 ) )
CALL DORT01( 'Columns', M, M, Q, LDQ, WORK, LWORK,
$ RESULT( 2 ) )
CALL DORT01( 'Rows', N, N, P, LDP, WORK, LWORK,
$ RESULT( 3 ) )
CALL DBDT02( M, NRHS, C, LDC, CC, LDC, Q, LDQ, WORK,
$ RESULT( 4 ) )
*
* End of Loop -- Check for RESULT(j) > THRESH
*
NTEST = 4
120 CONTINUE
NTESTT = NTESTT + NTEST
*
* Print out tests which fail.
*
DO 130 JR = 1, NTEST
IF( RESULT( JR ).GE.THRESH ) THEN
IF( NERRS.EQ.0 )
$ CALL DLAHD2( NOUNIT, 'DBB' )
NERRS = NERRS + 1
WRITE( NOUNIT, FMT = 9998 )M, N, K, IOLDSD, JTYPE,
$ JR, RESULT( JR )
END IF
130 CONTINUE
*
140 CONTINUE
150 CONTINUE
160 CONTINUE
*
* Summary
*
CALL DLASUM( 'DBB', NOUNIT, NERRS, NTESTT )
RETURN
*
9999 FORMAT( ' DCHKBB: ', A, ' returned INFO=', I5, '.', / 9X, 'M=',
$ I5, ' N=', I5, ' K=', I5, ', JTYPE=', I5, ', ISEED=(',
$ 3( I5, ',' ), I5, ')' )
9998 FORMAT( ' M =', I4, ' N=', I4, ', K=', I3, ', seed=',
$ 4( I4, ',' ), ' type ', I2, ', test(', I2, ')=', G10.3 )
*
* End of DCHKBB
*
END
SUBROUTINE DCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS,
$ ISEED, THRESH, A, LDA, BD, BE, S1, S2, X, LDX,
$ Y, Z, Q, LDQ, PT, LDPT, U, VT, WORK, LWORK,
$ IWORK, NOUT, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDPT, LDQ, LDX, LWORK, NOUT, NRHS,
$ NSIZES, NTYPES
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER ISEED( 4 ), IWORK( * ), MVAL( * ), NVAL( * )
DOUBLE PRECISION A( LDA, * ), BD( * ), BE( * ), PT( LDPT, * ),
$ Q( LDQ, * ), S1( * ), S2( * ), U( LDPT, * ),
$ VT( LDPT, * ), WORK( * ), X( LDX, * ),
$ Y( LDX, * ), Z( LDX, * )
* ..
*
* Purpose
* =======
*
* DCHKBD checks the singular value decomposition (SVD) routines.
*
* DGEBRD reduces a real general m by n matrix A to upper or lower
* bidiagonal form B by an orthogonal transformation: Q' * A * P = B
* (or A = Q * B * P'). The matrix B is upper bidiagonal if m >= n
* and lower bidiagonal if m < n.
*
* DORGBR generates the orthogonal matrices Q and P' from DGEBRD.
* Note that Q and P are not necessarily square.
*
* DBDSQR computes the singular value decomposition of the bidiagonal
* matrix B as B = U S V'. It is called three times to compute
* 1) B = U S1 V', where S1 is the diagonal matrix of singular
* values and the columns of the matrices U and V are the left
* and right singular vectors, respectively, of B.
* 2) Same as 1), but the singular values are stored in S2 and the
* singular vectors are not computed.
* 3) A = (UQ) S (P'V'), the SVD of the original matrix A.
* In addition, DBDSQR has an option to apply the left orthogonal matrix
* U to a matrix X, useful in least squares applications.
*
* DBDSDC computes the singular value decomposition of the bidiagonal
* matrix B as B = U S V' using divide-and-conquer. It is called twice
* to compute
* 1) B = U S1 V', where S1 is the diagonal matrix of singular
* values and the columns of the matrices U and V are the left
* and right singular vectors, respectively, of B.
* 2) Same as 1), but the singular values are stored in S2 and the
* singular vectors are not computed.
*
* For each pair of matrix dimensions (M,N) and each selected matrix
* type, an M by N matrix A and an M by NRHS matrix X are generated.
* The problem dimensions are as follows
* A: M x N
* Q: M x min(M,N) (but M x M if NRHS > 0)
* P: min(M,N) x N
* B: min(M,N) x min(M,N)
* U, V: min(M,N) x min(M,N)
* S1, S2 diagonal, order min(M,N)
* X: M x NRHS
*
* For each generated matrix, 14 tests are performed:
*
* Test DGEBRD and DORGBR
*
* (1) | A - Q B PT | / ( |A| max(M,N) ulp ), PT = P'
*
* (2) | I - Q' Q | / ( M ulp )
*
* (3) | I - PT PT' | / ( N ulp )
*
* Test DBDSQR on bidiagonal matrix B
*
* (4) | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V'
*
* (5) | Y - U Z | / ( |Y| max(min(M,N),k) ulp ), where Y = Q' X
* and Z = U' Y.
* (6) | I - U' U | / ( min(M,N) ulp )
*
* (7) | I - VT VT' | / ( min(M,N) ulp )
*
* (8) S1 contains min(M,N) nonnegative values in decreasing order.
* (Return 0 if true, 1/ULP if false.)
*
* (9) | S1 - S2 | / ( |S1| ulp ), where S2 is computed without
* computing U and V.
*
* (10) 0 if the true singular values of B are within THRESH of
* those in S1. 2*THRESH if they are not. (Tested using
* DSVDCH)
*
* Test DBDSQR on matrix A
*
* (11) | A - (QU) S (VT PT) | / ( |A| max(M,N) ulp )
*
* (12) | X - (QU) Z | / ( |X| max(M,k) ulp )
*
* (13) | I - (QU)'(QU) | / ( M ulp )
*
* (14) | I - (VT PT) (PT'VT') | / ( N ulp )
*
* Test DBDSDC on bidiagonal matrix B
*
* (15) | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V'
*
* (16) | I - U' U | / ( min(M,N) ulp )
*
* (17) | I - VT VT' | / ( min(M,N) ulp )
*
* (18) S1 contains min(M,N) nonnegative values in decreasing order.
* (Return 0 if true, 1/ULP if false.)
*
* (19) | S1 - S2 | / ( |S1| ulp ), where S2 is computed without
* computing U and V.
* The possible matrix types are
*
* (1) The zero matrix.
* (2) The identity matrix.
*
* (3) A diagonal matrix with evenly spaced entries
* 1, ..., ULP and random signs.
* (ULP = (first number larger than 1) - 1 )
* (4) A diagonal matrix with geometrically spaced entries
* 1, ..., ULP and random signs.
* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
* and random signs.
*
* (6) Same as (3), but multiplied by SQRT( overflow threshold )
* (7) Same as (3), but multiplied by SQRT( underflow threshold )
*
* (8) A matrix of the form U D V, where U and V are orthogonal and
* D has evenly spaced entries 1, ..., ULP with random signs
* on the diagonal.
*
* (9) A matrix of the form U D V, where U and V are orthogonal and
* D has geometrically spaced entries 1, ..., ULP with random
* signs on the diagonal.
*
* (10) A matrix of the form U D V, where U and V are orthogonal and
* D has "clustered" entries 1, ULP,..., ULP with random
* signs on the diagonal.
*
* (11) Same as (8), but multiplied by SQRT( overflow threshold )
* (12) Same as (8), but multiplied by SQRT( underflow threshold )
*
* (13) Rectangular matrix with random entries chosen from (-1,1).
* (14) Same as (13), but multiplied by SQRT( overflow threshold )
* (15) Same as (13), but multiplied by SQRT( underflow threshold )
*
* Special case:
* (16) A bidiagonal matrix with random entries chosen from a
* logarithmic distribution on [ulp^2,ulp^(-2)] (I.e., each
* entry is e^x, where x is chosen uniformly on
* [ 2 log(ulp), -2 log(ulp) ] .) For *this* type:
* (a) DGEBRD is not called to reduce it to bidiagonal form.
* (b) the bidiagonal is min(M,N) x min(M,N); if M= THRESH. To have
* every test ratio printed, use THRESH = 0. Note that the
* expected value of the test ratios is O(1), so THRESH should
* be a reasonably small multiple of 1, e.g., 10 or 100.
*
* A (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX)
* where NMAX is the maximum value of N in NVAL.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,MMAX),
* where MMAX is the maximum value of M in MVAL.
*
* BD (workspace) DOUBLE PRECISION array, dimension
* (max(min(MVAL(j),NVAL(j))))
*
* BE (workspace) DOUBLE PRECISION array, dimension
* (max(min(MVAL(j),NVAL(j))))
*
* S1 (workspace) DOUBLE PRECISION array, dimension
* (max(min(MVAL(j),NVAL(j))))
*
* S2 (workspace) DOUBLE PRECISION array, dimension
* (max(min(MVAL(j),NVAL(j))))
*
* X (workspace) DOUBLE PRECISION array, dimension (LDX,NRHS)
*
* LDX (input) INTEGER
* The leading dimension of the arrays X, Y, and Z.
* LDX >= max(1,MMAX)
*
* Y (workspace) DOUBLE PRECISION array, dimension (LDX,NRHS)
*
* Z (workspace) DOUBLE PRECISION array, dimension (LDX,NRHS)
*
* Q (workspace) DOUBLE PRECISION array, dimension (LDQ,MMAX)
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,MMAX).
*
* PT (workspace) DOUBLE PRECISION array, dimension (LDPT,NMAX)
*
* LDPT (input) INTEGER
* The leading dimension of the arrays PT, U, and V.
* LDPT >= max(1, max(min(MVAL(j),NVAL(j)))).
*
* U (workspace) DOUBLE PRECISION array, dimension
* (LDPT,max(min(MVAL(j),NVAL(j))))
*
* V (workspace) DOUBLE PRECISION array, dimension
* (LDPT,max(min(MVAL(j),NVAL(j))))
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The number of entries in WORK. This must be at least
* 3(M+N) and M(M + max(M,N,k) + 1) + N*min(M,N) for all
* pairs (M,N)=(MM(j),NN(j))
*
* IWORK (workspace) INTEGER array, dimension at least 8*min(M,N)
*
* NOUT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns IINFO not equal to 0.)
*
* INFO (output) INTEGER
* If 0, then everything ran OK.
* -1: NSIZES < 0
* -2: Some MM(j) < 0
* -3: Some NN(j) < 0
* -4: NTYPES < 0
* -6: NRHS < 0
* -8: THRESH < 0
* -11: LDA < 1 or LDA < MMAX, where MMAX is max( MM(j) ).
* -17: LDB < 1 or LDB < MMAX.
* -21: LDQ < 1 or LDQ < MMAX.
* -23: LDPT< 1 or LDPT< MNMAX.
* -27: LWORK too small.
* If DLATMR, SLATMS, DGEBRD, DORGBR, or DBDSQR,
* returns an error code, the
* absolute value of it is returned.
*
*-----------------------------------------------------------------------
*
* Some Local Variables and Parameters:
* ---- ----- --------- --- ----------
*
* ZERO, ONE Real 0 and 1.
* MAXTYP The number of types defined.
* NTEST The number of tests performed, or which can
* be performed so far, for the current matrix.
* MMAX Largest value in NN.
* NMAX Largest value in NN.
* MNMIN min(MM(j), NN(j)) (the dimension of the bidiagonal
* matrix.)
* MNMAX The maximum value of MNMIN for j=1,...,NSIZES.
* NFAIL The number of tests which have exceeded THRESH
* COND, IMODE Values to be passed to the matrix generators.
* ANORM Norm of A; passed to matrix generators.
*
* OVFL, UNFL Overflow and underflow thresholds.
* RTOVFL, RTUNFL Square roots of the previous 2 values.
* ULP, ULPINV Finest relative precision and its inverse.
*
* The following four arrays decode JTYPE:
* KTYPE(j) The general type (1-10) for type "j".
* KMODE(j) The MODE value to be passed to the matrix
* generator for type "j".
* KMAGN(j) The order of magnitude ( O(1),
* O(overflow^(1/2) ), O(underflow^(1/2) )
*
* ======================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, HALF
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ HALF = 0.5D0 )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 16 )
* ..
* .. Local Scalars ..
LOGICAL BADMM, BADNN, BIDIAG
CHARACTER UPLO
CHARACTER*3 PATH
INTEGER I, IINFO, IMODE, ITYPE, J, JCOL, JSIZE, JTYPE,
$ LOG2UI, M, MINWRK, MMAX, MNMAX, MNMIN, MQ,
$ MTYPES, N, NFAIL, NMAX, NTEST
DOUBLE PRECISION AMNINV, ANORM, COND, OVFL, RTOVFL, RTUNFL,
$ TEMP1, TEMP2, ULP, ULPINV, UNFL
* ..
* .. Local Arrays ..
INTEGER IDUM( 1 ), IOLDSD( 4 ), KMAGN( MAXTYP ),
$ KMODE( MAXTYP ), KTYPE( MAXTYP )
DOUBLE PRECISION DUM( 1 ), DUMMA( 1 ), RESULT( 19 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLARND
EXTERNAL DLAMCH, DLARND
* ..
* .. External Subroutines ..
EXTERNAL ALASUM, DBDSDC, DBDSQR, DBDT01, DBDT02, DBDT03,
$ DCOPY, DGEBRD, DGEMM, DLABAD, DLACPY, DLAHD2,
$ DLASET, DLATMR, DLATMS, DORGBR, DORT01, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, EXP, INT, LOG, MAX, MIN, SQRT
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA KTYPE / 1, 2, 5*4, 5*6, 3*9, 10 /
DATA KMAGN / 2*1, 3*1, 2, 3, 3*1, 2, 3, 1, 2, 3, 0 /
DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
$ 0, 0, 0 /
* ..
* .. Executable Statements ..
*
* Check for errors
*
INFO = 0
*
BADMM = .FALSE.
BADNN = .FALSE.
MMAX = 1
NMAX = 1
MNMAX = 1
MINWRK = 1
DO 10 J = 1, NSIZES
MMAX = MAX( MMAX, MVAL( J ) )
IF( MVAL( J ).LT.0 )
$ BADMM = .TRUE.
NMAX = MAX( NMAX, NVAL( J ) )
IF( NVAL( J ).LT.0 )
$ BADNN = .TRUE.
MNMAX = MAX( MNMAX, MIN( MVAL( J ), NVAL( J ) ) )
MINWRK = MAX( MINWRK, 3*( MVAL( J )+NVAL( J ) ),
$ MVAL( J )*( MVAL( J )+MAX( MVAL( J ), NVAL( J ),
$ NRHS )+1 )+NVAL( J )*MIN( NVAL( J ), MVAL( J ) ) )
10 CONTINUE
*
* Check for errors
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADMM ) THEN
INFO = -2
ELSE IF( BADNN ) THEN
INFO = -3
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -4
ELSE IF( NRHS.LT.0 ) THEN
INFO = -6
ELSE IF( LDA.LT.MMAX ) THEN
INFO = -11
ELSE IF( LDX.LT.MMAX ) THEN
INFO = -17
ELSE IF( LDQ.LT.MMAX ) THEN
INFO = -21
ELSE IF( LDPT.LT.MNMAX ) THEN
INFO = -23
ELSE IF( MINWRK.GT.LWORK ) THEN
INFO = -27
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DCHKBD', -INFO )
RETURN
END IF
*
* Initialize constants
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'BD'
NFAIL = 0
NTEST = 0
UNFL = DLAMCH( 'Safe minimum' )
OVFL = DLAMCH( 'Overflow' )
CALL DLABAD( UNFL, OVFL )
ULP = DLAMCH( 'Precision' )
ULPINV = ONE / ULP
LOG2UI = INT( LOG( ULPINV ) / LOG( TWO ) )
RTUNFL = SQRT( UNFL )
RTOVFL = SQRT( OVFL )
INFOT = 0
*
* Loop over sizes, types
*
DO 200 JSIZE = 1, NSIZES
M = MVAL( JSIZE )
N = NVAL( JSIZE )
MNMIN = MIN( M, N )
AMNINV = ONE / MAX( M, N, 1 )
*
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
DO 190 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 190
*
DO 20 J = 1, 4
IOLDSD( J ) = ISEED( J )
20 CONTINUE
*
DO 30 J = 1, 14
RESULT( J ) = -ONE
30 CONTINUE
*
UPLO = ' '
*
* Compute "A"
*
* Control parameters:
*
* KMAGN KMODE KTYPE
* =1 O(1) clustered 1 zero
* =2 large clustered 2 identity
* =3 small exponential (none)
* =4 arithmetic diagonal, (w/ eigenvalues)
* =5 random symmetric, w/ eigenvalues
* =6 nonsymmetric, w/ singular values
* =7 random diagonal
* =8 random symmetric
* =9 random nonsymmetric
* =10 random bidiagonal (log. distrib.)
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 100
*
ITYPE = KTYPE( JTYPE )
IMODE = KMODE( JTYPE )
*
* Compute norm
*
GO TO ( 40, 50, 60 )KMAGN( JTYPE )
*
40 CONTINUE
ANORM = ONE
GO TO 70
*
50 CONTINUE
ANORM = ( RTOVFL*ULP )*AMNINV
GO TO 70
*
60 CONTINUE
ANORM = RTUNFL*MAX( M, N )*ULPINV
GO TO 70
*
70 CONTINUE
*
CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
IINFO = 0
COND = ULPINV
*
BIDIAG = .FALSE.
IF( ITYPE.EQ.1 ) THEN
*
* Zero matrix
*
IINFO = 0
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Identity
*
DO 80 JCOL = 1, MNMIN
A( JCOL, JCOL ) = ANORM
80 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Diagonal Matrix, [Eigen]values Specified
*
CALL DLATMS( MNMIN, MNMIN, 'S', ISEED, 'N', WORK, IMODE,
$ COND, ANORM, 0, 0, 'N', A, LDA,
$ WORK( MNMIN+1 ), IINFO )
*
ELSE IF( ITYPE.EQ.5 ) THEN
*
* Symmetric, eigenvalues specified
*
CALL DLATMS( MNMIN, MNMIN, 'S', ISEED, 'S', WORK, IMODE,
$ COND, ANORM, M, N, 'N', A, LDA,
$ WORK( MNMIN+1 ), IINFO )
*
ELSE IF( ITYPE.EQ.6 ) THEN
*
* Nonsymmetric, singular values specified
*
CALL DLATMS( M, N, 'S', ISEED, 'N', WORK, IMODE, COND,
$ ANORM, M, N, 'N', A, LDA, WORK( MNMIN+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.7 ) THEN
*
* Diagonal, random entries
*
CALL DLATMR( MNMIN, MNMIN, 'S', ISEED, 'N', WORK, 6, ONE,
$ ONE, 'T', 'N', WORK( MNMIN+1 ), 1, ONE,
$ WORK( 2*MNMIN+1 ), 1, ONE, 'N', IWORK, 0, 0,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.8 ) THEN
*
* Symmetric, random entries
*
CALL DLATMR( MNMIN, MNMIN, 'S', ISEED, 'S', WORK, 6, ONE,
$ ONE, 'T', 'N', WORK( MNMIN+1 ), 1, ONE,
$ WORK( M+MNMIN+1 ), 1, ONE, 'N', IWORK, M, N,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.9 ) THEN
*
* Nonsymmetric, random entries
*
CALL DLATMR( M, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( MNMIN+1 ), 1, ONE,
$ WORK( M+MNMIN+1 ), 1, ONE, 'N', IWORK, M, N,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.10 ) THEN
*
* Bidiagonal, random entries
*
TEMP1 = -TWO*LOG( ULP )
DO 90 J = 1, MNMIN
BD( J ) = EXP( TEMP1*DLARND( 2, ISEED ) )
IF( J.LT.MNMIN )
$ BE( J ) = EXP( TEMP1*DLARND( 2, ISEED ) )
90 CONTINUE
*
IINFO = 0
BIDIAG = .TRUE.
IF( M.GE.N ) THEN
UPLO = 'U'
ELSE
UPLO = 'L'
END IF
ELSE
IINFO = 1
END IF
*
IF( IINFO.EQ.0 ) THEN
*
* Generate Right-Hand Side
*
IF( BIDIAG ) THEN
CALL DLATMR( MNMIN, NRHS, 'S', ISEED, 'N', WORK, 6,
$ ONE, ONE, 'T', 'N', WORK( MNMIN+1 ), 1,
$ ONE, WORK( 2*MNMIN+1 ), 1, ONE, 'N',
$ IWORK, MNMIN, NRHS, ZERO, ONE, 'NO', Y,
$ LDX, IWORK, IINFO )
ELSE
CALL DLATMR( M, NRHS, 'S', ISEED, 'N', WORK, 6, ONE,
$ ONE, 'T', 'N', WORK( M+1 ), 1, ONE,
$ WORK( 2*M+1 ), 1, ONE, 'N', IWORK, M,
$ NRHS, ZERO, ONE, 'NO', X, LDX, IWORK,
$ IINFO )
END IF
END IF
*
* Error Exit
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )'Generator', IINFO, M, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
100 CONTINUE
*
* Call DGEBRD and DORGBR to compute B, Q, and P, do tests.
*
IF( .NOT.BIDIAG ) THEN
*
* Compute transformations to reduce A to bidiagonal form:
* B := Q' * A * P.
*
CALL DLACPY( ' ', M, N, A, LDA, Q, LDQ )
CALL DGEBRD( M, N, Q, LDQ, BD, BE, WORK, WORK( MNMIN+1 ),
$ WORK( 2*MNMIN+1 ), LWORK-2*MNMIN, IINFO )
*
* Check error code from DGEBRD.
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )'DGEBRD', IINFO, M, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
CALL DLACPY( ' ', M, N, Q, LDQ, PT, LDPT )
IF( M.GE.N ) THEN
UPLO = 'U'
ELSE
UPLO = 'L'
END IF
*
* Generate Q
*
MQ = M
IF( NRHS.LE.0 )
$ MQ = MNMIN
CALL DORGBR( 'Q', M, MQ, N, Q, LDQ, WORK,
$ WORK( 2*MNMIN+1 ), LWORK-2*MNMIN, IINFO )
*
* Check error code from DORGBR.
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )'DORGBR(Q)', IINFO, M, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
* Generate P'
*
CALL DORGBR( 'P', MNMIN, N, M, PT, LDPT, WORK( MNMIN+1 ),
$ WORK( 2*MNMIN+1 ), LWORK-2*MNMIN, IINFO )
*
* Check error code from DORGBR.
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )'DORGBR(P)', IINFO, M, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
* Apply Q' to an M by NRHS matrix X: Y := Q' * X.
*
CALL DGEMM( 'Transpose', 'No transpose', M, NRHS, M, ONE,
$ Q, LDQ, X, LDX, ZERO, Y, LDX )
*
* Test 1: Check the decomposition A := Q * B * PT
* 2: Check the orthogonality of Q
* 3: Check the orthogonality of PT
*
CALL DBDT01( M, N, 1, A, LDA, Q, LDQ, BD, BE, PT, LDPT,
$ WORK, RESULT( 1 ) )
CALL DORT01( 'Columns', M, MQ, Q, LDQ, WORK, LWORK,
$ RESULT( 2 ) )
CALL DORT01( 'Rows', MNMIN, N, PT, LDPT, WORK, LWORK,
$ RESULT( 3 ) )
END IF
*
* Use DBDSQR to form the SVD of the bidiagonal matrix B:
* B := U * S1 * VT, and compute Z = U' * Y.
*
CALL DCOPY( MNMIN, BD, 1, S1, 1 )
IF( MNMIN.GT.0 )
$ CALL DCOPY( MNMIN-1, BE, 1, WORK, 1 )
CALL DLACPY( ' ', M, NRHS, Y, LDX, Z, LDX )
CALL DLASET( 'Full', MNMIN, MNMIN, ZERO, ONE, U, LDPT )
CALL DLASET( 'Full', MNMIN, MNMIN, ZERO, ONE, VT, LDPT )
*
CALL DBDSQR( UPLO, MNMIN, MNMIN, MNMIN, NRHS, S1, WORK, VT,
$ LDPT, U, LDPT, Z, LDX, WORK( MNMIN+1 ), IINFO )
*
* Check error code from DBDSQR.
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )'DBDSQR(vects)', IINFO, M, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 4 ) = ULPINV
GO TO 170
END IF
END IF
*
* Use DBDSQR to compute only the singular values of the
* bidiagonal matrix B; U, VT, and Z should not be modified.
*
CALL DCOPY( MNMIN, BD, 1, S2, 1 )
IF( MNMIN.GT.0 )
$ CALL DCOPY( MNMIN-1, BE, 1, WORK, 1 )
*
CALL DBDSQR( UPLO, MNMIN, 0, 0, 0, S2, WORK, VT, LDPT, U,
$ LDPT, Z, LDX, WORK( MNMIN+1 ), IINFO )
*
* Check error code from DBDSQR.
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )'DBDSQR(values)', IINFO, M, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 9 ) = ULPINV
GO TO 170
END IF
END IF
*
* Test 4: Check the decomposition B := U * S1 * VT
* 5: Check the computation Z := U' * Y
* 6: Check the orthogonality of U
* 7: Check the orthogonality of VT
*
CALL DBDT03( UPLO, MNMIN, 1, BD, BE, U, LDPT, S1, VT, LDPT,
$ WORK, RESULT( 4 ) )
CALL DBDT02( MNMIN, NRHS, Y, LDX, Z, LDX, U, LDPT, WORK,
$ RESULT( 5 ) )
CALL DORT01( 'Columns', MNMIN, MNMIN, U, LDPT, WORK, LWORK,
$ RESULT( 6 ) )
CALL DORT01( 'Rows', MNMIN, MNMIN, VT, LDPT, WORK, LWORK,
$ RESULT( 7 ) )
*
* Test 8: Check that the singular values are sorted in
* non-increasing order and are non-negative
*
RESULT( 8 ) = ZERO
DO 110 I = 1, MNMIN - 1
IF( S1( I ).LT.S1( I+1 ) )
$ RESULT( 8 ) = ULPINV
IF( S1( I ).LT.ZERO )
$ RESULT( 8 ) = ULPINV
110 CONTINUE
IF( MNMIN.GE.1 ) THEN
IF( S1( MNMIN ).LT.ZERO )
$ RESULT( 8 ) = ULPINV
END IF
*
* Test 9: Compare DBDSQR with and without singular vectors
*
TEMP2 = ZERO
*
DO 120 J = 1, MNMIN
TEMP1 = ABS( S1( J )-S2( J ) ) /
$ MAX( SQRT( UNFL )*MAX( S1( 1 ), ONE ),
$ ULP*MAX( ABS( S1( J ) ), ABS( S2( J ) ) ) )
TEMP2 = MAX( TEMP1, TEMP2 )
120 CONTINUE
*
RESULT( 9 ) = TEMP2
*
* Test 10: Sturm sequence test of singular values
* Go up by factors of two until it succeeds
*
TEMP1 = THRESH*( HALF-ULP )
*
DO 130 J = 0, LOG2UI
* CALL DSVDCH( MNMIN, BD, BE, S1, TEMP1, IINFO )
IF( IINFO.EQ.0 )
$ GO TO 140
TEMP1 = TEMP1*TWO
130 CONTINUE
*
140 CONTINUE
RESULT( 10 ) = TEMP1
*
* Use DBDSQR to form the decomposition A := (QU) S (VT PT)
* from the bidiagonal form A := Q B PT.
*
IF( .NOT.BIDIAG ) THEN
CALL DCOPY( MNMIN, BD, 1, S2, 1 )
IF( MNMIN.GT.0 )
$ CALL DCOPY( MNMIN-1, BE, 1, WORK, 1 )
*
CALL DBDSQR( UPLO, MNMIN, N, M, NRHS, S2, WORK, PT, LDPT,
$ Q, LDQ, Y, LDX, WORK( MNMIN+1 ), IINFO )
*
* Test 11: Check the decomposition A := Q*U * S2 * VT*PT
* 12: Check the computation Z := U' * Q' * X
* 13: Check the orthogonality of Q*U
* 14: Check the orthogonality of VT*PT
*
CALL DBDT01( M, N, 0, A, LDA, Q, LDQ, S2, DUMMA, PT,
$ LDPT, WORK, RESULT( 11 ) )
CALL DBDT02( M, NRHS, X, LDX, Y, LDX, Q, LDQ, WORK,
$ RESULT( 12 ) )
CALL DORT01( 'Columns', M, MQ, Q, LDQ, WORK, LWORK,
$ RESULT( 13 ) )
CALL DORT01( 'Rows', MNMIN, N, PT, LDPT, WORK, LWORK,
$ RESULT( 14 ) )
END IF
*
* Use DBDSDC to form the SVD of the bidiagonal matrix B:
* B := U * S1 * VT
*
CALL DCOPY( MNMIN, BD, 1, S1, 1 )
IF( MNMIN.GT.0 )
$ CALL DCOPY( MNMIN-1, BE, 1, WORK, 1 )
CALL DLASET( 'Full', MNMIN, MNMIN, ZERO, ONE, U, LDPT )
CALL DLASET( 'Full', MNMIN, MNMIN, ZERO, ONE, VT, LDPT )
*
CALL DBDSDC( UPLO, 'I', MNMIN, S1, WORK, U, LDPT, VT, LDPT,
$ DUM, IDUM, WORK( MNMIN+1 ), IWORK, IINFO )
*
* Check error code from DBDSDC.
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )'DBDSDC(vects)', IINFO, M, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 15 ) = ULPINV
GO TO 170
END IF
END IF
*
* Use DBDSDC to compute only the singular values of the
* bidiagonal matrix B; U and VT should not be modified.
*
CALL DCOPY( MNMIN, BD, 1, S2, 1 )
IF( MNMIN.GT.0 )
$ CALL DCOPY( MNMIN-1, BE, 1, WORK, 1 )
*
CALL DBDSDC( UPLO, 'N', MNMIN, S2, WORK, DUM, 1, DUM, 1,
$ DUM, IDUM, WORK( MNMIN+1 ), IWORK, IINFO )
*
* Check error code from DBDSDC.
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9998 )'DBDSDC(values)', IINFO, M, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 18 ) = ULPINV
GO TO 170
END IF
END IF
*
* Test 15: Check the decomposition B := U * S1 * VT
* 16: Check the orthogonality of U
* 17: Check the orthogonality of VT
*
CALL DBDT03( UPLO, MNMIN, 1, BD, BE, U, LDPT, S1, VT, LDPT,
$ WORK, RESULT( 15 ) )
CALL DORT01( 'Columns', MNMIN, MNMIN, U, LDPT, WORK, LWORK,
$ RESULT( 16 ) )
CALL DORT01( 'Rows', MNMIN, MNMIN, VT, LDPT, WORK, LWORK,
$ RESULT( 17 ) )
*
* Test 18: Check that the singular values are sorted in
* non-increasing order and are non-negative
*
RESULT( 18 ) = ZERO
DO 150 I = 1, MNMIN - 1
IF( S1( I ).LT.S1( I+1 ) )
$ RESULT( 18 ) = ULPINV
IF( S1( I ).LT.ZERO )
$ RESULT( 18 ) = ULPINV
150 CONTINUE
IF( MNMIN.GE.1 ) THEN
IF( S1( MNMIN ).LT.ZERO )
$ RESULT( 18 ) = ULPINV
END IF
*
* Test 19: Compare DBDSQR with and without singular vectors
*
TEMP2 = ZERO
*
DO 160 J = 1, MNMIN
TEMP1 = ABS( S1( J )-S2( J ) ) /
$ MAX( SQRT( UNFL )*MAX( S1( 1 ), ONE ),
$ ULP*MAX( ABS( S1( 1 ) ), ABS( S2( 1 ) ) ) )
TEMP2 = MAX( TEMP1, TEMP2 )
160 CONTINUE
*
RESULT( 19 ) = TEMP2
*
* End of Loop -- Check for RESULT(j) > THRESH
*
170 CONTINUE
DO 180 J = 1, 19
IF( RESULT( J ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 )
$ CALL DLAHD2( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )M, N, JTYPE, IOLDSD, J,
$ RESULT( J )
NFAIL = NFAIL + 1
END IF
180 CONTINUE
IF( .NOT.BIDIAG ) THEN
NTEST = NTEST + 19
ELSE
NTEST = NTEST + 5
END IF
*
190 CONTINUE
200 CONTINUE
*
* Summary
*
CALL ALASUM( PATH, NOUT, NFAIL, NTEST, 0 )
*
RETURN
*
* End of DCHKBD
*
9999 FORMAT( ' M=', I5, ', N=', I5, ', type ', I2, ', seed=',
$ 4( I4, ',' ), ' test(', I2, ')=', G11.4 )
9998 FORMAT( ' DCHKBD: ', A, ' returned INFO=', I6, '.', / 9X, 'M=',
$ I6, ', N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ),
$ I5, ')' )
*
END
SUBROUTINE DCHKBK( NIN, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER NIN, NOUT
* ..
*
* Purpose
* =======
*
* DCHKBK tests DGEBAK, a routine for backward transformation of
* the computed right or left eigenvectors if the orginal matrix
* was preprocessed by balance subroutine DGEBAL.
*
* Arguments
* =========
*
* NIN (input) INTEGER
* The logical unit number for input. NIN > 0.
*
* NOUT (input) INTEGER
* The logical unit number for output. NOUT > 0.
*
* ======================================================================
*
* .. Parameters ..
INTEGER LDE
PARAMETER ( LDE = 20 )
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, IHI, ILO, INFO, J, KNT, N, NINFO
DOUBLE PRECISION EPS, RMAX, SAFMIN, VMAX, X
* ..
* .. Local Arrays ..
INTEGER LMAX( 2 )
DOUBLE PRECISION E( LDE, LDE ), EIN( LDE, LDE ), SCALE( LDE )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DGEBAK
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
LMAX( 1 ) = 0
LMAX( 2 ) = 0
NINFO = 0
KNT = 0
RMAX = ZERO
EPS = DLAMCH( 'E' )
SAFMIN = DLAMCH( 'S' )
*
10 CONTINUE
*
READ( NIN, FMT = * )N, ILO, IHI
IF( N.EQ.0 )
$ GO TO 60
*
READ( NIN, FMT = * )( SCALE( I ), I = 1, N )
DO 20 I = 1, N
READ( NIN, FMT = * )( E( I, J ), J = 1, N )
20 CONTINUE
*
DO 30 I = 1, N
READ( NIN, FMT = * )( EIN( I, J ), J = 1, N )
30 CONTINUE
*
KNT = KNT + 1
CALL DGEBAK( 'B', 'R', N, ILO, IHI, SCALE, N, E, LDE, INFO )
*
IF( INFO.NE.0 ) THEN
NINFO = NINFO + 1
LMAX( 1 ) = KNT
END IF
*
VMAX = ZERO
DO 50 I = 1, N
DO 40 J = 1, N
X = ABS( E( I, J )-EIN( I, J ) ) / EPS
IF( ABS( E( I, J ) ).GT.SAFMIN )
$ X = X / ABS( E( I, J ) )
VMAX = MAX( VMAX, X )
40 CONTINUE
50 CONTINUE
*
IF( VMAX.GT.RMAX ) THEN
LMAX( 2 ) = KNT
RMAX = VMAX
END IF
*
GO TO 10
*
60 CONTINUE
*
WRITE( NOUT, FMT = 9999 )
9999 FORMAT( 1X, '.. test output of DGEBAK .. ' )
*
WRITE( NOUT, FMT = 9998 )RMAX
9998 FORMAT( 1X, 'value of largest test error = ', D12.3 )
WRITE( NOUT, FMT = 9997 )LMAX( 1 )
9997 FORMAT( 1X, 'example number where info is not zero = ', I4 )
WRITE( NOUT, FMT = 9996 )LMAX( 2 )
9996 FORMAT( 1X, 'example number having largest error = ', I4 )
WRITE( NOUT, FMT = 9995 )NINFO
9995 FORMAT( 1X, 'number of examples where info is not 0 = ', I4 )
WRITE( NOUT, FMT = 9994 )KNT
9994 FORMAT( 1X, 'total number of examples tested = ', I4 )
*
RETURN
*
* End of DCHKBK
*
END
SUBROUTINE DCHKBL( NIN, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER NIN, NOUT
* ..
*
* Purpose
* =======
*
* DCHKBL tests DGEBAL, a routine for balancing a general real
* matrix and isolating some of its eigenvalues.
*
* Arguments
* =========
*
* NIN (input) INTEGER
* The logical unit number for input. NIN > 0.
*
* NOUT (input) INTEGER
* The logical unit number for output. NOUT > 0.
*
* ======================================================================
*
* .. Parameters ..
INTEGER LDA
PARAMETER ( LDA = 20 )
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, IHI, IHIIN, ILO, ILOIN, INFO, J, KNT, N,
$ NINFO
DOUBLE PRECISION ANORM, MEPS, RMAX, SFMIN, TEMP, VMAX
* ..
* .. Local Arrays ..
INTEGER LMAX( 3 )
DOUBLE PRECISION A( LDA, LDA ), AIN( LDA, LDA ), DUMMY( 1 ),
$ SCALE( LDA ), SCALIN( LDA )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DGEBAL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
LMAX( 1 ) = 0
LMAX( 2 ) = 0
LMAX( 3 ) = 0
NINFO = 0
KNT = 0
RMAX = ZERO
VMAX = ZERO
SFMIN = DLAMCH( 'S' )
MEPS = DLAMCH( 'E' )
*
10 CONTINUE
*
READ( NIN, FMT = * )N
IF( N.EQ.0 )
$ GO TO 70
DO 20 I = 1, N
READ( NIN, FMT = * )( A( I, J ), J = 1, N )
20 CONTINUE
*
READ( NIN, FMT = * )ILOIN, IHIIN
DO 30 I = 1, N
READ( NIN, FMT = * )( AIN( I, J ), J = 1, N )
30 CONTINUE
READ( NIN, FMT = * )( SCALIN( I ), I = 1, N )
*
ANORM = DLANGE( 'M', N, N, A, LDA, DUMMY )
KNT = KNT + 1
*
CALL DGEBAL( 'B', N, A, LDA, ILO, IHI, SCALE, INFO )
*
IF( INFO.NE.0 ) THEN
NINFO = NINFO + 1
LMAX( 1 ) = KNT
END IF
*
IF( ILO.NE.ILOIN .OR. IHI.NE.IHIIN ) THEN
NINFO = NINFO + 1
LMAX( 2 ) = KNT
END IF
*
DO 50 I = 1, N
DO 40 J = 1, N
TEMP = MAX( A( I, J ), AIN( I, J ) )
TEMP = MAX( TEMP, SFMIN )
VMAX = MAX( VMAX, ABS( A( I, J )-AIN( I, J ) ) / TEMP )
40 CONTINUE
50 CONTINUE
*
DO 60 I = 1, N
TEMP = MAX( SCALE( I ), SCALIN( I ) )
TEMP = MAX( TEMP, SFMIN )
VMAX = MAX( VMAX, ABS( SCALE( I )-SCALIN( I ) ) / TEMP )
60 CONTINUE
*
*
IF( VMAX.GT.RMAX ) THEN
LMAX( 3 ) = KNT
RMAX = VMAX
END IF
*
GO TO 10
*
70 CONTINUE
*
WRITE( NOUT, FMT = 9999 )
9999 FORMAT( 1X, '.. test output of DGEBAL .. ' )
*
WRITE( NOUT, FMT = 9998 )RMAX
9998 FORMAT( 1X, 'value of largest test error = ', D12.3 )
WRITE( NOUT, FMT = 9997 )LMAX( 1 )
9997 FORMAT( 1X, 'example number where info is not zero = ', I4 )
WRITE( NOUT, FMT = 9996 )LMAX( 2 )
9996 FORMAT( 1X, 'example number where ILO or IHI wrong = ', I4 )
WRITE( NOUT, FMT = 9995 )LMAX( 3 )
9995 FORMAT( 1X, 'example number having largest error = ', I4 )
WRITE( NOUT, FMT = 9994 )NINFO
9994 FORMAT( 1X, 'number of examples where info is not 0 = ', I4 )
WRITE( NOUT, FMT = 9993 )KNT
9993 FORMAT( 1X, 'total number of examples tested = ', I4 )
*
RETURN
*
* End of DCHKBL
*
END
SUBROUTINE DCHKEC( THRESH, TSTERR, NIN, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTERR
INTEGER NIN, NOUT
DOUBLE PRECISION THRESH
* ..
*
* Purpose
* =======
*
* DCHKEC tests eigen- condition estimation routines
* DLALN2, DLASY2, DLANV2, DLAQTR, DLAEXC,
* DTRSYL, DTREXC, DTRSNA, DTRSEN
*
* In all cases, the routine runs through a fixed set of numerical
* examples, subjects them to various tests, and compares the test
* results to a threshold THRESH. In addition, DTREXC, DTRSNA and DTRSEN
* are tested by reading in precomputed examples from a file (on input
* unit NIN). Output is written to output unit NOUT.
*
* Arguments
* =========
*
* THRESH (input) DOUBLE PRECISION
* Threshold for residual tests. A computed test ratio passes
* the threshold if it is less than THRESH.
*
* TSTERR (input) LOGICAL
* Flag that indicates whether error exits are to be tested.
*
* NIN (input) INTEGER
* The logical unit number for input.
*
* NOUT (input) INTEGER
* The logical unit number for output.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL OK
CHARACTER*3 PATH
INTEGER KLAEXC, KLALN2, KLANV2, KLAQTR, KLASY2, KTREXC,
$ KTRSEN, KTRSNA, KTRSYL, LLAEXC, LLALN2, LLANV2,
$ LLAQTR, LLASY2, LTREXC, LTRSYL, NLANV2, NLAQTR,
$ NLASY2, NTESTS, NTRSYL
DOUBLE PRECISION EPS, RLAEXC, RLALN2, RLANV2, RLAQTR, RLASY2,
$ RTREXC, RTRSYL, SFMIN
* ..
* .. Local Arrays ..
INTEGER LTRSEN( 3 ), LTRSNA( 3 ), NLAEXC( 2 ),
$ NLALN2( 2 ), NTREXC( 3 ), NTRSEN( 3 ),
$ NTRSNA( 3 )
DOUBLE PRECISION RTRSEN( 3 ), RTRSNA( 3 )
* ..
* .. External Subroutines ..
EXTERNAL DERREC, DGET31, DGET32, DGET33, DGET34, DGET35,
$ DGET36, DGET37, DGET38, DGET39
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Executable Statements ..
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'EC'
EPS = DLAMCH( 'P' )
SFMIN = DLAMCH( 'S' )
*
* Print header information
*
WRITE( NOUT, FMT = 9989 )
WRITE( NOUT, FMT = 9988 )EPS, SFMIN
WRITE( NOUT, FMT = 9987 )THRESH
*
* Test error exits if TSTERR is .TRUE.
*
IF( TSTERR )
$ CALL DERREC( PATH, NOUT )
*
OK = .TRUE.
CALL DGET31( RLALN2, LLALN2, NLALN2, KLALN2 )
IF( RLALN2.GT.THRESH .OR. NLALN2( 1 ).NE.0 ) THEN
OK = .FALSE.
WRITE( NOUT, FMT = 9999 )RLALN2, LLALN2, NLALN2, KLALN2
END IF
*
CALL DGET32( RLASY2, LLASY2, NLASY2, KLASY2 )
IF( RLASY2.GT.THRESH ) THEN
OK = .FALSE.
WRITE( NOUT, FMT = 9998 )RLASY2, LLASY2, NLASY2, KLASY2
END IF
*
CALL DGET33( RLANV2, LLANV2, NLANV2, KLANV2 )
IF( RLANV2.GT.THRESH .OR. NLANV2.NE.0 ) THEN
OK = .FALSE.
WRITE( NOUT, FMT = 9997 )RLANV2, LLANV2, NLANV2, KLANV2
END IF
*
CALL DGET34( RLAEXC, LLAEXC, NLAEXC, KLAEXC )
IF( RLAEXC.GT.THRESH .OR. NLAEXC( 2 ).NE.0 ) THEN
OK = .FALSE.
WRITE( NOUT, FMT = 9996 )RLAEXC, LLAEXC, NLAEXC, KLAEXC
END IF
*
CALL DGET35( RTRSYL, LTRSYL, NTRSYL, KTRSYL )
IF( RTRSYL.GT.THRESH ) THEN
OK = .FALSE.
WRITE( NOUT, FMT = 9995 )RTRSYL, LTRSYL, NTRSYL, KTRSYL
END IF
*
CALL DGET36( RTREXC, LTREXC, NTREXC, KTREXC, NIN )
IF( RTREXC.GT.THRESH .OR. NTREXC( 3 ).GT.0 ) THEN
OK = .FALSE.
WRITE( NOUT, FMT = 9994 )RTREXC, LTREXC, NTREXC, KTREXC
END IF
*
CALL DGET37( RTRSNA, LTRSNA, NTRSNA, KTRSNA, NIN )
IF( RTRSNA( 1 ).GT.THRESH .OR. RTRSNA( 2 ).GT.THRESH .OR.
$ NTRSNA( 1 ).NE.0 .OR. NTRSNA( 2 ).NE.0 .OR. NTRSNA( 3 ).NE.0 )
$ THEN
OK = .FALSE.
WRITE( NOUT, FMT = 9993 )RTRSNA, LTRSNA, NTRSNA, KTRSNA
END IF
*
CALL DGET38( RTRSEN, LTRSEN, NTRSEN, KTRSEN, NIN )
IF( RTRSEN( 1 ).GT.THRESH .OR. RTRSEN( 2 ).GT.THRESH .OR.
$ NTRSEN( 1 ).NE.0 .OR. NTRSEN( 2 ).NE.0 .OR. NTRSEN( 3 ).NE.0 )
$ THEN
OK = .FALSE.
WRITE( NOUT, FMT = 9992 )RTRSEN, LTRSEN, NTRSEN, KTRSEN
END IF
*
CALL DGET39( RLAQTR, LLAQTR, NLAQTR, KLAQTR )
IF( RLAQTR.GT.THRESH ) THEN
OK = .FALSE.
WRITE( NOUT, FMT = 9991 )RLAQTR, LLAQTR, NLAQTR, KLAQTR
END IF
*
NTESTS = KLALN2 + KLASY2 + KLANV2 + KLAEXC + KTRSYL + KTREXC +
$ KTRSNA + KTRSEN + KLAQTR
IF( OK )
$ WRITE( NOUT, FMT = 9990 )PATH, NTESTS
*
RETURN
9999 FORMAT( ' Error in DLALN2: RMAX =', D12.3, / ' LMAX = ', I8, ' N',
$ 'INFO=', 2I8, ' KNT=', I8 )
9998 FORMAT( ' Error in DLASY2: RMAX =', D12.3, / ' LMAX = ', I8, ' N',
$ 'INFO=', I8, ' KNT=', I8 )
9997 FORMAT( ' Error in DLANV2: RMAX =', D12.3, / ' LMAX = ', I8, ' N',
$ 'INFO=', I8, ' KNT=', I8 )
9996 FORMAT( ' Error in DLAEXC: RMAX =', D12.3, / ' LMAX = ', I8, ' N',
$ 'INFO=', 2I8, ' KNT=', I8 )
9995 FORMAT( ' Error in DTRSYL: RMAX =', D12.3, / ' LMAX = ', I8, ' N',
$ 'INFO=', I8, ' KNT=', I8 )
9994 FORMAT( ' Error in DTREXC: RMAX =', D12.3, / ' LMAX = ', I8, ' N',
$ 'INFO=', 3I8, ' KNT=', I8 )
9993 FORMAT( ' Error in DTRSNA: RMAX =', 3D12.3, / ' LMAX = ', 3I8,
$ ' NINFO=', 3I8, ' KNT=', I8 )
9992 FORMAT( ' Error in DTRSEN: RMAX =', 3D12.3, / ' LMAX = ', 3I8,
$ ' NINFO=', 3I8, ' KNT=', I8 )
9991 FORMAT( ' Error in DLAQTR: RMAX =', D12.3, / ' LMAX = ', I8, ' N',
$ 'INFO=', I8, ' KNT=', I8 )
9990 FORMAT( / 1X, 'All tests for ', A3, ' routines passed the thresh',
$ 'old (', I6, ' tests run)' )
9989 FORMAT( ' Tests of the Nonsymmetric eigenproblem condition estim',
$ 'ation routines', / ' DLALN2, DLASY2, DLANV2, DLAEXC, DTRS',
$ 'YL, DTREXC, DTRSNA, DTRSEN, DLAQTR', / )
9988 FORMAT( ' Relative machine precision (EPS) = ', D16.6, / ' Safe ',
$ 'minimum (SFMIN) = ', D16.6, / )
9987 FORMAT( ' Routines pass computational tests if test ratio is les',
$ 's than', F8.2, / / )
*
* End of DCHKEC
*
END
PROGRAM DCHKEE
*
* -- LAPACK test routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* January 2007
*
* Purpose
* =======
*
* DCHKEE tests the DOUBLE PRECISION LAPACK subroutines for the matrix
* eigenvalue problem. The test paths in this version are
*
* NEP (Nonsymmetric Eigenvalue Problem):
* Test DGEHRD, DORGHR, DHSEQR, DTREVC, DHSEIN, and DORMHR
*
* SEP (Symmetric Eigenvalue Problem):
* Test DSYTRD, DORGTR, DSTEQR, DSTERF, DSTEIN, DSTEDC,
* and drivers DSYEV(X), DSBEV(X), DSPEV(X), DSTEV(X),
* DSYEVD, DSBEVD, DSPEVD, DSTEVD
*
* SVD (Singular Value Decomposition):
* Test DGEBRD, DORGBR, DBDSQR, DBDSDC
* and the drivers DGESVD, DGESDD
*
* DEV (Nonsymmetric Eigenvalue/eigenvector Driver):
* Test DGEEV
*
* DES (Nonsymmetric Schur form Driver):
* Test DGEES
*
* DVX (Nonsymmetric Eigenvalue/eigenvector Expert Driver):
* Test DGEEVX
*
* DSX (Nonsymmetric Schur form Expert Driver):
* Test DGEESX
*
* DGG (Generalized Nonsymmetric Eigenvalue Problem):
* Test DGGHRD, DGGBAL, DGGBAK, DHGEQZ, and DTGEVC
* and the driver routines DGEGS and DGEGV
*
* DGS (Generalized Nonsymmetric Schur form Driver):
* Test DGGES
*
* DGV (Generalized Nonsymmetric Eigenvalue/eigenvector Driver):
* Test DGGEV
*
* DGX (Generalized Nonsymmetric Schur form Expert Driver):
* Test DGGESX
*
* DXV (Generalized Nonsymmetric Eigenvalue/eigenvector Expert Driver):
* Test DGGEVX
*
* DSG (Symmetric Generalized Eigenvalue Problem):
* Test DSYGST, DSYGV, DSYGVD, DSYGVX, DSPGST, DSPGV, DSPGVD,
* DSPGVX, DSBGST, DSBGV, DSBGVD, and DSBGVX
*
* DSB (Symmetric Band Eigenvalue Problem):
* Test DSBTRD
*
* DBB (Band Singular Value Decomposition):
* Test DGBBRD
*
* DEC (Eigencondition estimation):
* Test DLALN2, DLASY2, DLAEQU, DLAEXC, DTRSYL, DTREXC, DTRSNA,
* DTRSEN, and DLAQTR
*
* DBL (Balancing a general matrix)
* Test DGEBAL
*
* DBK (Back transformation on a balanced matrix)
* Test DGEBAK
*
* DGL (Balancing a matrix pair)
* Test DGGBAL
*
* DGK (Back transformation on a matrix pair)
* Test DGGBAK
*
* GLM (Generalized Linear Regression Model):
* Tests DGGGLM
*
* GQR (Generalized QR and RQ factorizations):
* Tests DGGQRF and DGGRQF
*
* GSV (Generalized Singular Value Decomposition):
* Tests DGGSVD, DGGSVP, DTGSJA, DLAGS2, DLAPLL, and DLAPMT
*
* LSE (Constrained Linear Least Squares):
* Tests DGGLSE
*
* Each test path has a different set of inputs, but the data sets for
* the driver routines xEV, xES, xVX, and xSX can be concatenated in a
* single input file. The first line of input should contain one of the
* 3-character path names in columns 1-3. The number of remaining lines
* depends on what is found on the first line.
*
* The number of matrix types used in testing is often controllable from
* the input file. The number of matrix types for each path, and the
* test routine that describes them, is as follows:
*
* Path name(s) Types Test routine
*
* DHS or NEP 21 DCHKHS
* DST or SEP 21 DCHKST (routines)
* 18 DDRVST (drivers)
* DBD or SVD 16 DCHKBD (routines)
* 5 DDRVBD (drivers)
* DEV 21 DDRVEV
* DES 21 DDRVES
* DVX 21 DDRVVX
* DSX 21 DDRVSX
* DGG 26 DCHKGG (routines)
* 26 DDRVGG (drivers)
* DGS 26 DDRGES
* DGX 5 DDRGSX
* DGV 26 DDRGEV
* DXV 2 DDRGVX
* DSG 21 DDRVSG
* DSB 15 DCHKSB
* DBB 15 DCHKBB
* DEC - DCHKEC
* DBL - DCHKBL
* DBK - DCHKBK
* DGL - DCHKGL
* DGK - DCHKGK
* GLM 8 DCKGLM
* GQR 8 DCKGQR
* GSV 8 DCKGSV
* LSE 8 DCKLSE
*
*-----------------------------------------------------------------------
*
* NEP input file:
*
* line 2: NN, INTEGER
* Number of values of N.
*
* line 3: NVAL, INTEGER array, dimension (NN)
* The values for the matrix dimension N.
*
* line 4: NPARMS, INTEGER
* Number of values of the parameters NB, NBMIN, NX, NS, and
* MAXB.
*
* line 5: NBVAL, INTEGER array, dimension (NPARMS)
* The values for the blocksize NB.
*
* line 6: NBMIN, INTEGER array, dimension (NPARMS)
* The values for the minimum blocksize NBMIN.
*
* line 7: NXVAL, INTEGER array, dimension (NPARMS)
* The values for the crossover point NX.
*
* line 8: INMIN, INTEGER array, dimension (NPARMS)
* LAHQR vs TTQRE crossover point, >= 11
*
* line 9: INWIN, INTEGER array, dimension (NPARMS)
* recommended deflation window size
*
* line 10: INIBL, INTEGER array, dimension (NPARMS)
* nibble crossover point
*
* line 11: ISHFTS, INTEGER array, dimension (NPARMS)
* number of simultaneous shifts)
*
* line 12: IACC22, INTEGER array, dimension (NPARMS)
* select structured matrix multiply: 0, 1 or 2)
*
* line 13: THRESH
* Threshold value for the test ratios. Information will be
* printed about each test for which the test ratio is greater
* than or equal to the threshold. To have all of the test
* ratios printed, use THRESH = 0.0 .
*
* line 14: NEWSD, INTEGER
* A code indicating how to set the random number seed.
* = 0: Set the seed to a default value before each run
* = 1: Initialize the seed to a default value only before the
* first run
* = 2: Like 1, but use the seed values on the next line
*
* If line 14 was 2:
*
* line 15: INTEGER array, dimension (4)
* Four integer values for the random number seed.
*
* lines 15-EOF: The remaining lines occur in sets of 1 or 2 and allow
* the user to specify the matrix types. Each line contains
* a 3-character path name in columns 1-3, and the number
* of matrix types must be the first nonblank item in columns
* 4-80. If the number of matrix types is at least 1 but is
* less than the maximum number of possible types, a second
* line will be read to get the numbers of the matrix types to
* be used. For example,
* NEP 21
* requests all of the matrix types for the nonsymmetric
* eigenvalue problem, while
* NEP 4
* 9 10 11 12
* requests only matrices of type 9, 10, 11, and 12.
*
* The valid 3-character path names are 'NEP' or 'SHS' for the
* nonsymmetric eigenvalue routines.
*
*-----------------------------------------------------------------------
*
* SEP or DSG input file:
*
* line 2: NN, INTEGER
* Number of values of N.
*
* line 3: NVAL, INTEGER array, dimension (NN)
* The values for the matrix dimension N.
*
* line 4: NPARMS, INTEGER
* Number of values of the parameters NB, NBMIN, and NX.
*
* line 5: NBVAL, INTEGER array, dimension (NPARMS)
* The values for the blocksize NB.
*
* line 6: NBMIN, INTEGER array, dimension (NPARMS)
* The values for the minimum blocksize NBMIN.
*
* line 7: NXVAL, INTEGER array, dimension (NPARMS)
* The values for the crossover point NX.
*
* line 8: THRESH
* Threshold value for the test ratios. Information will be
* printed about each test for which the test ratio is greater
* than or equal to the threshold.
*
* line 9: TSTCHK, LOGICAL
* Flag indicating whether or not to test the LAPACK routines.
*
* line 10: TSTDRV, LOGICAL
* Flag indicating whether or not to test the driver routines.
*
* line 11: TSTERR, LOGICAL
* Flag indicating whether or not to test the error exits for
* the LAPACK routines and driver routines.
*
* line 12: NEWSD, INTEGER
* A code indicating how to set the random number seed.
* = 0: Set the seed to a default value before each run
* = 1: Initialize the seed to a default value only before the
* first run
* = 2: Like 1, but use the seed values on the next line
*
* If line 12 was 2:
*
* line 13: INTEGER array, dimension (4)
* Four integer values for the random number seed.
*
* lines 13-EOF: Lines specifying matrix types, as for NEP.
* The 3-character path names are 'SEP' or 'SST' for the
* symmetric eigenvalue routines and driver routines, and
* 'DSG' for the routines for the symmetric generalized
* eigenvalue problem.
*
*-----------------------------------------------------------------------
*
* SVD input file:
*
* line 2: NN, INTEGER
* Number of values of M and N.
*
* line 3: MVAL, INTEGER array, dimension (NN)
* The values for the matrix row dimension M.
*
* line 4: NVAL, INTEGER array, dimension (NN)
* The values for the matrix column dimension N.
*
* line 5: NPARMS, INTEGER
* Number of values of the parameter NB, NBMIN, NX, and NRHS.
*
* line 6: NBVAL, INTEGER array, dimension (NPARMS)
* The values for the blocksize NB.
*
* line 7: NBMIN, INTEGER array, dimension (NPARMS)
* The values for the minimum blocksize NBMIN.
*
* line 8: NXVAL, INTEGER array, dimension (NPARMS)
* The values for the crossover point NX.
*
* line 9: NSVAL, INTEGER array, dimension (NPARMS)
* The values for the number of right hand sides NRHS.
*
* line 10: THRESH
* Threshold value for the test ratios. Information will be
* printed about each test for which the test ratio is greater
* than or equal to the threshold.
*
* line 11: TSTCHK, LOGICAL
* Flag indicating whether or not to test the LAPACK routines.
*
* line 12: TSTDRV, LOGICAL
* Flag indicating whether or not to test the driver routines.
*
* line 13: TSTERR, LOGICAL
* Flag indicating whether or not to test the error exits for
* the LAPACK routines and driver routines.
*
* line 14: NEWSD, INTEGER
* A code indicating how to set the random number seed.
* = 0: Set the seed to a default value before each run
* = 1: Initialize the seed to a default value only before the
* first run
* = 2: Like 1, but use the seed values on the next line
*
* If line 14 was 2:
*
* line 15: INTEGER array, dimension (4)
* Four integer values for the random number seed.
*
* lines 15-EOF: Lines specifying matrix types, as for NEP.
* The 3-character path names are 'SVD' or 'SBD' for both the
* SVD routines and the SVD driver routines.
*
*-----------------------------------------------------------------------
*
* DEV and DES data files:
*
* line 1: 'DEV' or 'DES' in columns 1 to 3.
*
* line 2: NSIZES, INTEGER
* Number of sizes of matrices to use. Should be at least 0
* and at most 20. If NSIZES = 0, no testing is done
* (although the remaining 3 lines are still read).
*
* line 3: NN, INTEGER array, dimension(NSIZES)
* Dimensions of matrices to be tested.
*
* line 4: NB, NBMIN, NX, NS, NBCOL, INTEGERs
* These integer parameters determine how blocking is done
* (see ILAENV for details)
* NB : block size
* NBMIN : minimum block size
* NX : minimum dimension for blocking
* NS : number of shifts in xHSEQR
* NBCOL : minimum column dimension for blocking
*
* line 5: THRESH, REAL
* The test threshold against which computed residuals are
* compared. Should generally be in the range from 10. to 20.
* If it is 0., all test case data will be printed.
*
* line 6: TSTERR, LOGICAL
* Flag indicating whether or not to test the error exits.
*
* line 7: NEWSD, INTEGER
* A code indicating how to set the random number seed.
* = 0: Set the seed to a default value before each run
* = 1: Initialize the seed to a default value only before the
* first run
* = 2: Like 1, but use the seed values on the next line
*
* If line 7 was 2:
*
* line 8: INTEGER array, dimension (4)
* Four integer values for the random number seed.
*
* lines 9 and following: Lines specifying matrix types, as for NEP.
* The 3-character path name is 'DEV' to test SGEEV, or
* 'DES' to test SGEES.
*
*-----------------------------------------------------------------------
*
* The DVX data has two parts. The first part is identical to DEV,
* and the second part consists of test matrices with precomputed
* solutions.
*
* line 1: 'DVX' in columns 1-3.
*
* line 2: NSIZES, INTEGER
* If NSIZES = 0, no testing of randomly generated examples
* is done, but any precomputed examples are tested.
*
* line 3: NN, INTEGER array, dimension(NSIZES)
*
* line 4: NB, NBMIN, NX, NS, NBCOL, INTEGERs
*
* line 5: THRESH, REAL
*
* line 6: TSTERR, LOGICAL
*
* line 7: NEWSD, INTEGER
*
* If line 7 was 2:
*
* line 8: INTEGER array, dimension (4)
*
* lines 9 and following: The first line contains 'DVX' in columns 1-3
* followed by the number of matrix types, possibly with
* a second line to specify certain matrix types.
* If the number of matrix types = 0, no testing of randomly
* generated examples is done, but any precomputed examples
* are tested.
*
* remaining lines : Each matrix is stored on 1+2*N lines, where N is
* its dimension. The first line contains the dimension (a
* single integer). The next N lines contain the matrix, one
* row per line. The last N lines correspond to each
* eigenvalue. Each of these last N lines contains 4 real
* values: the real part of the eigenvalue, the imaginary
* part of the eigenvalue, the reciprocal condition number of
* the eigenvalues, and the reciprocal condition number of the
* eigenvector. The end of data is indicated by dimension N=0.
* Even if no data is to be tested, there must be at least one
* line containing N=0.
*
*-----------------------------------------------------------------------
*
* The DSX data is like DVX. The first part is identical to DEV, and the
* second part consists of test matrices with precomputed solutions.
*
* line 1: 'DSX' in columns 1-3.
*
* line 2: NSIZES, INTEGER
* If NSIZES = 0, no testing of randomly generated examples
* is done, but any precomputed examples are tested.
*
* line 3: NN, INTEGER array, dimension(NSIZES)
*
* line 4: NB, NBMIN, NX, NS, NBCOL, INTEGERs
*
* line 5: THRESH, REAL
*
* line 6: TSTERR, LOGICAL
*
* line 7: NEWSD, INTEGER
*
* If line 7 was 2:
*
* line 8: INTEGER array, dimension (4)
*
* lines 9 and following: The first line contains 'DSX' in columns 1-3
* followed by the number of matrix types, possibly with
* a second line to specify certain matrix types.
* If the number of matrix types = 0, no testing of randomly
* generated examples is done, but any precomputed examples
* are tested.
*
* remaining lines : Each matrix is stored on 3+N lines, where N is its
* dimension. The first line contains the dimension N and the
* dimension M of an invariant subspace. The second line
* contains M integers, identifying the eigenvalues in the
* invariant subspace (by their position in a list of
* eigenvalues ordered by increasing real part). The next N
* lines contain the matrix. The last line contains the
* reciprocal condition number for the average of the selected
* eigenvalues, and the reciprocal condition number for the
* corresponding right invariant subspace. The end of data is
* indicated by a line containing N=0 and M=0. Even if no data
* is to be tested, there must be at least one line containing
* N=0 and M=0.
*
*-----------------------------------------------------------------------
*
* DGG input file:
*
* line 2: NN, INTEGER
* Number of values of N.
*
* line 3: NVAL, INTEGER array, dimension (NN)
* The values for the matrix dimension N.
*
* line 4: NPARMS, INTEGER
* Number of values of the parameters NB, NBMIN, NS, MAXB, and
* NBCOL.
*
* line 5: NBVAL, INTEGER array, dimension (NPARMS)
* The values for the blocksize NB.
*
* line 6: NBMIN, INTEGER array, dimension (NPARMS)
* The values for NBMIN, the minimum row dimension for blocks.
*
* line 7: NSVAL, INTEGER array, dimension (NPARMS)
* The values for the number of shifts.
*
* line 8: MXBVAL, INTEGER array, dimension (NPARMS)
* The values for MAXB, used in determining minimum blocksize.
*
* line 9: NBCOL, INTEGER array, dimension (NPARMS)
* The values for NBCOL, the minimum column dimension for
* blocks.
*
* line 10: THRESH
* Threshold value for the test ratios. Information will be
* printed about each test for which the test ratio is greater
* than or equal to the threshold.
*
* line 11: TSTCHK, LOGICAL
* Flag indicating whether or not to test the LAPACK routines.
*
* line 12: TSTDRV, LOGICAL
* Flag indicating whether or not to test the driver routines.
*
* line 13: TSTERR, LOGICAL
* Flag indicating whether or not to test the error exits for
* the LAPACK routines and driver routines.
*
* line 14: NEWSD, INTEGER
* A code indicating how to set the random number seed.
* = 0: Set the seed to a default value before each run
* = 1: Initialize the seed to a default value only before the
* first run
* = 2: Like 1, but use the seed values on the next line
*
* If line 14 was 2:
*
* line 15: INTEGER array, dimension (4)
* Four integer values for the random number seed.
*
* lines 15-EOF: Lines specifying matrix types, as for NEP.
* The 3-character path name is 'DGG' for the generalized
* eigenvalue problem routines and driver routines.
*
*-----------------------------------------------------------------------
*
* DGS and DGV input files:
*
* line 1: 'DGS' or 'DGV' in columns 1 to 3.
*
* line 2: NN, INTEGER
* Number of values of N.
*
* line 3: NVAL, INTEGER array, dimension(NN)
* Dimensions of matrices to be tested.
*
* line 4: NB, NBMIN, NX, NS, NBCOL, INTEGERs
* These integer parameters determine how blocking is done
* (see ILAENV for details)
* NB : block size
* NBMIN : minimum block size
* NX : minimum dimension for blocking
* NS : number of shifts in xHGEQR
* NBCOL : minimum column dimension for blocking
*
* line 5: THRESH, REAL
* The test threshold against which computed residuals are
* compared. Should generally be in the range from 10. to 20.
* If it is 0., all test case data will be printed.
*
* line 6: TSTERR, LOGICAL
* Flag indicating whether or not to test the error exits.
*
* line 7: NEWSD, INTEGER
* A code indicating how to set the random number seed.
* = 0: Set the seed to a default value before each run
* = 1: Initialize the seed to a default value only before the
* first run
* = 2: Like 1, but use the seed values on the next line
*
* If line 17 was 2:
*
* line 7: INTEGER array, dimension (4)
* Four integer values for the random number seed.
*
* lines 7-EOF: Lines specifying matrix types, as for NEP.
* The 3-character path name is 'DGS' for the generalized
* eigenvalue problem routines and driver routines.
*
*-----------------------------------------------------------------------
*
* DXV input files:
*
* line 1: 'DXV' in columns 1 to 3.
*
* line 2: N, INTEGER
* Value of N.
*
* line 3: NB, NBMIN, NX, NS, NBCOL, INTEGERs
* These integer parameters determine how blocking is done
* (see ILAENV for details)
* NB : block size
* NBMIN : minimum block size
* NX : minimum dimension for blocking
* NS : number of shifts in xHGEQR
* NBCOL : minimum column dimension for blocking
*
* line 4: THRESH, REAL
* The test threshold against which computed residuals are
* compared. Should generally be in the range from 10. to 20.
* Information will be printed about each test for which the
* test ratio is greater than or equal to the threshold.
*
* line 5: TSTERR, LOGICAL
* Flag indicating whether or not to test the error exits for
* the LAPACK routines and driver routines.
*
* line 6: NEWSD, INTEGER
* A code indicating how to set the random number seed.
* = 0: Set the seed to a default value before each run
* = 1: Initialize the seed to a default value only before the
* first run
* = 2: Like 1, but use the seed values on the next line
*
* If line 6 was 2:
*
* line 7: INTEGER array, dimension (4)
* Four integer values for the random number seed.
*
* If line 2 was 0:
*
* line 7-EOF: Precomputed examples are tested.
*
* remaining lines : Each example is stored on 3+2*N lines, where N is
* its dimension. The first line contains the dimension (a
* single integer). The next N lines contain the matrix A, one
* row per line. The next N lines contain the matrix B. The
* next line contains the reciprocals of the eigenvalue
* condition numbers. The last line contains the reciprocals of
* the eigenvector condition numbers. The end of data is
* indicated by dimension N=0. Even if no data is to be tested,
* there must be at least one line containing N=0.
*
*-----------------------------------------------------------------------
*
* DGX input files:
*
* line 1: 'DGX' in columns 1 to 3.
*
* line 2: N, INTEGER
* Value of N.
*
* line 3: NB, NBMIN, NX, NS, NBCOL, INTEGERs
* These integer parameters determine how blocking is done
* (see ILAENV for details)
* NB : block size
* NBMIN : minimum block size
* NX : minimum dimension for blocking
* NS : number of shifts in xHGEQR
* NBCOL : minimum column dimension for blocking
*
* line 4: THRESH, REAL
* The test threshold against which computed residuals are
* compared. Should generally be in the range from 10. to 20.
* Information will be printed about each test for which the
* test ratio is greater than or equal to the threshold.
*
* line 5: TSTERR, LOGICAL
* Flag indicating whether or not to test the error exits for
* the LAPACK routines and driver routines.
*
* line 6: NEWSD, INTEGER
* A code indicating how to set the random number seed.
* = 0: Set the seed to a default value before each run
* = 1: Initialize the seed to a default value only before the
* first run
* = 2: Like 1, but use the seed values on the next line
*
* If line 6 was 2:
*
* line 7: INTEGER array, dimension (4)
* Four integer values for the random number seed.
*
* If line 2 was 0:
*
* line 7-EOF: Precomputed examples are tested.
*
* remaining lines : Each example is stored on 3+2*N lines, where N is
* its dimension. The first line contains the dimension (a
* single integer). The next line contains an integer k such
* that only the last k eigenvalues will be selected and appear
* in the leading diagonal blocks of $A$ and $B$. The next N
* lines contain the matrix A, one row per line. The next N
* lines contain the matrix B. The last line contains the
* reciprocal of the eigenvalue cluster condition number and the
* reciprocal of the deflating subspace (associated with the
* selected eigencluster) condition number. The end of data is
* indicated by dimension N=0. Even if no data is to be tested,
* there must be at least one line containing N=0.
*
*-----------------------------------------------------------------------
*
* DSB input file:
*
* line 2: NN, INTEGER
* Number of values of N.
*
* line 3: NVAL, INTEGER array, dimension (NN)
* The values for the matrix dimension N.
*
* line 4: NK, INTEGER
* Number of values of K.
*
* line 5: KVAL, INTEGER array, dimension (NK)
* The values for the matrix dimension K.
*
* line 6: THRESH
* Threshold value for the test ratios. Information will be
* printed about each test for which the test ratio is greater
* than or equal to the threshold.
*
* line 7: NEWSD, INTEGER
* A code indicating how to set the random number seed.
* = 0: Set the seed to a default value before each run
* = 1: Initialize the seed to a default value only before the
* first run
* = 2: Like 1, but use the seed values on the next line
*
* If line 7 was 2:
*
* line 8: INTEGER array, dimension (4)
* Four integer values for the random number seed.
*
* lines 8-EOF: Lines specifying matrix types, as for NEP.
* The 3-character path name is 'DSB'.
*
*-----------------------------------------------------------------------
*
* DBB input file:
*
* line 2: NN, INTEGER
* Number of values of M and N.
*
* line 3: MVAL, INTEGER array, dimension (NN)
* The values for the matrix row dimension M.
*
* line 4: NVAL, INTEGER array, dimension (NN)
* The values for the matrix column dimension N.
*
* line 4: NK, INTEGER
* Number of values of K.
*
* line 5: KVAL, INTEGER array, dimension (NK)
* The values for the matrix bandwidth K.
*
* line 6: NPARMS, INTEGER
* Number of values of the parameter NRHS
*
* line 7: NSVAL, INTEGER array, dimension (NPARMS)
* The values for the number of right hand sides NRHS.
*
* line 8: THRESH
* Threshold value for the test ratios. Information will be
* printed about each test for which the test ratio is greater
* than or equal to the threshold.
*
* line 9: NEWSD, INTEGER
* A code indicating how to set the random number seed.
* = 0: Set the seed to a default value before each run
* = 1: Initialize the seed to a default value only before the
* first run
* = 2: Like 1, but use the seed values on the next line
*
* If line 9 was 2:
*
* line 10: INTEGER array, dimension (4)
* Four integer values for the random number seed.
*
* lines 10-EOF: Lines specifying matrix types, as for SVD.
* The 3-character path name is 'DBB'.
*
*-----------------------------------------------------------------------
*
* DEC input file:
*
* line 2: THRESH, REAL
* Threshold value for the test ratios. Information will be
* printed about each test for which the test ratio is greater
* than or equal to the threshold.
*
* lines 3-EOF:
*
* Input for testing the eigencondition routines consists of a set of
* specially constructed test cases and their solutions. The data
* format is not intended to be modified by the user.
*
*-----------------------------------------------------------------------
*
* DBL and DBK input files:
*
* line 1: 'DBL' in columns 1-3 to test SGEBAL, or 'DBK' in
* columns 1-3 to test SGEBAK.
*
* The remaining lines consist of specially constructed test cases.
*
*-----------------------------------------------------------------------
*
* DGL and DGK input files:
*
* line 1: 'DGL' in columns 1-3 to test DGGBAL, or 'DGK' in
* columns 1-3 to test DGGBAK.
*
* The remaining lines consist of specially constructed test cases.
*
*-----------------------------------------------------------------------
*
* GLM data file:
*
* line 1: 'GLM' in columns 1 to 3.
*
* line 2: NN, INTEGER
* Number of values of M, P, and N.
*
* line 3: MVAL, INTEGER array, dimension(NN)
* Values of M (row dimension).
*
* line 4: PVAL, INTEGER array, dimension(NN)
* Values of P (row dimension).
*
* line 5: NVAL, INTEGER array, dimension(NN)
* Values of N (column dimension), note M <= N <= M+P.
*
* line 6: THRESH, REAL
* Threshold value for the test ratios. Information will be
* printed about each test for which the test ratio is greater
* than or equal to the threshold.
*
* line 7: TSTERR, LOGICAL
* Flag indicating whether or not to test the error exits for
* the LAPACK routines and driver routines.
*
* line 8: NEWSD, INTEGER
* A code indicating how to set the random number seed.
* = 0: Set the seed to a default value before each run
* = 1: Initialize the seed to a default value only before the
* first run
* = 2: Like 1, but use the seed values on the next line
*
* If line 8 was 2:
*
* line 9: INTEGER array, dimension (4)
* Four integer values for the random number seed.
*
* lines 9-EOF: Lines specifying matrix types, as for NEP.
* The 3-character path name is 'GLM' for the generalized
* linear regression model routines.
*
*-----------------------------------------------------------------------
*
* GQR data file:
*
* line 1: 'GQR' in columns 1 to 3.
*
* line 2: NN, INTEGER
* Number of values of M, P, and N.
*
* line 3: MVAL, INTEGER array, dimension(NN)
* Values of M.
*
* line 4: PVAL, INTEGER array, dimension(NN)
* Values of P.
*
* line 5: NVAL, INTEGER array, dimension(NN)
* Values of N.
*
* line 6: THRESH, REAL
* Threshold value for the test ratios. Information will be
* printed about each test for which the test ratio is greater
* than or equal to the threshold.
*
* line 7: TSTERR, LOGICAL
* Flag indicating whether or not to test the error exits for
* the LAPACK routines and driver routines.
*
* line 8: NEWSD, INTEGER
* A code indicating how to set the random number seed.
* = 0: Set the seed to a default value before each run
* = 1: Initialize the seed to a default value only before the
* first run
* = 2: Like 1, but use the seed values on the next line
*
* If line 8 was 2:
*
* line 9: INTEGER array, dimension (4)
* Four integer values for the random number seed.
*
* lines 9-EOF: Lines specifying matrix types, as for NEP.
* The 3-character path name is 'GQR' for the generalized
* QR and RQ routines.
*
*-----------------------------------------------------------------------
*
* GSV data file:
*
* line 1: 'GSV' in columns 1 to 3.
*
* line 2: NN, INTEGER
* Number of values of M, P, and N.
*
* line 3: MVAL, INTEGER array, dimension(NN)
* Values of M (row dimension).
*
* line 4: PVAL, INTEGER array, dimension(NN)
* Values of P (row dimension).
*
* line 5: NVAL, INTEGER array, dimension(NN)
* Values of N (column dimension).
*
* line 6: THRESH, REAL
* Threshold value for the test ratios. Information will be
* printed about each test for which the test ratio is greater
* than or equal to the threshold.
*
* line 7: TSTERR, LOGICAL
* Flag indicating whether or not to test the error exits for
* the LAPACK routines and driver routines.
*
* line 8: NEWSD, INTEGER
* A code indicating how to set the random number seed.
* = 0: Set the seed to a default value before each run
* = 1: Initialize the seed to a default value only before the
* first run
* = 2: Like 1, but use the seed values on the next line
*
* If line 8 was 2:
*
* line 9: INTEGER array, dimension (4)
* Four integer values for the random number seed.
*
* lines 9-EOF: Lines specifying matrix types, as for NEP.
* The 3-character path name is 'GSV' for the generalized
* SVD routines.
*
*-----------------------------------------------------------------------
*
* LSE data file:
*
* line 1: 'LSE' in columns 1 to 3.
*
* line 2: NN, INTEGER
* Number of values of M, P, and N.
*
* line 3: MVAL, INTEGER array, dimension(NN)
* Values of M.
*
* line 4: PVAL, INTEGER array, dimension(NN)
* Values of P.
*
* line 5: NVAL, INTEGER array, dimension(NN)
* Values of N, note P <= N <= P+M.
*
* line 6: THRESH, REAL
* Threshold value for the test ratios. Information will be
* printed about each test for which the test ratio is greater
* than or equal to the threshold.
*
* line 7: TSTERR, LOGICAL
* Flag indicating whether or not to test the error exits for
* the LAPACK routines and driver routines.
*
* line 8: NEWSD, INTEGER
* A code indicating how to set the random number seed.
* = 0: Set the seed to a default value before each run
* = 1: Initialize the seed to a default value only before the
* first run
* = 2: Like 1, but use the seed values on the next line
*
* If line 8 was 2:
*
* line 9: INTEGER array, dimension (4)
* Four integer values for the random number seed.
*
* lines 9-EOF: Lines specifying matrix types, as for NEP.
* The 3-character path name is 'GSV' for the generalized
* SVD routines.
*
*-----------------------------------------------------------------------
*
* NMAX is currently set to 132 and must be at least 12 for some of the
* precomputed examples, and LWORK = NMAX*(5*NMAX+5)+1 in the parameter
* statements below. For SVD, we assume NRHS may be as big as N. The
* parameter NEED is set to 14 to allow for 14 N-by-N matrices for DGG.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 132 )
INTEGER NCMAX
PARAMETER ( NCMAX = 20 )
INTEGER NEED
PARAMETER ( NEED = 14 )
INTEGER LWORK
PARAMETER ( LWORK = NMAX*( 5*NMAX+5 )+1 )
INTEGER LIWORK
PARAMETER ( LIWORK = NMAX*( 5*NMAX+20 ) )
INTEGER MAXIN
PARAMETER ( MAXIN = 20 )
INTEGER MAXT
PARAMETER ( MAXT = 30 )
INTEGER NIN, NOUT
PARAMETER ( NIN = 5, NOUT = 6 )
* ..
* .. Local Scalars ..
LOGICAL DBB, DGG, DSB, FATAL, GLM, GQR, GSV, LSE, NEP,
$ DBK, DBL, SEP, DES, DEV, DGK, DGL, DGS, DGV,
$ DGX, DSX, SVD, DVX, DXV, TSTCHK, TSTDIF,
$ TSTDRV, TSTERR
CHARACTER C1
CHARACTER*3 C3, PATH
CHARACTER*6 VNAME
CHARACTER*10 INTSTR
CHARACTER*80 LINE
INTEGER I, I1, IC, INFO, ITMP, K, LENP, MAXTYP, NEWSD,
$ NK, NN, NPARMS, NRHS, NTYPES,
$ VERS_MAJOR, VERS_MINOR, VERS_PATCH
DOUBLE PRECISION EPS, S1, S2, THRESH, THRSHN
* ..
* .. Local Arrays ..
LOGICAL DOTYPE( MAXT ), LOGWRK( NMAX )
INTEGER IOLDSD( 4 ), ISEED( 4 ), IWORK( LIWORK ),
$ KVAL( MAXIN ), MVAL( MAXIN ), MXBVAL( MAXIN ),
$ NBCOL( MAXIN ), NBMIN( MAXIN ), NBVAL( MAXIN ),
$ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ),
$ PVAL( MAXIN )
INTEGER INMIN( MAXIN ), INWIN( MAXIN ), INIBL( MAXIN ),
$ ISHFTS( MAXIN ), IACC22( MAXIN )
DOUBLE PRECISION A( NMAX*NMAX, NEED ), B( NMAX*NMAX, 5 ),
$ C( NCMAX*NCMAX, NCMAX*NCMAX ), D( NMAX, 12 ),
$ RESULT( 500 ), TAUA( NMAX ), TAUB( NMAX ),
$ WORK( LWORK ), X( 5*NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
DOUBLE PRECISION DLAMCH, DSECND
EXTERNAL LSAMEN, DLAMCH, DSECND
* ..
* .. External Subroutines ..
EXTERNAL ALAREQ, DCHKBB, DCHKBD, DCHKBK, DCHKBL, DCHKEC,
$ DCHKGG, DCHKGK, DCHKGL, DCHKHS, DCHKSB, DCHKST,
$ DCKGLM, DCKGQR, DCKGSV, DCKLSE, DDRGES, DDRGEV,
$ DDRGSX, DDRGVX, DDRVBD, DDRVES, DDRVEV, DDRVGG,
$ DDRVSG, DDRVST, DDRVSX, DDRVVX, DERRBD, DERRED,
$ DERRGG, DERRHS, DERRST, ILAVER, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC LEN, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, MAXB, NPROC, NSHIFT, NUNIT, SELDIM,
$ SELOPT
* ..
* .. Arrays in Common ..
LOGICAL SELVAL( 20 )
INTEGER IPARMS( 100 )
DOUBLE PRECISION SELWI( 20 ), SELWR( 20 )
* ..
* .. Common blocks ..
COMMON / CENVIR / NPROC, NSHIFT, MAXB
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
COMMON / SSLCT / SELOPT, SELDIM, SELVAL, SELWR, SELWI
COMMON / ZLAENV / IPARMS
* ..
* .. Data statements ..
DATA INTSTR / '0123456789' /
DATA IOLDSD / 0, 0, 0, 1 /
* ..
* .. Executable Statements ..
*
S1 = DSECND( )
FATAL = .FALSE.
NUNIT = NOUT
*
* Return to here to read multiple sets of data
*
10 CONTINUE
*
* Read the first line and set the 3-character test path
*
READ( NIN, FMT = '(A80)', END = 380 )LINE
PATH = LINE( 1: 3 )
NEP = LSAMEN( 3, PATH, 'NEP' ) .OR. LSAMEN( 3, PATH, 'DHS' )
SEP = LSAMEN( 3, PATH, 'SEP' ) .OR. LSAMEN( 3, PATH, 'DST' ) .OR.
$ LSAMEN( 3, PATH, 'DSG' )
SVD = LSAMEN( 3, PATH, 'SVD' ) .OR. LSAMEN( 3, PATH, 'DBD' )
DEV = LSAMEN( 3, PATH, 'DEV' )
DES = LSAMEN( 3, PATH, 'DES' )
DVX = LSAMEN( 3, PATH, 'DVX' )
DSX = LSAMEN( 3, PATH, 'DSX' )
DGG = LSAMEN( 3, PATH, 'DGG' )
DGS = LSAMEN( 3, PATH, 'DGS' )
DGX = LSAMEN( 3, PATH, 'DGX' )
DGV = LSAMEN( 3, PATH, 'DGV' )
DXV = LSAMEN( 3, PATH, 'DXV' )
DSB = LSAMEN( 3, PATH, 'DSB' )
DBB = LSAMEN( 3, PATH, 'DBB' )
GLM = LSAMEN( 3, PATH, 'GLM' )
GQR = LSAMEN( 3, PATH, 'GQR' ) .OR. LSAMEN( 3, PATH, 'GRQ' )
GSV = LSAMEN( 3, PATH, 'GSV' )
LSE = LSAMEN( 3, PATH, 'LSE' )
DBL = LSAMEN( 3, PATH, 'DBL' )
DBK = LSAMEN( 3, PATH, 'DBK' )
DGL = LSAMEN( 3, PATH, 'DGL' )
DGK = LSAMEN( 3, PATH, 'DGK' )
*
* Report values of parameters.
*
IF( PATH.EQ.' ' ) THEN
GO TO 10
ELSE IF( NEP ) THEN
WRITE( NOUT, FMT = 9987 )
ELSE IF( SEP ) THEN
WRITE( NOUT, FMT = 9986 )
ELSE IF( SVD ) THEN
WRITE( NOUT, FMT = 9985 )
ELSE IF( DEV ) THEN
WRITE( NOUT, FMT = 9979 )
ELSE IF( DES ) THEN
WRITE( NOUT, FMT = 9978 )
ELSE IF( DVX ) THEN
WRITE( NOUT, FMT = 9977 )
ELSE IF( DSX ) THEN
WRITE( NOUT, FMT = 9976 )
ELSE IF( DGG ) THEN
WRITE( NOUT, FMT = 9975 )
ELSE IF( DGS ) THEN
WRITE( NOUT, FMT = 9964 )
ELSE IF( DGX ) THEN
WRITE( NOUT, FMT = 9965 )
ELSE IF( DGV ) THEN
WRITE( NOUT, FMT = 9963 )
ELSE IF( DXV ) THEN
WRITE( NOUT, FMT = 9962 )
ELSE IF( DSB ) THEN
WRITE( NOUT, FMT = 9974 )
ELSE IF( DBB ) THEN
WRITE( NOUT, FMT = 9967 )
ELSE IF( GLM ) THEN
WRITE( NOUT, FMT = 9971 )
ELSE IF( GQR ) THEN
WRITE( NOUT, FMT = 9970 )
ELSE IF( GSV ) THEN
WRITE( NOUT, FMT = 9969 )
ELSE IF( LSE ) THEN
WRITE( NOUT, FMT = 9968 )
ELSE IF( DBL ) THEN
*
* DGEBAL: Balancing
*
CALL DCHKBL( NIN, NOUT )
GO TO 10
ELSE IF( DBK ) THEN
*
* DGEBAK: Back transformation
*
CALL DCHKBK( NIN, NOUT )
GO TO 10
ELSE IF( DGL ) THEN
*
* DGGBAL: Balancing
*
CALL DCHKGL( NIN, NOUT )
GO TO 10
ELSE IF( DGK ) THEN
*
* DGGBAK: Back transformation
*
CALL DCHKGK( NIN, NOUT )
GO TO 10
ELSE IF( LSAMEN( 3, PATH, 'DEC' ) ) THEN
*
* DEC: Eigencondition estimation
*
READ( NIN, FMT = * )THRESH
CALL XLAENV( 1, 1 )
CALL XLAENV( 12, 11 )
CALL XLAENV( 13, 2 )
CALL XLAENV( 14, 0 )
CALL XLAENV( 15, 2 )
CALL XLAENV( 16, 2 )
TSTERR = .TRUE.
CALL DCHKEC( THRESH, TSTERR, NIN, NOUT )
GO TO 10
ELSE
WRITE( NOUT, FMT = 9992 )PATH
GO TO 10
END IF
CALL ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH )
WRITE( NOUT, FMT = 9972 ) VERS_MAJOR, VERS_MINOR, VERS_PATCH
WRITE( NOUT, FMT = 9984 )
*
* Read the number of values of M, P, and N.
*
READ( NIN, FMT = * )NN
IF( NN.LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )' NN ', NN, 1
NN = 0
FATAL = .TRUE.
ELSE IF( NN.GT.MAXIN ) THEN
WRITE( NOUT, FMT = 9988 )' NN ', NN, MAXIN
NN = 0
FATAL = .TRUE.
END IF
*
* Read the values of M
*
IF( .NOT.( DGX .OR. DXV ) ) THEN
READ( NIN, FMT = * )( MVAL( I ), I = 1, NN )
IF( SVD ) THEN
VNAME = ' M '
ELSE
VNAME = ' N '
END IF
DO 20 I = 1, NN
IF( MVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )VNAME, MVAL( I ), 0
FATAL = .TRUE.
ELSE IF( MVAL( I ).GT.NMAX ) THEN
WRITE( NOUT, FMT = 9988 )VNAME, MVAL( I ), NMAX
FATAL = .TRUE.
END IF
20 CONTINUE
WRITE( NOUT, FMT = 9983 )'M: ', ( MVAL( I ), I = 1, NN )
END IF
*
* Read the values of P
*
IF( GLM .OR. GQR .OR. GSV .OR. LSE ) THEN
READ( NIN, FMT = * )( PVAL( I ), I = 1, NN )
DO 30 I = 1, NN
IF( PVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )' P ', PVAL( I ), 0
FATAL = .TRUE.
ELSE IF( PVAL( I ).GT.NMAX ) THEN
WRITE( NOUT, FMT = 9988 )' P ', PVAL( I ), NMAX
FATAL = .TRUE.
END IF
30 CONTINUE
WRITE( NOUT, FMT = 9983 )'P: ', ( PVAL( I ), I = 1, NN )
END IF
*
* Read the values of N
*
IF( SVD .OR. DBB .OR. GLM .OR. GQR .OR. GSV .OR. LSE ) THEN
READ( NIN, FMT = * )( NVAL( I ), I = 1, NN )
DO 40 I = 1, NN
IF( NVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )' N ', NVAL( I ), 0
FATAL = .TRUE.
ELSE IF( NVAL( I ).GT.NMAX ) THEN
WRITE( NOUT, FMT = 9988 )' N ', NVAL( I ), NMAX
FATAL = .TRUE.
END IF
40 CONTINUE
ELSE
DO 50 I = 1, NN
NVAL( I ) = MVAL( I )
50 CONTINUE
END IF
IF( .NOT.( DGX .OR. DXV ) ) THEN
WRITE( NOUT, FMT = 9983 )'N: ', ( NVAL( I ), I = 1, NN )
ELSE
WRITE( NOUT, FMT = 9983 )'N: ', NN
END IF
*
* Read the number of values of K, followed by the values of K
*
IF( DSB .OR. DBB ) THEN
READ( NIN, FMT = * )NK
READ( NIN, FMT = * )( KVAL( I ), I = 1, NK )
DO 60 I = 1, NK
IF( KVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )' K ', KVAL( I ), 0
FATAL = .TRUE.
ELSE IF( KVAL( I ).GT.NMAX ) THEN
WRITE( NOUT, FMT = 9988 )' K ', KVAL( I ), NMAX
FATAL = .TRUE.
END IF
60 CONTINUE
WRITE( NOUT, FMT = 9983 )'K: ', ( KVAL( I ), I = 1, NK )
END IF
*
IF( DEV .OR. DES .OR. DVX .OR. DSX ) THEN
*
* For the nonsymmetric QR driver routines, only one set of
* parameters is allowed.
*
READ( NIN, FMT = * )NBVAL( 1 ), NBMIN( 1 ), NXVAL( 1 ),
$ INMIN( 1 ), INWIN( 1 ), INIBL(1), ISHFTS(1), IACC22(1)
IF( NBVAL( 1 ).LT.1 ) THEN
WRITE( NOUT, FMT = 9989 )' NB ', NBVAL( 1 ), 1
FATAL = .TRUE.
ELSE IF( NBMIN( 1 ).LT.1 ) THEN
WRITE( NOUT, FMT = 9989 )'NBMIN ', NBMIN( 1 ), 1
FATAL = .TRUE.
ELSE IF( NXVAL( 1 ).LT.1 ) THEN
WRITE( NOUT, FMT = 9989 )' NX ', NXVAL( 1 ), 1
FATAL = .TRUE.
ELSE IF( INMIN( 1 ).LT.1 ) THEN
WRITE( NOUT, FMT = 9989 )' INMIN ', INMIN( 1 ), 1
FATAL = .TRUE.
ELSE IF( INWIN( 1 ).LT.1 ) THEN
WRITE( NOUT, FMT = 9989 )' INWIN ', INWIN( 1 ), 1
FATAL = .TRUE.
ELSE IF( INIBL( 1 ).LT.1 ) THEN
WRITE( NOUT, FMT = 9989 )' INIBL ', INIBL( 1 ), 1
FATAL = .TRUE.
ELSE IF( ISHFTS( 1 ).LT.1 ) THEN
WRITE( NOUT, FMT = 9989 )' ISHFTS ', ISHFTS( 1 ), 1
FATAL = .TRUE.
ELSE IF( IACC22( 1 ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )' IACC22 ', IACC22( 1 ), 0
FATAL = .TRUE.
END IF
CALL XLAENV( 1, NBVAL( 1 ) )
CALL XLAENV( 2, NBMIN( 1 ) )
CALL XLAENV( 3, NXVAL( 1 ) )
CALL XLAENV(12, MAX( 11, INMIN( 1 ) ) )
CALL XLAENV(13, INWIN( 1 ) )
CALL XLAENV(14, INIBL( 1 ) )
CALL XLAENV(15, ISHFTS( 1 ) )
CALL XLAENV(16, IACC22( 1 ) )
WRITE( NOUT, FMT = 9983 )'NB: ', NBVAL( 1 )
WRITE( NOUT, FMT = 9983 )'NBMIN:', NBMIN( 1 )
WRITE( NOUT, FMT = 9983 )'NX: ', NXVAL( 1 )
WRITE( NOUT, FMT = 9983 )'INMIN: ', INMIN( 1 )
WRITE( NOUT, FMT = 9983 )'INWIN: ', INWIN( 1 )
WRITE( NOUT, FMT = 9983 )'INIBL: ', INIBL( 1 )
WRITE( NOUT, FMT = 9983 )'ISHFTS: ', ISHFTS( 1 )
WRITE( NOUT, FMT = 9983 )'IACC22: ', IACC22( 1 )
*
ELSEIF( DGS .OR. DGX .OR. DGV .OR. DXV ) THEN
*
* For the nonsymmetric generalized driver routines, only one set
* of parameters is allowed.
*
READ( NIN, FMT = * )NBVAL( 1 ), NBMIN( 1 ), NXVAL( 1 ),
$ NSVAL( 1 ), MXBVAL( 1 )
IF( NBVAL( 1 ).LT.1 ) THEN
WRITE( NOUT, FMT = 9989 )' NB ', NBVAL( 1 ), 1
FATAL = .TRUE.
ELSE IF( NBMIN( 1 ).LT.1 ) THEN
WRITE( NOUT, FMT = 9989 )'NBMIN ', NBMIN( 1 ), 1
FATAL = .TRUE.
ELSE IF( NXVAL( 1 ).LT.1 ) THEN
WRITE( NOUT, FMT = 9989 )' NX ', NXVAL( 1 ), 1
FATAL = .TRUE.
ELSE IF( NSVAL( 1 ).LT.2 ) THEN
WRITE( NOUT, FMT = 9989 )' NS ', NSVAL( 1 ), 2
FATAL = .TRUE.
ELSE IF( MXBVAL( 1 ).LT.1 ) THEN
WRITE( NOUT, FMT = 9989 )' MAXB ', MXBVAL( 1 ), 1
FATAL = .TRUE.
END IF
CALL XLAENV( 1, NBVAL( 1 ) )
CALL XLAENV( 2, NBMIN( 1 ) )
CALL XLAENV( 3, NXVAL( 1 ) )
CALL XLAENV( 4, NSVAL( 1 ) )
CALL XLAENV( 8, MXBVAL( 1 ) )
WRITE( NOUT, FMT = 9983 )'NB: ', NBVAL( 1 )
WRITE( NOUT, FMT = 9983 )'NBMIN:', NBMIN( 1 )
WRITE( NOUT, FMT = 9983 )'NX: ', NXVAL( 1 )
WRITE( NOUT, FMT = 9983 )'NS: ', NSVAL( 1 )
WRITE( NOUT, FMT = 9983 )'MAXB: ', MXBVAL( 1 )
*
ELSE IF( .NOT.DSB .AND. .NOT.GLM .AND. .NOT.GQR .AND. .NOT.
$ GSV .AND. .NOT.LSE ) THEN
*
* For the other paths, the number of parameters can be varied
* from the input file. Read the number of parameter values.
*
READ( NIN, FMT = * )NPARMS
IF( NPARMS.LT.1 ) THEN
WRITE( NOUT, FMT = 9989 )'NPARMS', NPARMS, 1
NPARMS = 0
FATAL = .TRUE.
ELSE IF( NPARMS.GT.MAXIN ) THEN
WRITE( NOUT, FMT = 9988 )'NPARMS', NPARMS, MAXIN
NPARMS = 0
FATAL = .TRUE.
END IF
*
* Read the values of NB
*
IF( .NOT.DBB ) THEN
READ( NIN, FMT = * )( NBVAL( I ), I = 1, NPARMS )
DO 70 I = 1, NPARMS
IF( NBVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )' NB ', NBVAL( I ), 0
FATAL = .TRUE.
ELSE IF( NBVAL( I ).GT.NMAX ) THEN
WRITE( NOUT, FMT = 9988 )' NB ', NBVAL( I ), NMAX
FATAL = .TRUE.
END IF
70 CONTINUE
WRITE( NOUT, FMT = 9983 )'NB: ',
$ ( NBVAL( I ), I = 1, NPARMS )
END IF
*
* Read the values of NBMIN
*
IF( NEP .OR. SEP .OR. SVD .OR. DGG ) THEN
READ( NIN, FMT = * )( NBMIN( I ), I = 1, NPARMS )
DO 80 I = 1, NPARMS
IF( NBMIN( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )'NBMIN ', NBMIN( I ), 0
FATAL = .TRUE.
ELSE IF( NBMIN( I ).GT.NMAX ) THEN
WRITE( NOUT, FMT = 9988 )'NBMIN ', NBMIN( I ), NMAX
FATAL = .TRUE.
END IF
80 CONTINUE
WRITE( NOUT, FMT = 9983 )'NBMIN:',
$ ( NBMIN( I ), I = 1, NPARMS )
ELSE
DO 90 I = 1, NPARMS
NBMIN( I ) = 1
90 CONTINUE
END IF
*
* Read the values of NX
*
IF( NEP .OR. SEP .OR. SVD ) THEN
READ( NIN, FMT = * )( NXVAL( I ), I = 1, NPARMS )
DO 100 I = 1, NPARMS
IF( NXVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )' NX ', NXVAL( I ), 0
FATAL = .TRUE.
ELSE IF( NXVAL( I ).GT.NMAX ) THEN
WRITE( NOUT, FMT = 9988 )' NX ', NXVAL( I ), NMAX
FATAL = .TRUE.
END IF
100 CONTINUE
WRITE( NOUT, FMT = 9983 )'NX: ',
$ ( NXVAL( I ), I = 1, NPARMS )
ELSE
DO 110 I = 1, NPARMS
NXVAL( I ) = 1
110 CONTINUE
END IF
*
* Read the values of NSHIFT (if DGG) or NRHS (if SVD
* or DBB).
*
IF( SVD .OR. DBB .OR. DGG ) THEN
READ( NIN, FMT = * )( NSVAL( I ), I = 1, NPARMS )
DO 120 I = 1, NPARMS
IF( NSVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )' NS ', NSVAL( I ), 0
FATAL = .TRUE.
ELSE IF( NSVAL( I ).GT.NMAX ) THEN
WRITE( NOUT, FMT = 9988 )' NS ', NSVAL( I ), NMAX
FATAL = .TRUE.
END IF
120 CONTINUE
WRITE( NOUT, FMT = 9983 )'NS: ',
$ ( NSVAL( I ), I = 1, NPARMS )
ELSE
DO 130 I = 1, NPARMS
NSVAL( I ) = 1
130 CONTINUE
END IF
*
* Read the values for MAXB.
*
IF( DGG ) THEN
READ( NIN, FMT = * )( MXBVAL( I ), I = 1, NPARMS )
DO 140 I = 1, NPARMS
IF( MXBVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )' MAXB ', MXBVAL( I ), 0
FATAL = .TRUE.
ELSE IF( MXBVAL( I ).GT.NMAX ) THEN
WRITE( NOUT, FMT = 9988 )' MAXB ', MXBVAL( I ), NMAX
FATAL = .TRUE.
END IF
140 CONTINUE
WRITE( NOUT, FMT = 9983 )'MAXB: ',
$ ( MXBVAL( I ), I = 1, NPARMS )
ELSE
DO 150 I = 1, NPARMS
MXBVAL( I ) = 1
150 CONTINUE
END IF
*
* Read the values for INMIN.
*
IF( NEP ) THEN
READ( NIN, FMT = * )( INMIN( I ), I = 1, NPARMS )
DO 540 I = 1, NPARMS
IF( INMIN( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )' INMIN ', INMIN( I ), 0
FATAL = .TRUE.
END IF
540 CONTINUE
WRITE( NOUT, FMT = 9983 )'INMIN: ',
$ ( INMIN( I ), I = 1, NPARMS )
ELSE
DO 550 I = 1, NPARMS
INMIN( I ) = 1
550 CONTINUE
END IF
*
* Read the values for INWIN.
*
IF( NEP ) THEN
READ( NIN, FMT = * )( INWIN( I ), I = 1, NPARMS )
DO 560 I = 1, NPARMS
IF( INWIN( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )' INWIN ', INWIN( I ), 0
FATAL = .TRUE.
END IF
560 CONTINUE
WRITE( NOUT, FMT = 9983 )'INWIN: ',
$ ( INWIN( I ), I = 1, NPARMS )
ELSE
DO 570 I = 1, NPARMS
INWIN( I ) = 1
570 CONTINUE
END IF
*
* Read the values for INIBL.
*
IF( NEP ) THEN
READ( NIN, FMT = * )( INIBL( I ), I = 1, NPARMS )
DO 580 I = 1, NPARMS
IF( INIBL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )' INIBL ', INIBL( I ), 0
FATAL = .TRUE.
END IF
580 CONTINUE
WRITE( NOUT, FMT = 9983 )'INIBL: ',
$ ( INIBL( I ), I = 1, NPARMS )
ELSE
DO 590 I = 1, NPARMS
INIBL( I ) = 1
590 CONTINUE
END IF
*
* Read the values for ISHFTS.
*
IF( NEP ) THEN
READ( NIN, FMT = * )( ISHFTS( I ), I = 1, NPARMS )
DO 600 I = 1, NPARMS
IF( ISHFTS( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )' ISHFTS ', ISHFTS( I ), 0
FATAL = .TRUE.
END IF
600 CONTINUE
WRITE( NOUT, FMT = 9983 )'ISHFTS: ',
$ ( ISHFTS( I ), I = 1, NPARMS )
ELSE
DO 610 I = 1, NPARMS
ISHFTS( I ) = 1
610 CONTINUE
END IF
*
* Read the values for IACC22.
*
IF( NEP ) THEN
READ( NIN, FMT = * )( IACC22( I ), I = 1, NPARMS )
DO 620 I = 1, NPARMS
IF( IACC22( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )' IACC22 ', IACC22( I ), 0
FATAL = .TRUE.
END IF
620 CONTINUE
WRITE( NOUT, FMT = 9983 )'IACC22: ',
$ ( IACC22( I ), I = 1, NPARMS )
ELSE
DO 630 I = 1, NPARMS
IACC22( I ) = 1
630 CONTINUE
END IF
*
* Read the values for NBCOL.
*
IF( DGG ) THEN
READ( NIN, FMT = * )( NBCOL( I ), I = 1, NPARMS )
DO 160 I = 1, NPARMS
IF( NBCOL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9989 )'NBCOL ', NBCOL( I ), 0
FATAL = .TRUE.
ELSE IF( NBCOL( I ).GT.NMAX ) THEN
WRITE( NOUT, FMT = 9988 )'NBCOL ', NBCOL( I ), NMAX
FATAL = .TRUE.
END IF
160 CONTINUE
WRITE( NOUT, FMT = 9983 )'NBCOL:',
$ ( NBCOL( I ), I = 1, NPARMS )
ELSE
DO 170 I = 1, NPARMS
NBCOL( I ) = 1
170 CONTINUE
END IF
END IF
*
* Calculate and print the machine dependent constants.
*
WRITE( NOUT, FMT = * )
EPS = DLAMCH( 'Underflow threshold' )
WRITE( NOUT, FMT = 9981 )'underflow', EPS
EPS = DLAMCH( 'Overflow threshold' )
WRITE( NOUT, FMT = 9981 )'overflow ', EPS
EPS = DLAMCH( 'Epsilon' )
WRITE( NOUT, FMT = 9981 )'precision', EPS
*
* Read the threshold value for the test ratios.
*
READ( NIN, FMT = * )THRESH
WRITE( NOUT, FMT = 9982 )THRESH
IF( SEP .OR. SVD .OR. DGG ) THEN
*
* Read the flag that indicates whether to test LAPACK routines.
*
READ( NIN, FMT = * )TSTCHK
*
* Read the flag that indicates whether to test driver routines.
*
READ( NIN, FMT = * )TSTDRV
END IF
*
* Read the flag that indicates whether to test the error exits.
*
READ( NIN, FMT = * )TSTERR
*
* Read the code describing how to set the random number seed.
*
READ( NIN, FMT = * )NEWSD
*
* If NEWSD = 2, read another line with 4 integers for the seed.
*
IF( NEWSD.EQ.2 )
$ READ( NIN, FMT = * )( IOLDSD( I ), I = 1, 4 )
*
DO 180 I = 1, 4
ISEED( I ) = IOLDSD( I )
180 CONTINUE
*
IF( FATAL ) THEN
WRITE( NOUT, FMT = 9999 )
STOP
END IF
*
* Read the input lines indicating the test path and its parameters.
* The first three characters indicate the test path, and the number
* of test matrix types must be the first nonblank item in columns
* 4-80.
*
190 CONTINUE
*
IF( .NOT.( DGX .OR. DXV ) ) THEN
*
200 CONTINUE
READ( NIN, FMT = '(A80)', END = 380 )LINE
C3 = LINE( 1: 3 )
LENP = LEN( LINE )
I = 3
ITMP = 0
I1 = 0
210 CONTINUE
I = I + 1
IF( I.GT.LENP ) THEN
IF( I1.GT.0 ) THEN
GO TO 240
ELSE
NTYPES = MAXT
GO TO 240
END IF
END IF
IF( LINE( I: I ).NE.' ' .AND. LINE( I: I ).NE.',' ) THEN
I1 = I
C1 = LINE( I1: I1 )
*
* Check that a valid integer was read
*
DO 220 K = 1, 10
IF( C1.EQ.INTSTR( K: K ) ) THEN
IC = K - 1
GO TO 230
END IF
220 CONTINUE
WRITE( NOUT, FMT = 9991 )I, LINE
GO TO 200
230 CONTINUE
ITMP = 10*ITMP + IC
GO TO 210
ELSE IF( I1.GT.0 ) THEN
GO TO 240
ELSE
GO TO 210
END IF
240 CONTINUE
NTYPES = ITMP
*
* Skip the tests if NTYPES is <= 0.
*
IF( .NOT.( DEV .OR. DES .OR. DVX .OR. DSX .OR. DGV .OR.
$ DGS ) .AND. NTYPES.LE.0 ) THEN
WRITE( NOUT, FMT = 9990 )C3
GO TO 200
END IF
*
ELSE
IF( DXV )
$ C3 = 'DXV'
IF( DGX )
$ C3 = 'DGX'
END IF
*
* Reset the random number seed.
*
IF( NEWSD.EQ.0 ) THEN
DO 250 K = 1, 4
ISEED( K ) = IOLDSD( K )
250 CONTINUE
END IF
*
IF( LSAMEN( 3, C3, 'DHS' ) .OR. LSAMEN( 3, C3, 'NEP' ) ) THEN
*
* -------------------------------------
* NEP: Nonsymmetric Eigenvalue Problem
* -------------------------------------
* Vary the parameters
* NB = block size
* NBMIN = minimum block size
* NX = crossover point
* NS = number of shifts
* MAXB = minimum submatrix size
*
MAXTYP = 21
NTYPES = MIN( MAXTYP, NTYPES )
CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
CALL XLAENV( 1, 1 )
IF( TSTERR )
$ CALL DERRHS( 'DHSEQR', NOUT )
DO 270 I = 1, NPARMS
CALL XLAENV( 1, NBVAL( I ) )
CALL XLAENV( 2, NBMIN( I ) )
CALL XLAENV( 3, NXVAL( I ) )
CALL XLAENV(12, MAX( 11, INMIN( I ) ) )
CALL XLAENV(13, INWIN( I ) )
CALL XLAENV(14, INIBL( I ) )
CALL XLAENV(15, ISHFTS( I ) )
CALL XLAENV(16, IACC22( I ) )
*
IF( NEWSD.EQ.0 ) THEN
DO 260 K = 1, 4
ISEED( K ) = IOLDSD( K )
260 CONTINUE
END IF
WRITE( NOUT, FMT = 9961 )C3, NBVAL( I ), NBMIN( I ),
$ NXVAL( I ), MAX( 11, INMIN(I)),
$ INWIN( I ), INIBL( I ), ISHFTS( I ), IACC22( I )
CALL DCHKHS( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, NOUT,
$ A( 1, 1 ), NMAX, A( 1, 2 ), A( 1, 3 ),
$ A( 1, 4 ), A( 1, 5 ), NMAX, A( 1, 6 ),
$ A( 1, 7 ), D( 1, 1 ), D( 1, 2 ), D( 1, 3 ),
$ D( 1, 4 ), A( 1, 8 ), A( 1, 9 ), A( 1, 10 ),
$ A( 1, 11 ), A( 1, 12 ), D( 1, 5 ), WORK, LWORK,
$ IWORK, LOGWRK, RESULT, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'DCHKHS', INFO
270 CONTINUE
*
ELSE IF( LSAMEN( 3, C3, 'DST' ) .OR. LSAMEN( 3, C3, 'SEP' ) ) THEN
*
* ----------------------------------
* SEP: Symmetric Eigenvalue Problem
* ----------------------------------
* Vary the parameters
* NB = block size
* NBMIN = minimum block size
* NX = crossover point
*
MAXTYP = 21
NTYPES = MIN( MAXTYP, NTYPES )
CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
CALL XLAENV( 1, 1 )
CALL XLAENV( 9, 25 )
IF( TSTERR )
$ CALL DERRST( 'DST', NOUT )
DO 290 I = 1, NPARMS
CALL XLAENV( 1, NBVAL( I ) )
CALL XLAENV( 2, NBMIN( I ) )
CALL XLAENV( 3, NXVAL( I ) )
*
IF( NEWSD.EQ.0 ) THEN
DO 280 K = 1, 4
ISEED( K ) = IOLDSD( K )
280 CONTINUE
END IF
WRITE( NOUT, FMT = 9997 )C3, NBVAL( I ), NBMIN( I ),
$ NXVAL( I )
IF( TSTCHK ) THEN
CALL DCHKST( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH,
$ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), D( 1, 1 ),
$ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), D( 1, 5 ),
$ D( 1, 6 ), D( 1, 7 ), D( 1, 8 ), D( 1, 9 ),
$ D( 1, 10 ), D( 1, 11 ), A( 1, 3 ), NMAX,
$ A( 1, 4 ), A( 1, 5 ), D( 1, 12 ), A( 1, 6 ),
$ WORK, LWORK, IWORK, LIWORK, RESULT, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'DCHKST', INFO
END IF
IF( TSTDRV ) THEN
CALL DDRVST( NN, NVAL, 18, DOTYPE, ISEED, THRESH, NOUT,
$ A( 1, 1 ), NMAX, D( 1, 3 ), D( 1, 4 ),
$ D( 1, 5 ), D( 1, 6 ), D( 1, 8 ), D( 1, 9 ),
$ D( 1, 10 ), D( 1, 11 ), A( 1, 2 ), NMAX,
$ A( 1, 3 ), D( 1, 12 ), A( 1, 4 ), WORK,
$ LWORK, IWORK, LIWORK, RESULT, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'DDRVST', INFO
END IF
290 CONTINUE
*
ELSE IF( LSAMEN( 3, C3, 'DSG' ) ) THEN
*
* ----------------------------------------------
* DSG: Symmetric Generalized Eigenvalue Problem
* ----------------------------------------------
* Vary the parameters
* NB = block size
* NBMIN = minimum block size
* NX = crossover point
*
MAXTYP = 21
NTYPES = MIN( MAXTYP, NTYPES )
CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
CALL XLAENV( 9, 25 )
DO 310 I = 1, NPARMS
CALL XLAENV( 1, NBVAL( I ) )
CALL XLAENV( 2, NBMIN( I ) )
CALL XLAENV( 3, NXVAL( I ) )
*
IF( NEWSD.EQ.0 ) THEN
DO 300 K = 1, 4
ISEED( K ) = IOLDSD( K )
300 CONTINUE
END IF
WRITE( NOUT, FMT = 9997 )C3, NBVAL( I ), NBMIN( I ),
$ NXVAL( I )
IF( TSTCHK ) THEN
CALL DDRVSG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH,
$ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX,
$ D( 1, 3 ), A( 1, 3 ), NMAX, A( 1, 4 ),
$ A( 1, 5 ), A( 1, 6 ), A( 1, 7 ), WORK,
$ LWORK, IWORK, LIWORK, RESULT, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'DDRVSG', INFO
END IF
310 CONTINUE
*
ELSE IF( LSAMEN( 3, C3, 'DBD' ) .OR. LSAMEN( 3, C3, 'SVD' ) ) THEN
*
* ----------------------------------
* SVD: Singular Value Decomposition
* ----------------------------------
* Vary the parameters
* NB = block size
* NBMIN = minimum block size
* NX = crossover point
* NRHS = number of right hand sides
*
MAXTYP = 16
NTYPES = MIN( MAXTYP, NTYPES )
CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
CALL XLAENV( 1, 1 )
CALL XLAENV( 9, 25 )
*
* Test the error exits
*
IF( TSTERR .AND. TSTCHK )
$ CALL DERRBD( 'DBD', NOUT )
IF( TSTERR .AND. TSTDRV )
$ CALL DERRED( 'DBD', NOUT )
*
DO 330 I = 1, NPARMS
NRHS = NSVAL( I )
CALL XLAENV( 1, NBVAL( I ) )
CALL XLAENV( 2, NBMIN( I ) )
CALL XLAENV( 3, NXVAL( I ) )
IF( NEWSD.EQ.0 ) THEN
DO 320 K = 1, 4
ISEED( K ) = IOLDSD( K )
320 CONTINUE
END IF
WRITE( NOUT, FMT = 9995 )C3, NBVAL( I ), NBMIN( I ),
$ NXVAL( I ), NRHS
IF( TSTCHK ) THEN
CALL DCHKBD( NN, MVAL, NVAL, MAXTYP, DOTYPE, NRHS, ISEED,
$ THRESH, A( 1, 1 ), NMAX, D( 1, 1 ),
$ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), A( 1, 2 ),
$ NMAX, A( 1, 3 ), A( 1, 4 ), A( 1, 5 ), NMAX,
$ A( 1, 6 ), NMAX, A( 1, 7 ), A( 1, 8 ), WORK,
$ LWORK, IWORK, NOUT, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'DCHKBD', INFO
END IF
IF( TSTDRV )
$ CALL DDRVBD( NN, MVAL, NVAL, MAXTYP, DOTYPE, ISEED,
$ THRESH, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX,
$ A( 1, 3 ), NMAX, A( 1, 4 ), A( 1, 5 ),
$ A( 1, 6 ), D( 1, 1 ), D( 1, 2 ), D( 1, 3 ),
$ WORK, LWORK, IWORK, NOUT, INFO )
330 CONTINUE
*
ELSE IF( LSAMEN( 3, C3, 'DEV' ) ) THEN
*
* --------------------------------------------
* DEV: Nonsymmetric Eigenvalue Problem Driver
* DGEEV (eigenvalues and eigenvectors)
* --------------------------------------------
*
MAXTYP = 21
NTYPES = MIN( MAXTYP, NTYPES )
IF( NTYPES.LE.0 ) THEN
WRITE( NOUT, FMT = 9990 )C3
ELSE
IF( TSTERR )
$ CALL DERRED( C3, NOUT )
CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
CALL DDRVEV( NN, NVAL, NTYPES, DOTYPE, ISEED, THRESH, NOUT,
$ A( 1, 1 ), NMAX, A( 1, 2 ), D( 1, 1 ),
$ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), A( 1, 3 ),
$ NMAX, A( 1, 4 ), NMAX, A( 1, 5 ), NMAX, RESULT,
$ WORK, LWORK, IWORK, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'DGEEV', INFO
END IF
WRITE( NOUT, FMT = 9973 )
GO TO 10
*
ELSE IF( LSAMEN( 3, C3, 'DES' ) ) THEN
*
* --------------------------------------------
* DES: Nonsymmetric Eigenvalue Problem Driver
* DGEES (Schur form)
* --------------------------------------------
*
MAXTYP = 21
NTYPES = MIN( MAXTYP, NTYPES )
IF( NTYPES.LE.0 ) THEN
WRITE( NOUT, FMT = 9990 )C3
ELSE
IF( TSTERR )
$ CALL DERRED( C3, NOUT )
CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
CALL DDRVES( NN, NVAL, NTYPES, DOTYPE, ISEED, THRESH, NOUT,
$ A( 1, 1 ), NMAX, A( 1, 2 ), A( 1, 3 ),
$ D( 1, 1 ), D( 1, 2 ), D( 1, 3 ), D( 1, 4 ),
$ A( 1, 4 ), NMAX, RESULT, WORK, LWORK, IWORK,
$ LOGWRK, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'DGEES', INFO
END IF
WRITE( NOUT, FMT = 9973 )
GO TO 10
*
ELSE IF( LSAMEN( 3, C3, 'DVX' ) ) THEN
*
* --------------------------------------------------------------
* DVX: Nonsymmetric Eigenvalue Problem Expert Driver
* DGEEVX (eigenvalues, eigenvectors and condition numbers)
* --------------------------------------------------------------
*
MAXTYP = 21
NTYPES = MIN( MAXTYP, NTYPES )
IF( NTYPES.LT.0 ) THEN
WRITE( NOUT, FMT = 9990 )C3
ELSE
IF( TSTERR )
$ CALL DERRED( C3, NOUT )
CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
CALL DDRVVX( NN, NVAL, NTYPES, DOTYPE, ISEED, THRESH, NIN,
$ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), D( 1, 1 ),
$ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), A( 1, 3 ),
$ NMAX, A( 1, 4 ), NMAX, A( 1, 5 ), NMAX,
$ D( 1, 5 ), D( 1, 6 ), D( 1, 7 ), D( 1, 8 ),
$ D( 1, 9 ), D( 1, 10 ), D( 1, 11 ), D( 1, 12 ),
$ RESULT, WORK, LWORK, IWORK, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'DGEEVX', INFO
END IF
WRITE( NOUT, FMT = 9973 )
GO TO 10
*
ELSE IF( LSAMEN( 3, C3, 'DSX' ) ) THEN
*
* ---------------------------------------------------
* DSX: Nonsymmetric Eigenvalue Problem Expert Driver
* DGEESX (Schur form and condition numbers)
* ---------------------------------------------------
*
MAXTYP = 21
NTYPES = MIN( MAXTYP, NTYPES )
IF( NTYPES.LT.0 ) THEN
WRITE( NOUT, FMT = 9990 )C3
ELSE
IF( TSTERR )
$ CALL DERRED( C3, NOUT )
CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
CALL DDRVSX( NN, NVAL, NTYPES, DOTYPE, ISEED, THRESH, NIN,
$ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), A( 1, 3 ),
$ D( 1, 1 ), D( 1, 2 ), D( 1, 3 ), D( 1, 4 ),
$ D( 1, 5 ), D( 1, 6 ), A( 1, 4 ), NMAX,
$ A( 1, 5 ), RESULT, WORK, LWORK, IWORK, LOGWRK,
$ INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'DGEESX', INFO
END IF
WRITE( NOUT, FMT = 9973 )
GO TO 10
*
ELSE IF( LSAMEN( 3, C3, 'DGG' ) ) THEN
*
* -------------------------------------------------
* DGG: Generalized Nonsymmetric Eigenvalue Problem
* -------------------------------------------------
* Vary the parameters
* NB = block size
* NBMIN = minimum block size
* NS = number of shifts
* MAXB = minimum submatrix size
* NBCOL = minimum column dimension for blocks
*
MAXTYP = 26
NTYPES = MIN( MAXTYP, NTYPES )
CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
IF( TSTCHK .AND. TSTERR )
$ CALL DERRGG( C3, NOUT )
DO 350 I = 1, NPARMS
CALL XLAENV( 1, NBVAL( I ) )
CALL XLAENV( 2, NBMIN( I ) )
CALL XLAENV( 4, NSVAL( I ) )
CALL XLAENV( 8, MXBVAL( I ) )
CALL XLAENV( 5, NBCOL( I ) )
*
IF( NEWSD.EQ.0 ) THEN
DO 340 K = 1, 4
ISEED( K ) = IOLDSD( K )
340 CONTINUE
END IF
WRITE( NOUT, FMT = 9996 )C3, NBVAL( I ), NBMIN( I ),
$ NSVAL( I ), MXBVAL( I ), NBCOL( I )
TSTDIF = .FALSE.
THRSHN = 10.D0
IF( TSTCHK ) THEN
CALL DCHKGG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH,
$ TSTDIF, THRSHN, NOUT, A( 1, 1 ), NMAX,
$ A( 1, 2 ), A( 1, 3 ), A( 1, 4 ), A( 1, 5 ),
$ A( 1, 6 ), A( 1, 7 ), A( 1, 8 ), A( 1, 9 ),
$ NMAX, A( 1, 10 ), A( 1, 11 ), A( 1, 12 ),
$ D( 1, 1 ), D( 1, 2 ), D( 1, 3 ), D( 1, 4 ),
$ D( 1, 5 ), D( 1, 6 ), A( 1, 13 ),
$ A( 1, 14 ), WORK, LWORK, LOGWRK, RESULT,
$ INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'DCHKGG', INFO
END IF
CALL XLAENV( 1, 1 )
IF( TSTDRV ) THEN
CALL DDRVGG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH,
$ THRSHN, NOUT, A( 1, 1 ), NMAX, A( 1, 2 ),
$ A( 1, 3 ), A( 1, 4 ), A( 1, 5 ), A( 1, 6 ),
$ A( 1, 7 ), NMAX, A( 1, 8 ), D( 1, 1 ),
$ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), D( 1, 5 ),
$ D( 1, 6 ), A( 1, 13 ), A( 1, 14 ), WORK,
$ LWORK, RESULT, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'DDRVGG', INFO
END IF
350 CONTINUE
*
ELSE IF( LSAMEN( 3, C3, 'DGS' ) ) THEN
*
* -------------------------------------------------
* DGS: Generalized Nonsymmetric Eigenvalue Problem
* DGGES (Schur form)
* -------------------------------------------------
*
MAXTYP = 26
NTYPES = MIN( MAXTYP, NTYPES )
IF( NTYPES.LE.0 ) THEN
WRITE( NOUT, FMT = 9990 )C3
ELSE
IF( TSTERR )
$ CALL DERRGG( C3, NOUT )
CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
CALL DDRGES( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, NOUT,
$ A( 1, 1 ), NMAX, A( 1, 2 ), A( 1, 3 ),
$ A( 1, 4 ), A( 1, 7 ), NMAX, A( 1, 8 ),
$ D( 1, 1 ), D( 1, 2 ), D( 1, 3 ), WORK, LWORK,
$ RESULT, LOGWRK, INFO )
*
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'DDRGES', INFO
END IF
WRITE( NOUT, FMT = 9973 )
GO TO 10
*
ELSE IF( DGX ) THEN
*
* -------------------------------------------------
* DGX: Generalized Nonsymmetric Eigenvalue Problem
* DGGESX (Schur form and condition numbers)
* -------------------------------------------------
*
MAXTYP = 5
NTYPES = MAXTYP
IF( NN.LT.0 ) THEN
WRITE( NOUT, FMT = 9990 )C3
ELSE
IF( TSTERR )
$ CALL DERRGG( C3, NOUT )
CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
CALL XLAENV( 5, 2 )
CALL DDRGSX( NN, NCMAX, THRESH, NIN, NOUT, A( 1, 1 ), NMAX,
$ A( 1, 2 ), A( 1, 3 ), A( 1, 4 ), A( 1, 5 ),
$ A( 1, 6 ), D( 1, 1 ), D( 1, 2 ), D( 1, 3 ),
$ C( 1, 1 ), NCMAX*NCMAX, A( 1, 12 ), WORK,
$ LWORK, IWORK, LIWORK, LOGWRK, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'DDRGSX', INFO
END IF
WRITE( NOUT, FMT = 9973 )
GO TO 10
*
ELSE IF( LSAMEN( 3, C3, 'DGV' ) ) THEN
*
* -------------------------------------------------
* DGV: Generalized Nonsymmetric Eigenvalue Problem
* DGGEV (Eigenvalue/vector form)
* -------------------------------------------------
*
MAXTYP = 26
NTYPES = MIN( MAXTYP, NTYPES )
IF( NTYPES.LE.0 ) THEN
WRITE( NOUT, FMT = 9990 )C3
ELSE
IF( TSTERR )
$ CALL DERRGG( C3, NOUT )
CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
CALL DDRGEV( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, NOUT,
$ A( 1, 1 ), NMAX, A( 1, 2 ), A( 1, 3 ),
$ A( 1, 4 ), A( 1, 7 ), NMAX, A( 1, 8 ),
$ A( 1, 9 ), NMAX, D( 1, 1 ), D( 1, 2 ),
$ D( 1, 3 ), D( 1, 4 ), D( 1, 5 ), D( 1, 6 ),
$ WORK, LWORK, RESULT, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'DDRGEV', INFO
END IF
WRITE( NOUT, FMT = 9973 )
GO TO 10
*
ELSE IF( DXV ) THEN
*
* -------------------------------------------------
* DXV: Generalized Nonsymmetric Eigenvalue Problem
* DGGEVX (eigenvalue/vector with condition numbers)
* -------------------------------------------------
*
MAXTYP = 2
NTYPES = MAXTYP
IF( NN.LT.0 ) THEN
WRITE( NOUT, FMT = 9990 )C3
ELSE
IF( TSTERR )
$ CALL DERRGG( C3, NOUT )
CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
CALL DDRGVX( NN, THRESH, NIN, NOUT, A( 1, 1 ), NMAX,
$ A( 1, 2 ), A( 1, 3 ), A( 1, 4 ), D( 1, 1 ),
$ D( 1, 2 ), D( 1, 3 ), A( 1, 5 ), A( 1, 6 ),
$ IWORK( 1 ), IWORK( 2 ), D( 1, 4 ), D( 1, 5 ),
$ D( 1, 6 ), D( 1, 7 ), D( 1, 8 ), D( 1, 9 ),
$ WORK, LWORK, IWORK( 3 ), LIWORK-2, RESULT,
$ LOGWRK, INFO )
*
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'DDRGVX', INFO
END IF
WRITE( NOUT, FMT = 9973 )
GO TO 10
*
ELSE IF( LSAMEN( 3, C3, 'DSB' ) ) THEN
*
* ------------------------------
* DSB: Symmetric Band Reduction
* ------------------------------
*
MAXTYP = 15
NTYPES = MIN( MAXTYP, NTYPES )
CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
IF( TSTERR )
$ CALL DERRST( 'DSB', NOUT )
CALL DCHKSB( NN, NVAL, NK, KVAL, MAXTYP, DOTYPE, ISEED, THRESH,
$ NOUT, A( 1, 1 ), NMAX, D( 1, 1 ), D( 1, 2 ),
$ A( 1, 2 ), NMAX, WORK, LWORK, RESULT, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'DCHKSB', INFO
*
ELSE IF( LSAMEN( 3, C3, 'DBB' ) ) THEN
*
* ------------------------------
* DBB: General Band Reduction
* ------------------------------
*
MAXTYP = 15
NTYPES = MIN( MAXTYP, NTYPES )
CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
DO 370 I = 1, NPARMS
NRHS = NSVAL( I )
*
IF( NEWSD.EQ.0 ) THEN
DO 360 K = 1, 4
ISEED( K ) = IOLDSD( K )
360 CONTINUE
END IF
WRITE( NOUT, FMT = 9966 )C3, NRHS
CALL DCHKBB( NN, MVAL, NVAL, NK, KVAL, MAXTYP, DOTYPE, NRHS,
$ ISEED, THRESH, NOUT, A( 1, 1 ), NMAX,
$ A( 1, 2 ), 2*NMAX, D( 1, 1 ), D( 1, 2 ),
$ A( 1, 4 ), NMAX, A( 1, 5 ), NMAX, A( 1, 6 ),
$ NMAX, A( 1, 7 ), WORK, LWORK, RESULT, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'DCHKBB', INFO
370 CONTINUE
*
ELSE IF( LSAMEN( 3, C3, 'GLM' ) ) THEN
*
* -----------------------------------------
* GLM: Generalized Linear Regression Model
* -----------------------------------------
*
CALL XLAENV( 1, 1 )
IF( TSTERR )
$ CALL DERRGG( 'GLM', NOUT )
CALL DCKGLM( NN, MVAL, PVAL, NVAL, NTYPES, ISEED, THRESH, NMAX,
$ A( 1, 1 ), A( 1, 2 ), B( 1, 1 ), B( 1, 2 ), X,
$ WORK, D( 1, 1 ), NIN, NOUT, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'DCKGLM', INFO
*
ELSE IF( LSAMEN( 3, C3, 'GQR' ) ) THEN
*
* ------------------------------------------
* GQR: Generalized QR and RQ factorizations
* ------------------------------------------
*
CALL XLAENV( 1, 1 )
IF( TSTERR )
$ CALL DERRGG( 'GQR', NOUT )
CALL DCKGQR( NN, MVAL, NN, PVAL, NN, NVAL, NTYPES, ISEED,
$ THRESH, NMAX, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
$ A( 1, 4 ), TAUA, B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
$ B( 1, 4 ), B( 1, 5 ), TAUB, WORK, D( 1, 1 ), NIN,
$ NOUT, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'DCKGQR', INFO
*
ELSE IF( LSAMEN( 3, C3, 'GSV' ) ) THEN
*
* ----------------------------------------------
* GSV: Generalized Singular Value Decomposition
* ----------------------------------------------
*
IF( TSTERR )
$ CALL DERRGG( 'GSV', NOUT )
CALL DCKGSV( NN, MVAL, PVAL, NVAL, NTYPES, ISEED, THRESH, NMAX,
$ A( 1, 1 ), A( 1, 2 ), B( 1, 1 ), B( 1, 2 ),
$ A( 1, 3 ), B( 1, 3 ), A( 1, 4 ), TAUA, TAUB,
$ B( 1, 4 ), IWORK, WORK, D( 1, 1 ), NIN, NOUT,
$ INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'DCKGSV', INFO
*
ELSE IF( LSAMEN( 3, C3, 'LSE' ) ) THEN
*
* --------------------------------------
* LSE: Constrained Linear Least Squares
* --------------------------------------
*
CALL XLAENV( 1, 1 )
IF( TSTERR )
$ CALL DERRGG( 'LSE', NOUT )
CALL DCKLSE( NN, MVAL, PVAL, NVAL, NTYPES, ISEED, THRESH, NMAX,
$ A( 1, 1 ), A( 1, 2 ), B( 1, 1 ), B( 1, 2 ), X,
$ WORK, D( 1, 1 ), NIN, NOUT, INFO )
IF( INFO.NE.0 )
$ WRITE( NOUT, FMT = 9980 )'DCKLSE', INFO
*
ELSE
WRITE( NOUT, FMT = * )
WRITE( NOUT, FMT = * )
WRITE( NOUT, FMT = 9992 )C3
END IF
IF( .NOT.( DGX .OR. DXV ) )
$ GO TO 190
380 CONTINUE
WRITE( NOUT, FMT = 9994 )
S2 = DSECND( )
WRITE( NOUT, FMT = 9993 )S2 - S1
*
9999 FORMAT( / ' Execution not attempted due to input errors' )
9998 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NX =', I4,
$ ', NS =', I4, ', MAXB =', I4 )
9997 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NX =', I4 )
9996 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NS =', I4,
$ ', MAXB =', I4, ', NBCOL =', I4 )
9995 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NX =', I4,
$ ', NRHS =', I4 )
9994 FORMAT( / / ' End of tests' )
9993 FORMAT( ' Total time used = ', F12.2, ' seconds', / )
9992 FORMAT( 1X, A3, ': Unrecognized path name' )
9991 FORMAT( / / ' *** Invalid integer value in column ', I2,
$ ' of input', ' line:', / A79 )
9990 FORMAT( / / 1X, A3, ' routines were not tested' )
9989 FORMAT( ' Invalid input value: ', A6, '=', I6, '; must be >=',
$ I6 )
9988 FORMAT( ' Invalid input value: ', A6, '=', I6, '; must be <=',
$ I6 )
9987 FORMAT( ' Tests of the Nonsymmetric Eigenvalue Problem routines' )
9986 FORMAT( ' Tests of the Symmetric Eigenvalue Problem routines' )
9985 FORMAT( ' Tests of the Singular Value Decomposition routines' )
9984 FORMAT( / ' The following parameter values will be used:' )
9983 FORMAT( 4X, A6, 10I6, / 10X, 10I6 )
9982 FORMAT( / ' Routines pass computational tests if test ratio is ',
$ 'less than', F8.2, / )
9981 FORMAT( ' Relative machine ', A, ' is taken to be', D16.6 )
9980 FORMAT( ' *** Error code from ', A6, ' = ', I4 )
9979 FORMAT( / ' Tests of the Nonsymmetric Eigenvalue Problem Driver',
$ / ' DGEEV (eigenvalues and eigevectors)' )
9978 FORMAT( / ' Tests of the Nonsymmetric Eigenvalue Problem Driver',
$ / ' DGEES (Schur form)' )
9977 FORMAT( / ' Tests of the Nonsymmetric Eigenvalue Problem Expert',
$ ' Driver', / ' DGEEVX (eigenvalues, eigenvectors and',
$ ' condition numbers)' )
9976 FORMAT( / ' Tests of the Nonsymmetric Eigenvalue Problem Expert',
$ ' Driver', / ' DGEESX (Schur form and condition',
$ ' numbers)' )
9975 FORMAT( / ' Tests of the Generalized Nonsymmetric Eigenvalue ',
$ 'Problem routines' )
9974 FORMAT( ' Tests of DSBTRD', / ' (reduction of a symmetric band ',
$ 'matrix to tridiagonal form)' )
9973 FORMAT( / 1X, 71( '-' ) )
9972 FORMAT( / ' LAPACK VERSION ', I1, '.', I1, '.', I1 )
9971 FORMAT( / ' Tests of the Generalized Linear Regression Model ',
$ 'routines' )
9970 FORMAT( / ' Tests of the Generalized QR and RQ routines' )
9969 FORMAT( / ' Tests of the Generalized Singular Value',
$ ' Decomposition routines' )
9968 FORMAT( / ' Tests of the Linear Least Squares routines' )
9967 FORMAT( ' Tests of DGBBRD', / ' (reduction of a general band ',
$ 'matrix to real bidiagonal form)' )
9966 FORMAT( / / 1X, A3, ': NRHS =', I4 )
9965 FORMAT( / ' Tests of the Generalized Nonsymmetric Eigenvalue ',
$ 'Problem Expert Driver DGGESX' )
9964 FORMAT( / ' Tests of the Generalized Nonsymmetric Eigenvalue ',
$ 'Problem Driver DGGES' )
9963 FORMAT( / ' Tests of the Generalized Nonsymmetric Eigenvalue ',
$ 'Problem Driver DGGEV' )
9962 FORMAT( / ' Tests of the Generalized Nonsymmetric Eigenvalue ',
$ 'Problem Expert Driver DGGEVX' )
9961 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NX =', I4,
$ ', INMIN=', I4,
$ ', INWIN =', I4, ', INIBL =', I4, ', ISHFTS =', I4,
$ ', IACC22 =', I4)
*
* End of DCHKEE
*
END
SUBROUTINE DCHKGG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
$ TSTDIF, THRSHN, NOUNIT, A, LDA, B, H, T, S1,
$ S2, P1, P2, U, LDU, V, Q, Z, ALPHR1, ALPHI1,
$ BETA1, ALPHR3, ALPHI3, BETA3, EVECTL, EVECTR,
$ WORK, LWORK, LLWORK, RESULT, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL TSTDIF
INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES
DOUBLE PRECISION THRESH, THRSHN
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * ), LLWORK( * )
INTEGER ISEED( 4 ), NN( * )
DOUBLE PRECISION A( LDA, * ), ALPHI1( * ), ALPHI3( * ),
$ ALPHR1( * ), ALPHR3( * ), B( LDA, * ),
$ BETA1( * ), BETA3( * ), EVECTL( LDU, * ),
$ EVECTR( LDU, * ), H( LDA, * ), P1( LDA, * ),
$ P2( LDA, * ), Q( LDU, * ), RESULT( 15 ),
$ S1( LDA, * ), S2( LDA, * ), T( LDA, * ),
$ U( LDU, * ), V( LDU, * ), WORK( * ),
$ Z( LDU, * )
* ..
*
* Purpose
* =======
*
* DCHKGG checks the nonsymmetric generalized eigenvalue problem
* routines.
* T T T
* DGGHRD factors A and B as U H V and U T V , where means
* transpose, H is hessenberg, T is triangular and U and V are
* orthogonal.
* T T
* DHGEQZ factors H and T as Q S Z and Q P Z , where P is upper
* triangular, S is in generalized Schur form (block upper triangular,
* with 1x1 and 2x2 blocks on the diagonal, the 2x2 blocks
* corresponding to complex conjugate pairs of generalized
* eigenvalues), and Q and Z are orthogonal. It also computes the
* generalized eigenvalues (alpha(1),beta(1)),...,(alpha(n),beta(n)),
* where alpha(j)=S(j,j) and beta(j)=P(j,j) -- thus,
* w(j) = alpha(j)/beta(j) is a root of the generalized eigenvalue
* problem
*
* det( A - w(j) B ) = 0
*
* and m(j) = beta(j)/alpha(j) is a root of the essentially equivalent
* problem
*
* det( m(j) A - B ) = 0
*
* DTGEVC computes the matrix L of left eigenvectors and the matrix R
* of right eigenvectors for the matrix pair ( S, P ). In the
* description below, l and r are left and right eigenvectors
* corresponding to the generalized eigenvalues (alpha,beta).
*
* When DCHKGG is called, a number of matrix "sizes" ("n's") and a
* number of matrix "types" are specified. For each size ("n")
* and each type of matrix, one matrix will be generated and used
* to test the nonsymmetric eigenroutines. For each matrix, 15
* tests will be performed. The first twelve "test ratios" should be
* small -- O(1). They will be compared with the threshhold THRESH:
*
* T
* (1) | A - U H V | / ( |A| n ulp )
*
* T
* (2) | B - U T V | / ( |B| n ulp )
*
* T
* (3) | I - UU | / ( n ulp )
*
* T
* (4) | I - VV | / ( n ulp )
*
* T
* (5) | H - Q S Z | / ( |H| n ulp )
*
* T
* (6) | T - Q P Z | / ( |T| n ulp )
*
* T
* (7) | I - QQ | / ( n ulp )
*
* T
* (8) | I - ZZ | / ( n ulp )
*
* (9) max over all left eigenvalue/-vector pairs (beta/alpha,l) of
*
* | l**H * (beta S - alpha P) | / ( ulp max( |beta S|, |alpha P| ) )
*
* (10) max over all left eigenvalue/-vector pairs (beta/alpha,l') of
* T
* | l'**H * (beta H - alpha T) | / ( ulp max( |beta H|, |alpha T| ) )
*
* where the eigenvectors l' are the result of passing Q to
* DTGEVC and back transforming (HOWMNY='B').
*
* (11) max over all right eigenvalue/-vector pairs (beta/alpha,r) of
*
* | (beta S - alpha T) r | / ( ulp max( |beta S|, |alpha T| ) )
*
* (12) max over all right eigenvalue/-vector pairs (beta/alpha,r') of
*
* | (beta H - alpha T) r' | / ( ulp max( |beta H|, |alpha T| ) )
*
* where the eigenvectors r' are the result of passing Z to
* DTGEVC and back transforming (HOWMNY='B').
*
* The last three test ratios will usually be small, but there is no
* mathematical requirement that they be so. They are therefore
* compared with THRESH only if TSTDIF is .TRUE.
*
* (13) | S(Q,Z computed) - S(Q,Z not computed) | / ( |S| ulp )
*
* (14) | P(Q,Z computed) - P(Q,Z not computed) | / ( |P| ulp )
*
* (15) max( |alpha(Q,Z computed) - alpha(Q,Z not computed)|/|S| ,
* |beta(Q,Z computed) - beta(Q,Z not computed)|/|P| ) / ulp
*
* In addition, the normalization of L and R are checked, and compared
* with the threshhold THRSHN.
*
* Test Matrices
* ---- --------
*
* The sizes of the test matrices are specified by an array
* NN(1:NSIZES); the value of each element NN(j) specifies one size.
* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if
* DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
* Currently, the list of possible types is:
*
* (1) ( 0, 0 ) (a pair of zero matrices)
*
* (2) ( I, 0 ) (an identity and a zero matrix)
*
* (3) ( 0, I ) (an identity and a zero matrix)
*
* (4) ( I, I ) (a pair of identity matrices)
*
* t t
* (5) ( J , J ) (a pair of transposed Jordan blocks)
*
* t ( I 0 )
* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t )
* ( 0 I ) ( 0 J )
* and I is a k x k identity and J a (k+1)x(k+1)
* Jordan block; k=(N-1)/2
*
* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal
* matrix with those diagonal entries.)
* (8) ( I, D )
*
* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big
*
* (10) ( small*D, big*I )
*
* (11) ( big*I, small*D )
*
* (12) ( small*I, big*D )
*
* (13) ( big*D, big*I )
*
* (14) ( small*D, small*I )
*
* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and
* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 )
* t t
* (16) U ( J , J ) V where U and V are random orthogonal matrices.
*
* (17) U ( T1, T2 ) V where T1 and T2 are upper triangular matrices
* with random O(1) entries above the diagonal
* and diagonal entries diag(T1) =
* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) =
* ( 0, N-3, N-4,..., 1, 0, 0 )
*
* (18) U ( T1, T2 ) V diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 )
* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 )
* s = machine precision.
*
* (19) U ( T1, T2 ) V diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 )
* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 )
*
* N-5
* (20) U ( T1, T2 ) V diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 )
* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
*
* (21) U ( T1, T2 ) V diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 )
* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
* where r1,..., r(N-4) are random.
*
* (22) U ( big*T1, small*T2 ) V diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (23) U ( small*T1, big*T2 ) V diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (24) U ( small*T1, small*T2 ) V diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (25) U ( big*T1, big*T2 ) V diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (26) U ( T1, T2 ) V where T1 and T2 are random upper-triangular
* matrices.
*
* Arguments
* =========
*
* NSIZES (input) INTEGER
* The number of sizes of matrices to use. If it is zero,
* DCHKGG does nothing. It must be at least zero.
*
* NN (input) INTEGER array, dimension (NSIZES)
* An array containing the sizes to be used for the matrices.
* Zero values will be skipped. The values must be at least
* zero.
*
* NTYPES (input) INTEGER
* The number of elements in DOTYPE. If it is zero, DCHKGG
* does nothing. It must be at least zero. If it is MAXTYP+1
* and NSIZES is 1, then an additional type, MAXTYP+1 is
* defined, which is to use whatever matrix is in A. This
* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
* DOTYPE(MAXTYP+1) is .TRUE. .
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* If DOTYPE(j) is .TRUE., then for each size in NN a
* matrix of that size and of type j will be generated.
* If NTYPES is smaller than the maximum number of types
* defined (PARAMETER MAXTYP), then types NTYPES+1 through
* MAXTYP will not be generated. If NTYPES is larger
* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
* will be ignored.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The array elements should be between 0 and 4095;
* if not they will be reduced mod 4096. Also, ISEED(4) must
* be odd. The random number generator uses a linear
* congruential sequence limited to small integers, and so
* should produce machine independent random numbers. The
* values of ISEED are changed on exit, and can be used in the
* next call to DCHKGG to continue the same random number
* sequence.
*
* THRESH (input) DOUBLE PRECISION
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error is
* scaled to be O(1), so THRESH should be a reasonably small
* multiple of 1, e.g., 10 or 100. In particular, it should
* not depend on the precision (single vs. double) or the size
* of the matrix. It must be at least zero.
*
* TSTDIF (input) LOGICAL
* Specifies whether test ratios 13-15 will be computed and
* compared with THRESH.
* = .FALSE.: Only test ratios 1-12 will be computed and tested.
* Ratios 13-15 will be set to zero.
* = .TRUE.: All the test ratios 1-15 will be computed and
* tested.
*
* THRSHN (input) DOUBLE PRECISION
* Threshhold for reporting eigenvector normalization error.
* If the normalization of any eigenvector differs from 1 by
* more than THRSHN*ulp, then a special error message will be
* printed. (This is handled separately from the other tests,
* since only a compiler or programming error should cause an
* error message, at least if THRSHN is at least 5--10.)
*
* NOUNIT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns IINFO not equal to 0.)
*
* A (input/workspace) DOUBLE PRECISION array, dimension
* (LDA, max(NN))
* Used to hold the original A matrix. Used as input only
* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
* DOTYPE(MAXTYP+1)=.TRUE.
*
* LDA (input) INTEGER
* The leading dimension of A, B, H, T, S1, P1, S2, and P2.
* It must be at least 1 and at least max( NN ).
*
* B (input/workspace) DOUBLE PRECISION array, dimension
* (LDA, max(NN))
* Used to hold the original B matrix. Used as input only
* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
* DOTYPE(MAXTYP+1)=.TRUE.
*
* H (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
* The upper Hessenberg matrix computed from A by DGGHRD.
*
* T (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
* The upper triangular matrix computed from B by DGGHRD.
*
* S1 (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
* The Schur (block upper triangular) matrix computed from H by
* DHGEQZ when Q and Z are also computed.
*
* S2 (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
* The Schur (block upper triangular) matrix computed from H by
* DHGEQZ when Q and Z are not computed.
*
* P1 (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
* The upper triangular matrix computed from T by DHGEQZ
* when Q and Z are also computed.
*
* P2 (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
* The upper triangular matrix computed from T by DHGEQZ
* when Q and Z are not computed.
*
* U (workspace) DOUBLE PRECISION array, dimension (LDU, max(NN))
* The (left) orthogonal matrix computed by DGGHRD.
*
* LDU (input) INTEGER
* The leading dimension of U, V, Q, Z, EVECTL, and EVEZTR. It
* must be at least 1 and at least max( NN ).
*
* V (workspace) DOUBLE PRECISION array, dimension (LDU, max(NN))
* The (right) orthogonal matrix computed by DGGHRD.
*
* Q (workspace) DOUBLE PRECISION array, dimension (LDU, max(NN))
* The (left) orthogonal matrix computed by DHGEQZ.
*
* Z (workspace) DOUBLE PRECISION array, dimension (LDU, max(NN))
* The (left) orthogonal matrix computed by DHGEQZ.
*
* ALPHR1 (workspace) DOUBLE PRECISION array, dimension (max(NN))
* ALPHI1 (workspace) DOUBLE PRECISION array, dimension (max(NN))
* BETA1 (workspace) DOUBLE PRECISION array, dimension (max(NN))
*
* The generalized eigenvalues of (A,B) computed by DHGEQZ
* when Q, Z, and the full Schur matrices are computed.
* On exit, ( ALPHR1(k)+ALPHI1(k)*i ) / BETA1(k) is the k-th
* generalized eigenvalue of the matrices in A and B.
*
* ALPHR3 (workspace) DOUBLE PRECISION array, dimension (max(NN))
* ALPHI3 (workspace) DOUBLE PRECISION array, dimension (max(NN))
* BETA3 (workspace) DOUBLE PRECISION array, dimension (max(NN))
*
* EVECTL (workspace) DOUBLE PRECISION array, dimension (LDU, max(NN))
* The (block lower triangular) left eigenvector matrix for
* the matrices in S1 and P1. (See DTGEVC for the format.)
*
* EVEZTR (workspace) DOUBLE PRECISION array, dimension (LDU, max(NN))
* The (block upper triangular) right eigenvector matrix for
* the matrices in S1 and P1. (See DTGEVC for the format.)
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The number of entries in WORK. This must be at least
* max( 2 * N**2, 6*N, 1 ), for all N=NN(j).
*
* LLWORK (workspace) LOGICAL array, dimension (max(NN))
*
* RESULT (output) DOUBLE PRECISION array, dimension (15)
* The values computed by the tests described above.
* The values are currently limited to 1/ulp, to avoid
* overflow.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: A routine returned an error code. INFO is the
* absolute value of the INFO value returned.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 26 )
* ..
* .. Local Scalars ..
LOGICAL BADNN
INTEGER I1, IADD, IINFO, IN, J, JC, JR, JSIZE, JTYPE,
$ LWKOPT, MTYPES, N, N1, NERRS, NMATS, NMAX,
$ NTEST, NTESTT
DOUBLE PRECISION ANORM, BNORM, SAFMAX, SAFMIN, TEMP1, TEMP2,
$ ULP, ULPINV
* ..
* .. Local Arrays ..
INTEGER IASIGN( MAXTYP ), IBSIGN( MAXTYP ),
$ IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ),
$ KATYPE( MAXTYP ), KAZERO( MAXTYP ),
$ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ),
$ KBZERO( MAXTYP ), KCLASS( MAXTYP ),
$ KTRIAN( MAXTYP ), KZ1( 6 ), KZ2( 6 )
DOUBLE PRECISION DUMMA( 4 ), RMAGN( 0: 3 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE, DLARND
EXTERNAL DLAMCH, DLANGE, DLARND
* ..
* .. External Subroutines ..
EXTERNAL DGEQR2, DGET51, DGET52, DGGHRD, DHGEQZ, DLABAD,
$ DLACPY, DLARFG, DLASET, DLASUM, DLATM4, DORM2R,
$ DTGEVC, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN, SIGN
* ..
* .. Data statements ..
DATA KCLASS / 15*1, 10*2, 1*3 /
DATA KZ1 / 0, 1, 2, 1, 3, 3 /
DATA KZ2 / 0, 0, 1, 2, 1, 1 /
DATA KADD / 0, 0, 0, 0, 3, 2 /
DATA KATYPE / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4,
$ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 /
DATA KBTYPE / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4,
$ 1, 1, -4, 2, -4, 8*8, 0 /
DATA KAZERO / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3,
$ 4*5, 4*3, 1 /
DATA KBZERO / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4,
$ 4*6, 4*4, 1 /
DATA KAMAGN / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3,
$ 2, 1 /
DATA KBMAGN / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3,
$ 2, 1 /
DATA KTRIAN / 16*0, 10*1 /
DATA IASIGN / 6*0, 2, 0, 2*2, 2*0, 3*2, 0, 2, 3*0,
$ 5*2, 0 /
DATA IBSIGN / 7*0, 2, 2*0, 2*2, 2*0, 2, 0, 2, 9*0 /
* ..
* .. Executable Statements ..
*
* Check for errors
*
INFO = 0
*
BADNN = .FALSE.
NMAX = 1
DO 10 J = 1, NSIZES
NMAX = MAX( NMAX, NN( J ) )
IF( NN( J ).LT.0 )
$ BADNN = .TRUE.
10 CONTINUE
*
* Maximum blocksize and shift -- we assume that blocksize and number
* of shifts are monotone increasing functions of N.
*
LWKOPT = MAX( 6*NMAX, 2*NMAX*NMAX, 1 )
*
* Check for errors
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADNN ) THEN
INFO = -2
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -3
ELSE IF( THRESH.LT.ZERO ) THEN
INFO = -6
ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN
INFO = -10
ELSE IF( LDU.LE.1 .OR. LDU.LT.NMAX ) THEN
INFO = -19
ELSE IF( LWKOPT.GT.LWORK ) THEN
INFO = -30
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DCHKGG', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
$ RETURN
*
SAFMIN = DLAMCH( 'Safe minimum' )
ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
SAFMIN = SAFMIN / ULP
SAFMAX = ONE / SAFMIN
CALL DLABAD( SAFMIN, SAFMAX )
ULPINV = ONE / ULP
*
* The values RMAGN(2:3) depend on N, see below.
*
RMAGN( 0 ) = ZERO
RMAGN( 1 ) = ONE
*
* Loop over sizes, types
*
NTESTT = 0
NERRS = 0
NMATS = 0
*
DO 240 JSIZE = 1, NSIZES
N = NN( JSIZE )
N1 = MAX( 1, N )
RMAGN( 2 ) = SAFMAX*ULP / DBLE( N1 )
RMAGN( 3 ) = SAFMIN*ULPINV*N1
*
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
DO 230 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 230
NMATS = NMATS + 1
NTEST = 0
*
* Save ISEED in case of an error.
*
DO 20 J = 1, 4
IOLDSD( J ) = ISEED( J )
20 CONTINUE
*
* Initialize RESULT
*
DO 30 J = 1, 15
RESULT( J ) = ZERO
30 CONTINUE
*
* Compute A and B
*
* Description of control parameters:
*
* KZLASS: =1 means w/o rotation, =2 means w/ rotation,
* =3 means random.
* KATYPE: the "type" to be passed to DLATM4 for computing A.
* KAZERO: the pattern of zeros on the diagonal for A:
* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ),
* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ),
* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of
* non-zero entries.)
* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1),
* =2: large, =3: small.
* IASIGN: 1 if the diagonal elements of A are to be
* multiplied by a random magnitude 1 number, =2 if
* randomly chosen diagonal blocks are to be rotated
* to form 2x2 blocks.
* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B.
* KTRIAN: =0: don't fill in the upper triangle, =1: do.
* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO.
* RMAGN: used to implement KAMAGN and KBMAGN.
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 110
IINFO = 0
IF( KCLASS( JTYPE ).LT.3 ) THEN
*
* Generate A (w/o rotation)
*
IF( ABS( KATYPE( JTYPE ) ).EQ.3 ) THEN
IN = 2*( ( N-1 ) / 2 ) + 1
IF( IN.NE.N )
$ CALL DLASET( 'Full', N, N, ZERO, ZERO, A, LDA )
ELSE
IN = N
END IF
CALL DLATM4( KATYPE( JTYPE ), IN, KZ1( KAZERO( JTYPE ) ),
$ KZ2( KAZERO( JTYPE ) ), IASIGN( JTYPE ),
$ RMAGN( KAMAGN( JTYPE ) ), ULP,
$ RMAGN( KTRIAN( JTYPE )*KAMAGN( JTYPE ) ), 2,
$ ISEED, A, LDA )
IADD = KADD( KAZERO( JTYPE ) )
IF( IADD.GT.0 .AND. IADD.LE.N )
$ A( IADD, IADD ) = RMAGN( KAMAGN( JTYPE ) )
*
* Generate B (w/o rotation)
*
IF( ABS( KBTYPE( JTYPE ) ).EQ.3 ) THEN
IN = 2*( ( N-1 ) / 2 ) + 1
IF( IN.NE.N )
$ CALL DLASET( 'Full', N, N, ZERO, ZERO, B, LDA )
ELSE
IN = N
END IF
CALL DLATM4( KBTYPE( JTYPE ), IN, KZ1( KBZERO( JTYPE ) ),
$ KZ2( KBZERO( JTYPE ) ), IBSIGN( JTYPE ),
$ RMAGN( KBMAGN( JTYPE ) ), ONE,
$ RMAGN( KTRIAN( JTYPE )*KBMAGN( JTYPE ) ), 2,
$ ISEED, B, LDA )
IADD = KADD( KBZERO( JTYPE ) )
IF( IADD.NE.0 .AND. IADD.LE.N )
$ B( IADD, IADD ) = RMAGN( KBMAGN( JTYPE ) )
*
IF( KCLASS( JTYPE ).EQ.2 .AND. N.GT.0 ) THEN
*
* Include rotations
*
* Generate U, V as Householder transformations times
* a diagonal matrix.
*
DO 50 JC = 1, N - 1
DO 40 JR = JC, N
U( JR, JC ) = DLARND( 3, ISEED )
V( JR, JC ) = DLARND( 3, ISEED )
40 CONTINUE
CALL DLARFG( N+1-JC, U( JC, JC ), U( JC+1, JC ), 1,
$ WORK( JC ) )
WORK( 2*N+JC ) = SIGN( ONE, U( JC, JC ) )
U( JC, JC ) = ONE
CALL DLARFG( N+1-JC, V( JC, JC ), V( JC+1, JC ), 1,
$ WORK( N+JC ) )
WORK( 3*N+JC ) = SIGN( ONE, V( JC, JC ) )
V( JC, JC ) = ONE
50 CONTINUE
U( N, N ) = ONE
WORK( N ) = ZERO
WORK( 3*N ) = SIGN( ONE, DLARND( 2, ISEED ) )
V( N, N ) = ONE
WORK( 2*N ) = ZERO
WORK( 4*N ) = SIGN( ONE, DLARND( 2, ISEED ) )
*
* Apply the diagonal matrices
*
DO 70 JC = 1, N
DO 60 JR = 1, N
A( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
$ A( JR, JC )
B( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
$ B( JR, JC )
60 CONTINUE
70 CONTINUE
CALL DORM2R( 'L', 'N', N, N, N-1, U, LDU, WORK, A,
$ LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
CALL DORM2R( 'R', 'T', N, N, N-1, V, LDU, WORK( N+1 ),
$ A, LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
CALL DORM2R( 'L', 'N', N, N, N-1, U, LDU, WORK, B,
$ LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
CALL DORM2R( 'R', 'T', N, N, N-1, V, LDU, WORK( N+1 ),
$ B, LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
END IF
ELSE
*
* Random matrices
*
DO 90 JC = 1, N
DO 80 JR = 1, N
A( JR, JC ) = RMAGN( KAMAGN( JTYPE ) )*
$ DLARND( 2, ISEED )
B( JR, JC ) = RMAGN( KBMAGN( JTYPE ) )*
$ DLARND( 2, ISEED )
80 CONTINUE
90 CONTINUE
END IF
*
ANORM = DLANGE( '1', N, N, A, LDA, WORK )
BNORM = DLANGE( '1', N, N, B, LDA, WORK )
*
100 CONTINUE
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
110 CONTINUE
*
* Call DGEQR2, DORM2R, and DGGHRD to compute H, T, U, and V
*
CALL DLACPY( ' ', N, N, A, LDA, H, LDA )
CALL DLACPY( ' ', N, N, B, LDA, T, LDA )
NTEST = 1
RESULT( 1 ) = ULPINV
*
CALL DGEQR2( N, N, T, LDA, WORK, WORK( N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DGEQR2', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
*
CALL DORM2R( 'L', 'T', N, N, N, T, LDA, WORK, H, LDA,
$ WORK( N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DORM2R', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
*
CALL DLASET( 'Full', N, N, ZERO, ONE, U, LDU )
CALL DORM2R( 'R', 'N', N, N, N, T, LDA, WORK, U, LDU,
$ WORK( N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DORM2R', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
*
CALL DGGHRD( 'V', 'I', N, 1, N, H, LDA, T, LDA, U, LDU, V,
$ LDU, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DGGHRD', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
NTEST = 4
*
* Do tests 1--4
*
CALL DGET51( 1, N, A, LDA, H, LDA, U, LDU, V, LDU, WORK,
$ RESULT( 1 ) )
CALL DGET51( 1, N, B, LDA, T, LDA, U, LDU, V, LDU, WORK,
$ RESULT( 2 ) )
CALL DGET51( 3, N, B, LDA, T, LDA, U, LDU, U, LDU, WORK,
$ RESULT( 3 ) )
CALL DGET51( 3, N, B, LDA, T, LDA, V, LDU, V, LDU, WORK,
$ RESULT( 4 ) )
*
* Call DHGEQZ to compute S1, P1, S2, P2, Q, and Z, do tests.
*
* Compute T1 and UZ
*
* Eigenvalues only
*
CALL DLACPY( ' ', N, N, H, LDA, S2, LDA )
CALL DLACPY( ' ', N, N, T, LDA, P2, LDA )
NTEST = 5
RESULT( 5 ) = ULPINV
*
CALL DHGEQZ( 'E', 'N', 'N', N, 1, N, S2, LDA, P2, LDA,
$ ALPHR3, ALPHI3, BETA3, Q, LDU, Z, LDU, WORK,
$ LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DHGEQZ(E)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
*
* Eigenvalues and Full Schur Form
*
CALL DLACPY( ' ', N, N, H, LDA, S2, LDA )
CALL DLACPY( ' ', N, N, T, LDA, P2, LDA )
*
CALL DHGEQZ( 'S', 'N', 'N', N, 1, N, S2, LDA, P2, LDA,
$ ALPHR1, ALPHI1, BETA1, Q, LDU, Z, LDU, WORK,
$ LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DHGEQZ(S)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
*
* Eigenvalues, Schur Form, and Schur Vectors
*
CALL DLACPY( ' ', N, N, H, LDA, S1, LDA )
CALL DLACPY( ' ', N, N, T, LDA, P1, LDA )
*
CALL DHGEQZ( 'S', 'I', 'I', N, 1, N, S1, LDA, P1, LDA,
$ ALPHR1, ALPHI1, BETA1, Q, LDU, Z, LDU, WORK,
$ LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DHGEQZ(V)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
*
NTEST = 8
*
* Do Tests 5--8
*
CALL DGET51( 1, N, H, LDA, S1, LDA, Q, LDU, Z, LDU, WORK,
$ RESULT( 5 ) )
CALL DGET51( 1, N, T, LDA, P1, LDA, Q, LDU, Z, LDU, WORK,
$ RESULT( 6 ) )
CALL DGET51( 3, N, T, LDA, P1, LDA, Q, LDU, Q, LDU, WORK,
$ RESULT( 7 ) )
CALL DGET51( 3, N, T, LDA, P1, LDA, Z, LDU, Z, LDU, WORK,
$ RESULT( 8 ) )
*
* Compute the Left and Right Eigenvectors of (S1,P1)
*
* 9: Compute the left eigenvector Matrix without
* back transforming:
*
NTEST = 9
RESULT( 9 ) = ULPINV
*
* To test "SELECT" option, compute half of the eigenvectors
* in one call, and half in another
*
I1 = N / 2
DO 120 J = 1, I1
LLWORK( J ) = .TRUE.
120 CONTINUE
DO 130 J = I1 + 1, N
LLWORK( J ) = .FALSE.
130 CONTINUE
*
CALL DTGEVC( 'L', 'S', LLWORK, N, S1, LDA, P1, LDA, EVECTL,
$ LDU, DUMMA, LDU, N, IN, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DTGEVC(L,S1)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
*
I1 = IN
DO 140 J = 1, I1
LLWORK( J ) = .FALSE.
140 CONTINUE
DO 150 J = I1 + 1, N
LLWORK( J ) = .TRUE.
150 CONTINUE
*
CALL DTGEVC( 'L', 'S', LLWORK, N, S1, LDA, P1, LDA,
$ EVECTL( 1, I1+1 ), LDU, DUMMA, LDU, N, IN,
$ WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DTGEVC(L,S2)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
*
CALL DGET52( .TRUE., N, S1, LDA, P1, LDA, EVECTL, LDU,
$ ALPHR1, ALPHI1, BETA1, WORK, DUMMA( 1 ) )
RESULT( 9 ) = DUMMA( 1 )
IF( DUMMA( 2 ).GT.THRSHN ) THEN
WRITE( NOUNIT, FMT = 9998 )'Left', 'DTGEVC(HOWMNY=S)',
$ DUMMA( 2 ), N, JTYPE, IOLDSD
END IF
*
* 10: Compute the left eigenvector Matrix with
* back transforming:
*
NTEST = 10
RESULT( 10 ) = ULPINV
CALL DLACPY( 'F', N, N, Q, LDU, EVECTL, LDU )
CALL DTGEVC( 'L', 'B', LLWORK, N, S1, LDA, P1, LDA, EVECTL,
$ LDU, DUMMA, LDU, N, IN, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DTGEVC(L,B)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
*
CALL DGET52( .TRUE., N, H, LDA, T, LDA, EVECTL, LDU, ALPHR1,
$ ALPHI1, BETA1, WORK, DUMMA( 1 ) )
RESULT( 10 ) = DUMMA( 1 )
IF( DUMMA( 2 ).GT.THRSHN ) THEN
WRITE( NOUNIT, FMT = 9998 )'Left', 'DTGEVC(HOWMNY=B)',
$ DUMMA( 2 ), N, JTYPE, IOLDSD
END IF
*
* 11: Compute the right eigenvector Matrix without
* back transforming:
*
NTEST = 11
RESULT( 11 ) = ULPINV
*
* To test "SELECT" option, compute half of the eigenvectors
* in one call, and half in another
*
I1 = N / 2
DO 160 J = 1, I1
LLWORK( J ) = .TRUE.
160 CONTINUE
DO 170 J = I1 + 1, N
LLWORK( J ) = .FALSE.
170 CONTINUE
*
CALL DTGEVC( 'R', 'S', LLWORK, N, S1, LDA, P1, LDA, DUMMA,
$ LDU, EVECTR, LDU, N, IN, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DTGEVC(R,S1)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
*
I1 = IN
DO 180 J = 1, I1
LLWORK( J ) = .FALSE.
180 CONTINUE
DO 190 J = I1 + 1, N
LLWORK( J ) = .TRUE.
190 CONTINUE
*
CALL DTGEVC( 'R', 'S', LLWORK, N, S1, LDA, P1, LDA, DUMMA,
$ LDU, EVECTR( 1, I1+1 ), LDU, N, IN, WORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DTGEVC(R,S2)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
*
CALL DGET52( .FALSE., N, S1, LDA, P1, LDA, EVECTR, LDU,
$ ALPHR1, ALPHI1, BETA1, WORK, DUMMA( 1 ) )
RESULT( 11 ) = DUMMA( 1 )
IF( DUMMA( 2 ).GT.THRESH ) THEN
WRITE( NOUNIT, FMT = 9998 )'Right', 'DTGEVC(HOWMNY=S)',
$ DUMMA( 2 ), N, JTYPE, IOLDSD
END IF
*
* 12: Compute the right eigenvector Matrix with
* back transforming:
*
NTEST = 12
RESULT( 12 ) = ULPINV
CALL DLACPY( 'F', N, N, Z, LDU, EVECTR, LDU )
CALL DTGEVC( 'R', 'B', LLWORK, N, S1, LDA, P1, LDA, DUMMA,
$ LDU, EVECTR, LDU, N, IN, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DTGEVC(R,B)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
*
CALL DGET52( .FALSE., N, H, LDA, T, LDA, EVECTR, LDU,
$ ALPHR1, ALPHI1, BETA1, WORK, DUMMA( 1 ) )
RESULT( 12 ) = DUMMA( 1 )
IF( DUMMA( 2 ).GT.THRESH ) THEN
WRITE( NOUNIT, FMT = 9998 )'Right', 'DTGEVC(HOWMNY=B)',
$ DUMMA( 2 ), N, JTYPE, IOLDSD
END IF
*
* Tests 13--15 are done only on request
*
IF( TSTDIF ) THEN
*
* Do Tests 13--14
*
CALL DGET51( 2, N, S1, LDA, S2, LDA, Q, LDU, Z, LDU,
$ WORK, RESULT( 13 ) )
CALL DGET51( 2, N, P1, LDA, P2, LDA, Q, LDU, Z, LDU,
$ WORK, RESULT( 14 ) )
*
* Do Test 15
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 200 J = 1, N
TEMP1 = MAX( TEMP1, ABS( ALPHR1( J )-ALPHR3( J ) )+
$ ABS( ALPHI1( J )-ALPHI3( J ) ) )
TEMP2 = MAX( TEMP2, ABS( BETA1( J )-BETA3( J ) ) )
200 CONTINUE
*
TEMP1 = TEMP1 / MAX( SAFMIN, ULP*MAX( TEMP1, ANORM ) )
TEMP2 = TEMP2 / MAX( SAFMIN, ULP*MAX( TEMP2, BNORM ) )
RESULT( 15 ) = MAX( TEMP1, TEMP2 )
NTEST = 15
ELSE
RESULT( 13 ) = ZERO
RESULT( 14 ) = ZERO
RESULT( 15 ) = ZERO
NTEST = 12
END IF
*
* End of Loop -- Check for RESULT(j) > THRESH
*
210 CONTINUE
*
NTESTT = NTESTT + NTEST
*
* Print out tests which fail.
*
DO 220 JR = 1, NTEST
IF( RESULT( JR ).GE.THRESH ) THEN
*
* If this is the first test to fail,
* print a header to the data file.
*
IF( NERRS.EQ.0 ) THEN
WRITE( NOUNIT, FMT = 9997 )'DGG'
*
* Matrix types
*
WRITE( NOUNIT, FMT = 9996 )
WRITE( NOUNIT, FMT = 9995 )
WRITE( NOUNIT, FMT = 9994 )'Orthogonal'
*
* Tests performed
*
WRITE( NOUNIT, FMT = 9993 )'orthogonal', '''',
$ 'transpose', ( '''', J = 1, 10 )
*
END IF
NERRS = NERRS + 1
IF( RESULT( JR ).LT.10000.0D0 ) THEN
WRITE( NOUNIT, FMT = 9992 )N, JTYPE, IOLDSD, JR,
$ RESULT( JR )
ELSE
WRITE( NOUNIT, FMT = 9991 )N, JTYPE, IOLDSD, JR,
$ RESULT( JR )
END IF
END IF
220 CONTINUE
*
230 CONTINUE
240 CONTINUE
*
* Summary
*
CALL DLASUM( 'DGG', NOUNIT, NERRS, NTESTT )
RETURN
*
9999 FORMAT( ' DCHKGG: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
*
9998 FORMAT( ' DCHKGG: ', A, ' Eigenvectors from ', A, ' incorrectly ',
$ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 9X,
$ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5,
$ ')' )
*
9997 FORMAT( / 1X, A3, ' -- Real Generalized eigenvalue problem' )
*
9996 FORMAT( ' Matrix types (see DCHKGG for details): ' )
*
9995 FORMAT( ' Special Matrices:', 23X,
$ '(J''=transposed Jordan block)',
$ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ',
$ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ',
$ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I',
$ ') 11=(large*I, small*D) 13=(large*D, large*I)', /
$ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ',
$ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' )
9994 FORMAT( ' Matrices Rotated by Random ', A, ' Matrices U, V:',
$ / ' 16=Transposed Jordan Blocks 19=geometric ',
$ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ',
$ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ',
$ 'alpha, beta=0,1 21=random alpha, beta=0,1',
$ / ' Large & Small Matrices:', / ' 22=(large, small) ',
$ '23=(small,large) 24=(small,small) 25=(large,large)',
$ / ' 26=random O(1) matrices.' )
*
9993 FORMAT( / ' Tests performed: (H is Hessenberg, S is Schur, B, ',
$ 'T, P are triangular,', / 20X, 'U, V, Q, and Z are ', A,
$ ', l and r are the', / 20X,
$ 'appropriate left and right eigenvectors, resp., a is',
$ / 20X, 'alpha, b is beta, and ', A, ' means ', A, '.)',
$ / ' 1 = | A - U H V', A,
$ ' | / ( |A| n ulp ) 2 = | B - U T V', A,
$ ' | / ( |B| n ulp )', / ' 3 = | I - UU', A,
$ ' | / ( n ulp ) 4 = | I - VV', A,
$ ' | / ( n ulp )', / ' 5 = | H - Q S Z', A,
$ ' | / ( |H| n ulp )', 6X, '6 = | T - Q P Z', A,
$ ' | / ( |T| n ulp )', / ' 7 = | I - QQ', A,
$ ' | / ( n ulp ) 8 = | I - ZZ', A,
$ ' | / ( n ulp )', / ' 9 = max | ( b S - a P )', A,
$ ' l | / const. 10 = max | ( b H - a T )', A,
$ ' l | / const.', /
$ ' 11= max | ( b S - a P ) r | / const. 12 = max | ( b H',
$ ' - a T ) r | / const.', / 1X )
*
9992 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
$ 4( I4, ',' ), ' result ', I2, ' is', 0P, F8.2 )
9991 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
$ 4( I4, ',' ), ' result ', I2, ' is', 1P, D10.3 )
*
* End of DCHKGG
*
END
SUBROUTINE DCHKGK( NIN, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER NIN, NOUT
* ..
*
* Purpose
* =======
*
* DCHKGK tests DGGBAK, a routine for backward balancing of
* a matrix pair (A, B).
*
* Arguments
* =========
*
* NIN (input) INTEGER
* The logical unit number for input. NIN > 0.
*
* NOUT (input) INTEGER
* The logical unit number for output. NOUT > 0.
*
* =====================================================================
*
* .. Parameters ..
INTEGER LDA, LDB, LDVL, LDVR
PARAMETER ( LDA = 50, LDB = 50, LDVL = 50, LDVR = 50 )
INTEGER LDE, LDF, LDWORK
PARAMETER ( LDE = 50, LDF = 50, LDWORK = 50 )
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, IHI, ILO, INFO, J, KNT, M, N, NINFO
DOUBLE PRECISION ANORM, BNORM, EPS, RMAX, VMAX
* ..
* .. Local Arrays ..
INTEGER LMAX( 4 )
DOUBLE PRECISION A( LDA, LDA ), AF( LDA, LDA ), B( LDB, LDB ),
$ BF( LDB, LDB ), E( LDE, LDE ), F( LDF, LDF ),
$ LSCALE( LDA ), RSCALE( LDA ), VL( LDVL, LDVL ),
$ VLF( LDVL, LDVL ), VR( LDVR, LDVR ),
$ VRF( LDVR, LDVR ), WORK( LDWORK, LDWORK )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DGGBAK, DGGBAL, DLACPY
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Initialization
*
LMAX( 1 ) = 0
LMAX( 2 ) = 0
LMAX( 3 ) = 0
LMAX( 4 ) = 0
NINFO = 0
KNT = 0
RMAX = ZERO
*
EPS = DLAMCH( 'Precision' )
*
10 CONTINUE
READ( NIN, FMT = * )N, M
IF( N.EQ.0 )
$ GO TO 100
*
DO 20 I = 1, N
READ( NIN, FMT = * )( A( I, J ), J = 1, N )
20 CONTINUE
*
DO 30 I = 1, N
READ( NIN, FMT = * )( B( I, J ), J = 1, N )
30 CONTINUE
*
DO 40 I = 1, N
READ( NIN, FMT = * )( VL( I, J ), J = 1, M )
40 CONTINUE
*
DO 50 I = 1, N
READ( NIN, FMT = * )( VR( I, J ), J = 1, M )
50 CONTINUE
*
KNT = KNT + 1
*
ANORM = DLANGE( 'M', N, N, A, LDA, WORK )
BNORM = DLANGE( 'M', N, N, B, LDB, WORK )
*
CALL DLACPY( 'FULL', N, N, A, LDA, AF, LDA )
CALL DLACPY( 'FULL', N, N, B, LDB, BF, LDB )
*
CALL DGGBAL( 'B', N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE,
$ WORK, INFO )
IF( INFO.NE.0 ) THEN
NINFO = NINFO + 1
LMAX( 1 ) = KNT
END IF
*
CALL DLACPY( 'FULL', N, M, VL, LDVL, VLF, LDVL )
CALL DLACPY( 'FULL', N, M, VR, LDVR, VRF, LDVR )
*
CALL DGGBAK( 'B', 'L', N, ILO, IHI, LSCALE, RSCALE, M, VL, LDVL,
$ INFO )
IF( INFO.NE.0 ) THEN
NINFO = NINFO + 1
LMAX( 2 ) = KNT
END IF
*
CALL DGGBAK( 'B', 'R', N, ILO, IHI, LSCALE, RSCALE, M, VR, LDVR,
$ INFO )
IF( INFO.NE.0 ) THEN
NINFO = NINFO + 1
LMAX( 3 ) = KNT
END IF
*
* Test of DGGBAK
*
* Check tilde(VL)'*A*tilde(VR) - VL'*tilde(A)*VR
* where tilde(A) denotes the transformed matrix.
*
CALL DGEMM( 'N', 'N', N, M, N, ONE, AF, LDA, VR, LDVR, ZERO, WORK,
$ LDWORK )
CALL DGEMM( 'T', 'N', M, M, N, ONE, VL, LDVL, WORK, LDWORK, ZERO,
$ E, LDE )
*
CALL DGEMM( 'N', 'N', N, M, N, ONE, A, LDA, VRF, LDVR, ZERO, WORK,
$ LDWORK )
CALL DGEMM( 'T', 'N', M, M, N, ONE, VLF, LDVL, WORK, LDWORK, ZERO,
$ F, LDF )
*
VMAX = ZERO
DO 70 J = 1, M
DO 60 I = 1, M
VMAX = MAX( VMAX, ABS( E( I, J )-F( I, J ) ) )
60 CONTINUE
70 CONTINUE
VMAX = VMAX / ( EPS*MAX( ANORM, BNORM ) )
IF( VMAX.GT.RMAX ) THEN
LMAX( 4 ) = KNT
RMAX = VMAX
END IF
*
* Check tilde(VL)'*B*tilde(VR) - VL'*tilde(B)*VR
*
CALL DGEMM( 'N', 'N', N, M, N, ONE, BF, LDB, VR, LDVR, ZERO, WORK,
$ LDWORK )
CALL DGEMM( 'T', 'N', M, M, N, ONE, VL, LDVL, WORK, LDWORK, ZERO,
$ E, LDE )
*
CALL DGEMM( 'N', 'N', N, M, N, ONE, B, LDB, VRF, LDVR, ZERO, WORK,
$ LDWORK )
CALL DGEMM( 'T', 'N', M, M, N, ONE, VLF, LDVL, WORK, LDWORK, ZERO,
$ F, LDF )
*
VMAX = ZERO
DO 90 J = 1, M
DO 80 I = 1, M
VMAX = MAX( VMAX, ABS( E( I, J )-F( I, J ) ) )
80 CONTINUE
90 CONTINUE
VMAX = VMAX / ( EPS*MAX( ANORM, BNORM ) )
IF( VMAX.GT.RMAX ) THEN
LMAX( 4 ) = KNT
RMAX = VMAX
END IF
*
GO TO 10
*
100 CONTINUE
*
WRITE( NOUT, FMT = 9999 )
9999 FORMAT( 1X, '.. test output of DGGBAK .. ' )
*
WRITE( NOUT, FMT = 9998 )RMAX
9998 FORMAT( ' value of largest test error =', D12.3 )
WRITE( NOUT, FMT = 9997 )LMAX( 1 )
9997 FORMAT( ' example number where DGGBAL info is not 0 =', I4 )
WRITE( NOUT, FMT = 9996 )LMAX( 2 )
9996 FORMAT( ' example number where DGGBAK(L) info is not 0 =', I4 )
WRITE( NOUT, FMT = 9995 )LMAX( 3 )
9995 FORMAT( ' example number where DGGBAK(R) info is not 0 =', I4 )
WRITE( NOUT, FMT = 9994 )LMAX( 4 )
9994 FORMAT( ' example number having largest error =', I4 )
WRITE( NOUT, FMT = 9993 )NINFO
9993 FORMAT( ' number of examples where info is not 0 =', I4 )
WRITE( NOUT, FMT = 9992 )KNT
9992 FORMAT( ' total number of examples tested =', I4 )
*
RETURN
*
* End of DCHKGK
*
END
SUBROUTINE DCHKGL( NIN, NOUT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER NIN, NOUT
* ..
*
* Purpose
* =======
*
* DCHKGL tests DGGBAL, a routine for balancing a matrix pair (A, B).
*
* Arguments
* =========
*
* NIN (input) INTEGER
* The logical unit number for input. NIN > 0.
*
* NOUT (input) INTEGER
* The logical unit number for output. NOUT > 0.
*
* =====================================================================
*
* .. Parameters ..
INTEGER LDA, LDB, LWORK
PARAMETER ( LDA = 20, LDB = 20, LWORK = 6*LDA )
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, IHI, IHIIN, ILO, ILOIN, INFO, J, KNT, N,
$ NINFO
DOUBLE PRECISION ANORM, BNORM, EPS, RMAX, VMAX
* ..
* .. Local Arrays ..
INTEGER LMAX( 5 )
DOUBLE PRECISION A( LDA, LDA ), AIN( LDA, LDA ), B( LDB, LDB ),
$ BIN( LDB, LDB ), LSCALE( LDA ), LSCLIN( LDA ),
$ RSCALE( LDA ), RSCLIN( LDA ), WORK( LWORK )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DGGBAL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
LMAX( 1 ) = 0
LMAX( 2 ) = 0
LMAX( 3 ) = 0
NINFO = 0
KNT = 0
RMAX = ZERO
*
EPS = DLAMCH( 'Precision' )
*
10 CONTINUE
*
READ( NIN, FMT = * )N
IF( N.EQ.0 )
$ GO TO 90
DO 20 I = 1, N
READ( NIN, FMT = * )( A( I, J ), J = 1, N )
20 CONTINUE
*
DO 30 I = 1, N
READ( NIN, FMT = * )( B( I, J ), J = 1, N )
30 CONTINUE
*
READ( NIN, FMT = * )ILOIN, IHIIN
DO 40 I = 1, N
READ( NIN, FMT = * )( AIN( I, J ), J = 1, N )
40 CONTINUE
DO 50 I = 1, N
READ( NIN, FMT = * )( BIN( I, J ), J = 1, N )
50 CONTINUE
*
READ( NIN, FMT = * )( LSCLIN( I ), I = 1, N )
READ( NIN, FMT = * )( RSCLIN( I ), I = 1, N )
*
ANORM = DLANGE( 'M', N, N, A, LDA, WORK )
BNORM = DLANGE( 'M', N, N, B, LDB, WORK )
*
KNT = KNT + 1
*
CALL DGGBAL( 'B', N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE,
$ WORK, INFO )
*
IF( INFO.NE.0 ) THEN
NINFO = NINFO + 1
LMAX( 1 ) = KNT
END IF
*
IF( ILO.NE.ILOIN .OR. IHI.NE.IHIIN ) THEN
NINFO = NINFO + 1
LMAX( 2 ) = KNT
END IF
*
VMAX = ZERO
DO 70 I = 1, N
DO 60 J = 1, N
VMAX = MAX( VMAX, ABS( A( I, J )-AIN( I, J ) ) )
VMAX = MAX( VMAX, ABS( B( I, J )-BIN( I, J ) ) )
60 CONTINUE
70 CONTINUE
*
DO 80 I = 1, N
VMAX = MAX( VMAX, ABS( LSCALE( I )-LSCLIN( I ) ) )
VMAX = MAX( VMAX, ABS( RSCALE( I )-RSCLIN( I ) ) )
80 CONTINUE
*
VMAX = VMAX / ( EPS*MAX( ANORM, BNORM ) )
*
IF( VMAX.GT.RMAX ) THEN
LMAX( 3 ) = KNT
RMAX = VMAX
END IF
*
GO TO 10
*
90 CONTINUE
*
WRITE( NOUT, FMT = 9999 )
9999 FORMAT( 1X, '.. test output of DGGBAL .. ' )
*
WRITE( NOUT, FMT = 9998 )RMAX
9998 FORMAT( 1X, 'value of largest test error = ', D12.3 )
WRITE( NOUT, FMT = 9997 )LMAX( 1 )
9997 FORMAT( 1X, 'example number where info is not zero = ', I4 )
WRITE( NOUT, FMT = 9996 )LMAX( 2 )
9996 FORMAT( 1X, 'example number where ILO or IHI wrong = ', I4 )
WRITE( NOUT, FMT = 9995 )LMAX( 3 )
9995 FORMAT( 1X, 'example number having largest error = ', I4 )
WRITE( NOUT, FMT = 9994 )NINFO
9994 FORMAT( 1X, 'number of examples where info is not 0 = ', I4 )
WRITE( NOUT, FMT = 9993 )KNT
9993 FORMAT( 1X, 'total number of examples tested = ', I4 )
*
RETURN
*
* End of DCHKGL
*
END
SUBROUTINE DCHKHS( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
$ NOUNIT, A, LDA, H, T1, T2, U, LDU, Z, UZ, WR1,
$ WI1, WR3, WI3, EVECTL, EVECTR, EVECTY, EVECTX,
$ UU, TAU, WORK, NWORK, IWORK, SELECT, RESULT,
$ INFO )
*
* -- LAPACK test routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* February 2007
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDU, NOUNIT, NSIZES, NTYPES, NWORK
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * ), SELECT( * )
INTEGER ISEED( 4 ), IWORK( * ), NN( * )
DOUBLE PRECISION A( LDA, * ), EVECTL( LDU, * ),
$ EVECTR( LDU, * ), EVECTX( LDU, * ),
$ EVECTY( LDU, * ), H( LDA, * ), RESULT( 14 ),
$ T1( LDA, * ), T2( LDA, * ), TAU( * ),
$ U( LDU, * ), UU( LDU, * ), UZ( LDU, * ),
$ WI1( * ), WI3( * ), WORK( * ), WR1( * ),
$ WR3( * ), Z( LDU, * )
* ..
*
* Purpose
* =======
*
* DCHKHS checks the nonsymmetric eigenvalue problem routines.
*
* DGEHRD factors A as U H U' , where ' means transpose,
* H is hessenberg, and U is an orthogonal matrix.
*
* DORGHR generates the orthogonal matrix U.
*
* DORMHR multiplies a matrix by the orthogonal matrix U.
*
* DHSEQR factors H as Z T Z' , where Z is orthogonal and
* T is "quasi-triangular", and the eigenvalue vector W.
*
* DTREVC computes the left and right eigenvector matrices
* L and R for T.
*
* DHSEIN computes the left and right eigenvector matrices
* Y and X for H, using inverse iteration.
*
* When DCHKHS is called, a number of matrix "sizes" ("n's") and a
* number of matrix "types" are specified. For each size ("n")
* and each type of matrix, one matrix will be generated and used
* to test the nonsymmetric eigenroutines. For each matrix, 14
* tests will be performed:
*
* (1) | A - U H U**T | / ( |A| n ulp )
*
* (2) | I - UU**T | / ( n ulp )
*
* (3) | H - Z T Z**T | / ( |H| n ulp )
*
* (4) | I - ZZ**T | / ( n ulp )
*
* (5) | A - UZ H (UZ)**T | / ( |A| n ulp )
*
* (6) | I - UZ (UZ)**T | / ( n ulp )
*
* (7) | T(Z computed) - T(Z not computed) | / ( |T| ulp )
*
* (8) | W(Z computed) - W(Z not computed) | / ( |W| ulp )
*
* (9) | TR - RW | / ( |T| |R| ulp )
*
* (10) | L**H T - W**H L | / ( |T| |L| ulp )
*
* (11) | HX - XW | / ( |H| |X| ulp )
*
* (12) | Y**H H - W**H Y | / ( |H| |Y| ulp )
*
* (13) | AX - XW | / ( |A| |X| ulp )
*
* (14) | Y**H A - W**H Y | / ( |A| |Y| ulp )
*
* The "sizes" are specified by an array NN(1:NSIZES); the value of
* each element NN(j) specifies one size.
* The "types" are specified by a logical array DOTYPE( 1:NTYPES );
* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
* Currently, the list of possible types is:
*
* (1) The zero matrix.
* (2) The identity matrix.
* (3) A (transposed) Jordan block, with 1's on the diagonal.
*
* (4) A diagonal matrix with evenly spaced entries
* 1, ..., ULP and random signs.
* (ULP = (first number larger than 1) - 1 )
* (5) A diagonal matrix with geometrically spaced entries
* 1, ..., ULP and random signs.
* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
* and random signs.
*
* (7) Same as (4), but multiplied by SQRT( overflow threshold )
* (8) Same as (4), but multiplied by SQRT( underflow threshold )
*
* (9) A matrix of the form U' T U, where U is orthogonal and
* T has evenly spaced entries 1, ..., ULP with random signs
* on the diagonal and random O(1) entries in the upper
* triangle.
*
* (10) A matrix of the form U' T U, where U is orthogonal and
* T has geometrically spaced entries 1, ..., ULP with random
* signs on the diagonal and random O(1) entries in the upper
* triangle.
*
* (11) A matrix of the form U' T U, where U is orthogonal and
* T has "clustered" entries 1, ULP,..., ULP with random
* signs on the diagonal and random O(1) entries in the upper
* triangle.
*
* (12) A matrix of the form U' T U, where U is orthogonal and
* T has real or complex conjugate paired eigenvalues randomly
* chosen from ( ULP, 1 ) and random O(1) entries in the upper
* triangle.
*
* (13) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP
* with random signs on the diagonal and random O(1) entries
* in the upper triangle.
*
* (14) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has geometrically spaced entries
* 1, ..., ULP with random signs on the diagonal and random
* O(1) entries in the upper triangle.
*
* (15) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP
* with random signs on the diagonal and random O(1) entries
* in the upper triangle.
*
* (16) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has real or complex conjugate paired
* eigenvalues randomly chosen from ( ULP, 1 ) and random
* O(1) entries in the upper triangle.
*
* (17) Same as (16), but multiplied by SQRT( overflow threshold )
* (18) Same as (16), but multiplied by SQRT( underflow threshold )
*
* (19) Nonsymmetric matrix with random entries chosen from (-1,1).
* (20) Same as (19), but multiplied by SQRT( overflow threshold )
* (21) Same as (19), but multiplied by SQRT( underflow threshold )
*
* Arguments
* ==========
*
* NSIZES - INTEGER
* The number of sizes of matrices to use. If it is zero,
* DCHKHS does nothing. It must be at least zero.
* Not modified.
*
* NN - INTEGER array, dimension (NSIZES)
* An array containing the sizes to be used for the matrices.
* Zero values will be skipped. The values must be at least
* zero.
* Not modified.
*
* NTYPES - INTEGER
* The number of elements in DOTYPE. If it is zero, DCHKHS
* does nothing. It must be at least zero. If it is MAXTYP+1
* and NSIZES is 1, then an additional type, MAXTYP+1 is
* defined, which is to use whatever matrix is in A. This
* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
* DOTYPE(MAXTYP+1) is .TRUE. .
* Not modified.
*
* DOTYPE - LOGICAL array, dimension (NTYPES)
* If DOTYPE(j) is .TRUE., then for each size in NN a
* matrix of that size and of type j will be generated.
* If NTYPES is smaller than the maximum number of types
* defined (PARAMETER MAXTYP), then types NTYPES+1 through
* MAXTYP will not be generated. If NTYPES is larger
* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
* will be ignored.
* Not modified.
*
* ISEED - INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The array elements should be between 0 and 4095;
* if not they will be reduced mod 4096. Also, ISEED(4) must
* be odd. The random number generator uses a linear
* congruential sequence limited to small integers, and so
* should produce machine independent random numbers. The
* values of ISEED are changed on exit, and can be used in the
* next call to DCHKHS to continue the same random number
* sequence.
* Modified.
*
* THRESH - DOUBLE PRECISION
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error
* is scaled to be O(1), so THRESH should be a reasonably
* small multiple of 1, e.g., 10 or 100. In particular,
* it should not depend on the precision (single vs. double)
* or the size of the matrix. It must be at least zero.
* Not modified.
*
* NOUNIT - INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns IINFO not equal to 0.)
* Not modified.
*
* A - DOUBLE PRECISION array, dimension (LDA,max(NN))
* Used to hold the matrix whose eigenvalues are to be
* computed. On exit, A contains the last matrix actually
* used.
* Modified.
*
* LDA - INTEGER
* The leading dimension of A, H, T1 and T2. It must be at
* least 1 and at least max( NN ).
* Not modified.
*
* H - DOUBLE PRECISION array, dimension (LDA,max(NN))
* The upper hessenberg matrix computed by DGEHRD. On exit,
* H contains the Hessenberg form of the matrix in A.
* Modified.
*
* T1 - DOUBLE PRECISION array, dimension (LDA,max(NN))
* The Schur (="quasi-triangular") matrix computed by DHSEQR
* if Z is computed. On exit, T1 contains the Schur form of
* the matrix in A.
* Modified.
*
* T2 - DOUBLE PRECISION array, dimension (LDA,max(NN))
* The Schur matrix computed by DHSEQR when Z is not computed.
* This should be identical to T1.
* Modified.
*
* LDU - INTEGER
* The leading dimension of U, Z, UZ and UU. It must be at
* least 1 and at least max( NN ).
* Not modified.
*
* U - DOUBLE PRECISION array, dimension (LDU,max(NN))
* The orthogonal matrix computed by DGEHRD.
* Modified.
*
* Z - DOUBLE PRECISION array, dimension (LDU,max(NN))
* The orthogonal matrix computed by DHSEQR.
* Modified.
*
* UZ - DOUBLE PRECISION array, dimension (LDU,max(NN))
* The product of U times Z.
* Modified.
*
* WR1 - DOUBLE PRECISION array, dimension (max(NN))
* WI1 - DOUBLE PRECISION array, dimension (max(NN))
* The real and imaginary parts of the eigenvalues of A,
* as computed when Z is computed.
* On exit, WR1 + WI1*i are the eigenvalues of the matrix in A.
* Modified.
*
* WR3 - DOUBLE PRECISION array, dimension (max(NN))
* WI3 - DOUBLE PRECISION array, dimension (max(NN))
* Like WR1, WI1, these arrays contain the eigenvalues of A,
* but those computed when DHSEQR only computes the
* eigenvalues, i.e., not the Schur vectors and no more of the
* Schur form than is necessary for computing the
* eigenvalues.
* Modified.
*
* EVECTL - DOUBLE PRECISION array, dimension (LDU,max(NN))
* The (upper triangular) left eigenvector matrix for the
* matrix in T1. For complex conjugate pairs, the real part
* is stored in one row and the imaginary part in the next.
* Modified.
*
* EVEZTR - DOUBLE PRECISION array, dimension (LDU,max(NN))
* The (upper triangular) right eigenvector matrix for the
* matrix in T1. For complex conjugate pairs, the real part
* is stored in one column and the imaginary part in the next.
* Modified.
*
* EVECTY - DOUBLE PRECISION array, dimension (LDU,max(NN))
* The left eigenvector matrix for the
* matrix in H. For complex conjugate pairs, the real part
* is stored in one row and the imaginary part in the next.
* Modified.
*
* EVECTX - DOUBLE PRECISION array, dimension (LDU,max(NN))
* The right eigenvector matrix for the
* matrix in H. For complex conjugate pairs, the real part
* is stored in one column and the imaginary part in the next.
* Modified.
*
* UU - DOUBLE PRECISION array, dimension (LDU,max(NN))
* Details of the orthogonal matrix computed by DGEHRD.
* Modified.
*
* TAU - DOUBLE PRECISION array, dimension(max(NN))
* Further details of the orthogonal matrix computed by DGEHRD.
* Modified.
*
* WORK - DOUBLE PRECISION array, dimension (NWORK)
* Workspace.
* Modified.
*
* NWORK - INTEGER
* The number of entries in WORK. NWORK >= 4*NN(j)*NN(j) + 2.
*
* IWORK - INTEGER array, dimension (max(NN))
* Workspace.
* Modified.
*
* SELECT - LOGICAL array, dimension (max(NN))
* Workspace.
* Modified.
*
* RESULT - DOUBLE PRECISION array, dimension (14)
* The values computed by the fourteen tests described above.
* The values are currently limited to 1/ulp, to avoid
* overflow.
* Modified.
*
* INFO - INTEGER
* If 0, then everything ran OK.
* -1: NSIZES < 0
* -2: Some NN(j) < 0
* -3: NTYPES < 0
* -6: THRESH < 0
* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
* -14: LDU < 1 or LDU < NMAX.
* -28: NWORK too small.
* If DLATMR, SLATMS, or SLATME returns an error code, the
* absolute value of it is returned.
* If 1, then DHSEQR could not find all the shifts.
* If 2, then the EISPACK code (for small blocks) failed.
* If >2, then 30*N iterations were not enough to find an
* eigenvalue or to decompose the problem.
* Modified.
*
*-----------------------------------------------------------------------
*
* Some Local Variables and Parameters:
* ---- ----- --------- --- ----------
*
* ZERO, ONE Real 0 and 1.
* MAXTYP The number of types defined.
* MTEST The number of tests defined: care must be taken
* that (1) the size of RESULT, (2) the number of
* tests actually performed, and (3) MTEST agree.
* NTEST The number of tests performed on this matrix
* so far. This should be less than MTEST, and
* equal to it by the last test. It will be less
* if any of the routines being tested indicates
* that it could not compute the matrices that
* would be tested.
* NMAX Largest value in NN.
* NMATS The number of matrices generated so far.
* NERRS The number of tests which have exceeded THRESH
* so far (computed by DLAFTS).
* COND, CONDS,
* IMODE Values to be passed to the matrix generators.
* ANORM Norm of A; passed to matrix generators.
*
* OVFL, UNFL Overflow and underflow thresholds.
* ULP, ULPINV Finest relative precision and its inverse.
* RTOVFL, RTUNFL,
* RTULP, RTULPI Square roots of the previous 4 values.
*
* The following four arrays decode JTYPE:
* KTYPE(j) The general type (1-10) for type "j".
* KMODE(j) The MODE value to be passed to the matrix
* generator for type "j".
* KMAGN(j) The order of magnitude ( O(1),
* O(overflow^(1/2) ), O(underflow^(1/2) )
* KCONDS(j) Selects whether CONDS is to be 1 or
* 1/sqrt(ulp). (0 means irrelevant.)
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 21 )
* ..
* .. Local Scalars ..
LOGICAL BADNN, MATCH
INTEGER I, IHI, IINFO, ILO, IMODE, IN, ITYPE, J, JCOL,
$ JJ, JSIZE, JTYPE, K, MTYPES, N, N1, NERRS,
$ NMATS, NMAX, NSELC, NSELR, NTEST, NTESTT
DOUBLE PRECISION ANINV, ANORM, COND, CONDS, OVFL, RTOVFL, RTULP,
$ RTULPI, RTUNFL, TEMP1, TEMP2, ULP, ULPINV, UNFL
* ..
* .. Local Arrays ..
CHARACTER ADUMMA( 1 )
INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( MAXTYP ),
$ KMAGN( MAXTYP ), KMODE( MAXTYP ),
$ KTYPE( MAXTYP )
DOUBLE PRECISION DUMMA( 6 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEHRD, DGEMM, DGET10, DGET22, DHSEIN,
$ DHSEQR, DHST01, DLABAD, DLACPY, DLAFTS, DLASET,
$ DLASUM, DLATME, DLATMR, DLATMS, DORGHR, DORMHR,
$ DTREVC, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN, SQRT
* ..
* .. Data statements ..
DATA KTYPE / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
DATA KMAGN / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
$ 3, 1, 2, 3 /
DATA KMODE / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
$ 1, 5, 5, 5, 4, 3, 1 /
DATA KCONDS / 3*0, 5*0, 4*1, 6*2, 3*0 /
* ..
* .. Executable Statements ..
*
* Check for errors
*
NTESTT = 0
INFO = 0
*
BADNN = .FALSE.
NMAX = 0
DO 10 J = 1, NSIZES
NMAX = MAX( NMAX, NN( J ) )
IF( NN( J ).LT.0 )
$ BADNN = .TRUE.
10 CONTINUE
*
* Check for errors
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADNN ) THEN
INFO = -2
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -3
ELSE IF( THRESH.LT.ZERO ) THEN
INFO = -6
ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN
INFO = -9
ELSE IF( LDU.LE.1 .OR. LDU.LT.NMAX ) THEN
INFO = -14
ELSE IF( 4*NMAX*NMAX+2.GT.NWORK ) THEN
INFO = -28
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DCHKHS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
$ RETURN
*
* More important constants
*
UNFL = DLAMCH( 'Safe minimum' )
OVFL = DLAMCH( 'Overflow' )
CALL DLABAD( UNFL, OVFL )
ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
ULPINV = ONE / ULP
RTUNFL = SQRT( UNFL )
RTOVFL = SQRT( OVFL )
RTULP = SQRT( ULP )
RTULPI = ONE / RTULP
*
* Loop over sizes, types
*
NERRS = 0
NMATS = 0
*
DO 270 JSIZE = 1, NSIZES
N = NN( JSIZE )
IF( N.EQ.0 )
$ GO TO 270
N1 = MAX( 1, N )
ANINV = ONE / DBLE( N1 )
*
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
DO 260 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 260
NMATS = NMATS + 1
NTEST = 0
*
* Save ISEED in case of an error.
*
DO 20 J = 1, 4
IOLDSD( J ) = ISEED( J )
20 CONTINUE
*
* Initialize RESULT
*
DO 30 J = 1, 14
RESULT( J ) = ZERO
30 CONTINUE
*
* Compute "A"
*
* Control parameters:
*
* KMAGN KCONDS KMODE KTYPE
* =1 O(1) 1 clustered 1 zero
* =2 large large clustered 2 identity
* =3 small exponential Jordan
* =4 arithmetic diagonal, (w/ eigenvalues)
* =5 random log symmetric, w/ eigenvalues
* =6 random general, w/ eigenvalues
* =7 random diagonal
* =8 random symmetric
* =9 random general
* =10 random triangular
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 100
*
ITYPE = KTYPE( JTYPE )
IMODE = KMODE( JTYPE )
*
* Compute norm
*
GO TO ( 40, 50, 60 )KMAGN( JTYPE )
*
40 CONTINUE
ANORM = ONE
GO TO 70
*
50 CONTINUE
ANORM = ( RTOVFL*ULP )*ANINV
GO TO 70
*
60 CONTINUE
ANORM = RTUNFL*N*ULPINV
GO TO 70
*
70 CONTINUE
*
CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
IINFO = 0
COND = ULPINV
*
* Special Matrices
*
IF( ITYPE.EQ.1 ) THEN
*
* Zero
*
IINFO = 0
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Identity
*
DO 80 JCOL = 1, N
A( JCOL, JCOL ) = ANORM
80 CONTINUE
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* Jordan Block
*
DO 90 JCOL = 1, N
A( JCOL, JCOL ) = ANORM
IF( JCOL.GT.1 )
$ A( JCOL, JCOL-1 ) = ONE
90 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Diagonal Matrix, [Eigen]values Specified
*
CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.5 ) THEN
*
* Symmetric, eigenvalues specified
*
CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, N, N, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.6 ) THEN
*
* General, eigenvalues specified
*
IF( KCONDS( JTYPE ).EQ.1 ) THEN
CONDS = ONE
ELSE IF( KCONDS( JTYPE ).EQ.2 ) THEN
CONDS = RTULPI
ELSE
CONDS = ZERO
END IF
*
ADUMMA( 1 ) = ' '
CALL DLATME( N, 'S', ISEED, WORK, IMODE, COND, ONE,
$ ADUMMA, 'T', 'T', 'T', WORK( N+1 ), 4,
$ CONDS, N, N, ANORM, A, LDA, WORK( 2*N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.7 ) THEN
*
* Diagonal, random eigenvalues
*
CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.8 ) THEN
*
* Symmetric, random eigenvalues
*
CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.9 ) THEN
*
* General, random eigenvalues
*
CALL DLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.10 ) THEN
*
* Triangular, random eigenvalues
*
CALL DLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, 0,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE
*
IINFO = 1
END IF
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
100 CONTINUE
*
* Call DGEHRD to compute H and U, do tests.
*
CALL DLACPY( ' ', N, N, A, LDA, H, LDA )
*
NTEST = 1
*
ILO = 1
IHI = N
*
CALL DGEHRD( N, ILO, IHI, H, LDA, WORK, WORK( N+1 ),
$ NWORK-N, IINFO )
*
IF( IINFO.NE.0 ) THEN
RESULT( 1 ) = ULPINV
WRITE( NOUNIT, FMT = 9999 )'DGEHRD', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 250
END IF
*
DO 120 J = 1, N - 1
UU( J+1, J ) = ZERO
DO 110 I = J + 2, N
U( I, J ) = H( I, J )
UU( I, J ) = H( I, J )
H( I, J ) = ZERO
110 CONTINUE
120 CONTINUE
CALL DCOPY( N-1, WORK, 1, TAU, 1 )
CALL DORGHR( N, ILO, IHI, U, LDU, WORK, WORK( N+1 ),
$ NWORK-N, IINFO )
NTEST = 2
*
CALL DHST01( N, ILO, IHI, A, LDA, H, LDA, U, LDU, WORK,
$ NWORK, RESULT( 1 ) )
*
* Call DHSEQR to compute T1, T2 and Z, do tests.
*
* Eigenvalues only (WR3,WI3)
*
CALL DLACPY( ' ', N, N, H, LDA, T2, LDA )
NTEST = 3
RESULT( 3 ) = ULPINV
*
CALL DHSEQR( 'E', 'N', N, ILO, IHI, T2, LDA, WR3, WI3, UZ,
$ LDU, WORK, NWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DHSEQR(E)', IINFO, N, JTYPE,
$ IOLDSD
IF( IINFO.LE.N+2 ) THEN
INFO = ABS( IINFO )
GO TO 250
END IF
END IF
*
* Eigenvalues (WR1,WI1) and Full Schur Form (T2)
*
CALL DLACPY( ' ', N, N, H, LDA, T2, LDA )
*
CALL DHSEQR( 'S', 'N', N, ILO, IHI, T2, LDA, WR1, WI1, UZ,
$ LDU, WORK, NWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.LE.N+2 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DHSEQR(S)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 250
END IF
*
* Eigenvalues (WR1,WI1), Schur Form (T1), and Schur vectors
* (UZ)
*
CALL DLACPY( ' ', N, N, H, LDA, T1, LDA )
CALL DLACPY( ' ', N, N, U, LDU, UZ, LDA )
*
CALL DHSEQR( 'S', 'V', N, ILO, IHI, T1, LDA, WR1, WI1, UZ,
$ LDU, WORK, NWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.LE.N+2 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DHSEQR(V)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 250
END IF
*
* Compute Z = U' UZ
*
CALL DGEMM( 'T', 'N', N, N, N, ONE, U, LDU, UZ, LDU, ZERO,
$ Z, LDU )
NTEST = 8
*
* Do Tests 3: | H - Z T Z' | / ( |H| n ulp )
* and 4: | I - Z Z' | / ( n ulp )
*
CALL DHST01( N, ILO, IHI, H, LDA, T1, LDA, Z, LDU, WORK,
$ NWORK, RESULT( 3 ) )
*
* Do Tests 5: | A - UZ T (UZ)' | / ( |A| n ulp )
* and 6: | I - UZ (UZ)' | / ( n ulp )
*
CALL DHST01( N, ILO, IHI, A, LDA, T1, LDA, UZ, LDU, WORK,
$ NWORK, RESULT( 5 ) )
*
* Do Test 7: | T2 - T1 | / ( |T| n ulp )
*
CALL DGET10( N, N, T2, LDA, T1, LDA, WORK, RESULT( 7 ) )
*
* Do Test 8: | W3 - W1 | / ( max(|W1|,|W3|) ulp )
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 130 J = 1, N
TEMP1 = MAX( TEMP1, ABS( WR1( J ) )+ABS( WI1( J ) ),
$ ABS( WR3( J ) )+ABS( WI3( J ) ) )
TEMP2 = MAX( TEMP2, ABS( WR1( J )-WR3( J ) )+
$ ABS( WR1( J )-WR3( J ) ) )
130 CONTINUE
*
RESULT( 8 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) )
*
* Compute the Left and Right Eigenvectors of T
*
* Compute the Right eigenvector Matrix:
*
NTEST = 9
RESULT( 9 ) = ULPINV
*
* Select last max(N/4,1) real, max(N/4,1) complex eigenvectors
*
NSELC = 0
NSELR = 0
J = N
140 CONTINUE
IF( WI1( J ).EQ.ZERO ) THEN
IF( NSELR.LT.MAX( N / 4, 1 ) ) THEN
NSELR = NSELR + 1
SELECT( J ) = .TRUE.
ELSE
SELECT( J ) = .FALSE.
END IF
J = J - 1
ELSE
IF( NSELC.LT.MAX( N / 4, 1 ) ) THEN
NSELC = NSELC + 1
SELECT( J ) = .TRUE.
SELECT( J-1 ) = .FALSE.
ELSE
SELECT( J ) = .FALSE.
SELECT( J-1 ) = .FALSE.
END IF
J = J - 2
END IF
IF( J.GT.0 )
$ GO TO 140
*
CALL DTREVC( 'Right', 'All', SELECT, N, T1, LDA, DUMMA, LDU,
$ EVECTR, LDU, N, IN, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DTREVC(R,A)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
GO TO 250
END IF
*
* Test 9: | TR - RW | / ( |T| |R| ulp )
*
CALL DGET22( 'N', 'N', 'N', N, T1, LDA, EVECTR, LDU, WR1,
$ WI1, WORK, DUMMA( 1 ) )
RESULT( 9 ) = DUMMA( 1 )
IF( DUMMA( 2 ).GT.THRESH ) THEN
WRITE( NOUNIT, FMT = 9998 )'Right', 'DTREVC',
$ DUMMA( 2 ), N, JTYPE, IOLDSD
END IF
*
* Compute selected right eigenvectors and confirm that
* they agree with previous right eigenvectors
*
CALL DTREVC( 'Right', 'Some', SELECT, N, T1, LDA, DUMMA,
$ LDU, EVECTL, LDU, N, IN, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DTREVC(R,S)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
GO TO 250
END IF
*
K = 1
MATCH = .TRUE.
DO 170 J = 1, N
IF( SELECT( J ) .AND. WI1( J ).EQ.ZERO ) THEN
DO 150 JJ = 1, N
IF( EVECTR( JJ, J ).NE.EVECTL( JJ, K ) ) THEN
MATCH = .FALSE.
GO TO 180
END IF
150 CONTINUE
K = K + 1
ELSE IF( SELECT( J ) .AND. WI1( J ).NE.ZERO ) THEN
DO 160 JJ = 1, N
IF( EVECTR( JJ, J ).NE.EVECTL( JJ, K ) .OR.
$ EVECTR( JJ, J+1 ).NE.EVECTL( JJ, K+1 ) ) THEN
MATCH = .FALSE.
GO TO 180
END IF
160 CONTINUE
K = K + 2
END IF
170 CONTINUE
180 CONTINUE
IF( .NOT.MATCH )
$ WRITE( NOUNIT, FMT = 9997 )'Right', 'DTREVC', N, JTYPE,
$ IOLDSD
*
* Compute the Left eigenvector Matrix:
*
NTEST = 10
RESULT( 10 ) = ULPINV
CALL DTREVC( 'Left', 'All', SELECT, N, T1, LDA, EVECTL, LDU,
$ DUMMA, LDU, N, IN, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DTREVC(L,A)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
GO TO 250
END IF
*
* Test 10: | LT - WL | / ( |T| |L| ulp )
*
CALL DGET22( 'Trans', 'N', 'Conj', N, T1, LDA, EVECTL, LDU,
$ WR1, WI1, WORK, DUMMA( 3 ) )
RESULT( 10 ) = DUMMA( 3 )
IF( DUMMA( 4 ).GT.THRESH ) THEN
WRITE( NOUNIT, FMT = 9998 )'Left', 'DTREVC', DUMMA( 4 ),
$ N, JTYPE, IOLDSD
END IF
*
* Compute selected left eigenvectors and confirm that
* they agree with previous left eigenvectors
*
CALL DTREVC( 'Left', 'Some', SELECT, N, T1, LDA, EVECTR,
$ LDU, DUMMA, LDU, N, IN, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DTREVC(L,S)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
GO TO 250
END IF
*
K = 1
MATCH = .TRUE.
DO 210 J = 1, N
IF( SELECT( J ) .AND. WI1( J ).EQ.ZERO ) THEN
DO 190 JJ = 1, N
IF( EVECTL( JJ, J ).NE.EVECTR( JJ, K ) ) THEN
MATCH = .FALSE.
GO TO 220
END IF
190 CONTINUE
K = K + 1
ELSE IF( SELECT( J ) .AND. WI1( J ).NE.ZERO ) THEN
DO 200 JJ = 1, N
IF( EVECTL( JJ, J ).NE.EVECTR( JJ, K ) .OR.
$ EVECTL( JJ, J+1 ).NE.EVECTR( JJ, K+1 ) ) THEN
MATCH = .FALSE.
GO TO 220
END IF
200 CONTINUE
K = K + 2
END IF
210 CONTINUE
220 CONTINUE
IF( .NOT.MATCH )
$ WRITE( NOUNIT, FMT = 9997 )'Left', 'DTREVC', N, JTYPE,
$ IOLDSD
*
* Call DHSEIN for Right eigenvectors of H, do test 11
*
NTEST = 11
RESULT( 11 ) = ULPINV
DO 230 J = 1, N
SELECT( J ) = .TRUE.
230 CONTINUE
*
CALL DHSEIN( 'Right', 'Qr', 'Ninitv', SELECT, N, H, LDA,
$ WR3, WI3, DUMMA, LDU, EVECTX, LDU, N1, IN,
$ WORK, IWORK, IWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DHSEIN(R)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 )
$ GO TO 250
ELSE
*
* Test 11: | HX - XW | / ( |H| |X| ulp )
*
* (from inverse iteration)
*
CALL DGET22( 'N', 'N', 'N', N, H, LDA, EVECTX, LDU, WR3,
$ WI3, WORK, DUMMA( 1 ) )
IF( DUMMA( 1 ).LT.ULPINV )
$ RESULT( 11 ) = DUMMA( 1 )*ANINV
IF( DUMMA( 2 ).GT.THRESH ) THEN
WRITE( NOUNIT, FMT = 9998 )'Right', 'DHSEIN',
$ DUMMA( 2 ), N, JTYPE, IOLDSD
END IF
END IF
*
* Call DHSEIN for Left eigenvectors of H, do test 12
*
NTEST = 12
RESULT( 12 ) = ULPINV
DO 240 J = 1, N
SELECT( J ) = .TRUE.
240 CONTINUE
*
CALL DHSEIN( 'Left', 'Qr', 'Ninitv', SELECT, N, H, LDA, WR3,
$ WI3, EVECTY, LDU, DUMMA, LDU, N1, IN, WORK,
$ IWORK, IWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DHSEIN(L)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 )
$ GO TO 250
ELSE
*
* Test 12: | YH - WY | / ( |H| |Y| ulp )
*
* (from inverse iteration)
*
CALL DGET22( 'C', 'N', 'C', N, H, LDA, EVECTY, LDU, WR3,
$ WI3, WORK, DUMMA( 3 ) )
IF( DUMMA( 3 ).LT.ULPINV )
$ RESULT( 12 ) = DUMMA( 3 )*ANINV
IF( DUMMA( 4 ).GT.THRESH ) THEN
WRITE( NOUNIT, FMT = 9998 )'Left', 'DHSEIN',
$ DUMMA( 4 ), N, JTYPE, IOLDSD
END IF
END IF
*
* Call DORMHR for Right eigenvectors of A, do test 13
*
NTEST = 13
RESULT( 13 ) = ULPINV
*
CALL DORMHR( 'Left', 'No transpose', N, N, ILO, IHI, UU,
$ LDU, TAU, EVECTX, LDU, WORK, NWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DORMHR(R)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 )
$ GO TO 250
ELSE
*
* Test 13: | AX - XW | / ( |A| |X| ulp )
*
* (from inverse iteration)
*
CALL DGET22( 'N', 'N', 'N', N, A, LDA, EVECTX, LDU, WR3,
$ WI3, WORK, DUMMA( 1 ) )
IF( DUMMA( 1 ).LT.ULPINV )
$ RESULT( 13 ) = DUMMA( 1 )*ANINV
END IF
*
* Call DORMHR for Left eigenvectors of A, do test 14
*
NTEST = 14
RESULT( 14 ) = ULPINV
*
CALL DORMHR( 'Left', 'No transpose', N, N, ILO, IHI, UU,
$ LDU, TAU, EVECTY, LDU, WORK, NWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DORMHR(L)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 )
$ GO TO 250
ELSE
*
* Test 14: | YA - WY | / ( |A| |Y| ulp )
*
* (from inverse iteration)
*
CALL DGET22( 'C', 'N', 'C', N, A, LDA, EVECTY, LDU, WR3,
$ WI3, WORK, DUMMA( 3 ) )
IF( DUMMA( 3 ).LT.ULPINV )
$ RESULT( 14 ) = DUMMA( 3 )*ANINV
END IF
*
* End of Loop -- Check for RESULT(j) > THRESH
*
250 CONTINUE
*
NTESTT = NTESTT + NTEST
CALL DLAFTS( 'DHS', N, N, JTYPE, NTEST, RESULT, IOLDSD,
$ THRESH, NOUNIT, NERRS )
*
260 CONTINUE
270 CONTINUE
*
* Summary
*
CALL DLASUM( 'DHS', NOUNIT, NERRS, NTESTT )
*
RETURN
*
9999 FORMAT( ' DCHKHS: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
9998 FORMAT( ' DCHKHS: ', A, ' Eigenvectors from ', A, ' incorrectly ',
$ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 9X,
$ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5,
$ ')' )
9997 FORMAT( ' DCHKHS: Selected ', A, ' Eigenvectors from ', A,
$ ' do not match other eigenvectors ', 9X, 'N=', I6,
$ ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
*
* End of DCHKHS
*
END
SUBROUTINE DCHKSB( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, ISEED,
$ THRESH, NOUNIT, A, LDA, SD, SE, U, LDU, WORK,
$ LWORK, RESULT, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES,
$ NWDTHS
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER ISEED( 4 ), KK( * ), NN( * )
DOUBLE PRECISION A( LDA, * ), RESULT( * ), SD( * ), SE( * ),
$ U( LDU, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DCHKSB tests the reduction of a symmetric band matrix to tridiagonal
* form, used with the symmetric eigenvalue problem.
*
* DSBTRD factors a symmetric band matrix A as U S U' , where ' means
* transpose, S is symmetric tridiagonal, and U is orthogonal.
* DSBTRD can use either just the lower or just the upper triangle
* of A; DCHKSB checks both cases.
*
* When DCHKSB is called, a number of matrix "sizes" ("n's"), a number
* of bandwidths ("k's"), and a number of matrix "types" are
* specified. For each size ("n"), each bandwidth ("k") less than or
* equal to "n", and each type of matrix, one matrix will be generated
* and used to test the symmetric banded reduction routine. For each
* matrix, a number of tests will be performed:
*
* (1) | A - V S V' | / ( |A| n ulp ) computed by DSBTRD with
* UPLO='U'
*
* (2) | I - UU' | / ( n ulp )
*
* (3) | A - V S V' | / ( |A| n ulp ) computed by DSBTRD with
* UPLO='L'
*
* (4) | I - UU' | / ( n ulp )
*
* The "sizes" are specified by an array NN(1:NSIZES); the value of
* each element NN(j) specifies one size.
* The "types" are specified by a logical array DOTYPE( 1:NTYPES );
* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
* Currently, the list of possible types is:
*
* (1) The zero matrix.
* (2) The identity matrix.
*
* (3) A diagonal matrix with evenly spaced entries
* 1, ..., ULP and random signs.
* (ULP = (first number larger than 1) - 1 )
* (4) A diagonal matrix with geometrically spaced entries
* 1, ..., ULP and random signs.
* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
* and random signs.
*
* (6) Same as (4), but multiplied by SQRT( overflow threshold )
* (7) Same as (4), but multiplied by SQRT( underflow threshold )
*
* (8) A matrix of the form U' D U, where U is orthogonal and
* D has evenly spaced entries 1, ..., ULP with random signs
* on the diagonal.
*
* (9) A matrix of the form U' D U, where U is orthogonal and
* D has geometrically spaced entries 1, ..., ULP with random
* signs on the diagonal.
*
* (10) A matrix of the form U' D U, where U is orthogonal and
* D has "clustered" entries 1, ULP,..., ULP with random
* signs on the diagonal.
*
* (11) Same as (8), but multiplied by SQRT( overflow threshold )
* (12) Same as (8), but multiplied by SQRT( underflow threshold )
*
* (13) Symmetric matrix with random entries chosen from (-1,1).
* (14) Same as (13), but multiplied by SQRT( overflow threshold )
* (15) Same as (13), but multiplied by SQRT( underflow threshold )
*
* Arguments
* =========
*
* NSIZES (input) INTEGER
* The number of sizes of matrices to use. If it is zero,
* DCHKSB does nothing. It must be at least zero.
*
* NN (input) INTEGER array, dimension (NSIZES)
* An array containing the sizes to be used for the matrices.
* Zero values will be skipped. The values must be at least
* zero.
*
* NWDTHS (input) INTEGER
* The number of bandwidths to use. If it is zero,
* DCHKSB does nothing. It must be at least zero.
*
* KK (input) INTEGER array, dimension (NWDTHS)
* An array containing the bandwidths to be used for the band
* matrices. The values must be at least zero.
*
* NTYPES (input) INTEGER
* The number of elements in DOTYPE. If it is zero, DCHKSB
* does nothing. It must be at least zero. If it is MAXTYP+1
* and NSIZES is 1, then an additional type, MAXTYP+1 is
* defined, which is to use whatever matrix is in A. This
* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
* DOTYPE(MAXTYP+1) is .TRUE. .
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* If DOTYPE(j) is .TRUE., then for each size in NN a
* matrix of that size and of type j will be generated.
* If NTYPES is smaller than the maximum number of types
* defined (PARAMETER MAXTYP), then types NTYPES+1 through
* MAXTYP will not be generated. If NTYPES is larger
* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
* will be ignored.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The array elements should be between 0 and 4095;
* if not they will be reduced mod 4096. Also, ISEED(4) must
* be odd. The random number generator uses a linear
* congruential sequence limited to small integers, and so
* should produce machine independent random numbers. The
* values of ISEED are changed on exit, and can be used in the
* next call to DCHKSB to continue the same random number
* sequence.
*
* THRESH (input) DOUBLE PRECISION
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error
* is scaled to be O(1), so THRESH should be a reasonably
* small multiple of 1, e.g., 10 or 100. In particular,
* it should not depend on the precision (single vs. double)
* or the size of the matrix. It must be at least zero.
*
* NOUNIT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns IINFO not equal to 0.)
*
* A (input/workspace) DOUBLE PRECISION array, dimension
* (LDA, max(NN))
* Used to hold the matrix whose eigenvalues are to be
* computed.
*
* LDA (input) INTEGER
* The leading dimension of A. It must be at least 2 (not 1!)
* and at least max( KK )+1.
*
* SD (workspace) DOUBLE PRECISION array, dimension (max(NN))
* Used to hold the diagonal of the tridiagonal matrix computed
* by DSBTRD.
*
* SE (workspace) DOUBLE PRECISION array, dimension (max(NN))
* Used to hold the off-diagonal of the tridiagonal matrix
* computed by DSBTRD.
*
* U (workspace) DOUBLE PRECISION array, dimension (LDU, max(NN))
* Used to hold the orthogonal matrix computed by DSBTRD.
*
* LDU (input) INTEGER
* The leading dimension of U. It must be at least 1
* and at least max( NN ).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The number of entries in WORK. This must be at least
* max( LDA+1, max(NN)+1 )*max(NN).
*
* RESULT (output) DOUBLE PRECISION array, dimension (4)
* The values computed by the tests described above.
* The values are currently limited to 1/ulp, to avoid
* overflow.
*
* INFO (output) INTEGER
* If 0, then everything ran OK.
*
*-----------------------------------------------------------------------
*
* Some Local Variables and Parameters:
* ---- ----- --------- --- ----------
* ZERO, ONE Real 0 and 1.
* MAXTYP The number of types defined.
* NTEST The number of tests performed, or which can
* be performed so far, for the current matrix.
* NTESTT The total number of tests performed so far.
* NMAX Largest value in NN.
* NMATS The number of matrices generated so far.
* NERRS The number of tests which have exceeded THRESH
* so far.
* COND, IMODE Values to be passed to the matrix generators.
* ANORM Norm of A; passed to matrix generators.
*
* OVFL, UNFL Overflow and underflow thresholds.
* ULP, ULPINV Finest relative precision and its inverse.
* RTOVFL, RTUNFL Square roots of the previous 2 values.
* The following four arrays decode JTYPE:
* KTYPE(j) The general type (1-10) for type "j".
* KMODE(j) The MODE value to be passed to the matrix
* generator for type "j".
* KMAGN(j) The order of magnitude ( O(1),
* O(overflow^(1/2) ), O(underflow^(1/2) )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, TEN
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ TEN = 10.0D0 )
DOUBLE PRECISION HALF
PARAMETER ( HALF = ONE / TWO )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 15 )
* ..
* .. Local Scalars ..
LOGICAL BADNN, BADNNB
INTEGER I, IINFO, IMODE, ITYPE, J, JC, JCOL, JR, JSIZE,
$ JTYPE, JWIDTH, K, KMAX, MTYPES, N, NERRS,
$ NMATS, NMAX, NTEST, NTESTT
DOUBLE PRECISION ANINV, ANORM, COND, OVFL, RTOVFL, RTUNFL,
$ TEMP1, ULP, ULPINV, UNFL
* ..
* .. Local Arrays ..
INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KMAGN( MAXTYP ),
$ KMODE( MAXTYP ), KTYPE( MAXTYP )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DLACPY, DLASET, DLASUM, DLATMR, DLATMS, DSBT21,
$ DSBTRD, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN, SQRT
* ..
* .. Data statements ..
DATA KTYPE / 1, 2, 5*4, 5*5, 3*8 /
DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
$ 2, 3 /
DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
$ 0, 0 /
* ..
* .. Executable Statements ..
*
* Check for errors
*
NTESTT = 0
INFO = 0
*
* Important constants
*
BADNN = .FALSE.
NMAX = 1
DO 10 J = 1, NSIZES
NMAX = MAX( NMAX, NN( J ) )
IF( NN( J ).LT.0 )
$ BADNN = .TRUE.
10 CONTINUE
*
BADNNB = .FALSE.
KMAX = 0
DO 20 J = 1, NSIZES
KMAX = MAX( KMAX, KK( J ) )
IF( KK( J ).LT.0 )
$ BADNNB = .TRUE.
20 CONTINUE
KMAX = MIN( NMAX-1, KMAX )
*
* Check for errors
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADNN ) THEN
INFO = -2
ELSE IF( NWDTHS.LT.0 ) THEN
INFO = -3
ELSE IF( BADNNB ) THEN
INFO = -4
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.KMAX+1 ) THEN
INFO = -11
ELSE IF( LDU.LT.NMAX ) THEN
INFO = -15
ELSE IF( ( MAX( LDA, NMAX )+1 )*NMAX.GT.LWORK ) THEN
INFO = -17
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DCHKSB', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 .OR. NWDTHS.EQ.0 )
$ RETURN
*
* More Important constants
*
UNFL = DLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
ULPINV = ONE / ULP
RTUNFL = SQRT( UNFL )
RTOVFL = SQRT( OVFL )
*
* Loop over sizes, types
*
NERRS = 0
NMATS = 0
*
DO 190 JSIZE = 1, NSIZES
N = NN( JSIZE )
ANINV = ONE / DBLE( MAX( 1, N ) )
*
DO 180 JWIDTH = 1, NWDTHS
K = KK( JWIDTH )
IF( K.GT.N )
$ GO TO 180
K = MAX( 0, MIN( N-1, K ) )
*
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
DO 170 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 170
NMATS = NMATS + 1
NTEST = 0
*
DO 30 J = 1, 4
IOLDSD( J ) = ISEED( J )
30 CONTINUE
*
* Compute "A".
* Store as "Upper"; later, we will copy to other format.
*
* Control parameters:
*
* KMAGN KMODE KTYPE
* =1 O(1) clustered 1 zero
* =2 large clustered 2 identity
* =3 small exponential (none)
* =4 arithmetic diagonal, (w/ eigenvalues)
* =5 random log symmetric, w/ eigenvalues
* =6 random (none)
* =7 random diagonal
* =8 random symmetric
* =9 positive definite
* =10 diagonally dominant tridiagonal
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 100
*
ITYPE = KTYPE( JTYPE )
IMODE = KMODE( JTYPE )
*
* Compute norm
*
GO TO ( 40, 50, 60 )KMAGN( JTYPE )
*
40 CONTINUE
ANORM = ONE
GO TO 70
*
50 CONTINUE
ANORM = ( RTOVFL*ULP )*ANINV
GO TO 70
*
60 CONTINUE
ANORM = RTUNFL*N*ULPINV
GO TO 70
*
70 CONTINUE
*
CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
IINFO = 0
IF( JTYPE.LE.15 ) THEN
COND = ULPINV
ELSE
COND = ULPINV*ANINV / TEN
END IF
*
* Special Matrices -- Identity & Jordan block
*
* Zero
*
IF( ITYPE.EQ.1 ) THEN
IINFO = 0
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Identity
*
DO 80 JCOL = 1, N
A( K+1, JCOL ) = ANORM
80 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Diagonal Matrix, [Eigen]values Specified
*
CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, 0, 0, 'Q', A( K+1, 1 ), LDA,
$ WORK( N+1 ), IINFO )
*
ELSE IF( ITYPE.EQ.5 ) THEN
*
* Symmetric, eigenvalues specified
*
CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, K, K, 'Q', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.7 ) THEN
*
* Diagonal, random eigenvalues
*
CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
$ ZERO, ANORM, 'Q', A( K+1, 1 ), LDA,
$ IDUMMA, IINFO )
*
ELSE IF( ITYPE.EQ.8 ) THEN
*
* Symmetric, random eigenvalues
*
CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, K, K,
$ ZERO, ANORM, 'Q', A, LDA, IDUMMA, IINFO )
*
ELSE IF( ITYPE.EQ.9 ) THEN
*
* Positive definite, eigenvalues specified.
*
CALL DLATMS( N, N, 'S', ISEED, 'P', WORK, IMODE, COND,
$ ANORM, K, K, 'Q', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.10 ) THEN
*
* Positive definite tridiagonal, eigenvalues specified.
*
IF( N.GT.1 )
$ K = MAX( 1, K )
CALL DLATMS( N, N, 'S', ISEED, 'P', WORK, IMODE, COND,
$ ANORM, 1, 1, 'Q', A( K, 1 ), LDA,
$ WORK( N+1 ), IINFO )
DO 90 I = 2, N
TEMP1 = ABS( A( K, I ) ) /
$ SQRT( ABS( A( K+1, I-1 )*A( K+1, I ) ) )
IF( TEMP1.GT.HALF ) THEN
A( K, I ) = HALF*SQRT( ABS( A( K+1,
$ I-1 )*A( K+1, I ) ) )
END IF
90 CONTINUE
*
ELSE
*
IINFO = 1
END IF
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
100 CONTINUE
*
* Call DSBTRD to compute S and U from upper triangle.
*
CALL DLACPY( ' ', K+1, N, A, LDA, WORK, LDA )
*
NTEST = 1
CALL DSBTRD( 'V', 'U', N, K, WORK, LDA, SD, SE, U, LDU,
$ WORK( LDA*N+1 ), IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSBTRD(U)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 1 ) = ULPINV
GO TO 150
END IF
END IF
*
* Do tests 1 and 2
*
CALL DSBT21( 'Upper', N, K, 1, A, LDA, SD, SE, U, LDU,
$ WORK, RESULT( 1 ) )
*
* Convert A from Upper-Triangle-Only storage to
* Lower-Triangle-Only storage.
*
DO 120 JC = 1, N
DO 110 JR = 0, MIN( K, N-JC )
A( JR+1, JC ) = A( K+1-JR, JC+JR )
110 CONTINUE
120 CONTINUE
DO 140 JC = N + 1 - K, N
DO 130 JR = MIN( K, N-JC ) + 1, K
A( JR+1, JC ) = ZERO
130 CONTINUE
140 CONTINUE
*
* Call DSBTRD to compute S and U from lower triangle
*
CALL DLACPY( ' ', K+1, N, A, LDA, WORK, LDA )
*
NTEST = 3
CALL DSBTRD( 'V', 'L', N, K, WORK, LDA, SD, SE, U, LDU,
$ WORK( LDA*N+1 ), IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSBTRD(L)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 3 ) = ULPINV
GO TO 150
END IF
END IF
NTEST = 4
*
* Do tests 3 and 4
*
CALL DSBT21( 'Lower', N, K, 1, A, LDA, SD, SE, U, LDU,
$ WORK, RESULT( 3 ) )
*
* End of Loop -- Check for RESULT(j) > THRESH
*
150 CONTINUE
NTESTT = NTESTT + NTEST
*
* Print out tests which fail.
*
DO 160 JR = 1, NTEST
IF( RESULT( JR ).GE.THRESH ) THEN
*
* If this is the first test to fail,
* print a header to the data file.
*
IF( NERRS.EQ.0 ) THEN
WRITE( NOUNIT, FMT = 9998 )'DSB'
WRITE( NOUNIT, FMT = 9997 )
WRITE( NOUNIT, FMT = 9996 )
WRITE( NOUNIT, FMT = 9995 )'Symmetric'
WRITE( NOUNIT, FMT = 9994 )'orthogonal', '''',
$ 'transpose', ( '''', J = 1, 4 )
END IF
NERRS = NERRS + 1
WRITE( NOUNIT, FMT = 9993 )N, K, IOLDSD, JTYPE,
$ JR, RESULT( JR )
END IF
160 CONTINUE
*
170 CONTINUE
180 CONTINUE
190 CONTINUE
*
* Summary
*
CALL DLASUM( 'DSB', NOUNIT, NERRS, NTESTT )
RETURN
*
9999 FORMAT( ' DCHKSB: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
*
9998 FORMAT( / 1X, A3,
$ ' -- Real Symmetric Banded Tridiagonal Reduction Routines' )
9997 FORMAT( ' Matrix types (see DCHKSB for details): ' )
*
9996 FORMAT( / ' Special Matrices:',
$ / ' 1=Zero matrix. ',
$ ' 5=Diagonal: clustered entries.',
$ / ' 2=Identity matrix. ',
$ ' 6=Diagonal: large, evenly spaced.',
$ / ' 3=Diagonal: evenly spaced entries. ',
$ ' 7=Diagonal: small, evenly spaced.',
$ / ' 4=Diagonal: geometr. spaced entries.' )
9995 FORMAT( ' Dense ', A, ' Banded Matrices:',
$ / ' 8=Evenly spaced eigenvals. ',
$ ' 12=Small, evenly spaced eigenvals.',
$ / ' 9=Geometrically spaced eigenvals. ',
$ ' 13=Matrix with random O(1) entries.',
$ / ' 10=Clustered eigenvalues. ',
$ ' 14=Matrix with large random entries.',
$ / ' 11=Large, evenly spaced eigenvals. ',
$ ' 15=Matrix with small random entries.' )
*
9994 FORMAT( / ' Tests performed: (S is Tridiag, U is ', A, ',',
$ / 20X, A, ' means ', A, '.', / ' UPLO=''U'':',
$ / ' 1= | A - U S U', A1, ' | / ( |A| n ulp ) ',
$ ' 2= | I - U U', A1, ' | / ( n ulp )', / ' UPLO=''L'':',
$ / ' 3= | A - U S U', A1, ' | / ( |A| n ulp ) ',
$ ' 4= | I - U U', A1, ' | / ( n ulp )' )
9993 FORMAT( ' N=', I5, ', K=', I4, ', seed=', 4( I4, ',' ), ' type ',
$ I2, ', test(', I2, ')=', G10.3 )
*
* End of DCHKSB
*
END
SUBROUTINE DCHKST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
$ NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5,
$ WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK,
$ LWORK, IWORK, LIWORK, RESULT, INFO )
IMPLICIT NONE
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES,
$ NTYPES
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER ISEED( 4 ), IWORK( * ), NN( * )
DOUBLE PRECISION A( LDA, * ), AP( * ), D1( * ), D2( * ),
$ D3( * ), D4( * ), D5( * ), RESULT( * ),
$ SD( * ), SE( * ), TAU( * ), U( LDU, * ),
$ V( LDU, * ), VP( * ), WA1( * ), WA2( * ),
$ WA3( * ), WORK( * ), WR( * ), Z( LDU, * )
* ..
*
* Purpose
* =======
*
* DCHKST checks the symmetric eigenvalue problem routines.
*
* DSYTRD factors A as U S U' , where ' means transpose,
* S is symmetric tridiagonal, and U is orthogonal.
* DSYTRD can use either just the lower or just the upper triangle
* of A; DCHKST checks both cases.
* U is represented as a product of Householder
* transformations, whose vectors are stored in the first
* n-1 columns of V, and whose scale factors are in TAU.
*
* DSPTRD does the same as DSYTRD, except that A and V are stored
* in "packed" format.
*
* DORGTR constructs the matrix U from the contents of V and TAU.
*
* DOPGTR constructs the matrix U from the contents of VP and TAU.
*
* DSTEQR factors S as Z D1 Z' , where Z is the orthogonal
* matrix of eigenvectors and D1 is a diagonal matrix with
* the eigenvalues on the diagonal. D2 is the matrix of
* eigenvalues computed when Z is not computed.
*
* DSTERF computes D3, the matrix of eigenvalues, by the
* PWK method, which does not yield eigenvectors.
*
* DPTEQR factors S as Z4 D4 Z4' , for a
* symmetric positive definite tridiagonal matrix.
* D5 is the matrix of eigenvalues computed when Z is not
* computed.
*
* DSTEBZ computes selected eigenvalues. WA1, WA2, and
* WA3 will denote eigenvalues computed to high
* absolute accuracy, with different range options.
* WR will denote eigenvalues computed to high relative
* accuracy.
*
* DSTEIN computes Y, the eigenvectors of S, given the
* eigenvalues.
*
* DSTEDC factors S as Z D1 Z' , where Z is the orthogonal
* matrix of eigenvectors and D1 is a diagonal matrix with
* the eigenvalues on the diagonal ('I' option). It may also
* update an input orthogonal matrix, usually the output
* from DSYTRD/DORGTR or DSPTRD/DOPGTR ('V' option). It may
* also just compute eigenvalues ('N' option).
*
* DSTEMR factors S as Z D1 Z' , where Z is the orthogonal
* matrix of eigenvectors and D1 is a diagonal matrix with
* the eigenvalues on the diagonal ('I' option). DSTEMR
* uses the Relatively Robust Representation whenever possible.
*
* When DCHKST is called, a number of matrix "sizes" ("n's") and a
* number of matrix "types" are specified. For each size ("n")
* and each type of matrix, one matrix will be generated and used
* to test the symmetric eigenroutines. For each matrix, a number
* of tests will be performed:
*
* (1) | A - V S V' | / ( |A| n ulp ) DSYTRD( UPLO='U', ... )
*
* (2) | I - UV' | / ( n ulp ) DORGTR( UPLO='U', ... )
*
* (3) | A - V S V' | / ( |A| n ulp ) DSYTRD( UPLO='L', ... )
*
* (4) | I - UV' | / ( n ulp ) DORGTR( UPLO='L', ... )
*
* (5-8) Same as 1-4, but for DSPTRD and DOPGTR.
*
* (9) | S - Z D Z' | / ( |S| n ulp ) DSTEQR('V',...)
*
* (10) | I - ZZ' | / ( n ulp ) DSTEQR('V',...)
*
* (11) | D1 - D2 | / ( |D1| ulp ) DSTEQR('N',...)
*
* (12) | D1 - D3 | / ( |D1| ulp ) DSTERF
*
* (13) 0 if the true eigenvalues (computed by sturm count)
* of S are within THRESH of
* those in D1. 2*THRESH if they are not. (Tested using
* DSTECH)
*
* For S positive definite,
*
* (14) | S - Z4 D4 Z4' | / ( |S| n ulp ) DPTEQR('V',...)
*
* (15) | I - Z4 Z4' | / ( n ulp ) DPTEQR('V',...)
*
* (16) | D4 - D5 | / ( 100 |D4| ulp ) DPTEQR('N',...)
*
* When S is also diagonally dominant by the factor gamma < 1,
*
* (17) max | D4(i) - WR(i) | / ( |D4(i)| omega ) ,
* i
* omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4
* DSTEBZ( 'A', 'E', ...)
*
* (18) | WA1 - D3 | / ( |D3| ulp ) DSTEBZ( 'A', 'E', ...)
*
* (19) ( max { min | WA2(i)-WA3(j) | } +
* i j
* max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
* i j
* DSTEBZ( 'I', 'E', ...)
*
* (20) | S - Y WA1 Y' | / ( |S| n ulp ) DSTEBZ, SSTEIN
*
* (21) | I - Y Y' | / ( n ulp ) DSTEBZ, SSTEIN
*
* (22) | S - Z D Z' | / ( |S| n ulp ) DSTEDC('I')
*
* (23) | I - ZZ' | / ( n ulp ) DSTEDC('I')
*
* (24) | S - Z D Z' | / ( |S| n ulp ) DSTEDC('V')
*
* (25) | I - ZZ' | / ( n ulp ) DSTEDC('V')
*
* (26) | D1 - D2 | / ( |D1| ulp ) DSTEDC('V') and
* DSTEDC('N')
*
* Test 27 is disabled at the moment because DSTEMR does not
* guarantee high relatvie accuracy.
*
* (27) max | D6(i) - WR(i) | / ( |D6(i)| omega ) ,
* i
* omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4
* DSTEMR('V', 'A')
*
* (28) max | D6(i) - WR(i) | / ( |D6(i)| omega ) ,
* i
* omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4
* DSTEMR('V', 'I')
*
* Tests 29 through 34 are disable at present because DSTEMR
* does not handle partial specturm requests.
*
* (29) | S - Z D Z' | / ( |S| n ulp ) DSTEMR('V', 'I')
*
* (30) | I - ZZ' | / ( n ulp ) DSTEMR('V', 'I')
*
* (31) ( max { min | WA2(i)-WA3(j) | } +
* i j
* max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
* i j
* DSTEMR('N', 'I') vs. SSTEMR('V', 'I')
*
* (32) | S - Z D Z' | / ( |S| n ulp ) DSTEMR('V', 'V')
*
* (33) | I - ZZ' | / ( n ulp ) DSTEMR('V', 'V')
*
* (34) ( max { min | WA2(i)-WA3(j) | } +
* i j
* max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
* i j
* DSTEMR('N', 'V') vs. SSTEMR('V', 'V')
*
* (35) | S - Z D Z' | / ( |S| n ulp ) DSTEMR('V', 'A')
*
* (36) | I - ZZ' | / ( n ulp ) DSTEMR('V', 'A')
*
* (37) ( max { min | WA2(i)-WA3(j) | } +
* i j
* max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
* i j
* DSTEMR('N', 'A') vs. SSTEMR('V', 'A')
*
* The "sizes" are specified by an array NN(1:NSIZES); the value of
* each element NN(j) specifies one size.
* The "types" are specified by a logical array DOTYPE( 1:NTYPES );
* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
* Currently, the list of possible types is:
*
* (1) The zero matrix.
* (2) The identity matrix.
*
* (3) A diagonal matrix with evenly spaced entries
* 1, ..., ULP and random signs.
* (ULP = (first number larger than 1) - 1 )
* (4) A diagonal matrix with geometrically spaced entries
* 1, ..., ULP and random signs.
* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
* and random signs.
*
* (6) Same as (4), but multiplied by SQRT( overflow threshold )
* (7) Same as (4), but multiplied by SQRT( underflow threshold )
*
* (8) A matrix of the form U' D U, where U is orthogonal and
* D has evenly spaced entries 1, ..., ULP with random signs
* on the diagonal.
*
* (9) A matrix of the form U' D U, where U is orthogonal and
* D has geometrically spaced entries 1, ..., ULP with random
* signs on the diagonal.
*
* (10) A matrix of the form U' D U, where U is orthogonal and
* D has "clustered" entries 1, ULP,..., ULP with random
* signs on the diagonal.
*
* (11) Same as (8), but multiplied by SQRT( overflow threshold )
* (12) Same as (8), but multiplied by SQRT( underflow threshold )
*
* (13) Symmetric matrix with random entries chosen from (-1,1).
* (14) Same as (13), but multiplied by SQRT( overflow threshold )
* (15) Same as (13), but multiplied by SQRT( underflow threshold )
* (16) Same as (8), but diagonal elements are all positive.
* (17) Same as (9), but diagonal elements are all positive.
* (18) Same as (10), but diagonal elements are all positive.
* (19) Same as (16), but multiplied by SQRT( overflow threshold )
* (20) Same as (16), but multiplied by SQRT( underflow threshold )
* (21) A diagonally dominant tridiagonal matrix with geometrically
* spaced diagonal entries 1, ..., ULP.
*
* Arguments
* =========
*
* NSIZES (input) INTEGER
* The number of sizes of matrices to use. If it is zero,
* DCHKST does nothing. It must be at least zero.
*
* NN (input) INTEGER array, dimension (NSIZES)
* An array containing the sizes to be used for the matrices.
* Zero values will be skipped. The values must be at least
* zero.
*
* NTYPES (input) INTEGER
* The number of elements in DOTYPE. If it is zero, DCHKST
* does nothing. It must be at least zero. If it is MAXTYP+1
* and NSIZES is 1, then an additional type, MAXTYP+1 is
* defined, which is to use whatever matrix is in A. This
* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
* DOTYPE(MAXTYP+1) is .TRUE. .
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* If DOTYPE(j) is .TRUE., then for each size in NN a
* matrix of that size and of type j will be generated.
* If NTYPES is smaller than the maximum number of types
* defined (PARAMETER MAXTYP), then types NTYPES+1 through
* MAXTYP will not be generated. If NTYPES is larger
* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
* will be ignored.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The array elements should be between 0 and 4095;
* if not they will be reduced mod 4096. Also, ISEED(4) must
* be odd. The random number generator uses a linear
* congruential sequence limited to small integers, and so
* should produce machine independent random numbers. The
* values of ISEED are changed on exit, and can be used in the
* next call to DCHKST to continue the same random number
* sequence.
*
* THRESH (input) DOUBLE PRECISION
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error
* is scaled to be O(1), so THRESH should be a reasonably
* small multiple of 1, e.g., 10 or 100. In particular,
* it should not depend on the precision (single vs. double)
* or the size of the matrix. It must be at least zero.
*
* NOUNIT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns IINFO not equal to 0.)
*
* A (input/workspace/output) DOUBLE PRECISION array of
* dimension ( LDA , max(NN) )
* Used to hold the matrix whose eigenvalues are to be
* computed. On exit, A contains the last matrix actually
* used.
*
* LDA (input) INTEGER
* The leading dimension of A. It must be at
* least 1 and at least max( NN ).
*
* AP (workspace) DOUBLE PRECISION array of
* dimension( max(NN)*max(NN+1)/2 )
* The matrix A stored in packed format.
*
* SD (workspace/output) DOUBLE PRECISION array of
* dimension( max(NN) )
* The diagonal of the tridiagonal matrix computed by DSYTRD.
* On exit, SD and SE contain the tridiagonal form of the
* matrix in A.
*
* SE (workspace/output) DOUBLE PRECISION array of
* dimension( max(NN) )
* The off-diagonal of the tridiagonal matrix computed by
* DSYTRD. On exit, SD and SE contain the tridiagonal form of
* the matrix in A.
*
* D1 (workspace/output) DOUBLE PRECISION array of
* dimension( max(NN) )
* The eigenvalues of A, as computed by DSTEQR simlutaneously
* with Z. On exit, the eigenvalues in D1 correspond with the
* matrix in A.
*
* D2 (workspace/output) DOUBLE PRECISION array of
* dimension( max(NN) )
* The eigenvalues of A, as computed by DSTEQR if Z is not
* computed. On exit, the eigenvalues in D2 correspond with
* the matrix in A.
*
* D3 (workspace/output) DOUBLE PRECISION array of
* dimension( max(NN) )
* The eigenvalues of A, as computed by DSTERF. On exit, the
* eigenvalues in D3 correspond with the matrix in A.
*
* U (workspace/output) DOUBLE PRECISION array of
* dimension( LDU, max(NN) ).
* The orthogonal matrix computed by DSYTRD + DORGTR.
*
* LDU (input) INTEGER
* The leading dimension of U, Z, and V. It must be at least 1
* and at least max( NN ).
*
* V (workspace/output) DOUBLE PRECISION array of
* dimension( LDU, max(NN) ).
* The Housholder vectors computed by DSYTRD in reducing A to
* tridiagonal form. The vectors computed with UPLO='U' are
* in the upper triangle, and the vectors computed with UPLO='L'
* are in the lower triangle. (As described in DSYTRD, the
* sub- and superdiagonal are not set to 1, although the
* true Householder vector has a 1 in that position. The
* routines that use V, such as DORGTR, set those entries to
* 1 before using them, and then restore them later.)
*
* VP (workspace) DOUBLE PRECISION array of
* dimension( max(NN)*max(NN+1)/2 )
* The matrix V stored in packed format.
*
* TAU (workspace/output) DOUBLE PRECISION array of
* dimension( max(NN) )
* The Householder factors computed by DSYTRD in reducing A
* to tridiagonal form.
*
* Z (workspace/output) DOUBLE PRECISION array of
* dimension( LDU, max(NN) ).
* The orthogonal matrix of eigenvectors computed by DSTEQR,
* DPTEQR, and DSTEIN.
*
* WORK (workspace/output) DOUBLE PRECISION array of
* dimension( LWORK )
*
* LWORK (input) INTEGER
* The number of entries in WORK. This must be at least
* 1 + 4 * Nmax + 2 * Nmax * lg Nmax + 3 * Nmax**2
* where Nmax = max( NN(j), 2 ) and lg = log base 2.
*
* IWORK (workspace/output) INTEGER array,
* dimension (6 + 6*Nmax + 5 * Nmax * lg Nmax )
* where Nmax = max( NN(j), 2 ) and lg = log base 2.
* Workspace.
*
* RESULT (output) DOUBLE PRECISION array, dimension (26)
* The values computed by the tests described above.
* The values are currently limited to 1/ulp, to avoid
* overflow.
*
* INFO (output) INTEGER
* If 0, then everything ran OK.
* -1: NSIZES < 0
* -2: Some NN(j) < 0
* -3: NTYPES < 0
* -5: THRESH < 0
* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
* -23: LDU < 1 or LDU < NMAX.
* -29: LWORK too small.
* If DLATMR, SLATMS, DSYTRD, DORGTR, DSTEQR, SSTERF,
* or DORMC2 returns an error code, the
* absolute value of it is returned.
*
*-----------------------------------------------------------------------
*
* Some Local Variables and Parameters:
* ---- ----- --------- --- ----------
* ZERO, ONE Real 0 and 1.
* MAXTYP The number of types defined.
* NTEST The number of tests performed, or which can
* be performed so far, for the current matrix.
* NTESTT The total number of tests performed so far.
* NBLOCK Blocksize as returned by ENVIR.
* NMAX Largest value in NN.
* NMATS The number of matrices generated so far.
* NERRS The number of tests which have exceeded THRESH
* so far.
* COND, IMODE Values to be passed to the matrix generators.
* ANORM Norm of A; passed to matrix generators.
*
* OVFL, UNFL Overflow and underflow thresholds.
* ULP, ULPINV Finest relative precision and its inverse.
* RTOVFL, RTUNFL Square roots of the previous 2 values.
* The following four arrays decode JTYPE:
* KTYPE(j) The general type (1-10) for type "j".
* KMODE(j) The MODE value to be passed to the matrix
* generator for type "j".
* KMAGN(j) The order of magnitude ( O(1),
* O(overflow^(1/2) ), O(underflow^(1/2) )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, EIGHT, TEN, HUN
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ EIGHT = 8.0D0, TEN = 10.0D0, HUN = 100.0D0 )
DOUBLE PRECISION HALF
PARAMETER ( HALF = ONE / TWO )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 21 )
LOGICAL SRANGE
PARAMETER ( SRANGE = .FALSE. )
LOGICAL SREL
PARAMETER ( SREL = .FALSE. )
* ..
* .. Local Scalars ..
LOGICAL BADNN, TRYRAC
INTEGER I, IINFO, IL, IMODE, ITEMP, ITYPE, IU, J, JC,
$ JR, JSIZE, JTYPE, LGN, LIWEDC, LOG2UI, LWEDC,
$ M, M2, M3, MTYPES, N, NAP, NBLOCK, NERRS,
$ NMATS, NMAX, NSPLIT, NTEST, NTESTT
DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
$ RTUNFL, TEMP1, TEMP2, TEMP3, TEMP4, ULP,
$ ULPINV, UNFL, VL, VU
* ..
* .. Local Arrays ..
INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
$ KMAGN( MAXTYP ), KMODE( MAXTYP ),
$ KTYPE( MAXTYP )
DOUBLE PRECISION DUMMA( 1 )
* ..
* .. External Functions ..
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLARND, DSXT1
EXTERNAL ILAENV, DLAMCH, DLARND, DSXT1
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLABAD, DLACPY, DLASET, DLASUM, DLATMR,
$ DLATMS, DOPGTR, DORGTR, DPTEQR, DSPT21, DSPTRD,
$ DSTEBZ, DSTECH, DSTEDC, DSTEMR, DSTEIN, DSTEQR,
$ DSTERF, DSTT21, DSTT22, DSYT21, DSYTRD, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, INT, LOG, MAX, MIN, SQRT
* ..
* .. Data statements ..
DATA KTYPE / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8,
$ 8, 8, 9, 9, 9, 9, 9, 10 /
DATA KMAGN / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
$ 2, 3, 1, 1, 1, 2, 3, 1 /
DATA KMODE / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
$ 0, 0, 4, 3, 1, 4, 4, 3 /
* ..
* .. Executable Statements ..
*
* Keep ftnchek happy
IDUMMA( 1 ) = 1
*
* Check for errors
*
NTESTT = 0
INFO = 0
*
* Important constants
*
BADNN = .FALSE.
TRYRAC = .TRUE.
NMAX = 1
DO 10 J = 1, NSIZES
NMAX = MAX( NMAX, NN( J ) )
IF( NN( J ).LT.0 )
$ BADNN = .TRUE.
10 CONTINUE
*
NBLOCK = ILAENV( 1, 'DSYTRD', 'L', NMAX, -1, -1, -1 )
NBLOCK = MIN( NMAX, MAX( 1, NBLOCK ) )
*
* Check for errors
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADNN ) THEN
INFO = -2
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.NMAX ) THEN
INFO = -9
ELSE IF( LDU.LT.NMAX ) THEN
INFO = -23
ELSE IF( 2*MAX( 2, NMAX )**2.GT.LWORK ) THEN
INFO = -29
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DCHKST', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
$ RETURN
*
* More Important constants
*
UNFL = DLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
CALL DLABAD( UNFL, OVFL )
ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
ULPINV = ONE / ULP
LOG2UI = INT( LOG( ULPINV ) / LOG( TWO ) )
RTUNFL = SQRT( UNFL )
RTOVFL = SQRT( OVFL )
*
* Loop over sizes, types
*
DO 20 I = 1, 4
ISEED2( I ) = ISEED( I )
20 CONTINUE
NERRS = 0
NMATS = 0
*
DO 310 JSIZE = 1, NSIZES
N = NN( JSIZE )
IF( N.GT.0 ) THEN
LGN = INT( LOG( DBLE( N ) ) / LOG( TWO ) )
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
LWEDC = 1 + 4*N + 2*N*LGN + 3*N**2
LIWEDC = 6 + 6*N + 5*N*LGN
ELSE
LWEDC = 8
LIWEDC = 12
END IF
NAP = ( N*( N+1 ) ) / 2
ANINV = ONE / DBLE( MAX( 1, N ) )
*
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
DO 300 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 300
NMATS = NMATS + 1
NTEST = 0
*
DO 30 J = 1, 4
IOLDSD( J ) = ISEED( J )
30 CONTINUE
*
* Compute "A"
*
* Control parameters:
*
* KMAGN KMODE KTYPE
* =1 O(1) clustered 1 zero
* =2 large clustered 2 identity
* =3 small exponential (none)
* =4 arithmetic diagonal, (w/ eigenvalues)
* =5 random log symmetric, w/ eigenvalues
* =6 random (none)
* =7 random diagonal
* =8 random symmetric
* =9 positive definite
* =10 diagonally dominant tridiagonal
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 100
*
ITYPE = KTYPE( JTYPE )
IMODE = KMODE( JTYPE )
*
* Compute norm
*
GO TO ( 40, 50, 60 )KMAGN( JTYPE )
*
40 CONTINUE
ANORM = ONE
GO TO 70
*
50 CONTINUE
ANORM = ( RTOVFL*ULP )*ANINV
GO TO 70
*
60 CONTINUE
ANORM = RTUNFL*N*ULPINV
GO TO 70
*
70 CONTINUE
*
CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
IINFO = 0
IF( JTYPE.LE.15 ) THEN
COND = ULPINV
ELSE
COND = ULPINV*ANINV / TEN
END IF
*
* Special Matrices -- Identity & Jordan block
*
* Zero
*
IF( ITYPE.EQ.1 ) THEN
IINFO = 0
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Identity
*
DO 80 JC = 1, N
A( JC, JC ) = ANORM
80 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Diagonal Matrix, [Eigen]values Specified
*
CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
*
ELSE IF( ITYPE.EQ.5 ) THEN
*
* Symmetric, eigenvalues specified
*
CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, N, N, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.7 ) THEN
*
* Diagonal, random eigenvalues
*
CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.8 ) THEN
*
* Symmetric, random eigenvalues
*
CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.9 ) THEN
*
* Positive definite, eigenvalues specified.
*
CALL DLATMS( N, N, 'S', ISEED, 'P', WORK, IMODE, COND,
$ ANORM, N, N, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.10 ) THEN
*
* Positive definite tridiagonal, eigenvalues specified.
*
CALL DLATMS( N, N, 'S', ISEED, 'P', WORK, IMODE, COND,
$ ANORM, 1, 1, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
DO 90 I = 2, N
TEMP1 = ABS( A( I-1, I ) ) /
$ SQRT( ABS( A( I-1, I-1 )*A( I, I ) ) )
IF( TEMP1.GT.HALF ) THEN
A( I-1, I ) = HALF*SQRT( ABS( A( I-1, I-1 )*A( I,
$ I ) ) )
A( I, I-1 ) = A( I-1, I )
END IF
90 CONTINUE
*
ELSE
*
IINFO = 1
END IF
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
100 CONTINUE
*
* Call DSYTRD and DORGTR to compute S and U from
* upper triangle.
*
CALL DLACPY( 'U', N, N, A, LDA, V, LDU )
*
NTEST = 1
CALL DSYTRD( 'U', N, V, LDU, SD, SE, TAU, WORK, LWORK,
$ IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSYTRD(U)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 1 ) = ULPINV
GO TO 280
END IF
END IF
*
CALL DLACPY( 'U', N, N, V, LDU, U, LDU )
*
NTEST = 2
CALL DORGTR( 'U', N, U, LDU, TAU, WORK, LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DORGTR(U)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 2 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do tests 1 and 2
*
CALL DSYT21( 2, 'Upper', N, 1, A, LDA, SD, SE, U, LDU, V,
$ LDU, TAU, WORK, RESULT( 1 ) )
CALL DSYT21( 3, 'Upper', N, 1, A, LDA, SD, SE, U, LDU, V,
$ LDU, TAU, WORK, RESULT( 2 ) )
*
* Call DSYTRD and DORGTR to compute S and U from
* lower triangle, do tests.
*
CALL DLACPY( 'L', N, N, A, LDA, V, LDU )
*
NTEST = 3
CALL DSYTRD( 'L', N, V, LDU, SD, SE, TAU, WORK, LWORK,
$ IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSYTRD(L)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 3 ) = ULPINV
GO TO 280
END IF
END IF
*
CALL DLACPY( 'L', N, N, V, LDU, U, LDU )
*
NTEST = 4
CALL DORGTR( 'L', N, U, LDU, TAU, WORK, LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DORGTR(L)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 4 ) = ULPINV
GO TO 280
END IF
END IF
*
CALL DSYT21( 2, 'Lower', N, 1, A, LDA, SD, SE, U, LDU, V,
$ LDU, TAU, WORK, RESULT( 3 ) )
CALL DSYT21( 3, 'Lower', N, 1, A, LDA, SD, SE, U, LDU, V,
$ LDU, TAU, WORK, RESULT( 4 ) )
*
* Store the upper triangle of A in AP
*
I = 0
DO 120 JC = 1, N
DO 110 JR = 1, JC
I = I + 1
AP( I ) = A( JR, JC )
110 CONTINUE
120 CONTINUE
*
* Call DSPTRD and DOPGTR to compute S and U from AP
*
CALL DCOPY( NAP, AP, 1, VP, 1 )
*
NTEST = 5
CALL DSPTRD( 'U', N, VP, SD, SE, TAU, IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSPTRD(U)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 5 ) = ULPINV
GO TO 280
END IF
END IF
*
NTEST = 6
CALL DOPGTR( 'U', N, VP, TAU, U, LDU, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DOPGTR(U)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 6 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do tests 5 and 6
*
CALL DSPT21( 2, 'Upper', N, 1, AP, SD, SE, U, LDU, VP, TAU,
$ WORK, RESULT( 5 ) )
CALL DSPT21( 3, 'Upper', N, 1, AP, SD, SE, U, LDU, VP, TAU,
$ WORK, RESULT( 6 ) )
*
* Store the lower triangle of A in AP
*
I = 0
DO 140 JC = 1, N
DO 130 JR = JC, N
I = I + 1
AP( I ) = A( JR, JC )
130 CONTINUE
140 CONTINUE
*
* Call DSPTRD and DOPGTR to compute S and U from AP
*
CALL DCOPY( NAP, AP, 1, VP, 1 )
*
NTEST = 7
CALL DSPTRD( 'L', N, VP, SD, SE, TAU, IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSPTRD(L)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 7 ) = ULPINV
GO TO 280
END IF
END IF
*
NTEST = 8
CALL DOPGTR( 'L', N, VP, TAU, U, LDU, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DOPGTR(L)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 8 ) = ULPINV
GO TO 280
END IF
END IF
*
CALL DSPT21( 2, 'Lower', N, 1, AP, SD, SE, U, LDU, VP, TAU,
$ WORK, RESULT( 7 ) )
CALL DSPT21( 3, 'Lower', N, 1, AP, SD, SE, U, LDU, VP, TAU,
$ WORK, RESULT( 8 ) )
*
* Call DSTEQR to compute D1, D2, and Z, do tests.
*
* Compute D1 and Z
*
CALL DCOPY( N, SD, 1, D1, 1 )
IF( N.GT.0 )
$ CALL DCOPY( N-1, SE, 1, WORK, 1 )
CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDU )
*
NTEST = 9
CALL DSTEQR( 'V', N, D1, WORK, Z, LDU, WORK( N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEQR(V)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 9 ) = ULPINV
GO TO 280
END IF
END IF
*
* Compute D2
*
CALL DCOPY( N, SD, 1, D2, 1 )
IF( N.GT.0 )
$ CALL DCOPY( N-1, SE, 1, WORK, 1 )
*
NTEST = 11
CALL DSTEQR( 'N', N, D2, WORK, WORK( N+1 ), LDU,
$ WORK( N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEQR(N)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 11 ) = ULPINV
GO TO 280
END IF
END IF
*
* Compute D3 (using PWK method)
*
CALL DCOPY( N, SD, 1, D3, 1 )
IF( N.GT.0 )
$ CALL DCOPY( N-1, SE, 1, WORK, 1 )
*
NTEST = 12
CALL DSTERF( N, D3, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTERF', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 12 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do Tests 9 and 10
*
CALL DSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK,
$ RESULT( 9 ) )
*
* Do Tests 11 and 12
*
TEMP1 = ZERO
TEMP2 = ZERO
TEMP3 = ZERO
TEMP4 = ZERO
*
DO 150 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) )
TEMP3 = MAX( TEMP3, ABS( D1( J ) ), ABS( D3( J ) ) )
TEMP4 = MAX( TEMP4, ABS( D1( J )-D3( J ) ) )
150 CONTINUE
*
RESULT( 11 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) )
RESULT( 12 ) = TEMP4 / MAX( UNFL, ULP*MAX( TEMP3, TEMP4 ) )
*
* Do Test 13 -- Sturm Sequence Test of Eigenvalues
* Go up by factors of two until it succeeds
*
NTEST = 13
TEMP1 = THRESH*( HALF-ULP )
*
DO 160 J = 0, LOG2UI
CALL DSTECH( N, SD, SE, D1, TEMP1, WORK, IINFO )
IF( IINFO.EQ.0 )
$ GO TO 170
TEMP1 = TEMP1*TWO
160 CONTINUE
*
170 CONTINUE
RESULT( 13 ) = TEMP1
*
* For positive definite matrices ( JTYPE.GT.15 ) call DPTEQR
* and do tests 14, 15, and 16 .
*
IF( JTYPE.GT.15 ) THEN
*
* Compute D4 and Z4
*
CALL DCOPY( N, SD, 1, D4, 1 )
IF( N.GT.0 )
$ CALL DCOPY( N-1, SE, 1, WORK, 1 )
CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDU )
*
NTEST = 14
CALL DPTEQR( 'V', N, D4, WORK, Z, LDU, WORK( N+1 ),
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DPTEQR(V)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 14 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do Tests 14 and 15
*
CALL DSTT21( N, 0, SD, SE, D4, DUMMA, Z, LDU, WORK,
$ RESULT( 14 ) )
*
* Compute D5
*
CALL DCOPY( N, SD, 1, D5, 1 )
IF( N.GT.0 )
$ CALL DCOPY( N-1, SE, 1, WORK, 1 )
*
NTEST = 16
CALL DPTEQR( 'N', N, D5, WORK, Z, LDU, WORK( N+1 ),
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DPTEQR(N)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 16 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do Test 16
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 180 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D4( J ) ), ABS( D5( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D4( J )-D5( J ) ) )
180 CONTINUE
*
RESULT( 16 ) = TEMP2 / MAX( UNFL,
$ HUN*ULP*MAX( TEMP1, TEMP2 ) )
ELSE
RESULT( 14 ) = ZERO
RESULT( 15 ) = ZERO
RESULT( 16 ) = ZERO
END IF
*
* Call DSTEBZ with different options and do tests 17-18.
*
* If S is positive definite and diagonally dominant,
* ask for all eigenvalues with high relative accuracy.
*
VL = ZERO
VU = ZERO
IL = 0
IU = 0
IF( JTYPE.EQ.21 ) THEN
NTEST = 17
ABSTOL = UNFL + UNFL
CALL DSTEBZ( 'A', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE,
$ M, NSPLIT, WR, IWORK( 1 ), IWORK( N+1 ),
$ WORK, IWORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(A,rel)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 17 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do test 17
*
TEMP2 = TWO*( TWO*N-ONE )*ULP*( ONE+EIGHT*HALF**2 ) /
$ ( ONE-HALF )**4
*
TEMP1 = ZERO
DO 190 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D4( J )-WR( N-J+1 ) ) /
$ ( ABSTOL+ABS( D4( J ) ) ) )
190 CONTINUE
*
RESULT( 17 ) = TEMP1 / TEMP2
ELSE
RESULT( 17 ) = ZERO
END IF
*
* Now ask for all eigenvalues with high absolute accuracy.
*
NTEST = 18
ABSTOL = UNFL + UNFL
CALL DSTEBZ( 'A', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, M,
$ NSPLIT, WA1, IWORK( 1 ), IWORK( N+1 ), WORK,
$ IWORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(A)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 18 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do test 18
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 200 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D3( J ) ), ABS( WA1( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D3( J )-WA1( J ) ) )
200 CONTINUE
*
RESULT( 18 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) )
*
* Choose random values for IL and IU, and ask for the
* IL-th through IU-th eigenvalues.
*
NTEST = 19
IF( N.LE.1 ) THEN
IL = 1
IU = N
ELSE
IL = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) )
IU = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) )
IF( IU.LT.IL ) THEN
ITEMP = IU
IU = IL
IL = ITEMP
END IF
END IF
*
CALL DSTEBZ( 'I', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE,
$ M2, NSPLIT, WA2, IWORK( 1 ), IWORK( N+1 ),
$ WORK, IWORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(I)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 19 ) = ULPINV
GO TO 280
END IF
END IF
*
* Determine the values VL and VU of the IL-th and IU-th
* eigenvalues and ask for all eigenvalues in this range.
*
IF( N.GT.0 ) THEN
IF( IL.NE.1 ) THEN
VL = WA1( IL ) - MAX( HALF*( WA1( IL )-WA1( IL-1 ) ),
$ ULP*ANORM, TWO*RTUNFL )
ELSE
VL = WA1( 1 ) - MAX( HALF*( WA1( N )-WA1( 1 ) ),
$ ULP*ANORM, TWO*RTUNFL )
END IF
IF( IU.NE.N ) THEN
VU = WA1( IU ) + MAX( HALF*( WA1( IU+1 )-WA1( IU ) ),
$ ULP*ANORM, TWO*RTUNFL )
ELSE
VU = WA1( N ) + MAX( HALF*( WA1( N )-WA1( 1 ) ),
$ ULP*ANORM, TWO*RTUNFL )
END IF
ELSE
VL = ZERO
VU = ONE
END IF
*
CALL DSTEBZ( 'V', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE,
$ M3, NSPLIT, WA3, IWORK( 1 ), IWORK( N+1 ),
$ WORK, IWORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(V)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 19 ) = ULPINV
GO TO 280
END IF
END IF
*
IF( M3.EQ.0 .AND. N.NE.0 ) THEN
RESULT( 19 ) = ULPINV
GO TO 280
END IF
*
* Do test 19
*
TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
IF( N.GT.0 ) THEN
TEMP3 = MAX( ABS( WA1( N ) ), ABS( WA1( 1 ) ) )
ELSE
TEMP3 = ZERO
END IF
*
RESULT( 19 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, TEMP3*ULP )
*
* Call DSTEIN to compute eigenvectors corresponding to
* eigenvalues in WA1. (First call DSTEBZ again, to make sure
* it returns these eigenvalues in the correct order.)
*
NTEST = 21
CALL DSTEBZ( 'A', 'B', N, VL, VU, IL, IU, ABSTOL, SD, SE, M,
$ NSPLIT, WA1, IWORK( 1 ), IWORK( N+1 ), WORK,
$ IWORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(A,B)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 20 ) = ULPINV
RESULT( 21 ) = ULPINV
GO TO 280
END IF
END IF
*
CALL DSTEIN( N, SD, SE, M, WA1, IWORK( 1 ), IWORK( N+1 ), Z,
$ LDU, WORK, IWORK( 2*N+1 ), IWORK( 3*N+1 ),
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEIN', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 20 ) = ULPINV
RESULT( 21 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do tests 20 and 21
*
CALL DSTT21( N, 0, SD, SE, WA1, DUMMA, Z, LDU, WORK,
$ RESULT( 20 ) )
*
* Call DSTEDC(I) to compute D1 and Z, do tests.
*
* Compute D1 and Z
*
CALL DCOPY( N, SD, 1, D1, 1 )
IF( N.GT.0 )
$ CALL DCOPY( N-1, SE, 1, WORK, 1 )
CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDU )
*
NTEST = 22
CALL DSTEDC( 'I', N, D1, WORK, Z, LDU, WORK( N+1 ), LWEDC-N,
$ IWORK, LIWEDC, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEDC(I)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 22 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do Tests 22 and 23
*
CALL DSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK,
$ RESULT( 22 ) )
*
* Call DSTEDC(V) to compute D1 and Z, do tests.
*
* Compute D1 and Z
*
CALL DCOPY( N, SD, 1, D1, 1 )
IF( N.GT.0 )
$ CALL DCOPY( N-1, SE, 1, WORK, 1 )
CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDU )
*
NTEST = 24
CALL DSTEDC( 'V', N, D1, WORK, Z, LDU, WORK( N+1 ), LWEDC-N,
$ IWORK, LIWEDC, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEDC(V)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 24 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do Tests 24 and 25
*
CALL DSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK,
$ RESULT( 24 ) )
*
* Call DSTEDC(N) to compute D2, do tests.
*
* Compute D2
*
CALL DCOPY( N, SD, 1, D2, 1 )
IF( N.GT.0 )
$ CALL DCOPY( N-1, SE, 1, WORK, 1 )
CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDU )
*
NTEST = 26
CALL DSTEDC( 'N', N, D2, WORK, Z, LDU, WORK( N+1 ), LWEDC-N,
$ IWORK, LIWEDC, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEDC(N)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 26 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do Test 26
*
TEMP1 = ZERO
TEMP2 = ZERO
*
DO 210 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) )
210 CONTINUE
*
RESULT( 26 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) )
*
* Only test DSTEMR if IEEE compliant
*
IF( ILAENV( 10, 'DSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 .AND.
$ ILAENV( 11, 'DSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 ) THEN
*
* Call DSTEMR, do test 27 (relative eigenvalue accuracy)
*
* If S is positive definite and diagonally dominant,
* ask for all eigenvalues with high relative accuracy.
*
VL = ZERO
VU = ZERO
IL = 0
IU = 0
IF( JTYPE.EQ.21 .AND. SREL ) THEN
NTEST = 27
ABSTOL = UNFL + UNFL
CALL DSTEMR( 'V', 'A', N, SD, SE, VL, VU, IL, IU,
$ M, WR, Z, LDU, N, IWORK( 1 ), TRYRAC,
$ WORK, LWORK, IWORK( 2*N+1 ), LWORK-2*N,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEMR(V,A,rel)',
$ IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 27 ) = ULPINV
GO TO 270
END IF
END IF
*
* Do test 27
*
TEMP2 = TWO*( TWO*N-ONE )*ULP*( ONE+EIGHT*HALF**2 ) /
$ ( ONE-HALF )**4
*
TEMP1 = ZERO
DO 220 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D4( J )-WR( N-J+1 ) ) /
$ ( ABSTOL+ABS( D4( J ) ) ) )
220 CONTINUE
*
RESULT( 27 ) = TEMP1 / TEMP2
*
IL = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) )
IU = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) )
IF( IU.LT.IL ) THEN
ITEMP = IU
IU = IL
IL = ITEMP
END IF
*
IF( SRANGE ) THEN
NTEST = 28
ABSTOL = UNFL + UNFL
CALL DSTEMR( 'V', 'I', N, SD, SE, VL, VU, IL, IU,
$ M, WR, Z, LDU, N, IWORK( 1 ), TRYRAC,
$ WORK, LWORK, IWORK( 2*N+1 ),
$ LWORK-2*N, IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEMR(V,I,rel)',
$ IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 28 ) = ULPINV
GO TO 270
END IF
END IF
*
*
* Do test 28
*
TEMP2 = TWO*( TWO*N-ONE )*ULP*
$ ( ONE+EIGHT*HALF**2 ) / ( ONE-HALF )**4
*
TEMP1 = ZERO
DO 230 J = IL, IU
TEMP1 = MAX( TEMP1, ABS( WR( J-IL+1 )-D4( N-J+
$ 1 ) ) / ( ABSTOL+ABS( WR( J-IL+1 ) ) ) )
230 CONTINUE
*
RESULT( 28 ) = TEMP1 / TEMP2
ELSE
RESULT( 28 ) = ZERO
END IF
ELSE
RESULT( 27 ) = ZERO
RESULT( 28 ) = ZERO
END IF
*
* Call DSTEMR(V,I) to compute D1 and Z, do tests.
*
* Compute D1 and Z
*
CALL DCOPY( N, SD, 1, D5, 1 )
IF( N.GT.0 )
$ CALL DCOPY( N-1, SE, 1, WORK, 1 )
CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDU )
*
IF( SRANGE ) THEN
NTEST = 29
IL = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) )
IU = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) )
IF( IU.LT.IL ) THEN
ITEMP = IU
IU = IL
IL = ITEMP
END IF
CALL DSTEMR( 'V', 'I', N, D5, WORK, VL, VU, IL, IU,
$ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC,
$ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ),
$ LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEMR(V,I)', IINFO,
$ N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 29 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do Tests 29 and 30
*
CALL DSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK,
$ M, RESULT( 29 ) )
*
* Call DSTEMR to compute D2, do tests.
*
* Compute D2
*
CALL DCOPY( N, SD, 1, D5, 1 )
IF( N.GT.0 )
$ CALL DCOPY( N-1, SE, 1, WORK, 1 )
*
NTEST = 31
CALL DSTEMR( 'N', 'I', N, D5, WORK, VL, VU, IL, IU,
$ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC,
$ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ),
$ LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEMR(N,I)', IINFO,
$ N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 31 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do Test 31
*
TEMP1 = ZERO
TEMP2 = ZERO
*
DO 240 J = 1, IU - IL + 1
TEMP1 = MAX( TEMP1, ABS( D1( J ) ),
$ ABS( D2( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) )
240 CONTINUE
*
RESULT( 31 ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
*
* Call DSTEMR(V,V) to compute D1 and Z, do tests.
*
* Compute D1 and Z
*
CALL DCOPY( N, SD, 1, D5, 1 )
IF( N.GT.0 )
$ CALL DCOPY( N-1, SE, 1, WORK, 1 )
CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDU )
*
NTEST = 32
*
IF( N.GT.0 ) THEN
IF( IL.NE.1 ) THEN
VL = D2( IL ) - MAX( HALF*
$ ( D2( IL )-D2( IL-1 ) ), ULP*ANORM,
$ TWO*RTUNFL )
ELSE
VL = D2( 1 ) - MAX( HALF*( D2( N )-D2( 1 ) ),
$ ULP*ANORM, TWO*RTUNFL )
END IF
IF( IU.NE.N ) THEN
VU = D2( IU ) + MAX( HALF*
$ ( D2( IU+1 )-D2( IU ) ), ULP*ANORM,
$ TWO*RTUNFL )
ELSE
VU = D2( N ) + MAX( HALF*( D2( N )-D2( 1 ) ),
$ ULP*ANORM, TWO*RTUNFL )
END IF
ELSE
VL = ZERO
VU = ONE
END IF
*
CALL DSTEMR( 'V', 'V', N, D5, WORK, VL, VU, IL, IU,
$ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC,
$ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ),
$ LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEMR(V,V)', IINFO,
$ N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 32 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do Tests 32 and 33
*
CALL DSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK,
$ M, RESULT( 32 ) )
*
* Call DSTEMR to compute D2, do tests.
*
* Compute D2
*
CALL DCOPY( N, SD, 1, D5, 1 )
IF( N.GT.0 )
$ CALL DCOPY( N-1, SE, 1, WORK, 1 )
*
NTEST = 34
CALL DSTEMR( 'N', 'V', N, D5, WORK, VL, VU, IL, IU,
$ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC,
$ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ),
$ LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEMR(N,V)', IINFO,
$ N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 34 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do Test 34
*
TEMP1 = ZERO
TEMP2 = ZERO
*
DO 250 J = 1, IU - IL + 1
TEMP1 = MAX( TEMP1, ABS( D1( J ) ),
$ ABS( D2( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) )
250 CONTINUE
*
RESULT( 34 ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
ELSE
RESULT( 29 ) = ZERO
RESULT( 30 ) = ZERO
RESULT( 31 ) = ZERO
RESULT( 32 ) = ZERO
RESULT( 33 ) = ZERO
RESULT( 34 ) = ZERO
END IF
*
*
* Call DSTEMR(V,A) to compute D1 and Z, do tests.
*
* Compute D1 and Z
*
CALL DCOPY( N, SD, 1, D5, 1 )
IF( N.GT.0 )
$ CALL DCOPY( N-1, SE, 1, WORK, 1 )
*
NTEST = 35
*
CALL DSTEMR( 'V', 'A', N, D5, WORK, VL, VU, IL, IU,
$ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC,
$ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ),
$ LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEMR(V,A)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 35 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do Tests 35 and 36
*
CALL DSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, M,
$ RESULT( 35 ) )
*
* Call DSTEMR to compute D2, do tests.
*
* Compute D2
*
CALL DCOPY( N, SD, 1, D5, 1 )
IF( N.GT.0 )
$ CALL DCOPY( N-1, SE, 1, WORK, 1 )
*
NTEST = 37
CALL DSTEMR( 'N', 'A', N, D5, WORK, VL, VU, IL, IU,
$ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC,
$ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ),
$ LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEMR(N,A)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 37 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do Test 34
*
TEMP1 = ZERO
TEMP2 = ZERO
*
DO 260 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) )
260 CONTINUE
*
RESULT( 37 ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
END IF
270 CONTINUE
280 CONTINUE
NTESTT = NTESTT + NTEST
*
* End of Loop -- Check for RESULT(j) > THRESH
*
*
* Print out tests which fail.
*
DO 290 JR = 1, NTEST
IF( RESULT( JR ).GE.THRESH ) THEN
*
* If this is the first test to fail,
* print a header to the data file.
*
IF( NERRS.EQ.0 ) THEN
WRITE( NOUNIT, FMT = 9998 )'DST'
WRITE( NOUNIT, FMT = 9997 )
WRITE( NOUNIT, FMT = 9996 )
WRITE( NOUNIT, FMT = 9995 )'Symmetric'
WRITE( NOUNIT, FMT = 9994 )
*
* Tests performed
*
WRITE( NOUNIT, FMT = 9988 )
END IF
NERRS = NERRS + 1
WRITE( NOUNIT, FMT = 9990 )N, IOLDSD, JTYPE, JR,
$ RESULT( JR )
END IF
290 CONTINUE
300 CONTINUE
310 CONTINUE
*
* Summary
*
CALL DLASUM( 'DST', NOUNIT, NERRS, NTESTT )
RETURN
*
9999 FORMAT( ' DCHKST: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
*
9998 FORMAT( / 1X, A3, ' -- Real Symmetric eigenvalue problem' )
9997 FORMAT( ' Matrix types (see DCHKST for details): ' )
*
9996 FORMAT( / ' Special Matrices:',
$ / ' 1=Zero matrix. ',
$ ' 5=Diagonal: clustered entries.',
$ / ' 2=Identity matrix. ',
$ ' 6=Diagonal: large, evenly spaced.',
$ / ' 3=Diagonal: evenly spaced entries. ',
$ ' 7=Diagonal: small, evenly spaced.',
$ / ' 4=Diagonal: geometr. spaced entries.' )
9995 FORMAT( ' Dense ', A, ' Matrices:',
$ / ' 8=Evenly spaced eigenvals. ',
$ ' 12=Small, evenly spaced eigenvals.',
$ / ' 9=Geometrically spaced eigenvals. ',
$ ' 13=Matrix with random O(1) entries.',
$ / ' 10=Clustered eigenvalues. ',
$ ' 14=Matrix with large random entries.',
$ / ' 11=Large, evenly spaced eigenvals. ',
$ ' 15=Matrix with small random entries.' )
9994 FORMAT( ' 16=Positive definite, evenly spaced eigenvalues',
$ / ' 17=Positive definite, geometrically spaced eigenvlaues',
$ / ' 18=Positive definite, clustered eigenvalues',
$ / ' 19=Positive definite, small evenly spaced eigenvalues',
$ / ' 20=Positive definite, large evenly spaced eigenvalues',
$ / ' 21=Diagonally dominant tridiagonal, geometrically',
$ ' spaced eigenvalues' )
*
9993 FORMAT( / ' Tests performed: ',
$ '(S is Tridiag, D is diagonal, U and Z are ', A, ',', / 20X,
$ A, ', W is a diagonal matrix of eigenvalues,', / 20X,
$ ' V is U represented by Householder vectors, and', / 20X,
$ ' Y is a matrix of eigenvectors of S.)',
$ / ' DSYTRD, UPLO=''U'':', / ' 1= | A - V S V', A1,
$ ' | / ( |A| n ulp ) ', ' 2= | I - U V', A1,
$ ' | / ( n ulp )', / ' DSYTRD, UPLO=''L'':',
$ / ' 3= | A - V S V', A1, ' | / ( |A| n ulp ) ',
$ ' 4= | I - U V', A1, ' | / ( n ulp )' )
9992 FORMAT( ' DSPTRD, UPLO=''U'':', / ' 5= | A - V S V', A1,
$ ' | / ( |A| n ulp ) ', ' 6= | I - U V', A1,
$ ' | / ( n ulp )', / ' DSPTRD, UPLO=''L'':',
$ / ' 7= | A - V S V', A1, ' | / ( |A| n ulp ) ',
$ ' 8= | I - U V', A1, ' | / ( n ulp )',
$ / ' 9= | S - Z D Z', A1, ' | / ( |S| n ulp ) ',
$ ' 10= | I - Z Z', A1, ' | / ( n ulp )',
$ / ' 11= |D(with Z) - D(w/o Z)| / (|D| ulp) ',
$ ' 12= | D(PWK) - D(QR) | / (|D| ulp)',
$ / ' 13= Sturm sequence test on W ' )
9991 FORMAT( ' 14= | S - Z4 D4 Z4', A1, ' | / (|S| n ulp)',
$ / ' 15= | I - Z4 Z4', A1, ' | / (n ulp ) ',
$ ' 16= | D4 - D5 | / ( 100 |D4| ulp ) ',
$ / ' 17= max | D4(i) - WR(i) | / ( |D4(i)| (2n-1) ulp )',
$ / ' 18= | WA1 - D3 | / ( |D3| ulp )',
$ / ' 19= max | WA2(i) - WA3(ii) | / ( |D3| ulp )',
$ / ' 20= | S - Y WA1 Y', A1, ' | / ( |S| n ulp )',
$ / ' 21= | I - Y Y', A1, ' | / ( n ulp )' )
9990 FORMAT( ' N=', I5, ', seed=', 4( I4, ',' ), ' type ', I2,
$ ', test(', I2, ')=', G10.3 )
9989 FORMAT( ' 22= | S - Z D Z', A1, '| / ( |S| n ulp ) for DSTEDC(I)',
$ / ' 23= | I - Z Z', A1, '| / ( n ulp ) for DSTEDC(I)',
$ / ' 24= | S - Z D Z', A1, '| / ( |S| n ulp ) for DSTEDC(V)',
$ / ' 25= | I - Z Z', A1, '| / ( n ulp ) for DSTEDC(V)',
$ / ' 26= | D1(DSTEDC(V)) - D2(SSTEDC(N)) | / ( |D1| ulp )' )
*
9988 FORMAT( / 'Test performed: see DCHKST for details.', / )
* End of DCHKST
*
END
SUBROUTINE DCKGLM( NN, MVAL, PVAL, NVAL, NMATS, ISEED, THRESH,
$ NMAX, A, AF, B, BF, X, WORK, RWORK, NIN, NOUT,
$ INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, NIN, NMATS, NMAX, NN, NOUT
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 ), MVAL( * ), NVAL( * ), PVAL( * )
DOUBLE PRECISION A( * ), AF( * ), B( * ), BF( * ), RWORK( * ),
$ WORK( * ), X( * )
* ..
*
* Purpose
* =======
*
* DCKGLM tests DGGGLM - subroutine for solving generalized linear
* model problem.
*
* Arguments
* =========
*
* NN (input) INTEGER
* The number of values of N, M and P contained in the vectors
* NVAL, MVAL and PVAL.
*
* MVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension M.
*
* PVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension P.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix row dimension N.
*
* NMATS (input) INTEGER
* The number of matrix types to be tested for each combination
* of matrix dimensions. If NMATS >= NTYPES (the maximum
* number of matrix types), then all the different types are
* generated for testing. If NMATS < NTYPES, another input line
* is read to get the numbers of the matrix types to be used.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry, the seed of the random number generator. The array
* elements should be between 0 and 4095, otherwise they will be
* reduced mod 4096, and ISEED(4) must be odd.
* On exit, the next seed in the random number sequence after
* all the test matrices have been generated.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESID >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* NMAX (input) INTEGER
* The maximum value permitted for M or N, used in dimensioning
* the work arrays.
*
* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* BF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* X (workspace) DOUBLE PRECISION array, dimension (4*NMAX)
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* NIN (input) INTEGER
* The unit number for input.
*
* NOUT (input) INTEGER
* The unit number for output.
*
* INFO (output) INTEGER
* = 0 : successful exit
* > 0 : If DLATMS returns an error code, the absolute value
* of it is returned.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTYPES
PARAMETER ( NTYPES = 8 )
* ..
* .. Local Scalars ..
LOGICAL FIRSTT
CHARACTER DISTA, DISTB, TYPE
CHARACTER*3 PATH
INTEGER I, IINFO, IK, IMAT, KLA, KLB, KUA, KUB, LDA,
$ LDB, LWORK, M, MODEA, MODEB, N, NFAIL, NRUN, P
DOUBLE PRECISION ANORM, BNORM, CNDNMA, CNDNMB, RESID
* ..
* .. Local Arrays ..
LOGICAL DOTYPE( NTYPES )
* ..
* .. External Functions ..
DOUBLE PRECISION DLARND
EXTERNAL DLARND
* ..
* .. External Subroutines ..
EXTERNAL ALAHDG, ALAREQ, ALASUM, DGLMTS, DLATB9, DLATMS
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
* Initialize constants.
*
PATH( 1: 3 ) = 'GLM'
INFO = 0
NRUN = 0
NFAIL = 0
FIRSTT = .TRUE.
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
LDA = NMAX
LDB = NMAX
LWORK = NMAX*NMAX
*
* Check for valid input values.
*
DO 10 IK = 1, NN
M = MVAL( IK )
P = PVAL( IK )
N = NVAL( IK )
IF( M.GT.N .OR. N.GT.M+P ) THEN
IF( FIRSTT ) THEN
WRITE( NOUT, FMT = * )
FIRSTT = .FALSE.
END IF
WRITE( NOUT, FMT = 9997 )M, P, N
END IF
10 CONTINUE
FIRSTT = .TRUE.
*
* Do for each value of M in MVAL.
*
DO 40 IK = 1, NN
M = MVAL( IK )
P = PVAL( IK )
N = NVAL( IK )
IF( M.GT.N .OR. N.GT.M+P )
$ GO TO 40
*
DO 30 IMAT = 1, NTYPES
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 30
*
* Set up parameters with DLATB9 and generate test
* matrices A and B with DLATMS.
*
CALL DLATB9( PATH, IMAT, M, P, N, TYPE, KLA, KUA, KLB, KUB,
$ ANORM, BNORM, MODEA, MODEB, CNDNMA, CNDNMB,
$ DISTA, DISTB )
*
CALL DLATMS( N, M, DISTA, ISEED, TYPE, RWORK, MODEA, CNDNMA,
$ ANORM, KLA, KUA, 'No packing', A, LDA, WORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9999 )IINFO
INFO = ABS( IINFO )
GO TO 30
END IF
*
CALL DLATMS( N, P, DISTB, ISEED, TYPE, RWORK, MODEB, CNDNMB,
$ BNORM, KLB, KUB, 'No packing', B, LDB, WORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9999 )IINFO
INFO = ABS( IINFO )
GO TO 30
END IF
*
* Generate random left hand side vector of GLM
*
DO 20 I = 1, N
X( I ) = DLARND( 2, ISEED )
20 CONTINUE
*
CALL DGLMTS( N, M, P, A, AF, LDA, B, BF, LDB, X,
$ X( NMAX+1 ), X( 2*NMAX+1 ), X( 3*NMAX+1 ),
$ WORK, LWORK, RWORK, RESID )
*
* Print information about the tests that did not
* pass the threshold.
*
IF( RESID.GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. FIRSTT ) THEN
FIRSTT = .FALSE.
CALL ALAHDG( NOUT, PATH )
END IF
WRITE( NOUT, FMT = 9998 )N, M, P, IMAT, 1, RESID
NFAIL = NFAIL + 1
END IF
NRUN = NRUN + 1
*
30 CONTINUE
40 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, 0 )
*
9999 FORMAT( ' DLATMS in DCKGLM INFO = ', I5 )
9998 FORMAT( ' N=', I4, ' M=', I4, ', P=', I4, ', type ', I2,
$ ', test ', I2, ', ratio=', G13.6 )
9997 FORMAT( ' *** Invalid input for GLM: M = ', I6, ', P = ', I6,
$ ', N = ', I6, ';', / ' must satisfy M <= N <= M+P ',
$ '(this set of values will be skipped)' )
RETURN
*
* End of DCKGLM
*
END
SUBROUTINE DCKGQR( NM, MVAL, NP, PVAL, NN, NVAL, NMATS, ISEED,
$ THRESH, NMAX, A, AF, AQ, AR, TAUA, B, BF, BZ,
$ BT, BWK, TAUB, WORK, RWORK, NIN, NOUT, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, NIN, NM, NMATS, NMAX, NN, NOUT, NP
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 ), MVAL( * ), NVAL( * ), PVAL( * )
DOUBLE PRECISION A( * ), AF( * ), AQ( * ), AR( * ), B( * ),
$ BF( * ), BT( * ), BWK( * ), BZ( * ),
$ RWORK( * ), TAUA( * ), TAUB( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DCKGQR tests
* DGGQRF: GQR factorization for N-by-M matrix A and N-by-P matrix B,
* DGGRQF: GRQ factorization for M-by-N matrix A and P-by-N matrix B.
*
* Arguments
* =========
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row(column) dimension M.
*
* NP (input) INTEGER
* The number of values of P contained in the vector PVAL.
*
* PVAL (input) INTEGER array, dimension (NP)
* The values of the matrix row(column) dimension P.
*
* NN (input) INTEGER
* The number of values of N contained in the vector NVAL.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column(row) dimension N.
*
* NMATS (input) INTEGER
* The number of matrix types to be tested for each combination
* of matrix dimensions. If NMATS >= NTYPES (the maximum
* number of matrix types), then all the different types are
* generated for testing. If NMATS < NTYPES, another input line
* is read to get the numbers of the matrix types to be used.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry, the seed of the random number generator. The array
* elements should be between 0 and 4095, otherwise they will be
* reduced mod 4096, and ISEED(4) must be odd.
* On exit, the next seed in the random number sequence after
* all the test matrices have been generated.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* NMAX (input) INTEGER
* The maximum value permitted for M or N, used in dimensioning
* the work arrays.
*
* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AQ (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AR (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* TAUA (workspace) DOUBLE PRECISION array, dimension (NMAX)
*
* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* BF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* BZ (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* BT (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* BWK (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* TAUB (workspace) DOUBLE PRECISION array, dimension (NMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX)
*
* NIN (input) INTEGER
* The unit number for input.
*
* NOUT (input) INTEGER
* The unit number for output.
*
* INFO (output) INTEGER
* = 0 : successful exit
* > 0 : If DLATMS returns an error code, the absolute value
* of it is returned.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTESTS
PARAMETER ( NTESTS = 7 )
INTEGER NTYPES
PARAMETER ( NTYPES = 8 )
* ..
* .. Local Scalars ..
LOGICAL FIRSTT
CHARACTER DISTA, DISTB, TYPE
CHARACTER*3 PATH
INTEGER I, IINFO, IM, IMAT, IN, IP, KLA, KLB, KUA, KUB,
$ LDA, LDB, LWORK, M, MODEA, MODEB, N, NFAIL,
$ NRUN, NT, P
DOUBLE PRECISION ANORM, BNORM, CNDNMA, CNDNMB
* ..
* .. Local Arrays ..
LOGICAL DOTYPE( NTYPES )
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Subroutines ..
EXTERNAL ALAHDG, ALAREQ, ALASUM, DGQRTS, DGRQTS, DLATB9,
$ DLATMS
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
* Initialize constants.
*
PATH( 1: 3 ) = 'GQR'
INFO = 0
NRUN = 0
NFAIL = 0
FIRSTT = .TRUE.
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
LDA = NMAX
LDB = NMAX
LWORK = NMAX*NMAX
*
* Do for each value of M in MVAL.
*
DO 60 IM = 1, NM
M = MVAL( IM )
*
* Do for each value of P in PVAL.
*
DO 50 IP = 1, NP
P = PVAL( IP )
*
* Do for each value of N in NVAL.
*
DO 40 IN = 1, NN
N = NVAL( IN )
*
DO 30 IMAT = 1, NTYPES
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 30
*
* Test DGGRQF
*
* Set up parameters with DLATB9 and generate test
* matrices A and B with DLATMS.
*
CALL DLATB9( 'GRQ', IMAT, M, P, N, TYPE, KLA, KUA,
$ KLB, KUB, ANORM, BNORM, MODEA, MODEB,
$ CNDNMA, CNDNMB, DISTA, DISTB )
*
* Generate M by N matrix A
*
CALL DLATMS( M, N, DISTA, ISEED, TYPE, RWORK, MODEA,
$ CNDNMA, ANORM, KLA, KUA, 'No packing', A,
$ LDA, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9999 )IINFO
INFO = ABS( IINFO )
GO TO 30
END IF
*
* Generate P by N matrix B
*
CALL DLATMS( P, N, DISTB, ISEED, TYPE, RWORK, MODEB,
$ CNDNMB, BNORM, KLB, KUB, 'No packing', B,
$ LDB, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9999 )IINFO
INFO = ABS( IINFO )
GO TO 30
END IF
*
NT = 4
*
CALL DGRQTS( M, P, N, A, AF, AQ, AR, LDA, TAUA, B, BF,
$ BZ, BT, BWK, LDB, TAUB, WORK, LWORK,
$ RWORK, RESULT )
*
* Print information about the tests that did not
* pass the threshold.
*
DO 10 I = 1, NT
IF( RESULT( I ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. FIRSTT ) THEN
FIRSTT = .FALSE.
CALL ALAHDG( NOUT, 'GRQ' )
END IF
WRITE( NOUT, FMT = 9998 )M, P, N, IMAT, I,
$ RESULT( I )
NFAIL = NFAIL + 1
END IF
10 CONTINUE
NRUN = NRUN + NT
*
* Test DGGQRF
*
* Set up parameters with DLATB9 and generate test
* matrices A and B with DLATMS.
*
CALL DLATB9( 'GQR', IMAT, M, P, N, TYPE, KLA, KUA,
$ KLB, KUB, ANORM, BNORM, MODEA, MODEB,
$ CNDNMA, CNDNMB, DISTA, DISTB )
*
* Generate N-by-M matrix A
*
CALL DLATMS( N, M, DISTA, ISEED, TYPE, RWORK, MODEA,
$ CNDNMA, ANORM, KLA, KUA, 'No packing', A,
$ LDA, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9999 )IINFO
INFO = ABS( IINFO )
GO TO 30
END IF
*
* Generate N-by-P matrix B
*
CALL DLATMS( N, P, DISTB, ISEED, TYPE, RWORK, MODEA,
$ CNDNMA, BNORM, KLB, KUB, 'No packing', B,
$ LDB, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9999 )IINFO
INFO = ABS( IINFO )
GO TO 30
END IF
*
NT = 4
*
CALL DGQRTS( N, M, P, A, AF, AQ, AR, LDA, TAUA, B, BF,
$ BZ, BT, BWK, LDB, TAUB, WORK, LWORK,
$ RWORK, RESULT )
*
* Print information about the tests that did not
* pass the threshold.
*
DO 20 I = 1, NT
IF( RESULT( I ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. FIRSTT ) THEN
FIRSTT = .FALSE.
CALL ALAHDG( NOUT, PATH )
END IF
WRITE( NOUT, FMT = 9997 )N, M, P, IMAT, I,
$ RESULT( I )
NFAIL = NFAIL + 1
END IF
20 CONTINUE
NRUN = NRUN + NT
*
30 CONTINUE
40 CONTINUE
50 CONTINUE
60 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, 0 )
*
9999 FORMAT( ' DLATMS in DCKGQR: INFO = ', I5 )
9998 FORMAT( ' M=', I4, ' P=', I4, ', N=', I4, ', type ', I2,
$ ', test ', I2, ', ratio=', G13.6 )
9997 FORMAT( ' N=', I4, ' M=', I4, ', P=', I4, ', type ', I2,
$ ', test ', I2, ', ratio=', G13.6 )
RETURN
*
* End of DCKGQR
*
END
SUBROUTINE DCKGSV( NM, MVAL, PVAL, NVAL, NMATS, ISEED, THRESH,
$ NMAX, A, AF, B, BF, U, V, Q, ALPHA, BETA, R,
$ IWORK, WORK, RWORK, NIN, NOUT, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, NIN, NM, NMATS, NMAX, NOUT
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 ), IWORK( * ), MVAL( * ), NVAL( * ),
$ PVAL( * )
DOUBLE PRECISION A( * ), AF( * ), ALPHA( * ), B( * ), BETA( * ),
$ BF( * ), Q( * ), R( * ), RWORK( * ), U( * ),
$ V( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DCKGSV tests DGGSVD:
* the GSVD for M-by-N matrix A and P-by-N matrix B.
*
* Arguments
* =========
*
* NM (input) INTEGER
* The number of values of M contained in the vector MVAL.
*
* MVAL (input) INTEGER array, dimension (NM)
* The values of the matrix row dimension M.
*
* PVAL (input) INTEGER array, dimension (NP)
* The values of the matrix row dimension P.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column dimension N.
*
* NMATS (input) INTEGER
* The number of matrix types to be tested for each combination
* of matrix dimensions. If NMATS >= NTYPES (the maximum
* number of matrix types), then all the different types are
* generated for testing. If NMATS < NTYPES, another input line
* is read to get the numbers of the matrix types to be used.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry, the seed of the random number generator. The array
* elements should be between 0 and 4095, otherwise they will be
* reduced mod 4096, and ISEED(4) must be odd.
* On exit, the next seed in the random number sequence after
* all the test matrices have been generated.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* NMAX (input) INTEGER
* The maximum value permitted for M or N, used in dimensioning
* the work arrays.
*
* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* BF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* U (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* V (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* Q (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* ALPHA (workspace) DOUBLE PRECISION array, dimension (NMAX)
*
* BETA (workspace) DOUBLE PRECISION array, dimension (NMAX)
*
* R (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* IWORK (workspace) INTEGER array, dimension (NMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX)
*
* NIN (input) INTEGER
* The unit number for input.
*
* NOUT (input) INTEGER
* The unit number for output.
*
* INFO (output) INTEGER
* = 0 : successful exit
* > 0 : If DLATMS returns an error code, the absolute value
* of it is returned.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTESTS
PARAMETER ( NTESTS = 7 )
INTEGER NTYPES
PARAMETER ( NTYPES = 8 )
* ..
* .. Local Scalars ..
LOGICAL FIRSTT
CHARACTER DISTA, DISTB, TYPE
CHARACTER*3 PATH
INTEGER I, IINFO, IM, IMAT, KLA, KLB, KUA, KUB, LDA,
$ LDB, LDQ, LDR, LDU, LDV, LWORK, M, MODEA,
$ MODEB, N, NFAIL, NRUN, NT, P
DOUBLE PRECISION ANORM, BNORM, CNDNMA, CNDNMB
* ..
* .. Local Arrays ..
LOGICAL DOTYPE( NTYPES )
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Subroutines ..
EXTERNAL ALAHDG, ALAREQ, ALASUM, DGSVTS, DLATB9, DLATMS
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 3 ) = 'GSV'
INFO = 0
NRUN = 0
NFAIL = 0
FIRSTT = .TRUE.
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
LDA = NMAX
LDB = NMAX
LDU = NMAX
LDV = NMAX
LDQ = NMAX
LDR = NMAX
LWORK = NMAX*NMAX
*
* Do for each value of M in MVAL.
*
DO 30 IM = 1, NM
M = MVAL( IM )
P = PVAL( IM )
N = NVAL( IM )
*
DO 20 IMAT = 1, NTYPES
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 20
*
* Set up parameters with DLATB9 and generate test
* matrices A and B with DLATMS.
*
CALL DLATB9( PATH, IMAT, M, P, N, TYPE, KLA, KUA, KLB, KUB,
$ ANORM, BNORM, MODEA, MODEB, CNDNMA, CNDNMB,
$ DISTA, DISTB )
*
* Generate M by N matrix A
*
CALL DLATMS( M, N, DISTA, ISEED, TYPE, RWORK, MODEA, CNDNMA,
$ ANORM, KLA, KUA, 'No packing', A, LDA, WORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9999 )IINFO
INFO = ABS( IINFO )
GO TO 20
END IF
*
CALL DLATMS( P, N, DISTB, ISEED, TYPE, RWORK, MODEB, CNDNMB,
$ BNORM, KLB, KUB, 'No packing', B, LDB, WORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9999 )IINFO
INFO = ABS( IINFO )
GO TO 20
END IF
*
NT = 6
*
CALL DGSVTS( M, P, N, A, AF, LDA, B, BF, LDB, U, LDU, V,
$ LDV, Q, LDQ, ALPHA, BETA, R, LDR, IWORK, WORK,
$ LWORK, RWORK, RESULT )
*
* Print information about the tests that did not
* pass the threshold.
*
DO 10 I = 1, NT
IF( RESULT( I ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. FIRSTT ) THEN
FIRSTT = .FALSE.
CALL ALAHDG( NOUT, PATH )
END IF
WRITE( NOUT, FMT = 9998 )M, P, N, IMAT, I,
$ RESULT( I )
NFAIL = NFAIL + 1
END IF
10 CONTINUE
NRUN = NRUN + NT
20 CONTINUE
30 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, 0 )
*
9999 FORMAT( ' DLATMS in DCKGSV INFO = ', I5 )
9998 FORMAT( ' M=', I4, ' P=', I4, ', N=', I4, ', type ', I2,
$ ', test ', I2, ', ratio=', G13.6 )
RETURN
*
* End of DCKGSV
*
END
SUBROUTINE DCKLSE( NN, MVAL, PVAL, NVAL, NMATS, ISEED, THRESH,
$ NMAX, A, AF, B, BF, X, WORK, RWORK, NIN, NOUT,
$ INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, NIN, NMATS, NMAX, NN, NOUT
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 ), MVAL( * ), NVAL( * ), PVAL( * )
DOUBLE PRECISION A( * ), AF( * ), B( * ), BF( * ), RWORK( * ),
$ WORK( * ), X( * )
* ..
*
* Purpose
* =======
*
* DCKLSE tests DGGLSE - a subroutine for solving linear equality
* constrained least square problem (LSE).
*
* Arguments
* =========
*
* NN (input) INTEGER
* The number of values of (M,P,N) contained in the vectors
* (MVAL, PVAL, NVAL).
*
* MVAL (input) INTEGER array, dimension (NN)
* The values of the matrix row(column) dimension M.
*
* PVAL (input) INTEGER array, dimension (NN)
* The values of the matrix row(column) dimension P.
*
* NVAL (input) INTEGER array, dimension (NN)
* The values of the matrix column(row) dimension N.
*
* NMATS (input) INTEGER
* The number of matrix types to be tested for each combination
* of matrix dimensions. If NMATS >= NTYPES (the maximum
* number of matrix types), then all the different types are
* generated for testing. If NMATS < NTYPES, another input line
* is read to get the numbers of the matrix types to be used.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry, the seed of the random number generator. The array
* elements should be between 0 and 4095, otherwise they will be
* reduced mod 4096, and ISEED(4) must be odd.
* On exit, the next seed in the random number sequence after
* all the test matrices have been generated.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. To have
* every test ratio printed, use THRESH = 0.
*
* NMAX (input) INTEGER
* The maximum value permitted for M or N, used in dimensioning
* the work arrays.
*
* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* AF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* BF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* X (workspace) DOUBLE PRECISION array, dimension (5*NMAX)
*
* WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX)
*
* NIN (input) INTEGER
* The unit number for input.
*
* NOUT (input) INTEGER
* The unit number for output.
*
* INFO (output) INTEGER
* = 0 : successful exit
* > 0 : If DLATMS returns an error code, the absolute value
* of it is returned.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTESTS
PARAMETER ( NTESTS = 7 )
INTEGER NTYPES
PARAMETER ( NTYPES = 8 )
* ..
* .. Local Scalars ..
LOGICAL FIRSTT
CHARACTER DISTA, DISTB, TYPE
CHARACTER*3 PATH
INTEGER I, IINFO, IK, IMAT, KLA, KLB, KUA, KUB, LDA,
$ LDB, LWORK, M, MODEA, MODEB, N, NFAIL, NRUN,
$ NT, P
DOUBLE PRECISION ANORM, BNORM, CNDNMA, CNDNMB
* ..
* .. Local Arrays ..
LOGICAL DOTYPE( NTYPES )
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Subroutines ..
EXTERNAL ALAHDG, ALAREQ, ALASUM, DLARHS, DLATB9, DLATMS,
$ DLSETS
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Initialize constants and the random number seed.
*
PATH( 1: 3 ) = 'LSE'
INFO = 0
NRUN = 0
NFAIL = 0
FIRSTT = .TRUE.
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
LDA = NMAX
LDB = NMAX
LWORK = NMAX*NMAX
*
* Check for valid input values.
*
DO 10 IK = 1, NN
M = MVAL( IK )
P = PVAL( IK )
N = NVAL( IK )
IF( P.GT.N .OR. N.GT.M+P ) THEN
IF( FIRSTT ) THEN
WRITE( NOUT, FMT = * )
FIRSTT = .FALSE.
END IF
WRITE( NOUT, FMT = 9997 )M, P, N
END IF
10 CONTINUE
FIRSTT = .TRUE.
*
* Do for each value of M in MVAL.
*
DO 40 IK = 1, NN
M = MVAL( IK )
P = PVAL( IK )
N = NVAL( IK )
IF( P.GT.N .OR. N.GT.M+P )
$ GO TO 40
*
DO 30 IMAT = 1, NTYPES
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 30
*
* Set up parameters with DLATB9 and generate test
* matrices A and B with DLATMS.
*
CALL DLATB9( PATH, IMAT, M, P, N, TYPE, KLA, KUA, KLB, KUB,
$ ANORM, BNORM, MODEA, MODEB, CNDNMA, CNDNMB,
$ DISTA, DISTB )
*
CALL DLATMS( M, N, DISTA, ISEED, TYPE, RWORK, MODEA, CNDNMA,
$ ANORM, KLA, KUA, 'No packing', A, LDA, WORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9999 )IINFO
INFO = ABS( IINFO )
GO TO 30
END IF
*
CALL DLATMS( P, N, DISTB, ISEED, TYPE, RWORK, MODEB, CNDNMB,
$ BNORM, KLB, KUB, 'No packing', B, LDB, WORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9999 )IINFO
INFO = ABS( IINFO )
GO TO 30
END IF
*
* Generate the right-hand sides C and D for the LSE.
*
CALL DLARHS( 'DGE', 'New solution', 'Upper', 'N', M, N,
$ MAX( M-1, 0 ), MAX( N-1, 0 ), 1, A, LDA,
$ X( 4*NMAX+1 ), MAX( N, 1 ), X, MAX( M, 1 ),
$ ISEED, IINFO )
*
CALL DLARHS( 'DGE', 'Computed', 'Upper', 'N', P, N,
$ MAX( P-1, 0 ), MAX( N-1, 0 ), 1, B, LDB,
$ X( 4*NMAX+1 ), MAX( N, 1 ), X( 2*NMAX+1 ),
$ MAX( P, 1 ), ISEED, IINFO )
*
NT = 2
*
CALL DLSETS( M, P, N, A, AF, LDA, B, BF, LDB, X,
$ X( NMAX+1 ), X( 2*NMAX+1 ), X( 3*NMAX+1 ),
$ X( 4*NMAX+1 ), WORK, LWORK, RWORK,
$ RESULT( 1 ) )
*
* Print information about the tests that did not
* pass the threshold.
*
DO 20 I = 1, NT
IF( RESULT( I ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. FIRSTT ) THEN
FIRSTT = .FALSE.
CALL ALAHDG( NOUT, PATH )
END IF
WRITE( NOUT, FMT = 9998 )M, P, N, IMAT, I,
$ RESULT( I )
NFAIL = NFAIL + 1
END IF
20 CONTINUE
NRUN = NRUN + NT
*
30 CONTINUE
40 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, 0 )
*
9999 FORMAT( ' DLATMS in DCKLSE INFO = ', I5 )
9998 FORMAT( ' M=', I4, ' P=', I4, ', N=', I4, ', type ', I2,
$ ', test ', I2, ', ratio=', G13.6 )
9997 FORMAT( ' *** Invalid input for LSE: M = ', I6, ', P = ', I6,
$ ', N = ', I6, ';', / ' must satisfy P <= N <= P+M ',
$ '(this set of values will be skipped)' )
RETURN
*
* End of DCKLSE
*
END
SUBROUTINE DDRGES( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
$ NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, ALPHAR,
$ ALPHAI, BETA, WORK, LWORK, RESULT, BWORK,
$ INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL BWORK( * ), DOTYPE( * )
INTEGER ISEED( 4 ), NN( * )
DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
$ B( LDA, * ), BETA( * ), Q( LDQ, * ),
$ RESULT( 13 ), S( LDA, * ), T( LDA, * ),
$ WORK( * ), Z( LDQ, * )
* ..
*
* Purpose
* =======
*
* DDRGES checks the nonsymmetric generalized eigenvalue (Schur form)
* problem driver DGGES.
*
* DGGES factors A and B as Q S Z' and Q T Z' , where ' means
* transpose, T is upper triangular, S is in generalized Schur form
* (block upper triangular, with 1x1 and 2x2 blocks on the diagonal,
* the 2x2 blocks corresponding to complex conjugate pairs of
* generalized eigenvalues), and Q and Z are orthogonal. It also
* computes the generalized eigenvalues (alpha(j),beta(j)), j=1,...,n,
* Thus, w(j) = alpha(j)/beta(j) is a root of the characteristic
* equation
* det( A - w(j) B ) = 0
* Optionally it also reorder the eigenvalues so that a selected
* cluster of eigenvalues appears in the leading diagonal block of the
* Schur forms.
*
* When DDRGES is called, a number of matrix "sizes" ("N's") and a
* number of matrix "TYPES" are specified. For each size ("N")
* and each TYPE of matrix, a pair of matrices (A, B) will be generated
* and used for testing. For each matrix pair, the following 13 tests
* will be performed and compared with the threshhold THRESH except
* the tests (5), (11) and (13).
*
*
* (1) | A - Q S Z' | / ( |A| n ulp ) (no sorting of eigenvalues)
*
*
* (2) | B - Q T Z' | / ( |B| n ulp ) (no sorting of eigenvalues)
*
*
* (3) | I - QQ' | / ( n ulp ) (no sorting of eigenvalues)
*
*
* (4) | I - ZZ' | / ( n ulp ) (no sorting of eigenvalues)
*
* (5) if A is in Schur form (i.e. quasi-triangular form)
* (no sorting of eigenvalues)
*
* (6) if eigenvalues = diagonal blocks of the Schur form (S, T),
* i.e., test the maximum over j of D(j) where:
*
* if alpha(j) is real:
* |alpha(j) - S(j,j)| |beta(j) - T(j,j)|
* D(j) = ------------------------ + -----------------------
* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|)
*
* if alpha(j) is complex:
* | det( s S - w T ) |
* D(j) = ---------------------------------------------------
* ulp max( s norm(S), |w| norm(T) )*norm( s S - w T )
*
* and S and T are here the 2 x 2 diagonal blocks of S and T
* corresponding to the j-th and j+1-th eigenvalues.
* (no sorting of eigenvalues)
*
* (7) | (A,B) - Q (S,T) Z' | / ( | (A,B) | n ulp )
* (with sorting of eigenvalues).
*
* (8) | I - QQ' | / ( n ulp ) (with sorting of eigenvalues).
*
* (9) | I - ZZ' | / ( n ulp ) (with sorting of eigenvalues).
*
* (10) if A is in Schur form (i.e. quasi-triangular form)
* (with sorting of eigenvalues).
*
* (11) if eigenvalues = diagonal blocks of the Schur form (S, T),
* i.e. test the maximum over j of D(j) where:
*
* if alpha(j) is real:
* |alpha(j) - S(j,j)| |beta(j) - T(j,j)|
* D(j) = ------------------------ + -----------------------
* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|)
*
* if alpha(j) is complex:
* | det( s S - w T ) |
* D(j) = ---------------------------------------------------
* ulp max( s norm(S), |w| norm(T) )*norm( s S - w T )
*
* and S and T are here the 2 x 2 diagonal blocks of S and T
* corresponding to the j-th and j+1-th eigenvalues.
* (with sorting of eigenvalues).
*
* (12) if sorting worked and SDIM is the number of eigenvalues
* which were SELECTed.
*
* Test Matrices
* =============
*
* The sizes of the test matrices are specified by an array
* NN(1:NSIZES); the value of each element NN(j) specifies one size.
* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if
* DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
* Currently, the list of possible types is:
*
* (1) ( 0, 0 ) (a pair of zero matrices)
*
* (2) ( I, 0 ) (an identity and a zero matrix)
*
* (3) ( 0, I ) (an identity and a zero matrix)
*
* (4) ( I, I ) (a pair of identity matrices)
*
* t t
* (5) ( J , J ) (a pair of transposed Jordan blocks)
*
* t ( I 0 )
* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t )
* ( 0 I ) ( 0 J )
* and I is a k x k identity and J a (k+1)x(k+1)
* Jordan block; k=(N-1)/2
*
* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal
* matrix with those diagonal entries.)
* (8) ( I, D )
*
* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big
*
* (10) ( small*D, big*I )
*
* (11) ( big*I, small*D )
*
* (12) ( small*I, big*D )
*
* (13) ( big*D, big*I )
*
* (14) ( small*D, small*I )
*
* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and
* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 )
* t t
* (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices.
*
* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices
* with random O(1) entries above the diagonal
* and diagonal entries diag(T1) =
* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) =
* ( 0, N-3, N-4,..., 1, 0, 0 )
*
* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 )
* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 )
* s = machine precision.
*
* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 )
* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 )
*
* N-5
* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 )
* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
*
* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 )
* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
* where r1,..., r(N-4) are random.
*
* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular
* matrices.
*
*
* Arguments
* =========
*
* NSIZES (input) INTEGER
* The number of sizes of matrices to use. If it is zero,
* DDRGES does nothing. NSIZES >= 0.
*
* NN (input) INTEGER array, dimension (NSIZES)
* An array containing the sizes to be used for the matrices.
* Zero values will be skipped. NN >= 0.
*
* NTYPES (input) INTEGER
* The number of elements in DOTYPE. If it is zero, DDRGES
* does nothing. It must be at least zero. If it is MAXTYP+1
* and NSIZES is 1, then an additional type, MAXTYP+1 is
* defined, which is to use whatever matrix is in A on input.
* This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
* DOTYPE(MAXTYP+1) is .TRUE. .
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* If DOTYPE(j) is .TRUE., then for each size in NN a
* matrix of that size and of type j will be generated.
* If NTYPES is smaller than the maximum number of types
* defined (PARAMETER MAXTYP), then types NTYPES+1 through
* MAXTYP will not be generated. If NTYPES is larger
* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
* will be ignored.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The array elements should be between 0 and 4095;
* if not they will be reduced mod 4096. Also, ISEED(4) must
* be odd. The random number generator uses a linear
* congruential sequence limited to small integers, and so
* should produce machine independent random numbers. The
* values of ISEED are changed on exit, and can be used in the
* next call to DDRGES to continue the same random number
* sequence.
*
* THRESH (input) DOUBLE PRECISION
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error is
* scaled to be O(1), so THRESH should be a reasonably small
* multiple of 1, e.g., 10 or 100. In particular, it should
* not depend on the precision (single vs. double) or the size
* of the matrix. THRESH >= 0.
*
* NOUNIT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns IINFO not equal to 0.)
*
* A (input/workspace) DOUBLE PRECISION array,
* dimension(LDA, max(NN))
* Used to hold the original A matrix. Used as input only
* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
* DOTYPE(MAXTYP+1)=.TRUE.
*
* LDA (input) INTEGER
* The leading dimension of A, B, S, and T.
* It must be at least 1 and at least max( NN ).
*
* B (input/workspace) DOUBLE PRECISION array,
* dimension(LDA, max(NN))
* Used to hold the original B matrix. Used as input only
* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
* DOTYPE(MAXTYP+1)=.TRUE.
*
* S (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
* The Schur form matrix computed from A by DGGES. On exit, S
* contains the Schur form matrix corresponding to the matrix
* in A.
*
* T (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
* The upper triangular matrix computed from B by DGGES.
*
* Q (workspace) DOUBLE PRECISION array, dimension (LDQ, max(NN))
* The (left) orthogonal matrix computed by DGGES.
*
* LDQ (input) INTEGER
* The leading dimension of Q and Z. It must
* be at least 1 and at least max( NN ).
*
* Z (workspace) DOUBLE PRECISION array, dimension( LDQ, max(NN) )
* The (right) orthogonal matrix computed by DGGES.
*
* ALPHAR (workspace) DOUBLE PRECISION array, dimension (max(NN))
* ALPHAI (workspace) DOUBLE PRECISION array, dimension (max(NN))
* BETA (workspace) DOUBLE PRECISION array, dimension (max(NN))
* The generalized eigenvalues of (A,B) computed by DGGES.
* ( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th
* generalized eigenvalue of A and B.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* LWORK >= MAX( 10*(N+1), 3*N*N ), where N is the largest
* matrix dimension.
*
* RESULT (output) DOUBLE PRECISION array, dimension (15)
* The values computed by the tests described above.
* The values are currently limited to 1/ulp, to avoid overflow.
*
* BWORK (workspace) LOGICAL array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: A routine returned an error code. INFO is the
* absolute value of the INFO value returned.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 26 )
* ..
* .. Local Scalars ..
LOGICAL BADNN, ILABAD
CHARACTER SORT
INTEGER I, I1, IADD, IERR, IINFO, IN, ISORT, J, JC, JR,
$ JSIZE, JTYPE, KNTEIG, MAXWRK, MINWRK, MTYPES,
$ N, N1, NB, NERRS, NMATS, NMAX, NTEST, NTESTT,
$ RSUB, SDIM
DOUBLE PRECISION SAFMAX, SAFMIN, TEMP1, TEMP2, ULP, ULPINV
* ..
* .. Local Arrays ..
INTEGER IASIGN( MAXTYP ), IBSIGN( MAXTYP ),
$ IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ),
$ KATYPE( MAXTYP ), KAZERO( MAXTYP ),
$ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ),
$ KBZERO( MAXTYP ), KCLASS( MAXTYP ),
$ KTRIAN( MAXTYP ), KZ1( 6 ), KZ2( 6 )
DOUBLE PRECISION RMAGN( 0: 3 )
* ..
* .. External Functions ..
LOGICAL DLCTES
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLARND
EXTERNAL DLCTES, ILAENV, DLAMCH, DLARND
* ..
* .. External Subroutines ..
EXTERNAL ALASVM, DGET51, DGET53, DGET54, DGGES, DLABAD,
$ DLACPY, DLARFG, DLASET, DLATM4, DORM2R, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN, SIGN
* ..
* .. Data statements ..
DATA KCLASS / 15*1, 10*2, 1*3 /
DATA KZ1 / 0, 1, 2, 1, 3, 3 /
DATA KZ2 / 0, 0, 1, 2, 1, 1 /
DATA KADD / 0, 0, 0, 0, 3, 2 /
DATA KATYPE / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4,
$ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 /
DATA KBTYPE / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4,
$ 1, 1, -4, 2, -4, 8*8, 0 /
DATA KAZERO / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3,
$ 4*5, 4*3, 1 /
DATA KBZERO / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4,
$ 4*6, 4*4, 1 /
DATA KAMAGN / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3,
$ 2, 1 /
DATA KBMAGN / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3,
$ 2, 1 /
DATA KTRIAN / 16*0, 10*1 /
DATA IASIGN / 6*0, 2, 0, 2*2, 2*0, 3*2, 0, 2, 3*0,
$ 5*2, 0 /
DATA IBSIGN / 7*0, 2, 2*0, 2*2, 2*0, 2, 0, 2, 9*0 /
* ..
* .. Executable Statements ..
*
* Check for errors
*
INFO = 0
*
BADNN = .FALSE.
NMAX = 1
DO 10 J = 1, NSIZES
NMAX = MAX( NMAX, NN( J ) )
IF( NN( J ).LT.0 )
$ BADNN = .TRUE.
10 CONTINUE
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADNN ) THEN
INFO = -2
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -3
ELSE IF( THRESH.LT.ZERO ) THEN
INFO = -6
ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN
INFO = -9
ELSE IF( LDQ.LE.1 .OR. LDQ.LT.NMAX ) THEN
INFO = -14
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.
*
MINWRK = 1
IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN
MINWRK = MAX( 10*( NMAX+1 ), 3*NMAX*NMAX )
NB = MAX( 1, ILAENV( 1, 'DGEQRF', ' ', NMAX, NMAX, -1, -1 ),
$ ILAENV( 1, 'DORMQR', 'LT', NMAX, NMAX, NMAX, -1 ),
$ ILAENV( 1, 'DORGQR', ' ', NMAX, NMAX, NMAX, -1 ) )
MAXWRK = MAX( 10*( NMAX+1 ), 2*NMAX+NMAX*NB, 3*NMAX*NMAX )
WORK( 1 ) = MAXWRK
END IF
*
IF( LWORK.LT.MINWRK )
$ INFO = -20
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DDRGES', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
$ RETURN
*
SAFMIN = DLAMCH( 'Safe minimum' )
ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
SAFMIN = SAFMIN / ULP
SAFMAX = ONE / SAFMIN
CALL DLABAD( SAFMIN, SAFMAX )
ULPINV = ONE / ULP
*
* The values RMAGN(2:3) depend on N, see below.
*
RMAGN( 0 ) = ZERO
RMAGN( 1 ) = ONE
*
* Loop over matrix sizes
*
NTESTT = 0
NERRS = 0
NMATS = 0
*
DO 190 JSIZE = 1, NSIZES
N = NN( JSIZE )
N1 = MAX( 1, N )
RMAGN( 2 ) = SAFMAX*ULP / DBLE( N1 )
RMAGN( 3 ) = SAFMIN*ULPINV*DBLE( N1 )
*
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
* Loop over matrix types
*
DO 180 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 180
NMATS = NMATS + 1
NTEST = 0
*
* Save ISEED in case of an error.
*
DO 20 J = 1, 4
IOLDSD( J ) = ISEED( J )
20 CONTINUE
*
* Initialize RESULT
*
DO 30 J = 1, 13
RESULT( J ) = ZERO
30 CONTINUE
*
* Generate test matrices A and B
*
* Description of control parameters:
*
* KZLASS: =1 means w/o rotation, =2 means w/ rotation,
* =3 means random.
* KATYPE: the "type" to be passed to DLATM4 for computing A.
* KAZERO: the pattern of zeros on the diagonal for A:
* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ),
* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ),
* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of
* non-zero entries.)
* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1),
* =2: large, =3: small.
* IASIGN: 1 if the diagonal elements of A are to be
* multiplied by a random magnitude 1 number, =2 if
* randomly chosen diagonal blocks are to be rotated
* to form 2x2 blocks.
* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B.
* KTRIAN: =0: don't fill in the upper triangle, =1: do.
* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO.
* RMAGN: used to implement KAMAGN and KBMAGN.
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 110
IINFO = 0
IF( KCLASS( JTYPE ).LT.3 ) THEN
*
* Generate A (w/o rotation)
*
IF( ABS( KATYPE( JTYPE ) ).EQ.3 ) THEN
IN = 2*( ( N-1 ) / 2 ) + 1
IF( IN.NE.N )
$ CALL DLASET( 'Full', N, N, ZERO, ZERO, A, LDA )
ELSE
IN = N
END IF
CALL DLATM4( KATYPE( JTYPE ), IN, KZ1( KAZERO( JTYPE ) ),
$ KZ2( KAZERO( JTYPE ) ), IASIGN( JTYPE ),
$ RMAGN( KAMAGN( JTYPE ) ), ULP,
$ RMAGN( KTRIAN( JTYPE )*KAMAGN( JTYPE ) ), 2,
$ ISEED, A, LDA )
IADD = KADD( KAZERO( JTYPE ) )
IF( IADD.GT.0 .AND. IADD.LE.N )
$ A( IADD, IADD ) = ONE
*
* Generate B (w/o rotation)
*
IF( ABS( KBTYPE( JTYPE ) ).EQ.3 ) THEN
IN = 2*( ( N-1 ) / 2 ) + 1
IF( IN.NE.N )
$ CALL DLASET( 'Full', N, N, ZERO, ZERO, B, LDA )
ELSE
IN = N
END IF
CALL DLATM4( KBTYPE( JTYPE ), IN, KZ1( KBZERO( JTYPE ) ),
$ KZ2( KBZERO( JTYPE ) ), IBSIGN( JTYPE ),
$ RMAGN( KBMAGN( JTYPE ) ), ONE,
$ RMAGN( KTRIAN( JTYPE )*KBMAGN( JTYPE ) ), 2,
$ ISEED, B, LDA )
IADD = KADD( KBZERO( JTYPE ) )
IF( IADD.NE.0 .AND. IADD.LE.N )
$ B( IADD, IADD ) = ONE
*
IF( KCLASS( JTYPE ).EQ.2 .AND. N.GT.0 ) THEN
*
* Include rotations
*
* Generate Q, Z as Householder transformations times
* a diagonal matrix.
*
DO 50 JC = 1, N - 1
DO 40 JR = JC, N
Q( JR, JC ) = DLARND( 3, ISEED )
Z( JR, JC ) = DLARND( 3, ISEED )
40 CONTINUE
CALL DLARFG( N+1-JC, Q( JC, JC ), Q( JC+1, JC ), 1,
$ WORK( JC ) )
WORK( 2*N+JC ) = SIGN( ONE, Q( JC, JC ) )
Q( JC, JC ) = ONE
CALL DLARFG( N+1-JC, Z( JC, JC ), Z( JC+1, JC ), 1,
$ WORK( N+JC ) )
WORK( 3*N+JC ) = SIGN( ONE, Z( JC, JC ) )
Z( JC, JC ) = ONE
50 CONTINUE
Q( N, N ) = ONE
WORK( N ) = ZERO
WORK( 3*N ) = SIGN( ONE, DLARND( 2, ISEED ) )
Z( N, N ) = ONE
WORK( 2*N ) = ZERO
WORK( 4*N ) = SIGN( ONE, DLARND( 2, ISEED ) )
*
* Apply the diagonal matrices
*
DO 70 JC = 1, N
DO 60 JR = 1, N
A( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
$ A( JR, JC )
B( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
$ B( JR, JC )
60 CONTINUE
70 CONTINUE
CALL DORM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, A,
$ LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
CALL DORM2R( 'R', 'T', N, N, N-1, Z, LDQ, WORK( N+1 ),
$ A, LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
CALL DORM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, B,
$ LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
CALL DORM2R( 'R', 'T', N, N, N-1, Z, LDQ, WORK( N+1 ),
$ B, LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
END IF
ELSE
*
* Random matrices
*
DO 90 JC = 1, N
DO 80 JR = 1, N
A( JR, JC ) = RMAGN( KAMAGN( JTYPE ) )*
$ DLARND( 2, ISEED )
B( JR, JC ) = RMAGN( KBMAGN( JTYPE ) )*
$ DLARND( 2, ISEED )
80 CONTINUE
90 CONTINUE
END IF
*
100 CONTINUE
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
110 CONTINUE
*
DO 120 I = 1, 13
RESULT( I ) = -ONE
120 CONTINUE
*
* Test with and without sorting of eigenvalues
*
DO 150 ISORT = 0, 1
IF( ISORT.EQ.0 ) THEN
SORT = 'N'
RSUB = 0
ELSE
SORT = 'S'
RSUB = 5
END IF
*
* Call DGGES to compute H, T, Q, Z, alpha, and beta.
*
CALL DLACPY( 'Full', N, N, A, LDA, S, LDA )
CALL DLACPY( 'Full', N, N, B, LDA, T, LDA )
NTEST = 1 + RSUB + ISORT
RESULT( 1+RSUB+ISORT ) = ULPINV
CALL DGGES( 'V', 'V', SORT, DLCTES, N, S, LDA, T, LDA,
$ SDIM, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDQ,
$ WORK, LWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 1+RSUB+ISORT ) = ULPINV
WRITE( NOUNIT, FMT = 9999 )'DGGES', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 160
END IF
*
NTEST = 4 + RSUB
*
* Do tests 1--4 (or tests 7--9 when reordering )
*
IF( ISORT.EQ.0 ) THEN
CALL DGET51( 1, N, A, LDA, S, LDA, Q, LDQ, Z, LDQ,
$ WORK, RESULT( 1 ) )
CALL DGET51( 1, N, B, LDA, T, LDA, Q, LDQ, Z, LDQ,
$ WORK, RESULT( 2 ) )
ELSE
CALL DGET54( N, A, LDA, B, LDA, S, LDA, T, LDA, Q,
$ LDQ, Z, LDQ, WORK, RESULT( 7 ) )
END IF
CALL DGET51( 3, N, A, LDA, T, LDA, Q, LDQ, Q, LDQ, WORK,
$ RESULT( 3+RSUB ) )
CALL DGET51( 3, N, B, LDA, T, LDA, Z, LDQ, Z, LDQ, WORK,
$ RESULT( 4+RSUB ) )
*
* Do test 5 and 6 (or Tests 10 and 11 when reordering):
* check Schur form of A and compare eigenvalues with
* diagonals.
*
NTEST = 6 + RSUB
TEMP1 = ZERO
*
DO 130 J = 1, N
ILABAD = .FALSE.
IF( ALPHAI( J ).EQ.ZERO ) THEN
TEMP2 = ( ABS( ALPHAR( J )-S( J, J ) ) /
$ MAX( SAFMIN, ABS( ALPHAR( J ) ), ABS( S( J,
$ J ) ) )+ABS( BETA( J )-T( J, J ) ) /
$ MAX( SAFMIN, ABS( BETA( J ) ), ABS( T( J,
$ J ) ) ) ) / ULP
*
IF( J.LT.N ) THEN
IF( S( J+1, J ).NE.ZERO ) THEN
ILABAD = .TRUE.
RESULT( 5+RSUB ) = ULPINV
END IF
END IF
IF( J.GT.1 ) THEN
IF( S( J, J-1 ).NE.ZERO ) THEN
ILABAD = .TRUE.
RESULT( 5+RSUB ) = ULPINV
END IF
END IF
*
ELSE
IF( ALPHAI( J ).GT.ZERO ) THEN
I1 = J
ELSE
I1 = J - 1
END IF
IF( I1.LE.0 .OR. I1.GE.N ) THEN
ILABAD = .TRUE.
ELSE IF( I1.LT.N-1 ) THEN
IF( S( I1+2, I1+1 ).NE.ZERO ) THEN
ILABAD = .TRUE.
RESULT( 5+RSUB ) = ULPINV
END IF
ELSE IF( I1.GT.1 ) THEN
IF( S( I1, I1-1 ).NE.ZERO ) THEN
ILABAD = .TRUE.
RESULT( 5+RSUB ) = ULPINV
END IF
END IF
IF( .NOT.ILABAD ) THEN
CALL DGET53( S( I1, I1 ), LDA, T( I1, I1 ), LDA,
$ BETA( J ), ALPHAR( J ),
$ ALPHAI( J ), TEMP2, IERR )
IF( IERR.GE.3 ) THEN
WRITE( NOUNIT, FMT = 9998 )IERR, J, N,
$ JTYPE, IOLDSD
INFO = ABS( IERR )
END IF
ELSE
TEMP2 = ULPINV
END IF
*
END IF
TEMP1 = MAX( TEMP1, TEMP2 )
IF( ILABAD ) THEN
WRITE( NOUNIT, FMT = 9997 )J, N, JTYPE, IOLDSD
END IF
130 CONTINUE
RESULT( 6+RSUB ) = TEMP1
*
IF( ISORT.GE.1 ) THEN
*
* Do test 12
*
NTEST = 12
RESULT( 12 ) = ZERO
KNTEIG = 0
DO 140 I = 1, N
IF( DLCTES( ALPHAR( I ), ALPHAI( I ),
$ BETA( I ) ) .OR. DLCTES( ALPHAR( I ),
$ -ALPHAI( I ), BETA( I ) ) ) THEN
KNTEIG = KNTEIG + 1
END IF
IF( I.LT.N ) THEN
IF( ( DLCTES( ALPHAR( I+1 ), ALPHAI( I+1 ),
$ BETA( I+1 ) ) .OR. DLCTES( ALPHAR( I+1 ),
$ -ALPHAI( I+1 ), BETA( I+1 ) ) ) .AND.
$ ( .NOT.( DLCTES( ALPHAR( I ), ALPHAI( I ),
$ BETA( I ) ) .OR. DLCTES( ALPHAR( I ),
$ -ALPHAI( I ), BETA( I ) ) ) ) .AND.
$ IINFO.NE.N+2 ) THEN
RESULT( 12 ) = ULPINV
END IF
END IF
140 CONTINUE
IF( SDIM.NE.KNTEIG ) THEN
RESULT( 12 ) = ULPINV
END IF
END IF
*
150 CONTINUE
*
* End of Loop -- Check for RESULT(j) > THRESH
*
160 CONTINUE
*
NTESTT = NTESTT + NTEST
*
* Print out tests which fail.
*
DO 170 JR = 1, NTEST
IF( RESULT( JR ).GE.THRESH ) THEN
*
* If this is the first test to fail,
* print a header to the data file.
*
IF( NERRS.EQ.0 ) THEN
WRITE( NOUNIT, FMT = 9996 )'DGS'
*
* Matrix types
*
WRITE( NOUNIT, FMT = 9995 )
WRITE( NOUNIT, FMT = 9994 )
WRITE( NOUNIT, FMT = 9993 )'Orthogonal'
*
* Tests performed
*
WRITE( NOUNIT, FMT = 9992 )'orthogonal', '''',
$ 'transpose', ( '''', J = 1, 8 )
*
END IF
NERRS = NERRS + 1
IF( RESULT( JR ).LT.10000.0D0 ) THEN
WRITE( NOUNIT, FMT = 9991 )N, JTYPE, IOLDSD, JR,
$ RESULT( JR )
ELSE
WRITE( NOUNIT, FMT = 9990 )N, JTYPE, IOLDSD, JR,
$ RESULT( JR )
END IF
END IF
170 CONTINUE
*
180 CONTINUE
190 CONTINUE
*
* Summary
*
CALL ALASVM( 'DGS', NOUNIT, NERRS, NTESTT, 0 )
*
WORK( 1 ) = MAXWRK
*
RETURN
*
9999 FORMAT( ' DDRGES: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ', ISEED=(', 4( I4, ',' ), I5, ')' )
*
9998 FORMAT( ' DDRGES: DGET53 returned INFO=', I1, ' for eigenvalue ',
$ I6, '.', / 9X, 'N=', I6, ', JTYPE=', I6, ', ISEED=(',
$ 4( I4, ',' ), I5, ')' )
*
9997 FORMAT( ' DDRGES: S not in Schur form at eigenvalue ', I6, '.',
$ / 9X, 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ),
$ I5, ')' )
*
9996 FORMAT( / 1X, A3, ' -- Real Generalized Schur form driver' )
*
9995 FORMAT( ' Matrix types (see DDRGES for details): ' )
*
9994 FORMAT( ' Special Matrices:', 23X,
$ '(J''=transposed Jordan block)',
$ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ',
$ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ',
$ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I',
$ ') 11=(large*I, small*D) 13=(large*D, large*I)', /
$ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ',
$ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' )
9993 FORMAT( ' Matrices Rotated by Random ', A, ' Matrices U, V:',
$ / ' 16=Transposed Jordan Blocks 19=geometric ',
$ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ',
$ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ',
$ 'alpha, beta=0,1 21=random alpha, beta=0,1',
$ / ' Large & Small Matrices:', / ' 22=(large, small) ',
$ '23=(small,large) 24=(small,small) 25=(large,large)',
$ / ' 26=random O(1) matrices.' )
*
9992 FORMAT( / ' Tests performed: (S is Schur, T is triangular, ',
$ 'Q and Z are ', A, ',', / 19X,
$ 'l and r are the appropriate left and right', / 19X,
$ 'eigenvectors, resp., a is alpha, b is beta, and', / 19X, A,
$ ' means ', A, '.)', / ' Without ordering: ',
$ / ' 1 = | A - Q S Z', A,
$ ' | / ( |A| n ulp ) 2 = | B - Q T Z', A,
$ ' | / ( |B| n ulp )', / ' 3 = | I - QQ', A,
$ ' | / ( n ulp ) 4 = | I - ZZ', A,
$ ' | / ( n ulp )', / ' 5 = A is in Schur form S',
$ / ' 6 = difference between (alpha,beta)',
$ ' and diagonals of (S,T)', / ' With ordering: ',
$ / ' 7 = | (A,B) - Q (S,T) Z', A,
$ ' | / ( |(A,B)| n ulp ) ', / ' 8 = | I - QQ', A,
$ ' | / ( n ulp ) 9 = | I - ZZ', A,
$ ' | / ( n ulp )', / ' 10 = A is in Schur form S',
$ / ' 11 = difference between (alpha,beta) and diagonals',
$ ' of (S,T)', / ' 12 = SDIM is the correct number of ',
$ 'selected eigenvalues', / )
9991 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
$ 4( I4, ',' ), ' result ', I2, ' is', 0P, F8.2 )
9990 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
$ 4( I4, ',' ), ' result ', I2, ' is', 1P, D10.3 )
*
* End of DDRGES
*
END
SUBROUTINE DDRGEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
$ NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, QE, LDQE,
$ ALPHAR, ALPHAI, BETA, ALPHR1, ALPHI1, BETA1,
$ WORK, LWORK, RESULT, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDQ, LDQE, LWORK, NOUNIT, NSIZES,
$ NTYPES
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER ISEED( 4 ), NN( * )
DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
$ ALPHI1( * ), ALPHR1( * ), B( LDA, * ),
$ BETA( * ), BETA1( * ), Q( LDQ, * ),
$ QE( LDQE, * ), RESULT( * ), S( LDA, * ),
$ T( LDA, * ), WORK( * ), Z( LDQ, * )
* ..
*
* Purpose
* =======
*
* DDRGEV checks the nonsymmetric generalized eigenvalue problem driver
* routine DGGEV.
*
* DGGEV computes for a pair of n-by-n nonsymmetric matrices (A,B) the
* generalized eigenvalues and, optionally, the left and right
* eigenvectors.
*
* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
* or a ratio alpha/beta = w, such that A - w*B is singular. It is
* usually represented as the pair (alpha,beta), as there is reasonalbe
* interpretation for beta=0, and even for both being zero.
*
* A right generalized eigenvector corresponding to a generalized
* eigenvalue w for a pair of matrices (A,B) is a vector r such that
* (A - wB) * r = 0. A left generalized eigenvector is a vector l such
* that l**H * (A - wB) = 0, where l**H is the conjugate-transpose of l.
*
* When DDRGEV is called, a number of matrix "sizes" ("n's") and a
* number of matrix "types" are specified. For each size ("n")
* and each type of matrix, a pair of matrices (A, B) will be generated
* and used for testing. For each matrix pair, the following tests
* will be performed and compared with the threshhold THRESH.
*
* Results from DGGEV:
*
* (1) max over all left eigenvalue/-vector pairs (alpha/beta,l) of
*
* | VL**H * (beta A - alpha B) |/( ulp max(|beta A|, |alpha B|) )
*
* where VL**H is the conjugate-transpose of VL.
*
* (2) | |VL(i)| - 1 | / ulp and whether largest component real
*
* VL(i) denotes the i-th column of VL.
*
* (3) max over all left eigenvalue/-vector pairs (alpha/beta,r) of
*
* | (beta A - alpha B) * VR | / ( ulp max(|beta A|, |alpha B|) )
*
* (4) | |VR(i)| - 1 | / ulp and whether largest component real
*
* VR(i) denotes the i-th column of VR.
*
* (5) W(full) = W(partial)
* W(full) denotes the eigenvalues computed when both l and r
* are also computed, and W(partial) denotes the eigenvalues
* computed when only W, only W and r, or only W and l are
* computed.
*
* (6) VL(full) = VL(partial)
* VL(full) denotes the left eigenvectors computed when both l
* and r are computed, and VL(partial) denotes the result
* when only l is computed.
*
* (7) VR(full) = VR(partial)
* VR(full) denotes the right eigenvectors computed when both l
* and r are also computed, and VR(partial) denotes the result
* when only l is computed.
*
*
* Test Matrices
* ---- --------
*
* The sizes of the test matrices are specified by an array
* NN(1:NSIZES); the value of each element NN(j) specifies one size.
* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if
* DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
* Currently, the list of possible types is:
*
* (1) ( 0, 0 ) (a pair of zero matrices)
*
* (2) ( I, 0 ) (an identity and a zero matrix)
*
* (3) ( 0, I ) (an identity and a zero matrix)
*
* (4) ( I, I ) (a pair of identity matrices)
*
* t t
* (5) ( J , J ) (a pair of transposed Jordan blocks)
*
* t ( I 0 )
* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t )
* ( 0 I ) ( 0 J )
* and I is a k x k identity and J a (k+1)x(k+1)
* Jordan block; k=(N-1)/2
*
* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal
* matrix with those diagonal entries.)
* (8) ( I, D )
*
* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big
*
* (10) ( small*D, big*I )
*
* (11) ( big*I, small*D )
*
* (12) ( small*I, big*D )
*
* (13) ( big*D, big*I )
*
* (14) ( small*D, small*I )
*
* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and
* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 )
* t t
* (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices.
*
* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices
* with random O(1) entries above the diagonal
* and diagonal entries diag(T1) =
* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) =
* ( 0, N-3, N-4,..., 1, 0, 0 )
*
* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 )
* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 )
* s = machine precision.
*
* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 )
* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 )
*
* N-5
* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 )
* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
*
* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 )
* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
* where r1,..., r(N-4) are random.
*
* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular
* matrices.
*
*
* Arguments
* =========
*
* NSIZES (input) INTEGER
* The number of sizes of matrices to use. If it is zero,
* DDRGES does nothing. NSIZES >= 0.
*
* NN (input) INTEGER array, dimension (NSIZES)
* An array containing the sizes to be used for the matrices.
* Zero values will be skipped. NN >= 0.
*
* NTYPES (input) INTEGER
* The number of elements in DOTYPE. If it is zero, DDRGES
* does nothing. It must be at least zero. If it is MAXTYP+1
* and NSIZES is 1, then an additional type, MAXTYP+1 is
* defined, which is to use whatever matrix is in A. This
* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
* DOTYPE(MAXTYP+1) is .TRUE. .
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* If DOTYPE(j) is .TRUE., then for each size in NN a
* matrix of that size and of type j will be generated.
* If NTYPES is smaller than the maximum number of types
* defined (PARAMETER MAXTYP), then types NTYPES+1 through
* MAXTYP will not be generated. If NTYPES is larger
* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
* will be ignored.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The array elements should be between 0 and 4095;
* if not they will be reduced mod 4096. Also, ISEED(4) must
* be odd. The random number generator uses a linear
* congruential sequence limited to small integers, and so
* should produce machine independent random numbers. The
* values of ISEED are changed on exit, and can be used in the
* next call to DDRGES to continue the same random number
* sequence.
*
* THRESH (input) DOUBLE PRECISION
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error is
* scaled to be O(1), so THRESH should be a reasonably small
* multiple of 1, e.g., 10 or 100. In particular, it should
* not depend on the precision (single vs. double) or the size
* of the matrix. It must be at least zero.
*
* NOUNIT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns IERR not equal to 0.)
*
* A (input/workspace) DOUBLE PRECISION array,
* dimension(LDA, max(NN))
* Used to hold the original A matrix. Used as input only
* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
* DOTYPE(MAXTYP+1)=.TRUE.
*
* LDA (input) INTEGER
* The leading dimension of A, B, S, and T.
* It must be at least 1 and at least max( NN ).
*
* B (input/workspace) DOUBLE PRECISION array,
* dimension(LDA, max(NN))
* Used to hold the original B matrix. Used as input only
* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
* DOTYPE(MAXTYP+1)=.TRUE.
*
* S (workspace) DOUBLE PRECISION array,
* dimension (LDA, max(NN))
* The Schur form matrix computed from A by DGGES. On exit, S
* contains the Schur form matrix corresponding to the matrix
* in A.
*
* T (workspace) DOUBLE PRECISION array,
* dimension (LDA, max(NN))
* The upper triangular matrix computed from B by DGGES.
*
* Q (workspace) DOUBLE PRECISION array,
* dimension (LDQ, max(NN))
* The (left) eigenvectors matrix computed by DGGEV.
*
* LDQ (input) INTEGER
* The leading dimension of Q and Z. It must
* be at least 1 and at least max( NN ).
*
* Z (workspace) DOUBLE PRECISION array, dimension( LDQ, max(NN) )
* The (right) orthogonal matrix computed by DGGES.
*
* QE (workspace) DOUBLE PRECISION array, dimension( LDQ, max(NN) )
* QE holds the computed right or left eigenvectors.
*
* LDQE (input) INTEGER
* The leading dimension of QE. LDQE >= max(1,max(NN)).
*
* ALPHAR (workspace) DOUBLE PRECISION array, dimension (max(NN))
* ALPHAI (workspace) DOUBLE PRECISION array, dimension (max(NN))
* BETA (workspace) DOUBLE PRECISION array, dimension (max(NN))
* The generalized eigenvalues of (A,B) computed by DGGEV.
* ( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th
* generalized eigenvalue of A and B.
*
* ALPHR1 (workspace) DOUBLE PRECISION array, dimension (max(NN))
* ALPHI1 (workspace) DOUBLE PRECISION array, dimension (max(NN))
* BETA1 (workspace) DOUBLE PRECISION array, dimension (max(NN))
* Like ALPHAR, ALPHAI, BETA, these arrays contain the
* eigenvalues of A and B, but those computed when DGGEV only
* computes a partial eigendecomposition, i.e. not the
* eigenvalues and left and right eigenvectors.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The number of entries in WORK. LWORK >= MAX( 8*N, N*(N+1) ).
*
* RESULT (output) DOUBLE PRECISION array, dimension (2)
* The values computed by the tests described above.
* The values are currently limited to 1/ulp, to avoid overflow.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: A routine returned an error code. INFO is the
* absolute value of the INFO value returned.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 26 )
* ..
* .. Local Scalars ..
LOGICAL BADNN
INTEGER I, IADD, IERR, IN, J, JC, JR, JSIZE, JTYPE,
$ MAXWRK, MINWRK, MTYPES, N, N1, NERRS, NMATS,
$ NMAX, NTESTT
DOUBLE PRECISION SAFMAX, SAFMIN, ULP, ULPINV
* ..
* .. Local Arrays ..
INTEGER IASIGN( MAXTYP ), IBSIGN( MAXTYP ),
$ IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ),
$ KATYPE( MAXTYP ), KAZERO( MAXTYP ),
$ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ),
$ KBZERO( MAXTYP ), KCLASS( MAXTYP ),
$ KTRIAN( MAXTYP ), KZ1( 6 ), KZ2( 6 )
DOUBLE PRECISION RMAGN( 0: 3 )
* ..
* .. External Functions ..
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLARND
EXTERNAL ILAENV, DLAMCH, DLARND
* ..
* .. External Subroutines ..
EXTERNAL ALASVM, DGET52, DGGEV, DLABAD, DLACPY, DLARFG,
$ DLASET, DLATM4, DORM2R, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN, SIGN
* ..
* .. Data statements ..
DATA KCLASS / 15*1, 10*2, 1*3 /
DATA KZ1 / 0, 1, 2, 1, 3, 3 /
DATA KZ2 / 0, 0, 1, 2, 1, 1 /
DATA KADD / 0, 0, 0, 0, 3, 2 /
DATA KATYPE / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4,
$ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 /
DATA KBTYPE / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4,
$ 1, 1, -4, 2, -4, 8*8, 0 /
DATA KAZERO / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3,
$ 4*5, 4*3, 1 /
DATA KBZERO / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4,
$ 4*6, 4*4, 1 /
DATA KAMAGN / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3,
$ 2, 1 /
DATA KBMAGN / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3,
$ 2, 1 /
DATA KTRIAN / 16*0, 10*1 /
DATA IASIGN / 6*0, 2, 0, 2*2, 2*0, 3*2, 0, 2, 3*0,
$ 5*2, 0 /
DATA IBSIGN / 7*0, 2, 2*0, 2*2, 2*0, 2, 0, 2, 9*0 /
* ..
* .. Executable Statements ..
*
* Check for errors
*
INFO = 0
*
BADNN = .FALSE.
NMAX = 1
DO 10 J = 1, NSIZES
NMAX = MAX( NMAX, NN( J ) )
IF( NN( J ).LT.0 )
$ BADNN = .TRUE.
10 CONTINUE
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADNN ) THEN
INFO = -2
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -3
ELSE IF( THRESH.LT.ZERO ) THEN
INFO = -6
ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN
INFO = -9
ELSE IF( LDQ.LE.1 .OR. LDQ.LT.NMAX ) THEN
INFO = -14
ELSE IF( LDQE.LE.1 .OR. LDQE.LT.NMAX ) THEN
INFO = -17
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.
*
MINWRK = 1
IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN
MINWRK = MAX( 1, 8*NMAX, NMAX*( NMAX+1 ) )
MAXWRK = 7*NMAX + NMAX*ILAENV( 1, 'DGEQRF', ' ', NMAX, 1, NMAX,
$ 0 )
MAXWRK = MAX( MAXWRK, NMAX*( NMAX+1 ) )
WORK( 1 ) = MAXWRK
END IF
*
IF( LWORK.LT.MINWRK )
$ INFO = -25
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DDRGEV', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
$ RETURN
*
SAFMIN = DLAMCH( 'Safe minimum' )
ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
SAFMIN = SAFMIN / ULP
SAFMAX = ONE / SAFMIN
CALL DLABAD( SAFMIN, SAFMAX )
ULPINV = ONE / ULP
*
* The values RMAGN(2:3) depend on N, see below.
*
RMAGN( 0 ) = ZERO
RMAGN( 1 ) = ONE
*
* Loop over sizes, types
*
NTESTT = 0
NERRS = 0
NMATS = 0
*
DO 220 JSIZE = 1, NSIZES
N = NN( JSIZE )
N1 = MAX( 1, N )
RMAGN( 2 ) = SAFMAX*ULP / DBLE( N1 )
RMAGN( 3 ) = SAFMIN*ULPINV*N1
*
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
DO 210 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 210
NMATS = NMATS + 1
*
* Save ISEED in case of an error.
*
DO 20 J = 1, 4
IOLDSD( J ) = ISEED( J )
20 CONTINUE
*
* Generate test matrices A and B
*
* Description of control parameters:
*
* KZLASS: =1 means w/o rotation, =2 means w/ rotation,
* =3 means random.
* KATYPE: the "type" to be passed to DLATM4 for computing A.
* KAZERO: the pattern of zeros on the diagonal for A:
* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ),
* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ),
* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of
* non-zero entries.)
* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1),
* =2: large, =3: small.
* IASIGN: 1 if the diagonal elements of A are to be
* multiplied by a random magnitude 1 number, =2 if
* randomly chosen diagonal blocks are to be rotated
* to form 2x2 blocks.
* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B.
* KTRIAN: =0: don't fill in the upper triangle, =1: do.
* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO.
* RMAGN: used to implement KAMAGN and KBMAGN.
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 100
IERR = 0
IF( KCLASS( JTYPE ).LT.3 ) THEN
*
* Generate A (w/o rotation)
*
IF( ABS( KATYPE( JTYPE ) ).EQ.3 ) THEN
IN = 2*( ( N-1 ) / 2 ) + 1
IF( IN.NE.N )
$ CALL DLASET( 'Full', N, N, ZERO, ZERO, A, LDA )
ELSE
IN = N
END IF
CALL DLATM4( KATYPE( JTYPE ), IN, KZ1( KAZERO( JTYPE ) ),
$ KZ2( KAZERO( JTYPE ) ), IASIGN( JTYPE ),
$ RMAGN( KAMAGN( JTYPE ) ), ULP,
$ RMAGN( KTRIAN( JTYPE )*KAMAGN( JTYPE ) ), 2,
$ ISEED, A, LDA )
IADD = KADD( KAZERO( JTYPE ) )
IF( IADD.GT.0 .AND. IADD.LE.N )
$ A( IADD, IADD ) = ONE
*
* Generate B (w/o rotation)
*
IF( ABS( KBTYPE( JTYPE ) ).EQ.3 ) THEN
IN = 2*( ( N-1 ) / 2 ) + 1
IF( IN.NE.N )
$ CALL DLASET( 'Full', N, N, ZERO, ZERO, B, LDA )
ELSE
IN = N
END IF
CALL DLATM4( KBTYPE( JTYPE ), IN, KZ1( KBZERO( JTYPE ) ),
$ KZ2( KBZERO( JTYPE ) ), IBSIGN( JTYPE ),
$ RMAGN( KBMAGN( JTYPE ) ), ONE,
$ RMAGN( KTRIAN( JTYPE )*KBMAGN( JTYPE ) ), 2,
$ ISEED, B, LDA )
IADD = KADD( KBZERO( JTYPE ) )
IF( IADD.NE.0 .AND. IADD.LE.N )
$ B( IADD, IADD ) = ONE
*
IF( KCLASS( JTYPE ).EQ.2 .AND. N.GT.0 ) THEN
*
* Include rotations
*
* Generate Q, Z as Householder transformations times
* a diagonal matrix.
*
DO 40 JC = 1, N - 1
DO 30 JR = JC, N
Q( JR, JC ) = DLARND( 3, ISEED )
Z( JR, JC ) = DLARND( 3, ISEED )
30 CONTINUE
CALL DLARFG( N+1-JC, Q( JC, JC ), Q( JC+1, JC ), 1,
$ WORK( JC ) )
WORK( 2*N+JC ) = SIGN( ONE, Q( JC, JC ) )
Q( JC, JC ) = ONE
CALL DLARFG( N+1-JC, Z( JC, JC ), Z( JC+1, JC ), 1,
$ WORK( N+JC ) )
WORK( 3*N+JC ) = SIGN( ONE, Z( JC, JC ) )
Z( JC, JC ) = ONE
40 CONTINUE
Q( N, N ) = ONE
WORK( N ) = ZERO
WORK( 3*N ) = SIGN( ONE, DLARND( 2, ISEED ) )
Z( N, N ) = ONE
WORK( 2*N ) = ZERO
WORK( 4*N ) = SIGN( ONE, DLARND( 2, ISEED ) )
*
* Apply the diagonal matrices
*
DO 60 JC = 1, N
DO 50 JR = 1, N
A( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
$ A( JR, JC )
B( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
$ B( JR, JC )
50 CONTINUE
60 CONTINUE
CALL DORM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, A,
$ LDA, WORK( 2*N+1 ), IERR )
IF( IERR.NE.0 )
$ GO TO 90
CALL DORM2R( 'R', 'T', N, N, N-1, Z, LDQ, WORK( N+1 ),
$ A, LDA, WORK( 2*N+1 ), IERR )
IF( IERR.NE.0 )
$ GO TO 90
CALL DORM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, B,
$ LDA, WORK( 2*N+1 ), IERR )
IF( IERR.NE.0 )
$ GO TO 90
CALL DORM2R( 'R', 'T', N, N, N-1, Z, LDQ, WORK( N+1 ),
$ B, LDA, WORK( 2*N+1 ), IERR )
IF( IERR.NE.0 )
$ GO TO 90
END IF
ELSE
*
* Random matrices
*
DO 80 JC = 1, N
DO 70 JR = 1, N
A( JR, JC ) = RMAGN( KAMAGN( JTYPE ) )*
$ DLARND( 2, ISEED )
B( JR, JC ) = RMAGN( KBMAGN( JTYPE ) )*
$ DLARND( 2, ISEED )
70 CONTINUE
80 CONTINUE
END IF
*
90 CONTINUE
*
IF( IERR.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'Generator', IERR, N, JTYPE,
$ IOLDSD
INFO = ABS( IERR )
RETURN
END IF
*
100 CONTINUE
*
DO 110 I = 1, 7
RESULT( I ) = -ONE
110 CONTINUE
*
* Call DGGEV to compute eigenvalues and eigenvectors.
*
CALL DLACPY( ' ', N, N, A, LDA, S, LDA )
CALL DLACPY( ' ', N, N, B, LDA, T, LDA )
CALL DGGEV( 'V', 'V', N, S, LDA, T, LDA, ALPHAR, ALPHAI,
$ BETA, Q, LDQ, Z, LDQ, WORK, LWORK, IERR )
IF( IERR.NE.0 .AND. IERR.NE.N+1 ) THEN
RESULT( 1 ) = ULPINV
WRITE( NOUNIT, FMT = 9999 )'DGGEV1', IERR, N, JTYPE,
$ IOLDSD
INFO = ABS( IERR )
GO TO 190
END IF
*
* Do the tests (1) and (2)
*
CALL DGET52( .TRUE., N, A, LDA, B, LDA, Q, LDQ, ALPHAR,
$ ALPHAI, BETA, WORK, RESULT( 1 ) )
IF( RESULT( 2 ).GT.THRESH ) THEN
WRITE( NOUNIT, FMT = 9998 )'Left', 'DGGEV1',
$ RESULT( 2 ), N, JTYPE, IOLDSD
END IF
*
* Do the tests (3) and (4)
*
CALL DGET52( .FALSE., N, A, LDA, B, LDA, Z, LDQ, ALPHAR,
$ ALPHAI, BETA, WORK, RESULT( 3 ) )
IF( RESULT( 4 ).GT.THRESH ) THEN
WRITE( NOUNIT, FMT = 9998 )'Right', 'DGGEV1',
$ RESULT( 4 ), N, JTYPE, IOLDSD
END IF
*
* Do the test (5)
*
CALL DLACPY( ' ', N, N, A, LDA, S, LDA )
CALL DLACPY( ' ', N, N, B, LDA, T, LDA )
CALL DGGEV( 'N', 'N', N, S, LDA, T, LDA, ALPHR1, ALPHI1,
$ BETA1, Q, LDQ, Z, LDQ, WORK, LWORK, IERR )
IF( IERR.NE.0 .AND. IERR.NE.N+1 ) THEN
RESULT( 1 ) = ULPINV
WRITE( NOUNIT, FMT = 9999 )'DGGEV2', IERR, N, JTYPE,
$ IOLDSD
INFO = ABS( IERR )
GO TO 190
END IF
*
DO 120 J = 1, N
IF( ALPHAR( J ).NE.ALPHR1( J ) .OR. ALPHAI( J ).NE.
$ ALPHI1( J ) .OR. BETA( J ).NE.BETA1( J ) )RESULT( 5 )
$ = ULPINV
120 CONTINUE
*
* Do the test (6): Compute eigenvalues and left eigenvectors,
* and test them
*
CALL DLACPY( ' ', N, N, A, LDA, S, LDA )
CALL DLACPY( ' ', N, N, B, LDA, T, LDA )
CALL DGGEV( 'V', 'N', N, S, LDA, T, LDA, ALPHR1, ALPHI1,
$ BETA1, QE, LDQE, Z, LDQ, WORK, LWORK, IERR )
IF( IERR.NE.0 .AND. IERR.NE.N+1 ) THEN
RESULT( 1 ) = ULPINV
WRITE( NOUNIT, FMT = 9999 )'DGGEV3', IERR, N, JTYPE,
$ IOLDSD
INFO = ABS( IERR )
GO TO 190
END IF
*
DO 130 J = 1, N
IF( ALPHAR( J ).NE.ALPHR1( J ) .OR. ALPHAI( J ).NE.
$ ALPHI1( J ) .OR. BETA( J ).NE.BETA1( J ) )RESULT( 6 )
$ = ULPINV
130 CONTINUE
*
DO 150 J = 1, N
DO 140 JC = 1, N
IF( Q( J, JC ).NE.QE( J, JC ) )
$ RESULT( 6 ) = ULPINV
140 CONTINUE
150 CONTINUE
*
* DO the test (7): Compute eigenvalues and right eigenvectors,
* and test them
*
CALL DLACPY( ' ', N, N, A, LDA, S, LDA )
CALL DLACPY( ' ', N, N, B, LDA, T, LDA )
CALL DGGEV( 'N', 'V', N, S, LDA, T, LDA, ALPHR1, ALPHI1,
$ BETA1, Q, LDQ, QE, LDQE, WORK, LWORK, IERR )
IF( IERR.NE.0 .AND. IERR.NE.N+1 ) THEN
RESULT( 1 ) = ULPINV
WRITE( NOUNIT, FMT = 9999 )'DGGEV4', IERR, N, JTYPE,
$ IOLDSD
INFO = ABS( IERR )
GO TO 190
END IF
*
DO 160 J = 1, N
IF( ALPHAR( J ).NE.ALPHR1( J ) .OR. ALPHAI( J ).NE.
$ ALPHI1( J ) .OR. BETA( J ).NE.BETA1( J ) )RESULT( 7 )
$ = ULPINV
160 CONTINUE
*
DO 180 J = 1, N
DO 170 JC = 1, N
IF( Z( J, JC ).NE.QE( J, JC ) )
$ RESULT( 7 ) = ULPINV
170 CONTINUE
180 CONTINUE
*
* End of Loop -- Check for RESULT(j) > THRESH
*
190 CONTINUE
*
NTESTT = NTESTT + 7
*
* Print out tests which fail.
*
DO 200 JR = 1, 7
IF( RESULT( JR ).GE.THRESH ) THEN
*
* If this is the first test to fail,
* print a header to the data file.
*
IF( NERRS.EQ.0 ) THEN
WRITE( NOUNIT, FMT = 9997 )'DGV'
*
* Matrix types
*
WRITE( NOUNIT, FMT = 9996 )
WRITE( NOUNIT, FMT = 9995 )
WRITE( NOUNIT, FMT = 9994 )'Orthogonal'
*
* Tests performed
*
WRITE( NOUNIT, FMT = 9993 )
*
END IF
NERRS = NERRS + 1
IF( RESULT( JR ).LT.10000.0D0 ) THEN
WRITE( NOUNIT, FMT = 9992 )N, JTYPE, IOLDSD, JR,
$ RESULT( JR )
ELSE
WRITE( NOUNIT, FMT = 9991 )N, JTYPE, IOLDSD, JR,
$ RESULT( JR )
END IF
END IF
200 CONTINUE
*
210 CONTINUE
220 CONTINUE
*
* Summary
*
CALL ALASVM( 'DGV', NOUNIT, NERRS, NTESTT, 0 )
*
WORK( 1 ) = MAXWRK
*
RETURN
*
9999 FORMAT( ' DDRGEV: ', A, ' returned INFO=', I6, '.', / 3X, 'N=',
$ I6, ', JTYPE=', I6, ', ISEED=(', 4( I4, ',' ), I5, ')' )
*
9998 FORMAT( ' DDRGEV: ', A, ' Eigenvectors from ', A, ' incorrectly ',
$ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 3X,
$ 'N=', I4, ', JTYPE=', I3, ', ISEED=(', 4( I4, ',' ), I5,
$ ')' )
*
9997 FORMAT( / 1X, A3, ' -- Real Generalized eigenvalue problem driver'
$ )
*
9996 FORMAT( ' Matrix types (see DDRGEV for details): ' )
*
9995 FORMAT( ' Special Matrices:', 23X,
$ '(J''=transposed Jordan block)',
$ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ',
$ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ',
$ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I',
$ ') 11=(large*I, small*D) 13=(large*D, large*I)', /
$ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ',
$ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' )
9994 FORMAT( ' Matrices Rotated by Random ', A, ' Matrices U, V:',
$ / ' 16=Transposed Jordan Blocks 19=geometric ',
$ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ',
$ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ',
$ 'alpha, beta=0,1 21=random alpha, beta=0,1',
$ / ' Large & Small Matrices:', / ' 22=(large, small) ',
$ '23=(small,large) 24=(small,small) 25=(large,large)',
$ / ' 26=random O(1) matrices.' )
*
9993 FORMAT( / ' Tests performed: ',
$ / ' 1 = max | ( b A - a B )''*l | / const.,',
$ / ' 2 = | |VR(i)| - 1 | / ulp,',
$ / ' 3 = max | ( b A - a B )*r | / const.',
$ / ' 4 = | |VL(i)| - 1 | / ulp,',
$ / ' 5 = 0 if W same no matter if r or l computed,',
$ / ' 6 = 0 if l same no matter if l computed,',
$ / ' 7 = 0 if r same no matter if r computed,', / 1X )
9992 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
$ 4( I4, ',' ), ' result ', I2, ' is', 0P, F8.2 )
9991 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
$ 4( I4, ',' ), ' result ', I2, ' is', 1P, D10.3 )
*
* End of DDRGEV
*
END
SUBROUTINE DDRGSX( NSIZE, NCMAX, THRESH, NIN, NOUT, A, LDA, B, AI,
$ BI, Z, Q, ALPHAR, ALPHAI, BETA, C, LDC, S,
$ WORK, LWORK, IWORK, LIWORK, BWORK, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDC, LIWORK, LWORK, NCMAX, NIN,
$ NOUT, NSIZE
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL BWORK( * )
INTEGER IWORK( * )
DOUBLE PRECISION A( LDA, * ), AI( LDA, * ), ALPHAI( * ),
$ ALPHAR( * ), B( LDA, * ), BETA( * ),
$ BI( LDA, * ), C( LDC, * ), Q( LDA, * ), S( * ),
$ WORK( * ), Z( LDA, * )
* ..
*
* Purpose
* =======
*
* DDRGSX checks the nonsymmetric generalized eigenvalue (Schur form)
* problem expert driver DGGESX.
*
* DGGESX factors A and B as Q S Z' and Q T Z', where ' means
* transpose, T is upper triangular, S is in generalized Schur form
* (block upper triangular, with 1x1 and 2x2 blocks on the diagonal,
* the 2x2 blocks corresponding to complex conjugate pairs of
* generalized eigenvalues), and Q and Z are orthogonal. It also
* computes the generalized eigenvalues (alpha(1),beta(1)), ...,
* (alpha(n),beta(n)). Thus, w(j) = alpha(j)/beta(j) is a root of the
* characteristic equation
*
* det( A - w(j) B ) = 0
*
* Optionally it also reorders the eigenvalues so that a selected
* cluster of eigenvalues appears in the leading diagonal block of the
* Schur forms; computes a reciprocal condition number for the average
* of the selected eigenvalues; and computes a reciprocal condition
* number for the right and left deflating subspaces corresponding to
* the selected eigenvalues.
*
* When DDRGSX is called with NSIZE > 0, five (5) types of built-in
* matrix pairs are used to test the routine DGGESX.
*
* When DDRGSX is called with NSIZE = 0, it reads in test matrix data
* to test DGGESX.
*
* For each matrix pair, the following tests will be performed and
* compared with the threshhold THRESH except for the tests (7) and (9):
*
* (1) | A - Q S Z' | / ( |A| n ulp )
*
* (2) | B - Q T Z' | / ( |B| n ulp )
*
* (3) | I - QQ' | / ( n ulp )
*
* (4) | I - ZZ' | / ( n ulp )
*
* (5) if A is in Schur form (i.e. quasi-triangular form)
*
* (6) maximum over j of D(j) where:
*
* if alpha(j) is real:
* |alpha(j) - S(j,j)| |beta(j) - T(j,j)|
* D(j) = ------------------------ + -----------------------
* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|)
*
* if alpha(j) is complex:
* | det( s S - w T ) |
* D(j) = ---------------------------------------------------
* ulp max( s norm(S), |w| norm(T) )*norm( s S - w T )
*
* and S and T are here the 2 x 2 diagonal blocks of S and T
* corresponding to the j-th and j+1-th eigenvalues.
*
* (7) if sorting worked and SDIM is the number of eigenvalues
* which were selected.
*
* (8) the estimated value DIF does not differ from the true values of
* Difu and Difl more than a factor 10*THRESH. If the estimate DIF
* equals zero the corresponding true values of Difu and Difl
* should be less than EPS*norm(A, B). If the true value of Difu
* and Difl equal zero, the estimate DIF should be less than
* EPS*norm(A, B).
*
* (9) If INFO = N+3 is returned by DGGESX, the reordering "failed"
* and we check that DIF = PL = PR = 0 and that the true value of
* Difu and Difl is < EPS*norm(A, B). We count the events when
* INFO=N+3.
*
* For read-in test matrices, the above tests are run except that the
* exact value for DIF (and PL) is input data. Additionally, there is
* one more test run for read-in test matrices:
*
* (10) the estimated value PL does not differ from the true value of
* PLTRU more than a factor THRESH. If the estimate PL equals
* zero the corresponding true value of PLTRU should be less than
* EPS*norm(A, B). If the true value of PLTRU equal zero, the
* estimate PL should be less than EPS*norm(A, B).
*
* Note that for the built-in tests, a total of 10*NSIZE*(NSIZE-1)
* matrix pairs are generated and tested. NSIZE should be kept small.
*
* SVD (routine DGESVD) is used for computing the true value of DIF_u
* and DIF_l when testing the built-in test problems.
*
* Built-in Test Matrices
* ======================
*
* All built-in test matrices are the 2 by 2 block of triangular
* matrices
*
* A = [ A11 A12 ] and B = [ B11 B12 ]
* [ A22 ] [ B22 ]
*
* where for different type of A11 and A22 are given as the following.
* A12 and B12 are chosen so that the generalized Sylvester equation
*
* A11*R - L*A22 = -A12
* B11*R - L*B22 = -B12
*
* have prescribed solution R and L.
*
* Type 1: A11 = J_m(1,-1) and A_22 = J_k(1-a,1).
* B11 = I_m, B22 = I_k
* where J_k(a,b) is the k-by-k Jordan block with ``a'' on
* diagonal and ``b'' on superdiagonal.
*
* Type 2: A11 = (a_ij) = ( 2(.5-sin(i)) ) and
* B11 = (b_ij) = ( 2(.5-sin(ij)) ) for i=1,...,m, j=i,...,m
* A22 = (a_ij) = ( 2(.5-sin(i+j)) ) and
* B22 = (b_ij) = ( 2(.5-sin(ij)) ) for i=m+1,...,k, j=i,...,k
*
* Type 3: A11, A22 and B11, B22 are chosen as for Type 2, but each
* second diagonal block in A_11 and each third diagonal block
* in A_22 are made as 2 by 2 blocks.
*
* Type 4: A11 = ( 20(.5 - sin(ij)) ) and B22 = ( 2(.5 - sin(i+j)) )
* for i=1,...,m, j=1,...,m and
* A22 = ( 20(.5 - sin(i+j)) ) and B22 = ( 2(.5 - sin(ij)) )
* for i=m+1,...,k, j=m+1,...,k
*
* Type 5: (A,B) and have potentially close or common eigenvalues and
* very large departure from block diagonality A_11 is chosen
* as the m x m leading submatrix of A_1:
* | 1 b |
* | -b 1 |
* | 1+d b |
* | -b 1+d |
* A_1 = | d 1 |
* | -1 d |
* | -d 1 |
* | -1 -d |
* | 1 |
* and A_22 is chosen as the k x k leading submatrix of A_2:
* | -1 b |
* | -b -1 |
* | 1-d b |
* | -b 1-d |
* A_2 = | d 1+b |
* | -1-b d |
* | -d 1+b |
* | -1+b -d |
* | 1-d |
* and matrix B are chosen as identity matrices (see DLATM5).
*
*
* Arguments
* =========
*
* NSIZE (input) INTEGER
* The maximum size of the matrices to use. NSIZE >= 0.
* If NSIZE = 0, no built-in tests matrices are used, but
* read-in test matrices are used to test DGGESX.
*
* NCMAX (input) INTEGER
* Maximum allowable NMAX for generating Kroneker matrix
* in call to DLAKF2
*
* THRESH (input) DOUBLE PRECISION
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error
* is scaled to be O(1), so THRESH should be a reasonably
* small multiple of 1, e.g., 10 or 100. In particular,
* it should not depend on the precision (single vs. double)
* or the size of the matrix. THRESH >= 0.
*
* NIN (input) INTEGER
* The FORTRAN unit number for reading in the data file of
* problems to solve.
*
* NOUT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns IINFO not equal to 0.)
*
* A (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE)
* Used to store the matrix whose eigenvalues are to be
* computed. On exit, A contains the last matrix actually used.
*
* LDA (input) INTEGER
* The leading dimension of A, B, AI, BI, Z and Q,
* LDA >= max( 1, NSIZE ). For the read-in test,
* LDA >= max( 1, N ), N is the size of the test matrices.
*
* B (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE)
* Used to store the matrix whose eigenvalues are to be
* computed. On exit, B contains the last matrix actually used.
*
* AI (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE)
* Copy of A, modified by DGGESX.
*
* BI (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE)
* Copy of B, modified by DGGESX.
*
* Z (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE)
* Z holds the left Schur vectors computed by DGGESX.
*
* Q (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE)
* Q holds the right Schur vectors computed by DGGESX.
*
* ALPHAR (workspace) DOUBLE PRECISION array, dimension (NSIZE)
* ALPHAI (workspace) DOUBLE PRECISION array, dimension (NSIZE)
* BETA (workspace) DOUBLE PRECISION array, dimension (NSIZE)
* On exit, (ALPHAR + ALPHAI*i)/BETA are the eigenvalues.
*
* C (workspace) DOUBLE PRECISION array, dimension (LDC, LDC)
* Store the matrix generated by subroutine DLAKF2, this is the
* matrix formed by Kronecker products used for estimating
* DIF.
*
* LDC (input) INTEGER
* The leading dimension of C. LDC >= max(1, LDA*LDA/2 ).
*
* S (workspace) DOUBLE PRECISION array, dimension (LDC)
* Singular values of C
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* LWORK >= MAX( 5*NSIZE*NSIZE/2 - 2, 10*(NSIZE+1) )
*
* IWORK (workspace) INTEGER array, dimension (LIWORK)
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK. LIWORK >= NSIZE + 6.
*
* BWORK (workspace) LOGICAL array, dimension (LDA)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: A routine returned an error code.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TEN
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1 )
* ..
* .. Local Scalars ..
LOGICAL ILABAD
CHARACTER SENSE
INTEGER BDSPAC, I, I1, IFUNC, IINFO, J, LINFO, MAXWRK,
$ MINWRK, MM, MN2, NERRS, NPTKNT, NTEST, NTESTT,
$ PRTYPE, QBA, QBB
DOUBLE PRECISION ABNRM, BIGNUM, DIFTRU, PLTRU, SMLNUM, TEMP1,
$ TEMP2, THRSH2, ULP, ULPINV, WEIGHT
* ..
* .. Local Arrays ..
DOUBLE PRECISION DIFEST( 2 ), PL( 2 ), RESULT( 10 )
* ..
* .. External Functions ..
LOGICAL DLCTSX
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL DLCTSX, ILAENV, DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL ALASVM, DGESVD, DGET51, DGET53, DGGESX, DLABAD,
$ DLACPY, DLAKF2, DLASET, DLATM5, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Scalars in Common ..
LOGICAL FS
INTEGER K, M, MPLUSN, N
* ..
* .. Common blocks ..
COMMON / MN / M, N, MPLUSN, K, FS
* ..
* .. Executable Statements ..
*
* Check for errors
*
IF( NSIZE.LT.0 ) THEN
INFO = -1
ELSE IF( THRESH.LT.ZERO ) THEN
INFO = -2
ELSE IF( NIN.LE.0 ) THEN
INFO = -3
ELSE IF( NOUT.LE.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.1 .OR. LDA.LT.NSIZE ) THEN
INFO = -6
ELSE IF( LDC.LT.1 .OR. LDC.LT.NSIZE*NSIZE / 2 ) THEN
INFO = -17
ELSE IF( LIWORK.LT.NSIZE+6 ) THEN
INFO = -21
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.)
*
MINWRK = 1
IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN
MINWRK = MAX( 10*( NSIZE+1 ), 5*NSIZE*NSIZE / 2 )
*
* workspace for sggesx
*
MAXWRK = 9*( NSIZE+1 ) + NSIZE*
$ ILAENV( 1, 'DGEQRF', ' ', NSIZE, 1, NSIZE, 0 )
MAXWRK = MAX( MAXWRK, 9*( NSIZE+1 )+NSIZE*
$ ILAENV( 1, 'DORGQR', ' ', NSIZE, 1, NSIZE, -1 ) )
*
* workspace for dgesvd
*
BDSPAC = 5*NSIZE*NSIZE / 2
MAXWRK = MAX( MAXWRK, 3*NSIZE*NSIZE / 2+NSIZE*NSIZE*
$ ILAENV( 1, 'DGEBRD', ' ', NSIZE*NSIZE / 2,
$ NSIZE*NSIZE / 2, -1, -1 ) )
MAXWRK = MAX( MAXWRK, BDSPAC )
*
MAXWRK = MAX( MAXWRK, MINWRK )
*
WORK( 1 ) = MAXWRK
END IF
*
IF( LWORK.LT.MINWRK )
$ INFO = -19
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DDRGSX', -INFO )
RETURN
END IF
*
* Important constants
*
ULP = DLAMCH( 'P' )
ULPINV = ONE / ULP
SMLNUM = DLAMCH( 'S' ) / ULP
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
THRSH2 = TEN*THRESH
NTESTT = 0
NERRS = 0
*
* Go to the tests for read-in matrix pairs
*
IFUNC = 0
IF( NSIZE.EQ.0 )
$ GO TO 70
*
* Test the built-in matrix pairs.
* Loop over different functions (IFUNC) of DGGESX, types (PRTYPE)
* of test matrices, different size (M+N)
*
PRTYPE = 0
QBA = 3
QBB = 4
WEIGHT = SQRT( ULP )
*
DO 60 IFUNC = 0, 3
DO 50 PRTYPE = 1, 5
DO 40 M = 1, NSIZE - 1
DO 30 N = 1, NSIZE - M
*
WEIGHT = ONE / WEIGHT
MPLUSN = M + N
*
* Generate test matrices
*
FS = .TRUE.
K = 0
*
CALL DLASET( 'Full', MPLUSN, MPLUSN, ZERO, ZERO, AI,
$ LDA )
CALL DLASET( 'Full', MPLUSN, MPLUSN, ZERO, ZERO, BI,
$ LDA )
*
CALL DLATM5( PRTYPE, M, N, AI, LDA, AI( M+1, M+1 ),
$ LDA, AI( 1, M+1 ), LDA, BI, LDA,
$ BI( M+1, M+1 ), LDA, BI( 1, M+1 ), LDA,
$ Q, LDA, Z, LDA, WEIGHT, QBA, QBB )
*
* Compute the Schur factorization and swapping the
* m-by-m (1,1)-blocks with n-by-n (2,2)-blocks.
* Swapping is accomplished via the function DLCTSX
* which is supplied below.
*
IF( IFUNC.EQ.0 ) THEN
SENSE = 'N'
ELSE IF( IFUNC.EQ.1 ) THEN
SENSE = 'E'
ELSE IF( IFUNC.EQ.2 ) THEN
SENSE = 'V'
ELSE IF( IFUNC.EQ.3 ) THEN
SENSE = 'B'
END IF
*
CALL DLACPY( 'Full', MPLUSN, MPLUSN, AI, LDA, A, LDA )
CALL DLACPY( 'Full', MPLUSN, MPLUSN, BI, LDA, B, LDA )
*
CALL DGGESX( 'V', 'V', 'S', DLCTSX, SENSE, MPLUSN, AI,
$ LDA, BI, LDA, MM, ALPHAR, ALPHAI, BETA,
$ Q, LDA, Z, LDA, PL, DIFEST, WORK, LWORK,
$ IWORK, LIWORK, BWORK, LINFO )
*
IF( LINFO.NE.0 .AND. LINFO.NE.MPLUSN+2 ) THEN
RESULT( 1 ) = ULPINV
WRITE( NOUT, FMT = 9999 )'DGGESX', LINFO, MPLUSN,
$ PRTYPE
INFO = LINFO
GO TO 30
END IF
*
* Compute the norm(A, B)
*
CALL DLACPY( 'Full', MPLUSN, MPLUSN, AI, LDA, WORK,
$ MPLUSN )
CALL DLACPY( 'Full', MPLUSN, MPLUSN, BI, LDA,
$ WORK( MPLUSN*MPLUSN+1 ), MPLUSN )
ABNRM = DLANGE( 'Fro', MPLUSN, 2*MPLUSN, WORK, MPLUSN,
$ WORK )
*
* Do tests (1) to (4)
*
CALL DGET51( 1, MPLUSN, A, LDA, AI, LDA, Q, LDA, Z,
$ LDA, WORK, RESULT( 1 ) )
CALL DGET51( 1, MPLUSN, B, LDA, BI, LDA, Q, LDA, Z,
$ LDA, WORK, RESULT( 2 ) )
CALL DGET51( 3, MPLUSN, B, LDA, BI, LDA, Q, LDA, Q,
$ LDA, WORK, RESULT( 3 ) )
CALL DGET51( 3, MPLUSN, B, LDA, BI, LDA, Z, LDA, Z,
$ LDA, WORK, RESULT( 4 ) )
NTEST = 4
*
* Do tests (5) and (6): check Schur form of A and
* compare eigenvalues with diagonals.
*
TEMP1 = ZERO
RESULT( 5 ) = ZERO
RESULT( 6 ) = ZERO
*
DO 10 J = 1, MPLUSN
ILABAD = .FALSE.
IF( ALPHAI( J ).EQ.ZERO ) THEN
TEMP2 = ( ABS( ALPHAR( J )-AI( J, J ) ) /
$ MAX( SMLNUM, ABS( ALPHAR( J ) ),
$ ABS( AI( J, J ) ) )+
$ ABS( BETA( J )-BI( J, J ) ) /
$ MAX( SMLNUM, ABS( BETA( J ) ),
$ ABS( BI( J, J ) ) ) ) / ULP
IF( J.LT.MPLUSN ) THEN
IF( AI( J+1, J ).NE.ZERO ) THEN
ILABAD = .TRUE.
RESULT( 5 ) = ULPINV
END IF
END IF
IF( J.GT.1 ) THEN
IF( AI( J, J-1 ).NE.ZERO ) THEN
ILABAD = .TRUE.
RESULT( 5 ) = ULPINV
END IF
END IF
ELSE
IF( ALPHAI( J ).GT.ZERO ) THEN
I1 = J
ELSE
I1 = J - 1
END IF
IF( I1.LE.0 .OR. I1.GE.MPLUSN ) THEN
ILABAD = .TRUE.
ELSE IF( I1.LT.MPLUSN-1 ) THEN
IF( AI( I1+2, I1+1 ).NE.ZERO ) THEN
ILABAD = .TRUE.
RESULT( 5 ) = ULPINV
END IF
ELSE IF( I1.GT.1 ) THEN
IF( AI( I1, I1-1 ).NE.ZERO ) THEN
ILABAD = .TRUE.
RESULT( 5 ) = ULPINV
END IF
END IF
IF( .NOT.ILABAD ) THEN
CALL DGET53( AI( I1, I1 ), LDA, BI( I1, I1 ),
$ LDA, BETA( J ), ALPHAR( J ),
$ ALPHAI( J ), TEMP2, IINFO )
IF( IINFO.GE.3 ) THEN
WRITE( NOUT, FMT = 9997 )IINFO, J,
$ MPLUSN, PRTYPE
INFO = ABS( IINFO )
END IF
ELSE
TEMP2 = ULPINV
END IF
END IF
TEMP1 = MAX( TEMP1, TEMP2 )
IF( ILABAD ) THEN
WRITE( NOUT, FMT = 9996 )J, MPLUSN, PRTYPE
END IF
10 CONTINUE
RESULT( 6 ) = TEMP1
NTEST = NTEST + 2
*
* Test (7) (if sorting worked)
*
RESULT( 7 ) = ZERO
IF( LINFO.EQ.MPLUSN+3 ) THEN
RESULT( 7 ) = ULPINV
ELSE IF( MM.NE.N ) THEN
RESULT( 7 ) = ULPINV
END IF
NTEST = NTEST + 1
*
* Test (8): compare the estimated value DIF and its
* value. first, compute the exact DIF.
*
RESULT( 8 ) = ZERO
MN2 = MM*( MPLUSN-MM )*2
IF( IFUNC.GE.2 .AND. MN2.LE.NCMAX*NCMAX ) THEN
*
* Note: for either following two causes, there are
* almost same number of test cases fail the test.
*
CALL DLAKF2( MM, MPLUSN-MM, AI, LDA,
$ AI( MM+1, MM+1 ), BI,
$ BI( MM+1, MM+1 ), C, LDC )
*
CALL DGESVD( 'N', 'N', MN2, MN2, C, LDC, S, WORK,
$ 1, WORK( 2 ), 1, WORK( 3 ), LWORK-2,
$ INFO )
DIFTRU = S( MN2 )
*
IF( DIFEST( 2 ).EQ.ZERO ) THEN
IF( DIFTRU.GT.ABNRM*ULP )
$ RESULT( 8 ) = ULPINV
ELSE IF( DIFTRU.EQ.ZERO ) THEN
IF( DIFEST( 2 ).GT.ABNRM*ULP )
$ RESULT( 8 ) = ULPINV
ELSE IF( ( DIFTRU.GT.THRSH2*DIFEST( 2 ) ) .OR.
$ ( DIFTRU*THRSH2.LT.DIFEST( 2 ) ) ) THEN
RESULT( 8 ) = MAX( DIFTRU / DIFEST( 2 ),
$ DIFEST( 2 ) / DIFTRU )
END IF
NTEST = NTEST + 1
END IF
*
* Test (9)
*
RESULT( 9 ) = ZERO
IF( LINFO.EQ.( MPLUSN+2 ) ) THEN
IF( DIFTRU.GT.ABNRM*ULP )
$ RESULT( 9 ) = ULPINV
IF( ( IFUNC.GT.1 ) .AND. ( DIFEST( 2 ).NE.ZERO ) )
$ RESULT( 9 ) = ULPINV
IF( ( IFUNC.EQ.1 ) .AND. ( PL( 1 ).NE.ZERO ) )
$ RESULT( 9 ) = ULPINV
NTEST = NTEST + 1
END IF
*
NTESTT = NTESTT + NTEST
*
* Print out tests which fail.
*
DO 20 J = 1, 9
IF( RESULT( J ).GE.THRESH ) THEN
*
* If this is the first test to fail,
* print a header to the data file.
*
IF( NERRS.EQ.0 ) THEN
WRITE( NOUT, FMT = 9995 )'SGX'
*
* Matrix types
*
WRITE( NOUT, FMT = 9993 )
*
* Tests performed
*
WRITE( NOUT, FMT = 9992 )'orthogonal', '''',
$ 'transpose', ( '''', I = 1, 4 )
*
END IF
NERRS = NERRS + 1
IF( RESULT( J ).LT.10000.0D0 ) THEN
WRITE( NOUT, FMT = 9991 )MPLUSN, PRTYPE,
$ WEIGHT, M, J, RESULT( J )
ELSE
WRITE( NOUT, FMT = 9990 )MPLUSN, PRTYPE,
$ WEIGHT, M, J, RESULT( J )
END IF
END IF
20 CONTINUE
*
30 CONTINUE
40 CONTINUE
50 CONTINUE
60 CONTINUE
*
GO TO 150
*
70 CONTINUE
*
* Read in data from file to check accuracy of condition estimation
* Read input data until N=0
*
NPTKNT = 0
*
80 CONTINUE
READ( NIN, FMT = *, END = 140 )MPLUSN
IF( MPLUSN.EQ.0 )
$ GO TO 140
READ( NIN, FMT = *, END = 140 )N
DO 90 I = 1, MPLUSN
READ( NIN, FMT = * )( AI( I, J ), J = 1, MPLUSN )
90 CONTINUE
DO 100 I = 1, MPLUSN
READ( NIN, FMT = * )( BI( I, J ), J = 1, MPLUSN )
100 CONTINUE
READ( NIN, FMT = * )PLTRU, DIFTRU
*
NPTKNT = NPTKNT + 1
FS = .TRUE.
K = 0
M = MPLUSN - N
*
CALL DLACPY( 'Full', MPLUSN, MPLUSN, AI, LDA, A, LDA )
CALL DLACPY( 'Full', MPLUSN, MPLUSN, BI, LDA, B, LDA )
*
* Compute the Schur factorization while swaping the
* m-by-m (1,1)-blocks with n-by-n (2,2)-blocks.
*
CALL DGGESX( 'V', 'V', 'S', DLCTSX, 'B', MPLUSN, AI, LDA, BI, LDA,
$ MM, ALPHAR, ALPHAI, BETA, Q, LDA, Z, LDA, PL, DIFEST,
$ WORK, LWORK, IWORK, LIWORK, BWORK, LINFO )
*
IF( LINFO.NE.0 .AND. LINFO.NE.MPLUSN+2 ) THEN
RESULT( 1 ) = ULPINV
WRITE( NOUT, FMT = 9998 )'DGGESX', LINFO, MPLUSN, NPTKNT
GO TO 130
END IF
*
* Compute the norm(A, B)
* (should this be norm of (A,B) or (AI,BI)?)
*
CALL DLACPY( 'Full', MPLUSN, MPLUSN, AI, LDA, WORK, MPLUSN )
CALL DLACPY( 'Full', MPLUSN, MPLUSN, BI, LDA,
$ WORK( MPLUSN*MPLUSN+1 ), MPLUSN )
ABNRM = DLANGE( 'Fro', MPLUSN, 2*MPLUSN, WORK, MPLUSN, WORK )
*
* Do tests (1) to (4)
*
CALL DGET51( 1, MPLUSN, A, LDA, AI, LDA, Q, LDA, Z, LDA, WORK,
$ RESULT( 1 ) )
CALL DGET51( 1, MPLUSN, B, LDA, BI, LDA, Q, LDA, Z, LDA, WORK,
$ RESULT( 2 ) )
CALL DGET51( 3, MPLUSN, B, LDA, BI, LDA, Q, LDA, Q, LDA, WORK,
$ RESULT( 3 ) )
CALL DGET51( 3, MPLUSN, B, LDA, BI, LDA, Z, LDA, Z, LDA, WORK,
$ RESULT( 4 ) )
*
* Do tests (5) and (6): check Schur form of A and compare
* eigenvalues with diagonals.
*
NTEST = 6
TEMP1 = ZERO
RESULT( 5 ) = ZERO
RESULT( 6 ) = ZERO
*
DO 110 J = 1, MPLUSN
ILABAD = .FALSE.
IF( ALPHAI( J ).EQ.ZERO ) THEN
TEMP2 = ( ABS( ALPHAR( J )-AI( J, J ) ) /
$ MAX( SMLNUM, ABS( ALPHAR( J ) ), ABS( AI( J,
$ J ) ) )+ABS( BETA( J )-BI( J, J ) ) /
$ MAX( SMLNUM, ABS( BETA( J ) ), ABS( BI( J, J ) ) ) )
$ / ULP
IF( J.LT.MPLUSN ) THEN
IF( AI( J+1, J ).NE.ZERO ) THEN
ILABAD = .TRUE.
RESULT( 5 ) = ULPINV
END IF
END IF
IF( J.GT.1 ) THEN
IF( AI( J, J-1 ).NE.ZERO ) THEN
ILABAD = .TRUE.
RESULT( 5 ) = ULPINV
END IF
END IF
ELSE
IF( ALPHAI( J ).GT.ZERO ) THEN
I1 = J
ELSE
I1 = J - 1
END IF
IF( I1.LE.0 .OR. I1.GE.MPLUSN ) THEN
ILABAD = .TRUE.
ELSE IF( I1.LT.MPLUSN-1 ) THEN
IF( AI( I1+2, I1+1 ).NE.ZERO ) THEN
ILABAD = .TRUE.
RESULT( 5 ) = ULPINV
END IF
ELSE IF( I1.GT.1 ) THEN
IF( AI( I1, I1-1 ).NE.ZERO ) THEN
ILABAD = .TRUE.
RESULT( 5 ) = ULPINV
END IF
END IF
IF( .NOT.ILABAD ) THEN
CALL DGET53( AI( I1, I1 ), LDA, BI( I1, I1 ), LDA,
$ BETA( J ), ALPHAR( J ), ALPHAI( J ), TEMP2,
$ IINFO )
IF( IINFO.GE.3 ) THEN
WRITE( NOUT, FMT = 9997 )IINFO, J, MPLUSN, NPTKNT
INFO = ABS( IINFO )
END IF
ELSE
TEMP2 = ULPINV
END IF
END IF
TEMP1 = MAX( TEMP1, TEMP2 )
IF( ILABAD ) THEN
WRITE( NOUT, FMT = 9996 )J, MPLUSN, NPTKNT
END IF
110 CONTINUE
RESULT( 6 ) = TEMP1
*
* Test (7) (if sorting worked) <--------- need to be checked.
*
NTEST = 7
RESULT( 7 ) = ZERO
IF( LINFO.EQ.MPLUSN+3 )
$ RESULT( 7 ) = ULPINV
*
* Test (8): compare the estimated value of DIF and its true value.
*
NTEST = 8
RESULT( 8 ) = ZERO
IF( DIFEST( 2 ).EQ.ZERO ) THEN
IF( DIFTRU.GT.ABNRM*ULP )
$ RESULT( 8 ) = ULPINV
ELSE IF( DIFTRU.EQ.ZERO ) THEN
IF( DIFEST( 2 ).GT.ABNRM*ULP )
$ RESULT( 8 ) = ULPINV
ELSE IF( ( DIFTRU.GT.THRSH2*DIFEST( 2 ) ) .OR.
$ ( DIFTRU*THRSH2.LT.DIFEST( 2 ) ) ) THEN
RESULT( 8 ) = MAX( DIFTRU / DIFEST( 2 ), DIFEST( 2 ) / DIFTRU )
END IF
*
* Test (9)
*
NTEST = 9
RESULT( 9 ) = ZERO
IF( LINFO.EQ.( MPLUSN+2 ) ) THEN
IF( DIFTRU.GT.ABNRM*ULP )
$ RESULT( 9 ) = ULPINV
IF( ( IFUNC.GT.1 ) .AND. ( DIFEST( 2 ).NE.ZERO ) )
$ RESULT( 9 ) = ULPINV
IF( ( IFUNC.EQ.1 ) .AND. ( PL( 1 ).NE.ZERO ) )
$ RESULT( 9 ) = ULPINV
END IF
*
* Test (10): compare the estimated value of PL and it true value.
*
NTEST = 10
RESULT( 10 ) = ZERO
IF( PL( 1 ).EQ.ZERO ) THEN
IF( PLTRU.GT.ABNRM*ULP )
$ RESULT( 10 ) = ULPINV
ELSE IF( PLTRU.EQ.ZERO ) THEN
IF( PL( 1 ).GT.ABNRM*ULP )
$ RESULT( 10 ) = ULPINV
ELSE IF( ( PLTRU.GT.THRESH*PL( 1 ) ) .OR.
$ ( PLTRU*THRESH.LT.PL( 1 ) ) ) THEN
RESULT( 10 ) = ULPINV
END IF
*
NTESTT = NTESTT + NTEST
*
* Print out tests which fail.
*
DO 120 J = 1, NTEST
IF( RESULT( J ).GE.THRESH ) THEN
*
* If this is the first test to fail,
* print a header to the data file.
*
IF( NERRS.EQ.0 ) THEN
WRITE( NOUT, FMT = 9995 )'SGX'
*
* Matrix types
*
WRITE( NOUT, FMT = 9994 )
*
* Tests performed
*
WRITE( NOUT, FMT = 9992 )'orthogonal', '''',
$ 'transpose', ( '''', I = 1, 4 )
*
END IF
NERRS = NERRS + 1
IF( RESULT( J ).LT.10000.0D0 ) THEN
WRITE( NOUT, FMT = 9989 )NPTKNT, MPLUSN, J, RESULT( J )
ELSE
WRITE( NOUT, FMT = 9988 )NPTKNT, MPLUSN, J, RESULT( J )
END IF
END IF
*
120 CONTINUE
*
130 CONTINUE
GO TO 80
140 CONTINUE
*
150 CONTINUE
*
* Summary
*
CALL ALASVM( 'SGX', NOUT, NERRS, NTESTT, 0 )
*
WORK( 1 ) = MAXWRK
*
RETURN
*
9999 FORMAT( ' DDRGSX: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ')' )
*
9998 FORMAT( ' DDRGSX: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', Input Example #', I2, ')' )
*
9997 FORMAT( ' DDRGSX: DGET53 returned INFO=', I1, ' for eigenvalue ',
$ I6, '.', / 9X, 'N=', I6, ', JTYPE=', I6, ')' )
*
9996 FORMAT( ' DDRGSX: S not in Schur form at eigenvalue ', I6, '.',
$ / 9X, 'N=', I6, ', JTYPE=', I6, ')' )
*
9995 FORMAT( / 1X, A3, ' -- Real Expert Generalized Schur form',
$ ' problem driver' )
*
9994 FORMAT( 'Input Example' )
*
9993 FORMAT( ' Matrix types: ', /
$ ' 1: A is a block diagonal matrix of Jordan blocks ',
$ 'and B is the identity ', / ' matrix, ',
$ / ' 2: A and B are upper triangular matrices, ',
$ / ' 3: A and B are as type 2, but each second diagonal ',
$ 'block in A_11 and ', /
$ ' each third diaongal block in A_22 are 2x2 blocks,',
$ / ' 4: A and B are block diagonal matrices, ',
$ / ' 5: (A,B) has potentially close or common ',
$ 'eigenvalues.', / )
*
9992 FORMAT( / ' Tests performed: (S is Schur, T is triangular, ',
$ 'Q and Z are ', A, ',', / 19X,
$ ' a is alpha, b is beta, and ', A, ' means ', A, '.)',
$ / ' 1 = | A - Q S Z', A,
$ ' | / ( |A| n ulp ) 2 = | B - Q T Z', A,
$ ' | / ( |B| n ulp )', / ' 3 = | I - QQ', A,
$ ' | / ( n ulp ) 4 = | I - ZZ', A,
$ ' | / ( n ulp )', / ' 5 = 1/ULP if A is not in ',
$ 'Schur form S', / ' 6 = difference between (alpha,beta)',
$ ' and diagonals of (S,T)', /
$ ' 7 = 1/ULP if SDIM is not the correct number of ',
$ 'selected eigenvalues', /
$ ' 8 = 1/ULP if DIFEST/DIFTRU > 10*THRESH or ',
$ 'DIFTRU/DIFEST > 10*THRESH',
$ / ' 9 = 1/ULP if DIFEST <> 0 or DIFTRU > ULP*norm(A,B) ',
$ 'when reordering fails', /
$ ' 10 = 1/ULP if PLEST/PLTRU > THRESH or ',
$ 'PLTRU/PLEST > THRESH', /
$ ' ( Test 10 is only for input examples )', / )
9991 FORMAT( ' Matrix order=', I2, ', type=', I2, ', a=', D10.4,
$ ', order(A_11)=', I2, ', result ', I2, ' is ', 0P, F8.2 )
9990 FORMAT( ' Matrix order=', I2, ', type=', I2, ', a=', D10.4,
$ ', order(A_11)=', I2, ', result ', I2, ' is ', 0P, D10.4 )
9989 FORMAT( ' Input example #', I2, ', matrix order=', I4, ',',
$ ' result ', I2, ' is', 0P, F8.2 )
9988 FORMAT( ' Input example #', I2, ', matrix order=', I4, ',',
$ ' result ', I2, ' is', 1P, D10.3 )
*
* End of DDRGSX
*
END
SUBROUTINE DDRGVX( NSIZE, THRESH, NIN, NOUT, A, LDA, B, AI, BI,
$ ALPHAR, ALPHAI, BETA, VL, VR, ILO, IHI, LSCALE,
$ RSCALE, S, DTRU, DIF, DIFTRU, WORK, LWORK,
$ IWORK, LIWORK, RESULT, BWORK, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IHI, ILO, INFO, LDA, LIWORK, LWORK, NIN, NOUT,
$ NSIZE
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL BWORK( * )
INTEGER IWORK( * )
DOUBLE PRECISION A( LDA, * ), AI( LDA, * ), ALPHAI( * ),
$ ALPHAR( * ), B( LDA, * ), BETA( * ),
$ BI( LDA, * ), DIF( * ), DIFTRU( * ), DTRU( * ),
$ LSCALE( * ), RESULT( 4 ), RSCALE( * ), S( * ),
$ VL( LDA, * ), VR( LDA, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DDRGVX checks the nonsymmetric generalized eigenvalue problem
* expert driver DGGEVX.
*
* DGGEVX computes the generalized eigenvalues, (optionally) the left
* and/or right eigenvectors, (optionally) computes a balancing
* transformation to improve the conditioning, and (optionally)
* reciprocal condition numbers for the eigenvalues and eigenvectors.
*
* When DDRGVX is called with NSIZE > 0, two types of test matrix pairs
* are generated by the subroutine DLATM6 and test the driver DGGEVX.
* The test matrices have the known exact condition numbers for
* eigenvalues. For the condition numbers of the eigenvectors
* corresponding the first and last eigenvalues are also know
* ``exactly'' (see DLATM6).
*
* For each matrix pair, the following tests will be performed and
* compared with the threshhold THRESH.
*
* (1) max over all left eigenvalue/-vector pairs (beta/alpha,l) of
*
* | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) )
*
* where l**H is the conjugate tranpose of l.
*
* (2) max over all right eigenvalue/-vector pairs (beta/alpha,r) of
*
* | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) )
*
* (3) The condition number S(i) of eigenvalues computed by DGGEVX
* differs less than a factor THRESH from the exact S(i) (see
* DLATM6).
*
* (4) DIF(i) computed by DTGSNA differs less than a factor 10*THRESH
* from the exact value (for the 1st and 5th vectors only).
*
* Test Matrices
* =============
*
* Two kinds of test matrix pairs
*
* (A, B) = inverse(YH) * (Da, Db) * inverse(X)
*
* are used in the tests:
*
* 1: Da = 1+a 0 0 0 0 Db = 1 0 0 0 0
* 0 2+a 0 0 0 0 1 0 0 0
* 0 0 3+a 0 0 0 0 1 0 0
* 0 0 0 4+a 0 0 0 0 1 0
* 0 0 0 0 5+a , 0 0 0 0 1 , and
*
* 2: Da = 1 -1 0 0 0 Db = 1 0 0 0 0
* 1 1 0 0 0 0 1 0 0 0
* 0 0 1 0 0 0 0 1 0 0
* 0 0 0 1+a 1+b 0 0 0 1 0
* 0 0 0 -1-b 1+a , 0 0 0 0 1 .
*
* In both cases the same inverse(YH) and inverse(X) are used to compute
* (A, B), giving the exact eigenvectors to (A,B) as (YH, X):
*
* YH: = 1 0 -y y -y X = 1 0 -x -x x
* 0 1 -y y -y 0 1 x -x -x
* 0 0 1 0 0 0 0 1 0 0
* 0 0 0 1 0 0 0 0 1 0
* 0 0 0 0 1, 0 0 0 0 1 , where
*
* a, b, x and y will have all values independently of each other from
* { sqrt(sqrt(ULP)), 0.1, 1, 10, 1/sqrt(sqrt(ULP)) }.
*
* Arguments
* =========
*
* NSIZE (input) INTEGER
* The number of sizes of matrices to use. NSIZE must be at
* least zero. If it is zero, no randomly generated matrices
* are tested, but any test matrices read from NIN will be
* tested.
*
* THRESH (input) DOUBLE PRECISION
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error
* is scaled to be O(1), so THRESH should be a reasonably
* small multiple of 1, e.g., 10 or 100. In particular,
* it should not depend on the precision (single vs. double)
* or the size of the matrix. It must be at least zero.
*
* NIN (input) INTEGER
* The FORTRAN unit number for reading in the data file of
* problems to solve.
*
* NOUT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns IINFO not equal to 0.)
*
* A (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE)
* Used to hold the matrix whose eigenvalues are to be
* computed. On exit, A contains the last matrix actually used.
*
* LDA (input) INTEGER
* The leading dimension of A, B, AI, BI, Ao, and Bo.
* It must be at least 1 and at least NSIZE.
*
* B (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE)
* Used to hold the matrix whose eigenvalues are to be
* computed. On exit, B contains the last matrix actually used.
*
* AI (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE)
* Copy of A, modified by DGGEVX.
*
* BI (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE)
* Copy of B, modified by DGGEVX.
*
* ALPHAR (workspace) DOUBLE PRECISION array, dimension (NSIZE)
* ALPHAI (workspace) DOUBLE PRECISION array, dimension (NSIZE)
* BETA (workspace) DOUBLE PRECISION array, dimension (NSIZE)
* On exit, (ALPHAR + ALPHAI*i)/BETA are the eigenvalues.
*
* VL (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE)
* VL holds the left eigenvectors computed by DGGEVX.
*
* VR (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE)
* VR holds the right eigenvectors computed by DGGEVX.
*
* ILO (output/workspace) INTEGER
*
* IHI (output/workspace) INTEGER
*
* LSCALE (output/workspace) DOUBLE PRECISION array, dimension (N)
*
* RSCALE (output/workspace) DOUBLE PRECISION array, dimension (N)
*
* S (output/workspace) DOUBLE PRECISION array, dimension (N)
*
* DTRU (output/workspace) DOUBLE PRECISION array, dimension (N)
*
* DIF (output/workspace) DOUBLE PRECISION array, dimension (N)
*
* DIFTRU (output/workspace) DOUBLE PRECISION array, dimension (N)
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* Leading dimension of WORK. LWORK >= 2*N*N+12*N+16.
*
* IWORK (workspace) INTEGER array, dimension (LIWORK)
*
* LIWORK (input) INTEGER
* Leading dimension of IWORK. Must be at least N+6.
*
* RESULT (output/workspace) DOUBLE PRECISION array, dimension (4)
*
* BWORK (workspace) LOGICAL array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: A routine returned an error code.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TEN, TNTH
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1,
$ TNTH = 1.0D-1 )
* ..
* .. Local Scalars ..
INTEGER I, IPTYPE, IWA, IWB, IWX, IWY, J, LINFO,
$ MAXWRK, MINWRK, N, NERRS, NMAX, NPTKNT, NTESTT
DOUBLE PRECISION ABNORM, ANORM, BNORM, RATIO1, RATIO2, THRSH2,
$ ULP, ULPINV
* ..
* .. Local Arrays ..
DOUBLE PRECISION WEIGHT( 5 )
* ..
* .. External Functions ..
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL ILAENV, DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL ALASVM, DGET52, DGGEVX, DLACPY, DLATM6, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Check for errors
*
INFO = 0
*
NMAX = 5
*
IF( NSIZE.LT.0 ) THEN
INFO = -1
ELSE IF( THRESH.LT.ZERO ) THEN
INFO = -2
ELSE IF( NIN.LE.0 ) THEN
INFO = -3
ELSE IF( NOUT.LE.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.1 .OR. LDA.LT.NMAX ) THEN
INFO = -6
ELSE IF( LIWORK.LT.NMAX+6 ) THEN
INFO = -26
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.)
*
MINWRK = 1
IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN
MINWRK = 2*NMAX*NMAX + 12*NMAX + 16
MAXWRK = 6*NMAX + NMAX*ILAENV( 1, 'DGEQRF', ' ', NMAX, 1, NMAX,
$ 0 )
MAXWRK = MAX( MAXWRK, 2*NMAX*NMAX+12*NMAX+16 )
WORK( 1 ) = MAXWRK
END IF
*
IF( LWORK.LT.MINWRK )
$ INFO = -24
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DDRGVX', -INFO )
RETURN
END IF
*
N = 5
ULP = DLAMCH( 'P' )
ULPINV = ONE / ULP
THRSH2 = TEN*THRESH
NERRS = 0
NPTKNT = 0
NTESTT = 0
*
IF( NSIZE.EQ.0 )
$ GO TO 90
*
* Parameters used for generating test matrices.
*
WEIGHT( 1 ) = SQRT( SQRT( ULP ) )
WEIGHT( 2 ) = TNTH
WEIGHT( 3 ) = ONE
WEIGHT( 4 ) = ONE / WEIGHT( 2 )
WEIGHT( 5 ) = ONE / WEIGHT( 1 )
*
DO 80 IPTYPE = 1, 2
DO 70 IWA = 1, 5
DO 60 IWB = 1, 5
DO 50 IWX = 1, 5
DO 40 IWY = 1, 5
*
* generated a test matrix pair
*
CALL DLATM6( IPTYPE, 5, A, LDA, B, VR, LDA, VL,
$ LDA, WEIGHT( IWA ), WEIGHT( IWB ),
$ WEIGHT( IWX ), WEIGHT( IWY ), DTRU,
$ DIFTRU )
*
* Compute eigenvalues/eigenvectors of (A, B).
* Compute eigenvalue/eigenvector condition numbers
* using computed eigenvectors.
*
CALL DLACPY( 'F', N, N, A, LDA, AI, LDA )
CALL DLACPY( 'F', N, N, B, LDA, BI, LDA )
*
CALL DGGEVX( 'N', 'V', 'V', 'B', N, AI, LDA, BI,
$ LDA, ALPHAR, ALPHAI, BETA, VL, LDA,
$ VR, LDA, ILO, IHI, LSCALE, RSCALE,
$ ANORM, BNORM, S, DIF, WORK, LWORK,
$ IWORK, BWORK, LINFO )
IF( LINFO.NE.0 ) THEN
RESULT( 1 ) = ULPINV
WRITE( NOUT, FMT = 9999 )'DGGEVX', LINFO, N,
$ IPTYPE
GO TO 30
END IF
*
* Compute the norm(A, B)
*
CALL DLACPY( 'Full', N, N, AI, LDA, WORK, N )
CALL DLACPY( 'Full', N, N, BI, LDA, WORK( N*N+1 ),
$ N )
ABNORM = DLANGE( 'Fro', N, 2*N, WORK, N, WORK )
*
* Tests (1) and (2)
*
RESULT( 1 ) = ZERO
CALL DGET52( .TRUE., N, A, LDA, B, LDA, VL, LDA,
$ ALPHAR, ALPHAI, BETA, WORK,
$ RESULT( 1 ) )
IF( RESULT( 2 ).GT.THRESH ) THEN
WRITE( NOUT, FMT = 9998 )'Left', 'DGGEVX',
$ RESULT( 2 ), N, IPTYPE, IWA, IWB, IWX, IWY
END IF
*
RESULT( 2 ) = ZERO
CALL DGET52( .FALSE., N, A, LDA, B, LDA, VR, LDA,
$ ALPHAR, ALPHAI, BETA, WORK,
$ RESULT( 2 ) )
IF( RESULT( 3 ).GT.THRESH ) THEN
WRITE( NOUT, FMT = 9998 )'Right', 'DGGEVX',
$ RESULT( 3 ), N, IPTYPE, IWA, IWB, IWX, IWY
END IF
*
* Test (3)
*
RESULT( 3 ) = ZERO
DO 10 I = 1, N
IF( S( I ).EQ.ZERO ) THEN
IF( DTRU( I ).GT.ABNORM*ULP )
$ RESULT( 3 ) = ULPINV
ELSE IF( DTRU( I ).EQ.ZERO ) THEN
IF( S( I ).GT.ABNORM*ULP )
$ RESULT( 3 ) = ULPINV
ELSE
WORK( I ) = MAX( ABS( DTRU( I ) / S( I ) ),
$ ABS( S( I ) / DTRU( I ) ) )
RESULT( 3 ) = MAX( RESULT( 3 ), WORK( I ) )
END IF
10 CONTINUE
*
* Test (4)
*
RESULT( 4 ) = ZERO
IF( DIF( 1 ).EQ.ZERO ) THEN
IF( DIFTRU( 1 ).GT.ABNORM*ULP )
$ RESULT( 4 ) = ULPINV
ELSE IF( DIFTRU( 1 ).EQ.ZERO ) THEN
IF( DIF( 1 ).GT.ABNORM*ULP )
$ RESULT( 4 ) = ULPINV
ELSE IF( DIF( 5 ).EQ.ZERO ) THEN
IF( DIFTRU( 5 ).GT.ABNORM*ULP )
$ RESULT( 4 ) = ULPINV
ELSE IF( DIFTRU( 5 ).EQ.ZERO ) THEN
IF( DIF( 5 ).GT.ABNORM*ULP )
$ RESULT( 4 ) = ULPINV
ELSE
RATIO1 = MAX( ABS( DIFTRU( 1 ) / DIF( 1 ) ),
$ ABS( DIF( 1 ) / DIFTRU( 1 ) ) )
RATIO2 = MAX( ABS( DIFTRU( 5 ) / DIF( 5 ) ),
$ ABS( DIF( 5 ) / DIFTRU( 5 ) ) )
RESULT( 4 ) = MAX( RATIO1, RATIO2 )
END IF
*
NTESTT = NTESTT + 4
*
* Print out tests which fail.
*
DO 20 J = 1, 4
IF( ( RESULT( J ).GE.THRSH2 .AND. J.GE.4 ) .OR.
$ ( RESULT( J ).GE.THRESH .AND. J.LE.3 ) )
$ THEN
*
* If this is the first test to fail,
* print a header to the data file.
*
IF( NERRS.EQ.0 ) THEN
WRITE( NOUT, FMT = 9997 )'DXV'
*
* Print out messages for built-in examples
*
* Matrix types
*
WRITE( NOUT, FMT = 9995 )
WRITE( NOUT, FMT = 9994 )
WRITE( NOUT, FMT = 9993 )
*
* Tests performed
*
WRITE( NOUT, FMT = 9992 )'''',
$ 'transpose', ''''
*
END IF
NERRS = NERRS + 1
IF( RESULT( J ).LT.10000.0D0 ) THEN
WRITE( NOUT, FMT = 9991 )IPTYPE, IWA,
$ IWB, IWX, IWY, J, RESULT( J )
ELSE
WRITE( NOUT, FMT = 9990 )IPTYPE, IWA,
$ IWB, IWX, IWY, J, RESULT( J )
END IF
END IF
20 CONTINUE
*
30 CONTINUE
*
40 CONTINUE
50 CONTINUE
60 CONTINUE
70 CONTINUE
80 CONTINUE
*
GO TO 150
*
90 CONTINUE
*
* Read in data from file to check accuracy of condition estimation
* Read input data until N=0
*
READ( NIN, FMT = *, END = 150 )N
IF( N.EQ.0 )
$ GO TO 150
DO 100 I = 1, N
READ( NIN, FMT = * )( A( I, J ), J = 1, N )
100 CONTINUE
DO 110 I = 1, N
READ( NIN, FMT = * )( B( I, J ), J = 1, N )
110 CONTINUE
READ( NIN, FMT = * )( DTRU( I ), I = 1, N )
READ( NIN, FMT = * )( DIFTRU( I ), I = 1, N )
*
NPTKNT = NPTKNT + 1
*
* Compute eigenvalues/eigenvectors of (A, B).
* Compute eigenvalue/eigenvector condition numbers
* using computed eigenvectors.
*
CALL DLACPY( 'F', N, N, A, LDA, AI, LDA )
CALL DLACPY( 'F', N, N, B, LDA, BI, LDA )
*
CALL DGGEVX( 'N', 'V', 'V', 'B', N, AI, LDA, BI, LDA, ALPHAR,
$ ALPHAI, BETA, VL, LDA, VR, LDA, ILO, IHI, LSCALE,
$ RSCALE, ANORM, BNORM, S, DIF, WORK, LWORK, IWORK,
$ BWORK, LINFO )
*
IF( LINFO.NE.0 ) THEN
RESULT( 1 ) = ULPINV
WRITE( NOUT, FMT = 9987 )'DGGEVX', LINFO, N, NPTKNT
GO TO 140
END IF
*
* Compute the norm(A, B)
*
CALL DLACPY( 'Full', N, N, AI, LDA, WORK, N )
CALL DLACPY( 'Full', N, N, BI, LDA, WORK( N*N+1 ), N )
ABNORM = DLANGE( 'Fro', N, 2*N, WORK, N, WORK )
*
* Tests (1) and (2)
*
RESULT( 1 ) = ZERO
CALL DGET52( .TRUE., N, A, LDA, B, LDA, VL, LDA, ALPHAR, ALPHAI,
$ BETA, WORK, RESULT( 1 ) )
IF( RESULT( 2 ).GT.THRESH ) THEN
WRITE( NOUT, FMT = 9986 )'Left', 'DGGEVX', RESULT( 2 ), N,
$ NPTKNT
END IF
*
RESULT( 2 ) = ZERO
CALL DGET52( .FALSE., N, A, LDA, B, LDA, VR, LDA, ALPHAR, ALPHAI,
$ BETA, WORK, RESULT( 2 ) )
IF( RESULT( 3 ).GT.THRESH ) THEN
WRITE( NOUT, FMT = 9986 )'Right', 'DGGEVX', RESULT( 3 ), N,
$ NPTKNT
END IF
*
* Test (3)
*
RESULT( 3 ) = ZERO
DO 120 I = 1, N
IF( S( I ).EQ.ZERO ) THEN
IF( DTRU( I ).GT.ABNORM*ULP )
$ RESULT( 3 ) = ULPINV
ELSE IF( DTRU( I ).EQ.ZERO ) THEN
IF( S( I ).GT.ABNORM*ULP )
$ RESULT( 3 ) = ULPINV
ELSE
WORK( I ) = MAX( ABS( DTRU( I ) / S( I ) ),
$ ABS( S( I ) / DTRU( I ) ) )
RESULT( 3 ) = MAX( RESULT( 3 ), WORK( I ) )
END IF
120 CONTINUE
*
* Test (4)
*
RESULT( 4 ) = ZERO
IF( DIF( 1 ).EQ.ZERO ) THEN
IF( DIFTRU( 1 ).GT.ABNORM*ULP )
$ RESULT( 4 ) = ULPINV
ELSE IF( DIFTRU( 1 ).EQ.ZERO ) THEN
IF( DIF( 1 ).GT.ABNORM*ULP )
$ RESULT( 4 ) = ULPINV
ELSE IF( DIF( 5 ).EQ.ZERO ) THEN
IF( DIFTRU( 5 ).GT.ABNORM*ULP )
$ RESULT( 4 ) = ULPINV
ELSE IF( DIFTRU( 5 ).EQ.ZERO ) THEN
IF( DIF( 5 ).GT.ABNORM*ULP )
$ RESULT( 4 ) = ULPINV
ELSE
RATIO1 = MAX( ABS( DIFTRU( 1 ) / DIF( 1 ) ),
$ ABS( DIF( 1 ) / DIFTRU( 1 ) ) )
RATIO2 = MAX( ABS( DIFTRU( 5 ) / DIF( 5 ) ),
$ ABS( DIF( 5 ) / DIFTRU( 5 ) ) )
RESULT( 4 ) = MAX( RATIO1, RATIO2 )
END IF
*
NTESTT = NTESTT + 4
*
* Print out tests which fail.
*
DO 130 J = 1, 4
IF( RESULT( J ).GE.THRSH2 ) THEN
*
* If this is the first test to fail,
* print a header to the data file.
*
IF( NERRS.EQ.0 ) THEN
WRITE( NOUT, FMT = 9997 )'DXV'
*
* Print out messages for built-in examples
*
* Matrix types
*
WRITE( NOUT, FMT = 9996 )
*
* Tests performed
*
WRITE( NOUT, FMT = 9992 )'''', 'transpose', ''''
*
END IF
NERRS = NERRS + 1
IF( RESULT( J ).LT.10000.0D0 ) THEN
WRITE( NOUT, FMT = 9989 )NPTKNT, N, J, RESULT( J )
ELSE
WRITE( NOUT, FMT = 9988 )NPTKNT, N, J, RESULT( J )
END IF
END IF
130 CONTINUE
*
140 CONTINUE
*
GO TO 90
150 CONTINUE
*
* Summary
*
CALL ALASVM( 'DXV', NOUT, NERRS, NTESTT, 0 )
*
WORK( 1 ) = MAXWRK
*
RETURN
*
9999 FORMAT( ' DDRGVX: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ')' )
*
9998 FORMAT( ' DDRGVX: ', A, ' Eigenvectors from ', A, ' incorrectly ',
$ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 9X,
$ 'N=', I6, ', JTYPE=', I6, ', IWA=', I5, ', IWB=', I5,
$ ', IWX=', I5, ', IWY=', I5 )
*
9997 FORMAT( / 1X, A3, ' -- Real Expert Eigenvalue/vector',
$ ' problem driver' )
*
9996 FORMAT( ' Input Example' )
*
9995 FORMAT( ' Matrix types: ', / )
*
9994 FORMAT( ' TYPE 1: Da is diagonal, Db is identity, ',
$ / ' A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1) ',
$ / ' YH and X are left and right eigenvectors. ', / )
*
9993 FORMAT( ' TYPE 2: Da is quasi-diagonal, Db is identity, ',
$ / ' A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1) ',
$ / ' YH and X are left and right eigenvectors. ', / )
*
9992 FORMAT( / ' Tests performed: ', / 4X,
$ ' a is alpha, b is beta, l is a left eigenvector, ', / 4X,
$ ' r is a right eigenvector and ', A, ' means ', A, '.',
$ / ' 1 = max | ( b A - a B )', A, ' l | / const.',
$ / ' 2 = max | ( b A - a B ) r | / const.',
$ / ' 3 = max ( Sest/Stru, Stru/Sest ) ',
$ ' over all eigenvalues', /
$ ' 4 = max( DIFest/DIFtru, DIFtru/DIFest ) ',
$ ' over the 1st and 5th eigenvectors', / )
*
9991 FORMAT( ' Type=', I2, ',', ' IWA=', I2, ', IWB=', I2, ', IWX=',
$ I2, ', IWY=', I2, ', result ', I2, ' is', 0P, F8.2 )
9990 FORMAT( ' Type=', I2, ',', ' IWA=', I2, ', IWB=', I2, ', IWX=',
$ I2, ', IWY=', I2, ', result ', I2, ' is', 1P, D10.3 )
9989 FORMAT( ' Input example #', I2, ', matrix order=', I4, ',',
$ ' result ', I2, ' is', 0P, F8.2 )
9988 FORMAT( ' Input example #', I2, ', matrix order=', I4, ',',
$ ' result ', I2, ' is', 1P, D10.3 )
9987 FORMAT( ' DDRGVX: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', Input example #', I2, ')' )
*
9986 FORMAT( ' DDRGVX: ', A, ' Eigenvectors from ', A, ' incorrectly ',
$ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 9X,
$ 'N=', I6, ', Input Example #', I2, ')' )
*
*
* End of DDRGVX
*
END
SUBROUTINE DDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH,
$ A, LDA, U, LDU, VT, LDVT, ASAV, USAV, VTSAV, S,
$ SSAV, E, WORK, LWORK, IWORK, NOUT, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDU, LDVT, LWORK, NOUT, NSIZES,
$ NTYPES
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER ISEED( 4 ), IWORK( * ), MM( * ), NN( * )
DOUBLE PRECISION A( LDA, * ), ASAV( LDA, * ), E( * ), S( * ),
$ SSAV( * ), U( LDU, * ), USAV( LDU, * ),
$ VT( LDVT, * ), VTSAV( LDVT, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DDRVBD checks the singular value decomposition (SVD) drivers
* DGESVD and SGESDD.
* Both DGESVD and SGESDD factor A = U diag(S) VT, where U and VT are
* orthogonal and diag(S) is diagonal with the entries of the array S
* on its diagonal. The entries of S are the singular values,
* nonnegative and stored in decreasing order. U and VT can be
* optionally not computed, overwritten on A, or computed partially.
*
* A is M by N. Let MNMIN = min( M, N ). S has dimension MNMIN.
* U can be M by M or M by MNMIN. VT can be N by N or MNMIN by N.
*
* When DDRVBD is called, a number of matrix "sizes" (M's and N's)
* and a number of matrix "types" are specified. For each size (M,N)
* and each type of matrix, and for the minimal workspace as well as
* workspace adequate to permit blocking, an M x N matrix "A" will be
* generated and used to test the SVD routines. For each matrix, A will
* be factored as A = U diag(S) VT and the following 12 tests computed:
*
* Test for DGESVD:
*
* (1) | A - U diag(S) VT | / ( |A| max(M,N) ulp )
*
* (2) | I - U'U | / ( M ulp )
*
* (3) | I - VT VT' | / ( N ulp )
*
* (4) S contains MNMIN nonnegative values in decreasing order.
* (Return 0 if true, 1/ULP if false.)
*
* (5) | U - Upartial | / ( M ulp ) where Upartial is a partially
* computed U.
*
* (6) | VT - VTpartial | / ( N ulp ) where VTpartial is a partially
* computed VT.
*
* (7) | S - Spartial | / ( MNMIN ulp |S| ) where Spartial is the
* vector of singular values from the partial SVD
*
* Test for DGESDD:
*
* (8) | A - U diag(S) VT | / ( |A| max(M,N) ulp )
*
* (9) | I - U'U | / ( M ulp )
*
* (10) | I - VT VT' | / ( N ulp )
*
* (11) S contains MNMIN nonnegative values in decreasing order.
* (Return 0 if true, 1/ULP if false.)
*
* (12) | U - Upartial | / ( M ulp ) where Upartial is a partially
* computed U.
*
* (13) | VT - VTpartial | / ( N ulp ) where VTpartial is a partially
* computed VT.
*
* (14) | S - Spartial | / ( MNMIN ulp |S| ) where Spartial is the
* vector of singular values from the partial SVD
*
* The "sizes" are specified by the arrays MM(1:NSIZES) and
* NN(1:NSIZES); the value of each element pair (MM(j),NN(j))
* specifies one size. The "types" are specified by a logical array
* DOTYPE( 1:NTYPES ); if DOTYPE(j) is .TRUE., then matrix type "j"
* will be generated.
* Currently, the list of possible types is:
*
* (1) The zero matrix.
* (2) The identity matrix.
* (3) A matrix of the form U D V, where U and V are orthogonal and
* D has evenly spaced entries 1, ..., ULP with random signs
* on the diagonal.
* (4) Same as (3), but multiplied by the underflow-threshold / ULP.
* (5) Same as (3), but multiplied by the overflow-threshold * ULP.
*
* Arguments
* ==========
*
* NSIZES (input) INTEGER
* The number of matrix sizes (M,N) contained in the vectors
* MM and NN.
*
* MM (input) INTEGER array, dimension (NSIZES)
* The values of the matrix row dimension M.
*
* NN (input) INTEGER array, dimension (NSIZES)
* The values of the matrix column dimension N.
*
* NTYPES (input) INTEGER
* The number of elements in DOTYPE. If it is zero, DDRVBD
* does nothing. It must be at least zero. If it is MAXTYP+1
* and NSIZES is 1, then an additional type, MAXTYP+1 is
* defined, which is to use whatever matrices are in A and B.
* This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
* DOTYPE(MAXTYP+1) is .TRUE. .
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* If DOTYPE(j) is .TRUE., then for each size (m,n), a matrix
* of type j will be generated. If NTYPES is smaller than the
* maximum number of types defined (PARAMETER MAXTYP), then
* types NTYPES+1 through MAXTYP will not be generated. If
* NTYPES is larger than MAXTYP, DOTYPE(MAXTYP+1) through
* DOTYPE(NTYPES) will be ignored.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry, the seed of the random number generator. The array
* elements should be between 0 and 4095; if not they will be
* reduced mod 4096. Also, ISEED(4) must be odd.
* On exit, ISEED is changed and can be used in the next call to
* DDRVBD to continue the same random number sequence.
*
* THRESH (input) DOUBLE PRECISION
* The threshold value for the test ratios. A result is
* included in the output file if RESULT >= THRESH. The test
* ratios are scaled to be O(1), so THRESH should be a small
* multiple of 1, e.g., 10 or 100. To have every test ratio
* printed, use THRESH = 0.
*
* A (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX)
* where NMAX is the maximum value of N in NN.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,MMAX),
* where MMAX is the maximum value of M in MM.
*
* U (workspace) DOUBLE PRECISION array, dimension (LDU,MMAX)
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= max(1,MMAX).
*
* VT (workspace) DOUBLE PRECISION array, dimension (LDVT,NMAX)
*
* LDVT (input) INTEGER
* The leading dimension of the array VT. LDVT >= max(1,NMAX).
*
* ASAV (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX)
*
* USAV (workspace) DOUBLE PRECISION array, dimension (LDU,MMAX)
*
* VTSAV (workspace) DOUBLE PRECISION array, dimension (LDVT,NMAX)
*
* S (workspace) DOUBLE PRECISION array, dimension
* (max(min(MM,NN)))
*
* SSAV (workspace) DOUBLE PRECISION array, dimension
* (max(min(MM,NN)))
*
* E (workspace) DOUBLE PRECISION array, dimension
* (max(min(MM,NN)))
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The number of entries in WORK. This must be at least
* max(3*MN+MX,5*MN-4)+2*MN**2 for all pairs
* pairs (MN,MX)=( min(MM(j),NN(j), max(MM(j),NN(j)) )
*
* IWORK (workspace) INTEGER array, dimension at least 8*min(M,N)
*
* NOUT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns IINFO not equal to 0.)
*
* INFO (output) INTEGER
* If 0, then everything ran OK.
* -1: NSIZES < 0
* -2: Some MM(j) < 0
* -3: Some NN(j) < 0
* -4: NTYPES < 0
* -7: THRESH < 0
* -10: LDA < 1 or LDA < MMAX, where MMAX is max( MM(j) ).
* -12: LDU < 1 or LDU < MMAX.
* -14: LDVT < 1 or LDVT < NMAX, where NMAX is max( NN(j) ).
* -21: LWORK too small.
* If DLATMS, or DGESVD returns an error code, the
* absolute value of it is returned.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 5 )
* ..
* .. Local Scalars ..
LOGICAL BADMM, BADNN
CHARACTER JOBQ, JOBU, JOBVT
CHARACTER*3 PATH
INTEGER I, IINFO, IJQ, IJU, IJVT, IWS, IWTMP, J, JSIZE,
$ JTYPE, LSWORK, M, MINWRK, MMAX, MNMAX, MNMIN,
$ MTYPES, N, NFAIL, NMAX, NTEST
DOUBLE PRECISION ANORM, DIF, DIV, OVFL, ULP, ULPINV, UNFL
* ..
* .. Local Arrays ..
CHARACTER CJOB( 4 )
INTEGER IOLDSD( 4 )
DOUBLE PRECISION RESULT( 14 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL ALASVM, DBDT01, DGESDD, DGESVD, DLABAD, DLACPY,
$ DLASET, DLATMS, DORT01, DORT03, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA CJOB / 'N', 'O', 'S', 'A' /
* ..
* .. Executable Statements ..
*
* Check for errors
*
INFO = 0
BADMM = .FALSE.
BADNN = .FALSE.
MMAX = 1
NMAX = 1
MNMAX = 1
MINWRK = 1
DO 10 J = 1, NSIZES
MMAX = MAX( MMAX, MM( J ) )
IF( MM( J ).LT.0 )
$ BADMM = .TRUE.
NMAX = MAX( NMAX, NN( J ) )
IF( NN( J ).LT.0 )
$ BADNN = .TRUE.
MNMAX = MAX( MNMAX, MIN( MM( J ), NN( J ) ) )
MINWRK = MAX( MINWRK, MAX( 3*MIN( MM( J ),
$ NN( J ) )+MAX( MM( J ), NN( J ) ), 5*MIN( MM( J ),
$ NN( J )-4 ) )+2*MIN( MM( J ), NN( J ) )**2 )
10 CONTINUE
*
* Check for errors
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADMM ) THEN
INFO = -2
ELSE IF( BADNN ) THEN
INFO = -3
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, MMAX ) ) THEN
INFO = -10
ELSE IF( LDU.LT.MAX( 1, MMAX ) ) THEN
INFO = -12
ELSE IF( LDVT.LT.MAX( 1, NMAX ) ) THEN
INFO = -14
ELSE IF( MINWRK.GT.LWORK ) THEN
INFO = -21
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DDRVBD', -INFO )
RETURN
END IF
*
* Initialize constants
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'BD'
NFAIL = 0
NTEST = 0
UNFL = DLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
CALL DLABAD( UNFL, OVFL )
ULP = DLAMCH( 'Precision' )
ULPINV = ONE / ULP
INFOT = 0
*
* Loop over sizes, types
*
DO 150 JSIZE = 1, NSIZES
M = MM( JSIZE )
N = NN( JSIZE )
MNMIN = MIN( M, N )
*
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
DO 140 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 140
*
DO 20 J = 1, 4
IOLDSD( J ) = ISEED( J )
20 CONTINUE
*
* Compute "A"
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 30
*
IF( JTYPE.EQ.1 ) THEN
*
* Zero matrix
*
CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA )
*
ELSE IF( JTYPE.EQ.2 ) THEN
*
* Identity matrix
*
CALL DLASET( 'Full', M, N, ZERO, ONE, A, LDA )
*
ELSE
*
* (Scaled) random matrix
*
IF( JTYPE.EQ.3 )
$ ANORM = ONE
IF( JTYPE.EQ.4 )
$ ANORM = UNFL / ULP
IF( JTYPE.EQ.5 )
$ ANORM = OVFL*ULP
CALL DLATMS( M, N, 'U', ISEED, 'N', S, 4, DBLE( MNMIN ),
$ ANORM, M-1, N-1, 'N', A, LDA, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9996 )'Generator', IINFO, M, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
END IF
*
30 CONTINUE
CALL DLACPY( 'F', M, N, A, LDA, ASAV, LDA )
*
* Do for minimal and adequate (for blocking) workspace
*
DO 130 IWS = 1, 4
*
DO 40 J = 1, 14
RESULT( J ) = -ONE
40 CONTINUE
*
* Test DGESVD: Factorize A
*
IWTMP = MAX( 3*MIN( M, N )+MAX( M, N ), 5*MIN( M, N ) )
LSWORK = IWTMP + ( IWS-1 )*( LWORK-IWTMP ) / 3
LSWORK = MIN( LSWORK, LWORK )
LSWORK = MAX( LSWORK, 1 )
IF( IWS.EQ.4 )
$ LSWORK = LWORK
*
IF( IWS.GT.1 )
$ CALL DLACPY( 'F', M, N, ASAV, LDA, A, LDA )
SRNAMT = 'DGESVD'
CALL DGESVD( 'A', 'A', M, N, A, LDA, SSAV, USAV, LDU,
$ VTSAV, LDVT, WORK, LSWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9995 )'GESVD', IINFO, M, N, JTYPE,
$ LSWORK, IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
* Do tests 1--4
*
CALL DBDT01( M, N, 0, ASAV, LDA, USAV, LDU, SSAV, E,
$ VTSAV, LDVT, WORK, RESULT( 1 ) )
IF( M.NE.0 .AND. N.NE.0 ) THEN
CALL DORT01( 'Columns', M, M, USAV, LDU, WORK, LWORK,
$ RESULT( 2 ) )
CALL DORT01( 'Rows', N, N, VTSAV, LDVT, WORK, LWORK,
$ RESULT( 3 ) )
END IF
RESULT( 4 ) = ZERO
DO 50 I = 1, MNMIN - 1
IF( SSAV( I ).LT.SSAV( I+1 ) )
$ RESULT( 4 ) = ULPINV
IF( SSAV( I ).LT.ZERO )
$ RESULT( 4 ) = ULPINV
50 CONTINUE
IF( MNMIN.GE.1 ) THEN
IF( SSAV( MNMIN ).LT.ZERO )
$ RESULT( 4 ) = ULPINV
END IF
*
* Do partial SVDs, comparing to SSAV, USAV, and VTSAV
*
RESULT( 5 ) = ZERO
RESULT( 6 ) = ZERO
RESULT( 7 ) = ZERO
DO 80 IJU = 0, 3
DO 70 IJVT = 0, 3
IF( ( IJU.EQ.3 .AND. IJVT.EQ.3 ) .OR.
$ ( IJU.EQ.1 .AND. IJVT.EQ.1 ) )GO TO 70
JOBU = CJOB( IJU+1 )
JOBVT = CJOB( IJVT+1 )
CALL DLACPY( 'F', M, N, ASAV, LDA, A, LDA )
SRNAMT = 'DGESVD'
CALL DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU,
$ VT, LDVT, WORK, LSWORK, IINFO )
*
* Compare U
*
DIF = ZERO
IF( M.GT.0 .AND. N.GT.0 ) THEN
IF( IJU.EQ.1 ) THEN
CALL DORT03( 'C', M, MNMIN, M, MNMIN, USAV,
$ LDU, A, LDA, WORK, LWORK, DIF,
$ IINFO )
ELSE IF( IJU.EQ.2 ) THEN
CALL DORT03( 'C', M, MNMIN, M, MNMIN, USAV,
$ LDU, U, LDU, WORK, LWORK, DIF,
$ IINFO )
ELSE IF( IJU.EQ.3 ) THEN
CALL DORT03( 'C', M, M, M, MNMIN, USAV, LDU,
$ U, LDU, WORK, LWORK, DIF,
$ IINFO )
END IF
END IF
RESULT( 5 ) = MAX( RESULT( 5 ), DIF )
*
* Compare VT
*
DIF = ZERO
IF( M.GT.0 .AND. N.GT.0 ) THEN
IF( IJVT.EQ.1 ) THEN
CALL DORT03( 'R', N, MNMIN, N, MNMIN, VTSAV,
$ LDVT, A, LDA, WORK, LWORK, DIF,
$ IINFO )
ELSE IF( IJVT.EQ.2 ) THEN
CALL DORT03( 'R', N, MNMIN, N, MNMIN, VTSAV,
$ LDVT, VT, LDVT, WORK, LWORK,
$ DIF, IINFO )
ELSE IF( IJVT.EQ.3 ) THEN
CALL DORT03( 'R', N, N, N, MNMIN, VTSAV,
$ LDVT, VT, LDVT, WORK, LWORK,
$ DIF, IINFO )
END IF
END IF
RESULT( 6 ) = MAX( RESULT( 6 ), DIF )
*
* Compare S
*
DIF = ZERO
DIV = MAX( DBLE( MNMIN )*ULP*S( 1 ), UNFL )
DO 60 I = 1, MNMIN - 1
IF( SSAV( I ).LT.SSAV( I+1 ) )
$ DIF = ULPINV
IF( SSAV( I ).LT.ZERO )
$ DIF = ULPINV
DIF = MAX( DIF, ABS( SSAV( I )-S( I ) ) / DIV )
60 CONTINUE
RESULT( 7 ) = MAX( RESULT( 7 ), DIF )
70 CONTINUE
80 CONTINUE
*
* Test DGESDD: Factorize A
*
IWTMP = 5*MNMIN*MNMIN + 9*MNMIN + MAX( M, N )
LSWORK = IWTMP + ( IWS-1 )*( LWORK-IWTMP ) / 3
LSWORK = MIN( LSWORK, LWORK )
LSWORK = MAX( LSWORK, 1 )
IF( IWS.EQ.4 )
$ LSWORK = LWORK
*
CALL DLACPY( 'F', M, N, ASAV, LDA, A, LDA )
SRNAMT = 'DGESDD'
CALL DGESDD( 'A', M, N, A, LDA, SSAV, USAV, LDU, VTSAV,
$ LDVT, WORK, LSWORK, IWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUT, FMT = 9995 )'GESDD', IINFO, M, N, JTYPE,
$ LSWORK, IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
* Do tests 8--11
*
CALL DBDT01( M, N, 0, ASAV, LDA, USAV, LDU, SSAV, E,
$ VTSAV, LDVT, WORK, RESULT( 8 ) )
IF( M.NE.0 .AND. N.NE.0 ) THEN
CALL DORT01( 'Columns', M, M, USAV, LDU, WORK, LWORK,
$ RESULT( 9 ) )
CALL DORT01( 'Rows', N, N, VTSAV, LDVT, WORK, LWORK,
$ RESULT( 10 ) )
END IF
RESULT( 11 ) = ZERO
DO 90 I = 1, MNMIN - 1
IF( SSAV( I ).LT.SSAV( I+1 ) )
$ RESULT( 11 ) = ULPINV
IF( SSAV( I ).LT.ZERO )
$ RESULT( 11 ) = ULPINV
90 CONTINUE
IF( MNMIN.GE.1 ) THEN
IF( SSAV( MNMIN ).LT.ZERO )
$ RESULT( 11 ) = ULPINV
END IF
*
* Do partial SVDs, comparing to SSAV, USAV, and VTSAV
*
RESULT( 12 ) = ZERO
RESULT( 13 ) = ZERO
RESULT( 14 ) = ZERO
DO 110 IJQ = 0, 2
JOBQ = CJOB( IJQ+1 )
CALL DLACPY( 'F', M, N, ASAV, LDA, A, LDA )
SRNAMT = 'DGESDD'
CALL DGESDD( JOBQ, M, N, A, LDA, S, U, LDU, VT, LDVT,
$ WORK, LSWORK, IWORK, IINFO )
*
* Compare U
*
DIF = ZERO
IF( M.GT.0 .AND. N.GT.0 ) THEN
IF( IJQ.EQ.1 ) THEN
IF( M.GE.N ) THEN
CALL DORT03( 'C', M, MNMIN, M, MNMIN, USAV,
$ LDU, A, LDA, WORK, LWORK, DIF,
$ INFO )
ELSE
CALL DORT03( 'C', M, MNMIN, M, MNMIN, USAV,
$ LDU, U, LDU, WORK, LWORK, DIF,
$ INFO )
END IF
ELSE IF( IJQ.EQ.2 ) THEN
CALL DORT03( 'C', M, MNMIN, M, MNMIN, USAV, LDU,
$ U, LDU, WORK, LWORK, DIF, INFO )
END IF
END IF
RESULT( 12 ) = MAX( RESULT( 12 ), DIF )
*
* Compare VT
*
DIF = ZERO
IF( M.GT.0 .AND. N.GT.0 ) THEN
IF( IJQ.EQ.1 ) THEN
IF( M.GE.N ) THEN
CALL DORT03( 'R', N, MNMIN, N, MNMIN, VTSAV,
$ LDVT, VT, LDVT, WORK, LWORK,
$ DIF, INFO )
ELSE
CALL DORT03( 'R', N, MNMIN, N, MNMIN, VTSAV,
$ LDVT, A, LDA, WORK, LWORK, DIF,
$ INFO )
END IF
ELSE IF( IJQ.EQ.2 ) THEN
CALL DORT03( 'R', N, MNMIN, N, MNMIN, VTSAV,
$ LDVT, VT, LDVT, WORK, LWORK, DIF,
$ INFO )
END IF
END IF
RESULT( 13 ) = MAX( RESULT( 13 ), DIF )
*
* Compare S
*
DIF = ZERO
DIV = MAX( DBLE( MNMIN )*ULP*S( 1 ), UNFL )
DO 100 I = 1, MNMIN - 1
IF( SSAV( I ).LT.SSAV( I+1 ) )
$ DIF = ULPINV
IF( SSAV( I ).LT.ZERO )
$ DIF = ULPINV
DIF = MAX( DIF, ABS( SSAV( I )-S( I ) ) / DIV )
100 CONTINUE
RESULT( 14 ) = MAX( RESULT( 14 ), DIF )
110 CONTINUE
*
* End of Loop -- Check for RESULT(j) > THRESH
*
DO 120 J = 1, 14
IF( RESULT( J ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 ) THEN
WRITE( NOUT, FMT = 9999 )
WRITE( NOUT, FMT = 9998 )
END IF
WRITE( NOUT, FMT = 9997 )M, N, JTYPE, IWS, IOLDSD,
$ J, RESULT( J )
NFAIL = NFAIL + 1
END IF
120 CONTINUE
NTEST = NTEST + 14
*
130 CONTINUE
140 CONTINUE
150 CONTINUE
*
* Summary
*
CALL ALASVM( PATH, NOUT, NFAIL, NTEST, 0 )
*
9999 FORMAT( ' SVD -- Real Singular Value Decomposition Driver ',
$ / ' Matrix types (see DDRVBD for details):',
$ / / ' 1 = Zero matrix', / ' 2 = Identity matrix',
$ / ' 3 = Evenly spaced singular values near 1',
$ / ' 4 = Evenly spaced singular values near underflow',
$ / ' 5 = Evenly spaced singular values near overflow', / /
$ ' Tests performed: ( A is dense, U and V are orthogonal,',
$ / 19X, ' S is an array, and Upartial, VTpartial, and',
$ / 19X, ' Spartial are partially computed U, VT and S),', / )
9998 FORMAT( ' 1 = | A - U diag(S) VT | / ( |A| max(M,N) ulp ) ',
$ / ' 2 = | I - U**T U | / ( M ulp ) ',
$ / ' 3 = | I - VT VT**T | / ( N ulp ) ',
$ / ' 4 = 0 if S contains min(M,N) nonnegative values in',
$ ' decreasing order, else 1/ulp',
$ / ' 5 = | U - Upartial | / ( M ulp )',
$ / ' 6 = | VT - VTpartial | / ( N ulp )',
$ / ' 7 = | S - Spartial | / ( min(M,N) ulp |S| )',
$ / ' 8 = | A - U diag(S) VT | / ( |A| max(M,N) ulp ) ',
$ / ' 9 = | I - U**T U | / ( M ulp ) ',
$ / '10 = | I - VT VT**T | / ( N ulp ) ',
$ / '11 = 0 if S contains min(M,N) nonnegative values in',
$ ' decreasing order, else 1/ulp',
$ / '12 = | U - Upartial | / ( M ulp )',
$ / '13 = | VT - VTpartial | / ( N ulp )',
$ / '14 = | S - Spartial | / ( min(M,N) ulp |S| )', / / )
9997 FORMAT( ' M=', I5, ', N=', I5, ', type ', I1, ', IWS=', I1,
$ ', seed=', 4( I4, ',' ), ' test(', I2, ')=', G11.4 )
9996 FORMAT( ' DDRVBD: ', A, ' returned INFO=', I6, '.', / 9X, 'M=',
$ I6, ', N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ),
$ I5, ')' )
9995 FORMAT( ' DDRVBD: ', A, ' returned INFO=', I6, '.', / 9X, 'M=',
$ I6, ', N=', I6, ', JTYPE=', I6, ', LSWORK=', I6, / 9X,
$ 'ISEED=(', 3( I5, ',' ), I5, ')' )
*
RETURN
*
* End of DDRVBD
*
END
SUBROUTINE DDRVES( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
$ NOUNIT, A, LDA, H, HT, WR, WI, WRT, WIT, VS,
$ LDVS, RESULT, WORK, NWORK, IWORK, BWORK, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDVS, NOUNIT, NSIZES, NTYPES, NWORK
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL BWORK( * ), DOTYPE( * )
INTEGER ISEED( 4 ), IWORK( * ), NN( * )
DOUBLE PRECISION A( LDA, * ), H( LDA, * ), HT( LDA, * ),
$ RESULT( 13 ), VS( LDVS, * ), WI( * ), WIT( * ),
$ WORK( * ), WR( * ), WRT( * )
* ..
*
* Purpose
* =======
*
* DDRVES checks the nonsymmetric eigenvalue (Schur form) problem
* driver DGEES.
*
* When DDRVES is called, a number of matrix "sizes" ("n's") and a
* number of matrix "types" are specified. For each size ("n")
* and each type of matrix, one matrix will be generated and used
* to test the nonsymmetric eigenroutines. For each matrix, 13
* tests will be performed:
*
* (1) 0 if T is in Schur form, 1/ulp otherwise
* (no sorting of eigenvalues)
*
* (2) | A - VS T VS' | / ( n |A| ulp )
*
* Here VS is the matrix of Schur eigenvectors, and T is in Schur
* form (no sorting of eigenvalues).
*
* (3) | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues).
*
* (4) 0 if WR+sqrt(-1)*WI are eigenvalues of T
* 1/ulp otherwise
* (no sorting of eigenvalues)
*
* (5) 0 if T(with VS) = T(without VS),
* 1/ulp otherwise
* (no sorting of eigenvalues)
*
* (6) 0 if eigenvalues(with VS) = eigenvalues(without VS),
* 1/ulp otherwise
* (no sorting of eigenvalues)
*
* (7) 0 if T is in Schur form, 1/ulp otherwise
* (with sorting of eigenvalues)
*
* (8) | A - VS T VS' | / ( n |A| ulp )
*
* Here VS is the matrix of Schur eigenvectors, and T is in Schur
* form (with sorting of eigenvalues).
*
* (9) | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues).
*
* (10) 0 if WR+sqrt(-1)*WI are eigenvalues of T
* 1/ulp otherwise
* (with sorting of eigenvalues)
*
* (11) 0 if T(with VS) = T(without VS),
* 1/ulp otherwise
* (with sorting of eigenvalues)
*
* (12) 0 if eigenvalues(with VS) = eigenvalues(without VS),
* 1/ulp otherwise
* (with sorting of eigenvalues)
*
* (13) if sorting worked and SDIM is the number of
* eigenvalues which were SELECTed
*
* The "sizes" are specified by an array NN(1:NSIZES); the value of
* each element NN(j) specifies one size.
* The "types" are specified by a logical array DOTYPE( 1:NTYPES );
* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
* Currently, the list of possible types is:
*
* (1) The zero matrix.
* (2) The identity matrix.
* (3) A (transposed) Jordan block, with 1's on the diagonal.
*
* (4) A diagonal matrix with evenly spaced entries
* 1, ..., ULP and random signs.
* (ULP = (first number larger than 1) - 1 )
* (5) A diagonal matrix with geometrically spaced entries
* 1, ..., ULP and random signs.
* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
* and random signs.
*
* (7) Same as (4), but multiplied by a constant near
* the overflow threshold
* (8) Same as (4), but multiplied by a constant near
* the underflow threshold
*
* (9) A matrix of the form U' T U, where U is orthogonal and
* T has evenly spaced entries 1, ..., ULP with random signs
* on the diagonal and random O(1) entries in the upper
* triangle.
*
* (10) A matrix of the form U' T U, where U is orthogonal and
* T has geometrically spaced entries 1, ..., ULP with random
* signs on the diagonal and random O(1) entries in the upper
* triangle.
*
* (11) A matrix of the form U' T U, where U is orthogonal and
* T has "clustered" entries 1, ULP,..., ULP with random
* signs on the diagonal and random O(1) entries in the upper
* triangle.
*
* (12) A matrix of the form U' T U, where U is orthogonal and
* T has real or complex conjugate paired eigenvalues randomly
* chosen from ( ULP, 1 ) and random O(1) entries in the upper
* triangle.
*
* (13) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP
* with random signs on the diagonal and random O(1) entries
* in the upper triangle.
*
* (14) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has geometrically spaced entries
* 1, ..., ULP with random signs on the diagonal and random
* O(1) entries in the upper triangle.
*
* (15) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP
* with random signs on the diagonal and random O(1) entries
* in the upper triangle.
*
* (16) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has real or complex conjugate paired
* eigenvalues randomly chosen from ( ULP, 1 ) and random
* O(1) entries in the upper triangle.
*
* (17) Same as (16), but multiplied by a constant
* near the overflow threshold
* (18) Same as (16), but multiplied by a constant
* near the underflow threshold
*
* (19) Nonsymmetric matrix with random entries chosen from (-1,1).
* If N is at least 4, all entries in first two rows and last
* row, and first column and last two columns are zero.
* (20) Same as (19), but multiplied by a constant
* near the overflow threshold
* (21) Same as (19), but multiplied by a constant
* near the underflow threshold
*
* Arguments
* =========
*
* NSIZES (input) INTEGER
* The number of sizes of matrices to use. If it is zero,
* DDRVES does nothing. It must be at least zero.
*
* NN (input) INTEGER array, dimension (NSIZES)
* An array containing the sizes to be used for the matrices.
* Zero values will be skipped. The values must be at least
* zero.
*
* NTYPES (input) INTEGER
* The number of elements in DOTYPE. If it is zero, DDRVES
* does nothing. It must be at least zero. If it is MAXTYP+1
* and NSIZES is 1, then an additional type, MAXTYP+1 is
* defined, which is to use whatever matrix is in A. This
* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
* DOTYPE(MAXTYP+1) is .TRUE. .
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* If DOTYPE(j) is .TRUE., then for each size in NN a
* matrix of that size and of type j will be generated.
* If NTYPES is smaller than the maximum number of types
* defined (PARAMETER MAXTYP), then types NTYPES+1 through
* MAXTYP will not be generated. If NTYPES is larger
* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
* will be ignored.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The array elements should be between 0 and 4095;
* if not they will be reduced mod 4096. Also, ISEED(4) must
* be odd. The random number generator uses a linear
* congruential sequence limited to small integers, and so
* should produce machine independent random numbers. The
* values of ISEED are changed on exit, and can be used in the
* next call to DDRVES to continue the same random number
* sequence.
*
* THRESH (input) DOUBLE PRECISION
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error
* is scaled to be O(1), so THRESH should be a reasonably
* small multiple of 1, e.g., 10 or 100. In particular,
* it should not depend on the precision (single vs. double)
* or the size of the matrix. It must be at least zero.
*
* NOUNIT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns INFO not equal to 0.)
*
* A (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
* Used to hold the matrix whose eigenvalues are to be
* computed. On exit, A contains the last matrix actually used.
*
* LDA (input) INTEGER
* The leading dimension of A, and H. LDA must be at
* least 1 and at least max(NN).
*
* H (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
* Another copy of the test matrix A, modified by DGEES.
*
* HT (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
* Yet another copy of the test matrix A, modified by DGEES.
*
* WR (workspace) DOUBLE PRECISION array, dimension (max(NN))
* WI (workspace) DOUBLE PRECISION array, dimension (max(NN))
* The real and imaginary parts of the eigenvalues of A.
* On exit, WR + WI*i are the eigenvalues of the matrix in A.
*
* WRT (workspace) DOUBLE PRECISION array, dimension (max(NN))
* WIT (workspace) DOUBLE PRECISION array, dimension (max(NN))
* Like WR, WI, these arrays contain the eigenvalues of A,
* but those computed when DGEES only computes a partial
* eigendecomposition, i.e. not Schur vectors
*
* VS (workspace) DOUBLE PRECISION array, dimension (LDVS, max(NN))
* VS holds the computed Schur vectors.
*
* LDVS (input) INTEGER
* Leading dimension of VS. Must be at least max(1,max(NN)).
*
* RESULT (output) DOUBLE PRECISION array, dimension (13)
* The values computed by the 13 tests described above.
* The values are currently limited to 1/ulp, to avoid overflow.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (NWORK)
*
* NWORK (input) INTEGER
* The number of entries in WORK. This must be at least
* 5*NN(j)+2*NN(j)**2 for all j.
*
* IWORK (workspace) INTEGER array, dimension (max(NN))
*
* INFO (output) INTEGER
* If 0, then everything ran OK.
* -1: NSIZES < 0
* -2: Some NN(j) < 0
* -3: NTYPES < 0
* -6: THRESH < 0
* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
* -17: LDVS < 1 or LDVS < NMAX, where NMAX is max( NN(j) ).
* -20: NWORK too small.
* If DLATMR, SLATMS, SLATME or DGEES returns an error code,
* the absolute value of it is returned.
*
*-----------------------------------------------------------------------
*
* Some Local Variables and Parameters:
* ---- ----- --------- --- ----------
*
* ZERO, ONE Real 0 and 1.
* MAXTYP The number of types defined.
* NMAX Largest value in NN.
* NERRS The number of tests which have exceeded THRESH
* COND, CONDS,
* IMODE Values to be passed to the matrix generators.
* ANORM Norm of A; passed to matrix generators.
*
* OVFL, UNFL Overflow and underflow thresholds.
* ULP, ULPINV Finest relative precision and its inverse.
* RTULP, RTULPI Square roots of the previous 4 values.
*
* The following four arrays decode JTYPE:
* KTYPE(j) The general type (1-10) for type "j".
* KMODE(j) The MODE value to be passed to the matrix
* generator for type "j".
* KMAGN(j) The order of magnitude ( O(1),
* O(overflow^(1/2) ), O(underflow^(1/2) )
* KCONDS(j) Selectw whether CONDS is to be 1 or
* 1/sqrt(ulp). (0 means irrelevant.)
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 21 )
* ..
* .. Local Scalars ..
LOGICAL BADNN
CHARACTER SORT
CHARACTER*3 PATH
INTEGER I, IINFO, IMODE, ISORT, ITYPE, IWK, J, JCOL,
$ JSIZE, JTYPE, KNTEIG, LWORK, MTYPES, N, NERRS,
$ NFAIL, NMAX, NNWORK, NTEST, NTESTF, NTESTT,
$ RSUB, SDIM
DOUBLE PRECISION ANORM, COND, CONDS, OVFL, RTULP, RTULPI, TMP,
$ ULP, ULPINV, UNFL
* ..
* .. Local Arrays ..
CHARACTER ADUMMA( 1 )
INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( MAXTYP ),
$ KMAGN( MAXTYP ), KMODE( MAXTYP ),
$ KTYPE( MAXTYP )
DOUBLE PRECISION RES( 2 )
* ..
* .. Arrays in Common ..
LOGICAL SELVAL( 20 )
DOUBLE PRECISION SELWI( 20 ), SELWR( 20 )
* ..
* .. Scalars in Common ..
INTEGER SELDIM, SELOPT
* ..
* .. Common blocks ..
COMMON / SSLCT / SELOPT, SELDIM, SELVAL, SELWR, SELWI
* ..
* .. External Functions ..
LOGICAL DSLECT
DOUBLE PRECISION DLAMCH
EXTERNAL DSLECT, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DGEES, DHST01, DLABAD, DLACPY, DLASET, DLASUM,
$ DLATME, DLATMR, DLATMS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SIGN, SQRT
* ..
* .. Data statements ..
DATA KTYPE / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
DATA KMAGN / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
$ 3, 1, 2, 3 /
DATA KMODE / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
$ 1, 5, 5, 5, 4, 3, 1 /
DATA KCONDS / 3*0, 5*0, 4*1, 6*2, 3*0 /
* ..
* .. Executable Statements ..
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'ES'
*
* Check for errors
*
NTESTT = 0
NTESTF = 0
INFO = 0
SELOPT = 0
*
* Important constants
*
BADNN = .FALSE.
NMAX = 0
DO 10 J = 1, NSIZES
NMAX = MAX( NMAX, NN( J ) )
IF( NN( J ).LT.0 )
$ BADNN = .TRUE.
10 CONTINUE
*
* Check for errors
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADNN ) THEN
INFO = -2
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -3
ELSE IF( THRESH.LT.ZERO ) THEN
INFO = -6
ELSE IF( NOUNIT.LE.0 ) THEN
INFO = -7
ELSE IF( LDA.LT.1 .OR. LDA.LT.NMAX ) THEN
INFO = -9
ELSE IF( LDVS.LT.1 .OR. LDVS.LT.NMAX ) THEN
INFO = -17
ELSE IF( 5*NMAX+2*NMAX**2.GT.NWORK ) THEN
INFO = -20
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DDRVES', -INFO )
RETURN
END IF
*
* Quick return if nothing to do
*
IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
$ RETURN
*
* More Important constants
*
UNFL = DLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
CALL DLABAD( UNFL, OVFL )
ULP = DLAMCH( 'Precision' )
ULPINV = ONE / ULP
RTULP = SQRT( ULP )
RTULPI = ONE / RTULP
*
* Loop over sizes, types
*
NERRS = 0
*
DO 270 JSIZE = 1, NSIZES
N = NN( JSIZE )
MTYPES = MAXTYP
IF( NSIZES.EQ.1 .AND. NTYPES.EQ.MAXTYP+1 )
$ MTYPES = MTYPES + 1
*
DO 260 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 260
*
* Save ISEED in case of an error.
*
DO 20 J = 1, 4
IOLDSD( J ) = ISEED( J )
20 CONTINUE
*
* Compute "A"
*
* Control parameters:
*
* KMAGN KCONDS KMODE KTYPE
* =1 O(1) 1 clustered 1 zero
* =2 large large clustered 2 identity
* =3 small exponential Jordan
* =4 arithmetic diagonal, (w/ eigenvalues)
* =5 random log symmetric, w/ eigenvalues
* =6 random general, w/ eigenvalues
* =7 random diagonal
* =8 random symmetric
* =9 random general
* =10 random triangular
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 90
*
ITYPE = KTYPE( JTYPE )
IMODE = KMODE( JTYPE )
*
* Compute norm
*
GO TO ( 30, 40, 50 )KMAGN( JTYPE )
*
30 CONTINUE
ANORM = ONE
GO TO 60
*
40 CONTINUE
ANORM = OVFL*ULP
GO TO 60
*
50 CONTINUE
ANORM = UNFL*ULPINV
GO TO 60
*
60 CONTINUE
*
CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
IINFO = 0
COND = ULPINV
*
* Special Matrices -- Identity & Jordan block
*
* Zero
*
IF( ITYPE.EQ.1 ) THEN
IINFO = 0
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Identity
*
DO 70 JCOL = 1, N
A( JCOL, JCOL ) = ANORM
70 CONTINUE
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* Jordan Block
*
DO 80 JCOL = 1, N
A( JCOL, JCOL ) = ANORM
IF( JCOL.GT.1 )
$ A( JCOL, JCOL-1 ) = ONE
80 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Diagonal Matrix, [Eigen]values Specified
*
CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.5 ) THEN
*
* Symmetric, eigenvalues specified
*
CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, N, N, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.6 ) THEN
*
* General, eigenvalues specified
*
IF( KCONDS( JTYPE ).EQ.1 ) THEN
CONDS = ONE
ELSE IF( KCONDS( JTYPE ).EQ.2 ) THEN
CONDS = RTULPI
ELSE
CONDS = ZERO
END IF
*
ADUMMA( 1 ) = ' '
CALL DLATME( N, 'S', ISEED, WORK, IMODE, COND, ONE,
$ ADUMMA, 'T', 'T', 'T', WORK( N+1 ), 4,
$ CONDS, N, N, ANORM, A, LDA, WORK( 2*N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.7 ) THEN
*
* Diagonal, random eigenvalues
*
CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.8 ) THEN
*
* Symmetric, random eigenvalues
*
CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.9 ) THEN
*
* General, random eigenvalues
*
CALL DLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
IF( N.GE.4 ) THEN
CALL DLASET( 'Full', 2, N, ZERO, ZERO, A, LDA )
CALL DLASET( 'Full', N-3, 1, ZERO, ZERO, A( 3, 1 ),
$ LDA )
CALL DLASET( 'Full', N-3, 2, ZERO, ZERO, A( 3, N-1 ),
$ LDA )
CALL DLASET( 'Full', 1, N, ZERO, ZERO, A( N, 1 ),
$ LDA )
END IF
*
ELSE IF( ITYPE.EQ.10 ) THEN
*
* Triangular, random eigenvalues
*
CALL DLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, 0,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE
*
IINFO = 1
END IF
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9992 )'Generator', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
90 CONTINUE
*
* Test for minimal and generous workspace
*
DO 250 IWK = 1, 2
IF( IWK.EQ.1 ) THEN
NNWORK = 3*N
ELSE
NNWORK = 5*N + 2*N**2
END IF
NNWORK = MAX( NNWORK, 1 )
*
* Initialize RESULT
*
DO 100 J = 1, 13
RESULT( J ) = -ONE
100 CONTINUE
*
* Test with and without sorting of eigenvalues
*
DO 210 ISORT = 0, 1
IF( ISORT.EQ.0 ) THEN
SORT = 'N'
RSUB = 0
ELSE
SORT = 'S'
RSUB = 6
END IF
*
* Compute Schur form and Schur vectors, and test them
*
CALL DLACPY( 'F', N, N, A, LDA, H, LDA )
CALL DGEES( 'V', SORT, DSLECT, N, H, LDA, SDIM, WR,
$ WI, VS, LDVS, WORK, NNWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 1+RSUB ) = ULPINV
WRITE( NOUNIT, FMT = 9992 )'DGEES1', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
GO TO 220
END IF
*
* Do Test (1) or Test (7)
*
RESULT( 1+RSUB ) = ZERO
DO 120 J = 1, N - 2
DO 110 I = J + 2, N
IF( H( I, J ).NE.ZERO )
$ RESULT( 1+RSUB ) = ULPINV
110 CONTINUE
120 CONTINUE
DO 130 I = 1, N - 2
IF( H( I+1, I ).NE.ZERO .AND. H( I+2, I+1 ).NE.
$ ZERO )RESULT( 1+RSUB ) = ULPINV
130 CONTINUE
DO 140 I = 1, N - 1
IF( H( I+1, I ).NE.ZERO ) THEN
IF( H( I, I ).NE.H( I+1, I+1 ) .OR.
$ H( I, I+1 ).EQ.ZERO .OR.
$ SIGN( ONE, H( I+1, I ) ).EQ.
$ SIGN( ONE, H( I, I+1 ) ) )RESULT( 1+RSUB )
$ = ULPINV
END IF
140 CONTINUE
*
* Do Tests (2) and (3) or Tests (8) and (9)
*
LWORK = MAX( 1, 2*N*N )
CALL DHST01( N, 1, N, A, LDA, H, LDA, VS, LDVS, WORK,
$ LWORK, RES )
RESULT( 2+RSUB ) = RES( 1 )
RESULT( 3+RSUB ) = RES( 2 )
*
* Do Test (4) or Test (10)
*
RESULT( 4+RSUB ) = ZERO
DO 150 I = 1, N
IF( H( I, I ).NE.WR( I ) )
$ RESULT( 4+RSUB ) = ULPINV
150 CONTINUE
IF( N.GT.1 ) THEN
IF( H( 2, 1 ).EQ.ZERO .AND. WI( 1 ).NE.ZERO )
$ RESULT( 4+RSUB ) = ULPINV
IF( H( N, N-1 ).EQ.ZERO .AND. WI( N ).NE.ZERO )
$ RESULT( 4+RSUB ) = ULPINV
END IF
DO 160 I = 1, N - 1
IF( H( I+1, I ).NE.ZERO ) THEN
TMP = SQRT( ABS( H( I+1, I ) ) )*
$ SQRT( ABS( H( I, I+1 ) ) )
RESULT( 4+RSUB ) = MAX( RESULT( 4+RSUB ),
$ ABS( WI( I )-TMP ) /
$ MAX( ULP*TMP, UNFL ) )
RESULT( 4+RSUB ) = MAX( RESULT( 4+RSUB ),
$ ABS( WI( I+1 )+TMP ) /
$ MAX( ULP*TMP, UNFL ) )
ELSE IF( I.GT.1 ) THEN
IF( H( I+1, I ).EQ.ZERO .AND. H( I, I-1 ).EQ.
$ ZERO .AND. WI( I ).NE.ZERO )RESULT( 4+RSUB )
$ = ULPINV
END IF
160 CONTINUE
*
* Do Test (5) or Test (11)
*
CALL DLACPY( 'F', N, N, A, LDA, HT, LDA )
CALL DGEES( 'N', SORT, DSLECT, N, HT, LDA, SDIM, WRT,
$ WIT, VS, LDVS, WORK, NNWORK, BWORK,
$ IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 5+RSUB ) = ULPINV
WRITE( NOUNIT, FMT = 9992 )'DGEES2', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
GO TO 220
END IF
*
RESULT( 5+RSUB ) = ZERO
DO 180 J = 1, N
DO 170 I = 1, N
IF( H( I, J ).NE.HT( I, J ) )
$ RESULT( 5+RSUB ) = ULPINV
170 CONTINUE
180 CONTINUE
*
* Do Test (6) or Test (12)
*
RESULT( 6+RSUB ) = ZERO
DO 190 I = 1, N
IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
$ RESULT( 6+RSUB ) = ULPINV
190 CONTINUE
*
* Do Test (13)
*
IF( ISORT.EQ.1 ) THEN
RESULT( 13 ) = ZERO
KNTEIG = 0
DO 200 I = 1, N
IF( DSLECT( WR( I ), WI( I ) ) .OR.
$ DSLECT( WR( I ), -WI( I ) ) )
$ KNTEIG = KNTEIG + 1
IF( I.LT.N ) THEN
IF( ( DSLECT( WR( I+1 ),
$ WI( I+1 ) ) .OR. DSLECT( WR( I+1 ),
$ -WI( I+1 ) ) ) .AND.
$ ( .NOT.( DSLECT( WR( I ),
$ WI( I ) ) .OR. DSLECT( WR( I ),
$ -WI( I ) ) ) ) .AND. IINFO.NE.N+2 )
$ RESULT( 13 ) = ULPINV
END IF
200 CONTINUE
IF( SDIM.NE.KNTEIG ) THEN
RESULT( 13 ) = ULPINV
END IF
END IF
*
210 CONTINUE
*
* End of Loop -- Check for RESULT(j) > THRESH
*
220 CONTINUE
*
NTEST = 0
NFAIL = 0
DO 230 J = 1, 13
IF( RESULT( J ).GE.ZERO )
$ NTEST = NTEST + 1
IF( RESULT( J ).GE.THRESH )
$ NFAIL = NFAIL + 1
230 CONTINUE
*
IF( NFAIL.GT.0 )
$ NTESTF = NTESTF + 1
IF( NTESTF.EQ.1 ) THEN
WRITE( NOUNIT, FMT = 9999 )PATH
WRITE( NOUNIT, FMT = 9998 )
WRITE( NOUNIT, FMT = 9997 )
WRITE( NOUNIT, FMT = 9996 )
WRITE( NOUNIT, FMT = 9995 )THRESH
WRITE( NOUNIT, FMT = 9994 )
NTESTF = 2
END IF
*
DO 240 J = 1, 13
IF( RESULT( J ).GE.THRESH ) THEN
WRITE( NOUNIT, FMT = 9993 )N, IWK, IOLDSD, JTYPE,
$ J, RESULT( J )
END IF
240 CONTINUE
*
NERRS = NERRS + NFAIL
NTESTT = NTESTT + NTEST
*
250 CONTINUE
260 CONTINUE
270 CONTINUE
*
* Summary
*
CALL DLASUM( PATH, NOUNIT, NERRS, NTESTT )
*
9999 FORMAT( / 1X, A3, ' -- Real Schur Form Decomposition Driver',
$ / ' Matrix types (see DDRVES for details): ' )
*
9998 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ',
$ ' ', ' 5=Diagonal: geometr. spaced entries.',
$ / ' 2=Identity matrix. ', ' 6=Diagona',
$ 'l: clustered entries.', / ' 3=Transposed Jordan block. ',
$ ' ', ' 7=Diagonal: large, evenly spaced.', / ' ',
$ '4=Diagonal: evenly spaced entries. ', ' 8=Diagonal: s',
$ 'mall, evenly spaced.' )
9997 FORMAT( ' Dense, Non-Symmetric Matrices:', / ' 9=Well-cond., ev',
$ 'enly spaced eigenvals.', ' 14=Ill-cond., geomet. spaced e',
$ 'igenals.', / ' 10=Well-cond., geom. spaced eigenvals. ',
$ ' 15=Ill-conditioned, clustered e.vals.', / ' 11=Well-cond',
$ 'itioned, clustered e.vals. ', ' 16=Ill-cond., random comp',
$ 'lex ', / ' 12=Well-cond., random complex ', 6X, ' ',
$ ' 17=Ill-cond., large rand. complx ', / ' 13=Ill-condi',
$ 'tioned, evenly spaced. ', ' 18=Ill-cond., small rand.',
$ ' complx ' )
9996 FORMAT( ' 19=Matrix with random O(1) entries. ', ' 21=Matrix ',
$ 'with small random entries.', / ' 20=Matrix with large ran',
$ 'dom entries. ', / )
9995 FORMAT( ' Tests performed with test threshold =', F8.2,
$ / ' ( A denotes A on input and T denotes A on output)',
$ / / ' 1 = 0 if T in Schur form (no sort), ',
$ ' 1/ulp otherwise', /
$ ' 2 = | A - VS T transpose(VS) | / ( n |A| ulp ) (no sort)',
$ / ' 3 = | I - VS transpose(VS) | / ( n ulp ) (no sort) ', /
$ ' 4 = 0 if WR+sqrt(-1)*WI are eigenvalues of T (no sort),',
$ ' 1/ulp otherwise', /
$ ' 5 = 0 if T same no matter if VS computed (no sort),',
$ ' 1/ulp otherwise', /
$ ' 6 = 0 if WR, WI same no matter if VS computed (no sort)',
$ ', 1/ulp otherwise' )
9994 FORMAT( ' 7 = 0 if T in Schur form (sort), ', ' 1/ulp otherwise',
$ / ' 8 = | A - VS T transpose(VS) | / ( n |A| ulp ) (sort)',
$ / ' 9 = | I - VS transpose(VS) | / ( n ulp ) (sort) ',
$ / ' 10 = 0 if WR+sqrt(-1)*WI are eigenvalues of T (sort),',
$ ' 1/ulp otherwise', /
$ ' 11 = 0 if T same no matter if VS computed (sort),',
$ ' 1/ulp otherwise', /
$ ' 12 = 0 if WR, WI same no matter if VS computed (sort),',
$ ' 1/ulp otherwise', /
$ ' 13 = 0 if sorting succesful, 1/ulp otherwise', / )
9993 FORMAT( ' N=', I5, ', IWK=', I2, ', seed=', 4( I4, ',' ),
$ ' type ', I2, ', test(', I2, ')=', G10.3 )
9992 FORMAT( ' DDRVES: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
*
RETURN
*
* End of DDRVES
*
END
SUBROUTINE DDRVEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
$ NOUNIT, A, LDA, H, WR, WI, WR1, WI1, VL, LDVL,
$ VR, LDVR, LRE, LDLRE, RESULT, WORK, NWORK,
$ IWORK, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NOUNIT, NSIZES,
$ NTYPES, NWORK
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER ISEED( 4 ), IWORK( * ), NN( * )
DOUBLE PRECISION A( LDA, * ), H( LDA, * ), LRE( LDLRE, * ),
$ RESULT( 7 ), VL( LDVL, * ), VR( LDVR, * ),
$ WI( * ), WI1( * ), WORK( * ), WR( * ), WR1( * )
* ..
*
* Purpose
* =======
*
* DDRVEV checks the nonsymmetric eigenvalue problem driver DGEEV.
*
* When DDRVEV is called, a number of matrix "sizes" ("n's") and a
* number of matrix "types" are specified. For each size ("n")
* and each type of matrix, one matrix will be generated and used
* to test the nonsymmetric eigenroutines. For each matrix, 7
* tests will be performed:
*
* (1) | A * VR - VR * W | / ( n |A| ulp )
*
* Here VR is the matrix of unit right eigenvectors.
* W is a block diagonal matrix, with a 1x1 block for each
* real eigenvalue and a 2x2 block for each complex conjugate
* pair. If eigenvalues j and j+1 are a complex conjugate pair,
* so WR(j) = WR(j+1) = wr and WI(j) = - WI(j+1) = wi, then the
* 2 x 2 block corresponding to the pair will be:
*
* ( wr wi )
* ( -wi wr )
*
* Such a block multiplying an n x 2 matrix ( ur ui ) on the
* right will be the same as multiplying ur + i*ui by wr + i*wi.
*
* (2) | A**H * VL - VL * W**H | / ( n |A| ulp )
*
* Here VL is the matrix of unit left eigenvectors, A**H is the
* conjugate transpose of A, and W is as above.
*
* (3) | |VR(i)| - 1 | / ulp and whether largest component real
*
* VR(i) denotes the i-th column of VR.
*
* (4) | |VL(i)| - 1 | / ulp and whether largest component real
*
* VL(i) denotes the i-th column of VL.
*
* (5) W(full) = W(partial)
*
* W(full) denotes the eigenvalues computed when both VR and VL
* are also computed, and W(partial) denotes the eigenvalues
* computed when only W, only W and VR, or only W and VL are
* computed.
*
* (6) VR(full) = VR(partial)
*
* VR(full) denotes the right eigenvectors computed when both VR
* and VL are computed, and VR(partial) denotes the result
* when only VR is computed.
*
* (7) VL(full) = VL(partial)
*
* VL(full) denotes the left eigenvectors computed when both VR
* and VL are also computed, and VL(partial) denotes the result
* when only VL is computed.
*
* The "sizes" are specified by an array NN(1:NSIZES); the value of
* each element NN(j) specifies one size.
* The "types" are specified by a logical array DOTYPE( 1:NTYPES );
* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
* Currently, the list of possible types is:
*
* (1) The zero matrix.
* (2) The identity matrix.
* (3) A (transposed) Jordan block, with 1's on the diagonal.
*
* (4) A diagonal matrix with evenly spaced entries
* 1, ..., ULP and random signs.
* (ULP = (first number larger than 1) - 1 )
* (5) A diagonal matrix with geometrically spaced entries
* 1, ..., ULP and random signs.
* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
* and random signs.
*
* (7) Same as (4), but multiplied by a constant near
* the overflow threshold
* (8) Same as (4), but multiplied by a constant near
* the underflow threshold
*
* (9) A matrix of the form U' T U, where U is orthogonal and
* T has evenly spaced entries 1, ..., ULP with random signs
* on the diagonal and random O(1) entries in the upper
* triangle.
*
* (10) A matrix of the form U' T U, where U is orthogonal and
* T has geometrically spaced entries 1, ..., ULP with random
* signs on the diagonal and random O(1) entries in the upper
* triangle.
*
* (11) A matrix of the form U' T U, where U is orthogonal and
* T has "clustered" entries 1, ULP,..., ULP with random
* signs on the diagonal and random O(1) entries in the upper
* triangle.
*
* (12) A matrix of the form U' T U, where U is orthogonal and
* T has real or complex conjugate paired eigenvalues randomly
* chosen from ( ULP, 1 ) and random O(1) entries in the upper
* triangle.
*
* (13) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP
* with random signs on the diagonal and random O(1) entries
* in the upper triangle.
*
* (14) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has geometrically spaced entries
* 1, ..., ULP with random signs on the diagonal and random
* O(1) entries in the upper triangle.
*
* (15) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP
* with random signs on the diagonal and random O(1) entries
* in the upper triangle.
*
* (16) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has real or complex conjugate paired
* eigenvalues randomly chosen from ( ULP, 1 ) and random
* O(1) entries in the upper triangle.
*
* (17) Same as (16), but multiplied by a constant
* near the overflow threshold
* (18) Same as (16), but multiplied by a constant
* near the underflow threshold
*
* (19) Nonsymmetric matrix with random entries chosen from (-1,1).
* If N is at least 4, all entries in first two rows and last
* row, and first column and last two columns are zero.
* (20) Same as (19), but multiplied by a constant
* near the overflow threshold
* (21) Same as (19), but multiplied by a constant
* near the underflow threshold
*
* Arguments
* ==========
*
* NSIZES (input) INTEGER
* The number of sizes of matrices to use. If it is zero,
* DDRVEV does nothing. It must be at least zero.
*
* NN (input) INTEGER array, dimension (NSIZES)
* An array containing the sizes to be used for the matrices.
* Zero values will be skipped. The values must be at least
* zero.
*
* NTYPES (input) INTEGER
* The number of elements in DOTYPE. If it is zero, DDRVEV
* does nothing. It must be at least zero. If it is MAXTYP+1
* and NSIZES is 1, then an additional type, MAXTYP+1 is
* defined, which is to use whatever matrix is in A. This
* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
* DOTYPE(MAXTYP+1) is .TRUE. .
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* If DOTYPE(j) is .TRUE., then for each size in NN a
* matrix of that size and of type j will be generated.
* If NTYPES is smaller than the maximum number of types
* defined (PARAMETER MAXTYP), then types NTYPES+1 through
* MAXTYP will not be generated. If NTYPES is larger
* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
* will be ignored.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The array elements should be between 0 and 4095;
* if not they will be reduced mod 4096. Also, ISEED(4) must
* be odd. The random number generator uses a linear
* congruential sequence limited to small integers, and so
* should produce machine independent random numbers. The
* values of ISEED are changed on exit, and can be used in the
* next call to DDRVEV to continue the same random number
* sequence.
*
* THRESH (input) DOUBLE PRECISION
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error
* is scaled to be O(1), so THRESH should be a reasonably
* small multiple of 1, e.g., 10 or 100. In particular,
* it should not depend on the precision (single vs. double)
* or the size of the matrix. It must be at least zero.
*
* NOUNIT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns INFO not equal to 0.)
*
* A (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
* Used to hold the matrix whose eigenvalues are to be
* computed. On exit, A contains the last matrix actually used.
*
* LDA (input) INTEGER
* The leading dimension of A, and H. LDA must be at
* least 1 and at least max(NN).
*
* H (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
* Another copy of the test matrix A, modified by DGEEV.
*
* WR (workspace) DOUBLE PRECISION array, dimension (max(NN))
* WI (workspace) DOUBLE PRECISION array, dimension (max(NN))
* The real and imaginary parts of the eigenvalues of A.
* On exit, WR + WI*i are the eigenvalues of the matrix in A.
*
* WR1 (workspace) DOUBLE PRECISION array, dimension (max(NN))
* WI1 (workspace) DOUBLE PRECISION array, dimension (max(NN))
* Like WR, WI, these arrays contain the eigenvalues of A,
* but those computed when DGEEV only computes a partial
* eigendecomposition, i.e. not the eigenvalues and left
* and right eigenvectors.
*
* VL (workspace) DOUBLE PRECISION array, dimension (LDVL, max(NN))
* VL holds the computed left eigenvectors.
*
* LDVL (input) INTEGER
* Leading dimension of VL. Must be at least max(1,max(NN)).
*
* VR (workspace) DOUBLE PRECISION array, dimension (LDVR, max(NN))
* VR holds the computed right eigenvectors.
*
* LDVR (input) INTEGER
* Leading dimension of VR. Must be at least max(1,max(NN)).
*
* LRE (workspace) DOUBLE PRECISION array, dimension (LDLRE,max(NN))
* LRE holds the computed right or left eigenvectors.
*
* LDLRE (input) INTEGER
* Leading dimension of LRE. Must be at least max(1,max(NN)).
*
* RESULT (output) DOUBLE PRECISION array, dimension (7)
* The values computed by the seven tests described above.
* The values are currently limited to 1/ulp, to avoid overflow.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (NWORK)
*
* NWORK (input) INTEGER
* The number of entries in WORK. This must be at least
* 5*NN(j)+2*NN(j)**2 for all j.
*
* IWORK (workspace) INTEGER array, dimension (max(NN))
*
* INFO (output) INTEGER
* If 0, then everything ran OK.
* -1: NSIZES < 0
* -2: Some NN(j) < 0
* -3: NTYPES < 0
* -6: THRESH < 0
* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
* -16: LDVL < 1 or LDVL < NMAX, where NMAX is max( NN(j) ).
* -18: LDVR < 1 or LDVR < NMAX, where NMAX is max( NN(j) ).
* -20: LDLRE < 1 or LDLRE < NMAX, where NMAX is max( NN(j) ).
* -23: NWORK too small.
* If DLATMR, SLATMS, SLATME or DGEEV returns an error code,
* the absolute value of it is returned.
*
*-----------------------------------------------------------------------
*
* Some Local Variables and Parameters:
* ---- ----- --------- --- ----------
*
* ZERO, ONE Real 0 and 1.
* MAXTYP The number of types defined.
* NMAX Largest value in NN.
* NERRS The number of tests which have exceeded THRESH
* COND, CONDS,
* IMODE Values to be passed to the matrix generators.
* ANORM Norm of A; passed to matrix generators.
*
* OVFL, UNFL Overflow and underflow thresholds.
* ULP, ULPINV Finest relative precision and its inverse.
* RTULP, RTULPI Square roots of the previous 4 values.
*
* The following four arrays decode JTYPE:
* KTYPE(j) The general type (1-10) for type "j".
* KMODE(j) The MODE value to be passed to the matrix
* generator for type "j".
* KMAGN(j) The order of magnitude ( O(1),
* O(overflow^(1/2) ), O(underflow^(1/2) )
* KCONDS(j) Selectw whether CONDS is to be 1 or
* 1/sqrt(ulp). (0 means irrelevant.)
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D0 )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 21 )
* ..
* .. Local Scalars ..
LOGICAL BADNN
CHARACTER*3 PATH
INTEGER IINFO, IMODE, ITYPE, IWK, J, JCOL, JJ, JSIZE,
$ JTYPE, MTYPES, N, NERRS, NFAIL, NMAX, NNWORK,
$ NTEST, NTESTF, NTESTT
DOUBLE PRECISION ANORM, COND, CONDS, OVFL, RTULP, RTULPI, TNRM,
$ ULP, ULPINV, UNFL, VMX, VRMX, VTST
* ..
* .. Local Arrays ..
CHARACTER ADUMMA( 1 )
INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( MAXTYP ),
$ KMAGN( MAXTYP ), KMODE( MAXTYP ),
$ KTYPE( MAXTYP )
DOUBLE PRECISION DUM( 1 ), RES( 2 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2
EXTERNAL DLAMCH, DLAPY2, DNRM2
* ..
* .. External Subroutines ..
EXTERNAL DGEEV, DGET22, DLABAD, DLACPY, DLASET, DLASUM,
$ DLATME, DLATMR, DLATMS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Data statements ..
DATA KTYPE / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
DATA KMAGN / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
$ 3, 1, 2, 3 /
DATA KMODE / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
$ 1, 5, 5, 5, 4, 3, 1 /
DATA KCONDS / 3*0, 5*0, 4*1, 6*2, 3*0 /
* ..
* .. Executable Statements ..
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'EV'
*
* Check for errors
*
NTESTT = 0
NTESTF = 0
INFO = 0
*
* Important constants
*
BADNN = .FALSE.
NMAX = 0
DO 10 J = 1, NSIZES
NMAX = MAX( NMAX, NN( J ) )
IF( NN( J ).LT.0 )
$ BADNN = .TRUE.
10 CONTINUE
*
* Check for errors
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADNN ) THEN
INFO = -2
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -3
ELSE IF( THRESH.LT.ZERO ) THEN
INFO = -6
ELSE IF( NOUNIT.LE.0 ) THEN
INFO = -7
ELSE IF( LDA.LT.1 .OR. LDA.LT.NMAX ) THEN
INFO = -9
ELSE IF( LDVL.LT.1 .OR. LDVL.LT.NMAX ) THEN
INFO = -16
ELSE IF( LDVR.LT.1 .OR. LDVR.LT.NMAX ) THEN
INFO = -18
ELSE IF( LDLRE.LT.1 .OR. LDLRE.LT.NMAX ) THEN
INFO = -20
ELSE IF( 5*NMAX+2*NMAX**2.GT.NWORK ) THEN
INFO = -23
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DDRVEV', -INFO )
RETURN
END IF
*
* Quick return if nothing to do
*
IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
$ RETURN
*
* More Important constants
*
UNFL = DLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
CALL DLABAD( UNFL, OVFL )
ULP = DLAMCH( 'Precision' )
ULPINV = ONE / ULP
RTULP = SQRT( ULP )
RTULPI = ONE / RTULP
*
* Loop over sizes, types
*
NERRS = 0
*
DO 270 JSIZE = 1, NSIZES
N = NN( JSIZE )
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
DO 260 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 260
*
* Save ISEED in case of an error.
*
DO 20 J = 1, 4
IOLDSD( J ) = ISEED( J )
20 CONTINUE
*
* Compute "A"
*
* Control parameters:
*
* KMAGN KCONDS KMODE KTYPE
* =1 O(1) 1 clustered 1 zero
* =2 large large clustered 2 identity
* =3 small exponential Jordan
* =4 arithmetic diagonal, (w/ eigenvalues)
* =5 random log symmetric, w/ eigenvalues
* =6 random general, w/ eigenvalues
* =7 random diagonal
* =8 random symmetric
* =9 random general
* =10 random triangular
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 90
*
ITYPE = KTYPE( JTYPE )
IMODE = KMODE( JTYPE )
*
* Compute norm
*
GO TO ( 30, 40, 50 )KMAGN( JTYPE )
*
30 CONTINUE
ANORM = ONE
GO TO 60
*
40 CONTINUE
ANORM = OVFL*ULP
GO TO 60
*
50 CONTINUE
ANORM = UNFL*ULPINV
GO TO 60
*
60 CONTINUE
*
CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
IINFO = 0
COND = ULPINV
*
* Special Matrices -- Identity & Jordan block
*
* Zero
*
IF( ITYPE.EQ.1 ) THEN
IINFO = 0
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Identity
*
DO 70 JCOL = 1, N
A( JCOL, JCOL ) = ANORM
70 CONTINUE
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* Jordan Block
*
DO 80 JCOL = 1, N
A( JCOL, JCOL ) = ANORM
IF( JCOL.GT.1 )
$ A( JCOL, JCOL-1 ) = ONE
80 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Diagonal Matrix, [Eigen]values Specified
*
CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.5 ) THEN
*
* Symmetric, eigenvalues specified
*
CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, N, N, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.6 ) THEN
*
* General, eigenvalues specified
*
IF( KCONDS( JTYPE ).EQ.1 ) THEN
CONDS = ONE
ELSE IF( KCONDS( JTYPE ).EQ.2 ) THEN
CONDS = RTULPI
ELSE
CONDS = ZERO
END IF
*
ADUMMA( 1 ) = ' '
CALL DLATME( N, 'S', ISEED, WORK, IMODE, COND, ONE,
$ ADUMMA, 'T', 'T', 'T', WORK( N+1 ), 4,
$ CONDS, N, N, ANORM, A, LDA, WORK( 2*N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.7 ) THEN
*
* Diagonal, random eigenvalues
*
CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.8 ) THEN
*
* Symmetric, random eigenvalues
*
CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.9 ) THEN
*
* General, random eigenvalues
*
CALL DLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
IF( N.GE.4 ) THEN
CALL DLASET( 'Full', 2, N, ZERO, ZERO, A, LDA )
CALL DLASET( 'Full', N-3, 1, ZERO, ZERO, A( 3, 1 ),
$ LDA )
CALL DLASET( 'Full', N-3, 2, ZERO, ZERO, A( 3, N-1 ),
$ LDA )
CALL DLASET( 'Full', 1, N, ZERO, ZERO, A( N, 1 ),
$ LDA )
END IF
*
ELSE IF( ITYPE.EQ.10 ) THEN
*
* Triangular, random eigenvalues
*
CALL DLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, 0,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE
*
IINFO = 1
END IF
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9993 )'Generator', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
90 CONTINUE
*
* Test for minimal and generous workspace
*
DO 250 IWK = 1, 2
IF( IWK.EQ.1 ) THEN
NNWORK = 4*N
ELSE
NNWORK = 5*N + 2*N**2
END IF
NNWORK = MAX( NNWORK, 1 )
*
* Initialize RESULT
*
DO 100 J = 1, 7
RESULT( J ) = -ONE
100 CONTINUE
*
* Compute eigenvalues and eigenvectors, and test them
*
CALL DLACPY( 'F', N, N, A, LDA, H, LDA )
CALL DGEEV( 'V', 'V', N, H, LDA, WR, WI, VL, LDVL, VR,
$ LDVR, WORK, NNWORK, IINFO )
IF( IINFO.NE.0 ) THEN
RESULT( 1 ) = ULPINV
WRITE( NOUNIT, FMT = 9993 )'DGEEV1', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 220
END IF
*
* Do Test (1)
*
CALL DGET22( 'N', 'N', 'N', N, A, LDA, VR, LDVR, WR, WI,
$ WORK, RES )
RESULT( 1 ) = RES( 1 )
*
* Do Test (2)
*
CALL DGET22( 'T', 'N', 'T', N, A, LDA, VL, LDVL, WR, WI,
$ WORK, RES )
RESULT( 2 ) = RES( 1 )
*
* Do Test (3)
*
DO 120 J = 1, N
TNRM = ONE
IF( WI( J ).EQ.ZERO ) THEN
TNRM = DNRM2( N, VR( 1, J ), 1 )
ELSE IF( WI( J ).GT.ZERO ) THEN
TNRM = DLAPY2( DNRM2( N, VR( 1, J ), 1 ),
$ DNRM2( N, VR( 1, J+1 ), 1 ) )
END IF
RESULT( 3 ) = MAX( RESULT( 3 ),
$ MIN( ULPINV, ABS( TNRM-ONE ) / ULP ) )
IF( WI( J ).GT.ZERO ) THEN
VMX = ZERO
VRMX = ZERO
DO 110 JJ = 1, N
VTST = DLAPY2( VR( JJ, J ), VR( JJ, J+1 ) )
IF( VTST.GT.VMX )
$ VMX = VTST
IF( VR( JJ, J+1 ).EQ.ZERO .AND.
$ ABS( VR( JJ, J ) ).GT.VRMX )
$ VRMX = ABS( VR( JJ, J ) )
110 CONTINUE
IF( VRMX / VMX.LT.ONE-TWO*ULP )
$ RESULT( 3 ) = ULPINV
END IF
120 CONTINUE
*
* Do Test (4)
*
DO 140 J = 1, N
TNRM = ONE
IF( WI( J ).EQ.ZERO ) THEN
TNRM = DNRM2( N, VL( 1, J ), 1 )
ELSE IF( WI( J ).GT.ZERO ) THEN
TNRM = DLAPY2( DNRM2( N, VL( 1, J ), 1 ),
$ DNRM2( N, VL( 1, J+1 ), 1 ) )
END IF
RESULT( 4 ) = MAX( RESULT( 4 ),
$ MIN( ULPINV, ABS( TNRM-ONE ) / ULP ) )
IF( WI( J ).GT.ZERO ) THEN
VMX = ZERO
VRMX = ZERO
DO 130 JJ = 1, N
VTST = DLAPY2( VL( JJ, J ), VL( JJ, J+1 ) )
IF( VTST.GT.VMX )
$ VMX = VTST
IF( VL( JJ, J+1 ).EQ.ZERO .AND.
$ ABS( VL( JJ, J ) ).GT.VRMX )
$ VRMX = ABS( VL( JJ, J ) )
130 CONTINUE
IF( VRMX / VMX.LT.ONE-TWO*ULP )
$ RESULT( 4 ) = ULPINV
END IF
140 CONTINUE
*
* Compute eigenvalues only, and test them
*
CALL DLACPY( 'F', N, N, A, LDA, H, LDA )
CALL DGEEV( 'N', 'N', N, H, LDA, WR1, WI1, DUM, 1, DUM,
$ 1, WORK, NNWORK, IINFO )
IF( IINFO.NE.0 ) THEN
RESULT( 1 ) = ULPINV
WRITE( NOUNIT, FMT = 9993 )'DGEEV2', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 220
END IF
*
* Do Test (5)
*
DO 150 J = 1, N
IF( WR( J ).NE.WR1( J ) .OR. WI( J ).NE.WI1( J ) )
$ RESULT( 5 ) = ULPINV
150 CONTINUE
*
* Compute eigenvalues and right eigenvectors, and test them
*
CALL DLACPY( 'F', N, N, A, LDA, H, LDA )
CALL DGEEV( 'N', 'V', N, H, LDA, WR1, WI1, DUM, 1, LRE,
$ LDLRE, WORK, NNWORK, IINFO )
IF( IINFO.NE.0 ) THEN
RESULT( 1 ) = ULPINV
WRITE( NOUNIT, FMT = 9993 )'DGEEV3', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 220
END IF
*
* Do Test (5) again
*
DO 160 J = 1, N
IF( WR( J ).NE.WR1( J ) .OR. WI( J ).NE.WI1( J ) )
$ RESULT( 5 ) = ULPINV
160 CONTINUE
*
* Do Test (6)
*
DO 180 J = 1, N
DO 170 JJ = 1, N
IF( VR( J, JJ ).NE.LRE( J, JJ ) )
$ RESULT( 6 ) = ULPINV
170 CONTINUE
180 CONTINUE
*
* Compute eigenvalues and left eigenvectors, and test them
*
CALL DLACPY( 'F', N, N, A, LDA, H, LDA )
CALL DGEEV( 'V', 'N', N, H, LDA, WR1, WI1, LRE, LDLRE,
$ DUM, 1, WORK, NNWORK, IINFO )
IF( IINFO.NE.0 ) THEN
RESULT( 1 ) = ULPINV
WRITE( NOUNIT, FMT = 9993 )'DGEEV4', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 220
END IF
*
* Do Test (5) again
*
DO 190 J = 1, N
IF( WR( J ).NE.WR1( J ) .OR. WI( J ).NE.WI1( J ) )
$ RESULT( 5 ) = ULPINV
190 CONTINUE
*
* Do Test (7)
*
DO 210 J = 1, N
DO 200 JJ = 1, N
IF( VL( J, JJ ).NE.LRE( J, JJ ) )
$ RESULT( 7 ) = ULPINV
200 CONTINUE
210 CONTINUE
*
* End of Loop -- Check for RESULT(j) > THRESH
*
220 CONTINUE
*
NTEST = 0
NFAIL = 0
DO 230 J = 1, 7
IF( RESULT( J ).GE.ZERO )
$ NTEST = NTEST + 1
IF( RESULT( J ).GE.THRESH )
$ NFAIL = NFAIL + 1
230 CONTINUE
*
IF( NFAIL.GT.0 )
$ NTESTF = NTESTF + 1
IF( NTESTF.EQ.1 ) THEN
WRITE( NOUNIT, FMT = 9999 )PATH
WRITE( NOUNIT, FMT = 9998 )
WRITE( NOUNIT, FMT = 9997 )
WRITE( NOUNIT, FMT = 9996 )
WRITE( NOUNIT, FMT = 9995 )THRESH
NTESTF = 2
END IF
*
DO 240 J = 1, 7
IF( RESULT( J ).GE.THRESH ) THEN
WRITE( NOUNIT, FMT = 9994 )N, IWK, IOLDSD, JTYPE,
$ J, RESULT( J )
END IF
240 CONTINUE
*
NERRS = NERRS + NFAIL
NTESTT = NTESTT + NTEST
*
250 CONTINUE
260 CONTINUE
270 CONTINUE
*
* Summary
*
CALL DLASUM( PATH, NOUNIT, NERRS, NTESTT )
*
9999 FORMAT( / 1X, A3, ' -- Real Eigenvalue-Eigenvector Decomposition',
$ ' Driver', / ' Matrix types (see DDRVEV for details): ' )
*
9998 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ',
$ ' ', ' 5=Diagonal: geometr. spaced entries.',
$ / ' 2=Identity matrix. ', ' 6=Diagona',
$ 'l: clustered entries.', / ' 3=Transposed Jordan block. ',
$ ' ', ' 7=Diagonal: large, evenly spaced.', / ' ',
$ '4=Diagonal: evenly spaced entries. ', ' 8=Diagonal: s',
$ 'mall, evenly spaced.' )
9997 FORMAT( ' Dense, Non-Symmetric Matrices:', / ' 9=Well-cond., ev',
$ 'enly spaced eigenvals.', ' 14=Ill-cond., geomet. spaced e',
$ 'igenals.', / ' 10=Well-cond., geom. spaced eigenvals. ',
$ ' 15=Ill-conditioned, clustered e.vals.', / ' 11=Well-cond',
$ 'itioned, clustered e.vals. ', ' 16=Ill-cond., random comp',
$ 'lex ', / ' 12=Well-cond., random complex ', 6X, ' ',
$ ' 17=Ill-cond., large rand. complx ', / ' 13=Ill-condi',
$ 'tioned, evenly spaced. ', ' 18=Ill-cond., small rand.',
$ ' complx ' )
9996 FORMAT( ' 19=Matrix with random O(1) entries. ', ' 21=Matrix ',
$ 'with small random entries.', / ' 20=Matrix with large ran',
$ 'dom entries. ', / )
9995 FORMAT( ' Tests performed with test threshold =', F8.2,
$ / / ' 1 = | A VR - VR W | / ( n |A| ulp ) ',
$ / ' 2 = | transpose(A) VL - VL W | / ( n |A| ulp ) ',
$ / ' 3 = | |VR(i)| - 1 | / ulp ',
$ / ' 4 = | |VL(i)| - 1 | / ulp ',
$ / ' 5 = 0 if W same no matter if VR or VL computed,',
$ ' 1/ulp otherwise', /
$ ' 6 = 0 if VR same no matter if VL computed,',
$ ' 1/ulp otherwise', /
$ ' 7 = 0 if VL same no matter if VR computed,',
$ ' 1/ulp otherwise', / )
9994 FORMAT( ' N=', I5, ', IWK=', I2, ', seed=', 4( I4, ',' ),
$ ' type ', I2, ', test(', I2, ')=', G10.3 )
9993 FORMAT( ' DDRVEV: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
*
RETURN
*
* End of DDRVEV
*
END
SUBROUTINE DDRVGG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
$ THRSHN, NOUNIT, A, LDA, B, S, T, S2, T2, Q,
$ LDQ, Z, ALPHR1, ALPHI1, BETA1, ALPHR2, ALPHI2,
$ BETA2, VL, VR, WORK, LWORK, RESULT, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES
DOUBLE PRECISION THRESH, THRSHN
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER ISEED( 4 ), NN( * )
DOUBLE PRECISION A( LDA, * ), ALPHI1( * ), ALPHI2( * ),
$ ALPHR1( * ), ALPHR2( * ), B( LDA, * ),
$ BETA1( * ), BETA2( * ), Q( LDQ, * ),
$ RESULT( * ), S( LDA, * ), S2( LDA, * ),
$ T( LDA, * ), T2( LDA, * ), VL( LDQ, * ),
$ VR( LDQ, * ), WORK( * ), Z( LDQ, * )
* ..
*
* Purpose
* =======
*
* DDRVGG checks the nonsymmetric generalized eigenvalue driver
* routines.
* T T T
* DGEGS factors A and B as Q S Z and Q T Z , where means
* transpose, T is upper triangular, S is in generalized Schur form
* (block upper triangular, with 1x1 and 2x2 blocks on the diagonal,
* the 2x2 blocks corresponding to complex conjugate pairs of
* generalized eigenvalues), and Q and Z are orthogonal. It also
* computes the generalized eigenvalues (alpha(1),beta(1)), ...,
* (alpha(n),beta(n)), where alpha(j)=S(j,j) and beta(j)=P(j,j) --
* thus, w(j) = alpha(j)/beta(j) is a root of the generalized
* eigenvalue problem
*
* det( A - w(j) B ) = 0
*
* and m(j) = beta(j)/alpha(j) is a root of the essentially equivalent
* problem
*
* det( m(j) A - B ) = 0
*
* DGEGV computes the generalized eigenvalues (alpha(1),beta(1)), ...,
* (alpha(n),beta(n)), the matrix L whose columns contain the
* generalized left eigenvectors l, and the matrix R whose columns
* contain the generalized right eigenvectors r for the pair (A,B).
*
* When DDRVGG is called, a number of matrix "sizes" ("n's") and a
* number of matrix "types" are specified. For each size ("n")
* and each type of matrix, one matrix will be generated and used
* to test the nonsymmetric eigenroutines. For each matrix, 7
* tests will be performed and compared with the threshhold THRESH:
*
* Results from DGEGS:
*
* T
* (1) | A - Q S Z | / ( |A| n ulp )
*
* T
* (2) | B - Q T Z | / ( |B| n ulp )
*
* T
* (3) | I - QQ | / ( n ulp )
*
* T
* (4) | I - ZZ | / ( n ulp )
*
* (5) maximum over j of D(j) where:
*
* if alpha(j) is real:
* |alpha(j) - S(j,j)| |beta(j) - T(j,j)|
* D(j) = ------------------------ + -----------------------
* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|)
*
* if alpha(j) is complex:
* | det( s S - w T ) |
* D(j) = ---------------------------------------------------
* ulp max( s norm(S), |w| norm(T) )*norm( s S - w T )
*
* and S and T are here the 2 x 2 diagonal blocks of S and T
* corresponding to the j-th eigenvalue.
*
* Results from DGEGV:
*
* (6) max over all left eigenvalue/-vector pairs (beta/alpha,l) of
*
* | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) )
*
* where l**H is the conjugate tranpose of l.
*
* (7) max over all right eigenvalue/-vector pairs (beta/alpha,r) of
*
* | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) )
*
* Test Matrices
* ---- --------
*
* The sizes of the test matrices are specified by an array
* NN(1:NSIZES); the value of each element NN(j) specifies one size.
* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if
* DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
* Currently, the list of possible types is:
*
* (1) ( 0, 0 ) (a pair of zero matrices)
*
* (2) ( I, 0 ) (an identity and a zero matrix)
*
* (3) ( 0, I ) (an identity and a zero matrix)
*
* (4) ( I, I ) (a pair of identity matrices)
*
* t t
* (5) ( J , J ) (a pair of transposed Jordan blocks)
*
* t ( I 0 )
* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t )
* ( 0 I ) ( 0 J )
* and I is a k x k identity and J a (k+1)x(k+1)
* Jordan block; k=(N-1)/2
*
* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal
* matrix with those diagonal entries.)
* (8) ( I, D )
*
* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big
*
* (10) ( small*D, big*I )
*
* (11) ( big*I, small*D )
*
* (12) ( small*I, big*D )
*
* (13) ( big*D, big*I )
*
* (14) ( small*D, small*I )
*
* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and
* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 )
* t t
* (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices.
*
* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices
* with random O(1) entries above the diagonal
* and diagonal entries diag(T1) =
* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) =
* ( 0, N-3, N-4,..., 1, 0, 0 )
*
* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 )
* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 )
* s = machine precision.
*
* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 )
* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 )
*
* N-5
* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 )
* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
*
* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 )
* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
* where r1,..., r(N-4) are random.
*
* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
*
* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular
* matrices.
*
* Arguments
* =========
*
* NSIZES (input) INTEGER
* The number of sizes of matrices to use. If it is zero,
* DDRVGG does nothing. It must be at least zero.
*
* NN (input) INTEGER array, dimension (NSIZES)
* An array containing the sizes to be used for the matrices.
* Zero values will be skipped. The values must be at least
* zero.
*
* NTYPES (input) INTEGER
* The number of elements in DOTYPE. If it is zero, DDRVGG
* does nothing. It must be at least zero. If it is MAXTYP+1
* and NSIZES is 1, then an additional type, MAXTYP+1 is
* defined, which is to use whatever matrix is in A. This
* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
* DOTYPE(MAXTYP+1) is .TRUE. .
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* If DOTYPE(j) is .TRUE., then for each size in NN a
* matrix of that size and of type j will be generated.
* If NTYPES is smaller than the maximum number of types
* defined (PARAMETER MAXTYP), then types NTYPES+1 through
* MAXTYP will not be generated. If NTYPES is larger
* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
* will be ignored.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The array elements should be between 0 and 4095;
* if not they will be reduced mod 4096. Also, ISEED(4) must
* be odd. The random number generator uses a linear
* congruential sequence limited to small integers, and so
* should produce machine independent random numbers. The
* values of ISEED are changed on exit, and can be used in the
* next call to DDRVGG to continue the same random number
* sequence.
*
* THRESH (input) DOUBLE PRECISION
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error is
* scaled to be O(1), so THRESH should be a reasonably small
* multiple of 1, e.g., 10 or 100. In particular, it should
* not depend on the precision (single vs. double) or the size
* of the matrix. It must be at least zero.
*
* THRSHN (input) DOUBLE PRECISION
* Threshhold for reporting eigenvector normalization error.
* If the normalization of any eigenvector differs from 1 by
* more than THRSHN*ulp, then a special error message will be
* printed. (This is handled separately from the other tests,
* since only a compiler or programming error should cause an
* error message, at least if THRSHN is at least 5--10.)
*
* NOUNIT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns IINFO not equal to 0.)
*
* A (input/workspace) DOUBLE PRECISION array, dimension
* (LDA, max(NN))
* Used to hold the original A matrix. Used as input only
* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
* DOTYPE(MAXTYP+1)=.TRUE.
*
* LDA (input) INTEGER
* The leading dimension of A, B, S, T, S2, and T2.
* It must be at least 1 and at least max( NN ).
*
* B (input/workspace) DOUBLE PRECISION array, dimension
* (LDA, max(NN))
* Used to hold the original B matrix. Used as input only
* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
* DOTYPE(MAXTYP+1)=.TRUE.
*
* S (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
* The Schur form matrix computed from A by DGEGS. On exit, S
* contains the Schur form matrix corresponding to the matrix
* in A.
*
* T (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
* The upper triangular matrix computed from B by DGEGS.
*
* S2 (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
* The matrix computed from A by DGEGV. This will be the
* Schur form of some matrix related to A, but will not, in
* general, be the same as S.
*
* T2 (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
* The matrix computed from B by DGEGV. This will be the
* Schur form of some matrix related to B, but will not, in
* general, be the same as T.
*
* Q (workspace) DOUBLE PRECISION array, dimension (LDQ, max(NN))
* The (left) orthogonal matrix computed by DGEGS.
*
* LDQ (input) INTEGER
* The leading dimension of Q, Z, VL, and VR. It must
* be at least 1 and at least max( NN ).
*
* Z (workspace) DOUBLE PRECISION array of
* dimension( LDQ, max(NN) )
* The (right) orthogonal matrix computed by DGEGS.
*
* ALPHR1 (workspace) DOUBLE PRECISION array, dimension (max(NN))
* ALPHI1 (workspace) DOUBLE PRECISION array, dimension (max(NN))
* BETA1 (workspace) DOUBLE PRECISION array, dimension (max(NN))
*
* The generalized eigenvalues of (A,B) computed by DGEGS.
* ( ALPHR1(k)+ALPHI1(k)*i ) / BETA1(k) is the k-th
* generalized eigenvalue of the matrices in A and B.
*
* ALPHR2 (workspace) DOUBLE PRECISION array, dimension (max(NN))
* ALPHI2 (workspace) DOUBLE PRECISION array, dimension (max(NN))
* BETA2 (workspace) DOUBLE PRECISION array, dimension (max(NN))
*
* The generalized eigenvalues of (A,B) computed by DGEGV.
* ( ALPHR2(k)+ALPHI2(k)*i ) / BETA2(k) is the k-th
* generalized eigenvalue of the matrices in A and B.
*
* VL (workspace) DOUBLE PRECISION array, dimension (LDQ, max(NN))
* The (block lower triangular) left eigenvector matrix for
* the matrices in A and B. (See DTGEVC for the format.)
*
* VR (workspace) DOUBLE PRECISION array, dimension (LDQ, max(NN))
* The (block upper triangular) right eigenvector matrix for
* the matrices in A and B. (See DTGEVC for the format.)
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The number of entries in WORK. This must be at least
* 2*N + MAX( 6*N, N*(NB+1), (k+1)*(2*k+N+1) ), where
* "k" is the sum of the blocksize and number-of-shifts for
* DHGEQZ, and NB is the greatest of the blocksizes for
* DGEQRF, DORMQR, and DORGQR. (The blocksizes and the
* number-of-shifts are retrieved through calls to ILAENV.)
*
* RESULT (output) DOUBLE PRECISION array, dimension (15)
* The values computed by the tests described above.
* The values are currently limited to 1/ulp, to avoid
* overflow.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: A routine returned an error code. INFO is the
* absolute value of the INFO value returned.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 26 )
* ..
* .. Local Scalars ..
LOGICAL BADNN, ILABAD
INTEGER I1, IADD, IINFO, IN, J, JC, JR, JSIZE, JTYPE,
$ LWKOPT, MTYPES, N, N1, NB, NBZ, NERRS, NMATS,
$ NMAX, NS, NTEST, NTESTT
DOUBLE PRECISION SAFMAX, SAFMIN, TEMP1, TEMP2, ULP, ULPINV
* ..
* .. Local Arrays ..
INTEGER IASIGN( MAXTYP ), IBSIGN( MAXTYP ),
$ IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ),
$ KATYPE( MAXTYP ), KAZERO( MAXTYP ),
$ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ),
$ KBZERO( MAXTYP ), KCLASS( MAXTYP ),
$ KTRIAN( MAXTYP ), KZ1( 6 ), KZ2( 6 )
DOUBLE PRECISION DUMMA( 4 ), RMAGN( 0: 3 )
* ..
* .. External Functions ..
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLARND
EXTERNAL ILAENV, DLAMCH, DLARND
* ..
* .. External Subroutines ..
EXTERNAL ALASVM, DGEGS, DGEGV, DGET51, DGET52, DGET53,
$ DLABAD, DLACPY, DLARFG, DLASET, DLATM4, DORM2R,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN, SIGN
* ..
* .. Data statements ..
DATA KCLASS / 15*1, 10*2, 1*3 /
DATA KZ1 / 0, 1, 2, 1, 3, 3 /
DATA KZ2 / 0, 0, 1, 2, 1, 1 /
DATA KADD / 0, 0, 0, 0, 3, 2 /
DATA KATYPE / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4,
$ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 /
DATA KBTYPE / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4,
$ 1, 1, -4, 2, -4, 8*8, 0 /
DATA KAZERO / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3,
$ 4*5, 4*3, 1 /
DATA KBZERO / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4,
$ 4*6, 4*4, 1 /
DATA KAMAGN / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3,
$ 2, 1 /
DATA KBMAGN / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3,
$ 2, 1 /
DATA KTRIAN / 16*0, 10*1 /
DATA IASIGN / 6*0, 2, 0, 2*2, 2*0, 3*2, 0, 2, 3*0,
$ 5*2, 0 /
DATA IBSIGN / 7*0, 2, 2*0, 2*2, 2*0, 2, 0, 2, 9*0 /
* ..
* .. Executable Statements ..
*
* Check for errors
*
INFO = 0
*
BADNN = .FALSE.
NMAX = 1
DO 10 J = 1, NSIZES
NMAX = MAX( NMAX, NN( J ) )
IF( NN( J ).LT.0 )
$ BADNN = .TRUE.
10 CONTINUE
*
* Maximum blocksize and shift -- we assume that blocksize and number
* of shifts are monotone increasing functions of N.
*
NB = MAX( 1, ILAENV( 1, 'DGEQRF', ' ', NMAX, NMAX, -1, -1 ),
$ ILAENV( 1, 'DORMQR', 'LT', NMAX, NMAX, NMAX, -1 ),
$ ILAENV( 1, 'DORGQR', ' ', NMAX, NMAX, NMAX, -1 ) )
NBZ = ILAENV( 1, 'DHGEQZ', 'SII', NMAX, 1, NMAX, 0 )
NS = ILAENV( 4, 'DHGEQZ', 'SII', NMAX, 1, NMAX, 0 )
I1 = NBZ + NS
LWKOPT = 2*NMAX + MAX( 6*NMAX, NMAX*( NB+1 ),
$ ( 2*I1+NMAX+1 )*( I1+1 ) )
*
* Check for errors
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADNN ) THEN
INFO = -2
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -3
ELSE IF( THRESH.LT.ZERO ) THEN
INFO = -6
ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN
INFO = -10
ELSE IF( LDQ.LE.1 .OR. LDQ.LT.NMAX ) THEN
INFO = -19
ELSE IF( LWKOPT.GT.LWORK ) THEN
INFO = -30
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DDRVGG', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
$ RETURN
*
SAFMIN = DLAMCH( 'Safe minimum' )
ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
SAFMIN = SAFMIN / ULP
SAFMAX = ONE / SAFMIN
CALL DLABAD( SAFMIN, SAFMAX )
ULPINV = ONE / ULP
*
* The values RMAGN(2:3) depend on N, see below.
*
RMAGN( 0 ) = ZERO
RMAGN( 1 ) = ONE
*
* Loop over sizes, types
*
NTESTT = 0
NERRS = 0
NMATS = 0
*
DO 170 JSIZE = 1, NSIZES
N = NN( JSIZE )
N1 = MAX( 1, N )
RMAGN( 2 ) = SAFMAX*ULP / DBLE( N1 )
RMAGN( 3 ) = SAFMIN*ULPINV*N1
*
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
DO 160 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 160
NMATS = NMATS + 1
NTEST = 0
*
* Save ISEED in case of an error.
*
DO 20 J = 1, 4
IOLDSD( J ) = ISEED( J )
20 CONTINUE
*
* Initialize RESULT
*
DO 30 J = 1, 15
RESULT( J ) = ZERO
30 CONTINUE
*
* Compute A and B
*
* Description of control parameters:
*
* KZLASS: =1 means w/o rotation, =2 means w/ rotation,
* =3 means random.
* KATYPE: the "type" to be passed to DLATM4 for computing A.
* KAZERO: the pattern of zeros on the diagonal for A:
* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ),
* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ),
* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of
* non-zero entries.)
* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1),
* =2: large, =3: small.
* IASIGN: 1 if the diagonal elements of A are to be
* multiplied by a random magnitude 1 number, =2 if
* randomly chosen diagonal blocks are to be rotated
* to form 2x2 blocks.
* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B.
* KTRIAN: =0: don't fill in the upper triangle, =1: do.
* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO.
* RMAGN: used to implement KAMAGN and KBMAGN.
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 110
IINFO = 0
IF( KCLASS( JTYPE ).LT.3 ) THEN
*
* Generate A (w/o rotation)
*
IF( ABS( KATYPE( JTYPE ) ).EQ.3 ) THEN
IN = 2*( ( N-1 ) / 2 ) + 1
IF( IN.NE.N )
$ CALL DLASET( 'Full', N, N, ZERO, ZERO, A, LDA )
ELSE
IN = N
END IF
CALL DLATM4( KATYPE( JTYPE ), IN, KZ1( KAZERO( JTYPE ) ),
$ KZ2( KAZERO( JTYPE ) ), IASIGN( JTYPE ),
$ RMAGN( KAMAGN( JTYPE ) ), ULP,
$ RMAGN( KTRIAN( JTYPE )*KAMAGN( JTYPE ) ), 2,
$ ISEED, A, LDA )
IADD = KADD( KAZERO( JTYPE ) )
IF( IADD.GT.0 .AND. IADD.LE.N )
$ A( IADD, IADD ) = ONE
*
* Generate B (w/o rotation)
*
IF( ABS( KBTYPE( JTYPE ) ).EQ.3 ) THEN
IN = 2*( ( N-1 ) / 2 ) + 1
IF( IN.NE.N )
$ CALL DLASET( 'Full', N, N, ZERO, ZERO, B, LDA )
ELSE
IN = N
END IF
CALL DLATM4( KBTYPE( JTYPE ), IN, KZ1( KBZERO( JTYPE ) ),
$ KZ2( KBZERO( JTYPE ) ), IBSIGN( JTYPE ),
$ RMAGN( KBMAGN( JTYPE ) ), ONE,
$ RMAGN( KTRIAN( JTYPE )*KBMAGN( JTYPE ) ), 2,
$ ISEED, B, LDA )
IADD = KADD( KBZERO( JTYPE ) )
IF( IADD.NE.0 .AND. IADD.LE.N )
$ B( IADD, IADD ) = ONE
*
IF( KCLASS( JTYPE ).EQ.2 .AND. N.GT.0 ) THEN
*
* Include rotations
*
* Generate Q, Z as Householder transformations times
* a diagonal matrix.
*
DO 50 JC = 1, N - 1
DO 40 JR = JC, N
Q( JR, JC ) = DLARND( 3, ISEED )
Z( JR, JC ) = DLARND( 3, ISEED )
40 CONTINUE
CALL DLARFG( N+1-JC, Q( JC, JC ), Q( JC+1, JC ), 1,
$ WORK( JC ) )
WORK( 2*N+JC ) = SIGN( ONE, Q( JC, JC ) )
Q( JC, JC ) = ONE
CALL DLARFG( N+1-JC, Z( JC, JC ), Z( JC+1, JC ), 1,
$ WORK( N+JC ) )
WORK( 3*N+JC ) = SIGN( ONE, Z( JC, JC ) )
Z( JC, JC ) = ONE
50 CONTINUE
Q( N, N ) = ONE
WORK( N ) = ZERO
WORK( 3*N ) = SIGN( ONE, DLARND( 2, ISEED ) )
Z( N, N ) = ONE
WORK( 2*N ) = ZERO
WORK( 4*N ) = SIGN( ONE, DLARND( 2, ISEED ) )
*
* Apply the diagonal matrices
*
DO 70 JC = 1, N
DO 60 JR = 1, N
A( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
$ A( JR, JC )
B( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
$ B( JR, JC )
60 CONTINUE
70 CONTINUE
CALL DORM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, A,
$ LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
CALL DORM2R( 'R', 'T', N, N, N-1, Z, LDQ, WORK( N+1 ),
$ A, LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
CALL DORM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, B,
$ LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
CALL DORM2R( 'R', 'T', N, N, N-1, Z, LDQ, WORK( N+1 ),
$ B, LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
END IF
ELSE
*
* Random matrices
*
DO 90 JC = 1, N
DO 80 JR = 1, N
A( JR, JC ) = RMAGN( KAMAGN( JTYPE ) )*
$ DLARND( 2, ISEED )
B( JR, JC ) = RMAGN( KBMAGN( JTYPE ) )*
$ DLARND( 2, ISEED )
80 CONTINUE
90 CONTINUE
END IF
*
100 CONTINUE
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
110 CONTINUE
*
* Call DGEGS to compute H, T, Q, Z, alpha, and beta.
*
CALL DLACPY( ' ', N, N, A, LDA, S, LDA )
CALL DLACPY( ' ', N, N, B, LDA, T, LDA )
NTEST = 1
RESULT( 1 ) = ULPINV
*
CALL DGEGS( 'V', 'V', N, S, LDA, T, LDA, ALPHR1, ALPHI1,
$ BETA1, Q, LDQ, Z, LDQ, WORK, LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DGEGS', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 140
END IF
*
NTEST = 4
*
* Do tests 1--4
*
CALL DGET51( 1, N, A, LDA, S, LDA, Q, LDQ, Z, LDQ, WORK,
$ RESULT( 1 ) )
CALL DGET51( 1, N, B, LDA, T, LDA, Q, LDQ, Z, LDQ, WORK,
$ RESULT( 2 ) )
CALL DGET51( 3, N, B, LDA, T, LDA, Q, LDQ, Q, LDQ, WORK,
$ RESULT( 3 ) )
CALL DGET51( 3, N, B, LDA, T, LDA, Z, LDQ, Z, LDQ, WORK,
$ RESULT( 4 ) )
*
* Do test 5: compare eigenvalues with diagonals.
* Also check Schur form of A.
*
TEMP1 = ZERO
*
DO 120 J = 1, N
ILABAD = .FALSE.
IF( ALPHI1( J ).EQ.ZERO ) THEN
TEMP2 = ( ABS( ALPHR1( J )-S( J, J ) ) /
$ MAX( SAFMIN, ABS( ALPHR1( J ) ), ABS( S( J,
$ J ) ) )+ABS( BETA1( J )-T( J, J ) ) /
$ MAX( SAFMIN, ABS( BETA1( J ) ), ABS( T( J,
$ J ) ) ) ) / ULP
IF( J.LT.N ) THEN
IF( S( J+1, J ).NE.ZERO )
$ ILABAD = .TRUE.
END IF
IF( J.GT.1 ) THEN
IF( S( J, J-1 ).NE.ZERO )
$ ILABAD = .TRUE.
END IF
ELSE
IF( ALPHI1( J ).GT.ZERO ) THEN
I1 = J
ELSE
I1 = J - 1
END IF
IF( I1.LE.0 .OR. I1.GE.N ) THEN
ILABAD = .TRUE.
ELSE IF( I1.LT.N-1 ) THEN
IF( S( I1+2, I1+1 ).NE.ZERO )
$ ILABAD = .TRUE.
ELSE IF( I1.GT.1 ) THEN
IF( S( I1, I1-1 ).NE.ZERO )
$ ILABAD = .TRUE.
END IF
IF( .NOT.ILABAD ) THEN
CALL DGET53( S( I1, I1 ), LDA, T( I1, I1 ), LDA,
$ BETA1( J ), ALPHR1( J ), ALPHI1( J ),
$ TEMP2, IINFO )
IF( IINFO.GE.3 ) THEN
WRITE( NOUNIT, FMT = 9997 )IINFO, J, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
END IF
ELSE
TEMP2 = ULPINV
END IF
END IF
TEMP1 = MAX( TEMP1, TEMP2 )
IF( ILABAD ) THEN
WRITE( NOUNIT, FMT = 9996 )J, N, JTYPE, IOLDSD
END IF
120 CONTINUE
RESULT( 5 ) = TEMP1
*
* Call DGEGV to compute S2, T2, VL, and VR, do tests.
*
* Eigenvalues and Eigenvectors
*
CALL DLACPY( ' ', N, N, A, LDA, S2, LDA )
CALL DLACPY( ' ', N, N, B, LDA, T2, LDA )
NTEST = 6
RESULT( 6 ) = ULPINV
*
CALL DGEGV( 'V', 'V', N, S2, LDA, T2, LDA, ALPHR2, ALPHI2,
$ BETA2, VL, LDQ, VR, LDQ, WORK, LWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DGEGV', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 140
END IF
*
NTEST = 7
*
* Do Tests 6 and 7
*
CALL DGET52( .TRUE., N, A, LDA, B, LDA, VL, LDQ, ALPHR2,
$ ALPHI2, BETA2, WORK, DUMMA( 1 ) )
RESULT( 6 ) = DUMMA( 1 )
IF( DUMMA( 2 ).GT.THRSHN ) THEN
WRITE( NOUNIT, FMT = 9998 )'Left', 'DGEGV', DUMMA( 2 ),
$ N, JTYPE, IOLDSD
END IF
*
CALL DGET52( .FALSE., N, A, LDA, B, LDA, VR, LDQ, ALPHR2,
$ ALPHI2, BETA2, WORK, DUMMA( 1 ) )
RESULT( 7 ) = DUMMA( 1 )
IF( DUMMA( 2 ).GT.THRESH ) THEN
WRITE( NOUNIT, FMT = 9998 )'Right', 'DGEGV', DUMMA( 2 ),
$ N, JTYPE, IOLDSD
END IF
*
* Check form of Complex eigenvalues.
*
DO 130 J = 1, N
ILABAD = .FALSE.
IF( ALPHI2( J ).GT.ZERO ) THEN
IF( J.EQ.N ) THEN
ILABAD = .TRUE.
ELSE IF( ALPHI2( J+1 ).GE.ZERO ) THEN
ILABAD = .TRUE.
END IF
ELSE IF( ALPHI2( J ).LT.ZERO ) THEN
IF( J.EQ.1 ) THEN
ILABAD = .TRUE.
ELSE IF( ALPHI2( J-1 ).LE.ZERO ) THEN
ILABAD = .TRUE.
END IF
END IF
IF( ILABAD ) THEN
WRITE( NOUNIT, FMT = 9996 )J, N, JTYPE, IOLDSD
END IF
130 CONTINUE
*
* End of Loop -- Check for RESULT(j) > THRESH
*
140 CONTINUE
*
NTESTT = NTESTT + NTEST
*
* Print out tests which fail.
*
DO 150 JR = 1, NTEST
IF( RESULT( JR ).GE.THRESH ) THEN
*
* If this is the first test to fail,
* print a header to the data file.
*
IF( NERRS.EQ.0 ) THEN
WRITE( NOUNIT, FMT = 9995 )'DGG'
*
* Matrix types
*
WRITE( NOUNIT, FMT = 9994 )
WRITE( NOUNIT, FMT = 9993 )
WRITE( NOUNIT, FMT = 9992 )'Orthogonal'
*
* Tests performed
*
WRITE( NOUNIT, FMT = 9991 )'orthogonal', '''',
$ 'transpose', ( '''', J = 1, 5 )
*
END IF
NERRS = NERRS + 1
IF( RESULT( JR ).LT.10000.0D0 ) THEN
WRITE( NOUNIT, FMT = 9990 )N, JTYPE, IOLDSD, JR,
$ RESULT( JR )
ELSE
WRITE( NOUNIT, FMT = 9989 )N, JTYPE, IOLDSD, JR,
$ RESULT( JR )
END IF
END IF
150 CONTINUE
*
160 CONTINUE
170 CONTINUE
*
* Summary
*
CALL ALASVM( 'DGG', NOUNIT, NERRS, NTESTT, 0 )
RETURN
*
9999 FORMAT( ' DDRVGG: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
*
9998 FORMAT( ' DDRVGG: ', A, ' Eigenvectors from ', A, ' incorrectly ',
$ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 9X,
$ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5,
$ ')' )
*
9997 FORMAT( ' DDRVGG: DGET53 returned INFO=', I1, ' for eigenvalue ',
$ I6, '.', / 9X, 'N=', I6, ', JTYPE=', I6, ', ISEED=(',
$ 3( I5, ',' ), I5, ')' )
*
9996 FORMAT( ' DDRVGG: S not in Schur form at eigenvalue ', I6, '.',
$ / 9X, 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ),
$ I5, ')' )
*
9995 FORMAT( / 1X, A3, ' -- Real Generalized eigenvalue problem driver'
$ )
*
9994 FORMAT( ' Matrix types (see DDRVGG for details): ' )
*
9993 FORMAT( ' Special Matrices:', 23X,
$ '(J''=transposed Jordan block)',
$ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ',
$ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ',
$ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I',
$ ') 11=(large*I, small*D) 13=(large*D, large*I)', /
$ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ',
$ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' )
9992 FORMAT( ' Matrices Rotated by Random ', A, ' Matrices U, V:',
$ / ' 16=Transposed Jordan Blocks 19=geometric ',
$ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ',
$ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ',
$ 'alpha, beta=0,1 21=random alpha, beta=0,1',
$ / ' Large & Small Matrices:', / ' 22=(large, small) ',
$ '23=(small,large) 24=(small,small) 25=(large,large)',
$ / ' 26=random O(1) matrices.' )
*
9991 FORMAT( / ' Tests performed: (S is Schur, T is triangular, ',
$ 'Q and Z are ', A, ',', / 20X,
$ 'l and r are the appropriate left and right', / 19X,
$ 'eigenvectors, resp., a is alpha, b is beta, and', / 19X, A,
$ ' means ', A, '.)', / ' 1 = | A - Q S Z', A,
$ ' | / ( |A| n ulp ) 2 = | B - Q T Z', A,
$ ' | / ( |B| n ulp )', / ' 3 = | I - QQ', A,
$ ' | / ( n ulp ) 4 = | I - ZZ', A,
$ ' | / ( n ulp )', /
$ ' 5 = difference between (alpha,beta) and diagonals of',
$ ' (S,T)', / ' 6 = max | ( b A - a B )', A,
$ ' l | / const. 7 = max | ( b A - a B ) r | / const.',
$ / 1X )
9990 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
$ 4( I4, ',' ), ' result ', I3, ' is', 0P, F8.2 )
9989 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
$ 4( I4, ',' ), ' result ', I3, ' is', 1P, D10.3 )
*
* End of DDRVGG
*
END
SUBROUTINE DDRVSG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
$ NOUNIT, A, LDA, B, LDB, D, Z, LDZ, AB, BB, AP,
$ BP, WORK, NWORK, IWORK, LIWORK, RESULT, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
*******************************************************************
*
* modified August 1997, a new parameter LIWORK is added
* in the calling sequence.
*
* test routine DDGT01 is also modified
*
*******************************************************************
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LDZ, LIWORK, NOUNIT, NSIZES,
$ NTYPES, NWORK
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER ISEED( 4 ), IWORK( * ), NN( * )
DOUBLE PRECISION A( LDA, * ), AB( LDA, * ), AP( * ),
$ B( LDB, * ), BB( LDB, * ), BP( * ), D( * ),
$ RESULT( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DDRVSG checks the real symmetric generalized eigenproblem
* drivers.
*
* DSYGV computes all eigenvalues and, optionally,
* eigenvectors of a real symmetric-definite generalized
* eigenproblem.
*
* DSYGVD computes all eigenvalues and, optionally,
* eigenvectors of a real symmetric-definite generalized
* eigenproblem using a divide and conquer algorithm.
*
* DSYGVX computes selected eigenvalues and, optionally,
* eigenvectors of a real symmetric-definite generalized
* eigenproblem.
*
* DSPGV computes all eigenvalues and, optionally,
* eigenvectors of a real symmetric-definite generalized
* eigenproblem in packed storage.
*
* DSPGVD computes all eigenvalues and, optionally,
* eigenvectors of a real symmetric-definite generalized
* eigenproblem in packed storage using a divide and
* conquer algorithm.
*
* DSPGVX computes selected eigenvalues and, optionally,
* eigenvectors of a real symmetric-definite generalized
* eigenproblem in packed storage.
*
* DSBGV computes all eigenvalues and, optionally,
* eigenvectors of a real symmetric-definite banded
* generalized eigenproblem.
*
* DSBGVD computes all eigenvalues and, optionally,
* eigenvectors of a real symmetric-definite banded
* generalized eigenproblem using a divide and conquer
* algorithm.
*
* DSBGVX computes selected eigenvalues and, optionally,
* eigenvectors of a real symmetric-definite banded
* generalized eigenproblem.
*
* When DDRVSG is called, a number of matrix "sizes" ("n's") and a
* number of matrix "types" are specified. For each size ("n")
* and each type of matrix, one matrix A of the given type will be
* generated; a random well-conditioned matrix B is also generated
* and the pair (A,B) is used to test the drivers.
*
* For each pair (A,B), the following tests are performed:
*
* (1) DSYGV with ITYPE = 1 and UPLO ='U':
*
* | A Z - B Z D | / ( |A| |Z| n ulp )
*
* (2) as (1) but calling DSPGV
* (3) as (1) but calling DSBGV
* (4) as (1) but with UPLO = 'L'
* (5) as (4) but calling DSPGV
* (6) as (4) but calling DSBGV
*
* (7) DSYGV with ITYPE = 2 and UPLO ='U':
*
* | A B Z - Z D | / ( |A| |Z| n ulp )
*
* (8) as (7) but calling DSPGV
* (9) as (7) but with UPLO = 'L'
* (10) as (9) but calling DSPGV
*
* (11) DSYGV with ITYPE = 3 and UPLO ='U':
*
* | B A Z - Z D | / ( |A| |Z| n ulp )
*
* (12) as (11) but calling DSPGV
* (13) as (11) but with UPLO = 'L'
* (14) as (13) but calling DSPGV
*
* DSYGVD, DSPGVD and DSBGVD performed the same 14 tests.
*
* DSYGVX, DSPGVX and DSBGVX performed the above 14 tests with
* the parameter RANGE = 'A', 'N' and 'I', respectively.
*
* The "sizes" are specified by an array NN(1:NSIZES); the value
* of each element NN(j) specifies one size.
* The "types" are specified by a logical array DOTYPE( 1:NTYPES );
* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
* This type is used for the matrix A which has half-bandwidth KA.
* B is generated as a well-conditioned positive definite matrix
* with half-bandwidth KB (<= KA).
* Currently, the list of possible types for A is:
*
* (1) The zero matrix.
* (2) The identity matrix.
*
* (3) A diagonal matrix with evenly spaced entries
* 1, ..., ULP and random signs.
* (ULP = (first number larger than 1) - 1 )
* (4) A diagonal matrix with geometrically spaced entries
* 1, ..., ULP and random signs.
* (5) A diagonal matrix with "clustered" entries
* 1, ULP, ..., ULP and random signs.
*
* (6) Same as (4), but multiplied by SQRT( overflow threshold )
* (7) Same as (4), but multiplied by SQRT( underflow threshold )
*
* (8) A matrix of the form U* D U, where U is orthogonal and
* D has evenly spaced entries 1, ..., ULP with random signs
* on the diagonal.
*
* (9) A matrix of the form U* D U, where U is orthogonal and
* D has geometrically spaced entries 1, ..., ULP with random
* signs on the diagonal.
*
* (10) A matrix of the form U* D U, where U is orthogonal and
* D has "clustered" entries 1, ULP,..., ULP with random
* signs on the diagonal.
*
* (11) Same as (8), but multiplied by SQRT( overflow threshold )
* (12) Same as (8), but multiplied by SQRT( underflow threshold )
*
* (13) symmetric matrix with random entries chosen from (-1,1).
* (14) Same as (13), but multiplied by SQRT( overflow threshold )
* (15) Same as (13), but multiplied by SQRT( underflow threshold)
*
* (16) Same as (8), but with KA = 1 and KB = 1
* (17) Same as (8), but with KA = 2 and KB = 1
* (18) Same as (8), but with KA = 2 and KB = 2
* (19) Same as (8), but with KA = 3 and KB = 1
* (20) Same as (8), but with KA = 3 and KB = 2
* (21) Same as (8), but with KA = 3 and KB = 3
*
* Arguments
* =========
*
* NSIZES INTEGER
* The number of sizes of matrices to use. If it is zero,
* DDRVSG does nothing. It must be at least zero.
* Not modified.
*
* NN INTEGER array, dimension (NSIZES)
* An array containing the sizes to be used for the matrices.
* Zero values will be skipped. The values must be at least
* zero.
* Not modified.
*
* NTYPES INTEGER
* The number of elements in DOTYPE. If it is zero, DDRVSG
* does nothing. It must be at least zero. If it is MAXTYP+1
* and NSIZES is 1, then an additional type, MAXTYP+1 is
* defined, which is to use whatever matrix is in A. This
* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
* DOTYPE(MAXTYP+1) is .TRUE. .
* Not modified.
*
* DOTYPE LOGICAL array, dimension (NTYPES)
* If DOTYPE(j) is .TRUE., then for each size in NN a
* matrix of that size and of type j will be generated.
* If NTYPES is smaller than the maximum number of types
* defined (PARAMETER MAXTYP), then types NTYPES+1 through
* MAXTYP will not be generated. If NTYPES is larger
* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
* will be ignored.
* Not modified.
*
* ISEED INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The array elements should be between 0 and 4095;
* if not they will be reduced mod 4096. Also, ISEED(4) must
* be odd. The random number generator uses a linear
* congruential sequence limited to small integers, and so
* should produce machine independent random numbers. The
* values of ISEED are changed on exit, and can be used in the
* next call to DDRVSG to continue the same random number
* sequence.
* Modified.
*
* THRESH DOUBLE PRECISION
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error
* is scaled to be O(1), so THRESH should be a reasonably
* small multiple of 1, e.g., 10 or 100. In particular,
* it should not depend on the precision (single vs. double)
* or the size of the matrix. It must be at least zero.
* Not modified.
*
* NOUNIT INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns IINFO not equal to 0.)
* Not modified.
*
* A DOUBLE PRECISION array, dimension (LDA , max(NN))
* Used to hold the matrix whose eigenvalues are to be
* computed. On exit, A contains the last matrix actually
* used.
* Modified.
*
* LDA INTEGER
* The leading dimension of A and AB. It must be at
* least 1 and at least max( NN ).
* Not modified.
*
* B DOUBLE PRECISION array, dimension (LDB , max(NN))
* Used to hold the symmetric positive definite matrix for
* the generailzed problem.
* On exit, B contains the last matrix actually
* used.
* Modified.
*
* LDB INTEGER
* The leading dimension of B and BB. It must be at
* least 1 and at least max( NN ).
* Not modified.
*
* D DOUBLE PRECISION array, dimension (max(NN))
* The eigenvalues of A. On exit, the eigenvalues in D
* correspond with the matrix in A.
* Modified.
*
* Z DOUBLE PRECISION array, dimension (LDZ, max(NN))
* The matrix of eigenvectors.
* Modified.
*
* LDZ INTEGER
* The leading dimension of Z. It must be at least 1 and
* at least max( NN ).
* Not modified.
*
* AB DOUBLE PRECISION array, dimension (LDA, max(NN))
* Workspace.
* Modified.
*
* BB DOUBLE PRECISION array, dimension (LDB, max(NN))
* Workspace.
* Modified.
*
* AP DOUBLE PRECISION array, dimension (max(NN)**2)
* Workspace.
* Modified.
*
* BP DOUBLE PRECISION array, dimension (max(NN)**2)
* Workspace.
* Modified.
*
* WORK DOUBLE PRECISION array, dimension (NWORK)
* Workspace.
* Modified.
*
* NWORK INTEGER
* The number of entries in WORK. This must be at least
* 1+5*N+2*N*lg(N)+3*N**2 where N = max( NN(j) ) and
* lg( N ) = smallest integer k such that 2**k >= N.
* Not modified.
*
* IWORK INTEGER array, dimension (LIWORK)
* Workspace.
* Modified.
*
* LIWORK INTEGER
* The number of entries in WORK. This must be at least 6*N.
* Not modified.
*
* RESULT DOUBLE PRECISION array, dimension (70)
* The values computed by the 70 tests described above.
* Modified.
*
* INFO INTEGER
* If 0, then everything ran OK.
* -1: NSIZES < 0
* -2: Some NN(j) < 0
* -3: NTYPES < 0
* -5: THRESH < 0
* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
* -16: LDZ < 1 or LDZ < NMAX.
* -21: NWORK too small.
* -23: LIWORK too small.
* If DLATMR, SLATMS, DSYGV, DSPGV, DSBGV, SSYGVD, SSPGVD,
* DSBGVD, DSYGVX, DSPGVX or SSBGVX returns an error code,
* the absolute value of it is returned.
* Modified.
*
* ----------------------------------------------------------------------
*
* Some Local Variables and Parameters:
* ---- ----- --------- --- ----------
* ZERO, ONE Real 0 and 1.
* MAXTYP The number of types defined.
* NTEST The number of tests that have been run
* on this matrix.
* NTESTT The total number of tests for this call.
* NMAX Largest value in NN.
* NMATS The number of matrices generated so far.
* NERRS The number of tests which have exceeded THRESH
* so far (computed by DLAFTS).
* COND, IMODE Values to be passed to the matrix generators.
* ANORM Norm of A; passed to matrix generators.
*
* OVFL, UNFL Overflow and underflow thresholds.
* ULP, ULPINV Finest relative precision and its inverse.
* RTOVFL, RTUNFL Square roots of the previous 2 values.
* The following four arrays decode JTYPE:
* KTYPE(j) The general type (1-10) for type "j".
* KMODE(j) The MODE value to be passed to the matrix
* generator for type "j".
* KMAGN(j) The order of magnitude ( O(1),
* O(overflow^(1/2) ), O(underflow^(1/2) )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TEN
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0 )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 21 )
* ..
* .. Local Scalars ..
LOGICAL BADNN
CHARACTER UPLO
INTEGER I, IBTYPE, IBUPLO, IINFO, IJ, IL, IMODE, ITEMP,
$ ITYPE, IU, J, JCOL, JSIZE, JTYPE, KA, KA9, KB,
$ KB9, M, MTYPES, N, NERRS, NMATS, NMAX, NTEST,
$ NTESTT
DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
$ RTUNFL, ULP, ULPINV, UNFL, VL, VU
* ..
* .. Local Arrays ..
INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
$ KMAGN( MAXTYP ), KMODE( MAXTYP ),
$ KTYPE( MAXTYP )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLARND
EXTERNAL LSAME, DLAMCH, DLARND
* ..
* .. External Subroutines ..
EXTERNAL DLABAD, DLACPY, DLAFTS, DLASET, DLASUM, DLATMR,
$ DLATMS, DSBGV, DSBGVD, DSBGVX, DSGT01, DSPGV,
$ DSPGVD, DSPGVX, DSYGV, DSYGVD, DSYGVX, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN, SQRT
* ..
* .. Data statements ..
DATA KTYPE / 1, 2, 5*4, 5*5, 3*8, 6*9 /
DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
$ 2, 3, 6*1 /
DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
$ 0, 0, 6*4 /
* ..
* .. Executable Statements ..
*
* 1) Check for errors
*
NTESTT = 0
INFO = 0
*
BADNN = .FALSE.
NMAX = 0
DO 10 J = 1, NSIZES
NMAX = MAX( NMAX, NN( J ) )
IF( NN( J ).LT.0 )
$ BADNN = .TRUE.
10 CONTINUE
*
* Check for errors
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADNN ) THEN
INFO = -2
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN
INFO = -9
ELSE IF( LDZ.LE.1 .OR. LDZ.LT.NMAX ) THEN
INFO = -16
ELSE IF( 2*MAX( NMAX, 3 )**2.GT.NWORK ) THEN
INFO = -21
ELSE IF( 2*MAX( NMAX, 3 )**2.GT.LIWORK ) THEN
INFO = -23
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DDRVSG', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
$ RETURN
*
* More Important constants
*
UNFL = DLAMCH( 'Safe minimum' )
OVFL = DLAMCH( 'Overflow' )
CALL DLABAD( UNFL, OVFL )
ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
ULPINV = ONE / ULP
RTUNFL = SQRT( UNFL )
RTOVFL = SQRT( OVFL )
*
DO 20 I = 1, 4
ISEED2( I ) = ISEED( I )
20 CONTINUE
*
* Loop over sizes, types
*
NERRS = 0
NMATS = 0
*
DO 650 JSIZE = 1, NSIZES
N = NN( JSIZE )
ANINV = ONE / DBLE( MAX( 1, N ) )
*
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
KA9 = 0
KB9 = 0
DO 640 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 640
NMATS = NMATS + 1
NTEST = 0
*
DO 30 J = 1, 4
IOLDSD( J ) = ISEED( J )
30 CONTINUE
*
* 2) Compute "A"
*
* Control parameters:
*
* KMAGN KMODE KTYPE
* =1 O(1) clustered 1 zero
* =2 large clustered 2 identity
* =3 small exponential (none)
* =4 arithmetic diagonal, w/ eigenvalues
* =5 random log hermitian, w/ eigenvalues
* =6 random (none)
* =7 random diagonal
* =8 random hermitian
* =9 banded, w/ eigenvalues
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 90
*
ITYPE = KTYPE( JTYPE )
IMODE = KMODE( JTYPE )
*
* Compute norm
*
GO TO ( 40, 50, 60 )KMAGN( JTYPE )
*
40 CONTINUE
ANORM = ONE
GO TO 70
*
50 CONTINUE
ANORM = ( RTOVFL*ULP )*ANINV
GO TO 70
*
60 CONTINUE
ANORM = RTUNFL*N*ULPINV
GO TO 70
*
70 CONTINUE
*
IINFO = 0
COND = ULPINV
*
* Special Matrices -- Identity & Jordan block
*
IF( ITYPE.EQ.1 ) THEN
*
* Zero
*
KA = 0
KB = 0
CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Identity
*
KA = 0
KB = 0
CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
DO 80 JCOL = 1, N
A( JCOL, JCOL ) = ANORM
80 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Diagonal Matrix, [Eigen]values Specified
*
KA = 0
KB = 0
CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.5 ) THEN
*
* symmetric, eigenvalues specified
*
KA = MAX( 0, N-1 )
KB = KA
CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, N, N, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.7 ) THEN
*
* Diagonal, random eigenvalues
*
KA = 0
KB = 0
CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.8 ) THEN
*
* symmetric, random eigenvalues
*
KA = MAX( 0, N-1 )
KB = KA
CALL DLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.9 ) THEN
*
* symmetric banded, eigenvalues specified
*
* The following values are used for the half-bandwidths:
*
* ka = 1 kb = 1
* ka = 2 kb = 1
* ka = 2 kb = 2
* ka = 3 kb = 1
* ka = 3 kb = 2
* ka = 3 kb = 3
*
KB9 = KB9 + 1
IF( KB9.GT.KA9 ) THEN
KA9 = KA9 + 1
KB9 = 1
END IF
KA = MAX( 0, MIN( N-1, KA9 ) )
KB = MAX( 0, MIN( N-1, KB9 ) )
CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, KA, KA, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE
*
IINFO = 1
END IF
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
90 CONTINUE
*
ABSTOL = UNFL + UNFL
IF( N.LE.1 ) THEN
IL = 1
IU = N
ELSE
IL = 1 + ( N-1 )*DLARND( 1, ISEED2 )
IU = 1 + ( N-1 )*DLARND( 1, ISEED2 )
IF( IL.GT.IU ) THEN
ITEMP = IL
IL = IU
IU = ITEMP
END IF
END IF
*
* 3) Call DSYGV, DSPGV, DSBGV, SSYGVD, SSPGVD, SSBGVD,
* DSYGVX, DSPGVX, and DSBGVX, do tests.
*
* loop over the three generalized problems
* IBTYPE = 1: A*x = (lambda)*B*x
* IBTYPE = 2: A*B*x = (lambda)*x
* IBTYPE = 3: B*A*x = (lambda)*x
*
DO 630 IBTYPE = 1, 3
*
* loop over the setting UPLO
*
DO 620 IBUPLO = 1, 2
IF( IBUPLO.EQ.1 )
$ UPLO = 'U'
IF( IBUPLO.EQ.2 )
$ UPLO = 'L'
*
* Generate random well-conditioned positive definite
* matrix B, of bandwidth not greater than that of A.
*
CALL DLATMS( N, N, 'U', ISEED, 'P', WORK, 5, TEN, ONE,
$ KB, KB, UPLO, B, LDB, WORK( N+1 ),
$ IINFO )
*
* Test DSYGV
*
NTEST = NTEST + 1
*
CALL DLACPY( ' ', N, N, A, LDA, Z, LDZ )
CALL DLACPY( UPLO, N, N, B, LDB, BB, LDB )
*
CALL DSYGV( IBTYPE, 'V', UPLO, N, Z, LDZ, BB, LDB, D,
$ WORK, NWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSYGV(V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 100
END IF
END IF
*
* Do Test
*
CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
* Test DSYGVD
*
NTEST = NTEST + 1
*
CALL DLACPY( ' ', N, N, A, LDA, Z, LDZ )
CALL DLACPY( UPLO, N, N, B, LDB, BB, LDB )
*
CALL DSYGVD( IBTYPE, 'V', UPLO, N, Z, LDZ, BB, LDB, D,
$ WORK, NWORK, IWORK, LIWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSYGVD(V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 100
END IF
END IF
*
* Do Test
*
CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
* Test DSYGVX
*
NTEST = NTEST + 1
*
CALL DLACPY( ' ', N, N, A, LDA, AB, LDA )
CALL DLACPY( UPLO, N, N, B, LDB, BB, LDB )
*
CALL DSYGVX( IBTYPE, 'V', 'A', UPLO, N, AB, LDA, BB,
$ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z,
$ LDZ, WORK, NWORK, IWORK( N+1 ), IWORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSYGVX(V,A' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 100
END IF
END IF
*
* Do Test
*
CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 1
*
CALL DLACPY( ' ', N, N, A, LDA, AB, LDA )
CALL DLACPY( UPLO, N, N, B, LDB, BB, LDB )
*
* since we do not know the exact eigenvalues of this
* eigenpair, we just set VL and VU as constants.
* It is quite possible that there are no eigenvalues
* in this interval.
*
VL = ZERO
VU = ANORM
CALL DSYGVX( IBTYPE, 'V', 'V', UPLO, N, AB, LDA, BB,
$ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z,
$ LDZ, WORK, NWORK, IWORK( N+1 ), IWORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSYGVX(V,V,' //
$ UPLO // ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 100
END IF
END IF
*
* Do Test
*
CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 1
*
CALL DLACPY( ' ', N, N, A, LDA, AB, LDA )
CALL DLACPY( UPLO, N, N, B, LDB, BB, LDB )
*
CALL DSYGVX( IBTYPE, 'V', 'I', UPLO, N, AB, LDA, BB,
$ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z,
$ LDZ, WORK, NWORK, IWORK( N+1 ), IWORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSYGVX(V,I,' //
$ UPLO // ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 100
END IF
END IF
*
* Do Test
*
CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
100 CONTINUE
*
* Test DSPGV
*
NTEST = NTEST + 1
*
* Copy the matrices into packed storage.
*
IF( LSAME( UPLO, 'U' ) ) THEN
IJ = 1
DO 120 J = 1, N
DO 110 I = 1, J
AP( IJ ) = A( I, J )
BP( IJ ) = B( I, J )
IJ = IJ + 1
110 CONTINUE
120 CONTINUE
ELSE
IJ = 1
DO 140 J = 1, N
DO 130 I = J, N
AP( IJ ) = A( I, J )
BP( IJ ) = B( I, J )
IJ = IJ + 1
130 CONTINUE
140 CONTINUE
END IF
*
CALL DSPGV( IBTYPE, 'V', UPLO, N, AP, BP, D, Z, LDZ,
$ WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSPGV(V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 310
END IF
END IF
*
* Do Test
*
CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
* Test DSPGVD
*
NTEST = NTEST + 1
*
* Copy the matrices into packed storage.
*
IF( LSAME( UPLO, 'U' ) ) THEN
IJ = 1
DO 160 J = 1, N
DO 150 I = 1, J
AP( IJ ) = A( I, J )
BP( IJ ) = B( I, J )
IJ = IJ + 1
150 CONTINUE
160 CONTINUE
ELSE
IJ = 1
DO 180 J = 1, N
DO 170 I = J, N
AP( IJ ) = A( I, J )
BP( IJ ) = B( I, J )
IJ = IJ + 1
170 CONTINUE
180 CONTINUE
END IF
*
CALL DSPGVD( IBTYPE, 'V', UPLO, N, AP, BP, D, Z, LDZ,
$ WORK, NWORK, IWORK, LIWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSPGVD(V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 310
END IF
END IF
*
* Do Test
*
CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
* Test DSPGVX
*
NTEST = NTEST + 1
*
* Copy the matrices into packed storage.
*
IF( LSAME( UPLO, 'U' ) ) THEN
IJ = 1
DO 200 J = 1, N
DO 190 I = 1, J
AP( IJ ) = A( I, J )
BP( IJ ) = B( I, J )
IJ = IJ + 1
190 CONTINUE
200 CONTINUE
ELSE
IJ = 1
DO 220 J = 1, N
DO 210 I = J, N
AP( IJ ) = A( I, J )
BP( IJ ) = B( I, J )
IJ = IJ + 1
210 CONTINUE
220 CONTINUE
END IF
*
CALL DSPGVX( IBTYPE, 'V', 'A', UPLO, N, AP, BP, VL,
$ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK,
$ IWORK( N+1 ), IWORK, INFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSPGVX(V,A' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 310
END IF
END IF
*
* Do Test
*
CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 1
*
* Copy the matrices into packed storage.
*
IF( LSAME( UPLO, 'U' ) ) THEN
IJ = 1
DO 240 J = 1, N
DO 230 I = 1, J
AP( IJ ) = A( I, J )
BP( IJ ) = B( I, J )
IJ = IJ + 1
230 CONTINUE
240 CONTINUE
ELSE
IJ = 1
DO 260 J = 1, N
DO 250 I = J, N
AP( IJ ) = A( I, J )
BP( IJ ) = B( I, J )
IJ = IJ + 1
250 CONTINUE
260 CONTINUE
END IF
*
VL = ZERO
VU = ANORM
CALL DSPGVX( IBTYPE, 'V', 'V', UPLO, N, AP, BP, VL,
$ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK,
$ IWORK( N+1 ), IWORK, INFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSPGVX(V,V' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 310
END IF
END IF
*
* Do Test
*
CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 1
*
* Copy the matrices into packed storage.
*
IF( LSAME( UPLO, 'U' ) ) THEN
IJ = 1
DO 280 J = 1, N
DO 270 I = 1, J
AP( IJ ) = A( I, J )
BP( IJ ) = B( I, J )
IJ = IJ + 1
270 CONTINUE
280 CONTINUE
ELSE
IJ = 1
DO 300 J = 1, N
DO 290 I = J, N
AP( IJ ) = A( I, J )
BP( IJ ) = B( I, J )
IJ = IJ + 1
290 CONTINUE
300 CONTINUE
END IF
*
CALL DSPGVX( IBTYPE, 'V', 'I', UPLO, N, AP, BP, VL,
$ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK,
$ IWORK( N+1 ), IWORK, INFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSPGVX(V,I' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 310
END IF
END IF
*
* Do Test
*
CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
310 CONTINUE
*
IF( IBTYPE.EQ.1 ) THEN
*
* TEST DSBGV
*
NTEST = NTEST + 1
*
* Copy the matrices into band storage.
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 340 J = 1, N
DO 320 I = MAX( 1, J-KA ), J
AB( KA+1+I-J, J ) = A( I, J )
320 CONTINUE
DO 330 I = MAX( 1, J-KB ), J
BB( KB+1+I-J, J ) = B( I, J )
330 CONTINUE
340 CONTINUE
ELSE
DO 370 J = 1, N
DO 350 I = J, MIN( N, J+KA )
AB( 1+I-J, J ) = A( I, J )
350 CONTINUE
DO 360 I = J, MIN( N, J+KB )
BB( 1+I-J, J ) = B( I, J )
360 CONTINUE
370 CONTINUE
END IF
*
CALL DSBGV( 'V', UPLO, N, KA, KB, AB, LDA, BB, LDB,
$ D, Z, LDZ, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSBGV(V,' //
$ UPLO // ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 620
END IF
END IF
*
* Do Test
*
CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
* TEST DSBGVD
*
NTEST = NTEST + 1
*
* Copy the matrices into band storage.
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 400 J = 1, N
DO 380 I = MAX( 1, J-KA ), J
AB( KA+1+I-J, J ) = A( I, J )
380 CONTINUE
DO 390 I = MAX( 1, J-KB ), J
BB( KB+1+I-J, J ) = B( I, J )
390 CONTINUE
400 CONTINUE
ELSE
DO 430 J = 1, N
DO 410 I = J, MIN( N, J+KA )
AB( 1+I-J, J ) = A( I, J )
410 CONTINUE
DO 420 I = J, MIN( N, J+KB )
BB( 1+I-J, J ) = B( I, J )
420 CONTINUE
430 CONTINUE
END IF
*
CALL DSBGVD( 'V', UPLO, N, KA, KB, AB, LDA, BB,
$ LDB, D, Z, LDZ, WORK, NWORK, IWORK,
$ LIWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSBGVD(V,' //
$ UPLO // ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 620
END IF
END IF
*
* Do Test
*
CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
* Test DSBGVX
*
NTEST = NTEST + 1
*
* Copy the matrices into band storage.
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 460 J = 1, N
DO 440 I = MAX( 1, J-KA ), J
AB( KA+1+I-J, J ) = A( I, J )
440 CONTINUE
DO 450 I = MAX( 1, J-KB ), J
BB( KB+1+I-J, J ) = B( I, J )
450 CONTINUE
460 CONTINUE
ELSE
DO 490 J = 1, N
DO 470 I = J, MIN( N, J+KA )
AB( 1+I-J, J ) = A( I, J )
470 CONTINUE
DO 480 I = J, MIN( N, J+KB )
BB( 1+I-J, J ) = B( I, J )
480 CONTINUE
490 CONTINUE
END IF
*
CALL DSBGVX( 'V', 'A', UPLO, N, KA, KB, AB, LDA,
$ BB, LDB, BP, MAX( 1, N ), VL, VU, IL,
$ IU, ABSTOL, M, D, Z, LDZ, WORK,
$ IWORK( N+1 ), IWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSBGVX(V,A' //
$ UPLO // ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 620
END IF
END IF
*
* Do Test
*
CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
*
NTEST = NTEST + 1
*
* Copy the matrices into band storage.
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 520 J = 1, N
DO 500 I = MAX( 1, J-KA ), J
AB( KA+1+I-J, J ) = A( I, J )
500 CONTINUE
DO 510 I = MAX( 1, J-KB ), J
BB( KB+1+I-J, J ) = B( I, J )
510 CONTINUE
520 CONTINUE
ELSE
DO 550 J = 1, N
DO 530 I = J, MIN( N, J+KA )
AB( 1+I-J, J ) = A( I, J )
530 CONTINUE
DO 540 I = J, MIN( N, J+KB )
BB( 1+I-J, J ) = B( I, J )
540 CONTINUE
550 CONTINUE
END IF
*
VL = ZERO
VU = ANORM
CALL DSBGVX( 'V', 'V', UPLO, N, KA, KB, AB, LDA,
$ BB, LDB, BP, MAX( 1, N ), VL, VU, IL,
$ IU, ABSTOL, M, D, Z, LDZ, WORK,
$ IWORK( N+1 ), IWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSBGVX(V,V' //
$ UPLO // ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 620
END IF
END IF
*
* Do Test
*
CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 1
*
* Copy the matrices into band storage.
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 580 J = 1, N
DO 560 I = MAX( 1, J-KA ), J
AB( KA+1+I-J, J ) = A( I, J )
560 CONTINUE
DO 570 I = MAX( 1, J-KB ), J
BB( KB+1+I-J, J ) = B( I, J )
570 CONTINUE
580 CONTINUE
ELSE
DO 610 J = 1, N
DO 590 I = J, MIN( N, J+KA )
AB( 1+I-J, J ) = A( I, J )
590 CONTINUE
DO 600 I = J, MIN( N, J+KB )
BB( 1+I-J, J ) = B( I, J )
600 CONTINUE
610 CONTINUE
END IF
*
CALL DSBGVX( 'V', 'I', UPLO, N, KA, KB, AB, LDA,
$ BB, LDB, BP, MAX( 1, N ), VL, VU, IL,
$ IU, ABSTOL, M, D, Z, LDZ, WORK,
$ IWORK( N+1 ), IWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSBGVX(V,I' //
$ UPLO // ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 620
END IF
END IF
*
* Do Test
*
CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
END IF
*
620 CONTINUE
630 CONTINUE
*
* End of Loop -- Check for RESULT(j) > THRESH
*
NTESTT = NTESTT + NTEST
CALL DLAFTS( 'DSG', N, N, JTYPE, NTEST, RESULT, IOLDSD,
$ THRESH, NOUNIT, NERRS )
640 CONTINUE
650 CONTINUE
*
* Summary
*
CALL DLASUM( 'DSG', NOUNIT, NERRS, NTESTT )
*
RETURN
*
* End of DDRVSG
*
9999 FORMAT( ' DDRVSG: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
END
SUBROUTINE DDRVST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
$ NOUNIT, A, LDA, D1, D2, D3, D4, EVEIGS, WA1,
$ WA2, WA3, U, LDU, V, TAU, Z, WORK, LWORK,
$ IWORK, LIWORK, RESULT, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES,
$ NTYPES
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER ISEED( 4 ), IWORK( * ), NN( * )
DOUBLE PRECISION A( LDA, * ), D1( * ), D2( * ), D3( * ),
$ D4( * ), EVEIGS( * ), RESULT( * ), TAU( * ),
$ U( LDU, * ), V( LDU, * ), WA1( * ), WA2( * ),
$ WA3( * ), WORK( * ), Z( LDU, * )
* ..
*
* Purpose
* =======
*
* DDRVST checks the symmetric eigenvalue problem drivers.
*
* DSTEV computes all eigenvalues and, optionally,
* eigenvectors of a real symmetric tridiagonal matrix.
*
* DSTEVX computes selected eigenvalues and, optionally,
* eigenvectors of a real symmetric tridiagonal matrix.
*
* DSTEVR computes selected eigenvalues and, optionally,
* eigenvectors of a real symmetric tridiagonal matrix
* using the Relatively Robust Representation where it can.
*
* DSYEV computes all eigenvalues and, optionally,
* eigenvectors of a real symmetric matrix.
*
* DSYEVX computes selected eigenvalues and, optionally,
* eigenvectors of a real symmetric matrix.
*
* DSYEVR computes selected eigenvalues and, optionally,
* eigenvectors of a real symmetric matrix
* using the Relatively Robust Representation where it can.
*
* DSPEV computes all eigenvalues and, optionally,
* eigenvectors of a real symmetric matrix in packed
* storage.
*
* DSPEVX computes selected eigenvalues and, optionally,
* eigenvectors of a real symmetric matrix in packed
* storage.
*
* DSBEV computes all eigenvalues and, optionally,
* eigenvectors of a real symmetric band matrix.
*
* DSBEVX computes selected eigenvalues and, optionally,
* eigenvectors of a real symmetric band matrix.
*
* DSYEVD computes all eigenvalues and, optionally,
* eigenvectors of a real symmetric matrix using
* a divide and conquer algorithm.
*
* DSPEVD computes all eigenvalues and, optionally,
* eigenvectors of a real symmetric matrix in packed
* storage, using a divide and conquer algorithm.
*
* DSBEVD computes all eigenvalues and, optionally,
* eigenvectors of a real symmetric band matrix,
* using a divide and conquer algorithm.
*
* When DDRVST is called, a number of matrix "sizes" ("n's") and a
* number of matrix "types" are specified. For each size ("n")
* and each type of matrix, one matrix will be generated and used
* to test the appropriate drivers. For each matrix and each
* driver routine called, the following tests will be performed:
*
* (1) | A - Z D Z' | / ( |A| n ulp )
*
* (2) | I - Z Z' | / ( n ulp )
*
* (3) | D1 - D2 | / ( |D1| ulp )
*
* where Z is the matrix of eigenvectors returned when the
* eigenvector option is given and D1 and D2 are the eigenvalues
* returned with and without the eigenvector option.
*
* The "sizes" are specified by an array NN(1:NSIZES); the value of
* each element NN(j) specifies one size.
* The "types" are specified by a logical array DOTYPE( 1:NTYPES );
* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
* Currently, the list of possible types is:
*
* (1) The zero matrix.
* (2) The identity matrix.
*
* (3) A diagonal matrix with evenly spaced eigenvalues
* 1, ..., ULP and random signs.
* (ULP = (first number larger than 1) - 1 )
* (4) A diagonal matrix with geometrically spaced eigenvalues
* 1, ..., ULP and random signs.
* (5) A diagonal matrix with "clustered" eigenvalues
* 1, ULP, ..., ULP and random signs.
*
* (6) Same as (4), but multiplied by SQRT( overflow threshold )
* (7) Same as (4), but multiplied by SQRT( underflow threshold )
*
* (8) A matrix of the form U' D U, where U is orthogonal and
* D has evenly spaced entries 1, ..., ULP with random signs
* on the diagonal.
*
* (9) A matrix of the form U' D U, where U is orthogonal and
* D has geometrically spaced entries 1, ..., ULP with random
* signs on the diagonal.
*
* (10) A matrix of the form U' D U, where U is orthogonal and
* D has "clustered" entries 1, ULP,..., ULP with random
* signs on the diagonal.
*
* (11) Same as (8), but multiplied by SQRT( overflow threshold )
* (12) Same as (8), but multiplied by SQRT( underflow threshold )
*
* (13) Symmetric matrix with random entries chosen from (-1,1).
* (14) Same as (13), but multiplied by SQRT( overflow threshold )
* (15) Same as (13), but multiplied by SQRT( underflow threshold )
* (16) A band matrix with half bandwidth randomly chosen between
* 0 and N-1, with evenly spaced eigenvalues 1, ..., ULP
* with random signs.
* (17) Same as (16), but multiplied by SQRT( overflow threshold )
* (18) Same as (16), but multiplied by SQRT( underflow threshold )
*
* Arguments
* =========
*
* NSIZES INTEGER
* The number of sizes of matrices to use. If it is zero,
* DDRVST does nothing. It must be at least zero.
* Not modified.
*
* NN INTEGER array, dimension (NSIZES)
* An array containing the sizes to be used for the matrices.
* Zero values will be skipped. The values must be at least
* zero.
* Not modified.
*
* NTYPES INTEGER
* The number of elements in DOTYPE. If it is zero, DDRVST
* does nothing. It must be at least zero. If it is MAXTYP+1
* and NSIZES is 1, then an additional type, MAXTYP+1 is
* defined, which is to use whatever matrix is in A. This
* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
* DOTYPE(MAXTYP+1) is .TRUE. .
* Not modified.
*
* DOTYPE LOGICAL array, dimension (NTYPES)
* If DOTYPE(j) is .TRUE., then for each size in NN a
* matrix of that size and of type j will be generated.
* If NTYPES is smaller than the maximum number of types
* defined (PARAMETER MAXTYP), then types NTYPES+1 through
* MAXTYP will not be generated. If NTYPES is larger
* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
* will be ignored.
* Not modified.
*
* ISEED INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The array elements should be between 0 and 4095;
* if not they will be reduced mod 4096. Also, ISEED(4) must
* be odd. The random number generator uses a linear
* congruential sequence limited to small integers, and so
* should produce machine independent random numbers. The
* values of ISEED are changed on exit, and can be used in the
* next call to DDRVST to continue the same random number
* sequence.
* Modified.
*
* THRESH DOUBLE PRECISION
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error
* is scaled to be O(1), so THRESH should be a reasonably
* small multiple of 1, e.g., 10 or 100. In particular,
* it should not depend on the precision (single vs. double)
* or the size of the matrix. It must be at least zero.
* Not modified.
*
* NOUNIT INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns IINFO not equal to 0.)
* Not modified.
*
* A DOUBLE PRECISION array, dimension (LDA , max(NN))
* Used to hold the matrix whose eigenvalues are to be
* computed. On exit, A contains the last matrix actually
* used.
* Modified.
*
* LDA INTEGER
* The leading dimension of A. It must be at
* least 1 and at least max( NN ).
* Not modified.
*
* D1 DOUBLE PRECISION array, dimension (max(NN))
* The eigenvalues of A, as computed by DSTEQR simlutaneously
* with Z. On exit, the eigenvalues in D1 correspond with the
* matrix in A.
* Modified.
*
* D2 DOUBLE PRECISION array, dimension (max(NN))
* The eigenvalues of A, as computed by DSTEQR if Z is not
* computed. On exit, the eigenvalues in D2 correspond with
* the matrix in A.
* Modified.
*
* D3 DOUBLE PRECISION array, dimension (max(NN))
* The eigenvalues of A, as computed by DSTERF. On exit, the
* eigenvalues in D3 correspond with the matrix in A.
* Modified.
*
* D4 DOUBLE PRECISION array, dimension
*
* EVEIGS DOUBLE PRECISION array, dimension (max(NN))
* The eigenvalues as computed by DSTEV('N', ... )
* (I reserve the right to change this to the output of
* whichever algorithm computes the most accurate eigenvalues).
*
* WA1 DOUBLE PRECISION array, dimension
*
* WA2 DOUBLE PRECISION array, dimension
*
* WA3 DOUBLE PRECISION array, dimension
*
* U DOUBLE PRECISION array, dimension (LDU, max(NN))
* The orthogonal matrix computed by DSYTRD + DORGTR.
* Modified.
*
* LDU INTEGER
* The leading dimension of U, Z, and V. It must be at
* least 1 and at least max( NN ).
* Not modified.
*
* V DOUBLE PRECISION array, dimension (LDU, max(NN))
* The Housholder vectors computed by DSYTRD in reducing A to
* tridiagonal form.
* Modified.
*
* TAU DOUBLE PRECISION array, dimension (max(NN))
* The Householder factors computed by DSYTRD in reducing A
* to tridiagonal form.
* Modified.
*
* Z DOUBLE PRECISION array, dimension (LDU, max(NN))
* The orthogonal matrix of eigenvectors computed by DSTEQR,
* DPTEQR, and DSTEIN.
* Modified.
*
* WORK DOUBLE PRECISION array, dimension (LWORK)
* Workspace.
* Modified.
*
* LWORK INTEGER
* The number of entries in WORK. This must be at least
* 1 + 4 * Nmax + 2 * Nmax * lg Nmax + 4 * Nmax**2
* where Nmax = max( NN(j), 2 ) and lg = log base 2.
* Not modified.
*
* IWORK INTEGER array,
* dimension (6 + 6*Nmax + 5 * Nmax * lg Nmax )
* where Nmax = max( NN(j), 2 ) and lg = log base 2.
* Workspace.
* Modified.
*
* RESULT DOUBLE PRECISION array, dimension (105)
* The values computed by the tests described above.
* The values are currently limited to 1/ulp, to avoid
* overflow.
* Modified.
*
* INFO INTEGER
* If 0, then everything ran OK.
* -1: NSIZES < 0
* -2: Some NN(j) < 0
* -3: NTYPES < 0
* -5: THRESH < 0
* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
* -16: LDU < 1 or LDU < NMAX.
* -21: LWORK too small.
* If DLATMR, DLATMS, DSYTRD, DORGTR, DSTEQR, DSTERF,
* or DORMTR returns an error code, the
* absolute value of it is returned.
* Modified.
*
*-----------------------------------------------------------------------
*
* Some Local Variables and Parameters:
* ---- ----- --------- --- ----------
* ZERO, ONE Real 0 and 1.
* MAXTYP The number of types defined.
* NTEST The number of tests performed, or which can
* be performed so far, for the current matrix.
* NTESTT The total number of tests performed so far.
* NMAX Largest value in NN.
* NMATS The number of matrices generated so far.
* NERRS The number of tests which have exceeded THRESH
* so far (computed by DLAFTS).
* COND, IMODE Values to be passed to the matrix generators.
* ANORM Norm of A; passed to matrix generators.
*
* OVFL, UNFL Overflow and underflow thresholds.
* ULP, ULPINV Finest relative precision and its inverse.
* RTOVFL, RTUNFL Square roots of the previous 2 values.
* The following four arrays decode JTYPE:
* KTYPE(j) The general type (1-10) for type "j".
* KMODE(j) The MODE value to be passed to the matrix
* generator for type "j".
* KMAGN(j) The order of magnitude ( O(1),
* O(overflow^(1/2) ), O(underflow^(1/2) )
*
* The tests performed are: Routine tested
* 1= | A - U S U' | / ( |A| n ulp ) DSTEV('V', ... )
* 2= | I - U U' | / ( n ulp ) DSTEV('V', ... )
* 3= |D(with Z) - D(w/o Z)| / (|D| ulp) DSTEV('N', ... )
* 4= | A - U S U' | / ( |A| n ulp ) DSTEVX('V','A', ... )
* 5= | I - U U' | / ( n ulp ) DSTEVX('V','A', ... )
* 6= |D(with Z) - EVEIGS| / (|D| ulp) DSTEVX('N','A', ... )
* 7= | A - U S U' | / ( |A| n ulp ) DSTEVR('V','A', ... )
* 8= | I - U U' | / ( n ulp ) DSTEVR('V','A', ... )
* 9= |D(with Z) - EVEIGS| / (|D| ulp) DSTEVR('N','A', ... )
* 10= | A - U S U' | / ( |A| n ulp ) DSTEVX('V','I', ... )
* 11= | I - U U' | / ( n ulp ) DSTEVX('V','I', ... )
* 12= |D(with Z) - D(w/o Z)| / (|D| ulp) DSTEVX('N','I', ... )
* 13= | A - U S U' | / ( |A| n ulp ) DSTEVX('V','V', ... )
* 14= | I - U U' | / ( n ulp ) DSTEVX('V','V', ... )
* 15= |D(with Z) - D(w/o Z)| / (|D| ulp) DSTEVX('N','V', ... )
* 16= | A - U S U' | / ( |A| n ulp ) DSTEVD('V', ... )
* 17= | I - U U' | / ( n ulp ) DSTEVD('V', ... )
* 18= |D(with Z) - EVEIGS| / (|D| ulp) DSTEVD('N', ... )
* 19= | A - U S U' | / ( |A| n ulp ) DSTEVR('V','I', ... )
* 20= | I - U U' | / ( n ulp ) DSTEVR('V','I', ... )
* 21= |D(with Z) - D(w/o Z)| / (|D| ulp) DSTEVR('N','I', ... )
* 22= | A - U S U' | / ( |A| n ulp ) DSTEVR('V','V', ... )
* 23= | I - U U' | / ( n ulp ) DSTEVR('V','V', ... )
* 24= |D(with Z) - D(w/o Z)| / (|D| ulp) DSTEVR('N','V', ... )
*
* 25= | A - U S U' | / ( |A| n ulp ) DSYEV('L','V', ... )
* 26= | I - U U' | / ( n ulp ) DSYEV('L','V', ... )
* 27= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEV('L','N', ... )
* 28= | A - U S U' | / ( |A| n ulp ) DSYEVX('L','V','A', ... )
* 29= | I - U U' | / ( n ulp ) DSYEVX('L','V','A', ... )
* 30= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVX('L','N','A', ... )
* 31= | A - U S U' | / ( |A| n ulp ) DSYEVX('L','V','I', ... )
* 32= | I - U U' | / ( n ulp ) DSYEVX('L','V','I', ... )
* 33= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVX('L','N','I', ... )
* 34= | A - U S U' | / ( |A| n ulp ) DSYEVX('L','V','V', ... )
* 35= | I - U U' | / ( n ulp ) DSYEVX('L','V','V', ... )
* 36= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVX('L','N','V', ... )
* 37= | A - U S U' | / ( |A| n ulp ) DSPEV('L','V', ... )
* 38= | I - U U' | / ( n ulp ) DSPEV('L','V', ... )
* 39= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEV('L','N', ... )
* 40= | A - U S U' | / ( |A| n ulp ) DSPEVX('L','V','A', ... )
* 41= | I - U U' | / ( n ulp ) DSPEVX('L','V','A', ... )
* 42= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVX('L','N','A', ... )
* 43= | A - U S U' | / ( |A| n ulp ) DSPEVX('L','V','I', ... )
* 44= | I - U U' | / ( n ulp ) DSPEVX('L','V','I', ... )
* 45= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVX('L','N','I', ... )
* 46= | A - U S U' | / ( |A| n ulp ) DSPEVX('L','V','V', ... )
* 47= | I - U U' | / ( n ulp ) DSPEVX('L','V','V', ... )
* 48= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVX('L','N','V', ... )
* 49= | A - U S U' | / ( |A| n ulp ) DSBEV('L','V', ... )
* 50= | I - U U' | / ( n ulp ) DSBEV('L','V', ... )
* 51= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEV('L','N', ... )
* 52= | A - U S U' | / ( |A| n ulp ) DSBEVX('L','V','A', ... )
* 53= | I - U U' | / ( n ulp ) DSBEVX('L','V','A', ... )
* 54= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVX('L','N','A', ... )
* 55= | A - U S U' | / ( |A| n ulp ) DSBEVX('L','V','I', ... )
* 56= | I - U U' | / ( n ulp ) DSBEVX('L','V','I', ... )
* 57= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVX('L','N','I', ... )
* 58= | A - U S U' | / ( |A| n ulp ) DSBEVX('L','V','V', ... )
* 59= | I - U U' | / ( n ulp ) DSBEVX('L','V','V', ... )
* 60= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVX('L','N','V', ... )
* 61= | A - U S U' | / ( |A| n ulp ) DSYEVD('L','V', ... )
* 62= | I - U U' | / ( n ulp ) DSYEVD('L','V', ... )
* 63= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVD('L','N', ... )
* 64= | A - U S U' | / ( |A| n ulp ) DSPEVD('L','V', ... )
* 65= | I - U U' | / ( n ulp ) DSPEVD('L','V', ... )
* 66= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVD('L','N', ... )
* 67= | A - U S U' | / ( |A| n ulp ) DSBEVD('L','V', ... )
* 68= | I - U U' | / ( n ulp ) DSBEVD('L','V', ... )
* 69= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVD('L','N', ... )
* 70= | A - U S U' | / ( |A| n ulp ) DSYEVR('L','V','A', ... )
* 71= | I - U U' | / ( n ulp ) DSYEVR('L','V','A', ... )
* 72= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVR('L','N','A', ... )
* 73= | A - U S U' | / ( |A| n ulp ) DSYEVR('L','V','I', ... )
* 74= | I - U U' | / ( n ulp ) DSYEVR('L','V','I', ... )
* 75= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVR('L','N','I', ... )
* 76= | A - U S U' | / ( |A| n ulp ) DSYEVR('L','V','V', ... )
* 77= | I - U U' | / ( n ulp ) DSYEVR('L','V','V', ... )
* 78= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVR('L','N','V', ... )
*
* Tests 25 through 78 are repeated (as tests 79 through 132)
* with UPLO='U'
*
* To be added in 1999
*
* 79= | A - U S U' | / ( |A| n ulp ) DSPEVR('L','V','A', ... )
* 80= | I - U U' | / ( n ulp ) DSPEVR('L','V','A', ... )
* 81= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVR('L','N','A', ... )
* 82= | A - U S U' | / ( |A| n ulp ) DSPEVR('L','V','I', ... )
* 83= | I - U U' | / ( n ulp ) DSPEVR('L','V','I', ... )
* 84= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVR('L','N','I', ... )
* 85= | A - U S U' | / ( |A| n ulp ) DSPEVR('L','V','V', ... )
* 86= | I - U U' | / ( n ulp ) DSPEVR('L','V','V', ... )
* 87= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVR('L','N','V', ... )
* 88= | A - U S U' | / ( |A| n ulp ) DSBEVR('L','V','A', ... )
* 89= | I - U U' | / ( n ulp ) DSBEVR('L','V','A', ... )
* 90= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVR('L','N','A', ... )
* 91= | A - U S U' | / ( |A| n ulp ) DSBEVR('L','V','I', ... )
* 92= | I - U U' | / ( n ulp ) DSBEVR('L','V','I', ... )
* 93= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVR('L','N','I', ... )
* 94= | A - U S U' | / ( |A| n ulp ) DSBEVR('L','V','V', ... )
* 95= | I - U U' | / ( n ulp ) DSBEVR('L','V','V', ... )
* 96= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVR('L','N','V', ... )
*
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, TEN
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ TEN = 10.0D0 )
DOUBLE PRECISION HALF
PARAMETER ( HALF = 0.5D0 )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 18 )
* ..
* .. Local Scalars ..
LOGICAL BADNN
CHARACTER UPLO
INTEGER I, IDIAG, IHBW, IINFO, IL, IMODE, INDX, IROW,
$ ITEMP, ITYPE, IU, IUPLO, J, J1, J2, JCOL,
$ JSIZE, JTYPE, KD, LGN, LIWEDC, LWEDC, M, M2,
$ M3, MTYPES, N, NERRS, NMATS, NMAX, NTEST,
$ NTESTT
DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
$ RTUNFL, TEMP1, TEMP2, TEMP3, ULP, ULPINV, UNFL,
$ VL, VU
* ..
* .. Local Arrays ..
INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
$ ISEED3( 4 ), KMAGN( MAXTYP ), KMODE( MAXTYP ),
$ KTYPE( MAXTYP )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLARND, DSXT1
EXTERNAL DLAMCH, DLARND, DSXT1
* ..
* .. External Subroutines ..
EXTERNAL ALASVM, DLABAD, DLACPY, DLAFTS, DLASET, DLATMR,
$ DLATMS, DSBEV, DSBEVD, DSBEVX, DSPEV, DSPEVD,
$ DSPEVX, DSTEV, DSTEVD, DSTEVR, DSTEVX, DSTT21,
$ DSTT22, DSYEV, DSYEVD, DSYEVR, DSYEVX, DSYT21,
$ DSYT22, XERBLA
* ..
* .. Scalars in Common ..
CHARACTER*6 SRNAMT
* ..
* .. Common blocks ..
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, INT, LOG, MAX, MIN, SQRT
* ..
* .. Data statements ..
DATA KTYPE / 1, 2, 5*4, 5*5, 3*8, 3*9 /
DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
$ 2, 3, 1, 2, 3 /
DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
$ 0, 0, 4, 4, 4 /
* ..
* .. Executable Statements ..
*
* Keep ftrnchek happy
*
VL = ZERO
VU = ZERO
*
* 1) Check for errors
*
NTESTT = 0
INFO = 0
*
BADNN = .FALSE.
NMAX = 1
DO 10 J = 1, NSIZES
NMAX = MAX( NMAX, NN( J ) )
IF( NN( J ).LT.0 )
$ BADNN = .TRUE.
10 CONTINUE
*
* Check for errors
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADNN ) THEN
INFO = -2
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.NMAX ) THEN
INFO = -9
ELSE IF( LDU.LT.NMAX ) THEN
INFO = -16
ELSE IF( 2*MAX( 2, NMAX )**2.GT.LWORK ) THEN
INFO = -21
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DDRVST', -INFO )
RETURN
END IF
*
* Quick return if nothing to do
*
IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
$ RETURN
*
* More Important constants
*
UNFL = DLAMCH( 'Safe minimum' )
OVFL = DLAMCH( 'Overflow' )
CALL DLABAD( UNFL, OVFL )
ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
ULPINV = ONE / ULP
RTUNFL = SQRT( UNFL )
RTOVFL = SQRT( OVFL )
*
* Loop over sizes, types
*
DO 20 I = 1, 4
ISEED2( I ) = ISEED( I )
ISEED3( I ) = ISEED( I )
20 CONTINUE
*
NERRS = 0
NMATS = 0
*
*
DO 1740 JSIZE = 1, NSIZES
N = NN( JSIZE )
IF( N.GT.0 ) THEN
LGN = INT( LOG( DBLE( N ) ) / LOG( TWO ) )
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
LWEDC = 1 + 4*N + 2*N*LGN + 4*N**2
c LIWEDC = 6 + 6*N + 5*N*LGN
LIWEDC = 3 + 5*N
ELSE
LWEDC = 9
c LIWEDC = 12
LIWEDC = 8
END IF
ANINV = ONE / DBLE( MAX( 1, N ) )
*
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
DO 1730 JTYPE = 1, MTYPES
*
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 1730
NMATS = NMATS + 1
NTEST = 0
*
DO 30 J = 1, 4
IOLDSD( J ) = ISEED( J )
30 CONTINUE
*
* 2) Compute "A"
*
* Control parameters:
*
* KMAGN KMODE KTYPE
* =1 O(1) clustered 1 zero
* =2 large clustered 2 identity
* =3 small exponential (none)
* =4 arithmetic diagonal, (w/ eigenvalues)
* =5 random log symmetric, w/ eigenvalues
* =6 random (none)
* =7 random diagonal
* =8 random symmetric
* =9 band symmetric, w/ eigenvalues
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 110
*
ITYPE = KTYPE( JTYPE )
IMODE = KMODE( JTYPE )
*
* Compute norm
*
GO TO ( 40, 50, 60 )KMAGN( JTYPE )
*
40 CONTINUE
ANORM = ONE
GO TO 70
*
50 CONTINUE
ANORM = ( RTOVFL*ULP )*ANINV
GO TO 70
*
60 CONTINUE
ANORM = RTUNFL*N*ULPINV
GO TO 70
*
70 CONTINUE
*
CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
IINFO = 0
COND = ULPINV
*
* Special Matrices -- Identity & Jordan block
*
* Zero
*
IF( ITYPE.EQ.1 ) THEN
IINFO = 0
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Identity
*
DO 80 JCOL = 1, N
A( JCOL, JCOL ) = ANORM
80 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Diagonal Matrix, [Eigen]values Specified
*
CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.5 ) THEN
*
* Symmetric, eigenvalues specified
*
CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, N, N, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.7 ) THEN
*
* Diagonal, random eigenvalues
*
IDUMMA( 1 ) = 1
CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.8 ) THEN
*
* Symmetric, random eigenvalues
*
IDUMMA( 1 ) = 1
CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.9 ) THEN
*
* Symmetric banded, eigenvalues specified
*
IHBW = INT( ( N-1 )*DLARND( 1, ISEED3 ) )
CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, IHBW, IHBW, 'Z', U, LDU, WORK( N+1 ),
$ IINFO )
*
* Store as dense matrix for most routines.
*
CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
DO 100 IDIAG = -IHBW, IHBW
IROW = IHBW - IDIAG + 1
J1 = MAX( 1, IDIAG+1 )
J2 = MIN( N, N+IDIAG )
DO 90 J = J1, J2
I = J - IDIAG
A( I, J ) = U( IROW, J )
90 CONTINUE
100 CONTINUE
ELSE
IINFO = 1
END IF
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
110 CONTINUE
*
ABSTOL = UNFL + UNFL
IF( N.LE.1 ) THEN
IL = 1
IU = N
ELSE
IL = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) )
IU = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) )
IF( IL.GT.IU ) THEN
ITEMP = IL
IL = IU
IU = ITEMP
END IF
END IF
*
* 3) If matrix is tridiagonal, call DSTEV and DSTEVX.
*
IF( JTYPE.LE.7 ) THEN
NTEST = 1
DO 120 I = 1, N
D1( I ) = DBLE( A( I, I ) )
120 CONTINUE
DO 130 I = 1, N - 1
D2( I ) = DBLE( A( I+1, I ) )
130 CONTINUE
SRNAMT = 'DSTEV'
CALL DSTEV( 'V', N, D1, D2, Z, LDU, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEV(V)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 1 ) = ULPINV
RESULT( 2 ) = ULPINV
RESULT( 3 ) = ULPINV
GO TO 180
END IF
END IF
*
* Do tests 1 and 2.
*
DO 140 I = 1, N
D3( I ) = DBLE( A( I, I ) )
140 CONTINUE
DO 150 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
150 CONTINUE
CALL DSTT21( N, 0, D3, D4, D1, D2, Z, LDU, WORK,
$ RESULT( 1 ) )
*
NTEST = 3
DO 160 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
160 CONTINUE
SRNAMT = 'DSTEV'
CALL DSTEV( 'N', N, D3, D4, Z, LDU, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEV(N)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 3 ) = ULPINV
GO TO 180
END IF
END IF
*
* Do test 3.
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 170 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) )
170 CONTINUE
RESULT( 3 ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
180 CONTINUE
*
NTEST = 4
DO 190 I = 1, N
EVEIGS( I ) = D3( I )
D1( I ) = DBLE( A( I, I ) )
190 CONTINUE
DO 200 I = 1, N - 1
D2( I ) = DBLE( A( I+1, I ) )
200 CONTINUE
SRNAMT = 'DSTEVX'
CALL DSTEVX( 'V', 'A', N, D1, D2, VL, VU, IL, IU, ABSTOL,
$ M, WA1, Z, LDU, WORK, IWORK, IWORK( 5*N+1 ),
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEVX(V,A)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 4 ) = ULPINV
RESULT( 5 ) = ULPINV
RESULT( 6 ) = ULPINV
GO TO 250
END IF
END IF
IF( N.GT.0 ) THEN
TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) )
ELSE
TEMP3 = ZERO
END IF
*
* Do tests 4 and 5.
*
DO 210 I = 1, N
D3( I ) = DBLE( A( I, I ) )
210 CONTINUE
DO 220 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
220 CONTINUE
CALL DSTT21( N, 0, D3, D4, WA1, D2, Z, LDU, WORK,
$ RESULT( 4 ) )
*
NTEST = 6
DO 230 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
230 CONTINUE
SRNAMT = 'DSTEVX'
CALL DSTEVX( 'N', 'A', N, D3, D4, VL, VU, IL, IU, ABSTOL,
$ M2, WA2, Z, LDU, WORK, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEVX(N,A)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 6 ) = ULPINV
GO TO 250
END IF
END IF
*
* Do test 6.
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 240 J = 1, N
TEMP1 = MAX( TEMP1, ABS( WA2( J ) ),
$ ABS( EVEIGS( J ) ) )
TEMP2 = MAX( TEMP2, ABS( WA2( J )-EVEIGS( J ) ) )
240 CONTINUE
RESULT( 6 ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
250 CONTINUE
*
NTEST = 7
DO 260 I = 1, N
D1( I ) = DBLE( A( I, I ) )
260 CONTINUE
DO 270 I = 1, N - 1
D2( I ) = DBLE( A( I+1, I ) )
270 CONTINUE
SRNAMT = 'DSTEVR'
CALL DSTEVR( 'V', 'A', N, D1, D2, VL, VU, IL, IU, ABSTOL,
$ M, WA1, Z, LDU, IWORK, WORK, LWORK,
$ IWORK(2*N+1), LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEVR(V,A)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 7 ) = ULPINV
RESULT( 8 ) = ULPINV
GO TO 320
END IF
END IF
IF( N.GT.0 ) THEN
TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) )
ELSE
TEMP3 = ZERO
END IF
*
* Do tests 7 and 8.
*
DO 280 I = 1, N
D3( I ) = DBLE( A( I, I ) )
280 CONTINUE
DO 290 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
290 CONTINUE
CALL DSTT21( N, 0, D3, D4, WA1, D2, Z, LDU, WORK,
$ RESULT( 7 ) )
*
NTEST = 9
DO 300 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
300 CONTINUE
SRNAMT = 'DSTEVR'
CALL DSTEVR( 'N', 'A', N, D3, D4, VL, VU, IL, IU, ABSTOL,
$ M2, WA2, Z, LDU, IWORK, WORK, LWORK,
$ IWORK(2*N+1), LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEVR(N,A)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 9 ) = ULPINV
GO TO 320
END IF
END IF
*
* Do test 9.
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 310 J = 1, N
TEMP1 = MAX( TEMP1, ABS( WA2( J ) ),
$ ABS( EVEIGS( J ) ) )
TEMP2 = MAX( TEMP2, ABS( WA2( J )-EVEIGS( J ) ) )
310 CONTINUE
RESULT( 9 ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
320 CONTINUE
*
*
NTEST = 10
DO 330 I = 1, N
D1( I ) = DBLE( A( I, I ) )
330 CONTINUE
DO 340 I = 1, N - 1
D2( I ) = DBLE( A( I+1, I ) )
340 CONTINUE
SRNAMT = 'DSTEVX'
CALL DSTEVX( 'V', 'I', N, D1, D2, VL, VU, IL, IU, ABSTOL,
$ M2, WA2, Z, LDU, WORK, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEVX(V,I)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 10 ) = ULPINV
RESULT( 11 ) = ULPINV
RESULT( 12 ) = ULPINV
GO TO 380
END IF
END IF
*
* Do tests 10 and 11.
*
DO 350 I = 1, N
D3( I ) = DBLE( A( I, I ) )
350 CONTINUE
DO 360 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
360 CONTINUE
CALL DSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK,
$ MAX( 1, M2 ), RESULT( 10 ) )
*
*
NTEST = 12
DO 370 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
370 CONTINUE
SRNAMT = 'DSTEVX'
CALL DSTEVX( 'N', 'I', N, D3, D4, VL, VU, IL, IU, ABSTOL,
$ M3, WA3, Z, LDU, WORK, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEVX(N,I)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 12 ) = ULPINV
GO TO 380
END IF
END IF
*
* Do test 12.
*
TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
RESULT( 12 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, ULP*TEMP3 )
*
380 CONTINUE
*
NTEST = 12
IF( N.GT.0 ) THEN
IF( IL.NE.1 ) THEN
VL = WA1( IL ) - MAX( HALF*
$ ( WA1( IL )-WA1( IL-1 ) ), TEN*ULP*TEMP3,
$ TEN*RTUNFL )
ELSE
VL = WA1( 1 ) - MAX( HALF*( WA1( N )-WA1( 1 ) ),
$ TEN*ULP*TEMP3, TEN*RTUNFL )
END IF
IF( IU.NE.N ) THEN
VU = WA1( IU ) + MAX( HALF*
$ ( WA1( IU+1 )-WA1( IU ) ), TEN*ULP*TEMP3,
$ TEN*RTUNFL )
ELSE
VU = WA1( N ) + MAX( HALF*( WA1( N )-WA1( 1 ) ),
$ TEN*ULP*TEMP3, TEN*RTUNFL )
END IF
ELSE
VL = ZERO
VU = ONE
END IF
*
DO 390 I = 1, N
D1( I ) = DBLE( A( I, I ) )
390 CONTINUE
DO 400 I = 1, N - 1
D2( I ) = DBLE( A( I+1, I ) )
400 CONTINUE
SRNAMT = 'DSTEVX'
CALL DSTEVX( 'V', 'V', N, D1, D2, VL, VU, IL, IU, ABSTOL,
$ M2, WA2, Z, LDU, WORK, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEVX(V,V)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 13 ) = ULPINV
RESULT( 14 ) = ULPINV
RESULT( 15 ) = ULPINV
GO TO 440
END IF
END IF
*
IF( M2.EQ.0 .AND. N.GT.0 ) THEN
RESULT( 13 ) = ULPINV
RESULT( 14 ) = ULPINV
RESULT( 15 ) = ULPINV
GO TO 440
END IF
*
* Do tests 13 and 14.
*
DO 410 I = 1, N
D3( I ) = DBLE( A( I, I ) )
410 CONTINUE
DO 420 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
420 CONTINUE
CALL DSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK,
$ MAX( 1, M2 ), RESULT( 13 ) )
*
NTEST = 15
DO 430 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
430 CONTINUE
SRNAMT = 'DSTEVX'
CALL DSTEVX( 'N', 'V', N, D3, D4, VL, VU, IL, IU, ABSTOL,
$ M3, WA3, Z, LDU, WORK, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEVX(N,V)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 15 ) = ULPINV
GO TO 440
END IF
END IF
*
* Do test 15.
*
TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
RESULT( 15 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, TEMP3*ULP )
*
440 CONTINUE
*
NTEST = 16
DO 450 I = 1, N
D1( I ) = DBLE( A( I, I ) )
450 CONTINUE
DO 460 I = 1, N - 1
D2( I ) = DBLE( A( I+1, I ) )
460 CONTINUE
SRNAMT = 'DSTEVD'
CALL DSTEVD( 'V', N, D1, D2, Z, LDU, WORK, LWEDC, IWORK,
$ LIWEDC, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEVD(V)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 16 ) = ULPINV
RESULT( 17 ) = ULPINV
RESULT( 18 ) = ULPINV
GO TO 510
END IF
END IF
*
* Do tests 16 and 17.
*
DO 470 I = 1, N
D3( I ) = DBLE( A( I, I ) )
470 CONTINUE
DO 480 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
480 CONTINUE
CALL DSTT21( N, 0, D3, D4, D1, D2, Z, LDU, WORK,
$ RESULT( 16 ) )
*
NTEST = 18
DO 490 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
490 CONTINUE
SRNAMT = 'DSTEVD'
CALL DSTEVD( 'N', N, D3, D4, Z, LDU, WORK, LWEDC, IWORK,
$ LIWEDC, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEVD(N)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 18 ) = ULPINV
GO TO 510
END IF
END IF
*
* Do test 18.
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 500 J = 1, N
TEMP1 = MAX( TEMP1, ABS( EVEIGS( J ) ),
$ ABS( D3( J ) ) )
TEMP2 = MAX( TEMP2, ABS( EVEIGS( J )-D3( J ) ) )
500 CONTINUE
RESULT( 18 ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
510 CONTINUE
*
NTEST = 19
DO 520 I = 1, N
D1( I ) = DBLE( A( I, I ) )
520 CONTINUE
DO 530 I = 1, N - 1
D2( I ) = DBLE( A( I+1, I ) )
530 CONTINUE
SRNAMT = 'DSTEVR'
CALL DSTEVR( 'V', 'I', N, D1, D2, VL, VU, IL, IU, ABSTOL,
$ M2, WA2, Z, LDU, IWORK, WORK, LWORK,
$ IWORK(2*N+1), LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEVR(V,I)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 19 ) = ULPINV
RESULT( 20 ) = ULPINV
RESULT( 21 ) = ULPINV
GO TO 570
END IF
END IF
*
* DO tests 19 and 20.
*
DO 540 I = 1, N
D3( I ) = DBLE( A( I, I ) )
540 CONTINUE
DO 550 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
550 CONTINUE
CALL DSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK,
$ MAX( 1, M2 ), RESULT( 19 ) )
*
*
NTEST = 21
DO 560 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
560 CONTINUE
SRNAMT = 'DSTEVR'
CALL DSTEVR( 'N', 'I', N, D3, D4, VL, VU, IL, IU, ABSTOL,
$ M3, WA3, Z, LDU, IWORK, WORK, LWORK,
$ IWORK(2*N+1), LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEVR(N,I)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 21 ) = ULPINV
GO TO 570
END IF
END IF
*
* Do test 21.
*
TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
RESULT( 21 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, ULP*TEMP3 )
*
570 CONTINUE
*
NTEST = 21
IF( N.GT.0 ) THEN
IF( IL.NE.1 ) THEN
VL = WA1( IL ) - MAX( HALF*
$ ( WA1( IL )-WA1( IL-1 ) ), TEN*ULP*TEMP3,
$ TEN*RTUNFL )
ELSE
VL = WA1( 1 ) - MAX( HALF*( WA1( N )-WA1( 1 ) ),
$ TEN*ULP*TEMP3, TEN*RTUNFL )
END IF
IF( IU.NE.N ) THEN
VU = WA1( IU ) + MAX( HALF*
$ ( WA1( IU+1 )-WA1( IU ) ), TEN*ULP*TEMP3,
$ TEN*RTUNFL )
ELSE
VU = WA1( N ) + MAX( HALF*( WA1( N )-WA1( 1 ) ),
$ TEN*ULP*TEMP3, TEN*RTUNFL )
END IF
ELSE
VL = ZERO
VU = ONE
END IF
*
DO 580 I = 1, N
D1( I ) = DBLE( A( I, I ) )
580 CONTINUE
DO 590 I = 1, N - 1
D2( I ) = DBLE( A( I+1, I ) )
590 CONTINUE
SRNAMT = 'DSTEVR'
CALL DSTEVR( 'V', 'V', N, D1, D2, VL, VU, IL, IU, ABSTOL,
$ M2, WA2, Z, LDU, IWORK, WORK, LWORK,
$ IWORK(2*N+1), LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEVR(V,V)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 22 ) = ULPINV
RESULT( 23 ) = ULPINV
RESULT( 24 ) = ULPINV
GO TO 630
END IF
END IF
*
IF( M2.EQ.0 .AND. N.GT.0 ) THEN
RESULT( 22 ) = ULPINV
RESULT( 23 ) = ULPINV
RESULT( 24 ) = ULPINV
GO TO 630
END IF
*
* Do tests 22 and 23.
*
DO 600 I = 1, N
D3( I ) = DBLE( A( I, I ) )
600 CONTINUE
DO 610 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
610 CONTINUE
CALL DSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK,
$ MAX( 1, M2 ), RESULT( 22 ) )
*
NTEST = 24
DO 620 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
620 CONTINUE
SRNAMT = 'DSTEVR'
CALL DSTEVR( 'N', 'V', N, D3, D4, VL, VU, IL, IU, ABSTOL,
$ M3, WA3, Z, LDU, IWORK, WORK, LWORK,
$ IWORK(2*N+1), LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEVR(N,V)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 24 ) = ULPINV
GO TO 630
END IF
END IF
*
* Do test 24.
*
TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
RESULT( 24 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, TEMP3*ULP )
*
630 CONTINUE
*
*
*
ELSE
*
DO 640 I = 1, 24
RESULT( I ) = ZERO
640 CONTINUE
NTEST = 24
END IF
*
* Perform remaining tests storing upper or lower triangular
* part of matrix.
*
DO 1720 IUPLO = 0, 1
IF( IUPLO.EQ.0 ) THEN
UPLO = 'L'
ELSE
UPLO = 'U'
END IF
*
* 4) Call DSYEV and DSYEVX.
*
CALL DLACPY( ' ', N, N, A, LDA, V, LDU )
*
NTEST = NTEST + 1
SRNAMT = 'DSYEV'
CALL DSYEV( 'V', UPLO, N, A, LDU, D1, WORK, LWORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSYEV(V,' // UPLO // ')',
$ IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 660
END IF
END IF
*
* Do tests 25 and 26 (or +54)
*
CALL DSYT21( 1, UPLO, N, 0, V, LDU, D1, D2, A, LDU, Z,
$ LDU, TAU, WORK, RESULT( NTEST ) )
*
CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
*
NTEST = NTEST + 2
SRNAMT = 'DSYEV'
CALL DSYEV( 'N', UPLO, N, A, LDU, D3, WORK, LWORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSYEV(N,' // UPLO // ')',
$ IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 660
END IF
END IF
*
* Do test 27 (or +54)
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 650 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) )
650 CONTINUE
RESULT( NTEST ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
660 CONTINUE
CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
*
NTEST = NTEST + 1
*
IF( N.GT.0 ) THEN
TEMP3 = MAX( ABS( D1( 1 ) ), ABS( D1( N ) ) )
IF( IL.NE.1 ) THEN
VL = D1( IL ) - MAX( HALF*( D1( IL )-D1( IL-1 ) ),
$ TEN*ULP*TEMP3, TEN*RTUNFL )
ELSE IF( N.GT.0 ) THEN
VL = D1( 1 ) - MAX( HALF*( D1( N )-D1( 1 ) ),
$ TEN*ULP*TEMP3, TEN*RTUNFL )
END IF
IF( IU.NE.N ) THEN
VU = D1( IU ) + MAX( HALF*( D1( IU+1 )-D1( IU ) ),
$ TEN*ULP*TEMP3, TEN*RTUNFL )
ELSE IF( N.GT.0 ) THEN
VU = D1( N ) + MAX( HALF*( D1( N )-D1( 1 ) ),
$ TEN*ULP*TEMP3, TEN*RTUNFL )
END IF
ELSE
TEMP3 = ZERO
VL = ZERO
VU = ONE
END IF
*
SRNAMT = 'DSYEVX'
CALL DSYEVX( 'V', 'A', UPLO, N, A, LDU, VL, VU, IL, IU,
$ ABSTOL, M, WA1, Z, LDU, WORK, LWORK, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSYEVX(V,A,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 680
END IF
END IF
*
* Do tests 28 and 29 (or +54)
*
CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
*
CALL DSYT21( 1, UPLO, N, 0, A, LDU, D1, D2, Z, LDU, V,
$ LDU, TAU, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 2
SRNAMT = 'DSYEVX'
CALL DSYEVX( 'N', 'A', UPLO, N, A, LDU, VL, VU, IL, IU,
$ ABSTOL, M2, WA2, Z, LDU, WORK, LWORK, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSYEVX(N,A,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 680
END IF
END IF
*
* Do test 30 (or +54)
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 670 J = 1, N
TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) )
TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) )
670 CONTINUE
RESULT( NTEST ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
680 CONTINUE
*
NTEST = NTEST + 1
CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
SRNAMT = 'DSYEVX'
CALL DSYEVX( 'V', 'I', UPLO, N, A, LDU, VL, VU, IL, IU,
$ ABSTOL, M2, WA2, Z, LDU, WORK, LWORK, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSYEVX(V,I,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 690
END IF
END IF
*
* Do tests 31 and 32 (or +54)
*
CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
*
CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU,
$ V, LDU, TAU, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 2
CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
SRNAMT = 'DSYEVX'
CALL DSYEVX( 'N', 'I', UPLO, N, A, LDU, VL, VU, IL, IU,
$ ABSTOL, M3, WA3, Z, LDU, WORK, LWORK, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSYEVX(N,I,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 690
END IF
END IF
*
* Do test 33 (or +54)
*
TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
RESULT( NTEST ) = ( TEMP1+TEMP2 ) /
$ MAX( UNFL, ULP*TEMP3 )
690 CONTINUE
*
NTEST = NTEST + 1
CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
SRNAMT = 'DSYEVX'
CALL DSYEVX( 'V', 'V', UPLO, N, A, LDU, VL, VU, IL, IU,
$ ABSTOL, M2, WA2, Z, LDU, WORK, LWORK, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSYEVX(V,V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 700
END IF
END IF
*
* Do tests 34 and 35 (or +54)
*
CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
*
CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU,
$ V, LDU, TAU, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 2
CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
SRNAMT = 'DSYEVX'
CALL DSYEVX( 'N', 'V', UPLO, N, A, LDU, VL, VU, IL, IU,
$ ABSTOL, M3, WA3, Z, LDU, WORK, LWORK, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSYEVX(N,V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 700
END IF
END IF
*
IF( M3.EQ.0 .AND. N.GT.0 ) THEN
RESULT( NTEST ) = ULPINV
GO TO 700
END IF
*
* Do test 36 (or +54)
*
TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
IF( N.GT.0 ) THEN
TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) )
ELSE
TEMP3 = ZERO
END IF
RESULT( NTEST ) = ( TEMP1+TEMP2 ) /
$ MAX( UNFL, TEMP3*ULP )
*
700 CONTINUE
*
* 5) Call DSPEV and DSPEVX.
*
CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
*
* Load array WORK with the upper or lower triangular
* part of the matrix in packed form.
*
IF( IUPLO.EQ.1 ) THEN
INDX = 1
DO 720 J = 1, N
DO 710 I = 1, J
WORK( INDX ) = A( I, J )
INDX = INDX + 1
710 CONTINUE
720 CONTINUE
ELSE
INDX = 1
DO 740 J = 1, N
DO 730 I = J, N
WORK( INDX ) = A( I, J )
INDX = INDX + 1
730 CONTINUE
740 CONTINUE
END IF
*
NTEST = NTEST + 1
SRNAMT = 'DSPEV'
CALL DSPEV( 'V', UPLO, N, WORK, D1, Z, LDU, V, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSPEV(V,' // UPLO // ')',
$ IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 800
END IF
END IF
*
* Do tests 37 and 38 (or +54)
*
CALL DSYT21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V,
$ LDU, TAU, WORK, RESULT( NTEST ) )
*
IF( IUPLO.EQ.1 ) THEN
INDX = 1
DO 760 J = 1, N
DO 750 I = 1, J
WORK( INDX ) = A( I, J )
INDX = INDX + 1
750 CONTINUE
760 CONTINUE
ELSE
INDX = 1
DO 780 J = 1, N
DO 770 I = J, N
WORK( INDX ) = A( I, J )
INDX = INDX + 1
770 CONTINUE
780 CONTINUE
END IF
*
NTEST = NTEST + 2
SRNAMT = 'DSPEV'
CALL DSPEV( 'N', UPLO, N, WORK, D3, Z, LDU, V, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSPEV(N,' // UPLO // ')',
$ IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 800
END IF
END IF
*
* Do test 39 (or +54)
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 790 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) )
790 CONTINUE
RESULT( NTEST ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
* Load array WORK with the upper or lower triangular part
* of the matrix in packed form.
*
800 CONTINUE
IF( IUPLO.EQ.1 ) THEN
INDX = 1
DO 820 J = 1, N
DO 810 I = 1, J
WORK( INDX ) = A( I, J )
INDX = INDX + 1
810 CONTINUE
820 CONTINUE
ELSE
INDX = 1
DO 840 J = 1, N
DO 830 I = J, N
WORK( INDX ) = A( I, J )
INDX = INDX + 1
830 CONTINUE
840 CONTINUE
END IF
*
NTEST = NTEST + 1
*
IF( N.GT.0 ) THEN
TEMP3 = MAX( ABS( D1( 1 ) ), ABS( D1( N ) ) )
IF( IL.NE.1 ) THEN
VL = D1( IL ) - MAX( HALF*( D1( IL )-D1( IL-1 ) ),
$ TEN*ULP*TEMP3, TEN*RTUNFL )
ELSE IF( N.GT.0 ) THEN
VL = D1( 1 ) - MAX( HALF*( D1( N )-D1( 1 ) ),
$ TEN*ULP*TEMP3, TEN*RTUNFL )
END IF
IF( IU.NE.N ) THEN
VU = D1( IU ) + MAX( HALF*( D1( IU+1 )-D1( IU ) ),
$ TEN*ULP*TEMP3, TEN*RTUNFL )
ELSE IF( N.GT.0 ) THEN
VU = D1( N ) + MAX( HALF*( D1( N )-D1( 1 ) ),
$ TEN*ULP*TEMP3, TEN*RTUNFL )
END IF
ELSE
TEMP3 = ZERO
VL = ZERO
VU = ONE
END IF
*
SRNAMT = 'DSPEVX'
CALL DSPEVX( 'V', 'A', UPLO, N, WORK, VL, VU, IL, IU,
$ ABSTOL, M, WA1, Z, LDU, V, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSPEVX(V,A,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 900
END IF
END IF
*
* Do tests 40 and 41 (or +54)
*
CALL DSYT21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V,
$ LDU, TAU, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 2
*
IF( IUPLO.EQ.1 ) THEN
INDX = 1
DO 860 J = 1, N
DO 850 I = 1, J
WORK( INDX ) = A( I, J )
INDX = INDX + 1
850 CONTINUE
860 CONTINUE
ELSE
INDX = 1
DO 880 J = 1, N
DO 870 I = J, N
WORK( INDX ) = A( I, J )
INDX = INDX + 1
870 CONTINUE
880 CONTINUE
END IF
*
SRNAMT = 'DSPEVX'
CALL DSPEVX( 'N', 'A', UPLO, N, WORK, VL, VU, IL, IU,
$ ABSTOL, M2, WA2, Z, LDU, V, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSPEVX(N,A,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 900
END IF
END IF
*
* Do test 42 (or +54)
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 890 J = 1, N
TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) )
TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) )
890 CONTINUE
RESULT( NTEST ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
900 CONTINUE
IF( IUPLO.EQ.1 ) THEN
INDX = 1
DO 920 J = 1, N
DO 910 I = 1, J
WORK( INDX ) = A( I, J )
INDX = INDX + 1
910 CONTINUE
920 CONTINUE
ELSE
INDX = 1
DO 940 J = 1, N
DO 930 I = J, N
WORK( INDX ) = A( I, J )
INDX = INDX + 1
930 CONTINUE
940 CONTINUE
END IF
*
NTEST = NTEST + 1
*
SRNAMT = 'DSPEVX'
CALL DSPEVX( 'V', 'I', UPLO, N, WORK, VL, VU, IL, IU,
$ ABSTOL, M2, WA2, Z, LDU, V, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSPEVX(V,I,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 990
END IF
END IF
*
* Do tests 43 and 44 (or +54)
*
CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU,
$ V, LDU, TAU, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 2
*
IF( IUPLO.EQ.1 ) THEN
INDX = 1
DO 960 J = 1, N
DO 950 I = 1, J
WORK( INDX ) = A( I, J )
INDX = INDX + 1
950 CONTINUE
960 CONTINUE
ELSE
INDX = 1
DO 980 J = 1, N
DO 970 I = J, N
WORK( INDX ) = A( I, J )
INDX = INDX + 1
970 CONTINUE
980 CONTINUE
END IF
*
SRNAMT = 'DSPEVX'
CALL DSPEVX( 'N', 'I', UPLO, N, WORK, VL, VU, IL, IU,
$ ABSTOL, M3, WA3, Z, LDU, V, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSPEVX(N,I,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 990
END IF
END IF
*
IF( M3.EQ.0 .AND. N.GT.0 ) THEN
RESULT( NTEST ) = ULPINV
GO TO 990
END IF
*
* Do test 45 (or +54)
*
TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
IF( N.GT.0 ) THEN
TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) )
ELSE
TEMP3 = ZERO
END IF
RESULT( NTEST ) = ( TEMP1+TEMP2 ) /
$ MAX( UNFL, TEMP3*ULP )
*
990 CONTINUE
IF( IUPLO.EQ.1 ) THEN
INDX = 1
DO 1010 J = 1, N
DO 1000 I = 1, J
WORK( INDX ) = A( I, J )
INDX = INDX + 1
1000 CONTINUE
1010 CONTINUE
ELSE
INDX = 1
DO 1030 J = 1, N
DO 1020 I = J, N
WORK( INDX ) = A( I, J )
INDX = INDX + 1
1020 CONTINUE
1030 CONTINUE
END IF
*
NTEST = NTEST + 1
*
SRNAMT = 'DSPEVX'
CALL DSPEVX( 'V', 'V', UPLO, N, WORK, VL, VU, IL, IU,
$ ABSTOL, M2, WA2, Z, LDU, V, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSPEVX(V,V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 1080
END IF
END IF
*
* Do tests 46 and 47 (or +54)
*
CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU,
$ V, LDU, TAU, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 2
*
IF( IUPLO.EQ.1 ) THEN
INDX = 1
DO 1050 J = 1, N
DO 1040 I = 1, J
WORK( INDX ) = A( I, J )
INDX = INDX + 1
1040 CONTINUE
1050 CONTINUE
ELSE
INDX = 1
DO 1070 J = 1, N
DO 1060 I = J, N
WORK( INDX ) = A( I, J )
INDX = INDX + 1
1060 CONTINUE
1070 CONTINUE
END IF
*
SRNAMT = 'DSPEVX'
CALL DSPEVX( 'N', 'V', UPLO, N, WORK, VL, VU, IL, IU,
$ ABSTOL, M3, WA3, Z, LDU, V, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSPEVX(N,V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 1080
END IF
END IF
*
IF( M3.EQ.0 .AND. N.GT.0 ) THEN
RESULT( NTEST ) = ULPINV
GO TO 1080
END IF
*
* Do test 48 (or +54)
*
TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
IF( N.GT.0 ) THEN
TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) )
ELSE
TEMP3 = ZERO
END IF
RESULT( NTEST ) = ( TEMP1+TEMP2 ) /
$ MAX( UNFL, TEMP3*ULP )
*
1080 CONTINUE
*
* 6) Call DSBEV and DSBEVX.
*
IF( JTYPE.LE.7 ) THEN
KD = 1
ELSE IF( JTYPE.GE.8 .AND. JTYPE.LE.15 ) THEN
KD = MAX( N-1, 0 )
ELSE
KD = IHBW
END IF
*
* Load array V with the upper or lower triangular part
* of the matrix in band form.
*
IF( IUPLO.EQ.1 ) THEN
DO 1100 J = 1, N
DO 1090 I = MAX( 1, J-KD ), J
V( KD+1+I-J, J ) = A( I, J )
1090 CONTINUE
1100 CONTINUE
ELSE
DO 1120 J = 1, N
DO 1110 I = J, MIN( N, J+KD )
V( 1+I-J, J ) = A( I, J )
1110 CONTINUE
1120 CONTINUE
END IF
*
NTEST = NTEST + 1
SRNAMT = 'DSBEV'
CALL DSBEV( 'V', UPLO, N, KD, V, LDU, D1, Z, LDU, WORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSBEV(V,' // UPLO // ')',
$ IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 1180
END IF
END IF
*
* Do tests 49 and 50 (or ... )
*
CALL DSYT21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V,
$ LDU, TAU, WORK, RESULT( NTEST ) )
*
IF( IUPLO.EQ.1 ) THEN
DO 1140 J = 1, N
DO 1130 I = MAX( 1, J-KD ), J
V( KD+1+I-J, J ) = A( I, J )
1130 CONTINUE
1140 CONTINUE
ELSE
DO 1160 J = 1, N
DO 1150 I = J, MIN( N, J+KD )
V( 1+I-J, J ) = A( I, J )
1150 CONTINUE
1160 CONTINUE
END IF
*
NTEST = NTEST + 2
SRNAMT = 'DSBEV'
CALL DSBEV( 'N', UPLO, N, KD, V, LDU, D3, Z, LDU, WORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSBEV(N,' // UPLO // ')',
$ IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 1180
END IF
END IF
*
* Do test 51 (or +54)
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 1170 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) )
1170 CONTINUE
RESULT( NTEST ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
* Load array V with the upper or lower triangular part
* of the matrix in band form.
*
1180 CONTINUE
IF( IUPLO.EQ.1 ) THEN
DO 1200 J = 1, N
DO 1190 I = MAX( 1, J-KD ), J
V( KD+1+I-J, J ) = A( I, J )
1190 CONTINUE
1200 CONTINUE
ELSE
DO 1220 J = 1, N
DO 1210 I = J, MIN( N, J+KD )
V( 1+I-J, J ) = A( I, J )
1210 CONTINUE
1220 CONTINUE
END IF
*
NTEST = NTEST + 1
SRNAMT = 'DSBEVX'
CALL DSBEVX( 'V', 'A', UPLO, N, KD, V, LDU, U, LDU, VL,
$ VU, IL, IU, ABSTOL, M, WA2, Z, LDU, WORK,
$ IWORK, IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSBEVX(V,A,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 1280
END IF
END IF
*
* Do tests 52 and 53 (or +54)
*
CALL DSYT21( 1, UPLO, N, 0, A, LDU, WA2, D2, Z, LDU, V,
$ LDU, TAU, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 2
*
IF( IUPLO.EQ.1 ) THEN
DO 1240 J = 1, N
DO 1230 I = MAX( 1, J-KD ), J
V( KD+1+I-J, J ) = A( I, J )
1230 CONTINUE
1240 CONTINUE
ELSE
DO 1260 J = 1, N
DO 1250 I = J, MIN( N, J+KD )
V( 1+I-J, J ) = A( I, J )
1250 CONTINUE
1260 CONTINUE
END IF
*
SRNAMT = 'DSBEVX'
CALL DSBEVX( 'N', 'A', UPLO, N, KD, V, LDU, U, LDU, VL,
$ VU, IL, IU, ABSTOL, M3, WA3, Z, LDU, WORK,
$ IWORK, IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSBEVX(N,A,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 1280
END IF
END IF
*
* Do test 54 (or +54)
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 1270 J = 1, N
TEMP1 = MAX( TEMP1, ABS( WA2( J ) ), ABS( WA3( J ) ) )
TEMP2 = MAX( TEMP2, ABS( WA2( J )-WA3( J ) ) )
1270 CONTINUE
RESULT( NTEST ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
1280 CONTINUE
NTEST = NTEST + 1
IF( IUPLO.EQ.1 ) THEN
DO 1300 J = 1, N
DO 1290 I = MAX( 1, J-KD ), J
V( KD+1+I-J, J ) = A( I, J )
1290 CONTINUE
1300 CONTINUE
ELSE
DO 1320 J = 1, N
DO 1310 I = J, MIN( N, J+KD )
V( 1+I-J, J ) = A( I, J )
1310 CONTINUE
1320 CONTINUE
END IF
*
SRNAMT = 'DSBEVX'
CALL DSBEVX( 'V', 'I', UPLO, N, KD, V, LDU, U, LDU, VL,
$ VU, IL, IU, ABSTOL, M2, WA2, Z, LDU, WORK,
$ IWORK, IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSBEVX(V,I,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 1370
END IF
END IF
*
* Do tests 55 and 56 (or +54)
*
CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU,
$ V, LDU, TAU, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 2
*
IF( IUPLO.EQ.1 ) THEN
DO 1340 J = 1, N
DO 1330 I = MAX( 1, J-KD ), J
V( KD+1+I-J, J ) = A( I, J )
1330 CONTINUE
1340 CONTINUE
ELSE
DO 1360 J = 1, N
DO 1350 I = J, MIN( N, J+KD )
V( 1+I-J, J ) = A( I, J )
1350 CONTINUE
1360 CONTINUE
END IF
*
SRNAMT = 'DSBEVX'
CALL DSBEVX( 'N', 'I', UPLO, N, KD, V, LDU, U, LDU, VL,
$ VU, IL, IU, ABSTOL, M3, WA3, Z, LDU, WORK,
$ IWORK, IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSBEVX(N,I,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 1370
END IF
END IF
*
* Do test 57 (or +54)
*
TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
IF( N.GT.0 ) THEN
TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) )
ELSE
TEMP3 = ZERO
END IF
RESULT( NTEST ) = ( TEMP1+TEMP2 ) /
$ MAX( UNFL, TEMP3*ULP )
*
1370 CONTINUE
NTEST = NTEST + 1
IF( IUPLO.EQ.1 ) THEN
DO 1390 J = 1, N
DO 1380 I = MAX( 1, J-KD ), J
V( KD+1+I-J, J ) = A( I, J )
1380 CONTINUE
1390 CONTINUE
ELSE
DO 1410 J = 1, N
DO 1400 I = J, MIN( N, J+KD )
V( 1+I-J, J ) = A( I, J )
1400 CONTINUE
1410 CONTINUE
END IF
*
SRNAMT = 'DSBEVX'
CALL DSBEVX( 'V', 'V', UPLO, N, KD, V, LDU, U, LDU, VL,
$ VU, IL, IU, ABSTOL, M2, WA2, Z, LDU, WORK,
$ IWORK, IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSBEVX(V,V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 1460
END IF
END IF
*
* Do tests 58 and 59 (or +54)
*
CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU,
$ V, LDU, TAU, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 2
*
IF( IUPLO.EQ.1 ) THEN
DO 1430 J = 1, N
DO 1420 I = MAX( 1, J-KD ), J
V( KD+1+I-J, J ) = A( I, J )
1420 CONTINUE
1430 CONTINUE
ELSE
DO 1450 J = 1, N
DO 1440 I = J, MIN( N, J+KD )
V( 1+I-J, J ) = A( I, J )
1440 CONTINUE
1450 CONTINUE
END IF
*
SRNAMT = 'DSBEVX'
CALL DSBEVX( 'N', 'V', UPLO, N, KD, V, LDU, U, LDU, VL,
$ VU, IL, IU, ABSTOL, M3, WA3, Z, LDU, WORK,
$ IWORK, IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSBEVX(N,V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 1460
END IF
END IF
*
IF( M3.EQ.0 .AND. N.GT.0 ) THEN
RESULT( NTEST ) = ULPINV
GO TO 1460
END IF
*
* Do test 60 (or +54)
*
TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
IF( N.GT.0 ) THEN
TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) )
ELSE
TEMP3 = ZERO
END IF
RESULT( NTEST ) = ( TEMP1+TEMP2 ) /
$ MAX( UNFL, TEMP3*ULP )
*
1460 CONTINUE
*
* 7) Call DSYEVD
*
CALL DLACPY( ' ', N, N, A, LDA, V, LDU )
*
NTEST = NTEST + 1
SRNAMT = 'DSYEVD'
CALL DSYEVD( 'V', UPLO, N, A, LDU, D1, WORK, LWEDC,
$ IWORK, LIWEDC, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSYEVD(V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 1480
END IF
END IF
*
* Do tests 61 and 62 (or +54)
*
CALL DSYT21( 1, UPLO, N, 0, V, LDU, D1, D2, A, LDU, Z,
$ LDU, TAU, WORK, RESULT( NTEST ) )
*
CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
*
NTEST = NTEST + 2
SRNAMT = 'DSYEVD'
CALL DSYEVD( 'N', UPLO, N, A, LDU, D3, WORK, LWEDC,
$ IWORK, LIWEDC, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSYEVD(N,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 1480
END IF
END IF
*
* Do test 63 (or +54)
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 1470 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) )
1470 CONTINUE
RESULT( NTEST ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
1480 CONTINUE
*
* 8) Call DSPEVD.
*
CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
*
* Load array WORK with the upper or lower triangular
* part of the matrix in packed form.
*
IF( IUPLO.EQ.1 ) THEN
INDX = 1
DO 1500 J = 1, N
DO 1490 I = 1, J
WORK( INDX ) = A( I, J )
INDX = INDX + 1
1490 CONTINUE
1500 CONTINUE
ELSE
INDX = 1
DO 1520 J = 1, N
DO 1510 I = J, N
WORK( INDX ) = A( I, J )
INDX = INDX + 1
1510 CONTINUE
1520 CONTINUE
END IF
*
NTEST = NTEST + 1
SRNAMT = 'DSPEVD'
CALL DSPEVD( 'V', UPLO, N, WORK, D1, Z, LDU,
$ WORK( INDX ), LWEDC-INDX+1, IWORK, LIWEDC,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSPEVD(V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 1580
END IF
END IF
*
* Do tests 64 and 65 (or +54)
*
CALL DSYT21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V,
$ LDU, TAU, WORK, RESULT( NTEST ) )
*
IF( IUPLO.EQ.1 ) THEN
INDX = 1
DO 1540 J = 1, N
DO 1530 I = 1, J
*
WORK( INDX ) = A( I, J )
INDX = INDX + 1
1530 CONTINUE
1540 CONTINUE
ELSE
INDX = 1
DO 1560 J = 1, N
DO 1550 I = J, N
WORK( INDX ) = A( I, J )
INDX = INDX + 1
1550 CONTINUE
1560 CONTINUE
END IF
*
NTEST = NTEST + 2
SRNAMT = 'DSPEVD'
CALL DSPEVD( 'N', UPLO, N, WORK, D3, Z, LDU,
$ WORK( INDX ), LWEDC-INDX+1, IWORK, LIWEDC,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSPEVD(N,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 1580
END IF
END IF
*
* Do test 66 (or +54)
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 1570 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) )
1570 CONTINUE
RESULT( NTEST ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
1580 CONTINUE
*
* 9) Call DSBEVD.
*
IF( JTYPE.LE.7 ) THEN
KD = 1
ELSE IF( JTYPE.GE.8 .AND. JTYPE.LE.15 ) THEN
KD = MAX( N-1, 0 )
ELSE
KD = IHBW
END IF
*
* Load array V with the upper or lower triangular part
* of the matrix in band form.
*
IF( IUPLO.EQ.1 ) THEN
DO 1600 J = 1, N
DO 1590 I = MAX( 1, J-KD ), J
V( KD+1+I-J, J ) = A( I, J )
1590 CONTINUE
1600 CONTINUE
ELSE
DO 1620 J = 1, N
DO 1610 I = J, MIN( N, J+KD )
V( 1+I-J, J ) = A( I, J )
1610 CONTINUE
1620 CONTINUE
END IF
*
NTEST = NTEST + 1
SRNAMT = 'DSBEVD'
CALL DSBEVD( 'V', UPLO, N, KD, V, LDU, D1, Z, LDU, WORK,
$ LWEDC, IWORK, LIWEDC, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSBEVD(V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 1680
END IF
END IF
*
* Do tests 67 and 68 (or +54)
*
CALL DSYT21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V,
$ LDU, TAU, WORK, RESULT( NTEST ) )
*
IF( IUPLO.EQ.1 ) THEN
DO 1640 J = 1, N
DO 1630 I = MAX( 1, J-KD ), J
V( KD+1+I-J, J ) = A( I, J )
1630 CONTINUE
1640 CONTINUE
ELSE
DO 1660 J = 1, N
DO 1650 I = J, MIN( N, J+KD )
V( 1+I-J, J ) = A( I, J )
1650 CONTINUE
1660 CONTINUE
END IF
*
NTEST = NTEST + 2
SRNAMT = 'DSBEVD'
CALL DSBEVD( 'N', UPLO, N, KD, V, LDU, D3, Z, LDU, WORK,
$ LWEDC, IWORK, LIWEDC, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSBEVD(N,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 1680
END IF
END IF
*
* Do test 69 (or +54)
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 1670 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) )
1670 CONTINUE
RESULT( NTEST ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
1680 CONTINUE
*
*
CALL DLACPY( ' ', N, N, A, LDA, V, LDU )
NTEST = NTEST + 1
SRNAMT = 'DSYEVR'
CALL DSYEVR( 'V', 'A', UPLO, N, A, LDU, VL, VU, IL, IU,
$ ABSTOL, M, WA1, Z, LDU, IWORK, WORK, LWORK,
$ IWORK(2*N+1), LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSYEVR(V,A,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 1700
END IF
END IF
*
* Do tests 70 and 71 (or ... )
*
CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
*
CALL DSYT21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V,
$ LDU, TAU, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 2
SRNAMT = 'DSYEVR'
CALL DSYEVR( 'N', 'A', UPLO, N, A, LDU, VL, VU, IL, IU,
$ ABSTOL, M2, WA2, Z, LDU, IWORK, WORK, LWORK,
$ IWORK(2*N+1), LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSYEVR(N,A,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 1700
END IF
END IF
*
* Do test 72 (or ... )
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 1690 J = 1, N
TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) )
TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) )
1690 CONTINUE
RESULT( NTEST ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
1700 CONTINUE
*
NTEST = NTEST + 1
CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
SRNAMT = 'DSYEVR'
CALL DSYEVR( 'V', 'I', UPLO, N, A, LDU, VL, VU, IL, IU,
$ ABSTOL, M2, WA2, Z, LDU, IWORK, WORK, LWORK,
$ IWORK(2*N+1), LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSYEVR(V,I,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 1710
END IF
END IF
*
* Do tests 73 and 74 (or +54)
*
CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
*
CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU,
$ V, LDU, TAU, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 2
CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
SRNAMT = 'DSYEVR'
CALL DSYEVR( 'N', 'I', UPLO, N, A, LDU, VL, VU, IL, IU,
$ ABSTOL, M3, WA3, Z, LDU, IWORK, WORK, LWORK,
$ IWORK(2*N+1), LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSYEVR(N,I,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 1710
END IF
END IF
*
* Do test 75 (or +54)
*
TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
RESULT( NTEST ) = ( TEMP1+TEMP2 ) /
$ MAX( UNFL, ULP*TEMP3 )
1710 CONTINUE
*
NTEST = NTEST + 1
CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
SRNAMT = 'DSYEVR'
CALL DSYEVR( 'V', 'V', UPLO, N, A, LDU, VL, VU, IL, IU,
$ ABSTOL, M2, WA2, Z, LDU, IWORK, WORK, LWORK,
$ IWORK(2*N+1), LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSYEVR(V,V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
RESULT( NTEST+1 ) = ULPINV
RESULT( NTEST+2 ) = ULPINV
GO TO 700
END IF
END IF
*
* Do tests 76 and 77 (or +54)
*
CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
*
CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU,
$ V, LDU, TAU, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 2
CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
SRNAMT = 'DSYEVR'
CALL DSYEVR( 'N', 'V', UPLO, N, A, LDU, VL, VU, IL, IU,
$ ABSTOL, M3, WA3, Z, LDU, IWORK, WORK, LWORK,
$ IWORK(2*N+1), LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSYEVR(N,V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 700
END IF
END IF
*
IF( M3.EQ.0 .AND. N.GT.0 ) THEN
RESULT( NTEST ) = ULPINV
GO TO 700
END IF
*
* Do test 78 (or +54)
*
TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
IF( N.GT.0 ) THEN
TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) )
ELSE
TEMP3 = ZERO
END IF
RESULT( NTEST ) = ( TEMP1+TEMP2 ) /
$ MAX( UNFL, TEMP3*ULP )
*
CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
*
1720 CONTINUE
*
* End of Loop -- Check for RESULT(j) > THRESH
*
NTESTT = NTESTT + NTEST
*
CALL DLAFTS( 'DST', N, N, JTYPE, NTEST, RESULT, IOLDSD,
$ THRESH, NOUNIT, NERRS )
*
1730 CONTINUE
1740 CONTINUE
*
* Summary
*
CALL ALASVM( 'DST', NOUNIT, NERRS, NTESTT, 0 )
*
9999 FORMAT( ' DDRVST: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
*
RETURN
*
* End of DDRVST
*
END
SUBROUTINE DDRVSX( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
$ NIUNIT, NOUNIT, A, LDA, H, HT, WR, WI, WRT,
$ WIT, WRTMP, WITMP, VS, LDVS, VS1, RESULT, WORK,
$ LWORK, IWORK, BWORK, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDVS, LWORK, NIUNIT, NOUNIT, NSIZES,
$ NTYPES
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL BWORK( * ), DOTYPE( * )
INTEGER ISEED( 4 ), IWORK( * ), NN( * )
DOUBLE PRECISION A( LDA, * ), H( LDA, * ), HT( LDA, * ),
$ RESULT( 17 ), VS( LDVS, * ), VS1( LDVS, * ),
$ WI( * ), WIT( * ), WITMP( * ), WORK( * ),
$ WR( * ), WRT( * ), WRTMP( * )
* ..
*
* Purpose
* =======
*
* DDRVSX checks the nonsymmetric eigenvalue (Schur form) problem
* expert driver DGEESX.
*
* DDRVSX uses both test matrices generated randomly depending on
* data supplied in the calling sequence, as well as on data
* read from an input file and including precomputed condition
* numbers to which it compares the ones it computes.
*
* When DDRVSX is called, a number of matrix "sizes" ("n's") and a
* number of matrix "types" are specified. For each size ("n")
* and each type of matrix, one matrix will be generated and used
* to test the nonsymmetric eigenroutines. For each matrix, 15
* tests will be performed:
*
* (1) 0 if T is in Schur form, 1/ulp otherwise
* (no sorting of eigenvalues)
*
* (2) | A - VS T VS' | / ( n |A| ulp )
*
* Here VS is the matrix of Schur eigenvectors, and T is in Schur
* form (no sorting of eigenvalues).
*
* (3) | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues).
*
* (4) 0 if WR+sqrt(-1)*WI are eigenvalues of T
* 1/ulp otherwise
* (no sorting of eigenvalues)
*
* (5) 0 if T(with VS) = T(without VS),
* 1/ulp otherwise
* (no sorting of eigenvalues)
*
* (6) 0 if eigenvalues(with VS) = eigenvalues(without VS),
* 1/ulp otherwise
* (no sorting of eigenvalues)
*
* (7) 0 if T is in Schur form, 1/ulp otherwise
* (with sorting of eigenvalues)
*
* (8) | A - VS T VS' | / ( n |A| ulp )
*
* Here VS is the matrix of Schur eigenvectors, and T is in Schur
* form (with sorting of eigenvalues).
*
* (9) | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues).
*
* (10) 0 if WR+sqrt(-1)*WI are eigenvalues of T
* 1/ulp otherwise
* If workspace sufficient, also compare WR, WI with and
* without reciprocal condition numbers
* (with sorting of eigenvalues)
*
* (11) 0 if T(with VS) = T(without VS),
* 1/ulp otherwise
* If workspace sufficient, also compare T with and without
* reciprocal condition numbers
* (with sorting of eigenvalues)
*
* (12) 0 if eigenvalues(with VS) = eigenvalues(without VS),
* 1/ulp otherwise
* If workspace sufficient, also compare VS with and without
* reciprocal condition numbers
* (with sorting of eigenvalues)
*
* (13) if sorting worked and SDIM is the number of
* eigenvalues which were SELECTed
* If workspace sufficient, also compare SDIM with and
* without reciprocal condition numbers
*
* (14) if RCONDE the same no matter if VS and/or RCONDV computed
*
* (15) if RCONDV the same no matter if VS and/or RCONDE computed
*
* The "sizes" are specified by an array NN(1:NSIZES); the value of
* each element NN(j) specifies one size.
* The "types" are specified by a logical array DOTYPE( 1:NTYPES );
* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
* Currently, the list of possible types is:
*
* (1) The zero matrix.
* (2) The identity matrix.
* (3) A (transposed) Jordan block, with 1's on the diagonal.
*
* (4) A diagonal matrix with evenly spaced entries
* 1, ..., ULP and random signs.
* (ULP = (first number larger than 1) - 1 )
* (5) A diagonal matrix with geometrically spaced entries
* 1, ..., ULP and random signs.
* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
* and random signs.
*
* (7) Same as (4), but multiplied by a constant near
* the overflow threshold
* (8) Same as (4), but multiplied by a constant near
* the underflow threshold
*
* (9) A matrix of the form U' T U, where U is orthogonal and
* T has evenly spaced entries 1, ..., ULP with random signs
* on the diagonal and random O(1) entries in the upper
* triangle.
*
* (10) A matrix of the form U' T U, where U is orthogonal and
* T has geometrically spaced entries 1, ..., ULP with random
* signs on the diagonal and random O(1) entries in the upper
* triangle.
*
* (11) A matrix of the form U' T U, where U is orthogonal and
* T has "clustered" entries 1, ULP,..., ULP with random
* signs on the diagonal and random O(1) entries in the upper
* triangle.
*
* (12) A matrix of the form U' T U, where U is orthogonal and
* T has real or complex conjugate paired eigenvalues randomly
* chosen from ( ULP, 1 ) and random O(1) entries in the upper
* triangle.
*
* (13) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP
* with random signs on the diagonal and random O(1) entries
* in the upper triangle.
*
* (14) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has geometrically spaced entries
* 1, ..., ULP with random signs on the diagonal and random
* O(1) entries in the upper triangle.
*
* (15) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP
* with random signs on the diagonal and random O(1) entries
* in the upper triangle.
*
* (16) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has real or complex conjugate paired
* eigenvalues randomly chosen from ( ULP, 1 ) and random
* O(1) entries in the upper triangle.
*
* (17) Same as (16), but multiplied by a constant
* near the overflow threshold
* (18) Same as (16), but multiplied by a constant
* near the underflow threshold
*
* (19) Nonsymmetric matrix with random entries chosen from (-1,1).
* If N is at least 4, all entries in first two rows and last
* row, and first column and last two columns are zero.
* (20) Same as (19), but multiplied by a constant
* near the overflow threshold
* (21) Same as (19), but multiplied by a constant
* near the underflow threshold
*
* In addition, an input file will be read from logical unit number
* NIUNIT. The file contains matrices along with precomputed
* eigenvalues and reciprocal condition numbers for the eigenvalue
* average and right invariant subspace. For these matrices, in
* addition to tests (1) to (15) we will compute the following two
* tests:
*
* (16) |RCONDE - RCDEIN| / cond(RCONDE)
*
* RCONDE is the reciprocal average eigenvalue condition number
* computed by DGEESX and RCDEIN (the precomputed true value)
* is supplied as input. cond(RCONDE) is the condition number
* of RCONDE, and takes errors in computing RCONDE into account,
* so that the resulting quantity should be O(ULP). cond(RCONDE)
* is essentially given by norm(A)/RCONDV.
*
* (17) |RCONDV - RCDVIN| / cond(RCONDV)
*
* RCONDV is the reciprocal right invariant subspace condition
* number computed by DGEESX and RCDVIN (the precomputed true
* value) is supplied as input. cond(RCONDV) is the condition
* number of RCONDV, and takes errors in computing RCONDV into
* account, so that the resulting quantity should be O(ULP).
* cond(RCONDV) is essentially given by norm(A)/RCONDE.
*
* Arguments
* =========
*
* NSIZES (input) INTEGER
* The number of sizes of matrices to use. NSIZES must be at
* least zero. If it is zero, no randomly generated matrices
* are tested, but any test matrices read from NIUNIT will be
* tested.
*
* NN (input) INTEGER array, dimension (NSIZES)
* An array containing the sizes to be used for the matrices.
* Zero values will be skipped. The values must be at least
* zero.
*
* NTYPES (input) INTEGER
* The number of elements in DOTYPE. NTYPES must be at least
* zero. If it is zero, no randomly generated test matrices
* are tested, but and test matrices read from NIUNIT will be
* tested. If it is MAXTYP+1 and NSIZES is 1, then an
* additional type, MAXTYP+1 is defined, which is to use
* whatever matrix is in A. This is only useful if
* DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. .
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* If DOTYPE(j) is .TRUE., then for each size in NN a
* matrix of that size and of type j will be generated.
* If NTYPES is smaller than the maximum number of types
* defined (PARAMETER MAXTYP), then types NTYPES+1 through
* MAXTYP will not be generated. If NTYPES is larger
* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
* will be ignored.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The array elements should be between 0 and 4095;
* if not they will be reduced mod 4096. Also, ISEED(4) must
* be odd. The random number generator uses a linear
* congruential sequence limited to small integers, and so
* should produce machine independent random numbers. The
* values of ISEED are changed on exit, and can be used in the
* next call to DDRVSX to continue the same random number
* sequence.
*
* THRESH (input) DOUBLE PRECISION
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error
* is scaled to be O(1), so THRESH should be a reasonably
* small multiple of 1, e.g., 10 or 100. In particular,
* it should not depend on the precision (single vs. double)
* or the size of the matrix. It must be at least zero.
*
* NIUNIT (input) INTEGER
* The FORTRAN unit number for reading in the data file of
* problems to solve.
*
* NOUNIT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns INFO not equal to 0.)
*
* A (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
* Used to hold the matrix whose eigenvalues are to be
* computed. On exit, A contains the last matrix actually used.
*
* LDA (input) INTEGER
* The leading dimension of A, and H. LDA must be at
* least 1 and at least max( NN ).
*
* H (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
* Another copy of the test matrix A, modified by DGEESX.
*
* HT (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
* Yet another copy of the test matrix A, modified by DGEESX.
*
* WR (workspace) DOUBLE PRECISION array, dimension (max(NN))
* WI (workspace) DOUBLE PRECISION array, dimension (max(NN))
* The real and imaginary parts of the eigenvalues of A.
* On exit, WR + WI*i are the eigenvalues of the matrix in A.
*
* WRT (workspace) DOUBLE PRECISION array, dimension (max(NN))
* WIT (workspace) DOUBLE PRECISION array, dimension (max(NN))
* Like WR, WI, these arrays contain the eigenvalues of A,
* but those computed when DGEESX only computes a partial
* eigendecomposition, i.e. not Schur vectors
*
* WRTMP (workspace) DOUBLE PRECISION array, dimension (max(NN))
* WITMP (workspace) DOUBLE PRECISION array, dimension (max(NN))
* More temporary storage for eigenvalues.
*
* VS (workspace) DOUBLE PRECISION array, dimension (LDVS, max(NN))
* VS holds the computed Schur vectors.
*
* LDVS (input) INTEGER
* Leading dimension of VS. Must be at least max(1,max(NN)).
*
* VS1 (workspace) DOUBLE PRECISION array, dimension (LDVS, max(NN))
* VS1 holds another copy of the computed Schur vectors.
*
* RESULT (output) DOUBLE PRECISION array, dimension (17)
* The values computed by the 17 tests described above.
* The values are currently limited to 1/ulp, to avoid overflow.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The number of entries in WORK. This must be at least
* max(3*NN(j),2*NN(j)**2) for all j.
*
* IWORK (workspace) INTEGER array, dimension (max(NN)*max(NN))
*
* INFO (output) INTEGER
* If 0, successful exit.
* <0, input parameter -INFO is incorrect
* >0, DLATMR, SLATMS, SLATME or DGET24 returned an error
* code and INFO is its absolute value
*
*-----------------------------------------------------------------------
*
* Some Local Variables and Parameters:
* ---- ----- --------- --- ----------
* ZERO, ONE Real 0 and 1.
* MAXTYP The number of types defined.
* NMAX Largest value in NN.
* NERRS The number of tests which have exceeded THRESH
* COND, CONDS,
* IMODE Values to be passed to the matrix generators.
* ANORM Norm of A; passed to matrix generators.
*
* OVFL, UNFL Overflow and underflow thresholds.
* ULP, ULPINV Finest relative precision and its inverse.
* RTULP, RTULPI Square roots of the previous 4 values.
* The following four arrays decode JTYPE:
* KTYPE(j) The general type (1-10) for type "j".
* KMODE(j) The MODE value to be passed to the matrix
* generator for type "j".
* KMAGN(j) The order of magnitude ( O(1),
* O(overflow^(1/2) ), O(underflow^(1/2) )
* KCONDS(j) Selectw whether CONDS is to be 1 or
* 1/sqrt(ulp). (0 means irrelevant.)
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 21 )
* ..
* .. Local Scalars ..
LOGICAL BADNN
CHARACTER*3 PATH
INTEGER I, IINFO, IMODE, ITYPE, IWK, J, JCOL, JSIZE,
$ JTYPE, MTYPES, N, NERRS, NFAIL, NMAX, NNWORK,
$ NSLCT, NTEST, NTESTF, NTESTT
DOUBLE PRECISION ANORM, COND, CONDS, OVFL, RCDEIN, RCDVIN,
$ RTULP, RTULPI, ULP, ULPINV, UNFL
* ..
* .. Local Arrays ..
CHARACTER ADUMMA( 1 )
INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISLCT( 20 ),
$ KCONDS( MAXTYP ), KMAGN( MAXTYP ),
$ KMODE( MAXTYP ), KTYPE( MAXTYP )
* ..
* .. Arrays in Common ..
LOGICAL SELVAL( 20 )
DOUBLE PRECISION SELWI( 20 ), SELWR( 20 )
* ..
* .. Scalars in Common ..
INTEGER SELDIM, SELOPT
* ..
* .. Common blocks ..
COMMON / SSLCT / SELOPT, SELDIM, SELVAL, SELWR, SELWI
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DGET24, DLABAD, DLASET, DLASUM, DLATME, DLATMR,
$ DLATMS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Data statements ..
DATA KTYPE / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
DATA KMAGN / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
$ 3, 1, 2, 3 /
DATA KMODE / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
$ 1, 5, 5, 5, 4, 3, 1 /
DATA KCONDS / 3*0, 5*0, 4*1, 6*2, 3*0 /
* ..
* .. Executable Statements ..
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'SX'
*
* Check for errors
*
NTESTT = 0
NTESTF = 0
INFO = 0
*
* Important constants
*
BADNN = .FALSE.
*
* 12 is the largest dimension in the input file of precomputed
* problems
*
NMAX = 12
DO 10 J = 1, NSIZES
NMAX = MAX( NMAX, NN( J ) )
IF( NN( J ).LT.0 )
$ BADNN = .TRUE.
10 CONTINUE
*
* Check for errors
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADNN ) THEN
INFO = -2
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -3
ELSE IF( THRESH.LT.ZERO ) THEN
INFO = -6
ELSE IF( NIUNIT.LE.0 ) THEN
INFO = -7
ELSE IF( NOUNIT.LE.0 ) THEN
INFO = -8
ELSE IF( LDA.LT.1 .OR. LDA.LT.NMAX ) THEN
INFO = -10
ELSE IF( LDVS.LT.1 .OR. LDVS.LT.NMAX ) THEN
INFO = -20
ELSE IF( MAX( 3*NMAX, 2*NMAX**2 ).GT.LWORK ) THEN
INFO = -24
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DDRVSX', -INFO )
RETURN
END IF
*
* If nothing to do check on NIUNIT
*
IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
$ GO TO 150
*
* More Important constants
*
UNFL = DLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
CALL DLABAD( UNFL, OVFL )
ULP = DLAMCH( 'Precision' )
ULPINV = ONE / ULP
RTULP = SQRT( ULP )
RTULPI = ONE / RTULP
*
* Loop over sizes, types
*
NERRS = 0
*
DO 140 JSIZE = 1, NSIZES
N = NN( JSIZE )
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
DO 130 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 130
*
* Save ISEED in case of an error.
*
DO 20 J = 1, 4
IOLDSD( J ) = ISEED( J )
20 CONTINUE
*
* Compute "A"
*
* Control parameters:
*
* KMAGN KCONDS KMODE KTYPE
* =1 O(1) 1 clustered 1 zero
* =2 large large clustered 2 identity
* =3 small exponential Jordan
* =4 arithmetic diagonal, (w/ eigenvalues)
* =5 random log symmetric, w/ eigenvalues
* =6 random general, w/ eigenvalues
* =7 random diagonal
* =8 random symmetric
* =9 random general
* =10 random triangular
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 90
*
ITYPE = KTYPE( JTYPE )
IMODE = KMODE( JTYPE )
*
* Compute norm
*
GO TO ( 30, 40, 50 )KMAGN( JTYPE )
*
30 CONTINUE
ANORM = ONE
GO TO 60
*
40 CONTINUE
ANORM = OVFL*ULP
GO TO 60
*
50 CONTINUE
ANORM = UNFL*ULPINV
GO TO 60
*
60 CONTINUE
*
CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
IINFO = 0
COND = ULPINV
*
* Special Matrices -- Identity & Jordan block
*
* Zero
*
IF( ITYPE.EQ.1 ) THEN
IINFO = 0
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Identity
*
DO 70 JCOL = 1, N
A( JCOL, JCOL ) = ANORM
70 CONTINUE
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* Jordan Block
*
DO 80 JCOL = 1, N
A( JCOL, JCOL ) = ANORM
IF( JCOL.GT.1 )
$ A( JCOL, JCOL-1 ) = ONE
80 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Diagonal Matrix, [Eigen]values Specified
*
CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.5 ) THEN
*
* Symmetric, eigenvalues specified
*
CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, N, N, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.6 ) THEN
*
* General, eigenvalues specified
*
IF( KCONDS( JTYPE ).EQ.1 ) THEN
CONDS = ONE
ELSE IF( KCONDS( JTYPE ).EQ.2 ) THEN
CONDS = RTULPI
ELSE
CONDS = ZERO
END IF
*
ADUMMA( 1 ) = ' '
CALL DLATME( N, 'S', ISEED, WORK, IMODE, COND, ONE,
$ ADUMMA, 'T', 'T', 'T', WORK( N+1 ), 4,
$ CONDS, N, N, ANORM, A, LDA, WORK( 2*N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.7 ) THEN
*
* Diagonal, random eigenvalues
*
CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.8 ) THEN
*
* Symmetric, random eigenvalues
*
CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.9 ) THEN
*
* General, random eigenvalues
*
CALL DLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
IF( N.GE.4 ) THEN
CALL DLASET( 'Full', 2, N, ZERO, ZERO, A, LDA )
CALL DLASET( 'Full', N-3, 1, ZERO, ZERO, A( 3, 1 ),
$ LDA )
CALL DLASET( 'Full', N-3, 2, ZERO, ZERO, A( 3, N-1 ),
$ LDA )
CALL DLASET( 'Full', 1, N, ZERO, ZERO, A( N, 1 ),
$ LDA )
END IF
*
ELSE IF( ITYPE.EQ.10 ) THEN
*
* Triangular, random eigenvalues
*
CALL DLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, 0,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE
*
IINFO = 1
END IF
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9991 )'Generator', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
90 CONTINUE
*
* Test for minimal and generous workspace
*
DO 120 IWK = 1, 2
IF( IWK.EQ.1 ) THEN
NNWORK = 3*N
ELSE
NNWORK = MAX( 3*N, 2*N*N )
END IF
NNWORK = MAX( NNWORK, 1 )
*
CALL DGET24( .FALSE., JTYPE, THRESH, IOLDSD, NOUNIT, N,
$ A, LDA, H, HT, WR, WI, WRT, WIT, WRTMP,
$ WITMP, VS, LDVS, VS1, RCDEIN, RCDVIN, NSLCT,
$ ISLCT, RESULT, WORK, NNWORK, IWORK, BWORK,
$ INFO )
*
* Check for RESULT(j) > THRESH
*
NTEST = 0
NFAIL = 0
DO 100 J = 1, 15
IF( RESULT( J ).GE.ZERO )
$ NTEST = NTEST + 1
IF( RESULT( J ).GE.THRESH )
$ NFAIL = NFAIL + 1
100 CONTINUE
*
IF( NFAIL.GT.0 )
$ NTESTF = NTESTF + 1
IF( NTESTF.EQ.1 ) THEN
WRITE( NOUNIT, FMT = 9999 )PATH
WRITE( NOUNIT, FMT = 9998 )
WRITE( NOUNIT, FMT = 9997 )
WRITE( NOUNIT, FMT = 9996 )
WRITE( NOUNIT, FMT = 9995 )THRESH
WRITE( NOUNIT, FMT = 9994 )
NTESTF = 2
END IF
*
DO 110 J = 1, 15
IF( RESULT( J ).GE.THRESH ) THEN
WRITE( NOUNIT, FMT = 9993 )N, IWK, IOLDSD, JTYPE,
$ J, RESULT( J )
END IF
110 CONTINUE
*
NERRS = NERRS + NFAIL
NTESTT = NTESTT + NTEST
*
120 CONTINUE
130 CONTINUE
140 CONTINUE
*
150 CONTINUE
*
* Read in data from file to check accuracy of condition estimation
* Read input data until N=0
*
JTYPE = 0
160 CONTINUE
READ( NIUNIT, FMT = *, END = 200 )N, NSLCT
IF( N.EQ.0 )
$ GO TO 200
JTYPE = JTYPE + 1
ISEED( 1 ) = JTYPE
IF( NSLCT.GT.0 )
$ READ( NIUNIT, FMT = * )( ISLCT( I ), I = 1, NSLCT )
DO 170 I = 1, N
READ( NIUNIT, FMT = * )( A( I, J ), J = 1, N )
170 CONTINUE
READ( NIUNIT, FMT = * )RCDEIN, RCDVIN
*
CALL DGET24( .TRUE., 22, THRESH, ISEED, NOUNIT, N, A, LDA, H, HT,
$ WR, WI, WRT, WIT, WRTMP, WITMP, VS, LDVS, VS1,
$ RCDEIN, RCDVIN, NSLCT, ISLCT, RESULT, WORK, LWORK,
$ IWORK, BWORK, INFO )
*
* Check for RESULT(j) > THRESH
*
NTEST = 0
NFAIL = 0
DO 180 J = 1, 17
IF( RESULT( J ).GE.ZERO )
$ NTEST = NTEST + 1
IF( RESULT( J ).GE.THRESH )
$ NFAIL = NFAIL + 1
180 CONTINUE
*
IF( NFAIL.GT.0 )
$ NTESTF = NTESTF + 1
IF( NTESTF.EQ.1 ) THEN
WRITE( NOUNIT, FMT = 9999 )PATH
WRITE( NOUNIT, FMT = 9998 )
WRITE( NOUNIT, FMT = 9997 )
WRITE( NOUNIT, FMT = 9996 )
WRITE( NOUNIT, FMT = 9995 )THRESH
WRITE( NOUNIT, FMT = 9994 )
NTESTF = 2
END IF
DO 190 J = 1, 17
IF( RESULT( J ).GE.THRESH ) THEN
WRITE( NOUNIT, FMT = 9992 )N, JTYPE, J, RESULT( J )
END IF
190 CONTINUE
*
NERRS = NERRS + NFAIL
NTESTT = NTESTT + NTEST
GO TO 160
200 CONTINUE
*
* Summary
*
CALL DLASUM( PATH, NOUNIT, NERRS, NTESTT )
*
9999 FORMAT( / 1X, A3, ' -- Real Schur Form Decomposition Expert ',
$ 'Driver', / ' Matrix types (see DDRVSX for details):' )
*
9998 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ',
$ ' ', ' 5=Diagonal: geometr. spaced entries.',
$ / ' 2=Identity matrix. ', ' 6=Diagona',
$ 'l: clustered entries.', / ' 3=Transposed Jordan block. ',
$ ' ', ' 7=Diagonal: large, evenly spaced.', / ' ',
$ '4=Diagonal: evenly spaced entries. ', ' 8=Diagonal: s',
$ 'mall, evenly spaced.' )
9997 FORMAT( ' Dense, Non-Symmetric Matrices:', / ' 9=Well-cond., ev',
$ 'enly spaced eigenvals.', ' 14=Ill-cond., geomet. spaced e',
$ 'igenals.', / ' 10=Well-cond., geom. spaced eigenvals. ',
$ ' 15=Ill-conditioned, clustered e.vals.', / ' 11=Well-cond',
$ 'itioned, clustered e.vals. ', ' 16=Ill-cond., random comp',
$ 'lex ', / ' 12=Well-cond., random complex ', ' ',
$ ' 17=Ill-cond., large rand. complx ', / ' 13=Ill-condi',
$ 'tioned, evenly spaced. ', ' 18=Ill-cond., small rand.',
$ ' complx ' )
9996 FORMAT( ' 19=Matrix with random O(1) entries. ', ' 21=Matrix ',
$ 'with small random entries.', / ' 20=Matrix with large ran',
$ 'dom entries. ', / )
9995 FORMAT( ' Tests performed with test threshold =', F8.2,
$ / ' ( A denotes A on input and T denotes A on output)',
$ / / ' 1 = 0 if T in Schur form (no sort), ',
$ ' 1/ulp otherwise', /
$ ' 2 = | A - VS T transpose(VS) | / ( n |A| ulp ) (no sort)',
$ / ' 3 = | I - VS transpose(VS) | / ( n ulp ) (no sort) ', /
$ ' 4 = 0 if WR+sqrt(-1)*WI are eigenvalues of T (no sort),',
$ ' 1/ulp otherwise', /
$ ' 5 = 0 if T same no matter if VS computed (no sort),',
$ ' 1/ulp otherwise', /
$ ' 6 = 0 if WR, WI same no matter if VS computed (no sort)',
$ ', 1/ulp otherwise' )
9994 FORMAT( ' 7 = 0 if T in Schur form (sort), ', ' 1/ulp otherwise',
$ / ' 8 = | A - VS T transpose(VS) | / ( n |A| ulp ) (sort)',
$ / ' 9 = | I - VS transpose(VS) | / ( n ulp ) (sort) ',
$ / ' 10 = 0 if WR+sqrt(-1)*WI are eigenvalues of T (sort),',
$ ' 1/ulp otherwise', /
$ ' 11 = 0 if T same no matter what else computed (sort),',
$ ' 1/ulp otherwise', /
$ ' 12 = 0 if WR, WI same no matter what else computed ',
$ '(sort), 1/ulp otherwise', /
$ ' 13 = 0 if sorting succesful, 1/ulp otherwise',
$ / ' 14 = 0 if RCONDE same no matter what else computed,',
$ ' 1/ulp otherwise', /
$ ' 15 = 0 if RCONDv same no matter what else computed,',
$ ' 1/ulp otherwise', /
$ ' 16 = | RCONDE - RCONDE(precomputed) | / cond(RCONDE),',
$ / ' 17 = | RCONDV - RCONDV(precomputed) | / cond(RCONDV),' )
9993 FORMAT( ' N=', I5, ', IWK=', I2, ', seed=', 4( I4, ',' ),
$ ' type ', I2, ', test(', I2, ')=', G10.3 )
9992 FORMAT( ' N=', I5, ', input example =', I3, ', test(', I2, ')=',
$ G10.3 )
9991 FORMAT( ' DDRVSX: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
*
RETURN
*
* End of DDRVSX
*
END
SUBROUTINE DDRVVX( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
$ NIUNIT, NOUNIT, A, LDA, H, WR, WI, WR1, WI1,
$ VL, LDVL, VR, LDVR, LRE, LDLRE, RCONDV, RCNDV1,
$ RCDVIN, RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1,
$ RESULT, WORK, NWORK, IWORK, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NIUNIT, NOUNIT,
$ NSIZES, NTYPES, NWORK
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER ISEED( 4 ), IWORK( * ), NN( * )
DOUBLE PRECISION A( LDA, * ), H( LDA, * ), LRE( LDLRE, * ),
$ RCDEIN( * ), RCDVIN( * ), RCNDE1( * ),
$ RCNDV1( * ), RCONDE( * ), RCONDV( * ),
$ RESULT( 11 ), SCALE( * ), SCALE1( * ),
$ VL( LDVL, * ), VR( LDVR, * ), WI( * ),
$ WI1( * ), WORK( * ), WR( * ), WR1( * )
* ..
*
* Purpose
* =======
*
* DDRVVX checks the nonsymmetric eigenvalue problem expert driver
* DGEEVX.
*
* DDRVVX uses both test matrices generated randomly depending on
* data supplied in the calling sequence, as well as on data
* read from an input file and including precomputed condition
* numbers to which it compares the ones it computes.
*
* When DDRVVX is called, a number of matrix "sizes" ("n's") and a
* number of matrix "types" are specified in the calling sequence.
* For each size ("n") and each type of matrix, one matrix will be
* generated and used to test the nonsymmetric eigenroutines. For
* each matrix, 9 tests will be performed:
*
* (1) | A * VR - VR * W | / ( n |A| ulp )
*
* Here VR is the matrix of unit right eigenvectors.
* W is a block diagonal matrix, with a 1x1 block for each
* real eigenvalue and a 2x2 block for each complex conjugate
* pair. If eigenvalues j and j+1 are a complex conjugate pair,
* so WR(j) = WR(j+1) = wr and WI(j) = - WI(j+1) = wi, then the
* 2 x 2 block corresponding to the pair will be:
*
* ( wr wi )
* ( -wi wr )
*
* Such a block multiplying an n x 2 matrix ( ur ui ) on the
* right will be the same as multiplying ur + i*ui by wr + i*wi.
*
* (2) | A**H * VL - VL * W**H | / ( n |A| ulp )
*
* Here VL is the matrix of unit left eigenvectors, A**H is the
* conjugate transpose of A, and W is as above.
*
* (3) | |VR(i)| - 1 | / ulp and largest component real
*
* VR(i) denotes the i-th column of VR.
*
* (4) | |VL(i)| - 1 | / ulp and largest component real
*
* VL(i) denotes the i-th column of VL.
*
* (5) W(full) = W(partial)
*
* W(full) denotes the eigenvalues computed when VR, VL, RCONDV
* and RCONDE are also computed, and W(partial) denotes the
* eigenvalues computed when only some of VR, VL, RCONDV, and
* RCONDE are computed.
*
* (6) VR(full) = VR(partial)
*
* VR(full) denotes the right eigenvectors computed when VL, RCONDV
* and RCONDE are computed, and VR(partial) denotes the result
* when only some of VL and RCONDV are computed.
*
* (7) VL(full) = VL(partial)
*
* VL(full) denotes the left eigenvectors computed when VR, RCONDV
* and RCONDE are computed, and VL(partial) denotes the result
* when only some of VR and RCONDV are computed.
*
* (8) 0 if SCALE, ILO, IHI, ABNRM (full) =
* SCALE, ILO, IHI, ABNRM (partial)
* 1/ulp otherwise
*
* SCALE, ILO, IHI and ABNRM describe how the matrix is balanced.
* (full) is when VR, VL, RCONDE and RCONDV are also computed, and
* (partial) is when some are not computed.
*
* (9) RCONDV(full) = RCONDV(partial)
*
* RCONDV(full) denotes the reciprocal condition numbers of the
* right eigenvectors computed when VR, VL and RCONDE are also
* computed. RCONDV(partial) denotes the reciprocal condition
* numbers when only some of VR, VL and RCONDE are computed.
*
* The "sizes" are specified by an array NN(1:NSIZES); the value of
* each element NN(j) specifies one size.
* The "types" are specified by a logical array DOTYPE( 1:NTYPES );
* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
* Currently, the list of possible types is:
*
* (1) The zero matrix.
* (2) The identity matrix.
* (3) A (transposed) Jordan block, with 1's on the diagonal.
*
* (4) A diagonal matrix with evenly spaced entries
* 1, ..., ULP and random signs.
* (ULP = (first number larger than 1) - 1 )
* (5) A diagonal matrix with geometrically spaced entries
* 1, ..., ULP and random signs.
* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
* and random signs.
*
* (7) Same as (4), but multiplied by a constant near
* the overflow threshold
* (8) Same as (4), but multiplied by a constant near
* the underflow threshold
*
* (9) A matrix of the form U' T U, where U is orthogonal and
* T has evenly spaced entries 1, ..., ULP with random signs
* on the diagonal and random O(1) entries in the upper
* triangle.
*
* (10) A matrix of the form U' T U, where U is orthogonal and
* T has geometrically spaced entries 1, ..., ULP with random
* signs on the diagonal and random O(1) entries in the upper
* triangle.
*
* (11) A matrix of the form U' T U, where U is orthogonal and
* T has "clustered" entries 1, ULP,..., ULP with random
* signs on the diagonal and random O(1) entries in the upper
* triangle.
*
* (12) A matrix of the form U' T U, where U is orthogonal and
* T has real or complex conjugate paired eigenvalues randomly
* chosen from ( ULP, 1 ) and random O(1) entries in the upper
* triangle.
*
* (13) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP
* with random signs on the diagonal and random O(1) entries
* in the upper triangle.
*
* (14) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has geometrically spaced entries
* 1, ..., ULP with random signs on the diagonal and random
* O(1) entries in the upper triangle.
*
* (15) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP
* with random signs on the diagonal and random O(1) entries
* in the upper triangle.
*
* (16) A matrix of the form X' T X, where X has condition
* SQRT( ULP ) and T has real or complex conjugate paired
* eigenvalues randomly chosen from ( ULP, 1 ) and random
* O(1) entries in the upper triangle.
*
* (17) Same as (16), but multiplied by a constant
* near the overflow threshold
* (18) Same as (16), but multiplied by a constant
* near the underflow threshold
*
* (19) Nonsymmetric matrix with random entries chosen from (-1,1).
* If N is at least 4, all entries in first two rows and last
* row, and first column and last two columns are zero.
* (20) Same as (19), but multiplied by a constant
* near the overflow threshold
* (21) Same as (19), but multiplied by a constant
* near the underflow threshold
*
* In addition, an input file will be read from logical unit number
* NIUNIT. The file contains matrices along with precomputed
* eigenvalues and reciprocal condition numbers for the eigenvalues
* and right eigenvectors. For these matrices, in addition to tests
* (1) to (9) we will compute the following two tests:
*
* (10) |RCONDV - RCDVIN| / cond(RCONDV)
*
* RCONDV is the reciprocal right eigenvector condition number
* computed by DGEEVX and RCDVIN (the precomputed true value)
* is supplied as input. cond(RCONDV) is the condition number of
* RCONDV, and takes errors in computing RCONDV into account, so
* that the resulting quantity should be O(ULP). cond(RCONDV) is
* essentially given by norm(A)/RCONDE.
*
* (11) |RCONDE - RCDEIN| / cond(RCONDE)
*
* RCONDE is the reciprocal eigenvalue condition number
* computed by DGEEVX and RCDEIN (the precomputed true value)
* is supplied as input. cond(RCONDE) is the condition number
* of RCONDE, and takes errors in computing RCONDE into account,
* so that the resulting quantity should be O(ULP). cond(RCONDE)
* is essentially given by norm(A)/RCONDV.
*
* Arguments
* ==========
*
* NSIZES (input) INTEGER
* The number of sizes of matrices to use. NSIZES must be at
* least zero. If it is zero, no randomly generated matrices
* are tested, but any test matrices read from NIUNIT will be
* tested.
*
* NN (input) INTEGER array, dimension (NSIZES)
* An array containing the sizes to be used for the matrices.
* Zero values will be skipped. The values must be at least
* zero.
*
* NTYPES (input) INTEGER
* The number of elements in DOTYPE. NTYPES must be at least
* zero. If it is zero, no randomly generated test matrices
* are tested, but and test matrices read from NIUNIT will be
* tested. If it is MAXTYP+1 and NSIZES is 1, then an
* additional type, MAXTYP+1 is defined, which is to use
* whatever matrix is in A. This is only useful if
* DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. .
*
* DOTYPE (input) LOGICAL array, dimension (NTYPES)
* If DOTYPE(j) is .TRUE., then for each size in NN a
* matrix of that size and of type j will be generated.
* If NTYPES is smaller than the maximum number of types
* defined (PARAMETER MAXTYP), then types NTYPES+1 through
* MAXTYP will not be generated. If NTYPES is larger
* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
* will be ignored.
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The array elements should be between 0 and 4095;
* if not they will be reduced mod 4096. Also, ISEED(4) must
* be odd. The random number generator uses a linear
* congruential sequence limited to small integers, and so
* should produce machine independent random numbers. The
* values of ISEED are changed on exit, and can be used in the
* next call to DDRVVX to continue the same random number
* sequence.
*
* THRESH (input) DOUBLE PRECISION
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error
* is scaled to be O(1), so THRESH should be a reasonably
* small multiple of 1, e.g., 10 or 100. In particular,
* it should not depend on the precision (single vs. double)
* or the size of the matrix. It must be at least zero.
*
* NIUNIT (input) INTEGER
* The FORTRAN unit number for reading in the data file of
* problems to solve.
*
* NOUNIT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns INFO not equal to 0.)
*
* A (workspace) DOUBLE PRECISION array, dimension
* (LDA, max(NN,12))
* Used to hold the matrix whose eigenvalues are to be
* computed. On exit, A contains the last matrix actually used.
*
* LDA (input) INTEGER
* The leading dimension of the arrays A and H.
* LDA >= max(NN,12), since 12 is the dimension of the largest
* matrix in the precomputed input file.
*
* H (workspace) DOUBLE PRECISION array, dimension
* (LDA, max(NN,12))
* Another copy of the test matrix A, modified by DGEEVX.
*
* WR (workspace) DOUBLE PRECISION array, dimension (max(NN))
* WI (workspace) DOUBLE PRECISION array, dimension (max(NN))
* The real and imaginary parts of the eigenvalues of A.
* On exit, WR + WI*i are the eigenvalues of the matrix in A.
*
* WR1 (workspace) DOUBLE PRECISION array, dimension (max(NN,12))
* WI1 (workspace) DOUBLE PRECISION array, dimension (max(NN,12))
* Like WR, WI, these arrays contain the eigenvalues of A,
* but those computed when DGEEVX only computes a partial
* eigendecomposition, i.e. not the eigenvalues and left
* and right eigenvectors.
*
* VL (workspace) DOUBLE PRECISION array, dimension
* (LDVL, max(NN,12))
* VL holds the computed left eigenvectors.
*
* LDVL (input) INTEGER
* Leading dimension of VL. Must be at least max(1,max(NN,12)).
*
* VR (workspace) DOUBLE PRECISION array, dimension
* (LDVR, max(NN,12))
* VR holds the computed right eigenvectors.
*
* LDVR (input) INTEGER
* Leading dimension of VR. Must be at least max(1,max(NN,12)).
*
* LRE (workspace) DOUBLE PRECISION array, dimension
* (LDLRE, max(NN,12))
* LRE holds the computed right or left eigenvectors.
*
* LDLRE (input) INTEGER
* Leading dimension of LRE. Must be at least max(1,max(NN,12))
*
* RCONDV (workspace) DOUBLE PRECISION array, dimension (N)
* RCONDV holds the computed reciprocal condition numbers
* for eigenvectors.
*
* RCNDV1 (workspace) DOUBLE PRECISION array, dimension (N)
* RCNDV1 holds more computed reciprocal condition numbers
* for eigenvectors.
*
* RCDVIN (workspace) DOUBLE PRECISION array, dimension (N)
* When COMP = .TRUE. RCDVIN holds the precomputed reciprocal
* condition numbers for eigenvectors to be compared with
* RCONDV.
*
* RCONDE (workspace) DOUBLE PRECISION array, dimension (N)
* RCONDE holds the computed reciprocal condition numbers
* for eigenvalues.
*
* RCNDE1 (workspace) DOUBLE PRECISION array, dimension (N)
* RCNDE1 holds more computed reciprocal condition numbers
* for eigenvalues.
*
* RCDEIN (workspace) DOUBLE PRECISION array, dimension (N)
* When COMP = .TRUE. RCDEIN holds the precomputed reciprocal
* condition numbers for eigenvalues to be compared with
* RCONDE.
*
* RESULT (output) DOUBLE PRECISION array, dimension (11)
* The values computed by the seven tests described above.
* The values are currently limited to 1/ulp, to avoid overflow.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (NWORK)
*
* NWORK (input) INTEGER
* The number of entries in WORK. This must be at least
* max(6*12+2*12**2,6*NN(j)+2*NN(j)**2) =
* max( 360 ,6*NN(j)+2*NN(j)**2) for all j.
*
* IWORK (workspace) INTEGER array, dimension (2*max(NN,12))
*
* INFO (output) INTEGER
* If 0, then successful exit.
* If <0, then input paramter -INFO is incorrect.
* If >0, DLATMR, SLATMS, SLATME or DGET23 returned an error
* code, and INFO is its absolute value.
*
*-----------------------------------------------------------------------
*
* Some Local Variables and Parameters:
* ---- ----- --------- --- ----------
*
* ZERO, ONE Real 0 and 1.
* MAXTYP The number of types defined.
* NMAX Largest value in NN or 12.
* NERRS The number of tests which have exceeded THRESH
* COND, CONDS,
* IMODE Values to be passed to the matrix generators.
* ANORM Norm of A; passed to matrix generators.
*
* OVFL, UNFL Overflow and underflow thresholds.
* ULP, ULPINV Finest relative precision and its inverse.
* RTULP, RTULPI Square roots of the previous 4 values.
*
* The following four arrays decode JTYPE:
* KTYPE(j) The general type (1-10) for type "j".
* KMODE(j) The MODE value to be passed to the matrix
* generator for type "j".
* KMAGN(j) The order of magnitude ( O(1),
* O(overflow^(1/2) ), O(underflow^(1/2) )
* KCONDS(j) Selectw whether CONDS is to be 1 or
* 1/sqrt(ulp). (0 means irrelevant.)
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 21 )
* ..
* .. Local Scalars ..
LOGICAL BADNN
CHARACTER BALANC
CHARACTER*3 PATH
INTEGER I, IBAL, IINFO, IMODE, ITYPE, IWK, J, JCOL,
$ JSIZE, JTYPE, MTYPES, N, NERRS, NFAIL, NMAX,
$ NNWORK, NTEST, NTESTF, NTESTT
DOUBLE PRECISION ANORM, COND, CONDS, OVFL, RTULP, RTULPI, ULP,
$ ULPINV, UNFL
* ..
* .. Local Arrays ..
CHARACTER ADUMMA( 1 ), BAL( 4 )
INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( MAXTYP ),
$ KMAGN( MAXTYP ), KMODE( MAXTYP ),
$ KTYPE( MAXTYP )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DGET23, DLABAD, DLASET, DLASUM, DLATME, DLATMR,
$ DLATMS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Data statements ..
DATA KTYPE / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
DATA KMAGN / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
$ 3, 1, 2, 3 /
DATA KMODE / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
$ 1, 5, 5, 5, 4, 3, 1 /
DATA KCONDS / 3*0, 5*0, 4*1, 6*2, 3*0 /
DATA BAL / 'N', 'P', 'S', 'B' /
* ..
* .. Executable Statements ..
*
PATH( 1: 1 ) = 'Double precision'
PATH( 2: 3 ) = 'VX'
*
* Check for errors
*
NTESTT = 0
NTESTF = 0
INFO = 0
*
* Important constants
*
BADNN = .FALSE.
*
* 12 is the largest dimension in the input file of precomputed
* problems
*
NMAX = 12
DO 10 J = 1, NSIZES
NMAX = MAX( NMAX, NN( J ) )
IF( NN( J ).LT.0 )
$ BADNN = .TRUE.
10 CONTINUE
*
* Check for errors
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADNN ) THEN
INFO = -2
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -3
ELSE IF( THRESH.LT.ZERO ) THEN
INFO = -6
ELSE IF( LDA.LT.1 .OR. LDA.LT.NMAX ) THEN
INFO = -10
ELSE IF( LDVL.LT.1 .OR. LDVL.LT.NMAX ) THEN
INFO = -17
ELSE IF( LDVR.LT.1 .OR. LDVR.LT.NMAX ) THEN
INFO = -19
ELSE IF( LDLRE.LT.1 .OR. LDLRE.LT.NMAX ) THEN
INFO = -21
ELSE IF( 6*NMAX+2*NMAX**2.GT.NWORK ) THEN
INFO = -32
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DDRVVX', -INFO )
RETURN
END IF
*
* If nothing to do check on NIUNIT
*
IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
$ GO TO 160
*
* More Important constants
*
UNFL = DLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
CALL DLABAD( UNFL, OVFL )
ULP = DLAMCH( 'Precision' )
ULPINV = ONE / ULP
RTULP = SQRT( ULP )
RTULPI = ONE / RTULP
*
* Loop over sizes, types
*
NERRS = 0
*
DO 150 JSIZE = 1, NSIZES
N = NN( JSIZE )
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
DO 140 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 140
*
* Save ISEED in case of an error.
*
DO 20 J = 1, 4
IOLDSD( J ) = ISEED( J )
20 CONTINUE
*
* Compute "A"
*
* Control parameters:
*
* KMAGN KCONDS KMODE KTYPE
* =1 O(1) 1 clustered 1 zero
* =2 large large clustered 2 identity
* =3 small exponential Jordan
* =4 arithmetic diagonal, (w/ eigenvalues)
* =5 random log symmetric, w/ eigenvalues
* =6 random general, w/ eigenvalues
* =7 random diagonal
* =8 random symmetric
* =9 random general
* =10 random triangular
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 90
*
ITYPE = KTYPE( JTYPE )
IMODE = KMODE( JTYPE )
*
* Compute norm
*
GO TO ( 30, 40, 50 )KMAGN( JTYPE )
*
30 CONTINUE
ANORM = ONE
GO TO 60
*
40 CONTINUE
ANORM = OVFL*ULP
GO TO 60
*
50 CONTINUE
ANORM = UNFL*ULPINV
GO TO 60
*
60 CONTINUE
*
CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
IINFO = 0
COND = ULPINV
*
* Special Matrices -- Identity & Jordan block
*
* Zero
*
IF( ITYPE.EQ.1 ) THEN
IINFO = 0
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Identity
*
DO 70 JCOL = 1, N
A( JCOL, JCOL ) = ANORM
70 CONTINUE
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* Jordan Block
*
DO 80 JCOL = 1, N
A( JCOL, JCOL ) = ANORM
IF( JCOL.GT.1 )
$ A( JCOL, JCOL-1 ) = ONE
80 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Diagonal Matrix, [Eigen]values Specified
*
CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.5 ) THEN
*
* Symmetric, eigenvalues specified
*
CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, N, N, 'N', A, LDA, WORK( N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.6 ) THEN
*
* General, eigenvalues specified
*
IF( KCONDS( JTYPE ).EQ.1 ) THEN
CONDS = ONE
ELSE IF( KCONDS( JTYPE ).EQ.2 ) THEN
CONDS = RTULPI
ELSE
CONDS = ZERO
END IF
*
ADUMMA( 1 ) = ' '
CALL DLATME( N, 'S', ISEED, WORK, IMODE, COND, ONE,
$ ADUMMA, 'T', 'T', 'T', WORK( N+1 ), 4,
$ CONDS, N, N, ANORM, A, LDA, WORK( 2*N+1 ),
$ IINFO )
*
ELSE IF( ITYPE.EQ.7 ) THEN
*
* Diagonal, random eigenvalues
*
CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.8 ) THEN
*
* Symmetric, random eigenvalues
*
CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE IF( ITYPE.EQ.9 ) THEN
*
* General, random eigenvalues
*
CALL DLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
IF( N.GE.4 ) THEN
CALL DLASET( 'Full', 2, N, ZERO, ZERO, A, LDA )
CALL DLASET( 'Full', N-3, 1, ZERO, ZERO, A( 3, 1 ),
$ LDA )
CALL DLASET( 'Full', N-3, 2, ZERO, ZERO, A( 3, N-1 ),
$ LDA )
CALL DLASET( 'Full', 1, N, ZERO, ZERO, A( N, 1 ),
$ LDA )
END IF
*
ELSE IF( ITYPE.EQ.10 ) THEN
*
* Triangular, random eigenvalues
*
CALL DLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
$ 'T', 'N', WORK( N+1 ), 1, ONE,
$ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, 0,
$ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
ELSE
*
IINFO = 1
END IF
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9992 )'Generator', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
90 CONTINUE
*
* Test for minimal and generous workspace
*
DO 130 IWK = 1, 3
IF( IWK.EQ.1 ) THEN
NNWORK = 3*N
ELSE IF( IWK.EQ.2 ) THEN
NNWORK = 6*N + N**2
ELSE
NNWORK = 6*N + 2*N**2
END IF
NNWORK = MAX( NNWORK, 1 )
*
* Test for all balancing options
*
DO 120 IBAL = 1, 4
BALANC = BAL( IBAL )
*
* Perform tests
*
CALL DGET23( .FALSE., BALANC, JTYPE, THRESH, IOLDSD,
$ NOUNIT, N, A, LDA, H, WR, WI, WR1, WI1,
$ VL, LDVL, VR, LDVR, LRE, LDLRE, RCONDV,
$ RCNDV1, RCDVIN, RCONDE, RCNDE1, RCDEIN,
$ SCALE, SCALE1, RESULT, WORK, NNWORK,
$ IWORK, INFO )
*
* Check for RESULT(j) > THRESH
*
NTEST = 0
NFAIL = 0
DO 100 J = 1, 9
IF( RESULT( J ).GE.ZERO )
$ NTEST = NTEST + 1
IF( RESULT( J ).GE.THRESH )
$ NFAIL = NFAIL + 1
100 CONTINUE
*
IF( NFAIL.GT.0 )
$ NTESTF = NTESTF + 1
IF( NTESTF.EQ.1 ) THEN
WRITE( NOUNIT, FMT = 9999 )PATH
WRITE( NOUNIT, FMT = 9998 )
WRITE( NOUNIT, FMT = 9997 )
WRITE( NOUNIT, FMT = 9996 )
WRITE( NOUNIT, FMT = 9995 )THRESH
NTESTF = 2
END IF
*
DO 110 J = 1, 9
IF( RESULT( J ).GE.THRESH ) THEN
WRITE( NOUNIT, FMT = 9994 )BALANC, N, IWK,
$ IOLDSD, JTYPE, J, RESULT( J )
END IF
110 CONTINUE
*
NERRS = NERRS + NFAIL
NTESTT = NTESTT + NTEST
*
120 CONTINUE
130 CONTINUE
140 CONTINUE
150 CONTINUE
*
160 CONTINUE
*
* Read in data from file to check accuracy of condition estimation.
* Assume input eigenvalues are sorted lexicographically (increasing
* by real part, then decreasing by imaginary part)
*
JTYPE = 0
170 CONTINUE
READ( NIUNIT, FMT = *, END = 220 )N
*
* Read input data until N=0
*
IF( N.EQ.0 )
$ GO TO 220
JTYPE = JTYPE + 1
ISEED( 1 ) = JTYPE
DO 180 I = 1, N
READ( NIUNIT, FMT = * )( A( I, J ), J = 1, N )
180 CONTINUE
DO 190 I = 1, N
READ( NIUNIT, FMT = * )WR1( I ), WI1( I ), RCDEIN( I ),
$ RCDVIN( I )
190 CONTINUE
CALL DGET23( .TRUE., 'N', 22, THRESH, ISEED, NOUNIT, N, A, LDA, H,
$ WR, WI, WR1, WI1, VL, LDVL, VR, LDVR, LRE, LDLRE,
$ RCONDV, RCNDV1, RCDVIN, RCONDE, RCNDE1, RCDEIN,
$ SCALE, SCALE1, RESULT, WORK, 6*N+2*N**2, IWORK,
$ INFO )
*
* Check for RESULT(j) > THRESH
*
NTEST = 0
NFAIL = 0
DO 200 J = 1, 11
IF( RESULT( J ).GE.ZERO )
$ NTEST = NTEST + 1
IF( RESULT( J ).GE.THRESH )
$ NFAIL = NFAIL + 1
200 CONTINUE
*
IF( NFAIL.GT.0 )
$ NTESTF = NTESTF + 1
IF( NTESTF.EQ.1 ) THEN
WRITE( NOUNIT, FMT = 9999 )PATH
WRITE( NOUNIT, FMT = 9998 )
WRITE( NOUNIT, FMT = 9997 )
WRITE( NOUNIT, FMT = 9996 )
WRITE( NOUNIT, FMT = 9995 )THRESH
NTESTF = 2
END IF
*
DO 210 J = 1, 11
IF( RESULT( J ).GE.THRESH ) THEN
WRITE( NOUNIT, FMT = 9993 )N, JTYPE, J, RESULT( J )
END IF
210 CONTINUE
*
NERRS = NERRS + NFAIL
NTESTT = NTESTT + NTEST
GO TO 170
220 CONTINUE
*
* Summary
*
CALL DLASUM( PATH, NOUNIT, NERRS, NTESTT )
*
9999 FORMAT( / 1X, A3, ' -- Real Eigenvalue-Eigenvector Decomposition',
$ ' Expert Driver', /
$ ' Matrix types (see DDRVVX for details): ' )
*
9998 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ',
$ ' ', ' 5=Diagonal: geometr. spaced entries.',
$ / ' 2=Identity matrix. ', ' 6=Diagona',
$ 'l: clustered entries.', / ' 3=Transposed Jordan block. ',
$ ' ', ' 7=Diagonal: large, evenly spaced.', / ' ',
$ '4=Diagonal: evenly spaced entries. ', ' 8=Diagonal: s',
$ 'mall, evenly spaced.' )
9997 FORMAT( ' Dense, Non-Symmetric Matrices:', / ' 9=Well-cond., ev',
$ 'enly spaced eigenvals.', ' 14=Ill-cond., geomet. spaced e',
$ 'igenals.', / ' 10=Well-cond., geom. spaced eigenvals. ',
$ ' 15=Ill-conditioned, clustered e.vals.', / ' 11=Well-cond',
$ 'itioned, clustered e.vals. ', ' 16=Ill-cond., random comp',
$ 'lex ', / ' 12=Well-cond., random complex ', ' ',
$ ' 17=Ill-cond., large rand. complx ', / ' 13=Ill-condi',
$ 'tioned, evenly spaced. ', ' 18=Ill-cond., small rand.',
$ ' complx ' )
9996 FORMAT( ' 19=Matrix with random O(1) entries. ', ' 21=Matrix ',
$ 'with small random entries.', / ' 20=Matrix with large ran',
$ 'dom entries. ', ' 22=Matrix read from input file', / )
9995 FORMAT( ' Tests performed with test threshold =', F8.2,
$ / / ' 1 = | A VR - VR W | / ( n |A| ulp ) ',
$ / ' 2 = | transpose(A) VL - VL W | / ( n |A| ulp ) ',
$ / ' 3 = | |VR(i)| - 1 | / ulp ',
$ / ' 4 = | |VL(i)| - 1 | / ulp ',
$ / ' 5 = 0 if W same no matter if VR or VL computed,',
$ ' 1/ulp otherwise', /
$ ' 6 = 0 if VR same no matter what else computed,',
$ ' 1/ulp otherwise', /
$ ' 7 = 0 if VL same no matter what else computed,',
$ ' 1/ulp otherwise', /
$ ' 8 = 0 if RCONDV same no matter what else computed,',
$ ' 1/ulp otherwise', /
$ ' 9 = 0 if SCALE, ILO, IHI, ABNRM same no matter what else',
$ ' computed, 1/ulp otherwise',
$ / ' 10 = | RCONDV - RCONDV(precomputed) | / cond(RCONDV),',
$ / ' 11 = | RCONDE - RCONDE(precomputed) | / cond(RCONDE),' )
9994 FORMAT( ' BALANC=''', A1, ''',N=', I4, ',IWK=', I1, ', seed=',
$ 4( I4, ',' ), ' type ', I2, ', test(', I2, ')=', G10.3 )
9993 FORMAT( ' N=', I5, ', input example =', I3, ', test(', I2, ')=',
$ G10.3 )
9992 FORMAT( ' DDRVVX: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
*
RETURN
*
* End of DDRVVX
*
END
SUBROUTINE DERRBD( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* DERRBD tests the error exits for DGEBRD, DORGBR, DORMBR, DBDSQR and
* DBDSDC.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX, LW
PARAMETER ( NMAX = 4, LW = NMAX )
* ..
* .. Local Scalars ..
CHARACTER*2 C2
INTEGER I, INFO, J, NT
* ..
* .. Local Arrays ..
INTEGER IQ( NMAX, NMAX ), IW( NMAX )
DOUBLE PRECISION A( NMAX, NMAX ), D( NMAX ), E( NMAX ),
$ Q( NMAX, NMAX ), TP( NMAX ), TQ( NMAX ),
$ U( NMAX, NMAX ), V( NMAX, NMAX ), W( LW )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL CHKXER, DBDSDC, DBDSQR, DGEBD2, DGEBRD, DORGBR,
$ DORMBR
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
C2 = PATH( 2: 3 )
*
* Set the variables to innocuous values.
*
DO 20 J = 1, NMAX
DO 10 I = 1, NMAX
A( I, J ) = 1.D0 / DBLE( I+J )
10 CONTINUE
20 CONTINUE
OK = .TRUE.
NT = 0
*
* Test error exits of the SVD routines.
*
IF( LSAMEN( 2, C2, 'BD' ) ) THEN
*
* DGEBRD
*
SRNAMT = 'DGEBRD'
INFOT = 1
CALL DGEBRD( -1, 0, A, 1, D, E, TQ, TP, W, 1, INFO )
CALL CHKXER( 'DGEBRD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGEBRD( 0, -1, A, 1, D, E, TQ, TP, W, 1, INFO )
CALL CHKXER( 'DGEBRD', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGEBRD( 2, 1, A, 1, D, E, TQ, TP, W, 2, INFO )
CALL CHKXER( 'DGEBRD', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DGEBRD( 2, 1, A, 2, D, E, TQ, TP, W, 1, INFO )
CALL CHKXER( 'DGEBRD', INFOT, NOUT, LERR, OK )
NT = NT + 4
*
* DGEBD2
*
SRNAMT = 'DGEBD2'
INFOT = 1
CALL DGEBD2( -1, 0, A, 1, D, E, TQ, TP, W, INFO )
CALL CHKXER( 'DGEBD2', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGEBD2( 0, -1, A, 1, D, E, TQ, TP, W, INFO )
CALL CHKXER( 'DGEBD2', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGEBD2( 2, 1, A, 1, D, E, TQ, TP, W, INFO )
CALL CHKXER( 'DGEBD2', INFOT, NOUT, LERR, OK )
NT = NT + 3
*
* DORGBR
*
SRNAMT = 'DORGBR'
INFOT = 1
CALL DORGBR( '/', 0, 0, 0, A, 1, TQ, W, 1, INFO )
CALL CHKXER( 'DORGBR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORGBR( 'Q', -1, 0, 0, A, 1, TQ, W, 1, INFO )
CALL CHKXER( 'DORGBR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORGBR( 'Q', 0, -1, 0, A, 1, TQ, W, 1, INFO )
CALL CHKXER( 'DORGBR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORGBR( 'Q', 0, 1, 0, A, 1, TQ, W, 1, INFO )
CALL CHKXER( 'DORGBR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORGBR( 'Q', 1, 0, 1, A, 1, TQ, W, 1, INFO )
CALL CHKXER( 'DORGBR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORGBR( 'P', 1, 0, 0, A, 1, TQ, W, 1, INFO )
CALL CHKXER( 'DORGBR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORGBR( 'P', 0, 1, 1, A, 1, TQ, W, 1, INFO )
CALL CHKXER( 'DORGBR', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DORGBR( 'Q', 0, 0, -1, A, 1, TQ, W, 1, INFO )
CALL CHKXER( 'DORGBR', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DORGBR( 'Q', 2, 1, 1, A, 1, TQ, W, 1, INFO )
CALL CHKXER( 'DORGBR', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DORGBR( 'Q', 2, 2, 1, A, 2, TQ, W, 1, INFO )
CALL CHKXER( 'DORGBR', INFOT, NOUT, LERR, OK )
NT = NT + 10
*
* DORMBR
*
SRNAMT = 'DORMBR'
INFOT = 1
CALL DORMBR( '/', 'L', 'T', 0, 0, 0, A, 1, TQ, U, 1, W, 1,
$ INFO )
CALL CHKXER( 'DORMBR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORMBR( 'Q', '/', 'T', 0, 0, 0, A, 1, TQ, U, 1, W, 1,
$ INFO )
CALL CHKXER( 'DORMBR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORMBR( 'Q', 'L', '/', 0, 0, 0, A, 1, TQ, U, 1, W, 1,
$ INFO )
CALL CHKXER( 'DORMBR', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DORMBR( 'Q', 'L', 'T', -1, 0, 0, A, 1, TQ, U, 1, W, 1,
$ INFO )
CALL CHKXER( 'DORMBR', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORMBR( 'Q', 'L', 'T', 0, -1, 0, A, 1, TQ, U, 1, W, 1,
$ INFO )
CALL CHKXER( 'DORMBR', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DORMBR( 'Q', 'L', 'T', 0, 0, -1, A, 1, TQ, U, 1, W, 1,
$ INFO )
CALL CHKXER( 'DORMBR', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DORMBR( 'Q', 'L', 'T', 2, 0, 0, A, 1, TQ, U, 2, W, 1,
$ INFO )
CALL CHKXER( 'DORMBR', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DORMBR( 'Q', 'R', 'T', 0, 2, 0, A, 1, TQ, U, 1, W, 1,
$ INFO )
CALL CHKXER( 'DORMBR', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DORMBR( 'P', 'L', 'T', 2, 0, 2, A, 1, TQ, U, 2, W, 1,
$ INFO )
CALL CHKXER( 'DORMBR', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DORMBR( 'P', 'R', 'T', 0, 2, 2, A, 1, TQ, U, 1, W, 1,
$ INFO )
CALL CHKXER( 'DORMBR', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DORMBR( 'Q', 'R', 'T', 2, 0, 0, A, 1, TQ, U, 1, W, 1,
$ INFO )
CALL CHKXER( 'DORMBR', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL DORMBR( 'Q', 'L', 'T', 0, 2, 0, A, 1, TQ, U, 1, W, 1,
$ INFO )
CALL CHKXER( 'DORMBR', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL DORMBR( 'Q', 'R', 'T', 2, 0, 0, A, 1, TQ, U, 2, W, 1,
$ INFO )
CALL CHKXER( 'DORMBR', INFOT, NOUT, LERR, OK )
NT = NT + 13
*
* DBDSQR
*
SRNAMT = 'DBDSQR'
INFOT = 1
CALL DBDSQR( '/', 0, 0, 0, 0, D, E, V, 1, U, 1, A, 1, W, INFO )
CALL CHKXER( 'DBDSQR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DBDSQR( 'U', -1, 0, 0, 0, D, E, V, 1, U, 1, A, 1, W,
$ INFO )
CALL CHKXER( 'DBDSQR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DBDSQR( 'U', 0, -1, 0, 0, D, E, V, 1, U, 1, A, 1, W,
$ INFO )
CALL CHKXER( 'DBDSQR', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DBDSQR( 'U', 0, 0, -1, 0, D, E, V, 1, U, 1, A, 1, W,
$ INFO )
CALL CHKXER( 'DBDSQR', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DBDSQR( 'U', 0, 0, 0, -1, D, E, V, 1, U, 1, A, 1, W,
$ INFO )
CALL CHKXER( 'DBDSQR', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DBDSQR( 'U', 2, 1, 0, 0, D, E, V, 1, U, 1, A, 1, W, INFO )
CALL CHKXER( 'DBDSQR', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DBDSQR( 'U', 0, 0, 2, 0, D, E, V, 1, U, 1, A, 1, W, INFO )
CALL CHKXER( 'DBDSQR', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL DBDSQR( 'U', 2, 0, 0, 1, D, E, V, 1, U, 1, A, 1, W, INFO )
CALL CHKXER( 'DBDSQR', INFOT, NOUT, LERR, OK )
NT = NT + 8
*
* DBDSDC
*
SRNAMT = 'DBDSDC'
INFOT = 1
CALL DBDSDC( '/', 'N', 0, D, E, U, 1, V, 1, Q, IQ, W, IW,
$ INFO )
CALL CHKXER( 'DBDSDC', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DBDSDC( 'U', '/', 0, D, E, U, 1, V, 1, Q, IQ, W, IW,
$ INFO )
CALL CHKXER( 'DBDSDC', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DBDSDC( 'U', 'N', -1, D, E, U, 1, V, 1, Q, IQ, W, IW,
$ INFO )
CALL CHKXER( 'DBDSDC', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DBDSDC( 'U', 'I', 2, D, E, U, 1, V, 1, Q, IQ, W, IW,
$ INFO )
CALL CHKXER( 'DBDSDC', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DBDSDC( 'U', 'I', 2, D, E, U, 2, V, 1, Q, IQ, W, IW,
$ INFO )
CALL CHKXER( 'DBDSDC', INFOT, NOUT, LERR, OK )
NT = NT + 5
END IF
*
* Print a summary line.
*
IF( OK ) THEN
WRITE( NOUT, FMT = 9999 )PATH, NT
ELSE
WRITE( NOUT, FMT = 9998 )PATH
END IF
*
9999 FORMAT( 1X, A3, ' routines passed the tests of the error exits',
$ ' (', I3, ' tests done)' )
9998 FORMAT( ' *** ', A3, ' routines failed the tests of the error ',
$ 'exits ***' )
*
RETURN
*
* End of DERRBD
*
END
SUBROUTINE DERREC( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* DERREC tests the error exits for the routines for eigen- condition
* estimation for DOUBLE PRECISION matrices:
* DTRSYL, STREXC, STRSNA and STRSEN.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
DOUBLE PRECISION ONE, ZERO
PARAMETER ( NMAX = 4, ONE = 1.0D0, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, IFST, ILST, INFO, J, M, NT
DOUBLE PRECISION SCALE
* ..
* .. Local Arrays ..
LOGICAL SEL( NMAX )
INTEGER IWORK( NMAX )
DOUBLE PRECISION A( NMAX, NMAX ), B( NMAX, NMAX ),
$ C( NMAX, NMAX ), S( NMAX ), SEP( NMAX ),
$ WI( NMAX ), WORK( NMAX ), WR( NMAX )
* ..
* .. External Subroutines ..
EXTERNAL CHKXER, DTREXC, DTRSEN, DTRSNA, DTRSYL
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
OK = .TRUE.
NT = 0
*
* Initialize A, B and SEL
*
DO 20 J = 1, NMAX
DO 10 I = 1, NMAX
A( I, J ) = ZERO
B( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
DO 30 I = 1, NMAX
A( I, I ) = ONE
SEL( I ) = .TRUE.
30 CONTINUE
*
* Test DTRSYL
*
SRNAMT = 'DTRSYL'
INFOT = 1
CALL DTRSYL( 'X', 'N', 1, 0, 0, A, 1, B, 1, C, 1, SCALE, INFO )
CALL CHKXER( 'DTRSYL', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTRSYL( 'N', 'X', 1, 0, 0, A, 1, B, 1, C, 1, SCALE, INFO )
CALL CHKXER( 'DTRSYL', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DTRSYL( 'N', 'N', 0, 0, 0, A, 1, B, 1, C, 1, SCALE, INFO )
CALL CHKXER( 'DTRSYL', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DTRSYL( 'N', 'N', 1, -1, 0, A, 1, B, 1, C, 1, SCALE, INFO )
CALL CHKXER( 'DTRSYL', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTRSYL( 'N', 'N', 1, 0, -1, A, 1, B, 1, C, 1, SCALE, INFO )
CALL CHKXER( 'DTRSYL', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DTRSYL( 'N', 'N', 1, 2, 0, A, 1, B, 1, C, 2, SCALE, INFO )
CALL CHKXER( 'DTRSYL', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DTRSYL( 'N', 'N', 1, 0, 2, A, 1, B, 1, C, 1, SCALE, INFO )
CALL CHKXER( 'DTRSYL', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DTRSYL( 'N', 'N', 1, 2, 0, A, 2, B, 1, C, 1, SCALE, INFO )
CALL CHKXER( 'DTRSYL', INFOT, NOUT, LERR, OK )
NT = NT + 8
*
* Test DTREXC
*
SRNAMT = 'DTREXC'
IFST = 1
ILST = 1
INFOT = 1
CALL DTREXC( 'X', 1, A, 1, B, 1, IFST, ILST, WORK, INFO )
CALL CHKXER( 'DTREXC', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DTREXC( 'N', 0, A, 1, B, 1, IFST, ILST, WORK, INFO )
CALL CHKXER( 'DTREXC', INFOT, NOUT, LERR, OK )
INFOT = 4
ILST = 2
CALL DTREXC( 'N', 2, A, 1, B, 1, IFST, ILST, WORK, INFO )
CALL CHKXER( 'DTREXC', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DTREXC( 'V', 2, A, 2, B, 1, IFST, ILST, WORK, INFO )
CALL CHKXER( 'DTREXC', INFOT, NOUT, LERR, OK )
INFOT = 7
IFST = 0
ILST = 1
CALL DTREXC( 'V', 1, A, 1, B, 1, IFST, ILST, WORK, INFO )
CALL CHKXER( 'DTREXC', INFOT, NOUT, LERR, OK )
INFOT = 7
IFST = 2
CALL DTREXC( 'V', 1, A, 1, B, 1, IFST, ILST, WORK, INFO )
CALL CHKXER( 'DTREXC', INFOT, NOUT, LERR, OK )
INFOT = 8
IFST = 1
ILST = 0
CALL DTREXC( 'V', 1, A, 1, B, 1, IFST, ILST, WORK, INFO )
CALL CHKXER( 'DTREXC', INFOT, NOUT, LERR, OK )
INFOT = 8
ILST = 2
CALL DTREXC( 'V', 1, A, 1, B, 1, IFST, ILST, WORK, INFO )
CALL CHKXER( 'DTREXC', INFOT, NOUT, LERR, OK )
NT = NT + 8
*
* Test DTRSNA
*
SRNAMT = 'DTRSNA'
INFOT = 1
CALL DTRSNA( 'X', 'A', SEL, 0, A, 1, B, 1, C, 1, S, SEP, 1, M,
$ WORK, 1, IWORK, INFO )
CALL CHKXER( 'DTRSNA', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTRSNA( 'B', 'X', SEL, 0, A, 1, B, 1, C, 1, S, SEP, 1, M,
$ WORK, 1, IWORK, INFO )
CALL CHKXER( 'DTRSNA', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DTRSNA( 'B', 'A', SEL, -1, A, 1, B, 1, C, 1, S, SEP, 1, M,
$ WORK, 1, IWORK, INFO )
CALL CHKXER( 'DTRSNA', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DTRSNA( 'V', 'A', SEL, 2, A, 1, B, 1, C, 1, S, SEP, 2, M,
$ WORK, 2, IWORK, INFO )
CALL CHKXER( 'DTRSNA', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DTRSNA( 'B', 'A', SEL, 2, A, 2, B, 1, C, 2, S, SEP, 2, M,
$ WORK, 2, IWORK, INFO )
CALL CHKXER( 'DTRSNA', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DTRSNA( 'B', 'A', SEL, 2, A, 2, B, 2, C, 1, S, SEP, 2, M,
$ WORK, 2, IWORK, INFO )
CALL CHKXER( 'DTRSNA', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL DTRSNA( 'B', 'A', SEL, 1, A, 1, B, 1, C, 1, S, SEP, 0, M,
$ WORK, 1, IWORK, INFO )
CALL CHKXER( 'DTRSNA', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL DTRSNA( 'B', 'S', SEL, 2, A, 2, B, 2, C, 2, S, SEP, 1, M,
$ WORK, 2, IWORK, INFO )
CALL CHKXER( 'DTRSNA', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL DTRSNA( 'B', 'A', SEL, 2, A, 2, B, 2, C, 2, S, SEP, 2, M,
$ WORK, 1, IWORK, INFO )
CALL CHKXER( 'DTRSNA', INFOT, NOUT, LERR, OK )
NT = NT + 9
*
* Test DTRSEN
*
SEL( 1 ) = .FALSE.
SRNAMT = 'DTRSEN'
INFOT = 1
CALL DTRSEN( 'X', 'N', SEL, 0, A, 1, B, 1, WR, WI, M, S( 1 ),
$ SEP( 1 ), WORK, 1, IWORK, 1, INFO )
CALL CHKXER( 'DTRSEN', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTRSEN( 'N', 'X', SEL, 0, A, 1, B, 1, WR, WI, M, S( 1 ),
$ SEP( 1 ), WORK, 1, IWORK, 1, INFO )
CALL CHKXER( 'DTRSEN', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DTRSEN( 'N', 'N', SEL, -1, A, 1, B, 1, WR, WI, M, S( 1 ),
$ SEP( 1 ), WORK, 1, IWORK, 1, INFO )
CALL CHKXER( 'DTRSEN', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DTRSEN( 'N', 'N', SEL, 2, A, 1, B, 1, WR, WI, M, S( 1 ),
$ SEP( 1 ), WORK, 2, IWORK, 1, INFO )
CALL CHKXER( 'DTRSEN', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DTRSEN( 'N', 'V', SEL, 2, A, 2, B, 1, WR, WI, M, S( 1 ),
$ SEP( 1 ), WORK, 1, IWORK, 1, INFO )
CALL CHKXER( 'DTRSEN', INFOT, NOUT, LERR, OK )
INFOT = 15
CALL DTRSEN( 'N', 'V', SEL, 2, A, 2, B, 2, WR, WI, M, S( 1 ),
$ SEP( 1 ), WORK, 0, IWORK, 1, INFO )
CALL CHKXER( 'DTRSEN', INFOT, NOUT, LERR, OK )
INFOT = 15
CALL DTRSEN( 'E', 'V', SEL, 3, A, 3, B, 3, WR, WI, M, S( 1 ),
$ SEP( 1 ), WORK, 1, IWORK, 1, INFO )
CALL CHKXER( 'DTRSEN', INFOT, NOUT, LERR, OK )
INFOT = 15
CALL DTRSEN( 'V', 'V', SEL, 3, A, 3, B, 3, WR, WI, M, S( 1 ),
$ SEP( 1 ), WORK, 3, IWORK, 2, INFO )
CALL CHKXER( 'DTRSEN', INFOT, NOUT, LERR, OK )
INFOT = 17
CALL DTRSEN( 'E', 'V', SEL, 2, A, 2, B, 2, WR, WI, M, S( 1 ),
$ SEP( 1 ), WORK, 1, IWORK, 0, INFO )
CALL CHKXER( 'DTRSEN', INFOT, NOUT, LERR, OK )
INFOT = 17
CALL DTRSEN( 'V', 'V', SEL, 3, A, 3, B, 3, WR, WI, M, S( 1 ),
$ SEP( 1 ), WORK, 4, IWORK, 1, INFO )
CALL CHKXER( 'DTRSEN', INFOT, NOUT, LERR, OK )
NT = NT + 10
*
* Print a summary line.
*
IF( OK ) THEN
WRITE( NOUT, FMT = 9999 )PATH, NT
ELSE
WRITE( NOUT, FMT = 9998 )PATH
END IF
*
RETURN
9999 FORMAT( 1X, A3, ' routines passed the tests of the error exits (',
$ I3, ' tests done)' )
9998 FORMAT( ' *** ', A3, ' routines failed the tests of the error ex',
$ 'its ***' )
*
* End of DERREC
*
END
SUBROUTINE DERRED( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* DERRED tests the error exits for the eigenvalue driver routines for
* DOUBLE PRECISION matrices:
*
* PATH driver description
* ---- ------ -----------
* SEV DGEEV find eigenvalues/eigenvectors for nonsymmetric A
* SES DGEES find eigenvalues/Schur form for nonsymmetric A
* SVX DGEEVX SGEEV + balancing and condition estimation
* SSX DGEESX SGEES + balancing and condition estimation
* DBD DGESVD compute SVD of an M-by-N matrix A
* DGESDD compute SVD of an M-by-N matrix A (by divide and
* conquer)
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
DOUBLE PRECISION ONE, ZERO
PARAMETER ( NMAX = 4, ONE = 1.0D0, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
CHARACTER*2 C2
INTEGER I, IHI, ILO, INFO, J, NT, SDIM
DOUBLE PRECISION ABNRM
* ..
* .. Local Arrays ..
LOGICAL B( NMAX )
INTEGER IW( 2*NMAX )
DOUBLE PRECISION A( NMAX, NMAX ), R1( NMAX ), R2( NMAX ),
$ S( NMAX ), U( NMAX, NMAX ), VL( NMAX, NMAX ),
$ VR( NMAX, NMAX ), VT( NMAX, NMAX ),
$ W( 4*NMAX ), WI( NMAX ), WR( NMAX )
* ..
* .. External Subroutines ..
EXTERNAL CHKXER, DGEES, DGEESX, DGEEV, DGEEVX, DGESDD,
$ DGESVD
* ..
* .. External Functions ..
LOGICAL DSLECT, LSAMEN
EXTERNAL DSLECT, LSAMEN
* ..
* .. Arrays in Common ..
LOGICAL SELVAL( 20 )
DOUBLE PRECISION SELWI( 20 ), SELWR( 20 )
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT, SELDIM, SELOPT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
COMMON / SSLCT / SELOPT, SELDIM, SELVAL, SELWR, SELWI
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
C2 = PATH( 2: 3 )
*
* Initialize A
*
DO 20 J = 1, NMAX
DO 10 I = 1, NMAX
A( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
DO 30 I = 1, NMAX
A( I, I ) = ONE
30 CONTINUE
OK = .TRUE.
NT = 0
*
IF( LSAMEN( 2, C2, 'EV' ) ) THEN
*
* Test DGEEV
*
SRNAMT = 'DGEEV '
INFOT = 1
CALL DGEEV( 'X', 'N', 0, A, 1, WR, WI, VL, 1, VR, 1, W, 1,
$ INFO )
CALL CHKXER( 'DGEEV ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGEEV( 'N', 'X', 0, A, 1, WR, WI, VL, 1, VR, 1, W, 1,
$ INFO )
CALL CHKXER( 'DGEEV ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGEEV( 'N', 'N', -1, A, 1, WR, WI, VL, 1, VR, 1, W, 1,
$ INFO )
CALL CHKXER( 'DGEEV ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGEEV( 'N', 'N', 2, A, 1, WR, WI, VL, 1, VR, 1, W, 6,
$ INFO )
CALL CHKXER( 'DGEEV ', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DGEEV( 'V', 'N', 2, A, 2, WR, WI, VL, 1, VR, 1, W, 8,
$ INFO )
CALL CHKXER( 'DGEEV ', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DGEEV( 'N', 'V', 2, A, 2, WR, WI, VL, 1, VR, 1, W, 8,
$ INFO )
CALL CHKXER( 'DGEEV ', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL DGEEV( 'V', 'V', 1, A, 1, WR, WI, VL, 1, VR, 1, W, 3,
$ INFO )
CALL CHKXER( 'DGEEV ', INFOT, NOUT, LERR, OK )
NT = NT + 7
*
ELSE IF( LSAMEN( 2, C2, 'ES' ) ) THEN
*
* Test DGEES
*
SRNAMT = 'DGEES '
INFOT = 1
CALL DGEES( 'X', 'N', DSLECT, 0, A, 1, SDIM, WR, WI, VL, 1, W,
$ 1, B, INFO )
CALL CHKXER( 'DGEES ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGEES( 'N', 'X', DSLECT, 0, A, 1, SDIM, WR, WI, VL, 1, W,
$ 1, B, INFO )
CALL CHKXER( 'DGEES ', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGEES( 'N', 'S', DSLECT, -1, A, 1, SDIM, WR, WI, VL, 1, W,
$ 1, B, INFO )
CALL CHKXER( 'DGEES ', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DGEES( 'N', 'S', DSLECT, 2, A, 1, SDIM, WR, WI, VL, 1, W,
$ 6, B, INFO )
CALL CHKXER( 'DGEES ', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DGEES( 'V', 'S', DSLECT, 2, A, 2, SDIM, WR, WI, VL, 1, W,
$ 6, B, INFO )
CALL CHKXER( 'DGEES ', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL DGEES( 'N', 'S', DSLECT, 1, A, 1, SDIM, WR, WI, VL, 1, W,
$ 2, B, INFO )
CALL CHKXER( 'DGEES ', INFOT, NOUT, LERR, OK )
NT = NT + 6
*
ELSE IF( LSAMEN( 2, C2, 'VX' ) ) THEN
*
* Test DGEEVX
*
SRNAMT = 'DGEEVX'
INFOT = 1
CALL DGEEVX( 'X', 'N', 'N', 'N', 0, A, 1, WR, WI, VL, 1, VR, 1,
$ ILO, IHI, S, ABNRM, R1, R2, W, 1, IW, INFO )
CALL CHKXER( 'DGEEVX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGEEVX( 'N', 'X', 'N', 'N', 0, A, 1, WR, WI, VL, 1, VR, 1,
$ ILO, IHI, S, ABNRM, R1, R2, W, 1, IW, INFO )
CALL CHKXER( 'DGEEVX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGEEVX( 'N', 'N', 'X', 'N', 0, A, 1, WR, WI, VL, 1, VR, 1,
$ ILO, IHI, S, ABNRM, R1, R2, W, 1, IW, INFO )
CALL CHKXER( 'DGEEVX', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGEEVX( 'N', 'N', 'N', 'X', 0, A, 1, WR, WI, VL, 1, VR, 1,
$ ILO, IHI, S, ABNRM, R1, R2, W, 1, IW, INFO )
CALL CHKXER( 'DGEEVX', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGEEVX( 'N', 'N', 'N', 'N', -1, A, 1, WR, WI, VL, 1, VR,
$ 1, ILO, IHI, S, ABNRM, R1, R2, W, 1, IW, INFO )
CALL CHKXER( 'DGEEVX', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DGEEVX( 'N', 'N', 'N', 'N', 2, A, 1, WR, WI, VL, 1, VR, 1,
$ ILO, IHI, S, ABNRM, R1, R2, W, 1, IW, INFO )
CALL CHKXER( 'DGEEVX', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DGEEVX( 'N', 'V', 'N', 'N', 2, A, 2, WR, WI, VL, 1, VR, 1,
$ ILO, IHI, S, ABNRM, R1, R2, W, 6, IW, INFO )
CALL CHKXER( 'DGEEVX', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL DGEEVX( 'N', 'N', 'V', 'N', 2, A, 2, WR, WI, VL, 1, VR, 1,
$ ILO, IHI, S, ABNRM, R1, R2, W, 6, IW, INFO )
CALL CHKXER( 'DGEEVX', INFOT, NOUT, LERR, OK )
INFOT = 21
CALL DGEEVX( 'N', 'N', 'N', 'N', 1, A, 1, WR, WI, VL, 1, VR, 1,
$ ILO, IHI, S, ABNRM, R1, R2, W, 1, IW, INFO )
CALL CHKXER( 'DGEEVX', INFOT, NOUT, LERR, OK )
INFOT = 21
CALL DGEEVX( 'N', 'V', 'N', 'N', 1, A, 1, WR, WI, VL, 1, VR, 1,
$ ILO, IHI, S, ABNRM, R1, R2, W, 2, IW, INFO )
CALL CHKXER( 'DGEEVX', INFOT, NOUT, LERR, OK )
INFOT = 21
CALL DGEEVX( 'N', 'N', 'V', 'V', 1, A, 1, WR, WI, VL, 1, VR, 1,
$ ILO, IHI, S, ABNRM, R1, R2, W, 3, IW, INFO )
CALL CHKXER( 'DGEEVX', INFOT, NOUT, LERR, OK )
NT = NT + 11
*
ELSE IF( LSAMEN( 2, C2, 'SX' ) ) THEN
*
* Test DGEESX
*
SRNAMT = 'DGEESX'
INFOT = 1
CALL DGEESX( 'X', 'N', DSLECT, 'N', 0, A, 1, SDIM, WR, WI, VL,
$ 1, R1( 1 ), R2( 1 ), W, 1, IW, 1, B, INFO )
CALL CHKXER( 'DGEESX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGEESX( 'N', 'X', DSLECT, 'N', 0, A, 1, SDIM, WR, WI, VL,
$ 1, R1( 1 ), R2( 1 ), W, 1, IW, 1, B, INFO )
CALL CHKXER( 'DGEESX', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGEESX( 'N', 'N', DSLECT, 'X', 0, A, 1, SDIM, WR, WI, VL,
$ 1, R1( 1 ), R2( 1 ), W, 1, IW, 1, B, INFO )
CALL CHKXER( 'DGEESX', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGEESX( 'N', 'N', DSLECT, 'N', -1, A, 1, SDIM, WR, WI, VL,
$ 1, R1( 1 ), R2( 1 ), W, 1, IW, 1, B, INFO )
CALL CHKXER( 'DGEESX', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DGEESX( 'N', 'N', DSLECT, 'N', 2, A, 1, SDIM, WR, WI, VL,
$ 1, R1( 1 ), R2( 1 ), W, 6, IW, 1, B, INFO )
CALL CHKXER( 'DGEESX', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DGEESX( 'V', 'N', DSLECT, 'N', 2, A, 2, SDIM, WR, WI, VL,
$ 1, R1( 1 ), R2( 1 ), W, 6, IW, 1, B, INFO )
CALL CHKXER( 'DGEESX', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL DGEESX( 'N', 'N', DSLECT, 'N', 1, A, 1, SDIM, WR, WI, VL,
$ 1, R1( 1 ), R2( 1 ), W, 2, IW, 1, B, INFO )
CALL CHKXER( 'DGEESX', INFOT, NOUT, LERR, OK )
NT = NT + 7
*
ELSE IF( LSAMEN( 2, C2, 'BD' ) ) THEN
*
* Test DGESVD
*
SRNAMT = 'DGESVD'
INFOT = 1
CALL DGESVD( 'X', 'N', 0, 0, A, 1, S, U, 1, VT, 1, W, 1, INFO )
CALL CHKXER( 'DGESVD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGESVD( 'N', 'X', 0, 0, A, 1, S, U, 1, VT, 1, W, 1, INFO )
CALL CHKXER( 'DGESVD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGESVD( 'O', 'O', 0, 0, A, 1, S, U, 1, VT, 1, W, 1, INFO )
CALL CHKXER( 'DGESVD', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGESVD( 'N', 'N', -1, 0, A, 1, S, U, 1, VT, 1, W, 1,
$ INFO )
CALL CHKXER( 'DGESVD', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGESVD( 'N', 'N', 0, -1, A, 1, S, U, 1, VT, 1, W, 1,
$ INFO )
CALL CHKXER( 'DGESVD', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DGESVD( 'N', 'N', 2, 1, A, 1, S, U, 1, VT, 1, W, 5, INFO )
CALL CHKXER( 'DGESVD', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DGESVD( 'A', 'N', 2, 1, A, 2, S, U, 1, VT, 1, W, 5, INFO )
CALL CHKXER( 'DGESVD', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DGESVD( 'N', 'A', 1, 2, A, 1, S, U, 1, VT, 1, W, 5, INFO )
CALL CHKXER( 'DGESVD', INFOT, NOUT, LERR, OK )
NT = NT + 8
IF( OK ) THEN
WRITE( NOUT, FMT = 9999 )SRNAMT, NT
ELSE
WRITE( NOUT, FMT = 9998 )
END IF
*
* Test DGESDD
*
SRNAMT = 'DGESDD'
INFOT = 1
CALL DGESDD( 'X', 0, 0, A, 1, S, U, 1, VT, 1, W, 1, IW, INFO )
CALL CHKXER( 'DGESDD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGESDD( 'N', -1, 0, A, 1, S, U, 1, VT, 1, W, 1, IW, INFO )
CALL CHKXER( 'DGESDD', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGESDD( 'N', 0, -1, A, 1, S, U, 1, VT, 1, W, 1, IW, INFO )
CALL CHKXER( 'DGESDD', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGESDD( 'N', 2, 1, A, 1, S, U, 1, VT, 1, W, 5, IW, INFO )
CALL CHKXER( 'DGESDD', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DGESDD( 'A', 2, 1, A, 2, S, U, 1, VT, 1, W, 5, IW, INFO )
CALL CHKXER( 'DGESDD', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DGESDD( 'A', 1, 2, A, 1, S, U, 1, VT, 1, W, 5, IW, INFO )
CALL CHKXER( 'DGESDD', INFOT, NOUT, LERR, OK )
NT = NT - 2
IF( OK ) THEN
WRITE( NOUT, FMT = 9999 )SRNAMT, NT
ELSE
WRITE( NOUT, FMT = 9998 )
END IF
END IF
*
* Print a summary line.
*
IF( .NOT.LSAMEN( 2, C2, 'BD' ) ) THEN
IF( OK ) THEN
WRITE( NOUT, FMT = 9999 )SRNAMT, NT
ELSE
WRITE( NOUT, FMT = 9998 )
END IF
END IF
*
9999 FORMAT( 1X, A6, ' passed the tests of the error exits (', I3,
$ ' tests done)' )
9998 FORMAT( ' *** ', A6, ' failed the tests of the error exits ***' )
RETURN
*
* End of DERRED
END
SUBROUTINE DERRGG( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* DERRGG tests the error exits for DGGES, DGGESX, DGGEV, DGGEVX,
* DGGGLM, DGGHRD, DGGLSE, DGGQRF, DGGRQF, DGGSVD, DGGSVP, DHGEQZ,
* DTGEVC, DTGEXC, DTGSEN, DTGSJA, DTGSNA, and DTGSYL.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX, LW
PARAMETER ( NMAX = 3, LW = 6*NMAX )
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
CHARACTER*2 C2
INTEGER DUMMYK, DUMMYL, I, IFST, ILST, INFO, J, M,
$ NCYCLE, NT, SDIM
DOUBLE PRECISION ANRM, BNRM, DIF, SCALE, TOLA, TOLB
* ..
* .. Local Arrays ..
LOGICAL BW( NMAX ), SEL( NMAX )
INTEGER IW( NMAX )
DOUBLE PRECISION A( NMAX, NMAX ), B( NMAX, NMAX ), LS( NMAX ),
$ Q( NMAX, NMAX ), R1( NMAX ), R2( NMAX ),
$ R3( NMAX ), RCE( 2 ), RCV( 2 ), RS( NMAX ),
$ TAU( NMAX ), U( NMAX, NMAX ), V( NMAX, NMAX ),
$ W( LW ), Z( NMAX, NMAX )
* ..
* .. External Functions ..
LOGICAL DLCTES, DLCTSX, LSAMEN
EXTERNAL DLCTES, DLCTSX, LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL CHKXER, DGGES, DGGESX, DGGEV, DGGEVX, DGGGLM,
$ DGGHRD, DGGLSE, DGGQRF, DGGRQF, DGGSVD, DGGSVP,
$ DHGEQZ, DTGEVC, DTGEXC, DTGSEN, DTGSJA, DTGSNA,
$ DTGSYL
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
C2 = PATH( 2: 3 )
*
* Set the variables to innocuous values.
*
DO 20 J = 1, NMAX
SEL( J ) = .TRUE.
DO 10 I = 1, NMAX
A( I, J ) = ZERO
B( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
DO 30 I = 1, NMAX
A( I, I ) = ONE
B( I, I ) = ONE
30 CONTINUE
OK = .TRUE.
TOLA = 1.0D0
TOLB = 1.0D0
IFST = 1
ILST = 1
NT = 0
*
* Test error exits for the GG path.
*
IF( LSAMEN( 2, C2, 'GG' ) ) THEN
*
* DGGHRD
*
SRNAMT = 'DGGHRD'
INFOT = 1
CALL DGGHRD( '/', 'N', 0, 1, 0, A, 1, B, 1, Q, 1, Z, 1, INFO )
CALL CHKXER( 'DGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGGHRD( 'N', '/', 0, 1, 0, A, 1, B, 1, Q, 1, Z, 1, INFO )
CALL CHKXER( 'DGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGGHRD( 'N', 'N', -1, 0, 0, A, 1, B, 1, Q, 1, Z, 1, INFO )
CALL CHKXER( 'DGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGGHRD( 'N', 'N', 0, 0, 0, A, 1, B, 1, Q, 1, Z, 1, INFO )
CALL CHKXER( 'DGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGGHRD( 'N', 'N', 0, 1, 1, A, 1, B, 1, Q, 1, Z, 1, INFO )
CALL CHKXER( 'DGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DGGHRD( 'N', 'N', 2, 1, 1, A, 1, B, 2, Q, 1, Z, 1, INFO )
CALL CHKXER( 'DGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DGGHRD( 'N', 'N', 2, 1, 1, A, 2, B, 1, Q, 1, Z, 1, INFO )
CALL CHKXER( 'DGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DGGHRD( 'V', 'N', 2, 1, 1, A, 2, B, 2, Q, 1, Z, 1, INFO )
CALL CHKXER( 'DGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL DGGHRD( 'N', 'V', 2, 1, 1, A, 2, B, 2, Q, 1, Z, 1, INFO )
CALL CHKXER( 'DGGHRD', INFOT, NOUT, LERR, OK )
NT = NT + 9
*
* DHGEQZ
*
SRNAMT = 'DHGEQZ'
INFOT = 1
CALL DHGEQZ( '/', 'N', 'N', 0, 1, 0, A, 1, B, 1, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'DHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DHGEQZ( 'E', '/', 'N', 0, 1, 0, A, 1, B, 1, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'DHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DHGEQZ( 'E', 'N', '/', 0, 1, 0, A, 1, B, 1, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'DHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DHGEQZ( 'E', 'N', 'N', -1, 0, 0, A, 1, B, 1, R1, R2, R3,
$ Q, 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'DHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DHGEQZ( 'E', 'N', 'N', 0, 0, 0, A, 1, B, 1, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'DHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DHGEQZ( 'E', 'N', 'N', 0, 1, 1, A, 1, B, 1, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'DHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DHGEQZ( 'E', 'N', 'N', 2, 1, 1, A, 1, B, 2, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'DHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DHGEQZ( 'E', 'N', 'N', 2, 1, 1, A, 2, B, 1, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'DHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 15
CALL DHGEQZ( 'E', 'V', 'N', 2, 1, 1, A, 2, B, 2, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'DHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 17
CALL DHGEQZ( 'E', 'N', 'V', 2, 1, 1, A, 2, B, 2, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'DHGEQZ', INFOT, NOUT, LERR, OK )
NT = NT + 10
*
* DTGEVC
*
SRNAMT = 'DTGEVC'
INFOT = 1
CALL DTGEVC( '/', 'A', SEL, 0, A, 1, B, 1, Q, 1, Z, 1, 0, M, W,
$ INFO )
CALL CHKXER( 'DTGEVC', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTGEVC( 'R', '/', SEL, 0, A, 1, B, 1, Q, 1, Z, 1, 0, M, W,
$ INFO )
CALL CHKXER( 'DTGEVC', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DTGEVC( 'R', 'A', SEL, -1, A, 1, B, 1, Q, 1, Z, 1, 0, M,
$ W, INFO )
CALL CHKXER( 'DTGEVC', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DTGEVC( 'R', 'A', SEL, 2, A, 1, B, 2, Q, 1, Z, 2, 0, M, W,
$ INFO )
CALL CHKXER( 'DTGEVC', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DTGEVC( 'R', 'A', SEL, 2, A, 2, B, 1, Q, 1, Z, 2, 0, M, W,
$ INFO )
CALL CHKXER( 'DTGEVC', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DTGEVC( 'L', 'A', SEL, 2, A, 2, B, 2, Q, 1, Z, 1, 0, M, W,
$ INFO )
CALL CHKXER( 'DTGEVC', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DTGEVC( 'R', 'A', SEL, 2, A, 2, B, 2, Q, 1, Z, 1, 0, M, W,
$ INFO )
CALL CHKXER( 'DTGEVC', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL DTGEVC( 'R', 'A', SEL, 2, A, 2, B, 2, Q, 1, Z, 2, 1, M, W,
$ INFO )
CALL CHKXER( 'DTGEVC', INFOT, NOUT, LERR, OK )
NT = NT + 8
*
* Test error exits for the GSV path.
*
ELSE IF( LSAMEN( 3, PATH, 'GSV' ) ) THEN
*
* DGGSVD
*
SRNAMT = 'DGGSVD'
INFOT = 1
CALL DGGSVD( '/', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGGSVD( 'N', '/', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGGSVD( 'N', 'N', '/', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGGSVD( 'N', 'N', 'N', -1, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGGSVD( 'N', 'N', 'N', 0, -1, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DGGSVD( 'N', 'N', 'N', 0, 0, -1, DUMMYK, DUMMYL, A, 1, B,
$ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DGGSVD( 'N', 'N', 'N', 2, 1, 1, DUMMYK, DUMMYL, A, 1, B,
$ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DGGSVD( 'N', 'N', 'N', 1, 1, 2, DUMMYK, DUMMYL, A, 1, B,
$ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL DGGSVD( 'U', 'N', 'N', 2, 2, 2, DUMMYK, DUMMYL, A, 2, B,
$ 2, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 18
CALL DGGSVD( 'N', 'V', 'N', 1, 1, 2, DUMMYK, DUMMYL, A, 1, B,
$ 2, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 20
CALL DGGSVD( 'N', 'N', 'Q', 1, 2, 1, DUMMYK, DUMMYL, A, 1, B,
$ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
NT = NT + 11
*
* DGGSVP
*
SRNAMT = 'DGGSVP'
INFOT = 1
CALL DGGSVP( '/', 'N', 'N', 0, 0, 0, A, 1, B, 1, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGGSVP( 'N', '/', 'N', 0, 0, 0, A, 1, B, 1, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGGSVP( 'N', 'N', '/', 0, 0, 0, A, 1, B, 1, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGGSVP( 'N', 'N', 'N', -1, 0, 0, A, 1, B, 1, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGGSVP( 'N', 'N', 'N', 0, -1, 0, A, 1, B, 1, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DGGSVP( 'N', 'N', 'N', 0, 0, -1, A, 1, B, 1, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DGGSVP( 'N', 'N', 'N', 2, 1, 1, A, 1, B, 1, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DGGSVP( 'N', 'N', 'N', 1, 2, 1, A, 1, B, 1, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL DGGSVP( 'U', 'N', 'N', 2, 2, 2, A, 2, B, 2, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 18
CALL DGGSVP( 'N', 'V', 'N', 1, 2, 1, A, 1, B, 2, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 20
CALL DGGSVP( 'N', 'N', 'Q', 1, 1, 2, A, 1, B, 1, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
NT = NT + 11
*
* DTGSJA
*
SRNAMT = 'DTGSJA'
INFOT = 1
CALL DTGSJA( '/', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, TOLA, TOLB, R1, R2, U, 1, V, 1, Q, 1, W,
$ NCYCLE, INFO )
CALL CHKXER( 'DTGSJA', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTGSJA( 'N', '/', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, TOLA, TOLB, R1, R2, U, 1, V, 1, Q, 1, W,
$ NCYCLE, INFO )
CALL CHKXER( 'DTGSJA', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DTGSJA( 'N', 'N', '/', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, TOLA, TOLB, R1, R2, U, 1, V, 1, Q, 1, W,
$ NCYCLE, INFO )
CALL CHKXER( 'DTGSJA', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DTGSJA( 'N', 'N', 'N', -1, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, TOLA, TOLB, R1, R2, U, 1, V, 1, Q, 1, W,
$ NCYCLE, INFO )
CALL CHKXER( 'DTGSJA', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTGSJA( 'N', 'N', 'N', 0, -1, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, TOLA, TOLB, R1, R2, U, 1, V, 1, Q, 1, W,
$ NCYCLE, INFO )
CALL CHKXER( 'DTGSJA', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DTGSJA( 'N', 'N', 'N', 0, 0, -1, DUMMYK, DUMMYL, A, 1, B,
$ 1, TOLA, TOLB, R1, R2, U, 1, V, 1, Q, 1, W,
$ NCYCLE, INFO )
CALL CHKXER( 'DTGSJA', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DTGSJA( 'N', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 0, B,
$ 1, TOLA, TOLB, R1, R2, U, 1, V, 1, Q, 1, W,
$ NCYCLE, INFO )
CALL CHKXER( 'DTGSJA', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DTGSJA( 'N', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 0, TOLA, TOLB, R1, R2, U, 1, V, 1, Q, 1, W,
$ NCYCLE, INFO )
CALL CHKXER( 'DTGSJA', INFOT, NOUT, LERR, OK )
INFOT = 18
CALL DTGSJA( 'U', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, TOLA, TOLB, R1, R2, U, 0, V, 1, Q, 1, W,
$ NCYCLE, INFO )
CALL CHKXER( 'DTGSJA', INFOT, NOUT, LERR, OK )
INFOT = 20
CALL DTGSJA( 'N', 'V', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, TOLA, TOLB, R1, R2, U, 1, V, 0, Q, 1, W,
$ NCYCLE, INFO )
CALL CHKXER( 'DTGSJA', INFOT, NOUT, LERR, OK )
INFOT = 22
CALL DTGSJA( 'N', 'N', 'Q', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, TOLA, TOLB, R1, R2, U, 1, V, 1, Q, 0, W,
$ NCYCLE, INFO )
CALL CHKXER( 'DTGSJA', INFOT, NOUT, LERR, OK )
NT = NT + 11
*
* Test error exits for the GLM path.
*
ELSE IF( LSAMEN( 3, PATH, 'GLM' ) ) THEN
*
* DGGGLM
*
SRNAMT = 'DGGGLM'
INFOT = 1
CALL DGGGLM( -1, 0, 0, A, 1, B, 1, R1, R2, R3, W, LW, INFO )
CALL CHKXER( 'DGGGLM', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGGGLM( 0, -1, 0, A, 1, B, 1, R1, R2, R3, W, LW, INFO )
CALL CHKXER( 'DGGGLM', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGGGLM( 0, 1, 0, A, 1, B, 1, R1, R2, R3, W, LW, INFO )
CALL CHKXER( 'DGGGLM', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGGGLM( 0, 0, -1, A, 1, B, 1, R1, R2, R3, W, LW, INFO )
CALL CHKXER( 'DGGGLM', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGGGLM( 1, 0, 0, A, 1, B, 1, R1, R2, R3, W, LW, INFO )
CALL CHKXER( 'DGGGLM', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGGGLM( 0, 0, 0, A, 0, B, 1, R1, R2, R3, W, LW, INFO )
CALL CHKXER( 'DGGGLM', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DGGGLM( 0, 0, 0, A, 1, B, 0, R1, R2, R3, W, LW, INFO )
CALL CHKXER( 'DGGGLM', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DGGGLM( 1, 1, 1, A, 1, B, 1, R1, R2, R3, W, 1, INFO )
CALL CHKXER( 'DGGGLM', INFOT, NOUT, LERR, OK )
NT = NT + 8
*
* Test error exits for the LSE path.
*
ELSE IF( LSAMEN( 3, PATH, 'LSE' ) ) THEN
*
* DGGLSE
*
SRNAMT = 'DGGLSE'
INFOT = 1
CALL DGGLSE( -1, 0, 0, A, 1, B, 1, R1, R2, R3, W, LW, INFO )
CALL CHKXER( 'DGGLSE', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGGLSE( 0, -1, 0, A, 1, B, 1, R1, R2, R3, W, LW, INFO )
CALL CHKXER( 'DGGLSE', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGGLSE( 0, 0, -1, A, 1, B, 1, R1, R2, R3, W, LW, INFO )
CALL CHKXER( 'DGGLSE', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGGLSE( 0, 0, 1, A, 1, B, 1, R1, R2, R3, W, LW, INFO )
CALL CHKXER( 'DGGLSE', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGGLSE( 0, 1, 0, A, 1, B, 1, R1, R2, R3, W, LW, INFO )
CALL CHKXER( 'DGGLSE', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGGLSE( 0, 0, 0, A, 0, B, 1, R1, R2, R3, W, LW, INFO )
CALL CHKXER( 'DGGLSE', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DGGLSE( 0, 0, 0, A, 1, B, 0, R1, R2, R3, W, LW, INFO )
CALL CHKXER( 'DGGLSE', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DGGLSE( 1, 1, 1, A, 1, B, 1, R1, R2, R3, W, 1, INFO )
CALL CHKXER( 'DGGLSE', INFOT, NOUT, LERR, OK )
NT = NT + 8
*
* Test error exits for the GQR path.
*
ELSE IF( LSAMEN( 3, PATH, 'GQR' ) ) THEN
*
* DGGQRF
*
SRNAMT = 'DGGQRF'
INFOT = 1
CALL DGGQRF( -1, 0, 0, A, 1, R1, B, 1, R2, W, LW, INFO )
CALL CHKXER( 'DGGQRF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGGQRF( 0, -1, 0, A, 1, R1, B, 1, R2, W, LW, INFO )
CALL CHKXER( 'DGGQRF', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGGQRF( 0, 0, -1, A, 1, R1, B, 1, R2, W, LW, INFO )
CALL CHKXER( 'DGGQRF', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGGQRF( 0, 0, 0, A, 0, R1, B, 1, R2, W, LW, INFO )
CALL CHKXER( 'DGGQRF', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DGGQRF( 0, 0, 0, A, 1, R1, B, 0, R2, W, LW, INFO )
CALL CHKXER( 'DGGQRF', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DGGQRF( 1, 1, 2, A, 1, R1, B, 1, R2, W, 1, INFO )
CALL CHKXER( 'DGGQRF', INFOT, NOUT, LERR, OK )
NT = NT + 6
*
* DGGRQF
*
SRNAMT = 'DGGRQF'
INFOT = 1
CALL DGGRQF( -1, 0, 0, A, 1, R1, B, 1, R2, W, LW, INFO )
CALL CHKXER( 'DGGRQF', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGGRQF( 0, -1, 0, A, 1, R1, B, 1, R2, W, LW, INFO )
CALL CHKXER( 'DGGRQF', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGGRQF( 0, 0, -1, A, 1, R1, B, 1, R2, W, LW, INFO )
CALL CHKXER( 'DGGRQF', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGGRQF( 0, 0, 0, A, 0, R1, B, 1, R2, W, LW, INFO )
CALL CHKXER( 'DGGRQF', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DGGRQF( 0, 0, 0, A, 1, R1, B, 0, R2, W, LW, INFO )
CALL CHKXER( 'DGGRQF', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DGGRQF( 1, 1, 2, A, 1, R1, B, 1, R2, W, 1, INFO )
CALL CHKXER( 'DGGRQF', INFOT, NOUT, LERR, OK )
NT = NT + 6
*
* Test error exits for the DGS, DGV, DGX, and DXV paths.
*
ELSE IF( LSAMEN( 3, PATH, 'DGS' ) .OR.
$ LSAMEN( 3, PATH, 'DGV' ) .OR.
$ LSAMEN( 3, PATH, 'DGX' ) .OR. LSAMEN( 3, PATH, 'DXV' ) )
$ THEN
*
* DGGES
*
SRNAMT = 'DGGES '
INFOT = 1
CALL DGGES( '/', 'N', 'S', DLCTES, 1, A, 1, B, 1, SDIM, R1, R2,
$ R3, Q, 1, U, 1, W, 1, BW, INFO )
CALL CHKXER( 'DGGES ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGGES( 'N', '/', 'S', DLCTES, 1, A, 1, B, 1, SDIM, R1, R2,
$ R3, Q, 1, U, 1, W, 1, BW, INFO )
CALL CHKXER( 'DGGES ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGGES( 'N', 'V', '/', DLCTES, 1, A, 1, B, 1, SDIM, R1, R2,
$ R3, Q, 1, U, 1, W, 1, BW, INFO )
CALL CHKXER( 'DGGES ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGGES( 'N', 'V', 'S', DLCTES, -1, A, 1, B, 1, SDIM, R1,
$ R2, R3, Q, 1, U, 1, W, 1, BW, INFO )
CALL CHKXER( 'DGGES ', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DGGES( 'N', 'V', 'S', DLCTES, 1, A, 0, B, 1, SDIM, R1, R2,
$ R3, Q, 1, U, 1, W, 1, BW, INFO )
CALL CHKXER( 'DGGES ', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DGGES( 'N', 'V', 'S', DLCTES, 1, A, 1, B, 0, SDIM, R1, R2,
$ R3, Q, 1, U, 1, W, 1, BW, INFO )
CALL CHKXER( 'DGGES ', INFOT, NOUT, LERR, OK )
INFOT = 15
CALL DGGES( 'N', 'V', 'S', DLCTES, 1, A, 1, B, 1, SDIM, R1, R2,
$ R3, Q, 0, U, 1, W, 1, BW, INFO )
CALL CHKXER( 'DGGES ', INFOT, NOUT, LERR, OK )
INFOT = 15
CALL DGGES( 'V', 'V', 'S', DLCTES, 2, A, 2, B, 2, SDIM, R1, R2,
$ R3, Q, 1, U, 2, W, 1, BW, INFO )
CALL CHKXER( 'DGGES ', INFOT, NOUT, LERR, OK )
INFOT = 17
CALL DGGES( 'N', 'V', 'S', DLCTES, 1, A, 1, B, 1, SDIM, R1, R2,
$ R3, Q, 1, U, 0, W, 1, BW, INFO )
CALL CHKXER( 'DGGES ', INFOT, NOUT, LERR, OK )
INFOT = 17
CALL DGGES( 'V', 'V', 'S', DLCTES, 2, A, 2, B, 2, SDIM, R1, R2,
$ R3, Q, 2, U, 1, W, 1, BW, INFO )
CALL CHKXER( 'DGGES ', INFOT, NOUT, LERR, OK )
INFOT = 19
CALL DGGES( 'V', 'V', 'S', DLCTES, 2, A, 2, B, 2, SDIM, R1, R2,
$ R3, Q, 2, U, 2, W, 1, BW, INFO )
CALL CHKXER( 'DGGES ', INFOT, NOUT, LERR, OK )
NT = NT + 11
*
* DGGESX
*
SRNAMT = 'DGGESX'
INFOT = 1
CALL DGGESX( '/', 'N', 'S', DLCTSX, 'N', 1, A, 1, B, 1, SDIM,
$ R1, R2, R3, Q, 1, U, 1, RCE, RCV, W, 1, IW, 1, BW,
$ INFO )
CALL CHKXER( 'DGGESX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGGESX( 'N', '/', 'S', DLCTSX, 'N', 1, A, 1, B, 1, SDIM,
$ R1, R2, R3, Q, 1, U, 1, RCE, RCV, W, 1, IW, 1, BW,
$ INFO )
CALL CHKXER( 'DGGESX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGGESX( 'V', 'V', '/', DLCTSX, 'N', 1, A, 1, B, 1, SDIM,
$ R1, R2, R3, Q, 1, U, 1, RCE, RCV, W, 1, IW, 1, BW,
$ INFO )
CALL CHKXER( 'DGGESX', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGGESX( 'V', 'V', 'S', DLCTSX, '/', 1, A, 1, B, 1, SDIM,
$ R1, R2, R3, Q, 1, U, 1, RCE, RCV, W, 1, IW, 1, BW,
$ INFO )
CALL CHKXER( 'DGGESX', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DGGESX( 'V', 'V', 'S', DLCTSX, 'B', -1, A, 1, B, 1, SDIM,
$ R1, R2, R3, Q, 1, U, 1, RCE, RCV, W, 1, IW, 1, BW,
$ INFO )
CALL CHKXER( 'DGGESX', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DGGESX( 'V', 'V', 'S', DLCTSX, 'B', 1, A, 0, B, 1, SDIM,
$ R1, R2, R3, Q, 1, U, 1, RCE, RCV, W, 1, IW, 1, BW,
$ INFO )
CALL CHKXER( 'DGGESX', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DGGESX( 'V', 'V', 'S', DLCTSX, 'B', 1, A, 1, B, 0, SDIM,
$ R1, R2, R3, Q, 1, U, 1, RCE, RCV, W, 1, IW, 1, BW,
$ INFO )
CALL CHKXER( 'DGGESX', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL DGGESX( 'V', 'V', 'S', DLCTSX, 'B', 1, A, 1, B, 1, SDIM,
$ R1, R2, R3, Q, 0, U, 1, RCE, RCV, W, 1, IW, 1, BW,
$ INFO )
CALL CHKXER( 'DGGESX', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL DGGESX( 'V', 'V', 'S', DLCTSX, 'B', 2, A, 2, B, 2, SDIM,
$ R1, R2, R3, Q, 1, U, 1, RCE, RCV, W, 1, IW, 1, BW,
$ INFO )
CALL CHKXER( 'DGGESX', INFOT, NOUT, LERR, OK )
INFOT = 18
CALL DGGESX( 'V', 'V', 'S', DLCTSX, 'B', 1, A, 1, B, 1, SDIM,
$ R1, R2, R3, Q, 1, U, 0, RCE, RCV, W, 1, IW, 1, BW,
$ INFO )
CALL CHKXER( 'DGGESX', INFOT, NOUT, LERR, OK )
INFOT = 18
CALL DGGESX( 'V', 'V', 'S', DLCTSX, 'B', 2, A, 2, B, 2, SDIM,
$ R1, R2, R3, Q, 2, U, 1, RCE, RCV, W, 1, IW, 1, BW,
$ INFO )
CALL CHKXER( 'DGGESX', INFOT, NOUT, LERR, OK )
INFOT = 22
CALL DGGESX( 'V', 'V', 'S', DLCTSX, 'B', 2, A, 2, B, 2, SDIM,
$ R1, R2, R3, Q, 2, U, 2, RCE, RCV, W, 1, IW, 1, BW,
$ INFO )
CALL CHKXER( 'DGGESX', INFOT, NOUT, LERR, OK )
INFOT = 24
CALL DGGESX( 'V', 'V', 'S', DLCTSX, 'V', 1, A, 1, B, 1, SDIM,
$ R1, R2, R3, Q, 1, U, 1, RCE, RCV, W, 32, IW, 0,
$ BW, INFO )
CALL CHKXER( 'DGGESX', INFOT, NOUT, LERR, OK )
NT = NT + 13
*
* DGGEV
*
SRNAMT = 'DGGEV '
INFOT = 1
CALL DGGEV( '/', 'N', 1, A, 1, B, 1, R1, R2, R3, Q, 1, U, 1, W,
$ 1, INFO )
CALL CHKXER( 'DGGEV ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGGEV( 'N', '/', 1, A, 1, B, 1, R1, R2, R3, Q, 1, U, 1, W,
$ 1, INFO )
CALL CHKXER( 'DGGEV ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGGEV( 'V', 'V', -1, A, 1, B, 1, R1, R2, R3, Q, 1, U, 1,
$ W, 1, INFO )
CALL CHKXER( 'DGGEV ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGGEV( 'V', 'V', 1, A, 0, B, 1, R1, R2, R3, Q, 1, U, 1, W,
$ 1, INFO )
CALL CHKXER( 'DGGEV ', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DGGEV( 'V', 'V', 1, A, 1, B, 0, R1, R2, R3, Q, 1, U, 1, W,
$ 1, INFO )
CALL CHKXER( 'DGGEV ', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DGGEV( 'N', 'V', 1, A, 1, B, 1, R1, R2, R3, Q, 0, U, 1, W,
$ 1, INFO )
CALL CHKXER( 'DGGEV ', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DGGEV( 'V', 'V', 2, A, 2, B, 2, R1, R2, R3, Q, 1, U, 2, W,
$ 1, INFO )
CALL CHKXER( 'DGGEV ', INFOT, NOUT, LERR, OK )
INFOT = 14
CALL DGGEV( 'V', 'N', 2, A, 2, B, 2, R1, R2, R3, Q, 2, U, 0, W,
$ 1, INFO )
CALL CHKXER( 'DGGEV ', INFOT, NOUT, LERR, OK )
INFOT = 14
CALL DGGEV( 'V', 'V', 2, A, 2, B, 2, R1, R2, R3, Q, 2, U, 1, W,
$ 1, INFO )
CALL CHKXER( 'DGGEV ', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL DGGEV( 'V', 'V', 1, A, 1, B, 1, R1, R2, R3, Q, 1, U, 1, W,
$ 1, INFO )
CALL CHKXER( 'DGGEV ', INFOT, NOUT, LERR, OK )
NT = NT + 10
*
* DGGEVX
*
SRNAMT = 'DGGEVX'
INFOT = 1
CALL DGGEVX( '/', 'N', 'N', 'N', 1, A, 1, B, 1, R1, R2, R3, Q,
$ 1, U, 1, 1, 1, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
$ IW, BW, INFO )
CALL CHKXER( 'DGGEVX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGGEVX( 'N', '/', 'N', 'N', 1, A, 1, B, 1, R1, R2, R3, Q,
$ 1, U, 1, 1, 1, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
$ IW, BW, INFO )
CALL CHKXER( 'DGGEVX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGGEVX( 'N', 'N', '/', 'N', 1, A, 1, B, 1, R1, R2, R3, Q,
$ 1, U, 1, 1, 1, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
$ IW, BW, INFO )
CALL CHKXER( 'DGGEVX', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGGEVX( 'N', 'N', 'N', '/', 1, A, 1, B, 1, R1, R2, R3, Q,
$ 1, U, 1, 1, 1, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
$ IW, BW, INFO )
CALL CHKXER( 'DGGEVX', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGGEVX( 'N', 'N', 'N', 'N', -1, A, 1, B, 1, R1, R2, R3, Q,
$ 1, U, 1, 1, 1, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
$ IW, BW, INFO )
CALL CHKXER( 'DGGEVX', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DGGEVX( 'N', 'N', 'N', 'N', 1, A, 0, B, 1, R1, R2, R3, Q,
$ 1, U, 1, 1, 1, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
$ IW, BW, INFO )
CALL CHKXER( 'DGGEVX', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DGGEVX( 'N', 'N', 'N', 'N', 1, A, 1, B, 0, R1, R2, R3, Q,
$ 1, U, 1, 1, 1, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
$ IW, BW, INFO )
CALL CHKXER( 'DGGEVX', INFOT, NOUT, LERR, OK )
INFOT = 14
CALL DGGEVX( 'N', 'N', 'N', 'N', 1, A, 1, B, 1, R1, R2, R3, Q,
$ 0, U, 1, 1, 1, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
$ IW, BW, INFO )
CALL CHKXER( 'DGGEVX', INFOT, NOUT, LERR, OK )
INFOT = 14
CALL DGGEVX( 'N', 'V', 'N', 'N', 2, A, 2, B, 2, R1, R2, R3, Q,
$ 1, U, 2, 1, 2, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
$ IW, BW, INFO )
CALL CHKXER( 'DGGEVX', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL DGGEVX( 'N', 'N', 'N', 'N', 1, A, 1, B, 1, R1, R2, R3, Q,
$ 1, U, 0, 1, 1, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
$ IW, BW, INFO )
CALL CHKXER( 'DGGEVX', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL DGGEVX( 'N', 'N', 'V', 'N', 2, A, 2, B, 2, R1, R2, R3, Q,
$ 2, U, 1, 1, 2, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
$ IW, BW, INFO )
CALL CHKXER( 'DGGEVX', INFOT, NOUT, LERR, OK )
INFOT = 26
CALL DGGEVX( 'N', 'N', 'V', 'N', 2, A, 2, B, 2, R1, R2, R3, Q,
$ 2, U, 2, 1, 2, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
$ IW, BW, INFO )
CALL CHKXER( 'DGGEVX', INFOT, NOUT, LERR, OK )
NT = NT + 12
*
* DTGEXC
*
SRNAMT = 'DTGEXC'
INFOT = 3
CALL DTGEXC( .TRUE., .TRUE., -1, A, 1, B, 1, Q, 1, Z, 1, IFST,
$ ILST, W, 1, INFO )
CALL CHKXER( 'DTGEXC', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTGEXC( .TRUE., .TRUE., 1, A, 0, B, 1, Q, 1, Z, 1, IFST,
$ ILST, W, 1, INFO )
CALL CHKXER( 'DTGEXC', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DTGEXC( .TRUE., .TRUE., 1, A, 1, B, 0, Q, 1, Z, 1, IFST,
$ ILST, W, 1, INFO )
CALL CHKXER( 'DTGEXC', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DTGEXC( .FALSE., .TRUE., 1, A, 1, B, 1, Q, 0, Z, 1, IFST,
$ ILST, W, 1, INFO )
CALL CHKXER( 'DTGEXC', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DTGEXC( .TRUE., .TRUE., 1, A, 1, B, 1, Q, 0, Z, 1, IFST,
$ ILST, W, 1, INFO )
CALL CHKXER( 'DTGEXC', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DTGEXC( .TRUE., .FALSE., 1, A, 1, B, 1, Q, 1, Z, 0, IFST,
$ ILST, W, 1, INFO )
CALL CHKXER( 'DTGEXC', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DTGEXC( .TRUE., .TRUE., 1, A, 1, B, 1, Q, 1, Z, 0, IFST,
$ ILST, W, 1, INFO )
CALL CHKXER( 'DTGEXC', INFOT, NOUT, LERR, OK )
INFOT = 15
CALL DTGEXC( .TRUE., .TRUE., 1, A, 1, B, 1, Q, 1, Z, 1, IFST,
$ ILST, W, 0, INFO )
CALL CHKXER( 'DTGEXC', INFOT, NOUT, LERR, OK )
NT = NT + 8
*
* DTGSEN
*
SRNAMT = 'DTGSEN'
INFOT = 1
CALL DTGSEN( -1, .TRUE., .TRUE., SEL, 1, A, 1, B, 1, R1, R2,
$ R3, Q, 1, Z, 1, M, TOLA, TOLB, RCV, W, 1, IW, 1,
$ INFO )
CALL CHKXER( 'DTGSEN', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DTGSEN( 1, .TRUE., .TRUE., SEL, -1, A, 1, B, 1, R1, R2,
$ R3, Q, 1, Z, 1, M, TOLA, TOLB, RCV, W, 1, IW, 1,
$ INFO )
CALL CHKXER( 'DTGSEN', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DTGSEN( 1, .TRUE., .TRUE., SEL, 1, A, 0, B, 1, R1, R2, R3,
$ Q, 1, Z, 1, M, TOLA, TOLB, RCV, W, 1, IW, 1,
$ INFO )
CALL CHKXER( 'DTGSEN', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DTGSEN( 1, .TRUE., .TRUE., SEL, 1, A, 1, B, 0, R1, R2, R3,
$ Q, 1, Z, 1, M, TOLA, TOLB, RCV, W, 1, IW, 1,
$ INFO )
CALL CHKXER( 'DTGSEN', INFOT, NOUT, LERR, OK )
INFOT = 14
CALL DTGSEN( 1, .TRUE., .TRUE., SEL, 1, A, 1, B, 1, R1, R2, R3,
$ Q, 0, Z, 1, M, TOLA, TOLB, RCV, W, 1, IW, 1,
$ INFO )
CALL CHKXER( 'DTGSEN', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL DTGSEN( 1, .TRUE., .TRUE., SEL, 1, A, 1, B, 1, R1, R2, R3,
$ Q, 1, Z, 0, M, TOLA, TOLB, RCV, W, 1, IW, 1,
$ INFO )
CALL CHKXER( 'DTGSEN', INFOT, NOUT, LERR, OK )
INFOT = 22
CALL DTGSEN( 0, .TRUE., .TRUE., SEL, 1, A, 1, B, 1, R1, R2, R3,
$ Q, 1, Z, 1, M, TOLA, TOLB, RCV, W, 1, IW, 1,
$ INFO )
CALL CHKXER( 'DTGSEN', INFOT, NOUT, LERR, OK )
INFOT = 22
CALL DTGSEN( 1, .TRUE., .TRUE., SEL, 1, A, 1, B, 1, R1, R2, R3,
$ Q, 1, Z, 1, M, TOLA, TOLB, RCV, W, 1, IW, 1,
$ INFO )
CALL CHKXER( 'DTGSEN', INFOT, NOUT, LERR, OK )
INFOT = 22
CALL DTGSEN( 2, .TRUE., .TRUE., SEL, 1, A, 1, B, 1, R1, R2, R3,
$ Q, 1, Z, 1, M, TOLA, TOLB, RCV, W, 1, IW, 1,
$ INFO )
CALL CHKXER( 'DTGSEN', INFOT, NOUT, LERR, OK )
INFOT = 24
CALL DTGSEN( 0, .TRUE., .TRUE., SEL, 1, A, 1, B, 1, R1, R2, R3,
$ Q, 1, Z, 1, M, TOLA, TOLB, RCV, W, 20, IW, 0,
$ INFO )
CALL CHKXER( 'DTGSEN', INFOT, NOUT, LERR, OK )
INFOT = 24
CALL DTGSEN( 1, .TRUE., .TRUE., SEL, 1, A, 1, B, 1, R1, R2, R3,
$ Q, 1, Z, 1, M, TOLA, TOLB, RCV, W, 20, IW, 0,
$ INFO )
CALL CHKXER( 'DTGSEN', INFOT, NOUT, LERR, OK )
INFOT = 24
CALL DTGSEN( 2, .TRUE., .TRUE., SEL, 1, A, 1, B, 1, R1, R2, R3,
$ Q, 1, Z, 1, M, TOLA, TOLB, RCV, W, 20, IW, 1,
$ INFO )
CALL CHKXER( 'DTGSEN', INFOT, NOUT, LERR, OK )
NT = NT + 12
*
* DTGSNA
*
SRNAMT = 'DTGSNA'
INFOT = 1
CALL DTGSNA( '/', 'A', SEL, 1, A, 1, B, 1, Q, 1, U, 1, R1, R2,
$ 1, M, W, 1, IW, INFO )
CALL CHKXER( 'DTGSNA', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTGSNA( 'B', '/', SEL, 1, A, 1, B, 1, Q, 1, U, 1, R1, R2,
$ 1, M, W, 1, IW, INFO )
CALL CHKXER( 'DTGSNA', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DTGSNA( 'B', 'A', SEL, -1, A, 1, B, 1, Q, 1, U, 1, R1, R2,
$ 1, M, W, 1, IW, INFO )
CALL CHKXER( 'DTGSNA', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DTGSNA( 'B', 'A', SEL, 1, A, 0, B, 1, Q, 1, U, 1, R1, R2,
$ 1, M, W, 1, IW, INFO )
CALL CHKXER( 'DTGSNA', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DTGSNA( 'B', 'A', SEL, 1, A, 1, B, 0, Q, 1, U, 1, R1, R2,
$ 1, M, W, 1, IW, INFO )
CALL CHKXER( 'DTGSNA', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DTGSNA( 'E', 'A', SEL, 1, A, 1, B, 1, Q, 0, U, 1, R1, R2,
$ 1, M, W, 1, IW, INFO )
CALL CHKXER( 'DTGSNA', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DTGSNA( 'E', 'A', SEL, 1, A, 1, B, 1, Q, 1, U, 0, R1, R2,
$ 1, M, W, 1, IW, INFO )
CALL CHKXER( 'DTGSNA', INFOT, NOUT, LERR, OK )
INFOT = 15
CALL DTGSNA( 'E', 'A', SEL, 1, A, 1, B, 1, Q, 1, U, 1, R1, R2,
$ 0, M, W, 1, IW, INFO )
CALL CHKXER( 'DTGSNA', INFOT, NOUT, LERR, OK )
INFOT = 18
CALL DTGSNA( 'E', 'A', SEL, 1, A, 1, B, 1, Q, 1, U, 1, R1, R2,
$ 1, M, W, 0, IW, INFO )
CALL CHKXER( 'DTGSNA', INFOT, NOUT, LERR, OK )
NT = NT + 9
*
* DTGSYL
*
SRNAMT = 'DTGSYL'
INFOT = 1
CALL DTGSYL( '/', 0, 1, 1, A, 1, B, 1, Q, 1, U, 1, V, 1, Z, 1,
$ SCALE, DIF, W, 1, IW, INFO )
CALL CHKXER( 'DTGSYL', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTGSYL( 'N', -1, 1, 1, A, 1, B, 1, Q, 1, U, 1, V, 1, Z, 1,
$ SCALE, DIF, W, 1, IW, INFO )
CALL CHKXER( 'DTGSYL', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DTGSYL( 'N', 0, 0, 1, A, 1, B, 1, Q, 1, U, 1, V, 1, Z, 1,
$ SCALE, DIF, W, 1, IW, INFO )
CALL CHKXER( 'DTGSYL', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DTGSYL( 'N', 0, 1, 0, A, 1, B, 1, Q, 1, U, 1, V, 1, Z, 1,
$ SCALE, DIF, W, 1, IW, INFO )
CALL CHKXER( 'DTGSYL', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DTGSYL( 'N', 0, 1, 1, A, 0, B, 1, Q, 1, U, 1, V, 1, Z, 1,
$ SCALE, DIF, W, 1, IW, INFO )
CALL CHKXER( 'DTGSYL', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DTGSYL( 'N', 0, 1, 1, A, 1, B, 0, Q, 1, U, 1, V, 1, Z, 1,
$ SCALE, DIF, W, 1, IW, INFO )
CALL CHKXER( 'DTGSYL', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DTGSYL( 'N', 0, 1, 1, A, 1, B, 1, Q, 0, U, 1, V, 1, Z, 1,
$ SCALE, DIF, W, 1, IW, INFO )
CALL CHKXER( 'DTGSYL', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DTGSYL( 'N', 0, 1, 1, A, 1, B, 1, Q, 1, U, 0, V, 1, Z, 1,
$ SCALE, DIF, W, 1, IW, INFO )
CALL CHKXER( 'DTGSYL', INFOT, NOUT, LERR, OK )
INFOT = 14
CALL DTGSYL( 'N', 0, 1, 1, A, 1, B, 1, Q, 1, U, 1, V, 0, Z, 1,
$ SCALE, DIF, W, 1, IW, INFO )
CALL CHKXER( 'DTGSYL', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL DTGSYL( 'N', 0, 1, 1, A, 1, B, 1, Q, 1, U, 1, V, 1, Z, 0,
$ SCALE, DIF, W, 1, IW, INFO )
CALL CHKXER( 'DTGSYL', INFOT, NOUT, LERR, OK )
INFOT = 20
CALL DTGSYL( 'N', 1, 1, 1, A, 1, B, 1, Q, 1, U, 1, V, 1, Z, 1,
$ SCALE, DIF, W, 1, IW, INFO )
CALL CHKXER( 'DTGSYL', INFOT, NOUT, LERR, OK )
INFOT = 20
CALL DTGSYL( 'N', 2, 1, 1, A, 1, B, 1, Q, 1, U, 1, V, 1, Z, 1,
$ SCALE, DIF, W, 1, IW, INFO )
CALL CHKXER( 'DTGSYL', INFOT, NOUT, LERR, OK )
NT = NT + 12
END IF
*
* Print a summary line.
*
IF( OK ) THEN
WRITE( NOUT, FMT = 9999 )PATH, NT
ELSE
WRITE( NOUT, FMT = 9998 )PATH
END IF
*
9999 FORMAT( 1X, A3, ' routines passed the tests of the error exits (',
$ I3, ' tests done)' )
9998 FORMAT( ' *** ', A3, ' routines failed the tests of the error ',
$ 'exits ***' )
*
RETURN
*
* End of DERRGG
*
END
SUBROUTINE DERRHS( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* DERRHS tests the error exits for DGEBAK, SGEBAL, SGEHRD, DORGHR,
* DORMHR, DHSEQR, SHSEIN, and DTREVC.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX, LW
PARAMETER ( NMAX = 3, LW = ( NMAX+2 )*( NMAX+2 )+NMAX )
* ..
* .. Local Scalars ..
CHARACTER*2 C2
INTEGER I, IHI, ILO, INFO, J, M, NT
* ..
* .. Local Arrays ..
LOGICAL SEL( NMAX )
INTEGER IFAILL( NMAX ), IFAILR( NMAX )
DOUBLE PRECISION A( NMAX, NMAX ), C( NMAX, NMAX ), S( NMAX ),
$ TAU( NMAX ), VL( NMAX, NMAX ),
$ VR( NMAX, NMAX ), W( LW ), WI( NMAX ),
$ WR( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL CHKXER, DGEBAK, DGEBAL, DGEHRD, DHSEIN, DHSEQR,
$ DORGHR, DORMHR, DTREVC
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
C2 = PATH( 2: 3 )
*
* Set the variables to innocuous values.
*
DO 20 J = 1, NMAX
DO 10 I = 1, NMAX
A( I, J ) = 1.D0 / DBLE( I+J )
10 CONTINUE
WI( J ) = DBLE( J )
SEL( J ) = .TRUE.
20 CONTINUE
OK = .TRUE.
NT = 0
*
* Test error exits of the nonsymmetric eigenvalue routines.
*
IF( LSAMEN( 2, C2, 'HS' ) ) THEN
*
* DGEBAL
*
SRNAMT = 'DGEBAL'
INFOT = 1
CALL DGEBAL( '/', 0, A, 1, ILO, IHI, S, INFO )
CALL CHKXER( 'DGEBAL', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGEBAL( 'N', -1, A, 1, ILO, IHI, S, INFO )
CALL CHKXER( 'DGEBAL', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGEBAL( 'N', 2, A, 1, ILO, IHI, S, INFO )
CALL CHKXER( 'DGEBAL', INFOT, NOUT, LERR, OK )
NT = NT + 3
*
* DGEBAK
*
SRNAMT = 'DGEBAK'
INFOT = 1
CALL DGEBAK( '/', 'R', 0, 1, 0, S, 0, A, 1, INFO )
CALL CHKXER( 'DGEBAK', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGEBAK( 'N', '/', 0, 1, 0, S, 0, A, 1, INFO )
CALL CHKXER( 'DGEBAK', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGEBAK( 'N', 'R', -1, 1, 0, S, 0, A, 1, INFO )
CALL CHKXER( 'DGEBAK', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGEBAK( 'N', 'R', 0, 0, 0, S, 0, A, 1, INFO )
CALL CHKXER( 'DGEBAK', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGEBAK( 'N', 'R', 0, 2, 0, S, 0, A, 1, INFO )
CALL CHKXER( 'DGEBAK', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGEBAK( 'N', 'R', 2, 2, 1, S, 0, A, 2, INFO )
CALL CHKXER( 'DGEBAK', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGEBAK( 'N', 'R', 0, 1, 1, S, 0, A, 1, INFO )
CALL CHKXER( 'DGEBAK', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DGEBAK( 'N', 'R', 0, 1, 0, S, -1, A, 1, INFO )
CALL CHKXER( 'DGEBAK', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DGEBAK( 'N', 'R', 2, 1, 2, S, 0, A, 1, INFO )
CALL CHKXER( 'DGEBAK', INFOT, NOUT, LERR, OK )
NT = NT + 9
*
* DGEHRD
*
SRNAMT = 'DGEHRD'
INFOT = 1
CALL DGEHRD( -1, 1, 1, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'DGEHRD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGEHRD( 0, 0, 0, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'DGEHRD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGEHRD( 0, 2, 0, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'DGEHRD', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGEHRD( 1, 1, 0, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'DGEHRD', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGEHRD( 0, 1, 1, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'DGEHRD', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGEHRD( 2, 1, 1, A, 1, TAU, W, 2, INFO )
CALL CHKXER( 'DGEHRD', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DGEHRD( 2, 1, 2, A, 2, TAU, W, 1, INFO )
CALL CHKXER( 'DGEHRD', INFOT, NOUT, LERR, OK )
NT = NT + 7
*
* DORGHR
*
SRNAMT = 'DORGHR'
INFOT = 1
CALL DORGHR( -1, 1, 1, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'DORGHR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORGHR( 0, 0, 0, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'DORGHR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORGHR( 0, 2, 0, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'DORGHR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORGHR( 1, 1, 0, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'DORGHR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORGHR( 0, 1, 1, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'DORGHR', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORGHR( 2, 1, 1, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'DORGHR', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DORGHR( 3, 1, 3, A, 3, TAU, W, 1, INFO )
CALL CHKXER( 'DORGHR', INFOT, NOUT, LERR, OK )
NT = NT + 7
*
* DORMHR
*
SRNAMT = 'DORMHR'
INFOT = 1
CALL DORMHR( '/', 'N', 0, 0, 1, 0, A, 1, TAU, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORMHR( 'L', '/', 0, 0, 1, 0, A, 1, TAU, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORMHR( 'L', 'N', -1, 0, 1, 0, A, 1, TAU, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DORMHR( 'L', 'N', 0, -1, 1, 0, A, 1, TAU, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORMHR( 'L', 'N', 0, 0, 0, 0, A, 1, TAU, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORMHR( 'L', 'N', 0, 0, 2, 0, A, 1, TAU, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORMHR( 'L', 'N', 1, 2, 2, 1, A, 1, TAU, C, 1, W, 2,
$ INFO )
CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORMHR( 'R', 'N', 2, 1, 2, 1, A, 1, TAU, C, 2, W, 2,
$ INFO )
CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DORMHR( 'L', 'N', 1, 1, 1, 0, A, 1, TAU, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DORMHR( 'L', 'N', 0, 1, 1, 1, A, 1, TAU, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DORMHR( 'R', 'N', 1, 0, 1, 1, A, 1, TAU, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DORMHR( 'L', 'N', 2, 1, 1, 1, A, 1, TAU, C, 2, W, 1,
$ INFO )
CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DORMHR( 'R', 'N', 1, 2, 1, 1, A, 1, TAU, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DORMHR( 'L', 'N', 2, 1, 1, 1, A, 2, TAU, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL DORMHR( 'L', 'N', 1, 2, 1, 1, A, 1, TAU, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL DORMHR( 'R', 'N', 2, 1, 1, 1, A, 1, TAU, C, 2, W, 1,
$ INFO )
CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
NT = NT + 16
*
* DHSEQR
*
SRNAMT = 'DHSEQR'
INFOT = 1
CALL DHSEQR( '/', 'N', 0, 1, 0, A, 1, WR, WI, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'DHSEQR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DHSEQR( 'E', '/', 0, 1, 0, A, 1, WR, WI, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'DHSEQR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DHSEQR( 'E', 'N', -1, 1, 0, A, 1, WR, WI, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'DHSEQR', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DHSEQR( 'E', 'N', 0, 0, 0, A, 1, WR, WI, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'DHSEQR', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DHSEQR( 'E', 'N', 0, 2, 0, A, 1, WR, WI, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'DHSEQR', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DHSEQR( 'E', 'N', 1, 1, 0, A, 1, WR, WI, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'DHSEQR', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DHSEQR( 'E', 'N', 1, 1, 2, A, 1, WR, WI, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'DHSEQR', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DHSEQR( 'E', 'N', 2, 1, 2, A, 1, WR, WI, C, 2, W, 1,
$ INFO )
CALL CHKXER( 'DHSEQR', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DHSEQR( 'E', 'V', 2, 1, 2, A, 2, WR, WI, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'DHSEQR', INFOT, NOUT, LERR, OK )
NT = NT + 9
*
* DHSEIN
*
SRNAMT = 'DHSEIN'
INFOT = 1
CALL DHSEIN( '/', 'N', 'N', SEL, 0, A, 1, WR, WI, VL, 1, VR, 1,
$ 0, M, W, IFAILL, IFAILR, INFO )
CALL CHKXER( 'DHSEIN', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DHSEIN( 'R', '/', 'N', SEL, 0, A, 1, WR, WI, VL, 1, VR, 1,
$ 0, M, W, IFAILL, IFAILR, INFO )
CALL CHKXER( 'DHSEIN', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DHSEIN( 'R', 'N', '/', SEL, 0, A, 1, WR, WI, VL, 1, VR, 1,
$ 0, M, W, IFAILL, IFAILR, INFO )
CALL CHKXER( 'DHSEIN', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DHSEIN( 'R', 'N', 'N', SEL, -1, A, 1, WR, WI, VL, 1, VR,
$ 1, 0, M, W, IFAILL, IFAILR, INFO )
CALL CHKXER( 'DHSEIN', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DHSEIN( 'R', 'N', 'N', SEL, 2, A, 1, WR, WI, VL, 1, VR, 2,
$ 4, M, W, IFAILL, IFAILR, INFO )
CALL CHKXER( 'DHSEIN', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DHSEIN( 'L', 'N', 'N', SEL, 2, A, 2, WR, WI, VL, 1, VR, 1,
$ 4, M, W, IFAILL, IFAILR, INFO )
CALL CHKXER( 'DHSEIN', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL DHSEIN( 'R', 'N', 'N', SEL, 2, A, 2, WR, WI, VL, 1, VR, 1,
$ 4, M, W, IFAILL, IFAILR, INFO )
CALL CHKXER( 'DHSEIN', INFOT, NOUT, LERR, OK )
INFOT = 14
CALL DHSEIN( 'R', 'N', 'N', SEL, 2, A, 2, WR, WI, VL, 1, VR, 2,
$ 1, M, W, IFAILL, IFAILR, INFO )
CALL CHKXER( 'DHSEIN', INFOT, NOUT, LERR, OK )
NT = NT + 8
*
* DTREVC
*
SRNAMT = 'DTREVC'
INFOT = 1
CALL DTREVC( '/', 'A', SEL, 0, A, 1, VL, 1, VR, 1, 0, M, W,
$ INFO )
CALL CHKXER( 'DTREVC', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTREVC( 'L', '/', SEL, 0, A, 1, VL, 1, VR, 1, 0, M, W,
$ INFO )
CALL CHKXER( 'DTREVC', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DTREVC( 'L', 'A', SEL, -1, A, 1, VL, 1, VR, 1, 0, M, W,
$ INFO )
CALL CHKXER( 'DTREVC', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DTREVC( 'L', 'A', SEL, 2, A, 1, VL, 2, VR, 1, 4, M, W,
$ INFO )
CALL CHKXER( 'DTREVC', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DTREVC( 'L', 'A', SEL, 2, A, 2, VL, 1, VR, 1, 4, M, W,
$ INFO )
CALL CHKXER( 'DTREVC', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DTREVC( 'R', 'A', SEL, 2, A, 2, VL, 1, VR, 1, 4, M, W,
$ INFO )
CALL CHKXER( 'DTREVC', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DTREVC( 'L', 'A', SEL, 2, A, 2, VL, 2, VR, 1, 1, M, W,
$ INFO )
CALL CHKXER( 'DTREVC', INFOT, NOUT, LERR, OK )
NT = NT + 7
END IF
*
* Print a summary line.
*
IF( OK ) THEN
WRITE( NOUT, FMT = 9999 )PATH, NT
ELSE
WRITE( NOUT, FMT = 9998 )PATH
END IF
*
9999 FORMAT( 1X, A3, ' routines passed the tests of the error exits',
$ ' (', I3, ' tests done)' )
9998 FORMAT( ' *** ', A3, ' routines failed the tests of the error ',
$ 'exits ***' )
*
RETURN
*
* End of DERRHS
*
END
SUBROUTINE DERRST( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* DERRST tests the error exits for DSYTRD, DORGTR, DORMTR, DSPTRD,
* DOPGTR, DOPMTR, DSTEQR, SSTERF, SSTEBZ, SSTEIN, DPTEQR, DSBTRD,
* DSYEV, SSYEVX, SSYEVD, DSBEV, SSBEVX, SSBEVD,
* DSPEV, SSPEVX, SSPEVD, DSTEV, SSTEVX, SSTEVD, and SSTEDC.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* NMAX has to be at least 3 or LIW may be too small
* .. Parameters ..
INTEGER NMAX, LIW, LW
PARAMETER ( NMAX = 3, LIW = 12*NMAX, LW = 20*NMAX )
* ..
* .. Local Scalars ..
CHARACTER*2 C2
INTEGER I, INFO, J, M, N, NSPLIT, NT
* ..
* .. Local Arrays ..
INTEGER I1( NMAX ), I2( NMAX ), I3( NMAX ), IW( LIW )
DOUBLE PRECISION A( NMAX, NMAX ), C( NMAX, NMAX ), D( NMAX ),
$ E( NMAX ), Q( NMAX, NMAX ), R( NMAX ),
$ TAU( NMAX ), W( LW ), X( NMAX ),
$ Z( NMAX, NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL CHKXER, DOPGTR, DOPMTR, DORGTR, DORMTR, DPTEQR,
$ DSBEV, DSBEVD, DSBEVX, DSBTRD, DSPEV, DSPEVD,
$ DSPEVX, DSPTRD, DSTEBZ, DSTEDC, DSTEIN, DSTEQR,
$ DSTERF, DSTEV, DSTEVD, DSTEVR, DSTEVX, DSYEV,
$ DSYEVD, DSYEVR, DSYEVX, DSYTRD
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
C2 = PATH( 2: 3 )
*
* Set the variables to innocuous values.
*
DO 20 J = 1, NMAX
DO 10 I = 1, NMAX
A( I, J ) = 1.D0 / DBLE( I+J )
10 CONTINUE
20 CONTINUE
DO 30 J = 1, NMAX
D( J ) = DBLE( J )
E( J ) = 0.0D0
I1( J ) = J
I2( J ) = J
TAU( J ) = 1.D0
30 CONTINUE
OK = .TRUE.
NT = 0
*
* Test error exits for the ST path.
*
IF( LSAMEN( 2, C2, 'ST' ) ) THEN
*
* DSYTRD
*
SRNAMT = 'DSYTRD'
INFOT = 1
CALL DSYTRD( '/', 0, A, 1, D, E, TAU, W, 1, INFO )
CALL CHKXER( 'DSYTRD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSYTRD( 'U', -1, A, 1, D, E, TAU, W, 1, INFO )
CALL CHKXER( 'DSYTRD', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DSYTRD( 'U', 2, A, 1, D, E, TAU, W, 1, INFO )
CALL CHKXER( 'DSYTRD', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DSYTRD( 'U', 0, A, 1, D, E, TAU, W, 0, INFO )
CALL CHKXER( 'DSYTRD', INFOT, NOUT, LERR, OK )
NT = NT + 4
*
* DORGTR
*
SRNAMT = 'DORGTR'
INFOT = 1
CALL DORGTR( '/', 0, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'DORGTR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORGTR( 'U', -1, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'DORGTR', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DORGTR( 'U', 2, A, 1, TAU, W, 1, INFO )
CALL CHKXER( 'DORGTR', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DORGTR( 'U', 3, A, 3, TAU, W, 1, INFO )
CALL CHKXER( 'DORGTR', INFOT, NOUT, LERR, OK )
NT = NT + 4
*
* DORMTR
*
SRNAMT = 'DORMTR'
INFOT = 1
CALL DORMTR( '/', 'U', 'N', 0, 0, A, 1, TAU, C, 1, W, 1, INFO )
CALL CHKXER( 'DORMTR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DORMTR( 'L', '/', 'N', 0, 0, A, 1, TAU, C, 1, W, 1, INFO )
CALL CHKXER( 'DORMTR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DORMTR( 'L', 'U', '/', 0, 0, A, 1, TAU, C, 1, W, 1, INFO )
CALL CHKXER( 'DORMTR', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DORMTR( 'L', 'U', 'N', -1, 0, A, 1, TAU, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'DORMTR', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DORMTR( 'L', 'U', 'N', 0, -1, A, 1, TAU, C, 1, W, 1,
$ INFO )
CALL CHKXER( 'DORMTR', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DORMTR( 'L', 'U', 'N', 2, 0, A, 1, TAU, C, 2, W, 1, INFO )
CALL CHKXER( 'DORMTR', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DORMTR( 'R', 'U', 'N', 0, 2, A, 1, TAU, C, 1, W, 1, INFO )
CALL CHKXER( 'DORMTR', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DORMTR( 'L', 'U', 'N', 2, 0, A, 2, TAU, C, 1, W, 1, INFO )
CALL CHKXER( 'DORMTR', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DORMTR( 'L', 'U', 'N', 0, 2, A, 1, TAU, C, 1, W, 1, INFO )
CALL CHKXER( 'DORMTR', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DORMTR( 'R', 'U', 'N', 2, 0, A, 1, TAU, C, 2, W, 1, INFO )
CALL CHKXER( 'DORMTR', INFOT, NOUT, LERR, OK )
NT = NT + 10
*
* DSPTRD
*
SRNAMT = 'DSPTRD'
INFOT = 1
CALL DSPTRD( '/', 0, A, D, E, TAU, INFO )
CALL CHKXER( 'DSPTRD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSPTRD( 'U', -1, A, D, E, TAU, INFO )
CALL CHKXER( 'DSPTRD', INFOT, NOUT, LERR, OK )
NT = NT + 2
*
* DOPGTR
*
SRNAMT = 'DOPGTR'
INFOT = 1
CALL DOPGTR( '/', 0, A, TAU, Z, 1, W, INFO )
CALL CHKXER( 'DOPGTR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DOPGTR( 'U', -1, A, TAU, Z, 1, W, INFO )
CALL CHKXER( 'DOPGTR', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DOPGTR( 'U', 2, A, TAU, Z, 1, W, INFO )
CALL CHKXER( 'DOPGTR', INFOT, NOUT, LERR, OK )
NT = NT + 3
*
* DOPMTR
*
SRNAMT = 'DOPMTR'
INFOT = 1
CALL DOPMTR( '/', 'U', 'N', 0, 0, A, TAU, C, 1, W, INFO )
CALL CHKXER( 'DOPMTR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DOPMTR( 'L', '/', 'N', 0, 0, A, TAU, C, 1, W, INFO )
CALL CHKXER( 'DOPMTR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DOPMTR( 'L', 'U', '/', 0, 0, A, TAU, C, 1, W, INFO )
CALL CHKXER( 'DOPMTR', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DOPMTR( 'L', 'U', 'N', -1, 0, A, TAU, C, 1, W, INFO )
CALL CHKXER( 'DOPMTR', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DOPMTR( 'L', 'U', 'N', 0, -1, A, TAU, C, 1, W, INFO )
CALL CHKXER( 'DOPMTR', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DOPMTR( 'L', 'U', 'N', 2, 0, A, TAU, C, 1, W, INFO )
CALL CHKXER( 'DOPMTR', INFOT, NOUT, LERR, OK )
NT = NT + 6
*
* DPTEQR
*
SRNAMT = 'DPTEQR'
INFOT = 1
CALL DPTEQR( '/', 0, D, E, Z, 1, W, INFO )
CALL CHKXER( 'DPTEQR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DPTEQR( 'N', -1, D, E, Z, 1, W, INFO )
CALL CHKXER( 'DPTEQR', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DPTEQR( 'V', 2, D, E, Z, 1, W, INFO )
CALL CHKXER( 'DPTEQR', INFOT, NOUT, LERR, OK )
NT = NT + 3
*
* DSTEBZ
*
SRNAMT = 'DSTEBZ'
INFOT = 1
CALL DSTEBZ( '/', 'E', 0, 0.0D0, 1.0D0, 1, 0, 0.0D0, D, E, M,
$ NSPLIT, X, I1, I2, W, IW, INFO )
CALL CHKXER( 'DSTEBZ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSTEBZ( 'A', '/', 0, 0.0D0, 0.0D0, 0, 0, 0.0D0, D, E, M,
$ NSPLIT, X, I1, I2, W, IW, INFO )
CALL CHKXER( 'DSTEBZ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSTEBZ( 'A', 'E', -1, 0.0D0, 0.0D0, 0, 0, 0.0D0, D, E, M,
$ NSPLIT, X, I1, I2, W, IW, INFO )
CALL CHKXER( 'DSTEBZ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DSTEBZ( 'V', 'E', 0, 0.0D0, 0.0D0, 0, 0, 0.0D0, D, E, M,
$ NSPLIT, X, I1, I2, W, IW, INFO )
CALL CHKXER( 'DSTEBZ', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DSTEBZ( 'I', 'E', 0, 0.0D0, 0.0D0, 0, 0, 0.0D0, D, E, M,
$ NSPLIT, X, I1, I2, W, IW, INFO )
CALL CHKXER( 'DSTEBZ', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DSTEBZ( 'I', 'E', 1, 0.0D0, 0.0D0, 2, 1, 0.0D0, D, E, M,
$ NSPLIT, X, I1, I2, W, IW, INFO )
CALL CHKXER( 'DSTEBZ', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DSTEBZ( 'I', 'E', 1, 0.0D0, 0.0D0, 1, 0, 0.0D0, D, E, M,
$ NSPLIT, X, I1, I2, W, IW, INFO )
CALL CHKXER( 'DSTEBZ', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DSTEBZ( 'I', 'E', 1, 0.0D0, 0.0D0, 1, 2, 0.0D0, D, E, M,
$ NSPLIT, X, I1, I2, W, IW, INFO )
CALL CHKXER( 'DSTEBZ', INFOT, NOUT, LERR, OK )
NT = NT + 8
*
* DSTEIN
*
SRNAMT = 'DSTEIN'
INFOT = 1
CALL DSTEIN( -1, D, E, 0, X, I1, I2, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSTEIN', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DSTEIN( 0, D, E, -1, X, I1, I2, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSTEIN', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DSTEIN( 0, D, E, 1, X, I1, I2, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSTEIN', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DSTEIN( 2, D, E, 0, X, I1, I2, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSTEIN', INFOT, NOUT, LERR, OK )
NT = NT + 4
*
* DSTEQR
*
SRNAMT = 'DSTEQR'
INFOT = 1
CALL DSTEQR( '/', 0, D, E, Z, 1, W, INFO )
CALL CHKXER( 'DSTEQR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSTEQR( 'N', -1, D, E, Z, 1, W, INFO )
CALL CHKXER( 'DSTEQR', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DSTEQR( 'V', 2, D, E, Z, 1, W, INFO )
CALL CHKXER( 'DSTEQR', INFOT, NOUT, LERR, OK )
NT = NT + 3
*
* DSTERF
*
SRNAMT = 'DSTERF'
INFOT = 1
CALL DSTERF( -1, D, E, INFO )
CALL CHKXER( 'DSTERF', INFOT, NOUT, LERR, OK )
NT = NT + 1
*
* DSTEDC
*
SRNAMT = 'DSTEDC'
INFOT = 1
CALL DSTEDC( '/', 0, D, E, Z, 1, W, 1, IW, 1, INFO )
CALL CHKXER( 'DSTEDC', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSTEDC( 'N', -1, D, E, Z, 1, W, 1, IW, 1, INFO )
CALL CHKXER( 'DSTEDC', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DSTEDC( 'V', 2, D, E, Z, 1, W, 23, IW, 28, INFO )
CALL CHKXER( 'DSTEDC', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DSTEDC( 'N', 1, D, E, Z, 1, W, 0, IW, 1, INFO )
CALL CHKXER( 'DSTEDC', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DSTEDC( 'I', 2, D, E, Z, 2, W, 0, IW, 12, INFO )
CALL CHKXER( 'DSTEDC', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DSTEDC( 'V', 2, D, E, Z, 2, W, 0, IW, 28, INFO )
CALL CHKXER( 'DSTEDC', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DSTEDC( 'N', 1, D, E, Z, 1, W, 1, IW, 0, INFO )
CALL CHKXER( 'DSTEDC', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DSTEDC( 'I', 2, D, E, Z, 2, W, 19, IW, 0, INFO )
CALL CHKXER( 'DSTEDC', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DSTEDC( 'V', 2, D, E, Z, 2, W, 23, IW, 0, INFO )
CALL CHKXER( 'DSTEDC', INFOT, NOUT, LERR, OK )
NT = NT + 9
*
* DSTEVD
*
SRNAMT = 'DSTEVD'
INFOT = 1
CALL DSTEVD( '/', 0, D, E, Z, 1, W, 1, IW, 1, INFO )
CALL CHKXER( 'DSTEVD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSTEVD( 'N', -1, D, E, Z, 1, W, 1, IW, 1, INFO )
CALL CHKXER( 'DSTEVD', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DSTEVD( 'V', 2, D, E, Z, 1, W, 19, IW, 12, INFO )
CALL CHKXER( 'DSTEVD', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DSTEVD( 'N', 1, D, E, Z, 1, W, 0, IW, 1, INFO )
CALL CHKXER( 'DSTEVD', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DSTEVD( 'V', 2, D, E, Z, 2, W, 12, IW, 12, INFO )
CALL CHKXER( 'DSTEVD', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DSTEVD( 'N', 0, D, E, Z, 1, W, 1, IW, 0, INFO )
CALL CHKXER( 'DSTEVD', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DSTEVD( 'V', 2, D, E, Z, 2, W, 19, IW, 11, INFO )
CALL CHKXER( 'DSTEVD', INFOT, NOUT, LERR, OK )
NT = NT + 7
*
* DSTEV
*
SRNAMT = 'DSTEV '
INFOT = 1
CALL DSTEV( '/', 0, D, E, Z, 1, W, INFO )
CALL CHKXER( 'DSTEV ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSTEV( 'N', -1, D, E, Z, 1, W, INFO )
CALL CHKXER( 'DSTEV ', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DSTEV( 'V', 2, D, E, Z, 1, W, INFO )
CALL CHKXER( 'DSTEV ', INFOT, NOUT, LERR, OK )
NT = NT + 3
*
* DSTEVX
*
SRNAMT = 'DSTEVX'
INFOT = 1
CALL DSTEVX( '/', 'A', 0, D, E, 0.0D0, 0.0D0, 0, 0, 0.0D0, M,
$ X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSTEVX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSTEVX( 'N', '/', 0, D, E, 0.0D0, 1.0D0, 1, 0, 0.0D0, M,
$ X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSTEVX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSTEVX( 'N', 'A', -1, D, E, 0.0D0, 0.0D0, 0, 0, 0.0D0, M,
$ X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSTEVX', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DSTEVX( 'N', 'V', 1, D, E, 0.0D0, 0.0D0, 0, 0, 0.0D0, M,
$ X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSTEVX', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DSTEVX( 'N', 'I', 1, D, E, 0.0D0, 0.0D0, 0, 0, 0.0D0, M,
$ X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSTEVX', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DSTEVX( 'N', 'I', 1, D, E, 0.0D0, 0.0D0, 2, 1, 0.0D0, M,
$ X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSTEVX', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DSTEVX( 'N', 'I', 2, D, E, 0.0D0, 0.0D0, 2, 1, 0.0D0, M,
$ X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSTEVX', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DSTEVX( 'N', 'I', 1, D, E, 0.0D0, 0.0D0, 1, 2, 0.0D0, M,
$ X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSTEVX', INFOT, NOUT, LERR, OK )
INFOT = 14
CALL DSTEVX( 'V', 'A', 2, D, E, 0.0D0, 0.0D0, 0, 0, 0.0D0, M,
$ X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSTEVX', INFOT, NOUT, LERR, OK )
NT = NT + 9
*
* DSTEVR
*
N = 1
SRNAMT = 'DSTEVR'
INFOT = 1
CALL DSTEVR( '/', 'A', 0, D, E, 0.0D0, 0.0D0, 1, 1, 0.0D0, M,
$ R, Z, 1, IW, X, 20*N, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'DSTEVR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSTEVR( 'V', '/', 0, D, E, 0.0D0, 0.0D0, 1, 1, 0.0D0, M,
$ R, Z, 1, IW, X, 20*N, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'DSTEVR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSTEVR( 'V', 'A', -1, D, E, 0.0D0, 0.0D0, 1, 1, 0.0D0, M,
$ R, Z, 1, IW, X, 20*N, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'DSTEVR', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DSTEVR( 'V', 'V', 1, D, E, 0.0D0, 0.0D0, 1, 1, 0.0D0, M,
$ R, Z, 1, IW, X, 20*N, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'DSTEVR', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DSTEVR( 'V', 'I', 1, D, E, 0.0D0, 0.0D0, 0, 1, 0.0D0, M,
$ W, Z, 1, IW, X, 20*N, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'DSTEVR', INFOT, NOUT, LERR, OK )
INFOT = 9
N = 2
CALL DSTEVR( 'V', 'I', 2, D, E, 0.0D0, 0.0D0, 2, 1, 0.0D0, M,
$ W, Z, 1, IW, X, 20*N, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'DSTEVR', INFOT, NOUT, LERR, OK )
INFOT = 14
N = 1
CALL DSTEVR( 'V', 'I', 1, D, E, 0.0D0, 0.0D0, 1, 1, 0.0D0, M,
$ W, Z, 0, IW, X, 20*N, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'DSTEVR', INFOT, NOUT, LERR, OK )
INFOT = 17
CALL DSTEVR( 'V', 'I', 1, D, E, 0.0D0, 0.0D0, 1, 1, 0.0D0, M,
$ W, Z, 1, IW, X, 20*N-1, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'DSTEVR', INFOT, NOUT, LERR, OK )
INFOT = 19
CALL DSTEVR( 'V', 'I', 1, D, E, 0.0D0, 0.0D0, 1, 1, 0.0D0, M,
$ W, Z, 1, IW, X, 20*N, IW( 2*N+1 ), 10*N-1, INFO )
CALL CHKXER( 'DSTEVR', INFOT, NOUT, LERR, OK )
NT = NT + 9
*
* DSYEVD
*
SRNAMT = 'DSYEVD'
INFOT = 1
CALL DSYEVD( '/', 'U', 0, A, 1, X, W, 1, IW, 1, INFO )
CALL CHKXER( 'DSYEVD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSYEVD( 'N', '/', 0, A, 1, X, W, 1, IW, 1, INFO )
CALL CHKXER( 'DSYEVD', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSYEVD( 'N', 'U', -1, A, 1, X, W, 1, IW, 1, INFO )
CALL CHKXER( 'DSYEVD', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DSYEVD( 'N', 'U', 2, A, 1, X, W, 3, IW, 1, INFO )
CALL CHKXER( 'DSYEVD', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DSYEVD( 'N', 'U', 1, A, 1, X, W, 0, IW, 1, INFO )
CALL CHKXER( 'DSYEVD', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DSYEVD( 'N', 'U', 2, A, 2, X, W, 4, IW, 1, INFO )
CALL CHKXER( 'DSYEVD', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DSYEVD( 'V', 'U', 2, A, 2, X, W, 20, IW, 12, INFO )
CALL CHKXER( 'DSYEVD', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DSYEVD( 'N', 'U', 1, A, 1, X, W, 1, IW, 0, INFO )
CALL CHKXER( 'DSYEVD', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DSYEVD( 'N', 'U', 2, A, 2, X, W, 5, IW, 0, INFO )
CALL CHKXER( 'DSYEVD', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DSYEVD( 'V', 'U', 2, A, 2, X, W, 27, IW, 11, INFO )
CALL CHKXER( 'DSYEVD', INFOT, NOUT, LERR, OK )
NT = NT + 10
*
* DSYEVR
*
SRNAMT = 'DSYEVR'
N = 1
INFOT = 1
CALL DSYEVR( '/', 'A', 'U', 0, A, 1, 0.0D0, 0.0D0, 1, 1, 0.0D0,
$ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'DSYEVR', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSYEVR( 'V', '/', 'U', 0, A, 1, 0.0D0, 0.0D0, 1, 1, 0.0D0,
$ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'DSYEVR', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSYEVR( 'V', 'A', '/', -1, A, 1, 0.0D0, 0.0D0, 1, 1,
$ 0.0D0, M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N,
$ INFO )
CALL CHKXER( 'DSYEVR', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DSYEVR( 'V', 'A', 'U', -1, A, 1, 0.0D0, 0.0D0, 1, 1,
$ 0.0D0, M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N,
$ INFO )
CALL CHKXER( 'DSYEVR', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DSYEVR( 'V', 'A', 'U', 2, A, 1, 0.0D0, 0.0D0, 1, 1, 0.0D0,
$ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'DSYEVR', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DSYEVR( 'V', 'V', 'U', 1, A, 1, 0.0D0, 0.0D0, 1, 1, 0.0D0,
$ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'DSYEVR', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DSYEVR( 'V', 'I', 'U', 1, A, 1, 0.0D0, 0.0D0, 0, 1, 0.0D0,
$ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'DSYEVR', INFOT, NOUT, LERR, OK )
INFOT = 10
*
CALL DSYEVR( 'V', 'I', 'U', 2, A, 2, 0.0D0, 0.0D0, 2, 1, 0.0D0,
$ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'DSYEVR', INFOT, NOUT, LERR, OK )
INFOT = 15
CALL DSYEVR( 'V', 'I', 'U', 1, A, 1, 0.0D0, 0.0D0, 1, 1, 0.0D0,
$ M, R, Z, 0, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO )
CALL CHKXER( 'DSYEVR', INFOT, NOUT, LERR, OK )
INFOT = 18
CALL DSYEVR( 'V', 'I', 'U', 1, A, 1, 0.0D0, 0.0D0, 1, 1, 0.0D0,
$ M, R, Z, 1, IW, Q, 26*N-1, IW( 2*N+1 ), 10*N,
$ INFO )
CALL CHKXER( 'DSYEVR', INFOT, NOUT, LERR, OK )
INFOT = 20
CALL DSYEVR( 'V', 'I', 'U', 1, A, 1, 0.0D0, 0.0D0, 1, 1, 0.0D0,
$ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N-1,
$ INFO )
CALL CHKXER( 'DSYEVR', INFOT, NOUT, LERR, OK )
NT = NT + 11
*
* DSYEV
*
SRNAMT = 'DSYEV '
INFOT = 1
CALL DSYEV( '/', 'U', 0, A, 1, X, W, 1, INFO )
CALL CHKXER( 'DSYEV ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSYEV( 'N', '/', 0, A, 1, X, W, 1, INFO )
CALL CHKXER( 'DSYEV ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSYEV( 'N', 'U', -1, A, 1, X, W, 1, INFO )
CALL CHKXER( 'DSYEV ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DSYEV( 'N', 'U', 2, A, 1, X, W, 3, INFO )
CALL CHKXER( 'DSYEV ', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DSYEV( 'N', 'U', 1, A, 1, X, W, 1, INFO )
CALL CHKXER( 'DSYEV ', INFOT, NOUT, LERR, OK )
NT = NT + 5
*
* DSYEVX
*
SRNAMT = 'DSYEVX'
INFOT = 1
CALL DSYEVX( '/', 'A', 'U', 0, A, 1, 0.0D0, 0.0D0, 0, 0, 0.0D0,
$ M, X, Z, 1, W, 1, IW, I3, INFO )
CALL CHKXER( 'DSYEVX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSYEVX( 'N', '/', 'U', 0, A, 1, 0.0D0, 1.0D0, 1, 0, 0.0D0,
$ M, X, Z, 1, W, 1, IW, I3, INFO )
CALL CHKXER( 'DSYEVX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSYEVX( 'N', 'A', '/', 0, A, 1, 0.0D0, 0.0D0, 0, 0, 0.0D0,
$ M, X, Z, 1, W, 1, IW, I3, INFO )
INFOT = 4
CALL DSYEVX( 'N', 'A', 'U', -1, A, 1, 0.0D0, 0.0D0, 0, 0,
$ 0.0D0, M, X, Z, 1, W, 1, IW, I3, INFO )
CALL CHKXER( 'DSYEVX', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DSYEVX( 'N', 'A', 'U', 2, A, 1, 0.0D0, 0.0D0, 0, 0, 0.0D0,
$ M, X, Z, 1, W, 16, IW, I3, INFO )
CALL CHKXER( 'DSYEVX', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DSYEVX( 'N', 'V', 'U', 1, A, 1, 0.0D0, 0.0D0, 0, 0, 0.0D0,
$ M, X, Z, 1, W, 8, IW, I3, INFO )
CALL CHKXER( 'DSYEVX', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DSYEVX( 'N', 'I', 'U', 1, A, 1, 0.0D0, 0.0D0, 0, 0, 0.0D0,
$ M, X, Z, 1, W, 8, IW, I3, INFO )
CALL CHKXER( 'DSYEVX', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DSYEVX( 'N', 'I', 'U', 1, A, 1, 0.0D0, 0.0D0, 2, 1, 0.0D0,
$ M, X, Z, 1, W, 8, IW, I3, INFO )
CALL CHKXER( 'DSYEVX', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DSYEVX( 'N', 'I', 'U', 2, A, 2, 0.0D0, 0.0D0, 2, 1, 0.0D0,
$ M, X, Z, 1, W, 16, IW, I3, INFO )
CALL CHKXER( 'DSYEVX', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DSYEVX( 'N', 'I', 'U', 1, A, 1, 0.0D0, 0.0D0, 1, 2, 0.0D0,
$ M, X, Z, 1, W, 8, IW, I3, INFO )
CALL CHKXER( 'DSYEVX', INFOT, NOUT, LERR, OK )
INFOT = 15
CALL DSYEVX( 'V', 'A', 'U', 2, A, 2, 0.0D0, 0.0D0, 0, 0, 0.0D0,
$ M, X, Z, 1, W, 16, IW, I3, INFO )
CALL CHKXER( 'DSYEVX', INFOT, NOUT, LERR, OK )
INFOT = 17
CALL DSYEVX( 'V', 'A', 'U', 1, A, 1, 0.0D0, 0.0D0, 0, 0, 0.0D0,
$ M, X, Z, 1, W, 0, IW, I3, INFO )
CALL CHKXER( 'DSYEVX', INFOT, NOUT, LERR, OK )
NT = NT + 12
*
* DSPEVD
*
SRNAMT = 'DSPEVD'
INFOT = 1
CALL DSPEVD( '/', 'U', 0, A, X, Z, 1, W, 1, IW, 1, INFO )
CALL CHKXER( 'DSPEVD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSPEVD( 'N', '/', 0, A, X, Z, 1, W, 1, IW, 1, INFO )
CALL CHKXER( 'DSPEVD', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSPEVD( 'N', 'U', -1, A, X, Z, 1, W, 1, IW, 1, INFO )
CALL CHKXER( 'DSPEVD', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DSPEVD( 'V', 'U', 2, A, X, Z, 1, W, 23, IW, 12, INFO )
CALL CHKXER( 'DSPEVD', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DSPEVD( 'N', 'U', 1, A, X, Z, 1, W, 0, IW, 1, INFO )
CALL CHKXER( 'DSPEVD', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DSPEVD( 'N', 'U', 2, A, X, Z, 1, W, 3, IW, 1, INFO )
CALL CHKXER( 'DSPEVD', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DSPEVD( 'V', 'U', 2, A, X, Z, 2, W, 16, IW, 12, INFO )
CALL CHKXER( 'DSPEVD', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DSPEVD( 'N', 'U', 1, A, X, Z, 1, W, 1, IW, 0, INFO )
CALL CHKXER( 'DSPEVD', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DSPEVD( 'N', 'U', 2, A, X, Z, 1, W, 4, IW, 0, INFO )
CALL CHKXER( 'DSPEVD', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DSPEVD( 'V', 'U', 2, A, X, Z, 2, W, 23, IW, 11, INFO )
CALL CHKXER( 'DSPEVD', INFOT, NOUT, LERR, OK )
NT = NT + 10
*
* DSPEV
*
SRNAMT = 'DSPEV '
INFOT = 1
CALL DSPEV( '/', 'U', 0, A, W, Z, 1, X, INFO )
CALL CHKXER( 'DSPEV ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSPEV( 'N', '/', 0, A, W, Z, 1, X, INFO )
CALL CHKXER( 'DSPEV ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSPEV( 'N', 'U', -1, A, W, Z, 1, X, INFO )
CALL CHKXER( 'DSPEV ', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DSPEV( 'V', 'U', 2, A, W, Z, 1, X, INFO )
CALL CHKXER( 'DSPEV ', INFOT, NOUT, LERR, OK )
NT = NT + 4
*
* DSPEVX
*
SRNAMT = 'DSPEVX'
INFOT = 1
CALL DSPEVX( '/', 'A', 'U', 0, A, 0.0D0, 0.0D0, 0, 0, 0.0D0, M,
$ X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSPEVX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSPEVX( 'N', '/', 'U', 0, A, 0.0D0, 0.0D0, 0, 0, 0.0D0, M,
$ X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSPEVX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSPEVX( 'N', 'A', '/', 0, A, 0.0D0, 0.0D0, 0, 0, 0.0D0, M,
$ X, Z, 1, W, IW, I3, INFO )
INFOT = 4
CALL DSPEVX( 'N', 'A', 'U', -1, A, 0.0D0, 0.0D0, 0, 0, 0.0D0,
$ M, X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSPEVX', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DSPEVX( 'N', 'V', 'U', 1, A, 0.0D0, 0.0D0, 0, 0, 0.0D0, M,
$ X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSPEVX', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DSPEVX( 'N', 'I', 'U', 1, A, 0.0D0, 0.0D0, 0, 0, 0.0D0, M,
$ X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSPEVX', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DSPEVX( 'N', 'I', 'U', 1, A, 0.0D0, 0.0D0, 2, 1, 0.0D0, M,
$ X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSPEVX', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DSPEVX( 'N', 'I', 'U', 2, A, 0.0D0, 0.0D0, 2, 1, 0.0D0, M,
$ X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSPEVX', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DSPEVX( 'N', 'I', 'U', 1, A, 0.0D0, 0.0D0, 1, 2, 0.0D0, M,
$ X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSPEVX', INFOT, NOUT, LERR, OK )
INFOT = 14
CALL DSPEVX( 'V', 'A', 'U', 2, A, 0.0D0, 0.0D0, 0, 0, 0.0D0, M,
$ X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSPEVX', INFOT, NOUT, LERR, OK )
NT = NT + 10
*
* Test error exits for the SB path.
*
ELSE IF( LSAMEN( 2, C2, 'SB' ) ) THEN
*
* DSBTRD
*
SRNAMT = 'DSBTRD'
INFOT = 1
CALL DSBTRD( '/', 'U', 0, 0, A, 1, D, E, Z, 1, W, INFO )
CALL CHKXER( 'DSBTRD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSBTRD( 'N', '/', 0, 0, A, 1, D, E, Z, 1, W, INFO )
CALL CHKXER( 'DSBTRD', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSBTRD( 'N', 'U', -1, 0, A, 1, D, E, Z, 1, W, INFO )
CALL CHKXER( 'DSBTRD', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DSBTRD( 'N', 'U', 0, -1, A, 1, D, E, Z, 1, W, INFO )
CALL CHKXER( 'DSBTRD', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DSBTRD( 'N', 'U', 1, 1, A, 1, D, E, Z, 1, W, INFO )
CALL CHKXER( 'DSBTRD', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DSBTRD( 'V', 'U', 2, 0, A, 1, D, E, Z, 1, W, INFO )
CALL CHKXER( 'DSBTRD', INFOT, NOUT, LERR, OK )
NT = NT + 6
*
* DSBEVD
*
SRNAMT = 'DSBEVD'
INFOT = 1
CALL DSBEVD( '/', 'U', 0, 0, A, 1, X, Z, 1, W, 1, IW, 1, INFO )
CALL CHKXER( 'DSBEVD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSBEVD( 'N', '/', 0, 0, A, 1, X, Z, 1, W, 1, IW, 1, INFO )
CALL CHKXER( 'DSBEVD', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSBEVD( 'N', 'U', -1, 0, A, 1, X, Z, 1, W, 1, IW, 1,
$ INFO )
CALL CHKXER( 'DSBEVD', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DSBEVD( 'N', 'U', 0, -1, A, 1, X, Z, 1, W, 1, IW, 1,
$ INFO )
CALL CHKXER( 'DSBEVD', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DSBEVD( 'N', 'U', 2, 1, A, 1, X, Z, 1, W, 4, IW, 1, INFO )
CALL CHKXER( 'DSBEVD', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DSBEVD( 'V', 'U', 2, 1, A, 2, X, Z, 1, W, 25, IW, 12,
$ INFO )
CALL CHKXER( 'DSBEVD', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DSBEVD( 'N', 'U', 1, 0, A, 1, X, Z, 1, W, 0, IW, 1, INFO )
CALL CHKXER( 'DSBEVD', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DSBEVD( 'N', 'U', 2, 0, A, 1, X, Z, 1, W, 3, IW, 1, INFO )
CALL CHKXER( 'DSBEVD', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DSBEVD( 'V', 'U', 2, 0, A, 1, X, Z, 2, W, 18, IW, 12,
$ INFO )
CALL CHKXER( 'DSBEVD', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL DSBEVD( 'N', 'U', 1, 0, A, 1, X, Z, 1, W, 1, IW, 0, INFO )
CALL CHKXER( 'DSBEVD', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL DSBEVD( 'V', 'U', 2, 0, A, 1, X, Z, 2, W, 25, IW, 11,
$ INFO )
CALL CHKXER( 'DSBEVD', INFOT, NOUT, LERR, OK )
NT = NT + 11
*
* DSBEV
*
SRNAMT = 'DSBEV '
INFOT = 1
CALL DSBEV( '/', 'U', 0, 0, A, 1, X, Z, 1, W, INFO )
CALL CHKXER( 'DSBEV ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSBEV( 'N', '/', 0, 0, A, 1, X, Z, 1, W, INFO )
CALL CHKXER( 'DSBEV ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSBEV( 'N', 'U', -1, 0, A, 1, X, Z, 1, W, INFO )
CALL CHKXER( 'DSBEV ', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DSBEV( 'N', 'U', 0, -1, A, 1, X, Z, 1, W, INFO )
CALL CHKXER( 'DSBEV ', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DSBEV( 'N', 'U', 2, 1, A, 1, X, Z, 1, W, INFO )
CALL CHKXER( 'DSBEV ', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DSBEV( 'V', 'U', 2, 0, A, 1, X, Z, 1, W, INFO )
CALL CHKXER( 'DSBEV ', INFOT, NOUT, LERR, OK )
NT = NT + 6
*
* DSBEVX
*
SRNAMT = 'DSBEVX'
INFOT = 1
CALL DSBEVX( '/', 'A', 'U', 0, 0, A, 1, Q, 1, 0.0D0, 0.0D0, 0,
$ 0, 0.0D0, M, X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSBEVX', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DSBEVX( 'N', '/', 'U', 0, 0, A, 1, Q, 1, 0.0D0, 0.0D0, 0,
$ 0, 0.0D0, M, X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSBEVX', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DSBEVX( 'N', 'A', '/', 0, 0, A, 1, Q, 1, 0.0D0, 0.0D0, 0,
$ 0, 0.0D0, M, X, Z, 1, W, IW, I3, INFO )
INFOT = 4
CALL DSBEVX( 'N', 'A', 'U', -1, 0, A, 1, Q, 1, 0.0D0, 0.0D0, 0,
$ 0, 0.0D0, M, X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSBEVX', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DSBEVX( 'N', 'A', 'U', 0, -1, A, 1, Q, 1, 0.0D0, 0.0D0, 0,
$ 0, 0.0D0, M, X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSBEVX', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DSBEVX( 'N', 'A', 'U', 2, 1, A, 1, Q, 1, 0.0D0, 0.0D0, 0,
$ 0, 0.0D0, M, X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSBEVX', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DSBEVX( 'V', 'A', 'U', 2, 0, A, 1, Q, 1, 0.0D0, 0.0D0, 0,
$ 0, 0.0D0, M, X, Z, 2, W, IW, I3, INFO )
CALL CHKXER( 'DSBEVX', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DSBEVX( 'N', 'V', 'U', 1, 0, A, 1, Q, 1, 0.0D0, 0.0D0, 0,
$ 0, 0.0D0, M, X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSBEVX', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DSBEVX( 'N', 'I', 'U', 1, 0, A, 1, Q, 1, 0.0D0, 0.0D0, 0,
$ 0, 0.0D0, M, X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSBEVX', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DSBEVX( 'N', 'I', 'U', 1, 0, A, 1, Q, 1, 0.0D0, 0.0D0, 2,
$ 1, 0.0D0, M, X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSBEVX', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL DSBEVX( 'N', 'I', 'U', 2, 0, A, 1, Q, 1, 0.0D0, 0.0D0, 2,
$ 1, 0.0D0, M, X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSBEVX', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL DSBEVX( 'N', 'I', 'U', 1, 0, A, 1, Q, 1, 0.0D0, 0.0D0, 1,
$ 2, 0.0D0, M, X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSBEVX', INFOT, NOUT, LERR, OK )
INFOT = 18
CALL DSBEVX( 'V', 'A', 'U', 2, 0, A, 1, Q, 2, 0.0D0, 0.0D0, 0,
$ 0, 0.0D0, M, X, Z, 1, W, IW, I3, INFO )
CALL CHKXER( 'DSBEVX', INFOT, NOUT, LERR, OK )
NT = NT + 13
END IF
*
* Print a summary line.
*
IF( OK ) THEN
WRITE( NOUT, FMT = 9999 )PATH, NT
ELSE
WRITE( NOUT, FMT = 9998 )PATH
END IF
*
9999 FORMAT( 1X, A3, ' routines passed the tests of the error exits',
$ ' (', I3, ' tests done)' )
9998 FORMAT( ' *** ', A3, ' routines failed the tests of the error ',
$ 'exits ***' )
*
RETURN
*
* End of DERRST
*
END
SUBROUTINE DGET02( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB,
$ RWORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER LDA, LDB, LDX, M, N, NRHS
DOUBLE PRECISION RESID
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), RWORK( * ),
$ X( LDX, * )
* ..
*
* Purpose
* =======
*
* DGET02 computes the residual for a solution of a system of linear
* equations A*x = b or A'*x = b:
* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ),
* where EPS is the machine epsilon.
*
* Arguments
* =========
*
* TRANS (input) CHARACTER*1
* Specifies the form of the system of equations:
* = 'N': A *x = b
* = 'T': A'*x = b, where A' is the transpose of A
* = 'C': A'*x = b, where A' is the transpose of A
*
* 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.
*
* NRHS (input) INTEGER
* The number of columns of B, the matrix of right hand sides.
* NRHS >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The original M x N matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
* The computed solution vectors for the system of linear
* equations.
*
* LDX (input) INTEGER
* The leading dimension of the array X. If TRANS = 'N',
* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the right hand side vectors for the system of
* linear equations.
* On exit, B is overwritten with the difference B - A*X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. IF TRANS = 'N',
* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N).
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (M)
*
* RESID (output) DOUBLE PRECISION
* The maximum over the number of right hand sides of
* norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER J, N1, N2
DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DASUM, DLAMCH, DLANGE
EXTERNAL LSAME, DASUM, DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DGEMM
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Quick exit if M = 0 or N = 0 or NRHS = 0
*
IF( M.LE.0 .OR. N.LE.0 .OR. NRHS.EQ.0 ) THEN
RESID = ZERO
RETURN
END IF
*
IF( LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) ) THEN
N1 = N
N2 = M
ELSE
N1 = M
N2 = N
END IF
*
* Exit with RESID = 1/EPS if ANORM = 0.
*
EPS = DLAMCH( 'Epsilon' )
ANORM = DLANGE( '1', N1, N2, A, LDA, RWORK )
IF( ANORM.LE.ZERO ) THEN
RESID = ONE / EPS
RETURN
END IF
*
* Compute B - A*X (or B - A'*X ) and store in B.
*
CALL DGEMM( TRANS, 'No transpose', N1, NRHS, N2, -ONE, A, LDA, X,
$ LDX, ONE, B, LDB )
*
* Compute the maximum over the number of right hand sides of
* norm(B - A*X) / ( norm(A) * norm(X) * EPS ) .
*
RESID = ZERO
DO 10 J = 1, NRHS
BNORM = DASUM( N1, B( 1, J ), 1 )
XNORM = DASUM( N2, X( 1, J ), 1 )
IF( XNORM.LE.ZERO ) THEN
RESID = ONE / EPS
ELSE
RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) / EPS )
END IF
10 CONTINUE
*
RETURN
*
* End of DGET02
*
END
SUBROUTINE DGET10( M, N, A, LDA, B, LDB, WORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDB, M, N
DOUBLE PRECISION RESULT
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGET10 compares two matrices A and B and computes the ratio
* RESULT = norm( A - B ) / ( norm(A) * M * EPS )
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrices A and B.
*
* N (input) INTEGER
* The number of columns of the matrices A and B.
*
* 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).
*
* B (input) DOUBLE PRECISION array, dimension (LDB,N)
* The m by n matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,M).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (M)
*
* RESULT (output) DOUBLE PRECISION
* RESULT = norm( A - B ) / ( norm(A) * M * EPS )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER J
DOUBLE PRECISION ANORM, EPS, UNFL, WNORM
* ..
* .. External Functions ..
DOUBLE PRECISION DASUM, DLAMCH, DLANGE
EXTERNAL DASUM, DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 ) THEN
RESULT = ZERO
RETURN
END IF
*
UNFL = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
*
WNORM = ZERO
DO 10 J = 1, N
CALL DCOPY( M, A( 1, J ), 1, WORK, 1 )
CALL DAXPY( M, -ONE, B( 1, J ), 1, WORK, 1 )
WNORM = MAX( WNORM, DASUM( N, WORK, 1 ) )
10 CONTINUE
*
ANORM = MAX( DLANGE( '1', M, N, A, LDA, WORK ), UNFL )
*
IF( ANORM.GT.WNORM ) THEN
RESULT = ( WNORM / ANORM ) / ( M*EPS )
ELSE
IF( ANORM.LT.ONE ) THEN
RESULT = ( MIN( WNORM, M*ANORM ) / ANORM ) / ( M*EPS )
ELSE
RESULT = MIN( WNORM / ANORM, DBLE( M ) ) / ( M*EPS )
END IF
END IF
*
RETURN
*
* End of DGET10
*
END
SUBROUTINE DGET22( TRANSA, TRANSE, TRANSW, N, A, LDA, E, LDE, WR,
$ WI, WORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANSA, TRANSE, TRANSW
INTEGER LDA, LDE, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), E( LDE, * ), RESULT( 2 ), WI( * ),
$ WORK( * ), WR( * )
* ..
*
* Purpose
* =======
*
* DGET22 does an eigenvector check.
*
* The basic test is:
*
* RESULT(1) = | A E - E W | / ( |A| |E| ulp )
*
* using the 1-norm. It also tests the normalization of E:
*
* RESULT(2) = max | m-norm(E(j)) - 1 | / ( n ulp )
* j
*
* where E(j) is the j-th eigenvector, and m-norm is the max-norm of a
* vector. If an eigenvector is complex, as determined from WI(j)
* nonzero, then the max-norm of the vector ( er + i*ei ) is the maximum
* of
* |er(1)| + |ei(1)|, ... , |er(n)| + |ei(n)|
*
* W is a block diagonal matrix, with a 1 by 1 block for each real
* eigenvalue and a 2 by 2 block for each complex conjugate pair.
* If eigenvalues j and j+1 are a complex conjugate pair, so that
* WR(j) = WR(j+1) = wr and WI(j) = - WI(j+1) = wi, then the 2 by 2
* block corresponding to the pair will be:
*
* ( wr wi )
* ( -wi wr )
*
* Such a block multiplying an n by 2 matrix ( ur ui ) on the right
* will be the same as multiplying ur + i*ui by wr + i*wi.
*
* To handle various schemes for storage of left eigenvectors, there are
* options to use A-transpose instead of A, E-transpose instead of E,
* and/or W-transpose instead of W.
*
* Arguments
* ==========
*
* TRANSA (input) CHARACTER*1
* Specifies whether or not A is transposed.
* = 'N': No transpose
* = 'T': Transpose
* = 'C': Conjugate transpose (= Transpose)
*
* TRANSE (input) CHARACTER*1
* Specifies whether or not E is transposed.
* = 'N': No transpose, eigenvectors are in columns of E
* = 'T': Transpose, eigenvectors are in rows of E
* = 'C': Conjugate transpose (= Transpose)
*
* TRANSW (input) CHARACTER*1
* Specifies whether or not W is transposed.
* = 'N': No transpose
* = 'T': Transpose, use -WI(j) instead of WI(j)
* = 'C': Conjugate transpose, use -WI(j) instead of WI(j)
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The matrix whose eigenvectors are in E.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* E (input) DOUBLE PRECISION array, dimension (LDE,N)
* The matrix of eigenvectors. If TRANSE = 'N', the eigenvectors
* are stored in the columns of E, if TRANSE = 'T' or 'C', the
* eigenvectors are stored in the rows of E.
*
* LDE (input) INTEGER
* The leading dimension of the array E. LDE >= max(1,N).
*
* WR (input) DOUBLE PRECISION array, dimension (N)
* WI (input) DOUBLE PRECISION array, dimension (N)
* The real and imaginary parts of the eigenvalues of A.
* Purely real eigenvalues are indicated by WI(j) = 0.
* Complex conjugate pairs are indicated by WR(j)=WR(j+1) and
* WI(j) = - WI(j+1) non-zero; the real part is assumed to be
* stored in the j-th row/column and the imaginary part in
* the (j+1)-th row/column.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (N*(N+1))
*
* RESULT (output) DOUBLE PRECISION array, dimension (2)
* RESULT(1) = | A E - E W | / ( |A| |E| ulp )
* RESULT(2) = max | m-norm(E(j)) - 1 | / ( n ulp )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
CHARACTER NORMA, NORME
INTEGER IECOL, IEROW, INCE, IPAIR, ITRNSE, J, JCOL,
$ JVEC
DOUBLE PRECISION ANORM, ENORM, ENRMAX, ENRMIN, ERRNRM, TEMP1,
$ ULP, UNFL
* ..
* .. Local Arrays ..
DOUBLE PRECISION WMAT( 2, 2 )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL LSAME, DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DGEMM, DLASET
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
* Initialize RESULT (in case N=0)
*
RESULT( 1 ) = ZERO
RESULT( 2 ) = ZERO
IF( N.LE.0 )
$ RETURN
*
UNFL = DLAMCH( 'Safe minimum' )
ULP = DLAMCH( 'Precision' )
*
ITRNSE = 0
INCE = 1
NORMA = 'O'
NORME = 'O'
*
IF( LSAME( TRANSA, 'T' ) .OR. LSAME( TRANSA, 'C' ) ) THEN
NORMA = 'I'
END IF
IF( LSAME( TRANSE, 'T' ) .OR. LSAME( TRANSE, 'C' ) ) THEN
NORME = 'I'
ITRNSE = 1
INCE = LDE
END IF
*
* Check normalization of E
*
ENRMIN = ONE / ULP
ENRMAX = ZERO
IF( ITRNSE.EQ.0 ) THEN
*
* Eigenvectors are column vectors.
*
IPAIR = 0
DO 30 JVEC = 1, N
TEMP1 = ZERO
IF( IPAIR.EQ.0 .AND. JVEC.LT.N .AND. WI( JVEC ).NE.ZERO )
$ IPAIR = 1
IF( IPAIR.EQ.1 ) THEN
*
* Complex eigenvector
*
DO 10 J = 1, N
TEMP1 = MAX( TEMP1, ABS( E( J, JVEC ) )+
$ ABS( E( J, JVEC+1 ) ) )
10 CONTINUE
ENRMIN = MIN( ENRMIN, TEMP1 )
ENRMAX = MAX( ENRMAX, TEMP1 )
IPAIR = 2
ELSE IF( IPAIR.EQ.2 ) THEN
IPAIR = 0
ELSE
*
* Real eigenvector
*
DO 20 J = 1, N
TEMP1 = MAX( TEMP1, ABS( E( J, JVEC ) ) )
20 CONTINUE
ENRMIN = MIN( ENRMIN, TEMP1 )
ENRMAX = MAX( ENRMAX, TEMP1 )
IPAIR = 0
END IF
30 CONTINUE
*
ELSE
*
* Eigenvectors are row vectors.
*
DO 40 JVEC = 1, N
WORK( JVEC ) = ZERO
40 CONTINUE
*
DO 60 J = 1, N
IPAIR = 0
DO 50 JVEC = 1, N
IF( IPAIR.EQ.0 .AND. JVEC.LT.N .AND. WI( JVEC ).NE.ZERO )
$ IPAIR = 1
IF( IPAIR.EQ.1 ) THEN
WORK( JVEC ) = MAX( WORK( JVEC ),
$ ABS( E( J, JVEC ) )+ABS( E( J,
$ JVEC+1 ) ) )
WORK( JVEC+1 ) = WORK( JVEC )
ELSE IF( IPAIR.EQ.2 ) THEN
IPAIR = 0
ELSE
WORK( JVEC ) = MAX( WORK( JVEC ),
$ ABS( E( J, JVEC ) ) )
IPAIR = 0
END IF
50 CONTINUE
60 CONTINUE
*
DO 70 JVEC = 1, N
ENRMIN = MIN( ENRMIN, WORK( JVEC ) )
ENRMAX = MAX( ENRMAX, WORK( JVEC ) )
70 CONTINUE
END IF
*
* Norm of A:
*
ANORM = MAX( DLANGE( NORMA, N, N, A, LDA, WORK ), UNFL )
*
* Norm of E:
*
ENORM = MAX( DLANGE( NORME, N, N, E, LDE, WORK ), ULP )
*
* Norm of error:
*
* Error = AE - EW
*
CALL DLASET( 'Full', N, N, ZERO, ZERO, WORK, N )
*
IPAIR = 0
IEROW = 1
IECOL = 1
*
DO 80 JCOL = 1, N
IF( ITRNSE.EQ.1 ) THEN
IEROW = JCOL
ELSE
IECOL = JCOL
END IF
*
IF( IPAIR.EQ.0 .AND. WI( JCOL ).NE.ZERO )
$ IPAIR = 1
*
IF( IPAIR.EQ.1 ) THEN
WMAT( 1, 1 ) = WR( JCOL )
WMAT( 2, 1 ) = -WI( JCOL )
WMAT( 1, 2 ) = WI( JCOL )
WMAT( 2, 2 ) = WR( JCOL )
CALL DGEMM( TRANSE, TRANSW, N, 2, 2, ONE, E( IEROW, IECOL ),
$ LDE, WMAT, 2, ZERO, WORK( N*( JCOL-1 )+1 ), N )
IPAIR = 2
ELSE IF( IPAIR.EQ.2 ) THEN
IPAIR = 0
*
ELSE
*
CALL DAXPY( N, WR( JCOL ), E( IEROW, IECOL ), INCE,
$ WORK( N*( JCOL-1 )+1 ), 1 )
IPAIR = 0
END IF
*
80 CONTINUE
*
CALL DGEMM( TRANSA, TRANSE, N, N, N, ONE, A, LDA, E, LDE, -ONE,
$ WORK, N )
*
ERRNRM = DLANGE( 'One', N, N, WORK, N, WORK( N*N+1 ) ) / ENORM
*
* Compute RESULT(1) (avoiding under/overflow)
*
IF( ANORM.GT.ERRNRM ) THEN
RESULT( 1 ) = ( ERRNRM / ANORM ) / ULP
ELSE
IF( ANORM.LT.ONE ) THEN
RESULT( 1 ) = ( MIN( ERRNRM, ANORM ) / ANORM ) / ULP
ELSE
RESULT( 1 ) = MIN( ERRNRM / ANORM, ONE ) / ULP
END IF
END IF
*
* Compute RESULT(2) : the normalization error in E.
*
RESULT( 2 ) = MAX( ABS( ENRMAX-ONE ), ABS( ENRMIN-ONE ) ) /
$ ( DBLE( N )*ULP )
*
RETURN
*
* End of DGET22
*
END
SUBROUTINE DGET23( COMP, BALANC, JTYPE, THRESH, ISEED, NOUNIT, N,
$ A, LDA, H, WR, WI, WR1, WI1, VL, LDVL, VR,
$ LDVR, LRE, LDLRE, RCONDV, RCNDV1, RCDVIN,
$ RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1, RESULT,
$ WORK, LWORK, IWORK, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL COMP
CHARACTER BALANC
INTEGER INFO, JTYPE, LDA, LDLRE, LDVL, LDVR, LWORK, N,
$ NOUNIT
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 ), IWORK( * )
DOUBLE PRECISION A( LDA, * ), H( LDA, * ), LRE( LDLRE, * ),
$ RCDEIN( * ), RCDVIN( * ), RCNDE1( * ),
$ RCNDV1( * ), RCONDE( * ), RCONDV( * ),
$ RESULT( 11 ), SCALE( * ), SCALE1( * ),
$ VL( LDVL, * ), VR( LDVR, * ), WI( * ),
$ WI1( * ), WORK( * ), WR( * ), WR1( * )
* ..
*
* Purpose
* =======
*
* DGET23 checks the nonsymmetric eigenvalue problem driver SGEEVX.
* If COMP = .FALSE., the first 8 of the following tests will be
* performed on the input matrix A, and also test 9 if LWORK is
* sufficiently large.
* if COMP is .TRUE. all 11 tests will be performed.
*
* (1) | A * VR - VR * W | / ( n |A| ulp )
*
* Here VR is the matrix of unit right eigenvectors.
* W is a block diagonal matrix, with a 1x1 block for each
* real eigenvalue and a 2x2 block for each complex conjugate
* pair. If eigenvalues j and j+1 are a complex conjugate pair,
* so WR(j) = WR(j+1) = wr and WI(j) = - WI(j+1) = wi, then the
* 2 x 2 block corresponding to the pair will be:
*
* ( wr wi )
* ( -wi wr )
*
* Such a block multiplying an n x 2 matrix ( ur ui ) on the
* right will be the same as multiplying ur + i*ui by wr + i*wi.
*
* (2) | A**H * VL - VL * W**H | / ( n |A| ulp )
*
* Here VL is the matrix of unit left eigenvectors, A**H is the
* conjugate transpose of A, and W is as above.
*
* (3) | |VR(i)| - 1 | / ulp and largest component real
*
* VR(i) denotes the i-th column of VR.
*
* (4) | |VL(i)| - 1 | / ulp and largest component real
*
* VL(i) denotes the i-th column of VL.
*
* (5) 0 if W(full) = W(partial), 1/ulp otherwise
*
* W(full) denotes the eigenvalues computed when VR, VL, RCONDV
* and RCONDE are also computed, and W(partial) denotes the
* eigenvalues computed when only some of VR, VL, RCONDV, and
* RCONDE are computed.
*
* (6) 0 if VR(full) = VR(partial), 1/ulp otherwise
*
* VR(full) denotes the right eigenvectors computed when VL, RCONDV
* and RCONDE are computed, and VR(partial) denotes the result
* when only some of VL and RCONDV are computed.
*
* (7) 0 if VL(full) = VL(partial), 1/ulp otherwise
*
* VL(full) denotes the left eigenvectors computed when VR, RCONDV
* and RCONDE are computed, and VL(partial) denotes the result
* when only some of VR and RCONDV are computed.
*
* (8) 0 if SCALE, ILO, IHI, ABNRM (full) =
* SCALE, ILO, IHI, ABNRM (partial)
* 1/ulp otherwise
*
* SCALE, ILO, IHI and ABNRM describe how the matrix is balanced.
* (full) is when VR, VL, RCONDE and RCONDV are also computed, and
* (partial) is when some are not computed.
*
* (9) 0 if RCONDV(full) = RCONDV(partial), 1/ulp otherwise
*
* RCONDV(full) denotes the reciprocal condition numbers of the
* right eigenvectors computed when VR, VL and RCONDE are also
* computed. RCONDV(partial) denotes the reciprocal condition
* numbers when only some of VR, VL and RCONDE are computed.
*
* (10) |RCONDV - RCDVIN| / cond(RCONDV)
*
* RCONDV is the reciprocal right eigenvector condition number
* computed by DGEEVX and RCDVIN (the precomputed true value)
* is supplied as input. cond(RCONDV) is the condition number of
* RCONDV, and takes errors in computing RCONDV into account, so
* that the resulting quantity should be O(ULP). cond(RCONDV) is
* essentially given by norm(A)/RCONDE.
*
* (11) |RCONDE - RCDEIN| / cond(RCONDE)
*
* RCONDE is the reciprocal eigenvalue condition number
* computed by DGEEVX and RCDEIN (the precomputed true value)
* is supplied as input. cond(RCONDE) is the condition number
* of RCONDE, and takes errors in computing RCONDE into account,
* so that the resulting quantity should be O(ULP). cond(RCONDE)
* is essentially given by norm(A)/RCONDV.
*
* Arguments
* =========
*
* COMP (input) LOGICAL
* COMP describes which input tests to perform:
* = .FALSE. if the computed condition numbers are not to
* be tested against RCDVIN and RCDEIN
* = .TRUE. if they are to be compared
*
* BALANC (input) CHARACTER
* Describes the balancing option to be tested.
* = 'N' for no permuting or diagonal scaling
* = 'P' for permuting but no diagonal scaling
* = 'S' for no permuting but diagonal scaling
* = 'B' for permuting and diagonal scaling
*
* JTYPE (input) INTEGER
* Type of input matrix. Used to label output if error occurs.
*
* THRESH (input) DOUBLE PRECISION
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error
* is scaled to be O(1), so THRESH should be a reasonably
* small multiple of 1, e.g., 10 or 100. In particular,
* it should not depend on the precision (single vs. double)
* or the size of the matrix. It must be at least zero.
*
* ISEED (input) INTEGER array, dimension (4)
* If COMP = .FALSE., the random number generator seed
* used to produce matrix.
* If COMP = .TRUE., ISEED(1) = the number of the example.
* Used to label output if error occurs.
*
* NOUNIT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns INFO not equal to 0.)
*
* N (input) INTEGER
* The dimension of A. N must be at least 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* Used to hold the matrix whose eigenvalues are to be
* computed.
*
* LDA (input) INTEGER
* The leading dimension of A, and H. LDA must be at
* least 1 and at least N.
*
* H (workspace) DOUBLE PRECISION array, dimension (LDA,N)
* Another copy of the test matrix A, modified by DGEEVX.
*
* WR (workspace) DOUBLE PRECISION array, dimension (N)
* WI (workspace) DOUBLE PRECISION array, dimension (N)
* The real and imaginary parts of the eigenvalues of A.
* On exit, WR + WI*i are the eigenvalues of the matrix in A.
*
* WR1 (workspace) DOUBLE PRECISION array, dimension (N)
* WI1 (workspace) DOUBLE PRECISION array, dimension (N)
* Like WR, WI, these arrays contain the eigenvalues of A,
* but those computed when DGEEVX only computes a partial
* eigendecomposition, i.e. not the eigenvalues and left
* and right eigenvectors.
*
* VL (workspace) DOUBLE PRECISION array, dimension (LDVL,N)
* VL holds the computed left eigenvectors.
*
* LDVL (input) INTEGER
* Leading dimension of VL. Must be at least max(1,N).
*
* VR (workspace) DOUBLE PRECISION array, dimension (LDVR,N)
* VR holds the computed right eigenvectors.
*
* LDVR (input) INTEGER
* Leading dimension of VR. Must be at least max(1,N).
*
* LRE (workspace) DOUBLE PRECISION array, dimension (LDLRE,N)
* LRE holds the computed right or left eigenvectors.
*
* LDLRE (input) INTEGER
* Leading dimension of LRE. Must be at least max(1,N).
*
* RCONDV (workspace) DOUBLE PRECISION array, dimension (N)
* RCONDV holds the computed reciprocal condition numbers
* for eigenvectors.
*
* RCNDV1 (workspace) DOUBLE PRECISION array, dimension (N)
* RCNDV1 holds more computed reciprocal condition numbers
* for eigenvectors.
*
* RCDVIN (input) DOUBLE PRECISION array, dimension (N)
* When COMP = .TRUE. RCDVIN holds the precomputed reciprocal
* condition numbers for eigenvectors to be compared with
* RCONDV.
*
* RCONDE (workspace) DOUBLE PRECISION array, dimension (N)
* RCONDE holds the computed reciprocal condition numbers
* for eigenvalues.
*
* RCNDE1 (workspace) DOUBLE PRECISION array, dimension (N)
* RCNDE1 holds more computed reciprocal condition numbers
* for eigenvalues.
*
* RCDEIN (input) DOUBLE PRECISION array, dimension (N)
* When COMP = .TRUE. RCDEIN holds the precomputed reciprocal
* condition numbers for eigenvalues to be compared with
* RCONDE.
*
* SCALE (workspace) DOUBLE PRECISION array, dimension (N)
* Holds information describing balancing of matrix.
*
* SCALE1 (workspace) DOUBLE PRECISION array, dimension (N)
* Holds information describing balancing of matrix.
*
* RESULT (output) DOUBLE PRECISION array, dimension (11)
* The values computed by the 11 tests described above.
* The values are currently limited to 1/ulp, to avoid
* overflow.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The number of entries in WORK. This must be at least
* 3*N, and 6*N+N**2 if tests 9, 10 or 11 are to be performed.
*
* IWORK (workspace) INTEGER array, dimension (2*N)
*
* INFO (output) INTEGER
* If 0, successful exit.
* If <0, input parameter -INFO had an incorrect value.
* If >0, DGEEVX returned an error code, the absolute
* value of which is returned.
*
* =====================================================================
*
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
DOUBLE PRECISION EPSIN
PARAMETER ( EPSIN = 5.9605D-8 )
* ..
* .. Local Scalars ..
LOGICAL BALOK, NOBAL
CHARACTER SENSE
INTEGER I, IHI, IHI1, IINFO, ILO, ILO1, ISENS, ISENSM,
$ J, JJ, KMIN
DOUBLE PRECISION ABNRM, ABNRM1, EPS, SMLNUM, TNRM, TOL, TOLIN,
$ ULP, ULPINV, V, VIMIN, VMAX, VMX, VRMIN, VRMX,
$ VTST
* ..
* .. Local Arrays ..
CHARACTER SENS( 2 )
DOUBLE PRECISION DUM( 1 ), RES( 2 )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2
EXTERNAL LSAME, DLAMCH, DLAPY2, DNRM2
* ..
* .. External Subroutines ..
EXTERNAL DGEEVX, DGET22, DLACPY, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN
* ..
* .. Data statements ..
DATA SENS / 'N', 'V' /
* ..
* .. Executable Statements ..
*
* Check for errors
*
NOBAL = LSAME( BALANC, 'N' )
BALOK = NOBAL .OR. LSAME( BALANC, 'P' ) .OR.
$ LSAME( BALANC, 'S' ) .OR. LSAME( BALANC, 'B' )
INFO = 0
IF( .NOT.BALOK ) THEN
INFO = -2
ELSE IF( THRESH.LT.ZERO ) THEN
INFO = -4
ELSE IF( NOUNIT.LE.0 ) THEN
INFO = -6
ELSE IF( N.LT.0 ) THEN
INFO = -7
ELSE IF( LDA.LT.1 .OR. LDA.LT.N ) THEN
INFO = -9
ELSE IF( LDVL.LT.1 .OR. LDVL.LT.N ) THEN
INFO = -16
ELSE IF( LDVR.LT.1 .OR. LDVR.LT.N ) THEN
INFO = -18
ELSE IF( LDLRE.LT.1 .OR. LDLRE.LT.N ) THEN
INFO = -20
ELSE IF( LWORK.LT.3*N .OR. ( COMP .AND. LWORK.LT.6*N+N*N ) ) THEN
INFO = -31
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGET23', -INFO )
RETURN
END IF
*
* Quick return if nothing to do
*
DO 10 I = 1, 11
RESULT( I ) = -ONE
10 CONTINUE
*
IF( N.EQ.0 )
$ RETURN
*
* More Important constants
*
ULP = DLAMCH( 'Precision' )
SMLNUM = DLAMCH( 'S' )
ULPINV = ONE / ULP
*
* Compute eigenvalues and eigenvectors, and test them
*
IF( LWORK.GE.6*N+N*N ) THEN
SENSE = 'B'
ISENSM = 2
ELSE
SENSE = 'E'
ISENSM = 1
END IF
CALL DLACPY( 'F', N, N, A, LDA, H, LDA )
CALL DGEEVX( BALANC, 'V', 'V', SENSE, N, H, LDA, WR, WI, VL, LDVL,
$ VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV,
$ WORK, LWORK, IWORK, IINFO )
IF( IINFO.NE.0 ) THEN
RESULT( 1 ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'DGEEVX1', IINFO, N, JTYPE,
$ BALANC, ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'DGEEVX1', IINFO, N, ISEED( 1 )
END IF
INFO = ABS( IINFO )
RETURN
END IF
*
* Do Test (1)
*
CALL DGET22( 'N', 'N', 'N', N, A, LDA, VR, LDVR, WR, WI, WORK,
$ RES )
RESULT( 1 ) = RES( 1 )
*
* Do Test (2)
*
CALL DGET22( 'T', 'N', 'T', N, A, LDA, VL, LDVL, WR, WI, WORK,
$ RES )
RESULT( 2 ) = RES( 1 )
*
* Do Test (3)
*
DO 30 J = 1, N
TNRM = ONE
IF( WI( J ).EQ.ZERO ) THEN
TNRM = DNRM2( N, VR( 1, J ), 1 )
ELSE IF( WI( J ).GT.ZERO ) THEN
TNRM = DLAPY2( DNRM2( N, VR( 1, J ), 1 ),
$ DNRM2( N, VR( 1, J+1 ), 1 ) )
END IF
RESULT( 3 ) = MAX( RESULT( 3 ),
$ MIN( ULPINV, ABS( TNRM-ONE ) / ULP ) )
IF( WI( J ).GT.ZERO ) THEN
VMX = ZERO
VRMX = ZERO
DO 20 JJ = 1, N
VTST = DLAPY2( VR( JJ, J ), VR( JJ, J+1 ) )
IF( VTST.GT.VMX )
$ VMX = VTST
IF( VR( JJ, J+1 ).EQ.ZERO .AND. ABS( VR( JJ, J ) ).GT.
$ VRMX )VRMX = ABS( VR( JJ, J ) )
20 CONTINUE
IF( VRMX / VMX.LT.ONE-TWO*ULP )
$ RESULT( 3 ) = ULPINV
END IF
30 CONTINUE
*
* Do Test (4)
*
DO 50 J = 1, N
TNRM = ONE
IF( WI( J ).EQ.ZERO ) THEN
TNRM = DNRM2( N, VL( 1, J ), 1 )
ELSE IF( WI( J ).GT.ZERO ) THEN
TNRM = DLAPY2( DNRM2( N, VL( 1, J ), 1 ),
$ DNRM2( N, VL( 1, J+1 ), 1 ) )
END IF
RESULT( 4 ) = MAX( RESULT( 4 ),
$ MIN( ULPINV, ABS( TNRM-ONE ) / ULP ) )
IF( WI( J ).GT.ZERO ) THEN
VMX = ZERO
VRMX = ZERO
DO 40 JJ = 1, N
VTST = DLAPY2( VL( JJ, J ), VL( JJ, J+1 ) )
IF( VTST.GT.VMX )
$ VMX = VTST
IF( VL( JJ, J+1 ).EQ.ZERO .AND. ABS( VL( JJ, J ) ).GT.
$ VRMX )VRMX = ABS( VL( JJ, J ) )
40 CONTINUE
IF( VRMX / VMX.LT.ONE-TWO*ULP )
$ RESULT( 4 ) = ULPINV
END IF
50 CONTINUE
*
* Test for all options of computing condition numbers
*
DO 200 ISENS = 1, ISENSM
*
SENSE = SENS( ISENS )
*
* Compute eigenvalues only, and test them
*
CALL DLACPY( 'F', N, N, A, LDA, H, LDA )
CALL DGEEVX( BALANC, 'N', 'N', SENSE, N, H, LDA, WR1, WI1, DUM,
$ 1, DUM, 1, ILO1, IHI1, SCALE1, ABNRM1, RCNDE1,
$ RCNDV1, WORK, LWORK, IWORK, IINFO )
IF( IINFO.NE.0 ) THEN
RESULT( 1 ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'DGEEVX2', IINFO, N, JTYPE,
$ BALANC, ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'DGEEVX2', IINFO, N,
$ ISEED( 1 )
END IF
INFO = ABS( IINFO )
GO TO 190
END IF
*
* Do Test (5)
*
DO 60 J = 1, N
IF( WR( J ).NE.WR1( J ) .OR. WI( J ).NE.WI1( J ) )
$ RESULT( 5 ) = ULPINV
60 CONTINUE
*
* Do Test (8)
*
IF( .NOT.NOBAL ) THEN
DO 70 J = 1, N
IF( SCALE( J ).NE.SCALE1( J ) )
$ RESULT( 8 ) = ULPINV
70 CONTINUE
IF( ILO.NE.ILO1 )
$ RESULT( 8 ) = ULPINV
IF( IHI.NE.IHI1 )
$ RESULT( 8 ) = ULPINV
IF( ABNRM.NE.ABNRM1 )
$ RESULT( 8 ) = ULPINV
END IF
*
* Do Test (9)
*
IF( ISENS.EQ.2 .AND. N.GT.1 ) THEN
DO 80 J = 1, N
IF( RCONDV( J ).NE.RCNDV1( J ) )
$ RESULT( 9 ) = ULPINV
80 CONTINUE
END IF
*
* Compute eigenvalues and right eigenvectors, and test them
*
CALL DLACPY( 'F', N, N, A, LDA, H, LDA )
CALL DGEEVX( BALANC, 'N', 'V', SENSE, N, H, LDA, WR1, WI1, DUM,
$ 1, LRE, LDLRE, ILO1, IHI1, SCALE1, ABNRM1, RCNDE1,
$ RCNDV1, WORK, LWORK, IWORK, IINFO )
IF( IINFO.NE.0 ) THEN
RESULT( 1 ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'DGEEVX3', IINFO, N, JTYPE,
$ BALANC, ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'DGEEVX3', IINFO, N,
$ ISEED( 1 )
END IF
INFO = ABS( IINFO )
GO TO 190
END IF
*
* Do Test (5) again
*
DO 90 J = 1, N
IF( WR( J ).NE.WR1( J ) .OR. WI( J ).NE.WI1( J ) )
$ RESULT( 5 ) = ULPINV
90 CONTINUE
*
* Do Test (6)
*
DO 110 J = 1, N
DO 100 JJ = 1, N
IF( VR( J, JJ ).NE.LRE( J, JJ ) )
$ RESULT( 6 ) = ULPINV
100 CONTINUE
110 CONTINUE
*
* Do Test (8) again
*
IF( .NOT.NOBAL ) THEN
DO 120 J = 1, N
IF( SCALE( J ).NE.SCALE1( J ) )
$ RESULT( 8 ) = ULPINV
120 CONTINUE
IF( ILO.NE.ILO1 )
$ RESULT( 8 ) = ULPINV
IF( IHI.NE.IHI1 )
$ RESULT( 8 ) = ULPINV
IF( ABNRM.NE.ABNRM1 )
$ RESULT( 8 ) = ULPINV
END IF
*
* Do Test (9) again
*
IF( ISENS.EQ.2 .AND. N.GT.1 ) THEN
DO 130 J = 1, N
IF( RCONDV( J ).NE.RCNDV1( J ) )
$ RESULT( 9 ) = ULPINV
130 CONTINUE
END IF
*
* Compute eigenvalues and left eigenvectors, and test them
*
CALL DLACPY( 'F', N, N, A, LDA, H, LDA )
CALL DGEEVX( BALANC, 'V', 'N', SENSE, N, H, LDA, WR1, WI1, LRE,
$ LDLRE, DUM, 1, ILO1, IHI1, SCALE1, ABNRM1, RCNDE1,
$ RCNDV1, WORK, LWORK, IWORK, IINFO )
IF( IINFO.NE.0 ) THEN
RESULT( 1 ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'DGEEVX4', IINFO, N, JTYPE,
$ BALANC, ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'DGEEVX4', IINFO, N,
$ ISEED( 1 )
END IF
INFO = ABS( IINFO )
GO TO 190
END IF
*
* Do Test (5) again
*
DO 140 J = 1, N
IF( WR( J ).NE.WR1( J ) .OR. WI( J ).NE.WI1( J ) )
$ RESULT( 5 ) = ULPINV
140 CONTINUE
*
* Do Test (7)
*
DO 160 J = 1, N
DO 150 JJ = 1, N
IF( VL( J, JJ ).NE.LRE( J, JJ ) )
$ RESULT( 7 ) = ULPINV
150 CONTINUE
160 CONTINUE
*
* Do Test (8) again
*
IF( .NOT.NOBAL ) THEN
DO 170 J = 1, N
IF( SCALE( J ).NE.SCALE1( J ) )
$ RESULT( 8 ) = ULPINV
170 CONTINUE
IF( ILO.NE.ILO1 )
$ RESULT( 8 ) = ULPINV
IF( IHI.NE.IHI1 )
$ RESULT( 8 ) = ULPINV
IF( ABNRM.NE.ABNRM1 )
$ RESULT( 8 ) = ULPINV
END IF
*
* Do Test (9) again
*
IF( ISENS.EQ.2 .AND. N.GT.1 ) THEN
DO 180 J = 1, N
IF( RCONDV( J ).NE.RCNDV1( J ) )
$ RESULT( 9 ) = ULPINV
180 CONTINUE
END IF
*
190 CONTINUE
*
200 CONTINUE
*
* If COMP, compare condition numbers to precomputed ones
*
IF( COMP ) THEN
CALL DLACPY( 'F', N, N, A, LDA, H, LDA )
CALL DGEEVX( 'N', 'V', 'V', 'B', N, H, LDA, WR, WI, VL, LDVL,
$ VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV,
$ WORK, LWORK, IWORK, IINFO )
IF( IINFO.NE.0 ) THEN
RESULT( 1 ) = ULPINV
WRITE( NOUNIT, FMT = 9999 )'DGEEVX5', IINFO, N, ISEED( 1 )
INFO = ABS( IINFO )
GO TO 250
END IF
*
* Sort eigenvalues and condition numbers lexicographically
* to compare with inputs
*
DO 220 I = 1, N - 1
KMIN = I
VRMIN = WR( I )
VIMIN = WI( I )
DO 210 J = I + 1, N
IF( WR( J ).LT.VRMIN ) THEN
KMIN = J
VRMIN = WR( J )
VIMIN = WI( J )
END IF
210 CONTINUE
WR( KMIN ) = WR( I )
WI( KMIN ) = WI( I )
WR( I ) = VRMIN
WI( I ) = VIMIN
VRMIN = RCONDE( KMIN )
RCONDE( KMIN ) = RCONDE( I )
RCONDE( I ) = VRMIN
VRMIN = RCONDV( KMIN )
RCONDV( KMIN ) = RCONDV( I )
RCONDV( I ) = VRMIN
220 CONTINUE
*
* Compare condition numbers for eigenvectors
* taking their condition numbers into account
*
RESULT( 10 ) = ZERO
EPS = MAX( EPSIN, ULP )
V = MAX( DBLE( N )*EPS*ABNRM, SMLNUM )
IF( ABNRM.EQ.ZERO )
$ V = ONE
DO 230 I = 1, N
IF( V.GT.RCONDV( I )*RCONDE( I ) ) THEN
TOL = RCONDV( I )
ELSE
TOL = V / RCONDE( I )
END IF
IF( V.GT.RCDVIN( I )*RCDEIN( I ) ) THEN
TOLIN = RCDVIN( I )
ELSE
TOLIN = V / RCDEIN( I )
END IF
TOL = MAX( TOL, SMLNUM / EPS )
TOLIN = MAX( TOLIN, SMLNUM / EPS )
IF( EPS*( RCDVIN( I )-TOLIN ).GT.RCONDV( I )+TOL ) THEN
VMAX = ONE / EPS
ELSE IF( RCDVIN( I )-TOLIN.GT.RCONDV( I )+TOL ) THEN
VMAX = ( RCDVIN( I )-TOLIN ) / ( RCONDV( I )+TOL )
ELSE IF( RCDVIN( I )+TOLIN.LT.EPS*( RCONDV( I )-TOL ) ) THEN
VMAX = ONE / EPS
ELSE IF( RCDVIN( I )+TOLIN.LT.RCONDV( I )-TOL ) THEN
VMAX = ( RCONDV( I )-TOL ) / ( RCDVIN( I )+TOLIN )
ELSE
VMAX = ONE
END IF
RESULT( 10 ) = MAX( RESULT( 10 ), VMAX )
230 CONTINUE
*
* Compare condition numbers for eigenvalues
* taking their condition numbers into account
*
RESULT( 11 ) = ZERO
DO 240 I = 1, N
IF( V.GT.RCONDV( I ) ) THEN
TOL = ONE
ELSE
TOL = V / RCONDV( I )
END IF
IF( V.GT.RCDVIN( I ) ) THEN
TOLIN = ONE
ELSE
TOLIN = V / RCDVIN( I )
END IF
TOL = MAX( TOL, SMLNUM / EPS )
TOLIN = MAX( TOLIN, SMLNUM / EPS )
IF( EPS*( RCDEIN( I )-TOLIN ).GT.RCONDE( I )+TOL ) THEN
VMAX = ONE / EPS
ELSE IF( RCDEIN( I )-TOLIN.GT.RCONDE( I )+TOL ) THEN
VMAX = ( RCDEIN( I )-TOLIN ) / ( RCONDE( I )+TOL )
ELSE IF( RCDEIN( I )+TOLIN.LT.EPS*( RCONDE( I )-TOL ) ) THEN
VMAX = ONE / EPS
ELSE IF( RCDEIN( I )+TOLIN.LT.RCONDE( I )-TOL ) THEN
VMAX = ( RCONDE( I )-TOL ) / ( RCDEIN( I )+TOLIN )
ELSE
VMAX = ONE
END IF
RESULT( 11 ) = MAX( RESULT( 11 ), VMAX )
240 CONTINUE
250 CONTINUE
*
END IF
*
9999 FORMAT( ' DGET23: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', INPUT EXAMPLE NUMBER = ', I4 )
9998 FORMAT( ' DGET23: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ', BALANC = ', A, ', ISEED=(',
$ 3( I5, ',' ), I5, ')' )
*
RETURN
*
* End of DGET23
*
END
SUBROUTINE DGET24( COMP, JTYPE, THRESH, ISEED, NOUNIT, N, A, LDA,
$ H, HT, WR, WI, WRT, WIT, WRTMP, WITMP, VS,
$ LDVS, VS1, RCDEIN, RCDVIN, NSLCT, ISLCT,
$ RESULT, WORK, LWORK, IWORK, BWORK, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL COMP
INTEGER INFO, JTYPE, LDA, LDVS, LWORK, N, NOUNIT, NSLCT
DOUBLE PRECISION RCDEIN, RCDVIN, THRESH
* ..
* .. Array Arguments ..
LOGICAL BWORK( * )
INTEGER ISEED( 4 ), ISLCT( * ), IWORK( * )
DOUBLE PRECISION A( LDA, * ), H( LDA, * ), HT( LDA, * ),
$ RESULT( 17 ), VS( LDVS, * ), VS1( LDVS, * ),
$ WI( * ), WIT( * ), WITMP( * ), WORK( * ),
$ WR( * ), WRT( * ), WRTMP( * )
* ..
*
* Purpose
* =======
*
* DGET24 checks the nonsymmetric eigenvalue (Schur form) problem
* expert driver DGEESX.
*
* If COMP = .FALSE., the first 13 of the following tests will be
* be performed on the input matrix A, and also tests 14 and 15
* if LWORK is sufficiently large.
* If COMP = .TRUE., all 17 test will be performed.
*
* (1) 0 if T is in Schur form, 1/ulp otherwise
* (no sorting of eigenvalues)
*
* (2) | A - VS T VS' | / ( n |A| ulp )
*
* Here VS is the matrix of Schur eigenvectors, and T is in Schur
* form (no sorting of eigenvalues).
*
* (3) | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues).
*
* (4) 0 if WR+sqrt(-1)*WI are eigenvalues of T
* 1/ulp otherwise
* (no sorting of eigenvalues)
*
* (5) 0 if T(with VS) = T(without VS),
* 1/ulp otherwise
* (no sorting of eigenvalues)
*
* (6) 0 if eigenvalues(with VS) = eigenvalues(without VS),
* 1/ulp otherwise
* (no sorting of eigenvalues)
*
* (7) 0 if T is in Schur form, 1/ulp otherwise
* (with sorting of eigenvalues)
*
* (8) | A - VS T VS' | / ( n |A| ulp )
*
* Here VS is the matrix of Schur eigenvectors, and T is in Schur
* form (with sorting of eigenvalues).
*
* (9) | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues).
*
* (10) 0 if WR+sqrt(-1)*WI are eigenvalues of T
* 1/ulp otherwise
* If workspace sufficient, also compare WR, WI with and
* without reciprocal condition numbers
* (with sorting of eigenvalues)
*
* (11) 0 if T(with VS) = T(without VS),
* 1/ulp otherwise
* If workspace sufficient, also compare T with and without
* reciprocal condition numbers
* (with sorting of eigenvalues)
*
* (12) 0 if eigenvalues(with VS) = eigenvalues(without VS),
* 1/ulp otherwise
* If workspace sufficient, also compare VS with and without
* reciprocal condition numbers
* (with sorting of eigenvalues)
*
* (13) if sorting worked and SDIM is the number of
* eigenvalues which were SELECTed
* If workspace sufficient, also compare SDIM with and
* without reciprocal condition numbers
*
* (14) if RCONDE the same no matter if VS and/or RCONDV computed
*
* (15) if RCONDV the same no matter if VS and/or RCONDE computed
*
* (16) |RCONDE - RCDEIN| / cond(RCONDE)
*
* RCONDE is the reciprocal average eigenvalue condition number
* computed by DGEESX and RCDEIN (the precomputed true value)
* is supplied as input. cond(RCONDE) is the condition number
* of RCONDE, and takes errors in computing RCONDE into account,
* so that the resulting quantity should be O(ULP). cond(RCONDE)
* is essentially given by norm(A)/RCONDV.
*
* (17) |RCONDV - RCDVIN| / cond(RCONDV)
*
* RCONDV is the reciprocal right invariant subspace condition
* number computed by DGEESX and RCDVIN (the precomputed true
* value) is supplied as input. cond(RCONDV) is the condition
* number of RCONDV, and takes errors in computing RCONDV into
* account, so that the resulting quantity should be O(ULP).
* cond(RCONDV) is essentially given by norm(A)/RCONDE.
*
* Arguments
* =========
*
* COMP (input) LOGICAL
* COMP describes which input tests to perform:
* = .FALSE. if the computed condition numbers are not to
* be tested against RCDVIN and RCDEIN
* = .TRUE. if they are to be compared
*
* JTYPE (input) INTEGER
* Type of input matrix. Used to label output if error occurs.
*
* ISEED (input) INTEGER array, dimension (4)
* If COMP = .FALSE., the random number generator seed
* used to produce matrix.
* If COMP = .TRUE., ISEED(1) = the number of the example.
* Used to label output if error occurs.
*
* THRESH (input) DOUBLE PRECISION
* A test will count as "failed" if the "error", computed as
* described above, exceeds THRESH. Note that the error
* is scaled to be O(1), so THRESH should be a reasonably
* small multiple of 1, e.g., 10 or 100. In particular,
* it should not depend on the precision (single vs. double)
* or the size of the matrix. It must be at least zero.
*
* NOUNIT (input) INTEGER
* The FORTRAN unit number for printing out error messages
* (e.g., if a routine returns INFO not equal to 0.)
*
* N (input) INTEGER
* The dimension of A. N must be at least 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
* Used to hold the matrix whose eigenvalues are to be
* computed.
*
* LDA (input) INTEGER
* The leading dimension of A, and H. LDA must be at
* least 1 and at least N.
*
* H (workspace) DOUBLE PRECISION array, dimension (LDA, N)
* Another copy of the test matrix A, modified by DGEESX.
*
* HT (workspace) DOUBLE PRECISION array, dimension (LDA, N)
* Yet another copy of the test matrix A, modified by DGEESX.
*
* WR (workspace) DOUBLE PRECISION array, dimension (N)
* WI (workspace) DOUBLE PRECISION array, dimension (N)
* The real and imaginary parts of the eigenvalues of A.
* On exit, WR + WI*i are the eigenvalues of the matrix in A.
*
* WRT (workspace) DOUBLE PRECISION array, dimension (N)
* WIT (workspace) DOUBLE PRECISION array, dimension (N)
* Like WR, WI, these arrays contain the eigenvalues of A,
* but those computed when DGEESX only computes a partial
* eigendecomposition, i.e. not Schur vectors
*
* WRTMP (workspace) DOUBLE PRECISION array, dimension (N)
* WITMP (workspace) DOUBLE PRECISION array, dimension (N)
* Like WR, WI, these arrays contain the eigenvalues of A,
* but sorted by increasing real part.
*
* VS (workspace) DOUBLE PRECISION array, dimension (LDVS, N)
* VS holds the computed Schur vectors.
*
* LDVS (input) INTEGER
* Leading dimension of VS. Must be at least max(1, N).
*
* VS1 (workspace) DOUBLE PRECISION array, dimension (LDVS, N)
* VS1 holds another copy of the computed Schur vectors.
*
* RCDEIN (input) DOUBLE PRECISION
* When COMP = .TRUE. RCDEIN holds the precomputed reciprocal
* condition number for the average of selected eigenvalues.
*
* RCDVIN (input) DOUBLE PRECISION
* When COMP = .TRUE. RCDVIN holds the precomputed reciprocal
* condition number for the selected right invariant subspace.
*
* NSLCT (input) INTEGER
* When COMP = .TRUE. the number of selected eigenvalues
* corresponding to the precomputed values RCDEIN and RCDVIN.
*
* ISLCT (input) INTEGER array, dimension (NSLCT)
* When COMP = .TRUE. ISLCT selects the eigenvalues of the
* input matrix corresponding to the precomputed values RCDEIN
* and RCDVIN. For I=1, ... ,NSLCT, if ISLCT(I) = J, then the
* eigenvalue with the J-th largest real part is selected.
* Not referenced if COMP = .FALSE.
*
* RESULT (output) DOUBLE PRECISION array, dimension (17)
* The values computed by the 17 tests described above.
* The values are currently limited to 1/ulp, to avoid
* overflow.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The number of entries in WORK to be passed to DGEESX. This
* must be at least 3*N, and N+N**2 if tests 14--16 are to
* be performed.
*
* IWORK (workspace) INTEGER array, dimension (N*N)
*
* BWORK (workspace) LOGICAL array, dimension (N)
*
* INFO (output) INTEGER
* If 0, successful exit.
* If <0, input parameter -INFO had an incorrect value.
* If >0, DGEESX returned an error code, the absolute
* value of which is returned.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
DOUBLE PRECISION EPSIN
PARAMETER ( EPSIN = 5.9605D-8 )
* ..
* .. Local Scalars ..
CHARACTER SORT
INTEGER I, IINFO, ISORT, ITMP, J, KMIN, KNTEIG, LIWORK,
$ RSUB, SDIM, SDIM1
DOUBLE PRECISION ANORM, EPS, RCNDE1, RCNDV1, RCONDE, RCONDV,
$ SMLNUM, TMP, TOL, TOLIN, ULP, ULPINV, V, VIMIN,
$ VRMIN, WNORM
* ..
* .. Local Arrays ..
INTEGER IPNT( 20 )
* ..
* .. Arrays in Common ..
LOGICAL SELVAL( 20 )
DOUBLE PRECISION SELWI( 20 ), SELWR( 20 )
* ..
* .. Scalars in Common ..
INTEGER SELDIM, SELOPT
* ..
* .. Common blocks ..
COMMON / SSLCT / SELOPT, SELDIM, SELVAL, SELWR, SELWI
* ..
* .. External Functions ..
LOGICAL DSLECT
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL DSLECT, DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEESX, DGEMM, DLACPY, DORT01, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Check for errors
*
INFO = 0
IF( THRESH.LT.ZERO ) THEN
INFO = -3
ELSE IF( NOUNIT.LE.0 ) THEN
INFO = -5
ELSE IF( N.LT.0 ) THEN
INFO = -6
ELSE IF( LDA.LT.1 .OR. LDA.LT.N ) THEN
INFO = -8
ELSE IF( LDVS.LT.1 .OR. LDVS.LT.N ) THEN
INFO = -18
ELSE IF( LWORK.LT.3*N ) THEN
INFO = -26
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGET24', -INFO )
RETURN
END IF
*
* Quick return if nothing to do
*
DO 10 I = 1, 17
RESULT( I ) = -ONE
10 CONTINUE
*
IF( N.EQ.0 )
$ RETURN
*
* Important constants
*
SMLNUM = DLAMCH( 'Safe minimum' )
ULP = DLAMCH( 'Precision' )
ULPINV = ONE / ULP
*
* Perform tests (1)-(13)
*
SELOPT = 0
LIWORK = N*N
DO 120 ISORT = 0, 1
IF( ISORT.EQ.0 ) THEN
SORT = 'N'
RSUB = 0
ELSE
SORT = 'S'
RSUB = 6
END IF
*
* Compute Schur form and Schur vectors, and test them
*
CALL DLACPY( 'F', N, N, A, LDA, H, LDA )
CALL DGEESX( 'V', SORT, DSLECT, 'N', N, H, LDA, SDIM, WR, WI,
$ VS, LDVS, RCONDE, RCONDV, WORK, LWORK, IWORK,
$ LIWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 1+RSUB ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'DGEESX1', IINFO, N, JTYPE,
$ ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'DGEESX1', IINFO, N,
$ ISEED( 1 )
END IF
INFO = ABS( IINFO )
RETURN
END IF
IF( ISORT.EQ.0 ) THEN
CALL DCOPY( N, WR, 1, WRTMP, 1 )
CALL DCOPY( N, WI, 1, WITMP, 1 )
END IF
*
* Do Test (1) or Test (7)
*
RESULT( 1+RSUB ) = ZERO
DO 30 J = 1, N - 2
DO 20 I = J + 2, N
IF( H( I, J ).NE.ZERO )
$ RESULT( 1+RSUB ) = ULPINV
20 CONTINUE
30 CONTINUE
DO 40 I = 1, N - 2
IF( H( I+1, I ).NE.ZERO .AND. H( I+2, I+1 ).NE.ZERO )
$ RESULT( 1+RSUB ) = ULPINV
40 CONTINUE
DO 50 I = 1, N - 1
IF( H( I+1, I ).NE.ZERO ) THEN
IF( H( I, I ).NE.H( I+1, I+1 ) .OR. H( I, I+1 ).EQ.
$ ZERO .OR. SIGN( ONE, H( I+1, I ) ).EQ.
$ SIGN( ONE, H( I, I+1 ) ) )RESULT( 1+RSUB ) = ULPINV
END IF
50 CONTINUE
*
* Test (2) or (8): Compute norm(A - Q*H*Q') / (norm(A) * N * ULP)
*
* Copy A to VS1, used as workspace
*
CALL DLACPY( ' ', N, N, A, LDA, VS1, LDVS )
*
* Compute Q*H and store in HT.
*
CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, VS,
$ LDVS, H, LDA, ZERO, HT, LDA )
*
* Compute A - Q*H*Q'
*
CALL DGEMM( 'No transpose', 'Transpose', N, N, N, -ONE, HT,
$ LDA, VS, LDVS, ONE, VS1, LDVS )
*
ANORM = MAX( DLANGE( '1', N, N, A, LDA, WORK ), SMLNUM )
WNORM = DLANGE( '1', N, N, VS1, LDVS, WORK )
*
IF( ANORM.GT.WNORM ) THEN
RESULT( 2+RSUB ) = ( WNORM / ANORM ) / ( N*ULP )
ELSE
IF( ANORM.LT.ONE ) THEN
RESULT( 2+RSUB ) = ( MIN( WNORM, N*ANORM ) / ANORM ) /
$ ( N*ULP )
ELSE
RESULT( 2+RSUB ) = MIN( WNORM / ANORM, DBLE( N ) ) /
$ ( N*ULP )
END IF
END IF
*
* Test (3) or (9): Compute norm( I - Q'*Q ) / ( N * ULP )
*
CALL DORT01( 'Columns', N, N, VS, LDVS, WORK, LWORK,
$ RESULT( 3+RSUB ) )
*
* Do Test (4) or Test (10)
*
RESULT( 4+RSUB ) = ZERO
DO 60 I = 1, N
IF( H( I, I ).NE.WR( I ) )
$ RESULT( 4+RSUB ) = ULPINV
60 CONTINUE
IF( N.GT.1 ) THEN
IF( H( 2, 1 ).EQ.ZERO .AND. WI( 1 ).NE.ZERO )
$ RESULT( 4+RSUB ) = ULPINV
IF( H( N, N-1 ).EQ.ZERO .AND. WI( N ).NE.ZERO )
$ RESULT( 4+RSUB ) = ULPINV
END IF
DO 70 I = 1, N - 1
IF( H( I+1, I ).NE.ZERO ) THEN
TMP = SQRT( ABS( H( I+1, I ) ) )*
$ SQRT( ABS( H( I, I+1 ) ) )
RESULT( 4+RSUB ) = MAX( RESULT( 4+RSUB ),
$ ABS( WI( I )-TMP ) /
$ MAX( ULP*TMP, SMLNUM ) )
RESULT( 4+RSUB ) = MAX( RESULT( 4+RSUB ),
$ ABS( WI( I+1 )+TMP ) /
$ MAX( ULP*TMP, SMLNUM ) )
ELSE IF( I.GT.1 ) THEN
IF( H( I+1, I ).EQ.ZERO .AND. H( I, I-1 ).EQ.ZERO .AND.
$ WI( I ).NE.ZERO )RESULT( 4+RSUB ) = ULPINV
END IF
70 CONTINUE
*
* Do Test (5) or Test (11)
*
CALL DLACPY( 'F', N, N, A, LDA, HT, LDA )
CALL DGEESX( 'N', SORT, DSLECT, 'N', N, HT, LDA, SDIM, WRT,
$ WIT, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, IWORK,
$ LIWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 5+RSUB ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'DGEESX2', IINFO, N, JTYPE,
$ ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'DGEESX2', IINFO, N,
$ ISEED( 1 )
END IF
INFO = ABS( IINFO )
GO TO 250
END IF
*
RESULT( 5+RSUB ) = ZERO
DO 90 J = 1, N
DO 80 I = 1, N
IF( H( I, J ).NE.HT( I, J ) )
$ RESULT( 5+RSUB ) = ULPINV
80 CONTINUE
90 CONTINUE
*
* Do Test (6) or Test (12)
*
RESULT( 6+RSUB ) = ZERO
DO 100 I = 1, N
IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
$ RESULT( 6+RSUB ) = ULPINV
100 CONTINUE
*
* Do Test (13)
*
IF( ISORT.EQ.1 ) THEN
RESULT( 13 ) = ZERO
KNTEIG = 0
DO 110 I = 1, N
IF( DSLECT( WR( I ), WI( I ) ) .OR.
$ DSLECT( WR( I ), -WI( I ) ) )KNTEIG = KNTEIG + 1
IF( I.LT.N ) THEN
IF( ( DSLECT( WR( I+1 ), WI( I+1 ) ) .OR.
$ DSLECT( WR( I+1 ), -WI( I+1 ) ) ) .AND.
$ ( .NOT.( DSLECT( WR( I ),
$ WI( I ) ) .OR. DSLECT( WR( I ),
$ -WI( I ) ) ) ) .AND. IINFO.NE.N+2 )RESULT( 13 )
$ = ULPINV
END IF
110 CONTINUE
IF( SDIM.NE.KNTEIG )
$ RESULT( 13 ) = ULPINV
END IF
*
120 CONTINUE
*
* If there is enough workspace, perform tests (14) and (15)
* as well as (10) through (13)
*
IF( LWORK.GE.N+( N*N ) / 2 ) THEN
*
* Compute both RCONDE and RCONDV with VS
*
SORT = 'S'
RESULT( 14 ) = ZERO
RESULT( 15 ) = ZERO
CALL DLACPY( 'F', N, N, A, LDA, HT, LDA )
CALL DGEESX( 'V', SORT, DSLECT, 'B', N, HT, LDA, SDIM1, WRT,
$ WIT, VS1, LDVS, RCONDE, RCONDV, WORK, LWORK,
$ IWORK, LIWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 14 ) = ULPINV
RESULT( 15 ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'DGEESX3', IINFO, N, JTYPE,
$ ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'DGEESX3', IINFO, N,
$ ISEED( 1 )
END IF
INFO = ABS( IINFO )
GO TO 250
END IF
*
* Perform tests (10), (11), (12), and (13)
*
DO 140 I = 1, N
IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
$ RESULT( 10 ) = ULPINV
DO 130 J = 1, N
IF( H( I, J ).NE.HT( I, J ) )
$ RESULT( 11 ) = ULPINV
IF( VS( I, J ).NE.VS1( I, J ) )
$ RESULT( 12 ) = ULPINV
130 CONTINUE
140 CONTINUE
IF( SDIM.NE.SDIM1 )
$ RESULT( 13 ) = ULPINV
*
* Compute both RCONDE and RCONDV without VS, and compare
*
CALL DLACPY( 'F', N, N, A, LDA, HT, LDA )
CALL DGEESX( 'N', SORT, DSLECT, 'B', N, HT, LDA, SDIM1, WRT,
$ WIT, VS1, LDVS, RCNDE1, RCNDV1, WORK, LWORK,
$ IWORK, LIWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 14 ) = ULPINV
RESULT( 15 ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'DGEESX4', IINFO, N, JTYPE,
$ ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'DGEESX4', IINFO, N,
$ ISEED( 1 )
END IF
INFO = ABS( IINFO )
GO TO 250
END IF
*
* Perform tests (14) and (15)
*
IF( RCNDE1.NE.RCONDE )
$ RESULT( 14 ) = ULPINV
IF( RCNDV1.NE.RCONDV )
$ RESULT( 15 ) = ULPINV
*
* Perform tests (10), (11), (12), and (13)
*
DO 160 I = 1, N
IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
$ RESULT( 10 ) = ULPINV
DO 150 J = 1, N
IF( H( I, J ).NE.HT( I, J ) )
$ RESULT( 11 ) = ULPINV
IF( VS( I, J ).NE.VS1( I, J ) )
$ RESULT( 12 ) = ULPINV
150 CONTINUE
160 CONTINUE
IF( SDIM.NE.SDIM1 )
$ RESULT( 13 ) = ULPINV
*
* Compute RCONDE with VS, and compare
*
CALL DLACPY( 'F', N, N, A, LDA, HT, LDA )
CALL DGEESX( 'V', SORT, DSLECT, 'E', N, HT, LDA, SDIM1, WRT,
$ WIT, VS1, LDVS, RCNDE1, RCNDV1, WORK, LWORK,
$ IWORK, LIWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 14 ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'DGEESX5', IINFO, N, JTYPE,
$ ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'DGEESX5', IINFO, N,
$ ISEED( 1 )
END IF
INFO = ABS( IINFO )
GO TO 250
END IF
*
* Perform test (14)
*
IF( RCNDE1.NE.RCONDE )
$ RESULT( 14 ) = ULPINV
*
* Perform tests (10), (11), (12), and (13)
*
DO 180 I = 1, N
IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
$ RESULT( 10 ) = ULPINV
DO 170 J = 1, N
IF( H( I, J ).NE.HT( I, J ) )
$ RESULT( 11 ) = ULPINV
IF( VS( I, J ).NE.VS1( I, J ) )
$ RESULT( 12 ) = ULPINV
170 CONTINUE
180 CONTINUE
IF( SDIM.NE.SDIM1 )
$ RESULT( 13 ) = ULPINV
*
* Compute RCONDE without VS, and compare
*
CALL DLACPY( 'F', N, N, A, LDA, HT, LDA )
CALL DGEESX( 'N', SORT, DSLECT, 'E', N, HT, LDA, SDIM1, WRT,
$ WIT, VS1, LDVS, RCNDE1, RCNDV1, WORK, LWORK,
$ IWORK, LIWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 14 ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'DGEESX6', IINFO, N, JTYPE,
$ ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'DGEESX6', IINFO, N,
$ ISEED( 1 )
END IF
INFO = ABS( IINFO )
GO TO 250
END IF
*
* Perform test (14)
*
IF( RCNDE1.NE.RCONDE )
$ RESULT( 14 ) = ULPINV
*
* Perform tests (10), (11), (12), and (13)
*
DO 200 I = 1, N
IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
$ RESULT( 10 ) = ULPINV
DO 190 J = 1, N
IF( H( I, J ).NE.HT( I, J ) )
$ RESULT( 11 ) = ULPINV
IF( VS( I, J ).NE.VS1( I, J ) )
$ RESULT( 12 ) = ULPINV
190 CONTINUE
200 CONTINUE
IF( SDIM.NE.SDIM1 )
$ RESULT( 13 ) = ULPINV
*
* Compute RCONDV with VS, and compare
*
CALL DLACPY( 'F', N, N, A, LDA, HT, LDA )
CALL DGEESX( 'V', SORT, DSLECT, 'V', N, HT, LDA, SDIM1, WRT,
$ WIT, VS1, LDVS, RCNDE1, RCNDV1, WORK, LWORK,
$ IWORK, LIWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 15 ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'DGEESX7', IINFO, N, JTYPE,
$ ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'DGEESX7', IINFO, N,
$ ISEED( 1 )
END IF
INFO = ABS( IINFO )
GO TO 250
END IF
*
* Perform test (15)
*
IF( RCNDV1.NE.RCONDV )
$ RESULT( 15 ) = ULPINV
*
* Perform tests (10), (11), (12), and (13)
*
DO 220 I = 1, N
IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
$ RESULT( 10 ) = ULPINV
DO 210 J = 1, N
IF( H( I, J ).NE.HT( I, J ) )
$ RESULT( 11 ) = ULPINV
IF( VS( I, J ).NE.VS1( I, J ) )
$ RESULT( 12 ) = ULPINV
210 CONTINUE
220 CONTINUE
IF( SDIM.NE.SDIM1 )
$ RESULT( 13 ) = ULPINV
*
* Compute RCONDV without VS, and compare
*
CALL DLACPY( 'F', N, N, A, LDA, HT, LDA )
CALL DGEESX( 'N', SORT, DSLECT, 'V', N, HT, LDA, SDIM1, WRT,
$ WIT, VS1, LDVS, RCNDE1, RCNDV1, WORK, LWORK,
$ IWORK, LIWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 15 ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'DGEESX8', IINFO, N, JTYPE,
$ ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'DGEESX8', IINFO, N,
$ ISEED( 1 )
END IF
INFO = ABS( IINFO )
GO TO 250
END IF
*
* Perform test (15)
*
IF( RCNDV1.NE.RCONDV )
$ RESULT( 15 ) = ULPINV
*
* Perform tests (10), (11), (12), and (13)
*
DO 240 I = 1, N
IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
$ RESULT( 10 ) = ULPINV
DO 230 J = 1, N
IF( H( I, J ).NE.HT( I, J ) )
$ RESULT( 11 ) = ULPINV
IF( VS( I, J ).NE.VS1( I, J ) )
$ RESULT( 12 ) = ULPINV
230 CONTINUE
240 CONTINUE
IF( SDIM.NE.SDIM1 )
$ RESULT( 13 ) = ULPINV
*
END IF
*
250 CONTINUE
*
* If there are precomputed reciprocal condition numbers, compare
* computed values with them.
*
IF( COMP ) THEN
*
* First set up SELOPT, SELDIM, SELVAL, SELWR, and SELWI so that
* the logical function DSLECT selects the eigenvalues specified
* by NSLCT and ISLCT.
*
SELDIM = N
SELOPT = 1
EPS = MAX( ULP, EPSIN )
DO 260 I = 1, N
IPNT( I ) = I
SELVAL( I ) = .FALSE.
SELWR( I ) = WRTMP( I )
SELWI( I ) = WITMP( I )
260 CONTINUE
DO 280 I = 1, N - 1
KMIN = I
VRMIN = WRTMP( I )
VIMIN = WITMP( I )
DO 270 J = I + 1, N
IF( WRTMP( J ).LT.VRMIN ) THEN
KMIN = J
VRMIN = WRTMP( J )
VIMIN = WITMP( J )
END IF
270 CONTINUE
WRTMP( KMIN ) = WRTMP( I )
WITMP( KMIN ) = WITMP( I )
WRTMP( I ) = VRMIN
WITMP( I ) = VIMIN
ITMP = IPNT( I )
IPNT( I ) = IPNT( KMIN )
IPNT( KMIN ) = ITMP
280 CONTINUE
DO 290 I = 1, NSLCT
SELVAL( IPNT( ISLCT( I ) ) ) = .TRUE.
290 CONTINUE
*
* Compute condition numbers
*
CALL DLACPY( 'F', N, N, A, LDA, HT, LDA )
CALL DGEESX( 'N', 'S', DSLECT, 'B', N, HT, LDA, SDIM1, WRT,
$ WIT, VS1, LDVS, RCONDE, RCONDV, WORK, LWORK,
$ IWORK, LIWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 16 ) = ULPINV
RESULT( 17 ) = ULPINV
WRITE( NOUNIT, FMT = 9999 )'DGEESX9', IINFO, N, ISEED( 1 )
INFO = ABS( IINFO )
GO TO 300
END IF
*
* Compare condition number for average of selected eigenvalues
* taking its condition number into account
*
ANORM = DLANGE( '1', N, N, A, LDA, WORK )
V = MAX( DBLE( N )*EPS*ANORM, SMLNUM )
IF( ANORM.EQ.ZERO )
$ V = ONE
IF( V.GT.RCONDV ) THEN
TOL = ONE
ELSE
TOL = V / RCONDV
END IF
IF( V.GT.RCDVIN ) THEN
TOLIN = ONE
ELSE
TOLIN = V / RCDVIN
END IF
TOL = MAX( TOL, SMLNUM / EPS )
TOLIN = MAX( TOLIN, SMLNUM / EPS )
IF( EPS*( RCDEIN-TOLIN ).GT.RCONDE+TOL ) THEN
RESULT( 16 ) = ULPINV
ELSE IF( RCDEIN-TOLIN.GT.RCONDE+TOL ) THEN
RESULT( 16 ) = ( RCDEIN-TOLIN ) / ( RCONDE+TOL )
ELSE IF( RCDEIN+TOLIN.LT.EPS*( RCONDE-TOL ) ) THEN
RESULT( 16 ) = ULPINV
ELSE IF( RCDEIN+TOLIN.LT.RCONDE-TOL ) THEN
RESULT( 16 ) = ( RCONDE-TOL ) / ( RCDEIN+TOLIN )
ELSE
RESULT( 16 ) = ONE
END IF
*
* Compare condition numbers for right invariant subspace
* taking its condition number into account
*
IF( V.GT.RCONDV*RCONDE ) THEN
TOL = RCONDV
ELSE
TOL = V / RCONDE
END IF
IF( V.GT.RCDVIN*RCDEIN ) THEN
TOLIN = RCDVIN
ELSE
TOLIN = V / RCDEIN
END IF
TOL = MAX( TOL, SMLNUM / EPS )
TOLIN = MAX( TOLIN, SMLNUM / EPS )
IF( EPS*( RCDVIN-TOLIN ).GT.RCONDV+TOL ) THEN
RESULT( 17 ) = ULPINV
ELSE IF( RCDVIN-TOLIN.GT.RCONDV+TOL ) THEN
RESULT( 17 ) = ( RCDVIN-TOLIN ) / ( RCONDV+TOL )
ELSE IF( RCDVIN+TOLIN.LT.EPS*( RCONDV-TOL ) ) THEN
RESULT( 17 ) = ULPINV
ELSE IF( RCDVIN+TOLIN.LT.RCONDV-TOL ) THEN
RESULT( 17 ) = ( RCONDV-TOL ) / ( RCDVIN+TOLIN )
ELSE
RESULT( 17 ) = ONE
END IF
*
300 CONTINUE
*
END IF
*
9999 FORMAT( ' DGET24: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', INPUT EXAMPLE NUMBER = ', I4 )
9998 FORMAT( ' DGET24: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
*
RETURN
*
* End of DGET24
*
END
SUBROUTINE DGET31( RMAX, LMAX, NINFO, KNT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KNT, LMAX
DOUBLE PRECISION RMAX
* ..
* .. Array Arguments ..
INTEGER NINFO( 2 )
* ..
*
* Purpose
* =======
*
* DGET31 tests DLALN2, a routine for solving
*
* (ca A - w D)X = sB
*
* where A is an NA by NA matrix (NA=1 or 2 only), w is a real (NW=1) or
* complex (NW=2) constant, ca is a real constant, D is an NA by NA real
* diagonal matrix, and B is an NA by NW matrix (when NW=2 the second
* column of B contains the imaginary part of the solution). The code
* returns X and s, where s is a scale factor, less than or equal to 1,
* which is chosen to avoid overflow in X.
*
* If any singular values of ca A-w D are less than another input
* parameter SMIN, they are perturbed up to SMIN.
*
* The test condition is that the scaled residual
*
* norm( (ca A-w D)*X - s*B ) /
* ( max( ulp*norm(ca A-w D), SMIN )*norm(X) )
*
* should be on the order of 1. Here, ulp is the machine precision.
* Also, it is verified that SCALE is less than or equal to 1, and that
* XNORM = infinity-norm(X).
*
* Arguments
* ==========
*
* RMAX (output) DOUBLE PRECISION
* Value of the largest test ratio.
*
* LMAX (output) INTEGER
* Example number where largest test ratio achieved.
*
* NINFO (output) INTEGER array, dimension (3)
* NINFO(1) = number of examples with INFO less than 0
* NINFO(2) = number of examples with INFO greater than 0
*
* KNT (output) INTEGER
* Total number of examples tested.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
DOUBLE PRECISION TWO, THREE, FOUR
PARAMETER ( TWO = 2.0D0, THREE = 3.0D0, FOUR = 4.0D0 )
DOUBLE PRECISION SEVEN, TEN
PARAMETER ( SEVEN = 7.0D0, TEN = 10.0D0 )
DOUBLE PRECISION TWNONE
PARAMETER ( TWNONE = 21.0D0 )
* ..
* .. Local Scalars ..
INTEGER IA, IB, ICA, ID1, ID2, INFO, ISMIN, ITRANS,
$ IWI, IWR, NA, NW
DOUBLE PRECISION BIGNUM, CA, D1, D2, DEN, EPS, RES, SCALE, SMIN,
$ SMLNUM, TMP, UNFL, WI, WR, XNORM
* ..
* .. Local Arrays ..
LOGICAL LTRANS( 0: 1 )
DOUBLE PRECISION A( 2, 2 ), B( 2, 2 ), VAB( 3 ), VCA( 5 ),
$ VDD( 4 ), VSMIN( 4 ), VWI( 4 ), VWR( 4 ),
$ X( 2, 2 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DLABAD, DLALN2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Data statements ..
DATA LTRANS / .FALSE., .TRUE. /
* ..
* .. Executable Statements ..
*
* Get machine parameters
*
EPS = DLAMCH( 'P' )
UNFL = DLAMCH( 'U' )
SMLNUM = DLAMCH( 'S' ) / EPS
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
*
* Set up test case parameters
*
VSMIN( 1 ) = SMLNUM
VSMIN( 2 ) = EPS
VSMIN( 3 ) = ONE / ( TEN*TEN )
VSMIN( 4 ) = ONE / EPS
VAB( 1 ) = SQRT( SMLNUM )
VAB( 2 ) = ONE
VAB( 3 ) = SQRT( BIGNUM )
VWR( 1 ) = ZERO
VWR( 2 ) = HALF
VWR( 3 ) = TWO
VWR( 4 ) = ONE
VWI( 1 ) = SMLNUM
VWI( 2 ) = EPS
VWI( 3 ) = ONE
VWI( 4 ) = TWO
VDD( 1 ) = SQRT( SMLNUM )
VDD( 2 ) = ONE
VDD( 3 ) = TWO
VDD( 4 ) = SQRT( BIGNUM )
VCA( 1 ) = ZERO
VCA( 2 ) = SQRT( SMLNUM )
VCA( 3 ) = EPS
VCA( 4 ) = HALF
VCA( 5 ) = ONE
*
KNT = 0
NINFO( 1 ) = 0
NINFO( 2 ) = 0
LMAX = 0
RMAX = ZERO
*
* Begin test loop
*
DO 190 ID1 = 1, 4
D1 = VDD( ID1 )
DO 180 ID2 = 1, 4
D2 = VDD( ID2 )
DO 170 ICA = 1, 5
CA = VCA( ICA )
DO 160 ITRANS = 0, 1
DO 150 ISMIN = 1, 4
SMIN = VSMIN( ISMIN )
*
NA = 1
NW = 1
DO 30 IA = 1, 3
A( 1, 1 ) = VAB( IA )
DO 20 IB = 1, 3
B( 1, 1 ) = VAB( IB )
DO 10 IWR = 1, 4
IF( D1.EQ.ONE .AND. D2.EQ.ONE .AND. CA.EQ.
$ ONE ) THEN
WR = VWR( IWR )*A( 1, 1 )
ELSE
WR = VWR( IWR )
END IF
WI = ZERO
CALL DLALN2( LTRANS( ITRANS ), NA, NW,
$ SMIN, CA, A, 2, D1, D2, B, 2,
$ WR, WI, X, 2, SCALE, XNORM,
$ INFO )
IF( INFO.LT.0 )
$ NINFO( 1 ) = NINFO( 1 ) + 1
IF( INFO.GT.0 )
$ NINFO( 2 ) = NINFO( 2 ) + 1
RES = ABS( ( CA*A( 1, 1 )-WR*D1 )*
$ X( 1, 1 )-SCALE*B( 1, 1 ) )
IF( INFO.EQ.0 ) THEN
DEN = MAX( EPS*( ABS( ( CA*A( 1,
$ 1 )-WR*D1 )*X( 1, 1 ) ) ),
$ SMLNUM )
ELSE
DEN = MAX( SMIN*ABS( X( 1, 1 ) ),
$ SMLNUM )
END IF
RES = RES / DEN
IF( ABS( X( 1, 1 ) ).LT.UNFL .AND.
$ ABS( B( 1, 1 ) ).LE.SMLNUM*
$ ABS( CA*A( 1, 1 )-WR*D1 ) )RES = ZERO
IF( SCALE.GT.ONE )
$ RES = RES + ONE / EPS
RES = RES + ABS( XNORM-ABS( X( 1, 1 ) ) )
$ / MAX( SMLNUM, XNORM ) / EPS
IF( INFO.NE.0 .AND. INFO.NE.1 )
$ RES = RES + ONE / EPS
KNT = KNT + 1
IF( RES.GT.RMAX ) THEN
LMAX = KNT
RMAX = RES
END IF
10 CONTINUE
20 CONTINUE
30 CONTINUE
*
NA = 1
NW = 2
DO 70 IA = 1, 3
A( 1, 1 ) = VAB( IA )
DO 60 IB = 1, 3
B( 1, 1 ) = VAB( IB )
B( 1, 2 ) = -HALF*VAB( IB )
DO 50 IWR = 1, 4
IF( D1.EQ.ONE .AND. D2.EQ.ONE .AND. CA.EQ.
$ ONE ) THEN
WR = VWR( IWR )*A( 1, 1 )
ELSE
WR = VWR( IWR )
END IF
DO 40 IWI = 1, 4
IF( D1.EQ.ONE .AND. D2.EQ.ONE .AND.
$ CA.EQ.ONE ) THEN
WI = VWI( IWI )*A( 1, 1 )
ELSE
WI = VWI( IWI )
END IF
CALL DLALN2( LTRANS( ITRANS ), NA, NW,
$ SMIN, CA, A, 2, D1, D2, B,
$ 2, WR, WI, X, 2, SCALE,
$ XNORM, INFO )
IF( INFO.LT.0 )
$ NINFO( 1 ) = NINFO( 1 ) + 1
IF( INFO.GT.0 )
$ NINFO( 2 ) = NINFO( 2 ) + 1
RES = ABS( ( CA*A( 1, 1 )-WR*D1 )*
$ X( 1, 1 )+( WI*D1 )*X( 1, 2 )-
$ SCALE*B( 1, 1 ) )
RES = RES + ABS( ( -WI*D1 )*X( 1, 1 )+
$ ( CA*A( 1, 1 )-WR*D1 )*X( 1, 2 )-
$ SCALE*B( 1, 2 ) )
IF( INFO.EQ.0 ) THEN
DEN = MAX( EPS*( MAX( ABS( CA*A( 1,
$ 1 )-WR*D1 ), ABS( D1*WI ) )*
$ ( ABS( X( 1, 1 ) )+ABS( X( 1,
$ 2 ) ) ) ), SMLNUM )
ELSE
DEN = MAX( SMIN*( ABS( X( 1,
$ 1 ) )+ABS( X( 1, 2 ) ) ),
$ SMLNUM )
END IF
RES = RES / DEN
IF( ABS( X( 1, 1 ) ).LT.UNFL .AND.
$ ABS( X( 1, 2 ) ).LT.UNFL .AND.
$ ABS( B( 1, 1 ) ).LE.SMLNUM*
$ ABS( CA*A( 1, 1 )-WR*D1 ) )
$ RES = ZERO
IF( SCALE.GT.ONE )
$ RES = RES + ONE / EPS
RES = RES + ABS( XNORM-
$ ABS( X( 1, 1 ) )-
$ ABS( X( 1, 2 ) ) ) /
$ MAX( SMLNUM, XNORM ) / EPS
IF( INFO.NE.0 .AND. INFO.NE.1 )
$ RES = RES + ONE / EPS
KNT = KNT + 1
IF( RES.GT.RMAX ) THEN
LMAX = KNT
RMAX = RES
END IF
40 CONTINUE
50 CONTINUE
60 CONTINUE
70 CONTINUE
*
NA = 2
NW = 1
DO 100 IA = 1, 3
A( 1, 1 ) = VAB( IA )
A( 1, 2 ) = -THREE*VAB( IA )
A( 2, 1 ) = -SEVEN*VAB( IA )
A( 2, 2 ) = TWNONE*VAB( IA )
DO 90 IB = 1, 3
B( 1, 1 ) = VAB( IB )
B( 2, 1 ) = -TWO*VAB( IB )
DO 80 IWR = 1, 4
IF( D1.EQ.ONE .AND. D2.EQ.ONE .AND. CA.EQ.
$ ONE ) THEN
WR = VWR( IWR )*A( 1, 1 )
ELSE
WR = VWR( IWR )
END IF
WI = ZERO
CALL DLALN2( LTRANS( ITRANS ), NA, NW,
$ SMIN, CA, A, 2, D1, D2, B, 2,
$ WR, WI, X, 2, SCALE, XNORM,
$ INFO )
IF( INFO.LT.0 )
$ NINFO( 1 ) = NINFO( 1 ) + 1
IF( INFO.GT.0 )
$ NINFO( 2 ) = NINFO( 2 ) + 1
IF( ITRANS.EQ.1 ) THEN
TMP = A( 1, 2 )
A( 1, 2 ) = A( 2, 1 )
A( 2, 1 ) = TMP
END IF
RES = ABS( ( CA*A( 1, 1 )-WR*D1 )*
$ X( 1, 1 )+( CA*A( 1, 2 ) )*
$ X( 2, 1 )-SCALE*B( 1, 1 ) )
RES = RES + ABS( ( CA*A( 2, 1 ) )*
$ X( 1, 1 )+( CA*A( 2, 2 )-WR*D2 )*
$ X( 2, 1 )-SCALE*B( 2, 1 ) )
IF( INFO.EQ.0 ) THEN
DEN = MAX( EPS*( MAX( ABS( CA*A( 1,
$ 1 )-WR*D1 )+ABS( CA*A( 1, 2 ) ),
$ ABS( CA*A( 2, 1 ) )+ABS( CA*A( 2,
$ 2 )-WR*D2 ) )*MAX( ABS( X( 1,
$ 1 ) ), ABS( X( 2, 1 ) ) ) ),
$ SMLNUM )
ELSE
DEN = MAX( EPS*( MAX( SMIN / EPS,
$ MAX( ABS( CA*A( 1,
$ 1 )-WR*D1 )+ABS( CA*A( 1, 2 ) ),
$ ABS( CA*A( 2, 1 ) )+ABS( CA*A( 2,
$ 2 )-WR*D2 ) ) )*MAX( ABS( X( 1,
$ 1 ) ), ABS( X( 2, 1 ) ) ) ),
$ SMLNUM )
END IF
RES = RES / DEN
IF( ABS( X( 1, 1 ) ).LT.UNFL .AND.
$ ABS( X( 2, 1 ) ).LT.UNFL .AND.
$ ABS( B( 1, 1 ) )+ABS( B( 2, 1 ) ).LE.
$ SMLNUM*( ABS( CA*A( 1,
$ 1 )-WR*D1 )+ABS( CA*A( 1,
$ 2 ) )+ABS( CA*A( 2,
$ 1 ) )+ABS( CA*A( 2, 2 )-WR*D2 ) ) )
$ RES = ZERO
IF( SCALE.GT.ONE )
$ RES = RES + ONE / EPS
RES = RES + ABS( XNORM-
$ MAX( ABS( X( 1, 1 ) ), ABS( X( 2,
$ 1 ) ) ) ) / MAX( SMLNUM, XNORM ) /
$ EPS
IF( INFO.NE.0 .AND. INFO.NE.1 )
$ RES = RES + ONE / EPS
KNT = KNT + 1
IF( RES.GT.RMAX ) THEN
LMAX = KNT
RMAX = RES
END IF
80 CONTINUE
90 CONTINUE
100 CONTINUE
*
NA = 2
NW = 2
DO 140 IA = 1, 3
A( 1, 1 ) = VAB( IA )*TWO
A( 1, 2 ) = -THREE*VAB( IA )
A( 2, 1 ) = -SEVEN*VAB( IA )
A( 2, 2 ) = TWNONE*VAB( IA )
DO 130 IB = 1, 3
B( 1, 1 ) = VAB( IB )
B( 2, 1 ) = -TWO*VAB( IB )
B( 1, 2 ) = FOUR*VAB( IB )
B( 2, 2 ) = -SEVEN*VAB( IB )
DO 120 IWR = 1, 4
IF( D1.EQ.ONE .AND. D2.EQ.ONE .AND. CA.EQ.
$ ONE ) THEN
WR = VWR( IWR )*A( 1, 1 )
ELSE
WR = VWR( IWR )
END IF
DO 110 IWI = 1, 4
IF( D1.EQ.ONE .AND. D2.EQ.ONE .AND.
$ CA.EQ.ONE ) THEN
WI = VWI( IWI )*A( 1, 1 )
ELSE
WI = VWI( IWI )
END IF
CALL DLALN2( LTRANS( ITRANS ), NA, NW,
$ SMIN, CA, A, 2, D1, D2, B,
$ 2, WR, WI, X, 2, SCALE,
$ XNORM, INFO )
IF( INFO.LT.0 )
$ NINFO( 1 ) = NINFO( 1 ) + 1
IF( INFO.GT.0 )
$ NINFO( 2 ) = NINFO( 2 ) + 1
IF( ITRANS.EQ.1 ) THEN
TMP = A( 1, 2 )
A( 1, 2 ) = A( 2, 1 )
A( 2, 1 ) = TMP
END IF
RES = ABS( ( CA*A( 1, 1 )-WR*D1 )*
$ X( 1, 1 )+( CA*A( 1, 2 ) )*
$ X( 2, 1 )+( WI*D1 )*X( 1, 2 )-
$ SCALE*B( 1, 1 ) )
RES = RES + ABS( ( CA*A( 1,
$ 1 )-WR*D1 )*X( 1, 2 )+
$ ( CA*A( 1, 2 ) )*X( 2, 2 )-
$ ( WI*D1 )*X( 1, 1 )-SCALE*
$ B( 1, 2 ) )
RES = RES + ABS( ( CA*A( 2, 1 ) )*
$ X( 1, 1 )+( CA*A( 2, 2 )-WR*D2 )*
$ X( 2, 1 )+( WI*D2 )*X( 2, 2 )-
$ SCALE*B( 2, 1 ) )
RES = RES + ABS( ( CA*A( 2, 1 ) )*
$ X( 1, 2 )+( CA*A( 2, 2 )-WR*D2 )*
$ X( 2, 2 )-( WI*D2 )*X( 2, 1 )-
$ SCALE*B( 2, 2 ) )
IF( INFO.EQ.0 ) THEN
DEN = MAX( EPS*( MAX( ABS( CA*A( 1,
$ 1 )-WR*D1 )+ABS( CA*A( 1,
$ 2 ) )+ABS( WI*D1 ),
$ ABS( CA*A( 2,
$ 1 ) )+ABS( CA*A( 2,
$ 2 )-WR*D2 )+ABS( WI*D2 ) )*
$ MAX( ABS( X( 1,
$ 1 ) )+ABS( X( 2, 1 ) ),
$ ABS( X( 1, 2 ) )+ABS( X( 2,
$ 2 ) ) ) ), SMLNUM )
ELSE
DEN = MAX( EPS*( MAX( SMIN / EPS,
$ MAX( ABS( CA*A( 1,
$ 1 )-WR*D1 )+ABS( CA*A( 1,
$ 2 ) )+ABS( WI*D1 ),
$ ABS( CA*A( 2,
$ 1 ) )+ABS( CA*A( 2,
$ 2 )-WR*D2 )+ABS( WI*D2 ) ) )*
$ MAX( ABS( X( 1,
$ 1 ) )+ABS( X( 2, 1 ) ),
$ ABS( X( 1, 2 ) )+ABS( X( 2,
$ 2 ) ) ) ), SMLNUM )
END IF
RES = RES / DEN
IF( ABS( X( 1, 1 ) ).LT.UNFL .AND.
$ ABS( X( 2, 1 ) ).LT.UNFL .AND.
$ ABS( X( 1, 2 ) ).LT.UNFL .AND.
$ ABS( X( 2, 2 ) ).LT.UNFL .AND.
$ ABS( B( 1, 1 ) )+
$ ABS( B( 2, 1 ) ).LE.SMLNUM*
$ ( ABS( CA*A( 1, 1 )-WR*D1 )+
$ ABS( CA*A( 1, 2 ) )+ABS( CA*A( 2,
$ 1 ) )+ABS( CA*A( 2,
$ 2 )-WR*D2 )+ABS( WI*D2 )+ABS( WI*
$ D1 ) ) )RES = ZERO
IF( SCALE.GT.ONE )
$ RES = RES + ONE / EPS
RES = RES + ABS( XNORM-
$ MAX( ABS( X( 1, 1 ) )+ABS( X( 1,
$ 2 ) ), ABS( X( 2,
$ 1 ) )+ABS( X( 2, 2 ) ) ) ) /
$ MAX( SMLNUM, XNORM ) / EPS
IF( INFO.NE.0 .AND. INFO.NE.1 )
$ RES = RES + ONE / EPS
KNT = KNT + 1
IF( RES.GT.RMAX ) THEN
LMAX = KNT
RMAX = RES
END IF
110 CONTINUE
120 CONTINUE
130 CONTINUE
140 CONTINUE
150 CONTINUE
160 CONTINUE
170 CONTINUE
180 CONTINUE
190 CONTINUE
*
RETURN
*
* End of DGET31
*
END
SUBROUTINE DGET32( RMAX, LMAX, NINFO, KNT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KNT, LMAX, NINFO
DOUBLE PRECISION RMAX
* ..
*
* Purpose
* =======
*
* DGET32 tests DLASY2, a routine for solving
*
* op(TL)*X + ISGN*X*op(TR) = SCALE*B
*
* where TL is N1 by N1, TR is N2 by N2, and N1,N2 =1 or 2 only.
* X and B are N1 by N2, op() is an optional transpose, an
* ISGN = 1 or -1. SCALE is chosen less than or equal to 1 to
* avoid overflow in X.
*
* The test condition is that the scaled residual
*
* norm( op(TL)*X + ISGN*X*op(TR) = SCALE*B )
* / ( max( ulp*norm(TL), ulp*norm(TR)) * norm(X), SMLNUM )
*
* should be on the order of 1. Here, ulp is the machine precision.
* Also, it is verified that SCALE is less than or equal to 1, and
* that XNORM = infinity-norm(X).
*
* Arguments
* ==========
*
* RMAX (output) DOUBLE PRECISION
* Value of the largest test ratio.
*
* LMAX (output) INTEGER
* Example number where largest test ratio achieved.
*
* NINFO (output) INTEGER
* Number of examples returned with INFO.NE.0.
*
* KNT (output) INTEGER
* Total number of examples tested.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
DOUBLE PRECISION TWO, FOUR, EIGHT
PARAMETER ( TWO = 2.0D0, FOUR = 4.0D0, EIGHT = 8.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LTRANL, LTRANR
INTEGER IB, IB1, IB2, IB3, INFO, ISGN, ITL, ITLSCL,
$ ITR, ITRANL, ITRANR, ITRSCL, N1, N2
DOUBLE PRECISION BIGNUM, DEN, EPS, RES, SCALE, SGN, SMLNUM, TMP,
$ TNRM, XNORM, XNRM
* ..
* .. Local Arrays ..
INTEGER ITVAL( 2, 2, 8 )
DOUBLE PRECISION B( 2, 2 ), TL( 2, 2 ), TR( 2, 2 ), VAL( 3 ),
$ X( 2, 2 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DLABAD, DLASY2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Data statements ..
DATA ITVAL / 8, 4, 2, 1, 4, 8, 1, 2, 2, 1, 8, 4, 1,
$ 2, 4, 8, 9, 4, 2, 1, 4, 9, 1, 2, 2, 1, 9, 4, 1,
$ 2, 4, 9 /
* ..
* .. Executable Statements ..
*
* Get machine parameters
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' ) / EPS
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
*
* Set up test case parameters
*
VAL( 1 ) = SQRT( SMLNUM )
VAL( 2 ) = ONE
VAL( 3 ) = SQRT( BIGNUM )
*
KNT = 0
NINFO = 0
LMAX = 0
RMAX = ZERO
*
* Begin test loop
*
DO 230 ITRANL = 0, 1
DO 220 ITRANR = 0, 1
DO 210 ISGN = -1, 1, 2
SGN = ISGN
LTRANL = ITRANL.EQ.1
LTRANR = ITRANR.EQ.1
*
N1 = 1
N2 = 1
DO 30 ITL = 1, 3
DO 20 ITR = 1, 3
DO 10 IB = 1, 3
TL( 1, 1 ) = VAL( ITL )
TR( 1, 1 ) = VAL( ITR )
B( 1, 1 ) = VAL( IB )
KNT = KNT + 1
CALL DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL,
$ 2, TR, 2, B, 2, SCALE, X, 2, XNORM,
$ INFO )
IF( INFO.NE.0 )
$ NINFO = NINFO + 1
RES = ABS( ( TL( 1, 1 )+SGN*TR( 1, 1 ) )*
$ X( 1, 1 )-SCALE*B( 1, 1 ) )
IF( INFO.EQ.0 ) THEN
DEN = MAX( EPS*( ( ABS( TR( 1,
$ 1 ) )+ABS( TL( 1, 1 ) ) )*ABS( X( 1,
$ 1 ) ) ), SMLNUM )
ELSE
DEN = SMLNUM*MAX( ABS( X( 1, 1 ) ), ONE )
END IF
RES = RES / DEN
IF( SCALE.GT.ONE )
$ RES = RES + ONE / EPS
RES = RES + ABS( XNORM-ABS( X( 1, 1 ) ) ) /
$ MAX( SMLNUM, XNORM ) / EPS
IF( INFO.NE.0 .AND. INFO.NE.1 )
$ RES = RES + ONE / EPS
IF( RES.GT.RMAX ) THEN
LMAX = KNT
RMAX = RES
END IF
10 CONTINUE
20 CONTINUE
30 CONTINUE
*
N1 = 2
N2 = 1
DO 80 ITL = 1, 8
DO 70 ITLSCL = 1, 3
DO 60 ITR = 1, 3
DO 50 IB1 = 1, 3
DO 40 IB2 = 1, 3
B( 1, 1 ) = VAL( IB1 )
B( 2, 1 ) = -FOUR*VAL( IB2 )
TL( 1, 1 ) = ITVAL( 1, 1, ITL )*
$ VAL( ITLSCL )
TL( 2, 1 ) = ITVAL( 2, 1, ITL )*
$ VAL( ITLSCL )
TL( 1, 2 ) = ITVAL( 1, 2, ITL )*
$ VAL( ITLSCL )
TL( 2, 2 ) = ITVAL( 2, 2, ITL )*
$ VAL( ITLSCL )
TR( 1, 1 ) = VAL( ITR )
KNT = KNT + 1
CALL DLASY2( LTRANL, LTRANR, ISGN, N1, N2,
$ TL, 2, TR, 2, B, 2, SCALE, X,
$ 2, XNORM, INFO )
IF( INFO.NE.0 )
$ NINFO = NINFO + 1
IF( LTRANL ) THEN
TMP = TL( 1, 2 )
TL( 1, 2 ) = TL( 2, 1 )
TL( 2, 1 ) = TMP
END IF
RES = ABS( ( TL( 1, 1 )+SGN*TR( 1, 1 ) )*
$ X( 1, 1 )+TL( 1, 2 )*X( 2, 1 )-
$ SCALE*B( 1, 1 ) )
RES = RES + ABS( ( TL( 2, 2 )+SGN*TR( 1,
$ 1 ) )*X( 2, 1 )+TL( 2, 1 )*
$ X( 1, 1 )-SCALE*B( 2, 1 ) )
TNRM = ABS( TR( 1, 1 ) ) +
$ ABS( TL( 1, 1 ) ) +
$ ABS( TL( 1, 2 ) ) +
$ ABS( TL( 2, 1 ) ) +
$ ABS( TL( 2, 2 ) )
XNRM = MAX( ABS( X( 1, 1 ) ),
$ ABS( X( 2, 1 ) ) )
DEN = MAX( SMLNUM, SMLNUM*XNRM,
$ ( TNRM*EPS )*XNRM )
RES = RES / DEN
IF( SCALE.GT.ONE )
$ RES = RES + ONE / EPS
RES = RES + ABS( XNORM-XNRM ) /
$ MAX( SMLNUM, XNORM ) / EPS
IF( RES.GT.RMAX ) THEN
LMAX = KNT
RMAX = RES
END IF
40 CONTINUE
50 CONTINUE
60 CONTINUE
70 CONTINUE
80 CONTINUE
*
N1 = 1
N2 = 2
DO 130 ITR = 1, 8
DO 120 ITRSCL = 1, 3
DO 110 ITL = 1, 3
DO 100 IB1 = 1, 3
DO 90 IB2 = 1, 3
B( 1, 1 ) = VAL( IB1 )
B( 1, 2 ) = -TWO*VAL( IB2 )
TR( 1, 1 ) = ITVAL( 1, 1, ITR )*
$ VAL( ITRSCL )
TR( 2, 1 ) = ITVAL( 2, 1, ITR )*
$ VAL( ITRSCL )
TR( 1, 2 ) = ITVAL( 1, 2, ITR )*
$ VAL( ITRSCL )
TR( 2, 2 ) = ITVAL( 2, 2, ITR )*
$ VAL( ITRSCL )
TL( 1, 1 ) = VAL( ITL )
KNT = KNT + 1
CALL DLASY2( LTRANL, LTRANR, ISGN, N1, N2,
$ TL, 2, TR, 2, B, 2, SCALE, X,
$ 2, XNORM, INFO )
IF( INFO.NE.0 )
$ NINFO = NINFO + 1
IF( LTRANR ) THEN
TMP = TR( 1, 2 )
TR( 1, 2 ) = TR( 2, 1 )
TR( 2, 1 ) = TMP
END IF
TNRM = ABS( TL( 1, 1 ) ) +
$ ABS( TR( 1, 1 ) ) +
$ ABS( TR( 1, 2 ) ) +
$ ABS( TR( 2, 2 ) ) +
$ ABS( TR( 2, 1 ) )
XNRM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) )
RES = ABS( ( ( TL( 1, 1 )+SGN*TR( 1,
$ 1 ) ) )*( X( 1, 1 ) )+
$ ( SGN*TR( 2, 1 ) )*( X( 1, 2 ) )-
$ ( SCALE*B( 1, 1 ) ) )
RES = RES + ABS( ( ( TL( 1, 1 )+SGN*TR( 2,
$ 2 ) ) )*( X( 1, 2 ) )+
$ ( SGN*TR( 1, 2 ) )*( X( 1, 1 ) )-
$ ( SCALE*B( 1, 2 ) ) )
DEN = MAX( SMLNUM, SMLNUM*XNRM,
$ ( TNRM*EPS )*XNRM )
RES = RES / DEN
IF( SCALE.GT.ONE )
$ RES = RES + ONE / EPS
RES = RES + ABS( XNORM-XNRM ) /
$ MAX( SMLNUM, XNORM ) / EPS
IF( RES.GT.RMAX ) THEN
LMAX = KNT
RMAX = RES
END IF
90 CONTINUE
100 CONTINUE
110 CONTINUE
120 CONTINUE
130 CONTINUE
*
N1 = 2
N2 = 2
DO 200 ITR = 1, 8
DO 190 ITRSCL = 1, 3
DO 180 ITL = 1, 8
DO 170 ITLSCL = 1, 3
DO 160 IB1 = 1, 3
DO 150 IB2 = 1, 3
DO 140 IB3 = 1, 3
B( 1, 1 ) = VAL( IB1 )
B( 2, 1 ) = -FOUR*VAL( IB2 )
B( 1, 2 ) = -TWO*VAL( IB3 )
B( 2, 2 ) = EIGHT*
$ MIN( VAL( IB1 ), VAL
$ ( IB2 ), VAL( IB3 ) )
TR( 1, 1 ) = ITVAL( 1, 1, ITR )*
$ VAL( ITRSCL )
TR( 2, 1 ) = ITVAL( 2, 1, ITR )*
$ VAL( ITRSCL )
TR( 1, 2 ) = ITVAL( 1, 2, ITR )*
$ VAL( ITRSCL )
TR( 2, 2 ) = ITVAL( 2, 2, ITR )*
$ VAL( ITRSCL )
TL( 1, 1 ) = ITVAL( 1, 1, ITL )*
$ VAL( ITLSCL )
TL( 2, 1 ) = ITVAL( 2, 1, ITL )*
$ VAL( ITLSCL )
TL( 1, 2 ) = ITVAL( 1, 2, ITL )*
$ VAL( ITLSCL )
TL( 2, 2 ) = ITVAL( 2, 2, ITL )*
$ VAL( ITLSCL )
KNT = KNT + 1
CALL DLASY2( LTRANL, LTRANR, ISGN,
$ N1, N2, TL, 2, TR, 2,
$ B, 2, SCALE, X, 2,
$ XNORM, INFO )
IF( INFO.NE.0 )
$ NINFO = NINFO + 1
IF( LTRANR ) THEN
TMP = TR( 1, 2 )
TR( 1, 2 ) = TR( 2, 1 )
TR( 2, 1 ) = TMP
END IF
IF( LTRANL ) THEN
TMP = TL( 1, 2 )
TL( 1, 2 ) = TL( 2, 1 )
TL( 2, 1 ) = TMP
END IF
TNRM = ABS( TR( 1, 1 ) ) +
$ ABS( TR( 2, 1 ) ) +
$ ABS( TR( 1, 2 ) ) +
$ ABS( TR( 2, 2 ) ) +
$ ABS( TL( 1, 1 ) ) +
$ ABS( TL( 2, 1 ) ) +
$ ABS( TL( 1, 2 ) ) +
$ ABS( TL( 2, 2 ) )
XNRM = MAX( ABS( X( 1, 1 ) )+
$ ABS( X( 1, 2 ) ),
$ ABS( X( 2, 1 ) )+
$ ABS( X( 2, 2 ) ) )
RES = ABS( ( ( TL( 1, 1 )+SGN*TR( 1,
$ 1 ) ) )*( X( 1, 1 ) )+
$ ( SGN*TR( 2, 1 ) )*
$ ( X( 1, 2 ) )+( TL( 1, 2 ) )*
$ ( X( 2, 1 ) )-
$ ( SCALE*B( 1, 1 ) ) )
RES = RES + ABS( ( TL( 1, 1 ) )*
$ ( X( 1, 2 ) )+
$ ( SGN*TR( 1, 2 ) )*
$ ( X( 1, 1 ) )+
$ ( SGN*TR( 2, 2 ) )*
$ ( X( 1, 2 ) )+( TL( 1, 2 ) )*
$ ( X( 2, 2 ) )-
$ ( SCALE*B( 1, 2 ) ) )
RES = RES + ABS( ( TL( 2, 1 ) )*
$ ( X( 1, 1 ) )+
$ ( SGN*TR( 1, 1 ) )*
$ ( X( 2, 1 ) )+
$ ( SGN*TR( 2, 1 ) )*
$ ( X( 2, 2 ) )+( TL( 2, 2 ) )*
$ ( X( 2, 1 ) )-
$ ( SCALE*B( 2, 1 ) ) )
RES = RES + ABS( ( ( TL( 2,
$ 2 )+SGN*TR( 2, 2 ) ) )*
$ ( X( 2, 2 ) )+
$ ( SGN*TR( 1, 2 ) )*
$ ( X( 2, 1 ) )+( TL( 2, 1 ) )*
$ ( X( 1, 2 ) )-
$ ( SCALE*B( 2, 2 ) ) )
DEN = MAX( SMLNUM, SMLNUM*XNRM,
$ ( TNRM*EPS )*XNRM )
RES = RES / DEN
IF( SCALE.GT.ONE )
$ RES = RES + ONE / EPS
RES = RES + ABS( XNORM-XNRM ) /
$ MAX( SMLNUM, XNORM ) / EPS
IF( RES.GT.RMAX ) THEN
LMAX = KNT
RMAX = RES
END IF
140 CONTINUE
150 CONTINUE
160 CONTINUE
170 CONTINUE
180 CONTINUE
190 CONTINUE
200 CONTINUE
210 CONTINUE
220 CONTINUE
230 CONTINUE
*
RETURN
*
* End of DGET32
*
END
SUBROUTINE DGET33( RMAX, LMAX, NINFO, KNT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KNT, LMAX, NINFO
DOUBLE PRECISION RMAX
* ..
*
* Purpose
* =======
*
* DGET33 tests DLANV2, a routine for putting 2 by 2 blocks into
* standard form. In other words, it computes a two by two rotation
* [[C,S];[-S,C]] where in
*
* [ C S ][T(1,1) T(1,2)][ C -S ] = [ T11 T12 ]
* [-S C ][T(2,1) T(2,2)][ S C ] [ T21 T22 ]
*
* either
* 1) T21=0 (real eigenvalues), or
* 2) T11=T22 and T21*T12<0 (complex conjugate eigenvalues).
* We also verify that the residual is small.
*
* Arguments
* ==========
*
* RMAX (output) DOUBLE PRECISION
* Value of the largest test ratio.
*
* LMAX (output) INTEGER
* Example number where largest test ratio achieved.
*
* NINFO (output) INTEGER
* Number of examples returned with INFO .NE. 0.
*
* KNT (output) INTEGER
* Total number of examples tested.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
DOUBLE PRECISION TWO, FOUR
PARAMETER ( TWO = 2.0D0, FOUR = 4.0D0 )
* ..
* .. Local Scalars ..
INTEGER I1, I2, I3, I4, IM1, IM2, IM3, IM4, J1, J2, J3
DOUBLE PRECISION BIGNUM, CS, EPS, RES, SMLNUM, SN, SUM, TNRM,
$ WI1, WI2, WR1, WR2
* ..
* .. Local Arrays ..
DOUBLE PRECISION Q( 2, 2 ), T( 2, 2 ), T1( 2, 2 ), T2( 2, 2 ),
$ VAL( 4 ), VM( 3 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DLABAD, DLANV2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SIGN
* ..
* .. Executable Statements ..
*
* Get machine parameters
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' ) / EPS
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
*
* Set up test case parameters
*
VAL( 1 ) = ONE
VAL( 2 ) = ONE + TWO*EPS
VAL( 3 ) = TWO
VAL( 4 ) = TWO - FOUR*EPS
VM( 1 ) = SMLNUM
VM( 2 ) = ONE
VM( 3 ) = BIGNUM
*
KNT = 0
NINFO = 0
LMAX = 0
RMAX = ZERO
*
* Begin test loop
*
DO 150 I1 = 1, 4
DO 140 I2 = 1, 4
DO 130 I3 = 1, 4
DO 120 I4 = 1, 4
DO 110 IM1 = 1, 3
DO 100 IM2 = 1, 3
DO 90 IM3 = 1, 3
DO 80 IM4 = 1, 3
T( 1, 1 ) = VAL( I1 )*VM( IM1 )
T( 1, 2 ) = VAL( I2 )*VM( IM2 )
T( 2, 1 ) = -VAL( I3 )*VM( IM3 )
T( 2, 2 ) = VAL( I4 )*VM( IM4 )
TNRM = MAX( ABS( T( 1, 1 ) ),
$ ABS( T( 1, 2 ) ), ABS( T( 2, 1 ) ),
$ ABS( T( 2, 2 ) ) )
T1( 1, 1 ) = T( 1, 1 )
T1( 1, 2 ) = T( 1, 2 )
T1( 2, 1 ) = T( 2, 1 )
T1( 2, 2 ) = T( 2, 2 )
Q( 1, 1 ) = ONE
Q( 1, 2 ) = ZERO
Q( 2, 1 ) = ZERO
Q( 2, 2 ) = ONE
*
CALL DLANV2( T( 1, 1 ), T( 1, 2 ),
$ T( 2, 1 ), T( 2, 2 ), WR1,
$ WI1, WR2, WI2, CS, SN )
DO 10 J1 = 1, 2
RES = Q( J1, 1 )*CS + Q( J1, 2 )*SN
Q( J1, 2 ) = -Q( J1, 1 )*SN +
$ Q( J1, 2 )*CS
Q( J1, 1 ) = RES
10 CONTINUE
*
RES = ZERO
RES = RES + ABS( Q( 1, 1 )**2+
$ Q( 1, 2 )**2-ONE ) / EPS
RES = RES + ABS( Q( 2, 2 )**2+
$ Q( 2, 1 )**2-ONE ) / EPS
RES = RES + ABS( Q( 1, 1 )*Q( 2, 1 )+
$ Q( 1, 2 )*Q( 2, 2 ) ) / EPS
DO 40 J1 = 1, 2
DO 30 J2 = 1, 2
T2( J1, J2 ) = ZERO
DO 20 J3 = 1, 2
T2( J1, J2 ) = T2( J1, J2 ) +
$ T1( J1, J3 )*
$ Q( J3, J2 )
20 CONTINUE
30 CONTINUE
40 CONTINUE
DO 70 J1 = 1, 2
DO 60 J2 = 1, 2
SUM = T( J1, J2 )
DO 50 J3 = 1, 2
SUM = SUM - Q( J3, J1 )*
$ T2( J3, J2 )
50 CONTINUE
RES = RES + ABS( SUM ) / EPS / TNRM
60 CONTINUE
70 CONTINUE
IF( T( 2, 1 ).NE.ZERO .AND.
$ ( T( 1, 1 ).NE.T( 2,
$ 2 ) .OR. SIGN( ONE, T( 1,
$ 2 ) )*SIGN( ONE, T( 2,
$ 1 ) ).GT.ZERO ) )RES = RES + ONE / EPS
KNT = KNT + 1
IF( RES.GT.RMAX ) THEN
LMAX = KNT
RMAX = RES
END IF
80 CONTINUE
90 CONTINUE
100 CONTINUE
110 CONTINUE
120 CONTINUE
130 CONTINUE
140 CONTINUE
150 CONTINUE
*
RETURN
*
* End of DGET33
*
END
SUBROUTINE DGET34( RMAX, LMAX, NINFO, KNT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KNT, LMAX
DOUBLE PRECISION RMAX
* ..
* .. Array Arguments ..
INTEGER NINFO( 2 )
* ..
*
* Purpose
* =======
*
* DGET34 tests DLAEXC, a routine for swapping adjacent blocks (either
* 1 by 1 or 2 by 2) on the diagonal of a matrix in real Schur form.
* Thus, DLAEXC computes an orthogonal matrix Q such that
*
* Q' * [ A B ] * Q = [ C1 B1 ]
* [ 0 C ] [ 0 A1 ]
*
* where C1 is similar to C and A1 is similar to A. Both A and C are
* assumed to be in standard form (equal diagonal entries and
* offdiagonal with differing signs) and A1 and C1 are returned with the
* same properties.
*
* The test code verifies these last last assertions, as well as that
* the residual in the above equation is small.
*
* Arguments
* ==========
*
* RMAX (output) DOUBLE PRECISION
* Value of the largest test ratio.
*
* LMAX (output) INTEGER
* Example number where largest test ratio achieved.
*
* NINFO (output) INTEGER array, dimension (2)
* NINFO(J) is the number of examples where INFO=J occurred.
*
* KNT (output) INTEGER
* Total number of examples tested.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
DOUBLE PRECISION TWO, THREE
PARAMETER ( TWO = 2.0D0, THREE = 3.0D0 )
INTEGER LWORK
PARAMETER ( LWORK = 32 )
* ..
* .. Local Scalars ..
INTEGER I, IA, IA11, IA12, IA21, IA22, IAM, IB, IC,
$ IC11, IC12, IC21, IC22, ICM, INFO, J
DOUBLE PRECISION BIGNUM, EPS, RES, SMLNUM, TNRM
* ..
* .. Local Arrays ..
DOUBLE PRECISION Q( 4, 4 ), RESULT( 2 ), T( 4, 4 ), T1( 4, 4 ),
$ VAL( 9 ), VM( 2 ), WORK( LWORK )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DHST01, DLABAD, DLAEXC
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Get machine parameters
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' ) / EPS
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
*
* Set up test case parameters
*
VAL( 1 ) = ZERO
VAL( 2 ) = SQRT( SMLNUM )
VAL( 3 ) = ONE
VAL( 4 ) = TWO
VAL( 5 ) = SQRT( BIGNUM )
VAL( 6 ) = -SQRT( SMLNUM )
VAL( 7 ) = -ONE
VAL( 8 ) = -TWO
VAL( 9 ) = -SQRT( BIGNUM )
VM( 1 ) = ONE
VM( 2 ) = ONE + TWO*EPS
CALL DCOPY( 16, VAL( 4 ), 0, T( 1, 1 ), 1 )
*
NINFO( 1 ) = 0
NINFO( 2 ) = 0
KNT = 0
LMAX = 0
RMAX = ZERO
*
* Begin test loop
*
DO 40 IA = 1, 9
DO 30 IAM = 1, 2
DO 20 IB = 1, 9
DO 10 IC = 1, 9
T( 1, 1 ) = VAL( IA )*VM( IAM )
T( 2, 2 ) = VAL( IC )
T( 1, 2 ) = VAL( IB )
T( 2, 1 ) = ZERO
TNRM = MAX( ABS( T( 1, 1 ) ), ABS( T( 2, 2 ) ),
$ ABS( T( 1, 2 ) ) )
CALL DCOPY( 16, T, 1, T1, 1 )
CALL DCOPY( 16, VAL( 1 ), 0, Q, 1 )
CALL DCOPY( 4, VAL( 3 ), 0, Q, 5 )
CALL DLAEXC( .TRUE., 2, T, 4, Q, 4, 1, 1, 1, WORK,
$ INFO )
IF( INFO.NE.0 )
$ NINFO( INFO ) = NINFO( INFO ) + 1
CALL DHST01( 2, 1, 2, T1, 4, T, 4, Q, 4, WORK, LWORK,
$ RESULT )
RES = RESULT( 1 ) + RESULT( 2 )
IF( INFO.NE.0 )
$ RES = RES + ONE / EPS
IF( T( 1, 1 ).NE.T1( 2, 2 ) )
$ RES = RES + ONE / EPS
IF( T( 2, 2 ).NE.T1( 1, 1 ) )
$ RES = RES + ONE / EPS
IF( T( 2, 1 ).NE.ZERO )
$ RES = RES + ONE / EPS
KNT = KNT + 1
IF( RES.GT.RMAX ) THEN
LMAX = KNT
RMAX = RES
END IF
10 CONTINUE
20 CONTINUE
30 CONTINUE
40 CONTINUE
*
DO 110 IA = 1, 5
DO 100 IAM = 1, 2
DO 90 IB = 1, 5
DO 80 IC11 = 1, 5
DO 70 IC12 = 2, 5
DO 60 IC21 = 2, 4
DO 50 IC22 = -1, 1, 2
T( 1, 1 ) = VAL( IA )*VM( IAM )
T( 1, 2 ) = VAL( IB )
T( 1, 3 ) = -TWO*VAL( IB )
T( 2, 1 ) = ZERO
T( 2, 2 ) = VAL( IC11 )
T( 2, 3 ) = VAL( IC12 )
T( 3, 1 ) = ZERO
T( 3, 2 ) = -VAL( IC21 )
T( 3, 3 ) = VAL( IC11 )*DBLE( IC22 )
TNRM = MAX( ABS( T( 1, 1 ) ),
$ ABS( T( 1, 2 ) ), ABS( T( 1, 3 ) ),
$ ABS( T( 2, 2 ) ), ABS( T( 2, 3 ) ),
$ ABS( T( 3, 2 ) ), ABS( T( 3, 3 ) ) )
CALL DCOPY( 16, T, 1, T1, 1 )
CALL DCOPY( 16, VAL( 1 ), 0, Q, 1 )
CALL DCOPY( 4, VAL( 3 ), 0, Q, 5 )
CALL DLAEXC( .TRUE., 3, T, 4, Q, 4, 1, 1, 2,
$ WORK, INFO )
IF( INFO.NE.0 )
$ NINFO( INFO ) = NINFO( INFO ) + 1
CALL DHST01( 3, 1, 3, T1, 4, T, 4, Q, 4,
$ WORK, LWORK, RESULT )
RES = RESULT( 1 ) + RESULT( 2 )
IF( INFO.EQ.0 ) THEN
IF( T1( 1, 1 ).NE.T( 3, 3 ) )
$ RES = RES + ONE / EPS
IF( T( 3, 1 ).NE.ZERO )
$ RES = RES + ONE / EPS
IF( T( 3, 2 ).NE.ZERO )
$ RES = RES + ONE / EPS
IF( T( 2, 1 ).NE.0 .AND.
$ ( T( 1, 1 ).NE.T( 2,
$ 2 ) .OR. SIGN( ONE, T( 1,
$ 2 ) ).EQ.SIGN( ONE, T( 2, 1 ) ) ) )
$ RES = RES + ONE / EPS
END IF
KNT = KNT + 1
IF( RES.GT.RMAX ) THEN
LMAX = KNT
RMAX = RES
END IF
50 CONTINUE
60 CONTINUE
70 CONTINUE
80 CONTINUE
90 CONTINUE
100 CONTINUE
110 CONTINUE
*
DO 180 IA11 = 1, 5
DO 170 IA12 = 2, 5
DO 160 IA21 = 2, 4
DO 150 IA22 = -1, 1, 2
DO 140 ICM = 1, 2
DO 130 IB = 1, 5
DO 120 IC = 1, 5
T( 1, 1 ) = VAL( IA11 )
T( 1, 2 ) = VAL( IA12 )
T( 1, 3 ) = -TWO*VAL( IB )
T( 2, 1 ) = -VAL( IA21 )
T( 2, 2 ) = VAL( IA11 )*DBLE( IA22 )
T( 2, 3 ) = VAL( IB )
T( 3, 1 ) = ZERO
T( 3, 2 ) = ZERO
T( 3, 3 ) = VAL( IC )*VM( ICM )
TNRM = MAX( ABS( T( 1, 1 ) ),
$ ABS( T( 1, 2 ) ), ABS( T( 1, 3 ) ),
$ ABS( T( 2, 2 ) ), ABS( T( 2, 3 ) ),
$ ABS( T( 3, 2 ) ), ABS( T( 3, 3 ) ) )
CALL DCOPY( 16, T, 1, T1, 1 )
CALL DCOPY( 16, VAL( 1 ), 0, Q, 1 )
CALL DCOPY( 4, VAL( 3 ), 0, Q, 5 )
CALL DLAEXC( .TRUE., 3, T, 4, Q, 4, 1, 2, 1,
$ WORK, INFO )
IF( INFO.NE.0 )
$ NINFO( INFO ) = NINFO( INFO ) + 1
CALL DHST01( 3, 1, 3, T1, 4, T, 4, Q, 4,
$ WORK, LWORK, RESULT )
RES = RESULT( 1 ) + RESULT( 2 )
IF( INFO.EQ.0 ) THEN
IF( T1( 3, 3 ).NE.T( 1, 1 ) )
$ RES = RES + ONE / EPS
IF( T( 2, 1 ).NE.ZERO )
$ RES = RES + ONE / EPS
IF( T( 3, 1 ).NE.ZERO )
$ RES = RES + ONE / EPS
IF( T( 3, 2 ).NE.0 .AND.
$ ( T( 2, 2 ).NE.T( 3,
$ 3 ) .OR. SIGN( ONE, T( 2,
$ 3 ) ).EQ.SIGN( ONE, T( 3, 2 ) ) ) )
$ RES = RES + ONE / EPS
END IF
KNT = KNT + 1
IF( RES.GT.RMAX ) THEN
LMAX = KNT
RMAX = RES
END IF
120 CONTINUE
130 CONTINUE
140 CONTINUE
150 CONTINUE
160 CONTINUE
170 CONTINUE
180 CONTINUE
*
DO 300 IA11 = 1, 5
DO 290 IA12 = 2, 5
DO 280 IA21 = 2, 4
DO 270 IA22 = -1, 1, 2
DO 260 IB = 1, 5
DO 250 IC11 = 3, 4
DO 240 IC12 = 3, 4
DO 230 IC21 = 3, 4
DO 220 IC22 = -1, 1, 2
DO 210 ICM = 5, 7
IAM = 1
T( 1, 1 ) = VAL( IA11 )*VM( IAM )
T( 1, 2 ) = VAL( IA12 )*VM( IAM )
T( 1, 3 ) = -TWO*VAL( IB )
T( 1, 4 ) = HALF*VAL( IB )
T( 2, 1 ) = -T( 1, 2 )*VAL( IA21 )
T( 2, 2 ) = VAL( IA11 )*
$ DBLE( IA22 )*VM( IAM )
T( 2, 3 ) = VAL( IB )
T( 2, 4 ) = THREE*VAL( IB )
T( 3, 1 ) = ZERO
T( 3, 2 ) = ZERO
T( 3, 3 ) = VAL( IC11 )*
$ ABS( VAL( ICM ) )
T( 3, 4 ) = VAL( IC12 )*
$ ABS( VAL( ICM ) )
T( 4, 1 ) = ZERO
T( 4, 2 ) = ZERO
T( 4, 3 ) = -T( 3, 4 )*VAL( IC21 )*
$ ABS( VAL( ICM ) )
T( 4, 4 ) = VAL( IC11 )*
$ DBLE( IC22 )*
$ ABS( VAL( ICM ) )
TNRM = ZERO
DO 200 I = 1, 4
DO 190 J = 1, 4
TNRM = MAX( TNRM,
$ ABS( T( I, J ) ) )
190 CONTINUE
200 CONTINUE
CALL DCOPY( 16, T, 1, T1, 1 )
CALL DCOPY( 16, VAL( 1 ), 0, Q, 1 )
CALL DCOPY( 4, VAL( 3 ), 0, Q, 5 )
CALL DLAEXC( .TRUE., 4, T, 4, Q, 4,
$ 1, 2, 2, WORK, INFO )
IF( INFO.NE.0 )
$ NINFO( INFO ) = NINFO( INFO ) + 1
CALL DHST01( 4, 1, 4, T1, 4, T, 4,
$ Q, 4, WORK, LWORK,
$ RESULT )
RES = RESULT( 1 ) + RESULT( 2 )
IF( INFO.EQ.0 ) THEN
IF( T( 3, 1 ).NE.ZERO )
$ RES = RES + ONE / EPS
IF( T( 4, 1 ).NE.ZERO )
$ RES = RES + ONE / EPS
IF( T( 3, 2 ).NE.ZERO )
$ RES = RES + ONE / EPS
IF( T( 4, 2 ).NE.ZERO )
$ RES = RES + ONE / EPS
IF( T( 2, 1 ).NE.0 .AND.
$ ( T( 1, 1 ).NE.T( 2,
$ 2 ) .OR. SIGN( ONE, T( 1,
$ 2 ) ).EQ.SIGN( ONE, T( 2,
$ 1 ) ) ) )RES = RES +
$ ONE / EPS
IF( T( 4, 3 ).NE.0 .AND.
$ ( T( 3, 3 ).NE.T( 4,
$ 4 ) .OR. SIGN( ONE, T( 3,
$ 4 ) ).EQ.SIGN( ONE, T( 4,
$ 3 ) ) ) )RES = RES +
$ ONE / EPS
END IF
KNT = KNT + 1
IF( RES.GT.RMAX ) THEN
LMAX = KNT
RMAX = RES
END IF
210 CONTINUE
220 CONTINUE
230 CONTINUE
240 CONTINUE
250 CONTINUE
260 CONTINUE
270 CONTINUE
280 CONTINUE
290 CONTINUE
300 CONTINUE
*
RETURN
*
* End of DGET34
*
END
SUBROUTINE DGET35( RMAX, LMAX, NINFO, KNT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KNT, LMAX, NINFO
DOUBLE PRECISION RMAX
* ..
*
* Purpose
* =======
*
* DGET35 tests DTRSYL, a routine for solving the Sylvester matrix
* equation
*
* op(A)*X + ISGN*X*op(B) = scale*C,
*
* A and B are assumed to be in Schur canonical form, op() represents an
* optional transpose, and ISGN can be -1 or +1. Scale is an output
* less than or equal to 1, chosen to avoid overflow in X.
*
* The test code verifies that the following residual is order 1:
*
* norm(op(A)*X + ISGN*X*op(B) - scale*C) /
* (EPS*max(norm(A),norm(B))*norm(X))
*
* Arguments
* ==========
*
* RMAX (output) DOUBLE PRECISION
* Value of the largest test ratio.
*
* LMAX (output) INTEGER
* Example number where largest test ratio achieved.
*
* NINFO (output) INTEGER
* Number of examples where INFO is nonzero.
*
* KNT (output) INTEGER
* Total number of examples tested.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
DOUBLE PRECISION TWO, FOUR
PARAMETER ( TWO = 2.0D0, FOUR = 4.0D0 )
* ..
* .. Local Scalars ..
CHARACTER TRANA, TRANB
INTEGER I, IMA, IMB, IMLDA1, IMLDA2, IMLDB1, IMLOFF,
$ INFO, ISGN, ITRANA, ITRANB, J, M, N
DOUBLE PRECISION BIGNUM, CNRM, EPS, RES, RES1, RMUL, SCALE,
$ SMLNUM, TNRM, XNRM
* ..
* .. Local Arrays ..
INTEGER IDIM( 8 ), IVAL( 6, 6, 8 )
DOUBLE PRECISION A( 6, 6 ), B( 6, 6 ), C( 6, 6 ), CC( 6, 6 ),
$ DUM( 1 ), VM1( 3 ), VM2( 3 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLABAD, DTRSYL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, SIN, SQRT
* ..
* .. Data statements ..
DATA IDIM / 1, 2, 3, 4, 3, 3, 6, 4 /
DATA IVAL / 1, 35*0, 1, 2, 4*0, -2, 0, 28*0, 1, 5*0,
$ 5, 1, 2, 3*0, -8, -2, 1, 21*0, 3, 4, 4*0, -5,
$ 3, 4*0, 1, 2, 1, 4, 2*0, -3, -9, -1, 1, 14*0,
$ 1, 5*0, 2, 3, 4*0, 5, 6, 7, 21*0, 1, 5*0, 1, 3,
$ -4, 3*0, 2, 5, 2, 21*0, 1, 2, 4*0, -2, 0, 4*0,
$ 5, 6, 3, 4, 2*0, -1, -9, -5, 2, 2*0, 4*8, 5, 6,
$ 4*9, -7, 5, 1, 5*0, 1, 5, 2, 3*0, 2, -21, 5,
$ 3*0, 1, 2, 3, 4, 14*0 /
* ..
* .. Executable Statements ..
*
* Get machine parameters
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' )*FOUR / EPS
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
*
* Set up test case parameters
*
VM1( 1 ) = SQRT( SMLNUM )
VM1( 2 ) = ONE
VM1( 3 ) = SQRT( BIGNUM )
VM2( 1 ) = ONE
VM2( 2 ) = ONE + TWO*EPS
VM2( 3 ) = TWO
*
KNT = 0
NINFO = 0
LMAX = 0
RMAX = ZERO
*
* Begin test loop
*
DO 150 ITRANA = 1, 2
DO 140 ITRANB = 1, 2
DO 130 ISGN = -1, 1, 2
DO 120 IMA = 1, 8
DO 110 IMLDA1 = 1, 3
DO 100 IMLDA2 = 1, 3
DO 90 IMLOFF = 1, 2
DO 80 IMB = 1, 8
DO 70 IMLDB1 = 1, 3
IF( ITRANA.EQ.1 )
$ TRANA = 'N'
IF( ITRANA.EQ.2 )
$ TRANA = 'T'
IF( ITRANB.EQ.1 )
$ TRANB = 'N'
IF( ITRANB.EQ.2 )
$ TRANB = 'T'
M = IDIM( IMA )
N = IDIM( IMB )
TNRM = ZERO
DO 20 I = 1, M
DO 10 J = 1, M
A( I, J ) = IVAL( I, J, IMA )
IF( ABS( I-J ).LE.1 ) THEN
A( I, J ) = A( I, J )*
$ VM1( IMLDA1 )
A( I, J ) = A( I, J )*
$ VM2( IMLDA2 )
ELSE
A( I, J ) = A( I, J )*
$ VM1( IMLOFF )
END IF
TNRM = MAX( TNRM,
$ ABS( A( I, J ) ) )
10 CONTINUE
20 CONTINUE
DO 40 I = 1, N
DO 30 J = 1, N
B( I, J ) = IVAL( I, J, IMB )
IF( ABS( I-J ).LE.1 ) THEN
B( I, J ) = B( I, J )*
$ VM1( IMLDB1 )
ELSE
B( I, J ) = B( I, J )*
$ VM1( IMLOFF )
END IF
TNRM = MAX( TNRM,
$ ABS( B( I, J ) ) )
30 CONTINUE
40 CONTINUE
CNRM = ZERO
DO 60 I = 1, M
DO 50 J = 1, N
C( I, J ) = SIN( DBLE( I*J ) )
CNRM = MAX( CNRM, C( I, J ) )
CC( I, J ) = C( I, J )
50 CONTINUE
60 CONTINUE
KNT = KNT + 1
CALL DTRSYL( TRANA, TRANB, ISGN, M, N,
$ A, 6, B, 6, C, 6, SCALE,
$ INFO )
IF( INFO.NE.0 )
$ NINFO = NINFO + 1
XNRM = DLANGE( 'M', M, N, C, 6, DUM )
RMUL = ONE
IF( XNRM.GT.ONE .AND. TNRM.GT.ONE )
$ THEN
IF( XNRM.GT.BIGNUM / TNRM ) THEN
RMUL = ONE / MAX( XNRM, TNRM )
END IF
END IF
CALL DGEMM( TRANA, 'N', M, N, M, RMUL,
$ A, 6, C, 6, -SCALE*RMUL,
$ CC, 6 )
CALL DGEMM( 'N', TRANB, M, N, N,
$ DBLE( ISGN )*RMUL, C, 6, B,
$ 6, ONE, CC, 6 )
RES1 = DLANGE( 'M', M, N, CC, 6, DUM )
RES = RES1 / MAX( SMLNUM, SMLNUM*XNRM,
$ ( ( RMUL*TNRM )*EPS )*XNRM )
IF( RES.GT.RMAX ) THEN
LMAX = KNT
RMAX = RES
END IF
70 CONTINUE
80 CONTINUE
90 CONTINUE
100 CONTINUE
110 CONTINUE
120 CONTINUE
130 CONTINUE
140 CONTINUE
150 CONTINUE
*
RETURN
*
* End of DGET35
*
END
SUBROUTINE DGET36( RMAX, LMAX, NINFO, KNT, NIN )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KNT, LMAX, NIN
DOUBLE PRECISION RMAX
* ..
* .. Array Arguments ..
INTEGER NINFO( 3 )
* ..
*
* Purpose
* =======
*
* DGET36 tests DTREXC, a routine for moving blocks (either 1 by 1 or
* 2 by 2) on the diagonal of a matrix in real Schur form. Thus, DLAEXC
* computes an orthogonal matrix Q such that
*
* Q' * T1 * Q = T2
*
* and where one of the diagonal blocks of T1 (the one at row IFST) has
* been moved to position ILST.
*
* The test code verifies that the residual Q'*T1*Q-T2 is small, that T2
* is in Schur form, and that the final position of the IFST block is
* ILST (within +-1).
*
* The test matrices are read from a file with logical unit number NIN.
*
* Arguments
* ==========
*
* RMAX (output) DOUBLE PRECISION
* Value of the largest test ratio.
*
* LMAX (output) INTEGER
* Example number where largest test ratio achieved.
*
* NINFO (output) INTEGER array, dimension (3)
* NINFO(J) is the number of examples where INFO=J.
*
* KNT (output) INTEGER
* Total number of examples tested.
*
* NIN (input) INTEGER
* Input logical unit number.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
INTEGER LDT, LWORK
PARAMETER ( LDT = 10, LWORK = 2*LDT*LDT )
* ..
* .. Local Scalars ..
INTEGER I, IFST, IFST1, IFST2, IFSTSV, ILST, ILST1,
$ ILST2, ILSTSV, INFO1, INFO2, J, LOC, N
DOUBLE PRECISION EPS, RES
* ..
* .. Local Arrays ..
DOUBLE PRECISION Q( LDT, LDT ), RESULT( 2 ), T1( LDT, LDT ),
$ T2( LDT, LDT ), TMP( LDT, LDT ), WORK( LWORK )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DHST01, DLACPY, DLASET, DTREXC
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SIGN
* ..
* .. Executable Statements ..
*
EPS = DLAMCH( 'P' )
RMAX = ZERO
LMAX = 0
KNT = 0
NINFO( 1 ) = 0
NINFO( 2 ) = 0
NINFO( 3 ) = 0
*
* Read input data until N=0
*
10 CONTINUE
READ( NIN, FMT = * )N, IFST, ILST
IF( N.EQ.0 )
$ RETURN
KNT = KNT + 1
DO 20 I = 1, N
READ( NIN, FMT = * )( TMP( I, J ), J = 1, N )
20 CONTINUE
CALL DLACPY( 'F', N, N, TMP, LDT, T1, LDT )
CALL DLACPY( 'F', N, N, TMP, LDT, T2, LDT )
IFSTSV = IFST
ILSTSV = ILST
IFST1 = IFST
ILST1 = ILST
IFST2 = IFST
ILST2 = ILST
RES = ZERO
*
* Test without accumulating Q
*
CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDT )
CALL DTREXC( 'N', N, T1, LDT, Q, LDT, IFST1, ILST1, WORK, INFO1 )
DO 40 I = 1, N
DO 30 J = 1, N
IF( I.EQ.J .AND. Q( I, J ).NE.ONE )
$ RES = RES + ONE / EPS
IF( I.NE.J .AND. Q( I, J ).NE.ZERO )
$ RES = RES + ONE / EPS
30 CONTINUE
40 CONTINUE
*
* Test with accumulating Q
*
CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDT )
CALL DTREXC( 'V', N, T2, LDT, Q, LDT, IFST2, ILST2, WORK, INFO2 )
*
* Compare T1 with T2
*
DO 60 I = 1, N
DO 50 J = 1, N
IF( T1( I, J ).NE.T2( I, J ) )
$ RES = RES + ONE / EPS
50 CONTINUE
60 CONTINUE
IF( IFST1.NE.IFST2 )
$ RES = RES + ONE / EPS
IF( ILST1.NE.ILST2 )
$ RES = RES + ONE / EPS
IF( INFO1.NE.INFO2 )
$ RES = RES + ONE / EPS
*
* Test for successful reordering of T2
*
IF( INFO2.NE.0 ) THEN
NINFO( INFO2 ) = NINFO( INFO2 ) + 1
ELSE
IF( ABS( IFST2-IFSTSV ).GT.1 )
$ RES = RES + ONE / EPS
IF( ABS( ILST2-ILSTSV ).GT.1 )
$ RES = RES + ONE / EPS
END IF
*
* Test for small residual, and orthogonality of Q
*
CALL DHST01( N, 1, N, TMP, LDT, T2, LDT, Q, LDT, WORK, LWORK,
$ RESULT )
RES = RES + RESULT( 1 ) + RESULT( 2 )
*
* Test for T2 being in Schur form
*
LOC = 1
70 CONTINUE
IF( T2( LOC+1, LOC ).NE.ZERO ) THEN
*
* 2 by 2 block
*
IF( T2( LOC, LOC+1 ).EQ.ZERO .OR. T2( LOC, LOC ).NE.
$ T2( LOC+1, LOC+1 ) .OR. SIGN( ONE, T2( LOC, LOC+1 ) ).EQ.
$ SIGN( ONE, T2( LOC+1, LOC ) ) )RES = RES + ONE / EPS
DO 80 I = LOC + 2, N
IF( T2( I, LOC ).NE.ZERO )
$ RES = RES + ONE / RES
IF( T2( I, LOC+1 ).NE.ZERO )
$ RES = RES + ONE / RES
80 CONTINUE
LOC = LOC + 2
ELSE
*
* 1 by 1 block
*
DO 90 I = LOC + 1, N
IF( T2( I, LOC ).NE.ZERO )
$ RES = RES + ONE / RES
90 CONTINUE
LOC = LOC + 1
END IF
IF( LOC.LT.N )
$ GO TO 70
IF( RES.GT.RMAX ) THEN
RMAX = RES
LMAX = KNT
END IF
GO TO 10
*
* End of DGET36
*
END
SUBROUTINE DGET37( RMAX, LMAX, NINFO, KNT, NIN )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KNT, NIN
* ..
* .. Array Arguments ..
INTEGER LMAX( 3 ), NINFO( 3 )
DOUBLE PRECISION RMAX( 3 )
* ..
*
* Purpose
* =======
*
* DGET37 tests DTRSNA, a routine for estimating condition numbers of
* eigenvalues and/or right eigenvectors of a matrix.
*
* The test matrices are read from a file with logical unit number NIN.
*
* Arguments
* ==========
*
* RMAX (output) DOUBLE PRECISION array, dimension (3)
* Value of the largest test ratio.
* RMAX(1) = largest ratio comparing different calls to DTRSNA
* RMAX(2) = largest error in reciprocal condition
* numbers taking their conditioning into account
* RMAX(3) = largest error in reciprocal condition
* numbers not taking their conditioning into
* account (may be larger than RMAX(2))
*
* LMAX (output) INTEGER array, dimension (3)
* LMAX(i) is example number where largest test ratio
* RMAX(i) is achieved. Also:
* If DGEHRD returns INFO nonzero on example i, LMAX(1)=i
* If DHSEQR returns INFO nonzero on example i, LMAX(2)=i
* If DTRSNA returns INFO nonzero on example i, LMAX(3)=i
*
* NINFO (output) INTEGER array, dimension (3)
* NINFO(1) = No. of times DGEHRD returned INFO nonzero
* NINFO(2) = No. of times DHSEQR returned INFO nonzero
* NINFO(3) = No. of times DTRSNA returned INFO nonzero
*
* KNT (output) INTEGER
* Total number of examples tested.
*
* NIN (input) INTEGER
* Input logical unit number
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
DOUBLE PRECISION EPSIN
PARAMETER ( EPSIN = 5.9605D-8 )
INTEGER LDT, LWORK
PARAMETER ( LDT = 20, LWORK = 2*LDT*( 10+LDT ) )
* ..
* .. Local Scalars ..
INTEGER I, ICMP, IFND, INFO, ISCL, J, KMIN, M, N
DOUBLE PRECISION BIGNUM, EPS, SMLNUM, TNRM, TOL, TOLIN, V,
$ VIMIN, VMAX, VMUL, VRMIN
* ..
* .. Local Arrays ..
LOGICAL SELECT( LDT )
INTEGER IWORK( 2*LDT ), LCMP( 3 )
DOUBLE PRECISION DUM( 1 ), LE( LDT, LDT ), RE( LDT, LDT ),
$ S( LDT ), SEP( LDT ), SEPIN( LDT ),
$ SEPTMP( LDT ), SIN( LDT ), STMP( LDT ),
$ T( LDT, LDT ), TMP( LDT, LDT ), VAL( 3 ),
$ WI( LDT ), WIIN( LDT ), WITMP( LDT ),
$ WORK( LWORK ), WR( LDT ), WRIN( LDT ),
$ WRTMP( LDT )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEHRD, DHSEQR, DLABAD, DLACPY, DSCAL,
$ DTREVC, DTRSNA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, SQRT
* ..
* .. Executable Statements ..
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' ) / EPS
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
*
* EPSIN = 2**(-24) = precision to which input data computed
*
EPS = MAX( EPS, EPSIN )
RMAX( 1 ) = ZERO
RMAX( 2 ) = ZERO
RMAX( 3 ) = ZERO
LMAX( 1 ) = 0
LMAX( 2 ) = 0
LMAX( 3 ) = 0
KNT = 0
NINFO( 1 ) = 0
NINFO( 2 ) = 0
NINFO( 3 ) = 0
*
VAL( 1 ) = SQRT( SMLNUM )
VAL( 2 ) = ONE
VAL( 3 ) = SQRT( BIGNUM )
*
* Read input data until N=0. Assume input eigenvalues are sorted
* lexicographically (increasing by real part, then decreasing by
* imaginary part)
*
10 CONTINUE
READ( NIN, FMT = * )N
IF( N.EQ.0 )
$ RETURN
DO 20 I = 1, N
READ( NIN, FMT = * )( TMP( I, J ), J = 1, N )
20 CONTINUE
DO 30 I = 1, N
READ( NIN, FMT = * )WRIN( I ), WIIN( I ), SIN( I ), SEPIN( I )
30 CONTINUE
TNRM = DLANGE( 'M', N, N, TMP, LDT, WORK )
*
* Begin test
*
DO 240 ISCL = 1, 3
*
* Scale input matrix
*
KNT = KNT + 1
CALL DLACPY( 'F', N, N, TMP, LDT, T, LDT )
VMUL = VAL( ISCL )
DO 40 I = 1, N
CALL DSCAL( N, VMUL, T( 1, I ), 1 )
40 CONTINUE
IF( TNRM.EQ.ZERO )
$ VMUL = ONE
*
* Compute eigenvalues and eigenvectors
*
CALL DGEHRD( N, 1, N, T, LDT, WORK( 1 ), WORK( N+1 ), LWORK-N,
$ INFO )
IF( INFO.NE.0 ) THEN
LMAX( 1 ) = KNT
NINFO( 1 ) = NINFO( 1 ) + 1
GO TO 240
END IF
DO 60 J = 1, N - 2
DO 50 I = J + 2, N
T( I, J ) = ZERO
50 CONTINUE
60 CONTINUE
*
* Compute Schur form
*
CALL DHSEQR( 'S', 'N', N, 1, N, T, LDT, WR, WI, DUM, 1, WORK,
$ LWORK, INFO )
IF( INFO.NE.0 ) THEN
LMAX( 2 ) = KNT
NINFO( 2 ) = NINFO( 2 ) + 1
GO TO 240
END IF
*
* Compute eigenvectors
*
CALL DTREVC( 'Both', 'All', SELECT, N, T, LDT, LE, LDT, RE,
$ LDT, N, M, WORK, INFO )
*
* Compute condition numbers
*
CALL DTRSNA( 'Both', 'All', SELECT, N, T, LDT, LE, LDT, RE,
$ LDT, S, SEP, N, M, WORK, N, IWORK, INFO )
IF( INFO.NE.0 ) THEN
LMAX( 3 ) = KNT
NINFO( 3 ) = NINFO( 3 ) + 1
GO TO 240
END IF
*
* Sort eigenvalues and condition numbers lexicographically
* to compare with inputs
*
CALL DCOPY( N, WR, 1, WRTMP, 1 )
CALL DCOPY( N, WI, 1, WITMP, 1 )
CALL DCOPY( N, S, 1, STMP, 1 )
CALL DCOPY( N, SEP, 1, SEPTMP, 1 )
CALL DSCAL( N, ONE / VMUL, SEPTMP, 1 )
DO 80 I = 1, N - 1
KMIN = I
VRMIN = WRTMP( I )
VIMIN = WITMP( I )
DO 70 J = I + 1, N
IF( WRTMP( J ).LT.VRMIN ) THEN
KMIN = J
VRMIN = WRTMP( J )
VIMIN = WITMP( J )
END IF
70 CONTINUE
WRTMP( KMIN ) = WRTMP( I )
WITMP( KMIN ) = WITMP( I )
WRTMP( I ) = VRMIN
WITMP( I ) = VIMIN
VRMIN = STMP( KMIN )
STMP( KMIN ) = STMP( I )
STMP( I ) = VRMIN
VRMIN = SEPTMP( KMIN )
SEPTMP( KMIN ) = SEPTMP( I )
SEPTMP( I ) = VRMIN
80 CONTINUE
*
* Compare condition numbers for eigenvalues
* taking their condition numbers into account
*
V = MAX( TWO*DBLE( N )*EPS*TNRM, SMLNUM )
IF( TNRM.EQ.ZERO )
$ V = ONE
DO 90 I = 1, N
IF( V.GT.SEPTMP( I ) ) THEN
TOL = ONE
ELSE
TOL = V / SEPTMP( I )
END IF
IF( V.GT.SEPIN( I ) ) THEN
TOLIN = ONE
ELSE
TOLIN = V / SEPIN( I )
END IF
TOL = MAX( TOL, SMLNUM / EPS )
TOLIN = MAX( TOLIN, SMLNUM / EPS )
IF( EPS*( SIN( I )-TOLIN ).GT.STMP( I )+TOL ) THEN
VMAX = ONE / EPS
ELSE IF( SIN( I )-TOLIN.GT.STMP( I )+TOL ) THEN
VMAX = ( SIN( I )-TOLIN ) / ( STMP( I )+TOL )
ELSE IF( SIN( I )+TOLIN.LT.EPS*( STMP( I )-TOL ) ) THEN
VMAX = ONE / EPS
ELSE IF( SIN( I )+TOLIN.LT.STMP( I )-TOL ) THEN
VMAX = ( STMP( I )-TOL ) / ( SIN( I )+TOLIN )
ELSE
VMAX = ONE
END IF
IF( VMAX.GT.RMAX( 2 ) ) THEN
RMAX( 2 ) = VMAX
IF( NINFO( 2 ).EQ.0 )
$ LMAX( 2 ) = KNT
END IF
90 CONTINUE
*
* Compare condition numbers for eigenvectors
* taking their condition numbers into account
*
DO 100 I = 1, N
IF( V.GT.SEPTMP( I )*STMP( I ) ) THEN
TOL = SEPTMP( I )
ELSE
TOL = V / STMP( I )
END IF
IF( V.GT.SEPIN( I )*SIN( I ) ) THEN
TOLIN = SEPIN( I )
ELSE
TOLIN = V / SIN( I )
END IF
TOL = MAX( TOL, SMLNUM / EPS )
TOLIN = MAX( TOLIN, SMLNUM / EPS )
IF( EPS*( SEPIN( I )-TOLIN ).GT.SEPTMP( I )+TOL ) THEN
VMAX = ONE / EPS
ELSE IF( SEPIN( I )-TOLIN.GT.SEPTMP( I )+TOL ) THEN
VMAX = ( SEPIN( I )-TOLIN ) / ( SEPTMP( I )+TOL )
ELSE IF( SEPIN( I )+TOLIN.LT.EPS*( SEPTMP( I )-TOL ) ) THEN
VMAX = ONE / EPS
ELSE IF( SEPIN( I )+TOLIN.LT.SEPTMP( I )-TOL ) THEN
VMAX = ( SEPTMP( I )-TOL ) / ( SEPIN( I )+TOLIN )
ELSE
VMAX = ONE
END IF
IF( VMAX.GT.RMAX( 2 ) ) THEN
RMAX( 2 ) = VMAX
IF( NINFO( 2 ).EQ.0 )
$ LMAX( 2 ) = KNT
END IF
100 CONTINUE
*
* Compare condition numbers for eigenvalues
* without taking their condition numbers into account
*
DO 110 I = 1, N
IF( SIN( I ).LE.DBLE( 2*N )*EPS .AND. STMP( I ).LE.
$ DBLE( 2*N )*EPS ) THEN
VMAX = ONE
ELSE IF( EPS*SIN( I ).GT.STMP( I ) ) THEN
VMAX = ONE / EPS
ELSE IF( SIN( I ).GT.STMP( I ) ) THEN
VMAX = SIN( I ) / STMP( I )
ELSE IF( SIN( I ).LT.EPS*STMP( I ) ) THEN
VMAX = ONE / EPS
ELSE IF( SIN( I ).LT.STMP( I ) ) THEN
VMAX = STMP( I ) / SIN( I )
ELSE
VMAX = ONE
END IF
IF( VMAX.GT.RMAX( 3 ) ) THEN
RMAX( 3 ) = VMAX
IF( NINFO( 3 ).EQ.0 )
$ LMAX( 3 ) = KNT
END IF
110 CONTINUE
*
* Compare condition numbers for eigenvectors
* without taking their condition numbers into account
*
DO 120 I = 1, N
IF( SEPIN( I ).LE.V .AND. SEPTMP( I ).LE.V ) THEN
VMAX = ONE
ELSE IF( EPS*SEPIN( I ).GT.SEPTMP( I ) ) THEN
VMAX = ONE / EPS
ELSE IF( SEPIN( I ).GT.SEPTMP( I ) ) THEN
VMAX = SEPIN( I ) / SEPTMP( I )
ELSE IF( SEPIN( I ).LT.EPS*SEPTMP( I ) ) THEN
VMAX = ONE / EPS
ELSE IF( SEPIN( I ).LT.SEPTMP( I ) ) THEN
VMAX = SEPTMP( I ) / SEPIN( I )
ELSE
VMAX = ONE
END IF
IF( VMAX.GT.RMAX( 3 ) ) THEN
RMAX( 3 ) = VMAX
IF( NINFO( 3 ).EQ.0 )
$ LMAX( 3 ) = KNT
END IF
120 CONTINUE
*
* Compute eigenvalue condition numbers only and compare
*
VMAX = ZERO
DUM( 1 ) = -ONE
CALL DCOPY( N, DUM, 0, STMP, 1 )
CALL DCOPY( N, DUM, 0, SEPTMP, 1 )
CALL DTRSNA( 'Eigcond', 'All', SELECT, N, T, LDT, LE, LDT, RE,
$ LDT, STMP, SEPTMP, N, M, WORK, N, IWORK, INFO )
IF( INFO.NE.0 ) THEN
LMAX( 3 ) = KNT
NINFO( 3 ) = NINFO( 3 ) + 1
GO TO 240
END IF
DO 130 I = 1, N
IF( STMP( I ).NE.S( I ) )
$ VMAX = ONE / EPS
IF( SEPTMP( I ).NE.DUM( 1 ) )
$ VMAX = ONE / EPS
130 CONTINUE
*
* Compute eigenvector condition numbers only and compare
*
CALL DCOPY( N, DUM, 0, STMP, 1 )
CALL DCOPY( N, DUM, 0, SEPTMP, 1 )
CALL DTRSNA( 'Veccond', 'All', SELECT, N, T, LDT, LE, LDT, RE,
$ LDT, STMP, SEPTMP, N, M, WORK, N, IWORK, INFO )
IF( INFO.NE.0 ) THEN
LMAX( 3 ) = KNT
NINFO( 3 ) = NINFO( 3 ) + 1
GO TO 240
END IF
DO 140 I = 1, N
IF( STMP( I ).NE.DUM( 1 ) )
$ VMAX = ONE / EPS
IF( SEPTMP( I ).NE.SEP( I ) )
$ VMAX = ONE / EPS
140 CONTINUE
*
* Compute all condition numbers using SELECT and compare
*
DO 150 I = 1, N
SELECT( I ) = .TRUE.
150 CONTINUE
CALL DCOPY( N, DUM, 0, STMP, 1 )
CALL DCOPY( N, DUM, 0, SEPTMP, 1 )
CALL DTRSNA( 'Bothcond', 'Some', SELECT, N, T, LDT, LE, LDT,
$ RE, LDT, STMP, SEPTMP, N, M, WORK, N, IWORK,
$ INFO )
IF( INFO.NE.0 ) THEN
LMAX( 3 ) = KNT
NINFO( 3 ) = NINFO( 3 ) + 1
GO TO 240
END IF
DO 160 I = 1, N
IF( SEPTMP( I ).NE.SEP( I ) )
$ VMAX = ONE / EPS
IF( STMP( I ).NE.S( I ) )
$ VMAX = ONE / EPS
160 CONTINUE
*
* Compute eigenvalue condition numbers using SELECT and compare
*
CALL DCOPY( N, DUM, 0, STMP, 1 )
CALL DCOPY( N, DUM, 0, SEPTMP, 1 )
CALL DTRSNA( 'Eigcond', 'Some', SELECT, N, T, LDT, LE, LDT, RE,
$ LDT, STMP, SEPTMP, N, M, WORK, N, IWORK, INFO )
IF( INFO.NE.0 ) THEN
LMAX( 3 ) = KNT
NINFO( 3 ) = NINFO( 3 ) + 1
GO TO 240
END IF
DO 170 I = 1, N
IF( STMP( I ).NE.S( I ) )
$ VMAX = ONE / EPS
IF( SEPTMP( I ).NE.DUM( 1 ) )
$ VMAX = ONE / EPS
170 CONTINUE
*
* Compute eigenvector condition numbers using SELECT and compare
*
CALL DCOPY( N, DUM, 0, STMP, 1 )
CALL DCOPY( N, DUM, 0, SEPTMP, 1 )
CALL DTRSNA( 'Veccond', 'Some', SELECT, N, T, LDT, LE, LDT, RE,
$ LDT, STMP, SEPTMP, N, M, WORK, N, IWORK, INFO )
IF( INFO.NE.0 ) THEN
LMAX( 3 ) = KNT
NINFO( 3 ) = NINFO( 3 ) + 1
GO TO 240
END IF
DO 180 I = 1, N
IF( STMP( I ).NE.DUM( 1 ) )
$ VMAX = ONE / EPS
IF( SEPTMP( I ).NE.SEP( I ) )
$ VMAX = ONE / EPS
180 CONTINUE
IF( VMAX.GT.RMAX( 1 ) ) THEN
RMAX( 1 ) = VMAX
IF( NINFO( 1 ).EQ.0 )
$ LMAX( 1 ) = KNT
END IF
*
* Select first real and first complex eigenvalue
*
IF( WI( 1 ).EQ.ZERO ) THEN
LCMP( 1 ) = 1
IFND = 0
DO 190 I = 2, N
IF( IFND.EQ.1 .OR. WI( I ).EQ.ZERO ) THEN
SELECT( I ) = .FALSE.
ELSE
IFND = 1
LCMP( 2 ) = I
LCMP( 3 ) = I + 1
CALL DCOPY( N, RE( 1, I ), 1, RE( 1, 2 ), 1 )
CALL DCOPY( N, RE( 1, I+1 ), 1, RE( 1, 3 ), 1 )
CALL DCOPY( N, LE( 1, I ), 1, LE( 1, 2 ), 1 )
CALL DCOPY( N, LE( 1, I+1 ), 1, LE( 1, 3 ), 1 )
END IF
190 CONTINUE
IF( IFND.EQ.0 ) THEN
ICMP = 1
ELSE
ICMP = 3
END IF
ELSE
LCMP( 1 ) = 1
LCMP( 2 ) = 2
IFND = 0
DO 200 I = 3, N
IF( IFND.EQ.1 .OR. WI( I ).NE.ZERO ) THEN
SELECT( I ) = .FALSE.
ELSE
LCMP( 3 ) = I
IFND = 1
CALL DCOPY( N, RE( 1, I ), 1, RE( 1, 3 ), 1 )
CALL DCOPY( N, LE( 1, I ), 1, LE( 1, 3 ), 1 )
END IF
200 CONTINUE
IF( IFND.EQ.0 ) THEN
ICMP = 2
ELSE
ICMP = 3
END IF
END IF
*
* Compute all selected condition numbers
*
CALL DCOPY( ICMP, DUM, 0, STMP, 1 )
CALL DCOPY( ICMP, DUM, 0, SEPTMP, 1 )
CALL DTRSNA( 'Bothcond', 'Some', SELECT, N, T, LDT, LE, LDT,
$ RE, LDT, STMP, SEPTMP, N, M, WORK, N, IWORK,
$ INFO )
IF( INFO.NE.0 ) THEN
LMAX( 3 ) = KNT
NINFO( 3 ) = NINFO( 3 ) + 1
GO TO 240
END IF
DO 210 I = 1, ICMP
J = LCMP( I )
IF( SEPTMP( I ).NE.SEP( J ) )
$ VMAX = ONE / EPS
IF( STMP( I ).NE.S( J ) )
$ VMAX = ONE / EPS
210 CONTINUE
*
* Compute selected eigenvalue condition numbers
*
CALL DCOPY( ICMP, DUM, 0, STMP, 1 )
CALL DCOPY( ICMP, DUM, 0, SEPTMP, 1 )
CALL DTRSNA( 'Eigcond', 'Some', SELECT, N, T, LDT, LE, LDT, RE,
$ LDT, STMP, SEPTMP, N, M, WORK, N, IWORK, INFO )
IF( INFO.NE.0 ) THEN
LMAX( 3 ) = KNT
NINFO( 3 ) = NINFO( 3 ) + 1
GO TO 240
END IF
DO 220 I = 1, ICMP
J = LCMP( I )
IF( STMP( I ).NE.S( J ) )
$ VMAX = ONE / EPS
IF( SEPTMP( I ).NE.DUM( 1 ) )
$ VMAX = ONE / EPS
220 CONTINUE
*
* Compute selected eigenvector condition numbers
*
CALL DCOPY( ICMP, DUM, 0, STMP, 1 )
CALL DCOPY( ICMP, DUM, 0, SEPTMP, 1 )
CALL DTRSNA( 'Veccond', 'Some', SELECT, N, T, LDT, LE, LDT, RE,
$ LDT, STMP, SEPTMP, N, M, WORK, N, IWORK, INFO )
IF( INFO.NE.0 ) THEN
LMAX( 3 ) = KNT
NINFO( 3 ) = NINFO( 3 ) + 1
GO TO 240
END IF
DO 230 I = 1, ICMP
J = LCMP( I )
IF( STMP( I ).NE.DUM( 1 ) )
$ VMAX = ONE / EPS
IF( SEPTMP( I ).NE.SEP( J ) )
$ VMAX = ONE / EPS
230 CONTINUE
IF( VMAX.GT.RMAX( 1 ) ) THEN
RMAX( 1 ) = VMAX
IF( NINFO( 1 ).EQ.0 )
$ LMAX( 1 ) = KNT
END IF
240 CONTINUE
GO TO 10
*
* End of DGET37
*
END
SUBROUTINE DGET38( RMAX, LMAX, NINFO, KNT, NIN )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KNT, NIN
* ..
* .. Array Arguments ..
INTEGER LMAX( 3 ), NINFO( 3 )
DOUBLE PRECISION RMAX( 3 )
* ..
*
* Purpose
* =======
*
* DGET38 tests DTRSEN, a routine for estimating condition numbers of a
* cluster of eigenvalues and/or its associated right invariant subspace
*
* The test matrices are read from a file with logical unit number NIN.
*
* Arguments
* ==========
*
* RMAX (output) DOUBLE PRECISION array, dimension (3)
* Values of the largest test ratios.
* RMAX(1) = largest residuals from DHST01 or comparing
* different calls to DTRSEN
* RMAX(2) = largest error in reciprocal condition
* numbers taking their conditioning into account
* RMAX(3) = largest error in reciprocal condition
* numbers not taking their conditioning into
* account (may be larger than RMAX(2))
*
* LMAX (output) INTEGER array, dimension (3)
* LMAX(i) is example number where largest test ratio
* RMAX(i) is achieved. Also:
* If DGEHRD returns INFO nonzero on example i, LMAX(1)=i
* If DHSEQR returns INFO nonzero on example i, LMAX(2)=i
* If DTRSEN returns INFO nonzero on example i, LMAX(3)=i
*
* NINFO (output) INTEGER array, dimension (3)
* NINFO(1) = No. of times DGEHRD returned INFO nonzero
* NINFO(2) = No. of times DHSEQR returned INFO nonzero
* NINFO(3) = No. of times DTRSEN returned INFO nonzero
*
* KNT (output) INTEGER
* Total number of examples tested.
*
* NIN (input) INTEGER
* Input logical unit number.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
DOUBLE PRECISION EPSIN
PARAMETER ( EPSIN = 5.9605D-8 )
INTEGER LDT, LWORK
PARAMETER ( LDT = 20, LWORK = 2*LDT*( 10+LDT ) )
INTEGER LIWORK
PARAMETER ( LIWORK = LDT*LDT )
* ..
* .. Local Scalars ..
INTEGER I, INFO, ISCL, ITMP, J, KMIN, M, N, NDIM
DOUBLE PRECISION BIGNUM, EPS, S, SEP, SEPIN, SEPTMP, SIN,
$ SMLNUM, STMP, TNRM, TOL, TOLIN, V, VIMIN, VMAX,
$ VMUL, VRMIN
* ..
* .. Local Arrays ..
LOGICAL SELECT( LDT )
INTEGER IPNT( LDT ), ISELEC( LDT ), IWORK( LIWORK )
DOUBLE PRECISION Q( LDT, LDT ), QSAV( LDT, LDT ),
$ QTMP( LDT, LDT ), RESULT( 2 ), T( LDT, LDT ),
$ TMP( LDT, LDT ), TSAV( LDT, LDT ),
$ TSAV1( LDT, LDT ), TTMP( LDT, LDT ), VAL( 3 ),
$ WI( LDT ), WITMP( LDT ), WORK( LWORK ),
$ WR( LDT ), WRTMP( LDT )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEHRD, DHSEQR, DHST01, DLABAD, DLACPY,
$ DORGHR, DSCAL, DTRSEN
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, SQRT
* ..
* .. Executable Statements ..
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' ) / EPS
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
*
* EPSIN = 2**(-24) = precision to which input data computed
*
EPS = MAX( EPS, EPSIN )
RMAX( 1 ) = ZERO
RMAX( 2 ) = ZERO
RMAX( 3 ) = ZERO
LMAX( 1 ) = 0
LMAX( 2 ) = 0
LMAX( 3 ) = 0
KNT = 0
NINFO( 1 ) = 0
NINFO( 2 ) = 0
NINFO( 3 ) = 0
*
VAL( 1 ) = SQRT( SMLNUM )
VAL( 2 ) = ONE
VAL( 3 ) = SQRT( SQRT( BIGNUM ) )
*
* Read input data until N=0. Assume input eigenvalues are sorted
* lexicographically (increasing by real part, then decreasing by
* imaginary part)
*
10 CONTINUE
READ( NIN, FMT = * )N, NDIM
IF( N.EQ.0 )
$ RETURN
READ( NIN, FMT = * )( ISELEC( I ), I = 1, NDIM )
DO 20 I = 1, N
READ( NIN, FMT = * )( TMP( I, J ), J = 1, N )
20 CONTINUE
READ( NIN, FMT = * )SIN, SEPIN
*
TNRM = DLANGE( 'M', N, N, TMP, LDT, WORK )
DO 160 ISCL = 1, 3
*
* Scale input matrix
*
KNT = KNT + 1
CALL DLACPY( 'F', N, N, TMP, LDT, T, LDT )
VMUL = VAL( ISCL )
DO 30 I = 1, N
CALL DSCAL( N, VMUL, T( 1, I ), 1 )
30 CONTINUE
IF( TNRM.EQ.ZERO )
$ VMUL = ONE
CALL DLACPY( 'F', N, N, T, LDT, TSAV, LDT )
*
* Compute Schur form
*
CALL DGEHRD( N, 1, N, T, LDT, WORK( 1 ), WORK( N+1 ), LWORK-N,
$ INFO )
IF( INFO.NE.0 ) THEN
LMAX( 1 ) = KNT
NINFO( 1 ) = NINFO( 1 ) + 1
GO TO 160
END IF
*
* Generate orthogonal matrix
*
CALL DLACPY( 'L', N, N, T, LDT, Q, LDT )
CALL DORGHR( N, 1, N, Q, LDT, WORK( 1 ), WORK( N+1 ), LWORK-N,
$ INFO )
*
* Compute Schur form
*
CALL DHSEQR( 'S', 'V', N, 1, N, T, LDT, WR, WI, Q, LDT, WORK,
$ LWORK, INFO )
IF( INFO.NE.0 ) THEN
LMAX( 2 ) = KNT
NINFO( 2 ) = NINFO( 2 ) + 1
GO TO 160
END IF
*
* Sort, select eigenvalues
*
DO 40 I = 1, N
IPNT( I ) = I
SELECT( I ) = .FALSE.
40 CONTINUE
CALL DCOPY( N, WR, 1, WRTMP, 1 )
CALL DCOPY( N, WI, 1, WITMP, 1 )
DO 60 I = 1, N - 1
KMIN = I
VRMIN = WRTMP( I )
VIMIN = WITMP( I )
DO 50 J = I + 1, N
IF( WRTMP( J ).LT.VRMIN ) THEN
KMIN = J
VRMIN = WRTMP( J )
VIMIN = WITMP( J )
END IF
50 CONTINUE
WRTMP( KMIN ) = WRTMP( I )
WITMP( KMIN ) = WITMP( I )
WRTMP( I ) = VRMIN
WITMP( I ) = VIMIN
ITMP = IPNT( I )
IPNT( I ) = IPNT( KMIN )
IPNT( KMIN ) = ITMP
60 CONTINUE
DO 70 I = 1, NDIM
SELECT( IPNT( ISELEC( I ) ) ) = .TRUE.
70 CONTINUE
*
* Compute condition numbers
*
CALL DLACPY( 'F', N, N, Q, LDT, QSAV, LDT )
CALL DLACPY( 'F', N, N, T, LDT, TSAV1, LDT )
CALL DTRSEN( 'B', 'V', SELECT, N, T, LDT, Q, LDT, WRTMP, WITMP,
$ M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO )
IF( INFO.NE.0 ) THEN
LMAX( 3 ) = KNT
NINFO( 3 ) = NINFO( 3 ) + 1
GO TO 160
END IF
SEPTMP = SEP / VMUL
STMP = S
*
* Compute residuals
*
CALL DHST01( N, 1, N, TSAV, LDT, T, LDT, Q, LDT, WORK, LWORK,
$ RESULT )
VMAX = MAX( RESULT( 1 ), RESULT( 2 ) )
IF( VMAX.GT.RMAX( 1 ) ) THEN
RMAX( 1 ) = VMAX
IF( NINFO( 1 ).EQ.0 )
$ LMAX( 1 ) = KNT
END IF
*
* Compare condition number for eigenvalue cluster
* taking its condition number into account
*
V = MAX( TWO*DBLE( N )*EPS*TNRM, SMLNUM )
IF( TNRM.EQ.ZERO )
$ V = ONE
IF( V.GT.SEPTMP ) THEN
TOL = ONE
ELSE
TOL = V / SEPTMP
END IF
IF( V.GT.SEPIN ) THEN
TOLIN = ONE
ELSE
TOLIN = V / SEPIN
END IF
TOL = MAX( TOL, SMLNUM / EPS )
TOLIN = MAX( TOLIN, SMLNUM / EPS )
IF( EPS*( SIN-TOLIN ).GT.STMP+TOL ) THEN
VMAX = ONE / EPS
ELSE IF( SIN-TOLIN.GT.STMP+TOL ) THEN
VMAX = ( SIN-TOLIN ) / ( STMP+TOL )
ELSE IF( SIN+TOLIN.LT.EPS*( STMP-TOL ) ) THEN
VMAX = ONE / EPS
ELSE IF( SIN+TOLIN.LT.STMP-TOL ) THEN
VMAX = ( STMP-TOL ) / ( SIN+TOLIN )
ELSE
VMAX = ONE
END IF
IF( VMAX.GT.RMAX( 2 ) ) THEN
RMAX( 2 ) = VMAX
IF( NINFO( 2 ).EQ.0 )
$ LMAX( 2 ) = KNT
END IF
*
* Compare condition numbers for invariant subspace
* taking its condition number into account
*
IF( V.GT.SEPTMP*STMP ) THEN
TOL = SEPTMP
ELSE
TOL = V / STMP
END IF
IF( V.GT.SEPIN*SIN ) THEN
TOLIN = SEPIN
ELSE
TOLIN = V / SIN
END IF
TOL = MAX( TOL, SMLNUM / EPS )
TOLIN = MAX( TOLIN, SMLNUM / EPS )
IF( EPS*( SEPIN-TOLIN ).GT.SEPTMP+TOL ) THEN
VMAX = ONE / EPS
ELSE IF( SEPIN-TOLIN.GT.SEPTMP+TOL ) THEN
VMAX = ( SEPIN-TOLIN ) / ( SEPTMP+TOL )
ELSE IF( SEPIN+TOLIN.LT.EPS*( SEPTMP-TOL ) ) THEN
VMAX = ONE / EPS
ELSE IF( SEPIN+TOLIN.LT.SEPTMP-TOL ) THEN
VMAX = ( SEPTMP-TOL ) / ( SEPIN+TOLIN )
ELSE
VMAX = ONE
END IF
IF( VMAX.GT.RMAX( 2 ) ) THEN
RMAX( 2 ) = VMAX
IF( NINFO( 2 ).EQ.0 )
$ LMAX( 2 ) = KNT
END IF
*
* Compare condition number for eigenvalue cluster
* without taking its condition number into account
*
IF( SIN.LE.DBLE( 2*N )*EPS .AND. STMP.LE.DBLE( 2*N )*EPS ) THEN
VMAX = ONE
ELSE IF( EPS*SIN.GT.STMP ) THEN
VMAX = ONE / EPS
ELSE IF( SIN.GT.STMP ) THEN
VMAX = SIN / STMP
ELSE IF( SIN.LT.EPS*STMP ) THEN
VMAX = ONE / EPS
ELSE IF( SIN.LT.STMP ) THEN
VMAX = STMP / SIN
ELSE
VMAX = ONE
END IF
IF( VMAX.GT.RMAX( 3 ) ) THEN
RMAX( 3 ) = VMAX
IF( NINFO( 3 ).EQ.0 )
$ LMAX( 3 ) = KNT
END IF
*
* Compare condition numbers for invariant subspace
* without taking its condition number into account
*
IF( SEPIN.LE.V .AND. SEPTMP.LE.V ) THEN
VMAX = ONE
ELSE IF( EPS*SEPIN.GT.SEPTMP ) THEN
VMAX = ONE / EPS
ELSE IF( SEPIN.GT.SEPTMP ) THEN
VMAX = SEPIN / SEPTMP
ELSE IF( SEPIN.LT.EPS*SEPTMP ) THEN
VMAX = ONE / EPS
ELSE IF( SEPIN.LT.SEPTMP ) THEN
VMAX = SEPTMP / SEPIN
ELSE
VMAX = ONE
END IF
IF( VMAX.GT.RMAX( 3 ) ) THEN
RMAX( 3 ) = VMAX
IF( NINFO( 3 ).EQ.0 )
$ LMAX( 3 ) = KNT
END IF
*
* Compute eigenvalue condition number only and compare
* Update Q
*
VMAX = ZERO
CALL DLACPY( 'F', N, N, TSAV1, LDT, TTMP, LDT )
CALL DLACPY( 'F', N, N, QSAV, LDT, QTMP, LDT )
SEPTMP = -ONE
STMP = -ONE
CALL DTRSEN( 'E', 'V', SELECT, N, TTMP, LDT, QTMP, LDT, WRTMP,
$ WITMP, M, STMP, SEPTMP, WORK, LWORK, IWORK,
$ LIWORK, INFO )
IF( INFO.NE.0 ) THEN
LMAX( 3 ) = KNT
NINFO( 3 ) = NINFO( 3 ) + 1
GO TO 160
END IF
IF( S.NE.STMP )
$ VMAX = ONE / EPS
IF( -ONE.NE.SEPTMP )
$ VMAX = ONE / EPS
DO 90 I = 1, N
DO 80 J = 1, N
IF( TTMP( I, J ).NE.T( I, J ) )
$ VMAX = ONE / EPS
IF( QTMP( I, J ).NE.Q( I, J ) )
$ VMAX = ONE / EPS
80 CONTINUE
90 CONTINUE
*
* Compute invariant subspace condition number only and compare
* Update Q
*
CALL DLACPY( 'F', N, N, TSAV1, LDT, TTMP, LDT )
CALL DLACPY( 'F', N, N, QSAV, LDT, QTMP, LDT )
SEPTMP = -ONE
STMP = -ONE
CALL DTRSEN( 'V', 'V', SELECT, N, TTMP, LDT, QTMP, LDT, WRTMP,
$ WITMP, M, STMP, SEPTMP, WORK, LWORK, IWORK,
$ LIWORK, INFO )
IF( INFO.NE.0 ) THEN
LMAX( 3 ) = KNT
NINFO( 3 ) = NINFO( 3 ) + 1
GO TO 160
END IF
IF( -ONE.NE.STMP )
$ VMAX = ONE / EPS
IF( SEP.NE.SEPTMP )
$ VMAX = ONE / EPS
DO 110 I = 1, N
DO 100 J = 1, N
IF( TTMP( I, J ).NE.T( I, J ) )
$ VMAX = ONE / EPS
IF( QTMP( I, J ).NE.Q( I, J ) )
$ VMAX = ONE / EPS
100 CONTINUE
110 CONTINUE
*
* Compute eigenvalue condition number only and compare
* Do not update Q
*
CALL DLACPY( 'F', N, N, TSAV1, LDT, TTMP, LDT )
CALL DLACPY( 'F', N, N, QSAV, LDT, QTMP, LDT )
SEPTMP = -ONE
STMP = -ONE
CALL DTRSEN( 'E', 'N', SELECT, N, TTMP, LDT, QTMP, LDT, WRTMP,
$ WITMP, M, STMP, SEPTMP, WORK, LWORK, IWORK,
$ LIWORK, INFO )
IF( INFO.NE.0 ) THEN
LMAX( 3 ) = KNT
NINFO( 3 ) = NINFO( 3 ) + 1
GO TO 160
END IF
IF( S.NE.STMP )
$ VMAX = ONE / EPS
IF( -ONE.NE.SEPTMP )
$ VMAX = ONE / EPS
DO 130 I = 1, N
DO 120 J = 1, N
IF( TTMP( I, J ).NE.T( I, J ) )
$ VMAX = ONE / EPS
IF( QTMP( I, J ).NE.QSAV( I, J ) )
$ VMAX = ONE / EPS
120 CONTINUE
130 CONTINUE
*
* Compute invariant subspace condition number only and compare
* Do not update Q
*
CALL DLACPY( 'F', N, N, TSAV1, LDT, TTMP, LDT )
CALL DLACPY( 'F', N, N, QSAV, LDT, QTMP, LDT )
SEPTMP = -ONE
STMP = -ONE
CALL DTRSEN( 'V', 'N', SELECT, N, TTMP, LDT, QTMP, LDT, WRTMP,
$ WITMP, M, STMP, SEPTMP, WORK, LWORK, IWORK,
$ LIWORK, INFO )
IF( INFO.NE.0 ) THEN
LMAX( 3 ) = KNT
NINFO( 3 ) = NINFO( 3 ) + 1
GO TO 160
END IF
IF( -ONE.NE.STMP )
$ VMAX = ONE / EPS
IF( SEP.NE.SEPTMP )
$ VMAX = ONE / EPS
DO 150 I = 1, N
DO 140 J = 1, N
IF( TTMP( I, J ).NE.T( I, J ) )
$ VMAX = ONE / EPS
IF( QTMP( I, J ).NE.QSAV( I, J ) )
$ VMAX = ONE / EPS
140 CONTINUE
150 CONTINUE
IF( VMAX.GT.RMAX( 1 ) ) THEN
RMAX( 1 ) = VMAX
IF( NINFO( 1 ).EQ.0 )
$ LMAX( 1 ) = KNT
END IF
160 CONTINUE
GO TO 10
*
* End of DGET38
*
END
SUBROUTINE DGET39( RMAX, LMAX, NINFO, KNT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KNT, LMAX, NINFO
DOUBLE PRECISION RMAX
* ..
*
* Purpose
* =======
*
* DGET39 tests DLAQTR, a routine for solving the real or
* special complex quasi upper triangular system
*
* op(T)*p = scale*c,
* or
* op(T + iB)*(p+iq) = scale*(c+id),
*
* in real arithmetic. T is upper quasi-triangular.
* If it is complex, then the first diagonal block of T must be
* 1 by 1, B has the special structure
*
* B = [ b(1) b(2) ... b(n) ]
* [ w ]
* [ w ]
* [ . ]
* [ w ]
*
* op(A) = A or A', where A' denotes the conjugate transpose of
* the matrix A.
*
* On input, X = [ c ]. On output, X = [ p ].
* [ d ] [ q ]
*
* Scale is an output less than or equal to 1, chosen to avoid
* overflow in X.
* This subroutine is specially designed for the condition number
* estimation in the eigenproblem routine DTRSNA.
*
* The test code verifies that the following residual is order 1:
*
* ||(T+i*B)*(x1+i*x2) - scale*(d1+i*d2)||
* -----------------------------------------
* max(ulp*(||T||+||B||)*(||x1||+||x2||),
* (||T||+||B||)*smlnum/ulp,
* smlnum)
*
* (The (||T||+||B||)*smlnum/ulp term accounts for possible
* (gradual or nongradual) underflow in x1 and x2.)
*
* Arguments
* ==========
*
* RMAX (output) DOUBLE PRECISION
* Value of the largest test ratio.
*
* LMAX (output) INTEGER
* Example number where largest test ratio achieved.
*
* NINFO (output) INTEGER
* Number of examples where INFO is nonzero.
*
* KNT (output) INTEGER
* Total number of examples tested.
*
* =====================================================================
*
* .. Parameters ..
INTEGER LDT, LDT2
PARAMETER ( LDT = 10, LDT2 = 2*LDT )
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, IVM1, IVM2, IVM3, IVM4, IVM5, J, K, N,
$ NDIM
DOUBLE PRECISION BIGNUM, DOMIN, DUMM, EPS, NORM, NORMTB, RESID,
$ SCALE, SMLNUM, W, XNORM
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DASUM, DDOT, DLAMCH, DLANGE
EXTERNAL IDAMAX, DASUM, DDOT, DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMV, DLABAD, DLAQTR
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, COS, DBLE, MAX, SIN, SQRT
* ..
* .. Local Arrays ..
INTEGER IDIM( 6 ), IVAL( 5, 5, 6 )
DOUBLE PRECISION B( LDT ), D( LDT2 ), DUM( 1 ), T( LDT, LDT ),
$ VM1( 5 ), VM2( 5 ), VM3( 5 ), VM4( 5 ),
$ VM5( 3 ), WORK( LDT ), X( LDT2 ), Y( LDT2 )
* ..
* .. Data statements ..
DATA IDIM / 4, 5*5 /
DATA IVAL / 3, 4*0, 1, 1, -1, 0, 0, 3, 2, 1, 0, 0,
$ 4, 3, 2, 2, 0, 5*0, 1, 4*0, 2, 2, 3*0, 3, 3, 4,
$ 0, 0, 4, 2, 2, 3, 0, 4*1, 5, 1, 4*0, 2, 4, -2,
$ 0, 0, 3, 3, 4, 0, 0, 4, 2, 2, 3, 0, 5*1, 1,
$ 4*0, 2, 1, -1, 0, 0, 9, 8, 1, 0, 0, 4, 9, 1, 2,
$ -1, 5*2, 9, 4*0, 6, 4, 0, 0, 0, 3, 2, 1, 1, 0,
$ 5, 1, -1, 1, 0, 5*2, 4, 4*0, 2, 2, 0, 0, 0, 1,
$ 4, 4, 0, 0, 2, 4, 2, 2, -1, 5*2 /
* ..
* .. Executable Statements ..
*
* Get machine parameters
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
*
* Set up test case parameters
*
VM1( 1 ) = ONE
VM1( 2 ) = SQRT( SMLNUM )
VM1( 3 ) = SQRT( VM1( 2 ) )
VM1( 4 ) = SQRT( BIGNUM )
VM1( 5 ) = SQRT( VM1( 4 ) )
*
VM2( 1 ) = ONE
VM2( 2 ) = SQRT( SMLNUM )
VM2( 3 ) = SQRT( VM2( 2 ) )
VM2( 4 ) = SQRT( BIGNUM )
VM2( 5 ) = SQRT( VM2( 4 ) )
*
VM3( 1 ) = ONE
VM3( 2 ) = SQRT( SMLNUM )
VM3( 3 ) = SQRT( VM3( 2 ) )
VM3( 4 ) = SQRT( BIGNUM )
VM3( 5 ) = SQRT( VM3( 4 ) )
*
VM4( 1 ) = ONE
VM4( 2 ) = SQRT( SMLNUM )
VM4( 3 ) = SQRT( VM4( 2 ) )
VM4( 4 ) = SQRT( BIGNUM )
VM4( 5 ) = SQRT( VM4( 4 ) )
*
VM5( 1 ) = ONE
VM5( 2 ) = EPS
VM5( 3 ) = SQRT( SMLNUM )
*
* Initalization
*
KNT = 0
RMAX = ZERO
NINFO = 0
SMLNUM = SMLNUM / EPS
*
* Begin test loop
*
DO 140 IVM5 = 1, 3
DO 130 IVM4 = 1, 5
DO 120 IVM3 = 1, 5
DO 110 IVM2 = 1, 5
DO 100 IVM1 = 1, 5
DO 90 NDIM = 1, 6
*
N = IDIM( NDIM )
DO 20 I = 1, N
DO 10 J = 1, N
T( I, J ) = DBLE( IVAL( I, J, NDIM ) )*
$ VM1( IVM1 )
IF( I.GE.J )
$ T( I, J ) = T( I, J )*VM5( IVM5 )
10 CONTINUE
20 CONTINUE
*
W = ONE*VM2( IVM2 )
*
DO 30 I = 1, N
B( I ) = COS( DBLE( I ) )*VM3( IVM3 )
30 CONTINUE
*
DO 40 I = 1, 2*N
D( I ) = SIN( DBLE( I ) )*VM4( IVM4 )
40 CONTINUE
*
NORM = DLANGE( '1', N, N, T, LDT, WORK )
K = IDAMAX( N, B, 1 )
NORMTB = NORM + ABS( B( K ) ) + ABS( W )
*
CALL DCOPY( N, D, 1, X, 1 )
KNT = KNT + 1
CALL DLAQTR( .FALSE., .TRUE., N, T, LDT, DUM,
$ DUMM, SCALE, X, WORK, INFO )
IF( INFO.NE.0 )
$ NINFO = NINFO + 1
*
* || T*x - scale*d || /
* max(ulp*||T||*||x||,smlnum/ulp*||T||,smlnum)
*
CALL DCOPY( N, D, 1, Y, 1 )
CALL DGEMV( 'No transpose', N, N, ONE, T, LDT,
$ X, 1, -SCALE, Y, 1 )
XNORM = DASUM( N, X, 1 )
RESID = DASUM( N, Y, 1 )
DOMIN = MAX( SMLNUM, ( SMLNUM / EPS )*NORM,
$ ( NORM*EPS )*XNORM )
RESID = RESID / DOMIN
IF( RESID.GT.RMAX ) THEN
RMAX = RESID
LMAX = KNT
END IF
*
CALL DCOPY( N, D, 1, X, 1 )
KNT = KNT + 1
CALL DLAQTR( .TRUE., .TRUE., N, T, LDT, DUM,
$ DUMM, SCALE, X, WORK, INFO )
IF( INFO.NE.0 )
$ NINFO = NINFO + 1
*
* || T*x - scale*d || /
* max(ulp*||T||*||x||,smlnum/ulp*||T||,smlnum)
*
CALL DCOPY( N, D, 1, Y, 1 )
CALL DGEMV( 'Transpose', N, N, ONE, T, LDT, X,
$ 1, -SCALE, Y, 1 )
XNORM = DASUM( N, X, 1 )
RESID = DASUM( N, Y, 1 )
DOMIN = MAX( SMLNUM, ( SMLNUM / EPS )*NORM,
$ ( NORM*EPS )*XNORM )
RESID = RESID / DOMIN
IF( RESID.GT.RMAX ) THEN
RMAX = RESID
LMAX = KNT
END IF
*
CALL DCOPY( 2*N, D, 1, X, 1 )
KNT = KNT + 1
CALL DLAQTR( .FALSE., .FALSE., N, T, LDT, B, W,
$ SCALE, X, WORK, INFO )
IF( INFO.NE.0 )
$ NINFO = NINFO + 1
*
* ||(T+i*B)*(x1+i*x2) - scale*(d1+i*d2)|| /
* max(ulp*(||T||+||B||)*(||x1||+||x2||),
* smlnum/ulp * (||T||+||B||), smlnum )
*
*
CALL DCOPY( 2*N, D, 1, Y, 1 )
Y( 1 ) = DDOT( N, B, 1, X( 1+N ), 1 ) +
$ SCALE*Y( 1 )
DO 50 I = 2, N
Y( I ) = W*X( I+N ) + SCALE*Y( I )
50 CONTINUE
CALL DGEMV( 'No transpose', N, N, ONE, T, LDT,
$ X, 1, -ONE, Y, 1 )
*
Y( 1+N ) = DDOT( N, B, 1, X, 1 ) -
$ SCALE*Y( 1+N )
DO 60 I = 2, N
Y( I+N ) = W*X( I ) - SCALE*Y( I+N )
60 CONTINUE
CALL DGEMV( 'No transpose', N, N, ONE, T, LDT,
$ X( 1+N ), 1, ONE, Y( 1+N ), 1 )
*
RESID = DASUM( 2*N, Y, 1 )
DOMIN = MAX( SMLNUM, ( SMLNUM / EPS )*NORMTB,
$ EPS*( NORMTB*DASUM( 2*N, X, 1 ) ) )
RESID = RESID / DOMIN
IF( RESID.GT.RMAX ) THEN
RMAX = RESID
LMAX = KNT
END IF
*
CALL DCOPY( 2*N, D, 1, X, 1 )
KNT = KNT + 1
CALL DLAQTR( .TRUE., .FALSE., N, T, LDT, B, W,
$ SCALE, X, WORK, INFO )
IF( INFO.NE.0 )
$ NINFO = NINFO + 1
*
* ||(T+i*B)*(x1+i*x2) - scale*(d1+i*d2)|| /
* max(ulp*(||T||+||B||)*(||x1||+||x2||),
* smlnum/ulp * (||T||+||B||), smlnum )
*
CALL DCOPY( 2*N, D, 1, Y, 1 )
Y( 1 ) = B( 1 )*X( 1+N ) - SCALE*Y( 1 )
DO 70 I = 2, N
Y( I ) = B( I )*X( 1+N ) + W*X( I+N ) -
$ SCALE*Y( I )
70 CONTINUE
CALL DGEMV( 'Transpose', N, N, ONE, T, LDT, X,
$ 1, ONE, Y, 1 )
*
Y( 1+N ) = B( 1 )*X( 1 ) + SCALE*Y( 1+N )
DO 80 I = 2, N
Y( I+N ) = B( I )*X( 1 ) + W*X( I ) +
$ SCALE*Y( I+N )
80 CONTINUE
CALL DGEMV( 'Transpose', N, N, ONE, T, LDT,
$ X( 1+N ), 1, -ONE, Y( 1+N ), 1 )
*
RESID = DASUM( 2*N, Y, 1 )
DOMIN = MAX( SMLNUM, ( SMLNUM / EPS )*NORMTB,
$ EPS*( NORMTB*DASUM( 2*N, X, 1 ) ) )
RESID = RESID / DOMIN
IF( RESID.GT.RMAX ) THEN
RMAX = RESID
LMAX = KNT
END IF
*
90 CONTINUE
100 CONTINUE
110 CONTINUE
120 CONTINUE
130 CONTINUE
140 CONTINUE
*
RETURN
*
* End of DGET39
*
END
SUBROUTINE DGET51( ITYPE, N, A, LDA, B, LDB, U, LDU, V, LDV, WORK,
$ RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER ITYPE, LDA, LDB, LDU, LDV, N
DOUBLE PRECISION RESULT
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), U( LDU, * ),
$ V( LDV, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGET51 generally checks a decomposition of the form
*
* A = U B V'
*
* where ' means transpose and U and V are orthogonal.
*
* Specifically, if ITYPE=1
*
* RESULT = | A - U B V' | / ( |A| n ulp )
*
* If ITYPE=2, then:
*
* RESULT = | A - B | / ( |A| n ulp )
*
* If ITYPE=3, then:
*
* RESULT = | I - UU' | / ( n ulp )
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* Specifies the type of tests to be performed.
* =1: RESULT = | A - U B V' | / ( |A| n ulp )
* =2: RESULT = | A - B | / ( |A| n ulp )
* =3: RESULT = | I - UU' | / ( n ulp )
*
* N (input) INTEGER
* The size of the matrix. If it is zero, DGET51 does nothing.
* It must be at least zero.
*
* A (input) DOUBLE PRECISION array, dimension (LDA, N)
* The original (unfactored) matrix.
*
* LDA (input) INTEGER
* The leading dimension of A. It must be at least 1
* and at least N.
*
* B (input) DOUBLE PRECISION array, dimension (LDB, N)
* The factored matrix.
*
* LDB (input) INTEGER
* The leading dimension of B. It must be at least 1
* and at least N.
*
* U (input) DOUBLE PRECISION array, dimension (LDU, N)
* The orthogonal matrix on the left-hand side in the
* decomposition.
* Not referenced if ITYPE=2
*
* LDU (input) INTEGER
* The leading dimension of U. LDU must be at least N and
* at least 1.
*
* V (input) DOUBLE PRECISION array, dimension (LDV, N)
* The orthogonal matrix on the left-hand side in the
* decomposition.
* Not referenced if ITYPE=2
*
* LDV (input) INTEGER
* The leading dimension of V. LDV must be at least N and
* at least 1.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (2*N**2)
*
* RESULT (output) DOUBLE PRECISION
* The values computed by the test specified by ITYPE. The
* value is currently limited to 1/ulp, to avoid overflow.
* Errors are flagged by RESULT=10/ulp.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TEN
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0 )
* ..
* .. Local Scalars ..
INTEGER JCOL, JDIAG, JROW
DOUBLE PRECISION ANORM, ULP, UNFL, WNORM
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLACPY
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
RESULT = ZERO
IF( N.LE.0 )
$ RETURN
*
* Constants
*
UNFL = DLAMCH( 'Safe minimum' )
ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
*
* Some Error Checks
*
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
RESULT = TEN / ULP
RETURN
END IF
*
IF( ITYPE.LE.2 ) THEN
*
* Tests scaled by the norm(A)
*
ANORM = MAX( DLANGE( '1', N, N, A, LDA, WORK ), UNFL )
*
IF( ITYPE.EQ.1 ) THEN
*
* ITYPE=1: Compute W = A - UBV'
*
CALL DLACPY( ' ', N, N, A, LDA, WORK, N )
CALL DGEMM( 'N', 'N', N, N, N, ONE, U, LDU, B, LDB, ZERO,
$ WORK( N**2+1 ), N )
*
CALL DGEMM( 'N', 'C', N, N, N, -ONE, WORK( N**2+1 ), N, V,
$ LDV, ONE, WORK, N )
*
ELSE
*
* ITYPE=2: Compute W = A - B
*
CALL DLACPY( ' ', N, N, B, LDB, WORK, N )
*
DO 20 JCOL = 1, N
DO 10 JROW = 1, N
WORK( JROW+N*( JCOL-1 ) ) = WORK( JROW+N*( JCOL-1 ) )
$ - A( JROW, JCOL )
10 CONTINUE
20 CONTINUE
END IF
*
* Compute norm(W)/ ( ulp*norm(A) )
*
WNORM = DLANGE( '1', N, N, WORK, N, WORK( N**2+1 ) )
*
IF( ANORM.GT.WNORM ) THEN
RESULT = ( WNORM / ANORM ) / ( N*ULP )
ELSE
IF( ANORM.LT.ONE ) THEN
RESULT = ( MIN( WNORM, N*ANORM ) / ANORM ) / ( N*ULP )
ELSE
RESULT = MIN( WNORM / ANORM, DBLE( N ) ) / ( N*ULP )
END IF
END IF
*
ELSE
*
* Tests not scaled by norm(A)
*
* ITYPE=3: Compute UU' - I
*
CALL DGEMM( 'N', 'C', N, N, N, ONE, U, LDU, U, LDU, ZERO, WORK,
$ N )
*
DO 30 JDIAG = 1, N
WORK( ( N+1 )*( JDIAG-1 )+1 ) = WORK( ( N+1 )*( JDIAG-1 )+
$ 1 ) - ONE
30 CONTINUE
*
RESULT = MIN( DLANGE( '1', N, N, WORK, N, WORK( N**2+1 ) ),
$ DBLE( N ) ) / ( N*ULP )
END IF
*
RETURN
*
* End of DGET51
*
END
SUBROUTINE DGET52( LEFT, N, A, LDA, B, LDB, E, LDE, ALPHAR,
$ ALPHAI, BETA, WORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
LOGICAL LEFT
INTEGER LDA, LDB, LDE, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
$ B( LDB, * ), BETA( * ), E( LDE, * ),
$ RESULT( 2 ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGET52 does an eigenvector check for the generalized eigenvalue
* problem.
*
* The basic test for right eigenvectors is:
*
* | b(j) A E(j) - a(j) B E(j) |
* RESULT(1) = max -------------------------------
* j n ulp max( |b(j) A|, |a(j) B| )
*
* using the 1-norm. Here, a(j)/b(j) = w is the j-th generalized
* eigenvalue of A - w B, or, equivalently, b(j)/a(j) = m is the j-th
* generalized eigenvalue of m A - B.
*
* For real eigenvalues, the test is straightforward. For complex
* eigenvalues, E(j) and a(j) are complex, represented by
* Er(j) + i*Ei(j) and ar(j) + i*ai(j), resp., so the test for that
* eigenvector becomes
*
* max( |Wr|, |Wi| )
* --------------------------------------------
* n ulp max( |b(j) A|, (|ar(j)|+|ai(j)|) |B| )
*
* where
*
* Wr = b(j) A Er(j) - ar(j) B Er(j) + ai(j) B Ei(j)
*
* Wi = b(j) A Ei(j) - ai(j) B Er(j) - ar(j) B Ei(j)
*
* T T _
* For left eigenvectors, A , B , a, and b are used.
*
* DGET52 also tests the normalization of E. Each eigenvector is
* supposed to be normalized so that the maximum "absolute value"
* of its elements is 1, where in this case, "absolute value"
* of a complex value x is |Re(x)| + |Im(x)| ; let us call this
* maximum "absolute value" norm of a vector v M(v).
* if a(j)=b(j)=0, then the eigenvector is set to be the jth coordinate
* vector. The normalization test is:
*
* RESULT(2) = max | M(v(j)) - 1 | / ( n ulp )
* eigenvectors v(j)
*
* Arguments
* =========
*
* LEFT (input) LOGICAL
* =.TRUE.: The eigenvectors in the columns of E are assumed
* to be *left* eigenvectors.
* =.FALSE.: The eigenvectors in the columns of E are assumed
* to be *right* eigenvectors.
*
* N (input) INTEGER
* The size of the matrices. If it is zero, DGET52 does
* nothing. It must be at least zero.
*
* A (input) DOUBLE PRECISION array, dimension (LDA, N)
* The matrix A.
*
* LDA (input) INTEGER
* The leading dimension of A. It must be at least 1
* and at least N.
*
* B (input) DOUBLE PRECISION array, dimension (LDB, N)
* The matrix B.
*
* LDB (input) INTEGER
* The leading dimension of B. It must be at least 1
* and at least N.
*
* E (input) DOUBLE PRECISION array, dimension (LDE, N)
* The matrix of eigenvectors. It must be O( 1 ). Complex
* eigenvalues and eigenvectors always come in pairs, the
* eigenvalue and its conjugate being stored in adjacent
* elements of ALPHAR, ALPHAI, and BETA. Thus, if a(j)/b(j)
* and a(j+1)/b(j+1) are a complex conjugate pair of
* generalized eigenvalues, then E(,j) contains the real part
* of the eigenvector and E(,j+1) contains the imaginary part.
* Note that whether E(,j) is a real eigenvector or part of a
* complex one is specified by whether ALPHAI(j) is zero or not.
*
* LDE (input) INTEGER
* The leading dimension of E. It must be at least 1 and at
* least N.
*
* ALPHAR (input) DOUBLE PRECISION array, dimension (N)
* The real parts of the values a(j) as described above, which,
* along with b(j), define the generalized eigenvalues.
* Complex eigenvalues always come in complex conjugate pairs
* a(j)/b(j) and a(j+1)/b(j+1), which are stored in adjacent
* elements in ALPHAR, ALPHAI, and BETA. Thus, if the j-th
* and (j+1)-st eigenvalues form a pair, ALPHAR(j+1)/BETA(j+1)
* is assumed to be equal to ALPHAR(j)/BETA(j).
*
* ALPHAI (input) DOUBLE PRECISION array, dimension (N)
* The imaginary parts of the values a(j) as described above,
* which, along with b(j), define the generalized eigenvalues.
* If ALPHAI(j)=0, then the eigenvalue is real, otherwise it
* is part of a complex conjugate pair. Complex eigenvalues
* always come in complex conjugate pairs a(j)/b(j) and
* a(j+1)/b(j+1), which are stored in adjacent elements in
* ALPHAR, ALPHAI, and BETA. Thus, if the j-th and (j+1)-st
* eigenvalues form a pair, ALPHAI(j+1)/BETA(j+1) is assumed to
* be equal to -ALPHAI(j)/BETA(j). Also, nonzero values in
* ALPHAI are assumed to always come in adjacent pairs.
*
* BETA (input) DOUBLE PRECISION array, dimension (N)
* The values b(j) as described above, which, along with a(j),
* define the generalized eigenvalues.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (N**2+N)
*
* RESULT (output) DOUBLE PRECISION array, dimension (2)
* The values computed by the test described above. If A E or
* B E is likely to overflow, then RESULT(1:2) is set to
* 10 / ulp.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TEN
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0 )
* ..
* .. Local Scalars ..
LOGICAL ILCPLX
CHARACTER NORMAB, TRANS
INTEGER J, JVEC
DOUBLE PRECISION ABMAX, ACOEF, ALFMAX, ANORM, BCOEFI, BCOEFR,
$ BETMAX, BNORM, ENORM, ENRMER, ERRNRM, SAFMAX,
$ SAFMIN, SALFI, SALFR, SBETA, SCALE, TEMP1, ULP
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DGEMV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX
* ..
* .. Executable Statements ..
*
RESULT( 1 ) = ZERO
RESULT( 2 ) = ZERO
IF( N.LE.0 )
$ RETURN
*
SAFMIN = DLAMCH( 'Safe minimum' )
SAFMAX = ONE / SAFMIN
ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
*
IF( LEFT ) THEN
TRANS = 'T'
NORMAB = 'I'
ELSE
TRANS = 'N'
NORMAB = 'O'
END IF
*
* Norm of A, B, and E:
*
ANORM = MAX( DLANGE( NORMAB, N, N, A, LDA, WORK ), SAFMIN )
BNORM = MAX( DLANGE( NORMAB, N, N, B, LDB, WORK ), SAFMIN )
ENORM = MAX( DLANGE( 'O', N, N, E, LDE, WORK ), ULP )
ALFMAX = SAFMAX / MAX( ONE, BNORM )
BETMAX = SAFMAX / MAX( ONE, ANORM )
*
* Compute error matrix.
* Column i = ( b(i) A - a(i) B ) E(i) / max( |a(i) B| |b(i) A| )
*
ILCPLX = .FALSE.
DO 10 JVEC = 1, N
IF( ILCPLX ) THEN
*
* 2nd Eigenvalue/-vector of pair -- do nothing
*
ILCPLX = .FALSE.
ELSE
SALFR = ALPHAR( JVEC )
SALFI = ALPHAI( JVEC )
SBETA = BETA( JVEC )
IF( SALFI.EQ.ZERO ) THEN
*
* Real eigenvalue and -vector
*
ABMAX = MAX( ABS( SALFR ), ABS( SBETA ) )
IF( ABS( SALFR ).GT.ALFMAX .OR. ABS( SBETA ).GT.
$ BETMAX .OR. ABMAX.LT.ONE ) THEN
SCALE = ONE / MAX( ABMAX, SAFMIN )
SALFR = SCALE*SALFR
SBETA = SCALE*SBETA
END IF
SCALE = ONE / MAX( ABS( SALFR )*BNORM,
$ ABS( SBETA )*ANORM, SAFMIN )
ACOEF = SCALE*SBETA
BCOEFR = SCALE*SALFR
CALL DGEMV( TRANS, N, N, ACOEF, A, LDA, E( 1, JVEC ), 1,
$ ZERO, WORK( N*( JVEC-1 )+1 ), 1 )
CALL DGEMV( TRANS, N, N, -BCOEFR, B, LDA, E( 1, JVEC ),
$ 1, ONE, WORK( N*( JVEC-1 )+1 ), 1 )
ELSE
*
* Complex conjugate pair
*
ILCPLX = .TRUE.
IF( JVEC.EQ.N ) THEN
RESULT( 1 ) = TEN / ULP
RETURN
END IF
ABMAX = MAX( ABS( SALFR )+ABS( SALFI ), ABS( SBETA ) )
IF( ABS( SALFR )+ABS( SALFI ).GT.ALFMAX .OR.
$ ABS( SBETA ).GT.BETMAX .OR. ABMAX.LT.ONE ) THEN
SCALE = ONE / MAX( ABMAX, SAFMIN )
SALFR = SCALE*SALFR
SALFI = SCALE*SALFI
SBETA = SCALE*SBETA
END IF
SCALE = ONE / MAX( ( ABS( SALFR )+ABS( SALFI ) )*BNORM,
$ ABS( SBETA )*ANORM, SAFMIN )
ACOEF = SCALE*SBETA
BCOEFR = SCALE*SALFR
BCOEFI = SCALE*SALFI
IF( LEFT ) THEN
BCOEFI = -BCOEFI
END IF
*
CALL DGEMV( TRANS, N, N, ACOEF, A, LDA, E( 1, JVEC ), 1,
$ ZERO, WORK( N*( JVEC-1 )+1 ), 1 )
CALL DGEMV( TRANS, N, N, -BCOEFR, B, LDA, E( 1, JVEC ),
$ 1, ONE, WORK( N*( JVEC-1 )+1 ), 1 )
CALL DGEMV( TRANS, N, N, BCOEFI, B, LDA, E( 1, JVEC+1 ),
$ 1, ONE, WORK( N*( JVEC-1 )+1 ), 1 )
*
CALL DGEMV( TRANS, N, N, ACOEF, A, LDA, E( 1, JVEC+1 ),
$ 1, ZERO, WORK( N*JVEC+1 ), 1 )
CALL DGEMV( TRANS, N, N, -BCOEFI, B, LDA, E( 1, JVEC ),
$ 1, ONE, WORK( N*JVEC+1 ), 1 )
CALL DGEMV( TRANS, N, N, -BCOEFR, B, LDA, E( 1, JVEC+1 ),
$ 1, ONE, WORK( N*JVEC+1 ), 1 )
END IF
END IF
10 CONTINUE
*
ERRNRM = DLANGE( 'One', N, N, WORK, N, WORK( N**2+1 ) ) / ENORM
*
* Compute RESULT(1)
*
RESULT( 1 ) = ERRNRM / ULP
*
* Normalization of E:
*
ENRMER = ZERO
ILCPLX = .FALSE.
DO 40 JVEC = 1, N
IF( ILCPLX ) THEN
ILCPLX = .FALSE.
ELSE
TEMP1 = ZERO
IF( ALPHAI( JVEC ).EQ.ZERO ) THEN
DO 20 J = 1, N
TEMP1 = MAX( TEMP1, ABS( E( J, JVEC ) ) )
20 CONTINUE
ENRMER = MAX( ENRMER, TEMP1-ONE )
ELSE
ILCPLX = .TRUE.
DO 30 J = 1, N
TEMP1 = MAX( TEMP1, ABS( E( J, JVEC ) )+
$ ABS( E( J, JVEC+1 ) ) )
30 CONTINUE
ENRMER = MAX( ENRMER, TEMP1-ONE )
END IF
END IF
40 CONTINUE
*
* Compute RESULT(2) : the normalization error in E.
*
RESULT( 2 ) = ENRMER / ( DBLE( N )*ULP )
*
RETURN
*
* End of DGET52
*
END
SUBROUTINE DGET53( A, LDA, B, LDB, SCALE, WR, WI, RESULT, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB
DOUBLE PRECISION RESULT, SCALE, WI, WR
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* DGET53 checks the generalized eigenvalues computed by DLAG2.
*
* The basic test for an eigenvalue is:
*
* | det( s A - w B ) |
* RESULT = ---------------------------------------------------
* ulp max( s norm(A), |w| norm(B) )*norm( s A - w B )
*
* Two "safety checks" are performed:
*
* (1) ulp*max( s*norm(A), |w|*norm(B) ) must be at least
* safe_minimum. This insures that the test performed is
* not essentially det(0*A + 0*B)=0.
*
* (2) s*norm(A) + |w|*norm(B) must be less than 1/safe_minimum.
* This insures that s*A - w*B will not overflow.
*
* If these tests are not passed, then s and w are scaled and
* tested anyway, if this is possible.
*
* Arguments
* =========
*
* A (input) DOUBLE PRECISION array, dimension (LDA, 2)
* The 2x2 matrix A.
*
* LDA (input) INTEGER
* The leading dimension of A. It must be at least 2.
*
* B (input) DOUBLE PRECISION array, dimension (LDB, N)
* The 2x2 upper-triangular matrix B.
*
* LDB (input) INTEGER
* The leading dimension of B. It must be at least 2.
*
* SCALE (input) DOUBLE PRECISION
* The "scale factor" s in the formula s A - w B . It is
* assumed to be non-negative.
*
* WR (input) DOUBLE PRECISION
* The real part of the eigenvalue w in the formula
* s A - w B .
*
* WI (input) DOUBLE PRECISION
* The imaginary part of the eigenvalue w in the formula
* s A - w B .
*
* RESULT (output) DOUBLE PRECISION
* If INFO is 2 or less, the value computed by the test
* described above.
* If INFO=3, this will just be 1/ulp.
*
* INFO (output) INTEGER
* =0: The input data pass the "safety checks".
* =1: s*norm(A) + |w|*norm(B) > 1/safe_minimum.
* =2: ulp*max( s*norm(A), |w|*norm(B) ) < safe_minimum
* =3: same as INFO=2, but s and w could not be scaled so
* as to compute the test.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION ABSW, ANORM, BNORM, CI11, CI12, CI22, CNORM,
$ CR11, CR12, CR21, CR22, CSCALE, DETI, DETR, S1,
$ SAFMIN, SCALES, SIGMIN, TEMP, ULP, WIS, WRS
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Initialize
*
INFO = 0
RESULT = ZERO
SCALES = SCALE
WRS = WR
WIS = WI
*
* Machine constants and norms
*
SAFMIN = DLAMCH( 'Safe minimum' )
ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
ABSW = ABS( WRS ) + ABS( WIS )
ANORM = MAX( ABS( A( 1, 1 ) )+ABS( A( 2, 1 ) ),
$ ABS( A( 1, 2 ) )+ABS( A( 2, 2 ) ), SAFMIN )
BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 1, 2 ) )+ABS( B( 2, 2 ) ),
$ SAFMIN )
*
* Check for possible overflow.
*
TEMP = ( SAFMIN*BNORM )*ABSW + ( SAFMIN*ANORM )*SCALES
IF( TEMP.GE.ONE ) THEN
*
* Scale down to avoid overflow
*
INFO = 1
TEMP = ONE / TEMP
SCALES = SCALES*TEMP
WRS = WRS*TEMP
WIS = WIS*TEMP
ABSW = ABS( WRS ) + ABS( WIS )
END IF
S1 = MAX( ULP*MAX( SCALES*ANORM, ABSW*BNORM ),
$ SAFMIN*MAX( SCALES, ABSW ) )
*
* Check for W and SCALE essentially zero.
*
IF( S1.LT.SAFMIN ) THEN
INFO = 2
IF( SCALES.LT.SAFMIN .AND. ABSW.LT.SAFMIN ) THEN
INFO = 3
RESULT = ONE / ULP
RETURN
END IF
*
* Scale up to avoid underflow
*
TEMP = ONE / MAX( SCALES*ANORM+ABSW*BNORM, SAFMIN )
SCALES = SCALES*TEMP
WRS = WRS*TEMP
WIS = WIS*TEMP
ABSW = ABS( WRS ) + ABS( WIS )
S1 = MAX( ULP*MAX( SCALES*ANORM, ABSW*BNORM ),
$ SAFMIN*MAX( SCALES, ABSW ) )
IF( S1.LT.SAFMIN ) THEN
INFO = 3
RESULT = ONE / ULP
RETURN
END IF
END IF
*
* Compute C = s A - w B
*
CR11 = SCALES*A( 1, 1 ) - WRS*B( 1, 1 )
CI11 = -WIS*B( 1, 1 )
CR21 = SCALES*A( 2, 1 )
CR12 = SCALES*A( 1, 2 ) - WRS*B( 1, 2 )
CI12 = -WIS*B( 1, 2 )
CR22 = SCALES*A( 2, 2 ) - WRS*B( 2, 2 )
CI22 = -WIS*B( 2, 2 )
*
* Compute the smallest singular value of s A - w B:
*
* |det( s A - w B )|
* sigma_min = ------------------
* norm( s A - w B )
*
CNORM = MAX( ABS( CR11 )+ABS( CI11 )+ABS( CR21 ),
$ ABS( CR12 )+ABS( CI12 )+ABS( CR22 )+ABS( CI22 ), SAFMIN )
CSCALE = ONE / SQRT( CNORM )
DETR = ( CSCALE*CR11 )*( CSCALE*CR22 ) -
$ ( CSCALE*CI11 )*( CSCALE*CI22 ) -
$ ( CSCALE*CR12 )*( CSCALE*CR21 )
DETI = ( CSCALE*CR11 )*( CSCALE*CI22 ) +
$ ( CSCALE*CI11 )*( CSCALE*CR22 ) -
$ ( CSCALE*CI12 )*( CSCALE*CR21 )
SIGMIN = ABS( DETR ) + ABS( DETI )
RESULT = SIGMIN / S1
RETURN
*
* End of DGET53
*
END
SUBROUTINE DGET54( N, A, LDA, B, LDB, S, LDS, T, LDT, U, LDU, V,
$ LDV, WORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDB, LDS, LDT, LDU, LDV, N
DOUBLE PRECISION RESULT
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( LDS, * ),
$ T( LDT, * ), U( LDU, * ), V( LDV, * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* DGET54 checks a generalized decomposition of the form
*
* A = U*S*V' and B = U*T* V'
*
* where ' means transpose and U and V are orthogonal.
*
* Specifically,
*
* RESULT = ||( A - U*S*V', B - U*T*V' )|| / (||( A, B )||*n*ulp )
*
* Arguments
* =========
*
* N (input) INTEGER
* The size of the matrix. If it is zero, DGET54 does nothing.
* It must be at least zero.
*
* A (input) DOUBLE PRECISION array, dimension (LDA, N)
* The original (unfactored) matrix A.
*
* LDA (input) INTEGER
* The leading dimension of A. It must be at least 1
* and at least N.
*
* B (input) DOUBLE PRECISION array, dimension (LDB, N)
* The original (unfactored) matrix B.
*
* LDB (input) INTEGER
* The leading dimension of B. It must be at least 1
* and at least N.
*
* S (input) DOUBLE PRECISION array, dimension (LDS, N)
* The factored matrix S.
*
* LDS (input) INTEGER
* The leading dimension of S. It must be at least 1
* and at least N.
*
* T (input) DOUBLE PRECISION array, dimension (LDT, N)
* The factored matrix T.
*
* LDT (input) INTEGER
* The leading dimension of T. It must be at least 1
* and at least N.
*
* U (input) DOUBLE PRECISION array, dimension (LDU, N)
* The orthogonal matrix on the left-hand side in the
* decomposition.
*
* LDU (input) INTEGER
* The leading dimension of U. LDU must be at least N and
* at least 1.
*
* V (input) DOUBLE PRECISION array, dimension (LDV, N)
* The orthogonal matrix on the left-hand side in the
* decomposition.
*
* LDV (input) INTEGER
* The leading dimension of V. LDV must be at least N and
* at least 1.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N**2)
*
* RESULT (output) DOUBLE PRECISION
* The value RESULT, It is currently limited to 1/ulp, to
* avoid overflow. Errors are flagged by RESULT=10/ulp.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION ABNORM, ULP, UNFL, WNORM
* ..
* .. Local Arrays ..
DOUBLE PRECISION DUM( 1 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLACPY
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
RESULT = ZERO
IF( N.LE.0 )
$ RETURN
*
* Constants
*
UNFL = DLAMCH( 'Safe minimum' )
ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
*
* compute the norm of (A,B)
*
CALL DLACPY( 'Full', N, N, A, LDA, WORK, N )
CALL DLACPY( 'Full', N, N, B, LDB, WORK( N*N+1 ), N )
ABNORM = MAX( DLANGE( '1', N, 2*N, WORK, N, DUM ), UNFL )
*
* Compute W1 = A - U*S*V', and put in the array WORK(1:N*N)
*
CALL DLACPY( ' ', N, N, A, LDA, WORK, N )
CALL DGEMM( 'N', 'N', N, N, N, ONE, U, LDU, S, LDS, ZERO,
$ WORK( N*N+1 ), N )
*
CALL DGEMM( 'N', 'C', N, N, N, -ONE, WORK( N*N+1 ), N, V, LDV,
$ ONE, WORK, N )
*
* Compute W2 = B - U*T*V', and put in the workarray W(N*N+1:2*N*N)
*
CALL DLACPY( ' ', N, N, B, LDB, WORK( N*N+1 ), N )
CALL DGEMM( 'N', 'N', N, N, N, ONE, U, LDU, T, LDT, ZERO,
$ WORK( 2*N*N+1 ), N )
*
CALL DGEMM( 'N', 'C', N, N, N, -ONE, WORK( 2*N*N+1 ), N, V, LDV,
$ ONE, WORK( N*N+1 ), N )
*
* Compute norm(W)/ ( ulp*norm((A,B)) )
*
WNORM = DLANGE( '1', N, 2*N, WORK, N, DUM )
*
IF( ABNORM.GT.WNORM ) THEN
RESULT = ( WNORM / ABNORM ) / ( 2*N*ULP )
ELSE
IF( ABNORM.LT.ONE ) THEN
RESULT = ( MIN( WNORM, 2*N*ABNORM ) / ABNORM ) / ( 2*N*ULP )
ELSE
RESULT = MIN( WNORM / ABNORM, DBLE( 2*N ) ) / ( 2*N*ULP )
END IF
END IF
*
RETURN
*
* End of DGET54
*
END
SUBROUTINE DGLMTS( N, M, P, A, AF, LDA, B, BF, LDB, D, DF, X, U,
$ WORK, LWORK, RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDB, LWORK, M, N, P
DOUBLE PRECISION RESULT
* ..
* .. Array Arguments ..
*
* Purpose
* =======
*
* DGLMTS tests DGGGLM - a subroutine for solving the generalized
* linear model problem.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of rows of the matrices A and B. N >= 0.
*
* M (input) INTEGER
* The number of columns of the matrix A. M >= 0.
*
* P (input) INTEGER
* The number of columns of the matrix B. P >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,M)
* The N-by-M matrix A.
*
* AF (workspace) DOUBLE PRECISION array, dimension (LDA,M)
*
* LDA (input) INTEGER
* The leading dimension of the arrays A, AF. LDA >= max(M,N).
*
* B (input) DOUBLE PRECISION array, dimension (LDB,P)
* The N-by-P matrix A.
*
* BF (workspace) DOUBLE PRECISION array, dimension (LDB,P)
*
* LDB (input) INTEGER
* The leading dimension of the arrays B, BF. LDB >= max(P,N).
*
* D (input) DOUBLE PRECISION array, dimension( N )
* On input, the left hand side of the GLM.
*
* DF (workspace) DOUBLE PRECISION array, dimension( N )
*
* X (output) DOUBLE PRECISION array, dimension( M )
* solution vector X in the GLM problem.
*
* U (output) DOUBLE PRECISION array, dimension( P )
* solution vector U in the GLM problem.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (M)
*
* RESULT (output) DOUBLE PRECISION
* The test ratio:
* norm( d - A*x - B*u )
* RESULT = -----------------------------------------
* (norm(A)+norm(B))*(norm(x)+norm(u))*EPS
*
* ====================================================================
*
DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), B( LDB, * ),
$ BF( LDB, * ), D( * ), DF( * ), RWORK( * ),
$ U( * ), WORK( LWORK ), X( * )
* ..
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER INFO
DOUBLE PRECISION ANORM, BNORM, DNORM, EPS, UNFL, XNORM, YNORM
* ..
* .. External Functions ..
DOUBLE PRECISION DASUM, DLAMCH, DLANGE
EXTERNAL DASUM, DLAMCH, DLANGE
* ..
* .. External Subroutines ..
*
EXTERNAL DCOPY, DGEMV, DGGGLM, DLACPY
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
EPS = DLAMCH( 'Epsilon' )
UNFL = DLAMCH( 'Safe minimum' )
ANORM = MAX( DLANGE( '1', N, M, A, LDA, RWORK ), UNFL )
BNORM = MAX( DLANGE( '1', N, P, B, LDB, RWORK ), UNFL )
*
* Copy the matrices A and B to the arrays AF and BF,
* and the vector D the array DF.
*
CALL DLACPY( 'Full', N, M, A, LDA, AF, LDA )
CALL DLACPY( 'Full', N, P, B, LDB, BF, LDB )
CALL DCOPY( N, D, 1, DF, 1 )
*
* Solve GLM problem
*
CALL DGGGLM( N, M, P, AF, LDA, BF, LDB, DF, X, U, WORK, LWORK,
$ INFO )
*
* Test the residual for the solution of LSE
*
* norm( d - A*x - B*u )
* RESULT = -----------------------------------------
* (norm(A)+norm(B))*(norm(x)+norm(u))*EPS
*
CALL DCOPY( N, D, 1, DF, 1 )
CALL DGEMV( 'No transpose', N, M, -ONE, A, LDA, X, 1, ONE, DF, 1 )
*
CALL DGEMV( 'No transpose', N, P, -ONE, B, LDB, U, 1, ONE, DF, 1 )
*
DNORM = DASUM( N, DF, 1 )
XNORM = DASUM( M, X, 1 ) + DASUM( P, U, 1 )
YNORM = ANORM + BNORM
*
IF( XNORM.LE.ZERO ) THEN
RESULT = ZERO
ELSE
RESULT = ( ( DNORM / YNORM ) / XNORM ) / EPS
END IF
*
RETURN
*
* End of DGLMTS
*
END
SUBROUTINE DGQRTS( N, M, P, A, AF, Q, R, LDA, TAUA, B, BF, Z, T,
$ BWK, LDB, TAUB, WORK, LWORK, RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDB, LWORK, M, N, P
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), B( LDB, * ),
$ BF( LDB, * ), BWK( LDB, * ), Q( LDA, * ),
$ R( LDA, * ), RESULT( 4 ), RWORK( * ),
$ T( LDB, * ), TAUA( * ), TAUB( * ),
$ WORK( LWORK ), Z( LDB, * )
* ..
*
* Purpose
* =======
*
* DGQRTS tests DGGQRF, which computes the GQR factorization of an
* N-by-M matrix A and a N-by-P matrix B: A = Q*R and B = Q*T*Z.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of rows of the matrices A and B. N >= 0.
*
* M (input) INTEGER
* The number of columns of the matrix A. M >= 0.
*
* P (input) INTEGER
* The number of columns of the matrix B. P >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,M)
* The N-by-M matrix A.
*
* AF (output) DOUBLE PRECISION array, dimension (LDA,N)
* Details of the GQR factorization of A and B, as returned
* by DGGQRF, see SGGQRF for further details.
*
* Q (output) DOUBLE PRECISION array, dimension (LDA,N)
* The M-by-M orthogonal matrix Q.
*
* R (workspace) DOUBLE PRECISION array, dimension (LDA,MAX(M,N))
*
* LDA (input) INTEGER
* The leading dimension of the arrays A, AF, R and Q.
* LDA >= max(M,N).
*
* TAUA (output) DOUBLE PRECISION array, dimension (min(M,N))
* The scalar factors of the elementary reflectors, as returned
* by DGGQRF.
*
* B (input) DOUBLE PRECISION array, dimension (LDB,P)
* On entry, the N-by-P matrix A.
*
* BF (output) DOUBLE PRECISION array, dimension (LDB,N)
* Details of the GQR factorization of A and B, as returned
* by DGGQRF, see SGGQRF for further details.
*
* Z (output) DOUBLE PRECISION array, dimension (LDB,P)
* The P-by-P orthogonal matrix Z.
*
* T (workspace) DOUBLE PRECISION array, dimension (LDB,max(P,N))
*
* BWK (workspace) DOUBLE PRECISION array, dimension (LDB,N)
*
* LDB (input) INTEGER
* The leading dimension of the arrays B, BF, Z and T.
* LDB >= max(P,N).
*
* TAUB (output) DOUBLE PRECISION array, dimension (min(P,N))
* The scalar factors of the elementary reflectors, as returned
* by DGGRQF.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The dimension of the array WORK, LWORK >= max(N,M,P)**2.
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (max(N,M,P))
*
* RESULT (output) DOUBLE PRECISION array, dimension (4)
* The test ratios:
* RESULT(1) = norm( R - Q'*A ) / ( MAX(M,N)*norm(A)*ULP)
* RESULT(2) = norm( T*Z - Q'*B ) / (MAX(P,N)*norm(B)*ULP)
* RESULT(3) = norm( I - Q'*Q ) / ( M*ULP )
* RESULT(4) = norm( I - Z'*Z ) / ( P*ULP )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION ROGUE
PARAMETER ( ROGUE = -1.0D+10 )
* ..
* .. Local Scalars ..
INTEGER INFO
DOUBLE PRECISION ANORM, BNORM, RESID, ULP, UNFL
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
EXTERNAL DLAMCH, DLANGE, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DGGQRF, DLACPY, DLASET, DORGQR, DORGRQ,
$ DSYRK
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
ULP = DLAMCH( 'Precision' )
UNFL = DLAMCH( 'Safe minimum' )
*
* Copy the matrix A to the array AF.
*
CALL DLACPY( 'Full', N, M, A, LDA, AF, LDA )
CALL DLACPY( 'Full', N, P, B, LDB, BF, LDB )
*
ANORM = MAX( DLANGE( '1', N, M, A, LDA, RWORK ), UNFL )
BNORM = MAX( DLANGE( '1', N, P, B, LDB, RWORK ), UNFL )
*
* Factorize the matrices A and B in the arrays AF and BF.
*
CALL DGGQRF( N, M, P, AF, LDA, TAUA, BF, LDB, TAUB, WORK, LWORK,
$ INFO )
*
* Generate the N-by-N matrix Q
*
CALL DLASET( 'Full', N, N, ROGUE, ROGUE, Q, LDA )
CALL DLACPY( 'Lower', N-1, M, AF( 2, 1 ), LDA, Q( 2, 1 ), LDA )
CALL DORGQR( N, N, MIN( N, M ), Q, LDA, TAUA, WORK, LWORK, INFO )
*
* Generate the P-by-P matrix Z
*
CALL DLASET( 'Full', P, P, ROGUE, ROGUE, Z, LDB )
IF( N.LE.P ) THEN
IF( N.GT.0 .AND. N.LT.P )
$ CALL DLACPY( 'Full', N, P-N, BF, LDB, Z( P-N+1, 1 ), LDB )
IF( N.GT.1 )
$ CALL DLACPY( 'Lower', N-1, N-1, BF( 2, P-N+1 ), LDB,
$ Z( P-N+2, P-N+1 ), LDB )
ELSE
IF( P.GT.1 )
$ CALL DLACPY( 'Lower', P-1, P-1, BF( N-P+2, 1 ), LDB,
$ Z( 2, 1 ), LDB )
END IF
CALL DORGRQ( P, P, MIN( N, P ), Z, LDB, TAUB, WORK, LWORK, INFO )
*
* Copy R
*
CALL DLASET( 'Full', N, M, ZERO, ZERO, R, LDA )
CALL DLACPY( 'Upper', N, M, AF, LDA, R, LDA )
*
* Copy T
*
CALL DLASET( 'Full', N, P, ZERO, ZERO, T, LDB )
IF( N.LE.P ) THEN
CALL DLACPY( 'Upper', N, N, BF( 1, P-N+1 ), LDB, T( 1, P-N+1 ),
$ LDB )
ELSE
CALL DLACPY( 'Full', N-P, P, BF, LDB, T, LDB )
CALL DLACPY( 'Upper', P, P, BF( N-P+1, 1 ), LDB, T( N-P+1, 1 ),
$ LDB )
END IF
*
* Compute R - Q'*A
*
CALL DGEMM( 'Transpose', 'No transpose', N, M, N, -ONE, Q, LDA, A,
$ LDA, ONE, R, LDA )
*
* Compute norm( R - Q'*A ) / ( MAX(M,N)*norm(A)*ULP ) .
*
RESID = DLANGE( '1', N, M, R, LDA, RWORK )
IF( ANORM.GT.ZERO ) THEN
RESULT( 1 ) = ( ( RESID / DBLE( MAX( 1, M, N ) ) ) / ANORM ) /
$ ULP
ELSE
RESULT( 1 ) = ZERO
END IF
*
* Compute T*Z - Q'*B
*
CALL DGEMM( 'No Transpose', 'No transpose', N, P, P, ONE, T, LDB,
$ Z, LDB, ZERO, BWK, LDB )
CALL DGEMM( 'Transpose', 'No transpose', N, P, N, -ONE, Q, LDA, B,
$ LDB, ONE, BWK, LDB )
*
* Compute norm( T*Z - Q'*B ) / ( MAX(P,N)*norm(A)*ULP ) .
*
RESID = DLANGE( '1', N, P, BWK, LDB, RWORK )
IF( BNORM.GT.ZERO ) THEN
RESULT( 2 ) = ( ( RESID / DBLE( MAX( 1, P, N ) ) ) / BNORM ) /
$ ULP
ELSE
RESULT( 2 ) = ZERO
END IF
*
* Compute I - Q'*Q
*
CALL DLASET( 'Full', N, N, ZERO, ONE, R, LDA )
CALL DSYRK( 'Upper', 'Transpose', N, N, -ONE, Q, LDA, ONE, R,
$ LDA )
*
* Compute norm( I - Q'*Q ) / ( N * ULP ) .
*
RESID = DLANSY( '1', 'Upper', N, R, LDA, RWORK )
RESULT( 3 ) = ( RESID / DBLE( MAX( 1, N ) ) ) / ULP
*
* Compute I - Z'*Z
*
CALL DLASET( 'Full', P, P, ZERO, ONE, T, LDB )
CALL DSYRK( 'Upper', 'Transpose', P, P, -ONE, Z, LDB, ONE, T,
$ LDB )
*
* Compute norm( I - Z'*Z ) / ( P*ULP ) .
*
RESID = DLANSY( '1', 'Upper', P, T, LDB, RWORK )
RESULT( 4 ) = ( RESID / DBLE( MAX( 1, P ) ) ) / ULP
*
RETURN
*
* End of DGQRTS
*
END
SUBROUTINE DGRQTS( M, P, N, A, AF, Q, R, LDA, TAUA, B, BF, Z, T,
$ BWK, LDB, TAUB, WORK, LWORK, RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDB, LWORK, M, N, P
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), B( LDB, * ),
$ BF( LDB, * ), BWK( LDB, * ), Q( LDA, * ),
$ R( LDA, * ), RESULT( 4 ), RWORK( * ),
$ T( LDB, * ), TAUA( * ), TAUB( * ),
$ WORK( LWORK ), Z( LDB, * )
* ..
*
* Purpose
* =======
*
* DGRQTS tests DGGRQF, which computes the GRQ factorization of an
* M-by-N matrix A and a P-by-N matrix B: A = R*Q and B = Z*T*Q.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix A. M >= 0.
*
* P (input) INTEGER
* The number of rows of the matrix B. P >= 0.
*
* N (input) INTEGER
* The number of columns of the matrices A and B. N >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The M-by-N matrix A.
*
* AF (output) DOUBLE PRECISION array, dimension (LDA,N)
* Details of the GRQ factorization of A and B, as returned
* by DGGRQF, see SGGRQF for further details.
*
* Q (output) DOUBLE PRECISION array, dimension (LDA,N)
* The N-by-N orthogonal matrix Q.
*
* R (workspace) DOUBLE PRECISION array, dimension (LDA,MAX(M,N))
*
* LDA (input) INTEGER
* The leading dimension of the arrays A, AF, R and Q.
* LDA >= max(M,N).
*
* TAUA (output) DOUBLE PRECISION array, dimension (min(M,N))
* The scalar factors of the elementary reflectors, as returned
* by DGGQRC.
*
* B (input) DOUBLE PRECISION array, dimension (LDB,N)
* On entry, the P-by-N matrix A.
*
* BF (output) DOUBLE PRECISION array, dimension (LDB,N)
* Details of the GQR factorization of A and B, as returned
* by DGGRQF, see SGGRQF for further details.
*
* Z (output) DOUBLE PRECISION array, dimension (LDB,P)
* The P-by-P orthogonal matrix Z.
*
* T (workspace) DOUBLE PRECISION array, dimension (LDB,max(P,N))
*
* BWK (workspace) DOUBLE PRECISION array, dimension (LDB,N)
*
* LDB (input) INTEGER
* The leading dimension of the arrays B, BF, Z and T.
* LDB >= max(P,N).
*
* TAUB (output) DOUBLE PRECISION array, dimension (min(P,N))
* The scalar factors of the elementary reflectors, as returned
* by DGGRQF.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The dimension of the array WORK, LWORK >= max(M,P,N)**2.
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (M)
*
* RESULT (output) DOUBLE PRECISION array, dimension (4)
* The test ratios:
* RESULT(1) = norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP)
* RESULT(2) = norm( T*Q - Z'*B ) / (MAX(P,N)*norm(B)*ULP)
* RESULT(3) = norm( I - Q'*Q ) / ( N*ULP )
* RESULT(4) = norm( I - Z'*Z ) / ( P*ULP )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION ROGUE
PARAMETER ( ROGUE = -1.0D+10 )
* ..
* .. Local Scalars ..
INTEGER INFO
DOUBLE PRECISION ANORM, BNORM, RESID, ULP, UNFL
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
EXTERNAL DLAMCH, DLANGE, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DGGRQF, DLACPY, DLASET, DORGQR, DORGRQ,
$ DSYRK
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
ULP = DLAMCH( 'Precision' )
UNFL = DLAMCH( 'Safe minimum' )
*
* Copy the matrix A to the array AF.
*
CALL DLACPY( 'Full', M, N, A, LDA, AF, LDA )
CALL DLACPY( 'Full', P, N, B, LDB, BF, LDB )
*
ANORM = MAX( DLANGE( '1', M, N, A, LDA, RWORK ), UNFL )
BNORM = MAX( DLANGE( '1', P, N, B, LDB, RWORK ), UNFL )
*
* Factorize the matrices A and B in the arrays AF and BF.
*
CALL DGGRQF( M, P, N, AF, LDA, TAUA, BF, LDB, TAUB, WORK, LWORK,
$ INFO )
*
* Generate the N-by-N matrix Q
*
CALL DLASET( 'Full', N, N, ROGUE, ROGUE, Q, LDA )
IF( M.LE.N ) THEN
IF( M.GT.0 .AND. M.LT.N )
$ CALL DLACPY( 'Full', M, N-M, AF, LDA, Q( N-M+1, 1 ), LDA )
IF( M.GT.1 )
$ CALL DLACPY( 'Lower', M-1, M-1, AF( 2, N-M+1 ), LDA,
$ Q( N-M+2, N-M+1 ), LDA )
ELSE
IF( N.GT.1 )
$ CALL DLACPY( 'Lower', N-1, N-1, AF( M-N+2, 1 ), LDA,
$ Q( 2, 1 ), LDA )
END IF
CALL DORGRQ( N, N, MIN( M, N ), Q, LDA, TAUA, WORK, LWORK, INFO )
*
* Generate the P-by-P matrix Z
*
CALL DLASET( 'Full', P, P, ROGUE, ROGUE, Z, LDB )
IF( P.GT.1 )
$ CALL DLACPY( 'Lower', P-1, N, BF( 2, 1 ), LDB, Z( 2, 1 ), LDB )
CALL DORGQR( P, P, MIN( P, N ), Z, LDB, TAUB, WORK, LWORK, INFO )
*
* Copy R
*
CALL DLASET( 'Full', M, N, ZERO, ZERO, R, LDA )
IF( M.LE.N ) THEN
CALL DLACPY( 'Upper', M, M, AF( 1, N-M+1 ), LDA, R( 1, N-M+1 ),
$ LDA )
ELSE
CALL DLACPY( 'Full', M-N, N, AF, LDA, R, LDA )
CALL DLACPY( 'Upper', N, N, AF( M-N+1, 1 ), LDA, R( M-N+1, 1 ),
$ LDA )
END IF
*
* Copy T
*
CALL DLASET( 'Full', P, N, ZERO, ZERO, T, LDB )
CALL DLACPY( 'Upper', P, N, BF, LDB, T, LDB )
*
* Compute R - A*Q'
*
CALL DGEMM( 'No transpose', 'Transpose', M, N, N, -ONE, A, LDA, Q,
$ LDA, ONE, R, LDA )
*
* Compute norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP ) .
*
RESID = DLANGE( '1', M, N, R, LDA, RWORK )
IF( ANORM.GT.ZERO ) THEN
RESULT( 1 ) = ( ( RESID / DBLE( MAX( 1, M, N ) ) ) / ANORM ) /
$ ULP
ELSE
RESULT( 1 ) = ZERO
END IF
*
* Compute T*Q - Z'*B
*
CALL DGEMM( 'Transpose', 'No transpose', P, N, P, ONE, Z, LDB, B,
$ LDB, ZERO, BWK, LDB )
CALL DGEMM( 'No transpose', 'No transpose', P, N, N, ONE, T, LDB,
$ Q, LDA, -ONE, BWK, LDB )
*
* Compute norm( T*Q - Z'*B ) / ( MAX(P,N)*norm(A)*ULP ) .
*
RESID = DLANGE( '1', P, N, BWK, LDB, RWORK )
IF( BNORM.GT.ZERO ) THEN
RESULT( 2 ) = ( ( RESID / DBLE( MAX( 1, P, M ) ) ) / BNORM ) /
$ ULP
ELSE
RESULT( 2 ) = ZERO
END IF
*
* Compute I - Q*Q'
*
CALL DLASET( 'Full', N, N, ZERO, ONE, R, LDA )
CALL DSYRK( 'Upper', 'No Transpose', N, N, -ONE, Q, LDA, ONE, R,
$ LDA )
*
* Compute norm( I - Q'*Q ) / ( N * ULP ) .
*
RESID = DLANSY( '1', 'Upper', N, R, LDA, RWORK )
RESULT( 3 ) = ( RESID / DBLE( MAX( 1, N ) ) ) / ULP
*
* Compute I - Z'*Z
*
CALL DLASET( 'Full', P, P, ZERO, ONE, T, LDB )
CALL DSYRK( 'Upper', 'Transpose', P, P, -ONE, Z, LDB, ONE, T,
$ LDB )
*
* Compute norm( I - Z'*Z ) / ( P*ULP ) .
*
RESID = DLANSY( '1', 'Upper', P, T, LDB, RWORK )
RESULT( 4 ) = ( RESID / DBLE( MAX( 1, P ) ) ) / ULP
*
RETURN
*
* End of DGRQTS
*
END
SUBROUTINE DGSVTS( M, P, N, A, AF, LDA, B, BF, LDB, U, LDU, V,
$ LDV, Q, LDQ, ALPHA, BETA, R, LDR, IWORK, WORK,
$ LWORK, RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDB, LDQ, LDR, LDU, LDV, LWORK, M, N, P
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), ALPHA( * ),
$ B( LDB, * ), BETA( * ), BF( LDB, * ),
$ Q( LDQ, * ), R( LDR, * ), RESULT( 6 ),
$ RWORK( * ), U( LDU, * ), V( LDV, * ),
$ WORK( LWORK )
* ..
*
* Purpose
* =======
*
* DGSVTS tests DGGSVD, which computes the GSVD of an M-by-N matrix A
* and a P-by-N matrix B:
* U'*A*Q = D1*R and V'*B*Q = D2*R.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix A. M >= 0.
*
* P (input) INTEGER
* The number of rows of the matrix B. P >= 0.
*
* N (input) INTEGER
* The number of columns of the matrices A and B. N >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,M)
* The M-by-N matrix A.
*
* AF (output) DOUBLE PRECISION array, dimension (LDA,N)
* Details of the GSVD of A and B, as returned by DGGSVD,
* see DGGSVD for further details.
*
* LDA (input) INTEGER
* The leading dimension of the arrays A and AF.
* LDA >= max( 1,M ).
*
* B (input) DOUBLE PRECISION array, dimension (LDB,P)
* On entry, the P-by-N matrix B.
*
* BF (output) DOUBLE PRECISION array, dimension (LDB,N)
* Details of the GSVD of A and B, as returned by DGGSVD,
* see DGGSVD for further details.
*
* LDB (input) INTEGER
* The leading dimension of the arrays B and BF.
* LDB >= max(1,P).
*
* U (output) DOUBLE PRECISION array, dimension(LDU,M)
* The M by M orthogonal matrix U.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= max(1,M).
*
* V (output) DOUBLE PRECISION array, dimension(LDV,M)
* The P by P orthogonal matrix V.
*
* LDV (input) INTEGER
* The leading dimension of the array V. LDV >= max(1,P).
*
* Q (output) DOUBLE PRECISION array, dimension(LDQ,N)
* The N by N orthogonal matrix Q.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* ALPHA (output) DOUBLE PRECISION array, dimension (N)
* BETA (output) DOUBLE PRECISION array, dimension (N)
* The generalized singular value pairs of A and B, the
* ``diagonal'' matrices D1 and D2 are constructed from
* ALPHA and BETA, see subroutine DGGSVD for details.
*
* R (output) DOUBLE PRECISION array, dimension(LDQ,N)
* The upper triangular matrix R.
*
* LDR (input) INTEGER
* The leading dimension of the array R. LDR >= max(1,N).
*
* IWORK (workspace) INTEGER array, dimension (N)
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The dimension of the array WORK,
* LWORK >= max(M,P,N)*max(M,P,N).
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (max(M,P,N))
*
* RESULT (output) DOUBLE PRECISION array, dimension (6)
* The test ratios:
* RESULT(1) = norm( U'*A*Q - D1*R ) / ( MAX(M,N)*norm(A)*ULP)
* RESULT(2) = norm( V'*B*Q - D2*R ) / ( MAX(P,N)*norm(B)*ULP)
* RESULT(3) = norm( I - U'*U ) / ( M*ULP )
* RESULT(4) = norm( I - V'*V ) / ( P*ULP )
* RESULT(5) = norm( I - Q'*Q ) / ( N*ULP )
* RESULT(6) = 0 if ALPHA is in decreasing order;
* = ULPINV otherwise.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J, K, L
DOUBLE PRECISION ANORM, BNORM, RESID, TEMP, ULP, ULPINV, UNFL
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
EXTERNAL DLAMCH, DLANGE, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMM, DGGSVD, DLACPY, DLASET, DSYRK
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
ULP = DLAMCH( 'Precision' )
ULPINV = ONE / ULP
UNFL = DLAMCH( 'Safe minimum' )
*
* Copy the matrix A to the array AF.
*
CALL DLACPY( 'Full', M, N, A, LDA, AF, LDA )
CALL DLACPY( 'Full', P, N, B, LDB, BF, LDB )
*
ANORM = MAX( DLANGE( '1', M, N, A, LDA, RWORK ), UNFL )
BNORM = MAX( DLANGE( '1', P, N, B, LDB, RWORK ), UNFL )
*
* Factorize the matrices A and B in the arrays AF and BF.
*
CALL DGGSVD( 'U', 'V', 'Q', M, N, P, K, L, AF, LDA, BF, LDB,
$ ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, IWORK,
$ INFO )
*
* Copy R
*
DO 20 I = 1, MIN( K+L, M )
DO 10 J = I, K + L
R( I, J ) = AF( I, N-K-L+J )
10 CONTINUE
20 CONTINUE
*
IF( M-K-L.LT.0 ) THEN
DO 40 I = M + 1, K + L
DO 30 J = I, K + L
R( I, J ) = BF( I-K, N-K-L+J )
30 CONTINUE
40 CONTINUE
END IF
*
* Compute A:= U'*A*Q - D1*R
*
CALL DGEMM( 'No transpose', 'No transpose', M, N, N, ONE, A, LDA,
$ Q, LDQ, ZERO, WORK, LDA )
*
CALL DGEMM( 'Transpose', 'No transpose', M, N, M, ONE, U, LDU,
$ WORK, LDA, ZERO, A, LDA )
*
DO 60 I = 1, K
DO 50 J = I, K + L
A( I, N-K-L+J ) = A( I, N-K-L+J ) - R( I, J )
50 CONTINUE
60 CONTINUE
*
DO 80 I = K + 1, MIN( K+L, M )
DO 70 J = I, K + L
A( I, N-K-L+J ) = A( I, N-K-L+J ) - ALPHA( I )*R( I, J )
70 CONTINUE
80 CONTINUE
*
* Compute norm( U'*A*Q - D1*R ) / ( MAX(1,M,N)*norm(A)*ULP ) .
*
RESID = DLANGE( '1', M, N, A, LDA, RWORK )
*
IF( ANORM.GT.ZERO ) THEN
RESULT( 1 ) = ( ( RESID / DBLE( MAX( 1, M, N ) ) ) / ANORM ) /
$ ULP
ELSE
RESULT( 1 ) = ZERO
END IF
*
* Compute B := V'*B*Q - D2*R
*
CALL DGEMM( 'No transpose', 'No transpose', P, N, N, ONE, B, LDB,
$ Q, LDQ, ZERO, WORK, LDB )
*
CALL DGEMM( 'Transpose', 'No transpose', P, N, P, ONE, V, LDV,
$ WORK, LDB, ZERO, B, LDB )
*
DO 100 I = 1, L
DO 90 J = I, L
B( I, N-L+J ) = B( I, N-L+J ) - BETA( K+I )*R( K+I, K+J )
90 CONTINUE
100 CONTINUE
*
* Compute norm( V'*B*Q - D2*R ) / ( MAX(P,N)*norm(B)*ULP ) .
*
RESID = DLANGE( '1', P, N, B, LDB, RWORK )
IF( BNORM.GT.ZERO ) THEN
RESULT( 2 ) = ( ( RESID / DBLE( MAX( 1, P, N ) ) ) / BNORM ) /
$ ULP
ELSE
RESULT( 2 ) = ZERO
END IF
*
* Compute I - U'*U
*
CALL DLASET( 'Full', M, M, ZERO, ONE, WORK, LDQ )
CALL DSYRK( 'Upper', 'Transpose', M, M, -ONE, U, LDU, ONE, WORK,
$ LDU )
*
* Compute norm( I - U'*U ) / ( M * ULP ) .
*
RESID = DLANSY( '1', 'Upper', M, WORK, LDU, RWORK )
RESULT( 3 ) = ( RESID / DBLE( MAX( 1, M ) ) ) / ULP
*
* Compute I - V'*V
*
CALL DLASET( 'Full', P, P, ZERO, ONE, WORK, LDV )
CALL DSYRK( 'Upper', 'Transpose', P, P, -ONE, V, LDV, ONE, WORK,
$ LDV )
*
* Compute norm( I - V'*V ) / ( P * ULP ) .
*
RESID = DLANSY( '1', 'Upper', P, WORK, LDV, RWORK )
RESULT( 4 ) = ( RESID / DBLE( MAX( 1, P ) ) ) / ULP
*
* Compute I - Q'*Q
*
CALL DLASET( 'Full', N, N, ZERO, ONE, WORK, LDQ )
CALL DSYRK( 'Upper', 'Transpose', N, N, -ONE, Q, LDQ, ONE, WORK,
$ LDQ )
*
* Compute norm( I - Q'*Q ) / ( N * ULP ) .
*
RESID = DLANSY( '1', 'Upper', N, WORK, LDQ, RWORK )
RESULT( 5 ) = ( RESID / DBLE( MAX( 1, N ) ) ) / ULP
*
* Check sorting
*
CALL DCOPY( N, ALPHA, 1, WORK, 1 )
DO 110 I = K + 1, MIN( K+L, M )
J = IWORK( I )
IF( I.NE.J ) THEN
TEMP = WORK( I )
WORK( I ) = WORK( J )
WORK( J ) = TEMP
END IF
110 CONTINUE
*
RESULT( 6 ) = ZERO
DO 120 I = K + 1, MIN( K+L, M ) - 1
IF( WORK( I ).LT.WORK( I+1 ) )
$ RESULT( 6 ) = ULPINV
120 CONTINUE
*
RETURN
*
* End of DGSVTS
*
END
SUBROUTINE DHST01( N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK,
$ LWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IHI, ILO, LDA, LDH, LDQ, LWORK, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), H( LDH, * ), Q( LDQ, * ),
$ RESULT( 2 ), WORK( LWORK )
* ..
*
* Purpose
* =======
*
* DHST01 tests the reduction of a general matrix A to upper Hessenberg
* form: A = Q*H*Q'. Two test ratios are computed;
*
* RESULT(1) = norm( A - Q*H*Q' ) / ( norm(A) * N * EPS )
* RESULT(2) = norm( I - Q'*Q ) / ( N * EPS )
*
* The matrix Q is assumed to be given explicitly as it would be
* following DGEHRD + DORGHR.
*
* In this version, ILO and IHI are not used and are assumed to be 1 and
* N, respectively.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* A is assumed to be upper triangular in rows and columns
* 1:ILO-1 and IHI+1:N, so Q differs from the identity only in
* rows and columns ILO+1:IHI.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The original n by n matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* H (input) DOUBLE PRECISION array, dimension (LDH,N)
* The upper Hessenberg matrix H from the reduction A = Q*H*Q'
* as computed by DGEHRD. H is assumed to be zero below the
* first subdiagonal.
*
* LDH (input) INTEGER
* The leading dimension of the array H. LDH >= max(1,N).
*
* Q (input) DOUBLE PRECISION array, dimension (LDQ,N)
* The orthogonal matrix Q from the reduction A = Q*H*Q' as
* computed by DGEHRD + DORGHR.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of the array WORK. LWORK >= 2*N*N.
*
* RESULT (output) DOUBLE PRECISION array, dimension (2)
* RESULT(1) = norm( A - Q*H*Q' ) / ( norm(A) * N * EPS )
* RESULT(2) = norm( I - Q'*Q ) / ( N * EPS )
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER LDWORK
DOUBLE PRECISION ANORM, EPS, OVFL, SMLNUM, UNFL, WNORM
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL DLAMCH, DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLABAD, DLACPY, DORT01
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.0 ) THEN
RESULT( 1 ) = ZERO
RESULT( 2 ) = ZERO
RETURN
END IF
*
UNFL = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
OVFL = ONE / UNFL
CALL DLABAD( UNFL, OVFL )
SMLNUM = UNFL*N / EPS
*
* Test 1: Compute norm( A - Q*H*Q' ) / ( norm(A) * N * EPS )
*
* Copy A to WORK
*
LDWORK = MAX( 1, N )
CALL DLACPY( ' ', N, N, A, LDA, WORK, LDWORK )
*
* Compute Q*H
*
CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, Q, LDQ,
$ H, LDH, ZERO, WORK( LDWORK*N+1 ), LDWORK )
*
* Compute A - Q*H*Q'
*
CALL DGEMM( 'No transpose', 'Transpose', N, N, N, -ONE,
$ WORK( LDWORK*N+1 ), LDWORK, Q, LDQ, ONE, WORK,
$ LDWORK )
*
ANORM = MAX( DLANGE( '1', N, N, A, LDA, WORK( LDWORK*N+1 ) ),
$ UNFL )
WNORM = DLANGE( '1', N, N, WORK, LDWORK, WORK( LDWORK*N+1 ) )
*
* Note that RESULT(1) cannot overflow and is bounded by 1/(N*EPS)
*
RESULT( 1 ) = MIN( WNORM, ANORM ) / MAX( SMLNUM, ANORM*EPS ) / N
*
* Test 2: Compute norm( I - Q'*Q ) / ( N * EPS )
*
CALL DORT01( 'Columns', N, N, Q, LDQ, WORK, LWORK, RESULT( 2 ) )
*
RETURN
*
* End of DHST01
*
END
SUBROUTINE DLAFTS( TYPE, M, N, IMAT, NTESTS, RESULT, ISEED,
$ THRESH, IOUNIT, IE )
*
* -- LAPACK auxiliary test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 TYPE
INTEGER IE, IMAT, IOUNIT, M, N, NTESTS
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
DOUBLE PRECISION RESULT( * )
* ..
*
* Purpose
* =======
*
* DLAFTS tests the result vector against the threshold value to
* see which tests for this matrix type failed to pass the threshold.
* Output is to the file given by unit IOUNIT.
*
* Arguments
* =========
*
* TYPE - CHARACTER*3
* On entry, TYPE specifies the matrix type to be used in the
* printed messages.
* Not modified.
*
* N - INTEGER
* On entry, N specifies the order of the test matrix.
* Not modified.
*
* IMAT - INTEGER
* On entry, IMAT specifies the type of the test matrix.
* A listing of the different types is printed by DLAHD2
* to the output file if a test fails to pass the threshold.
* Not modified.
*
* NTESTS - INTEGER
* On entry, NTESTS is the number of tests performed on the
* subroutines in the path given by TYPE.
* Not modified.
*
* RESULT - DOUBLE PRECISION array of dimension( NTESTS )
* On entry, RESULT contains the test ratios from the tests
* performed in the calling program.
* Not modified.
*
* ISEED - INTEGER array of dimension( 4 )
* Contains the random seed that generated the matrix used
* for the tests whose ratios are in RESULT.
* Not modified.
*
* THRESH - DOUBLE PRECISION
* On entry, THRESH specifies the acceptable threshold of the
* test ratios. If RESULT( K ) > THRESH, then the K-th test
* did not pass the threshold and a message will be printed.
* Not modified.
*
* IOUNIT - INTEGER
* On entry, IOUNIT specifies the unit number of the file
* to which the messages are printed.
* Not modified.
*
* IE - INTEGER
* On entry, IE contains the number of tests which have
* failed to pass the threshold so far.
* Updated on exit if any of the ratios in RESULT also fail.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER K
* ..
* .. External Subroutines ..
EXTERNAL DLAHD2
* ..
* .. Executable Statements ..
*
IF( M.EQ.N ) THEN
*
* Output for square matrices:
*
DO 10 K = 1, NTESTS
IF( RESULT( K ).GE.THRESH ) THEN
*
* If this is the first test to fail, call DLAHD2
* to print a header to the data file.
*
IF( IE.EQ.0 )
$ CALL DLAHD2( IOUNIT, TYPE )
IE = IE + 1
*** WRITE( IOUNIT, 15 )' Matrix of order', N,
*** $ ', type ', IMAT,
*** $ ', test ', K,
*** $ ', ratio = ', RESULT( K )
*** 15 FORMAT( A16, I5, 2( A8, I2 ), A11, G13.6 )
IF( RESULT( K ).LT.10000.0D0 ) THEN
WRITE( IOUNIT, FMT = 9999 )N, IMAT, ISEED, K,
$ RESULT( K )
9999 FORMAT( ' Matrix order=', I5, ', type=', I2,
$ ', seed=', 4( I4, ',' ), ' result ', I3, ' is',
$ 0P, F8.2 )
ELSE
WRITE( IOUNIT, FMT = 9998 )N, IMAT, ISEED, K,
$ RESULT( K )
9998 FORMAT( ' Matrix order=', I5, ', type=', I2,
$ ', seed=', 4( I4, ',' ), ' result ', I3, ' is',
$ 1P, D10.3 )
END IF
END IF
10 CONTINUE
ELSE
*
* Output for rectangular matrices
*
DO 20 K = 1, NTESTS
IF( RESULT( K ).GE.THRESH ) THEN
*
* If this is the first test to fail, call DLAHD2
* to print a header to the data file.
*
IF( IE.EQ.0 )
$ CALL DLAHD2( IOUNIT, TYPE )
IE = IE + 1
*** WRITE( IOUNIT, FMT = 9997 )' Matrix of size', M, ' x',
*** $ N, ', type ', IMAT, ', test ', K, ', ratio = ',
*** $ RESULT( K )
*** 9997 FORMAT( A10, I5, A2, I5, A7, I2, A8, I2, A11, G13.6 )
IF( RESULT( K ).LT.10000.0D0 ) THEN
WRITE( IOUNIT, FMT = 9997 )M, N, IMAT, ISEED, K,
$ RESULT( K )
9997 FORMAT( 1X, I5, ' x', I5, ' matrix, type=', I2, ', s',
$ 'eed=', 3( I4, ',' ), I4, ': result ', I3,
$ ' is', 0P, F8.2 )
ELSE
WRITE( IOUNIT, FMT = 9996 )M, N, IMAT, ISEED, K,
$ RESULT( K )
9996 FORMAT( 1X, I5, ' x', I5, ' matrix, type=', I2, ', s',
$ 'eed=', 3( I4, ',' ), I4, ': result ', I3,
$ ' is', 1P, D10.3 )
END IF
END IF
20 CONTINUE
*
END IF
RETURN
*
* End of DLAFTS
*
END
SUBROUTINE DLAHD2( IOUNIT, PATH )
*
* -- LAPACK auxiliary test routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER IOUNIT
* ..
*
* Purpose
* =======
*
* DLAHD2 prints header information for the different test paths.
*
* Arguments
* =========
*
* IOUNIT (input) INTEGER.
* On entry, IOUNIT specifies the unit number to which the
* header information should be printed.
*
* PATH (input) CHARACTER*3.
* On entry, PATH contains the name of the path for which the
* header information is to be printed. Current paths are
*
* DHS, ZHS: Non-symmetric eigenproblem.
* DST, ZST: Symmetric eigenproblem.
* DSG, ZSG: Symmetric Generalized eigenproblem.
* DBD, ZBD: Singular Value Decomposition (SVD)
* DBB, ZBB: General Banded reduction to bidiagonal form
*
* These paths also are supplied in double precision (replace
* leading S by D and leading C by Z in path names).
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL CORZ, SORD
CHARACTER*2 C2
INTEGER J
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. Executable Statements ..
*
IF( IOUNIT.LE.0 )
$ RETURN
SORD = LSAME( PATH, 'S' ) .OR. LSAME( PATH, 'D' )
CORZ = LSAME( PATH, 'C' ) .OR. LSAME( PATH, 'Z' )
IF( .NOT.SORD .AND. .NOT.CORZ ) THEN
WRITE( IOUNIT, FMT = 9999 )PATH
END IF
C2 = PATH( 2: 3 )
*
IF( LSAMEN( 2, C2, 'HS' ) ) THEN
IF( SORD ) THEN
*
* Real Non-symmetric Eigenvalue Problem:
*
WRITE( IOUNIT, FMT = 9998 )PATH
*
* Matrix types
*
WRITE( IOUNIT, FMT = 9988 )
WRITE( IOUNIT, FMT = 9987 )
WRITE( IOUNIT, FMT = 9986 )'pairs ', 'pairs ', 'prs.',
$ 'prs.'
WRITE( IOUNIT, FMT = 9985 )
*
* Tests performed
*
WRITE( IOUNIT, FMT = 9984 )'orthogonal', '''=transpose',
$ ( '''', J = 1, 6 )
*
ELSE
*
* Complex Non-symmetric Eigenvalue Problem:
*
WRITE( IOUNIT, FMT = 9997 )PATH
*
* Matrix types
*
WRITE( IOUNIT, FMT = 9988 )
WRITE( IOUNIT, FMT = 9987 )
WRITE( IOUNIT, FMT = 9986 )'e.vals', 'e.vals', 'e.vs',
$ 'e.vs'
WRITE( IOUNIT, FMT = 9985 )
*
* Tests performed
*
WRITE( IOUNIT, FMT = 9984 )'unitary', '*=conj.transp.',
$ ( '*', J = 1, 6 )
END IF
*
ELSE IF( LSAMEN( 2, C2, 'ST' ) ) THEN
*
IF( SORD ) THEN
*
* Real Symmetric Eigenvalue Problem:
*
WRITE( IOUNIT, FMT = 9996 )PATH
*
* Matrix types
*
WRITE( IOUNIT, FMT = 9983 )
WRITE( IOUNIT, FMT = 9982 )
WRITE( IOUNIT, FMT = 9981 )'Symmetric'
*
* Tests performed
*
WRITE( IOUNIT, FMT = 9968 )
*
ELSE
*
* Complex Hermitian Eigenvalue Problem:
*
WRITE( IOUNIT, FMT = 9995 )PATH
*
* Matrix types
*
WRITE( IOUNIT, FMT = 9983 )
WRITE( IOUNIT, FMT = 9982 )
WRITE( IOUNIT, FMT = 9981 )'Hermitian'
*
* Tests performed
*
WRITE( IOUNIT, FMT = 9967 )
END IF
*
ELSE IF( LSAMEN( 2, C2, 'SG' ) ) THEN
*
IF( SORD ) THEN
*
* Real Symmetric Generalized Eigenvalue Problem:
*
WRITE( IOUNIT, FMT = 9992 )PATH
*
* Matrix types
*
WRITE( IOUNIT, FMT = 9980 )
WRITE( IOUNIT, FMT = 9979 )
WRITE( IOUNIT, FMT = 9978 )'Symmetric'
*
* Tests performed
*
WRITE( IOUNIT, FMT = 9977 )
WRITE( IOUNIT, FMT = 9976 )
*
ELSE
*
* Complex Hermitian Generalized Eigenvalue Problem:
*
WRITE( IOUNIT, FMT = 9991 )PATH
*
* Matrix types
*
WRITE( IOUNIT, FMT = 9980 )
WRITE( IOUNIT, FMT = 9979 )
WRITE( IOUNIT, FMT = 9978 )'Hermitian'
*
* Tests performed
*
WRITE( IOUNIT, FMT = 9975 )
WRITE( IOUNIT, FMT = 9974 )
*
END IF
*
ELSE IF( LSAMEN( 2, C2, 'BD' ) ) THEN
*
IF( SORD ) THEN
*
* Real Singular Value Decomposition:
*
WRITE( IOUNIT, FMT = 9994 )PATH
*
* Matrix types
*
WRITE( IOUNIT, FMT = 9973 )
*
* Tests performed
*
WRITE( IOUNIT, FMT = 9972 )'orthogonal'
WRITE( IOUNIT, FMT = 9971 )
ELSE
*
* Complex Singular Value Decomposition:
*
WRITE( IOUNIT, FMT = 9993 )PATH
*
* Matrix types
*
WRITE( IOUNIT, FMT = 9973 )
*
* Tests performed
*
WRITE( IOUNIT, FMT = 9972 )'unitary '
WRITE( IOUNIT, FMT = 9971 )
END IF
*
ELSE IF( LSAMEN( 2, C2, 'BB' ) ) THEN
*
IF( SORD ) THEN
*
* Real General Band reduction to bidiagonal form:
*
WRITE( IOUNIT, FMT = 9990 )PATH
*
* Matrix types
*
WRITE( IOUNIT, FMT = 9970 )
*
* Tests performed
*
WRITE( IOUNIT, FMT = 9969 )'orthogonal'
ELSE
*
* Complex Band reduction to bidiagonal form:
*
WRITE( IOUNIT, FMT = 9989 )PATH
*
* Matrix types
*
WRITE( IOUNIT, FMT = 9970 )
*
* Tests performed
*
WRITE( IOUNIT, FMT = 9969 )'unitary '
END IF
*
ELSE
*
WRITE( IOUNIT, FMT = 9999 )PATH
RETURN
END IF
*
RETURN
*
9999 FORMAT( 1X, A3, ': no header available' )
9998 FORMAT( / 1X, A3, ' -- Real Non-symmetric eigenvalue problem' )
9997 FORMAT( / 1X, A3, ' -- Complex Non-symmetric eigenvalue problem' )
9996 FORMAT( / 1X, A3, ' -- Real Symmetric eigenvalue problem' )
9995 FORMAT( / 1X, A3, ' -- Complex Hermitian eigenvalue problem' )
9994 FORMAT( / 1X, A3, ' -- Real Singular Value Decomposition' )
9993 FORMAT( / 1X, A3, ' -- Complex Singular Value Decomposition' )
9992 FORMAT( / 1X, A3, ' -- Real Symmetric Generalized eigenvalue ',
$ 'problem' )
9991 FORMAT( / 1X, A3, ' -- Complex Hermitian Generalized eigenvalue ',
$ 'problem' )
9990 FORMAT( / 1X, A3, ' -- Real Band reduc. to bidiagonal form' )
9989 FORMAT( / 1X, A3, ' -- Complex Band reduc. to bidiagonal form' )
*
9988 FORMAT( ' Matrix types (see xCHKHS for details): ' )
*
9987 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ',
$ ' ', ' 5=Diagonal: geometr. spaced entries.',
$ / ' 2=Identity matrix. ', ' 6=Diagona',
$ 'l: clustered entries.', / ' 3=Transposed Jordan block. ',
$ ' ', ' 7=Diagonal: large, evenly spaced.', / ' ',
$ '4=Diagonal: evenly spaced entries. ', ' 8=Diagonal: s',
$ 'mall, evenly spaced.' )
9986 FORMAT( ' Dense, Non-Symmetric Matrices:', / ' 9=Well-cond., ev',
$ 'enly spaced eigenvals.', ' 14=Ill-cond., geomet. spaced e',
$ 'igenals.', / ' 10=Well-cond., geom. spaced eigenvals. ',
$ ' 15=Ill-conditioned, clustered e.vals.', / ' 11=Well-cond',
$ 'itioned, clustered e.vals. ', ' 16=Ill-cond., random comp',
$ 'lex ', A6, / ' 12=Well-cond., random complex ', A6, ' ',
$ ' 17=Ill-cond., large rand. complx ', A4, / ' 13=Ill-condi',
$ 'tioned, evenly spaced. ', ' 18=Ill-cond., small rand.',
$ ' complx ', A4 )
9985 FORMAT( ' 19=Matrix with random O(1) entries. ', ' 21=Matrix ',
$ 'with small random entries.', / ' 20=Matrix with large ran',
$ 'dom entries. ' )
9984 FORMAT( / ' Tests performed: ', '(H is Hessenberg, T is Schur,',
$ ' U and Z are ', A, ',', / 20X, A, ', W is a diagonal matr',
$ 'ix of eigenvalues,', / 20X, 'L and R are the left and rig',
$ 'ht eigenvector matrices)', / ' 1 = | A - U H U', A1, ' |',
$ ' / ( |A| n ulp ) ', ' 2 = | I - U U', A1, ' | / ',
$ '( n ulp )', / ' 3 = | H - Z T Z', A1, ' | / ( |H| n ulp ',
$ ') ', ' 4 = | I - Z Z', A1, ' | / ( n ulp )',
$ / ' 5 = | A - UZ T (UZ)', A1, ' | / ( |A| n ulp ) ',
$ ' 6 = | I - UZ (UZ)', A1, ' | / ( n ulp )', / ' 7 = | T(',
$ 'e.vects.) - T(no e.vects.) | / ( |T| ulp )', / ' 8 = | W',
$ '(e.vects.) - W(no e.vects.) | / ( |W| ulp )', / ' 9 = | ',
$ 'TR - RW | / ( |T| |R| ulp ) ', ' 10 = | LT - WL | / (',
$ ' |T| |L| ulp )', / ' 11= |HX - XW| / (|H| |X| ulp) (inv.',
$ 'it)', ' 12= |YH - WY| / (|H| |Y| ulp) (inv.it)' )
*
* Symmetric/Hermitian eigenproblem
*
9983 FORMAT( ' Matrix types (see xDRVST for details): ' )
*
9982 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ',
$ ' ', ' 5=Diagonal: clustered entries.', / ' 2=',
$ 'Identity matrix. ', ' 6=Diagonal: lar',
$ 'ge, evenly spaced.', / ' 3=Diagonal: evenly spaced entri',
$ 'es. ', ' 7=Diagonal: small, evenly spaced.', / ' 4=D',
$ 'iagonal: geometr. spaced entries.' )
9981 FORMAT( ' Dense ', A, ' Matrices:', / ' 8=Evenly spaced eigen',
$ 'vals. ', ' 12=Small, evenly spaced eigenvals.',
$ / ' 9=Geometrically spaced eigenvals. ', ' 13=Matrix ',
$ 'with random O(1) entries.', / ' 10=Clustered eigenvalues.',
$ ' ', ' 14=Matrix with large random entries.',
$ / ' 11=Large, evenly spaced eigenvals. ', ' 15=Matrix ',
$ 'with small random entries.' )
*
* Symmetric/Hermitian Generalized eigenproblem
*
9980 FORMAT( ' Matrix types (see xDRVSG for details): ' )
*
9979 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ',
$ ' ', ' 5=Diagonal: clustered entries.', / ' 2=',
$ 'Identity matrix. ', ' 6=Diagonal: lar',
$ 'ge, evenly spaced.', / ' 3=Diagonal: evenly spaced entri',
$ 'es. ', ' 7=Diagonal: small, evenly spaced.', / ' 4=D',
$ 'iagonal: geometr. spaced entries.' )
9978 FORMAT( ' Dense or Banded ', A, ' Matrices: ',
$ / ' 8=Evenly spaced eigenvals. ',
$ ' 15=Matrix with small random entries.',
$ / ' 9=Geometrically spaced eigenvals. ',
$ ' 16=Evenly spaced eigenvals, KA=1, KB=1.',
$ / ' 10=Clustered eigenvalues. ',
$ ' 17=Evenly spaced eigenvals, KA=2, KB=1.',
$ / ' 11=Large, evenly spaced eigenvals. ',
$ ' 18=Evenly spaced eigenvals, KA=2, KB=2.',
$ / ' 12=Small, evenly spaced eigenvals. ',
$ ' 19=Evenly spaced eigenvals, KA=3, KB=1.',
$ / ' 13=Matrix with random O(1) entries. ',
$ ' 20=Evenly spaced eigenvals, KA=3, KB=2.',
$ / ' 14=Matrix with large random entries.',
$ ' 21=Evenly spaced eigenvals, KA=3, KB=3.' )
9977 FORMAT( / ' Tests performed: ',
$ / '( For each pair (A,B), where A is of the given type ',
$ / ' and B is a random well-conditioned matrix. D is ',
$ / ' diagonal, and Z is orthogonal. )',
$ / ' 1 = DSYGV, with ITYPE=1 and UPLO=''U'':',
$ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
$ / ' 2 = DSPGV, with ITYPE=1 and UPLO=''U'':',
$ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
$ / ' 3 = DSBGV, with ITYPE=1 and UPLO=''U'':',
$ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
$ / ' 4 = DSYGV, with ITYPE=1 and UPLO=''L'':',
$ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
$ / ' 5 = DSPGV, with ITYPE=1 and UPLO=''L'':',
$ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
$ / ' 6 = DSBGV, with ITYPE=1 and UPLO=''L'':',
$ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ' )
9976 FORMAT( ' 7 = DSYGV, with ITYPE=2 and UPLO=''U'':',
$ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
$ / ' 8 = DSPGV, with ITYPE=2 and UPLO=''U'':',
$ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
$ / ' 9 = DSPGV, with ITYPE=2 and UPLO=''L'':',
$ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
$ / '10 = DSPGV, with ITYPE=2 and UPLO=''L'':',
$ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
$ / '11 = DSYGV, with ITYPE=3 and UPLO=''U'':',
$ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ',
$ / '12 = DSPGV, with ITYPE=3 and UPLO=''U'':',
$ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ',
$ / '13 = DSYGV, with ITYPE=3 and UPLO=''L'':',
$ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ',
$ / '14 = DSPGV, with ITYPE=3 and UPLO=''L'':',
$ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ' )
9975 FORMAT( / ' Tests performed: ',
$ / '( For each pair (A,B), where A is of the given type ',
$ / ' and B is a random well-conditioned matrix. D is ',
$ / ' diagonal, and Z is unitary. )',
$ / ' 1 = ZHEGV, with ITYPE=1 and UPLO=''U'':',
$ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
$ / ' 2 = ZHPGV, with ITYPE=1 and UPLO=''U'':',
$ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
$ / ' 3 = ZHBGV, with ITYPE=1 and UPLO=''U'':',
$ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
$ / ' 4 = ZHEGV, with ITYPE=1 and UPLO=''L'':',
$ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
$ / ' 5 = ZHPGV, with ITYPE=1 and UPLO=''L'':',
$ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
$ / ' 6 = ZHBGV, with ITYPE=1 and UPLO=''L'':',
$ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ' )
9974 FORMAT( ' 7 = ZHEGV, with ITYPE=2 and UPLO=''U'':',
$ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
$ / ' 8 = ZHPGV, with ITYPE=2 and UPLO=''U'':',
$ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
$ / ' 9 = ZHPGV, with ITYPE=2 and UPLO=''L'':',
$ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
$ / '10 = ZHPGV, with ITYPE=2 and UPLO=''L'':',
$ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
$ / '11 = ZHEGV, with ITYPE=3 and UPLO=''U'':',
$ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ',
$ / '12 = ZHPGV, with ITYPE=3 and UPLO=''U'':',
$ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ',
$ / '13 = ZHEGV, with ITYPE=3 and UPLO=''L'':',
$ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ',
$ / '14 = ZHPGV, with ITYPE=3 and UPLO=''L'':',
$ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ' )
*
* Singular Value Decomposition
*
9973 FORMAT( ' Matrix types (see xCHKBD for details):',
$ / ' Diagonal matrices:', / ' 1: Zero', 28X,
$ ' 5: Clustered entries', / ' 2: Identity', 24X,
$ ' 6: Large, evenly spaced entries',
$ / ' 3: Evenly spaced entries', 11X,
$ ' 7: Small, evenly spaced entries',
$ / ' 4: Geometrically spaced entries',
$ / ' General matrices:', / ' 8: Evenly spaced sing. vals.',
$ 7X, '12: Small, evenly spaced sing vals',
$ / ' 9: Geometrically spaced sing vals ',
$ '13: Random, O(1) entries', / ' 10: Clustered sing. vals.',
$ 11X, '14: Random, scaled near overflow',
$ / ' 11: Large, evenly spaced sing vals ',
$ '15: Random, scaled near underflow' )
*
9972 FORMAT( / ' Test ratios: ',
$ '(B: bidiagonal, S: diagonal, Q, P, U, and V: ', A10, / 16X,
$ 'X: m x nrhs, Y = Q'' X, and Z = U'' Y)',
$ / ' 1: norm( A - Q B P'' ) / ( norm(A) max(m,n) ulp )',
$ / ' 2: norm( I - Q'' Q ) / ( m ulp )',
$ / ' 3: norm( I - P'' P ) / ( n ulp )',
$ / ' 4: norm( B - U S V'' ) / ( norm(B) min(m,n) ulp )', /
$ ' 5: norm( Y - U Z ) / ( norm(Z) max(min(m,n),k) ulp )'
$ , / ' 6: norm( I - U'' U ) / ( min(m,n) ulp )',
$ / ' 7: norm( I - V'' V ) / ( min(m,n) ulp )' )
9971 FORMAT( ' 8: Test ordering of S (0 if nondecreasing, 1/ulp ',
$ ' otherwise)', /
$ ' 9: norm( S - S2 ) / ( norm(S) ulp ),',
$ ' where S2 is computed', / 44X,
$ 'without computing U and V''',
$ / ' 10: Sturm sequence test ',
$ '(0 if sing. vals of B within THRESH of S)',
$ / ' 11: norm( A - (QU) S (V'' P'') ) / ',
$ '( norm(A) max(m,n) ulp )', /
$ ' 12: norm( X - (QU) Z ) / ( |X| max(M,k) ulp )',
$ / ' 13: norm( I - (QU)''(QU) ) / ( M ulp )',
$ / ' 14: norm( I - (V'' P'') (P V) ) / ( N ulp )' )
*
* Band reduction to bidiagonal form
*
9970 FORMAT( ' Matrix types (see xCHKBB for details):',
$ / ' Diagonal matrices:', / ' 1: Zero', 28X,
$ ' 5: Clustered entries', / ' 2: Identity', 24X,
$ ' 6: Large, evenly spaced entries',
$ / ' 3: Evenly spaced entries', 11X,
$ ' 7: Small, evenly spaced entries',
$ / ' 4: Geometrically spaced entries',
$ / ' General matrices:', / ' 8: Evenly spaced sing. vals.',
$ 7X, '12: Small, evenly spaced sing vals',
$ / ' 9: Geometrically spaced sing vals ',
$ '13: Random, O(1) entries', / ' 10: Clustered sing. vals.',
$ 11X, '14: Random, scaled near overflow',
$ / ' 11: Large, evenly spaced sing vals ',
$ '15: Random, scaled near underflow' )
*
9969 FORMAT( / ' Test ratios: ', '(B: upper bidiagonal, Q and P: ',
$ A10, / 16X, 'C: m x nrhs, PT = P'', Y = Q'' C)',
$ / ' 1: norm( A - Q B PT ) / ( norm(A) max(m,n) ulp )',
$ / ' 2: norm( I - Q'' Q ) / ( m ulp )',
$ / ' 3: norm( I - PT PT'' ) / ( n ulp )',
$ / ' 4: norm( Y - Q'' C ) / ( norm(Y) max(m,nrhs) ulp )' )
9968 FORMAT( / ' Tests performed: See sdrvst.f' )
9967 FORMAT( / ' Tests performed: See cdrvst.f' )
*
* End of DLAHD2
*
END
SUBROUTINE DLARFY( UPLO, N, V, INCV, TAU, C, LDC, WORK )
*
* -- LAPACK auxiliary test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INCV, LDC, N
DOUBLE PRECISION TAU
* ..
* .. Array Arguments ..
DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLARFY applies an elementary reflector, or Householder matrix, H,
* to an n x n symmetric matrix C, from both the left and the right.
*
* H is represented in the form
*
* H = I - tau * v * v'
*
* where tau is a scalar and v is a vector.
*
* If tau is zero, then H is taken to be the unit matrix.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrix C is stored.
* = 'U': Upper triangle
* = 'L': Lower triangle
*
* N (input) INTEGER
* The number of rows and columns of the matrix C. N >= 0.
*
* V (input) DOUBLE PRECISION array, dimension
* (1 + (N-1)*abs(INCV))
* The vector v as described above.
*
* INCV (input) INTEGER
* The increment between successive elements of v. INCV must
* not be zero.
*
* TAU (input) DOUBLE PRECISION
* The value tau as described above.
*
* C (input/output) DOUBLE PRECISION array, dimension (LDC, N)
* On entry, the matrix C.
* On exit, C is overwritten by H * C * H'.
*
* LDC (input) INTEGER
* The leading dimension of the array C. LDC >= max( 1, N ).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO, HALF
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0, HALF = 0.5D+0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION ALPHA
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DSYMV, DSYR2
* ..
* .. External Functions ..
DOUBLE PRECISION DDOT
EXTERNAL DDOT
* ..
* .. Executable Statements ..
*
IF( TAU.EQ.ZERO )
$ RETURN
*
* Form w:= C * v
*
CALL DSYMV( UPLO, N, ONE, C, LDC, V, INCV, ZERO, WORK, 1 )
*
ALPHA = -HALF*TAU*DDOT( N, WORK, 1, V, INCV )
CALL DAXPY( N, ALPHA, V, INCV, WORK, 1 )
*
* C := C - v * w' - w * v'
*
CALL DSYR2( UPLO, N, -TAU, V, INCV, WORK, 1, C, LDC )
*
RETURN
*
* End of DLARFY
*
END
SUBROUTINE DLARHS( PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS,
$ A, LDA, X, LDX, B, LDB, ISEED, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TRANS, UPLO, XTYPE
CHARACTER*3 PATH
INTEGER INFO, KL, KU, LDA, LDB, LDX, M, N, NRHS
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), X( LDX, * )
* ..
*
* Purpose
* =======
*
* DLARHS chooses a set of NRHS random solution vectors and sets
* up the right hand sides for the linear system
* op( A ) * X = B,
* where op( A ) may be A or A' (transpose of A).
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The type of the real matrix A. PATH may be given in any
* combination of upper and lower case. Valid types include
* xGE: General m x n matrix
* xGB: General banded matrix
* xPO: Symmetric positive definite, 2-D storage
* xPP: Symmetric positive definite packed
* xPB: Symmetric positive definite banded
* xSY: Symmetric indefinite, 2-D storage
* xSP: Symmetric indefinite packed
* xSB: Symmetric indefinite banded
* xTR: Triangular
* xTP: Triangular packed
* xTB: Triangular banded
* xQR: General m x n matrix
* xLQ: General m x n matrix
* xQL: General m x n matrix
* xRQ: General m x n matrix
* where the leading character indicates the precision.
*
* XTYPE (input) CHARACTER*1
* Specifies how the exact solution X will be determined:
* = 'N': New solution; generate a random X.
* = 'C': Computed; use value of X on entry.
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* matrix A is stored, if A is symmetric.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* TRANS (input) CHARACTER*1
* Specifies the operation applied to the matrix A.
* = 'N': System is A * x = b
* = 'T': System is A'* x = b
* = 'C': System is A'* x = b
*
* M (input) INTEGER
* The number or rows of the matrix A. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix A. N >= 0.
*
* KL (input) INTEGER
* Used only if A is a band matrix; specifies the number of
* subdiagonals of A if A is a general band matrix or if A is
* symmetric or triangular and UPLO = 'L'; specifies the number
* of superdiagonals of A if A is symmetric or triangular and
* UPLO = 'U'. 0 <= KL <= M-1.
*
* KU (input) INTEGER
* Used only if A is a general band matrix or if A is
* triangular.
*
* If PATH = xGB, specifies the number of superdiagonals of A,
* and 0 <= KU <= N-1.
*
* If PATH = xTR, xTP, or xTB, specifies whether or not the
* matrix has unit diagonal:
* = 1: matrix has non-unit diagonal (default)
* = 2: matrix has unit diagonal
*
* NRHS (input) INTEGER
* The number of right hand side vectors in the system A*X = B.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The test matrix whose type is given by PATH.
*
* LDA (input) INTEGER
* The leading dimension of the array A.
* If PATH = xGB, LDA >= KL+KU+1.
* If PATH = xPB, xSB, xHB, or xTB, LDA >= KL+1.
* Otherwise, LDA >= max(1,M).
*
* X (input or output) DOUBLE PRECISION array, dimension(LDX,NRHS)
* On entry, if XTYPE = 'C' (for 'Computed'), then X contains
* the exact solution to the system of linear equations.
* On exit, if XTYPE = 'N' (for 'New'), then X is initialized
* with random values.
*
* LDX (input) INTEGER
* The leading dimension of the array X. If TRANS = 'N',
* LDX >= max(1,N); if TRANS = 'T', LDX >= max(1,M).
*
* B (output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* The right hand side vector(s) for the system of equations,
* computed from B = op(A) * X, where op(A) is determined by
* TRANS.
*
* LDB (input) INTEGER
* The leading dimension of the array B. If TRANS = 'N',
* LDB >= max(1,M); if TRANS = 'T', LDB >= max(1,N).
*
* ISEED (input/output) INTEGER array, dimension (4)
* The seed vector for the random number generator (used in
* DLATMS). Modified on exit.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL BAND, GEN, NOTRAN, QRS, SYM, TRAN, TRI
CHARACTER C1, DIAG
CHARACTER*2 C2
INTEGER J, MB, NX
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL LSAME, LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL DGBMV, DGEMM, DLACPY, DLARNV, DSBMV, DSPMV,
$ DSYMM, DTBMV, DTPMV, DTRMM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
C1 = PATH( 1: 1 )
C2 = PATH( 2: 3 )
TRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
NOTRAN = .NOT.TRAN
GEN = LSAME( PATH( 2: 2 ), 'G' )
QRS = LSAME( PATH( 2: 2 ), 'Q' ) .OR. LSAME( PATH( 3: 3 ), 'Q' )
SYM = LSAME( PATH( 2: 2 ), 'P' ) .OR. LSAME( PATH( 2: 2 ), 'S' )
TRI = LSAME( PATH( 2: 2 ), 'T' )
BAND = LSAME( PATH( 3: 3 ), 'B' )
IF( .NOT.LSAME( C1, 'Double precision' ) ) THEN
INFO = -1
ELSE IF( .NOT.( LSAME( XTYPE, 'N' ) .OR. LSAME( XTYPE, 'C' ) ) )
$ THEN
INFO = -2
ELSE IF( ( SYM .OR. TRI ) .AND. .NOT.
$ ( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) THEN
INFO = -3
ELSE IF( ( GEN .OR. QRS ) .AND. .NOT.
$ ( TRAN .OR. LSAME( TRANS, 'N' ) ) ) THEN
INFO = -4
ELSE IF( M.LT.0 ) THEN
INFO = -5
ELSE IF( N.LT.0 ) THEN
INFO = -6
ELSE IF( BAND .AND. KL.LT.0 ) THEN
INFO = -7
ELSE IF( BAND .AND. KU.LT.0 ) THEN
INFO = -8
ELSE IF( NRHS.LT.0 ) THEN
INFO = -9
ELSE IF( ( .NOT.BAND .AND. LDA.LT.MAX( 1, M ) ) .OR.
$ ( BAND .AND. ( SYM .OR. TRI ) .AND. LDA.LT.KL+1 ) .OR.
$ ( BAND .AND. GEN .AND. LDA.LT.KL+KU+1 ) ) THEN
INFO = -11
ELSE IF( ( NOTRAN .AND. LDX.LT.MAX( 1, N ) ) .OR.
$ ( TRAN .AND. LDX.LT.MAX( 1, M ) ) ) THEN
INFO = -13
ELSE IF( ( NOTRAN .AND. LDB.LT.MAX( 1, M ) ) .OR.
$ ( TRAN .AND. LDB.LT.MAX( 1, N ) ) ) THEN
INFO = -15
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLARHS', -INFO )
RETURN
END IF
*
* Initialize X to NRHS random vectors unless XTYPE = 'C'.
*
IF( TRAN ) THEN
NX = M
MB = N
ELSE
NX = N
MB = M
END IF
IF( .NOT.LSAME( XTYPE, 'C' ) ) THEN
DO 10 J = 1, NRHS
CALL DLARNV( 2, ISEED, N, X( 1, J ) )
10 CONTINUE
END IF
*
* Multiply X by op( A ) using an appropriate
* matrix multiply routine.
*
IF( LSAMEN( 2, C2, 'GE' ) .OR. LSAMEN( 2, C2, 'QR' ) .OR.
$ LSAMEN( 2, C2, 'LQ' ) .OR. LSAMEN( 2, C2, 'QL' ) .OR.
$ LSAMEN( 2, C2, 'RQ' ) ) THEN
*
* General matrix
*
CALL DGEMM( TRANS, 'N', MB, NRHS, NX, ONE, A, LDA, X, LDX,
$ ZERO, B, LDB )
*
ELSE IF( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'SY' ) ) THEN
*
* Symmetric matrix, 2-D storage
*
CALL DSYMM( 'Left', UPLO, N, NRHS, ONE, A, LDA, X, LDX, ZERO,
$ B, LDB )
*
ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
*
* General matrix, band storage
*
DO 20 J = 1, NRHS
CALL DGBMV( TRANS, MB, NX, KL, KU, ONE, A, LDA, X( 1, J ),
$ 1, ZERO, B( 1, J ), 1 )
20 CONTINUE
*
ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN
*
* Symmetric matrix, band storage
*
DO 30 J = 1, NRHS
CALL DSBMV( UPLO, N, KL, ONE, A, LDA, X( 1, J ), 1, ZERO,
$ B( 1, J ), 1 )
30 CONTINUE
*
ELSE IF( LSAMEN( 2, C2, 'PP' ) .OR. LSAMEN( 2, C2, 'SP' ) ) THEN
*
* Symmetric matrix, packed storage
*
DO 40 J = 1, NRHS
CALL DSPMV( UPLO, N, ONE, A, X( 1, J ), 1, ZERO, B( 1, J ),
$ 1 )
40 CONTINUE
*
ELSE IF( LSAMEN( 2, C2, 'TR' ) ) THEN
*
* Triangular matrix. Note that for triangular matrices,
* KU = 1 => non-unit triangular
* KU = 2 => unit triangular
*
CALL DLACPY( 'Full', N, NRHS, X, LDX, B, LDB )
IF( KU.EQ.2 ) THEN
DIAG = 'U'
ELSE
DIAG = 'N'
END IF
CALL DTRMM( 'Left', UPLO, TRANS, DIAG, N, NRHS, ONE, A, LDA, B,
$ LDB )
*
ELSE IF( LSAMEN( 2, C2, 'TP' ) ) THEN
*
* Triangular matrix, packed storage
*
CALL DLACPY( 'Full', N, NRHS, X, LDX, B, LDB )
IF( KU.EQ.2 ) THEN
DIAG = 'U'
ELSE
DIAG = 'N'
END IF
DO 50 J = 1, NRHS
CALL DTPMV( UPLO, TRANS, DIAG, N, A, B( 1, J ), 1 )
50 CONTINUE
*
ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
*
* Triangular matrix, banded storage
*
CALL DLACPY( 'Full', N, NRHS, X, LDX, B, LDB )
IF( KU.EQ.2 ) THEN
DIAG = 'U'
ELSE
DIAG = 'N'
END IF
DO 60 J = 1, NRHS
CALL DTBMV( UPLO, TRANS, DIAG, N, KL, A, LDA, B( 1, J ), 1 )
60 CONTINUE
*
ELSE
*
* If PATH is none of the above, return with an error code.
*
INFO = -1
CALL XERBLA( 'DLARHS', -INFO )
END IF
*
RETURN
*
* End of DLARHS
*
END
SUBROUTINE DLASUM( TYPE, IOUNIT, IE, NRUN )
*
* -- LAPACK auxiliary test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 TYPE
INTEGER IE, IOUNIT, NRUN
* ..
*
* Purpose
* =======
*
* DLASUM prints a summary of the results from one of the test routines.
*
* =====================================================================
*
* .. Executable Statements ..
*
IF( IE.GT.0 ) THEN
WRITE( IOUNIT, FMT = 9999 )TYPE, ': ', IE, ' out of ', NRUN,
$ ' tests failed to pass the threshold'
ELSE
WRITE( IOUNIT, FMT = 9998 )'All tests for ', TYPE,
$ ' passed the threshold (', NRUN, ' tests run)'
END IF
9999 FORMAT( 1X, A3, A2, I4, A8, I5, A35 )
9998 FORMAT( / 1X, A14, A3, A23, I5, A11 )
RETURN
*
* End of DLASUM
*
END
SUBROUTINE DLATB9( PATH, IMAT, M, P, N, TYPE, KLA, KUA, KLB, KUB,
$ ANORM, BNORM, MODEA, MODEB, CNDNMA, CNDNMB,
$ DISTA, DISTB )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DISTA, DISTB, TYPE
CHARACTER*3 PATH
INTEGER IMAT, KLA, KLB, KUA, KUB, M, MODEA, MODEB, N, P
DOUBLE PRECISION ANORM, BNORM, CNDNMA, CNDNMB
* ..
*
* Purpose
* =======
*
* DLATB9 sets parameters for the matrix generator based on the type of
* matrix to be generated.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name.
*
* IMAT (input) INTEGER
* An integer key describing which matrix to generate for this
* path.
*
* M (input) INTEGER
* The number of rows in the matrix to be generated.
*
* N (input) INTEGER
* The number of columns in the matrix to be generated.
*
* TYPE (output) CHARACTER*1
* The type of the matrix to be generated:
* = 'S': symmetric matrix;
* = 'P': symmetric positive (semi)definite matrix;
* = 'N': nonsymmetric matrix.
*
* KL (output) INTEGER
* The lower band width of the matrix to be generated.
*
* KU (output) INTEGER
* The upper band width of the matrix to be generated.
*
* ANORM (output) DOUBLE PRECISION
* The desired norm of the matrix to be generated. The diagonal
* matrix of singular values or eigenvalues is scaled by this
* value.
*
* MODE (output) INTEGER
* A key indicating how to choose the vector of eigenvalues.
*
* CNDNUM (output) DOUBLE PRECISION
* The desired condition number.
*
* DIST (output) CHARACTER*1
* The type of distribution to be used by the random number
* generator.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION SHRINK, TENTH
PARAMETER ( SHRINK = 0.25D0, TENTH = 0.1D+0 )
DOUBLE PRECISION ONE, TEN
PARAMETER ( ONE = 1.0D+0, TEN = 1.0D+1 )
* ..
* .. Local Scalars ..
LOGICAL FIRST
DOUBLE PRECISION BADC1, BADC2, EPS, LARGE, SMALL
* ..
* .. External Functions ..
LOGICAL LSAMEN
DOUBLE PRECISION DLAMCH
EXTERNAL LSAMEN, DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. External Subroutines ..
EXTERNAL DLABAD
* ..
* .. Save statement ..
SAVE EPS, SMALL, LARGE, BADC1, BADC2, FIRST
* ..
* .. Data statements ..
DATA FIRST / .TRUE. /
* ..
* .. Executable Statements ..
*
* Set some constants for use in the subroutine.
*
IF( FIRST ) THEN
FIRST = .FALSE.
EPS = DLAMCH( 'Precision' )
BADC2 = TENTH / EPS
BADC1 = SQRT( BADC2 )
SMALL = DLAMCH( 'Safe minimum' )
LARGE = ONE / SMALL
*
* If it looks like we're on a Cray, take the square root of
* SMALL and LARGE to avoid overflow and underflow problems.
*
CALL DLABAD( SMALL, LARGE )
SMALL = SHRINK*( SMALL / EPS )
LARGE = ONE / SMALL
END IF
*
* Set some parameters we don't plan to change.
*
TYPE = 'N'
DISTA = 'S'
DISTB = 'S'
MODEA = 3
MODEB = 4
*
* Set the lower and upper bandwidths.
*
IF( LSAMEN( 3, PATH, 'GRQ' ) .OR. LSAMEN( 3, PATH, 'LSE' ) .OR.
$ LSAMEN( 3, PATH, 'GSV' ) ) THEN
*
* A: M by N, B: P by N
*
IF( IMAT.EQ.1 ) THEN
*
* A: diagonal, B: upper triangular
*
KLA = 0
KUA = 0
KLB = 0
KUB = MAX( N-1, 0 )
*
ELSE IF( IMAT.EQ.2 ) THEN
*
* A: upper triangular, B: upper triangular
*
KLA = 0
KUA = MAX( N-1, 0 )
KLB = 0
KUB = MAX( N-1, 0 )
*
ELSE IF( IMAT.EQ.3 ) THEN
*
* A: lower triangular, B: upper triangular
*
KLA = MAX( M-1, 0 )
KUA = 0
KLB = 0
KUB = MAX( N-1, 0 )
*
ELSE
*
* A: general dense, B: general dense
*
KLA = MAX( M-1, 0 )
KUA = MAX( N-1, 0 )
KLB = MAX( P-1, 0 )
KUB = MAX( N-1, 0 )
*
END IF
*
ELSE IF( LSAMEN( 3, PATH, 'GQR' ) .OR. LSAMEN( 3, PATH, 'GLM' ) )
$ THEN
*
* A: N by M, B: N by P
*
IF( IMAT.EQ.1 ) THEN
*
* A: diagonal, B: lower triangular
*
KLA = 0
KUA = 0
KLB = MAX( N-1, 0 )
KUB = 0
ELSE IF( IMAT.EQ.2 ) THEN
*
* A: lower triangular, B: diagonal
*
KLA = MAX( N-1, 0 )
KUA = 0
KLB = 0
KUB = 0
*
ELSE IF( IMAT.EQ.3 ) THEN
*
* A: lower triangular, B: upper triangular
*
KLA = MAX( N-1, 0 )
KUA = 0
KLB = 0
KUB = MAX( P-1, 0 )
*
ELSE
*
* A: general dense, B: general dense
*
KLA = MAX( N-1, 0 )
KUA = MAX( M-1, 0 )
KLB = MAX( N-1, 0 )
KUB = MAX( P-1, 0 )
END IF
*
END IF
*
* Set the condition number and norm.
*
CNDNMA = TEN*TEN
CNDNMB = TEN
IF( LSAMEN( 3, PATH, 'GQR' ) .OR. LSAMEN( 3, PATH, 'GRQ' ) .OR.
$ LSAMEN( 3, PATH, 'GSV' ) ) THEN
IF( IMAT.EQ.5 ) THEN
CNDNMA = BADC1
CNDNMB = BADC1
ELSE IF( IMAT.EQ.6 ) THEN
CNDNMA = BADC2
CNDNMB = BADC2
ELSE IF( IMAT.EQ.7 ) THEN
CNDNMA = BADC1
CNDNMB = BADC2
ELSE IF( IMAT.EQ.8 ) THEN
CNDNMA = BADC2
CNDNMB = BADC1
END IF
END IF
*
ANORM = TEN
BNORM = TEN*TEN*TEN
IF( LSAMEN( 3, PATH, 'GQR' ) .OR. LSAMEN( 3, PATH, 'GRQ' ) ) THEN
IF( IMAT.EQ.7 ) THEN
ANORM = SMALL
BNORM = LARGE
ELSE IF( IMAT.EQ.8 ) THEN
ANORM = LARGE
BNORM = SMALL
END IF
END IF
*
IF( N.LE.1 ) THEN
CNDNMA = ONE
CNDNMB = ONE
END IF
*
RETURN
*
* End of DLATB9
*
END
SUBROUTINE DLATM4( ITYPE, N, NZ1, NZ2, ISIGN, AMAGN, RCOND,
$ TRIANG, IDIST, ISEED, A, LDA )
*
* -- LAPACK auxiliary test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IDIST, ISIGN, ITYPE, LDA, N, NZ1, NZ2
DOUBLE PRECISION AMAGN, RCOND, TRIANG
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
DOUBLE PRECISION A( LDA, * )
* ..
*
* Purpose
* =======
*
* DLATM4 generates basic square matrices, which may later be
* multiplied by others in order to produce test matrices. It is
* intended mainly to be used to test the generalized eigenvalue
* routines.
*
* It first generates the diagonal and (possibly) subdiagonal,
* according to the value of ITYPE, NZ1, NZ2, ISIGN, AMAGN, and RCOND.
* It then fills in the upper triangle with random numbers, if TRIANG is
* non-zero.
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* The "type" of matrix on the diagonal and sub-diagonal.
* If ITYPE < 0, then type abs(ITYPE) is generated and then
* swapped end for end (A(I,J) := A'(N-J,N-I).) See also
* the description of AMAGN and ISIGN.
*
* Special types:
* = 0: the zero matrix.
* = 1: the identity.
* = 2: a transposed Jordan block.
* = 3: If N is odd, then a k+1 x k+1 transposed Jordan block
* followed by a k x k identity block, where k=(N-1)/2.
* If N is even, then k=(N-2)/2, and a zero diagonal entry
* is tacked onto the end.
*
* Diagonal types. The diagonal consists of NZ1 zeros, then
* k=N-NZ1-NZ2 nonzeros. The subdiagonal is zero. ITYPE
* specifies the nonzero diagonal entries as follows:
* = 4: 1, ..., k
* = 5: 1, RCOND, ..., RCOND
* = 6: 1, ..., 1, RCOND
* = 7: 1, a, a^2, ..., a^(k-1)=RCOND
* = 8: 1, 1-d, 1-2*d, ..., 1-(k-1)*d=RCOND
* = 9: random numbers chosen from (RCOND,1)
* = 10: random numbers with distribution IDIST (see DLARND.)
*
* N (input) INTEGER
* The order of the matrix.
*
* NZ1 (input) INTEGER
* If abs(ITYPE) > 3, then the first NZ1 diagonal entries will
* be zero.
*
* NZ2 (input) INTEGER
* If abs(ITYPE) > 3, then the last NZ2 diagonal entries will
* be zero.
*
* ISIGN (input) INTEGER
* = 0: The sign of the diagonal and subdiagonal entries will
* be left unchanged.
* = 1: The diagonal and subdiagonal entries will have their
* sign changed at random.
* = 2: If ITYPE is 2 or 3, then the same as ISIGN=1.
* Otherwise, with probability 0.5, odd-even pairs of
* diagonal entries A(2*j-1,2*j-1), A(2*j,2*j) will be
* converted to a 2x2 block by pre- and post-multiplying
* by distinct random orthogonal rotations. The remaining
* diagonal entries will have their sign changed at random.
*
* AMAGN (input) DOUBLE PRECISION
* The diagonal and subdiagonal entries will be multiplied by
* AMAGN.
*
* RCOND (input) DOUBLE PRECISION
* If abs(ITYPE) > 4, then the smallest diagonal entry will be
* entry will be RCOND. RCOND must be between 0 and 1.
*
* TRIANG (input) DOUBLE PRECISION
* The entries above the diagonal will be random numbers with
* magnitude bounded by TRIANG (i.e., random numbers multiplied
* by TRIANG.)
*
* IDIST (input) INTEGER
* Specifies the type of distribution to be used to generate a
* random matrix.
* = 1: UNIFORM( 0, 1 )
* = 2: UNIFORM( -1, 1 )
* = 3: NORMAL ( 0, 1 )
*
* ISEED (input/output) INTEGER array, dimension (4)
* On entry ISEED specifies the seed of the random number
* generator. The values of ISEED are changed on exit, and can
* be used in the next call to DLATM4 to continue the same
* random number sequence.
* Note: ISEED(4) should be odd, for the random number generator
* used at present.
*
* A (output) DOUBLE PRECISION array, dimension (LDA, N)
* Array to be computed.
*
* LDA (input) INTEGER
* Leading dimension of A. Must be at least 1 and at least N.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
DOUBLE PRECISION HALF
PARAMETER ( HALF = ONE / TWO )
* ..
* .. Local Scalars ..
INTEGER I, IOFF, ISDB, ISDE, JC, JD, JR, K, KBEG, KEND,
$ KLEN
DOUBLE PRECISION ALPHA, CL, CR, SAFMIN, SL, SR, SV1, SV2, TEMP
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLARAN, DLARND
EXTERNAL DLAMCH, DLARAN, DLARND
* ..
* .. External Subroutines ..
EXTERNAL DLASET
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, EXP, LOG, MAX, MIN, MOD, SQRT
* ..
* .. Executable Statements ..
*
IF( N.LE.0 )
$ RETURN
CALL DLASET( 'Full', N, N, ZERO, ZERO, A, LDA )
*
* Insure a correct ISEED
*
IF( MOD( ISEED( 4 ), 2 ).NE.1 )
$ ISEED( 4 ) = ISEED( 4 ) + 1
*
* Compute diagonal and subdiagonal according to ITYPE, NZ1, NZ2,
* and RCOND
*
IF( ITYPE.NE.0 ) THEN
IF( ABS( ITYPE ).GE.4 ) THEN
KBEG = MAX( 1, MIN( N, NZ1+1 ) )
KEND = MAX( KBEG, MIN( N, N-NZ2 ) )
KLEN = KEND + 1 - KBEG
ELSE
KBEG = 1
KEND = N
KLEN = N
END IF
ISDB = 1
ISDE = 0
GO TO ( 10, 30, 50, 80, 100, 120, 140, 160,
$ 180, 200 )ABS( ITYPE )
*
* abs(ITYPE) = 1: Identity
*
10 CONTINUE
DO 20 JD = 1, N
A( JD, JD ) = ONE
20 CONTINUE
GO TO 220
*
* abs(ITYPE) = 2: Transposed Jordan block
*
30 CONTINUE
DO 40 JD = 1, N - 1
A( JD+1, JD ) = ONE
40 CONTINUE
ISDB = 1
ISDE = N - 1
GO TO 220
*
* abs(ITYPE) = 3: Transposed Jordan block, followed by the
* identity.
*
50 CONTINUE
K = ( N-1 ) / 2
DO 60 JD = 1, K
A( JD+1, JD ) = ONE
60 CONTINUE
ISDB = 1
ISDE = K
DO 70 JD = K + 2, 2*K + 1
A( JD, JD ) = ONE
70 CONTINUE
GO TO 220
*
* abs(ITYPE) = 4: 1,...,k
*
80 CONTINUE
DO 90 JD = KBEG, KEND
A( JD, JD ) = DBLE( JD-NZ1 )
90 CONTINUE
GO TO 220
*
* abs(ITYPE) = 5: One large D value:
*
100 CONTINUE
DO 110 JD = KBEG + 1, KEND
A( JD, JD ) = RCOND
110 CONTINUE
A( KBEG, KBEG ) = ONE
GO TO 220
*
* abs(ITYPE) = 6: One small D value:
*
120 CONTINUE
DO 130 JD = KBEG, KEND - 1
A( JD, JD ) = ONE
130 CONTINUE
A( KEND, KEND ) = RCOND
GO TO 220
*
* abs(ITYPE) = 7: Exponentially distributed D values:
*
140 CONTINUE
A( KBEG, KBEG ) = ONE
IF( KLEN.GT.1 ) THEN
ALPHA = RCOND**( ONE / DBLE( KLEN-1 ) )
DO 150 I = 2, KLEN
A( NZ1+I, NZ1+I ) = ALPHA**DBLE( I-1 )
150 CONTINUE
END IF
GO TO 220
*
* abs(ITYPE) = 8: Arithmetically distributed D values:
*
160 CONTINUE
A( KBEG, KBEG ) = ONE
IF( KLEN.GT.1 ) THEN
ALPHA = ( ONE-RCOND ) / DBLE( KLEN-1 )
DO 170 I = 2, KLEN
A( NZ1+I, NZ1+I ) = DBLE( KLEN-I )*ALPHA + RCOND
170 CONTINUE
END IF
GO TO 220
*
* abs(ITYPE) = 9: Randomly distributed D values on ( RCOND, 1):
*
180 CONTINUE
ALPHA = LOG( RCOND )
DO 190 JD = KBEG, KEND
A( JD, JD ) = EXP( ALPHA*DLARAN( ISEED ) )
190 CONTINUE
GO TO 220
*
* abs(ITYPE) = 10: Randomly distributed D values from DIST
*
200 CONTINUE
DO 210 JD = KBEG, KEND
A( JD, JD ) = DLARND( IDIST, ISEED )
210 CONTINUE
*
220 CONTINUE
*
* Scale by AMAGN
*
DO 230 JD = KBEG, KEND
A( JD, JD ) = AMAGN*DBLE( A( JD, JD ) )
230 CONTINUE
DO 240 JD = ISDB, ISDE
A( JD+1, JD ) = AMAGN*DBLE( A( JD+1, JD ) )
240 CONTINUE
*
* If ISIGN = 1 or 2, assign random signs to diagonal and
* subdiagonal
*
IF( ISIGN.GT.0 ) THEN
DO 250 JD = KBEG, KEND
IF( DBLE( A( JD, JD ) ).NE.ZERO ) THEN
IF( DLARAN( ISEED ).GT.HALF )
$ A( JD, JD ) = -A( JD, JD )
END IF
250 CONTINUE
DO 260 JD = ISDB, ISDE
IF( DBLE( A( JD+1, JD ) ).NE.ZERO ) THEN
IF( DLARAN( ISEED ).GT.HALF )
$ A( JD+1, JD ) = -A( JD+1, JD )
END IF
260 CONTINUE
END IF
*
* Reverse if ITYPE < 0
*
IF( ITYPE.LT.0 ) THEN
DO 270 JD = KBEG, ( KBEG+KEND-1 ) / 2
TEMP = A( JD, JD )
A( JD, JD ) = A( KBEG+KEND-JD, KBEG+KEND-JD )
A( KBEG+KEND-JD, KBEG+KEND-JD ) = TEMP
270 CONTINUE
DO 280 JD = 1, ( N-1 ) / 2
TEMP = A( JD+1, JD )
A( JD+1, JD ) = A( N+1-JD, N-JD )
A( N+1-JD, N-JD ) = TEMP
280 CONTINUE
END IF
*
* If ISIGN = 2, and no subdiagonals already, then apply
* random rotations to make 2x2 blocks.
*
IF( ISIGN.EQ.2 .AND. ITYPE.NE.2 .AND. ITYPE.NE.3 ) THEN
SAFMIN = DLAMCH( 'S' )
DO 290 JD = KBEG, KEND - 1, 2
IF( DLARAN( ISEED ).GT.HALF ) THEN
*
* Rotation on left.
*
CL = TWO*DLARAN( ISEED ) - ONE
SL = TWO*DLARAN( ISEED ) - ONE
TEMP = ONE / MAX( SAFMIN, SQRT( CL**2+SL**2 ) )
CL = CL*TEMP
SL = SL*TEMP
*
* Rotation on right.
*
CR = TWO*DLARAN( ISEED ) - ONE
SR = TWO*DLARAN( ISEED ) - ONE
TEMP = ONE / MAX( SAFMIN, SQRT( CR**2+SR**2 ) )
CR = CR*TEMP
SR = SR*TEMP
*
* Apply
*
SV1 = A( JD, JD )
SV2 = A( JD+1, JD+1 )
A( JD, JD ) = CL*CR*SV1 + SL*SR*SV2
A( JD+1, JD ) = -SL*CR*SV1 + CL*SR*SV2
A( JD, JD+1 ) = -CL*SR*SV1 + SL*CR*SV2
A( JD+1, JD+1 ) = SL*SR*SV1 + CL*CR*SV2
END IF
290 CONTINUE
END IF
*
END IF
*
* Fill in upper triangle (except for 2x2 blocks)
*
IF( TRIANG.NE.ZERO ) THEN
IF( ISIGN.NE.2 .OR. ITYPE.EQ.2 .OR. ITYPE.EQ.3 ) THEN
IOFF = 1
ELSE
IOFF = 2
DO 300 JR = 1, N - 1
IF( A( JR+1, JR ).EQ.ZERO )
$ A( JR, JR+1 ) = TRIANG*DLARND( IDIST, ISEED )
300 CONTINUE
END IF
*
DO 320 JC = 2, N
DO 310 JR = 1, JC - IOFF
A( JR, JC ) = TRIANG*DLARND( IDIST, ISEED )
310 CONTINUE
320 CONTINUE
END IF
*
RETURN
*
* End of DLATM4
*
END
LOGICAL FUNCTION DLCTES( ZR, ZI, D )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
DOUBLE PRECISION D, ZI, ZR
* ..
*
* Purpose
* =======
*
* DLCTES returns .TRUE. if the eigenvalue (ZR/D) + sqrt(-1)*(ZI/D)
* is to be selected (specifically, in this subroutine, if the real
* part of the eigenvalue is negative), and otherwise it returns
* .FALSE..
*
* It is used by the test routine DDRGES to test whether the driver
* routine DGGES succesfully sorts eigenvalues.
*
* Arguments
* =========
*
* ZR (input) DOUBLE PRECISION
* The numerator of the real part of a complex eigenvalue
* (ZR/D) + i*(ZI/D).
*
* ZI (input) DOUBLE PRECISION
* The numerator of the imaginary part of a complex eigenvalue
* (ZR/D) + i*(ZI).
*
* D (input) DOUBLE PRECISION
* The denominator part of a complex eigenvalue
* (ZR/D) + i*(ZI/D).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Intrinsic Functions ..
INTRINSIC SIGN
* ..
* .. Executable Statements ..
*
IF( D.EQ.ZERO ) THEN
DLCTES = ( ZR.LT.ZERO )
ELSE
DLCTES = ( SIGN( ONE, ZR ).NE.SIGN( ONE, D ) )
END IF
*
RETURN
*
* End of DLCTES
*
END
LOGICAL FUNCTION DLCTSX( AR, AI, BETA )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
DOUBLE PRECISION AI, AR, BETA
* ..
*
* Purpose
* =======
*
* This function is used to determine what eigenvalues will be
* selected. If this is part of the test driver DDRGSX, do not
* change the code UNLESS you are testing input examples and not
* using the built-in examples.
*
* Arguments
* =========
*
* AR (input) DOUBLE PRECISION
* The numerator of the real part of a complex eigenvalue
* (AR/BETA) + i*(AI/BETA).
*
* AI (input) DOUBLE PRECISION
* The numerator of the imaginary part of a complex eigenvalue
* (AR/BETA) + i*(AI).
*
* BETA (input) DOUBLE PRECISION
* The denominator part of a complex eigenvalue
* (AR/BETA) + i*(AI/BETA).
*
* =====================================================================
*
* .. Scalars in Common ..
LOGICAL FS
INTEGER I, M, MPLUSN, N
* ..
* .. Common blocks ..
COMMON / MN / M, N, MPLUSN, I, FS
* ..
* .. Save statement ..
SAVE
* ..
* .. Executable Statements ..
*
IF( FS ) THEN
I = I + 1
IF( I.LE.M ) THEN
DLCTSX = .FALSE.
ELSE
DLCTSX = .TRUE.
END IF
IF( I.EQ.MPLUSN ) THEN
FS = .FALSE.
I = 0
END IF
ELSE
I = I + 1
IF( I.LE.N ) THEN
DLCTSX = .TRUE.
ELSE
DLCTSX = .FALSE.
END IF
IF( I.EQ.MPLUSN ) THEN
FS = .TRUE.
I = 0
END IF
END IF
*
* IF( AR/BETA.GT.0.0 )THEN
* DLCTSX = .TRUE.
* ELSE
* DLCTSX = .FALSE.
* END IF
*
RETURN
*
* End of DLCTSX
*
END
SUBROUTINE DLSETS( M, P, N, A, AF, LDA, B, BF, LDB, C, CF, D, DF,
$ X, WORK, LWORK, RWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDB, LWORK, M, N, P
* ..
* .. Array Arguments ..
*
* Purpose
* =======
*
* DLSETS tests DGGLSE - a subroutine for solving linear equality
* constrained least square problem (LSE).
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix A. M >= 0.
*
* P (input) INTEGER
* The number of rows of the matrix B. P >= 0.
*
* N (input) INTEGER
* The number of columns of the matrices A and B. N >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The M-by-N matrix A.
*
* AF (workspace) DOUBLE PRECISION array, dimension (LDA,N)
*
* LDA (input) INTEGER
* The leading dimension of the arrays A, AF, Q and R.
* LDA >= max(M,N).
*
* B (input) DOUBLE PRECISION array, dimension (LDB,N)
* The P-by-N matrix A.
*
* BF (workspace) DOUBLE PRECISION array, dimension (LDB,N)
*
* LDB (input) INTEGER
* The leading dimension of the arrays B, BF, V and S.
* LDB >= max(P,N).
*
* C (input) DOUBLE PRECISION array, dimension( M )
* the vector C in the LSE problem.
*
* CF (workspace) DOUBLE PRECISION array, dimension( M )
*
* D (input) DOUBLE PRECISION array, dimension( P )
* the vector D in the LSE problem.
*
* DF (workspace) DOUBLE PRECISION array, dimension( P )
*
* X (output) DOUBLE PRECISION array, dimension( N )
* solution vector X in the LSE problem.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (M)
*
* RESULT (output) DOUBLE PRECISION array, dimension (2)
* The test ratios:
* RESULT(1) = norm( A*x - c )/ norm(A)*norm(X)*EPS
* RESULT(2) = norm( B*x - d )/ norm(B)*norm(X)*EPS
*
* ====================================================================
*
DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), B( LDB, * ),
$ BF( LDB, * ), C( * ), CF( * ), D( * ), DF( * ),
$ RESULT( 2 ), RWORK( * ), WORK( LWORK ), X( * )
* ..
* .. Local Scalars ..
INTEGER INFO
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGET02, DGGLSE, DLACPY
* ..
* .. Executable Statements ..
*
* Copy the matrices A and B to the arrays AF and BF,
* and the vectors C and D to the arrays CF and DF,
*
CALL DLACPY( 'Full', M, N, A, LDA, AF, LDA )
CALL DLACPY( 'Full', P, N, B, LDB, BF, LDB )
CALL DCOPY( M, C, 1, CF, 1 )
CALL DCOPY( P, D, 1, DF, 1 )
*
* Solve LSE problem
*
CALL DGGLSE( M, N, P, AF, LDA, BF, LDB, CF, DF, X, WORK, LWORK,
$ INFO )
*
* Test the residual for the solution of LSE
*
* Compute RESULT(1) = norm( A*x - c ) / norm(A)*norm(X)*EPS
*
CALL DCOPY( M, C, 1, CF, 1 )
CALL DCOPY( P, D, 1, DF, 1 )
CALL DGET02( 'No transpose', M, N, 1, A, LDA, X, N, CF, M, RWORK,
$ RESULT( 1 ) )
*
* Compute result(2) = norm( B*x - d ) / norm(B)*norm(X)*EPS
*
CALL DGET02( 'No transpose', P, N, 1, B, LDB, X, N, DF, P, RWORK,
$ RESULT( 2 ) )
*
RETURN
*
* End of DLSETS
*
END
SUBROUTINE DORT01( ROWCOL, M, N, U, LDU, WORK, LWORK, RESID )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER ROWCOL
INTEGER LDU, LWORK, M, N
DOUBLE PRECISION RESID
* ..
* .. Array Arguments ..
DOUBLE PRECISION U( LDU, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DORT01 checks that the matrix U is orthogonal by computing the ratio
*
* RESID = norm( I - U*U' ) / ( n * EPS ), if ROWCOL = 'R',
* or
* RESID = norm( I - U'*U ) / ( m * EPS ), if ROWCOL = 'C'.
*
* Alternatively, if there isn't sufficient workspace to form
* I - U*U' or I - U'*U, the ratio is computed as
*
* RESID = abs( I - U*U' ) / ( n * EPS ), if ROWCOL = 'R',
* or
* RESID = abs( I - U'*U ) / ( m * EPS ), if ROWCOL = 'C'.
*
* where EPS is the machine precision. ROWCOL is used only if m = n;
* if m > n, ROWCOL is assumed to be 'C', and if m < n, ROWCOL is
* assumed to be 'R'.
*
* Arguments
* =========
*
* ROWCOL (input) CHARACTER
* Specifies whether the rows or columns of U should be checked
* for orthogonality. Used only if M = N.
* = 'R': Check for orthogonal rows of U
* = 'C': Check for orthogonal columns of U
*
* M (input) INTEGER
* The number of rows of the matrix U.
*
* N (input) INTEGER
* The number of columns of the matrix U.
*
* U (input) DOUBLE PRECISION array, dimension (LDU,N)
* The orthogonal matrix U. U is checked for orthogonal columns
* if m > n or if m = n and ROWCOL = 'C'. U is checked for
* orthogonal rows if m < n or if m = n and ROWCOL = 'R'.
*
* LDU (input) INTEGER
* The leading dimension of the array U. LDU >= max(1,M).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of the array WORK. For best performance, LWORK
* should be at least N*(N+1) if ROWCOL = 'C' or M*(M+1) if
* ROWCOL = 'R', but the test will be done even if LWORK is 0.
*
* RESID (output) DOUBLE PRECISION
* RESID = norm( I - U * U' ) / ( n * EPS ), if ROWCOL = 'R', or
* RESID = norm( I - U' * U ) / ( m * EPS ), if ROWCOL = 'C'.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
CHARACTER TRANSU
INTEGER I, J, K, LDWORK, MNMIN
DOUBLE PRECISION EPS, TMP
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DDOT, DLAMCH, DLANSY
EXTERNAL LSAME, DDOT, DLAMCH, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DLASET, DSYRK
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
RESID = ZERO
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
EPS = DLAMCH( 'Precision' )
IF( M.LT.N .OR. ( M.EQ.N .AND. LSAME( ROWCOL, 'R' ) ) ) THEN
TRANSU = 'N'
K = N
ELSE
TRANSU = 'T'
K = M
END IF
MNMIN = MIN( M, N )
*
IF( ( MNMIN+1 )*MNMIN.LE.LWORK ) THEN
LDWORK = MNMIN
ELSE
LDWORK = 0
END IF
IF( LDWORK.GT.0 ) THEN
*
* Compute I - U*U' or I - U'*U.
*
CALL DLASET( 'Upper', MNMIN, MNMIN, ZERO, ONE, WORK, LDWORK )
CALL DSYRK( 'Upper', TRANSU, MNMIN, K, -ONE, U, LDU, ONE, WORK,
$ LDWORK )
*
* Compute norm( I - U*U' ) / ( K * EPS ) .
*
RESID = DLANSY( '1', 'Upper', MNMIN, WORK, LDWORK,
$ WORK( LDWORK*MNMIN+1 ) )
RESID = ( RESID / DBLE( K ) ) / EPS
ELSE IF( TRANSU.EQ.'T' ) THEN
*
* Find the maximum element in abs( I - U'*U ) / ( m * EPS )
*
DO 20 J = 1, N
DO 10 I = 1, J
IF( I.NE.J ) THEN
TMP = ZERO
ELSE
TMP = ONE
END IF
TMP = TMP - DDOT( M, U( 1, I ), 1, U( 1, J ), 1 )
RESID = MAX( RESID, ABS( TMP ) )
10 CONTINUE
20 CONTINUE
RESID = ( RESID / DBLE( M ) ) / EPS
ELSE
*
* Find the maximum element in abs( I - U*U' ) / ( n * EPS )
*
DO 40 J = 1, M
DO 30 I = 1, J
IF( I.NE.J ) THEN
TMP = ZERO
ELSE
TMP = ONE
END IF
TMP = TMP - DDOT( N, U( J, 1 ), LDU, U( I, 1 ), LDU )
RESID = MAX( RESID, ABS( TMP ) )
30 CONTINUE
40 CONTINUE
RESID = ( RESID / DBLE( N ) ) / EPS
END IF
RETURN
*
* End of DORT01
*
END
SUBROUTINE DORT03( RC, MU, MV, N, K, U, LDU, V, LDV, WORK, LWORK,
$ RESULT, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*( * ) RC
INTEGER INFO, K, LDU, LDV, LWORK, MU, MV, N
DOUBLE PRECISION RESULT
* ..
* .. Array Arguments ..
DOUBLE PRECISION U( LDU, * ), V( LDV, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DORT03 compares two orthogonal matrices U and V to see if their
* corresponding rows or columns span the same spaces. The rows are
* checked if RC = 'R', and the columns are checked if RC = 'C'.
*
* RESULT is the maximum of
*
* | V*V' - I | / ( MV ulp ), if RC = 'R', or
*
* | V'*V - I | / ( MV ulp ), if RC = 'C',
*
* and the maximum over rows (or columns) 1 to K of
*
* | U(i) - S*V(i) |/ ( N ulp )
*
* where S is +-1 (chosen to minimize the expression), U(i) is the i-th
* row (column) of U, and V(i) is the i-th row (column) of V.
*
* Arguments
* ==========
*
* RC (input) CHARACTER*1
* If RC = 'R' the rows of U and V are to be compared.
* If RC = 'C' the columns of U and V are to be compared.
*
* MU (input) INTEGER
* The number of rows of U if RC = 'R', and the number of
* columns if RC = 'C'. If MU = 0 DORT03 does nothing.
* MU must be at least zero.
*
* MV (input) INTEGER
* The number of rows of V if RC = 'R', and the number of
* columns if RC = 'C'. If MV = 0 DORT03 does nothing.
* MV must be at least zero.
*
* N (input) INTEGER
* If RC = 'R', the number of columns in the matrices U and V,
* and if RC = 'C', the number of rows in U and V. If N = 0
* DORT03 does nothing. N must be at least zero.
*
* K (input) INTEGER
* The number of rows or columns of U and V to compare.
* 0 <= K <= max(MU,MV).
*
* U (input) DOUBLE PRECISION array, dimension (LDU,N)
* The first matrix to compare. If RC = 'R', U is MU by N, and
* if RC = 'C', U is N by MU.
*
* LDU (input) INTEGER
* The leading dimension of U. If RC = 'R', LDU >= max(1,MU),
* and if RC = 'C', LDU >= max(1,N).
*
* V (input) DOUBLE PRECISION array, dimension (LDV,N)
* The second matrix to compare. If RC = 'R', V is MV by N, and
* if RC = 'C', V is N by MV.
*
* LDV (input) INTEGER
* The leading dimension of V. If RC = 'R', LDV >= max(1,MV),
* and if RC = 'C', LDV >= max(1,N).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
*
* LWORK (input) INTEGER
* The length of the array WORK. For best performance, LWORK
* should be at least N*N if RC = 'C' or M*M if RC = 'R', but
* the tests will be done even if LWORK is 0.
*
* RESULT (output) DOUBLE PRECISION
* The value computed by the test described above. RESULT is
* limited to 1/ulp to avoid overflow.
*
* INFO (output) INTEGER
* 0 indicates a successful exit
* -k indicates the k-th parameter had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, IRC, J, LMX
DOUBLE PRECISION RES1, RES2, S, ULP
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, IDAMAX, DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN, SIGN
* ..
* .. External Subroutines ..
EXTERNAL DORT01, XERBLA
* ..
* .. Executable Statements ..
*
* Check inputs
*
INFO = 0
IF( LSAME( RC, 'R' ) ) THEN
IRC = 0
ELSE IF( LSAME( RC, 'C' ) ) THEN
IRC = 1
ELSE
IRC = -1
END IF
IF( IRC.EQ.-1 ) THEN
INFO = -1
ELSE IF( MU.LT.0 ) THEN
INFO = -2
ELSE IF( MV.LT.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( K.LT.0 .OR. K.GT.MAX( MU, MV ) ) THEN
INFO = -5
ELSE IF( ( IRC.EQ.0 .AND. LDU.LT.MAX( 1, MU ) ) .OR.
$ ( IRC.EQ.1 .AND. LDU.LT.MAX( 1, N ) ) ) THEN
INFO = -7
ELSE IF( ( IRC.EQ.0 .AND. LDV.LT.MAX( 1, MV ) ) .OR.
$ ( IRC.EQ.1 .AND. LDV.LT.MAX( 1, N ) ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORT03', -INFO )
RETURN
END IF
*
* Initialize result
*
RESULT = ZERO
IF( MU.EQ.0 .OR. MV.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
* Machine constants
*
ULP = DLAMCH( 'Precision' )
*
IF( IRC.EQ.0 ) THEN
*
* Compare rows
*
RES1 = ZERO
DO 20 I = 1, K
LMX = IDAMAX( N, U( I, 1 ), LDU )
S = SIGN( ONE, U( I, LMX ) )*SIGN( ONE, V( I, LMX ) )
DO 10 J = 1, N
RES1 = MAX( RES1, ABS( U( I, J )-S*V( I, J ) ) )
10 CONTINUE
20 CONTINUE
RES1 = RES1 / ( DBLE( N )*ULP )
*
* Compute orthogonality of rows of V.
*
CALL DORT01( 'Rows', MV, N, V, LDV, WORK, LWORK, RES2 )
*
ELSE
*
* Compare columns
*
RES1 = ZERO
DO 40 I = 1, K
LMX = IDAMAX( N, U( 1, I ), 1 )
S = SIGN( ONE, U( LMX, I ) )*SIGN( ONE, V( LMX, I ) )
DO 30 J = 1, N
RES1 = MAX( RES1, ABS( U( J, I )-S*V( J, I ) ) )
30 CONTINUE
40 CONTINUE
RES1 = RES1 / ( DBLE( N )*ULP )
*
* Compute orthogonality of columns of V.
*
CALL DORT01( 'Columns', N, MV, V, LDV, WORK, LWORK, RES2 )
END IF
*
RESULT = MIN( MAX( RES1, RES2 ), ONE / ULP )
RETURN
*
* End of DORT03
*
END
SUBROUTINE DSBT21( UPLO, N, KA, KS, A, LDA, D, E, U, LDU, WORK,
$ RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER KA, KS, LDA, LDU, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), RESULT( 2 ),
$ U( LDU, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DSBT21 generally checks a decomposition of the form
*
* A = U S U'
*
* where ' means transpose, A is symmetric banded, U is
* orthogonal, and S is diagonal (if KS=0) or symmetric
* tridiagonal (if KS=1).
*
* Specifically:
*
* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and*
* RESULT(2) = | I - UU' | / ( n ulp )
*
* Arguments
* =========
*
* UPLO (input) CHARACTER
* If UPLO='U', the upper triangle of A and V will be used and
* the (strictly) lower triangle will not be referenced.
* If UPLO='L', the lower triangle of A and V will be used and
* the (strictly) upper triangle will not be referenced.
*
* N (input) INTEGER
* The size of the matrix. If it is zero, DSBT21 does nothing.
* It must be at least zero.
*
* KA (input) INTEGER
* The bandwidth of the matrix A. It must be at least zero. If
* it is larger than N-1, then max( 0, N-1 ) will be used.
*
* KS (input) INTEGER
* The bandwidth of the matrix S. It may only be zero or one.
* If zero, then S is diagonal, and E is not referenced. If
* one, then S is symmetric tri-diagonal.
*
* A (input) DOUBLE PRECISION array, dimension (LDA, N)
* The original (unfactored) matrix. It is assumed to be
* symmetric, and only the upper (UPLO='U') or only the lower
* (UPLO='L') will be referenced.
*
* LDA (input) INTEGER
* The leading dimension of A. It must be at least 1
* and at least min( KA, N-1 ).
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The diagonal of the (symmetric tri-) diagonal matrix S.
*
* E (input) DOUBLE PRECISION array, dimension (N-1)
* The off-diagonal of the (symmetric tri-) diagonal matrix S.
* E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and
* (3,2) element, etc.
* Not referenced if KS=0.
*
* U (input) DOUBLE PRECISION array, dimension (LDU, N)
* The orthogonal matrix in the decomposition, expressed as a
* dense matrix (i.e., not as a product of Householder
* transformations, Givens transformations, etc.)
*
* LDU (input) INTEGER
* The leading dimension of U. LDU must be at least N and
* at least 1.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (N**2+N)
*
* RESULT (output) DOUBLE PRECISION array, dimension (2)
* The values computed by the two tests described above. The
* values are currently limited to 1/ulp, to avoid overflow.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LOWER
CHARACTER CUPLO
INTEGER IKA, J, JC, JR, LW
DOUBLE PRECISION ANORM, ULP, UNFL, WNORM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANGE, DLANSB, DLANSP
EXTERNAL LSAME, DLAMCH, DLANGE, DLANSB, DLANSP
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DSPR, DSPR2
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
* Constants
*
RESULT( 1 ) = ZERO
RESULT( 2 ) = ZERO
IF( N.LE.0 )
$ RETURN
*
IKA = MAX( 0, MIN( N-1, KA ) )
LW = ( N*( N+1 ) ) / 2
*
IF( LSAME( UPLO, 'U' ) ) THEN
LOWER = .FALSE.
CUPLO = 'U'
ELSE
LOWER = .TRUE.
CUPLO = 'L'
END IF
*
UNFL = DLAMCH( 'Safe minimum' )
ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
*
* Some Error Checks
*
* Do Test 1
*
* Norm of A:
*
ANORM = MAX( DLANSB( '1', CUPLO, N, IKA, A, LDA, WORK ), UNFL )
*
* Compute error matrix: Error = A - U S U'
*
* Copy A from SB to SP storage format.
*
J = 0
DO 50 JC = 1, N
IF( LOWER ) THEN
DO 10 JR = 1, MIN( IKA+1, N+1-JC )
J = J + 1
WORK( J ) = A( JR, JC )
10 CONTINUE
DO 20 JR = IKA + 2, N + 1 - JC
J = J + 1
WORK( J ) = ZERO
20 CONTINUE
ELSE
DO 30 JR = IKA + 2, JC
J = J + 1
WORK( J ) = ZERO
30 CONTINUE
DO 40 JR = MIN( IKA, JC-1 ), 0, -1
J = J + 1
WORK( J ) = A( IKA+1-JR, JC )
40 CONTINUE
END IF
50 CONTINUE
*
DO 60 J = 1, N
CALL DSPR( CUPLO, N, -D( J ), U( 1, J ), 1, WORK )
60 CONTINUE
*
IF( N.GT.1 .AND. KS.EQ.1 ) THEN
DO 70 J = 1, N - 1
CALL DSPR2( CUPLO, N, -E( J ), U( 1, J ), 1, U( 1, J+1 ), 1,
$ WORK )
70 CONTINUE
END IF
WNORM = DLANSP( '1', CUPLO, N, WORK, WORK( LW+1 ) )
*
IF( ANORM.GT.WNORM ) THEN
RESULT( 1 ) = ( WNORM / ANORM ) / ( N*ULP )
ELSE
IF( ANORM.LT.ONE ) THEN
RESULT( 1 ) = ( MIN( WNORM, N*ANORM ) / ANORM ) / ( N*ULP )
ELSE
RESULT( 1 ) = MIN( WNORM / ANORM, DBLE( N ) ) / ( N*ULP )
END IF
END IF
*
* Do Test 2
*
* Compute UU' - I
*
CALL DGEMM( 'N', 'C', N, N, N, ONE, U, LDU, U, LDU, ZERO, WORK,
$ N )
*
DO 80 J = 1, N
WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - ONE
80 CONTINUE
*
RESULT( 2 ) = MIN( DLANGE( '1', N, N, WORK, N, WORK( N**2+1 ) ),
$ DBLE( N ) ) / ( N*ULP )
*
RETURN
*
* End of DSBT21
*
END
SUBROUTINE DSGT01( ITYPE, UPLO, N, M, A, LDA, B, LDB, Z, LDZ, D,
$ WORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* modified August 1997, a new parameter M is added to the calling
* sequence.
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER ITYPE, LDA, LDB, LDZ, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), D( * ), RESULT( * ),
$ WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DDGT01 checks a decomposition of the form
*
* A Z = B Z D or
* A B Z = Z D or
* B A Z = Z D
*
* where A is a symmetric matrix, B is
* symmetric positive definite, Z is orthogonal, and D is diagonal.
*
* One of the following test ratios is computed:
*
* ITYPE = 1: RESULT(1) = | A Z - B Z D | / ( |A| |Z| n ulp )
*
* ITYPE = 2: RESULT(1) = | A B Z - Z D | / ( |A| |Z| n ulp )
*
* ITYPE = 3: RESULT(1) = | B A Z - Z D | / ( |A| |Z| n ulp )
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* The form of the symmetric generalized eigenproblem.
* = 1: A*z = (lambda)*B*z
* = 2: A*B*z = (lambda)*z
* = 3: B*A*z = (lambda)*z
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* symmetric matrices A and B is stored.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* M (input) INTEGER
* The number of eigenvalues found. 0 <= M <= N.
*
* A (input) DOUBLE PRECISION array, dimension (LDA, N)
* The original symmetric matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* B (input) DOUBLE PRECISION array, dimension (LDB, N)
* The original symmetric positive definite matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* Z (input) DOUBLE PRECISION array, dimension (LDZ, M)
* The computed eigenvectors of the generalized eigenproblem.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= max(1,N).
*
* D (input) DOUBLE PRECISION array, dimension (M)
* The computed eigenvalues of the generalized eigenproblem.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (N*N)
*
* RESULT (output) DOUBLE PRECISION array, dimension (1)
* The test ratio as described above.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
INTEGER I
DOUBLE PRECISION ANORM, ULP
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
EXTERNAL DLAMCH, DLANGE, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, DSYMM
* ..
* .. Executable Statements ..
*
RESULT( 1 ) = ZERO
IF( N.LE.0 )
$ RETURN
*
ULP = DLAMCH( 'Epsilon' )
*
* Compute product of 1-norms of A and Z.
*
ANORM = DLANSY( '1', UPLO, N, A, LDA, WORK )*
$ DLANGE( '1', N, M, Z, LDZ, WORK )
IF( ANORM.EQ.ZERO )
$ ANORM = ONE
*
IF( ITYPE.EQ.1 ) THEN
*
* Norm of AZ - BZD
*
CALL DSYMM( 'Left', UPLO, N, M, ONE, A, LDA, Z, LDZ, ZERO,
$ WORK, N )
DO 10 I = 1, M
CALL DSCAL( N, D( I ), Z( 1, I ), 1 )
10 CONTINUE
CALL DSYMM( 'Left', UPLO, N, M, ONE, B, LDB, Z, LDZ, -ONE,
$ WORK, N )
*
RESULT( 1 ) = ( DLANGE( '1', N, M, WORK, N, WORK ) / ANORM ) /
$ ( N*ULP )
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Norm of ABZ - ZD
*
CALL DSYMM( 'Left', UPLO, N, M, ONE, B, LDB, Z, LDZ, ZERO,
$ WORK, N )
DO 20 I = 1, M
CALL DSCAL( N, D( I ), Z( 1, I ), 1 )
20 CONTINUE
CALL DSYMM( 'Left', UPLO, N, M, ONE, A, LDA, WORK, N, -ONE, Z,
$ LDZ )
*
RESULT( 1 ) = ( DLANGE( '1', N, M, Z, LDZ, WORK ) / ANORM ) /
$ ( N*ULP )
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* Norm of BAZ - ZD
*
CALL DSYMM( 'Left', UPLO, N, M, ONE, A, LDA, Z, LDZ, ZERO,
$ WORK, N )
DO 30 I = 1, M
CALL DSCAL( N, D( I ), Z( 1, I ), 1 )
30 CONTINUE
CALL DSYMM( 'Left', UPLO, N, M, ONE, B, LDB, WORK, N, -ONE, Z,
$ LDZ )
*
RESULT( 1 ) = ( DLANGE( '1', N, M, Z, LDZ, WORK ) / ANORM ) /
$ ( N*ULP )
END IF
*
RETURN
*
* End of DDGT01
*
END
LOGICAL FUNCTION DSLECT( ZR, ZI )
*
* -- LAPACK test routine (version 3.1.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* February 2007
*
* .. Scalar Arguments ..
DOUBLE PRECISION ZI, ZR
* ..
*
* Purpose
* =======
*
* DSLECT returns .TRUE. if the eigenvalue ZR+sqrt(-1)*ZI is to be
* selected, and otherwise it returns .FALSE.
* It is used by DCHK41 to test if DGEES succesfully sorts eigenvalues,
* and by DCHK43 to test if DGEESX succesfully sorts eigenvalues.
*
* The common block /SSLCT/ controls how eigenvalues are selected.
* If SELOPT = 0, then DSLECT return .TRUE. when ZR is less than zero,
* and .FALSE. otherwise.
* If SELOPT is at least 1, DSLECT returns SELVAL(SELOPT) and adds 1
* to SELOPT, cycling back to 1 at SELMAX.
*
* Arguments
* =========
*
* ZR (input) DOUBLE PRECISION
* The real part of a complex eigenvalue ZR + i*ZI.
*
* ZI (input) DOUBLE PRECISION
* The imaginary part of a complex eigenvalue ZR + i*ZI.
*
* =====================================================================
*
* .. Arrays in Common ..
LOGICAL SELVAL( 20 )
DOUBLE PRECISION SELWI( 20 ), SELWR( 20 )
* ..
* .. Scalars in Common ..
INTEGER SELDIM, SELOPT
* ..
* .. Common blocks ..
COMMON / SSLCT / SELOPT, SELDIM, SELVAL, SELWR, SELWI
* ..
* .. Local Scalars ..
INTEGER I
DOUBLE PRECISION RMIN, X
* ..
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAPY2
EXTERNAL DLAPY2
* ..
* .. Executable Statements ..
*
IF( SELOPT.EQ.0 ) THEN
DSLECT = ( ZR.LT.ZERO )
ELSE
RMIN = DLAPY2( ZR-SELWR( 1 ), ZI-SELWI( 1 ) )
DSLECT = SELVAL( 1 )
DO 10 I = 2, SELDIM
X = DLAPY2( ZR-SELWR( I ), ZI-SELWI( I ) )
IF( X.LE.RMIN ) THEN
RMIN = X
DSLECT = SELVAL( I )
END IF
10 CONTINUE
END IF
RETURN
*
* End of DSLECT
*
END
SUBROUTINE DSPT21( ITYPE, UPLO, N, KBAND, AP, D, E, U, LDU, VP,
$ TAU, WORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER ITYPE, KBAND, LDU, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP( * ), D( * ), E( * ), RESULT( 2 ), TAU( * ),
$ U( LDU, * ), VP( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DSPT21 generally checks a decomposition of the form
*
* A = U S U'
*
* where ' means transpose, A is symmetric (stored in packed format), U
* is orthogonal, and S is diagonal (if KBAND=0) or symmetric
* tridiagonal (if KBAND=1). If ITYPE=1, then U is represented as a
* dense matrix, otherwise the U is expressed as a product of
* Householder transformations, whose vectors are stored in the array
* "V" and whose scaling constants are in "TAU"; we shall use the
* letter "V" to refer to the product of Householder transformations
* (which should be equal to U).
*
* Specifically, if ITYPE=1, then:
*
* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and*
* RESULT(2) = | I - UU' | / ( n ulp )
*
* If ITYPE=2, then:
*
* RESULT(1) = | A - V S V' | / ( |A| n ulp )
*
* If ITYPE=3, then:
*
* RESULT(1) = | I - VU' | / ( n ulp )
*
* Packed storage means that, for example, if UPLO='U', then the columns
* of the upper triangle of A are stored one after another, so that
* A(1,j+1) immediately follows A(j,j) in the array AP. Similarly, if
* UPLO='L', then the columns of the lower triangle of A are stored one
* after another in AP, so that A(j+1,j+1) immediately follows A(n,j)
* in the array AP. This means that A(i,j) is stored in:
*
* AP( i + j*(j-1)/2 ) if UPLO='U'
*
* AP( i + (2*n-j)*(j-1)/2 ) if UPLO='L'
*
* The array VP bears the same relation to the matrix V that A does to
* AP.
*
* For ITYPE > 1, the transformation U is expressed as a product
* of Householder transformations:
*
* If UPLO='U', then V = H(n-1)...H(1), where
*
* H(j) = I - tau(j) v(j) v(j)'
*
* and the first j-1 elements of v(j) are stored in V(1:j-1,j+1),
* (i.e., VP( j*(j+1)/2 + 1 : j*(j+1)/2 + j-1 ) ),
* the j-th element is 1, and the last n-j elements are 0.
*
* If UPLO='L', then V = H(1)...H(n-1), where
*
* H(j) = I - tau(j) v(j) v(j)'
*
* and the first j elements of v(j) are 0, the (j+1)-st is 1, and the
* (j+2)-nd through n-th elements are stored in V(j+2:n,j) (i.e.,
* in VP( (2*n-j)*(j-1)/2 + j+2 : (2*n-j)*(j-1)/2 + n ) .)
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* Specifies the type of tests to be performed.
* 1: U expressed as a dense orthogonal matrix:
* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and*
* RESULT(2) = | I - UU' | / ( n ulp )
*
* 2: U expressed as a product V of Housholder transformations:
* RESULT(1) = | A - V S V' | / ( |A| n ulp )
*
* 3: U expressed both as a dense orthogonal matrix and
* as a product of Housholder transformations:
* RESULT(1) = | I - VU' | / ( n ulp )
*
* UPLO (input) CHARACTER
* If UPLO='U', AP and VP are considered to contain the upper
* triangle of A and V.
* If UPLO='L', AP and VP are considered to contain the lower
* triangle of A and V.
*
* N (input) INTEGER
* The size of the matrix. If it is zero, DSPT21 does nothing.
* It must be at least zero.
*
* KBAND (input) INTEGER
* The bandwidth of the matrix. It may only be zero or one.
* If zero, then S is diagonal, and E is not referenced. If
* one, then S is symmetric tri-diagonal.
*
* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* The original (unfactored) matrix. It is assumed to be
* symmetric, and contains the columns of just the upper
* triangle (UPLO='U') or only the lower triangle (UPLO='L'),
* packed one after another.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The diagonal of the (symmetric tri-) diagonal matrix.
*
* E (input) DOUBLE PRECISION array, dimension (N-1)
* The off-diagonal of the (symmetric tri-) diagonal matrix.
* E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and
* (3,2) element, etc.
* Not referenced if KBAND=0.
*
* U (input) DOUBLE PRECISION array, dimension (LDU, N)
* If ITYPE=1 or 3, this contains the orthogonal matrix in
* the decomposition, expressed as a dense matrix. If ITYPE=2,
* then it is not referenced.
*
* LDU (input) INTEGER
* The leading dimension of U. LDU must be at least N and
* at least 1.
*
* VP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
* If ITYPE=2 or 3, the columns of this array contain the
* Householder vectors used to describe the orthogonal matrix
* in the decomposition, as described in purpose.
* *NOTE* If ITYPE=2 or 3, V is modified and restored. The
* subdiagonal (if UPLO='L') or the superdiagonal (if UPLO='U')
* is set to one, and later reset to its original value, during
* the course of the calculation.
* If ITYPE=1, then it is neither referenced nor modified.
*
* TAU (input) DOUBLE PRECISION array, dimension (N)
* If ITYPE >= 2, then TAU(j) is the scalar factor of
* v(j) v(j)' in the Householder transformation H(j) of
* the product U = H(1)...H(n-2)
* If ITYPE < 2, then TAU is not referenced.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (N**2+N)
* Workspace.
*
* RESULT (output) DOUBLE PRECISION array, dimension (2)
* The values computed by the two tests described above. The
* values are currently limited to 1/ulp, to avoid overflow.
* RESULT(1) is always modified. RESULT(2) is modified only
* if ITYPE=1.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TEN
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0 )
DOUBLE PRECISION HALF
PARAMETER ( HALF = 1.0D+0 / 2.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LOWER
CHARACTER CUPLO
INTEGER IINFO, J, JP, JP1, JR, LAP
DOUBLE PRECISION ANORM, TEMP, ULP, UNFL, VSAVE, WNORM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DDOT, DLAMCH, DLANGE, DLANSP
EXTERNAL LSAME, DDOT, DLAMCH, DLANGE, DLANSP
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DGEMM, DLACPY, DLASET, DOPMTR,
$ DSPMV, DSPR, DSPR2
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
* 1) Constants
*
RESULT( 1 ) = ZERO
IF( ITYPE.EQ.1 )
$ RESULT( 2 ) = ZERO
IF( N.LE.0 )
$ RETURN
*
LAP = ( N*( N+1 ) ) / 2
*
IF( LSAME( UPLO, 'U' ) ) THEN
LOWER = .FALSE.
CUPLO = 'U'
ELSE
LOWER = .TRUE.
CUPLO = 'L'
END IF
*
UNFL = DLAMCH( 'Safe minimum' )
ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
*
* Some Error Checks
*
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
RESULT( 1 ) = TEN / ULP
RETURN
END IF
*
* Do Test 1
*
* Norm of A:
*
IF( ITYPE.EQ.3 ) THEN
ANORM = ONE
ELSE
ANORM = MAX( DLANSP( '1', CUPLO, N, AP, WORK ), UNFL )
END IF
*
* Compute error matrix:
*
IF( ITYPE.EQ.1 ) THEN
*
* ITYPE=1: error = A - U S U'
*
CALL DLASET( 'Full', N, N, ZERO, ZERO, WORK, N )
CALL DCOPY( LAP, AP, 1, WORK, 1 )
*
DO 10 J = 1, N
CALL DSPR( CUPLO, N, -D( J ), U( 1, J ), 1, WORK )
10 CONTINUE
*
IF( N.GT.1 .AND. KBAND.EQ.1 ) THEN
DO 20 J = 1, N - 1
CALL DSPR2( CUPLO, N, -E( J ), U( 1, J ), 1, U( 1, J+1 ),
$ 1, WORK )
20 CONTINUE
END IF
WNORM = DLANSP( '1', CUPLO, N, WORK, WORK( N**2+1 ) )
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* ITYPE=2: error = V S V' - A
*
CALL DLASET( 'Full', N, N, ZERO, ZERO, WORK, N )
*
IF( LOWER ) THEN
WORK( LAP ) = D( N )
DO 40 J = N - 1, 1, -1
JP = ( ( 2*N-J )*( J-1 ) ) / 2
JP1 = JP + N - J
IF( KBAND.EQ.1 ) THEN
WORK( JP+J+1 ) = ( ONE-TAU( J ) )*E( J )
DO 30 JR = J + 2, N
WORK( JP+JR ) = -TAU( J )*E( J )*VP( JP+JR )
30 CONTINUE
END IF
*
IF( TAU( J ).NE.ZERO ) THEN
VSAVE = VP( JP+J+1 )
VP( JP+J+1 ) = ONE
CALL DSPMV( 'L', N-J, ONE, WORK( JP1+J+1 ),
$ VP( JP+J+1 ), 1, ZERO, WORK( LAP+1 ), 1 )
TEMP = -HALF*TAU( J )*DDOT( N-J, WORK( LAP+1 ), 1,
$ VP( JP+J+1 ), 1 )
CALL DAXPY( N-J, TEMP, VP( JP+J+1 ), 1, WORK( LAP+1 ),
$ 1 )
CALL DSPR2( 'L', N-J, -TAU( J ), VP( JP+J+1 ), 1,
$ WORK( LAP+1 ), 1, WORK( JP1+J+1 ) )
VP( JP+J+1 ) = VSAVE
END IF
WORK( JP+J ) = D( J )
40 CONTINUE
ELSE
WORK( 1 ) = D( 1 )
DO 60 J = 1, N - 1
JP = ( J*( J-1 ) ) / 2
JP1 = JP + J
IF( KBAND.EQ.1 ) THEN
WORK( JP1+J ) = ( ONE-TAU( J ) )*E( J )
DO 50 JR = 1, J - 1
WORK( JP1+JR ) = -TAU( J )*E( J )*VP( JP1+JR )
50 CONTINUE
END IF
*
IF( TAU( J ).NE.ZERO ) THEN
VSAVE = VP( JP1+J )
VP( JP1+J ) = ONE
CALL DSPMV( 'U', J, ONE, WORK, VP( JP1+1 ), 1, ZERO,
$ WORK( LAP+1 ), 1 )
TEMP = -HALF*TAU( J )*DDOT( J, WORK( LAP+1 ), 1,
$ VP( JP1+1 ), 1 )
CALL DAXPY( J, TEMP, VP( JP1+1 ), 1, WORK( LAP+1 ),
$ 1 )
CALL DSPR2( 'U', J, -TAU( J ), VP( JP1+1 ), 1,
$ WORK( LAP+1 ), 1, WORK )
VP( JP1+J ) = VSAVE
END IF
WORK( JP1+J+1 ) = D( J+1 )
60 CONTINUE
END IF
*
DO 70 J = 1, LAP
WORK( J ) = WORK( J ) - AP( J )
70 CONTINUE
WNORM = DLANSP( '1', CUPLO, N, WORK, WORK( LAP+1 ) )
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* ITYPE=3: error = U V' - I
*
IF( N.LT.2 )
$ RETURN
CALL DLACPY( ' ', N, N, U, LDU, WORK, N )
CALL DOPMTR( 'R', CUPLO, 'T', N, N, VP, TAU, WORK, N,
$ WORK( N**2+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
RESULT( 1 ) = TEN / ULP
RETURN
END IF
*
DO 80 J = 1, N
WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - ONE
80 CONTINUE
*
WNORM = DLANGE( '1', N, N, WORK, N, WORK( N**2+1 ) )
END IF
*
IF( ANORM.GT.WNORM ) THEN
RESULT( 1 ) = ( WNORM / ANORM ) / ( N*ULP )
ELSE
IF( ANORM.LT.ONE ) THEN
RESULT( 1 ) = ( MIN( WNORM, N*ANORM ) / ANORM ) / ( N*ULP )
ELSE
RESULT( 1 ) = MIN( WNORM / ANORM, DBLE( N ) ) / ( N*ULP )
END IF
END IF
*
* Do Test 2
*
* Compute UU' - I
*
IF( ITYPE.EQ.1 ) THEN
CALL DGEMM( 'N', 'C', N, N, N, ONE, U, LDU, U, LDU, ZERO, WORK,
$ N )
*
DO 90 J = 1, N
WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - ONE
90 CONTINUE
*
RESULT( 2 ) = MIN( DLANGE( '1', N, N, WORK, N,
$ WORK( N**2+1 ) ), DBLE( N ) ) / ( N*ULP )
END IF
*
RETURN
*
* End of DSPT21
*
END
SUBROUTINE DSTECH( N, A, B, EIG, TOL, WORK, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, N
DOUBLE PRECISION TOL
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( * ), B( * ), EIG( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* Let T be the tridiagonal matrix with diagonal entries A(1) ,...,
* A(N) and offdiagonal entries B(1) ,..., B(N-1)). DSTECH checks to
* see if EIG(1) ,..., EIG(N) are indeed accurate eigenvalues of T.
* It does this by expanding each EIG(I) into an interval
* [SVD(I) - EPS, SVD(I) + EPS], merging overlapping intervals if
* any, and using Sturm sequences to count and verify whether each
* resulting interval has the correct number of eigenvalues (using
* DSTECT). Here EPS = TOL*MAZHEPS*MAXEIG, where MACHEPS is the
* machine precision and MAXEIG is the absolute value of the largest
* eigenvalue. If each interval contains the correct number of
* eigenvalues, INFO = 0 is returned, otherwise INFO is the index of
* the first eigenvalue in the first bad interval.
*
* Arguments
* =========
*
* N (input) INTEGER
* The dimension of the tridiagonal matrix T.
*
* A (input) DOUBLE PRECISION array, dimension (N)
* The diagonal entries of the tridiagonal matrix T.
*
* B (input) DOUBLE PRECISION array, dimension (N-1)
* The offdiagonal entries of the tridiagonal matrix T.
*
* EIG (input) DOUBLE PRECISION array, dimension (N)
* The purported eigenvalues to be checked.
*
* TOL (input) DOUBLE PRECISION
* Error tolerance for checking, a multiple of the
* machine precision.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (N)
*
* INFO (output) INTEGER
* 0 if the eigenvalues are all correct (to within
* 1 +- TOL*MAZHEPS*MAXEIG)
* >0 if the interval containing the INFO-th eigenvalue
* contains the incorrect number of eigenvalues.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER BPNT, COUNT, I, ISUB, J, NUML, NUMU, TPNT
DOUBLE PRECISION EMIN, EPS, LOWER, MX, TUPPR, UNFLEP, UPPER
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DSTECT
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
* Check input parameters
*
INFO = 0
IF( N.EQ.0 )
$ RETURN
IF( N.LT.0 ) THEN
INFO = -1
RETURN
END IF
IF( TOL.LT.ZERO ) THEN
INFO = -5
RETURN
END IF
*
* Get machine constants
*
EPS = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
UNFLEP = DLAMCH( 'Safe minimum' ) / EPS
EPS = TOL*EPS
*
* Compute maximum absolute eigenvalue, error tolerance
*
MX = ABS( EIG( 1 ) )
DO 10 I = 2, N
MX = MAX( MX, ABS( EIG( I ) ) )
10 CONTINUE
EPS = MAX( EPS*MX, UNFLEP )
*
* Sort eigenvalues from EIG into WORK
*
DO 20 I = 1, N
WORK( I ) = EIG( I )
20 CONTINUE
DO 40 I = 1, N - 1
ISUB = 1
EMIN = WORK( 1 )
DO 30 J = 2, N + 1 - I
IF( WORK( J ).LT.EMIN ) THEN
ISUB = J
EMIN = WORK( J )
END IF
30 CONTINUE
IF( ISUB.NE.N+1-I ) THEN
WORK( ISUB ) = WORK( N+1-I )
WORK( N+1-I ) = EMIN
END IF
40 CONTINUE
*
* TPNT points to singular value at right endpoint of interval
* BPNT points to singular value at left endpoint of interval
*
TPNT = 1
BPNT = 1
*
* Begin loop over all intervals
*
50 CONTINUE
UPPER = WORK( TPNT ) + EPS
LOWER = WORK( BPNT ) - EPS
*
* Begin loop merging overlapping intervals
*
60 CONTINUE
IF( BPNT.EQ.N )
$ GO TO 70
TUPPR = WORK( BPNT+1 ) + EPS
IF( TUPPR.LT.LOWER )
$ GO TO 70
*
* Merge
*
BPNT = BPNT + 1
LOWER = WORK( BPNT ) - EPS
GO TO 60
70 CONTINUE
*
* Count singular values in interval [ LOWER, UPPER ]
*
CALL DSTECT( N, A, B, LOWER, NUML )
CALL DSTECT( N, A, B, UPPER, NUMU )
COUNT = NUMU - NUML
IF( COUNT.NE.BPNT-TPNT+1 ) THEN
*
* Wrong number of singular values in interval
*
INFO = TPNT
GO TO 80
END IF
TPNT = BPNT + 1
BPNT = TPNT
IF( TPNT.LE.N )
$ GO TO 50
80 CONTINUE
RETURN
*
* End of DSTECH
*
END
SUBROUTINE DSTECT( N, A, B, SHIFT, NUM )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER N, NUM
DOUBLE PRECISION SHIFT
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( * ), B( * )
* ..
*
* Purpose
* =======
*
* DSTECT counts the number NUM of eigenvalues of a tridiagonal
* matrix T which are less than or equal to SHIFT. T has
* diagonal entries A(1), ... , A(N), and offdiagonal entries
* B(1), ..., B(N-1).
* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
* Matrix", Report CS41, Computer Science Dept., Stanford
* University, July 21, 1966
*
* Arguments
* =========
*
* N (input) INTEGER
* The dimension of the tridiagonal matrix T.
*
* A (input) DOUBLE PRECISION array, dimension (N)
* The diagonal entries of the tridiagonal matrix T.
*
* B (input) DOUBLE PRECISION array, dimension (N-1)
* The offdiagonal entries of the tridiagonal matrix T.
*
* SHIFT (input) DOUBLE PRECISION
* The shift, used as described under Purpose.
*
* NUM (output) INTEGER
* The number of eigenvalues of T less than or equal
* to SHIFT.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, THREE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, THREE = 3.0D0 )
* ..
* .. Local Scalars ..
INTEGER I
DOUBLE PRECISION M1, M2, MX, OVFL, SOV, SSHIFT, SSUN, SUN, TMP,
$ TOM, U, UNFL
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Get machine constants
*
UNFL = DLAMCH( 'Safe minimum' )
OVFL = DLAMCH( 'Overflow' )
*
* Find largest entry
*
MX = ABS( A( 1 ) )
DO 10 I = 1, N - 1
MX = MAX( MX, ABS( A( I+1 ) ), ABS( B( I ) ) )
10 CONTINUE
*
* Handle easy cases, including zero matrix
*
IF( SHIFT.GE.THREE*MX ) THEN
NUM = N
RETURN
END IF
IF( SHIFT.LT.-THREE*MX ) THEN
NUM = 0
RETURN
END IF
*
* Compute scale factors as in Kahan's report
* At this point, MX .NE. 0 so we can divide by it
*
SUN = SQRT( UNFL )
SSUN = SQRT( SUN )
SOV = SQRT( OVFL )
TOM = SSUN*SOV
IF( MX.LE.ONE ) THEN
M1 = ONE / MX
M2 = TOM
ELSE
M1 = ONE
M2 = TOM / MX
END IF
*
* Begin counting
*
NUM = 0
SSHIFT = ( SHIFT*M1 )*M2
U = ( A( 1 )*M1 )*M2 - SSHIFT
IF( U.LE.SUN ) THEN
IF( U.LE.ZERO ) THEN
NUM = NUM + 1
IF( U.GT.-SUN )
$ U = -SUN
ELSE
U = SUN
END IF
END IF
DO 20 I = 2, N
TMP = ( B( I-1 )*M1 )*M2
U = ( ( A( I )*M1 )*M2-TMP*( TMP / U ) ) - SSHIFT
IF( U.LE.SUN ) THEN
IF( U.LE.ZERO ) THEN
NUM = NUM + 1
IF( U.GT.-SUN )
$ U = -SUN
ELSE
U = SUN
END IF
END IF
20 CONTINUE
RETURN
*
* End of DSTECT
*
END
SUBROUTINE DSTT21( N, KBAND, AD, AE, SD, SE, U, LDU, WORK,
$ RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KBAND, LDU, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AD( * ), AE( * ), RESULT( 2 ), SD( * ),
$ SE( * ), U( LDU, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DSTT21 checks a decomposition of the form
*
* A = U S U'
*
* where ' means transpose, A is symmetric tridiagonal, U is orthogonal,
* and S is diagonal (if KBAND=0) or symmetric tridiagonal (if KBAND=1).
* Two tests are performed:
*
* RESULT(1) = | A - U S U' | / ( |A| n ulp )
*
* RESULT(2) = | I - UU' | / ( n ulp )
*
* Arguments
* =========
*
* N (input) INTEGER
* The size of the matrix. If it is zero, DSTT21 does nothing.
* It must be at least zero.
*
* KBAND (input) INTEGER
* The bandwidth of the matrix S. It may only be zero or one.
* If zero, then S is diagonal, and SE is not referenced. If
* one, then S is symmetric tri-diagonal.
*
* AD (input) DOUBLE PRECISION array, dimension (N)
* The diagonal of the original (unfactored) matrix A. A is
* assumed to be symmetric tridiagonal.
*
* AE (input) DOUBLE PRECISION array, dimension (N-1)
* The off-diagonal of the original (unfactored) matrix A. A
* is assumed to be symmetric tridiagonal. AE(1) is the (1,2)
* and (2,1) element, AE(2) is the (2,3) and (3,2) element, etc.
*
* SD (input) DOUBLE PRECISION array, dimension (N)
* The diagonal of the (symmetric tri-) diagonal matrix S.
*
* SE (input) DOUBLE PRECISION array, dimension (N-1)
* The off-diagonal of the (symmetric tri-) diagonal matrix S.
* Not referenced if KBSND=0. If KBAND=1, then AE(1) is the
* (1,2) and (2,1) element, SE(2) is the (2,3) and (3,2)
* element, etc.
*
* U (input) DOUBLE PRECISION array, dimension (LDU, N)
* The orthogonal matrix in the decomposition.
*
* LDU (input) INTEGER
* The leading dimension of U. LDU must be at least N.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (N*(N+1))
*
* RESULT (output) DOUBLE PRECISION array, dimension (2)
* The values computed by the two tests described above. The
* values are currently limited to 1/ulp, to avoid overflow.
* RESULT(1) is always modified.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
INTEGER J
DOUBLE PRECISION ANORM, TEMP1, TEMP2, ULP, UNFL, WNORM
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
EXTERNAL DLAMCH, DLANGE, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLASET, DSYR, DSYR2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
* 1) Constants
*
RESULT( 1 ) = ZERO
RESULT( 2 ) = ZERO
IF( N.LE.0 )
$ RETURN
*
UNFL = DLAMCH( 'Safe minimum' )
ULP = DLAMCH( 'Precision' )
*
* Do Test 1
*
* Copy A & Compute its 1-Norm:
*
CALL DLASET( 'Full', N, N, ZERO, ZERO, WORK, N )
*
ANORM = ZERO
TEMP1 = ZERO
*
DO 10 J = 1, N - 1
WORK( ( N+1 )*( J-1 )+1 ) = AD( J )
WORK( ( N+1 )*( J-1 )+2 ) = AE( J )
TEMP2 = ABS( AE( J ) )
ANORM = MAX( ANORM, ABS( AD( J ) )+TEMP1+TEMP2 )
TEMP1 = TEMP2
10 CONTINUE
*
WORK( N**2 ) = AD( N )
ANORM = MAX( ANORM, ABS( AD( N ) )+TEMP1, UNFL )
*
* Norm of A - USU'
*
DO 20 J = 1, N
CALL DSYR( 'L', N, -SD( J ), U( 1, J ), 1, WORK, N )
20 CONTINUE
*
IF( N.GT.1 .AND. KBAND.EQ.1 ) THEN
DO 30 J = 1, N - 1
CALL DSYR2( 'L', N, -SE( J ), U( 1, J ), 1, U( 1, J+1 ), 1,
$ WORK, N )
30 CONTINUE
END IF
*
WNORM = DLANSY( '1', 'L', N, WORK, N, WORK( N**2+1 ) )
*
IF( ANORM.GT.WNORM ) THEN
RESULT( 1 ) = ( WNORM / ANORM ) / ( N*ULP )
ELSE
IF( ANORM.LT.ONE ) THEN
RESULT( 1 ) = ( MIN( WNORM, N*ANORM ) / ANORM ) / ( N*ULP )
ELSE
RESULT( 1 ) = MIN( WNORM / ANORM, DBLE( N ) ) / ( N*ULP )
END IF
END IF
*
* Do Test 2
*
* Compute UU' - I
*
CALL DGEMM( 'N', 'C', N, N, N, ONE, U, LDU, U, LDU, ZERO, WORK,
$ N )
*
DO 40 J = 1, N
WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - ONE
40 CONTINUE
*
RESULT( 2 ) = MIN( DBLE( N ), DLANGE( '1', N, N, WORK, N,
$ WORK( N**2+1 ) ) ) / ( N*ULP )
*
RETURN
*
* End of DSTT21
*
END
SUBROUTINE DSTT22( N, M, KBAND, AD, AE, SD, SE, U, LDU, WORK,
$ LDWORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER KBAND, LDU, LDWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION AD( * ), AE( * ), RESULT( 2 ), SD( * ),
$ SE( * ), U( LDU, * ), WORK( LDWORK, * )
* ..
*
* Purpose
* =======
*
* DSTT22 checks a set of M eigenvalues and eigenvectors,
*
* A U = U S
*
* where A is symmetric tridiagonal, the columns of U are orthogonal,
* and S is diagonal (if KBAND=0) or symmetric tridiagonal (if KBAND=1).
* Two tests are performed:
*
* RESULT(1) = | U' A U - S | / ( |A| m ulp )
*
* RESULT(2) = | I - U'U | / ( m ulp )
*
* Arguments
* =========
*
* N (input) INTEGER
* The size of the matrix. If it is zero, DSTT22 does nothing.
* It must be at least zero.
*
* M (input) INTEGER
* The number of eigenpairs to check. If it is zero, DSTT22
* does nothing. It must be at least zero.
*
* KBAND (input) INTEGER
* The bandwidth of the matrix S. It may only be zero or one.
* If zero, then S is diagonal, and SE is not referenced. If
* one, then S is symmetric tri-diagonal.
*
* AD (input) DOUBLE PRECISION array, dimension (N)
* The diagonal of the original (unfactored) matrix A. A is
* assumed to be symmetric tridiagonal.
*
* AE (input) DOUBLE PRECISION array, dimension (N)
* The off-diagonal of the original (unfactored) matrix A. A
* is assumed to be symmetric tridiagonal. AE(1) is ignored,
* AE(2) is the (1,2) and (2,1) element, etc.
*
* SD (input) DOUBLE PRECISION array, dimension (N)
* The diagonal of the (symmetric tri-) diagonal matrix S.
*
* SE (input) DOUBLE PRECISION array, dimension (N)
* The off-diagonal of the (symmetric tri-) diagonal matrix S.
* Not referenced if KBSND=0. If KBAND=1, then AE(1) is
* ignored, SE(2) is the (1,2) and (2,1) element, etc.
*
* U (input) DOUBLE PRECISION array, dimension (LDU, N)
* The orthogonal matrix in the decomposition.
*
* LDU (input) INTEGER
* The leading dimension of U. LDU must be at least N.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK, M+1)
*
* LDWORK (input) INTEGER
* The leading dimension of WORK. LDWORK must be at least
* max(1,M).
*
* RESULT (output) DOUBLE PRECISION array, dimension (2)
* The values computed by the two tests described above. The
* values are currently limited to 1/ulp, to avoid overflow.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, J, K
DOUBLE PRECISION ANORM, AUKJ, ULP, UNFL, WNORM
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
EXTERNAL DLAMCH, DLANGE, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DGEMM
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
RESULT( 1 ) = ZERO
RESULT( 2 ) = ZERO
IF( N.LE.0 .OR. M.LE.0 )
$ RETURN
*
UNFL = DLAMCH( 'Safe minimum' )
ULP = DLAMCH( 'Epsilon' )
*
* Do Test 1
*
* Compute the 1-norm of A.
*
IF( N.GT.1 ) THEN
ANORM = ABS( AD( 1 ) ) + ABS( AE( 1 ) )
DO 10 J = 2, N - 1
ANORM = MAX( ANORM, ABS( AD( J ) )+ABS( AE( J ) )+
$ ABS( AE( J-1 ) ) )
10 CONTINUE
ANORM = MAX( ANORM, ABS( AD( N ) )+ABS( AE( N-1 ) ) )
ELSE
ANORM = ABS( AD( 1 ) )
END IF
ANORM = MAX( ANORM, UNFL )
*
* Norm of U'AU - S
*
DO 40 I = 1, M
DO 30 J = 1, M
WORK( I, J ) = ZERO
DO 20 K = 1, N
AUKJ = AD( K )*U( K, J )
IF( K.NE.N )
$ AUKJ = AUKJ + AE( K )*U( K+1, J )
IF( K.NE.1 )
$ AUKJ = AUKJ + AE( K-1 )*U( K-1, J )
WORK( I, J ) = WORK( I, J ) + U( K, I )*AUKJ
20 CONTINUE
30 CONTINUE
WORK( I, I ) = WORK( I, I ) - SD( I )
IF( KBAND.EQ.1 ) THEN
IF( I.NE.1 )
$ WORK( I, I-1 ) = WORK( I, I-1 ) - SE( I-1 )
IF( I.NE.N )
$ WORK( I, I+1 ) = WORK( I, I+1 ) - SE( I )
END IF
40 CONTINUE
*
WNORM = DLANSY( '1', 'L', M, WORK, M, WORK( 1, M+1 ) )
*
IF( ANORM.GT.WNORM ) THEN
RESULT( 1 ) = ( WNORM / ANORM ) / ( M*ULP )
ELSE
IF( ANORM.LT.ONE ) THEN
RESULT( 1 ) = ( MIN( WNORM, M*ANORM ) / ANORM ) / ( M*ULP )
ELSE
RESULT( 1 ) = MIN( WNORM / ANORM, DBLE( M ) ) / ( M*ULP )
END IF
END IF
*
* Do Test 2
*
* Compute U'U - I
*
CALL DGEMM( 'T', 'N', M, M, N, ONE, U, LDU, U, LDU, ZERO, WORK,
$ M )
*
DO 50 J = 1, M
WORK( J, J ) = WORK( J, J ) - ONE
50 CONTINUE
*
RESULT( 2 ) = MIN( DBLE( M ), DLANGE( '1', M, M, WORK, M, WORK( 1,
$ M+1 ) ) ) / ( M*ULP )
*
RETURN
*
* End of DSTT22
*
END
SUBROUTINE DSVDCH( N, S, E, SVD, TOL, INFO )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, N
DOUBLE PRECISION TOL
* ..
* .. Array Arguments ..
DOUBLE PRECISION E( * ), S( * ), SVD( * )
* ..
*
* Purpose
* =======
*
* DSVDCH checks to see if SVD(1) ,..., SVD(N) are accurate singular
* values of the bidiagonal matrix B with diagonal entries
* S(1) ,..., S(N) and superdiagonal entries E(1) ,..., E(N-1)).
* It does this by expanding each SVD(I) into an interval
* [SVD(I) * (1-EPS) , SVD(I) * (1+EPS)], merging overlapping intervals
* if any, and using Sturm sequences to count and verify whether each
* resulting interval has the correct number of singular values (using
* DSVDCT). Here EPS=TOL*MAX(N/10,1)*MAZHEP, where MACHEP is the
* machine precision. The routine assumes the singular values are sorted
* with SVD(1) the largest and SVD(N) smallest. If each interval
* contains the correct number of singular values, INFO = 0 is returned,
* otherwise INFO is the index of the first singular value in the first
* bad interval.
*
* Arguments
* ==========
*
* N (input) INTEGER
* The dimension of the bidiagonal matrix B.
*
* S (input) DOUBLE PRECISION array, dimension (N)
* The diagonal entries of the bidiagonal matrix B.
*
* E (input) DOUBLE PRECISION array, dimension (N-1)
* The superdiagonal entries of the bidiagonal matrix B.
*
* SVD (input) DOUBLE PRECISION array, dimension (N)
* The computed singular values to be checked.
*
* TOL (input) DOUBLE PRECISION
* Error tolerance for checking, a multiplier of the
* machine precision.
*
* INFO (output) INTEGER
* =0 if the singular values are all correct (to within
* 1 +- TOL*MAZHEPS)
* >0 if the interval containing the INFO-th singular value
* contains the incorrect number of singular values.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER BPNT, COUNT, NUML, NUMU, TPNT
DOUBLE PRECISION EPS, LOWER, OVFL, TUPPR, UNFL, UNFLEP, UPPER
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DSVDCT
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Get machine constants
*
INFO = 0
IF( N.LE.0 )
$ RETURN
UNFL = DLAMCH( 'Safe minimum' )
OVFL = DLAMCH( 'Overflow' )
EPS = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
*
* UNFLEP is chosen so that when an eigenvalue is multiplied by the
* scale factor sqrt(OVFL)*sqrt(sqrt(UNFL))/MX in DSVDCT, it exceeds
* sqrt(UNFL), which is the lower limit for DSVDCT.
*
UNFLEP = ( SQRT( SQRT( UNFL ) ) / SQRT( OVFL ) )*SVD( 1 ) +
$ UNFL / EPS
*
* The value of EPS works best when TOL .GE. 10.
*
EPS = TOL*MAX( N / 10, 1 )*EPS
*
* TPNT points to singular value at right endpoint of interval
* BPNT points to singular value at left endpoint of interval
*
TPNT = 1
BPNT = 1
*
* Begin loop over all intervals
*
10 CONTINUE
UPPER = ( ONE+EPS )*SVD( TPNT ) + UNFLEP
LOWER = ( ONE-EPS )*SVD( BPNT ) - UNFLEP
IF( LOWER.LE.UNFLEP )
$ LOWER = -UPPER
*
* Begin loop merging overlapping intervals
*
20 CONTINUE
IF( BPNT.EQ.N )
$ GO TO 30
TUPPR = ( ONE+EPS )*SVD( BPNT+1 ) + UNFLEP
IF( TUPPR.LT.LOWER )
$ GO TO 30
*
* Merge
*
BPNT = BPNT + 1
LOWER = ( ONE-EPS )*SVD( BPNT ) - UNFLEP
IF( LOWER.LE.UNFLEP )
$ LOWER = -UPPER
GO TO 20
30 CONTINUE
*
* Count singular values in interval [ LOWER, UPPER ]
*
CALL DSVDCT( N, S, E, LOWER, NUML )
CALL DSVDCT( N, S, E, UPPER, NUMU )
COUNT = NUMU - NUML
IF( LOWER.LT.ZERO )
$ COUNT = COUNT / 2
IF( COUNT.NE.BPNT-TPNT+1 ) THEN
*
* Wrong number of singular values in interval
*
INFO = TPNT
GO TO 40
END IF
TPNT = BPNT + 1
BPNT = TPNT
IF( TPNT.LE.N )
$ GO TO 10
40 CONTINUE
RETURN
*
* End of DSVDCH
*
END
SUBROUTINE DSVDCT( N, S, E, SHIFT, NUM )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER N, NUM
DOUBLE PRECISION SHIFT
* ..
* .. Array Arguments ..
DOUBLE PRECISION E( * ), S( * )
* ..
*
* Purpose
* =======
*
* DSVDCT counts the number NUM of eigenvalues of a 2*N by 2*N
* tridiagonal matrix T which are less than or equal to SHIFT. T is
* formed by putting zeros on the diagonal and making the off-diagonals
* equal to S(1), E(1), S(2), E(2), ... , E(N-1), S(N). If SHIFT is
* positive, NUM is equal to N plus the number of singular values of a
* bidiagonal matrix B less than or equal to SHIFT. Here B has diagonal
* entries S(1), ..., S(N) and superdiagonal entries E(1), ... E(N-1).
* If SHIFT is negative, NUM is equal to the number of singular values
* of B greater than or equal to -SHIFT.
*
* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
* Matrix", Report CS41, Computer Science Dept., Stanford University,
* July 21, 1966
*
* Arguments
* =========
*
* N (input) INTEGER
* The dimension of the bidiagonal matrix B.
*
* S (input) DOUBLE PRECISION array, dimension (N)
* The diagonal entries of the bidiagonal matrix B.
*
* E (input) DOUBLE PRECISION array of dimension (N-1)
* The superdiagonal entries of the bidiagonal matrix B.
*
* SHIFT (input) DOUBLE PRECISION
* The shift, used as described under Purpose.
*
* NUM (output) INTEGER
* The number of eigenvalues of T less than or equal to SHIFT.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER I
DOUBLE PRECISION M1, M2, MX, OVFL, SOV, SSHIFT, SSUN, SUN, TMP,
$ TOM, U, UNFL
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Get machine constants
*
UNFL = 2*DLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
*
* Find largest entry
*
MX = ABS( S( 1 ) )
DO 10 I = 1, N - 1
MX = MAX( MX, ABS( S( I+1 ) ), ABS( E( I ) ) )
10 CONTINUE
*
IF( MX.EQ.ZERO ) THEN
IF( SHIFT.LT.ZERO ) THEN
NUM = 0
ELSE
NUM = 2*N
END IF
RETURN
END IF
*
* Compute scale factors as in Kahan's report
*
SUN = SQRT( UNFL )
SSUN = SQRT( SUN )
SOV = SQRT( OVFL )
TOM = SSUN*SOV
IF( MX.LE.ONE ) THEN
M1 = ONE / MX
M2 = TOM
ELSE
M1 = ONE
M2 = TOM / MX
END IF
*
* Begin counting
*
U = ONE
NUM = 0
SSHIFT = ( SHIFT*M1 )*M2
U = -SSHIFT
IF( U.LE.SUN ) THEN
IF( U.LE.ZERO ) THEN
NUM = NUM + 1
IF( U.GT.-SUN )
$ U = -SUN
ELSE
U = SUN
END IF
END IF
TMP = ( S( 1 )*M1 )*M2
U = -TMP*( TMP / U ) - SSHIFT
IF( U.LE.SUN ) THEN
IF( U.LE.ZERO ) THEN
NUM = NUM + 1
IF( U.GT.-SUN )
$ U = -SUN
ELSE
U = SUN
END IF
END IF
DO 20 I = 1, N - 1
TMP = ( E( I )*M1 )*M2
U = -TMP*( TMP / U ) - SSHIFT
IF( U.LE.SUN ) THEN
IF( U.LE.ZERO ) THEN
NUM = NUM + 1
IF( U.GT.-SUN )
$ U = -SUN
ELSE
U = SUN
END IF
END IF
TMP = ( S( I+1 )*M1 )*M2
U = -TMP*( TMP / U ) - SSHIFT
IF( U.LE.SUN ) THEN
IF( U.LE.ZERO ) THEN
NUM = NUM + 1
IF( U.GT.-SUN )
$ U = -SUN
ELSE
U = SUN
END IF
END IF
20 CONTINUE
RETURN
*
* End of DSVDCT
*
END
DOUBLE PRECISION FUNCTION DSXT1( IJOB, D1, N1, D2, N2, ABSTOL,
$ ULP, UNFL )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER IJOB, N1, N2
DOUBLE PRECISION ABSTOL, ULP, UNFL
* ..
* .. Array Arguments ..
DOUBLE PRECISION D1( * ), D2( * )
* ..
*
* Purpose
* =======
*
* DSXT1 computes the difference between a set of eigenvalues.
* The result is returned as the function value.
*
* IJOB = 1: Computes max { min | D1(i)-D2(j) | }
* i j
*
* IJOB = 2: Computes max { min | D1(i)-D2(j) | /
* i j
* ( ABSTOL + |D1(i)|*ULP ) }
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* Specifies the type of tests to be performed. (See above.)
*
* D1 (input) DOUBLE PRECISION array, dimension (N1)
* The first array. D1 should be in increasing order, i.e.,
* D1(j) <= D1(j+1).
*
* N1 (input) INTEGER
* The length of D1.
*
* D2 (input) DOUBLE PRECISION array, dimension (N2)
* The second array. D2 should be in increasing order, i.e.,
* D2(j) <= D2(j+1).
*
* N2 (input) INTEGER
* The length of D2.
*
* ABSTOL (input) DOUBLE PRECISION
* The absolute tolerance, used as a measure of the error.
*
* ULP (input) DOUBLE PRECISION
* Machine precision.
*
* UNFL (input) DOUBLE PRECISION
* The smallest positive number whose reciprocal does not
* overflow.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION TEMP1, TEMP2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
TEMP1 = ZERO
*
J = 1
DO 20 I = 1, N1
10 CONTINUE
IF( D2( J ).LT.D1( I ) .AND. J.LT.N2 ) THEN
J = J + 1
GO TO 10
END IF
IF( J.EQ.1 ) THEN
TEMP2 = ABS( D2( J )-D1( I ) )
IF( IJOB.EQ.2 )
$ TEMP2 = TEMP2 / MAX( UNFL, ABSTOL+ULP*ABS( D1( I ) ) )
ELSE
TEMP2 = MIN( ABS( D2( J )-D1( I ) ),
$ ABS( D1( I )-D2( J-1 ) ) )
IF( IJOB.EQ.2 )
$ TEMP2 = TEMP2 / MAX( UNFL, ABSTOL+ULP*ABS( D1( I ) ) )
END IF
TEMP1 = MAX( TEMP1, TEMP2 )
20 CONTINUE
*
DSXT1 = TEMP1
RETURN
*
* End of DSXT1
*
END
SUBROUTINE DSYT21( ITYPE, UPLO, N, KBAND, A, LDA, D, E, U, LDU, V,
$ LDV, TAU, WORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER ITYPE, KBAND, LDA, LDU, LDV, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), RESULT( 2 ),
$ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DSYT21 generally checks a decomposition of the form
*
* A = U S U'
*
* where ' means transpose, A is symmetric, U is orthogonal, and S is
* diagonal (if KBAND=0) or symmetric tridiagonal (if KBAND=1).
*
* If ITYPE=1, then U is represented as a dense matrix; otherwise U is
* expressed as a product of Householder transformations, whose vectors
* are stored in the array "V" and whose scaling constants are in "TAU".
* We shall use the letter "V" to refer to the product of Householder
* transformations (which should be equal to U).
*
* Specifically, if ITYPE=1, then:
*
* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and*
* RESULT(2) = | I - UU' | / ( n ulp )
*
* If ITYPE=2, then:
*
* RESULT(1) = | A - V S V' | / ( |A| n ulp )
*
* If ITYPE=3, then:
*
* RESULT(1) = | I - VU' | / ( n ulp )
*
* For ITYPE > 1, the transformation U is expressed as a product
* V = H(1)...H(n-2), where H(j) = I - tau(j) v(j) v(j)' and each
* vector v(j) has its first j elements 0 and the remaining n-j elements
* stored in V(j+1:n,j).
*
* Arguments
* =========
*
* ITYPE (input) INTEGER
* Specifies the type of tests to be performed.
* 1: U expressed as a dense orthogonal matrix:
* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and*
* RESULT(2) = | I - UU' | / ( n ulp )
*
* 2: U expressed as a product V of Housholder transformations:
* RESULT(1) = | A - V S V' | / ( |A| n ulp )
*
* 3: U expressed both as a dense orthogonal matrix and
* as a product of Housholder transformations:
* RESULT(1) = | I - VU' | / ( n ulp )
*
* UPLO (input) CHARACTER
* If UPLO='U', the upper triangle of A and V will be used and
* the (strictly) lower triangle will not be referenced.
* If UPLO='L', the lower triangle of A and V will be used and
* the (strictly) upper triangle will not be referenced.
*
* N (input) INTEGER
* The size of the matrix. If it is zero, DSYT21 does nothing.
* It must be at least zero.
*
* KBAND (input) INTEGER
* The bandwidth of the matrix. It may only be zero or one.
* If zero, then S is diagonal, and E is not referenced. If
* one, then S is symmetric tri-diagonal.
*
* A (input) DOUBLE PRECISION array, dimension (LDA, N)
* The original (unfactored) matrix. It is assumed to be
* symmetric, and only the upper (UPLO='U') or only the lower
* (UPLO='L') will be referenced.
*
* LDA (input) INTEGER
* The leading dimension of A. It must be at least 1
* and at least N.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The diagonal of the (symmetric tri-) diagonal matrix.
*
* E (input) DOUBLE PRECISION array, dimension (N-1)
* The off-diagonal of the (symmetric tri-) diagonal matrix.
* E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and
* (3,2) element, etc.
* Not referenced if KBAND=0.
*
* U (input) DOUBLE PRECISION array, dimension (LDU, N)
* If ITYPE=1 or 3, this contains the orthogonal matrix in
* the decomposition, expressed as a dense matrix. If ITYPE=2,
* then it is not referenced.
*
* LDU (input) INTEGER
* The leading dimension of U. LDU must be at least N and
* at least 1.
*
* V (input) DOUBLE PRECISION array, dimension (LDV, N)
* If ITYPE=2 or 3, the columns of this array contain the
* Householder vectors used to describe the orthogonal matrix
* in the decomposition. If UPLO='L', then the vectors are in
* the lower triangle, if UPLO='U', then in the upper
* triangle.
* *NOTE* If ITYPE=2 or 3, V is modified and restored. The
* subdiagonal (if UPLO='L') or the superdiagonal (if UPLO='U')
* is set to one, and later reset to its original value, during
* the course of the calculation.
* If ITYPE=1, then it is neither referenced nor modified.
*
* LDV (input) INTEGER
* The leading dimension of V. LDV must be at least N and
* at least 1.
*
* TAU (input) DOUBLE PRECISION array, dimension (N)
* If ITYPE >= 2, then TAU(j) is the scalar factor of
* v(j) v(j)' in the Householder transformation H(j) of
* the product U = H(1)...H(n-2)
* If ITYPE < 2, then TAU is not referenced.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (2*N**2)
*
* RESULT (output) DOUBLE PRECISION array, dimension (2)
* The values computed by the two tests described above. The
* values are currently limited to 1/ulp, to avoid overflow.
* RESULT(1) is always modified. RESULT(2) is modified only
* if ITYPE=1.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TEN
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LOWER
CHARACTER CUPLO
INTEGER IINFO, J, JCOL, JR, JROW
DOUBLE PRECISION ANORM, ULP, UNFL, VSAVE, WNORM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
EXTERNAL LSAME, DLAMCH, DLANGE, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLACPY, DLARFY, DLASET, DORM2L, DORM2R,
$ DSYR, DSYR2
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
RESULT( 1 ) = ZERO
IF( ITYPE.EQ.1 )
$ RESULT( 2 ) = ZERO
IF( N.LE.0 )
$ RETURN
*
IF( LSAME( UPLO, 'U' ) ) THEN
LOWER = .FALSE.
CUPLO = 'U'
ELSE
LOWER = .TRUE.
CUPLO = 'L'
END IF
*
UNFL = DLAMCH( 'Safe minimum' )
ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
*
* Some Error Checks
*
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
RESULT( 1 ) = TEN / ULP
RETURN
END IF
*
* Do Test 1
*
* Norm of A:
*
IF( ITYPE.EQ.3 ) THEN
ANORM = ONE
ELSE
ANORM = MAX( DLANSY( '1', CUPLO, N, A, LDA, WORK ), UNFL )
END IF
*
* Compute error matrix:
*
IF( ITYPE.EQ.1 ) THEN
*
* ITYPE=1: error = A - U S U'
*
CALL DLASET( 'Full', N, N, ZERO, ZERO, WORK, N )
CALL DLACPY( CUPLO, N, N, A, LDA, WORK, N )
*
DO 10 J = 1, N
CALL DSYR( CUPLO, N, -D( J ), U( 1, J ), 1, WORK, N )
10 CONTINUE
*
IF( N.GT.1 .AND. KBAND.EQ.1 ) THEN
DO 20 J = 1, N - 1
CALL DSYR2( CUPLO, N, -E( J ), U( 1, J ), 1, U( 1, J+1 ),
$ 1, WORK, N )
20 CONTINUE
END IF
WNORM = DLANSY( '1', CUPLO, N, WORK, N, WORK( N**2+1 ) )
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* ITYPE=2: error = V S V' - A
*
CALL DLASET( 'Full', N, N, ZERO, ZERO, WORK, N )
*
IF( LOWER ) THEN
WORK( N**2 ) = D( N )
DO 40 J = N - 1, 1, -1
IF( KBAND.EQ.1 ) THEN
WORK( ( N+1 )*( J-1 )+2 ) = ( ONE-TAU( J ) )*E( J )
DO 30 JR = J + 2, N
WORK( ( J-1 )*N+JR ) = -TAU( J )*E( J )*V( JR, J )
30 CONTINUE
END IF
*
VSAVE = V( J+1, J )
V( J+1, J ) = ONE
CALL DLARFY( 'L', N-J, V( J+1, J ), 1, TAU( J ),
$ WORK( ( N+1 )*J+1 ), N, WORK( N**2+1 ) )
V( J+1, J ) = VSAVE
WORK( ( N+1 )*( J-1 )+1 ) = D( J )
40 CONTINUE
ELSE
WORK( 1 ) = D( 1 )
DO 60 J = 1, N - 1
IF( KBAND.EQ.1 ) THEN
WORK( ( N+1 )*J ) = ( ONE-TAU( J ) )*E( J )
DO 50 JR = 1, J - 1
WORK( J*N+JR ) = -TAU( J )*E( J )*V( JR, J+1 )
50 CONTINUE
END IF
*
VSAVE = V( J, J+1 )
V( J, J+1 ) = ONE
CALL DLARFY( 'U', J, V( 1, J+1 ), 1, TAU( J ), WORK, N,
$ WORK( N**2+1 ) )
V( J, J+1 ) = VSAVE
WORK( ( N+1 )*J+1 ) = D( J+1 )
60 CONTINUE
END IF
*
DO 90 JCOL = 1, N
IF( LOWER ) THEN
DO 70 JROW = JCOL, N
WORK( JROW+N*( JCOL-1 ) ) = WORK( JROW+N*( JCOL-1 ) )
$ - A( JROW, JCOL )
70 CONTINUE
ELSE
DO 80 JROW = 1, JCOL
WORK( JROW+N*( JCOL-1 ) ) = WORK( JROW+N*( JCOL-1 ) )
$ - A( JROW, JCOL )
80 CONTINUE
END IF
90 CONTINUE
WNORM = DLANSY( '1', CUPLO, N, WORK, N, WORK( N**2+1 ) )
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* ITYPE=3: error = U V' - I
*
IF( N.LT.2 )
$ RETURN
CALL DLACPY( ' ', N, N, U, LDU, WORK, N )
IF( LOWER ) THEN
CALL DORM2R( 'R', 'T', N, N-1, N-1, V( 2, 1 ), LDV, TAU,
$ WORK( N+1 ), N, WORK( N**2+1 ), IINFO )
ELSE
CALL DORM2L( 'R', 'T', N, N-1, N-1, V( 1, 2 ), LDV, TAU,
$ WORK, N, WORK( N**2+1 ), IINFO )
END IF
IF( IINFO.NE.0 ) THEN
RESULT( 1 ) = TEN / ULP
RETURN
END IF
*
DO 100 J = 1, N
WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - ONE
100 CONTINUE
*
WNORM = DLANGE( '1', N, N, WORK, N, WORK( N**2+1 ) )
END IF
*
IF( ANORM.GT.WNORM ) THEN
RESULT( 1 ) = ( WNORM / ANORM ) / ( N*ULP )
ELSE
IF( ANORM.LT.ONE ) THEN
RESULT( 1 ) = ( MIN( WNORM, N*ANORM ) / ANORM ) / ( N*ULP )
ELSE
RESULT( 1 ) = MIN( WNORM / ANORM, DBLE( N ) ) / ( N*ULP )
END IF
END IF
*
* Do Test 2
*
* Compute UU' - I
*
IF( ITYPE.EQ.1 ) THEN
CALL DGEMM( 'N', 'C', N, N, N, ONE, U, LDU, U, LDU, ZERO, WORK,
$ N )
*
DO 110 J = 1, N
WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - ONE
110 CONTINUE
*
RESULT( 2 ) = MIN( DLANGE( '1', N, N, WORK, N,
$ WORK( N**2+1 ) ), DBLE( N ) ) / ( N*ULP )
END IF
*
RETURN
*
* End of DSYT21
*
END
SUBROUTINE DSYT22( ITYPE, UPLO, N, M, KBAND, A, LDA, D, E, U, LDU,
$ V, LDV, TAU, WORK, RESULT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER ITYPE, KBAND, LDA, LDU, LDV, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), RESULT( 2 ),
$ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DSYT22 generally checks a decomposition of the form
*
* A U = U S
*
* where A is symmetric, the columns of U are orthonormal, and S
* is diagonal (if KBAND=0) or symmetric tridiagonal (if
* KBAND=1). If ITYPE=1, then U is represented as a dense matrix,
* otherwise the U is expressed as a product of Householder
* transformations, whose vectors are stored in the array "V" and
* whose scaling constants are in "TAU"; we shall use the letter
* "V" to refer to the product of Householder transformations
* (which should be equal to U).
*
* Specifically, if ITYPE=1, then:
*
* RESULT(1) = | U' A U - S | / ( |A| m ulp ) *and*
* RESULT(2) = | I - U'U | / ( m ulp )
*
* Arguments
* =========
*
* ITYPE INTEGER
* Specifies the type of tests to be performed.
* 1: U expressed as a dense orthogonal matrix:
* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and*
* RESULT(2) = | I - UU' | / ( n ulp )
*
* UPLO CHARACTER
* If UPLO='U', the upper triangle of A will be used and the
* (strictly) lower triangle will not be referenced. If
* UPLO='L', the lower triangle of A will be used and the
* (strictly) upper triangle will not be referenced.
* Not modified.
*
* N INTEGER
* The size of the matrix. If it is zero, DSYT22 does nothing.
* It must be at least zero.
* Not modified.
*
* M INTEGER
* The number of columns of U. If it is zero, DSYT22 does
* nothing. It must be at least zero.
* Not modified.
*
* KBAND INTEGER
* The bandwidth of the matrix. It may only be zero or one.
* If zero, then S is diagonal, and E is not referenced. If
* one, then S is symmetric tri-diagonal.
* Not modified.
*
* A DOUBLE PRECISION array, dimension (LDA , N)
* The original (unfactored) matrix. It is assumed to be
* symmetric, and only the upper (UPLO='U') or only the lower
* (UPLO='L') will be referenced.
* Not modified.
*
* LDA INTEGER
* The leading dimension of A. It must be at least 1
* and at least N.
* Not modified.
*
* D DOUBLE PRECISION array, dimension (N)
* The diagonal of the (symmetric tri-) diagonal matrix.
* Not modified.
*
* E DOUBLE PRECISION array, dimension (N)
* The off-diagonal of the (symmetric tri-) diagonal matrix.
* E(1) is ignored, E(2) is the (1,2) and (2,1) element, etc.
* Not referenced if KBAND=0.
* Not modified.
*
* U DOUBLE PRECISION array, dimension (LDU, N)
* If ITYPE=1 or 3, this contains the orthogonal matrix in
* the decomposition, expressed as a dense matrix. If ITYPE=2,
* then it is not referenced.
* Not modified.
*
* LDU INTEGER
* The leading dimension of U. LDU must be at least N and
* at least 1.
* Not modified.
*
* V DOUBLE PRECISION array, dimension (LDV, N)
* If ITYPE=2 or 3, the lower triangle of this array contains
* the Householder vectors used to describe the orthogonal
* matrix in the decomposition. If ITYPE=1, then it is not
* referenced.
* Not modified.
*
* LDV INTEGER
* The leading dimension of V. LDV must be at least N and
* at least 1.
* Not modified.
*
* TAU DOUBLE PRECISION array, dimension (N)
* If ITYPE >= 2, then TAU(j) is the scalar factor of
* v(j) v(j)' in the Householder transformation H(j) of
* the product U = H(1)...H(n-2)
* If ITYPE < 2, then TAU is not referenced.
* Not modified.
*
* WORK DOUBLE PRECISION array, dimension (2*N**2)
* Workspace.
* Modified.
*
* RESULT DOUBLE PRECISION array, dimension (2)
* The values computed by the two tests described above. The
* values are currently limited to 1/ulp, to avoid overflow.
* RESULT(1) is always modified. RESULT(2) is modified only
* if LDU is at least N.
* Modified.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
INTEGER J, JJ, JJ1, JJ2, NN, NNP1
DOUBLE PRECISION ANORM, ULP, UNFL, WNORM
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANSY
EXTERNAL DLAMCH, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DORT01, DSYMM
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
RESULT( 1 ) = ZERO
RESULT( 2 ) = ZERO
IF( N.LE.0 .OR. M.LE.0 )
$ RETURN
*
UNFL = DLAMCH( 'Safe minimum' )
ULP = DLAMCH( 'Precision' )
*
* Do Test 1
*
* Norm of A:
*
ANORM = MAX( DLANSY( '1', UPLO, N, A, LDA, WORK ), UNFL )
*
* Compute error matrix:
*
* ITYPE=1: error = U' A U - S
*
CALL DSYMM( 'L', UPLO, N, M, ONE, A, LDA, U, LDU, ZERO, WORK, N )
NN = N*N
NNP1 = NN + 1
CALL DGEMM( 'T', 'N', M, M, N, ONE, U, LDU, WORK, N, ZERO,
$ WORK( NNP1 ), N )
DO 10 J = 1, M
JJ = NN + ( J-1 )*N + J
WORK( JJ ) = WORK( JJ ) - D( J )
10 CONTINUE
IF( KBAND.EQ.1 .AND. N.GT.1 ) THEN
DO 20 J = 2, M
JJ1 = NN + ( J-1 )*N + J - 1
JJ2 = NN + ( J-2 )*N + J
WORK( JJ1 ) = WORK( JJ1 ) - E( J-1 )
WORK( JJ2 ) = WORK( JJ2 ) - E( J-1 )
20 CONTINUE
END IF
WNORM = DLANSY( '1', UPLO, M, WORK( NNP1 ), N, WORK( 1 ) )
*
IF( ANORM.GT.WNORM ) THEN
RESULT( 1 ) = ( WNORM / ANORM ) / ( M*ULP )
ELSE
IF( ANORM.LT.ONE ) THEN
RESULT( 1 ) = ( MIN( WNORM, M*ANORM ) / ANORM ) / ( M*ULP )
ELSE
RESULT( 1 ) = MIN( WNORM / ANORM, DBLE( M ) ) / ( M*ULP )
END IF
END IF
*
* Do Test 2
*
* Compute U'U - I
*
IF( ITYPE.EQ.1 )
$ CALL DORT01( 'Columns', N, M, U, LDU, WORK, 2*N*N,
$ RESULT( 2 ) )
*
RETURN
*
* End of DSYT22
*
END
INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3,
$ N4 )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*( * ) NAME, OPTS
INTEGER ISPEC, N1, N2, N3, N4
* ..
*
* Purpose
* =======
*
* ILAENV returns problem-dependent parameters for the local
* environment. See ISPEC for a description of the parameters.
*
* In this version, the problem-dependent parameters are contained in
* the integer array IPARMS in the common block CLAENV and the value
* with index ISPEC is copied to ILAENV. This version of ILAENV is
* to be used in conjunction with XLAENV in TESTING and TIMING.
*
* 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
* = 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 and QZ methods
* for nonsymmetric eigenvalue problems.
* = 9: maximum size of the subproblems at the bottom of the
* computation tree in the divide-and-conquer algorithm
* =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
*
* Other specifications (up to 100) can be added later.
*
* NAME (input) CHARACTER*(*)
* The name of the calling subroutine.
*
* 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.
*
* (ILAENV) (output) INTEGER
* >= 0: the value of the parameter specified by ISPEC
* < 0: if ILAENV = -k, the k-th argument had an illegal value.
*
* 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 )
*
* =====================================================================
*
* .. Intrinsic Functions ..
INTRINSIC INT, MIN, REAL
* ..
* .. External Functions ..
INTEGER IEEECK
EXTERNAL IEEECK
* ..
* .. Arrays in Common ..
INTEGER IPARMS( 100 )
* ..
* .. Common blocks ..
COMMON / CLAENV / IPARMS
* ..
* .. Save statement ..
SAVE / CLAENV /
* ..
* .. Executable Statements ..
*
IF( ISPEC.GE.1 .AND. ISPEC.LE.5 ) THEN
*
* Return a value from the common block.
*
ILAENV = IPARMS( ISPEC )
*
ELSE IF( ISPEC.EQ.6 ) THEN
*
* Compute SVD crossover point.
*
ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 )
*
ELSE IF( ISPEC.GE.7 .AND. ISPEC.LE.9 ) THEN
*
* Return a value from the common block.
*
ILAENV = IPARMS( ISPEC )
*
ELSE IF( ISPEC.EQ.10 ) THEN
*
* IEEE NaN arithmetic can be trusted not to trap
*
C ILAENV = 0
ILAENV = 1
IF( ILAENV.EQ.1 ) THEN
ILAENV = IEEECK( 0, 0.0, 1.0 )
END IF
*
ELSE IF( ISPEC.EQ.11 ) THEN
*
* Infinity arithmetic can be trusted not to trap
*
C ILAENV = 0
ILAENV = 1
IF( ILAENV.EQ.1 ) THEN
ILAENV = IEEECK( 1, 0.0, 1.0 )
END IF
*
ELSE IF(( ISPEC.GE.12 ) .AND. (ISPEC.LE.16)) THEN
*
* 12 <= ISPEC <= 16: xHSEQR or one of its subroutines.
*
ILAENV = IPARMS( ISPEC )
* WRITE(*,*) 'ISPEC = ',ISPEC,' ILAENV =',ILAENV
* ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 )
*
ELSE
*
* Invalid value for ISPEC
*
ILAENV = -1
END IF
*
RETURN
*
* End of ILAENV
*
END
INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK )
*
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 = 11, K22MIN = 14, KACMIN = 14,
$ NIBBLE = 14, KNWSWP = 500 )
REAL TWO
PARAMETER ( TWO = 2.0 )
* ..
* .. Scalar Arguments ..
INTEGER IHI, ILO, ISPEC, LWORK, N
CHARACTER NAME*( * ), OPTS*( * )
* ..
* .. 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 LAHQR, 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
SUBROUTINE XLAENV( ISPEC, NVALUE )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER ISPEC, NVALUE
* ..
*
* Purpose
* =======
*
* XLAENV sets certain machine- and problem-dependent quantities
* which will later be retrieved by ILAENV.
*
* Arguments
* =========
*
* ISPEC (input) INTEGER
* Specifies the parameter to be set in the COMMON array IPARMS.
* = 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
* = 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: another crossover point, for the multishift QR and QZ
* methods for nonsymmetric eigenvalue problems.
* = 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
*
* NVALUE (input) INTEGER
* The value of the parameter specified by ISPEC.
*
* =====================================================================
*
* .. Arrays in Common ..
INTEGER IPARMS( 100 )
* ..
* .. Common blocks ..
COMMON / CLAENV / IPARMS
* ..
* .. Save statement ..
SAVE / CLAENV /
* ..
* .. Executable Statements ..
*
IF( ISPEC.GE.1 .AND. ISPEC.LE.16 ) THEN
IPARMS( ISPEC ) = NVALUE
END IF
*
RETURN
*
* End of XLAENV
*
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/eig/sep.in 0000644 0001750 0001750 00000001355 10616163237 023110 0 ustar osallou osallou SEP: Data file for testing Symmetric Eigenvalue Problem routines
6 Number of values of N
0 1 2 3 5 20 Values of N (dimension)
5 Number of values of NB
1 3 3 3 10 Values of NB (blocksize)
2 2 2 2 2 Values of NBMIN (minimum blocksize)
1 0 5 9 1 Values of NX (crossover point)
50.0 Threshold value
T Put T to test the LAPACK routines
T Put T to test the driver routines
T Put T to test the error exits
1 Code to interpret the seed
SEP 21
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/eig/dbal.in 0000644 0001750 0001750 00000024470 10616163234 023223 0 ustar osallou osallou DBL: Tests DGEBAL
5
0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.3000D+01 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.4000D+01 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.5000D+01
1 1
0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.3000D+01 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.4000D+01 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.5000D+01
0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01
5
0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.1000D+01 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00
0.1000D+01 0.2000D+01 0.3000D+01 0.0000D+00 0.0000D+00
0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.0000D+00
0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01
1 1
0.5000D+01 0.4000D+01 0.3000D+01 0.2000D+01 0.1000D+01
0.0000D+00 0.4000D+01 0.3000D+01 0.2000D+01 0.1000D+01
0.0000D+00 0.0000D+00 0.3000D+01 0.2000D+01 0.1000D+01
0.0000D+00 0.0000D+00 0.0000D+00 0.2000D+01 0.1000D+01
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
0.1000D+01 0.2000D+01 0.3000D+01 0.2000D+01 0.1000D+01
5
0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.1000D+01 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.1000D+01 0.1000D+01 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01
1 1
0.1000D+01 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.1000D+01 0.1000D+01 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
0.1000D+01 0.2000D+01 0.3000D+01 0.2000D+01 0.1000D+01
4
0.0000D+00 0.2000D+01 0.1000D+00 0.0000D+00
0.2000D+01 0.0000D+00 0.0000D+00 0.1000D+00
0.1000D+03 0.0000D+00 0.0000D+00 0.2000D+01
0.0000D+00 0.1000D+03 0.2000D+01 0.0000D+00
1 4
0.0000D-03 2.0000D+00 3.2000D+00 0.0000D-03
2.0000D+00 0.0000D-03 0.0000D-03 3.2000D+00
3.1250D+00 0.0000D-03 0.0000D-03 2.0000D+00
0.0000D-03 3.1250D+00 2.0000D+00 0.0000D-03
62.5000D-03 62.5000D-03 2.0000D+00 2.0000D+00
6
0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1024D+04
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1280D+03
0.0000D+00 0.2000D+01 0.3000D+04 0.0000D+00 0.0000D+00 0.2000D+01
0.1280D+03 0.4000D+01 0.4000D-02 0.5000D+01 0.6000D+03 0.8000D+01
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.2000D-02 0.2000D+01
0.8000D+01 0.8192D+04 0.0000D+00 0.0000D+00 0.0000D+00 0.2000D+01
4 6
0.5000D+01 0.4000D-02 0.6000D+03 0.1024D+04 0.5000D+00 0.8000D+01
0.0000D+00 0.3000D+04 0.0000D+00 0.0000D+00 0.2500D+00 0.2000D+01
0.0000D+00 0.0000D+00 0.2000D-02 0.0000D+00 0.0000D+00 0.2000D+01
0.0000D+00 0.0000D+00 0.0000D+00 0.2000D+01 0.0000D+00 0.1280D+03
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1024D+04
0.0000D+00 0.0000D+00 0.0000D+00 0.6400D+02 0.1024D+04 0.2000D+01
0.4000D+01 0.3000D+01 0.5000D+01 0.8000D+01 0.1250D+00 0.1000D+01
5
0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.8000D+01
0.0000D+00 0.2000D+01 0.8192D+04 0.2000D+01 0.4000D+01
0.2500D-03 0.1250D-03 0.4000D+01 0.0000D+00 0.6400D+02
0.0000D+00 0.2000D+01 0.1024D+04 0.4000D+01 0.8000D+01
0.0000D+00 0.8192D+04 0.0000D+00 0.0000D+00 0.8000D+01
1 5
1.0000D+00 0.0000D-03 0.0000D-03 0.0000D-03 250.0000D-03
0.0000D-03 2.0000D+00 1.0240D+03 16.0000D+00 16.0000D+00
256.0000D-03 1.0000D-03 4.0000D+00 0.0000D-03 2.0480D+03
0.0000D-03 250.0000D-03 16.0000D+00 4.0000D+00 4.0000D+00
0.0000D-03 2.0480D+03 0.0000D-03 0.0000D-03 8.0000D+00
64.0000D+00 500.0000D-03 62.5000D-03 4.0000D+00 2.0000D+00
4
0.1000D+01 0.1000D+07 0.1000D+07 0.1000D+07
-0.2000D+07 0.3000D+01 0.2000D-05 0.3000D-05
-0.3000D+07 0.0000D+00 0.1000D-05 0.2000D+01
0.1000D+07 0.0000D+00 0.3000D-05 0.4000D+07
1 4
1.0000D+00 1.0000D+06 2.0000D+06 1.0000D+06
-2.0000D+06 3.0000D+00 4.0000D-06 3.0000D-06
-1.5000D+06 0.0000D-03 1.0000D-06 1.0000D+00
1.0000D+06 0.0000D-03 6.0000D-06 4.0000D+06
1.0000D+00 1.0000D+00 2.0000D+00 1.0000D+00
4
0.1000D+01 0.1000D+05 0.1000D+05 0.1000D+05
-0.2000D+05 0.3000D+01 0.2000D-02 0.3000D-02
0.0000D+00 0.2000D+01 0.0000D+00 -0.3000D+05
0.0000D+00 0.0000D+00 0.1000D+05 0.0000D+00
1 4
1.0000D+00 10.0000D+03 10.0000D+03 5.0000D+03
-20.0000D+03 3.0000D+00 2.0000D-03 1.5000D-03
0.0000D-03 2.0000D+00 0.0000D-03 -15.0000D+03
0.0000D-03 0.0000D-03 20.0000D+03 0.0000D-03
1.0000D+00 1.0000D+00 1.0000D+00 500.0000D-03
5
0.1000D+01 0.5120D+03 0.4096D+04 3.2768D+04 2.62144D+05
0.8000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.8000D+01 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.8000D+01 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.8000D+01 0.0000D+00
1 5
1.0000D+00 32.0000D+00 32.0000D+00 32.0000D+000 32.0000D+00
128.0000D+00 0.0000D-03 0.0000D-03 0.0000D-003 0.0000D-03
0.0000D-03 64.0000D+00 0.0000D-03 0.0000D-003 0.0000D-03
0.0000D-03 0.0000D-03 64.0000D+00 0.0000D-003 0.0000D-03
0.0000D-03 0.0000D-03 0.0000D-03 64.0000D+000 0.0000D-03
256.0000D+00 16.0000D+00 2.0000D+00 250.0000D-03 31.2500D-03
6
0.1000D+01 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00
0.1000D+01 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
2 5
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
0.3000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.4000D+01
7
0.6000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00
0.0000D+00 0.4000D+01 0.0000D+00 0.2500D-03 0.1250D-01 0.2000D-01 0.1250D+00
0.1000D+01 0.1280D+03 0.6400D+02 0.0000D+00 0.0000D+00 -0.2000D+01 0.1600D+02
0.0000D+00 1.6384D+04 0.0000D+00 0.1000D+01 -0.4000D+03 0.2560D+03 -0.4000D+04
-0.2000D+01 -0.2560D+03 0.0000D+00 0.1250D-01 0.2000D+01 0.2000D+01 0.3200D+02
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.8000D+01 0.0000D+00 0.4000D-02 0.1250D+00 -0.2000D+00 0.3000D+01
2 5
6.4000D+01 2.5000D-01 5.00000D-01 0.0000D+00 0.0000D+00 1.0000D+00 -2.0000D+00
0.0000D+00 4.0000D+00 2.00000D+00 4.0960D+00 1.6000D+00 0.0000D+00 1.0240D+01
0.0000D+00 5.0000D-01 3.00000D+00 4.0960D+00 1.0000D+00 0.0000D+00 -6.4000D+00
0.0000D+00 1.0000D+00 -3.90625D+00 1.0000D+00 -3.1250D+00 0.0000D+00 8.0000D+00
0.0000D+00 -2.0000D+00 4.00000D+00 1.6000D+00 2.0000D+00 -8.0000D+00 8.0000D+00
0.0000D+00 0.0000D+00 0.00000D+00 0.0000D+00 0.0000D+00 6.0000D+00 1.0000D+00
0.0000D+00 0.0000D+00 0.00000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
3.0000D+00 1.953125D-03 3.1250D-02 3.2000D+01 2.5000D-01 1.0000D+00 6.0000D+00
5
0.1000D+04 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+06
0.9000D+01 0.0000D+00 0.2000D-03 0.1000D+01 0.3000D+01
0.0000D+00 -0.3000D+03 0.2000D+01 0.1000D+01 0.1000D+01
0.9000D+01 0.2000D-02 0.1000D+01 0.1000D+01 -0.1000D+04
0.6000D+01 0.2000D+03 0.1000D+01 0.6000D+03 0.3000D+01
1 5
1.0000D+03 3.1250D-02 3.7500D-01 6.2500D-02 3.90625D+03
5.7600D+02 0.0000D+00 1.6000D-03 1.0000D+00 1.5000D+00
0.0000D+00 -3.7500D+01 2.0000D+00 1.2500D-01 6.2500D-02
5.7600D+02 2.0000D-03 8.0000D+00 1.0000D+00 -5.0000D+02
7.6800D+02 4.0000D+02 1.6000D+01 1.2000D+03 3.0000D+00
1.2800D+02 2.0000D+00 1.6000D+01 2.0000D+00 1.0000D+00
6
1.0000D+00 1.0000D+120 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
1.0000D-120 1.0000D+00 1.0000D+120 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 1.0000D-120 1.0000D+00 1.0000D+120 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 1.0000D-120 1.0000D+00 1.0000D+120 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 1.0000D-120 1.0000D+00 1.0000D+120
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D-120 1.0000D+00
1 6
1.000000000000000000D+00 6.344854593289122931D+03 0.000000000000000000D+00 0.000000000000000000D+00 0.000000000000000000D+00 0.000000000000000000D+00
1.576080247855779135D-04 1.000000000000000000D+00 6.344854593289122931D+03 0.000000000000000000D+00 0.000000000000000000D+00 0.000000000000000000D+00
0.000000000000000000D+00 1.576080247855779135D-04 1.000000000000000000D+00 3.172427296644561466D+03 0.000000000000000000D+00 0.000000000000000000D+00
0.000000000000000000D+00 0.000000000000000000D+00 3.152160495711558270D-04 1.000000000000000000D+00 1.586213648322280733D+03 0.000000000000000000D+00
0.000000000000000000D+00 0.000000000000000000D+00 0.000000000000000000D+00 6.304320991423116539D-04 1.000000000000000000D+00 1.586213648322280733D+03
0.000000000000000000D+00 0.000000000000000000D+00 0.000000000000000000D+00 0.000000000000000000D+00 6.304320991423116539D-04 1.000000000000000000D+00
2.494800386918399765D+291 1.582914569427869018D+175 1.004336277661868922D+59 3.186183822264904554D-58 5.053968264940243633D-175 8.016673440035891112D-292
0
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/eig/gqr.in 0000644 0001750 0001750 00000000762 10616163237 023113 0 ustar osallou osallou GQR: Data file for testing Generalized QR and RQ routines
3 Number of values of M, P and N
0 3 10 Values of M
0 5 20 Values of P
0 3 30 Values of N
20.0 Threshold value of test ratio
T Put T to test the error exits
1 Code to interpret the seed
GQR 8 List types on next line if 0 < NTYPES < 8
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/eig/lse.in 0000644 0001750 0001750 00000001001 10616163237 023070 0 ustar osallou osallou LSE: Data file for testing Constrained Linear Least Squares routines
6 Number of values of M, P, and N
6 0 5 8 10 30 Values of M
0 5 5 5 8 20 Values of P
5 5 6 8 12 40 Values of N, note P<= N <= P+M
20.0 Threshold value of test ratio
T Put T to test the error exits
1 Code to interpret the seed
LSE 8 List types on next line if 0 < NTYPES < 8
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/eig/ded.in 0000644 0001750 0001750 00000136175 10616163234 023063 0 ustar osallou osallou DEV Data file for Real Nonsymmetric Eigenvalue Driver
6 Number of matrix dimensions
0 1 2 3 5 10 20 Matrix dimensions
3 3 1 11 4 8 2 0 Parameters NB, NBMIN, NXOVER, INMIN, INWIN, INIBL, ISHFTS, IACC22
20.0 Threshold for test ratios
T
2 Read another line with random number generator seed
2518 3899 995 397 Seed for random number generator
DEV 21 Use all matrix types
DES Data file for Real Nonsymmetric Schur Form Driver
6 Number of matrix dimensions
0 1 2 3 5 10 20 Matrix dimensions
3 3 1 11 4 8 2 0 Parameters NB, NBMIN, NXOVER, INMIN, INWIN, INIBL, ISHFTS, IACC22
20.0 Threshold for test ratios
T
2 Read another line with random number generator seed
2518 3899 995 397 Seed for random number generator
DES 21 Use all matrix types
DVX Data file for Real Nonsymmetric Eigenvalue Expert Driver
6 Number of matrix dimensions
0 1 2 3 5 10 20 Matrix dimensions
3 3 1 11 4 8 2 0 Parameters NB, NBMIN, NXOVER, INMIN, INWIN, INIBL, ISHFTS, IACC22
20.0 Threshold for test ratios
T
2 Read another line with random number generator seed
2518 3899 995 397 Seed for random number generator
DVX 21 Use all matrix types
1
0.0000D+00
0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
1
1.0000D+00
1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
2
0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
2
3.0000D+00 2.0000D+00
2.0000D+00 3.0000D+00
1.0000D+00 0.0000D+00 1.0000D+00 4.0000D+00
5.0000D+00 0.0000D+00 1.0000D+00 4.0000D+00
2
3.0000D+00 -2.0000D+00
2.0000D+00 3.0000D+00
3.0000D+00 2.0000D+00 1.0000D+00 4.0000D+00
3.0000D+00 -2.0000D+00 1.0000D+00 4.0000D+00
6
1.0000D-07 -1.0000D-07 1.0000D+00 1.1000D+00 2.3000D+00 3.7000D+00
3.0000D-07 1.0000D-07 1.0000D+00 1.0000D+00 -1.3000D+00 -7.7000D+00
0.0000D+00 0.0000D+00 3.0000D-07 1.0000D-07 2.2000D+00 3.3000D+00
0.0000D+00 0.0000D+00 -1.0000D-07 3.0000D-07 1.8000D+00 1.6000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 4.0000D-06 5.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 3.0000D+00 4.0000D-06
-3.8730D+00 0.0000D+00 6.9855D-01 2.2823D+00
1.0000D-07 1.7321D-07 9.7611D-08 5.0060D-14
1.0000D-07 -1.7321D-07 9.7611D-08 5.0060D-14
3.0000D-07 1.0000D-07 1.0000D-07 9.4094D-14
3.0000D-07 -1.0000D-07 1.0000D-07 9.4094D-14
3.8730D+00 0.0000D+00 4.0659D-01 1.5283D+00
4
7.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
-1.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
-1.0000D+00 1.0000D+00 5.0000D+00 -3.0000D+00
1.0000D+00 -1.0000D+00 3.0000D+00 3.0000D+00
3.9603D+00 4.0425D-02 1.1244D-05 3.1179D-05
3.9603D+00 -4.0425D-02 1.1244D-05 3.1179D-05
4.0397D+00 3.8854D-02 1.0807D-05 2.9981D-05
4.0397D+00 -3.8854D-02 1.0807D-05 2.9981D-05
5
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
0.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
0.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
0.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
0.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
5
1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
1.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
1.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
1.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
1.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
1.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
6
1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
6
1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
6
1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 2.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 3.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 4.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 5.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 6.0000D+00
1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
2.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
3.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
4.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
5.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
6.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
4
9.4480D-01 6.7670D-01 6.9080D-01 5.9650D-01
5.8760D-01 8.6420D-01 6.7690D-01 7.2600D-02
7.2560D-01 1.9430D-01 9.6870D-01 2.8310D-01
2.8490D-01 5.8000D-02 4.8450D-01 7.3610D-01
2.4326D-01 2.1409D-01 8.7105D-01 3.5073D-01
2.4326D-01 -2.1409D-01 8.7105D-01 3.5073D-01
7.4091D-01 0.0000D+00 9.8194D-01 4.6989D-01
2.2864D+00 0.0000D+00 9.7723D-01 1.5455D+00
6
5.0410D-01 6.6520D-01 7.7190D-01 6.3870D-01 5.9550D-01 6.1310D-01
1.5740D-01 3.7340D-01 5.9840D-01 1.5470D-01 9.4270D-01 6.5900D-02
4.4170D-01 7.2300D-02 1.5440D-01 5.4920D-01 8.7000D-03 3.0040D-01
2.0080D-01 6.0800D-01 3.0340D-01 8.4390D-01 2.3900D-01 5.7680D-01
9.3610D-01 7.4130D-01 1.4440D-01 1.7860D-01 1.4280D-01 7.2630D-01
5.5990D-01 9.3360D-01 7.8000D-02 4.0930D-01 6.7140D-01 5.6170D-01
-5.2278D-01 0.0000D+00 2.7888D-01 1.1793D-01
-3.5380D-01 0.0000D+00 3.5427D-01 6.8911D-02
-8.0876D-03 0.0000D+00 3.4558D-01 1.3489D-01
3.4760D-01 3.0525D-01 5.4661D-01 1.7729D-01
3.4760D-01 -3.0525D-01 5.4661D-01 1.7729D-01
2.7698D+00 0.0000D+00 9.6635D-01 1.8270D+00
5
2.0000D-03 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 1.0000D-03 1.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 -1.0000D-03 1.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 -2.0000D-03 1.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
-2.0000D-03 0.0000D+00 2.4000D-11 2.3952D-11
-1.0000D-03 0.0000D+00 6.0000D-12 5.9940D-12
0.0000D+00 0.0000D+00 4.0000D-12 3.9920D-12
1.0000D-03 0.0000D+00 6.0000D-12 5.9940D-12
2.0000D-03 0.0000D+00 2.4000D-11 2.3952D-11
10
4.8630D-01 9.1260D-01 2.1900D-02 6.0110D-01 1.4050D-01 2.0840D-01
8.2640D-01 8.4410D-01 3.1420D-01 8.6750D-01
7.1500D-01 2.6480D-01 8.8510D-01 2.6150D-01 5.9520D-01 4.7800D-01
7.6730D-01 4.6110D-01 5.7320D-01 7.7000D-03
2.1210D-01 5.5080D-01 5.2350D-01 3.0810D-01 6.6020D-01 2.8900D-01
2.3140D-01 2.2790D-01 9.6600D-02 1.0910D-01
7.1510D-01 8.5790D-01 5.7710D-01 5.1140D-01 1.9010D-01 9.0810D-01
6.0090D-01 7.1980D-01 1.0640D-01 8.6840D-01
5.6800D-01 2.8100D-02 4.0140D-01 6.3150D-01 1.1480D-01 7.5800D-02
9.4230D-01 7.2030D-01 3.6850D-01 1.7430D-01
7.7210D-01 3.0280D-01 5.5640D-01 9.9980D-01 3.6520D-01 5.2580D-01
3.7030D-01 6.7790D-01 9.9350D-01 5.0270D-01
7.3960D-01 4.5600D-02 7.4740D-01 9.2880D-01 2.2000D-03 8.2600D-02
3.6340D-01 4.9120D-01 9.4050D-01 3.8910D-01
5.6370D-01 8.5540D-01 3.2100D-02 2.6380D-01 3.6090D-01 6.4970D-01
8.4690D-01 9.3500D-01 3.7000D-02 2.9170D-01
8.6560D-01 6.3270D-01 3.5620D-01 6.3560D-01 2.7360D-01 6.5120D-01
1.0220D-01 2.8880D-01 5.7620D-01 4.0790D-01
5.3320D-01 4.1210D-01 7.2870D-01 2.3110D-01 6.8300D-01 7.3860D-01
8.1800D-01 9.8150D-01 8.0550D-01 2.5660D-01
-4.6121D-01 7.2657D-01 4.7781D-01 1.5842D-01
-4.6121D-01 -7.2657D-01 4.7781D-01 1.5842D-01
-4.5164D-01 0.0000D+00 4.6034D-01 1.9931D-01
-1.4922D-01 4.8255D-01 4.7500D-01 9.1686D-02
-1.4922D-01 -4.8255D-01 4.7500D-01 9.1686D-02
3.3062D-02 0.0000D+00 2.9729D-01 8.2469D-02
3.0849D-01 1.1953D-01 4.2947D-01 3.9688D-02
3.0849D-01 -1.1953D-01 4.2947D-01 3.9688D-02
5.4509D-01 0.0000D+00 7.0777D-01 1.5033D-01
5.0352D+00 0.0000D+00 9.7257D-01 3.5548D+00
4
-3.8730D-01 3.6560D-01 3.1200D-02 -5.8340D-01
5.5230D-01 -1.1854D+00 9.8330D-01 7.6670D-01
1.6746D+00 -1.9900D-02 -1.8293D+00 5.7180D-01
-5.2500D-01 3.5340D-01 -2.7210D-01 -8.8300D-02
-1.8952D+00 7.5059D-01 8.1913D-01 7.7090D-01
-1.8952D+00 -7.5059D-01 8.1913D-01 7.7090D-01
-9.5162D-02 0.0000D+00 8.0499D-01 4.9037D-01
3.9520D-01 0.0000D+00 9.8222D-01 4.9037D-01
6
-1.0777D+00 1.7027D+00 2.6510D-01 8.5160D-01 1.0121D+00 2.5710D-01
-1.3400D-02 3.9030D-01 -1.2680D+00 2.7530D-01 -3.2350D-01 -1.3844D+00
1.5230D-01 3.0680D-01 8.7330D-01 -3.3410D-01 -4.8310D-01 -1.5416D+00
1.4470D-01 -6.0570D-01 3.1900D-02 -1.0905D+00 -8.3700D-02 6.2410D-01
-7.6510D-01 -1.7889D+00 -1.5069D+00 -6.0210D-01 5.2170D-01 6.4700D-01
8.1940D-01 2.1100D-01 5.4320D-01 7.5610D-01 1.7130D-01 5.5400D-01
-1.7029D+00 0.0000D+00 6.7909D-01 6.7220D-01
-1.0307D+00 0.0000D+00 7.2671D-01 2.0436D-01
2.8487D-01 1.2101D+00 3.9757D-01 4.9797D-01
2.8487D-01 -1.2101D+00 3.9757D-01 4.9797D-01
1.1675D+00 4.6631D-01 4.2334D-01 1.9048D-01
1.1675D+00 -4.6631D-01 4.2334D-01 1.9048D-01
10
-1.0639D+00 1.6120D-01 1.5620D-01 3.4360D-01 -6.7480D-01 1.6598D+00
6.4650D-01 -7.8630D-01 -2.6100D-01 7.0190D-01
-8.4400D-01 -2.2439D+00 1.8800D+00 -1.0005D+00 7.4500D-02 -1.6156D+00
2.8220D-01 8.5600D-01 1.3497D+00 -1.5883D+00
1.5988D+00 1.1758D+00 1.2398D+00 1.1173D+00 2.1500D-01 4.3140D-01
1.8500D-01 7.9470D-01 6.6260D-01 8.6460D-01
-2.2960D-01 1.2442D+00 2.3242D+00 -5.0690D-01 -7.5160D-01 -5.4370D-01
-2.5990D-01 1.2830D+00 -1.1067D+00 -1.1150D-01
-3.6040D-01 4.0420D-01 6.1240D-01 -1.2164D+00 -9.4650D-01 -3.1460D-01
1.8310D-01 7.3710D-01 1.4278D+00 2.9220D-01
4.6150D-01 3.8740D-01 -4.2900D-02 -9.3600D-01 7.1160D-01 -8.2590D-01
-1.7640D+00 -9.4660D-01 1.8202D+00 -2.5480D-01
1.2934D+00 -9.7550D-01 6.7480D-01 -1.0481D+00 -1.8442D+00 -5.4600D-02
7.4050D-01 6.1000D-03 1.2430D+00 -1.8490D-01
-3.4710D-01 -9.5800D-01 1.6530D-01 9.1300D-02 -5.2010D-01 -1.1832D+00
8.5410D-01 -2.3200D-01 -1.6155D+00 5.5180D-01
1.0190D+00 -6.8240D-01 8.0850D-01 2.5950D-01 -3.7580D-01 -1.8825D+00
1.6473D+00 -6.5920D-01 8.0250D-01 -4.9000D-03
1.2670D+00 -4.2400D-02 8.9570D-01 -1.6770D-01 1.4620D-01 9.8800D-01
-2.3170D-01 -1.4483D+00 -5.8200D-02 1.9700D-02
-2.6992D+00 9.0387D-01 6.4005D-01 4.1615D-01
-2.6992D+00 -9.0387D-01 6.4005D-01 4.1615D-01
-2.4366D+00 0.0000D+00 6.9083D-01 2.5476D-01
-1.2882D+00 8.8930D-01 5.3435D-01 6.0878D-01
-1.2882D+00 -8.8930D-01 5.3435D-01 6.0878D-01
9.0275D-01 0.0000D+00 2.9802D-01 4.7530D-01
9.0442D-01 2.5661D+00 7.3193D-01 6.2016D-01
9.0442D-01 -2.5661D+00 7.3193D-01 6.2016D-01
1.6774D+00 0.0000D+00 3.0743D-01 4.1726D-01
3.0060D+00 0.0000D+00 8.5623D-01 4.3175D-01
4
-1.2298D+00 -2.3142D+00 -6.9800D-02 1.0523D+00
2.0390D-01 -1.2298D+00 8.0500D-02 9.7860D-01
0.0000D+00 0.0000D+00 2.5600D-01 -8.9100D-01
0.0000D+00 0.0000D+00 2.7480D-01 2.5600D-01
-1.2298D+00 6.8692D-01 4.7136D-01 7.1772D-01
-1.2298D+00 -6.8692D-01 4.7136D-01 7.1772D-01
2.5600D-01 4.9482D-01 8.0960D-01 5.1408D-01
2.5600D-01 -4.9482D-01 8.0960D-01 5.1408D-01
6
5.9930D-01 1.9372D+00 -1.6160D-01 -1.4602D+00 6.0180D-01 2.7120D+00
-2.2049D+00 5.9930D-01 -1.0679D+00 1.9405D+00 -1.4400D+00 -2.2110D-01
0.0000D+00 0.0000D+00 -2.4567D+00 -6.8650D-01 -1.9101D+00 6.4960D-01
0.0000D+00 0.0000D+00 0.0000D+00 7.3620D-01 3.9700D-01 -1.5190D-01
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 -1.0034D+00 1.1954D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 -1.3400D-01 -1.0034D+00
-2.4567D+00 0.0000D+00 4.7091D-01 8.5788D-01
-1.0034D+00 4.0023D-01 3.6889D-01 1.8909D-01
-1.0034D+00 -4.0023D-01 3.6889D-01 1.8909D-01
5.9930D-01 2.0667D+00 5.8849D-01 1.3299D+00
5.9930D-01 -2.0667D+00 5.8849D-01 1.3299D+00
7.3620D-01 0.0000D+00 6.0845D-01 9.6725D-01
4
1.0000D-04 1.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 -1.0000D-04 1.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 1.0000D-02 1.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 -5.0000D-03
-5.0000D-03 0.0000D+00 3.7485D-07 3.6932D-07
-1.0000D-04 0.0000D+00 9.8979D-09 9.8493D-09
1.0000D-04 0.0000D+00 1.0098D-08 1.0046D-08
1.0000D-02 0.0000D+00 1.4996D-06 1.4773D-06
3
2.0000D-06 1.0000D+00 -2.0000D+00
1.0000D-06 -2.0000D+00 4.0000D+00
0.0000D+00 1.0000D+00 -2.0000D+00
-4.0000D+00 0.0000D+00 7.3030D-01 4.0000D+00
0.0000D+00 0.0000D+00 7.2801D-01 1.3726D-06
2.2096D-06 0.0000D+00 8.2763D-01 2.2096D-06
6
2.4080D-01 6.5530D-01 9.1660D-01 5.0300D-02 2.8490D-01 2.4080D-01
6.9070D-01 9.7000D-01 1.4020D-01 5.7820D-01 6.7670D-01 6.9070D-01
1.0620D-01 3.8000D-02 7.0540D-01 2.4320D-01 8.6420D-01 1.0620D-01
2.6400D-01 9.8800D-02 1.7800D-02 9.4480D-01 1.9430D-01 2.6400D-01
7.0340D-01 2.5600D-01 2.6110D-01 5.8760D-01 5.8000D-02 7.0340D-01
4.0210D-01 5.5980D-01 1.3580D-01 7.2560D-01 6.9080D-01 4.0210D-01
-3.4008D-01 3.2133D-01 5.7839D-01 2.0310D-01
-3.4008D-01 -3.2133D-01 5.7839D-01 2.0310D-01
-1.6998D-07 0.0000D+00 4.9641D-01 2.1574D-01
7.2311D-01 5.9389D-02 7.0039D-01 4.1945D-02
7.2311D-01 -5.9389D-02 7.0039D-01 4.1945D-02
2.5551D+00 0.0000D+00 9.2518D-01 1.7390D+00
6
3.4800D+00 -2.9900D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
-4.9000D-01 2.4800D+00 -1.9900D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 -4.9000D-01 1.4800D+00 -9.9000D-01 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 -9.9000D-01 1.4800D+00 -4.9000D-01 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 -1.9900D+00 2.4800D+00 -4.9000D-01
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 -2.9900D+00 3.4800D+00
1.3034D-02 0.0000D+00 7.5301D-01 6.0533D-01
1.1294D+00 0.0000D+00 6.0479D-01 2.8613D-01
2.0644D+00 0.0000D+00 5.4665D-01 1.7376D-01
2.8388D+00 0.0000D+00 4.2771D-01 3.0915D-01
4.3726D+00 0.0000D+00 6.6370D-01 7.6443D-02
4.4618D+00 0.0000D+00 5.7388D-01 8.9227D-02
6
0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
1.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00
-1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
-1.7321D+00 0.0000D+00 8.6603D-01 7.2597D-01
-1.0000D+00 0.0000D+00 5.0000D-01 2.6417D-01
0.0000D+00 0.0000D+00 2.9582D-31 1.4600D-07
0.0000D+00 0.0000D+00 2.9582D-31 6.2446D-08
1.0000D+00 0.0000D+00 5.0000D-01 2.6417D-01
1.7321D+00 0.0000D+00 8.6603D-01 3.7896D-01
6
3.5345D-01 9.3023D-01 7.4679D-02 -1.0059D-02 4.6698D-02 -4.3480D-02
9.3545D-01 -3.5147D-01 -2.8216D-02 3.8008D-03 -1.7644D-02 1.6428D-02
0.0000D+00 -1.0555D-01 7.5211D-01 -1.0131D-01 4.7030D-01 -4.3789D-01
0.0000D+00 0.0000D+00 6.5419D-01 1.1779D-01 -5.4678D-01 5.0911D-01
0.0000D+00 0.0000D+00 0.0000D+00 -9.8780D-01 -1.1398D-01 1.0612D-01
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 6.8144D-01 7.3187D-01
-9.9980D-01 1.9645D-02 1.0000D+00 3.9290D-02
-9.9980D-01 -1.9645D-02 1.0000D+00 3.9290D-02
7.4539D-01 6.6663D-01 1.0000D+00 5.2120D-01
7.4539D-01 -6.6663D-01 1.0000D+00 5.2120D-01
9.9929D-01 3.7545D-02 1.0000D+00 7.5089D-02
9.9929D-01 -3.7545D-02 1.0000D+00 7.5089D-02
6
1.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
5.0000D-01 3.3330D-01 2.5000D-01 2.0000D-01 1.6670D-01 1.4290D-01
3.3330D-01 2.5000D-01 2.0000D-01 1.6670D-01 1.4290D-01 1.2500D-01
2.5000D-01 2.0000D-01 1.6670D-01 1.4290D-01 1.2500D-01 1.1110D-01
2.0000D-01 1.6670D-01 1.4290D-01 1.2500D-01 1.1110D-01 1.0000D-01
1.6670D-01 1.4290D-01 1.2500D-01 1.1110D-01 1.0000D-01 9.0900D-02
-2.2135D-01 0.0000D+00 4.0841D-01 1.6605D-01
-3.1956D-02 0.0000D+00 3.7927D-01 3.0531D-02
-8.5031D-04 0.0000D+00 6.2793D-01 7.8195D-04
-5.8584D-05 0.0000D+00 8.1156D-01 7.2478D-05
1.3895D-05 0.0000D+00 9.7087D-01 7.2478D-05
2.1324D+00 0.0000D+00 8.4325D-01 1.8048D+00
12
1.2000D+01 1.1000D+01 1.0000D+01 9.0000D+00 8.0000D+00 7.0000D+00
6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
1.1000D+01 1.1000D+01 1.0000D+01 9.0000D+00 8.0000D+00 7.0000D+00
6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
0.0000D+00 1.0000D+01 1.0000D+01 9.0000D+00 8.0000D+00 7.0000D+00
6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
0.0000D+00 0.0000D+00 9.0000D+00 9.0000D+00 8.0000D+00 7.0000D+00
6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 8.0000D+00 8.0000D+00 7.0000D+00
6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 7.0000D+00 7.0000D+00
6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 6.0000D+00
6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
5.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 4.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 3.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 2.0000D+00 2.0000D+00 1.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
-2.8234D-02 0.0000D+00 2.8690D-06 3.2094D-06
7.2587D-02 9.0746D-02 1.5885D-06 9.9934D-07
7.2587D-02 -9.0746D-02 1.5885D-06 9.9934D-07
1.8533D-01 0.0000D+00 6.5757D-07 7.8673D-07
2.8828D-01 0.0000D+00 1.8324D-06 2.0796D-06
6.4315D-01 0.0000D+00 6.8640D-05 6.1058D-05
1.5539D+00 0.0000D+00 4.6255D-03 6.4028D-03
3.5119D+00 0.0000D+00 1.4447D-01 1.9470D-01
6.9615D+00 0.0000D+00 5.8447D-01 1.2016D+00
1.2311D+01 0.0000D+00 3.1823D-01 1.4273D+00
2.0199D+01 0.0000D+00 2.0079D-01 2.4358D+00
3.2229D+01 0.0000D+00 3.0424D-01 5.6865D+00
6
0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
5.0000D+00 0.0000D+00 2.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 4.0000D+00 0.0000D+00 3.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 3.0000D+00 0.0000D+00 4.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 2.0000D+00 0.0000D+00 5.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
-5.0000D+00 0.0000D+00 8.2295D-01 1.2318D+00
-3.0000D+00 0.0000D+00 7.2281D-01 7.5970D-01
-1.0000D+00 0.0000D+00 6.2854D-01 6.9666D-01
1.0000D+00 0.0000D+00 6.2854D-01 6.9666D-01
3.0000D+00 0.0000D+00 7.2281D-01 7.5970D-01
5.0000D+00 0.0000D+00 8.2295D-01 1.2318D+00
6
1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
-1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
-1.0000D+00 -1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
-1.0000D+00 -1.0000D+00 -1.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00
-1.0000D+00 -1.0000D+00 -1.0000D+00 -1.0000D+00 1.0000D+00 1.0000D+00
-1.0000D+00 -1.0000D+00 -1.0000D+00 -1.0000D+00 -1.0000D+00 1.0000D+00
8.0298D-02 2.4187D+00 8.9968D-01 1.5236D+00
8.0298D-02 -2.4187D+00 8.9968D-01 1.5236D+00
1.4415D+00 6.2850D-01 9.6734D-01 4.2793D-01
1.4415D+00 -6.2850D-01 9.6734D-01 4.2793D-01
1.4782D+00 1.5638D-01 9.7605D-01 2.2005D-01
1.4782D+00 -1.5638D-01 9.7605D-01 2.2005D-01
6
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
0.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00
1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00
0.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
-3.5343D-02 7.4812D-01 3.9345D-01 1.8415D-01
-3.5343D-02 -7.4812D-01 3.9345D-01 1.8415D-01
5.8440D-07 0.0000D+00 2.8868D-01 1.7003D-01
6.4087D-01 7.2822D-01 4.5013D-01 2.9425D-01
6.4087D-01 -7.2822D-01 4.5013D-01 2.9425D-01
3.7889D+00 0.0000D+00 9.6305D-01 2.2469D+00
6
1.0000D+00 4.0112D+00 1.2750D+01 4.0213D+01 1.2656D+02 3.9788D+02
1.0000D+00 3.2616D+00 1.0629D+01 3.3342D+01 1.0479D+02 3.2936D+02
1.0000D+00 3.1500D+00 9.8006D+00 3.0630D+01 9.6164D+01 3.0215D+02
1.0000D+00 3.2755D+00 1.0420D+01 3.2957D+01 1.0374D+02 3.2616D+02
1.0000D+00 2.8214D+00 8.4558D+00 2.6296D+01 8.2443D+01 2.5893D+02
1.0000D+00 2.6406D+00 8.3565D+00 2.6558D+01 8.3558D+01 2.6268D+02
-5.3220D-01 0.0000D+00 5.3287D-01 3.8557D-01
-1.0118D-01 0.0000D+00 7.2342D-01 9.1303D-02
-9.8749D-03 0.0000D+00 7.3708D-01 1.1032D-02
2.9861D-03 0.0000D+00 4.4610D-01 1.2861D-02
1.8075D-01 0.0000D+00 4.2881D-01 1.7378D-01
3.9260D+02 0.0000D+00 4.8057D-01 3.9201D+02
8
0.0000D+00 4.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00
1.0000D+00 0.0000D+00 4.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00
0.0000D+00 1.0000D+00 0.0000D+00 4.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 4.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 4.0000D+00
0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
4.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
0.0000D+00 4.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
1.0000D+00 0.0000D+00
-3.7588D+00 0.0000D+00 1.2253D-01 1.2978D-01
-3.0642D+00 0.0000D+00 4.9811D-02 8.0162D-02
-2.0000D+00 0.0000D+00 3.6914D-02 8.2942D-02
-6.9459D-01 0.0000D+00 3.3328D-02 1.3738D-01
6.9459D-01 0.0000D+00 3.3328D-02 1.1171D-01
2.0000D+00 0.0000D+00 3.6914D-02 7.2156D-02
3.0642D+00 0.0000D+00 4.9811D-02 6.8352D-02
3.7588D+00 0.0000D+00 1.2253D-01 1.1527D-01
6
8.5000D+00 -1.0472D+01 2.8944D+00 -1.5279D+00 1.1056D+00 -5.0000D-01
2.6180D+00 -1.1708D+00 -2.0000D+00 8.9440D-01 -6.1800D-01 2.7640D-01
-7.2360D-01 2.0000D+00 -1.7080D-01 -1.6180D+00 8.9440D-01 -3.8200D-01
3.8200D-01 -8.9440D-01 1.6180D+00 1.7080D-01 -2.0000D+00 7.2360D-01
-2.7640D-01 6.1800D-01 -8.9440D-01 2.0000D+00 1.1708D+00 -2.6180D+00
5.0000D-01 -1.1056D+00 1.5279D+00 -2.8944D+00 1.0472D+01 -8.5000D+00
-5.8930D-01 0.0000D+00 1.7357D-04 2.8157D-04
-2.7627D-01 4.9852D-01 1.7486D-04 1.6704D-04
-2.7627D-01 -4.9852D-01 1.7486D-04 1.6704D-04
2.7509D-01 5.0059D-01 1.7635D-04 1.6828D-04
2.7509D-01 -5.0059D-01 1.7635D-04 1.6828D-04
5.9167D-01 0.0000D+00 1.7623D-04 3.0778D-04
4
4.0000D+00 -5.0000D+00 0.0000D+00 3.0000D+00
0.0000D+00 4.0000D+00 -3.0000D+00 -5.0000D+00
5.0000D+00 -3.0000D+00 4.0000D+00 0.0000D+00
3.0000D+00 0.0000D+00 5.0000D+00 4.0000D+00
1.0000D+00 5.0000D+00 1.0000D+00 4.3333D+00
1.0000D+00 -5.0000D+00 1.0000D+00 4.3333D+00
2.0000D+00 0.0000D+00 1.0000D+00 4.3333D+00
1.2000D+01 0.0000D+00 1.0000D+00 9.1250D+00
5
1.5000D+01 1.1000D+01 6.0000D+00 -9.0000D+00 -1.5000D+01
1.0000D+00 3.0000D+00 9.0000D+00 -3.0000D+00 -8.0000D+00
7.0000D+00 6.0000D+00 6.0000D+00 -3.0000D+00 -1.1000D+01
7.0000D+00 7.0000D+00 5.0000D+00 -3.0000D+00 -1.1000D+01
1.7000D+01 1.2000D+01 5.0000D+00 -1.0000D+01 -1.6000D+01
-9.9999D-01 0.0000D+00 2.1768D-01 5.2263D-01
1.4980D+00 3.5752D+00 3.9966D-04 6.0947D-03
1.4980D+00 -3.5752D+00 3.9966D-04 6.0947D-03
1.5020D+00 3.5662D+00 3.9976D-04 6.0960D-03
1.5020D+00 -3.5662D+00 3.9976D-04 6.0960D-03
6
-9.0000D+00 2.1000D+01 -1.5000D+01 4.0000D+00 2.0000D+00 0.0000D+00
-1.0000D+01 2.1000D+01 -1.4000D+01 4.0000D+00 2.0000D+00 0.0000D+00
-8.0000D+00 1.6000D+01 -1.1000D+01 4.0000D+00 2.0000D+00 0.0000D+00
-6.0000D+00 1.2000D+01 -9.0000D+00 3.0000D+00 3.0000D+00 0.0000D+00
-4.0000D+00 8.0000D+00 -6.0000D+00 0.0000D+00 5.0000D+00 0.0000D+00
-2.0000D+00 4.0000D+00 -3.0000D+00 0.0000D+00 1.0000D+00 3.0000D+00
1.0000D+00 6.2559D-04 6.4875D-05 5.0367D-04
1.0000D+00 -6.2559D-04 6.4875D-05 5.0367D-04
2.0000D+00 1.0001D+00 5.4076D-02 2.3507D-01
2.0000D+00 -1.0001D+00 5.4076D-02 2.3507D-01
3.0000D+00 0.0000D+00 8.6149D-01 5.4838D-07
3.0000D+00 0.0000D+00 1.2425D-01 1.2770D-06
10
1.0000D+00 1.0000D+00 1.0000D+00 -2.0000D+00 1.0000D+00 -1.0000D+00
2.0000D+00 -2.0000D+00 4.0000D+00 -3.0000D+00
-1.0000D+00 2.0000D+00 3.0000D+00 -4.0000D+00 2.0000D+00 -2.0000D+00
4.0000D+00 -4.0000D+00 8.0000D+00 -6.0000D+00
-1.0000D+00 0.0000D+00 5.0000D+00 -5.0000D+00 3.0000D+00 -3.0000D+00
6.0000D+00 -6.0000D+00 1.2000D+01 -9.0000D+00
-1.0000D+00 0.0000D+00 3.0000D+00 -4.0000D+00 4.0000D+00 -4.0000D+00
8.0000D+00 -8.0000D+00 1.6000D+01 -1.2000D+01
-1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 5.0000D+00 -4.0000D+00
1.0000D+01 -1.0000D+01 2.0000D+01 -1.5000D+01
-1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 2.0000D+00 -2.0000D+00
1.2000D+01 -1.2000D+01 2.4000D+01 -1.8000D+01
-1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 2.0000D+00 -5.0000D+00
1.5000D+01 -1.3000D+01 2.8000D+01 -2.1000D+01
-1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 2.0000D+00 -5.0000D+00
1.2000D+01 -1.1000D+01 3.2000D+01 -2.4000D+01
-1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 2.0000D+00 -5.0000D+00
1.2000D+01 -1.4000D+01 3.7000D+01 -2.6000D+01
-1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 2.0000D+00 -5.0000D+00
1.2000D+01 -1.4000D+01 3.6000D+01 -2.5000D+01
1.0000D+00 0.0000D+00 3.6037D-02 7.9613D-02
1.9867D+00 0.0000D+00 7.4283D-05 7.4025D-06
2.0000D+00 2.5052D-03 1.4346D-04 6.7839D-07
2.0000D+00 -2.5052D-03 1.4346D-04 6.7839D-07
2.0067D+00 1.1763D-02 6.7873D-05 5.7496D-06
2.0067D+00 -1.1763D-02 6.7873D-05 5.7496D-06
2.9970D+00 0.0000D+00 9.2779D-05 2.6519D-06
3.0000D+00 8.7028D-04 2.7358D-04 1.9407D-07
3.0000D+00 -8.7028D-04 2.7358D-04 1.9407D-07
3.0030D+00 0.0000D+00 9.2696D-05 2.6477D-06
0
DSX Data file for Real Nonsymmetric Schur Form Expert Driver
6 Number of matrix dimensions
0 1 2 3 5 10 20 Matrix dimensions
3 3 1 11 4 8 2 0 Parameters NB, NBMIN, NXOVER, INMIN, INWIN, INIBL, ISHFTS, IACC22
20.0 Threshold for test ratios
T
2 Read another line with random number generator seed
2518 3899 995 397 Seed for random number generator
DSX 21 Use all matrix types
1 1
1
0.00000D+00
1.00000D+00 0.00000D+00
1 1
1
1.00000D+00
1.00000D+00 1.00000D+00
6 6
1 2 3 4 5 6
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
1.00000D+00 4.43734D-31
6 0
1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
1.00000D+00 1.00000D+00
6 6
1 2 3 4 5 6
1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
1.00000D+00 2.00000D+00
6 1
1
1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00
1.00000D+00 2.00000D+00
6 3
4 5 6
1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 2.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 3.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 4.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 5.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 6.00000D+00
1.00000D+00 1.00000D+00
2 1
1
1.00000D+00 2.00000D+00
0.00000D+00 3.00000D+00
7.07107D-01 2.00000D+00
4 2
1 2
8.52400D-01 5.61100D-01 7.04300D-01 9.54000D-01
2.79800D-01 7.21600D-01 9.61300D-01 3.58200D-01
7.08100D-01 4.09400D-01 2.25000D-01 9.51800D-01
5.54300D-01 5.22000D-01 6.86000D-01 3.07000D-02
7.22196D-01 4.63943D-01
7 6
1 2 3 4 5 6
7.81800D-01 5.65700D-01 7.62100D-01 7.43600D-01 2.55300D-01 4.10000D-01
1.34000D-02
6.45800D-01 2.66600D-01 5.51000D-01 8.31800D-01 9.27100D-01 6.20900D-01
7.83900D-01
1.31600D-01 4.91400D-01 1.77100D-01 1.96400D-01 1.08500D-01 9.27000D-01
2.24700D-01
6.41000D-01 4.68900D-01 9.65900D-01 8.88400D-01 3.76900D-01 9.67300D-01
6.18300D-01
8.38200D-01 8.74300D-01 4.50700D-01 9.44200D-01 7.75500D-01 9.67600D-01
7.83100D-01
3.25900D-01 7.38900D-01 8.30200D-01 4.52100D-01 3.01500D-01 2.13300D-01
8.43400D-01
5.24400D-01 5.01600D-01 7.52900D-01 3.83800D-01 8.47900D-01 9.12800D-01
5.77000D-01
9.43220D-01 3.20530D+00
4 2
2 3
-9.85900D-01 1.47840D+00 -1.33600D-01 -2.95970D+00
-4.33700D-01 -6.54000D-01 -7.15500D-01 1.23760D+00
-7.36300D-01 -1.97680D+00 -1.95100D-01 3.43200D-01
6.41400D-01 -1.40880D+00 6.39400D-01 8.58000D-02
5.22869D-01 5.45530D-01
7 5
1 2 3 4 5
2.72840D+00 2.15200D-01 -1.05200D+00 -2.44600D-01 -6.53000D-02 3.90500D-01
1.40980D+00
9.75300D-01 6.51500D-01 -4.76200D-01 5.42100D-01 6.20900D-01 4.75900D-01
-1.44930D+00
-9.05200D-01 1.79000D-01 -7.08600D-01 4.62100D-01 1.05800D+00 2.24260D+00
1.58260D+00
-7.17900D-01 -2.53400D-01 -4.73900D-01 -1.08100D+00 4.13800D-01 -9.50000D-02
1.45300D-01
-1.37990D+00 -1.06490D+00 1.25580D+00 7.80100D-01 -6.40500D-01 -8.61000D-02
8.30000D-02
2.84900D-01 -1.29900D-01 4.80000D-02 -2.58600D-01 4.18900D-01 1.37680D+00
8.20800D-01
-5.44200D-01 9.74900D-01 9.55800D-01 1.23700D-01 1.09020D+00 -1.40600D-01
1.90960D+00
6.04729D-01 9.00391D-01
6 4
3 4 5 6
0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00
1.00000D-06 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 5.00000D-01
4.89525D-05 4.56492D-05
8 4
1 2 3 4
1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 1.00000D+01 0.00000D+00
1.00000D+01 0.00000D+00
0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 1.00000D+01
1.00000D+01 0.00000D+00
0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 1.00000D+01
1.00000D+01 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 1.00000D+01
0.00000D+00 1.00000D+01
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 5.00000D-01 1.00000D+00
0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 5.00000D-01
1.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
5.00000D-01 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 5.00000D-01
9.56158D-05 4.14317D-05
9 3
1 2 3
1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
7.50000D-01 1.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 7.50000D-01 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 7.50000D-01
1.00000D+00 5.55801D-07
10 4
1 2 3 4
1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
8.75000D-01 1.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 8.75000D-01 1.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 8.75000D-01 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 8.75000D-01
1.00000D+00 1.16972D-10
12 6
1 2 3 4 5 6
1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
1.00000D+01 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 1.00000D+01 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 1.00000D+01 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+01 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+01 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+01
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
9.37500D-01 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 9.37500D-01 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 9.37500D-01 1.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 9.37500D-01 1.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 9.37500D-01 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 9.37500D-01
1.85655D-10 2.20147D-16
12 7
6 7 8 9 10 11 12
1.20000D+01 1.10000D+01 1.00000D+01 9.00000D+00 8.00000D+00 7.00000D+00
6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
1.10000D+01 1.10000D+01 1.00000D+01 9.00000D+00 8.00000D+00 7.00000D+00
6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
0.00000D+00 1.00000D+01 1.00000D+01 9.00000D+00 8.00000D+00 7.00000D+00
6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
0.00000D+00 0.00000D+00 9.00000D+00 9.00000D+00 8.00000D+00 7.00000D+00
6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 8.00000D+00 8.00000D+00 7.00000D+00
6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 7.00000D+00 7.00000D+00
6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 6.00000D+00
6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
5.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 4.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 3.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 2.00000D+00 2.00000D+00 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00
6.92558D-05 5.52606D-05
3 1
1
2.00000D-06 1.00000D+00 -2.00000D+00
1.00000D-06 -2.00000D+00 4.00000D+00
0.00000D+00 1.00000D+00 -2.00000D+00
7.30297D-01 4.00000D+00
5 1
3
2.00000D-03 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 1.00000D-03 1.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 -1.00000D-03 1.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 -2.00000D-03 1.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
3.99999D-12 3.99201D-12
6 4
1 2 3 5
1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
1.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00
1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00
1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00
2.93294D-01 1.63448D-01
6 2
3 4
0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
1.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 1.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00
0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 1.00000D+00
-1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00
3.97360D-01 3.58295D-01
6 3
3 4 5
1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00
5.00000D-01 3.33300D-01 2.50000D-01 2.00000D-01 1.66700D-01 1.42900D-01
3.33300D-01 2.50000D-01 2.00000D-01 1.66700D-01 1.42900D-01 1.25000D-01
2.50000D-01 2.00000D-01 1.66700D-01 1.42900D-01 1.25000D-01 1.11100D-01
2.00000D-01 1.66700D-01 1.42900D-01 1.25000D-01 1.11100D-01 1.00000D-01
1.66700D-01 1.42900D-01 1.25000D-01 1.11100D-01 1.00000D-01 9.09000D-02
7.28934D-01 1.24624D-02
5 1
1
1.50000D+01 1.10000D+01 6.00000D+00 -9.00000D+00 -1.50000D+01
1.00000D+00 3.00000D+00 9.00000D+00 -3.00000D+00 -8.00000D+00
7.00000D+00 6.00000D+00 6.00000D+00 -3.00000D+00 -1.10000D+01
7.00000D+00 7.00000D+00 5.00000D+00 -3.00000D+00 -1.10000D+01
1.70000D+01 1.20000D+01 5.00000D+00 -1.00000D+01 -1.60000D+01
2.17680D-01 5.22626D-01
6 2
1 2
-9.00000D+00 2.10000D+01 -1.50000D+01 4.00000D+00 2.00000D+00 0.00000D+00
-1.00000D+01 2.10000D+01 -1.40000D+01 4.00000D+00 2.00000D+00 0.00000D+00
-8.00000D+00 1.60000D+01 -1.10000D+01 4.00000D+00 2.00000D+00 0.00000D+00
-6.00000D+00 1.20000D+01 -9.00000D+00 3.00000D+00 3.00000D+00 0.00000D+00
-4.00000D+00 8.00000D+00 -6.00000D+00 0.00000D+00 5.00000D+00 0.00000D+00
-2.00000D+00 4.00000D+00 -3.00000D+00 0.00000D+00 1.00000D+00 3.00000D+00
6.78904D-02 4.22005D-02
10 1
1
1.00000D+00 1.00000D+00 1.00000D+00 -2.00000D+00 1.00000D+00 -1.00000D+00
2.00000D+00 -2.00000D+00 4.00000D+00 -3.00000D+00
-1.00000D+00 2.00000D+00 3.00000D+00 -4.00000D+00 2.00000D+00 -2.00000D+00
4.00000D+00 -4.00000D+00 8.00000D+00 -6.00000D+00
-1.00000D+00 0.00000D+00 5.00000D+00 -5.00000D+00 3.00000D+00 -3.00000D+00
6.00000D+00 -6.00000D+00 1.20000D+01 -9.00000D+00
-1.00000D+00 0.00000D+00 3.00000D+00 -4.00000D+00 4.00000D+00 -4.00000D+00
8.00000D+00 -8.00000D+00 1.60000D+01 -1.20000D+01
-1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 5.00000D+00 -4.00000D+00
1.00000D+01 -1.00000D+01 2.00000D+01 -1.50000D+01
-1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 2.00000D+00 -2.00000D+00
1.20000D+01 -1.20000D+01 2.40000D+01 -1.80000D+01
-1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 2.00000D+00 -5.00000D+00
1.50000D+01 -1.30000D+01 2.80000D+01 -2.10000D+01
-1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 2.00000D+00 -5.00000D+00
1.20000D+01 -1.10000D+01 3.20000D+01 -2.40000D+01
-1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 2.00000D+00 -5.00000D+00
1.20000D+01 -1.40000D+01 3.70000D+01 -2.60000D+01
-1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 2.00000D+00 -5.00000D+00
1.20000D+01 -1.40000D+01 3.60000D+01 -2.50000D+01
3.60372D-02 7.96134D-02
0 0
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/eig/dsg.in 0000644 0001750 0001750 00000001371 10616163234 023071 0 ustar osallou osallou DSG: Data file for testing Generalized Symmetric Eigenvalue Problem routines
7 Number of values of N
0 1 2 3 5 10 16 Values of N (dimension)
3 Number of values of NB
1 3 20 Values of NB (blocksize)
2 2 2 Values of NBMIN (minimum blocksize)
1 1 1 Values of NX (crossover point)
20.0 Threshold value
T Put T to test the LAPACK routines
T Put T to test the driver routines
T Put T to test the error exits
1 Code to interpret the seed
DSG 21
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/eig/dgbak.in 0000644 0001750 0001750 00000026220 10616163234 023364 0 ustar osallou osallou DGK: Tests DGGBAK
6 3
0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.3000D+01 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.4000D+01 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.5000D+01 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.6000D+01
0.6000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.5000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.4000D+01 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.3000D+01 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.2000D+01 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
0.1000D+01 0.1000D+01 0.1000D+01
0.2000D+01 0.2000D+01 0.2000D+01
0.3000D+01 0.3000D+01 0.3000D+01
0.4000D+01 0.4000D+01 0.4000D+01
0.5000D+01 0.5000D+01 0.5000D+01
0.6000D+01 0.6000D+01 0.6000D+01
-0.1000D+01 -0.1000D+01 -0.1000D+01
-0.2000D+01 -0.2000D+01 -0.2000D+01
-0.3000D+01 -0.3000D+01 -0.3000D+01
-0.4000D+01 -0.4000D+01 -0.4000D+01
-0.5000D+01 -0.5000D+01 -0.5000D+01
-0.6000D+01 -0.6000D+01 -0.6000D+01
6 3
0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.2000D+01 0.2100D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.3000D+01 0.3100D+01 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.4000D+01 0.4100D+01 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.5000D+01 0.5100D+01 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.6000D+01 0.6100D+01
0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.3000D+01 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.4000D+01 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.5000D+01 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.6000D+01
0.1000D+01 0.1000D+01 0.1000D+01
0.2000D+01 0.2000D+01 0.2000D+01
0.3000D+01 0.3000D+01 0.3000D+01
0.4000D+01 0.4000D+01 0.4000D+01
0.5000D+01 0.5000D+01 0.5000D+01
0.6000D+01 0.6000D+01 0.6000D+01
-0.1000D+01 -0.1000D+01 -0.1000D+01
-0.2000D+01 -0.2000D+01 -0.2000D+01
-0.3000D+01 -0.3000D+01 -0.3000D+01
-0.4000D+01 -0.4000D+01 -0.4000D+01
-0.5000D+01 -0.5000D+01 -0.5000D+01
-0.6000D+01 -0.6000D+01 -0.6000D+01
5 5
0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.1000D+01 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00
0.1000D+01 0.2000D+01 0.3000D+01 0.0000D+00 0.0000D+00
0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.0000D+00
0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01
0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00
0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.2000D+01 0.2000D+01 0.2000D+01 0.2000D+01 0.2000D+01
0.3000D+01 0.3000D+01 0.3000D+01 0.3000D+01 0.3000D+01
0.4000D+01 0.4000D+01 0.4000D+01 0.4000D+01 0.4000D+01
0.5000D+01 0.5000D+01 0.5000D+01 0.5000D+01 0.5000D+01
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.2000D+01 0.2000D+01 0.2000D+01 0.2000D+01 0.2000D+01
0.3000D+01 0.3000D+01 0.3000D+01 0.3000D+01 0.3000D+01
0.4000D+01 0.4000D+01 0.4000D+01 0.4000D+01 0.4000D+01
0.5000D+01 0.5000D+01 0.5000D+01 0.5000D+01 0.5000D+01
6 5
0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11
0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11
0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01 0.2000D+01 -0.3000D+01 0.4000D+01 0.5000D+01
0.8000D+01 0.9000D+01 0.0000D+00 0.9000D+01 0.2000D+01
0.0000D+00 -0.9000D+01 0.2000D+01 0.1000D+01 0.1000D+01
0.8000D+01 0.2000D+01 0.1000D+01 0.0000D+00 0.2000D+01
0.0000D+00 0.3000D+01 0.2000D+01 0.1000D+01 0.1000D+01
0.2000D+01 0.1000D+01 0.9000D+01 0.0000D+00 0.1000D+01
0.1000D+01 -0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01
-0.8000D+01 0.9000D+01 0.0000D+00 0.9000D+01 0.2000D+01
0.0000D+00 0.9000D+01 0.2000D+01 0.1000D+01 0.1000D+01
0.8000D+01 0.2000D+01 0.1000D+01 0.0000D+00 0.2000D+01
0.0000D+00 0.3000D+01 0.2000D+01 0.1000D+01 0.1000D+01
0.2000D+01 0.8000D+01 0.9000D+01 0.0000D+00 0.1000D+01
6 2
0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D-05 0.1000D+07
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D-05 0.1000D-05
0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+07 0.1000D+07
0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D-05 0.1000D+07
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D-05 0.1000D-05
0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+07 0.1000D+07
0.1000D+01 0.1000D+01
0.2000D+01 0.2000D+01
0.3000D+01 0.3000D+01
0.4000D+01 0.4000D+01
0.5000D+01 0.5000D+01
0.6000D+01 0.6000D+01
0.1100D+01 0.1100D+01
0.2200D+01 0.2200D+01
0.3300D+01 0.3300D+01
0.4400D+01 0.4400D+01
0.5500D+01 0.5500D+01
0.6600D+01 0.6600D+01
7 3
0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01
0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01
0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01
0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00
0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.1000D+01
0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01
0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01
0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01
0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01
0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01
0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00
0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.1000D+01
0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
0.1000D+01
0.1000D+01 0.1000D+01 0.1000D+01
0.2000D+01 0.2000D+01 0.2000D+01
0.3000D+01 0.3000D+01 0.3000D+01
0.4000D+01 0.4000D+01 0.4000D+01
0.5000D+01 0.5000D+01 0.5000D+01
0.6000D+01 0.6000D+01 0.6000D+01
0.7000D+01 0.7000D+01 0.7000D+01
-0.1000D+01 -0.1000D+01 -0.1000D+01
-0.2000D+01 -0.2000D+01 -0.2000D+01
-0.3000D+01 -0.3000D+01 -0.3000D+01
-0.4000D+01 -0.4000D+01 -0.4000D+01
-0.5000D+01 -0.5000D+01 -0.5000D+01
-0.6000D+01 -0.6000D+01 -0.6000D+01
-0.7000D+01 -0.7000D+01 -0.7000D+01
7 3
0.0000D+00 0.1000D+04 0.0000D+00 0.1000D+04 0.1000D+04 0.1000D+04
0.1000D-04
0.0000D+00 0.1000D-04 0.1000D+04 0.1000D-04 0.1000D-04 0.1000D+04
0.1000D+04
0.1000D+04 0.1000D+04 0.1000D-04 0.1000D+04 0.1000D+04 0.1000D+04
0.1000D+04
0.0000D+00 0.1000D-04 0.0000D+00 0.1000D+00 0.1000D+04 0.1000D-04
0.1000D+04
0.0000D+00 0.1000D+04 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00
0.0000D+00 0.4000D-04 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.1000D-04
0.0000D+00 0.1000D+04 0.0000D+00 0.1000D+04 0.1000D+04 0.1000D-04
0.1000D+04
0.0000D+00 0.1000D-01 0.0000D+00 0.1000D+04 0.1000D-04 0.1000D+04
0.1000D+04
0.0000D+00 0.1000D+04 0.1000D+04 0.1000D+04 0.1000D+04 0.1000D+00
0.1000D+04
0.1000D+04 0.1000D+04 0.1000D+04 0.1000D+04 0.1000D-04 0.1000D+04
0.1000D+04
0.0000D+00 0.4000D-01 0.0000D+00 0.1000D+04 0.1000D+01 0.1000D+04
0.1000D+04
0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.0000D+00
0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
0.1000D+01
0.0000D+00 0.1000D-04 0.0000D+00 0.1000D+04 0.1000D+01 0.1000D+01
0.1000D-04
0.1000D+01 0.1000D+01 0.1000D+01
0.2000D+01 0.2000D+01 0.2000D+01
0.3000D+01 0.3000D+01 0.3000D+01
0.4000D+01 0.4000D+01 0.4000D+01
0.5000D+01 0.5000D+01 0.5000D+01
0.6000D+01 0.6000D+01 0.6000D+01
0.7000D+01 0.7000D+01 0.7000D+01
0.1000D+01 0.1000D+01 0.1000D+01
0.2000D+01 0.2000D+01 0.2000D+01
0.3000D+01 0.3000D+01 0.3000D+01
0.4000D+01 0.4000D+01 0.4000D+01
0.5000D+01 0.5000D+01 0.5000D+01
0.6000D+01 0.6000D+01 0.6000D+01
0.7000D+01 0.7000D+01 0.7000D+01
6 2
-0.2000D+02 -0.1000D+05 -0.2000D+01 -0.1000D+07 -0.1000D+02 -0.2000D+06
0.6000D-02 0.4000D+01 0.6000D-03 0.2000D+03 0.3000D-02 0.3000D+02
-0.2000D+00 -0.3000D+03 -0.4000D-01 -0.1000D+05 0.0000D+00 0.3000D+04
0.6000D-04 0.4000D-01 0.9000D-05 0.9000D+01 0.3000D-04 0.5000D+00
0.6000D-01 0.5000D+02 0.8000D-02 -0.4000D+04 0.8000D-01 0.0000D+00
0.0000D+00 0.1000D+04 0.7000D+00 -0.2000D+06 0.1300D+02 -0.6000D+05
-0.2000D+02 -0.1000D+05 0.2000D+01 -0.2000D+07 0.1000D+02 -0.1000D+06
0.5000D-02 0.3000D+01 -0.2000D-03 0.4000D+03 -0.1000D-02 0.3000D+02
0.0000D+00 -0.1000D+03 -0.8000D-01 0.2000D+05 -0.4000D+00 0.0000D+00
0.5000D-04 0.3000D-01 0.2000D-05 0.4000D+01 0.2000D-04 0.1000D+00
0.4000D-01 0.3000D+02 -0.1000D-02 0.3000D+04 -0.1000D-01 0.6000D+03
-0.1000D+01 0.0000D+00 0.4000D+00 -0.1000D+06 0.4000D+01 0.2000D+05
0.1000D+01 0.1000D+01
0.2000D+01 0.2000D+01
0.3000D+01 0.3000D+01
0.4000D+01 0.4000D+01
0.5000D+01 0.5000D+01
0.6000D+01 0.6000D+01
0.1000D+02 0.1000D+02
0.2000D+02 0.2000D+02
0.3000D+02 0.3000D+02
0.4000D+02 0.4000D+02
0.5000D+02 0.5000D+02
0.6000D+02 0.6000D+02
0 0
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/testing/eig/xerbla.f 0000644 0001750 0001750 00000004623 10616163237 023416 0 ustar osallou osallou SUBROUTINE XERBLA( SRNAME, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*6 SRNAME
INTEGER INFO
* ..
*
* Purpose
* =======
*
* This is a special version of XERBLA to be used only as part of
* the test program for testing error exits from the LAPACK routines.
* Error messages are printed if INFO.NE.INFOT or if SRNAME.NE.SRNAMT,
* where INFOT and SRNAMT are values stored in COMMON.
*
* Arguments
* =========
*
* SRNAME (input) CHARACTER*6
* The name of the subroutine calling XERBLA. This name should
* match the COMMON variable SRNAMT.
*
* INFO (input) INTEGER
* The error return code from the calling subroutine. INFO
* should equal the COMMON variable INFOT.
*
* Further Details
* ======= =======
*
* The following variables are passed via the common blocks INFOC and
* SRNAMC:
*
* INFOT INTEGER Expected integer return code
* NOUT INTEGER Unit number for printing error messages
* OK LOGICAL Set to .TRUE. if INFO = INFOT and
* SRNAME = SRNAMT, otherwise set to .FALSE.
* LERR LOGICAL Set to .TRUE., indicating that XERBLA was called
* SRNAMT CHARACTER*6 Expected name of calling subroutine
*
*
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
LERR = .TRUE.
IF( INFO.NE.INFOT ) THEN
IF( INFOT.NE.0 ) THEN
WRITE( NOUT, FMT = 9999 )SRNAMT, INFO, INFOT
ELSE
WRITE( NOUT, FMT = 9997 )SRNAME, INFO
END IF
OK = .FALSE.
END IF
IF( SRNAME.NE.SRNAMT ) THEN
WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT
OK = .FALSE.
END IF
RETURN
*
9999 FORMAT( ' *** XERBLA was called from ', A6, ' with INFO = ', I6,
$ ' instead of ', I2, ' ***' )
9998 FORMAT( ' *** XERBLA was called with SRNAME = ', A6,
$ ' instead of ', A6, ' ***' )
9997 FORMAT( ' *** On entry to ', A6, ' parameter number ', I6,
$ ' had an illegal value ***' )
*
* End of XERBLA
*
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/error_reporting/ 0000755 0001750 0001750 00000000000 11734055017 022764 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/error_reporting/Makefile_javasrc 0000644 0001750 0001750 00000001150 10616163231 026126 0 ustar osallou osallou .SUFFIXES: .f .java
ROOT=../..
include $(ROOT)/make.def
$(ROOT)/$(ERR_IDX): $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR) err.f
$(MAKE) nojar
/bin/rm -f `find . -name "*.class"`
mkdir -p $(JAVASRC_OUTDIR)
$(JAVAC) -classpath $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR) -d $(JAVASRC_OUTDIR) $(OUTDIR)/$(ERR_PDIR)/*.java
/bin/rm -f $(JAVASRC_OUTDIR)/$(ERR_PDIR)/*.old
$(JAVAB) $(JAVASRC_OUTDIR)/$(ERR_PDIR)/*.class
cd $(JAVASRC_OUTDIR); $(JAR) cvf ../$(ERR_JAR) `find . -name "*.class"`
$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):
cd $(ROOT)/$(UTIL_DIR); $(MAKE)
clean:
/bin/rm -rf *.java *.class *.f2j $(OUTDIR) $(JAVASRC_OUTDIR) $(ERR_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/error_reporting/Makefile 0000644 0001750 0001750 00000000632 10616163231 024421 0 ustar osallou osallou .SUFFIXES: .f .java
ROOT=../..
include $(ROOT)/make.def
F2JFLAGS=-c .:$(OUTDIR) -p $(ERR_PACKAGE) -o $(OUTDIR)
$(ROOT)/$(ERR_IDX): err.f
$(F2J) $(F2JFLAGS) $? > /dev/null
cd $(OUTDIR); $(JAR) cvf ../$(ERR_JAR) `find . -name "*.class"`
nojar: err.f
$(F2J) $(F2JFLAGS) $? > /dev/null
javasrc:
$(MAKE) -f Makefile_javasrc
clean:
/bin/rm -rf *.java *.class *.f2j $(OUTDIR) $(JAVASRC_OUTDIR) $(ERR_JAR)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/src/error_reporting/err.f 0000644 0001750 0001750 00000002026 10616163231 023717 0 ustar osallou osallou SUBROUTINE XERBLA(SRNAME,INFO)
*
* -- LAPACK auxiliary routine (preliminary version) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO
CHARACTER*6 SRNAME
* ..
*
* 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 (input) CHARACTER*6
* The name of the routine which called XERBLA.
*
* INFO (input) INTEGER
* The position of the invalid parameter in the parameter list
* of the calling routine.
*
*
WRITE (*,FMT=9999) SRNAME,INFO
*
STOP
*
9999 FORMAT (' ** On entry to ',A6,' parameter number ',I2,' had ',
+ 'an illegal value')
*
* End of XERBLA
*
END
jlapack-0.8~dfsg.orig/jlapack-3.1.1/Makefile 0000644 0001750 0001750 00000017356 10627076327 020436 0 ustar osallou osallou include make.def
default:
@echo ""
@echo "JLAPACK (version: $(VERSION))"
@echo ""
@echo "The possible targets are as follows:"
@echo ""
@echo "Translated from Fortran directly to bytecode:"
@echo " lib - BLAS and LAPACK libraries"
@echo " testers - BLAS and LAPACK test routines"
@echo " alltests - build and run the test routines"
@echo " alldist - a distribution of everything"
@echo " libdist - a distribution of the BLAS and LAPACK libraries"
@echo " libdist_strict - a distribution of BLAS/LAPACK containing all strictfp versions"
@echo " testers_dist - a distribution of the BLAS and LAPACK test routines"
@echo " timers - BLAS and LAPACK timing routines"
@echo " timers_dist - a distribution of the BLAS and LAPACK timing routines"
@echo ""
@echo "Translated from Fortran to Java source:"
@echo " javasrc - BLAS and LAPACK libraries"
@echo " testers_javasrc - BLAS and LAPACK test routines"
@echo " alltests_javasrc - build and run the test routines"
@echo " libdist_javasrc - a distribution of the BLAS and LAPACK libraries"
@echo " libdist_strict_javasrc - a distribution of BLAS/LAPACK containing all strictfp versions"
@echo " testers_dist_javasrc - a distribution of the BLAS and LAPACK test routines"
@echo ""
@echo "Documentation:"
@echo " javadoc - documentation in javadoc HTML format"
@echo " javadoc_dist - distribution of the documentation"
@echo ""
@echo "Other:"
@echo " clean - remove all jar files, generated code, etc."
alldist:
$(MAKE) clean
$(MAKE) libdist
$(MAKE) almost_clean
$(MAKE) libdist_strict
$(MAKE) almost_clean
$(MAKE) testers_dist
$(MAKE) almost_clean
$(MAKE) javadoc_dist
lib:
cd $(SRCDIR); $(MAKE)
all:
cd $(SRCDIR); $(MAKE) all
testers: lib
cd $(TESTING_DIR); $(MAKE) testers
matgen:
cd $(MATGEN_DIR); $(MAKE)
smatgen:
cd $(SMATGEN_DIR); $(MAKE)
timers: lib matgen smatgen
cd $(TIMING_DIR); $(MAKE) timers
testers_javasrc: javasrc
cd $(TESTING_DIR); $(MAKE) -f Makefile_javasrc testers
alltests: testers
cd $(TESTING_DIR); $(MAKE) runtests
alltests_javasrc: testers_javasrc
cd $(TESTING_DIR); $(MAKE) -f Makefile_javasrc runtests
javasrc:
cd $(SRCDIR); $(MAKE) -f Makefile_javasrc
javadoc: lib
mkdir -p doc
javadoc -author -sourcepath $(BLAS_OBJ):$(LAPACK_OBJ):$(ERR_OBJ):$(UTIL_F2J_SRC_DIR) -d doc -J-mx256000000 $(UTIL_PACKAGE) $(BLAS_PACKAGE) $(LAPACK_PACKAGE) $(ERR_PACKAGE)
javadoc_dist: javadoc
/bin/rm -f $(JAVADOC_DIST_ZIP) $(JAVADOC_DIST_TGZ) $(VERSION)/doc
mkdir -p $(VERSION)
cd $(VERSION); ln -s ../doc doc
$(ZIP) -r9 $(JAVADOC_DIST_ZIP) $(VERSION)/doc
$(TAR) $(TARFLAGS) - $(VERSION)/doc | $(GZIP) > $(JAVADOC_DIST_TGZ)
libdist: lib libdist_common
$(ZIP) -r9 $(LIBDIST_ZIP) $(VERSION)
$(TAR) $(TARFLAGS) - $(VERSION) | $(GZIP) > $(LIBDIST_TGZ)
libdist_javasrc: javasrc libdist_common
$(ZIP) -r9 $(LIBDIST_ZIP) $(VERSION)
$(TAR) $(TARFLAGS) - $(VERSION) | $(GZIP) > $(LIBDIST_TGZ)
libdist_common:
/bin/rm -rf $(VERSION)
mkdir -p $(VERSION)/examples
cp README INSTALL CHANGES $(VERSION)
cp examples/*.java examples/Makefile examples/README $(VERSION)/examples
$(MAKE) STRICT_DIR="" libdist_copy_jar_files
libdist_strict:
$(MAKE) LIB_TARGET=lib libdist_strict_common
$(ZIP) -r9 $(LIBDIST_STRICT_ZIP) $(VERSION)
$(TAR) $(TARFLAGS) - $(VERSION) | $(GZIP) > $(LIBDIST_STRICT_TGZ)
libdist_strict_javasrc:
$(MAKE) LIB_TARGET=javasrc libdist_strict_common
$(ZIP) -r9 $(LIBDIST_STRICT_ZIP) $(VERSION)
$(TAR) $(TARFLAGS) - $(VERSION) | $(GZIP) > $(LIBDIST_STRICT_TGZ)
libdist_strict_common:
$(MAKE) almost_clean
/bin/rm -rf $(VERSION)
mkdir -p $(VERSION)/plain
mkdir -p $(VERSION)/strict_both
mkdir -p $(VERSION)/strict_fp
mkdir -p $(VERSION)/strict_math_lib
$(MAKE) STATIC=-fb $(LIB_TARGET)
$(MAKE) STRICT_DIR=strict_both libdist_copy_jar_files
cd src; $(MAKE) clean
$(MAKE) STATIC=-fm $(LIB_TARGET)
$(MAKE) STRICT_DIR=strict_math_lib libdist_copy_jar_files
cd src; $(MAKE) clean
$(MAKE) STATIC=-fs $(LIB_TARGET)
$(MAKE) STRICT_DIR=strict_fp libdist_copy_jar_files
cd src; $(MAKE) clean
$(MAKE) $(LIB_TARGET)
$(MAKE) STRICT_DIR=plain libdist_copy_jar_files
cp README INSTALL CHANGES $(VERSION)
mkdir -p $(VERSION)/examples
cp examples/*.java examples/Makefile examples/README $(VERSION)/examples
libdist_copy_jar_files:
cp $(BLAS_DIR)/$(BLAS_JAR) $(BLAS_DIR)/$(SIMPLE_BLAS_JAR) \
$(LAPACK_DIR)/$(LAPACK_JAR) $(LAPACK_DIR)/$(SIMPLE_LAPACK_JAR) \
$(UTIL_DIR)/$(UTIL_JAR) $(ERR_DIR)/$(ERR_JAR) $(VERSION)/$(STRICT_DIR)
testers_dist: testers testers_dist_common
$(ZIP) -r9 $(TESTERS_DIST_ZIP) $(VERSION)/testing
$(TAR) $(TARFLAGS) - $(VERSION)/testing | $(GZIP) > $(TESTERS_DIST_TGZ)
testers_dist_javasrc: testers_javasrc testers_dist_common
$(ZIP) -r9 $(TESTERS_DIST_ZIP) $(VERSION)/testing
$(TAR) $(TARFLAGS) - $(VERSION)/testing | $(GZIP) > $(TESTERS_DIST_TGZ)
testers_dist_common:
/bin/rm -rf $(VERSION)/testing
mkdir -p $(VERSION)/testing
-/bin/cp $(BLAS2TEST_DIR)/*.in $(BLAS3TEST_DIR)/*.in $(SBLAS2TEST_DIR)/*.in \
$(SBLAS3TEST_DIR)/*.in $(LINTEST_DIR)/*.in $(SLINTEST_DIR)/*.in \
$(EIGTEST_DIR)/*.in $(SEIGTEST_DIR)/*.in $(VERSION)/testing
-/bin/cp $(DISTDIR_TESTING)/*.sh $(DISTDIR_TESTING)/*.bat \
$(DISTDIR_TESTING)/README $(VERSION)/testing
-ln -s ../../$(BLAS1TEST_DIR)/$(BLAS1TEST_JAR) $(VERSION)/testing/$(BLAS1TEST_JAR)
-ln -s ../../$(BLAS2TEST_DIR)/$(BLAS2TEST_JAR) $(VERSION)/testing/$(BLAS2TEST_JAR)
-ln -s ../../$(BLAS3TEST_DIR)/$(BLAS3TEST_JAR) $(VERSION)/testing/$(BLAS3TEST_JAR)
-ln -s ../../$(SBLAS1TEST_DIR)/$(SBLAS1TEST_JAR) $(VERSION)/testing/$(SBLAS1TEST_JAR)
-ln -s ../../$(SBLAS2TEST_DIR)/$(SBLAS2TEST_JAR) $(VERSION)/testing/$(SBLAS2TEST_JAR)
-ln -s ../../$(SBLAS3TEST_DIR)/$(SBLAS3TEST_JAR) $(VERSION)/testing/$(SBLAS3TEST_JAR)
-ln -s ../../$(MATGEN_DIR)/$(MATGEN_JAR) $(VERSION)/testing/$(MATGEN_JAR)
-ln -s ../../$(SMATGEN_DIR)/$(SMATGEN_JAR) $(VERSION)/testing/$(SMATGEN_JAR)
-ln -s ../../$(LINTEST_DIR)/$(LINTEST_JAR) $(VERSION)/testing/$(LINTEST_JAR)
-ln -s ../../$(SLINTEST_DIR)/$(SLINTEST_JAR) $(VERSION)/testing/$(SLINTEST_JAR)
-ln -s ../../$(EIGTEST_DIR)/$(EIGTEST_JAR) $(VERSION)/testing/$(EIGTEST_JAR)
-ln -s ../../$(SEIGTEST_DIR)/$(SEIGTEST_JAR) $(VERSION)/testing/$(SEIGTEST_JAR)
timers_dist: timers timers_dist_common
$(ZIP) -r9 $(TIMERS_DIST_ZIP) $(VERSION)/timing
$(TAR) $(TARFLAGS) - $(VERSION)/timing | $(GZIP) > $(TIMERS_DIST_TGZ)
timers_dist_common:
/bin/rm -rf $(VERSION)/timing
mkdir -p $(VERSION)/timing/input_files_large
-/bin/cp $(LINTIME_DIR)/*.in $(SLINTIME_DIR)/*.in $(EIGTIME_DIR)/*.in \
$(SEIGTIME_DIR)/*.in $(VERSION)/timing
-/bin/cp $(LINTIME_DIR)/input_files_large/*.in \
$(SLINTIME_DIR)/input_files_large/*.in \
$(EIGTIME_DIR)/input_files_large/*.in \
$(SEIGTIME_DIR)/input_files_large/*.in \
$(VERSION)/timing/input_files_large
-/bin/cp $(DISTDIR_TIMING)/*.sh $(DISTDIR_TIMING)/*.bat \
$(DISTDIR_TIMING)/README $(VERSION)/timing
-ln -s ../../$(MATGEN_DIR)/$(MATGEN_JAR) $(VERSION)/timing/$(MATGEN_JAR)
-ln -s ../../$(SMATGEN_DIR)/$(SMATGEN_JAR) $(VERSION)/timing/$(SMATGEN_JAR)
-ln -s ../../$(LINTIME_DIR)/$(LINTIME_JAR) $(VERSION)/timing/$(LINTIME_JAR)
-ln -s ../../$(SLINTIME_DIR)/$(SLINTIME_JAR) $(VERSION)/timing/$(SLINTIME_JAR)
-ln -s ../../$(EIGTIME_DIR)/$(EIGTIME_JAR) $(VERSION)/timing/$(EIGTIME_JAR)
-ln -s ../../$(SEIGTIME_DIR)/$(SEIGTIME_JAR) $(VERSION)/timing/$(SEIGTIME_JAR)
examples:
cd examples; $(MAKE)
almost_clean:
cd src; $(MAKE) clean
cd examples; $(MAKE) clean
/bin/rm -rf doc $(VERSION)
clean: almost_clean
/bin/rm -rf $(LIBDIST_ZIP) $(LIBDIST_TGZ) \
$(TESTERS_DIST_ZIP) $(TESTERS_DIST_TGZ) $(JAVADOC_DIST_ZIP) \
$(JAVADOC_DIST_TGZ) $(TIMERS_DIST_ZIP) $(TIMERS_DIST_TGZ) \
$(LIBDIST_STRICT_ZIP) $(LIBDIST_STRICT_TGZ)
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist/ 0000755 0001750 0001750 00000000000 11734055016 017715 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist/test_sblas1.sh 0000755 0001750 0001750 00000000140 10616442116 022472 0 ustar osallou osallou #!/bin/sh
java -classpath sblat1.jar:../f2jutil.jar:../blas.jar org.netlib.blas.testing.Sblat1
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist/test_blas1.sh 0000755 0001750 0001750 00000000140 10616163227 022312 0 ustar osallou osallou #!/bin/sh
java -classpath dblat1.jar:../f2jutil.jar:../blas.jar org.netlib.blas.testing.Dblat1
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist/test_eig.sh 0000755 0001750 0001750 00000003762 10616163227 022071 0 ustar osallou osallou #!/bin/sh
java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < dbak.in
java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < dec.in
java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < dgbak.in
java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < dgg.in
java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < dsg.in
java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < gqr.in
java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < lse.in
java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < sep.in
java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < dbal.in
java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < ded.in
java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < dgbal.in
java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < dsb.in
java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < glm.in
java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < gsv.in
java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < nep.in
java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < svd.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist/test_blas2.bat 0000644 0001750 0001750 00000000150 10616163227 022445 0 ustar osallou osallou
java -classpath .\dblat2.jar;..\f2jutil.jar;..\blas.jar; org.netlib.blas.testing.Dblat2 < dblat2.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist/test_sblas3.bat 0000644 0001750 0001750 00000000150 10616442116 022626 0 ustar osallou osallou
java -classpath .\sblat3.jar;..\f2jutil.jar;..\blas.jar; org.netlib.blas.testing.Sblat3 < sblat3.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist/test_lin.bat 0000644 0001750 0001750 00000000210 10616163227 022221 0 ustar osallou osallou
java -classpath .\lintest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.lin.Dchkaa < dtest.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist/test_blas1.bat 0000644 0001750 0001750 00000000136 10616163227 022450 0 ustar osallou osallou
java -classpath .\dblat1.jar;..\f2jutil.jar;..\blas.jar; org.netlib.blas.testing.Dblat1
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist/README 0000644 0001750 0001750 00000012763 10616163227 020610 0 ustar osallou osallou JLAPACK 0.8 testing routines README
May 31, 2007
This directory should contain:
README - this file
Test Scripts for Double Precision:
test_blas1.bat - windows batch file to test BLAS level 1
test_blas2.bat - windows batch file to test BLAS level 2
test_blas3.bat - windows batch file to test BLAS level 3
test_eig.bat - windows batch file to test LAPACK linear equation routines
test_lin.bat - windows batch file to test LAPACK eigenvalue routines
test_blas1.sh - unix shell script to test BLAS level 1
test_blas2.sh - unix shell script to test BLAS level 2
test_blas3.sh - unix shell script to test BLAS level 3
test_eig.sh - unix shell script to test LAPACK linear equation routines
test_lin.sh - unix shell script to test LAPACK eigenvalue routines
Test Scripts for Single Precision:
test_sblas1.bat - windows batch file to test BLAS level 1
test_sblas2.bat - windows batch file to test BLAS level 2
test_sblas3.bat - windows batch file to test BLAS level 3
test_seig.bat - windows batch file to test LAPACK linear equation routines
test_slin.bat - windows batch file to test LAPACK eigenvalue routines
test_sblas1.sh - unix shell script to test BLAS level 1
test_sblas2.sh - unix shell script to test BLAS level 2
test_sblas3.sh - unix shell script to test BLAS level 3
test_seig.sh - unix shell script to test LAPACK linear equation routines
test_slin.sh - unix shell script to test LAPACK eigenvalue routines
Jar Files for Double Precision:
dblat1.jar - BLAS level 1 testing code
dblat2.jar - BLAS level 2 testing code
dblat3.jar - BLAS level 3 testing code
eigtest.jar - LAPACK eigenvalue testing code
lintest.jar - LAPACK linear equation testing code
matgen.jar - support routines for the testers
Jar Files for Single Precision:
sblat1.jar - BLAS level 1 testing code
sblat2.jar - BLAS level 2 testing code
sblat3.jar - BLAS level 3 testing code
seigtest.jar - LAPACK eigenvalue testing code
slintest.jar - LAPACK linear equation testing code
smatgen.jar - support routines for the testers
Test Input Files:
dblat2.in - Double precision BLAS level 2 input file
dblat3.in - Double precision BLAS level 3 input file
sblat2.in - Single precision BLAS level 2 input file
sblat3.in - Single precision BLAS level 3 input file
dtest.in - Double precision linear equation input file
stest.in - Single precision linear equation input file
dbak.in - eigenvalue input file
dbal.in - eigenvalue input file
dec.in - eigenvalue input file
ded.in - eigenvalue input file
dgbak.in - eigenvalue input file
dgbal.in - eigenvalue input file
dgg.in - eigenvalue input file
dsb.in - eigenvalue input file
dsg.in - eigenvalue input file
glm.in - eigenvalue input file
gqr.in - eigenvalue input file
gsv.in - eigenvalue input file
lse.in - eigenvalue input file
nep.in - eigenvalue input file
sbak.in - eigenvalue input file
sbal.in - eigenvalue input file
sbb.in - eigenvalue input file
sec.in - eigenvalue input file
sed.in - eigenvalue input file
sep.in - eigenvalue input file
sgbak.in - eigenvalue input file
sgbal.in - eigenvalue input file
sgd.in - eigenvalue input file
sgg.in - eigenvalue input file
ssb.in - eigenvalue input file
ssg.in - eigenvalue input file
svd.in - eigenvalue input file
To run the tests, simply execute the appropriate script, which
depends on the operating system you are running.
Some of the output is not exactly as the Fortran versions
would be (e.g. some arrays are printed as "NULL", but that is
only a limitation of the f2j I/O handling), however this
does not affect the running of the tests. As long as the
test results say "All tests passed the threshold", then things
are fine (see the note below, however).
Test results
------------
We tested JLAPACK on the following platforms:
-Solaris 9 (sparc), Java version:
java version "1.5.0_02"
Java(TM) 2 Runtime Environment, Standard Edition (build 1.5.0_02-b09)
Java HotSpot(TM) Client VM (build 1.5.0_02-b09, mixed mode, sharing)
-Solaris 9 (x86), Java version:
java version "1.4.2_05"
Java(TM) 2 Runtime Environment, Standard Edition (build 1.4.2_05-b04)
Java HotSpot(TM) Client VM (build 1.4.2_05-b04, mixed mode)
-Linux x86 (Debian 3.1), Java version:
java version "1.6.0"
Java(TM) SE Runtime Environment (build 1.6.0-b105)
Java HotSpot(TM) Client VM (build 1.6.0-b105, mixed mode, sharing)
-Linux x86 (Fedora Core 4), Java version:
java version "1.4.2"
gij (GNU libgcj) version 4.0.0 20050519 (Red Hat 4.0.0-8)
-Mac OS X 10.4.7 (ppc), Java version:
java version "1.5.0_06"
Java(TM) 2 Runtime Environment, Standard Edition (build 1.5.0_06-112)
Java HotSpot(TM) Client VM (build 1.5.0_06-64, mixed mode, sharing)
-Win2000 x86 / Sun JDK 1.6
Note: in single precision, the eigenvalue testers will report
some failures, but they match the failures observed during execution
of the native Fortran code. For more details, see:
http://www.netlib.org/lapack/faq.html#1.23
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist/test_slin.sh 0000755 0001750 0001750 00000000215 10616442116 022255 0 ustar osallou osallou #!/bin/sh
java -classpath slintest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.lin.Schkaa < stest.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist/test_eig.bat 0000644 0001750 0001750 00000004122 10616163227 022211 0 ustar osallou osallou
java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < dbak.in
java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < dec.in
java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < dgbak.in
java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < dgg.in
java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < dsg.in
java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < gqr.in
java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < lse.in
java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < sep.in
java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < dbal.in
java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < ded.in
java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < dgbal.in
java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < dsb.in
java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < glm.in
java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < gsv.in
java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < nep.in
java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < svd.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist/test_lin.sh 0000755 0001750 0001750 00000000213 10616163227 022073 0 ustar osallou osallou #!/bin/sh
java -classpath lintest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.lin.Dchkaa < dtest.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist/test_sblas2.bat 0000644 0001750 0001750 00000000150 10616442116 022625 0 ustar osallou osallou
java -classpath .\sblat2.jar;..\f2jutil.jar;..\blas.jar; org.netlib.blas.testing.Sblat2 < sblat2.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist/test_blas2.sh 0000755 0001750 0001750 00000000154 10616163227 022320 0 ustar osallou osallou #!/bin/sh
java -classpath dblat2.jar:../f2jutil.jar:../blas.jar org.netlib.blas.testing.Dblat2 < dblat2.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist/test_sblas2.sh 0000755 0001750 0001750 00000000154 10616442116 022500 0 ustar osallou osallou #!/bin/sh
java -classpath sblat2.jar:../f2jutil.jar:../blas.jar org.netlib.blas.testing.Sblat2 < sblat2.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist/test_seig.sh 0000755 0001750 0001750 00000004423 10616442116 022244 0 ustar osallou osallou #!/bin/sh
java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < glm.in
java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < lse.in
java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < sbal.in
java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < sed.in
java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < sgbal.in
java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < ssb.in
java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < gqr.in
java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < nep.in
java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < sbb.in
java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < sep.in
java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < sgd.in
java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < ssg.in
java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < gsv.in
java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < sbak.in
java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < sec.in
java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < sgbak.in
java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < sgg.in
java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < svd.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist/test_blas3.bat 0000644 0001750 0001750 00000000150 10616163227 022446 0 ustar osallou osallou
java -classpath .\dblat3.jar;..\f2jutil.jar;..\blas.jar; org.netlib.blas.testing.Dblat3 < dblat3.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist/test_seig.bat 0000644 0001750 0001750 00000004570 10616442116 022400 0 ustar osallou osallou
java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < glm.in
java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < lse.in
java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < sbal.in
java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < sed.in
java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < sgbal.in
java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < ssb.in
java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < gqr.in
java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < nep.in
java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < sbb.in
java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < sep.in
java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < sgd.in
java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < ssg.in
java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < gsv.in
java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < sbak.in
java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < sec.in
java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < sgbak.in
java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < sgg.in
java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < svd.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist/test_sblas1.bat 0000644 0001750 0001750 00000000136 10616442116 022630 0 ustar osallou osallou
java -classpath .\sblat1.jar;..\f2jutil.jar;..\blas.jar; org.netlib.blas.testing.Sblat1
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist/test_slin.bat 0000644 0001750 0001750 00000000212 10616442116 022403 0 ustar osallou osallou
java -classpath .\slintest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.lin.Schkaa < stest.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist/test_blas3.sh 0000755 0001750 0001750 00000000154 10616163227 022321 0 ustar osallou osallou #!/bin/sh
java -classpath dblat3.jar:../f2jutil.jar:../blas.jar org.netlib.blas.testing.Dblat3 < dblat3.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist/test_sblas3.sh 0000755 0001750 0001750 00000000154 10616442116 022501 0 ustar osallou osallou #!/bin/sh
java -classpath sblat3.jar:../f2jutil.jar:../blas.jar org.netlib.blas.testing.Sblat3 < sblat3.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/examples/ 0000755 0001750 0001750 00000000000 11734055016 020570 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/examples/DgesvdTest.java 0000644 0001750 0001750 00000001246 10616163230 023506 0 ustar osallou osallou import org.netlib.util.*;
import org.netlib.lapack.Dgesvd;
public class DgesvdTest {
public static void main(String[] args) {
int M = 5;
int N = 3;
double[]m = {18.91, 14.91, -6.15, -18.15, 27.5, -1.59, -1.59, -2.25, -1.59, -2.25, -1.59, 1.59, 0.0, 1.59, 0.0};
double[]s = new double[m.length];
double[]u = new double[M*M];
double[]vt = new double[N*N];
double[]work = new double[Math.max(3*Math.min(M,N)+Math.max(M,N),5*Math.min(M,N))];
org.netlib.util.intW info = new org.netlib.util.intW(2);
Dgesvd.dgesvd("A","A",M,N,m, 0,M,s, 0,u, 0,M,vt,
0,N,work, 0,work.length,info);
System.out.println("info = " + info.val);
}
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/examples/DlaruvTest.java 0000644 0001750 0001750 00000001604 10616163230 023525 0 ustar osallou osallou import org.netlib.util.*;
import org.netlib.lapack.Dlaruv;
/**
* DlaruvTest - example of calling the Java version of Dlaruv (from LAPACK).
*
* To compile and run:
*
* bambam> javac -classpath .:f2jutil.jar:blas.jar:lapack.jar DlaruvTest.java
* bambam> java -classpath .:f2jutil.jar:blas.jar:lapack.jar:xerbla.jar DlaruvTest
* Answer =
* 0.5806943866373508 0.7878030027693832 0.22090042246633246 0.7438538655551419 0.2937111564915149 0.19260597967192794 0.46939556457146026 0.903349054003403 0.852466982480923 0.3357901748424048
*
**/
public class DlaruvTest {
public static void main(String [] args) {
int [] iseed = {1998, 1999, 2000, 2001};
double []x = new double [10];
int n = x.length;
Dlaruv.dlaruv(iseed,0,n,x,0);
System.out.println("Answer = ");
for(int i = 0; i < x.length; i++)
System.out.print(x[i] + " ");
System.out.println();
}
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/examples/DdotTest.java 0000644 0001750 0001750 00000001164 10616163230 023163 0 ustar osallou osallou import org.netlib.util.*;
import org.netlib.blas.Ddot;
/**
* DdotTest - example of calling the Java version of Ddot.
*
* To compile and run:
*
* bambam> javac -classpath .:f2jutil.jar:blas.jar DdotTest.java
* bambam> java -classpath .:f2jutil.jar:blas.jar DdotTest
* Answer = 36.3
*
**/
public class DdotTest {
public static void main(String [] args) {
double [] dx = {1.1, 2.2, 3.3, 4.4};
double [] dy = {1.1, 2.2, 3.3, 4.4};
int incx = 1;
int incy = 1;
int n = dx.length;
double answer;
answer = Ddot.ddot(n,dx,0,incx,dy,0,incy);
System.out.println("Answer = " + answer);
}
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/examples/DsygvTest.java 0000644 0001750 0001750 00000001773 10616163230 023373 0 ustar osallou osallou import org.netlib.util.*;
import org.netlib.lapack.Dsygv;
/**
* DsygvTest - example of calling the Java version of Dsygv (from LAPACK).
*
* To compile and run:
*
* # javac -classpath .:f2jutil.jar:blas.jar:lapack.jar DsygvTest.java
* # java -classpath .:f2jutil.jar:blas.jar:lapack.jar:xerbla.jar DsygvTest
* on return info = 0
*
**/
public class DsygvTest {
public static void main(String[] args) {
int itype = 1;
String jobz = new String("V");
String uplo = new String("U");
int n = 3;
double []a = {1.0, 2.0, 4.0, 0.0, 3.0, 5.0, 0.0, 0.0, 6.0};
int lda = 3;
double []b = {2.5298, 0.6405, 0.2091, 0.3798, 2.7833, 0.6808, 0.4611, 0.5678, 2.7942};
int ldb = 3;
double []w = new double[n];
int lwork = 9;
double []work = new double[lwork];
org.netlib.util.intW info = new org.netlib.util.intW(0);
Dsygv.dsygv(itype, jobz, uplo, n, a, 0, lda, b, 0,
ldb, w, 0, work, 0, lwork, info);
System.out.println("on return info = " + info.val);
}
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/examples/Makefile 0000644 0001750 0001750 00000002277 10625375111 022237 0 ustar osallou osallou JAVAC=javac
BLAS_CLASSPATH=.:../f2jutil.jar:../blas.jar
SIMPLE_BLAS_CLASSPATH=$(BLAS_CLASSPATH):../blas_simple.jar
LAPACK_CLASSPATH=$(BLAS_CLASSPATH):../lapack.jar:../xerbla.jar
SIMPLE_LAPACK_CLASSPATH=$(LAPACK_CLASSPATH):../lapack_simple.jar
all: DdotTest.class SimpleDdotTest.class DgesvdTest.class SimpleDgesvdTest.class \
DlaruvTest.class DsygvTest.class DstevrTest.class SimpleDsygvTest.class
DdotTest.class: DdotTest.java
$(JAVAC) -classpath $(BLAS_CLASSPATH) DdotTest.java
SimpleDdotTest.class: SimpleDdotTest.java
$(JAVAC) -classpath $(SIMPLE_BLAS_CLASSPATH) SimpleDdotTest.java
DlaruvTest.class: DlaruvTest.java
$(JAVAC) -classpath $(LAPACK_CLASSPATH) DlaruvTest.java
DsygvTest.class: DsygvTest.java
$(JAVAC) -classpath $(LAPACK_CLASSPATH) DsygvTest.java
DstevrTest.class: DstevrTest.java
$(JAVAC) -classpath $(LAPACK_CLASSPATH) DstevrTest.java
SimpleDsygvTest.class: SimpleDsygvTest.java
$(JAVAC) -classpath $(SIMPLE_LAPACK_CLASSPATH) SimpleDsygvTest.java
DgesvdTest.class: DgesvdTest.java
$(JAVAC) -classpath $(LAPACK_CLASSPATH) DgesvdTest.java
SimpleDgesvdTest.class: SimpleDgesvdTest.java
$(JAVAC) -classpath $(SIMPLE_LAPACK_CLASSPATH) SimpleDgesvdTest.java
clean:
/bin/rm -f *.class
jlapack-0.8~dfsg.orig/jlapack-3.1.1/examples/README 0000644 0001750 0001750 00000001577 10616163230 021456 0 ustar osallou osallou
JLAPACK Examples
----------------
This directory contains some basic examples showing how to call JLAPACK
routines. There is no error handling or anything fancy like that.
Sometimes I don't even initialize the arrays. It's just to show how
to arrange the calling sequence.
DdotTest.java - simple example of how to call a BLAS routine
SimpleDdotTest.java - example of calling a simplified interface from BLAS
DlaruvTest.java - simple example of how to call a LAPACK routine
DgesvdTest.java - another LAPACK example
DsygvTest.java - another LAPACK example
DstevrTest.java - another LAPACK example
SimpleDgesvdTest.java - example of calling a simplified interface from LAPACK
SimpleDsygvTest.java - example of calling a simplified interface from LAPACK
To build the examples, just do "make" here (after building JLAPACK of course).
jlapack-0.8~dfsg.orig/jlapack-3.1.1/examples/SimpleDgesvdTest.java 0000644 0001750 0001750 00000001337 10616163230 024661 0 ustar osallou osallou import org.netlib.util.*;
import org.netlib.lapack.DGESVD;
public class SimpleDgesvdTest {
public static void main(String[] args) {
double[][] m = {
{18.91, -1.59, -1.59},
{14.91, -1.59, 1.59},
{-6.15, -2.25, 0},
{-18.15, -1.59, 1.59},
{27.5, -2.25, 0}};
int M = m.length;
int N = m[0].length;
double[]s = new double[m.length];
double[][]u = new double[M][M];
double[][]vt = new double[N][N];
double[]work = new double[Math.max(3*Math.min(M,N)+Math.max(M,N),5*Math.min(M,N))];
org.netlib.util.intW info = new org.netlib.util.intW(2);
DGESVD.DGESVD("A", "A", M, N, m, s, u, vt,
work, work.length, info);
System.out.println("info = " + info.val);
}
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/examples/DstevrTest.java 0000644 0001750 0001750 00000004570 10616163230 023544 0 ustar osallou osallou import java.lang.*;
import org.netlib.util.*;
import org.netlib.lapack.Dstevr;
/**
* DstevrTest - example of calling DSTEVR (from LAPACK).
*
* To compile and run:
*
* # javac -classpath .:f2jutil.jar:blas.jar:lapack.jar DstevrTest.java
* # java -classpath .:f2jutil.jar:blas.jar:lapack.jar DstevrTest
* Selected eigenvalues
* 3.547002474892091 8.657766989006001
* Selected eigenvectors
* 0.33875494698229236 0.049369992446919496
* 0.8628096883458374 0.3780638984074957
* -0.36480280022104183 0.8557817766452163
* 0.08788313002203395 -0.3496681903300259
**/
public class DstevrTest {
public static void main (String [] args) {
double abstol= 0.0d;
double vl= 0.0d;
double vu= 0.0d;
int i= 0;
int ifail= 0;
int il= 0;
intW info= new intW(0);
int iu= 0;
int j= 0;
int liwopt= 0;
int lwopt= 0;
intW m= new intW(0);
int n= 0;
double [] d= new double[10];
double [] e= new double[10-1];
double [] w= new double[10];
double [] work= new double[200];
double [] z= new double[10 * 5];
int [] isuppz= new int[2*10];
int [] iwork= new int[100];
n = 4;
il = 2;
iu = 3;
d[0] = 1.0;
d[1] = 4.0;
d[2] = 9.0;
d[3] = 16.0;
e[0] = 1.0;
e[1] = 2.0;
e[2] = 3.0;
abstol = 0.0;
Dstevr.dstevr("Vectors", "Indices", n, d, 0, e, 0,
vl, vu, il, iu, abstol, m, w, 0, z, 0, 10, isuppz, 0,
work, 0, 200, iwork, 0, 100, info);
lwopt = (int)(work[0]);
liwopt = iwork[0];
if(info.val == 0) {
System.out.println("Selected eigenvalues");
System.out.print("");
for(j = 0; j < m.val; j++)
System.out.print(w[j] + " ");
System.out.println();
System.out.println("Selected eigenvectors");
for(i = 0; i < n; i++) {
for(j = 0; j < m.val; j++)
System.out.print(z[j*10+i] + " ");
System.out.println();
}
ifail = 0;
}
else
System.out.println("Failure in DSTEVR. INFO = " + info.val);
if(200 < lwopt) {
System.out.println();
System.out.println("Real workspace required = " + lwopt);
System.out.println("Real workspace provided = " + 200);
}
if (100 < liwopt) {
System.out.println();
System.out.println("Integer workspace required = " + liwopt);
System.out.println("Integer workspace provided = " + 100);
}
return;
}
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/examples/SimpleDdotTest.java 0000644 0001750 0001750 00000001256 10616163230 024337 0 ustar osallou osallou import org.netlib.util.*;
import org.netlib.blas.DDOT;
/**
* SimpleDdotTest - example of calling the simplified version of Ddot.
*
* To compile and run:
*
* bambam> javac -classpath .:f2jutil.jar:blas.jar:blas_simple.jar SimpleDdotTest.java
* bambam> java -classpath .:f2jutil.jar:blas.jar:blas_simple.jar SimpleDdotTest
* Answer = 36.3
*
**/
public class SimpleDdotTest {
public static void main(String [] args) {
double [] dx = {1.1, 2.2, 3.3, 4.4};
double [] dy = {1.1, 2.2, 3.3, 4.4};
int incx = 1;
int incy = 1;
int n = dx.length;
double answer;
answer = DDOT.DDOT(n,dx,incx,dy,incy);
System.out.println("Answer = " + answer);
}
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/examples/SimpleDsygvTest.java 0000644 0001750 0001750 00000002140 10616163230 024532 0 ustar osallou osallou import org.netlib.util.*;
import org.netlib.lapack.DSYGV;
/**
* SimpleDsygvTest - example of calling the simplified version of DSYGV (from LAPACK).
*
* To compile and run:
*
* # javac -classpath .:f2jutil.jar:blas.jar:lapack.jar:lapack_simple.jar:xerbla.jar SimpleDsygvTest.java
* # java -classpath .:f2jutil.jar:blas.jar:lapack.jar:lapack_simple.jar:xerbla.jar SimpleDsygvTest
* on return info = 0
*
**/
public class SimpleDsygvTest {
public static void main(String[] args) {
int itype = 1;
String jobz = new String("V");
String uplo = new String("U");
int n = 3;
double [][]a = {
{1.0, 2.0, 4.0},
{0.0, 3.0, 5.0},
{0.0, 0.0, 6.0}};
int lda = 3;
double [][]b = {
{2.5298, 0.6405, 0.2091},
{0.3798, 2.7833, 0.6808},
{0.4611, 0.5678, 2.7942}};
int ldb = 3;
double []w = new double[n];
int lwork = 9;
double []work = new double[lwork];
org.netlib.util.intW info = new org.netlib.util.intW(0);
DSYGV.DSYGV(itype, jobz, uplo, n, a, b, w, work, lwork, info);
System.out.println("on return info = " + info.val);
}
}
jlapack-0.8~dfsg.orig/jlapack-3.1.1/README 0000644 0001750 0001750 00000010600 10616442116 017626 0 ustar osallou osallou
JLAPACK 0.8
May 31, 2007
----------------
This directory should contain the following files:
README - this file
INSTALL - installation details
CHANGES - what has changed in this version
examples - directory containing a few examples of calling JLAPACK
The following jar files should exist:
blas.jar - the BLAS library
blas_simple.jar - the simplified interfaces to BLAS
lapack.jar - the LAPACK library
lapack_simple.jar - the simplified interfaces to LAPACK
xerbla.jar - LAPACK error reporting routine
f2jutil.jar - utilities required for running f2j translated code
If you downloaded the 'strict' distribution, there will be
four subdirectories:
strict_math_lib - calls java.lang.StrictMath instead of java.lang.Math,
but the methods are not declared as strictfp
strict_fp - methods are declared strictfp, but does not call
java.lang.StrictMath
strict_both - methods are declared strictfp and calls
java.lang.StrictMath
plain - not strict
Each of the subdirectories will contain all of the jar files mentioned
above.
In addition to raw translations of the numerical routines, the blas_simple
and lapack_simple jar files contain classes that provide a more Java-like
interface to the underlying numerical functions. There is one such class
for each numerical routine. The name of the class is simply the function
name in all caps. For example, the fortran routine 'ddot' is translated
into two classes: Ddot.java and DDOT.java. Ddot.java contains the actual
translation of the fortran code while DDOT.java contains only a call to
the real ddot (Ddot), but provides a more simple interface. Since the
interface may have to do matrix transposition and copying for some routines,
it is faster to use the 'raw' numerical routines.
API documentation for the BLAS and LAPACK can be found online at the
following URL:
http://www.cs.utk.edu/f2j/docs/html/packages.html
NOTES:
1. This release has not been tuned for performance - it is a simple,
automatic translation.
2. Some scalars must be wrapped in objects. The wrapper classes are
located in the org.netlib.util package. Therefore, your code
should contain "import org.netlib.util.*;" to have access to the
wrappers.
In addition, your code should import org.netlib.lapack.Blah or
org.netlib.blas.Blah, where Blah represents the routine your
code calls. See the files DdotTest.java and DlaruvTest.java
for examples.
3. See the warnings on recompilation in the INSTALL file.
4. If you are using a JVM with a JIT complier and encounter a
fault in calling JLAPACK, try turning off the JIT and report
the problem to f2j@cs.utk.edu.
5. The appropriate jar files should be in your CLASSPATH.
f2jutil.jar - should always be included
blas.jar - include if calling BLAS routines
lapack.jar - include if calling LAPACK routines
xerbla.jar - include for LAPACK error handling
So, if calling LAPACK, you'll want to include all four
jar files in your CLASSPATH.
You may customize your error handling by replacing xerbla.jar
with your own error reporting package.
The following two notes only apply to interfacing with the 'raw'
numerical routines, not the Java style front-ends.
6. All array arguments are followed by an extra "offset" argument.
This allows passing array subsections.
7. It is important to keep this in mind when interfacing Java code
to the JLAPACK routines: all multidimensional arrays are mapped
to one-dimensional arrays in the translated code and the original
column-major layout is maintained.
The following note only applies to using the Java style front-ends.
8. When you pass Java 2D arrays to one of the interface routines,
it will make a copy of it and convert it into a linearized 1D
array to be passed to the underlying numerical routine. If some
routine takes two matrices and you pass the same matrix for both
arguments, the interface will generate two copies of the same
array rather than the single copy that would normally be provided
to the underlying routine. Therefore, some inconsistency in the
results could occur.
Contact f2j@cs.utk.edu with any questions, comments, or suggestions.
jlapack-0.8~dfsg.orig/jlapack-3.1.1/INSTALL 0000644 0001750 0001750 00000003770 10616163227 020014 0 ustar osallou osallou
JLAPACK 0.8 Installation
All you need to do to get started with JLAPACK is set your CLASSPATH.
The following directions are for Solaris (using csh). Other UNIX platforms
should be very similar. MS-DOS and Windows users should consult their JDK
documentation to find out how to set the CLASSPATH.
If your CLASSPATH environment variable is already set, append the following
files to it:
$JLAPACK_HOME/f2jutil.jar
$JLAPACK_HOME/blas.jar
$JLAPACK_HOME/lapack.jar
$JLAPACK_HOME/xerbla.jar
where JLAPACK_HOME represents the full path of the directory where you have
JLAPACK installed.
You may omit lapack.jar if you only plan to call BLAS routines, however
the others should always be used.
If you plan to use the simplified interfaces, you will need to add the
corresponding jar files to your CLASSPATH:
$JLAPACK_HOME/blas_simple.jar -- for the simplified BLAS interface
$JLAPACK_HOME/lapack_simple.jar -- for the simplified LAPACK interface
For example, if your jlapack directory is /users/bob/jlapack/ the following
command would append the appropriate files to your CLASSPATH:
% setenv CLASSPATH $CLASSPATH":/users/bob/jlapack/f2jutil.jar:/users/bob/jlapack/blas.jar:/users/bob/jlapack/lapack.jar:/users/bob/jlapack/xerbla.jar"
If your CLASSPATH has not been set, you should set it to include the
current directory as well as the jar files previously mentioned.
For example:
% setenv CLASSPATH .:/users/bob/jlapack/f2jutil.jar:/users/bob/jlapack/blas.jar:/users/bob/jlapack/lapack.jar:/users/bob/jlapack/xerbla.jar
There are several basic test files in the $JLAPACK_HOME/examples subdirectory.
To verify that your CLASSPATH is properly set, attempt to build one of them
without using the Makefile. For example:
% javac DdotTest.java
If it compiles without any errors, try running it:
% java DdotTest
Answer = 36.3
If DdotTest.java will not compile, double-check the CLASSPATH setting
and the location of the class files. Take a look at the Makefile for
an example of setting up the CLASSPATH.
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist_timing/ 0000755 0001750 0001750 00000000000 11734055016 021264 5 ustar osallou osallou jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist_timing/time_seig_small.bat 0000644 0001750 0001750 00000001060 10616442116 025105 0 ustar osallou osallou java -Xmx500M -classpath seigtime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Stimee < sgeptim.in
java -Xmx500M -classpath seigtime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Stimee < sneptim.in
java -Xmx500M -classpath seigtime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Stimee < sseptim.in
java -Xmx500M -classpath seigtime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Stimee < ssvdtim.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist_timing/time_slin_small.bat 0000644 0001750 0001750 00000001500 10616442116 025122 0 ustar osallou osallou java -Xmx500M -classpath slintime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Stimaa < sband.in
java -Xmx500M -classpath slintime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Stimaa < sblasa.in
java -Xmx500M -classpath slintime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Stimaa < sblasb.in
java -Xmx500M -classpath slintime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Stimaa < sblasc.in
java -Xmx500M -classpath slintime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Stimaa < stime.in
java -Xmx500M -classpath slintime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Stimaa < stime2.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist_timing/time_seig_small.sh 0000755 0001750 0001750 00000001073 10616442116 024760 0 ustar osallou osallou #!/bin/sh
java -Xmx500M -classpath seigtime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Stimee < sgeptim.in
java -Xmx500M -classpath seigtime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Stimee < sneptim.in
java -Xmx500M -classpath seigtime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Stimee < sseptim.in
java -Xmx500M -classpath seigtime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Stimee < ssvdtim.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist_timing/time_slin_small.sh 0000755 0001750 0001750 00000001513 10616442116 024775 0 ustar osallou osallou #!/bin/sh
java -Xmx500M -classpath slintime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Stimaa < sband.in
java -Xmx500M -classpath slintime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Stimaa < sblasa.in
java -Xmx500M -classpath slintime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Stimaa < sblasb.in
java -Xmx500M -classpath slintime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Stimaa < sblasc.in
java -Xmx500M -classpath slintime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Stimaa < stime.in
java -Xmx500M -classpath slintime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Stimaa < stime2.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist_timing/time_eig_small.sh 0000755 0001750 0001750 00000001063 10616163230 024571 0 ustar osallou osallou #!/bin/sh
java -Xmx500M -classpath eigtime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Dtimee < dgeptim.in
java -Xmx500M -classpath eigtime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Dtimee < dneptim.in
java -Xmx500M -classpath eigtime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Dtimee < dseptim.in
java -Xmx500M -classpath eigtime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Dtimee < dsvdtim.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist_timing/time_slin_large.sh 0000755 0001750 0001750 00000001667 10616442116 024771 0 ustar osallou osallou #!/bin/sh
java -Xmx500M -classpath slintime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Stimaa < input_files_large/SBAND.in
java -Xmx500M -classpath slintime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Stimaa < input_files_large/SBLASA.in
java -Xmx500M -classpath slintime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Stimaa < input_files_large/SBLASB.in
java -Xmx500M -classpath slintime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Stimaa < input_files_large/SBLASC.in
java -Xmx500M -classpath slintime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Stimaa < input_files_large/STIME.in
java -Xmx500M -classpath slintime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Stimaa < input_files_large/STIME2.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist_timing/time_seig_large.sh 0000755 0001750 0001750 00000001203 10616442116 024735 0 ustar osallou osallou #!/bin/sh
java -Xmx500M -classpath seigtime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Stimee < input_files_large/SGEPTIM.in
java -Xmx500M -classpath seigtime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Stimee < input_files_large/SNEPTIM.in
java -Xmx500M -classpath seigtime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Stimee < input_files_large/SSEPTIM.in
java -Xmx500M -classpath seigtime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Stimee < input_files_large/SSVDTIM.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist_timing/README 0000644 0001750 0001750 00000007042 10616163230 022143 0 ustar osallou osallou JLAPACK timing routines README
May 31, 2007
----
NOTE: the timing routines weren't included in LAPACK 3.1. These are the timing
routines from 3.0. I'm not sure if they work with the 3.1 library, but I'm
keeping the files here as placeholders to drop in the timing code if it becomes
available.
----
This directory should contain:
README - this file
Timing Scripts for Double Precision:
time_eig_small.sh - Timer for LAPACK linear equation routines (small matrix sizes)
time_eig_small.bat - Windows version of the previous script
time_eig_large.sh - Timer for LAPACK linear equation routines (large matrix sizes)
time_eig_large.bat - Windows version of the previous script
time_lin_small.sh - Timer for LAPACK eigenvalue routines (small matrix sizes)
time_lin_small.bat - Windows version of the previous script
time_lin_large.sh - Timer for LAPACK eigenvalue routines (large matrix sizes)
time_lin_large.bat - Windows version of the previous script
Timing Scripts for Single Precision:
time_seig_small.sh - Timer for LAPACK linear equation routines (small matrix sizes)
time_seig_small.bat - Windows version of the previous script
time_seig_large.sh - Timer for LAPACK linear equation routines (large matrix sizes)
time_seig_large.bat - Windows version of the previous script
time_slin_small.sh - Timer for LAPACK eigenvalue routines (small matrix sizes)
time_slin_small.bat - Windows version of the previous script
time_slin_large.sh - Timer for LAPACK eigenvalue routines (large matrix sizes)
time_slin_large.bat - Windows version of the previous script
Jar Files for Double Precision:
eigtime.jar - LAPACK eigenvalue timing code
lintime.jar - LAPACK linear equation timing code
matgen.jar - support routines for the timers
Jar Files for Single Precision:
seigtime.jar - LAPACK eigenvalue timing code
slintime.jar - LAPACK linear equation timing code
smatgen.jar - support routines for the timers
Double Precision Linear Equation Timer Input Files (small sizes):
dband.in
dblasa.in
dblasb.in
dblasc.in
dtime.in
dtime2.in
Single Precision Linear Equation Timer Input Files (small sizes):
sband.in
sblasa.in
sblasb.in
sblasc.in
stime.in
stime2.in
Double Precision Eigenvalue Timer Input Files (small sizes):
dgeptim.in
dseptim.in
dneptim.in
dsvdtim.in
Single Precision Eigenvalue Timer Input Files (small sizes):
sgeptim.in
sseptim.in
sneptim.in
ssvdtim.in
The following input files for large matrix sizes are located in the
subdirectory named "input_files_large":
Double Precision Linear Equation Timer Input Files (large sizes):
DBAND.in
DBLASB.in
DTIME.in
DBLASA.in
DBLASC.in
DTIME2.in
Single Precision Linear Equation Timer Input Files (large sizes):
SBAND.in
SBLASA.in
SBLASB.in
SBLASC.in
STIME.in
STIME2.in
Double Precision Eigenvalue Timer Input Files (large sizes):
DGEPTIM.in
DSEPTIM.in
DNEPTIM.in
DSVDTIM.in
Single Precision Eigenvalue Timer Input Files (large sizes):
SGEPTIM.in
SSEPTIM.in
SNEPTIM.in
SSVDTIM.in
To run the timers, simply execute the appropriate script, which
depends on the operating system you are running.
Some of the output is not exactly as the Fortran versions
would be (e.g. some arrays are printed as "NULL", but that is
only a limitation of the f2j I/O handling), however this
does not affect the running of the timers.
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist_timing/time_lin_small.bat 0000644 0001750 0001750 00000001464 10616163230 024745 0 ustar osallou osallou java -Xmx500M -classpath lintime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Dtimaa < dband.in
java -Xmx500M -classpath lintime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Dtimaa < dblasa.in
java -Xmx500M -classpath lintime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Dtimaa < dblasb.in
java -Xmx500M -classpath lintime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Dtimaa < dblasc.in
java -Xmx500M -classpath lintime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Dtimaa < dtime.in
java -Xmx500M -classpath lintime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Dtimaa < dtime2.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist_timing/time_lin_large.bat 0000644 0001750 0001750 00000001640 10616163230 024723 0 ustar osallou osallou java -Xmx500M -classpath lintime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Dtimaa < input_files_large\DBAND.in
java -Xmx500M -classpath lintime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Dtimaa < input_files_large\DBLASA.in
java -Xmx500M -classpath lintime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Dtimaa < input_files_large\DBLASB.in
java -Xmx500M -classpath lintime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Dtimaa < input_files_large\DBLASC.in
java -Xmx500M -classpath lintime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Dtimaa < input_files_large\DTIME.in
java -Xmx500M -classpath lintime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Dtimaa < input_files_large\DTIME2.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist_timing/time_eig_small.bat 0000644 0001750 0001750 00000001050 10616163230 024716 0 ustar osallou osallou java -Xmx500M -classpath eigtime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Dtimee < dgeptim.in
java -Xmx500M -classpath eigtime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Dtimee < dneptim.in
java -Xmx500M -classpath eigtime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Dtimee < dseptim.in
java -Xmx500M -classpath eigtime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Dtimee < dsvdtim.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist_timing/time_seig_large.bat 0000644 0001750 0001750 00000001170 10616442116 025071 0 ustar osallou osallou java -Xmx500M -classpath seigtime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Stimee < input_files_large\SGEPTIM.in
java -Xmx500M -classpath seigtime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Stimee < input_files_large\SNEPTIM.in
java -Xmx500M -classpath seigtime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Stimee < input_files_large\SSEPTIM.in
java -Xmx500M -classpath seigtime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Stimee < input_files_large\SSVDTIM.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist_timing/time_lin_large.sh 0000755 0001750 0001750 00000001653 10616163230 024576 0 ustar osallou osallou #!/bin/sh
java -Xmx500M -classpath lintime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Dtimaa < input_files_large/DBAND.in
java -Xmx500M -classpath lintime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Dtimaa < input_files_large/DBLASA.in
java -Xmx500M -classpath lintime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Dtimaa < input_files_large/DBLASB.in
java -Xmx500M -classpath lintime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Dtimaa < input_files_large/DBLASC.in
java -Xmx500M -classpath lintime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Dtimaa < input_files_large/DTIME.in
java -Xmx500M -classpath lintime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Dtimaa < input_files_large/DTIME2.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist_timing/time_slin_large.bat 0000644 0001750 0001750 00000001654 10616442116 025116 0 ustar osallou osallou java -Xmx500M -classpath slintime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Stimaa < input_files_large\SBAND.in
java -Xmx500M -classpath slintime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Stimaa < input_files_large\SBLASA.in
java -Xmx500M -classpath slintime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Stimaa < input_files_large\SBLASB.in
java -Xmx500M -classpath slintime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Stimaa < input_files_large\SBLASC.in
java -Xmx500M -classpath slintime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Stimaa < input_files_large\STIME.in
java -Xmx500M -classpath slintime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Stimaa < input_files_large\STIME2.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist_timing/time_eig_large.bat 0000644 0001750 0001750 00000001160 10616163230 024702 0 ustar osallou osallou java -Xmx500M -classpath eigtime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Dtimee < input_files_large\DGEPTIM.in
java -Xmx500M -classpath eigtime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Dtimee < input_files_large\DNEPTIM.in
java -Xmx500M -classpath eigtime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Dtimee < input_files_large\DSEPTIM.in
java -Xmx500M -classpath eigtime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Dtimee < input_files_large\DSVDTIM.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist_timing/time_lin_small.sh 0000755 0001750 0001750 00000001477 10616163230 024620 0 ustar osallou osallou #!/bin/sh
java -Xmx500M -classpath lintime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Dtimaa < dband.in
java -Xmx500M -classpath lintime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Dtimaa < dblasa.in
java -Xmx500M -classpath lintime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Dtimaa < dblasb.in
java -Xmx500M -classpath lintime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Dtimaa < dblasc.in
java -Xmx500M -classpath lintime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Dtimaa < dtime.in
java -Xmx500M -classpath lintime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Dtimaa < dtime2.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/dist_timing/time_eig_large.sh 0000755 0001750 0001750 00000001173 10616163230 024555 0 ustar osallou osallou #!/bin/sh
java -Xmx500M -classpath eigtime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Dtimee < input_files_large/DGEPTIM.in
java -Xmx500M -classpath eigtime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Dtimee < input_files_large/DNEPTIM.in
java -Xmx500M -classpath eigtime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Dtimee < input_files_large/DSEPTIM.in
java -Xmx500M -classpath eigtime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Dtimee < input_files_large/DSVDTIM.in
jlapack-0.8~dfsg.orig/jlapack-3.1.1/CHANGES 0000644 0001750 0001750 00000011250 10616442116 017743 0 ustar osallou osallou ---------------------------------------------------------------------------
JLAPACK 0.8 -- released May 31, 2007
This is a beta release of JLAPACK based on LAPACK version 3.1.1.
The previous translation was based on version 3.0, so there have been
many changes to LAPACK since then. See the following for details:
http://www.netlib.org/lapack/lapack-3.1.0.changes
http://www.netlib.org/lapack/lapack-3.1.1.changes
As with the previous version, there are single and double precision
versions of all routines (no complex yet) with different Java strictfp
modes available.
Translation of formatted output in the testers is also improved.
The single and double precision jar files have been merged.
---------------------------------------------------------------------------
JLAPACK 0.7 -- released January 31, 2007
There are several improvements in this release. First, there are
now single precision versions of all the BLAS and LAPACK libraries
as well as testers. There are versions of the libraries
that use Java's strict floating point mode and strict version of
the Java math library. Also for this release, there are translations
of the LAPACK timing routines.
---------------------------------------------------------------------------
JLAPACK 0.6-strict -- released December 7, 2006
This release contains versions of JLAPACK that use Java's strict
floating-point features. Otherwise, it should be the same as 0.6.
---------------------------------------------------------------------------
JLAPACK 0.6 -- released January 14, 2002
Changed the way that variables are declared. f2j now generates variables
as local to the method (where possible). This normally gives better
performance than using static class variables.
Fixed a bug in the simplified interfaces. Thanks to Michael DiClemente
for the bug report.
---------------------------------------------------------------------------
JLAPACK 0.5 -- released August 23, 2001
This version can be generated either as Java source or directly as
JVM bytecode. The main change for 0.5 is that the library is based
on the LAPACK 3.0 source code.
---------------------------------------------------------------------------
JLAPACK 0.4 -- unreleased
This was the first version generated directly as JVM bytecode. This
version was never released because it was based on the LAPACK 2.0 sources
and we wanted the next release to be based on the LAPACK 3.0 sources.
---------------------------------------------------------------------------
JLAPACK 0.3a released June 5, 1998
This is an update to version 0.3, only minor changes have been made.
This release is reorganized a bit to make life easier on Win 95/NT
users. The JLAPACK classes are now all grouped into one ZIP file,
much like the core Java classes. So, users should adjust their
CLASSPATH to point at the ZIP file instead of jlapack-0.3/classes.
The INSTALL file has details.
Also the source code for the simplified interfaces is now stored in
the "ssrc" directory, rather than in "src".
---------------------------------------------------------------------------
JLAPACK 0.3 released May 22, 1998
This is the first general release of JLAPACK.
The major change for this release is that we no longer wrap every
scalar in a wrapper. We wrap only those scalars that really need
to be wrapped - that is, they are modified in the function/subroutine
or in some called function/subroutine. This helps a lot in the BLAS
and LAPACK libraries since most scalars are not modified. Of course,
this means that the interface is totally different from the previous
version.
This release contains some simplified front-ends to the numerical
routines. They should provide a more "Java-like" interface to the
underlying functions by accepting row-major 2D arrays and omitting
unnecessary parameters such as leading dimension and offset.
Comments from the original fortran source code are now retained
in the Java source.
This release was compiled with Sun's JDK 1.1.6 on Solaris 2.5 with
optimization turned off (using -O didn't seem to help much).
---------------------------------------------------------------------------
JLAPACK 0.2 released Apr 15, 1998
This release is organized into packages:
org.netlib.blas - BLAS
org.netlib.lapack - LAPACK
org.netlib.util - utilities needed by f2java-translated programs
This release was also compiled with optimization on.
---------------------------------------------------------------------------
JLAPACK 0.1 released Apr 1, 1998
This is basically an early evaluation version distributed to only
a few people.
---------------------------------------------------------------------------
jlapack-0.8~dfsg.orig/jlapack-3.1.1/make.def 0000644 0001750 0001750 00000014717 10616442116 020360 0 ustar osallou osallou VERSION=jlapack-0.8
F2J=f2java
JAVA=java
MORE_MEM_FLAG=-Xmx500M
JAVAC=javac -source 1.4 -target 1.4
JAVAB=javab
JAR=jar
# JAR=/usr/bin/jar
ZIP=zip
TAR=tar
TARFLAGS=chvf
GZIP=gzip
VERIFY=de.fub.bytecode.verifier.Verifier
JUSTICE=$$HOME/bin/JustIce.jar
BCEL=$$HOME/bin/BCEL.jar
# uncomment and set the following to override the user's JFLAGS setting
# JFLAGS=
# uncomment the following to force all locals to be emitted static
# STATIC=-vs
SRCDIR=src
DISTDIR_TESTING=dist
DISTDIR_TIMING=dist_timing
OUTDIR=obj
JAVASRC_OUTDIR=javasrc_obj
UTIL_JAR=f2jutil.jar
ERR_JAR=xerbla.jar
BLAS_JAR=blas.jar
SIMPLE_BLAS_JAR=blas_simple.jar
LAPACK_JAR=lapack.jar
SIMPLE_LAPACK_JAR=lapack_simple.jar
LIBDIST_ZIP=$(VERSION).zip
LIBDIST_TGZ=$(VERSION).tgz
LIBDIST_STRICT_ZIP=$(VERSION)-strict.zip
LIBDIST_STRICT_TGZ=$(VERSION)-strict.tgz
TESTERS_DIST_ZIP=$(VERSION)-testers.zip
TESTERS_DIST_TGZ=$(VERSION)-testers.tgz
TIMERS_DIST_ZIP=$(VERSION)-timers.zip
TIMERS_DIST_TGZ=$(VERSION)-timers.tgz
JAVADOC_DIST_ZIP=$(VERSION)-javadoc.zip
JAVADOC_DIST_TGZ=$(VERSION)-javadoc.tgz
BLAS1TEST_JAR=dblat1.jar
BLAS2TEST_JAR=dblat2.jar
BLAS3TEST_JAR=dblat3.jar
SBLAS1TEST_JAR=sblat1.jar
SBLAS2TEST_JAR=sblat2.jar
SBLAS3TEST_JAR=sblat3.jar
EIGTEST_JAR=eigtest.jar
SEIGTEST_JAR=seigtest.jar
LINTEST_JAR=lintest.jar
SLINTEST_JAR=slintest.jar
MATGEN_JAR=matgen.jar
SMATGEN_JAR=smatgen.jar
EIGTIME_JAR=eigtime.jar
SEIGTIME_JAR=seigtime.jar
LINTIME_JAR=lintime.jar
SLINTIME_JAR=slintime.jar
BLAS1TEST_SH=test_blas1.sh
BLAS2TEST_SH=test_blas2.sh
BLAS3TEST_SH=test_blas3.sh
SBLAS1TEST_SH=test_sblas1.sh
SBLAS2TEST_SH=test_sblas2.sh
SBLAS3TEST_SH=test_sblas3.sh
LINTEST_SH=test_lin.sh
SLINTEST_SH=test_slin.sh
EIGTEST_SH=test_eig.sh
SEIGTEST_SH=test_seig.sh
BLAS1TEST_BAT=test_blas1.bat
BLAS2TEST_BAT=test_blas2.bat
BLAS3TEST_BAT=test_blas3.bat
SBLAS1TEST_BAT=test_sblas1.bat
SBLAS2TEST_BAT=test_sblas2.bat
SBLAS3TEST_BAT=test_sblas3.bat
LINTEST_BAT=test_lin.bat
SLINTEST_BAT=test_slin.bat
EIGTEST_BAT=test_eig.bat
SEIGTEST_BAT=test_seig.bat
UTIL_DIR=$(SRCDIR)/util
UTIL_F2J_SRC_DIR=../util
BLAS_DIR=$(SRCDIR)/blas
ERR_DIR=$(SRCDIR)/error_reporting
LAPACK_DIR=$(SRCDIR)/lapack
TESTING_DIR=$(SRCDIR)/testing
MATGEN_DIR=$(TESTING_DIR)/matgen
SMATGEN_DIR=$(TESTING_DIR)/smatgen
EIGTEST_DIR=$(TESTING_DIR)/eig
SEIGTEST_DIR=$(TESTING_DIR)/seig
LINTEST_DIR=$(TESTING_DIR)/lin
SLINTEST_DIR=$(TESTING_DIR)/slin
BLAS1TEST_DIR=$(TESTING_DIR)/blas1
BLAS2TEST_DIR=$(TESTING_DIR)/blas2
BLAS3TEST_DIR=$(TESTING_DIR)/blas3
SBLAS1TEST_DIR=$(TESTING_DIR)/sblas1
SBLAS2TEST_DIR=$(TESTING_DIR)/sblas2
SBLAS3TEST_DIR=$(TESTING_DIR)/sblas3
TIMING_DIR=$(SRCDIR)/timing
SIMPLE_DIR=simple
UTIL_OBJ=$(UTIL_DIR)/$(OUTDIR)
MATGEN_OBJ=$(MATGEN_DIR)/$(OUTDIR)
SMATGEN_OBJ=$(SMATGEN_DIR)/$(OUTDIR)
BLAS_OBJ=$(BLAS_DIR)/$(OUTDIR)
ERR_OBJ=$(ERR_DIR)/$(OUTDIR)
LAPACK_OBJ=$(LAPACK_DIR)/$(OUTDIR)
EIGTEST_OBJ=$(EIGTEST_DIR)/$(OUTDIR)
SEIGTEST_OBJ=$(SEIGTEST_DIR)/$(OUTDIR)
LINTEST_OBJ=$(LINTEST_DIR)/$(OUTDIR)
SLINTEST_OBJ=$(SLINTEST_DIR)/$(OUTDIR)
BLAS1TEST_OBJ=$(BLAS1TEST_DIR)/$(OUTDIR)
BLAS2TEST_OBJ=$(BLAS2TEST_DIR)/$(OUTDIR)
BLAS3TEST_OBJ=$(BLAS3TEST_DIR)/$(OUTDIR)
SBLAS1TEST_OBJ=$(SBLAS1TEST_DIR)/$(OUTDIR)
SBLAS2TEST_OBJ=$(SBLAS2TEST_DIR)/$(OUTDIR)
SBLAS3TEST_OBJ=$(SBLAS3TEST_DIR)/$(OUTDIR)
MATGEN_IDX=$(MATGEN_OBJ)/Matgen.f2j
SMATGEN_IDX=$(SMATGEN_OBJ)/Smatgen.f2j
BLAS_IDX=$(BLAS_OBJ)/Blas.f2j
ERR_IDX=$(ERR_OBJ)/Err.f2j
LAPACK_IDX=$(LAPACK_OBJ)/Lapack.f2j
EIGTEST_IDX=$(EIGTEST_OBJ)/Eigtest.f2j
SEIGTEST_IDX=$(SEIGTEST_OBJ)/Seigtest.f2j
LINTEST_IDX=$(LINTEST_OBJ)/Lintest.f2j
SLINTEST_IDX=$(SLINTEST_OBJ)/Slintest.f2j
BLAS1TEST_IDX=$(BLAS1TEST_OBJ)/Dblat1.f2j
BLAS2TEST_IDX=$(BLAS2TEST_OBJ)/Dblat2.f2j
BLAS3TEST_IDX=$(BLAS3TEST_OBJ)/Dblat3.f2j
SBLAS1TEST_IDX=$(SBLAS1TEST_OBJ)/Sblat1.f2j
SBLAS2TEST_IDX=$(SBLAS2TEST_OBJ)/Sblat2.f2j
SBLAS3TEST_IDX=$(SBLAS3TEST_OBJ)/Sblat3.f2j
UTIL_PACKAGE=org.netlib.util
UTIL_PDIR=org/netlib/util
BLAS_PACKAGE=org.netlib.blas
BLAS_PDIR=org/netlib/blas
ERR_PACKAGE=org.netlib.err
ERR_PDIR=org/netlib/err
LAPACK_PACKAGE=org.netlib.lapack
LAPACK_PDIR=org/netlib/lapack
BLASTEST_PACKAGE=org.netlib.blas.testing
BLASTEST_PDIR=org/netlib/blas/testing
SBLASTEST_PACKAGE=org.netlib.blas.testing
SBLASTEST_PDIR=org/netlib/blas/testing
MATGEN_PACKAGE=org.netlib.lapack.testing.matgen
MATGEN_PDIR=org/netlib/lapack/testing/matgen
SMATGEN_PACKAGE=org.netlib.lapack.testing.matgen
SMATGEN_PDIR=org/netlib/lapack/testing/matgen
EIGTEST_PACKAGE=org.netlib.lapack.testing.eig
EIGTEST_PDIR=org/netlib/lapack/testing/eig
SEIGTEST_PACKAGE=org.netlib.lapack.testing.eig
SEIGTEST_PDIR=org/netlib/lapack/testing/eig
LINTEST_PACKAGE=org.netlib.lapack.testing.lin
LINTEST_PDIR=org/netlib/lapack/testing/lin
SLINTEST_PACKAGE=org.netlib.lapack.testing.lin
SLINTEST_PDIR=org/netlib/lapack/testing/lin
EIGTIME_DIR=$(TIMING_DIR)/eig
SEIGTIME_DIR=$(TIMING_DIR)/seig
LINTIME_DIR=$(TIMING_DIR)/lin
SLINTIME_DIR=$(TIMING_DIR)/slin
EIGTIME_OBJ=$(EIGTIME_DIR)/$(OUTDIR)
SEIGTIME_OBJ=$(SEIGTIME_DIR)/$(OUTDIR)
LINTIME_OBJ=$(LINTIME_DIR)/$(OUTDIR)
SLINTIME_OBJ=$(SLINTIME_DIR)/$(OUTDIR)
EIGTIME_IDX=$(EIGTIME_OBJ)/Eigtime.f2j
SEIGTIME_IDX=$(SEIGTIME_OBJ)/Seigtime.f2j
LINTIME_IDX=$(LINTIME_OBJ)/Lintime.f2j
SLINTIME_IDX=$(SLINTIME_OBJ)/Slintime.f2j
EIGTIME_PACKAGE=org.netlib.lapack.timing.eig
EIGTIME_PDIR=org/netlib/lapack/timing/eig
SEIGTIME_PACKAGE=org.netlib.lapack.timing.eig
SEIGTIME_PDIR=org/netlib/lapack/timing/eig
LINTIME_PACKAGE=org.netlib.lapack.timing.lin
LINTIME_PDIR=org/netlib/lapack/timing/lin
SLINTIME_PACKAGE=org.netlib.lapack.timing.lin
SLINTIME_PDIR=org/netlib/lapack/timing/lin
EIGSRC_PACKAGE=org.netlib.lapack.timing.eig.eigsrc
EIGSRC_PDIR=org/netlib/lapack/timing/eig/eigsrc
SEIGSRC_PACKAGE=org.netlib.lapack.timing.eig.eigsrc
SEIGSRC_PDIR=org/netlib/lapack/timing/eig/eigsrc
LINSRC_PACKAGE=org.netlib.lapack.timing.lin.linsrc
LINSRC_PDIR=org/netlib/lapack/timing/lin/linsrc
SLINSRC_PACKAGE=org.netlib.lapack.timing.lin.linsrc
SLINSRC_PDIR=org/netlib/lapack/timing/lin/linsrc
UTIL_CLASSES=$(OUTDIR)/$(UTIL_PDIR)/Dsign.class \
$(OUTDIR)/$(UTIL_PDIR)/Dummy.class \
$(OUTDIR)/$(UTIL_PDIR)/EasyIn.class \
$(OUTDIR)/$(UTIL_PDIR)/Etime.class \
$(OUTDIR)/$(UTIL_PDIR)/LAprint.class \
$(OUTDIR)/$(UTIL_PDIR)/MatConv.class \
$(OUTDIR)/$(UTIL_PDIR)/Second.class \
$(OUTDIR)/$(UTIL_PDIR)/StringW.class \
$(OUTDIR)/$(UTIL_PDIR)/Util.class \
$(OUTDIR)/$(UTIL_PDIR)/Xerbla.class \
$(OUTDIR)/$(UTIL_PDIR)/booleanW.class \
$(OUTDIR)/$(UTIL_PDIR)/doubleW.class \
$(OUTDIR)/$(UTIL_PDIR)/floatW.class \
$(OUTDIR)/$(UTIL_PDIR)/intW.class